Usenet 1994 January

home *** CD-ROM | disk | FTP | other *** search

/ Usenet 1994 January / usenetsourcesnewsgroupsinfomagicjanuary1994.iso / sources / misc / volume12 / ffccc / part11 < prev next >

Wrap

Text File | 1990-05-14 | 40.4 KB | 1,166 lines

Newsgroups: comp.sources.misc organization: CERN, Geneva, Switzerland keywords: fortran subject: v12i097: Floppy - Fortran Coding Convention Checker Part 11/11 from: julian@cernvax.cern.ch (julian bunn) Sender: allbery@uunet.UU.NET (Brandon S. Allbery - comp.sources.misc) Posting-number: Volume 12, Issue 97 Submitted-by: julian@cernvax.cern.ch (julian bunn) Archive-name: ffccc/part11 #!/bin/sh echo 'Start of Floppy, part 11 of 11:' echo 'x - ALCAZA.h' sed 's/^X//' > ALCAZA.h << '/' X COMMON/ALCAZA/SCROUT,SSTM,SNAM,SSTA,SSTR,SNEWST(100),SIMA(MXSIMD), X 1 SNAMES(MXNAME),SCBVAR(MXNAME),SCBNAM(MAXGRP) X CHARACTER SCROUT*(MXNMCH),SSTM*(MXSSTM),SNAM*(MXSSTM), X 1 SSTA*(MDIMST),SSTR*(MDIMST),SNEWST*(MXLINE),SIMA*(MXLINE), X 2 SNAMES*(MXNMCH),SCBVAR*(MXNMCH),SCBNAM*(MXNMCH) X*IF DEF,NEVER X*----------------------------------------------------------------------- X*--- SCROUT = name of current routine being processed X*--- SSTM = string containing all statement descriptions X*--- SNAM = string containing all statement descriptors X*--- SSTA = string containing the actual statement, col. 7-72 (all) X*--- SSTR = temporary statement buffer during replacement X*--- SNEWST = temporary statement image buffer during reformatting X*--- SIMA = string containing one complete routine X*--- SNAMES = name list for global, routine, and statement names X*--- SCBVAR = list of c.b. variables in one routine (ACTION(24)) X*--- SCBNAM = list of c.b. names in one routine X*----------------------------------------------------------------------- X*EI / echo 'x - CALCAZA.h' sed 's/^X//' > CALCAZA.h << '/' X*IF DEF,NEVER X*----------------------------------------------------------------------- X*--- SCROUT = name of current routine being processed X*--- SSTM = string containing all statement descriptions X*--- SNAM = string containing all statement descriptors X*--- SSTA = string containing the actual statement, col. 7-72 (all) X*--- SSTR = temporary statement buffer during replacement X*--- SNEWST = temporary statement image buffer during reformatting X*--- SIMA = string containing one complete routine X*--- SNAMES = name list for global, routine, and statement names X*--- SCBVAR = list of c.b. variables in one routine (ACTION(24)) X*--- SCBNAM = list of c.b. names in one routine X*----------------------------------------------------------------------- X*EI / echo 'x - CCONDEC.h' sed 's/^X//' > CCONDEC.h << '/' X*IF DEF,NEVER X*----------------------------------------------------------------------- X*--- SBASE = list of all ccharacters recognized by FLOP. X*+++ warning +++ : '{', and '}' are forbidden for users. X*--- SPCHAR = list of string replacement characters in flop. X*----------------------------------------------------------------------- X*EI / echo 'x - CCURSTA.h' sed 's/^X//' > CCURSTA.h << '/' X*IF DEF,NEVER X*----------------------------------------------------------------------- X* /CURSTA/ describes the "current" statement X* (after calls to EXTRAC and CLASSF) X* NCHST no. of ch. in statement X* NSTREF no. of corresponding statement in SIMA X* NLIMA no. of corresponding image lines of current stmt. X* IFILTR flag: = -1 reset for routine, 0 reset for statement, X* 1 do not reset X* NLREF ref. to n-th corresponding line in SIMA X* ICURCL(1) class of first part X* ICURCL(2) class of second part ( if ICURCL(1)=IIF), else ILL X* NEWOUT occupation of SNEWST in lines X* NDUMMY true dummy argument (to avoid integer overflows) X*----------------------------------------------------------------------- X*EI / echo 'x - CFLWORK.h' sed 's/^X//' > CFLWORK.h << '/' X*IF DEF,NEVER X*--- IWS = working space X*EI / echo 'x - CHECKS.h' sed 's/^X//' > CHECKS.h << '/' X PARAMETER (MCHEKS=100) X COMMON /USCHEK/ LCHECK(MCHEKS),CCHECK(MCHEKS) X LOGICAL LCHECK X CHARACTER*80 CCHECK / echo 'x - CJOBSUM.h' sed 's/^X//' > CJOBSUM.h << '/' X*IF DEF,NEVER X*----------------------------------------------------------------------- X* contains the statistical information X* TIME1 starting time in seconds X* TIME2 ending - - X* NSTATC overall statistical information X* 1 = # of lines read X* 2 = # of lines written to output file X* 3 = # of statements read X* 4 = # of statements after filters X* 5 = # of statements changed X* 6 = # of lines unable to change (length overflow) X* 7 = # of comment lines (including blank lines) X* 8 = # of lines printed X* NFDCLS no. of times internal class found X* (I,1) normal, (I,2) behind logical IF X*----------------------------------------------------------------------- X*EI / echo 'x - COMMENT.h' sed 's/^X//' > COMMENT.h << '/' X*IF DEF,NEVER XC FLOPPY XC ------ XC Implementation in FLOP of Fortran Coding Convention Checking XC XC J.J.Bunn December 1985 XC Version 5 December 1986 for general release XC X*EI / echo 'x - CONDAT.h' sed 's/^X//' > CONDAT.h << '/' X DATA SBASE/ X 1' :?!#&$@;><=()+-*/[],.''"{}ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijk X +lmnopqrstuvwxyz_0123456789%'/ X DATA SPCHAR/'@&$#?!>'/,SPILL/'{}'/ X*----------------------------------------------------------------------- X*--- statement function SPECCH = true for special character X SPECCH(SDUMMY)=INDEX(SBASE(2:24),SDUMMY).NE.0 X 1 .OR.INDEX(SBASE(90:),SDUMMY).NE.0 X*--- statement function NUMCH = true for numeric character X NUMCH(SDUMMY)=INDEX(SBASE(80:89),SDUMMY).NE.0 X*--- statement function ALPHCH = true for alphabetic character X ALPHCH(SDUMMY)=INDEX(SBASE(27:79),SDUMMY).NE.0 X*--- statement function ANUMCH = true for alphanumeric character X ANUMCH(SDUMMY)=INDEX(SBASE(27:89),SDUMMY).NE.0 X*--- statement function STRGCH = true for string character X STRGCH(SDUMMY)=INDEX(SBASE(3:10),SDUMMY).NE.0 X*--- statement function for integer value (place) of character X ICVAL(SDUMMY)=INDEX(SBASE(27:89),SDUMMY) X*----------------------------------------------------------------------- / echo 'x - CONDEC.h' sed 's/^X//' > CONDEC.h << '/' X LOGICAL SPECCH,NUMCH,ALPHCH,ANUMCH,STRGCH X CHARACTER SBASE*91,SPCHAR*7,SPILL*2,SDUMMY*1 X*IF DEF,NEVER X*----------------------------------------------------------------------- X*--- SBASE = list of all ccharacters recognized by FLOP. X*+++ warning +++ : '{', and '}' are forbidden for users. X*--- SPCHAR = list of string replacement characters in flop. X*----------------------------------------------------------------------- X*EI / echo 'x - CONVEX.h' sed 's/^X//' > CONVEX.h << '/' X include 'CONDEC.h' X include 'CONDAT.h' / echo 'x - CTREECOM.h' sed 's/^X//' > CTREECOM.h << '/' X*IF DEF,NEVER X*----------------------------------------------------------------------- X* X* CALLER calling routiine, or entry in it X* CALLED called routine or function X* CERARG argument types of caller X* CEDARG argument types of called X* KODE type of caller or entry (S/R = blank) X* NCALLR # of callers in this routine X* NCALLD # of called in this routine X* ICALLR statement number of CALL X*----------------------------------------------------------------------- X*EI / echo 'x - CTYPDEF.h' sed 's/^X//' > CTYPDEF.h << '/' X*IF DEF,NEVER X*----------------------------------------------------------------------- X* X* KVTYPE(I) current default type for starting character no. I X*----------------------------------------------------------------------- X*EI / echo 'x - CURSTA.h' sed 's/^X//' > CURSTA.h << '/' X COMMON/CURSTA/NCHST,NSTREF,NLIMA,IFILTR,NLREF(20),ICURCL(2), X + NEWOUT,NDUMMY X*IF DEF,NEVER X*----------------------------------------------------------------------- X* /CURSTA/ describes the "current" statement X* (after calls to EXTRAC and CLASSF) X* NCHST no. of ch. in statement X* NSTREF no. of corresponding statement in SIMA X* NLIMA no. of corresponding image lines of current stmt. X* IFILTR flag: = -1 reset for routine, 0 reset for statement, X* 1 do not reset X* NLREF ref. to n-th corresponding line in SIMA X* ICURCL(1) class of first part X* ICURCL(2) class of second part ( if ICURCL(1)=IIF), else ILL X* NEWOUT occupation of SNEWST in lines X* NDUMMY true dummy argument (to avoid integer overflows) X*----------------------------------------------------------------------- X*EI / echo 'x - CUSARGS.h' sed 's/^X//' > CUSARGS.h << '/' X*IF DEF,NEVER X*----------------------------------------------------------------------- X* NARGS = number of arguments passed to current module X* CARGNMi = name of argument i X* CARGTYi = type of argument i (EG CHAR80, INTE2) X* NARGDIi = number of dimensions of argument i X* CARGDIji= 1) lower bound for jth. dimension of argument i X* 2) upper bound for jth. dimension of argument i X* NKALL = number of CALL statements in module X* CKALLNi = name of subroutine ith. CALLed X* KALLIFi = IF level of ith. subroutine CALLed X* KALLDOi = DO level of ith. subroutine CALLed X*----------------------------------------------------------------------- X*EI / echo 'x - CUSCOMN.h' sed 's/^X//' > CUSCOMN.h << '/' X*IF DEF,NEVER X*----------------------------------------------------------------------- X* NCOMN = number of variables in all COMMON blocks this routine X* NCOMT = number of COMMON block titles this routine X* SCNAME = name of variable I X* SCTITL = name of COMMON block J X* ICNAME = pointer to J for name I X* ICTITL = -(pointer to start of names in SCNAME for COMMON block J) X*----------------------------------------------------------------------- X*EI / echo 'x - CUSGCOM.h' sed 's/^X//' > CUSGCOM.h << '/' X*IF DEF,NEVER X*----------------------------------------------------------------------- X* NGCON = number of variables in all COMMON blocks all ROUTINES X* NGCOT = number of COMMON block titles all ROUTINES X* SGCNAM = name of variable I X* SGCTIT = name of COMMON block J X* IGCNAM = pointer to J for name I X* IGCTIT = -(pointer to start of names in SGCNAM for COMMON block J) X*----------------------------------------------------------------------- X*EI / echo 'x - CUSIGNO.h' sed 's/^X//' > CUSIGNO.h << '/' X*IF DEF,NEVER X*----------------------------------------------------------------------- X* MXIGNV = Maximum number of variable names to ignore X* MUUNIT = LUN of USER list of variable names to ignore X* NIGNOR = Number of variable names found X* NIGNOS = Number of subroutine names found X* CIGNOR = Array of ignorable variable names X* CIGNOS = Array of ignorable subroutine names X* LIGNOR = Length of variable name X* LIGNOS = Length of subroutine name X* GALEPH = set .TRUE. if special GALEPH processing X* ADAMO = set .TRUE. if special ADAMO processing X* USAGE = set .TRUE. if check of COMMON variable usage X* UNFLP = set .TRUE. if NO coding convention checks ! X*----------------------------------------------------------------------- X*EI / echo 'x - CUSINFN.h' sed 's/^X//' > CUSINFN.h << '/' X*IF DEF,NEVER X*----------------------------------------------------------------------- X* LIF = number of intrinsic functions recognised X* CINFUN = name of intrinsic function X* INFUNG = "1" if generic, "0" if not X* CTYFUN = set only for generic types ... gives type of function X* = 'I' integer X* = 'R' real X* = 'D' double precision X* = 'K' complex X* = 'L' logical X* = 'C' character X* = '$' takes type of argument(s) X*----------------------------------------------------------------------- X*EI / echo 'x - CUSLIST.h' sed 's/^X//' > CUSLIST.h << '/' X*IF DEF,NEVER X*----------------------------------------------------------------------- X* USFULL = set .TRUE. if input file to be printed to MZUNIT X*----------------------------------------------------------------------- X*EI / echo 'x - CUSUNIT.h' sed 's/^X//' > CUSUNIT.h << '/' X*IF DEF,NEVER X*----------------------------------------------------------------------- X* MZUNIT = logical unit of scratch file X* MJUNIT = logical unit for customized TREE output X* MSUNIT = logical unit for specification of rules X*----------------------------------------------------------------------- X*EI / echo 'x - ERREX1.f' sed 's/^X//' > ERREX1.f << '/' X SUBROUTINE ERREX1 X*----------------------------------------------------------------------- X* X*--- error exit and stop when name buffer overflow X* X*----------------------------------------------------------------------- X include 'PARAM.h' X N=MXNAME X WRITE (MPUNIT,10000) N X STOP X10000 FORMAT (//' ++++++++++++++++++++++++++++++++++++++++'/ X +' + +'/ X +' + NAME BUFFER OVERFLOW, STOP +'/ X +' + ACTUAL SIZE =',I5,T41,'+'/ X +' + +'/ X +' ++++++++++++++++++++++++++++++++++++++++') X END / echo 'x - FLDUMP.f' sed 's/^X//' > FLDUMP.f << '/' X SUBROUTINE FLDUMP(NUN,N,STRING,NCOUNT) X*----------------------------------------------------------------------- X* X*--- writes lines onto output file X* X*--- input X* NUN output unit X* N # of lines X* STRING lines X*--- input/output X* NCOUNT counter to be increased by N X* X*----------------------------------------------------------------------- X CHARACTER *(*) STRING(*) X DO 10 I=1,N X WRITE (NUN,'(A)') STRING(I) X 10 CONTINUE X NCOUNT=NCOUNT+N X END / echo 'x - FLPRNT.f' sed 's/^X//' > FLPRNT.f << '/' X SUBROUTINE FLPRNT(NBLANK,SHEAD,N,STRING,NCOUNT) X*----------------------------------------------------------------------- X* X*--- writes lines onto PRINT output file (MPUNIT) X* X*--- input X* NBLANK # of blank lines to print in front X* SHEAD string to be put into header part of line 1 X* N # of lines X* STRING lines X*--- input/output X* NCOUNT counter to be increased by N X* X*----------------------------------------------------------------------- X include 'PARAM.h' X include 'USUNIT.h' X CHARACTER *(*) STRING(*),SHEAD,SLOC*15 X DO 10 I=1,NBLANK X WRITE (MZUNIT,'('' '')') X 10 CONTINUE X SLOC=SHEAD X WRITE(MZUNIT,'(1X,A15,A)') SLOC,STRING(1) X DO 20 I=2,N X WRITE (MZUNIT,'(16X,A)') STRING(I) X 20 CONTINUE X NCOUNT=NCOUNT+N X END / echo 'x - FLWORK.h' sed 's/^X//' > FLWORK.h << '/' X COMMON/FLWORK/IWS(MXNAME) X*IF DEF,NEVER X*--- IWS = working space X*EI / echo 'x - GETINT.f' sed 's/^X//' > GETINT.f << '/' X SUBROUTINE GETINT(STRING,ICC1,ICC2,KFCH,KLCH,NN) X*----------------------------------------------------------------------- X* X* routine to extract one positive integer from a BCD string. X* input X* STRING input string X* ICC1 starting pos. for scan X* ICC2 end - - - X* output X* KFCH pos. of first character of integer in STRING, X* or 0 if no integer found. X* KLCH pos. of last ch. in STRING. X* NN integer in integer format. (set to zero when none found) X* X*----------------------------------------------------------------------- X CHARACTER*(*) STRING X NN=0 X CALL CHRTYP(1,STRING,ICC1,ICC2,.FALSE.,KFCH,ILEV) X IF(KFCH.NE.0) THEN X CALL SKIPTP(1,STRING,KFCH,ICC2,.FALSE.,KLCH,ILEV) X NN=NEXTIN(STRING,KFCH,KLCH) X ENDIF X END / echo 'x - GETNBL.f' sed 's/^X//' > GETNBL.f << '/' X SUBROUTINE GETNBL(STRING,SNBLK,NN) X*----------------------------------------------------------------------- X* X*--- extracts non-blank characters X*--- input X* STRING input string - full length taken X*--- output X* SNBLK string of non-blank (to max. length) X* NN # of non-blank put in SNBLK X*----------------------------------------------------------------------- X CHARACTER *(*) STRING,SNBLK,STEMP*1 X LUP=LEN(SNBLK) X NN=0 X DO 10 I=1,LEN(STRING) X STEMP=STRING(I:I) X IF (STEMP.EQ.' ') GOTO 10 X IF (NN.EQ.LUP) GOTO 999 X NN=NN+1 X SNBLK(NN:NN)=STEMP X 10 CONTINUE X 999 END / echo 'x - GETRNG.f' sed 's/^X//' > GETRNG.f << '/' X SUBROUTINE GETRNG(IST,LAST,IARR) X*----------------------------------------------------------------------- X* X* Gives positions of '(' and ')' in SSTA (no string check !) X* X* Input X* IST starting position of scan X* LAST last position of scan X* X* Output X* IARR(1) # of '(...)' X* IARR(2) pos. of first '(' X* IARR(3) pos. of first ')' X* IARR(4) pos. of second '(' X* etc. X*----------------------------------------------------------------------- X include 'PARAM.h' X include 'ALCAZA.h' X DIMENSION IARR(*) X N=0 X IPT=IST-1 X 10 CONTINUE X IND=INDEX(SSTA(IPT+1:LAST),'(') X IF (IND.EQ.0) GOTO 20 X IPT=IPT+IND X CALL SKIPLV(SSTA,IPT+1,LAST,.FALSE.,IND,ILEV) X IF (IND.EQ.0) GOTO 20 X N=N+1 X IARR(2*N)=IPT X IARR(2*N+1)=IND X IPT=IND X IF (IPT.LT.LAST) GOTO 10 X 20 CONTINUE X IARR(1)=N X END / echo 'x - HEADER.f' sed 's/^X//' > HEADER.f << '/' X SUBROUTINE HEADER X*----------------------------------------------------------------------- X* X*--- prints print output header X* X*----------------------------------------------------------------------- X include 'PARAM.h' X write(mpunit,10000) versio X10000 format('1 ',78('*'),/, X & ' *',76(' '),'*',/, X & ' *',30x,'F L O P P Y',35x,'*',/, X & ' *',76(' '),'*',/, X & ' *',76(' '),'*',/, X & ' *',12x, X & 'Fortran Coding Convention Checker and Code Tidier', X & 15x,'*',/ X & ' *',76(' '),'*',/, X & ' *',30x,'Version ',f3.1,35x,'*',/, X & ' *',76(' '),'*',/, X & ' * (c) CERN, 1990',61x,'*',/, X & ' ',78('*')) X END / echo 'x - INDECS.f' sed 's/^X//' > INDECS.f << '/' X SUBROUTINE INDECS(I1,I2,*) X*----------------------------------------------------------------------- X* X* Sub-task of routine INDECO. X* Stores string without {} from SSTA(I1:I2) into SKYSTR, X* sets NKYSTR, LKYSTR, KKYSTA, KKYEND. X* X*----------------------------------------------------------------------- X include 'PARAM.h' X include 'ALCAZA.h' X include 'KEYCOM.h' X* X L=I2-I1-1 X IF(NKYSTR.EQ.MXKNAM.OR.LKYSTR+L.GT.MDIMST) THEN X WRITE (MPUNIT,10000) NKYSTR,MXKNAM,MDIMST X RETURN 1 X ENDIF X NKYSTR=NKYSTR+1 X KKYSTA(NKYSTR)=LKYSTR+1 X SKYSTR(LKYSTR+1:LKYSTR+L)=SSTA(I1+1:I2-1) X LKYSTR=LKYSTR+L X KKYEND(NKYSTR)=LKYSTR X10000 FORMAT(/1X,8('*-*-'),' WARNING - no. of strings in commands =', X +I5,' has reached maximum =',I5/ 33X, X +' or total length has reached maximum =',I5,' rest ignored') X END / echo 'x - INDECT.f' sed 's/^X//' > INDECT.f << '/' X SUBROUTINE INDECT X*----------------------------------------------------------------------- X* X* Checks for invalid string replacement requests, kills them X* X*----------------------------------------------------------------------- X include 'PARAM.h' X include 'KEYCOM.h' X* X*--- loop over OR-sets (first OR-set is for global commands) X*--- loop over commands in OR-set X DO 30 ICOM=1,NGLSET X*--- loop over strings behind names X DO 10 JNAM=KEYREF(ICOM,5)+1,KEYREF(ICOM,5)+KEYREF(ICOM,4) X CALL INDECZ(KNAMRF(JNAM,1),KNAMRF(JNAM,2)) X 10 CONTINUE X*--- loop over stand-alone strings X DO 20 JSTR=KEYREF(ICOM,7)+1,KEYREF(ICOM,7)+KEYREF(ICOM,6) X CALL INDECZ(KSTREF(JSTR,1),KSTREF(JSTR,2)) X 20 CONTINUE X 30 CONTINUE X END / echo 'x - ISBIT.f' sed 's/^X//' > ISBIT.f << '/' X SUBROUTINE ISBIT(N,I) X*----------------------------------------------------------------------- X* X* Sets the bit I ( 0 < I < 26) in word N , rightmost = 1 . X* Bits can be tested with ITBIT. X* X*----------------------------------------------------------------------- X DIMENSION NP(26) X SAVE IFIRST X DATA IFIRST/0/ X IF(IFIRST.EQ.0) THEN X IFIRST=1 X NP(1)=1 X DO 10 J=2,26 X NP(J)=2*NP(J-1) X 10 CONTINUE X ENDIF X IF(I.GT.0.AND.I.LE.25) THEN X IF (ITBIT(N,I).EQ.0) N=N+NP(I) X ENDIF X END / echo 'x - ITBIT.f' sed 's/^X//' > ITBIT.f << '/' X FUNCTION ITBIT(N,I) X*----------------------------------------------------------------------- X* X* Tests bit I ( 0 < I < 26) in word N , rightmost = 1 . X* X*----------------------------------------------------------------------- X DIMENSION NP(26) X SAVE IFIRST X DATA IFIRST/0/ X IF(IFIRST.EQ.0) THEN X IFIRST=1 X NP(1)=1 X DO 10 J=2,26 X NP(J)=2*NP(J-1) X 10 CONTINUE X ENDIF X IF(I.GT.0.AND.I.LE.25) THEN X ITBIT=MOD(N,NP(I+1))/NP(I) X ELSE X ITBIT=0 X ENDIF X END / echo 'x - JOBSUM.h' sed 's/^X//' > JOBSUM.h << '/' X COMMON/JOBSUM/TIME1,TIME2,NSTATC(10),NFDCLS(MXSTAT,2) X*IF DEF,NEVER X*----------------------------------------------------------------------- X* contains the statistical information X* TIME1 starting time in seconds X* TIME2 ending - - X* NSTATC overall statistical information X* 1 = # of lines read X* 2 = # of lines written to output file X* 3 = # of statements read X* 4 = # of statements after filters X* 5 = # of statements changed X* 6 = # of lines unable to change (length overflow) X* 7 = # of comment lines (including blank lines) X* 8 = # of lines printed X* NFDCLS no. of times internal class found X* (I,1) normal, (I,2) behind logical IF X*----------------------------------------------------------------------- X*EI / echo 'x - LASTNB.f' sed 's/^X//' > LASTNB.f << '/' X FUNCTION LASTNB(STRING,KFCH,KLCH) X*----------------------------------------------------------------------- X* X* Returns as function value the position of the last non-blank in string X* 'STRING' between KFCH and KLCH. X* This value is KFCH-1 if STRING consists of blanks only. X* X*----------------------------------------------------------------------- X CHARACTER *(*) STRING X LASTNB=KFCH-1 X DO 10 I=KLCH,KFCH,-1 X IF(STRING(I:I).NE.' ') THEN X LASTNB=I X GOTO 999 X ENDIF X 10 CONTINUE X 999 END / echo 'x - LEXARS.f' sed 's/^X//' > LEXARS.f << '/' X LOGICAL FUNCTION LEXARS(NNAM) X*----------------------------------------------------------------------- X* X*--- returns TRUE if name NNAM in current statement is both in an X* EXTERNAL statement, and is passed as an argument X*---Input X* NNAM position of name in current statement list X*----------------------------------------------------------------------- X include 'PARAM.h' X include 'ALCAZA.h' X include 'TREECOM.h' X include 'STATE.h' X include 'CURSTA.h' X CHARACTER STEMP*1 X LEXARS=.FALSE. X IF(NSEND(NNAM).LT.NCHST.AND.NNAM.GT.1) THEN X DO 10 I=1,NEXEL X IF(SNAMES(ISNAME+NNAM).EQ.SEXEL(I)) GOTO 20 X 10 CONTINUE X GOTO 999 X 20 CONTINUE X K=NSEND(NNAM) X STEMP=SSTA(K+1:K+1) X IF(STEMP.EQ.' ') THEN X STEMP=SSTA(K+2:K+2) X ENDIF X LEXARS=STEMP.NE.'(' X ENDIF X 999 END / echo 'x - LSORT.f' sed 's/^X//' > LSORT.f << '/' X SUBROUTINE LSORT(SLIST,NACC,FLACC,NS) X*----------------------------------------------------------------------- X* X*--- sorts a list in itself alphabetically, updates NACC X* X*--- input X* SLIST list containing all names X* NACC array to be re-arranged with sort X* FLACC if true, NACC is actually updated X* NS # of elements X*----------------------------------------------------------------------- X include 'PARAM.h' X CHARACTER *(MXNMCH) SLIST(*),SLOC X DIMENSION NACC(*) X LOGICAL ENDFL,FLACC X IF(NS.GT.1) THEN X 10 CONTINUE X ENDFL=.TRUE. X DO 20 I=2,NS X IF (SLIST(I-1).GT.SLIST(I)) THEN X ENDFL=.FALSE. X SLOC=SLIST(I-1) X SLIST(I-1)=SLIST(I) X SLIST(I)=SLOC X IF(FLACC) THEN X NLOC=NACC(I-1) X NACC(I-1)=NACC(I) X NACC(I)=NLOC X ENDIF X ENDIF X 20 CONTINUE X IF (.NOT.ENDFL) GOTO 10 X ENDIF X END / echo 'x - NAMSRC.f' sed 's/^X//' > NAMSRC.f << '/' X SUBROUTINE NAMSRC(SNAME,SLIST,NLIST,IPOS,LAST) X*----------------------------------------------------------------------- X* X* finds name in alphabetic table (binary search). X* X* Input X* SNAME name to be looked up X* SLIST table X* NLIST length of table X* X* Output X* IPOS = 0: name not in table X* > 0: position in table X* LAST for IPOS=0, position behind which name belongs X* X*----------------------------------------------------------------------- X CHARACTER *(*) SNAME,SLIST(*) X IPOS=0 X LAST=0 X N=NLIST X IF(N.GT.0) THEN X KPOS=0 X 10 M=(N+1)/2 X LAST=KPOS+M X IF (SNAME.LT.SLIST(LAST)) THEN X N=M X LAST=LAST-1 X IF (N.GT.1) GOTO 10 X ELSEIF (SNAME.GT.SLIST(LAST)) THEN X KPOS=LAST X N=N-M X IF (N.GT.0) GOTO 10 X ELSE X IPOS=LAST X ENDIF X ENDIF X END / echo 'x - NEXTIN.f' sed 's/^X//' > NEXTIN.f << '/' X FUNCTION NEXTIN(STRING,KFCH,KLCH) X*----------------------------------------------------------------------- X* X* returns as function value the integer extracted from string X* 'STRING' between KFCH and KLCH, by ignoring all non-numeric X* characters. default value is therefore 0. X* X*----------------------------------------------------------------------- X include 'PARAM.h' X CHARACTER *(*) STRING X include 'CONVEX.h' X N=0 X*--- convert external zero into internal X NZERO=ICVAL('0') X*--- construct integer X DO 10 J=KFCH,KLCH X I=ICVAL(STRING(J:J))-NZERO X IF (I.GE.0.AND.I.LE.9) N=10*N+I X 10 CONTINUE X NEXTIN=N X END / echo 'x - NLBLPS.f' sed 's/^X//' > NLBLPS.f << '/' X FUNCTION NLBLPS(STRING,KFCH,KLCH) X*----------------------------------------------------------------------- X* X* returns as function value the position of the last blank in string X* 'STRING' between KFCH and KLCH. X* This value is KFCH-1 if the first character is not blank. X* X*----------------------------------------------------------------------- X CHARACTER *(*) STRING X NLBLPS=KFCH-1 X DO 10 I=KFCH,KLCH X IF (STRING(I:I).NE.' ') GOTO 20 X NLBLPS=I X 10 CONTINUE X 20 CONTINUE X END / echo 'x - OPPREC.h' sed 's/^X//' > OPPREC.h << '/' X PARAMETER (LOPS=23) X INTEGER ILEFP(LOPS),IRITP(LOPS),ILENO(LOPS) X CHARACTER*(LOPER) COPER(LOPS) X DATA COPER /'** ','* ','/ ','+ ','- ','// ', X & '.LT. ','.GT. ','.LE. ','.GE. ','.EQ. ','.NE. ', X & '.NOT. ','.AND. ','.OR. ','.EQV. ','.NEQV.',': ', X & ', ','= ','( ',') ','END '/ X DATA ILENO /2,1,1,1,1,2,4,4,4,4,4,4,5,5,4,5,6,1,1,1,1,1,3/ XC left precedence of operators X DATA ILEFP /17 ,16 ,16 ,15 ,15 ,14 , X & 13 ,13 ,13 ,13 ,13 ,13 , X & 12 ,11 ,10 ,9 ,9 ,7 , X & 6 ,3 ,4 ,-1 ,2 / XC right precedence of operators X DATA IRITP /18 ,16 ,16 ,15 ,15 ,14 , X & 13 ,13 ,13 ,13 ,13 ,13 , X & 12 ,11 ,10 ,9 ,9 ,7 , X & 6 ,3 ,20 ,4 ,2 / / echo 'x - PUTOPA.f' sed 's/^X//' > PUTOPA.f << '/' X SUBROUTINE PUTOPA(SNAME,STYP,ICHR,ICHRE,IERR) XC! Put an operand on the stack. X include 'STACK.h' X CHARACTER*(*) SNAME,STYP X NLEVL = NLEVL+1 X IF(NLEVL.GT.MLEVL) GOTO 900 X CTYP(NLEVL)(:LCTYP) = STYP(:LCTYP) X LSN = MAX(0,INDEX(SNAME,' ')-1) X LOPD(NLEVL) = MIN(LSN,LCOPD) X COPD(NLEVL)(:LOPD(NLEVL)) = SNAME(:LOPD(NLEVL)) X COPT(NLEVL) = ' ' X IPOS(NLEVL) = 0 X IERR = 0 X GOTO 999 X 900 IERR = NLEVL X 999 CONTINUE X RETURN X END / echo 'x - PUTOUT.f' sed 's/^X//' > PUTOUT.f << '/' X SUBROUTINE PUTOUT X*----------------------------------------------------------------------- X* X* Writes the FORTRAN code output file X* X*----------------------------------------------------------------------- X include 'PARAM.h' X include 'ALCAZA.h' X include 'FLAGS.h' X include 'STATE.h' X include 'JOBSUM.h' X LOGICAL OUTFL X DO 20 I=1,NSTAMM X OUTFL=ACTION(7).AND.IMODIF(I).GT.10.OR.ACTION(8).AND.IMODIF(I). X + GT.0.OR.ACTION(9) X IF (OUTFL) THEN X DO 10 J=NFLINE(I),NLLINE(I) X IF(ACTION(23)) THEN X*--- compressed output = only up to last non-blank written X NUP=LASTNB(SIMA(J),2,MXLINE) X ELSE X NUP=MXLINE X ENDIF X WRITE (MOUNIT,'(A)') SIMA(J)(:NUP) X NSTATC(2)=NSTATC(2)+1 X 10 CONTINUE X ENDIF X 20 CONTINUE X END / echo 'x - RANGE.f' sed 's/^X//' > RANGE.f << '/' X LOGICAL FUNCTION RANGE(NUMBER,IARRAY) X*----------------------------------------------------------------------- X* X* Purpose: returns 'TRUE' if NUMBER is contained in ranges given X* in IARRAY. X* X* Input: NUMBER number to check X* IARRAY array containing ranges in the following way: X* word 1 = no. of ranges X* word 2 = lower limit, range 1 X* word 3 = upper limit, range 1 etc. X* X* Author : HG date: 4.6.84 last revision: 4.6.84 X*----------------------------------------------------------------------- X DIMENSION IARRAY(*) X RANGE=.FALSE. X DO 10 I=1,IARRAY(1) X IF (NUMBER.GE.IARRAY(2*I).AND.NUMBER.LE.IARRAY(2*I+1)) THEN X RANGE=.TRUE. X GOTO 999 X ENDIF X 10 CONTINUE X 999 END / echo 'x - SAMEST.f' sed 's/^X//' > SAMEST.f << '/' X LOGICAL FUNCTION SAMEST(IST) X*----------------------------------------------------------------------- X* X* Compares statement IST in SIMA with the new image SNEWST, returns X* .TRUE. if they are identical. X* X*----------------------------------------------------------------------- X include 'PARAM.h' X include 'ALCAZA.h' X include 'STATE.h' X include 'CURSTA.h' X SAMEST=.FALSE. X N=0 X DO 10 I=NFLINE(IST),NLLINE(IST) X IF(NLTYPE(I).NE.0) N=N+1 X 10 CONTINUE X IF(N.NE.NEWOUT) GOTO 999 X N=0 X DO 20 I=NFLINE(IST),NLLINE(IST) X IF(NLTYPE(I).NE.0) THEN X N=N+1 X IF(SNEWST(N)(:72).NE.SIMA(I)(:72)) GOTO 999 X ENDIF X 20 CONTINUE X SAMEST=.TRUE. X 999 END / echo 'x - SETREQ.f' sed 's/^X//' > SETREQ.f << '/' X SUBROUTINE SETREQ X END / echo 'x - SORTSP.f' sed 's/^X//' > SORTSP.f << '/' X SUBROUTINE SORTSP(N1,IARR,N2) X*----------------------------------------------------------------------- X* Sorts integers, suppresses multiple occurrences X* Input X* N1 = no. of integers X* Input/Output X* IARR = array containing integers X* Output X* N2 = new number of integers X*----------------------------------------------------------------------- X DIMENSION IARR(*) X 10 CONTINUE X IND=0 X DO 20 J=2,N1 X IF (IARR(J).LT.IARR(J-1)) THEN X K=IARR(J) X IARR(J)=IARR(J-1) X IARR(J-1)=K X IND=1 X ENDIF X 20 CONTINUE X IF (IND.NE.0) GOTO 10 X N2=MIN(N1,1) X DO 30 J=2,N1 X IF (IARR(J).GT.IARR(J-1)) THEN X N2=N2+1 X IARR(N2)=IARR(J) X ENDIF X 30 CONTINUE X END / echo 'x - SPERUL.f' sed 's/^X//' > SPERUL.f << '/' X SUBROUTINE SPERUL X include 'PARAM.h' X include 'CHECKS.h' X include 'USUNIT.h' X CHARACTER*3 CDEF,CTMP X WRITE(MPUNIT,100) MCHEKS X 100 FORMAT(//,1X,'Interactive Specification of Rules to Check', X & /,1X,'-------------------------------------------', X & /,1X,'A maximum of ',I5,' rules may be checked', X & /,1X,'Answer YES or NO for each rule') X DO 1 IRULE=1,MCHEKS X IF(CCHECK(IRULE)(:4).EQ.'$$$$') GOTO 1 X WRITE(MPUNIT,'(A,A)') ' ',CCHECK(IRULE) X CDEF = 'NO ' X IF(LCHECK(IRULE)) CDEF = 'YES' X WRITE(MPUNIT,'(A,A,A)') ' Check this rule ? [CR=',CDEF,']' X READ(MSUNIT,'(A)',END=1,ERR=1) CTMP X IF(CTMP(1:1).EQ.'y'.OR.CTMP(1:1).EQ.'Y') LCHECK(IRULE)=.TRUE. X IF(CTMP(1:1).EQ.'n'.OR.CTMP(1:1).EQ.'N') LCHECK(IRULE)=.FALSE. X IF(CTMP(1:1).EQ.' '.AND.CDEF.EQ.'YES') LCHECK(IRULE)=.TRUE. X IF(CTMP(1:1).EQ.' '.AND.CDEF.EQ.'NO ') LCHECK(IRULE)=.FALSE. X 1 CONTINUE X RETURN X END / echo 'x - STACK.h' sed 's/^X//' > STACK.h << '/' X PARAMETER (MLEVL=100,LCTYP=1,LCOPD=512,LOPER=6) X COMMON /STACK/ CTYP(MLEVL),COPD(MLEVL),COPT(MLEVL) X COMMON /STACK1/NLEVL,IPOP(MLEVL),IPOS(MLEVL),LOPD(MLEVL) X CHARACTER*(LCTYP) CTYP X CHARACTER*(LCOPD) COPD X CHARACTER*(LOPER) COPT / echo 'x - TREECOM.h' sed 's/^X//' > TREECOM.h << '/' X COMMON/STREE/CALLER(KENT),CALLED(KALL) ,CERARG(KENT), X +CEDARG(KALL),KODE(KENT),SARGEL(NOARG),SEXEL(KALL) X CHARACTER CALLER*(MXNMCH),CALLED* (MXNMCH),CERARG*(NOARG), X +CEDARG*(NOARG),KODE*1,SARGEL*(MXNMCH),SEXEL*(MXNMCH) X COMMON/TREE/NCALLR,NCALLD,NARGEL,NEXEL,ICALLR(KENT) X*IF DEF,NEVER X*----------------------------------------------------------------------- X* X* CALLER calling routiine, or entry in it X* CALLED called routine or function X* CERARG argument types of caller X* CEDARG argument types of called X* KODE type of caller or entry (S/R = blank) X* SARGEL list of routine (dummy) arguments X* SEXEL list of names in EXTERNAL X* NCALLR # of callers in this routine X* NCALLD # of called in this routine X* ICALLR statement number of CALL X*----------------------------------------------------------------------- X*EI / echo 'x - URINIT.f' sed 's/^X//' > URINIT.f << '/' X SUBROUTINE URINIT X*----------------------------------------------------------------------- X* X*--- user routine initialization X* X*----------------------------------------------------------------------- X include 'PARAM.h' X include 'ALCAZA.h' X include 'CLASS.h' X include 'CURSTA.h' X include 'FLWORK.h' X include 'KEYCOM.h' X include 'TYPDEF.h' X include 'JOBSUM.h' X include 'STATE.h' X include 'FLAGS.h' X include 'USARGS.h' X CMMNT = ' ' X END / echo 'x - USARGS.h' sed 's/^X//' > USARGS.h << '/' X PARAMETER (MARGS=50,MARGD=10,MKALL=50,LARC=50) X COMMON /USARGS/ NARGS,CARGNM(MARGS),CARGTY(MARGS), NARGDI(MARGS), X +CARGDI(MARGD,2,MARGS) X COMMON /USCOMM/ CMMNT X COMMON /USCALL/ NKALL,CKALLN(MKALL),KALLIF(MKALL),KALLDO(MKALL) X CHARACTER*(MXNMCH) CARGNM,CKALLN X CHARACTER*(LARC) CARGTY,CARGDI,CMMNT / echo 'x - USCOMN.h' sed 's/^X//' > USCOMN.h << '/' X PARAMETER (MCOMN=500,MCOMT=50) X COMMON /USCOMN/ NCOMN,NCOMT, SCNAME(MCOMN),SCTITL(MCOMT), ICNAME X +(MCOMN),ICTITL(MCOMT) X CHARACTER SCNAME*(MXNMCH),SCTITL*(MXNMCH) / echo 'x - USGCOM.h' sed 's/^X//' > USGCOM.h << '/' X PARAMETER (MGCON=2000,MGCOT=200) X COMMON /USGCOM/ NGCON,NGCOT, SGCNAM(MGCON),SGCTIT(MGCOT), IGCNAM X +(MGCON),IGCTIT(MGCOT) X CHARACTER SGCNAM*(MXNMCH),SGCTIT*(MXNMCH) / echo 'x - USIGNO.h' sed 's/^X//' > USIGNO.h << '/' X PARAMETER (MXIGNV=50,MXIGNS=50,MUUNIT=15) X COMMON /USIGNO/ GALEPH,ADAMO,USAGE,UNFLP, X & NIGNOR,NIGNOS, X & CIGNOR(MXIGNV),LIGNOR(MXIGNS), X & CIGNOS(MXIGNS),LIGNOS(MXIGNS) X CHARACTER*(MXNMCH) CIGNOR,CIGNOS X LOGICAL GALEPH,ADAMO,USAGE,UNFLP / echo 'x - USINFN.h' sed 's/^X//' > USINFN.h << '/' X PARAMETER (LIF=109) X COMMON /USINFN/ INFUNG(LIF),CINFUN(LIF),CTYFUN(LIF) X CHARACTER*6 CINFUN X CHARACTER*1 CTYFUN / echo 'x - USLIST.h' sed 's/^X//' > USLIST.h << '/' X COMMON /USLIST/ USFULL X LOGICAL USFULL / echo 'x - USLTYD.h' sed 's/^X//' > USLTYD.h << '/' X LOGICAL LFUNCT,LNSVT,LCOMMN,LDIMEN,LELSE,LGOTO,LPRINT X LOGICAL LIFF,LWRITE,LPAUSE,LSTOP,LENTRY,LIO,LRETRN X LOGICAL LMODUS,LCHARC,LDECLR,LDATA,LASIGN,LMODUL,LSAVE / echo 'x - USSALL.f' sed 's/^X//' > USSALL.f << '/' X SUBROUTINE USSALL X*----------------------------------------------------------------------- X* X*--- user start of each statement (including comments and illegal) X* X*----------------------------------------------------------------------- X include 'PARAM.h' X include 'ALCAZA.h' X include 'CLASS.h' X include 'CURSTA.h' X include 'FLWORK.h' X include 'KEYCOM.h' X include 'TYPDEF.h' X include 'JOBSUM.h' X include 'STATE.h' X include 'FLAGS.h' X END / echo 'x - USSEND.f' sed 's/^X//' > USSEND.f << '/' X SUBROUTINE USSEND X*----------------------------------------------------------------------- X* X*--- user end of filtered statement X* X*----------------------------------------------------------------------- X include 'PARAM.h' X include 'ALCAZA.h' X include 'CLASS.h' X include 'CURSTA.h' X include 'FLWORK.h' X include 'KEYCOM.h' X include 'TYPDEF.h' X include 'JOBSUM.h' X include 'STATE.h' X include 'FLAGS.h' X END / echo 'x - USSTMT.h' sed 's/^X//' > USSTMT.h << '/' X COMMON /USSTMT/ ISGLOB,ICLOLD,NFIOLD,NFAULT,RPROCS X LOGICAL RPROCS / echo 'x - USUNIT.h' sed 's/^X//' > USUNIT.h << '/' X PARAMETER (MZUNIT=99,MJUNIT=50,MSUNIT=55) / echo 'x - btest.f' sed 's/^X//' > btest.f << '/' X logical function btest(n,i) X btest = .false. X if(itbit(n,i+1).ne.0) btest = .true. X end / echo 'x - ior.f' sed 's/^X//' > ior.f << '/' X integer function ior(i,j) X ior = or(i,j) X end / echo 'Part 11 of Floppy complete.' exit