Clicky
Showing changes from revision #3 to #4:
(追記) Added (追記ここまで) | (削除) Removed (削除ここまで) | (削除) Chan (削除ここまで)(追記) ged (追記ここまで)
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. ',&
' -b 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 -b 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'' (削除ここまで)(追記) 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 -b 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(削除) \\ (削除ここまで)(追記) \ (追記ここまで) ',&
' -b 1 -T 1 -B .75 -N -o paper.pdf < asa2pdf.c ',&
' ',&
' # titling ',&
' asa2pdf -d ''1 0 1'' -t "$USER" -b 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, >= 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.
!! -b 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-=_+()*&^%$#@!\\|[]{};':",.<>/?`~ (削除ここまで)(追記) 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 -b 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 -b 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(削除) \\ (削除ここまで)(追記) \ (追記ここまで)
!! -b 1 -T 1 -B .75 -N -o paper.pdf < asa2pdf.c
!!
!! # titling
!! asa2pdf -d '1 0 1' -t "$USER" -b 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',' &
& -i &
& -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
& -b 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 -b "//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(*,'("-b ",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
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()=
!===================================================================================================================================