mod_sng Module Reference

Data Types
interface	ftn_arg_get

Functions/Subroutines
integer function	ftn_strlen (sng)
integer function	ftn_opt_lng_get (sng)
subroutine	ftn_getarg_wrp (arg_idx, arg_val)
subroutine	ftn_getarg_err (arg_idx, arg_val)
integer function	ftn_strstr (sng1, sng2)
subroutine	ftn_strini (sng)
subroutine	ftn_strnul (sng)
integer function	ftn_strlsc (sng)
integer function	ftn_strfic (sng)
subroutine	ftn_strprn (sng)
subroutine	ftn_strcpy (sng1, sng2)
integer function	ftn_strcmp (sng1, sng2)
subroutine	ftn_strcpylsc (sng1, sng2)
subroutine	ftn_strcat (sng1, sng2)
subroutine	ftn_strpfx (sng1, sng2)
subroutine	ftn_drcpfx (drc, fl_nm)
subroutine	ftn_prg_id_mk (CVS_Id, CVS_Revision, CVS_Date, prg_ID)
subroutine	ftn_cmd_ln_sng (cmd_ln)
character(len=10) function	ftn_date2sng (idate)
character(len=8) function	ftn_sec2sng (isec)

Function/Subroutine Documentation

ftn_cmd_ln_sng()

subroutine mod_sng::ftn_cmd_ln_sng

(

character(len=*), intent(out)

cmd_ln

)

Definition at line 1152 of file mod_sng.f90.

    ! Purpose: Return a copy of command-line and initialize program name
    ! See http://www.winteracter.com/f2kcli/index.htm for alternatives
    ! Usage:
    ! call ftn_cmd_ln_sng(cmd_ln) ! [sng] command-line
    use mod_utils ! [mdl] Debugging constants, prg_nm, dbg_lvl
    implicit none
    ! Commons
    ! Output
    character(len=*),intent(out)::cmd_ln ! O [sng] command-line
    ! Local
    character(len=80) arg_val         ! [sng] command-line argument value
    integer arg_idx           ! [idx] Counting index
    integer arg_nbr           ! [nbr] Number of command-line arguments
    integer cmd_ln_len        ! [nbr] Length of command-line
    integer cmd_ln_lng        ! [nbr] Length of command-line
    ! Main Code
    ! Initialize defaults
    call ftn_strini(cmd_ln) ! [sng] sng(1:len)=NUL
    call ftn_strini(prg_nm) ! [sng] sng(1:len)=NUL
    cmd_ln_len=len(cmd_ln)  ! [nbr] Length of command-line
    cmd_ln_lng=0            ! [nbr] Length of command-line CEWI
    
    arg_nbr=command_argument_count() ! [nbr] Number of command-line arguments
    if (dbg_lvl >= dbg_vec) then
       write (6,'(a,i2)') 'ftn_cmd_ln_sng(): arg_nbr = ',arg_nbr
    endif                     ! endif dbg
    
    ! Loop over arguments
    do arg_idx=0,arg_nbr      ! NB: Loop starts with 0
       ! Argument 0 is program name
       ! if (arg_idx > 0) call ftn_strcat(cmd_ln,' ')
       ! Insert space between arguments
       if (arg_idx > 0) cmd_ln(cmd_ln_lng+1:cmd_ln_lng+1)=' '
       call ftn_strini(arg_val) ! [sng] sng(1:len)=NUL
       call get_command_argument(arg_idx,arg_val)
       call ftn_strnul(arg_val) ! [sbr] NUL-initialize all characters after LSC
       call ftn_strcat(cmd_ln,arg_val)
       if (arg_idx == 0) call ftn_strcpy(prg_nm,arg_val) ! [sng] Program name
       cmd_ln_lng=ftn_strlen(cmd_ln) ! [nbr] Length of string
       if (cmd_ln_lng > cmd_ln_len) stop 'cmd_ln_lng > cmd_ln_len in ftn_cmd_ln_sng()'
       if (dbg_lvl >= dbg_vrb) then
          write (6,'(a,i3)') 'arg_idx = ',arg_idx
          write (6,'(a,a)') 'arg_val = ',arg_val
          write (6,'(a,i3)') 'len(arg_val) = ',len(arg_val)
          write (6,'(a,i3)') 'ftn_strlen(arg_val) = ',ftn_strlen(arg_val)
          write (6,'(a,i3)') 'ftn_strlen(cmd_ln) = ',ftn_strlen(cmd_ln)
          write (6,'(a,a)') 'cmd_ln = ',cmd_ln
       endif                  ! endif dbg
    end do                     ! end loop over arg
    
    if (dbg_lvl >= dbg_io) write (6,'(a,a)') 'cmd_ln = ',cmd_ln(1:ftn_strlen(cmd_ln))
    return

Here is the call graph for this function:

Here is the caller graph for this function:

ftn_date2sng()

character(len=10) function mod_sng::ftn_date2sng

(

integer, intent(in)

idate

)

Definition at line 1207 of file mod_sng.f90.

    ! Purpose: Convert integer date in YYYYMMDD to a character array in the form
    ! 'YYYY-MM-DD'
    ! Author: Brian Eaton charutl.F:idate2char()
    ! Recoded: 19990901 Charlie Zender
    ! Usage:
    ! character(len=10) ftn_date2sng   ! [sng] Convert YYYYMMDD integer to YYYY-MM-DD string
    implicit none
    ! Input
    integer,intent(in)::idate
    ! Local
    integer yy 
    integer mm
    integer dd
    character dash
    ! Main code
    dash='-'
    ! Extract year, month, and day from date
    yy=idate/10000
    mm=mod(abs(idate),10000)/100
    dd=mod(abs(idate),100)
    write(ftn_date2sng,'(i4.4,a1,i2.2,a1,i2.2)') yy,dash,mm,dash,dd
    return

ftn_drcpfx()

subroutine mod_sng::ftn_drcpfx	(	character(len=*), intent(in)	drc,
		character(len=*), intent(inout)	fl_nm
	)

Definition at line 1021 of file mod_sng.f90.

    ! Purpose: fl_nm := drc/fl_nm, more or less
    ! Differences with ftn_strpfx(): 
    ! 1. Result is stored in second string not first string
    ! 2. Strings are trimmed before concatenation
    ! 3. Filenames containing slashes are unaltered
    ! Usage:
    ! call ftn_drcpfx(drc,fl_nm) ! [sbr] fl_nm := drc/fl_nm
    use mod_utils ! [mdl] Debugging constants, prg_nm, dbg_lvl
    implicit none
    ! Commons
    ! Input
    character(len=*),intent(in)::drc ! I [sng] Directory to prepend
    ! Input/Output
    character(len=*),intent(inout)::fl_nm ! I/O [sbr] File name
    ! Local
    integer len_drc
    integer len_fl
    integer lng_drc
    integer lng_fl
    ! Main Code
    len_drc=len(drc)
    len_fl=len(fl_nm)
    lng_drc=ftn_strlen(drc) ! [nbr] Length of string
    lng_fl=ftn_strlen(fl_nm) ! [nbr] Length of string
    if (lng_drc+lng_fl >= len_fl) then
       write (6,'(a,a)') prg_nm(1:ftn_strlen(prg_nm)),': ERROR lng_drc+lng_fl >= len_fl in ftn_drcpfx()'
       write (6,'(2(a,i3),2a)') 'len_drc = ',len_drc,', lng_drc = ',lng_drc,', drc = ',drc
       write (6,'(2(a,i3),2a)') 'len_fl = ',len_fl,', lng_fl = ',lng_fl,', fl_nm = ',fl_nm
       call ftn_strprn(drc)
       call ftn_strprn(fl_nm)
       stop 'EXIT_FAILURE from ftn_drcpfx()'
    endif                     ! endif
    
    if ( &                     ! Conditions for prepending fl_nm with drc:
         lng_drc > 0 .and. &   ! Directory must be non-NUL 
         ftn_strstr(fl_nm,'/') == -1 & ! fl_nm does not look like directory itself
         ) then
       ! If directory does not have trailing slash...
       if (drc(lng_drc:lng_drc) /= '/') then ! Directory does not have trailing slash
          ! ...and if room exists for one...
          if (lng_drc+lng_fl+1 < len_fl) then
             ! ...then add one
             ! Order is important
             fl_nm(lng_drc+2:lng_drc+2+lng_fl)=fl_nm(1:lng_fl)
             fl_nm(1:lng_drc)=drc(1:lng_drc)
             fl_nm(lng_drc+1:lng_drc+1)='/'
          endif               ! endif adding trailing slash
       else                   ! Directory does have trailing slash
          fl_nm(lng_drc+1:lng_drc+1+lng_fl)=fl_nm(1:lng_fl)
          fl_nm(1:lng_drc)=drc(1:lng_drc)
       endif                  ! Directory does have trailing slash
    endif                     ! endif prepending drc
    call ftn_strnul(fl_nm) ! [sbr] NUL-initialize all characters after LSC
    
    return

Here is the call graph for this function:

ftn_getarg_err()

subroutine mod_sng::ftn_getarg_err	(	integer, intent(inout)	arg_idx,
		character(len=*), intent(inout)	arg_val
	)

Definition at line 184 of file mod_sng.f90.

    ! Purpose: Handle option-not-found errors for getopt()
    ! Routine assumes arg_idx points to arg_val
    ! Typically arg_idx is advanced before option recognition is attempted,
    ! thus arg_idx may need to be decremented before ftn_getarg_err() is called
    ! Usage:
    ! call ftn_getarg_err(arg_idx,arg_val) ! [sbr] Error handler for getarg()
    use mod_utils ! [mdl] Debugging constants, prg_nm, dbg_lvl
    implicit none
    ! Commons
    ! Input
    ! Input/Output
    integer,intent(inout)::arg_idx ! I/O [idx] Argument counter 
    character(len=*),intent(inout)::arg_val ! I/O [sng] String to copy into opt_val
    ! Output
    ! Local
    integer arg_nbr           ! [nbr] Number of command-line arguments
    ! integer exit_status       ! [enm] Program exit status (non-standard Fortran)
    ! Main Code
    arg_nbr=command_argument_count() ! [nbr] Number of command-line arguments
    write (6,'(2a)') prg_nm(1:ftn_strlsc(prg_nm)),': ERROR Option not recognized'
    write (6,'(2a)') prg_nm(1:ftn_strlsc(prg_nm)),': HINT Option syntax is nearly POSIX/GNU compliant:'
    write (6,'(2a)') prg_nm(1:ftn_strlsc(prg_nm)), &
         ': Short option syntax is dash-key-space-value, e.g., -D 2'
    write (6,'(3a)') prg_nm(1:ftn_strlsc(prg_nm)), &
         ': Long option syntax is dash-dash-key-space-value, e.g., --dbg 2', &
         ', or dash-dash-key-equal-value, e.g., --dbg=2 (preferred)'
    ! Subtract 1 from arg_idx because rule is that arg_idx is incremented before option recognition is attempted
    write (6,'(2a,i2,2a)') prg_nm(1:ftn_strlsc(prg_nm)),   &
         ': DEBUG ftn_getarg_err() reports arg_idx = ',arg_idx,', arg_val = ',arg_val(1:len_trim(arg_val))
    if (arg_idx+1 <= arg_nbr) then
       arg_idx=arg_idx+1      ! [idx] Counting index
       call get_command_argument(arg_idx,arg_val)
       write (6,'(2a,i2,2a)') prg_nm(1:ftn_strlsc(prg_nm)), &
            ': DEBUG Next argument value is arg_val(',arg_idx,') = ',arg_val
    else
       write (6,'(2a)') prg_nm(1:ftn_strlsc(prg_nm)), &
            ': DEBUG No arguments follow this one'
    endif                     ! endif not last argument
    ! exit_status=-1            ! [enm] Program exit status (non-standard Fortran)
    ! call exit(exit_status)    ! [enm] Exit with current exit status (non-standard Fortran)
    stop 'Exit on error from ftn_getarg_err()'
    return

Here is the call graph for this function:

Here is the caller graph for this function:

ftn_getarg_wrp()

subroutine mod_sng::ftn_getarg_wrp	(	integer, intent(inout)	arg_idx,
		character(len=*), intent(inout)	arg_val
	)

Definition at line 159 of file mod_sng.f90.

    ! Purpose: Wrapper for getarg() intrinsic that increments argument counter
    ! Argument index is incremented after getarg() is called
    ! Usage:
    ! call ftn_getarg_wrp(arg_idx,arg_val) ! [sbr] Call getarg() and increment arg_idx
    use mod_utils ! [mdl] Debugging constants, prg_nm, dbg_lvl
    implicit none
    ! Commons
    ! Input
    ! Input/Output
    integer,intent(inout)::arg_idx ! I/O [idx] Argument counter 
    character(len=*),intent(inout)::arg_val ! I/O [sng] String to copy into opt_val
    ! Output
    ! Local
    ! Main Code
    call get_command_argument(arg_idx,arg_val)
    if (dbg_lvl >= dbg_io) write (6,'(2a,i2,2a)') prg_nm(1:ftn_strlsc(prg_nm)),   &
         ': DEBUG ftn_getarg_wrp() reports arg_idx = ',arg_idx,', arg_val = ',arg_val(1:len_trim(arg_val))
    ! Increment counter for next read
    arg_idx=arg_idx+1
    return

Here is the call graph for this function:

Here is the caller graph for this function:

ftn_opt_lng_get()

integer function mod_sng::ftn_opt_lng_get

(

character(len=*), intent(in)

sng

)

Definition at line 118 of file mod_sng.f90.

    ! Purpose: Return length of option string preceding space or equals character
    ! Any preceding dashes are NOT counted towards option length
    ! Fortran intrinsic len(sng) is returned if string is not NUL-terminated
    ! Prototype:
    ! integer ftn_opt_lng_get ! [nbr] Length of option
    ! Usage:
    ! Call ftn_opt_lng_get with the full option string, e.g.,
    ! ftn_opt_lng_get('--dbg_lvl=5') and ftn_opt_lng_get will return the
    ! length of the option string 
    ! opt_sng=arg_val(3:2+ftn_opt_lng_get(arg_val)) ! [sng] Option string
    ! if (opt_sng == 'dbg') then ...
    implicit none
    ! Input
    character(len=*),intent(in)::sng
    ! Local
    integer idx
    integer len_sng
    integer::dsh_nbr=0        ! [nbr] Number of dashes
    ! Main Code
    ! Length of option string is one less than position of first space or equal sign
    len_sng=len(sng)
    if (len_sng >= 1) then
       if (sng(1:1) == '-') dsh_nbr=1 ! [nbr] Number of dashes
    endif
    if (len_sng >= 2) then
       if (sng(1:2) == '--') dsh_nbr=2 ! [nbr] Number of dashes
    endif
    do idx=1,len_sng
       ! Look for first abnormal character
       if (sng(idx:idx) == ' ' .or. sng(idx:idx) == '=') goto 100
    end do                    ! end loop over characters
100 continue
    ftn_opt_lng_get=idx-1-dsh_nbr
    ! Strings initialized to '' should have length 0
    if (ftn_opt_lng_get < 0 .or. sng == '') ftn_opt_lng_get=0
    return

Here is the caller graph for this function:

ftn_prg_id_mk()

subroutine mod_sng::ftn_prg_id_mk	(	character(len=*), intent(in)	CVS_Id,
		character(len=*), intent(in)	CVS_Revision,
		character(len=*), intent(in)	CVS_Date,
		character(len=*), intent(out)	prg_ID
	)

Definition at line 1079 of file mod_sng.f90.

    ! Purpose: Create identity string from CVS input
    use mod_utils ! [mdl] Debugging constants, prg_nm, dbg_lvl
    implicit none
    ! Commons
    ! Parameter
    integer,parameter::CVS_kk=0
    integer,parameter::CVS_kv=1
    integer,parameter::CVS_kkv=2
    ! Input
    character(len=*),intent(in)::CVS_Id
    character(len=*),intent(in)::CVS_Revision
    character(len=*),intent(in)::CVS_Date
    ! Output
    character(len=*),intent(out)::prg_ID
    ! Local
    integer CVS_typ
    integer Date_ptr
    integer slash_ptr
    integer prg_ptr
    integer vrs_ptr
    ! Main Code
    ! Decide how CVS keywords were expanded
    date_ptr=ftn_strstr(cvs_date,'Date')
    if (date_ptr < 0) then
       ! String 'Date' was not found---CVS expansion must be -kv
       cvs_typ=cvs_kv
    else
       ! String 'Date' was found---CVS expansion is -kk or -kkv
       slash_ptr=ftn_strstr(cvs_date,'/')
       if (slash_ptr > 0) then 
          cvs_typ=cvs_kkv 
       else 
          cvs_typ=cvs_kk
       endif                  ! endif
    endif                     ! endif
    
    if (.false.) then
       write (6,'(a,a)') prg_nm(1:ftn_strlen(prg_nm)),': DEBUG ftn_prg_ID_mk() reports CVS strings:'
       write (6,'(a,a)') 'CVS_Id: ',cvs_id
       write (6,'(a,a)') 'CVS_Revision: ',cvs_revision
       write (6,'(a,a)') 'CVS_Date: ',cvs_date
       write (6,'(a,i1)') 'CVS_typ: ',cvs_typ
       write (6,'(a,i2)') 'Date_ptr: ',date_ptr
       write (6,'(a,i2)') 'slash_ptr: ',slash_ptr
    endif
    
    ! CVS_Revision and CVS_Date are parameters---do not attempt to write them
    !  call ftn_strnul(CVS_Revision) ! [sbr] NUL-initialize all characters after LSC
    !  call ftn_strnul(CVS_Date) ! [sbr] NUL-initialize all characters after LSC
    call ftn_strini(prg_id) ! [sng] sng(1:len)=NUL
    if (cvs_typ == cvs_kk) then
       prg_id='Source file unknown Version unknown Date unknown' // char(0)
    else 
       prg_ptr=ftn_strstr(cvs_id,',v') ! ',v' is right after program name
       if (prg_ptr < 0) stop 'ERROR: ftn_prg_ID_mk() unable to find source code name'
       if (cvs_typ == cvs_kv) then
          prg_id=cvs_id(1:prg_ptr-1) //  &
               ' version ' // cvs_revision(1:ftn_strlen(cvs_revision)) //  &
               ' dated ' // cvs_date(1:ftn_strlen(cvs_date)) // ' GMT' // char(0)
       else if (cvs_typ == cvs_kkv) then
          vrs_ptr=ftn_strstr(cvs_revision,'ion:') ! 'ion:' should appear two characters before version
          if (vrs_ptr < 0) stop 'ERROR: ftn_prg_ID_mk() unable to find revision number'
          prg_id=cvs_id(6:prg_ptr-1) //  &
               ' version ' // cvs_revision(vrs_ptr+5:ftn_strlen(cvs_revision)-2) //  &
               ' dated ' // cvs_date(8:26) // ' GMT' // char(0)
       else 
          write (6,'(a,a)') prg_nm(1:ftn_strlen(prg_nm)),': ERROR ftn_prg_ID_mk() reports unknown CVS_typ'
       endif                  ! endif
    endif                     ! endif
    return

Here is the call graph for this function:

Here is the caller graph for this function:

ftn_sec2sng()

character(len=8) function mod_sng::ftn_sec2sng

(

integer, intent(in)

isec

)

Definition at line 1232 of file mod_sng.f90.

    ! Purpose: Convert integer seconds to a character array in the form 'HH:MM:SS'
    ! Author: Brian Eaton charutl.F:isec2char()
    ! Recoded: 19990901 Charlie Zender
    ! character(len=8) ftn_sec2sng   ! [sng] Convert integer to 'HH:MM:SS' string
    implicit none
    ! Input
    integer,intent(in)::isec
    ! Local
    integer hh
    integer mm
    integer ss
    character colon
    ! Main Code
    colon=':'
    ! Extract hour, minutes, seconds
    hh=isec/3600
    mm=mod(isec,3600)/60
    ss=mod(isec,60)
    write(ftn_sec2sng,'(i2.2,a1,i2.2,a1,i2.2)') hh,colon,mm,colon,ss
    return

ftn_strcat()

subroutine mod_sng::ftn_strcat	(	character(len=*), intent(inout)	sng1,
		character(len=*), intent(in)	sng2
	)

Definition at line 940 of file mod_sng.f90.

    ! Purpose: sng1 := sng1 // sng2
    ! The case where sng1=sng2 is handled correctly
    ! Usage:
    ! call ftn_strcat(sng1,sng2) ! [fnc] sng1 := sng1 // sng2
    use mod_utils ! [mdl] Debugging constants, prg_nm, dbg_lvl
    implicit none
    ! Commons
    ! Input
    character(len=*),intent(in)::sng2 ! I [sng] String to affix to first string
    ! Input/Output
    character(len=*),intent(inout)::sng1 ! I/O [sng] String to affix second string to
    ! Local
    integer len1
    integer len2
    integer lng1
    integer lng2
    ! Main Code
    len1=len(sng1)
    len2=len(sng2)
    lng1=ftn_strlen(sng1) ! [nbr] Length of string
    lng2=ftn_strlen(sng2) ! [nbr] Length of string
    if (lng1+lng2 >= len1) then
       write (6,'(a,a)') prg_nm(1:ftn_strlen(prg_nm)),': ERROR lng1+lng2 >= len1 in ftn_strcat()'
       write (6,'(a,i3,a,i3,2a)') 'len1 = ',len1,', lng1 = ',lng1,', sng1 = ',sng1
       write (6,'(a,i3,a,i3,2a)') 'len2 = ',len2,', lng2 = ',lng2,', sng2 = ',sng2
       stop 'EXIT_FAILURE from ftn_strcat()'
    endif                     ! endif
    sng1(lng1+1:lng1+lng2)=sng2(1:lng2) ! I/O [sng] String to affix second string to
    return

Here is the call graph for this function:

Here is the caller graph for this function:

ftn_strcmp()

integer function mod_sng::ftn_strcmp	(	character(len=*), intent(in)	sng1,
		character(len=*), intent(in)	sng2
	)

Definition at line 830 of file mod_sng.f90.

    ! Purpose: Compare sng2 to sng1
    ! Returns an integer less than, equal to, or greater than
    ! zero  if  sng1  is  found, respectively, to be less than, to
    ! match, or be greater than sng2.
    ! Usage:
    ! if(ftn_strcmp(sng1,"Hello World")==0) then ! [fnc] Compare sng1 to sng2: -1,0,1 iff sng1 <,=,> sng2
    use mod_utils ! [mdl] Debugging constants, prg_nm, dbg_lvl
    implicit none
    ! Commons
    ! Input
    character(len=*),intent(in)::sng1
    character(len=*),intent(in)::sng2
    ! Input/Output
    ! Local
    integer idx               ! [idx] Counting idx
    integer len1
    integer len2
    integer lng1
    integer lng2
    integer lng_min
    ! Main Code
    len1=len(sng1)
    len2=len(sng2)
    lng1=ftn_strlen(sng1) ! [nbr] Length of string
    lng2=ftn_strlen(sng2) ! [nbr] Length of string
    if (.false.) then 
       ! If this debugging block is turned on then attempting to print,ftn_strcmp()
       ! will cause a recursive I/O error at runtime
       write (6,'(2a)') prg_nm(1:ftn_strlen(prg_nm)),': DEBUG Diagnostics from ftn_strcmp()'
       write (6,'(2(a,i3),2a)') 'len1 = ',len1,', lng1 = ',lng1,', sng1 = ',sng1
       write (6,'(2(a,i3),2a)') 'len2 = ',len2,', lng2 = ',lng2,', sng2 = ',sng2
       call ftn_strprn(sng1) ! [fnc] Print character values of string
       call ftn_strprn(sng2) ! [fnc] Print character values of string
    endif                     ! endif
    lng_min=min(lng1,lng2)
    do idx=1,lng_min
       ! Prevent memory overruns
       ! Characters are equal, proceed to next character
       if (iachar(sng1(idx:idx)) == iachar(sng2(idx:idx))) cycle ! Goto next iteration
       ! Characters are unequal, determine relationship
       if (iachar(sng1(idx:idx)) < iachar(sng2(idx:idx))) then
          ftn_strcmp=-1    ! [fnc] Compare sng1 to sng2: -1,0,1 iff sng1 <,=,> sng2
       else                ! (iachar(sng1(idx:idx)) > iachar(sng2(idx:idx)))
          ftn_strcmp=1     ! [fnc] Compare sng1 to sng2: -1,0,1 iff sng1 <,=,> sng2
       endif               ! endif
       
       ! Characters were unequal, exit with appropriate value
       goto 100            ! Exit Branch
    end do
    
    if (lng1 == lng2) then
       ! All significant values of both strings were equal in all positions
       ! Thus the strings are equal by our criterion
       ftn_strcmp=0           ! [fnc] Compare sng1 to sng2: -1,0,1 iff sng1 <,=,> sng2
    else
       ! All significant values of both strings were equal in all mutually legal positions
       ! However, one string has more significant characters than the other
       ! Thus return value depends on which string is longer
       if (lng1 > lng2) then
          ftn_strcmp=1        ! [fnc] Compare sng1 to sng2: -1,0,1 iff sng1 <,=,> sng2
       else 
          ftn_strcmp=-1       ! [fnc] Compare sng1 to sng2: -1,0,1 iff sng1 <,=,> sng2
       endif                  ! endif
    endif ! endif lng1 == lng2
    
100 continue                  ! Exit branch for unequal values inside loop
    return

Here is the call graph for this function:

ftn_strcpy()

subroutine mod_sng::ftn_strcpy	(	character(len=*), intent(inout)	sng1,
		character(len=*), intent(in)	sng2
	)

Definition at line 785 of file mod_sng.f90.

    ! Purpose: Copy sng2 into sng1
    ! Space remaining at end of sng1 is NUL-initialized
    ! This function works well at copying fixed strings into variables, e.g.,
    ! Usage:
    ! call ftn_strcpy(sng,'Hello World') ! [fnc] Copy sng2 into sng1, NUL-terminate unused space
    use mod_utils ! [mdl] Debugging constants, prg_nm, dbg_lvl
    implicit none
    ! Commons
    ! Input
    character(len=*),intent(in)::sng2
    ! Input/Output
    character(len=*),intent(inout)::sng1
    ! Local
    integer len1
    integer len2
    integer lng1
    integer lng2
    ! Main Code
    len1=len(sng1)
    len2=len(sng2)
    ! Initialize sng1 before diagnostic ftn_strlen(sng1) is evaluated
    ! This handles situation when sng1 is large enough, but not-initialized in calling routine
    ! Otherwise some compilers, e.g., lf95 in debug mode, may complain in ftn_strlen(sng1)->ftn_strfic()
    ! when they are unable to determine string length
    ! Initialize sng1 before copying sng2 into sng1 WLOG since ftn_strcpy() behavior
    ! is intended to mimic C library strcpy() which NUL-terminates the copy, and thus
    ! all material after the NUL may be assumed to be undefined, i.e., set to NUL.
    ! This is not equivalent to calling ftn_strnul(sng1) after the copy since when sng1 is undefined
    ! There could be corner cases where contents of undefined sng1 character immediately
    ! following copy of sng2 is not NUL or 8-bit. Results are unpredicatable in that case.
    ! Hence initialize sng1 to NUL before using ftn_strlen(sng1) and before copying sng2
    call ftn_strini(sng1) ! [sng] sng(1:len)=NUL
    lng1=ftn_strlen(sng1) ! [nbr] Length of string
    lng2=ftn_strlen(sng2) ! [nbr] Length of string
    if (len1 < lng2) then
       write (6,'(a,a)') prg_nm(1:ftn_strlen(prg_nm)),': ERROR len1 < lng2 in ftn_strcpy()'
       write (6,'(a,i3,a,i3,2a)') 'len1 = ',len1,', lng1 = ',lng1,', sng1 = ',sng1
       write (6,'(a,i3,a,i3,2a)') 'len2 = ',len2,', lng2 = ',lng2,', sng2 = ',sng2
       stop 'EXIT_FAILURE from ftn_strcpy()'
    endif                     ! endif
    sng1(1:lng2)=sng2(1:lng2)
    return

Here is the call graph for this function:

Here is the caller graph for this function:

ftn_strcpylsc()

subroutine mod_sng::ftn_strcpylsc	(	character(len=*), intent(inout)	sng1,
		character(len=*), intent(in)	sng2
	)

Definition at line 900 of file mod_sng.f90.

    ! Purpose: Copy sng2 into sng1
    ! Space remaining at end of sng1 is NUL-initialized
    ! This function works well at copying fixed strings into variables, e.g.,
    ! Usage:
    ! call ftn_strcpylsc(sng,'Hello World') ! [fnc] Copy up to LSC of sng2 into sng1, NUL-initialize unused space
    use mod_utils ! [mdl] Debugging constants, prg_nm, dbg_lvl
    implicit none
    ! Commons
    ! Input
    character(len=*),intent(in)::sng2
    ! Input/Output
    character(len=*),intent(inout)::sng1
    ! Local
    integer idx               ! [idx] Counting idx
    integer len1
    integer len2
    integer lsc1
    integer lsc2
    ! Main Code
    len1=len(sng1)
    len2=len(sng2)
    lsc1=ftn_strlsc(sng1)
    lsc2=ftn_strlsc(sng2)
    if (len1 < lsc2) then
       write (6,'(a,a)') prg_nm(1:ftn_strlsc(prg_nm)),': ERROR len1 < lsc2 in ftn_strcpylsc()'
       write (6,'(a,i3,a,i3,2a)') 'len1 = ',len1,', lsc1 = ',lsc1,', sng1 = ',sng1
       write (6,'(a,i3,a,i3,2a)') 'len2 = ',len2,', lsc2 = ',lsc2,', sng2 = ',sng2
       stop 'EXIT_FAILURE from ftn_strcpylsc()'
    endif                     ! endif
    sng1(1:lsc2)=sng2(1:lsc2)
    ! NUL-initialize rest of string
    do idx=lsc2+1,len1
       sng1(idx:idx)=char(0)
    end do                    ! end loop over characters
    return

Here is the call graph for this function:

ftn_strfic()

integer function mod_sng::ftn_strfic

(

character(len=*), intent(in)

sng

)

Definition at line 721 of file mod_sng.f90.

    ! Purpose: Return position of first insignificant character (FIC) in string
    ! FIC is first NUL character in string, or first 8-bit character, i.e., iachar > 127
    ! FIC is len(sng)+1 if string has no NUL character and no iachar > 127
    ! Usage:
    ! psn=ftn_strfic(sng) ! [idx] First NUL or 8-bit character position
    ! Prototype:
    ! integer ftn_strfic ! [idx] First NUL or 8-bit character position
    implicit none
    ! Input
    character(len=*),intent(in)::sng ! I [sng] String to examine
    ! Local
    integer idx
    integer lng
    ! Main Code
    lng=len(sng)
    do idx=1,lng
       ! Look for first abnormal character
       if (sng(idx:idx) == char(0) .or. iachar(sng(idx:idx)) > 127) goto 100
    end do                    ! end loop over characters
100 continue
    ftn_strfic=idx ! [idx] First NUL or 8-bit character position
    return

Here is the caller graph for this function:

ftn_strini()

subroutine mod_sng::ftn_strini

(

character(len=*), intent(out)

sng

)

Definition at line 650 of file mod_sng.f90.

    ! Purpose: Initialize all elements of a character array to char(0)
    ! Usage:
    ! call ftn_strini(sng) ! [sng] sng(1:len)=NUL
    implicit none
    ! Input/Output
    character(len=*),intent(out)::sng ! I/O [sng] String to initialize
    ! Local
    integer idx
    integer lng
    ! Main Code
    lng=len(sng)
    do idx=1,lng
       sng(idx:idx)=char(0)
    end do                    ! end loop over characters
    ! write (6,*) 'ftn_strini(): Initialized string of length',lng
    return

Here is the caller graph for this function:

ftn_strlen()

integer function mod_sng::ftn_strlen

(

character(len=*), intent(in)

sng

)

Definition at line 98 of file mod_sng.f90.

    ! Purpose: Return length of string preceding first null character
    ! Fortran intrinsic len(sng) is returned if string is not NUL-terminated
    ! Prototype:
    ! integer ftn_strlen ! [nbr] Length of string
    implicit none
    ! Input
    character(len=*),intent(in)::sng
    ! Local
    ! Main Code
    ! Normally, length of string is position of first insignificant character minus one
    ftn_strlen=ftn_strfic(sng)-1 ! [idx] First NUL or 8-bit character position
    ! String length may not exceed buffer size
    if (ftn_strlen > len(sng)) ftn_strlen=len(sng)
    ! String length may not be less than 0
    ! Strings initialized to '' should have length 0 not -1
    if (ftn_strlen < 0 .or. sng == '') ftn_strlen=0
    return

Here is the call graph for this function:

Here is the caller graph for this function:

ftn_strlsc()

integer function mod_sng::ftn_strlsc

(

character(len=*), intent(in)

sng

)

Definition at line 691 of file mod_sng.f90.

    ! Purpose: Return position of last significant character (LSC) in string
    ! LSC is last character that is not a space or a NUL character
    ! Routine is useful in determining effective lengths of strings which
    ! may have been padded by compiler or shell.
    ! Automatic padding is always done with spaces or NULs, so this routine
    ! tells us how long the non-padded portion of the string is.
    ! Routine will mis-handle user-defined strings that end in spaces
    ! LSC is always <= len(sng)
    ! Usage:
    ! psn=ftn_strlsc(sng) ! [idx] Last significant character position
    ! Prototype:
    ! integer ftn_strlsc ! [idx] Last significant character position
    implicit none
    ! Input
    character(len=*),intent(in)::sng
    ! Local
    integer idx
    integer lng
    ! Main Code
    lng=len(sng)
    do idx=lng,1,-1
       ! Look for last normal character
       if (sng(idx:idx) /= ' '.and.sng(idx:idx) /= char(0)) goto 100
    end do                    ! end loop over characters
100 continue
    ftn_strlsc=idx
    return

Here is the caller graph for this function:

ftn_strnul()

subroutine mod_sng::ftn_strnul

(

character(len=*), intent(inout)

sng

)

Definition at line 669 of file mod_sng.f90.

    ! Purpose: Change space characters to NUL characters in a string
    ! Spaces after last significant character (LSC) in string are changed to NUL
    ! Spaces before LSC are not affected
    ! Usage:
    ! call ftn_strnul(sng) ! [sbr] NUL-initialize all characters after LSC
    implicit none
    ! Input/Output
    character(len=*),intent(inout)::sng ! I/O [sng] String to NUL-initialize
    ! Local
    integer idx
    integer lng
    integer lst_sgn_chr_idx
    ! Main Code
    lng=ftn_strlen(sng) ! [nbr] Length of string
    lst_sgn_chr_idx=ftn_strlsc(sng)
    do idx=lst_sgn_chr_idx+1,lng
       if(sng(idx:idx) == ' ') sng(idx:idx)=char(0)
    end do                    ! end loop over characters
    return

Here is the call graph for this function:

Here is the caller graph for this function:

ftn_strpfx()

subroutine mod_sng::ftn_strpfx	(	character(len=*), intent(in)	sng1,
		character(len=*), intent(inout)	sng2
	)

Definition at line 972 of file mod_sng.f90.

    ! Purpose: sng2 := sng1 // sng2
    ! Differences with ftn_strcat(): 
    ! 1. Result is stored in second string not first string
    ! 2. Strings are trimmed before concatenation
    ! The case where sng1=sng2 is handled correctly
    ! Usage:
    ! call ftn_strpfx(sng1,sng2) ! [sbr] sng2 := sng1 // sng2
    use mod_utils ! [mdl] Debugging constants, prg_nm, dbg_lvl
    implicit none
    ! Commons
    ! Input
    character(len=*),intent(in)::sng1
    ! Output
    character(len=*),intent(inout)::sng2
    ! Local
    integer len1
    integer len2
    integer len_trim1
    integer len_trim2
    integer lng1
    integer lng2
    integer lsc1
    integer lsc2
    ! Main Code
    len1=len(sng1)
    len2=len(sng2)
    lng1=ftn_strlen(sng1) ! [nbr] Length of string
    lng2=ftn_strlen(sng2) ! [nbr] Length of string
    lsc1=ftn_strlsc(sng1)
    lsc2=ftn_strlsc(sng2)
    len_trim1=len_trim(sng1)
    len_trim2=len_trim(sng2)
    if (lsc1+lsc2 >= len2) then
       write (6,'(a,a)') prg_nm(1:ftn_strlen(prg_nm)),': ERROR lsc1+lsc2 >= len2 in ftn_strpfx()'
       write (6,'(4(a,i3),2a)') 'len1 = ',len1,', len_trim1 = ',len_trim1,', lng1 = ',lng1,', sng1 = ',sng1
       write (6,'(4(a,i3),2a)') 'len2 = ',len2,', len_trim2 = ',len_trim2,', lng2 = ',lng2,', sng2 = ',sng2
       call ftn_strprn(sng1)
       call ftn_strprn(sng2)
       stop 'EXIT_FAILURE from ftn_strpfx()'
    endif                     ! endif
    ! Order is important
    sng2(lsc1+1:lsc1+lsc2)=sng2(1:lsc2)
    sng2(1:lsc1)=sng1(1:lsc1)
    return

Here is the call graph for this function:

ftn_strprn()

subroutine mod_sng::ftn_strprn

(

character(len=*), intent(in)

sng

)

Definition at line 746 of file mod_sng.f90.

    ! Purpose: Print character values of string
    ! Usage:
    ! call ftn_strprn(sng) ! [fnc] Print character values of string
    implicit none
    ! Input
    character(len=*),intent(in)::sng
    ! Local
    character(1) chr_crr ! [sng] Current character
    integer idx
    integer lng
    integer iachr_crr ! [enm] Integer representing current character
    ! Main Code
    lng=len(sng)
    do idx=1,lng
       ! Print each normal character
       chr_crr=sng(idx:idx) ! [sng] Current character
       iachr_crr=iachar(chr_crr) ! [enm] Integer representing current character
       if (idx < lng) then
          if (iachr_crr == 0) then
             write (6,'(a3,a3,i3,a2)',advance="no") 'NUL',' = ',iachr_crr,', '
          else if (iachr_crr == 32) then
             write (6,'(a5,a3,i3,a2)',advance="no") 'SPACE',' = ',iachr_crr,', '
          else
             write (6,'(a1,a3,i3,a2)',advance="no") chr_crr,' = ',iachr_crr,', '
          endif               ! endif
       else
          if (iachr_crr == 0) then
             write (6,'(a3,a3,i3)') 'NUL',' = ',iachr_crr,', '
          else if (iachr_crr == 32) then
             write (6,'(a5,a3,i3)') 'SPACE',' = ',iachr_crr,', '
          else
             write (6,'(a1,a3,i3)') chr_crr,' = ',iachr_crr,', '
          endif               ! endif
       endif                  ! endif
    end do                    ! end loop over characters
    return

Here is the caller graph for this function:

ftn_strstr()

integer function mod_sng::ftn_strstr	(	character(len=*), intent(in)	sng1,
		character(len=*), intent(in)	sng2
	)

Definition at line 612 of file mod_sng.f90.

    ! Purpose: Return the location of second string in the first
    ! Fortran intrinsic len(sng) is returned if string is not NUL-terminated
    ! Return -1 if sng1 does not contain sng1
    ! Prototype:
    ! integer ftn_strstr ! [idx] Location of sng1 in sng2
    implicit none
    ! Input
    character(len=*),intent(in)::sng1
    character(len=*),intent(in)::sng2
    ! Local
    integer lng1
    integer lng2
    integer idx1
    integer idx2
    ! Initialize
    idx2=0 ! CEWI for lf95
    ! Main Code
    lng1=ftn_strlen(sng1) ! [nbr] Length of string
    lng2=ftn_strlen(sng2) ! [nbr] Length of string
    do idx1=1,lng1
       if (sng1(idx1:idx1) == sng2(1:1)) then
          do idx2=2,lng2
             if (sng1(idx1+idx2-1:idx1+idx2-1) /= sng2(idx2:idx2)) goto 200
          end do              ! end loop over characters
          goto 100
       endif                  ! endif
200    continue
    end do                    ! end loop over characters
100 continue
    if (idx2 == lng2+1) then
       ftn_strstr=idx1
    else
       ftn_strstr=-1
    endif ! endif
    return

Here is the call graph for this function:

Here is the caller graph for this function: