!>>>>> build/dependencies/M_CLI2/src/M_CLI2.F90 !VERSION 1.0 20200115 !VERSION 2.0 20200802 !VERSION 3.0 20201021 LONG:SHORT syntax !VERSION 3.1 20201115 LONG:SHORT:: syntax !VERSION 3.2 20230205 set_mode() !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! M_CLI2(3fm) - [ARGUMENTS::M_CLI2::INTRO] command line argument !! parsing using a prototype command !! (LICENSE:PD) !!##SYNOPSIS !! !! Available procedures and variables: !! !! ! basic procedures !! use M_CLI2, only : set_args, get_args, specified, set_mode !! ! convenience functions !! use M_CLI2, only : dget, iget, lget, rget, sget, cget !! use M_CLI2, only : dgets, igets, lgets, rgets, sgets, cgets !! ! variables !! use M_CLI2, only : unnamed, remaining, args !! ! working with non-allocatable strings and arrays !! use M_CLI2, only : get_args_fixed_length, get_args_fixed_size !! ! special function for creating subcommands !! use M_CLI2, only : get_subcommand(3f) !! !!##DESCRIPTION !! The M_CLI2 module cracks a Unix-style command line. !! !! Typically one call to SET_ARGS(3f) is made to define the command !! arguments, set default values and parse the command line. Then a call !! is made to the convenience procedures or GET_ARGS(3f) proper for each !! command keyword to obtain the argument values. !! !! Detailed descriptions of each procedure and example programs are !! included. !! !!##EXAMPLE !! !! !! Sample minimal program which may be called in various ways: !! !! mimimal -x 100.3 -y 3.0e4 !! mimimal --xvalue=300 --debug !! mimimal --yvalue 400 !! mimimal -x 10 file1 file2 file3 !! !! Program example: !! !! program minimal !! use M_CLI2, only : set_args, lget, rget, sgets !! implicit none !! real :: x, y !! integer :: i !! character(len=:),allocatable :: filenames(:) !! ! define and crack command line !! call set_args(' --yvalue:y 0.0 --xvalue:x 0.0 --debug F') !! ! get values !! x=rget('xvalue') !! y=rget('yvalue') !! if(lget('debug'))then !! write(*,*)'X=',x !! write(*,*)'Y=',y !! write(*,*)'ATAN2(Y,X)=',atan2(x=x,y=y) !! else !! write(*,*)atan2(x=x,y=y) !! endif !! filenames=sgets() ! sget with no name gets "unnamed" values !! if(size(filenames) > 0)then !! write(*,'(g0)')'filenames:' !! write(*,'(i6.6,3a)')(i,'[',filenames(i),']',i=1,size(filenames)) !! endif !! end program minimal !! !! Sample program using get_args() and variants !! !! program demo_M_CLI2 !! use M_CLI2, only : set_args, get_args !! use M_CLI2, only : filenames=>unnamed !! use M_CLI2, only : get_args_fixed_length, get_args_fixed_size !! implicit none !! integer :: i !! integer,parameter :: dp=kind(0.0d0) !! ! !! ! Define ARGS !! real :: x, y, z !! logical :: l, lbig !! character(len=40) :: label ! FIXED LENGTH !! real(kind=dp),allocatable :: point(:) !! logical,allocatable :: logicals(:) !! character(len=:),allocatable :: title ! VARIABLE LENGTH !! real :: p(3) ! FIXED SIZE !! logical :: logi(3) ! FIXED SIZE !! ! !! ! DEFINE AND PARSE (TO SET INITIAL VALUES) COMMAND LINE !! ! o set a value for all keywords. !! ! o double-quote strings, strings must be at least one space !! ! because adjacent double-quotes designate a double-quote !! ! in the value. !! ! o set all logical values to F !! ! o numeric values support an "e" or "E" exponent !! ! o for lists delimit with a comma, colon, or space !! call set_args(' & !! & -x 1 -y 2 -z 3 & !! & -p -1 -2 -3 & !! & --point 11.11, 22.22, 33.33e0 & !! & --title "my title" -l F -L F & !! & --logicals F F F F F & !! & --logi F T F & !! & --label " " & !! ! note space between quotes is required !! & ') !! ! Assign values to elements using G_ARGS(3f). !! ! non-allocatable scalars can be done up to twenty per call !! call get_args('x',x, 'y',y, 'z',z, 'l',l, 'L',lbig) !! ! As a convenience multiple pairs of keywords and variables may be !! ! specified if and only if all the values are scalars and the CHARACTER !! ! variables are fixed-length or pre-allocated. !! ! !! ! After SET_ARGS(3f) has parsed the command line !! ! GET_ARGS(3f) retrieves the value of keywords accept for !! ! two special cases. For fixed-length CHARACTER variables !! ! see GET_ARGS_FIXED_LENGTH(3f). For fixed-size arrays see !! ! GET_ARGS_FIXED_SIZE(3f). !! ! !! ! allocatables should be done one at a time !! call get_args('title',title) ! allocatable string !! call get_args('point',point) ! allocatable arrays !! call get_args('logicals',logicals) !! ! !! ! less commonly ... !! !! ! for fixed-length strings !! call get_args_fixed_length('label',label) !! !! ! for non-allocatable arrays !! call get_args_fixed_size('p',p) !! call get_args_fixed_size('logi',logi) !! ! !! ! all done parsing, use values !! write(*,*)'x=',x, 'y=',y, 'z=',z, x+y+z !! write(*,*)'p=',p !! write(*,*)'point=',point !! write(*,*)'title=',title !! write(*,*)'label=',label !! write(*,*)'l=',l !! write(*,*)'L=',lbig !! write(*,*)'logicals=',logicals !! write(*,*)'logi=',logi !! ! !! ! unnamed strings !! ! !! if(size(filenames) > 0)then !! write(*,'(i6.6,3a)')(i,'[',filenames(i),']',i=1,size(filenames)) !! endif !! ! !! end program demo_M_CLI2 !! !!##AUTHOR !! John S. Urban, 2019 !!##LICENSE !! Public Domain !!##SEE ALSO !! + get_args(3f) !! + get_args_fixed_size(3f) !! + get_args_fixed_length(3f) !! + get_subcommand(3f) !! + set_mode(3f) !! + specified(3f) !! !! Note that the convenience routines are described under get_args(3f): !! dget(3f), iget(3f), lget(3f), rget(3f), sget(3f), cget(3f) dgets(3f), !! igets(3f), lgets(3f), rgets(3f), sgets(3f), cgets(3f) !=================================================================================================================================== module M_CLI2 use, intrinsic :: iso_fortran_env, only : stderr=>ERROR_UNIT, stdin=>INPUT_UNIT, stdout=>OUTPUT_UNIT, warn=>OUTPUT_UNIT implicit none private integer,parameter,private :: dp=kind(0.0d0) integer,parameter,private :: sp=kind(0.0) character(len=*),parameter :: gen='(*(g0))' character(len=:),allocatable,public :: unnamed(:) character(len=:),allocatable,public :: args(:) character(len=:),allocatable,public :: remaining public :: set_mode public :: set_args public :: get_subcommand public :: get_args public :: get_args_fixed_size public :: get_args_fixed_length public :: specified public :: print_dictionary public :: dget, iget, lget, rget, sget, cget public :: dgets, igets, lgets, rgets, sgets, cgets type option character(:),allocatable :: shortname character(:),allocatable :: longname character(:),allocatable :: value integer :: length logical :: present_in logical :: mandatory end type option character(len=:),allocatable,save :: keywords(:) character(len=:),allocatable,save :: shorts(:) character(len=:),allocatable,save :: values(:) integer,allocatable,save :: counts(:) logical,allocatable,save :: present_in(:) logical,allocatable,save :: mandatory(:) logical,save :: G_DEBUG=.false. logical,save :: G_UNDERDASH=.false. logical,save :: G_NODASHUNDER=.false. logical,save :: G_IGNORELONGCASE=.false. ! ignore case of long keywords logical,save :: G_IGNOREALLCASE=.false. ! ignore case of long and short keywords logical,save :: G_STRICT=.false. ! strict short and long rules or allow -longname and --shortname logical,save :: G_APPEND=.true. ! whether to append or replace when duplicate keywords found logical,save :: G_keyword_single_letter=.true. character(len=:),allocatable,save :: G_passed_in logical,save :: G_remaining_on, G_remaining_option_allowed character(len=:),allocatable,save :: G_remaining character(len=:),allocatable,save :: G_subcommand ! possible candidate for a subcommand character(len=:),allocatable,save :: G_STOP_MESSAGE integer,save :: G_STOP logical,save :: G_QUIET character(len=:),allocatable,save :: G_PREFIX ! try out response files ! CLI_RESPONSE_FILE is left public for backward compatibility, but should be set via "set_mode('response_file') logical,save,public :: CLI_RESPONSE_FILE=.false. ! allow @name abbreviations logical,save :: G_OPTIONS_ONLY ! process response file only looking for options for get_subcommand() logical,save :: G_RESPONSE ! allow @name abbreviations character(len=:),allocatable,save :: G_RESPONSE_IGNORED ! return allocatable arrays interface get_args; module procedure get_anyarray_d; end interface ! any size array interface get_args; module procedure get_anyarray_i; end interface ! any size array interface get_args; module procedure get_anyarray_r; end interface ! any size array interface get_args; module procedure get_anyarray_x; end interface ! any size array interface get_args; module procedure get_anyarray_c; end interface ! any size array and any length interface get_args; module procedure get_anyarray_l; end interface ! any size array ! return scalars interface get_args; module procedure get_scalar_d; end interface interface get_args; module procedure get_scalar_i; end interface interface get_args; module procedure get_scalar_real; end interface interface get_args; module procedure get_scalar_complex; end interface interface get_args; module procedure get_scalar_logical; end interface interface get_args; module procedure get_scalar_anylength_c; end interface ! any length ! multiple scalars interface get_args; module procedure many_args; end interface ! return non-allocatable arrays ! said in conflict with get_args_*. Using class to get around that. ! that did not work either. Adding size parameter as optional parameter works; but using a different name interface get_args_fixed_size; module procedure get_fixedarray_class; end interface ! any length, fixed size array !interface get_args; module procedure get_fixedarray_d; end interface !interface get_args; module procedure get_fixedarray_i; end interface !interface get_args; module procedure get_fixedarray_r; end interface !interface get_args; module procedure get_fixedarray_l; end interface !interface get_args; module procedure get_fixedarray_fixed_length_c; end interface interface get_args_fixed_length; module procedure get_args_fixed_length_a_array; end interface ! fixed length any size array interface get_args_fixed_length; module procedure get_args_fixed_length_scalar_c; end interface ! fixed length ! Generic subroutine inserts element into allocatable array at specified position ! find PLACE in sorted character array where value can be found or should be placed interface locate_; module procedure locate_c ; end interface ! insert entry into a sorted allocatable array at specified position interface insert_; module procedure insert_c, insert_i, insert_l ; end interface ! replace entry by index from a sorted allocatable array if it is present interface replace_; module procedure replace_c, replace_i, replace_l ; end interface ! delete entry by index from a sorted allocatable array if it is present interface remove_; module procedure remove_c, remove_i, remove_l ; end interface ! convenience functions interface cgets;module procedure cgs, cg;end interface interface dgets;module procedure dgs, dg;end interface interface igets;module procedure igs, ig;end interface interface lgets;module procedure lgs, lg;end interface interface rgets;module procedure rgs, rg;end interface interface sgets;module procedure sgs, sg;end interface contains !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! check_commandline(3f) - [ARGUMENTS:M_CLI2]check command and process !! pre-defined options !! !!##SYNOPSIS !! !! subroutine check_commandline(help_text,version_text,ierr,errmsg) !! !! character(len=*),intent(in),optional :: help_text(:) !! character(len=*),intent(in),optional :: version_text(:) !! !!##DESCRIPTION !! Checks the commandline and processes the implicit --help, --version, !! --verbose, and --usage parameters. !! !! If the optional text values are supplied they will be displayed by !! --help and --version command-line options, respectively. !! !!##OPTIONS !! !! HELP_TEXT if present, will be displayed if program is called with !! --help switch, and then the program will terminate. If !! not supplied, the command line initialized string will be !! shown when --help is used on the commandline. !! !! VERSION_TEXT if present, will be displayed if program is called with !! --version switch, and then the program will terminate. !! !! If the first four characters of each line are "@(#)" this prefix !! will not be displayed and the last non-blank letter will be !! removed from each line. This if for support of the SCCS what(1) !! command. If you do not have the what(1) command on GNU/Linux and !! Unix platforms you can probably see how it can be used to place !! metadata in a binary by entering: !! !! strings demo_commandline|grep '@(#)'|tr '>' '\n'|sed -e 's/ */ /g' !! !!##EXAMPLE !! !! !! Typical usage: !! !! program check_commandline !! use M_CLI2, only : unnamed, set_args, get_args !! implicit none !! integer :: i !! character(len=:),allocatable :: version_text(:), help_text(:) !! real :: x, y, z !! character(len=*),parameter :: cmd='-x 1 -y 2 -z 3' !! version_text=[character(len=80) :: "version 1.0","author: me"] !! help_text=[character(len=80) :: & !! & "wish I put instructions","here","I suppose?"] !! call set_args(cmd,help_text,version_text) !! call get_args('x',x,'y',y,'z',z) !! ! All done cracking the command line. Use the values in your program. !! write (*,*)x,y,z !! ! the optional unnamed values on the command line are !! ! accumulated in the character array "UNNAMED" !! if(size(unnamed) > 0)then !! write (*,'(a)')'files:' !! write (*,'(i6.6,3a)') (i,'[',unnamed(i),']',i=1,size(unnamed)) !! endif !! end program check_commandline !=================================================================================================================================== subroutine check_commandline(help_text,version_text) character(len=*),intent(in),optional :: help_text(:) character(len=*),intent(in),optional :: version_text(:) character(len=:),allocatable :: line integer :: i integer :: istart integer :: iback if(get('usage') == 'T')then call print_dictionary_usage() call mystop(32) return endif if(present(help_text))then if(get('help') == 'T')then do i=1,size(help_text) call journal(help_text(i)) enddo call mystop(1,'displayed help text') return endif elseif(get('help') == 'T')then call default_help() call mystop(2,'displayed default help text') return endif if(present(version_text))then if(get('version') == 'T')then istart=1 iback=0 if(size(version_text) > 0)then if(index(version_text(1),'@'//'(#)') == 1)then ! allow for what(1) syntax istart=5 iback=1 endif endif do i=1,size(version_text) !xINTEL BUG*!call journal(version_text(i)(istart:len_trim(version_text(i))-iback)) line=version_text(i)(istart:len_trim(version_text(i))-iback) call journal(line) enddo call mystop(3,'displayed version text') return endif elseif(get('version') == 'T')then if(G_QUIET)then G_STOP_MESSAGE = 'no version text' else call journal('*check_commandline* no version text') endif call mystop(4,'displayed default version text') return endif contains subroutine default_help() character(len=:),allocatable :: cmd_name integer :: ilength call get_command_argument(number=0,length=ilength) if(allocated(cmd_name))deallocate(cmd_name) allocate(character(len=ilength) :: cmd_name) call get_command_argument(number=0,value=cmd_name) G_passed_in=G_passed_in//repeat(' ',len(G_passed_in)) G_passed_in=replace_str(G_passed_in, ' --', NEW_LINE('A')//' --') if(.not.G_QUIET)then call journal(cmd_name,G_passed_in) ! no help text, echo command and default options endif deallocate(cmd_name) end subroutine default_help end subroutine check_commandline !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! set_args(3f) - [ARGUMENTS:M_CLI2] command line argument parsing !! (LICENSE:PD) !! !!##SYNOPSIS !! !! subroutine set_args(prototype,help_text,version_text,ierr,errmsg) !! !! character(len=*),intent(in),optional :: prototype !! character(len=*),intent(in),optional :: help_text(:) !! character(len=*),intent(in),optional :: version_text(:) !! integer,intent(out),optional :: ierr !! character(len=:),intent(out),allocatable,optional :: errmsg !!##DESCRIPTION !! !! SET_ARGS(3f) requires a unix-like command prototype which defines !! the command-line options and their default values. When the program !! is executed this and the command-line options are applied and the !! resulting values are placed in an internal table for retrieval via !! GET_ARGS(3f). !! !! The built-in --help and --version options require optional help_text !! and version_text values to be provided to be particularly useful. !! !!##OPTIONS !! !! PROTOTYPE composed of all command arguments concatenated !! into a Unix-like command prototype string. For !! example: !! !! call set_args('-L F --ints 1,2,3 --title "my title" -R 10.3') !! !! The following options are predefined for all commands: !! '--verbose F --usage F --help F --version F'. !! !! see "DEFINING THE PROTOTYPE" in the next section for !! further details. !! !! HELP_TEXT if present, will be displayed when the program is called with !! a --help switch, and then the program will terminate. If !! help text is not supplied the command line initialization !! string will be echoed. !! !! VERSION_TEXT if present, any version text defined will be displayed !! when the program is called with a --version switch, !! and then the program will terminate. !! IERR if present a non-zero option is returned when an !! error occurs instead of the program terminating. !! ERRMSG a description of the error if ierr is present. !! !!##DEFINING THE PROTOTYPE !! !! o Keywords start with a single dash for short single-character !! keywords, and with two dashes for longer keywords. !! !! o all keywords on the prototype MUST get a value. !! !! * logicals must be set to an unquoted F. !! !! * strings must be delimited with double-quotes. !! Since internal double-quotes are represented with two !! double-quotes the string must be at least one space. !! !! o numeric keywords are not allowed; but this allows !! negative numbers to be used as values. !! !! o lists of values should be comma-delimited unless a !! user-specified delimiter is used. The prototype !! must use the same array delimiters as the call to !! get the value. !! !! o to define a zero-length allocatable array make the !! value a delimiter (usually a comma) or an empty set !! of braces ("[]"). !! !! LONG AND SHORT NAMES !! !! Long keywords start with two dashes followed by more than one letter. !! Short keywords are a dash followed by a single letter. !! !! o It is recommended long names (--keyword) should be all lowercase !! but are case-sensitive by default, unless !! "set_mode('ignorelongcase')" of "set_mode('ignoreallcase')" is !! in effect. !! !! o Long names should always be more than one character. !! !! o The recommended way to have short names is to suffix the long !! name with :LETTER in the definition. !! !! If this syntax is used then logical shorts may be combined on the !! command line when "set_mode('strict')" is in effect. !! !! SPECIAL BEHAVIORS !! !! o A special behavior occurs if a keyword name ends in ::. !! When the program is called the next parameter is taken as !! a value even if it starts with -. This is not generally !! recommended but is useful in rare cases where non-numeric !! values starting with a dash are desired. !! !! o If the prototype ends with "--" a special mode is turned !! on where anything after "--" on input goes into the variable !! REMAINING with values double-quoted and also into the array ARGS !! instead of becoming elements in the UNNAMED array. This is not !! needed for normal processing, but was needed for a program that !! needed this behavior for its subcommands. !! !! That is, for a normal call all unnamed values go into UNNAMED !! and ARGS and REMAINING are ignored. So for !! !! call set_args('-x 10 -y 20 ') !! !! A program invocation such as !! !! xx a b c -- A B C " dd " !! !! results in !! !! UNNAMED= ['a','b','c','A','B','C',' dd'] !! REMAINING= '' !! ARGS= [character(len=0) :: ] ! ie, an empty character array !! !! Whereas !! !! call set_args('-x 10 -y 20 --') !! !! generates the following output from the same program execution: !! !! UNNAMED= ['a','b','c'] !! REMAINING= '"A" "B" "C" " dd "' !! ARGS= ['A','B','C,' dd'] !! !!##USAGE NOTES !! When invoking the program line note the (subject to change) !! following restrictions (which often differ between various !! command-line parsers): !! !! o values for duplicate keywords are appended together with a space !! separator when a command line is executed by default. !! !! o shuffling is not supported. Values immediately follow their !! keywords. !! !! o Only short Boolean keywords can be bundled together. !! If allowing bundling is desired call "set_mode('strict')". !! This will require prefixing long names with "--" and short !! names with "-". Otherwise M_CLI2 relaxes that requirement !! and mostly does not care what prefix is used for a keyword. !! But this would make it unclear what was meant by "-ox" if !! allowed options were "-o F -x F --ox F " for example, so !! "strict" mode is required to remove the ambiguity. !! !! o if a parameter value of just "-" is supplied it is !! converted to the string "stdin". !! !! o values not needed for a keyword value go into the character !! array "UNNAMED". !! !! In addition if the keyword "--" is encountered on the command !! line the rest of the command line goes into the character array !! "UNNAMED". !! !!##EXAMPLE !! !! !! Sample program: !! !! program demo_set_args !! use M_CLI2, only : filenames=>unnamed, set_args, get_args !! use M_CLI2, only : get_args_fixed_size !! implicit none !! integer :: i !! ! DEFINE ARGS !! real :: x, y, z !! real :: p(3) !! character(len=:),allocatable :: title !! logical :: l, lbig !! integer,allocatable :: ints(:) !! ! !! ! DEFINE COMMAND (TO SET INITIAL VALUES AND ALLOWED KEYWORDS) !! ! AND READ COMMAND LINE !! call set_args(' & !! ! reals !! & -x 1 -y 2.3 -z 3.4e2 & !! ! integer array !! & -p -1,-2,-3 & !! ! always double-quote strings !! & --title "my title" & !! ! string should be a single character at a minimum !! & --label " ", & !! ! set all logical values to F !! & -l F -L F & !! ! set allocatable size to zero if you like by using a delimiter !! & --ints , & !! & ') !! ! ASSIGN VALUES TO ELEMENTS !! ! SCALARS !! call get_args('x',x) !! call get_args('y',y) !! call get_args('z',z) !! call get_args('l',l) !! call get_args('L',lbig) !! call get_args('ints',ints) ! ALLOCATABLE ARRAY !! call get_args('title',title) ! ALLOCATABLE STRING !! call get_args_fixed_size('p',p) ! NON-ALLOCATABLE ARRAY !! ! USE VALUES !! write(*,*)'x=',x !! write(*,*)'y=',y !! write(*,*)'z=',z !! write(*,*)'p=',p !! write(*,*)'title=',title !! write(*,*)'ints=',ints !! write(*,*)'l=',l !! write(*,*)'L=',lbig !! ! UNNAMED VALUES !! if(size(filenames) > 0)then !! write(*,'(i6.6,3a)')(i,'[',filenames(i),']',i=1,size(filenames)) !! endif !! end program demo_set_args !! !!##RESPONSE FILES !! !! If you have no interest in using external files as abbreviations !! you can ignore this section. Otherwise, before calling set_args(3f) !! add: !! !! use M_CLI2, only : set_mode !! call set_mode('response_file') !! !! M_CLI2 Response files are small files containing CLI (Command Line !! Interface) arguments that end with ".rsp" that can be used when command !! lines are so long that they would exceed line length limits or so complex !! that it is useful to have a platform-independent method of creating !! an abbreviation. !! !! Shell aliases and scripts are often used for similar purposes (and !! allow for much more complex conditional execution, of course), but !! they generally cannot be used to overcome line length limits and are !! typically platform-specific. !! !! Examples of commands that support similar response files are the Clang !! and Intel compilers, although there is no standard format for the files. !! !! They are read if you add options of the syntax "@NAME" as the FIRST !! parameters on your program command line calls. They are not recursive -- !! that is, an option in a response file cannot be given the value "@NAME2" !! to call another response file. !! !! More than one response name may appear on a command line. !! !! They are case-sensitive names. !! !! Note "@" s a special character in Powershell, and requires being escaped !! with a grave character. !! !! LOCATING RESPONSE FILES !! !! A search for the response file always starts with the current directory. !! The search then proceeds to look in any additional directories specified !! with the colon-delimited environment variable CLI_RESPONSE_PATH. !! !! The first resource file found that results in lines being processed !! will be used and processing stops after that first match is found. If !! no match is found an error occurs and the program is stopped. !! !! RESPONSE FILE SECTIONS !! !! A simple response file just has options for calling the program in it !! prefixed with the word "options". !! But they can also contain section headers to denote selections that are !! only executed when a specific OS is being used, print messages, and !! execute system commands. !! !! SEARCHING FOR OSTYPE IN REGULAR FILES !! !! So assuming the name @NAME was specified on the command line a file !! named NAME.rsp will be searched for in all the search directories !! and then in that file a string that starts with the string @OSTYPE !! (if the environment variables $OS and $OSTYPE are not blank. $OSTYPE !! takes precedence over $OS). !! !! SEARCHING FOR UNLABELED DIRECTIVES IN REGULAR FILES !! !! Then, the same files will be searched for lines above any line starting !! with "@". That is, if there is no special section for the current OS !! it just looks at the top of the file for unlabeled options. !! !! SEARCHING FOR OSTYPE AND NAME IN THE COMPOUND FILE !! !! In addition or instead of files with the same name as the @NAME option !! on the command line, you can have one file named after the executable !! name that contains multiple abbreviation names. !! !! So if your program executable is named EXEC you create a single file !! called EXEC.rsp and can append all the simple files described above !! separating them with lines of the form @OSTYPE@NAME or just @NAME. !! !! So if no specific file for the abbreviation is found a file called !! "EXEC.rsp" is searched for where "EXEC" is the name of the executable. !! This file is always a "compound" response file that uses the following format: !! !! Any compound EXEC.rsp file found in the current or searched directories !! will be searched for the string @OSTYPE@NAME first. !! !! Then if nothing is found, the less specific line @NAME is searched for. !! !! THE SEARCH IS OVER !! !! Sounds complicated but actually works quite intuitively. Make a file in !! the current directory and put options in it and it will be used. If that !! file ends up needing different cases for different platforms add a line !! like "@Linux" to the file and some more lines and that will only be !! executed if the environment variable OSTYPE or OS is "Linux". If no match !! is found for named sections the lines at the top before any "@" lines !! will be used as a default if no match is found. !! !! If you end up using a lot of files like this you can combine them all !! together and put them into a file called "program_name".rsp and just !! put lines like @NAME or @OSTYPE@NAME at that top of each selection. !! !! Now, back to the details on just what you can put in the files. !! !!##SPECIFICATION FOR RESPONSE FILES !! !! SIMPLE RESPONSE FILES !! !! The first word of a line is special and has the following meanings: !! !! options|- Command options following the rules of the SET_ARGS(3f) !! prototype. So !! o It is preferred to specify a value for all options. !! o double-quote strings. !! o give a blank string value as " ". !! o use F|T for lists of logicals, !! o lists of numbers should be comma-delimited. !! o --usage, --help, --version, --verbose, and unknown !! options are ignored. !! !! comment|# Line is a comment line !! system|! System command. !! System commands are executed as a simple call to !! system (so a cd(1) or setting a shell variable !! would not effect subsequent lines, for example) !! BEFORE the command being processed. !! print|> Message to screen !! stop display message and stop program. !! !! NOTE: system commands are executed when encountered, but options are !! gathered from multiple option lines and passed together at the end of !! processing of the block; so all commands will be executed BEFORE the !! command for which options are being supplied no matter where they occur. !! !! So if a program that does nothing but echos its parameters !! !! program testit !! use M_CLI2, only : set_args, rget, sget, lget, set_mode !! implicit none !! real :: x,y ; namelist/args/ x,y !! character(len=:),allocatable :: title ; namelist/args/ title !! logical :: big ; namelist/args/ big !! call set_mode('response_file') !! call set_args('-x 10.0 -y 20.0 --title "my title" --big F') !! x=rget('x') !! y=rget('y') !! title=sget('title') !! big=lget('big') !! write(*,nml=args) !! end program testit !! !! And a file in the current directory called "a.rsp" contains !! !! # defaults for project A !! options -x 1000 -y 9999 !! options --title " " !! options --big T !! !! The program could be called with !! !! $myprog # normal call !! X=10.0 Y=20.0 TITLE="my title" !! !! $myprog @a # change defaults as specified in "a.rsp" !! X=1000.0 Y=9999.0 TITLE=" " !! !! # change defaults but use any option as normal to override defaults !! $myprog @a -y 1234 !! X=1000.0 Y=1234.0 TITLE=" " !! !! COMPOUND RESPONSE FILES !! !! A compound response file has the same basename as the executable with a !! ".rsp" suffix added. So if your program is named "myprg" the filename !! must be "myprg.rsp". !! !! Note that here `basename` means the last leaf of the !! name of the program as returned by the Fortran intrinsic !! GET_COMMAND_ARGUMENT(0,...) trimmed of anything after a period ("."), !! so it is a good idea not to use hidden files. !! !! Unlike simple response files compound response files can contain multiple !! setting names. !! !! Specifically in a compound file !! if the environment variable $OSTYPE (first) or $OS is set the first search !! will be for a line of the form (no leading spaces should be used): !! !! @OSTYPE@alias_name !! !! If no match or if the environment variables $OSTYPE and $OS were not !! set or a match is not found then a line of the form !! !! @alias_name !! !! is searched for in simple or compound files. If found subsequent lines !! will be ignored that start with "@" until a line not starting with !! "@" is encountered. Lines will then be processed until another line !! starting with "@" is found or end-of-file is encountered. !! !! COMPOUND RESPONSE FILE EXAMPLE !! An example compound file !! !! ################# !! @if !! > RUNNING TESTS USING RELEASE VERSION AND ifort !! options test --release --compiler ifort !! ################# !! @gf !! > RUNNING TESTS USING RELEASE VERSION AND gfortran !! options test --release --compiler gfortran !! ################# !! @nv !! > RUNNING TESTS USING RELEASE VERSION AND nvfortran !! options test --release --compiler nvfortran !! ################# !! @nag !! > RUNNING TESTS USING RELEASE VERSION AND nagfor !! options test --release --compiler nagfor !! # !! ################# !! # OS-specific example: !! @Linux@install !! # !! # install executables in directory (assuming install(1) exists) !! # !! system mkdir -p ~/.local/bin !! options run --release T --runner "install -vbp -m 0711 -t ~/.local/bin" !! @install !! STOP INSTALL NOT SUPPORTED ON THIS PLATFORM OR $OSTYPE NOT SET !! # !! ################# !! @fpm@testall !! # !! !fpm test --compiler nvfortran !! !fpm test --compiler ifort !! !fpm test --compiler gfortran !! !fpm test --compiler nagfor !! STOP tests complete. Any additional parameters were ignored !! ################# !! !! Would be used like !! !! fpm @install !! fpm @nag -- !! fpm @testall !! !! NOTES !! !! The intel Fortran compiler now calls the response files "indirect !! files" and does not add the implied suffix ".rsp" to the files !! anymore. It also allows the @NAME syntax anywhere on the command line, !! not just at the beginning. -- 20201212 !! !!##AUTHOR !! John S. Urban, 2019 !! !!##LICENSE !! Public Domain !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== subroutine set_args(prototype,help_text,version_text,string,prefix,ierr,errmsg) ! ident_1="@(#) M_CLI2 set_args(3f) parse prototype string" character(len=*),intent(in) :: prototype character(len=*),intent(in),optional :: help_text(:) character(len=*),intent(in),optional :: version_text(:) character(len=*),intent(in),optional :: string character(len=*),intent(in),optional :: prefix integer,intent(out),optional :: ierr character(len=:),intent(out),allocatable,optional :: errmsg character(len=:),allocatable :: hold ! stores command line argument integer :: ibig character(len=:),allocatable :: debug_mode debug_mode= upper(get_env('CLI_DEBUG_MODE','FALSE'))//' ' select case(debug_mode(1:1)) case('Y','T') G_DEBUG=.true. end select G_response=CLI_RESPONSE_FILE G_options_only=.false. G_passed_in='' G_STOP=0 G_STOP_MESSAGE='' if(present(prefix))then G_PREFIX=prefix else G_PREFIX='' endif if(present(ierr))then G_QUIET=.true. else G_QUIET=.false. endif ibig=longest_command_argument() ! bug in gfortran. len=0 should be fine IF(ALLOCATED(UNNAMED)) DEALLOCATE(UNNAMED) ALLOCATE(CHARACTER(LEN=IBIG) :: UNNAMED(0)) if(allocated(args)) deallocate(args) allocate(character(len=ibig) :: args(0)) call wipe_dictionary() hold='--version F --usage F --help F --version F '//adjustl(prototype) call prototype_and_cmd_args_to_nlist(hold,string) if(allocated(G_RESPONSE_IGNORED))then if(G_DEBUG)write(*,gen)'SET_ARGS:G_RESPONSE_IGNORED:',G_RESPONSE_IGNORED if(size(unnamed) /= 0)write(*,*)'LOGIC ERROR' call split(G_RESPONSE_IGNORED,unnamed) endif if(.not.allocated(unnamed))then allocate(character(len=0) :: unnamed(0)) endif if(.not.allocated(args))then allocate(character(len=0) :: args(0)) endif call check_commandline(help_text,version_text) ! process --help, --version, --usage if(present(ierr))then ierr=G_STOP endif if(present(errmsg))then errmsg=G_STOP_MESSAGE endif end subroutine set_args !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! get_subcommand(3f) - [ARGUMENTS:M_CLI2] special-case routine for !! handling subcommands on a command line !! (LICENSE:PD) !! !!##SYNOPSIS !! !! function get_subcommand() !! !! character(len=:),allocatable :: get_subcommand !! !!##DESCRIPTION !! In the special case when creating a program with subcommands it !! is assumed the first word on the command line is the subcommand. A !! routine is required to handle response file processing, therefore !! this routine (optionally processing response files) returns that !! first word as the subcommand name. !! !! It should not be used by programs not building a more elaborate !! command with subcommands. !! !!##RETURNS !! NAME name of subcommand !! !!##EXAMPLE !! !! Sample program: !! !! program demo_get_subcommand !! !x! SUBCOMMANDS !! !x! For a command with subcommands like git(1) !! !x! you can make separate namelists for each subcommand. !! !x! You can call this program which has two subcommands (run, test), !! !x! like this: !! !x! demo_get_subcommand --help !! !x! demo_get_subcommand run -x -y -z --title -l -L !! !x! demo_get_subcommand test --title -l -L --testname !! !x! demo_get_subcommand run --help !! implicit none !! !x! DEFINE VALUES TO USE AS ARGUMENTS WITH INITIAL VALUES !! real :: x=-999.0,y=-999.0,z=-999.0 !! character(len=80) :: title="not set" !! logical :: l=.false. !! logical :: l_=.false. !! character(len=80) :: testname="not set" !! character(len=20) :: name !! call parse(name) !x! DEFINE AND PARSE COMMAND LINE !! !x! ALL DONE CRACKING THE COMMAND LINE. !! !x! USE THE VALUES IN YOUR PROGRAM. !! write(*,*)'command was ',name !! write(*,*)'x,y,z .... ',x,y,z !! write(*,*)'title .... ',title !! write(*,*)'l,l_ ..... ',l,l_ !! write(*,*)'testname . ',testname !! contains !! subroutine parse(name) !! !x! PUT EVERYTHING TO DO WITH COMMAND PARSING HERE FOR CLARITY !! use M_CLI2, only : set_args, get_args, get_args_fixed_length !! use M_CLI2, only : get_subcommand, set_mode !! character(len=*) :: name ! the subcommand name !! character(len=:),allocatable :: help_text(:), version_text(:) !! call set_mode('response_file') !! ! define version text !! version_text=[character(len=80) :: & !! '@(#)PROGRAM: demo_get_subcommand >', & !! '@(#)DESCRIPTION: My demo program >', & !! '@(#)VERSION: 1.0 20200715 >', & !! '@(#)AUTHOR: me, myself, and I>', & !! '@(#)LICENSE: Public Domain >', & !! '' ] !! ! general help for "demo_get_subcommand --help" !! help_text=[character(len=80) :: & !! ' allowed subcommands are ', & !! ' * run -l -L --title -x -y -z ', & !! ' * test -l -L --title ', & !! '' ] !! ! find the subcommand name by looking for first word on command !! ! not starting with dash !! name = get_subcommand() !! select case(name) !! case('run') !! help_text=[character(len=80) :: & !! ' ', & !! ' Help for subcommand "run" ', & !! ' ', & !! '' ] !! call set_args( & !! & '-x 1 -y 2 -z 3 --title "my title" -l F -L F',& !! & help_text,version_text) !! call get_args('x',x) !! call get_args('y',y) !! call get_args('z',z) !! call get_args_fixed_length('title',title) !! call get_args('l',l) !! call get_args('L',l_) !! case('test') !! help_text=[character(len=80) :: & !! ' ', & !! ' Help for subcommand "test" ', & !! ' ', & !! '' ] !! call set_args(& !! & '--title "my title" -l F -L F --testname "Test"',& !! & help_text,version_text) !! call get_args_fixed_length('title',title) !! call get_args('l',l) !! call get_args('L',l_) !! call get_args_fixed_length('testname',testname) !! case default !! ! process help and version !! call set_args(' ',help_text,version_text) !! write(*,'(*(a))')'unknown or missing subcommand [',trim(name),']' !! write(*,'(a)')[character(len=80) :: & !! ' allowed subcommands are ', & !! ' * run -l -L -title -x -y -z ', & !! ' * test -l -L -title ', & !! '' ] !! stop !! end select !! end subroutine parse !! end program demo_get_subcommand !! !!##AUTHOR !! John S. Urban, 2019 !! !!##LICENSE !! Public Domain !=================================================================================================================================== function get_subcommand() result(sub) ! ident_2="@(#) M_CLI2 get_subcommand(3f) parse prototype string to get subcommand allowing for response files" character(len=:),allocatable :: sub character(len=:),allocatable :: cmdarg character(len=:),allocatable :: array(:) character(len=:),allocatable :: prototype integer :: ilongest integer :: i integer :: j G_subcommand='' G_options_only=.true. sub='' if(.not.allocated(unnamed))then allocate(character(len=0) :: unnamed(0)) endif ilongest=longest_command_argument() allocate(character(len=max(63,ilongest)):: cmdarg) cmdarg(:) = '' ! look for @NAME if CLI_RESPONSE_FILE=.TRUE. AND LOAD THEM do i = 1, command_argument_count() call get_command_argument(i, cmdarg) if(scan(adjustl(cmdarg(1:1)),'@') == 1)then call get_prototype(cmdarg,prototype) call split(prototype,array) ! assume that if using subcommands first word not starting with dash is the subcommand do j=1,size(array) if(adjustl(array(j)(1:1)) /= '-')then G_subcommand=trim(array(j)) sub=G_subcommand exit endif enddo endif enddo if(G_subcommand /= '')then sub=G_subcommand elseif(size(unnamed) /= 0)then sub=unnamed(1) else cmdarg(:) = '' do i = 1, command_argument_count() call get_command_argument(i, cmdarg) if(adjustl(cmdarg(1:1)) /= '-')then sub=trim(cmdarg) exit endif enddo endif G_options_only=.false. end function get_subcommand !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! set_usage(3f) - [ARGUMENTS:M_CLI2] allow setting a short description !! for keywords for the --usage switch !! (LICENSE:PD) !! !!##SYNOPSIS !! !! subroutine set_usage(keyword,description) !! !! character(len=*),intent(in) :: keyword !! character(len=*),intent(in) :: description !! !!##DESCRIPTION !! !!##OPTIONS !! KEYWORD the name of a command keyword !! DESCRIPTION a brief one-line description of the keyword !! !! !!##EXAMPLE !! !! sample program: !! !! Results: !! !!##AUTHOR !! John S. Urban, 2019 !!##LICENSE !! Public Domain !=================================================================================================================================== subroutine set_usage(keyword,description,value) character(len=*),intent(in) :: keyword character(len=*),intent(in) :: description character(len=*),intent(in) :: value write(*,*)keyword write(*,*)description write(*,*)value ! store the descriptions in an array and then apply them when set_args(3f) is called. ! alternatively, could allow for a value as well in lieu of the prototype end subroutine set_usage !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! prototype_to_dictionary(3f) - [ARGUMENTS:M_CLI2] parse user command !! and store tokens into dictionary !! (LICENSE:PD) !! !!##SYNOPSIS !! !! recursive subroutine prototype_to_dictionary(string) !! !! character(len=*),intent(in) :: string !! !!##DESCRIPTION !! given a string of form !! !! -var value -var value !! !! define dictionary of form !! !! keyword(i), value(i) !! !! o string values !! !! o must be delimited with double quotes. !! o adjacent double quotes put one double quote into value !! o must not be null. A blank is specified as " ", not "". !! !! o logical values !! !! o logical values must have a value. Use F. !! !! o leading and trailing blanks are removed from unquoted values !! !! !!##OPTIONS !! STRING string is character input string to define command !! !!##RETURNS !! !!##EXAMPLE !! !! sample program: !! !! call prototype_to_dictionary(' -l F --ignorecase F --title "my title string" -x 10.20') !! call prototype_to_dictionary(' --ints 1,2,3,4') !! !! Results: !! !!##AUTHOR !! John S. Urban, 2019 !!##LICENSE !! Public Domain !=================================================================================================================================== recursive subroutine prototype_to_dictionary(string) ! ident_3="@(#) M_CLI2 prototype_to_dictionary(3f) parse user command and store tokens into dictionary" character(len=*),intent(in) :: string ! string is character input string of options and values character(len=:),allocatable :: dummy ! working copy of string character(len=:),allocatable :: value character(len=:),allocatable :: keyword character(len=3) :: delmt ! flag if in a delimited string or not character(len=1) :: currnt ! current character being processed character(len=1) :: prev ! character to left of CURRNT character(len=1) :: forwrd ! character to right of CURRNT integer,dimension(2) :: ipnt integer :: islen ! number of characters in input string integer :: ipoint integer :: itype integer,parameter :: VAL=1, KEYW=2 integer :: ifwd integer :: ibegin integer :: iend integer :: place islen=len_trim(string) ! find number of characters in input string if(islen == 0)then ! if input string is blank, even default variable will not be changed return endif dummy=adjustl(string)//' ' keyword="" ! initial variable name value="" ! initial value of a string ipoint=0 ! ipoint is the current character pointer for (dummy) ipnt(2)=2 ! pointer to position in keyword ipnt(1)=1 ! pointer to position in value itype=VAL ! itype=1 for value, itype=2 for variable delmt="off" prev=" " G_keyword_single_letter=.true. do ipoint=ipoint+1 ! move current character pointer forward currnt=dummy(ipoint:ipoint) ! store current character into currnt ifwd=min(ipoint+1,islen) ! ensure not past end of string 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 keyword if(forwrd == '-')then ! change --var to -var so "long" syntax is supported !x!dummy(ifwd:ifwd)='_' ipoint=ipoint+1 ! ignore second - instead (was changing it to _) G_keyword_single_letter=.false. ! flag this is a long keyword else G_keyword_single_letter=.true. ! flag this is a short (single letter) keyword endif if(ipnt(1)-1 >= 1)then ! position in value ibegin=1 iend=len_trim(value(:ipnt(1)-1)) TESTIT: do if(iend == 0)then ! len_trim returned 0, value is blank iend=ibegin exit TESTIT elseif(value(ibegin:ibegin) == " ")then ibegin=ibegin+1 else exit TESTIT endif enddo TESTIT if(keyword /= ' ')then if(value=='[]')value=',' call update(keyword,value) ! store name and its value elseif( G_remaining_option_allowed)then ! meaning "--" has been encountered if(value=='[]')value=',' call update('_args_',trim(value)) else !x!write(warn,'(*(g0))')'*prototype_to_dictionary* warning: ignoring string [',trim(value),'] for ',trim(keyword) G_RESPONSE_IGNORED=TRIM(VALUE) if(G_DEBUG)write(*,gen)'PROTOTYPE_TO_DICTIONARY:G_RESPONSE_IGNORED:',G_RESPONSE_IGNORED endif else call locate_key(keyword,place) if(keyword /= ' '.and.place < 0)then call update(keyword,'F') ! store name and null value (first pass) elseif(keyword /= ' ')then call update(keyword,' ') ! store name and null value (second pass) elseif(.not.G_keyword_single_letter.and.ipoint-2 == islen) then ! -- at end of line G_remaining_option_allowed=.true. ! meaning for "--" is that everything on commandline goes into G_remaining endif endif itype=KEYW ! change to expecting a keyword value="" ! clear value for this variable keyword="" ! clear variable name ipnt(1)=1 ! restart variable value ipnt(2)=1 ! restart variable name else ! currnt is not one of the special characters ! the space after a keyword before the value if(currnt == " " .and. itype == KEYW)then ! switch from building a keyword string to building a value string itype=VAL ! beginning of a delimited value elseif(currnt == """".and.itype == VAL)then ! second of a double quote, put quote in if(prev == """")then if(itype == VAL)then value=value//currnt else keyword=keyword//currnt endif ipnt(itype)=ipnt(itype)+1 delmt="on" elseif(delmt == "on")then ! first quote of a delimited string delmt="off" else delmt="on" endif if(prev /= """")then ! leave quotes where found them if(itype == VAL)then value=value//currnt else keyword=keyword//currnt endif ipnt(itype)=ipnt(itype)+1 endif else ! add character to current keyword or value if(itype == VAL)then value=value//currnt else keyword=keyword//currnt endif ipnt(itype)=ipnt(itype)+1 endif endif prev=currnt if(ipoint <= islen)then cycle else exit endif enddo end subroutine prototype_to_dictionary !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()= !=================================================================================================================================== !> !!##NAME !! specified(3f) - [ARGUMENTS:M_CLI2] return true if keyword was present !! on command line !! (LICENSE:PD) !! !!##SYNOPSIS !! !! elemental impure function specified(name) !! !! character(len=*),intent(in) :: name !! logical :: specified !! !!##DESCRIPTION !! !! specified(3f) returns .true. if the specified keyword was present on !! the command line. !! !! M_CLI2 intentionally does not have validators except for SPECIFIED(3f) !! and of course a check whether the input conforms to the type when !! requesting a value (with get_args(3f) or the convenience functions !! like inum(3f)). !! !! Fortran already has powerful validation capabilities. Logical !! expressions ANY(3f) and ALL(3f) are standard Fortran features which !! easily allow performing the common validations for command line !! arguments without having to learn any additional syntax or methods. !! !!##OPTIONS !! !! NAME name of commandline argument to query the presence of. Long !! names should always be used. !! !!##RETURNS !! SPECIFIED returns .TRUE. if specified NAME was present on the command !! line when the program was invoked. !! !!##EXAMPLE !! !! Sample program: !! !! program demo_specified !! use, intrinsic :: iso_fortran_env, only : & !! & stderr=>ERROR_UNIT, stdin=>INPUT_UNIT, stdout=>OUTPUT_UNIT !! use M_CLI2, only : set_args, igets, rgets, specified, sget, lget !! implicit none !! !! ! Define args !! integer,allocatable :: ints(:) !! real,allocatable :: floats(:) !! logical :: flag !! character(len=:),allocatable :: color !! character(len=:),allocatable :: list(:) !! integer :: i !! !! call set_args('& !! & --color:c "red" & !! & --flag:f F & !! & --ints:i 1,10,11 & !! & --floats:T 12.3, 4.56 & !! & ') !! ints=igets('ints') !! floats=rgets('floats') !! flag=lget('flag') !! color=sget('color') !! !! write(*,*)'color=',color !! write(*,*)'flag=',flag !! write(*,*)'ints=',ints !! write(*,*)'floats=',floats !! !! write(*,*)'was -flag specified?',specified('flag') !! !! ! elemental !! write(*,*)specified(['floats','ints ']) !! !! ! If you want to know if groups of parameters were specified use !! ! ANY(3f) and ALL(3f) !! write(*,*)'ANY:',any(specified(['floats','ints '])) !! write(*,*)'ALL:',all(specified(['floats','ints '])) !! !! ! For mutually exclusive !! if (all(specified(['floats','ints '])))then !! write(*,*)'You specified both names --ints and --floats' !! endif !! !! ! For required parameter !! if (.not.any(specified(['floats','ints '])))then !! write(*,*)'You must specify --ints or --floats' !! endif !! !! ! check if all values are in range from 10 to 30 and even !! write(*,*)'are all numbers good?',all([ints>=10,ints<= 30,(ints/2)*2==ints]) !! !! ! perhaps you want to check one value at a time !! do i=1,size(ints) !! write(*,*)ints(i),[ints(i) >= 10,ints(i) <= 30,(ints(i)/2)*2 == ints(i)] !! if(all([ints(i) >= 10,ints(i) <= 30,(ints(i)/2)*2 == ints(i)]) )then !! write(*,*)ints(i),'is an even number from 10 to 30 inclusive' !! else !! write(*,*)ints(i),'is not an even number from 10 to 30 inclusive' !! endif !! enddo !! !! list = [character(len=10) :: 'red','white','blue'] !! if( any(color == list) )then !! write(*,*)color,'matches a value in the list' !! else !! write(*,*)color,'not in the list' !! endif !! !! if(size(ints).eq.3)then !! write(*,*)'ints(:) has expected number of values' !! else !! write(*,*)'ints(:) does not have expected number of values' !! endif !! !! end program demo_specified !! !! Default output !! !! > color=red !! > flag= F !! > ints= 1 10 11 !! > floats= 12.3000002 4.55999994 !! > was -flag specified? F !! > F F !! > ANY: F !! > ALL: F !! > You must specify --ints or --floats !! > 1 F T F !! > 1 is not an even number from 10 to 30 inclusive !! > 10 T T T !! > 10 is an even number from 10 to 30 inclusive !! > 11 T T F !! > 11 is not an even number from 10 to 30 inclusive !! > red matches a value in the list !! > ints(:) has expected number of values !! !!##AUTHOR !! John S. Urban, 2019 !!##LICENSE !! Public Domain !=================================================================================================================================== elemental impure function specified(key) character(len=*),intent(in) :: key logical :: specified integer :: place call locate_key(key,place) ! find where string is or should be if(place < 1)then specified=.false. else specified=present_in(place) endif end function specified !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()= !=================================================================================================================================== !> !!##NAME !! update(3f) - [ARGUMENTS:M_CLI2] update internal dictionary given !! keyword and value !! (LICENSE:PD) !!##SYNOPSIS !! !! subroutine update(key,val) !! !! character(len=*),intent(in) :: key !! character(len=*),intent(in),optional :: val !!##DESCRIPTION !! Update internal dictionary in M_CLI2(3fm) module. !!##OPTIONS !! key name of keyword to add, replace, or delete from dictionary !! val if present add or replace value associated with keyword. If not !! present remove keyword entry from dictionary. !! !! If "present" is true, a value will be appended !!##EXAMPLE !! !! !!##AUTHOR !! John S. Urban, 2019 !!##LICENSE !! Public Domain !=================================================================================================================================== subroutine update(key,val) character(len=*),intent(in) :: key character(len=*),intent(in),optional :: val integer :: place, ii integer :: iilen character(len=:),allocatable :: val_local character(len=:),allocatable :: short character(len=:),allocatable :: long character(len=:),allocatable :: long_short(:) integer :: isize logical :: set_mandatory set_mandatory=.false. if(G_IGNOREALLCASE) then call split(lower(trim(key)),long_short,':',nulls='return') ! split long:short keyword or long:short:: or long:: or short:: else call split(trim(key),long_short,':',nulls='return') ! split long:short keyword or long:short:: or long:: or short:: endif ! check for :: on end isize=size(long_short) if(isize > 0)then ! very special-purpose syntax where if ends in :: next field is a value even if(long_short(isize) == '')then ! if it starts with a dash, for --flags option on fpm(1). set_mandatory=.true. long_short=long_short(:isize-1) endif endif select case(size(long_short)) case(0) long='' short='' case(1) long=trim(long_short(1)) if(len_trim(long) == 1)then !x!ii= findloc (shorts, long, dim=1) ! if parsing arguments on line and a short keyword look up long value ii=maxloc([0,merge(1, 0, shorts == long)],dim=1) if(ii > 1)then long=keywords(ii-1) endif short=long else short='' endif case(2) long=trim(long_short(1)) short=trim(long_short(2)) case default write(warn,*)'WARNING: incorrect syntax for key: ',trim(key) long=trim(long_short(1)) short=trim(long_short(2)) end select if(G_UNDERDASH) long=replace_str(long,'-','_') if(G_NODASHUNDER)then long=replace_str(long,'-','') long=replace_str(long,'_','') endif if(G_IGNORELONGCASE.and.len_trim(long) > 1)long=lower(long) if(present(val))then val_local=val iilen=len_trim(val_local) call locate_key(long,place) ! find where string is or should be if(place < 1)then ! if string was not found insert it call insert_(keywords,long,iabs(place)) call insert_(values,val_local,iabs(place)) call insert_(counts,iilen,iabs(place)) call insert_(shorts,short,iabs(place)) call insert_(present_in,.true.,iabs(place)) call insert_(mandatory,set_mandatory,iabs(place)) else if(present_in(place))then ! if multiple keywords append values with space between them if(G_append)then if(values(place)(1:1) == '"')then ! UNDESIRABLE: will ignore previous blank entries val_local='"'//trim(unquote(values(place)))//' '//trim(unquote(val_local))//'"' else val_local=clipends(values(place))//' '//val_local endif endif iilen=len_trim(val_local) endif call replace_(values,val_local,place) call replace_(counts,iilen,place) call replace_(present_in,.true.,place) endif else ! if no value is present remove the keyword and related values call locate_key(long,place) ! check name as long and short if(place > 0)then call remove_(keywords,place) call remove_(values,place) call remove_(counts,place) call remove_(shorts,place) call remove_(present_in,place) call remove_(mandatory,place) endif endif end subroutine update !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! wipe_dictionary(3fp) - [ARGUMENTS:M_CLI2] reset private M_CLI2(3fm) !! dictionary to empty !! (LICENSE:PD) !!##SYNOPSIS !! !! subroutine wipe_dictionary() !!##DESCRIPTION !! reset private M_CLI2(3fm) dictionary to empty !!##EXAMPLE !! !! Sample program: !! !! program demo_wipe_dictionary !! use M_CLI2, only : dictionary !! call wipe_dictionary() !! end program demo_wipe_dictionary !!##AUTHOR !! John S. Urban, 2019 !!##LICENSE !! Public Domain !=================================================================================================================================== subroutine wipe_dictionary() if(allocated(keywords))deallocate(keywords) allocate(character(len=0) :: keywords(0)) if(allocated(values))deallocate(values) allocate(character(len=0) :: values(0)) if(allocated(counts))deallocate(counts) allocate(counts(0)) if(allocated(shorts))deallocate(shorts) allocate(character(len=0) :: shorts(0)) if(allocated(present_in))deallocate(present_in) allocate(present_in(0)) if(allocated(mandatory))deallocate(mandatory) allocate(mandatory(0)) end subroutine wipe_dictionary !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! get(3f) - [ARGUMENTS:M_CLI2] get dictionary value associated with !! key name in private M_CLI2(3fm) dictionary !!##SYNOPSIS !! !! !!##DESCRIPTION !! Get dictionary value associated with key name in private M_CLI2(3fm) !! dictionary. !!##OPTIONS !!##RETURNS !!##EXAMPLE !! !=================================================================================================================================== function get(key) result(valout) character(len=*),intent(in) :: key character(len=:),allocatable :: valout integer :: place ! find where string is or should be call locate_key(key,place) if(place < 1)then valout='' else valout=values(place)(:counts(place)) endif end function get !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! prototype_and_cmd_args_to_nlist(3f) - [ARGUMENTS:M_CLI2] convert !! Unix-like command arguments to table !! (LICENSE:PD) !!##SYNOPSIS !! !! subroutine prototype_and_cmd_args_to_nlist(prototype) !! !! character(len=*) :: prototype !!##DESCRIPTION !! create dictionary with character keywords, values, and value lengths !! using the routines for maintaining a list from command line arguments. !!##OPTIONS !! prototype !!##EXAMPLE !! !! Sample program !! !! program demo_prototype_and_cmd_args_to_nlist !! use M_CLI2, only : prototype_and_cmd_args_to_nlist, unnamed !! implicit none !! character(len=:),allocatable :: readme !! character(len=256) :: message !! integer :: ios !! integer :: i !! doubleprecision :: something !! !! ! define arguments !! logical :: l,h,v !! real :: p(2) !! complex :: c !! doubleprecision :: x,y,z !! !! ! uppercase keywords get an underscore to make it easier to remember !! logical :: l_,h_,v_ !! ! character variables must be long enough to hold returned value !! character(len=256) :: a_,b_ !! integer :: c_(3) !! !! ! give command template with default values !! ! all values except logicals get a value. !! ! strings must be delimited with double quotes !! ! A string has to have at least one character as for -A !! ! lists of numbers should be comma-delimited. !! ! No spaces are allowed in lists of numbers !! call prototype_and_cmd_args_to_nlist('& !! & -l -v -h -LVH -x 0 -y 0.0 -z 0.0d0 -p 0,0 & !! & -A " " -B "Value B" -C 10,20,30 -c (-123,-456)',readme) !! !! call get_args('x',x,'y',y,'z',z) !! something=sqrt(x**2+y**2+z**2) !! write (*,*)something,x,y,z !! if(size(unnamed) > 0)then !! write (*,'(a)')'files:' !! write (*,'(i6.6,3a)')(i,'[',unnamed(i),']',i=1,size(unnamed)) !! endif !! end program demo_prototype_and_cmd_args_to_nlist !!##AUTHOR !! John S. Urban, 2019 !!##LICENSE !! Public Domain !=================================================================================================================================== subroutine prototype_and_cmd_args_to_nlist(prototype,string) ! ident_4="@(#) M_CLI2 prototype_and_cmd_args_to_nlist create dictionary from prototype if not null and update from command line" character(len=*),intent(in) :: prototype character(len=*),intent(in),optional :: string integer :: ibig integer :: itrim integer :: iused if(G_DEBUG)write(*,gen)'CMD_ARGS_TO_NLIST:START' G_passed_in=prototype ! make global copy for printing ibig=longest_command_argument() ! bug in gfortran. len=0 should be fine ibig=max(ibig,1) IF(ALLOCATED(UNNAMED))DEALLOCATE(UNNAMED) ALLOCATE(CHARACTER(LEN=IBIG) :: UNNAMED(0)) if(allocated(args))deallocate(args) allocate(character(len=ibig) :: args(0)) G_remaining_option_allowed=.false. G_remaining_on=.false. G_remaining='' if(prototype /= '')then call prototype_to_dictionary(prototype) ! build dictionary from prototype ! if short keywords not used by user allow them for standard options call locate_key('h',iused) if(iused <= 0)then call update('help') call update('help:h','F') endif call locate_key('v',iused) if(iused <= 0)then call update('version') call update('version:v','F') endif call locate_key('V',iused) if(iused <= 0)then call update('verbose') call update('verbose:V','F') endif call locate_key('u',iused) if(iused <= 0)then call update('usage') call update('usage:u','F') endif present_in=.false. ! reset all values to false so everything gets written endif if(present(string))then ! instead of command line arguments use another prototype string if(G_DEBUG)write(*,gen)'CMD_ARGS_TO_NLIST:CALL PROTOTYPE_TO_DICTIONARY:STRING=',STRING call prototype_to_dictionary(string) ! build dictionary from prototype else if(G_DEBUG)write(*,gen)'CMD_ARGS_TO_NLIST:CALL CMD_ARGS_TO_DICTIONARY:CHECK=',.true. call cmd_args_to_dictionary() endif if( len(G_remaining) > 1)then ! if -- was in prototype then after -- on input return rest in this string itrim=len(G_remaining) if(G_remaining(itrim:itrim) == ' ')then ! was adding a space at end as building it, but do not want to remove blanks G_remaining=G_remaining(:itrim-1) endif remaining=G_remaining endif if(G_DEBUG)write(*,gen)'CMD_ARGS_TO_NLIST:NORMAL END' end subroutine prototype_and_cmd_args_to_nlist !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== subroutine expand_response(name) character(len=*),intent(in) :: name character(len=:),allocatable :: prototype logical :: hold if(G_DEBUG)write(*,gen)'EXPAND_RESPONSE:START:NAME=',name call get_prototype(name,prototype) if(prototype /= '')then hold=G_append G_append=.false. if(G_DEBUG)write(*,gen)'EXPAND_RESPONSE:CALL PROTOTYPE_TO_DICTIONARY:PROTOTYPE=',prototype call prototype_to_dictionary(prototype) ! build dictionary from prototype G_append=hold endif if(G_DEBUG)write(*,gen)'EXPAND_RESPONSE:END' end subroutine expand_response !=================================================================================================================================== subroutine get_prototype(name,prototype) ! process @name abbreviations character(len=*),intent(in) :: name character(len=:),allocatable,intent(out) :: prototype character(len=:),allocatable :: filename character(len=:),allocatable :: os character(len=:),allocatable :: plain_name character(len=:),allocatable :: search_for integer :: lun integer :: ios integer :: itrim character(len=4096) :: line !x! assuming input never this long character(len=256) :: message character(len=:),allocatable :: array(:) ! output array of tokens integer :: lines_processed lines_processed=0 plain_name=name//' ' plain_name=trim(name(2:)) os= '@' // get_env('OSTYPE',get_env('OS')) if(G_DEBUG)write(*,gen)'GET_PROTOTYPE:OS=',OS search_for='' ! look for NAME.rsp and see if there is an @OS section in it and position to it and read if(os /= '@')then search_for=os call find_and_read_response_file(plain_name) if(lines_processed /= 0)return endif ! look for NAME.rsp and see if there is anything before an OS-specific section search_for='' call find_and_read_response_file(plain_name) if(lines_processed /= 0)return ! look for ARG0.rsp with @OS@NAME section in it and position to it if(os /= '@')then search_for=os//name call find_and_read_response_file(basename(get_name(),suffix=.false.)) if(lines_processed /= 0)return endif ! look for ARG0.rsp with a section called @NAME in it and position to it search_for=name call find_and_read_response_file(basename(get_name(),suffix=.false.)) if(lines_processed /= 0)return write(*,gen)' response name ['//trim(name)//'] not found' stop 1 contains !=================================================================================================================================== subroutine find_and_read_response_file(rname) ! search for a simple file named the same as the @NAME field with one entry assumed in it character(len=*),intent(in) :: rname character(len=:),allocatable :: paths(:) character(len=:),allocatable :: testpath character(len=256) :: message integer :: i integer :: ios prototype='' ! look for NAME.rsp ! assume if have / or \ a full filename was supplied to support ifort(1) if((index(rname,'/') /= 0.or.index(rname,'\') /= 0) .and. len(rname) > 1 )then filename=rname lun=fileopen(filename,message) if(lun /= -1)then call process_response() close(unit=lun,iostat=ios) endif return else filename=rname//'.rsp' endif if(G_DEBUG)write(*,gen)'FIND_AND_READ_RESPONSE_FILE:FILENAME=',filename ! look for name.rsp in directories from environment variable assumed to be a colon-separated list of directories call split(get_env('CLI_RESPONSE_PATH','~/.local/share/rsp'),paths) paths=[character(len=len(paths)) :: ' ',paths] if(G_DEBUG)write(*,gen)'FIND_AND_READ_RESPONSE_FILE:PATHS=',paths do i=1,size(paths) testpath=join_path(paths(i),filename) lun=fileopen(testpath,message) if(lun /= -1)then if(G_DEBUG)write(*,gen)'FIND_AND_READ_RESPONSE_FILE:SEARCH_FOR=',search_for if(search_for /= '') call position_response() ! set to end of file or where string was found call process_response() if(G_DEBUG)write(*,gen)'FIND_AND_READ_RESPONSE_FILE:LINES_PROCESSED=',LINES_PROCESSED close(unit=lun,iostat=ios) if(G_DEBUG)write(*,gen)'FIND_AND_READ_RESPONSE_FILE:CLOSE:LUN=',LUN,' IOSTAT=',IOS if(lines_processed /= 0)exit endif enddo end subroutine find_and_read_response_file !=================================================================================================================================== subroutine position_response() integer :: ios line='' INFINITE: do read(unit=lun,fmt='(a)',iostat=ios,iomsg=message)line if(is_iostat_end(ios))then if(G_DEBUG)write(*,gen)'POSITION_RESPONSE:EOF' backspace(lun,iostat=ios) exit INFINITE elseif(ios /= 0)then write(*,gen)'*position_response*:'//trim(message) exit INFINITE endif line=adjustl(line) if(line == search_for)return enddo INFINITE end subroutine position_response !=================================================================================================================================== subroutine process_response() character(len=:),allocatable :: padded character(len=:),allocatable :: temp line='' lines_processed=0 INFINITE: do read(unit=lun,fmt='(a)',iostat=ios,iomsg=message)line if(is_iostat_end(ios))then backspace(lun,iostat=ios) exit INFINITE elseif(ios /= 0)then write(*,gen)'*process_response*:'//trim(message) exit INFINITE endif line=clipends(line) temp=line if(index(temp//' ','#') == 1)cycle if(temp /= '')then if(index(temp,'@') == 1.and.lines_processed /= 0)exit INFINITE call split(temp,array) ! get first word itrim=len_trim(array(1))+2 temp=temp(itrim:) PROCESS: select case(lower(array(1))) case('comment','#','') case('system','!','$') if(G_options_only)exit PROCESS lines_processed= lines_processed+1 call execute_command_line(temp) case('options','option','-') lines_processed= lines_processed+1 prototype=prototype//' '//trim(temp) case('print','>','echo') if(G_options_only)exit PROCESS lines_processed= lines_processed+1 write(*,'(a)')trim(temp) case('stop') if(G_options_only)exit PROCESS write(*,'(a)')trim(temp) stop case default if(array(1)(1:1) == '-')then ! assume these are simply options to support ifort(1) ! if starts with a single dash must assume a single argument ! and rest is value to support -Dname and -Ifile option ! which currently is not supported, so multiple short keywords ! does not work. Just a ifort(1) test at this point, so do not document if(G_options_only)exit PROCESS padded=trim(line)//' ' if(padded(2:2) == '-')then prototype=prototype//' '//trim(line) else prototype=prototype//' '//padded(1:2)//' '//trim(padded(3:)) endif lines_processed= lines_processed+1 else if(array(1)(1:1) == '@')cycle INFINITE !skip adjacent @ lines from first lines_processed= lines_processed+1 write(*,'(*(g0))')'unknown response keyword [',array(1),'] with options of [',trim(temp),']' endif end select PROCESS endif enddo INFINITE end subroutine process_response end subroutine get_prototype !=================================================================================================================================== function fileopen(filename,message) result(lun) character(len=*),intent(in) :: filename character(len=*),intent(out),optional :: message integer :: lun integer :: ios character(len=256) :: message_local ios=0 message_local='' open(file=filename,newunit=lun,& & form='formatted',access='sequential',action='read',& & position='rewind',status='old',iostat=ios,iomsg=message_local) if(ios /= 0)then lun=-1 if(present(message))then message=trim(message_local) else write(*,gen)trim(message_local) endif endif if(G_DEBUG)write(*,gen)'FILEOPEN:FILENAME=',filename,' LUN=',lun,' IOS=',IOS,' MESSAGE=',trim(message_local) end function fileopen !=================================================================================================================================== function get_env(NAME,DEFAULT) result(VALUE) character(len=*),intent(in) :: NAME character(len=*),intent(in),optional :: DEFAULT character(len=:),allocatable :: VALUE integer :: howbig integer :: stat integer :: length ! get length required to hold value length=0 if(NAME /= '')then call get_environment_variable(NAME, length=howbig,status=stat,trim_name=.true.) select case (stat) case (1) !x!print *, NAME, " is not defined in the environment. Strange..." VALUE='' case (2) !x!print *, "This processor doesn't support environment variables. Boooh!" VALUE='' case default ! make string to hold value of sufficient size if(allocated(value))deallocate(value) allocate(character(len=max(howbig,1)) :: VALUE) ! get value call get_environment_variable(NAME,VALUE,status=stat,trim_name=.true.) if(stat /= 0)VALUE='' end select else VALUE='' endif if(VALUE == ''.and.present(DEFAULT))VALUE=DEFAULT end function get_env !=================================================================================================================================== function join_path(a1,a2,a3,a4,a5) result(path) ! Construct path by joining strings with os file separator ! character(len=*), intent(in) :: a1, a2 character(len=*), intent(in), optional :: a3, a4, a5 character(len=:), allocatable :: path character(len=1) :: filesep filesep = separator() if(a1 /= '')then path = trim(a1) // filesep // trim(a2) else path = trim(a2) endif if (present(a3)) path = path // filesep // trim(a3) if (present(a4)) path = path // filesep // trim(a4) if (present(a5)) path = path // filesep // trim(a5) path=adjustl(path//' ') path=path(1:1)//replace_str(path,filesep//filesep,'') ! some systems allow names starting with '//' or '\\' path=trim(path) end function join_path !=================================================================================================================================== function get_name() result(name) ! get the pathname of arg0 character(len=:),allocatable :: arg0 integer :: arg0_length integer :: istat character(len=4096) :: long_name character(len=:),allocatable :: name arg0_length=0 name='' long_name='' call get_command_argument(0,length=arg0_length,status=istat) if(istat == 0)then if(allocated(arg0))deallocate(arg0) allocate(character(len=arg0_length) :: arg0) call get_command_argument(0,arg0,status=istat) if(istat == 0)then inquire(file=arg0,iostat=istat,name=long_name) name=trim(long_name) else name=arg0 endif endif end function get_name !=================================================================================================================================== function basename(path,suffix) result (base) ! Extract filename from path with/without suffix ! character(*), intent(In) :: path logical, intent(in), optional :: suffix character(:), allocatable :: base character(:), allocatable :: file_parts(:) logical :: with_suffix if (.not.present(suffix)) then with_suffix = .true. else with_suffix = suffix endif if (with_suffix) then call split(path,file_parts,delimiters='\/') if(size(file_parts) > 0)then base = trim(file_parts(size(file_parts))) else base = '' endif else call split(path,file_parts,delimiters='\/.') if(size(file_parts) >= 2)then base = trim(file_parts(size(file_parts)-1)) elseif(size(file_parts) == 1)then base = trim(file_parts(1)) else base = '' endif endif end function basename !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !! !> !!##NAME !! separator(3f) - [M_io:ENVIRONMENT] try to determine pathname directory !! separator character !! (LICENSE:PD) !! !!##SYNOPSIS !! !! !! function separator() result(sep) !! !! character(len=1) :: sep !! !!##DESCRIPTION !! First testing for the existence of "/.", then if that fails a list !! of variable names assumed to contain directory paths {PATH|HOME} are !! examined first for a backslash, then a slash. Assuming basically the !! choice is a ULS or MSWindows system, and users can do weird things like !! put a backslash in a ULS path and break it. !! !! Therefore can be very system dependent. If the queries fail the !! default returned is "/". !! !!##EXAMPLE !! !! !! sample usage !! !! program demo_separator !! use M_io, only : separator !! implicit none !! write(*,*)'separator=',separator() !! end program demo_separator !=================================================================================================================================== function separator() result(sep) ! use the pathname returned as arg0 to determine pathname separator integer :: ios integer :: i logical :: existing=.false. character(len=1) :: sep !x!IFORT BUG:character(len=1),save :: sep_cache=' ' integer,save :: isep=-1 character(len=4096) :: name character(len=:),allocatable :: envnames(:) ! NOTE: A parallel code might theoretically use multiple OS !x!FORT BUG:if(sep_cache /= ' ')then ! use cached value. !x!FORT BUG: sep=sep_cache !x!FORT BUG: return !x!FORT BUG:endif if(isep /= -1)then ! use cached value. sep=char(isep) return endif FOUND: block ! simple, but does not work with ifort ! most MSWindows environments see to work with backslash even when ! using POSIX filenames to do not rely on '\.'. inquire(file='/.',exist=existing,iostat=ios,name=name) if(existing.and.ios == 0)then sep='/' exit FOUND endif ! check variables names common to many platforms that usually have a ! directory path in them although a ULS file can contain a backslash ! and vice-versa (eg. "touch A\\B\\C"). Removed HOMEPATH because it ! returned a name with backslash on CygWin, Mingw, WLS even when using ! POSIX filenames in the environment. envnames=[character(len=10) :: 'PATH', 'HOME'] do i=1,size(envnames) if(index(get_env(envnames(i)),'\') /= 0)then sep='\' exit FOUND elseif(index(get_env(envnames(i)),'/') /= 0)then sep='/' exit FOUND endif enddo write(*,*)'unknown system directory path separator' sep='\' endblock FOUND !x!IFORT BUG:sep_cache=sep isep=ichar(sep) end function separator !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== subroutine cmd_args_to_dictionary() ! convert command line arguments to dictionary entries !x!logical :: guess_if_value integer :: pointer character(len=:),allocatable :: lastkeyword integer :: i, jj, kk integer :: ilength, istatus, imax character(len=1) :: letter character(len=:),allocatable :: current_argument character(len=:),allocatable :: current_argument_padded character(len=:),allocatable :: dummy character(len=:),allocatable :: oldvalue logical :: nomore logical :: next_mandatory if(G_DEBUG)write(*,gen)'CMD_ARGS_TO_DICTIONARY:START' next_mandatory=.false. nomore=.false. pointer=0 lastkeyword=' ' G_keyword_single_letter=.true. i=1 current_argument='' GET_ARGS: do while (get_next_argument()) ! insert and replace entries if(G_DEBUG)write(*,gen)'CMD_ARGS_TO_DICTIONARY:WHILE:CURRENT_ARGUMENT=',current_argument if( current_argument == '-' .and. nomore .eqv. .true. )then ! sort of elseif( current_argument == '-')then ! sort of current_argument='"stdin"' endif if( current_argument == '--' .and. nomore .eqv. .true. )then ! -- was already encountered elseif( current_argument == '--' )then ! everything after this goes into the unnamed array nomore=.true. pointer=0 if(G_remaining_option_allowed)then G_remaining_on=.true. endif cycle GET_ARGS endif dummy=current_argument//' ' current_argument_padded=current_argument//' ' if(.not.next_mandatory.and..not.nomore.and.current_argument_padded(1:2) == '--')then ! beginning of long word if(G_DEBUG)write(*,gen)'CMD_ARGS_TO_DICTIONARY:START_LONG:' G_keyword_single_letter=.false. if(lastkeyword /= '')then call ifnull() endif call locate_key(current_argument_padded(3:),pointer) if(pointer <= 0)then if(G_QUIET)then lastkeyword="UNKNOWN" pointer=0 cycle GET_ARGS endif call print_dictionary('UNKNOWN LONG KEYWORD: '//current_argument) call mystop(1) return endif lastkeyword=trim(current_argument_padded(3:)) next_mandatory=mandatory(pointer) elseif(.not.next_mandatory & & .and..not.nomore & & .and.current_argument_padded(1:1) == '-' & & .and.index("0123456789.",dummy(2:2)) == 0)then ! short word if(G_DEBUG)write(*,gen)'CMD_ARGS_TO_DICTIONARY:START_SHORT' G_keyword_single_letter=.true. if(lastkeyword /= '')then call ifnull() endif call locate_key(current_argument_padded(2:),pointer) jj=len(current_argument) if( (pointer <= 0.or.jj.ge.3).and.(G_STRICT) )then ! name not found if(G_DEBUG)write(*,gen)'CMD_ARGS_TO_DICTIONARY:SHORT NOT FOUND:',current_argument_padded(2:) ! in strict mode this might be multiple single-character values do kk=2,jj letter=current_argument_padded(kk:kk) call locate_key(letter,pointer) if(G_DEBUG)write(*,gen)'CMD_ARGS_TO_DICTIONARY:LETTER:',letter,pointer if(pointer > 0)then call update(keywords(pointer),'T') else if(G_DEBUG)write(*,gen)'CMD_ARGS_TO_DICTIONARY:UNKNOWN SHORT:',letter call print_dictionary('UNKNOWN SHORT KEYWORD:'//letter) ! //' in '//current_argument) if(G_QUIET)then lastkeyword="UNKNOWN" pointer=0 cycle GET_ARGS endif call mystop(2) return endif current_argument='-'//current_argument_padded(jj:jj) enddo !-------------- lastkeyword="" pointer=0 if(G_DEBUG)write(*,gen)'CMD_ARGS_TO_DICTIONARY:SHORT_END:2:' cycle GET_ARGS !-------------- elseif(pointer<0)then if(G_DEBUG)write(*,gen)'CMD_ARGS_TO_DICTIONARY:UNKNOWN SHORT_CONFIRMED:',letter call print_dictionary('UNKNOWN SHORT KEYWORD:'//current_argument_padded(2:)) if(G_QUIET)then lastkeyword="UNKNOWN" pointer=0 cycle GET_ARGS endif call mystop(2) return endif if(G_DEBUG)write(*,gen)'CMD_ARGS_TO_DICTIONARY:SHORT_END:1:' lastkeyword=trim(current_argument_padded(2:)) next_mandatory=mandatory(pointer) elseif(pointer == 0)then ! unnamed arguments if(G_DEBUG)write(*,gen)'CMD_ARGS_TO_DICTIONARY:UNNAMED ARGUMENT:',current_argument if(G_remaining_on)then if(len(current_argument) < 1)then G_remaining=G_remaining//'"" ' elseif(current_argument(1:1) == '-')then !get fancier to handle spaces and =!G_remaining=G_remaining//current_argument//' ' G_remaining=G_remaining//'"'//current_argument//'" ' else G_remaining=G_remaining//'"'//current_argument//'" ' endif imax=max(len(args),len(current_argument)) args=[character(len=imax) :: args,current_argument] else imax=max(len(unnamed),len(current_argument)) if(scan(current_argument//' ','@') == 1.and.G_response)then if(G_DEBUG)write(*,gen)'CMD_ARGS_TO_DICTIONARY:1:CALL EXPAND_RESPONSE:CURRENT_ARGUMENT=',current_argument call expand_response(current_argument) else unnamed=[character(len=imax) :: unnamed,current_argument] endif endif else if(G_DEBUG)write(*,gen)'CMD_ARGS_TO_DICTIONARY:FOUND:',current_argument oldvalue=get(keywords(pointer))//' ' if(oldvalue(1:1) == '"')then current_argument=quote(current_argument(:ilength)) endif if(upper(oldvalue) == 'F'.or.upper(oldvalue) == 'T')then ! assume boolean parameter if(current_argument /= ' ')then if(G_remaining_on)then if(len(current_argument) < 1)then G_remaining=G_remaining//'"" ' elseif(current_argument(1:1) == '-')then !get fancier to handle spaces and =!G_remaining=G_remaining//current_argument//' ' G_remaining=G_remaining//'"'//current_argument//'" ' else G_remaining=G_remaining//'"'//current_argument//'" ' endif imax=max(len(args),len(current_argument)) args=[character(len=imax) :: args,current_argument] else imax=max(len(unnamed),len(current_argument)) if(scan(current_argument//' ','@') == 1.and.G_response)then if(G_DEBUG)write(*,gen)'CMD_ARGS_TO_DICTIONARY:2:CALL EXPAND_RESPONSE:CURRENT_ARGUMENT=',current_argument call expand_response(current_argument) else unnamed=[character(len=imax) :: unnamed,current_argument] endif endif endif current_argument='T' endif call update(keywords(pointer),current_argument) pointer=0 lastkeyword='' next_mandatory=.false. endif enddo GET_ARGS if(lastkeyword /= '')then call ifnull() endif if(G_DEBUG)write(*,gen)'CMD_ARGS_TO_DICTIONARY:NORMAL END' contains subroutine ifnull() oldvalue=clipends(get(lastkeyword))//' ' if(upper(oldvalue(1:1)) == 'F'.or.upper(oldvalue(1:1)) == 'T')then call update(lastkeyword,'T') elseif(oldvalue(1:1) == '"')then call update(lastkeyword,'" "') else call update(lastkeyword,' ') endif end subroutine ifnull function get_next_argument() ! ! get next argument from command line into allocated variable current_argument ! logical,save :: hadequal=.false. character(len=:),allocatable,save :: right_hand_side logical :: get_next_argument integer :: iright integer :: iequal if(hadequal)then ! use left-over value from previous -NAME=VALUE syntax current_argument=right_hand_side right_hand_side='' hadequal=.false. get_next_argument=.true. ilength=len(current_argument) return endif if(i>command_argument_count())then get_next_argument=.false. return else get_next_argument=.true. endif call get_command_argument(number=i,length=ilength,status=istatus) ! get next argument if(istatus /= 0) then ! on error write(warn,*)'*prototype_and_cmd_args_to_nlist* error obtaining argument ',i,& &'status=',istatus,& &'length=',ilength get_next_argument=.false. else ilength=max(ilength,1) if(allocated(current_argument))deallocate(current_argument) allocate(character(len=ilength) :: current_argument) call get_command_argument(number=i,value=current_argument,length=ilength,status=istatus) ! get next argument if(istatus /= 0) then ! on error write(warn,*)'*prototype_and_cmd_args_to_nlist* error obtaining argument ',i,& &'status=',istatus,& &'length=',ilength,& &'target length=',len(current_argument) get_next_argument=.false. endif ! if an argument keyword and an equal before a space split on equal and save right hand side for next call if(nomore)then elseif( len(current_argument) == 0)then else iright=index(current_argument,' ') if(iright == 0)iright=len(current_argument) iequal=index(current_argument(:iright),'=') if(next_mandatory)then elseif(iequal /= 0.and.current_argument(1:1) == '-')then if(iequal /= len(current_argument))then right_hand_side=current_argument(iequal+1:) else right_hand_side='' endif hadequal=.true. current_argument=current_argument(:iequal-1) endif endif endif i=i+1 end function get_next_argument end subroutine cmd_args_to_dictionary !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! print_dictionary(3f) - [ARGUMENTS:M_CLI2] print internal dictionary !! created by calls to set_args(3f) !! (LICENSE:PD) !!##SYNOPSIS !! !! subroutine print_dictionary(header,stop) !! !! character(len=*),intent(in),optional :: header !! logical,intent(in),optional :: stop !!##DESCRIPTION !! Print the internal dictionary created by calls to set_args(3f). !! This routine is intended to print the state of the argument list !! if an error occurs in using the set_args(3f) procedure. !!##OPTIONS !! HEADER label to print before printing the state of the command !! argument list. !! STOP logical value that if true stops the program after displaying !! the dictionary. !!##EXAMPLE !! !! !! !! Typical usage: !! !! program demo_print_dictionary !! use M_CLI2, only : set_args, get_args !! implicit none !! real :: x, y, z !! call set_args('-x 10 -y 20 -z 30') !! call get_args('x',x,'y',y,'z',z) !! ! all done cracking the command line; use the values in your program. !! write(*,*)x,y,z !! end program demo_print_dictionary !! !! Sample output !! !! Calling the sample program with an unknown parameter or the --usage !! switch produces the following: !! !! $ ./demo_print_dictionary -A !! UNKNOWN SHORT KEYWORD: -A !! KEYWORD PRESENT VALUE !! z F [3] !! y F [2] !! x F [1] !! help F [F] !! version F [F] !! usage F [F] !! !!##AUTHOR !! John S. Urban, 2019 !!##LICENSE !! Public Domain !=================================================================================================================================== subroutine print_dictionary(header,stop) character(len=*),intent(in),optional :: header logical,intent(in),optional :: stop integer :: i if(G_QUIET)return if(present(header))then if(header /= '')then write(warn,'(a)')header endif endif if(allocated(keywords))then if(size(keywords) > 0)then write(warn,'(a,1x,a,1x,a,1x,a)')atleast('KEYWORD',max(len(keywords),8)),'SHORT','PRESENT','VALUE' write(warn,'(*(a,1x,a5,1x,l1,8x,"[",a,"]",/))') & & (atleast(keywords(i),max(len(keywords),8)),shorts(i),present_in(i),values(i)(:counts(i)),i=size(keywords),1,-1) endif endif if(allocated(unnamed))then if(size(unnamed) > 0)then write(warn,'(a)')'UNNAMED' write(warn,'(i6.6,3a)')(i,'[',unnamed(i),']',i=1,size(unnamed)) endif endif if(allocated(args))then if(size(args) > 0)then write(warn,'(a)')'ARGS' write(warn,'(i6.6,3a)')(i,'[',args(i),']',i=1,size(args)) endif endif if(G_remaining /= '')then write(warn,'(a)')'REMAINING' write(warn,'(a)')G_remaining endif if(present(stop))then if(stop) call mystop(5) endif end subroutine print_dictionary !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! get_args(3f) - [ARGUMENTS:M_CLI2] return keyword values when parsing !! command line arguments !! (LICENSE:PD) !! !!##SYNOPSIS !! !! get_args(3f) and its convenience functions: !! !! use M_CLI2, only : get_args !! ! convenience functions !! use M_CLI2, only : dget, iget, lget, rget, sget, cget !! use M_CLI2, only : dgets, igets, lgets, rgets, sgets, cgets !! !! subroutine get_args(name,value,delimiters) !! !! character(len=*),intent(in) :: name !! !! type(${TYPE}),allocatable,intent(out) :: value(:) !! ! or !! type(${TYPE}),allocatable,intent(out) :: value !! !! character(len=*),intent(in),optional :: delimiters !! !! where ${TYPE} may be from the set !! {real,doubleprecision,integer,logical,complex,character(len=:)} !!##DESCRIPTION !! !! GET_ARGS(3f) returns the value of keywords after SET_ARGS(3f) has !! been called to parse the command line. For fixed-length CHARACTER !! variables see GET_ARGS_FIXED_LENGTH(3f). For fixed-size arrays see !! GET_ARGS_FIXED_SIZE(3f). !! !! As a convenience multiple pairs of keywords and variables may be !! specified if and only if all the values are scalars and the CHARACTER !! variables are fixed-length or pre-allocated. !! !!##OPTIONS !! !! NAME name of commandline argument to obtain the value of !! VALUE variable to hold returned value. The kind of the value !! is used to determine the type of returned value. May !! be a scalar or allocatable array. If type is CHARACTER !! the scalar must have an allocatable length. !! DELIMITERS By default the delimiter for array values are comma, !! colon, and whitespace. A string containing an alternate !! list of delimiter characters may be supplied. !! !!##CONVENIENCE FUNCTIONS !! There are convenience functions that are replacements for calls to !! get_args(3f) for each supported default intrinsic type !! !! o scalars -- dget(3f), iget(3f), lget(3f), rget(3f), sget(3f), !! cget(3f) !! o vectors -- dgets(3f), igets(3f), lgets(3f), rgets(3f), !! sgets(3f), cgets(3f) !! !! D is for DOUBLEPRECISION, I for INTEGER, L for LOGICAL, R for REAL, !! S for string (CHARACTER), and C for COMPLEX. !! !! If the functions are called with no argument they will return the !! UNNAMED array converted to the specified type. !! !!##EXAMPLE !! !! !! Sample program: !! !! program demo_get_args !! use M_CLI2, only : filenames=>unnamed, set_args, get_args !! implicit none !! integer :: i !! ! Define ARGS !! real :: x, y, z !! real,allocatable :: p(:) !! character(len=:),allocatable :: title !! logical :: l, lbig !! ! Define and parse (to set initial values) command line !! ! o only quote strings and use double-quotes !! ! o set all logical values to F or T. !! call set_args(' & !! & -x 1 -y 2 -z 3 & !! & -p -1,-2,-3 & !! & --title "my title" & !! & -l F -L F & !! & --label " " & !! & ') !! ! Assign values to elements !! ! Scalars !! call get_args('x',x,'y',y,'z',z,'l',l,'L',lbig) !! ! Allocatable string !! call get_args('title',title) !! ! Allocatable arrays !! call get_args('p',p) !! ! Use values !! write(*,'(1x,g0,"=",g0)')'x',x, 'y',y, 'z',z !! write(*,*)'p=',p !! write(*,*)'title=',title !! write(*,*)'l=',l !! write(*,*)'L=',lbig !! if(size(filenames) > 0)then !! write(*,'(i6.6,3a)')(i,'[',filenames(i),']',i=1,size(filenames)) !! endif !! end program demo_get_args !!##AUTHOR !! John S. Urban, 2019 !!##LICENSE !! Public Domain !=================================================================================================================================== !> !!##NAME !! get_args_fixed_length(3f) - [ARGUMENTS:M_CLI2] return keyword values !! for fixed-length string when parsing command line !! (LICENSE:PD) !! !!##SYNOPSIS !! !! subroutine get_args_fixed_length(name,value) !! !! character(len=*),intent(in) :: name !! character(len=:),allocatable :: value !! character(len=*),intent(in),optional :: delimiters !! !!##DESCRIPTION !! !! get_args_fixed_length(3f) returns the value of a string !! keyword when the string value is a fixed-length CHARACTER !! variable. !! !!##OPTIONS !! !! NAME name of commandline argument to obtain the value of !! !! VALUE variable to hold returned value. !! Must be a fixed-length CHARACTER variable. !! !! DELIMITERS By default the delimiter for array values are comma, !! colon, and whitespace. A string containing an alternate !! list of delimiter characters may be supplied. !! !!##EXAMPLE !! !! Sample program: !! !! program demo_get_args_fixed_length !! use M_CLI2, only : set_args, get_args_fixed_length !! implicit none !! !! ! Define args !! character(len=80) :: title !! ! Parse command line !! call set_args(' --title "my title" ') !! ! Assign values to variables !! call get_args_fixed_length('title',title) !! ! Use values !! write(*,*)'title=',title !! !! end program demo_get_args_fixed_length !! !!##AUTHOR !! John S. Urban, 2019 !!##LICENSE !! Public Domain !=================================================================================================================================== !> !!##NAME !! get_args_fixed_size(3f) - [ARGUMENTS:M_CLI2] return keyword values !! for fixed-size array when parsing command line arguments !! (LICENSE:PD) !! !!##SYNOPSIS !! !! subroutine get_args_fixed_size(name,value) !! !! character(len=*),intent(in) :: name !! [real|doubleprecision|integer|logical|complex] :: value(NNN) !! or !! character(len=MMM) :: value(NNN) !! !! character(len=*),intent(in),optional :: delimiters !! !!##DESCRIPTION !! !! get_args_fixed_size(3f) returns the value of keywords for fixed-size !! arrays after set_args(3f) has been called. On input on the command !! line all values of the array must be specified. !! !!##OPTIONS !! NAME name of commandline argument to obtain the value of !! !! VALUE variable to hold returned values. The kind of the value !! is used to determine the type of returned value. Must be !! a fixed-size array. If type is CHARACTER the length must !! also be fixed. !! !! DELIMITERS By default the delimiter for array values are comma, !! colon, and whitespace. A string containing an alternate !! list of delimiter characters may be supplied. !! !!##EXAMPLE !! !! Sample program: !! !! program demo_get_args_fixed_size !! use M_CLI2, only : set_args, get_args_fixed_size !! implicit none !! integer,parameter :: dp=kind(0.0d0) !! ! DEFINE ARGS !! real :: x(2) !! real(kind=dp) :: y(2) !! integer :: p(3) !! character(len=80) :: title(1) !! logical :: l(4), lbig(4) !! complex :: cmp(2) !! ! DEFINE AND PARSE (TO SET INITIAL VALUES) COMMAND LINE !! ! o only quote strings !! ! o set all logical values to F or T. !! call set_args(' & !! & -x 10.0,20.0 & !! & -y 11.0,22.0 & !! & -p -1,-2,-3 & !! & --title "my title" & !! & -l F,T,F,T -L T,F,T,F & !! & --cmp 111,222.0,333.0e0,4444 & !! & ') !! ! ASSIGN VALUES TO ELEMENTS !! call get_args_fixed_size('x',x) !! call get_args_fixed_size('y',y) !! call get_args_fixed_size('p',p) !! call get_args_fixed_size('title',title) !! call get_args_fixed_size('l',l) !! call get_args_fixed_size('L',lbig) !! call get_args_fixed_size('cmp',cmp) !! ! USE VALUES !! write(*,*)'x=',x !! write(*,*)'p=',p !! write(*,*)'title=',title !! write(*,*)'l=',l !! write(*,*)'L=',lbig !! write(*,*)'cmp=',cmp !! end program demo_get_args_fixed_size !! Results: !! !!##AUTHOR !! John S. Urban, 2019 !!##LICENSE !! Public Domain !=================================================================================================================================== subroutine get_fixedarray_class(keyword,generic,delimiters) character(len=*),intent(in) :: keyword ! keyword to retrieve value from dictionary class(*) :: generic(:) character(len=*),intent(in),optional :: delimiters select type(generic) type is (character(len=*)); call get_fixedarray_fixed_length_c(keyword,generic,delimiters) type is (integer); call get_fixedarray_i(keyword,generic,delimiters) type is (real); call get_fixedarray_r(keyword,generic,delimiters) type is (complex); call get_fixed_size_complex(keyword,generic,delimiters) type is (real(kind=dp)); call get_fixedarray_d(keyword,generic,delimiters) type is (logical); call get_fixedarray_l(keyword,generic,delimiters) class default call mystop(-7,'*get_fixedarray_class* crud -- procedure does not know about this type') end select end subroutine get_fixedarray_class !=================================================================================================================================== ! return allocatable arrays !=================================================================================================================================== subroutine get_anyarray_l(keyword,larray,delimiters) ! ident_5="@(#) M_CLI2 get_anyarray_l(3f) given keyword fetch logical array from string in dictionary(F on err)" character(len=*),intent(in) :: keyword ! the dictionary keyword (in form VERB_KEYWORD) to retrieve logical,allocatable :: larray(:) ! convert value to an array character(len=*),intent(in),optional :: delimiters character(len=:),allocatable :: carray(:) ! convert value to an array character(len=:),allocatable :: val integer :: i integer :: place integer :: iichar ! point to first character of word unless first character is "." call locate_key(keyword,place) ! find where string is or should be if(place > 0)then ! if string was found val=values(place)(:counts(place)) call split(adjustl(upper(val)),carray,delimiters=delimiters) ! convert value to uppercase, trimmed; then parse into array else call journal('*get_anyarray_l* unknown keyword',keyword) call mystop(8 ,'*get_anyarray_l* unknown keyword '//keyword) if(allocated(larray))deallocate(larray) allocate(larray(0)) return endif if(size(carray) > 0)then ! if not a null string if(allocated(larray))deallocate(larray) allocate(larray(size(carray))) ! allocate output array do i=1,size(carray) larray(i)=.false. ! initialize return value to .false. if(carray(i)(1:1) == '.')then ! looking for fortran logical syntax .STRING. iichar=2 else iichar=1 endif select case(carray(i)(iichar:iichar)) ! check word to see if true or false case('T','Y',' '); larray(i)=.true. ! anything starting with "T" or "Y" or a blank is TRUE (true,yes,...) case('F','N'); larray(i)=.false. ! assume this is false or no case default call journal("*get_anyarray_l* bad logical expression for ",(keyword),'=',carray(i)) end select enddo else ! for a blank string return one T if(allocated(larray))deallocate(larray) allocate(larray(1)) ! allocate output array larray(1)=.true. endif end subroutine get_anyarray_l !=================================================================================================================================== subroutine get_anyarray_d(keyword,darray,delimiters) ! ident_6="@(#) M_CLI2 get_anyarray_d(3f) given keyword fetch dble value array from Language Dictionary (0 on err)" character(len=*),intent(in) :: keyword ! keyword to retrieve value from dictionary real(kind=dp),allocatable,intent(out) :: darray(:) ! function type character(len=*),intent(in),optional :: delimiters character(len=:),allocatable :: carray(:) ! convert value to an array using split(3f) integer :: i integer :: place integer :: ierr character(len=:),allocatable :: val !----------------------------------------------------------------------------------------------------------------------------------- call locate_key(keyword,place) ! find where string is or should be if(place > 0)then ! if string was found val=values(place)(:counts(place)) val=replace_str(val,'(','') val=replace_str(val,')','') call split(val,carray,delimiters=delimiters) ! find value associated with keyword and split it into an array else call journal('*get_anyarray_d* unknown keyword '//keyword) call mystop(9 ,'*get_anyarray_d* unknown keyword '//keyword) if(allocated(darray))deallocate(darray) allocate(darray(0)) return endif if(allocated(darray))deallocate(darray) allocate(darray(size(carray))) ! create the output array do i=1,size(carray) call a2d(carray(i), darray(i),ierr) ! convert the string to a numeric value if(ierr /= 0)then call mystop(10 ,'*get_anyarray_d* unreadable value '//carray(i)//' for keyword '//keyword) endif enddo end subroutine get_anyarray_d !=================================================================================================================================== subroutine get_anyarray_i(keyword,iarray,delimiters) character(len=*),intent(in) :: keyword ! keyword to retrieve value from dictionary integer,allocatable :: iarray(:) character(len=*),intent(in),optional :: delimiters real(kind=dp),allocatable :: darray(:) ! function type call get_anyarray_d(keyword,darray,delimiters) iarray=nint(darray) end subroutine get_anyarray_i !=================================================================================================================================== subroutine get_anyarray_r(keyword,rarray,delimiters) character(len=*),intent(in) :: keyword ! keyword to retrieve value from dictionary real,allocatable :: rarray(:) character(len=*),intent(in),optional :: delimiters real(kind=dp),allocatable :: darray(:) ! function type call get_anyarray_d(keyword,darray,delimiters) rarray=real(darray) end subroutine get_anyarray_r !=================================================================================================================================== subroutine get_anyarray_x(keyword,xarray,delimiters) character(len=*),intent(in) :: keyword ! keyword to retrieve value from dictionary complex(kind=sp),allocatable :: xarray(:) character(len=*),intent(in),optional :: delimiters real(kind=dp),allocatable :: darray(:) ! function type integer :: half,sz,i call get_anyarray_d(keyword,darray,delimiters) sz=size(darray) half=sz/2 if(sz /= half+half)then call journal('*get_anyarray_x* uneven number of values defining complex value '//keyword) call mystop(11,'*get_anyarray_x* uneven number of values defining complex value '//keyword) if(allocated(xarray))deallocate(xarray) allocate(xarray(0)) endif !x!================================================================================================ !x!IFORT,GFORTRAN OK, NVIDIA RETURNS NULL ARRAY: xarray=cmplx(real(darray(1::2)),real(darray(2::2))) if(allocated(xarray))deallocate(xarray) allocate(xarray(half)) do i=1,sz,2 xarray((i+1)/2)=cmplx( darray(i),darray(i+1),kind=sp ) enddo !x!================================================================================================ end subroutine get_anyarray_x !=================================================================================================================================== subroutine get_anyarray_c(keyword,strings,delimiters) ! ident_7="@(#) M_CLI2 get_anyarray_c(3f) Fetch strings value for specified KEYWORD from the lang. dictionary" ! This routine trusts that the desired keyword exists. A blank is returned if the keyword is not in the dictionary character(len=*),intent(in) :: keyword ! name to look up in dictionary character(len=:),allocatable :: strings(:) character(len=*),intent(in),optional :: delimiters integer :: place character(len=:),allocatable :: val call locate_key(keyword,place) ! find where string is or should be if(place > 0)then ! if index is valid return strings val=unquote(values(place)(:counts(place))) call split(val,strings,delimiters=delimiters) ! find value associated with keyword and split it into an array else call journal('*get_anyarray_c* unknown keyword '//keyword) call mystop(12,'*get_anyarray_c* unknown keyword '//keyword) if(allocated(strings))deallocate(strings) allocate(character(len=0)::strings(0)) endif end subroutine get_anyarray_c !=================================================================================================================================== subroutine get_args_fixed_length_a_array(keyword,strings,delimiters) ! ident_8="@(#) M_CLI2 get_args_fixed_length_a_array(3f) Fetch strings value for specified KEYWORD from the lang. dictionary" ! This routine trusts that the desired keyword exists. A blank is returned if the keyword is not in the dictionary character(len=*),intent(in) :: keyword ! name to look up in dictionary character(len=*),allocatable :: strings(:) character(len=*),intent(in),optional :: delimiters character(len=:),allocatable :: strings_a(:) integer :: place character(len=:),allocatable :: val integer :: ibug call locate_key(keyword,place) ! find where string is or should be if(place > 0)then ! if index is valid return strings val=unquote(values(place)(:counts(place))) call split(val,strings_a,delimiters=delimiters) ! find value associated with keyword and split it into an array if( len(strings_a) <= len(strings) )then strings=strings_a else ibug=len(strings) call journal('*get_args_fixed_length_a_array* values too long. Longest is',len(strings_a),'allowed is',ibug) write(*,'("strings=",3x,*(a,1x))')strings call journal('*get_args_fixed_length_a_array* keyword='//keyword) call mystop(13,'*get_args_fixed_length_a_array* keyword='//keyword) strings=[character(len=len(strings)) ::] endif else call journal('*get_args_fixed_length_a_array* unknown keyword '//keyword) call mystop(14,'*get_args_fixed_length_a_array* unknown keyword '//keyword) strings=[character(len=len(strings)) ::] endif end subroutine get_args_fixed_length_a_array !=================================================================================================================================== ! return non-allocatable arrays !=================================================================================================================================== subroutine get_fixedarray_i(keyword,iarray,delimiters) character(len=*),intent(in) :: keyword ! keyword to retrieve value from dictionary integer :: iarray(:) character(len=*),intent(in),optional :: delimiters real(kind=dp),allocatable :: darray(:) ! function type integer :: dsize integer :: ibug call get_anyarray_d(keyword,darray,delimiters) dsize=size(darray) if(ubound(iarray,dim=1) == dsize)then iarray=nint(darray) else ibug=size(iarray) call journal('*get_fixedarray_i* wrong number of values for keyword',keyword,'got',dsize,'expected',ibug) call print_dictionary_usage() call mystop(33) iarray=0 endif end subroutine get_fixedarray_i !=================================================================================================================================== subroutine get_fixedarray_r(keyword,rarray,delimiters) character(len=*),intent(in) :: keyword ! keyword to retrieve value from dictionary real :: rarray(:) character(len=*),intent(in),optional :: delimiters real,allocatable :: darray(:) ! function type integer :: dsize integer :: ibug call get_anyarray_r(keyword,darray,delimiters) dsize=size(darray) if(ubound(rarray,dim=1) == dsize)then rarray=darray else ibug=size(rarray) call journal('*get_fixedarray_r* wrong number of values for keyword',keyword,'got',dsize,'expected',ibug) call print_dictionary_usage() call mystop(33) rarray=0.0 endif end subroutine get_fixedarray_r !=================================================================================================================================== subroutine get_fixed_size_complex(keyword,xarray,delimiters) character(len=*),intent(in) :: keyword ! keyword to retrieve value from dictionary complex :: xarray(:) character(len=*),intent(in),optional :: delimiters complex,allocatable :: darray(:) ! function type integer :: half, sz integer :: dsize integer :: ibug call get_anyarray_x(keyword,darray,delimiters) dsize=size(darray) sz=dsize*2 half=sz/2 if(sz /= half+half)then call journal('*get_fixed_size_complex* uneven number of values defining complex value '//keyword) call mystop(15,'*get_fixed_size_complex* uneven number of values defining complex value '//keyword) xarray=0 return endif if(ubound(xarray,dim=1) == dsize)then xarray=darray else ibug=size(xarray) call journal('*get_fixed_size_complex* wrong number of values for keyword',keyword,'got',dsize,'expected',ibug) call print_dictionary_usage() call mystop(34) xarray=cmplx(0.0,0.0) endif end subroutine get_fixed_size_complex !=================================================================================================================================== subroutine get_fixedarray_d(keyword,darr,delimiters) character(len=*),intent(in) :: keyword ! keyword to retrieve value from dictionary real(kind=dp) :: darr(:) character(len=*),intent(in),optional :: delimiters real(kind=dp),allocatable :: darray(:) ! function type integer :: dsize integer :: ibug call get_anyarray_d(keyword,darray,delimiters) dsize=size(darray) if(ubound(darr,dim=1) == dsize)then darr=darray else ibug=size(darr) call journal('*get_fixedarray_d* wrong number of values for keyword',keyword,'got',dsize,'expected',ibug) call print_dictionary_usage() call mystop(35) darr=0.0d0 endif end subroutine get_fixedarray_d !=================================================================================================================================== subroutine get_fixedarray_l(keyword,larray,delimiters) character(len=*),intent(in) :: keyword ! keyword to retrieve value from dictionary logical :: larray(:) character(len=*),intent(in),optional :: delimiters logical,allocatable :: darray(:) ! function type integer :: dsize integer :: ibug call get_anyarray_l(keyword,darray,delimiters) dsize=size(darray) if(ubound(larray,dim=1) == dsize)then larray=darray else ibug=size(larray) call journal('*get_fixedarray_l* wrong number of values for keyword',keyword,'got',dsize,'expected',ibug) call print_dictionary_usage() call mystop(36) larray=.false. endif end subroutine get_fixedarray_l !=================================================================================================================================== subroutine get_fixedarray_fixed_length_c(keyword,strings,delimiters) ! ident_9="@(#) M_CLI2 get_fixedarray_fixed_length_c(3f) Fetch strings value for specified KEYWORD from the lang. dictionary" ! This routine trusts that the desired keyword exists. A blank is returned if the keyword is not in the dictionary character(len=*) :: strings(:) character(len=*),intent(in),optional :: delimiters character(len=:),allocatable :: str(:) character(len=*),intent(in) :: keyword ! name to look up in dictionary integer :: place integer :: ssize integer :: ibug character(len=:),allocatable :: val call locate_key(keyword,place) ! find where string is or should be if(place > 0)then ! if index is valid return strings val=unquote(values(place)(:counts(place))) call split(val,str,delimiters=delimiters) ! find value associated with keyword and split it into an array ssize=size(str) if(ssize==size(strings))then strings(:ssize)=str else ibug=size(strings) call journal('*get_fixedarray_fixed_length_c* wrong number of values for keyword',& & keyword,'got',ssize,'expected ',ibug) !,ubound(strings,dim=1) call print_dictionary_usage() call mystop(30,'*get_fixedarray_fixed_length_c* unknown keyword '//keyword) strings='' endif else call journal('*get_fixedarray_fixed_length_c* unknown keyword '//keyword) call mystop(16,'*get_fixedarray_fixed_length_c* unknown keyword '//keyword) strings='' endif end subroutine get_fixedarray_fixed_length_c !=================================================================================================================================== ! return scalars !=================================================================================================================================== subroutine get_scalar_d(keyword,d) character(len=*),intent(in) :: keyword ! keyword to retrieve value from dictionary real(kind=dp) :: d real(kind=dp),allocatable :: darray(:) ! function type integer :: ibug call get_anyarray_d(keyword,darray) if(size(darray) == 1)then d=darray(1) else ibug=size(darray) call journal('*get_anyarray_d* incorrect number of values for keyword "',keyword,'" expected one found',ibug) call print_dictionary_usage() call mystop(31,'*get_anyarray_d* incorrect number of values for keyword "'//keyword//'" expected one') endif end subroutine get_scalar_d !=================================================================================================================================== subroutine get_scalar_real(keyword,r) character(len=*),intent(in) :: keyword ! keyword to retrieve value from dictionary real,intent(out) :: r real(kind=dp) :: d call get_scalar_d(keyword,d) r=real(d) end subroutine get_scalar_real !=================================================================================================================================== subroutine get_scalar_i(keyword,i) character(len=*),intent(in) :: keyword ! keyword to retrieve value from dictionary integer,intent(out) :: i real(kind=dp) :: d call get_scalar_d(keyword,d) i=nint(d) end subroutine get_scalar_i !=================================================================================================================================== subroutine get_scalar_anylength_c(keyword,string) ! ident_10="@(#) M_CLI2 get_scalar_anylength_c(3f) Fetch string value for specified KEYWORD from the lang. dictionary" ! This routine trusts that the desired keyword exists. A blank is returned if the keyword is not in the dictionary character(len=*),intent(in) :: keyword ! name to look up in dictionary character(len=:),allocatable,intent(out) :: string integer :: place call locate_key(keyword, place) ! find where string is or should be if (place > 0) then ! if index is valid return string string = unquote(values(place) (:counts(place))) else call journal('*get_anyarray_c* unknown keyword '//keyword) call mystop(17, '*get_anyarray_c* unknown keyword '//keyword) string = '' endif end subroutine get_scalar_anylength_c !=================================================================================================================================== elemental impure subroutine get_args_fixed_length_scalar_c(keyword,string) ! ident_11="@(#) M_CLI2 get_args_fixed_length_scalar_c(3f) Fetch string value for specified KEYWORD from the lang. dictionary" ! This routine trusts that the desired keyword exists. A blank is returned if the keyword is not in the dictionary character(len=*),intent(in) :: keyword ! name to look up in dictionary character(len=*),intent(out) :: string integer :: place integer :: unlen integer :: ibug call locate_key(keyword, place) ! find where string is or should be if (place > 0) then ! if index is valid return string string = unquote(values(place) (:counts(place))) else call mystop(18, '*get_args_fixed_length_scalar_c* unknown keyword '//keyword) string = '' endif unlen = len_trim(unquote(values(place) (:counts(place)))) if (unlen > len(string)) then ibug = len(string) call journal('*get_args_fixed_length_scalar_c* value too long for', keyword, 'allowed is', ibug,& & 'input string [', values(place), '] is', unlen) call mystop(19, '*get_args_fixed_length_scalar_c* value too long') string = '' endif end subroutine get_args_fixed_length_scalar_c !=================================================================================================================================== subroutine get_scalar_complex(keyword,x) character(len=*),intent(in) :: keyword ! keyword to retrieve value from dictionary complex,intent(out) :: x real(kind=dp) :: d(2) call get_fixedarray_d(keyword,d) x=cmplx(d(1),d(2),kind=sp) end subroutine get_scalar_complex !=================================================================================================================================== subroutine get_scalar_logical(keyword,l) character(len=*),intent(in) :: keyword ! keyword to retrieve value from dictionary logical :: l logical,allocatable :: larray(:) ! function type integer :: ibug l = .false. call get_anyarray_l(keyword, larray) if (.not. allocated(larray)) then call journal('*get_scalar_logical* expected one value found not allocated') call mystop(37, '*get_scalar_logical* incorrect number of values for keyword "'//keyword//'"') elseif (size(larray) == 1) then l = larray(1) else ibug = size(larray) call journal('*get_scalar_logical* expected one value found', ibug) call mystop(21, '*get_scalar_logical* incorrect number of values for keyword "'//keyword//'"') endif end subroutine get_scalar_logical !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== ! THE REMAINDER SHOULD BE ROUTINES EXTRACTED FROM OTHER MODULES TO MAKE THIS MODULE STANDALONE BY POPULAR REQUEST !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !use M_strings, only : UPPER, LOWER, QUOTE, REPLACE_STR=>REPLACE, UNQUOTE, SPLIT, STRING_TO_VALUE !use M_list, only : insert, locate, remove, replace !use M_journal, only : JOURNAL !use M_args, only : LONGEST_COMMAND_ARGUMENT ! routines extracted from other modules !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! longest_command_argument(3f) - [ARGUMENTS:M_args] length of longest !! argument on command line !! (LICENSE:PD) !!##SYNOPSIS !! !! function longest_command_argument() result(ilongest) !! !! integer :: ilongest !! !!##DESCRIPTION !! length of longest argument on command line. Useful when allocating !! storage for holding arguments. !!##RESULT !! longest_command_argument length of longest command argument !!##EXAMPLE !! !! Sample program !! !! program demo_longest_command_argument !! use M_args, only : longest_command_argument !! write(*,*)'longest argument is ',longest_command_argument() !! end program demo_longest_command_argument !!##AUTHOR !! John S. Urban, 2019 !!##LICENSE !! Public Domain !=================================================================================================================================== function longest_command_argument() result(ilongest) integer :: i integer :: ilength integer :: istatus integer :: ilongest ilength = 0 ilongest = 0 GET_LONGEST: do i = 1, command_argument_count() ! loop throughout command line arguments to find longest call get_command_argument(number=i, length=ilength, status=istatus) ! get next argument if (istatus /= 0) then ! on error write (warn, *) '*prototype_and_cmd_args_to_nlist* error obtaining length for argument ', i exit GET_LONGEST elseif (ilength > 0) then ilongest = max(ilongest, ilength) endif end do GET_LONGEST end function longest_command_argument !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! journal(3f) - [M_CLI2] converts a list of standard scalar types to a string and writes message !! (LICENSE:PD) !!##SYNOPSIS !! !! subroutine journal(g0,g1,g2,g3,g4,g5,g6,g7,g8,g9,ga,gb,gc,gd,ge,gf,gg,gh,gi,gj,sep,line) !! !! class(*),intent(in),optional :: g0,g1,g2,g3,g4,g5,g6,g7,g8,g9 !! class(*),intent(in),optional :: ga,gb,gc,gd,ge,gf,gg,gh,gi,gj !! character(len=*),intent(in),optional :: sep !! character(len=:),intent(out),allocatable,optional :: line !! !!##DESCRIPTION !! journal(3f) builds and prints a space-separated string from up to twenty scalar values. !! !!##OPTIONS !! g[0-9a-j] optional value to print the value of after the message. May !! be of type INTEGER, LOGICAL, REAL, DOUBLEPRECISION, !! COMPLEX, or CHARACTER. !! !! sep separator to place between values. Defaults to a space. !! line if present, the output is placed in the variable instead of !! being written !!##RETURNS !! journal description to print !!##EXAMPLES !! !! Sample program: !! !! program demo_journal !! use M_CLI2, only : journal !! implicit none !! character(len=:),allocatable :: frmt !! integer :: biggest !! !! call journal('HUGE(3f) integers',huge(0),'and real',& !! & huge(0.0),'and double',huge(0.0d0)) !! call journal('real :',huge(0.0),0.0,12345.6789,tiny(0.0) ) !! call journal('doubleprecision :',huge(0.0d0),0.0d0,12345.6789d0,tiny(0.0d0) ) !! call journal('complex :',cmplx(huge(0.0),tiny(0.0)) ) !! !! end program demo_journal !! !! Output !! !! HUGE(3f) integers 2147483647 and real 3.40282347E+38 and !! double 1.7976931348623157E+308 !! real : 3.40282347E+38 0.00000000 12345.6787 1.17549435E-38 !! doubleprecision : 1.7976931348623157E+308 0.0000000000000000 !! 12345.678900000001 2.2250738585072014E-308 !! complex : (3.40282347E+38,1.17549435E-38) !! format=(*(i9:,1x)) !! program will now stop !! !!##AUTHOR !! John S. Urban !!##LICENSE !! Public Domain !=================================================================================================================================== subroutine journal(g0, g1, g2, g3, g4, g5, g6, g7, g8, g9, ga, gb, gc, gd, ge, gf, gg, gh, gi, gj, sep,line) ! ident_12="@(#) M_CLI2 journal(3fp) writes a message to stdout or a string composed of any standard scalar types" class(*),intent(in),optional :: g0, g1, g2, g3, g4, g5, g6, g7, g8, g9, ga, gb, gc, gd, ge, gf, gg, gh, gi, gj character(len=*),intent(in),optional :: sep character(len=:),intent(out),allocatable,optional :: line character(len=:),allocatable :: sep_local character(len=4096) :: local_line integer :: istart integer :: increment if(present(sep))then sep_local=sep increment=len(sep_local)+1 else sep_local=' ' increment=2 endif istart=1 local_line='' if(present(g0))call print_generic(g0) if(present(g1))call print_generic(g1) if(present(g2))call print_generic(g2) if(present(g3))call print_generic(g3) if(present(g4))call print_generic(g4) if(present(g5))call print_generic(g5) if(present(g6))call print_generic(g6) if(present(g7))call print_generic(g7) if(present(g8))call print_generic(g8) if(present(g9))call print_generic(g9) if(present(ga))call print_generic(ga) if(present(gb))call print_generic(gb) if(present(gc))call print_generic(gc) if(present(gd))call print_generic(gd) if(present(ge))call print_generic(ge) if(present(gf))call print_generic(gf) if(present(gg))call print_generic(gg) if(present(gh))call print_generic(gh) if(present(gi))call print_generic(gi) if(present(gj))call print_generic(gj) if(present(line))then line=trim(local_line) else write(*,'(a)')trim(local_line) endif contains !=================================================================================================================================== subroutine print_generic(generic) use,intrinsic :: iso_fortran_env, only : int8, int16, int32, int64, real32, real64, real128 class(*),intent(in) :: generic select type(generic) type is (integer(kind=int8)); write(local_line(istart:),'(i0)') generic type is (integer(kind=int16)); write(local_line(istart:),'(i0)') generic type is (integer(kind=int32)); write(local_line(istart:),'(i0)') generic type is (integer(kind=int64)); write(local_line(istart:),'(i0)') generic type is (real(kind=real32)); write(local_line(istart:),'(1pg0)') generic type is (real(kind=real64)) write(local_line(istart:),'(1pg0)') generic !x! DOES NOT WORK WITH NVFORTRAN: type is (real(kind=real128)); write(local_line(istart:),'(1pg0)') generic type is (logical) write(local_line(istart:),'(l1)') generic type is (character(len=*)) write(local_line(istart:),'(a)') trim(generic) type is (complex); write(local_line(istart:),'("(",1pg0,",",1pg0,")")') generic end select istart=len_trim(local_line)+increment local_line=trim(local_line)//sep_local end subroutine print_generic !=================================================================================================================================== end subroutine journal !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== function str(g0, g1, g2, g3, g4, g5, g6, g7, g8, g9, ga, gb, gc, gd, ge, gf, gg, gh, gi, gj, sep) result(line) ! ident_13="@(#) M_CLI2 str(3fp) writes a message to a string composed of any standard scalar types" class(*),intent(in),optional :: g0, g1, g2, g3, g4, g5, g6, g7, g8, g9, ga, gb, gc, gd, ge, gf, gg, gh, gi, gj character(len=*),intent(in),optional :: sep character(len=:),allocatable :: line call journal(g0, g1, g2, g3, g4, g5, g6, g7, g8, g9, ga, gb, gc, gd, ge, gf, gg, gh, gi, gj, sep,line) end function str !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== function upper(str) result (string) ! ident_14="@(#) M_CLI2 upper(3f) Changes a string to uppercase" character(*), intent(in) :: str character(:),allocatable :: string integer :: i string = str do i = 1, len_trim(str) select case (str(i:i)) case ('a':'z') string(i:i) = char(iachar(str(i:i))-32) end select end do end function upper !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== function lower(str) result (string) ! ident_15="@(#) M_CLI2 lower(3f) Changes a string to lowercase over specified range" character(*), intent(In) :: str character(:),allocatable :: string integer :: i string = str do i = 1, len_trim(str) select case (str(i:i)) case ('A':'Z') string(i:i) = char(iachar(str(i:i))+32) end select end do end function lower !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== subroutine a2i(chars,valu,ierr) ! ident_16="@(#) M_CLI2 a2i(3fp) subroutine returns integer value from string" character(len=*),intent(in) :: chars ! input string integer,intent(out) :: valu ! value read from input string integer,intent(out) :: ierr ! error flag (0 == no error) doubleprecision :: valu8 integer,parameter :: ihuge=huge(0) valu8 = 0.0d0 call a2d(chars, valu8, ierr, onerr=0.0d0) if (valu8 <= huge(valu)) then if (valu8 <= huge(valu)) then valu = int(valu8) else call journal('*a2i*', '- value too large', valu8, '>', ihuge) valu = huge(valu) ierr = -1 endif endif end subroutine a2i !---------------------------------------------------------------------------------------------------------------------------------- subroutine a2d(chars,valu,ierr,onerr) ! ident_17="@(#) M_CLI2 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) class(*),optional,intent(in) :: onerr !---------------------------------------------------------------------------------------------------------------------------------- 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 integer :: pnd integer :: basevalue, ivalu character(len=3),save :: nan_string='NaN' !---------------------------------------------------------------------------------------------------------------------------------- ierr=0 ! initialize error flag to zero local_chars=unquote(chars) msg='' if(len(local_chars) == 0)local_chars=' ' local_chars=replace_str(local_chars,',','') ! remove any comma characters pnd=scan(local_chars,'#:') if(pnd /= 0)then write(frmt,fmt)pnd-1 ! build format of form '(BN,Gn.0)' read(local_chars(:pnd-1),fmt=frmt,iostat=ierr,iomsg=msg)basevalue ! try to read value from string if(decodebase(local_chars(pnd+1:),basevalue,ivalu))then valu=real(ivalu,kind=kind(0.0d0)) else valu=0.0d0 ierr=-1 endif else select case(local_chars(1:1)) case('z','Z','h','H') ! assume hexadecimal write(frmt,"('(Z',i0,')')")len(local_chars) read(local_chars(2:),frmt,iostat=ierr,iomsg=msg)intg valu=dble(intg) case('b','B') ! assume binary (base 2) write(frmt,"('(B',i0,')')")len(local_chars) read(local_chars(2:),frmt,iostat=ierr,iomsg=msg)intg valu=dble(intg) case('o','O') ! assume octal write(frmt,"('(O',i0,')')")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 endif if(ierr /= 0)then ! if an error occurred ierr will be non-zero. if(present(onerr))then select type(onerr) type is (integer) valu=onerr type is (real) valu=onerr type is (doubleprecision) valu=onerr end select else ! set return value to NaN read(nan_string,'(f3.3)')valu endif if(local_chars /= 'eod')then ! print warning message except for special value "eod" call journal('*a2d* - cannot produce number from string ['//trim(chars)//']') if(msg /= '')then call journal('*a2d* - ['//trim(msg)//']') endif endif endif end subroutine a2d !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! split(3f) - [M_CLI2:TOKENS] parse string into an array using specified !! delimiters !! (LICENSE:PD) !! !!##SYNOPSIS !! !! subroutine split(input_line,array,delimiters,order,nulls) !! !! character(len=*),intent(in) :: input_line !! character(len=:),allocatable,intent(out) :: array(:) !! character(len=*),optional,intent(in) :: delimiters !! character(len=*),optional,intent(in) :: order !! character(len=*),optional,intent(in) :: nulls !!##DESCRIPTION !! SPLIT(3f) parses a string using specified delimiter characters and !! store tokens into an allocatable array !! !!##OPTIONS !! !! INPUT_LINE Input string to tokenize !! !! ARRAY Output array of tokens !! !! DELIMITERS List of delimiter characters. !! The default delimiters are the "whitespace" characters !! (space, tab,new line, vertical tab, formfeed, carriage !! return, and null). You may specify an alternate set of !! delimiter characters. !! !! Multi-character delimiters are not supported (Each !! character in the DELIMITERS list is considered to be !! a delimiter). !! !! Quoting of delimiter characters is not supported. !! !! ORDER SEQUENTIAL|REVERSE|RIGHT Order of output array. !! By default ARRAY contains the tokens having parsed !! the INPUT_LINE from left to right. If ORDER='RIGHT' !! or ORDER='REVERSE' the parsing goes from right to left. !! !! NULLS IGNORE|RETURN|IGNOREEND Treatment of null fields. !! By default adjacent delimiters in the input string !! do not create an empty string in the output array. if !! NULLS='return' adjacent delimiters create an empty element !! in the output ARRAY. If NULLS='ignoreend' then only !! trailing delimiters at the right of the string are ignored. !! !!##EXAMPLES !! !! Sample program: !! !! program demo_split !! use M_CLI2, only: split !! character(len=*),parameter :: & !! & line=' aBcdef ghijklmnop qrstuvwxyz 1:|:2 333|333 a B cc ' !! character(len=:),allocatable :: array(:) ! output array of tokens !! write(*,*)'INPUT LINE:['//LINE//']' !! write(*,'(80("="))') !! write(*,*)'typical call:' !! CALL split(line,array) !! write(*,'(i0," ==> ",a)')(i,trim(array(i)),i=1,size(array)) !! write(*,*)'SIZE:',SIZE(array) !! write(*,'(80("-"))') !! write(*,*)'custom list of delimiters (colon and vertical line):' !! CALL split(line,array,delimiters=':|',order='sequential',nulls='ignore') !! write(*,'(i0," ==> ",a)')(i,trim(array(i)),i=1,size(array)) !! write(*,*)'SIZE:',SIZE(array) !! write(*,'(80("-"))') !! write(*,*)& !! &'custom list of delimiters, reverse array order and count null fields:' !! CALL split(line,array,delimiters=':|',order='reverse',nulls='return') !! write(*,'(i0," ==> ",a)')(i,trim(array(i)),i=1,size(array)) !! write(*,*)'SIZE:',SIZE(array) !! write(*,'(80("-"))') !! write(*,*)'INPUT LINE:['//LINE//']' !! write(*,*)& !! &'default delimiters and reverse array order and return null fields:' !! CALL split(line,array,delimiters='',order='reverse',nulls='return') !! write(*,'(i0," ==> ",a)')(i,trim(array(i)),i=1,size(array)) !! write(*,*)'SIZE:',SIZE(array) !! end program demo_split !! !! Output !! !! > INPUT LINE:[ aBcdef ghijklmnop qrstuvwxyz 1:|:2 333|333 a B cc ] !! > =========================================================================== !! > typical call: !! > 1 ==> aBcdef !! > 2 ==> ghijklmnop !! > 3 ==> qrstuvwxyz !! > 4 ==> 1:|:2 !! > 5 ==> 333|333 !! > 6 ==> a !! > 7 ==> B !! > 8 ==> cc !! > SIZE: 8 !! > -------------------------------------------------------------------------- !! > custom list of delimiters (colon and vertical line): !! > 1 ==> aBcdef ghijklmnop qrstuvwxyz 1 !! > 2 ==> 2 333 !! > 3 ==> 333 a B cc !! > SIZE: 3 !! > -------------------------------------------------------------------------- !! > custom list of delimiters, reverse array order and return null fields: !! > 1 ==> 333 a B cc !! > 2 ==> 2 333 !! > 3 ==> !! > 4 ==> !! > 5 ==> aBcdef ghijklmnop qrstuvwxyz 1 !! > SIZE: 5 !! > -------------------------------------------------------------------------- !! > INPUT LINE:[ aBcdef ghijklmnop qrstuvwxyz 1:|:2 333|333 a B cc ] !! > default delimiters and reverse array order and count null fields: !! > 1 ==> !! > 2 ==> !! > 3 ==> !! > 4 ==> cc !! > 5 ==> B !! > 6 ==> a !! > 7 ==> 333|333 !! > 8 ==> !! > 9 ==> !! > 10 ==> !! > 11 ==> !! > 12 ==> 1:|:2 !! > 13 ==> !! > 14 ==> qrstuvwxyz !! > 15 ==> ghijklmnop !! > 16 ==> !! > 17 ==> !! > 18 ==> aBcdef !! > 19 ==> !! > 20 ==> !! > SIZE: 20 !!##AUTHOR !! John S. Urban !!##LICENSE !! Public Domain !=================================================================================================================================== subroutine split(input_line,array,delimiters,order,nulls) ! ident_18="@(#) M_CLI2 split(3f) parse string on delimiter characters and store tokens into an allocatable array" ! John S. Urban intrinsic index, min, present, len ! given a line of structure " par1 par2 par3 ... parn " store each par(n) into a separate variable in array. ! o by default adjacent delimiters in the input string do not create an empty string in the output array ! o no quoting of delimiters is supported character(len=*),intent(in) :: input_line ! input string to tokenize character(len=*),optional,intent(in) :: delimiters ! list of delimiter characters character(len=*),optional,intent(in) :: order ! order of output array sequential|[reverse|right] character(len=*),optional,intent(in) :: nulls ! return strings composed of delimiters or not ignore|return|ignoreend character(len=:),allocatable,intent(out) :: array(:) ! output array of tokens !----------------------------------------------------------------------------------------------------------------------------------- integer :: n ! max number of strings INPUT_LINE could split into if all delimiter integer,allocatable :: ibegin(:) ! positions in input string where tokens start integer,allocatable :: iterm(:) ! positions in input string where tokens end character(len=:),allocatable :: dlim ! string containing delimiter characters character(len=:),allocatable :: ordr ! string containing order keyword character(len=:),allocatable :: nlls ! string containing nulls keyword integer :: ii,iiii ! loop parameters used to control print order integer :: icount ! number of tokens found integer :: iilen ! length of input string with trailing spaces trimmed integer :: i10,i20,i30 ! loop counters integer :: icol ! pointer into input string as it is being parsed integer :: idlim ! number of delimiter characters integer :: ifound ! where next delimiter character is found in remaining input string data integer :: inotnull ! count strings not composed of delimiters integer :: ireturn ! number of tokens returned integer :: imax ! length of longest token !----------------------------------------------------------------------------------------------------------------------------------- ! decide on value for optional DELIMITERS parameter if (present(delimiters)) then ! optional delimiter list was present if(delimiters /= '')then ! if DELIMITERS was specified and not null use it dlim=delimiters else ! DELIMITERS was specified on call as empty string dlim=' '//char(9)//char(10)//char(11)//char(12)//char(13)//char(0)//',:' ! use default delimiter when not specified endif else ! no delimiter value was specified dlim=' '//char(9)//char(10)//char(11)//char(12)//char(13)//char(0)//',:' ! use default delimiter when not specified endif idlim=len(dlim) ! dlim a lot of blanks on some machines if dlim is a big string !----------------------------------------------------------------------------------------------------------------------------------- if(present(order))then; ordr=lower(adjustl(order)); else; ordr='sequential'; endif ! decide on value for optional ORDER parameter if(present(nulls))then; nlls=lower(adjustl(nulls)); else; nlls='ignore' ; endif ! optional parameter !----------------------------------------------------------------------------------------------------------------------------------- n=len(input_line)+1 ! max number of strings INPUT_LINE could split into if all delimiter if(allocated(ibegin))deallocate(ibegin) !x! intel compiler says allocated already ??? allocate(ibegin(n)) ! allocate enough space to hold starting location of tokens if string all tokens if(allocated(iterm))deallocate(iterm) !x! intel compiler says allocated already ??? allocate(iterm(n)) ! allocate enough space to hold ending location of tokens if string all tokens ibegin(:)=1 iterm(:)=1 !----------------------------------------------------------------------------------------------------------------------------------- iilen=len(input_line) ! IILEN is the column position of the last non-blank character icount=0 ! how many tokens found inotnull=0 ! how many tokens found not composed of delimiters imax=0 ! length of longest token found if(iilen > 0)then ! there is at least one non-delimiter in INPUT_LINE if get here icol=1 ! initialize pointer into input line INFINITE: do i30=1,iilen,1 ! store into each array element ibegin(i30)=icol ! assume start new token on the character if(index(dlim(1:idlim),input_line(icol:icol)) == 0)then ! if current character is not a delimiter iterm(i30)=iilen ! initially assume no more tokens do i10=1,idlim ! search for next delimiter ifound=index(input_line(ibegin(i30):iilen),dlim(i10:i10)) IF(ifound > 0)then iterm(i30)=min(iterm(i30),ifound+ibegin(i30)-2) endif enddo icol=iterm(i30)+2 ! next place to look as found end of this token inotnull=inotnull+1 ! increment count of number of tokens not composed of delimiters else ! character is a delimiter for a null string iterm(i30)=icol-1 ! record assumed end of string. Will be less than beginning icol=icol+1 ! advance pointer into input string endif imax=max(imax,iterm(i30)-ibegin(i30)+1) icount=i30 ! increment count of number of tokens found if(icol > iilen)then ! no text left exit INFINITE endif enddo INFINITE endif !----------------------------------------------------------------------------------------------------------------------------------- select case (clipends(nlls)) case ('ignore','','ignoreend') ireturn=inotnull case default ireturn=icount end select if(allocated(array))deallocate(array) allocate(character(len=imax) :: array(ireturn)) ! allocate the array to return !allocate(array(ireturn)) ! allocate the array to turn !----------------------------------------------------------------------------------------------------------------------------------- select case (clipends(ordr)) ! decide which order to store tokens case ('reverse','right') ; ii=ireturn ; iiii=-1 ! last to first case default ; ii=1 ; iiii=1 ! first to last end select !----------------------------------------------------------------------------------------------------------------------------------- do i20=1,icount ! fill the array with the tokens that were found if(iterm(i20) < ibegin(i20))then select case (clipends(nlls)) case ('ignore','','ignoreend') case default array(ii)=' ' ii=ii+iiii end select else array(ii)=input_line(ibegin(i20):iterm(i20)) ii=ii+iiii endif enddo !----------------------------------------------------------------------------------------------------------------------------------- end subroutine split !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! replace_str(3f) - [M_CLI2:EDITING] function globally replaces one !! substring for another in string !! (LICENSE:PD) !! !!##SYNOPSIS !! !! function replace_str(targetline,old,new,range,ierr) result (newline) !! !! character(len=*) :: targetline !! character(len=*),intent(in) :: old !! character(len=*),intent(in) :: new !! integer,intent(in),optional :: range(2) !! integer,intent(out),optional :: ierr !! logical,intent(in),optional :: clip !! character(len=:),allocatable :: newline !!##DESCRIPTION !! Globally replace one substring for another in string. !! Either CMD or OLD and NEW must be specified. !! !!##OPTIONS !! targetline input line to be changed !! old old substring to replace !! new new substring !! range if present, only change range(1) to range(2) of !! occurrences of old string !! ierr error code. If ier = -1 bad directive, >= 0 then !! count of changes made !! clip whether to return trailing spaces or not. Defaults to .false. !!##RETURNS !! newline allocatable string returned !! !!##EXAMPLES !! !! Sample Program: !! !! program demo_replace_str !! use M_CLI2, only : replace_str !! implicit none !! character(len=:),allocatable :: targetline !! !! targetline='this is the input string' !! !! call testit('th','TH','THis is THe input string') !! !! ! a null old substring means "at beginning of line" !! call testit('','BEFORE:', 'BEFORE:THis is THe input string') !! !! ! a null new string deletes occurrences of the old substring !! call testit('i','', 'BEFORE:THs s THe nput strng') !! !! targetline=replace_str('a b ab baaa aaaa','a','A') !! write(*,*)'replace a with A ['//targetline//']' !! !! write(*,*)'Examples of the use of RANGE=' !! !! targetline=replace_str('a b ab baaa aaaa','a','A',range=[3,5]) !! write(*,*)'replace a with A instances 3 to 5 ['//targetline//']' !! !! targetline=replace_str('a b ab baaa aaaa','a','',range=[3,5]) !! write(*,*)'replace a with null instances 3 to 5 ['//targetline//']' !! !! targetline=replace_str('a b ab baaa aaaa aa aa a a a aa aaaaaa',& !! & 'aa','CCCC',range=[3,5]) !! write(*,*)'replace aa with CCCC instances 3 to 5 ['//targetline//']' !! !! contains !! subroutine testit(old,new,expected) !! character(len=*),intent(in) :: old,new,expected !! write(*,*)repeat('=',79) !! write(*,*)':STARTED ['//targetline//']' !! write(*,*)':OLD['//old//']', ' NEW['//new//']' !! targetline=replace_str(targetline,old,new) !! write(*,*)':GOT ['//targetline//']' !! write(*,*)':EXPECTED['//expected//']' !! write(*,*)':TEST [',targetline == expected,']' !! end subroutine testit !! !! end program demo_replace_str !! !! Expected output !! !! =============================================================================== !! STARTED [this is the input string] !! OLD[th] NEW[TH] !! GOT [THis is THe input string] !! EXPECTED[THis is THe input string] !! TEST [ T ] !! =============================================================================== !! STARTED [THis is THe input string] !! OLD[] NEW[BEFORE:] !! GOT [BEFORE:THis is THe input string] !! EXPECTED[BEFORE:THis is THe input string] !! TEST [ T ] !! =============================================================================== !! STARTED [BEFORE:THis is THe input string] !! OLD[i] NEW[] !! GOT [BEFORE:THs s THe nput strng] !! EXPECTED[BEFORE:THs s THe nput strng] !! TEST [ T ] !! replace a with A [A b Ab bAAA AAAA] !! Examples of the use of RANGE= !! replace a with A instances 3 to 5 [a b ab bAAA aaaa] !! replace a with null instances 3 to 5 [a b ab b aaaa] !! replace aa with CCCC instances 3 to 5 [a b ab baaa aaCCCC CCCC CCCC !! a a a aa aaaaaa] !! !!##AUTHOR !! John S. Urban !!##LICENSE !! Public Domain !=================================================================================================================================== function replace_str(targetline,old,new,ierr,range) result (newline) ! ident_19="@(#) M_CLI2 replace_str(3f) Globally replace one substring for another in string" !----------------------------------------------------------------------------------------------------------------------------------- ! parameters character(len=*),intent(in) :: targetline ! input line to be changed character(len=*),intent(in) :: old ! old substring to replace character(len=*),intent(in) :: new ! new substring integer,intent(out),optional :: ierr ! error code. If ierr = -1 bad directive, >=0 then ierr changes made integer,intent(in),optional :: range(2) ! start and end of which changes to make !----------------------------------------------------------------------------------------------------------------------------------- ! returns character(len=:),allocatable :: newline ! output string buffer !----------------------------------------------------------------------------------------------------------------------------------- ! local integer :: icount,ichange integer :: original_input_length integer :: len_old, len_new integer :: ladd integer :: left_margin, right_margin integer :: ind integer :: ic integer :: iichar integer :: range_local(2) !----------------------------------------------------------------------------------------------------------------------------------- icount=0 ! initialize error flag/change count ichange=0 ! initialize error flag/change count original_input_length=len_trim(targetline) ! get non-blank length of input line len_old=len(old) ! length of old substring to be replaced len_new=len(new) ! length of new substring to replace old substring left_margin=1 ! left_margin is left margin of window to change right_margin=len(targetline) ! right_margin is right margin of window to change newline='' ! begin with a blank line as output string !----------------------------------------------------------------------------------------------------------------------------------- if(present(range))then range_local=range else range_local=[1,original_input_length] endif !----------------------------------------------------------------------------------------------------------------------------------- if(len_old == 0)then ! c//new/ means insert new at beginning of line (or left margin) iichar=len_new + original_input_length if(len_new > 0)then newline=new(:len_new)//targetline(left_margin:original_input_length) else newline=targetline(left_margin:original_input_length) endif ichange=1 ! made one change. actually, c/// should maybe return 0 if(present(ierr))ierr=ichange return endif !----------------------------------------------------------------------------------------------------------------------------------- iichar=left_margin ! place to put characters into output string ic=left_margin ! place looking at in input string loop: do ind=index(targetline(ic:),old(:len_old))+ic-1 ! try finding start of OLD in remaining part of input in change window if(ind == ic-1.or.ind > right_margin)then ! did not find old string or found old string past edit window exit loop ! no more changes left to make endif icount=icount+1 ! found an old string to change, so increment count of change candidates if(ind > 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 newline=newline(:iichar-1)//targetline(ic:ind-1) iichar=iichar+ladd endif if(icount >= range_local(1).and.icount <= range_local(2))then ! check if this is an instance to change or keep ichange=ichange+1 if(len_new /= 0)then ! put in new string newline=newline(:iichar-1)//new(:len_new) iichar=iichar+len_new endif else if(len_old /= 0)then ! put in copy of old string newline=newline(:iichar-1)//old(:len_old) iichar=iichar+len_old endif endif ic=ind+len_old enddo loop !----------------------------------------------------------------------------------------------------------------------------------- select case (ichange) case (0) ! there were no changes made to the window newline=targetline ! if no changes made output should be input case default if(ic <= len(targetline))then ! if there is more after last change on original line add it newline=newline(:iichar-1)//targetline(ic:max(ic,original_input_length)) endif end select if(present(ierr))ierr=ichange !----------------------------------------------------------------------------------------------------------------------------------- end function replace_str !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()= !=================================================================================================================================== !> !!##NAME !! quote(3f) - [M_CLI2:QUOTES] add quotes to string as if written with !! list-directed input !! (LICENSE:PD) !!##SYNOPSIS !! !! function quote(str,mode,clip) result (quoted_str) !! !! character(len=*),intent(in) :: str !! character(len=*),optional,intent(in) :: mode !! logical,optional,intent(in) :: clip !! character(len=:),allocatable :: quoted_str !!##DESCRIPTION !! Add quotes to a CHARACTER variable as if it was written using !! list-directed input. This is particularly useful for processing !! strings to add to CSV files. !! !!##OPTIONS !! str input string to add quotes to, using the rules of !! list-directed input (single quotes are replaced by two !! adjacent quotes) !! mode alternate quoting methods are supported: !! !! DOUBLE default. replace quote with double quotes !! ESCAPE replace quotes with backslash-quote instead !! of double quotes !! !! clip default is to trim leading and trailing spaces from the !! string. If CLIP !! is .FALSE. spaces are not trimmed !! !!##RESULT !! quoted_str The output string, which is based on adding quotes to STR. !!##EXAMPLE !! !! Sample program: !! !! program demo_quote !! use M_CLI2, only : quote !! implicit none !! character(len=:),allocatable :: str !! character(len=1024) :: msg !! integer :: ios !! character(len=80) :: inline !! do !! write(*,'(a)',advance='no')'Enter test string:' !! read(*,'(a)',iostat=ios,iomsg=msg)inline !! if(ios /= 0)then !! write(*,*)trim(inline) !! exit !! endif !! !! ! the original string !! write(*,'(a)')'ORIGINAL ['//trim(inline)//']' !! !! ! the string processed by quote(3f) !! str=quote(inline) !! write(*,'(a)')'QUOTED ['//str//']' !! !! ! write the string list-directed to compare the results !! write(*,'(a)',iostat=ios,iomsg=msg) 'LIST DIRECTED:' !! write(*,*,iostat=ios,iomsg=msg,delim='none') inline !! write(*,*,iostat=ios,iomsg=msg,delim='quote') inline !! write(*,*,iostat=ios,iomsg=msg,delim='apostrophe') inline !! enddo !! end program demo_quote !! !!##AUTHOR !! John S. Urban !!##LICENSE !! Public Domain !----------------------------------------------------------------------------------------------------------------------------------- function quote(str,mode,clip) result (quoted_str) character(len=*),intent(in) :: str ! the string to be quoted character(len=*),optional,intent(in) :: mode logical,optional,intent(in) :: clip logical :: clip_local character(len=:),allocatable :: quoted_str character(len=1),parameter :: double_quote = '"' character(len=20) :: local_mode if(present(mode))then local_mode=mode else local_mode='DOUBLE' endif if(present(clip))then clip_local=clip else clip_local=.false. endif if(clip_local)then quoted_str=adjustl(str) else quoted_str=str endif select case(lower(local_mode)) case('double') quoted_str=double_quote//trim(replace_str(quoted_str,'"','""'))//double_quote case('escape') quoted_str=double_quote//trim(replace_str(quoted_str,'"','\"'))//double_quote case default call journal('*quote* ERROR: unknown quote mode ',local_mode) quoted_str=str end select end function quote !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()= !=================================================================================================================================== !> !!##NAME !! unquote(3f) - [M_CLI2:QUOTES] remove quotes from string as if read !! with list-directed input !! (LICENSE:PD) !!##SYNOPSIS !! !! pure function unquote(quoted_str,esc) result (unquoted_str) !! !! character(len=*),intent(in) :: quoted_str !! character(len=1),optional,intent(in) :: esc !! character(len=:),allocatable :: unquoted_str !!##DESCRIPTION !! Remove quotes from a CHARACTER variable as if it was read using !! list-directed input. This is particularly useful for processing !! tokens read from input such as CSV files. !! !! Fortran can now read using list-directed input from an internal file, !! which should handle quoted strings, but list-directed input does not !! support escape characters, which UNQUOTE(3f) does. !!##OPTIONS !! quoted_str input string to remove quotes from, using the rules of !! list-directed input (two adjacent quotes inside a quoted !! region are replaced by a single quote, a single quote or !! double quote is selected as the delimiter based on which !! is encountered first going from left to right, ...) !! esc optional character used to protect the next quote !! character from being processed as a quote, but simply as !! a plain character. !!##RESULT !! unquoted_str The output string, which is based on removing quotes !! from quoted_str. !!##EXAMPLE !! !! Sample program: !! !! program demo_unquote !! use M_CLI2, only : unquote !! implicit none !! character(len=128) :: quoted_str !! character(len=:),allocatable :: unquoted_str !! character(len=1),parameter :: esc='\' !! character(len=1024) :: msg !! integer :: ios !! character(len=1024) :: dummy !! do !! write(*,'(a)',advance='no')'Enter test string:' !! read(*,'(a)',iostat=ios,iomsg=msg)quoted_str !! if(ios /= 0)then !! write(*,*)trim(msg) !! exit !! endif !! !! ! the original string !! write(*,'(a)')'QUOTED ['//trim(quoted_str)//']' !! !! ! the string processed by unquote(3f) !! unquoted_str=unquote(trim(quoted_str),esc) !! write(*,'(a)')'UNQUOTED ['//unquoted_str//']' !! !! ! read the string list-directed to compare the results !! read(quoted_str,*,iostat=ios,iomsg=msg)dummy !! if(ios /= 0)then !! write(*,*)trim(msg) !! else !! write(*,'(a)')'LIST DIRECTED['//trim(dummy)//']' !! endif !! enddo !! end program demo_unquote !! !!##AUTHOR !! John S. Urban !!##LICENSE !! Public Domain !=================================================================================================================================== pure function unquote(quoted_str,esc) result (unquoted_str) character(len=*),intent(in) :: quoted_str ! the string to be unquoted character(len=1),optional,intent(in) :: esc ! escape character character(len=:),allocatable :: unquoted_str integer :: inlen character(len=1),parameter :: single_quote = "'" character(len=1),parameter :: double_quote = '"' integer :: quote ! whichever quote is to be used integer :: before integer :: current integer :: iesc integer :: iput integer :: i logical :: inside !----------------------------------------------------------------------------------------------------------------------------------- if(present(esc))then ! select escape character as specified character or special value meaning not set iesc=ichar(esc) ! allow for an escape character else iesc=-1 ! set to value that matches no character endif !----------------------------------------------------------------------------------------------------------------------------------- inlen=len(quoted_str) ! find length of input string if(allocated(unquoted_str))deallocate(unquoted_str) allocate(character(len=inlen) :: unquoted_str) ! initially make output string length of input string !----------------------------------------------------------------------------------------------------------------------------------- if(inlen >= 1)then ! double_quote is the default quote unless the first character is single_quote if(quoted_str(1:1) == single_quote)then quote=ichar(single_quote) else quote=ichar(double_quote) endif else quote=ichar(double_quote) endif !----------------------------------------------------------------------------------------------------------------------------------- before=-2 ! initially set previous character to impossible value unquoted_str(:)='' ! initialize output string to null string iput=1 inside=.false. STEPTHROUGH: do i=1,inlen current=ichar(quoted_str(i:i)) if(before == iesc)then ! if previous character was escape use current character unconditionally iput=iput-1 ! backup unquoted_str(iput:iput)=char(current) iput=iput+1 before=-2 ! this could be second esc or quote elseif(current == quote)then ! if current is a quote it depends on whether previous character was a quote if(before == quote)then unquoted_str(iput:iput)=char(quote) ! this is second quote so retain it iput=iput+1 before=-2 elseif(.not.inside.and.before /= iesc)then inside=.true. else ! this is first quote so ignore it except remember it in case next is a quote before=current endif else unquoted_str(iput:iput)=char(current) iput=iput+1 before=current endif enddo STEPTHROUGH !----------------------------------------------------------------------------------------------------------------------------------- unquoted_str=unquoted_str(:iput-1) !----------------------------------------------------------------------------------------------------------------------------------- end function unquote !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! !! decodebase(3f) - [M_CLI2:BASE] convert whole number string in base !! [2-36] to base 10 number !! (LICENSE:PD) !! !!##SYNOPSIS !! !! logical function decodebase(string,basein,out10) !! !! character(len=*),intent(in) :: string !! integer,intent(in) :: basein !! integer,intent(out) :: out10 !!##DESCRIPTION !! !! Convert a numeric string representing a whole number in base BASEIN !! to base 10. The function returns FALSE if BASEIN is not in the range !! [2..36] or if string STRING contains invalid characters in base BASEIN !! or if result OUT10 is too big !! !! The letters A,B,...,Z represent 10,11,...,36 in the base > 10. !! !!##OPTIONS !! string input string. It represents a whole number in !! the base specified by BASEIN unless BASEIN is set !! to zero. When BASEIN is zero STRING is assumed to !! be of the form BASE#VALUE where BASE represents !! the function normally provided by BASEIN. !! basein base of input string; either 0 or from 2 to 36. !! out10 output value in base 10 !! !!##EXAMPLE !! !! Sample program: !! !! program demo_decodebase !! use M_CLI2, only : codebase, decodebase !! implicit none !! integer :: ba,bd !! character(len=40) :: x,y !! integer :: r !! !! print *,' BASE CONVERSION' !! write(*,'("Start Base (2 to 36): ")',advance='no'); read *, bd !! write(*,'("Arrival Base (2 to 36): ")',advance='no'); read *, ba !! INFINITE: do !! print *,'' !! write(*,'("Enter number in start base: ")',advance='no'); read *, x !! if(x == '0') exit INFINITE !! if(decodebase(x,bd,r)) then !! if(codebase(r,ba,y)) then !! write(*,'("In base ",I2,": ",A20)') ba, y !! else !! print *,'Error in coding number.' !! endif !! else !! print *,'Error in decoding number.' !! endif !! enddo INFINITE !! !! end program demo_decodebase !! !!##AUTHOR !! John S. Urban !! !! Ref.: "Math matiques en Turbo-Pascal by !! M. Ducamp and A. Reverchon (2), !! Eyrolles, Paris, 1988". !! !! based on a F90 Version By J-P Moreau (www.jpmoreau.fr) !! !!##LICENSE !! Public Domain logical function decodebase(string,basein,out_baseten) ! ident_20="@(#) M_CLI2 decodebase(3f) convert whole number string in base [2-36] to base 10 number" character(len=*),intent(in) :: string integer,intent(in) :: basein integer,intent(out) :: out_baseten character(len=len(string)) :: string_local integer :: long, i, j, k real :: y real :: mult character(len=1) :: ch real,parameter :: XMAXREAL=real(huge(1)) integer :: out_sign integer :: basein_local integer :: ipound integer :: ierr string_local=upper(clipends(string)) decodebase=.false. ipound=index(string_local,'#') ! determine if in form [-]base#whole if(basein == 0.and.ipound > 1)then ! split string into two values call a2i(string_local(:ipound-1),basein_local,ierr) ! get the decimal value of the base string_local=string_local(ipound+1:) ! now that base is known make string just the value if(basein_local >= 0)then ! allow for a negative sign prefix out_sign=1 else out_sign=-1 endif basein_local=abs(basein_local) else ! assume string is a simple positive value basein_local=abs(basein) out_sign=1 endif out_baseten=0 y=0.0 ALL: if(basein_local<2.or.basein_local>36) then print *,'(*decodebase* ERROR: Base must be between 2 and 36. base=',basein_local else ALL out_baseten=0;y=0.0; mult=1.0 long=LEN_TRIM(string_local) do i=1, long k=long+1-i ch=string_local(k:k) IF(CH == '-'.AND.K == 1)THEN out_sign=-1 cycle endif if(ch<'0'.or.ch>'Z'.or.(ch>'9'.and.ch<'A'))then write(*,*)'*decodebase* ERROR: invalid character ',ch exit ALL endif if(ch<='9') then j=IACHAR(ch)-IACHAR('0') else j=IACHAR(ch)-IACHAR('A')+10 endif if(j>=basein_local)then exit ALL endif y=y+mult*j if(mult>XMAXREAL/basein_local)then exit ALL endif mult=mult*basein_local enddo decodebase=.true. out_baseten=nint(out_sign*y)*sign(1,basein) endif ALL end function decodebase !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! locate_(3f) - [M_CLI2] finds the index where a string is found or !! should be in a sorted array !! (LICENSE:PD) !! !!##SYNOPSIS !! !! subroutine locate_(list,value,place,ier,errmsg) !! !! character(len=:)|doubleprecision|real|integer,allocatable :: list(:) !! character(len=*)|doubleprecision|real|integer,intent(in) :: value !! integer, intent(out) :: PLACE !! !! integer, intent(out),optional :: IER !! character(len=*),intent(out),optional :: ERRMSG !! !!##DESCRIPTION !! !! LOCATE_(3f) finds the index where the VALUE is found or should !! be found in an array. The array must be sorted in descending !! order (highest at top). If VALUE is not found it returns the index !! where the name should be placed at with a negative sign. !! !! The array and list must be of the same type (CHARACTER, DOUBLEPRECISION, !! REAL,INTEGER) !! !!##OPTIONS !! !! VALUE the value to locate in the list. !! LIST is the list array. !! !!##RETURNS !! PLACE is the subscript that the entry was found at if it is !! greater than zero(0). !! !! If PLACE is negative, the absolute value of !! PLACE indicates the subscript value where the !! new entry should be placed in order to keep the !! list alphabetized. !! !! IER is zero(0) if no error occurs. !! If an error occurs and IER is not !! present, the program is stopped. !! !! ERRMSG description of any error !! !!##EXAMPLES !! !! !! Find if a string is in a sorted array, and insert the string into !! the list if it is not present ... !! !! program demo_locate !! use M_sort, only : sort_shell !! use M_CLI2, only : locate_ !! implicit none !! character(len=:),allocatable :: arr(:) !! integer :: i !! !! arr=[character(len=20) :: '', 'ZZZ', 'aaa', 'b', 'xxx' ] !! ! make sure sorted in descending order !! call sort_shell(arr,order='d') !! !! call update_dic(arr,'b') !! call update_dic(arr,'[') !! call update_dic(arr,'c') !! call update_dic(arr,'ZZ') !! call update_dic(arr,'ZZZZ') !! call update_dic(arr,'z') !! !! contains !! subroutine update_dic(arr,string) !! character(len=:),intent(in),allocatable :: arr(:) !! character(len=*),intent(in) :: string !! integer :: place, plus, ii, end !! ! find where string is or should be !! call locate_(arr,string,place) !! write(*,*)'for "'//string//'" index is ',place, size(arr) !! ! if string was not found insert it !! if(place < 1)then !! plus=abs(place) !! ii=len(arr) !! end=size(arr) !! ! empty array !! if(end == 0)then !! arr=[character(len=ii) :: string ] !! ! put in front of array !! elseif(plus == 1)then !! arr=[character(len=ii) :: string, arr] !! ! put at end of array !! elseif(plus == end)then !! arr=[character(len=ii) :: arr, string ] !! ! put in middle of array !! else !! arr=[character(len=ii) :: arr(:plus-1), string,arr(plus:) ] !! endif !! ! show array !! write(*,'("SIZE=",i0,1x,*(a,","))')end,(trim(arr(i)),i=1,end) !! endif !! end subroutine update_dic !! end program demo_locate !! !! Results: !! !! for "b" index is 2 5 !! for "[" index is -4 5 !! SIZE=5 xxx,b,aaa,[,ZZZ, !! for "c" index is -2 6 !! SIZE=6 xxx,c,b,aaa,[,ZZZ, !! for "ZZ" index is -7 7 !! SIZE=7 xxx,c,b,aaa,[,ZZZ,, !! for "ZZZZ" index is -6 8 !! SIZE=8 xxx,c,b,aaa,[,ZZZZ,ZZZ,, !! for "z" index is -1 9 !! SIZE=9 z,xxx,c,b,aaa,[,ZZZZ,ZZZ,, !! !!##AUTHOR !! 1989,2017 John S. Urban !!##LICENSE !! Public Domain subroutine locate_c(list,value,place,ier,errmsg) ! ident_21="@(#) M_CLI2 locate_c(3f) find PLACE in sorted character array LIST where VALUE can be found or should be placed" character(len=*),intent(in) :: value integer,intent(out) :: place character(len=:),allocatable :: list(:) integer,intent(out),optional :: ier character(len=*),intent(out),optional :: errmsg integer :: i character(len=:),allocatable :: message integer :: arraysize integer :: maxtry integer :: imin, imax integer :: error if(.not.allocated(list))then list=[character(len=max(len_trim(value),2)) :: ] endif arraysize=size(list) error=0 if(arraysize == 0)then maxtry=0 place=-1 else maxtry=nint(log(float(arraysize))/log(2.0)+1.0) place=(arraysize+1)/2 endif imin=1 imax=arraysize message='' LOOP: block do i=1,maxtry if(value == list(PLACE))then exit LOOP elseif(value > list(place))then imax=place-1 else imin=place+1 endif if(imin > imax)then place=-imin if(iabs(place) > arraysize)then ! ran off end of list. Where new value should go or an unsorted input array' exit LOOP endif exit LOOP endif place=(imax+imin)/2 if(place > arraysize.or.place <= 0)then message='*locate_* error: search is out of bounds of list. Probably an unsorted input array' error=-1 exit LOOP endif enddo message='*locate_* exceeded allowed tries. Probably an unsorted input array' endblock LOOP if(present(ier))then ier=error elseif(error /= 0)then write(warn,*)message//' VALUE=',trim(value)//' PLACE=',place call mystop(-24,'(*locate_c* '//message) endif if(present(errmsg))then errmsg=message endif end subroutine locate_c !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()= !=================================================================================================================================== !> !!##NAME !! remove_(3f) - [M_CLI2] remove entry from an allocatable array at specified position !! (LICENSE:PD) !! !!##SYNOPSIS !! !! subroutine remove_(list,place) !! !! character(len=:)|doubleprecision|real|integer,intent(inout) :: list(:) !! integer, intent(out) :: PLACE !! !!##DESCRIPTION !! !! Remove a value from an allocatable array at the specified index. !! The array is assumed to be sorted in descending order. It may be of !! type CHARACTER, DOUBLEPRECISION, REAL, or INTEGER. !! !!##OPTIONS !! !! list is the list array. !! PLACE is the subscript for the entry that should be removed !! !!##EXAMPLES !! !! !! Sample program !! !! program demo_remove !! use M_sort, only : sort_shell !! use M_CLI2, only : locate_, remove_ !! implicit none !! character(len=:),allocatable :: arr(:) !! integer :: i !! integer :: end !! !! arr=[character(len=20) :: '', 'ZZZ', 'Z', 'aaa', 'b', 'b', 'ab', 'bb', 'xxx' ] !! ! make sure sorted in descending order !! call sort_shell(arr,order='d') !! !! end=size(arr) !! write(*,'("SIZE=",i0,1x,*(a,","))')end,(trim(arr(i)),i=1,end) !! call remove_(arr,1) !! end=size(arr) !! write(*,'("SIZE=",i0,1x,*(a,","))')end,(trim(arr(i)),i=1,end) !! call remove_(arr,4) !! end=size(arr) !! write(*,'("SIZE=",i0,1x,*(a,","))')end,(trim(arr(i)),i=1,end) !! !! end program demo_remove !! !! Results: !! !! Expected output !! !! SIZE=9 xxx,bb,b,b,ab,aaa,ZZZ,Z,, !! SIZE=8 bb,b,b,ab,aaa,ZZZ,Z,, !! SIZE=7 bb,b,b,aaa,ZZZ,Z,, !! !!##AUTHOR !! 1989,2017 John S. Urban !!##LICENSE !! Public Domain subroutine remove_c(list,place) ! ident_22="@(#) M_CLI2 remove_c(3fp) remove string from allocatable string array at specified position" character(len=:),allocatable :: list(:) integer,intent(in) :: place integer :: ii, end if(.not.allocated(list))then list=[character(len=2) :: ] endif ii=len(list) end=size(list) if(place <= 0.or.place > end)then ! index out of bounds of array elseif(place == end)then ! remove from array list=[character(len=ii) :: list(:place-1) ] else list=[character(len=ii) :: list(:place-1), list(place+1:) ] endif end subroutine remove_c subroutine remove_l(list,place) ! ident_23="@(#) M_CLI2 remove_l(3fp) remove value from allocatable array at specified position" logical,allocatable :: list(:) integer,intent(in) :: place integer :: end if(.not.allocated(list))then list=[logical :: ] endif end=size(list) if(place <= 0.or.place > end)then ! index out of bounds of array elseif(place == end)then ! remove from array list=[ list(:place-1)] else list=[ list(:place-1), list(place+1:) ] endif end subroutine remove_l subroutine remove_i(list,place) ! ident_24="@(#) M_CLI2 remove_i(3fp) remove value from allocatable array at specified position" integer,allocatable :: list(:) integer,intent(in) :: place integer :: end if(.not.allocated(list))then list=[integer :: ] endif end=size(list) if(place <= 0.or.place > end)then ! index out of bounds of array elseif(place == end)then ! remove from array list=[ list(:place-1)] else list=[ list(:place-1), list(place+1:) ] endif end subroutine remove_i !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()= !=================================================================================================================================== !> !!##NAME !! replace_(3f) - [M_CLI2] replace entry in a string array at specified position !! (LICENSE:PD) !! !!##SYNOPSIS !! !! subroutine replace_(list,value,place) !! !! character(len=*)|doubleprecision|real|integer,intent(in) :: value !! character(len=:)|doubleprecision|real|integer,intent(in) :: list(:) !! integer, intent(out) :: place !! !!##DESCRIPTION !! !! replace a value in an allocatable array at the specified index. Unless the !! array needs the string length to increase this is merely an assign of a value !! to an array element. !! !! The array may be of type CHARACTER, DOUBLEPRECISION, REAL, or INTEGER> !! It is assumed to be sorted in descending order without duplicate values. !! !! The value and list must be of the same type. !! !!##OPTIONS !! !! VALUE the value to place in the array !! LIST is the array. !! PLACE is the subscript that the entry should be placed at !! !!##EXAMPLES !! !! !! Replace key-value pairs in a dictionary !! !! program demo_replace !! use M_CLI2, only : insert_, locate_, replace_ !! ! Find if a key is in a list and insert it !! ! into the key list and value list if it is not present !! ! or replace the associated value if the key existed !! implicit none !! character(len=20) :: key !! character(len=100) :: val !! character(len=:),allocatable :: keywords(:) !! character(len=:),allocatable :: values(:) !! integer :: i !! integer :: place !! call update_dic('b','value of b') !! call update_dic('a','value of a') !! call update_dic('c','value of c') !! call update_dic('c','value of c again') !! call update_dic('d','value of d') !! call update_dic('a','value of a again') !! ! show array !! write(*,'(*(a,"==>",a,/))')(trim(keywords(i)),trim(values(i)),i=1,size(keywords)) !! !! call locate_key('a',place) !! if(place > 0)then !! write(*,*)'The value of "a" is',trim(values(place)) !! else !! write(*,*)'"a" not found' !! endif !! !! contains !! subroutine update_dic(key,val) !! character(len=*),intent(in) :: key !! character(len=*),intent(in) :: val !! integer :: place !! !! ! find where string is or should be !! call locate_key(key,place) !! ! if string was not found insert it !! if(place < 1)then !! call insert_(keywords,key,abs(place)) !! call insert_(values,val,abs(place)) !! else ! replace !! call replace_(values,val,place) !! endif !! !! end subroutine update_dic !! end program demo_replace !! !! Expected output !! !! d==>value of d !! c==>value of c again !! b==>value of b !! a==>value of a again !! !!##AUTHOR !! 1989,2017 John S. Urban !!##LICENSE !! Public Domain subroutine replace_c(list,value,place) ! ident_25="@(#) M_CLI2 replace_c(3fp) replace string in allocatable string array at specified position" character(len=*),intent(in) :: value character(len=:),allocatable :: list(:) character(len=:),allocatable :: kludge(:) integer,intent(in) :: place integer :: ii integer :: tlen integer :: end if(.not.allocated(list))then list=[character(len=max(len_trim(value),2)) :: ] endif tlen=len_trim(value) end=size(list) if(place < 0.or.place > end)then write(warn,*)'*replace_c* error: index out of range. end=',end,' index=',place elseif(len_trim(value) <= len(list))then list(place)=value else ! increase length of variable ii=max(tlen,len(list)) kludge=[character(len=ii) :: list ] list=kludge list(place)=value endif end subroutine replace_c subroutine replace_l(list,value,place) ! ident_26="@(#) M_CLI2 replace_l(3fp) place value into allocatable array at specified position" logical,allocatable :: list(:) logical,intent(in) :: value integer,intent(in) :: place integer :: end if(.not.allocated(list))then list=[logical :: ] endif end=size(list) if(end == 0)then ! empty array list=[value] elseif(place > 0.and.place <= end)then list(place)=value else ! put in middle of array write(warn,*)'*replace_l* error: index out of range. end=',end,' index=',place endif end subroutine replace_l subroutine replace_i(list,value,place) ! ident_27="@(#) M_CLI2 replace_i(3fp) place value into allocatable array at specified position" integer,intent(in) :: value integer,allocatable :: list(:) integer,intent(in) :: place integer :: end if(.not.allocated(list))then list=[integer :: ] endif end=size(list) if(end == 0)then ! empty array list=[value] elseif(place > 0.and.place <= end)then list(place)=value else ! put in middle of array write(warn,*)'*replace_i* error: index out of range. end=',end,' index=',place endif end subroutine replace_i !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()= !=================================================================================================================================== !> !!##NAME !! insert_(3f) - [M_CLI2] insert entry into a string array at specified position !! (LICENSE:PD) !! !!##SYNOPSIS !! !! subroutine insert_(list,value,place) !! !! character(len=*)|doubleprecision|real|integer,intent(in) :: value !! character(len=:)|doubleprecision|real|integer,intent(in) :: list(:) !! integer,intent(in) :: place !! !!##DESCRIPTION !! !! Insert a value into an allocatable array at the specified index. !! The list and value must be of the same type (CHARACTER, DOUBLEPRECISION, !! REAL, or INTEGER) !! !!##OPTIONS !! !! list is the list array. Must be sorted in descending order. !! value the value to place in the array !! PLACE is the subscript that the entry should be placed at !! !!##EXAMPLES !! !! !! Find if a string is in a sorted array, and insert the string into !! the list if it is not present ... !! !! program demo_insert !! use M_sort, only : sort_shell !! use M_CLI2, only : locate_, insert_ !! implicit none !! character(len=:),allocatable :: arr(:) !! integer :: i !! !! arr=[character(len=20) :: '', 'ZZZ', 'aaa', 'b', 'xxx' ] !! ! make sure sorted in descending order !! call sort_shell(arr,order='d') !! ! add or replace values !! call update_dic(arr,'b') !! call update_dic(arr,'[') !! call update_dic(arr,'c') !! call update_dic(arr,'ZZ') !! call update_dic(arr,'ZZZ') !! call update_dic(arr,'ZZZZ') !! call update_dic(arr,'') !! call update_dic(arr,'z') !! !! contains !! subroutine update_dic(arr,string) !! character(len=:),allocatable :: arr(:) !! character(len=*) :: string !! integer :: place, end !! !! end=size(arr) !! ! find where string is or should be !! call locate_(arr,string,place) !! ! if string was not found insert it !! if(place < 1)then !! call insert_(arr,string,abs(place)) !! endif !! ! show array !! end=size(arr) !! write(*,'("array is now SIZE=",i0,1x,*(a,","))')end,(trim(arr(i)),i=1,end) !! !! end subroutine update_dic !! end program demo_insert !! !! Results: !! !! array is now SIZE=5 xxx,b,aaa,ZZZ,, !! array is now SIZE=6 xxx,b,aaa,[,ZZZ,, !! array is now SIZE=7 xxx,c,b,aaa,[,ZZZ,, !! array is now SIZE=8 xxx,c,b,aaa,[,ZZZ,ZZ,, !! array is now SIZE=9 xxx,c,b,aaa,[,ZZZZ,ZZZ,ZZ,, !! array is now SIZE=10 z,xxx,c,b,aaa,[,ZZZZ,ZZZ,ZZ,, !! !!##AUTHOR !! 1989,2017 John S. Urban !!##LICENSE !! Public Domain subroutine insert_c(list,value,place) ! ident_28="@(#) M_CLI2 insert_c(3fp) place string into allocatable string array at specified position" character(len=*),intent(in) :: value character(len=:),allocatable :: list(:) character(len=:),allocatable :: kludge(:) integer,intent(in) :: place integer :: ii integer :: end if(.not.allocated(list))then list=[character(len=max(len_trim(value),2)) :: ] endif ii=max(len_trim(value),len(list),2) end=size(list) if(end == 0)then ! empty array list=[character(len=ii) :: value ] elseif(place == 1)then ! put in front of array kludge=[character(len=ii) :: value, list] list=kludge elseif(place > end)then ! put at end of array kludge=[character(len=ii) :: list, value ] list=kludge elseif(place >= 2.and.place <= end)then ! put in middle of array kludge=[character(len=ii) :: list(:place-1), value,list(place:) ] list=kludge else ! index out of range write(warn,*)'*insert_c* error: index out of range. end=',end,' index=',place,' value=',value endif end subroutine insert_c subroutine insert_l(list,value,place) ! ident_29="@(#) M_CLI2 insert_l(3fp) place value into allocatable array at specified position" logical,allocatable :: list(:) logical,intent(in) :: value integer,intent(in) :: place integer :: end if(.not.allocated(list))then list=[logical :: ] endif end=size(list) if(end == 0)then ! empty array list=[value] elseif(place == 1)then ! put in front of array list=[value, list] elseif(place > end)then ! put at end of array list=[list, value ] elseif(place >= 2.and.place <= end)then ! put in middle of array list=[list(:place-1), value,list(place:) ] else ! index out of range write(warn,*)'*insert_l* error: index out of range. end=',end,' index=',place,' value=',value endif end subroutine insert_l subroutine insert_i(list,value,place) ! ident_30="@(#) M_CLI2 insert_i(3fp) place value into allocatable array at specified position" integer,allocatable :: list(:) integer,intent(in) :: value integer,intent(in) :: place integer :: end if(.not.allocated(list))then list=[integer :: ] endif end=size(list) if(end == 0)then ! empty array list=[value] elseif(place == 1)then ! put in front of array list=[value, list] elseif(place > end)then ! put at end of array list=[list, value ] elseif(place >= 2.and.place <= end)then ! put in middle of array list=[list(:place-1), value,list(place:) ] else ! index out of range write(warn,*)'*insert_i* error: index out of range. end=',end,' index=',place,' value=',value endif end subroutine insert_i !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()= !=================================================================================================================================== subroutine many_args(n0,g0, n1,g1, n2,g2, n3,g3, n4,g4, n5,g5, n6,g6, n7,g7, n8,g8, n9,g9, & & na,ga, nb,gb, nc,gc, nd,gd, ne,ge, nf,gf, ng,gg, nh,gh, ni,gi, nj,gj ) ! ident_31="@(#) M_CLI2 many_args(3fp) allow for multiple calls to get_args(3f)" character(len=*),intent(in) :: n0, n1 character(len=*),intent(in),optional :: n2, n3, n4, n5, n6, n7, n8, n9, na, nb, nc, nd, ne, nf, ng, nh, ni, nj class(*),intent(out) :: g0, g1 class(*),intent(out),optional :: g2, g3, g4, g5, g6, g7, g8, g9, ga, gb, gc, gd, ge, gf, gg, gh, gi, gj call get_generic(n0,g0) call get_generic(n1,g1) if( present(n2) .and. present(g2) )call get_generic(n2,g2) if( present(n3) .and. present(g3) )call get_generic(n3,g3) if( present(n4) .and. present(g4) )call get_generic(n4,g4) if( present(n5) .and. present(g5) )call get_generic(n5,g5) if( present(n6) .and. present(g6) )call get_generic(n6,g6) if( present(n7) .and. present(g7) )call get_generic(n7,g7) if( present(n8) .and. present(g8) )call get_generic(n8,g8) if( present(n9) .and. present(g9) )call get_generic(n9,g9) if( present(na) .and. present(ga) )call get_generic(na,ga) if( present(nb) .and. present(gb) )call get_generic(nb,gb) if( present(nc) .and. present(gc) )call get_generic(nc,gc) if( present(nd) .and. present(gd) )call get_generic(nd,gd) if( present(ne) .and. present(ge) )call get_generic(ne,ge) if( present(nf) .and. present(gf) )call get_generic(nf,gf) if( present(ng) .and. present(gg) )call get_generic(ng,gg) if( present(nh) .and. present(gh) )call get_generic(nh,gh) if( present(ni) .and. present(gi) )call get_generic(ni,gi) if( present(nj) .and. present(gj) )call get_generic(nj,gj) contains !=================================================================================================================================== function c(generic) class(*),intent(in) :: generic character(len=:),allocatable :: c select type(generic) type is (character(len=*)); c=trim(generic) class default c='unknown' stop 'get_many:: parameter name is not character' end select end function c !=================================================================================================================================== subroutine get_generic(name,generic) use,intrinsic :: iso_fortran_env, only : real64 character(len=*),intent(in) :: name class(*),intent(out) :: generic select type(generic) type is (integer); call get_args(name,generic) type is (real); call get_args(name,generic) type is (real(kind=real64)); call get_args(name,generic) type is (logical); call get_args(name,generic) !x!type is (character(len=:),allocatable ::); call get_args(name,generic) type is (character(len=*)); call get_args_fixed_length(name,generic) type is (complex); call get_args(name,generic) class default stop 'unknown type in *get_generic*' end select end subroutine get_generic !=================================================================================================================================== end subroutine many_args !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== function iget(n); integer :: iget; character(len=*),intent(in) :: n; call get_args(n,iget); end function iget function rget(n); real :: rget; character(len=*),intent(in) :: n; call get_args(n,rget); end function rget function dget(n); real(kind=dp) :: dget; character(len=*),intent(in) :: n; call get_args(n,dget); end function dget function sget(n); character(len=:),allocatable :: sget; character(len=*),intent(in) :: n; call get_args(n,sget); end function sget function cget(n); complex :: cget; character(len=*),intent(in) :: n; call get_args(n,cget); end function cget function lget(n); logical :: lget; character(len=*),intent(in) :: n; call get_args(n,lget); end function lget function igs(n); integer,allocatable :: igs(:); character(len=*),intent(in) :: n; call get_args(n,igs); end function igs function rgs(n); real,allocatable :: rgs(:); character(len=*),intent(in) :: n; call get_args(n,rgs); end function rgs function dgs(n); real(kind=dp),allocatable :: dgs(:); character(len=*),intent(in) :: n; call get_args(n,dgs); end function dgs function sgs(n,delims) character(len=:),allocatable :: sgs(:) character(len=*),optional,intent(in) :: delims character(len=*),intent(in) :: n call get_args(n,sgs,delims) end function sgs function cgs(n); complex,allocatable :: cgs(:); character(len=*),intent(in) :: n; call get_args(n,cgs); end function cgs function lgs(n); logical,allocatable :: lgs(:); character(len=*),intent(in) :: n; call get_args(n,lgs); end function lgs !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()= !=================================================================================================================================== function ig() integer,allocatable :: ig(:) integer :: i, ierr if(allocated(ig))deallocate(ig) allocate(ig(size(unnamed))) do i=1,size(ig) call a2i(unnamed(i),ig(i),ierr) enddo end function ig !=================================================================================================================================== function rg() real,allocatable :: rg(:) rg=real(dg()) end function rg !=================================================================================================================================== function dg() real(kind=dp),allocatable :: dg(:) integer :: i integer :: ierr if(allocated(dg))deallocate(dg) allocate(dg(size(unnamed))) do i=1,size(dg) call a2d(unnamed(i),dg(i),ierr) enddo end function dg !=================================================================================================================================== function lg() logical,allocatable :: lg(:) integer :: i integer :: iichar character,allocatable :: hold if(allocated(lg))deallocate(lg) allocate(lg(size(unnamed))) do i=1,size(lg) hold=upper(clipends(unnamed(i))) if(hold(1:1) == '.')then ! looking for fortran logical syntax .STRING. iichar=2 else iichar=1 endif select case(hold(iichar:iichar)) ! check word to see if true or false case('T','Y',' '); lg(i)=.true. ! anything starting with "T" or "Y" or a blank is TRUE (true,yes,...) case('F','N'); lg(i)=.false. ! assume this is false or no case default call journal("*lg* bad logical expression for element",i,'=',hold) end select enddo end function lg !=================================================================================================================================== function cg() complex,allocatable :: cg(:) integer :: i, ierr real(kind=dp) :: rc, ic if(allocated(cg))deallocate(cg) allocate(cg(size(unnamed))) do i=1,size(cg),2 call a2d(unnamed(i),rc,ierr) call a2d(unnamed(i+1),ic,ierr) cg(i)=cmplx(rc,ic,kind=sp) enddo end function cg !=================================================================================================================================== ! Does not work with gcc 5.3 !function sg() !character(len=:),allocatable :: sg(:) ! sg=unnamed !end function sg !=================================================================================================================================== function sg() character(len=:),allocatable :: sg(:) if(allocated(sg))deallocate(sg) allocate(sg,source=unnamed) end function sg !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()= !=================================================================================================================================== subroutine mystop(sig,msg) ! negative signal means always stop program ! else do not stop and set G_STOP_MESSAGE if G_QUIET is true ! or ! print message and stop if G_QUIET is false ! the MSG is NOT for displaying except for internal errors when the program will be stopped. ! It is for returning a value when the stop is being ignored ! integer,intent(in) :: sig character(len=*),intent(in),optional :: msg if(sig < 0)then if(present(msg))call journal(msg) stop 1 elseif(.not.G_QUIET)then stop else if(present(msg)) then G_STOP_MESSAGE=msg else G_STOP_MESSAGE='' endif G_STOP=sig endif end subroutine mystop !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()= !=================================================================================================================================== function atleast(line,length,pattern) result(strout) ! ident_32="@(#) M_strings atleast(3f) return string padded to at least specified length" character(len=*),intent(in) :: line integer,intent(in) :: length character(len=*),intent(in),optional :: pattern character(len=max(length,len(trim(line)))) :: strout if(present(pattern))then strout=line//repeat(pattern,len(strout)/len(pattern)+1) else strout=line endif end function atleast !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()= !=================================================================================================================================== function clipends(string) result(lopped) ! trim leading and trailings spaces from resulting string character(len=*),intent(in) :: string character(len=:),allocatable :: lopped integer :: ends(2) ends=verify( string, " ", [.false.,.true.] ) if(ends(1) == 0)then lopped="" else lopped=string(ends(1):ends(2)) endif end function clipends !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()= !=================================================================================================================================== subroutine locate_key(keyname,place) ! ident_33="@(#) M_CLI2 locate_key(3f) find PLACE in sorted character array where KEYNAME can be found or should be placed" character(len=*),intent(in) :: keyname integer,intent(out) :: place integer :: ii character(len=:),allocatable :: keyword_local if(G_UNDERDASH)then keyword_local=trim(replace_str(keyname,'-','_')) else keyword_local=trim(keyname) endif if(G_NODASHUNDER)then keyword_local=replace_str(keyword_local,'-','') keyword_local=replace_str(keyword_local,'_','') endif if(G_IGNORELONGCASE.and.len_trim(keyword_local) > 1)keyword_local=lower(keyword_local) if(G_IGNOREALLCASE)keyword_local=lower(keyword_local) if(len(keyword_local) == 1)then !x!ii=findloc(shorts,keyword_local,dim=1) ii=maxloc([0,merge(1, 0, shorts == keyword_local)],dim=1) if(ii > 1)then place=ii-1 else call locate_(keywords,keyword_local,place) endif else call locate_(keywords,keyword_local,place) endif if(G_DEBUG) write(*,gen)'LOCATE_KEY:KEYNAME:',trim(keyname),':KEYWORD:',keyword_local end subroutine locate_key !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! set_mode(3f) - [ARGUMENTS:M_CLI2] turn on optional modes !! (LICENSE:PD) !! !!##SYNOPSIS !! !! subroutine set_mode(key,mode) !! !! character(len=*),intent(in) :: key !! logical,intent(in),optional :: mode !! !!##DESCRIPTION !! Allow optional behaviors. !! !!##OPTIONS !! KEY name of option !! !! The following values are allowed: !! !! o response_file - enable use of response file !! !! o ignorelongcase - ignore case in long key names. So the user !! does not have to remember if the option is --CurtMode or --curtmode !! or --curtMode . !! !! o ignoreallcase - ignore case in long and short key names. !! This is similar to Powershell, which is case-insensitive. !! !! o dashunder - treat dash in keyword as an underscore. !! So the user should not have to remember if the option is !! --ignore_case or --ignore-case. !! !! o nodashunder - ignore dash and underscore in keywords. !! !! o strict - allow Boolean keys to be bundled, but requires !! a single dash prefix be used for short key names and long names !! must be prefixed with two dashes. !! !! o lastonly - when multiple keywords occur keep the rightmost !! value specified instead of appending the values together. !! !! MODE set to .true. to activate the optional mode. !! Set to .false. to deactivate the mode. !! It is .true. by default. !! !!##EXAMPLE !! !! Sample program: !! !! program demo_set_mode !! use M_CLI2, only : set_args, lget, set_mode !! implicit none !! character(len=*),parameter :: all='(*(g0))' !! ! !! ! enable use of response files !! call set_mode('response_file') !! ! !! ! Any dash in a keyword is treated as an underscore !! call set_mode('underdash') !! ! !! ! The case of long keywords are ignored. !! ! Values and short names remain case-sensitive !! call set_mode('ignorelongcase') !! ! The case of short and long keywords are ignored !! call set_mode('ignoreallcase') !! ! !! ! short single-character boolean keys may be bundled !! ! but it is required that a single dash is used for !! ! short keys and a double dash for long keywords. !! call set_mode('strict') !! ! !! call set_args(' --switch_X:X F --switch-Y:Y F --ox:O F -t F -x F -o F') !! ! !! ! show the results !! print all,'--switch_X or -X ... ',lget('switch_X') !! print all,'--switch_Y or -Y ... ',lget('switch_Y') !! print all,'--ox or -O ... ',lget('ox') !! print all,'-o ... ',lget('o') !! print all,'-x ... ',lget('x') !! print all,'-t ... ',lget('t') !! end program demo_set_mode !! !!##AUTHOR !! John S. Urban, 2019 !!##LICENSE !! Public Domain !=================================================================================================================================== elemental impure subroutine set_mode(key,mode) character(len=*),intent(in) :: key logical,intent(in),optional :: mode logical :: local_mode if(present(mode))then local_mode=mode else local_mode=.true. endif select case(lower(key)) case('response_file','response file'); CLI_RESPONSE_FILE=local_mode case('debug'); G_DEBUG=local_mode case('ignorecase','ignorelongcase'); G_IGNORELONGCASE=local_mode case('ignoreallcase'); G_IGNOREALLCASE=local_mode case('underdash','dashunder'); G_UNDERDASH=local_mode case('nodashunder','nounderdash'); G_NODASHUNDER=local_mode case('strict'); G_STRICT=local_mode case('lastonly'); G_APPEND=.not.local_mode case default call journal('*set_mode* unknown key name ',key) end select if(G_DEBUG)write(*,gen)'EXPAND_RESPONSE:END' end subroutine set_mode !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== subroutine print_dictionary_usage() if(G_DEBUG)then call print_dictionary( str('response_file=', CLI_RESPONSE_FILE, & &'ignorelongcase=', G_IGNORELONGCASE,& &'ignoreallcase=', G_IGNOREALLCASE,& &'underdash=', G_UNDERDASH,& &'strict=', G_STRICT,& &'lastonly=', G_APPEND,& &'NODASHUNDER=', G_NODASHUNDER,& &'debug=', G_DEBUG) ) else call print_dictionary('USAGE:') endif end subroutine print_dictionary_usage !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== end module M_CLI2 !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !=================================================================================================================================== !>>>>> build/dependencies/M_io/src/M_io.F90 !=================================================================================================================================== MODULE M_io use, intrinsic :: iso_fortran_env, only : stdin=>input_unit, stdout=>output_unit, stderr=>error_unit #ifdef __NVCOMPILER #define NOREAL128 #else #undef NOREAL128 #endif implicit none private integer,parameter,private:: sp=kind(1.0), dp=kind(1.0d0) public uniq public print_inquire public notopen public filename_generator public number_of_lines public get_next_char public dirname public basename public splitpath public joinpath public fileopen public filebyte, slurp public fileread, gulp, swallow public filewrite public fileclose public filedelete public get_tmp public read_line public getline public read_table public rd public separator public lookfor public which public get_env public getname ! ident_1="@(#) M_io rd(3f) ask for string or number from standard input with user-definable prompt" interface rd module procedure rd_character module procedure rd_integer module procedure rd_real module procedure rd_doubleprecision module procedure rd_logical end interface ! ident_2="@(#) M_io read_table(3f) read file containing a table of numeric values" interface read_table module procedure read_table_i module procedure read_table_r module procedure read_table_d end interface interface filedelete module procedure filedelete_filename module procedure filedelete_lun end interface integer,save,private :: my_stdout=stdout logical,save :: debug=.false. integer,save :: last_int=0 interface string_to_value module procedure a2d, a2i end interface interface v2s module procedure i2s end interface interface journal !!module procedure flush_trail ! journal() ! no options module procedure write_message_only ! journal(c) ! must have one string module procedure where_write_message_all ! journal(where,[g1-g9]) ! must have two strings !!module procedure set_stdout_lun ! journal(i) ! first is not a string end interface journal interface str module procedure msg_scalar, msg_one end interface str !----------------------------------- ! old names interface swallow; module procedure fileread; end interface interface gulp; module procedure fileread; end interface interface slurp; module procedure filebyte; end interface !----------------------------------- character(len=*),parameter,private :: gen='(*(g0,1x))' CONTAINS !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! uniq(3f) - [M_io:QUERY] append a number to the end of filename to make !! a unique name if name exists !! (LICENSE:PD) !!##SYNOPSIS !! !! Usage !! !! character(len=:),allocatable function uniq(name,istart,verbose,create) !! character(len=*),intent(in) :: name !! integer,intent(in),optional :: istart !! logical,intent(in),optional :: verbose !! logical,intent(in),optional :: create !! !!##DESCRIPTION !! Given a filename test if it is in use or exists. If it is, or if it !! ends in a period add a number to the end of the name and !! test if the new name exists. If necessary, increment the number and !! try again up to the value 9999999. By default an empty file is created !! if an unused name is found. !! !! !!##OPTIONS !! name base input name used to create output filename !! If name ends in "." a numeric suffix is always added. !! istart number to start with as a suffix. Default is 1. Must be a !! positive integer less than 9999999. !! verbose writes extra messages to stdout. Defaults to .false. !! create create file if a new unused name is successfully !! found. Defaults to .true. . !! !!##RETURNS !! uniq A unique filename that is the same as the NAME input parameter !! except with a number appended at the end if needed. If could !! not find a unique name a blank is returned. !! !!##EXAMPLE !! !! Sample program !! !! program demo_uniq !! use M_io, only : uniq !! implicit none !! character(len=4096) :: myname !! integer :: i !! myname=uniq('does_not_exist') !! write(*,*)'name stays the same :',trim(myname) !! open(unit=10,file='does_exist') !! myname=uniq('does_exist') !! write(*,*)'name has suffix added :',trim(myname) !! do i=1,10 !! myname=uniq('does_exist') !! write(*,*) 'FILENAME:',trim(myname) !! open(unit=20+i,file=myname) !! enddo !! end program demo_uniq !! !! Expected output !! !! name stays the same does_not_exist !! name has suffix added does_exist0001 !! FILENAME:does_exist0002 !! FILENAME:does_exist0003 !! FILENAME:does_exist0004 !! FILENAME:does_exist0005 !! FILENAME:does_exist0006 !! FILENAME:does_exist0007 !! FILENAME:does_exist0008 !! FILENAME:does_exist0009 !! FILENAME:does_exist0010 !! FILENAME:does_exist0011 !! !!##AUTHOR !! John S. Urban, 1993 !!##LICENSE !! Public Domain !----------------------------------------------------------------------------------------------------------------------------------- function uniq(name,istart,verbose,create) implicit none ! ident_3="@(#) M_io uniq(3f) append a number to the end of filename to make a unique name if name exists" !----------------------------------------------------------------------------------------------------------------------------------- character(len=*),intent(in) :: name character(len=:),allocatable :: uniq integer,intent(in),optional :: istart logical,intent(in),optional :: verbose logical,intent(in),optional :: create !----------------------------------------------------------------------------------------------------------------------------------- logical :: around integer,save :: icount=1 ! counter to generate suffix from character(len=4096),save :: lastname=' ' ! name called with last time the routine was called integer :: ilen integer :: itimes integer :: iscr integer :: ios logical :: verbose_local logical :: create_local !----------------------------------------------------------------------------------------------------------------------------------- uniq=trim(name) ! the input name will be returned if it passes all the tests !----------------------------------------------------------------------------------------------------------------------------------- if(lastname /= name)then ! if a different input name than last time called reset icount lastname=name ! a new name to keep for subsequent calls icount=1 ! icount is used to make a suffix to add to make the file unique endif !----------------------------------------------------------------------------------------------------------------------------------- if(present(verbose))then verbose_local=verbose else verbose_local=.false. endif !----------------------------------------------------------------------------------------------------------------------------------- if(present(create))then create_local=create else create_local=.true. endif !----------------------------------------------------------------------------------------------------------------------------------- if(present(istart))then icount=istart ! icount is used to make a suffix to add to make the file unique endif !----------------------------------------------------------------------------------------------------------------------------------- ilen=len_trim(name) ! find last non-blank character in file name !----------------------------------------------------------------------------------------------------------------------------------- if(ilen /= 0)then ! a blank input name so name will just be a suffix if(name(ilen:ilen) /= '.')then ! always append a number to a file ending in . inquire(file=name(:ilen),exist=around) ! check filename as-is if(.not.around)then ! file name does not exist, can use it as-is uniq=trim(name) if(create_local)then open(newunit=iscr,file=uniq,iostat=ios,status='new') close(unit=iscr,iostat=ios) endif return endif endif endif !----------------------------------------------------------------------------------------------------------------------------------- itimes=0 ! count number of times tried to get a uniq name deallocate(uniq) allocate(character(len=ilen+8) :: uniq) ! make it useable with an internal WRITE(3f) with room for a numeric suffix uniq(:)=name INFINITE: do ! top of loop trying for a unique name if(itimes >= 9999999)then ! if too many tries to be reasonable give up call journal('sc','*uniq* unable to find a unique filename. Too many tries') uniq='' return endif if(icount > 9999999) icount=1 ! reset ICOUNT when it hits arbitrary maximum value if(icount <= 9999)then write(uniq(ilen+1:),'(i4.4)')icount ! create name by adding a numeric string to end else write(uniq(ilen+1:),'(i7.7)')icount ! create name by adding a numeric string to end endif icount=icount+1 ! increment counter used to come up with suffix inquire(file=uniq,exist=around) ! see if this filename already exists if(.not.around)then ! found an unused name if(verbose_local)then call journal('c',trim('*uniq* name='//trim(uniq))) ! write out message reporting name used endif if(create_local)then open(newunit=iscr,file=uniq,iostat=ios,status='new') close(unit=iscr,iostat=ios) endif uniq=trim(uniq) return ! return successfully endif itimes=itimes+1 ! haven't found a unique name, try again enddo INFINITE !----------------------------------------------------------------------------------------------------------------------------------- end function uniq !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! print_inquire(3f) - [M_io:QUERY] Do INQUIRE on file by name/number and !! print results !! (LICENSE:PD) !! !!##SYNOPSIS !! !! Definition: !! !! subroutine print_inquire(lun) !! or !! subroutine print_inquire(name) !! integer,intent(in),optional :: lun !! character(len=*),intent(in),optional :: name !! !!##DESCRIPTION !! Given either a Fortran file-unit-number or filename, call the !! INQUIRE(3f) intrinsic and print typical status information. !! !!##OPTIONS !! lun if lun is not equal to -1 then query by number and ignore !! filename even if present !! name if lun = -1 or is not present then query by this filename !! !!##EXAMPLE !! !! Sample program: !! !! program demo_print_inquire !! use M_io, only : print_inquire, fileopen !! implicit none !! character(len=4096) :: filename !! character(len=20) :: mode !! integer :: ios !! character(len=256) :: message !! integer :: lun !! do !! write(*,'(a)',advance='no')'enter filename>' !! read(*,'(a)',iostat=ios)filename !! if(ios /= 0)exit !! write(*,'(a)',advance='no')'enter mode ([rwa][bt][+]>' !! read(*,'(a)',iostat=ios)mode !! if(ios /= 0)exit !! lun=fileopen(filename,mode,ios) !! if(ios == 0)then !! write(*,*)'OPENED' !! else !! write(*,*)'ERROR: IOS=',ios !! endif !! if(lun /= -1)then !! call print_inquire(lun,'') !! close(lun,iostat=ios,iomsg=message) !! if(ios /= 0)then !! write(*,'(a)')trim(message) !! endif !! endif !! enddo !! end program demo_print_inquire !! !!##AUTHOR !! John S. Urban !!##LICENSE !! Public Domain subroutine print_inquire(lun_in,namein_in) ! Version: JSU-1997-12-31, 2020-01-11 ! ident_4="@(#) M_io print_inquire(3f) Do INQUIRE on file by name/number and print results" integer,intent(in),optional :: lun_in ! if unit >= 0 then query by unit number, else by name character(len=*),intent(in),optional :: namein_in integer :: ios character(len=256) :: message character(len=:),allocatable :: namein integer :: lun !============================================================================================== ! ACCESS = SEQUENTIAL | DIRECT | STREAM ! ACTION = READ | WRITE | READWRITE ! FORM = FORMATTED | UNFORMATTED ! POSITION = ASIS | REWIND | APPEND ! STATUS = NEW | REPLACE | OLD | SCRATCH | UNKNOWN character(len=20) :: access ; namelist/inquire/access character(len=20) :: asynchronous ; namelist/inquire/asynchronous character(len=20) :: blank ; namelist/inquire/blank character(len=20) :: decimal ; namelist/inquire/decimal character(len=20) :: delim ; namelist/inquire/delim character(len=20) :: direct ; namelist/inquire/direct character(len=20) :: encoding ; namelist/inquire/encoding logical :: exist ; namelist/inquire/exist character(len=20) :: form ; namelist/inquire/form character(len=20) :: formatted ; namelist/inquire/formatted character(len=20) :: unformatted ; namelist/inquire/unformatted integer :: id ; namelist/inquire/id character(len=20) :: name ; namelist/inquire/name logical :: named ; namelist/inquire/named integer :: nextrec ; namelist/inquire/nextrec integer :: number ; namelist/inquire/number logical :: opened ; namelist/inquire/opened character(len=20) :: pad ; namelist/inquire/pad logical :: pending ; namelist/inquire/pending integer :: pos ; namelist/inquire/pos character(len=20) :: position ; namelist/inquire/position character(len=20) :: action ; namelist/inquire/action character(len=20) :: read ; namelist/inquire/read character(len=20) :: readwrite ; namelist/inquire/readwrite character(len=20) :: write ; namelist/inquire/write integer :: recl ; namelist/inquire/recl character(len=20) :: round ; namelist/inquire/round character(len=20) :: sequential ; namelist/inquire/sequential character(len=20) :: sign ; namelist/inquire/sign integer :: size ; namelist/inquire/size character(len=20) :: stream ; namelist/inquire/stream !============================================================================================== namein=merge_str(namein_in,'',present(namein_in)) lun=merge(lun_in,-1,present(lun_in)) ! exist, opened, and named always become defined unless an error condition occurs. !!write(*,*)'LUN=',lun,' FILENAME=',namein !----------------------------------------------------------------------------------------------------------------------------------- name='' if(namein == ''.and.lun /= -1)then call journal('sc','*print_inquire* checking unit',lun) inquire(unit=lun, & & recl=recl,nextrec=nextrec,pos=pos,size=size, & & position=position, & & name=name, & & form=form,formatted=formatted,unformatted=unformatted, & & access=access,sequential=sequential,direct=direct,stream=stream, & & action=action,read=read,write=write,readwrite=readwrite, & & sign=sign, & & round=round, & & blank=blank,decimal=decimal,delim=delim,encoding=encoding,pad=pad, & & named=named,opened=opened,exist=exist,number=number,pending=pending,asynchronous=asynchronous, & & iostat=ios,err=999,iomsg=message) elseif(namein /= '')then call journal('sc','*print_inquire* checking file:'//namein) inquire(file=namein, & & recl=recl,nextrec=nextrec,pos=pos,size=size, & & position=position, & & name=name, & & form=form,formatted=formatted,unformatted=unformatted, & & access=access,sequential=sequential,direct=direct,stream=stream, & & action=action,read=read,write=write,readwrite=readwrite, & & sign=sign, & & round=round, & & blank=blank,decimal=decimal,delim=delim,encoding=encoding,pad=pad, & & named=named,opened=opened,exist=exist,number=number,pending=pending,asynchronous=asynchronous, & & iostat=ios,err=999,iomsg=message) if(name == '')name=namein else call journal('sc','*print_inquire* must specify either filename or unit number') endif !----------------------------------------------------------------------------------------------------------------------------------- write(*,nml=inquire,delim='none') return !----------------------------------------------------------------------------------------------------------------------------------- 999 continue call journal('sc','*print_inquire* bad inquire') ! If an error condition occurs during execution of an INQUIRE statement, ! all of the inquiry identifiers except ios become undefined. call journal('sc','*print_inquire* inquire call failed,iostat=',ios,'message=',message) end subroutine print_inquire !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! separator(3f) - [M_io:QUERY] try to determine pathname directory !! separator character !! (LICENSE:PD) !! !!##SYNOPSIS !! !! function separator() result(sep) !! !! character(len=1) :: sep !! !!##DESCRIPTION !! !! Try to determine the separator character used to separate directory !! names from file basenames. It is assumed it is either a backslash or !! a slash character. !! !! First, the environment variables PATH, HOME, PWD, and SHELL are !! examined for a backslash, then a slash. !! !! Then, using the name the program was invoked with, then an INQUIRE(3f) !! of that name, then ".\NAME" and "./NAME" try to find an expected !! separator character. !! !! Can be very system dependent. If the queries fail the default returned !! is "/". !! !! The value is cached as a return value for subsequent calls. !! !!##EXAMPLE !! !! sample usage !! !! program demo_separator !! use M_io, only : separator !! implicit none !! write(*,*)'separator=',separator() !! end program demo_separator !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== function separator() result(sep) ! use the pathname returned as arg0 to determine pathname separator implicit none integer :: ios integer :: i logical :: existing=.false. character(len=1) :: sep !*!IFORT BUG:character(len=1),save :: sep_cache=' ' integer,save :: isep=-1 character(len=4096) :: name character(len=:),allocatable :: envnames(:) ! NOTE: A parallel code might theoretically use multiple OS !*!FORT BUG:if(sep_cache /= ' ')then ! use cached value. !*!FORT BUG: sep=sep_cache !*!FORT BUG: return !*!FORT BUG:endif if(isep /= -1)then ! use cached value. sep=char(isep) return endif FOUND: block ! simple, but does not work with ifort ! most MSWindows environments see to work with backslash even when ! using POSIX filenames to do not rely on '\.'. inquire(file='/.',exist=existing,iostat=ios,name=name) if(existing.and.ios == 0)then sep='/' exit FOUND endif ! check variables names common to many platforms that usually have a ! directory path in them although a ULS file can contain a backslash ! and vice-versa (eg. "touch A\\B\\C"). Removed HOMEPATH because it ! returned a name with backslash on CygWin, Mingw, WLS even when using ! POSIX filenames in the environment. envnames=[character(len=10) :: 'PATH', 'HOME'] do i=1,size(envnames) if(index(get_env(envnames(i)),'\') /= 0)then sep='\' exit FOUND elseif(index(get_env(envnames(i)),'/') /= 0)then sep='/' exit FOUND endif enddo write(*,*)'unknown system directory path separator' sep='\' endblock FOUND !*!IFORT BUG:sep_cache=sep isep=ichar(sep) end function separator !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! read_table(3f) - [M_io:READ] read file containing a table of numeric values !! (LICENSE:PD) !! !!##SYNOPSIS !! !! subroutine read_table(filename,array,ierr,comment) !! !! character(len=*),intent(in) :: filename !! TYPE,allocatable,intent(out) :: array(:,:) !! integer,intent(out) :: ierr !! character(len=1,intent(in),optional :: comment !! !! where TYPE may be REAL, INTEGER, or DOUBLEPRECISION !! !!##DESCRIPTION !! Read a table from a file that is assumed to be columns of numbers, !! ignoring characters not in the set [0-9edED+-.] and requiring each !! row contain the same number of values. !! !! The input file is assumed to be of a small enough size that it can !! be copied into memory. !! !!##OPTIONS !! filename filename to read !! array array to create. May be INTEGER, REAL, or DOUBLEPRECISION !! ierr zero if no error occurred. !! comment ignore lines which contain this as the first non-blank !! character. Ignore it and subsequent characters on any line. !!##EXAMPLES !! !! Sample program, assuming the input file "inputfile" exists: !! !! program demo_read_table !! use M_io, only : read_table !! implicit none !! doubleprecision,allocatable :: array(:,:) !! integer :: i, ierr !! !! ! create test file !! open(file='inputfile',unit=10,action='write') !! write(10,'(a)') [character(len=80):: & !! ' ___.___.___ ', & !! '| 1 | 5 | 3 | ', & !! '|---+---+---| ', & !! '| 4 | 2 | 6 | ', & !! ' ----------- ', & !! ' #-----#-----#------# ', & !! '| | 1 | 3e2 | 4 | ', & !! '| #-----#-----#------# ', & !! '| | 2.0 | -5 | +2.2 | ', & !! ' #-----#-----#------# ', & !! ' ', & !! '#___#___#___# ', & !! '| 1 | 5 | 3 | ', & !! '#---#---#---# ', & !! '| 4 | 2 | 6 | ', & !! '#---#---#---# ', & !! ' ', & !! '1;10;45 ', & !! '10, ,, ,,20 45 ', & !! ' 2 20 15 ', & !! ' big=20.345 medium=20 small=15 ', & !! ' ', & !! '30 30e3 0 ', & !! ' 4 300.444e-1 -10 ', & !! '40 30.5555d0 -10 ', & !! ' 4 300.444E-1 -10 ', & !! '40 30.5555D0 -10 ', & !! ' '] !! close(unit=10) !! !! ! read file as a table !! call read_table('inputfile',array,ierr) !! !! ! print values !! write(*,*)'size= ',size(array) !! write(*,*)'size(dim=1)=',size(array,dim=1) !! write(*,*)'size=(dim=2)',size(array,dim=2) !! do i=1,size(array,dim=1) !! write(*,*)array(i,:) !! enddo !! !! ! remove sample file !! open(file='inputfile',unit=10) !! close(unit=10,status='delete') !! !! end program demo_read_table !! !! Results: !! !! size= 45 !! size(dim=1)= 15 !! size=(dim=2) 3 !! 1.000000000000000 5.000000000000000 3.000000000000000 !! 4.000000000000000 2.000000000000000 6.000000000000000 !! 1.000000000000000 300.0000000000000 4.000000000000000 !! 2.000000000000000 -5.000000000000000 2.200000000000000 !! 1.000000000000000 5.000000000000000 3.000000000000000 !! 4.000000000000000 2.000000000000000 6.000000000000000 !! 1.000000000000000 10.00000000000000 45.00000000000000 !! 10.00000000000000 20.00000000000000 45.00000000000000 !! 2.000000000000000 20.00000000000000 15.00000000000000 !! 20.34499999999999 20.00000000000000 15.00000000000000 !! 30.00000000000000 30000.00000000000 0.000000000000000 !! 4.000000000000000 30.04440000000000 -10.00000000000000 !! 40.00000000000000 30.55549999999999 -10.00000000000000 !! 4.000000000000000 30.04440000000000 -10.00000000000000 !! 40.00000000000000 30.55549999999999 -10.00000000000000 !! !!##AUTHOR !! John S. Urban !!##LICENSE !! Public Domain subroutine read_table_d(filename,darray,ierr,comment) ! note the array is allocated as text, and then doubleprecision, and then placed in the output array. ! for large files it would be worth it to just determine the file size and allocate and fill the output ! array character(len=*),intent(in) :: FILENAME doubleprecision,allocatable,intent(out) :: darray(:,:) integer,intent(out) :: ierr character(len=1),intent(in),optional :: comment character(len=:),allocatable :: page(:) ! array to hold file in memory integer :: irows,irowsmax integer :: icols integer :: i doubleprecision,allocatable :: dline(:) ierr=0 ! allocate character array and copy file into it call fileread(FILENAME,page) if(.not.allocated(page))then write(*,*)'*demo_read_table* failed to load file '//FILENAME if(allocated(darray))deallocate(darray) allocate(darray(0,0)) ierr=-1 else call cleanse() if(allocated(darray))deallocate(darray) if(size(page,dim=1) == 0)then allocate(darray(0,0)) else irowsmax=size(page,dim=1) icols=size(s2vs(page(1))) allocate(darray(irowsmax,icols)) darray=0.0d0 irows=0 do i=1,irowsmax dline=s2vs(page(i)) irows=irows+1 if(size(dline) /= icols)then write(*,gen)page(i),'does not contain',icols,'values' ierr=ierr+1 darray(irows,:min(size(dline),icols))=dline(min(size(dline),icols)) else darray(irows,:)=dline endif enddo if(irows /= irowsmax)then darray=darray(:irows,:icols) endif deallocate(page) ! release memory endif endif contains subroutine cleanse() integer :: i,j,k integer :: ios integer :: ikeep character(len=:),allocatable :: words(:), line doubleprecision :: value ikeep=0 do i=1,size(page,dim=1) ! do this more rigourously ! [+-]NNNNNN[.NNNN][ED][+-]NN line='' ! get rid of all characters not in a number and ! then split the remaining line and keep only ! tokens that can be read as a number do j=1,len(page) if(present(comment))then if(page(i)(j:j) == comment)then page(i)(j:)=' ' exit endif endif select case(page(i)(j:j)) case('e','E','d','D','+','-','.','0':'9') case default page(i)(j:j)=' ' end select enddo call split(page(i),words) do k=1,size(words) read(words(k),*,iostat=ios)value if(ios == 0)then line=line//crop(words(k))//' ' endif enddo if(line /= '')then ikeep=ikeep+1 page(ikeep)(:)=line endif enddo page=page(:ikeep) end subroutine cleanse end subroutine read_table_d !=================================================================================================================================== subroutine read_table_i(filename,array,ierr,comment) implicit none character(len=*),intent(in) :: FILENAME integer,allocatable,intent(out) :: array(:,:) integer,intent(out) :: ierr character(len=1),intent(in),optional :: comment doubleprecision,allocatable :: darray(:,:) call read_table_d(filename,darray,ierr,comment) array=nint(darray) end subroutine read_table_i !=================================================================================================================================== subroutine read_table_r(filename,array,ierr,comment) implicit none character(len=*),intent(in) :: FILENAME real,allocatable,intent(out) :: array(:,:) integer,intent(out) :: ierr character(len=1),intent(in),optional :: comment doubleprecision,allocatable :: darray(:,:) call read_table_d(filename,darray,ierr,comment) array=real(darray) end subroutine read_table_r !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! fileread(3f) - [M_io:READ] read a file into a string array !! (LICENSE:PD) !!##SYNOPSIS !! !! subroutine fileread(filename,pageout) !! !! character(len=*),intent(in) :: filename !! or !! integer,intent(in) :: io !! !! character(len=:),allocatable,intent(out) :: pageout(:) !!##DESCRIPTION !! Read an entire file into memory as a character array, one character !! variable per line. !! !! NOTE: !! !! Do not casually read an entire file into memory if you can process it !! per line or in smaller units; as large files can consume unreasonable !! amounts of memory. !! !!##OPTIONS !! filename filename to read into memory, or LUN (Fortran Logical !! Unit Number). If filename is a LUN, file must be opened !! with !! !! form='unformatted',access='stream' !! !! as in !! !! open(unit=igetunit, file=filename, & !! & action="read", iomsg=message, & !! & form="unformatted", access="stream", & !! & status='old',iostat=ios) !! !! pageout array of characters to hold file !! !!##EXAMPLES !! !! Sample program !! !! program demo_fileread !! use M_io, only : fileread !! implicit none !! character(len=4096) :: FILENAME ! file to read !! character(len=:),allocatable :: pageout(:) ! array to hold file in memory !! integer :: longest, lines, i !! character(len=*),parameter :: gen='(*(g0,1x))' !! ! get a filename !! call get_command_argument(1, FILENAME) !! ! allocate character array and copy file into it !! call fileread(FILENAME,pageout) !! if(.not.allocated(pageout))then !! write(*,gen)'*demo_fileread* failed to load file',FILENAME !! else !! ! write file from last line to first line !! longest=len(pageout) !! lines=size(pageout) !! write(*,gen)'number of lines is',lines !! write(*,gen)'and length of lines is',longest !! write(*,'(a)')repeat('%',longest+2) !! write(*,'("%",a,"%")')(trim(pageout(i)),i=lines,1,-1) !! write(*,'(a)')repeat('%',longest+2) !! deallocate(pageout) ! release memory !! endif !! end program demo_fileread !! !! Given !! !! first line !! second line !! third line !! !! Expected output !! !! > number of lines is 3 !! > and length of lines is 11 !! > %%%%%%%%%%%%% !! > %third line % !! > %second line% !! > %first line % !! > %%%%%%%%%%%%% !! !!##AUTHOR !! John S. Urban !!##LICENSE !! Public Domain subroutine fileread(FILENAME,pageout) implicit none class(*),intent(in) :: FILENAME ! file to read character(len=:),allocatable,intent(out) :: pageout(:) ! page to hold file in memory character(len=1),allocatable :: text(:) ! array to hold file in memory call filebyte(FILENAME,text) ! allocate character array and copy file into it if(.not.allocated(text))then select type(FILENAME) type is (character(len=*)); write(*,*)'*fileread* failed to load file '//FILENAME type is (integer); write(*,'(a,i0)')'*fileread* failed to load file unit ',FILENAME end select else ! convert array of characters to array of lines pageout=page(text) deallocate(text) ! release memory endif contains function page(array) result (table) ! ident_5="@(#) page(3fp) function to copy char array to page of text" character(len=1),intent(in) :: array(:) character(len=:),allocatable :: table(:) integer :: i integer :: linelength integer :: length integer :: lines integer :: linecount integer :: position integer :: sz !!character(len=1),parameter :: nl=new_line('A') character(len=1),parameter :: nl = char(10) character(len=1),parameter :: cr = char(13) lines = 0 linelength = 0 length = 0 sz=size(array) do i = 1,sz if( array(i) == nl )then linelength = max(linelength,length) lines = lines + 1 length = 0 else length = length + 1 endif enddo if( sz > 0 )then if( array(sz) /= nl )then lines = lines+1 endif endif if(allocated(table))deallocate(table) allocate(character(len=linelength) :: table(lines)) table(:) = ' ' linecount = 1 position = 1 do i = 1,sz if( array(i) == nl )then linecount=linecount+1 position=1 elseif( array(i) == cr )then elseif( linelength /= 0 )then table(linecount)(position:position) = array(i) position = position+1 endif enddo end function page end subroutine fileread !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! filebyte(3f) - [M_io:READ] read a file into a character array !! (LICENSE:PD) !!##SYNOPSIS !! !! subroutine filebyte(filename,text,length.lines) !! !! character(len=*),intent(in) :: filename !! or !! integer,intent(in) :: filenumber !! !! character(len=1),allocatable,intent(out) :: text(:) !! integer,intent(out),optional :: length !! integer,intent(out),optional :: lines !!##DESCRIPTION !! Read an entire file as a stream into memory as an array of single !! characters, retaining line end terminators. !! !! NOTE: !! !! Never casually read an entire file into memory if you can process it !! per line or in smaller units; as large files can consume unreasonable !! amounts of memory. !! !!##OPTIONS !! filename filename to read into memory or LUN (Fortran Logical !! Unit Number) If a LUN, file must be opened with !! !! form='unformatted',access='stream' !! !! as in !! !! open(unit=igetunit, file=filename, & !! & action="read", iomsg=message, & !! & form="unformatted", access="stream", & !! & status='old',iostat=ios) !! !! text array of characters to hold file !! length returns length of longest line read(Optional). !! lines returns number of lines read(Optional). !! !!##EXAMPLES !! !! Sample program, which creates test input file "inputfile": !! !! program demo_filebyte !! use M_io, only : filebyte !! implicit none !! character(len=1),allocatable :: text(:) ! array to hold file in memory !! character(len=*),parameter :: FILENAME='inputfile' ! file to read !! !! ! create test file !! open(file=FILENAME,unit=10,action='write') !! write(10,'(a)') new_line('A')//'esrever lliw' !! write(10,'(a)') 'margorp elpmas eht taht' !! write(10,'(a)') 'elif elpmas a si sihT' !! close(unit=10) !! !! call filebyte(FILENAME,text) ! allocate character array and copy file into it !! !! if(.not.allocated(text))then !! write(*,*)'*rever* failed to load file '//FILENAME !! else !! ! write file reversed to stdout !! write(*,'(*(a:))',advance='no')text(size(text):1:-1) !! deallocate(text) ! release memory !! endif !! !! end program demo_filebyte !! !! Expected output: !! !! >This is a sample file !! >that the sample program !! >will reverse !!##AUTHOR !! John S. Urban !!##LICENSE !! Public Domain subroutine filebyte(filename,text,length,lines) implicit none ! ident_6="@(#) M_io filebyte(3f) allocate text array and read file filename into it" class(*),intent(in) :: filename ! filename to shlep character(len=1),allocatable,intent(out) :: text(:) ! array to hold file integer,intent(out),optional :: length ! length of longest line integer,intent(out),optional :: lines ! number of lines integer :: nchars=0 ! holds size of file integer :: igetunit ! use newunit=igetunit in f08 integer :: ios=0 ! used for I/O error status integer :: length_local integer :: lines_local integer :: i integer :: icount character(len=256) :: message character(len=4096) :: label character(len=:),allocatable :: line length_local=0 lines_local=0 message='' select type(FILENAME) type is (character(len=*)) if(filename /= '-') then open(newunit=igetunit, file=trim(filename), action="read", iomsg=message,& &form="unformatted", access="stream",status='old',iostat=ios) label=filename else ! copy stdin to a scratch file call copystdin() endif type is (integer) if(filename /= stdin) then rewind(unit=filename,iostat=ios,iomsg=message) igetunit=filename else ! copy stdin to a scratch file call copystdin() endif write(label,'("unit ",i0)')filename end select if(ios == 0)then ! if file was successfully opened inquire(unit=igetunit, size=nchars) if(nchars <= 0)then call stderr_local( '*filebyte* empty file '//trim(label) ) return endif ! read file into text array if(allocated(text))deallocate(text) ! make sure text array not allocated allocate ( text(nchars) ) ! make enough storage to hold file read(igetunit,iostat=ios,iomsg=message) text ! load input file -> text array if(ios /= 0)then call stderr_local( '*filebyte* bad read of '//trim(label)//':'//trim(message) ) endif else call stderr_local('*filebyte* '//message) allocate ( text(0) ) ! make enough storage to hold file endif close(iostat=ios,unit=igetunit) ! close if opened successfully or not if(present(lines).or.present(length))then ! get length of longest line and number of lines icount=0 do i=1,nchars if(text(i) == NEW_LINE('A'))then lines_local=lines_local+1 length_local=max(length_local,icount) icount=0 endif icount=icount+1 enddo if(nchars /= 0)then if(text(nchars) /= NEW_LINE('A'))then lines_local=lines_local+1 length_local=max(length_local,icount) endif endif if(present(lines))lines=lines_local if(present(length))length=length_local endif !----------------------------------------------------------------------------------------------------------------------------------- contains !----------------------------------------------------------------------------------------------------------------------------------- subroutine copystdin() integer :: iostat open(newunit=igetunit, iomsg=message,& &form="unformatted", access="stream",status='scratch',iostat=iostat) open(unit=stdin,pad='yes') INFINITE: do while (getline(line,iostat=iostat)==0) write(igetunit)line//new_line('a') enddo INFINITE rewind(igetunit,iostat=iostat,iomsg=message) end subroutine copystdin !----------------------------------------------------------------------------------------------------------------------------------- subroutine stderr_local(message) character(len=*) :: message write(stderr,'(a)')trim(message) ! write message to standard error end subroutine stderr_local !----------------------------------------------------------------------------------------------------------------------------------- end subroutine filebyte !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! number_of_lines(3f) - [M_io:QUERY] read an open sequential file to get !! number of lines !! (LICENSE:PD) !! !!##SYNOPSIS !! !! function number_of_lines(lun) result(nlines) !! !! integer,intent(in) :: lun !! integer :: nlines !! !!##DESCRIPTION !! Rewind an open sequential file and read through it to count the number !! of lines. The file is rewound on exit. If it is not readable -1 is returned. !! !!##OPTIONS !! lun logical unit number of open sequential file to count lines in. !! !!##RETURNS !! nlines number of lines read. If it is not readable -1 is returned. !! !!##EXAMPLES !! !! Sample program !! !! program demo_number_of_lines !! use M_io, only : number_of_lines, fileopen !! implicit none !! integer :: ios !! integer :: lun !! lun=fileopen('test.txt','r',ios) !! if(ios == 0)then !! write(*,*) number_of_lines(lun) !! else !! write(*,*)'ERROR: IOS=',ios !! endif !! end program demo_number_of_lines !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain function number_of_lines(lun) result(nlines) !@(#) determine number or lines in file given a LUN to the open file integer,intent(in) :: lun integer :: ios integer :: nlines character(len=256) :: iomsg if(lun /= stdin)rewind(lun,iostat=ios,iomsg=iomsg) nlines = 0 do read(lun, '(A)', end=99, iostat=ios,iomsg=iomsg) if (ios /= 0) then write(stderr,gen)'*number_of_lines*:',trim(iomsg) nlines=-1 exit endif nlines = nlines + 1 enddo 99 continue if(lun /= stdin)rewind(lun,iostat=ios,iomsg=iomsg) end function number_of_lines !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! notopen(3f) - [M_io:QUERY] Find a FUN/LUN (Fortran-unit-number) that is not in use !! (LICENSE:PD) !!##SYNOPSIS !! !! Usage !! !! integer function notopen(start,end,err) !! integer,optional,intent(in) :: start !! integer,optional,intent(in) :: end !! integer,optional,intent(out) :: err !!##DESCRIPTION !! A free FORTRAN unit number is needed to OPEN a file. NOTOPEN() returns !! a FORTRAN unit number from START to END not currently associated with !! an I/O unit. START and END are expected to be positive integers where !! END >= START. !! !! If NOTOPEN() returns -1, then no free FORTRAN unit could be found in !! the specified range. !! !! Otherwise, NOTOPEN() returns an integer representing a free FORTRAN !! logical unit number. Note that NOTOPEN() assumes the following unit !! numbers defined by the Fortran 2008 ISO_FORTRAN_ENV module !! !! ERROR_UNIT,INPUT_UNIT,OUTPUT_UNIT !! !! are special, and will never return those values. !! !!##OPTIONS !! start optional logical unit number to start scan at, defaults to 10. !! end optional logical unit number to stop scan at, defaults to 99. !! err optional error flag returned. ERR will be non-zero if !! no errors. If not present and an error occurs the program !! will stop instead of returning. !! !!##NOTES !! !! Why are the default START and END limits from 10 to 99? the Fortran 77 !! standard did not specify a specific limit on the upper range limit, but !! the LUN range of 1 to 99 was almost always supported in conventional !! programming environments. Additionally, units in the range 0-10 have !! often been the units used for pre-assigned files. Occasionally 100, !! 101 and 102 are reserved (for files such as standard input, standard !! output, standard error, ...). Therefore, the defaults for START and !! END were selected to be 10 and 99. And most programs do not need !! more than 90 files simultaneously open, so the defaults work well in !! practice with many versions/vintages of Fortran. !! !! Note that an environment may impose a limit on the number of !! simultaneously open files (which some compilers work around). !! !! Beginning with f2008, you can probably use OPEN(NEWUNIT=...) instead !! of an open unit locator. !! !!##EXAMPLE !! !! !! Sample program: !! !! program demo_notopen ! test the NOTOPEN(3f) function !! use m_io, only: notopen !! implicit none !! integer :: ii, ierr, igot !! !! write(*,*)'check for preassigned files from unit 0 to unit 1000' !! write(*,*)'(5 and 6 always return -1)' !! !! do ii=0,1000 !! if(notopen(ii,ii,ierr) /= ii)then !! write(*,*)'INUSE:',ii, notopen(ii,ii,ierr) !! endif !! enddo !! !! ! open all files from UNIT=10 to UNIT=30 so have used units !! do ii=10,30,1 !! open(unit=ii,status="scratch") !! enddo !! ! close UNIT=25 !! close(25) !! !! ! find open file in range 10 to 30 !! write(*,*)'Should get 25 for this ..',notopen(10,30,ierr) !! !! close(18) !! do ii=10,32 !! igot=notopen(ii,ii,ierr) !! write(*,*)'For unit ',ii,' I got ',igot,' with ERR=',ierr !! enddo !! !! end program demo_notopen !! !! Expected output(can vary with each programming environment): !! !! check for preassigned files from unit 0 to unit 1000 !! (5 and 6 always return -1) !! INUSE: 0 -1 !! INUSE: 5 -1 !! INUSE: 6 -1 !! Should get 25 for this .. 25 !! For unit 10 I got -1 with ERR= -1 !! For unit 11 I got -1 with ERR= -1 !! For unit 12 I got -1 with ERR= -1 !! For unit 13 I got -1 with ERR= -1 !! For unit 14 I got -1 with ERR= -1 !! For unit 15 I got -1 with ERR= -1 !! For unit 16 I got -1 with ERR= -1 !! For unit 17 I got -1 with ERR= -1 !! For unit 18 I got 18 with ERR= 0 !! For unit 19 I got -1 with ERR= -1 !! For unit 20 I got -1 with ERR= -1 !! For unit 21 I got -1 with ERR= -1 !! For unit 22 I got -1 with ERR= -1 !! For unit 23 I got -1 with ERR= -1 !! For unit 24 I got -1 with ERR= -1 !! For unit 25 I got 25 with ERR= 0 !! For unit 26 I got -1 with ERR= -1 !! For unit 27 I got -1 with ERR= -1 !! For unit 28 I got -1 with ERR= -1 !! For unit 29 I got -1 with ERR= -1 !! For unit 30 I got -1 with ERR= -1 !! For unit 31 I got 31 with ERR= 0 !! For unit 32 I got 32 with ERR= 0 !! !!##AUTHOR !! John S. Urban !!##LICENSE !! Public Domain integer function notopen(start,end,err) implicit none ! ident_7="@(#) M_io notopen(3f) find free FORTRAN unit number to OPEN() a file" integer,optional,intent(in) :: start ! unit number to start looking at integer,optional,intent(in) :: end ! last unit number to look at integer,optional,intent(out) :: err ! error flag returned integer :: istart integer :: iend integer :: ierr integer :: i10 ! counter from start to end integer :: ios ! iostatus from INQUIRE logical :: lopen ! returned from INQUIRE logical :: lexist ! returned from INQUIRE !----------------------------------------------------------------------------------------------------------------------------------- !! IEND=MERGE( END, 99, PRESENT(END)) do not use merge, as TSOURCE must be evaluated before the call if(present(start))then; istart=start; else; istart=10; endif if(present(end ))then; iend =end ; else; iend =99; endif ierr=0 notopen=(-1) ! result if no units are available !----------------------------------------------------------------------------------------------------------------------------------- do i10=istart,iend ! check units over selected range select case (i10) ! always skip these predefined units case(stderr,stdin,stdout) cycle end select inquire( unit=i10, opened=lopen, exist=lexist, iostat=ios ) if( ios == 0 )then ! no error on inquire if(.not. lopen .and. lexist)then ! if unit number not in use, return it notopen = i10 exit ! only need to find one, so return endif else write(stderr,*)'*notopen*:error on unit ',i10,'=',ios endif enddo !----------------------------------------------------------------------------------------------------------------------------------- if (notopen < 0 )then ! no valid unit was found in given range ierr=-1 else ! valid value being returned ierr=0 endif if(present(err))then ! if error flag is present set it err=ierr elseif(ierr /= 0)then ! if error occurred and error flag not present stop program stop 1 endif end function notopen !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! dirname(3f) - [M_io:PATHNAMES] strip last component from filename !! (LICENSE:PD) !! !!##SYNOPSIS !! !! function dirname(FILENAME) result (DIRECTORY) !! !! character(len=*),intent(in) :: FILENAME !! character(len=:),allocatable :: DIRECTORY !! !!##DESCRIPTION !! Output FILENAME with its last non-slash component and trailing slashes !! removed. If FILENAME contains no slash or backslash character, output !! '.' (meaning the current directory). !! !! Assumes leaf separator is a slash or backslash as determined by !! separator(3f) and that FILENAME does not contain trailing spaces. !! !!##OPTIONS !! FILENAME pathname to remove the last leaf from !! !!##RETURNS !! DIRECTORY directory name for pathname !! !!##EXAMPLES !! !! Sample program: !! !! program demo_dirname !! use M_io, only : dirname !! implicit none !! character(len=:),allocatable :: filename !! integer :: filename_length !! integer :: i !! ! get pathname from command line arguments !! do i = 1 , command_argument_count() !! call get_command_argument (i , length=filename_length) !! if(allocated(filename))deallocate(filename) !! allocate(character(len=filename_length) :: filename) !! call get_command_argument (i , value=filename) !! write(*,'(a)')dirname(filename) !! enddo !! end program demo_dirname !! !! Sample program executions: !! !! demo_dirname /usr/bin/ -> "/usr" !! demo_dirname dir1/str dir2/str -> "dir1" followed by "dir2" !! demo_dirname stdio.h -> "." !! !!##SEE ALSO !! dirname(3c), basename(3c), readlink(3c), realpath(3c) !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain !> !! PRODUCT: CLI library utilities and examples !! PROGRAM: dirname(3f) !! DESCRIPTION: strip last component from filename !!##VERSION: 1.0.0 !!##DATE: 2015-06-26 !! AUTHOR: John S. Urban !! REPORTING BUGS: http://www.urbanjost.altervista.org/ !! HOME PAGE: http://www.urbanjost.altervista.org/index.html function dirname(filename) result (directory) implicit none ! ident_8="@(#) M_io dirname(3f) strip last component from filename" character(len=*),intent(in) :: filename character(len=:),allocatable :: directory integer :: iend character(len=1) :: sep !----------------------------------------------------------------------------------------------------------------------------------- sep=separator() directory=trim(filename) call removetail() ! trim trailing slashes even if duplicates iend=index(directory,sep,back=.true.) ! find last slash if any if(iend == 0)then ! filename is a leaf directory='.' ! special case else directory=directory(:iend-1) ! remove leaf call removetail() ! trim off trailing slashes in case duplicates endif directory=trim(directory) ! clean up return value contains subroutine removetail() ! replace trailing slashes with spaces even if duplicates integer :: right do right=len(directory),1,-1 if(directory(right:right) == sep.or.directory(right:right) == ' ')then directory(right:right)=' ' else exit endif enddo end subroutine removetail end function dirname !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! basename(3f) - [M_io:PATHNAMES] return last component from filename !! (LICENSE:PD) !! !!##SYNOPSIS !! !! function basename(FILENAME,SUFFIX) result (LEAF) !! !! character(len=:),allocatable :: FILENAME !! character(len=*),intent(in),optional :: SUFFIX !! character(len=*),intent(in) :: LEAF !! !!##DESCRIPTION !! Output LEAF of filename with directory paths removed. !! !! Assumes leaf separator is a slash or backslash as determined by !! separator(3f) and that filename does not contain trailing spaces. !! !!##OPTIONS !! FILENAME pathname to extract the last leaf from !! SUFFIX suffix to remove. If not present !! the rightmost ".string" string is removed. !! If present the LEAF is returned with any matching !! suffix removed. !! !!##RETURNS !! LEAF returned leaf name !! !!##EXAMPLES !! !! Sample program: !! !! program demo_basename !! use M_io, only : basename !! implicit none !! character(len=:),allocatable :: fn !! integer :: filename_length !! integer :: i !! ! get pathname from command line arguments !! do i = 1, command_argument_count() !! call get_command_argument (i, length=filename_length) !! if(allocated(fn))deallocate(fn) !! allocate(character(len=filename_length) :: fn) !! call get_command_argument (i, value=fn) !! ! leaf with any suffix removed !! ! leaf with suffix retained !! ! with suffix unless it is ".f90" !! write(*,'(*(a,1x))') basename(fn), basename(fn,''), basename(fn,'.f90') !! enddo !! end program demo_basename !! !! Sample program executions: !! !! $demo_basename /usr/bin/ !! bin bin bin !! $demo_basename dir1/fred.x dir2/.y !! fred fred.x fred.x !! .y .y .y !! $demo_basename stdio.h !! stdio stdio.h stdio.h !! $demo_basename /name.f90 !! name name.f90 name !! !!##SEE ALSO !! basename(3c), basename(3c), readlink(3c), realpath(3c) !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain !> !! PRODUCT: CLI library utilities and examples !! PROGRAM: basename(3f) !! DESCRIPTION: strip last component from filename !!##VERSION: 1.0.0 !!##DATE: 2015-06-26 !! AUTHOR: John S. Urban !! REPORTING BUGS: http://www.urbanjost.altervista.org/ !! HOME PAGE: http://www.urbanjost.altervista.org/index.html function basename(filename,suffix) result (leaf) implicit none ! ident_9="@(#) M_io basename(3f) strip last component from filename" character(len=*),intent(in) :: filename character(len=*),intent(in),optional :: suffix character(len=:),allocatable :: leaf integer :: iend integer :: i integer,parameter :: maxlen=4096 character(len=maxlen) :: name character(len=maxlen) :: bname character(len=maxlen) :: extension character(len=1) :: sep sep=separator() iend=len_trim(filename) do i=iend,1,-1 if(filename(i:i) /= sep)exit iend=iend-1 enddo call splitpath(filename(:iend),name=name,basename=bname,ext=extension) if(present(suffix))then leaf=merge(bname,name,suffix == extension) else leaf=bname endif if(leaf == '')leaf=name leaf=trim(leaf) end function basename !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! fileopen(3f) - [M_io] A simple open of a sequential file !! (LICENSE:PD) !! !!##SYNOPSIS !! !! function fileopen(filename,mode,ios) result(lun) !! !! character(len=*),intent(in) :: filename !! character(len=*),intent(in),optional :: mode !! integer,intent(out),optional :: ios !! integer :: lun !! !!##DESCRIPTION !! fileopen(3f) is a convenience routine that allows you to open a file !! for sequential reading and writing as a text file in a form commonly !! found in C and interpreted languages such as shells. See the OPEN(3f) !! statement for more demanding I/O specifications (asynchronous, direct, !! unformatted, ... ). The documentation for the flexible and powerful !! OPEN(3f) statement can be a bit overwhelming; this routine cuts it !! down to the just the simple basic functions typically available in !! a scripting language such as bash, tcsh, sh, ... !! !! Specify the file's name as the string FILENAME with a shell-like prefix !! specifying the access mode, or alternatively specify a plain FILENAME !! and the kind of access you need to the file with the string MODE. !! !! Three fundamental kinds of access are available: read, write, !! and append. !! !!##OPTION !! FILENAME The filename to open. If the beginning of the filename is !! !! < open for read. File must exist !! > open for write. Will overwrite current file !! >> open for append. Will append to current file !! !! If no prefix exists to specify a file access mode, it !! will depend on the values of the MODE argument (meaning !! the default will be "readwrite"). !! !! A blank filename causes a unit number for a scratch file !! to be returned. !! !! MODE [rwa][tb][+] !! An alternate way to specify the file access mode is to specify !! a MODE value. It should begin with one of the three characters !! "r", "w", or "a". It defaults to 'rw'. It is case-insensitive. !! !! !! READING PREFIX !! r,< Open the file for reading; the operation will fail if the !! file does not exist, or if the host system does not permit !! you to read it. !! !! WRITING PREFIXES !! w,> Open a file for writing from the beginning of the file. !! If the file whose name you specified already existed, !! the call fails. !! !! o Open the file for writing from the beginning of the file: !! effectively, this always creates a new file. If the file !! whose name you specified already existed, its old contents !! are discarded. !! !! a,<< Initially open the file for appending data (ie. writing !! at the end of file). !! !! SUFFIX !! !! b Append a "b" to any of the three modes above to specify that !! you are opening the file as a "binary file" (the default is !! to open the file as a sequential formatted text file. This !! switch changes to to an unformatted stream). !! !! open( ... access='stream';form='unformatted') !! !! t Append a "t" to any of the three modes (rwa) to specify a !! formatted stream !! !! open( ... access='stream';form='formatted') !! !! + Finally, you might need to both read and write from the same !! file. You can specify "rw" or you can append a `+' to any of !! the three primary modes ("rwa") to permit "readwrite" access !! !! v Additionally, "v" selects verbose mode, which prints the !! OPEN(3f) options explicitly selected !! !! NOTES !! !! If you want to append both `b' and `+', you can do it in !! either order: for example, "rb+" means the same thing as !! "r+b" when used as a mode string.) !! !! IOS The error code returned by the OPEN(3f) statement ultimately !! executed by this function. If not present the program stops on !! an error. !!##RETURNS !! FILEOPEN(3f) returns a Fortran unit number which you can use !! for other file operations, unless the file you requested could !! not be opened; in that situation, the result is -1 (a reserved !! value that cannot be returned as a NEWUNIT value on an OPEN(3f)) !! and IOS will be non-zero. !! !!##EXAMPLE !! !! Common usage !! !! READ !! R=fileopen('out.txt') !! or !! W=fileopen('out.txt','W') !! !! READWRITE !! RW=fileopen('inout.txt') !! !! APPEND !! A=fileopen('>>inout.txt') !! or !! A=fileopen('inout.txt','a') !! !! Sample program !! !! program demo_fileopen !! use M_io, only : fileopen, fileclose, print_inquire !! implicit none !! integer :: lun !! lun=fileopen('fred.txt') !! call print_inquire(lun) !! end program demo_fileopen !! !!##AUTHOR !! John S. Urban !!##LICENSE !! Public Domain function fileopen(filename,mode,ios) result(lun) character(len=*),intent(in) :: filename character(len=*),intent(in),optional :: mode integer,intent(out),optional :: ios integer :: lun, i, ios_local,ifound,gts character(len=:),allocatable :: local_mode character(len=256) :: message character(len=:),allocatable :: action, position, access, form, status, file logical :: verbose local_mode=lower(merge_str(mode,'',present(mode))) file=trim(adjustl(filename))//' ' ifound=index(file,'>>') if(ifound /= 0)then file(ifound:ifound+1)=' ' local_mode=local_mode//'a' endif ifound=index(file,'>') if(ifound /= 0)then file(ifound:ifound)=' ' local_mode=local_mode//'w' endif ifound=index(file,'<') if(ifound /= 0)then file(ifound:ifound)=' ' local_mode=local_mode//'r' endif file=adjustl(file) local_mode=merge_str('rw',local_mode,local_mode == '') file=trim(file) gts=0 action='' position='asis' form='formatted' access='sequential' status='unknown' verbose=.false. do i=1,len(local_mode) ! create order independence select case(local_mode(i:i)) case('r','<'); if(action /= 'readwrite'.and.action /= 'read')action='read'//action if(status == 'unknown')status='old' case('w','>'); if(action /= 'readwrite'.and.action /= 'write')action=action//'write' if(status=='unknown')status='new' if(gts > 0)then position='append' endif gts=gts+1 case('o'); if(action /= 'readwrite'.and.action /= 'write')action=action//'write' if(status=='unknown')then status='replace' endif case('a'); position='append' if(action /= 'readwrite'.and.action /= 'write')action=action//'write' if(status == 'old')status='unknown' case('b'); access='stream';form='unformatted' case('t'); access='stream';form='formatted' case('+'); action='readwrite' status='unknown' case('v'); verbose=.true. case default write(*,'(*(g0))',advance='no')'*fileopen* unknown mode key ',local_mode(i:i) write(*,'(*(:,"[",g0,"=",g0,"]"))',advance='no') & & ' INPUTNAME=',trim(file), & & ' MODE=',trim(local_mode) end select enddo if(action == '')action='readwrite' if(verbose)then write(*,'(*(:,"[",g0,"=",g0,"]"))',advance='no') & & 'INPUTNAME=',trim(file), & & 'MODE=',trim(local_mode) write(*,'(a)',advance='no')'==>' write(*,'(*(:,"[",g0,"=",g0,"]"))') & & 'FILE=',trim(file), & & 'FORM=',trim(form), & & 'ACCESS=',trim(access), & & 'ACTION=',trim(action), & & 'POSITION=',trim(position), & & 'STATUS=',trim(status) endif if(file /= ' ')then open(file=file,newunit=lun,form=form,access=access,action=action,position=position,status=status,iostat=ios_local,iomsg=message) else open(newunit=lun,form=form,access=access,action=action,status='scratch',iostat=ios_local,iomsg=message) endif ! ACCESS = SEQUENTIAL | DIRECT | STREAM ! ACTION = READ|WRITE | READWRITE ! FORM = FORMATTED | UNFORMATTED ! POSITION = ASIS | REWIND | APPEND ! STATUS = NEW | REPLACE | OLD | SCRATCH | UNKNOWN if(ios_local /= 0)then call journal('sc','*fileopen* ',message) lun=-1 endif if(present(ios))then ! caller has asked for status so let caller process any error ios=ios_local elseif(ios_local /= 0)then ! caller did not ask for status so stop program on error stop 1 endif end function fileopen !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! fileclose(3f) - [M_io] A simple close of a sequential file !! (LICENSE:PD) !! !!##SYNOPSIS !! !! function fileclose(lun) result(ios) !! !! integer,intent(in) :: lun !! integer :: ios !!##DESCRIPTION !! A convenience command for closing a file that leaves an !! error message in the current journal file if active. !!##OPTION !! LUN unit number to close !!##RETURNS !! IOS status value from CLOSE !!##EXAMPLE !! !! Sample program: !! !! program demo_fileclose !! use M_io, only : fileclose, fileopen !! implicit none !! integer :: lun !! integer :: ios, ierr !! lun=fileopen(' opening file' !! endif !! ios=fileclose(lun) !! end program demo_fileclose !! !!##AUTHOR !! John S. Urban !!##LICENSE !! Public Domain function fileclose(lun) result(ios) integer,intent(in) :: lun integer :: ios character(len=256) :: message close(unit=lun,iostat=ios,iomsg=message) if(ios /= 0)then call journal('sc','*fileclose* ',message) stop endif end function fileclose !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! filewrite(3f) - [M_io:WRITE] A simple write of a CHARACTER array to a file !! (LICENSE:PD) !! !!##SYNOPSIS !! !! function filewrite(filename,data,status,position) result(ierr) !! !! character(len=*),intent(in) :: filename !! character(len=*),intent(in) :: data(:) !! character(len=*),intent(in),optional :: status !! character(len=*),intent(in),optional :: position !! integer :: ierr !!##DESCRIPTION !! A convenience procedure for writing a CHARACTER array as !! a new file. !!##OPTION !! FILENAME file to create or write. If the name ends !! in ">" the default for STATUS changes to !! "REPLACE". If it ends in ">>" STATUS changes to !! "UNKNOWN" and the default POSITION changes to "APPEND". !! DATA CHARACTER array to write to file !! STATUS STATUS to use on OPEN(7f). Defaults to "NEW". !! Allowed values are NEW|REPLACE|OLD|SCRATCH|UNKNOWN !! POSITION POSITION to use on OPEN(7f). Defaults to "REWIND". !! Allowed values are ASIS|REWIND|APPEND !!##RETURNS !! IERR status value. Zero indicates no error occurred !!##EXAMPLE !! !! Sample program: !! !! program demo_filewrite !! use M_io, only : filewrite !! implicit none !! integer :: ierr !! character(len=:),allocatable :: data(:) !! data=[ character(len=80) :: & !! &'This is the text to write ', & !! &'into the file. It will be ', & !! &'trimmed on the right side. ', & !! &' ', & !! &' That is all Folks! ', & !! &''] !! ierr=filewrite('_scratch.txt',data) !! end program demo_filewrite !! !!##AUTHOR !! John S. Urban !!##LICENSE !! Public Domain function filewrite(filename,filedata,status,position) result (ierr) ! write filedata to file filename character(len=*),intent(in) :: filename character(len=*),intent(in) :: filedata(:) character(len=*),intent(in),optional :: status character(len=*),intent(in),optional :: position integer :: ierr integer :: lun, i, ios, ilen character(len=256) :: message character(len=:),allocatable :: file character(len=:),allocatable :: local_status character(len=:),allocatable :: local_position character(len=:),allocatable :: default_status character(len=:),allocatable :: default_position ierr=0 default_status='NEW' default_position='REWIND' file=trim(adjustl(filename))//' ' ilen=max(len_trim(file),2) if(file(ilen-1:ilen) == '>>')then ilen=ilen-2 file=file(:ilen) default_status='UNKNOWN' default_position='APPEND' elseif(file(ilen:ilen) == '>')then ilen=ilen-1 file=file(:ilen) default_status='REPLACE' else file=trim(file) endif if(present(position))then; local_position=position; else; local_position=default_position; endif if(present(status))then; local_status=status; else; local_status=default_status; endif if(file /= ' ')then open(file=file, & & newunit=lun, & & form='formatted', & ! FORM = FORMATTED | UNFORMATTED & access='sequential', & ! ACCESS = SEQUENTIAL | DIRECT | STREAM & action='write', & ! ACTION = READ|WRITE | READWRITE & position=local_position, & ! POSITION = ASIS | REWIND | APPEND & status=local_status, & ! STATUS = NEW | REPLACE | OLD | SCRATCH | UNKNOWN & iostat=ios, & & iomsg=message) else lun=stdout ios=0 endif if(ios /= 0)then write(stderr,'(*(a,1x))')'*filewrite* error:',file,trim(message) ierr=ios else do i=1,size(filedata) ! write file write(lun,'(a)',iostat=ios,iomsg=message)trim(filedata(i)) if(ios /= 0)then write(stderr,'(*(a,1x))')'*filewrite* error:',file,trim(message) ierr=ios exit endif enddo endif close(unit=lun,iostat=ios,iomsg=message) ! close file if(ios /= 0)then write(stderr,'(*(a,1x))')'*filewrite* error:',trim(message) ierr=ios endif end function filewrite !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! filedelete(3f) - [M_io] A simple close of an open file with STATUS='DELETE' !! (LICENSE:PD) !! !!##SYNOPSIS !! !! function filedelete(lun) result(ios) !! !! integer,intent(in) :: lun !! or !! character(len=*),intent(in) :: filename !! integer :: ios !! !!##DESCRIPTION !! A convenience command for deleting an OPEN(3f) file that leaves an !! error message in the current journal file if active !!##OPTION !! LUN unit number of open file to delete or filename. !!##RETURNS !! IOS status returned by CLOSE(). !!##EXAMPLE !! !! Sample program: !! !! program demo_filedelete !! use M_io, only : filedelete, fileopen !! implicit none !! integer :: lun !! integer :: ios !! lun=fileopen(' !!##NAME !! joinpath(3f) - [M_io:PATHNAMES] join parts of a pathname together !! (LICENSE:PD) !! !!##SYNOPSIS !! !! function joinpath(a1,a2,a3,a4,a5,a6,a7,a8,a9) result(path) !! !! character(len=*), intent(in) :: a1, a2 !! character(len=*), intent(in), optional :: a3, a4, a5, a6, a7, a8, a9 !! character(len=:), allocatable :: path !!##DESCRIPTION !!##OPTIONS !! a1,a2 the first two pathname sections to join. Required !! a3-a9 additional optional sections to join !!##RETURNS !! pathname sections joined together with trailing spaces removed from !! the ends of sections and a separator (as returned by separator(3f) !! ) placed between them, and duplicate adjacent separators removed !! accept for one beginning the joined pathname. !!##EXAMPLE !! !! Sample program !! !! program demo_joinpath !! use M_io, only : joinpath !! implicit none !! write(*,*)joinpath(& !! &'/share/user','/man/','man3','joinpath.3m_io'//'.gz' & !! &) !! end program demo_joinpath !! !! Results: !! !! > /share/user/man/man3/joinpath.3m_io.gz !! !!##AUTHOR !! John S. Urban !!##LICENSE !! Public Domain !=================================================================================================================================== function joinpath(a1,a2,a3,a4,a5,a6,a7,a8,a9) result(path) ! Construct path by joining strings with os file separator ! character(len=*), intent(in) :: a1, a2 character(len=*), intent(in), optional :: a3, a4, a5, a6, a7, a8, a9 character(len=:), allocatable :: path character(len=1) :: filesep filesep = separator() if(a1 /= '')then path = trim(a1) // filesep // trim(a2) else path = trim(a2) endif if (present(a3)) path = path // filesep // trim(a3) if (present(a4)) path = path // filesep // trim(a4) if (present(a5)) path = path // filesep // trim(a5) if (present(a6)) path = path // filesep // trim(a6) if (present(a7)) path = path // filesep // trim(a7) if (present(a8)) path = path // filesep // trim(a8) if (present(a9)) path = path // filesep // trim(a9) path=adjustl(path//' ') call substitute(path,filesep//filesep,filesep,start=2) ! some systems allow names starting with '//' or '\\' path=trim(path) end function joinpath !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! splitpath(3f) - [M_io:PATHNAMES] split a Unix pathname into components !! (LICENSE:PD) !! !!##SYNOPSIS !! !! subroutine splitpath(path,dir,name,basename,ext) !! !! integer,parameter :: maxlen=4096 !! character(len=maxlen),intent(in) :: path !! character(len=maxlen),intent(out),optional :: dir !! character(len=maxlen),intent(out),optional :: name !! character(len=maxlen),intent(out),optional :: basename !! character(len=maxlen),intent(out),optional :: ext !! !!##DESCRIPTION !! splitpath(3f) splits given pathname assuming a forward slash separates !! filename components and that the right-most period in the last leaf !! of the pathname is considered the beginning of an extension. If !! an extension is found it is left present in NAME but removed from !! BASENAME. !! !! This routine does not check the system for the existence or type of !! the filename components; it merely parses a string. !! !! Assumes leaf separator is a slash or backslash as determined by !! separator(3f) and that filename does not contain trailing spaces. !! !!##OPTIONS !! path Path to be broken into components. It is assumed !! !! o Forward slashes (/) separate pathname components. !! o the name '.' means "current directory" !! o the name '..' means "up one directory" !! o a pathname ending in a slash is a directory name !! o a slash starting the pathname represents the root !! directory. !! o trailing spaces are insignificant. !! !! Using these rules helps to reduce incorrect parsing, but the !! routine is only intended for simple parsing of names of the form !! "[dir/]name[.extension]. !! !!##RESULTS !! dir Path of directories, including the trailing slash. !! name Name of file leaf or, if no file is specified in path, !! name of the lowest directory. !! basename NAME with any extension removed !! ext File name extension, if any, including the leading period (.). !! !! The path parameter can be a complete or partial file specification. The !! special name "." is assumed to mean the current directory, and the !! special name ".." is assumed to mean one directory above the current !! directory. !! !!##EXAMPLE !! !! program demo_splitpath !! !! use m_io, only : splitpath !! implicit none !! integer,parameter :: maxlen=4096 !! character(len=maxlen),parameter :: file(*)=[& !! & 'dirs/name.ext ', & !! & 'xx/IO/zz/NN.FF ', & !! & 'xx/IO/zz/NN ', & !! & '/xx/IO/zz/NN ', & !! & '/xx/IO/zz/ ', & !! & '/xx/IO/zz.A/ ', & !! & '/xx/IO/zz/. ', & !! & ' ', & !! & './ ', & !! & '/ ', & !! & '/.. ', & !! & './.. ', & !! & 'name. ', & !! & '.name ', & !! & '.name. ', & !! & '. ', & !! & '.. ', & !! & '... '] !! !! character(len=maxlen) :: dir !! character(len=maxlen) :: name !! character(len=maxlen) :: basename !! character(len=maxlen) :: ext !! integer :: i !! integer :: longest !! longest=maxval(len_trim(file)) ! find longest filename !! !! do i=1,size(file) !! call splitpath(file(i), dir, name, basename, ext) !! write(*,'(*("| ",a:))') & !! & file(i)(:longest), & !! & dir(:longest), & !! & name(:longest), & !! & basename(:longest), & !! & ext(:longest) !! enddo !! end program demo_splitpath !! !! Output !! !! | dirs/name.ext | dirs | name.ext | name | .ext !! | xx/IO/zz/NN.FF| xx/IO/zz | NN.FF | NN | .FF !! | xx/IO/zz/NN | xx/IO/zz | NN | NN | !! | /xx/IO/zz/NN | /xx/IO/zz | NN | NN | !! | /xx/IO/zz/ | /xx/IO/zz | | | !! | /xx/IO/zz.A/ | /xx/IO/zz.A | | | !! | /xx/IO/zz/. | /xx/IO/zz/. | | | !! | | . | | | !! | ./ | . | | | !! | / | / | | | !! | /.. | / | | | !! | ./.. | ./.. | | | !! | name. | | name. | name | . !! | .name | | .name | .name | !! | .name. | | .name. | .name | . !! | . | . | | | !! | .. | | | | !! | ... | | ... | .. | . !! !!##AUTHOR !! John S. Urban !!##LICENSE !! Public Domain subroutine splitpath(path,dir,name,basename,ext) implicit none ! ident_10="@(#) M_io splitpath(3f) split Unix pathname into components (dir name basename extension)" !=================================================================================================================================== character(len=*),intent(in) :: path character(len=*),intent(out),optional :: dir character(len=*),intent(out),optional :: name character(len=*),intent(out),optional :: basename character(len=*),intent(out),optional :: ext integer,parameter :: maxlen=4096 character(len=maxlen) :: dir_local character(len=maxlen) :: name_local character(len=maxlen) :: basename_local character(len=maxlen) :: ext_local character(len=len(path)+1) :: path_local integer :: where integer :: i integer :: iend character(len=1) :: sep sep=separator() !=================================================================================================================================== path_local=path ! initialize variables dir_local='' name_local='' basename_local='' ext_local='' iend=len_trim(path_local) LOCAL : block !=================================================================================================================================== if(iend == 0)then ! blank input path dir_local='.' exit LOCAL endif !=================================================================================================================================== if(path_local(iend:iend) == sep)then ! assume entire name is a directory if it ends in a slash if(iend > 1)then dir_local=path_local(:iend-1) else ! if just a slash it means root directory so leave it as slash dir_local=path_local endif exit LOCAL endif !=================================================================================================================================== TRIMSLASHES: do i=iend,1,-1 ! trim off trailing slashes even if duplicates if(path_local(i:i) == sep)then path_local(i:i)=' ' iend=i-1 else iend=i exit TRIMSLASHES endif enddo TRIMSLASHES if(iend == 0)then ! path composed entirely of slashes. dir_local=sep exit LOCAL endif !=================================================================================================================================== where=INDEX(path_local,sep,BACK=.true.) ! find any right-most slash in remaining non-null name_local after trimming trailing slashes if(where <= 0)then ! no slash in path so everything left is name_local name_local=path_local(:iend) ! this is name_local unless '.' or '..' else ! last slash found dir_local=path_local(:where-1) ! split into directory name_local=path_local(where+1:iend) ! this is name_local unless '.' or '..' endif !=================================================================================================================================== select case (name_local(1:3)) ! special cases where name_local is a relative directory name_local '.' or '..' case('. ') dir_local=path_local name_local='' case('.. ') if(dir_local == '')then if(path_local(1:1) == sep)then dir_local=sep endif else dir_local=path_local endif name_local='' case default end select !=================================================================================================================================== if(name_local == '.')then name_local='' endif !=================================================================================================================================== iend=len_trim(name_local) where=INDEX(name_local,'.',BACK=.true.) ! find any extension if(where > 0.and.where /= 1)then ! only consider a non-blank extension name_local ext_local=name_local(where:) basename_local=name_local(:where-1) else basename_local=name_local endif !=================================================================================================================================== endblock LOCAL if(present(dir))dir=dir_local if(present(name))name=name_local if(present(basename))basename=basename_local if(present(ext))ext=ext_local end subroutine splitpath !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! getline(3f) - [M_io:READ] read a line from specified LUN into allocatable !! string up to line length limit !! (LICENSE:PD) !! !!##SYNTAX !! function getline(line,lun,iostat) result(ier) !! !! character(len=:),allocatable,intent(out) :: line !! integer,intent(in),optional :: lun !! integer,intent(out),optional :: iostat !! integer :: ier !! !!##DESCRIPTION !! Read a line of any length up to programming environment maximum !! line length. Requires Fortran 2003+. !! !! It is primarily expected to be used when reading input which will !! then be parsed. !! !! The input file must have a PAD attribute of YES for the function !! to work properly, which is typically true. !! !! The simple use of a loop that repeatedly re-allocates a character !! variable in addition to reading the input file one buffer at a !! time could (depending on the programming environment used) be !! inefficient, as it could reallocate and allocate memory used for !! the output string with each buffer read. !! !!##OPTIONS !! LINE line read !! LUN optional LUN (Fortran logical I/O unit) number. Defaults !! to stdin. !! IOSTAT status returned by READ(IOSTAT=IOS). If not zero, an error !! occurred or an end-of-file or end-of-record was encountered. !! This is the same value as returned by the function. See the !! example program for a usage case. !!##RETURNS !! IER zero unless an error occurred. If not zero, LINE returns the !! I/O error message. !! !!##EXAMPLE !! !! Sample program: !! !! program demo_getline !! use,intrinsic :: iso_fortran_env, only : stdin=>input_unit !! use,intrinsic :: iso_fortran_env, only : iostat_end !! use M_io, only : getline !! implicit none !! integer :: iostat !! character(len=:),allocatable :: line !! open(unit=stdin,pad='yes') !! INFINITE: do while (getline(line,iostat=iostat)==0) !! write(*,'(a)')'['//line//']' !! enddo INFINITE !! if(iostat /= iostat_end)then !! write(*,*)'error reading input:',trim(line) !! endif !! end program demo_getline !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain function getline(line,lun,iostat) result(ier) implicit none ! ident_11="@(#) M_io getline(3f) read a line from specified LUN into allocatable string up to line length limit" character(len=:),allocatable,intent(out) :: line integer,intent(in),optional :: lun integer,intent(out),optional :: iostat integer :: ier character(len=4096) :: message integer,parameter :: buflen=1024 character(len=:),allocatable :: line_local character(len=buflen) :: buffer integer :: isize integer :: lun_local line_local='' ier=0 if(present(lun))then lun_local=lun else lun_local=stdin endif INFINITE: do ! read characters from line and append to result read(lun_local,pad='yes',iostat=ier,fmt='(a)',advance='no',size=isize,iomsg=message) buffer ! read next buffer (might use stream I/O for files ! other than stdin so system line limit is not limiting if(isize > 0)line_local=line_local//buffer(:isize) ! append what was read to result if(is_iostat_eor(ier))then ! if hit EOR reading is complete unless backslash ends the line ier=0 ! hitting end of record is not an error for this routine exit INFINITE ! end of reading line elseif(ier /= 0)then ! end of file or error line=trim(message) exit INFINITE endif enddo INFINITE line=line_local ! trim line if(present(iostat))iostat=ier end function getline !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! read_line(3f) - [M_io:READ] read a line from specified LUN into allocatable !! string up to line length limit cleaning up input line !! (LICENSE:PD) !! !!##SYNTAX !! function read_line(line,lun,ios) result(ier) !! !! character(len=:),allocatable,intent(out) :: line !! integer,intent(in),optional :: lun !! integer,optional :: ios !! integer :: ier !! !!##DESCRIPTION !! !! Read a line of any length up to the programming environment maximum !! line length. Requires Fortran 2003+. !! !! It is primarily expected to be used when reading input which will !! then be parsed. !! !! The input file must have a PAD attribute of YES for the function to !! work properly, which is typically true but can be set on an open file. !! !! o Append lines that end in a backslash with next line !! o Expand tabs !! o Replace unprintable characters with spaces !! o Remove trailing carriage return characters and white space !! !! The simple use of a loop that repeatedly re-allocates a character !! variable in addition to reading the input file one buffer at a time !! could (depending on the programming environment used) be inefficient, !! as it could reallocate and allocate memory used for the output string !! with each buffer read. !! !!##OPTIONS !! LINE the line read from the file. !! LUN The LUN (logical unit) to read from. Defaults to stdin. !! IOS status returned by READ(IOSTAT=IOS). If not zero, an error !! occurred or an end-of-file or end-of-record was encountered. !! This is the same value as returned by the function. See the !! example program for a usage case. !!##RETURNS !! IER status returned by READ(IOSTAT=IER). If not zero, an error !! occurred or an end-of-file or end-of-record was encountered. !! !!##EXAMPLE !! !! Sample program: !! !! Checking the error message and counting lines: !! !! program demo_read_line !! use,intrinsic :: iso_fortran_env, only : stdin => input_unit !! use,intrinsic :: iso_fortran_env, only : stderr => error_unit !! use,intrinsic :: iso_fortran_env, only : iostat_end, iostat_eor !! use M_io, only : read_line !! implicit none !! character (len =: ), allocatable :: line !! integer :: stat !! integer :: icount=0 !! open(unit=stdin,pad='yes') !! INFINITE: do while (read_line(line,ios=stat) == 0) !! icount=icount !! write (*, '(*(g0))') icount,' [',line,']' !! enddo INFINITE !! if ( .not.is_iostat_end(stat) ) then !! write (stderr, '(*(g0))') & !! & 'error: line ',icount,'==>',trim (line) !! endif !! end program demo_read_line !! !!##AUTHOR !! John S. Urban !!##LICENSE !! Public Domain function read_line(line,lun,ios) result(ier) implicit none ! ident_12="@(#) M_io read_line(3f) read a line from specified LUN into allocatable string up to line length limit" character(len=:),allocatable,intent(out) :: line integer,intent(in),optional :: lun integer,optional :: ios integer :: ier integer,parameter :: buflen=1024 character(len=:),allocatable :: line_local character(len=256) :: message integer :: biggest character(len=buflen) :: buffer integer :: last integer :: isize integer :: lun_local line_local='' ier=0 lun_local=merge(lun,stdin,present(lun)) INFINITE: do ! read characters from line and append to result read(lun_local,pad='yes',iostat=ier,fmt='(a)',advance='no',size=isize,iomsg=message) buffer ! read next buffer (might use stream I/O for ! files other than stdin so system line limit ! is not limiting if(isize > 0)line_local=line_local//buffer(:isize) ! append what was read to result if(is_iostat_eor(ier))then ! if hit EOR reading is complete unless backslash ends the line last=len(line_local) if(last /= 0)then if(line_local(last:last) == '\')then ! if line ends in backslash it is assumed a continued line line_local=line_local(:last-1) ! remove backslash cycle INFINITE ! continue on and read next line and append to result endif endif ier=0 ! hitting end of record is not an error for this routine exit INFINITE ! end of reading line elseif(ier /= 0)then ! end of file or error line_local=trim(message) exit INFINITE endif enddo INFINITE biggest=8*len(line_local) ! worst case is raw line is all tab characters if(allocated(line))deallocate(line) allocate(character(len=biggest) :: line) call notabs(line_local,line,last) ! expand tabs, trim carriage returns, remove unprintable characters line=noesc(line) line=trim(line(:last)) ! trim line if(present(ios))then ios=ier endif end function read_line !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! get_tmp(3f) - [M_io:QUERY] Return the name of the scratch directory !! (LICENSE:PD) !!##SYNOPSIS !! !! function get_tmp() result(tname) !! !! character(len=:),allocatable :: tname !!##DESCRIPTION !! !! Return the name of the scratch directory set by the most common !! environment variables used to designate a scratch directory. !! $TMPDIR is the canonical environment variable in Unix and POSIX[1] !! to use to specify a temporary directory for scratch space. If $TMPDIR !! is not set, $TEMP, $TEMPDIR, and $TMP are examined in that order. If !! nothing is set "/tmp/" is returned. The returned value always ends in !! "/". No test is made that the directory exists or is writable. !! !!##EXAMPLE !! !! !! Sample: !! !! program demo_get_tmp !! use M_io, only : get_tmp, uniq !! implicit none !! character(len=:),allocatable :: answer !! answer=get_tmp() !! write(*,*)'result is ',answer !! answer=get_tmp()//uniq('_scratch',create=.false.) !! write(*,*)'the file ',answer, & !! & ' was a good scratch file name, at least a moment ago' !! end program demo_get_tmp !! !! Sample Results: !! !! > result is /cygdrive/c/Users/JSU/AppData/Local/Temp/ !! > !! > the file /cygdrive/c/Users/JSU/AppData/Local/Temp/_scratch !! > was a good scratch file name, at least a moment ago !! !!##AUTHOR !! John S. Urban !!##LICENSE !! Public Domain function get_tmp() result(tname) ! ident_13="@(#) M_io get_tmp(3f) Return the name of the scratch directory" character(len=:),allocatable :: tname integer :: lngth character(len=10),parameter :: names(4)=["TMPDIR ","TEMP ","TEMPDIR ","TMP "] integer :: i character(len=1) :: sep sep=separator() tname='' do i=1,size(names) call get_environment_variable(name=names(i), length=lngth) if(lngth /= 0)then if(allocated(tname))deallocate(tname) allocate(character(len=lngth) :: tname) call get_environment_variable(name=names(i), value=tname) exit endif enddo if(lngth == 0)then tname='/tmp' lngth=len_trim(tname) endif if(scan(tname(lngth:lngth),'/\') == 0)then tname=tname//sep endif end function get_tmp !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! rd(3f) - [M_io:READ] ask for string from standard input with user-definable prompt !! (LICENSE:PD) !! !! function rd(prompt,default) result(out) !! !! character(len=*),intent(in) :: prompt !! !! One of !! !! character(len=*),intent(in) :: default !! character(len=:),allocatable,intent(out) :: out !! !! integer,intent(in) :: default !! integer,intent(out) :: out !! !! real,intent(in) :: default !! real,intent(out) :: out !! !! doubleprecision,intent(in) :: default !! doubleprecision,intent(out) :: out !! !! logical,intent(in) :: default !! logical,intent(out) :: out !! !! !!##DESCRIPTION !! Ask for string or value from standard input with user-definable prompt !! up to 20 times. !! !! Do not use the function in an I/O statement as not all versions of !! Fortran support this form of recursion. Numeric values may be input !! in standard INTEGER, REAL, and DOUBLEPRECISION formats or as whole !! numbers in base 2 to 36 in the format BASE#VALUE. !! !!##OPTIONS !! prompt Prompt string; displayed on same line as input is read from !! default default answer on carriage-return. The type of the default !! determines the type of the output. !!##RETURNS !! out returned string or value. If an end-of-file or system error !! is encountered the string "EOF" is returned, or a "Nan" !! REAL numeric value, or huge(0), or .false. . !!##EXAMPLE !! !! Sample program: !! !! program demo_rd !! use M_io, only : rd !! implicit none !! character(len=:),allocatable :: mystring !! doubleprecision :: d !! real :: r !! integer :: i !! logical :: l !! !! INFINITE: do !! mystring=rd('Enter string or "STOP":',default='Today') !! if(mystring == 'STOP')stop !! i=rd('Enter integer:',default=huge(0)) !! r=rd('Enter real:',default=huge(0.0)) !! d=rd('Enter double:',default=huge(0.0d0)) !! l=rd('Enter logical:',default=.false.) !! !! write(*,*)'I=', i, 'R=', r, 'D=',d, 'MYSTRING=', mystring !! write(*,*)'L=', l !! enddo INFINITE !! !! end program demo_rd !! !!##AUTHOR !! John S. Urban, 1993 !!##LICENSE !! Public Domain function rd_logical(prompt,default) result(out) ! 1995 John S. Urban ! implicit none ! ident_14="@(#) M_io rd_logical(3fp) ask for logical value from standard input with user-definable prompt" character(len=*),intent(in) :: prompt logical,intent(in) :: default logical :: out integer :: prompt_len integer :: igot integer :: ierr integer :: icount integer :: ios character(:),allocatable :: response character(len=256) :: iomsg out=.false. response='' prompt_len=len(prompt) do icount=1,20 ! prevent infinite loop on error or end-of-file if(prompt_len > 0)write(*,'(a,'' '')',advance='no')prompt ! write prompt ierr=getline(response,stdin) ! get back string igot=len(response) if(ierr /= 0)then cycle elseif(igot == 0.and.prompt_len > 0)then out=default exit elseif(igot <= 0)then call journal('*rd* blank string not allowed') cycle else response=response//' ' select case(response(1:1)) case('y','Y') out=.true. case('n','N') out=.false. case default read(response,*,iostat=ios,iomsg=iomsg)out if(ios /= 0)then write(*,*)trim(iomsg) cycle endif end select exit endif enddo end function rd_logical !=================================================================================================================================== function rd_character(prompt,default) result(strout) ! 1995 John S. Urban ! implicit none ! ident_15="@(#) M_io rd_character(3fp) ask for string from standard input with user-definable prompt" character(len=*),intent(in) :: prompt character(len=*),intent(in) :: default character(len=:),allocatable :: strout integer :: len_default integer :: igot integer :: ierr integer :: icount !=================================================================================================================================== len_default=len(prompt) !=================================================================================================================================== do icount=1,20 ! prevent infinite loop on error or end-of-file if(len_default > 0)write(*,'(a,'' '')',advance='no')prompt ! write prompt ierr=getline(strout,stdin) ! get back string igot=len(strout) if(ierr /= 0)then strout='EOF' cycle elseif(igot == 0.and.len_default > 0)then strout=default exit elseif(igot <= 0)then call journal('*rd* blank string not allowed') cycle else exit endif enddo end function rd_character !=================================================================================================================================== function rd_doubleprecision(prompt,default,iostat) result(dvalue) implicit none ! ident_16="@(#) M_io rd_doubleprecision(3fp) ask for number from standard input with user-definable prompt" doubleprecision :: dvalue integer :: ivalue character(len=*),intent(in) :: prompt doubleprecision,intent(in) :: default integer,intent(out),optional :: iostat character(len=:),allocatable :: strout character(len=:),allocatable :: message integer :: itest iostat=0 dvalue=default strout=adjustl(rd_character(prompt,'NaN')) ! 1 for an integer [-+]NNNNN ! 2 for a whole number [-+]NNNNN. ! 3 for a real value [-+]NNNNN.MMMM ! 4 for a exponential value [-+]NNNNN.MMMM[-+]LLLL [-+]NNNNN.MMMM[ed][-+]LLLL ! values less than 1 represent an error if(strout == 'NaN')then dvalue=default elseif(index(strout,'#') /= 0)then if( decodebase(strout,0,ivalue))then dvalue=ivalue else iostat=-1 write(*,*)'ERROR> could not convert ',strout endif else itest=isnumber(strout,message) if(itest > 0)then dvalue=s2v(strout,ierr=iostat) else iostat=-2 write(*,*)' ERROR> for ',strout,' ',itest,':',trim(message) endif endif end function rd_doubleprecision !=================================================================================================================================== function rd_real(prompt,default,iostat) result(rvalue) implicit none ! ident_17="@(#) M_io rd_real(3fp) ask for number from standard input with user-definable prompt" real :: rvalue real(kind=dp) :: dvalue character(len=*),intent(in) :: prompt real,intent(in) :: default integer,intent(out),optional :: iostat !*! what about Nan, Inf, -Inf? Likely place for compiler bugs dvalue=rd_doubleprecision(prompt,dble(default),iostat) if(dvalue /= dvalue)then write(stderr,'(*(g0))') & & '*input* value [',dvalue,'] is indefinite' rvalue=huge(0.0) else rvalue=real(dvalue) endif end function rd_real !=================================================================================================================================== function rd_integer(prompt,default,iostat) result(ivalue) implicit none ! ident_18="@(#) M_io rd_integer(3fp) ask for number from standard input with user-definable prompt" integer :: ivalue real(kind=dp) :: dvalue character(len=*),intent(in) :: prompt integer,intent(in) :: default integer,intent(out),optional :: iostat dvalue=rd_doubleprecision(prompt,dble(default),iostat) !*! what about Nan, Inf, -Inf? if(dvalue /= dvalue)then write(stderr,'(*(g0))') & & '*input* value [',dvalue,'] is indefinite' ivalue=huge(0) elseif(dvalue > huge(0))then write(stderr,'(*(g0))') & & '*input* value [',dvalue,'] greater than ', huge(0) ivalue=huge(0) elseif(dvalue < 1-huge(0))then write(stderr,'(*(g0))') & & '*input* value [',dvalue,'] less than ', 1-huge(0) ivalue=1-huge(0) else ivalue=nint(dvalue) endif end function rd_integer !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! getname(3f) - [M_io:QUERY] get name of the current executable !! (LICENSE:PD) !! !!##SYNOPSIS !! !! function getname() result(name) !! !! character(len=:),allocatable :: getname !! !!##DESCRIPTION !! getname(3f) returns the name of the current executable using !! get_command_argument(3f) and inquire(3f). !! !!##EXAMPLE !! !! Sample getting a pathname of current executable: !! !! program demo_getname !! use M_io, only : getname !! implicit none !! write(*,'(*(a))')'Running ',getname() !! end program demo_getname !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain function getname() result(name) ! get the pathname of arg0 implicit none character(len=:),allocatable :: arg0 integer :: arg0_length integer :: ios character(len=4096) :: long_name character(len=:),allocatable :: name arg0_length=0 name='' long_name='' call get_command_argument(0,length=arg0_length,status=ios) if(ios == 0)then if(allocated(arg0))deallocate(arg0) allocate(character(len=arg0_length) :: arg0) call get_command_argument(0,arg0,status=ios) if(ios == 0)then inquire(file=arg0,iostat=ios,name=long_name) if(ios == 0)then name=trim(long_name) else name=arg0 endif else arg0='' endif else arg0='' endif end function getname !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! which(3f) - [M_io:SCANNAMES] given a command name find the pathname !! by searching the directories in the environment variable !! $PATH !! (LICENSE:PD) !! !!##SYNTAX !! function which(command) result(pathname) !! !! character(len=*),intent(in) :: command !! character(len=:),allocatable :: pathname !! !!##DESCRIPTION !! Given a command name find the first file with that name in the directories !! specified by the environment variable $PATH. !! !!##OPTIONS !! COMMAND the command to search for !! !!##RETURNS !! PATHNAME the first pathname found in the current user path. Returns blank !! if the command is not found. !! !!##EXAMPLE !! !! Sample program: !! !! program demo_which !! use M_io, only : which !! implicit none !! write(*,*)'ls is ',which('ls') !! write(*,*)'dir is ',which('dir') !! write(*,*)'install is ',which('install') !! end program demo_which !! !!##SEE ALSO !! M_system:system_dir(3f) !! !!##AUTHOR !! John S. Urban !!##LICENSE !! Public Domain function which(command) result(pathname) character(len=*),intent(in) :: command character(len=:),allocatable :: pathname, checkon, paths(:), exts(:) integer :: i, j pathname='' call split(get_env('PATH'),paths,delimiters=merge(';',':',separator() == '\')) SEARCH: do i=1,size(paths) checkon=trim(joinpath(trim(paths(i)),command)) select case(separator()) case('/') if(exists(checkon))then pathname=checkon exit SEARCH endif case('\') if(exists(checkon))then pathname=checkon exit SEARCH endif if(exists(checkon//'.bat'))then pathname=checkon//'.bat' exit SEARCH endif if(exists(checkon//'.exe'))then pathname=checkon//'.exe' exit SEARCH endif call split(get_env('PATHEXT'),exts,delimiters=';') do j=1,size(exts) if(exists(checkon//'.'//trim(exts(j))))then pathname=checkon//'.'//trim(exts(j)) exit SEARCH endif enddo end select enddo SEARCH contains logical function exists(filename) result(r) character(len=*), intent(in) :: filename inquire(file=filename, exist=r) end function end function which !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! lookfor(3f) - [M_io:SCANNAMES] look for a filename in a number !! of directories specified by an environment variable !! (LICENSE:PD) !! !!##SYNTAX !! function lookfor(basename,env) result(pathname) !! !! character(len=:),intent(in) :: basename !! character(len=:),intent(in) :: env !! character(len=:),allocatable :: pathname !! !!##DESCRIPTION !! Given a base filename find the first file with that name in the directories !! specified by the environment variable ENV !! !!##OPTIONS !! BASENAME the file to search for !! ENV environment variable name. Separator between directory names is !! assumed to be a colon on ULS (Unix-Like Systems) and semi-colon on !! MS-Windows machines. !! !!##RETURNS !! PATHNAME the first pathname found in the current user path. Returns blank !! if the file is not found. !! !!##EXAMPLE !! !! Sample program: !! !! program demo_lookfor !! use M_io, only : lookfor !! implicit none !! character(len=:),allocatable :: returned !! returned=lookfor('ls','PATH') !! write(*,*)'ls is ',returned !! returned=lookfor('dir.exe','PATH') !! write(*,*)'dir is ',returned !! end program demo_lookfor !! !!##SEE ALSO !! M_system:system_dir(3f) !! !!##AUTHOR !! John S. Urban !!##LICENSE !! Public Domain function lookfor(basename,env) result(pathname) character(len=*),intent(in) :: basename character(len=*),intent(in) :: env character(len=:),allocatable :: pathname, checkon, paths(:) integer :: i logical :: r pathname='' call split(get_env(env),paths,delimiters=merge(';',':',separator() == '\')) if(size(paths) == 0)then paths=[''] endif do i=1,size(paths) checkon=trim(joinpath(trim(paths(i)),basename)) inquire(file=checkon, exist=r) if(r)then pathname=checkon exit endif enddo end function lookfor !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! get_env(3f) - [M_io:QUERY] a function returning the value of !! an environment variable !! (LICENSE:PD) !! !!##SYNTAX !! function get_env(NAME,DEFAULT) result(VALUE) !! !! character(len=*),intent(in) :: NAME !! character(len=*),intent(in),optional :: DEFAULT !! character(len=:),allocatable :: VALUE !! !! !!##DESCRIPTION !! Get the value of an environment variable or optionally return a !! default value if the returned value would be a blank string. !! !! This is a duplicate of system_getenv(3m_system) used to avoid !! some interdependencies. !! !!##OPTIONS !! NAME name of environment variable !! DEFAULT value to return if environment variable is not set or set !! to an empty string !!##RETURNS !! VALUE the value of the environment variable or the default !! !!##EXAMPLE !! !! Sample program: !! !! program demo_get_env !! use M_io, only : get_env !! character(len=:),allocatable :: HOME !! HOME=get_env('HOME','UNKNOWN') !! write(*,'(a)')HOME,get_env('PATH') !! write(*,'(a)')get_env('HOME'),get_env('PATH') !! end program demo_get_env !! !!##SEE ALSO !! get_environment_variable(3fortran), system_getenv(3m_system), !! set_environment_variable(3m_system), system_putenv(3m_system), !! system_clearenv(3m_system), system_initenv(3m_system), !! system_readenv(3m_system), system_unsetenv(3m_system) !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain function get_env(NAME, DEFAULT) result(VALUE) implicit none character(len=*), intent(in) :: NAME character(len=*), intent(in), optional :: DEFAULT character(len=:), allocatable :: VALUE integer :: howbig integer :: stat if (NAME /= '') then call get_environment_variable(NAME, length=howbig, status=stat, trim_name=.true.) ! get length required to hold value select case (stat) case (1); VALUE = '' ! NAME is not defined in the environment case (2); VALUE = '' ! This processor doesn't support environment variables. Boooh! case default allocate (character(len=max(howbig, 1)) :: VALUE) ! make string to hold value of sufficient size call get_environment_variable(NAME, VALUE, status=stat, trim_name=.true.) ! get value if (stat /= 0) VALUE = '' end select else VALUE = '' end if if (VALUE == '' .and. present(DEFAULT)) VALUE = DEFAULT end function get_env !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! get_next_char(3f) - [M_io:READ] read from a file one character at a time !! (LICENSE:PD) !! !!##SYNTAX !! subroutine get_next_char(fd,c,ios) !! !! integer,intent(in) :: fd !! character,intent(out) :: c !! integer,intent(out) :: ios !! !! !!##DESCRIPTION !! This reads a file opened with stream access one character at a !! time, much like ""read(fd,iostat=ios) c" but with buffering, which !! I have found to be up to sixty times faster than such a plain read, !! although this varies depending on how or if the programming environment !! implements I/O buffering itself. !! !! IT USES SAVED VARIABLES AND CAN ONLY BE USED ON ONE FILE AT A TIME !! IN THE CURRENT FORM. A user type including the saved values and the !! LUN could easily resolve this. !! !!##OPTIONS !! FD A Fortran unit number of a file opened for stream access !! C The next returned character if IOS=0 !! IOS The error status returned by the last read. It is zero (0) if !! no error occurred !! !!##EXAMPLE !! !! Sample program: !! !! program demo_get_next_char !! use,intrinsic :: iso_fortran_env, only : iostat_end !! use M_io, only : get_next_char !! implicit none !! character(len=4096) :: filename ! filename to read !! character(len=256) :: message ! returned error messages !! integer :: fd ! file descriptor for input file !! integer :: ios,ios1 ! hold I/O error flag !! character :: c1 ! current character read !! filename='test.in' !! open(unit=fd,file=trim(filename),access='stream',status='old',& !! & iostat=ios,action='read',form='unformatted',iomsg=message) !! if(ios /= 0)then !! write(*,*)& !! '*demo_get_next_char* ERROR: could not open '//& !! trim(filename) !! write(*,*)& !! '*demo_get_next_char* ERROR: '//trim(message) !! stop 5 !! endif !! ! loop through read of file one character at a time !! ONE_CHAR_AT_A_TIME: do !! ! get next character from buffered read from file !! call get_next_char(fd,c1,ios1) !! if(ios1 == iostat_end)then !! ! reached end of file so stop !! stop !! elseif(ios1 /= 0 )then !! ! error on file read !! write(*,*)& !! '*demo_get_next_char* ERROR: before end of '//& !! trim(filename) !! stop 1 !! endif !! ! do something with the characters !! write(*,'(a)',advance='no')c1 !! enddo ONE_CHAR_AT_A_TIME !! end program demo_get_next_char !! !!##AUTHOR !! John S. Urban !!##LICENSE !! Public Domain subroutine get_next_char(fd,c,ios) ! replace "read(fd,iostat=ios) c" because gfortran on CygWin sixty times slower with plain read (no system buffering?) ! quick buffering read implicit none integer,intent(in) :: fd character,intent(out) :: c integer,intent(out) :: ios integer,parameter :: bufsize=1048576 character(len=1),save :: buff(bufsize) integer,save :: point=0 integer,save :: filepoint=1 integer,save :: sz=bufsize ios=0 do select case(point) case(0) ! read a buffer read(fd,iostat=ios,pos=filepoint) buff(1:sz) if(is_iostat_end(ios))then ! this is the last buffer if(sz /= 1)then ! try again with a smaller buffer sz=sz/2 sz=max(1,sz) cycle endif elseif(ios == 0)then ! no error occurred so successfully read a buffer c=buff(1) filepoint=filepoint+sz point=sz-1 endif case(1:) ! getting a character from a previous buffer point=point-1 c=buff(sz-point) case default write(*,*)'*get_next_char* internal error ' read(fd,iostat=ios) c end select ! assume if IOS is not zero, not called again until new file is started if(ios /= 0)then filepoint=1 point=0 sz=bufsize endif exit enddo end subroutine get_next_char !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! notopen(3f) - [M_io:FILENAME] generate a filename containing a number !! (LICENSE:PD) !!##SYNOPSIS !! !! Usage !! !! function filename_generator(head,tail,num,lenlimit) result(filename) !! character(len=*),intent(in) :: head !! character(len=*),intent(in) :: tail !! integer,intent(in) :: num !! integer,intent(in) :: lenlimit !! character(len=:),allocatable :: filename !! !!##DESCRIPTION !! !! Generate a filename containing a representation of the specified !! whole number. This is useful for generating a series of filenames !! differing by a number such as "file1.txt", "file2.txt", !! ... . !! !!##OPTIONS !! !! head filename prefix. !! tail filename suffix. !! num number to represent as a string between HEAD and TAIL. !! lenlimit number of digits up to which to zero-pad the string !! representing NUM. !! !! !!##EXAMPLE !! !! !! Sample program: !! !! program demo_filename_generator !! use,intrinsic::iso_fortran_env,only:int8,int16,int32,int64 !! use M_io, only : filename_generator !! implicit none !! !! ! no zero-fill !! write(*,*) filename_generator("file_",".dat",11) !! ! zero-fill till 3 digits !! write(*,*) filename_generator("file_",".dat",11,3) !! ! zero-fill till 9 digits !! write(*,*) filename_generator("file_",".dat",11,9) !! ! same as default (no zero-fill) !! write(*,*) filename_generator("file_",".dat",11,0) !! !! end program demo_filename_generator !! !! Results !! !! > file_11.dat !! > file_011.dat !! > file_000000011.dat !! > file_11.dat !! !!##AUTHOR !! Zh, Niu; with modifications by John S. Urban !!##LICENSE !! Public Domain function filename_generator(head, tail, num, lenlimit) result(filename) character(*),intent(in) :: head character(*),intent(in) :: tail integer,intent(in) :: num integer,intent(in),optional :: lenlimit character(len=:),allocatable :: filename character(30) :: fmt integer :: local_lenlimit if ( present(lenlimit) ) then local_lenlimit = lenlimit else local_lenlimit = 0 endif fmt = "" write(fmt, '("(a,i0.",i2.2,",a)")' ) local_lenlimit filename=repeat(' ', len(head) + len(tail) + max(19,local_lenlimit) ) write(filename(:),fmt) trim(adjustl(head)), num, trim(adjustl(tail)) filename=trim(filename) end function filename_generator !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== ! routines from other modules to make this one stand-alone ! XX XX X ! X X X ! X X X ! XXXXX XX XX XXXXXX X XXX XXXXX XXXX XXXX XXXXX XXXXX ! X X X X X X X X X X X X X X X X ! X X X X X X X X X XXXXX X XXXXXXX XXX ! X X X X X X X X X X X X X XX ! X X X XX X X X X X X X X X X X X X X ! XXXXXX XX XX XXXXX XXXXX XXXXX XXXXX XXXX X XX XXXXX XXXXX ! X ! XXX !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== function lenset(line,length) result(strout) !character(len=*),parameter::ident_36="@(#)M_strings::lenset(3f): return string trimmed or padded to specified length" character(len=*),intent(in) :: line integer,intent(in) :: length character(len=length) :: strout strout=line end function lenset !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== subroutine a2i(chars,valu,ierr) !character(len=*),parameter::ident_41="@(#)M_strings::a2i(3fp): subroutine returns integer value from string" character(len=*),intent(in) :: chars ! input string integer,intent(out) :: valu ! value read from input string integer,intent(out) :: ierr ! error flag (0 == no error) doubleprecision :: valu8 valu8=0.0d0 call a2d(chars,valu8,ierr,onerr=0.0d0) if(valu8 <= huge(valu))then if(valu8 <= huge(valu))then valu=int(valu8) else write(*,*)'sc','*a2i*','- value too large',valu8,'>',huge(valu) valu=huge(valu) ierr=-1 endif endif end subroutine a2i !---------------------------------------------------------------------------------------------------------------------------------- subroutine a2d(chars,valu,ierr,onerr) !character(len=*),parameter::ident_42="@(#)M_strings::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) class(*),optional,intent(in) :: onerr !---------------------------------------------------------------------------------------------------------------------------------- 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 integer :: pnd integer :: basevalue, ivalu character(len=3),save :: nan_string='NaN' !---------------------------------------------------------------------------------------------------------------------------------- ierr=0 ! initialize error flag to zero local_chars=chars msg='' if(len(local_chars) == 0)local_chars=' ' call substitute(local_chars,',','') ! remove any comma characters pnd=scan(local_chars,'#:') if(pnd /= 0)then write(frmt,fmt)pnd-1 ! build format of form '(BN,Gn.0)' read(local_chars(:pnd-1),fmt=frmt,iostat=ierr,iomsg=msg)basevalue ! try to read value from string if(decodebase(local_chars(pnd+1:),basevalue,ivalu))then valu=real(ivalu,kind=kind(0.0d0)) else valu=0.0d0 ierr=-1 endif else 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 endif if(ierr /= 0)then ! if an error occurred ierr will be non-zero. if(present(onerr))then select type(onerr) type is (integer) valu=onerr type is (real) valu=onerr type is (doubleprecision) valu=onerr end select else ! set return value to NaN read(nan_string,'(g3.3)')valu endif if(local_chars /= 'eod')then ! print warning message except for special value "eod" write(*,*)'sc','*a2d* - cannot produce number from string ['//trim(chars)//']' if(msg /= '')then write(*,*)'*a2d* - ['//trim(msg)//']' endif endif endif end subroutine a2d !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== doubleprecision function s2v(chars,ierr,onerr) ! 1989 John S. Urban !character(len=*),parameter::ident_43="@(#)M_strings::s2v(3f): returns doubleprecision number from string" character(len=*),intent(in) :: chars integer,optional :: ierr doubleprecision :: valu integer :: ierr_local class(*),intent(in),optional :: onerr ierr_local=0 if(present(onerr))then call a2d(chars,valu,ierr_local,onerr) else call a2d(chars,valu,ierr_local) endif if(present(ierr))then ! if error is not returned stop program on error ierr=ierr_local s2v=valu elseif(ierr_local /= 0)then write(*,*)'*s2v* stopped while reading '//trim(chars) stop 1 else s2v=valu endif end function s2v !=================================================================================================================================== ! calls to s2v(3f) for extending intrinsics int(3f), real(3f), dble(3f) !=================================================================================================================================== doubleprecision function dble_s2v(chars) character(len=*),intent(in) :: chars dble_s2v=s2v(chars) end function dble_s2v !=================================================================================================================================== real function real_s2v(chars) character(len=*),intent(in) :: chars real_s2v=real(s2v(chars)) end function real_s2v !=================================================================================================================================== integer function int_s2v(chars) character(len=*),intent(in) :: chars int_s2v=int(s2v(chars)) end function int_s2v !=================================================================================================================================== function ints_s2v(chars) integer,allocatable :: ints_s2v(:) character(len=*),intent(in) :: chars(:) integer :: i,isize isize=size(chars) allocate(ints_s2v(isize)) do i=1,isize ints_s2v(i)=int(s2v(chars(i))) enddo end function ints_s2v !=================================================================================================================================== function reals_s2v(chars) real,allocatable :: reals_s2v(:) character(len=*),intent(in) :: chars(:) integer :: i,isize isize=size(chars) allocate(reals_s2v(isize)) do i=1,isize reals_s2v(i)=real(s2v(chars(i))) enddo end function reals_s2v !=================================================================================================================================== function dbles_s2v(chars) doubleprecision,allocatable :: dbles_s2v(:) character(len=*),intent(in) :: chars(:) integer :: i,isize isize=size(chars) allocate(dbles_s2v(isize)) do i=1,isize dbles_s2v(i)=s2v(chars(i)) enddo end function dbles_s2v !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()())()()()()()()()()()()()()! !=================================================================================================================================== function s2vs(string,delim) result(darray) !character(len=*),parameter::ident_55="@(#)M_strings::s2vs(3f): function returns array of values from a string" character(len=*),intent(in) :: string ! keyword to retrieve value for from dictionary character(len=*),optional :: delim ! delimiter characters character(len=:),allocatable :: delim_local doubleprecision,allocatable :: darray(:) ! function type character(len=:),allocatable :: carray(:) ! convert value to an array using split(3f) integer :: i integer :: ier !----------------------------------------------------------------------------------------------------------------------------------- if(present(delim))then delim_local=delim else delim_local=' ;,' endif !----------------------------------------------------------------------------------------------------------------------------------- call split(string,carray,delimiters=delim_local) ! split string into an array allocate(darray(size(carray))) ! create the output array do i=1,size(carray) call string_to_value(carray(i), darray(i), ier) ! convert the string to a numeric value enddo !----------------------------------------------------------------------------------------------------------------------------------- end function s2vs !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== logical function decodebase(string,basein,out_baseten) implicit none !character(len=*),parameter::ident_72="@(#)M_strings::decodebase(3f): convert whole number string in base [2-36] to base 10 number" character(len=*),intent(in) :: string integer,intent(in) :: basein integer,intent(out) :: out_baseten character(len=len(string)) :: string_local integer :: long, i, j, k real :: y real :: mult character(len=1) :: ch real,parameter :: XMAXREAL=real(huge(1)) integer :: out_sign integer :: basein_local integer :: ipound integer :: ierr string_local=upper(trim(adjustl(string))) decodebase=.false. ipound=index(string_local,'#') ! determine if in form [-]base#whole if(basein == 0.and.ipound > 1)then ! split string into two values call string_to_value(string_local(:ipound-1),basein_local,ierr) ! get the decimal value of the base string_local=string_local(ipound+1:) ! now that base is known make string just the value if(basein_local >= 0)then ! allow for a negative sign prefix out_sign=1 else out_sign=-1 endif basein_local=abs(basein_local) else ! assume string is a simple positive value basein_local=abs(basein) out_sign=1 endif out_baseten=0 y=0.0 ALL: if(basein_local<2.or.basein_local>36) then print *,'(*decodebase* ERROR: Base must be between 2 and 36. base=',basein_local else ALL out_baseten=0;y=0.0; mult=1.0 long=LEN_TRIM(string_local) do i=1, long k=long+1-i ch=string_local(k:k) if(ch == '-'.and.k == 1)then out_sign=-1 cycle endif if(ch<'0'.or.ch>'Z'.or.(ch>'9'.and.ch<'A'))then write(*,*)'*decodebase* ERROR: invalid character ',ch exit ALL endif if(ch<='9') then j=IACHAR(ch)-IACHAR('0') else j=IACHAR(ch)-IACHAR('A')+10 endif if(j>=basein_local)then exit ALL endif y=y+mult*j if(mult>XMAXREAL/basein_local)then exit ALL endif mult=mult*basein_local enddo decodebase=.true. out_baseten=nint(out_sign*y)*sign(1,basein) endif ALL end function decodebase !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== subroutine trimzeros(string) !character(len=*),parameter::ident_50="@(#)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,'.') == 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 <= 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 !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== subroutine substitute(targetline,old,new,ierr,start,end) !character(len=*),parameter::ident_11="@(#)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 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 !----------------------------------------------------------------------------------------------------------------------------------- character(len=len(targetline)) :: dum1 ! scratch string buffers 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 <= 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 == 0)then ! c//new/ means insert new at beginning of line (or left margin) ichar=len_new + original_input_length if(ichar > maxlengthout)then write(*,*)'*substitute* new line will be too long' ier1=-1 if (present(ierr))ierr=ier1 return endif if(len_new > 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 == ic-1.or.ind > 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 > 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 > maxlengthout)then ier1=-1 exit loop endif dum1(ichar:)=targetline(ic:ind-1) ichar=ichar+ladd endif if(ichar-1+len_new > maxlengthout)then ier1=-2 exit loop endif if(len_new /= 0)then dum1(ichar:)=new(:len_new) ichar=ichar+len_new endif ic=ind+len_old enddo loop !----------------------------------------------------------------------------------------------------------------------------------- select case (ier1) case (:-1) write(*,*)'*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 > maxlengthout)then write(*,*)'*substitute* new line will be too long' ier1=-1 if(present(ierr))ierr=ier1 return endif if(ic < 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 ! isnumber(3f) - [M_strings:NUMERIC] determine if a string represents a number ! (LICENSE:PD) ! ! SYNOPSIS ! function isnumber(str,msg) ! ! character(len=*),intent(in) :: str ! character(len=:),intent(out),allocatable,optional :: msg ! ! DESCRIPTION ! ISNUMBER(3f) returns a value greater than zero if the string represents ! a number, and a number less than or equal to zero if it is a bad number. ! Blank characters are ignored. ! ! OPTIONS ! str the string to evaluate as to whether it represents a numeric value ! or not ! msg An optional message describing the string ! ! RETURNS ! isnumber the following values are returned ! ! 1 for an integer [-+]NNNNN ! 2 for a whole number [-+]NNNNN. ! 3 for a real value [-+]NNNNN.MMMM ! 4 for a exponential value [-+]NNNNN.MMMM[-+]LLLL ! [-+]NNNNN.MMMM[ed][-+]LLLL ! ! values less than 1 represent an error ! ! EXAMPLES ! As the example shows, you can use an internal READ(3f) along with the ! IOSTAT= parameter to check (and read) a string as well. ! ! program demo_isnumber ! use M_strings, only : isnumber ! implicit none ! character(len=256) :: line ! real :: value ! integer :: ios ! integer :: answer ! character(len=256) :: message ! character(len=:),allocatable :: description ! write(*,*)'Begin entering values, one per line' ! do ! read(*,'(a)',iostat=ios)line ! ! ! ! try string as number using list-directed input ! line='' ! read(line,*,iostat=ios,iomsg=message) value ! if(ios == 0)then ! write(*,*)'VALUE=',value ! elseif( is_iostat_end(ios) ) then ! stop 'end of file' ! else ! write(*,*)'ERROR:',ios,trim(message) ! endif ! ! ! ! try string using isnumber(3f) ! answer=isnumber(line,msg=description) ! if(answer > 0)then ! write(*,*) & ! & ' for ',trim(line),' ',answer,':',description ! else ! write(*,*) & ! & ' ERROR for ',trim(line),' ',answer,':',description ! endif ! ! ! enddo ! end program demo_isnumber ! ! Example run ! ! > Begin entering values ! > ERROR: -1 End of file ! > ERROR for -1 :null string ! >10 ! > VALUE= 10.0000000 ! > for 10 1 :integer ! >20 ! > VALUE= 20.0000000 ! > for 20 1 :integer ! >20. ! > VALUE= 20.0000000 ! > for 20. 2 :whole number ! >30.1 ! > VALUE= 30.1000004 ! > for 30.1 3 :real number ! >3e1 ! > VALUE= 30.0000000 ! > for 3e1 4 :value with exponent ! >1-2 ! > VALUE= 9.99999978E-03 ! > for 1-2 4 :value with exponent ! >100.22d-4 ! > VALUE= 1.00220004E-02 ! > for 100.22d-4 4 :value with exponent ! >1--2 ! > ERROR: 5010 Bad real number in item 1 of list input ! > ERROR for 1--2 -5 :bad number ! >e ! > ERROR: 5010 Bad real number in item 1 of list input ! > ERROR for e -6 :missing leading value before exponent ! >e1 ! > ERROR: 5010 Bad real number in item 1 of list input ! > ERROR for e1 -6 :missing leading value before exponent ! >1e ! > ERROR: 5010 Bad real number in item 1 of list input ! > ERROR for 1e -3 :missing exponent ! >1e+ ! > ERROR: 5010 Bad real number in item 1 of list input ! > ERROR for 1e+ -4 :missing exponent after sign ! >1e+2.0 ! > ERROR: 5010 Bad real number in item 1 of list input ! > ERROR for 1e+2.0 -5 :bad number ! ! AUTHOR ! John S. Urban ! ! LICENSE ! Public Domain function isNumber(string,msg,verbose) implicit none ! ident_1="@(#)M_strings::isnumber(3f): Determines if a string is a number of not." character(len=*),intent(in) :: string character(len=:),intent(out),allocatable,optional :: msg logical,intent(in),optional :: verbose integer :: isnumber integer :: i,iend character(len=1),allocatable :: z(:) character(len=:),allocatable :: message logical :: founddigit logical :: verbose_local i=1 founddigit=.false. isnumber=0 z=s2a(trim(nospace(string))) iend=size(z) message='not a number' if(present(verbose))then verbose_local=verbose else verbose_local=.false. endif DONE : block if(iend == 0)then isnumber=-1 ! string is null message='null string' exit DONE endif if(index('+-',z(i)) /= 0) i=i+1 ! skip optional leading sign if(i > iend)then isnumber=-2 ! string was just a sign message='just a sign' exit DONE endif call next() ! position I to next non-digit or end of string+1 if(i > iend)then isnumber=1 ! [+-]NNNNNN message='integer' exit DONE endif if(z(i) == '.')then ! a period would be OK at this point i=i+1 endif if(i > iend)then ! [+-]NNNNNN. isnumber=2 message='whole number' exit DONE endif call next() ! position I to next non-digit or end of string+1 if(i > iend)then isnumber=3 ! [+-]NNNNNN.MMMM message='real number' exit DONE endif if(index('eEdD',z(i)) /= 0)then i=i+1 if(i == 2)then isnumber=-6 ! [+-]NNNNNN[.[MMMM]]e but a value must follow message='missing leading value before exponent' exit DONE endif endif if(i > iend)then isnumber=-3 ! [+-]NNNNNN[.[MMMM]]e but a value must follow message='missing exponent' exit DONE endif if(.not.founddigit)then isnumber=-7 message='missing value before exponent' exit DONE endif if(index('+-',z(i)) /= 0) i=i+1 if(i > iend)then isnumber=-4 ! [+-]NNNNNN[.[MMMM]]e[+-] but a value must follow message='missing exponent after sign' exit DONE endif call next() ! position I to next non-digit or end of string+1 if(i > iend)then isnumber=4 ! [+-]NNNNNN.MMMMe[+-]LL message='value with exponent' exit DONE endif isnumber=-5 message='bad number' endblock DONE if(verbose_local)then write(*,*)trim(string)//' is '//message endif if(present(msg))then msg=message endif contains subroutine next() ! move to next non-digit or end of string+1 integer :: j do j=i,iend if(.not.isdigit(z(j)))then exit endif founddigit=.true. if(verbose_local) write(*,*)'I=',i,' J=',j,' Z(j)=',z(j) enddo i=j if(verbose_local)then write(*,*)'I and J=',i if(i <= iend) then write(*,*)'Z(I)=',z(i) else write(*,*)'====>' endif endif end subroutine next end function isNumber !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== elemental function isdigit(ch) result(res) ! ident_2="@(#)M_strings::isdigit(3f): Returns .true. if ch is a digit (0-9) and .false. otherwise" character,intent(in) :: ch logical :: res select case(ch) case('0':'9') res=.true. case default res=.false. end select end function isdigit !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== ! NAME ! nospace(3f) - [M_strings:WHITESPACE] remove all whitespace from ! input string ! (LICENSE:PD) ! ! SYNOPSIS ! function nospace(str) - remove all whitespace from input string ! ! character(len=*),intent(in) :: str ! character(len=:),allocatable :: nospace ! ! DESCRIPTION ! nospace(3f) removes space, tab, carriage return, new line, vertical ! tab, formfeed and null characters (called "whitespace"). The output ! is returned trimmed. ! ! EXAMPLES ! Sample program: ! ! program demo_nospace ! use M_strings, only: nospace ! implicit none ! character(len=:),allocatable :: s ! s=' This is a test ' ! write(*,*) 'original input string is ....',s ! write(*,*) 'processed output string is ...',nospace(s) ! if(nospace(s) == 'Thisisatest')then ! write(*,*)'nospace test passed' ! else ! write(*,*)'nospace test error' ! endif ! end program demo_nospace ! ! Expected output ! ! original input string is .... This is a test ! processed output string is ...Thisisatest ! nospace test passed ! ! AUTHOR ! John S. Urban ! ! LICENSE ! Public Domain function nospace(line) ! ident_3="@(#)M_strings::nospace(3f): remove all whitespace from input string" character(len=*),intent(in) :: line ! remove whitespace from this string and return it character(len=:),allocatable :: nospace ! returned string integer :: ipos ! position to place next output character at integer :: i ! counter to increment from beginning to end of input string !----------------------------------------------------------------------------------------------------------------------------------- allocate(nospace,mold=line) ! initially make output line length of input line nospace(:len_trim(nospace))=' ' ipos=0 do i=1,len_trim(line) ! increment from first to last character of the input line if ( isspace( line(i:i) ) ) cycle ! if a blank is encountered skip it ipos=ipos+1 ! increment count of non-blank characters found nospace(ipos:ipos)=line(i:i) ! store non-blank character in output enddo nospace=trim(nospace) ! blank out unpacked part of line end function nospace !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! isspace(3f) - [M_strings:COMPARE] returns .true. if character is a !! null, space, tab, carriage return, new line, vertical tab, or formfeed !! (LICENSE:PD) !! !!##SYNOPSIS !! !! !! elemental function isspace(onechar) !! !! character,intent(in) :: onechar !! logical :: isspace !! !!##DESCRIPTION !! isspace(3f) returns .true. if character is a null, space, tab, !! carriage return, new line, vertical tab, or formfeed !! !!##OPTIONS !! onechar character to test !! !!##RETURNS !! isspace returns true if character is ASCII white space !! !!##EXAMPLE !! !! Sample program: !! !! program demo_isspace !! use M_strings, only : isspace !! implicit none !! integer :: i !! character(len=1),parameter :: string(*)=[(char(i),i=0,127)] !! write(*,'(20(g0,1x))')'ISSPACE: ', & !! & ichar(pack( string, isspace(string) )) !! end program demo_isspace !! !! Results: !! !! ISSPACE: 0 9 10 11 12 13 32 !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain elemental function isspace(ch) result(res) ! ident_63="@(#)M_strings::isspace(3f): true if null,space,tab,return,new line,vertical tab, or formfeed" character,intent(in) :: ch logical :: res select case(ch) case(' ') ! space(32) res=.true. case(char(0)) ! null(0) res=.true. case(char(9):char(13)) ! tab(9), new line(10), vertical tab(11), formfeed(12), carriage return(13), res=.true. case default res=.false. end select end function isspace !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== subroutine split(input_line,array,delimiters,order,nulls) !----------------------------------------------------------------------------------------------------------------------------------- !character(len=*),parameter::ident_7="& !&@(#)M_strings::split(3f): parse string on delimiter characters and store tokens into an allocatable array" ! John S. Urban !----------------------------------------------------------------------------------------------------------------------------------- intrinsic index, min, present, len !----------------------------------------------------------------------------------------------------------------------------------- ! given a line of structure " par1 par2 par3 ... parn " store each par(n) into a separate variable in array. ! o by default adjacent delimiters in the input string do not create an empty string in the output array ! o no quoting of delimiters is supported character(len=*),intent(in) :: input_line ! input string to tokenize character(len=*),optional,intent(in) :: delimiters ! list of delimiter characters character(len=*),optional,intent(in) :: order ! order of output array sequential|[reverse|right] character(len=*),optional,intent(in) :: nulls ! return strings composed of delimiters or not ignore|return|ignoreend character(len=:),allocatable,intent(out) :: array(:) ! output array of tokens !----------------------------------------------------------------------------------------------------------------------------------- integer :: n ! max number of strings INPUT_LINE could split into if all delimiter integer,allocatable :: ibegin(:) ! positions in input string where tokens start integer,allocatable :: iterm(:) ! positions in input string where tokens end character(len=:),allocatable :: dlim ! string containing delimiter characters character(len=:),allocatable :: ordr ! string containing order keyword character(len=:),allocatable :: nlls ! string containing nulls keyword integer :: ii,iiii ! loop parameters used to control print order integer :: icount ! number of tokens found integer :: ilen ! length of input string with trailing spaces trimmed integer :: i10,i20,i30 ! loop counters integer :: icol ! pointer into input string as it is being parsed integer :: idlim ! number of delimiter characters integer :: ifound ! where next delimiter character is found in remaining input string data integer :: inotnull ! count strings not composed of delimiters integer :: ireturn ! number of tokens returned integer :: imax ! length of longest token !----------------------------------------------------------------------------------------------------------------------------------- ! decide on value for optional DELIMITERS parameter if (present(delimiters)) then ! optional delimiter list was present if(delimiters /= '')then ! if DELIMITERS was specified and not null use it dlim=delimiters else ! DELIMITERS was specified on call as empty string dlim=' '//char(9)//char(10)//char(11)//char(12)//char(13)//char(0) ! use default delimiter when not specified endif else ! no delimiter value was specified dlim=' '//char(9)//char(10)//char(11)//char(12)//char(13)//char(0) ! use default delimiter when not specified endif idlim=len(dlim) ! dlim a lot of blanks on some machines if dlim is a big string !----------------------------------------------------------------------------------------------------------------------------------- if(present(order))then; ordr=lower(adjustl(order)); else; ordr='sequential'; endif ! decide on value for optional ORDER parameter if(present(nulls))then; nlls=lower(adjustl(nulls)); else; nlls='ignore' ; endif ! optional parameter !----------------------------------------------------------------------------------------------------------------------------------- n=len(input_line)+1 ! max number of strings INPUT_LINE could split into if all delimiter allocate(ibegin(n)) ! allocate enough space to hold starting location of tokens if string all tokens allocate(iterm(n)) ! allocate enough space to hold ending location of tokens if string all tokens ibegin(:)=1 iterm(:)=1 !----------------------------------------------------------------------------------------------------------------------------------- ilen=len(input_line) ! ILEN is the column position of the last non-blank character icount=0 ! how many tokens found inotnull=0 ! how many tokens found not composed of delimiters imax=0 ! length of longest token found !----------------------------------------------------------------------------------------------------------------------------------- select case (ilen) !----------------------------------------------------------------------------------------------------------------------------------- case (:0) ! command was totally blank !----------------------------------------------------------------------------------------------------------------------------------- case default ! there is at least one non-delimiter in INPUT_LINE if get here icol=1 ! initialize pointer into input line INFINITE: do i30=1,ilen,1 ! store into each array element ibegin(i30)=icol ! assume start new token on the character if(index(dlim(1:idlim),input_line(icol:icol)) == 0)then ! if current character is not a delimiter iterm(i30)=ilen ! initially assume no more tokens do i10=1,idlim ! search for next delimiter ifound=index(input_line(ibegin(i30):ilen),dlim(i10:i10)) IF(ifound > 0)then iterm(i30)=min(iterm(i30),ifound+ibegin(i30)-2) endif enddo icol=iterm(i30)+2 ! next place to look as found end of this token inotnull=inotnull+1 ! increment count of number of tokens not composed of delimiters else ! character is a delimiter for a null string iterm(i30)=icol-1 ! record assumed end of string. Will be less than beginning icol=icol+1 ! advance pointer into input string endif imax=max(imax,iterm(i30)-ibegin(i30)+1) icount=i30 ! increment count of number of tokens found if(icol > ilen)then ! no text left exit INFINITE endif enddo INFINITE !----------------------------------------------------------------------------------------------------------------------------------- end select !----------------------------------------------------------------------------------------------------------------------------------- select case (trim(adjustl(nlls))) case ('ignore','','ignoreend') ireturn=inotnull case default ireturn=icount end select allocate(character(len=imax) :: array(ireturn)) ! allocate the array to return !allocate(array(ireturn)) ! allocate the array to turn !----------------------------------------------------------------------------------------------------------------------------------- select case (trim(adjustl(ordr))) ! decide which order to store tokens case ('reverse','right') ; ii=ireturn ; iiii=-1 ! last to first case default ; ii=1 ; iiii=1 ! first to last end select !----------------------------------------------------------------------------------------------------------------------------------- do i20=1,icount ! fill the array with the tokens that were found if(iterm(i20) < ibegin(i20))then select case (trim(adjustl(nlls))) case ('ignore','','ignoreend') case default array(ii)=' ' ii=ii+iiii end select else array(ii)=input_line(ibegin(i20):iterm(i20)) ii=ii+iiii endif enddo !----------------------------------------------------------------------------------------------------------------------------------- end subroutine split !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== elemental pure function upper(str,begin,end) result (string) !character(len=*),parameter::ident_21="@(#)M_strings::upper(3f): Changes a string to uppercase" character(*), intent(In) :: str ! inpout string to convert to all uppercase integer, intent(in), optional :: begin,end character(len(str)) :: string ! output string that contains no miniscule letters integer :: i ! loop counter integer :: ibegin,iend string = str ! initialize output string to input string ibegin = 1 if (present(begin))then ibegin = max(ibegin,begin) endif iend = len_trim(str) if (present(end))then iend= min(iend,end) endif do i = ibegin, iend ! step thru each letter in the string in specified range select case (str(i:i)) case ('a':'z') ! located miniscule letter string(i:i) = char(iachar(str(i:i))-32) ! change miniscule letter to uppercase end select end do end function upper !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== elemental pure function lower(str,begin,end) result (string) !character(len=*),parameter::ident_22="@(#)M_strings::lower(3f): Changes a string to lowercase over specified range" character(*), intent(In) :: str character(len(str)) :: string integer,intent(in),optional :: begin, end integer :: i integer :: ibegin, iend string = str ibegin = 1 if (present(begin))then ibegin = max(ibegin,begin) endif iend = len_trim(str) if (present(end))then iend= min(iend,end) endif do i = ibegin, iend ! step thru each letter in the string in specified range select case (str(i:i)) case ('A':'Z') string(i:i) = char(iachar(str(i:i))+32) ! change letter to miniscule case default end select end do end function lower !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== pure function s2a(string) RESULT (array) !character(len=*),parameter::ident_24="@(#)M_strings::s2a(3fp): function to copy string(1:Clen(string)) to char array" character(len=*),intent(in) :: string character(len=1) :: array(len(string)) integer :: i ! ---------------------------------------------------------------------------------------------------------------------------------- forall(i=1:len(string)) array(i) = string(i:i) ! ---------------------------------------------------------------------------------------------------------------------------------- end function s2a !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== function i2s(ivalue,fmt) result(outstr) !character(len=*),parameter::ident_47="@(#)M_strings::i2s(3fp): private function returns string given integer value" integer,intent(in) :: ivalue ! input value to convert to a string character(len=*),intent(in),optional :: fmt character(len=:),allocatable :: outstr ! output string to generate character(len=80) :: string if(present(fmt))then call value_to_string(ivalue,string,fmt=fmt) else call value_to_string(ivalue,string) endif outstr=trim(string) end function i2s !=================================================================================================================================== subroutine value_to_string(gval,chars,length,err,fmt,trimz) !character(len=*),parameter::ident_40="@(#)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 logical,intent(in),optional :: trimz character(len=:),allocatable :: fmt_local character(len=1024) :: msg ! Notice that the value GVAL can be any of several types ( INTEGER,REAL,DOUBLEPRECISION,LOGICAL) if (present(fmt)) then select type(gval) type is (integer) fmt_local='(i0)' if(fmt /= '') fmt_local=fmt write(chars,fmt_local,iostat=err_local,iomsg=msg)gval type is (real) fmt_local='(bz,g23.10e3)' fmt_local='(bz,g0.8)' if(fmt /= '') fmt_local=fmt write(chars,fmt_local,iostat=err_local,iomsg=msg)gval type is (doubleprecision) fmt_local='(bz,g0)' if(fmt /= '') fmt_local=fmt write(chars,fmt_local,iostat=err_local,iomsg=msg)gval type is (logical) fmt_local='(l1)' if(fmt /= '') fmt_local=fmt write(chars,fmt_local,iostat=err_local,iomsg=msg)gval class default write(*,*)'*value_to_string* UNKNOWN TYPE' chars=' ' end select if(fmt == '') then chars=adjustl(chars) call trimzeros(chars) endif else ! no explicit format option present err_local=-1 select type(gval) type is (integer) write(chars,*,iostat=err_local,iomsg=msg)gval type is (real) write(chars,*,iostat=err_local,iomsg=msg)gval type is (doubleprecision) write(chars,*,iostat=err_local,iomsg=msg)gval type is (logical) write(chars,*,iostat=err_local,iomsg=msg)gval class default chars='' end select chars=adjustl(chars) if(index(chars,'.') /= 0) call trimzeros(chars) endif if(present(trimz))then if(trimz)then chars=adjustl(chars) call trimzeros(chars) endif endif if(present(length)) then length=len_trim(chars) endif if(present(err)) then err=err_local elseif(err_local /= 0)then !! cannot currently do I/O from a function being called from I/O !!write(ERROR_UNIT,'(a)')'*value_to_string* WARNING:['//trim(msg)//']' chars=chars//' *value_to_string* WARNING:['//trim(msg)//']' endif end subroutine value_to_string !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== function merge_str(str1,str2,expr) result(strout) ! for some reason the MERGE(3f) intrinsic requires the strings it compares to be of equal length ! make an alias for MERGE(3f) that makes the lengths the same before doing the comparison by padding the shorter one with spaces !character(len=*),parameter::ident_37="@(#)M_strings::merge_str(3f): pads first and second arguments to MERGE(3f) to same length" character(len=*),intent(in) :: str1 character(len=*),intent(in) :: str2 logical,intent(in) :: expr character(len=:),allocatable :: strout integer :: big big=max(len(str1),len(str2)) strout=trim(merge(lenset(str1,big),lenset(str2,big),expr)) end function merge_str !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== subroutine notabs(INSTR,OUTSTR,ILEN) !character(len=*),parameter::ident_31="& !&@(#)M_strings::notabs(3f): convert tabs to spaces while maintaining columns, remove CRLF chars" CHARACTER(LEN=*),INTENT(IN) :: instr ! input line to scan for tab characters CHARACTER(LEN=*),INTENT(OUT) :: outstr ! tab-expanded version of INSTR produced INTEGER,INTENT(OUT) :: ilen ! column position of last character put into output string ! that is, ILEN holds the position of the last non-blank character in OUTSTR !=================================================================================================================================== INTEGER,PARAMETER :: tabsize=8 ! assume a tab stop is set every 8th column INTEGER :: ipos ! position in OUTSTR to put next character of INSTR INTEGER :: lenin ! length of input string trimmed of trailing spaces INTEGER :: lenout ! number of characters output string can hold INTEGER :: istep ! counter that advances thru input string INSTR one character at a time CHARACTER(LEN=1) :: c ! character in input line being processed INTEGER :: iade ! ADE (ASCII Decimal Equivalent) of character being tested !=================================================================================================================================== IPOS=1 ! where to put next character in output string OUTSTR lenin=LEN(instr) ! length of character variable INSTR lenin=LEN_TRIM(instr(1:lenin)) ! length of INSTR trimmed of trailing spaces lenout=LEN(outstr) ! number of characters output string OUTSTR can hold OUTSTR=" " ! this SHOULD blank-fill string, a buggy machine required a loop to set all characters !=================================================================================================================================== SCAN_LINE: DO istep=1,lenin ! look through input string one character at a time c=instr(istep:istep) ! get next character iade=ICHAR(c) ! get ADE of the character expand_tabs : SELECT CASE (iade) ! take different actions depending on which character was found CASE(9) ! test if character is a tab and move pointer out to appropriate column ipos = ipos + (tabsize - (MOD(ipos-1,tabsize))) CASE(10,13) ! convert carriage-return and new-line to space ,typically to handle DOS-format files ipos=ipos+1 CASE DEFAULT ! c is anything else other than a tab,newline,or return insert it in output string IF(ipos > lenout)THEN write(*,*)"*notabs* output string overflow" EXIT ELSE outstr(ipos:ipos)=c ipos=ipos+1 ENDIF END SELECT expand_tabs enddo SCAN_LINE !=================================================================================================================================== ipos=MIN(ipos,lenout) ! tabs or newline or return characters or last character might have gone too far ilen=LEN_TRIM(outstr(:ipos)) ! trim trailing spaces !=================================================================================================================================== END SUBROUTINE notabs !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== elemental function noesc(INSTR) ! ident_48="@(#) M_strings noesc(3f) convert non-printable characters to a space" character(len=*),intent(in) :: INSTR ! string that might contain nonprintable characters character(len=len(instr)) :: noesc integer :: ic,i10 noesc='' ! initialize output string do i10=1,len_trim(INSTR(1:len(INSTR))) ic=iachar(INSTR(i10:i10)) if(ic <= 31.or.ic == 127)then ! find characters with ADE of 0-31, 127 noesc(I10:I10)=' ' ! replace non-printable characters with a space else noesc(I10:I10)=INSTR(i10:i10) ! copy other characters as-is from input string to output string endif enddo end function noesc !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== subroutine where_write_message(where,msg) ! ident_2="@(#)M_journal::where_write_message(3fp): basic message routine used for journal files" character(len=*),intent(in) :: where character(len=*),intent(in) :: msg logical,save :: trailopen=.false. integer,save :: itrail character,save :: comment='#' integer :: i integer :: ios integer :: times ! number of times written to my_stdout character(len=3) :: adv ! whether remaining writes from this call use advancing I/O character(len=4096) :: mssge adv='yes' times=0 do i=1,len_trim(where) select case(where(i:i)) case('T','t') if(trailopen) then write(itrail,'(a)',advance=adv)trim(msg) endif case('S','s') write(my_stdout,'(a)',advance=adv)trim(msg) times=times+1 case('E','e') write(stderr,'(a)',advance=adv)trim(msg) times=times+1 case('+'); adv='no' case('>'); debug=.true. case('<'); debug=.false. case('N') ! new name for my_stdout if(msg /= ' '.and.msg /= '#N#'.and.msg /= '"#N#"')then ! if filename not special or blank open new file close(unit=last_int,iostat=ios) open(unit=last_int,file=adjustl(trim(msg)),iostat=ios) if(ios == 0)then my_stdout=last_int else write(*,*)'*journal* error opening redirected output file, ioerr=',ios write(*,*)'*journal* msg='//trim(msg) endif elseif(msg == ' ')then close(unit=last_int,iostat=ios) my_stdout=6 endif case('C','c') if(trailopen)then write(itrail,'(3a)',advance=adv)comment,trim(msg) elseif(times == 0)then !! write(my_stdout,'(2a)',advance=adv)trim(msg) !! times=times+1 endif case('D','d') if(debug)then if(trailopen)then write(itrail,'(4a)',advance=adv)comment,'DEBUG: ',trim(msg) elseif(times == 0)then write(my_stdout,'(3a)',advance=adv)'DEBUG:',trim(msg) times=times+1 endif endif case('F','f') flush(unit=itrail,iostat=ios,iomsg=mssge) if(ios /= 0)then write(*,'(a)') trim(mssge) endif case('A','a') if(msg /= '')then open(newunit=itrail,status='unknown',access='sequential',file=adjustl(trim(msg)),& & form='formatted',iostat=ios,position='append') trailopen=.true. endif case('O','o') if(msg /= '')then open(newunit=itrail,status='unknown',access='sequential', file=adjustl(trim(msg)),form='formatted',iostat=ios) trailopen=.true. else if(trailopen)then write(itrail,'(4a)',advance=adv)comment,'closing trail file:',trim(msg) endif close(unit=itrail,iostat=ios) trailopen=.false. endif case default write(my_stdout,'(a)',advance=adv)'*journal* bad WHERE value '//trim(where)//' when msg=['//trim(msg)//']' end select enddo end subroutine where_write_message subroutine where_write_message_all(where, g0, g1, g2, g3, g4, g5, g6, g7, g8, g9, sep) implicit none ! ident_5="@(#)M_journal::where_write_message_all(3f): writes a message to a string composed of any standard scalar types" character(len=*),intent(in) :: where class(*),intent(in) :: g0 class(*),intent(in),optional :: g1, g2, g3, g4, g5, g6, g7, g8 ,g9 character(len=*),intent(in),optional :: sep call where_write_message(where,str(g0, g1, g2, g3, g4, g5, g6, g7, g8, g9,sep)) end subroutine where_write_message_all subroutine write_message_only(message) ! ident_6="@(#)M_journal::write_message_only(3fp): calls JOURNAL('sc',message)" character(len=*),intent(in) :: message call where_write_message('sc',trim(message)) end subroutine write_message_only function msg_scalar(generic0, generic1, generic2, generic3, generic4, generic5, generic6, generic7, generic8, generic9, & & generica, genericb, genericc, genericd, generice, genericf, genericg, generich, generici, genericj, & & sep) ! ident_2="@(#)M_msg::msg_scalar(3fp): writes a message to a string composed of any standard scalar types" class(*),intent(in),optional :: generic0, generic1, generic2, generic3, generic4 class(*),intent(in),optional :: generic5, generic6, generic7, generic8, generic9 class(*),intent(in),optional :: generica, genericb, genericc, genericd, generice class(*),intent(in),optional :: genericf, genericg, generich, generici, genericj character(len=*),intent(in),optional :: sep character(len=:),allocatable :: sep_local character(len=:), allocatable :: msg_scalar character(len=4096) :: line integer :: istart integer :: increment if(present(sep))then increment=len(sep)+1 sep_local=sep else sep_local=' ' increment=2 endif istart=1 line='' if(present(generic0))call print_generic(generic0) if(present(generic1))call print_generic(generic1) if(present(generic2))call print_generic(generic2) if(present(generic3))call print_generic(generic3) if(present(generic4))call print_generic(generic4) if(present(generic5))call print_generic(generic5) if(present(generic6))call print_generic(generic6) if(present(generic7))call print_generic(generic7) if(present(generic8))call print_generic(generic8) if(present(generic9))call print_generic(generic9) if(present(generica))call print_generic(generica) if(present(genericb))call print_generic(genericb) if(present(genericc))call print_generic(genericc) if(present(genericd))call print_generic(genericd) if(present(generice))call print_generic(generice) if(present(genericf))call print_generic(genericf) if(present(genericg))call print_generic(genericg) if(present(generich))call print_generic(generich) if(present(generici))call print_generic(generici) if(present(genericj))call print_generic(genericj) msg_scalar=trim(line) contains subroutine print_generic(generic) !use, intrinsic :: iso_fortran_env, only : int8, int16, int32, biggest=>int64, real32, real64, dp=>real128 use,intrinsic :: iso_fortran_env, only : int8, int16, int32, int64, real32, real64, real128 class(*),intent(in) :: generic select type(generic) type is (integer(kind=int8)); write(line(istart:),'(i0)') generic type is (integer(kind=int16)); write(line(istart:),'(i0)') generic type is (integer(kind=int32)); write(line(istart:),'(i0)') generic type is (integer(kind=int64)); write(line(istart:),'(i0)') generic type is (real(kind=real32)); write(line(istart:),'(1pg0)') generic type is (real(kind=real64)); write(line(istart:),'(1pg0)') generic #ifdef __NVCOMPILER #else type is (real(kind=real128)); write(line(istart:),'(1pg0)') generic #endif type is (logical); write(line(istart:),'(l1)') generic type is (character(len=*)); write(line(istart:),'(a)') trim(generic) type is (complex); write(line(istart:),'("(",1pg0,",",1pg0,")")') generic end select istart=len_trim(line)+increment line=trim(line)//sep_local end subroutine print_generic end function msg_scalar function msg_one(generic0,generic1, generic2, generic3, generic4, generic5, generic6, generic7, generic8, generic9,sep) implicit none ! ident_3="@(#)M_msg::msg_one(3fp): writes a message to a string composed of any standard one dimensional types" class(*),intent(in) :: generic0(:) class(*),intent(in),optional :: generic1(:), generic2(:), generic3(:), generic4(:), generic5(:) class(*),intent(in),optional :: generic6(:), generic7(:), generic8(:), generic9(:) character(len=*),intent(in),optional :: sep character(len=:),allocatable :: sep_local character(len=:),allocatable :: msg_one character(len=4096) :: line integer :: istart integer :: increment if(present(sep))then increment=len(sep)+1 sep_local=sep else sep_local=' ' increment=2 endif istart=1 line=' ' call print_generic(generic0) if(present(generic1))call print_generic(generic1) if(present(generic2))call print_generic(generic2) if(present(generic3))call print_generic(generic3) if(present(generic4))call print_generic(generic4) if(present(generic5))call print_generic(generic5) if(present(generic6))call print_generic(generic6) if(present(generic7))call print_generic(generic7) if(present(generic8))call print_generic(generic8) if(present(generic9))call print_generic(generic9) msg_one=trim(line) contains subroutine print_generic(generic) !use, intrinsic :: iso_fortran_env, only : int8, int16, int32, biggest=>int64, real32, real64, dp=>real128 use,intrinsic :: iso_fortran_env, only : int8, int16, int32, int64, real32, real64, real128 class(*),intent(in),optional :: generic(:) integer :: i select type(generic) type is (integer(kind=int8)); write(line(istart:),'("[",*(i0,1x))') generic type is (integer(kind=int16)); write(line(istart:),'("[",*(i0,1x))') generic type is (integer(kind=int32)); write(line(istart:),'("[",*(i0,1x))') generic type is (integer(kind=int64)); write(line(istart:),'("[",*(i0,1x))') generic type is (real(kind=real32)); write(line(istart:),'("[",*(1pg0,1x))') generic type is (real(kind=real64)); write(line(istart:),'("[",*(1pg0,1x))') generic #ifdef __NVCOMPILER #else type is (real(kind=real128)); write(line(istart:),'("[",*(1pg0,1x))') generic #endif !type is (real(kind=real256)); write(error_unit,'(1pg0)',advance='no') generic type is (logical); write(line(istart:),'("[",*(l1,1x))') generic type is (character(len=*)); write(line(istart:),'("[",:*("""",a,"""",1x))') (trim(generic(i)),i=1,size(generic)) type is (complex); write(line(istart:),'("[",*("(",1pg0,",",1pg0,")",1x))') generic class default stop 'unknown type in *print_generic*' end select istart=len_trim(line)+increment line=trim(line)//"]"//sep_local end subroutine print_generic end function msg_one !=================================================================================================================================== function crop(strin) result (strout) ! ident_19="@(#) M_strings crop(3f) trim leading and trailings spaces from resulting string" character(len=*),intent(in) :: strin character(len=:),allocatable :: strout strout=trim(adjustl(strin)) end function crop !=================================================================================================================================== end module m_io !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !>>>>> build/dependencies/M_strings/src/M_strings.F90 !> !!##NAME !! M_strings(3f) - [M_strings::INTRO] Fortran string module !! !!##DESCRIPTION !! The M_strings(3fm) module is a collection of Fortran procedures !! that supplement the built-in intrinsic string routines. Routines !! for parsing, tokenizing, changing case, substituting new strings for !! substrings, locating strings with simple wildcard expressions, removing !! tabs and line terminators and other string manipulations are included. !! !! M_strings_oop(3fm) is a companion module that provides an OOP interface !! to the M_strings module. !! !!##SYNOPSIS !! !! public entities: !! !! use M_strings,only : split, sep, delim, chomp, strtok !! use M_strings,only : split2020, find_field !! use M_strings,only : substitute, change, modif, transliterate, & !! & reverse, squeeze !! use M_strings,only : replace, join !! use M_strings,only : upper, lower, upper_quoted !! use M_strings,only : rotate13 !! use M_strings,only : adjustc, compact, nospace, indent !! use M_strings,only : crop, clip, unquote, quote, matching_delimiter !! use M_strings,only : len_white, pad, lpad, cpad, rpad, zpad, & !! & stretch, lenset, merge_str !! use M_strings,only : switch, s2c, c2s !! use M_strings,only : noesc, notabs, dilate, expand, visible !! use M_strings,only : longest_common_substring !! use M_strings,only : string_to_value, string_to_values, s2v, s2vs !! use M_strings,only : int, real, dble, nint !! use M_strings,only : atoi, atol, aton !! use M_strings,only : value_to_string, v2s, msg !! use M_strings,only : listout, getvals !! use M_strings,only : glob, ends_with !! use M_strings,only : paragraph !! use M_strings,only : base, decodebase, codebase, base2 !! use M_strings,only : isalnum, isalpha, iscntrl, isdigit !! use M_strings,only : isgraph, islower, isprint, ispunct !! use M_strings,only : isspace, isupper, isascii, isblank, isxdigit !! use M_strings,only : isnumber !! use M_strings,only : fortran_name !! use M_strings,only : describe !! use M_strings,only : edit_distance !! use M_strings,only : bundle !! !! TOKENS !! !! split subroutine parses string using specified delimiter characters !! and stores tokens into an array !! sep function interface to split(3f) !! delim subroutine parses string using specified delimiter characters !! and store tokens into an array !! chomp function consumes input line as it returns next token in a !! string using specified delimiters !! paragraph convert a string into a paragraph !! strtok tokenize a string like C strtok(3c) routine !! !! CONTRIBUTIONS !! !! split2020 split a string using prototype of proposed standard !! procedure !! find_field token a string !! !! EDITING !! !! substitute subroutine non-recursively globally replaces old !! substring with new substring !! replace function non-recursively globally replaces old !! substring with new substring using allocatable string !! (version of substitute(3f) without limitation on !! length of output string) !! change subroutine non-recursively globally replaces old !! substring with new substring with a directive like !! line editor !! modif subroutine modifies a string with a directive like the !! XEDIT line editor MODIFY command !! transliterate replace characters found in set one with characters !! from set two !! reverse reverse character order in a string !! join join an array of CHARACTER variables with specified !! separator !! rotate13 apply trivial encryption algorithm ROT13 to a string !! squeeze delete adjacent duplicate characters from a string !! !! CASE !! !! upper function converts string to uppercase !! lower function converts string to miniscule !! upper_quoted function converts string to uppercase skipping strings !! quoted per Fortran rules !! !! STRING LENGTH AND PADDING !! !! len_white find location of last non-whitespace character !! lenset return a string of specified length !! pad return a string of at least specified length !! zpad pad integer or string to length with zero characters !! on left !! lpad convert scalar intrinsic to a string padded on left to !! specified length !! cpad convert scalar intrinsic to a centered string of the !! specified length !! rpad convert scalar intrinsic to a string padded on right to !! specified length !! stretch return a string of at least specified length with suffix !! merge_str make strings of equal length and then call MERGE(3f) !! intrinsic !! WHITE SPACE !! !! adjustc elemental function centers text within the length of the !! input string !! compact left justify string and replace duplicate whitespace with !! single characters or nothing !! nospace function replaces whitespace with nothing !! indent find number of leading spaces !! crop function trims leading and trailing spaces and control !! characters !! clip function trims leading and trailing spaces !! !! See Also: squeeze !! !! QUOTES !! !! matching_delimiter find position of matching delimiter !! unquote remove quotes from string as if read with list-directed input !! quote add quotes to string as if written with list-directed input !! !! !! CHARACTER ARRAY VERSUS STRING !! !! switch switch between a string and an array of single characters !! s2c convert string to array of single characters and add null !! terminator for passing to C !! c2s convert null-terminated array of single characters to !! string for converting strings returned from C !! !! NONALPHA !! !! noesc convert non-printable ASCII8 characters to a space !! notabs convert tabs to spaces while maintaining columns, !! assuming tabs are set every 8 characters !! dilate function to convert tabs to spaces assuming tabs are set !! every 8 characters !! expand expand escape sequences in a string !! visible expand escape sequences in a string to "control" and !! meta-control representations !! !! NUMERIC STRINGS !! !! string_to_value generic subroutine returns numeric value (REAL, !! DOUBLEPRECISION, INTEGER) from string !! string_to_values subroutine reads an array of numbers from a string !! getvals subroutine reads a relatively arbitrary number !! of values from a string using list-directed read !! s2v function returns DOUBLEPRECISION numeric value !! from string !! s2vs function returns a DOUBLEPRECISION array of numbers !! from a string !! s2vs function returns a DOUBLEPRECISION array of numbers !! from a string !! atoi function returns INTEGER(kind=int32) from a string !! atol function returns INTEGER(kind=int64) from a string !! aton changes string to numeric value !! msg append the values of up to nine values into a string !! !! value_to_string generic subroutine returns string given numeric value !! (REAL, DOUBLEPRECISION, INTEGER, LOGICAL ) !! v2s generic function returns string from numeric value !! (REAL, DOUBLEPRECISION, INTEGER ) !! listout expand a list of numbers where negative numbers !! denote range ends (1 -10 means 1 thru 10) !! isnumber determine if string represents a number !! !! CHARACTER TESTS !! !! glob compares given string for match to pattern which may !! contain wildcard characters !! ends_with test whether strings ends with one of the specified suffixes !! !! o isalnum returns .true. if character is a letter or digit !! o isalpha returns .true. if character is a letter and !! .false. otherwise !! o iscntrl returns .true. if character is a delete character or !! ordinary control character !! o isdigit returns .true. if character is a digit (0,1,...,9) !! and .false. otherwise !! o isgraph returns .true. if character is a printable character !! except a space is considered non-printable !! o islower returns .true. if character is a miniscule letter (a-z) !! o isprint returns .true. if character is an ASCII printable !! character !! o ispunct returns .true. if character is a printable punctuation !! character !! o isspace returns .true. if character is a null, space, tab, !! carriage return, new line, vertical tab, or formfeed !! o isupper returns .true. if character is an uppercase letter (A-Z) !! o isascii returns .true. if the character is in the range char(0) !! to char(127) !! o isblank returns .true. if character is a blank character !! (space or horizontal tab. !! o isxdigit returns .true. if character is a hexadecimal digit !! (0-9, a-f, or A-F). !! !! fortran_name returns .true. if input string is a valid Fortran name !! !! BASE CONVERSION !! !! base convert whole number string in base [2-36] to string !! in alternate base [2-36] !! base2 convert INTEGER to a string representing a binary value !! codebase convert whole number string in base [2-36] to base !! 10 number !! decodebase convert whole number in base 10 to string in base [2-36] !! !! MISCELLANEOUS !! !! bundle return up to twenty strings of arbitrary length as an array !! describe returns a string describing the name of a single character !! edit_distance returns a naive edit distance using the Levenshtein !! distance algorithm !! longest_common_substring function that returns the longest common !! substring of two strings. !! !! INTRINSICS !! !! The M_strings(3fm) module supplements and works in combination with !! the Fortran built-in intrinsics. Stand-alone Fortran lets you access !! the characters in a string using ranges much like they are character !! arrays, assignment, comparisons with standard operators, supports !! dynamically allocatable strings and supports concatenation using the // !! operator, as well as a number of intrinsic string routines: !! !! adjustl Left adjust a string !! adjustr Right adjust a string !! index Position of a substring within a string !! repeat Repeated string concatenation !! scan Scan a string for the presence of a set !! of characters !! trim Remove trailing blank characters of a string !! verify Scan a string for the absence of a set of !! characters !! len It returns the length of a character string !! achar converts an integer into a character !! iachar converts a character into an integer !! len_trim finds length of string with trailing spaces !! ignored !! new_line Newline character !! selected_char_kind Choose character kind !! lge Lexical greater than or equal !! lgt Lexical greater than !! lle Lexical less than or equal !! llt Lexical less than !! !! OOPS INTERFACE !! !! The M_strings_oop(3fm) module (included with the M_strings(3fm) !! module) provides an OOP (Object-Oriented Programming) interface to !! the M_strings(3fm) module. !! !!##SEE ALSO !! There are additional routines in other GPF modules for working with !! expressions (M_calculator), time strings (M_time), random strings !! (M_random, M_uuid), lists (M_list), and interfacing with the C regular !! expression library (M_regex). !! !!##EXAMPLES !! !! Each of the procedural functions includes an example program in the !! corresponding man(1) page for the function. The object-oriented !! interface does not have individual man(1) pages, but is instead !! demonstrated using the following example program: !! !! program demo_M_strings !! use M_strings,only : split, sep, delim, chomp, strtok !! use M_strings,only : split2020, find_field !! use M_strings,only : substitute, change, modif, transliterate, & !! & reverse, squeeze !! use M_strings,only : replace, join !! use M_strings,only : upper, lower, upper_quoted !! use M_strings,only : rotate13 !! use M_strings,only : adjustc, compact, nospace, indent !! use M_strings,only : crop, clip, unquote, quote, matching_delimiter !! use M_strings,only : len_white, pad, lpad, cpad, rpad, zpad, & !! & stretch, lenset, merge_str !! use M_strings,only : switch, s2c, c2s !! use M_strings,only : noesc, notabs, dilate, expand, visible !! use M_strings,only : longest_common_substring !! use M_strings,only : string_to_value, string_to_values, s2v, s2vs !! use M_strings,only : int, real, dble, nint !! use M_strings,only : atoi, atol, aton !! use M_strings,only : value_to_string, v2s, msg !! use M_strings,only : listout, getvals !! use M_strings,only : glob, ends_with !! use M_strings,only : paragraph !! use M_strings,only : base, decodebase, codebase, base2 !! use M_strings,only : isalnum, isalpha, iscntrl, isdigit !! use M_strings,only : isgraph, islower, isprint, ispunct !! use M_strings,only : isspace, isupper, isascii, isblank, isxdigit !! use M_strings,only : isnumber !! use M_strings,only : fortran_name !! use M_strings,only : describe !! use M_strings,only : edit_distance !! use M_strings,only : bundle !! end program demo_M_strings !! !! Expected output !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== MODULE M_strings ! use, intrinsic :: iso_fortran_env, only : ERROR_UNIT ! access computing environment use, intrinsic :: iso_fortran_env, only : output_unit, stderr=>error_unit use,intrinsic :: iso_fortran_env, only : int8, int16, int32, int64, real32, real64, real128 implicit none ! ident_1="@(#) M_strings(3f) Fortran module containing routines that deal with character strings" !----------------------------------------------------------------------------------------------------------------------------------- private !----------------------# TOKENS public split ! subroutine parses a string using specified delimiter characters and store tokens into an allocatable array public sep ! function interface to split public chomp ! function consumes input line as it returns next token in a string using specified delimiters public delim ! subroutine parses a string using specified delimiter characters and store tokens into an array public strtok ! gets next token. Used by change(3f) public paragraph ! convert a long string into a paragraph !----------------------# EDITING public substitute ! subroutine non-recursively globally replaces old substring with new substring in string public replace ! function non-recursively globally replaces old substring with new substring in string public change ! replaces old substring with new substring in string with a directive like a line editor public modif ! change string using a directive using rules similar to XEDIT line editor MODIFY command public transliterate ! when characters in set one are found replace them with characters from set two public reverse ! elemental function reverses character order in a string public join ! append an array of character variables with specified separator into a single CHARACTER variable public squeeze ! delete adjacent duplicate characters from a string public rotate13 ! apply trivial encryption algorithm ROT13 to string !----------------------# CHARACTER ARRAY VERSUS STRING public switch ! generic switch between a string and an array of single characters (a2s,s2a) private a2s ! function to copy char array to string private s2a ! function to copy string(1:Clen(string)) to char array public s2c ! convert character variable to array of character(len=1) with null terminator for C compatibility public c2s ! convert null-terminated array of character(len=1) to string for strings returned by C !----------------------# CASE public upper ! elemental function converts string to uppercase public lower ! elemental function converts string to miniscule public upper_quoted ! elemental function converts string to miniscule skipping strings quoted per Fortran syntax rules !----------------------# WHITE SPACE public adjustc ! elemental function centers string within the length of the input string public compact ! left justify string and replace duplicate whitespace with single characters or nothing public nospace ! function replaces whitespace with nothing public indent ! count number of leading spaces public crop ! function trims leading and trailing spaces and control characters public clip ! function trims leading and trailing spaces !----------------------# QUOTES public matching_delimiter ! find position of matching delimiter public unquote ! remove quotes from string as if read with list-directed input public quote ! add quotes to string as if written with list-directed input !----------------------# STRING LENGTH public lenset ! return a string as specified length public pad ! return a string of at least specified length public zpad ! return a string of at least specified length padded on left with zeros interface zpad; module procedure zpad_scalar, zpad_vector; end interface public lpad ! convert value to a string of at least specified length padded on left with zeros interface lpad; module procedure lpad_scalar, lpad_vector; end interface public cpad ! convert value to a centered string of at least specified length interface cpad; module procedure cpad_scalar, cpad_vector; end interface public rpad ! convert value to a string of at least specified length padded on right with zeros interface rpad; module procedure rpad_scalar, rpad_vector; end interface public stretch ! return a string of at least specified length with suffix public merge_str ! make strings of equal length and then call MERGE(3f) intrinsic public len_white ! find location of last non-whitespace character !----------------------# NONALPHA public noesc ! elemental function converts non-printable ASCII8 characters to a space public notabs ! convert tabs to spaces in output while maintaining columns, assuming a tab is set every 8 characters public dilate ! convert tabs to spaces in output while maintaining columns, assuming a tab is set every 8 characters public expand ! expand escape sequences in a string public visible ! expand escape sequences in a string to control and meta-control representations !----------------------# NUMERIC STRINGS public string_to_value ! generic subroutine returns REAL|DOUBLEPRECISION|INTEGER value from string (a2d,a2r,a2i) private a2d ! subroutine returns double value from string private a2r ! subroutine returns real value from string private a2i ! subroutine returns integer value from string public string_to_values! subroutine returns values from a string public getvals ! subroutine returns values from a string public s2v ! function returns doubleprecision value from string public s2vs ! function returns a doubleprecision array of numbers from a string ! NOT USING INTERNAL READ FOR CONVERSION public atoi ! function returns an INTEGER(kind=int32) value from a string public atol ! function returns an INTEGER(kind=int64) value from a string public aton ! function returns true or false as to whether string converts to numeric value, and numeric value !------------------------------------------------------------------------------------------------------------ public msg ! function returns a string representing up to nine scalar intrinsic values public value_to_string ! generic subroutine returns string given numeric REAL|DOUBLEPRECISION|INTEGER|LOGICAL value public v2s ! generic function returns string given numeric REAL|DOUBLEPRECISION|INTEGER|LOGICAL value private d2s ! function returns string from doubleprecision value private r2s ! function returns string from real value private i2s ! function returns string from integer value private l2s ! function returns string from logical value public isnumber ! determine if string represents a number private trimzeros_ ! Delete trailing zeros from numeric decimal string public listout ! expand a list of numbers where negative numbers denote range ends (1 -10 means 1 thru 10) !----------------------------------------------------------------------------------------------------------------------------------- ! ! extend intrinsics to accept CHARACTER values ! public int, real, dble, nint interface int; module procedure atoi; end interface interface real; module procedure real_s2v; end interface interface dble; module procedure dble_s2v; end interface interface nint; module procedure nint_s2v; end interface interface aton module procedure ator_real32 module procedure ator_real64 module procedure atoi_int8 module procedure atoi_int16 module procedure atoi_int32 module procedure atoi_int64 end interface !----------------------------------------------------------------------------------------------------------------------------------- !----------------------# BIT ROUTINES public setbits8 ! use a string representing a positive binary value to fill the bits of an INTEGER value public setbits16 ! use a string representing a positive binary value to fill the bits of an INTEGER value public setbits32 ! use a string representing a positive binary value to fill the bits of an INTEGER value public setbits64 ! use a string representing a positive binary value to fill the bits of an INTEGER value !----------------------# BASE CONVERSION public base ! convert whole number string in base [2-36] to string in alternate base [2-36] public codebase ! convert whole number string in base [2-36] to base 10 number public decodebase ! convert whole number in base 10 to string in base [2-36] public base2 ! convert INTEGER to a string representing a binary value !----------------------# LOGICAL TESTS public glob ! compares given string for match to pattern which may contain wildcard characters public ends_with ! test whether strings ends with one of the specified suffix public isalnum ! elemental function returns .true. if CHR is a letter or digit public isalpha ! elemental function returns .true. if CHR is a letter and .false. otherwise public isascii ! elemental function returns .true. if the low order byte of c is in the range char(0) to char(127) public isblank ! elemental function returns .true. if CHR is a blank character (space or horizontal tab. public iscntrl ! elemental function returns .true. if CHR is a delete character or ordinary control character public isdigit ! elemental function returns .true. if CHR is a digit (0,1,...,9) and .false. otherwise public isgraph ! elemental function true if CHR is an ASCII printable character except considers a space non-printable public islower ! elemental function returns .true. if CHR is a miniscule letter (a-z) public isprint ! elemental function determines if CHR is an ASCII printable character public ispunct ! elemental function returns .true. if CHR is a printable punctuation character public isspace ! elemental function true if CHR is a null, space, tab, carriage return, new line, vertical tab, or formfeed public isupper ! elemental function returns .true. if CHR is an uppercase letter (A-Z) public isxdigit ! elemental function returns .true. if CHR is a hexadecimal digit (0-9, a-f, or A-F). !----------------------# !-------------------------------# public fortran_name ! elemental function returns .true. if LINE is a valid Fortran name public describe ! returns a string describing character public edit_distance ! returns a naive edit distance using the Levenshtein distance algorithm public bundle ! return up to twenty strings of arbitrary length as an array public longest_common_substring ! function that returns the longest common substring of two strings. !-------------------------------# !----------------------------------------------------------------------------------------------------------------------------------- ! ident_2="@(#) M_strings switch(3f) toggle between string and array of characters; generic{a2s s2a}" interface switch module procedure a2s, s2a end interface switch ! note how returned result is "created" by the function !----------------------------------------------------------------------------------------------------------------------------------- ! ident_3="@(#) M_strings string_to_value(3f) Generic subroutine converts numeric string to a number (a2d a2r a2i)" interface string_to_value module procedure a2d, a2r, a2i end interface !----------------------------------------------------------------------------------------------------------------------------------- ! ident_4="@(#) M_strings v2s(3f) Generic function returns string given REAL|INTEGER|DOUBLEPRECISION value(d2s r2s i2s)" interface v2s module procedure d2s, r2s, i2s, l2s end interface !----------------------------------------------------------------------------------------------------------------------------------- !-!interface setbits ! boz !-! module procedure setbits8, setbits16, setbits32, setbits64 !-!end interface !----------------------------------------------------------------------------------------------------------------------------------- ! ident_5="@(#) M_strings msg(3f) convert up to nine scalar values to a string. Alternatively can also handle one-dimensional arrays" interface msg module procedure msg_scalar, msg_one end interface msg !----------------------------------------------------------------------------------------------------------------------------------- ! ASCII character constants character, public, parameter :: ascii_nul = char(0) ! null character, public, parameter :: ascii_bel = char(7) ! bell character, public, parameter :: ascii_bs = char(8) ! backspace character, public, parameter :: ascii_ht = char(9) ! horizontal tab character, public, parameter :: ascii_lf = char(10) ! line feed or newline character, public, parameter :: ascii_ff = char(12) ! form feed or newpage character, public, parameter :: ascii_cr = char(13) ! carriage return character, public, parameter :: ascii_esc = char(27) ! escape !----------------------------------------------------------------------------------------------------------------------------------- interface ends_with procedure :: ends_with_str procedure :: ends_with_any end interface ends_with !----------------------------------------------------------------------------------------------------------------------------------- public :: split2020, string_tokens public :: find_field interface split2020 module procedure :: split_tokens, split_first_last, split_pos end interface split2020 !----------------------------------------------------------------------------------------------------------------------------------- !----------------------------------------------------------------------------------------------------------------------------------- !This contains a conditionally built mini-version of M_journal which allows the M_strings.f90 module !to be built using make as a stand-alone distribution but still have make.shell built a true version ! !This is so when built with make.shell(1) or fpm(1) it will use the !real M_journal.f90 file but that fpm(1) will not auto-discover the mini !M_journal.f90 file and built it and cause duplicates. interface journal module procedure flush_trail ! journal() ! no options module procedure write_message_only ! journal(c) ! must have one string module procedure where_write_message_all ! journal(where,[g1-g9]) ! must have two strings end interface journal interface str module procedure str_scalar, str_one end interface str !$@(#) M_journal::journal(3fg): provides public message routine, no paging or graphic mode change ! global variables integer,save,private :: stdout=OUTPUT_UNIT logical,save :: debug=.false. integer,save :: last_int=0 !----------------------------------------------------------------------------------------------------------------------------------- !----------------------------------------------------------------------------------------------------------------------------------- ! for compatibility allow old name for renamed procedures interface matchw; module procedure glob; end interface interface atleast; module procedure pad; end interface interface cc; module procedure bundle; end interface public matchw ! clone of glob -- for backward compatibiity public atleast ! clone of pad -- for backward compatibiity public cc ! clone of pad -- for backward compatibiity !----------------------------------------------------------------------------------------------------------------------------------- CONTAINS !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! glob(3f) - [M_strings:COMPARE] compare given string for match to !! a pattern which may contain globbing wildcard characters !! (LICENSE:PD) !! !!##SYNOPSIS !! !! logical function glob(string, pattern ) !! !! character(len=*),intent(in) :: string !! character(len=*),intent(in) :: pattern !! !!##DESCRIPTION !! glob(3f) compares given (entire) STRING for a match to PATTERN which may !! contain basic wildcard "globbing" characters. !! !! In this version to get a match the entire string must be described !! by PATTERN. Trailing whitespace is significant, so trim the input !! string to have trailing whitespace ignored. !! !! Patterns like "b*ba" fail on a string like "babababa" because the !! algorithm finds an early match. To skip over the early matches insert !! an extra character at the end of the string and pattern that does !! not occur in the pattern. Typically a NULL is used (char(0)). !! !!##OPTIONS !! string the input string to test to see if it contains the pattern. !! pattern the following simple globbing options are available !! !! o "?" matching any one character !! o "*" matching zero or more characters. !! Do NOT use adjacent asterisks. !! o spaces are significant and must be matched or pretrimmed !! o There is no escape character, so matching strings with !! literal question mark and asterisk is problematic. !! !!##EXAMPLES !! !! Example program !! !! program demo_glob !! implicit none !! ! This main() routine passes a bunch of test strings !! ! into the above code. In performance comparison mode, !! ! it does that over and over. Otherwise, it does it just !! ! once. Either way, it outputs a passed/failed result. !! ! !! integer :: nReps !! logical :: allpassed !! integer :: i !! allpassed = .true. !! !! nReps = 10000 !! ! Can choose as many repetitions as you're expecting !! ! in the real world. !! nReps = 1 !! !! do i=1,nReps !! ! Cases with repeating character sequences. !! allpassed= test("a*abab", "a*b", .true.) .and. allpassed !! allpassed= test("ab", "*?", .true.) .and. allpassed !! allpassed= test("abc", "*?", .true.) .and. allpassed !! allpassed= test("abcccd", "*ccd", .true.) .and. allpassed !! allpassed= test("bLah", "bLaH", .false.) .and. allpassed !! allpassed= test("mississippi", "*sip*", .true.) .and. allpassed !! allpassed= & !! & test("xxxx*zzzzzzzzy*f", "xxx*zzy*f", .true.) .and. allpassed !! allpassed= & !! & test("xxxx*zzzzzzzzy*f", "xxxx*zzy*fffff", .false.) .and. allpassed !! allpassed= & !! & test("mississipissippi", "*issip*ss*", .true.) .and. allpassed !! allpassed= & !! & test("xxxxzzzzzzzzyf", "xxxx*zzy*fffff", .false.) .and. allpassed !! allpassed= & !! & test("xxxxzzzzzzzzyf", "xxxx*zzy*f", .true.) .and. allpassed !! allpassed= test("xyxyxyzyxyz", "xy*z*xyz", .true.) .and. allpassed !! allpassed= test("xyxyxyxyz", "xy*xyz", .true.) .and. allpassed !! allpassed= test("mississippi", "mi*sip*", .true.) .and. allpassed !! allpassed= test("ababac", "*abac*", .true.) .and. allpassed !! allpassed= test("aaazz", "a*zz*", .true.) .and. allpassed !! allpassed= test("a12b12", "*12*23", .false.) .and. allpassed !! allpassed= test("a12b12", "a12b", .false.) .and. allpassed !! allpassed= test("a12b12", "*12*12*", .true.) .and. allpassed !! !! ! Additional cases where the '*' char appears in the tame string. !! allpassed= test("*", "*", .true.) .and. allpassed !! allpassed= test("a*r", "a*", .true.) .and. allpassed !! allpassed= test("a*ar", "a*aar", .false.) .and. allpassed !! !! ! More double wildcard scenarios. !! allpassed= test("XYXYXYZYXYz", "XY*Z*XYz", .true.) .and. allpassed !! allpassed= test("missisSIPpi", "*SIP*", .true.) .and. allpassed !! allpassed= test("mississipPI", "*issip*PI", .true.) .and. allpassed !! allpassed= test("xyxyxyxyz", "xy*xyz", .true.) .and. allpassed !! allpassed= test("miSsissippi", "mi*sip*", .true.) .and. allpassed !! allpassed= test("miSsissippi", "mi*Sip*", .false.) .and. allpassed !! allpassed= test("abAbac", "*Abac*", .true.) .and. allpassed !! allpassed= test("aAazz", "a*zz*", .true.) .and. allpassed !! allpassed= test("A12b12", "*12*23", .false.) .and. allpassed !! allpassed= test("a12B12", "*12*12*", .true.) .and. allpassed !! allpassed= test("oWn", "*oWn*", .true.) .and. allpassed !! !! ! Completely tame (no wildcards) cases. !! allpassed= test("bLah", "bLah", .true.) .and. allpassed !! !! ! Simple mixed wildcard tests suggested by IBMer Marlin Deckert. !! allpassed= test("a", "*?", .true.) .and. allpassed !! !! ! More mixed wildcard tests including coverage for false positives. !! allpassed= test("a", "??", .false.) .and. allpassed !! allpassed= test("ab", "?*?", .true.) .and. allpassed !! allpassed= test("ab", "*?*?*", .true.) .and. allpassed !! allpassed= test("abc", "?**?*?", .true.) .and. allpassed !! allpassed= test("abc", "?**?*&?", .false.) .and. allpassed !! allpassed= test("abcd", "?b*??", .true.) .and. allpassed !! allpassed= test("abcd", "?a*??", .false.) .and. allpassed !! allpassed= test("abcd", "?**?c?", .true.) .and. allpassed !! allpassed= test("abcd", "?**?d?", .false.) .and. allpassed !! allpassed= test("abcde", "?*b*?*d*?", .true.) .and. allpassed !! !! ! Single-character-match cases. !! allpassed= test("bLah", "bL?h", .true.) .and. allpassed !! allpassed= test("bLaaa", "bLa?", .false.) .and. allpassed !! allpassed= test("bLah", "bLa?", .true.) .and. allpassed !! allpassed= test("bLaH", "?Lah", .false.) .and. allpassed !! allpassed= test("bLaH", "?LaH", .true.) .and. allpassed !! !! allpassed= test('abcdefghijk' , '?b*', .true.) .and. allpassed !! allpassed= test('abcdefghijk' , '*c*', .true.) .and. allpassed !! allpassed= test('abcdefghijk' , '*c', .false.) .and. allpassed !! allpassed= test('abcdefghijk' , '*c*k', .true.) .and. allpassed !! allpassed= test('LS' , '?OW', .false.) .and. allpassed !! allpassed= test('teztit' , 'tez*t*t', .true.) .and. allpassed !! ! Two pattern match problems that might pose difficulties !! allpassed= test('e ' , '*e* ', .true.) .and. allpassed !! allpassed= test('abcde ' , '*e *', .true.) .and. allpassed !! allpassed= test('bababa' , 'b*ba', .true.) .and. allpassed !! allpassed= test('baaaaax' , 'b*ax', .true.) .and. allpassed !! allpassed= test('baaaaa' , 'b*ax', .false.) .and. allpassed !! allpassed= test('baaaaax' , 'b*a', .false.) .and. allpassed !! allpassed= test('' , 'b*', .false.) .and. allpassed !! allpassed= test('' , '*', .true.) .and. allpassed !! allpassed= test('b' , '', .false.) .and. allpassed !! allpassed= test('3' , '??', .false.) .and. allpassed !! ! known flaws !! allpassed= test('' , '', .true.) .and. allpassed !! allpassed= test('baaaaa' , 'b*a', .true.) .and. allpassed !! ! add unused character to work around !! allpassed= test(''//char(0), ''//char(0), .true.).and.allpassed !! allpassed= test('baaaaa'//char(0),'b*a'//char(0),.true.).and.allpassed !! !! ! Many-wildcard scenarios. !! allpassed= test(& !! &"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa& !! &aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaab",& !! &"a*a*a*a*a*a*aa*aaa*a*a*b",& !! &.true.) .and. allpassed !! allpassed= test(& !! &"abababababababababababababababababababaacacacacacacac& !! &adaeafagahaiajakalaaaaaaaaaaaaaaaaaffafagaagggagaaaaaaaab",& !! &"*a*b*ba*ca*a*aa*aaa*fa*ga*b*",& !! &.true.) .and. allpassed !! allpassed= test(& !! &"abababababababababababababababababababaacacacacacaca& !! &cadaeafagahaiajakalaaaaaaaaaaaaaaaaaffafagaagggagaaaaaaaab",& !! &"*a*b*ba*ca*a*x*aaa*fa*ga*b*",& !! &.false.) .and. allpassed !! allpassed= test(& !! &"abababababababababababababababababababaacacacacacacacad& !! &aeafagahaiajakalaaaaaaaaaaaaaaaaaffafagaagggagaaaaaaaab",& !! &"*a*b*ba*ca*aaaa*fa*ga*gggg*b*",& !! &.false.) .and. allpassed !! allpassed= test(& !! &"abababababababababababababababababababaacacacacacacacad& !! &aeafagahaiajakalaaaaaaaaaaaaaaaaaffafagaagggagaaaaaaaab",& !! &"*a*b*ba*ca*aaaa*fa*ga*ggg*b*",& !! &.true.) .and. allpassed !! allpassed= test("aaabbaabbaab","*aabbaa*a*",.true.).and.allpassed !! allpassed= & !! test("a*a*a*a*a*a*a*a*a*a*a*a*a*a*a*a*a*",& !! &"a*a*a*a*a*a*a*a*a*a*a*a*a*a*a*a*a*", .true.) .and. allpassed !! allpassed= test("aaaaaaaaaaaaaaaaa",& !! &"*a*a*a*a*a*a*a*a*a*a*a*a*a*a*a*a*a*", .true.) .and. allpassed !! allpassed= test("aaaaaaaaaaaaaaaa",& !! &"*a*a*a*a*a*a*a*a*a*a*a*a*a*a*a*a*a*", .false.) .and. allpassed !! allpassed= test(& !! &"abc*abcd*abcde*abcdef*abcdefg*abcdefgh*abcdefghi*abcdefghij& !! &*abcdefghijk*abcdefghijkl*abcdefghijklm*abcdefghijklmn",& !! & "abc*abc*abc*abc*abc*abc*abc*abc*abc*abc*abc*abc*abc*abc& !! &*abc*abc*abc*",& !! &.false.) .and. allpassed !! allpassed= test(& !! &"abc*abcd*abcde*abcdef*abcdefg*abcdefgh*abcdefghi*abcdefghij& !! &*abcdefghijk*abcdefghijkl*abcdefghijklm*abcdefghijklmn",& !! &"abc*abc*abc*abc*abc*abc*abc*abc*abc*abc*abc*abc*",& !! &.true.) .and. allpassed !! allpassed= test("abc*abcd*abcd*abc*abcd",& !! &"abc*abc*abc*abc*abc", .false.) .and. allpassed !! allpassed= test( "abc*abcd*abcd*abc*abcd*abcd& !! &*abc*abcd*abc*abc*abcd", & !! &"abc*abc*abc*abc*abc*abc*abc*abc*abc*abc*abcd",& !! &.true.) .and. allpassed !! allpassed= test("abc",& !! &"********a********b********c********", .true.) .and. allpassed !! allpassed=& !! &test("********a********b********c********", "abc",.false.)& !! & .and.allpassed !! allpassed= & !! &test("abc", "********a********b********b********",.false.)& !! & .and.allpassed !! allpassed= test("*abc*", "***a*b*c***", .true.) .and. allpassed !! !! ! A case-insensitive algorithm test. !! ! allpassed=test("mississippi", "*issip*PI", .true.) .and. allpassed !! enddo !! !! if (allpassed)then !! write(*,'(*(g0,1x))')"Passed",nReps !! else !! write(*,'(a)')"Failed" !! endif !! contains !! ! This is a test program for wildcard matching routines. !! ! It can be used either to test a single routine for correctness, !! ! or to compare the timings of two (or more) different wildcard !! ! matching routines. !! ! !! function test(tame, wild, bExpectedResult) result(bPassed) !! use M_strings, only : glob !! character(len=*) :: tame !! character(len=*) :: wild !! logical :: bExpectedResult !! logical :: bResult !! logical :: bPassed !! bResult = .true. ! We'll do "&=" cumulative checking. !! bPassed = .false. ! Assume the worst. !! write(*,*)repeat('=',79) !! bResult = glob(tame, wild) ! Call a wildcard matching routine. !! !! ! To assist correctness checking, output the two strings in any !! ! failing scenarios. !! if (bExpectedResult .eqv. bResult) then !! bPassed = .true. !! if(nReps == 1) write(*,*)"Passed match on ",tame," vs. ", wild !! else !! if(nReps == 1) write(*,*)"Failed match on ",tame," vs. ", wild !! endif !! !! end function test !! end program demo_glob !! !! Expected output !! !!##AUTHOR !! John S. Urban !! !!##REFERENCE !! The article "Matching Wildcards: An Empirical Way to Tame an Algorithm" !! in Dr Dobb's Journal, By Kirk J. Krauss, October 07, 2014 !! !!##LICENSE !! Public Domain function glob(tame,wild) ! ident_6="@(#) M_strings glob(3f) function compares text strings one of which can have wildcards ('*' or '?')." logical :: glob character(len=*) :: tame ! A string without wildcards character(len=*) :: wild ! A (potentially) corresponding string with wildcards character(len=len(tame)+1) :: tametext character(len=len(wild)+1) :: wildtext character(len=1),parameter :: NULL=char(0) integer :: wlen integer :: ti, wi integer :: i character(len=:),allocatable :: tbookmark, wbookmark ! These two values are set when we observe a wildcard character. They ! represent the locations, in the two strings, from which we start once we have observed it. tametext=tame//NULL wildtext=wild//NULL tbookmark = NULL wbookmark = NULL wlen=len(wild) wi=1 ti=1 do ! Walk the text strings one character at a time. if(wildtext(wi:wi) == '*')then ! How do you match a unique text string? do i=wi,wlen ! Easy: unique up on it! if(wildtext(wi:wi) == '*')then wi=wi+1 else exit endif enddo if(wildtext(wi:wi) == NULL) then ! "x" matches "*" glob=.true. return endif if(wildtext(wi:wi) /= '?') then ! Fast-forward to next possible match. do while (tametext(ti:ti) /= wildtext(wi:wi)) ti=ti+1 if (tametext(ti:ti) == NULL)then glob=.false. return ! "x" doesn't match "*y*" endif enddo endif wbookmark = wildtext(wi:) tbookmark = tametext(ti:) elseif(tametext(ti:ti) /= wildtext(wi:wi) .and. wildtext(wi:wi) /= '?') then ! Got a non-match. If we've set our bookmarks, back up to one or both of them and retry. if(wbookmark /= NULL) then if(wildtext(wi:) /= wbookmark) then wildtext = wbookmark wlen=len_trim(wbookmark) wi=1 ! Don't go this far back again. if (tametext(ti:ti) /= wildtext(wi:wi)) then tbookmark=tbookmark(2:) tametext = tbookmark ti=1 cycle ! "xy" matches "*y" else wi=wi+1 endif endif if (tametext(ti:ti) /= NULL) then ti=ti+1 cycle ! "mississippi" matches "*sip*" endif endif glob=.false. return ! "xy" doesn't match "x" endif ti=ti+1 wi=wi+1 if (ti > len(tametext)) then glob=.false. return elseif (tametext(ti:ti) == NULL) then ! How do you match a tame text string? if(wildtext(wi:wi) /= NULL)then do while (wildtext(wi:wi) == '*') ! The tame way: unique up on it! wi=wi+1 ! "x" matches "x*" if(wildtext(wi:wi) == NULL)exit enddo endif if (wildtext(wi:wi) == NULL)then glob=.true. return ! "x" matches "x" endif glob=.false. return ! "x" doesn't match "xy" endif enddo end function glob !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! ends_with(3f) - [M_strings:COMPARE] test if string ends with specified !! suffix(es) !! (LICENSE:PD) !! !!##SYNOPSIS !! !! function ends_with(source_string,suffix) !! !! or !! !! function ends_with(source_string,[suffix]) !! !! character(len=*),intent(in) :: source_string !! character(len=*),intent(in) :: suffix(..) !! logical :: ends_with !! !!##DESCRIPTION !! !!##OPTIONS !! SOURCE_STRING string to tokenize !! SUFFIX list of separator strings. May be scalar or an array. !! Trailing spaces are ignored. !! !!##RETURNS !! ENDS_WITH returns .TRUE. if one of the suffix match the end !! of SOURCE_STRING. !! !!##EXAMPLES !! !! Sample program: !! !! program demo_ends_with !! use M_strings, only : ends_with !! use, intrinsic :: iso_fortran_env, only : stdout=>output_unit !! implicit none !! write(stdout,*)ends_with('prog.a',['.o','.i','.s']) !! write(stdout,*)ends_with('prog.f90',['.F90','.f90','.f ','.F ']) !! write(stdout,*)ends_with('prog.pdf','.pdf') !! write(stdout,*)ends_with('prog.doc','.txt') !! end program demo_ends_with !! !! Results: !! !! F !! T !! T !! F !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain pure function ends_with_str(string, ending) result(matched) character(*), intent(in) :: string, ending integer :: n1, n2 logical :: matched n1 = len(string) - len(ending) + 1 n2 = len(string) if (n1 < 1) then matched = .false. else matched = (string(n1:n2) == ending) endif end function ends_with_str !----------------------------------------------------------------------------------------------------------------------------------- pure function ends_with_any(string, endings) result(matched) character(*), intent(in) :: string character(*), intent(in) :: endings(:) logical :: matched integer :: i matched = .true. FINDIT: block do i=1, size(endings) if(ends_with_str(string,trim(endings(i)))) exit FINDIT enddo matched = .false. endblock FINDIT end function ends_with_any !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! sep(3f) - [M_strings:TOKENS] function to parse string into an array using !! specified delimiters !! (LICENSE:PD) !! !!##SYNOPSIS !! !! function sep(input_line,delimiters,nulls) !! !! character(len=*),intent(in) :: input_line !! character(len=*),optional,intent(in) :: delimiters !! character(len=*),optional,intent(in) :: nulls !! character(len=:),allocatable :: sep(:) !! !!##DESCRIPTION !! sep(3f) parses a string using specified delimiter characters and !! store tokens into an allocatable array !! !!##OPTIONS !! INPUT_LINE Input string to tokenize !! !! DELIMITERS List of delimiter characters. !! The default delimiters are the "whitespace" characters !! (space, tab,new line, vertical tab, formfeed, carriage !! return, and null). You may specify an alternate set of !! delimiter characters. !! !! Multi-character delimiters are not supported (Each !! character in the DELIMITERS list is considered to be !! a delimiter). !! !! Quoting of delimiter characters is not supported. !! !! NULLS=IGNORE|RETURN|IGNOREEND Treatment of null fields. !! By default adjacent delimiters in the input string !! do not create an empty string in the output array. if !! NULLS='return' adjacent delimiters create an empty element !! in the output ARRAY. If NULLS='ignoreend' then only !! trailing delimiters at the right of the string are ignored. !! ORDER='ASCENDING'|'DESCENDING' by default the tokens are returned from !! last to first; order='ASCENDING' returns !! them from first to last (left to right). !!##RETURNS !! SEP Output array of tokens !! !!##EXAMPLES !! !! Sample program: !! !! program demo_sep !! use M_strings, only: sep !! character(len=*),parameter :: fo='(/,a,*(/,"[",g0,"]":,","))' !! character(len=*),parameter :: line=& !! ' aBcdef ghijklmnop qrstuvwxyz 1:|:2 333|333 a B cc ' !! write(*,'(a)') 'INPUT LINE:['//LINE//']' !! write(*,fo) 'typical call:',sep(line) !! write(*,fo) 'delimiters ":|":',sep(line,':|') !! write(*,fo) 'count null fields ":|":',sep(line,':|','return') !! end program demo_sep !! !! Output !! !! INPUT LINE:[ aBcdef ghijklmnop qrstuvwxyz 1:|:2 333|333 a B cc ] !! !! typical call: !! [cc ], !! [B ], !! [a ], !! [333|333 ], !! [1:|:2 ], !! [qrstuvwxyz], !! [ghijklmnop], !! [aBcdef ] !! !! delimiters ":|": !! [333 a B cc ], !! [2 333 ], !! [ aBcdef ghijklmnop qrstuvwxyz 1] !! !! count null fields ":|": !! [333 a B cc ], !! [2 333 ], !! [ ], !! [ ], !! [ aBcdef ghijklmnop qrstuvwxyz 1] !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain function sep(input_line,delimiters,nulls,order) !----------------------------------------------------------------------------------------------------------------------------------- ! ident_7="@(#) M_strings sep(3f) parse string on delimiter characters and store tokens into an allocatable array" ! John S. Urban !----------------------------------------------------------------------------------------------------------------------------------- intrinsic index, min, present, len !----------------------------------------------------------------------------------------------------------------------------------- ! given a line of structure " par1 par2 par3 ... parn " store each par(n) into a separate variable in array. ! o by default adjacent delimiters in the input string do not create an empty string in the output array ! o no quoting of delimiters is supported character(len=*),intent(in) :: input_line ! input string to tokenize character(len=*),optional,intent(in) :: delimiters ! list of delimiter characters character(len=*),optional,intent(in) :: nulls ! return strings composed of delimiters or not ignore|return|ignoreend character(len=*),optional,intent(in) :: order ! return strings composed of delimiters or not ignore|return|ignoreend character(len=:),allocatable :: sep(:) ! output array of tokens integer :: isize call split(input_line,sep,delimiters,'right',nulls) if(present(order))then select case(order) case('ascending','ASCENDING') isize=size(sep) if(isize > 1)then sep=sep(isize:1:-1) endif end select endif !----------------------------------------------------------------------------------------------------------------------------------- end function sep !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! split(3f) - [M_strings:TOKENS] parse string into an array using !! specified delimiters !! (LICENSE:PD) !! !!##SYNOPSIS !! !! subroutine split(input_line,array,delimiters,order,nulls) !! !! character(len=*),intent(in) :: input_line !! character(len=:),allocatable,intent(out) :: array(:) !! character(len=*),optional,intent(in) :: delimiters !! character(len=*),optional,intent(in) :: order !! character(len=*),optional,intent(in) :: nulls !! !!##DESCRIPTION !! SPLIT(3f) parses a string using specified delimiter characters and !! store tokens into an allocatable array !! !!##OPTIONS !! INPUT_LINE Input string to tokenize !! !! ARRAY Output array of tokens !! !! DELIMITERS List of delimiter characters. !! The default delimiters are the "whitespace" characters !! (space, tab,new line, vertical tab, formfeed, carriage !! return, and null). You may specify an alternate set of !! delimiter characters. !! !! Multi-character delimiters are not supported (Each !! character in the DELIMITERS list is considered to be !! a delimiter). !! !! Quoting of delimiter characters is not supported. !! !! ORDER SEQUENTIAL|REVERSE|RIGHT Order of output array. !! By default ARRAY contains the tokens having parsed !! the INPUT_LINE from left to right. If ORDER='RIGHT' !! or ORDER='REVERSE' the parsing goes from right to left. !! (This can be accomplished with array syntax in modern !! Fortran, but was more useful pre-fortran90). !! !! NULLS=IGNORE|RETURN|IGNOREEND Treatment of null fields. !! By default adjacent delimiters in the input string !! do not create an empty string in the output array. if !! NULLS='return' adjacent delimiters create an empty element !! in the output ARRAY. If NULLS='ignoreend' then only !! trailing delimiters at the right of the string are ignored. !! !!##EXAMPLES !! !! Sample program: !! !! program demo_split !! use M_strings, only: split !! implicit none !! integer :: i !! character(len=*),parameter :: line=& !! ' aBcdef ghijklmnop qrstuvwxyz 1:|:2 333|333 a B cc ' !! character(len=:),allocatable :: array(:) ! output array of tokens !! write(*,*)'INPUT LINE:['//line//']' !! write(*,'(70("="))') !! write(*,*)'typical call:' !! call split(line,array) !! write(*,'(i0," ==> ",a)')(i,trim(array(i)),i=1,size(array)) !! write(*,*)'SIZE:',size(array) !! write(*,'(70("-"))') !! write(*,*)'custom list of delimiters (colon and vertical line):' !! call split(line,array,delimiters=':|',& !! & order='sequential',nulls='ignore') !! write(*,'(i0," ==> ",a)')(i,trim(array(i)),i=1,size(array)) !! write(*,*)'SIZE:',size(array) !! write(*,'(70("-"))') !! write(*,*) 'custom list of delimiters, & !! &reverse array order and count null fields:' !! call split(line,array,delimiters=':|',& !! &order='reverse',nulls='return') !! write(*,'(i0," ==> ",a)')(i,trim(array(i)),i=1,size(array)) !! write(*,*)'SIZE:',size(array) !! write(*,'(70("-"))') !! write(*,*)'INPUT LINE:['//line//']' !! write(*,*) 'default delimiters and reverse array order & !! &and return null fields:' !! call split(line,array,delimiters='',order='reverse',nulls='return') !! write(*,'(i0," ==> ",a)')(i,trim(array(i)),i=1,size(array)) !! write(*,*)'SIZE:',size(array) !! end program demo_split !! !! Output !! !! >INPUT LINE:[ aBcdef ghijklmnop qrstuvwxyz 1:|:2 333| !! 333 a B cc ] !! >================================================================= !! > typical call: !! >1 ==> aBcdef !! >2 ==> ghijklmnop !! >3 ==> qrstuvwxyz !! >4 ==> 1:|:2 !! >5 ==> 333|333 !! >6 ==> a !! >7 ==> B !! >8 ==> cc !! > SIZE: 8 !! >---------------------------------------------------------------- !! > custom list of delimiters (colon and vertical line): !! >1 ==> aBcdef ghijklmnop qrstuvwxyz 1 !! >2 ==> 2 333 !! >3 ==> 333 a B cc !! > SIZE: 3 !! >---------------------------------------------------------------- !! > custom list of delimiters, reverse array order and !! return null fields: !! >1 ==> 333 a B cc !! >2 ==> 2 333 !! >3 ==> !! >4 ==> !! >5 ==> aBcdef ghijklmnop qrstuvwxyz 1 !! > SIZE: 5 !! >---------------------------------------------------------------- !! > INPUT LINE:[ aBcdef ghijklmnop qrstuvwxyz 1:|:2 333| !! 333 a B cc ] !! > default delimiters and reverse array order and count null fields: !! >1 ==> !! >2 ==> !! >3 ==> !! >4 ==> cc !! >5 ==> B !! >6 ==> a !! >7 ==> 333|333 !! >8 ==> !! >9 ==> !! >10 ==> !! >11 ==> !! >12 ==> 1:|:2 !! >13 ==> !! >14 ==> qrstuvwxyz !! >15 ==> ghijklmnop !! >16 ==> !! >17 ==> !! >18 ==> aBcdef !! >19 ==> !! >20 ==> !! > SIZE: 20 !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain subroutine split(input_line,array,delimiters,order,nulls) !----------------------------------------------------------------------------------------------------------------------------------- ! ident_8="@(#) M_strings split(3f) parse string on delimiter characters and store tokens into an allocatable array" ! John S. Urban !----------------------------------------------------------------------------------------------------------------------------------- intrinsic index, min, present, len !----------------------------------------------------------------------------------------------------------------------------------- ! given a line of structure " par1 par2 par3 ... parn " store each par(n) into a separate variable in array. ! o by default adjacent delimiters in the input string do not create an empty string in the output array ! o no quoting of delimiters is supported character(len=*),intent(in) :: input_line ! input string to tokenize character(len=*),optional,intent(in) :: delimiters ! list of delimiter characters character(len=*),optional,intent(in) :: order ! order of output array sequential|[reverse|right] character(len=*),optional,intent(in) :: nulls ! return strings composed of delimiters or not ignore|return|ignoreend character(len=:),allocatable,intent(out) :: array(:) ! output array of tokens !----------------------------------------------------------------------------------------------------------------------------------- integer :: n ! max number of strings INPUT_LINE could split into if all delimiter integer,allocatable :: ibegin(:) ! positions in input string where tokens start integer,allocatable :: iterm(:) ! positions in input string where tokens end character(len=:),allocatable :: dlim ! string containing delimiter characters character(len=:),allocatable :: ordr ! string containing order keyword character(len=:),allocatable :: nlls ! string containing nulls keyword integer :: ii,iiii ! loop parameters used to control print order integer :: icount ! number of tokens found integer :: lgth ! length of input string with trailing spaces trimmed integer :: i10,i20,i30 ! loop counters integer :: icol ! pointer into input string as it is being parsed integer :: idlim ! number of delimiter characters integer :: ifound ! where next delimiter character is found in remaining input string data integer :: inotnull ! count strings not composed of delimiters integer :: ireturn ! number of tokens returned integer :: imax ! length of longest token !----------------------------------------------------------------------------------------------------------------------------------- ! decide on value for optional DELIMITERS parameter if (present(delimiters)) then ! optional delimiter list was present if(delimiters /= '')then ! if DELIMITERS was specified and not null use it dlim=delimiters else ! DELIMITERS was specified on call as empty string dlim=' '//char(9)//char(10)//char(11)//char(12)//char(13)//char(0) ! use default delimiter when not specified endif else ! no delimiter value was specified dlim=' '//char(9)//char(10)//char(11)//char(12)//char(13)//char(0) ! use default delimiter when not specified endif idlim=len(dlim) ! dlim a lot of blanks on some machines if dlim is a big string !----------------------------------------------------------------------------------------------------------------------------------- if(present(order))then; ordr=lower(adjustl(order)); else; ordr='sequential'; endif ! decide on value for optional ORDER parameter if(present(nulls))then; nlls=lower(adjustl(nulls)); else; nlls='ignore' ; endif ! optional parameter !----------------------------------------------------------------------------------------------------------------------------------- n=len(input_line)+1 ! max number of strings INPUT_LINE could split into if all delimiter if(allocated(ibegin))deallocate(ibegin) !x! intel compiler says allocated already ? if(allocated(iterm))deallocate(iterm) !x! intel compiler says allocated already ? allocate(ibegin(n)) ! allocate enough space to hold starting location of tokens if string all tokens allocate(iterm(n)) ! allocate enough space to hold ending location of tokens if string all tokens ibegin(:)=1 iterm(:)=1 !----------------------------------------------------------------------------------------------------------------------------------- lgth=len(input_line) ! lgth is the column position of the last non-blank character icount=0 ! how many tokens found inotnull=0 ! how many tokens found not composed of delimiters imax=0 ! length of longest token found !----------------------------------------------------------------------------------------------------------------------------------- if(lgth > 0)then ! there is at least one non-delimiter in INPUT_LINE if get here icol=1 ! initialize pointer into input line INFINITE: do i30=1,lgth,1 ! store into each array element ibegin(i30)=icol ! assume start new token on the character if(index(dlim(1:idlim),input_line(icol:icol)) == 0)then ! if current character is not a delimiter iterm(i30)=lgth ! initially assume no more tokens do i10=1,idlim ! search for next delimiter ifound=index(input_line(ibegin(i30):lgth),dlim(i10:i10)) IF(ifound > 0)then iterm(i30)=min(iterm(i30),ifound+ibegin(i30)-2) endif enddo icol=iterm(i30)+2 ! next place to look as found end of this token inotnull=inotnull+1 ! increment count of number of tokens not composed of delimiters else ! character is a delimiter for a null string iterm(i30)=icol-1 ! record assumed end of string. Will be less than beginning icol=icol+1 ! advance pointer into input string endif imax=max(imax,iterm(i30)-ibegin(i30)+1) icount=i30 ! increment count of number of tokens found if(icol > lgth)then ! no text left exit INFINITE endif enddo INFINITE endif !----------------------------------------------------------------------------------------------------------------------------------- select case (trim(adjustl(nlls))) case ('ignore','','ignoreend') ireturn=inotnull case default ireturn=icount end select allocate(character(len=imax) :: array(ireturn)) ! allocate the array to return !allocate(array(ireturn)) ! allocate the array to return !----------------------------------------------------------------------------------------------------------------------------------- select case (trim(adjustl(ordr))) ! decide which order to store tokens case ('reverse','right') ; ii=ireturn ; iiii=-1 ! last to first case default ; ii=1 ; iiii=1 ! first to last end select !----------------------------------------------------------------------------------------------------------------------------------- do i20=1,icount ! fill the array with the tokens that were found if(iterm(i20) < ibegin(i20))then select case (trim(adjustl(nlls))) case ('ignore','','ignoreend') case default array(ii)=' ' ii=ii+iiii end select else array(ii)=input_line(ibegin(i20):iterm(i20)) ii=ii+iiii endif enddo !----------------------------------------------------------------------------------------------------------------------------------- end subroutine split !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! chomp(3f) - [M_strings:TOKENS] Tokenize a string, consuming it one !! token per call !! (LICENSE:PD) !! !!##SYNOPSIS !! !! function chomp(source_string,token[,delimiters]) !! !! character(len=*) :: source_string !! character(len=:),intent(out) :: token !! character(len=:),intent(in),optional :: delimiters !! integer :: chomp !! !!##DESCRIPTION !! The CHOMP(3f) function is used to isolate sequential tokens in a !! string, SOURCE_STRING. These tokens are delimited in the string by at !! least one of the characters in DELIMITERS. This routine consumes the !! source_string one token per call. It returns -1 when complete. The !! default delimiter list is "space,tab,carriage return,newline". !! !!##OPTIONS !! SOURCE_STRING string to tokenize !! DELIMITERS list of separator characters !! !!##RETURNS !! TOKEN returned token !! CHOMP status flag. 0 = success, -1 = no tokens remain !! !!##EXAMPLES !! !! Sample program: !! !! program demo_chomp !! !! use M_strings, only : chomp !! implicit none !! character(len=100) :: inline !! character(len=:),allocatable :: token !! character(len=*),parameter :: delimiters=' ;,' !! integer :: ios !! integer :: icount !! integer :: itoken !! icount=0 !! do ! read lines from stdin until end-of-file or error !! read (unit=*,fmt="(a)",iostat=ios) inline !! if(ios /= 0)stop !! icount=icount+1 !! itoken=0 !! write(*,*)'INLINE ',trim(inline) !! do while ( chomp(inline,token,delimiters) >= 0) !! itoken=itoken+1 !! print *, itoken,'TOKEN=['//trim(token)//']' !! enddo !! enddo !! !! end program demo_chomp !! !! sample input file !! !! this is a test of chomp; A:B :;,C;; !! !! sample output file !! !! > INLINE this is a test of chomp; A:B :;,C;; !! > 1 TOKEN=[this] !! > 2 TOKEN=[is] !! > 3 TOKEN=[a] !! > 4 TOKEN=[test] !! > 5 TOKEN=[of] !! > 6 TOKEN=[chomp] !! > 7 TOKEN=[A:B] !! > 8 TOKEN=[:] !! > 9 TOKEN=[C] !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain FUNCTION chomp(source_string,token,delimiters) ! ident_9="@(#) M_strings chomp(3f) Tokenize a string JSU- 20151030" character(len=*) :: source_string ! string to tokenize character(len=:),allocatable,intent(out) :: token ! returned token character(len=*),intent(in),optional :: delimiters ! list of separator characters integer :: chomp ! returns copy of shifted source_string character(len=:),allocatable :: delimiters_local integer :: token_start ! beginning of token found if function result is .true. integer :: token_end ! end of token found if function result is .true. integer :: isource_len !----------------------------------------------------------------------------------------------------------------------------------- ! calculate where token_start should start for this pass if(present(delimiters))then delimiters_local=delimiters else ! increment start to previous end + 1 delimiters_local=char(32)//char(09)//char(10)//char(13) ! space,horizontal tab, newline, carriage return endif !----------------------------------------------------------------------------------------------------------------------------------- isource_len=len(source_string) ! length of input string !----------------------------------------------------------------------------------------------------------------------------------- ! find beginning of token token_start=1 do while (token_start <= isource_len) ! step thru each character to find next delimiter, if any if(index(delimiters_local,source_string(token_start:token_start)) /= 0) then token_start = token_start + 1 else exit endif enddo !----------------------------------------------------------------------------------------------------------------------------------- token_end=token_start do while (token_end <= isource_len-1) ! step thru each character to find next delimiter, if any if(index(delimiters_local,source_string(token_end+1:token_end+1)) /= 0) then ! found a delimiter in next character exit endif token_end = token_end + 1 enddo !write(*,*)'TOKEN_START ',token_start !write(*,*)'TOKEN_END ',token_end chomp=isource_len-token_end if(chomp >= 0)then token=source_string(token_start:token_end) source_string=source_string(token_end+1:) else token='' source_string='' endif !----------------------------------------------------------------------------------------------------------------------------------- end function chomp !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! delim(3f) - [M_strings:TOKENS] parse a string and store tokens into !! an array !! (LICENSE:PD) !! !!##SYNOPSIS !! !! subroutine delim(line,array,n,icount,ibegin,iterm,lgth,dlim) !! !! character(len=*),intent(in) :: line !! integer,integer(in) :: n !! integer,intent(out) :: icount !! character(len=*) :: array(n) !! integer,intent(out) :: ibegin(n) !! integer,intent(out) :: iterm(n) !! integer,intent(out) :: lgth !! character(len=*) :: dlim !! !!##DESCRIPTION !! Given a LINE of structure " par1 par2 par3 ... parn " !! store each par(n) into a separate variable in ARRAY (UNLESS !! ARRAY(1) == '#N#') !! !! Also set ICOUNT to number of elements of array initialized, and !! return beginning and ending positions for each element in IBEGIN(N) !! and ITERM(N). !! !! Return position of last non-blank character (even if more !! than N elements were found) in lgth !! !! No quoting or escaping of delimiter is allowed, so the delimiter !! character can not be placed in a token. !! !! No checking for more than N parameters; If any more they are ignored. !! !!##OPTIONS !! LINE input string to parse into tokens !! ARRAY(N) array that receives tokens !! N size of arrays ARRAY, IBEGIN, ITERM !! ICOUNT number of tokens found !! IBEGIN(N) starting columns of tokens found !! ITERM(N) ending columns of tokens found !! LGTH position of last non-blank character in input string LINE !! DLIM delimiter characters !! !!##EXAMPLES !! !! Sample program: !! !! program demo_delim !! !! use M_strings, only: delim !! implicit none !! character(len=80) :: line !! character(len=80) :: dlm !! integer,parameter :: n=10 !! character(len=20) :: array(n)=' ' !! integer :: ibegin(n),iterm(n) !! integer :: i20, icount, lgth, i10 !! line=' first second 10.3 words_of_stuff ' !! do i20=1,4 !! ! change delimiter list and what is calculated or parsed !! if(i20 == 1)dlm=' ' !! if(i20 == 2)dlm='o' !! if(i20 == 3)dlm=' aeiou' ! NOTE SPACE IS FIRST !! if(i20 == 3)ARRAY(1)='#N#' ! QUIT RETURNING STRING ARRAY !! if(i20 == 4)line='AAAaBBBBBBbIIIIIi J K L' !! !! ! write out a break line composed of =========== .. !! write(*,'(57("="))') !! ! show line being parsed !! write(*,'(a)')'PARSING=['//trim(line)//'] on '//trim(dlm) !! ! call parsing procedure !! call delim(line,array,n,icount,ibegin,iterm,lgth,dlm) !! write(*,*)'number of tokens found=',icount !! write(*,*)'last character in column ',lgth !! if(icount > 0)then !! if(lgth /= iterm(icount))then !! write(*,*)'ignored from column ',iterm(icount)+1,' to ',lgth !! endif !! do i10=1,icount !! ! check flag to see if ARRAY() was set !! if(array(1) /= '#N#')then !! ! from returned array !! write(*,'(a,a,a)',advance='no')& !! &'[',array(i10)(:iterm(i10)-ibegin(i10)+1),']' !! endif !! enddo !! ! using start and end positions in IBEGIN() and ITERM() !! write(*,*) !! do i10=1,icount !! ! from positions in original line !! write(*,'(a,a,a)',advance='no')& !! &'[',line(ibegin(i10):iterm(i10)),']' !! enddo !! write(*,*) !! endif !! enddo !! end program demo_delim !! !! Results: !! !! ========================================================= !! PARSING=[ first second 10.3 words_of_stuff] on !! number of tokens found= 4 !! last character in column 34 !! [first][second][10.3][words_of_stuff] !! [first][second][10.3][words_of_stuff] !! ========================================================= !! PARSING=[ first second 10.3 words_of_stuff] on o !! number of tokens found= 4 !! last character in column 34 !! [ first sec][nd 10.3 w][rds_][f_stuff] !! [ first sec][nd 10.3 w][rds_][f_stuff] !! ========================================================= !! PARSING=[ first second 10.3 words_of_stuff] on aeiou !! number of tokens found= 10 !! last character in column 34 !! !! [f][rst][s][c][nd][10.3][w][rds_][f_st][ff] !! ========================================================= !! PARSING=[AAAaBBBBBBbIIIIIi J K L] on aeiou !! number of tokens found= 5 !! last character in column 24 !! !! [AAA][BBBBBBbIIIII][J][K][L] !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain subroutine delim(line,array,n,icount,ibegin,iterm,lgth,dlim) ! ident_10="@(#) M_strings 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 count 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) :: line integer,intent(in) :: n character(len=*) :: array(n) integer,intent(out) :: icount integer,intent(out) :: ibegin(n) integer,intent(out) :: iterm(n) integer,intent(out) :: lgth character(len=*),intent(in) :: dlim !----------------------------------------------------------------------------------------------------------------------------------- character(len=len(line)):: line_local logical :: lstore integer :: i10 integer :: iarray integer :: icol integer :: idlim integer :: iend integer :: ifound integer :: istart !----------------------------------------------------------------------------------------------------------------------------------- icount=0 lgth=len_trim(line) line_local=line 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 if(lgth == 0)then ! command was totally blank return endif ! ! there is at least one non-blank character in the command ! lgth 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 NOINCREMENT: do if(index(dlim(1:idlim),line_local(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=lgth-istart+1+1 ! assume no delimiters so put past end of line do i10=1,idlim ifound=index(line_local(istart:lgth),dlim(i10:i10)) if(ifound > 0)then iend=min(iend,ifound) endif enddo if(iend <= 0)then ! no remaining delimiters iterm(iarray)=lgth if(lstore)then array(iarray)=line_local(istart:lgth) endif icount=iarray return else iend=iend+istart-2 iterm(iarray)=iend if(lstore)then array(iarray)=line_local(istart:iend) endif endif icol=iend+2 exit NOINCREMENT endif icol=icol+1 enddo NOINCREMENT ! last character in line was a delimiter, so no text left ! (should not happen where blank=delimiter) if(icol > lgth)then icount=iarray if( (iterm(icount)-ibegin(icount)) < 0)then ! last token was all delimiters icount=icount-1 endif return endif enddo icount=n ! more than n elements end subroutine delim !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! replace(3f) - [M_strings:EDITING] function replaces one !! substring for another in string !! (LICENSE:PD) !! !!##SYNOPSIS !! !! syntax: !! !! function replace(targetline,old,new,cmd,& !! & occurrence, & !! & repeat, & !! & ignorecase, & !! & ierr) result (newline) !! character(len=*) :: targetline !! character(len=*),intent(in),optional :: old !! character(len=*),intent(in),optional :: new !! character(len=*),intent(in),optional :: cmd !! integer,intent(in),optional :: occurrence !! integer,intent(in),optional :: repeat !! logical,intent(in),optional :: ignorecase !! integer,intent(out),optional :: ierr !! character(len=:),allocatable :: newline !! !!##DESCRIPTION !! Replace one substring for another in string. !! Either CMD or OLD and NEW must be specified. !! !!##OPTIONS !! targetline input line to be changed !! old old substring to replace !! new new substring !! cmd alternate way to specify old and new string, in !! the form c/old/new/; where "/" can be any character !! not in "old" or "new". !! occurrence if present, start changing at the Nth occurrence of the !! OLD string. If negative start replacing from the left !! end of the string. !! repeat number of replacements to perform. Defaults to a global !! replacement. !! ignorecase whether to ignore ASCII case or not. Defaults !! to .false. . !!##RETURNS !! newline allocatable string returned !! ierr error code. iF ier = -1 bad directive, >= 0 then !! count of changes made. !! !!##EXAMPLES !! !! Sample Program: !! !! program demo_replace !! use M_strings, only : replace !! implicit none !! character(len=:),allocatable :: line !! !! write(*,*)replace('Xis is Xe string','X','th') !! write(*,*)replace('Xis is xe string','x','th',ignorecase=.true.) !! write(*,*)replace('Xis is xe string','X','th',ignorecase=.false.) !! !! ! a null old substring means "at beginning of line" !! write(*,*) replace('my line of text','','BEFORE:') !! !! ! a null new string deletes occurrences of the old substring !! write(*,*) replace('I wonder i ii iii','i','') !! !! ! Examples of the use of RANGE !! !! line=replace('aaaaaaaaa','a','A',occurrence=1,repeat=1) !! write(*,*)'replace first a with A ['//line//']' !! !! line=replace('aaaaaaaaa','a','A',occurrence=3,repeat=3) !! write(*,*)'replace a with A for 3rd to 5th occurrence ['//line//']' !! !! line=replace('ababababa','a','',occurrence=3,repeat=3) !! write(*,*)'replace a with null instances 3 to 5 ['//line//']' !! !! line=replace( & !! & 'a b ab baaa aaaa aa aa a a a aa aaaaaa',& !! & 'aa','CCCC',occurrence=-1,repeat=1) !! write(*,*)'replace lastaa with CCCC ['//line//']' !! !! write(*,*)replace('myf90stuff.f90.f90','f90','for',occurrence=-1,repeat=1) !! write(*,*)replace('myf90stuff.f90.f90','f90','for',occurrence=-2,repeat=2) !! !! end program demo_replace !! !! Results: !! !! this is the string !! this is the string !! this is xe string !! BEFORE:my line of text !! I wonder !! replace first a with A [Aaaaaaaaa] !! replace a with A for 3rd to 5th occurrence [aaAAAaaaa] !! replace a with null instances 3 to 5 [ababbb] !! replace lastaa with CCCC [a b ab baaa aaaa aa aa a a a aa aaaaCCCC] !! myf90stuff.f90.for !! myforstuff.for.f90 !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain subroutine crack_cmd(cmd,old,new,ierr) !----------------------------------------------------------------------------------------------------------------------------------- character(len=*),intent(in) :: cmd character(len=:),allocatable,intent(out) :: old,new ! scratch string buffers integer :: ierr !----------------------------------------------------------------------------------------------------------------------------------- character(len=1) :: delimiters integer :: itoken integer,parameter :: id=2 ! expected location of delimiter logical :: ifok integer :: lmax ! length of target string integer :: start_token,end_token !----------------------------------------------------------------------------------------------------------------------------------- ierr=0 old='' new='' lmax=len_trim(cmd) ! significant length of change directive if(lmax >= 4)then ! strtok ignores blank tokens so look for special case where first token is really null delimiters=cmd(id:id) ! find delimiter in expected location itoken=0 ! initialize strtok(3f) procedure if(strtok(cmd(id:),itoken,start_token,end_token,delimiters)) then ! find OLD string old=cmd(start_token+id-1:end_token+id-1) else old='' endif if(cmd(id:id) == cmd(id+1:id+1))then new=old old='' else ! normal case ifok=strtok(cmd(id:),itoken,start_token,end_token,delimiters) ! find NEW string if(end_token == (len(cmd)-id+1) )end_token=len_trim(cmd(id:)) ! if missing ending delimiter new=cmd(start_token+id-1:min(end_token+id-1,lmax)) endif else ! command was two or less characters ierr=-1 call journal('sc','*crack_cmd* incorrect change directive -too short') endif end subroutine crack_cmd !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== function replace(targetline,old,new,cmd,occurrence,repeat,ignorecase,ierr) result (newline) ! ident_11="@(#) M_strings replace(3f) replace one substring for another in string" !----------------------------------------------------------------------------------------------------------------------------------- ! parameters character(len=*),intent(in) :: targetline ! input line to be changed character(len=*),intent(in),optional :: old ! old substring to replace character(len=*),intent(in),optional :: new ! new substring character(len=*),intent(in),optional :: cmd ! contains the instructions changing the string integer,intent(in),optional :: occurrence ! Nth occurrence of OLD string to start replacement at integer,intent(in),optional :: repeat ! how many replacements logical,intent(in),optional :: ignorecase integer,intent(out),optional :: ierr ! error code. if ierr = -1 bad directive, >=0 then ierr changes made !----------------------------------------------------------------------------------------------------------------------------------- ! returns character(len=:),allocatable :: newline ! output string buffer !----------------------------------------------------------------------------------------------------------------------------------- ! local character(len=:),allocatable :: new_local, old_local, old_local_for_comparison integer :: icount,ichange,ier2 integer :: original_input_length integer :: len_old, len_new integer :: ladd integer :: left_margin, right_margin integer :: ind integer :: ic integer :: ichr integer :: range_local(2) character(len=:),allocatable :: targetline_for_comparison ! input line to be changed logical :: ignorecase_local logical :: flip character(len=:),allocatable :: targetline_local ! input line to be changed !----------------------------------------------------------------------------------------------------------------------------------- flip=.false. ignorecase_local=.false. original_input_length=len_trim(targetline) ! get non-blank length of input line ! get old_local and new_local from cmd or old and new if(present(cmd))then call crack_cmd(cmd,old_local,new_local,ier2) if(ier2 /= 0)then newline=targetline ! if no changes are made return original string on error if(present(ierr))ierr=ier2 return endif elseif(present(old).and.present(new))then old_local=old new_local=new else newline=targetline ! if no changes are made return original string on error call journal('sc','*replace* must specify OLD and NEW or CMD') return endif if(present(ignorecase))then ignorecase_local=ignorecase else ignorecase_local=.false. endif if(present(occurrence))then range_local(1)=abs(occurrence) else range_local(1)=1 endif if(present(repeat))then range_local(2)=range_local(1)+repeat-1 else range_local(2)=original_input_length endif if(ignorecase_local)then targetline_for_comparison=lower(targetline) old_local_for_comparison=lower(old_local) else targetline_for_comparison=targetline old_local_for_comparison=old_local endif if(present(occurrence))then if(occurrence < 0)then flip=.true. targetline_for_comparison=reverse(targetline_for_comparison) targetline_local=reverse(targetline) old_local_for_comparison=reverse(old_local_for_comparison) old_local=reverse(old_local) new_local=reverse(new_local) else targetline_local=targetline endif else targetline_local=targetline endif !----------------------------------------------------------------------------------------------------------------------------------- icount=0 ! initialize error flag/change count ichange=0 ! initialize error flag/change count len_old=len(old_local) ! length of old substring to be replaced len_new=len(new_local) ! length of new substring to replace old substring left_margin=1 ! left_margin is left margin of window to change right_margin=len(targetline) ! right_margin is right margin of window to change newline='' ! begin with a blank line as output string !----------------------------------------------------------------------------------------------------------------------------------- if(len_old == 0)then ! c//new/ means insert new at beginning of line (or left margin) ichr=len_new + original_input_length if(len_new > 0)then newline=new_local(:len_new)//targetline_local(left_margin:original_input_length) else newline=targetline_local(left_margin:original_input_length) endif ichange=1 ! made one change. actually, c/// should maybe return 0 if(present(ierr))ierr=ichange if(flip) newline=reverse(newline) return endif !----------------------------------------------------------------------------------------------------------------------------------- ichr=left_margin ! place to put characters into output string ic=left_margin ! place looking at in input string loop: do ! try finding start of OLD in remaining part of input in change window ind=index(targetline_for_comparison(ic:),old_local_for_comparison(:len_old))+ic-1 if(ind == ic-1.or.ind > right_margin)then ! did not find old string or found old string past edit window exit loop ! no more changes left to make endif icount=icount+1 ! found an old string to change, so increment count of change candidates if(ind > 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 newline=newline(:ichr-1)//targetline_local(ic:ind-1) ichr=ichr+ladd endif if(icount >= range_local(1).and.icount <= range_local(2))then ! check if this is an instance to change or keep ichange=ichange+1 if(len_new /= 0)then ! put in new string newline=newline(:ichr-1)//new_local(:len_new) ichr=ichr+len_new endif else if(len_old /= 0)then ! put in copy of old string newline=newline(:ichr-1)//old_local(:len_old) ichr=ichr+len_old endif endif ic=ind+len_old enddo loop !----------------------------------------------------------------------------------------------------------------------------------- select case (ichange) case (0) ! there were no changes made to the window newline=targetline_local ! if no changes made output should be input case default if(ic <= len(targetline))then ! if there is more after last change on original line add it newline=newline(:ichr-1)//targetline_local(ic:max(ic,original_input_length)) endif end select if(present(ierr))ierr=ichange if(flip) newline=reverse(newline) !----------------------------------------------------------------------------------------------------------------------------------- end function replace !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! substitute(3f) - [M_strings:EDITING] subroutine globally substitutes !! one substring for another in string !! (LICENSE:PD) !! !!##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. Must be long enough to !! hold altered output. !! OLD substring to find and replace !! NEW replacement for OLD substring !! IERR error code. If IER = -1 bad directive, >= 0 then !! count of changes made. !! START sets the left margin to be scanned for OLD in !! TARGETLINE. !! END sets the right margin to be scanned for OLD in !! TARGETLINE. !! !!##EXAMPLES !! !! Sample Program: !! !! program demo_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 demo_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 !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain subroutine substitute(targetline,old,new,ierr,start,end) ! ident_12="@(#) 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 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 !----------------------------------------------------------------------------------------------------------------------------------- character(len=len(targetline)) :: dum1 ! scratch string buffers 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 :: ichr !----------------------------------------------------------------------------------------------------------------------------------- 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 <= 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 == 0)then ! c//new/ means insert new at beginning of line (or left margin) ichr=len_new + original_input_length if(ichr > maxlengthout)then call journal('sc','*substitute* new line will be too long') ier1=-1 if (present(ierr))ierr=ier1 return endif if(len_new > 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 !----------------------------------------------------------------------------------------------------------------------------------- ichr=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 == ic-1.or.ind > 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 > 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(ichr-1+ladd > maxlengthout)then ier1=-1 exit loop endif dum1(ichr:)=targetline(ic:ind-1) ichr=ichr+ladd endif if(ichr-1+len_new > maxlengthout)then ier1=-2 exit loop endif if(len_new /= 0)then dum1(ichr:)=new(:len_new) ichr=ichr+len_new endif ic=ind+len_old enddo loop !----------------------------------------------------------------------------------------------------------------------------------- select case (ier1) case (:-1) call journal('sc','*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(ichr+ladd > maxlengthout)then call journal('sc','*substitute* new line will be too long') ier1=-1 if(present(ierr))ierr=ier1 return endif if(ic < len(targetline))then dum1(ichr:)=targetline(ic:max(ic,original_input_length)) endif targetline=dum1(:maxlengthout) end select if(present(ierr))ierr=ier1 !----------------------------------------------------------------------------------------------------------------------------------- end subroutine substitute !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! change(3f) - [M_strings:EDITING] change old string to new string with !! a directive like a line editor !! (LICENSE:PD) !! !!##SYNOPSIS !! !! subroutine change(target_string,cmd,ierr) !! !! character(len=*),intent(inout) :: target_string !! character(len=*),intent(in) :: cmd !! integer :: ierr !! !!##DESCRIPTION !! change an old substring into a new substring in a character variable !! like a line editor. Primarily used to create interactive utilities !! such as input history editors for interactive line-mode programs. The !! output string is assumed long enough to accommodate the change. !! a directive resembles a line editor directive of the form !! !! C/old_string/new_string/ !! !! where / may be any character which is not included in old_string !! or new_string. !! !! a null old_string implies "beginning of string". !! !!##OPTIONS !! target_string line to be changed !! cmd contains instructions to change the string !! ierr error code. !! !! o =-1 bad directive !! o =0 no changes made !! o >0 count of changes made !! !!##EXAMPLES !! !! Sample program: !! !! program demo_change !! !! use M_strings, only : change !! implicit none !! character(len=132) :: line='This is a test string to change' !! integer :: ierr !! write(*,*)trim(line) !! ! change miniscule a to uppercase A !! call change(line,'c/a/A/',ierr) !! write(*,*)trim(line) !! ! put string at beginning of line !! call change(line,'c//prefix: /',ierr) !! write(*,*)trim(line) !! ! remove blanks !! call change(line,'c/ //',ierr) !! write(*,*)trim(line) !! end program demo_change !! !! Expected output !! !! This is a test string to change !! This is A test string to chAnge !! prefix: This is A test string to chAnge !! prefix:ThisisAteststringtochAnge !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain subroutine change(target_string,cmd,ierr) ! Change a string assumed long enough to accommodate the change, with a directive that resembles a line editor directive of the form ! C/old_string/new_string/ ! where / may be any character which is not included in old_string or new_string. ! a null old_string implies "beginning of string" !=================================================================================================================================== ! ident_13="@(#) M_strings change(3f) change a character string like a line editor" character(len=*),intent(inout) :: target_string ! line to be changed character(len=*),intent(in) :: cmd ! contains the instructions changing the string character(len=1) :: delimiters integer :: ierr ! error code. ier=-1 bad directive;=0 no changes made;>0 ier changes made integer :: itoken integer,parameter :: id=2 ! expected location of delimiter character(len=:),allocatable :: old,new ! scratch string buffers logical :: ifok integer :: lmax ! length of target string integer :: start_token,end_token !----------------------------------------------------------------------------------------------------------------------------------- lmax=len_trim(cmd) ! significant length of change directive if(lmax >= 4)then ! strtok ignores blank tokens so look for special case where first token is really null delimiters=cmd(id:id) ! find delimiter in expected location itoken=0 ! initialize strtok(3f) procedure if(strtok(cmd(id:),itoken,start_token,end_token,delimiters)) then ! find OLD string old=cmd(start_token+id-1:end_token+id-1) else old='' endif if(cmd(id:id) == cmd(id+1:id+1))then new=old old='' else ! normal case ifok=strtok(cmd(id:),itoken,start_token,end_token,delimiters) ! find NEW string if(end_token == (len(cmd)-id+1) )end_token=len_trim(cmd(id:)) ! if missing ending delimiter new=cmd(start_token+id-1:min(end_token+id-1,lmax)) endif call substitute(target_string,old,new,ierr,1,len_trim(target_string)) ! change old substrings to new substrings else ! command was two or less characters ierr=-1 call journal('sc','*change* incorrect change directive -too short') endif !----------------------------------------------------------------------------------------------------------------------------------- end subroutine change !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! strtok(3f) - [M_strings:TOKENS] Tokenize a string !! (LICENSE:PD) !! !!##SYNOPSIS !! !! function strtok(source_string,itoken,token_start,token_end,delimiters) !! result(strtok_status) !! !! ! returned value !! logical :: strtok_status !! ! string to tokenize !! character(len=*),intent(in) :: source_string !! ! token count since started !! integer,intent(inout) :: itoken !! ! beginning of token !! integer,intent(out) :: token_start !! ! end of token !! integer,intent(inout) :: token_end !! ! list of separator characters !! character(len=*),intent(in) :: delimiters !! !!##DESCRIPTION !! The STRTOK(3f) function is used to isolate sequential tokens in a !! string, SOURCE_STRING. These tokens are delimited in the string by !! at least one of the characters in DELIMITERS. The first time that !! STRTOK(3f) is called, ITOKEN should be specified as zero. Subsequent !! calls, wishing to obtain further tokens from the same string, !! should pass back in TOKEN_END and ITOKEN until the function result !! returns .false. !! !! This routine assumes no other calls are made to it using any other !! input string while it is processing an input line. !! !!##OPTIONS !! source_string input string to parse !! itoken token count should be set to zero for a new string !! delimiters characters used to determine the end of tokens !! !!##RETURN !! token_start beginning position in SOURCE_STRING where token was found !! token_end ending position in SOURCE_STRING where token was found !! strtok_status !! !!##EXAMPLES !! !! Sample program: !! !! program demo_strtok !! use M_strings, only : strtok !! implicit none !! character(len=264) :: inline !! character(len=*),parameter :: delimiters=' ;,' !! integer :: ios, itoken, istart, iend !! do ! read lines from stdin until end-of-file or error !! read (unit=*,fmt="(a)",iostat=ios) inline !! if(ios /= 0)stop !! ! must set ITOKEN=0 before looping on strtok(3f) !! ! on a new string. !! itoken=0 !! do while & !! &( strtok(inline,itoken,istart,iend,delimiters) ) !! print *, itoken,& !! & 'TOKEN=['//(inline(istart:iend))//']',istart,iend !! enddo !! enddo !! end program demo_strtok !! !! sample input file !! !! this is a test of strtok; A:B :;,C;; !! !! sample output file !! !! 1 TOKEN=[this] 2 5 !! 2 TOKEN=[is] 7 8 !! 3 TOKEN=[a] 10 10 !! 4 TOKEN=[test] 12 15 !! 5 TOKEN=[of] 17 18 !! 6 TOKEN=[strtok] 20 25 !! 7 TOKEN=[A:B] 28 30 !! 8 TOKEN=[:] 32 32 !! 9 TOKEN=[C] 35 35 !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain FUNCTION strtok(source_string,itoken,token_start,token_end,delimiters) result(strtok_status) ! JSU- 20151030 ! ident_14="@(#) M_strings strtok(3f) Tokenize a string" character(len=*),intent(in) :: source_string ! Source string to tokenize. character(len=*),intent(in) :: delimiters ! list of separator characters. May change between calls integer,intent(inout) :: itoken ! token count since started logical :: strtok_status ! returned value integer,intent(out) :: token_start ! beginning of token found if function result is .true. integer,intent(inout) :: token_end ! end of token found if function result is .true. integer,save :: isource_len !---------------------------------------------------------------------------------------------------------------------------- ! calculate where token_start should start for this pass if(itoken <= 0)then ! this is assumed to be the first call token_start=1 else ! increment start to previous end + 1 token_start=token_end+1 endif !---------------------------------------------------------------------------------------------------------------------------- isource_len=len(source_string) ! length of input string !---------------------------------------------------------------------------------------------------------------------------- if(token_start > isource_len)then ! user input error or at end of string token_end=isource_len ! assume end of token is end of string until proven otherwise so it is set strtok_status=.false. return endif !---------------------------------------------------------------------------------------------------------------------------- ! find beginning of token do while (token_start <= isource_len) ! step thru each character to find next delimiter, if any if(index(delimiters,source_string(token_start:token_start)) /= 0) then token_start = token_start + 1 else exit endif enddo !---------------------------------------------------------------------------------------------------------------------------- token_end=token_start do while (token_end <= isource_len-1) ! step thru each character to find next delimiter, if any if(index(delimiters,source_string(token_end+1:token_end+1)) /= 0) then ! found a delimiter in next character exit endif token_end = token_end + 1 enddo !---------------------------------------------------------------------------------------------------------------------------- if (token_start > isource_len) then ! determine if finished strtok_status=.false. ! flag that input string has been completely processed else itoken=itoken+1 ! increment count of tokens found strtok_status=.true. ! flag more tokens may remain endif !---------------------------------------------------------------------------------------------------------------------------- end function strtok !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! modif(3f) - [M_strings:EDITING] emulate the MODIFY command from the !! line editor XEDIT !! (LICENSE:PD) !! !!##SYNOPSIS !! !! subroutine modif(cline,cmod) !! !! character(len=*) :: cline ! input string to change !! ! directive provides directions on changing string !! character(len=*) :: cmod !! !!##DESCRIPTION !! MODIF(3f) Modifies the line currently pointed at using a directive !! that acts much like a line editor directive. !! Primarily used to create interactive utilities such as input history !! editors for interactive line-mode programs. !! !! the modify directives are as follows- !! !! DIRECTIVE EXPLANATION !! !! ^STRING# Causes the string of characters between the ^ and the !! next # to be inserted before the characters pointed to !! by the ^. an ^ or & within the string is treated as a !! regular character. If the closing # is not specified, !! MODIF(3f) inserts the remainder of the line as if a # was !! specified after the last nonblank character. !! !! There are two exceptions. the combination ^# causes a # !! to be inserted before the character pointed to by the !! ^, and an ^ as the last character of the directives !! causes a blank to be inserted. !! !! # (When not the first # after an ^) causes the character !! above it to be deleted. !! !! & Replaces the character above it with a space. !! !! (SPACE) A space below a character leaves it unchanged. !! !! Any other character replaces the character above it. !! !!##EXAMPLES !! !! Example input/output: !! !! THE INPUT LINE........ 10 THIS STRING TO BE MORTIFD !! THE DIRECTIVES LINE... ^ IS THE# D# ^IE !! ALTERED INPUT LINE.... 10 THIS IS THE STRING TO BE MODIFIED !! !! Sample program: !! !! program demo_modif !! use M_strings, only : modif !! implicit none !! character(len=256) :: line !! integer :: ios !! integer :: count !! integer :: COMMAND_LINE_LENGTH !! character(len=:),allocatable :: COMMAND_LINE !! ! get command name length !! call get_command_argument(0,length=count) !! ! get command line length !! call get_command(length=COMMAND_LINE_LENGTH) !! ! allocate string big enough to hold command line !! allocate(character(len=COMMAND_LINE_LENGTH+200) :: COMMAND_LINE) !! ! get command line as a string !! call get_command(command=COMMAND_LINE) !! ! trim leading spaces just in case !! COMMAND_LINE=adjustl(COMMAND_LINE) !! ! remove command name !! COMMAND_LINE=adjustl(COMMAND_LINE(COUNT+2:)) !! INFINITE: do !! read(*,'(a)',iostat=ios)line !! if(ios /= 0)exit !! call modif(line,COMMAND_LINE) !! write(*,'(a)')trim(line) !! enddo INFINITE !! end program demo_modif !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain subroutine modif(cline,mod) !$@(#) M_strings::modif(3f): Emulate the MODIFY command from the line editor XEDIT ! ! MODIF ! ===== ! ACTION- MODIFIES THE LINE CURRENTLY POINTED AT. THE INPUT STRING CLINE IS ASSUMED TO BE LONG ENOUGH TO ACCOMMODATE THE CHANGES ! THE MODIFY DIRECTIVES ARE AS FOLLOWS- ! ! DIRECTIVE EXPLANATION ! --------- ------------ ! ^STRING# CAUSES THE STRING OF CHARACTERS BETWEEN THE ^ AND THE ! NEXT # TO BE INSERTED BEFORE THE CHARACTERS POINTED TO ! BY THE ^. AN ^ OR & WITHIN THE STRING IS TREATED AS A ! REGULAR CHARACTER. IF THE CLOSING # IS NOT SPECIFIED, ! MODIF(3f) INSERTS THE REMAINDER OFTHELINE AS IF A # WAS ! SPECIFIED AFTER THE LAST NONBLANK CHARACTER. ! ! THERE ARE TWO EXCEPTIONS. THE COMBINATION ^# CAUSES A # ! TO BE INSERTED BEFORE THE CHARACTER POINTED TO BY THE ! ^, AND AN ^ AS THE LAST CHARACTER OF THE DIRECTIVES ! CAUSES A BLANK TO BE INSERTED. ! ! # (WHEN NOT THE FIRST # AFTER AN ^) CAUSES THE CHARACTER ! ABOVE IT TO BE DELETED. ! ! & REPLACES THE CHARACTER ABOVE IT WITH A SPACE. ! ! (SPACE) A SPACE BELOW A CHARACTER LEAVES IT UNCHANGED. ! ! ANY OTHER CHARACTER REPLACES THE CHARACTER ABOVE IT. ! ! EXAMPLE- ! THE INPUT LINE........ 10 THIS STRING TO BE MORTIFD ! THE DIRECTIVES LINE... ^ IS THE# D# ^IE ! ALTERED INPUT LINE.... 10 THIS IS THE STRING TO BE MODIFIED !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC character(len=*) :: cline !STRING TO BE MODIFIED character(len=*),intent(in) :: mod !STRING TO DIRECT MODIFICATION character(len=len(cline)) :: cmod character(len=3),parameter :: c='#&^' !ASSIGN DEFAULT EDIT CHARACTERS integer :: maxscra !LENGTH OF SCRATCH BUFFER character(len=len(cline)) :: dum2 !SCRATCH CHARACTER BUFFER logical :: linsrt !FLAG FOR INSERTING DATA ON LINE integer :: i, j, ic, ichr, iend, lmax, lmx1 maxscra=len(cline) cmod=trim(mod) lmax=min0(len(cline),maxscra) !DETERMINE MAXIMUM LINE LENGTH lmx1=lmax-1 !MAX LINE LENGTH -1 dum2=' ' !INITIALIZE NEW LINE linsrt=.false. !INITIALIZE INSERT MODE iend=len_trim(cmod) !DETERMINE END OF MODS i=0 !CHAR COUNTER FOR MOD LINE CMOD ic=0 !CHAR COUNTER FOR CURRENT LINE CLINE ichr=0 !CHAR COUNTER NEW LINE DUM2 11 continue i=i+1 !NEXT CHAR IN MOD LINE if(ichr > lmx1)goto 999 !IF TOO MANY CHARS IN NEW LINE if(linsrt) then !IF INSERTING NEW CHARS if(i > iend) cmod(i:i)=c(1:1) !FORCE END OF INSERT MODE if(cmod(i:i) == c(1:1))then !IF END OF INSERT MODE linsrt=.false. !RESET INSERT MODE FLAG if(ic+1 == i)then !NULL INSERT STRING ichr=ichr+1 !INCREMENT COUNTER FOR NEW LINE dum2(ichr:ichr)=c(1:1) !INSERT INSERT MODE TERMINATOR endif do j=ic,i !LOOP OF NUMBER OF CHARS INSERTED ichr=ichr+1 !INCREMENT COUNTER FOR NEW LINE if(ichr > lmax)goto 999 !IF AT BUFFER LIMIT, QUIT dum2(ichr:ichr)=cline(j:j) !APPEND CHARS FROM ORIG LINE enddo !...WHICH ALIGN WITH INSERTED CHARS ic=i !RESET CHAR COUNT TO END OF INSERT goto 1 !CHECK NEW LINE LENGTH AND CYCLE endif !END OF TERMINATED INSERT LOGIC ichr=ichr+1 !INCREMENT NEW LINE COUNT dum2(ichr:ichr)=cmod(i:i) !SET NEWLINE CHAR TO INSERTED CHAR else !IF NOT INSERTING CHARACTERS ic=ic+1 !INCREMENT ORIGINAL LINE COUNTER if(cmod(i:i) == c(1:1))goto 1 !IF DELETE CHAR. NO COPY AND CYCLE if(cmod(i:i) == c(3:3))then !IF BEGIN INSERT MODE linsrt=.true. !SET INSERT FLAG TRUE goto 1 !CHECK LINE LENGTH AND CONTINUE endif !IF NOT BEGINNING INSERT MODE ichr=ichr+1 !INCREMENT NEW LINE COUNTER if(cmod(i:i) == c(2:2))then !IF REPLACE WITH BLANK dum2(ichr:ichr)=' ' !SET NEWLINE CHAR TO BLANK goto 1 !CHECK LINE LENGTH AND CYCLE endif !IF NOT REPLACE WITH BLANK if(cmod(i:i) == ' ')then !IF BLANK, KEEP ORIGINAL CHARACTER dum2(ichr:ichr)=cline(ic:ic) !SET NEW CHAR TO ORIGINAL CHAR else !IF NOT KEEPING OLD CHAR dum2(ichr:ichr)=cmod(i:i) !REPLACE ORIGINAL CHAR WITH NEW endif !END CHAR KEEP OR REPLACE endif !END INSERT OR NO-INSERT 1 continue if(i < lmax)goto 11 !CHECK FOR END OF LINE REACHED !AND CYCLE IF OK 999 continue cline=dum2 !SET ORIGINAL CHARS TO NEW CHARS end subroutine modif !RETURN !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! len_white(3f) - [M_strings:LENGTH] get length of string trimmed !! of whitespace. !! (LICENSE:PD) !! !!##SYNOPSIS !! !! integer function len_white(string) !! !! character(len=*) :: string !! !!##DESCRIPTION !! len_white(3f) returns the position of the last character in !! string that is not a whitespace character. The Fortran90 intrinsic !! LEN_TRIM() should be used when trailing whitespace can be assumed !! to always be spaces. !! !! This procedure was heavily used in the past because ANSI FORTRAN !! 77 character objects are fixed length and blank padded and the !! LEN_TRIM() intrinsic did not exist. It should now be used only when !! whitespace characters other than blanks are likely. !! !!##OPTIONS !! string input string whose trimmed length is being calculated !! ignoring all trailing whitespace characters. !!##RETURNS !! len_white the number of characters in the trimmed string !! !!##EXAMPLE !! !! Sample Program: !! !! program demo_len_white !! !! use M_strings, only : len_white !! implicit none !! character(len=80) :: s !! integer :: lgth, lastnb !! intrinsic len !! !! s=' ABCDEFG abcdefg ' !! lgth = len(s) !! lastnb = len_white(s) !! !! write(*,*) 'total length of variable is ',lgth !! write(*,*) 'trimmed length of variable is ',lastnb !! write(*,*) 'trimmed string=[',s(:lastnb),']' !! !! end program demo_len_white !! !! Results: !! !! total length of variable is 80 !! trimmed length of variable is 16 !! trimmed string=[ ABCDEFG abcdefg] !! !!##NOTES !! !! o len_white !! !! is a resource-intensive routine. Once the end of !! the string is found, it is probably best to keep track of it in !! order to avoid repeated calls to len_white. Because they !! might be more efficient, consider looking for vendor-supplied or !! system-optimized equivalents. For example: !! !! o lnblnk - Solaris f77 !! o len_trim - FORTRAN 90 !! !! o Some compilers seem to have trouble passing a string of variable !! length properly. To be safe, use something like this: !! !! subroutine message(s) !! character(len=*) :: s ! s is of variable length !! lgth=len(s) ! get total length of variable !! ! explicitly specify a substring instead of just variable name !! lastnb = len_white(s(:lgth)) !! write(*,*)'error:[',s(:lastnb),']' !! end subroutine messages !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain elemental integer function len_white(string) ! DEPRECATED. Use len_trim(3f),trim(3f) unless you might have trailing nulls (common when interacting with C procedures)" ! John S. Urban, 1984, 1997-12-31 ! Note that if the string is blank, a length of 0 is returned; which is not a legal string length in Fortran77. ! this routine used to return one instead of zero. ! - mod 1: 1994 ! added null (char(0)) because HP and some Suns not padding ! strings with blank, but with null characters; 1994 JSU ! - mod 2: 1999 ! update syntax with INTENT(), ENDDO, no RETURN ! still need instead of LEN_TRIM() because some systems stil pad CHARACTER with NULL !----------------------------------------------------------------------------------------------------------------------------------- ! ident_15="@(#) M_strings len_white(3f) return position of last non-blank/non-null character in string" character(len=*),intent(in):: string ! input string to determine length of integer :: i10 intrinsic len len_white=0 do i10=len(string),1,-1 select case(string(i10:i10)) case(' ') ! space(32) case(char(0)) ! null(0) case(char(9):char(13)) ! tab(9), new line(10), vertical tab(11), formfeed(12), carriage return(13) case default len_white=i10 exit end select enddo end function len_white !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! crop(3f) - [M_strings:WHITESPACE] trim leading and trailing blanks !! and control characters from a string !! (LICENSE:PD) !! !!##SYNOPSIS !! !! function crop(strin) result (strout) !! !! character(len=*),intent(in) :: strin !! character(len=:),allocatable :: strout !! !!##DESCRIPTION !! All control characters throughout the string are replaced with spaces !! and leading and trailing spaces are trimmed from the resulting string. !! Tabs are expanded assuming a stop every eight characters. !! !!##OPTIONS !! strin input string to trim leading and trailing space and control !! characters from !! !!##RETURNS !! strout cropped version of input string !! !!##EXAMPLE !! !! Sample program: !! !! program demo_crop !! use M_strings, only: crop !! implicit none !! character(len=20) :: untrimmed = ' ABCDEFG abcdefg ' !! write(*,*) 'untrimmed string=[',untrimmed,']' !! write(*,*) 'cropped string=[',crop(untrimmed),']' !! end program demo_crop !! !! Expected output !! !! untrimmed string=[ ABCDEFG abcdefg ] !! cropped string=[ABCDEFG abcdefg] !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain function crop(strin) result (strout) ! ident_16="@(#) M_strings crop(3f) replace control characters with whitespace and trim leading and trailings spaces from resulting string" character(len=*),intent(in) :: strin character(len=:),allocatable :: strout strout=trim(adjustl(noesc(dilate(strin)))) end function crop !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! clip(3f) - [M_strings:WHITESPACE] trim leading and trailing blanks from a string !! (LICENSE:PD) !! !!##SYNOPSIS !! !! function clip(strin) result (strout) !! !! character(len=*),intent(in) :: strin !! character(len=:),allocatable :: strout !! !!##DESCRIPTION !! leading and trailing spaces are trimmed from the resulting string. !! !!##OPTIONS !! strin input string to trim leading and trailing space characters from !! !!##RETURNS !! strout clipped version of input string !! !!##EXAMPLE !! !! Sample program: !! !! program demo_clip !! use M_strings, only: clip !! implicit none !! character(len=20) :: untrimmed = ' ABCDEFG abcdefg ' !! write(*,*) 'untrimmed string=[',untrimmed,']' !! write(*,*) 'clipped string=[',clip(untrimmed),']' !! end program demo_clip !! !! Expected output !! !! untrimmed string=[ ABCDEFG abcdefg ] !! clipped string=[ABCDEFG abcdefg] !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain function clip(string) result(lopped) ! ident_17="@(#) M_strings clip(3f) trim leading and trailings spaces from resulting string" logical,parameter :: T=.true.,F=.false. character(len=*),intent(in) :: string character(len=:),allocatable :: lopped integer :: ends(2) ends=verify( string, " ", [F,T] ) if(ends(1) == 0)then lopped="" else lopped=string(ends(1):ends(2)) endif end function clip !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! transliterate(3f) - [M_strings:EDITING] replace characters from old !! set with new set !! (LICENSE:PD) !! !!##SYNOPSIS !! !! pure function transliterate(instr,old_set,new_set) result(outstr) !! !! character(len=*),intent(in) :: instr !! character(len=*),intent(in) :: old_set !! character(len=*),intent(in) :: new_set !! character(len=len(instr)) :: outstr !! !!##DESCRIPTION !! Translate, squeeze, and/or delete characters from the input string. !! !!##OPTIONS !! instr input string to change !! old_set list of letters to change in INSTR if found !! !! Each character in the input string that matches a character !! in the old set is replaced. !! !! new_set list of letters to replace letters in OLD_SET with. !! !! If the new_set is the empty set the matched characters !! are deleted. !! !! If the new_set is shorter than the old set the last character !! in the new set is used to replace the remaining characters !! in the new set. !! !!##RETURNS !! outstr instr with substitutions applied !! !!##EXAMPLES !! !! Sample Program: !! !! program demo_transliterate !! !! use M_strings, only : transliterate !! implicit none !! character(len=80) :: STRING !! !! STRING='aAbBcCdDeEfFgGhHiIjJkKlLmMnNoOpPqQrRsStTuUvVwWxXyYzZ' !! write(*,'(a)') STRING !! !! ! convert a string to uppercase: !! write(*,*) TRANSLITERATE(STRING, & !! & 'abcdefghijklmnopqrstuvwxyz','ABCDEFGHIJKLMNOPQRSTUVWXYZ') !! !! ! change all miniscule letters to a colon (":"): !! write(*,*) TRANSLITERATE(STRING, & !! & 'abcdefghijklmnopqrstuvwxyz',':') !! !! ! delete all miniscule letters !! write(*,*) TRANSLITERATE(STRING, & !! & 'abcdefghijklmnopqrstuvwxyz','') !! !! end program demo_transliterate !! !! Expected output !! !! > aAbBcCdDeEfFgGhHiIjJkKlLmMnNoOpPqQrRsStTuUvVwWxXyYzZ !! > AABBCCDDEEFFGGHHIIJJKKLLMMNNOOPPQQRRSSTTUUVVWWXXYYZZ !! > :A:B:C:D:E:F:G:H:I:J:K:L:M:N:O:P:Q:R:S:T:U:V:W:X:Y:Z !! > ABCDEFGHIJKLMNOPQRSTUVWXYZ !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain PURE FUNCTION transliterate(instr,old_set,new_set) RESULT(outstr) ! ident_18="@(#) M_strings transliterate(3f) replace characters from old set with new set" !----------------------------------------------------------------------------------------------------------------------------------- CHARACTER(LEN=*),INTENT(IN) :: instr ! input string to change CHARACTER(LEN=*),intent(in) :: old_set CHARACTER(LEN=*),intent(in) :: new_set !----------------------------------------------------------------------------------------------------------------------------------- CHARACTER(LEN=LEN(instr)) :: outstr ! output string to generate !----------------------------------------------------------------------------------------------------------------------------------- INTEGER :: i10 ! loop counter for stepping thru string INTEGER :: ii,jj !----------------------------------------------------------------------------------------------------------------------------------- jj=LEN(new_set) IF(jj /= 0)THEN outstr=instr ! initially assume output string equals input string stepthru: DO i10 = 1, LEN(instr) ii=iNDEX(old_set,instr(i10:i10)) ! see if current character is in old_set IF (ii /= 0)THEN if(ii <= jj)then ! use corresponding character in new_set outstr(i10:i10) = new_set(ii:ii) else outstr(i10:i10) = new_set(jj:jj) ! new_set not as long as old_set; use last character in new_set endif ENDIF ENDDO stepthru else ! new_set is null string so delete characters in old_set outstr=' ' hopthru: DO i10 = 1, LEN(instr) ii=iNDEX(old_set,instr(i10:i10)) ! see if current character is in old_set IF (ii == 0)THEN ! only keep characters not in old_set jj=jj+1 outstr(jj:jj) = instr(i10:i10) ENDIF ENDDO hopthru endif END FUNCTION transliterate !==================================================================================================================================! !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !==================================================================================================================================! !> !!##NAME !! rotate13(3f) - [M_strings] apply trivial ROT13 encryption to a string !! (LICENSE:PD) !! !!##SYNOPSIS !! !! rotate13(input) result(output) !! !! character(len=*),intent(in) :: input !! character(len=len(input)) :: output !! !!##DESCRIPTION !! ROT13 ("rotate by 13 places", sometimes hyphenated ROT-13) is a simple !! letter substitution cipher that replaces a letter with the 13th letter !! after it in the alphabet; wrapping around if necessary. !! !! The transformation can be done using a lookup table, such as the !! following: !! !! Input ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz !! Output NOPQRSTUVWXYZABCDEFGHIJKLMnopqrstuvwxyzabcdefghijklm !! !! ROT13 is used in online forums as a means of hiding spoilers, !! punchlines, puzzle solutions, and offensive materials from the casual !! glance. ROT13 has inspired a variety of letter and word games on-line, !! and is frequently mentioned in newsgroup conversations. !! !! The algorithm provides virtually no cryptographic security, and is !! often cited as a canonical example of weak encryption. !! !! ROT13 is a special case of the Caesar cipher which was developed in !! ancient Rome. !! !! ALGORITHM !! !! Applying ROT13 to a piece of text merely requires examining its !! alphabetic characters and replacing each one by the letter 13 places !! further along in the alphabet, wrapping back to the beginning if !! necessary. A becomes N, B becomes O, and so on up to M, which becomes !! Z, then the sequence continues at the beginning of the alphabet: N !! becomes A, O becomes B, and so on to Z, which becomes M. Only those !! letters which occur in the English alphabet are affected; numbers, !! symbols, whitespace, and all other characters are left unchanged. !! !! SAME ALGORITHM FOR ENCODING AND DECODING !! !! Because there are 26 letters in the English alphabet and 26 = 2 x 13, !! the ROT13 function is its own inverse: so the same action can be used !! for encoding and decoding. In other words, two successive applications !! of ROT13 restore the original text (in mathematics, this is sometimes !! called an involution; in cryptography, a reciprocal cipher). !! !! TRIVIAL SECURITY !! !! The use of a constant shift means that the encryption effectively !! has no key, and decryption requires no more knowledge than the fact !! that ROT13 is in use. Even without this knowledge, the algorithm is !! easily broken through frequency analysis. !! !! In encrypted normal English-language text of any significant size, !! ROT13 is recognizable from some letter/word patterns. The words "n", !! "V" (capitalized only), and "gur" (ROT13 for "a", "I", and "the"), !! and words ending in "yl" ("ly") are examples. !! !!##REFERENCES !! Wikipedia, the free encyclopedia !! !!##EXAMPLE !! !! Sample program !! !! program demo_rotate13 !! use M_strings, only : rotate13 !! implicit none !! character(len=256) :: line !! integer :: ios !! do !! read(*,'(a)',iostat=ios)line !! if(ios /= 0)exit !! write(*,'(a)')rotate13(line) !! enddo !! end program demo_rotate13 !! !! Sample usage: !! !! demo_rotate13 !! United we stand, divided we fall. !! Havgrq jr fgnaq, qvivqrq jr snyy. !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain function rotate13 (input) ! ident_19="@(#) M_strings rotate13(3f) converts a character to its ROT13 equivalent which is a trivial encryption." character(len=*),intent(in) :: input character(len=len(input)) :: rotate13 integer :: itemp integer :: i rotate13=' ' do i=1,len_trim(input) itemp = iachar(input(i:i)) select case(itemp) case(65:77,97:109) itemp = itemp + 13 case(78:90,110:122) itemp = itemp - 13 end select rotate13(i:i) = char ( itemp ) enddo end function rotate13 !==================================================================================================================================! !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !==================================================================================================================================! !> !!##NAME !! join(3f) - [M_strings:EDITING] append CHARACTER variable array into !! a single CHARACTER variable with specified separator !! (LICENSE:PD) !! !!##SYNOPSIS !! !! pure function join(str,sep,trm,left,right,start,end) result (string) !! !! character(len=*),intent(in) :: str(:) !! character(len=*),intent(in),optional :: sep !! logical,intent(in),optional :: trm !! character(len=*),intent(in),optional :: right !! character(len=*),intent(in),optional :: left !! character(len=*),intent(in),optional :: start !! character(len=*),intent(in),optional :: end !! character(len=:),allocatable :: string !! !!##DESCRIPTION !! JOIN(3f) appends the elements of a CHARACTER array into a single !! CHARACTER variable, with elements 1 to N joined from left to right. !! By default each element is trimmed of trailing spaces and the !! default separator is a null string. !! !!##OPTIONS !! STR(:) array of CHARACTER variables to be joined !! SEP separator string to place between each variable. defaults !! to a null string. !! LEFT string to place at left of each element !! RIGHT string to place at right of each element !! START prefix string !! END suffix string !! TRM option to trim each element of STR of trailing !! spaces. Defaults to .TRUE. !! !!##RESULT !! STRING CHARACTER variable composed of all of the elements of STR() !! appended together with the optional separator SEP placed !! between the elements. !! !!##EXAMPLE !! !! Sample program: !! !! program demo_join !! use M_strings, only: join !! implicit none !! character(len=:),allocatable :: s(:) !! character(len=:),allocatable :: out !! integer :: i !! s=[character(len=10) :: 'United',' we',' stand,', & !! & ' divided',' we fall.'] !! out=join(s) !! write(*,'(a)') out !! write(*,'(a)') join(s,trm=.false.) !! write(*,'(a)') (join(s,trm=.false.,sep='|'),i=1,3) !! write(*,'(a)') join(s,sep='<>') !! write(*,'(a)') join(s,sep=';',left='[',right=']') !! write(*,'(a)') join(s,left='[',right=']') !! write(*,'(a)') join(s,left='>>') !! end program demo_join !! !! Expected output: !! !! United we stand, divided we fall. !! United we stand, divided we fall. !! United | we | stand, | divided | we fall. !! United | we | stand, | divided | we fall. !! United | we | stand, | divided | we fall. !! United<> we<> stand,<> divided<> we fall. !! [United];[ we];[ stand,];[ divided];[ we fall.] !! [United][ we][ stand,][ divided][ we fall.] !! >>United>> we>> stand,>> divided>> we fall. !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain pure function join(str,sep,trm,left,right,start,end) result (string) ! ident_20="@(#) M_strings join(3f) merge string array into a single CHARACTER value adding specified separators caps prefix and suffix" character(len=*),intent(in) :: str(:) character(len=*),intent(in),optional :: sep, right, left, start, end logical,intent(in),optional :: trm character(len=:),allocatable :: sep_local, left_local, right_local character(len=:),allocatable :: string logical :: trm_local integer :: i if(present(sep))then ; sep_local=sep ; else ; sep_local='' ; endif if(present(trm))then ; trm_local=trm ; else ; trm_local=.true. ; endif if(present(left))then ; left_local=left ; else ; left_local='' ; endif if(present(right))then ; right_local=right ; else ; right_local='' ; endif string='' if(size(str) == 0)then string=string//left_local//right_local else do i = 1,size(str)-1 if(trm_local)then string=string//left_local//trim(str(i))//right_local//sep_local else string=string//left_local//str(i)//right_local//sep_local endif enddo if(trm_local)then string=string//left_local//trim(str(i))//right_local else string=string//left_local//str(i)//right_local endif endif if(present(start))string=start//string if(present(end))string=string//end end function join !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! reverse(3f) - [M_strings:EDITING] Return a string reversed !! (LICENSE:PD) !! !!##SYNOPSIS !! !! elemental pure function reverse(str) result (string) !! !! character(*), intent(in) :: str !! character(len(str)) :: string !! !!##DESCRIPTION !! reverse(string) returns a copy of the input string with !! all characters reversed from right to left. !! !!##EXAMPLE !! !! Sample program: !! !! program demo_reverse !! use M_strings, only: reverse !! implicit none !! character(len=:),allocatable :: s !! write(*,*)'REVERSE STRINGS:',reverse('Madam, I''m Adam') !! s='abcdefghijklmnopqrstuvwxyz' !! write(*,*) 'original input string is ....',s !! write(*,*) 'reversed output string is ...',reverse(s) !! end program demo_reverse !! !! Results: !! !! > REVERSE STRINGS:madA m'I ,madaM !! > original input string is ....abcdefghijklmnopqrstuvwxyz !! > reversed output string is ...zyxwvutsrqponmlkjihgfedcba !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain elemental function reverse(string) result (rev) ! ident_21="@(#) M_strings reverse(3f) Return a string reversed" character(len=*),intent(in) :: string ! string to reverse character(len=len(string)) :: rev ! return value (reversed string) integer :: length integer :: i length = len(string) do i = 1,length rev(i:i)=string(length-i+1:length-i+1) enddo end function reverse !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! upper_quoted(3f) - [M_strings:CASE] elemental function converts string to !! miniscule skipping strings quoted per Fortran syntax rules !! (LICENSE:PD) !! !!##SYNOPSIS !! !! elemental pure function upper_quoted(str) result (string) !! !! character(*), intent(in) :: str !! character(len(str)) :: string ! output string !! !!##DESCRIPTION !! upper_quoted(string) returns a copy of the input string with all not-quoted !! characters converted to uppercase, assuming ASCII character sets !! are being used. The quoting rules are the same as for Fortran source. !! Either a single or double quote starts a quoted string, and a quote !! character of the same type is doubled when it appears internally in !! the quoted string. If a double quote quotes the string single quotes !! may appear in the quoted string as single characters, and vice-versa !! for single quotes. !! !!##OPTIONS !! str string to convert to uppercase !! !!##RESULTS !! upper copy of the input string with all unquoted characters converted !! to uppercase !! !!##EXAMPLE !! !! Sample program: !! !! program demo_upper_quoted !! use M_strings, only: upper_quoted !! implicit none !! character(len=:),allocatable :: s !! s=' ABCDEFG abcdefg "Double-Quoted" ''Single-Quoted'' "with ""& !! & Quote" everything else' !! write(*,*) 'mixed-case input string is ....',s !! write(*,*) 'upper-case output string is ...',upper_quoted(s) !! write(*,'(1x,a,*(a:,"+"))') 'upper_quoted(3f) is elemental ==>', & !! & upper_quoted(["abc","def","ghi"]) !! end program demo_upper_quoted !! !! Expected output: !! !! mixed-case input string is .... ABCDEFG abcdefg "Double-Quoted" !! 'Single-Quoted' "with "" Quote" everything else !! upper-case output string is ... ABCDEFG ABCDEFG "Double-Quoted" !! 'Single-Quoted' "with "" Quote" EVERYTHING ELSE !! upper_quoted(3f) is elemental ==>ABC+DEF+GHI !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain elemental pure function upper_quoted(str) result (string) ! ident_22="@(#) M_strings upper_quoted(3f) elemental function converts string to miniscule skipping strings quoted per Fortran syntax rules" character(len=*), intent(in) :: str ! The input string character(len=len(str)) :: string ! The output string logical :: toggle character(len=1) :: togglechar integer :: irnk integer :: i character(len=26), parameter :: large="ABCDEFGHIJKLMNOPQRSTUVWXYZ" character(len=26), parameter :: small="abcdefghijklmnopqrstuvwxyz" string=str toggle = .TRUE. do i = 1, len_trim(string) if(toggle) then if(string(i:i) == '"' .or. string(i:i) == "'") then toggle = .not. toggle togglechar = string(i:i) endif irnk = index(small, string(i:i)) if(irnk > 0) then string(i:i) = large(irnk:irnk) endif else if(string(i:i) == togglechar) toggle = .not. toggle endif enddo end function upper_quoted !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! upper(3f) - [M_strings:CASE] changes a string to uppercase !! (LICENSE:PD) !! !!##SYNOPSIS !! !! elemental pure function upper(str,begin,end) result (string) !! !! character(*), intent(in) :: str !! integer,optional,intent(in) :: begin,end !! character(len(str)) :: string ! output string !! !!##DESCRIPTION !! upper(string) returns a copy of the input string with all characters !! converted in the optionally specified range to uppercase, assuming !! ASCII character sets are being used. If no range is specified the !! entire string is converted to uppercase. !! !!##OPTIONS !! str string to convert to uppercase !! begin optional starting position in "str" to begin converting to !! uppercase !! end optional ending position in "str" to stop converting to !! uppercase !! !!##RESULTS !! upper copy of the input string with all characters converted to !! uppercase over optionally specified range. !! !!##TRIVIA !! The terms "uppercase" and "lowercase" date back to the early days of !! the mechanical printing press. Individual metal alloy casts of each !! needed letter, or punctuation symbol, were meticulously added to a !! press block, by hand, before rolling out copies of a page. These !! metal casts were stored and organized in wooden cases. The more !! often needed miniscule letters were placed closer to hand, in the !! lower cases of the work bench. The less often needed, capitalized, !! majuscule letters, ended up in the harder to reach upper cases. !! !!##EXAMPLE !! !! Sample program: !! !! program demo_upper !! use M_strings, only: upper !! implicit none !! character(len=:),allocatable :: s !! s=' ABCDEFG abcdefg ' !! write(*,*) 'mixed-case input string is ....',s !! write(*,*) 'upper-case output string is ...',upper(s) !! write(*,*) 'make first character uppercase ... ',& !! & upper('this is a sentence.',1,1) !! write(*,'(1x,a,*(a:,"+"))') 'UPPER(3f) is elemental ==>',& !! & upper(["abc","def","ghi"]) !! end program demo_upper !! !! Expected output !! !! mixed-case input string is .... ABCDEFG abcdefg !! upper-case output string is ... ABCDEFG ABCDEFG !! make first character uppercase ... This is a sentence. !! UPPER(3f) is elemental ==>ABC+DEF+GHI !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain !=================================================================================================================================== ! Timing ! ! Several different methods have been proposed for changing case. ! A simple program that copies a large file and converts it to ! uppercase was timed and compared to a simple copy. This was used ! to select the default function. ! ! NULL: 83.41user 9.25system 1:37.94elapsed 94%CPU ! upper: 101.44user 10.89system 1:58.36elapsed 94%CPU ! upper2: 105.04user 10.69system 2:04.17elapsed 93%CPU ! upper3: 267.21user 11.69system 4:49.21elapsed 96%CPU elemental pure function upper(str,begin,end) result (string) ! ident_23="@(#) M_strings upper(3f) returns a trimmed uppercase string" character(*), intent(in) :: str ! input string to convert to all uppercase integer, intent(in), optional :: begin,end character(len(str)) :: string ! output string that contains no miniscule letters integer :: i ! loop counter integer :: ibegin,iend integer,parameter :: diff = iachar('A')-iachar('a') string = str ! initialize output string to input string ibegin=1 iend=len_trim(str) if (present(begin))then ibegin = min(max(ibegin,begin),iend) endif if (present(end))then iend= max(1,min(iend,end)) endif do concurrent (i = ibegin:iend) ! step thru each letter in the string in specified range select case (str(i:i)) case ('a':'z') ! located miniscule letter string(i:i) = achar(iachar(str(i:i))+diff) ! change miniscule letter to majascule end select enddo end function upper !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! lower(3f) - [M_strings:CASE] changes a string to lowercase over !! specified range !! (LICENSE:PD) !! !!##SYNOPSIS !! !! elemental pure function lower(str,begin,end) result (string) !! !! character(*), intent(in) :: str !! integer,optional :: begin, end !! character(len(str)) :: string ! output string !! !!##DESCRIPTION !! lower(string) returns a copy of the input string with all characters !! converted to miniscule over the specified range, assuming ASCII !! character sets are being used. If no range is specified the entire !! string is converted to miniscule. !! !!##OPTIONS !! str string to convert to miniscule !! begin optional starting position in "str" to begin converting to !! miniscule !! end optional ending position in "str" to stop converting to !! miniscule !! !!##RESULTS !! lower copy of the input string with all characters converted to !! miniscule over optionally specified range. !! !!##TRIVIA !! The terms "uppercase" and "lowercase" date back to the early days of !! the mechanical printing press. Individual metal alloy casts of each !! needed letter, or punctuation symbol, were meticulously added to a !! press block, by hand, before rolling out copies of a page. These !! metal casts were stored and organized in wooden cases. The more !! often needed miniscule letters were placed closer to hand, in the !! lower cases of the work bench. The less often needed, capitalized, !! majuscule letters, ended up in the harder to reach upper cases. !! !!##EXAMPLE !! !! Sample program: !! !! program demo_lower !! use M_strings, only: lower !! implicit none !! character(len=:),allocatable :: s !! s=' ABCDEFG abcdefg ' !! write(*,*) 'mixed-case input string is ....',s !! write(*,*) 'lower-case output string is ...',lower(s) !! end program demo_lower !! !! Expected output !! !! mixed-case input string is .... ABCDEFG abcdefg !! lower-case output string is ... abcdefg abcdefg !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain elemental pure function lower(str,begin,end) result (string) ! ident_24="@(#) M_strings lower(3f) Changes a string to lowercase over specified range" character(*), intent(in) :: str character(len(str)) :: string integer,intent(in),optional :: begin, end integer :: i integer :: ibegin, iend integer,parameter :: diff = iachar('A')-iachar('a') string = str ibegin=1 iend=len_trim(str) if (present(begin))then ibegin = min(max(1,begin),iend) endif if (present(end))then iend= max(1,min(iend,end)) endif do concurrent (i = ibegin:iend) ! step thru each letter in the string in specified range select case (str(i:i)) case ('A':'Z') string(i:i) = achar(iachar(str(i:i))-diff) ! change letter to miniscule case default end select enddo end function lower !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! !! switch(3f) - [M_strings:ARRAY] converts between CHARACTER scalar and !! array of single characters !! (LICENSE:PD) !! !!##SYNOPSIS !! !! pure function switch(array) result (string) !! !! character(len=1),intent(in) :: array(:) !! character(len=SIZE(array)) :: string !! !! or !! !! pure function switch(string) result (array) !! !! character(len=1),intent(in) :: array(:) !! character(len=SIZE(array)) :: string !! !!##DESCRIPTION !! SWITCH(3f): generic function that switches CHARACTER string to an array !! of single characters or an array of single characters to a CHARACTER !! string. Useful in passing strings to C. New Fortran features may !! supersede these routines. !! !!##EXAMPLES !! !! Sample program: !! !! program demo_switch !! use M_strings, only : switch, isalpha, islower, nospace !! character(len=*),parameter :: & !! & dashes='-----------------------------------' !! character(len=*),parameter :: string='This is a string' !! character(len=1024) :: line !! !! ! First, examples of standard Fortran features !! ! returns array [F,T,T,T,T,T] !! write(*,*)['A','=','=','=','=','='] == '=' !! ! this would return T !! write(*,*)all(['=','=','=','=','=','='] == '=') !! ! this would return F !! write(*,*)all(['A','=','=','=','=','='] == '=') !! !! ! so to test if the string DASHES is all dashes !! ! using SWITCH(3f) is !! if(all(switch(dashes) == '-'))then !! write(*,*)'DASHES is all dashes' !! endif !! !! ! so to test is a string is all letters !! ! isalpha(3f) returns .true. only if character is a letter !! ! false because dashes are not a letter !! write(*,*) all(isalpha(switch(dashes))) !! ! false because of spaces !! write(*,*) all(isalpha(switch(string))) !! ! true because removed whitespace !! write(*,*) all(isalpha(switch(nospace(string)))) !! !! ! to see if a string is all uppercase !! ! show the string !! write(*,*) string !! ! converted to character array !! write(*,'(1x,*("[",a,"]":))') switch(string) !! write(*,'(*(l3))') islower(switch(string)) !! !! ! we need a string that is all letters !! line=nospace(string) !! write(*,*)'LINE=',trim(line) !! ! all true except first character !! write(*,*) islower(switch(nospace(string))) !! ! should be false !! write(*,*) all(islower(switch(nospace(string)))) !! ! should be true !! write(*,*) all(islower(switch(nospace(string(2:))))) !! !! end program demo_switch !! !! Expected output !! !! F T T T T T !! T !! F !! DASHES is all dashes !! F !! F !! T !! This is a string !! [T][h][i][s][ ][i][s][ ][a][ ][s][t][r][i][n][g] !! F T T T F T T F T F T T T T T T !! LINE=Thisisastring !! F T T T T T T T T T T T T !! F !! T !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain pure function a2s(array) result (string) ! ident_25="@(#) M_strings a2s(3fp) function to copy char array to string" character(len=1),intent(in) :: array(:) character(len=SIZE(array)) :: string integer :: i ! ---------------------------------------------------------------------------------------------------------------------------------- forall( i = 1:size(array)) string(i:i) = array(i) ! ---------------------------------------------------------------------------------------------------------------------------------- ! string=transfer(array,string) end function a2s !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== pure function s2a(string) RESULT (array) ! ident_26="@(#) M_strings s2a(3fp) function to copy string(1 Clen(string)) to char array" character(len=*),intent(in) :: string character(len=1) :: array(len(string)) integer :: i ! ---------------------------------------------------------------------------------------------------------------------------------- forall(i=1:len(string)) array(i) = string(i:i) ! ---------------------------------------------------------------------------------------------------------------------------------- ! array=transfer(string,array) end function s2a !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! s2c(3f) - [M_strings:ARRAY] convert character variable to array of !! characters with last element set to null !! (LICENSE:PD) !! !!##SYNOPSIS !! !! function s2c(string) !! !! character(len=*),intent=(in) :: string !! character(len=1),allocatable :: s2c(:) !! !!##DESCRIPTION !! Given a character variable convert it to an array of single-character !! character variables with the last element set to a null character. !! This is generally used to pass character variables to C procedures. !! !!##EXAMPLES !! !! Sample Program: !! !! program demo_s2c !! use M_strings, only : s2c !! implicit none !! character(len=*),parameter :: string="single string" !! character(len=3),allocatable :: array(:) !! write(*,*)'INPUT STRING ',trim(string) !! ! put one character into each 3-character element of array !! array=s2c(string) !! ! write array with ASCII Decimal Equivalent below it except show !! ! unprintable characters like NULL as "XXX" !! write(*,'(1x,*("[",a3,"]":))')& !! & merge('XXX',array,iachar(array(:)(1:1)) < 32) !! write(*,'(1x,*("[",i3,"]":))')& !! & iachar(array(:)(1:1)) !! end program demo_s2c !! !! Expected output: !! !! INPUT STRING single string !! [s ][i ][n ][g ][l ][e ][ ][s ][t ][r ][i ][n ][g ][XXX] !! [115][105][110][103][108][101][ 32][115][116][114][105][110][103][ 0] !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain pure function s2c(string) RESULT (array) use,intrinsic :: ISO_C_BINDING, only : C_CHAR ! ident_27="@(#) M_strings s2c(3f) copy string(1 Clen(string)) to char array with null terminator" character(len=*),intent(in) :: string ! This is changing, but currently the most portable way to pass a CHARACTER variable to C is to convert it to an array of ! character variables with length one and add a null character to the end of the array. The s2c(3f) function helps do this. character(kind=C_CHAR,len=1) :: array(len_trim(string)+1) integer :: i do i = 1,size(array)-1 array(i) = string(i:i) enddo array(size(array):)=achar(0) end function s2c !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! c2s(3f) - [M_strings:ARRAY] convert C string pointer to Fortran !! character string !! (LICENSE:PD) !! !!##SYNOPSIS !! !! function c2s(c_string_pointer) result(f_string) !! !! type(c_ptr), intent(in) :: c_string_pointer !! character(len=:), allocatable :: f_string !! !!##DESCRIPTION !! Given a C pointer to a character string return a Fortran character !! string. !! !!##OPTIONS !! c_string_pointer C pointer to convert !! !!##RETURNS !! f_string Fortran character variable to return !! !!##EXAMPLE !! !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain function c2s(c_string_pointer) result(f_string) ! gets a C string (pointer), and returns the corresponding Fortran string; ! If the C string is null, it returns "NULL", similar to C's "(null)" printed in similar cases: use, intrinsic :: iso_c_binding, only: c_ptr,c_f_pointer,c_char,c_null_char ! ident_28="@(#) M_strings c2s(3f) copy pointer to C char array till a null is encountered to a Fortran string up to 4096 characters" integer,parameter :: max_length=4096 type(c_ptr), intent(in) :: c_string_pointer character(len=:), allocatable :: f_string character(kind=c_char), dimension(:), pointer :: char_array_pointer => null() character(len=max_length) :: aux_string integer :: i,length=0 call c_f_pointer(c_string_pointer,char_array_pointer,[max_length]) if (.not.associated(char_array_pointer)) then allocate(character(len=4)::f_string) f_string="NULL" return endif aux_string=" " do i=1,max_length if (char_array_pointer(i)==c_null_char) then length=i-1 exit endif aux_string(i:i)=char_array_pointer(i) enddo allocate(character(len=length)::f_string) f_string=aux_string(1:length) end function c2s !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! indent(3f) - [M_strings:WHITESPACE] count number of leading spaces !! in a string !! (LICENSE:PD) !! !!##SYNOPSIS !! !! function indent(line) !! !! integer :: indent !! character(len=*),intent(in) :: line !! !!##DESCRIPTION !! Count number of leading spaces in a CHARACTER variable. !! !!##EXAMPLES !! !! Sample Program: !! !! program demo_indent !! ! test filter to count leading spaces in a character variable !! ! might want to call notabs(3f) to expand tab characters !! use M_strings, only : indent !! implicit none !! character(len=1024) :: in !! integer :: ios !! READFILE: do !! read(*,'(A)',iostat=ios)in !! if(ios /= 0) exit READFILE !! write(*,'(i3,"",a)')indent(in),trim(in) !! enddo READFILE !! end program demo_indent !! !! Results: !! !! 3 a b c !! 0a b c !! 6 a b c !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain function indent(line) ! ident_29="@(#) M_strings indent(3f) find number of leading spaces in a string" integer :: indent character(len=*),intent(in) :: line integer :: i indent=0 NOTSPACE: block SCAN: do i=1,len(line) if(line(i:i) /= ' ')then indent=i-1 exit NOTSPACE endif enddo SCAN indent=len(line) endblock NOTSPACE end function indent !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! visible(3f) - [M_strings:NONALPHA] expand a string to control and !! meta-control representations !! (LICENSE:PD) !! !!##SYNOPSIS !! !! function visible(input) result(output) !! !! character(len=*),intent(in) :: input !! character(len=:),allocatable :: output !! !!##DESCRIPTION !! visible(3f) expands characters to commonly used sequences used !! to represent the characters as control sequences or meta-control !! sequences. !! !!##EXAMPLES !! !! Sample Program: !! !! program demo_visible !! use M_strings, only : visible !! integer :: i !! do i=0,255 !! write(*,'(i0,1x,a)')i,visible(char(i)) !! enddo !! end program demo_visible !!##BUGS !! The expansion is not reversible, as input sequences such as "M-" or !! "^a" will look like expanded sequences. !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain function visible(input) result(output) character(len=*),intent(in) :: input character(len=:),allocatable :: output ! ident_30="@(#) M_strings visible(3f) expand escape sequences in a string to control and meta-control representations" integer :: i character(len=1) :: c character(len=*),parameter :: chars(0:255)= [ & '^@ ', '^A ', '^B ', '^C ', '^D ', '^E ', '^F ', '^G ', '^H ', '^I ', & '^J ', '^K ', '^L ', '^M ', '^N ', '^O ', '^P ', '^Q ', '^R ', '^S ', & '^T ', '^U ', '^V ', '^W ', '^X ', '^Y ', '^Z ', '^[ ', '^\ ', '^] ', & '^^ ', '^_ ', ' ', '! ', '" ', '# ', '$ ', '% ', '& ', ''' ', & '( ', ') ', '* ', '+ ', ', ', '- ', '. ', '/ ', '0 ', '1 ', & '2 ', '3 ', '4 ', '5 ', '6 ', '7 ', '8 ', '9 ', ': ', '; ', & '< ', '= ', '> ', '? ', '@ ', 'A ', 'B ', 'C ', 'D ', 'E ', & 'F ', 'G ', 'H ', 'I ', 'J ', 'K ', 'L ', 'M ', 'N ', 'O ', & 'P ', 'Q ', 'R ', 'S ', 'T ', 'U ', 'V ', 'W ', 'X ', 'Y ', & 'Z ', '[ ', '\ ', '] ', '^ ', '_ ', '` ', 'a ', 'b ', 'c ', & 'd ', 'e ', 'f ', 'g ', 'h ', 'i ', 'j ', 'k ', 'l ', 'm ', & 'n ', 'o ', 'p ', 'q ', 'r ', 's ', 't ', 'u ', 'v ', 'w ', & 'x ', 'y ', 'z ', '{ ', '| ', '} ', '~ ', '^? ', 'M-^@', 'M-^A', & 'M-^B', 'M-^C', 'M-^D', 'M-^E', 'M-^F', 'M-^G', 'M-^H', 'M-^I', 'M-^J', 'M-^K', & 'M-^L', 'M-^M', 'M-^N', 'M-^O', 'M-^P', 'M-^Q', 'M-^R', 'M-^S', 'M-^T', 'M-^U', & 'M-^V', 'M-^W', 'M-^X', 'M-^Y', 'M-^Z', 'M-^[', 'M-^\', 'M-^]', 'M-^^', 'M-^_', & 'M- ', 'M-! ', 'M-" ', 'M-# ', 'M-$ ', 'M-% ', 'M-& ', 'M-'' ', 'M-( ', 'M-) ', & 'M-* ', 'M-+ ', 'M-, ', 'M-- ', 'M-. ', 'M-/ ', 'M-0 ', 'M-1 ', 'M-2 ', 'M-3 ', & 'M-4 ', 'M-5 ', 'M-6 ', 'M-7 ', 'M-8 ', 'M-9 ', 'M-: ', 'M-; ', 'M-< ', 'M-= ', & 'M-> ', 'M-? ', 'M-@ ', 'M-A ', 'M-B ', 'M-C ', 'M-D ', 'M-E ', 'M-F ', 'M-G ', & 'M-H ', 'M-I ', 'M-J ', 'M-K ', 'M-L ', 'M-M ', 'M-N ', 'M-O ', 'M-P ', 'M-Q ', & 'M-R ', 'M-S ', 'M-T ', 'M-U ', 'M-V ', 'M-W ', 'M-X ', 'M-Y ', 'M-Z ', 'M-[ ', & 'M-\ ', 'M-] ', 'M-^ ', 'M-_ ', 'M-` ', 'M-a ', 'M-b ', 'M-c ', 'M-d ', 'M-e ', & 'M-f ', 'M-g ', 'M-h ', 'M-i ', 'M-j ', 'M-k ', 'M-l ', 'M-m ', 'M-n ', 'M-o ', & 'M-p ', 'M-q ', 'M-r ', 'M-s ', 'M-t ', 'M-u ', 'M-v ', 'M-w ', 'M-x ', 'M-y ', & 'M-z ', 'M-{ ', 'M-| ', 'M-} ', 'M-~ ', 'M-^?'] output='' do i=1,len(input) c=input(i:i) if(c == ' ')then output=output//' ' else output=output//trim(chars(iachar(c))) endif enddo end function visible !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! expand(3f) - [M_strings:NONALPHA] expand C-like escape sequences !! (LICENSE:PD) !! !!##SYNOPSIS !! !! function expand(line,escape) result(lineout) !! !! character(len=*) :: line !! character(len=1),intent(in),optional :: escape !! character(len=:),allocatable :: lineout !! !!##DESCRIPTION !! EXPAND() expands sequences used to represent commonly used escape !! sequences or control characters. By default ... !! !! Escape sequences !! \ backslash !! a alert (BEL) -- g is an alias for a !! b backspace !! c suppress further output !! e escape !! f form feed !! n new line !! r carriage return !! t horizontal tab !! v vertical tab !! oNNN byte with octal value NNN (3 digits) !! dNNN byte with decimal value NNN (3 digits) !! xHH byte with hexadecimal value HH (2 digits) -- h is an alias for x !! !! The default escape character is the backslash, but this may be !! changed using the optional parameter ESCAPE. !! !!##EXAMPLES !! !! Sample Program: !! !! program demo_expand !! ! test filter to expand escape sequences in input lines !! use M_strings, only : expand !! character(len=1024) :: line !! integer :: ios !! READFILE: block !! do !! read(*,'(A)',iostat=ios)line !! if(ios /= 0) exit READFILE !! write(*,'(a)')trim(expand(line)) !! enddo !! endblock READFILE !! end program demo_expand !! !! Sample input: !! !! \e[2J !! \tABC\tabc !! \tA\a !! \nONE\nTWO\nTHREE !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain function expand(line,escape) result(lineout) !x!USE ISO_C_BINDING ,ONLY: c_horizontal_tab ! ident_31="@(#) M_strings expand(3f) return string with escape sequences expanded" character(len=*),parameter :: c_horizontal_tab=char(9) character(len=*),intent(in) :: line character(len=1),intent(in),optional :: escape ! escape character. Default is backslash ! expand escape sequences found in input string ! Escape sequences ! %% escape character %a alert (BEL) -- gi is an alias for a ! %b backspace %c suppress further output ! %e escape %E escape ! %f form feed %n new line ! %r carriage return %t horizontal tab ! %v vertical tab ! %oNNN byte with octal value NNN (3 digits) ! %dNNN byte with decimal value NNN (3 digits) ! %xHH byte with hexadecimal value HH (2 digits) -- h is an alias for x character(len=1) :: esc ! escape character. Default is % character(len=:),allocatable :: lineout integer :: i integer :: lgth character(len=3) :: thr integer :: xxx integer :: ios i=0 ! pointer into input lgth=len_trim(line) lineout='' if(lgth == 0)return if (present(escape))then esc=escape else esc=char(92) endif EXP: do i=i+1 if(i > lgth)exit if(line(i:i) == esc)then i=i+1 if(i > lgth)exit if(line(i:i) /= esc)then BACKSLASH: select case(line(i:i)) case('a','A','g','G');lineout=lineout//char( 7) ! %a alert (BEL) case('b','B');lineout=lineout//char( 8) ! %b backspace case('c','C');exit EXP ! %c suppress further output case('d','D') ! %d Dnnn decimal value thr=line(i+1:) read(thr,'(i3)',iostat=ios)xxx lineout=lineout//char(xxx) i=i+3 case('e','E');lineout=lineout//char( 27) ! %e escape case('f','F');lineout=lineout//char( 12) ! %f form feed case('n','N');lineout=lineout//char( 10) ! %n new line !case('n','N');lineout=lineout//new_line('A') ! %n new line case('o','O') thr=line(i+1:) read(thr,'(o3)',iostat=ios)xxx lineout=lineout//char(xxx) i=i+3 case('r','R');lineout=lineout//char( 13) ! %r carriage return case('t','T');lineout=lineout//c_horizontal_tab ! %t horizontal tab case('v','V');lineout=lineout//char( 11) ! %v vertical tab case('x','X','h','H') ! %x xHH byte with hexadecimal value HH (1 to 2 digits) thr=line(i+1:) read(thr,'(z2)',iostat=ios)xxx lineout=lineout//char(xxx) i=i+2 end select BACKSLASH else lineout=lineout//esc ! escape character, defaults to backslash endif else lineout=lineout//line(i:i) endif if(i >= lgth)exit EXP enddo EXP end function expand !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! notabs(3f) - [M_strings:NONALPHA] expand tab characters !! (LICENSE:PD) !! !!##SYNOPSIS !! !! subroutine notabs(INSTR,OUTSTR,lgth) !! !! character(len=*),intent=(in) :: INSTR !! character(len=*),intent=(out) :: OUTSTR !! integer,intent=(out) :: lgth !! !!##DESCRIPTION !! NOTABS() converts tabs in INSTR to spaces in OUTSTR while maintaining !! columns. It assumes a tab is set every 8 characters. Trailing spaces !! are removed. !! !! In addition, trailing carriage returns and line feeds are removed !! (they are usually a problem created by going to and from MSWindows). !! !! What are some reasons for removing tab characters from an input line? !! Some Fortran compilers have problems with tabs, as tabs are not !! part of the Fortran character set. Some editors and printers will !! have problems with tabs. It is often useful to expand tabs in input !! files to simplify further processing such as tokenizing an input line. !! !!##OPTIONS !! instr Input line to remove tabs from !! !!##RESULTS !! outstr Output string with tabs expanded. Assumed to be of sufficient !! length !! lgth Significant length of returned string !! !!##EXAMPLES !! !! Sample program: !! !! program demo_notabs !! !! ! test filter to remove tabs and trailing white space from input !! ! on files up to 1024 characters wide !! use M_strings, only : notabs !! character(len=1024) :: in,out !! integer :: ios,iout !! do !! read(*,'(A)',iostat=ios)in !! if(ios /= 0) exit !! call notabs(in,out,iout) !! write(*,'(a)')out(:iout) !! enddo !! end program demo_notabs !! !!##SEE ALSO !! GNU/Unix commands expand(1) and unexpand(1) !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain elemental impure subroutine notabs(instr,outstr,lgth) ! ident_32="@(#) M_strings notabs(3f) convert tabs to spaces while maintaining columns remove CRLF chars" character(len=*),intent(in) :: instr ! input line to scan for tab characters character(len=*),intent(out) :: outstr ! tab-expanded version of INSTR produced integer,intent(out) :: lgth ! column position of last character put into output string ! that is, lgth holds the position of the last non-blank character in OUTSTR !=================================================================================================================================== integer,parameter :: tabsize=8 ! assume a tab stop is set every 8th column integer :: ipos ! position in OUTSTR to put next character of INSTR integer :: lenin ! length of input string trimmed of trailing spaces integer :: lenout ! number of characters output string can hold integer :: istep ! counter that advances thru input string INSTR one character at a time character(len=1) :: c ! character in input line being processed integer :: iade ! ADE (ASCII Decimal Equivalent) of character being tested !=================================================================================================================================== ipos=1 ! where to put next character in output string OUTSTR lenin=len_trim(instr( 1:len(instr) )) ! length of INSTR trimmed of trailing spaces lenout=len(outstr) ! number of characters output string OUTSTR can hold outstr=" " ! this SHOULD blank-fill string, a buggy machine required a loop to set all characters !=================================================================================================================================== SCAN_LINE: do istep=1,lenin ! look through input string one character at a time c=instr(istep:istep) ! get next character iade=iachar(c) ! get ADE of the character EXPAND_TABS : select case (iade) ! take different actions depending on which character was found case(9) ! test if character is a tab and move pointer out to appropriate column ipos = ipos + (tabsize - (mod(ipos-1,tabsize))) case(10,13) ! convert carriage-return and new-line to space ,typically to handle DOS-format files ipos=ipos+1 case default ! c is anything else other than a tab,newline,or return insert it in output string if(ipos > lenout)then call journal("*notabs* output string overflow") exit else outstr(ipos:ipos)=c ipos=ipos+1 endif end select EXPAND_TABS enddo SCAN_LINE !=================================================================================================================================== ipos=min(ipos,lenout) ! tabs or newline or return characters or last character might have gone too far lgth=len_trim(outstr(:ipos)) ! trim trailing spaces !=================================================================================================================================== end subroutine notabs !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! dilate(3f) - [M_strings:NONALPHA] expand tab characters !! (LICENSE:PD) !! !!##SYNOPSIS !! !! function dilate(INSTR) result(OUTSTR) !! !! character(len=*),intent=(in) :: INSTR !! character(len=:),allocatable :: OUTSTR !! !!##DESCRIPTION !! dilate() converts tabs in INSTR to spaces in OUTSTR. It assumes a !! tab is set every 8 characters. Trailing spaces are removed. !! !! In addition, trailing carriage returns and line feeds are removed !! (they are usually a problem created by going to and from MSWindows). !! !!##OPTIONS !! instr Input line to remove tabs from !! !!##RESULTS !! outstr Output string with tabs expanded. !! !!##EXAMPLES !! !! Sample program: !! !! program demo_dilate !! !! ! test filter to remove tabs and trailing white space from input !! ! on files up to 1024 characters wide !! use M_strings, only : dilate !! implicit none !! character(len=:),allocatable :: in !! integer :: i !! in=' this is my string ' !! ! change spaces to tabs to make a sample input !! do i=1,len(in) !! if(in(i:i) == ' ')in(i:i)=char(9) !! enddo !! write(*,'(a)')in,dilate(in) !! end program demo_dilate !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain function dilate(INSTR) result(OUTSTR) ! ident_33="@(#) M_strings dilate(3f) convert tabs to spaces and trims line removing CRLF chars" CHARACTER(LEN=*),INTENT(IN) :: instr ! input line to scan for tab characters CHARACTER(LEN=:),allocatable :: outstr ! tab-expanded version of INSTR produced integer :: i integer :: icount integer :: lgth icount=0 do i=1,len(instr) if(instr(i:i) == char(9))icount=icount+1 enddo allocate(character(len=(len(instr)+8*icount)) :: outstr) call notabs(instr,outstr,lgth) outstr=outstr(:lgth) !=================================================================================================================================== END function dilate !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! adjustc(3f) - [M_strings:WHITESPACE] center text !! (LICENSE:PD) !! !!##SYNOPSIS !! !! pure function adjustc(string[,length]) !! !! character(len=*),intent(in) :: string !! integer,intent(in),optional :: length !! character(len=:),allocatable :: adjustc !! !!##DESCRIPTION !! Centers input text in a string of the length specified. Returns a !! string of length LENGTH if LENGTH is present. Otherwise returns a !! string of the length of the input string. !! !!##OPTIONS !! string input string to trim and center !! length line length to center text in, optional. !! !!##RETURNS !! adjustc centered output string !! !!##EXAMPLES !! !! Sample Program: !! !! program demo_adjustc !! use M_strings, only : adjustc !! ! using length of the input string !! write(*,'(a)') '================================' !! write(*,'(a)')adjustc('centered string ') !! write(*,'(a)')adjustc(' centered string') !! write(*,'(a)')adjustc(' centered string ') !! ! using explicit output string length !! write(*,'(a)')repeat('=',50) !! write(*,'(a)')adjustc('this is a centered string',50) !! write(*,'(a)')repeat('=',50) !! end program demo_adjustc !! !! Expected output !! !! ================================ !! centered string !! centered string !! centered string !! ================================================== !! this is a centered string !! ================================================== !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain pure function adjustc(string,length) ! ident_34="@(#) M_strings adjustc(3f) center text" !> !! PROCEDURE adjustc(3f) !! DESCRIPTION center text using implicit or explicit length !!##VERSION 2.0, 20160711 !! AUTHOR John S. Urban !----------------------------------------------------------------------------------------------------------------------------------- character(len=*),intent(in) :: string ! input string to trim and center integer,intent(in),optional :: length ! line length to center text in character(len=:),allocatable :: adjustc ! output string integer :: inlen integer :: ileft ! left edge of string if it is centered !----------------------------------------------------------------------------------------------------------------------------------- if(present(length))then ! optional length inlen=length ! length will be requested length if(inlen <= 0)then ! bad input length inlen=len(string) ! could not use input value, fall back to length of input string endif else ! output length was not explicitly specified, use input string length inlen=len(string) endif allocate(character(len=inlen):: adjustc) ! create output at requested length adjustc(1:inlen)=' ' ! initialize output string to all blanks !----------------------------------------------------------------------------------------------------------------------------------- ileft =(inlen-len_trim(adjustl(string)))/2 ! find starting point to start input string to center it if(ileft > 0)then ! if string will fit centered in output adjustc(ileft+1:inlen)=adjustl(string) ! center the input text in the output string else ! input string will not fit centered in output string adjustc(1:inlen)=adjustl(string) ! copy as much of input to output as can endif end function adjustc !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! nospace(3f) - [M_strings:WHITESPACE] remove all whitespace from !! input string !! (LICENSE:PD) !! !!##SYNOPSIS !! !! function nospace(str) - remove all whitespace from input string !! !! character(len=*),intent(in) :: str !! character(len=:),allocatable :: nospace !! !!##DESCRIPTION !! nospace(3f) removes space, tab, carriage return, new line, vertical !! tab, formfeed and null characters (called "whitespace"). The output !! is returned trimmed. !! !!##EXAMPLES !! !! Sample program: !! !! program demo_nospace !! use M_strings, only: nospace !! implicit none !! character(len=:),allocatable :: s !! s=' This is a test ' !! write(*,*) 'original input string is ....',s !! write(*,*) 'processed output string is ...',nospace(s) !! if(nospace(s) == 'Thisisatest')then !! write(*,*)'nospace test passed' !! else !! write(*,*)'nospace test error' !! endif !! end program demo_nospace !! !! Expected output !! !! original input string is .... This is a test !! processed output string is ...Thisisatest !! nospace test passed !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain function nospace(line) ! ident_35="@(#) M_strings nospace(3f) remove all whitespace from input string" character(len=*),intent(in) :: line ! remove whitespace from this string and return it character(len=:),allocatable :: nospace ! returned string integer :: ipos ! position to place next output character at integer :: i ! counter to increment from beginning to end of input string !----------------------------------------------------------------------------------------------------------------------------------- allocate(nospace,mold=line) ! initially make output line length of input line nospace(:len_trim(nospace))=' ' ipos=0 do i=1,len_trim(line) ! increment from first to last character of the input line if ( isspace( line(i:i) ) ) cycle ! if a blank is encountered skip it ipos=ipos+1 ! increment count of non-blank characters found nospace(ipos:ipos)=line(i:i) ! store non-blank character in output enddo nospace=trim(nospace) ! blank out unpacked part of line end function nospace !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! stretch(3f) - [M_strings:LENGTH] return string padded to at least !! specified length !! (LICENSE:PD) !! !!##SYNOPSIS !! !! function stretch(str,length,pattern,suffix) result(strout) !! !! character(len=*),intent(in) :: str !! integer,intent(in) :: length !! character(len=*)intent(in),optional :: pattern !! character(len=*)intent(in),optional :: suffix !! character(len=:),allocatable :: strout !! !!##DESCRIPTION !! stretch(3f) pads a string with spaces to at least the specified !! length. If the trimmed input string is longer than the requested !! length the original string is returned trimmed of trailing spaces. !! !!##OPTIONS !! str the input string to return trimmed, but then padded to !! the specified length if shorter than length !! length The minimum string length to return !! pattern optional string to use as padding. Defaults to a space. !! suffix optional string to append to output string !! !!##RETURNS !! strout The input string padded to the requested length or !! the trimmed input string if the input string is !! longer than the requested length. !! !!##EXAMPLE !! !! Sample Program: !! !! program demo_stretch !! use M_strings, only : stretch !! implicit none !! character(len=10) :: string='abcdefghij' !! character(len=:),allocatable :: answer !! integer :: i !! answer=stretch(string,5) !! write(*,'("[",a,"]")') answer !! answer=stretch(string,20) !! write(*,'("[",a,"]")') answer !! i=30 !! write(*,*) !! write(*,'(1x,a,i0)') & !! & stretch('CHAPTER 1 : The beginning ',i,'.'), 1 ,& !! & stretch('CHAPTER 2 : The end ',i,'.'), 1234 ,& !! & stretch('APPENDIX ',i,'.'), 1235 !! write(*,*) !! write(*,'(1x,a,i7)') & !! & stretch('CHAPTER 1 : The beginning ',i,'.'), 1 ,& !! & stretch('CHAPTER 2 : The end ',i,'.'), 1234 ,& !! & stretch('APPENDIX ',i,'.'), 1235 !! write(*,*) !! write(*,*) & !! & stretch('CHAPTER 1 : The beginning ',i,suffix=': '), 1 !! write(*,*) & !! & stretch('CHAPTER 2 : The end ',i,suffix=': '),1234 !! write(*,*) & !! & stretch('APPENDIX ',i,suffix=': '), 1235 !! end program demo_stretch !! !! Results: !! !! [abcdefghij] !! [abcdefghij ] !! !! CHAPTER 1 : The beginning ....1 !! CHAPTER 2 : The end ..........1234 !! APPENDIX .....................1235 !! !! CHAPTER 1 : The beginning .... 1 !! CHAPTER 2 : The end .......... 1234 !! APPENDIX ..................... 1235 !! !! CHAPTER 1 : The beginning : 1 !! CHAPTER 2 : The end : 1234 !! APPENDIX : 1235 !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain function stretch(line,length,pattern,suffix) result(strout) ! ident_36="@(#) M_strings stretch(3f) return string padded to at least specified length" character(len=*),intent(in) :: line integer,intent(in) :: length character(len=*),intent(in),optional :: pattern character(len=*),intent(in),optional :: suffix !-!character(len=max(length,len(trim(line)))) :: strout character(len=:),allocatable :: strout if(present(pattern))then strout=pad(line,length,pattern) else strout=pad(line,length) endif if(present(suffix))then strout=strout//suffix endif end function stretch !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! rpad(3f) - [M_strings:LENGTH] convert to a string and pad on the right !! to requested length !! (LICENSE:PD) !! !!##SYNOPSIS !! !! function rpad(valuein,length) result(strout) !! !! class*,intent(in) :: valuein(..) !! integer,intent(in) :: length !! !!##DESCRIPTION !! rpad(3f) converts a scalar intrinsic value to a string and then pads !! it on the right with spaces to at least the specified length. If the !! trimmed input string is longer than the requested length the string !! is returned trimmed of leading and trailing spaces. !! !!##OPTIONS !! str The input may be scalar or a vector. !! the input value to return as a string, padded on the left to !! the specified length if shorter than length. The input may be !! any intrinsic scalar which is converted to a cropped string !! much as if written with list-directed output. !! length The minimum string length to return !! !!##RETURNS !! strout The input string padded to the requested length !! on the right with spaces. !! !!##EXAMPLE !! !! Sample Program: !! !! program demo_rpad !! use M_strings, only : rpad !! implicit none !! write(*,'("[",a,"]")') rpad( 'my string', 20) !! write(*,'("[",a,"]")') rpad( 'my string ', 20) !! write(*,'("[",a,"]")') rpad( ' my string', 20) !! write(*,'("[",a,"]")') rpad( ' my string ', 20) !! write(*,'("[",a,"]")') rpad( valuein=42 , length=7) !! write(*,'("[",a,"]")') rpad( valuein=1.0/9.0 , length=20) !! end program demo_rpad !! !! Results: !! !! > [my string ] !! > [my string ] !! > [my string ] !! > [my string ] !! > [42 ] !! > [0.111111112 ] !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain function rpad_scalar(valuein,length) result(strout) ! ident_37="@(#) M_strings rpad_scalar(3f) return value padded to at least specified length" class(*),intent(in) :: valuein integer,intent(in),optional :: length character(len=:),allocatable :: strout character(len=96) :: line integer :: local_length select type(valuein) type is (integer(kind=int8)); write(line,'(i0)') valuein type is (integer(kind=int16)); write(line,'(i0)') valuein type is (integer(kind=int32)); write(line,'(i0)') valuein type is (integer(kind=int64)); write(line,'(i0)') valuein type is (real(kind=real32)); write(line,'(1pg0)') valuein type is (real(kind=real64)); write(line,'(1pg0)') valuein type is (logical); write(line,'(l1)') valuein type is (complex); write(line,'("(",1pg0,",",1pg0,")")') valuein type is (character(len=*)) if(present(length))then local_length = length else local_length = len(valuein) endif strout = pad(valuein,local_length,' ',clip=.true.) return class default stop '*rpad_scalar* unknown type' end select if(present(length))then strout = pad( line, length, ' ', clip=.true. ) else strout = crop( line ) endif end function rpad_scalar !=================================================================================================================================== function rpad_vector(valuein,length) result(strout) ! ident_38="@(#) M_strings rpad_vector(3f) return strings or arguments converted to string right-padded to at least specified length" class(*),intent(in) :: valuein(:) integer,intent(in),optional :: length character(len=:),allocatable :: strout(:) integer :: i integer :: mxlen if(present(length))then allocate(character(len=length) :: strout(size(valuein) )) do i=1,size(valuein) strout(i)=rpad_scalar(valuein(i),length) enddo else ! doing this twice is a lot of overhead mxlen=0 do i=1,size(valuein) mxlen=max(mxlen, len_trim(rpad_scalar(valuein(i))) ) enddo allocate(character(len=mxlen) :: strout(size(valuein) )) do i=1,size(valuein) strout(i)=rpad_scalar(valuein(i),mxlen) enddo endif end function rpad_vector !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! cpad(3f) - [M_strings:LENGTH] convert to a cropped string and then !! centers the string to specified length !! (LICENSE:PD) !! !!##SYNOPSIS !! !! function cpad(valuein,length) result(strout) !! !! class*,intent(in) :: valuein(..) !! integer,intent(in) :: length !! !!##DESCRIPTION !! cpad(3f) converts a scalar value to a cropped string and then pads !! it with spaces to center it to at least the specified length. If !! the trimmed input is longer than the requested length the string is !! returned trimmed of leading and trailing spaces. !! !!##OPTIONS !! str The input may be scalar or a vector. !! the input value to return as a string, padded with spaces to !! center it at the the specified length if shorter than !! length. The input may be any intrinsic scalar which is !! converted to a cropped string much as if written with !! list-directed output. !! length The minimum string length to return !! !!##RETURNS !! strout The input string center-padded to the requested length !! with spaces. !! !!##EXAMPLE !! !! Sample Program: !! !! program demo_cpad !! use M_strings, only : cpad !! implicit none !! write(*,'("[",a,"]")') cpad( 'my string', 20) !! write(*,'("[",a,"]")') cpad( 'my string ', 20) !! write(*,'("[",a,"]")') cpad( ' my string', 20) !! write(*,'("[",a,"]")') cpad( ' my string ', 20) !! write(*,'("[",a,"]")') cpad( valuein=42 , length=7) !! write(*,'("[",a,"]")') cpad( valuein=1.0/9.0 , length=20) !! end program demo_cpad !! !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain function cpad_scalar(valuein,length) result(strout) ! ident_39="@(#) M_strings cpad_scalar(3f) convert value to string center-padded to at least specified length" class(*),intent(in) :: valuein integer,intent(in),optional :: length character(len=:),allocatable :: strout character(len=96) :: line integer :: local_length select type(valuein) type is (integer(kind=int8)); write( line, '(i0)' ) valuein type is (integer(kind=int16)); write( line, '(i0)' ) valuein type is (integer(kind=int32)); write( line, '(i0)' ) valuein type is (integer(kind=int64)); write( line, '(i0)' ) valuein type is (real(kind=real32)); write( line, '(1pg0)' ) valuein type is (real(kind=real64)); write( line, '(1pg0)' ) valuein type is (logical); write( line, '(l1)' ) valuein type is (complex); write( line, '("(",1pg0,",",1pg0,")")' ) valuein type is (character(len = *)) if(present( length ) )then local_length = length else local_length = len(valuein) endif strout = adjustc( crop(valuein), local_length ) return class default stop '*cpad_scalar* unknown type' end select if(present(length))then strout = adjustc( crop(line), length ) else strout = crop( line ) endif end function cpad_scalar !=================================================================================================================================== function cpad_vector(valuein,length) result(strout) ! ident_40="@(#) M_strings cpad_vector(3f) return strings or arguments converted to string center-padded to at least specified length" class(*),intent(in) :: valuein(:) integer,intent(in),optional :: length character(len=:),allocatable :: strout(:) integer :: i integer :: mxlen if(present(length))then allocate(character(len=length) :: strout(size(valuein) )) do i=1,size(valuein) strout(i)=cpad_scalar(valuein(i),length) enddo else ! doing this twice is a lot of overhead mxlen=0 do i=1,size(valuein) mxlen=max(mxlen, len_trim(cpad_scalar(valuein(i))) ) enddo allocate(character(len=mxlen) :: strout(size(valuein) )) do i=1,size(valuein) strout(i)=cpad_scalar(valuein(i),mxlen) enddo endif end function cpad_vector !=================================================================================================================================== !> !! !!##NAME !! lpad(3f) - [M_strings:LENGTH] convert to a cropped string and then !! blank-pad on the left to requested length !! (LICENSE:PD) !! !!##SYNOPSIS !! !! function lpad(valuein,length) result(strout) !! !! class*,intent(in) :: valuein(..) !! integer,intent(in) :: length !! !!##DESCRIPTION !! lpad(3f) converts a scalar value to a cropped string and then pads !! it on the left with spaces to at least the specified length. If !! the trimmed input is longer than the requested length the string is !! returned trimmed of leading and trailing spaces. !! !!##OPTIONS !! str The input may be scalar or a vector. !! the input value to return as a string, padded on the left to !! the specified length if shorter than length. The input may be !! any intrinsic scalar which is converted to a cropped string !! much as if written with list-directed output. !! length The minimum string length to return !! !!##RETURNS !! strout The input string padded to the requested length !! on the left with spaces. !! !!##EXAMPLE !! !! Sample Program: !! !! program demo_lpad !! use M_strings, only : lpad !! implicit none !! write(*,'("[",a,"]")') lpad( 'my string', 20) !! write(*,'("[",a,"]")') lpad( 'my string ', 20) !! write(*,'("[",a,"]")') lpad( ' my string', 20) !! write(*,'("[",a,"]")') lpad( ' my string ', 20) !! write(*,'("[",a,"]")') lpad( valuein=42 , length=7) !! write(*,'("[",a,"]")') lpad( valuein=1.0/9.0 , length=20) !! end program demo_lpad !! !! Results: !! !! > [ my string] !! > [ my string] !! > [ my string] !! > [ my string] !! > [ 42] !! > [ 0.111111112] !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain function lpad_scalar(valuein,length) result(strout) ! ident_41="@(#) M_strings lpad_scalar(3f) convert value to string padded on left to at least specified length" class(*),intent(in) :: valuein integer,intent(in),optional :: length character(len=:),allocatable :: strout character(len=96) :: line integer :: local_length select type(valuein) type is (integer(kind=int8)); write(line,'(i0)') valuein type is (integer(kind=int16)); write(line,'(i0)') valuein type is (integer(kind=int32)); write(line,'(i0)') valuein type is (integer(kind=int64)); write(line,'(i0)') valuein type is (real(kind=real32)); write(line,'(1pg0)') valuein type is (real(kind=real64)); write(line,'(1pg0)') valuein type is (logical); write(line,'(l1)') valuein type is (complex); write(line,'("(",1pg0,",",1pg0,")")') valuein type is (character(len=*)) if(present( length ))then local_length=length else local_length=len( valuein ) endif strout = pad( valuein, local_length, ' ', right=.false., clip=.true. ) return class default stop '*lpad_scalar* unknown type' end select if(present(length))then strout = pad( line, length, ' ', clip=.true., right=.false. ) else strout = crop( line ) endif end function lpad_scalar !=================================================================================================================================== function lpad_vector(valuein,length) result(strout) ! ident_42="@(#) M_strings lpad_vector(3f) return vector of strings or arguments converted to string left-padded to at least specified length" class(*),intent(in) :: valuein(:) integer,intent(in),optional :: length character(len=:),allocatable :: strout(:) integer :: i integer :: mxlen if(present(length))then allocate(character(len=length) :: strout(size(valuein) )) do i=1,size(valuein) strout(i)=lpad_scalar(valuein(i),length) enddo else ! doing this twice is a lot of overhead mxlen=0 do i=1,size(valuein) mxlen=max(mxlen, len_trim(lpad_scalar(valuein(i))) ) enddo allocate(character(len=mxlen) :: strout(size(valuein) )) do i=1,size(valuein) strout(i)=lpad_scalar(valuein(i),mxlen) enddo endif end function lpad_vector !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! zpad(3f) - [M_strings:LENGTH] pad a string on the left with zeros to !! specified length !! (LICENSE:PD) !! !!##SYNOPSIS !! !! function zpad(valuein,length) result(strout) !! !! class*,intent(in) :: valuein(..) !! integer,intent(in),optional :: length !! !!##DESCRIPTION !! zpad(3f) crops the input string or integer (which will be converted !! to a string) and then pads it on the left with zeros to at least !! the specified length. If the trimmed input string is longer than the !! requested length the original string is returned trimmed of leading !! and trailing spaces. !! !! For strings representing unsigned numbers this is basically an alias for !! !! strout=pad(str,length,'0',clip=.true.,right=.false.) !! !! For integers the same is often done with internal WRITE(3f) statements !! such as !! !! write(strout,'(i5.5)')ivalue !! !! but unlike internal I/O the function call can be used in expressions !! or passed as a procedure argument. If the requested length is exceeded !! the returned string is untruncated but cropped of leading and trailing !! spaces. !! !!##OPTIONS !! str May be a scalor or vector string or integer. The input string !! to return trimmed, but then padded to the specified length !! if shorter than length. If an integer is input it is first !! converted to a string. If the leftmost non-blank character !! is a sign character it is moved to the left-most position !! of the output. !! length The minimum string length to return. If not present, the !! length of the input parameter STR is used. If the input value !! STR is not a string no zero padding occurs if LENGTH is not !! supplied. !! !!##RETURNS !! strout The input string padded to the requested length or the trimmed !! input string if the input string is longer than the requested !! length. !! !!##EXAMPLE !! !! Sample Program: !! !! program demo_zpad !! use M_strings, only : zpad !! implicit none !! integer :: lun, i !! write(*,'("[",a,"]")') zpad( '111', 5) !! write(*,'("[",a,"]")') zpad( '123456789', 5) !! write(*,'("[",a,"]")') zpad( ' 34567 ', 7) !! write(*,'("[",a,"]")') zpad( valuein=42 , length=7) !! write(*,'("[",a,"]")') zpad( ' +34567 ', 7) !! write(*,'("[",a,"]")') zpad( ' -34567 ', 7) !! write(*,'("[",a,"]")') zpad(1234) !! write(*,'("[",a,"]")') zpad(-1234) !! write(*,'("[",a,"]")') zpad(1234,8) !! write(*,'("[",a,"]")') zpad(-1234,8) !! write(*,'("[",a,"]")') zpad('') !! write(*,'("[",a,"]")') zpad('0') !! write(*,'("[",a,"]")') zpad('0 ') !! write(*,'("[",a,"]")') zpad(' ') !! write(*,'("[",a,"]")') zpad([1,10,100,1000,10000,100000],8) !! !! ! open output_00085.dat !! i=85 !! open(newunit=lun,file='output_'//zpad(i,5)//'.dat') !! close(unit=lun,status='delete') !! !! end program demo_zpad !! !! Results: !! !! [00111] !! [123456789] !! [0034567] !! [0000042] !! [+0034567] !! [-0034567] !! [1234] !! [-1234] !! [00001234] !! [-00001234] !! [] !! [0] !! [00000] !! [00000] !! [00000001] !! [00000010] !! [00000100] !! [00001000] !! [00010000] !! [00100000] !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain function zpad_scalar(valuein,length) result(strout) ! ident_43="@(#) M_strings zpad_vector(3f) return string or argument converted to string zero-padded to at least specified length" class(*),intent(in) :: valuein integer,intent(in),optional :: length character(len=:),allocatable :: strout character(len=4096) :: line integer :: local_length if(present(length))then local_length=length else local_length=-1 endif select type(valuein) type is (integer(kind=int8)); write(line,'(i0)') valuein type is (integer(kind=int16)); write(line,'(i0)') valuein type is (integer(kind=int32)); write(line,'(i0)') valuein type is (integer(kind=int64)); write(line,'(i0)') valuein type is (real(kind=real32)); write(line,'(1pg0)') valuein type is (real(kind=real64)); write(line,'(1pg0)') valuein type is (logical); write(line,'(l1)') valuein type is (character(len=*)); line=valuein if(local_length==-1)local_length=len(valuein) type is (complex); write(line,'("(",1pg0,",",1pg0,")")') valuein end select if(local_length == -1)then strout=clip(line) else line=clip(line)//' ' if(scan(line(1:1),'+-') == 1)then strout= line(1:1)//pad(line(2:),local_length,'0',clip=.true.,right=.false.) else strout= pad(line,local_length,'0',clip=.true.,right=.false.) endif endif end function zpad_scalar !=================================================================================================================================== function zpad_vector(valuein,length) result(strout) ! ident_44="@(#) M_strings zpad_vector(3f) return vector of strings or arguments converted to string zero-padded to at least specified length" class(*),intent(in) :: valuein(:) integer,intent(in),optional :: length character(len=:),allocatable :: strout(:) integer :: i integer :: mxlen if(present(length))then allocate(character(len=length) :: strout(size(valuein) )) do i=1,size(valuein) strout(i)=zpad_scalar(valuein(i),length) enddo else ! doing this twice is a lot of overhead mxlen=0 do i=1,size(valuein) mxlen=max(mxlen, len_trim(zpad_scalar(valuein(i))) ) enddo allocate(character(len=mxlen) :: strout(size(valuein) )) do i=1,size(valuein) strout(i)=zpad_scalar(valuein(i),mxlen) enddo endif end function zpad_vector !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! pad(3f) - [M_strings:LENGTH] return string padded to at least !! specified length !! (LICENSE:PD) !! !!##SYNOPSIS !! !! !! function pad(str,length,pattern,right,clip) result(strout) !! !! character(len=*) :: str !! integer,intent(in) :: length !! character(len=max(length,len(trim(line)))) :: strout !! character(len=*),intent(in),optional :: pattern !! logical,intent(in),optional :: right !! logical,intent(in),optional :: clip !! !!##DESCRIPTION !! pad(3f) pads a string with a pattern to at least the specified !! length. If the trimmed input string is longer than the requested !! length the trimmed string is returned. !! !!##OPTIONS !! str the input string to return trimmed, but then padded to !! the specified length if shorter than length !! length The minimum string length to return !! pattern optional string to use as padding. Defaults to a space. !! right if true pads string on the right, else on the left !! clip trim spaces from input string but otherwise retain length. !! Except for simple cases you typically would trim the input !! yourself. !! !!##RETURNS !! strout The input string padded to the requested length or !! the trimmed input string if the input string is !! longer than the requested length. !! !!##EXAMPLE !! !! Sample Program: !! !! program demo_pad !! use M_strings, only : pad !! implicit none !! character(len=10) :: string='abcdefghij' !! character(len=:),allocatable :: answer !! integer :: i !! character(len=*),parameter :: g='(*(g0))' !! answer=pad(string,5) !! write(*,'("[",a,"]")') answer !! answer=pad(string,20) !! write(*,'("[",a,"]")') answer !! i=30 !! write(*,g) !! write(*,'(1x,a,1x,i0)') & !! & pad('CHAPTER 1 : The beginning ',i,'.'), 1 , & !! & pad('CHAPTER 2 : The end ',i,'.'), 1234, & !! & pad('APPENDIX ',i,'.'), 1235 !! write(*,*) !! write(*,'(1x,a,i7)') & !! & pad('CHAPTER 1 : The beginning ',i,'.'), 1 , & !! & pad('CHAPTER 2 : The end ',i,'.'), 1234, & !! & pad('APPENDIX ',i,'.'), 1235 !! !! write(*,g)pad('12',5,'0',right=.false.) !! !! write(*,g)pad('12345 ',30,'_',right=.false.) !! write(*,g)pad('12345 ',30,'_',right=.false.,clip=.true.) !! write(*,g)pad('12345 ',7,'_',right=.false.) !! write(*,g)pad('12345 ',7,'_',right=.false.,clip=.true.) !! write(*,g)pad('12345 ',6,'_',right=.false.) !! write(*,g)pad('12345 ',6,'_',right=.false.,clip=.true.) !! write(*,g)pad('12345 ',5,'_',right=.false.) !! write(*,g)pad('12345 ',5,'_',right=.false.,clip=.true.) !! write(*,g)pad('12345 ',4,'_',right=.false.) !! write(*,g)pad('12345 ',4,'_',right=.false.,clip=.true.) !! end program demo_pad !! !! Results: !! !! > [abcdefghij] !! > [abcdefghij ] !! > !! > CHAPTER 1 : The beginning .... 1 !! > CHAPTER 2 : The end .......... 1234 !! > APPENDIX ..................... 1235 !! > !! > CHAPTER 1 : The beginning .... 1 !! > CHAPTER 2 : The end .......... 1234 !! > APPENDIX ..................... 1235 !! > 00012 !! > ________________________12345 !! > _________________________12345 !! > _12345 !! > __12345 !! > 12345 !! > _12345 !! > 12345 !! > 12345 !! > 12345 !! > 12345 !! !!##SEE ALSO !! adjustl(3f), adjustr(3f), repeat(3f), trim(3f), len_trim(3f), len(3f) !! !! adjustc(3f), stretch(3f), lpad(3f), rpad(3f), cpad(3f), zpad(3f), lenset(3f) !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain !=================================================================================================================================== function pad(line,length,pattern,right,clip) result(strout) !$@(#) M_strings::pad(3f): return string padded to at least specified length character(len=*),intent(in) :: line integer,intent(in) :: length character(len=*),intent(in),optional :: pattern logical,optional,intent(in) :: right logical,optional,intent(in) :: clip character(len=:),allocatable :: strout logical :: local_right logical :: local_clip character(len=:),allocatable :: local_pattern character(len=:),allocatable :: local_line if( present(right) )then; local_right=right; else; local_right=.true.; endif if( present(clip) )then; local_clip=clip; else; local_clip=.false.; endif if( present(pattern) )then; local_pattern=pattern; else; local_pattern=' '; endif if(len(local_pattern) == 0)then strout=line else if(local_clip)then local_line=trim(adjustl(line)) allocate(character(len=max(length,len(local_line))) :: strout) else local_line=line allocate(character(len=max(length,len(line))) :: strout) endif if(local_right)then strout(:)=local_line//repeat(local_pattern,len(strout)/len(local_pattern)+1) else strout(:)=repeat(local_pattern, ceiling(real(len(strout))/len(local_pattern))) strout(max(0,len(strout)-len(local_line))+1:)=local_line endif endif end function pad !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! lenset(3f) - [M_strings:LENGTH] return string trimmed or padded to !! specified length !! (LICENSE:PD) !! !!##SYNOPSIS !! !! function lenset(str,length) result(strout) !! !! character(len=*) :: str !! character(len=length) :: strout !! integer,intent(in) :: length !! !!##DESCRIPTION !! lenset(3f) truncates a string or pads it with spaces to the specified !! length. !! !!##OPTIONS !! str input string !! length output string length !! !!##RESULTS !! strout output string !! !!##EXAMPLE !! !! Sample Program: !! !! program demo_lenset !! use M_strings, only : lenset !! implicit none !! character(len=10) :: string='abcdefghij' !! character(len=:),allocatable :: answer !! answer=lenset(string,5) !! write(*,'("[",a,"]")') answer !! answer=lenset(string,20) !! write(*,'("[",a,"]")') answer !! end program demo_lenset !! !! Expected output: !! !! [abcde] !! [abcdefghij ] !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain function lenset(line,length) result(strout) ! ident_45="@(#) M_strings lenset(3f) return string trimmed or padded to specified length" character(len=*),intent(in) :: line integer,intent(in) :: length character(len=length) :: strout strout=line end function lenset !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! merge_str(3f) - [M_strings:LENGTH] pads strings to same length and !! then calls MERGE(3f) !! (LICENSE:PD) !! !!##SYNOPSIS !! !! function merge_str(str1,str2,expr) result(strout) !! !! character(len=*),intent(in),optional :: str1 !! character(len=*),intent(in),optional :: str2 !! logical,intent(in) :: expr !! character(len=:),allocatable :: strout !! !!##DESCRIPTION !! merge_str(3f) pads the shorter of str1 and str2 to the longest length !! of str1 and str2 and then calls MERGE(padded_str1,padded_str2,expr). !! It trims trailing spaces off the result and returns the trimmed !! string. This makes it easier to call MERGE(3f) with strings, as !! MERGE(3f) requires the strings to be the same length. !! !! NOTE: STR1 and STR2 are always required even though declared optional. !! this is so the call "STR_MERGE(A,B,present(A))" is a valid call. !! The parameters STR1 and STR2 when they are optional parameters !! can be passed to a procedure if the options are optional on the !! called procedure. !! !!##OPTIONS !! STR1 string to return if the logical expression EXPR is true !! STR2 string to return if the logical expression EXPR is false !! EXPR logical expression to evaluate to determine whether to return !! STR1 when true, and STR2 when false. !!##RESULT !! MERGE_STR a trimmed string is returned that is otherwise the value !! of STR1 or STR2, depending on the logical expression EXPR. !! !!##EXAMPLES !! !! Sample Program: !! !! program demo_merge_str !! use M_strings, only : merge_str !! implicit none !! character(len=:), allocatable :: answer !! answer=merge_str('first string', & !! & 'second string is longer',10 == 10) !! write(*,'("[",a,"]")') answer !! answer=merge_str('first string', & !! & 'second string is longer',10 /= 10) !! write(*,'("[",a,"]")') answer !! end program demo_merge_str !! !! Expected output !! !! [first string] !! [second string is longer] !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain function merge_str(str1,str2,expr) result(strout) ! for some reason the MERGE(3f) intrinsic requires the strings it compares to be of equal length ! make an alias for MERGE(3f) that makes the lengths the same before doing the comparison by padding the shorter one with spaces ! ident_46="@(#) M_strings merge_str(3f) pads first and second arguments to MERGE(3f) to same length" character(len=*),intent(in),optional :: str1 character(len=*),intent(in),optional :: str2 character(len=:),allocatable :: str1_local character(len=:),allocatable :: str2_local logical,intent(in) :: expr character(len=:),allocatable :: strout integer :: big if(present(str2))then str2_local=str2 else str2_local='' endif if(present(str1))then str1_local=str1 else str1_local='' endif big=max(len(str1_local),len(str2_local)) ! note: perhaps it would be better to warn or fail if an optional value that is not present is returned, instead of returning '' strout=trim(merge(lenset(str1_local,big),lenset(str2_local,big),expr)) end function merge_str !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! squeeze(3f) - [M_strings:EDITING] delete adjacent duplicate occurrences !! of a character from a string !! (LICENSE:PD) !! !!##SYNOPSIS !! !! function squeeze(STR,CHAR) result (OUTSTR) !! !! character(len=*),intent(in) :: STR !! character(len=*),intent(in),optional :: CHAR !! character(len=len(str)) :: OUTSTR !! !!##DESCRIPTION !! squeeze(3f) reduces adjacent duplicates of the specified character !! to a single character !! !!##OPTIONS !! STR input string in which to reduce adjacent duplicate characters !! to a single character !! CHAR The character to remove adjacent duplicates of !! !!##RETURNS !! OUTSTR string with all contiguous adjacent occurrences of CHAR removed !! !!##EXAMPLES !! !! Sample Program: !! !! program demo_squeeze !! use M_strings, only : squeeze !! implicit none !! character(len=:),allocatable :: strings(:) !! !! strings=[ character(len=72) :: & !! &'', & !! &'"If I were two-faced,& !! &would I be wearing this one?" --- Abraham Lincoln', & !! &'..1111111111111111111& !! &111111111111111111111111111111111111111111117777888', & !! &'I never give ''em hell,& !! &I just tell the truth, and they think it''s hell.',& !! &' & !! & --- Harry S Truman' & !! &] !! call printme( trim(strings(1)), ' ' ) !! call printme( strings(2:4), ['-','7','.'] ) !! call printme( strings(5), [' ','-','r'] ) !! contains !! impure elemental subroutine printme(str,chr) !! character(len=*),intent(in) :: str !! character(len=1),intent(in) :: chr !! character(len=:),allocatable :: answer !! write(*,'(a)')repeat('=',11) !! write(*,'("IN: <<<",g0,">>>")')str !! answer=squeeze(str,chr) !! write(*,'("OUT: <<<",g0,">>>")')answer !! write(*,'("LENS: ",*(g0,1x))')"from",len(str),"to",len(answer), & !! & "for a change of",len(str)-len(answer) !! write(*,'("CHAR: ",g0)')chr !! end subroutine printme !! end program demo_squeeze !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain function squeeze(str,charp) result (outstr) character(len=*),intent(in) :: str character(len=1),intent(in) :: charp character(len=:),allocatable :: outstr character(len=1) :: ch, last_one integer :: i, pio ! position in output outstr=repeat(' ',len(str)) ! start with a string big enough to hold any output if(len(outstr)==0)return ! handle edge condition last_one=str(1:1) ! since at least this long start output with first character outstr(1:1)=last_one pio=1 do i=2,len(str) ch=str(i:i) pio=pio+merge(0,1, ch == last_one.and.ch == charp) ! decide whether to advance before saving outstr(pio:pio)=ch ! store new one or overlay the duplcation last_one=ch enddo outstr=outstr(:pio) ! trim the output string to just what was set end function squeeze !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! compact(3f) - [M_strings:WHITESPACE] converts contiguous whitespace !! to a single character (or nothing) !! (LICENSE:PD) !! !!##SYNOPSIS !! !! function compact(STR,CHAR) result (OUTSTR) !! !! character(len=*),intent(in) :: STR !! character(len=*),intent(in),optional :: CHAR !! character(len=len(str)) :: OUTSTR !! !!##DESCRIPTION !! COMPACT(3f) converts multiple spaces, tabs and control characters !! (called "whitespace") to a single character or nothing. Leading !! whitespace is removed. !! !!##OPTIONS !! STR input string to reduce or remove whitespace from !! CHAR By default the character that replaces adjacent !! whitespace is a space. If the optional CHAR parameter is supplied !! it will be used to replace the whitespace. If a null character is !! supplied for CHAR whitespace is removed. !! !!##RETURNS !! OUTSTR string of same length as input string but with all contiguous !! whitespace reduced to a single space and leading whitespace !! removed !! !!##EXAMPLES !! !! Sample Program: !! !! program demo_compact !! use M_strings, only : compact !! implicit none !! ! produces 'This is a test ' !! write(*,*)compact(' This is a test ') !! ! produces 'Thisisatest ' !! write(*,*)compact(' This is a test ',char='') !! ! produces 'This:is:a:test ' !! write(*,*)compact(' This is a test ',char=':') !! ! note CHAR is used to replace the whitespace, but if CHAR is !! ! in the original string it is just copied !! write(*,*)compact('A AA A AAAAA',char='A') !! ! produces (original A characters are left as-is) 'AAAAAAAAAAAA' !! ! not 'A' !! end program demo_compact !! !! Expected output !! !! >This is a test !! >Thisisatest !! >This:is:a:test !! >AAAAAAAAAAAA !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain !elemental pure function compact(str,char) result (outstr) function compact(str,char) result (outstr) ! ident_47="@(#) M_strings compact(3f) Converts white-space to single spaces; removes leading spaces" character(len=*),intent(in) :: str character(len=*),intent(in),optional :: char character(len=len(str)) :: outstr character(len=1) :: ch integer :: i integer :: position_in_output logical :: last_was_space character(len=1) :: char_p logical :: nospace if(present(char))then char_p=char if(len(char) == 0)then nospace=.true. else nospace=.false. endif else char_p=' ' nospace=.false. endif outstr=' ' last_was_space=.false. position_in_output=0 IFSPACE: do i=1,len_trim(str) ch=str(i:i) select case(iachar(ch)) case(0:32,127) ! space or tab character or control character if(position_in_output == 0)then ! still at beginning so ignore leading whitespace cycle IFSPACE elseif(.not.last_was_space) then ! if have not already put out a space output one if(.not.nospace)then position_in_output=position_in_output+1 outstr(position_in_output:position_in_output)=char_p endif endif last_was_space=.true. case(:-1,33:126,128:) ! not a space, quote, or control character so copy it position_in_output=position_in_output+1 outstr(position_in_output:position_in_output)=ch last_was_space=.false. end select enddo IFSPACE end function compact !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! noesc(3f) - [M_strings:NONALPHA] convert non-printable characters !! to a space !! (LICENSE:PD) !! !!##SYNOPSIS !! !! elemental function noesc(INSTR) !! !! character(len=*),intent(in) :: INSTR !! character(len=len(instr)) :: noesc !! !!##DESCRIPTION !! Convert non-printable characters to a space. !! !!##EXAMPLES !! !! Sample Program: !! !! program demo_noesc !! !! use M_strings, only : noesc !! implicit none !! character(len=128) :: ascii !! character(len=128) :: cleared !! integer :: i !! ! fill variable with base ASCII character set !! do i=1,128 !! ascii(i:i)=char(i-1) !! enddo !! cleared=noesc(ascii) !! write(*,*)'characters and their ADE (ASCII Decimal Equivalent)' !! call ade(ascii) !! write(*,*)'Cleared of non-printable characters' !! call ade(cleared) !! write(*,*)'Cleared string:' !! write(*,*)cleared !! contains !! subroutine ade(string) !! implicit none !! ! the string to print !! character(len=*),intent(in) :: string !! ! number of characters in string to print !! integer :: lgth !! ! counter used to step thru string !! integer :: i !! ! get trimmed length of input string !! lgth=len_trim(string(:len(string))) !! !! ! replace lower unprintable characters with spaces !! write(*,101)(merge(string(i:i),' ',& !! & iachar(string(i:i)) >= 32 & !! & .and. & !! & iachar(string(i:i)) <= 126) & !! & ,i=1,lgth) !! !! ! print ADE value of character underneath it !! write(*,202) (iachar(string(i:i))/100, i=1,lgth) !! write(*,202)(mod( iachar(string(i:i)),100)/10,i=1,lgth) !! write(*,202)(mod((iachar(string(i:i))),10), i=1,lgth) !! ! format for printing string characters !! 101 format(*(a1:)) !! ! format for printing ADE values !! 202 format(*(i1:)) !! end subroutine ade !! end program demo_noesc !! !! Expected output !! !! The string is printed with the ADE value vertically beneath. !! The original string has all the ADEs from 000 to 127. After !! NOESC(3f) is called on the string all the "non-printable" !! characters are replaced with a space (ADE of 032). !! !! characters and their ADE (ASCII Decimal Equivalent) !! !! > !"#$%&'()*+,-./0123456789 !! :;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_`abcdefghijklmnopqrstuvwxyz{|}~ !! >0000000000000000000000000000000000000000000000000000000000 !! 0000000000000000000000000000000000000000001111111111111111111111111111 !! >00000000001111111111222222222233333333334444444444555555555566666666 !! 667777777777888888888899999999990000000000111111111122222222 !! >012345678901234567890123456789012345678901234567890123456789012345678 !! 90123456789012345678901234567890123456789012345678901234567 !! !! Cleared of non-printable characters !! !! > !"#$%&'()*+,-./0123456789 !! :;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_`abcdefghijklmnopqrstuvwxyz{|}~ !! >0000000000000000000000000000000000000000000000000000000000 !! 000000000000000000000000000000000000000000111111111111111111111111111 !! >3333333333333333333333333333333333333333444444444455555555 !! 556666666666777777777788888888889999999999000000000011111111112222222 !! >2222222222222222222222222222222223456789012345678901234567 !! 890123456789012345678901234567890123456789012345678901234567890123456 !! !! Cleared string: !! !! > !"#$%&'()*+,-./0123456789:;<=>?@ !! ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_`abcdefghijklmnopqrstuvwxyz{|}~ !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain elemental function noesc(INSTR) ! ident_48="@(#) M_strings noesc(3f) convert non-printable characters to a space" character(len=*),intent(in) :: INSTR ! string that might contain nonprintable characters character(len=len(instr)) :: noesc integer :: ic,i10 !----------------------------------------------------------------------------------------------------------------------------------- noesc='' ! initialize output string do i10=1,len_trim(INSTR(1:len(INSTR))) ic=iachar(INSTR(i10:i10)) if(ic <= 31.or.ic == 127)then ! find characters with ADE of 0-31, 127 noesc(I10:I10)=' ' ! replace non-printable characters with a space else noesc(I10:I10)=INSTR(i10:i10) ! copy other characters as-is from input string to output string endif enddo end function noesc !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! string_to_value(3f) - [M_strings:TYPE] subroutine returns numeric !! value from string !! (LICENSE:PD) !! !!##SYNOPSIS !! !! subroutine string_to_value(chars,valu,ierr) !! !! character(len=*),intent(in) :: chars ! input string !! integer|real|doubleprecision,intent(out) :: valu !! integer,intent(out) :: ierr !! !!##DESCRIPTION !! Returns a numeric value from a numeric character string. !! !! Works with any g-format input, including integer, real, and !! exponential. If the input string begins with "B", "Z", or "O" !! and otherwise represents a positive whole number it is assumed to !! be a binary, hexadecimal, or octal value. If the string contains !! commas they are removed. If the string is of the form NN:MMM... or !! NN#MMM then NN is assumed to be the base of the whole number. !! !! If an error occurs in the READ, IOSTAT is returned in IERR and !! value is set to zero. if no error occurs, IERR=0. !! !!##OPTIONS !! CHARS input string to read numeric value from !! !!##RETURNS !! VALU numeric value returned. May be INTEGER, REAL, or !! DOUBLEPRECISION. !! IERR error flag (0 == no error) !! !!##EXAMPLE !! !! Sample Program: !! !! program demo_string_to_value !! use M_strings, only: string_to_value !! implicit none !! real :: value !! integer :: ierr !! character(len=80) :: string !! string=' -40.5e-2 ' !! call string_to_value(string,value,ierr) !! write(*,*) 'value of string ['//trim(string)//'] is ',value !! end program demo_string_to_value !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain subroutine a2r(chars,valu,ierr) ! ident_49="@(#) M_strings a2r(3fp) subroutine returns real value from string" character(len=*),intent(in) :: chars ! input string real,intent(out) :: valu ! value read from input string integer,intent(out) :: ierr ! error flag (0 == no error) doubleprecision :: valu8 valu8=0.0d0 call a2d(chars,valu8,ierr,onerr=0.0d0) if(ierr == 0)then if(valu8 <= huge(valu))then valu=real(valu8) else call journal('sc','*a2r*','- value too large',valu8,'>',huge(valu)) valu=huge(valu) ierr=-1 endif endif end subroutine a2r !---------------------------------------------------------------------------------------------------------------------------------- subroutine a2i(chars,valu,ierr) ! ident_50="@(#) M_strings a2i(3fp) subroutine returns integer value from string" character(len=*),intent(in) :: chars ! input string integer,intent(out) :: valu ! value read from input string integer,intent(out) :: ierr ! error flag (0 == no error) doubleprecision :: valu8 valu8=0.0d0 call a2d(chars,valu8,ierr,onerr=0.0d0) if(valu8 <= huge(valu))then if(valu8 <= huge(valu))then valu=int(valu8) else call journal('sc','*a2i*','- value too large',valu8,'>',huge(valu)) valu=huge(valu) ierr=-1 endif endif end subroutine a2i !---------------------------------------------------------------------------------------------------------------------------------- subroutine a2d(chars,valu,ierr,onerr) ! ident_51="@(#) M_strings 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) class(*),optional,intent(in) :: onerr !---------------------------------------------------------------------------------------------------------------------------------- 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 integer :: pnd integer :: basevalue, ivalu character(len=3),save :: nan_string='NaN' !---------------------------------------------------------------------------------------------------------------------------------- ierr=0 ! initialize error flag to zero local_chars=unquote(chars) msg='' if(len(local_chars) == 0)local_chars=' ' call substitute(local_chars,',','') ! remove any comma characters pnd=scan(local_chars,'#:') if(pnd /= 0)then write(frmt,fmt)pnd-1 ! build format of form '(BN,Gn.0)' read(local_chars(:pnd-1),fmt=frmt,iostat=ierr,iomsg=msg)basevalue ! try to read value from string if(decodebase(local_chars(pnd+1:),basevalue,ivalu))then valu=real(ivalu,kind=kind(0.0d0)) else valu=0.0d0 ierr=-1 endif else 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 endif if(ierr /= 0)then ! if an error occurred ierr will be non-zero. if(present(onerr))then select type(onerr) type is (integer) valu=onerr type is (real) valu=onerr type is (doubleprecision) valu=onerr end select else ! set return value to NaN read(nan_string,'(g3.3)')valu endif if(local_chars /= 'eod')then ! print warning message except for special value "eod" call journal('sc','*a2d* - cannot produce number from string ['//trim(chars)//']') if(msg /= '')then call journal('sc','*a2d* - ['//trim(msg)//']') endif endif endif end subroutine a2d !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! s2v(3f) - [M_strings:TYPE] function returns doubleprecision !! numeric value from a string !! (LICENSE:PD) !! !!##SYNOPSIS !! !! function s2v(string[,ierr][,onerr]) !! !! character(len=*) :: string !! doubleprecision :: s2v !! integer,intent(out),optional :: ierr !! class(*),intent(in),optional :: onerr !! !!##DESCRIPTION !! This function converts a string to a DOUBLEPRECISION numeric value. !! !! The intrinsics INT(3f), REAL(3f), and DBLE(3f) are also extended !! to take CHARACTER variables. The KIND= keyword is not supported !! on the extensions. !! !!##OPTIONS !! !! string holds string assumed to represent a numeric value !! ierr If an error occurs the program is stopped if the optional !! parameter IERR is not present. If IERR returns a non-zero !! value an error occurred. !! onerr The value to return on error. A value of NaN is !! returned on error by default. !! !!##RETURNS !! s2v numeric value read from string !! !!##EXAMPLE !! !! Sample Program: !! !! program demo_s2v !! !! use M_strings, only: s2v, int, real, dble !! 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(*,*)"Extended intrinsics" !! write(*,*)'given inputs:',s,strings(:8) !! write(*,*)'INT(3f):',int(s),int(strings(:8)) !! write(*,*)'REAL(3f):',real(s),real(strings(:8)) !! write(*,*)'DBLE(3f):',dble(s),dble(strings(:8)) !! 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 !! >Extended intrinsics !! >given inputs: 10.345 10.345 +10 -3 -4.94e-2 0.1 !! 12345.678910d0 1 2 1 2 1 . 0 !! >INT(3f): 10 10 10 -3 0 0 12345 0 12121 !! >REAL(3f): 10.3450003 10.3450003 10.0000000 -3.00000000 !! -4.94000018E-02 !! > 0.100000001 12345.6787 0.00000000 12121.0000 !! >DBLE(3f): 10.345000000000001 10.345000000000001 !! 10.000000000000000 !! > -3.0000000000000000 -4.9399999999999999E-002 !! 0.10000000000000001 !! > 12345.678910000001 0.0000000000000000 !! 12121.000000000000 !! >That's all folks! !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain !> !!##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,onerr) ! 1989 John S. Urban ! ident_52="@(#) M_strings s2v(3f) returns doubleprecision number from string;zero if error occurs" character(len=*),intent(in) :: chars integer,optional :: ierr doubleprecision :: valu integer :: ierr_local class(*),intent(in),optional :: onerr ierr_local=0 if(present(onerr))then call a2d(chars,valu,ierr_local,onerr) else call a2d(chars,valu,ierr_local) endif if(present(ierr))then ! if error is not returned stop program on error ierr=ierr_local s2v=valu elseif(ierr_local /= 0)then write(*,*)'*s2v* stopped while reading '//trim(chars) stop 1 else s2v=valu endif end function s2v !=================================================================================================================================== ! calls to s2v(3f) for extending intrinsics int(3f), real(3f), dble(3f) !=================================================================================================================================== !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()())()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! dble(3f) - [M_strings:TYPE] overloads DBLE(3f) so it can handle character arguments !! (LICENSE:PD) !! !!##SYNOPSIS !! !! impure elemental function dble(string) !! !! character(len=*) :: string !! integer :: dble !! !!##DESCRIPTION !! dble(3f) returns a DOUBLE value when given a numeric representation of a !! numeric value. This overloads the DBLE(3f) intrinsic so that CHARACTER !! arguments assumed to represent a numeric value may be input. !! !!##OPTIONS !! STRING input string to be converted to a dble value !! !!##RETURNS !! DBLE double precision value represented by input string !! !!##EXAMPLE !! !! Sample program: !! !! program demo_dble !! use M_strings, only: dble !! implicit none !! write(*,*)dble('100'),dble('20.4') !! write(*,*)'dble still works',dble(20),dble(20.4) !! write(*,*)'elemental',& !! & dble([character(len=23) :: '10','20.3','20.5','20.6']) !! end program demo_dble !! !! Results: !! !! > 100.00000000000000 20.399999999999999 !! > dble still works 20.000000000000000 20.399999618530273 !! > elemental 10.00000000000000 20.30000000000000 !! > 20.50000000000000 20.60000000000000 !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain impure elemental doubleprecision function dble_s2v(chars) character(len=*),intent(in) :: chars dble_s2v=s2v(chars) end function dble_s2v !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()())()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! real(3f) - [M_strings:TYPE] overloads REAL(3f) so it can handle character arguments !! (LICENSE:PD) !! !!##SYNOPSIS !! !! impure elemental function real(string) !! !! character(len=*) :: string !! integer :: real !! !!##DESCRIPTION !! real(3f) returns a REAL value when given a numeric representation of a !! numeric value. This overloads the REAL(3f) intrinsic so that CHARACTER !! arguments assumed to represent a numeric value may be input. !! !!##OPTIONS !! STRING input string to be converted to a real value !! !!##RETURNS !! REAL real value represented by input string !! !!##EXAMPLE !! !! Sample program: !! !! program demo_real !! use M_strings, only: real !! implicit none !! write(*,*)real('100'),real('20.4') !! write(*,*)'real still works',real(20) !! write(*,*)'elemental',& !! & real([character(len=23) :: '10','20.3','20.5','20.6']) !! end program demo_real !! !! Results: !! !! > 100.000000 20.3999996 !! > real still works 20.0000000 !! > elemental 10.0000000 20.2999992 20.5000000 20.6000004 !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain !=================================================================================================================================== impure elemental real function real_s2v(chars) character(len=*),intent(in) :: chars real_s2v=real(s2v(chars)) end function real_s2v !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()())()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! int(3f) - [M_strings:TYPE] overloads INT(3f) so it can handle character arguments !! (LICENSE:PD) !! !!##SYNOPSIS !! !! impure elemental function int(string) !! !! character(len=*) :: string !! integer(kind=int32) :: int !! !!##DESCRIPTION !! int(3f) returns an integer when given a numeric representation of a !! numeric value. This overloads the INT(3f) intrinsic so that CHARACTER !! arguments assumed to represent a numeric value may be input. !! !!##OPTIONS !! STRING input string to be converted to an INT32 integer !! !!##RETURNS !! INT integer represented by input string !! !!##EXAMPLE !! !! Sample program: !! !! program demo_int !! use M_strings, only: int !! implicit none !! write(*,*)int('100'),int('20.4') !! write(*,*)'int still works',int(20.4) !! write(*,*)'elemental',& !! & int([character(len=23) :: '10','20.3','20.5','20.6']) !! end program demo_int !! !! Results: !! !! > 100 20 !! > int still works 20 !! > elemental 10 20 20 20 !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain !=================================================================================================================================== !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()())()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! nint(3f) - [M_strings:TYPE] overloads NINT(3f) so it can handle character arguments !! (LICENSE:PD) !! !!##SYNOPSIS !! !! impure elemental function nint(string) !! !! character(len=*) :: string !! integer :: nint !! !!##DESCRIPTION !! nint(3f) returns an integer when given a numeric representation of a !! numeric value. This overloads the NINT(3f) intrinsic so that CHARACTER !! arguments assumed to represent a numeric value may be input. !! !!##OPTIONS !! STRING input string to be converted to an integer !! !!##RETURNS !! NINT integer represented by input string !! !!##EXAMPLE !! !! Sample program: !! !! program demo_nint !! use M_strings, only: nint !! implicit none !! write(*,*)nint('100'),nint('20.4') !! write(*,*)'nint still works',nint(20.4) !! write(*,*)'elemental',& !! & nint([character(len=23) :: '10','20.3','20.5','20.6']) !! end program demo_nint !! !! Results: !! !! > 100 20 !! > nint still works 20 !! > elemental 10 20 21 21 !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain !=================================================================================================================================== impure elemental integer function nint_s2v(chars) character(len=*),intent(in) :: chars nint_s2v=nint(s2v(chars)) end function nint_s2v !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()())()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! value_to_string(3f) - [M_strings:TYPE] return numeric string !! from a numeric value !! (LICENSE:PD) !! !!##SYNOPSIS !! !! subroutine value_to_string(value,chars[,lgth,ierr,fmt,trimz]) !! !! character(len=*) :: chars ! minimum of 23 characters required !! !-------- !! ! VALUE may be any one of the following types: !! doubleprecision,intent(in) :: value !! real,intent(in) :: value !! integer,intent(in) :: value !! logical,intent(in) :: value !! !-------- !! character(len=*),intent(out) :: chars !! integer,intent(out),optional :: lgth !! integer,optional :: ierr !! character(len=*),intent(in),optional :: fmt !! logical,intent(in) :: trimz !! !!##DESCRIPTION !! value_to_string(3f) returns a numeric representation of a numeric !! value in a string given a numeric value of type REAL, DOUBLEPRECISION, !! INTEGER or LOGICAL. It creates the string using internal writes. It !! then removes trailing zeros from non-zero values, and left-justifies !! the string. !! !!##OPTIONS !! VALUE input value to be converted to a string !! FMT You may specify a specific format that produces a string !! up to the length of CHARS; optional. !! TRIMZ If a format is supplied the default is not to try to trim !! trailing zeros. Set TRIMZ to .true. to trim zeros from a !! string assumed to represent a simple numeric value. !! !!##RETURNS !! CHARS returned string representing input value, must be at least !! 23 characters long; or what is required by optional FMT !! if longer. !! LGTH position of last non-blank character in returned string; !! optional. !! IERR If not zero, error occurred; optional. !! !!##EXAMPLE !! !! Sample program: !! !! program demo_value_to_string !! use M_strings, only: value_to_string !! implicit none !! character(len=80) :: string !! integer :: lgth !! call value_to_string(3.0/4.0,string,lgth) !! write(*,*) 'The value is [',string(:lgth),']' !! !! call value_to_string(3.0/4.0,string,lgth,fmt='') !! write(*,*) 'The value is [',string(:lgth),']' !! !! call value_to_string& !! &(3.0/4.0,string,lgth,fmt='("THE VALUE IS ",g0)') !! write(*,*) 'The value is [',string(:lgth),']' !! !! call value_to_string(1234,string,lgth) !! write(*,*) 'The value is [',string(:lgth),']' !! !! call value_to_string(1.0d0/3.0d0,string,lgth) !! write(*,*) 'The value is [',string(:lgth),']' !! !! 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] !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain subroutine value_to_string(gval,chars,length,err,fmt,trimz) ! ident_53="@(#) 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 logical,intent(in),optional :: trimz character(len=:),allocatable :: fmt_local character(len=1024) :: msg ! Notice that the value GVAL can be any of several types ( INTEGER,REAL,DOUBLEPRECISION,LOGICAL) if (present(fmt)) then select type(gval) type is (integer) fmt_local='(i0)' if(fmt /= '') fmt_local=fmt write(chars,fmt_local,iostat=err_local,iomsg=msg)gval type is (real) fmt_local='(bz,g23.10e3)' fmt_local='(bz,g0.8)' if(fmt /= '') fmt_local=fmt write(chars,fmt_local,iostat=err_local,iomsg=msg)gval type is (doubleprecision) fmt_local='(bz,g0)' if(fmt /= '') fmt_local=fmt write(chars,fmt_local,iostat=err_local,iomsg=msg)gval type is (logical) fmt_local='(l1)' if(fmt /= '') fmt_local=fmt write(chars,fmt_local,iostat=err_local,iomsg=msg)gval class default call journal('*value_to_string* UNKNOWN TYPE') chars=' ' end select if(fmt == '') then chars=adjustl(chars) call trimzeros_(chars) endif else ! no explicit format option present err_local=-1 select type(gval) type is (integer) write(chars,*,iostat=err_local,iomsg=msg)gval type is (real) write(chars,*,iostat=err_local,iomsg=msg)gval type is (doubleprecision) write(chars,*,iostat=err_local,iomsg=msg)gval type is (logical) write(chars,*,iostat=err_local,iomsg=msg)gval class default chars='' end select chars=adjustl(chars) if(index(chars,'.') /= 0) call trimzeros_(chars) endif if(present(trimz))then if(trimz)then chars=adjustl(chars) call trimzeros_(chars) endif endif if(present(length)) then length=len_trim(chars) endif if(present(err)) then err=err_local elseif(err_local /= 0)then ! cannot currently do I/O from a function being called from I/O !write(ERROR_UNIT,'(a)')'*value_to_string* WARNING:['//trim(msg)//']' chars=chars//' *value_to_string* WARNING:['//trim(msg)//']' endif end subroutine value_to_string !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! v2s(3f) - [M_strings:TYPE] return numeric string from a numeric value !! (LICENSE:PD) !! !!##SYNOPSIS !! !! function v2s(value) result(outstr) !! !! integer|real|doubleprecision|logical,intent(in ) :: value !! character(len=:),allocatable :: outstr !! character(len=*),optional,intent(in) :: fmt !! !!##DESCRIPTION !! v2s(3f) returns a representation of a numeric value as a !! string when given a numeric value of type REAL, DOUBLEPRECISION, !! INTEGER or LOGICAL. It creates the strings using internal WRITE() !! statements. Trailing zeros are removed from non-zero values, and the !! string is left-justified. !! !!##OPTIONS !! VALUE input value to be converted to a string !! FMT format can be explicitly given, but is limited to !! generating a string of eighty or less characters. !! !!##RETURNS !! OUTSTR returned string representing input value, !! !!##EXAMPLE !! !! Sample Program: !! !! program demo_v2s !! use M_strings, only: v2s !! write(*,*) 'The value of 3.0/4.0 is ['//v2s(3.0/4.0)//']' !! write(*,*) 'The value of 1234 is ['//v2s(1234)//']' !! write(*,*) 'The value of 0d0 is ['//v2s(0d0)//']' !! write(*,*) 'The value of .false. is ['//v2s(.false.)//']' !! write(*,*) 'The value of .true. is ['//v2s(.true.)//']' !! end program demo_v2s !! !! Expected output !! !! The value of 3.0/4.0 is [0.75] !! The value of 1234 is [1234] !! The value of 0d0 is [0] !! The value of .false. is [F] !! The value of .true. is [T] !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain !=================================================================================================================================== function d2s(dvalue,fmt) result(outstr) ! ident_54="@(#) M_strings d2s(3fp) private function returns string given doubleprecision value" doubleprecision,intent(in) :: dvalue ! input value to convert to a string character(len=*),intent(in),optional :: fmt character(len=:),allocatable :: outstr ! output string to generate character(len=80) :: string if(present(fmt))then call value_to_string(dvalue,string,fmt=fmt) else call value_to_string(dvalue,string) endif outstr=trim(string) end function d2s !=================================================================================================================================== function r2s(rvalue,fmt) result(outstr) ! ident_55="@(#) M_strings r2s(3fp) private function returns string given real value" real,intent(in) :: rvalue ! input value to convert to a string character(len=*),intent(in),optional :: fmt character(len=:),allocatable :: outstr ! output string to generate character(len=80) :: string if(present(fmt))then call value_to_string(rvalue,string,fmt=fmt) else call value_to_string(rvalue,string) endif outstr=trim(string) end function r2s !=================================================================================================================================== function i2s(ivalue,fmt) result(outstr) ! ident_56="@(#) M_strings i2s(3fp) private function returns string given integer value" integer,intent(in) :: ivalue ! input value to convert to a string character(len=*),intent(in),optional :: fmt character(len=:),allocatable :: outstr ! output string to generate character(len=80) :: string if(present(fmt))then call value_to_string(ivalue,string,fmt=fmt) else call value_to_string(ivalue,string) endif outstr=trim(string) end function i2s !=================================================================================================================================== function l2s(lvalue,fmt) result(outstr) ! ident_57="@(#) M_strings l2s(3fp) private function returns string given logical value" logical,intent(in) :: lvalue ! input value to convert to a string character(len=*),intent(in),optional :: fmt character(len=:),allocatable :: outstr ! output string to generate character(len=80) :: string if(present(fmt))then call value_to_string(lvalue,string,fmt=fmt) else call value_to_string(lvalue,string) endif outstr=trim(string) end function l2s !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! isnumber(3f) - [M_strings:TYPE] determine if a string represents a number !! (LICENSE:PD) !! !!##SYNOPSIS !! !! function isnumber(str,msg) !! !! character(len=*),intent(in) :: str !! character(len=:),intent(out),allocatable,optional :: msg !! !!##DESCRIPTION !! ISNUMBER(3f) returns a value greater than zero if the string represents !! a number, and a number less than or equal to zero if it is a bad number. !! Blank characters are ignored. !! !!##OPTIONS !! str the string to evaluate as to whether it represents a numeric value !! or not !! msg An optional message describing the string !! !!##RETURNS !! isnumber the following values are returned !! !! 1 for an integer [-+]NNNNN !! 2 for a whole number [-+]NNNNN. !! 3 for a real value [-+]NNNNN.MMMM !! 4 for a exponential value [-+]NNNNN.MMMM[-+]LLLL !! [-+]NNNNN.MMMM[ed][-+]LLLL !! !! values less than 1 represent an error !! !!##EXAMPLES !! !! As the example shows, you can use an internal READ(3f) along with the !! IOSTAT= parameter to check (and read) a string as well. !! !! program demo_isnumber !! use M_strings, only : isnumber !! implicit none !! character(len=256) :: line !! real :: value !! integer :: ios1, ios2 !! integer :: answer !! character(len=256) :: message !! character(len=:),allocatable :: description !! write(*,*)'Begin entering values, one per line' !! do !! read(*,'(a)',iostat=ios1)line !! ! !! ! try string as number using list-directed input !! line='' !! read(line,*,iostat=ios2,iomsg=message) value !! if(ios2 == 0)then !! write(*,*)'VALUE=',value !! elseif( is_iostat_end(ios1) ) then !! stop 'end of file' !! else !! write(*,*)'ERROR:',ios2,trim(message) !! endif !! ! !! ! try string using isnumber(3f) !! answer=isnumber(line,msg=description) !! if(answer > 0)then !! write(*,*) & !! & ' for ',trim(line),' ',answer,':',description !! else !! write(*,*) & !! & ' ERROR for ',trim(line),' ',answer,':',description !! endif !! ! !! enddo !! end program demo_isnumber !! !! Example run !! !! > Begin entering values !! > ERROR: -1 End of file !! > ERROR for -1 :null string !! >10 !! > VALUE= 10.0000000 !! > for 10 1 :integer !! >20 !! > VALUE= 20.0000000 !! > for 20 1 :integer !! >20. !! > VALUE= 20.0000000 !! > for 20. 2 :whole number !! >30.1 !! > VALUE= 30.1000004 !! > for 30.1 3 :real number !! >3e1 !! > VALUE= 30.0000000 !! > for 3e1 4 :value with exponent !! >1-2 !! > VALUE= 9.99999978E-03 !! > for 1-2 4 :value with exponent !! >100.22d-4 !! > VALUE= 1.00220004E-02 !! > for 100.22d-4 4 :value with exponent !! >1--2 !! > ERROR: 5010 Bad real number in item 1 of list input !! > ERROR for 1--2 -5 :bad number !! >e !! > ERROR: 5010 Bad real number in item 1 of list input !! > ERROR for e -6 :missing leading value before exponent !! >e1 !! > ERROR: 5010 Bad real number in item 1 of list input !! > ERROR for e1 -6 :missing leading value before exponent !! >1e !! > ERROR: 5010 Bad real number in item 1 of list input !! > ERROR for 1e -3 :missing exponent !! >1e+ !! > ERROR: 5010 Bad real number in item 1 of list input !! > ERROR for 1e+ -4 :missing exponent after sign !! >1e+2.0 !! > ERROR: 5010 Bad real number in item 1 of list input !! > ERROR for 1e+2.0 -5 :bad number !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain function isNumber(string,msg,verbose) ! ident_58="@(#) M_strings isnumber(3f) Determines if a string is a number of not." character(len=*),intent(in) :: string character(len=:),intent(out),allocatable,optional :: msg logical,intent(in),optional :: verbose integer :: isnumber integer :: i,iend character(len=1),allocatable :: z(:) character(len=:),allocatable :: message logical :: founddigit logical :: verbose_local i=1 founddigit=.false. isnumber=0 z=switch(trim(nospace(string))) iend=size(z) message='not a number' if(present(verbose))then verbose_local=verbose else verbose_local=.false. endif DONE : block if(iend == 0)then isnumber=-1 ! string is null message='null string' exit DONE endif if(index('+-',z(i)) /= 0) i=i+1 ! skip optional leading sign if(i > iend)then isnumber=-2 ! string was just a sign message='just a sign' exit DONE endif call next() ! position I to next non-digit or end of string+1 if(i > iend)then isnumber=1 ! [+-]NNNNNN message='integer' exit DONE endif if(z(i) == '.')then ! a period would be OK at this point i=i+1 endif if(i > iend)then ! [+-]NNNNNN. isnumber=2 message='whole number' exit DONE endif call next() ! position I to next non-digit or end of string+1 if(i > iend)then isnumber=3 ! [+-]NNNNNN.MMMM message='real number' exit DONE endif if(index('eEdD',z(i)) /= 0)then i=i+1 if(i == 2)then isnumber=-6 ! [+-]NNNNNN[.[MMMM]]e but a value must follow message='missing leading value before exponent' exit DONE endif endif if(i > iend)then isnumber=-3 ! [+-]NNNNNN[.[MMMM]]e but a value must follow message='missing exponent' exit DONE endif if(.not.founddigit)then isnumber=-7 message='missing value before exponent' exit DONE endif if(index('+-',z(i)) /= 0) i=i+1 if(i > iend)then isnumber=-4 ! [+-]NNNNNN[.[MMMM]]e[+-] but a value must follow message='missing exponent after sign' exit DONE endif call next() ! position I to next non-digit or end of string+1 if(i > iend)then isnumber=4 ! [+-]NNNNNN.MMMMe[+-]LL message='value with exponent' exit DONE endif isnumber=-5 message='bad number' endblock DONE if(verbose_local)then write(*,*)trim(string)//' is '//message endif if(present(msg))then msg=message endif contains subroutine next() ! move to next non-digit or end of string+1 integer :: j do j=i,iend if(.not.isdigit(z(j)))then exit endif founddigit=.true. if(verbose_local) write(*,*)'I=',i,' J=',j,' Z(j)=',z(j) enddo i=j if(verbose_local)then write(*,*)'I and J=',i if(i <= iend) then write(*,*)'Z(I)=',z(i) else write(*,*)'====>' endif endif end subroutine next end function isNumber !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! trimzeros_(3fp) - [M_strings:TYPE] Delete trailing zeros from !! numeric decimal string !! (LICENSE:PD) !! !!##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. !! !!##OPTIONS !! str input string will be assumed to be a numeric value and have !! trailing zeros removed !!##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_ !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain subroutine trimzeros_(string) ! ident_59="@(#) 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,'.') == 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 <= 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 enddo 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_ !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! listout(3f) - [M_strings:NUMERIC] expand a list of numbers where negative !! numbers denote range ends (1 -10 means 1 thru 10) !! (LICENSE:PD) !! !!##SYNOPSIS !! !! subroutine listout(icurve_lists,icurve_expanded,inums,ierr) !! !! integer,intent(in) :: icurve_lists(:) !! integer,intent(out) :: icurve_expanded(:) !! integer,intent(out) :: inums !! integer,intent(out) :: ierr !! !!##DESCRIPTION !! expand a list of whole numbers where negative numbers indicate a range. !! So [10,-20] would be expanded to [10,11,12,13,14,15,16,17,18,19,20]. !! !!##OPTIONS !! icurve_lists(:) input array !! !!##RETURNS !! icurve_expanded(:) output array; assumed large enough to hold !! returned list !! inums number of icurve_expanded numbers on output !! ierr zero if no error occurred !! !!##EXAMPLE !! !! Sample program: !! !! program demo_listout !! use M_strings, only : listout !! implicit none !! integer,allocatable :: icurve_lists(:) !! integer :: icurve_expanded(1000) !! ! icurve_lists is input array !! integer :: inums !! ! icurve_expanded is output array !! integer :: i !! ! number of icurve_lists values on input, !! ! number of icurve_expanded numbers on output !! integer :: ierr !! icurve_lists=[1, 20, -30, 101, 100, 99, 100, -120, 222, -200] !! inums=size(icurve_lists) !! call listout(icurve_lists,icurve_expanded,inums,ierr) !! if(ierr == 0)then !! write(*,'(i0)')(icurve_expanded(i),i=1,inums) !! else !! write(*,'(a,i0)')'error occurred in *listout* ',ierr !! write(*,'(i0)')(icurve_expanded(i),i=1,inums) !! endif !! end program demo_listout !! !! Results: !! !! > 1 20 21 22 23 !! > 24 25 26 27 28 !! > 29 30 101 100 99 !! > 100 101 102 103 104 !! > 105 106 107 108 109 !! > 110 111 112 113 114 !! > 115 116 117 118 119 !! > 120 222 221 220 219 !! > 218 217 216 215 214 !! > 213 212 211 210 209 !! > 208 207 206 205 204 !! > 203 202 201 200 !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain subroutine listout(icurve_lists,icurve_expanded,inums_out,ierr) ! ident_60="@(#) M_strings listout(3f) copy icurve_lists to icurve_expanded expanding negative numbers to ranges (1 -10 means 1 thru 10)" ! Created: 19971231 integer,intent(in) :: icurve_lists(:) ! input array integer,intent(out) :: icurve_expanded(:) ! output array integer,intent(out) :: inums_out ! number of icurve_expanded numbers on output integer,intent(out) :: ierr ! status variable character(len=80) :: temp1 integer :: i80, i90 integer :: imin, imax integer :: idirection, icount integer :: iin integer :: inums_max ierr=0 icurve_expanded=0 ! initialize output array inums_out=0 ! initialize number of significant values in output array inums_max=size(icurve_expanded) if(inums_max == 0)then ierr=-2 return endif iin=size(icurve_lists) if(iin > 0)then icurve_expanded(1)=icurve_lists(1) endif icount=2 do i90=2,iin if(icurve_lists(i90) < 0)then imax=abs(icurve_lists(i90)) imin=abs(icurve_lists(i90-1)) if(imin > imax)then idirection=-1 imin=imin-1 elseif(imax > imin)then idirection=1 imin=imin+1 else idirection=1 endif do i80=imin,imax,idirection if(icount > inums_max) then write(temp1,'(a,i5,a)')'*listout* only ',inums_max,' values allowed' ierr=-1 call journal(temp1) inums_out=icount-1 exit endif icurve_expanded(icount)=i80 icount=icount+1 enddo else icurve_expanded(icount)=icurve_lists(i90) icount=icount+1 endif enddo inums_out=icount-1 end subroutine listout !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()= !=================================================================================================================================== !> !!##NAME !! quote(3f) - [M_strings:QUOTES] add quotes to string as if written !! with list-directed input !! (LICENSE:PD) !! !!##SYNOPSIS !! !! function quote(str,mode,clip) result (quoted_str) !! !! character(len=*),intent(in) :: str !! character(len=*),optional,intent(in) :: mode !! logical,optional,intent(in) :: clip !! character(len=:),allocatable :: quoted_str !! !!##DESCRIPTION !! Add quotes to a CHARACTER variable as if it was written using !! list-directed input. This is particularly useful for processing !! strings to add to CSV files. !! !!##OPTIONS !! str input string to add quotes to, using the rules of !! list-directed input (single quotes are replaced by two !! adjacent quotes) !! mode alternate quoting methods are supported: !! !! DOUBLE default. replace quote with double quotes !! ESCAPE replace quotes with backslash-quote instead of !! double quotes !! !! clip default is to trim leading and trailing spaces from the !! string. If CLIP is .FALSE. spaces are not trimmed !! !!##RESULT !! quoted_str The output string, which is based on adding quotes to STR. !! !!##EXAMPLE !! !! Sample program: !! !! program demo_quote !! use M_strings, only : quote !! implicit none !! character(len=:),allocatable :: str !! character(len=1024) :: msg !! integer :: ios !! character(len=80) :: inline !! do !! write(*,'(a)',advance='no')'Enter test string:' !! read(*,'(a)',iostat=ios,iomsg=msg)inline !! if(ios /= 0)then !! write(*,*)trim(inline) !! exit !! endif !! !! ! the original string !! write(*,'(a)')'ORIGINAL ['//trim(inline)//']' !! !! ! the string processed by quote(3f) !! str=quote(inline) !! write(*,'(a)')'QUOTED ['//str//']' !! !! ! write the string list-directed to compare the results !! write(*,'(a)',iostat=ios,iomsg=msg) 'LIST DIRECTED:' !! write(*,*,iostat=ios,iomsg=msg,delim='none') inline !! write(*,*,iostat=ios,iomsg=msg,delim='quote') inline !! write(*,*,iostat=ios,iomsg=msg,delim='apostrophe') inline !! enddo !! end program demo_quote !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain function quote(str,mode,clip) result (quoted_str) character(len=*),intent(in) :: str ! the string to be quoted character(len=*),optional,intent(in) :: mode logical,optional,intent(in) :: clip character(len=:),allocatable :: quoted_str character(len=1),parameter :: double_quote = '"' character(len=20) :: local_mode if(present(clip))then if(clip)then quoted_str=adjustl(str) else quoted_str=str endif else quoted_str=str endif local_mode=merge_str(mode,'DOUBLE',present(mode)) select case(lower(local_mode)) case('double') quoted_str=double_quote//trim(replace(quoted_str,'"','""'))//double_quote case('escape') quoted_str=double_quote//trim(replace(quoted_str,'"','\"'))//double_quote case default call journal('sc','*quote* ERROR: unknown quote mode ',local_mode) quoted_str=str end select !----------------------------------------------------------------------------------------------------------------------------------- end function quote !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()= !=================================================================================================================================== !> !!##NAME !! unquote(3f) - [M_strings:QUOTES] remove quotes from string as if !! read with list-directed input !! (LICENSE:PD) !! !!##SYNOPSIS !! !! function unquote(quoted_str,esc) result (unquoted_str) !! !! character(len=*),intent(in) :: quoted_str !! character(len=1),optional,intent(in) :: esc !! character(len=:),allocatable :: unquoted_str !! !!##DESCRIPTION !! Remove quotes from a CHARACTER variable as if it was read using !! list-directed input. This is particularly useful for processing !! tokens read from input such as CSV files. !! !! Fortran can now read using list-directed input from an internal file, !! which should handle quoted strings, but list-directed input does not !! support escape characters, which UNQUOTE(3f) does. !! !!##OPTIONS !! quoted_str input string to remove quotes from, using the rules of !! list-directed input (two adjacent quotes inside a quoted !! region are replaced by a single quote, a single quote or !! double quote is selected as the delimiter based on which !! is encountered first going from left to right, ...) !! esc optional character used to protect the next quote !! character from being processed as a quote, but simply as !! a plain character. !! !!##RESULT !! unquoted_str The output string, which is based on removing quotes !! from quoted_str. !! !!##EXAMPLE !! !! Sample program: !! !! program demo_unquote !! use M_strings, only : unquote !! implicit none !! character(len=128) :: quoted_str !! character(len=:),allocatable :: unquoted_str !! character(len=1),parameter :: esc='\' !! character(len=1024) :: msg !! integer :: ios !! character(len=1024) :: dummy !! do !! write(*,'(a)',advance='no')'Enter test string:' !! read(*,'(a)',iostat=ios,iomsg=msg)quoted_str !! if(ios /= 0)then !! write(*,*)trim(msg) !! exit !! endif !! !! ! the original string !! write(*,'(a)')'QUOTED ['//trim(quoted_str)//']' !! !! ! the string processed by unquote(3f) !! unquoted_str=unquote(trim(quoted_str),esc) !! write(*,'(a)')'UNQUOTED ['//unquoted_str//']' !! !! ! read the string list-directed to compare the results !! read(quoted_str,*,iostat=ios,iomsg=msg)dummy !! if(ios /= 0)then !! write(*,*)trim(msg) !! else !! write(*,'(a)')'LIST DIRECTED['//trim(dummy)//']' !! endif !! enddo !! end program demo_unquote !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain function unquote(quoted_str,esc) result (unquoted_str) character(len=*),intent(in) :: quoted_str ! the string to be unquoted character(len=1),optional,intent(in) :: esc ! escape character character(len=:),allocatable :: unquoted_str integer :: inlen character(len=1),parameter :: single_quote = "'" character(len=1),parameter :: double_quote = '"' integer :: quote ! whichever quote is to be used integer :: before integer :: current integer :: iesc integer :: iput integer :: i logical :: inside !----------------------------------------------------------------------------------------------------------------------------------- if(present(esc))then ! select escape character as specified character or special value meaning not set iesc=iachar(esc) ! allow for an escape character else iesc=-1 ! set to value that matches no character endif !----------------------------------------------------------------------------------------------------------------------------------- inlen=len(quoted_str) ! find length of input string allocate(character(len=inlen) :: unquoted_str) ! initially make output string length of input string !----------------------------------------------------------------------------------------------------------------------------------- if(inlen >= 1)then ! double_quote is the default quote unless the first character is single_quote if(quoted_str(1:1) == single_quote)then quote=iachar(single_quote) else quote=iachar(double_quote) endif else quote=iachar(double_quote) endif !----------------------------------------------------------------------------------------------------------------------------------- before=-2 ! initially set previous character to impossible value unquoted_str(:)='' ! initialize output string to null string iput=1 inside=.false. STEPTHROUGH: do i=1,inlen current=iachar(quoted_str(i:i)) if(before == iesc)then ! if previous character was escape use current character unconditionally iput=iput-1 ! backup unquoted_str(iput:iput)=char(current) iput=iput+1 before=-2 ! this could be second esc or quote elseif(current == quote)then ! if current is a quote it depends on whether previous character was a quote if(before == quote)then unquoted_str(iput:iput)=char(quote) ! this is second quote so retain it iput=iput+1 before=-2 elseif(.not.inside.and.before /= iesc)then inside=.true. else ! this is first quote so ignore it except remember it in case next is a quote before=current endif else unquoted_str(iput:iput)=char(current) iput=iput+1 before=current endif enddo STEPTHROUGH !----------------------------------------------------------------------------------------------------------------------------------- unquoted_str=unquoted_str(:iput-1) !----------------------------------------------------------------------------------------------------------------------------------- end function unquote !==================================================================================================================================! !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !==================================================================================================================================! !> !!##NAME !! edit_distance(3f) - [M_strings:DESCRIBE] returns a naive edit distance using !! the Levenshtein distance algorithm !! (LICENSE:PD) !! !!##SYNOPSIS !! !! pure elemental function edit_distance(str1,str2) result (distance) !! !! character(len=*),intent(in) :: str1, str2 !! integer :: distance !! !!##DESCRIPTION !! !! The Levenshtein distance function returns how many edits (deletions, !! insertions, transposition) are required to turn one string into another. !! !!##EXAMPLES !! !! Sample Program: !! !! program demo_edit_distance !! use M_strings, only : edit_distance !! write(*,*)edit_distance('kittens','sitting')==3 !! write(*,*)edit_distance('geek','gesek')==1 !! write(*,*)edit_distance('Saturday','Sunday')==3 !! end program demo_edit_distance !! !! Expected output !! !! T !! T !! T !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain ! The Levenshtein distance function returns how many edits (deletions, ! insertions, transposition) are required to turn one string into another. pure elemental integer function edit_distance (a,b) character(len=*), intent(in) :: a, b integer :: len_a, len_b, i, j, cost ! matrix for calculating Levenshtein distance !integer :: matrix(0:len_trim(a), 0:len_trim(b)) ! not supported by all compilers yet integer,allocatable :: matrix(:,:) len_a = len_trim(a) len_b = len_trim(b) !-------------------------------------- ! required by older compilers instead of above declaration if(allocated(matrix))deallocate(matrix) allocate(matrix(0:len_a,0:len_b)) !-------------------------------------- matrix(:,0) = [(i,i=0,len_a)] matrix(0,:) = [(j,j=0,len_b)] do i = 1, len_a do j = 1, len_b cost=merge(0,1,a(i:i)==b(j:j)) matrix(i,j) = min(matrix(i-1,j)+1, matrix(i,j-1)+1, matrix(i-1,j-1)+cost) enddo enddo edit_distance = matrix(len_a,len_b) end function edit_distance !==================================================================================================================================! !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !==================================================================================================================================! !> !!##NAME !! bundle(3f) - [M_strings:ARRAY] return up to twenty strings of arbitrary length !! as an array !! (LICENSE:PD) !! !!##SYNOPSIS !! !! function bundle(str1,str2,...str20,len) result (vec) !! !! character(len=*),intent(in),optional :: str1, str2 ... str20 !! integer,intent(in),optional :: len !! !!##DESCRIPTION !! Given a list of up to twenty strings create a string array. The !! length of the variables with be the same as the maximum length !! of the input strings unless explicitly specified via LEN. !! !! This is an alternative to the syntax !! !! [ CHARACTER(LEN=NN) :: str1, str2, ... ] !! !! that by default additionally calculates the minimum length required !! to prevent truncation. !! !!##OPTIONS !! str1,str2, ... str20 input strings to combine into a vector !! len length of returned array variables !! !!##EXAMPLES !! !! Sample Program: !! !! program demo_bundle !! use M_strings, only: bundle !! implicit none !! print "(*('""',a,'""':,',',1x))", bundle("one") !! print "(*('""',a,'""':,',',1x))", bundle("one","two") !! print "(*('""',a,'""':,',',1x))", bundle("one","two","three") !! print "(*('""',a,'""':,',',1x))", bundle("one","two","three",& !! & "four","five","six","seven") !! end program demo_bundle !! !! Expected output !! !! "one" !! "one", "two" !! "one ", "two ", "three" !! "one ", "two ", "three", "four ", "five ", "six ", "seven" !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain function bundle(x1,x2,x3,x4,x5,x6,x7,x8,x9,x10,x11,x12,x13,x14,x15,x16,x17,x18,x19,x20,len) result(vec) ! return character array containing present arguments character(len=*),intent(in),optional :: x1,x2,x3,x4,x5,x6,x7,x8,x9,x10 character(len=*),intent(in),optional :: x11,x12,x13,x14,x15,x16,x17,x18,x19,x20 integer,intent(in),optional :: len character(len=:),allocatable :: vec(:) integer :: ilen, icount, iset ilen=0 icount=0 iset=0 call increment(x1) call increment(x2) call increment(x3) call increment(x4) call increment(x5) call increment(x6) call increment(x7) call increment(x8) call increment(x9) call increment(x10) call increment(x11) call increment(x12) call increment(x13) call increment(x14) call increment(x15) call increment(x16) call increment(x17) call increment(x18) call increment(x19) call increment(x20) if(present(len)) ilen=len allocate (character(len=ilen) ::vec(icount)) call set(x1) call set(x2) call set(x3) call set(x4) call set(x5) call set(x6) call set(x7) call set(x8) call set(x9) call set(x10) call set(x11) call set(x12) call set(x13) call set(x14) call set(x15) call set(x16) call set(x17) call set(x18) call set(x19) call set(x20) contains subroutine increment(str) character(len=*),intent(in),optional :: str if(present(str))then ilen=max(ilen,len_trim(str)) icount=icount+1 endif end subroutine increment subroutine set(str) character(len=*),intent(in),optional :: str if(present(str))then iset=iset+1 vec(iset)=str endif end subroutine set end function bundle !==================================================================================================================================! !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !==================================================================================================================================! !> !!##NAME !! describe(3f) - [M_strings:DESCRIBE] returns a string describing the name of !! a single character !! (LICENSE:PD) !! !!##SYNOPSIS !! !! function describe(ch) result (string) !! !! character(len=1),intent(in) :: ch !! character(len=:),allocatable :: string !! !!##DESCRIPTION !! describe(3f) returns a string describing long name of a single !! character !! !!##EXAMPLES !! !! Sample Program: !! !! program demo_describe !! use M_strings, only : describe !! implicit none !! integer :: i !! do i=1,128 ! fill variable with base ASCII character set !! write(*,*)describe(char(i-1)) !! enddo !! end program demo_describe !! !! Expected output !! !! ctrl-@ or ctrl-? (NUL) null !! ctrl-A (SOH) start of heading !! ctrl-B (STX) start of text !! ctrl-C (ETX) end of text !! ctrl-D (EOT) end of transmission !! ctrl-E (ENQ) enquiry !! ctrl-F (ACK) acknowledge !! ctrl-G (BEL) bell !! ctrl-H (BS) backspace !! ctrl-I (HT) horizontal tabulation !! ctrl-J (LF) line feed !! ctrl-K (VT) vertical tabulation !! ctrl-L (FF) form feed !! ctrl-M (CR) carriage return !! ctrl-N (SO) shift out !! ctrl-O (SI) shift in !! ctrl-P (DLE) data link escape !! ctrl-Q (DC1) device control 1 !! ctrl-R (DC2) device control 2 !! ctrl-S (DC3) device control 3 !! ctrl-T (DC4) device control 4 !! ctrl-U (NAK) negative acknowledge !! ctrl-V (SYN) synchronous idle !! ctrl-W (ETB) end of transmission block !! ctrl-X (CAN) cancel !! ctrl-Y (EM) end of medium !! ctrl-Z (SUB) substitute !! ctrl-[ (ESC) escape !! ctrl-\ or ctrl-@ (FS) file separator !! ctrl-] (GS) group separator !! ctrl-^ or ctrl-= (RS) record separator !! ctrl-_ (US) unit separator !! space !! ! exclamation point !! " quotation marks !! # number sign !! $ currency symbol !! % percent !! & ampersand !! ' apostrophe !! ( left parenthesis !! ) right parenthesis !! * asterisk !! + plus !! , comma !! - minus !! . period !! / slash !! 0 zero !! 1 one !! 2 two !! 3 three !! 4 four !! 5 five !! 6 six !! 7 seven !! 8 eight !! 9 nine !! : colon !! ; semicolon !! < less than !! = equals !! > greater than !! ? question mark !! @ at sign !! majuscule A !! majuscule B !! majuscule C !! majuscule D !! majuscule E !! majuscule F !! majuscule G !! majuscule H !! majuscule I !! majuscule J !! majuscule K !! majuscule L !! majuscule M !! majuscule N !! majuscule O !! majuscule P !! majuscule Q !! majuscule R !! majuscule S !! majuscule T !! majuscule U !! majuscule V !! majuscule W !! majuscule X !! majuscule Y !! majuscule Z !! [ left bracket !! \ backslash !! ] right bracket !! ^ caret !! _ underscore !! ` grave accent !! miniscule a !! miniscule b !! miniscule c !! miniscule d !! miniscule e !! miniscule f !! miniscule g !! miniscule h !! miniscule i !! miniscule j !! miniscule k !! miniscule l !! miniscule m !! miniscule n !! miniscule o !! miniscule p !! miniscule q !! miniscule r !! miniscule s !! miniscule t !! miniscule u !! miniscule v !! miniscule w !! miniscule x !! miniscule y !! miniscule z !! { left brace !! | vertical line !! } right brace !! ~ tilde !! ctrl-? (DEL) delete !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain function describe(ch) result (string) ! ident_61="@(#) M_strings describe(3f) return string describing long name of a single character" character(len=1),intent(in) :: ch character(len=:),allocatable :: string ! LATER: add hex, octal, decimal, key-press description, alternate names ! ASCII character codes select case (iachar(ch)) case( 0 ); STRING="ctrl-@ or ctrl-? (NUL) null" case( 1 ); STRING="ctrl-A (SOH) start of heading" case( 2 ); STRING="ctrl-B (STX) start of text" case( 3 ); STRING="ctrl-C (ETX) end of text" case( 4 ); STRING="ctrl-D (EOT) end of transmission" case( 5 ); STRING="ctrl-E (ENQ) enquiry" case( 6 ); STRING="ctrl-F (ACK) acknowledge" case( 7 ); STRING="ctrl-G (BEL) bell" case( 8 ); STRING="ctrl-H (BS) backspace" case( 9 ); STRING="ctrl-I (HT) horizontal tabulation" case( 10 ); STRING="ctrl-J (LF) line feed" case( 11 ); STRING="ctrl-K (VT) vertical tabulation" case( 12 ); STRING="ctrl-L (FF) form feed" case( 13 ); STRING="ctrl-M (CR) carriage return" case( 14 ); STRING="ctrl-N (SO) shift out" case( 15 ); STRING="ctrl-O (SI) shift in" case( 16 ); STRING="ctrl-P (DLE) data link escape" case( 17 ); STRING="ctrl-Q (DC1) device control 1" case( 18 ); STRING="ctrl-R (DC2) device control 2" case( 19 ); STRING="ctrl-S (DC3) device control 3" case( 20 ); STRING="ctrl-T (DC4) device control 4" case( 21 ); STRING="ctrl-U (NAK) negative acknowledge" case( 22 ); STRING="ctrl-V (SYN) synchronous idle" case( 23 ); STRING="ctrl-W (ETB) end of transmission block" case( 24 ); STRING="ctrl-X (CAN) cancel" case( 25 ); STRING="ctrl-Y (EM) end of medium" case( 26 ); STRING="ctrl-Z (SUB) substitute" case( 27 ); STRING="ctrl-[ (ESC) escape" case( 28 ); STRING="ctrl-\ or ctrl-@ (FS) file separator" case( 29 ); STRING="ctrl-] (GS) group separator" case( 30 ); STRING="ctrl-^ or ctrl-= (RS) record separator" case( 31 ); STRING="ctrl-_ (US) unit separator" case( 32 ); STRING="space" case( 33 ); STRING="! exclamation point (screamer, gasper, slammer, startler, bang, shriek, pling)" case( 34 ); STRING=""" quotation marks" case( 35 ); STRING="# number sign (hash, pound sign, hashtag)" case( 36 ); STRING="$ currency symbol" case( 37 ); STRING="% percent" case( 38 ); STRING="& ampersand" case( 39 ); STRING="' apostrophe" case( 40 ); STRING="( left parenthesis" case( 41 ); STRING=") right parenthesis" case( 42 ); STRING="* asterisk" case( 43 ); STRING="+ plus" case( 44 ); STRING=", comma" case( 45 ); STRING="- minus" case( 46 ); STRING=". period" case( 47 ); STRING="/ slash" case( 48 ); STRING="0 zero" case( 49 ); STRING="1 one" case( 50 ); STRING="2 two" case( 51 ); STRING="3 three" case( 52 ); STRING="4 four" case( 53 ); STRING="5 five" case( 54 ); STRING="6 six" case( 55 ); STRING="7 seven" case( 56 ); STRING="8 eight" case( 57 ); STRING="9 nine" case( 58 ); STRING=": colon" case( 59 ); STRING="; semicolon" case( 60 ); STRING="< less than" case( 61 ); STRING="= equals" case( 62 ); STRING="> greater than" case( 63 ); STRING="? question mark" case( 64 ); STRING="@ at sign" case( 65 ); STRING="A majuscule A" case( 66 ); STRING="B majuscule B" case( 67 ); STRING="C majuscule C" case( 68 ); STRING="D majuscule D" case( 69 ); STRING="E majuscule E" case( 70 ); STRING="F majuscule F" case( 71 ); STRING="G majuscule G" case( 72 ); STRING="H majuscule H" case( 73 ); STRING="I majuscule I" case( 74 ); STRING="J majuscule J" case( 75 ); STRING="K majuscule K" case( 76 ); STRING="L majuscule L" case( 77 ); STRING="M majuscule M" case( 78 ); STRING="N majuscule N" case( 79 ); STRING="O majuscule O" case( 80 ); STRING="P majuscule P" case( 81 ); STRING="Q majuscule Q" case( 82 ); STRING="R majuscule R" case( 83 ); STRING="S majuscule S" case( 84 ); STRING="T majuscule T" case( 85 ); STRING="U majuscule U" case( 86 ); STRING="V majuscule V" case( 87 ); STRING="W majuscule W" case( 88 ); STRING="X majuscule X" case( 89 ); STRING="Y majuscule Y" case( 90 ); STRING="Z majuscule Z" case( 91 ); STRING="[ left bracket" case( 92 ); STRING="\ backslash" case( 93 ); STRING="] right bracket" case( 94 ); STRING="^ caret" case( 95 ); STRING="_ underscore" case( 96 ); STRING="` grave accent" case( 97 ); STRING="a miniscule a" case( 98 ); STRING="b miniscule b" case( 99 ); STRING="c miniscule c" case( 100 ); STRING="d miniscule d" case( 101 ); STRING="e miniscule e" case( 102 ); STRING="f miniscule f" case( 103 ); STRING="g miniscule g" case( 104 ); STRING="h miniscule h" case( 105 ); STRING="i miniscule i" case( 106 ); STRING="j miniscule j" case( 107 ); STRING="k miniscule k" case( 108 ); STRING="l miniscule l" case( 109 ); STRING="m miniscule m" case( 110 ); STRING="n miniscule n" case( 111 ); STRING="o miniscule o" case( 112 ); STRING="p miniscule p" case( 113 ); STRING="q miniscule q" case( 114 ); STRING="r miniscule r" case( 115 ); STRING="s miniscule s" case( 116 ); STRING="t miniscule t" case( 117 ); STRING="u miniscule u" case( 118 ); STRING="v miniscule v" case( 119 ); STRING="w miniscule w" case( 120 ); STRING="x miniscule x" case( 121 ); STRING="y miniscule y" case( 122 ); STRING="z miniscule z" case( 123 ); STRING="{ left brace" case( 124 ); STRING="| vertical line" case( 125 ); STRING="} right brace" case( 126 ); STRING="~ tilde" case( 127 ); STRING="ctrl-? (DEL) delete" case default STRING='UNKNOWN'//v2s(IACHAR(ch)) end select end function describe !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! getvals(3f) - [M_strings:TYPE] read arbitrary number of REAL values !! from a character variable up to size of VALUES() array !! (LICENSE:PD) !! !!##SYNOPSIS !! !! subroutine getvals(line,values,icount,ierr) !! !! character(len=*),intent(in) :: line !! class(*),intent(out) :: values(:) !! integer,intent(out) :: icount !! integer,intent(out),optional :: ierr !! !!##DESCRIPTION !! GETVALS(3f) reads a relatively arbitrary number of numeric values from !! a character variable into a REAL array using list-directed input. !! !! NOTE: In this version null values are skipped instead of meaning to leave !! that value unchanged !! !! 1,,,,,,,2 / reads VALUES=[1.0,2.0] !! !! Per list-directed rules when reading values, allowed delimiters are !! comma, semi-colon and space. !! !! the slash separator can be used to add inline comments. !! !! 10.1, 20.43e-1 ; 11 / THIS IS TREATED AS A COMMENT !! !! Repeat syntax can be used up to the size of the output array. These are !! equivalent input lines: !! !! 4*10.0 !! 10.0, 10.0, 10.0, 10.0 !! !!##OPTIONS !! LINE A character variable containing the characters representing !! a list of numbers !! !!##RETURNS !! VALUES() array holding numbers read from string. May be of type !! INTEGER, REAL, DOUBLEPRECISION, or CHARACTER. If CHARACTER the !! strings are returned as simple words instead of numeric values. !! ICOUNT number of defined numbers in VALUES(). If ICOUNT reaches !! the size of the VALUES() array parsing stops. !! IERR zero if no error occurred in reading numbers. Optional. !! If not present and an error occurs the program is terminated. !! !!##EXAMPLES !! !! Sample program: !! !! program demo_getvals !! use M_strings, only: getvals !! implicit none !! integer,parameter :: longest_line=256 !! character(len=longest_line) :: line !! real :: values(longest_line/2+1) !! integer :: ios,icount,ierr !! INFINITE: do !! read(*,'(a)',iostat=ios) line !! if(ios /= 0)exit INFINITE !! call getvals(line,values,icount,ierr) !! write(*,'(4(g0,1x))')'VALUES=',values(:icount) !! enddo INFINITE !! end program demo_getvals !! !! Sample input lines !! !! 10,20 30.4 !! 1 2 3 !! 1 !! !! 3 4*2.5 8 !! 32.3333 / comment 1 !! 30e3;300, 30.0, 3 !! even 1 like this! 10 !! 11,,,,22,,,,33 !! !! Expected output: !! !! VALUES= 10.0000000 20.0000000 30.3999996 !! VALUES= 1.00000000 2.00000000 3.00000000 !! VALUES= 1.00000000 !! VALUES= !! VALUES= 3.00000000 2.50000000 2.50000000 !! 2.50000000 2.50000000 8.00000000 !! VALUES= 32.3333015 !! VALUES= 30000.0000 300.000000 30.0000000 !! 3.00000000 !! *getvals* WARNING:[even] is not a number !! *getvals* WARNING:[like] is not a number !! *getvals* WARNING:[this!] is not a number !! VALUES= 1.00000000 10.0000000 !! VALUES= 11.0000000 22.0000000 33.0000000 !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain subroutine getvals(line,values,icount,ierr) ! ident_62="@(#) M_strings getvals(3f) read arbitrary number of values from a character variable" ! JSU 20170831 character(len=*),intent(in) :: line class(*),intent(out) :: values(:) integer,intent(out) :: icount integer,intent(out),optional :: ierr character(len=:),allocatable :: buffer character(len=len(line)) :: words(size(values)) integer :: ios, i, ierr_local,isize isize=0 select type(values) type is (integer); isize=size(values) type is (real); isize=size(values) type is (doubleprecision); isize=size(values) type is (character(len=*)); isize=size(values) end select ierr_local=0 words=' ' ! make sure words() is initialized to null+blanks buffer=trim(unquote(line))//"/" ! add a slash to the end so how the read behaves with missing values is clearly defined read(buffer,*,iostat=ios) words ! undelimited strings are read into an array icount=0 do i=1,isize ! loop thru array and convert non-blank words to numbers if(words(i) == ' ')cycle select type(values) type is (integer); read(words(i),*,iostat=ios)values(icount+1) type is (real); read(words(i),*,iostat=ios)values(icount+1) type is (doubleprecision); read(words(i),*,iostat=ios)values(icount+1) type is (character(len=*)); values(icount+1)=words(i) end select if(ios == 0)then icount=icount+1 else ierr_local=ios write(ERROR_UNIT,*)'*getvals* WARNING:['//trim(words(i))//'] is not a number of specified type' endif enddo if(present(ierr))then ierr=ierr_local elseif(ierr_local /= 0)then ! error occurred and not returning error to main program to print message and stop program write(ERROR_UNIT,*)'*getval* error reading line ['//trim(line)//']' stop 2 endif end subroutine getvals !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! string_to_values(3f) - [M_strings:TYPE] read a string representing !! numbers into a numeric array !! (LICENSE:PD) !! !!##SYNOPSIS !! !! subroutine string_to_values(line,iread,values,inums,delims,ierr) !! !! character(len=*) :: line !! integer :: iread !! real :: values(*) !! integer :: inums !! character(len=*) :: delims !! integer :: ierr !! !!##DESCRIPTION !! This routine can take a string representing a series of numbers and !! convert it to a numeric array and return how many numbers were found. !! !!##OPTIONS !! LINE Input string containing numbers !! IREAD maximum number of values to try to read from input string !! !!##RESULTS !! VALUES real array to be filled with numbers !! INUMS number of values successfully read (before error occurs !! if one does) !! DELIMS delimiter character(s), usually a space. must not be a !! null string. If more than one character, a space must !! not be the last character or it will be ignored. !! IERR error flag (0=no error, else column number string starts !! at that error occurred on). !! !!##EXAMPLE !! !! Sample Program: !! !! program demo_string_to_values !! use M_strings, only : string_to_values !! implicit none !! character(len=80) :: s=' 10 20e3;3.45 -400.3e-2;1234; 5678 ' !! integer,parameter :: isz=10 !! real :: array(isz) !! integer :: inums, ierr, ii !! !! call string_to_values(s,10,array,inums,' ;',ierr) !! call reportit() !! !! call string_to_values('10;2.3;3.1416',isz,array,inums,' ;',ierr) !! call reportit() !! !! contains !! subroutine reportit() !! write(*,*)'string_to_values:' !! write(*,*)'input string.............',trim(s) !! write(*,*)'number of values found...',inums !! write(*,*)'values...................',(array(ii),ii=1,inums) !! end subroutine reportit !! end program demo_string_to_values !! !! Expected output !! !! string_to_values: !! input string............. 10 20e3;3.45 -400.3e-2;1234; 5678 !! number of values found... 6 !! values................... 10.0000000 20000.0000 3.45000005 !! -4.00299978 1234.00000 5678.00000 !! string_to_values: !! input string............. 10 20e3;3.45 -400.3e-2;1234; 5678 !! number of values found... 3 !! values................... 10.0000000 2.29999995 3.14159989 !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain subroutine string_to_values(line,iread,values,inums,delims,ierr) !---------------------------------------------------------------------------------------------------------------------------------- ! 1989,1997-12-31,2014 John S. Urban ! given a line of structure , string , string , string process each ! string as a numeric value and store into an array. ! DELIMS contain the legal delimiters. If a space is an allowed delimiter, it must not appear last in DELIMS. ! There is no direct checking for more values than can fit in VALUES. ! Quits if encounters any errors in read. !---------------------------------------------------------------------------------------------------------------------------------- ! ident_63="@(#) M_strings string_to_values(3f) reads an array of numbers from a numeric string" character(len=*),intent(in) :: line ! input string integer,intent(in) :: iread ! maximum number of values to try to read into values real,intent(inout) :: values(iread) ! real array to be filled with values integer,intent(out) :: inums ! number of values successfully read from string character(len=*),intent(in) :: delims ! allowed delimiters integer,intent(out) :: ierr ! 0 if no error, else column number undecipherable string starts at !---------------------------------------------------------------------------------------------------------------------------------- character(len=256) :: delims_local ! mutable copy of allowed delimiters integer :: istart,iend,lgth,icol integer :: i10,i20,i40 real :: rval integer :: ier integer :: delimiters_length !---------------------------------------------------------------------------------------------------------------------------------- delims_local=delims ! need a mutable copy of the delimiter list if(delims_local == '')then ! if delimiter list is null or all spaces make it a space delims_local=' ' ! delimiter is a single space delimiters_length=1 ! length of delimiter list else delimiters_length=len_trim(delims) ! length of variable WITH TRAILING WHITESPACE TRIMMED endif !---------------------------------------------------------------------------------------------------------------------------------- ierr=0 ! initialize error code returned inums=0 ! initialize count of values successfully returned istart=0 !---------------------------------------------------------------------------------------------------------------------------------- lgth=0 ! lgth will be the position of the right-most non-delimiter in the input line do i20=len(line),1,-1 ! loop from end of string to beginning to find right-most non-delimiter if(index(delims_local(:delimiters_length),line(i20:i20)) == 0)then ! found a non-delimiter lgth=i20 exit endif enddo if(lgth == 0)then ! command was totally composed of delimiters call journal('*string_to_values* blank line passed as a list of numbers') return endif !---------------------------------------------------------------------------------------------------------------------------------- ! there is at least one non-delimiter sub-string ! lgth is the column position of the last non-delimiter character ! now, starting at beginning of string find next non-delimiter icol=1 ! pointer to beginning of unprocessed part of LINE LOOP: dO i10=1,iread,1 ! each pass should find a value if(icol > lgth) EXIT LOOP ! everything is done INFINITE: do if(index(delims_local(:delimiters_length),line(icol:icol)) == 0)then ! found non-delimiter istart=icol iend=0 ! FIND END OF SUBSTRING do i40=istart,lgth ! look at each character starting at left if(index(delims_local(:delimiters_length),line(i40:i40)) /= 0)then ! determine if character is a delimiter iend=i40 ! found a delimiter. record where it was found EXIT ! found end of substring so leave loop endif enddo if(iend == 0)iend=lgth+1 ! no delimiters found, so this substring goes to end of line iend=iend-1 ! do not want to pass delimiter to be converted rval=0.0 call string_to_value(line(istart:iend),rval,ier) ! call procedure to convert string to a numeric value if(ier == 0)then ! a substring was successfully converted to a numeric value values(i10)=rval ! store numeric value in return array inums=inums+1 ! increment number of values converted to a numeric value else ! an error occurred converting string to value ierr=istart ! return starting position of substring that could not be converted return endif icol=iend+2 ! set to next character to look at CYCLE LOOP ! start looking for next value else ! this is a delimiter so keep looking for start of next string icol=icol+1 ! increment pointer into LINE CYCLE INFINITE endif enddo INFINITE enddo LOOP ! error >>>>> more than iread numbers were in the line. end subroutine string_to_values !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! s2vs(3f) - [M_strings:TYPE] given a string representing numbers !! return a numeric array !! (LICENSE:PD) !! !!##SYNOPSIS !! !! function s2vs(line[,delim]) !! !! character(len=*) :: line !! doubleprecision,allocatable :: s2vs(:) !! !!##DESCRIPTION !! The function S2VS(3f) takes a string representing a series of numbers !! and converts it to a numeric doubleprecision array. The string values !! may be delimited by spaces, semi-colons, and commas by default. !! !!##OPTIONS !! LINE Input string containing numbers !! DELIM optional list of delimiter characters. If a space is !! included, it should appear as the left-most character !! in the list. The default is " ;," (spaces, semi-colons, !! and commas). !! !!##RESULTS !! S2VS doubleprecision array !! !!##EXAMPLE !! !! Sample Program: !! !! program demo_s2vs !! use M_strings, only : s2vs !! implicit none !! character(len=80) :: s=' 10 20e3;3.45 -400.3e-2;1234; 5678 ' !! real,allocatable :: values(:) !! integer,allocatable :: ivalues(:) !! integer :: ii !! !! values=s2vs(s) !! ivalues=int(s2vs(s)) !! call reportit() !! !! contains !! subroutine reportit() !! write(*,*)'S2VS:' !! write(*,*)'input string.............',& !! & trim(s) !! write(*,*)'number of values found...',& !! & size(values) !! write(*,*)'values...................',& !! & (values(ii),ii=1,size(values)) !! write(*,'(*(g0,1x))')'ivalues..................',& !! & (ivalues(ii),ii=1,size(values)) !! end subroutine reportit !! end program demo_s2vs !! !! Expected output !! !! S2VS: !! input string............. 10 20e3;3.45 -400.3e-2;1234; 5678 !! number of values found... 6 !! values................... 10.0000000 20000.0000 3.45000005 !! -4.00299978 1234.00000 5678.00000 !! ivalues.................. 10 20000 3 -4 1234 5678 !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain function s2vs(string,delim) result(darray) ! ident_64="@(#) M_strings s2vs(3f) function returns array of values from a string" character(len=*),intent(in) :: string ! keyword to retrieve value for from dictionary character(len=*),optional :: delim ! delimiter characters character(len=:),allocatable :: delim_local doubleprecision,allocatable :: darray(:) ! function type character(len=:),allocatable :: carray(:) ! convert value to an array using split(3f) integer :: i integer :: ier !----------------------------------------------------------------------------------------------------------------------------------- if(present(delim))then delim_local=delim else delim_local=' ;,' endif !----------------------------------------------------------------------------------------------------------------------------------- call split(string,carray,delimiters=delim_local) ! split string into an array allocate(darray(size(carray))) ! create the output array do i=1,size(carray) call string_to_value(carray(i), darray(i), ier) ! convert the string to a numeric value enddo !----------------------------------------------------------------------------------------------------------------------------------- end function s2vs !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! isprint(3f) - [M_strings:COMPARE] returns .true. if character is an !! ASCII printable character !! (LICENSE:PD) !! !!##SYNOPSIS !! !! !! elemental function isprint(onechar) !! !! character,intent(in) :: onechar !! logical :: isprint !! !!##DESCRIPTION !! isprint(3f) returns .true. if character is an ASCII printable character !! !!##OPTIONS !! onechar character to test !! !!##RETURNS !! isprint logical value returns true if character is a !! printable ASCII character else false. !!##EXAMPLE !! !! Sample Program: !! !! program demo_isprint !! use M_strings, only : isprint !! implicit none !! integer :: i !! character(len=1),parameter :: string(*)=[(char(i),i=0,127)] !! write(*,'(40(a))')'ISPRINT: ',pack( string, isprint(string) ) !! end program demo_isprint !! !! Results: !! !! ISPRINT: !"#$%&'()*+,-./0123456789:;<=>?@ABCDEF !! GHIJKLMNOPQRSTUVWXYZ[\]^_`abcdefghijklmn !! opqrstuvwxyz{|}~ !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain elemental function isprint(onechar) ! ident_65="@(#) M_strings isprint(3f) indicates if input character is a printable ASCII character" character,intent(in) :: onechar logical :: isprint select case (onechar) case (' ':'~') ; isprint=.TRUE. case default ; isprint=.FALSE. end select end function isprint !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! isgraph(3f) - [M_strings:COMPARE] returns .true. if character is a !! printable character except a space is considered non-printable !! (LICENSE:PD) !! !!##SYNOPSIS !! !! !! elemental function isgraph(onechar) !! !! character,intent(in) :: onechar !! logical :: isgraph !! !!##DESCRIPTION !! isgraph(3f) returns .true. if character is a printable character !! except a space is considered non-printable !! !!##OPTIONS !! onechar character to test !! !!##RETURNS !! isgraph logical value returns true if character is a printable !! non-space character !!##EXAMPLE !! !! Sample Program: !! !! program demo_isgraph !! use M_strings, only : isgraph !! implicit none !! integer :: i !! character(len=1),parameter :: string(*)=[(char(i),i=0,127)] !! write(*,'(40(a))')'ISGRAPH: ',pack( string, isgraph(string) ) !! end program demo_isgraph !! !! Results: !! !! ISGRAPH: !"#$%&'()*+,-./0123456789:;<=>?@ABCDEFG !! HIJKLMNOPQRSTUVWXYZ[\]^_`abcdefghijklmno !! pqrstuvwxyz{|}~ !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain elemental function isgraph(onechar) ! ident_66="@(#) M_strings isgraph(3f) indicates if character is printable ASCII character excluding space" character,intent(in) :: onechar logical :: isgraph select case (iachar(onechar)) case (33:126) isgraph=.TRUE. case default isgraph=.FALSE. end select end function isgraph !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! isalpha(3f) - [M_strings:COMPARE] returns .true. if character is a !! letter and .false. otherwise !! (LICENSE:PD) !! !!##SYNOPSIS !! !! !! elemental function isalpha(onechar) !! !! character,intent(in) :: onechar !! logical :: isalpha !! !!##DESCRIPTION !! isalpha(3f) returns .true. if character is a letter and !! .false. otherwise !! !!##OPTIONS !! onechar character to test !! !!##RETURNS !! isalpha logical value returns .true. if character is a ASCII letter !! or false otherwise. !!##EXAMPLE !! !! !! Sample program !! !! program demo_isalpha !! use M_strings, only : isalpha !! implicit none !! integer :: i !! character(len=1),parameter :: string(*)=[(char(i),i=0,127)] !! write(*,'(40(a))')'ISGRAPH: ',pack( string, isalpha(string) ) !! end program demo_isalpha !! !! Results: !! !! ISGRAPH: ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklm !! nopqrstuvwxyz !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain elemental function isalpha(ch) result(res) ! ident_67="@(#) M_strings isalpha(3f) Return .true. if character is a letter and .false. otherwise" character,intent(in) :: ch logical :: res select case(ch) case('A':'Z','a':'z') res=.true. case default res=.false. end select end function isalpha !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! isxdigit(3f) - [M_strings:COMPARE] returns .true. if character is a !! hexadecimal digit (0-9, a-f, or A-F). !! (LICENSE:PD) !! !!##SYNOPSIS !! !! !! elemental function isxdigit(onechar) !! !! character,intent(in) :: onechar !! logical :: isxdigit !! !!##DESCRIPTION !! isxdigit(3f) returns .true. if character is a hexadecimal digit (0-9, !! a-f, or A-F). !! !!##OPTIONS !! onechar character to test !! !!##RETURNS !! isxdigit logical value returns true if character is a hexadecimal digit !! !!##EXAMPLE !! !! Sample program !! !! program demo_isxdigit !! use M_strings, only : isxdigit !! implicit none !! integer :: i !! character(len=1),parameter :: string(*)=[(char(i),i=0,127)] !! write(*,'(40(a))')'ISXDIGIT: ',pack( string, isxdigit(string) ) !! end program demo_isxdigit !! !! Results: !! !! ISXDIGIT: 0123456789ABCDEFabcdef !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain elemental function isxdigit(ch) result(res) ! ident_68="@(#) M_strings isxdigit(3f) returns .true. if c is a hexadecimal digit (0-9 a-f or A-F)" character,intent(in) :: ch logical :: res select case(ch) case('A':'F','a':'f','0':'9') res=.true. case default res=.false. end select end function isxdigit !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! isdigit(3f) - [M_strings:COMPARE] returns .true. if character is a !! digit (0,1,...,9) and .false. otherwise !! (LICENSE:PD) !! !!##SYNOPSIS !! !! !! elemental function isdigit(onechar) !! !! character,intent(in) :: onechar !! logical :: isdigit !! !!##DESCRIPTION !! isdigit(3f) returns .true. if character is a digit (0,1,...,9) !! and .false. otherwise !! !!##EXAMPLES !! !! !! Sample Program: !! !! program demo_isdigit !! use M_strings, only : isdigit, isspace, switch !! implicit none !! character(len=10),allocatable :: string(:) !! integer :: i !! string=[& !! & '1 2 3 4 5 ' ,& !! & 'letters ' ,& !! & '1234567890' ,& !! & 'both 8787 ' ] !! ! if string is nothing but digits and whitespace return .true. !! do i=1,size(string) !! write(*,'(a)',advance='no')'For string['//string(i)//']' !! write(*,*) & !! & all(isdigit(switch(string(i))).or.& !! & isspace(switch(string(i)))) !! enddo !! end program demo_isdigit !! !! Expected output: !! !! For string[1 2 3 4 5 ] T !! For string[letters ] F !! For string[1234567890] T !! For string[both 8787 ] F !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain elemental function isdigit(ch) result(res) ! ident_69="@(#) M_strings isdigit(3f) Returns .true. if ch is a digit (0-9) and .false. otherwise" character,intent(in) :: ch logical :: res select case(ch) case('0':'9') res=.true. case default res=.false. end select end function isdigit !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! isblank(3f) - [M_strings:COMPARE] returns .true. if character is a !! blank character (space or horizontal tab). !! (LICENSE:PD) !! !!##SYNOPSIS !! !! !! elemental function isblank(onechar) !! !! character,intent(in) :: onechar !! logical :: isblank !! !!##DESCRIPTION !! isblank(3f) returns .true. if character is a blank character (space !! or horizontal tab). !! !!##OPTIONS !! onechar character to test !! !!##RETURNS !! isblank logical value returns true if character is a "blank" !! ( an ASCII space or horizontal tab character). !!##EXAMPLE !! !! Sample program: !! !! program demo_isblank !! use M_strings, only : isblank !! implicit none !! integer :: i !! character(len=1),parameter :: string(*)=[(char(i),i=0,127)] !! write(*,'(*(g0,1x))')'ISXBLANK: ',& !! & iachar(pack( string, isblank(string) )) !! end program demo_isblank !! !! Results: !! !! ISXBLANK: 9 32 !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain elemental function isblank(ch) result(res) ! ident_70="@(#) M_strings isblank(3f) returns .true. if character is a blank (space or horizontal tab)" character,intent(in) :: ch logical :: res select case(ch) case(' ',char(9)) res=.true. case default res=.false. end select end function isblank !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! isascii(3f) - [M_strings:COMPARE] returns .true. if the character is !! in the range char(0) to char(256) !! (LICENSE:PD) !! !!##SYNOPSIS !! !! !! elemental function isascii(onechar) !! !! character,intent(in) :: onechar !! logical :: isascii !! !!##DESCRIPTION !! isascii(3f) returns .true. if the character is in the range char(0) !! to char(127) !! !!##OPTIONS !! onechar character to test !! !!##RETURNS !! isupper logical value returns true if character is an ASCII !! character. !!##EXAMPLE !! !! Sample program !! !! program demo_isascii !! use M_strings, only : isascii !! implicit none !! integer :: i !! character(len=1),parameter :: string(*)=[(char(i),i=0,255)] !! write(*,'(10(g0,1x))')'ISASCII: ', & !! & iachar(pack( string, isascii(string) )) !! end program demo_isascii !! !! Results: !! !! ISASCII: 0 1 2 3 4 5 6 7 8 !! 9 10 11 12 13 14 15 16 17 18 !! 19 20 21 22 23 24 25 26 27 28 !! 29 30 31 32 33 34 35 36 37 38 !! 39 40 41 42 43 44 45 46 47 48 !! 49 50 51 52 53 54 55 56 57 58 !! 59 60 61 62 63 64 65 66 67 68 !! 69 70 71 72 73 74 75 76 77 78 !! 79 80 81 82 83 84 85 86 87 88 !! 89 90 91 92 93 94 95 96 97 98 !! 99 100 101 102 103 104 105 106 107 108 !! 109 110 111 112 113 114 115 116 117 118 !! 119 120 121 122 123 124 125 126 127 !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain elemental function isascii(ch) result(res) ! ident_71="@(#) M_strings isascii(3f) returns .true. if character is in the range char(0) to char(127)" character,intent(in) :: ch logical :: res select case(iachar(ch)) case(0:127) res=.true. case default res=.false. end select end function isascii !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! isspace(3f) - [M_strings:COMPARE] returns .true. if character is a !! null, space, tab, carriage return, new line, vertical tab, or formfeed !! (LICENSE:PD) !! !!##SYNOPSIS !! !! !! elemental function isspace(onechar) !! !! character,intent(in) :: onechar !! logical :: isspace !! !!##DESCRIPTION !! isspace(3f) returns .true. if character is a null, space, tab, !! carriage return, new line, vertical tab, or formfeed !! !!##OPTIONS !! onechar character to test !! !!##RETURNS !! isspace returns true if character is ASCII white space !! !!##EXAMPLE !! !! Sample program: !! !! program demo_isspace !! use M_strings, only : isspace !! implicit none !! integer :: i !! character(len=1),parameter :: string(*)=[(char(i),i=0,127)] !! write(*,'(20(g0,1x))')'ISSPACE: ', & !! & iachar(pack( string, isspace(string) )) !! end program demo_isspace !! !! Results: !! !! ISSPACE: 0 9 10 11 12 13 32 !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain elemental function isspace(ch) result(res) ! ident_72="@(#) M_strings isspace(3f) true if null space tab return new line vertical tab or formfeed" character,intent(in) :: ch logical :: res select case(ch) case(' ') ! space(32) res=.true. case(char(0)) ! null(0) res=.true. case(char(9):char(13)) ! tab(9), new line(10), vertical tab(11), formfeed(12), carriage return(13), res=.true. case default res=.false. end select end function isspace !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! iscntrl(3f) - [M_strings:COMPARE] returns .true. if character is a !! delete character or ordinary control character !! (LICENSE:PD) !! !!##SYNOPSIS !! !! !! elemental function iscntrl(onechar) !! !! character,intent(in) :: onechar !! logical :: iscntrl !! !!##DESCRIPTION !! iscntrl(3f) returns .true. if character is a delete character or !! ordinary control character !! !!##OPTIONS !! onechar character to test !! !!##RETURNS !! iscntrl logical value returns true if character is a control character !! !!##EXAMPLE !! !! Sample program !! !! program demo_iscntrl !! use M_strings, only : iscntrl !! implicit none !! integer :: i !! character(len=1),parameter :: string(*)=[(char(i),i=0,127)] !! write(*,'(20(g0,1x))')'ISCNTRL: ', & !! & iachar(pack( string, iscntrl(string) )) !! end program demo_iscntrl !! !! Results: !! !! ISCNTRL: 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 !! 20 21 22 23 24 25 26 27 28 29 30 31 127 !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain elemental function iscntrl(ch) result(res) ! ident_73="@(#) M_strings iscntrl(3f) true if a delete or ordinary control character(0x7F or 0x00-0x1F)" character,intent(in) :: ch logical :: res select case(ch) case(char(127),char(0):char(31)) res=.true. case default res=.false. end select end function iscntrl !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! ispunct(3f) - [M_strings:COMPARE] returns .true. if character is a !! printable punctuation character !! (LICENSE:PD) !! !!##SYNOPSIS !! !! !! elemental function ispunct(onechar) !! !! character,intent(in) :: onechar !! logical :: ispunct !! !!##DESCRIPTION !! ispunct(3f) returns .true. if character is a printable punctuation !! character !! !!##OPTIONS !! onechar character to test !! !!##RETURNS !! ispunct logical value returns true if character is a printable !! punctuation character. !! !!##EXAMPLE !! !! Sample program: !! !! program demo_ispunct !! use M_strings, only : ispunct !! implicit none !! integer :: i !! character(len=1),parameter :: string(*)=[(char(i),i=0,127)] !! write(*,'(20(g0,1x))')'ISPUNCT: ', & !! & iachar(pack( string, ispunct(string) )) !! write(*,'(20(g0,1x))')'ISPUNCT: ', & !! & pack( string, ispunct(string) ) !! end program demo_ispunct !! Results: !! !! ISPUNCT: 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 58 59 60 61 !! 62 63 64 91 92 93 94 95 96 123 124 125 126 !! ISPUNCT: ! " # $ % & ' ( ) * + , - . / : ; < = !! > ? @ [ \ ] ^ _ ` { | } ~ !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain elemental function ispunct(ch) result(res) ! ident_74="@(#) M_strings ispunct(3f) true if a printable punctuation character (isgraph(c)&&!isalnum(c))" character,intent(in) :: ch logical :: res select case(ch) case (char(33):char(47), char(58):char(64), char(91):char(96), char(123):char(126)) res=.true. ! case(' ','0':'9','A':'Z','a':'z',char(128):) ! res=.true. ! case(char(0):char(31),char(127)) ! res=.true. case default res=.false. end select end function ispunct !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! fortran_name(3f) - [M_strings:COMPARE] test if string meets criteria !! for being a fortran name !! !!##SYNOPSIS !! !! !! elemental function fortran_name(line) result (lout) !! !! character(len=*),intent(in) :: line !! logical :: lout !! !!##DESCRIPTION !! Determines if a string is an allowed Fortran name. To pass the input !! string must be composed of 1 to 63 ASCII characters and start with a !! letter and be composed entirely of alphanumeric characters [a-zA-Z0-9] !! and underscores. !! !!##OPTIONS !! LINE input string to test. Leading spaces are significant but !! trailing spaces are ignored. !! !!##RETURNS !! LOUT a logical value indicating if the input string passed or failed !! the test to see if it is a valid Fortran name or not. !! !!##EXAMPLE !! !! Sample program !! !! program demo_fortran_name !! use M_strings, only : fortran_name !! implicit none !! character(len=20),parameter :: names(*)=[character(len=20) :: & !! & '_name', 'long_variable_name', 'name_', & !! & '12L', 'a__b__c ', 'PropertyOfGas', & !! & '3%3', '$NAME', ' ', & !! & 'Variable-name', 'A', 'x@x' ] !! integer :: i !! write(*,'(i3,1x,a20,1x,l1)')& !! & (i,names(i),fortran_name(names(i)),i=1,size(names)) !! end program demo_fortran_name !! !! Results: !! !! > 1 _name F !! > 2 long_variable_name T !! > 3 name_ T !! > 4 12L F !! > 5 a__b__c T !! > 6 PropertyOfGas T !! > 7 3%3 F !! > 8 $NAME F !! > 9 F !! > 10 Variable-name F !! > 11 A T !! > 12 x@x F elemental function fortran_name(line) result (lout) ! ident_75="@(#) M_strings fortran_name(3f) Return .true. if name is a valid Fortran name" ! determine if a string is a valid Fortran name ignoring trailing spaces (but not leading spaces) character(len=*),parameter :: int='0123456789' character(len=*),parameter :: lower='abcdefghijklmnopqrstuvwxyz' character(len=*),parameter :: upper='ABCDEFGHIJKLMNOPQRSTUVWXYZ' character(len=*),parameter :: allowed=upper//lower//int//'_' character(len=*),intent(in) :: line character(len=:),allocatable :: name logical :: lout name=trim(line) if(len(name) /= 0)then lout = verify(name(1:1), lower//upper) == 0 & & .and. verify(name,allowed) == 0 & & .and. len(name) <= 63 else lout = .false. endif end function fortran_name !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! isupper(3f) - [M_strings:COMPARE] returns .true. if character is an !! uppercase letter (A-Z) !! (LICENSE:PD) !! !!##SYNOPSIS !! !! !! elemental function isupper(onechar) !! !! character,intent(in) :: onechar !! logical :: isupper !! !!##DESCRIPTION !! isupper(3f) returns .true. if character is an uppercase letter (A-Z) !! !!##OPTIONS !! onechar character to test !!##RETURNS !! isupper logical value returns true if character is an uppercase !! ASCII character else false. !!##EXAMPLE !! !! Sample program: !! !! program demo_isupper !! use M_strings, only : isupper !! implicit none !! integer :: i !! character(len=1),parameter :: string(*)=[(char(i),i=0,127)] !! write(*,'(10(g0,1x))')'ISUPPER: ', & !! & iachar(pack( string, isupper(string) )) !! write(*,'(10(g0,1x))')'ISUPPER: ', & !! & pack( string, isupper(string) ) !! end program demo_isupper !! !! Results: !! !! ISUPPER: 65 66 67 68 69 70 71 72 73 !! 74 75 76 77 78 79 80 81 82 83 !! 84 85 86 87 88 89 90 !! ISUPPER: A B C D E F G H I !! J K L M N O P Q R S !! T U V W X Y Z !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain pure elemental function isupper(ch) result(res) ! ident_76="@(#) M_strings isupper(3f) returns true if character is an uppercase letter (A-Z)" character,intent(in) :: ch logical :: res select case(ch) case('A':'Z'); res=.true. case default; res=.false. end select end function isupper !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! islower(3f) - [M_strings:COMPARE] returns .true. if character is a !! miniscule letter (a-z) !! (LICENSE:PD) !! !!##SYNOPSIS !! !! !! elemental function islower(onechar) !! !! character,intent(in) :: onechar !! logical :: islower !! !!##DESCRIPTION !! islower(3f) returns .true. if character is a miniscule letter (a-z) !! !!##OPTIONS !! onechar character to test !! !!##RETURNS !! islower logical value returns true if character is a lowercase !! ASCII character else false. !!##EXAMPLE !! !! Sample program !! !! program demo_islower !! use M_strings, only : islower !! implicit none !! integer :: i !! character(len=1),parameter :: string(*)=[(char(i),i=0,127)] !! write(*,'(15(g0,1x))')'ISLOWER: ', & !! & iachar(pack( string, islower(string) )) !! write(*,'(15(g0,1x))')'ISLOWER: ', & !! & pack( string, islower(string) ) !! end program demo_islower !! Results: !! !! ISLOWER: 97 98 99 100 101 102 103 104 105 106 107 108 109 110 !! 111 112 113 114 115 116 117 118 119 120 121 122 !! ISLOWER: a b c d e f g h i j k l m n !! o p q r s t u v w x y z !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain elemental function islower(ch) result(res) ! ident_77="@(#) M_strings islower(3f) returns true if character is a miniscule letter (a-z)" character,intent(in) :: ch logical :: res select case(ch) case('a':'z'); res=.true. case default; res=.false. end select end function islower !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! isalnum,isalpha,iscntrl,isdigit,isgraph,islower, !! isprint,ispunct,isspace,isupper, !! isascii,isblank,isxdigit(3f) - [M_strings:COMPARE] test membership in !! subsets of ASCII set !! (LICENSE:PD) !! !!##SYNOPSIS !! !! Where "FUNCNAME" is one of the function names in the group, the !! functions are defined by !! !! elemental function FUNCNAME(onechar) !! character,intent(in) :: onechar !! logical :: FUNC_NAME !!##DESCRIPTION !! !! These elemental functions test if a character belongs to various !! subsets of the ASCII character set. !! !! isalnum returns .true. if character is a letter (a-z,A-Z) !! or digit (0-9) !! isalpha returns .true. if character is a letter and !! .false. otherwise !! isascii returns .true. if character is in the range char(0) !! to char(127) !! isblank returns .true. if character is a blank (space or !! horizontal tab). !! iscntrl returns .true. if character is a delete character or !! ordinary control character (0x7F or 0x00-0x1F). !! isdigit returns .true. if character is a digit (0,1,...,9) !! and .false. otherwise !! isgraph returns .true. if character is a printable ASCII !! character excluding space !! islower returns .true. if character is a miniscule letter (a-z) !! isprint returns .true. if character is a printable ASCII character !! ispunct returns .true. if character is a printable punctuation !! character (isgraph(c) && !isalnum(c)). !! isspace returns .true. if character is a null, space, tab, !! carriage return, new line, vertical tab, or formfeed !! isupper returns .true. if character is an uppercase letter (A-Z) !! isxdigit returns .true. if character is a hexadecimal digit !! (0-9, a-f, or A-F). !! !!##EXAMPLES !! !! Sample Program: !! !! program demo_isdigit !! !! use M_strings, only : isdigit, isspace, switch !! implicit none !! character(len=10),allocatable :: string(:) !! integer :: i !! string=[& !! & '1 2 3 4 5 ' ,& !! & 'letters ' ,& !! & '1234567890' ,& !! & 'both 8787 ' ] !! ! if string is nothing but digits and whitespace return .true. !! do i=1,size(string) !! write(*,'(a)',advance='no')'For string['//string(i)//']' !! write(*,*) & !! all(isdigit(switch(string(i))) .or. & !! & isspace(switch(string(i)))) !! enddo !! !! end program demo_isdigit !! !! Expected output: !! !! For string[1 2 3 4 5 ] T !! For string[letters ] F !! For string[1234567890] T !! For string[both 8787 ] F !! !!##AUTHOR !! John S. Urban !!##LICENSE !! Public Domain elemental function isalnum(ch) result(res) ! ident_78="@(#) M_strings isalnum(3f) returns true if character is a letter (a-z A-Z) or digit(0-9)" character,intent(in) :: ch logical :: res select case(ch) case('a':'z','A':'Z','0':'9') res=.true. case default res=.false. end select end function isalnum !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! base(3f) - [M_strings:BASE] convert whole number string in base [2-36] !! to string in alternate base [2-36] !! (LICENSE:PD) !! !!##SYNOPSIS !! !! logical function base(x,b,y,a) !! !! character(len=*),intent(in) :: x !! character(len=*),intent(out) :: y !! integer,intent(in) :: b,a !!##DESCRIPTION !! !! Convert a numeric string from base B to base A. The function returns !! FALSE if B is not in the range [2..36] or if string X contains invalid !! characters in base B or if result Y is too big !! !! The letters A,B,...,Z represent 10,11,...,36 in a base > 10. !! !!##OPTIONS !! x input string representing numeric whole value !! b assumed base of input string !! y output string !! a base specified for output string !! !!##EXAMPLE !! !! Sample program: !! !! program demo_base !! use M_strings, only : base !! implicit none !! integer :: ba,bd !! character(len=40) :: x,y !! !! print *,' BASE CONVERSION' !! write(*,'("Start Base (2 to 36): ")',advance='no'); read *, bd !! write(*,'("Arrival Base (2 to 36): ")',advance='no'); read *, ba !! INFINITE: do !! write(*,'("Enter number in start base (0 to quit): ")',advance='no') !! read *, x !! if(x == '0') exit INFINITE !! if(base(x,bd,y,ba))then !! write(*,'("In base ",I2,": ",A20)') ba, y !! else !! print *,'Error in decoding/encoding number.' !! endif !! enddo INFINITE !! !! end program demo_base !! !!##AUTHOR !! John S. Urban !!##LICENSE !! Public Domain logical function base(x,b,y,a) character(len=*),intent(in) :: x character(len=*),intent(out) :: y integer,intent(in) :: b,a integer :: temp ! ident_79="@(#) M_strings base(3f) convert whole number string in base [2-36] to string in alternate base [2-36]" base=.true. if(decodebase(x,b,temp)) then if(codebase(temp,a,y)) then else print *,'Error in coding number.' base=.false. endif else print *,'Error in decoding number.' base=.false. endif end function base !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! base2(3f) - [M_strings:BASE] convert whole number to string in base 2 !! (LICENSE:PD) !! !!##SYNOPSIS !! !! function base2(int) !! !! integer,intent(in) :: int !! character(len=:),allocatable :: base2 !! !!##DESCRIPTION !! !! Convert a whole number to a string in base 2. !! !! This is often done with the B edit descriptor and !! an internal WRITE() statement, but is done without !! calling the I/O routines, and as a function. !! !!##OPTIONS !! int input string representing numeric whole value !!##RETURNS !! base2 string representing input value in base 2 !!##EXAMPLE !! !! Sample program: !! !! program demo_base2 !! use M_strings, only : base2 !! implicit none !! write(*,'(a)') base2(huge(0)) !! write(*,'(a)') base2(0) !! write(*,'(a)') base2(64) !! write(*,'(a)') base2(-64) !! write(*,'(a)') base2(-huge(0)-1) !! end program demo_base2 !! Results: !! !! > 1111111111111111111111111111111 !! > 0 !! > 1000000 !! > 11111111111111111111111111000000 !! > 10000000000000000000000000000000 !! !!##AUTHOR !! John S. Urban !!##LICENSE !! Public Domain !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== function base2(x) result(str) ! return string representing number as a binary number. Fixed-length string: integer, intent(in) :: x integer :: i character(len=max(1,bit_size(x)-leadz(x))) :: str associate(n => len(str)) str = repeat('0',n) do i = 0,n-1 if (btest(x,i)) str(n-i:n-i) = '1' end do end associate end function base2 !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! !! decodebase(3f) - [M_strings:BASE] convert whole number string in base !! [2-36] to base 10 number !! (LICENSE:PD) !! !!##SYNOPSIS !! !! logical function decodebase(string,basein,out10) !! !! character(len=*),intent(in) :: string !! integer,intent(in) :: basein !! integer,intent(out) :: out10 !!##DESCRIPTION !! !! Convert a numeric string representing a whole number in base BASEIN !! to base 10. The function returns FALSE if BASEIN is not in the range !! [2..36] or if string STRING contains invalid characters in base BASEIN !! or if result OUT10 is too big !! !! The letters A,B,...,Z represent 10,11,...,36 in the base > 10. !! !!##OPTIONS !! string input string. It represents a whole number in !! the base specified by BASEIN unless BASEIN is set !! to zero. When BASEIN is zero STRING is assumed to !! be of the form BASE#VALUE where BASE represents !! the function normally provided by BASEIN. !! basein base of input string; either 0 or from 2 to 36. !! out10 output value in base 10 !! !!##EXAMPLE !! !! Sample program: !! !! program demo_decodebase !! use M_strings, only : codebase, decodebase !! implicit none !! integer :: ba,bd !! character(len=40) :: x,y !! integer :: r !! !! print *,' BASE CONVERSION' !! write(*,'("Start Base (2 to 36): ")',advance='no'); read *, bd !! write(*,'("Arrival Base (2 to 36): ")',advance='no'); read *, ba !! INFINITE: do !! print *,'' !! write(*,'("Enter number in start base: ")',advance='no'); read *, x !! if(x == '0') exit INFINITE !! if(decodebase(x,bd,r)) then !! if(codebase(r,ba,y)) then !! write(*,'("In base ",I2,": ",A20)') ba, y !! else !! print *,'Error in coding number.' !! endif !! else !! print *,'Error in decoding number.' !! endif !! enddo INFINITE !! !! end program demo_decodebase !! !!##AUTHOR !! John S. Urban !! !! Ref.: "Math matiques en Turbo-Pascal by !! M. Ducamp and A. Reverchon (2), !! Eyrolles, Paris, 1988". !! !! based on a F90 Version By J-P Moreau (www.jpmoreau.fr) !! !!##LICENSE !! Public Domain logical function decodebase(string,basein,out_baseten) ! ident_80="@(#) M_strings decodebase(3f) convert whole number string in base [2-36] to base 10 number" character(len=*),intent(in) :: string integer,intent(in) :: basein integer,intent(out) :: out_baseten character(len=len(string)) :: string_local integer :: long, i, j, k real :: y real :: mult character(len=1) :: ch real,parameter :: XMAXREAL=real(huge(1)) integer :: out_sign integer :: basein_local integer :: ipound integer :: ierr string_local=upper(trim(adjustl(string))) decodebase=.false. ipound=index(string_local,'#') ! determine if in form [-]base#whole if(basein == 0.and.ipound > 1)then ! split string into two values call string_to_value(string_local(:ipound-1),basein_local,ierr) ! get the decimal value of the base string_local=string_local(ipound+1:) ! now that base is known make string just the value if(basein_local >= 0)then ! allow for a negative sign prefix out_sign=1 else out_sign=-1 endif basein_local=abs(basein_local) else ! assume string is a simple positive value basein_local=abs(basein) out_sign=1 endif out_baseten=0 y=0.0 ALL: if(basein_local<2.or.basein_local>36) then print *,'(*decodebase* ERROR: Base must be between 2 and 36. base=',basein_local else ALL out_baseten=0;y=0.0; mult=1.0 long=LEN_TRIM(string_local) do i=1, long k=long+1-i ch=string_local(k:k) if(ch == '-'.and.k == 1)then out_sign=-1 cycle endif if(ch<'0'.or.ch>'Z'.or.(ch>'9'.and.ch<'A'))then write(*,*)'*decodebase* ERROR: invalid character ',ch exit ALL endif if(ch<='9') then j=IACHAR(ch)-IACHAR('0') else j=IACHAR(ch)-IACHAR('A')+10 endif if(j>=basein_local)then exit ALL endif y=y+mult*j if(mult>XMAXREAL/basein_local)then exit ALL endif mult=mult*basein_local enddo decodebase=.true. out_baseten=nint(out_sign*y)*sign(1,basein) endif ALL end function decodebase !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! codebase(3f) - [M_strings:BASE] convert whole number in base 10 to !! string in base [2-36] !! (LICENSE:PD) !! !!##SYNOPSIS !! !! logical function codebase(in_base10,out_base,answer) !! !! integer,intent(in) :: in_base10 !! integer,intent(in) :: out_base !! character(len=*),intent(out) :: answer !! !!##DESCRIPTION !! Convert a number from base 10 to base OUT_BASE. The function returns !! .FALSE. if OUT_BASE is not in [2..36] or if number IN_BASE10 is !! too big. !! !! The letters A,B,...,Z represent 10,11,...,36 in the base > 10. !! !!##EXAMPLE !! !! Sample program: !! !! program demo_codebase !! use M_strings, only : codebase !! implicit none !! character(len=20) :: answer !! integer :: i, j !! logical :: ierr !! do j=1,100 !! do i=2,36 !! ierr=codebase(j,i,answer) !! write(*,*)'VALUE=',j,' BASE=',i,' ANSWER=',answer !! enddo !! enddo !! end program demo_codebase !! !!##AUTHOR !! John S. Urban !! !! Ref.: "Math matiques en Turbo-Pascal by !! M. Ducamp and A. Reverchon (2), !! Eyrolles, Paris, 1988". !! !! based on a F90 Version By J-P Moreau (www.jpmoreau.fr) !! !!##LICENSE !! Public Domain logical function codebase(inval10,outbase,answer) ! ident_81="@(#) M_strings codebase(3f) convert whole number in base 10 to string in base [2-36]" integer,intent(in) :: inval10 integer,intent(in) :: outbase character(len=*),intent(out) :: answer integer :: n real :: inval10_local integer :: outbase_local integer :: in_sign answer='' in_sign=sign(1,inval10)*sign(1,outbase) inval10_local=abs(inval10) outbase_local=abs(outbase) if(outbase_local<2.or.outbase_local>36) then print *,'*codebase* ERROR: base must be between 2 and 36. base was',outbase_local codebase=.false. else do while(inval10_local>0.0 ) n=INT(inval10_local-outbase_local*INT(inval10_local/outbase_local)) if(n<10) then answer=ACHAR(IACHAR('0')+n)//answer else answer=ACHAR(IACHAR('A')+n-10)//answer endif inval10_local=INT(inval10_local/outbase_local) enddo codebase=.true. endif if(in_sign == -1)then answer='-'//trim(answer) endif if(answer == '')then answer='0' endif end function codebase !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== function todecimal(base, instr) ! ident_82="@(#) M_strings todecimal(3f) given string and base return decimal integer" ! based on an example at rosetta code. character(len=36),parameter :: alphanum = "0123456789abcdefghijklmnopqrstuvwxyz" integer,intent(in) :: base character(*),intent(in) :: instr character(len=:),allocatable :: instr_local integer :: todecimal integer :: length, i, n instr_local=trim(lower(instr)) todecimal = 0 length = len(instr_local) do i = 1, length n = index(alphanum, instr_local(i:i)) - 1 n = n * base**(length-i) todecimal = todecimal + n enddo end function todecimal !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== function tobase(base, number) ! ident_83="@(#) M_strings tobase(3f) given integer and base return string" ! based on an example at rosetta code. character(len=36),parameter :: alphanum = "0123456789abcdefghijklmnopqrstuvwxyz" integer,intent(in) :: base integer,intent(in) :: number character(len=:),allocatable :: tobase character(len=31) :: holdit integer :: number_local, i, rem number_local=number holdit = " " do i = 31, 1, -1 if(number_local < base) then holdit(i:i) = alphanum(number_local+1:number_local+1) exit endif rem = mod(number_local, base) holdit(i:i) = alphanum(rem+1:rem+1) number_local = number_local / base enddo tobase = adjustl(holdit) end function tobase !SUBROUTINE DectoBase(decimal, string, base) ! CHARACTER string ! string = '0' ! temp = decimal ! length = CEILING( LOG(decimal+1, base) ) !<<<<<<<< INTERESTING ! DO i = length, 1, -1 ! n = MOD( temp, base ) ! string(i) = "0123456789abcdefghijklmnopqrstuvwxyz"(n+1) ! temp = INT(temp / base) ! ENDDO ! END !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! paragraph(3f) - [M_strings:TOKENS] break a long line into a paragraph !! (LICENSE:PD) !! !!##SYNOPSIS !! !! function paragraph(source_string,length) !! !! character(len=*),intent(in) :: source_string !! integer,intent(in) :: length !! character(allocatable(len=length) :: paragraph(:) !! !!##DESCRIPTION !! paragraph(3f) breaks a long line into a simple paragraph of specified !! line length. !! !! Given a long string break it on spaces into an array such that no !! variable is longer than the specified length. Individual words longer !! than LENGTH will be placed in variables by themselves. !! !!##OPTIONS !! SOURCE_STRING input string to break into an array of shorter strings !! on blank delimiters !! LENGTH length of lines to break the string into. !! !!##RETURNS !! PARAGRAPH character array filled with data from source_string !! broken at spaces into variables of length LENGTH. !! !!##EXAMPLE !! !! sample program !! !! program demo_paragraph !! use M_strings, only : paragraph !! implicit none !! character(len=:),allocatable :: paragrph(:) !! character(len=*),parameter :: string= '& !! &one two three four five & !! &six seven eight & !! &nine ten eleven twelve & !! &thirteen fourteen fifteen sixteen & !! &seventeen' !! !! write(*,*)'LEN=',len(string) !! write(*,*)'INPUT:' !! write(*,*)string !! !! paragrph=paragraph(string,40) !! write(*,*)'LEN=',len(paragrph),' SIZE=',size(paragrph) !! write(*,*)'OUTPUT:' !! write(*,'(a)')paragrph !! !! write(*,'(a)')paragraph(string,0) !! write(*,'(3x,a)')paragraph(string,47) !! !! end program demo_paragraph !! !! Results: !! !! LEN= 106 !! INPUT: !! one two three four five six seven eight nine ten eleven twelve !! thirteen fourteen fifteen sixteen seventeen !! LEN= 40 SIZE= 3 !! OUTPUT: !! one two three four five six seven eight !! nine ten eleven twelve thirteen fourteen !! fifteen sixteen seventeen !! one !! two !! three !! four !! five !! six !! seven !! eight !! nine !! ten !! eleven !! twelve !! thirteen !! fourteen !! fifteen !! sixteen !! seventeen !! one two three four five six seven eight nine !! ten eleven twelve thirteen fourteen fifteen !! sixteen seventeen !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain function paragraph(source_string,length) ! ident_84="@(#) M_strings paragraph(3f) wrap a long string into a paragraph" character(len=*),intent(in) :: source_string integer,intent(in) :: length integer :: itoken integer :: istart integer :: iend character(len=*),parameter :: delimiters=' ' character(len=:),allocatable :: paragraph(:) integer :: ilines integer :: ilength integer :: iword, iword_max integer :: i !----------------------------------------------------------------------------------------------------------------------------------- ! parse string once to find out how big to make the returned array, then redo everything but store the data ! could store array of endpoints and leave original whitespace alone or many other options do i=1,2 iword_max=0 ! length of longest token ilines=1 ! number of output line output will go on ilength=0 ! length of output line so far itoken=0 ! must set ITOKEN=0 before looping on strtok(3f) on a new string. do while ( strtok(source_string,itoken,istart,iend,delimiters) ) iword=iend-istart+1 iword_max=max(iword_max,iword) if(iword > length)then ! this token is longer than the desired line length so put it on a line by itself if(ilength /= 0)then ilines=ilines+1 endif if(i == 2)then ! if paragraph has been allocated store data, else just gathering data to determine size of paragraph paragraph(ilines)=source_string(istart:iend)//' ' endif ilength=iword+1 elseif(ilength+iword <= length)then ! this word will fit on current line if(i == 2)then paragraph(ilines)=paragraph(ilines)(:ilength)//source_string(istart:iend) endif ilength=ilength+iword+1 else ! adding this word would make line too long so start new line ilines=ilines+1 ilength=0 if(i == 2)then paragraph(ilines)=paragraph(ilines)(:ilength)//source_string(istart:iend) endif ilength=iword+1 endif enddo if(i==1)then ! determined number of lines needed so allocate output array allocate(character(len=max(length,iword_max)) :: paragraph(ilines)) paragraph=' ' endif enddo paragraph=paragraph(:ilines) end function paragraph !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()= !=================================================================================================================================== function setbits8(string) result(answer) integer(kind=int8) :: answer character(len=8),intent(in) :: string integer :: pos integer :: lgth answer=0_int8 lgth=len(string) if(lgth /= bit_size(answer))then write(stderr,*)'*setbits8* wrong string length =',lgth lgth=min(lgth,int(bit_size(answer))) endif do pos=1,lgth select case(string(pos:pos)) case('1') answer = ibset(answer, pos-1) case('0') answer = ibclr(answer, pos-1) case default write(stderr,*)'*setbits8* unknown value. must be 0 or 1. found [',string(pos:pos),'] at position ',pos,' in ',string end select enddo end function setbits8 !----------------------------------------------------------------------------------------------------------------------------------- function setbits16(string) result(answer) integer(kind=int16) :: answer character(len=16),intent(in) :: string integer :: pos integer :: lgth answer=0_int16 lgth=len(string) if(lgth /= bit_size(answer))then write(stderr,*)'*setbits16* wrong string length =',lgth lgth=min(lgth,int(bit_size(answer))) endif do pos=1,len(string) select case(string(pos:pos)) case('1') answer = ibset(answer, pos-1) case('0') answer = ibclr(answer, pos-1) case default write(stderr,*)'*setbits16* unknown value. must be 0 or 1. found [',string(pos:pos),'] at position ',pos,' in ',string end select enddo end function setbits16 !----------------------------------------------------------------------------------------------------------------------------------- function setbits32(string) result(answer) integer(kind=int32) :: answer character(len=32),intent(in) :: string integer :: pos integer :: lgth answer=0_int32 lgth=len(string) if(lgth /= bit_size(answer))then write(stderr,*)'*setbits32* wrong string length =',lgth lgth=min(lgth,int(bit_size(answer))) endif do pos=1,len(string) select case(string(pos:pos)) case('1') answer = ibset(answer, pos-1) case('0') answer = ibclr(answer, pos-1) case default write(stderr,*)'*setbits32* unknown value. must be 0 or 1. found [',string(pos:pos),'] at position ',pos,' in ',string end select enddo end function setbits32 !----------------------------------------------------------------------------------------------------------------------------------- function setbits64(string) result(answer) integer(kind=int64) :: answer character(len=64),intent(in) :: string integer :: pos integer :: lgth answer=0_int64 lgth=len(string) if(lgth /= bit_size(answer))then write(stderr,*)'*setbits64* wrong string length =',lgth lgth=min(lgth,int(bit_size(answer))) endif do pos=1,len(string) select case(string(pos:pos)) case('1') answer = ibset(answer, pos-1) case('0') answer = ibclr(answer, pos-1) case default write(stderr,*)'*setbits64* unknown value. must be 0 or 1. found [',string(pos:pos),'] at position ',pos,' in ',string end select enddo end function setbits64 !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! msg(3f) - [M_strings:TYPE] converts any standard scalar type to a string !! (LICENSE:PD) !!##SYNOPSIS !! !! !! function msg(g1,g2g3,g4,g5,g6,g7,g8,g9,sep) !! !! class(*),intent(in),optional :: g1,g2,g3,g4,g5,g6,g7,g8,g9 !! character(len=*),intent(in),optional :: sep !! character(len=:),allocatable :: msg !! !!##DESCRIPTION !! msg(3f) builds a space-separated string from up to nine scalar values. !! !!##OPTIONS !! g[1-9] optional value to print the value of after the message. May !! be of type INTEGER, LOGICAL, REAL, DOUBLEPRECISION, COMPLEX, !! or CHARACTER. !! sep separator between values. Defaults to a space !! !!##RETURNS !! msg description to print !! !!##EXAMPLES !! !! !! Sample program: !! !! program demo_msg !! use M_strings, only : msg !! implicit none !! character(len=:),allocatable :: pr !! character(len=:),allocatable :: frmt !! integer :: biggest !! !! pr=msg('HUGE(3f) integers',huge(0),& !! & 'and real',huge(0.0),'and double',huge(0.0d0)) !! write(*,'(a)')pr !! pr=msg('real :',& !! & huge(0.0),0.0,12345.6789,tiny(0.0) ) !! write(*,'(a)')pr !! pr=msg('doubleprecision :',& !! & huge(0.0d0),0.0d0,12345.6789d0,tiny(0.0d0) ) !! write(*,'(a)')pr !! pr=msg('complex :',& !! & cmplx(huge(0.0),tiny(0.0)) ) !! write(*,'(a)')pr !! !! ! create a format on the fly !! biggest=huge(0) !! frmt=msg('(*(i',int(log10(real(biggest))),':,1x))',sep='') !! write(*,*)'format=',frmt !! !! ! although it will often work, using msg(3f) in an I/O statement !! ! is not recommended !! write(*,*)msg('program will now stop') !! !! end program demo_msg !! !! Output !! !! HUGE(3f) integers 2147483647 and real 3.40282347E+38 !! and double 1.7976931348623157E+308 !! real : 3.40282347E+38 0.00000000 !! 12345.6787 1.17549435E-38 !! doubleprecision : 1.7976931348623157E+308 0.0000000000000000 !! 12345.678900000001 2.2250738585072014E-308 !! complex : (3.40282347E+38,1.17549435E-38) !! format=(*(i9:,1x)) !! program will now stop !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain !=================================================================================================================================== function msg_scalar(generic1, generic2, generic3, generic4, generic5, generic6, generic7, generic8, generic9,sep) ! ident_85="@(#) M_strings msg_scalar(3fp) writes a message to a string composed of any standard scalar types" class(*),intent(in),optional :: generic1 ,generic2 ,generic3 ,generic4 ,generic5 class(*),intent(in),optional :: generic6 ,generic7 ,generic8 ,generic9 character(len=*),intent(in),optional :: sep character(len=:),allocatable :: sep_local character(len=:), allocatable :: msg_scalar character(len=4096) :: line integer :: istart integer :: increment if(present(sep))then sep_local=sep increment=len(sep)+1 else sep_local=' ' increment=2 endif istart=1 line=' ' if(present(generic1))call print_generic(generic1) if(present(generic2))call print_generic(generic2) if(present(generic3))call print_generic(generic3) if(present(generic4))call print_generic(generic4) if(present(generic5))call print_generic(generic5) if(present(generic6))call print_generic(generic6) if(present(generic7))call print_generic(generic7) if(present(generic8))call print_generic(generic8) if(present(generic9))call print_generic(generic9) msg_scalar=trim(line) contains !=================================================================================================================================== subroutine print_generic(generic) class(*),intent(in) :: generic select type(generic) type is (integer(kind=int8)); write(line(istart:),'(i0)') generic type is (integer(kind=int16)); write(line(istart:),'(i0)') generic type is (integer(kind=int32)); write(line(istart:),'(i0)') generic type is (integer(kind=int64)); write(line(istart:),'(i0)') generic type is (real(kind=real32)); write(line(istart:),'(1pg0)') generic type is (real(kind=real64)); write(line(istart:),'(1pg0)') generic !x!type is (real(kind=real128)); write(line(istart:),'(1pg0)') generic !x!type is (real(kind=real256)); write(line(istart:),'(1pg0)') generic type is (logical); write(line(istart:),'(l1)') generic type is (character(len=*)); write(line(istart:),'(a)') trim(generic) type is (complex); write(line(istart:),'("(",1pg0,",",1pg0,")")') generic end select istart=len_trim(line)+increment line=trim(line)//sep_local end subroutine print_generic !=================================================================================================================================== end function msg_scalar !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== function msg_one(generic1, generic2, generic3, generic4, generic5, generic6, generic7, generic8, generic9,sep) ! ident_86="@(#) M_strings msg_one(3fp) writes a message to a string composed of any standard one dimensional types" class(*),intent(in) :: generic1(:) class(*),intent(in),optional :: generic2(:), generic3(:), generic4(:), generic5(:) class(*),intent(in),optional :: generic6(:), generic7(:), generic8(:), generic9(:) character(len=*),intent(in),optional :: sep character(len=:),allocatable :: sep_local character(len=:), allocatable :: msg_one character(len=4096) :: line integer :: istart integer :: increment if(present(sep))then sep_local=sep increment=len(sep)+1 else sep_local=' ' increment=2 endif istart=1 line=' ' call print_generic(generic1) if(present(generic2))call print_generic(generic2) if(present(generic3))call print_generic(generic3) if(present(generic4))call print_generic(generic4) if(present(generic5))call print_generic(generic5) if(present(generic6))call print_generic(generic6) if(present(generic7))call print_generic(generic7) if(present(generic8))call print_generic(generic8) if(present(generic9))call print_generic(generic9) msg_one=trim(line) contains !=================================================================================================================================== subroutine print_generic(generic) class(*),intent(in),optional :: generic(:) integer :: i select type(generic) type is (integer(kind=int8)); write(line(istart:),'("[",*(i0,1x))') generic type is (integer(kind=int16)); write(line(istart:),'("[",*(i0,1x))') generic type is (integer(kind=int32)); write(line(istart:),'("[",*(i0,1x))') generic type is (integer(kind=int64)); write(line(istart:),'("[",*(i0,1x))') generic type is (real(kind=real32)); write(line(istart:),'("[",*(1pg0,1x))') generic type is (real(kind=real64)); write(line(istart:),'("[",*(1pg0,1x))') generic !x!type is (real(kind=real128)); write(line(istart:),'("[",*(1pg0,1x))') generic !x!type is (real(kind=real256)); write(line(istart:),'("[",*(1pg0,1x))') generic type is (logical); write(line(istart:),'("[",*(l1,1x))') generic type is (character(len=*)); write(line(istart:),'("[",:*("""",a,"""",1x))') (trim(generic(i)),i=1,size(generic)) type is (complex); write(line(istart:),'("[",*("(",1pg0,",",1pg0,")",1x))') generic end select istart=len_trim(line)+increment line=trim(line)//"]"//sep_local end subroutine print_generic !=================================================================================================================================== end function msg_one !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! find_field(3f) - [M_strings:TOKENS] parse a string into tokens !! (LICENSE:MIT) !! !!##SYNOPSIS !! !! subroutine find_field (string, field, position, delims, delim, found) !! !! character*(*),intent(in) :: string !! character*(*),intent(out) :: field !! integer,optional,intent(inout) :: position !! character*(*),optional,intent(in) :: delims !! character*(*),optional,intent(out) :: delim !! logical,optional,intent(out) :: found !! !!##DESCRIPTION !! !! Find a delimited field in a string. !! !! Here's my equivalent, which I've used for nearly 2 decades, as you can !! see from the date. This doesn't try to mimic the C strtok (and doesn't !! have its limitations either). It is in a much more native Fortran style. !! !! It is a little more complicated than some because it does some things !! that I regularly find useful. For example, it can tell the caller what !! trailing delimiter it found. This can be useful, for example, to !! distinguish between !! !! somefield, someotherfield !! !! versus !! !! somefield=somevalue, someotherfield !! !! Also, I have a bit of special handling for blanks. All the usage !! information is in the argument descriptions. Note that most of the !! arguments are optional. !! !! from comp.lang.fortran @ Richard Maine !! !!##OPTIONS !! STRING The string input. !! !! FIELD The returned field. Blank if no field found. !! !! POSITION On entry, the starting position for searching for the field. !! Default is 1 if the argument is not present. !! On exit, the starting position of the next field or !! len(string)+1 if there is no following field. !! !! DELIMS String containing the characters to be accepted as delimiters. !! If this includes a blank character, then leading blanks are !! removed from the returned field and the end delimiter may !! optionally be preceded by blanks. If this argument is !! not present, the default delimiter set is a blank. !! !! DELIM Returns the actual delimiter that terminated the field. !! Returns char(0) if the field was terminated by the end of !! the string or if no field was found. !! If blank is in delimiters and the field was terminated !! by one or more blanks, followed by a non-blank delimiter, !! the non-blank delimiter is returned. !! !! FOUND True if a field was found. !! !!##EXAMPLES !! !! Sample of uses !! !! program demo_find_field !! use M_strings, only : find_field !! implicit none !! character(len=256) :: string !! character(len=256) :: field !! integer :: position !! character(len=:),allocatable :: delims !! character(len=1) :: delim !! logical :: found !! !! delims='[,]' !! position=1 !! found=.true. !! string='[a,b,[ccc,ddd],and more]' !! write(*,'(a)')trim(string) !! do !! call find_field(string,field,position,delims,delim,found=found) !! if(.not.found)exit !! write(*,'("<",a,">")')trim(field) !! enddo !! write(*,'(*(g0))')repeat('=',70) !! !! position=1 !! found=.true. !! write(*,'(a)')trim(string) !! do !! call find_field(string,field,position,'[], ',delim,found=found) !! if(.not.found)exit !! write(*,'("<",a,">",i0,1x,a)')trim(field),position,delim !! enddo !! write(*,'(*(g0))')repeat('=',70) !! !! end program demo_find_field !! ``` !! Results: !! ```text !! > [a,b,[ccc,ddd],and more] !! > <> !! > !! > !! > <> !! > !! > !! > <> !! > !! > <> !! > ====================================================================== !! > [a,b,[ccc,ddd],and more] !! > <>2 [ !! > 4 , !! > 6 , !! > <>7 [ !! > 11 , !! > 15 ] !! > <>16 , !! > 20 !! > 257 ] !! > ====================================================================== !! !!##AUTHOR !! Richard Maine !! !!##LICENSE !! MIT !! !!##VERSION !! version 0.1.0, copyright Nov 15 1990, Richard Maine !! !! Minor editing to conform to inclusion in the string procedure module subroutine find_field (string, field, position, delims, delim, found) !-- Find a delimited field in a string. !-- 15 Nov 90, Richard Maine. !-------------------- interface. character*(*),intent(in) :: string character*(*),intent(out) :: field integer,optional,intent(inout) :: position character*(*),optional,intent(in) :: delims character*(*),optional,intent(out) :: delim logical,optional,intent(out) :: found !-------------------- local. character :: delimiter*1 integer :: pos, field_start, field_end, i logical :: trim_blanks !-------------------- executable code. field = '' delimiter = char(0) pos = 1 if (present(found)) found = .false. if (present(position)) pos = position if (pos > len(string)) goto 9000 !if (pos < 1) error stop 'Illegal position in find_field' if (pos < 1) stop 'Illegal position in find_field' !-- Skip leading blanks if blank is a delimiter. field_start = pos trim_blanks = .true. if (present(delims)) trim_blanks = index(delims,' ') /= 0 if (trim_blanks) then i = verify(string(pos:),' ') if (i == 0) then pos = len(string) + 1 goto 9000 end if field_start = pos + i - 1 end if if (present(found)) found = .true. !-- Find the end of the field. if (present(delims)) then i = scan(string(field_start:), delims) else i = scan(string(field_start:), ' ') end if if (i == 0) then field_end = len(string) delimiter = char(0) pos = field_end + 1 else field_end = field_start + i - 2 delimiter = string(field_end+1:field_end+1) pos = field_end + 2 end if !-- Return the field. field = string(field_start:field_end) !-- Skip trailing blanks if blank is a delimiter. if (trim_blanks) then i = verify(string(field_end+1:), ' ') if (i == 0) then pos = len(string) + 1 goto 9000 end if pos = field_end + i !-- If the first non-blank character is a delimiter, !-- skip blanks after it. i = 0 if (present(delims)) i = index(delims, string(pos:pos)) if (i /= 0) then delimiter = string(pos:pos) pos = pos + 1 i = verify(string(pos:), ' ') if (i == 0) then pos = len(string) + 1 else pos = pos + i - 1 end if end if end if !---------- Normal exit. 9000 continue if (present(delim)) delim = delimiter if (present(position)) position = pos end subroutine find_field !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! split2020(3f) - [M_strings:TOKENS] parse a string into tokens using !! proposed f2023 method !! (LICENSE:PD) !! !!##SYNOPSIS !! !! TOKEN form !! !! subroutine split2020 (string, set, tokens, separator) !! character(len=*),intent(in) :: string !! character(len=*),intent(in) :: set !! character(len=:),allocatable,intent(out) :: tokens(:) !! character(len=1),allocatable,intent(out),optional :: separator(:) !! !! BOUNDS ARRAY form !! !! subroutine split2020 (string, set, first, last) !! character(len=*),intent(in) :: string !! character(len=*),intent(in) :: set !! integer,allocatable,intent(out) :: first(:) !! integer,allocatable,intent(out) :: last(:) !! !! STEP THROUGH BY POSITION form !! !! subroutine split2020 (string, set, pos [, back]) !! character(len=*),intent(in) :: string !! character(len=*),intent(in) :: set !! integer,intent(inout) :: pos !! logical,intent(in),optional :: back !! !!##DESCRIPTION !! Parse a string into tokens. STRING, SET, TOKENS and SEPARATOR must !! all be of the same CHARACTER kind type parameter. !! !!##OPTIONS !! STRING string to break into tokens !! !! SET Each character in SET is a token delimiter. A !! sequence of zero or more characters in STRING delimited by !! any token delimiter, or the beginning or end of STRING, !! comprise a token. Thus, two consecutive token delimiters !! in STRING, or a token delimiter in the first or last !! character of STRING, indicate a token with zero length. !! !! ??? how about if null defaults to all whitespace characters !! !! TOKENS It is allocated with the lower bound equal to !! one and the upper bound equal to the number of tokens in !! STRING, and with character length equal to the length of !! the longest token. The tokens in STRING are assigned by !! intrinsic assignment, in the order found, to the elements !! of TOKENS, in array element order. !! !! ???If input is null it still must be of size 1? !! !! SEPARATOR Each element in SEPARATOR(i) is assigned the value of !! the ith token delimiter in STRING. !! It is allocated with the lower bound equal to !! one and the upper bound equal to one less than the number !! of tokens in STRING, and with character length equal to !! one. !! !! ???one less than? '' ' ' !! !! FIRST It is allocated with the lower bound equal to one and the !! upper bound equal to the number of tokens in STRING. Each !! element is assigned, in array element order, the starting !! position of each token in STRING, in the order found. If a !! token has zero length, the starting position is equal to one !! if the token is at the beginning of STRING, and one greater !! than the position of the preceding delimiter otherwise. !! !! LAST It is allocated with the lower bound equal to one and the !! upper bound equal to the number of tokens in STRING. Each !! element is assigned, in array element order, the ending !! position of each token in STRING, in the order found. If !! a token has zero length, the ending position is one less !! than the starting position. !! !! POS If BACK is present with the value .TRUE., the value !! of POS shall be in the range 0 < POS LEN (STRING)+1; !! otherwise it shall be in the range 0 POS LEN (STRING). !! !! If BACK is absent or is present with the value .FALSE., POS !! is assigned the position of the leftmost token delimiter in !! STRING whose position is greater than POS, or if there is !! no such character, it is assigned a value one greater than !! the length of STRING. This identifies a token with starting !! position one greater than the value of POS on invocation, !! and ending position one less than the value of POS on return. !! !! If BACK is present with the value true, POS is assigned the !! position of the rightmost token delimiter in STRING whose !! position is less than POS, or if there is no such character, !! it is assigned the value zero. This identifies a token with !! ending position one less than the value of POS on invocation, !! and starting position one greater than the value of POS !! on return. !! !! When SPLIT is invoked with a value for POS of !! 1 <= POS <= LEN(STRING) and STRING(POS:POS) is not a !! token delimiter present in SET, the token identified by !! SPLIT does not comprise a complete token as described in the !! description of the SET argument, but rather a partial token. !! !! BACK shall be a logical scalar. It is an INTENT (IN) argument. If !! POS does not appear and BACK is present with the value true, !! STRING is scanned backwards for tokens starting from the !! end. If POS does not appear and BACK is absent or present !! with the value false, STRING is scanned forwards for tokens !! starting from the beginning. !! !!##EXAMPLES !! !! Sample of uses !! !! program demo_sort2020 !! use M_strings, only : split2020 !! implicit none !! character(len=*),parameter :: gen='(*("[",g0,"]":,","))' !! !! ! Execution of TOKEN form !! block !! character (len=:), allocatable :: string !! character (len=:), allocatable :: tokens(:) !! character (len=*),parameter :: set = " ," !! string = 'first,second,third' !! call split2020(string, set, tokens ) !! write(*,gen)tokens !! !! ! assigns the value ['first ','second','third ' ] !! ! to TOKENS. !! endblock !! !! ! Execution of BOUNDS form !! !! block !! character (len=:), allocatable :: string !! character (len=*),parameter :: set = " ," !! integer, allocatable :: first(:), last(:) !! string = 'first,second,,forth' !! call split2020 (string, set, first, last) !! write(*,gen)first !! write(*,gen)last !! !! ! will assign the value [ 1, 7, 14, 15 ] to FIRST, !! ! and the value [ 5, 12, 13, 19 ] to LAST. !! endblock !! !! ! Execution of STEP form !! block !! character (len=:), allocatable :: string !! character (len=*),parameter :: set = " ," !! integer :: p, istart, iend !! string = " one, last example " !! do while (p < len(string)) !! istart = p + 1 !! call split2020 (string, set, p) !! iend=p-1 !! if(iend > istart)then !! print '(t3,a,1x,i0,1x,i0)', string (istart:iend),istart,iend !! endif !! enddo !! endblock !! end program demo_sort2020 !! !! Results: !! !! [first ],[second],[third ] !! [1],[7],[14],[15] !! [5],[12],[13],[19] !! one 2 4 !! last 9 12 !! example 15 21 !! !! > ??? option to skip adjacent delimiters (not return null tokens) !! > common with whitespace !! > ??? quoted strings, especially CSV both " and ', Fortran adjacent !! > is insert versus other rules !! > ??? escape character like \\ . !! > ??? multi-character delimiters like \\n, \\t, !! > ??? regular expression separator !! !!##AUTHOR !! Milan Curcic, "milancurcic@hey.com" !! !!##LICENSE !! MIT !! !!##VERSION !! version 0.1.0, copyright 2020, Milan Curcic pure subroutine split_tokens(string, set, tokens, separator) ! Splits a string into tokens using characters in set as token delimiters. ! If present, separator contains the array of token delimiters. character(*), intent(in) :: string character(*), intent(in) :: set character(:), allocatable, intent(out) :: tokens(:) character, allocatable, intent(out), optional :: separator(:) integer, allocatable :: first(:), last(:) integer :: n call split2020(string, set, first, last) allocate(character(len=maxval(last - first) + 1) :: tokens(size(first))) do concurrent (n = 1:size(tokens)) tokens(n) = string(first(n):last(n)) enddo if (present(separator)) then allocate(separator(size(tokens) - 1)) do concurrent (n = 1:size(tokens) - 1) separator(n) = string(first(n+1)-1:first(n+1)-1) enddo endif end subroutine split_tokens !=================================================================================================================================== pure subroutine split_first_last(string, set, first, last) ! Computes the first and last indices of tokens in input string, delimited ! by the characters in set, and stores them into first and last output ! arrays. character(*), intent(in) :: string character(*), intent(in) :: set integer, allocatable, intent(out) :: first(:) integer, allocatable, intent(out) :: last(:) character :: set_array(len(set)) logical, dimension(len(string)) :: is_first, is_last, is_separator integer :: n, slen slen = len(string) do concurrent (n = 1:len(set)) set_array(n) = set(n:n) enddo do concurrent (n = 1:slen) is_separator(n) = any(string(n:n) == set_array) enddo is_first = .false. is_last = .false. if (.not. is_separator(1)) is_first(1) = .true. do concurrent (n = 2:slen-1) if (.not. is_separator(n)) then if (is_separator(n - 1)) is_first(n) = .true. if (is_separator(n + 1)) is_last(n) = .true. else if (is_separator(n - 1)) then is_first(n) = .true. is_last(n-1) = .true. endif endif enddo if (.not. is_separator(slen)) is_last(slen) = .true. first = pack([(n, n = 1, slen)], is_first) last = pack([(n, n = 1, slen)], is_last) end subroutine split_first_last !=================================================================================================================================== pure subroutine split_pos(string, set, pos, back) ! If back is absent, computes the leftmost token delimiter in string whose ! position is > pos. If back is present and true, computes the rightmost ! token delimiter in string whose position is < pos. The result is stored ! in pos. character(*), intent(in) :: string character(*), intent(in) :: set integer, intent(in out) :: pos logical, intent(in), optional :: back logical :: backward character :: set_array(len(set)) integer :: n, result_pos !TODO use optval when implemented in stdlib !backward = optval(back, .false.) backward = .false. if (present(back)) backward = back do concurrent (n = 1:len(set)) set_array(n) = set(n:n) enddo if (backward) then result_pos = 0 do n = pos - 1, 1, -1 if (any(string(n:n) == set_array)) then result_pos = n exit endif enddo else result_pos = len(string) + 1 do n = pos + 1, len(string) if (any(string(n:n) == set_array)) then result_pos = n exit endif enddo endif pos = result_pos end subroutine split_pos !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== pure function string_tokens(string, set) result(tokens) ! Splits a string into tokens using characters in set as token delimiters. character(*), intent(in) :: string character(*), intent(in) :: set character(:), allocatable :: tokens(:) call split_tokens(string, set, tokens) end function string_tokens !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== ! Duplicate the M_journal module in condensed form for now so can be stand-alone on GITHUB ! ll ! l ! j l ! l ! j l ! j oooooo u u r rrrrrr n nnnnn aaaa l ! j o o u u rr nn n a l ! j o o u u r n n aaaaaa l ! j j o o u u r n n a a l ! jj oooooo uuuuuu u r n n aaaaa a l ! !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== ! @(#) place-holder for journal module !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== subroutine where_write_message(where,msg) !@(#) M_journal::where_write_message(3fp): basic message routine used for journal files character(len=*),intent(in) :: where character(len=*),intent(in) :: msg logical,save :: trailopen=.false. integer,save :: itrail character,save :: comment='#' integer :: i integer :: ios integer :: times ! number of times written to stdout character(len=3) :: adv ! whether remaining writes from this call use advancing I/O character(len=:),allocatable,save :: prefix_template ! string to run thru now_ex(3f) to make prefix character(len=:),allocatable :: prefix ! the prefix string to add to output logical,save :: prefix_it=.false. ! flag whether time prefix mode is on or not character(len=4096) :: mssge !----------------------------------------------------------------------------------------------------------------------------------- adv='yes' !----------------------------------------------------------------------------------------------------------------------------------- prefix='' !----------------------------------------------------------------------------------------------------------------------------------- times=0 do i=1,len_trim(where) select case(where(i:i)) case('T','t') if(trailopen) then write(itrail,'(a)',advance=adv)prefix//trim(msg) !elseif(times == 0)then ! write(stdout,'(a)',advance=adv)prefix//trim(msg) ! times=times+1 endif !----------------------------------------------------------------------------------------------------------------------------- case('S','s') write(stdout,'(a)',advance=adv)prefix//trim(msg) times=times+1 !----------------------------------------------------------------------------------------------------------------------------- case('E','e') write(stderr,'(a)',advance=adv)prefix//trim(msg) times=times+1 !----------------------------------------------------------------------------------------------------------------------------- case('+'); adv='no' !----------------------------------------------------------------------------------------------------------------------------- case('>'); debug=.true. !----------------------------------------------------------------------------------------------------------------------------- case('<'); debug=.false. !----------------------------------------------------------------------------------------------------------------------------- case('%') ! setting timestamp prefix if(msg == '')then ! if message is blank turn off prefix prefix_it=.false. else ! store message as string to pass to now_ex() on subsequent calls to make prefix prefix_template=msg prefix_it=.true. endif !----------------------------------------------------------------------------------------------------------------------------- case('N') ! new name for stdout if(msg /= ' '.and.msg /= '#N#'.and.msg /= '"#N#"')then ! if filename not special or blank open new file close(unit=last_int,iostat=ios) open(unit=last_int,file=adjustl(trim(msg)),iostat=ios) if(ios == 0)then stdout=last_int else write(*,*)'*journal* error opening redirected output file, ioerr=',ios write(*,*)'*journal* msg='//trim(msg) endif elseif(msg == ' ')then close(unit=last_int,iostat=ios) stdout=6 endif !----------------------------------------------------------------------------------------------------------------------------- case('C','c') if(trailopen)then write(itrail,'(3a)',advance=adv)prefix,comment,trim(msg) elseif(times == 0)then ! write(stdout,'(2a)',advance=adv)prefix,trim(msg) ! times=times+1 endif case('D','d') if(debug)then if(trailopen)then write(itrail,'(4a)',advance=adv)prefix,comment,'DEBUG: ',trim(msg) elseif(times == 0)then write(stdout,'(3a)',advance=adv)prefix,'DEBUG:',trim(msg) times=times+1 endif endif case('F','f') flush(unit=itrail,iostat=ios,iomsg=mssge) if(ios /= 0)then write(*,'(a)') trim(mssge) endif case('A','a') if(msg /= '')then open(newunit=itrail,status='unknown',access='sequential',file=adjustl(trim(msg)),& & form='formatted',iostat=ios,position='append') trailopen=.true. endif case('O','o') if(msg /= '')then open(newunit=itrail,status='unknown',access='sequential', file=adjustl(trim(msg)),form='formatted',iostat=ios) trailopen=.true. else if(trailopen)then write(itrail,'(4a)',advance=adv)prefix,comment,'closing trail file:',trim(msg) endif close(unit=itrail,iostat=ios) trailopen=.false. endif case default write(stdout,'(a)',advance=adv)'*journal* bad WHERE value '//trim(where)//' when msg=['//trim(msg)//']' end select enddo !----------------------------------------------------------------------------------------------------------------------------------- end subroutine where_write_message !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== subroutine flush_trail() call where_write_message('F','IGNORE THIS STRING') end subroutine flush_trail !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== subroutine where_write_message_all(where, g0,g1,g2,g3,g4,g5,g6,g7,g8,g9,nospace) !$(#) M_journal::where_write_message_all(3f): writes a message to a string composed of any standard scalar types character(len=*),intent(in) :: where class(*),intent(in) :: g0 class(*),intent(in),optional :: g1,g2,g3,g4,g5,g6,g7,g8,g9 logical,intent(in),optional :: nospace !call where_write_message(where,str(g0, g1, g2, g3, g4, g5, g6, g7, g8, g9,nospace)) end subroutine where_write_message_all !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== subroutine write_message_only(message) !$(#) M_journal::write_message_only(3fp): calls JOURNAL('sc',message) character(len=*),intent(in) :: message !----------------------------------------------------------------------------------------------------------------------------------- call where_write_message('sc',trim(message)) !----------------------------------------------------------------------------------------------------------------------------------- end subroutine write_message_only !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== function str_scalar(generic0, generic1, generic2, generic3, generic4, generic5, generic6, generic7, generic8, generic9, & & generica, genericb, genericc, genericd, generice, genericf, genericg, generich, generici, genericj, & & sep) class(*),intent(in),optional :: generic0, generic1, generic2, generic3, generic4 class(*),intent(in),optional :: generic5, generic6, generic7, generic8, generic9 class(*),intent(in),optional :: generica, genericb, genericc, genericd, generice class(*),intent(in),optional :: genericf, genericg, generich, generici, genericj character(len=*),intent(in),optional :: sep character(len=:), allocatable :: str_scalar character(len=4096) :: line integer :: istart integer :: increment character(len=:),allocatable :: sep_local if(present(sep))then sep_local=sep increment=len(sep)+1 else sep_local=' ' increment=2 endif istart=1 line='' if(present(generic0))call print_generic(generic0) if(present(generic1))call print_generic(generic1) if(present(generic2))call print_generic(generic2) if(present(generic3))call print_generic(generic3) if(present(generic4))call print_generic(generic4) if(present(generic5))call print_generic(generic5) if(present(generic6))call print_generic(generic6) if(present(generic7))call print_generic(generic7) if(present(generic8))call print_generic(generic8) if(present(generic9))call print_generic(generic9) if(present(generica))call print_generic(generica) if(present(genericb))call print_generic(genericb) if(present(genericc))call print_generic(genericc) if(present(genericd))call print_generic(genericd) if(present(generice))call print_generic(generice) if(present(genericf))call print_generic(genericf) if(present(genericg))call print_generic(genericg) if(present(generich))call print_generic(generich) if(present(generici))call print_generic(generici) if(present(genericj))call print_generic(genericj) str_scalar=trim(line) contains !=================================================================================================================================== subroutine print_generic(generic) class(*),intent(in) :: generic select type(generic) type is (integer(kind=int8)); write(line(istart:),'(i0)') generic type is (integer(kind=int16)); write(line(istart:),'(i0)') generic type is (integer(kind=int32)); write(line(istart:),'(i0)') generic type is (integer(kind=int64)); write(line(istart:),'(i0)') generic type is (real(kind=real32)); write(line(istart:),'(1pg0)') generic type is (real(kind=real64)); write(line(istart:),'(1pg0)') generic !x!type is (real(kind=real128)); write(line(istart:),'(1pg0)') generic !x!type is (real(kind=real256)); write(line(istart:),'(1pg0)') generic type is (logical); write(line(istart:),'(l1)') generic type is (character(len=*)); write(line(istart:),'(a)') trim(generic) type is (complex); write(line(istart:),'("(",1pg0,",",1pg0,")")') generic end select istart=len_trim(line)+increment line=trim(line)//sep_local end subroutine print_generic end function str_scalar !=================================================================================================================================== function str_one(generic0,generic1, generic2, generic3, generic4, generic5, generic6, generic7, generic8, generic9,sep) class(*),intent(in) :: generic0(:) class(*),intent(in),optional :: generic1(:), generic2(:), generic3(:), generic4(:), generic5(:) class(*),intent(in),optional :: generic6(:), generic7(:), generic8(:), generic9(:) character(len=*),intent(in),optional :: sep character(len=:),allocatable :: sep_local character(len=:), allocatable :: str_one character(len=4096) :: line integer :: istart integer :: increment if(present(sep))then sep_local=sep increment=len(sep)+1 else sep_local=' ' increment=2 endif istart=1 line=' ' call print_generic(generic0) if(present(generic1))call print_generic(generic1) if(present(generic2))call print_generic(generic2) if(present(generic3))call print_generic(generic3) if(present(generic4))call print_generic(generic4) if(present(generic5))call print_generic(generic5) if(present(generic6))call print_generic(generic6) if(present(generic7))call print_generic(generic7) if(present(generic8))call print_generic(generic8) if(present(generic9))call print_generic(generic9) str_one=trim(line) contains subroutine print_generic(generic) class(*),intent(in),optional :: generic(:) integer :: i select type(generic) type is (integer(kind=int8)); write(line(istart:),'("[",*(i0,1x))') generic type is (integer(kind=int16)); write(line(istart:),'("[",*(i0,1x))') generic type is (integer(kind=int32)); write(line(istart:),'("[",*(i0,1x))') generic type is (integer(kind=int64)); write(line(istart:),'("[",*(i0,1x))') generic type is (real(kind=real32)); write(line(istart:),'("[",*(1pg0,1x))') generic type is (real(kind=real64)); write(line(istart:),'("[",*(1pg0,1x))') generic !x!type is (real(kind=real128)); write(line(istart:),'("[",*(1pg0,1x))') generic !x!type is (real(kind=real256)); write(line(istart:),'("[",*(1pg0,1x))') generic type is (logical); write(line(istart:),'("[",*(l1,1x))') generic type is (character(len=*)); write(line(istart:),'("[",:*("""",a,"""",1x))') (trim(generic(i)),i=1,size(generic)) type is (complex); write(line(istart:),'("[",*("(",1pg0,",",1pg0,")",1x))') generic class default stop 'unknown type in *print_generic*' end select line=trim(line)//"]"//sep_local istart=len_trim(line)+increment end subroutine print_generic end function str_one !=================================================================================================================================== !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! matching_delimiter(3f) - [M_strings:QUOTES] find position of matching delimiter !! (LICENSE:PD) !! !!##SYNOPSIS !! !! impure elemental subroutine matching_delimiter(str,ipos,imatch) !! !! character(len=*),intent(in) :: str !! integer,intent(in) :: ipos !! integer,intent(out) :: imatch !! !!##DESCRIPTION !! Sets imatch to the position in string of the delimiter matching the !! delimiter in position ipos. Allowable delimiters are (), [], {}, <>. !! !!##OPTIONS !! str input string to locate delimiter position in !! ipos position of delimiter to find match for !! imatch location of matching delimiter. If no match is found, zero (0) !! is returned. !! !!##EXAMPLE !! !! Sample program: !! !! program demo_matching_delimiter !! use M_strings, only : matching_delimiter !! implicit none !! character(len=128) :: str !! integer :: imatch !! !! str=' a [[[[b] and ] then ] finally ]' !! write(*,*)'string=',str !! call matching_delimiter(str,1,imatch) !! write(*,*)'location=',imatch !! call matching_delimiter(str,4,imatch) !! write(*,*)'location=',imatch !! call matching_delimiter(str,5,imatch) !! write(*,*)'location=',imatch !! call matching_delimiter(str,6,imatch) !! write(*,*)'location=',imatch !! call matching_delimiter(str,7,imatch) !! write(*,*)'location=',imatch !! call matching_delimiter(str,32,imatch) !! write(*,*)'location=',imatch !! !! end program demo_matching_delimiter !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== impure elemental subroutine matching_delimiter(str,ipos,imatch) ! Sets imatch to the position in string of the delimiter matching the delimiter ! in position ipos. Allowable delimiters are (), [], {}, <>. ! pedigree? character(len=*),intent(in) :: str integer,intent(in) :: ipos integer,intent(out) :: imatch character :: delim1,delim2,ch integer :: lenstr integer :: idelim2 integer :: istart, iend integer :: inc integer :: isum integer :: i imatch=0 lenstr=len_trim(str) delim1=str(ipos:ipos) select case(delim1) case('(') idelim2=iachar(delim1)+1 istart=ipos+1 iend=lenstr inc=1 case(')') idelim2=iachar(delim1)-1 istart=ipos-1 iend=1 inc=-1 case('[','{','<') idelim2=iachar(delim1)+2 istart=ipos+1 iend=lenstr inc=1 case(']','}','>') idelim2=iachar(delim1)-2 istart=ipos-1 iend=1 inc=-1 case default write(*,*) delim1,' is not a valid delimiter' return end select if(istart < 1 .or. istart > lenstr) then write(*,*) delim1,' has no matching delimiter' return endif delim2=achar(idelim2) ! matching delimiter isum=1 do i=istart,iend,inc ch=str(i:i) if(ch /= delim1 .and. ch /= delim2) cycle if(ch == delim1) isum=isum+1 if(ch == delim2) isum=isum-1 if(isum == 0) exit enddo if(isum /= 0) then write(*,*) delim1,' has no matching delimiter' return endif imatch=i end subroutine matching_delimiter !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! longest_common_substring(3f) - [M_strings:COMPARE] function that !! returns the longest common substring of two strings. !!##SYNOPSIS !! !! function longest_common_substring(a,b) result(match) !! !! character(len=*),intent(in) :: a, b !! character(len=:),allocatable :: match !!##DESCRIPTION !! function that returns the longest common substring of two strings. !! !! Note that substrings are consecutive characters within a string. !! This distinguishes them from subsequences, which is any sequence of !! characters within a string, even if there are extraneous characters in !! between them. !! !! Hence, the longest common subsequence between "thisisatest" and !! "testing123testing" is "tsitest", whereas the longest common substring !! is just "test". !!##OPTIONS !! a,b strings to search for the longest common substring. !!##RETURNS !! longest_common_substring the longest common substring found !!##EXAMPLE !! !! Sample program !! !! program demo_longest_common_substring !! use M_strings, only : longest_common_substring !! implicit none !! call compare('testing123testingthing','thisis', 'thi') !! call compare('testing', 'sting', 'sting') !! call compare('thisisatest_stinger','testing123testingthing','sting') !! call compare('thisisatest_stinger', 'thisis', 'thisis') !! call compare('thisisatest', 'testing123testing', 'test') !! call compare('thisisatest', 'thisisatest', 'thisisatest') !! contains !! !! subroutine compare(a,b,answer) !! character(len=*),intent(in) :: a, b, answer !! character(len=:),allocatable :: match !! character(len=*),parameter :: g='(*(g0))' !! match=longest_common_substring(a,b) !! write(*,g) 'comparing "',a,'" and "',b,'"' !! write(*,g) merge('(PASSED) "','(FAILED) "',answer == match), & !! & match,'"; expected "',answer,'"' !! end subroutine compare !! !! end program demo_longest_common_substring !! !! expected output !! !! comparing "testing123testingthing" and "thisis" !! (PASSED) "thi"; expected "thi" !! comparing "testing" and "sting" !! (PASSED) "sting"; expected "sting" !! comparing "thisisatest_stinger" and "testing123testingthing" !! (PASSED) "sting"; expected "sting" !! comparing "thisisatest_stinger" and "thisis" !! (PASSED) "thisis"; expected "thisis" !! comparing "thisisatest" and "testing123testing" !! (PASSED) "test"; expected "test" !! comparing "thisisatest" and "thisisatest" !! (PASSED) "thisisatest"; expected "thisisatest" function longest_common_substring(a,b) result(match) character(len=*),intent(in) :: a, b character(len=:),allocatable :: match character(len=:),allocatable :: a2, b2 integer :: left, foundat, len_a, i if(len(a) < len(b))then ! to reduce required comparisions look for shortest string in longest string a2=a b2=b else a2=b b2=a endif match='' do i=1,len(a2)-1 len_a=len(a2) do left=1,len_a foundat=index(b2,a2(left:)) if(foundat /= 0.and.len(match) < len_a-left+1)then if(len(a2(left:)) > len(match))then match=a2(left:) exit endif endif enddo if(len(a2) < len(match))exit a2=a2(:len(a2)-1) enddo end function longest_common_substring !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== pure elemental function atoi (string) result(val) ! Convert STRING to an integer value integer(kind=int32) :: val character(len=*), intent(in) :: string character(len=1) :: c integer :: i integer :: j integer :: ilen logical :: neg val = 0 neg=.false. i=0 c=' ' ilen=len(string) do i=1, ilen ! Pass over any leading spaces c = string(i:i) if (c /= ' ') exit enddo if (c == '-') then ! check for +- as first digit neg = .true. i = i + 1 elseif (c == '+') then neg = .false. i = i + 1 endif do j=i,ilen ! Continue as long as its a digit ... c = string(j:j) if (lge(c, '0') .and. lle(c, '9')) then val = 10*val + ichar(c)-48 ! Shift number over and add new digit else exit endif enddo if (neg) val = -val ! Negate the result if necessary end function atoi pure elemental function atol (string) result(val) ! Convert STRING to an integer value integer(kind=int64) :: val character(len=*), intent(in) :: string character(len=1) :: c integer :: i integer :: j integer :: ilen logical :: neg val = 0 neg=.false. i=0 c=' ' ilen=len(string) do i=1, ilen ! Pass over any leading spaces c = string(i:i) if (c /= ' ') exit enddo if (c == '-') then ! check for +- as first digit neg = .true. i = i + 1 elseif (c == '+') then neg = .false. i = i + 1 endif do j=i,ilen ! Continue as long as its a digit ... c = string(j:j) if (lge(c, '0') .and. lle(c, '9')) then val = 10*val + ichar(c)-48 ! Shift number over and add new digit else exit endif enddo if (neg) val = -val ! Negate the result if necessary end function atol !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! aton(3f) - [M_strings:TYPE] function returns argument as a numeric !! value from a string !! (LICENSE:PD) !! !!##SYNOPSIS !! !! logical function aton(str,val[,msg]) !! !! character(len=*),intent(in) :: str !! type(TYPE(kind=KIND)),intent(out) :: val !! character(len=:),allocatable,intent(out) :: msg !! !!##DESCRIPTION !! This function converts a string to a numeric value. !! !!##OPTIONS !! !! str holds string assumed to represent a numeric value !! val returned value. May be REAL or INTEGER. !! msg message describing error when ATON returns .false. !! !!##RETURNS !! aton .true. if the conversion was successful, .false. otherwise !! !!##EXAMPLE !! !! Sample Program: !! !! program demo_aton !! !! use M_strings, only: aton !! implicit none !! character(len=14),allocatable :: strings(:) !! doubleprecision :: dv !! integer :: iv !! real :: rv !! integer :: i !! !! ! 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 !! !! do i=1,size(strings) !! write(*,'(a)',advance='no')'STRING:',strings(i) !! if(aton(strings(i),iv)) write(*,'(g0)',advance='no')':INTEGER ',iv !! if(aton(strings(i),rv)) write(*,'(g0)',advance='no')':INTEGER ',rv !! if(aton(strings(i),dv)) write(*,'(g0)',advance='no')':INTEGER ',dv !! enddo !! !! end program demo_aton !! !! !!##AUTHOR !! John S. Urban !! !!##LICENSE !! Public Domain logical function ator_real32(str,val,msg) use iso_fortran_env, only: wp => real32, ip => int64, int8 ! Convert ASCII-text to DP and return .TRUE. if OK character(len=*),intent(in) :: str real(kind=wp) :: val character(len=:),allocatable,optional,intent(out) :: msg integer(kind=int8),parameter :: upper_e=iachar('E'), lower_e=iachar('e'), upper_d=iachar('D'), lower_d=iachar('d') integer(kind=int8),parameter :: plus_sign=iachar('+'), minus_sign=iachar('-'), decimal=iachar('.') integer(kind=int8),parameter :: space=iachar(' '), digit_0=iachar('0'), digit_9=iachar('9') integer(kind=ip) :: sval(3) integer :: digit_count(3) integer(kind=int8) :: value(3,len(str)) real(kind=wp) :: whole, fractional integer :: power integer :: cnt(6) integer(kind=int8) :: a, part integer :: i, ipos, ios, too_many_digit_count value=0.0_wp cnt=0 digit_count=0 ipos=0 ator_real32 = .false. sval = [1,0,1] part = 1 too_many_digit_count=0 do i = 1, len(str) a=iachar(str(i:i),kind=int8) ipos=ipos+1 select case(a) case(digit_0:digit_9) digit_count(part) = digit_count(part) + 1 if(digit_count(part) < 19)then value(part,digit_count(part)) = a-digit_0 else too_many_digit_count=too_many_digit_count+1 ! so many digit_count just use powers of ten after this endif case(decimal) ! if more than once should report error if(part > 2)cnt(5)=99999 ! decimal in exponent part = 2 ! starting fractional value cnt(1)=cnt(1)+1 case(upper_e,lower_e,upper_d,lower_d) ! if more than once should report error part = 3 cnt(2)=cnt(2)+1 ! if more than one encountered an error ipos=0 case(minus_sign) ! sign in non-standard position or duplicated should report error sval(part) = -1 if(ipos /= 1)cnt(6)=99999 ! sign not first character of whole or exponent part cnt(3)=cnt(3)+1 ! if more than one sign character an error, but caught by not being first case(plus_sign) if(ipos /= 1)cnt(4)=99999 ! sign not first character of whole or exponent part cnt(3)=cnt(3)+1 ! if more than one sign character an error, but caught by not being first case(space) ! should possibly not ignore all internal spaces ipos=ipos-1 case default value(part,:) = 0.0_wp cnt(5)=99999 ! unknown character !return end select enddo ! is no value after E an error? whole=0.0_wp do i = digit_count(1),1,-1 whole=whole+value(1,i)*10**(digit_count(1)-i) enddo power=0 do i = digit_count(3),1,-1 power=power+value(3,i)*10**(digit_count(3)-i) enddo fractional=0.0_wp do i = digit_count(2),1,-1 fractional=fractional+real(value(2,i),kind=wp)/10.0_wp**i enddo associate ( sgn=>sval(1), sexp=>sval(3) ) val = sign(whole + fractional,real(sgn,kind=wp))* (10.0_wp**(power*sexp+too_many_digit_count)) end associate if(all(cnt <= 1).and.ipos /= 0)then ator_real32 = .true. else read(str,fmt=*,iostat=ios) val ! use internal read for INF, NAN for now if(ios == 0)then ator_real32 = .true. else if(present(msg))then if(cnt(5) /= 0)then msg='illegal character in value "'//trim(str)//'"' elseif(cnt(5) /= 0)then msg='decimal in exponent in "'//trim(str)//'"' elseif(cnt(1) >= 2)then msg='multiple decimals in "'//trim(str)//'"' elseif(cnt(2) >= 2)then msg='more than one exponent prefix (e,d,E,D) in "'//trim(str)//'"' elseif(cnt(3) >= 2)then msg='more than one sign character in "'//trim(str)//'"' elseif(cnt(6) /= 0)then msg='- sign character not first in "'//trim(str)//'"' elseif(cnt(4) >= 2)then msg='+ sign character not first in "'//trim(str)//'"' else msg='error in data conversion in "'//trim(str)//'"' endif endif ator_real32 = .false. endif endif end function ator_real32 logical function ator_real64(str,val,msg) use iso_fortran_env, only: wp => real64, ip => int64, int8 ! Convert ASCII-text to DP and return .TRUE. if OK character(len=*),intent(in) :: str real(kind=wp) :: val character(len=:),allocatable,optional,intent(out) :: msg integer(kind=int8),parameter :: upper_e=iachar('E'), lower_e=iachar('e'), upper_d=iachar('D'), lower_d=iachar('d') integer(kind=int8),parameter :: plus_sign=iachar('+'), minus_sign=iachar('-'), decimal=iachar('.') integer(kind=int8),parameter :: space=iachar(' '), digit_0=iachar('0'), digit_9=iachar('9') integer(kind=ip) :: sval(3) integer :: digit_count(3) integer(kind=int8) :: value(3,len(str)) real(kind=wp) :: whole, fractional integer :: power integer :: cnt(6) integer(kind=int8) :: a, part integer :: i, ipos, ios, too_many_digit_count value=0.0_wp cnt=0 digit_count=0 ipos=0 ator_real64 = .false. sval = [1,0,1] part = 1 too_many_digit_count=0 do i = 1, len(str) a=iachar(str(i:i),kind=int8) ipos=ipos+1 select case(a) case(digit_0:digit_9) digit_count(part) = digit_count(part) + 1 if(digit_count(part) < 19)then value(part,digit_count(part)) = a-digit_0 else too_many_digit_count=too_many_digit_count+1 ! so many digit_count just use powers of ten after this endif case(decimal) ! if more than once should report error if(part > 2)cnt(5)=99999 ! decimal in exponent part = 2 ! starting fractional value cnt(1)=cnt(1)+1 case(upper_e,lower_e,upper_d,lower_d) ! if more than once should report error part = 3 cnt(2)=cnt(2)+1 ! if more than one encountered an error ipos=0 case(minus_sign) ! sign in non-standard position or duplicated should report error sval(part) = -1 if(ipos /= 1)cnt(6)=99999 ! sign not first character of whole or exponent part cnt(3)=cnt(3)+1 ! if more than one sign character an error, but caught by not being first case(plus_sign) if(ipos /= 1)cnt(4)=99999 ! sign not first character of whole or exponent part cnt(3)=cnt(3)+1 ! if more than one sign character an error, but caught by not being first case(space) ! should possibly not ignore all internal spaces ipos=ipos-1 case default value(part,:) = 0.0_wp cnt(5)=99999 ! unknown character !return end select enddo ! is no value after E an error? whole=0.0_wp do i = digit_count(1),1,-1 whole=whole+value(1,i)*10**(digit_count(1)-i) enddo power=0 do i = digit_count(3),1,-1 power=power+value(3,i)*10**(digit_count(3)-i) enddo fractional=0.0_wp do i = digit_count(2),1,-1 fractional=fractional+real(value(2,i),kind=wp)/10.0_wp**i enddo associate ( sgn=>sval(1), sexp=>sval(3) ) val = sign(whole + fractional,real(sgn,kind=wp))* (10.0_wp**(power*sexp+too_many_digit_count)) end associate if(all(cnt <= 1).and.ipos /= 0)then ator_real64 = .true. else read(str,fmt=*,iostat=ios) val ! use internal read for INF, NAN for now if(ios == 0)then ator_real64 = .true. else if(present(msg))then if(cnt(5) /= 0)then msg='illegal character in value "'//trim(str)//'"' elseif(cnt(5) /= 0)then msg='decimal in exponent in "'//trim(str)//'"' elseif(cnt(1) >= 2)then msg='multiple decimals in "'//trim(str)//'"' elseif(cnt(2) >= 2)then msg='more than one exponent prefix (e,d,E,D) in "'//trim(str)//'"' elseif(cnt(3) >= 2)then msg='more than one sign character in "'//trim(str)//'"' elseif(cnt(6) /= 0)then msg='- sign character not first in "'//trim(str)//'"' elseif(cnt(4) >= 2)then msg='+ sign character not first in "'//trim(str)//'"' else msg='error in data conversion in "'//trim(str)//'"' endif endif ator_real64 = .false. endif endif end function ator_real64 logical function atoi_int8(str,val,msg) use iso_fortran_env, only: ip => int64, int8 ! Convert ASCII-text to REAL and return .TRUE. if OK character(len=*),intent(in) :: str integer(kind=int8) :: val character(len=:),allocatable,optional,intent(out) :: msg integer(kind=int8),parameter :: plus_sign=iachar('+'), minus_sign=iachar('-') integer(kind=int8),parameter :: space=iachar(' '), digit_0=iachar('0'), digit_9=iachar('9') integer(kind=ip) :: value, sval, digit_count integer :: cnt(6) integer(kind=int8) :: a integer :: i, ipos, too_many_digit_count value=0 cnt=0 digit_count=0 ipos=0 sval = 1 too_many_digit_count=0 do i = 1, len(str) a=iachar(str(i:i),kind=int8) ipos=ipos+1 select case(a) case(digit_0:digit_9) if(digit_count < 19)then value = value*10 + a-digit_0 elseif(real(value*10)+real(a-digit_0) < huge(0_ip))then value = value*10 + a-digit_0 else too_many_digit_count=too_many_digit_count+1 ! so many digit_count just use powers of ten after this endif digit_count = digit_count + 1 case(minus_sign) ! sign in non-standard position or duplicated should report error sval = -1 if(ipos /= 1)cnt(6)=99999 ! sign not first character of whole or exponent part cnt(3)=cnt(3)+1 ! if more than one sign character an error, but caught by not being first case(plus_sign) if(ipos /= 1)cnt(4)=99999 ! sign not first character of whole or exponent part cnt(3)=cnt(3)+1 ! if more than one sign character an error, but caught by not being first case(space) ! should possibly not ignore all internal spaces (and maybe ignore commas too?) ipos=ipos-1 case default value = 0 cnt(5)=99999 ! unknown character end select enddo val = sign(value,sval)* 10**too_many_digit_count if(all(cnt <= 1).and.ipos /= 0)then atoi_int8 = .true. else if(present(msg))then if(cnt(5) /= 0)then msg='illegal character in value "'//trim(str)//'"' elseif(cnt(3) >= 2)then msg='more than one sign character in "'//trim(str)//'"' elseif(cnt(6) /= 0)then msg='- sign character not first in "'//trim(str)//'"' elseif(cnt(4) >= 2)then msg='+ sign character not first in "'//trim(str)//'"' else msg='error in data conversion in "'//trim(str)//'"' endif endif atoi_int8 = .false. endif end function atoi_int8 logical function atoi_int16(str,val,msg) use iso_fortran_env, only: ip => int64, int8 ! Convert ASCII-text to REAL and return .TRUE. if OK character(len=*),intent(in) :: str integer(kind=int16) :: val character(len=:),allocatable,optional,intent(out) :: msg integer(kind=int8),parameter :: plus_sign=iachar('+'), minus_sign=iachar('-') integer(kind=int8),parameter :: space=iachar(' '), digit_0=iachar('0'), digit_9=iachar('9') integer(kind=ip) :: value, sval, digit_count integer :: cnt(6) integer(kind=int8) :: a integer :: i, ipos, too_many_digit_count value=0 cnt=0 digit_count=0 ipos=0 sval = 1 too_many_digit_count=0 do i = 1, len(str) a=iachar(str(i:i),kind=int8) ipos=ipos+1 select case(a) case(digit_0:digit_9) if(digit_count < 19)then value = value*10 + a-digit_0 elseif(real(value*10)+real(a-digit_0) < huge(0_ip))then value = value*10 + a-digit_0 else too_many_digit_count=too_many_digit_count+1 ! so many digit_count just use powers of ten after this endif digit_count = digit_count + 1 case(minus_sign) ! sign in non-standard position or duplicated should report error sval = -1 if(ipos /= 1)cnt(6)=99999 ! sign not first character of whole or exponent part cnt(3)=cnt(3)+1 ! if more than one sign character an error, but caught by not being first case(plus_sign) if(ipos /= 1)cnt(4)=99999 ! sign not first character of whole or exponent part cnt(3)=cnt(3)+1 ! if more than one sign character an error, but caught by not being first case(space) ! should possibly not ignore all internal spaces (and maybe ignore commas too?) ipos=ipos-1 case default value = 0 cnt(5)=99999 ! unknown character end select enddo val = sign(value,sval)* 10**too_many_digit_count if(all(cnt <= 1).and.ipos /= 0)then atoi_int16 = .true. else if(present(msg))then if(cnt(5) /= 0)then msg='illegal character in value "'//trim(str)//'"' elseif(cnt(3) >= 2)then msg='more than one sign character in "'//trim(str)//'"' elseif(cnt(6) /= 0)then msg='- sign character not first in "'//trim(str)//'"' elseif(cnt(4) >= 2)then msg='+ sign character not first in "'//trim(str)//'"' else msg='error in data conversion in "'//trim(str)//'"' endif endif atoi_int16 = .false. endif end function atoi_int16 logical function atoi_int32(str,val,msg) use iso_fortran_env, only: ip => int64, int8 ! Convert ASCII-text to REAL and return .TRUE. if OK character(len=*),intent(in) :: str integer(kind=int32) :: val character(len=:),allocatable,optional,intent(out) :: msg integer(kind=int8),parameter :: plus_sign=iachar('+'), minus_sign=iachar('-') integer(kind=int8),parameter :: space=iachar(' '), digit_0=iachar('0'), digit_9=iachar('9') integer(kind=ip) :: value, sval, digit_count integer :: cnt(6) integer(kind=int8) :: a integer :: i, ipos, too_many_digit_count value=0 cnt=0 digit_count=0 ipos=0 sval = 1 too_many_digit_count=0 do i = 1, len(str) a=iachar(str(i:i),kind=int8) ipos=ipos+1 select case(a) case(digit_0:digit_9) if(digit_count < 19)then value = value*10 + a-digit_0 elseif(real(value*10)+real(a-digit_0) < huge(0_ip))then value = value*10 + a-digit_0 else too_many_digit_count=too_many_digit_count+1 ! so many digit_count just use powers of ten after this endif digit_count = digit_count + 1 case(minus_sign) ! sign in non-standard position or duplicated should report error sval = -1 if(ipos /= 1)cnt(6)=99999 ! sign not first character of whole or exponent part cnt(3)=cnt(3)+1 ! if more than one sign character an error, but caught by not being first case(plus_sign) if(ipos /= 1)cnt(4)=99999 ! sign not first character of whole or exponent part cnt(3)=cnt(3)+1 ! if more than one sign character an error, but caught by not being first case(space) ! should possibly not ignore all internal spaces (and maybe ignore commas too?) ipos=ipos-1 case default value = 0 cnt(5)=99999 ! unknown character end select enddo val = sign(value,sval)* 10**too_many_digit_count if(all(cnt <= 1).and.ipos /= 0)then atoi_int32 = .true. else if(present(msg))then if(cnt(5) /= 0)then msg='illegal character in value "'//trim(str)//'"' elseif(cnt(3) >= 2)then msg='more than one sign character in "'//trim(str)//'"' elseif(cnt(6) /= 0)then msg='- sign character not first in "'//trim(str)//'"' elseif(cnt(4) >= 2)then msg='+ sign character not first in "'//trim(str)//'"' else msg='error in data conversion in "'//trim(str)//'"' endif endif atoi_int32 = .false. endif end function atoi_int32 logical function atoi_int64(str,val,msg) use iso_fortran_env, only: ip => int64, int8 ! Convert ASCII-text to REAL and return .TRUE. if OK character(len=*),intent(in) :: str integer(kind=int64) :: val character(len=:),allocatable,optional,intent(out) :: msg integer(kind=int8),parameter :: plus_sign=iachar('+'), minus_sign=iachar('-') integer(kind=int8),parameter :: space=iachar(' '), digit_0=iachar('0'), digit_9=iachar('9') integer(kind=ip) :: value, sval, digit_count integer :: cnt(6) integer(kind=int8) :: a integer :: i, ipos, too_many_digit_count value=0 cnt=0 digit_count=0 ipos=0 sval = 1 too_many_digit_count=0 do i = 1, len(str) a=iachar(str(i:i),kind=int8) ipos=ipos+1 select case(a) case(digit_0:digit_9) if(digit_count < 19)then value = value*10 + a-digit_0 elseif(real(value*10)+real(a-digit_0) < huge(0_ip))then value = value*10 + a-digit_0 else too_many_digit_count=too_many_digit_count+1 ! so many digit_count just use powers of ten after this endif digit_count = digit_count + 1 case(minus_sign) ! sign in non-standard position or duplicated should report error sval = -1 if(ipos /= 1)cnt(6)=99999 ! sign not first character of whole or exponent part cnt(3)=cnt(3)+1 ! if more than one sign character an error, but caught by not being first case(plus_sign) if(ipos /= 1)cnt(4)=99999 ! sign not first character of whole or exponent part cnt(3)=cnt(3)+1 ! if more than one sign character an error, but caught by not being first case(space) ! should possibly not ignore all internal spaces (and maybe ignore commas too?) ipos=ipos-1 case default value = 0 cnt(5)=99999 ! unknown character end select enddo val = sign(value,sval)* 10**too_many_digit_count if(all(cnt <= 1).and.ipos /= 0)then atoi_int64 = .true. else if(present(msg))then if(cnt(5) /= 0)then msg='illegal character in value "'//trim(str)//'"' elseif(cnt(3) >= 2)then msg='more than one sign character in "'//trim(str)//'"' elseif(cnt(6) /= 0)then msg='- sign character not first in "'//trim(str)//'"' elseif(cnt(4) >= 2)then msg='+ sign character not first in "'//trim(str)//'"' else msg='error in data conversion in "'//trim(str)//'"' endif endif atoi_int64 = .false. endif end function atoi_int64 !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== end module M_strings !>>>>> build/dependencies/M_list/src/M_list.f90 !> !!##NAME !! M_list(3f) - [M_list::INTRO] maintain simple lists !! (LICENSE:PD) !! !!##SYNOPSIS !! !! use M_list, only : insert, replace, remove, locate !! use M_list, only : dictionary !! !!##DESCRIPTION !! !! The M_list(3fm) module allows for maintaining an allocatable array of !! intrinsic type (REAL, INTEGER, CHARACTER) as a sorted list. An example !! is given that creates a keyword-value dictionary using the lists. !! !! The lists are maintained as simple allocatable arrays. Each time an !! entry is added or deleted the array is re-allocated. Because of the !! expense of reallocating the data these routines are best suited for !! maintaining small lists that do not change size frequently. !! !! The advantage of this simplistic approach is that the dictionary !! components are simple arrays of intrinsic types which can be easily !! accessed with standard routines. It is easy to understand, as it !! works with simple arrays. For more demanding applications this would !! be implemented as a linked list, which there are a number of freely !! available examples of; several are listed on the Fortran Wiki. !! !! BASIC LIST !! !! subroutine locate(list,value,place,ier,errmsg) finds the index where a !! value is found or should !! be in a sorted array and !! flag if the value exists !! already !! subroutine insert(list,value,place) insert entry into an allocatable !! array at specified position !! subroutine replace(list,value,place) replace entry in an allocatable !! array at specified position !! subroutine remove(list,place) remove entry from an allocatable !! array at specified position !! !!##EXAMPLES !! !! Sample program !! !! program demo_M_list !! use M_list, only : insert, locate, replace, remove !! ! create a dictionary with character keywords, values, and value lengths !! ! using the routines for maintaining a list !! !! use M_list, only : locate, insert, replace !! implicit none !! character(len=:),allocatable :: keywords(:) !! character(len=:),allocatable :: values(:) !! integer,allocatable :: counts(:) !! integer :: i !! ! insert and replace entries !! call update('b','value of b') !! call update('a','value of a') !! call update('c','value of c') !! call update('c','value of c again') !! call update('d','value of d') !! call update('a','value of a again') !! ! show array !! write(*,'(*(a,"==>","[",a,"]",/))')& !! & (trim(keywords(i)),values(i)(:counts(i)),i=1,size(keywords)) !! ! remove some entries !! call update('a') !! call update('c') !! write(*,'(*(a,"==>","[",a,"]",/))')& !! & (trim(keywords(i)),values(i)(:counts(i)),i=1,size(keywords)) !! ! get some values !! write(*,*)'get b=>',get('b') !! write(*,*)'get d=>',get('d') !! write(*,*)'get notthere=>',get('notthere') !! ! !! contains !! subroutine update(key,valin) !! character(len=*),intent(in) :: key !! character(len=*),intent(in),optional :: valin !! integer :: place !! integer :: ilen !! character(len=:),allocatable :: val !! if(present(valin))then !! val=valin !! ilen=len_trim(val) !! ! find where string is or should be !! call locate(keywords,key,place) !! ! if string was not found insert it !! if(place.lt.1)then !! call insert(keywords,key,iabs(place)) !! call insert(values,val,iabs(place)) !! call insert(counts,ilen,iabs(place)) !! else !! call replace(values,val,place) !! call replace(counts,ilen,place) !! endif !! else !! call locate(keywords,key,place) !! if(place.gt.0)then !! call remove(keywords,place) !! call remove(values,place) !! call remove(counts,place) !! endif !! endif !! end subroutine update !! function get(key) result(valout) !! character(len=*),intent(in) :: key !! character(len=:),allocatable :: valout !! integer :: place !! ! find where string is or should be !! call locate(keywords,key,place) !! if(place.lt.1)then !! valout='' !! else !! valout=values(place)(:counts(place)) !! endif !! end function get !! end program demo_M_list !! !! Results !! !! > d==>[value of d] !! > c==>[value of c again] !! > b==>[value of b] !! > a==>[value of a again] !! > !! > d==>[value of d] !! > b==>[value of b] !! > !! > get b=>value of b !! > get d=>value of d !! > get notthere=> !! !! !! BASIC DICTIONARY !! !! A basic dictionary that uses the basic M_list functions. !! !! Consider using generic linked-list based dictionaries when heavy !! usage is required, now that that is available in more recent versions !! of Fortran. !! !! Note: this does not work with gfortran(1) up to at least 7.4.0 but !! works from at least 10.3.0 and onward. !! !! Dictionary type definition: !! !! type dictionary !! character(len=:),allocatable :: key(:) !! character(len=:),allocatable :: value(:) !! integer,allocatable :: count(:) !! contains !! procedure,public :: get => dict_get !! procedure,public :: set => dict_add !! procedure,public :: del => dict_delete !! procedure,public :: clr => dict_clear !! end type dictionary !! !! %get get value from type(dictionary) given an existing key !! %set set or replace value for type(dictionary) given a key !! %del delete an existing key from type(dictionary) !! %clr empty a type(dictionary) !! %ifdef test if name is defined !! !!##EXAMPLES !! !! Sample program !! !! program test_dictionary !! use M_list, only : dictionary !! implicit none !! type(dictionary) :: table !! ! !! ! create a character string dictionary !! ! !! call table%set('A','aye') !! call table%set('B','bee') !! call table%set('C','see') !! call table%set('D','dee') !! ! !! write(*,*)'A=',table%get('A') !! write(*,*)'C=',table%get('C') !! write(*,*)'notthere=',table%get('notthere') !! ! !! call print_dict() !! ! !! ! delete dictionary entries !! ! !! call table%del('A') !! call table%del('C') !! call table%del('z') ! a noop as there is no key of 'z' !! ! !! call print_dict() !! ! !! ! clear dictionary !! ! !! call table%clr() !! ! !! call print_dict() !! ! !! contains !! ! !! subroutine print_dict() !! integer :: i !! ! the dictionary is just three arrays !! write(*,'("DICTIONARY:")') !! write(*,'(*(a,"==>","[",a,"]",/))') & !! & (trim(table%key(i)), & !! & table%value(i)(:table%count(i)), & !! & i=1,size(table%key)) !! ! !! end subroutine print_dict !! ! !! end program test_dictionary !! !!##AUTHOR !! John S. Urban !!##LICENSE !! Public Domain !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()= !=================================================================================================================================== module M_list use, intrinsic :: iso_fortran_env, only : stderr=>ERROR_UNIT,stdout=>OUTPUT_UNIT ! access computing environment implicit none private public locate ! [M_list] find PLACE in sorted character array where value can be found or should be placed private locate_c private locate_d private locate_r private locate_i public insert ! [M_list] insert entry into a sorted allocatable array at specified position private insert_c private insert_d private insert_r private insert_i private insert_l public replace ! [M_list] replace entry by index from a sorted allocatable array if it is present private replace_c private replace_d private replace_r private replace_i private replace_l public remove ! [M_list] delete entry by index from a sorted allocatable array if it is present private remove_c private remove_d private remove_r private remove_i private remove_l ! ident_1="@(#) M_list locate(3f) Generic subroutine locates where element is or should be in sorted allocatable array" interface locate module procedure locate_c, locate_d, locate_r, locate_i end interface ! ident_2="@(#) M_list insert(3f) Generic subroutine inserts element into allocatable array at specified position" interface insert module procedure insert_c, insert_d, insert_r, insert_i, insert_l end interface ! ident_3="@(#) M_list replace(3f) Generic subroutine replaces element from allocatable array at specified position" interface replace module procedure replace_c, replace_d, replace_r, replace_i, replace_l end interface ! ident_4="@(#) M_list remove(3f) Generic subroutine deletes element from allocatable array at specified position" interface remove module procedure remove_c, remove_d, remove_r, remove_i, remove_l end interface !----------------------------------------------------------------------------------------------------------------------------------- public dictionary type dictionary character(len=:),allocatable :: key(:) character(len=:),allocatable :: value(:) integer,allocatable :: count(:) contains procedure,public :: get => dict_get ! get value associated with a key in a dictionary or return blank procedure,public :: set => dict_add ! insert or replace entry by name into a dictionary procedure,public :: del => dict_delete ! delete entry by name from a dictionary if entry is present procedure,public :: clr => dict_clear ! clear dictionary procedure,public :: ifdef => dict_ifdef ! return if defined or not end type dictionary logical,save :: debug=.false. !==================================================================================================================================! !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !==================================================================================================================================! contains !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()= !=================================================================================================================================== !> !!##NAME !! locate(3f) - [M_list] finds the index where a string is found or !! should be in a sorted array !! (LICENSE:PD) !! !!##SYNOPSIS !! !! subroutine locate(list,value,place,ier,errmsg) !! !! character(len=:)|doubleprecision|real|integer,allocatable :: list(:) !! character(len=*)|doubleprecision|real|integer,intent(in) :: value !! integer, intent(out) :: PLACE !! !! integer, intent(out),optional :: IER !! character(len=*),intent(out),optional :: ERRMSG !! !!##DESCRIPTION !! !! LOCATE(3f) finds the index where the VALUE is found or should !! be found in an array. The array must be sorted in descending !! order (highest at top). If VALUE is not found it returns the index !! where the name should be placed at with a negative sign. !! !! The array and list must be of the same type (CHARACTER, DOUBLEPRECISION, !! REAL,INTEGER) !! !!##OPTIONS !! !! VALUE the value to locate in the list. !! LIST is the list array. !! !!##RETURNS !! PLACE is the subscript that the entry was found at if it is !! greater than zero(0). !! !! If PLACE is negative, the absolute value of !! PLACE indicates the subscript value where the !! new entry should be placed in order to keep the !! list alphabetized. !! !! IER is zero(0) if no error occurs. !! If an error occurs and IER is not !! present, the program is stopped. !! !! ERRMSG description of any error !! !!##EXAMPLES !! !! Find if a string is in a sorted array, and insert the string into !! the list if it is not present ... !! !! program demo_locate !! use M_sort, only : sort_shell !! use M_list, only : locate !! implicit none !! character(len=:),allocatable :: arr(:) !! integer :: i !! !! arr=[character(len=20) :: '', 'ZZZ', 'aaa', 'b', 'xxx' ] !! ! make sure sorted in descending order !! call sort_shell(arr,order='d') !! !! call update(arr,'b') !! call update(arr,'[') !! call update(arr,'c') !! call update(arr,'ZZ') !! call update(arr,'ZZZZ') !! call update(arr,'z') !! !! contains !! subroutine update(arr,string) !! character(len=:),allocatable :: arr(:) !! character(len=*) :: string !! integer :: place, plus, ii, end !! ! find where string is or should be !! call locate(arr,string,place) !! write(*,*)'for "'//string//'" index is ',place, size(arr) !! ! if string was not found insert it !! if(place.lt.1)then !! plus=abs(place) !! ii=len(arr) !! end=size(arr) !! ! empty array !! if(end.eq.0)then !! arr=[character(len=ii) :: string ] !! ! put in front of array !! elseif(plus.eq.1)then !! arr=[character(len=ii) :: string, arr] !! ! put at end of array !! elseif(plus.eq.end)then !! arr=[character(len=ii) :: arr, string ] !! ! put in middle of array !! else !! arr=[character(len=ii) :: arr(:plus-1), string,arr(plus:) ] !! endif !! ! show array !! write(*,'("SIZE=",i0,1x,*(a,","))')end,(trim(arr(i)),i=1,end) !! endif !! end subroutine update !! end program demo_locate !! !! Results !! !! > for "b" index is 2 5 !! > for "[" index is -4 5 !! > SIZE=5 xxx,b,aaa,[,ZZZ, !! > for "c" index is -2 6 !! > SIZE=6 xxx,c,b,aaa,[,ZZZ, !! > for "ZZ" index is -7 7 !! > SIZE=7 xxx,c,b,aaa,[,ZZZ,, !! > for "ZZZZ" index is -6 8 !! > SIZE=8 xxx,c,b,aaa,[,ZZZZ,ZZZ,, !! > for "z" index is -1 9 !! > SIZE=9 z,xxx,c,b,aaa,[,ZZZZ,ZZZ,, !! !!##AUTHOR !! 1989,2017 John S. Urban !!##LICENSE !! Public Domain subroutine locate_c(list,value,place,ier,errmsg) ! ident_5="@(#) M_list locate_c(3f) find PLACE in sorted character array where VALUE can be found or should be placed" character(len=*),intent(in) :: value integer,intent(out) :: place character(len=:),allocatable :: list(:) integer,intent(out),optional :: ier character(len=*),intent(out),optional :: errmsg integer :: i character(len=:),allocatable :: message integer :: arraysize integer :: maxtry integer :: imin, imax integer :: error if(.not.allocated(list))then list=[character(len=max(len_trim(value),2)) :: ] endif arraysize=size(list) if(debug)write(stderr,*)'*locate_c* START ARRAYSIZE=',size(list) error=0 if(arraysize.eq.0)then maxtry=0 place=-1 else maxtry=nint(log(float(arraysize))/log(2.0)+1.0) place=(arraysize+1)/2 endif imin=1 imax=arraysize message='' LOOP: block do i=1,maxtry if(value.eq.list(PLACE))then exit LOOP else if(value.gt.list(place))then imax=place-1 else imin=place+1 endif if(imin.gt.imax)then place=-imin if(iabs(place).gt.arraysize)then ! ran off end of list. Where new value should go or an unsorted input array' exit LOOP endif exit LOOP endif place=(imax+imin)/2 if(place.gt.arraysize.or.place.le.0)then message='*locate* error: search is out of bounds of list. Probably an unsorted input array' error=-1 exit LOOP endif enddo message='*locate* exceeded allowed tries. Probably an unsorted input array' endblock LOOP if(present(ier))then ier=error else if(error.ne.0)then write(stderr,*)message//' VALUE=',trim(value)//' PLACE=',place stop 1 endif if(present(errmsg))then errmsg=message endif if(debug)write(stderr,*)'*locate_c* END PLACE=',place,' ARRAYSIZE=',size(list),' LENGTH=',len(list) end subroutine locate_c subroutine locate_d(list,value,place,ier,errmsg) ! ident_6="@(#) M_list locate_d(3f) find PLACE in sorted doubleprecision array where VALUE can be found or should be placed" ! Assuming an array sorted in descending order ! ! 1. If it is not found report where it should be placed as a NEGATIVE index number. doubleprecision,allocatable :: list(:) doubleprecision,intent(in) :: value integer,intent(out) :: place integer,intent(out),optional :: ier character(len=*),intent(out),optional :: errmsg integer :: i character(len=:),allocatable :: message integer :: arraysize integer :: maxtry integer :: imin, imax integer :: error message='' if(.not.allocated(list))then list=[doubleprecision :: ] endif arraysize=size(list) if(debug)write(stderr,*)'*locate_d* START ARRAYSIZE=',size(list) error=0 if(arraysize.eq.0)then maxtry=0 place=-1 else maxtry=nint(log(float(arraysize))/log(2.0)+1.0) place=(arraysize+1)/2 endif imin=1 imax=arraysize message='' LOOP: block do i=1,maxtry if(value.eq.list(PLACE))then exit LOOP else if(value.gt.list(place))then imax=place-1 else imin=place+1 endif if(imin.gt.imax)then place=-imin if(iabs(place).gt.arraysize)then ! ran off end of list. Where new value should go or an unsorted input array' exit LOOP endif exit LOOP endif place=(imax+imin)/2 if(place.gt.arraysize.or.place.le.0)then message='*locate* error: search is out of bounds of list. Probably an unsorted input array' error=-1 exit LOOP endif enddo message='*locate* exceeded allowed tries. Probably an unsorted input array' endblock LOOP if(present(ier))then ier=error else if(error.ne.0)then write(stderr,*)message//' VALUE=',value,' PLACE=',place stop 1 endif if(present(errmsg))then errmsg=message endif if(debug)write(stderr,*)'*locate_d* END PLACE=',place,' ARRAYSIZE=',size(list) end subroutine locate_d subroutine locate_r(list,value,place,ier,errmsg) ! ident_7="@(#) M_list locate_r(3f) find PLACE in sorted real array where VALUE can be found or should be placed" ! Assuming an array sorted in descending order ! ! 1. If it is not found report where it should be placed as a NEGATIVE index number. real,allocatable :: list(:) real,intent(in) :: value integer,intent(out) :: place integer,intent(out),optional :: ier character(len=*),intent(out),optional :: errmsg integer :: i character(len=:),allocatable :: message integer :: arraysize integer :: maxtry integer :: imin, imax integer :: error if(.not.allocated(list))then list=[real :: ] endif arraysize=size(list) if(debug)write(stderr,*)'*locate_r* START ARRAYSIZE=',size(list) error=0 if(arraysize.eq.0)then maxtry=0 place=-1 else maxtry=nint(log(float(arraysize))/log(2.0)+1.0) place=(arraysize+1)/2 endif imin=1 imax=arraysize message='' LOOP: block do i=1,maxtry if(value.eq.list(PLACE))then exit LOOP else if(value.gt.list(place))then imax=place-1 else imin=place+1 endif if(imin.gt.imax)then place=-imin if(iabs(place).gt.arraysize)then ! ran off end of list. Where new value should go or an unsorted input array' exit LOOP endif exit LOOP endif place=(imax+imin)/2 if(place.gt.arraysize.or.place.le.0)then message='*locate* error: search is out of bounds of list. Probably an unsorted input array' error=-1 exit LOOP endif enddo message='*locate* exceeded allowed tries. Probably an unsorted input array' endblock LOOP if(present(ier))then ier=error else if(error.ne.0)then write(stderr,*)message//' VALUE=',value,' PLACE=',place stop 1 endif if(present(errmsg))then errmsg=message endif if(debug)write(stderr,*)'*locate_r* END PLACE=',place,' ARRAYSIZE=',size(list) end subroutine locate_r subroutine locate_i(list,value,place,ier,errmsg) ! ident_8="@(#) M_list locate_i(3f) find PLACE in sorted integer array where VALUE can be found or should be placed" ! Assuming an array sorted in descending order ! ! 1. If it is not found report where it should be placed as a NEGATIVE index number. integer,allocatable :: list(:) integer,intent(in) :: value integer,intent(out) :: place integer,intent(out),optional :: ier character(len=*),intent(out),optional :: errmsg integer :: i character(len=:),allocatable :: message integer :: arraysize integer :: maxtry integer :: imin, imax integer :: error if(.not.allocated(list))then list=[integer :: ] endif arraysize=size(list) if(debug)write(stderr,*)'*locate_i* START ARRAYSIZE=',size(list) error=0 if(arraysize.eq.0)then maxtry=0 place=-1 else maxtry=nint(log(float(arraysize))/log(2.0)+1.0) place=(arraysize+1)/2 endif imin=1 imax=arraysize message='' LOOP: block do i=1,maxtry if(value.eq.list(PLACE))then exit LOOP else if(value.gt.list(place))then imax=place-1 else imin=place+1 endif if(imin.gt.imax)then place=-imin if(iabs(place).gt.arraysize)then ! ran off end of list. Where new value should go or an unsorted input array' exit LOOP endif exit LOOP endif place=(imax+imin)/2 if(place.gt.arraysize.or.place.le.0)then message='*locate* error: search is out of bounds of list. Probably an unsorted input array' error=-1 exit LOOP endif enddo message='*locate* exceeded allowed tries. Probably an unsorted input array' endblock LOOP if(present(ier))then ier=error else if(error.ne.0)then write(stderr,*)message//' VALUE=',value,' PLACE=',place stop 1 endif if(present(errmsg))then errmsg=message endif if(debug)write(stderr,*)'*locate_i* END PLACE=',place,' ARRAYSIZE=',size(list) end subroutine locate_i !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()= !=================================================================================================================================== !> !!##NAME !! remove(3f) - [M_list] remove entry from an allocatable array at !! specified position !! (LICENSE:PD) !! !!##SYNOPSIS !! !! subroutine remove(list,place) !! !! character(len=:)|doubleprecision|real|integer,intent(inout) :: list(:) !! integer, intent(out) :: PLACE !! !!##DESCRIPTION !! !! Remove a value from an allocatable array at the specified index. !! The array is assumed to be sorted in descending order. It may be of !! type CHARACTER, DOUBLEPRECISION, REAL, or INTEGER. !! !!##OPTIONS !! !! list is the list array. !! PLACE is the subscript for the entry that should be removed !! !!##EXAMPLES !! !! Sample program !! !! program demo_remove !! use M_sort, only : sort_shell !! use M_list, only : locate, remove !! implicit none !! character(len=:),allocatable :: arr(:) !! integer :: i !! integer :: end !! !! arr=[character(len=20) :: '','ZZZ','Z','aaa','b','b','ab','bb','xxx' ] !! ! make sure sorted in descending order !! call sort_shell(arr,order='d') !! !! end=size(arr) !! write(*,'("SIZE=",i0,1x,*(a,","))')end,(trim(arr(i)),i=1,end) !! call remove(arr,1) !! end=size(arr) !! write(*,'("SIZE=",i0,1x,*(a,","))')end,(trim(arr(i)),i=1,end) !! call remove(arr,4) !! end=size(arr) !! write(*,'("SIZE=",i0,1x,*(a,","))')end,(trim(arr(i)),i=1,end) !! !! end program demo_remove !! !! Results !! !! > SIZE=9 xxx,bb,b,b,ab,aaa,ZZZ,Z,, !! > SIZE=8 bb,b,b,ab,aaa,ZZZ,Z,, !! > SIZE=7 bb,b,b,aaa,ZZZ,Z,, !! !!##AUTHOR !! 1989,2017 John S. Urban !!##LICENSE !! Public Domain subroutine remove_c(list,place) ! ident_9="@(#) M_list remove_c(3fp) remove string from allocatable string array at specified position" character(len=:),allocatable :: list(:) integer,intent(in) :: place integer :: ii, end if(debug) write(stderr,*)'*remove_c* START PLACE=',place,' ORIGINALSIZE=',size(list) if(.not.allocated(list))then list=[character(len=2) :: ] endif ii=len(list) end=size(list) if(place.le.0.or.place.gt.end)then ! index out of bounds of array elseif(place.eq.end)then ! remove from array list=[character(len=ii) :: list(:place-1) ] else list=[character(len=ii) :: list(:place-1), list(place+1:) ] endif if(debug)write(stderr,*)'*remove_c* END PLACE=',place,' NEWSIZE=',size(list),' LENGTH=',len(list) end subroutine remove_c subroutine remove_d(list,place) ! ident_10="@(#) M_list remove_d(3fp) remove doubleprecision value from allocatable array at specified position" doubleprecision,allocatable :: list(:) integer,intent(in) :: place integer :: end if(debug) write(stderr,*)'*remove_d* START PLACE=',place,' ORIGINALSIZE=',size(list) if(.not.allocated(list))then list=[doubleprecision :: ] endif end=size(list) if(place.le.0.or.place.gt.end)then ! index out of bounds of array elseif(place.eq.end)then ! remove from array list=[ list(:place-1)] else list=[ list(:place-1), list(place+1:) ] endif if(debug)write(stderr,*)'*remove_d* END PLACE=',place,' NEWSIZE=',size(list) end subroutine remove_d subroutine remove_r(list,place) ! ident_11="@(#) M_list remove_r(3fp) remove value from allocatable array at specified position" real,allocatable :: list(:) integer,intent(in) :: place integer :: end if(debug) write(stderr,*)'*remove_r* START PLACE=',place,' ORIGINALSIZE=',size(list) if(.not.allocated(list))then list=[real :: ] endif end=size(list) if(place.le.0.or.place.gt.end)then ! index out of bounds of array elseif(place.eq.end)then ! remove from array list=[ list(:place-1)] else list=[ list(:place-1), list(place+1:) ] endif if(debug)write(stderr,*)'*remove_r* END PLACE=',place,' NEWSIZE=',size(list) end subroutine remove_r subroutine remove_l(list,place) ! ident_12="@(#) M_list remove_l(3fp) remove value from allocatable array at specified position" logical,allocatable :: list(:) integer,intent(in) :: place integer :: end if(debug) write(stderr,*)'*remove_l* START PLACE=',place,' ORIGINALSIZE=',size(list) if(.not.allocated(list))then list=[logical :: ] endif end=size(list) if(place.le.0.or.place.gt.end)then ! index out of bounds of array elseif(place.eq.end)then ! remove from array list=[ list(:place-1)] else list=[ list(:place-1), list(place+1:) ] endif if(debug)write(stderr,*)'*remove_l* END PLACE=',place,' NEWSIZE=',size(list) end subroutine remove_l subroutine remove_i(list,place) ! ident_13="@(#) M_list remove_i(3fp) remove value from allocatable array at specified position" integer,allocatable :: list(:) integer,intent(in) :: place integer :: end if(debug) write(stderr,*)'*remove_i* START PLACE=',place,' ORIGINALSIZE=',size(list) if(.not.allocated(list))then list=[integer :: ] endif end=size(list) if(place.le.0.or.place.gt.end)then ! index out of bounds of array elseif(place.eq.end)then ! remove from array list=[ list(:place-1)] else list=[ list(:place-1), list(place+1:) ] endif if(debug)write(stderr,*)'*remove_i* END PLACE=',place,' NEWSIZE=',size(list) end subroutine remove_i !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()= !=================================================================================================================================== !> !!##NAME !! replace(3f) - [M_list] replace entry in a string array at specified position !! (LICENSE:PD) !! !!##SYNOPSIS !! !! subroutine replace(list,value,place) !! !! character(len=*)|doubleprecision|real|integer,intent(in) :: value !! character(len=:)|doubleprecision|real|integer,intent(in) :: list(:) !! integer, intent(out) :: PLACE !! !!##DESCRIPTION !! !! replace a value in an allocatable array at the specified index. Unless !! the array needs the string length to increase this is merely an assign !! of a value to an array element. !! !! The array may be of type CHARACTER, DOUBLEPRECISION, REAL, or INTEGER. !! It is assumed to be sorted in descending order without duplicate !! values. !! !! The value and list must be of the same type. !! !!##OPTIONS !! !! VALUE the value to place in the array !! LIST is the array. !! PLACE is the subscript that the entry should be placed at !! !!##EXAMPLES !! !! Replace key-value pairs in a dictionary !! !! program demo_replace !! use M_list, only : insert, locate, replace !! ! Find if a key is in a list and insert it !! ! into the key list and value list if it is not present !! ! or replace the associated value if the key existed !! implicit none !! character(len=20) :: key !! character(len=100) :: val !! character(len=:),allocatable :: keywords(:) !! character(len=:),allocatable :: values(:) !! integer :: i !! integer :: place !! call update('b','value of b') !! call update('a','value of a') !! call update('c','value of c') !! call update('c','value of c again') !! call update('d','value of d') !! call update('a','value of a again') !! ! show array !! write(*,'(*(a,"==>",a,/))')& !! &(trim(keywords(i)),trim(values(i)),i=1,size(keywords)) !! !! call locate(keywords,'a',place) !! if(place.gt.0)then !! write(*,*)'The value of "a" is ',trim(values(place)) !! else !! write(*,*)'"a" not found' !! endif !! !! contains !! subroutine update(key,val) !! character(len=*),intent(in) :: key !! character(len=*),intent(in) :: val !! integer :: place !! !! ! find where string is or should be !! call locate(keywords,key,place) !! ! if string was not found insert it !! if(place.lt.1)then !! call insert(keywords,key,abs(place)) !! call insert(values,val,abs(place)) !! else ! replace !! call replace(values,val,place) !! endif !! !! end subroutine update !! end program demo_replace !! !! Results !! !! > d==>value of d !! > c==>value of c again !! > b==>value of b !! > a==>value of a again !! !!##AUTHOR !! 1989,2017 John S. Urban !!##LICENSE !! Public Domain subroutine replace_c(list,value,place) ! ident_14="@(#) M_list replace_c(3fp) replace string in allocatable string array at specified position" character(len=*),intent(in) :: value character(len=:),allocatable :: list(:) character(len=:),allocatable :: kludge(:) integer,intent(in) :: place integer :: ii integer :: tlen integer :: end if(debug) write(stderr,*)'*replace_c* START VALUE=',trim(value),' PLACE=',place,' ORIGINALSIZE=',size(list) if(.not.allocated(list))then list=[character(len=max(len_trim(value),2)) :: ] endif tlen=len_trim(value) end=size(list) if(place.lt.0.or.place.gt.end)then write(stderr,*)'*replace_c* error: index out of range. end=',end,' index=',place elseif(len_trim(value).le.len(list))then list(place)=value else ! increase length of variable ii=max(tlen,len(list)) kludge=[character(len=ii) :: list ] list=kludge list(place)=value endif if(debug)write(stderr,*)'*replace_c* END VALUE=',trim(value),' PLACE=',place,' NEWSIZE=',size(list),' LENGTH=',len(list) end subroutine replace_c subroutine replace_d(list,value,place) ! ident_15="@(#) M_list replace_d(3fp) place doubleprecision value into allocatable array at specified position" doubleprecision,intent(in) :: value doubleprecision,allocatable :: list(:) integer,intent(in) :: place integer :: end if(debug) write(stderr,*)'*replace_d* START VALUE=',value,' PLACE=',place,' ORIGINALSIZE=',size(list) if(.not.allocated(list))then list=[doubleprecision :: ] endif end=size(list) if(end.eq.0)then ! empty array list=[value] elseif(place.gt.0.and.place.le.end)then list(place)=value else ! put in middle of array write(stderr,*)'*replace_d* error: index out of range. end=',end,' index=',place endif if(debug)write(stderr,*)'*replace_d* END VALUE=',value,' PLACE=',place,' NEWSIZE=',size(list) end subroutine replace_d subroutine replace_r(list,value,place) ! ident_16="@(#) M_list replace_r(3fp) place value into allocatable array at specified position" real,intent(in) :: value real,allocatable :: list(:) integer,intent(in) :: place integer :: end if(debug) write(stderr,*)'*replace_r* START REPLACE_R VALUE=',value,' PLACE=',place,' ORIGINALSIZE=',size(list) if(.not.allocated(list))then list=[real :: ] endif end=size(list) if(end.eq.0)then ! empty array list=[value] elseif(place.gt.0.and.place.le.end)then list(place)=value else ! put in middle of array write(stderr,*)'*replace_r* error: index out of range. end=',end,' index=',place endif if(debug)write(stderr,*)'*replace_r* END REPLACE_R VALUE=',value,' PLACE=',place,' NEWSIZE=',size(list) end subroutine replace_r subroutine replace_l(list,value,place) ! ident_17="@(#) M_list replace_l(3fp) place value into allocatable array at specified position" logical,allocatable :: list(:) logical,intent(in) :: value integer,intent(in) :: place integer :: end if(.not.allocated(list))then list=[logical :: ] endif end=size(list) if(debug)write(stderr,*)'*replace_l* START REPLACE_L VALUE=',value,' PLACE=',place,' ORIGINALSIZE=',size(list) if(end.eq.0)then ! empty array list=[value] elseif(place.gt.0.and.place.le.end)then list(place)=value else ! put in middle of array write(stderr,*)'*replace_l* error: index out of range. end=',end,' index=',place endif if(debug)write(stderr,*)'*replace_l* END REPLACE_L VALUE=',value,' PLACE=',place,' NEWSIZE=',size(list) end subroutine replace_l subroutine replace_i(list,value,place) ! ident_18="@(#) M_list replace_i(3fp) place value into allocatable array at specified position" integer,intent(in) :: value integer,allocatable :: list(:) integer,intent(in) :: place integer :: end if(.not.allocated(list))then list=[integer :: ] endif end=size(list) if(debug)write(stderr,*)'*replace_i* START VALUE=',value,' PLACE=',place,' ORIGINALSIZE=',size(list) if(end.eq.0)then ! empty array list=[value] elseif(place.gt.0.and.place.le.end)then list(place)=value else ! put in middle of array write(stderr,*)'*replace_i* error: index out of range. end=',end,' index=',place endif if(debug)write(stderr,*)'*replace_i* END VALUE=',value,' PLACE=',place,' NEWSIZE=',size(list) end subroutine replace_i !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()= !=================================================================================================================================== !> !!##NAME !! insert(3f) - [M_list] insert entry into a string array at specified position !! (LICENSE:PD) !! !!##SYNOPSIS !! !! subroutine insert(list,value,place) !! !! character(len=*)|doubleprecision|real|integer,intent(in) :: value !! character(len=:)|doubleprecision|real|integer,intent(in) :: list(:) !! integer,intent(in) :: place !! !!##DESCRIPTION !! !! Insert a value into an allocatable array at the specified index. !! The list and value must be of the same type (CHARACTER, DOUBLEPRECISION, !! REAL, or INTEGER) !! !!##OPTIONS !! !! list is the list array. Must be sorted in descending order. !! value the value to place in the array !! PLACE is the subscript that the entry should be placed at !! !!##EXAMPLES !! !! Find if a string is in a sorted array, and insert the string into !! the list if it is not present ... !! !! program demo_insert !! use M_sort, only : sort_shell !! use M_list, only : locate, insert !! implicit none !! character(len=:),allocatable :: arr(:) !! integer :: i !! !! arr=[character(len=20) :: '', 'ZZZ', 'aaa', 'b', 'xxx' ] !! ! make sure sorted in descending order !! call sort_shell(arr,order='d') !! ! add or replace values !! call update(arr,'b') !! call update(arr,'[') !! call update(arr,'c') !! call update(arr,'ZZ') !! call update(arr,'ZZZ') !! call update(arr,'ZZZZ') !! call update(arr,'') !! call update(arr,'z') !! !! contains !! subroutine update(arr,string) !! character(len=:),allocatable :: arr(:) !! character(len=*) :: string !! integer :: place, end !! !! end=size(arr) !! ! find where string is or should be !! call locate(arr,string,place) !! ! if string was not found insert it !! if(place.lt.1)then !! call insert(arr,string,abs(place)) !! endif !! ! show array !! end=size(arr) !! write(*,'("array is now SIZE=",i0,1x,*(a,","))')end,(trim(arr(i)),i=1,end) !! !! end subroutine update !! end program demo_insert !! !! Results !! !! > array is now SIZE=5 xxx,b,aaa,ZZZ,, !! > array is now SIZE=6 xxx,b,aaa,[,ZZZ,, !! > array is now SIZE=7 xxx,c,b,aaa,[,ZZZ,, !! > array is now SIZE=8 xxx,c,b,aaa,[,ZZZ,ZZ,, !! > array is now SIZE=9 xxx,c,b,aaa,[,ZZZZ,ZZZ,ZZ,, !! > array is now SIZE=10 z,xxx,c,b,aaa,[,ZZZZ,ZZZ,ZZ,, !! !!##AUTHOR !! 1989,2017 John S. Urban !!##LICENSE !! Public Domain subroutine insert_c(list,value,place) ! ident_19="@(#) M_list insert_c(3fp) place string into allocatable string array at specified position" character(len=*),intent(in) :: value character(len=:),allocatable :: list(:) integer,intent(in) :: place integer :: ii integer :: end if(debug) write(stderr,*)'*insert_c* START VALUE=',trim(value),' PLACE=',place,' ORIGINALSIZE=',size(list) if(.not.allocated(list))then list=[character(len=max(len_trim(value),2)) :: ] endif ii=max(len_trim(value),len(list),2) end=size(list) !call slower() call faster(ii) if(debug)write(stderr,*)'*insert_c* END VALUE=',trim(value),' PLACE=',place,' NEWSIZE=',size(list) contains subroutine slower() character(len=:),allocatable :: kludge(:) if(end.eq.0)then ! empty array list=[character(len=ii) :: value ] elseif(place.eq.1)then ! put in front of array kludge=[character(len=ii) :: value, list] list=kludge elseif(place.gt.end)then ! put at end of array kludge=[character(len=ii) :: list, value ] list=kludge elseif(place.ge.2.and.place.le.end)then ! put in middle of array kludge=[character(len=ii) :: list(:place-1), value,list(place:) ] list=kludge else ! index out of range write(stderr,*)'*insert_c* error: index out of range. end=',end,' index=',place,' value=',value endif end subroutine slower subroutine faster(ilen) integer,intent(in) :: ilen character(len=:),allocatable :: temp(:) allocate(character(len=ilen) :: temp(size(list)+1)) if(end.eq.0)then ! empty array temp(:)=[character(len=ii) :: value ] elseif(place.eq.1)then ! put in front of array temp(1)=value temp(2:)=list elseif(place.gt.end)then ! put at end of array temp(1:end)=list temp(end+1)=value elseif(place.ge.2.and.place.le.end)then ! put in middle of array temp(:place-1)=list(:place-1) temp(place)=value temp(place+1:)=list(place:) else ! index out of range write(stderr,*)'*insert_c* error: index out of range. end=',end,' index=',place,' value=',value endif call move_alloc (from=temp, to=list) end subroutine faster end subroutine insert_c subroutine insert_r(list,value,place) ! ident_20="@(#) M_list insert_r(3fp) place real value into allocatable array at specified position" real,intent(in) :: value real,allocatable :: list(:) integer,intent(in) :: place integer :: end if(debug) write(stderr,*)'*insert_r* START VALUE=',value,' PLACE=',place,' ORIGINALSIZE=',size(list) if(.not.allocated(list))then list=[real :: ] endif end=size(list) if(end.eq.0)then ! empty array list=[value] elseif(place.eq.1)then ! put in front of array list=[value, list] elseif(place.gt.end)then ! put at end of array list=[list, value ] elseif(place.ge.2.and.place.le.end)then ! put in middle of array list=[list(:place-1), value,list(place:) ] else ! index out of range write(stderr,*)'*insert_r* error: index out of range. end=',end,' index=',place,' value=',value endif if(debug)write(stderr,*)'*insert_r* END VALUE=',value,' PLACE=',place,' NEWSIZE=',size(list) end subroutine insert_r subroutine insert_d(list,value,place) ! ident_21="@(#) M_list insert_d(3fp) place doubleprecision value into allocatable array at specified position" doubleprecision,intent(in) :: value doubleprecision,allocatable :: list(:) integer,intent(in) :: place integer :: end if(debug) write(stderr,*)'*insert_d* START VALUE=',value,' PLACE=',place,' ORIGINALSIZE=',size(list) if(.not.allocated(list))then list=[doubleprecision :: ] endif end=size(list) if(end.eq.0)then ! empty array list=[value] elseif(place.eq.1)then ! put in front of array list=[value, list] elseif(place.gt.end)then ! put at end of array list=[list, value ] elseif(place.ge.2.and.place.le.end)then ! put in middle of array list=[list(:place-1), value,list(place:) ] else ! index out of range write(stderr,*)'*insert_d* error: index out of range. end=',end,' index=',place,' value=',value endif if(debug)write(stderr,*)'*insert_d* END VALUE=',value,' PLACE=',place,' NEWSIZE=',size(list) end subroutine insert_d subroutine insert_l(list,value,place) ! ident_22="@(#) M_list insert_l(3fp) place value into allocatable array at specified position" logical,allocatable :: list(:) logical,intent(in) :: value integer,intent(in) :: place integer :: end if(.not.allocated(list))then list=[logical :: ] endif end=size(list) if(debug)write(stderr,*)'*insert_l* START VALUE=',value,' PLACE=',place,' ORIGINALSIZE=',size(list) if(end.eq.0)then ! empty array list=[value] elseif(place.eq.1)then ! put in front of array list=[value, list] elseif(place.gt.end)then ! put at end of array list=[list, value ] elseif(place.ge.2.and.place.le.end)then ! put in middle of array list=[list(:place-1), value,list(place:) ] else ! index out of range write(stderr,*)'*insert_l* error: index out of range. end=',end,' index=',place,' value=',value endif if(debug)write(stderr,*)'*insert_l* END VALUE=',value,' PLACE=',place,' NEWSIZE=',size(list) end subroutine insert_l subroutine insert_i(list,value,place) ! ident_23="@(#) M_list insert_i(3fp) place value into allocatable array at specified position" integer,allocatable :: list(:) integer,intent(in) :: value integer,intent(in) :: place integer :: end if(.not.allocated(list))then list=[integer :: ] endif end=size(list) if(debug)write(stderr,*)'*insert_i* START VALUE=',value,' PLACE=',place,' ORIGINALSIZE=',size(list) if(end.eq.0)then ! empty array list=[value] elseif(place.eq.1)then ! put in front of array list=[value, list] elseif(place.gt.end)then ! put at end of array list=[list, value ] elseif(place.ge.2.and.place.le.end)then ! put in middle of array list=[list(:place-1), value,list(place:) ] else ! index out of range write(stderr,*)'*insert_i* error: index out of range. end=',end,' index=',place,' value=',value endif if(debug)write(stderr,*)'*insert_i* END VALUE=',value,' PLACE=',place,' NEWSIZE=',size(list) end subroutine insert_i !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()= !=================================================================================================================================== !> !!##NAME !! del(3f) - [M_list::dictionary::OOPS] delete entry by key name from !! a basic dictionary !! (LICENSE:PD) !! !!##SYNOPSIS !! !! type(dictionary) :: dict !! !! character(len=*),intent(in) :: key !! !! dict%del(key) !! !!##DESCRIPTION !! !! Delete an entry from a basic dictionary if it is present. !! !!##OPTIONS !! !! DICT the dictionary. !! KEY the key name to find and delete from the dictionary. !! !!##EXAMPLES !! !! Delete an entry from a dictionary by key name. !! !! program demo_del !! use M_list, only : dictionary !! implicit none !! type(dictionary) :: caps !! integer :: i !! ! create a character string dictionary !! call caps%set('A','aye') !! call caps%set('B','bee') !! call caps%set('C','see') !! call caps%set('D','dee') !! ! show current dictionary !! write(*,101)(trim(caps%key(i)),trim(caps%value(i)),i=1,size(caps%key)) !! ! delete dictionary entries !! call caps%del('A') !! call caps%del('C') !! call caps%del('z') ! a noop as there is no key of 'z' !! ! show current dictionary !! write(*,101)(trim(caps%key(i)),trim(caps%value(i)),i=1,size(caps%key)) !! !! 101 format (1x,*(a,"='",a,"'",:,",")) !! end program demo_del !! !! Results !! !! > D='dee',C='see',B='bee',A='aye' !! > D='dee',B='bee' !! !!##AUTHOR !! John S. Urban !!##LICENSE !! Public Domain subroutine dict_delete(self,key) ! ident_24="@(#) M_list dict_delete(3f) remove string from sorted allocatable string array if present" class(dictionary),intent(in) :: self character(len=*),intent(in) :: key integer :: place call locate(self%key,key,place) if(place.ge.1)then call remove(self%key,place) call remove(self%value,place) call remove(self%count,place) endif end subroutine dict_delete !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()= !=================================================================================================================================== !> !!##NAME !! get(3f) - [M_list::dictionary::OOPS] get value of key-value pair in !! a dictionary given key !! (LICENSE:PD) !! !!##SYNOPSIS !! !! type(dictionary) :: dict !! !! character(len=*),intent(in) :: key !! character(len=*),intent(in) :: VALUE !! !! value=dict%get(key) !! !! !!##DESCRIPTION !! !! get a value given a key from a key-value dictionary !! !! If key is not found in dictionary , return a blank !! !!##OPTIONS !! !! DICT is the dictionary. !! KEY key name !! VALUE value associated with key !! !!##EXAMPLES !! !! Sample program: !! !! program demo_get !! use M_list, only : dictionary !! implicit none !! type(dictionary) :: table !! character(len=:),allocatable :: val !! integer :: i !! !! call table%set('A','value for A') !! call table%set('B','value for B') !! call table%set('C','value for C') !! call table%set('D','value for D') !! call table%set('E','value for E') !! call table%set('F','value for F') !! call table%set('G','value for G') !! !! write(*,*)'A=',table%get('A') !! write(*,*)'B=',table%get('B') !! write(*,*)'C=',table%get('C') !! write(*,*)'D=',table%get('D') !! write(*,*)'E=',table%get('E') !! write(*,*)'F=',table%get('F') !! write(*,*)'G=',table%get('G') !! write(*,*)'H=',table%get('H') !! !! end program demo_get !! !! Results !! !! > A=value for A !! > B=value for B !! > C=value for C !! > D=value for D !! > E=value for E !! > F=value for F !! > G=value for G !! > H= !! !!##AUTHOR !! John S. Urban !!##LICENSE !! Public Domain function dict_get(self,key) result(value) ! ident_25="@(#) M_list dict_get(3f) get value of key-value pair in dictionary given key" class(dictionary),intent(in) :: self character(len=*),intent(in) :: key character(len=:),allocatable :: value integer :: place call locate(self%key,key,place) if(place.lt.1)then value='' else value=self%value(place)(:self%count(place)) endif end function dict_get !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()= !=================================================================================================================================== !> !!##NAME !! set(3f) - [M_list::dictionary::OOPS] add or replace a key-value pair !! in a dictionary !! (LICENSE:PD) !! !!##SYNOPSIS !! !! type(dictionary) :: dict !! !! character(len=*),intent(in) :: key !! character(len=*),intent(in) :: VALUE !! !! call dict%rep(key,value) !! !!##DESCRIPTION !! Add or replace a key-value pair in a dictionary. !! !!##OPTIONS !! DICT is the dictionary. !! key key name !! VALUE value associated with key !! !!##EXAMPLES !! !! Add or replace a key and value pair in a dictionary !! !! program demo_set !! use M_list, only : dictionary !! implicit none !! type(dictionary) :: dict !! integer :: i !! !! call dict%set('A','b') !! call dict%set('B','^') !! call dict%set('C',' ') !! call dict%set('D','c') !! call dict%set('E','ZZ') !! call dict%set('F','ZZZZ') !! call dict%set('G','z') !! call dict%set('A','new value for A') !! !! write(*,'(*(a,"==>","[",a,"]",/))') & !! & (trim(dict%key(i)), & !! & dict%value(i)(:dict%count(i)), & !! & i=1,size(dict%key)) !! !! end program demo_set !! !! Results !! !! > G==>[z] !! > F==>[ZZZZ] !! > E==>[ZZ] !! > D==>[c] !! > C==>[] !! > B==>[^] !! > A==>[new value for A] !! !!##AUTHOR !! John S. Urban !!##LICENSE !! Public Domain subroutine dict_add(self,key,value) ! ident_26="@(#) M_list dict_add(3f) place key-value pair into dictionary adding the key if required" class(dictionary),intent(inout) :: self character(len=*),intent(in) :: key character(len=*),intent(in) :: value integer :: place integer :: place2 call locate(self%key,key,place) if(place.le.0)then place2=iabs(place) call insert( self%key, key, place2 ) call insert( self%value, value, place2 ) call insert( self%count, len_trim(value), place2 ) elseif(place.gt.0)then ! replace instead of insert call replace( self%value, value, place ) call replace( self%count, len_trim(value), place ) endif end subroutine dict_add !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()= !=================================================================================================================================== !> !!##NAME !! clr(3f) - [M_list::dictionary::OOPS] clear basic dictionary !! (LICENSE:PD) !! !!##SYNOPSIS !! !! type(dictionary) :: dict !! !! call dict%clr() !! !!##DESCRIPTION !! !! clear a basic dictionary. !! !!##OPTIONS !! !! DICT the dictionary. !! !!##EXAMPLES !! !! create and clear a basic dictionary !! !! program demo_clr !! use M_list, only : dictionary !! implicit none !! type(dictionary) :: caps !! integer :: i !! ! create a character string dictionary !! call caps%set('A','aye') !! call caps%set('B','bee') !! call caps%set('C','see') !! call caps%set('D','dee') !! ! show current dictionary !! write(*,'("DICTIONARY BEFORE CLEARED")') !! write(*,101)(trim(caps%key(i)),trim(caps%value(i)),i=1,size(caps%key)) !! call caps%clr() !! write(*,'("DICTIONARY AFTER CLEARED")') !! ! show current dictionary !! write(*,101)(trim(caps%key(i)),trim(caps%value(i)),i=1,size(caps%key)) !! !! 101 format (1x,*(a,"='",a,"'",:,",")) !! end program demo_clr !! !! Results !! !! > DICTIONARY BEFORE CLEARED !! > D='dee',C='see',B='bee',A='aye' !! > DICTIONARY AFTER CLEARED !! !!##AUTHOR !! John S. Urban !!##LICENSE !! Public Domain subroutine dict_clear(self) ! ident_27="@(#) M_list dict_clear(3f) clear basic dictionary" class(dictionary),intent(inout) :: self integer :: i do i=size(self%key),1,-1 call self%del(self%key(i)) enddo end subroutine dict_clear !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()= !=================================================================================================================================== !> !!##NAME !! ifdef(3f) - [M_list::dictionary::OOPS] return whether name is present !! in dictionary or not !! (LICENSE:PD) !! !!##SYNOPSIS !! !! type(dictionary) :: dict !! !! character(len=*),intent(in) :: key !! logical :: value !! !! value=dict%ifdef(key) !! !! !!##DESCRIPTION !! !! determine if name is already defined in dictionary or not !! !!##OPTIONS !! !! DICT is the dictionary. !! KEY key name !! !!##RETURNS !! VALUE .FALSE. if name not defined, .TRUE if name is defined. !! !!##EXAMPLES !! !! Sample program: !! !! program demo_ifdef !! use M_list, only : dictionary !! implicit none !! type(dictionary) :: table !! character(len=:),allocatable :: val !! integer :: i !! !! call table%set('A','value for A') !! call table%set('B','value for B') !! call table%set('C','value for C') !! call table%set('D','value for D') !! call table%set('E','value for E') !! call table%set('F','value for F') !! call table%set('G','value for G') !! call table%del('F') !! call table%del('D') !! !! write(*,*)'A=',table%ifdef('A') !! write(*,*)'B=',table%ifdef('B') !! write(*,*)'C=',table%ifdef('C') !! write(*,*)'D=',table%ifdef('D') !! write(*,*)'E=',table%ifdef('E') !! write(*,*)'F=',table%ifdef('F') !! write(*,*)'G=',table%ifdef('G') !! write(*,*)'H=',table%ifdef('H') !! !! end program demo_ifdef !! !! Results: !! !! > A= T !! > B= T !! > C= T !! > D= F !! > E= T !! > F= F !! > G= T !! > H= F !! !!##AUTHOR !! John S. Urban !!##LICENSE !! Public Domain function dict_ifdef(self,key) result(value) ! ident_28="@(#) M_list dict_ifdef(3f) return whether name is defined or not" class(dictionary),intent(in) :: self character(len=*),intent(in) :: key logical :: value integer :: place call locate(self%key,key,place) if(place.lt.1)then value=.false. else value=.true. endif end function dict_ifdef !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()= !=================================================================================================================================== end module M_list !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()= !=================================================================================================================================== !>>>>> build/dependencies/M_history/src/M_history.f90 !> !!##NAME !! redo(3f) - [M_history] Fortran-based Input History Editor !! (LICENSE:MIT) !! !!##SYNOPSIS !! !! subroutine redo(inputline,r) !! !! character(len=*) :: inputline !! character(len=1),intent(in),optional :: r !! !!##DESCRIPTION !! the redo(3f) routine lets you recall, list, save, and modify previously !! entered program input. Built-in help is included. !! !! The redo(3f) input history editor is a simple-to-use input history !! editor interface modeled on the CDC NOS command REDO. It uses a !! line editor model that means no special escape characters or control !! characters are required. Typically, only a few minutes are required !! to master usage. !! !! When using redo(3f) input lines are usually first read into a character !! variable and then passed to the routine. The returned string can then !! be parsed or read from with an internal READ(3f). So, for example, !! if you have an existing READ(3f) such as !! !! READ(*,101) A,I,K !! !! replace it with something similar to !! !! USE M_HISTORY,ONLY : REDO !! CHARACTER(LEN=255) :: LINE ! make variable big enough to read a line !! : !! : !! READ(*,'(A)') LINE ! read line into character variable !! CALL REDO(LINE) ! pass line to REDO(3f). This is a no-op except !! ! for storing the line into the input history !! ! unless the input line is the "r" command !! READ(LINE,101)A,I,K ! read from variable like you did from file !!##OPTIONS !! inputline line to record into history buffer file or to edit. !! !! r Optional character to use as command to invoke editing. !! Defaults to 'r'. !! !!##USAGE !! When prompted for an input line by your program you may at any time !! enter "r" on a line by itself, or a line beginning with "r r_command" !! and you will enter the command history edit mode. Now you can recall !! and edit previous input or compose an input line using the editor !! commands. !! !! By default, you will be editing the last line you entered, shifted !! one character to the right by an exclamation character. !! !! The character you respond with in column one controls what happens next. !! !! o If you enter "?" while in command edit mode, help is displayed. !! !! o If the last input line is not the desired line to edit, !! select the line to edit by entering its line number or by !! using the /,l,u, and d commands (see below for details) to find the desired input line. !! o Next enter an editing directive (c,m) to edit the selected line. The !! "change" command will change all occurrences of an old string to a !! new string ... !! !! c/old/new/ !! !! o or the "modify" command can be used with the special characters # & and ^ ... !! o A # under a character will delete a character. !! o An "&" (ampersand) will cause the character above it to be replaced with a space. !! o To insert a string enter ^string#. !! o Otherwise, enter a character under one in the currently displayed command and it will replace it. !! o hit RETURN to start another edit of the line !! o Once the change is executed you will be prompted for another edit !! directive !! o You will stay in edit mode until you enter a return on a !! blank line to feed your line to your program; or enter "." or !! "q" (which means cancel changes and return a blank line). !! !! A detailed summary of the main edit-mode commands follows. In the !! descriptions, N stands for a number ... !! !! LISTING COMMAND HISTORY !! l|p N list from line N. -N shows N last lines !! L|P N same as 'l' except no line numbers (for pasting) !! /string search for simple string in all history lines !! !! Note that the buffer is set to the last line displayed !! !! POSITIONING TO PREVIOUS COMMANDS !! u N up through buffer !! d N down through buffer !! N load line number !! !! EDITING THE CURRENT BUFFER LINE !! c/oldstring/newstring/ change all occurrences of old string !! to new string. Note that s !! (for substitute) is a synonym for c !! (for change). !! !! For the "c" directive the second character !! becomes the delimiter. Traditionally one !! usually uses a delimiter of / unless the !! string you are editing contains /. !! !! mmod_string If the first character of your entry is m or blank, !! o REPLACE a string by entering a replacement character under it !! o LEAVE a character alone by leaving a space under it !! o DELETE a character by putting a # character under it !! o BLANK OUT a character by putting an & under it !! o INSERT A STRING by entering ^STRING# !! !! The "modify" directive takes a little practice but this single !! directive accommodates positionally deleting, replacing, and !! inserting text. it is hardest using "modify" to put the strings !! "&" and "#" into your lines. to put a # or & character into a !! string use the 'c' command instead or ^&# or ^##. !! !! ;N N N N ... Append specified lines to current line !! !! HELP !! h|? display help text !! !! SYSTEM COMMANDS !! !cmd execute system command !! !! DUMPING AND LOADING THE COMMAND HISTORY !! !! w FILENAME write entire command history to specified file !! r FILENAME replace command history with file contents !! a FILENAME append lines from file onto command history !! !!##EXAMPLE PROGRAM !! Sample program !! !! program demo_redo !! use M_history, only : redo !! implicit none !! character(len=1024) :: line !! integer :: ios !! integer :: cstat !! character(len=256) :: sstat !! write(*,'(a)') & !! & 'REDO(3f) COMMAND INPUT EDITOR', & !! & 'enter "r" or "r r_command" on the input line to go', & !! & 'into history edit mode. Once in history edit mode you', & !! & 'may enter "?" to get some help. Enter "quit" to exit', & !! & 'the program.' !! do !! write(*,'(a)',advance='no')'>->' ! write prompt !! read(*,'(a)',iostat=ios) line ! read new input line !! ! if "r", edit and return a line from the history editor !! call redo(line) ! store into history if not "r". !! if(line == 'quit')stop ! exit program if user enters "quit" !! ! now call user code to process new line of data !! ! As an example, call the system shell !! call execute_command_line(trim(line),cmdstat=cstat,cmdmsg=sstat) !! enddo !! end program demo_redo !! !!##SAMPLE USAGE !! !! The example program is basically a loop that reads a command from !! standard input and then executes it as a subshell unless the "r" !! command is entered. !! !! Now, we will enter an echo(1) command followed by a few other lines !! of input. Then we recall the echo(1) command and use a few of the !! features of redo(3) to change and then re-execute the command. !! !! >echo This isss a Test !! This isss a Test !! >date !! Sun May 31 23:54:09 EDT 2009 !! >pwd !! /cygdrive/c/urbanjs/MYCYGWIN/DISKA/public_html/public/CLONE/REDO !! >r ! enter edit mode !! 00001 echo This isss a Test ! last commands are displayed !! 00002 date !! 00003 pwd !! !pwd !! >1 ! go to first line in history !! !echo This isss a Test !! ## t ! delete and replace characters !! !echo This is a test ! insert a string !! ^new # !! !echo This is a new test !! c/test/TEST/ ! change a substring !! !echo This is a new TEST !! & | replace character with spaces !! !echo This is a newTEST !! ! a blank line ends editing !! This is a newTEST !! >quit !! !!##AUTHOR !! John S. Urban, 1988,2009,2011,2015 (last change: Nov 2019) !!##LICENSE !! MIT module M_history ! ! Acting much like a line-mode editor, the REDO(3f) procedure lets ! you list, edit, save, and modify your interactively entered program ! input. Built-in help and no dependence on terminal control sequences ! makes this a simple-to-master and portable input history editor. ! use, intrinsic :: iso_fortran_env, only : ERROR_UNIT ! access computing environment use, intrinsic :: iso_fortran_env, only : output_unit, stderr=>error_unit implicit none private public :: redo ! copy a line into history file or edit history if command is "r" and return line private :: open_history_ ! open history file private :: redol_ ! edit history private :: help_ ! produce help text for redo(3f) usage ! should use unused file, not just unit 1071 for history ! add option to read in and replace history file integer,parameter :: READLEN=1024 ! width of history file integer,save,private :: stdout=OUTPUT_UNIT logical,save :: debug=.false. integer,save :: last_int=0 interface string_to_value module procedure a2d, a2i end interface interface v2s module procedure i2s end interface interface msg module procedure msg_scalar, msg_one end interface msg interface journal module procedure write_message_only ! journal(c) ! must have one string module procedure where_write_message_all ! journal(where,[g1-g9]) ! must have two strings end interface journal interface str module procedure str_scalar, str_one end interface str contains !==================================================================================================================================! !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !==================================================================================================================================! subroutine redo(inputline,r,lun) ! if line starts with r word call redol_() ! uses unit 1071 ! r ! r string ! ident_1="@(#) M_history redo(3f) open binary direct access file for keeping history" character(len=*),intent(inout) :: inputline ! user string character(len=1),intent(in),optional :: r ! character to use to trigger editing integer,intent(in),optional :: lun character(len=1) :: r_local ! character to use to trigger editing integer,save :: iobuf=1071 ! unit number to use for redo history buffer integer,save :: iredo ! number of lines read from standard input into redo file logical,save :: lcalled=.false. ! flag whether first time this routine called or not character(len=READLEN) :: onerecord integer :: ioparc integer :: ilast !----------------------------------------------------------------------------------------------------------------------------------- if(present(r))then r_local=r else r_local='r' endif !----------------------------------------------------------------------------------------------------------------------------------- ! open history file and initialize if(.not.lcalled)then ! open the redo buffer file lcalled=.true. iredo=0 ! number of lines in redo buffer call open_history_(iobuf,' ','scratch',ioparc) ! redo buffer if(ioparc /= 0)then call journal('sc','error creating history file') return endif endif !----------------------------------------------------------------------------------------------------------------------------------- ilast=len_trim(inputline) if(ilast == 1.and.inputline(1:1) == r_local)then ! redo command call redol_(inputline,iobuf,iredo,READLEN,' ',lun) ilast=len_trim(inputline) elseif(inputline(1:min(2,len(inputline))) == r_local//' ')then ! redo command with a string following call redol_(inputline,iobuf,iredo,READLEN,inputline(3:max(3,ilast)),lun) ilast=len_trim(inputline) endif if(ilast /= 0)then ! put command into redo buffer iredo=iredo+1 onerecord=inputline ! make string the correct length; ASSUMING inputline IS NOT LONGER THAN onerecord write(iobuf,rec=iredo)onerecord endif end subroutine redo !==================================================================================================================================! !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !==================================================================================================================================! subroutine open_history_(iunit,fname,sname,ierr) implicit none !----------------------------------------------------------------------------------------------------------------------------------- ! ident_2="@(#) M_history open_history_(3fp) open history file for REDO(3f) procedure" integer,intent(in) :: iunit ! Fortran unit to open character(len=*),intent(in) :: fname ! filename to open character(len=*),intent(in) :: sname ! flag. If "scratch" ignore FNAME and open a scratch file integer,intent(out) :: ierr ! error code returned by opening file character(len=1024) :: msg !----------------------------------------------------------------------------------------------------------------------------------- if(sname == 'scratch')then open(unit=iunit,status='scratch',form='unformatted',access='direct',recl=READLEN,iostat=ierr,iomsg=msg,action='readwrite') else open(unit=iunit,file=trim(fname),status=trim(sname),form='unformatted',access='direct', & & recl=READLEN,iostat=ierr,iomsg=msg,action='readwrite') endif !----------------------------------------------------------------------------------------------------------------------------------- if(ierr /= 0)then call journal('sc','*open_history_* open error ',ierr,'=',msg) endif !----------------------------------------------------------------------------------------------------------------------------------- end subroutine open_history_ !==================================================================================================================================! !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !==================================================================================================================================! subroutine redol_(redoline,iobuf,iredo,ibuf0,init,lun) ! ! to do: ! might want to support a count on change to do the Nth to the Mth occurrence ! support edit window in change ! prompt to verify each change made with change() ! maybe make .NAME stick into variable $NAME in the calculator ! allow changing the edit characters in a modify ! ident_3="@(#) M_history redoline(3fp) redo a previous input line" character(len=*),intent(out) :: redoline ! edited command line to be returned integer,intent(in) :: iobuf ! history file unit to read old commands from integer :: iredo !iredo ...... (i) number of lines in history file character(len=*),intent(in) :: init ! initial command string integer,intent(in) :: ibuf0 ! the width of the history file in characters; <= len(redoline) integer,intent(in),optional :: lun ! LUN to read history commands from doubleprecision :: val8 integer :: i10, i15, i20, i30 integer :: iounit integer :: idump integer :: idown integer :: lun_local integer :: ipoint integer :: iread integer :: istart integer :: ios integer :: ii integer :: ilong integer :: icall integer :: iup integer :: ix integer :: ibuf integer :: ilast integer :: cstat character :: cmd character(:),allocatable :: cmdline character(len=len(redoline)+1) :: cin, cinbuf ! 1 greater than length of redoline character(len=1024),save :: numbers character(len=1024),save :: msg integer,allocatable :: ivals(:) integer :: iend integer :: i integer :: ierr integer :: ier logical,save :: ddd=.false. data numbers/'123456789012345678901234567890123456789012345678901234567890& &12345678901234567890123456789012345678901234567890123456789012345678901234& &56789012345678901234567890123456789012345678901234567890123456789012345678& &90123456789012345678901234567890123456789012345678901234567890123456789012& &34567890123456789012345678901234567890123456789012345678901234567890123456& &78901234567890123456789012345678901234567890123456789012345678901234567890& &12345678901234567890123456789012345678901234567890123456789012345678901234& &56789012345678901234567890123456789012345678901234567890123456789012345678& &90123456789012345678901234567890123456789012345678901234567890123456789012& &34567890123456789012345678901234567890123456789012345678901234567890123456& &78901234567890123456789012345678901234567890123456789012345678901234567890& &'/ !----------------------------------------------------------------------------------------------------------------------------------- if(present(lun))then lun_local=lun else lun_local=5 endif !----------------------------------------------------------------------------------------------------------------------------------- ipoint=iredo ! initial line in history file to start with icall=0 ! flag if have been thru loop or just got here cin=init ! initialize the directive ibuf=min(ibuf0,len(redoline)) if(ibuf <= 0)return !----------------------------------------------------------------------------------------------------------------------------------- 1 continue if(ipoint <= 0)then ! if no lines in redo history file redoline=' ' ! make command to 'redo' a blank line since no commands entered else read(iobuf,rec=ipoint,err=999)redoline(1:ibuf) ! get last line in history file as line to redo ! WARNING: OSF1 DIGITAL Fortran 77 Driver V5.2-10 DIGITAL Fortran 77 V5.2-171-428BH ! after this read the following storage was corrupted; switched declaration of ! init and redoline and problem cleared but it is probably corrupting cin and ! doesn't show because of logic. endif !----------------------------------------------------------------------------------------------------------------------------------- READLINE: do ! display buffer and decide on command on first call or read command ilong=max(1,len_trim(redoline(1:ibuf))) ! find length of command to redo write(*,'(a,a)')'!',redoline(:ilong) ! show old command if(icall /= 0)then ! if not first call read the directive read(lun_local,'(a)',iostat=ios)cinbuf if(ios /= 0)then ! if there was an I/O error reread line exit READLINE endif call notabs(cinbuf,cin,ilast) elseif(cin == ' ')then ! first call and no initial command passed in cin='l -5' ! on first call do this default command if init is blank ilast=4 else ! if initial command was not blank do it instead of default ilast=len_trim(cin) endif icall=icall+1 !----------------------------------------------------------------------------------------------------------------------------------- if(ilast == 0)then ! blank command line; return and execute return endif !----------------------------------------------------------------------------------------------------------------------------------- cmd=cin(1:1) if(ddd)call journal('d','*redol* cmd=',cmd,'options=',cin) select case(cmd) ! first character defines edit action !----------------------------------------------------------------------------------------------------------------------------------- case(' ') ! modify the string call modif(redoline,cin(2:)) !----------------------------------------------------------------------------------------------------------------------------------- case('m') ! modify the string with line number header write(*,'(1x,a)',iostat=ios)numbers(:len_trim(redoline)) call modif(redoline,cin(2:)) !----------------------------------------------------------------------------------------------------------------------------------- case('c','s') ! change old string to new call change(redoline,trim(cin(1:255)),ier) ! xedit-like change command ! C/STRING1/STRING2/ OR CW/STRING1/STRING2/ (CHANGE IN WINDOW) ! WHERE / MAY BE ANY CHARACTER OTHER THAN W OR BLANK, WHICH IS NOT ! INCLUDED IN STRING1 OR STRING2 !----------------------------------------------------------------------------------------------------------------------------------- case('u','b') ! up or back through buffer if(cin(2:) == ' ')then iup=1 else iup=int(s2v(cin(2:),ierr,onerr=0)) endif ipoint=max(ipoint-iup,1) goto 1 !----------------------------------------------------------------------------------------------------------------------------------- case('d','f') ! down or forward through buffer if(cin(2:) == ' ')then idown=1 else idown=int(s2v(cin(2:),ierr,onerr=0)) endif ipoint=min(ipoint+idown,iredo) goto 1 !----------------------------------------------------------------------------------------------------------------------------------- case(';') ! append lines ivals=int(s2vs(cin(2:))) if(allocated(ivals))then do i=1,size(ivals) ii=ivals(i) if(ii >= 1.and.ii <= iredo)then read(iobuf,rec=ii,err=999)cinbuf(1:ibuf) ! get last line in history file as line to redo iend=len_trim(redoline) redoline=redoline(:iend)//';'//trim(cinbuf) !! should warn of truncation else call journal('sc','*redol_* line not found in history',ii) endif enddo endif !----------------------------------------------------------------------------------------------------------------------------------- case('?','h') ! display help call help_() !----------------------------------------------------------------------------------------------------------------------------------- case('D') ! toggle debug mode if(ddd .eqv. .false.)then ddd=.true. call journal('>') else ddd=.false. call journal('<') endif !----------------------------------------------------------------------------------------------------------------------------------- case('l','p') ! display history buffer file with line numbers if(cin(2:) == ' ')then istart=iredo+1-20 ! default is to back up 20 lines else istart=int(s2v(cin(2:),ierr,onerr=0)) if(ddd)call journal('d','*redol* istart=',istart,'ierr=',ierr) if(ierr /= 0)istart=iredo if(istart < 0)then istart=iredo+1+istart endif endif istart=min(max(1,istart),iredo) ! make istart a safe value if(ddd)call journal('d','*redol* istart=',istart,'iredo=',iredo) do i10=istart,iredo read(iobuf,rec=i10,iostat=ios)redoline(1:ibuf) if(ios /= 0)then exit READLINE endif ix=max(1,len_trim(redoline)) write(*,'(i5.5,1x,a)',iostat=ios)i10,redoline(:ix) if(ios /= 0)then exit READLINE endif enddo !----------------------------------------------------------------------------------------------------------------------------------- case('w') ! dump to a file cin=adjustl(cin(2:)) ! eliminate leading spaces and command name if(cin == ' ')then cin='DUMP' ! set as default and for message endif call do_w() !----------------------------------------------------------------------------------------------------------------------------------- case('e','E') ! dump and edit history file and read it back in cmdline=cin(2:) ! assume rest of command is a system command if(cmdline=='')cmdline='vim' ! if no system command use "vim" cin='scratch.tmp' ! assume this is a writable scratch file name cmdline=trim(cmdline)//' '//cin ! append scratch filename to system command call do_w() ! dump history file call execute_command_line(cmdline,cmdstat=cstat,cmdmsg=msg) ! Execute the command line specified by the string. if(cstat == 0)then ! rewrite or append to history file if(cmd == 'e')iredo=0 call do_ar() endif open(newunit=iounit,file=cin,iostat=ios) ! remove scratch file if(ios /= 0)then call journal('sc','*redol_* error opening scratch file file',cin,ios,'=',msg) endif close(unit=iounit,status='delete',iostat=ios,iomsg=msg) if(ios /= 0)then call journal('sc','*redol_* error removing scratch file file',cin,ios,'=',msg) endif !----------------------------------------------------------------------------------------------------------------------------------- case('a') ! append to history from a file cin=adjustl(cin(2:)) ! eliminate leading spaces and command name if(cin == ' ')then cin='DUMP' ! set as default and for message endif call do_ar() !----------------------------------------------------------------------------------------------------------------------------------- case('r') ! replace history from a file iredo=0 cin=adjustl(cin(2:)) ! eliminate leading spaces and command name if(cin == ' ')then cin='DUMP' ! set as default and for message endif call do_ar() !----------------------------------------------------------------------------------------------------------------------------------- case('P','L') ! display history buffer file without line numbers if(cin(2:) == ' ')then ! default is to go back up to 20 istart=iredo+1-20 else istart=int(s2v(cin(2:),ierr,onerr=0)) if(istart < 0)then istart=iredo+1+istart endif endif istart=min(max(1,istart),iredo) ! make istart a safe value do i30=istart,iredo ! easier to cut and paste if no numbers read(iobuf,rec=i30,iostat=ios)redoline(1:ibuf) if(ios /= 0)then goto 999 endif ix=max(1,len_trim(redoline)) write(*,'(a)',err=999)redoline(:ix) enddo !----------------------------------------------------------------------------------------------------------------------------------- case('/') ! display matches in buffer if(ilast < 2)then cycle endif do i20=1,iredo read(iobuf,rec=i20,err=999,iostat=ios)redoline(1:ibuf) if(index(redoline(1:ibuf),cin(2:ilast)) /= 0)then ix=max(1,len_trim(redoline)) write(*,'(i5.5,1x,a)',err=999)i20,redoline(:ix) ipoint=i20 endif enddo goto 1 !----------------------------------------------------------------------------------------------------------------------------------- case('!') ! external command if(ilast < 2)then cycle endif call execute_command_line(trim(cin(2:)),cmdstat=cstat,cmdmsg=msg) ! Execute the command line specified by the string. !call system(trim(cin(2:))) ! Execute the command line specified by the string. !----------------------------------------------------------------------------------------------------------------------------------- case('.','q') ! blank out command and quit exit READLINE !----------------------------------------------------------------------------------------------------------------------------------- case default ! assume anything else is a number val8=s2v(cin,ierr,onerr=0) if(ierr == 0)then iread=int(val8) else iread=0 endif if(iread > 0.and.iread <= iredo)then read(iobuf,rec=iread,err=999,iostat=ios)redoline(1:ibuf) ipoint=iread endif !----------------------------------------------------------------------------------------------------------------------------------- end select !----------------------------------------------------------------------------------------------------------------------------------- enddo READLINE !----------------------------------------------------------------------------------------------------------------------------------- 999 continue redoline=' ' !----------------------------------------------------------------------------------------------------------------------------------- contains !----------------------------------------------------------------------------------------------------------------------------------- subroutine do_w() WRITE: block open(newunit=idump,file=cin,iostat=ios,status='UNKNOWN',iomsg=msg) if(ios /= 0)then call journal('sc','*redol_* error opening dump file',ios,'=',msg) exit WRITE endif do i15=1,iredo read(iobuf,rec=i15,iostat=ios,iomsg=msg)redoline(1:ibuf) if(ios /= 0)then call journal('sc','*redol_* error reading history file',ios,'=',msg) exit WRITE endif ix=max(1,len_trim(redoline)) write(idump,'(a)',iostat=ios,iomsg=msg)redoline(:ix) if(ios /= 0)then call journal('sc','*redol_* error writing dump file',ios,'=',msg) close(idump,iostat=ios) exit WRITE endif enddo call journal('sc','wrote file ',cin) endblock WRITE close(idump,iostat=ios) end subroutine do_w !----------------------------------------------------------------------------------------------------------------------------------- subroutine do_ar() REPLACE: block open(newunit=idump,file=cin,iostat=ios,status='OLD',iomsg=msg) if(ios /= 0)then call journal('sc','*redol_* error opening file',ios,'=',msg) exit REPLACE endif do read(idump,'(a)',iostat=ios,iomsg=msg)redoline(1:ibuf) if(ios /= 0)then if(.not.is_iostat_end(ios))then call journal('sc','*redol_* error reading file ',cin,ios,'=',msg) endif exit REPLACE endif iredo=iredo+1 write(iobuf,rec=iredo,iostat=ios,iomsg=msg)redoline(1:ibuf) if(ios /= 0)then call journal('sc','*redol_* error writing history file',ios,'=',msg) exit REPLACE endif enddo endblock REPLACE call journal('sc','read file ',cin) close(idump,iostat=ios) end subroutine do_ar !----------------------------------------------------------------------------------------------------------------------------------- end subroutine redol_ !==================================================================================================================================! !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== subroutine help_() ! ident_4="@(#) M_history help_(3fp) prints help for REDO(3f)" character(len=80),allocatable :: usage(:) integer :: i !----------------------------------------------------------------------------------------------------------------------------------- usage=[ & &' History Edit commands (where N is a number): ',& &'+______________________________________________________________________________+',& &'|List History |History File: |',& &'| l|p N # list from line N. | w file # write history to a file |',& &'! # -N shows N last lines | a file # append file to history |',& &'| L|P N # same as l sans line numbers| r file # replace history with file |',& &'| /string # search for simple string |Return to Normal Command Mode: |',& &'|Position in History File: | # return and execute command |',& &'| u|b N # up/back through buffer | .|q # quit and return a blank line |',& &'| d|f N # down/forward through buffer|Help: |',& &'| N # load line number | h|? # display this help text |',& &'|System: |Append lines to current line: |',& &'| !system_command # execute command | ;N N N N ... |',& &'|______________________________________________________________________________|',& &'|Edit Buffer: |',& &'| c|s/oldstring/newstring/ # change/substitute |',& &'| mmod_string # Modify with line number header |',& &'| mod_string # Modify (replace, delete, insert) |',& &'| # -- deletes |',& &'| & -- replaces with a blank |',& &'| ^STRING# -- inserts a string |',& &'| -- blank leaves as-is |',& &'| Any other -- replaces character |',& &'+______________________________________________________________________________+'] !----------------------------------------------------------------------------------------------------------------------------------- !WRITE(*,'(a)'),usage(i),i=1,size(usage)) do i=1,size(usage) call journal('sc',usage(i)) enddo end subroutine help_ !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()= !=================================================================================================================================== function sep(input_line,delimiters,nulls) intrinsic index, min, present, len character(len=*),intent(in) :: input_line character(len=*),optional,intent(in) :: delimiters character(len=*),optional,intent(in) :: nulls character(len=:),allocatable :: sep(:) call split(input_line,sep,delimiters,'right',nulls) end function sep subroutine split(input_line,array,delimiters,order,nulls) intrinsic index, min, present, len character(len=*),intent(in) :: input_line character(len=*),optional,intent(in) :: delimiters character(len=*),optional,intent(in) :: order character(len=*),optional,intent(in) :: nulls character(len=:),allocatable,intent(out) :: array(:) integer :: n integer,allocatable :: ibegin(:) integer,allocatable :: iterm(:) character(len=:),allocatable :: dlim character(len=:),allocatable :: ordr character(len=:),allocatable :: nlls integer :: ii,iiii integer :: icount integer :: lgth integer :: i10,i20,i30 integer :: icol integer :: idlim integer :: ifound integer :: inotnull integer :: ireturn integer :: imax if (present(delimiters)) then if(delimiters /= '')then dlim=delimiters else dlim=' '//char(9)//char(10)//char(11)//char(12)//char(13)//char(0) endif else dlim=' '//char(9)//char(10)//char(11)//char(12)//char(13)//char(0) endif idlim=len(dlim) if(present(order))then; ordr=lower(adjustl(order)); else; ordr='sequential'; endif if(present(nulls))then; nlls=lower(adjustl(nulls)); else; nlls='ignore' ; endif n=len(input_line)+1 if(allocated(ibegin))deallocate(ibegin) if(allocated(iterm))deallocate(iterm) allocate(ibegin(n)) allocate(iterm(n)) ibegin(:)=1 iterm(:)=1 lgth=len(input_line) icount=0 inotnull=0 imax=0 if(lgth > 0)then icol=1 infinite: do i30=1,lgth,1 ibegin(i30)=icol if(index(dlim(1:idlim),input_line(icol:icol)) == 0)then iterm(i30)=lgth do i10=1,idlim ifound=index(input_line(ibegin(i30):lgth),dlim(i10:i10)) if(ifound > 0)then iterm(i30)=min(iterm(i30),ifound+ibegin(i30)-2) endif enddo icol=iterm(i30)+2 inotnull=inotnull+1 else iterm(i30)=icol-1 icol=icol+1 endif imax=max(imax,iterm(i30)-ibegin(i30)+1) icount=i30 if(icol > lgth)then exit infinite endif enddo infinite endif select case (trim(adjustl(nlls))) case ('ignore','','ignoreend') ireturn=inotnull case default ireturn=icount end select allocate(character(len=imax) :: array(ireturn)) select case (trim(adjustl(ordr))) case ('reverse','right') ; ii=ireturn ; iiii=-1 case default ; ii=1 ; iiii=1 end select do i20=1,icount if(iterm(i20) < ibegin(i20))then select case (trim(adjustl(nlls))) case ('ignore','','ignoreend') case default array(ii)=' ' ii=ii+iiii end select else array(ii)=input_line(ibegin(i20):iterm(i20)) ii=ii+iiii endif enddo end subroutine split 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 character(len=len(targetline)) :: dum1 integer :: ml, mr, ier1 integer :: maxlengthout integer :: original_input_length integer :: len_old, len_new integer :: ladd integer :: ir integer :: ind integer :: il integer :: id integer :: ic integer :: ichr if (present(start)) then ml=start else ml=1 endif if (present(end)) then mr=end else mr=len(targetline) endif ier1=0 maxlengthout=len(targetline) original_input_length=len_trim(targetline) dum1(:)=' ' id=mr-ml len_old=len(old) len_new=len(new) if(id <= 0)then il=1 ir=maxlengthout dum1(:)=' ' else il=ml ir=min0(mr,maxlengthout) dum1=targetline(:il-1) endif if(len_old == 0)then ichr=len_new + original_input_length if(ichr > maxlengthout)then call journal('sc','*substitute* new line will be too long') ier1=-1 if (present(ierr))ierr=ier1 return endif if(len_new > 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 if(present(ierr))ierr=ier1 return endif ichr=il ic=il loop: do ind=index(targetline(ic:),old(:len_old))+ic-1 if(ind == ic-1.or.ind > ir)then exit loop endif ier1=ier1+1 if(ind > ic)then ladd=ind-ic if(ichr-1+ladd > maxlengthout)then ier1=-1 exit loop endif dum1(ichr:)=targetline(ic:ind-1) ichr=ichr+ladd endif if(ichr-1+len_new > maxlengthout)then ier1=-2 exit loop endif if(len_new /= 0)then dum1(ichr:)=new(:len_new) ichr=ichr+len_new endif ic=ind+len_old enddo loop select case (ier1) case (:-1) call journal('sc','*substitute* new line will be too long') case (0) case default ladd=original_input_length-ic if(ichr+ladd > maxlengthout)then call journal('sc','*substitute* new line will be too long') ier1=-1 if(present(ierr))ierr=ier1 return endif if(ic < len(targetline))then dum1(ichr:)=targetline(ic:max(ic,original_input_length)) endif targetline=dum1(:maxlengthout) end select if(present(ierr))ierr=ier1 end subroutine substitute subroutine change(target_string,cmd,ierr) character(len=*),intent(inout) :: target_string character(len=*),intent(in) :: cmd character(len=1) :: delimiters integer :: ierr integer :: itoken integer,parameter :: id=2 character(len=:),allocatable :: old,new logical :: ifok integer :: lmax integer :: start_token,end_token lmax=len_trim(cmd) if(lmax >= 4)then delimiters=cmd(id:id) itoken=0 if(strtok(cmd(id:),itoken,start_token,end_token,delimiters)) then old=cmd(start_token+id-1:end_token+id-1) else old='' endif if(cmd(id:id) == cmd(id+1:id+1))then new=old old='' else ifok=strtok(cmd(id:),itoken,start_token,end_token,delimiters) if(end_token == (len(cmd)-id+1) )end_token=len_trim(cmd(id:)) new=cmd(start_token+id-1:min(end_token+id-1,lmax)) endif call substitute(target_string,old,new,ierr,1,len_trim(target_string)) else ierr=-1 call journal('sc','*change* incorrect change directive -too short') endif end subroutine change function strtok(source_string,itoken,token_start,token_end,delimiters) result(strtok_status) character(len=*),intent(in) :: source_string character(len=*),intent(in) :: delimiters integer,intent(inout) :: itoken logical :: strtok_status integer,intent(out) :: token_start integer,intent(inout) :: token_end integer,save :: isource_len if(itoken <= 0)then token_start=1 else token_start=token_end+1 endif isource_len=len(source_string) if(token_start > isource_len)then token_end=isource_len strtok_status=.false. return endif do while (token_start <= isource_len) if(index(delimiters,source_string(token_start:token_start)) /= 0) then token_start = token_start + 1 else exit endif enddo token_end=token_start do while (token_end <= isource_len-1) if(index(delimiters,source_string(token_end+1:token_end+1)) /= 0) then exit endif token_end = token_end + 1 enddo if (token_start > isource_len) then strtok_status=.false. else itoken=itoken+1 strtok_status=.true. endif end function strtok subroutine modif(cline,modi) character(len=*) :: cline character(len=*),intent(in) :: modi character(len=len(cline)) :: cmod character(len=3),parameter :: c='#&^' integer :: maxscra character(len=len(cline)) :: dum2 logical :: linsrt integer :: i, j, ic, ichr, iend, lmax, lmx1 maxscra=len(cline) cmod=trim(modi) lmax=min0(len(cline),maxscra) lmx1=lmax-1 dum2=' ' linsrt=.false. iend=len_trim(cmod) i=0 ic=0 ichr=0 11 continue i=i+1 if(ichr > lmx1)goto 999 if(linsrt) then if(i > iend) cmod(i:i)=c(1:1) if(cmod(i:i) == c(1:1))then linsrt=.false. if(ic+1 == i)then ichr=ichr+1 dum2(ichr:ichr)=c(1:1) endif do j=ic,i ichr=ichr+1 if(ichr > lmax)goto 999 dum2(ichr:ichr)=cline(j:j) enddo ic=i goto 1 endif ichr=ichr+1 dum2(ichr:ichr)=cmod(i:i) else ic=ic+1 if(cmod(i:i) == c(1:1))goto 1 if(cmod(i:i) == c(3:3))then linsrt=.true. goto 1 endif ichr=ichr+1 if(cmod(i:i) == c(2:2))then dum2(ichr:ichr)=' ' goto 1 endif if(cmod(i:i) == ' ')then dum2(ichr:ichr)=cline(ic:ic) else dum2(ichr:ichr)=cmod(i:i) endif endif 1 continue if(i < lmax)goto 11 999 continue cline=dum2 end subroutine modif elemental pure function upper(str,begin,end) result (string) character(*), intent(in) :: str integer, intent(in), optional :: begin,end character(len(str)) :: string integer :: i integer :: ibegin,iend integer,parameter :: diff = iachar('A')-iachar('a') string = str ibegin=1 iend=len_trim(str) if (present(begin))then ibegin = min(max(ibegin,begin),iend) endif if (present(end))then iend= max(1,min(iend,end)) endif do concurrent (i = ibegin:iend) select case (str(i:i)) case ('a':'z') string(i:i) = char(iachar(str(i:i))+diff) end select enddo end function upper elemental pure function lower(str,begin,end) result (string) character(*), intent(in) :: str character(len(str)) :: string integer,intent(in),optional :: begin, end integer :: i integer :: ibegin, iend integer,parameter :: diff = iachar('A')-iachar('a') string = str ibegin=1 iend=len_trim(str) if (present(begin))then ibegin = min(max(1,begin),iend) endif if (present(end))then iend= max(1,min(iend,end)) endif do concurrent (i = ibegin:iend) select case (str(i:i)) case ('A':'Z') string(i:i) = char(iachar(str(i:i))-diff) case default end select enddo end function lower elemental impure subroutine notabs(instr,outstr,lgth) character(len=*),intent(in) :: instr character(len=*),intent(out) :: outstr integer,intent(out) :: lgth integer,parameter :: tabsize=8 integer :: ipos integer :: lenin integer :: lenout integer :: istep character(len=1) :: c integer :: iade ipos=1 lenin=len_trim(instr( 1:len(instr) )) lenout=len(outstr) outstr=" " scan_line: do istep=1,lenin c=instr(istep:istep) iade=iachar(c) expand_tabs : select case (iade) case(9) ipos = ipos + (tabsize - (mod(ipos-1,tabsize))) case(10,13) ipos=ipos+1 case default if(ipos > lenout)then call journal("*notabs* output string overflow") exit else outstr(ipos:ipos)=c ipos=ipos+1 endif end select expand_tabs enddo scan_line ipos=min(ipos,lenout) lgth=len_trim(outstr(:ipos)) end subroutine notabs subroutine a2i(chars,valu,ierr) character(len=*),intent(in) :: chars integer,intent(out) :: valu integer,intent(out) :: ierr doubleprecision :: valu8 valu8=0.0d0 call a2d(chars,valu8,ierr,onerr=0.0d0) if(valu8 <= huge(valu))then if(valu8 <= huge(valu))then valu=int(valu8) else call journal('sc','*a2i*','- value too large',valu8,'>',huge(valu)) valu=huge(valu) ierr=-1 endif endif end subroutine a2i subroutine a2d(chars,valu,ierr,onerr) character(len=*),intent(in) :: chars character(len=:),allocatable :: local_chars doubleprecision,intent(out) :: valu integer,intent(out) :: ierr class(*),optional,intent(in) :: onerr character(len=*),parameter :: fmt="('(bn,g',i5,'.0)')" character(len=15) :: frmt character(len=256) :: msg integer :: intg integer :: pnd integer :: basevalue, ivalu character(len=3),save :: nan_string='NaN' ierr=0 local_chars=unquote(chars) msg='' if(len(local_chars) == 0)local_chars=' ' call substitute(local_chars,',','') pnd=scan(local_chars,'#:') if(pnd /= 0)then write(frmt,fmt)pnd-1 read(local_chars(:pnd-1),fmt=frmt,iostat=ierr,iomsg=msg)basevalue if(decodebase(local_chars(pnd+1:),basevalue,ivalu))then valu=real(ivalu,kind=kind(0.0d0)) else valu=0.0d0 ierr=-1 endif else select case(local_chars(1:1)) case('z','Z','h','H') frmt='(Z'//v2s(len(local_chars))//')' read(local_chars(2:),frmt,iostat=ierr,iomsg=msg)intg valu=dble(intg) case('b','B') frmt='(B'//v2s(len(local_chars))//')' read(local_chars(2:),frmt,iostat=ierr,iomsg=msg)intg valu=dble(intg) case('o','O') 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) read(local_chars,fmt=frmt,iostat=ierr,iomsg=msg)valu end select endif if(ierr /= 0)then if(present(onerr))then select type(onerr) type is (integer) valu=onerr type is (real) valu=onerr type is (doubleprecision) valu=onerr end select else read(nan_string,'(g3.3)')valu endif if(local_chars /= 'eod')then call journal('sc','*a2d* - cannot produce number from string ['//trim(chars)//']') if(msg /= '')then call journal('sc','*a2d* - ['//trim(msg)//']') endif endif endif end subroutine a2d doubleprecision function s2v(chars,ierr,onerr) character(len=*),intent(in) :: chars integer,optional :: ierr doubleprecision :: valu integer :: ierr_local class(*),intent(in),optional :: onerr ierr_local=0 if(present(onerr))then call a2d(chars,valu,ierr_local,onerr) else call a2d(chars,valu,ierr_local) endif if(present(ierr))then ierr=ierr_local s2v=valu elseif(ierr_local /= 0)then write(*,*)'*s2v* stopped while reading '//trim(chars) stop 1 else s2v=valu endif end function s2v doubleprecision function dble_s2v(chars) character(len=*),intent(in) :: chars dble_s2v=s2v(chars) end function dble_s2v real function real_s2v(chars) character(len=*),intent(in) :: chars real_s2v=real(s2v(chars)) end function real_s2v integer function int_s2v(chars) character(len=*),intent(in) :: chars int_s2v=int(s2v(chars)) end function int_s2v function ints_s2v(chars) integer,allocatable :: ints_s2v(:) character(len=*),intent(in) :: chars(:) integer :: i,isize isize=size(chars) allocate(ints_s2v(isize)) do i=1,isize ints_s2v(i)=int(s2v(chars(i))) enddo end function ints_s2v function reals_s2v(chars) real,allocatable :: reals_s2v(:) character(len=*),intent(in) :: chars(:) integer :: i,isize isize=size(chars) allocate(reals_s2v(isize)) do i=1,isize reals_s2v(i)=real(s2v(chars(i))) enddo end function reals_s2v function dbles_s2v(chars) doubleprecision,allocatable :: dbles_s2v(:) character(len=*),intent(in) :: chars(:) integer :: i,isize isize=size(chars) allocate(dbles_s2v(isize)) do i=1,isize dbles_s2v(i)=s2v(chars(i)) enddo end function dbles_s2v subroutine value_to_string(gval,chars,length,err,fmt,trimz) 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 logical,intent(in),optional :: trimz character(len=:),allocatable :: fmt_local character(len=1024) :: msg if (present(fmt)) then select type(gval) type is (integer) fmt_local='(i0)' if(fmt /= '') fmt_local=fmt write(chars,fmt_local,iostat=err_local,iomsg=msg)gval type is (real) fmt_local='(bz,g23.10e3)' fmt_local='(bz,g0.8)' if(fmt /= '') fmt_local=fmt write(chars,fmt_local,iostat=err_local,iomsg=msg)gval type is (doubleprecision) fmt_local='(bz,g0)' if(fmt /= '') fmt_local=fmt write(chars,fmt_local,iostat=err_local,iomsg=msg)gval type is (logical) fmt_local='(l1)' if(fmt /= '') fmt_local=fmt write(chars,fmt_local,iostat=err_local,iomsg=msg)gval class default call journal('*value_to_string* UNKNOWN TYPE') chars=' ' end select if(fmt == '') then chars=adjustl(chars) call trimzeros_(chars) endif else err_local=-1 select type(gval) type is (integer) write(chars,*,iostat=err_local,iomsg=msg)gval type is (real) write(chars,*,iostat=err_local,iomsg=msg)gval type is (doubleprecision) write(chars,*,iostat=err_local,iomsg=msg)gval type is (logical) write(chars,*,iostat=err_local,iomsg=msg)gval class default chars='' end select chars=adjustl(chars) if(index(chars,'.') /= 0) call trimzeros_(chars) endif if(present(trimz))then if(trimz)then chars=adjustl(chars) call trimzeros_(chars) endif endif if(present(length)) then length=len_trim(chars) endif if(present(err)) then err=err_local elseif(err_local /= 0)then chars=chars//' *value_to_string* WARNING:['//trim(msg)//']' endif end subroutine value_to_string function i2s(ivalue,fmt) result(outstr) integer,intent(in) :: ivalue character(len=*),intent(in),optional :: fmt character(len=:),allocatable :: outstr character(len=80) :: string if(present(fmt))then call value_to_string(ivalue,string,fmt=fmt) else call value_to_string(ivalue,string) endif outstr=trim(string) end function i2s subroutine trimzeros_(string) character(len=*) :: string character(len=len(string)+2) :: str character(len=len(string)) :: expo integer :: ipos integer :: i, ii str=string ipos=scan(str,'eEdD') if(ipos>0) then expo=str(ipos:) str=str(1:ipos-1) endif if(index(str,'.') == 0)then ii=len_trim(str) str(ii+1:ii+1)='.' endif do i=len_trim(str),1,-1 select case(str(i:i)) case('0') cycle case('.') if(i <= 1)then str='0' else str=str(1:i-1) endif exit case default str=str(1:i) exit end select enddo if(ipos>0)then string=trim(str)//trim(expo) else string=str endif end subroutine trimzeros_ function unquote(quoted_str,esc) result (unquoted_str) character(len=*),intent(in) :: quoted_str character(len=1),optional,intent(in) :: esc character(len=:),allocatable :: unquoted_str integer :: inlen character(len=1),parameter :: single_quote = "'" character(len=1),parameter :: double_quote = '"' integer :: quote integer :: before integer :: current integer :: iesc integer :: iput integer :: i logical :: inside if(present(esc))then iesc=iachar(esc) else iesc=-1 endif inlen=len(quoted_str) allocate(character(len=inlen) :: unquoted_str) if(inlen >= 1)then if(quoted_str(1:1) == single_quote)then quote=iachar(single_quote) else quote=iachar(double_quote) endif else quote=iachar(double_quote) endif before=-2 unquoted_str(:)='' iput=1 inside=.false. stepthrough: do i=1,inlen current=iachar(quoted_str(i:i)) if(before == iesc)then iput=iput-1 unquoted_str(iput:iput)=char(current) iput=iput+1 before=-2 elseif(current == quote)then if(before == quote)then unquoted_str(iput:iput)=char(quote) iput=iput+1 before=-2 elseif(.not.inside.and.before /= iesc)then inside=.true. else before=current endif else unquoted_str(iput:iput)=char(current) iput=iput+1 before=current endif enddo stepthrough unquoted_str=unquoted_str(:iput-1) end function unquote function s2vs(string,delim) result(darray) character(len=*),intent(in) :: string character(len=*),optional :: delim character(len=:),allocatable :: delim_local doubleprecision,allocatable :: darray(:) character(len=:),allocatable :: carray(:) integer :: i integer :: ier if(present(delim))then delim_local=delim else delim_local=' ;,' endif call split(string,carray,delimiters=delim_local) allocate(darray(size(carray))) do i=1,size(carray) call string_to_value(carray(i), darray(i), ier) enddo end function s2vs logical function base(x,b,y,a) implicit none character(len=*),intent(in) :: x character(len=*),intent(out) :: y integer,intent(in) :: b,a integer :: temp base=.true. if(decodebase(x,b,temp)) then if(codebase(temp,a,y)) then else print *,'Error in coding number.' base=.false. endif else print *,'Error in decoding number.' base=.false. endif end function base logical function decodebase(string,basein,out_baseten) implicit none character(len=*),intent(in) :: string integer,intent(in) :: basein integer,intent(out) :: out_baseten character(len=len(string)) :: string_local integer :: long, i, j, k real :: y real :: mult character(len=1) :: ch real,parameter :: xmaxreal=real(huge(1)) integer :: out_sign integer :: basein_local integer :: ipound integer :: ierr string_local=upper(trim(adjustl(string))) decodebase=.false. ipound=index(string_local,'#') if(basein == 0.and.ipound > 1)then call string_to_value(string_local(:ipound-1),basein_local,ierr) string_local=string_local(ipound+1:) if(basein_local >= 0)then out_sign=1 else out_sign=-1 endif basein_local=abs(basein_local) else basein_local=abs(basein) out_sign=1 endif out_baseten=0 y=0.0 all: if(basein_local<2.or.basein_local>36) then print *,'(*decodebase* ERROR: Base must be between 2 and 36. base=',basein_local else all out_baseten=0;y=0.0; mult=1.0 long=len_trim(string_local) do i=1, long k=long+1-i ch=string_local(k:k) if(ch == '-'.and.k == 1)then out_sign=-1 cycle endif if(ch<'0'.or.ch>'Z'.or.(ch>'9'.and.ch<'A'))then write(*,*)'*decodebase* ERROR: invalid character ',ch exit all endif if(ch<='9') then j=iachar(ch)-iachar('0') else j=iachar(ch)-iachar('A')+10 endif if(j>=basein_local)then exit all endif y=y+mult*j if(mult>xmaxreal/basein_local)then exit all endif mult=mult*basein_local enddo decodebase=.true. out_baseten=nint(out_sign*y)*sign(1,basein) endif all end function decodebase logical function codebase(inval10,outbase,answer) implicit none integer,intent(in) :: inval10 integer,intent(in) :: outbase character(len=*),intent(out) :: answer integer :: n real :: inval10_local integer :: outbase_local integer :: in_sign answer='' in_sign=sign(1,inval10)*sign(1,outbase) inval10_local=abs(inval10) outbase_local=abs(outbase) if(outbase_local<2.or.outbase_local>36) then print *,'*codebase* ERROR: base must be between 2 and 36. base was',outbase_local codebase=.false. else do while(inval10_local>0.0 ) n=int(inval10_local-outbase_local*int(inval10_local/outbase_local)) if(n<10) then answer=achar(iachar('0')+n)//answer else answer=achar(iachar('A')+n-10)//answer endif inval10_local=int(inval10_local/outbase_local) enddo codebase=.true. endif if(in_sign == -1)then answer='-'//trim(answer) endif if(answer == '')then answer='0' endif end function codebase function todecimal(base, instr) character(len=36),parameter :: alphanum = "0123456789abcdefghijklmnopqrstuvwxyz" integer,intent(in) :: base character(*),intent(in) :: instr character(len=:),allocatable :: instr_local integer :: todecimal integer :: length, i, n instr_local=trim(lower(instr)) todecimal = 0 length = len(instr_local) do i = 1, length n = index(alphanum, instr_local(i:i)) - 1 n = n * base**(length-i) todecimal = todecimal + n enddo end function todecimal function tobase(base, number) character(len=36),parameter :: alphanum = "0123456789abcdefghijklmnopqrstuvwxyz" integer,intent(in) :: base integer,intent(in) :: number character(len=:),allocatable :: tobase character(len=31) :: holdit integer :: number_local, i, rem number_local=number holdit = " " do i = 31, 1, -1 if(number_local < base) then holdit(i:i) = alphanum(number_local+1:number_local+1) exit endif rem = mod(number_local, base) holdit(i:i) = alphanum(rem+1:rem+1) number_local = number_local / base enddo tobase = adjustl(holdit) end function tobase function fmt(source_string,length) character(len=*),intent(in) :: source_string integer,intent(in) :: length integer :: itoken integer :: istart integer :: iend character(len=*),parameter :: delimiters=' ' character(len=:),allocatable :: fmt(:) integer :: ilines integer :: ilength integer :: iword, iword_max integer :: i do i=1,2 iword_max=0 ilines=1 ilength=0 itoken=0 do while ( strtok(source_string,itoken,istart,iend,delimiters) ) iword=iend-istart+1 iword_max=max(iword_max,iword) if(iword > length)then if(ilength /= 0)then ilines=ilines+1 endif if(i == 2)then fmt(ilines)=source_string(istart:iend)//' ' endif ilength=iword+1 elseif(ilength+iword <= length)then if(i == 2)then fmt(ilines)=fmt(ilines)(:ilength)//source_string(istart:iend) endif ilength=ilength+iword+1 else ilines=ilines+1 ilength=0 if(i == 2)then fmt(ilines)=fmt(ilines)(:ilength)//source_string(istart:iend) endif ilength=iword+1 endif enddo if(i==1)then allocate(character(len=max(length,iword_max)) :: fmt(ilines)) fmt=' ' endif enddo fmt=fmt(:ilines) end function fmt function msg_scalar(generic1, generic2, generic3, generic4, generic5, generic6, generic7, generic8, generic9,sep) implicit none class(*),intent(in),optional :: generic1 ,generic2 ,generic3 ,generic4 ,generic5 class(*),intent(in),optional :: generic6 ,generic7 ,generic8 ,generic9 character(len=*),intent(in),optional :: sep character(len=:),allocatable :: sep_local character(len=:), allocatable :: msg_scalar character(len=4096) :: line integer :: istart integer :: increment if(present(sep))then sep_local=sep increment=len(sep)+1 else sep_local=' ' increment=2 endif istart=1 line=' ' if(present(generic1))call print_generic(generic1) if(present(generic2))call print_generic(generic2) if(present(generic3))call print_generic(generic3) if(present(generic4))call print_generic(generic4) if(present(generic5))call print_generic(generic5) if(present(generic6))call print_generic(generic6) if(present(generic7))call print_generic(generic7) if(present(generic8))call print_generic(generic8) if(present(generic9))call print_generic(generic9) msg_scalar=trim(line) contains subroutine print_generic(generic) use,intrinsic :: iso_fortran_env, only : int8, int16, int32, int64, real32, real64, real128 class(*),intent(in) :: generic select type(generic) type is (integer(kind=int8)); write(line(istart:),'(i0)') generic type is (integer(kind=int16)); write(line(istart:),'(i0)') generic type is (integer(kind=int32)); write(line(istart:),'(i0)') generic type is (integer(kind=int64)); write(line(istart:),'(i0)') generic type is (real(kind=real32)); write(line(istart:),'(1pg0)') generic type is (real(kind=real64)); write(line(istart:),'(1pg0)') generic type is (logical); write(line(istart:),'(l1)') generic type is (character(len=*)); write(line(istart:),'(a)') trim(generic) type is (complex); write(line(istart:),'("(",1pg0,",",1pg0,")")') generic end select istart=len_trim(line)+increment line=trim(line)//sep_local end subroutine print_generic end function msg_scalar function msg_one(generic1, generic2, generic3, generic4, generic5, generic6, generic7, generic8, generic9,sep) implicit none class(*),intent(in) :: generic1(:) class(*),intent(in),optional :: generic2(:), generic3(:), generic4(:), generic5(:) class(*),intent(in),optional :: generic6(:), generic7(:), generic8(:), generic9(:) character(len=*),intent(in),optional :: sep character(len=:),allocatable :: sep_local character(len=:), allocatable :: msg_one character(len=4096) :: line integer :: istart integer :: increment if(present(sep))then sep_local=sep increment=len(sep)+1 else sep_local=' ' increment=2 endif istart=1 line=' ' call print_generic(generic1) if(present(generic2))call print_generic(generic2) if(present(generic3))call print_generic(generic3) if(present(generic4))call print_generic(generic4) if(present(generic5))call print_generic(generic5) if(present(generic6))call print_generic(generic6) if(present(generic7))call print_generic(generic7) if(present(generic8))call print_generic(generic8) if(present(generic9))call print_generic(generic9) msg_one=trim(line) contains subroutine print_generic(generic) use,intrinsic :: iso_fortran_env, only : int8, int16, int32, int64, real32, real64, real128 class(*),intent(in),optional :: generic(:) integer :: i select type(generic) type is (integer(kind=int8)); write(line(istart:),'("[",*(i0,1x))') generic type is (integer(kind=int16)); write(line(istart:),'("[",*(i0,1x))') generic type is (integer(kind=int32)); write(line(istart:),'("[",*(i0,1x))') generic type is (integer(kind=int64)); write(line(istart:),'("[",*(i0,1x))') generic type is (real(kind=real32)); write(line(istart:),'("[",*(1pg0,1x))') generic type is (real(kind=real64)); write(line(istart:),'("[",*(1pg0,1x))') generic type is (logical); write(line(istart:),'("[",*(l1,1x))') generic type is (character(len=*)); write(line(istart:),'("[",:*("""",a,"""",1x))') (trim(generic(i)),i=1,size(generic)) type is (complex); write(line(istart:),'("[",*("(",1pg0,",",1pg0,")",1x))') generic end select istart=len_trim(line)+increment line=trim(line)//"]"//sep_local end subroutine print_generic end function msg_one subroutine where_write_message(where,msg) character(len=*),intent(in) :: where character(len=*),intent(in) :: msg logical,save :: trailopen=.false. integer,save :: itrail character,save :: comment='#' integer :: i integer :: ios integer :: times character(len=3) :: adv character(len=:),allocatable,save :: prefix_template character(len=:),allocatable :: prefix logical,save :: prefix_it=.false. character(len=4096) :: mssge adv='yes' prefix='' times=0 do i=1,len_trim(where) select case(where(i:i)) case('T','t') if(trailopen) then write(itrail,'(a)',advance=adv)prefix//trim(msg) endif case('S','s') write(stdout,'(a)',advance=adv)prefix//trim(msg) times=times+1 case('E','e') write(stderr,'(a)',advance=adv)prefix//trim(msg) times=times+1 case('+'); adv='no' case('>'); debug=.true. case('<'); debug=.false. case('%') if(msg == '')then prefix_it=.false. else prefix_template=msg prefix_it=.true. endif case('N') if(msg /= ' '.and.msg /= '#N#'.and.msg /= '"#N#"')then close(unit=last_int,iostat=ios) open(unit=last_int,file=adjustl(trim(msg)),iostat=ios) if(ios == 0)then stdout=last_int else write(*,*)'*journal* error opening redirected output file, ioerr=',ios write(*,*)'*journal* msg='//trim(msg) endif elseif(msg == ' ')then close(unit=last_int,iostat=ios) stdout=6 endif case('C','c') if(trailopen)then write(itrail,'(3a)',advance=adv)prefix,comment,trim(msg) elseif(times == 0)then endif case('D','d') if(debug)then if(trailopen)then write(itrail,'(4a)',advance=adv)prefix,comment,'DEBUG: ',trim(msg) elseif(times == 0)then write(stdout,'(3a)',advance=adv)prefix,'DEBUG:',trim(msg) times=times+1 endif endif case('F','f') flush(unit=itrail,iostat=ios,iomsg=mssge) if(ios /= 0)then write(*,'(a)') trim(mssge) endif case('A','a') if(msg /= '')then open(newunit=itrail,status='unknown',access='sequential',file=adjustl(trim(msg)),& & form='formatted',iostat=ios,position='append') trailopen=.true. endif case('O','o') if(msg /= '')then open(newunit=itrail,status='unknown',access='sequential', file=adjustl(trim(msg)),form='formatted',iostat=ios) trailopen=.true. else if(trailopen)then write(itrail,'(4a)',advance=adv)prefix,comment,'closing trail file:',trim(msg) endif close(unit=itrail,iostat=ios) trailopen=.false. endif case default write(stdout,'(a)',advance=adv)'*journal* bad WHERE value '//trim(where)//' when msg=['//trim(msg)//']' end select enddo end subroutine where_write_message subroutine where_write_message_all(where, g0,g1,g2,g3,g4,g5,g6,g7,g8,g9,nospace) implicit none character(len=*),intent(in) :: where class(*),intent(in) :: g0 class(*),intent(in),optional :: g1,g2,g3,g4,g5,g6,g7,g8,g9 logical,intent(in),optional :: nospace call where_write_message(where,str(g0, g1, g2, g3, g4, g5, g6, g7, g8, g9,nospace)) end subroutine where_write_message_all subroutine write_message_only(message) character(len=*),intent(in) :: message call where_write_message('sc',trim(message)) end subroutine write_message_only function str_scalar(generic0, generic1, generic2, generic3, generic4, generic5, generic6, generic7, generic8, generic9, & & generica, genericb, genericc, genericd, generice, genericf, genericg, generich, generici, genericj, & & sep) implicit none class(*),intent(in),optional :: generic0, generic1, generic2, generic3, generic4 class(*),intent(in),optional :: generic5, generic6, generic7, generic8, generic9 class(*),intent(in),optional :: generica, genericb, genericc, genericd, generice class(*),intent(in),optional :: genericf, genericg, generich, generici, genericj character(len=*),intent(in),optional :: sep character(len=:), allocatable :: str_scalar character(len=4096) :: line integer :: istart integer :: increment character(len=:),allocatable :: sep_local if(present(sep))then sep_local=sep increment=len(sep)+1 else sep_local=' ' increment=2 endif istart=1 line='' if(present(generic0))call print_generic(generic0) if(present(generic1))call print_generic(generic1) if(present(generic2))call print_generic(generic2) if(present(generic3))call print_generic(generic3) if(present(generic4))call print_generic(generic4) if(present(generic5))call print_generic(generic5) if(present(generic6))call print_generic(generic6) if(present(generic7))call print_generic(generic7) if(present(generic8))call print_generic(generic8) if(present(generic9))call print_generic(generic9) if(present(generica))call print_generic(generica) if(present(genericb))call print_generic(genericb) if(present(genericc))call print_generic(genericc) if(present(genericd))call print_generic(genericd) if(present(generice))call print_generic(generice) if(present(genericf))call print_generic(genericf) if(present(genericg))call print_generic(genericg) if(present(generich))call print_generic(generich) if(present(generici))call print_generic(generici) if(present(genericj))call print_generic(genericj) str_scalar=trim(line) contains subroutine print_generic(generic) use,intrinsic :: iso_fortran_env, only : int8, int16, int32, int64, real32, real64, real128 class(*),intent(in) :: generic select type(generic) type is (integer(kind=int8)); write(line(istart:),'(i0)') generic type is (integer(kind=int16)); write(line(istart:),'(i0)') generic type is (integer(kind=int32)); write(line(istart:),'(i0)') generic type is (integer(kind=int64)); write(line(istart:),'(i0)') generic type is (real(kind=real32)); write(line(istart:),'(1pg0)') generic type is (real(kind=real64)); write(line(istart:),'(1pg0)') generic type is (logical); write(line(istart:),'(l1)') generic type is (character(len=*)); write(line(istart:),'(a)') trim(generic) type is (complex); write(line(istart:),'("(",1pg0,",",1pg0,")")') generic end select istart=len_trim(line)+increment line=trim(line)//sep_local end subroutine print_generic end function str_scalar function str_one(generic0,generic1, generic2, generic3, generic4, generic5, generic6, generic7, generic8, generic9,sep) implicit none class(*),intent(in) :: generic0(:) class(*),intent(in),optional :: generic1(:), generic2(:), generic3(:), generic4(:), generic5(:) class(*),intent(in),optional :: generic6(:), generic7(:), generic8(:), generic9(:) character(len=*),intent(in),optional :: sep character(len=:),allocatable :: sep_local character(len=:), allocatable :: str_one character(len=4096) :: line integer :: istart integer :: increment if(present(sep))then sep_local=sep increment=len(sep)+1 else sep_local=' ' increment=2 endif istart=1 line=' ' call print_generic(generic0) if(present(generic1))call print_generic(generic1) if(present(generic2))call print_generic(generic2) if(present(generic3))call print_generic(generic3) if(present(generic4))call print_generic(generic4) if(present(generic5))call print_generic(generic5) if(present(generic6))call print_generic(generic6) if(present(generic7))call print_generic(generic7) if(present(generic8))call print_generic(generic8) if(present(generic9))call print_generic(generic9) str_one=trim(line) contains subroutine print_generic(generic) use,intrinsic :: iso_fortran_env, only : int8, int16, int32, int64, real32, real64, real128 class(*),intent(in),optional :: generic(:) integer :: i select type(generic) type is (integer(kind=int8)); write(line(istart:),'("[",*(i0,1x))') generic type is (integer(kind=int16)); write(line(istart:),'("[",*(i0,1x))') generic type is (integer(kind=int32)); write(line(istart:),'("[",*(i0,1x))') generic type is (integer(kind=int64)); write(line(istart:),'("[",*(i0,1x))') generic type is (real(kind=real32)); write(line(istart:),'("[",*(1pg0,1x))') generic type is (real(kind=real64)); write(line(istart:),'("[",*(1pg0,1x))') generic type is (logical); write(line(istart:),'("[",*(l1,1x))') generic type is (character(len=*)); write(line(istart:),'("[",:*("""",a,"""",1x))') (trim(generic(i)),i=1,size(generic)) type is (complex); write(line(istart:),'("[",*("(",1pg0,",",1pg0,")",1x))') generic class default stop 'unknown type in *print_generic*' end select line=trim(line)//"]"//sep_local istart=len_trim(line)+increment end subroutine print_generic end function str_one !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()= !=================================================================================================================================== end module M_history !>>>>> build/dependencies/M_match/src/M_match.f90 !09/22/1980 15:38:34 !04/19/2020 11:05:06 !==================================================================================================================================! !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !==================================================================================================================================! !> !!##NAME !! M_match(3fp) - [M_MATCH] Basic Regular Expressions !! (LICENSE:PD) !!##SYNOPSIS !! !! use M_match, only: match, amatch, getpat, makpat !! use M_match, only: YES, MAXPAT, MAXARG, MAXLINE, EOS, NEWLINE, ERR !! !!##DESCRIPTION !! Find a string matching a regular expression. !! !! * zero or more occurrences of the previous character !! . any character !! ^ beginning of line !! $ end of line !! [] class of characters. Inside the braces !! !! ^ at the beginning of the class means to !! negate the class. !! - if not the first or last character in !! the class, denotes a range of characters !! Escape characters: !! \\n newline !! \\r carriage return !! \\t tab !! \\b backspace !!##EXAMPLE !! !!##AUTHOR !! John S. Urban !!##REFERENCE !! "Software Tools" by Kernighan and Plauger , 1976 !!##LICENSE !! Public Domain module M_match use, intrinsic :: iso_fortran_env, only : stdin=>input_unit, stdout=>output_unit, stderr=>error_unit implicit none private public :: getpat !....... encode regular expression for pattern matching public :: match !....... match pattern anywhere on line public :: amatch !....... look for pattern matching regular expression public :: makpat !....... encode regular expression for pattern matching public :: regex_pattern public :: bpos, epos private :: omatch private :: error private :: addset private :: dodash private :: locate private :: patsiz private :: stclos private :: getccl private :: filset private :: esc integer,parameter,public :: MAXTAGS=10 interface getpat; module procedure getpat_, getpat__; end interface interface makpat; module procedure makpat_ ; end interface interface amatch; module procedure amatch_, amatch__; end interface interface match; module procedure match_, match__ ; end interface interface omatch; module procedure omatch_ ; end interface !========== STANDARD RATFOR DEFINITIONS ========== !x!integer,parameter :: CHARACTER=INTEGER integer,parameter :: chr=kind(1) integer,parameter :: byte=kind(1) integer,parameter :: def=kind(1) !x!integer,parameter :: ANDIF=IF integer(kind=byte),parameter :: EOF=10003_byte integer(kind=byte),parameter,public :: EOS=10002_byte integer(kind=byte),parameter,public :: ERR=10001_byte integer(kind=byte),parameter,public :: YES=1_byte !x!integer(kind=byte),parameter :: ARB=100_byte integer(kind=byte),parameter :: ACCENT=96_byte integer(kind=byte),parameter :: AND=38_byte integer(kind=byte),parameter :: ATSIGN=64_byte integer(kind=byte),parameter :: BACKSLASH=92_byte integer(kind=byte),parameter :: BACKSPACE=8_byte integer(kind=byte),parameter :: CR=13_byte integer(kind=byte),parameter :: BANG=33_byte integer(kind=byte),parameter :: BAR=124_byte integer(kind=byte),parameter :: BIGA=65_byte integer(kind=byte),parameter :: BIGB=66_byte integer(kind=byte),parameter :: BIGC=67_byte integer(kind=byte),parameter :: BIGD=68_byte integer(kind=byte),parameter :: BIGE=69_byte integer(kind=byte),parameter :: BIGF=70_byte integer(kind=byte),parameter :: BIGG=71_byte integer(kind=byte),parameter :: BIGH=72_byte integer(kind=byte),parameter :: BIGI=73_byte integer(kind=byte),parameter :: BIGJ=74_byte integer(kind=byte),parameter :: BIGK=75_byte integer(kind=byte),parameter :: BIGL=76_byte integer(kind=byte),parameter :: BIGM=77_byte integer(kind=byte),parameter :: BIGN=78_byte integer(kind=byte),parameter :: BIGO=79_byte integer(kind=byte),parameter :: BIGP=80_byte integer(kind=byte),parameter :: BIGQ=81_byte integer(kind=byte),parameter :: BIGR=82_byte integer(kind=byte),parameter :: BIGS=83_byte integer(kind=byte),parameter :: BIGT=84_byte integer(kind=byte),parameter :: BIGU=85_byte integer(kind=byte),parameter :: BIGV=86_byte integer(kind=byte),parameter :: BIGW=87_byte integer(kind=byte),parameter :: BIGX=88_byte integer(kind=byte),parameter :: BIGY=89_byte integer(kind=byte),parameter :: BIGZ=90_byte integer(kind=byte),parameter,public :: BLANK=32_byte integer(kind=byte),parameter :: CARET=94_byte integer(kind=byte),parameter :: COLON=58_byte integer(kind=byte),parameter :: COMMA=44_byte integer(kind=byte),parameter :: DIG0=48_byte integer(kind=byte),parameter :: DIG1=49_byte integer(kind=byte),parameter :: DIG2=50_byte integer(kind=byte),parameter :: DIG3=51_byte integer(kind=byte),parameter :: DIG4=52_byte integer(kind=byte),parameter :: DIG5=53_byte integer(kind=byte),parameter :: DIG6=54_byte integer(kind=byte),parameter :: DIG7=55_byte integer(kind=byte),parameter :: DIG8=56_byte integer(kind=byte),parameter :: DIG9=57_byte integer(kind=byte),parameter :: DIGIT=2_byte integer(kind=byte),parameter :: DOLLAR=36_byte integer(kind=byte),parameter :: DQUOTE=34_byte integer(kind=byte),parameter :: EQUALS=61_byte integer(kind=byte),parameter :: ERROUT=2_byte integer(kind=byte),parameter :: GREATER=62_byte integer(kind=byte),parameter :: LBRACE=123_byte integer(kind=byte),parameter :: LBRACK=91_byte integer(kind=byte),parameter :: LESS=60_byte integer(kind=byte),parameter :: LETA=97_byte integer(kind=byte),parameter :: LETB=98_byte integer(kind=byte),parameter :: LETC=99_byte integer(kind=byte),parameter :: LETD=100_byte integer(kind=byte),parameter :: LETE=101_byte integer(kind=byte),parameter :: LETF=102_byte integer(kind=byte),parameter :: LETG=103_byte integer(kind=byte),parameter :: LETH=104_byte integer(kind=byte),parameter :: LETI=105_byte integer(kind=byte),parameter :: LETJ=106_byte integer(kind=byte),parameter :: LETK=107_byte integer(kind=byte),parameter :: LETL=108_byte integer(kind=byte),parameter :: LETM=109_byte integer(kind=byte),parameter :: LETN=110_byte integer(kind=byte),parameter :: LETO=111_byte integer(kind=byte),parameter :: LETP=112_byte integer(kind=byte),parameter :: LETQ=113_byte integer(kind=byte),parameter :: LETR=114_byte integer(kind=byte),parameter :: LETS=115_byte integer(kind=byte),parameter :: LETT=116_byte integer(kind=byte),parameter :: LETTER=1_byte integer(kind=byte),parameter :: LETU=117_byte integer(kind=byte),parameter :: LETV=118_byte integer(kind=byte),parameter :: LETW=119_byte integer(kind=byte),parameter :: LETX=120_byte integer(kind=byte),parameter :: LETY=121_byte integer(kind=byte),parameter :: LETZ=122_byte integer(kind=byte),parameter :: LPAREN=40_byte !x!integer(kind=byte),parameter :: MAXCHARS=20_byte integer(kind=byte),parameter,public :: MAXLINE=1024_byte ! TYPICAL LINE LENGTH !x!integer(kind=byte),parameter :: MAXNAME=30_byte ! TYPICAL FILE NAME SIZE integer(kind=byte),parameter :: MINUS=45_byte integer(kind=byte),parameter :: NEWLINE=10_byte integer(kind=byte),parameter,public :: NO=0_byte integer(kind=byte),parameter :: NOERR=0_byte integer(kind=byte),parameter :: NOT=126_byte ! SAME AS TILDE integer(kind=byte),parameter :: OK=-2_byte integer(kind=byte),parameter :: OR=BAR ! SAME AS BAR integer(kind=byte),parameter :: PERCENT=37_byte integer(kind=byte),parameter :: PERIOD=46_byte integer(kind=byte),parameter :: PLUS=43_byte integer(kind=byte),parameter :: QMARK=63_byte integer(kind=byte),parameter :: RBRACE=125_byte integer(kind=byte),parameter :: RBRACK=93_byte integer(kind=byte),parameter :: READ=0_byte integer(kind=byte),parameter :: READWRITE=2_byte integer(kind=byte),parameter :: RPAREN=41_byte integer(kind=byte),parameter :: SEMICOL=59_byte integer(kind=byte),parameter :: SHARP=35_byte integer(kind=byte),parameter :: SLASH=47_byte integer(kind=byte),parameter :: SQUOTE=39_byte integer(kind=byte),parameter :: STAR=42_byte integer(kind=byte),parameter :: TAB=9_byte integer(kind=byte),parameter :: TILDE=126_byte integer(kind=byte),parameter :: UNDERLINE=95_byte integer(kind=byte),parameter :: WRITE=1_byte ! HANDY MACHINE-DEPENDENT PARAMETERS, CHANGE FOR A NEW MACHINE integer(kind=byte),parameter,public :: MAXPAT=512 integer(kind=byte),parameter,public :: MAXARG=512 integer(kind=byte),parameter :: MAXSUBS=10 integer(kind=byte),parameter :: COUNT=1 integer(kind=byte),parameter :: PREVCL=2 integer(kind=byte),parameter :: START=3 integer(kind=byte),parameter :: CLOSIZE=4 !x!integer(kind=byte),parameter :: ESCAPE=ATSIGN !x!integer(kind=byte),parameter :: ANY=QMARK !x!integer(kind=byte),parameter :: BOL=PERCENT integer(kind=byte),parameter :: EOL=DOLLAR integer(kind=byte),parameter :: CLOSURE=STAR integer(kind=byte),parameter :: DASH=MINUS integer(kind=byte),parameter :: ESCAPE=BACKSLASH integer(kind=byte),parameter :: ANY=PERIOD integer(kind=byte),parameter :: BOL=CARET integer(kind=byte),parameter :: CCL=LBRACK integer(kind=byte),parameter :: CCLEND=RBRACK integer(kind=byte),parameter :: NCCL=LETN integer(kind=byte),parameter :: CHAR=LETA integer(kind=byte),parameter :: BOSS=LBRACE ! < integer(kind=byte),parameter :: EOSS=RBRACE ! > !x!COMMON /CSUBS/ BPOS(MAXSUBS), EPOS(MAXSUBS) integer(kind=byte) :: bpos(maxsubs) ! beginning of partial match integer(kind=byte) :: epos(maxsubs) ! end of corresponding partial match type :: regex_pattern integer :: pat(MAXPAT) end type regex_pattern contains !----------------------------------------------------------------------------------------------------------------------------------! !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !----------------------------------------------------------------------------------------------------------------------------------! function f2r(string,isize) character(len=*),parameter::ident_1="& &@(#)M_match::f2r(3f): convert Fortran character variable to Ratfor integer array with Ratfor terminator" character(len=*),intent(in) :: string integer,intent(in) :: isize !!integer :: f2r(len(string)+1) integer :: f2r(isize) integer :: i f2r=blank do i=1,len_trim(string) f2r(i)=ichar(string(i:i)) enddo f2r(i)=eos end function f2r !----------------------------------------------------------------------------------------------------------------------------------! !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !----------------------------------------------------------------------------------------------------------------------------------! function r2f(ints) character(len=*),parameter::ident_2="@(#)M_match::r2f(3f): convert Ratfor integer array to Fortran character variable" integer,intent(in) :: ints(:) character(len=size(ints)-1) :: r2f integer :: i intrinsic char r2f=' ' do i=1,size(ints)-1 if(ints(i).eq.eos)then exit endif r2f(i:i)=char(ints(i)) enddo end function r2f !==================================================================================================================================! !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !==================================================================================================================================! !> !!##NAME !! getpat(3f) - [M_MATCH] convert str into pattern !! (LICENSE:PD) !!##SYNOPSIS !! !! integer function getpat(str, pat) !!##DESCRIPTION !! convert str into pattern !!##OPTIONS !!##EXAMPLE !! !!##AUTHOR !! John S. Urban !!##REFERENCE !! "Software Tools" by Kernighan and Plauger , 1976 !!##LICENSE !! Public Domain function getpat_(arg, pat) ! ident_1="@(#)M_match::getpat_ convert argument into pattern" integer(kind=def) :: getpat_ integer(kind=def) :: arg(maxarg) integer(kind=def) :: pat(maxpat) getpat_ = makpat_(arg, 1, EOS, pat) end function getpat_ !=================================================================================================================================== function getpat__(arg_str, pat) character(len=*),intent(in) :: arg_str integer(kind=def),intent(out) :: pat(maxpat) integer(kind=def) :: getpat__ integer(kind=def) :: arg(maxarg) integer :: len_arg_str len_arg_str=len(arg_str) if(len_arg_str.gt.MAXARG-1)then write(*,*)'*getpat* error: input arg_str too long,',len_arg_str,' > ',MAXARG-1 stop endif arg=f2r(arg_str,size(arg)) getpat__ = makpat_(arg, 1, eos, pat) end function getpat__ !==================================================================================================================================! !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !==================================================================================================================================! !> !!##NAME !! addset(3f) - [M_MATCH] put c in string(J) if it fits, increment J !! (LICENSE:PD) !!##SYNOPSIS !! !! integer function addset(c, str, j, maxsiz) !!##DESCRIPTION !! put c in string(j) if it fits, increment !!##OPTIONS !!##RETURNS !!##EXAMPLE !! !!##AUTHOR !! John S. Urban !!##REFERENCE !! "Software Tools" by Kernighan and Plauger , 1976 !!##LICENSE !! Public Domain function addset(c, set, j, maxsiz) ! ident_2="@(#)M_match::addset put C in SET(J) if it fits, increment J" integer(kind=byte) :: addset integer(kind=chr),intent(in) :: c integer(kind=chr) :: set(:) integer(kind=byte) :: j integer(kind=byte),intent(in) :: maxsiz if (j > maxsiz)then addset = NO else set(j) = c j = j + 1 addset = YES endif end function addset !==================================================================================================================================! !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !==================================================================================================================================! !> !!##NAME !! dodash(3f) - [M_MATCH] expand array(i-1)-array(i+1) into set(j)... from valid !! (LICENSE:PD) !!##SYNOPSIS !! !! subroutine dodash(valid, array, i, set, j, maxset) !!##DESCRIPTION !! expand array(i-1)-array(i+1) into set(j)... from valid !!##OPTIONS !!##EXAMPLE !! !!##AUTHOR !! John S. Urban !!##REFERENCE !! "Software Tools" by Kernighan and Plauger , 1976 !!##LICENSE !! Public Domain ! dodash - expand array(i-1)-array(i+1) into set(j)... from valid subroutine dodash(valid, array, i, set, j, maxset) integer(kind=def) :: i, j, junk, k, limit, maxset character(len=*),intent(in) :: valid integer(kind=chr) :: array(:) integer(kind=chr) :: set(:) intrinsic char i = i + 1 j = j - 1 limit = index(valid, char(esc(array, i))) k=index(valid,char(set(j))) do if(.not. (k.le.limit)) exit junk = addset(ichar(valid(k:k)), set, j, maxset) k=k+1 enddo end subroutine dodash !==================================================================================================================================! !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !==================================================================================================================================! !> !!##NAME !! locate(3f) - [M_MATCH] look for c in char class at pat(offset) !! (LICENSE:PD) !!##SYNOPSIS !! !! pure integer function locate(c, pat, offset) !!##DESCRIPTION !! look for c in char class at pat(offset) !!##OPTIONS !!##EXAMPLE !! !!##AUTHOR !! John S. Urban !!##REFERENCE !! "Software Tools" by Kernighan and Plauger , 1976 !!##LICENSE !! Public Domain !----------------------------------------------------------------------------------------------------------------------------------! !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !----------------------------------------------------------------------------------------------------------------------------------! pure function locate(c, pat, offset) ! ident_3="@(#)M_match::locate look for c in char class at pat(offset)" integer(kind=def) :: locate integer(kind=chr),intent(in) :: c integer(kind=chr),intent(in) :: pat(maxpat) integer(kind=def),intent(in) :: offset integer(kind=def) :: i ! size of class is at pat(offset), characters follow !x!for (i = offset + pat(offset); i > offset; i = i - 1) locate = NO LOC: do i = offset + pat(offset), offset+1, -1 if (c == pat(i)) then locate = YES exit LOC endif enddo LOC end function locate !==================================================================================================================================! !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !==================================================================================================================================! !> !!##NAME !! match(3f) - [M_MATCH] find match to a basic regular expression anywhere on input string !! (LICENSE:PD) !! !!##SYNOPSIS !! !! integer function match(line, pattern) !! !! character(len=*),intent(in) :: line !! integer,intent(in) :: pattern(MAXPAT) !! !!##DESCRIPTION !! Given a BRE(Basic Regular Expression) converted to a pattern !! return whether an input string matches it. !! !!##OPTIONS !! LIN string to search for a match to the pattern !! PAT pattern generated from a BRE using getpat(3f) or makpat(3f). !! !!##EXAMPLE !! !! Sample program: !! !! program demo_match !! use :: M_match, only : getpat, match !! use :: M_match, only : MAXPAT, MAXARG, MAXLINE, YES, ERR !! implicit none !! ! find _ find patterns in text !! integer :: pat(MAXPAT) !! character(len=MAXARG-1) :: argument !! integer :: stat !! integer :: ios !! integer :: len_arg !! character(len=MAXLINE-2) :: line !! call get_command_argument(1, argument,status=stat,length=len_arg) !! if(stat.ne.0.or.argument.eq.'')then !! write(*,*)"usage: find pattern." !! elseif(getpat(argument(:len_arg), pat) .eq. ERR) then !! write(*,*)"illegal pattern." !! else !! INFINITE: do !! read(*,'(a)',iostat=ios)line !! if(ios.ne.0)exit !! if(match(trim(line), pat) .eq. YES) then !! write(*,'(*(a))')trim(line) !! endif !! enddo INFINITE !! endif !! end program demo_match !! !!##AUTHOR !! John S. Urban !! !!##REFERENCE !! "Software Tools" by Kernighan and Plauger , 1976 !! !!##LICENSE !! Public Domain function match_(lin, pat) ! ident_4="@(#)M_match::match find match anywhere on line" integer(kind=def) :: match_ integer(kind=chr) :: lin(maxline), pat(maxpat) integer(kind=def) :: i if (pat(1) == bol) then ! anchored match if (amatch_(lin, 1, pat) > 0) then match_ = yes return endif else ! unanchored !- for (i = 1; lin(i) /= eos; i = i + 1) i=1 do while (lin(i) /= eos) if (amatch_(lin, i, pat) > 0) then match_ = yes return endif i=i+1 enddo endif match_ = no end function match_ !==================================================================================================================================! function match__(lin_str, pat) ! ident_5="@(#)M_match::match find match anywhere on line" character(len=*),intent(in) :: lin_str integer(kind=def) :: match__ integer(kind=chr) :: lin(maxline), pat(maxpat) lin=f2r(lin_str,size(lin)) match__=match_(lin,pat) end function match__ !==================================================================================================================================! !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !==================================================================================================================================! !> !!##NAME !! patsiz(3f) - [M_MATCH] returns size of pattern entry at pat(n) !! (LICENSE:PD) !!##SYNOPSIS !! !! integer function patsiz(pat, n) !!##DESCRIPTION !! returns size of pattern entry at pat(n) !!##OPTIONS !!##EXAMPLE !! !!##AUTHOR !! John S. Urban !!##REFERENCE !! "Software Tools" by Kernighan and Plauger , 1976 !!##LICENSE !! Public Domain function patsiz(pat, n) ! ident_6="@(#)M_match::patsiz returns size of pattern entry at pat(n)" integer(kind=def) :: patsiz integer(kind=chr) :: pat(MAXPAT) integer(kind=def) :: n select case(pat(n)) case(CHAR,BOSS,EOSS) patsiz = 2 case(BOL,EOL,ANY) patsiz = 1 case(CCL,NCCL) patsiz = pat(n + 1) + 2 case(CLOSURE) ! optional patsiz = CLOSIZE case default call error("in patsiz: cannot happen.") end select end function patsiz !==================================================================================================================================! !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !==================================================================================================================================! !> !!##NAME !! stclos(3f) - [M_MATCH] insert CLOSURE entry at pat(j) !! (LICENSE:PD) !!##SYNOPSIS !! !! integer function stclos(pat, j, lastj, lastcl) !!##DESCRIPTION !! insert CLOSURE entry at pat(j) !!##OPTIONS !!##RETURNS !!##EXAMPLE !! !!##AUTHOR !! John S. Urban !!##REFERENCE !! "Software Tools" by Kernighan and Plauger , 1976 !!##LICENSE !! Public Domain function stclos(pat, j, lastj, lastcl) ! ident_7="@(#)M_match::stclos insert closure entry at pat(j)" integer(kind=def) :: stclos integer(kind=chr) :: pat(maxpat) integer(kind=def) :: j, jp, jt, junk, lastcl, lastj !- for (jp = j - 1; jp >= lastj; jp = jp - 1) < ! make a hole do jp = j - 1, lastj, - 1 ! make a hole jt = jp + closize junk = addset(pat(jp), pat, jt, maxpat) enddo j = j + closize stclos = lastj junk = addset(closure, pat, lastj, maxpat) ! put closure in it junk = addset(0, pat, lastj, maxpat) ! count junk = addset(lastcl, pat, lastj, maxpat) ! prevcl junk = addset(0, pat, lastj, maxpat) ! start end function stclos !==================================================================================================================================! !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !==================================================================================================================================! !> !!##NAME !! getccl(3f) - [M_MATCH] expand char class at arg(i) into pat(j) !! (LICENSE:PD) !!##SYNOPSIS !! !! integer function getccl(arg, i, pat, j) !!##DESCRIPTION !! expand char class at arg(i) into pat(j) !!##OPTIONS !! ARG ADE string array !! I index into ARG !! PAT encoded regular expression !! J . !!##EXAMPLE !! !!##AUTHOR !! John S. Urban !!##REFERENCE !! "Software Tools" by Kernighan and Plauger , 1976 !!##LICENSE !! Public Domain function getccl(arg, i, pat, j) ! ident_8="@(#)M_match::getccl expand char class at arg(i) into pat(j)" integer(kind=def) :: getccl integer(kind=chr) :: arg(maxarg), pat(maxpat) integer(kind=def) :: i, j, jstart, junk i = i + 1 ! skip over [ if (arg(i) == tilde .or. arg(i) == caret) then junk = addset(nccl, pat, j, maxpat) i = i + 1 else junk = addset(ccl, pat, j, maxpat) endif jstart = j junk = addset(0, pat, j, maxpat) ! leave room for count call filset(cclend, arg, i, pat, j, maxpat) pat(jstart) = j - jstart - 1 if (arg(i) == cclend)then getccl = ok else getccl = err endif end function getccl !==================================================================================================================================! !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !==================================================================================================================================! !> !!##NAME !! filset(3f) - [M_MATCH] expand set at array(i) into set(j), stop at delim !! (LICENSE:PD) !!##SYNOPSIS !! !! subroutine filset(delim, array, i, set, j, maxset) !!##DESCRIPTION !! expand set at array(i) into set(j), stop at delim !!##OPTIONS !!##EXAMPLE !! !!##AUTHOR !! John S. Urban !!##REFERENCE !! "Software Tools" by Kernighan and Plauger , 1976 !!##LICENSE !! Public Domain subroutine filset(delim, array, i, set, j, maxset) ! ident_9="@(#)M_match::filset expand set at array(i) into set(j), stop at delim" integer(kind=def) :: i, j, junk, maxset integer(kind=chr) :: array(:), delim, set(:) character(len=*),parameter :: digits= "0123456789" character(len=*),parameter :: lowalf= "abcdefghijklmnopqrstuvwxyz" character(len=*),parameter :: upalf= "ABCDEFGHIJKLMNOPQRSTUVWXYZ" intrinsic char !- for ( ; array(i) /= delim .and. array(i) /= eos; i = i + 1) do while( array(i) /= delim .and. array(i) /= eos) if (array(i) == escape) then junk = addset(esc(array, i), set, j, maxset) elseif (array(i) /= dash) then junk = addset(array(i), set, j, maxset) elseif (j <= 1 .or. array(i+1) == eos) then ! literal - junk = addset(dash, set, j, maxset) elseif (index(digits, char(set (j - 1))) > 0) then call dodash(digits, array, i, set, j, maxset) elseif (index(lowalf, char(set (j - 1))) > 0) then call dodash(lowalf, array, i, set, j, maxset) elseif (index(upalf, char(set (j - 1))) > 0) then call dodash(upalf, array, i, set, j, maxset) else junk = addset (DASH, set, j, maxset) endif i=i+1 enddo end subroutine filset !==================================================================================================================================! !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !==================================================================================================================================! !> !!##NAME !! esc(3f) - [M_MATCH] map array(i) into escaped character if appropriate !! (LICENSE:PD) !!##SYNOPSIS !! !! integer function esc(array, i) !! integer,intent(in) :: array(*) !! integer :: i !! !!##DESCRIPTION !! To support commonly used non-printable characters escaped strings are !! supported. When the ESCAPE character is encountered the following !! character is examined. If one of the special characters ESC(3f) will !! increment I and return the designated non-printable character. Otherwise !! it will return the character as-is. !! !! o convert \n to newline !! o convert \t to horizontal tab !! o convert \r to carriage return !! o convert \b to backspace !! o convert \nnn to character represented by octal value !! !!##OPTIONS !! ARRAY array of ADE (ASCII Decimal Equivalent) values terminated by !! an EOS (End-Of-String) character representing a string to scan !! for escaped characters. !! I pointer into ARRAY. It is incremented to the position of the !! next character in ARRAY on return. !! !!##RETURNS !! ESC The ADE for the substituted character !! !!##EXAMPLE !! !! !!##AUTHOR !! John S. Urban !! !!##REFERENCE !! "Software Tools" by Kernighan and Plauger , 1976 !! !!##LICENSE !! Public Domain function esc(array, i) ! ident_10="@(#)M_match::esc map array(i) into escaped character if appropriate" integer(kind=chr) :: esc integer(kind=chr) :: array(:) integer(kind=def) :: i if (array(i) /= escape)then ! if not an escape character, return the character as-is esc = array(i) elseif (array(i+1) == eos)then ! if ESCAP is the last character it is left as-is and is not special esc = escape else i = i + 1 ! increment I to look at character after ESCAP select case(array(i)) ! make substitution to special character for designated characters case(ichar('n'),ichar('N')); esc = newline case(ichar('t'),ichar('T')); esc = tab case(ichar('b'),ichar('B')); esc = backspace case(ichar('r'),ichar('R')); esc = cr case(dig0:dig7) !- for (esc = 0; array(i) >= dig0 .and. array(i) <= dig7; i = i + 1) esc=0 do while (array(i) >= dig0 .and. array(i) <= dig7) i = i + 1 esc = 8*esc + array(i) - dig0 i = i - 1 ! so like other cases enddo case default esc = array(i) ! otherwise just copy character end select endif end function esc !----------------------------------------------------------------------------------------------------------------------------------! ! Conventional C Constants ! Oct Dec Hex Char ! ----------------------- ! 000 0 00 NUL '\0' Null ! 007 7 07 BEL '\a' Bell ! *010 8 08 BS '\b' Backspace ! *011 9 09 HT '\t' Horizontal Tab ! *012 10 0A LF '\n' Line Feed ! 013 11 0B VT '\v' Vertical Tab ! 014 12 0C FF '\f' Form Feed ! *015 13 0D CR '\r' Carriage Return ! 134 92 5C \ '\\' Backslash !==================================================================================================================================! !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !==================================================================================================================================! !> !!##NAME !! omatch(3f) - [M_MATCH] try to match a single pattern at pat(j) !! (LICENSE:PD) !!##SYNOPSIS !! !! integer function omatch(lin, i, pat, j) !!##DESCRIPTION !! try to match a single pattern at pat(j) !!##OPTIONS !!##EXAMPLE !! !!##AUTHOR !! John S. Urban !!##REFERENCE !! "Software Tools" by Kernighan and Plauger , 1976 !!##LICENSE !! Public Domain function omatch_(lin, i, pat, j) ! ident_11="@(#)M_match::omatch_ try to match a single pattern at pat(j)" integer(kind=def) :: omatch_ integer(kind=chr) :: lin(maxline), pat(maxpat) integer(kind=def) :: bump, i, j, k omatch_ = no if (lin(i) == eos)then return endif bump = -1 if (pat(j) == char) then if (lin(i) == pat(j + 1))then bump = 1 endif elseif (pat(j) == bol) then if (i == 1)then bump = 0 endif elseif (pat(j) == any) then if (lin(i) /= newline)then bump = 1 endif elseif (pat(j) == eol) then if (lin(i) == newline .or. lin(i) == eos)then bump = 0 endif elseif (pat(j) == ccl) then if (locate(lin(i), pat, j + 1) == yes)then bump = 1 endif elseif (pat(j) == nccl) then if (lin(i) /= newline .and. locate(lin(i), pat, j + 1) == no)then bump = 1 endif elseif (pat(j) == boss) then k = pat(j+1) bpos(k+1) = i bump = 0 elseif (pat(j) == eoss) then k = pat(j+1) epos(k+1) = i bump = 0 else call error("in omatch_: can't happen.") endif if (bump >= 0) then i = i + bump omatch_ = yes endif end function omatch_ !==================================================================================================================================! !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !==================================================================================================================================! !> !!##NAME !! amatch(3f) - [M_MATCH] look for pattern matching regular expression; returns its location !! (LICENSE:PD) !!##SYNOPSIS !! !! loc = amatch(line, from, pat, tagbeg, tagend) !! !! character(len=*),intent(in) :: line !! integer,intent(in) :: from !! character :: pat(MAXPAT) !! integer :: tagbeg(MAXTAGS), tagend(MAXTAGS) !! integer :: loc !!##DESCRIPTION !! AMATCH scans LINE starting at location FROM, looking !! for a pattern which matches the regular expression coded !! in PAT. If the pattern is found, its starting location !! in LINE is returned. If the pattern is not found, AMATCH !! returns 0. !! !! The regular expression in PAT must have been previously !! encoded by GETPAT(3f) or MAKPAT(3f). (For a complete description !! of regular expressions, see the manpage for M_match.) !! !! AMATCH(3f) is a special-purpose version of MATCH(3f), which should !! be used in most cases. !!##OPTIONS !! LINE input line to scan !! FROM beginning location to start scan from !! PAT coded regular expression encoded by GETPAT(3f) or MAKPAT(3f) !! TAGBEG,TAGEND element "i + 1" returns start or end, respectively, of "i"th tagged subpattern !!##RETURNS !! LOC returns location match was found or zero (0) if no match remains !!##EXAMPLE !! !! Sample program: !! !! program demo_amatch !! use :: M_match, only : getpat, amatch !! use :: M_match, only : MAXPAT, MAXARG, MAXLINE, MAXTAGS, YES, ERR !! implicit none !! ! find _ find patterns in text !! integer :: pat(MAXPAT) !! character(len=MAXARG-1) :: argument !! integer :: stat !! integer :: ios !! integer :: len_arg !! integer :: loc !! integer :: ii !! character(len=MAXLINE-2) :: line !! integer :: tagbeg(MAXTAGS),tagend(MAXTAGS) !! call get_command_argument(1, argument,status=stat,length=len_arg) !! if(stat.ne.0.or.argument.eq.'')then !! write(*,*)"usage: find pattern." !! elseif(getpat(argument(:len_arg), pat) .eq. ERR) then !! write(*,*)"illegal pattern." !! else !! INFINITE: do !! read(*,'(a)',iostat=ios)line !! tagbeg=-9999;tagend=-9999 !! if(ios.ne.0)exit !! loc = amatch(trim(line), 1, pat, tagbeg, tagend) ! returns location/0 !! if(loc.gt.0)then ! matched; if no match, loc is returned as 0 !! write(*,'(*(a))')trim(line) !! ! (element "i + 1" returns start or end, respectively, of "i"th tagged subpattern) !! write(*,'(*(i0,1x,i0,1x,i0,/))')(ii,tagbeg(ii),tagend(ii),ii=1,size(tagbeg)) !! endif !! enddo INFINITE !! endif !! end program demo_amatch !! !!##SEE ALSO !! match, getpat, makpat !!##DIAGNOSTICS !! None !!##AUTHOR !! John S. Urban !!##REFERENCE !! "Software Tools" by Kernighan and Plauger , 1976 !!##LICENSE !! Public Domain function amatch_(lin, from, pat) ! ident_12="@(#)M_match::amatch_ (non-recursive) look for match starting at lin(from)" integer(kind=def) :: amatch_ integer(kind=chr) :: lin(maxline), pat(maxpat) integer(kind=def) :: from, i, j, offset, stack stack = 0 offset = from ! next unexamined input character !- for (j = 1; j <= maxsubs; j = j + 1) < ! clear partial match results do j = 1, maxsubs ! clear partial match results bpos(j) = offset epos(j) = offset enddo !- for (j = 1; pat(j) /= eos; j = j + patsiz(pat, j)) j=1 do while (pat(j) /= eos) if (pat(j) == closure) then ! a closure entry stack = j j = j + closize ! step over closure !- for (i = offset; lin(i) /= eos; ) ! match as many as possible i = offset do while ( lin(i) /= eos ) ! match as many as if (omatch_(lin, i, pat, j) == no)then ! possible exit endif enddo pat(stack+count) = i - offset pat(stack+start) = offset offset = i ! character that made us fail elseif (omatch_(lin, offset, pat, j) == no) then ! non-closure !- for ( ; stack > 0; stack = pat(stack+prevcl)) do while (stack >0) if (pat(stack+count) > 0)then exit endif stack = pat(stack+prevcl) enddo if (stack <= 0) then ! stack is empty amatch_ = 0 ! return failure return endif pat(stack+count) = pat(stack+count) - 1 j = stack + closize offset = pat(stack+start) + pat(stack+count) endif j = j + patsiz(pat, j) enddo ! else omatch_ succeeded epos(1) = offset amatch_ = offset ! success end function amatch_ !==================================================================================================================================! function amatch__(lin_str, from, pat) ! ident_13="@(#)M_match::amatch" character(len=*),intent(in) :: lin_str integer,intent(in) :: from integer(kind=def) :: amatch__ integer(kind=chr) :: pat(maxpat) integer(kind=chr) :: lin(maxline) lin=f2r(lin_str,size(lin)) amatch__=amatch_(lin,from,pat) end function amatch__ !==================================================================================================================================! !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !==================================================================================================================================! !> !!##NAME !! makpat(3f) - [M_MATCH] make pattern from arg(from), terminate on delim !! (LICENSE:PD) !!##SYNOPSIS !! !! integer function makpat(arg, from, delim, pat) !!##DESCRIPTION !! make pattern from arg(from), terminate on delim !!##OPTIONS !!##EXAMPLE !! !!##AUTHOR !! John S. Urban !!##REFERENCE !! "Software Tools" by Kernighan and Plauger , 1976 !!##LICENSE !! Public Domain function makpat_(arg, from, delim, pat) ! ident_14="@(#)M_match::makpat_ make pattern from arg(from), terminate at delim" integer(kind=def) :: makpat_ integer(kind=chr) :: arg(maxarg), delim, pat(maxpat) integer(kind=def) :: from, i, j, junk, lastcl, lastj, lj, nsubs, sp, substk(maxsubs) j = 1 ! pat index lastj = 1 lastcl = 0 nsubs = 0 ! counts number of @(@) pairs sp = 0 ! stack pointer for substk !- for (i = from; arg(i) /= delim .and. arg(i) /= eos; i = i + 1) < i=from do while ( arg(i) /= delim .and. arg(i) /= eos ) lj = j if (arg(i) == any)then junk = addset(any, pat, j, maxpat) elseif (arg(i) == bol .and. i == from)then junk = addset(bol, pat, j, maxpat) elseif (arg(i) == eol .and. arg(i + 1) == delim)then junk = addset(eol, pat, j, maxpat) elseif (arg(i) == ccl) then if (getccl(arg, i, pat, j) == err)then exit endif elseif (arg(i) == closure .and. i > from) then lj = lastj !x!if(pat(lj)==bol .or. pat(lj)==eol .or. pat(lj)==closure .or. pat(lj-1) == boss .or. pat(lj-1) == eoss) then if(pat(lj)==bol .or. pat(lj)==eol .or. pat(lj)==closure .or. pat(lj) == boss .or. pat(lj) == eoss) then exit endif lastcl = stclos(pat, j, lastj, lastcl) elseif (arg(i) == escape .and. arg(i+1) == lparen) then nsubs = nsubs + 1 if (nsubs >= maxsubs)then exit endif junk = addset(boss, pat, j, maxpat) junk = addset(nsubs, pat, j, maxpat) sp = sp + 1 substk(sp) = nsubs i = i + 1 elseif (arg(i) == escape .and. arg(i+1) == rparen) then if (sp <= 0)then exit endif junk = addset(eoss, pat, j, maxpat) junk = addset(substk(sp), pat, j, maxpat) sp = sp - 1 i = i + 1 else junk = addset(char, pat, j, maxpat) junk = addset(esc(arg, i), pat, j, maxpat) endif lastj = lj i=i+1 enddo if (arg(i) /= delim .or. sp /= 0)then ! terminated early makpat_ = err elseif (addset(eos, pat, j, maxpat) == no)then ! no room makpat_ = err else makpat_ = i endif end function makpat_ !==================================================================================================================================! !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !==================================================================================================================================! !> !!##NAME !! error(3f) - [M_MATCH] print message and stop program execution !! (LICENSE:PD) !!##SYNOPSIS !! !! subroutine error(line) !!##DESCRIPTION !! print message and stop program execution !!##OPTIONS !!##EXAMPLE !! !!##AUTHOR !! John S. Urban !!##REFERENCE !! "Software Tools" by Kernighan and Plauger , 1976 !!##LICENSE !! Public Domain subroutine error(message) ! ident_15="@(#)M_match::error(3f): print message and stop program execution" character(len=*),intent(in) :: message write(stderr,'(a)')trim(message) stop end subroutine error !----------------------------------------------------------------------------------------------------------------------------------! !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !----------------------------------------------------------------------------------------------------------------------------------! end module M_match !==================================================================================================================================! !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !==================================================================================================================================! !>>>>> ././src/M_expr.f90 module M_expr ! evaluate Fortran-like integer and logical expressions use iso_fortran_env, only : stderr=>error_unit, stdout=>output_unit,stdin=>input_unit use M_strings, only : nospace, v2s, substitute, upper, split, str_replace=>replace, sep, glob use M_list, only : dictionary implicit none private public :: expr public :: undef public :: get_integer_from_string integer,public,parameter :: G_line_length=4096 ! allowed length of input lines integer,public,parameter :: G_var_len=63 ! allowed length of variable names integer,public,save :: G_iout=stdout ! output unit logical,public,save :: G_verbose=.false. logical,public,save :: G_debug=.false. type(dictionary),public,save :: table character(len=G_line_length) :: G_source='' ! original source file line integer,save :: G_error=0 contains !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== ! if def=.true. define if just a variable name to "1" ! if logical=.true. must return .true. or .false. ! if ierr/=0 an error occurred recursive subroutine expr(line,value,ierr,def,logical) !@(#)expr(3f): process '[variablename=]expression' directive character(len=*),intent(in) :: line character(len=G_var_len),intent(out) :: value ! returned variable value integer,intent(out) :: ierr logical,intent(in),optional :: def logical,intent(in),optional :: logical character(len=:),allocatable :: array(:) character(len=G_line_length) :: expression !character(len=:),allocatable :: expression logical :: def_local integer :: i if(present(def))then def_local=def else def_local=.false. endif G_source=line G_error=0 if(line.eq.'')then write(*,*)'BLANKS' call show_state(msg='Variables:') value='' ierr=0 return endif call split(nospace(upper(line)),array,delimiters=';') ! split string to an array parsing on delimiters do i=1,size(array) expression=nospace(trim(array(i))) FIND_DEFINED: do ! find and reduce all DEFINED() functions to ".TRUE." or ".FALSE." if (index(expression,'DEFINED(').ne.0) then ! find a DEFINED() function call ifdefined(expression,index(expression,'DEFINED(')) ! reduce DEFINED() function that was found cycle ! look for another DEFINED() function endif exit ! no remaining DEFINED() functions so exit loop enddo FIND_DEFINED ! normalize logical operators expression=str_replace(expression,'==','.EQ.') expression=str_replace(expression,'/=','.NE.') expression=str_replace(expression,'!=','.NE.') expression=str_replace(expression,'>=','.GE.') expression=str_replace(expression,'<=','.LE.') expression=str_replace(expression,'>','.GT.') expression=str_replace(expression,'<','.LT.') expression=str_replace(expression,'&&','.AND.') expression=str_replace(expression,'||','.OR.') expression=str_replace(expression,'!','.NOT.') expression=str_replace(expression,'.XOR.','.NEQV.') if(index(expression,'=').ne.0)then call let(expression,value,def) elseif(def_local)then call let(expression,value,def) else if(present(logical))then call eval(expression,value,logical) else call eval(expression,value,.false.) endif endif enddo ierr=G_error end subroutine expr !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== subroutine let(expression,value,def) !@(#)define(3f): process 'variablename[=expression]' directive character(len=*),intent(in) :: expression ! packed uppercase working copy of input line character(len=G_var_len) :: value ! returned variable value character(len=G_line_length) :: temp ! scratch integer :: iequ ! location of "=" in the directive, if any integer :: iname ! length of variable name logical,intent(in),optional :: def logical :: def_local if(present(def))then; def_local=def; else; def_local=.false.; endif if(expression.eq.'')then value='0' return endif iequ=index(expression,'=') ! find "=" in "variable_name=expression" if any iname=merge(len_trim(expression),iequ-1,iequ.eq.0) ! find end of variable name call checkname(expression(:iname)) ! check that variable name is composed of allowed characters if(def_local)then if (iequ.eq.0) then ! if no = then variable assumes value of 1 temp='1' ! no = but a definition so set expression to "1" else ! =value string trails name on directive temp=expression(iequ+1:) ! get expression endif else temp=expression(iequ+1:) ! get expression endif call eval(temp,value) ! check answer temp=nospace(value) select case(temp) case('.FALSE.','.TRUE.') call table%set(expression(:iname),temp) case default ! assumed a number if ( verify(temp(1:1),'0123456789+-').eq.0 .and. verify(temp(2:len_trim(temp)),'0123456789').eq.0 ) then call table%set(expression(:iname),temp) elseif (temp(1:1).ge.'A'.and.temp(1:1).le.'Z'.or.temp(1:1).eq.'_')then ! appears to be variable name not number or logical value=table%get(temp) ! find defined parameter in dictionary if (value.eq.'')then ! unknown variable name call oops('*M_expr* ERROR(003) - Undefined variable name:'//trim(expression)) else if(def_local)then call checkname(expression(:iname)) ! test for legal variable name call table%set(expression(:iname),value) endif endif else call oops('*M_expr* ERROR(004) - Not logical or integer expression:'//trim(expression)) endif end select end subroutine let !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== subroutine eval(expression,value,logical) !@(#)eval(3f): evaluate math expression to .TRUE. or .FALSE. or integer value character(len=*),intent(in) :: expression character(len=*),intent(out) :: value character(len=G_line_length) :: temp logical,intent(in),optional :: logical logical :: logical_local integer :: iostat if(present(logical))then logical_local=logical else logical_local=.false. endif temp=expression if(G_verbose)write(*,*)'*eval*:',trim(temp) call parens(temp); if(G_verbose)write(*,*)'*eval*:after parens:',trim(temp) call math(temp,1,len_trim(temp)); if(G_verbose)write(*,*)'*eval*:after math:',trim(temp) call doop(temp,1,len_trim(temp)); if(G_verbose)write(*,*)'*eval*:after doop:',trim(temp) call logic(temp,1,len_trim(temp)); if(G_verbose)write(*,*)'*eval*:after logic:',trim(temp) ! check answer temp=nospace(temp) select case(temp) case('.FALSE.','.TRUE.','T','F','.T.','.F.') case default ! assumed a number if ( verify(temp(1:1),'0123456789+-').eq.0 .and. verify(temp(2:len_trim(temp)),'0123456789').eq.0 ) then elseif (logical_local)then write(temp,'(g0)',iostat=iostat)true_or_false(temp,1,len_trim(temp)) if(iostat.ne.0)then call oops('*M_expr* ERROR(005) - logical expression required:'//trim(expression)) endif elseif (temp(1:1).ge.'A'.and.temp(1:1).le.'Z'.or.temp(1:1).eq.'_')then ! appears to be variable name not number or logical temp=table%get(temp) ! find defined parameter in dictionary if (temp.eq.'')then ! unknown variable name call oops('*M_expr* ERROR(001) - Undefined variable name:'//trim(expression)) endif else call oops('*M_expr* ERROR(002) - Not logical or integer expression:'//trim(expression)) endif end select value=temp ! should be variable name to get value of or integer number or logical end subroutine eval !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== subroutine parens(line) !@(#)parens(3f): find subexpressions in parenthesis and process them character(len=G_line_length) :: line ! line - integer :: i integer :: j TILLDONE: do if (index(line,')').ne.0) then ! closing parens found do i=index(line,')'),1,-1 ! find first right paren, then backwards to left paren (find innermost set of parens) if (line(i:i).eq.'(') exit enddo if (i.eq.0) then call oops("*M_expr* ERROR(014) - Constant logical expression required:"//trim(G_source)) endif call math(line,i+1,index(line,')')-1) call doop(line,i+1,index(line,')')-1) call logic(line,i+1,index(line,')')-1) if (i.eq.1.and.index(line,')').eq.len_trim(line)) then ! rewrite line after no more parens line=line(i+1:index(line,')')-1) elseif (i.eq.1) then ! rewrite line after first set of parens line=line(2:index(line,')')-1)//line(index(line,')')+1:) elseif (index(line,')').eq.len_trim(line)) then ! rewrite line after last set of parens on line if (line(i+1:i+1).eq.'-'.and.index('*/+-',line(i-1:i-1)).ne.0) then do j=i-2,1,-1 if (index('*/+-',line(j:j)).ne.0) exit enddo !if (j.eq.i-2) then ! call oops("*M_expr* 1**(-1) NOT IMPLEMENTED YET") !endif select case (index('*/+-',line(i-1:i-1))) case(1,2) if (j.eq.0) then line='-'//line(:i-1)//line(i+2:index(line,')')-1) else line=line(:j)//'(-'//line(j+1:i-1)//line(i+2:index(line,')')) endif case(3) line=line(:i-2)//'-'//line(i+2:index(line,')')-1) case(4) line=line(:i-2)//'+'//line(i+2:index(line,')')-1) case default end select else line=line(:i-1)//line(i+1:index(line,')')-1) endif elseif (line(i+1:i+1).eq.'-'.and.index('*/+-',line(i-1:i-1)).ne.0) then do j=i-2,1,-1 if (index('*/+-',line(j:j)).ne.0) exit enddo !if (j.eq.i-2) then ! !call oops("*M_expr* 1**(-1) Not Implemented Yet") !endif select case (index('*/+-',line(i-1:i-1))) case(1,2) if (j.eq.0) then line='-'//line(:i-1)//line(i+2:index(line,')')-1)//line(index(line,')')+1:) else line=line(:j)//'(-'//line(j+1:i-1)//line(i+2:index(line,')'))//line(index(line,')')+1:) endif case(3) line=line(:i-2)//'-'//line(i+2:index(line,')')-1)//line(index(line,')')+1:) case(4) line=line(:i-2)//'+'//line(i+2:index(line,')')-1)//line(index(line,')')+1:) case default end select else line=line(:i-1)//line(i+1:index(line,')')-1)//line(index(line,')')+1:) endif line=nospace(line) cycle TILLDONE elseif (index(line,'(').ne.0) then call oops('*M_expr* ERROR(015) - Constant logical expression required:'//trim(G_source)) endif exit enddo TILLDONE end subroutine parens !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== subroutine math(line,ipos1,ipos2) !@(#)math(3f): integer :: ipos1 integer :: ipos2 integer :: i,j character(len=G_line_length) :: line character(len=G_line_length) :: newl newl=line(ipos1:ipos2) i=1 do j=index(newl(i:),'.') if (j.ne.0.and.j.ne.1) then call domath(newl(i:j+i-2),j-1) i=i+j elseif (j.eq.1) then i=i+1 else call domath(newl(i:),ipos2-i+1) exit endif enddo line(ipos1:ipos2)=newl line=nospace(line) end subroutine math !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== recursive subroutine domath(line,ipos2) !@(#)domath(3f): reduce integer expression containing +*-/ and ** operators character(len=*) :: line integer :: ipos2 character(len=11) :: temp character(len=G_line_length) :: newl character(len=2),parameter :: ops(3)= ['**','*/','+-'] integer :: i integer :: j integer :: location integer :: minus1 integer :: i1 integer :: i2 integer :: l integer :: length integer :: numop if (ipos2.eq.0) then return endif location=0 j=0 minus1=1 newl=line(:ipos2) OVERALL: do numop=1,3 ! check **, then */, then +- TILLDONE: do ! keep doing reduction of current operators i=index(newl,ops(numop)) ! find location in input string where operator string was found if (numop.ne.1) then ! if not the two-character operator ** check for either operator of current group i=index(newl,ops(numop)(1:1)) ! find first operator of group, if present j=index(newl,ops(numop)(2:2)) ! find second operator of group, if present i=max(i,j) ! find right-most operator, if any if (i*j.ne.0) i=min(i,j) ! if at least one operator is present find left-most endif IF (I.EQ.0) cycle OVERALL ! did not find these operators length=1 ! operator length IF (NUMOP.EQ.1) length=2 IF (I.EQ.len_trim(NEWL)) then ! if operator is at end of string call oops("*M_expr* ERROR(016) - Incomplete statement. Operator (**,/,*,+,-) at string end:"//trim(G_SOURCE)) exit OVERALL endif IF (I.EQ.1.AND.NUMOP.NE.3) then ! if operator at beginning of string and not +- call oops("*M_expr* ERROR(017) - Syntax error. Operator (**,*,/) not allowed to prefix expression:"//trim(G_SOURCE)) exit OVERALL endif if (.not.(i.eq.1.and.numop.eq.3)) then ! if processing +- operators and sign at beginning of string skip this if (index('*/+-',newl(i-1:i-1)).ne.0.or.index('*/+-',newl(i+length:i+length)).ne.0) then call oops('*M_expr* ERROR(018) - Syntax error in domath:'//trim(G_source)) exit OVERALL endif endif i1=0 if (.not.(i.eq.1.and.numop.eq.3)) then do j=i-1,1,-1 if (index('*/+-.',newl(j:j)).eq.0) cycle exit enddo if (.not.(j.eq.i-1.and.j.ne.1))then i1=get_integer_from_string(newl(j+1:i-1)) endif endif do l=i+len_trim(ops(numop)),len_trim(newl) if (index('*/+-.',newl(l:l)).eq.0) cycle exit enddo i2=get_integer_from_string(newl(i+length:l-1)) if (numop.eq.1) then i1=i1**i2*minus1 else select case (index('*/+-',newl(i:i))) case(1) i1=i1*i2*minus1 case(2) if(i2.eq.0)then call oops('*M_expr* ERROR(019) - Divide by zero:'//trim(G_source)) exit OVERALL endif i1=i1/i2*minus1 case(3) if (i1.ne.0) then i1=i1*minus1+i2 else i1=i1+i2*minus1 endif case(4) if (i1.ne.0) then i1=i1*minus1-i2 else i1=i1-i2*minus1 endif case default call oops('*M_expr* ERROR(020) - Internal program error:'//trim(G_source)) exit OVERALL end select endif if (i1.le.0) then if (j.eq.i-1.and.j.ne.1) then minus1=-1 i1=abs(i1) location=j+1 newl(j+1:j+1)=' ' l=l-1 newl=nospace(newl) elseif (i.eq.1.and.numop.eq.3) then minus1=-1 i1=abs(i1) location=i newl(j:j)=' ' l=l-1 j=j-1 newl=nospace(newl) else minus1=1 endif else minus1=1 endif write(temp,'(i11)') i1 temp=nospace(temp) if (j.eq.0.and.l.gt.len_trim(newl)) then newl=temp(:len_trim(temp)) cycle overall elseif (j.eq.0) then newl=temp(:len_trim(temp))//newl(l:) elseif (l.gt.len_trim(newl)) then newl=newl(:j)//temp(:len_trim(temp)) else newl=newl(:j)//temp(:len_trim(temp))//newl(l:) endif if(i1.lt.0)then ! if i1 is negative, could produce +- call substitute(newl,'+-','-') endif enddo TILLDONE enddo OVERALL if (minus1.eq.-1.and.(location.eq.0.or.location.eq.1)) then newl(:G_line_length)='-'//trim(newl) !x! note potentially trimming a character off the end elseif (minus1.eq.-1.and.location.ne.1) then newl=newl(:location-1)//'-'//newl(location:) endif line(:ipos2)=newl(:len_trim(newl)) end subroutine domath !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== recursive subroutine doop(line,ipos1,ipos2) !@(#)doop(3f): find VAL.OP.VAL strings and reduce to .TRUE. or .FALSE. character(len=G_line_length) :: line integer :: ipos1 integer :: ipos2 character(len=4),parameter :: ops(6) = ['.EQ.','.NE.','.GE.','.GT.','.LE.','.LT.'] character(len=G_var_len) :: val1 character(len=G_var_len) :: val2 integer :: ival1, ival2 character(len=7) :: temp character(len=G_line_length) :: newl integer :: i,j,k if(G_verbose)write(*,*)'*doop*:TOP:',trim(line),ipos1,ipos2 newl=line(ipos1:ipos2) if(G_verbose)write(*,*)'*doop*:NEWL:',trim(newl) CHECK_EACH_OP_TYPE: do i=1,6 FIND_MORE_OF: do if (index(newl,ops(i)).ne.0) then ! found current operator looking for do j=index(newl,ops(i))-1,1,-1 if (newl(j:j).eq.'.') then exit endif enddo call getval(newl,j+1,index(newl,ops(i))-1,val1) do k=index(newl,ops(i))+4,len_trim(newl) if (newl(k:k).eq.'.')then exit endif enddo call getval(newl,index(newl,ops(i))+4,k-1,val2) call domath(val1,len_trim(val1)) ! instead of a simple integer it could be an expression ival1=get_integer_from_string(val1) ival2=get_integer_from_string(val2) temp='.FALSE.' select case(i) ! determine truth case(1); if (ival1.eq.ival2) temp='.TRUE.' ! .eq. case(2); if (ival1.ne.ival2) temp='.TRUE.' ! .ne. case(3); if (ival1.ge.ival2) temp='.TRUE.' ! .ge. case(4); if (ival1.gt.ival2) temp='.TRUE.' ! .gt. case(5); if (ival1.le.ival2) temp='.TRUE.' ! .le. case(6); if (ival1.lt.ival2) temp='.TRUE.' ! .lt. case default temp='.FALSE.' end select call rewrit(newl,temp(:len_trim(temp)),j,j,k,k) newl=nospace(newl) cycle endif exit enddo FIND_MORE_OF enddo CHECK_EACH_OP_TYPE if (ipos1.ne.1) then line=line(:ipos1-1)//newl(:len_trim(newl))//line(ipos2+1:) else line=newl(:len_trim(newl))//line(ipos2+1:) endif line=nospace(line) if(G_verbose)write(*,*)'*doop*:END:',trim(line) end subroutine doop !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== subroutine logic(line,ipos1,ipos2) !@(#)logic(3f): process .OP. operator strings character(len=*) :: line integer,intent(in) :: ipos1, ipos2 logical :: left, right character(len=7) :: temp character(len=G_line_length) :: newl integer :: i,j,k,l character(len=6),parameter :: ops(6)= (/'.NOT. ','.AND. ','.OR. ','.EQV. ','.NEQV.','.DEF. '/) integer,parameter :: opl(6)= [(len_trim(ops(i)),i=1,size(ops))] integer :: ieqv integer :: ineqv integer :: i1 integer :: iop integer :: chrs integer :: len1 integer :: len2 logical :: answer newl=line(ipos1:ipos2) len1=0 len2=0 left=.false. LOOP: do i=1,3 ! process .not, .and., .or. INFINITE: do chrs=len_trim(ops(i)) IF (INDEX(NEWL,OPS(I)(:chrs)).EQ.0) cycle LOOP I1= INDEX(NEWL,OPS(I)(:chrs))-1 J=I1+1 LEN1=0 IF (I.NE.1) then OUTER: DO J=I1,1,-1 INNER: DO K=1,size(ops) LEN1=opl(k) IF (INDEX(NEWL(J:I1),OPS(K)(:len_trim(OPS(K)))).NE.0) exit OUTER enddo INNER enddo OUTER IF (J.EQ.0) LEN1=1 left=true_or_false(NEWL,J+LEN1,I1) endif OUT: DO L=I1+chrs,len_trim(NEWL) IN: DO K=1,size(ops) LEN2=opl(k) IF (INDEX(NEWL(I1+chrs:L),OPS(K)(:len_trim(OPS(K)))).NE.0) exit OUT enddo IN enddo OUT IF (L.GT.len_trim(NEWL)) LEN2=0 right=true_or_false(NEWL,I1+chrs+1,L-LEN2) select case(i) case(1); answer=.not.right case(2); answer=left.and.right case(3); answer=left.or.right case default call oops('*M_expr* ERROR(300) - Internal program error:'//trim(G_source)) end select temp='.FALSE.' if (answer) temp='.TRUE.' call rewrit(newl,temp(:len_trim(temp)),j,j+len1-1,l,l-len2+1) enddo INFINITE enddo LOOP TILLDONE: do ieqv=index(newl,'.EQV.') ineqv=index(newl,'.NEQV.') if (ieqv*ineqv.eq.0.and.ieqv.ne.ineqv) then ! if one found but not both iop=max(ieqv,ineqv) elseif (ieqv.ne.0) then ! if found .EQV. iop=min(ieqv,ineqv) elseif (ipos1.eq.1) then line=newl(:len_trim(newl))//line(ipos2+1:) return else line=line(:ipos1-1)//newl(:len_trim(newl))//line(ipos2+1:) return endif chrs=5 if (index(newl,'.EQV.').ne.iop) chrs=6 do j=iop-1,1,-1 if (newl(j:j+1).eq.'V.') exit enddo if (j.eq.0) len1=1 left=true_or_false(newl,j+len1,iop-1) do l=iop+chrs,len_trim(newl) if (newl(l:l+1).eq.'.E'.or.newl(l:l+1).eq.'.N') exit enddo if (l.gt.len_trim(newl)) len2=0 right=true_or_false(newl,iop+chrs,l+len2) answer=left.eqv.right if (chrs.ne.5) answer=left.neqv.right temp='.FALSE.' if (answer) temp='.TRUE.' call rewrit(newl,temp(:len_trim(temp)),j,j+len1-1,l,l-len2+1) enddo TILLDONE end subroutine logic !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== logical function true_or_false(line,ipos1,ipos2) !@(#)true_or_false(3f): convert variable name or .TRUE./.FALSE. to a logical value character(len=G_line_length),intent(in) :: line ! line containing string to interpret as a logical value integer,intent(in) :: ipos1 ! starting column of substring in LINE integer,intent(in) :: ipos2 ! ending column of substring in LINE character(len=G_var_len) :: value character(len=G_var_len) :: substring integer :: ios ! error code returned by an internal READ true_or_false=.false. ! initialize return value substring=line(ipos1:ipos2) ! extract substring from LINE to interpret select case (substring) ! if string is not a logical string assume it is a variable name case ('.FALSE.','.F.') true_or_false=.false. ! set appropriate return value case ('.TRUE.','.T.') true_or_false=.true. ! set appropriate return value case default ! assume this is a variable name, find name in dictionary value=table%get(substring) if (value.eq.'') then ! if not a defined variable name stop program call oops('*M_expr* ERROR(021) - Undefined variable. Expression='//trim(G_source)//'. Variable='//trim(substring)) else read(value,'(l4)',iostat=ios) true_or_false ! try to read a logical from the value for the variable name if(ios.ne.0)then ! not successful in reading string as a logical value call oops('*M_expr* ERROR(022) - Constant logical expression required.'//trim(G_source)) endif endif end select end function true_or_false !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== function get_integer_from_string(line) !@(#)get_integer_from_string(3f): read integer value from line ! assume string is a variable name or an integer value character(len=*),intent(in) :: line ! string to read an integer value from integer :: ios ! I/O error value to check to see if internal reads succeeded integer :: get_integer_from_string ! integer value to return if string is converted successfully character(len=:),allocatable :: value character(len=G_var_len) :: rendered_value integer :: ierr get_integer_from_string=0 if(len_trim(line).eq.0)then get_integer_from_string=0 elseif (verify(line,'0123456789 +-').eq.0) then ! assumed a number read(line,'(i11)',iostat=ios) get_integer_from_string ! try to read integer value from input string if(ios.ne.0)then ! failed to convert the string to an integer, so stop call oops('*M_expr* ERROR(023) - Must be integer:"'//trim(line)//'" IN '//trim(G_source)) endif else ! input is not a number, assume it represents a variable name value=table%get(line) if (value.eq.'')then ! if variable name not found in dictionary, stop call oops('*M_expr* ERROR(024) - Undefined variable name:"'//trim(line)//'" IN '//trim(G_source)) else call expr(value,rendered_value,ierr) ! recursive call value=trim(rendered_value) read(value,'(i11)',iostat=ios) get_integer_from_string ! read integer value from the value associated with name if(ios.ne.0)then ! failed reading integer from value, stop call oops('*M_expr* ERROR(025) - Must be integer:"'//trim(line)//"="//trim(value)//'" IN '//trim(G_source)) endif endif endif ! return integer value end function get_integer_from_string !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== subroutine rewrit(line,temp,j,j1,l,l1) !@(#)rewrit(3f): character(len=G_line_length) :: line character(len=*),intent(in) :: temp integer,intent(in) :: j,j1, l,l1 if(G_verbose)write(*,*)'*rewrit*:',trim(line),trim(temp),j,j1,l,l1 if (j.eq.0.and.l.gt.len_trim(line)) then ! done line=temp elseif (j.eq.0) then ! first item line=temp//line(l1:) elseif (l.gt.len_trim(line)) then ! last item if (j1.ne.0) then line=line(:j1)//temp else line=temp endif else ! middle item line=line(:j1)//temp//line(l1:) endif if(G_verbose)write(*,'(*(g0))')'*rewrit*:END:LINE:',trim(line),':TEMP:',trim(temp),':',j,j1,l,l1 end subroutine rewrit !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== subroutine checkname(line,ierr) !@(#)name(3f): test for legal variable name character(len=*) :: line integer,intent(out),optional :: ierr integer :: i if (len(line).eq.0)then else if (line(1:1).lt.'A'.or.line(1:1).gt.'Z'.and.line(1:1).ne.'_')then ! variable names start with a-z call oops("*M_expr* ERROR(006) - Name does not start with alphameric or '_' (or general syntax error):"//trim(G_source),ierr) elseif(len_trim(line).gt.G_var_len)then call oops('*M_expr* ERROR(007) - Variable name exceeds '//v2s(G_var_len)//' characters:'//trim(G_source),ierr) endif do i=2,len_trim(line) ! name uses $ _ and letters (A-Z) digits (0-9) if(line(i:i).ne.'$'.and.line(i:i).ne.'_'.and. & & (line(i:i).lt.'A'.or.line(i:i).gt.'Z').and. & & (line(i:i).lt.'0'.or.line(i:i).gt.'9')) then call oops('*M_expr* ERROR(008) - Variable name contains unallowed character(or general syntax error):'//trim(G_source),ierr) endif enddo end subroutine checkname !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== subroutine ifdefined(line,ipos1) !@(#)ifdefined(3f): process and reduce DEFINED() function that was found character(len=G_line_length) :: line integer,intent(in) :: ipos1 character(len=G_line_length) :: newl character(len=G_var_len),allocatable :: ifvars(:) character(len=G_var_len),allocatable :: value integer :: j newl=line(ipos1+7:) ! defined( if (len_trim(newl).eq.1.or.index(newl,')').eq.0.or. index(newl,')').eq.2)then call oops("*M_expr* ERROR(013) - Incomplete statement."//trim(G_SOURCE)) endif value='.true.' line(ipos1:ipos1+6+index(newl,')'))='.TRUE.' ifvars= sep(newl(2:index(newl,')')-1),',') LIST: do j=1,size(ifvars) call checkname(ifvars(j)) ! test for legal variable name value=table%get(ifvars(j)) if(value.ne.'')cycle LIST value='.false.' line(ipos1:ipos1+6+index(newl,')'))='.FALSE.' exit LIST enddo LIST end subroutine ifdefined !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== subroutine getval(line,ipos1,ipos2,value) !@(#)getval(3f): get value from dictionary for given variable name or return input character(len=G_line_length),intent(in) :: line ! current(maybe partial) directive line integer,intent(in) :: ipos1 ! beginning position of variable name in LINE integer,intent(in) :: ipos2 ! ending position of variable name in LINE character(len=G_var_len),intent(out) :: value ! returned variable value character(len=G_line_length) :: temp ! copy of substring being examined integer :: i integer :: ivalue integer :: ios temp=line(ipos1:ipos2) ! place variable name/value substring into TEMP if (temp(1:1).eq.' ')then ! did not find expected variable name or value call oops('*M_expr* ERROR(009) - Incomplete statement.'//trim(G_SOURCE)) endif if (temp(1:1).ge.'A'.and.temp(1:1).le.'Z'.or.temp(1:1).eq.'_') then ! appears to be a variable name (not number or logical) value=table%get(temp) ! find defined parameter in dictionary if (value.eq.'')then ! unknown variable name call oops('*M_expr* ERROR(010) - Undefined variable name:'//trim(temp)//' in expression '//trim(G_source)) do i=1,size(table%key) ! print variable dictionary write(G_iout,'(*(g0,1x))')"! $DEFINE",trim(table%key(i)),' = ',adjustl(table%value(i)(:table%count(i)) ) enddo endif return else ! not a variable name, try as a value read(temp(1:11),'(i11)',iostat=ios) ivalue ! try string as a numeric integer value if(ios.eq.0)then write(value,'(i11)') ivalue ! write numeric value into VALUE return ! successfully return numeric VALUE endif continue ! failed to read numeric value value=temp(:G_var_len) ! test TEMP as a logical if (value.ne.'.FALSE.'.and.value.ne.'.TRUE.')then ! if here, value should be a logical call oops('*M_expr* ERROR(011) - Syntax error.'//trim(G_source)) endif ! value is ".TRUE." or ".FALSE." endif if(temp(1:1).ge.'A')then call oops('*M_expr* ERROR(012) - Defined value must be an integer or logical constant.'//trim(G_source)) endif end subroutine getval !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== subroutine undef(opts) !@(#)undef(3f): process UNDEFINE directive character(len=*) :: opts ! directive with no spaces, leading prefix removed, and all uppercase character(len=:),allocatable :: names(:) integer :: i,k ! REMOVE VARIABLE IF FOUND IN VARIABLE NAME DICTIONARY ! allow basic globbing where * is any string and ? is any character if (len_trim(opts).eq.0) then ! if no variable name call oops('*M_expr* ERROR(026) - missing targets:'//trim(G_source)) endif call split(opts,names,delimiters=' ;,') do k=1,size(names) do i=size(table%key),1,-1 ! find defined variable to be undefined by searching dictionary if (glob(trim(table%key(i)),trim(names(k))))then ! found the requested variable name call table%del(table%key(i)) endif enddo enddo end subroutine undef !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== subroutine show_state(list,msg) !@(#)debug(3f): process $SHOW command or state output when errors occur character(len=*),intent(in),optional :: list character(len=*),intent(in) :: msg integer :: i, j, ibug character(len=:),allocatable :: array(:) ! array of tokens character(len=*),parameter :: fmt='(*(g0,1x))' if(present(list))then if(list.ne.'')then ! print variables: CALL split(list,array,delimiters=' ;,') ! parse string to an array parsing on delimiters do j=1,size(array) do i=1,size(table%key) if(glob(trim(table%key(i)),trim(array(j))))then ! write variable and corresponding value write(G_iout,fmt)"! ",trim(table%key(i)),' = ',adjustl(table%value(i)(:table%count(i))) endif enddo enddo endif else write(G_iout,'(a)')'!===============================================================================' write(G_iout,'(a)')'! '//trim(msg) ! added UBOUND call because GFORTRAN returns size of 1 when undefined, OK with ifort and nvfortran ibug=minval([size(table%key),ubound(table%key)]) ! print variable dictionary do i=1,ibug ! print variable dictionary write(G_iout,fmt)"! ",trim(table%key(i)),' = ',adjustl(table%value(i)(:table%count(i)) ) enddo write(G_iout,'(a)')'!-------------------------------------------------------------------------------' endif end subroutine show_state !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== subroutine oops(message,ierr) !@(#) oops(3f): write MESSAGE to stderr if ierr not present and extract error number from ERROR(nnn) character(len=*),intent(in) :: message integer :: ios integer :: iwhere integer,intent(out),optional :: ierr write(stderr,'(a)',iostat=ios) trim(G_SOURCE) iwhere=index(message,'ERROR(') if(iwhere.ne.0)then read(message(iwhere+6:iwhere+8),'(i3)')G_error else write(G_iout,'(a)')'! *M_expr* ERROR(-999) - Message does not contain properly formatted ERROR CODE: '//trim(message) G_error=-999 endif if(.not.present(ierr))then write(G_iout,'(a)')'! '//trim(message) flush(unit=stdout,iostat=ios) flush(unit=stderr,iostat=ios) endif end subroutine oops !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== end module M_expr !>>>>> app/prep.f90 !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== ! @(#)prep: Fortran preprocessor ! Fortran preprocessor originally based on public-domain FPP preprocessor from Lahey Fortran Code Repository ! http://www.lahey.com/code.htm ! Extensively rewritten since under a MIT License. ! 2013-10-03,2020-12-19,2021-06-12 : John S. Urban ! ADD ! o line control # linenumber "file" ! o looping ! CONSIDER ! o make $OUTPUT file nestable ! o allow multiple files on $INCLUDE? ! o undocument $BLOCK HELP|VERSION? ! o %,>>,<< operators ! o replace math parsing with M_calculator (but add logical operators to M_calculator) ! o cpp-like procedure macros ! o cpp or fpp compatibility mode ! o modularize and modernize calculator expression, if/else/endif ! ! REMOVED $REDEFINE and no longer produce warning message if redefine a variable, more like fpp(1) and cpp(1) ! ! some fpp versions allow integer intrinsics, not well documented but things like "#define AND char(34)" ! ! a PROCEDURE variable with current procedure name, maybe MODULE::PROCEDURE::CONTAINS format would be very handy in messages ! ! perhaps change to a more standard CLI syntax; but either way support multiple -D and maybe -D without a space before value ! ! extend $INCLUDE to call libcurl to access remote files ! ! case('ENDBLOCK'); call document(' ') ! BUG: '' instead of 'END' worked with kracken95, not with M_CLI2 !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== module M_prep !@(#)M_prep(3f): module used by prep program USE ISO_FORTRAN_ENV, ONLY : STDERR=>ERROR_UNIT, STDOUT=>OUTPUT_UNIT,STDIN=>INPUT_UNIT use M_io, only : get_tmp, dirname, uniq, fileopen, filedelete, get_env ! Fortran file I/O routines use M_CLI2, only : set_args, SGET, iget, lget, unnamed, specified !,print_dictionary ! load command argument parsing module use M_strings, only : nospace, v2s, substitute, upper, lower, isalpha, split, delim, str_replace=>replace, sep, pad, unquote use M_strings, only : glob use M_list, only : dictionary use M_expr, only : expr, get_integer_from_string, table use M_match, only : getpat, match, regex_pattern use M_match, only : YES, ERR implicit none integer,parameter :: num=2048 ! number of named values allowed integer,public,parameter :: G_line_length=4096 ! allowed length of input lines integer,public,parameter :: G_var_len=63 ! allowed length of variable names logical,public :: G_ident=.false. ! whether to write IDENT as a comment or CHARACTER character(len=G_line_length),public :: G_source ! original source file line character(len=G_line_length),public :: G_outline ! message to build for writing to output type(dictionary),save :: macro type file_stack integer :: unit_number integer :: line_number=0 character(len=G_line_length) :: filename end type type(file_stack),public :: G_file_dictionary(250) type parcel_stack integer :: unit_number integer :: line_number=0 character(len=G_line_length) :: name end type type(parcel_stack),public :: G_parcel_dictionary(500) integer,save :: G_line_number=0 logical,save,public :: G_inparcel=.false. integer,public :: G_iocount=0 integer,public :: G_parcelcount=0 integer,public :: G_io_total_lines=0 integer,public :: G_iwidth ! maximum width of line to write on output unit logical,public :: G_noenv=.false. ! ignore environment variables in $IFDEF and $IFNDEF integer,public :: G_iout ! output unit integer,save,public :: G_iout_init ! initial output unit !integer,public :: G_ihelp=stderr ! output unit for help text integer,public :: G_ihelp=stdout ! output unit for help text character(len=10),public :: G_outtype='asis' integer,public :: G_varname_length=128 ! length for variable string definitions integer,public :: G_varname_width=0 ! minimum length for printing variable string definitions integer,public :: G_inc_count=0 character(len=G_line_length),public :: G_inc_files(50) character(len=:),allocatable,save :: G_MAN logical,save :: G_MAN_COLLECT=.false. logical,save :: G_MAN_PRINT=.false. character(len=:),allocatable :: G_MAN_FILE character(len=10) :: G_MAN_FILE_POSITION='ASIS ' integer,public :: G_nestl=0 ! count of if/elseif/else/endif nesting level integer,public,parameter :: G_nestl_max=20 ! maximum nesting level of conditionals logical,save :: G_debug=.false. logical,save,public :: G_verbose=.false. ! verbose, including write strings after @(#) like what(1). logical,save,public :: G_system_on=.false. ! allow system commands or not on $SYSTEM logical,public,save :: G_condop(0:G_nestl_max) ! storage to keep track of previous write flags data G_condop(0:G_nestl_max) /.true.,G_nestl_max*.false./ logical,public :: G_dc ! flag to determine write flag logical,public :: G_write=.true. ! whether non-if/else/endif directives should be processed logical,public :: G_llwrite=.true. ! whether to write current line or skip it integer,public :: G_comment_count=0 character(len=10),public :: G_comment_style=' ' character(len=:),allocatable,public :: G_comment character(len=:),allocatable,save :: G_scratch_file integer,save :: G_scratch_lun=-1 type(regex_pattern) :: G_pattern_start type(regex_pattern) :: G_pattern_stop logical,save :: G_extract character(len=:),allocatable,save :: G_extract_start character(len=:),allocatable,save :: G_extract_stop character(len=:),allocatable,save :: G_extract_start0 character(len=:),allocatable,save :: G_extract_stop0 logical,save :: G_extract_auto logical,save :: G_extract_writeflag=.false. character(len=:),allocatable,save :: G_cmd character(len=:),allocatable,save :: G_file character(len=:),allocatable,save :: G_lang logical :: G_cpp contains !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== subroutine cond() !@(#)cond(3f): process conditional directive assumed to be in SOURCE '$verb...' character(len=G_line_length) :: line ! directive line with leading prefix character (default is $) removed character(len=G_line_length) :: verb ! first word of command converted to uppercase character(len=G_line_length) :: options ! everything after first word of command till end of line or ! character(len=G_line_length) :: upopts ! directive line with leading prefix removed; uppercase; no spaces logical,save :: eb=.false. integer,save :: noelse=0 integer :: verblen logical :: ifound integer :: ierr character(len=G_var_len) :: value line=adjustl(G_source(2:)) ! remove leading prefix and spaces from directive line if (index(line//' ',G_comment) /= 0) then ! assume if directive contains G_comment comment is present ! LIMITATION: EVEN MESSAGES CANNOT CONTAIN COMMENTS line=line(:index(line//' ',G_comment)-1) ! trim trailing comment from directive endif if (line(1:1) == G_comment)line='' if(line(1:4) == '@(#)')then verblen=5 else verblen=scan(line,' (') endif if(verblen == 0)then verblen=len(line) verb=line options=' ' else verb=line(:verblen-1) options=adjustl(line(verblen:)) endif verb=upper(verb) upopts=nospace(upper(options)) ! remove spaces from directive if(G_debug.and.G_verbose)then ! if processing lines in a logically selected region write(stderr,*)'G_SOURCE='//trim(g_source) write(stderr,*)'LINE='//trim(line) write(stderr,*)'VERB='//trim(verb) write(stderr,*)'OPTIONS='//trim(options) write(stderr,*)'UPOPTS='//trim(upopts) call flushit() endif ifound=.true. if(G_write)then ! if processing lines in a logically selected region if(G_inparcel.and.(VERB /= 'PARCEL'.and.VERB /= 'ENDPARCEL') )then call write_out(trim(G_source)) ! write data line return endif ! process the directive ierr=0 select case(VERB) case(' ') ! entire line is a comment case('DEFINE','DEF','LET'); call expr(upopts,value,ierr,def=.true.) ! only process DEFINE if not skipping data lines case('REDEFINE','REDEF'); call expr(upopts,value,ierr,def=.true.) ! only process REDEFINE if not skipping data lines case('UNDEF','UNDEFINE','DELETE'); call undef(upper(options)) ! only process UNDEF if not skipping data lines case('INCLUDE','READ'); call include(options,50+G_iocount) ! Filenames can be case sensitive case('OUTPUT','ENDOUTPUT','OPEN','CLOSE'); call output_cmd(options) ! Filenames can be case sensitive case('PARCEL'); call parcel_case(upopts) case('ENDPARCEL'); call parcel_case('') case('POST','CALL','DO'); call prepost(upper(options)) case('BLOCK'); call document(options) case('ENDBLOCK'); call document(' ') case('SET','REPLACE','MACRO'); call set(options) case('UNSET'); call unset(upper(options)) ! only process UNSET if not skipping data lines case('IDENT','@(#)'); call ident(options) case('MESSAGE','WARNING'); call write_err(unquote(options)) ! trustingly trim MESSAGE from directive case('SHOW') ; call show_state(upper(options),msg='') CASE('HELP','CRIB'); call crib_help(stderr) case('STOP'); call stop(options) case('QUIT'); call stop('0 '//options) case('ERROR'); call stop('1 '//options) CASE('GET_ARGUMENTS'); call write_get_arguments() case('DEBUG'); G_debug=.not.G_debug ;write(stderr,*)'DEBUG:',G_debug case('VERBOSE'); G_verbose=.not.G_verbose ;write(stderr,*)'VERBOSE:',G_verbose case('IMPORT','GET_ENVIRONMENT_VARIABLE'); call import(options) case('SYSTEM','EXECUTE_COMMAND_LINE'); call exe() case default ifound=.false. end select if(ierr /= 0) call stop_prep(001,'expression invalid:',trim(G_source)) endif select case(VERB) ! process logical flow control even if G_write is false case('ELSE','ELSEIF','ELIF'); call else(verb,upopts,noelse,eb) case('ENDIF','FI'); call endif(noelse,eb) case('IF'); call if(upopts,noelse,eb) case('IFDEF','IFNDEF'); call def(verb,upopts,noelse,eb) case default if(.not.ifound)then call stop_prep(002,'unknown compiler directive:', '['//trim(verb)//']: '//trim(G_SOURCE) ) endif end select end subroutine cond !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== subroutine exe() !@(#)exe(3f): Execute the command line specified by the string COMMAND. character(len=G_line_length) :: command ! directive line with leading prefix and directive name removed character(len=G_line_length) :: defineme ! scratch string for writing a DEFINE directive in to return command status integer :: icmd=0 integer :: cstat integer :: ierr character(len=256) :: sstat character(len=G_var_len) :: value if(G_system_on)then command=adjustl(G_source(2:)) ! remove $ from directive command=command(7:) ! trim SYSTEM from directive if(G_verbose)then call write_err('+ '//command) endif ! not returning command status on all platforms call execute_command_line (command, exitstat=icmd,cmdstat=cstat,cmdmsg=sstat) ! execute system command if(icmd /= 0)then ! if system command failed exit program call stop_prep(003,'system command failed:',v2s(icmd)) endif else call stop_prep(004,'system directive encountered but not enabled:',trim(G_SOURCE)) endif write(defineme,'("CMD_STATUS=",i8)')icmd defineme=nospace(defineme) call expr(defineme,value,ierr) ! only process DEFINE if not skipping data lines if(ierr /= 0) call stop_prep(005,'expression invalid:',trim(G_source)) end subroutine exe !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== subroutine write_get_arguments() !@(#)write_get_arguments(3f): write block for processing M_CLI command line parsing integer :: i character(len=132),parameter :: text(*)=[character(len=132) :: & "function get_arguments()" ,& "character(len=255) :: message ! use for I/O error messages" ,& "character(len=:),allocatable :: string ! stores command line argument" ,& "integer :: get_arguments" ,& "integer :: command_line_length" ,& " call get_command(length=command_line_length) ! get length needed to hold command" ,& " allocate(character(len=command_line_length) :: string)" ,& " call get_command(string)" ,& " ! trim off command name and get command line arguments" ,& " string=adjustl(string)//' ' ! assuming command verb does not have spaces in it" ,& " string=string(index(string,' '):)" ,& " string='&cmd '//string//' /' ! add namelist prefix and terminator" ,& " read(string,nml=cmd,iostat=get_arguments,iomsg=message) ! internal read of namelist" ,& " if(get_arguments /= 0)then" ,& " write(*,'(''ERROR:'',i0,1x,a)')get_arguments, trim(message)" ,& " write(*,*)'COMMAND OPTIONS ARE'" ,& " write(*,nml=cmd)" ,& " stop 1" ,& " endif" ,& "end function get_arguments" ,& "" ] do i=1,size(text) write(G_iout,'(a)')trim(text(i)) enddo end subroutine write_get_arguments !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== subroutine output_cmd(opts) !@(#)output_cmd(3f): process $OUTPUT directive character(len=*) :: opts character(len=G_line_length) :: filename ! filename on $OUTPUT command character(len=20) :: position integer :: ios call dissect2('output','-oo --append .false.',opts) ! parse options and inline comment on input line if(size(unnamed) > 0.and.opts /= '')then filename=unnamed(1) else filename=' ' endif select case(filename) case('@') G_iout=stdout case(' ') ! reset back to initial output file if(G_iout /= stdout.and.G_iout /= G_iout_init)then ! do not close current output if it is stdout or default output file close(G_iout,iostat=ios) endif G_iout=G_iout_init case default G_iout=61 close(G_iout,iostat=ios) if(lget('append'))then; position='append'; else; position='asis'; endif open(unit=G_iout,file=filename,iostat=ios,action='write',position=position) if(ios /= 0)then call stop_prep(006,'failed to open output file:',trim(filename)) endif end select if(G_verbose)then call write_err( '+ output file changed to: '//trim(filename) ) endif end subroutine OUTPUT_CMD !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== subroutine parcel_case(opts) !@(#)parcel_case(3f): process $PARCEL directive character(len=*) :: opts character(len=G_line_length) :: name ! name on $PARCEL command integer :: ios integer :: lun character(len=256) :: message if(opts == '')then G_inparcel=.false. G_iout=G_iout_init else call dissect2('parcel','-oo ',opts) ! parse options and inline comment on input line if(size(unnamed) > 0.and.opts /= '')then name=unnamed(1) else name='' endif open(newunit=lun,iostat=ios,action='readwrite',status='scratch',iomsg=message) if(ios /= 0)then call stop_prep(007,'failed to open parcel scratch file:',trim(name)//' '//trim(message)) else G_parcelcount=G_parcelcount+1 G_parcel_dictionary(G_parcelcount)%name=name G_parcel_dictionary(G_parcelcount)%unit_number=lun G_inparcel=.true. G_iout=lun endif endif end subroutine parcel_case !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== subroutine prepost(opts) !@(#)prepost(3f): process $POST directive character(len=*) :: opts character(len=:),allocatable :: list character(len=:),allocatable :: names(:) ! names on $POST command character(len=:),allocatable :: fors(:) ! names on $POST --for integer :: i integer :: j,jsz call dissect2('PARCEL',' --FOR " " ',opts) ! parse options and inline comment on input line list='' if(size(unnamed) == 0.and.opts /= '')then list=' ' else do i=1,size(unnamed) list=list//' '//unnamed(i) enddo endif call split(list,names,delimiters=' ,') ! parse string to an array parsing on delimiters list=SGET('FOR') call split(list,fors,delimiters=' ,') ! parse string to an array parsing on delimiters jsz=size(fors) do i=size(names),1,-1 if(jsz == 0)then call post(names(i)) else do j=jsz,1,-1 call post(names(i)) call post(fors(j)) enddo endif enddo end subroutine prepost !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== subroutine post(parcel_name) !@(#)post(3f): switch to scratch file defined by PARCEL implicit none character(len=*),intent(in) :: parcel_name integer :: ifound integer :: ios character(len=4096) :: message integer :: i ifound=-1 do i=1,G_parcelcount if(G_parcel_dictionary(i)%name == parcel_name)then ifound=G_parcel_dictionary(i)%unit_number exit endif enddo if(ifound == -1)then call stop_prep(028,'parcel name not defined for',' PARCEL:'//trim(G_source)) else inquire(unit=ifound,iostat=ios) rewind(unit=ifound,iostat=ios,iomsg=message) if(ios /= 0)then call stop_prep(029,'error rewinding',' PARCEL:'//trim(G_source)//':'//trim(message)) endif if(G_debug)then do read(ifound,'(a)',iostat=ios)message if(ios /= 0)exit write(stdout,*)'>>>'//trim(message) enddo rewind(unit=ifound,iostat=ios,iomsg=message) endif G_iocount=G_iocount+1 if(G_iocount > size(G_file_dictionary))then call stop_prep(030,'input file nesting too deep:',trim(G_source)) endif G_file_dictionary(G_iocount)%unit_number=ifound G_file_dictionary(G_iocount)%filename=parcel_name G_file_dictionary(G_iocount)%line_number=0 endif end subroutine post !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== subroutine ident(opts) !@(#)ident(3f): process $IDENT directive character(len=*) :: opts character(len=G_line_length) :: lang ! language on $IDENT command character(len=:),allocatable :: text integer,save :: ident_count=1 integer :: i call dissect2('ident',' --language fortran',opts) ! parse options and inline comment on input line text='' do i=1,size(unnamed) text=text//' '//trim(unnamed(i)) enddo lang=SGET('language') select case(lang) case('fortran') !x! should make look for characters not allowed in metadata, continue over multiple lines, ... select case(len(text)) case(:89) if(G_ident)then write(G_iout,'("character(len=*),parameter::ident_",i0,"=""@(#)",a,''"'')')ident_count,text else write(G_iout,'("! ident_",i0,"=""@(#)",a,''"'')')ident_count,text endif ident_count=ident_count+1 case(90:126) if(G_ident)then write(G_iout,'("character(len=*),parameter::ident_",i0,"=""&")')ident_count write(G_iout,'(''&@(#)'',a,''"'')')text else write(G_iout,'("! ident_",i0,"=""@(#)",a,''"'')')ident_count,text endif ident_count=ident_count+1 case default call stop_prep(008,'description too long:',trim(G_SOURCE)) end select case('c') write(G_iout,'(a)')'#ident "@(#)'//text//'"' case default call stop_prep(009,'language unknown for',' $IDENT'//trim(G_SOURCE)) end select end subroutine ident !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== function getdate(name) result(s) !@(#) getdate(3f): Function to write date and time into returned string in different styles character(len=*),intent(in),optional :: name character(len=*),parameter :: month='JanFebMarAprMayJunJulAugSepOctNovDec' character(len=*),parameter :: fmt = '(I2.2,A1,I2.2,I3,1X,A3,1x,I4)' character(len=*),parameter :: cdate = '(A3,1X,I2.2,1X,I4.4)' character(len=:),allocatable :: s character(len=80) :: line integer :: v(8) character(len=10) :: name_ call date_and_time(values=v) name_='prep' if(present(name))name_=name select case(lower(name_)) case('prep') ; write(line,fmt) v(5), ':', v(6), v(3), month(3*v(2)-2:3*v(2)), v(1) ! PREP_DATE="00:39 5 Nov 2013" case('date') ; write(line,'(i4.4,"-",i2.2,"-",i2.2)') v(1),v(2),v(3) case('cdate'); write(line,cdate) month(3*v(2)-2:3*v(2)), v(3), v(1) case('long') ; write(line,'(i4.4,"-",i2.2,"-",i2.2," ",i2.2,":",i2.2,":",i2.2," UTC",sp,i0)') v(1),v(2),v(3),v(5),v(6),v(7),v(4) case('time') ; write(line,'(i2.2,":",i2.2,":",i2.2)') v(5),v(6),v(7) case default ; write(line,'(i4.4,"-",i2.2,"-",i2.2," ",i2.2,":",i2.2,":",i2.2," UTC",sp,i0)') v(1),v(2),v(3),v(5),v(6),v(7),v(4) end select s=trim(line) end function getdate !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== subroutine check_name(line) ! determine if a string is a valid Fortran name ignoring trailing spaces (but not leading spaces) character(len=*),parameter :: dig='0123456789' character(len=*),parameter :: lower='abcdefghijklmnopqrstuvwxyz' character(len=*),parameter :: upper='ABCDEFGHIJKLMNOPQRSTUVWXYZ' character(len=*),parameter :: allowed=upper//lower//dig//'_' character(len=*),intent(in) :: line character(len=:),allocatable :: name logical :: lout name=trim(line) if(len(name) /= 0)then lout = .true. & & .and. verify(name,allowed) == 0 & & .and. len(name) <= 63 else call stop_prep(010,"null variable name:",trim(G_source)) lout = .false. endif if(.not.lout)then call stop_prep(011,'name contains unallowed character(or general syntax error):',trim(G_source)) endif end subroutine check_name !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== subroutine unset(opts) !@(#)unset(3f): process UNSET directive character(len=*) :: opts ! directive with no spaces, leading prefix removed, and all uppercase character(len=:),allocatable :: names(:) integer :: i integer :: k integer :: ibug ! REMOVE VARIABLE IF FOUND IN VARIABLE NAME DICTIONARY ! allow basic globbing where * is any string and ? is any character if (len_trim(opts) == 0) then ! if no variable name call stop_prep(012,'missing targets for ',' $UNSET:'//trim(G_source)) endif call split(opts,names,delimiters=' ;,') do k=1,size(names) if(G_verbose)then call write_err('+ $UNSET '//names(k)) endif ! added UBOUND call because GFORTRAN returns size of 1 when undefined, OK with ifort and nvfortran ibug=minval([size(macro%key),ubound(macro%key)]) ! print variable dictionary do i=ibug,1,-1 ! find defined variable to be undefined by searching dictionary if (glob(trim(macro%key(i)),trim(names(k))))then ! found the requested variable name call macro%del(macro%key(i)) endif enddo enddo end subroutine unset !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== subroutine if(opts,noelse,eb) !@(#)if(3f): process IF and ELSEIF directives character(len=*),intent(in) :: opts integer,intent(out) :: noelse logical :: eb character(len=G_var_len) :: value integer :: ios integer :: ierr integer :: ithen character(len=G_line_length) :: expression noelse=0 G_write=.false. G_nestl=G_nestl+1 ! increment IF nest level if (G_nestl > G_nestl_max) then call stop_prep(013,'"$IF" block nesting too deep, limited to '//v2s(G_nestl_max)//' levels,',trim(G_source)) endif expression=opts ithen=len_trim(opts) ! trim off ")THEN" if(ithen > 5)then if(expression(ithen-4:ithen) == ')THEN'.and.expression(1:1) == '(')then expression=expression(2:ithen-5) endif endif if(G_debug.and.G_verbose) write(stderr,*)'*if* TOP:EXPRESSION:'//trim(expression) value='' call expr(expression,value,ierr,logical=.true.) if(ierr == 0)then read(value,'(l7)',iostat=ios)G_dc else G_dc=.false. call stop_prep(014,'"$IF" expression invalid:',trim(G_source)) endif if (.not.G_dc.or..not.G_condop(G_nestl-1).or.eb)then if(G_debug.and.G_verbose) write(stderr,*)'*if* PREVIOUS:' return ! check to make sure previous IF was true endif G_condop(G_nestl)=.true. G_write=G_condop(G_nestl) if(G_debug.and.G_verbose) write(stderr,*)'*if* BOT:' end subroutine if !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== subroutine def(verb,opts,noelse,eb) !@(#)def(3f): process IFDEF and IFNDEF directives character(len=*),intent(in) :: verb character(len=*),intent(in) :: opts integer,intent(out) :: noelse logical :: eb character(len=G_var_len) :: name character(len=G_var_len) :: value character(len=:),allocatable :: varvalue noelse=0 G_write=.false. G_nestl=G_nestl+1 ! increment IF nest level if (G_nestl > G_nestl_max) then call stop_prep(015,'block nesting too deep, limited to '//v2s(G_nestl_max)//' levels in:',' $IF'//trim(G_source)) endif call check_name(opts) ! check that opts contains only a legitimate variable name value=opts ! set VALUE to variable name G_dc=.true. ! initialize name=table%get(value) if (name == '') then ! if failed to find variable name G_dc=.false. endif if((.not.G_noenv).and.(.not.G_dc))then ! if not found in variable dictionary check environment variables if allowed varvalue=get_env(value) if(len_trim(varvalue) /= 0)then G_dc=.true. endif endif if(verb == 'IFNDEF')then G_dc=.not.G_dc endif if (.not.G_dc.or..not.G_condop(G_nestl-1).or.eb)then return ! check to make sure previous IFDEF or IFNDEF was true endif G_condop(G_nestl)=.true. G_write=G_condop(G_nestl) end subroutine def !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== subroutine else(verb,opts,noelse,eb) !@(#)else(3f): process else and elseif character(len=*) :: verb character(len=*) :: opts integer :: noelse logical :: eb character(len=G_line_length) :: expression integer :: ithen expression=opts ithen=len_trim(opts) ! trim off ")THEN" if(ithen > 5)then if(expression(ithen-4:ithen) == ')THEN'.and.expression(1:1) == '(')then expression=expression(2:ithen-5) endif endif if(noelse == 1.or.G_nestl == 0) then ! test for else instead of elseif call stop_prep(016,'misplaced $ELSE or $ELSEIF directive:',trim(G_SOURCE)) return endif if(verb == 'ELSE')then noelse=1 endif if(.not.G_condop(G_nestl-1))return ! if was true so ignore else eb=.false. if(G_condop(G_nestl)) then eb=.true. G_write=.false. elseif(len_trim(expression) /= 0)then ! elseif detected G_nestl=G_nestl-1 ! decrease if level because it will be incremented in subroutine if call if(expression,noelse,eb) else ! else detected G_condop(G_nestl)=.true. G_write=.true. endif end subroutine else !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== subroutine endif(noelse,eb) !@(#)endif(3f): process ENDIF directive integer,intent(out) :: noelse logical,intent(out) :: eb ! if no ELSE or ELSEIF present insert ELSE to simplify logic if(noelse == 0)then call else('ELSE',' ',noelse,eb) endif G_nestl=G_nestl-1 ! decrease if level if(G_nestl < 0)then call stop_prep(017,"misplaced $ENDIF directive:",trim(G_source)) endif noelse=0 ! reset else level eb=.not.G_condop(G_nestl+1) G_write=.not.eb G_condop(G_nestl+1)=.false. if(G_nestl == 0)then G_write=.true. eb=.false. endif end subroutine endif !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== logical function true_or_false(line,ipos1,ipos2) !@(#)true_or_false(3f): convert variable name or .TRUE./.FALSE. to a logical value character(len=G_line_length),intent(in) :: line ! line containing string to interpret as a logical value integer,intent(in) :: ipos1 ! starting column of substring in LINE integer,intent(in) :: ipos2 ! ending column of substring in LINE character(len=G_var_len) :: value character(len=G_var_len) :: substring integer :: ios ! error code returned by an internal READ true_or_false=.false. ! initialize return value substring=line(ipos1:ipos2) ! extract substring from LINE to interpret select case (substring) ! if string is not a logical string assume it is a variable name case ('.FALSE.','.F.') true_or_false=.false. ! set appropriate return value case ('.TRUE.','.T.') true_or_false=.true. ! set appropriate return value case default ! assume this is a variable name, find name in dictionary value=table%get(substring) if (value == '') then ! if not a defined variable name stop program call stop_prep(018,'undefined variable.',' DIRECTIVE='//trim(G_source)//' VARIABLE='//trim(substring)) else read(value,'(l4)',iostat=ios) true_or_false ! try to read a logical from the value for the variable name if(ios /= 0)then ! not successful in reading string as a logical value call stop_prep(019,'constant logical expression required.',trim(G_source)) endif endif end select end function true_or_false !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== subroutine document(opts) !@(#)document(3f): process BLOCK command to start or stop special processing character(len=*),intent(in) :: opts integer :: ierr integer :: ios character(len=G_line_length) :: options ! everything after first word of command till end of line or ! character(len=:),allocatable :: name ! CHECK COMMAND SYNTAX if(G_outtype == 'help')then ! if in 'help' mode wrap up the routine write(G_iout,'(a)')"'']" write(G_iout,'(a)')" WRITE(*,'(a)')(trim(help_text(i)),i=1,size(help_text))" write(G_iout,'(a)')" stop ! if --help was specified, stop" write(G_iout,'(a)')"endif" write(G_iout,'(a)')"end subroutine help_usage" !x!write(G_iout,'("!",a)')repeat('-',131) elseif(G_outtype == 'variable')then ! if in 'variable' mode wrap up the variable write(G_iout,'(a)')"'']" elseif(G_outtype == 'system')then close(unit=G_scratch_lun,iostat=ios) call execute_command_line( trim(G_cmd)//' < '//G_scratch_file//' > '//G_scratch_file//'.out') ierr=filedelete(G_scratch_file) options=G_scratch_file//'.out' call include(options,50+G_iocount) ! Filenames can be case sensitive elseif(G_outtype == 'version')then ! if in 'version' mode wrap up the routine write(G_iout,'("''@(#)COMPILED: ",a,"'',&")') getdate('long')//'>' write(G_iout,'(a)')"'']" write(G_iout,'(a)')" WRITE(*,'(a)')(trim(help_text(i)(5:len_trim(help_text(i))-1)),i=1,size(help_text))" !x!write(G_iout,'(a)')' write(*,*)"COMPILER VERSION=",COMPILER_VERSION()' !x!write(G_iout,'(a)')' write(*,*)"COMPILER OPTIONS=",COMPILER_OPTIONS()' write(G_iout,'(a)')" stop ! if --version was specified, stop" write(G_iout,'(a)')"endif" write(G_iout,'(a)')"end subroutine help_version" !x!write(G_iout,'("!",a)')repeat('-',131) endif ! parse options on input line call dissect2('block','--file --cmd sh --varname textblock --length 128 --width 0 --style "#N#" --append .false.',opts) ! if a previous command has opened a --file FILENAME flush it, because a new one is being opened or this is an END command ! and if a --file FILENAME has been selected open it call print_comment_block() ! now can start new section G_MAN='' if(SGET('file') /= '')then G_MAN_FILE=SGET('file') G_MAN_COLLECT=.true. else G_MAN_FILE='' G_MAN_COLLECT=.false. endif G_MAN_PRINT=.false. if(LGET('append'))then G_MAN_FILE_POSITION='APPEND' else G_MAN_FILE_POSITION='ASIS' endif if(size(unnamed) > 0.and.opts /= '')then name=upper(unnamed(1)) else name=' ' endif select case(name) case('COMMENT') G_outtype='comment' G_MAN_PRINT=.true. G_MAN_COLLECT=.true. if(SGET('style') /= '#N#')then G_comment_style=lower(SGET('style')) ! allow formatting comments for particular post-processors endif case('NULL') G_outtype='null' case('SET','REPLACE') G_outtype='set' G_MAN_PRINT=.false. G_MAN_COLLECT=.false. case('DEFINE') G_outtype='define' G_MAN_PRINT=.false. G_MAN_COLLECT=.false. case('REDEFINE') G_outtype='redefine' G_MAN_PRINT=.false. G_MAN_COLLECT=.false. case('MESSAGE') G_outtype='message' G_MAN_PRINT=.false. G_MAN_COLLECT=.false. case('SHELL','SYSTEM') G_outtype='system' G_MAN_PRINT=.false. G_MAN_COLLECT=.false. if(G_system_on)then ! if allowing commands to be executed flush(unit=G_iout,iostat=ios) !!G_scratch_file=scratch('prep_scratch.')) G_scratch_file=trim(uniq(get_tmp()//'prep_scratch.')) !! THIS HAS TO BE A UNIQUE NAME -- IMPROVE THIS G_scratch_lun=fileopen(G_scratch_file,'rw',ierr) if(ierr < 0)then call stop_prep(020,'filter command failed to open process:',trim(G_SOURCE)) endif else call stop_prep(021,'filter command $BLOCK encountered but system commands not enabled:',trim(G_SOURCE)) endif case('VARIABLE') G_outtype='variable' G_varname_length=iget('length') G_varname_width=iget('width') write(G_iout,'(a,i0,a)')trim(SGET('varname'))//'=[ CHARACTER(LEN=',G_varname_length,') :: &' G_MAN_PRINT=.false. case('HELP') G_outtype='help' write(G_iout,'(a)')'subroutine help_usage(l_help)' write(G_iout,'(a)')'implicit none' write(G_iout,'(a)')'character(len=*),parameter :: ident="@(#)help_usage(3f): prints help information"' write(G_iout,'(a)')'logical,intent(in) :: l_help' !write(G_iout,'(a)')'character(len=128),allocatable :: help_text(:)' write(G_iout,'(a)')'character(len=:),allocatable :: help_text(:)' write(G_iout,'(a)')'integer :: i' write(G_iout,'(a)')'logical :: stopit=.false.' write(G_iout,'(a)')'stopit=.false.' write(G_iout,'(a)')'if(l_help)then' ! NOTE: Without the type specification this constructor would have to specify all of the constants with the same character length. write(G_iout,'(a)')'help_text=[ CHARACTER(LEN=128) :: &' select case(G_comment_style) ! duplicate help text as a comment for some code documentation utilities case('doxygen') ! convert plain text to doxygen comment blocks with some automatic markdown highlights G_MAN_PRINT=.true. case('fort') ! convert plain text to ford comment blocks with some automatic markdown highlights G_MAN_PRINT=.true. case('none') ! do not print comment lines from block G_MAN_PRINT=.false. case default end select case('VERSION') G_outtype='version' write(G_iout,'(a)')'subroutine help_version(l_version)' write(G_iout,'(a)')'implicit none' write(G_iout,'(a)')'character(len=*),parameter :: ident="@(#)help_version(3f): prints version information"' write(G_iout,'(a)')'logical,intent(in) :: l_version' !write(G_iout,'(a)')'character(len=128),allocatable :: help_text(:)' write(G_iout,'(a)')'character(len=:),allocatable :: help_text(:)' write(G_iout,'(a)')'integer :: i' write(G_iout,'(a)')'logical :: stopit=.false.' write(G_iout,'(a)')'stopit=.false.' write(G_iout,'(a)')'if(l_version)then' ! NOTE: Without the type specification this constructor would have to specify all of the constants with the same character length. write(G_iout,'(a)')'help_text=[ CHARACTER(LEN=128) :: &' case('WRITE') G_outtype='write' case(' ','END') G_outtype='asis' G_MAN_COLLECT=.false. case('ASIS') G_outtype='asis' case default if(size(unnamed) > 0)then call stop_prep(022,'unexpected "BLOCK" option. found:"',trim(unnamed(1))//'" in '//trim(G_source) ) else call stop_prep(022,'unexpected "BLOCK" option. found:"',' " in '//trim(G_source) ) endif end select G_comment_count=0 end subroutine document !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== subroutine print_comment_block() !@(#)print_comment_block(3f): format comment block to file in document directory and output character(len=:),allocatable :: filename character(len=:),allocatable :: varvalue integer :: ios,iend,lun if(.not.allocated(G_MAN))then return endif varvalue=get_env('PREP_DOCUMENT_DIR') if(varvalue /= ''.and.G_MAN /= ''.and.G_MAN_FILE /= ' ')then ! if $BLOCK --file FILE is present generate file in directory/doc iend=len_trim(varvalue) if(varvalue(iend:iend) /= '/')then filename=trim(varvalue)//'/doc/'//trim(G_MAN_FILE) else filename=trim(varvalue)//'doc/'//trim(G_MAN_FILE) endif open(newunit=lun,file=filename,iostat=ios,action='write',position=G_MAN_FILE_POSITION) if(ios /= 0)then call stop_prep(023,'failed to open document output file:',trim(filename)) else if(len(G_MAN) > 1)then ! the way the string is built it starts with a newline write(lun,'(a)',iostat=ios) G_MAN(2:) else write(lun,'(a)',iostat=ios) G_MAN endif if(ios /= 0)then call write_err('G_MAN='//G_MAN) call stop_prep(024,'failed to write output file:',trim(filename)) endif endif close(unit=lun,iostat=ios) endif ! now if $BLOCK COMMENT print comment block if(G_MAN_PRINT)then call format_G_MAN() endif end subroutine print_comment_block !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== subroutine format_g_man() character(len=:),allocatable :: array1(:) ! output array of tokens character(len=:),allocatable :: array(:) ! output array of tokens integer :: ios integer :: i ALL: block WRITEIT: block select case(G_comment_style) case('doxygen') ! convert plain text to doxygen comment blocks with some automatic markdown highlights if(len(G_MAN) > 1)then ! the way the string is built it starts with a newline CALL split(G_MAN,array1,delimiters=new_line('N'),nulls='return') ! parse string to an array parsing on delimiters if(allocated(array))deallocate(array) allocate(character(len=len(array1)+6) :: array(size(array1))) ! make room for !! and ## array(:)=array1 deallocate(array1) do i=1,size(array) ! lines starting with a letter and all uppercase letters is prefixed with "##" if( upper(array(i)) == array(i) .and. isalpha(array(i)(1:1)).and.lower(array(i)) /= array(i))then array(i)='##'//trim(array(i)) select case(array(i)) case('##SYNOPSIS','##EXAMPLES','##EXAMPLE') array(i)=trim(array(i))//new_line('N')//'!'//'!' endselect else array(i)=' '//trim(array(i)) endif enddo if(size(array) > 0)then write(G_iout,'("!",">",a)')trim(array(1)) endif do i=2,size(array) write(G_iout,'("!","!",a)',iostat=ios)trim(array(i)) if(ios /= 0)exit WRITEIT enddo endif !x!write(G_iout,'("!",131("="))') case('ford') ! convert plain text to doxygen comment blocks with some automatic markdown highlights if(len(G_MAN) > 1)then ! the way the string is built it starts with a newline CALL split(G_MAN,array1,delimiters=new_line('N'),nulls='return') ! parse string to an array parsing on delimiters !======================================================================================== nvfortran bug ! array=[character(len=(len(array1)+6)) :: array1] !! pad with trailing spaces if(allocated(array))deallocate(array) allocate(character(len=len(array1)+6) :: array(size(array1))) ! make room for !! and ## array(:)=array1 !======================================================================================== deallocate(array1) do i=1,size(array) ! lines starting with a letter and all uppercase letters is prefixed with "##" if( upper(array(i)) == array(i) .and. isalpha(array(i)(1:1)).and.lower(array(i)) /= array(i))then array(i)='## '//trim(array(i)) select case(array(i)) case('## SYNOPSIS','## EXAMPLES','## EXAMPLE') array(i)=trim(array(i))//new_line('N')//'!>' endselect else array(i)=' '//trim(array(i)) endif enddo if(size(array) > 0)then write(G_iout,'("!>",a)')trim(array(1)) endif do i=2,size(array) write(G_iout,'("!>",a)',iostat=ios)trim(array(i)) if(ios /= 0)exit WRITEIT enddo endif !x!write(G_iout,'("!>",131("="))') case('none') ! ignore comment block case default if(len(G_MAN) > 1)then ! the way the string is built it starts with a newline G_MAN=G_MAN(2:)//repeat(' ',2*len(G_MAN)) ! make sure the white-space exists call substitute(G_MAN,NEW_LINE('A'),NEW_LINE('A')//'! ') G_MAN='! '//trim(G_MAN) endif write(G_iout,'(a)',iostat=ios) G_MAN if(ios /= 0)exit WRITEIT !x!write(G_iout,'("!",131("="))') end select exit ALL endblock WRITEIT call write_err('G_MAN='//G_MAN) call stop_prep(025,'failed to write comment block','') endblock ALL end subroutine format_g_man !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== subroutine show_state(list,msg) !@(#)debug(3f): process $SHOW command or state output when errors occur character(len=*),intent(in),optional :: list character(len=*),intent(in) :: msg integer :: i integer :: j character(len=:),allocatable :: array(:) ! output array of tokens character(len=*),parameter :: fmt='(*(g0,1x))' integer :: ibugm integer :: ibugt if(present(list))then if(list /= '')then ! print variables: CALL split(list,array,delimiters=' ;,') ! parse string to an array parsing on delimiters ibugm=minval([size(macro%key),ubound(macro%key)]) ibugt=minval([size(table%key),ubound(table%key)]) do j=1,size(array) do i=1,ibugm ! size(macro%key) bug in gfortran if(glob(trim(macro%key(i)),trim(array(j))))then ! write variable and corresponding value write(G_iout,fmt)"! MACRO: ",trim(macro%key(i)),' = ',adjustl(macro%value(i)(:macro%count(i))) endif enddo do i=1,ibugt ! size(table%key) bug in gfortran if(glob(trim(table%key(i)),trim(array(j))))then ! write variable and corresponding value write(G_iout,fmt)"! VARIABLE: ",trim(table%key(i)),' = ',adjustl(table%value(i)(:table%count(i))) endif enddo enddo return endif endif write(G_iout,'(a)')'!===============================================================================' write(G_iout,'(a)')'! '//trim(msg) write(G_iout,'(a)')'! Current state of prep(1):('//getdate()//')' write(G_iout,'("! Total lines read ............... ",i0)')G_io_total_lines ! write number of lines read write(G_iout,'("! Conditional nesting level....... ",i0)')G_nestl ! write nesting level write(G_iout,'("! G_WRITE (general processing).... ",l1)')G_write ! non-if/else/endif directives processed write(G_iout,'("! G_LLWRITE (write input lines)... ",l1)')G_llwrite ! non-if/else/endif directives processed call write_arguments() write(G_iout,'(a)')'! Open files:' write(G_iout,'(a)')'! unit ! line number ! filename' do i=1,G_iocount ! print file dictionary ! write table of files write(G_iout,'("! ",i4," ! ",i11," ! ",a)') & & G_file_dictionary(i)%unit_number, & & G_file_dictionary(i)%line_number, & & trim(G_file_dictionary(i)%filename ) enddo write(G_iout,'(a)')'! INCLUDE directories:' do i=1,G_inc_count write(G_iout,'("! ",a)') trim(G_inc_files(i)) enddo ibugt=minval([size(table%key),ubound(table%key)]) ! print variable dictionary if(ibugt > 0)then write(G_iout,fmt)'! Variables:(There are',ibugt,'variables defined)' do i=1,ibugt ! size(table%key) bug in gfortran write(G_iout,fmt)"! $DEFINE",trim(table%key(i)),' = ',adjustl(table%value(i)(:table%count(i)) ) enddo endif if(G_parcelcount > 0)write(G_iout,'(a)')'! Parcels:' do i=1,G_parcelcount write(G_iout,fmt) '! ',trim(G_parcel_dictionary(i)%name) enddo ibugm=minval([size(macro%key),ubound(macro%key)]) ! print variable dictionary if(ibugm > 0)then ! size(macro%key) > 0)then write(G_iout,fmt)'! Macros:(There are',ibugm,'keywords defined)' do i=1,ibugm ! size(table%key) bug in gfortran write(G_iout,fmt)"! $SET ",trim(macro%key(i)),' = ',adjustl(macro%value(i)(:macro%count(i)) ) enddo endif write(G_iout,'(a)')'!-------------------------------------------------------------------------------' end subroutine show_state !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== subroutine write_arguments() !@(#)write_arguments(3f): return all command arguments as a string integer :: istatus ! status (non-zero means error) integer :: ilength ! length of individual arguments integer :: i ! loop count integer :: icount ! count of number of arguments available character(len=255) :: value ! store individual arguments one at a time write(G_iout,'(a)',advance='no')'! Arguments ...................... ' icount=command_argument_count() ! intrinsic gets number of arguments do i=1,icount call get_command_argument(i,value,ilength,istatus) write(G_iout,'(a,1x)',advance='no')value(:ilength) enddo write(G_iout,'(a)') end subroutine write_arguments !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== subroutine include(line,iunit) !@(#)include(3f): add file to input file list implicit none character(len=G_line_length),intent(in) :: line integer,intent(in) :: iunit integer :: ios character(len=4096) :: message character(len=G_line_length) :: line_unquoted integer :: iend line_unquoted=adjustl(unquote(line)) ! remove " from filename using Fortran list-directed I/O rules iend=len_trim(line_unquoted) if(len(line_unquoted) >= 2)then if(line_unquoted(1:1) == '<'.and.line_unquoted(iend:iend) == '>')then ! remove < and > from filename line_unquoted=line_unquoted(2:iend-1) endif endif if(iunit == 5.or.line_unquoted == '@')then ! assume this is stdin G_iocount=G_iocount+1 G_file_dictionary(G_iocount)%unit_number=5 G_file_dictionary(G_iocount)%filename=line_unquoted return endif call findit(line_unquoted) open(unit=iunit,file=trim(line_unquoted),iostat=ios,status='old',action='read',iomsg=message) if(ios /= 0)then call show_state(msg='OPEN IN INCLUDE') call write_err(message) call stop_prep(026,'failed open of input file(',v2s(iunit)//"):"//trim(line_unquoted)) else rewind(unit=iunit) G_iocount=G_iocount+1 if(G_iocount > size(G_file_dictionary))then call stop_prep(027,'input file nesting too deep:',trim(G_source)) endif G_file_dictionary(G_iocount)%unit_number=iunit G_file_dictionary(G_iocount)%filename=line_unquoted G_file_dictionary(G_iocount)%line_number=0 endif end subroutine include !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== subroutine findit(line) !@(#)findit(3f): look for filename in search directories if name does not exist and return modified name character(len=G_line_length) :: line character(len=G_line_length) :: filename logical :: file_exist integer :: i integer :: iend_dir inquire(file=trim(line), exist=file_exist) ! test if input filename exists if(file_exist)then ! if file exits then return filename return endif if(G_inc_count > 0)then ! if search directories have been specified search for file do i=1,G_inc_count iend_dir=len_trim(G_inc_files(i)) if(G_inc_files(i)(iend_dir:iend_dir) /= '/')then filename=G_inc_files(i)(:iend_dir)//'/'//trim(line) else filename=G_inc_files(i)(:iend_dir)//trim(line) endif inquire(file=trim(filename), exist=file_exist) if(file_exist)then ! if find filename exit line=filename return endif enddo else ! file did not exist and no search directories have been specified filename=trim(line) endif call stop_prep(031,'missing input file:',trim(filename)) end subroutine findit !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== subroutine opens() !@(#)opens(3f): use expression on command line to open input files integer,parameter :: n=50 ! maximum number of tokens to look for character(len=G_line_length) :: array(n) ! the array to fill with tokens character(len=1) :: dlim=' ' ! string of single characters to use as delimiters integer :: icount ! how many tokens are found integer :: ibegin(n) ! starting column numbers for the tokens in INLINE integer :: iterm(n) ! ending column numbers for the tokens in INLINE integer :: ilength ! is the position of last non‐blank character in INLINE character(len=G_line_length) :: in_filename2='' ! input filename, default is stdin integer :: i, ii integer :: ivalue character(len=G_line_length) :: dir ! directory used by an input file if(.not.G_cpp)then in_filename2(:G_line_length) = sget('i') ! get values from command line if(in_filename2 == '')then ! read stdin if no -i on command line in_filename2 = '@' endif else if(size(unnamed) > 0)then in_filename2 = unnamed(1) else in_filename2 = '@' endif endif ! break command argument "i" into single words call delim(adjustl(trim(in_filename2)),array,n,icount,ibegin,iterm,ilength,dlim) ivalue=50 ! starting file unit to use do i=icount,1,-1 G_source='$include '//trim(array(i)) ! for messages call include(array(i),ivalue) ivalue=ivalue+1 ALREADY: block ! store directory path of input files as an implicit directory for reading $INCLUDE files dir=dirname(array(i)) do ii=1,G_inc_count if(G_inc_files(ii) == dir)exit ALREADY enddo G_inc_count=G_inc_count+1 G_inc_count=min(G_inc_count,size(G_inc_files)) ! guard against too many files; !x! should warn on overflow G_inc_files(G_inc_count)=dir endblock ALREADY enddo ! >>> ! If ARRAY(N) fills before reaching the end of the line the routine stops. ! Check "if(iend(icount) == ilength)" to see if you got to the end to warn if not all files include end subroutine opens !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== subroutine includes() !@(#)includes(3f): use expression on command line to get include directories integer,parameter :: n=50 ! maximum number of tokens to look for character(len=1) :: dlim=' ' ! string of single characters to use as delimiters integer :: ibegin(n) ! starting column numbers for the tokens in G_inc_files integer :: iterm(n) ! ending column numbers for the tokens in G_inc_files integer :: ilength ! is the position of last non‐blank character in G_inc_files ! G_inc_files is the array to fill with tokens ! G_inc_count is the number of tokens found ! break command argument "I" into single words call delim(adjustl(trim(SGET('I'))),G_inc_files,n,G_inc_count,ibegin,iterm,ilength,dlim) end subroutine includes !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== subroutine defines() !@(#)defines(3f): use expressions on command line to initialize dictionary and define variables integer,parameter :: n=300 ! maximum number of tokens to look for character(len=G_line_length) :: array(n) ! the array to fill with tokens character(len=1) :: dlim=' ' ! string of single characters to use as delimiters integer :: icount ! how many tokens are found integer :: ibegin(n) ! starting column numbers for the tokens in INLINE integer :: iterm(n) ! ending column numbers for the tokens in INLINE integer :: ilength ! is the position of last non‐blank character in INLINE character(len=:),allocatable :: in_define2 ! variable definition from command line integer :: i in_define2='' if(.not.G_cpp)then do i=1,size(unnamed) in_define2=in_define2//' '//unnamed(i) enddo endif ! break command argument prep_oo into single words call delim(adjustl(trim(in_define2))//' '//trim(SGET('D')),array,n,icount,ibegin,iterm,ilength,dlim) do i=1,icount G_source='$redefine '//trim(array(i)) call cond() ! convert variable name into a "$define variablename" directive and process it enddo ! If ARRAY(N) fills before reaching the end of the line the routine stops. ! Check "if(iend(icount) == ilength)" to see if you got to the end. end subroutine defines !=================================================================================================================================== subroutine undef(opts) !@(#)undef(3f): process UNDEFINE directive character(len=*) :: opts ! directive with no spaces, leading prefix removed, and all uppercase character(len=:),allocatable :: names(:) integer :: i integer :: k ! REMOVE VARIABLE IF FOUND IN VARIABLE NAME DICTIONARY ! allow basic globbing where * is any string and ? is any character if (len_trim(opts) == 0) then ! if no variable name call stop_prep(032,'missing targets in',' $UNDEFINE:'//trim(G_source)) endif call split(opts,names,delimiters=' ;,') do k=1,size(names) if(G_verbose)then call write_err('+ $UNDEFINE '//names(k)) endif do i=size(table%key),1,-1 ! find defined variable to be undefined by searching dictionary if (glob(trim(table%key(i)),trim(names(k))))then ! found the requested variable name call table%del(table%key(i)) endif enddo enddo end subroutine undef !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== subroutine stop(opts) !@(#)stop(3f): process stop directive character(len=*),intent(in) :: opts integer :: ivalue character(len=:),allocatable :: message integer :: iend ! CHECK COMMAND SYNTAX if(opts == '')then call stop_prep(000,'','',stop_value=1) else iend=index(opts,' ') if(iend == 0)then iend=len_trim(opts) message=' ' else message=unquote(trim(opts(iend:))) write(stderr,'(a)')message call flushit() endif ivalue=get_integer_from_string(opts(:iend)) if(ivalue == 0)then if(.not.G_debug)stop elseif(message == '')then call stop_prep(000,'','',stop_value=ivalue) ! UNEXPECTED "STOP" VALUE else if(.not.G_debug)stop ivalue endif endif end subroutine stop !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== subroutine stop_prep(errnum,translate,message,stop_value) !@(#)stop_prep(3f): write MESSAGE to stderr and exit program integer,intent(in) :: errnum character(len=*),intent(in) :: translate character(len=*),intent(in) :: message character(len=1024) :: toscreen character(len=:),allocatable :: translated integer,optional :: stop_value integer :: stop_value_local stop_value_local=1 if( present(stop_value) )stop_value_local=stop_value call write_err(trim(G_SOURCE)) select case(G_lang) case('en') translated=en(errnum,translate) case default translated=trim(translate) end select write(toscreen,'("*prep* ERROR(",i3.3,") - ",a,1x,a)')errnum,translated,message call show_state(msg=trim(toscreen)) if(.not.G_debug)stop stop_value_local end subroutine stop_prep !=================================================================================================================================== ! skeleton for supporting alternate languages function en(errnum,translate) result(english) integer,intent(in) :: errnum character(len=*),intent(in) :: translate character(len=:),allocatable :: english select case(errnum) case(000);english='' case(001);english='expression invalid:' case(002);english='unknown compiler directive:' case(003);english='system command failed:' case(004);english='system directive encountered but not enabled:' case(005);english='expression invalid:' case(006);english='failed to open output file:' case(007);english='failed to open parcel scratch file:' case(028);english='parcel name not defined for' case(029);english='error rewinding' case(030);english='input file nesting too deep:' case(008);english='description too long:' case(009);english='language unknown for' case(010);english='null variable name:' case(011);english='name contains unallowed character(or general syntax error):' case(012);english='missing targets for ' case(013);english='"IF" block nesting too deep, limited to '//v2s(G_nestl_max)//' levels,' case(014);english='"IF" expression invalid:' case(015);english='block nesting too deep, limited to '//v2s(G_nestl_max)//' levels in:' case(016);english='misplaced $ELSE or $ELSEIF directive:' case(017);english='misplaced $ENDIF directive:' case(018);english='undefined variable.' case(019);english='constant logical expression required.' case(020);english='filter command failed to open process:' case(021);english='filter command $BLOCK encountered but system commands not enabled:' case(022);english='unexpected "BLOCK" option. found:' case(023);english='failed to open document output file:' case(024);english='failed to write output file:' case(025);english='failed to write comment block' case(026);english='failed open of input file(' case(027);english='input file nesting too deep:' case(031);english='missing input file:' case(032);english='missing targets in' case(033);english='failed to write to process:' case(034);english='unexpected "BLOCK" value. Found:' case(035);english='unexpected "BLOCK" value. Found:' case(036);english='expression invalid:' case(037);english='incomplete set:' case(038);english='expression invalid:' case(039);english='failed to open output file:' case(040);english='block not closed in' case default; english=trim(translate) end select end function en !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== subroutine warn_prep(message) !@(#)warn_prep(3f): write MESSAGE to stderr and and continue program character(len=*),intent(in) :: message call write_err(message) call write_err(trim(G_SOURCE)) end subroutine warn_prep !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== ! This documentation is a combination of ! o the original Lahey documentation of fpp(1) from "LAHEY FORTRAN REFERENCE MANUAL"; Revision C, 1992; ! o documentation for the features subsequently added to the program. ! o examination of the code. subroutine setup(help_text,version_text) !@(#)help_usage(3f): prints help information implicit none character(len=:),allocatable,intent(out) :: help_text(:) character(len=:),allocatable,intent(out) :: version_text(:) !------------------------------------------------------------------------------- help_text=[ CHARACTER(LEN=128) :: & 'NAME ',& ' prep(1) - [DEVELOPER] preprocess Fortran source files ',& ' (LICENSE:MIT) ',& ' ',& 'SYNOPSIS ',& ' prep [[-D] define_list] ',& ' [-I include_directories] ',& ' [-i input_file(s)] ',& ' [-o output_file] ',& ' [--system] ',& ' [--type FILE_TYPE | --start START_STRING --stop STOP_STRING] ',& ' [--prefix character|ADE] ',& ' [--keeptabs] ',& ' [--noenv] ',& ' [--width n] ',& ' [-d ignore|remove|blank] ',& ' [--comment default|doxygen|ford|none] ',& ' [--ident] ',& ' [--verbose] ',& ' [--help| --usage| --crib| --version] ',& ' ',& ' IMPORTANT ',& ' For compatibility with other utilities where cpp(1)-like syntax is required ',& ' if -i is not specified and the unnamed parameters are less than three the ',& ' unnamed parameters are assumed to be the input file and optional output ',& ' file instead of macro definitions if the first parameter matches an existing ',& ' filename. ',& ' ',& 'DESCRIPTION ',& ' ',& ' prep(1) is a Fortran source preprocessor. ',& ' ',& ' A preprocessor performs operations on input files before they are passed to ',& ' a compiler, including conditional selection of lines based on directives ',& ' contained in the file. This makes it possible to use a single source file ',& ' even when different code is required for different programming environments. ',& ' ',& ' The prep(1) preprocessor has additional features that support free-format ',& ' documentation in the same file as the source and the generation of generic ',& ' code using a simple templating technique. The basic directives .... ',& ' ',& ' * Conditionally output parts of the source file (controlled by expressions ',& ' on the directives $IF, $IFDEF, $IFNDEF, and $ENDIF. The expressions may ',& ' include variables defined on the command line or via the directives ',& ' $DEFINE, and $UNDEFINE). ',& ' ',& ' * Include other files (provided by directive $INCLUDE). ',& ' ',& ' * Define parcels of text that may be replayed multiple times with ',& ' expansion, allowing for basic templating (controlled by directives ',& ' $PARCEL/$ENDPARCEL and $POST). The mechanism supported is to replace ',& ' text of the form ${NAME} with user-supplied strings similar to the ',& ' POSIX shell (controlled by directives $SET, $UNSET and $IMPORT). ',& ' ',& ' * Filter blocks of text and convert them to comments, a CHARACTER array, ',& ' Fortran WRITE statements, ... (provided by the $BLOCK directive.) ',& ' ',& ' The blocks of text may also be written to a file and executed, with ',& ' stdout captured and included in the prep(1) output file. ',& ' ',& ' Blocked text may optionally be simultaneously written to a separate file, ',& ' typically for use as documentation. ',& ' ',& ' * Call system commands (using the $SYSTEM directive). ',& ' ',& ' * Generate multiple output files from a single input file (using $OUTPUT). ',& ' ',& ' * Record the parameters used and the date and time executed as Fortran ',& ' comments in the output (using $SHOW). ',& ' ',& ' * Stop the preprocessing (controlled by directive $STOP, $QUIT or $ERROR) ',& ' and produce messages on stderr (using $MESSAGE). ',& ' ',& 'OPTIONS ',& ' define_list, -D define_list An optional space-delimited list of expressions ',& ' used to define variables before file processing ',& ' commences. These can subsequently be used in ',& ' $IF/$ELSE/$ELSEIF and $DEFINE directives. ',& ' ',& ' -i "input_files" The default input file is stdin. Filenames are ',& ' space-delimited. In a list, @ represents stdin. ',& ' ',& ' The suggested suffix for Fortran input files is ".ff" for code files unless ',& ' they contain $SYSTEM directives in which case ".FF" is preferred. $INCLUDE ',& ' files should use ".ffinc" and ".FFINC" if they include prep(1) directives. ',& ' This naming convention is not required. ',& ' ',& ' Files may also end in supported suffixes such as ".md", as explained under ',& ' the --type option description. ',& ' ',& ' -o output_file The default output file is stdout. ',& ' ',& ' -I "include_directories" The directories to search for files specified on ',& ' $INCLUDE directives. May be repeated. ',& ' ',& ' --system Allow system commands on $SYSTEM directives to be executed. ',& ' ',& ' --type FILETYPE This flag indicates to skip input lines until after a ',& ' specific start string is encountered and to stop once a ',& ' specific end string is found, left-justified on lines by ',& ' themselves. ',& ' FileType Start_String Stop_String ',& ' -------- ------------ ----------- ',& ' md ```fortran ``` ',& ' markdownMML ~~~ {: lang=fortran} ~~~ ',& ' html ',& ' tex \begin{minted}{Fortran} \end{minted} ',& ' ',& ' The default type is "auto", in which case files will be ',& ' processed according to their file suffix. ',& ' ',& ' This allows for easily extracting code from common document ',& ' formats. This is particularly useful with extended markdown ',& ' formats, allowing for code source to be easily documented ',& ' and for tests in documents to be able to be extracted and ',& ' tested. "auto" switches processing mode depending on input ',& ' file suffix, treating supported file suffixes ',& ' ("md","markdownMML","html","tex") appropriately. ',& ' ',& ' --start STRING Same as --type except along with --stop allows for custom ',& ' strings to be specified. The string is a BRE (Basic Regular ',& ' Expression). ',& ' ',& ' --stop STRING Same as --type except along with --start allows for custom ',& ' strings to be specified. The string is a BRE (Basic Regular ',& ' Expression). ',& ' ',& ' --comment Try to style comments generated in $BLOCK COMMENT blocks ',& ' for other utilities such as doxygen. Default is to ',& ' prefix lines with ''! ''. Allowed keywords are ',& ' currently "default", "doxygen","none","ford". ',& ' THIS IS AN ALPHA FEATURE AND NOT FULLY IMPLEMENTED. ',& ' ',& ' --prefix ADE|letter The directive prefix character. The default is "$". ',& ' If the value is numeric it is assumed to be an ASCII ',& ' Decimal Equivalent (Common values are 37=% 42=* 35=# ',& ' 36=$ 64=@). ',& ' ',& ' --noenv The $IFDEF and $IFNDEF directives test for an internal ',& ' prep(1) variable and then an environment variable by ',& ' default. This option turns off testing for environment ',& ' variables. ',& ' ',& ' --keeptabs By default tab characters are expanded assuming a stop has ',& ' been set every eight columns; and trailing carriage-return ',& ' are removed. Use this flag to prevent this processing from ',& ' from occurring. ',& ' ',& ' --ident The output of the $IDENT directive is in the form of a ',& ' comment by default. If this flag is set the output is ',& ' of the form described in the $IDENT documentation ',& ' so executables and object code can contain the metadata ',& ' for use with the what(1) command. Note this generates an ',& ' unused variable which some compilers might optimize ',& ' away depending on what compilation options are used. ',& ' ',& ' -d ignore|remove|blank Enable special treatment for lines beginning ',& ' with "d" or "D". The letter will be left as-is ',& ' (the default); removed; or replaced with a blank ',& ' character. This non-standard syntax has been ',& ' used to support the optional compilation of ',& ' "debug" code by many Fortran compilers when ',& ' compiling fixed-format Fortran source. ',& ' ',& ' --width n Maximum line length of the output file. The default is 1024. ',& ' The parameter is typically used to trim fixed-format Fortran ',& ' code that contains comments or "ident" labels past column 72 ',& ' when compiling fixed-format Fortran code. ',& ' ',& ' --verbose All commands on a $SYSTEM directive are echoed to stderr with a ',& ' "+" prefix. Text following the string "@(#)" is printed to stderr',& ' similar to the Unix command what(1) but is otherwise treated as ',& ' other text input. Additional descriptive messages are produced. ',& ' ',& ' --version Display version and exit ',& ' ',& ' --help Display documentation and exit. ',& ' ',& 'INPUT FILE SYNTAX ',& ' ',& ' The prep(1) preprocessor directives begin with "$" (by default) in column ',& ' one, and prep(1) will output no such lines. Other input is conditionally ',& ' written to the output file(s) based on the case-insensitive command names. ',& ' ',& ' An exclamation character FOLLOWED BY A SPACE on most directives ',& ' begins an in-line comment that is terminated by an end-of-line. The space ',& ' is required so comments are not confused with C-style logical operators such ',& ' as "!", which may NOT be followed by a space. ',& ' ',& ' VARIABLES AND EXPRESSIONS ',& ' ',& ' INTEGER or LOGICAL expressions are used to conditionally select ',& ' output lines. An expression is composed of INTEGER and LOGICAL ',& ' constants, variable names, and operators. Operators are processed ',& ' as in Fortran and/or C expressions. The supported operators are ... ',& ' ',& ' #-----#-----#-----#-----#-----# #-----#-----# ',& ' | + | - | * | / | ** | Math Operators # ( | ) | Grouping ',& ' #-----#-----#-----#-----#-----# #-----#-----# ',& ' Logical Operators ',& ' #-----#-----#-----#-----#-----#-----#-----#-----#-----#-----#------# ',& ' | .EQ.| .NE.| .GE.| .GT.| .LE.| .LT.|.NOT.|.AND.| .OR.|.EQV.|.NEQV.| ',& ' | == | /= | >= | > | <= | < | ! | && | || | == | != | ',& ' #-----# != #-----#-----#-----#-----#-----#-----#-----#-----#------# ',& ' #-----# ',& ' C-style operators NOT supported: %, <<, >>, &, ~ ',& ' ',& 'DIRECTIVES ',& ' ',& ' The directives fall into the following categories: ',& ' ',& ' VARIABLE DEFINITION FOR CONDITIONALS ',& ' Directives for defining variables ... ',& ' ',& ' $DEFINE variable_name[=expression] [;...] [! comment ] ',& ' $UNDEFINE|$UNDEF variable_name [;...] [! comment ] ',& ' ',& ' Details ... ',& ' ',& ' $DEFINE variable_name [=expression]; ... [! comment ] ',& ' ',& ' Defines a numeric or logical variable name and its value. The variable ',& ' names may subsequently be used in the expressions on the conditional output ',& ' selector directives $IF, $ELSEIF, $IFDEF, and $IFNDEF. ',& ' ',& ' If the result of the expression is ".TRUE." or ".FALSE." then the variable ',& ' will be of type LOGICAL, otherwise the variable is of type INTEGER (and the ',& ' expression must be an INTEGER expression or null). If no value is supplied ',& ' the variable is given the INTEGER value "1". ',& ' ',& ' Variables are defined from the point they are declared in a $DEFINE ',& ' directive or the command line until program termination unless explicitly ',& ' undefined with a $UNDEFINE directive. ',& ' ',& ' Example: ',& ' ',& ' > $define A ! will have default value of "1" ',& ' > $define B = 10 - 2 * 2**3 / 3 ! integer expressions ',& ' > $define C=1+1; D=(-40)/(-10) ',& ' > $define bigd= d >= a; bigb = ( (b >= c) && (b > 0) ) ! logical ',& ' > $if ( A + B ) / C == 1 ',& ' > (a+b)/c is one ',& ' > $endif ',& ' Note expressions are not case-sensitive. ',& ' ',& ' $UNDEFINE variable_name[; ...] ',& ' ',& ' A symbol defined with $DEFINE can be removed with the $UNDEFINE directive. ',& ' Multiple names may be specified, preferably separated by semi-colons. ',& ' ',& ' Basic globbing is supported, where "*" represents any string, and "?" ',& ' represents any single character. ',& ' ',& ' DEFINED(variable_name[,...]) ',& ' ',& ' A special function called DEFINED() may appear only in a $IF or $ELSEIF. ',& ' If "variable_name" has been defined at that point in the source code, ',& ' then the function value is ".TRUE.", otherwise it is ".FALSE.". A name is ',& ' defined only if it has appeared in the source previously in a $DEFINE ',& ' directive or been declared on the command line. ',& ' The names used in compiler directives are district from names in the ',& ' Fortran source, which means that "a" in a $DEFINE and "a" in a Fortran ',& ' source statement are totally unrelated. ',& ' The DEFINED() variable is NOT valid in a $DEFINE directive. ',& ' ',& ' Example: ',& ' ',& ' > Program test ',& ' > $IF .NOT. DEFINED (inc) ',& ' > INCLUDE "comm.inc" ',& ' > $ELSE ',& ' > INCLUDE "comm2.inc" ',& ' > $ENDIF ',& ' > END ',& ' ',& ' The file, "comm.inc" will be included in the source if the variable ',& ' "inc", has not been previously defined, while INCLUDE "comm2.inc" will ',& ' be included in the source if "inc" has been defined. ',& ' ',& ' Predefined variables are ',& ' ',& ' SYSTEMON = .TRUE. if --system was present on the command line, else .FALSE. ',& ' ',& ' UNKNOWN = 0 LINUX = 1 MACOS = 2 WINDOWS = 3 ',& ' CYGWIN = 4 SOLARIS = 5 FREEBSD = 6 OPENBSD = 7 ',& ' In addition OS is set to what the program guesses the system type is. ',& ' ',& ' > $if OS == LINUX ',& ' > write(*,*)"System type is Linux" ',& ' > $elseif OS == WINDOWS ',& ' > write(*,*)"System type is MSWindows" ',& ' > $else ',& ' > write(*,*)"System type is unknown" ',& ' > $endif ',& ' ',& ' CONDITIONAL CODE SELECTION ',& ' directives for conditionally selecting input lines ... ',& ' ',& ' $IF logical_integer-based expression | ',& ' $IFDEF [variable_name|environment_variable] | ',& ' $IFNDEF [variable_name|environment_variable] [! comment ] ',& ' { sequence of source statements} ',& ' [$ELSEIF|$ELIF logical_integer-based expression [! comment ] ',& ' { sequence of source statements}] ',& ' [$ELSE [! comment ] ',& ' { sequence of source statements}] ',& ' $ENDIF [! comment ] ',& ' ',& ' Details ... ',& ' ',& ' $IF/$ELSEIF/$ELSE/$ENDIF directives ... ',& ' ',& ' Each of these control lines delineates a block of source lines. If the ',& ' expression following the $IF is ".TRUE.", then the following lines of ',& ' source following are output. If it is ".FALSE.", and an $ELSEIF ',& ' follows, the expression is evaluated and treated the same as the $IF. If ',& ' the $IF and all $ELSEIF expressions are ".FALSE.", then the lines of ',& ' source following the optional $ELSE are output. A matching $ENDIF ends the ',& ' conditional block. ',& ' ',& ' $IFDEF/$IFNDEF directives ... ',& ' ',& ' $IFDEF and $IFNDEF are special forms of the $IF directive that simply test ',& ' if a variable name is defined or not. ',& ' ',& ' The expressions may optionally be enclosed in parenthesis and followed by ',& ' the keyword "THEN", ie. they may use Fortran syntax. For example, the ',& ' previous example may also be written as: ',& ' ',& ' > $IF(OS .EQ. LINUX)THEN ',& ' > write(*,*)"System type is Linux" ',& ' > $ELSEIF(OS .EQ. WINDOWS)THEN ',& ' > write(*,*)"System type is MSWindows" ',& ' > $ELSE ',& ' > write(*,*)"System type is unknown" ',& ' > $ENDIF ',& ' ',& ' Essentially, these are equivalent: ',& ' ',& ' $IFDEF varname ==> $IF DEFINED(varname) ',& ' $IFNDEF varname ==> $IF .NOT. DEFINED(varname) ',& ' ',& ' except that environment variables are tested as well by $IFDEF and $IFNDEF ',& ' if the --noenv option is not specified, but never by the function DEFINED(), ',& ' allowing for environment variables to be selectively used or ignored. ',& ' The --noenv switch is therefore only needed for compatibility with fpp(1). ',& ' For the purposes of prep(1) an environment variable is defined if it is ',& ' returned by the system and has a non-blank value. ',& ' ',& ' MACRO STRING EXPANSION AND TEXT REPLAY ',& ' Directives for defining replayable text blocks ... ',& ' ',& ' $PARCEL blockname / $ENDPARCEL [! comment ] ',& ' $POST blockname(s) [! comment ] ',& ' $SET varname string ',& ' $UNSET varname(s) [! comment ] ',& ' $IMPORT envname[;...] [! comment ] ',& ' ',& ' Details ... ',& ' ',& ' $PARCEL blockname / $ENDPARCEL [! comment ] ',& ' ',& ' The block of lines between a "$PARCEL name" and "$ENDPARCEL" directive are ',& ' written to a scratch file WITHOUT expanding directives. the scratch file can ',& ' then be read in with the $POST directive much like a named file can be with ',& ' $INCLUDE except the file is automatically deleted at program termination. ',& ' ',& ' $POST blockname(s) [! comment ] ',& ' ',& ' Read in a scratch file created by the $PARCEL directive. Combined with ',& ' $SET and $IMPORT directives this allows you to replay a section of input ',& ' and replace strings as a simple templating technique, or to repeat lines ',& ' like copyright information or definitions of (obsolescent) Fortran COMMON ',& ' blocks, but contained in source files without the need for separate ',& ' INCLUDE files or error-prone repetition of the declarations. ',& ' ',& ' $SET varname string ',& ' ',& ' If a $SET or $IMPORT directive defines a name prep(1) enters expansion mode. ',& ' In this mode anywhere the string "${NAME}" is encountered in subsequent ',& ' output it is replaced by "string". ',& ' ',& ' o values are case-sensitive but variable names are not. ',& ' o expansion of a line may cause it to be longer than allowed by some ',& ' compilers. Automatic breaking into continuation lines does not occur. ',& ' o comments are not supported on a $SET directive because everything past the ',& ' variable name becomes part of the value. ',& ' o The pre-defined values $FILE, $LINE, $DATE, and $TIME ( for input file, ',& ' line in input file, date and time ) are NOT ACTIVE until at least one ',& ' one $SET or $IMPORT directive is processed. That is, unless a variable ',& ' is defined no ${NAME} expansion occurs. ',& ' o The time and date refers to the time of processing, not the time of ',& ' compilation or loading. ',& ' ',& ' Example: ',& ' ',& ' > $set author William Shakespeare ',& ' > write(*,*)''By ${AUTHOR}'' ',& ' > write(*,*)''File ${FILE}'' ',& ' > write(*,*)''Line ${LINE}'' ',& ' > write(*,*)''Date ${DATE}'' ',& ' > write(*,*)''Time ${TIME}'' ',& ' ... ',& ' ',& ' $UNSET varname(s) ',& ' ',& ' Unset variables set with the $SET directive. ',& ' ',& ' $IMPORT envname[;...] [! comment ] ',& ' ',& ' The values of environment variables may be imported just like their names ',& ' and values were used on a $SET directive. The names of the variables are ',& ' case-sensitive in regards to obtaining the values, but the names become ',& ' case-insensitive in prep(). That is, "import home" gets the lowercase ',& ' environment variable "home" and then sets the associated value for the ',& ' variable "HOME" to the value. ',& ' ',& ' > $import HOME USER ',& ' > write(*,*)''HOME ${HOME}'' ',& ' > write(*,*)''USER ${USER}'' ',& ' ',& ' EXTERNAL FILES ',& ' Directives for reading and writing external files ... ',& ' ',& ' $OUTPUT filename [--append] [! comment ] ',& ' $ENDOUTPUT [! comment ] ',& ' $INCLUDE filename ',& ' ',& ' Details ... ',& ' ',& ' $OUTPUT filename [--append] [! comment ] ',& ' ',& ' Specifies the output file to write to. This overrides the initial output file',& ' specified with command line options. If no output filename is given ',& ' prep(1) reverts back to the initial output file. "@" is a synonym for stdout.',& ' ',& ' Files are open at the first line by default. Use the --append switch to ',& ' append to the end of an existing file instead of overwriting it. ',& ' ',& ' $ENDOUTPUT [! comment ] ',& ' ',& ' Ends writing to an alternate output file begun by a $OUTPUT directive. ',& ' ',& ' $INCLUDE filename ',& ' ',& ' Read in the specified input file. Fifty (50) nesting levels are allowed. ',& ' Following the tradition of cpp(1) if "" is specified the file is ',& ' only searched for relative to the search directories, otherwise it is ',& ' searched for as specified first. Double-quotes in the filename are treated ',& ' as in Fortran list-directed input. ',& ' ',& ' TEXT BLOCK FILTERS ',& ' (--file is ignored unless $PREP_DOCUMENT_DIR is set) ',& ' ',& ' $BLOCK [null|comment|write|variable [--varname NAME]| ',& ' set|system|message|define ',& ' help|version] [--file NAME [--append]] [! comment ] ',& ' $ENDBLOCK [! comment ] ',& ' ',& ' Details ... ',& ' ',& ' $BLOCK has several forms but in all cases operates on a block of lines: ',& ' ',& ' basic filtering: ',& ' $BLOCK [comment|null|write [--file NAME [--append]] ',& ' creating a CHARACTER array: ',& ' $BLOCK VARIABLE --varname NAME [--file NAME [--append]] ',& ' block versions of prep(1) commands: ',& ' $BLOCK set|system|message|define [--file NAME [--append]] ',& ' specialized procedure construction: ',& ' $BLOCK help|version [--file NAME [--append]] ',& ' ',& ' NULL: Do not write into current output file ',& ' COMMENT: write text prefixed by an exclamation and a space or according ',& ' to the style selected by the --comment style selected on the ',& ' command line. ',& ' WRITE: write text as Fortran WRITE(3f) statements ',& ' The Fortran generated is free-format. It is assumed the ',& ' output will not generate lines over 132 columns. ',& ' VARIABLE: write as a text variable. The name may be defined using ',& ' the --varname switch. Default name is "textblock". ',& ' MESSAGE: All the lines in the block are treated as options to $MESSAGE ',& ' SET: All the lines in the block are treated as options to $SET ',& ' DEFINE: All the lines in the block are treated as options to $DEFINE ',& ' SYSTEM: The lines are gathered into a file and executed by the shell ',& ' with the stdout being written to a scratch file and then read ',& ' END: End block of specially processed text ',& ' ',& ' special-purpose modes primarily for use with the M_kracken module: ',& ' ',& ' HELP: write text as a subroutine called HELP_USAGE ',& ' VERSION: write text as a subroutine called HELP_VERSION prefixing ',& ' lines with @(#) for use with the what(1) command. ',& ' ',& ' If the "--file NAME" option is present the text is written to the ',& ' specified file unfiltered except for string expansion. This allows ',& ' documentation to easily be maintained in the source file. It can be ',& ' markdownMML, tex, html, markdown or any plain text. The filename will be ',& ' prefixed with $PREP_DOCUMENT_DIR/doc/ . If the environment variable ',& ' $PREP_DOCUMENT_DIR is not set the option is ignored. ',& ' ',& ' The --file output can subsequently easily be processed by other utilities ',& ' such as markdown(1) or txt2man(1) to produce man(1) pages and HTML documents.',& ' $SYSTEM commands may follow the $BLOCK block text to optionally post-process ',& ' the doc files. ',& ' ',& ' $ENDBLOCK ends the block. ',& !!!!$! which is preferred; but a blank value or "END" on a $BLOCK directive does as well. ' ',& ' IDENTIFIERS ',& ' Directives for producing metadata ... ',& ' ',& ' $IDENT|$@(#) metadata [--language fortran|c|shell] [! comment ] ',& ' ',& ' $IDENT is a special-purpose directive useful to users of SCCS-metadata. ',& ' The string generated can be used by the what(1) command, ',& ' ',& ' When the command line option "--ident [LANGUAGE]" is specified this directive',& ' writes a line using SCCS-metadata format of one of the following forms: ',& ' ',& ' language: ',& ' fortran character(len=*),parameter::ident="@(#)metadata" ',& ' c #ident "@(#)metadata" ',& ' shell #@(#) metadata ',& ' ',& ' The default language is "fortran". ',& ' ',& ' Depending on your compiler and the optimization level used when compiling, ',& ' the output string may not remain in the object files and executables created.',& ' ',& ' If the -ident switch is not specified, a Fortran comment line is generated ',& ' of the form ',& ' ',& ' ! ident_NNN="@(#)this is metadata" ',& ' ',& ' "$@(#)" is an alias for "$IDENT" so the source file itself will contain ',& ' SCCS-metadata so the metadata can be displayed with what(1) even for the ',& ' unprocessed files. ',& ' ',& ' Do not use the characters double-quote, greater-than, backslash (ie. ">\) ',& ' in the metadata to remain compatible with SCCS metadata syntax. ',& ' Do not use strings starting with " -" either. ',& ' ',& ' INFORMATION ',& ' Informative directives for writing messages to stderr or inserting ',& ' state information into the output file ... ',& ' ',& ' $SHOW [variable_name[;...]] [! comment ] ',& ' $MESSAGE message_to_stderr ',& ' ',& ' Details ... ',& ' ',& ' $MESSAGE message_to_stderr ',& ' ',& ' Write message to stderr. ',& ' Note that messages for $MESSAGE do not treat "! " as starting a comment ',& ' ',& ' $SHOW [variable_name[;...]] [! comment ] ',& ' ',& ' Shows current state of prep(1); including variable names and values and ',& ' the name of the current input files. All output is preceded by an ',& ' exclamation character. ',& ' ',& ' If a list of defined variable names is present only those variables and ',& ' their values are shown. ',& ' ',& ' Basic globbing is supported, where "*" represents any string, and "?" ',& ' represents any single character. ',& ' ',& ' Example: ',& ' ',& ' > prep A=10 B C D -o paper ',& ' > $define z=22 ',& ' > $show B Z ',& ' > $show ',& ' > $show H*;*H;*H*! show beginning with "H", ending with "H", containing "H" ',& ' > $stop 0 ',& ' > ',& ' > ! B = 1 ',& ' > ! Z = 22 ',& ' > !================================================================ ',& ' > ! ',& ' > ! Current state of prep(1):(18:39 20 Jun 2021) ',& ' > ! Total lines read ............... 2 ',& ' > ! Conditional nesting level....... 0 ',& ' > ! G_WRITE (general processing).... T ',& ' > ! G_LLWRITE (write input lines)... T ',& ' > ! Arguments ...................... A=10 B C D -o paper ',& ' > ! Open files: ',& ' > ! unit ! line number ! filename ',& ' > ! 5 ! 2 ! @ ',& ' > ! INCLUDE directories: ',& ' > ! . ',& ' > ! Variables: ',& ' > ! $DEFINE UNKNOWN = 0 ',& ' > ! $DEFINE LINUX = 1 ',& ' > ! $DEFINE MACOS = 2 ',& ' > ! $DEFINE WINDOWS = 3 ',& ' > ! $DEFINE CYGWIN = 4 ',& ' > ! $DEFINE SOLARIS = 5 ',& ' > ! $DEFINE FREEBSD = 6 ',& ' > ! $DEFINE OPENBSD = 7 ',& ' > ! $DEFINE OS = 1 ',& ' > ! $DEFINE A = 10 ',& ' > ! $DEFINE B = 1 ',& ' > ! $DEFINE C = 1 ',& ' > ! $DEFINE D = 1 ',& ' > ! $DEFINE Z = 22 ',& ' > ! Parcels: ',& ' > !================================================================ ',& ' ',& ' SYSTEM COMMANDS ',& ' Directives that execute system commands ... ',& ' ',& ' $SYSTEM system_command ',& ' ',& ' If system command processing is enabled using the --system switch system ',& ' commands can be executed for such tasks as creating files to be read or to ',& ' further process documents created by $BLOCK. $SYSTEM directives are errors ',& ' by default; as you clearly need to ensure the input file is trusted before ',& ' before allowing commands to be executed. Commands that are system-specific ',& ' may need to be executed conditionally as well. ',& ' ',& ' Examples: ',& ' ',& ' > $! build variable definitions using GNU/Linux commands ',& ' > $SYSTEM echo system=`hostname` > compiled.h ',& ' > $SYSTEM echo compile_time="`date`" >> compiled.h ',& ' > $INCLUDE compiled.h ',& ' ',& ' > $if systemon ! if --system switch is present on command line ',& ' > $! obtain up-to-date copy of source file from HTTP server: ',& ' > $ SYSTEM wget http://repository.net/src/func.F90 -O - >_tmp.f90 ',& ' > $ INCLUDE _tmp.f90 ',& ' > $ SYSTEM rm _tmp.f90 ',& ' > $endif ',& ' ',& ' System commands may also appear in a $BLOCK section. Combining several ',& ' features this uses the Linux getconf(1) command to write some lines ',& ' into a scratch file that are then read back in to define variables describing',& ' the current platform. ',& ' ',& ' > $IF OS == LINUX ',& ' > $ ',& ' > $block system ! use getconf(1) command to get system values ',& ' > ( ',& ' > echo LEVEL_2_CACHE_SIZE $(getconf LEVEL2_CACHE_SIZE) ',& ' > echo LEVEL_3_CACHE_SIZE $(getconf LEVEL3_CACHE_SIZE) ',& ' > ) >_getconf.inc ',& ' > $endblock ',& ' > $block set ! read in output of getconf(1) ',& ' > $include _getconf.inc ',& ' > $endblock ',& ' > $system rm -f _getconf.inc ! cleanup ',& ' > $ ',& ' > $ELSE ',& ' > $ ',& ' > $error " ERROR: Not Linux. did not obtain system values" ',& ' > $ ',& ' > $ENDIF ',& ' > $! create code using values for this platform ',& ' > integer, parameter :: L2_CACHE_SZ=${LEVEL2_CACHE_SIZE} ',& ' > integer, parameter :: L3_CACHE_SZ=${LEVEL3_CACHE_SIZE} ',& ' ',& ' PROGRAM TERMINATION ',& ' Directives for stopping file processing (note there is no comment field): ',& ' ',& ' $STOP [stop_value ["message"]] ',& ' $QUIT ["message"] ',& ' $ERROR ["message"] ',& ' ',& ' Details ... ',& ' ',& ' $STOP [stop_value ["message"]] ',& ' ',& ' Stops the prep(1) program. The integer value will be returned as an exit ',& ' status value by the system where supported. ',& ' ',& ' o A value of "0" causes normal program termination. ',& ' o The default value is "1". ',& ' o comments are not supported on these directives; the entire line following ',& ' the directive command becomes part of the message. ',& ' o If a message is supplied it is displayed to stderr. ',& ' If the value is not zero ("0") and no message is supplied the "$SHOW" ',& ' directive is called before stopping. ',& ' o "$QUIT" is an alias for "$STOP 0". ',& ' o "$ERROR" is a synonym for "$STOP 1" ',& ' ',& ' >$IFNDEF TYPE ',& ' >$STOP 10 "ERROR: ""TYPE"" not defined" ',& ' >$ENDIF ',& ' ',& 'LIMITATIONS ',& ' ',& ' $IF constructs can be nested up to 20 levels deep. Note that using ',& ' more than two levels typically makes input files less readable. ',& ' ',& ' $ENDBLOCK is required after a $BLOCK or --file FILENAME is not written. ',& ' ',& ' Nesting of $BLOCK sections not allowed. ',& ' $INCLUDE may be nested fifty (50) levels. ',& ' ',& ' Input files ',& ' ',& ' o lines are limited to a maximum of 1024 columns. Text past the limit is ',& ' ignored. ',& ' o files cannot be concurrently opened multiple times ',& ' o a maximum of 50 files can be nested by $INCLUDE ',& ' o filenames cannot contain spaces on the command line. ',& ' ',& ' Variable names ',& ' ',& ' o are limited to 63 characters. ',& ' o must start with a letter (A-Z) or underscore(_). ',& ' o are composed of the letters A-Z, digits 0-9 and _ and $. ',& ' o 2048 variable names may be defined at a time. ',& ' ',& 'EXAMPLES ',& ' ',& ' Define variables on command line: ',& ' ',& ' Typically, variables are defined on the command line when prep(1) is ',& ' invoked but can be grouped together into small files that are included ',& ' with a $INCLUDE or as input files. ',& ' ',& ' > prep HP size=64 -i hp_directives.dirs test.F90 -o test_out.f90 ',& ' ',& ' defines variables HP and SIZE as if the expressions had been on a ',& ' $DEFINE and reads file "hp_directives.dirs" and then test.F90. ',& ' Output is directed to test_out.f90 ',& ' ',& ' Basic conditionals: ',& ' ',& ' > $! set variable "a" if not specified on the prep(1) command. ',& ' > $IF .NOT.DEFINED(A) ',& ' > $ DEFINE a=1 ! so only define the first version of SUB(3f) below ',& ' > $ENDIF ',& ' > program conditional_compile ',& ' > call sub() ',& ' > end program conditional_compile ',& ' > $! select a version of SUB depending on the value of variable "a" ',& ' > $IF a .EQ. 1 ',& ' > subroutine sub ',& ' > print*, "This is the first SUB" ',& ' > end subroutine sub ',& ' > $ELSEIF a == 2 ',& ' > subroutine sub ',& ' > print*, "This is the second SUB" ',& ' > end subroutine sub ',& ' > $ELSE ',& ' > subroutine sub ',& ' > print*, "This is the third SUB" ',& ' > end subroutine sub ',& ' > $ENDIF ',& ' ',& ' Common use of $BLOCK ',& ' ',& ' > $! ',& ' > $BLOCK NULL --file manual.tex ',& ' > This is a block of text that will be ignored except it is optionally ',& ' > written to a $PREP_DOCUMENT_DIR/doc/ file when $PREP_DOCUMENT_DIR is set. ',& ' > $ENDBLOCK ',& ' > ',& ' ',& ' This is a block of text that will be converted to comments and optionally ',& ' appended to a $PREP_DOCUMENT_DIR/doc/ file when $PREP_DOCUMENT_DIR is set. ',& ' ',& ' > $BLOCK COMMENT--file conditional_compile.man ',& ' > NAME ',& ' > conditional_compile - basic example for prep(1) preprocessor. ',& ' > SYNOPSIS ',& ' > conditional_example [--help] [--version] ',& ' > DESCRIPTION ',& ' > This is a basic example program showing how documentation can be ',& ' > used to generate program help text ',& ' > OPTIONS ',& ' > --help display this help and exit ',& ' > --version output version information and exit ',& ' > $ENDBLOCK ',& ' ',& 'GENERAL TEMPLATING ',& ' A parcel can be posted multiple times, changing the value of variables ',& ' before each post. ',& ' ',& ' > $PARCEL mysub ',& ' > subroutine mysub_${TYPE}(a,b) ',& ' > use, intrinsic :: iso_fortran_env, only : & ',& ' > & real_kinds, real32,real64,real128 ',& ' > implicit none ',& ' > integer,parameter :: wp=${TYPE} ',& ' > real(kind=wp) :: a,b ',& ' > write(*,*)10.0_wp ',& ' > write(*,*) "this is for type ${TYPE}" ',& ' > end subroutine mysub_${TYPE} ',& ' > ',& ' > $ENDPARCEL ',& ' > $set type real32 ',& ' > $post mysub ',& ' > $set type real64 ',& ' > $post mysub ',& ' > $set type real128 ',& ' > $post mysub ',& ' ',& 'NOTE ',& ' Not documented elsewhere, note that there is a developer flag (--debug) that ',& ' can be useful when learning prep(1) usage (but it should not be used in ',& ' production). Among other things it deactivates the termination of the program ',& ' upon detection of an error. This mode thus allows for simple interactive use. ',& ' In addition, when in this mode entering "$HELP" produces a cribsheet, which ',& ' may also be displayed by "prep --crib". ',& 'AUTHOR ',& ' John S. Urban ',& ' ',& 'LICENSE ',& ' MIT ',& ''] version_text=[ CHARACTER(LEN=128) :: & '@(#)PRODUCT: GPF (General Purpose Fortran) utilities and examples>',& '@(#)PROGRAM: prep(1f)>',& '@(#)DESCRIPTION: Fortran Preprocessor>',& !'@(#)VERSION: 4.0.0: 20170502>',& !'@(#)VERSION: 5.0.0: 20201219>',& !'@(#)VERSION: 8.1.1: 20220405>',& !'@(#)VERSION: 9.0.0: 20220804>',& !'@(#)VERSION: 9.1.0: 20220805>',& '@(#)VERSION: 9.2.0: 20220814>',& '@(#)AUTHOR: John S. Urban>',& '@(#)HOME PAGE https://github.com/urbanjost/prep.git/>',& ''] end subroutine setup !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== subroutine crib_help(lun) !@(#)crib_help(3f): prints abridged help information implicit none integer,intent(in) :: lun character(len=:),allocatable :: help_text(:) integer :: i help_text=[ CHARACTER(LEN=128) :: & "EXPRESSIONS ",& " numeric operators are +,-,*,/,**, (). Logical operators are ",& " > | .EQ.| .NE.| .GE.| .GT.| .LE.| .LT.|.NOT.|.AND.| .OR.| .EQV.|.NEQV.| ",& " > | == | /= | >= | > | <= | < | ! | && | || | == | != | ",& " $DEFINE variable_name[=expression][;...] ",& ' > Predefined values are "OS", which is set to a guess of the system type, and',& " > UNKNOWN=0 LINUX=1 MACOS=2 WINDOWS=3 CYGWIN=4 SOLARIS=5 FREEBSD=6 OPENBSD=7.",& " > SYSTEMON is .TRUE. if --system is present on the command line, else .FALSE.",& " $UNDEFINE|$UNDEF variable_name[;...] ",& "CONDITIONAL CODE SELECTION: ",& " $IF logical_integer-based_expression| [.NOT.] DEFINED(varname[,...]) ",& " $IFDEF|$IFNDEF variable_or_envname ",& " $ELSEIF|$ELIF logical_integer-based_expression ",& " $ELSE ",& " $ENDIF ",& "MACRO STRING EXPANSION AND TEXT REPLAY: ",& " > Unless at least one variable name is defined no ${NAME} expansion occurs. ",& " $SET varname string ",& " $$UNSET variable_name[;...] ",& " $IMPORT envname[;...] ",& " > $set author William Shakespeare ",& " > $import HOME ",& " > write(*,*)'${AUTHOR} ${DATE} ${TIME} File ${FILE} Line ${LINE} HOME ${HOME}",& " $PARCEL blockname ... $ENDPARCEL ! a reuseable parcel of expandable text ",& " $POST blockname(s) ! insert a defined parcel of text ",& "EXTERNAL FILES (see $BLOCK ... --file also) ",& " $OUTPUT filename [--append] ",& " $INCLUDE filename ",& "TEXT BLOCK FILTERS (--file writes to $PREP_DOCUMENT_DIR/doc/NAME) ",& " $BLOCK [comment|null|write|variable [--varname NAME]|set|system|message| ",& " define|help|version][--file NAME [--append]] ... $ENDBLOCK ",& "INFORMATION ",& " $MESSAGE message_to_stderr ",& " $SHOW [defined_variable_name][;...] ",& "SYSTEM COMMANDS (see also: $BLOCK SYSTEM) ",& " $SYSTEM command ",& " $STOP [stop_value[ ""message""]] | $QUIT [""message""]| $ERROR [""message""] "] WRITE(lun,'(a)')(trim(help_text(i)),i=1,size(help_text)) end subroutine crib_help !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== subroutine write_out(line) !@(#)writeout(3f): write (most) source code lines to output file character(len=*),intent(in) :: line integer :: istart if(G_verbose)then ! echo "what" lines to stderr istart=index(line,'@(#)') if(istart /= 0)then call write_err( '+ -->>'//trim(line(istart+4:)) ) endif endif call www(line) end subroutine write_out !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== subroutine www(line) !@(#)www(3f): change line into a WRITE, HELP/VERSION, COMMENT output line integer,parameter :: linewidth=128 character(len=*),intent(in) :: line character(len=:),allocatable :: buff character(len=115) :: chunk integer :: ilength integer :: ios integer :: ierr character(len=256) :: message character(len=G_var_len) :: value ierr=0 select case(trim(G_outtype)) case('comment') ! write as a Fortran comment preceded by two explanations and a space ! will be written later at end of BLOCK section case('null') ! do not write case('set','replace') ! do not write call set(line) case('define') ! do not write call expr(nospace(upper(line)),value,ierr,def=.true.) ! only process DEFINE if not skipping data lines case('redefine') ! do not write call expr(nospace(upper(line)),value,ierr,def=.true.) ! only process DEFINE if not skipping data lines case('message') ! do not write call write_err(line) ! trustingly trim MESSAGE from directive case('system') write(G_scratch_lun,'(a)',iostat=ios,iomsg=message)trim(line) if(ios < 0)then call stop_prep(033,'failed to write to process:',trim(line)//':'//trim(message)) endif case('variable') buff=trim(line) ! do not make a line over 132 characters. Trim input line if needed buff=buff//repeat(' ',max(linewidth,len(buff))) ! ensure space in buffer for substitute call substitute(buff,"'","''") ! change single quotes in input to two adjacent single quotes ilength=min(len_trim(buff),linewidth) ! make all lines have at least linewidth characters for a more legible output G_varname_width=max(G_varname_width,ilength) write(G_iout,'("''",a,"'',&")') pad(buff(:ilength),G_varname_width,right=.true.) case('help') buff=trim(line) ! do not make a line over 132 characters. Trim input line if needed buff=buff//repeat(' ',max(linewidth,len(buff))) ! ensure space in buffer for substitute call substitute(buff,"'","''") ! change single quotes in input to two adjacent single quotes ilength=max(80,min(len_trim(buff),linewidth)) ! make all lines have at least 80 characters for a more legible output write(G_iout,'("''",a,"'',&")') buff(:ilength) case('version') ! write version information with SCCS ID prefix for use with what(1) command write(G_iout,'("''@(#)",a,"'',&")')trim(line(:min(len_trim(line),128-1)))//'>' !x! should handle longer lines and split them case('write') ! convert string to a Fortran write statement to unit "IO" buff=trim(line) ! do not make a line over 132 characters. Trim input line if needed buff=buff//repeat(' ',max(linewidth,len(buff))) ! ensure space in buffer for substitute call substitute(buff,"'","''") write(G_iout,'(a)',advance='no')'write(io,''(a)'')''' chunk=buff write(G_iout,'(a)',advance='no')trim(chunk) write(G_iout,'(a)')'''' case('','asis') write(G_iout,'(a)')trim(line(:min(len(line),G_iwidth))) case default call stop_prep(034,'unexpected "BLOCK" value. Found:',trim(G_source)) call stop_prep(035,'unexpected "BLOCK" value. Found:',trim(G_outtype)) end select if(ierr /= 0) call stop_prep(036,'expression invalid:',trim(G_source)) if(G_MAN_COLLECT)then G_MAN=G_MAN//new_line('N')//trim(line) endif G_comment_count=G_comment_count+1 end subroutine www !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== subroutine write_err(msg) !@(#)M_verify::write_err(3f): writes a message to standard error using a standard f2003 method character(len=*),intent(in) :: msg integer :: ios write(stderr,'(a)',iostat=ios) trim(msg) call flushit() end subroutine write_err !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== subroutine dissect2(verb,init,pars) !@(#)dissect2(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 !call dissect(verb,init,pars,len(pars),error_return) call set_args(init,string=pars//'--') !call print_dictionary() end subroutine dissect2 !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== subroutine import(line) character(len=*),intent(in) :: line character(len=:),allocatable :: names(:) integer :: i names=sep(line,' ,;') do i=1,size(names) call set(names(i)//' '//get_env(names(i))) enddo end subroutine import !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== subroutine set(line) character(len=*),intent(in) :: line character(len=:),allocatable :: temp character(len=:),allocatable :: name character(len=:),allocatable :: val integer :: iend ! create a dictionary with character keywords, values, and value lengths ! using the routines for maintaining a list temp=adjustl(line) iend=merge(len(temp),index(temp,' '),index(temp,' ') == 0) name=adjustl(upper(temp(:iend))) if(name /= '')then if(len(temp) > iend)then val=temp(min(iend+1,len(temp)):) call check_name(name) if(val == ' ')val='1' call macro%set(name,val) ! insert and replace entries else endif else call stop_prep(037,'incomplete set:',trim(G_SOURCE)) endif end subroutine set !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== subroutine expand_variables(line) !@(#) brute force variable substitution. maybe add something like wordexp(3c) with command expansion only if --system? ! this is just to try the concept. Either use wordexp or an equivalent to replicate "here document" processing. ! note no automatic continuation of the line if it extends past allowed length, which for Fortran is currently 132 for free-format ! the way this is written it would do recursive substitution and does not know when there is just not a match character(len=*) :: line character(len=:),allocatable :: temp,search integer :: i integer :: j integer :: ibug character(len=4096) :: scratch if(index(line,'${') /= 0)then write(scratch,'(i0)')G_file_dictionary(G_iocount)%line_number call set('LINE ' // scratch) call set('FILE ' // G_file_dictionary(G_iocount)%filename ) call set('TIME ' // getdate('time')) call set('DATE ' // getdate('cdate')) call set('PROCEDURE ' // 'PROCNAME') temp=trim(line) ibug=minval([size(macro%key),ubound(macro%key)]) ! print variable dictionary INFINITE: do i=1,len_trim(line) do j=1,ibug if(index(temp,'${') /= 0)then search='${'//trim(macro%key(j))//'}' temp=str_replace(temp,search,macro%value(j)(:macro%count(j)),ignorecase=.true.) else exit INFINITE endif enddo enddo INFINITE line=temp endif end subroutine expand_variables !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> Determine the OS type by guessing subroutine get_os_type() !! !! At first, the environment variable `OS` is checked, which is usually !! found on Windows. Then, `OSTYPE` is read in and compared with common !! names. If this fails too, check the existence of files that can be !! found on specific system types only. !! !! Returns OS_UNKNOWN if the operating system cannot be determined. !! !! calling POSIX or C routines would be far better, M_system::like system_uname(3f) !! but trying to use portable Fortran. If assume compiled by certain compilers could !! use their extensions as well. Most have a uname(3f) function. !! integer, parameter :: OS_UNKNOWN = 0 integer, parameter :: OS_LINUX = 1 integer, parameter :: OS_MACOS = 2 integer, parameter :: OS_WINDOWS = 3 integer, parameter :: OS_CYGWIN = 4 integer, parameter :: OS_SOLARIS = 5 integer, parameter :: OS_FREEBSD = 6 integer, parameter :: OS_OPENBSD = 7 character(len=G_var_len) :: val integer :: r logical :: file_exists character(len=80) :: scratch call put( 'UNKNOWN=0' ) call put( 'LINUX=1' ) call put( 'MACOS=2' ) call put( 'WINDOWS=3' ) call put( 'CYGWIN=4' ) call put( 'SOLARIS=5' ) call put( 'FREEBSD=6' ) call put( 'OPENBSD=7' ) r = OS_UNKNOWN ! Check environment variable `OS`. val=get_env('OS') if ( index(val, 'Windows_NT') > 0) then r = OS_WINDOWS else ! Check environment variable `OSTYPE`. val=get_env('OSTYPE') if (val /= '') then if (index(val, 'linux') > 0) then ! Linux r = OS_LINUX elseif (index(val, 'darwin') > 0) then ! macOS r = OS_MACOS elseif (index(val, 'win') > 0 .or. index(val, 'msys') > 0) then ! Windows, MSYS, MinGW, Git Bash r = OS_WINDOWS elseif (index(val, 'cygwin') > 0) then ! Cygwin r = OS_CYGWIN elseif (index(val, 'SunOS') > 0 .or. index(val, 'solaris') > 0) then ! Solaris, OpenIndiana, ... r = OS_SOLARIS elseif (index(val, 'FreeBSD') > 0 .or. index(val, 'freebsd') > 0) then ! FreeBSD r = OS_FREEBSD elseif (index(val, 'OpenBSD') > 0 .or. index(val, 'openbsd') > 0) then ! OpenBSD r = OS_OPENBSD endif endif endif if(r == OS_UNKNOWN)then inquire (file='/etc/os-release', exist=file_exists) ! Linux if (file_exists) r = OS_LINUX inquire (file='/usr/bin/sw_vers', exist=file_exists) ! macOS if (file_exists) r = OS_MACOS inquire (file='/bin/freebsd-version', exist=file_exists) ! FreeBSD if (file_exists) r = OS_FREEBSD endif scratch=' ' write(scratch,'("OS=",i0)')r call put(scratch) end subroutine get_os_type !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== pure function ends_in(string) result(ending) character(*), intent(in) :: string character(:), allocatable :: ending integer :: n1 n1=index(string,'.',back=.true.) if (n1 < 1 .or. n1 == len(string) ) then ending='' else ending=string(n1+1:) endif end function ends_in !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== subroutine flushit() integer :: ios flush(unit=stdout,iostat=ios) flush(unit=stderr,iostat=ios) end subroutine flushit !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== subroutine put(opts) !@(#)expr_short(3f): call expr with just an expression character(len=*),intent(in) :: opts character(len=G_var_len) :: value integer :: ierr character(len=G_line_length) :: expression expression=upper(opts) call expr(expression,value,ierr,def=.true.) if(ierr /= 0) call stop_prep(038,'expression invalid:',trim(G_source)) end subroutine put end module M_prep !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== program prep !@(#)prep(1f): preprocessor for Fortran/Fortran source code use M_CLI2, only : set_args, lget, rget, iget, SGET !JSU kracken_comment use M_strings, only : notabs, isdigit, switch, sep use M_io, only : getname, basename use M_prep implicit none character(len=G_line_length) :: out_filename='' ! output filename, default is stdout character(len=1) :: prefix ! directive prefix character character(len=1) :: letterd ! character(len=G_line_length) :: line ! working copy of input line logical :: keeptabs=.false. ! flag whether to retain tabs and carriage returns or not integer :: ilast integer :: ios character(len=:),allocatable :: help_text(:) character(len=:),allocatable :: version_text(:) character(len=:),allocatable :: string character(len=:),allocatable :: cmd logical :: isscratch cmd='& & -i " " & & -D " " & & -I " " & & -o " " & & --prefix 36 & & --keeptabs .false. & & -d ignore & & --help .false. & & --verbose .false. & & --system .false. & & --version .false. & & --crib .false. & & --debug .false. & & --noenv .false. & & --comment "'//get_env('PREP_COMMENT_STYLE','default')//'" & & --ident .false. & & --width 1024 & & --start " " & & --stop " " & & --type auto & & --lang "'//get_env('PREP_LANGUAGE','en')//'" & & ' ! allow formatting comments for particular post-processors G_comment='! ' !JSUkracken_comment=G_comment call setup(help_text,version_text) call set_args(cmd,help_text,version_text) ! define command arguments, default values and crack command line ! cpp>========================================================================= ! decide whether to act like cpp or not if(specified('i').or.size(unnamed) > 2)then G_cpp=.false. else if(size(unnamed) > 0)then if(exists(unnamed(1)))then G_cpp=.true. else G_cpp=.false. endif else G_cpp=.true. endif endif ! cpp<========================================================================= string=adjustl(trim(SGET('prefix'))) if ( all( isdigit(switch(string)) ) ) then ! if all characters are numeric digits prefix = char(iget('prefix')) ! assume this is an ADE else prefix(1:1) = trim(SGET('prefix')) ! not a digit so not an ADE so assume a literal character endif G_inc_files=' ' G_lang=sget('lang') ! preferred message language G_ident=lget('ident') ! write IDENT as comment or CHARACTER variable G_iwidth = iget('width') G_iwidth=max(0,G_iwidth) letterd(1:1) = trim(SGET('d')) G_noenv = lget('noenv') out_filename(:G_line_length) = SGET('o') if(G_cpp .and. out_filename == '' )then if(size(unnamed) == 2) out_filename=unnamed(2) endif if(out_filename == '')then ! open output file G_iout=stdout elseif(out_filename == '@')then G_iout=stdout G_IHELP=stdout else G_iout=60 G_IHELP=60 open(unit=60,file=out_filename,iostat=ios,action='write') if(ios /= 0)then call stop_prep(039,'failed to open output file:',trim(out_filename)) endif endif G_iout_init=G_iout if(lget('crib'))then call crib_help(stdout) stop endif G_debug=lget('debug') ! turn on debug mode for developer keeptabs=lget('keeptabs') G_verbose=lget('verbose') ! set flag for special mode where lines with @(#) are written to stderr if(G_verbose)then call write_err('+ verbose mode on ') endif G_comment_style=lower(SGET('comment')) ! allow formatting comments for particular post-processors G_system_on = lget('system') ! allow system commands on $SYSTEM directives if(G_system_on)then call put('SYSTEMON=.TRUE.') else call put('SYSTEMON=.FALSE.') endif G_extract_start0='' G_extract_stop0='' if(sget('type').eq.'')then G_extract_auto=.true. ! auto mode where start and end are selected based on file suffix G_extract=.false. ! if these are set use them instead of auto mode G_extract_start=trim(SGET('start')) G_extract_stop=trim(SGET('stop')) G_extract_start0=G_extract_start G_extract_stop0=G_extract_stop else G_extract_auto=.false. G_extract=.true. select case(SGET('type')) case('md','.md') G_extract_start='```fortran' G_extract_stop='```' case('markdownMML','.markdownMML','MML','.MML','mml','.mml') G_extract_start='^ *~~~~* *{: *lang=fortran *}[ ~]*$' G_extract_stop='^ *~~~~* *$' case('html','.html','htm','.htm') ! flaw is HTML is not case sensitive G_extract_start=' *<[xX][mM][pP]>' G_extract_stop=' *' case('tex') G_extract_start='\begin{minted}{Fortran}' G_extract_stop='\end{minted}' case('auto') G_extract_start='' G_extract_stop='' G_extract_auto=.true. case('none') G_extract_start='' G_extract_stop='' G_extract=.false. case default call stop_prep(100,'unknown type:',sget('type')) end select endif if(G_extract_start /= ''.or.G_extract_stop /= '')then G_extract=.true. if (getpat(trim(G_extract_start), G_pattern_start%pat) .eq. ERR) then stop '*M_match* Illegal pattern '//G_extract_start endif if (getpat(trim(G_extract_stop), G_pattern_stop%pat) .eq. ERR) then stop '*M_match* Illegal pattern '//G_extract_stop endif endif call get_os_type() !cpp>============================================================================== call defines() ! define named variables declared on the command line !============================================================================== call opens() ! convert input filenames into $include directives ! 0))then close(G_file_dictionary(G_iocount)%unit_number,iostat=ios) elseif(isscratch.or.(G_file_dictionary(G_iocount)%unit_number < -1))then rewind(unit=G_file_dictionary(G_iocount)%unit_number,iostat=ios) endif endif G_iocount=G_iocount-1 if(G_scratch_lun /= -1)then ios=filedelete(G_scratch_file//'.out') G_scratch_lun=-1 endif if(G_iocount < 1)exit call auto() ! if in auto mode determine strings for new file enddo READLINE if (G_nestl /= 0) then ! check to make sure all if blocks are closed call stop_prep(040,'block not closed in',' $IF') endif call print_comment_block() contains subroutine auto() if(G_extract_auto)then select case(ends_in(G_file_dictionary(G_iocount)%filename) ) case('md','.md') G_extract_start='```fortran' G_extract_stop='```' case('markdownMML','.markdownMML','MML','mml') G_extract_start='^ *~~~~* *{: *lang=fortran *}[ ~]*$' !NOT WORKING G_extract_start='^ *[~`][~`][~`][~`]* *{: *lang=fortran *} *[~`]* *' G_extract_stop='^ *~~~~* *$' !NOT WORKING G_extract_stop='^ *[~`][~`][~`][~`]* *$' case('tex') G_extract_start='\begin{minted}{Fortran}' G_extract_stop='\end{minted}' case('html','.html','htm','.htm') G_extract_start=' *<[xX][mM][pP]>' G_extract_stop=' *' case default G_extract_start=G_extract_start0 G_extract_stop=G_extract_stop0 end select if(G_extract_start == ''.and.G_extract_stop == '')then G_extract=.false. else G_extract=.true. if (getpat(trim(G_extract_start), G_pattern_start%pat) .eq. ERR) then stop '*M_match* Illegal pattern '//G_extract_start endif if (getpat(trim(G_extract_stop), G_pattern_stop%pat) .eq. ERR) then stop '*M_match* Illegal pattern '//G_extract_stop endif endif endif end subroutine auto logical function exists(filename) result(r) character(len=*), intent(in) :: filename inquire(file=filename, exist=r) end function !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== end program prep !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !===================================================================================================================================