Usenet 1994 January

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

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

Wrap

Text File | 1990-05-14 | 47.2 KB | 1,301 lines

Newsgroups: comp.sources.misc organization: CERN, Geneva, Switzerland keywords: fortran subject: v12i094: Floppy - Fortran Coding Convention Checker Part 08/11 from: julian@cernvax.cern.ch (julian bunn) Sender: allbery@uunet.UU.NET (Brandon S. Allbery - comp.sources.misc) Posting-number: Volume 12, Issue 94 Submitted-by: julian@cernvax.cern.ch (julian bunn) Archive-name: ffccc/part08 #!/bin/sh echo 'Start of Floppy, part 08 of 11:' echo 'x - ARGTYP.f' sed 's/^X//' > ARGTYP.f << '/' X SUBROUTINE ARGTYP(STRING,CALLFL,I1,I2,ARG) X*----------------------------------------------------------------------- X* X*--- returns a list of argument types X*--- input X* STRING(I1:I2) = '(...)' argument list X* CALLFL = .TRUE. if argument list of a caller, else .FALSE. X*--- output X* ARG character variable, 1 ch./argument X* 'I' = integer X* 'R' = real X* 'D' = double prec. X* 'K' = complex X* 'C' = character X* 'L' = logical X* 'P' = procedure (subroutine or function passed) X* '*' = alternate ret. X* '$' = not determined X* X* the rest is blank. X*----------------------------------------------------------------------- X include 'PARAM.h' X include 'ALCAZA.h' X include 'CONDEC.h' X include 'STATE.h' X CHARACTER STRING*(*),ARG*(*),STYP*1, STEMP*1,SNAME*(MXNMCH), X +ATYP*7 X LOGICAL BRNONE,CALLFL X DATA ATYP/'IRLKDC$'/ X include 'CONDAT.h' X KPOS=I1 X N=0 X 10 CONTINUE X IPT=KPOS X*--- find end of each argument X CALL POSCH(',',STRING,IPT+1,I2, .FALSE.,0,KPOS,ILEV) X IF(KPOS.EQ.0) KPOS=I2 X N=N+1 X STEMP=STRING(IPT+1:IPT+1) X IF(STEMP.EQ.' ') THEN X IPT=IPT+1 X STEMP=STRING(IPT+1:IPT+1) X ENDIF X IF(STEMP.EQ.'*') THEN X ARG(N:N)='*' X ELSE X IF(STEMP.EQ.'+'.OR.STEMP.EQ.'-') THEN X IPT=IPT+1 X STEMP=STRING(IPT+1:IPT+1) X IF(STEMP.EQ.' ') THEN X IPT=IPT+1 X STEMP=STRING(IPT+1:IPT+1) X ENDIF X ENDIF X IF(INDEX('0123456789(.{',STEMP).NE.0) THEN X CALL GETCON(STRING,IPT+1,KPOS,KLCH,STYP) X IF(KLCH.EQ.0) GOTO 60 X IF(KLCH+1.EQ.KPOS.OR.(KLCH+2.EQ.KPOS .AND.STRING(KLCH+1:KLCH X + +1).EQ.' ' )) THEN X*--- argument is a simple constant X ARG(N:N)=STYP X ELSE X GOTO 60 X ENDIF X ELSEIF(ALPHCH(STEMP)) THEN X CALL GETNAM(STRING,IPT+1,KPOS,KFCH, KNAM) X KLCH=KNAM X STEMP=STRING(KLCH+1:KLCH+1) X IF(STEMP.EQ.' ') THEN X KLCH=KLCH+1 X STEMP=STRING(KLCH+1:KLCH+1) X ENDIF X IF(STEMP.EQ.'(') THEN X*--- check for dimensioned variable, or function X CALL SKIPLV(STRING,KLCH+2,KPOS, .FALSE.,KLCH,ILEV) X STEMP=STRING(KLCH+1:KLCH+1) X IF(STEMP.EQ.' ') THEN X KLCH=KLCH+1 X STEMP=STRING(KLCH+1:KLCH+1) X ENDIF X BRNONE=.FALSE. X ELSE X BRNONE=.TRUE. X ENDIF X IF(KLCH+1.EQ.KPOS) THEN X*--- simple argument X SNAME=' ' X CALL GETNBL(STRING(KFCH:KNAM),SNAME, NN) X DO 20 IPOS=1,NSNAME X IF(SNAME.EQ.SNAMES(ISNAME+IPOS)) GOTO 30 X 20 CONTINUE X GOTO 60 X 30 CONTINUE X NT=NAMTYP(ISNAME+IPOS) X IF(BRNONE.AND. (CALLFL.AND.(ITBIT(NT,15).NE.0.OR.ITBIT X + (NT,17).NE.0) .OR.(.NOT.CALLFL.AND.ITBIT(NT,12).NE.0))) X + THEN X*--- subroutine or function passed as argument X ARG(N:N)='P' X ELSE X DO 40 I=1,6 X K=NT/2 X IF(NT-2*K.GT.0) GOTO 50 X NT=K X 40 CONTINUE X 50 CONTINUE X ARG(N:N)=ATYP(I:I) X ENDIF X ELSE X GOTO 60 X ENDIF X ELSE X GOTO 60 X ENDIF X ENDIF X GOTO 70 X 60 CONTINUE X ARG(N:N)=ATYP(7:7) X 70 CONTINUE X IF(KPOS.LT.I2) GOTO 10 X 999 END / echo 'x - CHKOBS.f' sed 's/^X//' > CHKOBS.f << '/' X SUBROUTINE CHKOBS(CNAME,IWARN) XC XC Check that input CNAME (subroutine or function name) is XC not contained in list of obsolete CERN program library XC routines. If it is, set IWARN > 0, otherwise = 0. XC XC JJB march 86 XC X PARAMETER (LOBSO=176,LOBS1=90) X CHARACTER*6 COBSOL(LOBSO) X CHARACTER*(*) CNAME XC XC 'LOBSO' OBSOLETE PROGRAM LIBRARY ROUTINES FOR FLOPPY CHECKS. XC FROM CNL-180 AND LIST (B101,D114,F106,G112,G903,Z035,Z041,Z203, XC C327/330,E402/405) XC X DATA (COBSOL(I),I=1,LOBS1) / 'ABEND ','AFROMI','ATG ','BESIN ', X +'BESJN ', 'BITBYT','CBYT ','CCMAD ','CCMAD1','CCMAD2', 'CCMAD3', X +'CCMPY ','CCMPY1','CCMPY2','CCMPY3', 'CCMUB ','CCMUB1','CCMUB2', X +'CCMUB3','CHCOF1', 'CHECOF','CHMOVE','CHSUM1','CHSUM2','CMXPAK', X +'CRMAD ','CRMAD1','CRMAD2','CRMAD3','CRMPY ', 'CRMPY1','CRMPY2', X +'CRMPY3','CRMUB ','CRMUB1', 'CRMUB2','CRMUB3','DBESIN','DBESJN', X +'DIGITN', 'DOTI ','FLOARG','FUNLAN','GENLAN','GETSST', 'HIST ', X +'IDENZB','IDIGIT','IFROMA','INTARG', 'IOFMAS','IUBACK','IUEND ', X +'IUFORW','IULOOK', 'IUMODE','IUNEXT','JBIT ','JBYT ','JBYTET', X +'JRSBYT','LINEQ1','LINEQ2','LOCF ','LOCHAR', 'MATIN1','MATIN2', X +'MXEQU ','MXEQU1','MXMAD ', 'MXMAD1','MXMAD2','MXMAD3','MXMLRT', X +'MXMLTR', 'MXMPY ','MXMPY1','MXMPY2','MXMPY3','MXMUB ', 'MXMUB1', X +'MXMUB2','MXMUB3','MXTRP ','MXUTY ', 'NOARG ','PKCHAR','QNEXTE', X +'RANNOR','RCMAD '/ X DATA (COBSOL(I),I=LOBS1+1,LOBSO) / 'RCMAD1','RCMAD2','RCMAD3', X +'RCMPY ','RCMPY1', 'RCMPY2','RCMPY3','RCMUB ','RCMUB1','RCMUB2', X +'RCMUB3','RIWIAD','RRMAD ','RRMAD1','RRMAD2', 'RRMAD3','RRMPY ', X +'RRMPY1','RRMPY2','RRMPY2', 'RRMPY3','RRMUB ','RRMUB1','RRMUB2', X +'RRMUB3', 'SBIT ','SBIT0 ','SBIT1 ','SBYT ','SBYTOR', 'SETFMT', X +'SMXINV','SORTX ','STAP ','SYMINV', 'TLERR ','TLRES ','TLS ', X +'TLSC ','TRAAT ', 'TRAL ','TRALT ','TRAS ','TRASAT','TRATA ', X +'TRATS ','TRATSA','TRCHLU','TRCHUL','TRINV ', 'TRLA ','TRLTA ', X +'TRPCK ','TRQSQ ','TRSA ', 'TRSAT ','TRSINV','TRSMLU','TRSMUL', X +'TRUPCK', 'UBITS ','UBLANK','UBLOW ','UBLOW1','UBNCH1', 'UBUNCH', X +'UCOPIV','UCOPY2','UCTOH ','UCTOH1', 'UFILL ','UFLINT','UHOLLR', X +'UHTOC ','UHTOC1', 'ULEFT ','UOPT ','UPKCH ','URIGHT','USET ', X +'USWOP ','UTRANS','UZERO ','VBLANK','VOMAS ', 'XINOUT'/ X IWARN = 0 XC----------------------------------------------------------------------- XC AFTER M.METCALF NAMSCH16 XC-----------------------------------------------------------------------NAMSCH17 X IPOS=0 NAMSCH19 X LAST=0 NAMSCH20 X N=LOBSO NAMSCH21 X IF(N.GT.0) THEN NAMSCH22 X KPOS=0 X 5 M=(N+1)/2 X LAST=KPOS+M X IF (CNAME.LT.COBSOL(LAST)) THEN X N=M X LAST=LAST-1 X IF (N.GT.1) GOTO 5 X ELSEIF (CNAME.GT.COBSOL(LAST)) THEN X KPOS=LAST X N=N-M X IF (N.GT.0) GOTO 5 X ELSE X IWARN=LAST X ENDIF X ENDIF NAMSCH37 X RETURN X END / echo 'x - CLASS.h' sed 's/^X//' > CLASS.h << '/' X COMMON /CLASS/NCLASS,NPRIOR,NHEADR,IIF,IEND,IFORMT,IRETUR,ILL, X + ISTMDS(MCLASS,MXSTAT),IALPHA(2,27),IPRIOR(MXSTAT),IHEADR(MXSTAT) X*IF DEF,NEVER X*----------------------------------------------------------------------- X*--- contains statement classification information X* NCLASS no. of (internal) classes X* NPRIOR no. of priority statements X* NHEADR no. of header statements X* IIF internal number of the logical IF X* IEND internal number of END statement X* IFORMT internal number of the FORMAT statement X* ILL - - - illegal - X* ISTMDS(MCLASS,MXSTAT) control words being X* 1 = first ch. in SNAM X* 2 = last ch. in SNAM X* 3 = first ch. in SSTM X* 4 = last ch. in SSTM X* 5 = last significant ch. in SSTM X* 6 = external reference number ( class ) X* 7 = priority ( if 0, any order) X* 8 = char. in descr. after which to start name X* scan. if 99, start after match string. X* 9 = stop name scan at stmt. end X* 10 = statement number classifier, being X* 0 if statement cannot contain stmt. numbers X* 1 if (one) stmt. number must follow key immed. X* 2 if all stmt. no.s are inside first bracket X* 3 if all stmt. no.s follow immed. first bracket X* 4 if (one) after FMT=, or second in first br. X* 11 = exec flag ( 0 = non-executable) X* 12 = names flag ( 0 = no names, 1 = one, 2 = any) X* 13 = special treatement flag ( if 1) +2 * smflag X* where smflag = 1 allows for simple keyword match X* 14 = routine header flag (0 no, 1 yes) X* 15 = type flag: X* 0 if types valid for all names X* 1 if separate types for first name + rest X* 2 if special treatment (IMPLICIT) X* to this, 10 is added if only names outside X* brackets to be taken, +10 for COMMON X* 16 = n1 = no. of types for first or all X* 17 to 16 + n1 = types X* 17 + n1 = n2 X* 18 + n1 to 21 = types for rest (0 filled) X* IALPHA(2,27) for letters 1 to 26 (A to Z), X* first and last class under that letter. X* ( keys are in alphabetic order) X* 27 for those not starting with any key. X* if not specified otherwise, those will be X* processed last X* IPRIOR(MXSTAT) refs of priority statements X* IHEADR(MXSTAT) refs of header statements X*----------------------------------------------------------------------- X*EI / echo 'x - CLASSF.f' sed 's/^X//' > CLASSF.f << '/' X SUBROUTINE CLASSF X*----------------------------------------------------------------------- X* X*--- classifies a FORTRAN statement. X* X*--- input X* SSTA string containing the statement X* NCHST last ch. of statement in SSTA X* SSTM (,ISTMDS,IALPHA,IPRIOR,IHEADR) statement descriptors X*--- output X* ICURCL = statement numbers of first part and second part X* ( ICURCL(2) set for ICURCL(1) = IIF = logical IF, else = ILL) X* ICURCL(1) = ILL for illegal statements X* X*----------------------------------------------------------------------- X include 'PARAM.h' X include 'ALCAZA.h' X include 'CLASS.h' X include 'FLAGS.h' X include 'FLWORK.h' X include 'CURSTA.h' X CHARACTER STEMP*1,STRING*25 X include 'CONVEX.h' X ICURCL(1)=ILL X ICURCL(2)=ILL X*--- if illegal during extraction (EXTRAC), return X IF (STATUS(3)) GOTO 999 X KSTART=1 X*--- loop over (possibly) two parts of statement X DO 50 IPRTS=1,2 X KPOS=0 X 10 STEMP=SSTA(KSTART:) X IF (STEMP.EQ.' ') THEN X*--- skip blanks X KSTART=KSTART+1 X GOTO 10 X ENDIF X*--- check priority statements first if '=' present X IF(INDEX(SSTA(KSTART:NCHST),'=').NE.0) THEN X DO 20 JS=1,NPRIOR X JSS=IPRIOR(JS) X CALL MATCH(SSTM,ISTMDS(3,JSS),ISTMDS(4,JSS),SSTA,KSTART, X + NCHST,.FALSE.,KPOS,ILEV,NDUMMY,IWS,IWS) X IF (KPOS.NE.0) GOTO 40 X 20 CONTINUE X ENDIF X*--- no match yet - get alphabetic group and compare X IF (ALPHCH(STEMP)) THEN X K=ICVAL(STEMP) X ELSE X K=27 X ENDIF X IF(K.LE.0.OR.K.GT.27) GOTO 999 X*--- KBLP = pos. of first blank after start of keyword, X KBLP=INDEX(SSTA(KSTART:NCHST),' ') X DO 30 JSS=IALPHA(1,K),IALPHA(2,K) X IF (ISTMDS(7,JSS).EQ.0.AND.ISTMDS(3,JSS).NE.0) THEN X IF(ISTMDS(13,JSS).GE.2) THEN X*--- simple match is sufficient X I1=ISTMDS(3,JSS) X I2=ISTMDS(4,JSS) X N1=I2-I1 X N2=N1+1 X IF(KBLP.EQ.0.OR.KBLP.GT.N2) THEN X IF(SSTA(KSTART:KSTART+N1).EQ.SSTM(I1:I2)) KPOS=1 X ELSE X CALL GETNBL(SSTA(KSTART:NCHST),STRING(1:N2),KEXT) X IF(KEXT.GE.N2) THEN X IF(STRING(:N2).EQ.SSTM(I1:I2)) KPOS=1 X ENDIF X ENDIF X ELSE X CALL MATCH(SSTM,ISTMDS(3,JSS),ISTMDS(4,JSS),SSTA, X + KSTART, NCHST,.FALSE.,KPOS,ILEV,NDUMMY,IWS,IWS) X ENDIF X IF (KPOS.NE.0) GOTO 40 X ENDIF X 30 CONTINUE X*--- exit if no match at all X GOTO 999 X 40 CONTINUE X*--- matched X IF (IPRTS.EQ.1) THEN X ICURCL(1)=JSS X IF (ICURCL(1).NE.IIF) GOTO 999 X*--- skip to end of if(...) X KMT=INDEX(SSTA(1:NCHST),'(') X CALL SKIPLV(SSTA,KMT+1,NCHST,.FALSE.,KPOS,ILEV) X KSTART=KPOS+1 X ELSE X*--- second part matched X ICURCL(2)=JSS X ENDIF X 50 CONTINUE X 999 END / echo 'x - FILTER.f' sed 's/^X//' > FILTER.f << '/' X SUBROUTINE FILTER(KEY,NFLAG) X*----------------------------------------------------------------------- X* X* Filters a statement according to user specifications. X* Input: X* KEY = 10 : filter for routines X* = 11 : filter for names X* = 12 : filter for strings X* = 13 : filter for classes X* (see INDECO for input) X* NFLAG STATUS(NFLAG) will be true if accepted, false if not X* at return from FILTER X* Output X* STATUS(NFLAG) X* X*----------------------------------------------------------------------- X include 'PARAM.h' X include 'ALCAZA.h' X include 'CLASS.h' X include 'FLAGS.h' X include 'CURSTA.h' X include 'STATE.h' X include 'KEYCOM.h' X LOGICAL HASHFL X DIMENSION LRL(MXORST) X CHARACTER*1 STEMP X SAVE NRL,LRL X IF (IFILTR.LT.0) THEN X*--- start of routine: reset to overall OR-sets X NRL=NORSET X NRORST=NORSET X DO 10 I=1,NRL X LRL(I)=I X LRORST(I)=I X 10 CONTINUE X ELSEIF (IFILTR.EQ.0) THEN X*--- FILTER called first time for statement: reset to routine OR-set X NRL=NRORST X DO 20 I=1,NRL X LRL(I)=LRORST(I) X 20 CONTINUE X ENDIF X IFILTR=1 X*--- reset counter for new valid OR-sets X NEW=0 X*--- loop over currently valid OR-sets X DO 90 I=1,NRL X IOR=LRL(I) X DO 30 JK=KORCOM(IOR)+1,KORCOM(IOR)+NORCOM(IOR) X*--- check whether key in this OR-set X IF (KEYREF(JK,1).EQ.KEY) GOTO 40 X 30 CONTINUE X*--- key not present - accept OR-set X NEW=NEW+1 X LRL(NEW)=IOR X GOTO 90 X 40 CONTINUE X*--- KEY is present X IF (KEY.EQ.10) THEN X*--- routine name filter X CALL NAMSRC(SCROUT,SKEYLS(KEYREF(JK,5)+1),KEYREF(JK,4),IPOS, X + LAST) X IF (IPOS.GT.0) THEN X*-- name found X NEW=NEW+1 X LRL(NEW)=IOR X ENDIF X ELSEIF (KEY.EQ.11) THEN X*--- names in statement X DO 50 J=1,NSNAME X CALL NAMSRC(SNAMES(ISNAME+J),SKEYLS(KEYREF(JK,5)+1), X + KEYREF(JK,4),IPOS,LAST) X IF (IPOS.GT.0) THEN X NEW=NEW+1 X LRL(NEW)=IOR X GOTO 90 X ENDIF X 50 CONTINUE X ELSEIF (KEY.EQ.12) THEN X*--- string filter X DO 60 J=KEYREF(JK,7)+1,KEYREF(JK,7)+KEYREF(JK,6) X KREF=KSTREF(J,1) X*--- set '#' in front if not there X K1=KKYSTA(KREF) X K2=KKYEND(KREF) X HASHFL=SKYSTR(K1:K1).NE.'#' X IF (HASHFL) THEN X K1=K1-1 X STEMP=SKYSTR(K1:K1) X SKYSTR(K1:K1)='#' X ENDIF X CALL MATCH(SKYSTR,K1,K2,SSTA,1,NCHST,.TRUE.,KPOS,ILEV,N, X + IWS,IWS) X IF (HASHFL) SKYSTR(K1:K1)=STEMP X IF (KPOS.GT.0) THEN X NEW=NEW+1 X LRL(NEW)=IOR X GOTO 90 X ENDIF X 60 CONTINUE X ELSEIF (KEY.EQ.13) THEN X*--- classes X K1=KEYREF(JK,3)+1 X N1=KEYINT(K1) X N2=KEYINT(K1+N1+1) X*--- N1 counts simple classes, N2 those behind logical IF X IF(ICURCL(1).NE.IIF.OR.N2.EQ.0) THEN X DO 70 J=K1+1,K1+N1 X JC=KEYINT(J) X IF (JC.EQ.ISTMDS(6,ICURCL(1)).OR.(ICURCL(1).EQ.IIF.AND X + .JC.EQ.ISTMDS(6,ICURCL(2)))) THEN X NEW=NEW+1 X LRL(NEW)=IOR X GOTO 90 X ENDIF X 70 CONTINUE X ELSE X K1=K1+N1+1 X DO 80 J=K1+1,K1+N2 X IF (KEYINT(J).EQ.ISTMDS(6,ICURCL(2))) THEN X NEW=NEW+1 X LRL(NEW)=IOR X GOTO 90 X ENDIF X 80 CONTINUE X ENDIF X ENDIF X 90 CONTINUE X NRL=NEW X IF(KEY.EQ.10) THEN X*--- set OR-set for routine X NRORST=NRL X DO 100 I=1,NRL X LRORST(I)=LRL(I) X 100 CONTINUE X ENDIF X STATUS(NFLAG)=NRL.GT.0 X END / echo 'x - GETALL.f' sed 's/^X//' > GETALL.f << '/' X SUBROUTINE GETALL X*----------------------------------------------------------------------- X* X*--- gets all names in one statement X* X*--- input X* SSTA statement in /ALCAZA/ X* ICURCL etc. from /CURSTA/ X*--- output X* NSNAME no. of names /STATE/ X* SNAMES(ISNAME+1)...SNAMES(ISNAME+NSNAME) /ALCAZA/ = names X* NSSTRT, NSEND /STATE/ = start and end of each name in SSTA X* X*----------------------------------------------------------------------- X include 'PARAM.h' X include 'ALCAZA.h' X include 'CLASS.h' X include 'FLAGS.h' X include 'CURSTA.h' X include 'STATE.h' X include 'FLWORK.h' X CHARACTER STEMP*1 X NSNAME=0 X IF(ICURCL(1).EQ.ILL) THEN X IUP=0 X ELSEIF(ICURCL(1).EQ.IIF) THEN X IUP=2 X*--- find end of IF(...) X JPT=INDEX(SSTA(:NCHST),'(') X CALL SKIPLV(SSTA,JPT+1,NCHST,.FALSE.,KND,ILEV) X ELSE X IUP=1 X KND=NCHST X ENDIF X DO 30 IPART=1,IUP X IF (IPART.EQ.1) THEN X ILOC=ICURCL(1) X KST=1 X ELSE X ILOC=ICURCL(2) X KST=KND+1 X KND=NCHST X ENDIF X IF (ISTMDS(12,ILOC).NE.0) THEN X*--- this part of the statement may contain names X* prepare key match necessary for name scan X IK=ISTMDS(8,ILOC) X IF (IK.EQ.0) THEN X KMT=KST-1 X ELSEIF (IK.EQ.99) THEN X CALL MATCH(SSTM,ISTMDS(3,ILOC),ISTMDS(4,ILOC),SSTA,KST, X + NCHST,.FALSE.,KMT,ILEV,NDUMMY,IWS,IWS) X ELSE X CALL MATCH(SSTM,ISTMDS(3,ILOC),ISTMDS(3,ILOC)+IK-1,SSTA, X + KST,NCHST,.FALSE.,KMT,ILEV,NDUMMY,IWS,IWS) X ENDIF X IF (MOD(ISTMDS(13,ILOC),2).NE.0) THEN X*--- there are special keys like in READ(UNIT=.., ) etc. X I=INDEX(SSTA(KST:KND),'(')+KST X CALL SKIPLV(SSTA,I,KND,.FALSE.,JRBPOS,ILEV) X ELSE X JRBPOS=0 X ENDIF X*--- set start and end of scan for names X K1=KMT+1 X*--- remove trailing key (THEN) X NTRAIL=0 X DO 10 K2=KND,KST,-1 X IF(SSTA(K2:K2).NE.' ') THEN X NTRAIL=NTRAIL+1 X IF(NTRAIL.GT.ISTMDS(9,ILOC)) GOTO 20 X ENDIF X 10 CONTINUE X 20 CONTINUE X*--- start of name search loop X CALL GETNAM(SSTA,K1,K2,KFCH,KLCH) X IF (KFCH.EQ.0) GOTO 30 X K1=KLCH+1 X IF (K1.LE.K2.AND.KFCH.LE.JRBPOS) THEN X*--- exclude special keys like 'UNIT=' etc. X CALL GETNBL(SSTA(K1:),STEMP,NN) X IF (STEMP.EQ.'='.AND.NN.GT.0) GOTO 20 X ENDIF X IF (ISNAME+NSNAME.GE.MXNAME) CALL ERREX1 X NSNAME=NSNAME+1 X NSSTRT(NSNAME)=KFCH X NSEND(NSNAME)=KLCH X SNAMES(ISNAME+NSNAME)=' ' X CALL GETNBL(SSTA(KFCH:KLCH),SNAMES(ISNAME+NSNAME),NN) X*--- continue if all names to be found X IF (.NOT.(ACTION(10).OR.ISTMDS(12,ILOC).EQ.1)) GOTO 20 X ENDIF X 30 CONTINUE X END / echo 'x - NXITEM.f' sed 's/^X//' > NXITEM.f << '/' X SUBROUTINE NXITEM(STRING,ICC1,ICC2,LAST) X*----------------------------------------------------------------------- X* X* Cuts statement into pieces, one part at a time (called by REFORM) X* X*---Input X* STRING string to be chopped X* ICC1 starting position for next piece X* ICC2 string size X* LAST last ch. position of piece X* X*----------------------------------------------------------------------- X CHARACTER STRING*(*), STEMP*1 X LOGICAL NUFL,DEFL X include 'CONVEX.h' X*--- max. length for inclusive brackets X MAXL=12 X*--- skip leading blanks X DO 10 IC1=ICC1,ICC2 X IF (STRING(IC1:IC1).NE.' ') GOTO 20 X 10 CONTINUE X LAST=ICC2 X GOTO 999 X 20 CONTINUE X NSTST=INDEX(STRING(IC1:ICC2),'{')-1 X IF(NSTST.GT.0) THEN X*--- always stop before start of next string X IC2=IC1+NSTST-1 X ELSE X IC2=ICC2 X ENDIF X IF(STRING(IC1:IC1).EQ.'{') THEN X*--- get string X IN=IC1+INDEX(STRING(IC1+1:IC2),'}') X IF (IN.EQ.IC1.OR.IN.EQ.IC2) THEN X LAST=IC2 X ELSE X LAST=IN X ENDIF X GOTO 999 X ELSE X*--- no string X DO 30 I=IC1,IC2 X STEMP=STRING(I:I) X IF (INDEX(':(=*/+-',STEMP).EQ.0)GOTO 40 X LAST=I X IF (STEMP.EQ.'(') THEN X CALL SKIPLV(STRING,I+1,IC2,.FALSE.,KPOS,ILEV) X IF (KPOS.GT.0.AND.KPOS-ICC1.LT.MAXL) THEN X LAST=KPOS X GOTO 90 X ENDIF X ENDIF X 30 CONTINUE X GOTO 999 X 40 CONTINUE X IF (I.EQ.IC1) LAST=I X IF (STEMP.EQ.'.') THEN X*--- look for relational symbol X CALL POSCH('.',STRING,I+1,IC2,.FALSE.,9999,KPOS,ILEV) X IF (KPOS.EQ.0) GOTO 999 X DO 50 J=I+1,KPOS-1 X IF (.NOT.ALPHCH(STRING(J:J))) GOTO 999 X 50 CONTINUE X LAST=KPOS X ELSEIF (ANUMCH(STEMP)) THEN X NUFL=NUMCH(STEMP) X DEFL=.FALSE. X DO 70 J=I,IC2 X STEMP=STRING(J:J) X IF (STEMP.EQ.' '.OR.NUMCH(STEMP)) GOTO 60 X IF (.NOT.NUFL.AND.ALPHCH(STEMP)) GOTO 60 X IF (NUFL.AND.STEMP.EQ.'.') GOTO 60 X IF (DEFL.AND.(STEMP.EQ.'+'.OR.STEMP.EQ.'-')) GOTO 60 X DEFL=STEMP.EQ.'D'.OR.STEMP.EQ.'E' X NUFL=.FALSE. X IF (DEFL) GOTO 60 X GOTO 80 X 60 LAST=J X 70 CONTINUE X GOTO 999 X 80 CONTINUE X IF (STEMP.EQ.')') LAST=J X ENDIF X ENDIF X 90 CONTINUE X IF(LAST.LT.IC2.AND.STRING(LAST+1:LAST+1).EQ.',') THEN X LAST=LAST+1 X ELSEIF(LAST+1.LT.IC2.AND.STRING(LAST+1:LAST+1).EQ.' ' .AND.STRING X +(LAST+2:LAST+2).EQ.',') THEN X LAST=LAST+2 X ENDIF X 999 END / echo 'x - READEC.f' sed 's/^X//' > READEC.f << '/' X SUBROUTINE READEC X*----------------------------------------------------------------------- X* X*--- extracts one complete routine from input file, buffers it. X* the routine must end with an 'END' statement, or EOF X* X* Routines longer than MXSIMA lines are split. X* X* Blocks of comment lines in front of routines are treated as X* separate entities. X* X* The statements are counted, start and end of each statement X* (including comments between cont. lines) kept. Blocks of X* comment lines are treated like statements. X* X*--- output X* SIMA COMMON/ALCAZA/ statement images X* NLINES,NSTAMM,NFSTAT,NKEEPL ,/STATE/ X* NLTYPE(1..NLINES), NFLINE(1..NSTAMM), NLLINE(1..NSTAMM), X* ICLASS(1..NSTAMM) /STATE/ X* NSTATC(..) statistics X* STATUS(1), STATUS(2), STATUS(5), STATUS(6), /FLAGS/ X* X*----------------------------------------------------------------------- X include 'PARAM.h' X include 'ALCAZA.h' X include 'FLAGS.h' X include 'STATE.h' X include 'CLASS.h' X* X STATUS(6)=STATUS(5) X NCOMM=0 X NFSTAT=0 X NSTAMM=0 X NPL=NLINES X NLINES=0 X 10 CONTINUE X*--- loop over input lines until E.O.F., or END, or X* start of a new routine, or routine too long which X* will then be split behind a convenient statement. X IF(NLINES.EQ.MXSIMA) THEN X*--- buffer full X STATUS(5)=.TRUE. X IF (.NOT.STATUS(6)) WRITE (MPUNIT,10000)MXSIMA,SIMA(1) X CALL READSB(NCOMM,NST,ICL) X IF (NST.GT.0) THEN X*--- last FORTRAN statement could be incomplete - split before; X* check as well for routine header X IF (NST.EQ.NSTAMM.OR.(NFSTAT.GT.1.AND.ISTMDS(14,ICL).NE.0)) X + THEN X NSTAMM=NSTAMM-1 X NFSTAT=NFSTAT-1 X NKEEPL=NLINES-NLLINE(NSTAMM) X ENDIF X ENDIF X GOTO 999 X ENDIF X IF(NKEEPL.EQ.0) THEN X IF (.NOT.STATUS(1)) CALL INLINE(MIUNIT,SIMA(NLINES+1),STATUS(1) X + ,NLTYPE(NLINES+1)) X IF (STATUS(1)) THEN X*--- EOF on input file X STATUS(2)=NLINES.EQ.0 X IF (STATUS(2)) GOTO 999 X STATUS(5)=.FALSE. X CALL READSB(NCOMM,NST,ICL) X*--- last FORTRAN statement could be routine header X IF (NFSTAT.GT.1) THEN X IF (ISTMDS(14,ICL).NE.0) THEN X*--- leave routine header for next time X NSTAMM=NST-1 X NFSTAT=NFSTAT-1 X NKEEPL=NLINES-NLLINE(NSTAMM) X ENDIF X ENDIF X GOTO 999 X ENDIF X ELSE X*--- transfer buffered lines to start of buffer X NKEEPL=NKEEPL-1 X NLTYPE(NLINES+1)=NLTYPE(NPL-NKEEPL) X SIMA(NLINES+1)=SIMA(NPL-NKEEPL) X ENDIF X*--- now a new line in SIMA(NLINES+1), with type NLTYPE(NLINES+1) X IF(NLTYPE(NLINES+1).EQ.0) THEN X*--- comment line X NCOMM=NCOMM+1 X NLINES=NLINES+1 X ELSEIF (NLTYPE(NLINES+1).EQ.2) THEN X*--- this is a cont. line - accept comment lines in between X NCOMM=0 X NLINES=NLINES+1 X ELSE X*--- start of FORTRAN statement X CALL READSB(NCOMM,NST,ICL) X NLINES=NLINES+1 X IF (NST.GT.0) THEN X*--- previous statement could be END X IF (ICL.EQ.IEND) THEN X NKEEPL=1 X STATUS(5)=.FALSE. X GOTO 999 X*--- or routine header ? X ELSEIF (ISTMDS(14,ICL).NE.0) THEN X IF (NFSTAT.GT.1) THEN X NSTAMM=NST-1 X NFSTAT=NFSTAT-1 X NKEEPL=NLINES-NLLINE(NSTAMM) X STATUS(5)=.FALSE. X GOTO 999 X ELSE X STATUS(6)=.FALSE. X ENDIF X ENDIF X ENDIF X*--- accept the new line as start of a statement X NSTAMM=NSTAMM+1 X NFLINE(NSTAMM)=NLINES X ENDIF X GOTO 10 X10000 FORMAT(/' +++++++++ WARNING - deck with more than ',I5, X +' lines encountered, deck split'/' first line =',A90) X 999 END / echo 'x - REPNAM.f' sed 's/^X//' > REPNAM.f << '/' X SUBROUTINE REPNAM X*----------------------------------------------------------------------- X* X* Performs replacements of names, or names+strings attached X* X*----------------------------------------------------------------------- X include 'PARAM.h' X include 'ALCAZA.h' X include 'FLAGS.h' X include 'CURSTA.h' X include 'STATE.h' X include 'KEYCOM.h' X include 'JOBSUM.h' X DIMENSION KSP1(100),KSP2(100) X NCH=0 X IPT=0 X NMOD=IMODIF(NSTREF) X*--- check for 'REP' key X DO 10 IK=1,NGLSET X IF (KEYREF(IK,1).EQ.9) GOTO 20 X 10 CONTINUE X GOTO 999 X 20 CONTINUE X*--- check for name replacement X IF (KEYREF(IK,4).EQ.0) GOTO 999 X DO 30 I=1,NSNAME X CALL NAMSRC(SNAMES(ISNAME+I),SKEYLS(KEYREF(IK,5)+1), X + KEYREF(IK,4),IPOS,LAST) X IF (IPOS.EQ.0) GOTO 30 X IPOS=IPOS+KEYREF(IK,5) X KREF1=KNAMRF(IPOS,1) X*--- check illegal X IF (KREF1.LT.0) GOTO 30 X*--- name must behind last replacement X IF (NSSTRT(I).GT.IPT) THEN X*--- check for string following X KPOS=0 X NSPEC=0 X IF (KREF1.GT.0) THEN X CALL MATCH(SKYSTR,KKYSTA(KREF1),KKYEND(KREF1),SSTA,NSEND( X + I)+1,NCHST,.TRUE.,KPOS,ILEV,NSPEC,KSP1,KSP2) X IF (KPOS.EQ.0) GOTO 30 X ENDIF X*--- name (+string) do match X*--- set modify flag X IF (NMOD.LT.10) NMOD=NMOD+10 X*--- copy from pointer up to name X L=NSSTRT(I)-IPT-1 X IF (L.GT.0) THEN X IF (NCH+L.GT.MXLENG) GOTO 40 X SSTR(NCH+1:NCH+L)=SSTA(IPT+1:IPT+L) X NCH=NCH+L X ENDIF X IPT=MAX(NSEND(I),KPOS) X KREF2=KNAMRF(IPOS,2) X IF (KREF2.GT.0) THEN X*--- non-empty replacement string exists X L=KKYEND(KREF2)-KKYSTA(KREF2)+1 X IF (NSPEC.EQ.0) THEN X IF (NCH+L.GT.MXLENG) GOTO 40 X*--- replace name by string X SSTR(NCH+1:NCH+L)=SKYSTR(KKYSTA(KREF2):KKYEND(KREF2)) X NCH=NCH+L X ELSE X CALL REPSUB(KREF1,KREF2,NSPEC,KSP1,KSP2,NCH) X IF (NCH.GT.MXLENG) GOTO 40 X ENDIF X ENDIF X ENDIF X 30 CONTINUE X IF(NMOD.GE.10) THEN X*--- copy SSTR to SSTA, NCH to NCHST X L=NCHST-IPT X IF (L.GT.0) THEN X IF (NCH+L.GT.MXLENG) GOTO 40 X SSTR(NCH+1:NCH+L)=SSTA(IPT+1:NCHST) X NCH=NCH+L X ENDIF X IMODIF(NSTREF)=NMOD X NCHST=NCH X SSTA(:NCH)=SSTR(:NCH) X ENDIF X GOTO 999 X 40 CONTINUE X WRITE (MPUNIT,10000) X CALL FLPRNT(1,'OVERFLOW',NLLINE(NSTREF)-NFLINE(NSTREF)+1, SIMA X +(NFLINE(NSTREF)),NDUMMY) X NSTATC(6)=NSTATC(6)+1 X STATUS(11)=.TRUE. X10000 FORMAT(/' ++++++ Warning - replacements would lead to overflow', X +' in following statement, not done') X 999 END / echo 'x - RSTART.f' sed 's/^X//' > RSTART.f << '/' X SUBROUTINE RSTART X*----------------------------------------------------------------------- X* X* Processes the routine start X* X*----------------------------------------------------------------------- X include 'PARAM.h' X include 'ALCAZA.h' X include 'CLASS.h' X include 'FLAGS.h' X include 'CURSTA.h' X include 'STATE.h' X include 'TREECOM.h' X LOGICAL FLOC X*--- reset modify and filter flag X DO 10 I=1,NSTAMM X IMODIF(I)=0 X 10 CONTINUE X*--- only initialize for new routine if really true X IF(.NOT.STATUS(6)) THEN X IF(ACTION(24)) THEN X*--- reset counters and flags for c.b. names X STATUS(12)=.FALSE. X STATUS(13)=.FALSE. X NCBNAM=0 X NEQNAM=0 X NCBVAR=0 X DO 20 I=1,MAXGRP X LCBNAM(I)=0 X 20 CONTINUE X DO 30 I=1,MXNAME X LCBVAR(I)=0 X 30 CONTINUE X ENDIF X IF(ACTION(29)) THEN X*--- reset counters for TREE X NCALLR=0 X NCALLD=0 X NEXEL=0 X ENDIF X*--- set flag to re-initialize filters X IFILTR=-1 X*--- 'print routine header' flag X STATUS(9)=.TRUE. X*--- reset SUBROUTINE flag X STATUS(14)=.FALSE. X*--- get routine name X DO 40 I=1,NSTAMM X IF (ICLASS(I,1).NE.0) GOTO 50 X 40 CONTINUE X*--- only comments X SCROUT='COMMENTS' X GOTO 60 X 50 CONTINUE X CALL EXTRAC(I,'PART') X CALL CLASSF X*--- find routine name X IF (ISTMDS(14,ICURCL(1)).NE.0) THEN X*--- proper routine header X STATUS(14)=ISTMDS(6,ICURCL(1)).EQ.66 X FLOC=ACTION(10) X ACTION(10)=.TRUE. X ISNAME=IRNAME+NRNAME X CALL GETALL X ACTION(10)=FLOC X IF(NSNAME.GT.0) THEN X SCROUT=SNAMES(ISNAME+1) X ELSEIF(ISTMDS(6,ICURCL(1)).EQ.4) THEN X SCROUT='BLOCKDAT' X ELSE X SCROUT='NOHEADER' X ENDIF X ELSE X SCROUT='NOHEADER' X ENDIF X 60 CONTINUE X*--- reset variable type routine X IF (ACTION(20)) CALL SETTYP(0) X*--- preset 'routine filtered' flag X STATUS(7)=.TRUE. X*--- filter for routine names X IF (ACTION(16)) CALL FILTER(10,7) X ENDIF X*--- process only if routine selected X IF (STATUS(7)) THEN X*--- classify all statements X DO 70 J=1,NSTAMM X IF (ICLASS(J,1).NE.0) THEN X CALL EXTRAC(J,'FULL') X CALL CLASSF X ICLASS(J,1)=ICURCL(1) X ICLASS(J,2)=ICURCL(2) X ENDIF X 70 CONTINUE X*--- prepare re-numbering if requested X IF (ACTION(13)) CALL PRENUM X ENDIF X*--- reset variables X KNTDO=0 X KNTIF=0 X WRITE(MPUNIT,'(2A)') ' +++ start processing routine: ',SCROUT X END / echo 'x - STATE.h' sed 's/^X//' > STATE.h << '/' X COMMON/STATE/NLINES,NKEEPL,NSTAMM,NFSTAT,ISNAME,NSNAME,IRNAME, X 1 NRNAME,IGNAME,NGNAME,INDCNT,INDFAC,KNTDO,KNTIF,IBLPAD,NRORST, X 2 NSTANU,ICBPRT,NCBNAM,NEQNAM,NCBVAR, X + NCBGRP(MAXGRP),KCBGRP(MAXGRP),LCBNAM(MAXGRP),LCBVAR(MXNAME), X + NEQGRP(MAXGRP),KEQGRP(MAXGRP), X + LRORST(MXORST),NAMTYP(MXNAME),NSSTRT(700),NSEND(700), X 3 KSTANU(MAXNUM),KSTARE(MAXNUM),NLTYPE(MXSIMA),ICLASS(MXSIMA,2), X 4 IMODIF(MXSIMA),NFLINE(MXSIMA),NLLINE(MXSIMA) X*IF DEF,NEVER X*----------------------------------------------------------------------- X* /STATE/ contains the information concerning the actual X* status of the program X* NLINES no. of lines in line image buffer SIMA X* NKEEPL buffered line number in READEC, or 0 X* NSTAMM total no. of statements in current routine X* NFSTAT no. of FORTRAN statements in current routine X* ISNAME pointer to start-1 of stmt. names in SNAMES X* NSNAME no. of names found in statement X* IRNAME pointer to start-1 of names/routine in SNAMES X* NRNAME no. of names/routine X* IGNAME pointer to start-1 of global names in SNAMES X* NGNAME no. of global names X* INDCNT current indentation level (reset at routine start) X* INDFAC no. of ch./level to indent X* KNTDO current DO loop level (for indentation) X* KNTIF current IF...THEN level (for indentation) X* IBLPAD in QUOTES option, string blank-padded to multiples X* of IBLPAD (default = 1) X* NRORST no. of currently selected OR-sets in LRORST X* NSTANU no. of statement numbers in KSTANU, KSTARE X* ICBPRT no. of c.b. variables printed at ACTION(24) X* NCBNAM no. of c.b. names in NCBGRP, KCBGRP, SCBNAM X* NEQNAM no. of equiv. groups in NEQGRP, KEQGRP X* NCBVAR no. of names in SEQNAM X* NCBGRP no. of common block variables per c.b. X* KCBGRP pos.-1 of start of c.b. name list in SCBNAM X* LCBNAM # of c.b. variables used in current routine X* LCBVAR counts number of times a variable is referenced X* NEQGRP no. of names in equiv. group X* KEQGRP pos.-1 of start of equiv. group in SCBNAM X* LRORST list of OR-sets valid for current routine X* NAMTYP variable type, parallel to SNAMES X* NSSTRT start of name I in SSTA X* NSEND end of name I in SSTA X* KSTANU statement numbers in routine (sorted) X* KSTARE new statement numbers, corresponding to KSTANU X* NLTYPE type of line I (0 comment, 1 start, 2 cont. of stmt. ) X* ICLASS(I,1) type of statement I X* 0 = comment X* 999 = no comment, not classified X* class = ICURCL(1), common /CURSTA/ X* ICLASS(I,2) type of second part of statement I if logical IF X* IMODIF 10*n2 + n1 X* n1 = 1 : statement has been filtered X* n2 = 1 : statement has been modified X* NFLINE start of statement I in SIMA X* NLLINE end of statement I in SIMA X*----------------------------------------------------------------------- X*EI / echo 'x - TREESU.f' sed 's/^X//' > TREESU.f << '/' X SUBROUTINE TREESU X*----------------------------------------------------------------------- X* X*--- Writes TREE output for each routine X* X*----------------------------------------------------------------------- X include 'PARAM.h' X include 'ALCAZA.h' X include 'TREECOM.h' X include 'STATE.h' X include 'FLAGS.h' X include 'CLASS.h' X include 'CURSTA.h' X include 'USUNIT.h' X include 'USARGS.h' X CHARACTER SNAME*(MXNMCH),STEMP*1,ATYP*7,UNUCOM(MAXGRP)*1 X SAVE IFIRST X DATA ATYP/'IRLKDC$'/ X DATA IFIRST/0/ X*--- find types of callers, and argument list X DO 30 I=1,NCALLR X NUMBER=ICALLR(I) X CERARG(I)=' ' X KODE(I)=' ' X IF(NUMBER.EQ.0) THEN X*--- routine without header - treat as program X CERARG(I)(:4)='MAIN' X ELSE X CALL EXTRAC(NUMBER,'FULL') X ICURCL(1)=ICLASS(NUMBER,1) X ICURCL(2)=ICLASS(NUMBER,2) X*--- external class X ICLE=ISTMDS(6,ICURCL(1)) X IF(ICLE.EQ.55) THEN X*--- PROGRAM X CERARG(I)(:4)='MAIN' X ELSEIF(ICLE.EQ.4) THEN X*--- block data X KODE(I)='B' X ELSE X CALL GETALL X CALL SETTYP(1) X NT=NAMTYP(ISNAME+1) X DO 10 J=1,6 X IF(ITBIT(NT,J).NE.0) THEN X KODE(I)=ATYP(J:J) X GOTO 20 X ENDIF X 10 CONTINUE X 20 CONTINUE X JLBPOS=INDEX(SSTA(1:NCHST),'(') X IF(JLBPOS.NE.0) THEN X CALL ARGTYP(SSTA,.TRUE.,JLBPOS,NCHST,CERARG(I)) X ENDIF X ENDIF X ENDIF X 30 CONTINUE X IF(IFIRST.EQ.0) THEN X*--- neg. version number for format check X IVERS=-100.*(VERSIO+.001) XC WRITE(MTUNIT) IVERS X IFIRST=1 X ENDIF X*--- common block names are added plus a flag UNUCOM: X* ' ' if c.b. used in routine, otherwise '!' X DO 40 I=1,NCBNAM X IF(LCBNAM(I).EQ.0) THEN X UNUCOM(I)='!' X ELSE X UNUCOM(I)=' ' X ENDIF X 40 CONTINUE XC WRITE(MTUNIT) NCALLR,(CALLER(I),I=1,NCALLR), XC +(CERARG(I),I=1,NCALLR),(KODE(I),I=1,NCALLR), XC +NCALLD,(CALLED(I),I=1,NCALLD),(CEDARG(I),I=1,NCALLD), XC +NCBNAM,(SCBNAM(I),I=1,NCBNAM),(UNUCOM(I),I=1,NCBNAM),0,0,0,0,0 X WRITE(MJUNIT) NCALLR,(CALLER(I),I=1,NCALLR), X +(CERARG(I),I=1,NCALLR),(KODE(I),I=1,NCALLR), X +NCALLD,(CALLED(I),I=1,NCALLD),(CEDARG(I),I=1,NCALLD), X +NCBNAM,(SCBNAM(I),I=1,NCBNAM),(UNUCOM(I),I=1,NCBNAM), X +CMMNT,NARGS,(CARGNM(I),I=1,NARGS),(CARGTY(I),I=1,NARGS), X +(NARGDI(I),I=1,NARGS), X +(((CARGDI(III,II,I),II=1,2),III=1,NARGDI(I)),I=1,NARGS), X +NKALL,(CKALLN(I),I=1,NKALL),(KALLIF(I),I=1,NKALL), X +(KALLDO(I),I=1,NKALL), X +0,0,0,0,0 X END / echo 'x - UTTERM.f' sed 's/^X//' > UTTERM.f << '/' X SUBROUTINE UTTERM X*----------------------------------------------------------------------- X* X*--- user total termination 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 'USIGNO.h' X include 'USINFN.h' X include 'CHECKS.h' X LOGICAL BTEST X CHARACTER*(MXNMCH) CNAM X IF(UNFLP) RETURN X WRITE(MPUNIT,500) X DO 70 I=1,NGNAME X NTYP = NAMTYP(IGNAME+I) X CNAM = SNAMES(IGNAME+I) X DO 10 IGN=1,NIGNOR X IF(LIGNOR(IGN).NE.INDEX(CNAM,' ')-1) GOTO 10 X IF(CIGNOR(IGN)(:LIGNOR(IGN)).EQ.CNAM(:LIGNOR(IGN))) GOTO 70 X 10 CONTINUE XC check for use of obsolete CERN library routines X IF(LCHECK(33).AND.(BTEST(NTYP,16).OR.BTEST(NTYP,14))) THEN X CALL CHKOBS(CNAM,IWARN) X IF(IWARN.NE.0) THEN X WRITE(MPUNIT,560) CNAM X ENDIF X ENDIF X IF(LCHECK(32).AND.BTEST(NTYP,7)) THEN XC sort common block names. X DO 20 II=0,19 X IF(II.EQ.7) GOTO 20 X IF(BTEST(NTYP,II)) THEN X WRITE(MPUNIT,510) CNAM X ENDIF X 20 CONTINUE X ENDIF X IF(BTEST(NTYP,16)) THEN XC FUNCTION X ILEN = INDEX(CNAM,' ')-1 X DO 30 INF=1,LIF X IF(INDEX(CINFUN(INF),' ')-1.EQ.ILEN) THEN X IF(CINFUN(INF).EQ.CNAM) THEN X IF(LCHECK(34).AND.BTEST(NTYP,11)) X & WRITE(MPUNIT,520) CNAM X GOTO 40 X ENDIF X ENDIF X 30 CONTINUE X IF(LCHECK(35).AND..NOT.BTEST(NTYP,11)) WRITE(MPUNIT,530) X + CNAM X 40 CONTINUE X ENDIF XC Check for clashes between SUBROUTINE,BLOCKDATA,PROGRAM,ENTRY,FUNCTION X IF(LCHECK(36)) THEN X DO 60 ITY=12,16 X IF(.NOT.BTEST(NTYP,ITY)) GOTO 60 X DO 50 ITY2=12,16 X IF(ITY.EQ.ITY2) GOTO 50 X IF(.NOT.BTEST(NTYP,ITY2)) GOTO 50 X WRITE(MPUNIT,540) CNAM X GOTO 70 X 50 CONTINUE X 60 CONTINUE X ENDIF X 70 CONTINUE X WRITE(MPUNIT,550) X 500 FORMAT(/,1X,20('+'), ' BEGIN GLOBAL MODULE CHECKS ',10('+')) X 510 FORMAT(1X,'!!! WARNING ... VARIABLE ',A, X +' IS NAME OF COMMON BLOCK AND OTHER') X 520 FORMAT(1X,'!!! WARNING ... FUNCTION ',A, X +' IS EXTERNAL BUT CLASHES WITH INTRINSIC FUNCTION') X 530 FORMAT(1X,'!!! WARNING ... FUNCTION ',A, X +' IS NOT INTRINSIC, AND IS NOT DECLARED "EXTERNAL"') X 540 FORMAT(1X,'!!! WARNING ... MODULE ',A, X +' HAS NAME CLASH WITH OTHER MODULE') X 550 FORMAT(1X,20('+'), ' END GLOBAL MODULE CHECKS ',10('+'),//) X 560 FORMAT(1X,'!!! WARNING ... "',A, X +'" IS OBSOLETE CERN LIBRARY ROUTINE') X END / echo 'x - floppy.panel' sed 's/^X//' > floppy.panel << '/' X;PANEL1 X.CYF HELP CMS QUIT X==> FLOPPY VERSION 6.00 <=======> CODING CONVENTION CHECKER <==========> X X%&err X FN FT FM X %Source %FORTRAN %==> ^8&fnin ^8&ftin ^2&fmin X------------------------------------------------------------------------ Xa) Existing Floppy parameter file %==> ^8&fnold ^8&ftold ^2&fmold Xb) Checks to be made %==> ^30&checks X Specify names to ignore %==> ^3&ignore X------------------------------------------------------------------------ XGenerate a file for FLOW %==> ^3&tree X------------------------------------------------------------------------ XSend Floppy Output to disk %==> ^3&flopo XList all source FORTRAN lines %==> ^3&full X------------------------------------------------------------------------ XTidy Fortran? %==> ^3&tidy Output %==> ^8&fntdy ^8&fttdy ^2&fmtdy X a) Adjust GOTOs to right of page %==> ^3&gotos X b) Indent DO/IF clauses %==> ^3&indent Spaces %==> ^1&spaces X c) Group FORMATs at routine ends %==> ^3&groupf X d) Renumber FORMAT statements %==> ^3&renumf Start %==> ^4&startf X Step %==> ^4&stepf X e) Renumber all other statements %==> ^3&renums Start %==> ^4&starts X Step %==> ^4&steps XPF1:%Help %(on %cursor) PF2:%Enter %a %CMS %Command PF3:%Exit / echo 'Part 08 of Floppy complete.' exit