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, 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
- An extended personally maintained alternate version is also available as part of a collection of routines for building and maintaining Fortran code with a CLI (Command Line interface).
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
! @(#) 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 "http://www.urbanjost.altervista.org/LIBRARY/libGPF/arguments/krackenhelp.html".
!===================================================================================================================================
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