Fortran Wiki
ufpp

The uufp(1) program is a pre-processor that can be used to conditionally output lines from input files to generate a Fortran source file. The source is in the public domain. It is not cpp(1)-compatible. * it is written in Fortran * directives are compatible with Fortran 77 (case insensitive, blanks are ignored, expressions use the syntax of Fortran 77 INTEGER or LOGICAL expressions) * user documentation is generated by the program -help option (see the HELP procedure in the code). * if you make enhancements please feel free to incorporate them into this source * Requires the additional module M_kracken * A personally maintained alternate version is also available.

!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
!  @(#) FORTRAN preprocessor
!  Originally based on public-domain FPP preprocessor from Lahey Fortran Code Repository : http://www.lahey.com/code.htm
!  Use at your own risk.
!  John S. Urban ; last updated 20130611
!===================================================================================================================================
!     Requires:
!         M_kracken  Fortran module for parsing command line arguments.
!                    See "home.comcast.net/~urbanjost/CLONE/KRACKEN/krackenhelp.html".
!
!     Change log:
!     o command argument cracking instead of reading parameters from stdin
!        o allow defaults for filenames; default input and output files are stdin and stdout
!        o allow for multiple input files similar to original @FILENAME option
!        o allow variables to be defined from command line (using "cmd_oo" field)
!        o allow specifying directive prefix character
!     o changed line width from 80 to 1024 characters
!     o corrected logic error in DOOP where once VAL1.OP.VAL2 is true all similar expressions return true if not in parenthesis
!     o correction so $!comments works
!     o add simple include of a file with $include directive
!     o allow a list of directories to search for included files
!
!     NEXT
!     o PARCEL/POST and $INSERT definition of command line blocks, and invocation of the blocks.
!     o correct numeric expression problems with negative numbers
!     o use ASCII DISPLAY code to specify filenames in somewhat case-insensitive manner so converting directive to uppercase OK.
!     o UNTIL feature and use of <!-- --> HTML comments or XML <makeup name> so code can be mixed with HTML. Consider that
!       without support of the <XMP> directive code versus display issues occur with the use of & and <> characters in particular.
!     o alternatively, make document section and code section and use ufpp to select sections for making an HTML document from.
!       The fortran section could be run through existing utilities like enscript(1) to convert the Fortran to colorized HTML.
!     o Allow sections to be input to a system process so other tools are integrated? Makes input very system-dependent
!
!===================================================================================================================================
   module M_fpp                                                      !@(#) module used by UFPP(1) program

   integer,parameter           ::  num=128                           ! num         - number of named values allowed
   integer,parameter           ::  line_length=1024                  ! line_length - allowed length of input lines
   integer,parameter           ::  var_len=31                        ! var_len     - allowed length of variable names
   integer,parameter           ::  nestl_max=20                      ! nestl_max   - maximum nesting level of conditionals

   logical,save                :: condop(0:nestl_max)                ! condop      - flag to keep track of previous write flags
   data condop(0:nestl_max) /.true.,nestl_max*.false./

   integer                     :: numdef=0                           ! numdef      - number of defined variables in dictionary

   logical                     :: write=.true.                       ! write       - indicates whether lines should be processed
   integer                     :: nestl=0                            ! nestl       - count of if/elseif/else/endif nesting level

   character(len=line_length)  :: source                             ! source      - original source file line
   character(len=line_length)  :: message                            ! message     - message to build for stopping program

   character(len=var_len)      :: defval(num)                        ! defval      - variable values  in variable dictionary
   character(len=var_len)      :: defvar(num)                        ! defvar      - variables in variable dictionary

   logical                     :: dc                                 ! dc          - flag to determine write flag

   integer                     :: iin(50)=0
   integer                     :: iline_number(50)=0
   integer                     :: iocount=0
   integer                     :: iototallines=0
   character(len=line_length)  :: files(50)
   integer                     :: iout                               ! output unit

   integer                     :: inc_count=0
   character(len=line_length)  :: inc_files(50)

   contains
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
   subroutine cond                                         !@(#) process conditional directive assumed to be in SOURCE "$verb..."
   implicit none

   character(len=255),external :: upperstr                 ! function to convert a string to uppercase
   character(len=line_length)  :: line                     ! directive line with leading prefix removed
   logical,save                :: eb=.false.               !
   integer,save                :: noelse=0                 !
   integer                     :: istart
   integer                     :: itrim
!-----------------------------------------------------------------------------------------------------------------------------------
   line=source(2:)                                         ! remove leading prefix from directive line
   line=upperstr(line)                                     ! convert line to uppercase
   call nospace(line)                                      ! remove spaces from directive
   if (index(line,'!').ne.0) then                          ! if directive contains an exclamation a comment is present
      line=line(:index(line,'!')-1)                        ! trim trailing comment from directive
   endif
   select case(line(:2))                                   ! process directive based on first two characters
   case('  ')                                              ! entire line is a comment
   case('DE')                                              ! input is a DEFINE directive
      if (write) call define(line)                         ! only process DEFINE if not skipping data lines
   case('UN')                                              ! input is an UNDEF directive
      if (write) call undef(line)                          ! only process UNDEF if not skipping data lines
   case('IF')                                              ! input is an IF directive
      call if(line,noelse,eb)                              !
   case('PR')                                              ! input is a PRINTENV directive
      call printenv(line)                                  !
   case('EL')                                              ! input is an ELSE/ELSEIF directive
      call else(line,noelse,eb)                            !
   case('EN')                                              ! input is an ENDIF directive
      call endif(noelse,eb)                                !
   case('IN')                                              ! input is an INCLUDE directive. Filenames can be case sensitive
      istart=index(upperstr(source),'INCLUDE')             ! find INCLUDE in original source
      if(istart.ne.0)then                                  ! trim $INCLUDE from line
         line=source(istart+7:)
         itrim=index(line,'!')                             ! trim trailing comment, if any
         if(itrim.ne.0)then
            line(itrim-1:)='  '
         endif
         call nospace(line)
         call include(line,50+iocount)                     !
      else
         write(message,'("*ufpp* FATAL - MISSPELLED INCLUDE:",a)')trim(source)
         call stop_ufpp()
      endif
   case('SH')                                              ! input is a DEBUG directive
      call debug()                                         !
   case default
      write(message,'(''*ufpp* FATAL - UNKNOWN COMPILER DIRECTIVE:'',a)') trim(SOURCE)
      call stop_ufpp()
   end select
   end subroutine cond
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
   subroutine nospace(line)                                !@(#) remove all blanks from input string
   implicit none
   character(len=*)            ::  line                    ! remove spaces from this string and return it
   character(len=line_length)  ::  temp                    ! buffer to build output in
   integer                     ::  ipos                    ! position to place next output character at
   integer                     ::  i                       ! counter to increment from beginning to end of input string
!-----------------------------------------------------------------------------------------------------------------------------------
   ipos=0
   temp=' '
   do i=1,len(line)                                        ! increment from first to last character of the input line
      if (ichar(line(i:i)).eq.32) cycle                    ! if a blank is encountered skip it
      ipos=ipos+1                                          ! increment count of non-blank characters found
      if(ipos.gt.line_length)then                          ! of all of input cannot be stored in output stop
         write(message,'(''*ufpp* FATAL - INPUT LINE TOO LONG.'',a)') trim(line)
         call stop_ufpp()
      endif
      temp(ipos:ipos)=line(i:i)                            ! store non-blank character in output
   enddo
   line=temp                                               ! replace original string with output
   end subroutine nospace
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
   subroutine define(line)                                  !@(#) process "DEFINE variablename[=expression]" directive
   implicit none
   character(len=line_length)  ::  line                     ! packed uppercase working copy of input line with leading $ removed

   character(len=line_length)  ::  temp                     ! scratch
   integer                     :: iequ                      ! location of "=" in the directive, if any
   integer                     :: j                         ! index thru variable dictionary to see if variable is already defined
!-----------------------------------------------------------------------------------------------------------------------------------
! CHECK COMMAND SYNTAX
   if(line(1:6).ne.'DEFINE')then                            ! check verb really is DEFINE and find rest of directive
      write(message,'(''*ufpp* FATAL - EXPECTED "DEFINE". FOUND:'',a)') trim(source)
      call stop_ufpp()
   else
      line=line(7:)                                         ! trim off directive verb DEFINE
   endif
   iequ=index(line,'=')                                     ! find "=" in "variable_name=expression" if any
   if (line(1:1).eq.' '.or.iequ.eq.len_trim(line)) then     ! no variable name in packed string or string after = is null
      write(message,'(''*ufpp* FATAL - INCOMPLETE STATEMENT:'',a)') trim(source)
      call stop_ufpp()
   endif
   if (iequ.gt.var_len+1) then                              ! variable name too long
      write(message,'(''*ufpp* FATAL - MISPELLING OR NAME LENGTH EXCEEDS '',i5,''CHARACTERS:'',a)') var_len, trim(source)
      call stop_ufpp()
   endif
!-----------------------------------------------------------------------------------------------------------------------------------
! OBTAIN VARIABLE NAME
   numdef=numdef+1                                          ! increment number of defined variables
   if (iequ.eq.0) then                                      ! if no = then variable assumes value of 1
      defvar(numdef)=line                                   ! store variable name from line with no =value string
      line='1'                                              ! set string to default value
   else                                                     ! =value string trails name on directive
      defvar(numdef)=line(:iequ-1)                          ! store variable nanme from line with =value string
   endif
!-----------------------------------------------------------------------------------------------------------------------------------
! CHECK VARIABLE NAME
   call name(defvar(numdef))                                ! check that variable name is composed of allowed characters

   if (numdef.ne.1) then                                    ! test for redefinition of defined name
      do j=1,numdef-1
         if (defvar(numdef).eq.defvar(j)) then
            write(message,'(''*ufpp* FATAL - REDEFINITION OF DEFINED NAME INVALID:'',a)') trim(source)
            numdef=numdef-1
            call stop_ufpp()
         endif
      enddo
   endif
!-----------------------------------------------------------------------------------------------------------------------------------
   temp=line(iequ+1:)                                       ! get expression
   call parens(temp)                                        !
   if (iequ.eq.0) then
      line=temp
   else
      line=line(:iequ)//temp
   endif
!-----------------------------------------------------------------------------------------------------------------------------------
   call math(line,iequ+1,len_trim(line))
   call doop(line,iequ+1,len_trim(line))
   call logic(line,iequ+1,len_trim(line))
   call getval(line,iequ+1,len_trim(line),defval(numdef))
!-----------------------------------------------------------------------------------------------------------------------------------
   end subroutine define
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
FUNCTION GetDateTimeStr() RESULT(s)                                  !@(#) Function to write date and time into returned screen
! -----------------------------------------------------------------
! PURPOSE - Return a string with the current date and time
   IMPLICIT NONE
   CHARACTER(LEN=*),PARAMETER         :: MONTH='JanFebMarAprMayJunJulAugSepOctNovDec'
   CHARACTER(LEN=*),PARAMETER         :: FMT = '(I2.2,A1,I2.2,I3,A3,I4)'
   CHARACTER(LEN=15)                  :: s
   INTEGER,DIMENSION(8)               :: v
!-------------------------------------------------------------------
   CALL DATE_AND_TIME(VALUES=v)
   WRITE(s,FMT) v(5), ':', v(6), v(3), MONTH(3*v(2)-2:3*v(2)), v(1)
END FUNCTION GetDateTimeStr
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
   subroutine printenv(line)                                  !@(#) process "PRINTENV variablename" directive
   implicit none
   character(len=line_length)  ::  line                       ! packed uppercase working copy of input line with leading $ removed
   character(len=line_length)  ::  varvalue                   ! value of environmental variable
!-----------------------------------------------------------------------------------------------------------------------------------
! CHECK COMMAND SYNTAX
   if(line(1:8).ne.'PRINTENV')then                            ! check verb really is PRINTENV
      write(message,'(''*ufpp* FATAL - EXPECTED "PRINTENV". FOUND:'',a)') trim(source)
      call stop_ufpp()
   else
      line=line(9:)                                           ! trim off directive verb PRINTENV
   endif
!-----------------------------------------------------------------------------------------------------------------------------------
   select case(line)                                                          ! process directive based on variable name
   case('UFPP_DATE')
      write(iout,'("      UFPP_DATE=""",a,"""")')GetDateTimeStr()
   case('UFPP_FILE')
      write(iout,'("      UFPP_FILE=""",a,"""")')trim(files(iocount))     ! assumes filename does not have " characters
   case('UFPP_LINE')
      !write(iout,'("      UFPP_LINE=""",i11,"""")')iline_number(iocount)  ! assumes want this as a string and not a number
      write(iout,'("      UFPP_LINE=",i11)')iline_number(iocount)  ! assumes want this as a number
   case('')
      write(message,'(''*ufpp* FATAL - NO VARIABLE NAME ON "PRINTENV":'',a)') trim(SOURCE)
      call stop_ufpp()
   case default
      call get_environment_variable(line,varvalue)
      if(varvalue.eq.'')then
         write(message,'(''*ufpp* FATAL - NO VARIABLE VALUE FOUND FOR "PRINTENV":'',a)') trim(SOURCE)
         call stop_ufpp()
      endif
      write(iout,'(a)')trim(varvalue)
   end select
   end subroutine printenv
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
   subroutine name(line)                                                 !@(#) test for legal variable name
   implicit none
   character(len=*)       :: line
   integer                :: i
!-----------------------------------------------------------------------------------------------------------------------------------
   if (line(1:1).lt.'A'.or.line(1:1).gt.'Z')then                         ! variable names start with a-z
      write(message,'(''*ufpp* FATAL - VARIABLE NAME DOES NOT START WITH ALPHAMERIC (OR GENERAL SYNTAX ERROR):'',a)') trim(source)
      call stop_ufpp()
   endif

   if(len_trim(line).gt.var_len)then
      write(message,'(''*ufpp* FATAL - VARIABLE NAME EXCEEDS '',i5,'' CHARACTERS:'',a)') var_len,trim(source)
      call stop_ufpp()
   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
         write(message,'(''*ufpp* FATAL - VARIABLE NAME CONTAINS UNALLOWED CHARACTER (OR GENERAL SYNTAX ERROR):'',a)') trim(source)
         call stop_ufpp()
      endif
   enddo

   end subroutine name
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
   subroutine getval(line,ipos1,ipos2,value)                    !@(#) get value from dictionary for given variable name or return input
   implicit none

   character(len=var_len),intent(out)      :: value                         ! returned variable name
   integer,intent(in)                      :: ipos1                         ! beginning position of variable name in LINE
   integer,intent(in)                      :: ipos2                         ! ending position of variable name in LINE
   character(len=line_length),intent(in)   :: line                          ! current(maybe partial) directive line

   character(len=line_length)              :: temp                          ! copy of substring being examined
   integer                                 :: i
   integer                                 :: ivalue
!-----------------------------------------------------------------------------------------------------------------------------------
   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
      write(message,'(''*ufpp* FATAL - INCOMPLETE STATEMENT.'',a)') trim(SOURCE)
      call stop_ufpp()
   endif

   if (temp(1:1).ge.'A'.and.temp(1:1).le.'Z') then                          ! appears to be a variable name (not number or logical)

     value=temp
     do i=1,numdef                                                          ! find defined parameter in dictionary
        if (defvar(i).eq.value)exit
     enddo
     if (i.gt.numdef)then                                                   ! unknown variable name
        write(message,'(''*ufpp* FATAL - UNDEFINED PARAMETER IN GETVAL(3f):'',a)') trim(source)
        call stop_ufpp()
     endif
     value=defval(i)                                                        ! (trusted) value for variable name found in dictionary
     return
   else                                                                     ! not a variable name, try as a value
     read(temp(1:11),'(i11)',err=3) ivalue                                  ! try string as a numeric integer value
     write(value,'(i11)') ivalue                                            ! write numeric value into VALUE
     return                                                                 ! successfully return numeric VALUE

3    continue                                                               ! failed to read numeric value
     value=temp                                                             ! test TEMP as a logical
     if (value.ne.'.FALSE.'.and.value.ne.'.TRUE.')then                      ! if here, value should be a logical
        write(message,'(''*ufpp* FATAL - SYNTAX ERROR.'',a)') trim(source)
        call stop_ufpp()
     endif
                                                                            ! value is ".TRUE." or ".FALSE."
   endif

   if(temp(1:1).ge.'A')then
      write(message,'(''*ufpp* FATAL - $DEFINE VALUE MUST BE AN INTEGER OR LOGICAL CONSTANT.'',a)') trim(source)
      call stop_ufpp()
   endif

   end subroutine getval
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
   subroutine undef(line)                                  !@(#) process UNDEFINE directive
   character(len=line_length)  :: line                     ! directive with no spaces, leading prefix removed, and all uppercase
   integer                     :: ifound                   ! subscript for location of variable to delete
!-----------------------------------------------------------------------------------------------------------------------------------
! CHECK VERB
   if(line(1:8).ne.'UNDEFINE')then                         ! check that verb is UNDEFINE
      write(message,'(''*ufpp* FATAL - DIRECTIVE MUST START WITH "UNDEFINE":'',a)')trim(source)
      call stop_ufpp()
   endif
!-----------------------------------------------------------------------------------------------------------------------------------
! REMOVE VARIABLE IF FOUND IN VARIABLE NAME DICTIONARY
   line=line(9:)                                           ! remove leading UNDEFINE so just uppercase trimmed variable name remains

   if (len_trim(line).eq.0) then                           ! if no variable name
      write(message,'(''*ufpp* FATAL - INCOMPLETE STATEMENT:'',a)')trim(source)
      call stop_ufpp()
   endif

   ifound=-1                                               ! initialize subscript for variable name to be searched for to bad value
   do i=1,numdef                                           ! find defined variable to be undefined by searching dictionary
      if (defvar(i).eq.line)then                           ! found the requested variable name
         ifound=i                                          ! record the subscript that the name was located at
         exit                                              ! found the variable so no longer any need to search remaining names
      endif
   enddo

   if (ifound.lt.1) then                                   ! variable name not found
      return                                               ! quietly ignore unknown name (or syntax error!)
   endif

   do j=ifound,numdef-1                                    ! remove variable name and value from list of variable names and values
     defvar(j)=defvar(j+1)                                 ! replace the value to be removed with the one above it and then repeat
     defval(j)=defval(j+1)
   enddo

   numdef=numdef-1                                         ! decrement number of defined variables

   end subroutine undef
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
   subroutine if(line,noelse,eb)                           !@(#)  process IF and ELSEIF directives
   logical                    ::  eb
   character(len=var_len)     ::  value
   character(len=line_length) ::  line
!-----------------------------------------------------------------------------------------------------------------------------------
   line=line(3:)                                           ! reduce line to just the expression
   noelse=0
   write=.false.

   nestl=nestl+1                                           ! increment IF nest level
   if (nestl.gt.nestl_max) then
      write(message,'(''*ufpp* ABORT - "IF" BLOCK NESTING TOO DEEP, LIMITED TO '',i4,'' LEVELS:'',a)')nestl_max, trim(source)
      call stop_ufpp()
   endif

   FIND_DEFINED: do                                        ! find and reduce all DEFINED() functions to ".TRUE." or ".FALSE."
      if (index(line,'DEFINED(').ne.0) then                ! find a DEFINED() function
         call ifdef(line,index(line,'DEFINED('))           ! reduce DEFINED() function that was found
         call nospace(line)                                ! remove any spaces from rewritten expression
         cycle                                             ! look for another DEFINED() function
      endif
      exit                                                 ! no remaining DEFINED() functions so exit loop
   enddo FIND_DEFINED

   call parens(line)
   if (index(line,'.').eq.0) then                          ! if line should be a variable only
      if (line(1:1).ge.'A'.and.line(1:1).le.'Z') then      ! check that variable name starts with a valid character
         call name(line)                                   ! check that line contains only a legitimate variable name
         value=line(:var_len)                              ! set VALUE to variable name
         do i=1,numdef                                     ! find variable in variable dictionary
            if (defvar(i).eq.value) exit
         enddo
         if (i.gt.numdef) then                             ! if failed to find variable name
            write(message,'(''*ufpp* FATAL - UNDEFINED PARAMETER IN IF(3f):'',a)') trim(source)
            call stop_ufpp()
         endif
         read(defval(i),'(l4)',iostat=ios) dc              ! convert variable value to a logical
         if(ios.ne.0)then
            write(message,'(''*ufpp* FATAL - CONSTANT LOGICAL EXPRESSION REQUIRED.''),a') trim(source)
            call stop_ufpp()
         endif
      else                                                 ! this should have been a variable name
         write(message,'(''*ufpp* FATAL - CONSTANT LOGICAL EXPRESSION REQUIRED:'',a)') trim(source)
         call stop_ufpp()
      endif
   else                                                    ! a period is present in the expression so it needs evaluated
      call eval(line)                                      ! evaluate line
   endif
   if (.not.dc.or..not.condop(nestl-1).or.eb)then
      return                                               ! check to make sure previous IF was true
   endif
   condop(nestl)=.true.
   write=condop(nestl)
   end subroutine if
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
   subroutine ifdef(line,ipos1)                            !@(#) process
   character(len=line_length)    :: line
   character(len=line_length)    :: newl

   character(len=var_len)        ::  ifvar
!----------------------------------------------------------------------------------------------------------------------------------
   newl=line(ipos1+7:)
   if (len_trim(newl).eq.1.or.index(newl,')').eq.0.or. index(newl,')').eq.2)then
      write(message,'(''*ufpp* FATAL - INCOMPLETE STATEMENT.''),a') trim(SOURCE)
      call stop_ufpp()
   endif
   if (index(newl,')').gt.33)then
      write(message,'(''*ufpp* FATAL - MISSPELLING OR NAME LENGTH EXCEEDS '',i5,'' CHARACTERS.'',a)') var_len,trim(source)
      call stop_ufpp()
   endif
   ifvar= newl(2:index(newl,')')-1)
   if (newl(2:2).lt.'A'.or.newl(2:2).gt.'Z')then
      write(message,'(''*ufpp* FATAL - CONSTANT LOGICAL EXPRESSION REQUIRED.'',a)') trim(source)
      call stop_ufpp()
   endif

   do i=3,index(newl,')')-1
      IF (NEWL(I:I).NE.'$'.AND.NEWL(I:I).NE.'_'.AND.(NEWL(I:I).LT.'A' &
       &  .OR.NEWL(I:I).GT.'Z').AND.(NEWL(I:I).LT.'0'                 &
       &  .or.newl(i:i).gt.'9')) then
         write(message,'(''*ufpp* FATAL - CONSTANT LOGICAL EXPRESSION REQUIRED.'',a)') trim(source)
         call stop_ufpp()
      endif
   enddo

   dc=.false.
   line(ipos1:ipos1+6+index(newl,')'))='.FALSE.'

   do i=1,numdef
     if (defvar(i).eq.ifvar) then
       dc=.true.
       line(ipos1:ipos1+6+index(newl,')'))='.TRUE.'
       return
     endif
   enddo

   end subroutine ifdef
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
   subroutine else(line,noelse,eb)                         !@(#) process else and elseif
   logical eb
   character(len=line_length)  line                        ! line        -
!-----------------------------------------------------------------------------------------------------------------------------------
   if (noelse.eq.1.or.nestl.eq.0) then                     ! test for else instead of elseif
      WRITE(message,'(''*ufpp* FATAL - MISPLACED $ELSE OR $ELSEIF DIRECTIVE:'',A)') trim(SOURCE)
      call stop_ufpp()
   endif
   if (len_trim(line).eq.4) noelse=1
   if (.not.condop(nestl-1)) return                        ! if was true so ignore else
     eb=.false.
   if (condop(nestl)) then
       eb=.true.
       write=.false.
   elseif (len_trim(line).ne.4) then                      ! elseif detected
     nestl=nestl-1                                        ! decrease if level because it will be incremented in subroutine if
     line=line(5:)
     call if(line,noelse,eb)
   else                                                   ! else detected
     condop(nestl)=.true.
     write=.true.
   endif
   end subroutine else
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
   subroutine endif(noelse,eb)                             !@(#) process ENDIF directive
   logical                       :: eb
!-----------------------------------------------------------------------------------------------------------------------------------
   nestl=nestl-1                                           ! decrease if level
   if(nestl.lt.0)then
      write(message,'(''*uffp* FATAL - MISPLACED $ENDIF DIRECTIVE:'',a)') trim(source)
      call stop_ufpp()
   endif

   noelse=0                                                ! reset else level
   eb=.not.condop(nestl+1)
   write=.not.eb
   condop(nestl+1)=.false.

   if (nestl.eq.0) then
         write=.true.
         eb=.false.
   endif

   end subroutine endif
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
   subroutine parens(line)                                 !@(#) find subexpressions in parenthesis and process them
   character(len=line_length)  line                        ! line        -
!-----------------------------------------------------------------------------------------------------------------------------------
   TILLDONE: do
      if (index(line,')').ne.0) then          ! closing parens found
         do i=index(line,')'),1,-1            ! find inner most set of parens
            if (line(i:i).eq.'(') exit
         enddo
         if (i.eq.0) then
            write(message,'(''*ufpp* FATAL - CONSTANT LOGICAL EXPRESSION REQUIRED:'',a)') trim(source)
            call stop_ufpp()
         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
                  write(message,'(''*ufpp* 1**(-1) NOT IMPLEMENTED YET'')')
                  call stop_ufpp()
               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
               write(message,'(''*ufpp* 1**(-1) NOT IMPLEMENTED YET'')')
               call stop_ufpp()
            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
      call nospace(line)
      cycle TILLDONE
   elseif (index(line,'(').ne.0) then
      write(message,'(''*ufpp* FATAL - CONSTANT LOGICAL EXPRESSION REQUIRED:'',a)') trim(source)
      call stop_ufpp()
   endif
   exit
   enddo TILLDONE
   end subroutine parens
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
   subroutine math(line,ipos1,ipos2)                             !@(#)
   character(len=line_length)      :: line
   character(len=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
   call nospace(line)

   end subroutine math
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
   subroutine domath(line,ipos2)                           !@(#) reduce integer expression containing  +-/* and ** operators
   character(len=*)                          :: line

   character(len=11)                         :: temp
   character(len=line_length)                :: newl
   character(len=2),save                     :: ops(3)= (/'**','*/','+-'/)
   integer                                   :: i
   integer                                   :: j
   integer                                   :: loc
   integer                                   :: minus1
!-----------------------------------------------------------------------------------------------------------------------------------
   if (ipos2.eq.0) return
   loc=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

        LEN=1                                    ! operator length
        IF (NUMOP.EQ.1) LEN=2
        IF (I.EQ.len_trim(NEWL)) then            ! if operator is at end of string
           WRITE(message,'(''*uffp* FATAL - INCOMPLETE STATEMENT. OPERATOR (**,/,*,+,-) AT STRING END:'',a)') trim(SOURCE)
           call stop_ufpp()
        endif
        IF (I.EQ.1.AND.NUMOP.NE.3) then          ! if operator at beginning of string and not +-
           WRITE(message,'(''*ufpp* FATAL - SYNTAX ERROR. OPERATOR (**,*,/) NOT ALLOWED TO PREFIX EXPRESSION:'',a)') trim(SOURCE)
           call stop_ufpp()
        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+len:i+len)).ne.0) then
              write(message,'(''*ufpp* FATAL - SYNTAX ERROR IN DOMATH(3f):'',a)') trim(source)
              call stop_ufpp()
           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+len,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
                 write(message,'(''*ufpp* FATAL - DIVIDE BY ZERO:'',a)') trim(source)
                 call stop_ufpp()
	      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
              write(message,'(''*ufpp* FATAL - INTERNAL PROGRAM ERROR:'',a)') trim(source)
              call stop_ufpp()
           end select
        endif

        if (i1.le.0) then
          if (j.eq.i-1.and.j.ne.1) then
            minus1=-1
            i1=abs(i1)
            loc=j+1
            newl(j+1:j+1)=' '
            l=l-1
            call nospace(newl)
          elseif (i.eq.1.and.numop.eq.3) then
            minus1=-1
            i1=abs(i1)
            loc=i
            newl(j:j)=' '
            l=l-1
            j=j-1
            call nospace(newl)
          else
            minus1=1
          endif
        else
          minus1=1
        endif
        write(temp,'(i11)') i1
        call 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 change_all(newl,'c@+-@-@')
	endif
      enddo TILLDONE
   enddo OVERALL

   if (minus1.eq.-1.and.(loc.eq.0.or.loc.eq.1)) then
      newl='-'//newl
   elseif (minus1.eq.-1.and.loc.ne.1) then
      newl=newl(:loc-1)//'-'//newl(loc:)
   endif

   line(:ipos2)=newl(:len_trim(newl))

   end subroutine domath
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
   subroutine doop(line,ipos1,ipos2)                       !@(#) find VAL.OP.VAL strings and reduce to .TRUE. or .FALSE.

   character(len=4),save       ::  ops(6) = (/'.EQ.','.NE.','.GE.','.GT.','.LE.','.LT.'/)
   character(len=var_len)      :: val1
   character(len=var_len)      :: val2
   character(len=7)            :: temp

   character(len=line_length)  :: newl                           !
   character(len=line_length)  :: line                           !
!-----------------------------------------------------------------------------------------------------------------------------------
   newl=line(ipos1:ipos2)
   CHECK_EACH_OP_TYPE: do i=1,6
      FIND_MORE_OF: do
         dc=.false.
         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)
            select case(i)                                       ! determine truth
            case(1)                                              ! .eq.
               if (val1.eq.val2) dc=.true.
            case(2)                                              ! .ne.
               if (val1.ne.val2) dc=.true.
            case(3)                                              ! .ge.
               if (val1.ge.val2) dc=.true.
            case(4)                                              ! .gt.
               if (val1.gt.val2) dc=.true.
            case(5)                                              ! .le.
               if (val1.le.val2) dc=.true.
            case(6)                                              ! .lt.
               if (val1.lt.val2) dc=.true.
            case default
            end select
            temp='.FALSE.'
            if (dc) temp='.TRUE.'
            call rewrit(newl,temp(:len_trim(temp)),j,j,k,k)
            call 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
   call nospace(line)
   end subroutine doop
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
   logical function trufal(line,ipos1,ipos2)                 ! @(#) convert variable name or .TRUE./.FALSE. to a logical value
   implicit none
   character(len=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=var_len)                :: value            ! substring to extract from LINE
   integer                               :: i                ! loop counter
   integer                               :: ios              ! error code returned by an internal READ
   integer                               :: ifound           ! index in dictionary at which a variable name was found, or -1
!-----------------------------------------------------------------------------------------------------------------------------------
   trufal=.false.                                            ! initialize return value
   value=line(ipos1:ipos2)                                   ! extract substring from LINE to interpret
   ifound=-1                                                 ! flag if successfully converted string, or index variable naem found

   select case (value)                                       ! if string is not a logical string assume it is a variable name
   case ('.FALSE.','.F.')
      ifound=0                                               ! set flag to indicate a good value has been found
      trufal=.false.                                         ! set appropriate return value
   case ('.TRUE.','.T.')
      ifound=0                                               ! set flag to indicate a good value has been found
      trufal=.true.                                          ! set appropriate return value
   case default                                              ! assume this is a variable name, find name in dictionary
      do i=1,numdef
         if (defvar(i).eq.value) then                        ! found variable name in dictionary
            ifound=i                                         ! record index in diction where variable was found
            exit
         endif
      enddo

      if (ifound.eq.-1) then                                 ! if not a defined variable name stop program
         write(message,'(''*ufpp* FATAL - UNDEFINED PARAMETER.'',a)') trim(source)
         call stop_ufpp()
      endif

      read(defval(ifound),'(l4)',iostat=ios) trufal          ! try to read a logical from from the value for the variable name

      if(ios.ne.0)then                                       ! not successful in reading string as a logical value
            write(message,'(''*ufpp* FATAL - CONSTANT LOGICAL EXPRESSION REQUIRED.'',a)') trim(source)
            call stop_ufpp()
      endif

   end select

   if (ifound.lt.0) then                                     ! not a variable name or string '.TRUE.' or '.FALSE.'
      write(message,'(''*ufpp* FATAL - CONSTANT LOGICAL EXPRESSION REQUIRED:'',a)') trim(source)
      call stop_ufpp()
   endif

   end function trufal
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
   subroutine logic(line,ipos1,ipos2)           !@(#) process .OP. operator strings
   character(len=*)             :: line
   integer,intent(in)           :: ipos1, ipos2

   logical                      :: one, two
   character(len=7)             :: temp
   character(len=line_length)   :: newl
   character(len=6),save        :: ops(5)= (/'.NOT. ','.AND. ','.OR.  ','.EQV. ','.NEQV.'/)
!-----------------------------------------------------------------------------------------------------------------------------------
   NEWL=LINE(IPOS1:IPOS2)
   LEN1=0
   LEN2=0
   ONE=.FALSE.
   LOOP: DO I=1,3
20      continue
        LEN=5
        IF (I.EQ.3) LEN=4
        IF (INDEX(NEWL,OPS(I)(:len_trim(OPS(I)))).EQ.0) cycle
        I1=INDEX(NEWL,OPS(I)(:len_trim(OPS(I))))-1
        J=I1+1
        LEN1=0
        IF (I.NE.1) then
           OUTER: DO J=I1,1,-1
             INNER: DO K=1,5
                LEN1=5
                IF (K.EQ.3) LEN1=4
                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
           ONE=TRUFAL(NEWL,J+LEN1,I1)
        endif
!-------------------------------------------------------------------------
        OUT: DO L=I1+LEN,len_trim(NEWL)
          IN: DO K=1,5
             LEN2=5
             IF (K.EQ.3) LEN2=4
             IF (INDEX(NEWL(I1+LEN:L),OPS(K)(:len_trim(OPS(K)))).NE.0) exit OUT
          enddo IN
        enddo OUT
!-------------------------------------------------------------------------
        IF (L.GT.len_trim(NEWL)) LEN2=0
        TWO=TRUFAL(NEWL,I1+LEN+1,L-LEN2)
        !-------------------------------------
        select case(i)
        !-------------------------------------
        case(1)
           dc=.not.two
        !-------------------------------------
        case(2)
           dc=one.and.two
        !-------------------------------------
        case(3)
           dc=one.or.two
        !-------------------------------------
        case default
           write(message,*)'*ufpp* internal error'
           call stop_ufpp()
        end select
        !-------------------------------------
        temp='.FALSE.'
        if (dc) temp='.TRUE.'
        call rewrit(newl,temp(:len_trim(temp)),j,j+len1-1,l,l-len2+1)
        goto 20
   enddo LOOP
   TILLDONE: do
      ieqv=index(newl,'.EQV.')
      ineqv=index(newl,'.NEQV')
      if (ieqv*ineqv.eq.0.and.ieqv.ne.ineqv) then
        iop=max(ieqv,ineqv)
      elseif (ieqv.ne.0) then
        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
      len=5
      if (index(newl,'.EQV.').ne.iop) len=6
      do j=iop-1,1,-1
         if (newl(j:j+1).eq.'V.') exit
      enddo
      if (j.eq.0) len1=1
      one=trufal(newl,j+len1,iop-1)
      do l=iop+len,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
      two=trufal(newl,iop+len,l+len2)
      dc=one.eqv.two
      if (len.ne.5) dc=one.neqv.two
      temp='.FALSE.'
      if (dc) temp='.TRUE.'
      call rewrit(newl,temp(:len_trim(temp)),j,j+len1-1,l,l-len2+1)
   enddo TILLDONE
   end subroutine logic
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
   subroutine eval(line)                                   !@(#) evaluate math expression to .TRUE. or .FALSE.
   character(len=line_length)     :: line
   character(len=7)               :: value
!-----------------------------------------------------------------------------------------------------------------------------------
   call parens(line)
   call math(line,1,len_trim(line))
   call doop(line,1,len_trim(line))
   call logic(line,1,len_trim(line)) 
   value=line(1:7)

   if (value.ne.'.TRUE.'.and.value.ne.'.FALSE.') then
      write(message,'(''*ufpp* FATAL - value neither true or false:'',a,'' when evaluating  '',a)') trim(value), trim(source)
      call stop_ufpp()
   endif

   read(value,'(l4)') dc

   end subroutine eval
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
   function get_integer_from_string(line,ipos1,ipos2) !@(#) read integer value from line(ipos1:ipos2)
                                                      ! assume string is a variable name or an integer value
   implicit none
   character(len=*),intent(in)  :: line                             ! string containing substring to read an integer value from
   integer,intent(in)           :: ipos1                            ! lower bound of substring in input line to convert
   integer,intent(in)           :: ipos2                            ! upper bound of substring in input line to convert
   character(len=var_len)       :: value                            ! the substring
   integer                      :: i                                ! index of variable dictionary where variable name is stored
   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
!-----------------------------------------------------------------------------------------------------------------------------------
   if (line(ipos1:ipos1).ge.'A'.and.line(ipos1:ipos1).le.'Z') then  ! not a number, now assumed to  be a variable name
      value= line(ipos1:ipos2)                                      ! extract substring that is assumed to be a variable name
      i=-1                                                          ! this will be index where variable name is found in dictionary
      do i=1,numdef                                                 ! scan variable dictionary for the variable name
        if (defvar(i).eq.value) exit
      enddo
      if (i.gt.numdef.or.i.lt.0)then                                ! if variable name not found in dictionary, stop
        write(message,'(''*ufpp* FATAL - UNDEFINED PARAMETER:'',a)') trim(source)
        call stop_ufpp()
      endif
      read(defval(i),'(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
        write(message,'(''*ufpp* FATAL - MUST BE INTEGER:'',a)') trim(source)
        call stop_ufpp()
      endif
   else                                                             ! input is not a variable name, assume it represents an integer
      read(line(ipos1:ipos2),'(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
        write(message,'(''*ufpp* FATAL - MUST BE INTEGER:'',a)') trim(source)
        call stop_ufpp()
      endif
   endif                                                            ! return integer value
   end function get_integer_from_string
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
   subroutine rewrit(line,temp,j,j1,l,l1)                           !@(#)

   character temp*(*)
   character(len=line_length)  line
!-----------------------------------------------------------------------------------------------------------------------------------

   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
   end subroutine rewrit
!===================================================================================================================================
   subroutine debug()                                                  !@(#) process $SHOW command or state output when errors occur
!-----------------------------------------------------------------------------------------------------------------------------------
   write(*,'(a)')'!==============================================================================='
   write(*,'("! *ufpp* CURRENT STATE ...")')
   write(*,'("! *ufpp*    TOTAL LINES READ=",i11)')iototallines        ! write number of lines read
   write(*,'("! *ufpp*    CONDITIONAL_NESTING_LEVEL=",i4)')nestl       ! write nesting level

   write(*,'(a)')'! *ufpp* VARIABLES:'
   do i=1,numdef                                                       ! print variable dictionary
      write(*,'("! *ufpp*    ! ",a," ! ",a)'),defvar(i),defval(i)      ! write variable and corresponding value
   enddo

   write(*,'(a)')'! *ufpp* OPEN FILES:'
   write(*,'(a)')'! *ufpp*    ! xxxx ! UNIT ! LINE NUMBER ! FILENAME'
   do i=1,iocount                                                      ! print file dictionary
      write(*,'("! *ufpp*    ! ",i4," ! ",i4," ! ",i11," ! ",a)')i,iin(i),iline_number(i),trim(files(i)) ! write table of open files
   enddo

   write(*,'(a)')'!==============================================================================='
   end subroutine debug
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
   subroutine include(line,iunit)                         ! add file to input file list
   implicit none
   character(len=line_length),intent(in) :: line
   integer                               :: iunit
   integer                               :: ios
!-----------------------------------------------------------------------------------------------------------------------------------
   if(iunit.eq.5.or.line.eq.'@')then      ! assume this is stdin
      iocount=iocount+1
      iin(iocount)=5
      files(iocount)=line
      return
   endif

   call findit(line)

   open(unit=iunit,file=trim(line),iostat=ios,status='old',action='read')
   if(ios.ne.0)then
      write(message,'("*uffp* FATAL - FAILED OPEN OF INPUT FILE(",i4,"):",a)') iunit, trim(line)
      call debug()
      call stop_ufpp()
   else
      iocount=iocount+1
      if(iocount.gt.size(iin))then
         write(message,'(''*uffp* FATAL - INPUT FILE NESTING TOO DEEP:'',a)') trim(source)
         call stop_ufpp()
      endif
      iin(iocount)=iunit
      files(iocount)=line
      iline_number(iocount)=0
   endif

   end subroutine include
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
   subroutine findit(line)     !@(#) look for filename in search directories if name does not exist and return modified name
   implicit none
   character(len=line_length)            :: line
   character(len=line_length)            :: filename
   logical                               :: file_exist
   integer                               :: i
   integer                               :: iend_dir

   inquire(file=trim(line), exist=file_exist)

   if(file_exist)then
      return
   endif

   do i=1,inc_count
      iend_dir=len_trim(inc_files(i))
      if(inc_files(i)(iend_dir:iend_dir).ne.'/')then
         filename=inc_files(i)(:iend_dir)//'/'//trim(line)
      else
         filename=inc_files(i)(:iend_dir)//trim(line)
      endif
      inquire(file=trim(filename), exist=file_exist)
      if(file_exist)then
         line=filename
	 return
      endif
   enddo

   write(message,'(''*uffp* FATAL - MISSING INPUT FILE:'',a)') trim(source)
   call stop_ufpp()

   end subroutine findit
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
   subroutine opens()                                               !@(#)  use expression on command line to  open input files
   use M_kracken, only: delim, sget                                 ! load command argument parsing module

   integer,parameter                     :: n=50                    ! maximum number of tokens to look for
   character(len=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                               :: ilen                    ! is the position of last non‐blank character in INLINE
!-----------------------------------------------------------------------------------------------------------------------------------
   call delim(sget('cmd_i'),array,n,icount,ibegin,iterm,ilen,dlim) ! break command argument cmd_i into single words
   ivalue=50  ! starting file unit to use
   do i=icount,1,-1
      source='$include '//trim(array(i))  ! for messages
      call include(array(i),ivalue)
      ivalue=ivalue+1
   enddo

!   If ARRAY(N) fills before reaching the end of the line the routine stops.
!   Check "if(iend(icount) .eq. ilen)" to see if you got to the end.

   end subroutine opens
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
   subroutine includes()                                            !@(#)  use expression on command line to  get include directories
   use M_kracken, only: delim, sget                                 ! load command argument parsing module

   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 INC_FILES
   integer                               :: iterm(n)                ! ending column numbers for the tokens in INC_FILES
   integer                               :: ilen                    ! is the position of last non‐blank character in INC_FILES
!-----------------------------------------------------------------------------------------------------------------------------------
   ! inc_files is the array to fill with tokens
   ! inc_count is the number of tokens found
!-----------------------------------------------------------------------------------------------------------------------------------
   call delim(sget('cmd_I'),inc_files,n,inc_count,ibegin,iterm,ilen,dlim) ! break command argument cmd_I into single words
   end subroutine includes
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
   subroutine defines()                                             !@(#)  use expressions on command line to define variables
   use M_kracken, only: delim, sget                                 ! load command argument parsing module
   integer,parameter                     :: n=128                   ! maximum number of tokens to look for
   character(len=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                               :: ilen                    ! is the position of last non‐blank character in INLINE
!-----------------------------------------------------------------------------------------------------------------------------------
   call delim(sget('cmd_oo'),array,n,icount,ibegin,iterm,ilen,dlim) ! break command argument CMD_OO into single words
   do i=1,icount
      source='$define '//trim(array(i))
      call cond()
   enddo

!   If ARRAY(N) fills before reaching the end of the line the routine stops.
!   Check "if(iend(icount) .eq. ilen)" to see if you got to the end.

   end subroutine defines
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
   subroutine stop_ufpp                   !@(#) write MESSAGE to stderr
   USE ISO_FORTRAN_ENV, ONLY : ERROR_UNIT ! access computing environment ; Standard: Fortran 2003
   implicit none
   write(ERROR_UNIT,'(a)')trim(message)
   call debug()
   stop
   end subroutine stop_ufpp
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
      SUBROUTINE change_all(CDUM,CSTRNG) ! CHANGE A CHARACTER STRING
!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
!@(#) CHANGE A CHARACTER STRING LIKE XEDIT CHANGE OR C COMMAND
!     CDUM CONTAINS LINE TO BE CHANGED
!     CSTRNG CONTAINS THE COMMAND CHANGING THE STRING(LESS THE COUNT PARAM)
!
!     THIS ROUTINE DOES NOT ALLOW FOR SEPARATORS ON THE CHANGE COMMAND
!     (...) OR .NOT.CONTAINING (---).
!
!     THE COMMAND MUST BE OF THE FORM:
!      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
!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      CHARACTER*(*) CDUM,CSTRNG             ! USE STRING LENGTH
      PARAMETER (MAXSCR=255)                ! MAXIMUM SCRATCH LENGTH
      CHARACTER*(MAXSCR) STR1,STR2,DUM1     ! SCRATCH STRING BUFFERS
      ML=1                                  ! ML SETS THE LEFT  MARGIN
      MR=len(CDUM)                          ! MR SETS THE RIGHT MARGIN
      LMAX=MIN0(LEN(CDUM),MAXSCR)           ! MAX LENGTH OF NEW STRING
      LCDUM=JULEN(CDUM)                     ! GET NON-BLANK LENGTH OF LINE
!     CRACK THE DIRECTIVES LINE
      STR1(:)=' '                           ! INITIALIZE STRINGS
      STR2(:)=' '                           ! INITIALIZE STRINGS
      DUM1(:)=' '                           ! INITIALIZE STRINGS
      LDIR=JULEN(CSTRNG)                    ! FIND LAST CHARACTER IN DIRECTIVE
      ID=2
      IF(CSTRNG(2:2).EQ.'W')ID=3            ! CHECK FOR WINDOW OPTION
      ID1=ID+1                              ! DELIMITER CHARACTER + 1
!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      IF(LDIR.LT.3+ID)then                  ! IF BAD DIRECTIVE
         message='*change* bad directive'
         call stop_ufpp()
      endif
      IF(CSTRNG(ID:ID).NE.CSTRNG(LDIR:LDIR))then
         message='*change* unmatched delimiters'
         call stop_ufpp()
      endif
      IDEL=INDEX(CSTRNG(ID1:LDIR-1),CSTRNG(ID:ID))    ! FIND MID DELIM
      IF(IDEL.EQ.0)then                               ! IF NO MID DELIM
         message='*change* missing middle delimiter'
         call stop_ufpp()
      endif
      IF(IDEL.GT.1)STR1=CSTRNG(ID1:IDEL+ID-1)         ! STRING TO BE CHANGED
      LS1=IDEL-1                                      ! STRING OF STRING TBC
      IF(IDEL+ID.LT.LDIR-1)STR2=CSTRNG(IDEL+ID1:LDIR-1) ! NEW STRING
      LS2=LDIR-IDEL-ID1                               ! LENGTH OF NEW STRING
      IF(LS2.GT.0)THEN
         IF(INDEX(STR2(:LS2),CSTRNG(ID:ID)).NE.0)then ! EXTRA DELIMITER
            message='*change* extra delimiter'
            call stop_ufpp()
	 endif
      ENDIF
!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
!     DIRECTIVES HAVE BEEN CRACKED, NOW IMPLEMENT
      IF(ID.EQ.2)THEN                       ! NO WINDOW
         IL=1                               ! IL TO LEFT MARGIN
         IR=LMAX                            ! IR TO RIGHT MOST ALLOWED
      ELSE                                  ! IF WINDOW IS SET
         IL=ML                              ! USE LEFT MARGIN
         IR=MIN0(MR,LMAX)                   ! USE RIGHT MARGIN OR RIGHT MOST
      ENDIF                                 ! END OF WINDOW SETTINGS
!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      IF(IL.EQ.1)THEN                       ! IF LEFT MARGIN IS 1
         DUM1(:)=' '                        ! BEGIN WITH A BLANK LINE
      ELSE                                  ! IF LEFT MARGIN NOT 1
         DUM1=CDUM(:IL-1)                   ! BEGIN WITH WHAT'S BELOW MARGIN
      ENDIF
!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      IF(LS1.EQ.0)THEN                      ! c//str2/ means insert str2 at beginning of line (or left margin)
         ICHAR=LS2 + LCDUM
         IF(ICHAR.GT.LMAX)then
            message='*change* new line will be too long'
            call stop_ufpp()
	 endif
         IF(LS2.GT.0)THEN
            DUM1(IL:)=STR2(:LS2)//CDUM(IL:LCDUM)
         ELSE
            DUM1(IL:)=CDUM(IL:LCDUM)
         ENDIF
         CDUM(1:LMAX)=DUM1(:LMAX)
         IER=1                              ! Made one change. Actually, c/// should maybe return 0
         RETURN
      ENDIF
!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      IER=0
      ICHAR=IL
      IC=IL
!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      do
         IND=INDEX(CDUM(IC:),STR1(:LS1))+IC-1
         IF(IND.EQ.IC-1.OR.IND.GT.IR) exit
         IER=IER+1
         IF(IND.GT.IC)THEN
            LADD=IND-IC
            IF(ICHAR-1+LADD.GT.LMAX)then
               message='*change* new line will be too long'
               call stop_ufpp()
   	 endif
            DUM1(ICHAR:)=CDUM(IC:IND-1)
            ICHAR=ICHAR+LADD
         ENDIF
         IF(ICHAR-1+LS2.GT.LMAX)then
            message='*change* new line will be too long'
            call stop_ufpp()
         endif
         IF(LS2.NE.0)THEN
            DUM1(ICHAR:)=STR2(:LS2)
            ICHAR=ICHAR+LS2
         ENDIF
         IC=IND+LS1
      enddo
!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      IF(IER.EQ.0)RETURN
      LADD=LCDUM-IC
      IF(ICHAR+LADD.GT.LMAX)then
         message='*change* new line will be too long'
         call stop_ufpp()
      endif
      if(ic.lt.len(cdum))then
         DUM1(ICHAR:)=CDUM(IC:max(ic,LCDUM))
      endif
      CDUM=DUM1(:LMAX)
      END SUBROUTINE change_all
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
subroutine help()
implicit none
!-----------------------------------------------------------------------------------------------------------------------------------
! This documentation is a combination of the original Lahey documentation of fpp(1) from
! "LAHEY FORTRAN REFERENCE MANUAL"; Revision C, 1992;
! examination of the code and documentation of the features subsequently added to the program.
!-----------------------------------------------------------------------------------------------------------------------------------
write(*,'(a)')'ufpp(1)                       User Commands                            ufpp(1)  '
write(*,'(a)')'                                                                                '
write(*,'(a)')'NAME                                                                            '
write(*,'(a)')'   ufpp - preprocess FORTRAN source files (Lahey Compiler Style)                '
write(*,'(a)')'                                                                                '
write(*,'(a)')'SYNOPSIS                                                                        '
write(*,'(a)')'                                                                                '
write(*,'(a)')'   ufpp [define_list]                                                           '
write(*,'(a)')'        [-i input_file(s)]                                                      '
write(*,'(a)')'        [-o output_file]                                                        '
write(*,'(a)')'        [-I include_directories]                                                '
write(*,'(a)')'        [-prefix character]                                                     '
write(*,'(a)')'        [-version]                                                              '
write(*,'(a)')'        [-help]                                                                 '
write(*,'(a)')'                                                                                '
write(*,'(a)')'   define_list                                                                  '
write(*,'(a)')'       A list of variable names and optional expressions used to                '
write(*,'(a)')'       define variables before file processing commences, delimited by spaces.  '
write(*,'(a)')'                                                                                '
write(*,'(a)')'   -i input_files                                                               '
write(*,'(a)')'       The default input file is stdin. Filenames are space-delimited.          '                                        '
write(*,'(a)')'       In a list, @ represents stdin.                                           '                                        '
write(*,'(a)')'                                                                                '
write(*,'(a)')'   -o output_file                                                               '
write(*,'(a)')'       The default output file is stdout.                                       '
write(*,'(a)')'                                                                                '
write(*,'(a)')'   -I include directories                                                       '
write(*,'(a)')'       The directories to find files in that appear on $INCLUDE directives.     '                                        '
write(*,'(a)')'                                                                                '
write(*,'(a)')'   -prefix prefix_character                                                     '
write(*,'(a)')'       The default directive prefix character is "$". "#" may be specified      '
write(*,'(a)')'       as an alternate prefix.                                                  '
write(*,'(a)')'                                                                                '
write(*,'(a)')'   -help                                                                        '
write(*,'(a)')'       Display documentation and exit                                           '
write(*,'(a)')'                                                                                '
write(*,'(a)')'   -version                                                                     '
write(*,'(a)')'       Display version and exit                                                 '
write(*,'(a)')'                                                                                '
write(*,'(a)')'DESCRIPTION                                                                     '
write(*,'(a)')'                                                                                '
write(*,'(a)')'   By default the  stand-alone  pre-processor  ufpp(1)  will  interpret lines   '
write(*,'(a)')'   with "$" in column one, and will output a file containing no "$" lines.      '
write(*,'(a)')'   Other input is conditionally written to the output file based on the         '
write(*,'(a)')'   directives encountered in the input.                                         '
write(*,'(a)')'                                                                                '
write(*,'(a)')'   Compiler  directives are specified by a "$" in column one, followed by a     '
write(*,'(a)')'   keyword. The syntax and parsing rules of the text following the "$"  are     '
write(*,'(a)')'   essentially   like   FORTRAN   source, eg., spaces (blanks) are ignored,     '
write(*,'(a)')'   upper and lower case are equivalent.   However,   expressions   do   not     '
write(*,'(a)')'   need  to  be enclosed in parentheses.                                        '
write(*,'(a)')'                                                                                '
write(*,'(a)')'   The  syntax  for  the  control  lines  "$DEFINE", "$UNDEFINE", "$INCLUDE",   '
write(*,'(a)')'   "$IF", "$ELSE",  "$ELSEIF",  and "$ENDIF", is as follows:                    '
write(*,'(a)')'                                                                                '
write(*,'(a)')'     $DEFINE   variable_name[=expression]                 [! comment ]          '
write(*,'(a)')'     $UNDEFINE variable_name                              [! comment ]          '
write(*,'(a)')'     $PRINTENV environment_variable_name                  [! comment ]          '
write(*,'(a)')'     $INCLUDE  filename                                   [! comment ]          '
write(*,'(a)')'     $IF       <constant LOGICAL expression>              [! comment ]          '
write(*,'(a)')'               < sequence of FORTRAN source statements>                         '
write(*,'(a)')'     [$ELSEIF  <constant LOGICAL expression>              [! comment ]          '
write(*,'(a)')'               < sequence of FORTRAN source statements>]                        '
write(*,'(a)')'     [$ELSE                                               [! comment ]          '
write(*,'(a)')'               < sequence of FORTRAN source statements>]                        '
write(*,'(a)')'     $ENDIF                                               [! comment ]          '
write(*,'(a)')'                                                                                '
write(*,'(a)')'   An  exclamation character on a valid directive begins an in-line comment     '
write(*,'(a)')'   that is terminated by an end-of-line.                                        '
write(*,'(a)')'                                                                                '
write(*,'(a)')'   Each  of the control lines delineates a block of FORTRAN source.  If the     '
write(*,'(a)')'   expression following the $IF is ".TRUE.",  then  the  lines  of  FORTRAN     '
write(*,'(a)')'   source  following  are  output.  If  it  is  ".FALSE.", and an $ELSEIF       '
write(*,'(a)')'   follows, the expression is evaluated and treated the same as the $IF. If     '
write(*,'(a)')'   the  $IF  and  all  $ELSEIF expressions are ".FALSE.", then the lines of     '
write(*,'(a)')'   source following the $ELSE are output. A matching $ENDIF ends the            '
write(*,'(a)')'   conditional block.                                                           '
write(*,'(a)')'                                                                                '
write(*,'(a)')'   Any  LOGICAL  expression  composed  of  integer constants,  parameters       '
write(*,'(a)')'   names operators, and the DEFINED function is valid if valid on a $IF and     '
write(*,'(a)')'   $ELSEIF.                                                                     '
write(*,'(a)')'                                                                                '
write(*,'(a)')'   Logical operators are ".NOT.",".AND.",".OR.",".EQV.", and ".NEQV."; and      '
write(*,'(a)')'   ".EQ.",".NE.",".GE.",".GT.",".LE.", and ".LT.", and                          '
write(*,'(a)')'   "+,"-","*","/","(",")" and "**".                                             '
write(*,'(a)')'                                                                                '
write(*,'(a)')'   Constant parameters e defined from the point they are uncountered in a       '
write(*,'(a)')'   $DEFINE directive until program termination unless explicitly                '
write(*,'(a)')'   undefined with a $UNDEFINE directive.                                        '
write(*,'(a)')'                                                                                '
write(*,'(a)')'   ------------------------------------                                         '
write(*,'(a)')'   $DEFINE <parameter> [= <expression>]                                         '
write(*,'(a)')'   ------------------------------------                                         '
write(*,'(a)')'                                                                                '
write(*,'(a)')'   A $DEFINE may appear anywhere in a source file. If the value is ".TRUE."     '
write(*,'(a)')'   or ".FALSE." then the  parameter  is  of  type  LOGICAL,  otherwise  the     '
write(*,'(a)')'   parameter  is  of  type  INTEGER and the value must be an INTEGER. If no     '
write(*,'(a)')'   value is supplied, the parameter is of type INTEGER  and  is  given  the     '
write(*,'(a)')'   value 1. The DEFINED() parameter is NOT valid in a $DEFINE directive.        '
write(*,'(a)')'                                                                                '
write(*,'(a)')'                                                                                '
write(*,'(a)')'   ----------------                                                             '
write(*,'(a)')'   DEFINED function                                                             '
write(*,'(a)')'   ----------------                                                             '
write(*,'(a)')'                                                                                '
write(*,'(a)')'   Syntax:                                                                      '
write(*,'(a)')'                                                                                '
write(*,'(a)')'     DEFINED (<parameter>)                                                      '
write(*,'(a)')'                                                                                '
write(*,'(a)')'   If  <parameter>  has been defined at that point in the source code, then     '
write(*,'(a)')'   the function value is ".TRUE.", otherwise it is  ".FALSE.".  A  name  is     '
write(*,'(a)')'   defined  only  if  it has appeared in the source previously in a $DEFINE     '
write(*,'(a)')'   directive. The names used in compiler directives are district from names     '
write(*,'(a)')'   in  the  FORTRAN  source, which means that "a" in a $DEFINE and "a" in a     '
write(*,'(a)')'   FORTRAN source statement are totally unrelated.  The DEFINED() function      '
write(*,'(a)')'   is valid only on a $IF or $ELSEIF directive.                                 '
write(*,'(a)')'                                                                                '
write(*,'(a)')'     Example:                                                                   '
write(*,'(a)')'                                                                                '
write(*,'(a)')'            Program test                                                        '
write(*,'(a)')'     $IF .NOT. DEFINED (inc)                                                    '
write(*,'(a)')'            INCLUDE ''comm.inc''                                                '
write(*,'(a)')'     $ELSE                                                                      '
write(*,'(a)')'            INCLUDE ''comm2.inc''                                               '
write(*,'(a)')'     $ENDIF                                                                     '
write(*,'(a)')'            END                                                                 '
write(*,'(a)')'                                                                                '
write(*,'(a)')'   The file,  "comm.inc"  will  be INCLUDEd in the source if the parameter,     '
write(*,'(a)')'   "inc", has not been previously defined, while INCLUDE  "comm2.inc"  will     '
write(*,'(a)')'   be  included in the source if "inc" has been previously defined. This is     '
write(*,'(a)')'   useful for setting up a default inclusion.                                   '
write(*,'(a)')'                                                                                '
write(*,'(a)')'   $define A=1                                                                  '
write(*,'(a)')'   $define B=1                                                                  '
write(*,'(a)')'   $define C=2                                                                  '
write(*,'(a)')'   $if ( A + B ) / C .eq. 1                                                     '
write(*,'(a)')'      (a+b)/c is one                                                            '
write(*,'(a)')'   $endif                                                                       '
write(*,'(a)')'                                                                                '
write(*,'(a)')'   -------------------                                                          '
write(*,'(a)')'   $UNDEFINE directive                                                          '
write(*,'(a)')'   -------------------                                                          '
write(*,'(a)')'   A  symbol  defined  with  $DEFINE  can  be  removed  with  the $UNDEFINE     '
write(*,'(a)')'   directive, whose syntax is:                                                  '
write(*,'(a)')'                                                                                '
write(*,'(a)')'     $UNDEFINE <parameter>                                                      '
write(*,'(a)')'                                                                                '
write(*,'(a)')'                                                                                '
write(*,'(a)')'  --------------                                                                '
write(*,'(a)')'  $PRINTENV NAME                                                                '
write(*,'(a)')'  --------------                                                                '
write(*,'(a)')'                                                                                '
write(*,'(a)')'  If the name of an uppercase environmental variable is given the value         '
write(*,'(a)')'  of the variable will be placed in the output file. If the value is a          '
write(*,'(a)')'  null string or if the variable is undefined output will be stopped.           '
write(*,'(a)')'  This allows the system shell to generate code lines. This is usually          '
write(*,'(a)')'  used to pass in information about the compiler environment. For               '
write(*,'(a)')'  example:                                                                      '
write(*,'(a)')'  # If the following command were executed in the bash(1) shell...              '
write(*,'(a)')'                                                                                '
write(*,'(a)')'  export STAMP="      write(*,*)''COMPILED ON:`uname -s`;AT `date`''"             '
write(*,'(a)')'                                                                                '
write(*,'(a)')'  the environmental variable STAMP would be set to something like               '
write(*,'(a)')'                                                                                '
write(*,'(a)')'     write(*,*)''COMPILED ON:Eureka;AT Wed, Jun 12, 2013  8:12:06 PM''            '
write(*,'(a)')'                                                                                '
write(*,'(a)')'  A version number would be another possibility                                 '
write(*,'(a)')'                                                                                '
write(*,'(a)')'     export VERSION="      program_version=2.1"                                 '
write(*,'(a)')'                                                                                '
write(*,'(a)')'  Special predefined variable names are:                                        '
write(*,'(a)')'                                                                                '
write(*,'(a)')'     UFPP_DATE  ->      UFPP_DATE="12:58 14Jun2013"                             '
write(*,'(a)')'  Where code is assumed to have defined UFPP_DATE as CHARACTER(LEN=15)          '
write(*,'(a)')'     UFPP_FILE  ->      UFPP_FILE="current filename"                            '
write(*,'(a)')'  Where code is assumed to have defined UFPP_FILE as CHARACTER(LEN=1024)        '
write(*,'(a)')'     UFPP_LINE  ->      UFPP_LINE=    nnnnnn                                    '
write(*,'(a)')'  Where code is assumed to have defined UFPP_FILE as INTEGER                    '
write(*,'(a)')'                                                                                '
write(*,'(a)')'  ---------                                                                     '
write(*,'(a)')'  Examples:                                                                     '
write(*,'(a)')'  ---------                                                                     '
write(*,'(a)')'  ----------------------------------------------------------------------------- '
write(*,'(a)')'  Simple usage:                                                                 '
write(*,'(a)')'  -------------                                                                 '
write(*,'(a)')'  $DEFINE a=1                                                                   '
write(*,'(a)')'  C                                                                             '
write(*,'(a)')'  C Will only compile the first version of SUB1.                                '
write(*,'(a)')'  C                                                                             '
write(*,'(a)')'        PROGRAM conditional compile                                             '
write(*,'(a)')'        CALL sub1                                                               '
write(*,'(a)')'        END                                                                     '
write(*,'(a)')'  C                                                                             '
write(*,'(a)')'  C                                                                             '
write(*,'(a)')'  $IF a .EQ. 1                                                                  '
write(*,'(a)')'         SUBROUTINE sub1                                                        '
write(*,'(a)')'         PRINT*, "This is the first SUB1"                                       '
write(*,'(a)')'         END                                                                    '
write(*,'(a)')'  C                                                                             '
write(*,'(a)')'  $ELSE                                                                         '
write(*,'(a)')'         SUBROUTINE sub1                                                        '
write(*,'(a)')'         PRINT*, "This is the second SUB1"                                      '
write(*,'(a)')'         END                                                                    '
write(*,'(a)')'  C                                                                             '
write(*,'(a)')'  $ENDIF                                                                        '
write(*,'(a)')'  ----------------------------------------------------------------------------- '
write(*,'(a)')'  Define variables on command line:                                             '
write(*,'(a)')'  ---------------------------------                                             '
write(*,'(a)')'  ufpp HP SIZE=64bit -i hp_directives.dirs @ < test.F90 >test_out.f90           '
write(*,'(a)')'                                                                                '
write(*,'(a)')'  defines variables HP and SIZE as if the expressions had been on a $DEFINE     '
write(*,'(a)')'  and reads file "hp_directives.dirs" and then stdin.  Unix redirection puts    '
write(*,'(a)')'  test.F90 onto stdin and redirects output to test_out.f90                      '
write(*,'(a)')'  ----------------------------------------------------------------------------- '
write(*,'(a)')'                                                                                '
write(*,'(a)')'   -----------                                                                  '
write(*,'(a)')'   LIMITATIONS                                                                  '
write(*,'(a)')'   -----------                                                                  '
write(*,'(a)')'   $IF  constructs  can  be nested up to eight levels deep. Note that using     '
write(*,'(a)')'   more than two levels typically makes input files less readable.              '
write(*,'(a)')'                                                                                '
write(*,'(a)')'   Input files                                                                  '
write(*,'(a)')'       o lines are limited to 1024 columns. Text past column 1024 is ignored.   '
write(*,'(a)')'       o files already opened cannot be opened again.                           '
write(*,'(a)')'       o a maximum of 50 files can be nested by $INCLUDE                        '
write(*,'(a)')'       o filenames cannot contain spaces on the command line.                   '
write(*,'(a)')'                                                                                '
write(*,'(a)')'   Variable names                                                               '
write(*,'(a)')'       o cannot be redefined unless first undefined.                            '
write(*,'(a)')'       o are limited to ',var_len,' characters.                                        '
write(*,'(a)')'       o must start with a letter (A-Z).                                        '
write(*,'(a)')'       o are composed of the letters A-Z, digits 0-9 and _ and $.               '
write(*,'(a)')'       o 128 variable names may be defined at a time.                                 '
write(*,'(a)')'                                                                                '
write(*,'(a)')'   ---------------------------------------------                                '
write(*,'(a)')'   Major cpp(1) features not present in ufpp(1):                                '
write(*,'(a)')'   ---------------------------------------------                                '
write(*,'(a)')'                                                                                '
write(*,'(a)')'   There is no option to specify directories to search for included files.      '
write(*,'(a)')'   The FORTRAN INCLUDE statement can be used instead in  cases  where           '
write(*,'(a)')'   the included file does not contain preprocessing directives.                 '
write(*,'(a)')'                                                                                '
write(*,'(a)')'   There are no predefined preprocessor symbols. Use a directive input file     '
write(*,'(a)')'   instead.                                                                     '
write(*,'(a)')'                                                                                '
write(*,'(a)')'   This program does not provide  string  (macro)  substitution  in  output     '
write(*,'(a)')'   lines.  See cpp(1) and m4(1) and related utilities if macro expansion is     '
write(*,'(a)')'   required.                                                                    '
write(*,'(a)')'                                                                                '
write(*,'(a)')'   While   cpp(1)  is the de-facto standard for preprocessing Fortran code,     '
write(*,'(a)')'   Part 3  of  the  Fortran  95  standard  (ISO/IEC  1539-3:1998)   defines     '
write(*,'(a)')'   Conditional    Compilation,     but   it  is   (currently) not    widely     '
write(*,'(a)')'   supported (See coco(1)).                                                     '
write(*,'(a)')'--------------------------------------------------------------------------------'
write(*,'(a)')'   -----------                                                                  '
write(*,'(a)')'   BUGS                                                                         '
write(*,'(a)')'   -----------                                                                  '
write(*,'(a)')'   Expressions that return negative numbers are not handled properly under      '
write(*,'(a)')'   all conditions                                                               '
write(*,'(a)')'$define name = 44                                                               '
write(*,'(a)')'$define a = 22                                                                  '
write(*,'(a)')'$define c = name + a                                                            '
write(*,'(a)')'$define d = a + a - name                                                        '
write(*,'(a)')'# PRODUCES:                                                                     '
write(*,'(a)')'# *ufpp* FATAL - SYNTAX ERROR:$define d = a + a - name                          '
write(*,'(a)')'--------------------------------------------------------------------------------'
end subroutine help
!===================================================================================================================================
end module M_fpp
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
   program ufpp                                            !@(#) preprocessor for Fortran/FORTRAN source code
   !implicit none
   !--------------------------------------------------------
   use M_fpp
   !use M_fpp, only : line_length, source, write, nestl, iin, iocount, iototallines, iline_number, message
   ! LINE_LENGTH   current input line
   ! SOURCE        allowed length of input lines
   ! WRITE         flag whether current data lines should be written
   ! NESTL         nesting level for $IF/$ELSEIF/$ELSE/$ENDIF
   ! IIN()
   ! IOCOUNT
   ! LINE_LENGTH
   !--------------------------------------------------------
   use M_kracken, only: kracken, lget, rget, iget, sget, retrev, sgetl
   character(len=line_length) :: in_filename=''            ! input filename, default is stdin
   character(len=line_length) :: out_filename=''           ! output filename, default is stdout
   character(len=1)   :: prefix                            ! directive prefix character

   character(len=line_length)  :: line                     ! working copy of input line
!-----------------------------------------------------------------------------------------------------------------------------------
   call kracken('cmd','-i -I -o -prefix $ -help .false. -version .false.') !  define command arguments, default values and crack command line
   in_filename = sget('cmd_i')                                             !  get values from command line
   out_filename = sget('cmd_o')
   prefix = sget('cmd_prefix')
!-----------------------------------------------------------------------------------------------------------------------------------
   if(lget('cmd_version'))then                            ! if version switch is present display version name and exit
      write(*,'(a)') 'UFPP: Fortran Pre-processor version 1.4: 20130618'
      stop
   endif
!-----------------------------------------------------------------------------------------------------------------------------------
   if(lget('cmd_help'))then                                ! if help switch is present display help and exit
      call help()
      stop
   endif
!-----------------------------------------------------------------------------------------------------------------------------------
   call defines()                                          ! define named variables declared on the command line
   call includes()                                         ! define include directories supplies on command line
!-----------------------------------------------------------------------------------------------------------------------------------
   if(in_filename.eq.'')then                               ! open input file
      call include(in_filename,5)
   else
      call opens()
   endif
!-----------------------------------------------------------------------------------------------------------------------------------
   if(out_filename.eq.'')then                              ! open output file
      IOUT=6
   else
      IOUT=60
      open(unit=60,file=out_filename,iostat=ios,action='write')
      if(ios.ne.0)then
         write(message,'(a)')'*ufpp* FATAL - FAILED TO OPEN OUTPUT FILE:'//out_filename(:len_trim(out_filename))
         call stop_ufpp()
      endif
   endif
!-----------------------------------------------------------------------------------------------------------------------------------
   READLINE: do                                            ! read loop to read input file
      read(iin(iocount),'(a)',end=7) line
      iototallines=iototallines+1
      iline_number(iocount)=iline_number(iocount)+1
      if (line(1:1).eq.prefix) then                        ! prefix must be in column 1 for conditional compile directive
         source=line                                       ! make directive line available globally
         call cond()                                       ! process directive
      elseif (write) then                                  ! if last conditional was true then write line
         write(iout,'(a)') trim(line)                      ! write data line
      endif
      cycle
7     continue                                             ! end of file encountered on input
      if(iin(iocount).ne.5)then
         close(iin(iocount),iostat=ios)
      endif
      iocount=iocount-1
      if(iocount.lt.1)exit
   enddo READLINE
!-----------------------------------------------------------------------------------------------------------------------------------
   if (nestl.ne.0) then                                    ! check to make sure all if blocks are closed
      write(message,'(''*ufpp* FATAL - $IF BLOCK NOT CLOSED.'')')
      call stop_ufpp()
   endif
   end program ufpp
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
   character(len=*) function upperstr(linei)          !@(#)upperstr: return copy of string converted to uppercase 1996, John S. Urban
   use M_fpp, only : message, source, stop_ufpp
   implicit none
   character(len=*),intent(in) :: linei               ! input string to convert to uppercase

   intrinsic ichar, char, len
   integer                     :: inlen               ! number of characters in trimmed input string
   integer                     :: i10                 ! counter to increment through input and output string
   integer                     :: ilet                ! current character being converted represented using ASCII Decimal Equivalent
!-----------------------------------------------------------------------------------------------------------------------------------
   inlen=len_trim(linei)                              ! number of characters to convert to uppercase
   upperstr=' '                                       ! initialize output string to all blanks

   if(inlen.gt.len(upperstr))then                     ! make sure there is room to store the output characters
      write(message,'(a)')'*ufpp* FATAL - OUTPUT TOO LONG TO CONVERT TO UPPERCASE:'//trim(source)
      call stop_ufpp()
   endif

   do i10=1,inlen,1                                   ! loop through each character in input string
      ilet=ichar(linei(i10:i10))                      ! current character in input to convert to output converted to ADE
      if( (ilet.ge.97) .and. (ilet.le.122))then       ! lowercase a-z in ASCII is 97 to 122; uppercase A-Z in ASCII is 65 to 90
         upperstr(i10:i10)=char(ilet-32)              ! convert lowercase a-z to uppercase A-Z
      else
         upperstr(i10:i10)=linei(i10:i10)             ! character is not a lowercase a-z, just put it in output
      endif
   enddo
   end function upperstr
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
!===================================================================================================================================

category: code