!>
!!##NAME
!!    M_attr(3f) - [M_attr::INTRO] control text attributes on terminals
!!    (LICENSE:MIT)
!!
!!##SYNOPSIS
!!
!!   core functions
!!
!!      ! Add text attributes like color with an HTML-like syntax
!!      use M_attr, only : attr
!!      ! suppress the escape sequence output
!!      use M_attr, only : attr_mode
!!      ! customize what output strings are produced
!!      use M_attr, only : attr_update
!!
!!   for generating standard messages
!!
!!      use M_attr, only : alert
!!
!!##DESCRIPTION
!!    M_attr(3f) is a Fortran module that writes common ANSI escape sequences
!!    which control terminal text attributes. It is designed to allow the
!!    sequences to be suppressed when desired and for the user program to
!!    completely customize the keywords -- the user can add, delete and
!!    replace the sequences associated with a keyword without changing
!!    the code.
!!
!!    Attributes are specified by writing lines with HTML-like structure.
!!
!!    The advantage of the approach of replacing in-band escape sequences
!!    with formatting directives contained on each line is that it is easy
!!    to turn off when running batch, but more importantly your program can
!!    be run in "raw" mode and write a clean text file with the directives in
!!    it that can then be read back in by a simple filter program that strips
!!    it back to plain text( see app/plain.f90), or displays it to a screen
!!    in color(see app/light.f90) or perhaps converts it to another format.
!!
!!    By making each line self-contained (by default) this can still be done
!!    with any arbitrarily selected group of lines from the file.
!!
!!    So this module makes it trivial to read specially-formatted data
!!    from a file like a message catalog (perhaps with various versions
!!    in different languages) and colorize it or display it as plain text
!!    using the attr(3f) procedure.
!!##ACCESS
!!    Via git(1):
!!
!!        git clone https://github.com/urbanjost/M_attr.git
!!        cd M_attr/src
!!        # change Makefile if not using one of the listed compilers
!!        make clean; make gfortran    # for gfortran
!!        make clean; make ifort       # for ifort
!!        make clean; make nvfortran   # for nvfortran
!!
!!    This will compile the M_attr module and example programs.
!!
!!    Via fpm ( described at https://github.com/fortran-lang/fpm):
!!
!!         git clone https://github.com/urbanjost/M_attr.git
!!
!!    or just list it as a dependency in your fpm.toml project file.
!!
!!         [dependencies]
!!         M_attr        = { git = "https://github.com/urbanjost/M_attr.git" }
!!
!!##LIMITATIONS
!!   o colors are not nestable.
!!   o keywords are case-sensitive,
!!   o ANSI escape sequences are not universally supported by
!!     all terminal emulators; and normally should be suppressed
!!     when not going to a tty device. Therefore, you should use
!!     M_system::system_istty(3f) or the common Fortran extension
!!     ISATTY() to set the default to "plain" instead of "color"
!!     when the output file is not a conforming terminal. On basic
!!     MSWindows console windows, it is best to use Windows 10+ and/or
!!     the Linux mode; you may have to enable ANSI escape sequence
!!     mode on MSWindows. It does work as-is with CygWin and MinGW and
!!     Putty windows and mintty(1) as tested.
!!
!!##EXAMPLE
!!
!!    Sample program
!!
!!     program demo_M_attr
!!     use M_attr, only : attr, attr_mode, attr_update, alert
!!     implicit none
!!     character(len=256) :: line
!!     character(len=*),parameter :: f='( &
!!      &"   <bo><w><G> GREAT: </G></w>&
!!      &The new value <Y><b>",f8.4,1x,"</b></Y> is in range"&
!!      &)'
!!     real :: value
!!
!!        write(*,'(a)')&
!!        &attr('   <r><W><bo> ERROR: </W>red text on a white background</y>')
!!
!!        value=3.4567
!!        write(line,fmt=f) value
!!        write(*,'(a)')attr(trim(line))
!!
!!        ! write same string as plain text
!!        write(*,*)
!!        call attr_mode(manner='plain')
!!        write(*,'(a)')attr(trim(line))
!!
!!        call attr_mode(manner='color')
!!        ! use pre-defined or user defined strings
!!        write(*,*)
!!        write(*,'(a)')attr('<ERROR> Woe is nigh.')
!!        write(*,'(a)')attr('<WARNING> The night is young.')
!!        write(*,'(a)')attr('<INFO> It is Monday')
!!
!!        call alert('<ERROR>', 'Woe is nigh.')
!!        call alert('<WARNING>', 'The night is young.')
!!        call alert('<INFO>', 'It is Monday')
!!
!!        ! create a custom mnemonic
!!        call attr_update('MYERROR',attr(&
!!        ' <R><e> E<w>-<e>R<w>-<e>R<w>-<e>O<w>-<e>R: </e></R></bo>'&
!!        ))
!!        write(*,*)
!!        write(*,'(a)')attr('<MYERROR> my custom message style')
!!
!!     end program demo_M_attr
!!
!!##AUTHOR
!!    John S. Urban, 2021
!!
!!##LICENSE
!!    MIT
!!
!!##SEE ALSO
!!    attr(3f), attr_mode(3f), attr_update(3f)
!!
!!    Related information:
!!
!!     terminfo(3c), termlib(3c), tput(1), reset(1), clear(1),
!!     console_codes(4), ECMA-48,
!!     https://en.wikipedia.org/wiki/ANSI_escape_code
module M_attr
use, intrinsic :: iso_fortran_env, only : stderr=>ERROR_UNIT,stdin=>INPUT_UNIT,stdout=>OUTPUT_UNIT
use, intrinsic :: iso_c_binding, only: c_int
implicit none
private
public  :: attr
public  :: attr_mode
public  :: attr_update
public  :: alert, advice

private :: attr_matrix
private :: attr_scalar
private :: attr_scalar_width
private :: get

private :: locate   ! find PLACE in sorted character array where value can be found or should be placed
private :: insert   ! insert entry into a sorted allocatable array at specified position
private :: replace  ! replace entry by index from a sorted allocatable array if it is present
private :: remove   ! delete entry by index from a sorted allocatable array if it is present
private :: wipe_dictionary

private :: vt102

interface attr
   module procedure attr_scalar
   module procedure attr_matrix
   module procedure attr_scalar_width
end interface

interface advice  ! deprecated old name for alert(3f)
   module procedure alert
end interface

! direct use of constant strings

character(len=:),allocatable,save :: keywords(:)
character(len=:),allocatable,save :: values(:)
character(len=:),allocatable,save :: mono_values(:)

character(len=:),allocatable,save :: mode

! mnemonics
character(len=*),parameter  :: NL=new_line('a')                     ! New line character.
! DECIMAL
! *-------*-------*-------*-------*-------*-------*-------*-------*
! | 00 nul| 01 soh| 02 stx| 03 etx| 04 eot| 05 enq| 06 ack| 07 bel|
! | 08 bs | 09 ht | 10 nl | 11 vt | 12 np | 13 cr | 14 so | 15 si |
! | 16 dle| 17 dc1| 18 dc2| 19 dc3| 20 dc4| 21 nak| 22 syn| 23 etb|
! | 24 can| 25 em | 26 sub| 27 esc| 28 fs | 29 gs | 30 rs | 31 us |
! | 32 sp | 33  ! | 34  " | 35  # | 36  $ | 37  % | 38  & | 39  ' |
! | 40  ( | 41  ) | 42  * | 43  + | 44  , | 45  - | 46  . | 47  / |
! | 48  0 | 49  1 | 50  2 | 51  3 | 52  4 | 53  5 | 54  6 | 55  7 |
! | 56  8 | 57  9 | 58  : | 59  ; | 60  < | 61  = | 62  > | 63  ? |
! | 64  @ | 65  A | 66  B | 67  C | 68  D | 69  E | 70  F | 71  G |
! | 72  H | 73  I | 74  J | 75  K | 76  L | 77  M | 78  N | 79  O |
! | 80  P | 81  Q | 82  R | 83  S | 84  T | 85  U | 86  V | 87  W |
! | 88  X | 89  Y | 90  Z | 91  [ | 92  \ | 93  ] | 94  ^ | 95  _ |
! | 96  ` | 97  a | 98  b | 99  c |100  d |101  e |102  f |103  g |
! |104  h |105  i |106  j |107  k |108  l |109  m |110  n |111  o |
! |112  p |113  q |114  r |115  s |116  t |117  u |118  v |119  w |
! |120  x |121  y |122  z |123  { |124  | |125  } |126  ~ |127 del|
! *-------*-------*-------*-------*-------*-------*-------*-------*
character(len=*),parameter  :: nul=achar(0)
character(len=*),parameter  :: bel =achar(7)   ! ^G beeps;
character(len=*),parameter  :: bs =achar(8)    ! ^H backspaces one column (but not past the beginning of the line);
character(len=*),parameter  :: ht =achar(9)    ! ^I goes to next tab stop or to the end of the line if there is no earlier tab stop
character(len=*),parameter  :: lf =achar(10)   ! ^J
character(len=*),parameter  :: vt =achar(11)   ! ^K
character(len=*),parameter  :: ff =achar(12)   ! ^L all give a linefeed, and if LF/NL (new-line mode) is set also a carriage return
character(len=*),parameter  :: cr =achar(13)   ! ^M gives a carriage return;
character(len=*),parameter  :: so =achar(14)   ! ^N activates the G1 character set;
character(len=*),parameter  :: si =achar(15)   ! ^O activates the G0 character set;
character(len=*),parameter  :: can =achar(24)  ! ^X interrupt escape sequences;
character(len=*),parameter  :: sub=achar(26)   ! ^Z interrupt escape sequences;
character(len=*),parameter  :: esc =achar(27)  ! ^[ starts an escape sequence;
character(len=*),parameter  :: del =achar(127) ! is ignored;
! codes
character(len=*),parameter  :: CODE_START=esc//'['               ! Start ANSI code, "\[".
character(len=*),parameter  :: CODE_END='m'                         ! End ANSI code, "m".
character(len=*),parameter  :: CODE_RESET=CODE_START//'0'//CODE_END ! Clear all styles, "\[0m".

character(len=*),parameter  :: CLEAR_DISPLAY=CODE_START//'2J'
character(len=*),parameter  :: HOME_DISPLAY=CODE_START//'H'
character(len=*),parameter  :: BELL=achar(7)

character(len=*),parameter  :: AT_BOLD='1', AT_ITALIC='3', AT_UNDERLINE='4', AT_INVERSE='7'
character(len=*),parameter  :: BLACK='0', RED='1', GREEN='2', YELLOW='3', BLUE='4', MAGENTA='5', CYAN='6', WHITE='7', DEFAULT='9'
!prefixes
character(len=*),parameter  :: FG='3'
character(len=*),parameter  :: BG='4'
character(len=*),parameter  :: FG_INTENSE='9'
character(len=*),parameter  :: BG_INTENSE='10'
character(len=*),parameter  :: ON=''
character(len=*),parameter  :: OFF='2'


! foreground colors
character(len=*),parameter,public :: fg_red      =  CODE_START//FG//RED//CODE_END
character(len=*),parameter,public :: fg_cyan     =  CODE_START//FG//CYAN//CODE_END
character(len=*),parameter,public :: fg_magenta  =  CODE_START//FG//MAGENTA//CODE_END
character(len=*),parameter,public :: fg_blue     =  CODE_START//FG//BLUE//CODE_END
character(len=*),parameter,public :: fg_green    =  CODE_START//FG//GREEN//CODE_END
character(len=*),parameter,public :: fg_yellow   =  CODE_START//FG//YELLOW//CODE_END
character(len=*),parameter,public :: fg_white    =  CODE_START//FG//WHITE//CODE_END
character(len=*),parameter,public :: fg_ebony    =  CODE_START//FG//BLACK//CODE_END
character(len=*),parameter,public :: fg_black    =  CODE_START//FG//BLACK//CODE_END
character(len=*),parameter,public :: fg_default  =  CODE_START//FG//DEFAULT//CODE_END
! background colors
character(len=*),parameter,public :: bg_red      =  CODE_START//BG//RED//CODE_END
character(len=*),parameter,public :: bg_cyan     =  CODE_START//BG//CYAN//CODE_END
character(len=*),parameter,public :: bg_magenta  =  CODE_START//BG//MAGENTA//CODE_END
character(len=*),parameter,public :: bg_blue     =  CODE_START//BG//BLUE//CODE_END
character(len=*),parameter,public :: bg_green    =  CODE_START//BG//GREEN//CODE_END
character(len=*),parameter,public :: bg_yellow   =  CODE_START//BG//YELLOW//CODE_END
character(len=*),parameter,public :: bg_white    =  CODE_START//BG//WHITE//CODE_END
character(len=*),parameter,public :: bg_ebony    =  CODE_START//BG//BLACK//CODE_END
character(len=*),parameter,public :: bg_black    =  CODE_START//BG//BLACK//CODE_END
character(len=*),parameter,public :: bg_default  =  CODE_START//BG//DEFAULT//CODE_END
! attributes
character(len=*),parameter,public :: bold        =  CODE_START//ON//AT_BOLD//CODE_END
character(len=*),parameter,public :: italic      =  CODE_START//ON//AT_ITALIC//CODE_END
character(len=*),parameter,public :: inverse     =  CODE_START//ON//AT_INVERSE//CODE_END
character(len=*),parameter,public :: underline   =  CODE_START//ON//AT_UNDERLINE//CODE_END
character(len=*),parameter,public :: unbold      =  CODE_START//'22'//CODE_END
character(len=*),parameter,public :: unitalic    =  CODE_START//OFF//AT_ITALIC//CODE_END
character(len=*),parameter,public :: uninverse   =  CODE_START//OFF//AT_INVERSE//CODE_END
character(len=*),parameter,public :: ununderline =  CODE_START//OFF//AT_UNDERLINE//CODE_END

character(len=*),parameter,public :: reset       =  CODE_RESET
character(len=*),parameter,public :: clear       =  HOME_DISPLAY//CLEAR_DISPLAY

public fmt
integer,save :: alert_unit=stdout
logical,save :: alert_debug=.true.
logical,save :: alert_warn=.true.
logical,save :: alert_info=.true.
logical,save :: alert_error=.true.
logical,save :: alert_other=.true.

interface str
   module procedure msg_scalar, msg_one
end interface str

contains
!>
!!##NAME
!!    attr(3f) - [M_attr] substitute escape sequences for HTML-like syntax
!!               in strings
!!    (LICENSE:MIT)
!!
!!##SYNOPSIS
!!
!!      function attr(string,reset) result (expanded)
!!
!!        ! scalar
!!        character(len=*),intent(in)  :: string
!!        logical,intent(in),optional  :: reset
!!        character(len=:),allocatable :: expanded
!!        ! or array
!!        character(len=*),intent(in)  :: string(:)
!!        logical,intent(in),optional  :: reset
!!        character(len=:),allocatable :: expanded(:)
!!        integer,intent(in),optional  :: chars
!!
!!##DESCRIPTION
!!    Use HTML-like syntax to add attributes to terminal output such as color
!!    on devices that recognize ANSI escape sequences.
!!
!!##OPTIONS
!!    string        input string  of form
!!
!!                    "<attribute_name>string</attribute_name> ...".
!!
!!                   where the current attributes are color names,
!!                   bold, italic, underline, ...
!!
!!    reset          By default, a sequence to clear all text attributes
!!                   is sent at the end of each returned line if an escape
!!                   character appears in the output string. This can be
!!                   turned off by setting RESET to .false. .
!!
!!                   Note if turning off the reset attributes may be
!!                   continued across lines, but if each line is not
!!                   self-contained attributes may not display properly
!!                   when filtered with commands such as grep(1).
!!
!!    chars          For arrays, a reset will be placed after the Nth
!!                   displayable column count in order to make it easier
!!                   to generate consistent right borders for non-default
!!                   background colors for a text block.
!!##KEYWORDS
!!    primary default keywords
!!
!!      colors:
!!        r,         red,       R,  RED
!!        g,         green,     G,  GREEN
!!        b,         blue,      B,  BLUE
!!        m,         magenta,   M,  MAGENTA
!!        c,         cyan,      C,  CYAN
!!        y,         yellow,    Y,  YELLOW
!!        e,         ebony,     E,  EBONY
!!        w,         white,     W,  WHITE
!!
!!      attributes:
!!        it,        italic
!!        bo,        bold
!!        un,        underline
!!
!!      basic control characters:
!!       nul
!!       bel  (0x07, ^G) beeps;
!!       bs   (0x08, ^H) backspaces one column (but not past the beginning of
!!                       the line);
!!       ht   (0x09, ^I) goes to the next tab stop or to the end of the line if
!!                       there is no earlier tab stop;
!!       lf   (0x0A, ^J),
!!       vt   (0x0B, ^K)
!!       ff   (0x0C, ^L) all give a linefeed, and if LF/NL (new-line mode) is
!!                       set also a carriage return
!!       cr   (0x0D, ^M) gives a carriage return;
!!       so   (0x0E, ^N) activates the G1 character set;
!!       si   (0x0F, ^O) activates the G0 character set;
!!       can  (0x18, ^X) and SUB (0x1A, ^Z) interrupt escape sequences;
!!       sub
!!       esc  (0x1B, ^[) starts an escape sequence;
!!       del  (0x7F) is ignored;
!!
!!      other:
!!        clear
!!        default
!!        reset
!!        gt
!!        lt
!!        save,DECSC     Save  current state (cursor coordinates, attributes,
!!                       character sets pointed at by G0, G1).
!!        restore,DECRC  Restore state most recently saved by ESC 7.
!!        CSI            "Control Sequence Introducer"(0x9B) is equivalent to
!!                       "ESC [".
!!
!!      dual-value (one for color, one for mono):
!!
!!        write(*,*)attr('<ERROR>an error message')
!!        write(*,*)attr('<WARNING>a warning message')
!!        write(*,*)attr('<INFO>an informational message')
!!
!!    By default, if the color mnemonics (ie. the keywords) are uppercase
!!    they change the background color. If lowercase, the foreground color.
!!    When preceded by a "/" character the attribute is returned to the default.
!!
!!    The "default" keyword is typically used explicitly when
!!    reset=.false, and sets all text attributes to their initial defaults.
!!
!!##LIMITATIONS
!!    o colors are not nestable, keywords are case-sensitive,
!!    o not all terminals obey the sequences. On Windows, it is best if
!!      you use Windows 10+ and/or the Linux mode; although it has worked
!!      with all CygWin and MinGW and Putty windows and mintty.
!!    o you should use "<gt>" and "<lt>" instead of ">" and "<" in a string
!!      processed by attr(3f) instead of in any plain text output so that
!!      the raw mode will create correct input for the attr(3f) function
!!      if read back in.
!!
!!##EXAMPLE
!!
!!    Sample program
!!
!!     program demo_esc
!!     use M_attr, only : attr, attr_mode, attr_update
!!        call printstuff('defaults')
!!
!!        call attr_mode(manner='plain')
!!        call printstuff('plain:')
!!
!!        call printstuff('raw')
!!
!!        call attr_mode(manner='color')
!!        call printstuff('')
!!
!!        write(*,'(a)') attr('TEST ADDING A CUSTOM SEQUENCE:')
!!        call attr_update('blink',char(27)//'[5m')
!!        call attr_update('/blink',char(27)//'[25m')
!!        write(*,'(a)') attr('<blink>Items for Friday</blink>')
!!
!!     contains
!!     subroutine printstuff(label)
!!     character(len=*),intent(in)  :: label
!!     character(len=:),allocatable :: array(:)
!!       call attr_mode(manner=label)
!!
!!       array=[character(len=60) ::    &
!!        'TEST MANNER='//label,                      &
!!        '<r>RED</r>,<g>GREEN</g>,<b>BLUE</b>',      &
!!        '<c>CYAN</c>,<m>MAGENTA</g>,<y>YELLOW</y>', &
!!        '<w>WHITE</w> and <e>EBONY</e>']
!!       write(*,'(a)') attr(array)
!!
!!       write(*,'(a)') attr('Adding <bo>bold</bo>')
!!       write(*,'(a)') attr('<bo><r>RED</r>,<g>GREEN</g>,<b>BLUE</b></bo>')
!!       write(*,'(a)') attr('<bo><c>CYAN</c>,<m>MAGENTA</g>,<y>YELLOW</y></bo>')
!!       write(*,'(a)') attr('<bo><w>WHITE</w> and <e>EBONY</e></bo>')
!!
!!       write(*,'(a)') attr('Adding <ul>underline</ul>')
!!       write(*,'(a)') attr(&
!!        &'<bo><ul><r>RED</r>,<g>GREEN</g>,<b>BLUE</b></ul></bo>')
!!       write(*,'(a)') attr(&
!!        &'<bo><ul><c>CYAN</c>,<m>MAGENTA</g>,<y>YELLOW</y></ul></bo>')
!!       write(*,'(a)') attr('<bo><ul><w>WHITE</w> and <e>EBONY</e></ul></bo>')
!!
!!       write(*,'(a)') attr('Adding <ul>italic</ul>')
!!       write(*,'(a)') attr(&
!!        &'<bo><ul><it><r>RED</r>,<g>GREEN</g>,<b>BLUE</b></it></ul></bo>')
!!       write(*,'(a)') attr(&
!!        &'<bo><ul><it><c>CYAN</c>,<m>MAGENTA</g>,<y>YELLOW</it></y></ul></bo>')
!!       write(*,'(a)') attr('<bo><ul><it><w>WHITE</w> and <e>EBONY</e></ul></bo>')
!!
!!       write(*,'(a)') attr('Adding <in>inverse</in>')
!!       write(*,'(a)') attr('<in><bo><ul><it><r>RED</r>,<g>GREEN</g>,&
!!        &<b>BLUE</b></it></ul></bo></in>')
!!       write(*,'(a)') attr('<in><bo><ul><it><c>CYAN</c>,<m>MAGENTA</g>,&
!!        &<y>YELLOW</it></y></ul></bo></in>')
!!       write(*,'(a)') attr(&
!!        &'<in><bo><ul><it><w>WHITE</w> and <e>EBONY</e></ul></bo></in>')
!!     end subroutine printstuff
!!     end program demo_esc
!!
!!##AUTHOR
!!    John S. Urban, 2021
!!
!!##LICENSE
!!    MIT
!!
!!##SEE ALSO
!!    attr_mode(3f), attr_update(3f)
function attr_scalar(string,reset) result (expanded)
character(len=*),intent(in)  :: string
logical,intent(in),optional  :: reset
logical                      :: clear_at_end
character(len=:),allocatable :: padded
character(len=:),allocatable :: expanded
character(len=:),allocatable :: name
integer                      :: i
integer                      :: ii
integer                      :: maxlen
integer                      :: place
   if(present(reset))then
      clear_at_end=reset
   else
      clear_at_end=.true.
   endif
   if(.not.allocated(mode))then  ! set substitution mode
      mode='color' ! 'color'|'raw'|'plain'
      call vt102()
   endif

   if(mode=='raw')then
      expanded=string
      return
   endif

   maxlen=len(string)
   padded=string//' '
   i=1
   expanded=''
   do
      select case(padded(i:i))
      case('>')  ! should not get here unless unmatched
         i=i+1
         expanded=expanded//'>'
      case('<')  ! assuming not nested for now
         ii=index(padded(i+1:),'>')
         if(ii.eq.0)then
            expanded=expanded//'<'
            i=i+1
         else
            name=padded(i+1:i+ii-1)
            name=trim(adjustl(name))
            call locate(keywords,name,place)

            if(mode.eq.'plain')then
               expanded=expanded//get(name)
            elseif(place.le.0)then     ! unknown name; print what you found
               expanded=expanded//padded(i:i+ii)
               maxlen=maxlen-ii-1
            else
               expanded=expanded//get(name)
            endif
            i=ii+i+1
         endif
      case default
         expanded=expanded//padded(i:i)
         i=i+1
      end select
      if(i >= maxlen+1)exit
   enddo
   if( (index(expanded,esc).ne.0).and.(clear_at_end))then
      if((mode.ne.'raw').and.(mode.ne.'plain'))then
         expanded=expanded//CODE_RESET                                   ! Clear all styles
      endif
   endif
   expanded=expanded
end function attr_scalar

function attr_matrix(strings,reset,chars) result (expanded)
character(len=*),intent(in)  :: strings(:)
logical,intent(in),optional  :: reset
integer,intent(in),optional  :: chars
character(len=:),allocatable :: expanded(:)
   ! gfortran does not return allocatable array from a function properly, but works with subroutine
   call kludge_bug(strings,reset,chars,expanded)
end function attr_matrix

subroutine kludge_bug(strings,reset,chars,expanded)
character(len=*),intent(in)  :: strings(:)
logical,intent(in),optional  :: reset
integer,intent(in),optional  :: chars
character(len=:),allocatable :: expanded(:)
integer                      :: width
character(len=:),allocatable :: hold
integer                      :: i
integer                      :: right
integer                      :: len_local

allocate(character(len=0) :: expanded(0))
if(present(chars))then
   right=chars
else
   right=len(strings)
endif

if(.not.allocated(mode))then  ! set substitution mode
   mode='color' ! 'color'|'raw'|'plain'
   call vt102()
endif

do i=1,size(strings)

   if(mode.eq.'color')then
      mode='plain'
      len_local=len(attr_scalar(strings(i)))
      hold=trim(strings(i))//repeat(' ',max(0,right-len_local))
      mode='color'
   else
      hold=strings(i)
   endif

   hold=trim(attr_scalar(hold,reset=reset))
   width=max(len(hold),len(expanded))
   expanded=[character(len=width) :: expanded,hold]
enddo

end subroutine kludge_bug

function attr_scalar_width(string,reset,chars) result (expanded)
character(len=*),intent(in)  :: string
logical,intent(in),optional  :: reset
integer,intent(in)           :: chars
character(len=:),allocatable :: expanded_arr(:)
character(len=:),allocatable :: expanded
   expanded_arr=attr_matrix([string],reset,chars)
   expanded=expanded_arr(1)
end function attr_scalar_width

subroutine vt102()
! create a dictionary with character keywords, values, and value lengths
! using the routines for maintaining a list

   call wipe_dictionary()
   ! insert and replace entries
   call attr_update('bold',bold)
   call attr_update('/bold',unbold)
   call attr_update('bo',bold)
   call attr_update('/bo',unbold)
   call attr_update('italic',italic)
   call attr_update('/italic',unitalic)
   call attr_update('it',italic)
   call attr_update('/it',unitalic)
   call attr_update('inverse',inverse)
   call attr_update('/inverse',uninverse)
   call attr_update('in',inverse)
   call attr_update('/in',uninverse)
   call attr_update('underline',underline)
   call attr_update('/underline',ununderline)
   call attr_update('un',underline)
   call attr_update('/un',ununderline)
   call attr_update('ul',underline)
   call attr_update('/ul',ununderline)

   call attr_update('bell',BELL)
   call attr_update('nul', nul )
   call attr_update('bel', bel )
   call attr_update('bs', bs )
   call attr_update('ht', ht )
   call attr_update('lf', lf )
   call attr_update('vt', vt )
   call attr_update('ff', ff )
   call attr_update('cr', cr )
   call attr_update('so', so )
   call attr_update('si', si )
   call attr_update('can', can )
   call attr_update('sub', sub )
   call attr_update('esc', esc )
   call attr_update('escape',esc)
   call attr_update('del', del )

   call attr_update('save',esc//'7')
   call attr_update('DECSC',esc//'7')
   call attr_update('restore',esc//'8')
   call attr_update('DECRC',esc//'8')
   call attr_update('CSI',esc//'[')

   call attr_update('clear',clear)
   call attr_update('reset',reset)

   call attr_update('gt','>','>')
   call attr_update('lt','<','<')

   ! foreground colors
   call attr_update('r',fg_red)
       call attr_update('/r',fg_default)
       call attr_update('red',fg_red)
       call attr_update('/red',fg_default)
   call attr_update('c',fg_cyan)
       call attr_update('/c',fg_default)
       call attr_update('cyan',fg_cyan)
       call attr_update('/cyan',fg_default)
   call attr_update('m',fg_magenta)
       call attr_update('/m',fg_default)
       call attr_update('magenta',fg_magenta)
       call attr_update('/magenta',fg_default)
   call attr_update('b',fg_blue)
       call attr_update('/b',fg_default)
       call attr_update('blue',fg_blue)
       call attr_update('/blue',fg_default)
   call attr_update('g',fg_green)
       call attr_update('/g',fg_default)
       call attr_update('green',fg_green)
       call attr_update('/green',fg_default)
   call attr_update('y',fg_yellow)
       call attr_update('/y',fg_default)
       call attr_update('yellow',fg_yellow)
       call attr_update('/yellow',fg_default)
   call attr_update('w',fg_white)
       call attr_update('/w',fg_default)
       call attr_update('white',fg_white)
       call attr_update('/white',fg_default)
   call attr_update('e',fg_ebony)
       call attr_update('/e',fg_default)
       call attr_update('ebony',fg_ebony)
       call attr_update('/ebony',fg_default)
   call attr_update('x',fg_ebony)
       call attr_update('/x',fg_default)
       call attr_update('black',fg_ebony)
       call attr_update('/black',fg_default)

   ! background colors
   call attr_update('R',bg_red)
       call attr_update('/R',bg_default)
       call attr_update('RED',bg_red)
       call attr_update('/RED',bg_default)
   call attr_update('C',bg_cyan)
       call attr_update('/C',bg_default)
       call attr_update('CYAN',bg_cyan)
       call attr_update('/CYAN',bg_default)
   call attr_update('M',bg_magenta)
       call attr_update('/M',bg_default)
       call attr_update('MAGENTA',bg_magenta)
       call attr_update('/MAGENTA',bg_default)
   call attr_update('B',bg_blue)
       call attr_update('/B',bg_default)
       call attr_update('BLUE',bg_blue)
       call attr_update('/BLUE',bg_default)
   call attr_update('G',bg_green)
       call attr_update('/G',bg_default)
       call attr_update('GREEN',bg_green)
       call attr_update('/GREEN',bg_default)
   call attr_update('Y',bg_yellow)
       call attr_update('/Y',bg_default)
       call attr_update('YELLOW',bg_yellow)
       call attr_update('/YELLOW',bg_default)
   call attr_update('W',bg_white)
       call attr_update('/W',bg_default)
       call attr_update('WHITE',bg_white)
       call attr_update('/WHITE',bg_default)
   call attr_update('E',bg_ebony)
       call attr_update('/E',bg_default)
       call attr_update('EBONY',bg_ebony)
       call attr_update('/EBONY',bg_default)
   call attr_update('X',bg_ebony)
       call attr_update('/X',bg_default)
       call attr_update('BLACK',bg_ebony)
       call attr_update('/BLACK',bg_default)

   ! compound
   call attr_update('ERROR',fg_red//bold//bg_ebony     //':error:  '//bg_default//fg_default,':error:')
   call attr_update('WARNING',fg_yellow//bold//bg_ebony//':warning:'//bg_default//fg_default,':warning:')
   call attr_update('INFO',fg_green//bold//bg_ebony    //':info:   '//bg_default//fg_default,':info:')

end subroutine vt102
!>
!! !>
!!##NAME
!!    attr_mode(3f) - [M_attr] select processing mode for output from attr(3f)
!!    (LICENSE:MIT)
!!
!!##SYNOPSIS
!!
!!     subroutine attr_mode(manner)
!!
!!        character(len=*),intent(in) :: manner
!!
!!##DESCRIPTION
!!    Turn off the generation of strings associated with the HTML keywords
!!    in the string generated by the attr(3f) function, or display the
!!    text in raw mode as it was passed to attr(3f) or return to ANSI
!!    escape control sequence generation.
!!
!!##OPTIONS
!!    MANNER  The current manners or modes supported via the attr_mode(3f)
!!             procedure are
!!
!!         plain          suppress the output associated with keywords
!!         color(default) commonly supported escape sequences
!!         raw            echo the input to attr(3f) as its output
!!         reload         restore original keyword meanings deleted or
!!                        replaced by calls to attr_update(3f).
!!
!!##EXAMPLE
!!
!!    Sample program
!!
!!     program demo_attr_mode
!!     use M_attr, only : attr, attr_mode
!!     implicit none
!!     character(len=:),allocatable :: lines(:)
!!     character(len=:),allocatable :: outlines(:)
!!     integer :: i
!!        lines=[character(len=110):: &
!!        &'<M><y>',&
!!        &'<M><y>  Suffice it to say that black and white are also colors',&
!!        &'<M><y>  for their simultaneous contrast is as striking as that ',&
!!        &'<M><y>  of green and red, for instance. &
!!        & --- <y><bo>Vincent van Gogh</bo></y>',&
!!        &' ']
!!
!!        outlines=attr(lines,chars=57)
!!        write(*,'(a)')(trim(outlines(i)),i=1,size(outlines))
!!
!!        call attr_mode(manner='plain') ! write as plain text
!!        write(*,'(a)')attr(lines)
!!
!!        call attr_mode(manner='raw')   ! write as-is
!!        write(*,'(a)')attr(lines)
!!
!!        call attr_mode(manner='ansi')  ! return to default mode
!!
!!     end program demo_attr_mode
!!
!!##AUTHOR
!!    John S. Urban, 2021
!!
!!##LICENSE
!!    MIT
subroutine attr_mode(manner)
character(len=*),intent(in) :: manner
integer                     :: i
   if(.not.allocated(mode))then  ! set substitution mode
      mode='color'
      call vt102()
   endif
   select case(manner)
   case('vt102','ANSI','ansi','color','COLOR')
      mode='color'
   case('reload','default','defaults','')
      call vt102()
      mode='color'
   case('raw')
      mode='raw'
   case('dump')  ! dump dictionary for debugging
      if(allocated(keywords))then
         if(size(keywords).gt.0)then
            write(stderr,'(*(a,t30,a))')'KEYWORD','VALUE'
            write(stderr,'(*(a,t30,2("[",a,"]"),/))')(trim(keywords(i)),values(i),mono_values(i),i=1,size(keywords))
         endif
      endif
   case('dummy','plain','text')
      mode='plain'
   case default
      write(*,*)'unknown manner. Try color|raw|plain'
      mode='color'
   end select
end subroutine attr_mode

subroutine wipe_dictionary()
   if(allocated(keywords))deallocate(keywords)
   allocate(character(len=0) :: keywords(0))
   if(allocated(values))deallocate(values)
   allocate(character(len=0) :: values(0))
   if(allocated(mono_values))deallocate(mono_values)
   allocate(character(len=0) :: mono_values(0))
end subroutine wipe_dictionary

!>
!! !>
!!##NAME
!!    attr_update(3f) - [M_attr] update internal dictionary given keyword and value
!!    (LICENSE:MIT)
!!
!!##SYNOPSIS
!!
!!    subroutine attr_update(key,val)
!!
!!     character(len=*),intent(in)           :: key
!!     character(len=*),intent(in),optional  :: val
!!     character(len=*),intent(in),optional  :: mono_val
!!
!!##DESCRIPTION
!!    Update internal dictionary in M_attr(3fm) module.
!!
!!##OPTIONS
!!    key       name of keyword to add, replace, or delete from dictionary
!!    val       if present add or replace value associated with keyword. If
!!              not present remove keyword entry from dictionary.
!!    mono_val  if present add or replace second value associated with
!!              keyword used for plain text mode.
!!              Must only be specified if VAL is also specified.
!!
!!##KEYWORDS
!!    The following keywords are defined by default
!!
!!    colors:
!!
!!      r,red     c,cyan     w,white
!!      g,green   m,magenta  e,ebony
!!      b,blue    y,yellow
!!
!!    If the color keywords are capitalized they control the text background
!!    instead of the text color.
!!
!!    attributes:
!!
!!      ul,underline
!!      it,italics (often produces inverse colors on many devices
!!
!!##EXAMPLE
!!
!!    Sample program
!!
!!      program demo_update
!!      use M_attr, only : attr, attr_update
!!         write(*,'(a)') attr('<clear>TEST CUSTOMIZATIONS:')
!!         ! add custom keywords
!!         call attr_update('blink',char(27)//'[5m')
!!         call attr_update('/blink',char(27)//'[25m')
!!         write(*,*)
!!         write(*,'(a)') attr('<blink>Items for Friday</blink>')
!!         call attr_update('ouch',attr( &
!!         ' <R><bo><w>BIG mistake!</R></w> '))
!!         write(*,*)
!!         write(*,'(a)') attr('<ouch> Did not see that coming.')
!!         write(*,*)
!!         write(*,'(a)') attr( &
!!         'ORIGINALLY: <r>Apple</r>, <b>Sky</b>, <g>Grass</g>')
!!         ! delete
!!         call attr_update('r')
!!         call attr_update('/r')
!!         ! replace (or create)
!!         call attr_update('b','<<<<')
!!         call attr_update('/b','>>>>')
!!         write(*,*)
!!         write(*,'(a)') attr( &
!!         'CUSTOMIZED: <r>Apple</r>, <b>Sky</b>, <g>Grass</g>')
!!      end program demo_update
!!
!!##AUTHOR
!!    John S. Urban, 2021
!!
!!##LICENSE
!!    MIT
subroutine attr_update(key,valin,mono_valin)
character(len=*),intent(in)           :: key
character(len=*),intent(in),optional  :: valin
character(len=*),intent(in),optional  :: mono_valin
integer                               :: place
character(len=:),allocatable          :: val
character(len=:),allocatable          :: mono_val

if(.not.allocated(mode))then  ! set substitution mode
   mode='color' ! 'color'|'raw'|'plain'
   call vt102()
endif

if(present(mono_valin))then
   mono_val=mono_valin
else
   mono_val=''
endif

if(present(valin))then
   val=valin
   ! find where string is or should be
   call locate(keywords,key,place)
   ! if string was not found insert it
   if(place.lt.1)then
      call insert(keywords,key,iabs(place))
      call insert(values,val,iabs(place))
      call insert(mono_values,mono_val,iabs(place))
   else
      call replace(values,val,place)
      call replace(mono_values,mono_val,place)
   endif
else
   call locate(keywords,key,place)
   if(place.gt.0)then
      call remove(keywords,place)
      call remove(values,place)
      call remove(mono_values,place)
   endif
endif
end subroutine attr_update

function get(key) result(valout)
character(len=*),intent(in)   :: key
character(len=:),allocatable  :: valout
integer                       :: place
   ! find where string is or should be
   call locate(keywords,key,place)
   if(place.lt.1)then
      valout=''
   else
      if(mode.eq.'plain')then
         valout=trim(mono_values(place))
      else
         valout=trim(values(place))
      endif
   endif
end function get

subroutine locate(list,value,place,ier,errmsg)
character(len=*),intent(in)             :: value
integer,intent(out)                     :: place
character(len=:),allocatable            :: list(:)
integer,intent(out),optional            :: ier
character(len=*),intent(out),optional   :: errmsg
integer                                 :: i
character(len=:),allocatable            :: message
integer                                 :: arraysize
integer                                 :: maxtry
integer                                 :: imin, imax
integer                                 :: error
   if(.not.allocated(list))then
      list=[character(len=max(len_trim(value),2)) :: ]
   endif
   arraysize=size(list)

   error=0
   if(arraysize.eq.0)then
      maxtry=0
      place=-1
   else
      maxtry=int(log(float(arraysize))/log(2.0)+1.0)
      place=(arraysize+1)/2
   endif
   imin=1
   imax=arraysize
   message=''

   LOOP: block
   do i=1,maxtry
      if(value.eq.list(PLACE))then
         exit LOOP
      else if(value.gt.list(place))then
         imax=place-1
      else
         imin=place+1
      endif
      if(imin.gt.imax)then
         place=-imin
         if(iabs(place).gt.arraysize)then ! ran off end of list. Where new value should go or an unsorted input array'
            exit LOOP
         endif
         exit LOOP
      endif
      place=(imax+imin)/2
      if(place.gt.arraysize.or.place.le.0)then
         message='*locate* error: search is out of bounds of list. Probably an unsorted input array'
         error=-1
         exit LOOP
      endif
   enddo
   message='*locate* exceeded allowed tries. Probably an unsorted input array'
   endblock LOOP
   if(present(ier))then
      ier=error
   else if(error.ne.0)then
      write(stderr,*)message//' VALUE=',trim(value)//' PLACE=',place
      stop 1
   endif
   if(present(errmsg))then
      errmsg=message
   endif
end subroutine locate

subroutine remove(list,place)
character(len=:),allocatable :: list(:)
integer,intent(in)           :: place
integer                      :: ii, end
   if(.not.allocated(list))then
      list=[character(len=2) :: ]
   endif
   ii=len(list)
   end=size(list)
   if(place.le.0.or.place.gt.end)then                       ! index out of bounds of array
   elseif(place.eq.end)then                                 ! remove from array
      list=[character(len=ii) :: list(:place-1) ]
   else
      list=[character(len=ii) :: list(:place-1), list(place+1:) ]
   endif
end subroutine remove

subroutine replace(list,value,place)
character(len=*),intent(in)  :: value
character(len=:),allocatable :: list(:)
character(len=:),allocatable :: kludge(:)
integer,intent(in)           :: place
integer                      :: ii
integer                      :: tlen
integer                      :: end
   if(.not.allocated(list))then
      list=[character(len=max(len_trim(value),2)) :: ]
   endif
   tlen=len_trim(value)
   end=size(list)
   if(place.lt.0.or.place.gt.end)then
           write(stderr,*)'*replace* error: index out of range. end=',end,' index=',place
   elseif(len_trim(value).le.len(list))then
      list(place)=value
   else  ! increase length of variable
      ii=max(tlen,len(list))
      kludge=[character(len=ii) :: list ]
      list=kludge
      list(place)=value
   endif
end subroutine replace

subroutine insert(list,value,place)
character(len=*),intent(in)  :: value
character(len=:),allocatable :: list(:)
character(len=:),allocatable :: kludge(:)
integer,intent(in)           :: place
integer                      :: ii
integer                      :: end
   if(.not.allocated(list))then
      list=[character(len=max(len_trim(value),2)) :: ]
   endif
   ii=max(len_trim(value),len(list),2)
   end=size(list)
   if(end.eq.0)then                                          ! empty array
      list=[character(len=ii) :: value ]
   elseif(place.eq.1)then                                    ! put in front of array
      kludge=[character(len=ii) :: value, list]
      list=kludge
   elseif(place.gt.end)then                                  ! put at end of array
      kludge=[character(len=ii) :: list, value ]
      list=kludge
   elseif(place.ge.2.and.place.le.end)then                 ! put in middle of array
      kludge=[character(len=ii) :: list(:place-1), value,list(place:) ]
      list=kludge
   else                                                      ! index out of range
      write(stderr,*)'*insert* error: index out of range. end=',end,' index=',place,' value=',value
   endif
end subroutine insert
!>
!! !>
!!##NAME
!!    alert(3f) - [M_attr] print messages using a standard format including time and program name
!!    (LICENSE:MIT)
!!
!!##SYNOPSIS
!!
!!     subroutine alert(message,g0,g1,g2,g3,g4,g5,g6,g7,g8,g9,ga,gb,gc,gd,ge,gf,gg,gh,gi,gj)
!!
!!        character(len=*),intent(in),optional :: type
!!        character(len=*),intent(in),optional :: message
!!        class(*),intent(in),optional :: g0,g1,g2,g3,g4,g5,g6,g7,g8,g9, &
!!                                      & ga,gb,gc,gd,ge,gf,gg,gh,gi,gj
!!
!!##DESCRIPTION
!!    Display a message prefixed with a timestamp and the name
!!    of the calling program when the TYPE is specified as any
!!    of 'error','warn', or 'info'.
!!
!!    It also allows the keywords
!!    <ARG0>,<TZ>,<YE>,<MO>,<DA>,<HR>,<MI>,<SE>,<MS> to be used in the
!!    message (which is passed to ATTR(3f)).
!!
!!    Note that time stamp keywords will only be updated when using ALERT(3f)
!!    and will only be displayed in color mode!
!!
!!##OPTIONS
!!    TYPE     if present and one of 'warn','message','info', or 'debug'  a predefined
!!             message is written to stderr of the form
!!
!!              : <HR>:<MI>:<SE>.<MS> : (<ARG0>) : TYPE -> message
!!
!!    MESSAGE  the user-supplied message to display via a call to ATTR(3f)
!!
!!    g[0-9a-j]   optional values to print after the message. May
!!                be of type INTEGER, LOGICAL, REAL, DOUBLEPRECISION,
!!                COMPLEX, or CHARACTER.
!!
!!    if no parameters are supplied the macros are updated but no output is generated.
!!
!!##EXAMPLE
!!
!!    Sample program
!!
!!       program demo_alert
!!       use M_attr, only : alert, attr, attr_mode
!!       implicit none
!!       real X
!!          call attr_mode(manner='plain')
!!          call attr_mode(manner='color')
!!          call alert("error", "Say you didn't!")
!!          call alert("warn",  "I wouldn't if I were you, Will Robinson.")
!!          call alert("info",  "I fixed that for you, but it was a bad idea.")
!!          call alert("debug", "Who knows what is happening now?.")
!!          call alert("???    ",  "not today you don't")
!!          ! call to just update the macros
!!          call alert()
!!          ! conventional call to ATTR(3f) using the ALERT(3f)-defined macros
!!          write(*,*)attr('<bo>The year was <g><YE></g>, the month was <g><MO></g>')
!!          ! optional arguments
!!          X=211.3
!!          call alert('error','allowed range of X is 0 <lt> X <lt> 100, X=<r>',X)
!!          ! up to twenty values are allowed of intrinsic type
!!          call alert('info','values are<g>',10,234.567,cmplx(11.0,22.0),123.456d0,'</g>today')
!!       end program demo_alert
!!
!!   Results:
!!
!!     00:38:30.566 : (demo_alert) : error    -> Say you didn't!
!!     00:38:30.567 : (demo_alert) : warning  -> I wouldn't if I were you, Will Robinson.
!!     00:38:30.567 : (demo_alert) : info     -> I fixed that for you, but it was a bad idea.
!!     00:38:30.567 : (demo_alert) : debug    -> Who knows what is happening now?.
!!     00:38:30.567 : (demo_alert) : ???      -> not today you don't
!!     00:38:30.567 : (demo_alert) : error    -> allowed range of X is 0  X  100, X= 211.300003
!!     00:38:30.567 : (demo_alert) : info     -> values are 10 234.567001 (11.0000000,22.0000000) 123.45600000000000 today
!!
!!
!!
!!##AUTHOR
!!    John S. Urban, 2021
!!
!!##LICENSE
!!    MIT
subroutine alert(type,message,g0,g1,g2,g3,g4,g5,g6,g7,g8,g9,ga,gb,gc,gd,ge,gf,gg,gh,gi,gj)
! TODO: could add a warning level to ignore info, or info|warning, or all
implicit none
character(len=*),intent(in),optional :: type
character(len=*),intent(in),optional :: message
class(*),intent(in),optional  :: g0,g1,g2,g3,g4,g5,g6,g7,g8,g9
class(*),intent(in),optional  :: ga,gb,gc,gd,ge,gf,gg,gh,gi,gj
character(len=8)      :: dt
character(len=10)     :: tm
character(len=5)      :: zone
integer,dimension(8)  :: values
character(len=4096)   :: arg0
character(len=:),allocatable :: new_message
character(len=:),allocatable :: other
logical :: printme
   call date_and_time(dt,tm,zone,values)
   call attr_update('YE',dt(1:4),dt(1:4))
   call attr_update('MO',dt(5:6),dt(5:6))
   call attr_update('DA',dt(7:8),dt(7:8))
   call attr_update('HR',tm(1:2),tm(1:2))
   call attr_update('MI',tm(3:4),tm(3:4))
   call attr_update('SE',tm(5:6),tm(5:6))
   call attr_update('MS',tm(8:10),tm(8:10))
   call attr_update('TZ',zone,zone)
   call get_command_argument(0,arg0)
   if(index(arg0,'/').ne.0) arg0=arg0(index(arg0,'/',back=.true.)+1:)
   if(index(arg0,'\').ne.0) arg0=arg0(index(arg0,'\',back=.true.)+1:)
   call attr_update('ARG0',arg0,arg0)
   printme=.true.
   if(present(type))then
      new_message= ' <b>'//tm(1:2)//':'//tm(3:4)//':'//tm(5:6)//'.'//tm(8:10)//'</b> : ('//trim(arg0)//') : '
      other=message//' '//str(g0,g1,g2,g3,g4,g5,g6,g7,g8,g9,ga,gb,gc,gd,ge,gf,gg,gh,gi,gj)
      select case(type)

      case('warn','WARN','warning','WARNING')
       new_message= new_message//'<EBONY><bo><y>warning </y></EBONY> -<gt> '
       printme=alert_warn

      case('info','INFO','information','INFORMATION')
       new_message= new_message//'<EBONY><bo><g>info    </g></EBONY> -<gt> '
       printme=alert_info

      case('error','ERROR')
       new_message= new_message//'<EBONY><bo><r>error   </r></EBONY> -<gt> '
       printme=alert_error

      case('debug','DEBUG')
       new_message= new_message//'<EBONY><white><bo>debug   </white></EBONY> -<gt> '
       printme=alert_debug

      case default
       new_message= new_message//'<EBONY><bo><c>'//type//' </c></EBONY> -<gt> '
       printme=alert_other

      end select
    if(printme)then
       write(alert_unit,'(a)')attr(trim(new_message//other))
    endif

   elseif(present(message))then
    write(alert_unit,'(a)')attr(trim(other))
   endif
end subroutine alert

!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
!>
!!##NAME
!!    str(3f) - [M_attr] converts any standard scalar type to a string
!!    (LICENSE:PD)
!!
!!##SYNOPSIS
!!
!!    Syntax:
!!
!!      function str(g0,g1,g2,g3,g4,g5,g6,g7,g8,g9,&
!!      & ga,gb,gc,gd,ge,gf,gg,gh,gi,gj,sep)
!!      class(*),intent(in),optional  :: g0,g1,g2,g3,g4,g5,g6,g7,g8,g9
!!      class(*),intent(in),optional  :: ga,gb,gc,gd,ge,gf,gg,gh,gi,gj
!!      character(len=*),intent(in),optional :: sep
!!      character,len=(:),allocatable :: str
!!
!!##DESCRIPTION
!!    str(3f) builds a space-separated string from up to twenty scalar values.
!!
!!##OPTIONS
!!    g[0-9a-j]   optional value to print the value of after the message. May
!!                be of type INTEGER, LOGICAL, REAL, DOUBLEPRECISION,
!!                COMPLEX, or CHARACTER.
!!
!!                Optionally, all the generic values can be
!!                single-dimensioned arrays. Currently, mixing scalar
!!                arguments and array arguments is not supported.
!!
!!    sep         separator string used between values. Defaults to a space.
!!
!!##RETURNS
!!    str     description to print
!!
!!##EXAMPLES
!!
!!   Sample program:
!!
!!    program demo_msg
!!    use M_attr, only : alert
!!    end program demo_msg
!!
!!   Output
!!
!!
!!##AUTHOR
!!    John S. Urban
!!
!!##LICENSE
!!    Public Domain
function msg_scalar(generic0, generic1, generic2, generic3, generic4, generic5, generic6, generic7, generic8, generic9, &
                  & generica, genericb, genericc, genericd, generice, genericf, genericg, generich, generici, genericj, &
                  & sep)
implicit none

! ident_1="@(#)M_attr::msg_scalar(3fp): writes a message to a string composed of any standard scalar types"

class(*),intent(in),optional  :: generic0, generic1, generic2, generic3, generic4
class(*),intent(in),optional  :: generic5, generic6, generic7, generic8, generic9
class(*),intent(in),optional  :: generica, genericb, genericc, genericd, generice
class(*),intent(in),optional  :: genericf, genericg, generich, generici, genericj
character(len=:),allocatable  :: msg_scalar
character(len=4096)           :: line
integer                       :: istart
integer                       :: increment
character(len=*),intent(in),optional :: sep
character(len=:),allocatable  :: sep_local
   if(present(sep))then
      increment=len(sep)+1
      sep_local=sep
   else
      increment=2
      sep_local=' '
   endif

   istart=1
   line=''
   if(present(generic0))call print_generic(generic0)
   if(present(generic1))call print_generic(generic1)
   if(present(generic2))call print_generic(generic2)
   if(present(generic3))call print_generic(generic3)
   if(present(generic4))call print_generic(generic4)
   if(present(generic5))call print_generic(generic5)
   if(present(generic6))call print_generic(generic6)
   if(present(generic7))call print_generic(generic7)
   if(present(generic8))call print_generic(generic8)
   if(present(generic9))call print_generic(generic9)
   if(present(generica))call print_generic(generica)
   if(present(genericb))call print_generic(genericb)
   if(present(genericc))call print_generic(genericc)
   if(present(genericd))call print_generic(genericd)
   if(present(generice))call print_generic(generice)
   if(present(genericf))call print_generic(genericf)
   if(present(genericg))call print_generic(genericg)
   if(present(generich))call print_generic(generich)
   if(present(generici))call print_generic(generici)
   if(present(genericj))call print_generic(genericj)
   msg_scalar=trim(line)
contains
!===================================================================================================================================
subroutine print_generic(generic)
!use, intrinsic :: iso_fortran_env, only : int8, int16, int32, biggest=>int64, real32, real64, dp=>real128
use,intrinsic :: iso_fortran_env, only : int8, int16, int32, int64, real32, real64, real128
class(*),intent(in) :: generic
   select type(generic)
      type is (integer(kind=int8));     write(line(istart:),'(i0)') generic
      type is (integer(kind=int16));    write(line(istart:),'(i0)') generic
      type is (integer(kind=int32));    write(line(istart:),'(i0)') generic
      type is (integer(kind=int64));    write(line(istart:),'(i0)') generic
      type is (real(kind=real32));      write(line(istart:),'(1pg0)') generic
      type is (real(kind=real64));      write(line(istart:),'(1pg0)') generic
      type is (real(kind=real128));     write(line(istart:),'(1pg0)') generic
      type is (logical);                write(line(istart:),'(l1)') generic
      type is (character(len=*));       write(line(istart:),'(a)') trim(generic)
      type is (complex);                write(line(istart:),'("(",1pg0,",",1pg0,")")') generic
   end select
   istart=len_trim(line)+increment
   line=trim(line)//sep_local
end subroutine print_generic
!===================================================================================================================================
end function msg_scalar
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
function msg_one(generic0,generic1, generic2, generic3, generic4, generic5, generic6, generic7, generic8, generic9,&
               & generica,genericb, genericc, genericd, generice, genericf, genericg, generich, generici, genericj,&
               & sep)
implicit none

! ident_2="@(#)M_attr::msg_one(3fp): writes a message to a string composed of any standard one dimensional types"

class(*),intent(in)           :: generic0(:)
class(*),intent(in),optional  :: generic1(:), generic2(:), generic3(:), generic4(:), generic5(:)
class(*),intent(in),optional  :: generic6(:), generic7(:), generic8(:), generic9(:)
class(*),intent(in),optional  :: generica(:), genericb(:), genericc(:), genericd(:), generice(:)
class(*),intent(in),optional  :: genericf(:), genericg(:), generich(:), generici(:), genericj(:)
character(len=*),intent(in),optional :: sep
character(len=:),allocatable  :: sep_local
character(len=:), allocatable :: msg_one
character(len=4096)           :: line
integer                       :: istart
integer                       :: increment
   if(present(sep))then
      increment=1+len(sep)
      sep_local=sep
   else
      sep_local=' '
      increment=2
   endif

   istart=1
   line=' '
   call print_generic(generic0)
   if(present(generic1))call print_generic(generic1)
   if(present(generic2))call print_generic(generic2)
   if(present(generic3))call print_generic(generic3)
   if(present(generic4))call print_generic(generic4)
   if(present(generic5))call print_generic(generic5)
   if(present(generic6))call print_generic(generic6)
   if(present(generic7))call print_generic(generic7)
   if(present(generic8))call print_generic(generic8)
   if(present(generic9))call print_generic(generic9)
   if(present(generica))call print_generic(generica)
   if(present(genericb))call print_generic(genericb)
   if(present(genericc))call print_generic(genericc)
   if(present(genericd))call print_generic(genericd)
   if(present(generice))call print_generic(generice)
   if(present(genericf))call print_generic(genericf)
   if(present(genericg))call print_generic(genericg)
   if(present(generich))call print_generic(generich)
   if(present(generici))call print_generic(generici)
   if(present(genericj))call print_generic(genericj)
   msg_one=trim(line)
contains
!===================================================================================================================================
subroutine print_generic(generic)
!use, intrinsic :: iso_fortran_env, only : int8, int16, int32, biggest=>int64, real32, real64, dp=>real128
use,intrinsic :: iso_fortran_env, only : int8, int16, int32, int64, real32, real64, real128
class(*),intent(in),optional :: generic(:)
integer :: i
   select type(generic)
      type is (integer(kind=int8));     write(line(istart:),'("[",*(i0,1x))') generic
      type is (integer(kind=int16));    write(line(istart:),'("[",*(i0,1x))') generic
      type is (integer(kind=int32));    write(line(istart:),'("[",*(i0,1x))') generic
      type is (integer(kind=int64));    write(line(istart:),'("[",*(i0,1x))') generic
      type is (real(kind=real32));      write(line(istart:),'("[",*(1pg0,1x))') generic
      type is (real(kind=real64));      write(line(istart:),'("[",*(1pg0,1x))') generic
      type is (real(kind=real128));     write(line(istart:),'("[",*(1pg0,1x))') generic
      !type is (real(kind=real256));     write(error_unit,'(1pg0)',advance='no') generic
      type is (logical);                write(line(istart:),'("[",*(l1,1x))') generic
      type is (character(len=*));       write(line(istart:),'("[",:*("""",a,"""",1x))') (trim(generic(i)),i=1,size(generic))
      type is (complex);                write(line(istart:),'("[",*("(",1pg0,",",1pg0,")",1x))') generic
      class default
         stop 'unknown type in *print_generic*'
   end select
   istart=len_trim(line)+increment+1
   line=trim(line)//']'//sep_local
end subroutine print_generic
!===================================================================================================================================
end function msg_one
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
!>
!!##NAME
!!    fmt(3f) - [M_attr] convert any intrinsic to a string using specified format
!!    (LICENSE:PD)
!!##SYNOPSIS
!!
!!    function fmt(value,format) result(string)
!!
!!     class(*),intent(in),optional :: value
!!     character(len=*),intent(in),optional  :: format
!!     character(len=:),allocatable :: string
!!##DESCRIPTION
!!    FMT(3f) converts any standard intrinsic value to a string using the specified
!!    format.
!!##OPTIONS
!!    value    value to print the value of. May be of type INTEGER, LOGICAL,
!!             REAL, DOUBLEPRECISION, COMPLEX, or CHARACTER.
!!    format   format to use to print value. It is up to the user to use an
!!             appropriate format. The format does not require being
!!             surrounded by parenthesis. If not present a default is selected
!!             similar to what would be produced with free format.
!!##RETURNS
!!    string   A string value
!!##EXAMPLES
!!
!!   Sample program:
!!
!!     program demo_fmt
!!     use :: M_attr, only : fmt
!!     implicit none
!!     character(len=:),allocatable :: output
!!
!!        output=fmt(10,"'[',i0,']'")
!!        write(*,*)'result is ',output
!!
!!        output=fmt(10.0/3.0,"'[',g0.5,']'")
!!        write(*,*)'result is ',output
!!
!!        output=fmt(.true.,"'The final answer is [',g0,']'")
!!        write(*,*)'result is ',output
!!
!!     end program demo_fmt
!!
!!   Results:
!!
!!     result is [10]
!!     result is [3.3333]
!!     result is The final answer is [T]
!!
!!##AUTHOR
!!    John S. Urban
!!
!!##LICENSE
!!    Public Domain
recursive function fmt(generic,format) result (line)
use,intrinsic :: iso_fortran_env, only : int8, int16, int32, int64, real32, real64, real128

! ident_3="@(#)M_attr::fmt(3f): convert any intrinsic to a string using specified format"

class(*),intent(in)          :: generic
character(len=*),intent(in),optional  :: format
character(len=:),allocatable :: line
character(len=:),allocatable :: fmt_local
integer                      :: ios
character(len=255)           :: msg
character(len=1),parameter   :: null=char(0)
integer                      :: ilen
   if(present(format))then
      fmt_local=format
   else
      fmt_local=''
   endif
   ! add ",a" and print null and use position of null to find length of output
   ! add cannot use SIZE= or POS= or ADVANCE='NO' on WRITE() on INTERNAL READ,
   ! and do not want to trim as trailing spaces can be significant
   if(fmt_local.eq.'')then
      select type(generic)
         type is (integer(kind=int8));     fmt_local='(i0,a)'
         type is (integer(kind=int16));    fmt_local='(i0,a)'
         type is (integer(kind=int32));    fmt_local='(i0,a)'
         type is (integer(kind=int64));    fmt_local='(i0,a)'
         type is (real(kind=real32));      fmt_local='(1pg0,a)'
         type is (real(kind=real64));      fmt_local='(1pg0,a)'
         type is (real(kind=real128));     fmt_local='(1pg0,a)'
         type is (logical);                fmt_local='(l1,a)'
         type is (character(len=*));       fmt_local='(a,a)'
         type is (complex);                fmt_local='("(",1pg0,",",1pg0,")",a)'
      end select
   else
      if(format(1:1).eq.'(')then
         fmt_local=format(:len_trim(format)-1)//',a)'
      else
         fmt_local='('//fmt_local//',a)'
      endif
   endif
   allocate(character(len=256) :: line) ! cannot currently write into allocatable variable
   ios=0
   select type(generic)
      type is (integer(kind=int8));     write(line,fmt_local,iostat=ios,iomsg=msg) generic,null
      type is (integer(kind=int16));    write(line,fmt_local,iostat=ios,iomsg=msg) generic,null
      type is (integer(kind=int32));    write(line,fmt_local,iostat=ios,iomsg=msg) generic,null
      type is (integer(kind=int64));    write(line,fmt_local,iostat=ios,iomsg=msg) generic,null
      type is (real(kind=real32));      write(line,fmt_local,iostat=ios,iomsg=msg) generic,null
      type is (real(kind=real64));      write(line,fmt_local,iostat=ios,iomsg=msg) generic,null
      type is (real(kind=real128));     write(line,fmt_local,iostat=ios,iomsg=msg) generic,null
      type is (logical);                write(line,fmt_local,iostat=ios,iomsg=msg) generic,null
      type is (character(len=*));       write(line,fmt_local,iostat=ios,iomsg=msg) generic,null
      type is (complex);                write(line,fmt_local,iostat=ios,iomsg=msg) generic,null
   end select
   if(ios.ne.0)then
      line='<ERROR>'//trim(msg)
   else
      ilen=index(line,null,back=.true.)
      if(ilen.eq.0)ilen=len(line)
      line=line(:ilen-1)
   endif
end function fmt
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================

end module M_attr
