module faibidnt ! Identity of f90aib utility ! ____________________________________________________________________ character (len=*), parameter :: zsccs = & "@(#)faibidnt.f90 1.3 00/12/15 Michel Olagnon" character (len=*), parameter :: zvers = & "@(#) faibidnt.f90 V-0.3 00/12/15 Michel Olagnon" character (len=*), parameter :: zusg = & "( usage: f90aib < file.f90 > file.f90 )" character (len=*), parameter :: zhlp = '( & &"Fortran 90 utility to process free source form code and"/& &"automatically try to build interface blocks"/& &"____________________________________________________________________"/& &"Copyright (C) 1997-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 0.3 of 15 Dec. 2000"/& &"____________________________________________________________________"/& &"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 faibidnt 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 !ams integer, parameter :: nargm = 64 ! Max # of arguments integer, parameter :: nargm = 128 ! 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 = 72 ! current, desirable, linelength integer, save :: nndt = 0 ! current indentation integer, save :: nndtp = 3 ! current step for indentation integer, save :: lprc = 0 ! 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 = kclve ! 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 module faibprms ! Parameters for f90aib utility ! ____________________________________________________________________ ! character (len=*), parameter :: zsub = "Subroutine" character (len=*), parameter :: zfun = "Function" character (len=*), parameter :: zitf = "Interface" character (len=*), parameter :: zeif = "End Interface" character (len=*), parameter :: zend = "End" character (len=*), parameter :: zdim = "Dimension" character (len=*), parameter :: zlen = "Len" character (len=*), parameter :: zxtn = "External" integer, parameter :: nattm = 64 ! max # of attributes ! end module faibprms module faibvars ! variables to hold interface use faibprms use flexprms character (len=lnamm), save :: zprci ! to hold proc. id character (len=2*nattm*lnamm*nargm), save :: zargi ! attr. tokens integer, dimension (1:nargm), save :: nattt ! # of attr. tokens integer, dimension (1:nargm), save :: kargit ! arguments hashes integer, dimension (1:2*nattm,1:nargm), save :: kkattt ! attr. code integer, dimension (1:2*nattm,1:nargm), save :: iattdt ! attr. start integer, dimension (1:2*nattm,1:nargm), save :: iattft ! attr. end integer, dimension (1:2*nattm,1:nargm), save :: iattnt ! attr. hash integer, save :: nargi ! # of args integer, save :: iargi ! position in zargi ! ____________________________________________________________________ end module faibvars module faibcurs use faibprms use fpprcurs ! Current status variables in f90aib utility ! ____________________________________________________________________ integer, save :: ifexe = 0 ! are we in executable statements ? integer, save :: lctn = -1 ! level of ``contained'' procs. integer, save :: kfct = 0 ! type of current proc. ! end module faibcurs program f90aib ! Process standard input, trying automatically to build interface ! blocks for F90 source code, and output result on standard output. ! ____________________________________________________________________ use faibidnt use fpprcurs use fxprprms interface subroutine aibtok (ztok, ltok, kktok) ! add token to current stream, and reduce if end of statement use flexvars use faibcurs integer, intent (in) :: ltok, kktok character (len=ltok), intent (in) :: ztok end subroutine aibtok end interface ! ____________________________________________________________________ ! !ams write (luerr, "(a)") "This is f90aib: " // zvers !ams write (luerr, "(a)") zusg ! ! Initialize names, directives, expression evaluation ! call ininam call inicmd call inixpr ! ! Loop on (possibly multiple instructions) input lines ! ifstp = 1 ! strip-out embedded comments ksta = 0 do if (iffxd == 0) then call lexlin (aibtok, ifstp, ksta) else call lexfxd (aibtok, ifstp, ksta) endif if (ksta /= 0) exit enddo ! end program f90aib 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 aibtok (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 ! ! Skip if embedded comment ! if (kktok == kkebc) then return endif ! ! 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 trtstt (ntok, ksstt) ntok = 0 itokf = 0 endif return end subroutine aibtok 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 trtstt (ntok, ksstt) ! Parse statement (partially) use flexvars use fprsvars use faibcurs use faibvars integer, intent (inout) :: ntok integer, intent (out) :: ksstt ! ____________________________________________________________________ ! integer, save :: kctxc = kcbeg ! itoks = 1 kctok = kctxc ksstt = ksukn ! ! Apply pre-processor command ! 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) return endif ! ! blank lines ! if (ntok == 0) then return elseif (ntok == 1 .and. kktokt (1) == kkcmt) then return elseif (ntok == 1 .and. kktokt (1) == kkebc) then return elseif (ntok == 1 .and. kktokt (1) == kkfcm) then return endif ! ! Are-we still in executable code ? ! if (ifexe > 0) then kwnam = kwnul if (kktokt (itoks) == kkidf) then itokd = itokdt (itoks) itokf = itokft (itoks) call tstidf (ztoki (itokd:itokf), kcany, krany, kwnam, & inamwt (itoks)) if (kwnam /= kwenp .and. & kwnam /= kwctn .and. & kwnam /= kwenf .and. & kwnam /= kwntf) return else return endif ! ! Reduce "token clusters" ! if (ntok > itoks) call rdcstt (ntok) if (kktokt (itoks) == kkidf) then itokd = itokdt (itoks) itokf = itokft (itoks) ihsh = khshstr (ztoki (itokd:itokf)) kwnam = tnamt(ihsh)%kwnam if (kwnam /= kwenp .and. & kwnam /= kwctn .and. & kwnam /= kwenf .and. & kwnam /= kwntf) return ! ! Look for end of procedure or contains ! if (kwnam == kwenp) then if (lctn == 0) call outitf if (lctn >= 0 ) lctn = lctn - 1 if (lctn < -1 ) lctn = lctn + 1 ifexe = 0 elseif (kwnam == kwctn) then ifexe = 0 endif endif ! ! Not in executable code ! elseif (ifexe == 0) then !___________ ( if (ifexe == 0) ) ! ! Look for start/end of procedure, interface, type ! call rghprs (kswrk) ! ! Choice according to level of containment ! select case (lctn) case (:-2) ! select case (kswrk) case (ksprs, kstys, ksnts) lctn = lctn - 1 case (kspre, kstye, ksnte) lctn = lctn + 1 case (ksprm) ifexe = 0 case default continue end select ! case (-1) ! select case (kswrk) case (ksprs) ! ! Start of a possible new interface ! call subfct (ifnew) if (ifnew == 0) then lctn = lctn - 1 else lctn = 0 kfct = ifnew call newitf endif case (kstys, ksnts) lctn = lctn - 1 case (kspre, kstye, ksnte) lctn = lctn + 1 case (ksprm) ifexe = 0 case (ksexe) ifexe = 1 case default continue end select ! case (0) ! select case (kswrk) case (ksprs) lctn = 1 case (kstys) ! ! One needs to keep the type, and to write it ! when it is used to define an argument ! lctn = 1 case (ksnts) ! ! One needs to keep the interface, and to write it ! when it is used to define an argument ! if (nargi > 0) then ifexe = -1 call chkitf (ifarg) if (ifarg /= 0) then call bdyitf (ksnts) lctn = -1 endif else lctn = 1 endif case (kstye, ksnte) lctn = -1 case (kspre) call outitf lctn = -1 case (ksprm) ifexe = 0 case (ksexe) ifexe = 1 ! ! Look for argument info ! case (ksipl) if (nargi > 0) call bdyitf (kswrk) case (ksuse) if (nargi > 0) then call chkuse (ifarg) if (ifarg /= 0) call bdyitf (kswrk) endif case default if (nargi > 0) call chkdcl end select ! ! case (1:) ! ! Look for level change ! select case (kswrk) case (ksprs, kstys, ksnts) lctn = lctn + 1 case (kspre, kstye, ksnte) lctn = lctn - 1 case (ksprm) ifexe = 0 ! case (ksexe) ! ifexe = 1 case default continue end select end select else !___________ ( if (ifexe = -1) ) ! ! Look for start/end of procedure, interface, type ! call rghprs (kswrk) ! ! Choice according to level of containment ! select case (lctn) case (:-1) ! call bdyitf (kswrk) select case (kswrk) case (ksprs, ksnts) lctn = lctn - 1 case (kspre) lctn = lctn + 1 if (lctn == 0) call enditf case (ksnte) lctn = lctn + 1 if (lctn == 0) ifexe = 0 case default continue end select ! case (0) ! select case (kswrk) case (ksprs) call itfprc (ifarg) if (ifarg > 0) then call heaitf call bdyitf (ksprs) lctn = -1 else lctn = +1 endif case (ksnte) ifexe = 0 case default continue end select case (1:) ! select case (kswrk) case (ksprs) lctn = lctn + 1 case (kspre) lctn = lctn - 1 case default continue end select end select ! endif ! return contains subroutine rghprs (kode) ! ! Rough parsing of current token stream ! Recognize: - start/end proc ! - use ! - declarative instruction ! - start/end interface ! - start/end type ! - contains ! - executable instruction ! ___________________________________________________________________ ! ! Look for start of procedure ! itok = 1 if (ntok > itok) call rdcstt (ntok) ! ! Label ? ! if (kktokt (itok) == kknui) then kctok = kcblb itok = itok + 1 endif ! ! Block name ? ! if (itok + 1 < ntok) then if (kktokt (itok+1) == kkdpt .and. & kktokt (itok) == kkidf) then kode = ksexe return endif endif ! ! Identify first keyword ! kode = ksukn if (kktokt (itok) == kkidf) then itokd = itokdt (itok) itokf = itokft (itok) krtok = krukn if (itok == ntok) then krtok = krlst else if (kktokt (itok+1) == kkpou .or. & kktokt (itok+1) == kkpnb) then krtok = krpou endif endif call tstidf (ztoki (itokd:itokf), kctok, krtok, kwidf, & inamwt (itok)) select case (kwidf) case (kwpat, kwprc, kwfct) kode = ksprs return case (kwenp) kode = kspre return case (kwuse) kode = ksuse return case (kwipl) kode = ksipl return case (kwatt) kctok = kcdcl case (kwntf) kode = ksnts return case (kwenf) kode = ksnte return case (kwtyp) if (kktokt (itok+1) == kkpou .or. & kktokt (itok+1) == kkpnb) then kctok = kcdcl else kode = kstys return endif case (kwent) kode = kstye return case (kwctn) kode = ksprm return case (kwfmt, kwdta, kwpps, kwac5) kode = ksany return case default kode = ksexe return end select else kode = ksexe return endif ! ! lpar = 0 do itok = itok+1, ntok if (kktokt (itok) == kkidf .and. lpar == 0) then itokd = itokdt (itok) itokf = itokft (itok) krtok = krukn if (itok == ntok) then krtok = krlst else if (kktokt (itok+1) == kkpou .or. & kktokt (itok+1) == kkpnb) then krtok = krpou endif endif call tstidf (ztoki (itokd:itokf), kctok, krtok, kwidf, & inamwt (itok)) select case (kwidf) case (kwatt) kctok = kcdcl case (kwpat) kctok = kcdcp case (kwprc, kwfct) kode = ksprs return case default kode = ksdcl return end select elseif (kktokt (itok) == kkpou .or. & kktokt (itok) == kkpnb) then lpar = lpar + 1 elseif (kktokt (itok) == kkpfr) then lpar = lpar - 1 elseif (kktokt (itok) == kkdcl) then kode = ksdcl return elseif (kktokt (itok) == kksep .and. lpar == 0) then kode = ksdcl return endif enddo end subroutine rghprs subroutine subfct (ifprc) integer, intent (out) :: ifprc ! Find out if start of procedure is subroutine or function or else ! ___________________________________________________________________ ! interface ifsame logical function ifsame (zstr1, zstr2) ! Case insensitive compare character (len=*), intent (in) :: zstr1, zstr2 end function ifsame end interface itok = 1 ifprc = 0 kctok = kctxc find: do if (itok >= ntok) exit if (kktokt (itok) == kkidf) then itokd = itokdt (itok) itokf = itokft (itok) ihsh = khshstr (ztoki (itokd:itokf)) if (tnamt(ihsh)%kwnam == 0) then ifprc = 0 exit find else do inamd = tnamt(ihsh)%inamd inamf = tnamt(ihsh)%inamf if (ifsame (ztoki (itokd:itokf), znamg (inamd:inamf)))& exit if (tnamt(ihsh)%ihshf == 0) then ifprc = 0 exit find else ihsh = tnamt(ihsh)%ihshf endif enddo if (tnamt(ihsh)%kwnam == kwprc) then if (ifsame (ztoki (itokd:itokf), zsub)) then ifprc = 2 else ifprc = 0 endif exit find elseif (tnamt(ihsh)%kwnam == kwfct) then ifprc = 1 exit find else itok = itok + 1 if (tnamt(ihsh)%kwnam == kwtyp & .or. tnamt(ihsh)%kwnam == kwatt) then if (kktokt (itok) == kksta) then itok = itok + 1 if (itok >= ntok) then ifprc = 0 exit find endif if (kktokt (itok) == kknui) then itok = itok + 1 cycle find endif endif lpar = 0 do if (kktokt (itok) == kkpou) then lpar = lpar + 1 elseif (kktokt (itok) == kkpfr) then lpar = lpar - 1 else if (lpar == 0) cycle find endif itok = itok + 1 if (lpar == 0) cycle find if (itok >= ntok) then ifprc = 0 exit find endif enddo endif cycle find endif endif else ifprc = 0 exit find endif enddo find ! if (ifprc /= 1 .and. ifprc /= 2) return call tstidf (ztoki (itokd:itokf), kcany, krany, kwwrk, inamwt (itok)) itok = itok + 1 if (itok > ntok) then ifprc = 0 return endif if (kktokt (itok) /= kkidf) then ifprc = 0 return endif itokd = itokdt (itok) itokf = itokft (itok) zprci = ztoki (itokd:itokf) call tstidf (zprci, kcany, krany, kwwrk, inamwt (itok)) if (ifprc == 1) then nargi = 1 call iniarg (nargi, itok) else nargi = 0 endif ! ! Look for argument list ! itok = itok + 1 if (itok > ntok) return if (kktokt (itok) /= kkpou) then ifprc = 0 return endif do itok = itok + 1 if (itok > ntok) then ifprc = 0 return endif if (kktokt (itok) == kkpfr) exit if (kktokt (itok) == kkidf) then itokd = itokdt (itok) itokf = itokft (itok) nargi = nargi + 1 if (nargi > nargm) then call fpperr ("Too many arguments") call fpperr ("raise nargm and try again") endif call tstidf (ztoki (itokd:itokf), kcany, krany, kwwrk, & inamwt (itok)) call iniarg (nargi, itok) elseif (kktokt (itok) /= kksta) then ! possible * arg. ifprc = 0 return endif itok = itok + 1 if (itok > ntok) then ifprc = 0 return endif if (kktokt (itok) == kkpfr) exit if (kktokt (itok) /= kksep) then ifprc = 0 return endif enddo if (ifprc == 1 .and. itok < ntok) then itok = itok + 1 if (kktokt (itok) == kkidf) then ! result clause itokd = itokdt (itok) itokf = itokft (itok) call tstidf (ztoki (itokd:itokf), kcany, krany, kwwrk, & inamwt (itok)) else ifprc = 0 return endif itok = itok + 1 if (itok > ntok) then ifprc = 0 return endif if (kktokt (itok) /= kkpou) then ifprc = 0 return endif itok = itok + 1 if (kktokt (itok) == kkidf) then ! result name itokd = itokdt (itok) itokf = itokft (itok) call tstidf (ztoki (itokd:itokf), kcany, krany, kwwrk, & inamwt (itok)) nargi = nargi + 1 if (nargi > nargm) then call fpperr ("Too many arguments") call fpperr ("raise nargm and try again") endif call iniarg (nargi, itok) else ifprc = 0 return endif itok = itok + 1 if (itok > ntok) then ifprc = 0 return endif if (kktokt (itok) /= kkpfr) then ifprc = 0 return endif endif ! end subroutine subfct subroutine chkitf (ifarg) integer, intent (out) :: ifarg ! Find out if procedure in interface statement is argument ! ___________________________________________________________________ ! ifarg = 0 ! itok = 2 if (itok > ntok) return if (kktokt (itok) == kkidf) then itokd = itokdt (itok) itokf = itokft (itok) ihsh = indhsh (ztoki (itokd:itokf)) do iarg = 1, nargi if (ihsh == kargit (iarg)) then ifarg = iarg exit endif enddo endif ! return ! end subroutine chkitf subroutine chkuse (ifarg) integer, intent (out) :: ifarg ! Find out if module with ONLY clause refers to argument ! ___________________________________________________________________ ! ! ifarg = 0 ! ! itok = 3 ! if (itok > ntok) then ifarg = 1 return ! end if ! used: do ! itok = itok + 1 ! if (itok > ntok) exit ! if (kktokt (itok) == kkidf) then ! itokd = itokdt (itok) ! itokf = itokft (itok) ! ihsh = indhsh (ztoki (itokd:itokf)) ! do iarg = 1, nargi ! if (ihsh == kargit (iarg)) then ! ifarg = iarg ! exit used ! endif ! enddo ! endif ! enddo used ! ! return ! end subroutine chkuse subroutine itfprc (ifarg) integer, intent (out) :: ifarg ! Find out if procedure in interface is argument ! ___________________________________________________________________ ! interface logical function ifsame (zstr1, zstr2) ! Case insensitive compare character (len=*), intent (in) :: zstr1, zstr2 end function ifsame end interface ! ifarg = 0 ! itok = 1 ifprc = 0 kctok = kctxc find: do if (itok >= ntok) exit if (kktokt (itok) == kkidf) then itokd = itokdt (itok) itokf = itokft (itok) ihsh = khshstr (ztoki (itokd:itokf)) if (tnamt(ihsh)%kwnam == 0) then ifprc = 0 exit find else do inamd = tnamt(ihsh)%inamd inamf = tnamt(ihsh)%inamf if (ifsame (ztoki (itokd:itokf), znamg (inamd:inamf)))& exit if (tnamt(ihsh)%ihshf == 0) then ifprc = 0 exit find else ihsh = tnamt(ihsh)%ihshf endif enddo if (tnamt(ihsh)%kwnam == kwprc) then if (ifsame (ztoki (itokd:itokf), zsub)) then ifprc = 2 else ifprc = 0 endif exit find elseif (tnamt(ihsh)%kwnam == kwfct) then ifprc = 1 exit find else itok = itok + 1 if (tnamt(ihsh)%kwnam == kwtyp) then lpar = 0 do if (kktokt (itok) == kkpou) then lpar = lpar + 1 elseif (kktokt (itok) == kkpfr) then lpar = lpar - 1 endif itok = itok + 1 if (lpar == 0) cycle find if (itok >= ntok) then ifprc = 0 exit find endif enddo endif cycle find endif endif else ifprc = 0 exit find endif enddo find ! if (ifprc /= 1 .and. ifprc /= 2) return itok = itok + 1 if (itok > ntok) then ifprc = 0 return endif if (kktokt (itok) /= kkidf) then ifprc = 0 return endif itokd = itokdt (itok) itokf = itokft (itok) ihsh = indhsh (ztoki (itokd:itokf)) do iarg = 1, nargi if (ihsh == kargit (iarg)) then ifarg = iarg exit endif enddo ! end subroutine itfprc subroutine iniarg (iarg, itok) ! Initialise a new argument from list ! ___________________________________________________________________ ! integer, intent (in) :: iarg, itok ! nattt (iarg) = 0 kargit (iarg) = inamwt (itok) iattnt (:,iarg) = 0 end subroutine iniarg subroutine newitf ! Output start of interface block ! ___________________________________________________________________ ! call heaitf call outstt (ntok, ksprs) ! iargi = 0 ! end subroutine newitf subroutine heaitf ! Output "interface" ! ___________________________________________________________________ ! character (len=len(zitf)) :: zwrk ! zwrk = zitf if (kccask /= kclve) then call chgcas (zwrk, kccask) endif ! call wrtstt (zwrk, 0, zwrk, len_trim (zwrk), zwrk, 0, nndt) lprc = lprc + 1 nndt = nndt + nndtp ! end subroutine heaitf subroutine enditf ! Output "end interface" ! ___________________________________________________________________ ! character (len=len(zeif)) :: zwrk ! zwrk = zeif if (kccask /= kclve) then call chgcas (zwrk, kccask) endif ! nndt = nndt - nndtp call wrtstt (zwrk, 0, zwrk, len_trim (zwrk), zwrk, 0, nndt) lprc = lprc - 1 ! end subroutine enditf subroutine outitf ! Output end of interface block ! ___________________________________________________________________ ! integer, dimension (1:nargm) :: iargit ! arguments order interface subroutine outtks (kktknt, itkndt, itknft, itknnt, ztkni, ksstt) ! build and output statement use flexvars use fprsvars use fpprcurs character (len=*), intent (in) :: ztkni integer, intent (in), dimension (:) :: kktknt, itkndt, itknft, itknnt integer, intent (in) :: ksstt end subroutine outtks end interface interface ifsame logical function ifsame (zstr1, zstr2) ! Case insensitive compare character (len=*), intent (in) :: zstr1, zstr2 end function ifsame end interface ! ! Find out a no-backstep order ! iargit (1:nargi) = (/ (i, i=1,nargi) /) iargw = 1 iswp = 0 args: do if (iargw > nargi) exit iarg = iargit (iargw) natt = nattt (iarg) do iatt = 1, natt if (kkattt (iatt, iarg) == kkidf) then iattn = iattnt (iatt, iarg) kwnam = tnamt(iattn)%kwnam ! if (kwnam > kwsys) then do iarg1 = iargw + 1, nargi if (iattn == kargit (iargit (iarg1)) .and. & iswp /= iarg1) then iargit (iargw) = iargit (iarg1) iargit (iarg1) = iarg iswp = iarg1 cycle args endif enddo ! endif endif enddo iargw = iargw + 1 iswp = 0 enddo args ! ! Output arguments declarations ! do iargw = 1, nargi iarg = iargit (iargw) natt = nattt (iarg) if (natt > 0) then ! ! Add ":: name" to id. attribute list ! if (natt /= 1 .or. & (.not.ifsame (zargi (iattdt(1,iarg):iattft(1,iarg)), zxtn))) then if (zargi(iargi:iargi) /= ',') then natt = natt + 1 iargi = iargi + 1 iattdt (natt, iarg) = iargi endif iargf = iargi + 1 iattft (natt, iarg) = iargf kkattt (natt, iarg) = kkdcl zargi (iargi:iargf) = "::" iargi = iargf endif natt = natt + 1 inamd = tnamt(kargit(iarg))%inamod inamf = tnamt(kargit(iarg))%inamof iargi = iargi + 1 iattdt (natt, iarg) = iargi iargf = iargi + inamf - inamd iattft (natt, iarg) = iargf kkattt (natt, iarg) = kkidf zargi (iargi:iargf) = znamo (inamd:inamf) iattnt (natt, iarg) = kargit(iarg) iargi = iargf call outtks (kkattt (1:natt, iarg), iattdt (1:natt, iarg), & iattft (1:natt, iarg), iattnt (1:natt, iarg), & zargi, ksdcl) endif enddo ! ! Output end procedure / end interface ! do itok = 1, ntok itokd = itokdt (itok) itokf = itokft (itok) call tstidf (ztoki (itokd:itokf), kcany, krany, kwwrk, & inamwt (itok)) enddo if (kwwrk > kwsys) then ifnmd = 1 else ifnmd = 0 endif if (ntok == 1 .and. & (itokft(1)-itokdt(1)) == (len_trim (zend) - 1)) then itokd = itokdt (ntok) itokf = itokd + len_trim (zend) - 1 itokft (ntok) = itokf ztoki (itokd:itokf) = zend kktokt (ntok) = kkidf call tstidf (zend, kcany, krany, kwwrk, inamwt (ntok)) ntok = 2 itokd = itokf + 1 itokdt (ntok) = itokd kktokt (ntok) = kkidf if (kfct == 1) then itokf = itokd + len_trim (zfun) - 1 itokft (ntok) = itokf ztoki (itokd:itokf) = zfun call tstidf (zfun, kcany, krany, kwwrk, inamwt (ntok)) else ! if (kfct == 2) then itokf = itokd + len_trim (zsub) - 1 itokft (ntok) = itokf ztoki (itokd:itokf) = zsub call tstidf (zsub, kcany, krany, kwwrk, inamwt (ntok)) endif endif ! ! Put procedure name if it is not already there ! if (ifnmd == 0) then ntok = ntok + 1 itokd = itokf + 1 itokf = itokd + len_trim (zprci) - 1 itokdt (ntok) = itokd itokft (ntok) = itokf kktokt (ntok) = kkidf ztoki (itokd:itokf) = zprci call tstidf (zprci, kcany, krany, kwwrk, inamwt (ntok)) endif call outstt (ntok, kspre) call enditf end subroutine outitf subroutine bdyitf (ksstti) ! Output current line in interface block ! ___________________________________________________________________ ! integer, intent (in) :: ksstti ! do itok = 1, ntok if (kktokt (itok) == kkidf) then itokd = itokdt (itok) itokf = itokft (itok) call tstidf (ztoki (itokd:itokf), kcany, krany, kwwrk, & inamwt (itok)) endif enddo call outstt (ntok, ksstti) end subroutine bdyitf subroutine chkdcl ! Check for arguments declarations ! ___________________________________________________________________ ! ! integer, dimension (1:2*nattm) :: jwrk1, jwrk2 ! work arrays natt = 0 ifidf = 0 ntoka = 0 itok = 0 do itok = itok + 1 if (itok > ntok) exit ! ! ! if (kktokt (itok) == kkidf) then itokd = itokdt (itok) itokf = itokft (itok) inamw = indhsh (ztoki (itokd:itokf)) if (inamw == 0) then if (natt > 0) then ifidf = 1 cycle else return endif endif kwwrk = tnamt(inamw)%kwnam select case (kwwrk) case (kwatt, kwntt, kwtyp) natt = natt + 1 ntoka = itok cycle case default ! kwvar, kwext only should be allowed, but keywords ! can be used ... ifidf = 1 do iarg = 1, nargi if (inamw == kargit (iarg)) then natt = nattt (iarg) iargi0 = iargi natt0 = natt if (natt /= 0) then natt = natt + 1 iargi = iargi + 1 iattdt (natt, iarg) = iargi iattft (natt, iarg) = iargi kkattt (natt, iarg) = kksep zargi (iargi:iargi) = "," endif do iatt = 1, ntoka natt = natt + 1 iargi = iargi + 1 iattdt (natt, iarg) = iargi if (kktokt (iatt) /= kkidf) then itokd = itokdt (iatt) itokf = itokft (iatt) iargf = iargi + itokf - itokd iattft (natt, iarg) = iargf kkattt (natt, iarg) = kktokt (iatt) zargi (iargi:iargf) = ztoki (itokd:itokf) iargi = iargf else itokd = itokdt (iatt) itokf = itokft (iatt) call tstidf (ztoki (itokd:itokf), kcany, krany, & kwwrk, inamw) if (inamw == indhsh (zdim) .and. ntoka == 1) then iargi = iargi0 natt = natt0 elseif (inamw > 0) then if (tnamt(inamw)%kwnam <= kwsys) then inamd = tnamt(inamw)%inamod inamf = tnamt(inamw)%inamof iargf = iargi + inamf - inamd iattft (natt, iarg) = iargf kkattt (natt, iarg) = kktokt (iatt) zargi (iargi:iargf) = znamo (inamd:inamf) else iargf = iargi + itokf - itokd iattft (natt, iarg) = iargf kkattt (natt, iarg) = kktokt (iatt) zargi (iargi:iargf) = ztoki (itokd:itokf) endif iargi = iargf else iargf = iargi + itokf - itokd iattft (natt, iarg) = iargf kkattt (natt, iarg) = kktokt (iatt) zargi (iargi:iargf) = ztoki (itokd:itokf) iargi = iargf endif iattnt (natt, iarg) = inamw endif enddo if (itok < ntok - 2) then if (kktokt (itok+1) == kkpou) then ! ! Add ", dimension (xxxx)" to id. attribute list ! natt = natt + 1 iargi = iargi + 1 iattdt (natt, iarg) = iargi iattft (natt, iarg) = iargi kkattt (natt, iarg) = kksep zargi (iargi:iargi) = "," natt = natt + 1 iargi = iargi + 1 iattdt (natt, iarg) = iargi iargf = iargi + len_trim (zdim) - 1 iattft (natt, iarg) = iargf kkattt (natt, iarg) = kkidf zargi (iargi:iargf) = zdim iattnt (natt, iarg) = indhsh (zdim) iargi = iargf lpar = 0 do itok = itok+1, ntok natt = natt + 1 iargi = iargi + 1 iattdt (natt, iarg) = iargi itokd = itokdt (itok) itokf = itokft (itok) iargf = iargi + itokf - itokd iattft (natt, iarg) = iargf kkattt (natt, iarg) = kktokt (itok) zargi (iargi:iargf) = ztoki (itokd:itokf) iargi = iargf if (kktokt (itok) == kkidf) then call tstidf (ztoki (itokd:itokf), & kcany, krany, kwwrk, & iattnt (natt, iarg)) elseif (kktokt (itok) == kkpou) then lpar = lpar + 1 elseif (kktokt (itok) == kkpfr) then lpar = lpar - 1 if (lpar == 0) exit endif enddo elseif (kktokt (itok+1) == kksta) then ! ! add "(len=xxxx)" to the "character" definition ! natt = natt + 1 nattw = natt iargi = iargi + 1 iattdt (natt, iarg) = iargi iattft (natt, iarg) = iargi if (nattw > 2 .and. & kkattt (2, iarg) == kkpou) then kkattt (nattw, iarg) = kksep zargi (iargi:iargi) = "," ifchq = 1 else kkattt (natt, iarg) = kkpou zargi (iargi:iargi) = "(" ifchq = 0 endif natt = natt + 1 iargi = iargi + 1 iattdt (natt, iarg) = iargi iargf = iargi + len_trim (zlen) - 1 iattft (natt, iarg) = iargf kkattt (natt, iarg) = kkidf zargi (iargi:iargf) = zlen iattnt (natt, iarg) = indhsh (zlen) natt = natt + 1 iargi = iargf + 1 iattdt (natt, iarg) = iargi iattft (natt, iarg) = iargi kkattt (natt, iarg) = kkaff zargi (iargi:iargi) = "=" ifudl = 0 if (ntok > itok+3) then if (kktokt (itok+2) == kkpou .and. & kktokt (itok+3) == kksta .and. & kktokt (itok+4) == kkpfr) ifudl = 1 endif if (ifudl == 0) then lpar = 0 do itok = itok+2, ntok natt = natt + 1 iargi = iargi + 1 iattdt (natt, iarg) = iargi itokd = itokdt (itok) itokf = itokft (itok) iargf = iargi + itokf - itokd iattft (natt, iarg) = iargf kkattt (natt, iarg) = kktokt (itok) zargi (iargi:iargf) = ztoki (itokd:itokf) iattnt (natt, iarg) = indhsh (ztoki (itokd:itokf)) iargi = iargf if (kktokt (itok) == kkpou) then lpar = lpar + 1 elseif (kktokt (itok) == kkpfr) then lpar = lpar - 1 endif if (lpar == 0) exit enddo else ! ! remove brackets in (*) ! natt = natt + 1 iargi = iargi + 1 iattdt (natt, iarg) = iargi iattft (natt, iarg) = iargi kkattt (natt, iarg) = kksta zargi (iargi:iargi) = "*" endif if (ifchq == 0) then natt = natt + 1 iargi = iargi + 1 iattdt (natt, iarg) = iargi iattft (natt, iarg) = iargi kkattt (natt, iarg) = kkpfr zargi (iargi:iargi) = ")" endif ! ! move it to the right place ! if (nattw > 2) then if (ifchq == 0) then iattw = 2 else lpar = 0 do iattw = 2, nattw if (kkattt (iattw, iarg) == kkpou) then lpar = lpar + 1 elseif (kkattt (iattw, iarg) == kkpfr) then lpar = lpar - 1 endif if (lpar == 0) exit enddo endif natts = natt-nattw jwrk1 (1:natts+1) = kkattt (nattw:natt, iarg) jwrk2 (1:nattw-iattw) = kkattt (iattw:nattw-1, iarg) kkattt (iattw+natts+1:natt, iarg) = jwrk2 (1:nattw-iattw) kkattt (iattw:iattw+natts, iarg) = jwrk1 (1:natts+1) jwrk1 (1:natts+1) = iattdt (nattw:natt, iarg) jwrk2 (1:nattw-iattw) = iattdt (iattw:nattw-1, iarg) iattdt (iattw+natts+1:natt, iarg) = jwrk2 (1:nattw-iattw) iattdt (iattw:iattw+natts, iarg) = jwrk1 (1:natts+1) jwrk1 (1:natts+1) = iattft (nattw:natt, iarg) jwrk2 (1:nattw-iattw) = iattft (iattw:nattw-1, iarg) iattft (iattw+natts+1:natt, iarg) = jwrk2 (1:nattw-iattw) iattft (iattw:iattw+natts, iarg) = jwrk1 (1:natts+1) jwrk1 (1:natts+1) = iattnt (nattw:natt, iarg) jwrk2 (1:nattw-iattw) = iattnt (iattw:nattw-1, iarg) iattnt (iattw+natts+1:natt, iarg) = jwrk2 (1:nattw-iattw) iattnt (iattw:iattw+natts, iarg) = jwrk1 (1:natts+1) endif endif endif nattt (iarg) = natt exit endif enddo end select elseif (kktokt (itok) == kkpou) then ! ! Add (xxxx) to attribute list ! lpar = 0 do itok = itok, ntok if (kktokt (itok) == kkpou) then lpar = lpar + 1 elseif (kktokt (itok) == kkpfr) then lpar = lpar - 1 if (lpar == 0) then if (ifidf == 0) ntoka = itok exit endif endif enddo elseif (kktokt (itok) == kkdcl) then ifidf = 1 endif enddo end subroutine chkdcl end subroutine trtstt 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& >HIOSTATKINDLENLOGLOG10LOGICALMAXMINMODMODULEMODULEPROCEDURENAMENAMEDNAMELISTNEXTRECNINTNMLNONENULLIFYNUMBEROONLYOPENOPENEDOPERAT& &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 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) & // 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 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 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 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=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 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 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 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 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 ^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 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 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 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 outtks (kktknt, itkndt, itknft, itknnt, ztkni, ksstt) ! build and output statement use flexvars use fprsvars use fpprcurs character (len=*), intent (in) :: ztkni integer, intent (in), dimension (:) :: kktknt, itkndt, itknft, itknnt integer, intent (in) :: ksstt ! ____________________________________________________________________ ! character (len=2*lsttm) :: zstt character (len=linem) :: zcmt, zlab character (len=lsttm) :: ztknw ! ntkn = size (kktknt) ! ! 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 (ntkn == 0) then ! ! blank lines ! call wrtstt (zlab, llab, zblk, 0, zblk, len_trim (zblk), 0) elseif (ntkn == 1 .and. kktknt (1) == kkcmt) then itknd = itkndt (1) itknf = itknft (1) ltkn = itknf - itknd + 1 call wrtstt (zlab, llab, zblk, 0, ztkni (itknd:itknf), ltkn, 0) elseif (ntkn == 1 .and. kktknt (1) == kkebc) then itknd = itkndt (1) itknf = itknft (1) ltkn = itknf - itknd + 1 call wrtstt (zlab, llab, zblk, 0, ztkni (itknd:itknf), ltkn, 0) else kkprv = kkukn ifblk = 0 lcmt = 0 itkn = 0 do itkn = itkn + 1 if (itkn > ntkn) exit itknd = itkndt (itkn) itknf = itknft (itkn) ltknw = itknf - itknd + 1 ztknw (1:ltknw) = ztkni (itknd:itknf) kktkn = kktknt (itkn) ! ! Construct line inserting spaces where necessary ! select case (kktkn) case (kkcmt, kkebc) ! Comment string if (ifblk == 0) then ltkn = ltknw + 1 zcmt (1:ltkn) = " " // ztknw (1:ltknw) else ltkn = ltknw zcmt (1:ltkn) = ztknw (1:ltknw) endif lcmt = ltkn exit case (kkfcm) ! False comment llab = ltknw zlab (1:llab) = ztknw (1:ltknw) ltkn = 0 case (kklab) ! Numerical label if (lstt == 0) then llab = ltknw zlab (1:llab) = ztknw (1:ltknw) ltkn = 0 else ltkn = ltknw + 2 zstt (lstt+1:lstt+ltkn) = " " // ztknw (1:ltknw) // " " ifblk = 1 endif case (kkstr, & ! Character string & kkknd, & ! _Kind (underscore) & kkbnm, & ! Block name & kknui, & ! Integer Numerical value & kknuf) ! Real Numerical value ltkn = ltknw zstt (lstt+1:lstt+ltkn) = ztknw (1:ltknw) ifblk = 0 case (kkprc) ! % ltkn = ltknw if (ifblk /= 0) lstt = lstt - 1 zstt (lstt+1:lstt+ltkn) = ztknw (1:ltknw) ifblk = 0 case (kksep) ! , ltkn = ltknw + 1 if (ifblk /= 0) lstt = lstt - 1 zstt (lstt+1:lstt+ltkn) = ztknw (1:ltknw) // " " ifblk = 1 case (kkidf) ! Identifier ! kwnam = tnamt(itknnt(itkn))%kwnam if (kwnam <= kwsys .and. kccask /= kclve) then call chgcas (ztknw (1:ltknw), kccask) elseif (kwnam > kwsys .and. kccasu /= kclve) then call chgcas (ztknw (1:ltknw), kccasu) endif ! if (kwnam == kwlop .and. ifblk == 0) then ltkn = ltknw + 2 zstt (lstt+1:lstt+ltkn) = " " // ztknw (1:ltknw) // " " ifblk = 1 elseif (kwnam == kwlop .and. ifblk /= 0) then ltkn = ltknw + 1 zstt (lstt+1:lstt+ltkn) = ztknw (1:ltknw) // " " ifblk = 1 elseif (kwnam == kwac5) then if (ifblk /= 0 .or. lstt == 0) then ltkn = ltknw + 1 zstt (lstt+1:lstt+ltkn) = ztknw (1:ltknw) // " " else ltkn = ltknw + 2 zstt (lstt+1:lstt+ltkn) = " " // ztknw (1:ltknw) & // " " endif ifblk = 1 elseif ((kkprv == kkidf .or. & kkprv == kknui .or. & kkprv == kknuf ) .and. ifblk == 0) then ltkn = ltknw + 1 zstt (lstt+1:lstt+ltkn) = " " // ztknw (1:ltknw) ifblk = 0 else ltkn = ltknw zstt (lstt+1:lstt+ltkn) = ztknw (1:ltknw) ifblk = 0 endif case (kkdpt) ! : if (lpar <= 0) then ltkn = ltknw + 1 zstt (lstt+1:lstt+ltkn) = ztknw (1:ltknw) // " " ifblk = 1 else ltkn = ltknw zstt (lstt+1:lstt+ltkn) = ztknw (1:ltknw) ifblk = 0 endif ! case (kkpvg, & ! ; & kkcmd, & ! $command (preprocessor) & kkdot) ! ) ltkn = ltknw + 1 zstt (lstt+1:lstt+ltkn) = ztknw (1:ltknw) // " " ifblk = 1 case (kkqst) ! ? ltkn = 0 if (ifblk /= 0) lstt = lstt - 1 ifblk = 0 case (kkpfr) ! ) lpar = lpar - 1 ltkn = ltknw + 1 if (ifblk /= 0) lstt = lstt - 1 zstt (lstt+1:lstt+ltkn) = ztknw (1:ltknw) // " " ifblk = 1 case (kkpou) ! ( lpar = lpar + 1 if (lpar <= 1 .and. ifblk == 0) then ltkn = ltknw + 1 zstt (lstt+1:lstt+ltkn) = " " // ztknw (1:ltknw) else ltkn = ltknw zstt (lstt+1:lstt+ltkn) = ztknw (1:ltknw) endif ifblk = 0 case (kkpnb) ! ( within defined type lpar = lpar + 1 ltkn = ltknw zstt (lstt+1:lstt+ltkn) = ztknw (1:ltknw) ifblk = 0 case (kkslh, & ! / & kkpms, & ! + or - & kkcct, & ! // & kksta, & ! * & kkpow, & ! ** & kkaff) ! = if (lpar <= 0 .and. ifblk == 0) then ltkn = ltknw + 2 zstt (lstt+1:lstt+ltkn) = " " // ztknw (1:ltknw) // " " ifblk = 1 elseif (lpar <= 0) then ltkn = ltknw + 1 zstt (lstt+1:lstt+ltkn) = ztknw (1:ltknw) // " " ifblk = 1 else if (ifblk /= 0) lstt = lstt - 1 ltkn = ltknw zstt (lstt+1:lstt+ltkn) = ztknw (1:ltknw) ifblk = 0 endif case (kkcou, & ! (/ & kkneq, & ! /= & kkleq, & ! <= & kkequ, & ! == & kkgeq, & ! >= & kkpts, & ! => & kksup, & ! > & kkinf, & ! < & kkdcl, & ! :: & kklog, & ! .xxx. & kkcfr) ! /) if (ifblk == 0) then ltkn = ltknw + 2 zstt (lstt+1:lstt+ltkn) = " " // ztknw (1:ltknw) // " " else ltkn = ltknw + 1 zstt (lstt+1:lstt+ltkn) = ztknw (1:ltknw) // " " endif ifblk = 1 case default ltkn = ltknw zstt (lstt+1:lstt+ltkn) = ztknw (1:ltknw) ifblk = 0 endselect lstt = lstt + ltkn kkprv = kktkn 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 outtks integer function indhsh (znam) ! Return hash index for identifier use fprsvars use flexprms use fpprcurs 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)) inam = 0 if (tnamt(ihsh)%kwnam == 0) then indhsh = 0 else do inamd = tnamt(ihsh)%inamd inamf = tnamt(ihsh)%inamf if (ifsame (znam (1:lnam), znamg (inamd:inamf))) then indhsh = ihsh exit endif if (tnamt(ihsh)%ihshf == 0) then indhsh = 0 exit else ihsh = tnamt(ihsh)%ihshf cycle endif enddo endif ! return end function indhsh