C CLEAN77.FOR 10 June 1991 C C 10 June 1991 - The ULTRIX compiler would not accept C "CHARACTER LABSIG", "PARAMETER (LABSIG '\')" so I replaced LABSIG C by its value, alas. Alas squared! The back slash is treated as C an escape character, God bless UNIX! So I have to replace '\' C by CHAR(92) and hope I counted correctly. Will no one rid C me of this absurd operating system? C C Then I discover that in PROROU, there already IS a variable called C CHAR, so I had to rename THAT to CHAR1. C C The CHAR variable is running around in a COMMON block, and so occurs C fairly globally. Someone should go through and rename it to CHAR1 C everywhere (except, of course, where it's the CHAR function!). C PROGRAM CLEAN77 C IMPLICIT INTEGER (A-Z) C C CLEAN77 - FORTRAN 77 PROCESSOR. C C CREDIT: C GREGORY D. FLINT, PURDUE UNIVERSITY COMPUTING CENTER, C 1983, 1984, 1985, 1986, 1987. C C COPYRIGHT NOTICE: C COPYRIGHT BY PURDUE UNIVERSITY, 1983, 1984, 1985, 1986, 1987. C ALL RIGHTS RESERVED. C THIS PROGRAM MAY NOT BE REDISTRIBUTED WITHOUT THE EXPRESSED C CONSENT OF PURDUE UNIVERSITY. C A RECIPIENT OF THIS PROGRAM MAY MODIFY IT FOR HIS/HER OWN C INTERNAL USE. C C WARRANTY NOTICE: C PURDUE UNIVERSITY COMPUTING CENTER (PUCC) WARRANTS ONLY THAT C PUCC TESTING HAS BEEN APPLIED TO THIS CODE. NO OTHER C WARRANTY, EXPRESSED OR IMPLIED, IS APPLICABLE. C C DESCRIPTION: C CLEAN77 READS AND REFORMATS FORTRAN 77 PROGRAMS. IT WILL C ALSO PROCESS MANY DIALECTS OF FORTRAN 66. C C THE PROGRAM READS AN OPTIONAL FILE OF COMMANDS THAT MAY C BE USED TO INITIALIZE CERTAIN PROCESSING OPTIONS. AFTER C READING THE COMMAND FILE, THE INPUT FILE IS READ AND PROCESSED. C COPIES OF THE SOURCE AND RESULT FILES ARE PRINTED ON THE C OUTPUT FILE UNLESS DIRECTED OTHERWISE VIA A COMMAND FROM C EITHER THE COMMAND OR SOURCE FILE. C C FILES: C TAPE1 = SOURCE INPUT [DEF: FORT1] C TAPE2 = LISTING OUTPUT [DEF: FORT2] C TAPE3 = RESULT (CLEANED) OUTPUT [DEF: FORT3] C TAPE4 = COMMAND INPUT [DEF: FORT4] C TAPE5 = PROMPT INPUT [DEF: STD. INPUT] C TAPE6 = PROMPT OUTPUT [DEF: STD. OUTPUT] C TAPE7 = SCRATCH (INTERNAL TO CLEAN77) [DEF: FORT7] C TAPE8 = SCRATCH (INTERNAL TO CLEAN77) [DEF: FORT8] C TAPE9 = SCRATCH (INTERNAL TO CLEAN77) [DEF: FORT9] C COMMON /COUNT/ FMTBAS, FMTINC, INCNT , INDINC, LABASE, LABINC, * LINELN, OLDLEN, PAGELN, RINCNT, ROUCNT, THISLN, * THISPG, TINCNT, TOUCNT COMMON /LOGVR/ ADDCON, BRKCOM, COLFMT, CPYFLG, CVTHFI, DONERD, * DOSTAT, EXMCOM, EXMFMT, EXMNEX, FIRSTC, HAVEXS, * INDCOM, INDSTA, ISFMT , ISSCOM, LASTBC, LBTFUL, * LSTIDS, LSTRES, LSTSRC, MORE , NEEDRD, OVRLAY, * PASS0 , PASS1 , PROPCM, QUOTCV, RJLABS, ROUDON, * SIZDEF, SPLTNV, SPLTST, UNCOND, VARUEC, WASCHF, * WASCMD, WASKEY, WASLAB, WASSTR, WASUNC, WRBCOM, * WRCBLK, WRMSG1, WRTFMT, XTRAST, ZEND , ZREAD LOGICAL ADDCON, BRKCOM, COLFMT, CPYFLG, CVTHFI, DONERD, DOSTAT, * EXMCOM, EXMFMT, EXMNEX, FIRSTC, HAVEXS, INDCOM, INDSTA, * ISFMT , ISSCOM, LASTBC, LBTFUL, LSTIDS, LSTRES, LSTSRC, * MORE , NEEDRD, OVRLAY, PASS0 , PASS1 , PROPCM, QUOTCV, * RJLABS, ROUDON, SIZDEF, SPLTNV, SPLTST, UNCOND, VARUEC, * WASCHF, WASCMD, WASKEY, WASLAB, WASSTR, WASUNC, WRBCOM, * WRCBLK, WRMSG1, WRTFMT, XTRAST, ZEND , ZREAD C CHARACTER*8 IUNIT, USENUM CHARACTER*30 MSG(4) C CALL PRESET CALL RDCMDF C 10 CALL INPUTL IF (ZREAD) THEN CALL DMPLAB CALL PROROU ENDIF IF (.NOT. DONERD) GO TO 10 C WRITE (UNIT=IUNIT,FMT=20) INCNT 20 FORMAT (I8) READ (UNIT=IUNIT,FMT=30) USENUM 30 FORMAT (A) MSG(1) = USENUM // ' LINES READ.' C WRITE (UNIT=IUNIT,FMT=20) TINCNT READ (UNIT=IUNIT,FMT=30) USENUM MSG(2) = USENUM // ' STATEMENTS PROCESSED.' C WRITE (UNIT=IUNIT,FMT=20) ROUCNT READ (UNIT=IUNIT,FMT=30) USENUM MSG(3) = USENUM // ' ROUTINES DETECTED.' C WRITE (UNIT=IUNIT,FMT=20) TOUCNT READ (UNIT=IUNIT,FMT=30) USENUM MSG(4) = USENUM // ' LINES WRITTEN.' C IF (LSTRES .OR. LSTSRC) THEN PASS0 = .TRUE. CALL PAGECK(11) WRITE (2,40) MSG 40 FORMAT (///// * 5X,'FINAL CLEAN77 TOTALS:'// * 4(10X,A:/)) ENDIF C CLOSE (1) CLOSE (2) CLOSE (3) CLOSE (7,STATUS='DELETE') CLOSE (8,STATUS='DELETE') CLOSE (9,STATUS='DELETE') C WRITE(*,*)'CLEAN77 V2.23' WRITE(*,*)'Normal termination.' STOP C END BLOCK DATA IMPLICIT INTEGER (A-Z) C C PARAMETER TYPE USE C --------- ---- --------------------------------------- C DOTLEN I LENGTH OF ACTIVE DO-LOOP TABLE =TOTBL= C INDMAX I MAXIMUM NUMBER OF COLUMNS TO INDENT C LABSIG S* 1 LABEL SIGNAL FOR PASS 2 C LBTLEN I LENGTH OF LABEL TABLE =LBLTBL= (IF MORE C THAN 512, DMPLAB+LBHASH MUST CHANGE) C LBTLN3 I 3 * LBTLEN (FOR 2-D ARRAY =LBLTBL=) C C CHARACTER*1 LABSIG C PARAMETER ( DOTLEN = 30 ) PARAMETER ( INDMAX = 30 ) C PARAMETER ( LABSIG = '\' ) PARAMETER ( LBTLEN = 509 ) PARAMETER ( LBTLN3 = 3*LBTLEN ) C C PARAMETER TYPE USE C --------- ---- --------------------------------------- C CMDLEN I LENGTH OF A COMMAND IN COMMAND TABLE C CMDMAX I NUMBER OF COMMANDS TO CHECK C DEFLLN I DEFAULT LINE LENGTH C DEFLPP I DEFAULT LINES PER PAGE C DEFQUO S* 1 DEFAULT QUOTE CHARACTER C DEFRET S* 1 DEFAULT ALTERNATE RETURN LABEL PREFIX C MAXLLN I MAXIMUM LINE LENGTH C MAXVRL I MAXIMUM NUMBER OF CHARACTERS IN A VARIABLE C MINLLN I MINIMUM LINE LENGTH C MINLPP I MINIMUM LINES PER PAGE C STRSIG S* 1 STRING SIGNAL FOR PASS 2 C VEXTCS S* 2 VARIABLES EXTENDED CHARACTER SET CHARACTERS C CHARACTER*1 DEFRET, DEFUNC, DEFQUO, STRSIG CHARACTER*2 VEXTCS C PARAMETER ( CMDLEN = 7 ) PARAMETER ( CMDMAX = 34 ) PARAMETER ( DEFLLN = 72 ) PARAMETER ( DEFLPP = 60 ) PARAMETER ( DEFQUO = '''' ) PARAMETER ( DEFRET = '*' ) PARAMETER ( DEFUNC = ' ' ) PARAMETER ( MAXLLN = 125 ) PARAMETER ( MAXVRL = 8 ) PARAMETER ( MINLLN = 40 ) PARAMETER ( MINLPP = 30 ) PARAMETER ( STRSIG = '?' ) PARAMETER ( VEXTCS = '$_' ) C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C C *** BLCKDA - PRESETS LABELED COMMON AT LOAD TIME *** C C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C C C COMMON BLOCK: CHBLK - CHARACTER VARIABLES (USED WITH /CHPTR/). C C PARAMETER TYPE USE C --------- ---- --------------------------------------- C COMLEN I LENGTH OF =COMBLK= C C VARIABLE TYPE USE C -------- ------ ---------------------------------------- C CHAR1 S* 1 LATEST CHARACTER EXTRACTED FROM SUPRCD C COMBLK S* 126 COMMENT BLOCK C EOS S* 1 END-OF-STATEMENT CHARACTER C EXMCHR S* 1 EXEMPT CARDS WITH THIS CHAR IN COLUMN 1 C HOLDCH S* 1 TEMPORARY C INLINE S* 126 LATEST LINE READ FROM INPUT C LN1MSG S* 40 CONSOLE LINE 1 MESSAGE AREA C LONGKY S* 40 LONG (INCLUDING NUMBERS) POSSIBLE KEY WORD C NUMBER S* 40 LATEST NUMBER ENCOUNTERED C NUMLET S* 38 POSITIONS 1-10: DIGITS, 11-36: LETTERS C 37-38: EXTENDED CHARACTER SET IF IT IS C BEING USED, OTHERWISE =ZZ=. C QUOTCH S* 1 QUOTE MARK CONVERSION CHARACTER C RETPFX S* 1 ALTERNATE RETURN LABEL PREFIX C SPECHR S* 17 SPECIAL CHARACTERS: +-*/()$=,.:;&[]"' C SQZCRD S*1458 COMPRESSED ORIGINAL CARD (BLANKS REMOVED) C SUPRCD S*1458 ORIGINAL CARD + CONTINUATIONS AS IF ONE CARD C TMPCRD S*1458 TEMPORARY STORAGE USED FOR APPENDING STRINGS C TMPSTR S* 40 TEMPORARY STORAGE USED FOR APPENDING STRINGS C UNCONC S* 1 UNCONDITIONAL CHANGE OF CONTROL FLOW LINE C PREFIX C VARBLE S* 40 LATEST VARIABLE ENCOUNTERED C PARAMETER ( COMLEN = 100 ) PARAMETER ( SUPLEN = 1458 ) C COMMON /CHBLK/ CHAR1 , COMBLK, EOS , EXMCHR, HOLDCH, INLINE, * LN1MSG, LONGKY, NUMBER, NUMLET, QUOTCH, RETPFX, * SPECHR, SQZCRD, SUPRCD, TMPCRD, TMPSTR, UNCONC, * VARBLE CHARACTER*1 CHAR1, EOS, EXMCHR, HOLDCH, QUOTCH, RETPFX, UNCONC CHARACTER*17 SPECHR CHARACTER*38 NUMLET CHARACTER*40 LN1MSG, LONGKY, NUMBER, TMPSTR, VARBLE CHARACTER*126 COMBLK(COMLEN), INLINE CHARACTER*(SUPLEN) SQZCRD, SUPRCD, TMPCRD C C COMMON BLOCK: CHPTR - CHARACTER POINTERS (USED WITH /CHBLK/). C C VARIABLE TYPE USE C -------- ------ ---------------------------------------- C COMLNB I LAST NON-BLANK IN =COMBLK= ENTRIES C COMPTR I NUMBER OF ENTRIES IN =COMBLK= C EOLINE I END-OF-LINE (LAST NON-BLANK CHAR IN A LINE) C INDENT I INDENTATION LEVEL (MAX = 9) C KYTYPE I INDENTATION TYPE OF KEY/ASSIGNMENT STATEMENT: C 0 - COMMENT C 1 - INCREASE INDENTATION BY 1 (AFTER) C 2 - DECREASE INDENTATION BY 1 (BEFORE) C 3 - DECREASE, THEN INCREASE BY 1 C 4 - NO CHANGE IN IDENTATION C 5 - FORMAT STATEMENT C 6 - END STATEMENT C 7 - DO STATEMENT C 8 - NON-EXECUTABLE STATEMENT C 9 - COMMAND C MATLEN I NUMBER OF LETTERS BEYOND KEYWORD IN =VARBLE= C MATLLN I NUMBER OF LETTERS AND NUMBERS BEYOND KEYWORD C IN =LONGKY= C OCRDPT I COUNT OF ORIGINAL CARDS IN =SUPRCD= C SCRDPT I POINTER INTO =SUPRCD= (USUALLY AT E-O-S) C SQZIN I POINTER INTO =SQZCRD= FOR NEXT CHAR STORAGE C SUPOUT I POINTER INTO =SUPRCD= FOR NEXT CHAR EXTRACTION C TCRDPT I POINTER INTO =TMPCRD= (USUALLY AT E-O-S) C COMMON /CHPTR/ COMLNB(COMLEN), COMPTR, INDENT, EOLINE, KYTYPE, * MATLEN, MATLLN, OCRDPT, SCRDPT, SQZIN, SUPOUT, * TCRDPT C C COMMON BLOCK: COUNT - NON-CHARACTER POINTER COUNTS. C C VARIABLE TYPE USE C -------- ------ ---------------------------------------- C FMTBAS I STARTING NUMBER FOR FORMAT LABELS C FMTINC I INCREMENT NUMBER FOR FORMAT LABELS C INCNT I NUMBER OF CARDS READ ON INPUT (EXCLUDING C COMMENT CARDS). C INDINC I NUMBER OF COLUMNS TO BE INDENTED FOR C EACH LEVEL OF INDENTATION. C LABASE I STARTING NUMBER FOR LABELS. C LABINC I INCREMENT NUMBER FOR LABELS. C LINELN I NUMBER OF COLUMNS PER LINE OF *NEW* FILE C OLDLEN I NUMBER OF COLUMNS PER LINE OF *OLD* FILE C PAGELN I NUMBER OF LINES PER OUTPUT PAGE C RINCNT I NUMBER OF SUPER-CARDS READ FOR THIS ROUTINE. C ROUCNT I NUMBER OF ROUTINES PROCESSED. C THISLN I NUMBER OF LINES PRESENTLY ON THE OUTPUT PAGE. C THISPG I PRESENT PAGE NUMBER. C TINCNT I TOTAL SUPER-CARDS READ. C TOUCNT I TOTAL CARDS WRITTEN TO RESULT FILE. C COMMON /COUNT/ FMTBAS, FMTINC, INCNT , INDINC, LABASE, LABINC, * LINELN, OLDLEN, PAGELN, RINCNT, ROUCNT, THISLN, * THISPG, TINCNT, TOUCNT C C COMMON BLOCK: LBDAT - LABEL PROCESSING VARIABLES. C C VARIABLE TYPE USE C -------- ------ ---------------------------------------- C DOCNT I NUMBER OF ACTIVE DO-LOOP LABELS C DOTBL I TABLE OF ACTIVE DO-LOOP LABELS C LBLCNT I NUMBER OF *DEFINED* LABELS IN TABLE C LBLTBL I HASHED LABEL TABLE (LBTLEN,3) WHERE C 1: DEFINED POSITION/NEW VALUE C 2: OLD VALUE C 3: FLAGS: 2-IF USED, 1-IF FORMAT C COMMON /LBDAT/ DOCNT, DOTBL(DOTLEN), LBLCNT, LBLTBL(LBTLEN,3) C C COMMON BLOCK: LOGVR - LOGICAL (TRUE/FALSE) FLAGS. C C VARIABLE TYPE USE C -------- ------ ---------------------------------------- C ADDCON L ADD =CONTINUE= TO DO LOOPS C BRKCOM L ARE NON-BLANK COMMENTS TO BE BRACKETED C COLFMT L ARE FORMATS TO BE COLLECTED AT THE END C CPYFLG L IS COPY BEING PERFORMED (IDENT ENCOUNTERED) C CVTHFI L ARE H-FIELDS TO BE CONVERTED TO QUOTED C STRINGS C DONERD L DONE READING (EOR/EOF HIT ON INPUT) C DOSTAT L DO STATUS REPORT C EXMCOM L EXEMPT COMMENT STATEMENTS FROM PROCESSING C EXMFMT L EXEMPT FORMAT STATEMENTS FROM PROCESSING C EXMNEX L EXEMPT NON-EXECUTABLE STATEMENTS FROM C PROCESSING C FIRSTC L IS THIS COMMENT THE FIRST COMMENT SINCE C THE LAST NON-COMMENT STATEMENT C HAVEXS L HAS AN EXECUTABLE STATEMENT BEEN SEEN IN C THIS ROUTINE C INDCOM L ARE COMMENTS TO BE INDENTED IF POSSIBLE C INDSTA L ARE STATEMENTS TO BE INDENTED IF POSSIBLE C ISFMT L IS THIS A =FORMAT= STATMENT BEING PARSED C ISSCOM L ARE COMMENTS TO BE ISSUED TO RESULT FILE C LASTBC L IS A LAST BLANK COMMENT NEEDED C LBTFUL L IS LABEL HASH TABLE FULL C LSTIDS L ARE ORIGINAL CARD IDS TO BE LISTED ON OUTPUT C LSTRES L IS RESULT FILE TO BE LISTED ON OUTPUT C LSTSRC L IS SOURCE FILE TO BE LISTED ON OUTPUT C MORE L IS THERE MORE PROCESSING NEEDED ON THIS C =IF= OR =WHERE= STATEMENT C NEEDRD L IS A READ FROM INPUT NEEDED C OVRLAY L WAS AN =OVERLAY= CARD DETECTED C PASS0 L IS THIS PASS 0 (PRESET - READ COMMAND FILE) C PASS1 L IS THIS PASS 1 OR PASS 2? C PROPCM L ARE COMMANDS TO BE PROPAGATED TO RESULT FILE C QUOTCV L ARE QUOTE MARKS TO BE CONVERTED C RJLABS L ARE LABELS TO BE RIGHT JUSTIFIED C ROUDON L IS THIS ROUTINE DONE C SIZDEF L ARE SPECIFICATION SIZES (E.G., REAL*8) OKAY C SPLTNV L MAY TOKENS BE SPLIT OVER TWO LINES C SPLTST L MAY STRINGS BE SPLIT OVER TWO LINES C UNCOND L IS SPECIAL PROCESSING BE DONE ON UNCONDITIONAL C CHANGES IN PROGRAM FLOW C VARUEC L ARE VARIABLES USING THE EXTENDED CHARACTER SET C WASCHF L WAS THIS FUNCTION A CHARACTER FUNCTION C WASCMD L IS THIS COMMENT A COMMAND C WASKEY L IS THIS A KEYWORD OR ASSIGNMENT STATEMENT C WASLAB L IS THERE A LABEL USED IN THIS LINE C WASSTR L IS THERE A STRING (QUOTED, HFIELD OR RFIELD) C USED IN THIS LINE C WASUNC L WAS AN UNCONDITION FLOW CHANGE DETECTED C WRBCOM L WAS A BLANK COMMENT JUST WRITTEN C WRCBLK L WAS THE COMMENT BLOCK WRITTEN TO SCRATCH C WRMSG1 L IS CONSOLE LINE 1 MESSAGE YET WRITTEN C WRTFMT L WAS A FORMAT WRITTEN ON COLLECTION FILE C XTRAST L IS THERE MORE THAN ONE STATEMENT IN =SUPRCD= C (I.E., DID WE HIT A =$=) C ZEND L HAS THE =END= CARD BEEN DETECTED C ZREAD L HAS ANYTHING (EXCEPT A COMMAND) BEEN READ C SINCE THE LAST =END= CARD C COMMON /LOGVR/ ADDCON, BRKCOM, COLFMT, CPYFLG, CVTHFI, DONERD, * DOSTAT, EXMCOM, EXMFMT, EXMNEX, FIRSTC, HAVEXS, * INDCOM, INDSTA, ISFMT , ISSCOM, LASTBC, LBTFUL, * LSTIDS, LSTRES, LSTSRC, MORE , NEEDRD, OVRLAY, * PASS0 , PASS1 , PROPCM, QUOTCV, RJLABS, ROUDON, * SIZDEF, SPLTNV, SPLTST, UNCOND, VARUEC, WASCHF, * WASCMD, WASKEY, WASLAB, WASSTR, WASUNC, WRBCOM, * WRCBLK, WRMSG1, WRTFMT, XTRAST, ZEND , ZREAD LOGICAL ADDCON, BRKCOM, COLFMT, CPYFLG, CVTHFI, DONERD, DOSTAT, * EXMCOM, EXMFMT, EXMNEX, FIRSTC, HAVEXS, INDCOM, INDSTA, * ISFMT , ISSCOM, LASTBC, LBTFUL, LSTIDS, LSTRES, LSTSRC, * MORE , NEEDRD, OVRLAY, PASS0 , PASS1 , PROPCM, QUOTCV, * RJLABS, ROUDON, SIZDEF, SPLTNV, SPLTST, UNCOND, VARUEC, * WASCHF, WASCMD, WASKEY, WASLAB, WASSTR, WASUNC, WRBCOM, * WRCBLK, WRMSG1, WRTFMT, XTRAST, ZEND , ZREAD C C *** /CHBLK/ *** C DATA EOS / '@' / DATA EXMCHR / '@' / DATA NUMLET / '0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZZZ' / DATA QUOTCH / DEFQUO / DATA RETPFX / DEFRET / DATA SPECHR / '+-*/()$=,.:;&[]"''' / DATA UNCONC / DEFUNC / C C *** /CHPTR/ *** C DATA COMLNB / COMLEN*0 / DATA COMPTR / 0 / DATA INDENT / 0 / DATA KYTYPE / 4 / DATA SCRDPT / 1 / DATA TCRDPT / 0 / C C *** /COUNT/ *** C DATA FMTBAS / 0 / DATA FMTINC / 10 / DATA INCNT / 0 / DATA INDINC / 3 / DATA LABASE / 10 / DATA LABINC / 10 / DATA LINELN / DEFLLN / DATA OLDLEN / DEFLLN / DATA PAGELN / DEFLPP / DATA RINCNT / 0 / DATA ROUCNT / 0 / DATA THISLN / 99 / DATA THISPG / 0 / DATA TINCNT / 0 / DATA TOUCNT / 0 / C C *** /LBDAT/ *** C DATA DOCNT / 0 / DATA DOTBL / DOTLEN*0 / DATA LBLCNT / 0 / DATA LBLTBL / LBTLN3*0 / C C *** /LOGVR/ *** C DATA ADDCON / .TRUE. / DATA BRKCOM / .TRUE. / DATA COLFMT / .FALSE. / DATA CPYFLG / .FALSE. / DATA CVTHFI / .TRUE. / DATA DONERD / .FALSE. / DATA DOSTAT / .TRUE. / DATA EXMCOM / .FALSE. / DATA EXMFMT / .FALSE. / DATA EXMNEX / .FALSE. / DATA FIRSTC / .FALSE. / DATA HAVEXS / .FALSE. / DATA INDCOM / .FALSE. / DATA INDSTA / .TRUE. / DATA ISFMT / .FALSE. / DATA ISSCOM / .TRUE. / DATA LASTBC / .FALSE. / DATA LBTFUL / .FALSE. / DATA LSTIDS / .FALSE. / DATA LSTRES / .TRUE. / DATA LSTSRC / .TRUE. / DATA MORE / .FALSE. / DATA NEEDRD / .TRUE. / DATA OVRLAY / .FALSE. / DATA PASS0 / .TRUE. / DATA PASS1 / .TRUE. / DATA PROPCM / .FALSE. / DATA QUOTCV / .TRUE. / DATA RJLABS / .TRUE. / DATA ROUDON / .FALSE. / DATA SIZDEF / .FALSE. / DATA SPLTNV / .FALSE. / DATA SPLTST / .FALSE. / DATA UNCOND / .FALSE. / DATA VARUEC / .FALSE. / DATA WASCHF / .FALSE. / DATA WASCMD / .FALSE. / DATA WASLAB / .FALSE. / DATA WASSTR / .FALSE. / DATA WASUNC / .FALSE. / DATA WRBCOM / .FALSE. / DATA WRCBLK / .FALSE. / DATA WRMSG1 / .FALSE. / DATA WRTFMT / .FALSE. / DATA XTRAST / .FALSE. / DATA ZEND / .FALSE. / DATA ZREAD / .FALSE. / C END SUBROUTINE COMMAN IMPLICIT INTEGER (A-Z) CHARACTER*1 DEFRET, DEFUNC, DEFQUO, STRSIG CHARACTER*2 VEXTCS C PARAMETER ( CMDLEN = 7 ) PARAMETER ( CMDMAX = 34 ) PARAMETER ( DEFLLN = 72 ) PARAMETER ( DEFLPP = 60 ) PARAMETER ( DEFQUO = '''' ) PARAMETER ( DEFRET = '*' ) PARAMETER ( DEFUNC = ' ' ) PARAMETER ( MAXLLN = 125 ) PARAMETER ( MAXVRL = 8 ) PARAMETER ( MINLLN = 40 ) PARAMETER ( MINLPP = 30 ) PARAMETER ( STRSIG = '?' ) PARAMETER ( VEXTCS = '$_' ) C C THIS ROUTINE PROCESSES COMMANDS. PARAMETER ( COMLEN = 100 ) PARAMETER ( SUPLEN = 1458 ) C COMMON /CHBLK/ CHAR1 , COMBLK, EOS , EXMCHR, HOLDCH, INLINE, * LN1MSG, LONGKY, NUMBER, NUMLET, QUOTCH, RETPFX, * SPECHR, SQZCRD, SUPRCD, TMPCRD, TMPSTR, UNCONC, * VARBLE CHARACTER*1 CHAR1, EOS, EXMCHR, HOLDCH, QUOTCH, RETPFX, UNCONC CHARACTER*17 SPECHR CHARACTER*38 NUMLET CHARACTER*40 LN1MSG, LONGKY, NUMBER, TMPSTR, VARBLE CHARACTER*126 COMBLK(COMLEN), INLINE CHARACTER*(SUPLEN) SQZCRD, SUPRCD, TMPCRD COMMON /CHPTR/ COMLNB(COMLEN), COMPTR, INDENT, EOLINE, KYTYPE, * MATLEN, MATLLN, OCRDPT, SCRDPT, SQZIN, SUPOUT, * TCRDPT COMMON /COUNT/ FMTBAS, FMTINC, INCNT , INDINC, LABASE, LABINC, * LINELN, OLDLEN, PAGELN, RINCNT, ROUCNT, THISLN, * THISPG, TINCNT, TOUCNT COMMON /LOGVR/ ADDCON, BRKCOM, COLFMT, CPYFLG, CVTHFI, DONERD, * DOSTAT, EXMCOM, EXMFMT, EXMNEX, FIRSTC, HAVEXS, * INDCOM, INDSTA, ISFMT , ISSCOM, LASTBC, LBTFUL, * LSTIDS, LSTRES, LSTSRC, MORE , NEEDRD, OVRLAY, * PASS0 , PASS1 , PROPCM, QUOTCV, RJLABS, ROUDON, * SIZDEF, SPLTNV, SPLTST, UNCOND, VARUEC, WASCHF, * WASCMD, WASKEY, WASLAB, WASSTR, WASUNC, WRBCOM, * WRCBLK, WRMSG1, WRTFMT, XTRAST, ZEND , ZREAD LOGICAL ADDCON, BRKCOM, COLFMT, CPYFLG, CVTHFI, DONERD, DOSTAT, * EXMCOM, EXMFMT, EXMNEX, FIRSTC, HAVEXS, INDCOM, INDSTA, * ISFMT , ISSCOM, LASTBC, LBTFUL, LSTIDS, LSTRES, LSTSRC, * MORE , NEEDRD, OVRLAY, PASS0 , PASS1 , PROPCM, QUOTCV, * RJLABS, ROUDON, SIZDEF, SPLTNV, SPLTST, UNCOND, VARUEC, * WASCHF, WASCMD, WASKEY, WASLAB, WASSTR, WASUNC, WRBCOM, * WRCBLK, WRMSG1, WRTFMT, XTRAST, ZEND , ZREAD C CHARACTER*(CMDLEN) CMDTBL(CMDMAX) INTEGER CMDUSE(CMDMAX) LOGICAL FLAG C DATA (CMDUSE(I),CMDTBL(I),I=1,CMDMAX) / * 7,'ADDCONT', 7,'BRACKET', 7,'COLLECT', 4,'COPY ', * 7,'EXEMPTC', 7,'EXEMPTF', 7,'EXEMPTN', 7,'EXEMPTS', * 7,'FORMATB', 7,'FORMATI', 6,'HFIELD ', 7,'INDENTC', * 7,'INDENTI', 7,'INDENTS', 6,'ISSUEC ', 6,'LABELB ', * 6,'LABELI ', 5,'LEFTJ ', 7,'LINELEN', 7,'LISTIDS', * 7,'LISTNEW', 7,'LISTOLD', 6,'OLDLEN ', 7,'PAGELEN', * 4,'PROP ', 7,'QUOTECH', 7,'RETPRFX', 6,'RIGHTJ ', * 7,'SIZEDEF', 7,'SPLITNV', 7,'SPLITST', 6,'STATUS ', * 6,'UNCOND ', 7,'VARUECS' / C C ASSUME NOT A COMMAND C WASCMD = .FALSE. C C IF NOT BEFORE FIRST CARD OF ROUTINE, NOT COMMAND. C IF (RINCNT .NE. 0) RETURN C C COPY TO SUPRCD AND ADD E-O-S. C SUPRCD(1:SCRDPT+1) = INLINE(1:SCRDPT) // EOS SUPOUT = 2 C C SET ENABLE/DISABLE FLAG C CALL GETNBC IF (CHAR1 .EQ. '+') THEN FLAG = .TRUE. ELSE FLAG = .FALSE. ENDIF C C GET THE COMMAND C CALL GETVAR (.TRUE.,LENGTH) C C TRY FOR MATCH WITH COMMAND TABLE. C IF NO MATCH, RETURN. C IF MATCH, TAKE APPROPRIATE ACTION. C DO 20 I = 1 , CMDMAX J = CMDUSE(I) IF (VARBLE(1:J) .EQ. CMDTBL(I)) GO TO 30 20 CONTINUE RETURN C C IT WAS A COMMAND. FLAG IT SO AND PROCESS IT. C 30 WASCMD = .TRUE. NUMBER = ' ' LENGTH = 0 GO TO ( 40, 50, 60, 70, 80, 90, 100, 110, 140, 150, * 160, 170, 180, 190, 200, 210, 220, 230, 240, 250, * 260, 270, 275, 280, 290, 295, 300, 320, 330, 340, * 350, 360, 370, 390) * , I C C ADDCONT - ADD =CONTINUE= CARDS AT THE END OF DO-LOOPS C 40 ADDCON = FLAG RETURN C C BRACKET - BRACKET NON-BLANK COMMENTS WITH BLANK COMMENTS C 50 BRKCOM = FLAG RETURN C C COLLECT - COLLECT FORMAT AND PLACE THEM JUST BEFORE THE C =END= CARD. C 60 COLFMT = FLAG RETURN C C COPY - COPY ROUTINE WITH NO PROCESSING. C 70 CPYFLG = FLAG IF (FLAG) THEN LN1MSG = 'CLEAN: COPY: FORTRAN' ENDIF RETURN C C EXEMPTC - EXEMPT COMMENTS FROM PROCESSING. C 80 EXMCOM = FLAG RETURN C C EXEMPTF - EXEMPT FORMATS FROM PROCESSING. C 90 EXMFMT = FLAG RETURN C C EXEMPTN - EXEMPT NON-EXECUTABLE STATEMENTS FROM PROCESSING. C 100 EXMNEX = FLAG RETURN C C EXEMPTS=CHAR - EXEMPT STATEMENTS STARTING WITH *CHAR*. C 110 IF (FLAG) THEN IF (CHAR1 .NE. EOS) CALL GETNBC IF (INDEX(NUMLET,CHAR1).EQ.0 .AND. CHAR1.NE.EOS) THEN EXMCHR = CHAR1 ELSE EXMCHR = EOS IF (LSTSRC) THEN CALL PAGECK(3) WRITE (2,130) 130 FORMAT (/10X,'** =EXEMPTS= CANNOT BE ALPHANUMERIC/BLANK', * ' **'/) ENDIF ENDIF ELSE EXMCHR = EOS ENDIF RETURN C C FORMATB=N - STARTING FORMAT LABEL IS *N*. C 140 IF (FLAG) THEN IF (CHAR1 .NE. EOS) CALL GETNUM (.TRUE.,LENGTH) FMTBAS = CVTNUM (NUMBER,LENGTH) ELSE FMTBAS = 0 ENDIF RETURN C C FORMATI=N - INCREMENT FORMAT LABELS BY *N*. C 150 IF (FLAG) THEN IF (CHAR1 .NE. EOS) CALL GETNUM (.TRUE.,LENGTH) FMTINC = CVTNUM (NUMBER,LENGTH) ELSE FMTINC = 10 ENDIF RETURN C C HFIELD - CONVERT HFIELDS TO QUOTED STRINGS. C 160 CVTHFI = FLAG RETURN C C INDENTC - INDENT COMMENTS EVEN WITH NON-COMMENTS. C 170 INDCOM = FLAG RETURN C C INDENTI=N - INDENTATION INCREMENT IS *N*. C 180 IF (FLAG) THEN IF (CHAR1 .NE. EOS) CALL GETNUM (.TRUE.,LENGTH) INDINC = CVTNUM (NUMBER,LENGTH) IF (INDINC .GT. 5) INDINC = 5 ELSE INDINC = 0 ENDIF RETURN C C INDENTS - INDENT STATEMENTS. C 190 INDSTA = FLAG RETURN C C ISSUEC - ISSUE COMMENTS. C 200 ISSCOM = FLAG RETURN C C LABELB=N - STARTING LABEL IS *N*. C 210 IF (FLAG) THEN IF (CHAR1 .NE. EOS) CALL GETNUM (.TRUE.,LENGTH) LABASE = CVTNUM (NUMBER,LENGTH) IF (LABASE .EQ. 0) LABASE = LABINC ELSE LABASE = 10 ENDIF RETURN C C LABELI=N - INCREMENT LABELS BY *N*. C 220 IF (FLAG) THEN IF (CHAR1 .NE. EOS) CALL GETNUM (.TRUE.,LENGTH) LABINC = CVTNUM (NUMBER,LENGTH) ELSE LABINC = 0 ENDIF RETURN C C LEFTJ - LEFT JUSTIFY LABELS. C 230 RJLABS = .NOT. FLAG RETURN C C LINELEN=N - COLUMNS PER LINE OF =NEW= FILE IS *N*. C 240 IF (FLAG) THEN IF (CHAR1 .NE. EOS) CALL GETNUM (.TRUE.,LENGTH) LINELN = CVTNUM (NUMBER,LENGTH) IF (LINELN .LT. MINLLN) THEN LINELN = MINLLN ELSEIF (LINELN .GT. MAXLLN) THEN LINELN = MAXLLN ENDIF ELSE LINELN = DEFLLN ENDIF RETURN C C LISTIDS - LIST OLD (SOURCE) FILE CARD IDS ON OUTPUT. C 250 LSTIDS = FLAG RETURN C C LISTNEW - LIST NEW (RESULT) FILE ON OUTPUT. C 260 LSTRES = FLAG RETURN C C LISTOLD - LIST OLD (SOURCE) FILE ON OUTPUT. C 270 LSTSRC = FLAG RETURN C C OLDLEN=N - COLUMNS PER LINE OF =OLD= FILE IS *N*. C 275 IF (FLAG) THEN IF (CHAR1 .NE. EOS) CALL GETNUM (.TRUE.,LENGTH) OLDLEN = CVTNUM (NUMBER,LENGTH) IF (OLDLEN .LT. MINLLN) THEN OLDLEN = MINLLN ELSEIF (OLDLEN .GT. MAXLLN) THEN OLDLEN = MAXLLN ENDIF ELSE OLDLEN = DEFLLN ENDIF RETURN C C PAGELEN=N - LINES PER PAGE ON LISTING IS *N*. C 280 IF (FLAG) THEN IF (CHAR1 .NE. EOS) CALL GETNUM (.TRUE.,LENGTH) PAGELN = CVTNUM (NUMBER,LENGTH) IF (PAGELN .LT. MINLPP) PAGELN = MINLPP ELSE PAGELN = DEFLPP ENDIF RETURN C C PROP - PROPAGATE COMMANDS ONTO RESULT FILE. C 290 PROPCM = FLAG RETURN C C QUOTECH=X - CONVERT QUOTED STRINGS TO USE *X*. C 295 IF (FLAG) THEN IF (CHAR1 .NE. EOS) CALL GETNBC IF (CHAR1 .NE. EOS) THEN QUOTCH = CHAR1 ELSE QUOTCH = DEFQUO ENDIF ELSE QUOTCH = DEFQUO ENDIF QUOTCV = FLAG RETURN C C RETPRFX=X - ALTERNATE RETURN LABEL PREFIX IS *X*. C 300 IF (FLAG) THEN IF (CHAR1 .NE. EOS) CALL GETNBC IF (CHAR1 .NE. EOS) THEN RETPFX = CHAR1 ELSE RETPFX = DEFRET ENDIF ELSE RETPFX = DEFRET ENDIF RETURN C C RIGHTJ - RIGHT JUSTIFY LABELS. C 320 RJLABS = FLAG RETURN C C SIZEDEF - PERMIT SIZE DEFINITIONS ON SPECIFICATION STATEMENTS C 330 SIZDEF = FLAG RETURN C C SPLITNV - SPLIT NUMS AND VARS ACROSS TWO LINES. C 340 SPLTNV = FLAG RETURN C C SPLITST - SPLIT STRINGS ACROSS TWO LINES. C 350 SPLTST = FLAG RETURN C C STATUS - ISSUE STATUS OF CLEAN77 ENVIRONMENT. C 360 DOSTAT = FLAG RETURN C C UNCOND=X - LINE TO FOLLOW UNCONDITIONAL FLOW CHANGE IS *X*. C 370 IF (FLAG) THEN IF (CHAR1 .NE. EOS) CALL GETNBC IF (CHAR1 .NE. EOS) THEN UNCONC = CHAR1 ELSE UNCONC = DEFUNC ENDIF ENDIF UNCOND = FLAG RETURN C C VARUECS - VARIABLES USE EXTENDED CHARACTER SET. C 390 IF (FLAG) THEN NUMLET(37:38) = VEXTCS ELSE NUMLET(37:38) = 'ZZ' ENDIF VARUEC = FLAG RETURN C END SUBROUTINE COMMEN IMPLICIT INTEGER (A-Z) C C THIS ROUTINE PROCESSES COMMENT CARDS. C PARAMETER ( COMLEN = 100 ) PARAMETER ( SUPLEN = 1458 ) C COMMON /CHBLK/ CHAR , COMBLK, EOS , EXMCHR, HOLDCH, INLINE, * LN1MSG, LONGKY, NUMBER, NUMLET, QUOTCH, RETPFX, * SPECHR, SQZCRD, SUPRCD, TMPCRD, TMPSTR, UNCONC, * VARBLE CHARACTER*1 CHAR, EOS, EXMCHR, HOLDCH, QUOTCH, RETPFX, UNCONC CHARACTER*17 SPECHR CHARACTER*38 NUMLET CHARACTER*40 LN1MSG, LONGKY, NUMBER, TMPSTR, VARBLE CHARACTER*126 COMBLK(COMLEN), INLINE CHARACTER*(SUPLEN) SQZCRD, SUPRCD, TMPCRD COMMON /CHPTR/ COMLNB(COMLEN), COMPTR, INDENT, EOLINE, KYTYPE, * MATLEN, MATLLN, OCRDPT, SCRDPT, SQZIN, SUPOUT, * TCRDPT COMMON /COUNT/ FMTBAS, FMTINC, INCNT , INDINC, LABASE, LABINC, * LINELN, OLDLEN, PAGELN, RINCNT, ROUCNT, THISLN, * THISPG, TINCNT, TOUCNT COMMON /LOGVR/ ADDCON, BRKCOM, COLFMT, CPYFLG, CVTHFI, DONERD, * DOSTAT, EXMCOM, EXMFMT, EXMNEX, FIRSTC, HAVEXS, * INDCOM, INDSTA, ISFMT , ISSCOM, LASTBC, LBTFUL, * LSTIDS, LSTRES, LSTSRC, MORE , NEEDRD, OVRLAY, * PASS0 , PASS1 , PROPCM, QUOTCV, RJLABS, ROUDON, * SIZDEF, SPLTNV, SPLTST, UNCOND, VARUEC, WASCHF, * WASCMD, WASKEY, WASLAB, WASSTR, WASUNC, WRBCOM, * WRCBLK, WRMSG1, WRTFMT, XTRAST, ZEND , ZREAD LOGICAL ADDCON, BRKCOM, COLFMT, CPYFLG, CVTHFI, DONERD, DOSTAT, * EXMCOM, EXMFMT, EXMNEX, FIRSTC, HAVEXS, INDCOM, INDSTA, * ISFMT , ISSCOM, LASTBC, LBTFUL, LSTIDS, LSTRES, LSTSRC, * MORE , NEEDRD, OVRLAY, PASS0 , PASS1 , PROPCM, QUOTCV, * RJLABS, ROUDON, SIZDEF, SPLTNV, SPLTST, UNCOND, VARUEC, * WASCHF, WASCMD, WASKEY, WASLAB, WASSTR, WASUNC, WRBCOM, * WRCBLK, WRMSG1, WRTFMT, XTRAST, ZEND , ZREAD C CHARACTER*1 TMPCHR LOGICAL POSCMD, THISBC C C SAVE FIRST CHARACTER FOR LISTING C TMPCHR = INLINE(1:1) C C CHECK FOR COMMENT BEING BLANK. C IF (EOLINE .EQ. 0) THEN SCRDPT = OLDLEN ELSE SCRDPT = EOLINE ENDIF POSCMD = .FALSE. WASCMD = .FALSE. IF (SCRDPT .EQ. 1 .OR. EOLINE .EQ. 0) THEN THISBC = .TRUE. ELSE THISBC = .FALSE. IF (INLINE(1:2) .EQ. 'C+' .OR. INLINE(1:2) .EQ. 'C-') * POSCMD = .TRUE. ENDIF OLDTMP = OLDLEN INLINE(OLDLEN+1:) = ' ' C C SEE IF WE DID JUST ISSUE A BLANK (2:OLDLEN) COMMENT CARD. C IF (LASTBC) THEN IF (POSCMD) CALL COMMAN IF (.NOT.PASS0 .AND. ((.NOT.WASCMD) .OR. PROPCM)) THEN IF (.NOT.CPYFLG.AND. .NOT.(EXMCOM .OR. TMPCHR.EQ.EXMCHR) * .AND. EOLINE.NE.0) INLINE(1:1) = 'C' IF (ISSCOM .OR. CPYFLG .OR. (WASCMD .AND. PROPCM)) THEN CALL PUTCOM (INLINE,SCRDPT) IF (.NOT.THISBC) THEN LASTBC = .FALSE. WRBCOM = .FALSE. ENDIF ENDIF ENDIF ELSE C C NO WE DID NOT, SO WRITE THIS ONE (UNLESS CMD + NOT PROPAGATING) C PRECEDE THIS CARD WITH A BLANK COMMENT IF: C A) THIS CARD IS NOT A BLANK COMMENT, *** AND *** C B) THIS IS THE FIRST COMMENT CARD SINCE THE LAST C NON-COMMENT CARD. C IF (THISBC) THEN LASTBC = .TRUE. WRBCOM = .TRUE. IF (EOLINE.EQ.0 .AND. .NOT.CPYFLG .AND. ISSCOM .AND. * BRKCOM .AND. .NOT.FIRSTC) CALL PUTCOM ('C',1) ELSE WRBCOM = .FALSE. IF (POSCMD) CALL COMMAN IF (.NOT.CPYFLG .AND.ISSCOM .AND. .NOT.WASCMD .AND. BRKCOM * .AND. FIRSTC) CALL PUTCOM ('C',1) ENDIF IF ((.NOT.WASCMD) .OR. PROPCM) THEN IF (.NOT.CPYFLG .AND. .NOT.(EXMCOM .OR. TMPCHR.EQ.EXMCHR) * .AND. EOLINE.NE.0) INLINE(1:1) = 'C' IF (CPYFLG .OR. ISSCOM) CALL PUTCOM (INLINE,SCRDPT) ENDIF ENDIF C C IF TO LIST ORIGINAL CARDS, DO SO. C IF (LSTSRC .OR. (.NOT.PASS0 .AND. DOSTAT .AND. LSTRES)) THEN IF (.NOT.PASS1) THEN PASS1 = .TRUE. CALL PAGECK (-1) ELSE CALL PAGECK (1) ENDIF INLINE(1:1) = TMPCHR IF (LSTIDS) THEN WRITE (2,20) INLINE ELSE WRITE (2,20) INLINE(1:OLDTMP) ENDIF 20 FORMAT (7X,A) IF (.NOT.PASS0 .AND. DOSTAT) CALL DMPSTA ENDIF IF (.NOT.PASS1) PASS1 = .TRUE. C C INDICATE A COMMENT APPEARED (IF NOT A COMMAND OR BLANK LINE). C IF (WASCMD .OR. EOLINE.EQ.0) THEN FIRSTC = .TRUE. ELSE FIRSTC = .FALSE. ENDIF IF (.NOT.WASCMD) ZREAD = .TRUE. RETURN C END SUBROUTINE CVTLAB (LABEL,LENGTH,RJUST) IMPLICIT INTEGER (A-Z) C C THIS ROUTINE CONVERTS =LABEL= TO A STRING IN =TMPSTR=. C IT RETURNS THE LENGTH OF THE STRING IN =LENGTH=. IF =RJUST= C IS TRUE, A 5 CHARACTER, RIGHT JUSTIFIED NUMBER IS GENERATED. C IF =RJUST= IS FALSE, A LEFT JUSTIFIED STRING OF 1-5 CHARACTERS C IS BUILT. C PARAMETER ( COMLEN = 100 ) PARAMETER ( SUPLEN = 1458 ) C COMMON /CHBLK/ CHAR , COMBLK, EOS , EXMCHR, HOLDCH, INLINE, * LN1MSG, LONGKY, NUMBER, NUMLET, QUOTCH, RETPFX, * SPECHR, SQZCRD, SUPRCD, TMPCRD, TMPSTR, UNCONC, * VARBLE CHARACTER*1 CHAR, EOS, EXMCHR, HOLDCH, QUOTCH, RETPFX, UNCONC CHARACTER*17 SPECHR CHARACTER*38 NUMLET CHARACTER*40 LN1MSG, LONGKY, NUMBER, TMPSTR, VARBLE CHARACTER*126 COMBLK(COMLEN), INLINE CHARACTER*(SUPLEN) SQZCRD, SUPRCD, TMPCRD C LOGICAL RJUST C LAB = LABEL TMPSTR = ' ' I = 5 10 INDX = MOD(LAB,10) + 1 TMPSTR(I:I) = NUMLET(INDX:INDX) LAB = LAB / 10 I = I - 1 IF (LAB .NE. 0) GO TO 10 IF (RJUST .OR. I .EQ. 0) THEN LENGTH = 5 ELSE LENGTH = 5 - I DO 20 INDX = 1 , LENGTH TMPSTR(INDX:INDX) = TMPSTR(INDX+I:INDX+I) 20 CONTINUE TMPSTR(LENGTH+1:5) = ' ' ENDIF RETURN C END INTEGER FUNCTION CVTNUM (STRING,STRLEN) IMPLICIT INTEGER (A-Z) C C THIS FUNCTION RETURNS AS ITS VALUE THE BINARY CONVERSION C OF THE DECIMAL INTEGER WHOSE CHARACTERS MAKE UP THE FIRST C =STRLEN= CHARACTERS OF =STRING=. C PARAMETER ( COMLEN = 100 ) PARAMETER ( SUPLEN = 1458 ) C COMMON /CHBLK/ CHAR , COMBLK, EOS , EXMCHR, HOLDCH, INLINE, * LN1MSG, LONGKY, NUMBER, NUMLET, QUOTCH, RETPFX, * SPECHR, SQZCRD, SUPRCD, TMPCRD, TMPSTR, UNCONC, * VARBLE CHARACTER*1 CHAR, EOS, EXMCHR, HOLDCH, QUOTCH, RETPFX, UNCONC CHARACTER*17 SPECHR CHARACTER*38 NUMLET CHARACTER*40 LN1MSG, LONGKY, NUMBER, TMPSTR, VARBLE CHARACTER*126 COMBLK(COMLEN), INLINE CHARACTER*(SUPLEN) SQZCRD, SUPRCD, TMPCRD C CHARACTER*(*) STRING C TEMP = 0 DO 10 I = 1 , STRLEN HOLDCH = STRING(I:I) IF (HOLDCH .EQ. ' ') GO TO 10 TEMP = TEMP*10 + INDEX(NUMLET,HOLDCH)-1 10 CONTINUE C CVTNUM = TEMP RETURN C END SUBROUTINE DMPCOM IMPLICIT INTEGER (A-Z) C C THIS ROUTINE COPIES THE COLLECTED COMMENTS TO THE SCRATCH FILE. C PARAMETER ( COMLEN = 100 ) PARAMETER ( SUPLEN = 1458 ) C COMMON /CHBLK/ CHAR , COMBLK, EOS , EXMCHR, HOLDCH, INLINE, * LN1MSG, LONGKY, NUMBER, NUMLET, QUOTCH, RETPFX, * SPECHR, SQZCRD, SUPRCD, TMPCRD, TMPSTR, UNCONC, * VARBLE CHARACTER*1 CHAR, EOS, EXMCHR, HOLDCH, QUOTCH, RETPFX, UNCONC CHARACTER*17 SPECHR CHARACTER*38 NUMLET CHARACTER*40 LN1MSG, LONGKY, NUMBER, TMPSTR, VARBLE CHARACTER*126 COMBLK(COMLEN), INLINE CHARACTER*(SUPLEN) SQZCRD, SUPRCD, TMPCRD COMMON /CHPTR/ COMLNB(COMLEN), COMPTR, INDENT, EOLINE, KYTYPE, * MATLEN, MATLLN, OCRDPT, SCRDPT, SQZIN, SUPOUT, * TCRDPT COMMON /LOGVR/ ADDCON, BRKCOM, COLFMT, CPYFLG, CVTHFI, DONERD, * DOSTAT, EXMCOM, EXMFMT, EXMNEX, FIRSTC, HAVEXS, * INDCOM, INDSTA, ISFMT , ISSCOM, LASTBC, LBTFUL, * LSTIDS, LSTRES, LSTSRC, MORE , NEEDRD, OVRLAY, * PASS0 , PASS1 , PROPCM, QUOTCV, RJLABS, ROUDON, * SIZDEF, SPLTNV, SPLTST, UNCOND, VARUEC, WASCHF, * WASCMD, WASKEY, WASLAB, WASSTR, WASUNC, WRBCOM, * WRCBLK, WRMSG1, WRTFMT, XTRAST, ZEND , ZREAD LOGICAL ADDCON, BRKCOM, COLFMT, CPYFLG, CVTHFI, DONERD, DOSTAT, * EXMCOM, EXMFMT, EXMNEX, FIRSTC, HAVEXS, INDCOM, INDSTA, * ISFMT , ISSCOM, LASTBC, LBTFUL, LSTIDS, LSTRES, LSTSRC, * MORE , NEEDRD, OVRLAY, PASS0 , PASS1 , PROPCM, QUOTCV, * RJLABS, ROUDON, SIZDEF, SPLTNV, SPLTST, UNCOND, VARUEC, * WASCHF, WASCMD, WASKEY, WASLAB, WASSTR, WASUNC, WRBCOM, * WRCBLK, WRMSG1, WRTFMT, XTRAST, ZEND , ZREAD C CHARACTER*72 STRING C C IF ANYTHING IS ON THE COMMENT SCRATCH FILE, DUMP IT FIRST C IF (WRCBLK) THEN ENDFILE 9 REWIND 9 10 READ (9,END=20) STRLEN READ (9) STRING(1:STRLEN) WRITE (8) STRLEN, 0, 0, .FALSE., .FALSE. WRITE (8) STRING(1:STRLEN) GO TO 10 C 20 REWIND 9 ENDIF C DO 30 I = 1 , COMPTR WRITE (8) COMLNB(I), 0, 0, .FALSE., .FALSE. WRITE (8) COMBLK(I)(1:COMLNB(I)) 30 CONTINUE C COMPTR = 0 WRCBLK = .FALSE. RETURN C END SUBROUTINE DMPFMT IMPLICIT INTEGER (A-Z) C C THIS ROUTINES COPIES THE COLLECTED FORMATS TO THE SCRATCH FILE. C PARAMETER ( COMLEN = 100 ) PARAMETER ( SUPLEN = 1458 ) C COMMON /CHBLK/ CHAR , COMBLK, EOS , EXMCHR, HOLDCH, INLINE, * LN1MSG, LONGKY, NUMBER, NUMLET, QUOTCH, RETPFX, * SPECHR, SQZCRD, SUPRCD, TMPCRD, TMPSTR, UNCONC, * VARBLE CHARACTER*1 CHAR, EOS, EXMCHR, HOLDCH, QUOTCH, RETPFX, UNCONC CHARACTER*17 SPECHR CHARACTER*38 NUMLET CHARACTER*40 LN1MSG, LONGKY, NUMBER, TMPSTR, VARBLE CHARACTER*126 COMBLK(COMLEN), INLINE CHARACTER*(SUPLEN) SQZCRD, SUPRCD, TMPCRD COMMON /CHPTR/ COMLNB(COMLEN), COMPTR, INDENT, EOLINE, KYTYPE, * MATLEN, MATLLN, OCRDPT, SCRDPT, SQZIN, SUPOUT, * TCRDPT COMMON /LOGVR/ ADDCON, BRKCOM, COLFMT, CPYFLG, CVTHFI, DONERD, * DOSTAT, EXMCOM, EXMFMT, EXMNEX, FIRSTC, HAVEXS, * INDCOM, INDSTA, ISFMT , ISSCOM, LASTBC, LBTFUL, * LSTIDS, LSTRES, LSTSRC, MORE , NEEDRD, OVRLAY, * PASS0 , PASS1 , PROPCM, QUOTCV, RJLABS, ROUDON, * SIZDEF, SPLTNV, SPLTST, UNCOND, VARUEC, WASCHF, * WASCMD, WASKEY, WASLAB, WASSTR, WASUNC, WRBCOM, * WRCBLK, WRMSG1, WRTFMT, XTRAST, ZEND , ZREAD LOGICAL ADDCON, BRKCOM, COLFMT, CPYFLG, CVTHFI, DONERD, DOSTAT, * EXMCOM, EXMFMT, EXMNEX, FIRSTC, HAVEXS, INDCOM, INDSTA, * ISFMT , ISSCOM, LASTBC, LBTFUL, LSTIDS, LSTRES, LSTSRC, * MORE , NEEDRD, OVRLAY, PASS0 , PASS1 , PROPCM, QUOTCV, * RJLABS, ROUDON, SIZDEF, SPLTNV, SPLTST, UNCOND, VARUEC, * WASCHF, WASCMD, WASKEY, WASLAB, WASSTR, WASUNC, WRBCOM, * WRCBLK, WRMSG1, WRTFMT, XTRAST, ZEND , ZREAD C LOGICAL L1, L2 C ENDFILE 7 REWIND 7 K = KYTYPE KYTYPE = 5 NUMBER = SUPRCD(1:6) IF (ISSCOM .AND. BRKCOM .AND. .NOT.WRBCOM) THEN WRITE (8) 1, 0, 0, .FALSE., .FALSE. WRITE (8) 'C' ENDIF C 10 READ (7,END=20) IPTR,JLAB,I3,L1,L2 CALL LBHASH (JLAB,.TRUE.) WRITE (8) IPTR,JLAB,I3,L1,L2 READ (7) SUPRCD(1:IPTR) WRITE (8) SUPRCD(1:IPTR) GO TO 10 C 20 REWIND 7 WRTFMT = .FALSE. KYTYPE = K SUPRCD(1:6) = NUMBER IF (ISSCOM .AND. BRKCOM) THEN WRITE (8) 1, 0, 0, .FALSE., .FALSE. WRITE (8) 'C' ENDIF RETURN C END SUBROUTINE DMPLAB IMPLICIT INTEGER (A-Z) C CHARACTER*1 LABSIG C PARAMETER ( DOTLEN = 30 ) PARAMETER ( INDMAX = 30 ) C PARAMETER ( LABSIG = '\' ) PARAMETER ( LBTLEN = 509 ) PARAMETER ( LBTLN3 = 3*LBTLEN ) C C THIS ROUTINE DUMPS THE LABEL TABLE =LBLTBL=. C PARAMETER ( COMLEN = 100 ) PARAMETER ( SUPLEN = 1458 ) C COMMON /CHBLK/ CHAR , COMBLK, EOS , EXMCHR, HOLDCH, INLINE, * LN1MSG, LONGKY, NUMBER, NUMLET, QUOTCH, RETPFX, * SPECHR, SQZCRD, SUPRCD, TMPCRD, TMPSTR, UNCONC, * VARBLE CHARACTER*1 CHAR, EOS, EXMCHR, HOLDCH, QUOTCH, RETPFX, UNCONC CHARACTER*17 SPECHR CHARACTER*38 NUMLET CHARACTER*40 LN1MSG, LONGKY, NUMBER, TMPSTR, VARBLE CHARACTER*126 COMBLK(COMLEN), INLINE CHARACTER*(SUPLEN) SQZCRD, SUPRCD, TMPCRD COMMON /COUNT/ FMTBAS, FMTINC, INCNT , INDINC, LABASE, LABINC, * LINELN, OLDLEN, PAGELN, RINCNT, ROUCNT, THISLN, * THISPG, TINCNT, TOUCNT C C COMMON BLOCK: LBDAT - LABEL PROCESSING VARIABLES. C C VARIABLE TYPE USE C -------- ------ ---------------------------------------- C DOCNT I NUMBER OF ACTIVE DO-LOOP LABELS C DOTBL I TABLE OF ACTIVE DO-LOOP LABELS C LBLCNT I NUMBER OF *DEFINED* LABELS IN TABLE C LBLTBL I HASHED LABEL TABLE (LBTLEN,3) WHERE C 1: DEFINED POSITION/NEW VALUE C 2: OLD VALUE C 3: FLAGS: 2-IF USED, 1-IF FORMAT C COMMON /LBDAT/ DOCNT, DOTBL(DOTLEN), LBLCNT, LBLTBL(LBTLEN,3) COMMON /LOGVR/ ADDCON, BRKCOM, COLFMT, CPYFLG, CVTHFI, DONERD, * DOSTAT, EXMCOM, EXMFMT, EXMNEX, FIRSTC, HAVEXS, * INDCOM, INDSTA, ISFMT , ISSCOM, LASTBC, LBTFUL, * LSTIDS, LSTRES, LSTSRC, MORE , NEEDRD, OVRLAY, * PASS0 , PASS1 , PROPCM, QUOTCV, RJLABS, ROUDON, * SIZDEF, SPLTNV, SPLTST, UNCOND, VARUEC, WASCHF, * WASCMD, WASKEY, WASLAB, WASSTR, WASUNC, WRBCOM, * WRCBLK, WRMSG1, WRTFMT, XTRAST, ZEND , ZREAD LOGICAL ADDCON, BRKCOM, COLFMT, CPYFLG, CVTHFI, DONERD, DOSTAT, * EXMCOM, EXMFMT, EXMNEX, FIRSTC, HAVEXS, INDCOM, INDSTA, * ISFMT , ISSCOM, LASTBC, LBTFUL, LSTIDS, LSTRES, LSTSRC, * MORE , NEEDRD, OVRLAY, PASS0 , PASS1 , PROPCM, QUOTCV, * RJLABS, ROUDON, SIZDEF, SPLTNV, SPLTST, UNCOND, VARUEC, * WASCHF, WASCMD, WASKEY, WASLAB, WASSTR, WASUNC, WRBCOM, * WRCBLK, WRMSG1, WRTFMT, XTRAST, ZEND , ZREAD C LOGICAL NEWLAB, SWAP C C DETERMINE IF LABELS SHOULD BE PROCESSED C IF (LBTFUL.OR.CPYFLG) RETURN IF (LABINC .EQ. 0) THEN IF (LSTSRC) THEN CALL PAGECK(3) WRITE (2,260) ENDIF RETURN ENDIF C C STEP 1: CONDENSE THE TABLE C IN = 0 OUT = 1 10 IF (LBLTBL(OUT,1) .NE. 0) THEN IN = IN + 1 IF (IN .NE. OUT) THEN DO 20 I = 1 , 3 LBLTBL(IN,I) = LBLTBL(OUT,I) LBLTBL(OUT,I) = 0 20 CONTINUE ENDIF ENDIF OUT = OUT + 1 IF (OUT .LE. LBTLEN) GO TO 10 IF (IN .EQ. 0) RETURN C C STEP 2: SORT DECENDING BY LBLTBL(X,3) C IF (IN .GT. 1) THEN DO 50 I = 1 , IN SWAP = .FALSE. DO 40 J = 1 , IN-1 IF (LBLTBL(J,3) .LT. LBLTBL(J+1,3)) THEN DO 30 K = 1 , 3 ITEMP = LBLTBL(J,K) LBLTBL(J,K) = LBLTBL(J+1,K) LBLTBL(J+1,K) = ITEMP 30 CONTINUE SWAP = .TRUE. ENDIF 40 CONTINUE IF (.NOT.SWAP) GO TO 60 50 CONTINUE ENDIF C C STEP 3: GET POINTER TO LAST =3= (USED+FMT) AND =2= (USED). C 60 LAST3 = 0 LAST2 = 0 DO 70 I = 1 , IN ITEMP = LBLTBL(I,3) IF (ITEMP .EQ. 1) GO TO 80 IF (ITEMP .EQ. 2) LAST2 = LAST2 + 1 IF (ITEMP .EQ. 3) THEN LAST3 = LAST3 + 1 LAST2 = LAST2 + 1 ENDIF 70 CONTINUE C C STEP 4: INSURE NO OVERLAP OR LABEL TOO LARGE (>99999) C 80 IF (LAST2+LAST3 .EQ. 0) GO TO 170 IF (FMTBAS .EQ. 0 .OR. LAST3 .EQ. 0) THEN IF (LABASE+(LAST2-1)*LABINC .GT. 99999) THEN LBTFUL = .TRUE. ELSE LAST3 = 0 ENDIF ELSEIF (LAST2 .EQ. LAST3) THEN IF (FMTBAS+(LAST3-1)*FMTINC .GT. 99999) LBTFUL = .TRUE. ELSE IF (LABASE .LT. FMTBAS) THEN IF (LABASE+(LAST2-LAST3-1)*LABINC .GE. FMTBAS .OR. * FMTBAS+(LAST3-1)*FMTINC .GT. 99999) LBTFUL = .TRUE. ELSE IF (FMTBAS+(LAST3-1)*FMTINC .GE. LABASE .OR. * LABASE+(LAST2-LAST3-1)*LABINC .GT. 99999) LBTFUL=.TRUE. ENDIF ENDIF IF (LBTFUL) THEN IF (LSTSRC) THEN CALL PAGECK (3) WRITE (2,90) 90 FORMAT (//10X,'*** GENERATED LABELS OVERLAP OR > 99999 ***') ENDIF RETURN C ENDIF C C STEP 5: SORT 3'S BY POSITION C IF (LAST3 .GT. 1) THEN DO 120 I = 1 , LAST3 SWAP = .FALSE. DO 110 J = 1 , LAST3-1 IF (LBLTBL(J,1) .GT. LBLTBL(J+1,1)) THEN DO 100 K = 1 , 3 ITEMP = LBLTBL(J,K) LBLTBL(J,K) = LBLTBL(J+1,K) LBLTBL(J+1,K) = ITEMP 100 CONTINUE SWAP = .TRUE. ENDIF 110 CONTINUE IF (.NOT.SWAP) GO TO 130 120 CONTINUE ENDIF C C STEP 6: SORT 2'S BY POSITION C 130 IF (LAST2 .GT. LAST3+1) THEN DO 160 I = LAST3+1 , LAST2 SWAP = .FALSE. DO 150 J = LAST3+1 , LAST2-1 IF (LBLTBL(J,1) .GT. LBLTBL(J+1,1)) THEN DO 140 K = 1 , 3 ITEMP = LBLTBL(J,K) LBLTBL(J,K) = LBLTBL(J+1,K) LBLTBL(J+1,K) = ITEMP 140 CONTINUE SWAP = .TRUE. ENDIF 150 CONTINUE IF (.NOT.SWAP) GO TO 170 160 CONTINUE ENDIF C C STEP 7: BUILD TABLE OF FORM: NEW*524288 + OLD*4 + TYPE C 170 K = 0 DO 180 I = 1 , LAST3 IF (LBLTBL(I,1) .EQ. 0) GO TO 180 K = K + 1 LBLTBL(I,1) = FMTBAS + (K-1)*FMTINC 180 CONTINUE C K = 0 DO 190 I = LAST3+1 , LAST2 IF (LBLTBL(I,1) .EQ. 0) GO TO 190 K = K + 1 LBLTBL(I,1) = LABASE + (K-1)*LABINC 190 CONTINUE C DO 200 I = LAST2+1 , IN LBLTBL(I,1) = 0 200 CONTINUE C C STEP 8: SORT THE TABLE BY OLD NUMBER C IF (IN .GT. 1) THEN DO 230 I = 1 , IN SWAP = .FALSE. DO 220 J = 1 , IN-1 IF (LBLTBL(J,2) .GT. LBLTBL(J+1,2)) THEN DO 210 K = 1 , 3 ITEMP = LBLTBL(J,K) LBLTBL(J,K) = LBLTBL(J+1,K) LBLTBL(J+1,K) = ITEMP 210 CONTINUE SWAP = .TRUE. ENDIF 220 CONTINUE IF (.NOT.SWAP) GO TO 240 230 CONTINUE ENDIF C C STEP 9: PRINT THE TABLE AND SET TO NEW*131072 + OLD C 240 NEWLAB = .TRUE. DO 250 I = 1 , IN IF (LBLTBL(I,1) .NE. LBLTBL(I,2)) GO TO 270 250 CONTINUE NEWLAB = .FALSE. IF (LSTSRC) THEN CALL PAGECK(3) WRITE (2,260) 260 FORMAT (//10X,'** STATEMENT LABELS UNCHANGED **') ENDIF 270 ROWS = (IN+4) / 5 COLS = (IN+ROWS-1) / ROWS DO 310 I = 1 , ROWS IF (LSTSRC .AND. NEWLAB .AND. I .EQ. 1) THEN SQZCRD(1:80) = ' ' SUPRCD(1:80) = ' ' DO 280 J = 1 , COLS K = (J-1)*16+1 L = K + 15 SQZCRD(K:L) = ' OLD NEW ' SUPRCD(K:L) = ' ----- ----- ' 280 CONTINUE CALL PAGECK(5) WRITE (2,290) ' ' 290 FORMAT (A) WRITE (2,290) ' ' WRITE (2,290) SQZCRD(1:80) WRITE (2,290) SUPRCD(1:80) ENDIF IF (LSTSRC .AND. NEWLAB) SUPRCD(1:80) = ' ' DO 300 J = 1 , COLS K = (J-1)*ROWS + I IF (K .GT. IN) GO TO 300 NEW = LBLTBL(K,1) OLD = LBLTBL(K,2) IF (LSTSRC .AND. NEWLAB) THEN CALL CVTLAB (OLD,LENGTH,.TRUE.) ITEMP = LBLTBL(K,3)/2 K = (J-1)*16 SUPRCD(K+4:K+8) = TMPSTR(1:5) IF (ITEMP .EQ. 1) THEN IF (NEW .NE. 0) THEN CALL CVTLAB (NEW,LENGTH,.TRUE.) SUPRCD(K+11:K+15) = TMPSTR(1:5) ELSE SUPRCD(K+11:K+15) = 'UNDEF' ENDIF ELSE SUPRCD(K+10:K+15) = 'UNUSED' ENDIF ENDIF 300 CONTINUE IF (LSTSRC .AND. NEWLAB) THEN IF (I .NE. 1) CALL PAGECK(1) WRITE (2,290) SUPRCD(1:80) ENDIF 310 CONTINUE C C STEP 10: SET LBLCNT TO NUMBER OF LABELS IN TABLE C LBLCNT = IN C RETURN C END SUBROUTINE DMPSTA IMPLICIT INTEGER (A-Z) CHARACTER*1 DEFRET, DEFUNC, DEFQUO, STRSIG CHARACTER*2 VEXTCS C PARAMETER ( CMDLEN = 7 ) PARAMETER ( CMDMAX = 34 ) PARAMETER ( DEFLLN = 72 ) PARAMETER ( DEFLPP = 60 ) PARAMETER ( DEFQUO = '''' ) PARAMETER ( DEFRET = '*' ) PARAMETER ( DEFUNC = ' ' ) PARAMETER ( MAXLLN = 125 ) PARAMETER ( MAXVRL = 8 ) PARAMETER ( MINLLN = 40 ) PARAMETER ( MINLPP = 30 ) PARAMETER ( STRSIG = '?' ) PARAMETER ( VEXTCS = '$_' ) C C THIS ROUTINE DUMPS THE PRESENT STATUS OF THE CLEAN77 ENVIRONMENT. C PARAMETER ( COMLEN = 100 ) PARAMETER ( SUPLEN = 1458 ) C COMMON /CHBLK/ CHAR , COMBLK, EOS , EXMCHR, HOLDCH, INLINE, * LN1MSG, LONGKY, NUMBER, NUMLET, QUOTCH, RETPFX, * SPECHR, SQZCRD, SUPRCD, TMPCRD, TMPSTR, UNCONC, * VARBLE CHARACTER*1 CHAR, EOS, EXMCHR, HOLDCH, QUOTCH, RETPFX, UNCONC CHARACTER*17 SPECHR CHARACTER*38 NUMLET CHARACTER*40 LN1MSG, LONGKY, NUMBER, TMPSTR, VARBLE CHARACTER*126 COMBLK(COMLEN), INLINE CHARACTER*(SUPLEN) SQZCRD, SUPRCD, TMPCRD COMMON /COUNT/ FMTBAS, FMTINC, INCNT , INDINC, LABASE, LABINC, * LINELN, OLDLEN, PAGELN, RINCNT, ROUCNT, THISLN, * THISPG, TINCNT, TOUCNT COMMON /LOGVR/ ADDCON, BRKCOM, COLFMT, CPYFLG, CVTHFI, DONERD, * DOSTAT, EXMCOM, EXMFMT, EXMNEX, FIRSTC, HAVEXS, * INDCOM, INDSTA, ISFMT , ISSCOM, LASTBC, LBTFUL, * LSTIDS, LSTRES, LSTSRC, MORE , NEEDRD, OVRLAY, * PASS0 , PASS1 , PROPCM, QUOTCV, RJLABS, ROUDON, * SIZDEF, SPLTNV, SPLTST, UNCOND, VARUEC, WASCHF, * WASCMD, WASKEY, WASLAB, WASSTR, WASUNC, WRBCOM, * WRCBLK, WRMSG1, WRTFMT, XTRAST, ZEND , ZREAD LOGICAL ADDCON, BRKCOM, COLFMT, CPYFLG, CVTHFI, DONERD, DOSTAT, * EXMCOM, EXMFMT, EXMNEX, FIRSTC, HAVEXS, INDCOM, INDSTA, * ISFMT , ISSCOM, LASTBC, LBTFUL, LSTIDS, LSTRES, LSTSRC, * MORE , NEEDRD, OVRLAY, PASS0 , PASS1 , PROPCM, QUOTCV, * RJLABS, ROUDON, SIZDEF, SPLTNV, SPLTST, UNCOND, VARUEC, * WASCHF, WASCMD, WASKEY, WASLAB, WASSTR, WASUNC, WRBCOM, * WRCBLK, WRMSG1, WRTFMT, XTRAST, ZEND , ZREAD C CHARACTER*8 FLAGS(CMDMAX) C IF (DOSTAT .AND. (LSTSRC .OR. LSTRES)) THEN DO 10 I = 1 , CMDMAX FLAGS(I) = 'DISABLED' 10 CONTINUE C IF (ADDCON) FLAGS(1) = ' ENABLED' IF (BRKCOM) FLAGS(2) = ' ENABLED' IF (COLFMT) FLAGS(3) = ' ENABLED' IF (CPYFLG) FLAGS(4) = ' ENABLED' IF (EXMCOM) FLAGS(5) = ' ENABLED' IF (EXMFMT) FLAGS(6) = ' ENABLED' IF (EXMNEX) FLAGS(7) = ' ENABLED' IF (EXMCHR .NE. EOS) FLAGS(8) = ' ' // EXMCHR IF (FMTBAS .NE. 0 .AND. LABINC .NE. 0) THEN FLAGS(9) = ' ' CALL CVTLAB (FMTBAS,LENGTH,.TRUE.) FLAGS(9)(8+1-LENGTH:8) = TMPSTR(1:LENGTH) FLAGS(10) = ' ' CALL CVTLAB (FMTINC,LENGTH,.TRUE.) FLAGS(10)(8+1-LENGTH:8) = TMPSTR(1:LENGTH) ENDIF IF (CVTHFI) FLAGS(11) = ' ENABLED' IF (INDCOM) FLAGS(12) = ' ENABLED' FLAGS(13) = ' ' CALL CVTLAB (INDINC,LENGTH,.TRUE.) FLAGS(13)(8+1-LENGTH:8) = TMPSTR(1:LENGTH) IF (INDSTA) FLAGS(14) = ' ENABLED' IF (ISSCOM) FLAGS(15) = ' ENABLED' IF (LABINC .NE. 0) THEN FLAGS(16) = ' ' CALL CVTLAB (LABASE,LENGTH,.TRUE.) FLAGS(16)(8+1-LENGTH:8) = TMPSTR(1:LENGTH) FLAGS(17) = ' ' CALL CVTLAB (LABINC,LENGTH,.TRUE.) FLAGS(17)(8+1-LENGTH:8) = TMPSTR(1:LENGTH) ENDIF IF (.NOT.RJLABS) THEN FLAGS(18) = ' ENABLED' ELSE FLAGS(28) = ' ENABLED' ENDIF FLAGS(19) = ' ' CALL CVTLAB (LINELN,LENGTH,.TRUE.) FLAGS(19)(8+1-LENGTH:8) = TMPSTR(1:LENGTH) IF (LSTIDS) FLAGS(20) = ' ENABLED' IF (LSTRES) FLAGS(21) = ' ENABLED' IF (LSTSRC) FLAGS(22) = ' ENABLED' FLAGS(23) = ' ' CALL CVTLAB (OLDLEN,LENGTH,.TRUE.) FLAGS(23)(8+1-LENGTH:8) = TMPSTR(1:LENGTH) FLAGS(24) = ' ' CALL CVTLAB (PAGELN,LENGTH,.TRUE.) FLAGS(24)(8+1-LENGTH:8) = TMPSTR(1:LENGTH) IF (PROPCM) FLAGS(25) = ' ENABLED' IF (QUOTCV) FLAGS(26) = ' ' // QUOTCH FLAGS(27) = ' ' // RETPFX IF (SIZDEF) FLAGS(29) = ' ENABLED' IF (SPLTNV) FLAGS(30) = ' ENABLED' IF (SPLTST) FLAGS(31) = ' ENABLED' FLAGS(32) = ' ENABLED' IF (UNCOND) THEN IF (UNCONC .EQ. ' ') THEN FLAGS(33) = ' *BLANK*' ELSE FLAGS(33) = ' ' // UNCONC ENDIF ENDIF IF (VARUEC) FLAGS(34) = ' ENABLED' C CALL PAGECK (CMDMAX+8) WRITE (2,20) (FLAGS(I),I=1,10) WRITE (2,30) (FLAGS(I),I=11,20) WRITE (2,40) (FLAGS(I),I=21,30) WRITE (2,50) (FLAGS(I),I=31,CMDMAX) 20 FORMAT (///1X,'PRESENT COMMAND STATUS:'// * 5X,'ADD CONTINUE STMTS...........ADDCONT = ',A/ * 5X,'BRACKET COMMENTS.............BRACKET = ',A/ * 5X,'COLLECT FORMATS..............COLLECT = ',A/ * 5X,'COPY ROUTINE INTACT.............COPY = ',A/ * 5X,'EXEMPT COMMENTS..............EXEMPTC = ',A/ * 5X,'EXEMPT FORMATS...............EXEMPTF = ',A/ * 5X,'EXEMPT NONEXECUTABLE.........EXEMPTN = ',A/ * 5X,'EXEMPT STATEMENT CHAR........EXEMPTS = ',A/ * 5X,'FORMAT LABEL BASE............FORMATB = ',A/ * 5X,'FORMAT LABEL INCREMENT.......FORMATI = ',A) 30 FORMAT ( * 5X,'HFIELD CONVERSION.............HFIELD = ',A/ * 5X,'INDENT COMMENTS..............INDENTC = ',A/ * 5X,'INDENTATION INCREMENT........INDENTI = ',A/ * 5X,'INDENT STATEMENTS............INDENTS = ',A/ * 5X,'ISSUE COMMENTS................ISSUEC = ',A/ * 5X,'LABEL BASE....................LABELB = ',A/ * 5X,'LABEL INCREMENT...............LABELI = ',A/ * 5X,'LEFT JUSTIFY LABELS............LEFTJ = ',A/ * 5X,'NEW FILE LINE LENGTH.........LINELEN = ',A/ * 5X,'LIST OLD FILE CARD IDS.......LISTIDS = ',A) 40 FORMAT ( * 5X,'LIST NEW FILE................LISTNEW = ',A/ * 5X,'LIST OLD FILE................LISTOLD = ',A/ * 5X,'OLD FILE LINE LENGTH..........OLDLEN = ',A/ * 5X,'PAGE LENGTH..................PAGELEN = ',A/ * 5X,'PROPAGATE COMMANDS..............PROP = ',A/ * 5X,'QUOTE MARK CONVERSION CHAR...QUOTECH = ',A/ * 5X,'RETURN LABEL PREFIX..........RETPRFX = ',A/ * 5X,'RIGHT JUSTIFY LABELS..........RIGHTJ = ',A/ * 5X,'SPEC STMT SIZE DEFS..........SIZEDEF = ',A/ * 5X,'SPLIT NUMBERS AND VARS.......SPLITNV = ',A) 50 FORMAT ( * 5X,'SPLIT STRINGS................SPLITST = ',A/ * 5X,'STATUS REPORT.................STATUS = ',A/ * 5X,'UNCONDITIONAL FLOW CHANGE.....UNCOND = ',A/ * 5X,'VARS USE EXTENDED CHAR SET...VARUECS = ',A/ * //) ENDIF C C CLEAR STATUS REPORT REQUEST FLAG C DOSTAT = .FALSE. C C INSURE PAGE EJECT AFTER STATUS REPORT C THISLN = PAGELN RETURN C END SUBROUTINE GENLEX (ONETOK,PARZER) IMPLICIT INTEGER (A-Z) C C THIS ROUTINE DOES THE PARSING OF ASSIGNMENT STATEMENTS C AND ALSO PARTS OF KEYWORD STATEMENTS WHICH ARE LIKE C ASSIGNMENT STATEMENTS. AT ENTRY, =CHAR= CONTAINS THE FIRST C CHARACTER TO PROCESS, =ONETOK= IS .TRUE. IF ONLY ONE TOKEN C IS TO BE PROCESSED, AND =PARZER= IS .TRUE. IF TOKENS ARE C TO BE PROCESSED UNTIL PARENTHESIS LEVEL IS ZERO. C PARAMETER ( COMLEN = 100 ) PARAMETER ( SUPLEN = 1458 ) C COMMON /CHBLK/ CHAR , COMBLK, EOS , EXMCHR, HOLDCH, INLINE, * LN1MSG, LONGKY, NUMBER, NUMLET, QUOTCH, RETPFX, * SPECHR, SQZCRD, SUPRCD, TMPCRD, TMPSTR, UNCONC, * VARBLE CHARACTER*1 CHAR, EOS, EXMCHR, HOLDCH, QUOTCH, RETPFX, UNCONC CHARACTER*17 SPECHR CHARACTER*38 NUMLET CHARACTER*40 LN1MSG, LONGKY, NUMBER, TMPSTR, VARBLE CHARACTER*126 COMBLK(COMLEN), INLINE CHARACTER*(SUPLEN) SQZCRD, SUPRCD, TMPCRD COMMON /CHPTR/ COMLNB(COMLEN), COMPTR, INDENT, EOLINE, KYTYPE, * MATLEN, MATLLN, OCRDPT, SCRDPT, SQZIN, SUPOUT, * TCRDPT COMMON /LOGVR/ ADDCON, BRKCOM, COLFMT, CPYFLG, CVTHFI, DONERD, * DOSTAT, EXMCOM, EXMFMT, EXMNEX, FIRSTC, HAVEXS, * INDCOM, INDSTA, ISFMT , ISSCOM, LASTBC, LBTFUL, * LSTIDS, LSTRES, LSTSRC, MORE , NEEDRD, OVRLAY, * PASS0 , PASS1 , PROPCM, QUOTCV, RJLABS, ROUDON, * SIZDEF, SPLTNV, SPLTST, UNCOND, VARUEC, WASCHF, * WASCMD, WASKEY, WASLAB, WASSTR, WASUNC, WRBCOM, * WRCBLK, WRMSG1, WRTFMT, XTRAST, ZEND , ZREAD LOGICAL ADDCON, BRKCOM, COLFMT, CPYFLG, CVTHFI, DONERD, DOSTAT, * EXMCOM, EXMFMT, EXMNEX, FIRSTC, HAVEXS, INDCOM, INDSTA, * ISFMT , ISSCOM, LASTBC, LBTFUL, LSTIDS, LSTRES, LSTSRC, * MORE , NEEDRD, OVRLAY, PASS0 , PASS1 , PROPCM, QUOTCV, * RJLABS, ROUDON, SIZDEF, SPLTNV, SPLTST, UNCOND, VARUEC, * WASCHF, WASCMD, WASKEY, WASLAB, WASSTR, WASUNC, WRBCOM, * WRCBLK, WRMSG1, WRTFMT, XTRAST, ZEND , ZREAD C LOGICAL ONETOK, PARZER C PARLEV = 0 C 10 NLDEX = INDEX (NUMLET,CHAR) IF (NLDEX .GE. 11) THEN C C IS A LETTER C SUPOUT = SUPOUT - 1 CALL GETVAR (ISFMT,LENGTH) CALL PUTSTR (VARBLE,LENGTH) C C IF A QUOTE, BIT/OCTAL/HEX NUMBER. TREAT AS A Q-FIELD. C IF (CHAR .EQ. '''' .OR. CHAR .EQ. '"') CALL QFIELD GO TO 180 C ELSEIF (NLDEX .GE. 1) THEN C C IS A NUMBER C SUPOUT = SUPOUT - 1 CALL GETNUM( .FALSE. , LENGTH ) 20 HOLDCH = NUMBER(LENGTH:LENGTH) IF (HOLDCH.EQ.'.' .OR. HOLDCH.EQ.'E' .OR. HOLDCH.EQ.'D' .OR. * HOLDCH.EQ.'Q') THEN LENGTH = LENGTH - 1 30 SUPOUT = SUPOUT - 1 IF (SUPRCD(SUPOUT:SUPOUT) .EQ. ' ') GO TO 30 CHAR = HOLDCH GO TO 20 C ELSEIF (.NOT.ISFMT .AND. * (CHAR .EQ. 'R' .OR. CHAR .EQ. 'L')) THEN CALL RFIELD (LENGTH) ELSEIF (CHAR .EQ. 'H') THEN IF (ISFMT .OR. CVTHFI) THEN CALL HFIELD (LENGTH) ELSE CALL RFIELD (LENGTH) ENDIF ELSE CALL PUTSTR (NUMBER,LENGTH) ENDIF GO TO 180 C ELSE C C IS A SPECIAL CHARACTER OR E-O-S C SPDEX = INDEX(SPECHR,CHAR) IF (SPDEX .EQ. 0) THEN C C WAS E-O-S C IF (TCRDPT.EQ.0) XTRAST = .FALSE. CALL PUTC RETURN ENDIF C GO TO (160, 160, 60, 80, 40, 50, 90, 100, 160, 110, * 160, 160, 160, 160, 160, 150, 150) , SPDEX ENDIF C C WAS =(= C 40 PARLEV = PARLEV + 1 GO TO 160 C C WAS =)= C 50 PARLEV = PARLEV - 1 GO TO 160 C C WAS =*= C 60 IF (ISFMT) GO TO 150 CALL GETNBC IF (CHAR .EQ. '*') THEN CALL PUTSTR( '**' , 2 ) ELSE SUPOUT = SUPOUT-1 CALL PUTSTR ('*' , 1 ) ENDIF GO TO 170 C C WAS =/= C 80 CALL GETNBC IF (CHAR .EQ. '/') THEN CALL PUTSTR ( '//' , 2 ) ELSE SUPOUT = SUPOUT - 1 CALL PUTSTR ('/',1) ENDIF GO TO 170 C C WAS =$= C 90 IF (ISFMT) GO TO 150 CHAR = EOS CALL PUTC IF (TCRDPT.EQ.0) THEN TCRDPT = 6 + SCRDPT - SUPOUT TMPCRD(1:TCRDPT) = ' ' // SUPRCD(SUPOUT:SCRDPT-1) ELSE I = 1 + SCRDPT - SUPOUT TMPCRD(TCRDPT+1:TCRDPT+I) = '$' // SUPRCD(SUPOUT:SCRDPT-1) TCRDPT = TCRDPT + I ENDIF XTRAST = .TRUE. RETURN C C WAS === C 100 IF (WASKEY) GO TO 160 CALL PUTSTR (' = ',3) GO TO 170 C C WAS =.= C 110 TEMP = SUPOUT CALL GETNBC TMPDEX = INDEX(NUMLET,CHAR) IF (TMPDEX .GE. 11) THEN C C WAS A LETTER, SO =.STRING.= C SUPOUT = TEMP CALL GETVAR (.TRUE.,LENGTH) IF (LENGTH .EQ. 1) THEN CHAR = VARBLE(1:1) IF (CHAR .EQ. 'A') THEN VARBLE(1:3) = 'AND' LENGTH = 3 ELSEIF (CHAR .EQ. 'F') THEN VARBLE(1:5) = 'FALSE' LENGTH = 5 ELSEIF (CHAR .EQ. 'N') THEN VARBLE(1:3) = 'NOT' LENGTH = 3 ELSEIF (CHAR .EQ. 'O') THEN VARBLE(1:2) = 'OR' LENGTH = 2 ELSEIF (CHAR .EQ. 'T') THEN VARBLE(1:4) = 'TRUE' LENGTH = 4 ELSEIF (CHAR .EQ. 'X') THEN VARBLE(1:3) = 'XOR' LENGTH = 3 ENDIF ENDIF TMPSTR = '.' // VARBLE(1:LENGTH) // '.' CALL PUTSTR (TMPSTR,LENGTH+2) CALL GETNBC ELSE C C WAS A NUMBER, SO =.NUMBER= C OR NULL, SO =.= C 140 SUPOUT = TEMP - 1 TEMP = SUPOUT IF (SUPRCD(SUPOUT:SUPOUT) .EQ. ' ') GO TO 140 CALL GETNUM(.FALSE.,LENGTH) CALL PUTSTR(NUMBER,LENGTH) ENDIF GO TO 180 C C WAS ="= OR ='= C 150 CALL QFIELD GO TO 180 C C WAS =+=, =-=, =,=, =:=, =;=, =&=, =[= OR =]= C 160 CALL PUTC C C SEE IF DONE C 170 CALL GETNBC 180 IF (ONETOK) RETURN IF (PARZER .AND. PARLEV .EQ. 0) RETURN GO TO 10 C END SUBROUTINE GETC IMPLICIT INTEGER (A-Z) C C THIS ROUTINE EXTRACTS THE NEXT CHARACTER POSITION (=SUPOUT=) C FROM =SUPRCD= AND RETURNS IT =CHAR=. C PARAMETER ( COMLEN = 100 ) PARAMETER ( SUPLEN = 1458 ) C COMMON /CHBLK/ CHAR , COMBLK, EOS , EXMCHR, HOLDCH, INLINE, * LN1MSG, LONGKY, NUMBER, NUMLET, QUOTCH, RETPFX, * SPECHR, SQZCRD, SUPRCD, TMPCRD, TMPSTR, UNCONC, * VARBLE CHARACTER*1 CHAR, EOS, EXMCHR, HOLDCH, QUOTCH, RETPFX, UNCONC CHARACTER*17 SPECHR CHARACTER*38 NUMLET CHARACTER*40 LN1MSG, LONGKY, NUMBER, TMPSTR, VARBLE CHARACTER*126 COMBLK(COMLEN), INLINE CHARACTER*(SUPLEN) SQZCRD, SUPRCD, TMPCRD COMMON /CHPTR/ COMLNB(COMLEN), COMPTR, INDENT, EOLINE, KYTYPE, * MATLEN, MATLLN, OCRDPT, SCRDPT, SQZIN, SUPOUT, * TCRDPT C CHAR = SUPRCD(SUPOUT:SUPOUT) SUPOUT = SUPOUT + 1 RETURN C END SUBROUTINE GETNBC IMPLICIT INTEGER (A-Z) C C THIS ROUTINE EXTRACTS THE NEXT NON-BLANK CHARACTER (STARTING C FROM =SUPOUT=) FROM THE SUPERCARD =SUPRCD= AND RETURNS IT C IN =CHAR=. C PARAMETER ( COMLEN = 100 ) PARAMETER ( SUPLEN = 1458 ) C COMMON /CHBLK/ CHAR , COMBLK, EOS , EXMCHR, HOLDCH, INLINE, * LN1MSG, LONGKY, NUMBER, NUMLET, QUOTCH, RETPFX, * SPECHR, SQZCRD, SUPRCD, TMPCRD, TMPSTR, UNCONC, * VARBLE CHARACTER*1 CHAR, EOS, EXMCHR, HOLDCH, QUOTCH, RETPFX, UNCONC CHARACTER*17 SPECHR CHARACTER*38 NUMLET CHARACTER*40 LN1MSG, LONGKY, NUMBER, TMPSTR, VARBLE CHARACTER*126 COMBLK(COMLEN), INLINE CHARACTER*(SUPLEN) SQZCRD, SUPRCD, TMPCRD COMMON /CHPTR/ COMLNB(COMLEN), COMPTR, INDENT, EOLINE, KYTYPE, * MATLEN, MATLLN, OCRDPT, SCRDPT, SQZIN, SUPOUT, * TCRDPT C 10 CHAR = SUPRCD(SUPOUT:SUPOUT) SUPOUT = SUPOUT + 1 IF (CHAR .EQ. ' ') GO TO 10 RETURN C END SUBROUTINE GETNUM (BLDINT,LENGTH) IMPLICIT INTEGER (A-Z) C C THIS ROUTINE EXTRACTS A NUMBER AND STORES IT IN POSITIONS C 1-N OF ARRAY =NUMBER=. =LENGTH= IS THE LENGTH IN CHARACTERS C OF THE RESULTANT NUMBER. =CHAR= CONTAINS THE DELIMITER. C IF =BLDINT= IS .TRUE., ONLY AN INTEGER IS TO BE BUILT. C PARAMETER ( COMLEN = 100 ) PARAMETER ( SUPLEN = 1458 ) C COMMON /CHBLK/ CHAR , COMBLK, EOS , EXMCHR, HOLDCH, INLINE, * LN1MSG, LONGKY, NUMBER, NUMLET, QUOTCH, RETPFX, * SPECHR, SQZCRD, SUPRCD, TMPCRD, TMPSTR, UNCONC, * VARBLE CHARACTER*1 CHAR, EOS, EXMCHR, HOLDCH, QUOTCH, RETPFX, UNCONC CHARACTER*17 SPECHR CHARACTER*38 NUMLET CHARACTER*40 LN1MSG, LONGKY, NUMBER, TMPSTR, VARBLE CHARACTER*126 COMBLK(COMLEN), INLINE CHARACTER*(SUPLEN) SQZCRD, SUPRCD, TMPCRD COMMON /CHPTR/ COMLNB(COMLEN), COMPTR, INDENT, EOLINE, KYTYPE, * MATLEN, MATLLN, OCRDPT, SCRDPT, SQZIN, SUPOUT, * TCRDPT C LOGICAL BLDINT C C INITIALIZATION C HAVEE = 0 I = 0 NUMBER = ' ' C C LOOP UNTIL NON-DIGIT C 10 CALL GETNBC IF (INDEX(NUMLET(1:10),CHAR) .EQ. 0) GO TO 20 I = I + 1 NUMBER(I:I) = CHAR IF (I.LT.40) GO TO 10 GO TO 80 C C ENCOUNTERED FIRST SPECIAL CHARACTER C 20 IF (BLDINT) GO TO 80 IF (CHAR .EQ. '.' .OR. CHAR .EQ. 'B') GO TO 30 IF (CHAR.EQ.'D' .OR. CHAR.EQ.'E' .OR. CHAR.EQ.'Q') GO TO 50 GO TO 80 C C ISSUE '.' OR 'B'. LOOP UNTIL NEXT NON-DIGIT. C 30 I = I + 1 NUMBER(I:I) = CHAR CALL GETNBC IF (I.GE.40) GO TO 80 IF (INDEX(NUMLET(1:10),CHAR) .NE. 0) GO TO 30 C C SPECIAL CHARACTER AFTER ('.' OR 'B') OR 'D' OR 'E' OR 'Q' GETS C ACCEPTED AS PART OF THE NUMBER C IF (CHAR.NE.'D' .AND. CHAR.NE.'E' .AND. CHAR.NE.'Q') GO TO 80 50 HAVEE = I + 1 C C ISSUE THE 'D' OR 'E' OR 'Q'. LOOP UNTIL DONE. C 60 I = I + 1 NUMBER(I:I) = CHAR CALL GETNBC IF (I.GE.40) GO TO 80 IF (INDEX(NUMLET(1:10),CHAR) .NE. 0) GO TO 60 IF ((CHAR .EQ. '+' .OR. CHAR .EQ. '-') .AND. * (HAVEE .EQ. I)) GO TO 60 C C RETURN LENGTH C 80 LENGTH = I RETURN C END SUBROUTINE GETVAR (LTONLY,LENGTH) IMPLICIT INTEGER (A-Z) C C THIS ROUTINE EXTRACTS A VARIABLE AND STORES IT IN POSITIONS C 1-N OF ARRAY =VARBLE=. =LENGTH= IS THE LENGTH OF THE VARIABLE. C =CHAR= CONTAINS THE DELIMITER. IF =LTONLY= IS .TRUE., ONLY C LETTERS ARE PERMITTED TO BE IN THE VARIABLE NAME =VARBLE=. C PARAMETER ( COMLEN = 100 ) PARAMETER ( SUPLEN = 1458 ) C COMMON /CHBLK/ CHAR , COMBLK, EOS , EXMCHR, HOLDCH, INLINE, * LN1MSG, LONGKY, NUMBER, NUMLET, QUOTCH, RETPFX, * SPECHR, SQZCRD, SUPRCD, TMPCRD, TMPSTR, UNCONC, * VARBLE CHARACTER*1 CHAR, EOS, EXMCHR, HOLDCH, QUOTCH, RETPFX, UNCONC CHARACTER*17 SPECHR CHARACTER*38 NUMLET CHARACTER*40 LN1MSG, LONGKY, NUMBER, TMPSTR, VARBLE CHARACTER*126 COMBLK(COMLEN), INLINE CHARACTER*(SUPLEN) SQZCRD, SUPRCD, TMPCRD COMMON /CHPTR/ COMLNB(COMLEN), COMPTR, INDENT, EOLINE, KYTYPE, * MATLEN, MATLLN, OCRDPT, SCRDPT, SQZIN, SUPOUT, * TCRDPT C LOGICAL LTONLY C I = 0 VARBLE = ' ' 10 CALL GETNBC IVAL = INDEX(NUMLET,CHAR) IF (IVAL .GE. 11) GO TO 20 IF (LTONLY .OR. IVAL .EQ. 0) GO TO 30 20 I = I + 1 VARBLE(I:I) = CHAR IF (I.LT.40) GO TO 10 C 30 LENGTH = I RETURN C END INTEGER FUNCTION HASDOL () IMPLICIT INTEGER (A-Z) PARAMETER (HPOS=10+8 , LPOS=10+12 , RPOS=10+18) C C THIS FUNCTION SCANS THE SUPERCARD =SUPRCD= FROM THE C PRESENT CHARACTER TO THE FIRST DOLLAR SIGN, E-O-S C OR CHARACTER STRING, WHICH EVER COMES FIRST. THE C VALUE RETURNED IS THE COLUMN CONTAINING THE DOLLAR C SIGN, E-O-S OR THE START OF THE CHARACTER STRING. C PARAMETER ( COMLEN = 100 ) PARAMETER ( SUPLEN = 1458 ) C COMMON /CHBLK/ CHAR , COMBLK, EOS , EXMCHR, HOLDCH, INLINE, * LN1MSG, LONGKY, NUMBER, NUMLET, QUOTCH, RETPFX, * SPECHR, SQZCRD, SUPRCD, TMPCRD, TMPSTR, UNCONC, * VARBLE CHARACTER*1 CHAR, EOS, EXMCHR, HOLDCH, QUOTCH, RETPFX, UNCONC CHARACTER*17 SPECHR CHARACTER*38 NUMLET CHARACTER*40 LN1MSG, LONGKY, NUMBER, TMPSTR, VARBLE CHARACTER*126 COMBLK(COMLEN), INLINE CHARACTER*(SUPLEN) SQZCRD, SUPRCD, TMPCRD COMMON /CHPTR/ COMLNB(COMLEN), COMPTR, INDENT, EOLINE, KYTYPE, * MATLEN, MATLLN, OCRDPT, SCRDPT, SQZIN, SUPOUT, * TCRDPT COMMON /LOGVR/ ADDCON, BRKCOM, COLFMT, CPYFLG, CVTHFI, DONERD, * DOSTAT, EXMCOM, EXMFMT, EXMNEX, FIRSTC, HAVEXS, * INDCOM, INDSTA, ISFMT , ISSCOM, LASTBC, LBTFUL, * LSTIDS, LSTRES, LSTSRC, MORE , NEEDRD, OVRLAY, * PASS0 , PASS1 , PROPCM, QUOTCV, RJLABS, ROUDON, * SIZDEF, SPLTNV, SPLTST, UNCOND, VARUEC, WASCHF, * WASCMD, WASKEY, WASLAB, WASSTR, WASUNC, WRBCOM, * WRCBLK, WRMSG1, WRTFMT, XTRAST, ZEND , ZREAD LOGICAL ADDCON, BRKCOM, COLFMT, CPYFLG, CVTHFI, DONERD, DOSTAT, * EXMCOM, EXMFMT, EXMNEX, FIRSTC, HAVEXS, INDCOM, INDSTA, * ISFMT , ISSCOM, LASTBC, LBTFUL, LSTIDS, LSTRES, LSTSRC, * MORE , NEEDRD, OVRLAY, PASS0 , PASS1 , PROPCM, QUOTCV, * RJLABS, ROUDON, SIZDEF, SPLTNV, SPLTST, UNCOND, VARUEC, * WASCHF, WASCMD, WASKEY, WASLAB, WASSTR, WASUNC, WRBCOM, * WRCBLK, WRMSG1, WRTFMT, XTRAST, ZEND , ZREAD C CHARACTER*1 LSTNBC, SAVCHR C I = SUPOUT-1 LSTNBC = EOS 10 IF (INDEX(NUMLET,SUPRCD(I:I)) .EQ. 0) GO TO 20 I = I + 1 GO TO 10 C 20 HOLDCH = SUPRCD(I:I) C 30 IF (HOLDCH.EQ.EOS .OR. (HOLDCH.EQ.'$' .AND. .NOT.VARUEC) .OR. * HOLDCH .EQ. '"' .OR. HOLDCH .EQ. '''') THEN HASDOL = I RETURN C ELSE J = INDEX (NUMLET,HOLDCH) IF (J.GE.1 .AND. J.LE.10 .AND. INDEX(SPECHR,LSTNBC).NE.0) THEN C C POSSIBLE H-, L- OR R-FIELD C KEEPI = I 40 I = I + 1 SAVCHR = HOLDCH HOLDCH = SUPRCD(I:I) J = INDEX (NUMLET,HOLDCH) IF (J .GE. 1 .AND. J .LE. 10) GO TO 40 IF (J.EQ.HPOS .OR. J.EQ.LPOS .OR. J.EQ.RPOS) THEN C C IT WAS A STRING, SO FLAG THE START AND RETURN C I = KEEPI HOLDCH = EOS GO TO 30 C ELSE I = I - 1 HOLDCH = SAVCHR ENDIF ENDIF ENDIF C I = I + 1 IF (HOLDCH .NE. ' ') LSTNBC = HOLDCH GO TO 20 C END LOGICAL FUNCTION HASEQL(PARLEV) IMPLICIT INTEGER (A-Z) PARAMETER (HPOS=10+8 , LPOS=10+12 , RPOS=10+18) C C THIS FUNCTION SCANS THE SUPERCARD =SUPRCD= FROM THE C PRESENT CHARACTER TO E-O-S AND RETURNS A VALUE C OF .TRUE. IF AN EQUAL SIGN IS FOUND. =PARLEV= CONTAINS THE C PARENTHESIS LEVEL AT THE POINT WHERE THE EQUAL SIGN WAS FOUND. C PARAMETER ( COMLEN = 100 ) PARAMETER ( SUPLEN = 1458 ) C COMMON /CHBLK/ CHAR , COMBLK, EOS , EXMCHR, HOLDCH, INLINE, * LN1MSG, LONGKY, NUMBER, NUMLET, QUOTCH, RETPFX, * SPECHR, SQZCRD, SUPRCD, TMPCRD, TMPSTR, UNCONC, * VARBLE CHARACTER*1 CHAR, EOS, EXMCHR, HOLDCH, QUOTCH, RETPFX, UNCONC CHARACTER*17 SPECHR CHARACTER*38 NUMLET CHARACTER*40 LN1MSG, LONGKY, NUMBER, TMPSTR, VARBLE CHARACTER*126 COMBLK(COMLEN), INLINE CHARACTER*(SUPLEN) SQZCRD, SUPRCD, TMPCRD COMMON /CHPTR/ COMLNB(COMLEN), COMPTR, INDENT, EOLINE, KYTYPE, * MATLEN, MATLLN, OCRDPT, SCRDPT, SQZIN, SUPOUT, * TCRDPT COMMON /LOGVR/ ADDCON, BRKCOM, COLFMT, CPYFLG, CVTHFI, DONERD, * DOSTAT, EXMCOM, EXMFMT, EXMNEX, FIRSTC, HAVEXS, * INDCOM, INDSTA, ISFMT , ISSCOM, LASTBC, LBTFUL, * LSTIDS, LSTRES, LSTSRC, MORE , NEEDRD, OVRLAY, * PASS0 , PASS1 , PROPCM, QUOTCV, RJLABS, ROUDON, * SIZDEF, SPLTNV, SPLTST, UNCOND, VARUEC, WASCHF, * WASCMD, WASKEY, WASLAB, WASSTR, WASUNC, WRBCOM, * WRCBLK, WRMSG1, WRTFMT, XTRAST, ZEND , ZREAD LOGICAL ADDCON, BRKCOM, COLFMT, CPYFLG, CVTHFI, DONERD, DOSTAT, * EXMCOM, EXMFMT, EXMNEX, FIRSTC, HAVEXS, INDCOM, INDSTA, * ISFMT , ISSCOM, LASTBC, LBTFUL, LSTIDS, LSTRES, LSTSRC, * MORE , NEEDRD, OVRLAY, PASS0 , PASS1 , PROPCM, QUOTCV, * RJLABS, ROUDON, SIZDEF, SPLTNV, SPLTST, UNCOND, VARUEC, * WASCHF, WASCMD, WASKEY, WASLAB, WASSTR, WASUNC, WRBCOM, * WRCBLK, WRMSG1, WRTFMT, XTRAST, ZEND , ZREAD C CHARACTER*1 SAVCHR C I = SUPOUT-1 PARLV = 0 10 IF (INDEX(NUMLET,SUPRCD(I:I)) .EQ. 0) GO TO 20 I = I + 1 GO TO 10 C 20 HOLDCH = SUPRCD(I:I) J = INDEX (NUMLET,HOLDCH) C 30 IF (HOLDCH .EQ. EOS .OR. * (.NOT.VARUEC .AND. HOLDCH.EQ.'$' .AND. PARLV.EQ.0)) THEN HASEQL = .FALSE. C ELSEIF (HOLDCH .EQ. '=') THEN HASEQL = .TRUE. C ELSEIF (HOLDCH .EQ. '''' .OR. HOLDCH .EQ. '"' .OR. * (ISFMT .AND. (HOLDCH .EQ. '*' .OR. HOLDCH .EQ. '$'))) THEN SAVCHR = HOLDCH 40 I = I + 1 HOLDCH = SUPRCD(I:I) IF (HOLDCH .EQ. SAVCHR) THEN I = I + 1 HOLDCH = SUPRCD(I:I) IF (HOLDCH .NE. SAVCHR) GO TO 30 ENDIF GO TO 40 C ELSEIF (J .GT. 0 .AND. J .LE. 10) THEN LEN = 0 50 IF (LEN .LT. SCRDPT-I-1) LEN = LEN*10 + J-1 I = I + 1 HOLDCH = SUPRCD(I:I) J = INDEX (NUMLET,HOLDCH) IF (J .GT. 0 .AND. J .LE. 10) GO TO 50 IF (LEN .LT. SCRDPT-I-1 .AND. * (J.EQ.HPOS .OR. J.EQ.LPOS .OR. J.EQ.RPOS)) THEN I = I + LEN + 1 GO TO 20 C ENDIF GO TO 30 C ELSE IF (HOLDCH .EQ. '(') THEN PARLV = PARLV + 1 ELSEIF (HOLDCH .EQ. ')') THEN PARLV = PARLV - 1 ENDIF I = I + 1 GO TO 20 ENDIF C PARLEV = PARLV RETURN C END SUBROUTINE HFIELD (LENGTH) IMPLICIT INTEGER (A-Z) CHARACTER*1 DEFRET, DEFUNC, DEFQUO, STRSIG CHARACTER*2 VEXTCS C PARAMETER ( CMDLEN = 7 ) PARAMETER ( CMDMAX = 34 ) PARAMETER ( DEFLLN = 72 ) PARAMETER ( DEFLPP = 60 ) PARAMETER ( DEFQUO = '''' ) PARAMETER ( DEFRET = '*' ) PARAMETER ( DEFUNC = ' ' ) PARAMETER ( MAXLLN = 125 ) PARAMETER ( MAXVRL = 8 ) PARAMETER ( MINLLN = 40 ) PARAMETER ( MINLPP = 30 ) PARAMETER ( STRSIG = '?' ) PARAMETER ( VEXTCS = '$_' ) C C THIS ROUTINE COPIES AN H-FIELD OF =NUMBER= CHARACTERS C FROM =SUPRCD= TO =SQZCRD=. IT CONVERTS FROM (NH...) TO C ('...'). =LENGTH= IS THE LENGTH OF THE STRING =NUMBER=. C AT EXIT, =CHAR= CONTAINS THE NEXT NON-BLANK CHARACTER. C PARAMETER ( COMLEN = 100 ) PARAMETER ( SUPLEN = 1458 ) C COMMON /CHBLK/ CHAR , COMBLK, EOS , EXMCHR, HOLDCH, INLINE, * LN1MSG, LONGKY, NUMBER, NUMLET, QUOTCH, RETPFX, * SPECHR, SQZCRD, SUPRCD, TMPCRD, TMPSTR, UNCONC, * VARBLE CHARACTER*1 CHAR, EOS, EXMCHR, HOLDCH, QUOTCH, RETPFX, UNCONC CHARACTER*17 SPECHR CHARACTER*38 NUMLET CHARACTER*40 LN1MSG, LONGKY, NUMBER, TMPSTR, VARBLE CHARACTER*126 COMBLK(COMLEN), INLINE CHARACTER*(SUPLEN) SQZCRD, SUPRCD, TMPCRD COMMON /CHPTR/ COMLNB(COMLEN), COMPTR, INDENT, EOLINE, KYTYPE, * MATLEN, MATLLN, OCRDPT, SCRDPT, SQZIN, SUPOUT, * TCRDPT COMMON /LOGVR/ ADDCON, BRKCOM, COLFMT, CPYFLG, CVTHFI, DONERD, * DOSTAT, EXMCOM, EXMFMT, EXMNEX, FIRSTC, HAVEXS, * INDCOM, INDSTA, ISFMT , ISSCOM, LASTBC, LBTFUL, * LSTIDS, LSTRES, LSTSRC, MORE , NEEDRD, OVRLAY, * PASS0 , PASS1 , PROPCM, QUOTCV, RJLABS, ROUDON, * SIZDEF, SPLTNV, SPLTST, UNCOND, VARUEC, WASCHF, * WASCMD, WASKEY, WASLAB, WASSTR, WASUNC, WRBCOM, * WRCBLK, WRMSG1, WRTFMT, XTRAST, ZEND , ZREAD LOGICAL ADDCON, BRKCOM, COLFMT, CPYFLG, CVTHFI, DONERD, DOSTAT, * EXMCOM, EXMFMT, EXMNEX, FIRSTC, HAVEXS, INDCOM, INDSTA, * ISFMT , ISSCOM, LASTBC, LBTFUL, LSTIDS, LSTRES, LSTSRC, * MORE , NEEDRD, OVRLAY, PASS0 , PASS1 , PROPCM, QUOTCV, * RJLABS, ROUDON, SIZDEF, SPLTNV, SPLTST, UNCOND, VARUEC, * WASCHF, WASCMD, WASKEY, WASLAB, WASSTR, WASUNC, WRBCOM, * WRCBLK, WRMSG1, WRTFMT, XTRAST, ZEND , ZREAD C C FLAG THAT A STRING WAS ENCOUNTERED C WASSTR = .TRUE. C C CONVERT NUMBER. (IT MUST BE AN INTEGER.) C HLEN = CVTNUM (NUMBER, LENGTH) C C IF PASS 1: INSURE STRING PRECEDED BY A VALID CHARACTER C ISSUE THE STRING-START FLAG C IF (PASS1) THEN IF (ISFMT) THEN CHAR = SQZCRD(SQZIN-1:SQZIN-1) IF (CHAR .NE. ',' .AND. CHAR .NE. '/' .AND. * CHAR .NE. ':' .AND. CHAR .NE. '(') CALL PUTSTR (',',1) ENDIF CALL PUTSTR (STRSIG, 1) ENDIF C C ISSUE THE INITIAL QUOTE MARK. COPY THE =NUMBER= CHARACTERS. C CALL PUTSTR (QUOTCH, 1) DO 20 I = 1 , HLEN IF (SUPOUT .EQ. SCRDPT) THEN CHAR = ' ' ELSE CALL GETC IF (CHAR .EQ. QUOTCH) THEN C C CONVERT =QUOTCH= TO =QUOTCHQUOTCH= SINCE WITHIN QUOTES C CALL PUTC ENDIF ENDIF CALL PUTC 20 CONTINUE C C ISSUE FINAL QUOTE MARK C CALL PUTSTR (QUOTCH, 1) C C GET THE NEXT NON-BLANK CHARACTER. C IF PASS 1 AND IN A FORMAT, INSURE STRING FOLLOWED BY VALID CHAR C CALL GETNBC IF (PASS1 .AND. ISFMT .AND. CHAR .NE. '/' .AND. CHAR .NE. ':' * .AND. CHAR .NE. ',' .AND. CHAR .NE. ')') CALL PUTSTR (',',1) RETURN C END SUBROUTINE INPUTL IMPLICIT INTEGER (A-Z) CHARACTER*1 DEFRET, DEFUNC, DEFQUO, STRSIG CHARACTER*2 VEXTCS C PARAMETER ( CMDLEN = 7 ) PARAMETER ( CMDMAX = 34 ) PARAMETER ( DEFLLN = 72 ) PARAMETER ( DEFLPP = 60 ) PARAMETER ( DEFQUO = '''' ) PARAMETER ( DEFRET = '*' ) PARAMETER ( DEFUNC = ' ' ) PARAMETER ( MAXLLN = 125 ) PARAMETER ( MAXVRL = 8 ) PARAMETER ( MINLLN = 40 ) PARAMETER ( MINLPP = 30 ) PARAMETER ( STRSIG = '?' ) PARAMETER ( VEXTCS = '$_' ) PARAMETER (TMPLEN = MAXLLN+1) C C THIS ROUTINE READS IN CARDS FROM INPUT AND BUILDS THE C SUPER CARD (SUPRCD) CONTAINING THE ENTIRE STATEMENT. C PARAMETER ( COMLEN = 100 ) PARAMETER ( SUPLEN = 1458 ) C COMMON /CHBLK/ CHAR , COMBLK, EOS , EXMCHR, HOLDCH, INLINE, * LN1MSG, LONGKY, NUMBER, NUMLET, QUOTCH, RETPFX, * SPECHR, SQZCRD, SUPRCD, TMPCRD, TMPSTR, UNCONC, * VARBLE CHARACTER*1 CHAR, EOS, EXMCHR, HOLDCH, QUOTCH, RETPFX, UNCONC CHARACTER*17 SPECHR CHARACTER*38 NUMLET CHARACTER*40 LN1MSG, LONGKY, NUMBER, TMPSTR, VARBLE CHARACTER*126 COMBLK(COMLEN), INLINE CHARACTER*(SUPLEN) SQZCRD, SUPRCD, TMPCRD COMMON /CHPTR/ COMLNB(COMLEN), COMPTR, INDENT, EOLINE, KYTYPE, * MATLEN, MATLLN, OCRDPT, SCRDPT, SQZIN, SUPOUT, * TCRDPT COMMON /COUNT/ FMTBAS, FMTINC, INCNT , INDINC, LABASE, LABINC, * LINELN, OLDLEN, PAGELN, RINCNT, ROUCNT, THISLN, * THISPG, TINCNT, TOUCNT COMMON /LOGVR/ ADDCON, BRKCOM, COLFMT, CPYFLG, CVTHFI, DONERD, * DOSTAT, EXMCOM, EXMFMT, EXMNEX, FIRSTC, HAVEXS, * INDCOM, INDSTA, ISFMT , ISSCOM, LASTBC, LBTFUL, * LSTIDS, LSTRES, LSTSRC, MORE , NEEDRD, OVRLAY, * PASS0 , PASS1 , PROPCM, QUOTCV, RJLABS, ROUDON, * SIZDEF, SPLTNV, SPLTST, UNCOND, VARUEC, WASCHF, * WASCMD, WASKEY, WASLAB, WASSTR, WASUNC, WRBCOM, * WRCBLK, WRMSG1, WRTFMT, XTRAST, ZEND , ZREAD LOGICAL ADDCON, BRKCOM, COLFMT, CPYFLG, CVTHFI, DONERD, DOSTAT, * EXMCOM, EXMFMT, EXMNEX, FIRSTC, HAVEXS, INDCOM, INDSTA, * ISFMT , ISSCOM, LASTBC, LBTFUL, LSTIDS, LSTRES, LSTSRC, * MORE , NEEDRD, OVRLAY, PASS0 , PASS1 , PROPCM, QUOTCV, * RJLABS, ROUDON, SIZDEF, SPLTNV, SPLTST, UNCOND, VARUEC, * WASCHF, WASCMD, WASKEY, WASLAB, WASSTR, WASUNC, WRBCOM, * WRCBLK, WRMSG1, WRTFMT, XTRAST, ZEND , ZREAD C CHARACTER*3 ENDSTR CHARACTER*(TMPLEN) TMPLIN LOGICAL HADCOM, NOEND C DATA ENDSTR / 'END' / C C INITIALIZE C HADCOM = .FALSE. NOEND = .FALSE. ZEND = .FALSE. ZREAD = .FALSE. C C RESET COUNT OF ORIGINAL CARDS IN SUPER CARD C 10 OCRDPT = 0 C C READ A CARD. PROCESS IT IF IT IS A COMMENT. C 20 IF (COMPTR.NE.0) CALL DMPCOM 30 IF (NEEDRD) THEN IF (LSTIDS) THEN READ (1,40,END=200) INLINE CALL CAPCHR(INLINE) 40 FORMAT (A) ELSE READ (1,40,END=200) INLINE(1:OLDLEN) CALL CAPCHR(INLINE(1:OLDLEN)) ENDIF L = 1 U = OLDLEN 50 IF (L .EQ. U) THEN IF (INLINE(L:L) .EQ. ' ') THEN EOLINE = L - 1 ELSE EOLINE = L ENDIF ELSE MID = (L+U) / 2 IF (INLINE(MID:U) .NE. ' ') THEN L = MID + 1 GO TO 50 ELSE IF (MID .GT. L) MID = MID - 1 IF (INLINE(L:MID) .NE. ' ') THEN U = MID GO TO 50 ELSE EOLINE = L - 1 ENDIF ENDIF ENDIF INCNT = INCNT + 1 ENDIF OCRDPT = OCRDPT + 1 CHAR = INLINE(1:1) IF ((CHAR.NE.' ' .AND. INDEX(NUMLET(1:10),CHAR).EQ.0) .OR. * EOLINE.EQ.0) THEN OCRDPT = OCRDPT - 1 IF (.NOT.HADCOM .AND. .NOT.CPYFLG) THEN I = SCRDPT OLDTMP = OLDLEN TMPLIN(1:OLDTMP+1) = SUPRCD(1:OLDTMP+1) HADCOM = .TRUE. ENDIF CALL COMMEN GO TO 30 ENDIF C C =INLINE= IS NOT A COMMENT. SEE IF BLANK COMMENT IS NEEDED. C 70 ZREAD = .TRUE. IF (CPYFLG) GO TO 80 IF (BRKCOM .AND. .NOT.FIRSTC .AND. .NOT.LASTBC .AND. ISSCOM) THEN CALL PUTCOM ('C',1) WRBCOM = .TRUE. ENDIF LASTBC = .FALSE. FIRSTC = .TRUE. C C CHECK FOR MISSING END CARD. ISSUE WARNING IF NEED BE. C 80 IF (NOEND .AND. RINCNT.EQ.0) THEN IF (COMPTR.NE.0) CALL DMPCOM RETURN C ENDIF IF (NOEND) THEN IF (LSTSRC) THEN CALL PAGECK(3) WRITE (2,90) 90 FORMAT (/10X,'** NO =END= CARD. =END= SUPPLIED. **'/) ENDIF IF (CPYFLG) THEN WRITE (3,40) INLINE(1:OLDLEN) TOUCNT = TOUCNT + 1 ENDIF ENDIF C C IS THIS THE FIRST CARD IN THE SUPER CARD C IF NOT THE FIRST CARD, CHECK FOR CONTINUATION C IF CONTINUATION, ADD TO SUPER CARD C IF (CPYFLG) GO TO 110 100 IF (HADCOM) THEN SCRDPT = I SUPRCD(1:OLDTMP+1) = TMPLIN(1:OLDTMP+1) HADCOM = .FALSE. ENDIF IF (OCRDPT .EQ. 1) THEN SUPRCD(1:OLDLEN) = INLINE(1:OLDLEN) SCRDPT = OLDLEN TMPEOL = EOLINE ELSEIF (INLINE(6:6).EQ.' ' .OR. INLINE(6:6).EQ.'0') THEN NEEDRD = .FALSE. GO TO 170 C ELSE SUPRCD(SCRDPT+1:SCRDPT+OLDLEN-6) = INLINE(7:OLDLEN) TMPEOL = SCRDPT + EOLINE - 6 SCRDPT = SCRDPT + OLDLEN-6 ENDIF C C IF AT E-O-F, PROCESS THE FINAL CARD C OTHERWISE, SET UP FOR THE NEXT READ C 110 IF (DONERD) GO TO 160 NEEDRD = .TRUE. C C LIST =INLINE= C IF (CPYFLG .OR. OCRDPT .EQ. 1) THEN RINCNT = RINCNT + 1 TINCNT = TINCNT + 1 ENDIF IF (LSTSRC) THEN IF (RINCNT .EQ. 1 .AND. .NOT.PASS1) THEN PASS1 = .TRUE. CALL PAGECK (-1) ELSE CALL PAGECK (1) ENDIF IF (CPYFLG .OR. OCRDPT .EQ. 1) THEN IF (LSTIDS) THEN WRITE (2,120) RINCNT, INLINE 120 FORMAT (1X,I4,'. ',A) ELSE WRITE (2,120) RINCNT, INLINE(1:OLDLEN) ENDIF ELSE IF (LSTIDS) THEN WRITE (2,130) INLINE 130 FORMAT (7X,A) ELSE WRITE (2,130) INLINE(1:OLDLEN) ENDIF ENDIF ENDIF IF (RINCNT .EQ. 1 .AND. .NOT.PASS1) PASS1 = .TRUE. C C ISSUE CARD DIRECTLY TO CLEANED FILE IF COPYING C IF (CPYFLG) THEN WRITE (3,40) INLINE(1:OLDLEN) TOUCNT = TOUCNT + 1 ENDIF C C CHECK FOR =END= CARD C IF (.NOT.CPYFLG .AND. OCRDPT.NE.1) GO TO 20 IF (EOLINE .LT. 9) GO TO 20 I = 6 J = 0 150 I = I + 1 IF (INLINE(I:I).EQ.' ' .AND. I.LE.EOLINE) GO TO 150 IF (I .GT. EOLINE) GO TO 20 J = J + 1 IF (INLINE(I:I).NE.ENDSTR(J:J)) GO TO 20 IF (J .LT. 3) GO TO 150 IF (I .NE. EOLINE) GO TO 20 160 ZEND = .TRUE. IF (CPYFLG) RETURN IF (NOEND) THEN IF (COMPTR.NE.0) CALL DMPCOM IF (RINCNT.EQ.0) RETURN ENDIF C C PROCESS =SUPRCD= C C ADD E-O-S AND HAVE SCRDPT POINT TO IT C 170 SCRDPT = TMPEOL + 1 SUPRCD(SCRDPT:SCRDPT) = EOS C C PARSE THE LINE C 180 KYTYPE = 4 WASLAB = .FALSE. WASSTR = .FALSE. WASUNC = .FALSE. SQZIN = 7 SUPOUT = 7 CALL PROKEY C C GET STATEMENT NUMBER (IF ANY) AND ADD TO THE LIST. C SQZCRD(1:6) = SUPRCD(1:6) LABEL = 0 IF (.NOT.CPYFLG .AND. SUPRCD(1:5) .NE. ' ') THEN LABEL = CVTNUM(SUPRCD(1:5),5) IF (KYTYPE .NE. 5 .OR. .NOT.COLFMT) * CALL LBHASH (LABEL, .TRUE.) ENDIF SQZIN = SQZIN - 2 C C REMOVE ANY TRAILING BLANKS C 190 IF (SQZCRD(SQZIN:SQZIN) .EQ. ' ') THEN SQZIN = SQZIN - 1 IF (SQZIN .GT. 1) GO TO 190 ENDIF IF (SQZIN .LT. 7) THEN SQZCRD(SQZIN+1:7) = ' ' SQZIN = 7 ENDIF IF (KYTYPE .EQ. 5 .AND. COLFMT) THEN WRTFMT = .TRUE. WRITE (7) SQZIN,LABEL,KYTYPE,WASLAB,WASSTR WRITE (7) SQZCRD(1:SQZIN) ELSE WRITE (8) SQZIN,LABEL,KYTYPE,WASLAB,WASSTR WRITE (8) SQZCRD(1:SQZIN) IF (COMPTR.EQ.0) WRBCOM = .FALSE. ENDIF C C IF THERE IS AN UNCONDITIONAL FLOW CHANGE AND THIS CAUSES C SPECIAL PROCESSING, ISSUE THE TRAILING CARD C IF (WASUNC .AND. UNCOND) THEN IF (UNCONC .EQ. ' ') THEN WRITE (8) 7, 0, 4, .FALSE., .FALSE. SQZCRD(1:7) = UNCONC WRITE (8) SQZCRD(1:7) ELSEIF (UNCONC .EQ. 'C') THEN IF (COMPTR .EQ. 0) CALL PUTCOM (UNCONC,1) ELSE WRITE (8) 1, 0, 0, .FALSE., .FALSE. WRITE (8) UNCONC ENDIF ENDIF C C IF EXTRA STATEMENTS ON THIS CARD, PROCESS THEM C IF (XTRAST) THEN SQZCRD(1:6) = ' ' SUPRCD(1:TCRDPT+1) = TMPCRD(1:TCRDPT) // EOS SCRDPT = TCRDPT + 1 TCRDPT = 0 LABEL = 0 GO TO 180 ENDIF IF (COMPTR.NE.0) CALL DMPCOM IF (.NOT.ZEND) GO TO 10 RETURN C C READ EOR/EOF. IF MISSING FINAL =END= CARD, ADD ONE. C 200 DONERD = .TRUE. IF (.NOT.ZREAD) RETURN NOEND = .TRUE. INLINE = ' END' OCRDPT = 2 EOLINE = 9 IF (CPYFLG) GO TO 70 IF (RINCNT.EQ.0) GO TO 160 GO TO 100 C END SUBROUTINE IOCTRL IMPLICIT INTEGER (A-Z) C PARAMETER ( COMLEN = 100 ) PARAMETER ( SUPLEN = 1458 ) C COMMON /CHBLK/ CHAR , COMBLK, EOS , EXMCHR, HOLDCH, INLINE, * LN1MSG, LONGKY, NUMBER, NUMLET, QUOTCH, RETPFX, * SPECHR, SQZCRD, SUPRCD, TMPCRD, TMPSTR, UNCONC, * VARBLE CHARACTER*1 CHAR, EOS, EXMCHR, HOLDCH, QUOTCH, RETPFX, UNCONC CHARACTER*17 SPECHR CHARACTER*38 NUMLET CHARACTER*40 LN1MSG, LONGKY, NUMBER, TMPSTR, VARBLE CHARACTER*126 COMBLK(COMLEN), INLINE CHARACTER*(SUPLEN) SQZCRD, SUPRCD, TMPCRD COMMON /CHPTR/ COMLNB(COMLEN), COMPTR, INDENT, EOLINE, KYTYPE, * MATLEN, MATLLN, OCRDPT, SCRDPT, SQZIN, SUPOUT, * TCRDPT C C ISSUE INITIAL =(= C HOLDCH = '(' CALL PUTC CALL GETNBC C C CHECK FOR SPECIAL CHARACTER, LETTER OR NUMBER C 20 INDX = INDEX (NUMLET,CHAR) IF (INDX .EQ. 0) THEN C C IS SPECIAL CHARACTER. SEE WHICH ONE C HOLDCH = CHAR IF (CHAR .EQ. '(') THEN CALL GENLEX (.FALSE.,.TRUE.) ELSEIF (CHAR .NE. ')') THEN CALL GENLEX (.TRUE.,.FALSE.) ELSE C C =)=, SO DONE C GO TO 30 ENDIF C ELSEIF (INDX .GT. 10) THEN C C A LETTER C SUPOUT = SUPOUT - 1 CALL GETVAR (.FALSE.,LENGTH) CALL PUTSTR (VARBLE,LENGTH) C ELSE C C A NUMBER C SUPOUT = SUPOUT - 1 CALL GETNUM (.FALSE.,LENGTH) IF (CHAR .EQ. ',' .OR. CHAR .EQ. ')') THEN IF (HOLDCH .EQ. ',' .OR. * (HOLDCH .EQ. '=' .AND. (VARBLE .EQ. 'DUPKEY' .OR. * VARBLE .EQ. 'END' .OR. * VARBLE .EQ. 'ERR' .OR. * VARBLE .EQ. 'FMT' .OR. * VARBLE .EQ. 'NOTFOUND'))) THEN I =CVTNUM(NUMBER,LENGTH) CALL LBHASH (I,.FALSE.) ENDIF ENDIF CALL PUTSTR (NUMBER,LENGTH) ENDIF GO TO 20 C C ISSUE TERMINATING =)=, A SPACE AND RETURN C 30 CALL PUTSTR (') ',2) CALL GETNBC RETURN C END SUBROUTINE LBHASH(LABEL,DEFINE) IMPLICIT INTEGER (A-Z) C CHARACTER*1 LABSIG C PARAMETER ( DOTLEN = 30 ) PARAMETER ( INDMAX = 30 ) C PARAMETER ( LABSIG = '\' ) PARAMETER ( LBTLEN = 509 ) PARAMETER ( LBTLN3 = 3*LBTLEN ) C C THIS ROUTINE TAKES A LABEL NUMBER =LABEL= AND ADDS IT TO C THE LABEL TABLE =LBLTBL=. IF =DEFINE= IS .TRUE., THIS IS C A LABEL DEFINITION. IF =DEFINE= IS .FALSE., THIS IS A LABEL C USE. C PARAMETER ( COMLEN = 100 ) PARAMETER ( SUPLEN = 1458 ) C CHARACTER*1 CHAR C COMMON /CHBLK/ CHAR1 , COMBLK, EOS , EXMCHR, HOLDCH, INLINE, * LN1MSG, LONGKY, NUMBER, NUMLET, QUOTCH, RETPFX, * SPECHR, SQZCRD, SUPRCD, TMPCRD, TMPSTR, UNCONC, * VARBLE CHARACTER*1 CHAR1, EOS, EXMCHR, HOLDCH, QUOTCH, RETPFX, UNCONC CHARACTER*17 SPECHR CHARACTER*38 NUMLET CHARACTER*40 LN1MSG, LONGKY, NUMBER, TMPSTR, VARBLE CHARACTER*126 COMBLK(COMLEN), INLINE CHARACTER*(SUPLEN) SQZCRD, SUPRCD, TMPCRD COMMON /CHPTR/ COMLNB(COMLEN), COMPTR, INDENT, EOLINE, KYTYPE, * MATLEN, MATLLN, OCRDPT, SCRDPT, SQZIN, SUPOUT, * TCRDPT COMMON /COUNT/ FMTBAS, FMTINC, INCNT , INDINC, LABASE, LABINC, * LINELN, OLDLEN, PAGELN, RINCNT, ROUCNT, THISLN, * THISPG, TINCNT, TOUCNT C C COMMON BLOCK: LBDAT - LABEL PROCESSING VARIABLES. C C VARIABLE TYPE USE C -------- ------ ---------------------------------------- C DOCNT I NUMBER OF ACTIVE DO-LOOP LABELS C DOTBL I TABLE OF ACTIVE DO-LOOP LABELS C LBLCNT I NUMBER OF *DEFINED* LABELS IN TABLE C LBLTBL I HASHED LABEL TABLE (LBTLEN,3) WHERE C 1: DEFINED POSITION/NEW VALUE C 2: OLD VALUE C 3: FLAGS: 2-IF USED, 1-IF FORMAT C COMMON /LBDAT/ DOCNT, DOTBL(DOTLEN), LBLCNT, LBLTBL(LBTLEN,3) COMMON /LOGVR/ ADDCON, BRKCOM, COLFMT, CPYFLG, CVTHFI, DONERD, * DOSTAT, EXMCOM, EXMFMT, EXMNEX, FIRSTC, HAVEXS, * INDCOM, INDSTA, ISFMT , ISSCOM, LASTBC, LBTFUL, * LSTIDS, LSTRES, LSTSRC, MORE , NEEDRD, OVRLAY, * PASS0 , PASS1 , PROPCM, QUOTCV, RJLABS, ROUDON, * SIZDEF, SPLTNV, SPLTST, UNCOND, VARUEC, WASCHF, * WASCMD, WASKEY, WASLAB, WASSTR, WASUNC, WRBCOM, * WRCBLK, WRMSG1, WRTFMT, XTRAST, ZEND , ZREAD LOGICAL ADDCON, BRKCOM, COLFMT, CPYFLG, CVTHFI, DONERD, DOSTAT, * EXMCOM, EXMFMT, EXMNEX, FIRSTC, HAVEXS, INDCOM, INDSTA, * ISFMT , ISSCOM, LASTBC, LBTFUL, LSTIDS, LSTRES, LSTSRC, * MORE , NEEDRD, OVRLAY, PASS0 , PASS1 , PROPCM, QUOTCV, * RJLABS, ROUDON, SIZDEF, SPLTNV, SPLTST, UNCOND, VARUEC, * WASCHF, WASCMD, WASKEY, WASLAB, WASSTR, WASUNC, WRBCOM, * WRCBLK, WRMSG1, WRTFMT, XTRAST, ZEND , ZREAD C LOGICAL DEFINE C IF (.NOT.DEFINE) THEN CALL PUTSTR (CHAR(92),1) WASLAB = .TRUE. ELSE LBLCNT = LBLCNT + 1 IF (KYTYPE .EQ. 5 .AND. FMTBAS .NE. 0) THEN FMT = 1 ELSE FMT = 0 ENDIF ENDIF C IF (LBTFUL .OR. LABINC.EQ.0) RETURN C HASHVL = MOD(LABEL,LBTLEN) + 1 HASHSV = HASHVL C 10 IF (LBLTBL(HASHVL,2) .EQ. 0) THEN C C IS A NEW ENTRY. C IF (DEFINE) THEN LBLTBL(HASHVL,1) = LBLCNT LBLTBL(HASHVL,2) = LABEL LBLTBL(HASHVL,3) = FMT ELSE LBLTBL(HASHVL,1) = 0 LBLTBL(HASHVL,2) = LABEL LBLTBL(HASHVL,3) = 2 ENDIF C ELSEIF (LBLTBL(HASHVL,2) .EQ. LABEL) THEN C C WE HAVE SEEN THIS LABEL BEFORE. C IF (DEFINE) THEN LBLTBL(HASHVL,1) = LBLCNT LBLTBL(HASHVL,3) = MOD(LBLTBL(HASHVL,3)/2,2)*2 + FMT ELSE LBLTBL(HASHVL,3) = 2 + MOD(LBLTBL(HASHVL,3),2) ENDIF C ELSE C C WE HAVE A COLLISION. C HASHVL = MOD(HASHVL,LBTLEN) + 1 IF (HASHVL .NE. HASHSV) GO TO 10 C C FULL TABLE. C IF (LSTSRC) THEN CALL PAGECK(3) WRITE (2,20) 20 FORMAT (//,10X,'*** LABEL-NUMBER TABLE OVERFLOW ***') ENDIF LBTFUL = .TRUE. ENDIF RETURN C END INTEGER FUNCTION MATCH (TESTST,DEFST,DEFLEN) IMPLICIT INTEGER (A-Z) CHARACTER*1 DEFRET, DEFUNC, DEFQUO, STRSIG CHARACTER*2 VEXTCS C PARAMETER ( CMDLEN = 7 ) PARAMETER ( CMDMAX = 34 ) PARAMETER ( DEFLLN = 72 ) PARAMETER ( DEFLPP = 60 ) PARAMETER ( DEFQUO = '''' ) PARAMETER ( DEFRET = '*' ) PARAMETER ( DEFUNC = ' ' ) PARAMETER ( MAXLLN = 125 ) PARAMETER ( MAXVRL = 8 ) PARAMETER ( MINLLN = 40 ) PARAMETER ( MINLPP = 30 ) PARAMETER ( STRSIG = '?' ) PARAMETER ( VEXTCS = '$_' ) C C THIS FUNCTION COMPARES STRING =TESTST= TO STRING =DEFST= C AND RETURNS AS ITS VALUE THE FOLLOWING: C VALUE < 0 = NO MATCH. C VALUE = 0 = IDENTICAL STRINGS. C VALUE > 0 = SUPERSTRING WITH =MATCH= EXTRA CHARACTERS. C CHARACTER*(MAXVRL+1) DEFST CHARACTER*40 TESTST C IF (TESTST(1:DEFLEN) .NE. DEFST(1:DEFLEN)) THEN MATCH = -1 ELSE I = DEFLEN 10 I = I + 1 IF (TESTST(I:I) .NE. ' ' .AND. I .LT. 40) GO TO 10 MATCH = I - DEFLEN - 1 ENDIF RETURN C END SUBROUTINE PAGECK(ADDLIN) IMPLICIT INTEGER (A-Z) CHARACTER*1 DEFRET, DEFUNC, DEFQUO, STRSIG CHARACTER*2 VEXTCS C PARAMETER ( CMDLEN = 7 ) PARAMETER ( CMDMAX = 34 ) PARAMETER ( DEFLLN = 72 ) PARAMETER ( DEFLPP = 60 ) PARAMETER ( DEFQUO = '''' ) PARAMETER ( DEFRET = '*' ) PARAMETER ( DEFUNC = ' ' ) PARAMETER ( MAXLLN = 125 ) PARAMETER ( MAXVRL = 8 ) PARAMETER ( MINLLN = 40 ) PARAMETER ( MINLPP = 30 ) PARAMETER ( STRSIG = '?' ) PARAMETER ( VEXTCS = '$_' ) C PARAMETER ( MAXHDR = MAXLLN+7 ) C C THIS ROUTINE INSURE THAT NO MORE THAN =PAGELN-2= LINES C (EXCLUDING THE HEADER) ARE WRITTEN A GIVEN PAGE OF OUTPUT. C PARAMETER ( COMLEN = 100 ) PARAMETER ( SUPLEN = 1458 ) C COMMON /CHBLK/ CHAR , COMBLK, EOS , EXMCHR, HOLDCH, INLINE, * LN1MSG, LONGKY, NUMBER, NUMLET, QUOTCH, RETPFX, * SPECHR, SQZCRD, SUPRCD, TMPCRD, TMPSTR, UNCONC, * VARBLE CHARACTER*1 CHAR, EOS, EXMCHR, HOLDCH, QUOTCH, RETPFX, UNCONC CHARACTER*17 SPECHR CHARACTER*38 NUMLET CHARACTER*40 LN1MSG, LONGKY, NUMBER, TMPSTR, VARBLE CHARACTER*126 COMBLK(COMLEN), INLINE CHARACTER*(SUPLEN) SQZCRD, SUPRCD, TMPCRD COMMON /COUNT/ FMTBAS, FMTINC, INCNT , INDINC, LABASE, LABINC, * LINELN, OLDLEN, PAGELN, RINCNT, ROUCNT, THISLN, * THISPG, TINCNT, TOUCNT COMMON /LOGVR/ ADDCON, BRKCOM, COLFMT, CPYFLG, CVTHFI, DONERD, * DOSTAT, EXMCOM, EXMFMT, EXMNEX, FIRSTC, HAVEXS, * INDCOM, INDSTA, ISFMT , ISSCOM, LASTBC, LBTFUL, * LSTIDS, LSTRES, LSTSRC, MORE , NEEDRD, OVRLAY, * PASS0 , PASS1 , PROPCM, QUOTCV, RJLABS, ROUDON, * SIZDEF, SPLTNV, SPLTST, UNCOND, VARUEC, WASCHF, * WASCMD, WASKEY, WASLAB, WASSTR, WASUNC, WRBCOM, * WRCBLK, WRMSG1, WRTFMT, XTRAST, ZEND , ZREAD LOGICAL ADDCON, BRKCOM, COLFMT, CPYFLG, CVTHFI, DONERD, DOSTAT, * EXMCOM, EXMFMT, EXMNEX, FIRSTC, HAVEXS, INDCOM, INDSTA, * ISFMT , ISSCOM, LASTBC, LBTFUL, LSTIDS, LSTRES, LSTSRC, * MORE , NEEDRD, OVRLAY, PASS0 , PASS1 , PROPCM, QUOTCV, * RJLABS, ROUDON, SIZDEF, SPLTNV, SPLTST, UNCOND, VARUEC, * WASCHF, WASCMD, WASKEY, WASLAB, WASSTR, WASUNC, WRBCOM, * WRCBLK, WRMSG1, WRTFMT, XTRAST, ZEND , ZREAD C CHARACTER*8 CRDTYP CHARACTER*10 THISDT, THISTM C CHARACTER*10 DATE, TIME CHARACTER*(MAXHDR) HEADER C C IF ADDLIN > 0, SEE IF =ADDLIN= LINES WILL FIT. C IF ADDLIN <= 0, FORCE AN EJECT AND SET LINE COUNT TO =-ADDLIN=. C IF (ADDLIN .GT. 0) THEN THISLN = THISLN + ADDLIN IF (THISLN .LE. PAGELN-2) RETURN TEMP = ADDLIN ELSE TEMP = -ADDLIN ENDIF THISLN = TEMP THISPG = THISPG + 1 C C JVB fix this later. C THISDT=' ' THISTM=' ' C CALL DATE(THISDT) C CALL TIME(THISTM) IF (PASS0 .OR. PASS1) THEN IF (PASS0) THEN I = DEFLLN+7 ELSEIF (.NOT.LSTIDS) THEN I = MAX (DEFLLN+7,OLDLEN+7) ELSE I = MAXLLN+2 ENDIF ELSE I = MAX (DEFLLN+7,LINELN+7) IF (EXMFMT .OR. EXMNEX) I = MAX (I,OLDLEN+7) ENDIF CALL CVTLAB (THISPG,LENGTH,.TRUE.) IF (PASS0) THEN IF (.NOT.DONERD) THEN CRDTYP = '*PRESET*' ELSE CRDTYP = '*TOTALS*' LN1MSG = ' ' ENDIF ELSEIF (PASS1) THEN CRDTYP = '*SOURCE*' ELSE CRDTYP = '*RESULT*' ENDIF HEADER = '1CLEAN77 - V2.23 (GENL) ' // CRDTYP // ' ' // * LN1MSG(8:20) // ' ' // THISDT // THISTM HEADER(I-7:I-4) = 'PAGE' HEADER(I-3:I) = TMPSTR(2:5) WRITE (2,30) HEADER(1:I) 30 FORMAT (A/) RETURN C END SUBROUTINE PRESET IMPLICIT INTEGER (A-Z) C C THIS ROUTINE PERFORMS INITIALIZATION STEPS C PARAMETER ( COMLEN = 100 ) PARAMETER ( SUPLEN = 1458 ) C COMMON /CHBLK/ CHAR , COMBLK, EOS , EXMCHR, HOLDCH, INLINE, * LN1MSG, LONGKY, NUMBER, NUMLET, QUOTCH, RETPFX, * SPECHR, SQZCRD, SUPRCD, TMPCRD, TMPSTR, UNCONC, * VARBLE CHARACTER*1 CHAR, EOS, EXMCHR, HOLDCH, QUOTCH, RETPFX, UNCONC CHARACTER*17 SPECHR CHARACTER*38 NUMLET CHARACTER*40 LN1MSG, LONGKY, NUMBER, TMPSTR, VARBLE CHARACTER*126 COMBLK(COMLEN), INLINE CHARACTER*(SUPLEN) SQZCRD, SUPRCD, TMPCRD COMMON /LOGVR/ ADDCON, BRKCOM, COLFMT, CPYFLG, CVTHFI, DONERD, * DOSTAT, EXMCOM, EXMFMT, EXMNEX, FIRSTC, HAVEXS, * INDCOM, INDSTA, ISFMT , ISSCOM, LASTBC, LBTFUL, * LSTIDS, LSTRES, LSTSRC, MORE , NEEDRD, OVRLAY, * PASS0 , PASS1 , PROPCM, QUOTCV, RJLABS, ROUDON, * SIZDEF, SPLTNV, SPLTST, UNCOND, VARUEC, WASCHF, * WASCMD, WASKEY, WASLAB, WASSTR, WASUNC, WRBCOM, * WRCBLK, WRMSG1, WRTFMT, XTRAST, ZEND , ZREAD LOGICAL ADDCON, BRKCOM, COLFMT, CPYFLG, CVTHFI, DONERD, DOSTAT, * EXMCOM, EXMFMT, EXMNEX, FIRSTC, HAVEXS, INDCOM, INDSTA, * ISFMT , ISSCOM, LASTBC, LBTFUL, LSTIDS, LSTRES, LSTSRC, * MORE , NEEDRD, OVRLAY, PASS0 , PASS1 , PROPCM, QUOTCV, * RJLABS, ROUDON, SIZDEF, SPLTNV, SPLTST, UNCOND, VARUEC, * WASCHF, WASCMD, WASKEY, WASLAB, WASSTR, WASUNC, WRBCOM, * WRCBLK, WRMSG1, WRTFMT, XTRAST, ZEND , ZREAD C CHARACTER*80 FILNAM C LN1MSG = 'CLEAN:' PASS0 = .TRUE. C 9 CONTINUE WRITE (*,*)'Name of FORTRAN file to be cleaned up?' READ (*,'(A)') FILNAM IF (FILNAM(1:1).EQ.' ') FILNAM = 'FORT1' OPEN (1,FILE=FILNAM,STATUS='OLD',ERR=25) C WRITE (*,*)'Name for cleaned-up output file?' READ (*,'(A)') FILNAM IF (FILNAM(1:1).EQ.' ') FILNAM = 'FORT3' OPEN (3,FILE=FILNAM,STATUS='replace') C WRITE (*,*)'Name for list output file?' READ (*,'(A)') FILNAM IF (FILNAM(1:1).EQ.' ') FILNAM = 'FORT2' OPEN (2,FILE=FILNAM,STATUS='NEW') C WRITE (*,*)'Name of optional input command file?' READ (*,'(A)') FILNAM IF (FILNAM(1:1).EQ.' ') FILNAM = 'FORT4' OPEN (4,FILE=FILNAM,STATUS='UNKNOWN') C C OPEN THE SCRATCH FILES C OPEN (7,STATUS='SCRATCH',FORM='UNFORMATTED') OPEN (8,STATUS='SCRATCH',FORM='UNFORMATTED') OPEN (9,STATUS='SCRATCH',FORM='UNFORMATTED') C REWIND 7 REWIND 8 RETURN C 25 CONTINUE WRITE(*,*)'Routine PRESET could not open the file',FILNAM WRITE(*,*)'Please try to enter the name again.' GO TO 9 C END SUBROUTINE PROKEY IMPLICIT INTEGER (A-Z) CHARACTER*1 DEFRET, DEFUNC, DEFQUO, STRSIG CHARACTER*2 VEXTCS C PARAMETER ( CMDLEN = 7 ) PARAMETER ( CMDMAX = 34 ) PARAMETER ( DEFLLN = 72 ) PARAMETER ( DEFLPP = 60 ) PARAMETER ( DEFQUO = '''' ) PARAMETER ( DEFRET = '*' ) PARAMETER ( DEFUNC = ' ' ) PARAMETER ( MAXLLN = 125 ) PARAMETER ( MAXVRL = 8 ) PARAMETER ( MINLLN = 40 ) PARAMETER ( MINLPP = 30 ) PARAMETER ( STRSIG = '?' ) PARAMETER ( VEXTCS = '$_' ) C C PARAMETER TYPE USE C --------- ---- --------------------------------------- C BOKYLM I LAST ARRAY ENTRY OF A =BOTH= TYPE KEY C ENDXLM I ENTRY CONTAINING =END= C EXKYLM I LAST ARRAY ENTRY OF AN EXECUTABLE KEY C FRKYLM I LAST ARRAY ENTRY OF A =FIRST CARD= TYPE KEY C NXKYLM I LAST ARRAY ENTRY OF A NON-EXECUTABLE KEY C TOTKEY I LAST ARRAY ENTRY (LENGTH) OF KEY ARRAY C PARAMETER ( FRKYLM=5 , NXKYLM=FRKYLM+18 , BOKYLM=NXKYLM+4 , * ENDXLM=BOKYLM+18, EXKYLM=ENDXLM+19 , TOTKEY=EXKYLM ) C C THIS ROUTINE DOES THE LINE PARSING OF THE SUPERCARD =SUPRCD=. C PARAMETER ( COMLEN = 100 ) PARAMETER ( SUPLEN = 1458 ) C COMMON /CHBLK/ CHAR , COMBLK, EOS , EXMCHR, HOLDCH, INLINE, * LN1MSG, LONGKY, NUMBER, NUMLET, QUOTCH, RETPFX, * SPECHR, SQZCRD, SUPRCD, TMPCRD, TMPSTR, UNCONC, * VARBLE CHARACTER*1 CHAR, EOS, EXMCHR, HOLDCH, QUOTCH, RETPFX, UNCONC CHARACTER*17 SPECHR CHARACTER*38 NUMLET CHARACTER*40 LN1MSG, LONGKY, NUMBER, TMPSTR, VARBLE CHARACTER*126 COMBLK(COMLEN), INLINE CHARACTER*(SUPLEN) SQZCRD, SUPRCD, TMPCRD COMMON /CHPTR/ COMLNB(COMLEN), COMPTR, INDENT, EOLINE, KYTYPE, * MATLEN, MATLLN, OCRDPT, SCRDPT, SQZIN, SUPOUT, * TCRDPT COMMON /COUNT/ FMTBAS, FMTINC, INCNT , INDINC, LABASE, LABINC, * LINELN, OLDLEN, PAGELN, RINCNT, ROUCNT, THISLN, * THISPG, TINCNT, TOUCNT COMMON /LOGVR/ ADDCON, BRKCOM, COLFMT, CPYFLG, CVTHFI, DONERD, * DOSTAT, EXMCOM, EXMFMT, EXMNEX, FIRSTC, HAVEXS, * INDCOM, INDSTA, ISFMT , ISSCOM, LASTBC, LBTFUL, * LSTIDS, LSTRES, LSTSRC, MORE , NEEDRD, OVRLAY, * PASS0 , PASS1 , PROPCM, QUOTCV, RJLABS, ROUDON, * SIZDEF, SPLTNV, SPLTST, UNCOND, VARUEC, WASCHF, * WASCMD, WASKEY, WASLAB, WASSTR, WASUNC, WRBCOM, * WRCBLK, WRMSG1, WRTFMT, XTRAST, ZEND , ZREAD LOGICAL ADDCON, BRKCOM, COLFMT, CPYFLG, CVTHFI, DONERD, DOSTAT, * EXMCOM, EXMFMT, EXMNEX, FIRSTC, HAVEXS, INDCOM, INDSTA, * ISFMT , ISSCOM, LASTBC, LBTFUL, LSTIDS, LSTRES, LSTSRC, * MORE , NEEDRD, OVRLAY, PASS0 , PASS1 , PROPCM, QUOTCV, * RJLABS, ROUDON, SIZDEF, SPLTNV, SPLTST, UNCOND, VARUEC, * WASCHF, WASCMD, WASKEY, WASLAB, WASSTR, WASUNC, WRBCOM, * WRCBLK, WRMSG1, WRTFMT, XTRAST, ZEND , ZREAD C CHARACTER*(MAXVRL+1) KEYWRD(TOTKEY) INTEGER KEYLEN(TOTKEY), KEYLET(TOTKEY) LOGICAL KEYBLT, WASMOR C DATA (KEYLEN(I), KEYLET(I), KEYWRD(I),I=1,FRKYLM) / * 9, 2,'BLOCKDATA', 8, 6,'FUNCTION ', 7,15,'OVERLAY ', * 7,16,'PROGRAM ', 10,19,'SUBROUTIN' / DATA (KEYLEN(I), KEYLET(I), KEYWRD(I),I=FRKYLM+1,NXKYLM) / * 3, 2,'BIT ', 9, 3,'CHARACTER', 6, 3,'COMMON ', * 7, 3,'COMPLEX ', 10, 4,'DESCRIPTO', 9, 4,'DIMENSION', * 6, 4,'DOUBLE ', 11, 5,'EQUIVALEN', 8, 5,'EXTERNAL ', * 4, 8,'HALF ', 8, 9,'IMPLICIT ', 7, 9,'INTEGER ', * 9, 9,'INTRINSIC', 7,12,'LOGICAL ', 9,16,'PARAMETER', * 4,18,'REAL ', 7,18,'ROWWISE ', 4,19,'SAVE ' / DATA (KEYLEN(I), KEYLET(I), KEYWRD(I),I=NXKYLM+1,BOKYLM) / * 4, 4,'DATA ', 5, 5,'ENTRY ', 6, 6,'FORMAT ', * 7, 9,'INCLUDE ' / DATA (KEYLEN(I), KEYLET(I), KEYWRD(I),I=BOKYLM+1,ENDXLM) / * 6, 1,'ASSIGN ', 9, 2,'BACKSPACE', 8, 2,'BUFFERIN ', * 9, 2,'BUFFEROUT', 4, 3,'CALL ', 5, 3,'CLOSE ', * 8, 3,'CONTINUE ', 6, 4,'DECODE ', 6, 4,'DELETE ', * 2, 4,'DO ', 6, 5,'ELSEIF ', 4, 5,'ELSE ', * 6, 5,'ENCODE ', 7, 5,'ENDFILE ', 5, 5,'ENDIF ', * 8, 5,'ENDWHERE ', 8, 5,'ENDWHILE ', 3, 5,'END ' / DATA (KEYLEN(I), KEYLET(I), KEYWRD(I),I=ENDXLM+1,EXKYLM) / * 4, 6,'FREE ', 4, 7,'GOTO ', 2, 9,'IF ', * 7, 9,'INQUIRE ', 8,14,'NAMELIST ', 4,15,'OPEN ', * 9,15,'OTHERWISE', 5,16,'PAUSE ', 5,16,'PRINT ', * 5,16,'PUNCH ', 4,18,'READ ', 6,18,'RETURN ', * 6,18,'REWIND ', 7,18,'REWRITE ', 4,19,'STOP ', * 4,23,'WAIT ', 5,23,'WHERE ', 5,23,'WHILE ', * 5,23,'WRITE ' / C C ISSUE A CONSOLE LINE 1 MESSAGE IN CASE NO PROG/SUBR/.... C IF (.NOT.CPYFLG .AND. (RINCNT.EQ.1.OR.(OVRLAY.AND.RINCNT.EQ.2))) * THEN LN1MSG = 'CLEAN:' ELSEIF (.NOT.WRMSG1 .AND. .NOT.CPYFLG .AND. (RINCNT .GT. 1)) THEN LN1MSG = 'CLEAN: PROG/*NONAME*' WRMSG1 = .TRUE. ENDIF C C INITIALIZE C WASMOR = .FALSE. C C GET THE FIRST CHARACTER AND DO INITIAL PARSING BASE ON IT. C 10 KEYBLT = .FALSE. WASCHF = .FALSE. HOLDSU = SUPOUT CALL GETNBC IF (CHAR .EQ. EOS) THEN CALL GENLEX (.TRUE.,.FALSE.) RETURN C ENDIF LETTER = INDEX(NUMLET,CHAR) - 10 IF (ZEND) GO TO 160 IF (.NOT.HAVEXS) THEN IF (RINCNT .EQ. 1 .OR. (OVRLAY .AND. RINCNT.EQ.2)) THEN GOTO ( 30, 120, 130, 130, 130, 120, 30, 130, 130, 40, * 40, 130, 40, 30, 120, 120, 40, 130, 120, 40, * 40, 40, 30, 40, 40, 40, 40, 40) * , LETTER ELSE GOTO ( 30, 130, 130, 130, 130, 130, 30, 130, 130, 40, * 40, 130, 40, 30, 30, 130, 40, 130, 130, 40, * 40, 40, 30, 40, 40, 40, 40, 40) * , LETTER ENDIF ENDIF C C IT WAS NOT NON-EXECUTABLE, SO TRY FOR AN EXECUTABLE KEY. C 30 HAVEXS = .TRUE. GOTO (150, 150, 150, 140, 140, 140, 150, 40, 140, 40, * 40, 40, 40, 150, 150, 150, 40, 150, 150, 40, * 40, 40, 150, 40, 40, 40, 40, 40) * , LETTER C C ASSIGNMENT STATEMENT PROCESSING C 40 HAVEXS = .TRUE. SUPOUT = HOLDSU COLUMN = HASDOL () DO 50 I = SUPOUT , COLUMN-1 IF (SUPRCD(I:I) .EQ. '=') GO TO 60 50 CONTINUE I = SUPOUT 60 HOLDEQ = I DO 70 J = COLUMN-1 , HOLDEQ-1 , -1 IF (SUPRCD(J:J) .EQ. '=') GO TO 80 70 CONTINUE J = HOLDEQ 80 IF (J .EQ. HOLDEQ) GO TO 110 C C MULTIPLE EQUAL SIGNS - SAVE THE FIRST PART AND BEGIN C PROCESSING AT APPROPRIATE POINT. C DO 90 I = J-1 , SUPOUT , -1 IF (SUPRCD(I:I).EQ.'=') GO TO 100 90 CONTINUE 100 TCRDPT = 6 + J - SUPOUT TMPCRD(1:TCRDPT) = SUPRCD(1:6) // SUPRCD(SUPOUT:J-1) SUPOUT = I+1 XTRAST = .TRUE. C C PROCESS THE ASSIGNMENT C 110 CALL GETNBC WASKEY = .FALSE. CALL GENLEX(.FALSE.,.FALSE.) KYTYPE = 4 RETURN C C PREPARE TO SCAN THE APPROPRIATE SECTION OF THE KEY WORD TABLE C 120 KYSTRT = 1 KYEND = FRKYLM SCNTYP = 1 GO TO 170 C 130 KYSTRT = FRKYLM+1 KYEND = NXKYLM SCNTYP = 2 GO TO 170 C 140 KYSTRT = NXKYLM+1 KYEND = BOKYLM SCNTYP = 3 GO TO 170 C 150 KYSTRT = BOKYLM+1 KYEND = EXKYLM HAVEXS = .TRUE. SCNTYP = 4 GO TO 170 C 160 KYSTRT = ENDXLM KYEND = ENDXLM SCNTYP = 4 C C BUILD THE =MAYBE= KEY AND LONG (INCLUDING NUMBERS) KEY C 170 IF (.NOT.KEYBLT) THEN SUPOUT = SUPOUT - 1 CALL GETVAR(.TRUE.,LENGTH) LONGKY = VARBLE IF (INDEX(NUMLET,CHAR).NE.0) THEN TMPSTR = VARBLE I = SUPOUT IL = LENGTH SUPOUT = SUPOUT - 1 CALL GETVAR (.FALSE.,LENGTH) LONGKY = TMPSTR(1:IL) // VARBLE(1:LENGTH) LENGTH = IL SUPOUT = I - 1 VARBLE = TMPSTR CALL GETNBC ENDIF KEYBLT = .TRUE. ENDIF C C TRY TO FIND A MATCH C KYTYPE = 4 MORE = .FALSE. WASKEY = .FALSE. DO 190 I = KYSTRT , KYEND IF (LETTER .GT. KEYLET(I)) GO TO 190 IF (LETTER .LT. KEYLET(I)) GOTO (130, 140, 150, 40) , SCNTYP LENSTR = MIN(KEYLEN(I),9) MATLEN = MATCH(VARBLE,KEYWRD(I),LENSTR) IF (MATLEN .GE. 0) THEN WASKEY = .TRUE. MATLLN = MATCH (LONGKY,KEYWRD(I),LENSTR) GOTO (210, 220, 240, 250, 260, 270, 280, 290, 300, 310, * 320, 330, 340, 350, 360, 370, 300, 380, 300, 320, * 400, 300, 390, 400, 410, 420, 430, 440, 450, 460, * 470, 480, 490, 500, 510, 520, 530, 540, 550, 510, * 560, 570, 500, 500, 580, 590, 600, 610, 620, 630, * 640, 650, 660, 670, 670, 680, 690, 710, 720, 730, * 680, 740, 750, 670) * , I ENDIF 190 CONTINUE C GOTO (130, 140, 150, 40) , SCNTYP C C SEE IF WE FOUND A KEYWORD (OR AN IF(EXP) MORE). C 200 IF (.NOT.WASKEY) GO TO 40 C C IF FORMAT/NONEXECUTABLE, CHECK FOR EXEMPTION FROM PROCESSING C IF (((KYTYPE .EQ. 5) .AND. EXMFMT) .OR. * ((KYTYPE .EQ. 8) .AND. EXMNEX) ) THEN SQZIN = 7 CALL PUTSTR (SUPRCD(7:SCRDPT),SCRDPT-6) ENDIF C C IF MORE TO THIS STATEMENT (E.G., REST OF AN =IF=) C IF (MORE) THEN KEYBLT = .FALSE. WASMOR = .TRUE. GO TO 10 C ENDIF IF (WASMOR) WASUNC = .FALSE. RETURN C C JUMP TABLE THAT *** ALWAYS *** USES A NON-STANDARD RETURN. C 210 CALL XBLOCK (*200) 220 CALL XFUNCT (*200) 240 CALL XOVERL (*200) 250 CALL XPROGR (*200) 260 CALL XSUBRO (*200) C 270 CALL XBIT (*200) 280 CALL XCHARA (*200) 290 CALL XCOMMO (*200) 300 CALL XCOMPL (*200) 310 CALL XDESCR (*200) 320 CALL XDIMEN (*200) 330 CALL XDOUBL (*200) 340 CALL XEQUIV (*200) 350 CALL XEXTER (*200) 360 CALL XHALF (*200) 370 CALL XIMPLI (*200) C *** CALL XINTEG (*200) 380 CALL XINTRI (*200) C *** CALL XLOGIC (*200) C *** CALL XPARAM (*200) C *** CALL XREAL (*200) C *** CALL XROWWI (*200) 390 CALL XSAVE (*200) C 400 CALL XDATA (*200) 410 CALL XENTRY (*200) 420 CALL XFORMA (*200) 430 CALL XINCLU (*200) C 440 CALL XASSIG (*200) 450 CALL XBACKS (*200) 460 CALL XBUFFI (*200) 470 CALL XBUFFO (*200) 480 CALL XCALL (*200) 490 CALL XCLOSE (*200) 500 CALL XCONTI (*200) 510 CALL XDECOD (*200) 520 CALL XDELET (*200) 530 CALL XDO (*200) 540 CALL XELSEI (*200) 550 CALL XELSE (*200) C *** CALL XENCOD (*200) 560 CALL XENDFI (*200) 570 CALL XENDIF (*200) C *** CALL XENDWH (*200) C *** CALL XENDWH (*200) 580 CALL XEND (*200) 590 CALL XFREE (*200) 600 CALL XGOTO (*200) 610 CALL XIF (*200) 620 CALL XINQUI (*200) 630 CALL XNAMEL (*200) 640 CALL XOPEN (*200) 650 CALL XOTHER (*200) 660 CALL XPAUSE (*200) 670 CALL XPRINT (*200) C *** CALL XPUNCH (*200) 680 CALL XREAD (*200) C C IF RETURN, KYTYPE = 4, NOT 8 (B. MCKINNON) C 690 CALL XRETUR (*700) 700 IF (WASKEY) KYTYPE = 4 GO TO 200 C 710 CALL XREWIN (*200) 720 CALL XREWRI (*200) 730 CALL XSTOP (*200) C *** CALL XWAIT (*200) 740 CALL XWHERE (*200) 750 CALL XWHILE (*200) C *** CALL XWRITE (*200) C END SUBROUTINE PROROU IMPLICIT INTEGER (A-Z) C CHARACTER*1 LABSIG C PARAMETER ( DOTLEN = 30 ) PARAMETER ( INDMAX = 30 ) C PARAMETER ( LABSIG = '\' ) PARAMETER ( LBTLEN = 509 ) PARAMETER ( LBTLN3 = 3*LBTLEN ) CHARACTER*1 DEFRET, DEFUNC, DEFQUO, STRSIG CHARACTER*2 VEXTCS C PARAMETER ( CMDLEN = 7 ) PARAMETER ( CMDMAX = 34 ) PARAMETER ( DEFLLN = 72 ) PARAMETER ( DEFLPP = 60 ) PARAMETER ( DEFQUO = '''' ) PARAMETER ( DEFRET = '*' ) PARAMETER ( DEFUNC = ' ' ) PARAMETER ( MAXLLN = 125 ) PARAMETER ( MAXVRL = 8 ) PARAMETER ( MINLLN = 40 ) PARAMETER ( MINLPP = 30 ) PARAMETER ( STRSIG = '?' ) PARAMETER ( VEXTCS = '$_' ) C C PASS 2 - PROCESS ENTIRE ROUTINE. C PARAMETER ( COMLEN = 100 ) PARAMETER ( SUPLEN = 1458 ) C CHARACTER*1 CHAR C COMMON /CHBLK/ CHAR1 , COMBLK, EOS , EXMCHR, HOLDCH, INLINE, * LN1MSG, LONGKY, NUMBER, NUMLET, QUOTCH, RETPFX, * SPECHR, SQZCRD, SUPRCD, TMPCRD, TMPSTR, UNCONC, * VARBLE CHARACTER*1 CHAR1,EOS, EXMCHR, HOLDCH, QUOTCH, RETPFX, UNCONC CHARACTER*17 SPECHR CHARACTER*38 NUMLET CHARACTER*40 LN1MSG, LONGKY, NUMBER, TMPSTR, VARBLE CHARACTER*126 COMBLK(COMLEN), INLINE CHARACTER*(SUPLEN) SQZCRD, SUPRCD, TMPCRD COMMON /CHPTR/ COMLNB(COMLEN), COMPTR, INDENT, EOLINE, KYTYPE, * MATLEN, MATLLN, OCRDPT, SCRDPT, SQZIN, SUPOUT, * TCRDPT COMMON /COUNT/ FMTBAS, FMTINC, INCNT , INDINC, LABASE, LABINC, * LINELN, OLDLEN, PAGELN, RINCNT, ROUCNT, THISLN, * THISPG, TINCNT, TOUCNT COMMON /LBDAT/ DOCNT, DOTBL(DOTLEN), LBLCNT, LBLTBL(LBTLEN,3) COMMON /LOGVR/ ADDCON, BRKCOM, COLFMT, CPYFLG, CVTHFI, DONERD, * DOSTAT, EXMCOM, EXMFMT, EXMNEX, FIRSTC, HAVEXS, * INDCOM, INDSTA, ISFMT , ISSCOM, LASTBC, LBTFUL, * LSTIDS, LSTRES, LSTSRC, MORE , NEEDRD, OVRLAY, * PASS0 , PASS1 , PROPCM, QUOTCV, RJLABS, ROUDON, * SIZDEF, SPLTNV, SPLTST, UNCOND, VARUEC, WASCHF, * WASCMD, WASKEY, WASLAB, WASSTR, WASUNC, WRBCOM, * WRCBLK, WRMSG1, WRTFMT, XTRAST, ZEND , ZREAD LOGICAL ADDCON, BRKCOM, COLFMT, CPYFLG, CVTHFI, DONERD, DOSTAT, * EXMCOM, EXMFMT, EXMNEX, FIRSTC, HAVEXS, INDCOM, INDSTA, * ISFMT , ISSCOM, LASTBC, LBTFUL, LSTIDS, LSTRES, LSTSRC, * MORE , NEEDRD, OVRLAY, PASS0 , PASS1 , PROPCM, QUOTCV, * RJLABS, ROUDON, SIZDEF, SPLTNV, SPLTST, UNCOND, VARUEC, * WASCHF, WASCMD, WASKEY, WASLAB, WASSTR, WASUNC, WRBCOM, * WRCBLK, WRMSG1, WRTFMT, XTRAST, ZEND , ZREAD C CHARACTER*1 ICHAR, JCHAR CHARACTER*6 TYPE6L, TYPE6R CHARACTER*10 TYPE5L, TYPE5R CHARACTER*16 TYPE4L, TYPE4R CHARACTER*21 TYPE3L, TYPE3R LOGICAL DOREAD, EXEMPT, INXTRA, ISCONT, JMPTRM, TOOBIG DATA TYPE3L / '.EQ.GE.GT.LE.LT.NE.OR' / DATA TYPE3R / 'EQ.GE.GT.LE.LT.NE.OR.' / DATA TYPE4L / '.AND.EQV.NOT.XOR' / DATA TYPE4R / 'AND.EQV.NOT.XOR.' / DATA TYPE5L / '.NEQV.TRUE' / DATA TYPE5R / 'NEQV.TRUE.' / DATA TYPE6L / '.FALSE' / DATA TYPE6R / 'FALSE.' / C C TERMINATE PASS 1 C PASS1 = .FALSE. IF (CPYFLG) GO TO 260 DOREAD = .TRUE. ENDFILE 8 REWIND 8 IF (LSTRES) CALL PAGECK(0) OUTLIN = 0 C C READ A CARD FOR PASS 2 C 10 IF (DOREAD) THEN READ (8,END=260) SCRDPT,LABEL,KYTYPE,WASLAB,WASSTR READ (8) SUPRCD(1:SCRDPT) SCRDPT = SCRDPT + 1 IF (SCRDPT .EQ. 15 .AND. SUPRCD(7:14) .EQ. 'CONTINUE') THEN ISCONT = .TRUE. ELSE ISCONT = .FALSE. ENDIF OLDLAB = LABEL ELSE SCRDPT = 15 SUPRCD(7:14) = 'CONTINUE' DOREAD = .TRUE. ISCONT = .TRUE. LABEL = OLDLAB ENDIF SUPRCD(SCRDPT:SCRDPT) = EOS INXTRA = .TRUE. EXEMPT = .FALSE. TOOBIG = .FALSE. C C IF THIS STATEMENT CONTAINS A LABEL DEFINITION, SET THE NEW LABEL C IF NOT, DELETE STATEMENT IF CONTINUE/FORMAT. C BLANK LABEL IF NOT. C IF (LABEL .EQ. 0 .OR. LBTFUL .OR. LABINC .EQ. 0) THEN SQZCRD(1:6) = SUPRCD(1:6) ELSE DO 20 I = 1 , LBLCNT IF (LBLTBL(I,2) .EQ. LABEL) GO TO 30 20 CONTINUE 30 LABEL = LBLTBL(I,1) SQZCRD(1:6) = ' ' IF (LABEL .NE. 0) THEN CALL CVTLAB (LABEL,LENGTH,RJLABS) SQZCRD(1:6) = TMPSTR(1:6) ELSE C C UNUSED LABEL. DELETE STATEMENT IF =FORMAT= C OR =CONTINUE= (B. MCKINNON) C IF (KYTYPE .EQ. 5 .OR. ISCONT) GO TO 10 ENDIF ENDIF C C CHECK FOR DO-LOOP TERMINATION C DOS = 0 IF (LABEL .NE. 0) THEN JMPTRM = .FALSE. DO 40 I = 1 , DOCNT IF (DOS .NE. 0) DOTBL(I-DOS) = DOTBL(I) IF (LABEL .EQ. IABS(DOTBL(I))) THEN DOS = DOS + 1 IF (DOTBL(I) .LT. 0) JMPTRM = .TRUE. ENDIF 40 CONTINUE IF (ISCONT .AND. DOS .NE. 0) THEN INDENT = INDENT - DOS DOCNT = DOCNT - DOS DOS = 0 ELSEIF (ADDCON .AND. .NOT.JMPTRM .AND. DOS .NE. 0) THEN DOREAD = .FALSE. SQZCRD(1:6) = ' ' DOS = 0 ENDIF ENDIF C C IF TO DECREASE INDENTATION C IF (KYTYPE .EQ. 2 .OR. KYTYPE .EQ. 3) THEN INDENT = INDENT - 1 ELSEIF (KYTYPE .EQ. 6) THEN INDENT = 0 ENDIF IF (INDENT.LT.0) THEN INDENT = 0 IF (LSTRES) THEN CALL PAGECK (3) WRITE (2,45) 45 FORMAT (/10X,'** NEXT CARD IMPLIES BAD BLOCK STRUCTURE **'/) ENDIF ENDIF C C ASSUME WE CAN INDENT C IF (INDSTA) THEN UINDEN = INDENT IF (UINDEN*INDINC .GT. INDMAX) UINDEN = INDMAX/INDINC ELSE UINDEN = 0 ENDIF C C SET UP FOR BUILDING THE REST OF =SQZCRD= C 50 SUPOUT = 7 SQZIN = 7 UIND3 = INDINC * UINDEN BEGNUM = 0 C C IF THIS IS A COMMAND OR A COMMENT WITH NO COMMENT IDENTATION, C COPY IT. OTHERWISE, IF A COMMENT, TRY TO INDENT IT IF NOT EXEMPT. C IF (KYTYPE .EQ. 0 .OR. KYTYPE .EQ. 9) THEN SQZIN = 1 I = 1 J = SCRDPT-1 60 IF ((KYTYPE .EQ. 9) .OR. * (EXMCOM .OR. .NOT.INDCOM .OR. SCRDPT.EQ.2 .OR. * SUPRCD(1:1).EQ.EXMCHR)) THEN CALL PUTSTR (SUPRCD(I:I+J-1),J) SQZIN = MIN (SQZIN,LINELN+1) ELSE DO 70 I = 2 , SCRDPT-1 IF (SUPRCD(I:I) .NE. ' ') GO TO 80 70 CONTINUE I = 1 J = 1 KYTYPE = 9 GO TO 60 80 SHFT = MIN (MAXLLN+1-SCRDPT , 7+UIND3-I) IF (SHFT .EQ. 0) THEN I = 1 ELSE SQZCRD(1:LINELN) = 'C' SQZIN = I + SHFT J = SCRDPT - I ENDIF KYTYPE = 9 GO TO 60 C ENDIF C C ELSE, SEE IF CARD IS EXEMPT FROM PROCESSING C ELSEIF (((KYTYPE .EQ. 5) .AND. EXMFMT) .OR. * ((KYTYPE .EQ. 8) .AND. EXMNEX) ) THEN SQZCRD(7:SCRDPT-1) = SUPRCD(7:SCRDPT-1) SQZIN = SCRDPT EXEMPT = .TRUE. C C ELSE, SEE IF CARD CAN BE COPIED WITH NO CHANGES C ELSEIF (.NOT.WASLAB .AND. .NOT.WASSTR .AND. * (SPLTNV .OR. SCRDPT+UIND3.LE.LINELN+1)) THEN 90 IF (UIND3 .NE. 0) THEN SQZCRD(SQZIN:SQZIN-1+UIND3) = ' ' SQZIN = SQZIN + UIND3 ENDIF I = MIN (LINELN-7-UIND3,SCRDPT-1-SUPOUT) SQZCRD(SQZIN:SQZIN+I) = SUPRCD(SUPOUT:SUPOUT+I) SQZIN = SQZIN + I+1 SUPOUT = SUPOUT + I+1 IF (INXTRA .AND. UIND3 .EQ. INDINC*UINDEN) * UIND3 = UIND3 + INDINC IF (SUPOUT .LE. SCRDPT-1) GO TO 90 C C ELSE, HAS LABEL/STRING/SPLIT - COPY COLUMN BY COLUMN C ELSE 100 IF (UIND3 .NE. 0) THEN SQZCRD(SQZIN:SQZIN-1+UIND3) = ' ' SQZIN = SQZIN + UIND3 ENDIF IF (INXTRA .AND. UIND3 .EQ. INDINC*UINDEN) * UIND3 = UIND3 + INDINC 110 CALL GETC IF (CHAR1 .EQ. STRSIG) THEN C C STRING FLAG - COPY THE STRING THAT FOLLOWS C HOLDOU = SUPOUT - 1 CALL GETC HOLDIN = SQZIN HOLDCD = (SQZIN-8)/(LINELN-6) IF (INDEX(NUMLET,CHAR1) .GT. 0) THEN CALL GENLEX (.TRUE.,.FALSE.) ELSE CALL QFIELD ENDIF SUPOUT = SUPOUT - 1 IF (UIND3.NE.0 .AND. (SQZIN-8)/(LINELN-6) .NE. HOLDCD) THEN C C STRING SPLIT OVER TWO CARDS. TRY TO AVOID THAT. C IF (SPLTST .OR. (UIND3+SQZIN-HOLDIN .GT. LINELN-6)) THEN INXTRA = .FALSE. UINDEN = 0 GO TO 50 C ELSE C C BLANK FIRST PART OF STRING + START STRING ON NEXT CARD C I = (LINELN-6) - MOD(HOLDIN-6-1,(LINELN-6)) DO 120 J = 1 , I SQZCRD(HOLDIN-1+J:HOLDIN-1+J) = ' ' 120 CONTINUE SQZIN = HOLDIN + I SUPOUT = HOLDOU GO TO 100 C ENDIF ENDIF C ELSEIF (CHAR1 .EQ. CHAR(92)) THEN C C LABEL FLAG - MAP LABEL IF NOT TABLE OVERFLOW C LENGTH = 0 130 CALL GETC J = INDEX (NUMLET,CHAR1) IF (J .GT. 0 .AND. J .LT. 11) THEN LENGTH = LENGTH + 1 NUMBER(LENGTH:LENGTH) = CHAR1 GO TO 130 C ELSE SUPOUT = SUPOUT - 1 ENDIF LABEL = CVTNUM (NUMBER,LENGTH) IF (.NOT.LBTFUL .AND. LABINC.NE.0) THEN DO 140 I = 1 , LBLCNT IF (LBLTBL(I,2) .EQ. LABEL) GO TO 150 140 CONTINUE 150 LABEL = LBLTBL(I,1) ENDIF CALL CVTLAB (LABEL,LENGTH,.FALSE.) IF ((SQZIN-7)/(LINELN-6) .EQ. (SQZIN-7+LENGTH)/(LINELN-6)) * THEN CALL PUTSTR (TMPSTR,LENGTH) ELSE DO 160 I = 1 , LENGTH SUPRCD(SUPOUT-LENGTH-1+I:SUPOUT-LENGTH-1+I) = TMPSTR(I * :I) 160 CONTINUE SUPOUT = SUPOUT - LENGTH ENDIF C C IF A DO STATEMENT, ADD LABEL TO ACTIVE TABLE C IF NOT, CHECK FOR JUMP TO DO LOOP TERMINATION STATEMENT C IF (KYTYPE .EQ. 7) THEN DOCNT = DOCNT + 1 DOTBL(DOCNT) = LABEL ELSE DO 170 I = 1 , DOCNT IF (DOTBL(I) .EQ. LABEL) DOTBL(I) = -LABEL 170 CONTINUE ENDIF C ELSE C C NORMAL CHARACTER C CALL PUTC ENDIF C C CHECK IF WE NEED TO INSERT BLANKS (AT START OF NEW CARD) C IF (SUPOUT .LE. SCRDPT-1) THEN IF (MOD(SQZIN-6,LINELN-6) .NE. 1) GO TO 110 IF (TOOBIG .OR. SPLTNV) GO TO 100 ICHAR = SQZCRD(SQZIN-1:SQZIN-1) I = INDEX(NUMLET,ICHAR) JCHAR = SUPRCD(SUPOUT:SUPOUT) J = INDEX(NUMLET,JCHAR) IF (I.EQ.0 .OR. J.EQ.0) THEN IF (I+J .EQ. 0) THEN IF (ICHAR.NE.'(' .OR. (JCHAR.NE.'(' .AND. * JCHAR.NE.')')) GO TO 100 ELSEIF (I .NE. 0) THEN IF (JCHAR .NE. '.') GO TO 100 IF (I .GT. 10 .AND. * INDEX(TYPE3L,SQZCRD(SQZIN-3:SQZIN-1)) .EQ. 0 .AND. * INDEX(TYPE4L,SQZCRD(SQZIN-4:SQZIN-1)) .EQ. 0 .AND. * INDEX(TYPE5L,SQZCRD(SQZIN-5:SQZIN-1)) .EQ. 0 .AND. * INDEX(TYPE6L,SQZCRD(SQZIN-6:SQZIN-1)) .EQ. 0) * GO TO 100 ELSE IF (ICHAR .NE. '.') GO TO 100 IF (J.GT.10 .AND. * INDEX(TYPE3R,SUPRCD(SUPOUT:SUPOUT+2)) .EQ. 0 .AND. * INDEX(TYPE4R,SUPRCD(SUPOUT:SUPOUT+3)) .EQ. 0 .AND. * INDEX(TYPE5R,SUPRCD(SUPOUT:SUPOUT+4)) .EQ. 0 .AND. * INDEX(TYPE6R,SUPRCD(SUPOUT:SUPOUT+5)) .EQ. 0) * GO TO 100 ENDIF ENDIF C C =UN-SPLIT= TOKEN C I = 0 180 I = I + 1 J = SQZIN - I SUPOUT = SUPOUT - 1 SUPRCD(SUPOUT:SUPOUT) = SQZCRD(J:J) SQZCRD(J:J) = ' ' J = J - 1 IF (INDEX(NUMLET,SQZCRD(J:J)) .NE. 0 .OR. * SQZCRD(J:J) .EQ. ' ' .OR. SQZCRD(J:J) .EQ. '(') GO TO 180 IF (SQZCRD(J:J) .EQ. '.') THEN IF (INDEX(NUMLET(1:10),SQZCRD(J-1:J-1)) .NE. 0 .OR. * INDEX(TYPE3R,SUPRCD(SUPOUT:SUPOUT+2)) .NE. 0 .OR. * INDEX(TYPE4R,SUPRCD(SUPOUT:SUPOUT+3)) .NE. 0 .OR. * INDEX(TYPE5R,SUPRCD(SUPOUT:SUPOUT+4)) .NE. 0 .OR. * INDEX(TYPE6R,SUPRCD(SUPOUT:SUPOUT+5)) .NE. 0) * GO TO 180 ENDIF IF (SUPOUT .LE. BEGNUM) THEN IF (.NOT.INXTRA) TOOBIG = .TRUE. INXTRA = .FALSE. UINDEN = 0 GO TO 50 C ELSE BEGNUM = SUPOUT ENDIF GO TO 100 C ENDIF C ENDIF C C TRY TO WRITE THE CARD(S) TO OUTPUT AND CLEANED FILE. C SQZIN = SQZIN - 1 IF (EXEMPT) THEN HOLDLN = LINELN LINELN = OLDLEN ENDIF IF (SQZIN.GT.(LINELN-6)*20+6 .AND. UINDEN.NE.0) THEN C C MORE THAN 19 CONTINUATION CARDS - SO SQUEEZE IT C UINDEN = 0 INXTRA = .FALSE. TOOBIG = .TRUE. IF (EXEMPT) LINELN = HOLDLN GO TO 50 C ENDIF IF (SQZIN .LE. 6 .OR. KYTYPE .EQ. 0 .OR. KYTYPE .EQ. 9) THEN CARDS = 1 ELSE CARDS = (SQZIN-7)/(LINELN-6) + 1 ENDIF TOUCNT = TOUCNT + CARDS IF (LSTRES) CALL PAGECK (CARDS) I = MIN (LINELN,SQZIN) IF (KYTYPE .EQ. 0 .OR. KYTYPE .EQ. 9) THEN IF (LSTRES) WRITE (2,190) SQZCRD(1:I) 190 FORMAT (7X,A) WRITE (3,200) SQZCRD(1:I) 200 FORMAT (A) ELSE OUTLIN = OUTLIN + 1 IF (LSTRES) WRITE (2,210) OUTLIN,SQZCRD(1:I) 210 FORMAT (1X,I4,'.',1X,A) WRITE (3,200) SQZCRD(1:I) IF (CARDS .GT. 1) THEN DO 240 J = 2 , CARDS K = (J-2)*(LINELN-6) + LINELN+1 K2 = MIN (K+LINELN-6-1,SQZIN) IF (LSTRES) WRITE (2,220) SQZCRD(K:K2) 220 FORMAT (12X,'*',A) WRITE (3,230) SQZCRD(K:K2) 230 FORMAT (5X,'*',A) 240 CONTINUE ENDIF IF (EXEMPT) LINELN = HOLDLN ENDIF C C ISSUE WARNING IF MORE THAN 20 CONTINUATION CHARACTERS C IF (CARDS .GT. 20) THEN IF (LSTRES) THEN CALL PAGECK(3) WRITE (2,250) 250 FORMAT (/10X,'** EXCESSIVE CONTINUATION CARDS (>19) **'/) ENDIF ENDIF C C IF TO INCREASE/DECREASE INDENTATION C IF (KYTYPE .EQ. 1 .OR. KYTYPE .EQ. 3 .OR. KYTYPE .EQ. 7) * INDENT = INDENT + 1 IF (DOS .NE. 0) THEN INDENT = INDENT - DOS DOCNT = DOCNT - DOS ENDIF GO TO 10 C C DONE WITH PASS 2 FOR THIS ROUTINE. CLEAN UP. C 260 REWIND 8 IF (CPYFLG) THEN TINCNT = TINCNT - RINCNT ENDIF CPYFLG = .FALSE. HAVEXS = .FALSE. LBTFUL = .FALSE. OVRLAY = .FALSE. ROUDON = .FALSE. WRMSG1 = .FALSE. LN1MSG = 'CLEAN:' ROUCNT = ROUCNT + 1 LBLCNT = 0 RINCNT = 0 DO 270 I = 1 , LBTLEN DO 270 J = 1 , 3 LBLTBL(I,J) = 0 270 CONTINUE C RETURN C END SUBROUTINE PUTC IMPLICIT INTEGER (A-Z) C C THIS ROUTINE INSERTS A CHARACTER (=CHAR=) INTO THE THE NEXT C LOCATION IN =SQZCRD= (=SQZIN=). C PARAMETER ( COMLEN = 100 ) PARAMETER ( SUPLEN = 1458 ) C COMMON /CHBLK/ CHAR , COMBLK, EOS , EXMCHR, HOLDCH, INLINE, * LN1MSG, LONGKY, NUMBER, NUMLET, QUOTCH, RETPFX, * SPECHR, SQZCRD, SUPRCD, TMPCRD, TMPSTR, UNCONC, * VARBLE CHARACTER*1 CHAR, EOS, EXMCHR, HOLDCH, QUOTCH, RETPFX, UNCONC CHARACTER*17 SPECHR CHARACTER*38 NUMLET CHARACTER*40 LN1MSG, LONGKY, NUMBER, TMPSTR, VARBLE CHARACTER*126 COMBLK(COMLEN), INLINE CHARACTER*(SUPLEN) SQZCRD, SUPRCD, TMPCRD COMMON /CHPTR/ COMLNB(COMLEN), COMPTR, INDENT, EOLINE, KYTYPE, * MATLEN, MATLLN, OCRDPT, SCRDPT, SQZIN, SUPOUT, * TCRDPT C SQZCRD(SQZIN:SQZIN) = CHAR 10 SQZIN = SQZIN + 1 RETURN C C *** ENTRY: PUTB - PUT A BLANK CHARACTER C ENTRY PUTB SQZCRD(SQZIN:SQZIN) = ' ' GO TO 10 C END SUBROUTINE PUTCOM (STRING,STRLEN) IMPLICIT INTEGER (A-Z) C C THIS ROUTINE COLLECTS COMMENT STATEMENTS IN ARRAY =COMBLK=. C IF THE BLOCK OVERFLOWS, THE BLOCK IS WRITTEN TO A SCRATCH C FILE AND RE-USED. C PARAMETER ( COMLEN = 100 ) PARAMETER ( SUPLEN = 1458 ) C COMMON /CHBLK/ CHAR , COMBLK, EOS , EXMCHR, HOLDCH, INLINE, * LN1MSG, LONGKY, NUMBER, NUMLET, QUOTCH, RETPFX, * SPECHR, SQZCRD, SUPRCD, TMPCRD, TMPSTR, UNCONC, * VARBLE CHARACTER*1 CHAR, EOS, EXMCHR, HOLDCH, QUOTCH, RETPFX, UNCONC CHARACTER*17 SPECHR CHARACTER*38 NUMLET CHARACTER*40 LN1MSG, LONGKY, NUMBER, TMPSTR, VARBLE CHARACTER*126 COMBLK(COMLEN), INLINE CHARACTER*(SUPLEN) SQZCRD, SUPRCD, TMPCRD COMMON /CHPTR/ COMLNB(COMLEN), COMPTR, INDENT, EOLINE, KYTYPE, * MATLEN, MATLLN, OCRDPT, SCRDPT, SQZIN, SUPOUT, * TCRDPT COMMON /COUNT/ FMTBAS, FMTINC, INCNT , INDINC, LABASE, LABINC, * LINELN, OLDLEN, PAGELN, RINCNT, ROUCNT, THISLN, * THISPG, TINCNT, TOUCNT COMMON /LOGVR/ ADDCON, BRKCOM, COLFMT, CPYFLG, CVTHFI, DONERD, * DOSTAT, EXMCOM, EXMFMT, EXMNEX, FIRSTC, HAVEXS, * INDCOM, INDSTA, ISFMT , ISSCOM, LASTBC, LBTFUL, * LSTIDS, LSTRES, LSTSRC, MORE , NEEDRD, OVRLAY, * PASS0 , PASS1 , PROPCM, QUOTCV, RJLABS, ROUDON, * SIZDEF, SPLTNV, SPLTST, UNCOND, VARUEC, WASCHF, * WASCMD, WASKEY, WASLAB, WASSTR, WASUNC, WRBCOM, * WRCBLK, WRMSG1, WRTFMT, XTRAST, ZEND , ZREAD LOGICAL ADDCON, BRKCOM, COLFMT, CPYFLG, CVTHFI, DONERD, DOSTAT, * EXMCOM, EXMFMT, EXMNEX, FIRSTC, HAVEXS, INDCOM, INDSTA, * ISFMT , ISSCOM, LASTBC, LBTFUL, LSTIDS, LSTRES, LSTSRC, * MORE , NEEDRD, OVRLAY, PASS0 , PASS1 , PROPCM, QUOTCV, * RJLABS, ROUDON, SIZDEF, SPLTNV, SPLTST, UNCOND, VARUEC, * WASCHF, WASCMD, WASKEY, WASLAB, WASSTR, WASUNC, WRBCOM, * WRCBLK, WRMSG1, WRTFMT, XTRAST, ZEND , ZREAD C CHARACTER*(*) STRING C IF (CPYFLG) THEN C C WRITE COMMENTS DIRECTLY TO CLEANED FILE C WRITE (3,10) STRING(1:STRLEN) 10 FORMAT (A) TOUCNT = TOUCNT + 1 ELSE C C ATTEMP TO HOLD THE COMMENTS IN CORE FOR LATER PROCESSING C COMPTR = COMPTR + 1 C C SEE IF OVERFLOW C IF (COMPTR .GT. COMLEN) THEN C C OVERFLOW - WRITE, THEN RE-USE BLOCK C DO 20 I = 1 , COMLEN WRITE (9) COMLNB(I) WRITE (9) COMBLK(I)(1:COMLNB(I)) 20 CONTINUE WRCBLK = .TRUE. COMPTR = 1 ENDIF C C STORE THE LATEST COMMENT C COMBLK(COMPTR) = STRING(1:STRLEN) COMLNB(COMPTR) = STRLEN C ENDIF RETURN C END SUBROUTINE PUTSTR(STRING,LENGTH) IMPLICIT INTEGER (A-Z) C C THIS ROUTINE COPIES THE CHARACTERS FROM =STRING= TO =SQZCRD=. C =LENGTH= IS THE NUMBER OF CHARACTERS TO COPY. C PARAMETER ( COMLEN = 100 ) PARAMETER ( SUPLEN = 1458 ) C COMMON /CHBLK/ CHAR , COMBLK, EOS , EXMCHR, HOLDCH, INLINE, * LN1MSG, LONGKY, NUMBER, NUMLET, QUOTCH, RETPFX, * SPECHR, SQZCRD, SUPRCD, TMPCRD, TMPSTR, UNCONC, * VARBLE CHARACTER*1 CHAR, EOS, EXMCHR, HOLDCH, QUOTCH, RETPFX, UNCONC CHARACTER*17 SPECHR CHARACTER*38 NUMLET CHARACTER*40 LN1MSG, LONGKY, NUMBER, TMPSTR, VARBLE CHARACTER*126 COMBLK(COMLEN), INLINE CHARACTER*(SUPLEN) SQZCRD, SUPRCD, TMPCRD COMMON /CHPTR/ COMLNB(COMLEN), COMPTR, INDENT, EOLINE, KYTYPE, * MATLEN, MATLLN, OCRDPT, SCRDPT, SQZIN, SUPOUT, * TCRDPT C CHARACTER*(*) STRING C IF (LENGTH .LE. 0) RETURN C SQZCRD(SQZIN:SQZIN+LENGTH-1) = STRING(1:LENGTH) SQZIN = SQZIN + LENGTH RETURN C END SUBROUTINE QFIELD IMPLICIT INTEGER (A-Z) CHARACTER*1 DEFRET, DEFUNC, DEFQUO, STRSIG CHARACTER*2 VEXTCS C PARAMETER ( CMDLEN = 7 ) PARAMETER ( CMDMAX = 34 ) PARAMETER ( DEFLLN = 72 ) PARAMETER ( DEFLPP = 60 ) PARAMETER ( DEFQUO = '''' ) PARAMETER ( DEFRET = '*' ) PARAMETER ( DEFUNC = ' ' ) PARAMETER ( MAXLLN = 125 ) PARAMETER ( MAXVRL = 8 ) PARAMETER ( MINLLN = 40 ) PARAMETER ( MINLPP = 30 ) PARAMETER ( STRSIG = '?' ) PARAMETER ( VEXTCS = '$_' ) C C THIS ROUTINE COPIES A QUOTED FIELD FROM =SUPRCD= TO =SQZCRD=. C =CHAR= CONTAINS THE NEXT NON-BLANK CHARACTER AT EXIT. C PARAMETER ( COMLEN = 100 ) PARAMETER ( SUPLEN = 1458 ) C COMMON /CHBLK/ CHAR , COMBLK, EOS , EXMCHR, HOLDCH, INLINE, * LN1MSG, LONGKY, NUMBER, NUMLET, QUOTCH, RETPFX, * SPECHR, SQZCRD, SUPRCD, TMPCRD, TMPSTR, UNCONC, * VARBLE CHARACTER*1 CHAR, EOS, EXMCHR, HOLDCH, QUOTCH, RETPFX, UNCONC CHARACTER*17 SPECHR CHARACTER*38 NUMLET CHARACTER*40 LN1MSG, LONGKY, NUMBER, TMPSTR, VARBLE CHARACTER*126 COMBLK(COMLEN), INLINE CHARACTER*(SUPLEN) SQZCRD, SUPRCD, TMPCRD COMMON /CHPTR/ COMLNB(COMLEN), COMPTR, INDENT, EOLINE, KYTYPE, * MATLEN, MATLLN, OCRDPT, SCRDPT, SQZIN, SUPOUT, * TCRDPT COMMON /LOGVR/ ADDCON, BRKCOM, COLFMT, CPYFLG, CVTHFI, DONERD, * DOSTAT, EXMCOM, EXMFMT, EXMNEX, FIRSTC, HAVEXS, * INDCOM, INDSTA, ISFMT , ISSCOM, LASTBC, LBTFUL, * LSTIDS, LSTRES, LSTSRC, MORE , NEEDRD, OVRLAY, * PASS0 , PASS1 , PROPCM, QUOTCV, RJLABS, ROUDON, * SIZDEF, SPLTNV, SPLTST, UNCOND, VARUEC, WASCHF, * WASCMD, WASKEY, WASLAB, WASSTR, WASUNC, WRBCOM, * WRCBLK, WRMSG1, WRTFMT, XTRAST, ZEND , ZREAD LOGICAL ADDCON, BRKCOM, COLFMT, CPYFLG, CVTHFI, DONERD, DOSTAT, * EXMCOM, EXMFMT, EXMNEX, FIRSTC, HAVEXS, INDCOM, INDSTA, * ISFMT , ISSCOM, LASTBC, LBTFUL, LSTIDS, LSTRES, LSTSRC, * MORE , NEEDRD, OVRLAY, PASS0 , PASS1 , PROPCM, QUOTCV, * RJLABS, ROUDON, SIZDEF, SPLTNV, SPLTST, UNCOND, VARUEC, * WASCHF, WASCMD, WASKEY, WASLAB, WASSTR, WASUNC, WRBCOM, * WRCBLK, WRMSG1, WRTFMT, XTRAST, ZEND , ZREAD C CHARACTER*2 SPSTCH C C FLAG THAT A STRING WAS ENCOUNTERED. C SET UP SPECIAL-STRING-CHARACTERS STRING. C WASSTR = .TRUE. IF (QUOTCV .AND. PASS1) THEN SPSTCH = CHAR // QUOTCH ELSE SPSTCH = CHAR // CHAR ENDIF C C IF PASS 1: IF IN FORMAT, INSURE STRING PRECEDED BY VALID CHAR C ISSUE THE STRING-START FLAG C IF (PASS1) THEN IF (ISFMT) THEN CHAR = SQZCRD(SQZIN-1:SQZIN-1) IF (CHAR .NE. ',' .AND. CHAR .NE. '/' .AND. * CHAR .NE. ':' .AND. CHAR .NE. '(') CALL PUTSTR (',',1) ENDIF CALL PUTSTR (STRSIG, 1) ENDIF C C SET UP TO ISSUE INITIAL QUOTE MARK C CHAR = SPSTCH(2:2) C C PUT A CHARACTER. GET THE NEXT CHARACTER. CHECK FOR A NEED C TO DO SPECIAL PROCESSING. C 10 CALL PUTC CALL GETC CHRDEX = INDEX (SPSTCH, CHAR) IF (CHRDEX .EQ. 1) THEN C C WAS STRING DELIMITER - CHECK FOR 2 IN A ROW (ONLY 1 => DONE) C CALL GETC CHRDEX = INDEX (SPSTCH, CHAR) IF (CHRDEX .EQ. 1) THEN C C WE HAD TWO - ISSUE EITHER 1 OR 2 OF THE CHARACTER C IF (CHAR .EQ. SPSTCH(2:2)) CALL PUTC ELSE C C WE HAD ONLY ONE - ISSUE THE FINAL QUOTE MARK. INSURE A C VALID CHARACTER APPEARS AFTER THE STRING IF WE ARE IN A C FORMAT. EXIT THE ROUTINE. C CALL PUTSTR (SPSTCH(2:2), 1) IF (CHAR .EQ. ' ') CALL GETNBC IF (PASS1 .AND. ISFMT .AND. CHAR .NE. '/' .AND. * CHAR .NE. ':' .AND. CHAR .NE. ',' .AND. * CHAR .NE. ')') CALL PUTSTR (',',1) RETURN C ENDIF ELSEIF (CHRDEX .EQ. 2) THEN C C WAS QUOTCH, BUT NOT STRING DELIMITER, SO ISSUE FIRST OF C TWO QUOTE MARKS. C CALL PUTC ENDIF GO TO 10 C END SUBROUTINE RDCMDF IMPLICIT INTEGER (A-Z) CHARACTER*1 DEFRET, DEFUNC, DEFQUO, STRSIG CHARACTER*2 VEXTCS C PARAMETER ( CMDLEN = 7 ) PARAMETER ( CMDMAX = 34 ) PARAMETER ( DEFLLN = 72 ) PARAMETER ( DEFLPP = 60 ) PARAMETER ( DEFQUO = '''' ) PARAMETER ( DEFRET = '*' ) PARAMETER ( DEFUNC = ' ' ) PARAMETER ( MAXLLN = 125 ) PARAMETER ( MAXVRL = 8 ) PARAMETER ( MINLLN = 40 ) PARAMETER ( MINLPP = 30 ) PARAMETER ( STRSIG = '?' ) PARAMETER ( VEXTCS = '$_' ) C C READ COMMAND FILE. C PARAMETER ( COMLEN = 100 ) PARAMETER ( SUPLEN = 1458 ) C COMMON /CHBLK/ CHAR , COMBLK, EOS , EXMCHR, HOLDCH, INLINE, * LN1MSG, LONGKY, NUMBER, NUMLET, QUOTCH, RETPFX, * SPECHR, SQZCRD, SUPRCD, TMPCRD, TMPSTR, UNCONC, * VARBLE CHARACTER*1 CHAR, EOS, EXMCHR, HOLDCH, QUOTCH, RETPFX, UNCONC CHARACTER*17 SPECHR CHARACTER*38 NUMLET CHARACTER*40 LN1MSG, LONGKY, NUMBER, TMPSTR, VARBLE CHARACTER*126 COMBLK(COMLEN), INLINE CHARACTER*(SUPLEN) SQZCRD, SUPRCD, TMPCRD COMMON /CHPTR/ COMLNB(COMLEN), COMPTR, INDENT, EOLINE, KYTYPE, * MATLEN, MATLLN, OCRDPT, SCRDPT, SQZIN, SUPOUT, * TCRDPT COMMON /COUNT/ FMTBAS, FMTINC, INCNT , INDINC, LABASE, LABINC, * LINELN, OLDLEN, PAGELN, RINCNT, ROUCNT, THISLN, * THISPG, TINCNT, TOUCNT COMMON /LOGVR/ ADDCON, BRKCOM, COLFMT, CPYFLG, CVTHFI, DONERD, * DOSTAT, EXMCOM, EXMFMT, EXMNEX, FIRSTC, HAVEXS, * INDCOM, INDSTA, ISFMT , ISSCOM, LASTBC, LBTFUL, * LSTIDS, LSTRES, LSTSRC, MORE , NEEDRD, OVRLAY, * PASS0 , PASS1 , PROPCM, QUOTCV, RJLABS, ROUDON, * SIZDEF, SPLTNV, SPLTST, UNCOND, VARUEC, WASCHF, * WASCMD, WASKEY, WASLAB, WASSTR, WASUNC, WRBCOM, * WRCBLK, WRMSG1, WRTFMT, XTRAST, ZEND , ZREAD LOGICAL ADDCON, BRKCOM, COLFMT, CPYFLG, CVTHFI, DONERD, DOSTAT, * EXMCOM, EXMFMT, EXMNEX, FIRSTC, HAVEXS, INDCOM, INDSTA, * ISFMT , ISSCOM, LASTBC, LBTFUL, LSTIDS, LSTRES, LSTSRC, * MORE , NEEDRD, OVRLAY, PASS0 , PASS1 , PROPCM, QUOTCV, * RJLABS, ROUDON, SIZDEF, SPLTNV, SPLTST, UNCOND, VARUEC, * WASCHF, WASCMD, WASKEY, WASLAB, WASSTR, WASUNC, WRBCOM, * WRCBLK, WRMSG1, WRTFMT, XTRAST, ZEND , ZREAD C 10 READ (4,20,END=50) INLINE 20 FORMAT (A) IF (INLINE(1:2) .EQ. 'C+' .OR. INLINE(1:2) .EQ. 'C-') THEN EOLINE = 72 LASTBC = .TRUE. CALL COMMEN IF (.NOT.WASCMD) THEN CALL PAGECK(3) WRITE (2,30) 30 FORMAT (/10X,'** ABOVE COMMAND POSSIBLY MISSPELLED **'/) ENDIF ELSEIF (LSTSRC) THEN CALL PAGECK (1) WRITE (2,40) INLINE 40 FORMAT (7X,A) ENDIF GO TO 10 C C FINISHED WITH PASS 0 C 50 CALL DMPSTA FIRSTC = .TRUE. LASTBC = .FALSE. LN1MSG = 'CLEAN:' PASS0 = .FALSE. PASS1 = .FALSE. CLOSE (4) RETURN C END SUBROUTINE RFIELD (LENGTH) IMPLICIT INTEGER (A-Z) CHARACTER*1 DEFRET, DEFUNC, DEFQUO, STRSIG CHARACTER*2 VEXTCS C PARAMETER ( CMDLEN = 7 ) PARAMETER ( CMDMAX = 34 ) PARAMETER ( DEFLLN = 72 ) PARAMETER ( DEFLPP = 60 ) PARAMETER ( DEFQUO = '''' ) PARAMETER ( DEFRET = '*' ) PARAMETER ( DEFUNC = ' ' ) PARAMETER ( MAXLLN = 125 ) PARAMETER ( MAXVRL = 8 ) PARAMETER ( MINLLN = 40 ) PARAMETER ( MINLPP = 30 ) PARAMETER ( STRSIG = '?' ) PARAMETER ( VEXTCS = '$_' ) C C THIS ROUTINE COPIES AN R- OR L-FIELD OF =NUMBER= CHARACTERS C DIRECTLY FROM =SUPRCD= TO =SQZCRD=. =LENGTH= IS THE C NUMBER OF CHARACTERS IN STRING =NUMBER=. AT EXIT, =CHAR= C CONTAINS THE NEXT NON-BLANK CHARACTER. C PARAMETER ( COMLEN = 100 ) PARAMETER ( SUPLEN = 1458 ) C COMMON /CHBLK/ CHAR , COMBLK, EOS , EXMCHR, HOLDCH, INLINE, * LN1MSG, LONGKY, NUMBER, NUMLET, QUOTCH, RETPFX, * SPECHR, SQZCRD, SUPRCD, TMPCRD, TMPSTR, UNCONC, * VARBLE CHARACTER*1 CHAR, EOS, EXMCHR, HOLDCH, QUOTCH, RETPFX, UNCONC CHARACTER*17 SPECHR CHARACTER*38 NUMLET CHARACTER*40 LN1MSG, LONGKY, NUMBER, TMPSTR, VARBLE CHARACTER*126 COMBLK(COMLEN), INLINE CHARACTER*(SUPLEN) SQZCRD, SUPRCD, TMPCRD COMMON /CHPTR/ COMLNB(COMLEN), COMPTR, INDENT, EOLINE, KYTYPE, * MATLEN, MATLLN, OCRDPT, SCRDPT, SQZIN, SUPOUT, * TCRDPT COMMON /LOGVR/ ADDCON, BRKCOM, COLFMT, CPYFLG, CVTHFI, DONERD, * DOSTAT, EXMCOM, EXMFMT, EXMNEX, FIRSTC, HAVEXS, * INDCOM, INDSTA, ISFMT , ISSCOM, LASTBC, LBTFUL, * LSTIDS, LSTRES, LSTSRC, MORE , NEEDRD, OVRLAY, * PASS0 , PASS1 , PROPCM, QUOTCV, RJLABS, ROUDON, * SIZDEF, SPLTNV, SPLTST, UNCOND, VARUEC, WASCHF, * WASCMD, WASKEY, WASLAB, WASSTR, WASUNC, WRBCOM, * WRCBLK, WRMSG1, WRTFMT, XTRAST, ZEND , ZREAD LOGICAL ADDCON, BRKCOM, COLFMT, CPYFLG, CVTHFI, DONERD, DOSTAT, * EXMCOM, EXMFMT, EXMNEX, FIRSTC, HAVEXS, INDCOM, INDSTA, * ISFMT , ISSCOM, LASTBC, LBTFUL, LSTIDS, LSTRES, LSTSRC, * MORE , NEEDRD, OVRLAY, PASS0 , PASS1 , PROPCM, QUOTCV, * RJLABS, ROUDON, SIZDEF, SPLTNV, SPLTST, UNCOND, VARUEC, * WASCHF, WASCMD, WASKEY, WASLAB, WASSTR, WASUNC, WRBCOM, * WRCBLK, WRMSG1, WRTFMT, XTRAST, ZEND , ZREAD C C FLAG THAT A STRING WAS ENCOUNTERED C WASSTR = .TRUE. C C IF PASS 1: IF IN FORMAT, INSURE STRING PRECEDED BY VALID CHAR C ISSUE THE STRING-START FLAG C IF (PASS1) THEN IF (ISFMT) THEN HOLDCH = SQZCRD(SQZIN-1:SQZIN-1) IF (HOLDCH .NE. ',' .AND. HOLDCH .NE. '/' .AND. * HOLDCH .NE. ':' .AND. HOLDCH .NE. '(') CALL PUTSTR (',',1) ENDIF CALL PUTSTR (STRSIG,1) ENDIF C C CONVERT NUMBER. (IT MUST BE AN INTEGER.) MOVE THE NUMBER TO C =SQZCRD=. C RLEN = CVTNUM (NUMBER, LENGTH) CALL PUTSTR (NUMBER,LENGTH) C C MOVE THE =L= OR =R= TO =SQZCRD=. C CALL PUTC C C NOW COPY THE FIELD. C IF (SUPOUT+RLEN-1 .LT. SCRDPT) THEN SQZCRD(SQZIN:SQZIN+RLEN-1) = SUPRCD(SUPOUT:SUPOUT+RLEN-1) SQZIN = SQZIN + RLEN ELSE I = SCRDPT - SUPOUT - 1 IF (I.GE.0) THEN SQZCRD(SQZIN:SQZIN+I) = SUPRCD(SUPOUT:SUPOUT+I) SQZIN = SQZIN + I+1 ENDIF DO 10 J = I+2 , RLEN CALL PUTB 10 CONTINUE ENDIF SUPOUT = MIN (SUPOUT+RLEN,SCRDPT) C C GET THE NEXT NON-BLANK CHARACTER. C IF PASS 1 AND IN A FORMAT, INSURE STRING FOLLOWED BY VALID CHAR C CALL GETNBC IF (PASS1 .AND. ISFMT .AND. CHAR .NE. '/' .AND. CHAR .NE. ':' * .AND. CHAR .NE. ',' .AND. CHAR .NE. ')') CALL PUTSTR (',',1) RETURN C END SUBROUTINE XASSIG (*) IMPLICIT INTEGER (A-Z) C C SYNTAX: C <,> C <,> <.DYN.> C