text:
module fppridnt
!  Identity of f90ppr utility
! ____________________________________________________________________
      character (len=*), parameter :: zsccs = &
"@(#)fppridnt.f90	1.10	00/05/09 Michel Olagnon"
      character (len=*), parameter :: zvers = &
"@(#) fppridnt.f90	V-1.3 00/05/09 Michel Olagnon"
      character (len=*), parameter :: zusg = &
"( usage: f90ppr < file.F90  > file.f90 )"
      character (len=*), parameter :: zhlp  = '( &
&"Fortran 90 utility to pre-process free source form code with"/&
&"similar facilities to the C cpp pre-processor, and polishing"/&
&"____________________________________________________________________"/&
&"Copyright (C) 1995, ..., 2000 M. Olagnon"/&
&"This program is free software; you can redistribute it and/or modify"/&
&"it under the terms of the GNU General Public License as published by"/&
&"the Free Software Foundation; either version 2 of the License, or"/&
&"(at your option) any later version."//&
&"This program is distributed in the hope that it will be useful,"/&
&"but WITHOUT ANY WARRANTY; without even the implied warranty of"/&
&"MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the"/&
&"GNU General Public License for more details."//&
&"You should have received a copy of the GNU General Public License"/&
&"along with this program; if not, write to the Free Software"/&
&"Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA."//&
&"Originally written by Michel Olagnon, from Ifremer, France,"/&
&"who would be pleased to receive your comments and corrections."/&
&" M. Olagnon (Michel.Olagnon@ifremer.fr)"/&
&"____________________________________________________________________"/&
&"                    version 1.3 of 2000/05/09"/&
&"        Pre-process some (F90 code + macros) into f90 code"/&
&"____________________________________________________________________"/&
&"Note: If you do not like code to start in column 7, remember that,"/&
&"      had Diophantes left a 6 characters margin, then mathematicians"/&
&"      might have spared much efforts on A**N = B**N + C**N ..."/&
&"      My margin is wide to let you put your corrections there."/&
&"____________________________________________________________________")'
!
end module fppridnt
module flexprms
!  Parameters for f90lex utility
! ____________________________________________________________________
      character  (len=1), parameter   :: ztab = achar(9)
      character  (len=1), parameter   :: zbks = achar(92)
!
!  A few source characteristics
!
      integer, parameter  :: lnamm = 31 ! max. variable name length
      integer, parameter  :: lfilm = 64 ! max. file name length
      integer, parameter  :: ncntm = 39 ! max. # cont. lines
      integer, parameter  :: linem = 132 ! max. line length
      integer, parameter  :: lsttm = (linem-1)*ncntm+linem
                             ! max. sttmt. length
!
!  Line codes
!
      integer, parameter  :: klunv = -1 ! Unavailable
      integer, parameter  :: klnrm =  0 ! Not continued, non-comment
      integer, parameter  :: kllst =  1 ! Last line
      integer, parameter  :: klctd =  2 ! Continued line
      integer, parameter  :: klcmt =  3 ! Comment line
      integer, parameter  :: klfcm =  4 ! False comment
      integer, parameter  :: kltcm =  5 ! Trailing comment line
!
!  Token codes
!
      integer, parameter  :: kkndf =  0 ! Undefined
      integer, parameter  :: kkcmt =  1 ! Comment string
      integer, parameter  :: kkebc =  2 ! Embedded comment in continued instr.
      integer, parameter  :: kkstr =  3 ! Character string
      integer, parameter  :: kkidf =  4 ! Identifier
      integer, parameter  :: kknui =  5 ! Integer Numerical value
      integer, parameter  :: kkknd =  6 ! _Kind (underscore)
      integer, parameter  :: kkdpt =  7 ! :
      integer, parameter  :: kkpvg =  8 ! ;
      integer, parameter  :: kkpou =  9 ! (
      integer, parameter  :: kkpfr = 10 ! )
      integer, parameter  :: kkslh = 11 ! /
      integer, parameter  :: kkcou = 12 ! (/
      integer, parameter  :: kkcfr = 13 ! /)
      integer, parameter  :: kkcmd = 14 ! $command (preprocessor)
      integer, parameter  :: kkqst = 15 ! ?
      integer, parameter  :: kkprc = 16 ! %
      integer, parameter  :: kkpms = 17 ! + or -
      integer, parameter  :: kkcct = 18 ! //
      integer, parameter  :: kkaff = 19 ! =
      integer, parameter  :: kkneq = 20 ! /=
      integer, parameter  :: kkleq = 21 ! <=
      integer, parameter  :: kkequ = 22 ! ==
      integer, parameter  :: kkgeq = 23 ! >=
      integer, parameter  :: kkpts = 24 ! =>
      integer, parameter  :: kksup = 25 ! >
      integer, parameter  :: kkinf = 26 ! <
      integer, parameter  :: kksta = 27 ! *
      integer, parameter  :: kkpow = 28 ! **
      integer, parameter  :: kkdot = 29 ! .
      integer, parameter  :: kksep = 30 ! ,
      integer, parameter  :: kklog = 31 ! .xxx.
      integer, parameter  :: kkeos = 32 ! End of Statement (no token)
      integer, parameter  :: kkamp = 33 ! & (not continuation)
      integer, parameter  :: kkfcm = 34 ! False comment (i.e. !$HPF)
      integer, parameter  :: kkbnm = 35 ! Block name
      integer, parameter  :: kkdcl = 36 ! ::
      integer, parameter  :: kklab = 37 ! label
      integer, parameter  :: kknuf = 38 ! Real Numerical value
      integer, parameter  :: kkpnb = 39 ! ( within defined type
      integer, parameter  :: kkukn = 40 ! Other
!   Macros
      integer, parameter  :: nargm = 64 ! Max # of arguments
      integer, parameter  :: kkar0 = 50 ! Base for macro arguments
      integer, parameter, dimension (0:nargm)  :: kkargt = &
          (/ (kkar0+i, i = 0, nargm) /) ! Macro arguments
!
end module flexprms
module flexvars
!  variables to hold token stream
use flexprms
! ____________________________________________________________________
      character (len=lsttm), save        :: ztoki  ! to hold identified
      character (len=linem), dimension (:), pointer, save ::&
                                            zbufc  ! comments buffer
      integer, dimension (1:lsttm), save :: kktokt ! codes
      integer, dimension (1:lsttm), save :: inamwt ! names
      integer, dimension (1:lsttm), save :: itokdt ! starting indexes
      integer, dimension (1:lsttm), save :: itokft ! termination indexes
      integer, parameter                 :: nrepm = lsttm
      integer, parameter                 :: nrepgm = 8*nrepm
      character (len=nrepgm), save       :: zrepg  ! to hold replacements
      integer, dimension (1:nrepm), save :: kkrept ! codes
      integer, dimension (1:nrepm), save :: irepwt ! names
      integer, dimension (1:nrepm), save :: irepdt ! starting indexes
      integer, dimension (1:nrepm), save :: irepft ! termination indexes
      integer, dimension (1:nrepm), save :: irepnt ! next in chain
      integer, save                      :: irepg = 0
      integer, save                      :: irep  = 0
contains
      subroutine inizbu (nsiz)
         integer, intent (in) :: nsiz
!
         allocate (zbufc (nsiz))
         return
      end subroutine inizbu
      subroutine xpdzbu (nsiz)
         integer, intent (inout) :: nsiz
         character (len=linem), dimension (:), allocatable :: zbufw
!
         allocate (zbufw (nsiz))
         zbufw (1:nsiz) = zbufc (1:nsiz)
         deallocate (zbufc)
         allocate (zbufc (2*nsiz))
         zbufc (1:nsiz) = zbufw (1:nsiz)
         deallocate (zbufw)
         nsiz = 2 * nsiz
         return
      end subroutine xpdzbu
end module flexvars
module fprsprms
!  Parsing parameters for f90ppr utility
use flexprms
! ____________________________________________________________________
!
!   Pre-processing commands
!
      character (len=*), parameter  :: zadol = "$"
      character (len=*), parameter  :: zadef = "$DEFINE"
      character (len=*), parameter  :: zaeli = "$ELIF"
      character (len=*), parameter  :: zaels = "$ELSE"
      character (len=*), parameter  :: zaend = "$ENDIF"
      character (len=*), parameter  :: zaevl = "$EVAL"
      character (len=*), parameter  :: zaifx = "$IF"
      character (len=*), parameter  :: zaifd = "$IFDEF"
      character (len=*), parameter  :: zaifn = "$IFNDEF"
      character (len=*), parameter  :: zainc = "$INCLUDE"
      character (len=*), parameter  :: zamcr = "$MACRO"
      character (len=*), parameter  :: zaund = "$UNDEF"
!
!  Codes for current statement parsing left context
!
      integer, parameter :: kcbeg =   0 ! begin statement, nothing known
      integer, parameter :: kcbex =   1 ! begin executable stt
      integer, parameter :: kcblb =   2 ! begin labelled stt
      integer, parameter :: kcbnb =   3 ! begin named block stt
      integer, parameter :: kccmd =   4 ! within fppr command
      integer, parameter :: kcntf =   5 ! within interface stt
      integer, parameter :: kcwtx =   6 ! within executable stt
      integer, parameter :: kcwtf =   7 ! within format stt
      integer, parameter :: kcwti =   8 ! within I/O stt
      integer, parameter :: kcdcl =   9 ! within declaration attributes
      integer, parameter :: kccas =  10 ! after CASE
      integer, parameter :: kcntt =  11 ! within INTENT
      integer, parameter :: kcipl =  12 ! after IMPLICIT
      integer, parameter :: kcuse =  13 ! after USE
      integer, parameter :: kcprc =  14 ! after ENTRY or FUNCTION
      integer, parameter :: kcall =  15 ! within allocation
      integer, parameter :: kcife =  16 ! after IF (, ELSEIF (
      integer, parameter :: kcass =  17 ! after ASSIGN
      integer, parameter :: kcbcl =  18 ! after DO
      integer, parameter :: kcdcp =  19 ! within proc. attributes
      integer, parameter :: kcukn =  39 ! nothing known, but not keyword
      integer, parameter :: kcany =  40 ! nothing known, may be keyword
!
!
!  Codes for current statement parsing right context
!
      integer, parameter :: krukn =   0 ! nothing known, but not keyword
      integer, parameter :: krlst =   1 ! last token
      integer, parameter :: krstr =   2 ! string
      integer, parameter :: krpou =   3 ! (
      integer, parameter :: krany =   4 ! nothing known, may be keyword
!
!  Type used for identifiers
!
      type namtyp
         integer  :: ihshf  ! points to next identifier in chain
         integer  :: irepc  ! points to replacement tokens chain
         integer  :: kwnam  ! is it a keyword, a common name, a variable
         integer  :: inamd  ! starting position in global chain
         integer  :: inamf  ! ending position in global chain
         integer  :: inamod ! starting position in output chain
         integer  :: inamof ! ending position in output chain
      end type namtyp
!
!  identifiers characteristics
!
      integer, parameter :: nnamm = 8192 ! max # of identifiers
      integer, parameter :: lnama = 6    ! average length of names
!
!  Possible types
!
      integer, parameter :: kwnul =  0 ! empty
!
!  Fortran 90 keywords
!
      integer, parameter :: kwcmd =   1 ! pre-processor command
      integer, parameter :: kwlop =   2 ! logical operator (> 3rd token )
      integer, parameter :: kwlct =   3 ! logical constant (> 3rd token )
      integer, parameter :: kwfmb =   4 ! format item (> format (       )
      integer, parameter :: kwiok =   5 ! I/O keywrd  (> read (         )
      integer, parameter :: kwatt =   6 ! type attribute   (< name      )
      integer, parameter :: kwaca =   7 ! allocation action (< (name)   )
      integer, parameter :: kwgnn =   8 ! generic name (> interface     )
      integer, parameter :: kwprc =   9 ! procedure
      integer, parameter :: kwctn =  10 ! CONTAINS
      integer, parameter :: kwdef =  11 ! DEFAULT
      integer, parameter :: kwnta =  12 ! Intent attribute
      integer, parameter :: kwass =  13 ! ASSIGN
      integer, parameter :: kwac2 =  14 ! action   (< [(]name[)]        )
      integer, parameter :: kwfmt =  15 ! FORMAT
      integer, parameter :: kwsts =  16 ! string spec. (< '...'         )
      integer, parameter :: kwtoa =  17 ! TO ( > assign)
      integer, parameter :: kwac3 =  18 ! action   (< name              )
      integer, parameter :: kwac4 =  19 ! action   ( alone              )
      integer, parameter :: kwsel =  20 ! SELECT CASE
      integer, parameter :: kwaio =  21 ! i/o action (< (iolist)        )
      integer, parameter :: kwac5 =  22 ! action (< [name]              )
      integer, parameter :: kwacd =  23 ! declaration action (COMMON, ..)
      integer, parameter :: kweli =  24 ! ELSEIF
      integer, parameter :: kwenp =  25 ! END procedure
      integer, parameter :: kwenf =  26 ! END INTERFACE
      integer, parameter :: kwent =  27 ! END TYPE
      integer, parameter :: kwfct =  28 ! FUNCTION
      integer, parameter :: kwhol =  29 ! H
      integer, parameter :: kwifp =  30 ! IF (
      integer, parameter :: kwipl =  31 ! IMPLICIT
      integer, parameter :: kwntt =  32 ! INTENT
      integer, parameter :: kwntf =  33 ! INTERFACE
      integer, parameter :: kwnon =  34 ! NONE
      integer, parameter :: kwac6 =  35 ! action (< (name)              )
      integer, parameter :: kwuse =  36 ! USE
      integer, parameter :: kwnly =  37 ! ONLY
      integer, parameter :: kwpps =  38 ! PRIVATE,PUBLIC,SEQUENCE
      integer, parameter :: kwrsl =  39 ! RESULT
      integer, parameter :: kwstt =  40 ! STAT
      integer, parameter :: kwthn =  41 ! THEN
      integer, parameter :: kwbcl =  42 ! DO
      integer, parameter :: kwwhl =  43 ! WHILE
      integer, parameter :: kwels =  44 ! ELSE
      integer, parameter :: kweni =  45 ! END IF
      integer, parameter :: kwend =  46 ! END DO
      integer, parameter :: kwens =  47 ! END SELECT
      integer, parameter :: kwenw =  48 ! END WHERE
      integer, parameter :: kwwhe =  49 ! WHERE
      integer, parameter :: kwelw =  50 ! ELSEWHERE
      integer, parameter :: kwcas =  51 ! CASE
      integer, parameter :: kwtyp =  52 ! TYPE
      integer, parameter :: kwfra =  53 ! FORALL
      integer, parameter :: kwena =  54 ! END FORALL
      integer, parameter :: kwgto =  55 ! GOTO
      integer, parameter :: kwpat =  56 ! proc attribute   (< name      )
      integer, parameter :: kwdta =  57 ! DATA
      integer, parameter :: kwsys = 255 ! last possible keyword
!
!  User-defined identifiers
!
      integer, parameter :: kwvar = 256 ! variable name
      integer, parameter :: kwntr = 257 ! known intrinsic
      integer, parameter :: kwlab = 258 ! label ( ^num              )
      integer, parameter :: kwblk = 259 ! block name ( < :          )
      integer, parameter :: kwdfd = 260 ! defined name
      integer, parameter :: kwext = 261 ! external name (> procedure)
      integer, parameter :: kwpdn = 262 ! pre-defined numerical
      integer, parameter :: kwpds = 263 ! pre-defined string
!
!   Macros
!
      integer, parameter :: kwmc0 = 280 ! macro name base
      integer, parameter, dimension (0:nargm)  :: kwmcrt = &
          (/ (kwmc0+i, i = 0, nargm) /) ! Macro with i arguments
!
!  Fortran 90 statement types
!
      integer, parameter :: ksukn =   0 ! nothing known
      integer, parameter :: ksprs =   1 ! procedure start
      integer, parameter :: ksprm =   2 ! procedure middle (contains)
      integer, parameter :: kspre =   3 ! procedure end
      integer, parameter :: ksifs =   4 ! start block if
      integer, parameter :: ksifm =   5 ! middle block if (else)
      integer, parameter :: ksife =   6 ! end block if
      integer, parameter :: kswhs =   7 ! start where
      integer, parameter :: kswhm =   8 ! middle where
      integer, parameter :: kswhe =   9 ! end where
      integer, parameter :: ksdos =  10 ! start do
      integer, parameter :: ksdoe =  11 ! end do
      integer, parameter :: ksnts =  12 ! start interface
      integer, parameter :: ksnte =  13 ! end interface
      integer, parameter :: kssls =  14 ! start select
      integer, parameter :: ksslm =  15 ! middle select (case)
      integer, parameter :: kssle =  16 ! end select
      integer, parameter :: kstys =  17 ! start type
      integer, parameter :: kstye =  18 ! end type
      integer, parameter :: ksifp =  19 ! possible if
      integer, parameter :: ksppr =  20 ! pre-processor command
      integer, parameter :: ksfrs =  21 ! start forall
      integer, parameter :: ksfre =  22 ! end forall
      integer, parameter :: ksuse =  23 ! use
      integer, parameter :: ksexe =  24 ! otherwise undefined executable
      integer, parameter :: ksdcl =  25 ! declarative statement
      integer, parameter :: ksany =  26 ! data or format, appear anywhere
      integer, parameter :: ksipl =  27 ! IMPLICIT declaration
!
end module fprsprms
module fprsvars
!  Parsing variables for f90ppr utility
use fprsprms
! ____________________________________________________________________
!
!   Pre-processing commands
!
      integer, save                 :: iwdol
      integer, save                 :: iwdef
      integer, save                 :: iweli
      integer, save                 :: iwels
      integer, save                 :: iwend
      integer, save                 :: iwevl
      integer, save                 :: iwifx
      integer, save                 :: iwifd
      integer, save                 :: iwifn
      integer, save                 :: iwinc
      integer, save                 :: iwmcr
      integer, save                 :: iwund
!
!  Global chain for identifiers
!
      character (len=nnamm*lnama), save :: znamg
      integer, save                     :: inamg = 0
!
!  Global chain for output names of identifiers
!
      character (len=nnamm*lnama*2), save :: znamo
      integer, save                       :: inamo = 0
!
!  Identifiers tables
!
      type (namtyp), dimension (1:nnamm), save :: tnamt = &
           (/ (namtyp (0, 0, 0, 0, 0, 0, 0), i = 1, nnamm) /)
      integer, save                            :: ialt = nnamm + 1
!
end module fprsvars
module fxprprms
!  Parameters for f90 expressions evaluation
use flexprms
! ____________________________________________________________________
      type opropd
         double precision dval
         integer koprd
         integer iprv
         integer inxt
      end type opropd
!
!  Operator & operand names
!
      character (len=*), parameter  :: zoand = ".AND."
      integer, save                 :: iwand
      character (len=*), parameter  :: zoequ = ".EQ."
      integer, save                 :: iwequ
      character (len=*), parameter  :: zogeq = ".GE."
      integer, save                 :: iwgeq
      character (len=*), parameter  :: zogth = ".GT."
      integer, save                 :: iwgth
      character (len=*), parameter  :: zoleq = ".LE."
      integer, save                 :: iwleq
      character (len=*), parameter  :: zolth = ".LT."
      integer, save                 :: iwlth
      character (len=*), parameter  :: zoneq = ".NE."
      integer, save                 :: iwneq
      character (len=*), parameter  :: zonot = ".NOT."
      integer, save                 :: iwnot
      character (len=*), parameter  :: zoori = ".OR."
      integer, save                 :: iwori
!
      character (len=*), parameter  :: zotru = ".TRUE."
      integer, save                 :: iwtru
      character (len=*), parameter  :: zofls = ".FALSE."
      integer, save                 :: iwfls
!
      character (len=*), parameter  :: zoint = "INT"
      integer, save                 :: iwint
      character (len=*), parameter  :: zonin = "NINT"
      integer, save                 :: iwnin
      character (len=*), parameter  :: zosin = "SIN"
      integer, save                 :: iwsin
      character (len=*), parameter  :: zocos = "COS"
      integer, save                 :: iwcos
      character (len=*), parameter  :: zotan = "TAN"
      integer, save                 :: iwtan
      character (len=*), parameter  :: zoatn = "ATAN"
      integer, save                 :: iwatn
      character (len=*), parameter  :: zolog = "LOG"
      integer, save                 :: iwlog
      character (len=*), parameter  :: zoexp = "EXP"
      integer, save                 :: iwexp
      character (len=*), parameter  :: zol10 = "LOG10"
      integer, save                 :: iwl10
      character (len=*), parameter  :: zosqr = "SQRT"
      integer, save                 :: iwsqr
      character (len=*), parameter  :: zomod = "MOD"
      integer, save                 :: iwmod
      character (len=*), parameter  :: zomax = "MAX"
      integer, save                 :: iwmax
      character (len=*), parameter  :: zomin = "MIN"
      integer, save                 :: iwmin
      character (len=*), parameter  :: zoat2 = "ATAN2"
      integer, save                 :: iwat2
      character (len=*), parameter  :: zoasn = "ASIN"
      integer, save                 :: iwasn
      character (len=*), parameter  :: zoacs = "ACOS"
      integer, save                 :: iwacs
      character (len=*), parameter  :: zosnh = "SINH"
      integer, save                 :: iwsnh
      character (len=*), parameter  :: zocsh = "COSH"
      integer, save                 :: iwcsh
      character (len=*), parameter  :: zotnh = "TANH"
      integer, save                 :: iwtnh
      character (len=*), parameter  :: zoabs = "ABS"
      integer, save                 :: iwabs
      character (len=*), parameter  :: zoknd = "KIND"
      integer, save                 :: iwknd
      character (len=*), parameter  :: zosik = "SELECTED_INT_KIND"
      integer, save                 :: iwsik
      character (len=*), parameter  :: zosrk = "SELECTED_REAL_KIND"
      integer, save                 :: iwsrk
!
!  pre-defined parameters
!
      character (len=*), parameter  :: zofcm = "FPPR_FALSE_CMT"
      integer, save                 :: iwfcm
      character (len=*), parameter  :: zocsk = "FPPR_KWD_CASE"
      integer, save                 :: iwcsk
      character (len=*), parameter  :: zocsu = "FPPR_USR_CASE"
      integer, save                 :: iwcsu
      character (len=*), parameter  :: zofxi = "FPPR_FXD_IN"
      integer, save                 :: iwfxi
      character (len=*), parameter  :: zofxo = "FPPR_FXD_OUT"
      integer, save                 :: iwfxo
      character (len=*), parameter  :: zosed = "FPPR_USE_SHARP"
      integer, save                 :: iwsed
      character (len=*), parameter  :: zomll = "FPPR_MAX_LINE"
      integer, save                 :: iwmll
      character (len=*), parameter  :: zoids = "FPPR_STP_INDENT"
      integer, save                 :: iwids
      character (len=*), parameter  :: zolnb = "FPPR_NMBR_LINES"
      integer, save                 :: iwlnb
!
      character (len=*), parameter  :: zalve = "FPPR_LEAVE"
      integer, save                 :: iwlve
      character (len=*), parameter  :: zalwr = "FPPR_LOWER"
      integer, save                 :: iwlwr
      character (len=*), parameter  :: zaupr = "FPPR_UPPER"
      integer, save                 :: iwupr
!
!  Operator & operand codes
!  ** Beware, operands must be in increasing priority order
!
      integer, parameter  :: kondf =  0 ! Undefined
      integer, parameter  :: konul = 13 ! Logical Numerical value
      integer, parameter  :: konui = 19 ! Integer Numerical value
      integer, parameter  :: konuf = 25 ! Real Numerical value
      integer, parameter  :: konot = 33 ! Not
      integer, parameter  :: koori = 34 ! Or
      integer, parameter  :: koand = 35 ! And
      integer, parameter  :: kogth = 36 ! >
      integer, parameter  :: kogeq = 37 ! >=
      integer, parameter  :: koequ = 38 ! ==
      integer, parameter  :: kolth = 39 ! <
      integer, parameter  :: koleq = 40 ! <=
      integer, parameter  :: koneq = 41 ! /=
      integer, parameter  :: komns = 42 ! -
      integer, parameter  :: kopls = 43 ! +
      integer, parameter  :: komlt = 44 ! *
      integer, parameter  :: kodiv = 45 ! /
      integer, parameter  :: kopow = 46 ! **
      integer, parameter  :: koint = 47 ! Int
      integer, parameter  :: konin = 48 ! Nint
      integer, parameter  :: kosin = 49 ! Sin
      integer, parameter  :: kocos = 50 ! Cos
      integer, parameter  :: kotan = 51 ! Tan
      integer, parameter  :: koatn = 52 ! Atan
      integer, parameter  :: kolog = 53 ! Log
      integer, parameter  :: koexp = 54 ! Exp
      integer, parameter  :: kol10 = 55 ! Log10
      integer, parameter  :: kosqr = 56 ! Sqrt
      integer, parameter  :: komod = 57 ! Mod
      integer, parameter  :: komax = 58 ! Max
      integer, parameter  :: komin = 59 ! Min
      integer, parameter  :: koat2 = 60 ! Atan2
      integer, parameter  :: koasn = 61 ! Asin
      integer, parameter  :: koacs = 62 ! Acos
      integer, parameter  :: kosnh = 63 ! Sinh
      integer, parameter  :: kocsh = 64 ! Cosh
      integer, parameter  :: kotnh = 65 ! Tanh
      integer, parameter  :: koabs = 66 ! Abs
      integer, parameter  :: koknd = 67 ! Kind
      integer, parameter  :: kosik = 68 ! Selected_Int_Kind
      integer, parameter  :: kosrk = 69 ! Selected_Real_Kind
      integer, parameter  :: kouds = 90 ! _   (of kind)
      integer, parameter  :: kosep = 91 ! ,
      integer, parameter  :: kopou = 92 ! (
      integer, parameter  :: kopfr = 93 ! )
      integer, parameter  :: komodi = 94 ! .Mod.
      integer, parameter  :: komaxi = 95 ! .Max.
      integer, parameter  :: komini = 96 ! .Min.
      integer, parameter  :: koat2i = 97 ! .Atan2.
      integer, parameter  :: kosrki = 98 ! .S_R_K.
      integer, parameter  :: koukn = 99 ! Other
!
end module fxprprms
module fxprvars
!  Variables for f90 expression analysis
use flexprms
use fxprprms
! ____________________________________________________________________
!
      integer, parameter                 :: nxptm = lsttm
      integer, parameter                 :: nxptgm = 8*nxptm
      type (opropd), dimension (1:nxptm), save :: oxptt ! oper[and|ator]
      integer, save                      :: ixpt  = 0
!
end module fxprvars
module fpprprms
!  Parameters for f90ppr utility
! ____________________________________________________________________
!
!  Case processing
!
      integer, parameter  :: kclwr = -1 ! case processing: to lower
      integer, parameter  :: kcupr =  1 ! case processing: to upper
      integer, parameter  :: kclve =  0 ! case processing: leave as is
      character (len=26), parameter :: zlwr="abcdefghijklmnopqrstuvwxyz"
      character (len=26), parameter :: zupr="ABCDEFGHIJKLMNOPQRSTUVWXYZ"
!
!  Logical units
!
      integer, parameter  :: luerr  = 0 ! logical unit for stderr
      integer, parameter  :: lufil  = 6 ! logical unit for final file
      integer, parameter  :: lustdi = 5 ! logical unit for stdin
      integer, parameter  :: lufic0 = 7 ! base logical unit for include
!
!  False comments
!
      integer, parameter  :: ncmtim = 16 ! max # of "False comments"
      integer, parameter  :: lcmtim =  8 ! max length of "False comments"
!
!  Defines
!
      integer, parameter  :: nnstdm = 64 ! max nesting for DEFINEs
!
!  Tests
!
      integer, parameter  :: nnsttm = 64 ! max nesting for IFs, IFDEFs
!
!  Include files
!
      integer, parameter  :: nnstim = 16 ! maximum nesting
      integer, parameter  :: lzficm = 96 ! maximum name length
!
!  Loop labels
!
      integer, parameter  :: nlabdm = 16 ! maximum nesting
      integer, parameter  :: llabdm =  5 ! maximum label length
!
end module fpprprms
module fpprcurs
use fpprprms
use flexprms
!  Current status variables in f90ppr utility
! ____________________________________________________________________
      character (len=1) :: zblk = '!' ! current blank line printing
      character (len=2*linem+1), save :: zlinb ! advance line in buffer
      character (len=2*linem+1), dimension (nnstim), save :: zlinbh
                                  ! advance lines heap for include
      integer, save   :: nhav = 0 ! How many lines do we have in advance
      integer, dimension (nnstim), save :: nhavh  ! and the heap
      integer, save   :: klrea = klunv   ! Type of current line
      integer, save   :: klnxt = klunv   ! Type of next line
      integer, dimension (nnstim), save :: klnxth ! and the heap
      integer, save     :: ifskp = 0  ! are we skipping code ?
      integer, dimension (0:nnstim), save  :: nlinit = &
            (/ (0, i = 0, nnstim) /)  ! number of lines input
      integer, save     :: linel = 132 ! current, desirable, linelength
      integer, save     :: nndt  = 0  ! current indentation
      integer, save     :: nndtp =  2 ! current step for indentation
      integer, save     :: lprc  =  1 ! current procedure nesting
      integer, save     :: luinp = lustdi ! current input unit
      integer, save     :: lufic = lufic0 ! current include unit
      integer, save     :: iclev = 0  ! current include level
      character (len=lzficm), dimension (0:nnstim), save  :: zficit = &
            (/ "standard input", &
              ("              ", i = 1, nnstim) /)
                                      ! table of names
!
!  Format
!
      integer, save     :: iffxd = 0  ! are we reading fixed format ?
      integer, save     :: iffxf = 0  ! are we outputing fixed format ?
      integer, save     :: iflnb = 0  ! are we numbering lines ?
!
!  Interpret # as $
!
      integer, save     :: ifsed = 0  ! is # same as $ ?
!
!  Case processing
!
      integer, save  :: kccask = kclwr ! Case for keywords
      integer, save  :: kccasu = kclve ! Case for user identifiers
!
!  False comments
!
      integer, save  :: ncmti = 0 ! number of "False comments"
      character (len=lcmtim), dimension (ncmtim), save :: zcmtit
                                  ! the corresponding strings
!
!  Loop labels
!
      integer, save  :: nlabd = 0 ! number of labels
      integer, save  :: ndoe  = 0 ! number of loops ending on label
      character (len=llabdm), dimension (nlabdm), save :: zlabdt
                                  ! the corresponding strings
end module fpprcurs
program f90ppr
!  Pre-process standard input, applying some pretty-printing by default
!  and user specified commands to F90 source code, and output result
!  on standard output.
! ____________________________________________________________________
      use fppridnt
      use fpprcurs
      interface
         subroutine addtok (ztok, ltok, kktok)
!  add token to current stream, and reduce if end of statement
            use flexvars
            use fpprcurs
            integer, intent (in)              :: ltok, kktok
            character (len=ltok), intent (in) :: ztok
         end subroutine addtok
      end interface
! ____________________________________________________________________
!
      write (luerr, "(a)") "This is f90ppr: " // zvers
      write (luerr, "(a)")  zusg
!
!  Initialize names, directives, expression evaluation
!
      call ininam
      call inicmd
      call inixpr
!
!  Loop on (possibly multiple instructions) input lines
!
      ifstp = 0 ! do not strip-out embedded comments
      ksta = 0
      do
         if (iffxd == 0) then
            call lexlin (addtok, ifstp, ksta)
         else
            call lexfxd (addtok, ifstp, ksta)
         endif
         if (ksta /= 0) exit
      enddo
!
end program f90ppr
subroutine lexlin (trttok, ifstp, ksta)
!  Read input file, lexing free-form into token stream, until a
!  simultaneous end-of-line end-of-statement is found.
use flexprms
use fpprcurs
      interface
         subroutine trttok (ztok, ltok, kktok)
!  add token to current stream, and reduce if end of statement
            use flexvars
            use fpprcurs
            integer, intent (in)              :: ltok, kktok
            character (len=ltok), intent (in) :: ztok
         end subroutine trttok
      end interface
integer, intent (in)                :: ifstp ! strip-out comments ?
integer, intent (out)               :: ksta  ! status code
! ____________________________________________________________________
      character (len=2*linem) :: zlin
      character (len=lsttm) :: ztok
      character (len=1)     :: zdlm, zchr
!
      ksta  = 0
      ifcnt = 0
      ifchc = 0
      ntok  = 0
      kktok = kkndf
!
body: do
         do
            if (klrea == kllst .or. klrea == kltcm) then
               if (ifcnt /= 0) then
                  ksta = 2
                  call fpperr ("Unexpected end of input")
                  exit body
               else
                  if (iclev > 0) then
                     zlinb = zlinbh (iclev)
                     nhav  = nhavh  (iclev)
                     klnxt = klnxth (iclev)
                     iclev = iclev - 1
                     close (lufic)
                     lufic = lufic - 1
                     if (iclev == 0) then
                        luinp = lustdi
                     else
                        luinp = lufic
                     endif
                  else
                     ksta = -1
                     exit body
                  endif
               endif
            endif
!
!  Read a line
!
            call realin (luinp, zlin, klrea)
            if (klrea == klunv .and. iclev /= 0) then
               klrea = kllst
               cycle
            endif
            exit
         enddo
!
         select case (klrea)
         case (klunv)
            ksta = 1
            call fpperr ("Problem reading input")
            exit body
         case default
            ksta = 0
         end select
!
!  Recognize and skip full comments
!
         llin = len_trim (zlin)
         if (llin == 0) then
            call trttok ("!", 1, kkcmt)
            if (ifcnt == 0) then
               exit body
            else
               cycle body
            endif
         endif
         ilin = verify (zlin (1:llin), ztab // " ")
cmtl:    do
            if (ilin /= 0) then
               if (zlin (ilin:ilin) /= "!") then
                  exit cmtl
               endif
!
!  Do not skip "False comments"
!
               do icmti = 1, ncmti
                  lcmti = len_trim (zcmtit (icmti))
                  ilini = ilin + lcmti - 1
                  if (llin > ilini .and. &
                      zlin (ilin:ilini) == zcmtit (icmti)(1:lcmti)) then
                     call trttok (zlin (ilin:ilini), lcmti, kkfcm)
                     ilin = ilini + 1
                     exit cmtl
                  endif
               enddo
            endif
            if (ifcnt == 0) then
               call trttok (zlin, llin, kkcmt)
               exit body
            else
               call trttok (zlin, llin, kkebc)
               cycle body
            endif
         enddo cmtl
!
!  Check for continued mark
!
         if (ifcnt /= 0) then
            if (zlin (ilin:ilin) == "&") then
               ilin = ilin + 1
            else
               if (ifchc /= 0) then
                  ksta = 3
                  call fpperr ("Illegal continuation for string")
                  exit body
               else
                  if (kktok /= kkndf) then
                     call trttok (ztok, ltok, kktok)
                  endif
                  kktok = kkndf
               endif
            endif
         endif

         ifcnt = 0
         ichr = ilin - 1
!
!  Scan line
!
         do
               do
                  if (ichr >= llin) then
                     if (ifcnt == 0) then
                        if (kktok /= kkndf) then
                           call trttok (ztok, ltok, kktok)
                        endif
                        exit body
                     else
                        cycle body
                     endif
                  endif
                  ichr = ichr + 1
                  zchr = zlin (ichr:ichr)
                  if (ifchc == 0) then
                     select case (zchr)
!
!  Spaces
!
                     case (ztab,' ')
                        if (kktok /= kkndf) then
                           call trttok (ztok, ltok, kktok)
                        endif
                        kktok = kkndf
!
!  Letters
!
                     case ('A':'Z','a':'z')
                        if (kktok == kkidf .or. kktok == kkcmd) then
                           ltok = ltok + 1
                           ztok (ltok:ltok) = zchr
                        else
                           if (kktok /= kkndf) then
                              call trttok (ztok, ltok, kktok)
                           endif
                           ntok = ntok + 1
                           ltok = 1
                           ztok (ltok:ltok) = zchr
                           kktok = kkidf
                        endif
!
!  Digits
!
                     case ('0':'9')
                        if (kktok == kkidf .or. kktok == kknui) then
                           ltok = ltok + 1
                           ztok (ltok:ltok) = zchr
                        else
                           if (kktok /= kkndf) then
                              call trttok (ztok, ltok, kktok)
                           endif
                           ntok = ntok + 1
                           ltok = 1
                           ztok (ltok:ltok) = zchr
                           kktok = kknui
                        endif
!
!  Underscore (may be in identifier, or as a kind specifier)
!
                     case ('_')
                        select case (kktok)
                        case (kkidf)
                           ltok = ltok + 1
                           ztok (ltok:ltok) = zchr
                        case (kknui, kkstr)
                           call trttok (ztok, ltok, kktok)
                           ntok = ntok + 1
                           call trttok (zchr, 1, kkknd)
                           kktok = kkndf
                        case default
                           if (kktok /= kkndf) then
                              call trttok (ztok, ltok, kktok)
                           endif
                           ntok = ntok + 1
                           ltok = 1
                           ztok (ltok:ltok) = zchr
                           kktok = kkidf
                        end select
!
!  Colon
!
                     case (':')
                        if (kktok /= kkndf) then
                           call trttok (ztok, ltok, kktok)
                        endif
                        ntok = ntok + 1
                        call trttok (zchr, 1, kkdpt)
                        kktok = kkndf
!
!  Semi-colon
!
                     case (';')
                        if (kktok /= kkndf) then
                           call trttok (ztok, ltok, kktok)
                        endif
                        ntok = ntok + 1
                        call trttok (zchr, 1, kkpvg)
                        kktok = kkndf
!
!  Opening parenthesis
!
                     case ('(')
                        if (kktok /= kkndf) then
                           call trttok (ztok, ltok, kktok)
                        endif
                        ntok = ntok + 1
                        ltok = 1
                        ztok (ltok:ltok) = zchr
                        kktok = kkpou
!
!  Closing parenthesis
!
                     case (')')
                        if (kktok == kkslh) then
                           ltok = ltok + 1
                           ztok (ltok:ltok) = zchr
                           call trttok (ztok, ltok, kkcfr)
                           kktok = kkndf
                        else
                           if (kktok /= kkndf) then
                              call trttok (ztok, ltok, kktok)
                           endif
                           ntok = ntok + 1
                           call trttok (zchr, 1, kkpfr)
                           kktok = kkndf
                        endif
!
!  Exclamation mark (start of comment)
!
                     case ('!')
                        if (kktok /= kkndf .and. ifcnt == 0) then
                           call trttok (ztok, ltok, kktok)
                        endif
                        if (ifcnt == 0) then
                           ntok = ntok + 1
                           call trttok (zlin (ichr:llin), (llin-ichr+1),&
                                        kkcmt)
                           exit body
                        else
                           if (ifstp == 0) &
                           call wrtstt (zlin, 0, zlin, 0, &
                                        zlin (ichr:llin), &
                                        llin - ichr + 1, ichr-1)
                           cycle body
                        endif
!
!  Dollar (used as preprocessor command introduction)
!
                     case ('$')
                        if (kktok /= kkndf) then
                           call trttok (ztok, ltok, kktok)
                        endif
                        ntok = ntok + 1
                        ltok = 1
                        ztok (ltok:ltok) = '$'
                        kktok = kkcmd
!
!  Sharp (same as $ or !, depending on current status)
!
                     case ('#')
                        if (ifsed /= 0) then
                           if (kktok /= kkndf) then
                              call trttok (ztok, ltok, kktok)
                           endif
                           ntok = ntok + 1
                           ltok = 1
                           ztok (ltok:ltok) = '$'
                           kktok = kkcmd
                        else
                           if (kktok /= kkndf .and. ifcnt == 0) then
                              call trttok (ztok, ltok, kktok)
                           endif
                           if (ifcnt == 0) then
                              ntok = ntok + 1
                              call trttok (zlin (ichr:llin),&
                                           (llin-ichr+1), kkcmt)
                              exit body
                           else
                              if (ifstp == 0) &
                              call wrtstt (zlin, 0, zlin, 0, &
                                           zlin (ichr:llin), &
                                           llin - ichr + 1, ichr-1)
                              cycle body
                           endif
                        endif
!
!  Question mark
!
                     case ('?')
                        if (kktok /= kkndf) then
                           call trttok (ztok, ltok, kktok)
                        endif
                        ntok = ntok + 1
                        call trttok (zchr, 1, kkqst)
                        kktok = kkndf
!
!  Continuation mark
!
                     case ('&')
                        ifcnt = 1
                        if (ichr < llin) then
                           inxt = verify (zlin (ichr+1:llin),        &
                                          ztab // " ")
                           if (inxt /= 0) then
                              if (zlin (ichr+inxt:ichr+inxt) /= "!") then
                                 if (kktok /= kkndf) then
                                    call trttok (ztok, ltok, kktok)
                                 endif
                                 ntok = ntok + 1
                                 call trttok (zchr, 1, kkamp)
                                 kktok = kkndf
                                 ifcnt = 0
                              endif
                           endif
                        endif
!
!  Percent
!
                     case ('%')
                        if (kktok /= kkndf) then
                           call trttok (ztok, ltok, kktok)
                        endif
                        ntok = ntok + 1
                        call trttok (zchr, 1, kkprc)
                        kktok = kkndf
!
!  Plus and Minus
!
                     case ('+','-')
                        if (kktok /= kkndf) then
                           call trttok (ztok, ltok, kktok)
                        endif
                        ntok = ntok + 1
                        call trttok (zchr, 1, kkpms)
                        kktok = kkndf
!
!  Slash
!
                     case ('/')
                        select case (kktok)
                        case (kkslh)
                           ltok = ltok + 1
                           ztok (ltok:ltok) = zchr
                           call trttok (ztok, ltok, kkcct)
                           kktok = kkndf
                        case (kkpou)
                           ltok = ltok + 1
                           ztok (ltok:ltok) = zchr
                           call trttok (ztok, ltok, kkcou)
                           kktok = kkndf
                        case default
                           if (kktok /= kkndf) then
                              call trttok (ztok, ltok, kktok)
                           endif
                           ntok = ntok + 1
                           ltok = 1
                           ztok (ltok:ltok) = zchr
                           kktok = kkslh
                        end select
!
!  Star
!
                     case ('*')
                        if (kktok == kksta) then
                           ltok = ltok + 1
                           ztok (ltok:ltok) = zchr
                           call trttok (ztok, ltok, kkpow)
                           kktok = kkndf
                        else
                           if (kktok /= kkndf) then
                              call trttok (ztok, ltok, kktok)
                           endif
                           ntok = ntok + 1
                           ltok = 1
                           ztok (ltok:ltok) = zchr
                           kktok = kksta
                        endif
!
!  Superior
!
                     case ('>')
                        if (kktok == kkaff) then
                           ltok = ltok + 1
                           ztok (ltok:ltok) = zchr
                           call trttok (ztok, ltok, kkpts)
                           kktok = kkndf
                        else
                           if (kktok /= kkndf) then
                              call trttok (ztok, ltok, kktok)
                           endif
                           ntok = ntok + 1
                           ltok = 1
                           ztok (ltok:ltok) = zchr
                           kktok = kksup
                        endif
!
!  Inferior
!
                     case ('<')
                        if (kktok /= kkndf) then
                           call trttok (ztok, ltok, kktok)
                        endif
                        ntok = ntok + 1
                        ltok = 1
                        ztok (ltok:ltok) = zchr
                        kktok = kkinf
!
!  Equal
!
                     case ('=')
                        select case (kktok)
                        case (kkslh)
                           ltok = ltok + 1
                           ztok (ltok:ltok) = zchr
                           call trttok (ztok, ltok, kkneq)
                           kktok = kkndf
                        case (kkinf)
                           ltok = ltok + 1
                           ztok (ltok:ltok) = zchr
                           call trttok (ztok, ltok, kkleq)
                           kktok = kkndf
                        case (kkaff)
                           ltok = ltok + 1
                           ztok (ltok:ltok) = zchr
                           call trttok (ztok, ltok, kkequ)
                           kktok = kkndf
                        case (kksup)
                           ltok = ltok + 1
                           ztok (ltok:ltok) = zchr
                           call trttok (ztok, ltok, kkgeq)
                           kktok = kkndf
                        case default
                           if (kktok /= kkndf) then
                              call trttok (ztok, ltok, kktok)
                           endif
                           ntok = ntok + 1
                           ltok = 1
                           ztok (ltok:ltok) = zchr
                           kktok = kkaff
                        end select
!
!  Dot
!
                     case ('.')
                        if (kktok /= kkndf) then
                           call trttok (ztok, ltok, kktok)
                        endif
                        ntok = ntok + 1
                        call trttok (zchr, 1, kkdot)
                        kktok = kkndf
!
!  Separator
!
                     case (',')
                        if (kktok /= kkndf) then
                           call trttok (ztok, ltok, kktok)
                        endif
                        ntok = ntok + 1
                        call trttok (zchr, 1, kksep)
                        kktok = kkndf
!
!  String delimiter
!
                     case ('"',"'")
                        if (kktok == kkstr) then
                           if (zchr == zdlm) then
                              ltok = ltok + 1
                              ztok (ltok:ltok) = zchr
                           else
                              zdlm  = zchr
                              ltok  = 1
                              ztok (ltok:ltok) = zchr
                              ntok  = ntok + 1
                           endif
                           ifchc = 1
                        else
                           if (kktok /= kkndf) then
                              call trttok (ztok, ltok, kktok)
                           endif
                           if (ichr == llin) then
                              call fpperr ("Unmatched " // zchr)
                           else
                              zdlm  = zchr
                              ltok  = 1
                              ztok (ltok:ltok) = zchr
                              ntok  = ntok + 1
                              kktok = kkstr
                              ifchc = 1
                           endif
                        endif
!
!  Other character
!
                     case default
                        if (kktok /= kkndf) then
                           call trttok (ztok, ltok, kktok)
                        endif
                        ntok = ntok + 1
                        call trttok (zchr, 1, kkukn)
                        kktok = kkndf
                     end select
!
!  We are inside a char string
!
                  else
!
!  Test for end of current string
!
                     if (zchr == zdlm) then
                        ltok  = ltok + 1
                        ztok (ltok:ltok) = zchr
                        ifchc = 0
                     else
!
!  Test for end of line
!
                        if (ichr == llin) then
                           if (zchr == '&') then
                              ifcnt = 1
                              cycle body
                           else
                              call fpperr ("Unmatched " // zdlm)
                           endif
                        else
                           ltok = ltok + 1
                           ztok (ltok:ltok) = zchr
                        endif
                     endif
                  endif
               enddo
            enddo
      enddo body
      call trttok (ztok, 0, kkeos)
      return
end subroutine lexlin
subroutine addtok (ztok, ltok, kktok)
!  add token to current stream, and reduce if end of statement
use flexvars
use fpprcurs
character (len=ltok), intent (in) :: ztok
integer, intent (in)              :: ltok, kktok
! ____________________________________________________________________
      integer, save  :: ntok = 0
      integer, save  :: itokf = 0
      integer, save  :: itokd
!
!  Add to current stream
!
      if (ltok > 0) then
         ntok  = ntok + 1
         itokd = itokf + 1
         itokf = itokf + ltok
         kktokt (ntok) = kktok
         ztoki (itokd:itokf) = ztok (1:ltok)
         itokdt (ntok) = itokd
         itokft (ntok) = itokf
      endif
!
!  Reduce if end of statement
!
      if (kktok == kkpvg) then
         ntok = ntok - 1
      endif
      if ((kktok == kkpvg .or. kktok == kkeos) .and.  &
          (ntok > 0)                                ) then
         call prsstt (ntok, ksstt)
         if (ifskp == 0) then
            call outstt (ntok, ksstt)
         endif
         ntok = 0
         itokf = 0
      endif
      return
end subroutine addtok
subroutine rdcstt (ntok)
!  reduce lexed statement, to recognize constants, logical ops, ...
use flexvars
use fprsvars
use fpprprms
integer, intent (inout) :: ntok
! ____________________________________________________________________
!
      character (len=1) :: zchr
      interface
         logical function ifsame (zstr1, zstr2)
!           Case insensitive compare
         character (len=*), intent (in) :: zstr1, zstr2
         end function ifsame
      end interface
!
!  Note that we always skip the first token, since it may not be any
!  of the clusters considered. This trick solves the problem of
!  label E01 [ = ..., for instance] which is not a floating point
!  constant, and saves time...
!
!  Look for logical operators and variables .xxxx.
!
      if (index (ztoki (1:itokft(ntok)), '.') /= 0) then
         itok = 3
         do
            itok = itok + 1
            if (itok > ntok) exit
            if (kktokt (itok) == kkdot) then
               if (kktokt (itok-2) == kkdot .and. &
                   kktokt (itok-1) == kkidf .and. &
                   verify (ztoki (itokdt(itok-1):itokft(itok-1)), &
                           zlwr//zupr) == 0) then
                   kktokt (itok-2) = kkidf
                   itokft (itok-2) = itokft (itok)
                   itok2 = itok - 2
                   do itok1 = itok + 1, ntok
                      itok2 = itok2 + 1
                      kktokt (itok2) = kktokt (itok1)
                      itokdt (itok2) = itokdt (itok1)
                      itokft (itok2) = itokft (itok1)
                   enddo
                   ntok = itok2
               endif
            endif
         enddo
!
!  Look for floating point constants #.#
!
         itok = 3
         do
            itok = itok + 1
            if (itok > ntok) exit
            if (kktokt (itok) == kknui) then
               if (kktokt (itok-2) == kknui .and. &
                   kktokt (itok-1) == kkdot) then
                   itokft (itok-2) = itokft (itok)
                   itok2 = itok - 2
                   kktokt (itok2) = kknuf
                   do itok1 = itok + 1, ntok
                      itok2 = itok2 + 1
                      kktokt (itok2) = kktokt (itok1)
                      itokdt (itok2) = itokdt (itok1)
                      itokft (itok2) = itokft (itok1)
                   enddo
                   ntok = itok2
               endif
            endif
         enddo
!
!  Look for floating point constants #.
!
         itok = 2
         do
            itok = itok + 1
            if (itok > ntok) exit
            if (kktokt (itok) == kkdot) then
               if (kktokt (itok-1) == kknui) then
                   itokft (itok-1) = itokft (itok)
                   itok2 = itok - 1
                   kktokt (itok2) = kknuf
                   do itok1 = itok + 1, ntok
                      itok2 = itok2 + 1
                      kktokt (itok2) = kktokt (itok1)
                      itokdt (itok2) = itokdt (itok1)
                      itokft (itok2) = itokft (itok1)
                   enddo
                   ntok = itok2
               endif
            endif
         enddo
!
!  Look for floating point constants .#
!
         itok = 2
         do
            itok = itok + 1
            if (itok > ntok) exit
            if (kktokt (itok) == kknui) then
               if (kktokt (itok-1) == kkdot) then
                   itokft (itok-1) = itokft (itok)
                   kktokt (itok-1) = kknuf
                   itok2 = itok - 1
                   do itok1 = itok + 1, ntok
                      itok2 = itok2 + 1
                      kktokt (itok2) = kktokt (itok1)
                      itokdt (itok2) = itokdt (itok1)
                      itokft (itok2) = itokft (itok1)
                   enddo
                   ntok = itok2
               endif
            endif
         enddo
      endif
!
!  Look for exponent notation
!
      itok = 2
      do
         itok = itok + 1
         if (itok > ntok) exit
         if (kktokt (itok)   == kkidf        .and. &
             (kktokt (itok-1) == kknui) .or. &
             (kktokt (itok-1) == kknuf)           ) then
!
!  The following forms are possible: [EeDd][+-]#
!                                    [EeDd]#
!                                    [Ee]#_x
!                                    _x (comming from ._x)
!
            zchr = ztoki (itokdt(itok):itokdt(itok))
            if (index ("EeDd", zchr) /= 0) then
               itok1 = itok + 1
               if (itok1 < ntok) then
                  if (  itokdt(itok) == itokft(itok) .and. &
                      kktokt (itok1) == kkpms       ) then
                     itok1 = itok1 + 1
                     if (kktokt (itok1) == kknui) then
!  [EeDd][+-]#
                        itokft (itok-1) = itokft (itok1)
                        kktokt (itok-1) = kknuf
                        itok2 = itok-1
                        do itok1 = itok1 + 1, ntok
                           itok2 = itok2 + 1
                           kktokt (itok2) = kktokt (itok1)
                           itokdt (itok2) = itokdt (itok1)
                           itokft (itok2) = itokft (itok1)
                        enddo
                        ntok = itok2
                        cycle
                     endif
                  endif
               endif
               if (itok1 <= ntok) then
                  if (itokdt (itok)  == itokft (itok) .and. &
                      kktokt (itok1) == kknui         ) then
!  [EeDd]# (as 2 tokens)
                     itokft (itok-1) = itokft (itok1)
                     kktokt (itok-1) = kknuf
                     itok2 = itok-1
                     do itok1 = itok1 + 1, ntok
                        itok2 = itok2 + 1
                        kktokt (itok2) = kktokt (itok1)
                        itokdt (itok2) = itokdt (itok1)
                        itokft (itok2) = itokft (itok1)
                     enddo
                     ntok = itok2
                     cycle
                  endif
               endif
               if (itokdt (itok) < itokft (itok)) then
                     inumf = verify (ztoki(itokdt(itok)+1:itokft(itok)),&
                                     "0123456789")
                     if (inumf == 0) then
!  [EeDd]# (as a single identifier)
                        itokft (itok-1) = itokft (itok)
                        kktokt (itok-1) = kknuf
                        itok2 = itok-1
                        do itok1 = itok + 1, ntok
                           itok2 = itok2 + 1
                           kktokt (itok2) = kktokt (itok1)
                           itokdt (itok2) = itokdt (itok1)
                           itokft (itok2) = itokft (itok1)
                        enddo
                        ntok = itok2
                     else
                        inumf1 = itokdt(itok) + inumf
                        if (inumf1 > itokdt(itok) + 1 .and. &
                            ztoki (inumf1:inumf1) == '_' .and. &
                            inumf1 < itokft(itok) ) then
!  [EeDd]#_x (Dd are not standard)
                           itokft (itok-1) = inumf1 - 1
                           kktokt (itok-1) = kknuf
                           itok2 = ntok + 2
                           do itok1 = ntok, itok, -1
                              itok2 = itok2 - 1
                              kktokt (itok2) = kktokt (itok1)
                              itokdt (itok2) = itokdt (itok1)
                              itokft (itok2) = itokft (itok1)
                           enddo
                           itokdt (itok) = inumf1
                           itokft (itok) = inumf1
                           kktokt (itok) = kkknd
                           itok = itok + 1
                           itokdt (itok) = inumf1 + 1
                           inumf2 = verify ( &
                                     ztoki (itokdt(itok):itokft(itok)), &
                                     "0123456789")
                           if (inumf2 == 0) then
                              kktokt (itok) = kknui
                           else
                              kktokt (itok) = kkidf
                           endif
                           ntok = ntok + 1
                           itok = itok + 1
                        endif
                     endif
               endif
            elseif (zchr == '_' .and. &
                    itokdt (itok) < itokft (itok)) then
!  _x
               itok2 = ntok + 2
               do itok1 = ntok, itok, -1
                  itok2 = itok2 - 1
                  kktokt (itok2) = kktokt (itok1)
                  itokdt (itok2) = itokdt (itok1)
                  itokft (itok2) = itokft (itok1)
               enddo
               itokft (itok) = itokdt (itok)
               kktokt (itok) = kkknd
               itokdt (itok+1) = itokft (itok) + 1
               itok = itok + 1
               inumf2 = verify (ztoki (itokdt(itok):itokft(itok)), &
                                "0123456789")
               if (inumf2 == 0) then
                  kktokt (itok) = kknui
               else
                  kktokt (itok) = kkidf
               endif
               ntok = ntok + 1
               itok = itok + 1
            endif
         endif
      enddo
!
!  Remove embedded blanks in numerical constants
!
      itok = 2
      itok1 = 2
      do
         itok = itok + 1
         if (itok > ntok) exit
         if ((kktokt (itok) == kknui .and. kktokt (itok1) == kknui) .or.&
             (kktokt (itok) == kknuf .and. kktokt (itok1) == kknui) .or.&
             (kktokt (itok) == kknui .and. kktokt (itok1) == kknuf)) then
            itokft (itok1) = itokft (itok)
         else
            itok1 = itok1 + 1
            if (itok1 < itok) then
               kktokt (itok1) = kktokt (itok)
               itokdt (itok1) = itokdt (itok)
               itokft (itok1) = itokft (itok)
            endif
         endif
      enddo
      if (itok1 < ntok) ntok = itok1
!
!  find :: (must be outside of parentheses)
!
      itok = 2
      nparl = 0
      do
         itok = itok + 1
         if (itok > ntok) exit
         if (kktokt (itok) == kkpou) then
            nparl = nparl + 1
            cycle
         elseif (kktokt (itok) == kkpfr) then
            nparl = nparl - 1
            cycle
         elseif (nparl > 0) then
            cycle
         endif
         if (kktokt (itok) == kkdpt .and. &
             kktokt (itok-1) == kkdpt) then
            itokft (itok-1) = itokft (itok)
            kktokt (itok-1) = kkdcl
            do itok1 = itok + 1, ntok
               kktokt (itok1-1) = kktokt (itok1)
               itokdt (itok1-1) = itokdt (itok1)
               itokft (itok1-1) = itokft (itok1)
            enddo
            ntok = ntok - 1
            exit  ! (There should only be one :: per instruction)
         endif
      enddo
!
!  Now, look for double word keywords
!  (Here, we start again from the first token)
!
      itok  = 1
      itok1 = 1
expl: do
         itok = itok + 1
         if (itok > ntok) exit expl
         if (kktokt (itok)  == kkidf .and. &
             kktokt (itok1) == kkidf) then
            itokd = itokdt (itok1)
            itokf = itokft (itok)
            ihsh = khshstr (ztoki (itokd:itokf))
            if (tnamt(ihsh)%kwnam /= 0 .and. &
                tnamt(ihsh)%kwnam <= kwsys) then
               do
                  inamd = tnamt(ihsh)%inamd
                  inamf = tnamt(ihsh)%inamf
                  if (ifsame (ztoki (itokd:itokf), &
                              znamg (inamd:inamf))) then
                     itokft (itok1) = itokft (itok)
                     do itok2 = itok+1, ntok
                         kktokt (itok2-1) = kktokt (itok2)
                         itokdt (itok2-1) = itokdt (itok2)
                         itokft (itok2-1) = itokft (itok2)
                     enddo
                     itok = itok - 1
                     ntok = ntok - 1
                     cycle expl
                  endif
                  if (tnamt(ihsh)%ihshf /= 0) then
                     ihsh = tnamt(ihsh)%ihshf
                  else
                     exit
                  endif
               enddo
            endif
         endif
         itok1 = itok1 + 1
      enddo expl
!
!  Look for parentheses within defined types
!
         itok = 4
         do
            itok = itok + 1
            if (itok > ntok) exit
            if (kktokt (itok) == kkprc) then
               if (kktokt (itok-1) == kkpfr) then
                  npar = 1
                  do itok1 = itok - 3, 2, -1
                    if (kktokt (itok1) == kkpfr)  npar = npar + 1
                    if (kktokt (itok1) == kkpou .or. &
                        kktokt (itok1) == kkpnb) then
                       npar = npar - 1
                       if (npar == 0) then
                          kktokt (itok1) = kkpnb
                          exit
                       endif
                    endif
                  enddo
               endif
               if ((itok+2) < ntok) then
                  if (kktokt (itok+2) == kkpou) kktokt (itok+2) = kkpnb
               endif
               itok = itok + 1
            endif
         enddo
      return
end subroutine rdcstt
subroutine prsstt (ntok, ksstt)
!  Parse statement (partially)
use flexvars
use fprsvars
use fpprcurs
integer, intent (inout) :: ntok
integer, intent (out)   :: ksstt
! ____________________________________________________________________
!
      integer, save   :: kctxc = kcbeg
!
      itoks = 1
      kctok = kctxc
      ksstt = ksukn
!
!  Reduce "token clusters"
!
      if (ntok > itoks) then
         call rdcstt (ntok)
      endif
!
!  process $commands
!
      if (kktokt (itoks) == kkcmd) then
         itokd = itokdt (itoks)
         itokf = itokft (itoks)
         call tstidf (ztoki (itokd:itokf), kcbeg, krukn, kwidf, &
                      inamwt (itoks))
         call trtcmd (inamwt (itoks), ntok)
         ksstt = ksppr
         return
      endif
!
!  Are-we skipping ?
!
      if (ifskp /= 0) then
         return
      endif
!
!  Label ?
!
      ifdos = 0
      ifdoe = 0
      if (kktokt (itoks) == kknui) then
         itokd = itokdt (itoks)
         itokf = itokft (itoks)
         if ((itokf - itokd + 1) <= llabdm) then
            kktokt (itoks) = kklab
            kctok = kcblb
            itoks = itoks + 1
            ndoe  = 0
            do ilab = nlabd, 1, -1
               if (ztoki (itokd:itokf) == &
                   trim (zlabdt (ilab) (1:llabdm))) then
                  ndoe  = ndoe + 1
                  ifdoe = 1
                  zlabdt (ilab) (1:llabdm) = zlabdt (nlabd) (1:llabdm)
                  nlabd = nlabd - 1
               else
                  exit
               endif
            enddo
         endif
      endif
!
!  Block name ?
!
         if (itoks + 1 < ntok) then
            if (kktokt (itoks+1) == kkdpt .and. &
                kktokt (itoks)   == kkidf) then
               kktokt (itoks) = kkbnm
               kctok = kcbnb
               itoks = itoks + 2
            endif
         endif
!
!  Identify some keywords
!
      lpar = 0
      do itok = itoks, ntok
         if (kktokt (itok) == kkidf) then
            itokd = itokdt (itok)
            itokf = itokft (itok)
            krtok = krukn
            if (itok == ntok) then
               krtok = krlst
            else
               select case (kktokt (itok+1))
               case (kkstr)
                  krtok = krstr
               case (kkpou, kkpnb)
                  krtok = krpou
               end select
            endif
            call tstidf (ztoki (itokd:itokf), kctok, krtok, kwidf, &
                         inamwt (itok))
            if (itok < ntok) then
               select case (kwidf)
               case (kwatt)
                  kctok = kcdcl
               case (kwpat)
                  kctok = kcdcp
               case (kwaca)
                  kctok = kcall
               case (kwprc, kwfct)
                  kctok = kcprc
               case (kwass)
                  if (kktokt (itok+1) == kknui) kktokt (itok+1) = kklab
                  kctok = kcass
               case (kwfmt)
                  kctok = kcwtf
               case (kwaio)
                  kctok = kcwti
               case (kweli, kwifp)
                  kctok = kcife
               case (kwipl)
                  kctok = kcipl
               case (kwntt)
                  kctok = kcntt
               case (kwntf)
                  kctok = kcntf
               case (kwuse)
                  kctok = kcuse
               case (kwbcl)
                  kctok = kcbcl
               case (kwcas)
                  kctok = kccas
               case (kwgto)
                  if (kktokt (itok+1) == kknui) kktokt (itok+1) = kklab
                  if (kctok == kcbeg .or. kctok == kcbex .or. &
                      kctok == kcblb .or. kctok == kcbnb) then
                     kctok = kcwtx
                  endif
               case default
                  if (kctok == kcbeg .or. kctok == kcbex .or. &
                      kctok == kcblb .or. kctok == kcbnb) then
                     kctok = kcwtx
                  endif
               endselect
            endif
            select case (kwidf)
            case (kwprc, kwfct)
               ksstt = ksprs
            case (kwctn)
               ksstt = ksprm
            case (kwenp)
               ksstt = kspre
            case (kwifp)
               ksstt = ksifp
            case (kwthn)
               if (ksstt == ksifp) then
                  ksstt = ksifs
               endif
            case (kwels, kweli)
               ksstt = ksifm
            case (kweni)
               ksstt = ksife
            case (kwwhe)
               ksstt = kswhs
            case (kwelw)
               ksstt = kswhm
            case (kwenw)
               ksstt = kswhe
            case (kwbcl)
               ksstt = ksdos
            case (kwend)
               ksstt = ksdoe
               ndoe  = 1
            case (kwntf)
               ksstt = ksnts
            case (kwenf)
               ksstt = ksnte
            case (kwsel)
               ksstt = kssls
            case (kwcas)
               ksstt = ksslm
            case (kwens)
               ksstt = kssle
            case (kwtyp)
               ksstt = kstys
            case (kwent)
               ksstt = kstye
            case (kwfra)
               ksstt = ksfrs
            case (kwena)
               ksstt = ksfre
            end select
         elseif (kktokt (itok) == kkpou .or. &
                 kktokt (itok) == kkpnb) then
            lpar = lpar + 1
         elseif (kktokt (itok) == kkpfr) then
            if (itok >= ntok) exit
            lpar = lpar - 1
            if (lpar == 0) then
               select case (kctok)
               case default
                  continue
               case (kcntt)
                  kctok = kcdcl
               case (kcwti)
                  kctok = kcwtx
               endselect
!
!  non-block where and forall
!
               if ((ksstt == kswhs .or. ksstt == ksfrs) .and. &
                   (kktokt (itok+1) /= kkcmt .and.            &
                    kktokt (itok+1) /= kkebc)) then
                  ksstt = ksukn
               endif
            endif
!
!  Labels and DO loops
!
         elseif (kktokt (itok) == kkaff) then
            if (ksstt == ksdos .and. ifdos == 0) then
               ifdos = 1
            endif
         elseif (kktokt (itok) == kknui) then
            if (ksstt == ksdos .and. ifdos == 0) then
               ifdos = 1
               itokd = itokdt (itok)
               itokf = itokft (itok)
               if ((itokf - itokd + 1) <= llabdm) then
                  kktokt (itok) = kklab
                  if (nlabd >= nlabdm) then
                     call fpperr ("DO loops too deeply nested")
                  else
                     nlabd = nlabd + 1
                     zlabdt (nlabd) (1:llabdm) = ztoki (itokd:itokf)
                  endif
               endif
            endif
         endif
      enddo
      if (ifdoe /= 0) ksstt = ksdoe
      return
end subroutine prsstt
integer function khshstr (zstr)
!  A hash function for use in f90ppr
character (len=*), intent (in) :: zstr
! ____________________________________________________________________
      character (len=26), parameter :: zlwc="abcdefghijklmnopqrstuvwxyz"
      character (len=26), parameter :: zupc="ABCDEFGHIJKLMNOPQRSTUVWXYZ"
!
      jhsh = 0
      do istr = 1, len (zstr)
         irnk = index (zlwc, zstr (istr:istr))
         if (irnk > 0) then
            ichr = iachar (zupc (irnk:irnk))
         else
            ichr = iachar (zstr (istr:istr))
         endif
         jhsh = jhsh*17 + ichr - 45
         jhsh = modulo (jhsh, 4091)
      enddo
      khshstr = jhsh + 1
      return
end function khshstr
subroutine ininam
!  Initialise the names for f90ppr
use fprsvars
! _____________________________________________________________
!
      znamg (     1:  1230) = "&
&$$DEFINE$ELIF$ELSE$ENDIF$EVAL$IF$IFDEF$IFNDEF$INCLUDE$MACRO$UNDEF.AND..EQ..EQV..FALSE..GE..GT..LE..LT..NE..NEQV..NOT..OR..TRUE.ABS&
&ACOSASINATANATAN2ACCESSACTIONADVANCEALLOCATABLEALLOCATEASSIGNASSIGNMENTBACKSPACEBLANKBLOCKDATACALLCASECHARACTERCLOSECOMMONCOMPLEXC&
&ONTAINSCONTINUECOSCOSHCYCLEDATADEALLOCATEDEFAULTDELIMDIMENSIONDIRECTDODOUBLEPRECISIONELEMENTALELSEELSEIFELSEWHEREENDENDBLOCKDATAEN&
&DDOENDFILEENDFORALLENDFUNCTIONENDIFENDINTERFACEENDMODULEENDPROGRAMENDSELECTENDSUBROUTINEENDTYPEENDWHEREENTRYEOREQUIVALENCEERREXIST&
&EXITEXPEXTERNALFILEFMTFORALLFORMFORMATFORMATTEDFUNCTIONGOTOHIFIMPLICITININCLUDEINOUTINQUIREINTINTEGERINTENTINTERFACEINTRINSICIOLEN&
&GTHIOSTATKINDLENLOGLOG10LOGICALMAXMINMODMODULEMODULEPROCEDURENAMENAMEDNAMELISTNEXTRECNINTNMLNONENULLIFYNUMBEROONLYOPENOPENEDOPERAT&
&OROPTIONALOUTPADPARAMETERPAUSEPOINTERPOSITIONPRINTPRIVATEPROCEDUREPROGRAMPUBLICPUREREADREADWRITEREALRECRECLRECURSIVERESULTRETURNRE&
&WINDSAVESINSINHSELECTCASESELECTED_INT_KINDSELECTED_REAL_KINDSEQUENCESEQUENTIALSIZESQRTSTATSTATUSSTOPSUBROUTINETANTANHTARGETTHENTOT&
&YPETYPEUNFORMATTEDUNITUSEWHEREWHILEWRITEFPPR_LEAVEFPPR_LOWERFPPR_UPPERFPPR_FALSE_CMTFPPR_KWD_CASEFPPR_USR_CASEFPPR_FXD_INFPPR_FXD_&
&OUTFPPR_USE_SHARPFPPR_MAX_LINEFPPR_STP_INDENTFPPR_NMBR_LINES"
      inamg =   1230
!
      znamo (     1:  1249) = "&
&$$Define$ElIf$Else$EndIf$Eval$If$IfDef$IfnDef$Include$Macro$UnDef.And..Eq..Eqv..False..Ge..Gt..Le..Lt..Ne..Neqv..Not..Or..True.Abs&
&AcosAsinAtanAtan2AccessActionAdvanceAllocatableAllocateAssignAssignmentBackspaceBlankBlock DataCallCaseCharacterCloseCommonComplex&
&ContainsContinueCosCoshCycleDataDeallocateDefaultDelimDimensionDirectDoDouble PrecisionElementalElseElse IfElsewhereEndEnd Block D&
&ataEnd DoEndfileEnd ForallEnd FunctionEnd IfEnd InterfaceEnd ModuleEnd ProgramEnd SelectEnd SubroutineEnd TypeEnd WhereEntryEorEqu&
&ivalenceErrExistExitExpExternalFileFmtForallFormFormatFormattedFunctionGo ToHIfImplicitInIncludeInoutInquireIntIntegerIntentInterf&
&aceIntrinsicIoLengthIoStatKindLenLogLog10LogicalMaxMinModModuleModule ProcedureNameNamedNamelistNextRecNintNmlNoneNullifyNumberOOn&
&lyOpenOpenedOperatorOptionalOutPadParameterPausePointerPositionPrintPrivateProcedureProgramPublicPureReadReadWriteRealRecReclRecur&
&siveResultReturnRewindSaveSinSinhSelect CaseSelected_Int_KindSelected_Real_KindSequenceSequentialSizeSqrtStatStatusStopSubroutineT&
&anTanhTargetThenToTypeTypeUnformattedUnitUseWhereWhileWriteFPPR_leaveFPPR_lowerFPPR_upperFPPR_false_cmtFPPR_kwd_caseFPPR_usr_caseF&
&PPR_fxd_inFPPR_fxd_outFPPR_use_sharpFPPR_max_lineFPPR_stp_indentFPPR_nmbr_lines"
      inamo =   1249
!
      tnamt (    5) = namtyp (    0,    0,   42,  1071,  1075,  1090,  1094)
      tnamt (   28) = namtyp (    0,    0,   29,   580,   580,   597,   597)
      tnamt (   35) = namtyp (    0,    0,   16,   760,   760,   778,   778)
      tnamt (   48) = namtyp (    0,    0,    6,   637,   645,   654,   662)
      tnamt (   74) = namtyp (    0,    0,   56,   860,   863,   878,   881)
      tnamt (   92) = namtyp (    0,    0,   50,   365,   373,   368,   376)
      tnamt (  164) = namtyp (    0,    0,  263,  1162,  1173,  1181,  1192)
      tnamt (  179) = namtyp (    0,    0,   21,  1076,  1080,  1095,  1099)
      tnamt (  190) = namtyp (    0,    0,    2,    71,    74,    71,    74)
      tnamt (  228) = namtyp (    0,    0,   14,   202,   210,   202,   210)
      tnamt (  274) = namtyp (    0,    0,    5,   818,   825,   836,   843)
      tnamt (  276) = namtyp (    0,    0,    1,    25,    29,    25,    29)
      tnamt (  292) = namtyp (    0,    0,   14,   909,   914,   927,   932)
      tnamt (  325) = namtyp (    0,    0,   20,   926,   935,   944,   954)
      tnamt (  393) = namtyp ( 8191,    0,   52,  1040,  1043,  1059,  1062)
      tnamt (  426) = namtyp (    0,    0,   42,   329,   330,   330,   331)
      tnamt (  433) = namtyp (    0,    0,    5,   716,   720,   734,   738)
      tnamt (  454) = namtyp (    0,    0,   39,   897,   902,   915,   920)
      tnamt (  458) = namtyp (    0,    0,   22,   826,   830,   844,   848)
      tnamt (  467) = namtyp (    0,    0,    6,   797,   805,   815,   823)
      tnamt (  495) = namtyp (    0,    0,    1,    46,    53,    46,    53)
      tnamt (  502) = namtyp (    0,    0,   30,   581,   582,   598,   599)
      tnamt (  510) = namtyp (    0,    0,   12,   591,   592,   608,   609)
      tnamt (  511) = namtyp (    0,    0,  257,   612,   614,   629,   631)
      tnamt (  557) = namtyp (    0,    0,    5,   536,   539,   552,   555)
      tnamt (  561) = namtyp (    0,    0,    5,   646,   653,   663,   670)
      tnamt (  564) = namtyp (    0,    0,    2,    87,    90,    87,    90)
      tnamt (  568) = namtyp (    0,    0,    5,   769,   774,   787,   792)
      tnamt (  577) = namtyp (    0,    0,   22,   593,   599,   610,   616)
      tnamt (  597) = namtyp (    0,    0,    5,   979,   988,   998,  1007)
      tnamt (  609) = namtyp (    0,    0,    6,   660,   663,   677,   680)
      tnamt (  651) = namtyp (    0,    0,  263,  1216,  1230,  1235,  1249)
      tnamt (  698) = namtyp (    0,    0,   17,  1038,  1039,  1057,  1058)
      tnamt (  719) = namtyp (    0,    0,   34,   743,   746,   761,   764)
      tnamt (  721) = namtyp (    0,    0,   44,   355,   358,   357,   360)
      tnamt (  743) = namtyp (    0,    0,    6,   314,   322,   315,   323)
      tnamt (  747) = namtyp (    0,    0,    5,   712,   715,   730,   733)
      tnamt (  751) = namtyp (    0,    0,   25,   466,   478,   479,   492)
      tnamt (  758) = namtyp (    0,    0,    6,   233,   241,   234,   242)
      tnamt (  767) = namtyp (    0,    0,    6,   811,   817,   829,   835)
      tnamt (  797) = namtyp (    0,    0,    8,   775,   782,   793,   800)
      tnamt (  819) = namtyp (    0,    0,    2,    91,    94,    91,    94)
      tnamt (  822) = namtyp (    0,    0,    1,    39,    45,    39,    45)
      tnamt (  824) = namtyp (    0,    0,   57,   288,   291,   289,   292)
      tnamt (  834) = namtyp (    0,    0,    3,    80,    86,    80,    86)
      tnamt (  852) = namtyp (    0,    0,  262,  1091,  1100,  1110,  1119)
      tnamt (  895) = namtyp (    0,    0,   21,   864,   867,   882,   885)
      tnamt (  903) = namtyp (    0,    0,    6,   877,   880,   895,   898)
      tnamt (  919) = namtyp (    0,    0,   38,   915,   918,   933,   936)
      tnamt (  924) = namtyp (    0,    0,    1,     2,     8,     2,     8)
      tnamt (  937) = namtyp (    0,    0,    5,   884,   887,   902,   905)
      tnamt (  948) = namtyp (    0,    0,    5,   868,   876,   886,   894)
      tnamt (  966) = namtyp (    0,    0,   25,   410,   420,   417,   428)
      tnamt ( 1050) = namtyp (    0,    0,    6,   528,   535,   544,   551)
      tnamt ( 1128) = namtyp ( 8190,    0,    5,   559,   567,   575,   583)
      tnamt ( 1219) = namtyp (    0,    0,    6,   664,   666,   681,   683)
      tnamt ( 1238) = namtyp (    0,    0,   37,   761,   764,   779,   782)
      tnamt ( 1240) = namtyp (    0,    0,    8,   192,   201,   192,   201)
      tnamt ( 1293) = namtyp (    0,    0,   32,   622,   627,   639,   644)
      tnamt ( 1317) = namtyp (    0,    0,    9,   847,   853,   865,   871)
      tnamt ( 1326) = namtyp (    0,    0,   19,   268,   275,   269,   276)
      tnamt ( 1333) = namtyp (    0,    0,    2,   107,   112,   107,   112)
      tnamt ( 1372) = namtyp (    0,    0,   22,   903,   908,   921,   926)
      tnamt ( 1382) = namtyp ( 8192,    0,   10,   260,   267,   261,   268)
      tnamt ( 1385) = namtyp (    0,    0,   46,   389,   393,   394,   399)
      tnamt ( 1389) = namtyp (    0,    0,    5,   160,   166,   160,   166)
      tnamt ( 1399) = namtyp (    0,    0,  257,   993,   996,  1012,  1015)
      tnamt ( 1413) = namtyp (    0,    0,   35,   747,   753,   765,   771)
      tnamt ( 1426) = namtyp (    0,    0,   47,   457,   465,   469,   478)
      tnamt ( 1450) = namtyp (    0,    0,  257,   682,   684,   699,   701)
      tnamt ( 1461) = namtyp (    0,    0,   45,   421,   425,   429,   434)
      tnamt ( 1496) = namtyp (    0,    0,    6,  1028,  1033,  1047,  1052)
      tnamt ( 1543) = namtyp (    0,    0,    1,    60,    65,    60,    65)
      tnamt ( 1566) = namtyp (    0,    0,    9,   216,   224,   216,   225)
      tnamt ( 1576) = namtyp (    0,    0,  257,   685,   687,   702,   704)
      tnamt ( 1607) = namtyp (    0,    0,    1,     9,    13,     9,    13)
      tnamt ( 1608) = namtyp (    0,    0,  257,  1024,  1027,  1043,  1046)
      tnamt ( 1667) = namtyp (    0,    0,   25,   377,   388,   380,   393)
      tnamt ( 1668) = namtyp (    0,    0,  257,   688,   690,   705,   707)
      tnamt ( 1682) = namtyp (    0,    0,   28,   568,   575,   584,   591)
      tnamt ( 1686) = namtyp (    0,    0,   21,   765,   768,   783,   786)
      tnamt ( 1736) = namtyp (    0,    0,    1,    54,    59,    54,    59)
      tnamt ( 1750) = namtyp (    0,    0,    6,   697,   711,   714,   729)
      tnamt ( 1776) = namtyp (    0,    0,    1,    14,    18,    14,    18)
      tnamt ( 1777) = namtyp (    0,    0,   48,   486,   493,   501,   509)
      tnamt ( 1830) = namtyp (    0,    0,    5,   323,   328,   324,   329)
      tnamt ( 1931) = namtyp (    0,    0,    5,   740,   742,   758,   760)
      tnamt ( 1937) = namtyp (    0,    0,    5,   729,   735,   747,   753)
      tnamt ( 1956) = namtyp (    0,    0,    6,   675,   681,   692,   698)
      tnamt ( 1964) = namtyp (    0,    0,    5,   154,   159,   154,   159)
      tnamt ( 1974) = namtyp (    0,    0,   23,   247,   252,   248,   253)
      tnamt ( 1977) = namtyp (    0,    0,   40,   997,  1000,  1016,  1019)
      tnamt ( 1992) = namtyp (    0,    0,    1,    30,    32,    30,    32)
      tnamt ( 2009) = namtyp (    0,    0,    2,    95,    98,    95,    98)
      tnamt ( 2023) = namtyp (    0,    0,    5,  1059,  1062,  1078,  1081)
      tnamt ( 2031) = namtyp (    0,    0,    6,   331,   345,   332,   347)
      tnamt ( 2085) = namtyp (    0,    0,  257,   128,   130,   128,   130)
      tnamt ( 2119) = namtyp (    0,    0,    5,   211,   215,   211,   215)
      tnamt ( 2166) = namtyp (    0,    0,   18,   494,   498,   510,   514)
      tnamt ( 2195) = namtyp (    0,    0,    5,   654,   659,   671,   676)
      tnamt ( 2211) = namtyp (    0,    0,   22,  1007,  1010,  1026,  1029)
      tnamt ( 2254) = namtyp (    0,    0,  263,  1174,  1187,  1193,  1206)
      tnamt ( 2264) = namtyp (    0,    0,    2,    99,   102,    99,   102)
      tnamt ( 2268) = namtyp (    0,    0,   23,   721,   728,   739,   746)
      tnamt ( 2285) = namtyp (    0,    0,   38,   854,   859,   872,   877)
      tnamt ( 2287) = namtyp (    0,    0,  257,   936,   952,   955,   971)
      tnamt ( 2295) = namtyp (    0,    0,   22,   806,   810,   824,   828)
      tnamt ( 2297) = namtyp (    0,    0,    5,   794,   796,   812,   814)
      tnamt ( 2303) = namtyp (    0,    0,    6,   253,   259,   254,   260)
      tnamt ( 2311) = namtyp (    0,    0,   23,   502,   512,   518,   528)
      tnamt ( 2353) = namtyp (    0,    0,   54,   401,   409,   407,   416)
      tnamt ( 2354) = namtyp (    0,    0,  257,   670,   674,   687,   691)
      tnamt ( 2364) = namtyp (    0,    0,   12,   791,   793,   809,   811)
      tnamt ( 2401) = namtyp (    0,    0,    5,   549,   552,   565,   568)
      tnamt ( 2421) = namtyp (    0,    0,  263,  1125,  1137,  1144,  1156)
      tnamt ( 2499) = namtyp (    0,    0,    2,   113,   117,   113,   117)
      tnamt ( 2515) = namtyp (    0,    0,    8,   838,   846,   856,   864)
      tnamt ( 2587) = namtyp (    0,    0,    2,   103,   106,   103,   106)
      tnamt ( 2601) = namtyp (    0,    0,   15,   553,   558,   569,   574)
      tnamt ( 2637) = namtyp (    0,    0,    3,   122,   127,   122,   127)
      tnamt ( 2669) = namtyp (    0,    0,   25,   438,   446,   448,   457)
      tnamt ( 2687) = namtyp (    0,    0,  262,  1101,  1110,  1120,  1129)
      tnamt ( 2718) = namtyp (    0,    0,   31,   583,   590,   600,   607)
      tnamt ( 2771) = namtyp (    0,    0,   22,   283,   287,   284,   288)
      tnamt ( 2847) = namtyp (    0,    0,  263,  1138,  1150,  1157,  1169)
      tnamt ( 2863) = namtyp (    0,    0,    5,   309,   313,   310,   314)
      tnamt ( 2878) = namtyp (    0,    0,  257,   143,   147,   143,   147)
      tnamt ( 2884) = namtyp (    0,    0,  257,   276,   278,   277,   279)
      tnamt ( 2914) = namtyp (    0,    0,  262,  1081,  1090,  1100,  1109)
      tnamt ( 2934) = namtyp (    0,    0,   38,   831,   837,   849,   855)
      tnamt ( 2942) = namtyp (    0,    0,    5,   881,   883,   899,   901)
      tnamt ( 2960) = namtyp (    0,    0,  257,   131,   134,   131,   134)
      tnamt ( 3032) = namtyp (    0,    0,    1,    19,    24,    19,    24)
      tnamt ( 3040) = namtyp (    0,    0,    5,  1048,  1058,  1067,  1077)
      tnamt ( 3042) = namtyp (    0,    0,   49,  1066,  1070,  1085,  1089)
      tnamt ( 3053) = namtyp (    0,    0,    6,   167,   177,   167,   177)
      tnamt ( 3091) = namtyp (    0,    0,  257,   736,   739,   754,   757)
      tnamt ( 3097) = namtyp (    0,    0,    2,   118,   121,   118,   121)
      tnamt ( 3098) = namtyp (    0,    0,  257,   922,   925,   940,   943)
      tnamt ( 3125) = namtyp (    0,    0,    9,  1011,  1020,  1030,  1039)
      tnamt ( 3128) = namtyp (    0,    0,    5,   516,   520,   532,   536)
      tnamt ( 3134) = namtyp (    0,    0,    5,  1001,  1006,  1020,  1025)
      tnamt ( 3192) = namtyp (    0,    0,    1,    33,    38,    33,    38)
      tnamt ( 3197) = namtyp (    0,    0,   11,   302,   308,   303,   309)
      tnamt ( 3259) = namtyp (    0,    0,   55,   576,   579,   592,   596)
      tnamt ( 3271) = namtyp (    0,    0,    5,   148,   153,   148,   153)
      tnamt ( 3299) = namtyp (    0,    0,    5,   989,   992,  1008,  1011)
      tnamt ( 3309) = namtyp (    0,    0,    6,   783,   790,   801,   808)
      tnamt ( 3310) = namtyp (    0,    0,  257,   919,   921,   937,   939)
      tnamt ( 3360) = namtyp (    0,    0,    6,   615,   621,   632,   638)
      tnamt ( 3373) = namtyp (    0,    0,  257,   953,   970,   972,   989)
      tnamt ( 3386) = namtyp (    0,    0,  257,   135,   138,   135,   138)
      tnamt ( 3403) = namtyp (    0,    0,   53,   543,   548,   559,   564)
      tnamt ( 3430) = namtyp (    0,    0,   25,   374,   376,   377,   379)
      tnamt ( 3447) = namtyp (    0,    0,   27,   479,   485,   493,   500)
      tnamt ( 3461) = namtyp (    0,    0,    5,   499,   501,   515,   517)
      tnamt ( 3463) = namtyp (    0,    0,  257,  1021,  1023,  1040,  1042)
      tnamt ( 3480) = namtyp (    0,    0,   12,   600,   604,   617,   621)
      tnamt ( 3484) = namtyp (    0,    0,   41,  1034,  1037,  1053,  1056)
      tnamt ( 3488) = namtyp (    0,    0,   56,   888,   896,   906,   914)
      tnamt ( 3497) = namtyp (    0,    0,  263,  1111,  1124,  1130,  1143)
      tnamt ( 3501) = namtyp (    0,    0,  263,  1201,  1215,  1220,  1234)
      tnamt ( 3509) = namtyp (    0,    0,  263,  1151,  1161,  1170,  1180)
      tnamt ( 3512) = namtyp (    0,    0,    5,   513,   515,   529,   531)
      tnamt ( 3525) = namtyp (    0,    0,    2,    66,    70,    66,    70)
      tnamt ( 3535) = namtyp (    0,    0,    7,   292,   301,   293,   302)
      tnamt ( 3539) = namtyp (    0,    0,  257,   139,   142,   139,   142)
      tnamt ( 3611) = namtyp (    0,    0,   14,   394,   400,   400,   406)
      tnamt ( 3612) = namtyp (    0,    0,  257,   525,   527,   541,   543)
      tnamt ( 3676) = namtyp (    0,    0,   13,   186,   191,   186,   191)
      tnamt ( 3718) = namtyp (    0,    0,    5,   540,   542,   556,   558)
      tnamt ( 3719) = namtyp (    0,    0,    9,   691,   696,   708,   713)
      tnamt ( 3729) = namtyp (    0,    0,   38,   971,   978,   990,   997)
      tnamt ( 3733) = namtyp (    0,    0,    5,   754,   759,   772,   777)
      tnamt ( 3803) = namtyp (    0,    0,    7,   178,   185,   178,   185)
      tnamt ( 3854) = namtyp (    0,    0,   21,   242,   246,   243,   247)
      tnamt ( 3895) = namtyp (    0,    0,    2,    75,    79,    75,    79)
      tnamt ( 3922) = namtyp (    0,    0,   25,   447,   456,   458,   468)
      tnamt ( 3930) = namtyp (    0,    0,   33,   628,   636,   645,   653)
      tnamt ( 3968) = namtyp (    0,    0,   18,   225,   228,   226,   229)
      tnamt ( 4013) = namtyp (    0,    0,   21,   605,   611,   622,   628)
      tnamt ( 4031) = namtyp (    0,    0,   26,   426,   437,   435,   447)
      tnamt ( 4032) = namtyp (    0,    0,   24,   359,   364,   361,   367)
      tnamt ( 4034) = namtyp (    0,    0,   22,   521,   524,   537,   540)
      tnamt ( 4038) = namtyp (    0,    0,  257,   279,   282,   280,   283)
      tnamt ( 4049) = namtyp (    0,    0,   36,  1063,  1065,  1082,  1084)
      tnamt ( 4061) = namtyp (    0,    0,   56,   346,   354,   348,   356)
      tnamt ( 4080) = namtyp (    0,    0,   51,   229,   232,   230,   233)
      tnamt ( 4083) = namtyp (    0,    0,   16,     1,     1,     1,     1)
      tnamt ( 8190) = namtyp (    0, 1128,  263,  1188,  1200,  1207,  1219)
      tnamt ( 8191) = namtyp (    0,  393,    6,  1044,  1047,  1063,  1066)
      tnamt ( 8192) = namtyp (    0, 1382,  257,   667,   669,   684,   686)
      ialt =   8190
!
!
end subroutine ininam
subroutine tstidf (znam, kctok, krtok, kwnam, inam)
!  Try to make out what this identifier is
use fprsvars
use flexprms
use fpprcurs
character (len=*), intent (in) :: znam
integer, intent (in)           :: kctok, krtok
integer, intent (out)          :: kwnam, inam
! ____________________________________________________________________
!
    interface
      logical function ifsame (zstr1, zstr2)
!        Case insensitive compare
      character (len=*), intent (in) :: zstr1, zstr2
      end function ifsame
!
      logical function ifposs (kwnam, kctxt, krctx)
!  Test if keyword kwnam possible in context kctxt kwnam krctx
      use flexvars
      use fprsvars
      integer, intent (in) :: kwnam, kctxt, krctx
      end function ifposs
    end interface
!
      lnam = len_trim (znam)
      ihsh = khshstr (znam (1:lnam))
      ifput = 0
      inam  = 0
      if (tnamt(ihsh)%kwnam == 0) then
         kwnam = kwvar
         ifput = 1
         inam  = ihsh
         ibck = 0
      else
         do
            inamd = tnamt(ihsh)%inamd
            inamf = tnamt(ihsh)%inamf
            if (ifsame (znam (1:lnam), znamg (inamd:inamf))) then
               kwnam = tnamt(ihsh)%kwnam
               if (ifposs (kwnam, kctok, krtok)) then
                  inam = ihsh
                  exit
               endif
            endif
            if (tnamt(ihsh)%ihshf == 0) then
               ialt = ialt - 1
               if (tnamt(ialt)%kwnam /= 0) then
                     call fpperr ("insufficient name space, " // &
                                  "raise max # of names and try again")
                     stop
               endif
               kwnam = kwvar
               ifput = 1
               inam = ialt
               ibck = ihsh
               tnamt(ihsh)%ihshf = inam
               exit
            else
               ihsh = tnamt(ihsh)%ihshf
            endif
         enddo
      endif
!
      if (ifput /= 0) then
         inamd = inamg + 1
         inamg = inamg + lnam
         if (inamg > nnamm*lnama) then
            call fpperr ("insufficient name space (identifiers), " // &
                         "raise length of global chain and try again")
            stop
         endif
         inams = inamo + 1
         inamo = inamo + lnam
         if (inamo > nnamm*lnama*2) then
            call fpperr ("insufficient name space (out. idf. names), "//&
                         "raise length of global chain and try again")
            stop
         endif
         tnamt (inam) = namtyp (0, ibck, kwnam, inamd, inamg, &
                                inams, inamo)
         znamg (inamd:inamg) = znam (1:lnam)
         znamo (inams:inamo) = znam (1:lnam)
      endif
      return
end subroutine tstidf
logical function ifsame (zstr1, zstr2)
!  Case insensitive compare
use fpprprms
character (len=*), intent (in) :: zstr1, zstr2
! ____________________________________________________________________
      character (len=1) :: zchr1, zchr2
!
      lstr1 = len_trim (zstr1)
      lstr2 = len_trim (zstr2)
      if (lstr1 == lstr2) then
         ifsame = .true.
         do istr = 1, lstr1
            zchr1 = zstr1 (istr:istr)
            irnk  = index (zlwr, zchr1)
            if (irnk > 0) zchr1 = zupr (irnk:irnk)
            zchr2 = zstr2 (istr:istr)
            irnk  = index (zlwr, zchr2)
            if (irnk > 0) zchr2 = zupr (irnk:irnk)
            ifsame = (zchr1 == zchr2)
            if (.not. ifsame) exit
         enddo
      else
         ifsame = .false.
      endif
end function ifsame
logical function ifposs (kwnam, kctxt, krctx)
!  Test if keyword kwnam possible in context kctxt kwnam krctx
use fprsvars
integer, intent (in) :: kwnam, kctxt, krctx
! ____________________________________________________________________
!
      if (kctxt == kcany .and. krctx == krany) then
         ifposs = .true.
         return
      endif
      select case (kwnam)
      case default
         ifposs = .true.
      case (kwcmd)
         select case (kctxt)
         case default
            ifposs = .false.
         case (kcbeg, kccmd)
            ifposs = .true.
         end select
      case (kwlop, kwlct)
         select case (kctxt)
         case default
            ifposs = .true.
         case (kcukn, kcbeg, kcbex, kcblb, kcbnb)
            ifposs = .false.
         end select
      case (kwfmb)
         select case (kctxt)
         case default
            ifposs = .false.
         case (kcwtf)
            ifposs = .true.
         end select
      case (kwiok)
         select case (kctxt)
         case default
            ifposs = .false.
         case (kcwti)
            ifposs = .true.
         end select
      case (kwatt)
         select case (kctxt)
         case default
            ifposs = .false.
         case (kcbeg, kcdcl, kcany)
            ifposs = .true.
         end select
      case (kwpat)
         select case (kctxt)
         case default
            ifposs = .false.
         case (kcbeg, kcdcl, kcany)
            ifposs = .true.
         end select
      case (kwaca, kwaio, kwac6)
         select case (kctxt)
         case default
            ifposs = .false.
         case (kcbeg, kcbex, kcblb, kcany)
            ifposs = (krctx == krpou)
         end select
      case (kwgnn)
         select case (kctxt)
         case default
            ifposs = .false.
         case (kcntf, kcany)
            ifposs = .true.
         end select
      case (kwprc)
         select case (kctxt)
         case default
            ifposs = .false.
         case (kcbeg, kcdcp, kcany)
            ifposs = .true.
         end select
      case (kwctn)
         select case (kctxt)
         case default
            ifposs = .false.
         case (kcbeg, kcbex, kcany)
            ifposs = (krctx == krlst)
         end select
      case (kwdef)
         select case (kctxt)
         case default
            ifposs = .false.
         case (kccas, kcany)
            ifposs = .true.
         end select
      case (kwnta)
         select case (kctxt)
         case default
            ifposs = .false.
         case (kcntt, kcany)
            ifposs = .true.
         end select
      case (kwsts)
         select case (krctx)
         case default
            ifposs = .false.
         case (krstr)
            ifposs = .true.
         end select
      case (kwtoa)
         select case (kctxt)
         case default
            ifposs = .false.
         case (kcass)
            ifposs = .true.
         end select
      case (kwass)
         select case (kctxt)
         case default
            ifposs = .false.
         case (kcbeg, kcbex, kcblb, kcany)
            ifposs = .true.
         end select
      case (kwac2, kwac3, kwcas, kwgto)
         select case (kctxt)
         case default
            ifposs = .false.
         case (kcbeg, kcbex, kcblb, kcife)
            ifposs = (krctx /= krlst)
         case (kcany)
            ifposs = .true.
         end select
      case (kwac4, kwelw)
         select case (kctxt)
         case default
            ifposs = .false.
         case (kcbeg, kcbex, kcblb, kcife)
            ifposs = (krctx == krlst)
         case (kcany)
            ifposs = .true.
         end select
      case (kwfmt)
         select case (kctxt)
         case default
            ifposs = .false.
         case (kcblb, kcany)
            ifposs = .true.
         end select
      case (kwsel, kwwhe)
         select case (kctxt)
         case default
            ifposs = .false.
         case (kcbeg, kcbex, kcblb, kcbnb, kcany)
            ifposs = .true.
         end select
      case (kwfra)
         select case (kctxt)
         case default
            ifposs = .false.
         case (kcbeg, kcbex, kcblb, kcany)
            ifposs = .true.
         end select
      case (kwac5)
         select case (kctxt)
         case default
            ifposs = .false.
         case (kcbeg, kcbex, kcblb, kcife, kcany)
            ifposs = .true.
         end select
      case (kwacd)
         select case (kctxt)
         case default
            ifposs = .false.
         case (kcbeg)
            ifposs = (krctx /= krlst)
         case (kcany)
            ifposs = .true.
         end select
      case (kwdta)
         select case (kctxt)
         case default
            ifposs = .false.
         case (kcbeg)
            ifposs = (krctx /= krlst)
         case (kcany)
            ifposs = .true.
         end select
      case (kweli)
         select case (kctxt)
         case default
            ifposs = .false.
         case (kcbeg)
            ifposs = (krctx == krpou)
         case (kcany)
            ifposs = .true.
         end select
      case (kwenp)
         select case (kctxt)
         case default
            ifposs = .false.
         case (kcbeg, kcbex, kcblb, kcany)
            ifposs = .true.
         end select
      case (kwent)
         select case (kctxt)
         case default
            ifposs = .false.
         case (kcbeg, kcany)
            ifposs = .true.
         end select
      case (kwfct)
         select case (kctxt)
         case default
            ifposs = (krctx == krpou)
         case (kcbeg, kcdcl, kcdcp, kcany)
            ifposs = .true.
         end select
      case (kwhol)
! No support for Hollerith
            ifposs = .false.
      case (kwifp)
         select case (kctxt)
         case default
            ifposs = .false.
         case (kcbeg, kcbex, kcblb, kcbnb)
            ifposs = (krctx == krpou)
         case (kcany)
            ifposs = .true.
         end select
      case (kwipl)
         select case (kctxt)
         case default
            ifposs = .false.
         case (kcbeg, kcany)
            ifposs = .true.
         end select
      case (kwntt)
         select case (kctxt)
         case default
            ifposs = .false.
         case (kcbeg, kcdcl)
            ifposs = (krctx == krpou)
         case (kcany)
            ifposs = .true.
         end select
      case (kwntf)
         select case (kctxt)
         case default
            ifposs = .false.
         case (kcbeg, kcany)
            ifposs = .true.
         end select
      case (kwnon)
         select case (kctxt)
         case default
            ifposs = .false.
         case (kcipl, kcany)
            ifposs = .true.
         end select
      case (kwuse)
         select case (kctxt)
         case default
            ifposs = .false.
         case (kcbeg)
            ifposs = (krctx /= krlst)
         case (kcany)
            ifposs = .true.
         end select
      case (kwnly)
         select case (kctxt)
         case default
            ifposs = .false.
         case (kcuse, kcany)
            ifposs = .true.
         end select
      case (kwpps)
         select case (kctxt)
         case default
            ifposs = .false.
         case (kcbeg, kcdcl, kcany)
            ifposs = .true.
         end select
      case (kwrsl)
         select case (kctxt)
         case default
            ifposs = .false.
         case (kcprc, kcany)
            ifposs = .true.
         end select
      case (kwstt)
         select case (kctxt)
         case default
            ifposs = .false.
         case (kcall, kcany)
            ifposs = .true.
         end select
      case (kwthn)
         select case (kctxt)
         case default
            ifposs = .false.
         case (kcife, kcany)
            ifposs = .true.
         end select
      case (kwbcl)
         select case (kctxt)
         case default
            ifposs = .false.
         case (kcbeg, kcbex, kcblb, kcbnb, kcany)
            ifposs = .true.
         end select
      case (kwwhl)
         select case (kctxt)
         case default
            ifposs = .false.
         case (kcbcl, kcany)
            ifposs = .true.
         end select
      case (kwels, kweni, kwend, kwens, kwenw, kwenf, kwena)
         select case (kctxt)
         case default
            ifposs = .false.
         case (kcbeg, kcbex, kcany)
            ifposs = .true.
         end select
      case (kwtyp)
         select case (kctxt)
         case default
            ifposs = .false.
         case (kcbeg)
            ifposs = (krctx /= krpou)
         case (kcany)
            ifposs = .true.
         end select
      end select
end function ifposs
subroutine inicmd
!  Initialize pointers to pre-processor commands
use fprsvars
! ____________________________________________________________________
!
      iwdol = iwnam (zadol)
      iwdef = iwnam (zadef)
      iweli = iwnam (zaeli)
      iwels = iwnam (zaels)
      iwend = iwnam (zaend)
      iwevl = iwnam (zaevl)
      iwifx = iwnam (zaifx)
      iwifd = iwnam (zaifd)
      iwifn = iwnam (zaifn)
      iwinc = iwnam (zainc)
      iwmcr = iwnam (zamcr)
      iwund = iwnam (zaund)
!
      return
contains
      integer function iwnam (znam)
      character (len=*), intent (in) :: znam
! ____________________________________________________________________
      interface
         logical function ifsame (zstr1, zstr2)
!        Case insensitive compare
         character (len=*), intent (in) :: zstr1, zstr2
         end function ifsame
      end interface
      lnam = len_trim (znam)
      ihsh = khshstr (znam (1:lnam))
      if (tnamt(ihsh)%kwnam == 0) then
         iwnam = 0
      else
         do
            inamd = tnamt(ihsh)%inamd
            inamf = tnamt(ihsh)%inamf
            if (ifsame (znam (1:lnam), znamg (inamd:inamf))) then
               iwnam = ihsh
               exit
            endif
            if (tnamt(ihsh)%ihshf == 0) then
               iwnam = 0
               exit
            else
               ihsh = tnamt(ihsh)%ihshf
            endif
         enddo
      endif
      end function iwnam
end subroutine inicmd
subroutine trtcmd (iwnam, ntok)
!  Process pre-processor command
use fprsvars ! uses fprsprms
use flexvars ! uses flexprms
use fxprvars ! uses fxprprms
use fpprcurs ! uses fpprprms
integer, intent (in) :: iwnam
integer, intent (in) :: ntok
! ____________________________________________________________________
!
      integer, save :: iflev  = 0
      integer, save :: iflevr = 0
      integer       :: lzfic
      integer       :: inamod
      integer       :: inamof
      integer, save, dimension (nnsttm) :: ifdont = 0
      integer, dimension (nargm) :: inamat
      character (len=1), parameter :: zdlm = achar (1)
      character (len=2*lsttm) :: zsttw
      character (len=lsttm)   :: ztokw
      character (len=linem)   :: zrepw
      character (len=2)       :: znum
      character (len=lzficm)  :: zfic
      logical                 :: ifevl
!
body: do
!
!   $DEFINE
!
         if (iwnam == iwdef) then
            if (ifskp /= 0) exit body
            itok = 2
            if (itok > ntok) exit body
            itokd = itokdt (itok)
            itokf = itokft (itok)
            if (kktokt (itok) == kkidf) then
               call tstidf (ztoki (itokd:itokf), kcukn, krukn, kwtok, &
                            inam)
!
!   pre-defined keyword
!
               if (tnamt(inam)%kwnam == kwpdn .or. &
                   tnamt(inam)%kwnam == kwpds) then
!
!   False comments
!
                  if (inam == iwfcm) then
                     if (ncmti == ncmtim) then
                        call fpperr ("Too many false comments")
                        exit body
                     endif
                     itok = 3
                     if (ntok < itok) then
                        call fpperr ("Missing comment symbol")
                        exit body
                     endif
                     if (ntok == 4 .and. kktokt (itok) == kkcmd  &
                     .and. itokdt (itok) == itokft (itok)        &
                     .and. ztoki(itokdt(ntok)+1:itokdt(ntok)+1) == "!" &
                     .and. kktokt (ntok) == kkstr                ) then
                        itokd = itokdt (ntok) + 1
                        itokf = itokft (ntok) - 1
                     elseif (kktokt (itok) == kkcmt .or. &
                             kktokt (itok) == kkebc) then
                        itokd = itokdt (itok)
                        itokf = itokft (itok)
                     else
                        call fpperr ("Symbol is not comment")
                        exit body
                     endif
                     ncmti = ncmti + 1
                     zcmtit (ncmti) = ztoki (itokd:itokf)
!
!   Case processing
!
                  elseif (inam == iwcsk .or. inam == iwcsu) then
                     itok = 3
                     if (ntok < itok) then
                        kccur = kclve
                        exit body
                     endif
                     if (kktokt (itok) == kkidf) then
                        itokd = itokdt (itok)
                        itokf = itokft (itok)
                        call tstidf (ztoki (itokd:itokf), kcukn, krukn, &
                                     kwtok, inam1)
                        if (inam1 == iwlve) then
                           kccur = kclve
                        elseif (inam1 == iwlwr) then
                           kccur = kclwr
                        elseif (inam1 == iwupr) then
                           kccur = kcupr
                        else
                           call lexxpr (itok, ntok, kerr)
                           if (kerr /= 0) exit body
                           call evlxpr (ifevl, kerr)
                           if (kerr /= 0) exit body
                           kccur = nint (oxptt(1)%dval)
                           if (kccur /= kclve .and. &
                               kccur /= kclwr .and. &
                               kccur /= kcupr ) then
                              call fpperr ("Not a case definition")
                              exit body
                           endif
                        endif
                     else
                        call lexxpr (itok, ntok, kerr)
                        if (kerr /= 0) exit body
                        call evlxpr (ifevl, kerr)
                        if (kerr /= 0) exit body
                        kccur = nint (oxptt(1)%dval)
                        if (kccur /= kclve .and. &
                            kccur /= kclwr .and. &
                            kccur /= kcupr ) then
                           call fpperr ("Not a case definition")
                           exit body
                        endif
                     endif
                     if (inam == iwcsk) then
                        kccask = kccur
                     elseif (inam == iwcsu) then
                        kccasu = kccur
                     endif
!
!   Line length for splitting
!
                  elseif (inam == iwmll) then
                     itok = 3
                     if (ntok < itok) then
                        exit body
                     endif
                     call lexxpr (itok, ntok, kerr)
                     if (kerr /= 0) exit body
                     call evlxpr (ifevl, kerr)
                     if (kerr /= 0) exit body
                     jval = nint (oxptt(1)%dval)
                     if (jval < 2 .or. jval > linem ) then
                        call fpperr ("Not an allowed line length")
                        exit body
                     endif
                     linel = jval
!
!   step for indentation
!
                  elseif (inam == iwids) then
                     itok = 3
                     if (ntok < itok) then
                        exit body
                     endif
                     call lexxpr (itok, ntok, kerr)
                     if (kerr /= 0) exit body
                     call evlxpr (ifevl, kerr)
                     if (kerr /= 0) exit body
                     jval = nint (oxptt(1)%dval)
                     if (jval < 0 .or. jval > linem/2 ) then
                        call fpperr ("Not an allowed indentation step")
                        exit body
                     endif
                     nndtp = jval
!
!   Output line numbering information
!
                  elseif (inam == iwlnb) then
                     itok = 3
                     if (ntok < itok) then
                        iflnb = 1
                        exit body
                     else
                        call lexxpr (itok, ntok, kerr)
                        if (kerr /= 0) exit body
                        call evlxpr (ifevl, kerr)
                        if (kerr /= 0) exit body
                        if (ifevl) then
                           iflnb = 1
                        else
                           iflnb = 0
                        endif
                     endif
!
!   Input in Free or Fixed form
!
                  elseif (inam == iwfxi) then
                     itok = 3
                     if (ntok < itok) then
                        iffxd = 1
                        exit body
                     else
                        call lexxpr (itok, ntok, kerr)
                        if (kerr /= 0) exit body
                        call evlxpr (ifevl, kerr)
                        if (kerr /= 0) exit body
                        if (ifevl) then
                           iffxd = 1
                        else
                           iffxd = 0
                        endif
                     endif
!
!   Output in Free or Fixed form
!
                  elseif (inam == iwfxo) then
                     itok = 3
                     if (ntok < itok) then
                        iffxf = 1
                        exit body
                     else
                        call lexxpr (itok, ntok, kerr)
                        if (kerr /= 0) exit body
                        call evlxpr (ifevl, kerr)
                        if (kerr /= 0) exit body
                        if (ifevl) then
                           iffxf = 1
                        else
                           iffxf = 0
                        endif
                     endif
!
!   Treat Sharp as dollar
!
                  elseif (inam == iwsed) then
                     itok = 3
                     if (ntok < itok) then
                        ifsed = 1
                        exit body
                     else
                        call lexxpr (itok, ntok, kerr)
                        if (kerr /= 0) exit body
                        call evlxpr (ifevl, kerr)
                        if (kerr /= 0) exit body
                        if (ifevl) then
                           ifsed = 1
                        else
                           ifsed = 0
                        endif
                     endif
                  endif
                  exit body
               endif
               tnamt(inam)%kwnam = kwdfd
!
!   $"xxxxx" (not to be analysed), possibly multiple instruction
!
               itok = 3
               if (ntok == 4 .and. kktokt (itok) == kkcmd .and. &
                   itokdt (itok) == itokft (itok)         .and. &
                   kktokt (ntok) == kkstr) then
                  itokd = itokdt (ntok) + 1
                  itokf = itokft (ntok) - 1
                  lnam  = itokf - itokd + 1
                  inams = inamo + 1
                  inamo = inamo + lnam
                  if (inamo > nnamm*lnama*2) then
                     call fpperr ("insufficient name space&
                                      & (out. idf. names)")
                     call fpperr ("raise length of global&
                                      & chain and try again")
                     stop
                  endif
                  tnamt(inam)%inamod = inams
                  tnamt(inam)%inamof = inamo
                  znamo (inams:inamo) = ztoki (itokd:itokf)
!
!   expression (to be analysed)
!
               elseif (itok <= ntok) then
                  itokd = itokdt (itok)
                  itokf = itokft (ntok)
                  lnam  = itokf - itokd + 1
                  inams = inamo + 1
                  inamo = inamo + lnam
                  if (inamo > nnamm*lnama*2) then
                     call fpperr ("insufficient name space&
                                      & (out. idf. names)")
                     call fpperr ("raise length of global&
                                      & chain and try again")
                     stop
                  endif
                  ireps = irepg + 1
                  irepg = irepg + lnam
                  if (irepg > nrepgm) then
                     call fpperr ("insufficient name space&
                                      & (out. repl. names)")
                     call fpperr ("raise length of global&
                                      & chain and try again")
                     stop
                  endif
                  irepd = irep + 1
                  irep  = irep + (ntok - itok + 1)
                  if (irep > nrepm) then
                     call fpperr ("insufficient name space&
                                      & (out. repl. names)")
                     call fpperr ("raise # of repl. names&
                                      & and try again")
                     stop
                  endif
                  tnamt(inam)%irepc  = irepd
                  tnamt(inam)%inamod = inams
                  tnamt(inam)%inamof = inamo
                  znamo (inams:inamo) = ztoki (itokd:itokf)
                  zrepg (ireps:irepg) = ztoki (itokd:itokf)
                  itokn = itokft (ntok)
                  do itok1 = itok, ntok
                     itokd = itokdt (itok1)
                     itokf = itokft (itok1)
                     kkrept (irepd) = kktokt (itok1)
                     if (kkrept (irepd) == kkidf) then
                        if (itok1 == ntok) then
                           krtok = krany
                        else
                           select case (kktokt (itok1+1))
                           case (kkstr)
                              krtok = krstr
                           case (kkpou)
                              krtok = krpou
                           case default
                              krtok = krany
                           end select
                        endif
                        call tstidf (ztoki (itokd:itokf), kcany, krtok, &
                                     kwtok, irepwt (irepd))
                     endif
                     irepdt (irepd) = itokd + irepg - itokn
                     irepft (irepd) = itokf + irepg - itokn
                     irepnt (irepd) = irepd + 1
                     irepd = irepd + 1
                  enddo
                  irepnt (irep) = 0
               endif
               exit body
            else
               call fpperr ("Cannot redefine keyword" // &
                                ztoki (itokd:itokf))
               exit body
            endif
!
!   $UNDEF
!
         elseif (iwnam == iwund) then
            if (ifskp /= 0) exit body
            itok = 2
            if (itok > ntok) exit body
            itokd = itokdt (itok)
            itokf = itokft (itok)
            if (kktokt (itok) == kkidf) then
               call tstidf (ztoki (itokd:itokf), kcukn, krukn, kwtok, &
                            inam)
               if (tnamt(inam)%kwnam == kwdfd) then
                  lnam  = itokf - itokd + 1
                  inams = inamo + 1
                  inamo = inamo + lnam
                  if (inamo > nnamm*lnama*2) then
                     call fpperr ("insufficient name space&
                                      & (out. idf. names)")
                     call fpperr ("raise length of global&
                                      & chain and try again")
                     stop
                  endif
                  tnamt(inam)%kwnam  = kwvar
                  tnamt(inam)%inamod = inams
                  tnamt(inam)%inamof = inamo
                  znamo (inams:inamo) = ztoki (itokd:itokf)
               endif
               exit body
            else
               call fpperr ("Cannot undefine keyword" // &
                                ztoki (itokd:itokf))
               exit body
            endif
!
!   $EVAL
!
         elseif (iwnam == iwevl) then
            if (ifskp /= 0) exit body
            itok = 2
            if (itok > ntok) exit body
            itokd = itokdt (itok)
            itokf = itokft (itok)
            if (kktokt (itok) == kkidf) then
               call tstidf (ztoki (itokd:itokf), kcukn, krukn, kwtok, &
                            inam)
               itok = 3
               if (ntok < itok) then
                   zrepw = ".True."
               else
                   call lexxpr (itok, ntok, kerr)
                   if (kerr /= 0) exit body
                   call strxpr (zrepw, krep, kerr)
                   if (kerr /= 0) exit body
               endif
               tnamt(inam)%kwnam = kwdfd
!
               lnam  = len_trim (zrepw)
               inams = inamo + 1
               inamo = inamo + lnam
               if (inamo > nnamm*lnama*2) then
                     call fpperr ("insufficient name space&
                                      & (out. idf. names)")
                     call fpperr ("raise length of global&
                                      & chain and try again")
                     stop
               endif
               ireps = irepg + 1
               irepg = irepg + lnam
               if (irepg > nrepgm) then
                     call fpperr ("insufficient name space&
                                      & (out. repl. names)")
                     call fpperr ("raise length of global&
                                      & chain and try again")
                     stop
               endif
               irepd = irep + 1
               irep  = irep + 1
               if (irep > nrepm) then
                     call fpperr ("insufficient name space&
                                      & (out. repl. names)")
                     call fpperr ("raise # of repl. names&
                                      & and try again")
                     stop
               endif
               tnamt(inam)%irepc  = irepd
               tnamt(inam)%inamod = inams
               tnamt(inam)%inamof = inamo
               znamo (inams:inamo) = trim (zrepw)
               zrepg (ireps:irepg) = trim (zrepw)
               itokn = itokft (ntok)
               select case (krep)
               case (konul)
                  kkrept (irepd) = kklog
               case (konui)
                  kkrept (irepd) = kknui
               case (konuf)
                  kkrept (irepd) = kknuf
               case default
                  kkrept (irepd) = kkndf
               end select
               irepdt (irepd) = irepg + 1 - len_trim (zrepw)
               irepft (irepd) = irepg
               irepnt (irepd) = irepd + 1
               irepd = irepd + 1
               irepnt (irep) = 0
               exit body
            else
               call fpperr ("Cannot redefine keyword" // &
                                ztoki (itokd:itokf))
               exit body
            endif
!
!   $IF
!
         elseif (iwnam == iwifx) then
            itok = 2
            if (itok > ntok) exit body
            if (iflev >= nnsttm) then
               call fpperr ("Tests are too deeply nested")
               exit body
            endif
            iflev = iflev + 1
            ifdont (iflev) = -1
            if (ifskp == 0) then
               call lexxpr (itok, ntok, kerr)
               if (kerr /= 0) exit body
               call evlxpr (ifevl, kerr)
               if (kerr /= 0) exit body
               if (ifevl) then
                  ifskp = 0
                  ifdont (iflev) = 1
                  iflevr = iflev
                  exit body
               else
                  ifskp = 1
                  exit body
               endif
            endif
!
!   $IFDEF
!
         elseif (iwnam == iwifd) then
            itok = 2
            if (itok > ntok) exit body
            if (iflev >= nnsttm) then
               call fpperr ("Tests are too deeply nested")
               exit body
            endif
            iflev = iflev + 1
            ifdont (iflev) = -2
            if (ifskp == 0) then
               itokd = itokdt (itok)
               itokf = itokft (itok)
               if (kktokt (itok) == kkidf) then
                  call tstidf (ztoki (itokd:itokf), kcukn, krukn, &
                               kwtok, inam)
                  if (tnamt(inam)%kwnam == kwdfd) then
                     ifskp = 0
                     ifdont (iflev) = 2
                     iflevr = iflev
                  else
                     ifskp = 1
                  endif
                  exit body
               else
                  call fpperr ("Cannot test word " // ztoki(itokd:itokf))
                  exit body
               endif
            endif
!
!   $IFNDEF
!
         elseif (iwnam == iwifn) then
            itok = 2
            if (itok > ntok) exit body
            if (iflev >= nnsttm) then
               call fpperr ("Tests are too deeply nested")
               exit body
            endif
            iflev = iflev + 1
            ifdont (iflev) = -2
            if (ifskp == 0) then
               itokd = itokdt (itok)
               itokf = itokft (itok)
               if (kktokt (itok) == kkidf) then
                  call tstidf (ztoki (itokd:itokf), kcukn, krukn, &
                               kwtok, inam)
                  if (tnamt(inam)%kwnam /= kwdfd) then
                     ifskp = 0
                     ifdont (iflev) = 2
                     iflevr = iflev
                  else
                     ifskp = 1
                  endif
               else
                  call fpperr ("Cannot test word " // ztoki(itokd:itokf))
               endif
            endif
!
!   $ELSE
!
         elseif (iwnam == iwels) then
            if (iflevr == iflev - 1) then
               iflevr = iflevr + 1
               if (ifdont (iflevr) <= 0) then
                  ifskp = 0
                  ifdont (iflevr) = abs (ifdont (iflev))
               else
                  ifskp = 1
               endif
            elseif (iflevr == iflev) then
               iflevr = iflevr - 1
               ifskp  = 1
            endif
!
!   $ELIF
!
         elseif (iwnam == iweli) then
            itok = 2
            if (itok > ntok) exit body
            if (iflevr == iflev - 1) then
               iflevr = iflevr + 1
               if (ifdont (iflevr) == -1) then
                  call lexxpr (itok, ntok, kerr)
                  if (kerr /= 0) exit body
                  call evlxpr (ifevl, kerr)
                  if (kerr /= 0) exit body
                  if (ifevl) then
                     ifskp = 0
                     ifdont (iflevr) = 1
                  else
                     ifskp = 1
                     iflevr = iflevr -1
                  endif
               elseif (ifdont (iflevr) == -2) then
                  itokd = itokdt (itok)
                  itokf = itokft (itok)
                  if (kktokt (itok) == kkidf) then
                     call tstidf (ztoki (itokd:itokf), kcukn, krukn, &
                                  kwtok, inam)
                     if (tnamt(inam)%kwnam == kwdfd) then
                        ifskp = 0
                        ifdont (iflevr) = 2
                     else
                        ifskp = 1
                        iflevr = iflevr -1
                     endif
                  else
                     call fpperr ("Cannot test word " // ztoki(itokd:itokf))
                     exit body
                  endif
               else
                  ifskp = 1
               endif
            elseif (iflevr == iflev) then
               iflevr = iflevr - 1
               ifskp  = 1
            endif
!
!   $ENDIF
!
         elseif (iwnam == iwend) then
            iflev = iflev - 1
            if (iflevr >= iflev) then
               iflevr = iflev
               ifskp  = 0
            endif
!
!   $INCLUDE
!
         elseif (iwnam == iwinc) then
            if (ifskp /= 0) exit body
            itok = 2
            if (itok > ntok) exit body
            itokd = itokdt (itok)
            itokf = itokft (itok)
            select case (kktokt (itok))
               case (kkstr)
                  itokd = itokd + 1
                  itokf = itokf - 1
                  zfic = ztoki (itokd:itokf)
                  lzfic = itokf - itokd + 1
               case (kkidf)
                  call tstidf (ztoki(itokd:itokf), kcukn, krukn,  &
                               kwtok, inam)
                  if (tnamt(inam)%irepc /= 0) then
                     if (kkrept (tnamt(inam)%irepc) == kkstr) then
                        inamod = tnamt (inam)%inamod + 1
                        inamof = tnamt (inam)%inamof - 1
                        zfic = znamo (inamod:inamof)
                        lzfic = inamof - inamod + 1
                     else
                        call fpperr ("Include file name " // &
                                     ztoki (itokd:itokf) // &
                                     " must evaluate to string")
                        exit body
                     end if
                  else
                     call fpperr ("Include file name " // &
                                  ztoki (itokd:itokf) // &
                                  " is undefined")
                     exit body
                  end if
               case default
                  call fpperr ("Include file name must be string " // &
                               "or evaluate to string")
                  exit body
            end select
!
            lufic = lufic + 1
            open (lufic, file=zfic(1:lzfic), action="read", &
                  iostat=kerr)
            if (kerr /= 0) then
               call fpperr ("Unable to open include file: " // &
                                zfic (1:lzfic))
               close (lufic, iostat=kerr)
               lufic = lufic - 1
               exit body
            endif
            if (iclev < nnstim) then
               iclev = iclev + 1
            else
               call fpperr ("Include files too deeply nested")
               exit body
            endif
            islh = index (zfic(1:lzfic), '/', back=.true.)
            if (islh /= 0) then
               zfic = zfic (islh:lzfic)
               lzfic = lzfic + islh - 1
            endif
            zficit (iclev) = zfic (1:lzfic)
            nlinit (iclev) = 0
            zlinbh (iclev) = zlinb
            nhavh  (iclev) = nhav
            nhav = 0
            klnxth (iclev) = klnxt
            klrea = klnrm
            luinp = lufic
!
!   $MACRO
!
         elseif (iwnam == iwmcr) then
            if (ifskp /= 0) exit body
            if (ntok < 6) exit body
!
!   Analyse Macro to check that it is valid
!
            itok0 = 2
maca:       do
               if (kktokt (itok0) /= kkidf .or. &
                   kktokt (itok0+1) /= kkpou) then
                  ifvld = 0
                  exit maca
               endif
               narg = 1
               do itok = itok0 + 3, ntok, 2
                  if (kktokt (itok-1) /= kkidf) then
                     ifvld = 0
                     exit maca
                  else
                     itokd = itokdt (itok-1)
                     itokf = itokft (itok-1)
                     call tstidf (ztoki (itokd:itokf), kcukn, krukn, &
                                  kwtok, inam)
                     inamat (narg) = inam
                  endif
                  if (kktokt (itok) == kksep) then
                     narg = narg + 1
                     cycle
                  elseif (kktokt (itok) == kkpfr) then
                     ifvld = 1
                     exit maca
                  else
                     ifvld = 0
                     exit maca
                  endif
               enddo
               ifvld = 0
               exit maca
            enddo maca
            itokd = itokdt (itok0)
            itokf = itokft (itok0)
            if (ifvld /= 0) then
               call tstidf (ztoki (itokd:itokf), kcukn, krukn, kwtok, &
                            inam)
               tnamt(inam)%kwnam = kwmcrt (narg)
               tnamt(inam)%irepc = irep + 1
               if (kktokt (ntok) == kkcmt .or. &
                   kktokt (ntok) == kkebc) then
                  ntok1 = ntok - 1
               else
                  ntok1 = ntok
               endif
               itok = itok + 1
!
!   $"xxxxx" (not to be analysed), possibly multiple instruction
!
               if (ntok1 == itok+1 .and. kktokt (itok) == kkcmd .and. &
                   itokdt (itok) == itokft (itok)         .and. &
                   kktokt (ntok1) == kkstr) then
                  itokd = itokdt (ntok1) + 1
                  itokf = itokft (ntok1) - 1
                  lsttw = itokf - itokd + 4
!
!   Use non-printable char as delim
!
                  zsttw (1:lsttw) = zdlm // " " // &
                                    ztoki (itokd:itokf) // zdlm
                  do iarg = 1, narg
                     inam = inamat (iarg)
                     inamd = tnamt(inam)%inamd
                     inamf = tnamt(inam)%inamf
                     lnam  = inamf - inamd + 1
                     write (znum, "(i2)") iarg
                     do
                        iind = index (zsttw(1:lsttw), znamg(inamd:inamf))
                        if (iind == 0) then
                           exit
                        else
                           lsttw1 = lsttw - lnam + 4
                           zsttw (1:lsttw1) = zsttw (1:iind-1) //     &
                                              zdlm // znum // zdlm // &
                                              zsttw (iind+lnam:lsttw)
                           lsttw = lsttw1
                        endif
                     enddo
                  enddo
!
!   zsttw is now "xxx"nn"xxxxx"nn"xxxxx". Build token chain
!
                  kktok = kkukn
                  ltokw = 0
                  istt  = 2
                  do
                     if (istt > lsttw) then
                        exit
                     endif
                     if (zsttw (istt:istt) == zdlm .and. &
                         kktok == kkukn) then
                        if (ltokw /= 0) then
                           ireps = irepg + 1
                           irepg = irepg + ltokw
                           if (irepg > nrepgm) then
                              call fpperr ("insufficient name space&
                                               & (out. repl. names)")
                              call fpperr ("raise length of global&
                                               & chain and try again")
                              stop
                           endif
                           irep  = irep + 1
                           if (irep > nrepm) then
                              call fpperr ("insufficient name space&
                                               & (out. repl. names)")
                              call fpperr ("raise # of repl. names&
                                               & and try again")
                              stop
                           endif
                           zrepg (ireps:irepg) = ztokw (1:ltokw)
                           kkrept (irep) = kktok
                           irepdt (irep) = ireps
                           irepft (irep) = irepg
                           irepnt (irep) = irep + 1
                        endif
                        kktok = kkar0
                        ltokw = 0
                     elseif (zsttw (istt:istt) == zdlm .and. &
                             kktok == kkar0) then
                        irep  = irep + 1
                        if (irep > nrepm) then
                           call fpperr ("insufficient name space&
                                            & (out. repl. names)")
                           call fpperr ("raise # of repl. names&
                                            & and try again")
                           stop
                        endif
                        read (ztokw (1:ltokw), "(i2)") iarg
                        kkrept (irep) = kkargt (iarg)
                        irepdt (irep) = 0
                        irepft (irep) = 0
                        irepnt (irep) = irep + 1
                        kktok = kkukn
                        ltokw = 0
                     else
                        ltokw = ltokw + 1
                        ztokw (ltokw:ltokw) = zsttw (istt:istt)
                     endif
                     istt = istt + 1
                  enddo
                  irepnt (irep) = 0
!
!   expression (to be analysed)
!
               elseif (itok <= ntok1) then
                  itokd = itokdt (itok)
                  itokf = itokft (ntok1)
                  lnam  = itokf - itokd + 1
                  inams = inamo + 1
                  inamo = inamo + lnam
                  if (inamo > nnamm*lnama*2) then
                     call fpperr ("insufficient name space&
                                      & (out. idf. names)")
                     call fpperr ("raise length of global&
                                      & chain and try again")
                     stop
                  endif
                  ireps = irepg + 1
                  irepg = irepg + lnam
                  if (irepg > nrepgm) then
                     call fpperr ("insufficient name space&
                                      & (out. repl. names)")
                     call fpperr ("raise length of global&
                                      & chain and try again")
                     stop
                  endif
                  irepd = irep + 1
                  irep  = irep + (ntok1 - itok + 1)
                  if (irep > nrepm) then
                     call fpperr ("insufficient name space&
                                      & (out. repl. names)")
                     call fpperr ("raise # of repl. names&
                                      & and try again")
                     stop
                  endif
                  tnamt(inam)%irepc  = irepd
                  tnamt(inam)%inamod = inams
                  tnamt(inam)%inamof = inamo
                  znamo (inams:inamo) = ztoki (itokd:itokf)
                  zrepg (ireps:irepg) = ztoki (itokd:itokf)
                  itokn = itokft (ntok1)
                  do itok1 = itok, ntok1
                     itokd = itokdt (itok1)
                     itokf = itokft (itok1)
                     kkrept (irepd) = kktokt (itok1)
                     if (kkrept (irepd) == kkidf) then
                        call tstidf (ztoki (itokd:itokf), kcukn, krukn, &
                                     kwtok, irepwt (irepd))
                        do iarg = 1, narg
                           if (irepwt (irepd) == inamat (iarg)) then
                              kkrept (irepd) = kkargt (iarg)
                              exit
                           endif
                        enddo
                     endif
                     irepdt (irepd) = itokd + irepg - itokn
                     irepft (irepd) = itokf + irepg - itokn
                     irepnt (irepd) = irepd + 1
                     irepd = irepd + 1
                  enddo
                  irepnt (irep) = 0
               endif
               exit body
            else
               call fpperr ("Illegal macro expression for " // &
                                ztoki (itokd:itokf))
               exit body
            endif
!
         endif
         exit body
      enddo body
      return
end subroutine trtcmd
subroutine outstt (ntok, ksstt)
!  rebuild current statement
use flexvars
use fprsvars
use fpprcurs
integer, intent (in)       :: ntok
integer, intent (in)       :: ksstt
! ____________________________________________________________________
!
      integer, dimension (nnstdm) :: irepst
      integer, dimension (nargm)  :: irepat
      character (len=2*lsttm) :: zstt
      character (len=2*linem)   :: zcmt, zlab
      character (len=lsttm)   :: ztokw
!
!  Return if pre-processor command
!
      if (ksstt == ksppr) return
!
!  Need to change indent value ?
!

      select case (ksstt)
      case (ksprm)
         lprc = lprc - 1
         if (lprc == 0) nndt = nndt - nndtp
         nndt = nndt - nndtp
      case (kspre)
         lprc = lprc - 1
         if (lprc == 0) nndt = nndt - nndtp
         nndt = nndt - nndtp
      case (ksifm)
         nndt = nndt - nndtp
      case (ksife)
         nndt = nndt - nndtp
      case (ksfre)
         nndt = nndt - nndtp
      case (kswhm)
         nndt = nndt - nndtp
      case (kswhe)
         nndt = nndt - nndtp
      case (ksdoe)
         do idoe = 1, ndoe
            nndt = nndt - nndtp
         enddo
      case (ksnte)
         nndt = nndt - nndtp
      case (ksslm)
         nndt = nndt - nndtp
      case (kssle)
         nndt = nndt - nndtp
      case (kstye)
         nndt = nndt - nndtp
      end select

      nndt = max (nndt, 0)

      lstt = 0
      llab = 0
      lpar = 0
      irep1 = irep
      irepg1 = irepg
      if (ntok == 0) then
!
!  blank lines
!
         call wrtstt (zlab, llab, zblk, 0, zblk, len_trim (zblk), 0)
      elseif (ntok == 1 .and. kktokt (1) == kkcmt) then
         itokd = itokdt (1)
         itokf = itokft (1)
         ltok  = itokf - itokd + 1
         call wrtstt (zlab, llab, zblk, 0, ztoki (itokd:itokf), ltok, 0)
      elseif (ntok == 1 .and. kktokt (1) == kkebc) then
         itokd = itokdt (1)
         itokf = itokft (1)
         ltok  = itokf - itokd + 1
         call wrtstt (zlab, llab, zblk, 0, ztoki (itokd:itokf), ltok, 0)
      elseif (ntok == 1 .and. kktokt (1) == kkfcm) then
         itokd = itokdt (1)
         itokf = itokft (1)
         ltok  = itokf - itokd + 1
         call wrtstt (ztoki (itokd:itokf), ltok, zblk, 0, zblk, 0, 0)
      else
         kkprv = kkukn
         ifblk = 0
         lcmt  = 0
         instr = 0
         itok  = 0
         do
            if (instr == 0) then
               itok = itok + 1
               if (itok > ntok) exit
               itokd = itokdt (itok)
               itokf = itokft (itok)
               ltokw = itokf - itokd + 1
               ztokw (1:ltokw) = ztoki (itokd:itokf)
               kktok = kktokt (itok)
               if (kktok == kkidf) then
                  inam = inamwt (itok)
                  kwnam = tnamt(inam)%kwnam
                  if (kwnam == kwdfd .and. tnamt(inam)%irepc /= 0) then
                     instr = 1
                     irepd = tnamt(inam)%irepc
                     cycle
                  elseif (kwnam >= kwmc0 .and. tnamt(inam)%irepc /= 0) &
                         then
!
!  Analyse macro arguments
!
                     narge = kwnam - kwmc0
                     narg  = 1
                     irepat (narg) = irep1 + 1
                     itok1 = itok + 1
maca:                do
                        if (ntok < itok1 + 2*narge) then
                           ifvld = 0
                           exit maca
                        endif
                        if (kktokt (itok1) /= kkpou .and. &
                            kktokt (itok1) /= kkpnb) then
                           ifvld = 0
                           exit maca
                        endif
                        lpar  = 1
                        do
                           itok1 = itok1 + 1
                           if (itok1 > ntok) then
                              ifvld = 0
                              exit maca
                           endif
!
!  Add token to current arg list
!
                           itokd = itokdt (itok1)
                           itokf = itokft (itok1)
                           ltokw = itokf - itokd + 1
                           ireps  = irepg1 + 1
                           irepg1 = irepg1 + ltokw
                           if (irepg1 > nrepgm) then
                              write (luerr, *) "insufficient name space&
                                               & (out. repl. names)"
                              write (luerr, *) "raise length of global&
                                               & chain and try again"
                              stop
                           endif
                           irep1 = irep1 + 1
                           if (irep1 > nrepm) then
                              write (luerr, *) "insufficient name space&
                                               & (out. repl. names)"
                              write (luerr, *) "raise # of repl. names&
                                               & and try again"
                              stop
                           endif
                           kkrept (irep1) = kktokt (itok1)
                           irepdt (irep1) = ireps
                           irepft (irep1) = irepg1
                           irepnt (irep1) = irep1 + 1
                           zrepg (ireps:irepg1) = ztoki (itokd:itokf)
!
! Check for next argument or last one
! Find out nature of names
!
                           select case (kktokt (itok1))
                           case (kkpfr)
                              lpar = lpar - 1
                              if (lpar == 0) then
                                 if (narg == narge) then
                                    irep1 = irep1 - 1
                                    irepnt (irep1) = 0
                                    itok = itok1
                                    ifvld = 1
                                 else
                                    ifvld = 0
                                 endif
                                 exit maca
                              endif
                           case (kkpou, kkpnb)
                              lpar = lpar + 1
                           case (kksep)
                              if (lpar == 1) then
                                 irep1 = irep1 - 1
                                 irepnt (irep1) = 0
                                 narg = narg + 1
                                 irepat (narg) = irep1 + 1
                              endif
                           case (kkidf)
                              call tstidf (zrepg (ireps:irepg1), kcukn, &
                                           krukn, kwork, irepwt (irep1))
                           case default
                              continue
                           end select
                        enddo
                     enddo maca
!
! If it was legal macro, apply it
!
                     if (ifvld /= 0) then
                        instr = 1
                        irepd = tnamt(inam)%irepc
                        cycle
                     endif
                  else
                     itokd = tnamt(inam)%inamod
                     itokf = tnamt(inam)%inamof
                     ltokw = itokf - itokd + 1
                     ztokw (1:ltokw) = znamo (itokd:itokf)
                  endif
               endif
            else
               if (irepd == 0) then
                  instr = instr - 1
                  if (instr /= 0) then
                     irepd = irepst (instr)
                  endif
                  cycle
               endif
               itokd = irepdt (irepd)
               itokf = irepft (irepd)
               ltokw = itokf - itokd + 1
               ztokw (1:ltokw) = zrepg (itokd:itokf)
               kktok = kkrept (irepd)
               if (kktok == kkidf) then
                  inam  = irepwt (irepd)
                  kwnam = tnamt(inam)%kwnam
                  if (kwnam == kwdfd .and. tnamt(inam)%irepc /= 0) then
                     irepst (instr) = irepnt (irepd)
                     instr = instr + 1
                     if (instr > nnstdm) then
                        write (luerr, *) "defines should not be nested",&
                                         "deeper than", nnstdm
                        exit
                     endif
                     irepd = tnamt(inam)%irepc
                     cycle
                  endif
               elseif (kktok > kkar0) then
                  irepst (instr) = irepnt (irepd)
                  instr = instr + 1
                  if (instr > nnstdm) then
                     write (luerr, *) "defines should not be nested",&
                                      "deeper than", nnstdm
                     exit
                  endif
                  iarg  = kktok - kkar0
                  irepd = irepat (iarg)
                  cycle
               endif
               irepd = irepnt (irepd)
            endif
            if (ltokw + lstt + 2 > 2*lsttm) then
               call fpperr ("Substitution leads to line length overflow")
               exit
            endif
!
!  Construct line inserting spaces where necessary
!
            select case (kktok)
            case (kkcmt, kkebc)   ! Comment string
               if (ifblk == 0) then
                  ltok = ltokw + 1
                  zcmt (1:ltok) = " " // ztokw (1:ltokw)
               else
                  ltok = ltokw
                  zcmt (1:ltok) = ztokw (1:ltokw)
               endif
               lcmt = ltok
               exit
            case (kkfcm)   ! False comment
               llab = ltokw
               zlab (1:llab) = ztokw (1:ltokw)
               ltok = 0
            case (kklab)   ! Numerical label
               if (lstt == 0) then
                  llab = ltokw
                  zlab (1:llab) = ztokw (1:ltokw)
                  ltok = 0
               else
                  ltok = ltokw + 2
                  zstt (lstt+1:lstt+ltok) = " " // ztokw (1:ltokw) // " "
                  ifblk = 1
               endif
            case (kkstr, & ! Character string
            &     kkknd, & ! _Kind (underscore)
            &     kkbnm, & ! Block name
            &     kknui, & ! Integer Numerical value
            &     kknuf)   ! Real Numerical value
               ltok = ltokw
               zstt (lstt+1:lstt+ltok) = ztokw (1:ltokw)
               ifblk = 0
            case (kkprc)   ! %
               ltok = ltokw
               if (ifblk /= 0) lstt = lstt - 1
               zstt (lstt+1:lstt+ltok) = ztokw (1:ltokw)
               ifblk = 0
            case (kksep)   ! ,
               ltok = ltokw + 1
               if (ifblk /= 0) lstt = lstt - 1
               zstt (lstt+1:lstt+ltok) = ztokw (1:ltokw) // " "
               ifblk = 1
            case (kkidf)   ! Identifier
!
               if (kwnam <= kwsys .and. kccask /= kclve) then
                  call chgcas (ztokw (1:ltokw), kccask)
               elseif (kwnam > kwsys .and. kccasu /= kclve) then
                  call chgcas (ztokw (1:ltokw), kccasu)
               endif
!
               if (kwnam == kwlop .and. ifblk == 0) then
                  ltok = ltokw + 2
                  zstt (lstt+1:lstt+ltok) = " " // ztokw (1:ltokw) // " "
                  ifblk = 1
               elseif (kwnam == kwlop .and. ifblk /= 0) then
                  ltok = ltokw + 1
                  zstt (lstt+1:lstt+ltok) = ztokw (1:ltokw) // " "
                  ifblk = 1
               elseif (kwnam == kwac5) then
                  if (ifblk /= 0 .or. lstt == 0) then
                     ltok = ltokw + 1
                     zstt (lstt+1:lstt+ltok) = ztokw (1:ltokw) // " "
                  else
                     ltok = ltokw + 2
                     zstt (lstt+1:lstt+ltok) = " " // ztokw (1:ltokw)   &
                                                   // " "
                  endif
                  ifblk = 1
               elseif ((kkprv == kkidf .or. &
                        kkprv == kknui .or. &
                        kkprv == kknuf ) .and. ifblk == 0) then
                  ltok = ltokw + 1
                  zstt (lstt+1:lstt+ltok) = " " // ztokw (1:ltokw)
                  ifblk = 0
               else
                  ltok = ltokw
                  zstt (lstt+1:lstt+ltok) = ztokw (1:ltokw)
                  ifblk = 0
               endif
            case (kkdpt)   ! :
               if (lpar <= 0) then
                  ltok = ltokw + 1
                  zstt (lstt+1:lstt+ltok) = ztokw (1:ltokw) // " "
                  ifblk = 1
               else
                  ltok = ltokw
                  zstt (lstt+1:lstt+ltok) = ztokw (1:ltokw)
                  ifblk = 0
               endif
!
            case (kkpvg, & ! ;
            &     kkcmd, & ! $command (preprocessor)
            &     kkdot)   ! )
               ltok = ltokw + 1
               zstt (lstt+1:lstt+ltok) = ztokw (1:ltokw) // " "
               ifblk = 1
            case (kkqst)   ! ?
               ltok = 0
               if (ifblk /= 0) lstt = lstt - 1
               ifblk = 0
            case (kkpfr)   ! )
               lpar = lpar - 1
               ltok = ltokw + 1
               if (ifblk /= 0) lstt = lstt - 1
               zstt (lstt+1:lstt+ltok) = ztokw (1:ltokw) // " "
               ifblk = 1
            case (kkpou)   ! (
               lpar = lpar + 1
               if (lpar <= 1 .and. ifblk == 0) then
                  ltok = ltokw + 1
                  zstt (lstt+1:lstt+ltok) = " " // ztokw (1:ltokw)
               else
                  ltok = ltokw
                  zstt (lstt+1:lstt+ltok) = ztokw (1:ltokw)
               endif
               ifblk = 0
            case (kkpnb)   ! ( within defined type
               lpar = lpar + 1
               ltok = ltokw
               zstt (lstt+1:lstt+ltok) = ztokw (1:ltokw)
               ifblk = 0
            case (kkslh, & ! /
            &     kkpms, & ! + or -
            &     kkcct, & ! //
            &     kksta, & ! *
            &     kkpow, & ! **
            &     kkaff)   ! =
               if (lpar <= 0 .and. ifblk == 0) then
                  ltok = ltokw + 2
                  zstt (lstt+1:lstt+ltok) = " " // ztokw (1:ltokw) // " "
                  ifblk = 1
               elseif (lpar <= 0) then
                  ltok = ltokw + 1
                  zstt (lstt+1:lstt+ltok) = ztokw (1:ltokw) // " "
                  ifblk = 1
               else
                  if (ifblk /= 0) lstt = lstt - 1
                  ltok = ltokw
                  zstt (lstt+1:lstt+ltok) = ztokw (1:ltokw)
                  ifblk = 0
               endif
            case (kkcou, & ! (/
            &     kkneq, & ! /=
            &     kkleq, & ! <=
            &     kkequ, & ! ==
            &     kkgeq, & ! >=
            &     kkpts, & ! =>
            &     kksup, & ! >
            &     kkinf, & ! <
            &     kkdcl, & ! ::
            &     kklog, & ! .xxx.
            &     kkcfr)   ! /)
               if (ifblk == 0) then
                  ltok = ltokw + 2
                  zstt (lstt+1:lstt+ltok) = " " // ztokw (1:ltokw) // " "
               else
                  ltok = ltokw + 1
                  zstt (lstt+1:lstt+ltok) = ztokw (1:ltokw) // " "
               endif
               ifblk = 1
            case default
               ltok = ltokw
               zstt (lstt+1:lstt+ltok) = ztokw (1:ltokw)
               ifblk = 0
            endselect
            lstt = lstt + ltok
            kkprv = kktok
         enddo
         do
            if (zstt (lstt:lstt) /= " " .or. lstt <= 1) exit
            lstt = lstt - 1
         enddo
         call wrtstt (zlab, llab, zstt, lstt, zcmt, lcmt, nndt)
      endif
!
!  Need to change indent value ?
!
      select case (ksstt)
      case (ksprs)
         if (lprc == 0) nndt = nndt + nndtp
         lprc = lprc + 1
         nndt = nndt + nndtp
      case (ksprm)
         if (lprc == 0) nndt = nndt + nndtp
         lprc = lprc + 1
         nndt = nndt + nndtp
      case (ksifs)
         nndt = nndt + nndtp
      case (ksifm)
         nndt = nndt + nndtp
      case (ksfrs)
         nndt = nndt + nndtp
      case (kswhs)
         nndt = nndt + nndtp
      case (kswhm)
         nndt = nndt + nndtp
      case (ksdos)
         nndt = nndt + nndtp
      case (ksnts)
         nndt = nndt + nndtp
      case (kssls)
         nndt = nndt + nndtp
      case (ksslm)
         nndt = nndt + nndtp
      case (kstys)
         nndt = nndt + nndtp
      end select
      return
end subroutine outstt
subroutine wrtstt (zlab, llab, zstt, lstt, zcmt, lcmt, nndti)
!  write a label, a statement, and a trailing comment
use flexprms
use fpprcurs
character (len=*), intent (in) :: zlab, zstt, zcmt
integer, intent (in)           :: llab, lstt, lcmt, nndti
! ____________________________________________________________________
!
      character (len=*), parameter :: zfmts  = "(/)"
      character (len=*), parameter :: zfmt1n = "(a)"
      character (len=*), parameter :: zfmt1x = "(a,'&')"
      character (len=*), parameter :: zfmtl = "('# line ',i8,a)"
      character (len=1)            :: zdlm
      character (len=linem)        :: zheaw
      character (len=10)           :: zset
!
      integer, save :: nlino = 0
      integer, parameter :: lspltm = 5 ! decisions for splitting
      integer            :: lsplt
!
      lcmtw = lcmt
!
!  Null strings
!
      if (lstt <= 0) then
         if (lcmt /= 0) then
            nndtw = nndti
            lcmtw = lcmt
            if (lcmtw + nndtw > linem) then
               nndtw = 0
               lcmtw = min (lcmt, linem)
            endif
            if (llab == 0) then
               write (lufil, zfmt1n) repeat (" ", nndtw) &
                                     // adjustl(zcmt (1:lcmtw))
            else
               nndtw = max (1, nndtw - llab)
               write (lufil, zfmt1n)    zlab (1:llab) &
                                     // repeat (" ", nndtw) &
                                     // zcmt (1:lcmtw)
            endif
         else
            if (llab == 0) then
               write (lufil, zfmts)
            else
               write (lufil, zfmt1n) zlab (1:llab)
            endif
         endif
         nlino = nlino + 1
         return
      endif
!
!  Write line number
!
      if (iflnb /= 0) then
         write (lufil, zfmtl) nlinit (iclev), &
                              ' "' // trim(zficit(iclev)) // '"'
      endif
!
!  Find a reasonnable step
!
      if (iffxf == 0) then
         nndtw = nndti
         linew = linel
      else
         nndtw = max (nndti, 6)   ! fixed form code starts after column 6
         linew = 72         ! fixed form code ends on column 72
      endif
      lsttw = lstt + max (llab + 1 - nndtw, 0)
      if (lsttw > linew-2-nndtw) then
         call chxspl
      else
         lsplt = 0
      endif
      if (lsplt >= lspltm) then
         if (iffxf == 0) then
            linew = linem
            call chxspl
         endif
         if (lsplt >= lspltm) then
            if (iffxf == 0) then
               nndtw = 0
            else
               nndtw = 6   ! fixed form code starts columns 6
            endif
            lsttw = lstt + max (llab + 1 - nndtw, 0)
            call chxspl
            if (lsplt >= lspltm) then
               ncnt = (lsttw+linew-nndtw-3) / (linew-2-nndtw)
               write (luerr, *) "More than max # of continuation lines"
               write (luerr, *) "output lines", nlino + 1,             &
                                         " - ", nlino + ncnt
            endif
         endif
      endif
!
      ifin = 0
      ifchc = 0
      nampw = 2
      do
         ideb = ifin + 1
         ifin = ifin + linew - nampw - nndtw
         if (ideb == 1) then
            ifin = ifin + 1 ! no need for & at line start
            if (llab /= 0) then
               nndtw1 = max (nndtw, llab + 1)
               ifin = ifin + nndtw - nndtw1
            endif
         else
            if (nndtw > 1) then
               ifin = ifin + 1 ! leading & will not use character
            endif
         endif
         ifin = min (ifin, lstt)
         ifchp = ifchc
         if (ifin < lstt .and. lsplt < lspltm) then
            ilst = ideb
            do ichr = ideb, ifin
               if (ifchc == 0 .and. &
                   (zstt (ichr:ichr) == "'" .or. &
                    zstt (ichr:ichr) == '"' )    ) then
                  ifchc = 1
                  zdlm = zstt (ichr:ichr)
               elseif (ifchc == 1 .and. &
                       zstt (ichr:ichr) == zdlm) then
                  ifchc = 0
                  ilst  = ichr
               endif
            enddo
            if (ifchc == 0) then
               select case (lsplt)
               case default
                  zset = " "
               case (1)
                  zset = " +-"
               case (2)
                  zset = " +-,:="
               case (3)
                  zset = " +-,:=/*"
               case (4)
                  zset = " +-,:=/*><"
               end select
               ibck = scan (zstt (ilst+1:ifin+1), zset, &
                             back=.true.)
               if (ibck > 0) then
                  ifin = ilst + ibck
               endif
               nampw = 3
            else
               nampw = 2
            endif
         endif
!
!  First line of instruction
!
         if (ideb == 1) then
            if (ifin == lstt) then
               if (lcmt == 0) then
                  if (llab == 0) then
                     write (lufil, zfmt1n) repeat (" ", nndtw) &
                                           // zstt (ideb:ifin)
                  else
                     nndtw2 = nndtw1 - llab
                     write (lufil, zfmt1n)    zlab (1:llab)        &
                                           // repeat (" ", nndtw2) &
                                           // zstt (ideb:ifin)
                  endif
               else
                  if (llab == 0) then
                     llin = ifin - ideb + 1 + nndtw
                     if (llin <= linew) then
                        write (lufil, zfmt1n) repeat (" ", nndtw) &
                                              // zstt (ideb:ifin) &
                                              // zcmt (1:lcmtw)
                     else
                        write (lufil, zfmt1n) repeat (" ", nndtw) &
                                              // zstt (ideb:ifin)
                        nlino = nlino + 1
                        write (lufil, zfmt1n) adjustl (zcmt (1:lcmtw))
                     endif
                  else
                     nndtw2 = nndtw1 - llab
                     llin = ifin - ideb + 1 + nndtw1
                     if (llin <= linew) then
                        write (lufil, zfmt1n)    zlab (1:llab)        &
                                              // repeat (" ", nndtw2) &
                                              // zstt (ideb:ifin)     &
                                              // zcmt (1:lcmtw)
                     else
                        write (lufil, zfmt1n)    zlab (1:llab)        &
                                              // repeat (" ", nndtw2) &
                                              // zstt (ideb:ifin)
                        nlino = nlino + 1
                        write (lufil, zfmt1n) adjustl (zcmt (1:lcmtw))
                     endif
                  endif
               endif
               nlino = nlino + 1
               exit
            else
               if (iffxf == 0) then
                  if (llab == 0) then
                     write (lufil, zfmt1x) repeat (" ", nndtw) &
                                           // zstt (ideb:ifin)
                  else
                     nndtw2 = nndtw1 - llab
                     write (lufil, zfmt1x)    zlab (1:llab)        &
                                           // repeat (" ", nndtw2) &
                                           // zstt (ideb:ifin)
                  endif
               else
                  nfilw = 72 - nndtw - (ifin - ideb + 1)
                  if (llab == 0) then
                     write (lufil, zfmt1x) repeat (" ", nndtw) &
                                        // zstt (ideb:ifin) &
                                        // repeat (" ", nfilw)
                  else
                     nndtw2 = nndtw1 - llab
                     write (lufil, zfmt1x)    zlab (1:llab)        &
                                           // repeat (" ", nndtw2) &
                                           // zstt (ideb:ifin)     &
                                           // repeat (" ", nfilw)
                  endif
               endif
            endif
!
!  Other line of instruction
!
         else
            nndtw1 = max (nndtw, 1)
            if (iffxf == 0) then
               zheaw = repeat (" ", nndtw1 - 1) // "& "
               if (ifchp == 0) then
                  nndtw1 = nndtw1 + 1
               endif
            elseif (ifchp /= 0) then
               zheaw = repeat (" ", 5) // "&"
               nndtw1 = 6
            else
               zheaw = repeat (" ", 5) // "&"
            endif
            if (ifin == lstt) then
               if (lcmt == 0) then
                  write (lufil, zfmt1n) zheaw (1:nndtw1) &
                                     // zstt (ideb:ifin)
               else
                  llin = ifin - ideb + 1 + nndtw1
                  if (llin <= linew) then
                     write (lufil, zfmt1n) zheaw (1:nndtw1) &
                                        // zstt (ideb:ifin) &
                                        // zcmt (1:lcmtw)
                  else
                     write (lufil, zfmt1n) zheaw (1:nndtw1) &
                                        // zstt (ideb:ifin)
                     nlino = nlino + 1
                     write (lufil, zfmt1n) adjustl (zcmt (1:lcmtw))
                  endif
               endif
               nlino = nlino + 1
               exit
            else
               if (iffxf == 0) then
                  write (lufil, zfmt1x) zheaw (1:nndtw1) &
                                     // zstt (ideb:ifin)
               else
                  nfilw = 72 - nndtw1 + 1 - (ifin - ideb + 2)
                  write (lufil, zfmt1x) zheaw (1:nndtw1) &
                                        // zstt (ideb:ifin) &
                                        // repeat (" ", nfilw)
               endif
            endif
         endif
         nlino = nlino + 1
      enddo
      return
contains
   subroutine chxspl
! Choose assumptions governing splitting at end of lines
! ____________________________________________________________________
!
   lsplt = 0
   levels: do
      if (lsplt >= lspltm) exit levels
      ifinw = 0
      ifchc = 0
      nlinw = 0
      nampw = 2
      do
         idebw = ifinw + 1
         ifinw = ifinw + linew - nampw - nndtw
         if (idebw == 1) then
            ifinw = ifinw + 1 ! no need for & at line start
            if (llab /= 0) then
               nndtw1 = max (nndtw, llab + 1)
               ifinw = ifinw + nndtw - nndtw1
            endif
         else
            if (nndtw > 1) then
               ifinw = ifinw + 1 ! leading & will not use character
            endif
         endif
         ifinw = min (ifinw, lstt)
!
!  Need to split - Use current criteria
!
         if (ifinw < lstt) then
            ilst = idebw
            do ichr = idebw, ifinw
               if (ifchc == 0 .and. &
                   (zstt (ichr:ichr) == "'" .or. &
                    zstt (ichr:ichr) == '"' )    ) then
                  ifchc = 1
                  zdlm = zstt (ichr:ichr)
               elseif (ifchc == 1 .and. &
                       zstt (ichr:ichr) == zdlm) then
                  ifchc = 0
                  ilst  = ichr
               endif
            enddo
            if (ifchc == 0) then
               select case (lsplt)
               case default
                  zset = " "
               case (1)
                  zset = " +-"
               case (2)
                  zset = " +-,:="
               case (3)
                  zset = " +-,:=/*"
               case (4)
                  zset = " +-,:=/*><"
               end select
               ibck = scan (zstt (ilst+1:ifinw+1), zset, &
                             back=.true.)
               if (ibck > 0) then
                  ifinw = ilst + ibck
                  nampw = 3
               else
                  lsplt = lsplt + 1
                  cycle levels
               endif
            else
               ibck = index (zstt (ilst+1:ifinw+1), zdlm, &
                             back=.true.)
               if (ibck > 0) then
                  ifinw = ilst + ibck - 1
                  nampw = 3
                  ifchc = 0
               else
                  nampw = 2
               endif
            endif
         endif
!
!  First line of instruction
!
         if (idebw == 1) then
            if (ifinw == lstt) then
               nlinw = nlinw + 1
               exit
            endif
!
!  Other line of instruction
!
         else
            if (ifinw == lstt) then
               nlinw = nlinw + 1
               exit
            endif
         endif
         nlinw = nlinw + 1
         if (nlinw > ncntm) exit
      enddo
      if (nlinw <= ncntm) then
         return
      else
         lsplt = lsplt + 1
      endif
   enddo levels
   end subroutine chxspl
end subroutine wrtstt
subroutine inixpr
!  Initialize pointers to expression operators
use fprsvars
use fxprprms
! ____________________________________________________________________
!
      iwand = iwnam (zoand)
      iwequ = iwnam (zoequ)
      iwgeq = iwnam (zogeq)
      iwgth = iwnam (zogth)
      iwleq = iwnam (zoleq)
      iwlth = iwnam (zolth)
      iwneq = iwnam (zoneq)
      iwnot = iwnam (zonot)
      iwori = iwnam (zoori)
!
      iwtru = iwnam (zotru)
      iwfls = iwnam (zofls)
!
      iwint = iwnam (zoint)
      iwnin = iwnam (zonin)
      iwsin = iwnam (zosin)
      iwcos = iwnam (zocos)
      iwtan = iwnam (zotan)
      iwatn = iwnam (zoatn)
      iwlog = iwnam (zolog)
      iwexp = iwnam (zoexp)
      iwl10 = iwnam (zol10)
      iwsqr = iwnam (zosqr)
      iwmod = iwnam (zomod)
      iwmax = iwnam (zomax)
      iwmin = iwnam (zomin)
      iwat2 = iwnam (zoat2)
      iwasn = iwnam (zoasn)
      iwacs = iwnam (zoacs)
      iwsnh = iwnam (zosnh)
      iwcsh = iwnam (zocsh)
      iwtnh = iwnam (zotnh)
      iwabs = iwnam (zoabs)
      iwknd = iwnam (zoknd)
      iwsik = iwnam (zosik)
      iwsrk = iwnam (zosrk)
!
      iwfcm = iwnam (zofcm)
      iwcsk = iwnam (zocsk)
      iwcsu = iwnam (zocsu)
      iwfxi = iwnam (zofxi)
      iwfxo = iwnam (zofxo)
      iwsed = iwnam (zosed)
      iwmll = iwnam (zomll)
      iwids = iwnam (zoids)
      iwlnb = iwnam (zolnb)
!
      iwlve = iwnam (zalve)
      iwlwr = iwnam (zalwr)
      iwupr = iwnam (zaupr)
!
      return
contains
      integer function iwnam (znam)
      character (len=*), intent (in) :: znam
! ____________________________________________________________________
      interface
         logical function ifsame (zstr1, zstr2)
!        Case insensitive compare
         character (len=*), intent (in) :: zstr1, zstr2
         end function ifsame
      end interface
      lnam = len_trim (znam)
      ihsh = khshstr (znam (1:lnam))
      if (tnamt(ihsh)%kwnam == 0) then
         iwnam = 0
      else
         do
            inamd = tnamt(ihsh)%inamd
            inamf = tnamt(ihsh)%inamf
            if (ifsame (znam (1:lnam), znamg (inamd:inamf))) then
               iwnam = ihsh
               exit
            endif
            if (tnamt(ihsh)%ihshf == 0) then
               iwnam = 0
               exit
            else
               ihsh = tnamt(ihsh)%ihshf
            endif
         enddo
      endif
      end function iwnam
end subroutine inixpr
subroutine lexxpr (itok0, ntok, kerr)
!  prepare lexed statement for analysis as an expression
use flexvars
use fxprvars
use fprsvars
use fpprcurs
integer, intent (in) :: itok0
integer, intent (in) :: ntok
! ____________________________________________________________________
!
      double precision            :: dxpt
      integer, dimension (nnstdm) :: irepst
      character (len=lsttm)       :: ztokw
!
      kerr = 0
      instr = 0
      itok  = itok0 - 1
      ixptg = 0
      ixpt  = 0
      do
         if (instr == 0) then
            itok = itok + 1
            if (itok > ntok) exit
            itokd = itokdt (itok)
            itokf = itokft (itok)
            kktok = kktokt (itok)
            if (kktok == kkidf) then
               call tstidf (ztoki (itokd:itokf), kcany, krany, kwtok, &
                            inam)
               kwnam = tnamt(inam)%kwnam
               if (kwnam == kwdfd .and. tnamt(inam)%irepc /= 0) then
                  instr = 1
                  irepd = tnamt(inam)%irepc
                  cycle
               elseif (kwnam >= kwmc0 .and. tnamt(inam)%irepc /= 0) &
                      then
!
!  Analyse macro arguments
!
                  narge = kwnam - kwmc0
                  narg  = 1
                  itok1 = itok + 1
maca:             do
                     if (ntok < itok1 + 2*narge) then
                        ifvld = 0
                        exit maca
                     endif
                     if (kktokt (itok1) /= kkpou) then
                        ifvld = 0
                        exit maca
                     endif
                     lpar  = 1
                     do
                        itok1 = itok1 + 1
                        if (itok1 > ntok) then
                           ifvld = 0
                           exit maca
                        endif
!
!  Add token to current arg list
!
                        itokd = itokdt (itok1)
                        itokf = itokft (itok1)
                        ltokw = itokf - itokd + 1
                        ireps = irepg + 1
                        irepg = irepg + ltokw
                        if (irepg > nrepgm) then
                           call fpperr ("insufficient name space&
                                            & (out. repl. names)")
                           call fpperr ("raise length of global&
                                            & chain and try again")
                           stop
                        endif
                        irep = irep + 1
                        if (irep > nrepm) then
                           call fpperr ("insufficient name space&
                                            & (out. repl. names)")
                           call fpperr ("raise # of repl. names&
                                            & and try again")
                           stop
                        endif
                        kkrept (irep) = kktokt (itok1)
                        irepdt (irep) = ireps
                        irepft (irep) = irepg
                        irepnt (irep) = irep + 1
                        zrepg (ireps:irepg) = ztoki (itokd:itokf)
!
! Check for next argument or last one
!
                        select case (kktokt (itok1))
                        case (kkpfr)
                           lpar = lpar - 1
                           if (lpar == 0) then
                              if (narg == narge) then
                                 irep = irep - 1
                                 irepnt (irep) = 0
                                 itok = itok1
                                 ifvld = 1
                              else
                                 ifvld = 0
                              endif
                              exit maca
                           endif
                        case (kkpou)
                           lpar = lpar + 1
                        case (kksep)
                           if (lpar == 1) then
                              irep = irep - 1
                              irepnt (irep) = 0
                              narg = narg + 1
                           endif
                        case default
                           continue
                        end select
                     enddo
                  enddo maca
!
! If it was legal macro, apply it
!
                  if (ifvld /= 0) then
                     instr = 1
                     irepd = tnamt(inam)%irepc
                     cycle
                  endif
               else
                  itokd = tnamt(inam)%inamod
                  itokf = tnamt(inam)%inamof
                  ltokw = itokf - itokd + 1
                  ztokw (1:ltokw) = znamo (itokd:itokf)
               endif
            else
               ltokw = itokf - itokd + 1
               ztokw (1:ltokw) = ztoki (itokd:itokf)
            endif
         else
            if (irepd == 0) then
               instr = instr - 1
               if (instr /= 0) then
                  irepd = irepst (instr)
               endif
               cycle
            endif
            itokd = irepdt (irepd)
            itokf = irepft (irepd)
            ltokw = itokf - itokd + 1
            ztokw (1:ltokw) = zrepg (itokd:itokf)
            kktok = kkrept (irepd)
            if (kktok == kkidf) then
               inam  = irepwt (irepd)
               kwnam = tnamt(inam)%kwnam
               if (kwnam == kwdfd .and. tnamt(inam)%irepc /= 0) then
                  irepst (instr) = irepnt (irepd)
                  instr = instr + 1
                  if (instr > nnstdm) then
                  call fpperr ("defines nesting overflow")
                  exit
                  endif
                  irepd = tnamt(inam)%irepc
                  cycle
               else
                  itokd = tnamt(inam)%inamod
                  itokf = tnamt(inam)%inamof
                  ltokw = itokf - itokd + 1
                  ztokw (1:ltokw) = znamo (itokd:itokf)
               endif
            endif
            irepd = irepnt (irepd)
         endif
         if (ltokw + ixptg > nxptgm) then
            call fpperr ("Substitution leads to expression length&
                        & overflow")
            exit
         endif
         select case (kktok)
         case default
            kerr = 1
            call fpperr ("term not allowed in expression: " // &
                         ztokw (1:ltokw))
            exit
         case (kkcmt, kkebc)   ! Comment string
            exit
!
!  Constants
!
         case (kknui)   ! Integer Numerical value
            ixpt = ixpt + 1
            read (ztokw (1:ltokw), *, iostat=kerr) dxpt
            if (kerr /= 0) then
               call fpperr ("term not allowed in expression: " // &
                            ztokw (1:ltokw))
               exit
            endif
            oxptt (ixpt) = opropd (dxpt, konui, ixpt-1, ixpt+1)
         case (kknuf)   ! Real Numerical value
            ixpt = ixpt + 1
            read (ztokw (1:ltokw), *, iostat=kerr) dxpt
            if (kerr /= 0) then
               call fpperr ("term not allowed in expression: " // &
                            ztokw (1:ltokw))
               exit
            endif
            oxptt (ixpt) = opropd (dxpt, konuf, ixpt-1, ixpt+1)
         case (kkidf)   ! Identifier
!
!  Old form comparisons
!
            if (kwnam == kwlop) then
               if (inam == iwand) then
                  ixpt = ixpt + 1
                  oxptt (ixpt) = opropd (0.0d0, koand, ixpt-1, ixpt+1)
               elseif (inam == iwequ) then
                  ixpt = ixpt + 1
                  oxptt (ixpt) = opropd (0.0d0, koequ, ixpt-1, ixpt+1)
               elseif (inam == iwgeq) then
                  ixpt = ixpt + 1
                  oxptt (ixpt) = opropd (0.0d0, kogeq, ixpt-1, ixpt+1)
               elseif (inam == iwgth) then
                  ixpt = ixpt + 1
                  oxptt (ixpt) = opropd (0.0d0, kogth, ixpt-1, ixpt+1)
               elseif (inam == iwleq) then
                  ixpt = ixpt + 1
                  oxptt (ixpt) = opropd (0.0d0, koleq, ixpt-1, ixpt+1)
               elseif (inam == iwlth) then
                  ixpt = ixpt + 1
                  oxptt (ixpt) = opropd (0.0d0, kolth, ixpt-1, ixpt+1)
               elseif (inam == iwneq) then
                  ixpt = ixpt + 1
                  oxptt (ixpt) = opropd (0.0d0, koneq, ixpt-1, ixpt+1)
               elseif (inam == iwnot) then
                  ixpt = ixpt + 1
                  oxptt (ixpt) = opropd (0.0d0, konot, ixpt-1, ixpt+1)
               elseif (inam == iwori) then
                  ixpt = ixpt + 1
                  oxptt (ixpt) = opropd (0.0d0, koori, ixpt-1, ixpt+1)
               else
                  kerr = 1
                  call fpperr ("term not allowed in expression: " // &
                               ztokw (1:ltokw))
                  exit
               endif
!
!  Logical constants
!
            elseif (kwnam == kwlct) then
               if (inam == iwtru) then
                  ixpt = ixpt + 1
                  dxpt = 1.0D0
                  oxptt (ixpt) = opropd (dxpt, konui, ixpt-1, ixpt+1)
               elseif (inam == iwfls) then
                  ixpt = ixpt + 1
                  dxpt = 0.0D0
                  oxptt (ixpt) = opropd (dxpt, konui, ixpt-1, ixpt+1)
               else
                  kerr = 1
                  call fpperr ("term not allowed in expression: " // &
                               ztokw (1:ltokw))
                  exit
               endif
!
!  Known intrinsics
!
            elseif (kwnam == kwntr) then
               if (inam == iwint) then
                  ixpt = ixpt + 1
                  oxptt (ixpt) = opropd (0.0d0, koint, ixpt-1, ixpt+1)
               elseif (inam == iwnin) then
                  ixpt = ixpt + 1
                  oxptt (ixpt) = opropd (0.0d0, konin, ixpt-1, ixpt+1)
               elseif (inam == iwsin) then
                  ixpt = ixpt + 1
                  oxptt (ixpt) = opropd (0.0d0, kosin, ixpt-1, ixpt+1)
               elseif (inam == iwcos) then
                  ixpt = ixpt + 1
                  oxptt (ixpt) = opropd (0.0d0, kocos, ixpt-1, ixpt+1)
               elseif (inam == iwtan) then
                  ixpt = ixpt + 1
                  oxptt (ixpt) = opropd (0.0d0, kotan, ixpt-1, ixpt+1)
               elseif (inam == iwatn) then
                  ixpt = ixpt + 1
                  oxptt (ixpt) = opropd (0.0d0, koatn, ixpt-1, ixpt+1)
               elseif (inam == iwlog) then
                  ixpt = ixpt + 1
                  oxptt (ixpt) = opropd (0.0d0, kolog, ixpt-1, ixpt+1)
               elseif (inam == iwexp) then
                  ixpt = ixpt + 1
                  oxptt (ixpt) = opropd (0.0d0, koexp, ixpt-1, ixpt+1)
               elseif (inam == iwl10) then
                  ixpt = ixpt + 1
                  oxptt (ixpt) = opropd (0.0d0, kol10, ixpt-1, ixpt+1)
               elseif (inam == iwsqr) then
                  ixpt = ixpt + 1
                  oxptt (ixpt) = opropd (0.0d0, kosqr, ixpt-1, ixpt+1)
               elseif (inam == iwmod) then
                  ixpt = ixpt + 1
                  oxptt (ixpt) = opropd (0.0d0, komod, ixpt-1, ixpt+1)
               elseif (inam == iwmax) then
                  ixpt = ixpt + 1
                  oxptt (ixpt) = opropd (0.0d0, komax, ixpt-1, ixpt+1)
               elseif (inam == iwmin) then
                  ixpt = ixpt + 1
                  oxptt (ixpt) = opropd (0.0d0, komin, ixpt-1, ixpt+1)
               elseif (inam == iwat2) then
                  ixpt = ixpt + 1
                  oxptt (ixpt) = opropd (0.0d0, koat2, ixpt-1, ixpt+1)
               elseif (inam == iwasn) then
                  ixpt = ixpt + 1
                  oxptt (ixpt) = opropd (0.0d0, koasn, ixpt-1, ixpt+1)
               elseif (inam == iwacs) then
                  ixpt = ixpt + 1
                  oxptt (ixpt) = opropd (0.0d0, koacs, ixpt-1, ixpt+1)
               elseif (inam == iwsnh) then
                  ixpt = ixpt + 1
                  oxptt (ixpt) = opropd (0.0d0, kosnh, ixpt-1, ixpt+1)
               elseif (inam == iwcsh) then
                  ixpt = ixpt + 1
                  oxptt (ixpt) = opropd (0.0d0, kocsh, ixpt-1, ixpt+1)
               elseif (inam == iwtnh) then
                  ixpt = ixpt + 1
                  oxptt (ixpt) = opropd (0.0d0, kotnh, ixpt-1, ixpt+1)
               elseif (inam == iwabs) then
                  ixpt = ixpt + 1
                  oxptt (ixpt) = opropd (0.0d0, koabs, ixpt-1, ixpt+1)
               elseif (inam == iwknd) then
                  ixpt = ixpt + 1
                  oxptt (ixpt) = opropd (0.0d0, koknd, ixpt-1, ixpt+1)
               elseif (inam == iwsik) then
                  ixpt = ixpt + 1
                  oxptt (ixpt) = opropd (0.0d0, kosik, ixpt-1, ixpt+1)
               elseif (inam == iwsrk) then
                  ixpt = ixpt + 1
                  oxptt (ixpt) = opropd (0.0d0, kosrk, ixpt-1, ixpt+1)
               else
                  kerr = 1
                  call fpperr ("term not allowed in expression: " // &
                               ztokw (1:ltokw))
                  exit
               endif
            else
               kerr = 1
               call fpperr ("term not allowed in expression: " // &
                            ztokw (1:ltokw))
               exit
            endif
!
!  "Separators"
!
         case (kkpfr)   ! )
            ixpt = ixpt + 1
            oxptt (ixpt) = opropd (0.0d0, kopfr, ixpt-1, ixpt+1)
         case (kkpou)   ! (
            ixpt = ixpt + 1
            oxptt (ixpt) = opropd (0.0d0, kopou, ixpt-1, ixpt+1)
         case (kksep)   ! ,
            ixpt = ixpt + 1
            oxptt (ixpt) = opropd (0.0d0, kosep, ixpt-1, ixpt+1)
!
!  Comparisons
!
         case (kksup)   ! >
            ixpt = ixpt + 1
            oxptt (ixpt) = opropd (0.0d0, kogth, ixpt-1, ixpt+1)
         case (kkgeq)   ! >=
            ixpt = ixpt + 1
            oxptt (ixpt) = opropd (0.0d0, kogeq, ixpt-1, ixpt+1)
         case (kkneq)   ! /=
            ixpt = ixpt + 1
            oxptt (ixpt) = opropd (0.0d0, koneq, ixpt-1, ixpt+1)
         case (kkleq)   ! <=
            ixpt = ixpt + 1
            oxptt (ixpt) = opropd (0.0d0, koleq, ixpt-1, ixpt+1)
         case (kkinf)   ! <
            ixpt = ixpt + 1
            oxptt (ixpt) = opropd (0.0d0, kolth, ixpt-1, ixpt+1)
         case (kkequ)   ! ==
            ixpt = ixpt + 1
            oxptt (ixpt) = opropd (0.0d0, koequ, ixpt-1, ixpt+1)
!
!  Operators
!
         case (kkslh)   ! /
            ixpt = ixpt + 1
            oxptt (ixpt) = opropd (0.0d0, kodiv, ixpt-1, ixpt+1)
         case (kkpms)   ! + or -
            ixpt = ixpt + 1
            if (ztokw (1:1) == "+") then
               oxptt (ixpt) = opropd (0.0d0, kopls, ixpt-1, ixpt+1)
            else
               oxptt (ixpt) = opropd (0.0d0, komns, ixpt-1, ixpt+1)
            endif
         case (kksta)   ! *
            ixpt = ixpt + 1
            oxptt (ixpt) = opropd (0.0d0, komlt, ixpt-1, ixpt+1)
         case (kkpow)   ! **
            ixpt = ixpt + 1
            oxptt (ixpt) = opropd (0.0d0, kopow, ixpt-1, ixpt+1)
         endselect
      enddo
!
      oxptt (ixpt)%inxt = 0
      return
end subroutine lexxpr
subroutine evlxpr (ifres, kerr)
!  analyse lexed expression and evaluate result as logical
logical, intent (out) :: ifres
integer, intent (out) :: kerr
! ____________________________________________________________________
!
      double precision :: dres
      kerr = 0
      ifres = .true.
      call valxpr (dres, kres, kerr)
      ifres = (dres /= 0.0d0)
      return
end subroutine evlxpr
subroutine valxpr (dresw, kresw, kerr)
!  analyse lexed expression and value result in a character string
use fxprvars
use fpprcurs
double precision, intent (out) :: dresw
integer, intent (out) :: kresw, kerr
! ____________________________________________________________________
!
      kerr = 0
      kresw = konuf
      dresw = 1.0d0
      ixpte = ixpt
body: do
         if (ixpte < 1) then
            call fpperr ("Empty expression")
            kerr = 1
            exit body
         elseif (ixpte == 1) then
            if (oxptt(ixpte)%koprd == konui .or. &
                oxptt(ixpte)%koprd == konuf) then
               kresw = oxptt(ixpte)%koprd
               dresw = oxptt(ixpte)%dval
            else
               call fpperr ("Illegal expression")
               kerr = 2
            endif
            exit body
         else
!
!  Change Fun (A, B) into (A) .Fun. (B) where it appears
!
            ixptw = 1
            ixpta = ixpte
            do
               select case (oxptt(ixptw)%koprd)
               case (komod, komax, komin, koat2, kosrk)
!
!  Find corresponding separator
!
                  lpar = 0
                  ixpt1 = oxptt (ixptw)%inxt
                  do
                     select case (oxptt(ixpt1)%koprd)
                     case (kopfr)
                        lpar = lpar - 1
                        if (lpar <= 0) then
                           if (oxptt(ixptw)%koprd == kosrk) then
                              ixptw = oxptt (ixptw)%inxt
                              exit
                           endif
                           call fpperr ("Missing argument")
                           kerr = 3
                           exit body
                        endif
                     case (kopou)
                        lpar = lpar + 1
                     case (kosep)
                        koprdw = oxptt(ixptw)%koprd
                        iprv = oxptt (ixptw)%iprv
                        oxptt (ixptw) = oxptt (oxptt (ixptw)%inxt)
                        oxptt (ixptw)%iprv = iprv
                        oxptt (oxptt (ixptw)%inxt)%iprv = ixptw
                        if (ixpta + 2 > nxptm) then
                           call fpperr ("Operation stack too small" // &
                           " increase # of operators/ands and try again")
                           kerr = 4
                           exit body
                        endif
                        select case (koprdw)
                        case (komod)
                           koopr = komodi
                        case (komax)
                           koopr = komaxi
                        case (komin)
                           koopr = komini
                        case (koat2)
                           koopr = koat2i
                        case (kosrk)
                           koopr = kosrki
                        case default
                           koopr = koukn
                        end select
                        ixpt2 = oxptt (ixpt1)%iprv
                        ixpt4 = oxptt (ixpt1)%inxt
                        oxptt (ixpt1) = &
                                    opropd (0.0D0, kopfr, ixpt2, ixpta+1)
                        oxptt (ixpta+1) = &
                                    opropd (0.0D0, koopr, ixpt1, ixpta+2)
                        oxptt (ixpta+2) = &
                                    opropd (0.0D0, kopou, ixpta+1, ixpt4)
                        oxptt (ixpt4)%iprv = ixpta + 2
                        ixpta = ixpta + 2
                        exit
                     end select
                     ixpt1 = oxptt (ixpt1)%inxt
                     if (ixpt1 <= 0) then
                        call fpperr ("Illegal expression")
                        kerr = 5
                        exit body
                     endif
                  enddo
               case default
                  ixptw = oxptt (ixptw)%inxt
               end select
               if (ixptw <= 0) exit
            enddo
!
!  Reduce expressions
!
            ixptw = 1
            ixptd = 1
            do
               select case (oxptt(ixptw)%koprd)
               case (kopfr)
                  ixptf = ixptw
                  if (oxptt (ixptw)%iprv == 0) then
                     call fpperr ("Unexpected )")
                     kerr = 6
                     exit body
                  endif
                  call rdcxpr
                  if (oxptt (ixptd)%inxt == 0 .and.                     &
                      oxptt (ixptd)%iprv == 0) exit
                  ixptd = 1
                  ixptw = 1
                  cycle
               case (kopou)
                  ixptd = ixptw
               case (kosep)
                  call fpperr ("Illegal expression")
                  kerr = 5
                  exit body
               case default
               end select
               ixpt1 = oxptt (ixptw)%inxt
               if (ixpt1 <= 0) then
                  ixptf = ixptw
                  call rdcxpr
                  exit
               else
                  ixptw = ixpt1
               endif
            enddo
            if (kerr /= 0) then
               call fpperr ("Illegal expression")
               kerr = 5
               exit body
            else
               kresw = oxptt(ixptd)%koprd
               dresw = oxptt(ixptd)%dval
            endif
         endif
         exit body
      enddo body
      return
contains
      subroutine rdcxpr
!   Reduce an expression with no inner parentheses
         integer, dimension (nxptm) :: koprt, ixptt
         double precision dopd1, dopd2, dres
!
!   Remove enclosing parentheses if any
!
         ixpt4 = ixptf
         do
            kopr4 = oxptt(ixpt4)%koprd
            ixpt3 = oxptt(ixpt4)%iprv
            if (ixpt3 == 0) then
               if (kopr4 /= konui .and. kopr4 /= konuf) then
                  kerr = 7
               endif
               return
            endif
            kopr2 = oxptt(ixptd)%koprd
            ixpt2 = oxptt(ixptd)%inxt
            if (kopr4 == kopfr .and. kopr2 == kopou) then
               if (oxptt(ixpt4)%inxt /= 0) then
                  oxptt (oxptt(ixpt4)%inxt)%iprv = ixpt3
               endif
               oxptt(ixpt3)%inxt = oxptt(ixpt4)%inxt
               iprvw = oxptt(ixptd)%iprv
               oxptt(ixptd) = oxptt(ixpt2)
               oxptt(ixptd)%iprv = iprvw
               oxptt (oxptt(ixptd)%inxt)%iprv = ixptd
               ixptf = ixpt3
            else
               exit
            endif
         enddo
!
!   Find and apply unary operators, and store binary ones
!
         ixpt4 = ixptf
         ixpt3 = oxptt(ixpt4)%iprv
         kopr4 = oxptt(ixpt4)%koprd
         ixpt2 = oxptt(ixptd)%inxt
!
         nopr  = 0
         do
            if (ixptf == ixptd) exit
            if (ixpt3 /= ixptd) then
               ixpt2 = oxptt(ixpt3)%iprv
               kopr2 = oxptt(ixpt2)%koprd
            else
               ixpt2 = 0
               kopr2 = koukn
            endif
            kopr3 = oxptt(ixpt3)%koprd
            kopr4 = oxptt(ixpt4)%koprd
            if (kopr4 == konui .or. kopr4 == konuf) then
               if (kopr3 /= konui .and. kopr3 /= konuf .and. &
                   kopr2 /= konui .and. kopr2 /= konuf) then
!
!   Apply unary operator at 3 to value at 4
!
                   dopd1 = oxptt(ixpt4)%dval
                   call xqtunr (kopr3, kopr4, dopd1, kres, dres)
                   if (kerr /= 0) then
                      return
                   endif
                   oxptt(ixpt3)%dval  = dres
                   oxptt(ixpt3)%koprd = kres
                   oxptt(ixpt3)%inxt  = oxptt(ixpt4)%inxt
                   if (oxptt(ixpt3)%inxt /= 0) then
                      oxptt (oxptt(ixpt3)%inxt)%iprv = ixpt3
                   endif
               else
                   select case (kopr3)
                   case default
                      continue
                   case (koori, koand, kogth, kogeq, kolth, koleq, &
                         koneq, komns, kopls, komlt, kodiv, kopow, &
                         koequ, komodi, komaxi, komini, koat2i, kosrki)
                      nopr = nopr + 1
                      koprt (nopr) = kopr3
                      ixptt (nopr) = ixpt3
                   end select
               endif
            endif
            if (ixpt2 == 0) exit
            ixpt4 = ixpt3
            ixpt3 = ixpt2
         enddo
!
!   Apply binary operators in priority order
!
         if (nopr > 0) then
            do
               iopr = element (maxloc (koprt (1:nopr)), 1)
               kopr = koprt (iopr)
               if (kopr == 0) exit
               ixpt3 = ixptt (iopr)
               ixpt2 = oxptt(ixpt3)%iprv
               ixpt4 = oxptt(ixpt3)%inxt
               dopd1 = oxptt(ixpt2)%dval
               dopd2 = oxptt(ixpt4)%dval
               kopd1 = oxptt(ixpt2)%koprd
               kopd2 = oxptt(ixpt4)%koprd
               call xqtbin (kopr, kopd1, kopd2, dopd1, dopd2, &
                            kres, dres)
               if (kerr /= 0) then
                  return
               endif
               oxptt(ixpt2)%dval  = dres
               oxptt(ixpt2)%koprd = kres
               oxptt(ixpt2)%inxt  = oxptt(ixpt4)%inxt
               if (oxptt(ixpt2)%inxt /= 0) then
                  oxptt (oxptt(ixpt2)%inxt)%iprv = ixpt2
               endif
               koprt (iopr) = 0
            enddo
         endif
!
         return
      end subroutine rdcxpr
      subroutine xqtunr (kopr, kopd, dopd, kres, dres)
!   Apply unary operator kopr to operand dopd of type kopd
         integer, intent (in)           :: kopr, kopd
         double precision, intent (in)  :: dopd
         integer, intent (out)          :: kres
         double precision, intent (out) :: dres
!
         select case (kopr)
         case (konot) ! Not
            if (dopd /= 0.0D0) then
               dres = 0.0D0
            else
               dres = 1.0D0
            endif
            kres = konui
         case (komns) ! -
            dres = - dopd
            kres = kopd
         case (kopls) ! +
            dres = dopd
            kres = kopd
         case (koint) ! Int
            dres = int (dopd)
            kres = konui
         case (konin) ! Nint
            dres = nint (dopd)
            kres = konui
         case (kosin) ! Sin
            dres = sin (dopd)
            kres = konuf
         case (kocos) ! Cos
            dres = cos (dopd)
            kres = konuf
         case (kotan) ! Tan
            dres = tan (dopd)
            kres = konuf
         case (koatn) ! Atan
            dres = atan (dopd)
            kres = konuf
         case (kolog) ! Log
            dres = log (dopd)
            kres = konuf
         case (koexp) ! Exp
            dres = exp (dopd)
            kres = konuf
         case (kol10) ! Log10
            dres = log10 (dopd)
            kres = konuf
         case (kosqr) ! Sqrt
            dres = sqrt (dopd)
            kres = konuf
         case (koasn) ! Asin
            dres = asin (dopd)
            kres = konuf
         case (koacs) ! Acos
            dres = acos (dopd)
            kres = konuf
         case (kosnh) ! Sinh
            dres = sinh (dopd)
            kres = konuf
         case (kocsh) ! Cosh
            dres = cosh (dopd)
            kres = konuf
         case (kotnh) ! Tanh
            dres = tanh (dopd)
            kres = konuf
         case (koabs) ! Abs
            dres = abs (dopd)
            kres = kopd
         case (kosik) ! Selected_int_kind
            dres = selected_int_kind (nint (dopd))
            kres = konui
         case (kosrk) ! Selected_real_kind
            dres = selected_real_kind (nint (dopd))
            kres = kopd
         case (kopou) ! Nothing
            dres = dopd
            kres = kopd
         case default ! Other
            kerr = 9
            return
         end select
      end subroutine xqtunr
      subroutine xqtbin (kopr, kopd1, kopd2, dopd1, dopd2, kres, dres)
!   Apply binary operator kopr to operands dopdi of type kopdi
         integer, intent (in)           :: kopr, kopd1, kopd2
         double precision, intent (in)  :: dopd1, dopd2
         integer, intent (out)          :: kres
         double precision, intent (out) :: dres
!
         select case (kopr)
         case (koori) ! Or
            if (dopd1 /= 0.0D0 .or. dopd2 /= 0.0D0) then
               dres = 1.0D0
            else
               dres = 0.0D0
            endif
            kres = konui
         case (koand) ! And
            if (dopd1 /= 0.0D0 .and. dopd2 /= 0.0D0) then
               dres = 1.0D0
            else
               dres = 0.0D0
            endif
            kres = konui
         case (kogth) ! >
            if (dopd1 > dopd2) then
               dres = 1.0D0
            else
               dres = 0.0D0
            endif
            kres = konui
         case (kogeq) ! >=
            if (dopd1 >= dopd2) then
               dres = 1.0D0
            else
               dres = 0.0D0
            endif
            kres = konui
         case (koequ) ! ==
            if (dopd1 == dopd2) then
               dres = 1.0D0
            else
               dres = 0.0D0
            endif
            kres = konui
         case (kolth) ! <
            if (dopd1 < dopd2) then
               dres = 1.0D0
            else
               dres = 0.0D0
            endif
            kres = konui
         case (koleq) ! <=
            if (dopd1 <= dopd2) then
               dres = 1.0D0
            else
               dres = 0.0D0
            endif
            kres = konui
         case (koneq) ! /=
            if (dopd1 /= dopd2) then
               dres = 1.0D0
            else
               dres = 0.0D0
            endif
            kres = konui
         case (komns) ! -
            dres = dopd1 - dopd2
            if (kopd1 == konui .and. kopd2 == konui) then
               kres = konui
            else
               kres = konuf
            endif
         case (kopls) ! +
            dres = dopd1 + dopd2
            if (kopd1 == konui .and. kopd2 == konui) then
               kres = konui
            else
               kres = konuf
            endif
         case (komlt) ! *
            dres = dopd1 * dopd2
            if (kopd1 == konui .and. kopd2 == konui) then
               kres = konui
            else
               kres = konuf
            endif
         case (kodiv) ! /
            if (kopd1 == konui .and. kopd2 == konui) then
               dres = nint (dopd1) / nint (dopd2)
               kres = konui
            else
               dres = dopd1 / dopd2
               kres = konuf
            endif
         case (kopow) ! **
            if (kopd1 == konui .and. kopd2 == konui) then
               dres = nint (dopd1) ** nint (dopd2)
               kres = konui
            elseif (kopd1 == konuf .and. kopd2 == konui) then
               dres = dopd1 ** nint (dopd2)
               kres = konuf
            else
               dres = dopd1 ** dopd2
               kres = konuf
            endif
         case (komodi) ! .Mod.
            if (kopd1 == konui .and. kopd2 == konui) then
               dres = mod (nint (dopd1), nint (dopd2))
               kres = konui
            else
               dres = mod (dopd1, dopd2)
               kres = konuf
            endif
         case (komaxi) ! .Max.
            dres = max (dopd1, dopd2)
            if (kopd1 == konui .and. kopd2 == konui) then
               kres = konui
            else
               kres = konuf
            endif
         case (komini) ! .Min.
            dres = min (dopd1, dopd2)
            if (kopd1 == konui .and. kopd2 == konui) then
               kres = konui
            else
               kres = konuf
            endif
         case (koat2i) ! .Atan2.
            dres = atan2 (dopd1, dopd2)
            kres = konuf
         case (kosrki) ! .S_R_K.
            dres = selected_real_kind (nint (dopd1), nint (dopd2))
            kres = konui
         case default ! Other
            kerr = 11
            return
         end select
      end subroutine xqtbin
      integer function element (j, i)
         integer, dimension (:), intent (in) :: j
         integer, intent (in)                :: i
         element = j (i)
      end function element
end subroutine valxpr
subroutine strxpr (zres, kres, kerr)
!  analyse lexed expression and evaluate result as string
use fxprprms
character (len=*), intent (out) :: zres
integer, intent (out)           :: kres, kerr
! ____________________________________________________________________
!
      double precision :: dres
      kerr = 0
      call valxpr (dres, kres, kerr)
      select case (kres)
      case (konul)
         if (dres /= 0.0d0) then
            zres = ".True."
         else
            zres = ".False."
         endif
      case (konui)
         write (zres, *) nint (dres)
         zres = adjustl (zres)
      case (konuf)
         write (zres, *) dres
         zres = adjustl (zres)
      case default
         zres = ".True."
      end select
      return
end subroutine strxpr
subroutine fpperr (zstr)
!  Output error message
use fpprcurs
character (len=*), intent (in) :: zstr
! ____________________________________________________________________
!
      character (len=*), parameter :: zfmt = &
                            "(a, ', line ', a, ': Error:', ' ', a)"
      character (len=11) :: znum
!
      write (znum, "(i11)") nlinit (iclev)
      write (luerr, zfmt) trim (zficit (iclev)), &
                          trim (adjustl (znum)), &
                          trim (zstr)
      return
end subroutine fpperr
subroutine chgcas (zstr, kccas)
!  Case change
use fpprprms
character (len=*), intent (inout) :: zstr
! ____________________________________________________________________
!
      lstr = len_trim (zstr)
      select case (kccas)
      case (kcupr)
         do istr = 1, lstr
            irnk  = index (zlwr, zstr (istr:istr))
            if (irnk > 0) zstr (istr:istr) = zupr (irnk:irnk)
         enddo
      case (kclwr)
         do istr = 1, lstr
            irnk  = index (zupr, zstr (istr:istr))
            if (irnk > 0) zstr (istr:istr) = zlwr (irnk:irnk)
         enddo
      end select
end subroutine chgcas
subroutine lexfxd (trttok, ifstp, ksta)
!  Read input file, lexing fixed-form into token stream, until a
!  simultaneous end-of-line end-of-statement is found.
use flexprms
use fpprcurs
interface
         subroutine trttok (ztok, ltok, kktok)
!  add token to current stream, and reduce if end of statement
            use flexvars
            use fpprcurs
            integer, intent (in)              :: ltok, kktok
            character (len=ltok), intent (in) :: ztok
         end subroutine trttok
end interface
integer, intent (in)                :: ifstp ! strip-out comments ?
integer, intent (out)               :: ksta  ! status code
! ____________________________________________________________________
      character (len=2*linem) :: zlinw
      character (len=lsttm) :: zlin
      character (len=lsttm) :: ztok
      character (len=1)     :: zdlm, zchr
      integer, save         :: ifctn = 0
!
      ksta  = 0
      llin  = 0
      ifchc = 0
      ifcnt = 0
      ntok  = 0
      kktok = kkndf
!
body: do
         llin = 0
         ibeg = 1
!
!  Read a line
!
rdlin:   do
            do
               ifctn = 0
               if (klrea == kllst .or. klrea == kltcm) then
                  if (iclev > 0) then
                     zlinb = zlinbh (iclev)
                     nhav  = nhavh  (iclev)
                     klnxt = klnxth (iclev)
                     iclev = iclev - 1
                     close (lufic)
                     lufic = lufic - 1
                     if (iclev == 0) then
                        luinp = lustdi
                     else
                        luinp = lufic
                     endif
                     if (klnxt /= kllst .or. nhav /= 0) exit
                  else
                     ksta = -1
                     exit body
                  endif
               elseif (klrea == klctd) then
                  ifctn = 1
               endif
!
               call realin (luinp, zlinw, klrea)
               if (klrea == klunv .and. iclev /= 0) then
                  klrea = kllst
                  cycle
               endif
               exit
            enddo
!
            select case (klrea)
!
!  Unavailable
!
            case (klunv)
               ksta = 1
               call fpperr ("Problem reading input")
               exit body
!
!  "False comments"
!
            case (klfcm)
               llinw = len_trim (zlinw)
               do icmti = 1, ncmti
                  lcmti = len_trim (zcmtit (icmti))
                  if (llinw > lcmti .and. &
                      zlinw (1:lcmti) == zcmtit (icmti)(1:lcmti)) then
                     call trttok (zlinw (1:lcmti), lcmti, kkfcm)
                     ibeg = lcmti + 1
                     exit rdlin
                  endif
               enddo
!
!  True comments
!
            case (klcmt, kltcm)
               llinw = len_trim (zlinw)
               call trttok (zlinw, llinw, kkcmt)
               call trttok (ztok, 0, kkeos)
               cycle rdlin
!
!  Non-comment, not continued
!
            case (klnrm, kllst)
               llinw = len_trim (zlinw)
               ilinw = verify (zlinw (1:llinw), ztab // " ")
               ilin  = llin + 1
               llin  = llinw - ilinw + ilin
               zlin (ilin:llin) = zlinw (ilinw:llinw)
               exit rdlin
!
!  Continued
!
            case (klctd)
!
!  Check for trailing comment
!
               if (ifctn == 0) then
                  llinw = 72
               else
                  llinw = 72 - 6
               endif
               ichr = ibeg - 1
               ifctc = 0
check:         do
                  if (ichr >= llinw) then
                     exit check
                  endif
                  ichr = ichr + 1
                  zchr = zlinw (ichr:ichr)
                  if (ifctc == 0) then
                     if (zchr == "!") then
                        if (ifstp == 0) &
                           call wrtstt (zlinw, 0, zlinw, 0, &
                                        zlinw (ichr:llinw), &
                                        llinw - ichr + 1, ichr-1)
                        llinw = ichr - 1
                        exit check
                     elseif (zchr == '"' .or. zchr == "'") then
                        zdlm = zchr
                        ifctc = 1
                     endif
                  else
                     if (zchr == zdlm) then
                        ifctc = 0
                     endif
                  endif
               enddo check
!
               ilinw = verify (zlinw (1:llinw), ztab // " ")
               ilin  = llin + 1
               llin  = llinw - ilinw + ilin
               zlin (ilin:llin) = zlinw (ilinw:llinw)
               cycle rdlin
            end select
!
         enddo rdlin
!
         ichr = ibeg - 1
!
!  Scan line
!
         do
               do
                  if (ichr >= llin) then
                     if (ifcnt == 0) then
                        if (kktok /= kkndf) then
                           call trttok (ztok, ltok, kktok)
                        endif
                        exit body
                     else
                        cycle body
                     endif
                  endif
                  ichr = ichr + 1
                  zchr = zlin (ichr:ichr)
                  if (ifchc == 0) then
                     select case (zchr)
!
!  Tabs
!
                     case (ztab)
                        if (kktok /= kkndf) then
                           call trttok (ztok, ltok, kktok)
                        endif
                        kktok = kkndf
!
!  Spaces (are taken as significant, too complex to handle otherwise)
!
                     case (' ')
                        if (kktok /= kkndf) then
                           call trttok (ztok, ltok, kktok)
                        endif
                        kktok = kkndf
!
!  Letters
!
                     case ('A':'Z','a':'z')
                        if (kktok == kkidf .or. kktok == kkcmd) then
                           ltok = ltok + 1
                           ztok (ltok:ltok) = zchr
                        else
                           if (kktok /= kkndf) then
                              call trttok (ztok, ltok, kktok)
                           endif
                           ntok = ntok + 1
                           ltok = 1
                           ztok (ltok:ltok) = zchr
                           kktok = kkidf
                        endif
!
!  Digits
!
                     case ('0':'9')
                        if (kktok == kkidf .or. kktok == kknui) then
                           ltok = ltok + 1
                           ztok (ltok:ltok) = zchr
                        else
                           if (kktok /= kkndf) then
                              call trttok (ztok, ltok, kktok)
                           endif
                           ntok = ntok + 1
                           ltok = 1
                           ztok (ltok:ltok) = zchr
                           kktok = kknui
                        endif
!
!  Underscore (may be in identifier, or as a kind specifier)
!
                     case ('_')
                        select case (kktok)
                        case (kkidf)
                           ltok = ltok + 1
                           ztok (ltok:ltok) = zchr
                        case (kknui, kkstr)
                           call trttok (ztok, ltok, kktok)
                           ntok = ntok + 1
                           call trttok (zchr, 1, kkknd)
                           kktok = kkndf
                        case default
                           if (kktok /= kkndf) then
                              call trttok (ztok, ltok, kktok)
                           endif
                           ntok = ntok + 1
                           ltok = 1
                           ztok (ltok:ltok) = zchr
                           kktok = kkidf
                        end select
!
!  Colon
!
                     case (':')
                        if (kktok /= kkndf) then
                           call trttok (ztok, ltok, kktok)
                        endif
                        ntok = ntok + 1
                        call trttok (zchr, 1, kkdpt)
                        kktok = kkndf
!
!  Semi-colon
!
                     case (';')
                        if (kktok /= kkndf) then
                           call trttok (ztok, ltok, kktok)
                        endif
                        ntok = ntok + 1
                        call trttok (zchr, 1, kkpvg)
                        kktok = kkndf
!
!  Opening parenthesis
!
                     case ('(')
                        if (kktok /= kkndf) then
                           call trttok (ztok, ltok, kktok)
                        endif
                        ntok = ntok + 1
                        ltok = 1
                        ztok (ltok:ltok) = zchr
                        kktok = kkpou
!
!  Closing parenthesis
!
                     case (')')
                        if (kktok == kkslh) then
                           ltok = ltok + 1
                           ztok (ltok:ltok) = zchr
                           call trttok (ztok, ltok, kkcfr)
                           kktok = kkndf
                        else
                           if (kktok /= kkndf) then
                              call trttok (ztok, ltok, kktok)
                           endif
                           ntok = ntok + 1
                           call trttok (zchr, 1, kkpfr)
                           kktok = kkndf
                        endif
!
!  Exclamation mark (start of comment)
!
                     case ('!')
                        if (kktok /= kkndf .and. ifcnt == 0) then
                           call trttok (ztok, ltok, kktok)
                        endif
                        if (ifcnt == 0) then
                           ntok = ntok + 1
                           call trttok (zlin (ichr:llin), (llin-ichr+1),&
                                        kkcmt)
                           exit body
                        else
                           if (ifstp == 0) &
                           call wrtstt (zlin, 0, zlin, 0, &
                                        zlin (ichr:llin), &
                                        llin - ichr + 1, ichr-1)
                           cycle body
                        endif
!
!  Dollar (used as preprocessor command introduction)
!
                     case ('$')
                        if (kktok /= kkndf) then
                           call trttok (ztok, ltok, kktok)
                        endif
                        ntok = ntok + 1
                        ltok = 1
                        ztok (ltok:ltok) = '$'
                        kktok = kkcmd
!
!  Sharp (same as $ or !, depending on current status)
!
                     case ('#')
                        if (ifsed /= 0) then
                           if (kktok /= kkndf) then
                              call trttok (ztok, ltok, kktok)
                           endif
                           ntok = ntok + 1
                           ltok = 1
                           ztok (ltok:ltok) = '$'
                           kktok = kkcmd
                        else
                           if (kktok /= kkndf .and. ifcnt == 0) then
                              call trttok (ztok, ltok, kktok)
                           endif
                           if (ifcnt == 0) then
                              ntok = ntok + 1
                              call trttok (zlin (ichr:llin),&
                                           (llin-ichr+1), kkcmt)
                              exit body
                           else
                              if (ifstp == 0) &
                              call wrtstt (zlin, 0, zlin, 0, &
                                           zlin (ichr:llin), &
                                           llin - ichr + 1, ichr-1)
                              cycle body
                           endif
                        endif
!
!  Question mark
!
                     case ('?')
                        if (kktok /= kkndf) then
                           call trttok (ztok, ltok, kktok)
                        endif
                        ntok = ntok + 1
                        call trttok (zchr, 1, kkqst)
                        kktok = kkndf
!
!  Continuation mark
!
                     case ('&')
                        ifcnt = 1
                        if (ichr < llin) then
                           inxt = verify (zlin (ichr+1:llin),        &
                                          ztab // " ")
                           if (inxt /= 0) then
                              if (zlin (ichr+inxt:ichr+inxt) /= "!") then
                                 if (kktok /= kkndf) then
                                    call trttok (ztok, ltok, kktok)
                                 endif
                                 ntok = ntok + 1
                                 call trttok (zchr, 1, kkamp)
                                 kktok = kkndf
                                 ifcnt = 0
                              endif
                           endif
                        endif
!
!  Percent
!
                     case ('%')
                        if (kktok /= kkndf) then
                           call trttok (ztok, ltok, kktok)
                        endif
                        ntok = ntok + 1
                        call trttok (zchr, 1, kkprc)
                        kktok = kkndf
!
!  Plus and Minus
!
                     case ('+','-')
                        if (kktok /= kkndf) then
                           call trttok (ztok, ltok, kktok)
                        endif
                        ntok = ntok + 1
                        call trttok (zchr, 1, kkpms)
                        kktok = kkndf
!
!  Slash
!
                     case ('/')
                        select case (kktok)
                        case (kkslh)
                           ltok = ltok + 1
                           ztok (ltok:ltok) = zchr
                           call trttok (ztok, ltok, kkcct)
                           kktok = kkndf
                        case (kkpou)
                           ltok = ltok + 1
                           ztok (ltok:ltok) = zchr
                           call trttok (ztok, ltok, kkcou)
                           kktok = kkndf
                        case default
                           if (kktok /= kkndf) then
                              call trttok (ztok, ltok, kktok)
                           endif
                           ntok = ntok + 1
                           ltok = 1
                           ztok (ltok:ltok) = zchr
                           kktok = kkslh
                        end select
!
!  Star
!
                     case ('*')
                        if (kktok == kksta) then
                           ltok = ltok + 1
                           ztok (ltok:ltok) = zchr
                           call trttok (ztok, ltok, kkpow)
                           kktok = kkndf
                        else
                           if (kktok /= kkndf) then
                              call trttok (ztok, ltok, kktok)
                           endif
                           ntok = ntok + 1
                           ltok = 1
                           ztok (ltok:ltok) = zchr
                           kktok = kksta
                        endif
!
!  Superior
!
                     case ('>')
                        if (kktok == kkaff) then
                           ltok = ltok + 1
                           ztok (ltok:ltok) = zchr
                           call trttok (ztok, ltok, kkpts)
                           kktok = kkndf
                        else
                           if (kktok /= kkndf) then
                              call trttok (ztok, ltok, kktok)
                           endif
                           ntok = ntok + 1
                           ltok = 1
                           ztok (ltok:ltok) = zchr
                           kktok = kksup
                        endif
!
!  Inferior
!
                     case ('<')
                        if (kktok /= kkndf) then
                           call trttok (ztok, ltok, kktok)
                        endif
                        ntok = ntok + 1
                        ltok = 1
                        ztok (ltok:ltok) = zchr
                        kktok = kkinf
!
!  Equal
!
                     case ('=')
                        select case (kktok)
                        case (kkslh)
                           ltok = ltok + 1
                           ztok (ltok:ltok) = zchr
                           call trttok (ztok, ltok, kkneq)
                           kktok = kkndf
                        case (kkinf)
                           ltok = ltok + 1
                           ztok (ltok:ltok) = zchr
                           call trttok (ztok, ltok, kkleq)
                           kktok = kkndf
                        case (kkaff)
                           ltok = ltok + 1
                           ztok (ltok:ltok) = zchr
                           call trttok (ztok, ltok, kkequ)
                           kktok = kkndf
                        case (kksup)
                           ltok = ltok + 1
                           ztok (ltok:ltok) = zchr
                           call trttok (ztok, ltok, kkgeq)
                           kktok = kkndf
                        case default
                           if (kktok /= kkndf) then
                              call trttok (ztok, ltok, kktok)
                           endif
                           ntok = ntok + 1
                           ltok = 1
                           ztok (ltok:ltok) = zchr
                           kktok = kkaff
                        end select
!
!  Dot
!
                     case ('.')
                        if (kktok /= kkndf) then
                           call trttok (ztok, ltok, kktok)
                        endif
                        ntok = ntok + 1
                        call trttok (zchr, 1, kkdot)
                        kktok = kkndf
!
!  Separator
!
                     case (',')
                        if (kktok /= kkndf) then
                           call trttok (ztok, ltok, kktok)
                        endif
                        ntok = ntok + 1
                        call trttok (zchr, 1, kksep)
                        kktok = kkndf
!
!  String delimiter
!
                     case ('"',"'")
                        if (kktok == kkstr) then
                           if (zchr == zdlm) then
                              ltok = ltok + 1
                              ztok (ltok:ltok) = zchr
                           else
                              zdlm  = zchr
                              ltok  = 1
                              ztok (ltok:ltok) = zchr
                              ntok  = ntok + 1
                           endif
                           ifchc = 1
                        else
                           if (kktok /= kkndf) then
                              call trttok (ztok, ltok, kktok)
                           endif
                           zdlm  = zchr
                           ltok  = 1
                           ztok (ltok:ltok) = zchr
                           ntok  = ntok + 1
                           kktok = kkstr
                           ifchc = 1
                        endif
!
!  Other character
!
                     case default
                        if (kktok /= kkndf) then
                           call trttok (ztok, ltok, kktok)
                        endif
                        ntok = ntok + 1
                        call trttok (zchr, 1, kkukn)
                        kktok = kkndf
                     end select
!
!  We are inside a char string
!
                  else
!
!  Test for end of current string
!
                     if (zchr == zdlm) then
                        ltok  = ltok + 1
                        ztok (ltok:ltok) = zchr
                        ifchc = 0
                     else
!
!  Test for end of line
!
                        if (ichr == llin) then
                           if (zchr == '&') then
                              ifcnt = 1
                              cycle body
                           else
                              call fpperr ("Unmatched " // zdlm)
                           endif
                        else
                           ltok = ltok + 1
                           ztok (ltok:ltok) = zchr
                        endif
                     endif
                  endif
               enddo
            enddo
      enddo body
      call trttok (ztok, 0, kkeos)
      return
end subroutine lexfxd
subroutine realin (lurea, zlin, kllin)
!  Read a line, with advance buffering, for fixed form, in order
!  to detect continued lines
use flexvars
use fpprcurs
integer, intent (in)                :: lurea
character (len=*), intent (out)     :: zlin  ! The line
integer, intent (out)               :: kllin ! line type code
! ____________________________________________________________________
      character (len=*), parameter  :: zcmt1 = "Cc!Xx*"
      character (len=1), parameter  :: zcr = achar (13)
      integer, parameter            :: icntf = 6
      integer, save                 :: nhavm = 0
!
!  If don't have, read line
!
      if (nhav == 0) then
         read (lurea, "(a)", iostat=krea) zlinb
!
         if (krea /= 0) then
            kllin = klunv
            return
         else
            nhav = nhav + 1
            klnxt = klnrm
         endif
         llinw = len_trim (zlinb)
!
!  Remove trailing <CR> if any
!
         if (llinw > 0) then
            if (zlinb (llinw:llinw) == zcr) then
               zlinb (llinw:llinw) = ' '
               llinw = llinw - 1
            endif
         endif
!
!  If fixed form, find out if line is comment
!
         if (iffxd /= 0) then
!
!  Recognize blank comments
!
            if (llinw == 0) then
               zlinb (1:1) = '!'
               llinw = 1
               klnxt = klcmt
!
!  And other comments
!
            else
               if (index (zcmt1, zlinb (1:1)) /= 0) then
                  zlinb (1:1) = '!'
!
!  Do not skip "False comments"
!
                  klnxt = klcmt
                  do icmti = 1, ncmti
                     lcmti = len_trim (zcmtit (icmti))
                     if (llinw > lcmti .and. &
                         zlinb (1:lcmti) == zcmtit (icmti)(1:lcmti)) then
                        klnxt = klfcm
                        exit
                     endif
                  enddo
               endif
            endif
!
!  Handle past column 72 parts
!
            if (klnxt /= klcmt .and. llinw > 72) then
               zlinb = zlinb (1:72)
            endif
         endif
      endif
!
!  Provide requested line
!
      if (nhav == 1) then
         if (iffxd == 0) then
            zlin = trim (zlinb)
         else
            zlin = zlinb
         endif
         kllin = klnxt
      elseif (nhav > 1) then
         zlin = trim (zbufc (1))
         kllin = klcmt
         do ihav = 1, nhav - 2
            zbufc (ihav) = zbufc (ihav+1)
         enddo
      else
         kllin = klunv
         return
      endif
      nhav = nhav - 1
      nlinit (iclev) = nlinit (iclev) + 1
!
!  If necessary, read lines in advance
!
      if (nhav == 0) then
rdlin:   do
            read (lurea, "(a)", iostat=krea) zlinb
!
            select case (krea)
            case (1:)
               if (nhav == 0) then
                  if (klnxt == klcmt) then
                     kllin = kltcm
                  else
                     kllin = kllst
                  endif
               endif
               call fpperr ("Problem reading next line")
               return
            case (:-1)
               if (nhav == 0) then
                  if (klnxt == klcmt) then
                     kllin = kltcm
                  else
                     kllin = kllst
                  endif
               endif
               return
            case (0)
               nhav = nhav + 1
               llinw = len_trim (zlinb)
!
!  Remove trailing <CR> if any
!
               if (llinw > 0) then
                  if (zlinb (llinw:llinw) == zcr) then
                     zlinb (llinw:llinw) = ' '
                     llinw = llinw - 1
                  endif
               endif
!
!  If fixed form,
!
               if (iffxd /= 0) then
!
!                find out if next line is comment
!
                  klnxt = klnrm
!
!  Recognize blank comments
!
                  if (llinw == 0) then
                      klnxt = klcmt
                      zlinb (1:1) = '!'
                      llinw = 1
                  elseif (verify (zlinb (1:llinw), ztab // " ") == 0) &
                         then
                      klnxt = klcmt
                      zlinb (1:1) = '!'
                      llinw = 1
!
!  And other comments
!
                  else
                     if (index (zcmt1, zlinb (1:1)) /= 0) then
                        zlinb (1:1) = '!'
!
!  Exclude "False comments"
!
                        klnxt = klcmt
                        do icmti = 1, ncmti
                           lcmti = len_trim (zcmtit (icmti))
                           if (llinw > lcmti .and. &
                               zlinb (1:lcmti) ==  &
                               zcmtit (icmti)(1:lcmti)) then
                              klnxt = klfcm
                              exit rdlin
                           endif
                        enddo
                     endif
                  endif
!
!  Store comments for future use
!
                  if (klnxt == klcmt) then
                     if (nhav > nhavm) then
                        if (nhavm == 0) then
                           nhavm = 16
                           call inizbu (nhavm)
                        else
                           call xpdzbu (nhavm)
                        endif
                     endif
                     zbufc (nhav) (1:linem) = zlinb (1:llinw)
                     cycle rdlin
                  endif
!
!  Check for continuation mark
!
!
!  Handle past column 72 parts
!
                  if (llinw > 72) then
                     zlinb = zlinb (1:72)
                  endif
                  klnxt = klnrm
                  ilinw = verify (zlinb (1:llinw), ztab // " ")
!
!  Exclude Pre-processing commands, which may start column 1
!
                  if (ilinw /= 6 .and. &
                      (zlinb (ilinw:ilinw) == "$" .or. &
                       zlinb (ilinw:ilinw) == "#")) then
                     exit rdlin
                  endif
!
!  Handle TABs as ^<TAB>non-zero-digit = continuation
!
                  if (llinw > 2) then
                     if (zlinb (1:1) == ztab) then

                        if (index ("123456789", zlinb (2:2)) /= 0) then
                           kllin = klctd
                           zlinb = zlinb (3:llinw)
                           exit rdlin
                        endif
                     elseif (llinw > icntf) then
                        ilinw = verify (zlinb (1:llinw), &
                                        ztab // " 123456789")
                        if (ilinw >= icntf              .and. &
                            zlinb (icntf:icntf) /= ztab .and. &
                            zlinb (icntf:icntf) /= ' ') then
                           kllin = klctd
                           zlinb = zlinb (icntf+1:llinw)
                           exit rdlin
                        endif
                     else
                        cycle rdlin
                     endif
                  endif
               endif
               exit rdlin
            end select
         enddo rdlin
      endif
      return
end subroutine realin

max_stars_repo_name: naumruso/tdtbuj

max_issues_repo_name: naumruso/tdtbuj

max_forks_repo_name: naumruso/tdtbuj