Fortran Wiki
asa2pdf

asa2pdf(1)

convert text files using ASA carriage control to an Adobe PDF file

The asa2pdf(1)program takes a file with (or without) ASA carriage control and converts it to an Adobe PDF file.

The program provides extensive user documentation via the –help switch, including a basic definition of ASA vertical carriage control for those unfamiliar with it.

Tested with GNU Fortran (GCC) 5.4.0 ; 20170313

Support of ASA carriage control by Operating Systems and printers was once nearly ubiquitious, but is now rarely supported. As a result newer codes rarely produce ASA files; so this program is primarily of interest to people supporting codes that already contain ASA carriage control.

Various versions of asa2pdf(1) have been used for a long time to provide output support for a number of Fortran and COBOL programs that made extensive use of ASA carriage control to support overstrikes. Overstrikes were used to provide characters with accents, underlining, special characters such as “not equal” (“=”+“backspace”+“/”)…. . As an extension to ASA box characters and extended ANSI characters were also used and supported.

The programs the asa2pdf(1) filter was developed for have now been converted to generate HTML output and use Unicode characters, but if anyone else still needs to support ASA characters or wants to correctly display old ASCII Art files that used ASA carriage control, or are looking for an example program that converts flat text files to Adobe PDF files (which are hard to come by) this program is being made freely available, as asa2pdf(1) will (probably) no longer be supported as a public Open Source application by the original author.

To make the asa2pdf(1) source self-contained several string utilties and a large command-line parsing module are included, which makes the source rather larger than expected.

!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
subroutine help_usage(l_help)
implicit none
character(len=*),parameter     :: ident="@(#)help_usage(3f): prints help information"
logical,intent(in)             :: l_help
character(len=:),allocatable :: help_text(:)
integer                        :: i
logical                        :: stopit=.false.
stopit=.false.
if(l_help)then
help_text=[ CHARACTER(LEN=128) :: &
'NAME                                                                            ',&
'    asa2pdf(1f) - Convert text files with/without ASA carriage control          ',&
'                  to an Adobe PDF file.                                         ',&
'                                                                                ',&
'SYNOPSIS                                                                        ',&
'   asa2pdf -o output_filename -i input_filename                                 ',&
'           -g gray_scale_shade -b lines_alternately_shaded -d dashcode          ',&
'           -s top_middle_page_label -t top_left_page_label                      ',&
'           -P # add page numbers                                                ',&
'           -l lines_per_page -f font_name -S columns_to_shift_data              ',&
'           -N # add line numbers                                                ',&
'           -H page_height -W page_width -u points_per_unit                      ',&
'           -L left_margin -R right_margin -B bottom_margin -T top_margin        ',&
'           -help -version -show                                                 ',&
'                                                                                ',&
'DESCRIPTION                                                                     ',&
'                                                                                ',&
'   Basically, asa2pdf(1) emulates a line printer that recognizes ASA            ',&
'   carriage control. That is, it lets you convert ASCII text files using        ',&
'   ASA carriage control into Adobe "clear text" PDF files instead of a          ',&
'   printed page.                                                                ',&
'                                                                                ',&
'   The PDF is clear-text ASCII so that it is easy to still use other            ',&
'   Unix/Linux utilities such as spell(1), diff(1), grep(1), .... on the         ',&
'   output files.                                                                ',&
'                                                                                ',&
'   To properly view the output requires a PDF processor (such                   ',&
'   as xpdf(1),acroread(1)/AcroRd32, gv(1) or ghostview(1), ...).                ',&
'   Most modern systems can view, mail and print PDF files.                      ',&
'                                                                                ',&
'   The default layout generates a landscape 132-column 60-line format with      ',&
'   every other two lines shaded. A variety of switches are available to         ',&
'   let you easily print files with no vertical carriage control, and in         ',&
'   portrait mode too. There are options to use dashed lines instead of          ',&
'   shading, to set different margins, and so on.                                ',&
'                                                                                ',&
'   WHAT IS ASA CARRIAGE CONTROL?                                                ',&
'                                                                                ',&
'   The ASA carriage control standard was the first important formatting         ',&
'   standard for printing and viewing text files. The standard was almost        ',&
'   universally adapted by printer manufacturers of the time (and printers       ',&
'   were a much more common output device than interactive displays).            ',&
'                                                                                ',&
'   Most commercial high-level programs at the time the standard was             ',&
'   created were either FORTRAN or COBOL; so nearly all early FORTRAN            ',&
'   output used ASA carriage control                                             ',&
'   (ASA was the American Standards Association -- now ANSI).                    ',&
'   This FORTRAN/ASA association became so strong that the standard is           ',&
'   sometimes referred to as the "Fortran carriage control standard" (FCC).      ',&
'   Indeed, even though ASA is no longer commonly directly supported on          ',&
'   desktop printers, it was part of the Fortran 90 standard (this was           ',&
'   dropped in Fortran 2003 -- how a printer processes files is really           ',&
'   not directly part of any programming language).                              ',&
'                                                                                ',&
'   Times have changed, and the once nearly ubiquitous ASA standard              ',&
'   is poorly supported on Unix and MSWindows machines in particular             ',&
'   (Direct operating-system support of ASA files was once common, but           ',&
'   is now rare).                                                                ',&
'                                                                                ',&
'   But no alternative as simple has emerged for output files                    ',&
'   that truly replaces the ASA standard (although machine control               ',&
'   characters (ctrl-H, ctrl-L, ...) have come close they have their             ',&
'   own issues).                                                                 ',&
'                                                                                ',&
'   So many programs using ASA-based formatting have not been changed,           ',&
'   and use commands like asa(1)/nasa(1), and fpr(1) to allow the files to       ',&
'   be printed as desired but NOT to generally be viewed properly on-line,       ',&
'   and printing itself is becoming less common.                                 ',&
'                                                                                ',&
'   So the problem isn''t so much with ASA files, but that today''s              ',&
'   infrastructure does not support the format well. The asa2pdf(1)              ',&
'   program bridges the gap by allowing you to still make and manipulate         ',&
'   ASA files until you want to print or email them, at which time you           ',&
'   can quickly convert them to an Adobe PDF file.                               ',&
'                                                                                ',&
'USAGE                                                                           ',&
'                                                                                ',&
'   asa2pdf(1) reads input from standard input. By default the first             ',&
'   character of each line is interpreted as a control character. Lines          ',&
'   beginning with any character other than those listed in the ASA              ',&
'   carriage-control characters table or in the list of extensions below         ',&
'   are interpreted as if they began with a blank, and an appropriate            ',&
'   diagnostic appears on standard error. The first character of each            ',&
'   line is not printed.                                                         ',&
'                                                                                ',&
'   ASA Carriage Control Characters                                              ',&
'                                                                                ',&
'        +------------+-----------------------------------------------+          ',&
'        | Character  |                                               |          ',&
'        +------------+-----------------------------------------------+          ',&
'        | +          | Do not advance; overstrike previous line.     |          ',&
'        | blank      | Advance one line.                             |          ',&
'        | null lines | Treated as if they started with a blank       |          ',&
'        | 0          | Advance two lines.                            |          ',&
'        | -          | Advance three lines (IBM extension).          |          ',&
'        | 1          | Advance to top of next page.                  |          ',&
'        | all others | Discarded (except for extensions listed below)|          ',&
'        +------------+-----------------------------------------------+          ',&
'   Extensions                                                                   ',&
'                                                                                ',&
'       H   Advance one-half line.                                               ',&
'       R   Do not advance; overstrike previous line. Use red text color         ',&
'       G   Do not advance; overstrike previous line. Use green text color       ',&
'       B   Do not advance; overstrike previous line. Use blue text color        ',&
'       r   Advance one line. Use red text color                                 ',&
'       g   Advance one line. Use green text color                               ',&
'       b   Advance one line. Use blue text color                                ',&
'       ^   Overprint but add 127 to the ADE value of the character              ',&
'           (ie., use ASCII extended character set)                              ',&
'                                                                                ',&
'OPTIONS                                                                         ',&
'       -o outputfile  Name of Adobe PDF output file to create                   ',&
'       -i inputfile   Name of text file to read. Defaults to stdin.             ',&
'                                                                                ',&
'    PRINTABLE PAGE AREA                                                         ',&
'                                                                                ',&
'      The page size may be specified using -H for height, -W for width, and -u  ',&
'      to indicate the points per unit (72 makes H and W in inches,              ',&
'      1 is used when units are in font points). For example:                    ',&
'                                                                                ',&
'       -u 72 -H 8.5 -W 11   # page Height and Width in inches                   ',&
'       -T 0.5 -B 0.5 -L 0.5 -R 0.5   # margins (Top, Bottom, Left, Right)       ',&
'                                                                                ',&
'      common media sizes with -u 1:                                             ',&
'                                                                                ',&
'       +-------------------+------+------------+                                ',&
'       | name              |  W   |        H   |                                ',&
'       +-------------------+------+------------+                                ',&
'       | Letterdj (11x8.5) | 792  |       612  | (LandScape)                    ',&
'       | A4dj              | 842  |       595  |                                ',&
'       | Letter (8.5x11)   | 612  |       792  | (Portrait)                     ',&
'       | Legal             | 612  |       1008 |                                ',&
'       | A5                | 420  |       595  |                                ',&
'       | A4                | 595  |       842  |                                ',&
'       | A3                | 842  |       1190 |                                ',&
'       +-------------------+------+------------+                                ',&
'                                                                                ',&
'    SHADING                                                                     ',&
'        -g 0.800781      gray-scale value for shaded bars ( 0 < g 1 )           ',&
'                         0 is black, 1 is white.                                ',&
'        -i 2             repeat shade pattern every N lines                     ',&
'        -d '' ''           dashcode pattern                                     ',&
'                         The pattern is a series of integers defining an        ',&
'                         on-off sequence in user units used to create a         ',&
'                         dash pattern. A single digit "N" implies a pattern     ',&
'                         of "N N". (seems buggy)                                ',&
'                                                                                ',&
'    MARGIN LABELS                                                               ',&
'       -s ''''             top middle page label.                               ',&
'       -t ''''             top left page label.                                 ',&
'       -P                add page numbers to right corners                      ',&
'                                                                                ',&
'    TEXT OPTIONS                                                                ',&
'       -l 60             lines per page                                         ',&
'       -f Courier        font names: Courier, Courier-Bold,Courier-Oblique      ',&
'                         Helvetica, Symbol, Times-Bold, Helvetica-Bold,         ',&
'                         ZapfDingbats, Times-Italic, Helvetica-Oblique,         ',&
'                         Times-BoldItalic, Helvetica-BoldOblique,               ',&
'                         Times-Roman, Courier-BoldOblique                       ',&
'                                                                                ',&
'       -S 0              right shift 1 for non-ASA files                        ',&
'       -N                add line numbers                                       ',&
'    INFORMATION                                                                 ',&
'       -version          display version number                                 ',&
'       -help             display this help                                      ',&
'                                                                                ',&
'ENVIRONMENT VARIABLES                                                           ',&
'     o $IMPACT_TOP Will be printed in large red letters across the page top.    ',&
'     o $IMPACT_GRAY sets the default gray-scale value, same as the -g switch.   ',&
'                                                                                ',&
'EXAMPLES                                                                        ',&
' Sample input:                                                                  ',&
'                                                                                ',&
'  > The numbers are plain underlined double-struck over-struck                  ',&
'  >+                      __________ double-struck ///////////                  ',&
'  >R                                               ///////////                  ',&
'  > abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789-=_+()*&^%$#@!\|[]{};'':",.<>/?`~',&
'  >                                                                             ',&
'  >r red                                                                        ',&
'  >g     green                                                                  ',&
'  >b           blue                                                             ',&
'  > PRIMARY:                                                                    ',&
'  >R         red                                                                ',&
'  >G             green                                                          ',&
'  >B                   blue                                                     ',&
'  > 1/2 line advance                                                            ',&
'  >H                1                                                           ',&
'  >H                 2         a-1                                              ',&
'  >H                  3       Z                                                 ',&
'  >H                   4       b                                                ',&
'  > back to a normal line                                                       ',&
'                                                                                ',&
' Sample commands:                                                               ',&
'                                                                                ',&
'     # process  non-ASA file in portrait mode with a dashed line under every line ',&
'     asa2pdf -S 1 -W 8.5 -H 11 -i 1 -d ''2 4 1'' -T 1 -B .75 -o paper.pdf < INFILE',&
'                                                                                ',&
'     # banner on top                                                            ',&
'     env IMPACT_GRAY=1 IMPACT_TOP=CONFIDENTIAL asa2pdf -o paper.pdf < test.txt  ',&
'                                                                                ',&
'     # 132 landscape                                                            ',&
'      asa2pdf -s LANDSCAPE -o paper.pdf <asa2pdf.c                              ',&
'                                                                                ',&
'     # 132 landscape with line numbers with dashed lines                        ',&
'      asa2pdf -s ''LANDSCAPE LINE NUMBERS'' -d ''3 1 2'' \                      ',&
'      -N -T .9 -o paper.pdf <asa2pdf.c                                          ',&
'                                                                                ',&
'     # portrait 80 column non-ASA file with dashed lines                        ',&
'      asa2pdf -s PORTRAIT -S 1 -W 8.5 -H 11 -i 1 -d ''2 4 1'' \                 ',&
'      -T 1 -B .75 -o paper.pdf < asa2pdf.c                                      ',&
'                                                                                ',&
'     # portrait 80 column with line numbers , non-ASA                           ',&
'      asa2pdf -s ''PORTRAIT LINE NUMBERS'' -l 66 -S 1 -W 8.5 -H 11 \            ',&
'      -i 1 -T 1 -B .75 -N -o paper.pdf < asa2pdf.c                              ',&
'                                                                                ',&
'     # titling                                                                  ',&
'      asa2pdf -d ''1 0 1'' -t "$USER" -i 1 -P -N -T 1 \                         ',&
'      -s "asa2pdf.c" -o paper.pdf <asa2pdf.c                                    ',&
'                                                                                ',&
'SEE ALSO                                                                        ',&
'                                                                                ',&
'   ALTERNATIVES TO ASA2PDF                                                      ',&
'                                                                                ',&
'   About the only standard ASA support on Unix variants is that some            ',&
'   contain the asa(1)/fpr(1) and nasa(1) commands for converting ASA text       ',&
'   files into and from text files with machine control (MC) characters          ',&
'   such as form-feed, backspace, carriage-return, .... Most personal            ',&
'   printers will no longer properly print ASA files directly, but they          ',&
'   will often correctly print files with simple MC characters                   ',&
'   (Note that the asa(1) command is referenced in the POSIX.2 standard).        ',&
'                                                                                ',&
'   Furthermore, if a printer does not directly support MC characters,           ',&
'   text conversion utilities such as enscript(1) and a2ps(1) can                ',&
'   often be used to print the files (usually by converting the files            ',&
'   to PostScript or PCL). Such utilities support features such as               ',&
'   titling, page numbering, and other useful options.                           ',&
'                                                                                ',&
'   Programs like "Adobe Distiller" can convert text to a PDF; as well as        ',&
'   editors such as OpenOffice. In fact, most modern document-formatting         ',&
'   editors can read in an ASCII text file and save it as an Adobe               ',&
'   PDF file.                                                                    ',&
'                                                                                ',&
'   HTML and PostScript/PDF and PCL files are the alternatives often             ',&
'   incorporated to satisfy simple formatting criteria --                        ',&
'   yet HTML is not printer-oriented;                                            ',&
'   and PDF files are complex to write from a simple program, and PCL is         ',&
'   vendor-specific and has few on-line viewers available for it.                ',&
'                                                                                ',&
'                                                                                ',&
'   Assuming converting the Fortran program to just write a plain ASCII          ',&
'   file instead of an ASA file is not acceptable, More extensive flat-text      ',&
'   formatting is available using                                                ',&
'                                                                                ',&
'   o HTML, *roff and LaTex-related file formats                                 ',&
'   o libraries for writing more sophisticated PostScript, PDF, and HTML/CSS files',&
'   o XML files formatted using Cascading Style Sheet (CSS) files                ',&
'   o RTF (Rich Text Format) files                                               ',&
'                                                                                ',&
'   Other Unix commands that can be useful in working with plain text and        ',&
'   MC character files are                                                       ',&
'                                                                                ',&
'      pr(1)           can be used to add page numbers and titles.               ',&
'      expand(1)       can remove tab characters                                 ',&
'      fold(1),fmt(1)  can be used to wrap the text                              ',&
'      cut(1)          can let you trim or select columns                        ',&
'      cat -n          can be used to add number lines                           ',&
'      paste(1)        can be used to put files side-by-side.                    ',&
'                                                                                ',&
'asa(1)/nasa(1), fpr(1), enscript(1), a2ps(1), and ps2pdf(1).                    ',&
'                                                                                ',&
'']
   WRITE(*,'(a)')(trim(help_text(i)),i=1,size(help_text))
   stop ! if -help was specified, stop
endif
end subroutine help_usage
subroutine help_version(l_version)
implicit none
character(len=*),parameter     :: ident="@(#)help_version(3f): prints version information"
logical,intent(in)             :: l_version
character(len=:),allocatable   :: help_text(:)
integer                        :: i
logical                        :: stopit=.false.
stopit=.false.
if(l_version)then
help_text=[ CHARACTER(LEN=128) :: &
'@(#)PRODUCT:        CLI library utilities and examples>',&
!>PRODUCT:        CLI library utilities and examples
'@(#)PROGRAM:        asa2pdf(1f)>',&
!>PROGRAM:        asa2pdf(1f)
'@(#)DESCRIPTION:    convert text files with ASA carriage return to Adobe PDF files>',&
!>DESCRIPTION:    convert text files with ASA carriage return to Adobe PDF files
'@(#)VERSION:        2.0, 20170210>',&
!>VERSION:        2.0, 20170210
'@(#)AUTHOR:         John S. Urban>',&
!>AUTHOR:         John S. Urban
'@(#)COMPILED:       Sun, Mar 5th, 2017 11:22:47 PM>',&
'']
   WRITE(*,'(a)')(trim(help_text(i)(5:len_trim(help_text(i))-1)),i=1,size(help_text))
   stop ! if -version was specified, stop
endif
end subroutine help_version
!-----------------------------------------------------------------------------------------------------------------------------------
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
module M_kracken
implicit none
! "@(#)M_kracken(3f,module):parse command line options of Fortran programs using Unix-like syntax"
!===================================================================================================================================
   private
!-----------------------------------------------------------------------------------------------------------------------------------
   public :: kracken                ! define command and default parameter values from command arguments
   public :: setprompts             ! define prompts for commands in interactive mode
!-----------------------------------------------------------------------------------------------------------------------------------
   public :: rget                   ! fetch real    value of name VERB_NAME from the language dictionary
   public :: dget                   ! fetch double  value of name VERB_NAME from the language dictionary
   public :: iget                   ! fetch integer value of name VERB_NAME from the language dictionary
   public :: lget                   ! fetch logical value of name VERB_NAME from the language dictionary
   public :: sget                   ! fetch string  value of name VERB_NAME from the language dictionary.
   public :: sgetl                  ! fetch string  value of name VERB_NAME from the language dictionary.
   public :: retrev                 ! retrieve token value as string from Language Dictionary when given NAME
!-----------------------------------------------------------------------------------------------------------------------------------
   public :: delim                  ! parse a string and store tokens into an array
   public :: string_to_real         ! returns real value from numeric character string NOT USING CALCULATOR
   public :: string_to_dble         ! returns double precision value from numeric character string NOT USING CALCULATOR
!-----------------------------------------------------------------------------------------------------------------------------------
   private :: dissect               ! for user-defined commands: define defaults, then process user input
   private :: parse                 ! parse user command and store tokens into Language Dictionary
   private :: store                 ! replace dictionary name's value (if allow=add add name if necessary)
   private :: bounce                ! find location (index) in Language Dictionary where VARNAM can be found
   private :: add_string            ! Add new string name to Language Library dictionary
   private :: send_message
   private :: get_command_arguments ! get_command_arguments: return all command arguments as a string
   private :: igets                 ! return the subscript value of a string when given it's name
   private :: uppers                ! return copy of string converted to uppercase
   private :: menu                  ! generate an interactive menu when -? option is used
!-----------------------------------------------------------------------------------------------------------------------------------
! length of verbs and entries in Language dictionary
! NOTE:   many parameters were reduced in size so as to just accommodate being used as a command line parser.
!         In particular, some might want to change:
   integer, parameter,public :: IPic=400                           ! number of entries in language dictionary
   integer, parameter,public :: IPvalue=4096                       ! length of keyword value
   integer, parameter,public :: IPcmd=32768                        ! length of command
   integer, parameter,public :: IPverb=20                          ! length of verb
!-----------------------------------------------------------------------------------------------------------------------------------
   integer, parameter        :: dp = kind(0.d0)
   integer, parameter        :: k_int = SELECTED_INT_KIND(9)       ! integer*4
   integer, parameter        :: k_dbl = SELECTED_REAL_KIND(15,300) ! real*8
!-----------------------------------------------------------------------------------------------------------------------------------
   ! dictionary for Language routines
   character(len=IPvalue),dimension(IPic)     :: values=" "        ! contains the values of string variables
   character(len=IPverb),dimension(IPic)      :: dict_verbs=" "    ! string variable names
   integer(kind=k_int),dimension(IPic)        :: ivalue=0          ! significant lengths of string variable values
!-----------------------------------------------------------------------------------------------------------------------------------
contains
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
subroutine retrev(name,val,len,ier)
! "@(#)retrev(3f): retrieve token value from Language Dictionary when given NAME"
!-----------------------------------------------------------------------------------------------------------------------------------
      character(len=*),intent(in)  :: name        ! name of variable to retrieve value for in form VERB_NAME
      character(len=*),intent(out) :: val         ! value for requested variable
      integer,intent(out)          :: len         ! position of last non-blank character in requested variable
      integer,intent(out)          :: ier         ! error flag 0=found requested variable; -1=entry not found
!-----------------------------------------------------------------------------------------------------------------------------------
      integer                      :: isub        ! subscript in dictionary where requested entry and corresponding value are found
!-----------------------------------------------------------------------------------------------------------------------------------
      isub=igets(name)                            ! get index entry is stored at
!-----------------------------------------------------------------------------------------------------------------------------------
      if(isub > 0)then                            ! entry was in dictionary
         val=values(isub)                         ! retrieve corresponding value for requested entry
         len=ivalue(isub)                         ! get significant length of value
         ier=0                                    ! indicate requested entry name was successfully found
      else                                        ! entry was not in dictionary
         val=" "                                  ! set value to blank
         len=0                                    ! set length to zero
         ier=-1                                   ! set error flag to indicate requested entry was not found
      endif
!-----------------------------------------------------------------------------------------------------------------------------------
end subroutine retrev
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
subroutine string_to_dble(chars,value8,ierr)
! "@(#)string_to_dble(3f): returns double precision value from numeric character string"
                                                  !      works with any g-format input, including integer, real, and exponential.
      character(len=*),intent(in)  :: chars       ! string assumed to represent a numeric value
      real(kind=k_dbl),intent(out) :: value8      ! double precision value to return; set to zero on error.
      integer,intent(out)          :: ierr        ! if an error occurs in the read, a non-zero value is returned.
!-----------------------------------------------------------------------------------------------------------------------------------
      character(len=13)            :: frmt        ! FORMAT to use to read the value from the string
      integer                      :: ios         ! error flag returned from internal READ
!-----------------------------------------------------------------------------------------------------------------------------------
      ierr=0                                                     ! initialize the error flag
!-----------------------------------------------------------------------------------------------------------------------------------
      write(unit=frmt,fmt="( ""(bn,g"",i5,"".0)"" )")len(chars)  ! build FORMAT to read the value based on length of input string
      read(unit=chars,fmt=frmt,iostat=ios)value8                 ! read the value from the string using an internal read
!-----------------------------------------------------------------------------------------------------------------------------------
      if(ios /= 0 )then                                          ! if an error occurred in reading from the string report it
         value8=0.0_k_dbl                                        ! set the returned value to zero on error
         call send_message("*string_to_dble* - cannot produce number from this string["//trim(chars)//"]")
         ierr=ios
      endif
!-----------------------------------------------------------------------------------------------------------------------------------
end subroutine string_to_dble
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
subroutine string_to_real(chars,valu,ierr)
! "@(#)string_to_real(3f): returns real value from numeric character string"
      character(len=*),intent(in)  :: chars
      real,intent(out)             :: valu
      integer,intent(out)          :: ierr
      real(kind=k_dbl)             :: valu8
!-----------------------------------------------------------------------------------------------------------------------------------
      call string_to_dble(chars,valu8,ierr)         ! get value as double precision and stuff into a real variable
      valu=real(valu8)
!-----------------------------------------------------------------------------------------------------------------------------------
end subroutine string_to_real
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
function dget(keyword)
! "@(#)dget(3f): given keyword fetch value from Language Dictionary as a dble (zero on error)"
   real(kind=dp)               :: dget              ! function type
!-----------------------------------------------------------------------------------------------------------------------------------
   character(len=*),intent(in) :: keyword           ! keyword to retrieve value for from dictionary
!-----------------------------------------------------------------------------------------------------------------------------------
   character(len=IPvalue)      :: value             ! value returned
   integer                     :: len               ! length of value found
   integer                     :: ier               ! error flag on call to retrieve value
   real(kind=dp)               :: a8                ! number to return
!-----------------------------------------------------------------------------------------------------------------------------------
   value=" "                                        ! initialize value found for keyword in case an error occurs
   call retrev(keyword, value, len, ier)            ! find value associated with keyword
   call string_to_dble(value(:len), a8, ier)        ! convert the string to a numeric value
   dget = a8
!-----------------------------------------------------------------------------------------------------------------------------------
end function dget
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
function rget(keyword)
! "@(#)rget(3f): given keyword, fetch single real value from language dictionary (zero on error)"
!-----------------------------------------------------------------------------------------------------------------------------------
   real                        :: rget             ! function type
   character(len=*),intent(in) :: keyword          ! keyword to retrieve value for from dictionary
!-----------------------------------------------------------------------------------------------------------------------------------
   rget=real(dget(keyword))                        ! just call DGET(3f) but change returned value to type REAL
!-----------------------------------------------------------------------------------------------------------------------------------
end function rget
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
function iget(keyword)
! "@(#)iget(3f): given keyword, fetch integer value from language dictionary (zero on error)"
!-----------------------------------------------------------------------------------------------------------------------------------
   integer                      :: iget            ! function type
   character(len=*),intent(in)  :: keyword         ! keyword to retrieve value for from dictionary
!-----------------------------------------------------------------------------------------------------------------------------------
   iget = int(dget(keyword))                       ! just call DGET(3f) but change returned value to type INTEGER
!-----------------------------------------------------------------------------------------------------------------------------------
end function iget
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
function lget(keyword)
! "@(#)lget(3f): given keyword, fetch logical value from language dictionary (zero on error)"
!-----------------------------------------------------------------------------------------------------------------------------------
   logical                      :: lget            ! procedure type
   character(len=*),intent(in)  :: keyword         ! the dictionary keyword (in form VERB_KEYWORD) to retrieve
!-----------------------------------------------------------------------------------------------------------------------------------
   character(len=IPvalue)       :: value           ! value corresponding to the requested keyword
   integer                      :: len             ! length of VALUE returned by RETREV(3f)
   integer                      :: ier             ! flag returned by RETREV(3f) indicating if an error occurred in retrieving value
!-----------------------------------------------------------------------------------------------------------------------------------
   lget=.false.                                    ! initialize return value to .false.
   call retrev(keyword, value, len, ier)           ! get value for corresponding keyword from language dictionary
                                                   ! report on error ????
   value=adjustl(uppers(value,len))                ! convert value to uppercase, left spaces trimmed
!-----------------------------------------------------------------------------------------------------------------------------------
   if(value(:len).ne."#N#")then
      select case(value(1:1))                      ! check first letter
      case('T','Y',' ')                            ! anything starting with "T" or "Y" or a blank is TRUE (true,t,yes,y,...)
         lget=.true.
      case('F','N')                                ! assume this is false or no
         lget=.false.
      case('.')                                    ! looking for fortran logical syntax .STRING.
         select case(value(2:2))
         case('T')                                 ! assume this is .t. or .true.
            lget=.true.
         case('F')                                 ! assume this is .f. or .false.
            lget=.false.
         case default
            call send_message("*lget* bad logical expression for "//keyword(:len_trim(keyword))//'='//value(:len))
         end select
      case default
            call send_message("*lget* bad logical expression for "//keyword(:len_trim(keyword))//'='//value(:len))
      end select
   else                                            ! special value "#N#" is assumed FALSE
      lget=.false.
   endif
!-----------------------------------------------------------------------------------------------------------------------------------
end function lget
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
character(len=IPvalue) function sget(name,ilen) result(string)
! "@(#)sget(3f): Fetch string value and length of specified NAME the language dictionary"
!     This routine trusts that the desired name exists. A blank is returned if the name is not in the dictionary
      character(len=*),intent(in)   :: name     !  name to look up in dictionary
      integer,intent(out),optional  :: ilen     !  length of returned output string
!-----------------------------------------------------------------------------------------------------------------------------------
      integer                       :: isub     ! index where verb_oo is stored or -1 if this is an unknown name
!-----------------------------------------------------------------------------------------------------------------------------------
      isub=igets(name)                          ! given name return index name is stored at
!-----------------------------------------------------------------------------------------------------------------------------------
      if(isub > 0)then                          ! if index is valid return string
         string=values(isub)
      else                                      ! if index is not valid return blank string
         string(:)=" "
      endif
!-----------------------------------------------------------------------------------------------------------------------------------
      if(present(ilen))then                     ! if ILEN is present on call, return the value
         ilen=ivalue(isub)
      endif
!-----------------------------------------------------------------------------------------------------------------------------------
end function sget
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
function sgetl(name,ilen) result(string)
! "@(#)sgetl(3f): Fetch string value for NAME from language dictionary up to length ILEN"
!     This routine trusts that the desired name exists. A blank is returned if the name is not in the dictionary
      character(len=*),intent(in)  :: name        ! name to look up in dictionary
      integer,intent(in)           :: ilen        ! length of returned output string
!-----------------------------------------------------------------------------------------------------------------------------------
      character(len=ilen)          :: string
      integer                      :: isub
!-----------------------------------------------------------------------------------------------------------------------------------
      isub=igets(name)                            ! given name return index name is stored at
!-----------------------------------------------------------------------------------------------------------------------------------
      if(isub > 0)then                            ! if index is valid return string
         string=values(isub)
      else                                        ! if index is not valid return blank string
         string(:)=" "
      endif
!-----------------------------------------------------------------------------------------------------------------------------------
end function sgetl
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
subroutine kracken(verb,string,error_return)
! "@(#)kracken(3f): define and parse command line options"
!     get the entire command line argument list and pass it and the
!     prototype to dissect()
!-----------------------------------------------------------------------------------------------------------------------------------
      character(len=*),intent(in)    :: string
      character(len=*),intent(in)    :: verb
      integer,intent(out),optional   :: error_return
!-----------------------------------------------------------------------------------------------------------------------------------
      character(len=IPcmd)           :: command
      integer                        :: ilen
      integer                        :: ier
!-----------------------------------------------------------------------------------------------------------------------------------
      if(present(error_return))error_return=0
!-----------------------------------------------------------------------------------------------------------------------------------
      call get_command_arguments(command,ilen,ier)
      if(ier.ne.0)then
         call send_message("*kracken* could not get command line arguments")
         if(present(error_return))error_return=ier
      else
         call dissect(verb,string,command(:ilen),ilen,ier)
         ! if calling procedure is not testing error flag stop program on error
         if(.not.present(error_return).and.ier.ne.0)then
            call send_message("*kracken* (V 20151212) STOPPING: error parsing arguments")
            stop
         endif
      endif
!-----------------------------------------------------------------------------------------------------------------------------------
end subroutine kracken
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
subroutine setprompts(verb,init)
! "@(#)setprompts(3f): set explicit prompts for keywords in interactive mode"
      character(len=*),intent(in)  :: verb   ! verb name to define prompts for
      character(len=*),intent(in)  :: init   ! string to define prompts instead of values
      call parse('?'//trim(verb),init,"add") ! initialize command, prefixing verb with question mark character to designate prompts
end subroutine setprompts
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
subroutine dissect(verb,init,pars,ipars,error_return)
! "@(#)dissect(3f): convenient call to parse() -- define defaults, then process"
!
      character(len=*),intent(in)  :: verb            ! the name of the command to be reset/defined  and then set
      character(len=*),intent(in)  :: init            ! used to define or reset command options; usually hard-set in the program.
      character(len=*),intent(in)  :: pars            ! defines the command options to be set, usually from a user input file
      integer,intent(in)           :: ipars           ! length of the user-input string pars.
      integer,intent(out),optional :: error_return
!-----------------------------------------------------------------------------------------------------------------------------------
      integer                      :: ier
      character(len=IPvalue)       :: varvalue        ! value of environment variable
      integer                      :: ipars2
!-----------------------------------------------------------------------------------------------------------------------------------
      call store(trim(verb)//'_?','.false.',"add",ier)  ! all commands have the option -? to invoke prompt mode
      call parse(trim(verb),init,"add") ! initialize command
!-----------------------------------------------------------------------------------------------------------------------------------
      ! if environment variable DEFAULT_verbname is set apply it as defaults to define _verb values
      ! for programs that want to determine the values set by the command definition and the variable
      ! before user selections are applied
      call parse('_'//trim(verb),init,"add") ! initialize _command
      call get_environment_variable('DEFAULT_'//trim(verb),varvalue)
      call parse('_'//trim(verb),trim(varvalue),"no_add") ! process and store as _CMD_VERB for appending
!-----------------------------------------------------------------------------------------------------------------------------------
      if(varvalue.ne.' ')then
         call parse(verb,trim(varvalue),"no_add")            ! process environment variable
      endif
!-----------------------------------------------------------------------------------------------------------------------------------
      if(ipars <= 0)then
         ipars2=len(pars(:ipars))
      else
         ipars2=ipars
      endif
!-----------------------------------------------------------------------------------------------------------------------------------
      call parse(verb,pars(:ipars2),"no_add",ier) ! process user command options
      if(lget(trim(verb)//'_?'))then    ! if -? option was present prompt for values
         call menu(verb)
      endif
      if(present(error_return))error_return=ier
!-----------------------------------------------------------------------------------------------------------------------------------
end subroutine dissect
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
subroutine parse(verb,string,allow,error_return)
! "@(#)parse(3f,private): parse user command and store tokens into Language Dictionary"
!!!   set up odd for future expansion
!!!   need to handle a minus followed by a blank character
!-----------------------------------------------------------------------------------------------------------------------------------
!     given a string of form
!         verb  -keyword1 value1 -keyword2 value2 ...
!     define three arrays of the form
!     verb_keyword(i) : value(i)  : len_trim(value(i))
!     -keyword(i) will become verb__keyword(i)
!
!     values may be in double quotes.
!     if tokens contain alphameric characters an unquoted # signifies the rest of the line is a comment.
!     adjacent double quotes put one double quote into value
!     processing ends when an end of string is encountered
!     the variable name for the first value is verb_oo
!     call it once to give defaults
!     leading and trailing blanks are removed from values
!
!-----------------------------------------------------------------------------------------------------------------------------------
! @(#)parse+ for left-over command string for Language routines
!     optionally needed if you are going to allow multiple commands on a line
      ! number of characters left over,
      ! number of non-blank characters in actual parameter list
!-----------------------------------------------------------------------------------------------------------------------------------
      character(len=*),intent(in)          :: verb
      character(len=*),intent(in)          :: string
      character(len=*),intent(in)          :: allow
      character(len=IPvalue+2)             :: dummy
      character(len=IPvalue),dimension(2)  :: var
      character(len=3)                     :: delmt
      character(len=2)                     :: init
      character(len=1)                     :: currnt
      character(len=1)                     :: prev
      character(len=1)                     :: forwrd
      character(len=IPvalue)               :: val
      character(len=IPverb)                :: name
      integer,dimension(2)                 :: ipnt
      integer                              :: ilist
      integer                              :: ier
      integer,optional,intent(out)         :: error_return
      integer                              :: islen
      integer                              :: ipln
      integer                              :: ipoint
      integer                              :: itype
      integer                              :: ifwd
      integer                              :: ibegin
      integer                              :: iend
!-----------------------------------------------------------------------------------------------------------------------------------
      ilist=1
      init="oo"
      ier=0
      if(present(error_return)) error_return=0
      islen=len_trim(string)   ! find number of characters in input string
      ! if input string is blank, even default variable will not be changed
      if(islen  ==  0)then
         return
      endif
      dummy=string             ! working mutable copy of STRING
      ipln=len_trim(verb)      ! find number of characters in verb prefix string
!-----------------------------------------------------------------------------------------------------------------------------------
      var(2)=init         ! initial variable name
      var(1)=" "          ! initial value of a string
      ipoint=0            ! ipoint is the current character pointer for (dummy)
      ipnt(2)=2           ! pointer to position in parameter name
      ipnt(1)=1           ! pointer to position in parameter value
      itype=1             ! itype=1 for value, itype=2 for variable
!-----------------------------------------------------------------------------------------------------------------------------------
      delmt="off"
      prev=" "
!-----------------------------------------------------------------------------------------------------------------------------------
      do
      ipoint=ipoint+1               ! move current character pointer forward
      currnt=dummy(ipoint:ipoint)   ! store current character into currnt
      ifwd=min(ipoint+1,islen)
      forwrd=dummy(ifwd:ifwd)       ! next character (or duplicate if last)
!-----------------------------------------------------------------------------------------------------------------------------------
      if((currnt=="-".and.prev==" ".and.delmt == "off".and.index("0123456789.",forwrd) == 0).or.ipoint > islen)then
      ! beginning of a parameter name
         if(forwrd.eq.'-')then         ! change --var to -var so "long" syntax is supported
            dummy(ifwd:ifwd)='_'
            ipoint=ipoint+1            ! ignore second - instead
         endif
         if(ipnt(1)-1 >= 1)then
            ibegin=1
            iend=len_trim(var(1)(:ipnt(1)-1))
            do
               if(iend  ==  0)then   !len_trim returned 0, parameter value is blank
                  iend=ibegin
                  exit
               else if(var(1)(ibegin:ibegin) == " ")then
                  ibegin=ibegin+1
               else
                  exit
               endif
            enddo
            name=verb(:ipln)//"_"//var(2)(:ipnt(2))
            val=var(1)(ibegin:iend)
            if(var(2)(:ipnt(2)).eq.'oo'.and.allow.ne.'add'.and.val.eq.'')then
               ! do not allow a blank value to override initial value so can have default
            else
               call store(name,val,allow,ier)       ! store name and it's value
            endif
            if(present(error_return).and.ier.ne.0)error_return=ier
         else
            name=verb(:ipln)//"_"//var(2)(:ipnt(2))
            val=" "                                 ! store name and null value
            call store(name,val,allow,ier)
            if(present(error_return).and.ier.ne.0)error_return=ier
         endif
         ilist=ilist+ipln+1+ipnt(2)
         ilist=ilist+1
         itype=2                          ! change to filling a variable name
         var(1)=" "                       ! clear value for this variable
         var(2)=" "                       ! clear variable name
         ipnt(1)=1                        ! restart variable value
         ipnt(2)=1                        ! restart variable name
!-----------------------------------------------------------------------------------------------------------------------------------
      elseif(currnt == "#".and.delmt == "off")then   ! rest of line is comment
         islen=ipoint
         dummy=" "
         prev=" "
         cycle
!-----------------------------------------------------------------------------------------------------------------------------------
      ! rest of line is another command(s)
         islen=ipoint
         dummy=" "
         prev=" "
         cycle
!-----------------------------------------------------------------------------------------------------------------------------------
      else       ! currnt is not one of the special characters
         ! the space after a keyword before the value
         if(currnt == " ".and.itype  ==  2)then
            ! switch from building a keyword string to building a value string
            itype=1
         ! beginning of a delimited parameter value
         elseif(currnt  ==  """".and.itype  ==  1)then
            ! second of a double quote, put quote in
            if(prev  ==  """")then
                var(itype)(ipnt(itype):ipnt(itype))=currnt
                ipnt(itype)=ipnt(itype)+1
                delmt="on"
            elseif(delmt  ==  "on")then     ! first quote of a delimited string
                delmt="off"
            else
                delmt="on"
            endif
         else     ! add character to current parameter name or parameter value
            var(itype)(ipnt(itype):ipnt(itype))=currnt
            ipnt(itype)=ipnt(itype)+1
            if(currnt /= " ")then
            endif
         endif
!-----------------------------------------------------------------------------------------------------------------------------------
      endif
!-----------------------------------------------------------------------------------------------------------------------------------
      prev=currnt
      if(ipoint <= islen)then
         cycle
      endif
      exit
      enddo
end subroutine parse
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
subroutine store(name1,value1,allow1,ier)
! "@(#)store(3f,private): replace dictionary name's value (if allow='add' add name if necessary)"
!-----------------------------------------------------------------------------------------------------------------------------------
      character(len=*),intent(in)        :: name1       ! name in dictionary of from VERB_KEYWORD
      character(len=*),intent(in)        :: value1      ! value to be associated to NAME1
      character(len=*),intent(in)        :: allow1      ! flag to allow new VERB_KEYWORD name being added
      integer,intent(out)                :: ier         ! flag if error occurs in adding or setting value
!-----------------------------------------------------------------------------------------------------------------------------------
      character(len=IPverb)              :: name
      integer                            :: indx
      character(len=10)                  :: allow
      character(len=IPvalue)             :: value
      character(len=IPvalue)             :: mssge       !  the  message/error/string  value
      integer                            :: nlen
      integer                            :: new
      integer                            :: ii
      integer                            :: i10
!-----------------------------------------------------------------------------------------------------------------------------------
      value=" "
      name=" "
      allow=" "
      name=name1                                        ! store into a standard size variable for this type
      value=value1                                      ! store into a standard size variable for this type
      allow=allow1                                      ! store into a standard size variable for this type
      nlen=len(name1)
!-----------------------------------------------------------------------------------------------------------------------------------
      call bounce(name,indx,dict_verbs,ier,mssge)       ! determine storage placement of the variable and whether it is new
      if(ier  ==  -1)then                               ! an error occurred in determining the storage location
         call send_message("error occurred in *store*")
         call send_message(mssge)
         return
      endif
!-----------------------------------------------------------------------------------------------------------------------------------
      if(indx > 0)then                                  ! found the variable name
         new=1
      else if(indx <= 0.and.allow  ==  "add")then       ! check if the name needs added
         call add_string(name,nlen,indx,ier)            ! adding the new variable name in the variable name array
         if(ier  ==  -1)then
            call send_message("*store* could not add "//name(:nlen))
            call send_message(mssge)
            return
         endif
         new=0
!-----------------------------------------------------------------------------------------------------------------------------------
      else                                              ! did not find variable name but not allowed to add it
         ii=index(name,"_")
         call send_message("########################################################")
         call send_message("error: UNKNOWN OPTION -"//name(ii+1:))
         if(ii > 0)then
            call send_message(name(:ii-1)//" parameters are")
            do i10=1,IPic
               if(name(:ii)  ==  dict_verbs(i10)(:ii))then
                  if(dict_verbs(i10)(ii:ii+1).eq.'__')then
                     call send_message(" --"//dict_verbs(i10)(ii+2:len_trim(dict_verbs(i10)))//" "//values(i10)(:ivalue(i10)))
                  else
                     call send_message(" -"//dict_verbs(i10)(ii+1:len_trim(dict_verbs(i10)))//" "//values(i10)(:ivalue(i10)))
                  endif
               endif
            enddo
         endif
         call send_message("########################################################")
         ier=-10
         return
      endif
!-----------------------------------------------------------------------------------------------------------------------------------
      values(iabs(indx))=value               ! store a defined variable's value
      ivalue(iabs(indx))=len_trim(value)     ! store length of string
!-----------------------------------------------------------------------------------------------------------------------------------
end subroutine store
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
subroutine bounce(varnam,index,dictionary,ier,mssge)
! "@(#)bounce(3f,private): find index in Language Dictionary where VARNAM can be found"
!
!     If VARNAM is not found report where it should be placed as a NEGATIVE index number.
!     Assuming DICTIONARY is an alphabetized array
!     Assuming all variable names are lexically greater than a blank string.
!-----------------------------------------------------------------------------------------------------------------------------------
      character(len=*),intent(in)                :: varnam      ! variable name to look up in dictionary
      integer,intent(out)                        :: index       ! location where variable is or should be
      character(len=*),dimension(:),intent(in)   :: dictionary  ! sorted dictionary array to find varnam in
      integer,intent(out)                        :: ier
      character(len=*),intent(out)               :: mssge
!-----------------------------------------------------------------------------------------------------------------------------------
      integer                                    :: maxtry      ! maximum number of tries that should be required
      integer                                    :: imin
      integer                                    :: imax
      integer                                    :: i10
!-----------------------------------------------------------------------------------------------------------------------------------
      maxtry=int(log(float(IPic))/log(2.0)+1.0)                 ! calculate max number of tries required to find a conforming name
      index=(IPic+1)/2
      imin=1
      imax=IPic
!-----------------------------------------------------------------------------------------------------------------------------------
      do i10=1,maxtry
         if(varnam  ==  dictionary(index))then
            return
         else if(varnam > dictionary(index))then
            imax=index-1
         else
            imin=index+1
         endif
         if(imin > imax)then
            index=-imin
            if(iabs(index) > IPic)then
               mssge="error 03 in bounce"
               ier=-1
               return
            endif
            return
         endif
         index=(imax+imin)/2
         if(index > IPic.or.index <= 0)then
            mssge="error 01 in bounce"
            ier=-1
            return
         endif
      enddo
!-----------------------------------------------------------------------------------------------------------------------------------
      mssge="error 02 in bounce"
!-----------------------------------------------------------------------------------------------------------------------------------
end subroutine bounce
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
subroutine add_string(newnam,nchars,index,ier)
! "@(#)add_string(3f,private): Add new string name to Language Library dictionary"
!=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
      character(len=*),intent(in)       :: newnam     ! new variable name to add to dictionary
      integer,intent(in)                :: nchars     ! number of characters in NEWNAM
      integer,intent(in)                :: index
      integer,intent(out)               :: ier
!=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
      integer                           :: istart
      integer                           :: i10
!=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
      istart=iabs(index)
!=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
!     if last position in the name array has already been used, then report no room is left and set error flag and error message.
      if(dict_verbs(IPic) /= " ")then                 ! check if dictionary full
         call send_message("*add_string* no room left to add more string variable names")
         ier=-1
!=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
      elseif(istart.gt.IPic)then
         call send_message("*add_string* dictionary size exceeded")
         ier=-1
!=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
      else
         do i10=IPic-1,istart,-1
!           pull down the array to make room for new value
            values(i10+1)=values(i10)
            ivalue(i10+1)=ivalue(i10)
            dict_verbs(i10+1)=dict_verbs(i10)
         enddo
         values(istart)=" "
         ivalue(istart)= 0
         dict_verbs(istart)=newnam(1:nchars)
!=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
      endif
!=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
end subroutine add_string
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
function igets(chars0)
! "@(#)igets(3f,private): return the subscript value of a string when given it's name"
!     WARNING: only request value of names known to exist
!-----------------------------------------------------------------------------------------------------------------------------------
      character(len=*),intent(in)        :: chars0
!-----------------------------------------------------------------------------------------------------------------------------------
      character(len=IPverb)              :: chars
      character(len=IPvalue)             :: mssge
      integer                            :: ierr
      integer                            :: index
      integer                            :: igets
!-----------------------------------------------------------------------------------------------------------------------------------
      chars=chars0
      ierr=0
      index=0
      call bounce(chars,index,dict_verbs,ierr,mssge)             ! look up position
!-----------------------------------------------------------------------------------------------------------------------------------
      if((ierr  ==  -1).or.(index <= 0))then
         call send_message("*igets* variable "//trim(chars)//" undefined")
         igets=-1                                                ! very unfriendly subscript value
      else
         igets=index
      endif
!-----------------------------------------------------------------------------------------------------------------------------------
end function igets
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
subroutine delim(line0,array,n,iicount,ibegin,iterm,ilen,dlim)
! "@(#)delim(3f): parse a string and store tokens into an array"
!
!     given a line of structure " par1 par2 par3 ... parn "
!     store each par(n) into a separate variable in array.
!
!     IF ARRAY(1) = '#N#' do not store into string array  (KLUDGE))
!
!     also icount number of elements of array initialized, and
!     return beginning and ending positions for each element.
!     also return position of last non-blank character (even if more
!     than n elements were found).
!
!     no quoting of delimiter is allowed
!     no checking for more than n parameters, if any more they are ignored
!
      character(len=*),intent(in)                 :: line0
      integer,intent(in)                          :: n
      !character(len=*),dimension(n),intent(out)  :: array
      character(len=*),dimension(:),intent(out)   :: array
      integer,intent(out)                         :: iicount
      !integer,dimension(n),intent(out)           :: ibegin
      integer,dimension(:),intent(out)            :: ibegin
      !integer,dimension(n),intent(out)           :: iterm
      integer,dimension(:),intent(out)            :: iterm
      integer,intent(out)                         :: ilen
      character(len=*),intent(in)                 :: dlim
      character(len=IPcmd)                        :: line
      logical                                     :: lstore
      integer                                     :: idlim
      integer                                     :: icol
      integer                                     :: iarray
      integer                                     :: istart
      integer                                     :: iend
      integer                                     :: i10
      integer                                     :: ifound
      iicount=0
      ilen=len_trim(line0)
      if(ilen > IPcmd)then
         call send_message("*delim* input line too long")
      endif
      line=line0
      idlim=len(dlim)
      if(idlim > 5)then
         idlim=len_trim(dlim)                                ! dlim a lot of blanks on some machines if dlim is a big string
         if(idlim  ==  0)then
            idlim=1  ! blank string
         endif
      endif
!     command was totally blank
      if(ilen  ==  0)then
         return
      endif
!     there is at least one non-blank character in the command
!     ilen is the column position of the last non-blank character
!     find next non-delimiter
      icol=1
      if(array(1)  ==  "#N#")then                            ! special flag to not store into character array
         lstore=.false.
      else
         lstore=.true.
      endif
      do iarray=1,n,1                                        ! store into each array element until done or too many words
         if(index(dlim(1:idlim),line(icol:icol))  ==  0)then ! if current character is not a delimiter
           istart=icol                                       ! start new token on the non-delimiter character
           ibegin(iarray)=icol
           iend=ilen-istart+1+1                              ! assume no delimiters so put past end of line
           do i10=1,idlim
              ifound=index(line(istart:ilen),dlim(i10:i10))
              if(ifound > 0)then
                iend=min(iend,ifound)
              endif
           enddo
            if(iend <= 0)then                              ! no remaining delimiters
              iterm(iarray)=ilen
              if(lstore)then
                 array(iarray)=line(istart:ilen)
              endif
              iicount=iarray
              return
            else
              iend=iend+istart-2
              iterm(iarray)=iend
              if(lstore)then
                 array(iarray)=line(istart:iend)
              endif
            endif
           icol=iend+2
         else
           icol=icol+1
           cycle
         endif
   !     last character in line was a delimiter, so no text left
   !     (should not happen where blank=delimiter)
         if(icol > ilen)then
           iicount=iarray
           return
         endif
      enddo
!     more than n elements
      iicount=n
end subroutine delim
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
subroutine send_message(msg)
! "@(#)send_message(3f,private): general message routine"
      character(len=*),intent(in) :: msg                      ! message to display
      print "(""# "",a)", msg(:len_trim(msg))               ! write message
end subroutine send_message
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
subroutine get_command_arguments(string,istring_len,istatus)
! "@(#)get_command_arguments(3f,private): return all command arguments as a string"
!-----------------------------------------------------------------------------------------------------------------------------------
   character(len=*),intent(out) :: string                     ! string of all arguments to create
   integer,intent(out)          :: istring_len                ! last character position set in output string
   integer,intent(out)          :: istatus                    ! status (non-zero means error)
!-----------------------------------------------------------------------------------------------------------------------------------
   integer                      :: istring_len_new            ! length of output if append next argument
   integer                      :: string_len                 ! allowed length of output string
   integer                      :: ilength                    ! length of individual arguments
   integer                      :: i                          ! loop count
   character(len=IPvalue)       :: value                      ! store individual arguments one at a time
   integer                      :: ifoundspace
!-----------------------------------------------------------------------------------------------------------------------------------
   string=""                                                  ! initialize returned output string
   string_len=len(string)                                     ! find out how big the output string can be
   istring_len=0                                              ! initialize returned output string length
   istatus=0                                                  ! initialize returned error code
!-----------------------------------------------------------------------------------------------------------------------------------
   do i=1,command_argument_count()                            ! append any arguments together
      call get_command_argument(i,value,ilength,istatus)      ! get next argument
      istring_len_new=istring_len+ilength+1                   ! calculate total string length plus one for a separator
      !---------------------
      ! BEGIN GUESS AT RE-QUOTING STRING
      !---------------------
      ! if argument contains a space and does not contain a double-quote and is short enough to have double quotes added
      ! assume this argument was quoted but that the shell stripped the quotes and add double quotes. This is an optional
      ! behavior and assumes an operating system that strips the quotes from quoted strings on the command line. If the
      ! operating system is smarter than that remove this section
      if(ilength.gt.0)then
         ifoundspace=index(value(:ilength),' ')
         if(index(value(:ilength),' ').ne.0.and.index(value(:ilength),'"').eq.0)then
            ilength=ilength+2
            if(ilength.le.len(value))then
               value='"'//value(:ilength)//'"'
            endif
         endif
      endif
      !---------------------
      ! END GUESS AT RE-QUOTING STRING
      !---------------------
      if(ilength.gt.len(value))then
         call send_message('*get_command_arguments* argument too big')
         stop
      elseif(istatus /= 0) then                               ! stop appending on error
         call send_message('*get_command_arguments* error obtaining argument')
         stop
      elseif(istring_len_new.gt.string_len)then               ! not enough room to store argument
         call send_message('*get_command_arguments* output too long, command trimmed')
         stop
      endif
      string=string(:istring_len)//value(:ilength)            ! append strings together
      istring_len=istring_len_new
   enddo
   istring_len=len_trim(string)                               ! keep track of length and so do not need to use len_trim
!-----------------------------------------------------------------------------------------------------------------------------------
end subroutine get_command_arguments
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
function uppers(input_string,output_size) result (output_string)
! "@(#)uppers(3f,private): return copy of input string converted to uppercase"
!-----------------------------------------------------------------------------------------------------------------------------------
      character(len=*),intent(in) :: input_string         ! input string to convert to uppercase
      integer,intent(in)          :: output_size          ! size of output string
      character(len=output_size)  :: output_string        ! output string converted to uppercase
!-----------------------------------------------------------------------------------------------------------------------------------
      character(len=1)            :: letter               ! current letter
      integer                     :: ilet                 ! ADE (ASCII Decimal Equivalent) of current letter
      integer                     :: icount               ! counter used to increment thru the input string
!-----------------------------------------------------------------------------------------------------------------------------------
      if(len_trim(input_string).gt.output_size)then       ! warn that length of input longer than length of output
         call send_message("*uppers* - input string longer than output string")
      endif
!-----------------------------------------------------------------------------------------------------------------------------------
      output_string=" "                                   ! initialize output string to all blanks
!-----------------------------------------------------------------------------------------------------------------------------------
      do icount=1,min(output_size,len_trim(input_string)) ! loop thru input one character at a time up to length of output string
         letter=input_string(icount:icount)               ! extract next letter
         ilet=ichar(letter)                               ! get integer ADE (ASCII Decimal Equivalent) of letter
                                                          ! NOTE: lowercase a-z in ASCII is an ADE of 97 to 122
                                                          !       uppercase A-Z in ASCII is an ADE of 65 to 90
         if((ilet >= 97) .and.(ilet <= 122))then          ! find if current letter is a lowercase letter
            output_string(icount:icount)=char(ilet-32)    ! convert lowercase a-z to uppercase A-Z and store into output string
         else                                             ! character is not a lowercase letter, just put it in output
            output_string(icount:icount)=letter           ! store character as-is
         endif
      enddo
!-----------------------------------------------------------------------------------------------------------------------------------
end function uppers
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
subroutine menu(verb)
! "@(#)menu(3f,private): prompt for values using a menu interface"
!-----------------------------------------------------------------------------------------------------------------------------------
   character(len=*),intent(in)    :: verb
!-----------------------------------------------------------------------------------------------------------------------------------
   character(len=IPvalue)         :: reply
   character(len=IPvalue)         :: prompt
   integer                        :: ii
   integer                        :: icount
   integer                        :: ios
   integer                        :: i10
   integer                        :: i20
   integer                        :: istart
   integer                        :: iend
   integer                        :: ifound
   integer                        :: ireply
   real                           :: valu
   integer                        :: ierr
   integer                        :: index
   character(len=IPvalue)         :: mssge   !  the message/error/string  value returned by BOUNCE(3f)
!-----------------------------------------------------------------------------------------------------------------------------------
   ii=len_trim(verb)
   write(*,*)verb(:ii)//" parameters are"
   istart=1
!-----------------------------------------------------------------------------------------------------------------------------------
   INFINITE: do
      icount=0                                                ! how many entries in the dictionary belong to this command
      iend=IPic                                               ! last dictionary entry to search for current command
      MAKEMENU: do i10=istart,iend                            ! search dictionary for keywords for current command
         if(verb(:ii)//'_'  ==  dict_verbs(i10)(:ii+1))then   ! found part of the desired command
            if(istart.eq.0)istart=i10                         ! store index to the beginning of this command
            icount=icount+1                                   ! count keywords that start with VERB_
            if(dict_verbs(i10).eq.verb(:ii)//'_?')then        ! do not show the keyword VERB_?
               cycle MAKEMENU
            endif
            call bounce('?'//dict_verbs(i10),index,dict_verbs,ierr,mssge) ! if ?VERB is defined assume it is a prompt
            if(index.gt.0)then
               prompt=values(index)
            else
               prompt=' '
            endif
            if(prompt.eq.'')then
               write(*,'(i4,")",a,a)') i10,dict_verbs(i10)(ii+2:),trim(values(i10)(:ivalue(i10)))
            elseif(prompt.eq.'#N#')then                       ! special prompt value which means to skip prompting
            else
               write(*,'(i4,")",a,":[",a,"]")') i10,trim(prompt),trim(values(i10))
            endif
         endif
      enddo MAKEMENU
      iend=icount+istart-1                                 ! no need to go thru entire dictionary on subsequent passes
!-----------------------------------------------------------------------------------------------------------------------------------
      write(*,'(a)',advance='no')'Enter number of parameter to change(0 to finish):'
      read(*,'(a)',iostat=ios)reply
      reply=adjustl(reply)
      valu=-1
!-----------------------------------------------------------------------------------------------------------------------------------
      if(reply(1:1).eq.'-')then            ! assume this is the beginning of a respecification of options using -keyword value ...
         call parse(verb,trim(reply)//' -? .false.',"no_add")
         cycle INFINITE
      endif
!-----------------------------------------------------------------------------------------------------------------------------------
      select case(REPLY)
!-----------------------------------------------------------------------------------------------------------------------------------
      case('@DUMP')                                   ! debug option to dump dictionary
         do i20=1,IPic
            if(dict_verbs(i20).ne.' ')then
                 write(*,'(a,a,a)')i20,dict_verbs(i20),':',trim(values(i20)(:ivalue(i20)))
            endif
         enddo
         cycle INFINITE
!-----------------------------------------------------------------------------------------------------------------------------------
      case('.','q')
         stop
         !exit INFINITE
!-----------------------------------------------------------------------------------------------------------------------------------
      case('?')
         write(*,*)'--------------------------------------------------------------------------------'
         write(*,*)' Enter '
         write(*,*)'   o  NNN                   the number of the option to change the value for'
         write(*,*)'   o  "-keyword value ..."  to respecify values'
         write(*,*)'   o  ?                     display this help'
         write(*,*)'   o  .                     stop the program'
         write(*,*)''
         cycle INFINITE
!-----------------------------------------------------------------------------------------------------------------------------------
      case default
         call string_to_real(reply,valu,ierr)              ! try to convert to a number
      end select
!-----------------------------------------------------------------------------------------------------------------------------------
      ireply=int(valu)
!-----------------------------------------------------------------------------------------------------------------------------------
      if(ireply.eq.0)then
         exit INFINITE
      elseif((valu.lt.istart).or.(valu.gt.iend))then
         write(*,*)'illegal menu choice ',istart,'<=',valu,'<=',iend
!-----------------------------------------------------------------------------------------------------------------------------------
      else
         ifound=ireply                                     ! index into dictionary for requested keyword and value
         if(dict_verbs(ifound).eq.verb(:ii)//'_?')then     ! replaced this with FINISHED so exit
            exit INFINITE
         endif
         call bounce('?'//dict_verbs(ifound),index,dict_verbs,ierr,mssge) ! if ?VERB is defined assume it is a prompt
         if(index.gt.0)then
            prompt=values(index)
         else
            prompt=' '
         endif
         if(prompt.eq.'')then
            write(*,'("Enter value for ",a,":")',advance='no') trim(dict_verbs(ifound)(ii+2:))
         elseif(prompt.eq.'#N#')then                       ! special prompt value
         else
            write(*,'(a,":")',advance='no') trim(prompt)
         endif
!-----------------------------------------------------------------------------------------------------------------------------------
         read(*,'(a)',iostat=ios)reply
         call store(dict_verbs(ifound),reply,"no_add",ierr)
!-----------------------------------------------------------------------------------------------------------------------------------
      endif
   enddo INFINITE
!-----------------------------------------------------------------------------------------------------------------------------------
end subroutine menu
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
end module M_kracken
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
module M_utilities
use iso_fortran_env, only : ERROR_UNIT        ! access computing environment
implicit none
interface v2s
   module procedure d2s, r2s, i2s
end interface
contains
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
!! 
!! NAME
!!    stderr - [M_debug]write message to stderr
!! 
!! SYNOPSIS
!!    subroutine stderr(message)
!! 
!!     character(len=*) :: message
!! 
!! DESCRIPTION
!!    STDERR(3f) writes a message to standard error using a standard f2003 method.
!! 
!! EXAMPLES
!!   Sample program:
!! 
!!    program demo_stderr
!!    use M_utilities, only: stderr
!!    implicit none
!!    call stderr('error: program will now stop')
!!    stop 1
!!    end program demo_stderr
subroutine stderr(message)
character(len=*),parameter :: ident="@(#)M_debug::stderr(3f): writes a message to standard error using a standard f2003 method"
character(len=*) :: message
   write(error_unit,'(a)')trim(message)    ! write message to standard error
end subroutine stderr
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
!! NAME
!!      s2v - [M_utilities]function returns doubleprecision numeric value from a string
!! 
!! SYNOPSIS
!!    function s2v(string,[ierr])
!! 
!!     character(len=*)             :: string
!!     doubleprecision              :: s2v
!!     integer,intent(out),optional :: ierr
!! 
!! DESCRIPTION
!!       This function converts a string to a DOUBLEPRECISION numeric value.
!!       A value of zero (0) is returned on error.
!! 
!!       If an error occurs the program is stopped if the optional parameter
!!       IERR is not present. If IERR is non-zero an error occurred.
!! 
!! EXAMPLE
!! 
!!    program demo_s2v
!! 
!!     use M_utilities, only: s2v
!!     implicit none
!!     character(len=8)              :: s=' 10.345 '
!!     integer                       :: i
!!     character(len=14),allocatable :: strings(:)
!!     doubleprecision               :: dv
!!     integer                       :: errnum
!! 
!!     ! different strings representing INTEGER, REAL, and DOUBLEPRECISION
!!     strings=[&
!!     &' 10.345       ',&
!!     &'+10           ',&
!!     &'    -3        ',&
!!     &'    -4.94e-2  ',&
!!     &'0.1           ',&
!!     &'12345.678910d0',&
!!     &'              ',& ! Note: will return zero without an error message
!!     &'1 2 1 2 1 . 0 ',& ! Note: spaces will be ignored
!!     &'WHAT?         ']  ! Note: error messages will appear, zero returned
!! 
!!     ! a numeric value is returned, so it can be used in numeric expression
!!     write(*,*) '1/2 value of string is ',s2v(s)/2.0d0
!!     write(*,*)
!!     write(*,*)' STRING            VALUE                    ERROR_NUMBER'
!!     do i=1,size(strings)
!!        ! Note: not a good idea to use s2v(3f) in a WRITE(3f) statement,
!!        ! as it does I/O when errors occur, so called on a separate line
!!        dv=s2v(strings(i),errnum)
!!        write(*,*) strings(i)//'=',dv,errnum
!!     enddo
!!     write(*,*)"That's all folks!"
!! 
!!     end program demo_s2v
!! 
!!    Expected output
!! 
!!     >1/2 value of string is    5.1725000000000003
!!     >
!!     > STRING            VALUE                    ERROR_NUMBER
!!     > 10.345       =   10.345000000000001                0
!!     >+10           =   10.000000000000000                0
!!     >    -3        =  -3.0000000000000000                0
!!     >    -4.94e-2  =  -4.9399999999999999E-002           0
!!     >0.1           =  0.10000000000000001                0
!!     >12345.678910d0=   12345.678910000001                0
!!     >              =   0.0000000000000000                0
!!     >1 2 1 2 1 . 0 =   12121.000000000000                0
!!     >*a2d* - cannot produce number from string [WHAT?]
!!     >*a2d* - [Bad value during floating point read]
!!     >WHAT?         =   0.0000000000000000             5010
!!     >That's all folks!
!! PROCEDURE:
!! DESCRIPTION: s2v(3f): function returns doubleprecision number from string;zero if error occurs"
!! VERSION:     2.0, 20160704
!! AUTHOR:      John S. Urban
doubleprecision function s2v(chars,ierr)
!  1989 John S. Urban
character(len=*),parameter::ident="@(#)M_utilities::s2v(3f): returns doubleprecision number from string"

character(len=*),intent(in) :: chars
integer,optional            :: ierr
doubleprecision             :: valu
   integer                  :: ierr_local

   ierr_local=0
   call a2d(chars,valu,ierr_local)
   s2v=valu
   if(present(ierr))then ! if error is not returned stop program on error
      ierr=ierr_local
   elseif(ierr_local.ne.0)then
      write(*,*)'*s2v* stopped while reading '//trim(chars)
      stop 1
   endif
end function s2v
!----------------------------------------------------------------------------------------------------------------------------------
subroutine a2d(chars,valu,ierr)
character(len=*),parameter::ident="@(#)M_utilities::a2d(3fp): subroutine returns double value from string"
!     1989,2016 John S. Urban.
!
!  o  works with any g-format input, including integer, real, and exponential.
!  o  if an error occurs in the read, iostat is returned in ierr and value is set to zero.  if no error occurs, ierr=0.
!  o  if the string happens to be 'eod' no error message is produced so this string may be used to act as an end-of-data.
!     IERR will still be non-zero in this case.
!----------------------------------------------------------------------------------------------------------------------------------
   character(len=*),intent(in)  :: chars                        ! input string
   character(len=:),allocatable :: local_chars
   doubleprecision,intent(out)  :: valu                         ! value read from input string
   integer,intent(out)          :: ierr                         ! error flag (0 == no error)
!----------------------------------------------------------------------------------------------------------------------------------
   character(len=*),parameter   :: fmt="('(bn,g',i5,'.0)')"     ! format used to build frmt
   character(len=15)            :: frmt                         ! holds format built to read input string
   character(len=256)           :: msg                          ! hold message from I/O errors
   integer                      :: intg
!----------------------------------------------------------------------------------------------------------------------------------
   ierr=0                                                       ! initialize error flag to zero
   local_chars=chars
   if(len(local_chars).eq.0)local_chars=' '
   call substitute(local_chars,',','')                          ! remove any comma characters
   select case(local_chars(1:1))
   case('z','Z','h','H')                                        ! assume hexadecimal
      frmt='(Z'//v2s(len(local_chars))//')'
      read(local_chars(2:),frmt,iostat=ierr,iomsg=msg)intg
      valu=dble(intg)
   case('b','B')                                                ! assume binary (base 2)
      frmt='(B'//v2s(len(local_chars))//')'
      read(local_chars(2:),frmt,iostat=ierr,iomsg=msg)intg
      valu=dble(intg)
   case('O','o')                                                ! assume octal
      frmt='(O'//v2s(len(local_chars))//')'
      read(local_chars(2:),frmt,iostat=ierr,iomsg=msg)intg
      valu=dble(intg)
   case default
      write(frmt,fmt)len(local_chars)                           ! build format of form '(BN,Gn.0)'
      read(local_chars,fmt=frmt,iostat=ierr,iomsg=msg)valu      ! try to read value from string
   end select
   if(ierr.ne.0)then                                            ! if an error occurred ierr will be non-zero.
      valu=0.0                                                  ! set returned value to zero on error
         if(local_chars.ne.'eod')then                                 ! print warning message
            call stderr('*a2d* - cannot produce number from string ['//trim(chars)//']')
            call stderr('*a2d* - ['//trim(msg)//']')
         endif
      endif
end subroutine a2d
!===================================================================================================================================
function d2s(dvalue) result(outstr)
character(len=*),parameter::ident="@(#)M_utilities::d2s(3fp): private function returns string given doubleprecision value"
doubleprecision,intent(in)   :: dvalue                         ! input value to convert to a string
character(len=:),allocatable :: outstr                         ! output string to generate
character(len=80)            :: string
   call value_to_string(dvalue,string)
   outstr=trim(string)
end function d2s
!===================================================================================================================================
function r2s(rvalue) result(outstr)
character(len=*),parameter::ident="@(#)M_utilities::r2s(3fp): private function returns string given real value"
real,intent(in )             :: rvalue                         ! input value to convert to a string
character(len=:),allocatable :: outstr                         ! output string to generate
character(len=80)            :: string
   call value_to_string(rvalue,string)
   outstr=trim(string)
end function r2s
!===================================================================================================================================
function i2s(ivalue) result(outstr)
character(len=*),parameter::ident="@(#)M_utilities::i2s(3fp): private function returns string given integer value"
integer,intent(in )          :: ivalue                         ! input value to convert to a string
character(len=:),allocatable :: outstr                         ! output string to generate
character(len=80)            :: string
   call value_to_string(ivalue,string)
   outstr=trim(string)
end function i2s
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
!! NAME
!!    substitute - [M_strings]Globally substitute one substring for another in string
!! 
!! SYNOPSIS
!!    subroutine substitute(targetline,old,new,ierr,start,end)
!! 
!!     character(len=*)              :: targetline
!!     character(len=*),intent(in)   :: old
!!     character(len=*),intent(in)   :: new
!!     integer,intent(out),optional  :: ierr
!!     integer,intent(in),optional   :: start
!!     integer,intent(in),optional   :: end
!! 
!! DESCRIPTION
!!    Globally substitute one substring for another in string.
!! 
!! OPTIONS
!!     targetline  input line to be changed
!!     old         old substring to replace
!!     new         new substring
!!     ierr        error code. iF ier = -1 bad directive, &gt;= 0 then
!!                 count of changes made
!!     start       start sets the left  margin
!!     end         end sets the right  margin
!! 
!! EXAMPLES
!!   Sample Program:
!! 
!!    program test_substitute
!!    use M_strings, only : substitute
!!    implicit none
!!    ! must be long enough to hold changed line
!!    character(len=80) :: targetline
!! 
!!    targetline='this is the input string'
!!    write(*,*)'ORIGINAL    : '//trim(targetline)
!! 
!!    ! changes the input to 'THis is THe input string'
!!    call substitute(targetline,'th','TH')
!!    write(*,*)'th => TH    : '//trim(targetline)
!! 
!!    ! a null old substring means "at beginning of line"
!!    ! changes the input to 'BEFORE:this is the input string'
!!    call substitute(targetline,'','BEFORE:')
!!    write(*,*)'"" => BEFORE: '//trim(targetline)
!! 
!!    ! a null new string deletes occurrences of the old substring
!!    ! changes the input to 'ths s the nput strng'
!!    call substitute(targetline,'i','')
!!    write(*,*)'i => ""     : '//trim(targetline)
!! 
!!    end program test_substitute
!! 
!!   Expected output
!! 
!!     ORIGINAL    : this is the input string
!!     th => TH    : THis is THe input string
!!     "" => BEFORE: BEFORE:THis is THe input string
!!     i => ""     : BEFORE:THs s THe nput strng
subroutine substitute(targetline,old,new,ierr,start,end)
character(len=*),parameter::ident="@(#)M_strings::substitute(3f): Globally substitute one substring for another in string"
!-----------------------------------------------------------------------------------------------------------------------------------
   character(len=*)              :: targetline         ! input line to be changed
   character(len=*),intent(in)   :: old                ! old substring to replace
   character(len=*),intent(in)   :: new                ! new substring
   character(len=len(targetline)):: dum1               ! scratch string buffers
   integer,intent(out),optional  :: ierr               ! error code. if ierr = -1 bad directive, >=0 then ierr changes made
   integer,intent(in),optional   :: start              ! start sets the left  margin
   integer,intent(in),optional   :: end                ! end sets the right  margin
!-----------------------------------------------------------------------------------------------------------------------------------
   integer                       :: ml, mr, ier1
   integer                       :: maxlengthout       ! MAXIMUM LENGTH ALLOWED FOR NEW STRING
   integer                       :: original_input_length
   integer                       :: len_old, len_new
   integer                       :: ladd
   integer                       :: ir
   integer                       :: ind
   integer                       :: il
   integer                       :: id
   integer                       :: ic
   integer                       :: ichar
!-----------------------------------------------------------------------------------------------------------------------------------
   if (present(start)) then                            ! optional starting column
      ml=start
   else
      ml=1
   endif
   if (present(end)) then                              ! optional ending column
      mr=end
   else
      mr=len(targetline)
   endif
!-----------------------------------------------------------------------------------------------------------------------------------
   ier1=0                                              ! initialize error flag/change count
   maxlengthout=len(targetline)                        ! max length of output string
   original_input_length=len_trim(targetline)          ! get non-blank length of input line
   dum1(:)=' '                                         ! initialize string to build output in
   id=mr-ml                                            ! check for window option !! change to optional parameter(s)
!-----------------------------------------------------------------------------------------------------------------------------------
   len_old=len(old)                                    ! length of old substring to be replaced
   len_new=len(new)                                    ! length of new substring to replace old substring
   if(id.le.0)then                                     ! no window so change entire input string
      il=1                                             ! il is left margin of window to change
      ir=maxlengthout                                  ! ir is right margin  of window to change
      dum1(:)=' '                                      ! begin with a blank line
   else                                                ! if window is set
      il=ml                                            ! use left margin
      ir=min0(mr,maxlengthout)                         ! use right margin or rightmost
      dum1=targetline(:il-1)                           ! begin with what's below margin
   endif                                               ! end of window settings
!-----------------------------------------------------------------------------------------------------------------------------------
   if(len_old.eq.0)then                                ! c//new/ means insert new at beginning of line (or left margin)
      ichar=len_new + original_input_length
      if(ichar.gt.maxlengthout)then
         call stderr('*substitute* new line will be too long')
         ier1=-1
         if (present(ierr))ierr=ier1
         return
      endif
      if(len_new.gt.0)then
         dum1(il:)=new(:len_new)//targetline(il:original_input_length)
      else
         dum1(il:)=targetline(il:original_input_length)
      endif
      targetline(1:maxlengthout)=dum1(:maxlengthout)
      ier1=1                                           ! made one change. actually, c/// should maybe return 0
      if(present(ierr))ierr=ier1
      return
   endif
!-----------------------------------------------------------------------------------------------------------------------------------
   ichar=il                                            ! place to put characters into output string
   ic=il                                               ! place looking at in input string
   loop: do
      ind=index(targetline(ic:),old(:len_old))+ic-1    ! try to find start of old string in remaining part of input in change window
      if(ind.eq.ic-1.or.ind.gt.ir)then                 ! did not find old string or found old string past edit window
         exit loop                                     ! no more changes left to make
      endif
      ier1=ier1+1                                      ! found an old string to change, so increment count of changes
      if(ind.gt.ic)then                                ! if found old string past at current position in input string copy unchanged
         ladd=ind-ic                                   ! find length of character range to copy as-is from input to output
         if(ichar-1+ladd.gt.maxlengthout)then
            ier1=-1
            exit loop
         endif
         dum1(ichar:)=targetline(ic:ind-1)
         ichar=ichar+ladd
      endif
      if(ichar-1+len_new.gt.maxlengthout)then
         ier1=-2
         exit loop
      endif
      if(len_new.ne.0)then
         dum1(ichar:)=new(:len_new)
         ichar=ichar+len_new
      endif
      ic=ind+len_old
   enddo loop
!-----------------------------------------------------------------------------------------------------------------------------------
   select case (ier1)
   case (:-1)
      call stderr('*substitute* new line will be too long')
   case (0)                                                ! there were no changes made to the window
   case default
      ladd=original_input_length-ic
      if(ichar+ladd.gt.maxlengthout)then
         call stderr('*substitute* new line will be too long')
         ier1=-1
         if(present(ierr))ierr=ier1
         return
      endif
      if(ic.lt.len(targetline))then
         dum1(ichar:)=targetline(ic:max(ic,original_input_length))
      endif
      targetline=dum1(:maxlengthout)
   end select
   if(present(ierr))ierr=ier1
!-----------------------------------------------------------------------------------------------------------------------------------
end subroutine substitute
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
!! NAME
!!      value_to_string - [M_strings]return numeric string from a numeric value
!! 
!! SYNOPSIS
!! 
!!    subroutine value_to_string(value,chars[,ilen,ierr,fmt])
!! 
!!     character(len=*) :: chars  ! minimum of 23 characters required
!!     !--------
!!     ! VALUE may be any <em>one</em> of the following types:
!!     doubleprecision,intent(in)               :: value
!!     real,intent(in)                          :: value
!!     integer,intent(in)                       :: value
!!     !--------
!!     character(len=*),intent(out)             :: chars
!!     integer,intent(out),optional             :: ilen
!!     integer,optional                         :: ierr
!!     character(len=*),intent(in),optional     :: fmt
!! 
!! DESCRIPTION
!! 
!!    value_to_string(3f)
!!    that returns a numeric representation in a string given a numeric value of type
!!    REAL, DOUBLEPRECISION, or INTEGER. It creates the strings using internal writes.
!!    It then removes trailing zeros from non-zero values, and left-justifies the string.
!! 
!! OPTIONS
!!       o  VALUE - input value to be converted to a string
!! RETURNS
!!       o  CHARS - returned string representing input value, must be at least 23 characters long;
!!                  or what is required by optional FMT if longer.
!!       o  ILEN - position of last non-blank character in returned string; optional.
!!       o  IERR - If not zero, error occurred.; optional.
!!       o  FMT - You may specify a specific format that produces a string up to the length of CHARS; optional.
!! 
!! EXAMPLE
!! 
!!    Sample program
!! 
!!      program demo_value_to_string
!!      use m_strings, only: value_to_string
!!      implicit none
!!      character(len=80) :: string
!!      integer           :: ilen
!!         call value_to_string(3.0/4.0,string,ilen)
!!         write(*,*) 'The value is [',string(:ilen),']'
!! 
!!         call value_to_string(3.0/4.0,string,ilen,fmt='')
!!         write(*,*) 'The value is [',string(:ilen),']'
!! 
!!         call value_to_string(3.0/4.0,string,ilen,fmt='("THE VALUE IS ",g0)')
!!         write(*,*) 'The value is [',string(:ilen),']'
!! 
!!         call value_to_string(1234,string,ilen)
!!         write(*,*) 'The value is [',string(:ilen),']'
!! 
!!         call value_to_string(1.0d0/3.0d0,string,ilen)
!!         write(*,*) 'The value is [',string(:ilen),']'
!! 
!!      end program demo_value_to_string
!! 
!!    Expected output
!! 
!!     The value is [0.75]
!!     The value is [      0.7500000000]
!!     The value is [THE VALUE IS .750000000]
!!     The value is [1234]
!!     The value is [0.33333333333333331]
!! 
subroutine value_to_string(gval,chars,length,err,fmt)
character(len=*),parameter::ident="@(#)M_strings::value_to_string(3fp): subroutine returns a string from a value"
class(*),intent(in)                      :: gval
character(len=*),intent(out)             :: chars
integer,intent(out),optional             :: length
integer,optional                         :: err
integer                                  :: err_local
character(len=*),optional,intent(in)     :: fmt         ! format to write value with
character(len=:),allocatable             :: fmt_local

!  Notice that the value GVAL can be any of several types ( INTEGER,REAL,DOUBLEPRECISION)

   if (present(fmt)) then
      select type(gval)
      type is (integer)
         fmt_local='(i0)'
         if(fmt.ne.'') fmt_local=fmt
         write(chars,fmt_local,iostat=err_local)gval
      type is (real)
         fmt_local='(bz,g23.10e3)'
         if(fmt.ne.'') fmt_local=fmt
         write(chars,fmt_local,iostat=err_local)gval
      type is (doubleprecision)
         fmt_local='(bz,g0)'
         if(fmt.ne.'') fmt_local=fmt
         write(chars,fmt_local,iostat=err_local)gval
      end select
      if(fmt.eq.'') then
         chars=adjustl(chars)
         call trimzeros(chars)
      endif
   else                                                  ! no explicit format option present
      select type(gval)
      type is (integer)
         write(chars,*,iostat=err_local)gval
      type is (real)
         write(chars,*,iostat=err_local)gval
      type is (doubleprecision)
         write(chars,*,iostat=err_local)gval
      end select
      chars=adjustl(chars)
      if(index(chars,'.').ne.0) call trimzeros(chars)
   endif

   if(present(length)) then ; length=len_trim(chars) ; endif

   if(present(err)) then ; err=err_local ; endif

end subroutine value_to_string
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
!! NAME
!!    trimzeros(3fp) - [M_strings]Delete trailing zeros from numeric decimal string
!! SYNOPSIS
!!    subroutine trimzeros(str)
!! 
!!     character(len=*)  :: str
!! DESCRIPTION
!!    TRIMZEROS(3f) deletes trailing zeros from a string representing a
!!    number. If the resulting string would end in a decimal point, one
!!    trailing zero is added.
!! EXAMPLES
!!    Sample program:
!! 
!!       program demo_trimzeros
!!       use M_strings, only : trimzeros
!!       character(len=:),allocatable :: string
!!       write(*,*)trimzeros('123.450000000000')
!!       write(*,*)trimzeros('12345')
!!       write(*,*)trimzeros('12345.')
!!       write(*,*)trimzeros('12345.00e3')
!!       end program demo_trimzeros
subroutine trimzeros(string)
character(len=*),parameter::ident="@(#)M_strings::trimzeros(3fp): Delete trailing zeros from numeric decimal string"
! if zero needs added at end assumes input string has room
character(len=*)             :: string
character(len=len(string)+2) :: str
character(len=len(string))   :: exp          ! the exponent string if present
integer                      :: ipos         ! where exponent letter appears if present
integer                      :: i, ii
   str=string                                ! working copy of string
   ipos=scan(str,'eEdD')                     ! find end of real number if string uses exponent notation
   if(ipos>0) then                           ! letter was found
      exp=str(ipos:)                         ! keep exponent string so it can be added back as a suffix
      str=str(1:ipos-1)                      ! just the real part, exponent removed will not have trailing zeros removed
   endif
   if(index(str,'.').eq.0)then               ! if no decimal character in original string add one to end of string
      ii=len_trim(str)
      str(ii+1:ii+1)='.'                     ! add decimal to end of string
   endif
   do i=len_trim(str),1,-1                   ! scanning from end find a non-zero character
      select case(str(i:i))
      case('0')                              ! found a trailing zero so keep trimming
         cycle
      case('.')                              ! found a decimal character at end of remaining string
         if(i.le.1)then
            str='0'
         else
            str=str(1:i-1)
         endif
         exit
      case default
         str=str(1:i)                        ! found a non-zero character so trim string and exit
         exit
      end select
   end do
   if(ipos>0)then                            ! if originally had an exponent place it back on
      string=trim(str)//trim(exp)
   else
      string=str
   endif
end subroutine trimzeros
end module M_utilities
!-----------------------------------------------------------------------------------------------------------------------------------
!>NAME
!!    asa2pdf(1f) - Convert text files with/without ASA carriage control
!!                  to an Adobe PDF file.
!!
!!SYNOPSIS
!!   asa2pdf -o output_filename -i input_filename
!!           -g gray_scale_shade -b lines_alternately_shaded -d dashcode
!!           -s top_middle_page_label -t top_left_page_label
!!           -P # add page numbers
!!           -l lines_per_page -f font_name -S columns_to_shift_data
!!           -N # add line numbers
!!           -H page_height -W page_width -u points_per_unit
!!           -L left_margin -R right_margin -B bottom_margin -T top_margin
!!           -help -version -show
!!
!!DESCRIPTION
!!
!!   Basically, asa2pdf(1) emulates a line printer that recognizes ASA
!!   carriage control. That is, it lets you convert ASCII text files using
!!   ASA carriage control into Adobe "clear text" PDF files instead of a
!!   printed page.
!!
!!   The PDF is clear-text ASCII so that it is easy to still use other
!!   Unix/Linux utilities such as spell(1), diff(1), grep(1), .... on the
!!   output files.
!!
!!   To properly view the output requires a PDF processor (such
!!   as xpdf(1),acroread(1)/AcroRd32, gv(1) or ghostview(1), ...).
!!   Most modern systems can view, mail and print PDF files.
!!
!!   The default layout generates a landscape 132-column 60-line format with
!!   every other two lines shaded. A variety of switches are available to
!!   let you easily print files with no vertical carriage control, and in
!!   portrait mode too. There are options to use dashed lines instead of
!!   shading, to set different margins, and so on.
!!
!!   WHAT IS ASA CARRIAGE CONTROL?
!!
!!   The ASA carriage control standard was the first important formatting
!!   standard for printing and viewing text files. The standard was almost
!!   universally adapted by printer manufacturers of the time (and printers
!!   were a much more common output device than interactive displays).
!!
!!   Most commercial high-level programs at the time the standard was
!!   created were either FORTRAN or COBOL; so nearly all early FORTRAN
!!   output used ASA carriage control
!!   (ASA was the American Standards Association -- now ANSI).
!!   This FORTRAN/ASA association became so strong that the standard is
!!   sometimes referred to as the "Fortran carriage control standard" (FCC).
!!   Indeed, even though ASA is no longer commonly directly supported on
!!   desktop printers, it was part of the Fortran 90 standard (this was
!!   dropped in Fortran 2003 -- how a printer processes files is really
!!   not directly part of any programming language).
!!
!!   Times have changed, and the once nearly ubiquitous ASA standard
!!   is poorly supported on Unix and MSWindows machines in particular
!!   (Direct operating-system support of ASA files was once common, but
!!   is now rare).
!!
!!   But no alternative as simple has emerged for output files
!!   that truly replaces the ASA standard (although machine control
!!   characters (ctrl-H, ctrl-L, ...) have come close they have their
!!   own issues).
!!
!!   So many programs using ASA-based formatting have not been changed,
!!   and use commands like asa(1)/nasa(1), and fpr(1) to allow the files to
!!   be printed as desired but NOT to generally be viewed properly on-line,
!!   and printing itself is becoming less common.
!!
!!   So the problem isn't so much with ASA files, but that today's
!!   infrastructure does not support the format well. The asa2pdf(1)
!!   program bridges the gap by allowing you to still make and manipulate
!!   ASA files until you want to print or email them, at which time you
!!   can quickly convert them to an Adobe PDF file.
!!
!!USAGE
!!
!!   asa2pdf(1) reads input from standard input. By default the first
!!   character of each line is interpreted as a control character. Lines
!!   beginning with any character other than those listed in the ASA
!!   carriage-control characters table or in the list of extensions below
!!   are interpreted as if they began with a blank, and an appropriate
!!   diagnostic appears on standard error. The first character of each
!!   line is not printed.
!!
!!   ASA Carriage Control Characters
!!
!!        +------------+-----------------------------------------------+
!!        | Character  |                                               |
!!        +------------+-----------------------------------------------+
!!        | +          | Do not advance; overstrike previous line.     |
!!        | blank      | Advance one line.                             |
!!        | null lines | Treated as if they started with a blank       |
!!        | 0          | Advance two lines.                            |
!!        | -          | Advance three lines (IBM extension).          |
!!        | 1          | Advance to top of next page.                  |
!!        | all others | Discarded (except for extensions listed below)|
!!        +------------+-----------------------------------------------+
!!   Extensions
!!
!!       H   Advance one-half line.
!!       R   Do not advance; overstrike previous line. Use red text color
!!       G   Do not advance; overstrike previous line. Use green text color
!!       B   Do not advance; overstrike previous line. Use blue text color
!!       r   Advance one line. Use red text color
!!       g   Advance one line. Use green text color
!!       b   Advance one line. Use blue text color
!!       ^   Overprint but add 127 to the ADE value of the character
!!           (ie., use ASCII extended character set)
!!
!!OPTIONS
!!       -o outputfile  Name of Adobe PDF output file to create
!!       -i inputfile   Name of text file to read. Defaults to stdin.
!!
!!    PRINTABLE PAGE AREA
!!
!!      The page size may be specified using -H for height, -W for width, and -u
!!      to indicate the points per unit (72 makes H and W in inches,
!!      1 is used when units are in font points). For example:
!!
!!       -u 72 -H 8.5 -W 11   # page Height and Width in inches
!!       -T 0.5 -B 0.5 -L 0.5 -R 0.5   # margins (Top, Bottom, Left, Right)
!!
!!      common media sizes with -u 1:
!!
!!       +-------------------+------+------------+
!!       | name              |  W   |        H   |
!!       +-------------------+------+------------+
!!       | Letterdj (11x8.5) | 792  |       612  | (LandScape)
!!       | A4dj              | 842  |       595  |
!!       | Letter (8.5x11)   | 612  |       792  | (Portrait)
!!       | Legal             | 612  |       1008 |
!!       | A5                | 420  |       595  |
!!       | A4                | 595  |       842  |
!!       | A3                | 842  |       1190 |
!!       +-------------------+------+------------+
!!
!!    SHADING
!!        -g 0.800781      gray-scale value for shaded bars ( 0 < g 1 )
!!                         0 is black, 1 is white.
!!        -i 2             repeat shade pattern every N lines
!!        -d ' '           dashcode pattern
!!                         The pattern is a series of integers defining an
!!                         on-off sequence in user units used to create a
!!                         dash pattern. A single digit "N" implies a pattern
!!                         of "N N". (seems buggy)
!!
!!    MARGIN LABELS
!!       -s ''             top middle page label.
!!       -t ''             top left page label.
!!       -P                add page numbers to right corners
!!
!!    TEXT OPTIONS
!!       -l 60             lines per page
!!       -f Courier        font names: Courier, Courier-Bold,Courier-Oblique
!!                         Helvetica, Symbol, Times-Bold, Helvetica-Bold,
!!                         ZapfDingbats, Times-Italic, Helvetica-Oblique,
!!                         Times-BoldItalic, Helvetica-BoldOblique,
!!                         Times-Roman, Courier-BoldOblique
!!
!!       -S 0              right shift 1 for non-ASA files
!!       -N                add line numbers
!!    INFORMATION
!!       -version          display version number
!!       -help             display this help
!!
!!ENVIRONMENT VARIABLES
!!     o $IMPACT_TOP Will be printed in large red letters across the page top.
!!     o $IMPACT_GRAY sets the default gray-scale value, same as the -g switch.
!!
!!EXAMPLES
!! Sample input:
!!
!!  > The numbers are plain underlined double-struck over-struck
!!  >+                      __________ double-struck ///////////
!!  >R                                               ///////////
!!  > abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789-=_+()*&^%$#@!\|[]{};':",.<>/?`~
!!  >
!!  >r red
!!  >g     green
!!  >b           blue
!!  > PRIMARY:
!!  >R         red
!!  >G             green
!!  >B                   blue
!!  > 1/2 line advance
!!  >H                1
!!  >H                 2         a-1
!!  >H                  3       Z
!!  >H                   4       b
!!  > back to a normal line
!!
!! Sample commands:
!!
!!     # create non-ASA file in portrait mode with a dashed line under every line
!!     asa2pdf -S 1 -W 8.5 -H 11 -i 1 -d '2 4 1' -T 1 -B .75 -o paper.pdf < INFILE
!!
!!     # banner on top
!!     env IMPACT_GRAY=1 IMPACT_TOP=CONFIDENTIAL asa2pdf -o paper.pdf < test.txt
!!
!!     # 132 landscape
!!      asa2pdf -s LANDSCAPE -o paper.pdf <asa2pdf.c
!!
!!     # 132 landscape with line numbers with dashed lines
!!      asa2pdf -s 'LANDSCAPE LINE NUMBERS' -d '3 1 2' \
!!      -N -T .9 -o paper.pdf <asa2pdf.c
!!
!!     # portrait 80 non-ASA file with dashed lines
!!      asa2pdf -s PORTRAIT -S 1 -W 8.5 -H 11 -i 1 -d '2 4 1' \
!!      -T 1 -B .75 -o paper.pdf < asa2pdf.c
!!
!!     # portrait 80 with line numbers , non-ASA
!!      asa2pdf -s 'PORTRAIT LINE NUMBERS' -l 66 -S 1 -W 8.5 -H 11 \
!!      -i 1 -T 1 -B .75 -N -o paper.pdf < asa2pdf.c
!!
!!     # titling
!!      asa2pdf -d '1 0 1' -t "$USER" -i 1 -P -N -T 1 \
!!      -s "asa2pdf.c" -o paper.pdf <asa2pdf.c
!!
!!SEE ALSO
!!
!!   ALTERNATIVES TO ASA2PDF
!!
!!   About the only standard ASA support on Unix variants is that some
!!   contain the asa(1)/fpr(1) and nasa(1) commands for converting ASA text
!!   files into and from text files with machine control (MC) characters
!!   such as form-feed, backspace, carriage-return, .... Most personal
!!   printers will no longer properly print ASA files directly, but they
!!   will often correctly print files with simple MC characters
!!   (Note that the asa(1) command is referenced in the POSIX.2 standard).
!!
!!   Furthermore, if a printer does not directly support MC characters,
!!   text conversion utilities such as enscript(1) and a2ps(1) can
!!   often be used to print the files (usually by converting the files
!!   to PostScript or PCL). Such utilities support features such as
!!   titling, page numbering, and other useful options.
!!
!!   Programs like "Adobe Distiller" can convert text to a PDF; as well as
!!   editors such as OpenOffice. In fact, most modern document-formatting
!!   editors can read in an ASCII text file and save it as an Adobe
!!   PDF file.
!!
!!   HTML and PostScript/PDF and PCL files are the alternatives often
!!   incorporated to satisfy simple formatting criteria --
!!   yet HTML is not printer-oriented;
!!   and PDF files are complex to write from a simple program, and PCL is
!!   vendor-specific and has few on-line viewers available for it.
!!
!!
!!   Assuming converting the Fortran program to just write a plain ASCII
!!   file instead of an ASA file is not acceptable, More extensive flat-text
!!   formatting is available using
!!
!!   o HTML, *roff and LaTex-related file formats
!!   o libraries for writing more sophisticated PostScript, PDF, and HTML/CSS files
!!   o XML files formatted using Cascading Style Sheet (CSS) files
!!   o RTF (Rich Text Format) files
!!
!!   Other Unix commands that can be useful in working with plain text and
!!   MC character files are
!!
!!      pr(1)           can be used to add page numbers and titles.
!!      expand(1)       can remove tab characters
!!      fold(1),fmt(1)  can be used to wrap the text
!!      cut(1)          can let you trim or select columns
!!      cat -n          can be used to add number lines
!!      paste(1)        can be used to put files side-by-side.
!!
!!asa(1)/nasa(1), fpr(1), enscript(1), a2ps(1), and ps2pdf(1).
!!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()=
!===================================================================================================================================
program asa2pdf
use M_utilities, only   : stderr
use M_kracken, only : kracken, sget, rget, iget, lget
use M_utilities, only : s2v, v2s
implicit none

! size of printable area
! Default unit is 72 points per inch

 character(len=256),save      :: GLOBAL_CENTER_TITLE       = ' '
 character(len=256),save      :: GLOBAL_DASHCODE           = ' '
 character(len=256),save      :: GLOBAL_FONT               = 'Courier'
 character(len=256),save      :: GLOBAL_LEFT_TITLE         = ' '
 character(len=:),allocatable :: GLOBAL_PAGE_LIST
 logical                      :: GLOBAL_LINENUMBERS        = .false.
 logical                      :: GLOBAL_PAGES              = .false.
 integer                      :: GLOBAL_ADD                = 0
 integer                      :: GLOBAL_LINECOUNT          = 0
 integer                      :: GLOBAL_NUM_PAGES          = 0
 integer                      :: GLOBAL_OBJECT_ID          = 1
 integer                      :: GLOBAL_PAGECOUNT          = 0
 integer                      :: GLOBAL_PAGE_TREE_ID
 integer                      :: GLOBAL_SHADE_STEP         = 2
 integer                      :: GLOBAL_SHIFT              = 0
 integer                      :: GLOBAL_STREAM_ID, GLOBAL_STREAM_LEN_ID
 integer                      :: GLOBAL_STREAM_START
 integer,parameter            :: GLOBAL_DIRECT             = 12
 integer,parameter            :: GLOBAL_OUTFILE            = 11
 integer                      :: GLOBAL_INFILE             = 10
 real                         :: GLOBAL_FONT_SIZE
 real                         :: GLOBAL_GRAY_SCALE         =   0.800781 ! gray-scale value
 real                         :: GLOBAL_LEAD_SIZE
 real                         :: GLOBAL_LINES_PER_PAGE     =  60.0
 real                         :: GLOBAL_PAGE_DEPTH         = 612.0
 real                         :: GLOBAL_PAGE_MARGIN_BOTTOM =  36.0
 real                         :: GLOBAL_PAGE_MARGIN_LEFT   =  40.0
 real                         :: GLOBAL_PAGE_MARGIN_RIGHT  =  39.0
 real                         :: GLOBAL_PAGE_MARGIN_TOP    =  36.0
 real                         :: GLOBAL_PAGE_WIDTH         = 792.0 ! Default is 72 points per inch
 real                         :: GLOBAL_TITLE_SIZE         =  20.0
 real                         :: GLOBAL_UNIT_MULTIPLIER    =   1.0
 real                         :: GLOBAL_YPOS

   character(len=100):: varname
   integer :: ios

   GLOBAL_PAGE_LIST=''

   call get_environment_variable("IMPACT_GRAY",varname)
   if(varname.eq.'') varname='0.800781' ! gray-scale value
   GLOBAL_GRAY_SCALE=s2v(varname)
   if(GLOBAL_GRAY_SCALE.lt.0) GLOBAL_GRAY_SCALE=0.800781

   call kracken('asa2pdf',' &
   & -o asa.pdf &
   ! SHADING
   ! gray-scale value  for shaded bars ( 0 < g < 1 ); 0 is black, 1 is white
   & -g 0.800781 &
   ! repeat shade pattern every N lines
   & -i 2 &
   ! dashcode pattern (seems buggy)
   & -d &
   ! MARGIN LABELS
   ! top middle page label.
   & -s &
   ! top left page label.
   & -t &
   ! add page numbers to right corners
   & -P       .F. &
   ! TEXT OPTIONS
   ! lines per page
   & -l 60 &
   ! font names
   & -f Courier &
   ! right shift N characters for non-ASA files
   & -S 0 &
   ! add line numbers
   & -N       .F. &
   ! PRINTABLE PAGE AREA
   !   The page size may be specified using -H for height, -W for width, and -u
   !   to indicate the points per unit (72 makes H and W in inches,
   !   1 is used when units are in font points). For example:
   ! page height
   & -H 612.0  &
   ! page width
   & -W 792.0 &
   ! units per inch
   & -u 1    &
   ! MARGINS
   ! left margin
   & -L 40.0 &
   ! right margin
   & -R 39.0 &
   ! bottom margin
   & -B 36.0 &
   ! top margin
   & -T 36.0 &

   & -show    .F. &
   & -help    .F. &
   & -version .F. &
   &')

   call help_usage(lget('asa2pdf_help'))              ! display help information and stop if true
   call help_version(lget('asa2pdf_version'))         ! display version information and stop if true

   OPEN(UNIT=GLOBAL_OUTFILE, FILE=trim(sget('asa2pdf_o')), ACCESS="STREAM", iostat=ios,form='formatted')
   if(ios.ne.0)then
      call stderr("E-R-R-O-R: asa2pdf(1) cannot open output file "//trim(sget('asa2pdf_o')))
      stop 2
   endif

   if(sget('asa2pdf_i').ne.'')then
      OPEN(UNIT=GLOBAL_INFILE, FILE=trim(sget('asa2pdf_i')), iostat=ios,form='formatted')
      if(ios.ne.0)then
         call stderr("E-R-R-O-R: asa2pdf(1) cannot open input file "//trim(sget('asa2pdf_i')))
         stop 2
      endif
   else
      GLOBAL_INFILE=5
   endif

   GLOBAL_UNIT_MULTIPLIER =     rget('asa2pdf_u')                          ! unit_divisor
   GLOBAL_PAGE_MARGIN_LEFT =    rget('asa2pdf_L')*GLOBAL_UNIT_MULTIPLIER;  ! Left margin
   GLOBAL_PAGE_MARGIN_RIGHT =   rget('asa2pdf_R')*GLOBAL_UNIT_MULTIPLIER;  ! Right margin
   GLOBAL_PAGE_MARGIN_BOTTOM =  rget('asa2pdf_B')*GLOBAL_UNIT_MULTIPLIER;  ! Bottom margin
   GLOBAL_PAGE_MARGIN_TOP =     rget('asa2pdf_T')*GLOBAL_UNIT_MULTIPLIER;  ! Top margin
   GLOBAL_PAGE_DEPTH =          rget('asa2pdf_H')*GLOBAL_UNIT_MULTIPLIER;  ! Height
   GLOBAL_PAGE_WIDTH =          rget('asa2pdf_W')*GLOBAL_UNIT_MULTIPLIER;  ! Width

   GLOBAL_GRAY_SCALE =          rget('asa2pdf_g')                          ! grayscale value for bars
   GLOBAL_LINES_PER_PAGE=       rget('asa2pdf_l')                          ! lines per page
   GLOBAL_SHADE_STEP =          iget('asa2pdf_b')                          ! increment for bars
   GLOBAL_SHIFT =               MAX(0,iget('asa2pdf_S'))                   ! right shift

   GLOBAL_CENTER_TITLE=sget('asa2pdf_s')                                   ! special label
   GLOBAL_LEFT_TITLE=sget('asa2pdf_t')                                     ! margin left label

   GLOBAL_DASHCODE=sget('asa2pdf_d')                                       ! dash code
   GLOBAL_FONT=sget('asa2pdf_f')                                           ! font

   GLOBAL_LINENUMBERS=lget('asa2pdf_N')                                    ! number lines
   GLOBAL_PAGES= lget('asa2pdf_P')                                         ! number pages

   if(GLOBAL_SHADE_STEP < 1 )then
      call stderr("W-A-R-N-I-N-G: asa2pdf(1) resetting -i "//v2s(GLOBAL_SHADE_STEP))
      GLOBAL_SHADE_STEP=1;
   endif

   if(GLOBAL_LINES_PER_PAGE < 1 )then
      call stderr("W-A-R-N-I-N-G: asa2pdf(1) resetting -l "//v2s(GLOBAL_LINES_PER_PAGE))
      GLOBAL_LINES_PER_PAGE=60;
   endif

   if(lget('asa2pdf_show'))then
      call showhelp()
      stop 3
   endif

   open(unit=GLOBAL_DIRECT,iostat=ios,access='direct',form='formatted',recl=34,status='scratch')
   if(ios.ne.0)then
      call stderr("E-R-R-O-R: asa2pdf(1) cannot open scratch file ")
      stop 3
   endif

   call dopages()

   CLOSE(UNIT=GLOBAL_OUTFILE,iostat=ios)
   CLOSE(UNIT=GLOBAL_DIRECT,iostat=ios)
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()=
!===================================================================================================================================
contains
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()=
!===================================================================================================================================
subroutine showhelp()
   write(*,'("-u ",g0," # unit multiplier")')          GLOBAL_UNIT_MULTIPLIER
   write(*,'("-T ",g0," # Top margin")')               GLOBAL_PAGE_MARGIN_TOP/GLOBAL_UNIT_MULTIPLIER
   write(*,'("-B ",g0," # Bottom margin")')            GLOBAL_PAGE_MARGIN_BOTTOM/GLOBAL_UNIT_MULTIPLIER
   write(*,'("-L ",g0," # Left margin")')              GLOBAL_PAGE_MARGIN_LEFT/GLOBAL_UNIT_MULTIPLIER
   write(*,'("-R ",g0," # Right margin")')             GLOBAL_PAGE_MARGIN_RIGHT/GLOBAL_UNIT_MULTIPLIER

   write(*,'("-W ",g0," # page Width")')               GLOBAL_PAGE_WIDTH/GLOBAL_UNIT_MULTIPLIER
   write(*,'("-H ",g0," # page Height")')              GLOBAL_PAGE_DEPTH/GLOBAL_UNIT_MULTIPLIER

   write(*,'("-g ",g0,    " # shading gray scale value ([black]0 <= g <= 1[white]")') GLOBAL_GRAY_SCALE
   write(*,'("-i ",i0,t14," # shading line increment")')    GLOBAL_SHADE_STEP
   write(*,'("-d ",a,     " # shading line dashcode")')     trim(GLOBAL_DASHCODE)

   write(*,'("-l ",g0,t14," # lines per page")')            GLOBAL_LINES_PER_PAGE
   write(*,'("-f ",a,t14, " # font name")')                 trim(GLOBAL_FONT)

   write(*,'("-s ",a,     " # margin label")')              trim(GLOBAL_CENTER_TITLE)
   write(*,'("-t ",a,     " # margin left label")')         trim(GLOBAL_LEFT_TITLE)
   write(*,'("-S ",i0,t14," # right shift")')               GLOBAL_SHIFT

   write(*,'("-N [flag=",g0,"] # add line numbers ")')      GLOBAL_LINENUMBERS
   write(*,'("-P [flag=",L1,"] # add page numbers")')       GLOBAL_PAGES
end subroutine showhelp
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()=
!===================================================================================================================================
!>##REFERENCE
!!    8.4.3.6       Line Dash Pattern
!!
!!    The line dash pattern shall control the pattern of dashes and gaps used to stroke paths. It shall be specified by
!!    a dash array and a dash phase. The dash array's elements shall be numbers that specify the lengths of
!!    alternating dashes and gaps; the numbers shall be nonnegative and not all zero. The dash phase shall specify
!!    the distance into the dash pattern at which to start the dash. The elements of both the dash array and the dash
!!    phase shall be expressed in user space units.
!!
!!    Before beginning to stroke a path, the dash array shall be cycled through, adding up the lengths of dashes and
!!    gaps. When the accumulated length equals the value specified by the dash phase, stroking of the path shall
!!    begin, and the dash array shall be used cyclically from that point onward. Table 56 shows examples of line
!!    dash patterns. As can be seen from the table, an empty dash array and zero phase can be used to restore the
!!    dash pattern to a solid line.
!!
!!                       Table 56 ­ Examples of Line Dash Patterns
!!
!!      Dash Array       Appearance                   Description
!!      and Phase
!!
!!      [] 0                                          No dash; solid, unbroken lines
!!
!!      [3] 0                                         3 units on, 3 units off, ...
!!
!!      [2] 1                                         1 on, 2 off, 2 on, 2 off, ...
!!
!!      [2 1] 0                                       2 on, 1 off, 2 on, 1 off, ...
!!
!!      [3 5] 6                                       2 off, 3 on, 5 off, 3 on, 5 off, ...
!!
!!      [ 2 3 ] 11                                    1 on, 3 off, 2 on, 3 off, 2 on, ...
!!
!!    Dashed lines shall wrap around curves and corners just as solid stroked lines do. The ends of each dash shall
!!    be treated with the current line cap style, and corners within dashes shall be treated with the current line join
!!    style. A stroking operation shall take no measures to coordinate the dash pattern with features of the path; it
!!    simply shall dispense dashes and gaps along the path in the pattern defined by the dash array.
!!
!!    When a path consisting of several subpaths is stroked, each subpath shall be treated independently--that is,
!!    the dash pattern shall be restarted and the dash phase shall be reapplied to it at the beginning of each subpath.
subroutine print_bars()
real :: x1
real :: y1
real :: height
real :: width
real :: step

   write(GLOBAL_OUTFILE,'(f0.6," g")')GLOBAL_GRAY_SCALE ! gray-scale value
   ! If you want to add color,
   ! R G B rg where R G B are red, green, blue components
   ! in range 0.0 to 1.0 sets fill color, "RG" sets line
   ! color instead of fill color.
   !
   ! 0.60 0.82 0.60 rg
   !

   write(GLOBAL_OUTFILE,'(i0," i")')1

   x1=GLOBAL_PAGE_MARGIN_LEFT-0.1*GLOBAL_FONT_SIZE
   height=GLOBAL_SHADE_STEP*GLOBAL_LEAD_SIZE
   y1 = GLOBAL_PAGE_DEPTH - GLOBAL_PAGE_MARGIN_TOP - height- 0.22*GLOBAL_FONT_SIZE
   width=GLOBAL_PAGE_WIDTH-GLOBAL_PAGE_MARGIN_LEFT-GLOBAL_PAGE_MARGIN_RIGHT
   step=1.0

   if(GLOBAL_DASHCODE.ne.'')then
      write(GLOBAL_OUTFILE, '("0 w [",a,"] 0 d")')GLOBAL_DASHCODE      ! dash code array plus offset
   endif

   do while ( y1 >= (GLOBAL_PAGE_MARGIN_BOTTOM-height) )
      if(GLOBAL_DASHCODE .eq.'')then
            ! a shaded bar
            write(GLOBAL_OUTFILE,'(4(f0.6,1x),"re f")')x1,y1,width,height
            step=2.0

            !! x1 y1 m x2 y2 l S
            !! xxx w  # line width
            !write(GLOBAL_OUTFILE,'("0.6 0.8 0.6 RG",/,1x,f0.6,1x, f0.6," m ",%f %f," l S")')x1,y1,x1+width,y1

      else
             write(GLOBAL_OUTFILE,'(f0.6,1x,f0.6," m ")',advance='no') x1 ,y1
             write(GLOBAL_OUTFILE,'(f0.6,1x,f0.6," l s")')x1+width,y1
      endif
      y1=y1-step*height
   enddo

   if(GLOBAL_DASHCODE .ne. '')then
      write(GLOBAL_OUTFILE, '("[] 0 d")') ! set dash pattern to solid line
   endif

   write(GLOBAL_OUTFILE,'(i0," G")') 0
   write(GLOBAL_OUTFILE,'(i0," g")') 0 ! gray-scale value

 end subroutine print_bars
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()=
!===================================================================================================================================
subroutine end_page()
integer :: stream_len
integer :: page_id

   page_id = GLOBAL_OBJECT_ID
   GLOBAL_OBJECT_ID=GLOBAL_OBJECT_ID+1

   call store_page(page_id)
   write(GLOBAL_OUTFILE,'("ET")')

   stream_len = tell_position(GLOBAL_OUTFILE) - GLOBAL_STREAM_START
   write(GLOBAL_OUTFILE,'("endstream",/,"endobj")')

   call start_object(GLOBAL_STREAM_LEN_ID)
   write(GLOBAL_OUTFILE,'(i0,/,"endobj")')stream_len

   call start_object(page_id);
   write(GLOBAL_OUTFILE,'("<</Type/Page/Parent ",i0," 0 R/Contents ",i0," 0 R>>",/,"endobj")')GLOBAL_PAGE_TREE_ID, GLOBAL_STREAM_ID

end subroutine end_page
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()=
!===================================================================================================================================
subroutine printstring(buffer)
character(len=*) :: buffer
! Print string as (escaped_string) where ()\ characters have a preceding \ character added
character(len=1) :: c
integer          :: i

   write(GLOBAL_OUTFILE,'(a)',advance='no')'('

   if(GLOBAL_LINENUMBERS )then
      write(GLOBAL_OUTFILE,'(i6.6,1x)')GLOBAL_LINECOUNT
   endif

   do i=1,len(buffer)

      c=char(ichar(buffer(i:i))+GLOBAL_ADD)

      select case(c)
      case ('(',')','\')
         write(GLOBAL_OUTFILE,'("\")',advance='no')
      end select

      write(GLOBAL_OUTFILE,'(a)',advance='no')c

   enddo

   write(GLOBAL_OUTFILE,'(")")',advance='no')

end subroutine printstring
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()=
!===================================================================================================================================
function tell_position(lun) result (position)
integer,intent(in) :: lun
integer :: position
integer :: ios
  INQUIRE(UNIT=lun, POS=position,iostat=ios)
  if(ios.ne.0)then
     call stderr('*asa2pdf* cannot determine position of output file')
  endif
  position=position-1
end function tell_position
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()=
!===================================================================================================================================
subroutine printme(xvalue,yvalue,string)
real,intent(in)             :: xvalue
real,intent(in)             :: yvalue
character(len=*),intent(in) :: string
   write(GLOBAL_OUTFILE,'("BT /F2 ",f0.6," Tf ",f0.6," ",f0.6," Td")')GLOBAL_TITLE_SIZE,xvalue,yvalue
   call printstring(string)
   write(GLOBAL_OUTFILE,'(" Tj ET")')
end subroutine printme
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()=
!===================================================================================================================================
subroutine dopages()
integer :: catalog_id
integer :: font_id0
integer :: font_id1
integer :: start_xref
character(len=34) :: string
integer :: i

write(GLOBAL_OUTFILE,'("%PDF-1.0")')

!   Note: If a PDF file contains binary data, as most do , it is
!   recommended that the header line be immediately followed by a
!   comment line containing at least four binary characters--that is,
!   characters whose codes are 128 or greater. This will ensure proper behavior of file
!   transfer applications that inspect data near the beginning of a
!   file to determine whether to treat the file's contents as text or as binary.

   write(GLOBAL_OUTFILE,'("%",*(a))')char(128),char(129),char(130),char(131)
   write(GLOBAL_OUTFILE,'("% PDF: Adobe Portable Document Format")')

   GLOBAL_LEAD_SIZE=(GLOBAL_PAGE_DEPTH-GLOBAL_PAGE_MARGIN_TOP-GLOBAL_PAGE_MARGIN_BOTTOM)/GLOBAL_LINES_PER_PAGE
   GLOBAL_FONT_SIZE=GLOBAL_LEAD_SIZE

   GLOBAL_OBJECT_ID = 1;
   GLOBAL_PAGE_TREE_ID = GLOBAL_OBJECT_ID
   GLOBAL_OBJECT_ID= GLOBAL_OBJECT_ID +1

   call do_text()

   font_id0 = GLOBAL_OBJECT_ID
   call start_object(font_id0)
   GLOBAL_OBJECT_ID= GLOBAL_OBJECT_ID +1

   write(GLOBAL_OUTFILE,'("<</Type/Font/Subtype/Type1/BaseFont/",a,"/Encoding/WinAnsiEncoding>>")')trim(GLOBAL_FONT)
   write(GLOBAL_OUTFILE,'("endobj")')

   font_id1 = GLOBAL_OBJECT_ID
   call start_object(font_id1)
   GLOBAL_OBJECT_ID= GLOBAL_OBJECT_ID +1

   write(GLOBAL_OUTFILE,'("<</Type/Font/Subtype/Type1/BaseFont/",a,"/Encoding/WinAnsiEncoding>>")')trim(GLOBAL_FONT)
   write(GLOBAL_OUTFILE,'("endobj")')

   call start_object(GLOBAL_PAGE_TREE_ID)

   write(GLOBAL_OUTFILE,'("<</Type /Pages /Count ",i0)') GLOBAL_NUM_PAGES

   write(GLOBAL_OUTFILE,'("/Kids[")')
   write(GLOBAL_OUTFILE,'(a)') GLOBAL_PAGE_LIST ! '(i0," 0 R",new_line("A"))'
   write(GLOBAL_OUTFILE,'("]")')

   write(GLOBAL_OUTFILE,'("/Resources<</ProcSet[/PDF/Text]/Font<</F0 ",i0," 0 R")') font_id0
   write(GLOBAL_OUTFILE,'("/F1 ",i0," 0 R")') font_id1
   write(GLOBAL_OUTFILE,'(" /F2<</Type/Font/Subtype/Type1/BaseFont/Courier-Bold/Encoding/WinAnsiEncoding >> >>")')

   !write(GLOBAL_OUTFILE,'(">>/MediaBox [ 0 0 ",f0.6,1x,f0.6," ]")') GLOBAL_PAGE_WIDTH, GLOBAL_PAGE_DEPTH
   write(GLOBAL_OUTFILE,'(">>/MediaBox [ 0 0 ",a,1x,a," ]")') v2s(GLOBAL_PAGE_WIDTH), v2s(GLOBAL_PAGE_DEPTH)

   write(GLOBAL_OUTFILE,'(">>")')
   write(GLOBAL_OUTFILE,'("endobj")')

   catalog_id = GLOBAL_OBJECT_ID
   GLOBAL_OBJECT_ID= GLOBAL_OBJECT_ID +1
   call start_object(catalog_id)
   write(GLOBAL_OUTFILE,'("<</Type/Catalog/Pages ",i0," 0 R>>")') GLOBAL_PAGE_TREE_ID
   write(GLOBAL_OUTFILE,'("endobj")')
   start_xref = tell_position(GLOBAL_OUTFILE)
   write(GLOBAL_OUTFILE,'("xref")')
   write(GLOBAL_OUTFILE,'("0 ",i0)') GLOBAL_OBJECT_ID
   write(GLOBAL_OUTFILE,'("0000000000 65535 f ")')

   do i=1,GLOBAL_OBJECT_ID-1
      read(GLOBAL_DIRECT,'(a)',REC=i) string
      write(GLOBAL_OUTFILE,'(a)',advance='no') trim(string)
   enddo

   write(GLOBAL_OUTFILE,'("trailer")')
   write(GLOBAL_OUTFILE,'("<<")')
   write(GLOBAL_OUTFILE,'("/Size ",i0)') GLOBAL_OBJECT_ID
   write(GLOBAL_OUTFILE,'("/Root ",i0," 0 R")') catalog_id
   write(GLOBAL_OUTFILE,'(">>")')
   write(GLOBAL_OUTFILE,'("startxref")')
   write(GLOBAL_OUTFILE,'(i0)') start_xref
   write(GLOBAL_OUTFILE,'("%%EOF")')
end subroutine dopages
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()=
!===================================================================================================================================
 subroutine start_page()
   GLOBAL_STREAM_ID = GLOBAL_OBJECT_ID
   GLOBAL_OBJECT_ID= GLOBAL_OBJECT_ID +1
   GLOBAL_STREAM_LEN_ID = GLOBAL_OBJECT_ID
   GLOBAL_OBJECT_ID= GLOBAL_OBJECT_ID +1
   GLOBAL_PAGECOUNT= GLOBAL_PAGECOUNT+1
   call start_object(GLOBAL_STREAM_ID)

   write(GLOBAL_OUTFILE,'("<< /Length ",i0," 0 R >>")') GLOBAL_STREAM_LEN_ID
   write(GLOBAL_OUTFILE,'("stream")')

   GLOBAL_STREAM_START = tell_position(GLOBAL_OUTFILE)
   call print_bars()
   call print_margin_label()

   write(GLOBAL_OUTFILE,'("BT")')
   write(GLOBAL_OUTFILE,'("/F0 ",f0.6," Tf")') GLOBAL_FONT_SIZE

   GLOBAL_YPOS = GLOBAL_PAGE_DEPTH - GLOBAL_PAGE_MARGIN_TOP

   write(GLOBAL_OUTFILE,'(f0.6,1x,f0.6," Td")') GLOBAL_PAGE_MARGIN_LEFT, GLOBAL_YPOS
   write(GLOBAL_OUTFILE,'(f0.6," TL")') GLOBAL_LEAD_SIZE

end subroutine start_page
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()=
!===================================================================================================================================
subroutine print_margin_label()
character(len=80) :: line
real              :: charwidth
real              :: start
logical           :: hold

hold=GLOBAL_LINENUMBERS
GLOBAL_LINENUMBERS=.false.

call printme_top()

if(GLOBAL_CENTER_TITLE .ne.  '' )then

   ! assuming fixed-space font Courier-Bold
   charwidth=GLOBAL_TITLE_SIZE*0.60
   start=GLOBAL_PAGE_MARGIN_LEFT &
      &    +((GLOBAL_PAGE_WIDTH-GLOBAL_PAGE_MARGIN_LEFT-GLOBAL_PAGE_MARGIN_RIGHT)/2.0) &
      &    -(len_trim(GLOBAL_CENTER_TITLE)*charwidth/2.0)

   call printme(start,GLOBAL_PAGE_DEPTH-GLOBAL_PAGE_MARGIN_TOP+0.12*GLOBAL_TITLE_SIZE,GLOBAL_CENTER_TITLE)
   call printme(start,GLOBAL_PAGE_MARGIN_BOTTOM-GLOBAL_TITLE_SIZE,GLOBAL_CENTER_TITLE)
endif

if(GLOBAL_PAGES)then                                 ! print page numbers on page
   charwidth=GLOBAL_TITLE_SIZE*0.60
   write(line,'("Page ",i0.4)')GLOBAL_PAGECOUNT
   start=GLOBAL_PAGE_WIDTH-GLOBAL_PAGE_MARGIN_RIGHT-(len_trim(line)*charwidth) ! Right Justified
   call printme(start,GLOBAL_PAGE_DEPTH-GLOBAL_PAGE_MARGIN_TOP+0.12*GLOBAL_TITLE_SIZE,line)
   call printme(start,GLOBAL_PAGE_MARGIN_BOTTOM-GLOBAL_TITLE_SIZE,line)
endif

if(GLOBAL_LEFT_TITLE .ne. "" )then
   start=GLOBAL_PAGE_MARGIN_LEFT     ! Left justified
   call printme(start,GLOBAL_PAGE_DEPTH-GLOBAL_PAGE_MARGIN_TOP+0.12*GLOBAL_TITLE_SIZE,GLOBAL_LEFT_TITLE)
   call printme(start,GLOBAL_PAGE_MARGIN_BOTTOM-GLOBAL_TITLE_SIZE,GLOBAL_LEFT_TITLE)
endif

GLOBAL_LINENUMBERS=hold

end subroutine print_margin_label
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()=
!===================================================================================================================================
subroutine printme_top()
character(len=256) :: IMPACT_TOP
real :: charwidth
real :: xvalue
real :: yvalue
real :: text_size=20.0
call get_environment_variable('IMPACT_TOP',impact_top)
if( impact_top .ne. '' )then
   charwidth=text_size*0.60                              ! assuming fixed-space font Courier-Bold
   write(GLOBAL_OUTFILE,'("1.0 0.0 0.0 rg")')            ! gray-scale value
   yvalue=GLOBAL_PAGE_DEPTH-text_size
   xvalue=GLOBAL_PAGE_MARGIN_LEFT &
      & +((GLOBAL_PAGE_WIDTH-GLOBAL_PAGE_MARGIN_LEFT-GLOBAL_PAGE_MARGIN_RIGHT)/2.0) &
      & -(len_trim(IMPACT_TOP)*charwidth/2.0)

   write(GLOBAL_OUTFILE,'("BT /F2 ",f0.6," Tf ",f0.6,1x,f0.6," Td")')text_size,xvalue,yvalue
   call printstring(IMPACT_TOP)
   write(GLOBAL_OUTFILE,'(" Tj ET")')

   write(GLOBAL_OUTFILE,'("0.0 0.0 0.0 rg")')            ! gray-scale value
endif
end subroutine printme_top
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()=
!===================================================================================================================================
subroutine increment_ypos(mult)
real,intent(in) :: mult
   if (GLOBAL_YPOS < GLOBAL_PAGE_DEPTH - GLOBAL_PAGE_MARGIN_TOP ) then  ! if not at top of page
      GLOBAL_YPOS = GLOBAL_YPOS + GLOBAL_LEAD_SIZE*mult
   endif
end subroutine increment_ypos
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()=
!===================================================================================================================================
subroutine store_page(id)
integer,intent(in) :: id
character(len=80) :: string
   write(string,'(i0," 0 R")')id
   GLOBAL_PAGE_LIST = GLOBAL_PAGE_LIST // trim(string) //new_line('A')
   GLOBAL_NUM_PAGES= GLOBAL_NUM_PAGES + 1
end subroutine store_page
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()=
!===================================================================================================================================
subroutine start_object(id)
integer,intent(in) :: id
character(len=34)  :: string

   ! record position of start of object in file for writing the reference table at the end
   write(string,'(i10.10," 00000 n ",a)') tell_position(GLOBAL_OUTFILE) ,new_line('a')
   write(GLOBAL_DIRECT,'(a)',rec=id)string

   ! write the beginning of the object definition
   write(GLOBAL_OUTFILE,'(i0," 0 obj")') id

end subroutine start_object
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()=
!===================================================================================================================================
subroutine do_text()
character(len=8192) :: buffer
character(len=1)    :: ASA
integer             :: black
integer             :: ios

call start_page()
buffer=' '

INFINITE: do
   read(GLOBAL_INFILE,'(a)',iostat=ios) buffer(GLOBAL_SHIFT+1:)
   if(ios.ne.0)exit INFINITE
   GLOBAL_LINECOUNT= GLOBAL_LINECOUNT+1
   black=0
   GLOBAL_ADD=0

   ! +1 for roundoff , using floating point point units
   if(GLOBAL_YPOS <= (GLOBAL_PAGE_MARGIN_BOTTOM+1) .and. len_trim(buffer) .ne. 0 .and. buffer(1:1) .ne. '+' ) then
      call end_page()
      call start_page()
   endif

   if(len_trim(buffer) .eq. 0)then ! blank line
      write(GLOBAL_OUTFILE,'("T*")')
   else
      ASA=buffer(1:1);

      select case(ASA)

         case ('1')     ! start a new page before processing data on line
            if (GLOBAL_YPOS < GLOBAL_PAGE_DEPTH - GLOBAL_PAGE_MARGIN_TOP )then
               call end_page()
               call start_page()
            endif

         case ('0')        ! put out a blank line before processing data on line
               write(GLOBAL_OUTFILE,'("T*")')
               GLOBAL_YPOS = GLOBAL_YPOS - GLOBAL_LEAD_SIZE

         case ('-')        ! put out two blank lines before processing data on line
            write(GLOBAL_OUTFILE,'("T*")')
            GLOBAL_YPOS = GLOBAL_YPOS - GLOBAL_LEAD_SIZE;
            GLOBAL_YPOS = GLOBAL_YPOS - GLOBAL_LEAD_SIZE;

         case ('+')        ! print at same y-position as previous line
            write(GLOBAL_OUTFILE,'("0 ",f0.6," Td")')GLOBAL_LEAD_SIZE
            call increment_ypos(1.0)

         case ('R','G','B')  ! RED/GREEN/BLUE print at same y-position as previous line
            if(ASA .eq. 'R') write(GLOBAL_OUTFILE,'("1.0 0.0 0.0 rg")') ! red text
            if(ASA .eq. 'G') write(GLOBAL_OUTFILE,'("0.0 1.0 0.0 rg")') ! green text
            if(ASA .eq. 'B') write(GLOBAL_OUTFILE,'("0.0 0.0 1.0 rg")') ! blue text
            black=1
            write(GLOBAL_OUTFILE,'("0 ",f6.0," Td")')GLOBAL_LEAD_SIZE
            call increment_ypos(1.0)

         case ('H')        ! 1/2 line advance
            write(GLOBAL_OUTFILE,'("0 ",f0.6," Td")')GLOBAL_LEAD_SIZE/2.0
            call increment_ypos(0.5)

         case ('r','g','b') ! RED, GREEN, BLUE  print
            if(ASA .eq. 'r') write(GLOBAL_OUTFILE,'("1.0 0.0 0.0 rg")') ! red text
            if(ASA .eq. 'g') write(GLOBAL_OUTFILE,'("0.0 1.0 0.0 rg")') ! green text
            if(ASA .eq. 'b') write(GLOBAL_OUTFILE,'("0.0 0.0 1.0 rg")') ! blue text
            black=1

         case ('^')        ! print at same y-position as previous line like + but add 127 to character
            write(GLOBAL_OUTFILE,'("0 ",f0.6," Td")')GLOBAL_LEAD_SIZE
            call increment_ypos(1.0)
            GLOBAL_ADD=127

         case (char(12))       ! ctrl-L is a common form-feed character on Unix, but NOT ASA
            call end_page()
            call start_page()

         case (' ')
         case default
         call stderr("unknown ASA carriage control character "//ASA)

      end select

      call printstring(trim(buffer(2:)))
      write(GLOBAL_OUTFILE,'("''")')

   endif
   GLOBAL_YPOS = GLOBAL_YPOS - GLOBAL_LEAD_SIZE
   if(black .ne. 0)then
      write(GLOBAL_OUTFILE,'("0.0 0.0 0.0 rg")') ! black text
   endif

   enddo INFINITE
   call end_page()
end subroutine do_text
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()=
!===================================================================================================================================
end program asa2pdf
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()=
!===================================================================================================================================
category: code