C ALGORITHM 622 COLLECTED ALGORITHMS FROM ACM. C ALGORITHM APPEARED IN ACM-TRANS. MATH. SOFTWARE, VOL.10, NO. 4, C DEC., 1984, P. 410. C C REMARK ON 622, COLLECTED ALGORITHMS FROM ACM. C THIS WORK PUBLISHED IN TRANSACTIONS ON MATHEMATICAL SOFTWARE, C VOL. 24,NO. 3, September, 1998, P. 336--340 #! /bin/sh # This is a shell archive, meaning: # 1. Remove everything above the #! /bin/sh line. # 2. Save the resulting text in a file. # 3. Execute the file with /bin/sh (not csh) to create the files: # Doc/ # Doc/paper.ascii # Fortran77/ # Fortran77/Drivers/ # Fortran77/Drivers/Sp/ # Fortran77/Drivers/Sp/bugreport # Fortran77/Drivers/Sp/bugreport.out # Fortran77/Drivers/Sp/ellpack # Fortran77/Drivers/Sp/ellpack.out # Fortran77/Drivers/Sp/exhaustive # Fortran77/Drivers/Sp/exhaustive.out # Fortran77/Drivers/Sp/linpack # Fortran77/Drivers/Sp/linpack.out # Fortran77/Drivers/Sp/macrop # Fortran77/Drivers/Sp/macrop.out # Fortran77/Drivers/Sp/simple # Fortran77/Drivers/Sp/simple.out # Fortran77/Src/ # Fortran77/Src/Sp/ # Fortran77/Src/Sp/src.f # This archive created: Tue Mar 23 08:55:28 1999 export PATH; PATH=/bin:$PATH if test ! -d 'Doc' then mkdir 'Doc' fi cd 'Doc' if test -f 'paper.ascii' then echo shar: will not over-write existing file "'paper.ascii'" else cat << SHAR_EOF > 'paper.ascii' FILE 2. TEXT OF THE PRINTED PAPER. A SIMPLE MACRO PROCESSOR - ------ ----- --------- JOHN R. RICE CALVIN RIBBENS COMPUTER SCIENCE PURDUE UNIVERSITY WILLIAM A. WARD EXXON RESEARCH ABSTRACT -------- THE DESIGN OBJECTIVE FOR THIS MACRO PROCESSOR IS TO BE AS POWERFUL AS POSSIBLE AND YET REMAIN SIMPLE TO USE AND IMPLEMENT. IT WAS DEVELOPED PRIMARILY TO MANIPULATE COMPUTER PROGRAMS WHERE THE PROCESSOR TAKES A SYMBOL TABLE PLUS A PROGRAM TEMPLATE CONTAINING MACROS AND PRODUCES A SPECIFIC PROGRAM. THIS APPROACH IS APPLIED TO THE MACRO PROCESSOR ITSELF; THE ALGORITHM CONSISTS OF A PORTABLE FORTRAN 66 VERSION OF THE PROCESSOR PLUS A PROGRAM TEMPLATE OF THE PROCESSOR. THE MACRO PROCESSOR TEMPLATE MAY BE RUN THROUGH THE PORTABLE MACRO PROCESSOR TO PRODUCE A VERSION TAILORED TO THE LOCAL COMPUTING ENVIRONMENT. IN PARTICULAR, IT IS EASY TO PRODUCE A FORTRAN 77 VERSION OF THE MACRO PROCESSOR. 1. THE MACRO PROCESSOR --- ----- --------- A MACRO PROCESSOR IS A TOOL TO SUBSTITUTE VALUES FROM A SYMBOL TABLE INTO A TEXT. THUS, IF DATE HAS THE VALUE 'JULY 10, 1983' AND PLACE HAS THE VALUE 'HONG KONG' THEN THE TEXT FRAGMENT DATELINE: $DATE, $PLACE. THIS OBSERVER... WOULD BE TRANSFORMED INTO DATELINE: JULY 10, 1983, HONG KONG. THIS OBSERVER... SUBSTITUTION IS SIMPLE TO UNDERSTAND AND IMPLE- MENT; COMPLEXITY IN A MACRO PROCESSOR ARISES FROM FACILITIES TO CONTROL THE SUBSTITUTION. SEE [COLE, 1976] FOR A SURVEY OF MACRO PROCESSORS; SOME ARE ALMOST COMPLETE PROGRAMMING LANGUAGES. THE MACRO PROCESSOR PRESENTED HERE IS DESIGNED TO BE AS POWERFUL AS POSSIBLE WHILE REMAINING SIMPLE TO USE AND IMPLEMENT. IT IS EXPRESSLY DESIGNED TO MANIPULATE FOR- TRAN CODE ALTHOUGH IT IS SUITABLE FOR GENERAL TEXT PROCESS- ING. THE TWO INGREDIENTS OF MACRO PROCESSING ARE THE SYMBOL TABLE AND THE INPUT TEXT. THIS PROCESSOR HAS A VERY SMALL INITIAL SYMBOL TABLE (MOSTLY CONSISTING OF PROCESSOR OPTION SWITCHES) SO THE INPUT TEXT CONTAINS THE INFORMATION TO BUILD THE SYMBOL TABLE. THE FACILITIES ARE OF FOUR KINDS: (1) SUBSTITUTION OF TEXT, (2) MANIPULATION OF THE SYMBOL TABLE, (3) CONTROL OF THE SUBSTITUTION, AND (4) OTHERS (E.G. COMMENTS, PROCESSOR OPTIONS). THE PROCESSOR IS KEYED TO TWO SPECIAL CHARACTERS: $, THE SUBSTITUTION PREFIX AND *, THE DIRECTIVE PREFIX. THE INPUT HAS LINES OF TEXT WITH PROCES- SOR COMMANDS EMBEDDED IN THEM. EACH LINE IS FIRST SCANNED FOR SUBSTITUTION AND THESE ARE MADE. THE LINE IS THEN SCANNED FOR DIRECTIVES (THE * MUST BE THE FIRST NON-BLANK CHARACTER) AND THESE ARE EXECUTED. IF A SUBSTITUTION INVOLVES MULTIPLE LINES THEN EACH LINE IS PROCESSED AS THOUGH IT WERE INPUT. THIS ALLOWS FOR INDEFINITE NESTING OF SUBSTITUTIONS WHICH MAY INCLUDE CONTROL DIRECTIVES. THE ALGORITHM CONTAINS A COMPLETE USER'S GUIDE FOR THE MACRO PROCESSOR SO WE LIMIT FURTHER DESCRIPTION HERE TO COM- PACT TABULAR SUMMARY OF THE FACILITIES, TABLE 1 AND THE PRO- CESSOR OPTIONS, TABLE 2. THE PRINCIPAL DRAWBACKS TO A PORTABLE MACRO PROCESSOR IN FORTRAN ARE (1) CHARACTERS MUST BE STORED ONE PER WORD AND (2) THE FORTRAN I/O PACKAGES ARE USUALLY VERY INEFFI- CIENT. THE INPUT/OUTPUT OF THE MACRO PROCESSOR IS ISOLATED IN THE SHORT ROUTINES IOERRM, IOLIST, IOPAGE, IORDLN, AND IOWRLN. THESE MAY BE REPLACED BY MORE EFFICIENT, MACHINE DEPENDENT ROUTINES WITHOUT MUCH DIFFICULTY. STORING ONE CHARACTER PER WORD AND USING FORTRAN 66 MAKES THE MACRO PROCESSOR INEFFICIENT IN SPACE. THESE INEF- FICIENCIES ARE NOT VERY SIGNIFICANT FOR SHORT TEXTS OR OCCA- SIONAL USE BUT BECOME IMPORTANT WITH HEAVY USE. FOR THIS REASON A PROGRAM TEMPLATE OF THE MACRO PROCESSOR IS INCLUDED SO THE PORTABLE FORTRAN 66 VERSION CAN PRODUCE A VERSION WHICH USES THE CHARACTER DATA TYPE FACILITIES OF FORTRAN 77. OTHER TAILORING, SUCH AS RESETTING STANDARD UNIT NUMBERS, CAN BE MADE AT THE SAME TIME. THE DETAILS OF THIS PROCEDURE ARE GIVEN IN THE USER'S MANUAL. TABLE 1 BELOW SUMMARIZES THE FACILITIES OF THE SIMPLE MACRO PROCESSOR. TABLE 2 LISTS ITS OPTIONS. THE NATURE AND USE OF THE PROCESSOR IS ILLUSTRATED BY THE SIMPLE EXAMPLE APPLICATION IN THE NEXT SECTION. TABLE 1. SUMMARY OF MACRO PROCESSOR FACILITIES ----- - ------- -- ----- --------- ---------- 1. TEXT SUBSTITUTION FACILITY DESCRIPTION $(NAME), $NAME SUBSTITUTES VALUE OF NAME INTO TEXT $(TYPE) A => REAL A OR INTEGER A $DEF(NAME) RETURNS .TRUE. OR .FALSE. DEPENDING ON WHETHER NAME IS DEFINED OR NOT. USED FOR CONTROL IN *IF FACILITY. $LIST(NAME) SUBSTITUTES NEXT ITEM FROM LIST NAME *INCLUDE(NAME) SUBSTITUTES LINES OF TEXT OF NAME. SIMILAR TO $(NAME) ON A LINE BY ITSELF, BUT BEHAVES DIFFERENTLY WHEN SUBSTITUTION FLAG IS OFF LABEL THIS IS A SPECIAL VARIABLE WHICH IS INCREMENTED BY 1 EACH TIME IT IS ACCESSED. *SET(MAINLOOP = LABEL) *SET(EXIT = LABEL) DO $MAINLOOP I = 1, $ITEMS ... GO TO $EXIT ... $MAINLOOP CONTINUE PRODUCES DO 9004 I = 1,200 ... GO TO 9005 9004 CONTINUE 2. SYMBOL TABLE CONSTRUCTION AND MANIPULATION *SET(NAME1 = NAME2) ASSIGNS VALUES TO NAME1 IN THE SYM- *SET(NAME1 = 'LITERAL') BOL TABLE. EXAMPLE TO SET SEVERAL *SET(NAME1 = INTEGER) VALUES. *SET *SET ... MONTH = 'APRIL' *ENDSET DAY = 20 YEAR = CURRENTYEAR *SET(NAME1) *ENDSET ... EXAMPLE TO SET VALUE TO SEVERAL LINES *ENDSET *SET(READTIME) IF(TIMER) CALL SECOND(TIME1) KTIME = KTIME+1 TIME(KTIME) = TIME2-TIME1 TIME1 = TIME2 *ENDSET *DELETE(NAME) REMOVE VARIABLE NAME FROM SYMBOL TABLE *APPEND(NAME1, NAME2) APPEND OR CONCATENATE TEXT TO NAME1. *APPEND(NAME1, 'LITERAL') APPEND IS MUCH MORE EFFICIENT THAN *APPEND(NAME1) *SET WHEN USED FOR THE SAME TASK. ... MULTIPLE LINES MAY BE APPENDED AS *ENDAPP FOLLOWS: *APPEND(PROCESSACCOUNT) PRINT $LABELB, ACCOUNT, BALANCE $LABELB FORMAT('ACCOUNT=',I8, A /'BALANCE=',F12.2, B /'ON $DAY $MONTH $YEAR') *ENDAPP ADDS FOUR LINES OF CODE TO PROCESS AN ACCOUNT 3. CONTROL *IF(LOGICAL)LINE THE TEXT IN LINE, LINETRUE AND *IF(LOGICAL) LINEFALSE IS PROCESSED IF THE VALUE LINETRUE OF LOGICAL IS APPROPRIATE. LOGICAL *ELSE CAN BE A LOGICAL CONSTANT (.TRUE., LINEFALSE .FALSE.) A LOGICAL VARIABLE (INCLUD- *ENDIF ING $DEF(NAME)) OR EQUALITY (NAME1 = NAME2, NAME1 = 'LITERAL', NAME1 = INTEGER ). *IFS MAY BE NESTED TO ANY DEPTH. *IF(NOLIMIT) *SET(LIMIT = 1000) *IF($DEF(LIMIT)) *ELSE *SET(LIMIT = 1000) *END IF *IF(DEBUG) WRITE($(OUTPUT),66) X,Y,Z *IF(ID = SUPERUSER) *SET(PRIORITY = HIGHESTPRIORITY) *ENDIF *DO(NAME = I1,I2,I3) DO-LOOP MUCH AS IN FORTRAN. NAME ... ASSUMES INTEGER VALUES SO $(NAME) *ENDDO BECOMES 12, SAY, IN THE TEXT. THE RANGE SPECIFICATIONS MUST BE INTEGER LITERALS OR VARIABLES WITH INTEGER VALUES. *DO (K = 1, NLIST, 3) $(K), $LIST(A) $LIST(A)-$LIST(A) *ENDDO PRODUCES (FOR NLIST = 9 AND APPROPRIATE VALUES IN A) 1, BIOLOGY 200-299 4, MATHEMA 100-299 7, PHYSICS 110-320 4. OTHER *COMMENT COMMENT LINES. NO SUBSTITUTIONS ARE ... MADE OR DIRECTIVES PROCESSED IN COM- *ENDCOM MENTS. *END TERMINATE PROCESSING (END-OF-FILE) *RESET(NAME) RESET POINTER FOR LIST NAME TO BEGINNING OF LIST *OPTIONS(NAME1 = NAME2) SET MACRO PROCESSOR OPTION NAME1. *OPTIONS(NAME1 = 'LITERAL') NAME2 OR LITERAL MUST BE AN APPROPRIATE VALUE. THE OPTIONS WITH POSSIBLE NAME1 VALUES AND DEFAULTS ARE GIVEN IN TABLE 2. TABLE 2. MACRO PROCESSOR OPTIONS NAME DEFAULT DEFINITION CDIR * DIRECTIVE PREFIX CHARACTER CEOL - END-OF-LINE MARKER IS $- CEOR / LIST ITEM SEPARATOR IS $/ CONC + CONTINUATION PREFIX CHARACTER CSUB $ SUBSTITUTION PREFIX CHARACTER ICPLI 72 CHARACTERS PER LINE OF INPUT ICPLO 72 CHARACTERS PER LINE OF OUTPUT IUNITI 5 INPUT UNIT NUMBER IUNITO 6 OUTPUT UNIT NUMBER LBREAK .FALSE. SWITCH TO BREAK OUTPUT AT NICE CHARACTER LCOL1 .TRUE. ONLY CHECK COLUMN 1 FOR CDIR LFORT .FALSE. WRITE LINES WITH FORTRAN CONTINUATION LISTI .FALSE. LIST INPUT LISTO .FALSE. LIST OUTPUT LSUB .TRUE. PROCESS SUBSTITUTIONS AFTER THIS POINT L1TRIP .FALSE. USE ONE-TRIP DO-LOOPS 2. APPLICATIONS ------------ THIS MACRO PROCESSOR IS POWERFUL ENOUGH TO BE APPLICA- BLE TO A WIDE RANGE OF TYPICAL MACRO PROCESSOR APPLICATIONS. THESE RANGE FROM PROCESSING SIMPLE FORM LETTERS TO COMPLEX "INSTRUMENTATIONS" OF PROGRAMS AND TEXTS. THE PROCESSOR IS TUNED TO FORTRAN IN SEVERAL WAYS (E.G. IT HAS A SPECIAL VARIABLE LABEL FOR CREATING FORTRAN LABELS) AND IS TARGETED TO FORTRAN CODE MANIPULATION. TYPICAL APPLICATIONS INCLUDE (1) IMPLEMENTATIONS OF VERY HIGH LEVEL LANGUAGES VIA FORTRAN PREPROCESSORS. THESE PREPROCESSORS HAVE TWO COM- PONENTS: LANGUAGE PARSING AND CODE GENERATION. THE LANGUAGE PARSER SAVES VALUES IN A SYMBOL TABLE WHICH DEFINE WHAT IS TO BE DONE, THESE ARE THEN MERGED WITH THE TEMPLATE OF A FORTRAN PROGRAM TO GENERATE THE SPECIFIC FORTRAN CODE. THE MACRO PROCESSOR CAN IMPLEMENT THIS SECOND COMPONENT. SOME SUBSTANTIAL LANGUAGES HAVE BEEN IMPLEMENTED USING THIS MACRO PROCESSOR. (2) TAILORING PROGRAMS TO SPECIFIC ENVIRONMENTS. A FORTRAN PROGRAM CAN BE PUT INTO A TEMPLATE WITH MANY "PARAM- ETERS" TO BE INSERTED FOR A SPECIFIC VERSION. THESE PARAME- TERS MAY RANGE FROM SOMETHING SIMPLE LIKE THE I/O UNIT NUMBERS OR THE DIMENSIONS OF CERTAIN ARRAYS TO COMPLEX THINGS LIKE WHOLE SUBROUTINES FOR SPECIFIC ENVIRONMENTS OR CHANGING PROGRAM TYPE E.G. FROM REAL TO DOUBLE PRECISION. THE FOLLOWING EXAMPLE ILLUSTRATES THIS TYPE OF APPLICATION. CONSIDER THE LINPACK ROUTINES TO FACTOR AND SOLVE A SYSTEM OF LINEAR EQUATIONS. WE WANT TO BE ABLE TO CREATE A SPECIFIC PROGRAM WITH THE FOLLOWING OPTIONS: 1. THE CODE MAY BE SINGLE OR DOUBLE PRECISION, 2. THE MATRIX CONDITION NUMBER MAY BE ESTIMATED, 3. A RIGHT SIDE MAY BE READ AND THE LINEAR SYSTEM SOLVED. A PROGRAM TEMPLATE FOR THIS FOLLOWS: *IF (TYPE = 'SINGLE') *SET ( DECL = 'REAL') *SET ( PREFIX = 'S' ) *ELSE *SET ( DECL = 'DOUBLE PRECISION' ) *SET ( PREFIX = 'D' ) *ENDIF $DECL A($N,$N) *IF (CONDNO) $DECL RCOND, WORK($N) *ENDIF *IF (SOLVE) $DECL B($N) *ENDIF INTEGER IPVT($N) READ(5,*) A *IF (CONDNO) CALL $(PREFIX)GECO (A, $N, $N, IPVT, RCOND, WORK) WRITE(6,*) RCOND *ELSE CALL $(PREFIX)GEFA (A, $N, $N, IPVT, INFO) *ENDIF *IF (SOLVE) READ(5,*) B CALL $(PREFIX)GESL (A, $N, $N, IPVT, B, O) WRITE(6,*) B *ENDIF STOP END *END WE SEE THAT THE CODE IS PARAMETERIZED BY THE VARIABLES DECL = FORTRAN DECLARATION KEYWORD PREFIX = LINPACK SUBROUTINES NAME PREFIX CHARACTER CONDNO = SWITCH FOR CONDITION NUMBER SOLVE = SWITCH FOR SOLVING LINEAR SYSTEM TYPE = VARIBLE FOR SINGLE OR DOUBLE PRECISION IF THE PROGRAM TEMPLATE IS PRECEDED BY THE MACRO INSTRUC- TIONS *SET TYPE = 'SINGLE' CONDNO = .FALSE. SOLVE = .TRUE. N = 10 *ENDSET THEN THE MACRO PROCESSOR PRODUCES THE PROGRAM REAL A(10,10) REAL B(10) INTEGER IPVT(10) READ(5,*) A CALL SGEFA (A, 10, 10, IPVT, INFO) READ(5,*) B CALL SGESL (A, 10, 10, IPVT, B, 0) WRITE(6,*) B STOP END IF THE MACRO INSTRUCTIONS ARE CHANGED TO TYPE = 'DOUBLE', CONDNO = .TRUE., SOLVE = .FALSE. AND N=5 THEN THE MACRO PRO- CESSOR PRODUCES THE PROGRAM DOUBLE PRECISION A(5,5) DOUBLE PRECISION RCOND, WORK(5) INTEGER IPVT(5) READ(5,*) A CALL DGECO (A, 5, 5, IPVT, RCOND, WORK) WRITE(6,*) RCOND STOP END 3. DISTRIBUTED MATERIAL ----------- -------- THE ALGORITHM CONSISTS OF THE FOLLOWING FILES: (1) PORTABLE, FORTRAN 66 VERSION OF THE MACRO PROCES- SOR (2) TEXT OF THIS PAPER (3) USER'S GUIDE FOR THE MACRO PROCESSOR (4) MACRO PROCESSOR TEMPLATE (5) TEST CASES A. EXHAUSTIVE TEST OF ALL FACILITIES B. FORM LETTER TO AUTHORS TO REPORT PROBLEMS C. THE LINPACK EXAMPLE GIVEN ABOVE D. THE SIMPLE EXAMPLES FROM THE USER'S GUIDE E. A COMPLEX EXAMPLE: THE ELLPACK SYSTEM TEM- PLATE INSTALLERS SHOULD NOTE THAT ROUTINES UTCHKA, UTCHKN, AND UTCHKS MAY HAVE TO BE MODIFIED IF THE PROCESSOR IS TAILORED BY SETTING TESTCH = .FALSE., AND IF THE DIGITS 0 TO 9 AND THE LETTERS A TO Z ARE NONCONTIGUOUS IN THE CHARACTER SET USED. THIS WORK WAS SUPPORTED IN PART BY NSF GRANT MCS-79763L0 4. REFERENCES ---------- A.J. COLE, MACRO PROCESSORS, CAMBRIDGE UNIVERSITY, PRESS, CAMBRIDGE, ENGLAND, 1976. SHAR_EOF fi # end of overwriting check cd .. if test ! -d 'Fortran77' then mkdir 'Fortran77' fi cd 'Fortran77' if test ! -d 'Drivers' then mkdir 'Drivers' fi cd 'Drivers' if test ! -d 'Sp' then mkdir 'Sp' fi cd 'Sp' if test -f 'bugreport' then echo shar: will not over-write existing file "'bugreport'" else cat << SHAR_EOF > 'bugreport' *SET ( NAME = 'PUT YOUR NAME HERE' ) *SET ( DATE = 'PUT DATE HERE' ) *SET ( ADDRESS = 'PUT YOUR ADDRESS HERE' ) *SET ( CITY = 'YOUR CITY' ) *SET ( STATE = 'YOUR STATE' ) *SET ( ZIP = 'YOUR ZIP CODE' ) *SET ( FROM ) $$DATE $$ADDRESS $$CITY, $$STATE $$ZIP *ENDSET *SET ( TO ) TOOLPACK GROUP DEPARTMENT OF COMPUTER SCIENCES PURDUE UNIVERSITY WEST LAFAYETTE, INDIANA 47906 DEAR TOOLPACK, *ENDSET *SET ( BODY ) YOUR TEXT GOES HERE. *ENDSET *SET ( SIGNATURE ) YOURS, $$NAME *ENDSET *INCLUDE ( FROM ) *INCLUDE ( TO ) *INCLUDE ( BODY ) *INCLUDE ( SIGNATURE ) *END SHAR_EOF fi # end of overwriting check if test -f 'bugreport.out' then echo shar: will not over-write existing file "'bugreport.out'" else cat << SHAR_EOF > 'bugreport.out' PUT DATE HERE PUT YOUR ADDRESS HERE YOUR CITY, YOUR STATE YOUR ZIP CODE TOOLPACK GROUP DEPARTMENT OF COMPUTER SCIENCES PURDUE UNIVERSITY WEST LAFAYETTE, INDIANA 47906 DEAR TOOLPACK, YOUR TEXT GOES HERE. YOURS, PUT YOUR NAME HERE SHAR_EOF fi # end of overwriting check if test -f 'ellpack' then echo shar: will not over-write existing file "'ellpack'" else cat << SHAR_EOF > 'ellpack' *COMMENT THE FIRST BIG SET STATEMENT WAS ADDED FOR ILLUSTRATION PURPOSES WHEN THIS TEMPLATE IS USED AS A TEST FILE FOR THE TEMPLATE PROCESSOR. *ENDCOM *SET L1TWOD='.TRUE.' PDERHS='0.0' L1CRST='.FALSE.' L1MIXD='.FALSE.' I0MODN='1' XROT = '1$$/2' YROT = '3$$/4' AX = '0.0$$/1.0' AY = '0.0$$/1.0' I1BCST= '1$$/1$$/1$$/1' I1BCTY= '1$$/1$$/1$$/1' I1CF2D= 1 I1CF3D= 0 R1BRHS= 'TRUE(X,Y)' R0CBC = '1.0$$/0.0$$/0.0' R0SOLV= R1QD2I(X, Y, R1TABL, IDERIV) * *ENDSET *OPTION(LSUB=.FALSE.) *SET(UXX='1') *SET(UXY='2') *SET(UYY='3') *SET(UX='4') *SET(UY='5') *SET(U='6') *SET(UZZ='7') *SET(UXZ='8') *SET(UYZ='9') *SET(UZ='10') *SET(CUXX='0.0') *SET(CUXY='0.0') *SET(CUYY='0.0') *SET(CUX='0.0') *SET(CUY='0.0') *SET(CU='0.0') *SET(CUZZ='0.0') *SET(CUXZ='0.0') *SET(CUYZ='0.0') *SET(CUZ='0.0') *SET(NX='-1') *SET(NY='-1') *SET(NZ='1') *SET(PLOTS='.FALSE.') *SET(LABEL='20000') *SET(NEEDR1TABL='.FALSE.') *SET(HAVEDIS='.FALSE.') *SET(HAVEGRX='.FALSE.') *SET(HAVEGRY='.FALSE.') *SET(HAVEGRZ='.FALSE.') *SET(SPLINES='.FALSE.') *SET(QUADRATICS='.TRUE.') *SET(NGRMXX='1') *SET(NGRMXY='1') *SET(NGRMXZ='1') *SET(L1POLY='.TRUE.') *SET(L1PRDX='.TRUE.') *SET(L1PRDY='.TRUE.') *SET(L1PRDZ='.TRUE.') *SET(L1PRDC='.TRUE.') *SET(L1RECT='.TRUE.') *SET(L1HOLE='.FALSE.') *SET(L1DRCH='.TRUE.') *SET(L1NEUM='.TRUE.') *SET(L1CSTB='.FALSE.') *SET(GLOBAL) COMMON / C1RVGL / R1EPSG, R1EPSM, PI *ENDSET *SET(MDECLARE) C *ENDSET *SET(DECLARE) *INCLUDE(MDECLARE) *ENDSET *SET(SRCALLS) C *ENDSET *SET(GRIDEND) L1UNFG = L1UNFX .AND. L1UNFY .AND. L1UNFZ *IF (L1RECT) *ELSE C *RESET(R1BRNG) *DO (I=1,I1NBND) R1BRNG(1,$I) = $LIST(R1BRNG) R1BRNG(2,$I) = $LIST(R1BRNG) *ENDDO *ENDIF *ENDSET *SET(BEGINMODULE) C C============ $MODNAME C *IF (L1TIME) CALL Q1TIME (R0TBEG) *ENDIF *ENDSET *SET(AFTERTR) I0MODN = $I0MODN L0HVAN = .TRUE. L1NEWD = .TRUE. *ENDSET *SET(AFTERDI) I0DISM = $I0DISM L0HVDI = .TRUE. L1UINI = .FALSE. CALL Q0ASIS *ENDSET *SET(BEFOREIN) IF (.NOT. L0HVDI) CALL Q0ERPP(1) L1ASIS = .FALSE. L1RDBL = .FALSE. *ENDSET *SET(BEFORESO) IF (.NOT. L0HVDI) CALL Q0ERPP(2) *ENDSET *SET(AFTERSO) I0MODN = I0DISM L0HVAN = .TRUE. L1NEWD = .TRUE. CALL Q0UNDX *ENDSET *SET(BEGINSOLUT) C C============ $MODNAME C *ENDSET *SET(ENDSETUP) *IF (L1TIME) CALL Q1TIME(R0TEND) R0TIME = R0TEND - R0TBEG *SET(L ='$LABEL') WRITE(I0TIME,$L) R0TIME $L FORMAT(4X,F14.2,5X,'$MODNAME SETUP') CALL Q1TIME (R0TBEG) *ENDIF IF (L1FATL) CALL Q1FATL *ENDSET *SET(ENDMODULE) *IF(L1TIME) CALL Q1TIME (R0TEND) R0TIME = R0TEND - R0TBEG *SET(L='$LABEL') WRITE(I0TIME,$L) R0TIME $L FORMAT(4X,F14.2,5X,'$MODNAME') *ENDIF IF (L1FATL) CALL Q1FATL *ENDSET *SET(INTERPOLATE) *IF(L1RECT) *ELSE IF (L1NEWD) CALL Q2XTMN($TABLE) *ENDIF *IF(SPLINES) *IF(L1TWOD) R0SOLV = R1BS2I(X, Y, $TABLE, $I1KORD, IDERIV) *ELSE R0SOLV = R1BS3I(X, Y, Z, $TABLE, $I1KORD, IDERIV) *ENDIF *ENDIF *IF(QUADRATICS) *IF(L1TWOD) R0SOLV = R1QD2I(X, Y, $TABLE, IDERIV) *ELSE R0SOLV = R1QD3I(X, Y, Z, $TABLE, IDERIV) *ENDIF *ENDIF *ENDSET *SET(INITOPT) C *ENDSET *SET (SRGRIDX) C C============ SETUP GRIDX C I1NGRX = $I0NGRX L1UNFX = $L1UNFX *IF (L1UNFX) *IF (L1RECT) *ELSE *RESET(AX) R1AXGR = $LIST(AX) R1BXGR = $LIST(AX) *ENDIF CALL Q0GRUF(R1AXGR, R1BXGR, R1GRDX, I1NGRX, R1HXGR, $I1NGRX, 'X') *ELSE *RESET(R1GRDX) *DO (I=1,I0NGRX) R1GRDX($I) = $LIST(R1GRDX) *ENDDO CALL Q0GRNU(R1AXGR, R1BXGR, R1GRDX, I1NGRX, R1HXGR, $I1NGRX, 'X') *ENDIF *ENDSET *SET (SRGRIDY) C C============ SETUP GRIDY C I1NGRY = $I0NGRY L1UNFY = $L1UNFY *IF (L1UNFY) *IF (L1RECT) *ELSE *RESET(AY) R1AYGR = $LIST(AY) R1BYGR = $LIST(AY) *ENDIF CALL Q0GRUF(R1AYGR, R1BYGR, R1GRDY, I1NGRY, R1HYGR, $I1NGRY, 'Y') *ELSE *RESET(R1GRDY) *DO (I=1,I0NGRY) R1GRDY($I) = $LIST(R1GRDY) *ENDDO CALL Q0GRNU(R1AYGR, R1BYGR, R1GRDY, I1NGRY, R1HYGR, $I1NGRY, 'Y') *ENDIF *ENDSET *SET (SRGRIDZ) C C============ SETUP GRIDZ C I1NGRZ = $I0NGRZ L1UNFZ = $L1UNFZ *IF (L1UNFZ) *IF (L1RECT) *ELSE *RESET(AZ) R1AZGR = $LIST(AZ) R1BZGR = $LIST(AZ) *ENDIF CALL Q0GRUF(R1AZGR, R1BZGR, R1GRDZ, I1NGRZ, R1HZGR, $I1NGRZ, 'Z') *ELSE *RESET(R1GRDZ) *DO (I=1,I0NGRZ) R1GRDZ($I) = $LIST(R1GRDZ) *ENDDO CALL Q0GRNU(R1AZGR, R1BZGR, R1GRDZ, I1NGRZ, R1HZGR, $I1NGRZ, 'Z') *ENDIF *ENDSET *SET(DC=1) *SET(DC=2) *SET(DC=3) *SET(MEMORY='.FALSE.') *SET(PPDEBUG='.FALSE.') *SET(NOEXECUTION='.FALSE.') *SET(L0CSTC='.TRUE.') *SET(L1CSTC='$L0CSTC') *SET(ALCONSTANTCOEFFICIENTS='L1CSTC') *SET(L1CLKW='.FALSE.') *SET(ALCLOCKWISE='L1CLKW') *SET(L0HMBC='.TRUE.') *SET(L1HMBC='$L0HMBC') *SET(ALHOMOGENEOUSBC='L1HMBC') *SET(OTL1HMBC=3) *SET(L0HMEQ='.TRUE.') *SET(L1HMEQ='$L0HMEQ') *SET(ALHOMOGENEOUSPDE='L1HMEQ') *SET(OTL1HMEQ=3) *SET(L0LAPL='.FALSE.') *SET(L1LAPL='$L0LAPL') *SET(ALLAPLACE='L1LAPL') *SET(OTL1LAPL=3) *SET(I1LEVL='1') *SET(ALLEVEL='I1LEVL') *SET(OTI1LEVL=1) *SET(I0NGRX='1') *SET(I1NGRX='$I0NGRX') *SET(ALMAXXPOINTS='I1NGRX') *SET(I0NGRY='1') *SET(I1NGRY='$I0NGRY') *SET(ALMAXYPOINTS='I1NGRY') *SET(I0NGRZ='1') *SET(I1NGRZ='$I0NGRZ') *SET(ALMAXZPOINTS='I1NGRZ') *SET(L0POIS='.FALSE.') *SET(L1POIS='$L0POIS') *SET(ALPOISSON='L1POIS') *SET(OTL1POIS=3) *SET(L0SELF='.FALSE.') *SET(L1SELF='$L0SELF') *SET(ALSELFADJOINT='L1SELF') *SET(OTL1SELF=3) *SET(L1TIME='.FALSE.') *SET(ALTIME='L1TIME') *SET(I1PAGE='1') *SET(ALPAGE='I1PAGE') *SET(OTI1PAGE=1) *SET(I0GRDX='$I1NGRX') *SET(I0GRDY='$I1NGRY') *SET(I0GRDZ='$I1NGRZ') *SET(I0GRTY='$I1NGRX') *SET(I0GRT2='$I1NGRY') *SET(I0TABL='$I1NGRX') *SET(I0TAB2='$I1NGRY') *SET(I0TAB3='$I1NGRZ') *SET(I1NBND='1') *SET(I0BCST='$I1NBND') *SET(I0BCTY='$I1NBND') *SET(I0BRNG='$I1NBND') *SET(I1KWRK='1') *SET(I0KWRK='$I1KWRK') *SET(ALWORKSPACE='I0KWRK') *SET(MINWORKSPACE='1') *SET(MAXWORKSPACE='$I1KWRK') *SET(I1KBAN='1') *SET(I0KBAN='$I1KBAN') *SET(ALBANDWIDTH='I0KBAN') *SET(I1MXKO='0') *SET(I0KORD='$I1MXKO') *SET(ALORDER='I0KORD') *SET(I1BSTP='1') *SET(I0BSTP='$I1BSTP') *SET(I1MBPT='1') *SET(I0MBPT='$I1MBPT') *SET(ALBOUNDARYPOINTS='I0MBPT') *SET(I0BNGH='$I0MBPT') *SET(I0BGRD='$I0MBPT') *SET(I0BPAR='$I0MBPT') *SET(I0BPTY='$I0MBPT') *SET(I0PECE='$I0MBPT') *SET(I0XBND='$I0MBPT') *SET(I0YBND='$I0MBPT') *SET(I1MNEQ='1') *SET(I0MNEQ='$I1MNEQ') *SET(ALEQUATIONS='I0MNEQ') *SET(I0BBBB='$I0MNEQ') *SET(I0COEF='$I0MNEQ') *SET(I0ENDX='$I0MNEQ') *SET(I0IDCO='$I0MNEQ') *SET(I0UNDX='$I0MNEQ') *SET(I1MNCO='1') *SET(I0MNCO='$I1MNCO') *SET(ALCOEFFICIENTS='I0MNCO') *SET(I0COE2='$I0MNCO') *SET(I0IDC2='$I0MNCO') *SET(I1MUNK='1') *SET(I0MUNK='$I1MUNK') *SET(ALUNKNOWNS='I0MUNK') *SET(I0UNKN='$I1MUNK') *SET(PCDOMAIN='P1') *SET(TYP1='PR') *SET(DCP1=4) *SET(PCHOLE='P2') *SET(TYP2='PR') *SET(DCP2=5) *SET(PCARC='P3') *SET(TYP3='PR') *SET(DCP3=6) *SET(PCDISPLAYMATRIXPATTERN='P4') *SET(P4MATZER='1H.') *SET(P4MATNZR='1HX') *SET(P4MATDZR='1H0') *SET(P4MATDNZ='1HD') *SET(P4MATBLK='I1NEQN') *SET(P4MATLNL='120') *SET(P4EPSMAT='0.0') *SET(P4MATNBR='0') *SET(P4MATNBC='0') *SET(P4MATOUT='I1OUTP') *SET(TYP4='PR') *SET(DCP4=7) *SET(PCDOMAINFILL='P5') *SET(P5NFILL='1') *SET(P5EXTER='.FALSE.') *SET(TYP5='PR') *SET(DCP5=8) *SET(PCSETUNKNOWNSFOR5POINTSTAR='P6') *SET(P6UEST='ZERO') *SET(TYP6='PR') *SET(DCP6=9) *SET(PCSETUNKNOWNSFORHODIEHELMHOLTZ='P7') *SET(P7UEST='ZERO') *SET(TYP7='PR') *SET(DCP7=10) *SET(PCNONUNIQUE='P8') *SET(P8X='R1AXGR') *SET(P8Y='R1AYGR') *SET(P8Z='R1AZGR') *SET(P8U='0.0') *SET(TYP8='PR') *SET(PCREMOVE='P9') *SET(P9V='V') *SET(P9HXSTEP='-1.') *SET(P9HYSTEP='-1.') *SET(P9HZSTEP='-1.') *SET(TYP9='PR') *SET(PCREMOVEBYBLENDING='P10') *SET(TYP10='PR') *SET(PCREMOVEBYBICUBICS='P11') *SET(TYP11='PR') *SET(DCP11=11) *SET(PCEIGENVALUES='P12') *SET(P12SCALE='1.0') *SET(TYP12='PR') *SET(DCP12=12) *SET(PCSET='P13') *SET(P13U='ZERO') *SET(TYP13='TR') *SET(DCP13=13) *SET(PCSETUBYBLENDING='P14') *SET(TYP14='TR') *SET(PCSETUBYBICUBICS='P15') *SET(TYP15='TR') *SET(DCP15=14) *SET(PCHODIEFFT='P16') *SET(P16IORDER='4') *SET(TYP16='TR') *SET(DCP16=15) *SET(PCFFT9POINT='P17') *SET(P17IORDER='4') *SET(TYP17='TR') *SET(DCP17=16) *SET(PCP2C0TRIANGLES='P18') *SET(P18MEM='0') *SET(P18NTRI='0') *SET(TYP18='TR') *SET(DCP18=17) *SET(PCHODIE27POINT3D='P19') *SET(TYP19='TR') *SET(DCP19=18) *SET(PCFISHPAKHELMHOLTZ='P20') *SET(TYP20='TR') *SET(DCP20=19) *SET(PCCMM1='P21') *SET(P21IWORKR='0') *SET(P21IWORKI='0') *SET(P21NUDATA='0') *SET(TYP21='TR') *SET(DCP21=20) *SET(PCCMM2='P22') *SET(P22IWORKR='0') *SET(P22IWORKI='0') *SET(P22NUDATA='0') *SET(TYP22='TR') *SET(DCP22=21) *SET(PCCMM3='P23') *SET(P23IWORKR='0') *SET(P23IWORKI='0') *SET(P23NUDATA='0') *SET(TYP23='TR') *SET(DCP23=22) *SET(PCMULTIGRIDMG00='P24') *SET(P24METHOD='0') *SET(P24UINIT='0') *SET(P24NMIN='2') *SET(P24INEUM='0') *SET(P24ITER='0') *SET(P24IGAMMA='1') *SET(TYP24='TR') *SET(DCP24=23) *SET(PCMARCHINGALGORITHM='P25') *SET(P25KGMA='2') *SET(TYP25='TR') *SET(DCP25=24) *SET(PCDYAKANOVCG='P26') *SET(P26MAXIT='100') *SET(P26DEMAND='3.0') *SET(TYP26='TR') *SET(DCP26=25) *SET(PCDYAKANOVCG4='P27') *SET(P27MAXIT='100') *SET(P27DEMAND='3.0') *SET(TYP27='TR') *SET(DCP27=26) *SET(PC5POINTSTAR='P28') *SET(TYP28='DI') *SET(DCP28=27) *SET(PC7POINT3D='P29') *SET(TYP29='DI') *SET(DCP29=28) *SET(PCHODIEHELMHOLTZ='P30') *SET(P30IORDER='4') *SET(TYP30='DI') *SET(DCP30=29) *SET(PCHODIEACF='P31') *SET(P31METHOD='-1') *SET(TYP31='DI') *SET(DCP31=30) *SET(PCCOLLOCATION='P32') *SET(P32BCP1='0.') *SET(P32BCP2='0.') *SET(P32DSCARE='.05') *SET(P32PTSIZE='6.') *SET(P32GIVOPT='1') *SET(P32IDPLOT='0') *SET(P32USECRN='.FALSE.') *SET(TYP32='DI') *SET(DCP32=31) *SET(PCPLOTCOLLOCATIONPOINTS='P33') *SET(P33BCP1='0.') *SET(P33BCP2='0.') *SET(P33DSCARE='.05') *SET(P33PTSIZE='6.') *SET(P33GIVOPT='1') *SET(P33IDPLOT='0') *SET(P33USECRN='.FALSE.') *SET(TYP33='PR') *SET(DCP33=32) *SET(PCHERMITECOLLOCATION='P34') *SET(P34BCP1='0.0') *SET(P34BCP2='0.0') *SET(TYP34='DI') *SET(DCP34=33) *SET(PCINTERIORCOLLOCATION='P35') *SET(TYP35='DI') *SET(DCP35=34) *SET(PCSPLINEGALERKIN='P36') *SET(P36DEGREE='3') *SET(P36NDERV='2') *SET(TYP36='DI') *SET(DCP36=35) *SET(PCASIS='P37') *SET(TYP37='IN') *SET(PCREDBLACK='P38') *SET(P38LEVEL='I1LEVL') *SET(TYP38='IN') *SET(PCNESTEDDISSECTION='P39') *SET(P39NDTYPE='5') *SET(TYP39='IN') *SET(DCP39=36) *SET(PCREVERSECUTHILLMCKEE='P40') *SET(TYP40='IN') *SET(PCMINIMUMDEGREE='P41') *SET(TYP41='IN') *SET(DCP41=37) *SET(PCHERMITECOLLORDER='P42') *SET(TYP42='IN') *SET(PCINTERIORCOLLORDER='P43') *SET(TYP43='IN') *SET(DCP43=38) *SET(PCLINPACKBAND='P44') *SET(TYP44='SO') *SET(DCP44=39) *SET(PCLINPACKSPDBAND='P45') *SET(TYP45='SO') *SET(DCP45=40) *SET(PCBANDGENOPIVOTING='P46') *SET(TYP46='SO') *SET(DCP46=41) *SET(PCBANDGE='P47') *SET(TYP47='SO') *SET(DCP47=42) *SET(PCSPARSELDLT='P48') *SET(TYP48='SO') *SET(DCP48=43) *SET(PCSPARSELUUNCOMPRESSED='P49') *SET(TYP49='SO') *SET(DCP49=44) *SET(PCSPARSELUCOMPRESSED='P50') *SET(TYP50='SO') *SET(DCP50=45) *SET(PCSPARSEGENOPIVOTING='P51') *SET(TYP51='SO') *SET(DCP51=46) *SET(PCSPARSELUPIVOTING='P52') *SET(P52MAXNZ='0') *SET(TYP52='SO') *SET(DCP52=47) *SET(PCENVELOPELDU='P53') *SET(TYP53='SO') *SET(DCP53=48) *SET(PCENVELOPELDLT='P54') *SET(TYP54='SO') *SET(DCP54=49) *SET(PCSOR='P55') *SET(P55ITMAX='100') *SET(P55LEVEL='I1LEVL') *SET(P55IADAPT='1') *SET(P55ICASE='1') *SET(P55IDGTS='0') *SET(P55ZETA='AMAX1(5.E-6,5.E2*R1EPSM)') *SET(P55CME='0.') *SET(P55SME='0.') *SET(P55FF='.75') *SET(P55OMEGA='1.') *SET(P55SPECR='0.') *SET(P55BETAB='0.25') *SET(TYP55='SO') *SET(DCP55=50) *SET(PCJACOBICG='P56') *SET(P56ITMAX='100') *SET(P56LEVEL='I1LEVL') *SET(P56IADAPT='1') *SET(P56ICASE='1') *SET(P56IDGTS='0') *SET(P56ZETA='AMAX1(5.E-6,5.E2*R1EPSM)') *SET(P56CME='0.') *SET(P56SME='0.') *SET(P56FF='.75') *SET(P56OMEGA='1.') *SET(P56SPECR='0.') *SET(P56BETAB='0.25') *SET(TYP56='SO') *SET(DCP56=51) *SET(PCJACOBISI='P57') *SET(P57ITMAX='100') *SET(P57LEVEL='I1LEVL') *SET(P57IADAPT='1') *SET(P57ICASE='1') *SET(P57IDGTS='0') *SET(P57ZETA='AMAX1(5.E-6,5.E2*R1EPSM)') *SET(P57CME='0.') *SET(P57SME='0.') *SET(P57FF='.75') *SET(P57OMEGA='1.') *SET(P57SPECR='0.') *SET(P57BETAB='0.25') *SET(TYP57='SO') *SET(DCP57=52) *SET(PCREDUCEDSYSTEMCG='P58') *SET(P58ITMAX='100') *SET(P58LEVEL='I1LEVL') *SET(P58IADAPT='1') *SET(P58ICASE='1') *SET(P58IDGTS='0') *SET(P58ZETA='AMAX1(5.E-6,5.E2*R1EPSM)') *SET(P58CME='0.') *SET(P58SME='0.') *SET(P58FF='.75') *SET(P58OMEGA='1.') *SET(P58SPECR='0.') *SET(P58BETAB='0.25') *SET(TYP58='SO') *SET(DCP58=53) *SET(PCREDUCEDSYSTEMSI='P59') *SET(P59ITMAX='100') *SET(P59LEVEL='I1LEVL') *SET(P59IADAPT='1') *SET(P59ICASE='1') *SET(P59IDGTS='0') *SET(P59ZETA='AMAX1(5.E-6,5.E2*R1EPSM)') *SET(P59CME='0.') *SET(P59SME='0.') *SET(P59FF='.75') *SET(P59OMEGA='1.') *SET(P59SPECR='0.') *SET(P59BETAB='0.25') *SET(TYP59='SO') *SET(DCP59=54) *SET(PCSYMMETRICSORCG='P60') *SET(P60ITMAX='100') *SET(P60LEVEL='I1LEVL') *SET(P60IADAPT='1') *SET(P60ICASE='1') *SET(P60IDGTS='0') *SET(P60ZETA='AMAX1(5.E-6,5.E2*R1EPSM)') *SET(P60CME='0.') *SET(P60SME='0.') *SET(P60FF='.75') *SET(P60OMEGA='1.') *SET(P60SPECR='0.') *SET(P60BETAB='0.25') *SET(TYP60='SO') *SET(DCP60=55) *SET(PCSYMMETRICSORSI='P61') *SET(P61ITMAX='100') *SET(P61LEVEL='I1LEVL') *SET(P61IADAPT='1') *SET(P61ICASE='1') *SET(P61IDGTS='0') *SET(P61ZETA='AMAX1(5.E-6,5.E2*R1EPSM)') *SET(P61CME='0.') *SET(P61SME='0.') *SET(P61FF='.75') *SET(P61OMEGA='1.') *SET(P61SPECR='0.') *SET(P61BETAB='0.25') *SET(TYP61='SO') *SET(DCP61=56) *SET(PCMAX='P62') *SET(TYP62='OU') *SET(PCRMS='P63') *SET(TYP63='OU') *SET(PCNORM='P64') *SET(TYP64='OU') *SET(PCTABLE='P65') *SET(TYP65='OU') *SET(DCP65=57) *SET(PCSUMMARY='P66') *SET(TYP66='OU') *SET(DCP66=58) *SET(PCTABLEEQUATIONS='P67') *SET(TYP67='OU') *SET(PCTABLEPROBLEM='P68') *SET(TYP68='OU') *SET(PCTABLEINDEXES='P69') *SET(TYP69='OU') *SET(PCTABLEUNKNOWN='P70') *SET(TYP70='OU') *SET(PCPLOTDOMAIN='P71') *SET(TYP71='OU') *SET(DCP71=59) *SET(PCTABLEDOMAIN='P72') *SET(TYP72='OU') *SET(PCTABLEBOUNDARY='P73') *SET(TYP73='OU') *SET(PCPLOT='P74') *SET(TYP74='OU') *SET(DCP74=60) *SET(PCDATA='P75') *SET(TYP75='OU') *OPTION(LSUB=.TRUE.) *SET(L1HMBC='$L0HMBC') *SET(L1HMEQ='$L0HMEQ') *SET(L1LAPL='$L0LAPL') *SET(L1POIS='$L0POIS') *SET(L1SELF='$L0SELF') *IF($DEF(HVP1)) *SET(SRP1) *SET(MODNAME='DOMAIN') *INCLUDE(BEGINMODULE) L1CLKW = $$L1CLKW I1NBND = $$I1NBND CALL Q2DPMN IF (L1FATL) CALL Q1FATL *ENDSET *ENDIF *IF($DEF(HVP2)) *SET(SRP2) *SET(MODNAME='HOLE') *INCLUDE(BEGINMODULE) L1CLKW = $$L1CLKW I1NBND = $$I1NBND CALL Q2DPHO(.FALSE.) IF (L1FATL) CALL Q1FATL *ENDSET *ENDIF *IF($DEF(HVP3)) *SET(SRP3) *SET(MODNAME='ARC') *INCLUDE(BEGINMODULE) L1CLKW = $$L1CLKW I1NBND = $$I1NBND CALL Q2DPHO(.TRUE.) IF (L1FATL) CALL Q1FATL *ENDSET *ENDIF *IF($DEF(HVP4)) *SET(SRP4) *SET(MODNAME='DISPLAY MATRIX PATTERN') *INCLUDE(BEGINMODULE) MATZER = $$P4MATZER MATNZR = $$P4MATNZR MATDZR = $$P4MATDZR MATDNZ = $$P4MATDNZ MATBLK = $$P4MATBLK MATLNL = $$P4MATLNL EPSMAT = $$P4EPSMAT MATNBR = $$P4MATNBR MATNBC = $$P4MATNBC MATOUT = $$P4MATOUT CALL Q7DMMN (MATZER, MATNZR, MATDZR, MATDNZ, MATBLK, MATLNL, A EPSMAT, MATNBR, MATNBC, MATOUT) *ENDSET *ENDIF *IF($DEF(HVP5)) *SET(SRP5) *SET(MODNAME='DOMAIN FILL') *INCLUDE(BEGINMODULE) NFILL = $$P5NFILL EXTER = $$P5EXTER CALL Q7DFMN(NFILL,EXTER,I1GRTY,I1NGRX,I1NGRY) *ENDSET *ENDIF *IF($DEF(HVP6)) *SET(SRP6) *SET(MODNAME='SET UNKNOWNS FOR 5-POINT STAR') *INCLUDE(BEGINMODULE) CALL Q75PIU ($$P6UEST) *ENDSET *ENDIF *IF($DEF(HVP7)) *SET(SRP7) *SET(MODNAME='SET UNKNOWNS FOR HODIE-HELMHOLTZ') *INCLUDE(BEGINMODULE) CALL Q7HHIU ($$P7UEST) *ENDSET *ENDIF *IF($DEF(HVP8)) *SET(SRP8) *SET(MODNAME='NON-UNIQUE') *INCLUDE(BEGINMODULE) R1UNQX = $$P8X R1UNQY = $$P8Y R1UNQZ = $$P8Z R1UNQU = $$P8U L1NUNQ = .TRUE. *ENDSET *ENDIF *IF($DEF(HVP9)) *SET(SRP9) *SET(MODNAME='REMOVE') *INCLUDE(BEGINMODULE) HXSTEP = $$P9HXSTEP HYSTEP = $$P9HYSTEP HZSTEP = $$P9HZSTEP CALL Q7RMHS(HXSTEP, HYSTEP, HZSTEP) *SET(RMFCN='$$P9V') *IF(L1TWOD) *SET(RMPRHS='R7RML2($$RMFCN, X, Y)') *SET(RMBRHS='R7RMB2($$RMFCN, I0SIDE, X, Y)') *SET(RMSOLV='R7RMV2($$RMFCN, IDERIV, X, Y)') *ELSE *SET(RMPRHS='R7RML3($$RMFCN, X, Y, Z)') *SET(RMBRHS='R7RMB3($$RMFCN, I0SIDE, X, Y, Z)') *SET(RMSOLV='R7RMV3($$RMFCN, IDERIV, X, Y, Z)') *ENDIF *ENDSET *ENDIF *IF($DEF(HVP10)) *SET(SRP10) *SET(MODNAME='REMOVE BY BLENDING') *INCLUDE(BEGINMODULE) CALL Q7RBMN *SET(RMPRHS = 'R7RBL2(X,Y)') *SET(RMBRHS = 'R7RBB2(R1BRHS)') *SET(RMSOLV = 'R7RBV2(X,Y,IDERIV)') *ENDSET *ENDIF *IF($DEF(HVP11)) *SET(SRP11) *SET(MODNAME='REMOVE BY BICUBICS') *INCLUDE(BEGINMODULE) CALL Q7RHMN *SET(RMPRHS = 'R7RHL2(X,Y)') *SET(RMBRHS = 'R7RHB2(R1BRHS)') *SET(RMSOLV = 'R7RHV2(X,Y,IDERIV)') *ENDSET *ENDIF *IF($DEF(HVP12)) *SET(SRP12) *SET(MODNAME='EIGENVALUES') *INCLUDE(BEGINMODULE) SCALE = $$P12SCALE CALL Q7EIMN (SCALE) *ENDSET *ENDIF *IF($DEF(HVP13)) *SET(SRP13) *SET(MODNAME='SET') *INCLUDE(BEGINMODULE) *IF (L1TWOD) *IF (L1RECT) CALL Q6IUR2($$P13U) *ELSE CALL Q6IUNR($$P13U) *ENDIF *ELSE CALL Q6IUR3($$P13U) *ENDIF *ENDSET *SET(SLP13) *SET(MODNAME='SET') *INCLUDE(BEGINSOLUT) *SET(TABLE='R1TABL') *SET(I1KORD='4') *INCLUDE(INTERPOLATE) *ENDSET *ENDIF *IF($DEF(HVP14)) *SET(SRP14) *SET(MODNAME='SET U BY BLENDING') *INCLUDE(BEGINMODULE) CALL Q6BLMN *ENDSET *SET(HVP10=1) *SET(SLP14) *SET(MODNAME='SET U BY BLENDING') *INCLUDE(BEGINSOLUT) R0SOLV = R6BLVL(X, Y, IDERIV) *ENDSET *ENDIF *IF($DEF(HVP15)) *SET(SRP15) *SET(MODNAME='SET U BY BICUBICS') *INCLUDE(BEGINMODULE) CALL Q6HBMN *ENDSET *SET(HVP11=1) *SET(SLP15) *SET(MODNAME='SET U BY BICUBICS') *INCLUDE(BEGINSOLUT) R0SOLV = R6HBVL(X, Y, IDERIV) *ENDSET *ENDIF *IF($DEF(HVP16)) *SET(SRP16) *SET(MODNAME='HODIE-FFT') *INCLUDE(BEGINMODULE) IORDER = $$P16IORDER I1KORD = IORDER CALL Q6H2MN (IORDER) *ENDSET *SET(SLP16) *SET(MODNAME='HODIE-FFT') *INCLUDE(BEGINSOLUT) IF (L1NEWD) CALL Q6H2VL *SET(TABLE='R1TABL') *SET(I1KORD='I1KORD') *INCLUDE(INTERPOLATE) *ENDSET *ENDIF *IF($DEF(HVP17)) *SET(SRP17) *SET(MODNAME='FFT 9-POINT') *INCLUDE(BEGINMODULE) IORDER = $$P17IORDER I1KORD = IORDER CALL Q6FFMN (IORDER) *ENDSET *SET(SLP17) *SET(MODNAME='FFT 9-POINT') *INCLUDE(BEGINSOLUT) *SET(TABLE='R1TABL') *SET(I1KORD='I1KORD') *INCLUDE(INTERPOLATE) *ENDSET *ENDIF *IF($DEF(HVP18)) *SET(SRP18) *SET(MODNAME='P2C0-TRIANGLES') *INCLUDE(BEGINMODULE) MEM = $$P18MEM NTRI = $$P18NTRI MEM = $I1KWRK IF (NTRI.EQ.0) NTRI = 8*I1NGRX*I1NGRY CALL Q6TRMN (NTRI, MEM) *ENDSET *SET(SLP18) *SET(MODNAME='P2C0-TRIANGLES') *INCLUDE(BEGINSOLUT) *SET(TABLE='R1UNKN') *SET(I1KORD='6') *INCLUDE(INTERPOLATE) *ENDSET *ENDIF *IF($DEF(HVP19)) *SET(SRP19) *SET(MODNAME='HODIE 27-POINT 3D') *INCLUDE(BEGINMODULE) CALL Q627MN *ENDSET *SET(SLP19) *SET(MODNAME='HODIE 27-POINT 3D') *INCLUDE(BEGINSOLUT) *SET(TABLE='R1UNKN') *SET(I1KORD='6') *INCLUDE(INTERPOLATE) *ENDSET *ENDIF *IF($DEF(HVP20)) *SET(SRP20) *SET(MODNAME='FISHPAK-HELMHOLTZ') *INCLUDE(BEGINMODULE) CALL Q6FHMN *ENDSET *SET(SLP20) *SET(MODNAME='FISHPAK-HELMHOLTZ') *INCLUDE(BEGINSOLUT) *SET(TABLE='R1TABL') *SET(I1KORD='5') *INCLUDE(INTERPOLATE) *ENDSET *ENDIF *IF($DEF(HVP21)) *SET(SRP21) *SET(MODNAME='CMM 1') *INCLUDE(BEGINMODULE) IWORKR = $$P21IWORKR IWORKI = $$P21IWORKI NUDATA = $$P21NUDATA CALL Q6CMMN(IWORKR,IWORKI,NUDATA) *ENDSET *SET(SLP21) *SET(MODNAME='CMM 1') *INCLUDE(BEGINSOLUT) *SET(TABLE='R1TABL') *SET(I1KORD='3') *INCLUDE(INTERPOLATE) *ENDSET *ENDIF *IF($DEF(HVP22)) *SET(SRP22) *SET(MODNAME='CMM 2') *INCLUDE(BEGINMODULE) IWORKR = $$P22IWORKR IWORKI = $$P22IWORKI NUDATA = $$P22NUDATA CALL Q6CIMN(IWORKR,IWORKI,NUDATA) *ENDSET *SET(SLP22) *SET(MODNAME='CMM 2') *INCLUDE(BEGINSOLUT) *SET(TABLE='R1TABL') *SET(I1KORD='3') *INCLUDE(INTERPOLATE) *ENDSET *ENDIF *IF($DEF(HVP23)) *SET(SRP23) *SET(MODNAME='CMM 3') *INCLUDE(BEGINMODULE) IWORKR = $$P23IWORKR IWORKI = $$P23IWORKI NUDATA = $$P23NUDATA CALL Q6CSMN(IWORKR,IWORKI,NUDATA) *ENDSET *SET(SLP23) *SET(MODNAME='CMM 3') *INCLUDE(BEGINSOLUT) *SET(TABLE='R1TABL') *SET(I1KORD='3') *INCLUDE(INTERPOLATE) *ENDSET *ENDIF *IF($DEF(HVP24)) *SET(SRP24) *SET(MODNAME='MULTIGRID MG00') *INCLUDE(BEGINMODULE) METHOD = $$P24METHOD UINIT = $$P24UINIT NMIN = $$P24NMIN INEUM = $$P24INEUM ITER = $$P24ITER IGAMMA = $$P24IGAMMA CALL Q6MGSU(R1UNKN, R1GRDX, R1GRDY, METHOD, UINIT, NMIN, A INEUM, R1WORK, I6MGWK) *INCLUDE(ENDSETUP) CALL Q6MGMN(R1UNKN, ITER, IGAMMA, R1WORK, I6MGWK, R1TABL) *ENDSET *SET(SLP24) *SET(MODNAME='MULTIGRID MG00') *INCLUDE(BEGINSOLUT) *SET(TABLE='R1TABL') *SET(I1KORD='2') *INCLUDE(INTERPOLATE) *ENDSET *ENDIF *IF($DEF(HVP25)) *SET(SRP25) *SET(MODNAME='MARCHING ALGORITHM') *INCLUDE(BEGINMODULE) KGMA = $$P25KGMA CALL Q6MAMN ( KGMA ) *ENDSET *SET(SLP25) *SET(MODNAME='MARCHING ALGORITHM') *INCLUDE(BEGINSOLUT) *SET(TABLE='R1UNKN') *SET(I1KORD='4') *INCLUDE(INTERPOLATE) *ENDSET *ENDIF *IF($DEF(HVP26)) *SET(SRP26) *SET(MODNAME='DYAKANOV-CG') *INCLUDE(BEGINMODULE) MAXIT = $$P26MAXIT DEMAND = $$P26DEMAND CALL Q6DCMN (MAXIT, DEMAND) *ENDSET *SET(SLP26) *SET(MODNAME='DYAKANOV-CG') *INCLUDE(BEGINSOLUT) *SET(TABLE='R1UNKN') *SET(I1KORD='4') *INCLUDE(INTERPOLATE) *ENDSET *ENDIF *IF($DEF(HVP27)) *SET(SRP27) *SET(MODNAME='DYAKANOV-CG 4') *INCLUDE(BEGINMODULE) MAXIT = $$P27MAXIT DEMAND = $$P27DEMAND CALL Q6D4MN(MAXIT, DEMAND) *ENDSET *SET(SLP27) *SET(MODNAME='DYAKANOV-CG 4') *INCLUDE(BEGINSOLUT) *SET(TABLE='R1UNKN') *SET(I1KORD='4') *INCLUDE(INTERPOLATE) *ENDSET *ENDIF *IF($DEF(HVP28)) *SET(SRP28) *SET(MODNAME='5-POINT STAR') *INCLUDE(BEGINMODULE) *IF (L1RECT) CALL Q35PMN *ELSE CALL Q35GMN *ENDIF *ENDSET *SET(SLP28) *SET(MODNAME='5-POINT STAR') *INCLUDE(BEGINSOLUT) *IF (L1RECT) IF (L1NEWD) CALL Q35PVL *ELSE IF (L1NEWD) CALL Q35GVL *ENDIF *SET(TABLE='R1TABL') *SET(I1KORD='3') *INCLUDE(INTERPOLATE) *ENDSET *ENDIF *IF($DEF(HVP29)) *SET(SRP29) *SET(MODNAME='7-POINT 3D') *INCLUDE(BEGINMODULE) CALL Q37PMN *ENDSET *SET(SLP29) *SET(MODNAME='7-POINT 3D') *INCLUDE(BEGINSOLUT) IF (L1NEWD) CALL Q37PVL *SET(TABLE='R1TABL') *SET(I1KORD='4') *INCLUDE(INTERPOLATE) *ENDSET *ENDIF *IF($DEF(HVP30)) *SET(SRP30) *SET(MODNAME='HODIE-HELMHOLTZ') *INCLUDE(BEGINMODULE) IORDER = $$P30IORDER I1KORD = IORDER CALL Q3HHMN (IORDER) *ENDSET *SET(SLP30) *SET(MODNAME='HODIE-HELMHOLTZ') *INCLUDE(BEGINSOLUT) IF (L1NEWD) CALL Q3HHVL *SET(TABLE='R1TABL') *SET(I1KORD='I1KORD') *INCLUDE(INTERPOLATE) *ENDSET *ENDIF *IF($DEF(HVP31)) *SET(SRP31) *SET(MODNAME='HODIE-ACF') *INCLUDE(BEGINMODULE) METHOD = $$P31METHOD CALL Q3HAMN(METHOD) *ENDSET *SET(SLP31) *SET(MODNAME='HODIE-ACF') *INCLUDE(BEGINSOLUT) R0SOLV = R3HAEV(IDERIV, X, Y) *ENDSET *ENDIF *IF($DEF(HVP32)) *SET(SRP32) *SET(MODNAME='COLLOCATION') *INCLUDE(BEGINMODULE) BCP1 = $$P32BCP1 BCP2 = $$P32BCP2 DSCARE = $$P32DSCARE PTSIZE = $$P32PTSIZE GIVOPT = $$P32GIVOPT IDPLOT = $$P32IDPLOT USECRN = $$P32USECRN CALL Q3CGMN(BCP1, BCP2, DSCARE, PTSIZE, GIVOPT, IDPLOT, USECRN) *ENDSET *SET(SLP32) *SET(MODNAME='COLLOCATION') *INCLUDE(BEGINSOLUT) R0SOLV = R3CGEV(X, Y, IDERIV) *ENDSET *ENDIF *IF($DEF(HVP33)) *SET(SRP33) *SET(MODNAME='PLOT COLLOCATION POINTS') *INCLUDE(BEGINMODULE) BCP1 = $$P33BCP1 BCP2 = $$P33BCP2 DSCARE = $$P33DSCARE PTSIZE = $$P33PTSIZE GIVOPT = $$P33GIVOPT IDPLOT = $$P33IDPLOT USECRN = $$P33USECRN CALL Q7PCMN(BCP1, BCP2, DSCARE, PTSIZE, GIVOPT, IDPLOT, USECRN) *ENDSET *SET(HVP32=1) *ENDIF *IF($DEF(HVP34)) *SET(SRP34) *SET(MODNAME='HERMITE COLLOCATION') *INCLUDE(BEGINMODULE) BCP1 = $$P34BCP1 BCP2 = $$P34BCP2 *IF (L1HMBCNMIXD) CALL Q3H0MN *ELSE CALL Q3H1MN(BCP1, BCP2) *ENDIF *ENDSET *SET(SLP34) *SET(MODNAME='HERMITE COLLOCATION') *INCLUDE(BEGINSOLUT) *IF (L1HMBCNMIXD) R0SOLV = R3H0EV(X, Y, IDERIV) *ELSE R0SOLV = R3H1EV(X, Y, IDERIV) *ENDIF *ENDSET *ENDIF *IF($DEF(HVP35)) *SET(SRP35) *SET(MODNAME='INTERIOR COLLOCATION') *INCLUDE(BEGINMODULE) CALL Q3IHMN *ENDSET *SET(SLP35) *SET(MODNAME='INTERIOR COLLOCATION') *INCLUDE(BEGINSOLUT) R0SOLV = R3IHEV(X, Y, IDERIV) *ENDSET *ENDIF *IF($DEF(HVP36)) *SET(SRP36) *SET(MODNAME='SPLINE GALERKIN') *INCLUDE(BEGINMODULE) DEGREE = $$P36DEGREE NDERV = $$P36NDERV CALL Q3SGMN(DEGREE,NDERV) *ENDSET *SET(SLP36) *SET(MODNAME='SPLINE GALERKIN') *INCLUDE(BEGINSOLUT) R0SOLV = R3SGPR(X,Y,IDERIV) *ENDSET *ENDIF *IF($DEF(HVP37)) *SET(SRP37) *SET(MODNAME='AS IS') *INCLUDE(BEGINMODULE) CALL Q4AIMN *ENDSET *ENDIF *IF($DEF(HVP38)) *SET(SRP38) *SET(MODNAME='RED-BLACK') *INCLUDE(BEGINMODULE) LEVEL = $$P38LEVEL CALL Q4RBMN *ENDSET *ENDIF *IF($DEF(HVP39)) *SET(SRP39) *SET(MODNAME='NESTED DISSECTION') *INCLUDE(BEGINMODULE) NDTYPE = $$P39NDTYPE CALL Q4NDMN (NDTYPE) *ENDSET *ENDIF *IF($DEF(HVP40)) *SET(SRP40) *SET(MODNAME='REVERSE CUTHILL MCKEE') *INCLUDE(BEGINMODULE) CALL Q4RVMN *ENDSET *ENDIF *IF($DEF(HVP41)) *SET(SRP41) *SET(MODNAME='MINIMUM DEGREE') *INCLUDE(BEGINMODULE) CALL Q4MDMN *ENDSET *ENDIF *IF($DEF(HVP42)) *SET(SRP42) *SET(MODNAME='HERMITE COLLORDER') *INCLUDE(BEGINMODULE) CALL Q4HCMN *ENDSET *ENDIF *IF($DEF(HVP43)) *SET(SRP43) *SET(MODNAME='INTERIOR COLLORDER') *INCLUDE(BEGINMODULE) CALL Q4ICMN *ENDSET *ENDIF *IF($DEF(HVP44)) *SET(SRP44) *SET(MODNAME='LINPACK BAND') *INCLUDE(BEGINMODULE) CALL Q5LBSU(I5BDLW, I5BDUP) *INCLUDE(ENDSETUP) CALL Q5LBMN (I5BDLW, I5BDUP) *ENDSET *ENDIF *IF($DEF(HVP45)) *SET(SRP45) *SET(MODNAME='LINPACK SPD BAND') *INCLUDE(BEGINMODULE) CALL Q5LSSU(I5BDUP) *INCLUDE(ENDSETUP) CALL Q5LSMN(I5BDUP) *ENDSET *ENDIF *IF($DEF(HVP46)) *SET(SRP46) *SET(MODNAME='BAND GE NO PIVOTING') *INCLUDE(BEGINMODULE) CALL Q5BNSU(I5BDNR, I5BDNC, I5BDNU, I5BDNL) *INCLUDE(ENDSETUP) CALL Q5BNMN(I5BDNR, I5BDNC, I5BDNU, I5BDNL) *ENDSET *ENDIF *IF($DEF(HVP47)) *SET(SRP47) *SET(MODNAME='BAND GE') *INCLUDE(BEGINMODULE) CALL Q5BGSU(I5BGNR, I5BGNC, I5BGNU, I5BGNL) *INCLUDE(ENDSETUP) CALL Q5BGMN(I5BGNR, I5BGNC, I5BGNU, I5BGNL) *ENDSET *ENDIF *IF($DEF(HVP48)) *SET(SRP48) *SET(MODNAME='SPARSE LDLT') *INCLUDE(BEGINMODULE) CALL Q5YSMN *ENDSET *ENDIF *IF($DEF(HVP49)) *SET(SRP49) *SET(MODNAME='SPARSE LU UNCOMPRESSED') *INCLUDE(BEGINMODULE) CALL Q5YUMN *ENDSET *SET(HVP48=1) *ENDIF *IF($DEF(HVP50)) *SET(SRP50) *SET(MODNAME='SPARSE LU COMPRESSED') *INCLUDE(BEGINMODULE) CALL Q5YCMN *ENDSET *SET(HVP48=1) *ENDIF *IF($DEF(HVP51)) *SET(SRP51) *SET(MODNAME='SPARSE GE NO PIVOTING') *INCLUDE(BEGINMODULE) CALL Q5YNMN *ENDSET *SET(HVP48=1) *ENDIF *IF($DEF(HVP52)) *SET(SRP52) *SET(MODNAME='SPARSE LU PIVOTING') *INCLUDE(BEGINMODULE) MAXNZ = $$P52MAXNZ IF (MAXNZ.EQ.0) MAXNZ = 3*I1MNEQ*I1MNCO/2 CALL Q5SPSU (MAXNZ, NROWD, NCOLD) *INCLUDE(ENDSETUP) CALL Q5SPMN (NROWD, NCOLD, MAXNZ) *ENDSET *ENDIF *IF($DEF(HVP53)) *SET(SRP53) *SET(MODNAME='ENVELOPE LDU') *INCLUDE(BEGINMODULE) CALL Q5ENMN *ENDSET *SET(HVP48=1) *ENDIF *IF($DEF(HVP54)) *SET(SRP54) *SET(MODNAME='ENVELOPE LDLT') *INCLUDE(BEGINMODULE) CALL Q5ESMN *ENDSET *SET(HVP48=1) *ENDIF *IF($DEF(HVP55)) *SET(SRP55) *SET(MODNAME='SOR') *INCLUDE(BEGINMODULE) ITMAX = $$P55ITMAX LEVEL = $$P55LEVEL IADAPT = $$P55IADAPT ICASE = $$P55ICASE IDGTS = $$P55IDGTS ZETA = $$P55ZETA CME = $$P55CME SME = $$P55SME FF = $$P55FF OMEGA = $$P55OMEGA SPECR = $$P55SPECR BETAB = $$P55BETAB I5ITMT = 1 CALL Q5ITSU *INCLUDE(ENDSETUP) CALL Q5I1MN *ENDSET *ENDIF *IF($DEF(HVP56)) *SET(SRP56) *SET(MODNAME='JACOBI CG') *INCLUDE(BEGINMODULE) ITMAX = $$P56ITMAX LEVEL = $$P56LEVEL IADAPT = $$P56IADAPT ICASE = $$P56ICASE IDGTS = $$P56IDGTS ZETA = $$P56ZETA CME = $$P56CME SME = $$P56SME FF = $$P56FF OMEGA = $$P56OMEGA SPECR = $$P56SPECR BETAB = $$P56BETAB I5ITMT = 2 CALL Q5ITSU *INCLUDE(ENDSETUP) CALL Q5I2MN *ENDSET *SET(HVP55=1) *ENDIF *IF($DEF(HVP57)) *SET(SRP57) *SET(MODNAME='JACOBI SI') *INCLUDE(BEGINMODULE) ITMAX = $$P57ITMAX LEVEL = $$P57LEVEL IADAPT = $$P57IADAPT ICASE = $$P57ICASE IDGTS = $$P57IDGTS ZETA = $$P57ZETA CME = $$P57CME SME = $$P57SME FF = $$P57FF OMEGA = $$P57OMEGA SPECR = $$P57SPECR BETAB = $$P57BETAB I5ITMT = 3 CALL Q5ITSU *INCLUDE(ENDSETUP) CALL Q5I3MN *ENDSET *SET(HVP55=1) *ENDIF *IF($DEF(HVP58)) *SET(SRP58) *SET(MODNAME='REDUCED SYSTEM CG') *INCLUDE(BEGINMODULE) ITMAX = $$P58ITMAX LEVEL = $$P58LEVEL IADAPT = $$P58IADAPT ICASE = $$P58ICASE IDGTS = $$P58IDGTS ZETA = $$P58ZETA CME = $$P58CME SME = $$P58SME FF = $$P58FF OMEGA = $$P58OMEGA SPECR = $$P58SPECR BETAB = $$P58BETAB I5ITMT = 4 CALL Q5ITSU *INCLUDE(ENDSETUP) CALL Q5I4MN *ENDSET *SET(HVP55=1) *ENDIF *IF($DEF(HVP59)) *SET(SRP59) *SET(MODNAME='REDUCED SYSTEM SI') *INCLUDE(BEGINMODULE) ITMAX = $$P59ITMAX LEVEL = $$P59LEVEL IADAPT = $$P59IADAPT ICASE = $$P59ICASE IDGTS = $$P59IDGTS ZETA = $$P59ZETA CME = $$P59CME SME = $$P59SME FF = $$P59FF OMEGA = $$P59OMEGA SPECR = $$P59SPECR BETAB = $$P59BETAB I5ITMT = 5 CALL Q5ITSU *INCLUDE(ENDSETUP) CALL Q5I5MN *ENDSET *SET(HVP55=1) *ENDIF *IF($DEF(HVP60)) *SET(SRP60) *SET(MODNAME='SYMMETRIC SOR CG') *INCLUDE(BEGINMODULE) ITMAX = $$P60ITMAX LEVEL = $$P60LEVEL IADAPT = $$P60IADAPT ICASE = $$P60ICASE IDGTS = $$P60IDGTS ZETA = $$P60ZETA CME = $$P60CME SME = $$P60SME FF = $$P60FF OMEGA = $$P60OMEGA SPECR = $$P60SPECR BETAB = $$P60BETAB I5ITMT = 6 CALL Q5ITSU *INCLUDE(ENDSETUP) CALL Q5I6MN *ENDSET *SET(HVP55=1) *ENDIF *IF($DEF(HVP61)) *SET(SRP61) *SET(MODNAME='SYMMETRIC SOR SI') *INCLUDE(BEGINMODULE) ITMAX = $$P61ITMAX LEVEL = $$P61LEVEL IADAPT = $$P61IADAPT ICASE = $$P61ICASE IDGTS = $$P61IDGTS ZETA = $$P61ZETA CME = $$P61CME SME = $$P61SME FF = $$P61FF OMEGA = $$P61OMEGA SPECR = $$P61SPECR BETAB = $$P61BETAB I5ITMT = 7 CALL Q5ITSU *INCLUDE(ENDSETUP) CALL Q5I7MN *ENDSET *SET(HVP55=1) *ENDIF *IF($DEF(HVP62)) *SET(SRP62) *SET(MODNAME='MAX') *INCLUDE(BEGINMODULE) *IF (L1RECT) *IF (L1TWOD) CALL Q8MXR2($$FCN, '$$FCN ', $$NX, $$NY) *ELSE CALL Q8MXR3($$FCN, '$$FCN ', $$NX, $$NY, $$NZ) *ENDIF *ELSE CALL Q8MXNR($$FCN, '$$FCN ', $$NX, $$NY) *ENDIF *ENDSET *ENDIF *IF($DEF(HVP63)) *SET(SRP63) *SET(MODNAME='RMS') *INCLUDE(BEGINMODULE) *IF (L1RECT) *IF (L1TWOD) CALL Q8MXR2($$FCN, '$$FCN ', $$NX, $$NY) *ELSE CALL Q8MXR3($$FCN, '$$FCN ', $$NX, $$NY, $$NZ) *ENDIF *ELSE CALL Q8MXNR($$FCN, '$$FCN ', $$NX, $$NY) *ENDIF *ENDSET *ENDIF *IF($DEF(HVP64)) *SET(SRP64) *SET(MODNAME='NORM') *INCLUDE(BEGINMODULE) *IF (L1RECT) *IF (L1TWOD) CALL Q8MXR2($$FCN, '$$FCN ', $$NX, $$NY) *ELSE CALL Q8MXR3($$FCN, '$$FCN ', $$NX, $$NY, $$NZ) *ENDIF *ELSE CALL Q8MXNR($$FCN, '$$FCN ', $$NX, $$NY) *ENDIF *ENDSET *ENDIF *IF($DEF(HVP65)) *SET(SRP65) *SET(MODNAME='TABLE') *INCLUDE(BEGINMODULE) *IF (L1RECT) *IF (L1TWOD) CALL Q8TBR2($$FCN, '$$FCN ', $$NX, $$NY) *ELSE CALL Q8TBR3($$FCN, '$$FCN ', $$NX, $$NY, $$NZ) *ENDIF *ELSE CALL Q8TBNR($$FCN, '$$FCN ', $$NX, $$NY) *ENDIF *ENDSET *ENDIF *IF($DEF(HVP66)) *SET(SRP66) *SET(MODNAME='SUMMARY') *INCLUDE(BEGINMODULE) *IF (L1RECT) *IF (L1TWOD) CALL Q8SMR2($$FCN, '$$FCN ', $$NX, $$NY) *ELSE CALL Q8SMR3($$FCN, '$$FCN ', $$NX, $$NY, $$NZ) *ENDIF *ELSE CALL Q8SMNR($$FCN, '$$FCN ', $$NX, $$NY) *ENDIF *ENDSET *ENDIF *IF($DEF(HVP67)) *SET(SRP67) *SET(MODNAME='TABLE-EQUATIONS') *INCLUDE(BEGINMODULE) CALL Q8TEMN *ENDSET *ENDIF *IF($DEF(HVP68)) *SET(SRP68) *SET(MODNAME='TABLE-PROBLEM') *INCLUDE(BEGINMODULE) CALL Q8TPMN *ENDSET *ENDIF *IF($DEF(HVP69)) *SET(SRP69) *SET(MODNAME='TABLE-INDEXES') *INCLUDE(BEGINMODULE) CALL Q8TIMN *ENDSET *ENDIF *IF($DEF(HVP70)) *SET(SRP70) *SET(MODNAME='TABLE-UNKNOWN') *INCLUDE(BEGINMODULE) CALL Q8TUMN *ENDSET *ENDIF *IF($DEF(HVP71)) *SET(SRP71) *SET(MODNAME='PLOT-DOMAIN') *INCLUDE(BEGINMODULE) *IF (L1RECT) CALL Q8PDR2 *ELSE CALL Q8PDNR *ENDIF *ENDSET *ENDIF *IF($DEF(HVP72)) *SET(SRP72) *SET(MODNAME='TABLE-DOMAIN') *INCLUDE(BEGINMODULE) CALL Q8TDNR *ENDSET *ENDIF *IF($DEF(HVP73)) *SET(SRP73) *SET(MODNAME='TABLE BOUNDARY') *INCLUDE(BEGINMODULE) CALL Q8TRNR *ENDSET *ENDIF *IF($DEF(HVP74)) *SET(SRP74) *SET(MODNAME='PLOT') *INCLUDE(BEGINMODULE) *IF (L1RECT) CALL Q8PLR2($$FCN, '$$FCN ', $$NX, $$NY ) *ELSE CALL Q8PLNR($$FCN, '$$FCN ', $$NX, $$NY ) *ENDIF *ENDSET *ENDIF *IF($DEF(HVP75)) *SET(SRP75) *SET(MODNAME='DATA') *INCLUDE(BEGINMODULE) *IF(L1TWOD) *IF(L1RECT) CALL Q8DBR2($I1MEMY) *ELSE CALL Q8DBNR($I1MEMY) *ENDIF *ELSE CALL Q8DBR3($I1MEMY) *ENDIF *ENDSET *ENDIF *IF($DEF(HVP5)) *APPEND(MDECLARE) COMMON / C7DFXX / R7DFXX($I7DFNF) COMMON / C7DFYY / R7DFYY($I7DFNF) LOGICAL EXTER *ENDAPP *ENDIF *IF($DEF(HVP9)) *APPEND(MDECLARE) COMMON / C7RMHS / R7RMHX, R7RMHY, R7RMHZ *ENDAPP *ENDIF *IF($DEF(HVP10)) *APPEND(MDECLARE) COMMON / C6BLSU / R6BLDM(32), L6BLIC, L6BLSU COMMON / C7RBSU / L7RBFL LOGICAL L6BLIC, L6BLSU, L7RBFL *ENDAPP *ENDIF *IF($DEF(HVP11)) *APPEND(MDECLARE) COMMON / C6HBIV / I6HBCF(4,$I0NGRX,$I0NGRY) COMMON / C6HBRV / R6HBCF(4,$I0NGRX,$I0NGRY) COMMON / C7RHSU / L7RHFL LOGICAL L7RHFL *ENDAPP *ENDIF *IF($DEF(HVP24)) *APPEND(MDECLARE) INTEGER I6MGWK($I6MGWK), UINIT *ENDAPP *ENDIF *IF($DEF(HVP28)) *APPEND(MDECLARE) COMMON / C35PNU / I35PNU($I1NGRX,$I1NGRY) *IF (L1RECT) *ELSE COMMON / C35GBN / I35GBN($I1MBPT) *ENDIF *ENDAPP *ENDIF *IF($DEF(HVP30)) *APPEND(MDECLARE) INTEGER I3HHNU($I1NGRX,$I1NGRY) COMMON / C3HHNU / I3HHNU *ENDAPP *ENDIF *IF($DEF(HVP32)) *APPEND(MDECLARE) COMMON /C3CGNE/ I3CGNE($I3CGDM) INTEGER GIVOPT LOGICAL USECRN *ENDAPP *ENDIF *IF($DEF(HVP34)) *APPEND(MDECLARE) *IF (L1HMBCNMIXD) COMMON /C3H0CM/ NUMUNK(4, $I1NGRX, $I1NGRY) *ENDIF *ENDAPP *ENDIF *IF($DEF(HVP35)) *APPEND(MDECLARE) COMMON /C3IHNU/ R3IHNU(4, $I1NGRX, $I1NGRY) COMMON /C3IHUN/ R3IHUN(4, $I1NGRX, $I1NGRY) *ENDAPP *ENDIF *IF($DEF(HVP36)) *APPEND(MDECLARE) INTEGER DEGREE *ENDAPP *ENDIF *IF($DEF(HVP48)) *APPEND(MDECLARE) COMMON / C5YSCO / I5YSCO($I1MNEQ) *ENDAPP *ENDIF *IF($DEF(HVP55)) *APPEND(MDECLARE) COMMON / C5ITPK / RPARM(12),ZETA,CME,SME,FF,OMEGA,SPECR,BETAB, B IPARM(12),ITMAX,LEVEL,IADAPT,ICASE,IDGTS, C NBLACK,I5ITMT COMMON / C5ITIW / IWKSP($I1MNEQ) *ENDAPP *ENDIF *IF($DEF(HVP75)) *APPEND(MDECLARE) COMMON / C8DBTI / R8DBTI(3) *ENDAPP *ENDIF *IF (PPDEBUG) *OPTION(LISTI=.TRUE.) *OPTION(LISTO=.TRUE.) *ENDIF *OPTION(LFORT=.TRUE.) *OPTION(L1TRIP=.FALSE.) C PROGRAM ELPK *INCLUDE(INITOPT) C============ PROBLEM DEFINITION INTERFACE C COMMON / C1RVPR / R1CUXX, R1CUXY, R1CUYY, R1CCUX, R1CCUY, A R1CCCU, R1CUZZ, R1CUXZ, R1CUYZ, R1CCUZ, B R1UNQX, R1UNQY, R1UNQZ, R1UNQU COMMON / C1IVPR / I1NBND COMMON / C1LVPR / L1ARCC, L1CLKW, L1CRST, L1CSTB, L1CSTC, A L1DRCH, L1HMBC, L1HMEQ, L1HOLE, L1LAPL, B L1MIXD, L1NEUM, L1NUNQ, L1POIS, L1RECT, C L1SELF, L1TWOD LOGICAL L1ARCC, L1CLKW, L1CRST, L1CSTB, L1CSTC, A L1DRCH, L1HMBC, L1HMEQ, L1HOLE, L1LAPL, B L1MIXD, L1NEUM, L1NUNQ, L1POIS, L1RECT, C L1SELF, L1TWOD COMMON / C1LVBC / L1PRDC, L1PRDX, L1PRDY, L1PRDZ LOGICAL L1PRDC, L1PRDX, L1PRDY, L1PRDZ COMMON / C1BCST / I1BCST(4,$I0BCST) COMMON / C1BCTY / I1BCTY($I0BCTY) COMMON / C1CFST / I1CFST(10) *IF(L1RECT) *ELSE C C============ DISCRETE DOMAIN INTERFACE C EXTERNAL Q1BDRY COMMON / C1BNGH / I1BNGH($I0BNGH) COMMON / C1BRNG / R1BRNG(2,$I0BRNG) COMMON / C1BGRD / I1BGRD($I0BGRD) COMMON / C1BPAR / R1BPAR($I0BPAR) COMMON / C1BPTY / I1BPTY($I0BPTY) COMMON / C1GRTY / I1GRTY($I0GRTY,$I0GRT2) COMMON / C1PECE / I1PECE($I0PECE) COMMON / C1XBND / R1XBND($I0XBND) COMMON / C1YBND / R1YBND($I0YBND) *ENDIF COMMON / C1GRDX / R1GRDX($I0GRDX) COMMON / C1GRDY / R1GRDY($I0GRDY) *IF(L1TWOD) *ELSE COMMON / C1GRDZ / R1GRDZ($I0GRDZ) *ENDIF COMMON / C1IVGR / I1NGRX, I1NGRY, I1NGRZ, I1NBPT, I1MBPT, A I1PACK COMMON / C1LVGR / L1UNFG, L1UNFX, L1UNFY, L1UNFZ LOGICAL L1UNFG, L1UNFX, L1UNFY, L1UNFZ COMMON / C1RVGR / R1AXGR, R1AYGR, R1AZGR, R1BXGR, R1BYGR, A R1BZGR, R1HXGR, R1HYGR, R1HZGR *IF (HAVEDIS) C C============ DISCRETE OPERATOR INTERFACE C COMMON / C1BBBB / R1BBBB($I0BBBB) COMMON / C1COEF / R1COEF($I0COEF,$I0COE2) COMMON / C1IDCO / I1IDCO($I0IDCO,$I0IDC2) COMMON / C1IVDI / I1NEQN, I1MNEQ, I1NCOE, I1MNCO COMMON / C1LVDI / L1SYMM LOGICAL L1SYMM C C============ EQUATION/UNKNOWN REORDERING INTERFACE C COMMON / C1IVIN / I1MEND, I1MUND COMMON / C1LVIN / L1ASIS, L1RDBL LOGICAL L1ASIS, L1RDBL COMMON / C1ENDX / I1ENDX($I0ENDX) COMMON / C1UNDX / I1UNDX($I0UNDX) C C============ ALGEBRAIC EQUATION SOLUTION INTERFACE C *ENDIF COMMON / C1IVSO / I1MUNK COMMON / C1LVSO / L1UINI LOGICAL L1UINI COMMON / C1UNKN / R1UNKN($I0UNKN) C C============ OTHER GLOBAL CONTROL VARIABLES C COMMON / C1IVCN / I1LEVL, I1PAGE, I1INPT, I1OUTP, I1SCRA, A I1KWRK, I1KORD COMMON / C1LVCN / L1TIME, L1FATL, L1NEWD LOGICAL L1TIME, L1FATL, L1NEWD COMMON / C1RNRM / R1NRM1, R1NRM2, R1NRMI COMMON R1WORK($I0KWRK) COMMON / C1RVBS / R1BSTP($I0BSTP) *IF(NEEDR1TABL) COMMON / C1TABL / R1TABL($I0TABL, $I0TAB2, $I0TAB3) *ENDIF COMMON / C0IVCN / I0GROT, I0MODN, I0TIME INTEGER I0GROT(6) COMMON / C0LVCN / L0HVDI, L0HVAN LOGICAL L0HVDI, L0HVAN *INCLUDE(GLOBAL) *IF($DEF(EXTERNALS)) EXTERNAL $EXTERNALS *ENDIF *INCLUDE(DECLARE) C *IF (NOEXECUTION) STOP *ENDIF I1INPT = I1MACH(1) I1OUTP = I1MACH(2) I1SCRA = 1 I0TIME = 2 PI = 4.*ATAN(1.) R1EPSM = R1MACH(3) *IF(L1TIME) CALL Q1TIME(R0BEGT) *ENDIF *DO(I=1,I1NBND) I1BCST(1,$I) = $LIST(I1BCST) *ENDDO *IF(L1RECT) R1AXGR = $LIST(AX) R1BXGR = $LIST(AX) R1AYGR = $LIST(AY) R1BYGR = $LIST(AY) *IF(L1TWOD) *ELSE R1AZGR = $LIST(AZ) R1BZGR = $LIST(AZ) *ENDIF CALL Q0BCTP( $LIST(XROT),$LIST(XROT),$LIST(I1BCTY),$LIST(I1BCTY), A $LIST(YROT),$LIST(YROT),$LIST(I1BCTY),$LIST(I1BCTY), *IF(L1TWOD) B 0,0,0,0) *ELSE C $LIST(ZROT),$LIST(ZROT),$LIST(I1BCTY),$LIST(I1BCTY)) *ENDIF *ELSE I1MBPT = $I0MBPT *DO (I=1,I1NBND) I1BCTY($I) = $LIST(I1BCTY) *ENDDO *ENDIF CALL Q0INIT( $L1CLKW, $L1CRST, $L1CSTB, $L1CSTC, A $L1DRCH, $L1HMBC, $L1HMEQ, $L1HOLE, $L1LAPL, B $L1MIXD, $L1NEUM, $L1POIS, $L1RECT, $L1SELF, C $L1TWOD, $I1NBND, $L1TIME, $I0UNDX, D $I0ENDX, $I0MNCO, $I0MNEQ, $I0UNKN, E $I0KWRK, $I1CF2D, $I1CF3D, $L1PRDC, $L1PRDX, F $L1PRDY, $L1PRDZ ) *IF($L1CSTC) *IF(L1TWOD) CALL Q1PCOE(0.0, 0.0, R1CUXX) *ELSE CALL Q1PCOE(0.0, 0.0, 0.0, R1CUXX) *ENDIF *ENDIF C *IF(PLOTS) CALL PLOTS *ENDIF *INCLUDE(SRCALLS) *IF(PLOTS) CALL PLOT (0.0, 0.0, 999) *ENDIF *IF (L1TIME) *SET(MODNAME='TOTAL TIME') R0TBEG = R0BEGT *INCLUDE(ENDMODULE) CALL Q0TIME *ENDIF STOP END *IF (L1TWOD) SUBROUTINE Q1PCOE(X, Y, R0CPDE) *ELSE SUBROUTINE Q1PCOE(X, Y, Z, R0CPDE) *ENDIF C C ======= DEFINE EQUATION COEFFICIENTS C *INCLUDE(GLOBAL) *IF (L1TWOD) REAL R0CPDE(6) *ELSE REAL R0CPDE(10) *ENDIF C R0CPDE( 1) = $CUXX R0CPDE( 2) = $CUXY R0CPDE( 3) = $CUYY R0CPDE( 4) = $CUX R0CPDE( 5) = $CUY R0CPDE( 6) = $CU *IF(L1TWOD) *ELSE R0CPDE( 7) = $CUZZ R0CPDE( 8) = $CUXZ R0CPDE( 9) = $CUYZ R0CPDE(10) = $CUZ *ENDIF C RETURN END *IF (L1TWOD) REAL FUNCTION R1PRHS(X, Y) *ELSE REAL FUNCTION R1PRHS(X, Y, Z) *ENDIF C C ======= DEFINE THE RIGHT SIDE OF THE EQUATION C *INCLUDE(GLOBAL) *IF($DEF(RMFCN)) EXTERNAL $RMFCN *ENDIF R1PRHS = $PDERHS *IF($DEF(RMPRHS)) R1PRHS = R1PRHS - $RMPRHS *ENDIF C RETURN END *IF ($L1TWOD) SUBROUTINE Q1BCOE(I0SIDE, X, Y, R0CBC) *ELSE SUBROUTINE Q1BCOE(I0SIDE, X, Y, Z, R0CBC) *ENDIF C C ======= DEFINE THE BOUNDARY CONDITIONS C *INCLUDE(GLOBAL) *IF (L1TWOD) REAL R0CBC(3) *ELSE REAL R0CBC(4) *ENDIF COMMON / C0IVCN / I0GROT, I0MODN, I0TIME INTEGER I0GROT(6) C *SET (LABEL=10000) *SET (L=.TRUE.) *DO (I=1,I1NBND) *IF (L) *SET (BGOTO='$LABEL') *ELSE *SET (BGOTO='$BGOTO,$LABEL') *ENDIF *SET (L=.FALSE.) *ENDDO *IF (L1RECT) I0BCND = I0GROT(I0SIDE) *ELSE I0BCND = I0SIDE *ENDIF GO TO ($BGOTO), I0BCND *SET (LABEL=10000) *DO (I=1,I1NBND) $LABEL CONTINUE R0CBC(1) = $LIST(R0CBC) R0CBC(2) = $LIST(R0CBC) R0CBC(3) = $LIST(R0CBC) *IF (L1TWOD) *ELSE R0CBC(4) = $LIST(R0CBC) *ENDIF GO TO 9999 C *ENDDO C 9999 CONTINUE RETURN END *IF ($L1TWOD) REAL FUNCTION R1BRHS(I0SIDE, X, Y) *ELSE REAL FUNCTION R1BRHS(I0SIDE, X, Y, Z) *ENDIF C C ======= DEFINE THE BOUNDARY CONDITIONS C *INCLUDE(GLOBAL) COMMON / C0IVCN / I0GROT, I0MODN, I0TIME INTEGER I0GROT(6) *IF($DEF(RMFCN)) EXTERNAL $RMFCN *ENDIF C *SET (LABEL=10000) *SET (L=.TRUE.) *DO (I=1,I1NBND) *IF (L) *SET (BGOTO='$LABEL') *ELSE *SET (BGOTO='$BGOTO,$LABEL') *ENDIF *SET (L=.FALSE.) *ENDDO *IF (L1RECT) I0BCND = I0GROT(I0SIDE) *ELSE I0BCND = I0SIDE *ENDIF GO TO ($BGOTO), I0BCND *SET (LABEL=10000) *DO (I=1,I1NBND) $LABEL CONTINUE R1BRHS = $LIST(R1BRHS) GO TO 9999 C *ENDDO C 9999 CONTINUE *IF($DEF(RMBRHS)) R1BRHS = R1BRHS - $RMBRHS *ENDIF RETURN END *IF (L1RECT) *ELSE SUBROUTINE Q1BDRY(R0PARM, X, Y, I0PECE) C C ======= DEFINE THE BOUNDARY PIECES C *INCLUDE(GLOBAL) GO TO ($BGOTO), I0PECE *SET (LABEL=10000) *DO (I=1,I1NBND) $LABEL CONTINUE $LIST(Q1BDRY) GO TO 9999 C *ENDDO 9999 RETURN END *ENDIF *IF($DEF(R0SOLV)) *IF(L1TWOD) REAL FUNCTION R0SOLV(IDERIV, X, Y) *ELSE REAL FUNCTION R0SOLV(IDERIV, X, Y, Z) *ENDIF C C ======= RETURN THE SOLUTION AT THE SPECIFIED POINT C COMMON / C1UNKN / R1UNKN($I0UNKN) *IF(NEEDR1TABL) COMMON / C1TABL / R1TABL($I0TABL, $I0TAB2, $I0TAB3) *ENDIF COMMON / C1IVCN / I1LEVL, I1PAGE, I1INPT, I1OUTP, I1SCRA, A I1KWRK, I1KORD COMMON / C1LVCN / L1TIME, L1FATL, L1NEWD LOGICAL L1TIME, L1FATL, L1NEWD COMMON / C0IVCN / I0GROT, I0MODN, I0TIME INTEGER I0GROT(6) COMMON / C0LVCN / L0HVDI, L0HVAN LOGICAL L0HVDI, L0HVAN *IF($DEF(RMFCN)) EXTERNAL $RMFCN *ENDIF C IF (.NOT. L0HVAN) CALL Q0ERPP(3) *SET (LABEL=10000) *SET (L=.TRUE.) *SET (BGOTO='9999') *DO (I=1,I0MODN) *IF (L) *SET (BGOTO='$LABEL') *ELSE *SET (BGOTO='$BGOTO,$LABEL') *ENDIF *SET (L=.FALSE.) *ENDDO GO TO ($BGOTO), I0MODN *SET (LABEL=10000) *DO (I=1,I0MODN) $LABEL CONTINUE $LIST(R0SOLV) GO TO 9999 C *ENDDO C 9999 CONTINUE *IF($DEF(RMSOLV)) R0SOLV = R0SOLV + $RMSOLV *ENDIF L1NEWD = .FALSE. RETURN END *ENDIF *IF(L1TWOD) *ELSE REAL FUNCTION UXX(X, Y, Z) UXX = R0SOLV(1, X, Y, Z) RETURN END REAL FUNCTION UXY(X, Y, Z) UXY = R0SOLV(2, X, Y, Z) RETURN END REAL FUNCTION UYY(X, Y, Z) UYY = R0SOLV(3, X, Y, Z) RETURN END REAL FUNCTION UX(X, Y, Z) UX = R0SOLV(4, X, Y, Z) RETURN END REAL FUNCTION UY(X, Y, Z) UY = R0SOLV(5, X, Y, Z) RETURN END REAL FUNCTION U(X, Y, Z) U = R0SOLV(6, X, Y, Z) RETURN END REAL FUNCTION UZZ(X, Y, Z) UZZ = R0SOLV(7, X, Y, Z) RETURN END REAL FUNCTION UXZ(X, Y, Z) UXZ = R0SOLV(8, X, Y, Z) RETURN END REAL FUNCTION UYZ(X, Y, Z) UYZ = R0SOLV(9, X, Y, Z) RETURN END REAL FUNCTION UZ(X, Y, Z) UZ = R0SOLV(10, X, Y, Z) RETURN END REAL FUNCTION ERROR(X, Y, Z) ERROR = TRUE(X, Y, Z) - R0SOLV(6, X, Y, Z) RETURN END REAL FUNCTION RESIDU(X, Y, Z) RESIDU = R1RSR3(X, Y, Z) RETURN END REAL FUNCTION ZERO(X, Y, Z) ZERO = 0.0 RETURN END *ENDIF *END SHAR_EOF fi # end of overwriting check if test -f 'ellpack.out' then echo shar: will not over-write existing file "'ellpack.out'" else cat << SHAR_EOF > 'ellpack.out' C PROGRAM ELPK C C============ PROBLEM DEFINITION INTERFACE C COMMON / C1RVPR / R1CUXX, R1CUXY, R1CUYY, R1CCUX, R1CCUY, A R1CCCU, R1CUZZ, R1CUXZ, R1CUYZ, R1CCUZ, B R1UNQX, R1UNQY, R1UNQZ, R1UNQU COMMON / C1IVPR / I1NBND COMMON / C1LVPR / L1ARCC, L1CLKW, L1CRST, L1CSTB, L1CSTC, A L1DRCH, L1HMBC, L1HMEQ, L1HOLE, L1LAPL, B L1MIXD, L1NEUM, L1NUNQ, L1POIS, L1RECT, C L1SELF, L1TWOD LOGICAL L1ARCC, L1CLKW, L1CRST, L1CSTB, L1CSTC, A L1DRCH, L1HMBC, L1HMEQ, L1HOLE, L1LAPL, B L1MIXD, L1NEUM, L1NUNQ, L1POIS, L1RECT, C L1SELF, L1TWOD COMMON / C1LVBC / L1PRDC, L1PRDX, L1PRDY, L1PRDZ LOGICAL L1PRDC, L1PRDX, L1PRDY, L1PRDZ COMMON / C1BCST / I1BCST(4,1) COMMON / C1BCTY / I1BCTY(1) COMMON / C1CFST / I1CFST(10) COMMON / C1GRDX / R1GRDX(1) COMMON / C1GRDY / R1GRDY(1) COMMON / C1IVGR / I1NGRX, I1NGRY, I1NGRZ, I1NBPT, I1MBPT, A I1PACK COMMON / C1LVGR / L1UNFG, L1UNFX, L1UNFY, L1UNFZ LOGICAL L1UNFG, L1UNFX, L1UNFY, L1UNFZ COMMON / C1RVGR / R1AXGR, R1AYGR, R1AZGR, R1BXGR, R1BYGR, A R1BZGR, R1HXGR, R1HYGR, R1HZGR COMMON / C1IVSO / I1MUNK COMMON / C1LVSO / L1UINI LOGICAL L1UINI COMMON / C1UNKN / R1UNKN(1) C C============ OTHER GLOBAL CONTROL VARIABLES C COMMON / C1IVCN / I1LEVL, I1PAGE, I1INPT, I1OUTP, I1SCRA, A I1KWRK, I1KORD COMMON / C1LVCN / L1TIME, L1FATL, L1NEWD LOGICAL L1TIME, L1FATL, L1NEWD COMMON / C1RNRM / R1NRM1, R1NRM2, R1NRMI COMMON R1WORK(1) COMMON / C1RVBS / R1BSTP(1) COMMON / C0IVCN / I0GROT, I0MODN, I0TIME INTEGER I0GROT(6) COMMON / C0LVCN / L0HVDI, L0HVAN LOGICAL L0HVDI, L0HVAN COMMON / C1RVGL / R1EPSG, R1EPSM, PI C C I1INPT = I1MACH(1) I1OUTP = I1MACH(2) I1SCRA = 1 I0TIME = 2 PI = 4.*ATAN(1.) R1EPSM = R1MACH(3) I1BCST(1,1) = 1 R1AXGR = 0.0 R1BXGR = 1.0 R1AYGR = 0.0 R1BYGR = 1.0 CALL Q0BCTP( 1,2,1,1, A 3,4,1,1, B 0,0,0,0) CALL Q0INIT( .FALSE., .FALSE., .FALSE., .TRUE., A .TRUE., .TRUE., .TRUE., .FALSE., .FALSE., B .FALSE., .TRUE., .FALSE., .TRUE., .FALSE., C .TRUE., 1, .FALSE., 1, D 1, 1, 1, 1, E 1, 1, 0, .TRUE., .TRUE., F .TRUE., .TRUE. ) CALL Q1PCOE(0.0, 0.0, R1CUXX) C C STOP END SUBROUTINE Q1PCOE(X, Y, R0CPDE) C C ======= DEFINE EQUATION COEFFICIENTS C COMMON / C1RVGL / R1EPSG, R1EPSM, PI REAL R0CPDE(6) C R0CPDE( 1) = 0.0 R0CPDE( 2) = 0.0 R0CPDE( 3) = 0.0 R0CPDE( 4) = 0.0 R0CPDE( 5) = 0.0 R0CPDE( 6) = 0.0 C RETURN END REAL FUNCTION R1PRHS(X, Y) C C ======= DEFINE THE RIGHT SIDE OF THE EQUATION C COMMON / C1RVGL / R1EPSG, R1EPSM, PI R1PRHS = 0.0 C RETURN END SUBROUTINE Q1BCOE(I0SIDE, X, Y, R0CBC) C C ======= DEFINE THE BOUNDARY CONDITIONS C COMMON / C1RVGL / R1EPSG, R1EPSM, PI REAL R0CBC(3) COMMON / C0IVCN / I0GROT, I0MODN, I0TIME INTEGER I0GROT(6) C I0BCND = I0GROT(I0SIDE) GO TO (10001), I0BCND 10001 CONTINUE R0CBC(1) = 1.0 R0CBC(2) = 0.0 R0CBC(3) = 0.0 GO TO 9999 C C 9999 CONTINUE RETURN END REAL FUNCTION R1BRHS(I0SIDE, X, Y) C C ======= DEFINE THE BOUNDARY CONDITIONS C COMMON / C1RVGL / R1EPSG, R1EPSM, PI COMMON / C0IVCN / I0GROT, I0MODN, I0TIME INTEGER I0GROT(6) C I0BCND = I0GROT(I0SIDE) GO TO (10001), I0BCND 10001 CONTINUE R1BRHS = TRUE(X,Y) GO TO 9999 C C 9999 CONTINUE RETURN END REAL FUNCTION R0SOLV(IDERIV, X, Y) C C ======= RETURN THE SOLUTION AT THE SPECIFIED POINT C COMMON / C1UNKN / R1UNKN(1) COMMON / C1IVCN / I1LEVL, I1PAGE, I1INPT, I1OUTP, I1SCRA, A I1KWRK, I1KORD COMMON / C1LVCN / L1TIME, L1FATL, L1NEWD LOGICAL L1TIME, L1FATL, L1NEWD COMMON / C0IVCN / I0GROT, I0MODN, I0TIME INTEGER I0GROT(6) COMMON / C0LVCN / L0HVDI, L0HVAN LOGICAL L0HVDI, L0HVAN C IF (.NOT. L0HVAN) CALL Q0ERPP(3) GO TO (10001), I0MODN 10001 CONTINUE R1QD2I(X, Y, R1TABL, IDERIV) GO TO 9999 C C 9999 CONTINUE L1NEWD = .FALSE. RETURN END SHAR_EOF fi # end of overwriting check if test -f 'exhaustive' then echo shar: will not over-write existing file "'exhaustive'" else cat << SHAR_EOF > 'exhaustive' *COMMENT FILE 5. TEST CASE. EXHAUSTIVE TEST OF ALL FACILITIES. THIS IS A TEST FILE FOR THE TEMPLATE PROCESSOR. IT TESTS NEARLY ALL THE DIRECTIVE AND MACRO PROCESSING FACILITIES OF THE TEMPLATE PROCESSOR. THE SIMPLER FEATURES OF THE PROCESSOR ARE WORKING IF THE OUTPUT APPEARS AS BELOW. ERROR MESSAGES WILL BE PRINTED IF ANY OF THE MORE COMPLEX FEATURES FAIL TO WORK. CORRECT OUTPUT FROM TEST FILE: I11 = 11 I21 = 21 I2 = 2 TRUE = .TRUE. FALSE = .FALSE. AB = AB ITEMP = 11 LINE 1 LINE 2 A = B A = C X(1) = Y(1) LABEL(1) = 10001 X(2) = Y(2) LABEL(2) = 10002 X(3) = Y(3) LABEL(3) = 10003 X(7) = Y(7) LINE(1,11) = '**AB**' LINE(1,13) = '**CD**' LINE(2,11) = '**AB**' LINE(2,13) = '**CD**' X(1,5) = 0.15 X(1,10) = 0.110 X(2,5) = 0.25 X(2,10) = 0.210 X(1) = Y(1) LABEL(1) = 10001 X(2) = Y(2) LABEL(2) = 10002 X(3) = Y(3) LABEL(3) = 10003 THESE ARE THE LAST TWO LINES OF THIS INCLUDED TEXT. IJUMPI = IJUMP(I) GO TO (10001, 10002, 10003, 10004, 10005, 10006, 10007, 10008, Z 10009, 10010, 10011, 10012, 10013, 10014, 10015, 10016, 10017) Z , IJUMPI *ENDCOM *OPTION ( LFORT = .TRUE. ) *OPTION ( LBREAK = .TRUE. ) *OPTION ( LCOL1 = .FALSE.) *OPTION ( L1TRIP = .TRUE. ) *COMMENT TEST VARIOUS FORMS OF THE SET STATEMENT *ENDCOM *SET ( I11 = 11 ) *SET ( I21 = 21 ) *SET ( I2 = 2 ) *SET ( TRUE = .TRUE. ) *SET ( FALSE = .FALSE. ) *SET ( AB = 'AB' ) *SET ( CD = 'CD' ) *SET WX = 'WX' YZ = 'YZ' ITEMP = I11 LINES = LINE 1 LINE 2 * *ENDSET I11 = $I11 *OPTION ( CDIR = '+' ) +OPTION ( CSUB = '&' ) I21 = &(I21) I2 = &I2 TRUE = &(TRUE) +OPTION ( CSUB = '$' ) +OPTION ( CDIR = '*' ) FALSE = $FALSE AB = $(AB) ITEMP = $ITEMP *INCLUDE ( LINES ) *COMMENT TEST ONE-LINE IF STATEMENTS *ENDCOM *SET ( L1 = .TRUE. ) *SET ( L2 = .FALSE. ) *SET ( A = 'B' ) A = $A *IF ( L1 ) *SET ( A = 'C' ) A = $A *COMMENT TEST NESTED IF STATEMENTS *ENDCOM *IF ( L2 ) *IF ( L1 ) *SET ( X = 'Y' ) *ELSE *IF ( L1 ) *SET ( X = 'Z' ) *ENDIF *SET TEST = 'X = $X' ANS = 'X = Z' *ENDSET *IF (ANS = TEST) *ELSE ++++++++ERROR IN NESTED IF TEST *ENDIF *COMMENT TEST MORE COMPLEX NESTING *ENDCOM *IF ( L1 ) *IF ( L2 ) *SET ( P = 'Q' ) *IF ( L1 ) *IF ( L2 ) *SET ( P = 'Q' ) *ELSE *IF ( L2 ) *SET ( P = 'Q' ) *ENDIF *IF ( L1 ) *SET ( P = 'R' ) *ELSE *IF ( L2 ) *SET ( P = 'S' ) *IF ( L1 ) *IF ( L2 ) *SET ( P = 'S' ) *ELSE *IF ( L2 ) *SET ( P = 'S' ) *ENDIF *IF ( L1 ) *SET ( P = 'T' ) *ENDIF *SET TEST = 'P = $P' ANS = 'P = R' *ENDSET *IF (ANS = TEST) *ELSE ++++++++ERROR IN COMPLEX IF TEST *ENDIF *COMMENT TEST EXPRESSION IN IF STATEMENT *ENDCOM *SET ( E = 10 ) *SET ( F = 20 ) *IF ( E = F ) *SET ( U = 'V' ) *ELSE *SET ( U = 'W' ) *ENDIF *SET TEST1= 'U = $U' ANS1 = 'U = W' *ENDSET *IF ( F = 20 ) *SET ( U = 'V' ) *SET TEST2= 'U = $U' ANS2 = 'U = V' *ENDSET *IF (ANS1 = TEST1) *ELSE ++++++++ERROR IN EXPRESSION-IN-IF TEST *ENDIF *IF (ANS2 = TEST2) *ELSE ++++++++ERROR IN EXPRESSION-IN-IF TEST *ENDIF *COMMENT TEST THE CONTINUATION CHARACTER *ENDCOM *SET ( LONG $+ = 'STRING 1' ) *SET ( TEST1 ) LONG = $LONG *ENDSET *SET ( LONG = $+ 'STRING 2' ) *SET ( TEST2 ) LONG = $LONG *ENDSET *SET ( LONG = 'STRING$+ 3' ) *SET ( TEST3 ) LONG = $LONG *ENDSET *SET ( LONG = 'STRING 4'$+ ) *SET ( TEST4 ) LONG = $LONG *ENDSET *SET ANS1 = LONG = STRING 1 * ANS2 = LONG = STRING 2 * ANS3 = LONG = STRING 3 * ANS4 = LONG = STRING 4 * *ENDSET *IF(ANS1 = TEST1) *ELSE ++++++++ERROR IN CONTINUATION CHARACTER TEST *ENDIF *IF(ANS2 = TEST2) *ELSE ++++++++ERROR IN CONTINUATION CHARACTER TEST *ENDIF *IF(ANS3 = TEST3) *ELSE ++++++++ERROR IN CONTINUATION CHARACTER TEST *ENDIF *IF(ANS4 = TEST4) *ELSE ++++++++ERROR IN CONTINUATION CHARACTER TEST *ENDIF *COMMENT TEST NESTED SUBSTITUTIONS *ENDCOM *SET ( ABCD = '$$AB$$CD' ) *SET ( WXYZ = '$$WX$$YZ' ) *SET ( ABCDWXYZ ) ABCD = $$ABCD WXYZ = $$WXYZ *ENDSET *SET (TEST1) ABCD = $ABCD WXYZ = $WXYZ *ENDSET *SET (TEST2) $ABCDWXYZ$+ *ENDSET *SET ( ABCD = '$$WX$$YZ' ) *SET ( WXYZ = '$$AB$$CD' ) *SET (TEST3) $ABCDWXYZ$+ *ENDSET *SET ANS1 = ABCD = ABCD WXYZ = WXYZ * ANS2 = ABCD = ABCD WXYZ = WXYZ * ANS3 = ABCD = WXYZ WXYZ = ABCD * *ENDSET *IF (ANS1 = TEST1) *ELSE ++++++++ERROR IN NESTED SUBSTITUTION TEST *ENDIF *IF (ANS2 = TEST2) *ELSE ++++++++ERROR IN NESTED SUBSTITUTION TEST *ENDIF *IF (ANS3 = TEST3) *ELSE ++++++++ERROR IN NESTED SUBSTITUTION TEST *ENDIF *COMMENT TEST THE APPEND STATEMENT *ENDCOM *APPEND ( TEMP1, 11 ) *APPEND ( TEMP2, .TRUE. ) *APPEND ( TEMP1, 'AB' ) *APPEND ( TEMP2, ITEMP ) *APPEND ( LINES ) LINE 3 LINE 4 *ENDAPP *SET TEST1 = TEMP1 = $TEMP1 * TEST2 = TEMP2 = $TEMP2 * TEST3 = $LINES$+ * *ENDSET *SET ANS1 = TEMP1 = 11AB * ANS2 = TEMP2 = .TRUE.11 * ANS3 = LINE 1 LINE 2 LINE 3 LINE 4 * *ENDSET *IF (ANS1 = TEST1) *ELSE ++++++++ERROR IN APPEND TEST *ENDIF *IF (ANS2 = TEST2) *ELSE ++++++++ERROR IN APPEND TEST *ENDIF *IF (ANS3 = TEST3) *ELSE ++++++++ERROR IN APPEND TEST *ENDIF *COMMENT TEST THE DEF SUBSTITUTION AND THE DELETE STATEMENT *ENDCOM *SET (TEST) DEF(ABCD) = $DEF(ABCD) DEF(ITEMP) = $DEF(ITEMP) DEF(LONG) = $DEF(LONG) DEF(TEMP1) = $DEF(TEMP1) DEF(TEMP2) = $DEF(TEMP2) DEF(WXYZ) = $DEF(WXYZ) *ENDSET *SET (ANS) DEF(ABCD) = .TRUE. DEF(ITEMP) = .TRUE. DEF(LONG) = .TRUE. DEF(TEMP1) = .TRUE. DEF(TEMP2) = .TRUE. DEF(WXYZ) = .TRUE. *ENDSET *IF (ANS = TEST) *ELSE ++++++++ERROR IN DEF SUBSTITUTION TEST *ENDIF *DELETE ( ABCD ) *DELETE ( ITEMP ) *DELETE ( LONG ) *DELETE ( TEMP1 ) *DELETE ( TEMP2 ) *DELETE ( WXYZ ) *SET (TEST) DEF(ABCD) = $DEF(ABCD) DEF(ITEMP) = $DEF(ITEMP) DEF(LONG) = $DEF(LONG) DEF(TEMP1) = $DEF(TEMP1) DEF(TEMP2) = $DEF(TEMP2) DEF(WXYZ) = $DEF(WXYZ) *ENDSET *SET (ANS) DEF(ABCD) = .FALSE. DEF(ITEMP) = .FALSE. DEF(LONG) = .FALSE. DEF(TEMP1) = .FALSE. DEF(TEMP2) = .FALSE. DEF(WXYZ) = .FALSE. *ENDSET *IF (ANS = TEST) *ELSE ++++++++ERROR IN DELETE TEST *ENDIF *COMMENT TEST THE LIST SUBSTITUTION AND THE RESET STATEMENT *ENDCOM *SET ( ITEM = '$AB$$/$CD$$/' ) *SET (TEST) ITEM 1 = **$LIST(ITEM)** ITEM 2 = **$LIST(ITEM)** ITEM 3 = **$LIST(ITEM)** ITEM 4 = **$LIST(ITEM)** *ENDSET *SET (ANS) ITEM 1 = **AB** ITEM 2 = **CD** ITEM 3 = **** ITEM 4 = **** *ENDSET *IF (ANS = TEST) *ELSE ++++++++ERROR IN LIST SUBSTITUTION TEST *ENDIF *APPEND ( ITEM, '$WX$$/$YZ$$/' ) *SET (TEST) ITEM 3 = **$LIST(ITEM)** ITEM 4 = **$LIST(ITEM)** ITEM 5 = **$LIST(ITEM)** ITEM 6 = **$LIST(ITEM)** *ENDSET *SET (ANS) ITEM 3 = **WX** ITEM 4 = **YZ** ITEM 5 = **** ITEM 6 = **** *ENDSET *IF (ANS = TEST) *ELSE ++++++++ERROR IN LIST SUBSTITUTION TEST *ENDIF *RESET ( ITEM ) *SET (TEST) ITEM 1 = **$LIST(ITEM)** ITEM 2 = **$LIST(ITEM)** ITEM 3 = **$LIST(ITEM)** ITEM 4 = **$LIST(ITEM)** ITEM 5 = **$LIST(ITEM)** ITEM 6 = **$LIST(ITEM)** *ENDSET *SET (ANS) ITEM 1 = **AB** ITEM 2 = **CD** ITEM 3 = **WX** ITEM 4 = **YZ** ITEM 5 = **** ITEM 6 = **** *ENDSET *IF (ANS = TEST) *ELSE ++++++++ERROR IN RESET TEST *ENDIF *COMMENT TEST THE DO STATEMENT AND LABEL AND LIST SUBSTITUTIONS *ENDCOM *SET ( LABEL = 10000 ) *DO ( I = 1, 3 ) X($I) = Y($I) LABEL($I) = $LABEL *ENDDO *DO ( I = 7, 1 ) X($I) = Y($I) *ENDDO *SET ( I13 = 13 ) *DO ( I = 1, 2 ) *RESET ( ITEM ) *DO ( J = I11, I13, I2 ) LINE($I,$J) = '**$LIST(ITEM)**' *ENDDO *ENDDO *DO ( I = 1, 2 ) *DO ( J = 5, 10, 5 ) X($I,$J) = 0.$I$J *ENDDO *ENDDO *COMMENT TEST MACROS CONTAINING DIRECTIVES *ENDCOM *SET ( LINES ) *SET ( LABEL = 10000 ) *DO ( I = 1, 3 ) X($$I) = Y($$I) LABEL($$I) = $$LABEL *ENDDO THESE ARE THE LAST TWO LINES OF THIS INCLUDED TEXT. *ENDSET *INCLUDE ( LINES ) *COMMENT TEST THE FORTRAN LINE WRITER AND THE INCLUDE DIRECTIVE *ENDCOM *SET ( LINES ) IJUMPI = IJUMP(I) *ENDSET *APPEND ( LINES, ' GO TO (10001, 10002, 10003, 10004,' ) *APPEND ( LINES, ' 10005, 10006, 10007, 10008, 10009, 10010,' ) *APPEND ( LINES ) 10011, 10012, 10013, 10014, 10015, 10016, 10017), IJUMPI *ENDAPP *INCLUDE(LINES) *END *OPTION ( LISTI = .TRUE. ) *OPTION ( LISTO = .TRUE. ) SHAR_EOF fi # end of overwriting check if test -f 'exhaustive.out' then echo shar: will not over-write existing file "'exhaustive.out'" else cat << SHAR_EOF > 'exhaustive.out' I11 = 11 I21 = 21 I2 = 2 TRUE = .TRUE. FALSE = .FALSE. AB = AB ITEMP = 11 LINE 1 LINE 2 A = B A = C X(1) = Y(1) LABEL(1) = 10001 X(2) = Y(2) LABEL(2) = 10002 X(3) = Y(3) LABEL(3) = 10003 X(7) = Y(7) LINE(1,11) = '**AB**' LINE(1,13) = '**CD**' LINE(2,11) = '**AB**' LINE(2,13) = '**CD**' X(1,5) = 0.15 X(1,10) = 0.110 X(2,5) = 0.25 X(2,10) = 0.210 X(1) = Y(1) LABEL(1) = 10001 X(2) = Y(2) LABEL(2) = 10002 X(3) = Y(3) LABEL(3) = 10003 THESE ARE THE LAST TWO LINES OF THIS INCLUDED TEXT. IJUMPI = IJUMP(I) GO TO (10001, 10002, 10003, 10004, 10005, 10006, 10007, 10008, Z 10009, 10010, 10011, 10012, 10013, 10014, 10015, 10016, 10017) Z , IJUMPI SHAR_EOF fi # end of overwriting check if test -f 'linpack' then echo shar: will not over-write existing file "'linpack'" else cat << SHAR_EOF > 'linpack' *COMMENT FILE 7. A LINPACK EXAMPLE. DEFINE MACRO PARAMETERS *ENDCOM *OPTION (LISTI = .TRUE.) *OPTION (LISTO = .TRUE.) *OPTION (LCOL1 = .FALSE.) *SET TYPE = 'SINGLE' CONDNO = .FALSE. SOLVE = .TRUE. N = 10 *ENDSET *COMMENT SET THE CORRECT VARIABLE TYPE *ENDCOM *IF (TYPE = 'SINGLE') *SET (DECL = 'REAL') *SET (PREFIX = 'S') *ELSE *SET (DECL = 'DOUBLE PRECISION') *SET (PREFIX = 'D') *ENDIF *COMMENT BUILD THE FORTRAN PROGRAM *ENDCOM $DECL A ($N,$N) *IF (CONDNO) $DECL RCOND, WORK ($N) *ENDIF *IF (SOLVE) $DECL B ($N) *ENDIF INTEGER IPVT ($N) READ (5,*) A *IF (CONDNO) CALL $(PREFIX)GECO (A, $N, $N, IPVT, RCOND, WORK) WRITE (6,*) RCOND *ELSE CALL $(PREFIX)GEFA (A, $N, $N, IPVT, INFO) *ENDIF *IF (SOLVE) READ (5,*) B CALL $(PREFIX)GESL (A, $N, $N, IPVT, B, 0) WRITE (6,*) B *ENDIF STOP END *END SHAR_EOF fi # end of overwriting check if test -f 'linpack.out' then echo shar: will not over-write existing file "'linpack.out'" else cat << SHAR_EOF > 'linpack.out' REAL A (10,10) REAL B (10) INTEGER IPVT (10) READ (5,*) A CALL SGEFA (A, 10, 10, IPVT, INFO) READ (5,*) B CALL SGESL (A, 10, 10, IPVT, B, 0) WRITE (6,*) B STOP END SHAR_EOF fi # end of overwriting check if test -f 'macrop' then echo shar: will not over-write existing file "'macrop'" else cat << SHAR_EOF > 'macrop' *COMMENT A SIMPLE MACRO PROCESSOR THIS PROCESSOR WAS DEVELOPED AT PURDUE UNIVERSITY AS PART OF THE TOOLPACK PROJECT. SUPPORT BY NSF GRANT MCS79-26310 IS GRATEFULLY ACKNOWLEDGED. THIS PROGRAM WAS WRITTEN BY WILLIAM A. WARD BASED ON AN EARLIER MACRO-PROCESSOR WRITTEN BY JOHN R. RICE. THE FACILITIES & COMMENTS WERE ENHANCED BY CALVIN J. RIBBENS. PLEASE REPORT ANY BUGS OR SUGGESTIONS TO JOHN R. RICE, COMPUTER SCIENCES DEPT. , PURDUE UNIVERSITY, WEST LAFAYETTE, INDIANA 47907. THE PRIMARY DOCUMENTATION OF THIS PROGRAM ARE THE REPORTS: A SIMPLE MACRO PROCESSOR - USER'S GUIDE JOHN R. RICE AND WILLIAM A. WARD CSD-TR 403, PURDUE UNIVERSITY, 1982 (REVISED APRIL, 1983) A SIMPLE MACRO PROCESSOR CALVIN J. RIBBENS, JOHN R. RICE AND WILLIAM A. WARD CSD-TR 400, PURDUE UNIVERSITY, 1982 (REVISED APRIL, 1983) MACHINE READABLE VERSIONS OF THESE SHOULD BE DISTRIBUTED WITH THIS PROGRAM. THE DISTRIBUTION INCLUDES A FILE OF TEST INPUT WHICH EXTENSIVELY EXCERCISES THIS PROCESOR; IT SHOULD BE USED TO TEST ANY INSTALLATION. THE FOLLOWING COMMENTS PERTAIN TO HOW TO OBTAIN A WORKING FORTRAN VERSION OF THE MACRO-PROCESSOR FROM THIS MASTER TEMPLATE OF IT. YOUR VERSION OF THE TEMPLATE PROCESSOR MAY BE TUNED BY SETTING THE FOLLOWING TEMPLATE VARIABLES TO APPROPRIATE VALUES AND THEN APPLYING THE BASIC PROCESSOR TO THE FOLLOWING TEMPLATE. LIBRARY - IF .TRUE., ONLY THOSE ROUTINES NEEDED FOR A TEMPLATE PROCESSOR LIBRARY WILL BE INCLUDED. THE USER MUST SUPPLY A MAIN PROGRAM WHICH CALLS TPDRV, THE DRIVER ROUTINE. IF .FALSE., A MAIN PROGRAM WILL BE SUPPLIED SO THAT A COMPLETE STAND-ALONE VERSION OF THE PROCESSOR MAY BE CREATED. ICBDIM - THE DIMENSION OF THE ARRAY CBUFFR. ICSDIM - THE DIMENSION OF THE ARRAY CSTORE IHADIM - THE DIMENSION OF THE ARRAY IHASH. THIS SHOULD BE A PRIME NUMBER. ISTDIM - THE DIMENSION OF THE ARRAY ISTORE. SHOULD BE LESS THAN ICSDIM. CSTAR1 - IF .TRUE., FORTRAN 77 DECLARATIONS OF THE FORM CHARACTER*1 ARE USED INSTEAD OF INTEGER DECLARATIONS. NOPACK - IF .TRUE., ALL REFERENCES TO THE ARRAY CSTORE WILL BE DIRECT (IN-LINE) INSTEAD OF BEING FORCED THROUGH SUBROUTINES. TESTCH - IF .TRUE., CHARACTER TESTING USED TO CHECK FOR ALPHABETIC AND NUMERIC IS PERFORMED USING IN-LINE IF STATEMENTS INSTEAD OF BEING ISOLATED IN SEPARATE SUBROUTINES. USE OF IN-LINE IF STATEMENTS ASSUMES THE DIGITS 0 TO 9 AND THE LETTERS A TO Z ARE REPRESENTED BY CONTIGUOUS CHARACTER CODES. IF THIS IS NOT THE CASE, INSTALLER SHOULD SET TESTCH=.FALSE. AND MODIFY ROUTINES UTCHKA, UTCHKN, AND UTCHKS APPROPRIATELY. UNIX - PRODUCE A UNIX COMPATIBLE VERSION. CDC - IF .TRUE., A PURDUE CDC COMPATIBLE VERSION IS PRODUCED. DEBUG - IF .TRUE., MNF TRACE STATEMENTS WILL BE INSERTED. THIS SHOULD ONLY BE USED IF CDC = .TRUE. SHORTB - IF .TRUE. AND CDC = .TRUE., SHORT FILE BUFFERS WILL BE USED. STATS - IF .TRUE., MNF TIMING STATEMENTS WILL BE INSERTED. THIS SHOULD ONLY BE USED IF CDC = .TRUE. ENDEOF - IF .TRUE., A DUMMY *END CARD WILL BE GENERATED ON UNEXPECTED END OF FILE *ENDCOM *OPTION(LISTI = .FALSE.) *OPTION(LISTO = .FALSE.) *OPTION(LCOL1 = .TRUE. ) *COMMENT IF LIBRARY = .TRUE., THE USER SUPPLIES A MAIN PROGRAM WHICH WILL SET THE DIMENSIONS OF CBUFFR, CSTORE, IHASH, AND ISTORE. *ENDCOM *SET (LIBRARY = .FALSE.) *IF(LIBRARY) *SET ( ICBDIM = 1 ) *SET ( ICSDIM = 1 ) *SET ( IHADIM = 1 ) *SET ( ISTDIM = 1 ) *ELSE *SET ( ICBDIM = 2000 ) *SET ( ICSDIM = 20000 ) *SET ( IHADIM = 601 ) *SET ( ISTDIM = 6000 ) *ENDIF *SET ( CSTAR1 = .TRUE.) *SET ( NOPACK = .TRUE. ) *SET ( TESTCH = .TRUE. ) *SET ( UNIX = .TRUE. ) *SET ( CDC = .FALSE.) *SET ( DEBUG = .FALSE.) *SET ( SHORTB = .FALSE.) *SET ( STATS = .FALSE.) *SET ( ENDEOF = .TRUE.) *IF(CSTAR1) *SET(DECLAREC='CHARACTER*1') *SET(ARGDECLAREC='CHARACTER*(*)') *ELSE *SET(DECLAREC='INTEGER ') *SET(ARGDECLAREC='INTEGER ') *ENDIF *COMMENT DEFINE COMMON BLOCKS *ENDCOM *SET(GLCOM) C C GLOBAL CONSTANTS C $(DECLAREC) CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 COMMON / GLCOMC / CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 *ENDSET *SET(IOCOM) C C INPUT / OUTPUT CONTROL INTERFACE C $(DECLAREC) CBUFFR($ICBDIM) LOGICAL LBREAK, LFORT, LISTI, LISTO INTEGER ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOMC / CBUFFR COMMON / IOCOMI / ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOML / LBREAK, LFORT, LISTI, LISTO *ENDSET *SET(MMCOM) C C MEMORY MANAGER INTERFACE C $(DECLAREC) CSTORE($ICSDIM) INTEGER IHASH($IHADIM), ISTORE($ISTDIM) INTEGER ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS COMMON / MMCOMC / CSTORE COMMON / MMCOMH / IHASH COMMON / MMCOMS / ISTORE COMMON / MMCOMI / ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS *ENDSET *SET(MPCOM) C C MACRO PROCESSOR INTERFACE C $(DECLAREC) CDIV, CEOL, CEOR, CONC, CSUB, A CTOP LOGICAL LEMPTY, LSUB COMMON / MPCOMC / CDIV, CEOL, CEOR, CONC, CSUB, A CTOP COMMON / MPCOML / LEMPTY, LSUB *ENDSET *SET(TPCOM) C C TEMPLATE PROCESSOR INTERFACE C $(DECLAREC) CDIR, CSTAR INTEGER ICBP1(4), ICBP2(4) INTEGER ITOPDO, IARGS, INESTD, INESTF LOGICAL LCOL1, LDIRL, LEND, LINITM, L1TRIP COMMON / TPCOMC / CDIR, CSTAR COMMON / TPCOMI / ICBP1, ITOPDO, IARGS, ICBP2, INESTD, B INESTF COMMON / TPCOML / LCOL1, LDIRL, LEND, LINITM, L1TRIP *ENDSET *COMMENT IF LIBRARY = .TRUE., A USER SUPPLIED MAIN PROGRAM WILL SERVE AS THE CALLING PROGRAM FOR THE TEMPLATE PROCESSOR. NO MAIN PROGRAM IS NECESSARY. *ENDCOM *IF(LIBRARY = .FALSE.) *IF(CDC) *IF(SHORTB) PROGRAM GO (FILES=102B, INPUT=102B, LIST=102B, OUTPUT=102B, A TAPE4=FILES, TAPE5=INPUT, TAPE6=LIST, TAPE7=OUTPUT) *ELSE PROGRAM GO (FILES=102B, INPUT, LIST, OUTPUT, A TAPE4=FILES, TAPE5=INPUT, TAPE6=LIST, TAPE7=OUTPUT) *ENDIF *ELSE C PROGRAM GO *ENDIF C C---------------------------------------------------------------------- C C FAMILY C ------ C SYSTEM/USER INTERFACE C C PURPOSE C ------- C THIS IS A SAMPLE MAIN PROGRAM TO CALL THE C DRIVING ROUTINE OF THE MACRO PROCESSOR. C C---------------------------------------------------------------------- *INCLUDE(GLCOM) *INCLUDE(IOCOM) *INCLUDE(MMCOM) *INCLUDE(MPCOM) *INCLUDE(TPCOM) EXTERNAL TPDRV, TPMMIN *IF(UNIX) C C SET DIMENSIONS FOR ARRAYS C ICBDIM = $ICBDIM ICSDIM = $ICSDIM IHADIM = $IHADIM ISTDIM = $ISTDIM C C INITIALIZE TEMPLATE PROCESSOR C CALL TPMMIN C C CALL DRIVER C USING UNIX STANDARD ERROR, INPUT, AND OUTPUT UNITS C CALL TPDRV (0, 5, 0, 6) C STOP 0 *ELSE *IF(CDC) C C LOCAL VARIABLES AND PARAMETERS C INTEGER IFNAME(7) C C SET DIMENSIONS FOR ARRAYS C ICBDIM = $ICBDIM ICSDIM = $ICSDIM IHADIM = $IHADIM ISTDIM = $ISTDIM C C INITIALIZE TEMPLATE PROCESSOR C CALL TPMMIN *IF(STATS) TRACE SUBPROGRAM CALLS TRACE SUBPROGRAM TIME C *ENDIF *IF(DEBUG) TRACE DO LOOPING TRACE STATEMENT NUMBERS TRACE SUBSCRIPTS TRACE TRANSFERS C *ENDIF IFNNEW = 5LINPUT C DO 30 I=2,11 READ (4, 1010) (IFNAME(IFN), IFN=1,7) IF (EOF(4) .GT. 0.0) GO TO 999 IFNOLD = IFNNEW IFNNEW = 0 DO 10 IFN=1,7 IF (IFNAME(IFN) .EQ. 55B) GO TO 20 IFNNEW = IFNNEW .OR. SHIFT(IFNAME(IFN), 60-6*IFN) 10 CONTINUE 20 CONTINUE IF (IFNOLD .NE. IFNNEW) CALL RENAMEF (IFNOLD, IFNNEW) C C CALL DRIVER C CALL TPDRV (6, 5, 6, 7) 30 CONTINUE C 999 CONTINUE STOP 1010 FORMAT(7R1) *ENDIF *ENDIF END *ENDIF SUBROUTINE TPDRV (IUE0, IUI0, IUL0, IUO0) C C----------------------------------------------------------------------- C C FAMILY C ------ C TEMPLATE PROCESSOR C C PURPOSE C ------- C THIS IS THE DRIVING ROUTINE OF THE TEMPLATE PROCESSOR. C IT CALLS ROUTINES TO READ, EVALUATE, AND WRITE LINES C UNTIL AN END DIRECTIVE IS ENCOUNTERED C C PARAMETERS C ---------- C IUE0 -I- UNIT NUMBER FOR THE ERROR FILE C IUI0 -I- UNIT NUMBER FOR THE INPUT FILE C IUL0 -I- UNIT NUMBER FOR THE LISTING FILE C IUO0 -I- UNIT NUMBER FOR THE OUTPUT FILE C C COMMON VARIABLES AND DATA STRUCTURES C ------------------------------------ C THE COMMENTS BELOW GIVE A BRIEF DESCRIPTION OF THE COMMON C VARIABLES USED BY THE ROUTINES OF THE TEMPLATE PROCESSOR. C A MORE DETAILED LOOK AT THE MAIN DATA STRUCTURES IS ALSO C INCLUDED. C C GLOBAL CONSTANTS C C COMMON / GLCOMC / C CA - 'A' CPOINT - '.' C CBLANK - ' ' CQUOTE - ''' C CC - 'C' CRIGHT - '(' C CI - 'I' CZ - 'Z' C CLEFT - '(' C0 - '0' C CMINUS - '-' C9 - '9' C CPLUS - '+' C C INPUT / OUTPUT CONTROL INTERFACE C C COMMON / IOCOMC / C CBUFFR - I/O BUFFER C COMMON / IOCOMI / C ICBADD - NUMBER OF SPACES TO SKIP BEFORE THE CONTINUATION C OF A BROKEN LINE C ICBEND - BUFFER POSITION OF END OF CURRENT LOGICAL LINE C (LOGICAL LINE MAY INCLUDE SEVERAL ACTUAL LINES) C ICBEOL - BUFFER POSITION OF CURRENT EOL. C ICBSUB - BUFFER POSITION OF CURRENT SUB. PREF. CHARACTER C ICB0 - BUFFER POSITION OF START OF CURRENT LINE C ICB1 - BUFFER POSITION WHERE CURRENT PROCESSING BEGINS C ICB2 - BUFFER POSITION WHERE CURRENT PROCESSING ENDS C ICB3 - BUFFER POSITION OF END OF CURRENT LINE C ICBDIM - DIMENSION OF CBUFFR C ICPLI - INPUT LINE LENGTH C ICPLO - OUPUT LINE LENGTH C ILCTR - LINE NUMBER ON CURRENT LISTING PAGE C ILNMBR - LINE NUMBER FOR LISTING (OVER ALL PAGES) C ILPP - MAX NUMBER OF LINES PER LISTING PAGE C IPAGE - PAGE NUMBER ON LISTING C IUNITE - ERROR OUTPUT UNIT C IUNITI - INPUT UNIT C IUNITL - LISTING OUTPUT UNIT C IUNITO - STANDARD OUTPUT UNIT C COMMON / IOCOML / C LBREAK - BREAK LONG LINES AT NICE PLACE IF TRUE C LFORT - USE FORTRAN CONTINUATION CHAR. IF TRUE C LISTI - LIST INPUT IF TRUE C LISTO - LIST OUTPUT IF TRUE C C MEMORY MANAGER INTERFACE C C COMMON / MMCOMC / C CSTORE - CHARACTER STORAGE C COMMON / MMCOMH / C IHASH - HASH TABLE (IHASH(I) IS AN INDEX INTO ISTORE) C COMMON / MMCOMS / C ISTORE - INTEGER STORAGE; HOLDS THE POINTERS WHICH C IMPLEMENT THE SYMBOL TABLE AND THE STACK C COMMON / MMCOMI / C ICSDIM - DIMENSION OF ICSDIM C ICSP1 - PTR. TO TOP CHARACTER IN SUBSTITUTION STACK C ICSP2 - PTR. TO LAST CHAR. IN FIRST STRING ON STACK C IHADIM - DIMENSION OF IHASH C ISFREE - PTR. TO HEAD OF ISTORE FREELIST C ISTDIM - DIMENSION OF ISTORE C IS2HDC - PTR. TO HEAD OF FREE CHARACTER STORAGE BLOCKS C (ACTUALLY AN INDEX INTO ISTORE) C IS2HDS - PTR. TO TOP OF STACK C (ACTUALLY AN INDEX INTO ISTORE) C C MACRO PROCESSOR INTERFACE C C COMMON / MPCOMC / C CDIV - '/' C CEOL - '-' C CEOR - '/' C CONC - '+' C CSUB - DOLLAR SIGN C CTOP - TOP CHAR. IN STACK C COMMON / MPCOML / C LEMPTY - TRUE IF SUBSTITUTION STACK EMPTY C LSUB - TRUE IF SUBSTITUTIONS ARE TO BE PERFORMED C C TEMPLATE PROCESSOR INTERFACE C C COMMON / TPCOMC / C CDIR - '*' C CSTAR - '*' C COMMON / TPCOMI / C ICBP1 - ICBP1(I) IS BUFF. POSITION OF START OF C ITH ARGUMENT C ITOPDO - PTR. TO 'TOP' (INNERMOST) DO LOOP ENTRY C IN ISTORE C IARGS - NUMBER OF ARGUMENTS IN A DIRECTIVE C ICBP2 - ICBP2(I) IS BUFF. POSITION OF END OF C ITH ARGUMENT C INESTD - DO LOOP NESTING DEPTH C INESTF - IF-ELSE-ENDIF NESTING DEPTH C COMMON / TPCOML / C LCOL1 - TRUE IF DIRECTIVES MUST BEGIN IN COL 1 C LDIRL - TRUE IF A DIRECTIVE HAS BEEN FOUND C LEND - TRUE IF AN END DIRECTIVE HAS BEEN FOUND C LINITM - TRUE IF MMINIT HAS BEEN CALLED C L1TRIP - TRUE IF ONE TRIP DO-LOOPS SHOULD BE ASSUMED C C C DATA STRUCTURES C --------------- C C I/O BUFFER C THE ARRAY CBUFFR HOLDS THE I/O BUFFER. INPUT LINES ARE READ C IN, MACRO SUBSTITUTIONS PERFORMED, AND LISTING AND OUTPUT C (WHEN APPROPRIATE) ARE DONE FROM THE I/O BUFFER. C C INTEGER STORAGE C THE ARRAY ISTORE IS USED TO HOLD THE POINTERS WHICH IMPLEMENT C THE SYMBOL TABLE AND THE SUBSTITUTION STACK. IT IS USED IN C BLOCKS OF 3 ELEMENTS AT A TIME. THE VARIABLE ISFREE POINTS C TO THE HEAD OF A LINKED LIST OF FREE ISTORE BLOCKS. INITIALLY C ALL BLOCKS ARE FREE (THE 3RD ELEMENT IN A BLOCK POINTS TO THE C NEXT FREE BLOCK). C C CHARACTER STORAGE C THE ARRAY CSTORE PROVIDES A POOL OF CHARACTER STORAGE. IT C IS USED TO RECORD MACRO NAMES AND VALUES, AS WELL AS STRINGS C WHICH MUST BE PUSHED ONTO THE SUBSTITUTION STACK. THE VARIABLE C IS2HDC POINTS TO THE HEAD OF A FREELIST OF CHARACTER STORAGE C BLOCKS. THIS FREELIST IS MADE UP OF ISTORE BLOCKS OF THE C FOLLOWING FORMAT: C ISTORE(I) = CSTORE INDEX OF FIRST CHAR. IN BLOCK C ISTORE(I+1)= CSTORE INDEX OF LAST CHAR. IN BLOCK C ISTORE(I+2)= POINTER TO NEXT BLOCK C C SYMBOL TABLE C THE SYMBOL TABLE KEEPS TRACK OF MACRO NAMES AND VALUES. IT C IS BUILT OUT OF ISTORE BLOCKS WHICH CONTAIN POINTERS TO C OTHER ISTORE BLOCKS OR INDEXES INTO CSTORE. GIVEN A MACRO C NAME, ROUTINE MMHASH COMPUTES ITS HASH INDEX IH. THEN C IHASH(IH) IS THE ISTORE INDEX OF THE SYMBOL TABLE ENTRY FOR C THAT NAME. IF IHASH(IH)=I SAY, THE ISTORE BLOCK AT I HOLDS C THE FOLLOWING: C ISTORE(I) = PTR. TO ISTORE BLOCK FOR VARIABLE NAME C ISTORE(I+1) = PTR. TO HEAD OF LINKED LIST OF ISTORE C BLOCKS FOR VALUE OF VARIABLE C ISTORE(I+2) = PTR. TO TAIL OF THE LINKED LIST FOR THE C VALUE C C AN ISTORE BLOCK FOR THE NAME OF A VARIABLE CONTAINS: C ISTORE(J) = CSTORE INDEX OF FIRST CHAR. IN NAME C ISTORE(J+1) = CSTORE INDEX OF LAST CHAR. IN NAME C ISTORE(J+2) = 0 C C AN ISTORE BLOCK IN THE LINKED LIST WHICH KEEPS TRACK OF C THE VALUE OF A VARIABLE LOOKS LIKE: C ISTORE(K) = CSTORE INDEX OF FIRST CHAR. ASSOCIATED C WITH THIS BLOCK C ISTORE(K+1) = CSTORE INDEX OF LAST CHAR. ASSOCIATED C WITH THIS BLOCK C ISTORE(K+2) = ISTORE INDEX OF NEXT BLOCK IN LIST C (0 IF LAST ONE) C C SUBSTITUTION STACK C WHEN A MACRO SUBSTITUTION IS FOUND, IT AND THE REST OF THE C CURRENT LINE ARE PUSHED ONTO THE SUBSTITUTION STACK. THE C MACRO NAME IS POPPED OFF AND REPLACED BY ITS VALUE. CHARACTERS C ARE THEN POPPED OFF THE STACK, INTO THE I/O BUFFER, UNTIL C THE STACK IS EMPTY OR ANOTHER SUBSTITUTION IS CALLED FOR. C IF ANOTHER MACRO SUBSTITUTION IS NEEDED THE SAME PROCESS IS C REPEATED--THE MACRO NAME IS REPLACED BY ITS VALUE, AND THE C STACK POPPING RESUMES. C C THE STACK IS IMPLEMENTED AS A LINKED LIST OF ISTORE BLOCKS. C THE VARIABLE IS2HDS POINTS TO THE TOP BLOCK ON THE STACK. C A BLOCK AT INDEX I CONTAINS: C ISTORE(I) = PTR. TO ISTORE BLOCK WHICH POINTS TO A C STRING ON THE STACK C ISTORE(I+1) = CSTORE INDEX OF 1ST CHAR. OF C CORRESPONDING STRING C ISTORE(I+2) = LINK TO NEXT ISTORE BLOCK ON STACK C (0 IF THERE IS NONE) C C THE FORMAT OF AN ISTORE BLOCK WHICH POINTS TO A STRING ON THE C STACK IS LIKE THAT OF ONE WHICH POINTS TO A VARIABLE NAME: C ISTORE(J) = CSTORE INDEX OF FIRST CHAR. IN STRING C ISTORE(J+1) = CSTORE INDEX OF LAST CHAR. IN STRING C ISTORE(J+2) = 0 C C C C----------------------------------------------------------------------- *INCLUDE(GLCOM) *INCLUDE(IOCOM) *INCLUDE(MMCOM) *INCLUDE(MPCOM) *INCLUDE(TPCOM) INTEGER IUE0, IUI0, IUL0, IUO0 EXTERNAL TPINIT, MPLINE, TPEVAL, IOWRIT C CALL TPINIT (IUE0, IUI0, IUL0, IUO0) C 10 CONTINUE ICBEOL = 0 CALL MPLINE (.TRUE.) CALL TPEVAL IF (.NOT. LDIRL) CALL IOWRIT IF (.NOT. LEND) GO TO 10 C RETURN END SUBROUTINE IOERRM (LFATAL, CFMT) C C---------------------------------------------------------------------- C C FAMILY C ------ C INPUT/OUTPUT C C PURPOSE C ------- C TO PRINT OUT THE OFFENDING LINE AND AN ERROR MESSAGE BENEATH IT. C IF THE ERROR IS FATAL, PROCESSOR EXECUTION IS TERMINATED. C C PARAMETERS C ---------- C LFATAL -I- TRUE FOR FATAL ERRORS C CFMT -I- FORMAT FOR ERROR MESSAGE C C---------------------------------------------------------------------- *INCLUDE(IOCOM) C C LOCAL VARIABLES AND PARAMETERS C $(ARGDECLAREC) CFMT LOGICAL LFATAL INTEGER I EXTERNAL IOPAGE C *IF(LIBRARY) IF (IUNITE .EQ. IUNITL) CALL IOPAGE (3) IF (ICB0 .GT. ICB2) GO TO 10 WRITE (IUNITE, 1010) (CBUFFR(I), I=ICB0,ICB2) 10 WRITE (IUNITE, 1020) *IF(CSTAR1) 1010 FORMAT(' +++++++ ', 117A1) 1020 FORMAT(' +++++++ LIBRARY TEMPLATE PROCESSOR FAILS HERE ') *ELSE 1010 FORMAT(11H +++++++ , 117A1) 1020 FORMAT(49H +++++++ LIBRARY TEMPLATE PROCESSOR FAILS HERE ) *ENDIF *ELSE IF (IUNITE .EQ. IUNITL) CALL IOPAGE (2) IF (ICB0 .GT. ICB2) GO TO 10 WRITE (IUNITE, 1010) (CBUFFR(I), I=ICB0,ICB2) *IF(CSTAR1) 1010 FORMAT(' ******** ', 117A1) *ELSE 1010 FORMAT(12H ******** , 117A1) *ENDIF 10 CONTINUE *ENDIF WRITE (IUNITE, CFMT) *IF (UNIX) IF (LFATAL) STOP 1 *ELSE IF (LFATAL) STOP *ENDIF C RETURN END SUBROUTINE IOLIST (LNUMBR) C C---------------------------------------------------------------------- C C INPUT/OUTPUT C C PURPOSE C ------- C TO LIST THE LINE CURRENTLY IN THE INPUT/OUTPUT BUFFER. C C PARAMETER C --------- C LNUMBR -I- TRUE IF THE LINE SHOULD BE NUMBERED C C---------------------------------------------------------------------- *INCLUDE(IOCOM) C C LOCAL VARIABLES AND PARAMETERS C LOGICAL LNUMBR INTEGER I EXTERNAL IOPAGE C CALL IOPAGE (1) IF (.NOT. LNUMBR) GO TO 20 ILNMBR = ILNMBR + 1 C IF (ICB1 .LE. ICB2) GO TO 10 WRITE (IUNITL, 1010) ILNMBR GO TO 999 C 10 CONTINUE WRITE (IUNITL, 1020) ILNMBR, (CBUFFR(I), I=ICB1,ICB2) GO TO 999 C 20 CONTINUE IF (ICB1 .LE. ICB2) GO TO 30 WRITE (IUNITL, 1030) GO TO 999 C 30 CONTINUE WRITE (IUNITL, 1040) (CBUFFR(I), I=ICB1,ICB2) C 999 CONTINUE RETURN *IF(CSTAR1) 1010 FORMAT(' ', I8) 1020 FORMAT(' ', I8, 3X, 117A1) 1030 FORMAT(' ') 1040 FORMAT(' ', 11X, 117A1) *ELSE 1010 FORMAT(1H , I8) 1020 FORMAT(1H , I8, 3X, 117A1) 1030 FORMAT(1H ) 1040 FORMAT(1H , 11X, 117A1) *ENDIF END SUBROUTINE IOPAGE (IL) C C---------------------------------------------------------------------- C C FAMILY C ------ C INPUT/OUTPUT C C PURPOSE C ------- C TO DETERMINE IF THERE IS ROOM TO PRINT THE SPECIFIED NUMBER C OF LINES ON THE CURRENT PAGE. IF THERE IS NOT, A NEW PAGE C IS BEGUN AND A HEADING IS PRINTED. C C PARAMETERS C ---------- C IL -I- NUMBER OF LINES TO BE PRINTED C C---------------------------------------------------------------------- INTEGER IL *INCLUDE(IOCOM) C ILCTR = ILCTR + IL IF (ILCTR .LE. ILPP) GO TO 999 IPAGE = IPAGE + 1 ILCTR = 3 + IL *IF(LIBRARY=.FALSE.) WRITE (IUNITL,1010) IPAGE *ENDIF C 999 CONTINUE RETURN *IF(CSTAR1) 1010 FORMAT('1', 'PURDUE UNIVERSITY TEMPLATE PROCESSOR ', A '(V2 - 07/31/83) PAGE', I6 //) *ELSE 1010 FORMAT(1H1, 41HPURDUE UNIVERSITY TEMPLATE PROCESSOR , A 21H(V2 - 07/31/83) PAGE, I6 //) *ENDIF END SUBROUTINE IORDLN (CLINE, ICL1, ICL2, IUNIT) C C---------------------------------------------------------------------- C C FAMILY C ------ C INPUT/OUTPUT C C PURPOSE C ------- C TO READ A LINE INTO THE INPUT/OUTPUT BUFFER. THIS C MAY BE REPLACED BY A MORE EFFICIENT LOCAL I/O ROUTINE C C PARAMETERS C ---------- C CLINE -I- I/O BUFFER C ICL1 -I- INDEX OF THE FIRST CHARACTER TO BE READ C ICL2 -I- INDEX OF THE LAST CHARACTER TO BE READ C IUNIT -I- INPUT UNIT NUMBER C C---------------------------------------------------------------------- C INTEGER ICL1, ICL2, IUNIT $(ARGDECLAREC) CLINE(ICL2) INTEGER I, IBOT C C ACCESS CDIR DIRECTIVE PREFIX C *INCLUDE (TPCOM) C *IF(ENDEOF) $(DECLAREC) STREND(5) *IF(CSTAR1) SAVE STREND *ENDIF DATA STREND(1)/'*'/,STREND(2)/'E'/,STREND(3)/'N'/ DATA STREND(4)/'D'/,STREND(5)/' '/ C READ (IUNIT, 1010, END=999) (CLINE(I), I=ICL1,ICL2) RETURN 999 CONTINUE STREND(1) = CDIR DO 10 I=1,4 CLINE(ICL1+I-1)=STREND(I) 10 CONTINUE IBOT=ICL1+4 DO 20 I=IBOT,ICL2 CLINE(I)=STREND(5) 20 CONTINUE *ELSE READ (IUNIT, 1010) (CLINE(I), I=ICL1,ICL2) C RETURN *ENDIF 1010 FORMAT(132A1) END SUBROUTINE IOREAD C C---------------------------------------------------------------------- C C FAMILY C ------ C SUBSTITUTION PROCESSING C C PURPOSE C ------- C TO FILL THE BUFFER WITH A LINE, REMOVE THE TRAILING BLANKS, C SET THE BUFFER POINTERS, AND APPEND AN END-OF-LINE MARKER. C C---------------------------------------------------------------------- *INCLUDE(GLCOM) *INCLUDE(IOCOM) *INCLUDE(MMCOM) *INCLUDE(MPCOM) EXTERNAL IORDLN, IOLIST, IOERRM C C IF THERE IS ENOUGH SPACE IN THE BUFFER C READ A LINE FROM THE INPUT FILE C ICB1 = ICB2 + 1 ICB2 = ICB2 + ICPLI IF (ICB2+2 .GT. ICBDIM) GO TO 30 CALL IORDLN (CBUFFR, ICB1, ICB2, IUNITI) IF (LISTI) CALL IOLIST (.TRUE.) C C REMOVE TRAILING BLANKS C 10 CONTINUE IF (CBUFFR(ICB2) .NE. CBLANK) GO TO 20 ICB2 = ICB2 - 1 IF (ICB2 .GE. ICB1) GO TO 10 C C ADD THE END-OF-LINE MARKER C 20 CONTINUE CBUFFR(ICB2+1) = CSUB CBUFFR(ICB2+2) = CEOL ICB3 = ICB2 ICBEOL = ICB2 + 2 ICBEND = ICBEOL GO TO 999 C 30 CONTINUE CALL IOERRM (.TRUE., *IF(LIBRARY) *IF(CSTAR1) A '('' +++++++ BUFFER SPACE EXCEEDED'')') *ELSE A 37H(32H +++++++ BUFFER SPACE EXCEEDED)) *ENDIF *ELSE *IF(CSTAR1) A '('' ******** IOREAD - BUFFER SPACE EXCEEDED'')') *ELSE A 47H(42H ******** IOREAD - BUFFER SPACE EXCEEDED)) *ENDIF *ENDIF C 999 CONTINUE RETURN END SUBROUTINE IOWRIT C C---------------------------------------------------------------------- C C FAMILY C ------ C SUBSTITUTION PROCESSING C C PURPOSE C ------- C TO WRITE THE LINE CURRENTLY IN THE BUFFER TO THE OUTPUT FILE. C IF THE -BREAK- OPTION IS SPECIFIED, AN ATTEMPT WILL BE MADE TO C BREAK LONG LINES AT A BLANK, RIGHT PARENTHESIS, COMMA, OR AN C ARITHMETIC OPERATOR. IF THE -FORTRAN- OPTION IS SPECIFIED, C CONTINUATION LINES WILL BE WRITTEN WITH CONTINUATION CHARACTERS C IN COLUMN SIX UNLESS THE LINE IS A COMMENT. C C---------------------------------------------------------------------- *INCLUDE(GLCOM) *INCLUDE(IOCOM) *INCLUDE(MMCOM) *INCLUDE(MPCOM) C C LOCAL VARIABLES AND PARAMETERS C $(DECLAREC) C(7), CBI, COL1 INTEGER ICDIM, I, IC, ICB *IF(CSTAR1) SAVE ICDIM, C *ENDIF EXTERNAL IOWRLN, IOLIST DATA ICDIM / 7 / DATA A C(1), C(2), C(3), C(4), C(5), C(6), C(7) *IF(CSTAR1) B / ' ', ')', ',', '/', '*', '-', '+' / *ELSE B / 1H , 1H), 1H,, 1H/, 1H*, 1H-, 1H+ / *ENDIF C ICB1 = ICB0 COL1 = CBUFFR(ICB1) IF (ICB1 .LE. ICB3) GO TO 10 CBUFFR(ICB1) = CBLANK ICB2 = ICB1 GO TO 60 C 10 CONTINUE ICB2 = MIN0(ICB1+ICPLO-1,ICB3) IF (ICB2 .EQ. ICB3) GO TO 60 IF (.NOT. LBREAK) GO TO 40 C C FIND A PLACE TO BREAK THE LINE. C DO 30 I=1,10 CBI = CBUFFR(ICB2) DO 20 IC=1,ICDIM IF (C(IC) .EQ. CBI) GO TO 30 20 CONTINUE ICB2 = ICB2 - 1 30 CONTINUE C C WRITE THE LINE C 40 CONTINUE CALL IOWRLN (CBUFFR, ICB1, ICB2, IUNITO) IF (LISTO) CALL IOLIST (.NOT.LISTI) ICB1 = ICB2 + ICBADD IF (.NOT. LFORT) GO TO 10 C C PAD THE BEGINNING OF THE THE LINE C WITH THE STRING BBBBBZBBBB (B=BLANK) C DO 50 ICB=ICB1,ICB2 CBUFFR(ICB) = CBLANK 50 CONTINUE IF (COL1 .EQ. CC) CBUFFR(ICB1) = CC IF (COL1 .NE. CC) CBUFFR(ICB1+5) = CZ GO TO 10 C 60 CONTINUE CALL IOWRLN (CBUFFR, ICB1, ICB2, IUNITO) IF (LISTO) CALL IOLIST (.NOT.LISTI) C RETURN END SUBROUTINE IOWRLN (CLINE, ICL1, ICL2, IUNIT) C C---------------------------------------------------------------------- C C FAMILY C ------ C INPUT/OUTPUT C C PURPOSE C ------- C TO WRITE A LINE FROM THE INPUT/OUTPUT BUFFER. THIS C MAY BE REPLACED BY A MORE EFFICIENT LOCAL I/O ROUTINE C C PARAMETERS C ---------- C CLINE -I- I/O BUFFER C ICL1 -I- INDEX OF THE FIRST CHARACTER TO BE WRITTEN C ICL2 -I- INDEX OF THE LAST CHARACTER TO BE WRITTEN C IUNIT -I- OUTPUT UNIT NUMBER C C---------------------------------------------------------------------- INTEGER ICL1, ICL2, IUNIT $(ARGDECLAREC) CLINE(ICL2) INTEGER I C WRITE (IUNIT, 1010) (CLINE(I), I=ICL1,ICL2) C RETURN 1010 FORMAT(132A1) END SUBROUTINE MMAPPV (CNAME, ICN1, ICN2, CVALUE, ICV1, ICV2) C C---------------------------------------------------------------------- C C FAMILY C ------ C MEMORY MANAGER C C PURPOSE C ------- C TO APPEND A STRING TO A VARIABLE C C PARAMETERS C ---------- C CNAME -I- ARRAY CONTAINING THE NAME OF THE VARIABLE C ICN1 -I- INDEX OF THE FIRST CHARACTER IN THE NAME C ICN2 -I- INDEX OF THE LAST CHARACTER IN THE NAME C CVALUE -I- ARRAY CONTAINING THE STRING TO BE APPENDED C ICV1 -I- INDEX OF THE FIRST CHARACTER IN THE STRING C ICV2 -I- INDEX OF THE LAST CHARACTER IN THE STRING C C---------------------------------------------------------------------- *INCLUDE(GLCOM) *INCLUDE(IOCOM) *INCLUDE(MMCOM) C C LOCAL VARIABLES AND PARAMETERS C INTEGER ICN1, ICN2, ICV1, ICV2 $(ARGDECLAREC) CNAME(ICN2), CVALUE(ICV2) LOGICAL LFOUND INTEGER IH, IS1, I, IS2 EXTERNAL MMHASH, MMNEWI, MMPUT1 C C HASH THE VARIABLE NAME TO SEE IF IT EXISTS. C IF IT DOES NOT, CREATE IT AND RETURN. C CALL MMHASH (CNAME, ICN1, ICN2, IH, LFOUND) IF (LFOUND) GO TO 10 CALL MMNEWI (IS1) IHASH(IH) = IS1 CALL MMPUT1 (CNAME, ICN1, ICN2, ISTORE(IS1), I) CALL MMPUT1 (CVALUE, ICV1, ICV2, ISTORE(IS1+1), A ISTORE(IS1+2)) GO TO 999 C C THE VARIABLE ALREADY EXISTS. APPEND THE VALUE. C 10 CONTINUE IS1 = IHASH(IH) IS2 = ISTORE(IS1+2) CALL MMPUT1 (CVALUE, ICV1, ICV2, ISTORE(IS2+2), ISTORE(IS1+2)) C 999 CONTINUE RETURN END SUBROUTINE MMDELV (CNAME, ICN1, ICN2, LFOUND) C C---------------------------------------------------------------------- C C FAMILY C ------ C MEMORY MANAGER C C PURPOSE C ------- C TO DELETE A VARIABLE C C PARAMETERS C ---------- C CNAME -I- ARRAY CONTAINING THE NAME OF THE VARIABLE C ICN1 -I- INDEX OF THE FIRST CHARACTER IN THE NAME C ICN2 -I- INDEX OF THE LAST CHARACTER IN THE NAME C LFOUND -O- TRUE IF THE VARIABLE EXISTED C C---------------------------------------------------------------------- *INCLUDE(GLCOM) *INCLUDE(IOCOM) *INCLUDE(MMCOM) C C LOCAL VARIABLES AND PARAMETERS C INTEGER ICN1, ICN2 $(ARGDECLAREC) CNAME(ICN2) LOGICAL LFOUND INTEGER IH, IS1 EXTERNAL MMHASH, MMDEL1, MMRETI C C IF THE VARIABLE EXISTS, DELETE IT BY RETURNING THE SPACE C TAKEN UP BY IT-S NAME AND VALUE, RETURNING THE SPACE POINTER, C AND ZEROING OUT THE HASH TABLE ENTRY. C CALL MMHASH (CNAME, ICN1, ICN2, IH, LFOUND) IF (.NOT. LFOUND) GO TO 999 IS1 = IHASH(IH) CALL MMDEL1 (ISTORE(IS1)) CALL MMDEL1 (ISTORE(IS1+1)) CALL MMRETI (IS1) IHASH(IH) = 0 C 999 CONTINUE RETURN END SUBROUTINE MMDEL1 (IS2) C C---------------------------------------------------------------------- C C FAMILY C ------ C MEMORY MANAGER C C PURPOSE C ------- C TO RETURN BLOCKS OF CHARACTER STORAGE TO THE FREE SPACE POOL C C PARAMETERS C ---------- C IS2 -I- POINTER TO THE FIRST LINK IN A LIST C OF CHARACTER STORAGE BLOCKS C C---------------------------------------------------------------------- INTEGER IS2 *INCLUDE(GLCOM) *INCLUDE(IOCOM) *INCLUDE(MMCOM) INTEGER IS C IS = IS2 IF (IS .EQ. 0) GO TO 999 C C LOOP THROUGH EVERY LINK TO FIND THE TAIL C 10 CONTINUE IF (ISTORE(IS+2) .EQ. 0) GO TO 20 IS = ISTORE(IS+2) GO TO 10 C C ATTACH THE LIST TO THE FREE SPACE POOL AND C RESET THE FREE SPACE HEAD POINTER C 20 CONTINUE ISTORE(IS+2) = IS2HDC IS2HDC = IS2 C C 999 CONTINUE RETURN END *IF(NOPACK) *ELSE SUBROUTINE MMGETC (CSTORI, ICS) C C---------------------------------------------------------------------- C C FAMILY C ------ C MEMORY MANAGER C C PURPOSE C ------- C TO GET A CHARACTER FROM THE CHARACTER STORAGE ARRAY. C IT SHOULD BE USED TO IMPLEMENT MACHINE DEPENDENT PACKED C STORAGE IF THE -CHARACTER*1- DATA TYPE IS NOT AVAILABLE C AND THE PROCESSOR REQUIRES AN EXCESSIVE AMOUNT OF MEMORY. C C PARAMETERS C ---------- C CSTORI -O- CHARACTER FETCHED FROM STORAGE C ICS -I- INDEX OF THE CHARACTER TO BE FETCHED C C---------------------------------------------------------------------- *INCLUDE(GLCOM) *INCLUDE(IOCOM) *INCLUDE(MMCOM) C C LOCAL VARIABLES AND PARAMETERS C $(ARGDECLAREC) CSTORI C CSTORI = CSTORE(ICS) C RETURN END *ENDIF SUBROUTINE MMGETV (CNAME, ICN1, ICN2, A CVALUE, ICV1, ICV2, ICVDIM, LFOUND) C C---------------------------------------------------------------------- C C FAMILY C ------ C MEMORY MANAGER C C PURPOSE C ------- C TO GET THE VALUE OF THE NAMED VARIABLE FROM THE STORAGE C POOL AND COPY IT INTO THE SPECIFIED ARRAY. C C PARAMETERS C ---------- C CNAME -I- ARRAY CONTAINING THE NAME OF THE VARIABLE C ICN1 -I- INDEX OF THE FIRST CHARACTER IN THE NAME C ICN2 -I- INDEX OF THE LAST CHARACTER IN THE NAME C CVALUE -O- ARRAY TO CONTAIN THE VALUE OF THE VARIABLE C ICV1 -O- INDEX OF THE FIRST CHARACTER IN THE VALUE C ICV2 -O- INDEX OF THE LAST CHARACTER IN THE VALUE C ICVDIM -I- LENGTH OF ARRAY CVALUE C LFOUND -O- TRUE IF THE VARIABLE EXISTS C C---------------------------------------------------------------------- *INCLUDE(GLCOM) *INCLUDE(IOCOM) *INCLUDE(MMCOM) C C LOCAL VARIABLES AND PARAMETERS C INTEGER ICN1, ICN2, ICV1, ICV2, ICVDIM $(ARGDECLAREC) CNAME(ICN2), CVALUE(ICVDIM) LOGICAL LFOUND INTEGER IH, IS1, IS2H EXTERNAL MMHASH, MMGET1 C C IF THE VARIABLE EXISTS, COPY ITS VALUE C ICV2 = 0 CALL MMHASH (CNAME, ICN1, ICN2, IH, LFOUND) IF (.NOT. LFOUND) GO TO 999 IS1 = IHASH(IH) IS2H = ISTORE(IS1+1) CALL MMGET1 (CVALUE, ICV1, ICV2, ICVDIM, IS2H) C 999 CONTINUE RETURN END SUBROUTINE MMGET1 (CVALUE, ICV1, ICV2, ICVDIM, IS2H) C C---------------------------------------------------------------------- C C FAMILY C ------ C MEMORY MANAGER C C PURPOSE C ------- C TO COPY THE STRING SPECIFIED BY THE POINTER IS2H C AND COPY IT INTO A SPECIFIED ARRAY. C C PARAMETERS C ---------- C CVALUE -O- ARRAY TO CONTAIN THE VALUE OF THE VARIABLE C ICV1 -O- INDEX OF THE FIRST CHARACTER IN THE VALUE C ICV2 -O- INDEX OF THE LAST CHARACTER IN THE VALUE C ICVDIM -I- LENGTH OF ARRAY CVALUE C IS2H -I- HEAD POINTER TO THE LINKED LIST OF C BLOCKS CONTAINING THE STRING VALUE C C---------------------------------------------------------------------- *INCLUDE(GLCOM) *INCLUDE(IOCOM) *INCLUDE(MMCOM) C C LOCAL VARIABLES AND PARAMETERS C INTEGER ICV1, ICV2, ICVDIM, IS2H $(ARGDECLAREC) CVALUE(ICVDIM) INTEGER ICS1, ICS2, ICS, IS2 EXTERNAL IOERRM C IS2 = IS2H ICV2 = ICV1 - 1 C C LOOP THROUGH EACH BLOCK IN WHICH THE STRING IS STORED C 10 CONTINUE IF (IS2 .EQ. 0) GO TO 999 ICS1 = ISTORE(IS2) ICS2 = ISTORE(IS2+1) IS2 = ISTORE(IS2+2) IF (ICV2+ICS2-ICS1 .GE. ICVDIM) GO TO 30 C C LOOP OVER EACH CHARACTER IN THIS BLOCK C DO 20 ICS=ICS1,ICS2 ICV2 = ICV2 + 1 *IF(NOPACK) CVALUE(ICV2) = CSTORE(ICS) *ELSE CALL MMGETC (CVALUE(ICV2), ICS) *ENDIF 20 CONTINUE GO TO 10 C 30 CONTINUE CALL IOERRM (.TRUE., *IF(LIBRARY) *IF(CSTAR1) A '('' +++++++ STRING TOO LONG FOR CVALUE(*)'')') *ELSE A 45H(40H +++++++ STRING TOO LONG FOR CVALUE(*))) *ENDIF *ELSE *IF(CSTAR1) A '('' ******** MMGET1 - STRING TOO LONG FOR CVALUE(*)'')') *ELSE A 55H(50H ******** MMGET1 - STRING TOO LONG FOR CVALUE(*))) *ENDIF *ENDIF C 999 CONTINUE RETURN END SUBROUTINE MMHASH (CNAME, ICN1, ICN2, IH, LFOUND) C C---------------------------------------------------------------------- C C FAMILY C ------ C MEMORY MANAGER C C PURPOSE C ------- C TO HASH A NAME AND RETURN IT-S HASH TABLE INDEX C C PARAMETERS C ---------- C CNAME -I- ARRAY CONTAINING THE NAME OF THE VARIABLE C ICN1 -I- INDEX OF THE FIRST CHARACTER IN THE NAME C ICN2 -I- INDEX OF THE LAST CHARACTER IN THE NAME C IH -O- HASH INDEX INTO ARRAY IHASH C LFOUND -O- TRUE IF THE VARIABLE IS ALREADY IN THE TABLE C C---------------------------------------------------------------------- *INCLUDE(GLCOM) *INCLUDE(IOCOM) *INCLUDE(MMCOM) C C LOCAL VARIABLES AND PARAMETERS C INTEGER ICN1, ICN2, IH $(ARGDECLAREC) CNAME(ICN2) LOGICAL LERROR, LFOUND INTEGER INAME, IADD, I, IS1 EXTERNAL UTCVNI, MMTEST, IOERRM C C ENCODE THE NAME INTO AN INTEGER C CALL UTCVNI (CNAME, ICN1, ICN2, INAME, LERROR) INAME = MOD(INAME, IHADIM) IADD = MAX0(1, INAME) LFOUND = .FALSE. C C LOOP THROUGH ENTRIES IN THE TABLE UNTIL THE C NAME IS FOUND OR AN EMPTY BUCKET IS REACHED C DO 10 I=1,IHADIM IH = INAME + 1 IS1 = IHASH(IH) IF (IS1 .EQ. 0) GO TO 999 CALL MMTEST (CNAME, ICN1, ICN2, ISTORE(IS1), LFOUND) IF (LFOUND) GO TO 999 INAME = MOD(INAME+IADD, IHADIM) 10 CONTINUE C C EXIT FROM THE ABOVE LOOP INDICATES THAT THE HASH C TABLE IS FULL. TO OBTAIN MORE SPACE THE PROCESSOR C MUST BE RECOMPILED WITH A LARGER DIMENSION -IHADIM- C FOR ARRAY IHASH. IHADIM SHOULD BE A PRIME NUMBER. C CALL IOERRM (.TRUE., *IF(LIBRARY) *IF(CSTAR1) A '('' +++++++ HASH TABLE ARRAY IHASH(*) IS FULL'')') *ELSE A 49H(44H +++++++ HASH TABLE ARRAY IHASH(*) IS FULL)) *ENDIF *ELSE *IF(CSTAR1) A '('' ******** MMHASH - HASH TABLE ARRAY IHASH(*) IS FULL'')') *ELSE A 59H(54H ******** MMHASH - HASH TABLE ARRAY IHASH(*) IS FULL)) *ENDIF *ENDIF C 999 CONTINUE RETURN END SUBROUTINE MMINIT C C----------------------------------------------------------------------- C C FAMILY C ------ C MEMORY MANAGER C C PURPOSE C ------- C TO INITIALIZE MEMORY MANAGER VARIABLES C C----------------------------------------------------------------------- *INCLUDE(GLCOM) *INCLUDE(IOCOM) *INCLUDE(MMCOM) INTEGER I EXTERNAL MMNEWI C DO 10 I=1,IHADIM IHASH(I) = 0 10 CONTINUE C DO 20 I=1,ISTDIM,3 ISTORE(I) = 0 ISTORE(I+1) = 0 ISTORE(I+2) = I + 3 20 CONTINUE C ISTORE(ISTDIM) = 0 ISFREE = 1 C CALL MMNEWI (IS2HDC) ISTORE(IS2HDC) = 1 ISTORE(IS2HDC+1) = ICSDIM ISTORE(IS2HDC+2) = 0 IS2HDS = 0 ICSP1 = 1 ICSP2 = 0 C RETURN END SUBROUTINE MMNEWI (IS) C C----------------------------------------------------------------------- C C FAMILY C ------ C MEMORY MANAGER C C PURPOSE C ------- C TO RETURN A POINTER TO AN AVAILABLE BLOCK FROM THE INTEGER C STORAGE POOL C C PARAMETERS C ---------- C IS -O- INDEX INTO ARRAY ISTORE OF THE FREE BLOCK C C----------------------------------------------------------------------- *INCLUDE(GLCOM) *INCLUDE(IOCOM) *INCLUDE(MMCOM) INTEGER IS EXTERNAL IOERRM C IF (ISFREE .EQ. 0) GO TO 10 IS = ISFREE ISFREE = ISTORE(ISFREE+2) GO TO 999 C 10 CONTINUE CALL IOERRM (.TRUE., *IF(LIBRARY) *IF(CSTAR1) A '('' +++++++ STORAGE ARRAY ISTORE(*) IS FULL'')') *ELSE A 47H(42H +++++++ STORAGE ARRAY ISTORE(*) IS FULL)) *ENDIF *ELSE *IF(CSTAR1) A '('' ******** MMNEWI - STORAGE ARRAY ISTORE(*) IS FULL'')') *ELSE A 57H(52H ******** MMNEWI - STORAGE ARRAY ISTORE(*) IS FULL)) *ENDIF *ENDIF C 999 CONTINUE RETURN END SUBROUTINE MMPOPC (CTEST, IPOP, CTOP, LEMPTY) C C----------------------------------------------------------------------- C C FAMILY C ------ C MEMORY MANAGER C C PURPOSE C ------- C TO POP CHARACTERS OFF THE SUBSTITUTION STACK C C PARAMETERS C ---------- C CTEST -I- CHARACTER WHOSE PURPOSE DEPENDS ON IPOP C IPOP -I- INDICATES THE OPERATION TO BE PERFORMED C 1 - LOOK AT THE TOP CHARACTER C 2 - POP ONE CHARACTER OFF THE STACK C 3 - POP ONE VARIABLE OFF THE STACK C 4 - POP UNTIL TOP .NE. CTEST C 5 - POP UNTIL TOP .EQ. CTEST C 6 - POP ALL ALPHNUMERICS C CTOP -O- TOP CHARACTER ON STACK C LEMPTY -I- TRUE IF STACK IS EMPTY C C----------------------------------------------------------------------- *INCLUDE(GLCOM) *INCLUDE(IOCOM) *INCLUDE(MMCOM) C C LOCAL VARIABLES AND PARAMETERS C INTEGER IPOP $(ARGDECLAREC) CTEST, CTOP INTEGER ICS *IF(TESTCH) LOGICAL LEMPTY *ELSE LOGICAL L, LEMPTY *ENDIF EXTERNAL MMPOP1, MMPOPV, IOERRM C 10 CONTINUE CTOP = CBLANK C C CHECK FOR NULL ENTRIES ON STACK C IF (ICSP1 .GT. ICSP2) CALL MMPOP1 (LEMPTY) IF (LEMPTY) GO TO 999 GO TO (20, 30, 40, 50, 70, 90), IPOP C C IPOP = 1 - LOOK AT THE TOP OF THE STACK C 20 CONTINUE *IF(NOPACK) CTOP = CSTORE(ICSP1) *ELSE CALL MMGETC (CTOP, ICSP1) *ENDIF GO TO 999 C C IPOP = 2 - POP ONE CHARACTER OFF THE STACK C 30 CONTINUE ICB2 = ICB2 + 1 IF (ICB2 .GT. ICBDIM) GO TO 130 *IF(NOPACK) CBUFFR(ICB2) = CSTORE(ICSP1) *ELSE CALL MMGETC (CBUFFR(ICB2), ICSP1) *ENDIF ICSP1 = ICSP1 + 1 ISTORE(IS2HDS+1) = ICSP1 IF (ICSP1 .GT. ICSP2) CALL MMPOP1 (LEMPTY) *IF(NOPACK) IF (.NOT. LEMPTY) CTOP = CSTORE(ICSP1) *ELSE IF (.NOT. LEMPTY) CALL MMGETC (CTOP, ICSP1) *ENDIF GO TO 999 C C IPOP = 3 - POP ONE VARIABLE OFF THE STACK C 40 CONTINUE ICB2 = ICB2 + 1 IF (ICB2 .GT. ICBDIM) GO TO 130 *IF(NOPACK) CBUFFR(ICB2) = CSTORE(ICSP1) *ELSE CALL MMGETC (CBUFFR(ICB2), ICSP1) *ENDIF ISTORE(IS2HDS+1) = ICSP1 + 1 CALL MMPOPV (LEMPTY) CALL MMPOP1 (LEMPTY) *IF(NOPACK) IF (.NOT. LEMPTY) CTOP = CSTORE(ICSP1) *ELSE IF (.NOT. LEMPTY) CALL MMGETC (CTOP, ICSP1) *ENDIF GO TO 999 C C IPOP = 4 - POP UNTIL TOP CHAR .NE. CTEST C 50 CONTINUE IF (ICSP2-ICSP1 .GE. ICBDIM-ICB2) GO TO 130 DO 60 ICS=ICSP1,ICSP2 *IF(NOPACK) IF (CSTORE(ICS) .NE. CTEST) GO TO 120 ICB2 = ICB2 + 1 CBUFFR(ICB2) = CSTORE(ICS) *ELSE CALL MMGETC (CTOP, ICS) IF (CTOP .NE. CTEST) GO TO 120 ICB2 = ICB2 + 1 CBUFFR(ICB2) = CTOP *ENDIF 60 CONTINUE GO TO 110 C C IPOP = 5 - POP UNTIL TOP CHAR .EQ. CTEST C 70 CONTINUE IF (ICSP2-ICSP1 .GE. ICBDIM-ICB2) GO TO 130 DO 80 ICS=ICSP1,ICSP2 *IF(NOPACK) IF (CSTORE(ICS) .EQ. CTEST) GO TO 120 ICB2 = ICB2 + 1 CBUFFR(ICB2) = CSTORE(ICS) *ELSE CALL MMGETC (CTOP, ICS) IF (CTOP .EQ. CTEST) GO TO 120 ICB2 = ICB2 + 1 CBUFFR(ICB2) = CTOP *ENDIF 80 CONTINUE GO TO 110 C C IPOP = 6 - POP ALL ALPHANUMERICS OFF THE STACK C 90 CONTINUE IF (ICSP2-ICSP1 .GE. ICBDIM-ICB2) GO TO 130 DO 100 ICS=ICSP1,ICSP2 *IF(NOPACK) *IF(TESTCH) *IF(CSTAR1) IF (.NOT. ((LLE(CA,CSTORE(ICS)) A .AND. LLE(CSTORE(ICS),CZ)) B .OR. (LLE(C0,CSTORE(ICS)) C .AND. LLE(CSTORE(ICS),C9)))) GO TO 120 *ELSE IF (.NOT. (((CA .LE. CSTORE(ICS)) A .AND. (CSTORE(ICS) .LE. CZ)) B .OR. ((C0 .LE. CSTORE(ICS)) C .AND. (CSTORE(ICS) .LE. C9)))) GO TO 120 *ENDIF *ELSE CALL UTCHKS (CSTORE(ICS), L) IF (L) GO TO 120 *ENDIF ICB2 = ICB2 + 1 CBUFFR(ICB2) = CSTORE(ICS) *ELSE CALL MMGETC (CTOP, ICS) *IF(TESTCH) *IF(CSTAR1) IF (.NOT.((LLE(CA,CTOP) A .AND. LLE(CTOP,CZ)) B .OR. (LLE(C0,CTOP) C .AND. LLE(CTOP,C9))) GO TO 120 *ELSE IF (.NOT.(((CA .LE. CTOP) A .AND. (CTOP .LE. CZ)) B .OR. ((C0 .LE. CTOP) C .AND. (CTOP .LE. C9))) GO TO 120 *ENDIF *ELSE CALL UTCHKS (CTOP, L) IF (L) GO TO 120 *ENDIF ICB2 = ICB2 + 1 CBUFFR(ICB2) = CTOP *ENDIF 100 CONTINUE C C THE SPECIFIED CONDITION HAS NOT BEEN MET. C GET ANOTHER PIECE OF THE STACK AND TRY AGAIN. C 110 CONTINUE ICSP1 = ICSP2 + 1 ISTORE(IS2HDS+1) = ICSP1 GO TO 10 C C THE SPECIFIED CONDITION HAS BEEN MET. C SAVE THE STACK POINTER AND RETURN. C 120 CONTINUE ICSP1 = ICS ISTORE(IS2HDS+1) = ICS *IF(NOPACK) CTOP = CSTORE(ICS) *ENDIF GO TO 999 C C THE BUFFER SPACE HAS BEEN EXCEEDED C 130 CONTINUE CALL IOERRM (.TRUE., *IF(LIBRARY) *IF(CSTAR1) A '('' +++++++ STRING TOO LONG FOR BUFFER'')') *ELSE A 42H(37H +++++++ STRING TOO LONG FOR BUFFER)) *ENDIF *ELSE *IF(CSTAR1) A '('' ******** MMPOPC - STRING TOO LONG FOR BUFFER'')') *ELSE A 52H(47H ******** MMPOPC - STRING TOO LONG FOR BUFFER)) *ENDIF *ENDIF C 999 CONTINUE RETURN END SUBROUTINE MMPOPV (LEMPTY) C C----------------------------------------------------------------------- C C FAMILY C ------ C MEMORY MANAGER C C PURPOSE C ------- C TO POP A VARIABLE OFF THE SUBSTITUTION STACK C C PARAMETERS C ---------- C LEMPTY -O- TRUE IF THE STACK IS EMPTY C C----------------------------------------------------------------------- *INCLUDE(GLCOM) *INCLUDE(IOCOM) *INCLUDE(MMCOM) C C LOCAL VARIABLES AND PARAMETERS C LOGICAL LEMPTY INTEGER IS2 EXTERNAL MMRETI C LEMPTY = IS2HDS .EQ. 0 IF (LEMPTY) GO TO 999 IS2 = IS2HDS IS2HDS = ISTORE(IS2+2) ISTORE(IS2+2) = 0 LEMPTY = IS2HDS .EQ. 0 IF (ISTORE(IS2) .GT. 0) CALL MMRETI (IS2) C 999 CONTINUE RETURN END SUBROUTINE MMPOP1 (LEMPTY) C C----------------------------------------------------------------------- C C FAMILY C ------ C MEMORY MANAGER C C PURPOSE C ------- C TO POP NULL ENTRIES OFF THE SUBSTITUTION STACK C C PARAMETERS C ---------- C LEMPTY -O- TRUE IF THE STACK IS EMPTY C C----------------------------------------------------------------------- *INCLUDE(GLCOM) *INCLUDE(IOCOM) *INCLUDE(MMCOM) C C LOCAL VARIABLES AND PARAMETERS C LOGICAL LEMPTY INTEGER IS2 EXTERNAL MMPOPV C 10 CONTINUE LEMPTY = IS2HDS .EQ. 0 IF (LEMPTY) GO TO 999 IS2 = IABS(ISTORE(IS2HDS)) IF (IS2 .NE. 0) GO TO 30 20 CONTINUE CALL MMPOPV (LEMPTY) GO TO 10 C 30 CONTINUE ICSP1 = ISTORE(IS2HDS+1) ICSP2 = ISTORE(IS2+1) IF (ICSP1 .LE. ICSP2) GO TO 999 IS2 = ISTORE(IS2+2) IF (IS2 .EQ. 0) GO TO 20 ISTORE(IS2HDS) = ISIGN(IS2, ISTORE(IS2HDS)) ISTORE(IS2HDS+1) = ISTORE(IS2) GO TO 30 C 999 CONTINUE RETURN END SUBROUTINE MMPSHV (CNAME, ICN1, ICN2, IPUSH, LEMPTY, LFOUND) C C----------------------------------------------------------------------- C C FAMILY C ------ C MEMORY MANAGER C C PURPOSE C ------- C TO PUSH A VARIABLE ONTO THE SUBSTITUTION STACK C C PARAMETERS C ---------- C CNAME -I- THE NAME OF THE VARIABLE TO PUSH ONTO THE STACK C ICN1 -I- INDEX OF THE FIRST CHARACTER IN THE NAME C ICN2 -I- INDEX OF THE LAST CHARACTER IN THE NAME C IPUSH -I- INDICATES THE OPERATION TO BE PERFORMED C 1 - PUSH A VARIABLE ONTO THE STACK C 2 - PUSH A POINTER ONTO THE STACK C 3 - PUSH THE ACTUAL POINTER ONTO THE STACK C C----------------------------------------------------------------------- *INCLUDE(GLCOM) *INCLUDE(IOCOM) *INCLUDE(MMCOM) C C LOCAL VARIABLES AND PARAMETERS C INTEGER ICN1, ICN2, IPUSH $(ARGDECLAREC) CNAME(ICN2) LOGICAL LEMPTY, LFOUND INTEGER IH, IS1, IS2, ITEMP EXTERNAL MMHASH, MMNEWI, MMPOP1 C CALL MMHASH (CNAME, ICN1, ICN2, IH, LFOUND) IF (.NOT. LFOUND) GO TO 999 IS1 = IHASH(IH) IS2 = ISTORE(IS1+1) IF (IS2 .EQ. 0) GO TO 999 IF (IPUSH .EQ. 1) GO TO 10 IF (IPUSH .EQ. 2) GO TO 20 GO TO 30 C C PUSH A VARIABLE ONTO THE STACK; NEW ENTRY WILL POINT TO C VALUE OF THE VARIABLE C 10 CONTINUE CALL MMNEWI (ITEMP) ISTORE(ITEMP) = IS2 ISTORE(ITEMP+1) = ISTORE(IS2) ISTORE(ITEMP+2) = IS2HDS IS2HDS = ITEMP GO TO 40 C C PUSH A POINTER ONTO THE STACK C 20 CONTINUE CALL MMNEWI (ITEMP) ISTORE(ITEMP) = ISTORE(IS2) ISTORE(ITEMP+1) = ISTORE(IS2+1) ISTORE(ITEMP+2) = IS2HDS IS2HDS = ITEMP GO TO 40 C C PUSH THE ACTUAL POINTER ONTO THE STACK C 30 CONTINUE ISTORE(IS2) = -IABS(ISTORE(IS2)) ISTORE(IS2+2) = IS2HDS IS2HDS = IS2 C C CALL MMPOP1 TO SET THE POINTERS (ICSP1, ICSP2) INTO CSTORE C 40 CONTINUE CALL MMPOP1 (LEMPTY) C 999 CONTINUE RETURN END *IF(NOPACK) *ELSE SUBROUTINE MMPUTC (CSTORI, ICS) C C----------------------------------------------------------------------- C C FAMILY C ------ C MEMORY MANAGER C C PURPOSE C ------- C TO PUT A CHARACTER INTO CSTORE AT THE INDICATED POSITION. C THIS ROUTINE SHOULD BE REPLACED WITH ONE WHICH PACKS CHARACTERS C INTO CSTORE C C PARAMETERS C ---------- C CSTORI -I- THE CHARACTER TO STORE C ICS -I- THE INDEX INTO CSTORE C C----------------------------------------------------------------------- *INCLUDE(GLCOM) *INCLUDE(IOCOM) *INCLUDE(MMCOM) C C LOCAL VARIABLES AND PARAMETERS C $(ARGDECLAREC) CSTORI C CSTORE(ICS) = CSTORI C RETURN END *ENDIF SUBROUTINE MMPUTP (CNAME, ICN1, ICN2, CPTR, ICP1, ICP2, LFOUND) C C----------------------------------------------------------------------- C C FAMILY C ------ C MEMORY MANAGER C C PURPOSE C ------- C TO PUT A POINTER TO A VARIABLE IN THE SYMBOL TABLE C C PARAMETERS C ---------- C CNAME -I- NAME OF THE VARIABLE C ICN1 -I- INDEX OF THE FIRST CHARACTER IN THE NAME C ICN2 -I- INDEX OF THE LAST CHARACTER IN THE NAME C CPTR -I- NAME OF THE POINTER C ICP1 -I- INDEX OF THE FIRST CHARACTER IN THE POINTER NAME C ICP2 -I- INDEX OF THE LAST CHARACTER IN THE POINTER NAME C LFOUND -O- TRUE IF THE VARIABLE WAS FOUND IN THE TABLE C C----------------------------------------------------------------------- *INCLUDE(GLCOM) *INCLUDE(IOCOM) *INCLUDE(MMCOM) C C LOCAL VARIABLES AND PARAMETERS C INTEGER ICN1, ICN2, ICP1, ICP2 $(ARGDECLAREC) CNAME(ICN2), CPTR(ICP2) LOGICAL L, LFOUND INTEGER IH, IS1, IS2CN, I, IS2 EXTERNAL MMHASH, MMNEWI, MMPUT1 C CALL MMHASH (CNAME, ICN1, ICN2, IH, LFOUND) IF (.NOT. LFOUND) GO TO 999 IS1 = IHASH(IH) IS2CN = ISTORE(IS1+1) CALL MMHASH (CPTR, ICP1, ICP2, IH, L) IF (L) GO TO 10 CALL MMNEWI (IS1) IHASH(IH) = IS1 CALL MMPUT1 (CPTR, ICP1, ICP2, ISTORE(IS1), I) CALL MMNEWI (IS2) ISTORE(IS1+1) = IS2 ISTORE(IS1+2) = 0 GO TO 20 C 10 CONTINUE IS1 = IHASH(IH) IS2 = ISTORE(IS1+1) C 20 CONTINUE IF (IS2CN .NE. 0) GO TO 30 ISTORE(IS2) = 0 ISTORE(IS2+1) = 0 ISTORE(IS2+2) = 0 GO TO 999 C 30 CONTINUE ISTORE(IS2) = IS2CN ISTORE(IS2+1) = ISTORE(IS2CN) ISTORE(IS2+2) = 0 C 999 CONTINUE RETURN END SUBROUTINE MMPUTV (CNAME, ICN1, ICN2, CVALUE, ICV1, ICV2) C C----------------------------------------------------------------------- C C FAMILY C ------ C MEMORY MANAGER C C PURPOSE C ------- C TO PUT A VARIABLE INTO THE SYMBOL TABLE C C PARAMETERS C ---------- C CNAME -I- NAME OF THE VARIABLE C ICN1 -I- INDEX OF THE FIRST CHARACTER IN THE NAME C ICN2 -I- INDEX OF THE LAST CHARACTER IN THE NAME C CVALUE -I- VALUE OF THE VARIABLE C ICV1 -I- INDEX OF THE FIRST CHARACTER IN THE VALUE C ICV2 -I- INDEX OF THE LAST CHARACTER IN THE VALUE C C----------------------------------------------------------------------- *INCLUDE(GLCOM) *INCLUDE(IOCOM) *INCLUDE(MMCOM) C C LOCAL VARIABLES AND PARAMETERS C INTEGER ICN1, ICN2, ICV1, ICV2 $(ARGDECLAREC) CNAME(ICN2), CVALUE(ICV2) LOGICAL LFOUND INTEGER IH, IS1, I EXTERNAL MMHASH, MMNEWI, MMPUT1, MMDEL1 C C HASH THE NAME TO SEE IF IT IS IN THE TABLE. C IF IT IS NOT, STORE A NEW NAME IN THE TABLE. C CALL MMHASH (CNAME, ICN1, ICN2, IH, LFOUND) IF (LFOUND) GO TO 10 CALL MMNEWI (IS1) IHASH(IH) = IS1 CALL MMPUT1 (CNAME, ICN1, ICN2, ISTORE(IS1), I) GO TO 20 C C RETURN THE SPACE ALLOCATED TO THE OLD VALUE C 10 CONTINUE IS1 = IHASH(IH) CALL MMDEL1 (ISTORE(IS1+1)) C C STORE THE NEW VALUE IN THE TABLE C 20 CONTINUE CALL MMPUT1 (CVALUE, ICV1, ICV2, ISTORE(IS1+1), ISTORE(IS1+2)) C RETURN END SUBROUTINE MMPUT1 (CVALUE, ICV1, ICV2, IS2H, IS2T) C C----------------------------------------------------------------------- C C FAMILY C ------ C MEMORY MANAGER C C PURPOSE C ------- C TO PUT A STRING VALUE INTO CHARACTER STORAGE C AND RETURN POINTERS TO ITS LOCATION C C PARAMETERS C ---------- C CVALUE -I- CONTAINS THE CHARACTER STRING C ICV1 -I- INDEX OF THE FIRST CHARACTER IN THE STRING C ICV2 -I- INDEX OF THE LAST CHARACTER IN THE STRING C IS2H -O- POINTER TO THE FIRST BLOCK CONTAINING THE STRING C IS2T -O- POINTER TO THE LAST BLOCK CONTAINING THE STRING C C LOCAL VARIABLES C --------------- C ICV - INDEX OF THE CURRENT CHARACTER IN THE STRING C IS2 - POINTER TO CURRENT BLOCK FOR THE STRING C ICS - INDEX OF CURRENT STORE POSITION IN CSTORE C ICS1 - INDEX OF BEGINNING OF CURRENT CSTORE BLOCK C ICS2 - INDEX OF END OF CURRENT CSTORE BLOCK C ICSTST - INDEX OF LAST CSTORE POSITION NEEDED C ICSMIN - INDEX OF LAST CSTORE POSITION NEEDED IN CURRENT BLOCK C C----------------------------------------------------------------------- *INCLUDE(GLCOM) *INCLUDE(IOCOM) *INCLUDE(MMCOM) C C LOCAL VARIABLES AND PARAMETERS C INTEGER ICV1, ICV2, IS2H, IS2T $(ARGDECLAREC) CVALUE(ICV2) INTEGER ICV, IS2, ICS1, ICS2, ICSTST, ICSMIN, ICS EXTERNAL MMNEWI, IOERRM C IF ((ICV1 .GT. 0) .AND. (ICV1 .LE. ICV2)) GO TO 10 IS2H = 0 IS2T = 0 GO TO 999 C 10 CONTINUE ICV = ICV1 IS2 = IS2HDC IS2H = IS2HDC C C LOOP THROUGH THE LINKED LIST OF AVAILABLE MEMORY BLOCKS C 20 CONTINUE IF (IS2 .EQ. 0) GO TO 60 IS2T = IS2 ICS1 = ISTORE(IS2T) ICS2 = ISTORE(IS2T+1) IS2 = ISTORE(IS2T+2) ICSTST = ICS1 + ICV2 - ICV ICSMIN = MIN0(ICS2, ICSTST) C C STORE CHARACTERS INTO A PARTICULAR BLOCK C DO 30 ICS=ICS1,ICSMIN *IF(NOPACK) CSTORE(ICS) = CVALUE(ICV) *ELSE CALL MMPUTC (CVALUE(ICV), ICS) *ENDIF ICV = ICV + 1 30 CONTINUE IF (ICSTST .GT. ICS2) GO TO 20 C C IF THE LAST BLOCK USED WAS COMPLETELY FILLED, GO TO 40 C IF (ICSTST .NE. ICS2) GO TO 40 IS2HDC = IS2 GO TO 50 C C THE LAST BLOCK OF MEMORY WAS NOT COMPLETELY USED. C PUT A NEW BLOCK ON THE AVAILABLE MEMORY STACK C CORRESPONDING TO THE REMAINING CHARACTERS. C 40 CONTINUE CALL MMNEWI (IS2HDC) ISTORE(IS2HDC) = ICSMIN+1 ISTORE(IS2HDC+1) = ICS2 ISTORE(IS2HDC+2) = IS2 C 50 CONTINUE ISTORE(IS2T+1) = ICSTST ISTORE(IS2T+2) = 0 GO TO 999 C C FATAL ERROR - NO MORE CHARACTER STORAGE SPACE C 60 CONTINUE CALL IOERRM (.TRUE., *IF(LIBRARY) *IF(CSTAR1) A '('' +++++++ STORAGE ARRAY CSTORE(*) FULL'')') *ELSE A 44H(39H +++++++ STORAGE ARRAY CSTORE(*) FULL)) *ENDIF *ELSE *IF(CSTAR1) A '('' ******** MMPUT1 - STORAGE ARRAY CSTORE(*) FULL'')') *ELSE A 54H(49H ******** MMPUT1 - STORAGE ARRAY CSTORE(*) FULL)) *ENDIF *ENDIF C 999 CONTINUE RETURN END SUBROUTINE MMRETI (IS) C C----------------------------------------------------------------------- C C FAMILY C ------ C MEMORY MANAGER C C PURPOSE C ------- C TO RETURN AN INTEGER BLOCK TO THE FREE LIST C C PARAMETERS C ---------- C IS -I- POINTER TO THE BLOCK TO BE RETURNED C C----------------------------------------------------------------------- *INCLUDE(GLCOM) *INCLUDE(IOCOM) *INCLUDE(MMCOM) C INTEGER IS EXTERNAL IOERRM IF (IS .EQ. 0) GO TO 999 IF ((IS .LT. 0) .OR. (IS .GT. ISTDIM) A .OR. (MOD(IS,3) .NE. 1)) GO TO 10 ISTORE(IS+2) = ISFREE ISFREE = IS GO TO 999 C 10 CONTINUE CALL IOERRM (.FALSE., *IF(LIBRARY) *IF(CSTAR1) A '('' +++++++ ATTEMPT TO RETURN INVALID POINTER'')') *ELSE A 49H(44H +++++++ ATTEMPT TO RETURN INVALID POINTER)) *ENDIF *ELSE *IF(CSTAR1) A '('' ******** MMRETI - ATTEMPT TO RETURN INVALID POINTER'')') *ELSE A 59H(54H ******** MMRETI - ATTEMPT TO RETURN INVALID POINTER)) *ENDIF *ENDIF C 999 CONTINUE RETURN END SUBROUTINE MMSETP (CPTR, ICP1, ICP2) C C----------------------------------------------------------------------- C C FAMILY C ------ C MEMORY MANAGER C C PURPOSE C ------- C TO SAVE A POINTER TO THE CURRENT TOP OF THE SUBSTITUTION STACK C C PARAMETERS C ---------- C CPTR -I- NAME OF THE POINTER C ICP1 -I- INDEX OF THE FIRST CHARACTER IN THE NAME C ICP2 -I- INDEX OF THE LAST CHARACTER IN THE NAME C C----------------------------------------------------------------------- *INCLUDE(GLCOM) *INCLUDE(IOCOM) *INCLUDE(MMCOM) C C LOCAL VARIABLES AND PARAMETERS C INTEGER ICP1, ICP2 $(ARGDECLAREC) CPTR(ICP2) LOGICAL LFOUND INTEGER I, IH, IS1, IS2 EXTERNAL MMHASH, MMNEWI, MMPUT1 C CALL MMHASH (CPTR, ICP1, ICP2, IH, LFOUND) IF (.NOT. LFOUND) GO TO 10 IS1 = IHASH(IH) IS2 = ISTORE(IS1+1) GO TO 20 C 10 CONTINUE CALL MMNEWI (IS1) IHASH(IH) = IS1 CALL MMPUT1 (CPTR, ICP1, ICP2, ISTORE(IS1), I) CALL MMNEWI (IS2) ISTORE(IS1+1) = IS2 ISTORE(IS1+2) = 0 C 20 CONTINUE IF (IS2HDS .NE. 0) GO TO 30 ISTORE(IS2) = 0 ISTORE(IS2+1) = 0 ISTORE(IS2+2) = 0 GO TO 999 C 30 CONTINUE ISTORE(IS2) = ISTORE(IS2HDS) ISTORE(IS2+1) = ISTORE(IS2HDS+1) ISTORE(IS2+2) = 0 C 999 CONTINUE RETURN END SUBROUTINE MMTEST (CVALUE, ICV1, ICV2, IS2H, LEQUAL) C C----------------------------------------------------------------------- C C FAMILY C ------ C MEMORY MANAGER C C PURPOSE C ------- C TO SEE IF A GIVEN STRING IS EQUAL TO ONE IN THE SYMBOL TABLE C C PARAMETERS C ---------- C CVALUE -I- CONTAINS THE STRING TO BE TESTED C ICV1 -I- INDEX OF THE FIRST CHARACTER IN THE STRING C ICV2 -I- INDEX OF THE LAST CHARACTER IN THE STRING C IS2H -I- POINTER TO THE STRING IN THE SYMBOL TABLE C LEQUAL -O- TRUE IF THE STRINGS ARE EQUAL C C----------------------------------------------------------------------- *INCLUDE(GLCOM) *INCLUDE(IOCOM) *INCLUDE(MMCOM) C C LOCAL VARIABLES AND PARAMETERS C INTEGER ICV1, ICV2, IS2H $(ARGDECLAREC) CVALUE(ICV2) LOGICAL LEQUAL INTEGER ICS, ICS1, ICS2, ICV, IS2 C ICV = ICV1 IS2 = IS2H LEQUAL = .FALSE. C 10 CONTINUE IF (IS2 .EQ. 0) GO TO 30 ICS1 = ISTORE(IS2) ICS2 = ISTORE(IS2+1) IS2 = ISTORE(IS2+2) IF (ICS2-ICS1 .GT. ICV2-ICV) GO TO 999 DO 20 ICS=ICS1,ICS2 *IF(NOPACK) IF (CSTORE(ICS) .NE. CVALUE(ICV)) GO TO 999 *ELSE CALL MMGETC (CSTORI, ICS) IF (CSTORI .NE. CVALUE(ICV)) GO TO 999 *ENDIF ICV = ICV + 1 20 CONTINUE GO TO 10 C 30 CONTINUE LEQUAL = ICV .GT. ICV2 C 999 CONTINUE RETURN END SUBROUTINE MPEOL C C----------------------------------------------------------------------- C C FAMILY C ------ C MACRO PROCESSOR C C PURPOSE C ------- C TO REMOVE TRAILING BLANKS AND ADD AN END-OF-LINE MARKER C TO THE LINE IN THE INPUT/OUTPUT BUFFER C C----------------------------------------------------------------------- *INCLUDE(GLCOM) *INCLUDE(IOCOM) *INCLUDE(MMCOM) *INCLUDE(MPCOM) C C LOCAL VARIABLES AND PARAMETERS C $(DECLAREC) C EXTERNAL MMPOPC C CALL MMPOPC (C, 2, CTOP, LEMPTY) ICBEOL = ICB2 ICBEND = ICBEOL ICB2 = ICB2 - 2 ICB3 = ICB2 IF (ICB1 .GT. ICB2) GO TO 999 IF (CBUFFR(ICB2) .NE. CBLANK) GO TO 999 C C REMOVE TRAILING BLANKS C 10 CONTINUE ICB2 = ICB2 - 1 IF (ICB1 .GT. ICB2) GO TO 20 IF (CBUFFR(ICB2) .EQ. CBLANK) GO TO 10 C C ADD THE END-OF-LINE MARKER C 20 CONTINUE CBUFFR(ICB2+1) = CSUB CBUFFR(ICB2+2) = CEOL ICB3 = ICB2 ICBEOL = ICB2 + 2 ICBEND = ICBEOL C 999 CONTINUE RETURN END SUBROUTINE MPITEM C C----------------------------------------------------------------------- C C FAMILY C ------ C MACRO PROCESSOR C C PURPOSE C ------- C TO PUSH THE NEXT ITEM IN A LIST ONTO THE SUBSTITUTION STACK C C----------------------------------------------------------------------- *INCLUDE(GLCOM) *INCLUDE(IOCOM) *INCLUDE(MMCOM) *INCLUDE(MPCOM) C C LOCAL VARIABLES AND PARAMETERS C LOGICAL LERROR, LFOUND INTEGER ICN1, ICN2, ICP1, ICP2 EXTERNAL MPPOPN, UTBLDN, MMPSHV, MMPUTP, IOERRM C CALL MPPOPN (ICN1, ICN2, LERROR) ICP1 = ICB2 + 1 CALL UTBLDN (CDIV, CBUFFR, ICN1, ICN2, 1, A CBUFFR, ICP1, ICP2, ICBDIM, LERROR) CALL MMPSHV (CBUFFR, ICP1, ICP2, 3, LEMPTY, LFOUND) IF (LFOUND) GO TO 10 CALL MMPUTP (CBUFFR, ICN1, ICN2, CBUFFR, ICP1, ICP2, LFOUND) IF (.NOT. LFOUND) GO TO 20 CALL MMPSHV (CBUFFR, ICP1, ICP2, 3, LEMPTY, LFOUND) C 10 CONTINUE ICB2 = ICBSUB - 1 GO TO 999 C 20 CONTINUE CALL IOERRM (.FALSE., *IF(LIBRARY) *IF(CSTAR1) A '('' +++++++ VARIABLE NOT DEFINED'')') *ELSE A 36H(31H +++++++ VARIABLE NOT DEFINED)) *ENDIF *ELSE *IF(CSTAR1) A '('' ******** MPITEM - VARIABLE NOT DEFINED'')') *ELSE A 46H(41H ******** MPITEM - VARIABLE NOT DEFINED)) *ENDIF *ENDIF C 999 CONTINUE RETURN END SUBROUTINE MPLABL C C----------------------------------------------------------------------- C C FAMILY C ------ C MACRO PROCESSOR C C PURPOSE C ------- C TO COPY THE CURRENT LABEL TO THE BUFFER AND THEN C INCREMENT AND SAVE ITS VALUE C C----------------------------------------------------------------------- *INCLUDE(GLCOM) *INCLUDE(IOCOM) *INCLUDE(MMCOM) *INCLUDE(MPCOM) C C LOCAL VARIABLES AND PARAMETERS C INTEGER I, ICV1, ICV2, ICV2M4, ICV1M1 $(DECLAREC) C(5) LOGICAL L INTEGER ICNDIM EXTERNAL MMGETV, UTCVCI, UTCVIC, MMPUTV, IOERRM *IF(CSTAR1) SAVE ICNDIM, C *ENDIF DATA ICNDIM / 5 / DATA C(1), C(2), C(3), C(4), C(5) *IF(CSTAR1) A / 'L', 'A', 'B', 'E', 'L' / *ELSE A / 1HL, 1HA, 1HB, 1HE, 1HL / *ENDIF C C GET CURRENT VALUE OF LABEL, CONVERT TO AN INTEGER AND C CHECK IT. ADD ONE, CONVERT BACK TO CHARACTERS AND PLACE C IN CBUFFR C ICV1 = ICB2 + 5 CALL MMGETV (C, 1, ICNDIM, CBUFFR, ICV1, ICV2, ICBDIM, L) IF (.NOT. L) GO TO 40 CALL UTCVCI (CBUFFR, ICV1, ICV2, I, L) IF ((I .LT. 0) .OR. (99999 .LT. I)) GO TO 40 I = I + 1 CALL UTCVIC (CBUFFR, ICV1, ICV2, ICBDIM, I, L) ICV2M4 = ICV2 - 4 ICV1M1 = ICV1 - 1 IF (ICV2M4 .GT. ICV1M1) GO TO 20 C DO 10 I=ICV2M4,ICV1M1 CBUFFR(I) = CBLANK 10 CONTINUE C 20 CONTINUE CALL MMPUTV (C, 1, ICNDIM, CBUFFR, ICV2M4, ICV2) ICB2 = ICBSUB - 1 DO 30 I=ICV2M4,ICV2 ICB2 = ICB2 + 1 CBUFFR(ICB2) = CBUFFR(I) 30 CONTINUE GO TO 999 C C WARNING - INVALID LABEL VALUE C 40 CONTINUE CALL IOERRM (.FALSE., *IF(LIBRARY) *IF(CSTAR1) A '('' +++++++ ILLEGAL LABEL VALUE'')') *ELSE A 35H(30H +++++++ ILLEGAL LABEL VALUE)) *ENDIF *ELSE *IF(CSTAR1) A '('' ******** MPLABL - ILLEGAL LABEL VALUE'')') *ELSE A 45H(40H ******** MPLABL - ILLEGAL LABEL VALUE)) *ENDIF *ENDIF C 999 CONTINUE RETURN END SUBROUTINE MPLINE (LSUBL) C C----------------------------------------------------------------------- C C FAMILY C ------ C MACRO PROCESSOR C C PURPOSE C ------- C TO BUILD THE NEXT LINE IN THE I/O BUFFER C C PARAMETERS C ---------- C LSUBL -I- LOCAL SUBSTITUTION FLAG INDICATING WHETHER C OR NOT MACROS ON THIS LINE ARE TO BE EXPANDED C C----------------------------------------------------------------------- *INCLUDE(GLCOM) *INCLUDE(IOCOM) *INCLUDE(MMCOM) *INCLUDE(MPCOM) C C LOCAL VARIABLES AND PARAMETERS C INTEGER ICB $(DECLAREC) C(2) LOGICAL LEOL, LFOUND, LSUBL INTEGER ICNDIM EXTERNAL MMPOPC, MPSUBS, IOREAD, MMPUTV, MMPSHV *IF(CSTAR1) SAVE ICNDIM, C *ENDIF DATA ICNDIM / 2 / *IF(CSTAR1) DATA C(1), C(2) /'*', 'L' / *ELSE DATA C(1), C(2) /1H*, 1HL / *ENDIF C C SET I/O BUFFER POINTERS C ICB0 = ICBEOL + 1 ICB1 = ICBEOL + 1 ICB2 = ICBEOL IF (LEMPTY) GO TO 20 C C IF THE STACK IS NONEMPTY, POP INTO THE I/O BUFFER UNTIL A C SUB. CHAR. IS FOUND. THEN CALL MPSUBS. C 10 CONTINUE CALL MMPOPC (CSUB, 5, CTOP, LEMPTY) IF (LEMPTY) GO TO 20 CALL MPSUBS (LEOL, LSUBL) IF (LEOL) GO TO 999 GO TO 10 C C IF THE STACK IS EMPTY, GET MORE INPUT C 20 CONTINUE CALL IOREAD IF ((.NOT. LSUBL) .OR. (ICB1 .GT. ICB2)) GO TO 999 C C LOOK FOR SUBSTITUTION CHARACTER C DO 30 ICB=ICB1,ICB2 IF (CBUFFR(ICB) .EQ. CSUB) GO TO 40 30 CONTINUE GO TO 999 C C WHEN A SUB. CHAR IS FOUND, PUT THE VARIABLE '*L' IN THE C SYMBOL TABLE. THE VALUE OF THIS SPECIAL VARIABLE IS THE C REST OF THE LINE. ALSO PUSH *L ONTO THE SUBST. STACK. C 40 CONTINUE CALL MMPUTV (C, 1, ICNDIM, CBUFFR, ICB, ICBEOL) CALL MMPSHV (C, 1, ICNDIM, 1, LEMPTY, LFOUND) ICB2 = ICB - 1 CALL MPSUBS (LEOL, LSUBL) IF (.NOT. LEOL) GO TO 10 C 999 CONTINUE RETURN END SUBROUTINE MPMAC C C----------------------------------------------------------------------- C C FAMILY C ------ C MACRO PROCESSOR C C PURPOSE C ------- C TO DETERMINE THE TYPE OF MACRO EXPANSION INDICATED C AND CALL THE APPROPRIATE ROUTINES C C----------------------------------------------------------------------- *INCLUDE(GLCOM) *INCLUDE(IOCOM) *INCLUDE(MMCOM) *INCLUDE(MPCOM) C C LOCAL VARIABLES AND PARAMETERS C $(DECLAREC) C(12) INTEGER IK(3) INTEGER IKYDIM, ICKDIM, ICN1, ICN2, ICN1SV, I, A ICL1NA, ICL2NA, IH LOGICAL LERROR, LFOUND EXTERNAL MMHASH, MPPOPN, UTRDKY, UTRDNA, MMPSHV, A UTCVLC, MPLABL, MPITEM, IOERRM *IF(CSTAR1) SAVE IKYDIM, IK, ICKDIM, C *ENDIF DATA A IKYDIM, ICKDIM, B IK(1), C IK(2), D IK(3) E / 3, 12, F 3, G 5, H 4 / DATA B C(1), C(2), C(3), C C(4), C(5), C(6), C(7), C(8), D C(9), C(10), C(11), C(12) E / *IF(CSTAR1) F 'D', 'E', 'F', G 'L', 'A', 'B', 'E', 'L', H 'L', 'I', 'S', 'T' / *ELSE F 1HD, 1HE, 1HF, G 1HL, 1HA, 1HB, 1HE, 1HL, H 1HL, 1HI, 1HS, 1HT / *ENDIF C C MARK THE CURRENT LINE POSITION, POP THE NAME OFF THE STACK, C AND THEN DETERMINE THE TYPE OF SUBSTITUTION C ICBSUB = ICB2 CALL MPPOPN (ICN1, ICN2, LERROR) IF (LERROR) GO TO 999 ICN1SV = ICN1 CALL UTRDKY (CBUFFR, ICN1, ICN2, IK, IKYDIM, C, ICKDIM, I) IF(I.GT.IKYDIM) GO TO 10 C C CHECK IF WE ONLY HAPPENED TO MATCH A PREFIX C CALL UTRDNA (CBUFFR, ICN1, ICN2, ICL1NA, ICL2NA, LERROR) IF(LERROR) 1 GO TO (20, 30, 40), I C C IF SO, RESTORE ORIGINAL STATE AND PROCESS VARIABLE SUBSTITUTION C ICN1 = ICN1SV GO TO 10 C C A SIMPLE MACRO SUBSTITUTION HAS BEEN FOUND. C PUSH THE NEW NAME ONTO THE STACK C AND RESET THE CURRENT LINE POINTER. C SUBSEQUENT POPPING OF THE STACK WILL PUT THE VALUE C OF THE MACRO INTO THE I/O BUFFER. C 10 CONTINUE CALL MMPSHV (CBUFFR, ICN1, ICN2, 1, LEMPTY, LFOUND) IF (.NOT. LFOUND) GO TO 50 ICB2 = ICBSUB - 1 GO TO 999 C C A DEF SUBSTITUTION HAS BEEN ENCOUNTERED C 20 CONTINUE CALL MPPOPN (ICN1, ICN2, LERROR) CALL MMHASH (CBUFFR, ICN1, ICN2, IH, LFOUND) CALL UTCVLC (CBUFFR, ICBSUB, ICB2, ICBDIM, LFOUND, LERROR) GO TO 999 C C A LABEL SUBSTITUTION HAS BEEN ENCOUNTERED C 30 CONTINUE CALL MPLABL GO TO 999 C C A LIST SUBSTITUTION HAS POSSIBLY BEEN ENCOUNTERED C 40 CONTINUE CALL MPITEM GO TO 999 C C WARNING - NAME NOT FOUND IN SYMBOL TABLE C 50 CONTINUE CALL IOERRM (.FALSE., *IF(LIBRARY) *IF(CSTAR1) A '('' +++++++ VARIABLE NOT DEFINED'')') *ELSE A 36H(31H +++++++ VARIABLE NOT DEFINED)) *ENDIF *ELSE *IF(CSTAR1) A '('' ******** MPMAC - VARIABLE NOT DEFINED'')') *ELSE A 46H(41H ******** MPMAC - VARIABLE NOT DEFINED)) *ENDIF *ENDIF C 999 CONTINUE RETURN END SUBROUTINE MPPOPN (ICN1, ICN2, LERROR) C C----------------------------------------------------------------------- C C FAMILY C ------ C MACRO PROCESSOR C C PURPOSE C ------- C TO POP A NAME OFF THE SUBSTITUTION STACK INTO THE I/O BUFFER C C PARAMETERS C ---------- C ICN1 -O- INDEX IN THE BUFFER OF THE FIRST CHARACTER C IN THE NAME C ICN2 -O- INDEX OF THE LAST CHARACTER C LERROR -O- TRUE IF THE NAME WAS INVALID C C----------------------------------------------------------------------- *INCLUDE(GLCOM) *INCLUDE(IOCOM) *INCLUDE(MMCOM) *INCLUDE(MPCOM) C C LOCAL VARIABLES AND PARAMETERS C INTEGER ICN1, ICN2 $(DECLAREC) C LOGICAL LEFT, LERROR EXTERNAL MMPOPC, IOERRM C C POP BLANKS; LOOK FOR LEFT PAREN. C CALL MMPOPC (CBLANK, 4, CTOP, LEMPTY) LEFT = CLEFT .EQ. CTOP IF (.NOT. LEFT) GO TO 10 CALL MMPOPC (C, 2, CTOP, LEMPTY) CALL MMPOPC (CBLANK, 4, CTOP, LEMPTY) C 10 CONTINUE ICN1 = ICB2 + 1 C C CHECK FOR A LEGAL NAME C *IF(TESTCH) *IF(CSTAR1) LERROR = .NOT. (LLE(CA,CTOP) A .AND. LLE(CTOP,CZ)) *ELSE LERROR = .NOT. ((CA .LE. CTOP) A .AND. (CTOP .LE. CZ)) *ENDIF *ELSE CALL UTCHKA (CTOP, L) LERROR = .NOT. L *ENDIF IF (LERROR) GO TO 20 C C POP THE CHAR'S OF THE NAME OFF C CALL MMPOPC (C, 6, CTOP, LEMPTY) ICN2 = ICB2 IF (.NOT. LEFT) GO TO 999 CALL MMPOPC (CBLANK, 4, CTOP, LEMPTY) LERROR = CRIGHT .NE. CTOP IF (LERROR) GO TO 30 CALL MMPOPC (C, 2, CTOP, LEMPTY) GO TO 999 C C WARNING - ILLEGAL NAME C 20 CONTINUE CALL IOERRM (.FALSE., *IF(LIBRARY) *IF(CSTAR1) A '('' +++++++ ILLEGAL VARIABLE NAME'')') *ELSE A 37H(32H +++++++ ILLEGAL VARIABLE NAME)) *ENDIF *ELSE *IF(CSTAR1) A '('' ******** MPPOPN - ILLEGAL VARIABLE NAME'')') *ELSE A 47H(42H ******** MPPOPN - ILLEGAL VARIABLE NAME)) *ENDIF *ENDIF GO TO 999 C C WARNING - NO CLOSING RIGHT PARENTHESIS C 30 CONTINUE CALL IOERRM (.FALSE., *IF(LIBRARY) *IF(CSTAR1) A '('' +++++++ MISSING RIGHT PARENTHESIS'')') *ELSE A 41H(36H +++++++ MISSING RIGHT PARENTHESIS)) *ENDIF *ELSE *IF(CSTAR1) A '('' ******** MPPOPN - MISSING RIGHT PARENTHESIS'')') *ELSE A 51H(46H ******** MPPOPN - MISSING RIGHT PARENTHESIS)) *ENDIF *ENDIF C 999 CONTINUE RETURN END SUBROUTINE MPSUBS (LEOL, LSUBL) C C----------------------------------------------------------------------- C C FAMILY C ------ C MACRO PROCESSOR C C PURPOSE C ------- C TO EVALUATE OF THE SUBSTITUTION ESCAPE CHARACTER C AND DECIDE WHAT ACTION IS TO BE TAKEN C C PARAMETERS C ---------- C LEOL -O- TRUE IF AN END-OF-LINE MARKER WAS FOUND C LSUBL -I- TRUE IF NO SUBSTITUTION IS TO BE PERFORMED C ON THIS LINE C C----------------------------------------------------------------------- *INCLUDE(GLCOM) *INCLUDE(IOCOM) *INCLUDE(MMCOM) *INCLUDE(MPCOM) C C LOCAL VARIABLES AND PARAMETERS C $(DECLAREC) C LOGICAL LEOL, LSUBL EXTERNAL MPEOL, MPMAC, MMPOPC C C DETERMINE WHAT FOLLOWS THE SUBSTITUTION PREFIX CHARACTER C LEOL = .FALSE. CALL MMPOPC (C, 2, CTOP, LEMPTY) IF (CEOL .EQ. CTOP) GO TO 10 IF (CEOR .EQ. CTOP) GO TO 20 IF (CONC .EQ. CTOP) GO TO 30 IF (.NOT. (LSUB .AND. LSUBL)) GO TO 999 IF (CSUB .EQ. CTOP) GO TO 40 GO TO 50 C C PROCESS AN END-OF-LINE MARKER C 10 CONTINUE CALL MPEOL LEOL = .TRUE. GO TO 999 C C PROCESS AN END-OF-RECORD MARKER C 20 CONTINUE CALL MMPOPC (C, 3, CTOP, LEMPTY) ICB2 = ICB2 - 2 GO TO 999 C C PROCESS A CONTINUATION CHARACTER C 30 CONTINUE CALL MMPOPC (C, 2, CTOP, LEMPTY) CALL MMPOPC (C, 2, CTOP, LEMPTY) CALL MMPOPC (C, 2, CTOP, LEMPTY) ICB2 = ICB2 - 4 GO TO 999 C C PROCESS AN EMBEDDED SUBSTITUTION PREFIX CHARACTER C 40 CONTINUE CALL MMPOPC (C, 2, CTOP, LEMPTY) ICB2 = ICB2 - 1 GO TO 999 C C A LIST OR MACRO SUBSTITUTION HAS BEEN ENCOUNTERED C 50 CONTINUE CALL MPMAC C 999 CONTINUE RETURN END SUBROUTINE TPAPPE C C----------------------------------------------------------------------- C C FAMILY C ------ C TEMPLATE PROCESSOR C C PURPOSE C ------- C TO PROCESS APPEND DIRECTIVES C C----------------------------------------------------------------------- *INCLUDE(GLCOM) *INCLUDE(IOCOM) *INCLUDE(MMCOM) *INCLUDE(MPCOM) *INCLUDE(TPCOM) C C LOCAL VARIABLES AND PARAMETERS C $(DECLAREC) C(15) INTEGER ID(7), IK(3) INTEGER IKYDIM, ICKDIM, IDSDIM LOGICAL LERROR EXTERNAL TPSYNT, TPRDBL, MMAPPV, IOERRM *IF(CSTAR1) SAVE IKYDIM, IK, ICKDIM, C, IDSDIM, ID *ENDIF DATA A IKYDIM, ICKDIM, B IK(1), C IK(2), D IK(3) E / 3, 15, F 6, G 6, H 3 / DATA B C(1), C(2), C(3), C(4), C(5), C(6), C C(7), C(8), C(9), C(10), C(11), C(12), D C(13), C(14), C(15) E / *IF(CSTAR1) F 'A', 'P', 'P', 'E', 'N', 'D', G 'E', 'N', 'D', 'A', 'P', 'P', H 'E', 'N', 'D' / *ELSE F 1HA, 1HP, 1HP, 1HE, 1HN, 1HD, G 1HE, 1HN, 1HD, 1HA, 1HP, 1HP, H 1HE, 1HN, 1HD / *ENDIF DATA A IDSDIM, B ID(1), ID(2), ID(3), ID(4), ID(5), ID(6), ID(7) C / 7, D 1, 5, -3, 6, 6, 2, 7 / C C CHECK SYNTAX C CALL TPSYNT (ID, IDSDIM, .FALSE., LERROR) IF (LERROR) GO TO 999 IF (IARGS .EQ. 2) GO TO 10 C C PROCESS A MULTI-LINE APPEND STATEMENT C ICBP1(2) = ICBEOL + 1 C C READ A BLOCK; UNTIL *ENDAPP C CALL TPRDBL (IK, IKYDIM, C, ICKDIM, ID, IDSDIM, A .TRUE., .FALSE., .TRUE., LERROR) IF (LEND) GO TO 20 IF (LERROR) GO TO 999 ICBP2(2) = ICB0 - 1 C C APPEND THE VALUE C 10 CONTINUE CALL MMAPPV (CBUFFR, ICBP1(1), ICBP2(1), A CBUFFR, ICBP1(2), ICBP2(2)) GO TO 999 C 20 CONTINUE CALL IOERRM (.FALSE., *IF(LIBRARY) *IF(CSTAR1) A '('' +++++++ APPEND HAS NO MATCHING ENDAPP'')') *ELSE A 45H(40H +++++++ APPEND HAS NO MATCHING ENDAPP)) *ENDIF *ELSE *IF(CSTAR1) A '('' ******** TPAPPE - APPEND HAS NO MATCHING ENDAPP'')') *ELSE A 55H(50H ******** TPAPPE - APPEND HAS NO MATCHING ENDAPP)) *ENDIF *ENDIF C 999 CONTINUE RETURN END SUBROUTINE TPCHKD C C----------------------------------------------------------------------- C C FAMILY C ------ C TEMPLATE PROCESSOR C C PURPOSE C ------- C TO DETERMINE IF A LINE CONTAINS A DIRECTIVE C C----------------------------------------------------------------------- *INCLUDE(GLCOM) *INCLUDE(IOCOM) *INCLUDE(MMCOM) *INCLUDE(MPCOM) *INCLUDE(TPCOM) C C LOCAL VARIABLES AND PARAMETERS C LOGICAL LEOL EXTERNAL UTRDBL C LDIRL = .FALSE. IF (ICB1 .GT. ICB2) GO TO 999 IF (CBUFFR(ICB1) .EQ. CDIR) GO TO 10 IF (LCOL1) GO TO 999 CALL UTRDBL (CBUFFR, ICB1, ICB2, LEOL) IF (LEOL) GO TO 999 IF (CBUFFR(ICB1) .NE. CDIR) GO TO 999 C 10 CONTINUE ICB1 = ICB1 + 1 LDIRL = .TRUE. C 999 CONTINUE RETURN END SUBROUTINE TPCOMM C C----------------------------------------------------------------------- C C FAMILY C ------ C TEMPLATE PROCESSOR C C PURPOSE C ------- C TO PROCESS COMMENT DIRECTIVES C C----------------------------------------------------------------------- *INCLUDE(GLCOM) *INCLUDE(IOCOM) *INCLUDE(MMCOM) *INCLUDE(MPCOM) *INCLUDE(TPCOM) C C LOCAL VARIABLES AND PARAMETERS C $(DECLAREC) C(16) INTEGER ID(1), IK(3) INTEGER IKYDIM, ICKDIM, IDSDIM LOGICAL LERROR EXTERNAL TPSYNT, TPRDBL, IOERRM *IF(CSTAR1) SAVE IKYDIM, IK, ICKDIM, C, IDSDIM, ID *ENDIF DATA IDSDIM, ID(1) / 1, 7 / DATA A IKYDIM, ICKDIM, B IK(1), C IK(2), D IK(3) E / 3, 16, F 7, G 6, H 3 / DATA B C(1), C(2), C(3), C(4), C(5), C(6), C(7), C C(8), C(9), C(10), C(11), C(12), C(13), D C(14), C(15), C(16) E / *IF(CSTAR1) F 'C', 'O', 'M', 'M', 'E', 'N', 'T', G 'E', 'N', 'D', 'C', 'O', 'M', H 'E', 'N', 'D' / *ELSE F 1HC, 1HO, 1HM, 1HM, 1HE, 1HN, 1HT, G 1HE, 1HN, 1HD, 1HC, 1HO, 1HM, H 1HE, 1HN, 1HD / *ENDIF C C CHECK SYNTAX C CALL TPSYNT (ID, IDSDIM, .FALSE., LERROR) IF (LERROR) GO TO 999 C C READ A BLOCK; UNTIL *ENDCOM C CALL TPRDBL (IK, IKYDIM, C, ICKDIM, ID, IDSDIM, A .FALSE., .TRUE., .FALSE., LERROR) IF (.NOT. LEND) GO TO 999 C C AN -END- HAS POSSIBLY BEEN ENCOUNTERED C CALL IOERRM (.FALSE., *IF(LIBRARY) *IF(CSTAR1) A '('' +++++++ COMMENT HAS NO MATCHING ENDCOM'')') *ELSE A 46H(41H +++++++ COMMENT HAS NO MATCHING ENDCOM)) *ENDIF *ELSE *IF(CSTAR1) A '('' ******** TPCOMM - COMMENT HAS NO MATCHING ENDCOM'')') *ELSE A 56H(51H ******** TPCOMM - COMMENT HAS NO MATCHING ENDCOM)) *ENDIF *ENDIF C 999 CONTINUE RETURN END SUBROUTINE TPDELE C C----------------------------------------------------------------------- C C FAMILY C ------ C TEMPLATE PROCESSOR C C PURPOSE C ------- C TO PROCESS DELETE DIRECTIVES C C----------------------------------------------------------------------- *INCLUDE(GLCOM) *INCLUDE(IOCOM) *INCLUDE(MMCOM) *INCLUDE(MPCOM) *INCLUDE(TPCOM) C C LOCAL VARIABLES AND PARAMETERS C INTEGER ID(4) INTEGER IDSDIM LOGICAL LERROR, LFOUND EXTERNAL TPSYNT, MMDELV *IF(CSTAR1) SAVE IDSDIM, ID *ENDIF DATA IDSDIM, ID(1), ID(2), ID(3), ID(4) A / 4, 1, 5, 2, 7 / C C CHECK SYNTAX C CALL TPSYNT (ID, IDSDIM, .FALSE., LERROR) IF (LERROR) GO TO 999 C C DELETE THE VARIABLE C CALL MMDELV (CBUFFR, ICBP1(1), ICBP2(1), LFOUND) C 999 CONTINUE RETURN END SUBROUTINE TPDO C C----------------------------------------------------------------------- C C FAMILY C ------ C TEMPLATE PROCESSOR C C PURPOSE C ------- C TO PROCESS DO DIRECTIVES C C----------------------------------------------------------------------- *INCLUDE(GLCOM) *INCLUDE(IOCOM) *INCLUDE(MMCOM) *INCLUDE(MPCOM) *INCLUDE(TPCOM) C C LOCAL VARIABLES AND PARAMETERS C $(DECLAREC) C(10), CD(1), CIN(1) INTEGER ID(11), IK(3) LOGICAL LERROR, LFOUND INTEGER IKYDIM, ICKDIM, ICN1, ICN2, I1, I2, I3, ITEMP, A ICV1 INTEGER ICDDIM, ICIDIM, IDSDIM EXTERNAL TPSYNT, UTBLDN, MMPUTV, UTCVCI, TPRDBL, A MMNEWI, MMPSHV, MMSETP, IOERRM *IF(CSTAR1) SAVE ICDDIM, CD, ICIDIM, CIN SAVE IKYDIM, IK, ICKDIM, C, IDSDIM, ID *ENDIF DATA ICDDIM / 1 / *IF(CSTAR1) DATA CD(1) / 'D' / *ELSE DATA CD(1) / 1HD / *ENDIF DATA ICIDIM / 1 / *IF(CSTAR1) DATA CIN(1) / 'I' / *ELSE DATA CIN(1) / 1HI / *ENDIF DATA A IKYDIM,ICKDIM,IK(1),IK(2),IK(3) B / 3, 10, 2, 5, 3 / DATA A C(1), C(2), B C(3), C(4), C(5), C(6), C(7), C C(8), C(9), C(10) *IF(CSTAR1) D / 'D', 'O', E 'E', 'N', 'D', 'D', 'O', F 'E', 'N', 'D' / *ELSE D / 1HD, 1HO, E 1HE, 1HN, 1HD, 1HD, 1HO, F 1HE, 1HN, 1HD / *ENDIF DATA A IDSDIM, B ID(1), ID(2), ID(3), ID(4), ID(5), C ID(6), ID(7), ID(8), ID(9), ID(10), ID(11) D / 11, E 1, 5, 4, 6, 3, F 6, -3, 10, 6, 2, 7 / C C CHECK SYNTAX C CALL TPSYNT (ID, IDSDIM, .FALSE., LERROR) IF (LERROR) GO TO 999 INESTD = INESTD + 1 ICN1 = ICBEND + 1 C C GET LOOP INDEX AND LOOP PARAMETERS C CALL UTBLDN (CSTAR, CIN, 1, ICIDIM, INESTD, A CBUFFR, ICN1, ICN2, ICBDIM, LERROR) ICBEND = ICN2 CALL MMPUTV (CBUFFR, ICN1, ICN2, A CBUFFR, ICBP1(1), ICBP2(1)) CALL MMPUTV (CBUFFR, ICBP1(1), ICBP2(1), A CBUFFR, ICBP1(2), ICBP2(2)) CALL UTCVCI (CBUFFR, ICBP1(2), ICBP2(2), I1, LERROR) CALL UTCVCI (CBUFFR, ICBP1(3), ICBP2(3), I2, LERROR) I3 = 1 IF (IARGS .EQ. 4) A CALL UTCVCI (CBUFFR, ICBP1(4), ICBP2(4), I3, LERROR) IF (L1TRIP .OR. ((I2-I1)*ISIGN(1,I3) .GE. 0)) GO TO 10 CALL TPRDBL (IK, IKYDIM, C, ICKDIM, ID, IDSDIM, A .FALSE., .TRUE., .FALSE., LERROR) IF (LEND) GO TO 30 INESTD = INESTD - 1 GO TO 999 C 10 CONTINUE CALL MMNEWI (ITEMP) ISTORE(ITEMP) = I2 ISTORE(ITEMP+1) = I3 ISTORE(ITEMP+2) = ITOPDO ITOPDO = ITEMP IF (INESTD .GT. 1) GO TO 20 CALL UTBLDN (CSTAR, CD, 1, ICDDIM, -1, A CBUFFR, 1, ICN2, ICBDIM, LERROR) ICBEOL = ICN2 ICV1 = ICN2 + 1 C C READ A BLOCK UNTIL *ENDDO. PUSH CONTENTS OF DO RANGE C ONTO STACK. C CALL TPRDBL (IK, IKYDIM, C, ICKDIM, ID, IDSDIM, A .FALSE., .FALSE., .FALSE., LERROR) IF (LEND) GO TO 30 CALL MMPUTV (CBUFFR, 1, ICN2, CBUFFR, ICV1, ICBEOL) CALL MMPSHV (CBUFFR, 1, ICN2, 1, LEMPTY, LFOUND) C 20 CONTINUE CALL UTBLDN (CSTAR, CD, 1, ICDDIM, INESTD, A CBUFFR, 1, ICN2, ICBDIM, LERROR) CALL MMSETP (CBUFFR, 1, ICN2) GO TO 999 C C WARNING - MATCHING ENDDO NOT FOUND C 30 CONTINUE CALL IOERRM (.FALSE., *IF(LIBRARY) *IF(CSTAR1) A '('' +++++++ DO HAS NO MATCHING ENDDO'')') *ELSE A 40H(35H +++++++ DO HAS NO MATCHING ENDDO)) *ENDIF *ELSE *IF(CSTAR1) A '('' ******** TPDO - DO HAS NO MATCHING ENDDO'')') *ELSE A 50H(45H ******** TPDO - DO HAS NO MATCHING ENDDO)) *ENDIF *ENDIF C 999 CONTINUE RETURN END SUBROUTINE TPELSE C C----------------------------------------------------------------------- C C FAMILY C ------ C TEMPLATE PROCESSOR C C PURPOSE C ------- C TO PROCESS ELSE DIRECTIVES C C----------------------------------------------------------------------- *INCLUDE(GLCOM) *INCLUDE(IOCOM) *INCLUDE(MMCOM) *INCLUDE(MPCOM) *INCLUDE(TPCOM) C C LOCAL VARIABLES AND PARAMETERS C $(DECLAREC) C(10) INTEGER ID(1), IDIF(4), IK(3) LOGICAL LERROR INTEGER IDSDIM, IDSDIF, IKYDIM, ICKDIM EXTERNAL TPSYNT, TPRDBL, IOERRM *IF(CSTAR1) SAVE IKYDIM, IK, ICKDIM, C, IDSDIM, ID, IDSDIF, IDIF *ENDIF DATA IDSDIM, ID(1) / 1, 7 / DATA A IDSDIF, B IDIF(1), IDIF(2), IDIF(3), IDIF(4) C / 4, D 1, 6, 2, 8 / DATA A IKYDIM, ICKDIM, IK(1), IK(2), IK(3) B / 3, 10, 2, 5, 3 / DATA A C(1), C(2), B C(3), C(4), C(5), C(6), C(7), C C(8), C(9), C(10) / *IF(CSTAR1) D 'I', 'F', E 'E', 'N', 'D', 'I', 'F', F 'E', 'N', 'D' / *ELSE D 1HI, 1HF, E 1HE, 1HN, 1HD, 1HI, 1HF, F 1HE, 1HN, 1HD / *ENDIF C C CHECK SYNTAX C CALL TPSYNT (ID, IDSDIM, .FALSE., LERROR) IF (LERROR) GO TO 999 INESTF = INESTF - 1 CALL TPRDBL (IK, IKYDIM, C, ICKDIM, IDIF, IDSDIF, A .TRUE., .TRUE., .FALSE., LERROR) IF (.NOT. LEND) GO TO 999 C C AN -END- HAS BEEN ENCOUNTERED C CALL IOERRM (.FALSE., *IF(LIBRARY) *IF(CSTAR1) A '('' +++++++ IF HAS NO MATCHING ENDIF'')') *ELSE A 40H(35H +++++++ IF HAS NO MATCHING ENDIF)) *ENDIF *ELSE *IF(CSTAR1) A '('' ******** TPELSE - IF HAS NO MATCHING ENDIF'')') *ELSE A 50H(45H ******** TPELSE - IF HAS NO MATCHING ENDIF)) *ENDIF *ENDIF C 999 CONTINUE RETURN END SUBROUTINE TPENDO C C----------------------------------------------------------------------- C C FAMILY C ------ C TEMPLATE PROCESSOR C C PURPOSE C ------- C TO PROCESS ENDDO DIRECTIVES C C----------------------------------------------------------------------- *INCLUDE(GLCOM) *INCLUDE(IOCOM) *INCLUDE(MMCOM) *INCLUDE(MPCOM) *INCLUDE(TPCOM) C C LOCAL VARIABLES C $(DECLAREC) CD(1), CIN(1) INTEGER ID(1) INTEGER ICDDIM, ICIDIM, IDSDIM, ICN2, ICV2, ICV1, A I, I2, I3, ITEMP LOGICAL LERROR, LFOUND EXTERNAL TPSYNT, UTBLDN, MMGETV, UTCVCI, UTCVIC, A MMPUTV, MMPOPV, MMPSHV, MMRETI, IOERRM *IF(CSTAR1) SAVE ICDDIM, CD, ICIDIM, CIN, IDSDIM, ID *ENDIF DATA ICDDIM / 1 / *IF(CSTAR1) DATA CD(1) / 'D' / *ELSE DATA CD(1) / 1HD / *ENDIF DATA ICIDIM / 1 / *IF(CSTAR1) DATA CIN(1) / 'I' / *ELSE DATA CIN(1) / 1HI / *ENDIF DATA IDSDIM, ID(1) / 1, 7 / C C CHECK SYNTAX C CALL TPSYNT (ID, IDSDIM, .FALSE., LERROR) IF (LERROR) GO TO 999 IF (INESTD .LE. 0) GO TO 20 CALL UTBLDN (CSTAR, CIN, 1, ICIDIM, INESTD, A CBUFFR, 1, ICN2, ICBDIM, LERROR) CALL MMGETV (CBUFFR, 1, ICN2, CBUFFR, 1, ICV2, ICBDIM, LFOUND) ICN2 = ICV2 ICV1 = ICV2 + 1 CALL MMGETV (CBUFFR, 1, ICN2, A CBUFFR, ICV1, ICV2, ICBDIM, LFOUND) CALL UTCVCI (CBUFFR, ICV1, ICV2, I, LERROR) I2 = ISTORE(ITOPDO) I3 = ISTORE(ITOPDO+1) I = I + I3 IF ((I2-I)*ISIGN(1,I3) .LT. 0) GO TO 10 CALL UTCVIC (CBUFFR, ICV1, ICV2, ICBDIM, I, LERROR) CALL MMPUTV (CBUFFR, 1, ICN2, CBUFFR, ICV1, ICV2) CALL UTBLDN (CSTAR, CD, 1, ICDDIM, INESTD, A CBUFFR, 1, ICN2, ICBDIM, LERROR) IF (INESTD .GT. 1) CALL MMPOPV (LEMPTY) CALL MMPSHV (CBUFFR, 1, ICN2, 2, LEMPTY, LFOUND) GO TO 999 C 10 CONTINUE INESTD = INESTD - 1 ITEMP = ITOPDO ITOPDO = ISTORE(ITOPDO+2) CALL MMRETI (ITEMP) GO TO 999 C 20 CONTINUE CALL IOERRM (.FALSE., *IF(LIBRARY) *IF(CSTAR1) A '('' +++++++ MISPLACED ENDDO'')') *ELSE A 31H(26H +++++++ MISPLACED ENDDO)) *ENDIF *ELSE *IF(CSTAR1) A '('' ******** TPENDO - MISPLACED ENDDO'')') *ELSE A 41H(36H ******** TPENDO - MISPLACED ENDDO)) *ENDIF *ENDIF C C 999 CONTINUE RETURN END SUBROUTINE TPENDF C C----------------------------------------------------------------------- C C FAMILY C ------ C TEMPLATE PROCESSOR C C PURPOSE C ------- C TO PROCESS ENDIF DIRECTIVES C C----------------------------------------------------------------------- *INCLUDE(GLCOM) *INCLUDE(IOCOM) *INCLUDE(MMCOM) *INCLUDE(MPCOM) *INCLUDE(TPCOM) C C LOCAL VARIABLES C INTEGER ID(1) LOGICAL LERROR INTEGER IDSDIM EXTERNAL TPSYNT, IOERRM *IF(CSTAR1) SAVE IDSDIM, ID *ENDIF DATA IDSDIM, ID(1) / 1, 7 / C C CHECK SYNTAX C CALL TPSYNT (ID, IDSDIM, .FALSE., LERROR) IF (LERROR) GO TO 999 IF (INESTF .LE. 0) GO TO 10 INESTF = INESTF - 1 GO TO 999 C 10 CONTINUE CALL IOERRM (.FALSE., *IF(LIBRARY) *IF(CSTAR1) A '('' +++++++ MISPLACED ENDIF'')') *ELSE A 31H(26H +++++++ MISPLACED ENDIF)) *ENDIF *ELSE *IF(CSTAR1) A '('' ******** TPENDF - MISPLACED ENDIF'')') *ELSE A 41H(36H ******** TPENDF - MISPLACED ENDIF)) *ENDIF *ENDIF C 999 CONTINUE RETURN END SUBROUTINE TPEVAL C C----------------------------------------------------------------------- C C FAMILY C ------ C TEMPLATE PROCESSOR C C PURPOSE C ------- C TO CALL ROUTINES TO PROCESS DIRECTIVES C C----------------------------------------------------------------------- *INCLUDE(GLCOM) *INCLUDE(IOCOM) *INCLUDE(MMCOM) *INCLUDE(MPCOM) *INCLUDE(TPCOM) C C LOCAL VARIABLES C $(DECLAREC) C(79) INTEGER IK(16) INTEGER IKYDIM, ICKDIM, I EXTERNAL TPCHKD, UTRDKY, TPAPPE, TPCOMM, TPDELE, TPDO, A TPELSE, TPENDO, TPENDF, TPIF, TPINCL, TPOPT, B TPRSET, TPSET, IOERRM *IF(CSTAR1) SAVE IKYDIM, IK, ICKDIM, C *ENDIF DATA A IKYDIM, ICKDIM, B IK(1), C IK(2), D IK(3), E IK(4), F IK(5), G IK(6), H IK(7), I IK(8) J / 16, 79, K 6, L 7, M 6, N 2, O 4, P 5, Q 5, R 2 / DATA B C(1), C(2), C(3), C(4), C(5), C(6), C C(7), C(8), C(9), C(10), C(11), C(12), C(13), D C(14), C(15), C(16), C(17), C(18), C(19), E C(20), C(21), F C(22), C(23), C(24), C(25), G C(26), C(27), C(28), C(29), C(30), H C(31), C(32), C(33), C(34), C(35), I C(36), C(37) *IF(CSTAR1) K / 'A', 'P', 'P', 'E', 'N', 'D', L 'C', 'O', 'M', 'M', 'E', 'N', 'T', M 'D', 'E', 'L', 'E', 'T', 'E', N 'D', 'O', O 'E', 'L', 'S', 'E', P 'E', 'N', 'D', 'D', 'O', Q 'E', 'N', 'D', 'I', 'F', R 'I', 'F' / *ELSE K / 1HA, 1HP, 1HP, 1HE, 1HN, 1HD, L 1HC, 1HO, 1HM, 1HM, 1HE, 1HN, 1HT, M 1HD, 1HE, 1HL, 1HE, 1HT, 1HE, N 1HD, 1HO, O 1HE, 1HL, 1HS, 1HE, P 1HE, 1HN, 1HD, 1HD, 1HO, Q 1HE, 1HN, 1HD, 1HI, 1HF, R 1HI, 1HF / *ENDIF DATA A IK(9), B IK(10), C IK(11), D IK(12), E IK(13), F IK(14), G IK(15), H IK(16) I / 7, J 6, K 5, L 3, M 6, N 6, O 6, P 3 / DATA A C(38), C(39), C(40), C(41), C(42), C(43), C(44), B C(45), C(46), C(47), C(48), C(49), C(50), C C(51), C(52), C(53), C(54), C(55), D C(56), C(57), C(58), E C(59), C(60), C(61), C(62), C(63), C(64), F C(65), C(66), C(67), C(68), C(69), C(70), G C(71), C(72), C(73), C(74), C(75), C(76), H C(77), C(78), C(79) *IF(CSTAR1) I / 'I', 'N', 'C', 'L', 'U', 'D', 'E', J 'O', 'P', 'T', 'I', 'O', 'N', K 'R', 'E', 'S', 'E', 'T', L 'S', 'E', 'T', M 'E', 'N', 'D', 'A', 'P', 'P', N 'E', 'N', 'D', 'C', 'O', 'M', O 'E', 'N', 'D', 'S', 'E', 'T', P 'E', 'N', 'D' / *ELSE I / 1HI, 1HN, 1HC, 1HL, 1HU, 1HD, 1HE, J 1HO, 1HP, 1HT, 1HI, 1HO, 1HN, K 1HR, 1HE, 1HS, 1HE, 1HT, L 1HS, 1HE, 1HT, M 1HE, 1HN, 1HD, 1HA, 1HP, 1HP, N 1HE, 1HN, 1HD, 1HC, 1HO, 1HM, O 1HE, 1HN, 1HD, 1HS, 1HE, 1HT, P 1HE, 1HN, 1HD / *ENDIF C ICB1 = ICB0 ICB2 = ICB3 CALL TPCHKD IF (.NOT. LDIRL) GO TO 999 C C A DIRECTIVE LINE HAS BEEN FOUND. CHECK WHICH ONE IT IS C CALL UTRDKY (CBUFFR, ICB1, ICB2, IK, IKYDIM, C, ICKDIM, I) GO TO (10, 20, 30, 40, 50, 60, 70, 80, 90, A 100, 110, 120, 130, 140, 150, 160, 170), I C C PROCESS -APPEND- C 10 CONTINUE CALL TPAPPE GO TO 999 C C PROCESS -COMMENT- C 20 CONTINUE CALL TPCOMM GO TO 999 C C PROCESS -DELETE- C 30 CONTINUE CALL TPDELE GO TO 999 C C PROCESS -DO- C 40 CONTINUE CALL TPDO GO TO 999 C C PROCESS -ELSE- C 50 CONTINUE CALL TPELSE GO TO 999 C C PROCESS -ENDDO- C 60 CONTINUE CALL TPENDO GO TO 999 C C PROCESS -ENDIF- C 70 CONTINUE CALL TPENDF GO TO 999 C C PROCESS -IF- C 80 CONTINUE CALL TPIF GO TO 999 C C PROCESS -INCLUDE- C 90 CONTINUE CALL TPINCL GO TO 999 C C PROCESS -OPTION- C 100 CONTINUE CALL TPOPT GO TO 999 C C PROCESS -RESET- C 110 CONTINUE CALL TPRSET GO TO 999 C C PROCESS -SET- C 120 CONTINUE CALL TPSET GO TO 999 C C PROCESS -ENDAPP- C 130 CONTINUE CALL IOERRM (.FALSE., *IF(LIBRARY) *IF(CSTAR1) A '('' +++++++ MISPLACED ENDAPP'')') *ELSE A 32H(27H +++++++ MISPLACED ENDAPP)) *ENDIF *ELSE *IF(CSTAR1) A '('' ******** TPEVAL - MISPLACED ENDAPP'')') *ELSE A 42H(37H ******** TPEVAL - MISPLACED ENDAPP)) *ENDIF *ENDIF GO TO 999 C C PROCESS -ENDCOM- C 140 CONTINUE CALL IOERRM (.FALSE., *IF(LIBRARY) *IF(CSTAR1) A '('' +++++++ MISPLACED ENDCOM'')') *ELSE A 32H(27H +++++++ MISPLACED ENDCOM)) *ENDIF *ELSE *IF(CSTAR1) A '('' ******** TPEVAL - MISPLACED ENDCOM'')') *ELSE A 42H(37H ******** TPEVAL - MISPLACED ENDCOM)) *ENDIF *ENDIF GO TO 999 C C PROCESS -ENDSET- C 150 CONTINUE CALL IOERRM (.FALSE., *IF(LIBRARY) *IF(CSTAR1) A '('' +++++++ MISPLACED ENDSET'')') *ELSE A 32H(27H +++++++ MISPLACED ENDSET)) *ENDIF *ELSE *IF(CSTAR1) A '('' ******** TPEVAL - MISPLACED ENDSET'')') *ELSE A 42H(37H ******** TPEVAL - MISPLACED ENDSET)) *ENDIF *ENDIF GO TO 999 C C PROCESS -END- C 160 CONTINUE LEND = .TRUE. GO TO 999 C C PROCESS UNRECOGNIZED DIRECTIVES C 170 CONTINUE CALL IOERRM (.FALSE., *IF(LIBRARY) *IF(CSTAR1) A '('' +++++++ ILLEGAL OR MISSPELLED DIRECTIVE'')') *ELSE A 47H(42H +++++++ ILLEGAL OR MISSPELLED DIRECTIVE)) *ENDIF *ELSE *IF(CSTAR1) A '('' ******** TPEVAL - ILLEGAL OR MISSPELLED DIRECTIVE'')') *ELSE A 57H(52H ******** TPEVAL - ILLEGAL OR MISSPELLED DIRECTIVE)) *ENDIF *ENDIF C 999 CONTINUE RETURN END SUBROUTINE TPEXPR (ICV1, ICV2, LSCAN, LERROR) C C----------------------------------------------------------------------- C C FAMILY C ------ C TEMPLATE PROCESSOR C C PURPOSE C ------- C TO DETERMINE IF AN EXPRESSION IS VALID AND RETURN ITS VALUE. C CURRENTLY, EXPRESSIONS MAY CONSIST ONLY OF VARIABLES OR CONSTANTS. C C PARAMETERS C ---------- C ICV1 -I- INDEX INTO CBUFFR OF THE FIRST C CHARACTER IN THE EXPRESSION C ICV2 -I- INDEX OF THE LAST CHARACTER C LSCAN -I- IF TRUE, THEN VALIDATE (SCAN) BUT DO NOT EVALUATE C LERROR -O- TRUE IF THE EXPRESSION WAS INVALID C C----------------------------------------------------------------------- *INCLUDE(GLCOM) *INCLUDE(IOCOM) *INCLUDE(MMCOM) *INCLUDE(MPCOM) *INCLUDE(TPCOM) C C LOCAL VARIABLES AND PARAMETERS C INTEGER ICV1, ICV2 LOGICAL L, LERROR, LSCAN INTEGER ICN1, ICN2 EXTERNAL UTRDNA, MMGETV, UTRDNU, UTRDQS C *IF(TESTCH) *IF(CSTAR1) IF (LLE(CA,CBUFFR(ICB1)) .AND. A LLE(CBUFFR(ICB1),CZ)) GO TO 10 IF (LLE(C0,CBUFFR(ICB1)) .AND. A LLE(CBUFFR(ICB1),C9)) GO TO 20 *ELSE IF ((CA .LE. CBUFFR(ICB1)) .AND. A (CBUFFR(ICB1) .LE. CZ)) GO TO 10 IF ((C0 .LE. CBUFFR(ICB1)) .AND. A (CBUFFR(ICB1) .LE. C9)) GO TO 20 *ENDIF *ELSE CALL UTCHKA (CBUFFR(ICB1), L) IF (L) GO TO 10 CALL UTCHKN (CBUFFR(ICB1), L) IF (L) GO TO 20 *ENDIF IF (CBUFFR(ICB1) .EQ. CMINUS) GO TO 20 IF (CBUFFR(ICB1) .EQ. CPLUS) GO TO 20 IF (CBUFFR(ICB1) .EQ. CQUOTE) GO TO 30 IF (CBUFFR(ICB1) .EQ. CPOINT) GO TO 40 LERROR = .TRUE. GO TO 999 C C PROCESS A NAME C 10 CONTINUE CALL UTRDNA (CBUFFR, ICB1, ICB2, ICN1, ICN2, LERROR) IF (LERROR) GO TO 999 IF (LSCAN) GO TO 999 ICV1 = ICBEND + 1 CALL MMGETV (CBUFFR, ICN1, ICN2, CBUFFR, ICV1, ICV2, ICBDIM, L) ICBEND = ICV2 LERROR = .NOT. L GO TO 999 C C PROCESS A NUMBER C 20 CONTINUE CALL UTRDNU (CBUFFR, ICB1, ICB2, ICV1, ICV2, LERROR) GO TO 999 C C PROCESS A QUOTED STRING C 30 CONTINUE CALL UTRDQS (CBUFFR, ICB1, ICB2, ICV1, ICV2, LERROR) GO TO 999 C C PROCESS A LOGICAL CONSTANT C 40 CONTINUE CALL UTRDQS (CBUFFR, ICB1, ICB2, ICV1, ICV2, LERROR) IF (LERROR) GO TO 999 ICV1 = ICV1 - 1 ICV2 = ICV2 + 1 C 999 CONTINUE RETURN END SUBROUTINE TPIF C C----------------------------------------------------------------------- C C FAMILY C ------ C TEMPLATE PROCESSOR C C PURPOSE C ------- C TO PROCESS IF DIRECTIVES C C----------------------------------------------------------------------- *INCLUDE(GLCOM) *INCLUDE(IOCOM) *INCLUDE(MMCOM) *INCLUDE(MPCOM) *INCLUDE(TPCOM) C C LOCAL VARIABLES AND PARAMETERS C $(DECLAREC) C(14), CN(2) INTEGER ID(7), IK(4) INTEGER ICNDIM, IKYDIM, ICKDIM, IDSDIM, LEN1, LEN2, A I1, I2, I, INEST LOGICAL LERROR, LFOUND, LVALUE EXTERNAL TPSYNT, UTCVCL, MMPUTV, MMPSHV, MPLINE, A TPCHKD, UTRDKY, IOERRM *IF(CSTAR1) SAVE IKYDIM, IK, ICKDIM, C, ICNDIM, CN, IDSDIM, ID *ENDIF DATA ICNDIM / 2 / *IF(CSTAR1) DATA CN(1), CN(2) / '*', 'F' / *ELSE DATA CN(1), CN(2) / 1H*, 1HF / *ENDIF DATA A IKYDIM, ICKDIM, B IK(1), C IK(2), D IK(3), E IK(4) F / 4, 14, G 2, H 4, I 5, J 3 / DATA B C(1), C(2), C C(3), C(4), C(5), C(6), D C(7), C(8), C(9), C(10), C(11), E C(12), C(13), C(14) *IF(CSTAR1) G / 'I', 'F', H 'E', 'L', 'S', 'E', I 'E', 'N', 'D', 'I', 'F', J 'E', 'N', 'D' / *ELSE G / 1HI, 1HF, H 1HE, 1HL, 1HS, 1HE, I 1HE, 1HN, 1HD, 1HI, 1HF, J 1HE, 1HN, 1HD / *ENDIF DATA IDSDIM, ID(1), ID(2), ID(3), ID(4), ID(5), ID(6), ID(7) A / 7, 1, 6, -4, 6, 6, 2, 8 / C C CHECK SYNTAX C CALL TPSYNT (ID, IDSDIM, .FALSE., LERROR) IF (LERROR) GO TO 999 IF ((IARGS .EQ. 3) .OR. A ((IARGS .EQ. 2) .AND. (ICBEOL.NE.ICBP2(2)))) GO TO 3 C C HAVE FOUND FORM: '*IF(L)' C CALL UTCVCL (CBUFFR, ICBP1(1), ICBP2(1), LVALUE, LERROR) IF (IARGS .EQ. 1) GO TO 10 GO TO 9 3 CONTINUE C C HAVE FOUND FORM: '*IF(EXP1=EXP2)' C LVALUE = .FALSE. LEN1 = ICBP2(1) - ICBP1(1) + 1 LEN2 = ICBP2(2) - ICBP1(2) + 1 IF (LEN1 .NE. LEN2) GO TO 8 I1 = ICBP1(1) I2 = ICBP1(2) DO 5 I = 1, LEN1 IF (CBUFFR(I1) .NE. CBUFFR(I2)) GO TO 8 I1 = I1 + 1 I2 = I2 + 1 5 CONTINUE LVALUE = .TRUE. 8 CONTINUE IF (IARGS .EQ. 2) GO TO 10 C C C PROCESS A ONE-LINE IF STATEMENT C 9 CONTINUE IF (.NOT. LVALUE) GO TO 999 CALL MMPUTV (CN, 1, ICNDIM, CBUFFR, ICBP1(IARGS), ICBP2(IARGS)) CALL MMPSHV (CN, 1, ICNDIM, 1, LEMPTY, LFOUND) GO TO 999 C C PROCESS A MULTI-LINE IF STATEMENT C 10 CONTINUE INESTF = INESTF + 1 IF (LVALUE) GO TO 999 INEST = INESTF C 20 CONTINUE CALL MPLINE (.FALSE.) CALL TPCHKD IF (.NOT. LDIRL) GO TO 20 CALL UTRDKY (CBUFFR, ICB1, ICB2, IK, IKYDIM, C, ICKDIM, I) GO TO (30, 40, 50, 60, 20), I C C AN -IF- HAS BEEN ENCOUNTERED C 30 CONTINUE CALL TPSYNT (ID, IDSDIM, .TRUE., LERROR) IF (IARGS .EQ. 1) INESTF = INESTF + 1 C C IF IARGS=2 AND ICB1 > ICB2, ASSUME C DIRECTIVE IS OF FORM '*IF(ARG1 = ARG2)' C IF ((IARGS .EQ. 2) .AND. (ICB1 .GT. ICB2)) INESTF = INESTF + 1 GO TO 20 C C AN -ELSE- HAS BEEN ENCOUNTERED C 40 CONTINUE IF (INESTF .LE. INEST) GO TO 999 GO TO 20 C C AN -ENDIF- HAS BEEN ENCOUNTERED C 50 CONTINUE INESTF = INESTF - 1 IF (INESTF .LT. INEST) GO TO 999 GO TO 20 C C AN -END- HAS POSSIBLY BEEN ENCOUNTERED C 60 CONTINUE LEND = ICB1 .GT. ICB2 IF (.NOT. LEND) GO TO 20 CALL IOERRM (.FALSE., *IF(LIBRARY) *IF(CSTAR1) A '('' +++++++ IF HAS NO MATCHING ENDIF'')') *ELSE A 40H(35H +++++++ IF HAS NO MATCHING ENDIF)) *ENDIF *ELSE *IF(CSTAR1) A '('' ******** TPIF - IF HAS NO MATCHING ENDIF'')') *ELSE A 50H(45H ******** TPIF - IF HAS NO MATCHING ENDIF)) *ENDIF *ENDIF C 999 CONTINUE RETURN END SUBROUTINE TPINCL C C----------------------------------------------------------------------- C C FAMILY C ------ C TEMPLATE PROCESSOR C C PURPOSE C ------- C TO PROCESS INCLUDE DIRECTIVES C C----------------------------------------------------------------------- *INCLUDE(GLCOM) *INCLUDE(IOCOM) *INCLUDE(MMCOM) *INCLUDE(MPCOM) *INCLUDE(TPCOM) C C LOCAL VARIABLES AND PARAMETERS C INTEGER ID(4), IDSDIM LOGICAL LERROR, LFOUND EXTERNAL TPSYNT, MMPSHV, IOERRM *IF(CSTAR1) SAVE IDSDIM, ID *ENDIF DATA IDSDIM, ID(1), ID(2), ID(3), ID(4) A / 4, 1, 5, 2, 8 / C C CHECK SYNTAX, AND PUSH THE VARIABLE ON THE STACK C CALL TPSYNT (ID, IDSDIM, .FALSE., LERROR) IF (LERROR) GO TO 999 CALL MMPSHV (CBUFFR, ICBP1(1), ICBP2(1), 1, LEMPTY, LFOUND) IF (LFOUND) GO TO 999 CALL IOERRM (.FALSE., *IF(LIBRARY) *IF(CSTAR1) A '('' +++++++ VARIABLE NOT DEFINED'')') *ELSE A 36H(31H +++++++ VARIABLE NOT DEFINED)) *ENDIF *ELSE *IF(CSTAR1) A '('' ******** TPINCL - VARIABLE NOT DEFINED'')') *ELSE A 46H(41H ******** TPINCL - VARIABLE NOT DEFINED)) *ENDIF *ENDIF C 999 CONTINUE RETURN END SUBROUTINE TPINIT (IUE0, IUI0, IUL0, IUO0) C C----------------------------------------------------------------------- C C FAMILY C ------ C TEMPLATE PROCESSOR C C PURPOSE C ------- C TO INITIALIZE TEMPLATE PROCESSOR VATIABLES C C PARAMETERS C ---------- C IUE0 -I- UNIT NUMBER OF THE ERROR FILE C IUI0 -I- UNIT NUMBER OF THE INPUT FILE C IUL0 -I- UNIT NUMBER OF THE LISTING FILE C IUO0 -I- UNIT NUMBER OF THE OUTPUT FILE C C----------------------------------------------------------------------- *INCLUDE(GLCOM) *INCLUDE(IOCOM) *INCLUDE(MMCOM) *INCLUDE(MPCOM) *INCLUDE(TPCOM) INTEGER IUE0, IUI0, IUL0, IUO0 EXTERNAL MMINIT C IUNITE = IUE0 IUNITI = IUI0 IUNITL = IUL0 IUNITO = IUO0 C ILNMBR = 0 ILCTR = ILPP INESTD = 0 INESTF = 0 IPAGE = 0 ITOPDO = 0 LEMPTY = .TRUE. LEND = .FALSE. IF (.NOT. LINITM) CALL MMINIT LINITM = .TRUE. C RETURN END SUBROUTINE TPMMIN C C---------------------------------------------------------------------- C C FAMILY C ------ C TEMPLATE PROCESSOR C C PURPOSE C ------- C THIS ROUTINE INITIALIZES TEMPLATE PROCESSOR CONSTANTS. C C---------------------------------------------------------------------- *INCLUDE(GLCOM) *INCLUDE(IOCOM) *INCLUDE(MMCOM) *INCLUDE(MPCOM) *INCLUDE(TPCOM) C $(DECLAREC) CA0, CBLAN0, CC0, CI0, CLEFT0, A CMINU0, CPLUS0, CPOIN0, CQUOT0, CRIGH0, B CZ0, C00, C90, C CDIR0, CDIV0, CEOL0, CEOR0, CONC0, D CSTAR0, CSUB0 DATA CA0, CBLAN0, CC0, CI0, CLEFT0, A CMINU0, CPLUS0, CPOIN0, CQUOT0, CRIGH0, B CZ0, C00, C90 *OPTION(LSUB=.FALSE.) *IF(CSTAR1) C / 'A', ' ', 'C', 'I', '(', D '-', '+', '.', '''', ')', E 'Z', '0', '9' / DATA CDIR0 / '*' / DATA CDIV0 / '/' / DATA CEOL0 / '-' / DATA CEOR0 / '/' / DATA CONC0 / '+' / DATA CSTAR0 / '*' / DATA CSUB0 / '$' / *ELSE C / 1HA, 1H , 1HC, 1HI, 1H(, D 1H-, 1H+, 1H., 1H', 1H), E 1HZ, 1H0, 1H9 / DATA CDIR0 / 1H* / DATA CDIV0 / 1H/ / DATA CEOL0 / 1H- / DATA CEOR0 / 1H/ / DATA CONC0 / 1H+ / DATA CSTAR0 / 1H* / DATA CSUB0 / 1H$ / *ENDIF *OPTION(LSUB=.TRUE.) CA = CA0 CBLANK = CBLAN0 CC = CC0 CI = CI0 CLEFT = CLEFT0 CMINUS = CMINU0 CPLUS = CPLUS0 CPOINT = CPOIN0 CQUOTE = CQUOT0 CRIGHT = CRIGH0 CZ = CZ0 C0 = C00 C9 = C90 C CDIR = CDIR0 CDIV = CDIV0 CEOL = CEOL0 CEOR = CEOR0 CONC = CONC0 CSTAR = CSTAR0 CSUB = CSUB0 C ICBADD = 1 ICPLI = 72 ICPLO = 72 ILPP = 58 LBREAK = .FALSE. LCOL1 = .TRUE. LFORT = .FALSE. LINITM = .FALSE. LISTI = .FALSE. LISTO = .FALSE. LSUB = .TRUE. L1TRIP = .FALSE. C RETURN END SUBROUTINE TPOPT C C----------------------------------------------------------------------- C C FAMILY C ------ C TEMPLATE PROCESSOR C C PURPOSE C ------- C TO PROCESS OPTION DIRECTIVES C C----------------------------------------------------------------------- *INCLUDE(GLCOM) *INCLUDE(IOCOM) *INCLUDE(MMCOM) *INCLUDE(MPCOM) *INCLUDE(TPCOM) C C LOCAL VARIABLES AND PARAMETERS C $(DECLAREC) C(84), CVALUE INTEGER ID(6), IK(17) INTEGER IKYDIM, ICKDIM, IDSDIM, ICB, I, IVALUE LOGICAL LERROR, LVALUE EXTERNAL TPSYNT, UTRDKY, UTCVCI, UTCVCL, IOERRM *IF(CSTAR1) SAVE IKYDIM, IK, ICKDIM, C, IDSDIM, ID *ENDIF DATA A IKYDIM, ICKDIM, B IK(1), C IK(2), D IK(3), E IK(4), F IK(5) G / 17, 84, H 4, I 4, J 4, K 4, L 4 / DATA B C(1), C(2), C(3), C(4), C C(5), C(6), C(7), C(8), D C(9), C(10), C(11), C(12), E C(13), C(14), C(15), C(16), F C(17), C(18), C(19), C(20) G / *IF(CSTAR1) H 'C', 'D', 'I', 'R', I 'C', 'E', 'O', 'L', J 'C', 'E', 'O', 'R', K 'C', 'O', 'N', 'C', L 'C', 'S', 'U', 'B' / *ELSE H 1HC, 1HD, 1HI, 1HR, I 1HC, 1HE, 1HO, 1HL, J 1HC, 1HE, 1HO, 1HR, K 1HC, 1HO, 1HN, 1HC, L 1HC, 1HS, 1HU, 1HB / *ENDIF DATA A IK(6), B IK(7), C IK(8), D IK(9), E IK(10) F / 5, G 5, H 6, I 6, J 6 / DATA A C(21), C(22), C(23), C(24), C(25), B C(26), C(27), C(28), C(29), C(30), C C(31), C(32), C(33), C(34), C(35), C(36), D C(37), C(38), C(39), C(40), C(41), C(42), E C(43), C(44), C(45), C(46), C(47), C(48) *IF(CSTAR1) F / 'I', 'C', 'P', 'L', 'I', G 'I', 'C', 'P', 'L', 'O', H 'I', 'U', 'N', 'I', 'T', 'I', I 'I', 'U', 'N', 'I', 'T', 'L', J 'I', 'U', 'N', 'I', 'T', 'O' / *ELSE F / 5, 1HI, 1HC, 1HP, 1HL, 1HI, G 5, 1HI, 1HC, 1HP, 1HL, 1HO, H 6, 1HI, 1HU, 1HN, 1HI, 1HT, 1HI, I 6, 1HI, 1HU, 1HN, 1HI, 1HT, 1HL, J 6, 1HI, 1HU, 1HN, 1HI, 1HT, 1HO / *ENDIF DATA A IK(11), B IK(12), C IK(13), D IK(14), E IK(15), F IK(16), G IK(17) H / 6, I 5, K 5, L 5, M 5, N 4, O 6 / DATA A C(49), C(50), C(51), C(52), C(53), C(54), B C(55), C(56), C(57), C(58), C(59), C C(60), C(61), C(62), C(63), C(64), D C(65), C(66), C(67), C(68), C(69), E C(70), C(71), C(72), C(73), C(74), F C(75), C(76), C(77), C(78), G C(79), C(80), C(81), C(82), C(83), C(84) *IF(CSTAR1) H / 'L', 'B', 'R', 'E', 'A', 'K', I 'L', 'C', 'O', 'L', '1', K 'L', 'F', 'O', 'R', 'T', L 'L', 'I', 'S', 'T', 'I', M 'L', 'I', 'S', 'T', 'O', N 'L', 'S', 'U', 'B', O 'L', '1', 'T', 'R', 'I', 'P' / *ELSE H / 1HL, 1HB, 1HR, 1HE, 1HA, 1HK, I 1HL, 1HC, 1HO, 1HL, 1H1, K 1HL, 1HF, 1HO, 1HR, 1HT, L 1HL, 1HI, 1HS, 1HT, 1HI, M 1HL, 1HI, 1HS, 1HT, 1HO, N 1HL, 1HS, 1HU, 1HB, O 1HL, 1H1, 1HT, 1HR, 1HI, 1HP / *ENDIF DATA A IDSDIM, ID(1), ID(2), ID(3), ID(4), ID(5), ID(6) B / 6, 1, 5, 4, 6, 2, 7 / C C CHECK SYNTAX C CALL TPSYNT (ID, IDSDIM, .FALSE., LERROR) IF (LERROR) GO TO 999 ICB = ICBP1(1) CALL UTRDKY (CBUFFR, ICBP1(1), ICBP2(1), IK, IKYDIM, A C, ICKDIM, I) IF (I .GT. IKYDIM) GO TO 220 IF (CBUFFR(ICB) .EQ. CC) GO TO 10 IF (CBUFFR(ICB) .EQ. CI) GO TO 20 GO TO 30 C 10 CONTINUE IF (ICBP1(2) .NE. ICBP2(2)) GO TO 230 ICB = ICBP1(2) CVALUE = CBUFFR(ICB) GO TO 40 C 20 CONTINUE CALL UTCVCI (CBUFFR, ICBP1(2), ICBP2(2), IVALUE, LERROR) IF (LERROR) GO TO 240 GO TO 40 C 30 CONTINUE CALL UTCVCL (CBUFFR, ICBP1(2), ICBP2(2), LVALUE, LERROR) IF (LERROR) GO TO 250 C 40 CONTINUE GO TO (50, 60, 70, 80, 90, 100, 110, 120, A 130, 140, 150, 160, 170, 180, 190, 200, 210), I C C PROCESS -CDIR- C 50 CONTINUE CDIR = CVALUE GO TO 999 C C PROCESS -CEOL- C 60 CONTINUE CEOL = CVALUE GO TO 999 C C PROCESS -CEOR- C 70 CONTINUE CEOR = CVALUE GO TO 999 C C PROCESS -CONC- C 80 CONTINUE CONC = CVALUE GO TO 999 C C PROCESS -CSUB- C 90 CONTINUE CSUB = CVALUE GO TO 999 C C PROCESS -ICPLI- C 100 CONTINUE ICPLI = IVALUE GO TO 999 C C PROCESS -ICPLO- C 110 CONTINUE ICPLO = IVALUE GO TO 999 C C PROCESS -IUNITI- C 120 CONTINUE IUNITI = IVALUE GO TO 999 C C PROCESS -IUNITL- C 130 CONTINUE IUNITL = IVALUE GO TO 999 C C PROCESS -IUNITO- C 140 CONTINUE IUNITO = IVALUE GO TO 999 C C PROCESS -LBREAK- C 150 CONTINUE LBREAK = LVALUE ICBADD = 1 IF (LFORT) ICBADD = -5 IF (LFORT .AND. LBREAK) ICBADD = -9 GO TO 999 C C PROCESS -LCOL1- C 160 CONTINUE LCOL1 = LVALUE GO TO 999 C C PROCESS -LFORT- C 170 CONTINUE LFORT = LVALUE ICBADD = 1 IF (LFORT) ICBADD = -5 IF (LFORT .AND. LBREAK) ICBADD = -9 GO TO 999 C C PROCESS -LISTI- C 180 CONTINUE LISTI = LVALUE GO TO 999 C C PROCESS -LISTO- C 190 CONTINUE LISTO = LVALUE GO TO 999 C C PROCESS -LSUB- C 200 CONTINUE LSUB = LVALUE GO TO 999 C C PROCESS -L1TRIP- C 210 CONTINUE L1TRIP = LVALUE GO TO 999 C C ERROR - UNKNOWN OPTION NAME C 220 CONTINUE CALL IOERRM (.FALSE., *IF(LIBRARY) *IF(CSTAR1) A '('' +++++++ ILLEGAL OR MISSPELLED OPTION'')') *ELSE A 44H(39H +++++++ ILLEGAL OR MISSPELLED OPTION)) *ENDIF *ELSE *IF(CSTAR1) A '('' ******** TPOPT - ILLEGAL OR MISSPELLED OPTION'')') *ELSE A 54H(49H ******** TPOPT - ILLEGAL OR MISSPELLED OPTION)) *ENDIF *ENDIF GO TO 999 C C ERROR - SINGLE CHARACTER EXPECTED C 230 CONTINUE CALL IOERRM (.FALSE., *IF(LIBRARY) *IF(CSTAR1) A '('' +++++++ OPTION REQUIRES SINGLE CHARACTER'')') *ELSE A 48H(43H +++++++ OPTION REQUIRES SINGLE CHARACTER)) *ENDIF *ELSE *IF(CSTAR1) A '('' ******** TPOPT - OPTION REQUIRES SINGLE CHARACTER'')') *ELSE A 58H(53H ******** TPOPT - OPTION REQUIRES SINGLE CHARACTER)) *ENDIF *ENDIF GO TO 999 C C ERROR - INTEGER EXPECTED C 240 CONTINUE CALL IOERRM (.FALSE., *IF(LIBRARY) *IF(CSTAR1) A '('' +++++++ OPTION REQUIRES AN INTEGER'')') *ELSE A 42H(37H +++++++ OPTION REQUIRES AN INTEGER)) *ENDIF *ELSE *IF(CSTAR1) A '('' ******** TPOPT - OPTION REQUIRES AN INTEGER'')') *ELSE A 52H(47H ******** TPOPT - OPTION REQUIRES AN INTEGER)) *ENDIF *ENDIF GO TO 999 C C ERROR - LOGICAL VALUE EXPECTED C 250 CONTINUE CALL IOERRM (.FALSE., *IF(LIBRARY) *IF(CSTAR1) A '('' +++++++ OPTION REQUIRES A LOGICAL VALUE'')') *ELSE A 47H(42H +++++++ OPTION REQUIRES A LOGICAL VALUE)) *ENDIF *ELSE *IF(CSTAR1) A '('' ******** TPOPT - OPTION REQUIRES A LOGICAL VALUE'')') *ELSE A 57H(52H ******** TPOPT - OPTION REQUIRES A LOGICAL VALUE)) *ENDIF *ENDIF C 999 CONTINUE RETURN END SUBROUTINE TPRDBL (IK, IKYDIM, C, ICKDIM, ID, IDSDIM, A LSCAN, LSKIP, LSUBL, LERROR) C C----------------------------------------------------------------------- C C FAMILY C ------ C TEMPLATE PROCESSOR C C PURPOSE C ------- C TO READ A BLOCK OF STATEMENTS DELIMITED BY C DIRECTIVES OF THE FORM -NAME- AND -ENDNAME-. C THESE DIRECTIVES MAY BE NESTED. C C PARAMETERS C ---------- C IK -I- INDEXES OF DIRECTIVES IN ARRAY C C IKYDIM -I- DIMENSION OF IK (SHOULD BE 3) C C -I- CONTAINS DIRECTIVE NAMES. DIRECTIVE 1 IS -NAME-, C 2 IS -ENDNAME, AND 3 IS -END-. C ICKDIM -I- DIMENSION OF C (TOTAL NUMBER OF CHARACTERS) C ID -I- CONTAINS THE SYNTAX PATTERN FOR DIRECTIVE -NAME- C IDSDIM -I- DIMENSION OF ID C LSCAN -I- IF TRUE, EXPRESSIONS WILL BE SCANNED FOR ERRORS C BUT NOT EVALUATED C LSKIP -I- IF TRUE, INPUT LINES ARE SKIPPED, NOT SAVED C LSUBL -I- IF TRUE, MACRO SUBSTITUTIONS WILL BE PERFORMED C WHEN ENCOUNTERED WITHIN THE BLOCK C LERROR -O- TRUE IF AN ERROR WAS ENCOUNTERED C C----------------------------------------------------------------------- *INCLUDE(GLCOM) *INCLUDE(IOCOM) *INCLUDE(MMCOM) *INCLUDE(MPCOM) *INCLUDE(TPCOM) C C LOCAL VARIABLES AND PARAMETERS C INTEGER IKYDIM, ICKDIM, IDSDIM $(ARGDECLAREC) C(ICKDIM) INTEGER ID(IDSDIM), IK(IKYDIM) LOGICAL LERROR, LSCAN, LSKIP, LSUBL INTEGER I, INEST EXTERNAL MPLINE, TPCHKD, UTRDKY, TPSYNT C INEST = 1 C 10 CONTINUE IF (LSKIP) ICBEOL = 0 CALL MPLINE (LSUBL) CALL TPCHKD IF (.NOT. LDIRL) GO TO 10 CALL UTRDKY (CBUFFR, ICB1, ICB2, IK, IKYDIM, C, ICKDIM, I) GO TO (20, 30, 40, 10), I C C A -NAME- DIRECTIVE HAS BEEN ENCOUNTERED C 20 CONTINUE IF (LSCAN) CALL TPSYNT (ID, IDSDIM, LSCAN, LERROR) IF (LSCAN .AND. (IARGS .GE. 2)) GO TO 10 INEST = INEST + 1 GO TO 10 C C AN -ENDNAME- DIRECTIVE HAS BEEN ENCOUNTERED C 30 CONTINUE INEST = INEST - 1 IF (INEST .GT. 0) GO TO 10 GO TO 999 C C AN -END- DIRECTIVE HAS POSSIBLY BEEN ENCOUNTERED C 40 CONTINUE LEND = ICB1 .GT. ICB2 IF (.NOT. LEND) GO TO 10 C 999 CONTINUE RETURN END SUBROUTINE TPRSET C C----------------------------------------------------------------------- C C FAMILY C ------ C TEMPLATE PROCESSOR C C PURPOSE C ------- C TO PROCESS RESET DIRECTIVES C C----------------------------------------------------------------------- *INCLUDE(GLCOM) *INCLUDE(IOCOM) *INCLUDE(MMCOM) *INCLUDE(MPCOM) *INCLUDE(TPCOM) C C LOCAL VARIABLES AND PARAMETERS C INTEGER IDSDIM, ICP1,ICP2 INTEGER ID(4) LOGICAL LERROR, LFOUND EXTERNAL TPSYNT, UTBLDN, MMPUTP *IF(CSTAR1) SAVE IDSDIM, ID *ENDIF DATA IDSDIM, ID(1), ID(2), ID(3), ID(4) A / 4, 1, 5, 2, 7 / C C CHECK SYNTAX C CALL TPSYNT (ID, IDSDIM, .FALSE., LERROR) IF (LERROR) GO TO 999 ICP1 = ICBEND + 1 CALL UTBLDN (CDIV, CBUFFR, ICBP1(1), ICBP2(1), 1, A CBUFFR, ICP1, ICP2, ICBDIM, LERROR) ICBEND = ICP2 CALL MMPUTP (CBUFFR, ICBP1(1), ICBP2(1), A CBUFFR, ICP1, ICP2, LFOUND) C 999 CONTINUE RETURN END SUBROUTINE TPSET C C----------------------------------------------------------------------- C C FAMILY C ------ C TEMPLATE PROCESSOR C C PURPOSE C ------- C TO PROCESS SET DIRECTIVES C C----------------------------------------------------------------------- *INCLUDE(GLCOM) *INCLUDE(IOCOM) *INCLUDE(MMCOM) *INCLUDE(MPCOM) *INCLUDE(TPCOM) C C LOCAL VARIABLES AND PARAMETERS C INTEGER IKYDIM, ICKDIM, IDSDIM $(DECLAREC) C(12) INTEGER ID(8), IK(3) LOGICAL LERROR EXTERNAL TPSYNT, TPSETM, TPRDBL, MMPUTV, IOERRM *IF(CSTAR1) SAVE IKYDIM, IK, ICKDIM, C, IDSDIM, ID *ENDIF DATA A IKYDIM, ICKDIM, B IK(1), C IK(2), D IK(3) E / 3, 12, F 3, G 6, H 3 / DATA B C(1), C(2), C(3), C C(4), C(5), C(6), C(7), C(8), C(9), D C(10), C(11), C(12) E / *IF(CSTAR1) F 'S', 'E', 'T', G 'E', 'N', 'D', 'S', 'E', 'T', H 'E', 'N', 'D' / *ELSE F 1HS, 1HE, 1HT, G 1HE, 1HN, 1HD, 1HS, 1HE, 1HT, H 1HE, 1HN, 1HD / *ENDIF DATA A IDSDIM, B ID(1), ID(2), ID(3), ID(4), ID(5), ID(6), ID(7), ID(8) C / 8, D -1, 8, 5, -4, 7, 6, 2, 7 / C C CHECK SYNTAX C CALL TPSYNT (ID, IDSDIM, .FALSE., LERROR) IF (LERROR) GO TO 999 IF (IARGS .EQ. 2) GO TO 20 IF (IARGS .EQ. 1) GO TO 10 CALL TPSETM IF (LEND) GO TO 30 GO TO 999 C C PROCESS A MULTI-LINE SET STATEMENT C 10 CONTINUE ICBP1(2) = ICBEOL + 1 CALL TPRDBL (IK, IKYDIM, C, ICKDIM, ID, IDSDIM, A .TRUE., .FALSE., .TRUE., LERROR) IF (LEND) GO TO 30 IF (LERROR) GO TO 999 ICBP2(2) = ICB0 - 1 C C SET THE VALUE C 20 CONTINUE CALL MMPUTV (CBUFFR, ICBP1(1), ICBP2(1), A CBUFFR, ICBP1(2), ICBP2(2)) GO TO 999 C 30 CONTINUE CALL IOERRM (.FALSE., *IF(LIBRARY) *IF(CSTAR1) A '('' +++++++ SET HAS NO MATCHING ENDSET'')') *ELSE A 42H(37H +++++++ SET HAS NO MATCHING ENDSET)) *ENDIF *ELSE *IF(CSTAR1) A '('' ******** TPSET - SET HAS NO MATCHING ENDSET'')') *ELSE A 52H(47H ******** TPSET - SET HAS NO MATCHING ENDSET)) *ENDIF *ENDIF C 999 CONTINUE RETURN END SUBROUTINE TPSETM C C----------------------------------------------------------------------- C C FAMILY C ------ C TEMPLATE PROCESSOR C C PURPOSE C ------- C TO PROCESS MULTILINE SET DIRECTIVES C C----------------------------------------------------------------------- *INCLUDE(GLCOM) *INCLUDE(IOCOM) *INCLUDE(MMCOM) *INCLUDE(MPCOM) *INCLUDE(TPCOM) C C LOCAL VARIABLES AND PARAMETERS C INTEGER IKYDIM,ICKDIM, IDSDIM, I $(DECLAREC) C(9) INTEGER ID(5), IK(2) LOGICAL LERROR, LSKIP EXTERNAL MPLINE, TPCHKD, UTRDKY, TPSYNT, MMPUTV *IF(CSTAR1) SAVE IKYDIM, IK, ICKDIM, C, IDSDIM, ID *ENDIF DATA A IKYDIM, ICKDIM, B IK(1), C IK(2) D / 2, 9, E 6, F 3 / DATA B C(1), C(2), C(3), C(4), C(5), C(6), C C(7), C(8), C(9) D / *IF(CSTAR1) E 'E', 'N', 'D', 'S', 'E', 'T', F 'E', 'N', 'D' / *ELSE E 1HE, 1HN, 1HD, 1HS, 1HE, 1HT, F 1HE, 1HN, 1HD / *ENDIF DATA IDSDIM, ID(1), ID(2), ID(3), ID(4), ID(5) A / 5, 5, 4, -6, 5, 7 / C LSKIP = .TRUE. C 10 CONTINUE IF (LSKIP) ICBEOL = 0 CALL MPLINE (.TRUE.) CALL TPCHKD IF (.NOT. LDIRL) GO TO 20 IF (ICB1 .GT. ICB2) GO TO 30 CALL UTRDKY (CBUFFR, ICB1, ICB2, IK, IKYDIM, C, ICKDIM, I) IF (I .EQ. 1) GO TO 50 IF (I .EQ. 2) GO TO 60 IF (I .EQ. 3) GO TO 10 C C A TEXT LINE HAS BEEN ENCOUNTERED C 20 CONTINUE IF (.NOT. LSKIP) GO TO 10 CALL TPSYNT (ID, IDSDIM, .FALSE., LERROR) IF (LERROR) GO TO 10 IF (IARGS .EQ. 2) GO TO 40 ICBEOL = ICBP2(1) LSKIP = .FALSE. GO TO 10 C C A DIRECTIVE PREFIX CHARACTER HAS BEEN C ENCOUNTERED ON A LINE BY ITSELF C 30 CONTINUE IF (LSKIP) GO TO 10 ICBP1(2) = ICBP2(1) + 1 ICBP2(2) = ICB0 - 1 LSKIP = .TRUE. C C SAVE THE VALUE C 40 CONTINUE CALL MMPUTV (CBUFFR, ICBP1(1), ICBP2(1), A CBUFFR, ICBP1(2), ICBP2(2)) GO TO 10 C C AN ENDSET DIRECTIVE HAS BEEN ENCOUNTERED C 50 CONTINUE IF (.NOT. LSKIP) GO TO 10 GO TO 999 C C AN -END- DIRECTIVE HAS POSSIBLY BEEN ENCOUNTERED C 60 CONTINUE LEND = ICB1 .GT. ICB2 IF (.NOT. LEND) GO TO 10 C 999 CONTINUE RETURN END SUBROUTINE TPSYNT (IDSYNT, IDSDIM, LSCAN, LERROR) C C----------------------------------------------------------------------- C C FAMILY C ------ C TEMPLATE PROCESSOR C C PURPOSE C ------- C TO CHECK A DIRECTIVE LINE FOR CORRECT SYNTAX C C PARAMETERS C ---------- C IDSYNT -I- CONTAINS THE DIRECTIVE SYNTAX PATTERN. C THE VECTOR IDSYNT DESCRIBES THE TOKENS THAT C ARE ALLOWED. POSSIBLE VALUES OF IDSYNT(I): C ABS(IDSYNT(I)) TOKEN C -------------- ----- C 1 ( C 2 ) C 3 , C 4 = C 5 ID C 6 EXP C 7 EOL C 8 EOL C WHEN IDSYNT(I) < 0, TWO THINGS CAN HAPPEN: C - IF ABS(IDSYNT(I)) 'MATCHES' CURRENT TOKEN, C SKIP TO IDSYNT(I+2) FOR NEXT MATCH. C - IF NOT, SKIP TO IDSYNT(IDSYNT(I+1)) C FOR NEXT MATCH. C C IDSDIM -I- DIMENSION OF IDSYNT C LSCAN -I- IF TRUE, DIRECTIVES ARE TO BE SCANNED C BUT NOT EXECUTED C LERROR -O- TRUE IF THE DIRECTIVE HAS A SYNTAX ERROR C C----------------------------------------------------------------------- *INCLUDE(GLCOM) *INCLUDE(IOCOM) *INCLUDE(MMCOM) *INCLUDE(MPCOM) *INCLUDE(TPCOM) C C LOCAL VARIABLES AND PARAMETERS C INTEGER IDSDIM $(DECLAREC) C(4) INTEGER IDSYNT(IDSDIM) LOGICAL L, LEOL, LERROR, LSCAN INTEGER I, ICV1, IJUMP, ICV2 EXTERNAL UTRDBL, UTRDNA, TPEXPR, IOERRM *IF(CSTAR1) SAVE C *ENDIF DATA C(1), C(2), C(3), C(4) *IF(CSTAR1) A / '(', ')', ',', '=' / *ELSE A / 1H(, 1H), 1H,, 1H= / *ENDIF C I = 1 IARGS = 0 LERROR = .FALSE. C C DETERMINE WHICH TOKEN TO CHECK FOR C 10 CONTINUE ICV1 = ICB1 CALL UTRDBL (CBUFFR, ICB1, ICB2, LEOL) IJUMP = IABS(IDSYNT(I)) GO TO (20, 20, 20, 20, 30, 40, 50, 50), IJUMP C C CHECK FOR DELIMITERS AND SEPARATERS C 20 CONTINUE IF (LEOL) GO TO 80 IF (C(IJUMP) .NE. CBUFFR(ICB1)) GO TO 80 ICB1 = ICB1 + 1 GO TO 70 C C CHECK FOR A NAME C 30 CONTINUE IF (LEOL) GO TO 80 CALL UTRDNA (CBUFFR, ICB1, ICB2, ICV1, ICV2, L) IF (L) GO TO 80 GO TO 60 C C CHECK FOR AN EXPRESSION C 40 CONTINUE IF (LEOL) GO TO 80 CALL TPEXPR (ICV1, ICV2, LSCAN, L) IF (L) GO TO 80 GO TO 60 C C CHECK FOR END OF LINE C 50 CONTINUE IF (LEOL) GO TO 999 IF (IJUMP .NE. 8) GO TO 80 ICV2 = ICBEOL C 60 CONTINUE IARGS = IARGS + 1 IF (LSCAN) GO TO 70 ICBP1(IARGS) = ICV1 ICBP2(IARGS) = ICV2 C 70 CONTINUE IF (IDSYNT(I) .LT. 0) I = I + 1 I = I + 1 IF (I .LE. IDSDIM) GO TO 10 GO TO 999 C C IF THERE IS AN ALTERNATE SYNTAX FOR THIS STATEMENT C THEN TRY IT, OTHERWISE PRINT AN ERROR MESSAGE C 80 CONTINUE IF (IDSYNT(I).GT. 0) GO TO 90 I = IDSYNT(I+1) IF (I .LE. IDSDIM) GO TO 10 C C ERROR EXITS C 90 CONTINUE LERROR = .TRUE. GO TO (100, 110, 120, 130, 140, 150, 160, 160), IJUMP C 100 CONTINUE CALL IOERRM (.FALSE., *IF(LIBRARY) *IF(CSTAR1) A '('' +++++++ LEFT PARENTHESIS EXPECTED'')') *ELSE A 41H(36H +++++++ LEFT PARENTHESIS EXPECTED)) *ENDIF *ELSE *IF(CSTAR1) A '('' ******** TPSYNT - LEFT PARENTHESIS EXPECTED'')') *ELSE A 51H(46H ******** TPSYNT - LEFT PARENTHESIS EXPECTED)) *ENDIF *ENDIF GO TO 999 C 110 CONTINUE CALL IOERRM (.FALSE., *IF(LIBRARY) *IF(CSTAR1) A '('' +++++++ RIGHT PARENTHESIS EXPECTED'')') *ELSE A 42H(37H +++++++ RIGHT PARENTHESIS EXPECTED)) *ENDIF *ELSE *IF(CSTAR1) A '('' ******** TPSYNT - RIGHT PARENTHESIS EXPECTED'')') *ELSE A 52H(47H ******** TPSYNT - RIGHT PARENTHESIS EXPECTED)) *ENDIF *ENDIF GO TO 999 C 120 CONTINUE CALL IOERRM (.FALSE., *IF(LIBRARY) *IF(CSTAR1) A '('' +++++++ COMMA EXPECTED'')') *ELSE A 30H(25H +++++++ COMMA EXPECTED)) *ENDIF *ELSE *IF(CSTAR1) A '('' ******** TPSYNT - COMMA EXPECTED'')') *ELSE A 40H(35H ******** TPSYNT - COMMA EXPECTED)) *ENDIF *ENDIF GO TO 999 C 130 CONTINUE CALL IOERRM (.FALSE., *IF(LIBRARY) *IF(CSTAR1) A '('' +++++++ EQUALS SIGN EXPECTED'')') *ELSE A 36H(31H +++++++ EQUALS SIGN EXPECTED)) *ENDIF *ELSE *IF(CSTAR1) A '('' ******** TPSYNT - EQUALS SIGN EXPECTED'')') *ELSE A 46H(41H ******** TPSYNT - EQUALS SIGN EXPECTED)) *ENDIF *ENDIF GO TO 999 C 140 CONTINUE CALL IOERRM (.FALSE., *IF(LIBRARY) *IF(CSTAR1) A '('' +++++++ VARIABLE EXPECTED'')') *ELSE A 33H(28H +++++++ VARIABLE EXPECTED)) *ENDIF *ELSE *IF(CSTAR1) A '('' ******** TPSYNT - VARIABLE EXPECTED'')') *ELSE A 43H(38H ******** TPSYNT - VARIABLE EXPECTED)) *ENDIF *ENDIF GO TO 999 C 150 CONTINUE CALL IOERRM (.FALSE., *IF(LIBRARY) *IF(CSTAR1) A '('' +++++++ MISSING OR UNRECOGNIZED EXPRESSION'')') *ELSE A 50H(45H +++++++ MISSING OR UNRECOGNIZED EXPRESSION)) *ENDIF *ELSE *IF(CSTAR1) A '('' ******** TPSYNT - MISSING OR UNRECOGNIZED EXPRESSION'')') *ELSE A 60H(55H ******** TPSYNT - MISSING OR UNRECOGNIZED EXPRESSION)) *ENDIF *ENDIF GO TO 999 C 160 CONTINUE CALL IOERRM (.FALSE., *IF(LIBRARY) *IF(CSTAR1) A '('' +++++++ ILLEGAL CHARACTERS AT END OF LINE'')') *ELSE A 49H(44H +++++++ ILLEGAL CHARACTERS AT END OF LINE)) *ENDIF *ELSE *IF(CSTAR1) A '('' ******** TPSYNT - ILLEGAL CHARACTERS AT END OF LINE'')') *ELSE A 59H(54H ******** TPSYNT - ILLEGAL CHARACTERS AT END OF LINE)) *ENDIF *ENDIF C 999 CONTINUE RETURN END SUBROUTINE UTBLDN (CPREFX, CROOT, ICR1, ICR2, ISUFFX, A CNAME, ICN1, ICN2, ICNDIM, LERROR) C C----------------------------------------------------------------------- C C FAMILY C ------ C UTILITY C C PURPOSE C ------- C TO BUILD A NAME GIVEN A PREFIX, ROOT, AND SUFFIX C C PARAMETERS C ---------- C CPREFX -I- A ONE CHARACTER PREFIX C CROOT -I- ROOT OF THE NAME C ICR1 -I- INDEX OF THE FIRST CHARACTER IN THE ROOT C ICR2 -I- INDEX OF THE LAST CHARACTER IN THE ROOT C ISUFFX -I- INTEGER SUFFIX C CNAME -O- THE NAME C ICN1 -I- INDEX OF THE FIRST CHARACTER IN THE NAME C ICN2 -O- INDEX OF THE LAST CHARACTER IN THE NAME C ICNDIM -I- DIMENSION OF CNAME C LERROR -O- TRUE IF AN ERROR OCCURED C C----------------------------------------------------------------------- *INCLUDE(GLCOM) C C LOCAL VARIABLES AND PARAMETERS C INTEGER ICR1, ICR2, ISUFFX, ICN1, ICN2, ICNDIM $(ARGDECLAREC) CNAME(ICNDIM), CPREFX, CROOT(ICR2) LOGICAL LERROR INTEGER I EXTERNAL UTCVIC C LERROR = ICN1 + ICR2 - ICR1 + 1 .GT. ICNDIM IF (LERROR) GO TO 999 ICN2 = ICN1 CNAME(ICN2) = CPREFX IF (ICR1 .GT. ICR2) GO TO 20 DO 10 I=ICR1,ICR2 ICN2 = ICN2 + 1 CNAME(ICN2) = CROOT(I) 10 CONTINUE 20 CONTINUE IF (ISUFFX .LT. 0) GO TO 999 I = ICN2 + 1 CALL UTCVIC (CNAME, I, ICN2, ICNDIM, ISUFFX, LERROR) C 999 CONTINUE RETURN END *IF(TESTCH) *ELSE SUBROUTINE UTCHKA (C, LALPHA) C C----------------------------------------------------------------------- C C FAMILY C ------ C UTILITY C C PURPOSE C ------- C TO CHECK TO SEE IF A CHARACTER IS ALPHABETIC. C THIS ROUTINE MAY HAVE TO BE MODIFIED FOR SOME CHARACTER SETS. C IN A FORTRAN 77 SETTING THE INTRINSIC LLE MAY BE USEFUL. C C PARAMETERS C ---------- C C -I- THE CHARACTER TO BE TESTED C LALPHA -O- TRUE IF THE CHARACTER IS ALPHABETIC C C----------------------------------------------------------------------- *INCLUDE(GLCOM) C C LOCAL VARIABLES AND PARAMETERS C $(ARGDECLAREC) C LOGICAL LALPHA C LALPHA = (CA .LE. C) .AND. (C .LE. CZ) C RETURN END *ENDIF *IF(TESTCH) *ELSE SUBROUTINE UTCHKN (C, LNUMER) C C----------------------------------------------------------------------- C C FAMILY C ------ C UTILITY C C PURPOSE C ------- C TO CHECK TO SEE IF A CHARACTER IS NUMERIC C THIS ROUTINE MAY HAVE TO BE MODIFIED FOR SOME CHARACTER SETS. C C PARAMETERS C ---------- C C -I- CHARACTER TO BE TESTED C LNUMER -O- TRUE IF THE CHARACTER IS NUMERIC C C----------------------------------------------------------------------- *INCLUDE(GLCOM) C C LOCAL VARIABLES AND PARAMETERS C $(ARGDECLAREC) C LOGICAL LNUMER C LNUMER = (C0 .LE. C) .AND. (C .LE. C9) C RETURN END *ENDIF *IF(TESTCH) *ELSE SUBROUTINE UTCHKS (C, LSPECL) C C----------------------------------------------------------------------- C C FAMILY C ------ C UTILITY C C PURPOSE C ------- C TO CHECK TO SEE IF A CHARACTER IS A SPECIAL CHARACTER, C I.E. NOT ALPHABETIC OR NUMERIC C THIS ROUTINE MAY HAVE TO BE MODIFIED FOR SOME CHARACTER SETS. C C PARAMETERS C ---------- C C -I- CHARACTER TO BE TESTED C LSPECL -O- TRUE IF THE CHARACTER IS A SPECIAL CHARACTER C C----------------------------------------------------------------------- *INCLUDE(GLCOM) C C LOCAL VARIABLES AND PARAMETERS C $(ARGDECLAREC) C LOGICAL LSPECL C LSPECL = .NOT. (((CA .LE. C) .AND. (C .LE. CZ)) .OR. A ((C0 .LE. C) .AND. (C .LE. C9))) C RETURN END *ENDIF SUBROUTINE UTCVCI (CLINE, ICL1, ICL2, IVALUE, LERROR) C C----------------------------------------------------------------------- C C FAMILY C ------ C UTILITY C C PURPOSE C ------- C TO CONVERT A CHARACTER STRING INTO AN INTEGER C C PARAMETERS C ---------- C CLINE -I- STRING TO BE CONVERTED C ICL1 -I- INDEX OF THE FIRST CHARACTER IN THE STRING C ICL2 -I- INDEX OF THE LAST CHARACTER IN THE STRING C IVALUE -O- INTEGER RESULT C LERROR -O- TRUE IF AN ERROR OCCURED C C----------------------------------------------------------------------- *INCLUDE(GLCOM) C C LOCAL VARIABLES AND PARAMETERS C INTEGER ICL1, ICL2, IVALUE $(ARGDECLAREC) CLINE(ICL2) $(DECLAREC) C(10), CLINEI LOGICAL LERROR, LMINUS INTEGER I, I1, IC EXTERNAL UTRDBL *IF(CSTAR1) SAVE C *ENDIF DATA C(1), C(2), C(3), C(4), C(5), A C(6), C(7), C(8), C(9), C(10) *IF(CSTAR1) B / '0', '1', '2', '3', '4', C '5', '6', '7', '8', '9' / *ELSE B / 1H0, 1H1, 1H2, 1H3, 1H4, C 1H5, 1H6, 1H7, 1H8, 1H9 / *ENDIF C IVALUE = 0 I = ICL1 CALL UTRDBL (CLINE, I, ICL2, LERROR) IF (LERROR) GO TO 999 LMINUS = CLINE(I) .EQ. CMINUS IF ((.NOT. LMINUS) .AND. (CLINE(I) .NE. CPLUS)) GO TO 10 I = I + 1 CALL UTRDBL (CLINE, I, ICL2, LERROR) IF (LERROR) GO TO 999 C 10 CONTINUE I1 = I DO 40 I=I1,ICL2 CLINEI = CLINE(I) DO 20 IC=1,10 IF (CLINEI .EQ. C(IC)) GO TO 30 20 CONTINUE IF (I .GT. I1) GO TO 50 GO TO 999 30 CONTINUE IVALUE = IVALUE*10 + IC - 1 40 CONTINUE C 50 CONTINUE LERROR = .FALSE. IF (LMINUS) IVALUE = -IVALUE C 999 CONTINUE RETURN END SUBROUTINE UTCVCL (CLINE, ICL1, ICL2, LVALUE, LERROR) C C----------------------------------------------------------------------- C C FAMILY C ------ C UTILITY C C PURPOSE C ------- C TO CONVERT A CHARACTER STRING TO A LOGICAL VALUE C C PARAMETERS C ---------- C CLINE -I- STRING TO BE CONVERTED C ICL1 -I- INDEX OF THE FIRST CHARACTER IN THE STRING C ICL2 -I- INDEX OF THE LAST CHARACTER IN THE STRING C LVALUE -O- THE LOGICAL RESULT C LERROR -I- TRUE IF AN ERROR OCCURED C C----------------------------------------------------------------------- *INCLUDE(GLCOM) C C LOCAL VARIABLES AND PARAMETERS C INTEGER ICL1, ICL2 $(ARGDECLAREC) CLINE(ICL2) $(DECLAREC) C(13) INTEGER IK(2) LOGICAL LERROR, LV(3), LVALUE INTEGER IKYDIM, ICKDIM, I EXTERNAL UTRDKY *IF(CSTAR1) SAVE IKYDIM, IK, ICKDIM, C, LV *ENDIF DATA A IKYDIM, ICKDIM, B IK(1), C IK(2) D / 6, 13, E 6, F 7 / DATA B C(1), C(2), C(3), C(4), C(5), C(6), C C(7), C(8), C(9), C(10), C(11), C(12), C(13) D / *IF(CSTAR1) E '.', 'T', 'R', 'U', 'E', '.', F '.', 'F', 'A', 'L', 'S', 'E', '.' / *ELSE E 1H., 1HT, 1HR, 1HU, 1HE, 1H., F 1H., 1HF, 1HA, 1HL, 1HS, 1HE, 1H. / *ENDIF DATA A LV(1), LV(2), LV(3) B / .TRUE., .FALSE., .TRUE. / C LERROR = .TRUE. IF (ICL1 .GT. ICL2) GO TO 999 DO 10 I=ICL1,ICL2 IF (CLINE(I) .NE. CBLANK) GO TO 20 10 CONTINUE GO TO 999 C 20 CONTINUE CALL UTRDKY (CLINE, ICL1, ICL2, IK, IKYDIM, C, ICKDIM, I) LERROR = I .GT. IKYDIM LVALUE = LV(I) C 999 CONTINUE RETURN END SUBROUTINE UTCVIC (CLINE, ICL1, ICL2, ICLDIM, IVALUE, LERROR) C C----------------------------------------------------------------------- C C FAMILY C ------ C UTILITY C C PURPOSE C ------- C TO CONVERT AN INTEGER INTO A CHARACTER STRING C C PARAMETERS C ---------- C CLINE -O- STRING RESULT C ICL1 -I- INDEX OF THE FIRST CHARACTER IN THE STRING C ICL2 -O- INDEX OF THE LAST CHARACTER IN THE STRING C ICLDIM -I- DIMENSION OF CLINE C IVALUE -I- INTEGER TO BE CONVERTED C LERROR -O- TRUE IF AN ERROR OCCURED C C----------------------------------------------------------------------- *INCLUDE(GLCOM) C C LOCAL VARIABLES AND PARAMETERS C INTEGER ICL1, ICL2, ICLDIM, IVALUE $(ARGDECLAREC) CLINE(ICLDIM) $(DECLAREC) C(10), CTEMP LOGICAL LERROR INTEGER I1, I2, ICL2MD *IF(CSTAR1) SAVE C *ENDIF DATA C(1), C(2), C(3), C(4), C(5), A C(6), C(7), C(8), C(9), C(10) *IF(CSTAR1) B / '0', '1', '2', '3', '4', C '5', '6', '7', '8', '9' / *ELSE B / 1H0, 1H1, 1H2, 1H3, 1H4, C 1H5, 1H6, 1H7, 1H8, 1H9 / *ENDIF C I1 = IABS(IVALUE) LERROR = .TRUE. ICL2 = ICL1 - 1 C C CONVERT AND THEN REMOVE THE LEAST SIGNIFICANT DIGITS FIRST C 10 CONTINUE I2 = I1 I1 = I1 / 10 I2 = I2 - I1*10 ICL2 = ICL2 + 1 IF (ICL2 .GT. ICLDIM) GO TO 999 CLINE(ICL2) = C(I2+1) IF (I1 .GT. 0) GO TO 10 C C IF NECESSARY, ADD THE MINUS SIGN C IF (IVALUE .GE. 0) GO TO 20 ICL2 = ICL2 + 1 IF (ICL2 .GT. ICLDIM) GO TO 999 CLINE(ICL2) = CMINUS C C REVERSE THE STRING TO PUT THE DIGITS IN THE PROPER ORDER C 20 CONTINUE LERROR = .FALSE. IF (ICL1 .GE. ICL2) GO TO 999 ICL2MD = (ICL1 + ICL2 - 1) / 2 I2 = ICL2 DO 30 I1=ICL1,ICL2MD CTEMP = CLINE(I1) CLINE(I1) = CLINE(I2) CLINE(I2) = CTEMP I2 = I2 - 1 30 CONTINUE C 999 CONTINUE RETURN END SUBROUTINE UTCVLC (CLINE, ICL1, ICL2, ICLDIM, LVALUE, LERROR) C C----------------------------------------------------------------------- C C FAMILY C ------ C UTILITY C C PURPOSE C ------- C TO CONVERT A LOGICAL VALUE TO A CHARACTER C C PARAMETERS C ---------- C CLINE -O- STRING RESULT C ICL1 -I- INDEX OF THE FIRST CHARACTER IN THE STRING C ICL2 -O- INDEX OF THE LAST CHARACTER IN THE STRING C ICLDIM -I- DIMENSION OF CLINE C LVALUE -I- LOGICAL VALUE TO BE CONVERTED C LERROR -O- TRUE IF AN ERROR OCCURED C C----------------------------------------------------------------------- *INCLUDE(GLCOM) C C LOCAL VARIABLES AND PARAMETERS C INTEGER ICL1, ICL2, ICLDIM $(ARGDECLAREC) CLINE(ICLDIM) $(DECLAREC) CF(7), CT(6) LOGICAL LERROR, LVALUE INTEGER ICFDIM, ICTDIM, I *IF(CSTAR1) SAVE ICFDIM, CF, ICTDIM, CT *ENDIF DATA A ICFDIM, B ICTDIM C / 7, D 6 / DATA A CF(1), CF(2), CF(3), CF(4), CF(5), CF(6), CF(7), B CT(1), CT(2), CT(3), CT(4), CT(5), CT(6) *IF(CSTAR1) C / '.', 'F', 'A', 'L', 'S', 'E', '.', D '.', 'T', 'R', 'U', 'E', '.' / *ELSE C / 1H., 1HF, 1HA, 1HL, 1HS, 1HE, 1H., D 1H., 1HT, 1HR, 1HU, 1HE, 1H. / *ENDIF C ICL2 = ICL1 - 1 IF (LVALUE) GO TO 20 LERROR = (ICL2 + ICFDIM) .GT. ICLDIM IF (LERROR) GO TO 999 DO 10 I=1,ICFDIM ICL2 = ICL2 + 1 CLINE(ICL2) = CF(I) 10 CONTINUE GO TO 999 C 20 CONTINUE LERROR = (ICL2 + ICTDIM) .GT. ICLDIM IF (LERROR) GO TO 999 DO 30 I=1,ICTDIM ICL2 = ICL2 + 1 CLINE(ICL2) = CT(I) 30 CONTINUE C 999 CONTINUE RETURN END SUBROUTINE UTCVNI (CNAME, ICN1, ICN2, INAME, LERROR) C----------------------------------------------------------------------- C C FAMILY C ------ C UTILITY C C PURPOSE C ------- C TO CONVERT (HASH) A NAME INTO AN INTEGER C C PARAMETERS C ---------- C CNAME -I- THE NAME TO BE HASHED C ICN1 -I- INDEX OF THE FIRST CHARACTER IN THE NAME C ICN2 -I- INDEX OF THE LAST CHARACTER IN THE NAME C INAME -O- INTEGER RESULT C LERROR -O- TRUE IF AN ERROR OCCURED C C----------------------------------------------------------------------- *INCLUDE(GLCOM) C C LOCAL VARIABLES AND PARAMETERS C INTEGER ICN1, ICN2, INAME $(ARGDECLAREC) CNAME(ICN2) INTEGER ICHDIM, ICIDIM, I, ICNMIN, ICN, ICH *IF(CDC) LOGICAL LERROR DATA ICIDIM / 6 / *ELSE INTEGER IC(6) LOGICAL LERROR $(DECLAREC) C(48), CNAMEI *IF(CSTAR1) SAVE ICIDIM, IC, ICHDIM, C *ENDIF DATA A ICHDIM, B C(1), C(2), C(3), C(4), C(5), C(6), C C(7), C(8), C(9), C(10), C(11), C(12), D C(13), C(14), C(15), C(16), C(17), C(18), E C(19), C(20), C(21), C(22), C(23), C(24), F C(25), C(26), C(27), C(28), C(29), C(30), G C(31), C(32), C(33), C(34), C(35), C(36), H C(37), C(38), C(39), C(40), C(41), C(42), I C(43), C(44), C(45), C(46), C(47), C(48) J / 48, *OPTION(LSUB=.FALSE.) *IF(CSTAR1) K 'A', 'B', 'C', 'D', 'E', 'F', L 'G', 'H', 'I', 'J', 'K', 'L', M 'M', 'N', 'O', 'P', 'Q', 'R', N 'S', 'T', 'U', 'V', 'W', 'X', O 'Y', 'Z', '0', '1', '2', '3', P '4', '5', '6', '7', '8', '9', Q '+', '-', '*', ',', '=', '(', R ')', '.', ',', '''', '$', ' ' / *ELSE K 1HA, 1HB, 1HC, 1HD, 1HE, 1HF, L 1HG, 1HH, 1HI, 1HJ, 1HK, 1HL, M 1HM, 1HN, 1HO, 1HP, 1HQ, 1HR, N 1HS, 1HT, 1HU, 1HV, 1HW, 1HX, O 1HY, 1HZ, 1H0, 1H1, 1H2, 1H3, P 1H4, 1H5, 1H6, 1H7, 1H8, 1H9, Q 1H+, 1H-, 1H*, 1H,, 1H=, 1H(, R 1H), 1H., 1H,, 1H', 1H$, 1H / *ENDIF *OPTION(LSUB=.TRUE.) DATA A ICIDIM, B IC(1), IC(2), IC(3), IC(4), IC(5), IC(6) C / 6, D 61, 1, 47, 61, 1, 47 / *ENDIF C LERROR = ICN1 .GT. ICN2 IF (LERROR) GO TO 999 I = 0 INAME = 0 ICNMIN = MIN0(ICN2, ICN1+ICIDIM-1) C *IF(CDC) *IF(CSTAR1) DO 10 ICN=ICN1,ICNMIN INAME = INAME .OR. SHIFT(ICHAR(CNAME(ICN)), I) I = I + 6 10 CONTINUE *ELSE DO 10 ICN=ICN1,ICNMIN I = I + 6 INAME = INAME .OR. A SHIFT(CNAME(ICN).AND.77000000000000000000B, I) 10 CONTINUE *ENDIF *ELSE C DO 30 ICN=ICN1,ICNMIN CNAMEI = CNAME(ICN) DO 10 ICH=1,ICHDIM IF (CNAMEI .EQ. C(ICH)) GO TO 20 10 CONTINUE ICH = ICHDIM + 1 20 CONTINUE I = I + 1 INAME = INAME + IC(I)*ICH 30 CONTINUE *ENDIF C 999 CONTINUE RETURN END SUBROUTINE UTRDBL (CLINE, ICL1, ICL2, LEOL) C C----------------------------------------------------------------------- C C FAMILY C ------ C UTILITY C C PURPOSE C ------- C TO READ (SKIP) BLANKS IN A LINE C C PARAMETERS C ---------- C CLINE -I- LINE OF CHARACTERS C ICL1 -I- INDEX OF THE FIRST CHARACTER IN THE LINE C ICL2 -I- INDEX OF THE LAST CHARACTER IN THE LINE C LEOL -O- TRUE IF THE END OF THE LINE WAS REACHED C C----------------------------------------------------------------------- *INCLUDE(GLCOM) C C LOCAL VARIABLES AND PARAMETERS C INTEGER ICL1, ICL2 $(ARGDECLAREC) CLINE(ICL2) LOGICAL LEOL INTEGER I C IF (ICL1 .GT. ICL2) GO TO 20 C DO 10 I=ICL1,ICL2 IF (CBLANK .NE. CLINE(I)) GO TO 30 10 CONTINUE C 20 CONTINUE ICL1 = ICL2 + 1 LEOL = .TRUE. GO TO 999 C 30 CONTINUE ICL1 = I LEOL = .FALSE. C 999 CONTINUE RETURN END SUBROUTINE UTRDKY (CLINE, ICL1, ICL2, IKEY, IKYDIM, A CKEY, ICKDIM, IK) C C----------------------------------------------------------------------- C C FAMILY C ------ C UTILITY C C PURPOSE C ------- C TO MATCH CHARACTERS WITH ONE OF A GIVEN SET OF KEYS C C PARAMETERS C ---------- C CLINE -I- LINE OF CHARACTERS C ICL1 -I- INDEX OF THE FIRST CHARACTER IN THE LINE C ICL2 -I- INDEX OF THE LAST CHARACTER IN THE LINE C IKEY -I- CONTAINS THE LENGTH OF EACH KEY C IKYDIM -I- NUMBER OF KEYS C CKEY -I- CONTAINS THE KEYS C CKYDIM -I- DIMENSION OF CKEY C IK -O- NUMBER OF THE MATCHED KEY C C----------------------------------------------------------------------- *INCLUDE(GLCOM) C C LOCAL VARIABLES AND PARAMETERS C INTEGER ICL1, ICL2, IKYDIM, ICKDIM, IK $(ARGDECLAREC) CLINE(ICL2), CKEY(ICKDIM) INTEGER IKEY(IKYDIM) INTEGER ICK2, ICLDIF, ICK1, I, ICK C IF (ICL1 .GT. ICL2) GO TO 30 ICK2 = 0 ICLDIF = ICL2 - ICL1 + 1 C DO 20 IK=1,IKYDIM ICK1 = ICK2 + 1 ICK2 = ICK2 + IKEY(IK) IF (ICLDIF .LT. IKEY(IK)) GO TO 20 I = ICL1 DO 10 ICK=ICK1,ICK2 IF (CLINE(I) .NE. CKEY(ICK)) GO TO 20 I = I + 1 10 CONTINUE GO TO 40 20 CONTINUE C 30 CONTINUE IK = IKYDIM + 1 GO TO 999 C 40 CONTINUE ICL1 = ICL1 + IKEY(IK) C 999 CONTINUE RETURN END SUBROUTINE UTRDNA (CLINE, ICL1, ICL2, ICL1NA, ICL2NA, LERROR) C C----------------------------------------------------------------------- C C FAMILY C ------ C UTILITY C C PURPOSE C ------- C TO READ A NAME ON A LINE C C PARAMETERS C ---------- C CLINE -I- LINE OF CHARACTERS C ICL1 -I- INDEX OF THE FIRST CHARACTER IN THE LINE C ICL2 -I- INDEX OF THE LAST CHARACTER IN THE LINE C ICL1NA -O- INDEX OF THE FIRST CHARACTER IN THE NAME C ICL2NA -O- INDEX OF THE LAST CHARACTER IN THE NAME C LERROR -O- TRUE IF AN ERROR OCCURED C C----------------------------------------------------------------------- *INCLUDE(GLCOM) C C LOCAL VARIABLES AND PARAMETERS C INTEGER ICL1, ICL2, ICL1NA, ICL2NA $(ARGDECLAREC) CLINE(ICL2) LOGICAL LERROR INTEGER I C LERROR = .TRUE. IF (ICL1 .GT. ICL2) GO TO 999 C DO 10 I=ICL1,ICL2 *IF(TESTCH) *IF(CSTAR1) IF (.NOT. ((LLE(CA,CLINE(I)) A .AND. LLE(CLINE(I),CZ)) B .OR. (LLE(C0,CLINE(I)) C .AND. LLE(CLINE(I),C9)))) GO TO 20 *ELSE IF (.NOT. (((CA .LE. CLINE(I)) A .AND. (CLINE(I) .LE. CZ)) B .OR. ((C0 .LE. CLINE(I)) C .AND. (CLINE(I) .LE. C9)))) GO TO 20 *ENDIF *ELSE CALL UTCHKS (CLINE(I), L) IF (L) GO TO 20 *ENDIF 10 CONTINUE C I = ICL2 + 1 C 20 CONTINUE *IF(TESTCH) *IF(CSTAR1) IF (.NOT. (LLE(CA,CLINE(ICL1)) A .AND. LLE(CLINE(ICL1),CZ))) GO TO 999 *ELSE IF (.NOT. ((CA .LE. CLINE(ICL1)) A .AND. (CLINE(ICL1) .LE. CZ))) GO TO 999 *ENDIF *ELSE CALL UTCHKA (CLINE(ICL1), L) IF (.NOT. L) GO TO 999 *ENDIF ICL1NA = ICL1 ICL1 = I ICL2NA = I - 1 LERROR = .FALSE. C 999 CONTINUE RETURN END SUBROUTINE UTRDNU (CLINE, ICL1, ICL2, ICL1NU, ICL2NU, LERROR) C C----------------------------------------------------------------------- C C FAMILY C ------ C UTILITY C C PURPOSE C ------- C TO READ A NUMBER ON A LINE C C PARAMETERS C ---------- C CLINE -I- LINE OF CHARACTERS C ICL1 -I- INDEX OF THE FIRST CHARACTER IN THE LINE C ICL2 -I- INDEX OF THE LAST CHARACTER IN THE LINE C ICL1NU -O- INDEX OF THE FIRST CHARACTER IN THE NUMBER C ICL2NU -O- INDEX OF THE LAST CHARACTER IN THE NUMBER C LERROR -O- TRUE IF AN ERROR OCCURED C C----------------------------------------------------------------------- *INCLUDE(GLCOM) C C LOCAL VARIABLES AND PARAMETERS C INTEGER ICL1, ICL2, ICL1NU, ICL2NU $(ARGDECLAREC) CLINE(ICL2) LOGICAL LERROR INTEGER I, ICL EXTERNAL UTRDBL C LERROR = ICL1 .GT. ICL2 IF (LERROR) GO TO 999 I = ICL1 IF ((CLINE(I) .NE. CMINUS) A .AND. (CLINE(I) .NE. CPLUS)) GO TO 10 I = I + 1 CALL UTRDBL (CLINE, I, ICL2, LERROR) IF (LERROR) GO TO 999 C 10 CONTINUE ICL = I DO 20 I=ICL,ICL2 *IF(TESTCH) *IF(CSTAR1) IF (.NOT. (LLE(C0,CLINE(I)) A .AND. LLE(CLINE(I),C9))) GO TO 30 *ELSE IF (.NOT. ((C0 .LE. CLINE(I)) A .AND. (CLINE(I) .LE. C9))) GO TO 30 *ENDIF *ELSE CALL UTCHKN (CLINE(I), L) IF (.NOT. L) GO TO 30 *ENDIF 20 CONTINUE C I = ICL2 + 1 C 30 CONTINUE ICL1NU = ICL1 ICL1 = I ICL2NU = I - 1 LERROR = ICL1NU .GT. ICL2NU C 999 CONTINUE RETURN END SUBROUTINE UTRDQS (CLINE, ICL1, ICL2, ICL1QS, ICL2QS, LERROR) C C----------------------------------------------------------------------- C C FAMILY C ------ C UTILITY C C PURPOSE C ------- C TO READ A QUOTED STRING ON A LINE C C PARAMETERS C ---------- C CLINE -I- LINE OF CHARACTERS C ICL1 -I- INDEX OF THE FIRST CHARACTER IN THE LINE C ICL2 -I- INDEX OF THE LAST CHARACTER IN THE LINE C ICL1QS -O- INDEX OF THE FIRST CHARACTER IN THE STRING C ICL2QS -O- INDEX OF THE LAST CHARACTER IN THE STRING C LERROR -O- TRUE IF AN ERROR OCCURED C C----------------------------------------------------------------------- *INCLUDE(GLCOM) C C LOCAL VARIABLES AND PARAMETERS C INTEGER ICL1, ICL2, ICL1QS, ICL2QS $(ARGDECLAREC) CLINE(ICL2) $(DECLAREC) CQTEMP LOGICAL LERROR INTEGER I C LERROR = .TRUE. ICL1QS = ICL1 + 1 IF (ICL1QS .GT. ICL2) GO TO 999 CQTEMP = CLINE(ICL1) C DO 10 I=ICL1QS,ICL2 IF (CLINE(I) .EQ. CQTEMP) GO TO 20 10 CONTINUE C GO TO 999 C 20 CONTINUE ICL1 = I + 1 ICL2QS = I - 1 LERROR = .FALSE. C 999 CONTINUE RETURN END *END SHAR_EOF fi # end of overwriting check if test -f 'macrop.out' then echo shar: will not over-write existing file "'macrop.out'" else cat << SHAR_EOF > 'macrop.out' C PROGRAM GO C C---------------------------------------------------------------------- C C FAMILY C ------ C SYSTEM/USER INTERFACE C C PURPOSE C ------- C THIS IS A SAMPLE MAIN PROGRAM TO CALL THE C DRIVING ROUTINE OF THE MACRO PROCESSOR. C C---------------------------------------------------------------------- C C GLOBAL CONSTANTS C CHARACTER*1 CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 COMMON / GLCOMC / CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 C C INPUT / OUTPUT CONTROL INTERFACE C CHARACTER*1 CBUFFR(2000) LOGICAL LBREAK, LFORT, LISTI, LISTO INTEGER ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOMC / CBUFFR COMMON / IOCOMI / ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOML / LBREAK, LFORT, LISTI, LISTO C C MEMORY MANAGER INTERFACE C CHARACTER*1 CSTORE(20000) INTEGER IHASH(601), ISTORE(6000) INTEGER ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS COMMON / MMCOMC / CSTORE COMMON / MMCOMH / IHASH COMMON / MMCOMS / ISTORE COMMON / MMCOMI / ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS C C MACRO PROCESSOR INTERFACE C CHARACTER*1 CDIV, CEOL, CEOR, CONC, CSUB, A CTOP LOGICAL LEMPTY, LSUB COMMON / MPCOMC / CDIV, CEOL, CEOR, CONC, CSUB, A CTOP COMMON / MPCOML / LEMPTY, LSUB C C TEMPLATE PROCESSOR INTERFACE C CHARACTER*1 CDIR, CSTAR INTEGER ICBP1(4), ICBP2(4) INTEGER ITOPDO, IARGS, INESTD, INESTF LOGICAL LCOL1, LDIRL, LEND, LINITM, L1TRIP COMMON / TPCOMC / CDIR, CSTAR COMMON / TPCOMI / ICBP1, ITOPDO, IARGS, ICBP2, INESTD, B INESTF COMMON / TPCOML / LCOL1, LDIRL, LEND, LINITM, L1TRIP EXTERNAL TPDRV, TPMMIN C C SET DIMENSIONS FOR ARRAYS C ICBDIM = 2000 ICSDIM = 20000 IHADIM = 601 ISTDIM = 6000 C C INITIALIZE TEMPLATE PROCESSOR C CALL TPMMIN C C CALL DRIVER C USING UNIX STANDARD ERROR, INPUT, AND OUTPUT UNITS C CALL TPDRV (0, 5, 0, 6) C STOP 0 END SUBROUTINE TPDRV (IUE0, IUI0, IUL0, IUO0) C C----------------------------------------------------------------------- C C FAMILY C ------ C TEMPLATE PROCESSOR C C PURPOSE C ------- C THIS IS THE DRIVING ROUTINE OF THE TEMPLATE PROCESSOR. C IT CALLS ROUTINES TO READ, EVALUATE, AND WRITE LINES C UNTIL AN END DIRECTIVE IS ENCOUNTERED C C PARAMETERS C ---------- C IUE0 -I- UNIT NUMBER FOR THE ERROR FILE C IUI0 -I- UNIT NUMBER FOR THE INPUT FILE C IUL0 -I- UNIT NUMBER FOR THE LISTING FILE C IUO0 -I- UNIT NUMBER FOR THE OUTPUT FILE C C COMMON VARIABLES AND DATA STRUCTURES C ------------------------------------ C THE COMMENTS BELOW GIVE A BRIEF DESCRIPTION OF THE COMMON C VARIABLES USED BY THE ROUTINES OF THE TEMPLATE PROCESSOR. C A MORE DETAILED LOOK AT THE MAIN DATA STRUCTURES IS ALSO C INCLUDED. C C GLOBAL CONSTANTS C C COMMON / GLCOMC / C CA - 'A' CPOINT - '.' C CBLANK - ' ' CQUOTE - ''' C CC - 'C' CRIGHT - '(' C CI - 'I' CZ - 'Z' C CLEFT - '(' C0 - '0' C CMINUS - '-' C9 - '9' C CPLUS - '+' C C INPUT / OUTPUT CONTROL INTERFACE C C COMMON / IOCOMC / C CBUFFR - I/O BUFFER C COMMON / IOCOMI / C ICBADD - NUMBER OF SPACES TO SKIP BEFORE THE CONTINUATION C OF A BROKEN LINE C ICBEND - BUFFER POSITION OF END OF CURRENT LOGICAL LINE C (LOGICAL LINE MAY INCLUDE SEVERAL ACTUAL LINES) C ICBEOL - BUFFER POSITION OF CURRENT EOL. C ICBSUB - BUFFER POSITION OF CURRENT SUB. PREF. CHARACTER C ICB0 - BUFFER POSITION OF START OF CURRENT LINE C ICB1 - BUFFER POSITION WHERE CURRENT PROCESSING BEGINS C ICB2 - BUFFER POSITION WHERE CURRENT PROCESSING ENDS C ICB3 - BUFFER POSITION OF END OF CURRENT LINE C ICBDIM - DIMENSION OF CBUFFR C ICPLI - INPUT LINE LENGTH C ICPLO - OUPUT LINE LENGTH C ILCTR - LINE NUMBER ON CURRENT LISTING PAGE C ILNMBR - LINE NUMBER FOR LISTING (OVER ALL PAGES) C ILPP - MAX NUMBER OF LINES PER LISTING PAGE C IPAGE - PAGE NUMBER ON LISTING C IUNITE - ERROR OUTPUT UNIT C IUNITI - INPUT UNIT C IUNITL - LISTING OUTPUT UNIT C IUNITO - STANDARD OUTPUT UNIT C COMMON / IOCOML / C LBREAK - BREAK LONG LINES AT NICE PLACE IF TRUE C LFORT - USE FORTRAN CONTINUATION CHAR. IF TRUE C LISTI - LIST INPUT IF TRUE C LISTO - LIST OUTPUT IF TRUE C C MEMORY MANAGER INTERFACE C C COMMON / MMCOMC / C CSTORE - CHARACTER STORAGE C COMMON / MMCOMH / C IHASH - HASH TABLE (IHASH(I) IS AN INDEX INTO ISTORE) C COMMON / MMCOMS / C ISTORE - INTEGER STORAGE; HOLDS THE POINTERS WHICH C IMPLEMENT THE SYMBOL TABLE AND THE STACK C COMMON / MMCOMI / C ICSDIM - DIMENSION OF ICSDIM C ICSP1 - PTR. TO TOP CHARACTER IN SUBSTITUTION STACK C ICSP2 - PTR. TO LAST CHAR. IN FIRST STRING ON STACK C IHADIM - DIMENSION OF IHASH C ISFREE - PTR. TO HEAD OF ISTORE FREELIST C ISTDIM - DIMENSION OF ISTORE C IS2HDC - PTR. TO HEAD OF FREE CHARACTER STORAGE BLOCKS C (ACTUALLY AN INDEX INTO ISTORE) C IS2HDS - PTR. TO TOP OF STACK C (ACTUALLY AN INDEX INTO ISTORE) C C MACRO PROCESSOR INTERFACE C C COMMON / MPCOMC / C CDIV - '/' C CEOL - '-' C CEOR - '/' C CONC - '+' C CSUB - DOLLAR SIGN C CTOP - TOP CHAR. IN STACK C COMMON / MPCOML / C LEMPTY - TRUE IF SUBSTITUTION STACK EMPTY C LSUB - TRUE IF SUBSTITUTIONS ARE TO BE PERFORMED C C TEMPLATE PROCESSOR INTERFACE C C COMMON / TPCOMC / C CDIR - '*' C CSTAR - '*' C COMMON / TPCOMI / C ICBP1 - ICBP1(I) IS BUFF. POSITION OF START OF C ITH ARGUMENT C ITOPDO - PTR. TO 'TOP' (INNERMOST) DO LOOP ENTRY C IN ISTORE C IARGS - NUMBER OF ARGUMENTS IN A DIRECTIVE C ICBP2 - ICBP2(I) IS BUFF. POSITION OF END OF C ITH ARGUMENT C INESTD - DO LOOP NESTING DEPTH C INESTF - IF-ELSE-ENDIF NESTING DEPTH C COMMON / TPCOML / C LCOL1 - TRUE IF DIRECTIVES MUST BEGIN IN COL 1 C LDIRL - TRUE IF A DIRECTIVE HAS BEEN FOUND C LEND - TRUE IF AN END DIRECTIVE HAS BEEN FOUND C LINITM - TRUE IF MMINIT HAS BEEN CALLED C L1TRIP - TRUE IF ONE TRIP DO-LOOPS SHOULD BE ASSUMED C C C DATA STRUCTURES C --------------- C C I/O BUFFER C THE ARRAY CBUFFR HOLDS THE I/O BUFFER. INPUT LINES ARE READ C IN, MACRO SUBSTITUTIONS PERFORMED, AND LISTING AND OUTPUT C (WHEN APPROPRIATE) ARE DONE FROM THE I/O BUFFER. C C INTEGER STORAGE C THE ARRAY ISTORE IS USED TO HOLD THE POINTERS WHICH IMPLEMENT C THE SYMBOL TABLE AND THE SUBSTITUTION STACK. IT IS USED IN C BLOCKS OF 3 ELEMENTS AT A TIME. THE VARIABLE ISFREE POINTS C TO THE HEAD OF A LINKED LIST OF FREE ISTORE BLOCKS. INITIALLY C ALL BLOCKS ARE FREE (THE 3RD ELEMENT IN A BLOCK POINTS TO THE C NEXT FREE BLOCK). C C CHARACTER STORAGE C THE ARRAY CSTORE PROVIDES A POOL OF CHARACTER STORAGE. IT C IS USED TO RECORD MACRO NAMES AND VALUES, AS WELL AS STRINGS C WHICH MUST BE PUSHED ONTO THE SUBSTITUTION STACK. THE VARIABLE C IS2HDC POINTS TO THE HEAD OF A FREELIST OF CHARACTER STORAGE C BLOCKS. THIS FREELIST IS MADE UP OF ISTORE BLOCKS OF THE C FOLLOWING FORMAT: C ISTORE(I) = CSTORE INDEX OF FIRST CHAR. IN BLOCK C ISTORE(I+1)= CSTORE INDEX OF LAST CHAR. IN BLOCK C ISTORE(I+2)= POINTER TO NEXT BLOCK C C SYMBOL TABLE C THE SYMBOL TABLE KEEPS TRACK OF MACRO NAMES AND VALUES. IT C IS BUILT OUT OF ISTORE BLOCKS WHICH CONTAIN POINTERS TO C OTHER ISTORE BLOCKS OR INDEXES INTO CSTORE. GIVEN A MACRO C NAME, ROUTINE MMHASH COMPUTES ITS HASH INDEX IH. THEN C IHASH(IH) IS THE ISTORE INDEX OF THE SYMBOL TABLE ENTRY FOR C THAT NAME. IF IHASH(IH)=I SAY, THE ISTORE BLOCK AT I HOLDS C THE FOLLOWING: C ISTORE(I) = PTR. TO ISTORE BLOCK FOR VARIABLE NAME C ISTORE(I+1) = PTR. TO HEAD OF LINKED LIST OF ISTORE C BLOCKS FOR VALUE OF VARIABLE C ISTORE(I+2) = PTR. TO TAIL OF THE LINKED LIST FOR THE C VALUE C C AN ISTORE BLOCK FOR THE NAME OF A VARIABLE CONTAINS: C ISTORE(J) = CSTORE INDEX OF FIRST CHAR. IN NAME C ISTORE(J+1) = CSTORE INDEX OF LAST CHAR. IN NAME C ISTORE(J+2) = 0 C C AN ISTORE BLOCK IN THE LINKED LIST WHICH KEEPS TRACK OF C THE VALUE OF A VARIABLE LOOKS LIKE: C ISTORE(K) = CSTORE INDEX OF FIRST CHAR. ASSOCIATED C WITH THIS BLOCK C ISTORE(K+1) = CSTORE INDEX OF LAST CHAR. ASSOCIATED C WITH THIS BLOCK C ISTORE(K+2) = ISTORE INDEX OF NEXT BLOCK IN LIST C (0 IF LAST ONE) C C SUBSTITUTION STACK C WHEN A MACRO SUBSTITUTION IS FOUND, IT AND THE REST OF THE C CURRENT LINE ARE PUSHED ONTO THE SUBSTITUTION STACK. THE C MACRO NAME IS POPPED OFF AND REPLACED BY ITS VALUE. CHARACTERS C ARE THEN POPPED OFF THE STACK, INTO THE I/O BUFFER, UNTIL C THE STACK IS EMPTY OR ANOTHER SUBSTITUTION IS CALLED FOR. C IF ANOTHER MACRO SUBSTITUTION IS NEEDED THE SAME PROCESS IS C REPEATED--THE MACRO NAME IS REPLACED BY ITS VALUE, AND THE C STACK POPPING RESUMES. C C THE STACK IS IMPLEMENTED AS A LINKED LIST OF ISTORE BLOCKS. C THE VARIABLE IS2HDS POINTS TO THE TOP BLOCK ON THE STACK. C A BLOCK AT INDEX I CONTAINS: C ISTORE(I) = PTR. TO ISTORE BLOCK WHICH POINTS TO A C STRING ON THE STACK C ISTORE(I+1) = CSTORE INDEX OF 1ST CHAR. OF C CORRESPONDING STRING C ISTORE(I+2) = LINK TO NEXT ISTORE BLOCK ON STACK C (0 IF THERE IS NONE) C C THE FORMAT OF AN ISTORE BLOCK WHICH POINTS TO A STRING ON THE C STACK IS LIKE THAT OF ONE WHICH POINTS TO A VARIABLE NAME: C ISTORE(J) = CSTORE INDEX OF FIRST CHAR. IN STRING C ISTORE(J+1) = CSTORE INDEX OF LAST CHAR. IN STRING C ISTORE(J+2) = 0 C C C C----------------------------------------------------------------------- C C GLOBAL CONSTANTS C CHARACTER*1 CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 COMMON / GLCOMC / CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 C C INPUT / OUTPUT CONTROL INTERFACE C CHARACTER*1 CBUFFR(2000) LOGICAL LBREAK, LFORT, LISTI, LISTO INTEGER ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOMC / CBUFFR COMMON / IOCOMI / ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOML / LBREAK, LFORT, LISTI, LISTO C C MEMORY MANAGER INTERFACE C CHARACTER*1 CSTORE(20000) INTEGER IHASH(601), ISTORE(6000) INTEGER ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS COMMON / MMCOMC / CSTORE COMMON / MMCOMH / IHASH COMMON / MMCOMS / ISTORE COMMON / MMCOMI / ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS C C MACRO PROCESSOR INTERFACE C CHARACTER*1 CDIV, CEOL, CEOR, CONC, CSUB, A CTOP LOGICAL LEMPTY, LSUB COMMON / MPCOMC / CDIV, CEOL, CEOR, CONC, CSUB, A CTOP COMMON / MPCOML / LEMPTY, LSUB C C TEMPLATE PROCESSOR INTERFACE C CHARACTER*1 CDIR, CSTAR INTEGER ICBP1(4), ICBP2(4) INTEGER ITOPDO, IARGS, INESTD, INESTF LOGICAL LCOL1, LDIRL, LEND, LINITM, L1TRIP COMMON / TPCOMC / CDIR, CSTAR COMMON / TPCOMI / ICBP1, ITOPDO, IARGS, ICBP2, INESTD, B INESTF COMMON / TPCOML / LCOL1, LDIRL, LEND, LINITM, L1TRIP INTEGER IUE0, IUI0, IUL0, IUO0 EXTERNAL TPINIT, MPLINE, TPEVAL, IOWRIT C CALL TPINIT (IUE0, IUI0, IUL0, IUO0) C 10 CONTINUE ICBEOL = 0 CALL MPLINE (.TRUE.) CALL TPEVAL IF (.NOT. LDIRL) CALL IOWRIT IF (.NOT. LEND) GO TO 10 C RETURN END SUBROUTINE IOERRM (LFATAL, CFMT) C C---------------------------------------------------------------------- C C FAMILY C ------ C INPUT/OUTPUT C C PURPOSE C ------- C TO PRINT OUT THE OFFENDING LINE AND AN ERROR MESSAGE BENEATH IT. C IF THE ERROR IS FATAL, PROCESSOR EXECUTION IS TERMINATED. C C PARAMETERS C ---------- C LFATAL -I- TRUE FOR FATAL ERRORS C CFMT -I- FORMAT FOR ERROR MESSAGE C C---------------------------------------------------------------------- C C INPUT / OUTPUT CONTROL INTERFACE C CHARACTER*1 CBUFFR(2000) LOGICAL LBREAK, LFORT, LISTI, LISTO INTEGER ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOMC / CBUFFR COMMON / IOCOMI / ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOML / LBREAK, LFORT, LISTI, LISTO C C LOCAL VARIABLES AND PARAMETERS C CHARACTER*(*) CFMT LOGICAL LFATAL INTEGER I EXTERNAL IOPAGE C IF (IUNITE .EQ. IUNITL) CALL IOPAGE (2) IF (ICB0 .GT. ICB2) GO TO 10 WRITE (IUNITE, 1010) (CBUFFR(I), I=ICB0,ICB2) 1010 FORMAT(' ******** ', 117A1) 10 CONTINUE WRITE (IUNITE, CFMT) IF (LFATAL) STOP 1 C RETURN END SUBROUTINE IOLIST (LNUMBR) C C---------------------------------------------------------------------- C C INPUT/OUTPUT C C PURPOSE C ------- C TO LIST THE LINE CURRENTLY IN THE INPUT/OUTPUT BUFFER. C C PARAMETER C --------- C LNUMBR -I- TRUE IF THE LINE SHOULD BE NUMBERED C C---------------------------------------------------------------------- C C INPUT / OUTPUT CONTROL INTERFACE C CHARACTER*1 CBUFFR(2000) LOGICAL LBREAK, LFORT, LISTI, LISTO INTEGER ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOMC / CBUFFR COMMON / IOCOMI / ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOML / LBREAK, LFORT, LISTI, LISTO C C LOCAL VARIABLES AND PARAMETERS C LOGICAL LNUMBR INTEGER I EXTERNAL IOPAGE C CALL IOPAGE (1) IF (.NOT. LNUMBR) GO TO 20 ILNMBR = ILNMBR + 1 C IF (ICB1 .LE. ICB2) GO TO 10 WRITE (IUNITL, 1010) ILNMBR GO TO 999 C 10 CONTINUE WRITE (IUNITL, 1020) ILNMBR, (CBUFFR(I), I=ICB1,ICB2) GO TO 999 C 20 CONTINUE IF (ICB1 .LE. ICB2) GO TO 30 WRITE (IUNITL, 1030) GO TO 999 C 30 CONTINUE WRITE (IUNITL, 1040) (CBUFFR(I), I=ICB1,ICB2) C 999 CONTINUE RETURN 1010 FORMAT(' ', I8) 1020 FORMAT(' ', I8, 3X, 117A1) 1030 FORMAT(' ') 1040 FORMAT(' ', 11X, 117A1) END SUBROUTINE IOPAGE (IL) C C---------------------------------------------------------------------- C C FAMILY C ------ C INPUT/OUTPUT C C PURPOSE C ------- C TO DETERMINE IF THERE IS ROOM TO PRINT THE SPECIFIED NUMBER C OF LINES ON THE CURRENT PAGE. IF THERE IS NOT, A NEW PAGE C IS BEGUN AND A HEADING IS PRINTED. C C PARAMETERS C ---------- C IL -I- NUMBER OF LINES TO BE PRINTED C C---------------------------------------------------------------------- INTEGER IL C C INPUT / OUTPUT CONTROL INTERFACE C CHARACTER*1 CBUFFR(2000) LOGICAL LBREAK, LFORT, LISTI, LISTO INTEGER ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOMC / CBUFFR COMMON / IOCOMI / ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOML / LBREAK, LFORT, LISTI, LISTO C ILCTR = ILCTR + IL IF (ILCTR .LE. ILPP) GO TO 999 IPAGE = IPAGE + 1 ILCTR = 3 + IL WRITE (IUNITL,1010) IPAGE C 999 CONTINUE RETURN 1010 FORMAT('1', 'PURDUE UNIVERSITY TEMPLATE PROCESSOR ', A '(V2 - 07/31/83) PAGE', I6 //) END SUBROUTINE IORDLN (CLINE, ICL1, ICL2, IUNIT) C C---------------------------------------------------------------------- C C FAMILY C ------ C INPUT/OUTPUT C C PURPOSE C ------- C TO READ A LINE INTO THE INPUT/OUTPUT BUFFER. THIS C MAY BE REPLACED BY A MORE EFFICIENT LOCAL I/O ROUTINE C C PARAMETERS C ---------- C CLINE -I- I/O BUFFER C ICL1 -I- INDEX OF THE FIRST CHARACTER TO BE READ C ICL2 -I- INDEX OF THE LAST CHARACTER TO BE READ C IUNIT -I- INPUT UNIT NUMBER C C---------------------------------------------------------------------- C INTEGER ICL1, ICL2, IUNIT CHARACTER*(*) CLINE(ICL2) INTEGER I, IBOT C C ACCESS CDIR DIRECTIVE PREFIX C C C TEMPLATE PROCESSOR INTERFACE C CHARACTER*1 CDIR, CSTAR INTEGER ICBP1(4), ICBP2(4) INTEGER ITOPDO, IARGS, INESTD, INESTF LOGICAL LCOL1, LDIRL, LEND, LINITM, L1TRIP COMMON / TPCOMC / CDIR, CSTAR COMMON / TPCOMI / ICBP1, ITOPDO, IARGS, ICBP2, INESTD, B INESTF COMMON / TPCOML / LCOL1, LDIRL, LEND, LINITM, L1TRIP C CHARACTER*1 STREND(5) SAVE STREND DATA STREND(1)/'*'/,STREND(2)/'E'/,STREND(3)/'N'/ DATA STREND(4)/'D'/,STREND(5)/' '/ C READ (IUNIT, 1010, END=999) (CLINE(I), I=ICL1,ICL2) RETURN 999 CONTINUE STREND(1) = CDIR DO 10 I=1,4 CLINE(ICL1+I-1)=STREND(I) 10 CONTINUE IBOT=ICL1+4 DO 20 I=IBOT,ICL2 CLINE(I)=STREND(5) 20 CONTINUE 1010 FORMAT(132A1) END SUBROUTINE IOREAD C C---------------------------------------------------------------------- C C FAMILY C ------ C SUBSTITUTION PROCESSING C C PURPOSE C ------- C TO FILL THE BUFFER WITH A LINE, REMOVE THE TRAILING BLANKS, C SET THE BUFFER POINTERS, AND APPEND AN END-OF-LINE MARKER. C C---------------------------------------------------------------------- C C GLOBAL CONSTANTS C CHARACTER*1 CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 COMMON / GLCOMC / CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 C C INPUT / OUTPUT CONTROL INTERFACE C CHARACTER*1 CBUFFR(2000) LOGICAL LBREAK, LFORT, LISTI, LISTO INTEGER ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOMC / CBUFFR COMMON / IOCOMI / ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOML / LBREAK, LFORT, LISTI, LISTO C C MEMORY MANAGER INTERFACE C CHARACTER*1 CSTORE(20000) INTEGER IHASH(601), ISTORE(6000) INTEGER ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS COMMON / MMCOMC / CSTORE COMMON / MMCOMH / IHASH COMMON / MMCOMS / ISTORE COMMON / MMCOMI / ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS C C MACRO PROCESSOR INTERFACE C CHARACTER*1 CDIV, CEOL, CEOR, CONC, CSUB, A CTOP LOGICAL LEMPTY, LSUB COMMON / MPCOMC / CDIV, CEOL, CEOR, CONC, CSUB, A CTOP COMMON / MPCOML / LEMPTY, LSUB EXTERNAL IORDLN, IOLIST, IOERRM C C IF THERE IS ENOUGH SPACE IN THE BUFFER C READ A LINE FROM THE INPUT FILE C ICB1 = ICB2 + 1 ICB2 = ICB2 + ICPLI IF (ICB2+2 .GT. ICBDIM) GO TO 30 CALL IORDLN (CBUFFR, ICB1, ICB2, IUNITI) IF (LISTI) CALL IOLIST (.TRUE.) C C REMOVE TRAILING BLANKS C 10 CONTINUE IF (CBUFFR(ICB2) .NE. CBLANK) GO TO 20 ICB2 = ICB2 - 1 IF (ICB2 .GE. ICB1) GO TO 10 C C ADD THE END-OF-LINE MARKER C 20 CONTINUE CBUFFR(ICB2+1) = CSUB CBUFFR(ICB2+2) = CEOL ICB3 = ICB2 ICBEOL = ICB2 + 2 ICBEND = ICBEOL GO TO 999 C 30 CONTINUE CALL IOERRM (.TRUE., A '('' ******** IOREAD - BUFFER SPACE EXCEEDED'')') C 999 CONTINUE RETURN END SUBROUTINE IOWRIT C C---------------------------------------------------------------------- C C FAMILY C ------ C SUBSTITUTION PROCESSING C C PURPOSE C ------- C TO WRITE THE LINE CURRENTLY IN THE BUFFER TO THE OUTPUT FILE. C IF THE -BREAK- OPTION IS SPECIFIED, AN ATTEMPT WILL BE MADE TO C BREAK LONG LINES AT A BLANK, RIGHT PARENTHESIS, COMMA, OR AN C ARITHMETIC OPERATOR. IF THE -FORTRAN- OPTION IS SPECIFIED, C CONTINUATION LINES WILL BE WRITTEN WITH CONTINUATION CHARACTERS C IN COLUMN SIX UNLESS THE LINE IS A COMMENT. C C---------------------------------------------------------------------- C C GLOBAL CONSTANTS C CHARACTER*1 CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 COMMON / GLCOMC / CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 C C INPUT / OUTPUT CONTROL INTERFACE C CHARACTER*1 CBUFFR(2000) LOGICAL LBREAK, LFORT, LISTI, LISTO INTEGER ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOMC / CBUFFR COMMON / IOCOMI / ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOML / LBREAK, LFORT, LISTI, LISTO C C MEMORY MANAGER INTERFACE C CHARACTER*1 CSTORE(20000) INTEGER IHASH(601), ISTORE(6000) INTEGER ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS COMMON / MMCOMC / CSTORE COMMON / MMCOMH / IHASH COMMON / MMCOMS / ISTORE COMMON / MMCOMI / ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS C C MACRO PROCESSOR INTERFACE C CHARACTER*1 CDIV, CEOL, CEOR, CONC, CSUB, A CTOP LOGICAL LEMPTY, LSUB COMMON / MPCOMC / CDIV, CEOL, CEOR, CONC, CSUB, A CTOP COMMON / MPCOML / LEMPTY, LSUB C C LOCAL VARIABLES AND PARAMETERS C CHARACTER*1 C(7), CBI, COL1 INTEGER ICDIM, I, IC, ICB SAVE ICDIM, C EXTERNAL IOWRLN, IOLIST DATA ICDIM / 7 / DATA A C(1), C(2), C(3), C(4), C(5), C(6), C(7) B / ' ', ')', ',', '/', '*', '-', '+' / C ICB1 = ICB0 COL1 = CBUFFR(ICB1) IF (ICB1 .LE. ICB3) GO TO 10 CBUFFR(ICB1) = CBLANK ICB2 = ICB1 GO TO 60 C 10 CONTINUE ICB2 = MIN0(ICB1+ICPLO-1,ICB3) IF (ICB2 .EQ. ICB3) GO TO 60 IF (.NOT. LBREAK) GO TO 40 C C FIND A PLACE TO BREAK THE LINE. C DO 30 I=1,10 CBI = CBUFFR(ICB2) DO 20 IC=1,ICDIM IF (C(IC) .EQ. CBI) GO TO 30 20 CONTINUE ICB2 = ICB2 - 1 30 CONTINUE C C WRITE THE LINE C 40 CONTINUE CALL IOWRLN (CBUFFR, ICB1, ICB2, IUNITO) IF (LISTO) CALL IOLIST (.NOT.LISTI) ICB1 = ICB2 + ICBADD IF (.NOT. LFORT) GO TO 10 C C PAD THE BEGINNING OF THE THE LINE C WITH THE STRING BBBBBZBBBB (B=BLANK) C DO 50 ICB=ICB1,ICB2 CBUFFR(ICB) = CBLANK 50 CONTINUE IF (COL1 .EQ. CC) CBUFFR(ICB1) = CC IF (COL1 .NE. CC) CBUFFR(ICB1+5) = CZ GO TO 10 C 60 CONTINUE CALL IOWRLN (CBUFFR, ICB1, ICB2, IUNITO) IF (LISTO) CALL IOLIST (.NOT.LISTI) C RETURN END SUBROUTINE IOWRLN (CLINE, ICL1, ICL2, IUNIT) C C---------------------------------------------------------------------- C C FAMILY C ------ C INPUT/OUTPUT C C PURPOSE C ------- C TO WRITE A LINE FROM THE INPUT/OUTPUT BUFFER. THIS C MAY BE REPLACED BY A MORE EFFICIENT LOCAL I/O ROUTINE C C PARAMETERS C ---------- C CLINE -I- I/O BUFFER C ICL1 -I- INDEX OF THE FIRST CHARACTER TO BE WRITTEN C ICL2 -I- INDEX OF THE LAST CHARACTER TO BE WRITTEN C IUNIT -I- OUTPUT UNIT NUMBER C C---------------------------------------------------------------------- INTEGER ICL1, ICL2, IUNIT CHARACTER*(*) CLINE(ICL2) INTEGER I C WRITE (IUNIT, 1010) (CLINE(I), I=ICL1,ICL2) C RETURN 1010 FORMAT(132A1) END SUBROUTINE MMAPPV (CNAME, ICN1, ICN2, CVALUE, ICV1, ICV2) C C---------------------------------------------------------------------- C C FAMILY C ------ C MEMORY MANAGER C C PURPOSE C ------- C TO APPEND A STRING TO A VARIABLE C C PARAMETERS C ---------- C CNAME -I- ARRAY CONTAINING THE NAME OF THE VARIABLE C ICN1 -I- INDEX OF THE FIRST CHARACTER IN THE NAME C ICN2 -I- INDEX OF THE LAST CHARACTER IN THE NAME C CVALUE -I- ARRAY CONTAINING THE STRING TO BE APPENDED C ICV1 -I- INDEX OF THE FIRST CHARACTER IN THE STRING C ICV2 -I- INDEX OF THE LAST CHARACTER IN THE STRING C C---------------------------------------------------------------------- C C GLOBAL CONSTANTS C CHARACTER*1 CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 COMMON / GLCOMC / CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 C C INPUT / OUTPUT CONTROL INTERFACE C CHARACTER*1 CBUFFR(2000) LOGICAL LBREAK, LFORT, LISTI, LISTO INTEGER ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOMC / CBUFFR COMMON / IOCOMI / ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOML / LBREAK, LFORT, LISTI, LISTO C C MEMORY MANAGER INTERFACE C CHARACTER*1 CSTORE(20000) INTEGER IHASH(601), ISTORE(6000) INTEGER ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS COMMON / MMCOMC / CSTORE COMMON / MMCOMH / IHASH COMMON / MMCOMS / ISTORE COMMON / MMCOMI / ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS C C LOCAL VARIABLES AND PARAMETERS C INTEGER ICN1, ICN2, ICV1, ICV2 CHARACTER*(*) CNAME(ICN2), CVALUE(ICV2) LOGICAL LFOUND INTEGER IH, IS1, I, IS2 EXTERNAL MMHASH, MMNEWI, MMPUT1 C C HASH THE VARIABLE NAME TO SEE IF IT EXISTS. C IF IT DOES NOT, CREATE IT AND RETURN. C CALL MMHASH (CNAME, ICN1, ICN2, IH, LFOUND) IF (LFOUND) GO TO 10 CALL MMNEWI (IS1) IHASH(IH) = IS1 CALL MMPUT1 (CNAME, ICN1, ICN2, ISTORE(IS1), I) CALL MMPUT1 (CVALUE, ICV1, ICV2, ISTORE(IS1+1), A ISTORE(IS1+2)) GO TO 999 C C THE VARIABLE ALREADY EXISTS. APPEND THE VALUE. C 10 CONTINUE IS1 = IHASH(IH) IS2 = ISTORE(IS1+2) CALL MMPUT1 (CVALUE, ICV1, ICV2, ISTORE(IS2+2), ISTORE(IS1+2)) C 999 CONTINUE RETURN END SUBROUTINE MMDELV (CNAME, ICN1, ICN2, LFOUND) C C---------------------------------------------------------------------- C C FAMILY C ------ C MEMORY MANAGER C C PURPOSE C ------- C TO DELETE A VARIABLE C C PARAMETERS C ---------- C CNAME -I- ARRAY CONTAINING THE NAME OF THE VARIABLE C ICN1 -I- INDEX OF THE FIRST CHARACTER IN THE NAME C ICN2 -I- INDEX OF THE LAST CHARACTER IN THE NAME C LFOUND -O- TRUE IF THE VARIABLE EXISTED C C---------------------------------------------------------------------- C C GLOBAL CONSTANTS C CHARACTER*1 CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 COMMON / GLCOMC / CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 C C INPUT / OUTPUT CONTROL INTERFACE C CHARACTER*1 CBUFFR(2000) LOGICAL LBREAK, LFORT, LISTI, LISTO INTEGER ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOMC / CBUFFR COMMON / IOCOMI / ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOML / LBREAK, LFORT, LISTI, LISTO C C MEMORY MANAGER INTERFACE C CHARACTER*1 CSTORE(20000) INTEGER IHASH(601), ISTORE(6000) INTEGER ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS COMMON / MMCOMC / CSTORE COMMON / MMCOMH / IHASH COMMON / MMCOMS / ISTORE COMMON / MMCOMI / ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS C C LOCAL VARIABLES AND PARAMETERS C INTEGER ICN1, ICN2 CHARACTER*(*) CNAME(ICN2) LOGICAL LFOUND INTEGER IH, IS1 EXTERNAL MMHASH, MMDEL1, MMRETI C C IF THE VARIABLE EXISTS, DELETE IT BY RETURNING THE SPACE C TAKEN UP BY IT-S NAME AND VALUE, RETURNING THE SPACE POINTER, C AND ZEROING OUT THE HASH TABLE ENTRY. C CALL MMHASH (CNAME, ICN1, ICN2, IH, LFOUND) IF (.NOT. LFOUND) GO TO 999 IS1 = IHASH(IH) CALL MMDEL1 (ISTORE(IS1)) CALL MMDEL1 (ISTORE(IS1+1)) CALL MMRETI (IS1) IHASH(IH) = 0 C 999 CONTINUE RETURN END SUBROUTINE MMDEL1 (IS2) C C---------------------------------------------------------------------- C C FAMILY C ------ C MEMORY MANAGER C C PURPOSE C ------- C TO RETURN BLOCKS OF CHARACTER STORAGE TO THE FREE SPACE POOL C C PARAMETERS C ---------- C IS2 -I- POINTER TO THE FIRST LINK IN A LIST C OF CHARACTER STORAGE BLOCKS C C---------------------------------------------------------------------- INTEGER IS2 C C GLOBAL CONSTANTS C CHARACTER*1 CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 COMMON / GLCOMC / CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 C C INPUT / OUTPUT CONTROL INTERFACE C CHARACTER*1 CBUFFR(2000) LOGICAL LBREAK, LFORT, LISTI, LISTO INTEGER ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOMC / CBUFFR COMMON / IOCOMI / ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOML / LBREAK, LFORT, LISTI, LISTO C C MEMORY MANAGER INTERFACE C CHARACTER*1 CSTORE(20000) INTEGER IHASH(601), ISTORE(6000) INTEGER ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS COMMON / MMCOMC / CSTORE COMMON / MMCOMH / IHASH COMMON / MMCOMS / ISTORE COMMON / MMCOMI / ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS INTEGER IS C IS = IS2 IF (IS .EQ. 0) GO TO 999 C C LOOP THROUGH EVERY LINK TO FIND THE TAIL C 10 CONTINUE IF (ISTORE(IS+2) .EQ. 0) GO TO 20 IS = ISTORE(IS+2) GO TO 10 C C ATTACH THE LIST TO THE FREE SPACE POOL AND C RESET THE FREE SPACE HEAD POINTER C 20 CONTINUE ISTORE(IS+2) = IS2HDC IS2HDC = IS2 C C 999 CONTINUE RETURN END SUBROUTINE MMGETV (CNAME, ICN1, ICN2, A CVALUE, ICV1, ICV2, ICVDIM, LFOUND) C C---------------------------------------------------------------------- C C FAMILY C ------ C MEMORY MANAGER C C PURPOSE C ------- C TO GET THE VALUE OF THE NAMED VARIABLE FROM THE STORAGE C POOL AND COPY IT INTO THE SPECIFIED ARRAY. C C PARAMETERS C ---------- C CNAME -I- ARRAY CONTAINING THE NAME OF THE VARIABLE C ICN1 -I- INDEX OF THE FIRST CHARACTER IN THE NAME C ICN2 -I- INDEX OF THE LAST CHARACTER IN THE NAME C CVALUE -O- ARRAY TO CONTAIN THE VALUE OF THE VARIABLE C ICV1 -O- INDEX OF THE FIRST CHARACTER IN THE VALUE C ICV2 -O- INDEX OF THE LAST CHARACTER IN THE VALUE C ICVDIM -I- LENGTH OF ARRAY CVALUE C LFOUND -O- TRUE IF THE VARIABLE EXISTS C C---------------------------------------------------------------------- C C GLOBAL CONSTANTS C CHARACTER*1 CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 COMMON / GLCOMC / CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 C C INPUT / OUTPUT CONTROL INTERFACE C CHARACTER*1 CBUFFR(2000) LOGICAL LBREAK, LFORT, LISTI, LISTO INTEGER ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOMC / CBUFFR COMMON / IOCOMI / ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOML / LBREAK, LFORT, LISTI, LISTO C C MEMORY MANAGER INTERFACE C CHARACTER*1 CSTORE(20000) INTEGER IHASH(601), ISTORE(6000) INTEGER ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS COMMON / MMCOMC / CSTORE COMMON / MMCOMH / IHASH COMMON / MMCOMS / ISTORE COMMON / MMCOMI / ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS C C LOCAL VARIABLES AND PARAMETERS C INTEGER ICN1, ICN2, ICV1, ICV2, ICVDIM CHARACTER*(*) CNAME(ICN2), CVALUE(ICVDIM) LOGICAL LFOUND INTEGER IH, IS1, IS2H EXTERNAL MMHASH, MMGET1 C C IF THE VARIABLE EXISTS, COPY ITS VALUE C ICV2 = 0 CALL MMHASH (CNAME, ICN1, ICN2, IH, LFOUND) IF (.NOT. LFOUND) GO TO 999 IS1 = IHASH(IH) IS2H = ISTORE(IS1+1) CALL MMGET1 (CVALUE, ICV1, ICV2, ICVDIM, IS2H) C 999 CONTINUE RETURN END SUBROUTINE MMGET1 (CVALUE, ICV1, ICV2, ICVDIM, IS2H) C C---------------------------------------------------------------------- C C FAMILY C ------ C MEMORY MANAGER C C PURPOSE C ------- C TO COPY THE STRING SPECIFIED BY THE POINTER IS2H C AND COPY IT INTO A SPECIFIED ARRAY. C C PARAMETERS C ---------- C CVALUE -O- ARRAY TO CONTAIN THE VALUE OF THE VARIABLE C ICV1 -O- INDEX OF THE FIRST CHARACTER IN THE VALUE C ICV2 -O- INDEX OF THE LAST CHARACTER IN THE VALUE C ICVDIM -I- LENGTH OF ARRAY CVALUE C IS2H -I- HEAD POINTER TO THE LINKED LIST OF C BLOCKS CONTAINING THE STRING VALUE C C---------------------------------------------------------------------- C C GLOBAL CONSTANTS C CHARACTER*1 CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 COMMON / GLCOMC / CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 C C INPUT / OUTPUT CONTROL INTERFACE C CHARACTER*1 CBUFFR(2000) LOGICAL LBREAK, LFORT, LISTI, LISTO INTEGER ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOMC / CBUFFR COMMON / IOCOMI / ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOML / LBREAK, LFORT, LISTI, LISTO C C MEMORY MANAGER INTERFACE C CHARACTER*1 CSTORE(20000) INTEGER IHASH(601), ISTORE(6000) INTEGER ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS COMMON / MMCOMC / CSTORE COMMON / MMCOMH / IHASH COMMON / MMCOMS / ISTORE COMMON / MMCOMI / ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS C C LOCAL VARIABLES AND PARAMETERS C INTEGER ICV1, ICV2, ICVDIM, IS2H CHARACTER*(*) CVALUE(ICVDIM) INTEGER ICS1, ICS2, ICS, IS2 EXTERNAL IOERRM C IS2 = IS2H ICV2 = ICV1 - 1 C C LOOP THROUGH EACH BLOCK IN WHICH THE STRING IS STORED C 10 CONTINUE IF (IS2 .EQ. 0) GO TO 999 ICS1 = ISTORE(IS2) ICS2 = ISTORE(IS2+1) IS2 = ISTORE(IS2+2) IF (ICV2+ICS2-ICS1 .GE. ICVDIM) GO TO 30 C C LOOP OVER EACH CHARACTER IN THIS BLOCK C DO 20 ICS=ICS1,ICS2 ICV2 = ICV2 + 1 CVALUE(ICV2) = CSTORE(ICS) 20 CONTINUE GO TO 10 C 30 CONTINUE CALL IOERRM (.TRUE., A '('' ******** MMGET1 - STRING TOO LONG FOR CVALUE(*)'')') C 999 CONTINUE RETURN END SUBROUTINE MMHASH (CNAME, ICN1, ICN2, IH, LFOUND) C C---------------------------------------------------------------------- C C FAMILY C ------ C MEMORY MANAGER C C PURPOSE C ------- C TO HASH A NAME AND RETURN IT-S HASH TABLE INDEX C C PARAMETERS C ---------- C CNAME -I- ARRAY CONTAINING THE NAME OF THE VARIABLE C ICN1 -I- INDEX OF THE FIRST CHARACTER IN THE NAME C ICN2 -I- INDEX OF THE LAST CHARACTER IN THE NAME C IH -O- HASH INDEX INTO ARRAY IHASH C LFOUND -O- TRUE IF THE VARIABLE IS ALREADY IN THE TABLE C C---------------------------------------------------------------------- C C GLOBAL CONSTANTS C CHARACTER*1 CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 COMMON / GLCOMC / CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 C C INPUT / OUTPUT CONTROL INTERFACE C CHARACTER*1 CBUFFR(2000) LOGICAL LBREAK, LFORT, LISTI, LISTO INTEGER ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOMC / CBUFFR COMMON / IOCOMI / ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOML / LBREAK, LFORT, LISTI, LISTO C C MEMORY MANAGER INTERFACE C CHARACTER*1 CSTORE(20000) INTEGER IHASH(601), ISTORE(6000) INTEGER ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS COMMON / MMCOMC / CSTORE COMMON / MMCOMH / IHASH COMMON / MMCOMS / ISTORE COMMON / MMCOMI / ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS C C LOCAL VARIABLES AND PARAMETERS C INTEGER ICN1, ICN2, IH CHARACTER*(*) CNAME(ICN2) LOGICAL LERROR, LFOUND INTEGER INAME, IADD, I, IS1 EXTERNAL UTCVNI, MMTEST, IOERRM C C ENCODE THE NAME INTO AN INTEGER C CALL UTCVNI (CNAME, ICN1, ICN2, INAME, LERROR) INAME = MOD(INAME, IHADIM) IADD = MAX0(1, INAME) LFOUND = .FALSE. C C LOOP THROUGH ENTRIES IN THE TABLE UNTIL THE C NAME IS FOUND OR AN EMPTY BUCKET IS REACHED C DO 10 I=1,IHADIM IH = INAME + 1 IS1 = IHASH(IH) IF (IS1 .EQ. 0) GO TO 999 CALL MMTEST (CNAME, ICN1, ICN2, ISTORE(IS1), LFOUND) IF (LFOUND) GO TO 999 INAME = MOD(INAME+IADD, IHADIM) 10 CONTINUE C C EXIT FROM THE ABOVE LOOP INDICATES THAT THE HASH C TABLE IS FULL. TO OBTAIN MORE SPACE THE PROCESSOR C MUST BE RECOMPILED WITH A LARGER DIMENSION -IHADIM- C FOR ARRAY IHASH. IHADIM SHOULD BE A PRIME NUMBER. C CALL IOERRM (.TRUE., A '('' ******** MMHASH - HASH TABLE ARRAY IHASH(*) IS FULL'')') C 999 CONTINUE RETURN END SUBROUTINE MMINIT C C----------------------------------------------------------------------- C C FAMILY C ------ C MEMORY MANAGER C C PURPOSE C ------- C TO INITIALIZE MEMORY MANAGER VARIABLES C C----------------------------------------------------------------------- C C GLOBAL CONSTANTS C CHARACTER*1 CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 COMMON / GLCOMC / CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 C C INPUT / OUTPUT CONTROL INTERFACE C CHARACTER*1 CBUFFR(2000) LOGICAL LBREAK, LFORT, LISTI, LISTO INTEGER ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOMC / CBUFFR COMMON / IOCOMI / ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOML / LBREAK, LFORT, LISTI, LISTO C C MEMORY MANAGER INTERFACE C CHARACTER*1 CSTORE(20000) INTEGER IHASH(601), ISTORE(6000) INTEGER ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS COMMON / MMCOMC / CSTORE COMMON / MMCOMH / IHASH COMMON / MMCOMS / ISTORE COMMON / MMCOMI / ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS INTEGER I EXTERNAL MMNEWI C DO 10 I=1,IHADIM IHASH(I) = 0 10 CONTINUE C DO 20 I=1,ISTDIM,3 ISTORE(I) = 0 ISTORE(I+1) = 0 ISTORE(I+2) = I + 3 20 CONTINUE C ISTORE(ISTDIM) = 0 ISFREE = 1 C CALL MMNEWI (IS2HDC) ISTORE(IS2HDC) = 1 ISTORE(IS2HDC+1) = ICSDIM ISTORE(IS2HDC+2) = 0 IS2HDS = 0 ICSP1 = 1 ICSP2 = 0 C RETURN END SUBROUTINE MMNEWI (IS) C C----------------------------------------------------------------------- C C FAMILY C ------ C MEMORY MANAGER C C PURPOSE C ------- C TO RETURN A POINTER TO AN AVAILABLE BLOCK FROM THE INTEGER C STORAGE POOL C C PARAMETERS C ---------- C IS -O- INDEX INTO ARRAY ISTORE OF THE FREE BLOCK C C----------------------------------------------------------------------- C C GLOBAL CONSTANTS C CHARACTER*1 CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 COMMON / GLCOMC / CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 C C INPUT / OUTPUT CONTROL INTERFACE C CHARACTER*1 CBUFFR(2000) LOGICAL LBREAK, LFORT, LISTI, LISTO INTEGER ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOMC / CBUFFR COMMON / IOCOMI / ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOML / LBREAK, LFORT, LISTI, LISTO C C MEMORY MANAGER INTERFACE C CHARACTER*1 CSTORE(20000) INTEGER IHASH(601), ISTORE(6000) INTEGER ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS COMMON / MMCOMC / CSTORE COMMON / MMCOMH / IHASH COMMON / MMCOMS / ISTORE COMMON / MMCOMI / ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS INTEGER IS EXTERNAL IOERRM C IF (ISFREE .EQ. 0) GO TO 10 IS = ISFREE ISFREE = ISTORE(ISFREE+2) GO TO 999 C 10 CONTINUE CALL IOERRM (.TRUE., A '('' ******** MMNEWI - STORAGE ARRAY ISTORE(*) IS FULL'')') C 999 CONTINUE RETURN END SUBROUTINE MMPOPC (CTEST, IPOP, CTOP, LEMPTY) C C----------------------------------------------------------------------- C C FAMILY C ------ C MEMORY MANAGER C C PURPOSE C ------- C TO POP CHARACTERS OFF THE SUBSTITUTION STACK C C PARAMETERS C ---------- C CTEST -I- CHARACTER WHOSE PURPOSE DEPENDS ON IPOP C IPOP -I- INDICATES THE OPERATION TO BE PERFORMED C 1 - LOOK AT THE TOP CHARACTER C 2 - POP ONE CHARACTER OFF THE STACK C 3 - POP ONE VARIABLE OFF THE STACK C 4 - POP UNTIL TOP .NE. CTEST C 5 - POP UNTIL TOP .EQ. CTEST C 6 - POP ALL ALPHNUMERICS C CTOP -O- TOP CHARACTER ON STACK C LEMPTY -I- TRUE IF STACK IS EMPTY C C----------------------------------------------------------------------- C C GLOBAL CONSTANTS C CHARACTER*1 CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 COMMON / GLCOMC / CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 C C INPUT / OUTPUT CONTROL INTERFACE C CHARACTER*1 CBUFFR(2000) LOGICAL LBREAK, LFORT, LISTI, LISTO INTEGER ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOMC / CBUFFR COMMON / IOCOMI / ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOML / LBREAK, LFORT, LISTI, LISTO C C MEMORY MANAGER INTERFACE C CHARACTER*1 CSTORE(20000) INTEGER IHASH(601), ISTORE(6000) INTEGER ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS COMMON / MMCOMC / CSTORE COMMON / MMCOMH / IHASH COMMON / MMCOMS / ISTORE COMMON / MMCOMI / ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS C C LOCAL VARIABLES AND PARAMETERS C INTEGER IPOP CHARACTER*(*) CTEST, CTOP INTEGER ICS LOGICAL LEMPTY EXTERNAL MMPOP1, MMPOPV, IOERRM C 10 CONTINUE CTOP = CBLANK C C CHECK FOR NULL ENTRIES ON STACK C IF (ICSP1 .GT. ICSP2) CALL MMPOP1 (LEMPTY) IF (LEMPTY) GO TO 999 GO TO (20, 30, 40, 50, 70, 90), IPOP C C IPOP = 1 - LOOK AT THE TOP OF THE STACK C 20 CONTINUE CTOP = CSTORE(ICSP1) GO TO 999 C C IPOP = 2 - POP ONE CHARACTER OFF THE STACK C 30 CONTINUE ICB2 = ICB2 + 1 IF (ICB2 .GT. ICBDIM) GO TO 130 CBUFFR(ICB2) = CSTORE(ICSP1) ICSP1 = ICSP1 + 1 ISTORE(IS2HDS+1) = ICSP1 IF (ICSP1 .GT. ICSP2) CALL MMPOP1 (LEMPTY) IF (.NOT. LEMPTY) CTOP = CSTORE(ICSP1) GO TO 999 C C IPOP = 3 - POP ONE VARIABLE OFF THE STACK C 40 CONTINUE ICB2 = ICB2 + 1 IF (ICB2 .GT. ICBDIM) GO TO 130 CBUFFR(ICB2) = CSTORE(ICSP1) ISTORE(IS2HDS+1) = ICSP1 + 1 CALL MMPOPV (LEMPTY) CALL MMPOP1 (LEMPTY) IF (.NOT. LEMPTY) CTOP = CSTORE(ICSP1) GO TO 999 C C IPOP = 4 - POP UNTIL TOP CHAR .NE. CTEST C 50 CONTINUE IF (ICSP2-ICSP1 .GE. ICBDIM-ICB2) GO TO 130 DO 60 ICS=ICSP1,ICSP2 IF (CSTORE(ICS) .NE. CTEST) GO TO 120 ICB2 = ICB2 + 1 CBUFFR(ICB2) = CSTORE(ICS) 60 CONTINUE GO TO 110 C C IPOP = 5 - POP UNTIL TOP CHAR .EQ. CTEST C 70 CONTINUE IF (ICSP2-ICSP1 .GE. ICBDIM-ICB2) GO TO 130 DO 80 ICS=ICSP1,ICSP2 IF (CSTORE(ICS) .EQ. CTEST) GO TO 120 ICB2 = ICB2 + 1 CBUFFR(ICB2) = CSTORE(ICS) 80 CONTINUE GO TO 110 C C IPOP = 6 - POP ALL ALPHANUMERICS OFF THE STACK C 90 CONTINUE IF (ICSP2-ICSP1 .GE. ICBDIM-ICB2) GO TO 130 DO 100 ICS=ICSP1,ICSP2 IF (.NOT. ((LLE(CA,CSTORE(ICS)) A .AND. LLE(CSTORE(ICS),CZ)) B .OR. (LLE(C0,CSTORE(ICS)) C .AND. LLE(CSTORE(ICS),C9)))) GO TO 120 ICB2 = ICB2 + 1 CBUFFR(ICB2) = CSTORE(ICS) 100 CONTINUE C C THE SPECIFIED CONDITION HAS NOT BEEN MET. C GET ANOTHER PIECE OF THE STACK AND TRY AGAIN. C 110 CONTINUE ICSP1 = ICSP2 + 1 ISTORE(IS2HDS+1) = ICSP1 GO TO 10 C C THE SPECIFIED CONDITION HAS BEEN MET. C SAVE THE STACK POINTER AND RETURN. C 120 CONTINUE ICSP1 = ICS ISTORE(IS2HDS+1) = ICS CTOP = CSTORE(ICS) GO TO 999 C C THE BUFFER SPACE HAS BEEN EXCEEDED C 130 CONTINUE CALL IOERRM (.TRUE., A '('' ******** MMPOPC - STRING TOO LONG FOR BUFFER'')') C 999 CONTINUE RETURN END SUBROUTINE MMPOPV (LEMPTY) C C----------------------------------------------------------------------- C C FAMILY C ------ C MEMORY MANAGER C C PURPOSE C ------- C TO POP A VARIABLE OFF THE SUBSTITUTION STACK C C PARAMETERS C ---------- C LEMPTY -O- TRUE IF THE STACK IS EMPTY C C----------------------------------------------------------------------- C C GLOBAL CONSTANTS C CHARACTER*1 CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 COMMON / GLCOMC / CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 C C INPUT / OUTPUT CONTROL INTERFACE C CHARACTER*1 CBUFFR(2000) LOGICAL LBREAK, LFORT, LISTI, LISTO INTEGER ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOMC / CBUFFR COMMON / IOCOMI / ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOML / LBREAK, LFORT, LISTI, LISTO C C MEMORY MANAGER INTERFACE C CHARACTER*1 CSTORE(20000) INTEGER IHASH(601), ISTORE(6000) INTEGER ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS COMMON / MMCOMC / CSTORE COMMON / MMCOMH / IHASH COMMON / MMCOMS / ISTORE COMMON / MMCOMI / ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS C C LOCAL VARIABLES AND PARAMETERS C LOGICAL LEMPTY INTEGER IS2 EXTERNAL MMRETI C LEMPTY = IS2HDS .EQ. 0 IF (LEMPTY) GO TO 999 IS2 = IS2HDS IS2HDS = ISTORE(IS2+2) ISTORE(IS2+2) = 0 LEMPTY = IS2HDS .EQ. 0 IF (ISTORE(IS2) .GT. 0) CALL MMRETI (IS2) C 999 CONTINUE RETURN END SUBROUTINE MMPOP1 (LEMPTY) C C----------------------------------------------------------------------- C C FAMILY C ------ C MEMORY MANAGER C C PURPOSE C ------- C TO POP NULL ENTRIES OFF THE SUBSTITUTION STACK C C PARAMETERS C ---------- C LEMPTY -O- TRUE IF THE STACK IS EMPTY C C----------------------------------------------------------------------- C C GLOBAL CONSTANTS C CHARACTER*1 CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 COMMON / GLCOMC / CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 C C INPUT / OUTPUT CONTROL INTERFACE C CHARACTER*1 CBUFFR(2000) LOGICAL LBREAK, LFORT, LISTI, LISTO INTEGER ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOMC / CBUFFR COMMON / IOCOMI / ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOML / LBREAK, LFORT, LISTI, LISTO C C MEMORY MANAGER INTERFACE C CHARACTER*1 CSTORE(20000) INTEGER IHASH(601), ISTORE(6000) INTEGER ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS COMMON / MMCOMC / CSTORE COMMON / MMCOMH / IHASH COMMON / MMCOMS / ISTORE COMMON / MMCOMI / ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS C C LOCAL VARIABLES AND PARAMETERS C LOGICAL LEMPTY INTEGER IS2 EXTERNAL MMPOPV C 10 CONTINUE LEMPTY = IS2HDS .EQ. 0 IF (LEMPTY) GO TO 999 IS2 = IABS(ISTORE(IS2HDS)) IF (IS2 .NE. 0) GO TO 30 20 CONTINUE CALL MMPOPV (LEMPTY) GO TO 10 C 30 CONTINUE ICSP1 = ISTORE(IS2HDS+1) ICSP2 = ISTORE(IS2+1) IF (ICSP1 .LE. ICSP2) GO TO 999 IS2 = ISTORE(IS2+2) IF (IS2 .EQ. 0) GO TO 20 ISTORE(IS2HDS) = ISIGN(IS2, ISTORE(IS2HDS)) ISTORE(IS2HDS+1) = ISTORE(IS2) GO TO 30 C 999 CONTINUE RETURN END SUBROUTINE MMPSHV (CNAME, ICN1, ICN2, IPUSH, LEMPTY, LFOUND) C C----------------------------------------------------------------------- C C FAMILY C ------ C MEMORY MANAGER C C PURPOSE C ------- C TO PUSH A VARIABLE ONTO THE SUBSTITUTION STACK C C PARAMETERS C ---------- C CNAME -I- THE NAME OF THE VARIABLE TO PUSH ONTO THE STACK C ICN1 -I- INDEX OF THE FIRST CHARACTER IN THE NAME C ICN2 -I- INDEX OF THE LAST CHARACTER IN THE NAME C IPUSH -I- INDICATES THE OPERATION TO BE PERFORMED C 1 - PUSH A VARIABLE ONTO THE STACK C 2 - PUSH A POINTER ONTO THE STACK C 3 - PUSH THE ACTUAL POINTER ONTO THE STACK C C----------------------------------------------------------------------- C C GLOBAL CONSTANTS C CHARACTER*1 CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 COMMON / GLCOMC / CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 C C INPUT / OUTPUT CONTROL INTERFACE C CHARACTER*1 CBUFFR(2000) LOGICAL LBREAK, LFORT, LISTI, LISTO INTEGER ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOMC / CBUFFR COMMON / IOCOMI / ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOML / LBREAK, LFORT, LISTI, LISTO C C MEMORY MANAGER INTERFACE C CHARACTER*1 CSTORE(20000) INTEGER IHASH(601), ISTORE(6000) INTEGER ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS COMMON / MMCOMC / CSTORE COMMON / MMCOMH / IHASH COMMON / MMCOMS / ISTORE COMMON / MMCOMI / ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS C C LOCAL VARIABLES AND PARAMETERS C INTEGER ICN1, ICN2, IPUSH CHARACTER*(*) CNAME(ICN2) LOGICAL LEMPTY, LFOUND INTEGER IH, IS1, IS2, ITEMP EXTERNAL MMHASH, MMNEWI, MMPOP1 C CALL MMHASH (CNAME, ICN1, ICN2, IH, LFOUND) IF (.NOT. LFOUND) GO TO 999 IS1 = IHASH(IH) IS2 = ISTORE(IS1+1) IF (IS2 .EQ. 0) GO TO 999 IF (IPUSH .EQ. 1) GO TO 10 IF (IPUSH .EQ. 2) GO TO 20 GO TO 30 C C PUSH A VARIABLE ONTO THE STACK; NEW ENTRY WILL POINT TO C VALUE OF THE VARIABLE C 10 CONTINUE CALL MMNEWI (ITEMP) ISTORE(ITEMP) = IS2 ISTORE(ITEMP+1) = ISTORE(IS2) ISTORE(ITEMP+2) = IS2HDS IS2HDS = ITEMP GO TO 40 C C PUSH A POINTER ONTO THE STACK C 20 CONTINUE CALL MMNEWI (ITEMP) ISTORE(ITEMP) = ISTORE(IS2) ISTORE(ITEMP+1) = ISTORE(IS2+1) ISTORE(ITEMP+2) = IS2HDS IS2HDS = ITEMP GO TO 40 C C PUSH THE ACTUAL POINTER ONTO THE STACK C 30 CONTINUE ISTORE(IS2) = -IABS(ISTORE(IS2)) ISTORE(IS2+2) = IS2HDS IS2HDS = IS2 C C CALL MMPOP1 TO SET THE POINTERS (ICSP1, ICSP2) INTO CSTORE C 40 CONTINUE CALL MMPOP1 (LEMPTY) C 999 CONTINUE RETURN END SUBROUTINE MMPUTP (CNAME, ICN1, ICN2, CPTR, ICP1, ICP2, LFOUND) C C----------------------------------------------------------------------- C C FAMILY C ------ C MEMORY MANAGER C C PURPOSE C ------- C TO PUT A POINTER TO A VARIABLE IN THE SYMBOL TABLE C C PARAMETERS C ---------- C CNAME -I- NAME OF THE VARIABLE C ICN1 -I- INDEX OF THE FIRST CHARACTER IN THE NAME C ICN2 -I- INDEX OF THE LAST CHARACTER IN THE NAME C CPTR -I- NAME OF THE POINTER C ICP1 -I- INDEX OF THE FIRST CHARACTER IN THE POINTER NAME C ICP2 -I- INDEX OF THE LAST CHARACTER IN THE POINTER NAME C LFOUND -O- TRUE IF THE VARIABLE WAS FOUND IN THE TABLE C C----------------------------------------------------------------------- C C GLOBAL CONSTANTS C CHARACTER*1 CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 COMMON / GLCOMC / CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 C C INPUT / OUTPUT CONTROL INTERFACE C CHARACTER*1 CBUFFR(2000) LOGICAL LBREAK, LFORT, LISTI, LISTO INTEGER ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOMC / CBUFFR COMMON / IOCOMI / ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOML / LBREAK, LFORT, LISTI, LISTO C C MEMORY MANAGER INTERFACE C CHARACTER*1 CSTORE(20000) INTEGER IHASH(601), ISTORE(6000) INTEGER ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS COMMON / MMCOMC / CSTORE COMMON / MMCOMH / IHASH COMMON / MMCOMS / ISTORE COMMON / MMCOMI / ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS C C LOCAL VARIABLES AND PARAMETERS C INTEGER ICN1, ICN2, ICP1, ICP2 CHARACTER*(*) CNAME(ICN2), CPTR(ICP2) LOGICAL L, LFOUND INTEGER IH, IS1, IS2CN, I, IS2 EXTERNAL MMHASH, MMNEWI, MMPUT1 C CALL MMHASH (CNAME, ICN1, ICN2, IH, LFOUND) IF (.NOT. LFOUND) GO TO 999 IS1 = IHASH(IH) IS2CN = ISTORE(IS1+1) CALL MMHASH (CPTR, ICP1, ICP2, IH, L) IF (L) GO TO 10 CALL MMNEWI (IS1) IHASH(IH) = IS1 CALL MMPUT1 (CPTR, ICP1, ICP2, ISTORE(IS1), I) CALL MMNEWI (IS2) ISTORE(IS1+1) = IS2 ISTORE(IS1+2) = 0 GO TO 20 C 10 CONTINUE IS1 = IHASH(IH) IS2 = ISTORE(IS1+1) C 20 CONTINUE IF (IS2CN .NE. 0) GO TO 30 ISTORE(IS2) = 0 ISTORE(IS2+1) = 0 ISTORE(IS2+2) = 0 GO TO 999 C 30 CONTINUE ISTORE(IS2) = IS2CN ISTORE(IS2+1) = ISTORE(IS2CN) ISTORE(IS2+2) = 0 C 999 CONTINUE RETURN END SUBROUTINE MMPUTV (CNAME, ICN1, ICN2, CVALUE, ICV1, ICV2) C C----------------------------------------------------------------------- C C FAMILY C ------ C MEMORY MANAGER C C PURPOSE C ------- C TO PUT A VARIABLE INTO THE SYMBOL TABLE C C PARAMETERS C ---------- C CNAME -I- NAME OF THE VARIABLE C ICN1 -I- INDEX OF THE FIRST CHARACTER IN THE NAME C ICN2 -I- INDEX OF THE LAST CHARACTER IN THE NAME C CVALUE -I- VALUE OF THE VARIABLE C ICV1 -I- INDEX OF THE FIRST CHARACTER IN THE VALUE C ICV2 -I- INDEX OF THE LAST CHARACTER IN THE VALUE C C----------------------------------------------------------------------- C C GLOBAL CONSTANTS C CHARACTER*1 CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 COMMON / GLCOMC / CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 C C INPUT / OUTPUT CONTROL INTERFACE C CHARACTER*1 CBUFFR(2000) LOGICAL LBREAK, LFORT, LISTI, LISTO INTEGER ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOMC / CBUFFR COMMON / IOCOMI / ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOML / LBREAK, LFORT, LISTI, LISTO C C MEMORY MANAGER INTERFACE C CHARACTER*1 CSTORE(20000) INTEGER IHASH(601), ISTORE(6000) INTEGER ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS COMMON / MMCOMC / CSTORE COMMON / MMCOMH / IHASH COMMON / MMCOMS / ISTORE COMMON / MMCOMI / ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS C C LOCAL VARIABLES AND PARAMETERS C INTEGER ICN1, ICN2, ICV1, ICV2 CHARACTER*(*) CNAME(ICN2), CVALUE(ICV2) LOGICAL LFOUND INTEGER IH, IS1, I EXTERNAL MMHASH, MMNEWI, MMPUT1, MMDEL1 C C HASH THE NAME TO SEE IF IT IS IN THE TABLE. C IF IT IS NOT, STORE A NEW NAME IN THE TABLE. C CALL MMHASH (CNAME, ICN1, ICN2, IH, LFOUND) IF (LFOUND) GO TO 10 CALL MMNEWI (IS1) IHASH(IH) = IS1 CALL MMPUT1 (CNAME, ICN1, ICN2, ISTORE(IS1), I) GO TO 20 C C RETURN THE SPACE ALLOCATED TO THE OLD VALUE C 10 CONTINUE IS1 = IHASH(IH) CALL MMDEL1 (ISTORE(IS1+1)) C C STORE THE NEW VALUE IN THE TABLE C 20 CONTINUE CALL MMPUT1 (CVALUE, ICV1, ICV2, ISTORE(IS1+1), ISTORE(IS1+2)) C RETURN END SUBROUTINE MMPUT1 (CVALUE, ICV1, ICV2, IS2H, IS2T) C C----------------------------------------------------------------------- C C FAMILY C ------ C MEMORY MANAGER C C PURPOSE C ------- C TO PUT A STRING VALUE INTO CHARACTER STORAGE C AND RETURN POINTERS TO ITS LOCATION C C PARAMETERS C ---------- C CVALUE -I- CONTAINS THE CHARACTER STRING C ICV1 -I- INDEX OF THE FIRST CHARACTER IN THE STRING C ICV2 -I- INDEX OF THE LAST CHARACTER IN THE STRING C IS2H -O- POINTER TO THE FIRST BLOCK CONTAINING THE STRING C IS2T -O- POINTER TO THE LAST BLOCK CONTAINING THE STRING C C LOCAL VARIABLES C --------------- C ICV - INDEX OF THE CURRENT CHARACTER IN THE STRING C IS2 - POINTER TO CURRENT BLOCK FOR THE STRING C ICS - INDEX OF CURRENT STORE POSITION IN CSTORE C ICS1 - INDEX OF BEGINNING OF CURRENT CSTORE BLOCK C ICS2 - INDEX OF END OF CURRENT CSTORE BLOCK C ICSTST - INDEX OF LAST CSTORE POSITION NEEDED C ICSMIN - INDEX OF LAST CSTORE POSITION NEEDED IN CURRENT BLOCK C C----------------------------------------------------------------------- C C GLOBAL CONSTANTS C CHARACTER*1 CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 COMMON / GLCOMC / CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 C C INPUT / OUTPUT CONTROL INTERFACE C CHARACTER*1 CBUFFR(2000) LOGICAL LBREAK, LFORT, LISTI, LISTO INTEGER ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOMC / CBUFFR COMMON / IOCOMI / ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOML / LBREAK, LFORT, LISTI, LISTO C C MEMORY MANAGER INTERFACE C CHARACTER*1 CSTORE(20000) INTEGER IHASH(601), ISTORE(6000) INTEGER ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS COMMON / MMCOMC / CSTORE COMMON / MMCOMH / IHASH COMMON / MMCOMS / ISTORE COMMON / MMCOMI / ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS C C LOCAL VARIABLES AND PARAMETERS C INTEGER ICV1, ICV2, IS2H, IS2T CHARACTER*(*) CVALUE(ICV2) INTEGER ICV, IS2, ICS1, ICS2, ICSTST, ICSMIN, ICS EXTERNAL MMNEWI, IOERRM C IF ((ICV1 .GT. 0) .AND. (ICV1 .LE. ICV2)) GO TO 10 IS2H = 0 IS2T = 0 GO TO 999 C 10 CONTINUE ICV = ICV1 IS2 = IS2HDC IS2H = IS2HDC C C LOOP THROUGH THE LINKED LIST OF AVAILABLE MEMORY BLOCKS C 20 CONTINUE IF (IS2 .EQ. 0) GO TO 60 IS2T = IS2 ICS1 = ISTORE(IS2T) ICS2 = ISTORE(IS2T+1) IS2 = ISTORE(IS2T+2) ICSTST = ICS1 + ICV2 - ICV ICSMIN = MIN0(ICS2, ICSTST) C C STORE CHARACTERS INTO A PARTICULAR BLOCK C DO 30 ICS=ICS1,ICSMIN CSTORE(ICS) = CVALUE(ICV) ICV = ICV + 1 30 CONTINUE IF (ICSTST .GT. ICS2) GO TO 20 C C IF THE LAST BLOCK USED WAS COMPLETELY FILLED, GO TO 40 C IF (ICSTST .NE. ICS2) GO TO 40 IS2HDC = IS2 GO TO 50 C C THE LAST BLOCK OF MEMORY WAS NOT COMPLETELY USED. C PUT A NEW BLOCK ON THE AVAILABLE MEMORY STACK C CORRESPONDING TO THE REMAINING CHARACTERS. C 40 CONTINUE CALL MMNEWI (IS2HDC) ISTORE(IS2HDC) = ICSMIN+1 ISTORE(IS2HDC+1) = ICS2 ISTORE(IS2HDC+2) = IS2 C 50 CONTINUE ISTORE(IS2T+1) = ICSTST ISTORE(IS2T+2) = 0 GO TO 999 C C FATAL ERROR - NO MORE CHARACTER STORAGE SPACE C 60 CONTINUE CALL IOERRM (.TRUE., A '('' ******** MMPUT1 - STORAGE ARRAY CSTORE(*) FULL'')') C 999 CONTINUE RETURN END SUBROUTINE MMRETI (IS) C C----------------------------------------------------------------------- C C FAMILY C ------ C MEMORY MANAGER C C PURPOSE C ------- C TO RETURN AN INTEGER BLOCK TO THE FREE LIST C C PARAMETERS C ---------- C IS -I- POINTER TO THE BLOCK TO BE RETURNED C C----------------------------------------------------------------------- C C GLOBAL CONSTANTS C CHARACTER*1 CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 COMMON / GLCOMC / CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 C C INPUT / OUTPUT CONTROL INTERFACE C CHARACTER*1 CBUFFR(2000) LOGICAL LBREAK, LFORT, LISTI, LISTO INTEGER ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOMC / CBUFFR COMMON / IOCOMI / ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOML / LBREAK, LFORT, LISTI, LISTO C C MEMORY MANAGER INTERFACE C CHARACTER*1 CSTORE(20000) INTEGER IHASH(601), ISTORE(6000) INTEGER ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS COMMON / MMCOMC / CSTORE COMMON / MMCOMH / IHASH COMMON / MMCOMS / ISTORE COMMON / MMCOMI / ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS C INTEGER IS EXTERNAL IOERRM IF (IS .EQ. 0) GO TO 999 IF ((IS .LT. 0) .OR. (IS .GT. ISTDIM) A .OR. (MOD(IS,3) .NE. 1)) GO TO 10 ISTORE(IS+2) = ISFREE ISFREE = IS GO TO 999 C 10 CONTINUE CALL IOERRM (.FALSE., A '('' ******** MMRETI - ATTEMPT TO RETURN INVALID POINTER'')') C 999 CONTINUE RETURN END SUBROUTINE MMSETP (CPTR, ICP1, ICP2) C C----------------------------------------------------------------------- C C FAMILY C ------ C MEMORY MANAGER C C PURPOSE C ------- C TO SAVE A POINTER TO THE CURRENT TOP OF THE SUBSTITUTION STACK C C PARAMETERS C ---------- C CPTR -I- NAME OF THE POINTER C ICP1 -I- INDEX OF THE FIRST CHARACTER IN THE NAME C ICP2 -I- INDEX OF THE LAST CHARACTER IN THE NAME C C----------------------------------------------------------------------- C C GLOBAL CONSTANTS C CHARACTER*1 CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 COMMON / GLCOMC / CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 C C INPUT / OUTPUT CONTROL INTERFACE C CHARACTER*1 CBUFFR(2000) LOGICAL LBREAK, LFORT, LISTI, LISTO INTEGER ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOMC / CBUFFR COMMON / IOCOMI / ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOML / LBREAK, LFORT, LISTI, LISTO C C MEMORY MANAGER INTERFACE C CHARACTER*1 CSTORE(20000) INTEGER IHASH(601), ISTORE(6000) INTEGER ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS COMMON / MMCOMC / CSTORE COMMON / MMCOMH / IHASH COMMON / MMCOMS / ISTORE COMMON / MMCOMI / ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS C C LOCAL VARIABLES AND PARAMETERS C INTEGER ICP1, ICP2 CHARACTER*(*) CPTR(ICP2) LOGICAL LFOUND INTEGER I, IH, IS1, IS2 EXTERNAL MMHASH, MMNEWI, MMPUT1 C CALL MMHASH (CPTR, ICP1, ICP2, IH, LFOUND) IF (.NOT. LFOUND) GO TO 10 IS1 = IHASH(IH) IS2 = ISTORE(IS1+1) GO TO 20 C 10 CONTINUE CALL MMNEWI (IS1) IHASH(IH) = IS1 CALL MMPUT1 (CPTR, ICP1, ICP2, ISTORE(IS1), I) CALL MMNEWI (IS2) ISTORE(IS1+1) = IS2 ISTORE(IS1+2) = 0 C 20 CONTINUE IF (IS2HDS .NE. 0) GO TO 30 ISTORE(IS2) = 0 ISTORE(IS2+1) = 0 ISTORE(IS2+2) = 0 GO TO 999 C 30 CONTINUE ISTORE(IS2) = ISTORE(IS2HDS) ISTORE(IS2+1) = ISTORE(IS2HDS+1) ISTORE(IS2+2) = 0 C 999 CONTINUE RETURN END SUBROUTINE MMTEST (CVALUE, ICV1, ICV2, IS2H, LEQUAL) C C----------------------------------------------------------------------- C C FAMILY C ------ C MEMORY MANAGER C C PURPOSE C ------- C TO SEE IF A GIVEN STRING IS EQUAL TO ONE IN THE SYMBOL TABLE C C PARAMETERS C ---------- C CVALUE -I- CONTAINS THE STRING TO BE TESTED C ICV1 -I- INDEX OF THE FIRST CHARACTER IN THE STRING C ICV2 -I- INDEX OF THE LAST CHARACTER IN THE STRING C IS2H -I- POINTER TO THE STRING IN THE SYMBOL TABLE C LEQUAL -O- TRUE IF THE STRINGS ARE EQUAL C C----------------------------------------------------------------------- C C GLOBAL CONSTANTS C CHARACTER*1 CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 COMMON / GLCOMC / CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 C C INPUT / OUTPUT CONTROL INTERFACE C CHARACTER*1 CBUFFR(2000) LOGICAL LBREAK, LFORT, LISTI, LISTO INTEGER ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOMC / CBUFFR COMMON / IOCOMI / ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOML / LBREAK, LFORT, LISTI, LISTO C C MEMORY MANAGER INTERFACE C CHARACTER*1 CSTORE(20000) INTEGER IHASH(601), ISTORE(6000) INTEGER ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS COMMON / MMCOMC / CSTORE COMMON / MMCOMH / IHASH COMMON / MMCOMS / ISTORE COMMON / MMCOMI / ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS C C LOCAL VARIABLES AND PARAMETERS C INTEGER ICV1, ICV2, IS2H CHARACTER*(*) CVALUE(ICV2) LOGICAL LEQUAL INTEGER ICS, ICS1, ICS2, ICV, IS2 C ICV = ICV1 IS2 = IS2H LEQUAL = .FALSE. C 10 CONTINUE IF (IS2 .EQ. 0) GO TO 30 ICS1 = ISTORE(IS2) ICS2 = ISTORE(IS2+1) IS2 = ISTORE(IS2+2) IF (ICS2-ICS1 .GT. ICV2-ICV) GO TO 999 DO 20 ICS=ICS1,ICS2 IF (CSTORE(ICS) .NE. CVALUE(ICV)) GO TO 999 ICV = ICV + 1 20 CONTINUE GO TO 10 C 30 CONTINUE LEQUAL = ICV .GT. ICV2 C 999 CONTINUE RETURN END SUBROUTINE MPEOL C C----------------------------------------------------------------------- C C FAMILY C ------ C MACRO PROCESSOR C C PURPOSE C ------- C TO REMOVE TRAILING BLANKS AND ADD AN END-OF-LINE MARKER C TO THE LINE IN THE INPUT/OUTPUT BUFFER C C----------------------------------------------------------------------- C C GLOBAL CONSTANTS C CHARACTER*1 CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 COMMON / GLCOMC / CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 C C INPUT / OUTPUT CONTROL INTERFACE C CHARACTER*1 CBUFFR(2000) LOGICAL LBREAK, LFORT, LISTI, LISTO INTEGER ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOMC / CBUFFR COMMON / IOCOMI / ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOML / LBREAK, LFORT, LISTI, LISTO C C MEMORY MANAGER INTERFACE C CHARACTER*1 CSTORE(20000) INTEGER IHASH(601), ISTORE(6000) INTEGER ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS COMMON / MMCOMC / CSTORE COMMON / MMCOMH / IHASH COMMON / MMCOMS / ISTORE COMMON / MMCOMI / ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS C C MACRO PROCESSOR INTERFACE C CHARACTER*1 CDIV, CEOL, CEOR, CONC, CSUB, A CTOP LOGICAL LEMPTY, LSUB COMMON / MPCOMC / CDIV, CEOL, CEOR, CONC, CSUB, A CTOP COMMON / MPCOML / LEMPTY, LSUB C C LOCAL VARIABLES AND PARAMETERS C CHARACTER*1 C EXTERNAL MMPOPC C CALL MMPOPC (C, 2, CTOP, LEMPTY) ICBEOL = ICB2 ICBEND = ICBEOL ICB2 = ICB2 - 2 ICB3 = ICB2 IF (ICB1 .GT. ICB2) GO TO 999 IF (CBUFFR(ICB2) .NE. CBLANK) GO TO 999 C C REMOVE TRAILING BLANKS C 10 CONTINUE ICB2 = ICB2 - 1 IF (ICB1 .GT. ICB2) GO TO 20 IF (CBUFFR(ICB2) .EQ. CBLANK) GO TO 10 C C ADD THE END-OF-LINE MARKER C 20 CONTINUE CBUFFR(ICB2+1) = CSUB CBUFFR(ICB2+2) = CEOL ICB3 = ICB2 ICBEOL = ICB2 + 2 ICBEND = ICBEOL C 999 CONTINUE RETURN END SUBROUTINE MPITEM C C----------------------------------------------------------------------- C C FAMILY C ------ C MACRO PROCESSOR C C PURPOSE C ------- C TO PUSH THE NEXT ITEM IN A LIST ONTO THE SUBSTITUTION STACK C C----------------------------------------------------------------------- C C GLOBAL CONSTANTS C CHARACTER*1 CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 COMMON / GLCOMC / CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 C C INPUT / OUTPUT CONTROL INTERFACE C CHARACTER*1 CBUFFR(2000) LOGICAL LBREAK, LFORT, LISTI, LISTO INTEGER ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOMC / CBUFFR COMMON / IOCOMI / ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOML / LBREAK, LFORT, LISTI, LISTO C C MEMORY MANAGER INTERFACE C CHARACTER*1 CSTORE(20000) INTEGER IHASH(601), ISTORE(6000) INTEGER ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS COMMON / MMCOMC / CSTORE COMMON / MMCOMH / IHASH COMMON / MMCOMS / ISTORE COMMON / MMCOMI / ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS C C MACRO PROCESSOR INTERFACE C CHARACTER*1 CDIV, CEOL, CEOR, CONC, CSUB, A CTOP LOGICAL LEMPTY, LSUB COMMON / MPCOMC / CDIV, CEOL, CEOR, CONC, CSUB, A CTOP COMMON / MPCOML / LEMPTY, LSUB C C LOCAL VARIABLES AND PARAMETERS C LOGICAL LERROR, LFOUND INTEGER ICN1, ICN2, ICP1, ICP2 EXTERNAL MPPOPN, UTBLDN, MMPSHV, MMPUTP, IOERRM C CALL MPPOPN (ICN1, ICN2, LERROR) ICP1 = ICB2 + 1 CALL UTBLDN (CDIV, CBUFFR, ICN1, ICN2, 1, A CBUFFR, ICP1, ICP2, ICBDIM, LERROR) CALL MMPSHV (CBUFFR, ICP1, ICP2, 3, LEMPTY, LFOUND) IF (LFOUND) GO TO 10 CALL MMPUTP (CBUFFR, ICN1, ICN2, CBUFFR, ICP1, ICP2, LFOUND) IF (.NOT. LFOUND) GO TO 20 CALL MMPSHV (CBUFFR, ICP1, ICP2, 3, LEMPTY, LFOUND) C 10 CONTINUE ICB2 = ICBSUB - 1 GO TO 999 C 20 CONTINUE CALL IOERRM (.FALSE., A '('' ******** MPITEM - VARIABLE NOT DEFINED'')') C 999 CONTINUE RETURN END SUBROUTINE MPLABL C C----------------------------------------------------------------------- C C FAMILY C ------ C MACRO PROCESSOR C C PURPOSE C ------- C TO COPY THE CURRENT LABEL TO THE BUFFER AND THEN C INCREMENT AND SAVE ITS VALUE C C----------------------------------------------------------------------- C C GLOBAL CONSTANTS C CHARACTER*1 CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 COMMON / GLCOMC / CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 C C INPUT / OUTPUT CONTROL INTERFACE C CHARACTER*1 CBUFFR(2000) LOGICAL LBREAK, LFORT, LISTI, LISTO INTEGER ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOMC / CBUFFR COMMON / IOCOMI / ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOML / LBREAK, LFORT, LISTI, LISTO C C MEMORY MANAGER INTERFACE C CHARACTER*1 CSTORE(20000) INTEGER IHASH(601), ISTORE(6000) INTEGER ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS COMMON / MMCOMC / CSTORE COMMON / MMCOMH / IHASH COMMON / MMCOMS / ISTORE COMMON / MMCOMI / ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS C C MACRO PROCESSOR INTERFACE C CHARACTER*1 CDIV, CEOL, CEOR, CONC, CSUB, A CTOP LOGICAL LEMPTY, LSUB COMMON / MPCOMC / CDIV, CEOL, CEOR, CONC, CSUB, A CTOP COMMON / MPCOML / LEMPTY, LSUB C C LOCAL VARIABLES AND PARAMETERS C INTEGER I, ICV1, ICV2, ICV2M4, ICV1M1 CHARACTER*1 C(5) LOGICAL L INTEGER ICNDIM EXTERNAL MMGETV, UTCVCI, UTCVIC, MMPUTV, IOERRM SAVE ICNDIM, C DATA ICNDIM / 5 / DATA C(1), C(2), C(3), C(4), C(5) A / 'L', 'A', 'B', 'E', 'L' / C C GET CURRENT VALUE OF LABEL, CONVERT TO AN INTEGER AND C CHECK IT. ADD ONE, CONVERT BACK TO CHARACTERS AND PLACE C IN CBUFFR C ICV1 = ICB2 + 5 CALL MMGETV (C, 1, ICNDIM, CBUFFR, ICV1, ICV2, ICBDIM, L) IF (.NOT. L) GO TO 40 CALL UTCVCI (CBUFFR, ICV1, ICV2, I, L) IF ((I .LT. 0) .OR. (99999 .LT. I)) GO TO 40 I = I + 1 CALL UTCVIC (CBUFFR, ICV1, ICV2, ICBDIM, I, L) ICV2M4 = ICV2 - 4 ICV1M1 = ICV1 - 1 IF (ICV2M4 .GT. ICV1M1) GO TO 20 C DO 10 I=ICV2M4,ICV1M1 CBUFFR(I) = CBLANK 10 CONTINUE C 20 CONTINUE CALL MMPUTV (C, 1, ICNDIM, CBUFFR, ICV2M4, ICV2) ICB2 = ICBSUB - 1 DO 30 I=ICV2M4,ICV2 ICB2 = ICB2 + 1 CBUFFR(ICB2) = CBUFFR(I) 30 CONTINUE GO TO 999 C C WARNING - INVALID LABEL VALUE C 40 CONTINUE CALL IOERRM (.FALSE., A '('' ******** MPLABL - ILLEGAL LABEL VALUE'')') C 999 CONTINUE RETURN END SUBROUTINE MPLINE (LSUBL) C C----------------------------------------------------------------------- C C FAMILY C ------ C MACRO PROCESSOR C C PURPOSE C ------- C TO BUILD THE NEXT LINE IN THE I/O BUFFER C C PARAMETERS C ---------- C LSUBL -I- LOCAL SUBSTITUTION FLAG INDICATING WHETHER C OR NOT MACROS ON THIS LINE ARE TO BE EXPANDED C C----------------------------------------------------------------------- C C GLOBAL CONSTANTS C CHARACTER*1 CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 COMMON / GLCOMC / CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 C C INPUT / OUTPUT CONTROL INTERFACE C CHARACTER*1 CBUFFR(2000) LOGICAL LBREAK, LFORT, LISTI, LISTO INTEGER ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOMC / CBUFFR COMMON / IOCOMI / ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOML / LBREAK, LFORT, LISTI, LISTO C C MEMORY MANAGER INTERFACE C CHARACTER*1 CSTORE(20000) INTEGER IHASH(601), ISTORE(6000) INTEGER ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS COMMON / MMCOMC / CSTORE COMMON / MMCOMH / IHASH COMMON / MMCOMS / ISTORE COMMON / MMCOMI / ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS C C MACRO PROCESSOR INTERFACE C CHARACTER*1 CDIV, CEOL, CEOR, CONC, CSUB, A CTOP LOGICAL LEMPTY, LSUB COMMON / MPCOMC / CDIV, CEOL, CEOR, CONC, CSUB, A CTOP COMMON / MPCOML / LEMPTY, LSUB C C LOCAL VARIABLES AND PARAMETERS C INTEGER ICB CHARACTER*1 C(2) LOGICAL LEOL, LFOUND, LSUBL INTEGER ICNDIM EXTERNAL MMPOPC, MPSUBS, IOREAD, MMPUTV, MMPSHV SAVE ICNDIM, C DATA ICNDIM / 2 / DATA C(1), C(2) /'*', 'L' / C C SET I/O BUFFER POINTERS C ICB0 = ICBEOL + 1 ICB1 = ICBEOL + 1 ICB2 = ICBEOL IF (LEMPTY) GO TO 20 C C IF THE STACK IS NONEMPTY, POP INTO THE I/O BUFFER UNTIL A C SUB. CHAR. IS FOUND. THEN CALL MPSUBS. C 10 CONTINUE CALL MMPOPC (CSUB, 5, CTOP, LEMPTY) IF (LEMPTY) GO TO 20 CALL MPSUBS (LEOL, LSUBL) IF (LEOL) GO TO 999 GO TO 10 C C IF THE STACK IS EMPTY, GET MORE INPUT C 20 CONTINUE CALL IOREAD IF ((.NOT. LSUBL) .OR. (ICB1 .GT. ICB2)) GO TO 999 C C LOOK FOR SUBSTITUTION CHARACTER C DO 30 ICB=ICB1,ICB2 IF (CBUFFR(ICB) .EQ. CSUB) GO TO 40 30 CONTINUE GO TO 999 C C WHEN A SUB. CHAR IS FOUND, PUT THE VARIABLE '*L' IN THE C SYMBOL TABLE. THE VALUE OF THIS SPECIAL VARIABLE IS THE C REST OF THE LINE. ALSO PUSH *L ONTO THE SUBST. STACK. C 40 CONTINUE CALL MMPUTV (C, 1, ICNDIM, CBUFFR, ICB, ICBEOL) CALL MMPSHV (C, 1, ICNDIM, 1, LEMPTY, LFOUND) ICB2 = ICB - 1 CALL MPSUBS (LEOL, LSUBL) IF (.NOT. LEOL) GO TO 10 C 999 CONTINUE RETURN END SUBROUTINE MPMAC C C----------------------------------------------------------------------- C C FAMILY C ------ C MACRO PROCESSOR C C PURPOSE C ------- C TO DETERMINE THE TYPE OF MACRO EXPANSION INDICATED C AND CALL THE APPROPRIATE ROUTINES C C----------------------------------------------------------------------- C C GLOBAL CONSTANTS C CHARACTER*1 CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 COMMON / GLCOMC / CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 C C INPUT / OUTPUT CONTROL INTERFACE C CHARACTER*1 CBUFFR(2000) LOGICAL LBREAK, LFORT, LISTI, LISTO INTEGER ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOMC / CBUFFR COMMON / IOCOMI / ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOML / LBREAK, LFORT, LISTI, LISTO C C MEMORY MANAGER INTERFACE C CHARACTER*1 CSTORE(20000) INTEGER IHASH(601), ISTORE(6000) INTEGER ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS COMMON / MMCOMC / CSTORE COMMON / MMCOMH / IHASH COMMON / MMCOMS / ISTORE COMMON / MMCOMI / ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS C C MACRO PROCESSOR INTERFACE C CHARACTER*1 CDIV, CEOL, CEOR, CONC, CSUB, A CTOP LOGICAL LEMPTY, LSUB COMMON / MPCOMC / CDIV, CEOL, CEOR, CONC, CSUB, A CTOP COMMON / MPCOML / LEMPTY, LSUB C C LOCAL VARIABLES AND PARAMETERS C CHARACTER*1 C(12) INTEGER IK(3) INTEGER IKYDIM, ICKDIM, ICN1, ICN2, ICN1SV, I, A ICL1NA, ICL2NA, IH LOGICAL LERROR, LFOUND EXTERNAL MMHASH, MPPOPN, UTRDKY, UTRDNA, MMPSHV, A UTCVLC, MPLABL, MPITEM, IOERRM SAVE IKYDIM, IK, ICKDIM, C DATA A IKYDIM, ICKDIM, B IK(1), C IK(2), D IK(3) E / 3, 12, F 3, G 5, H 4 / DATA B C(1), C(2), C(3), C C(4), C(5), C(6), C(7), C(8), D C(9), C(10), C(11), C(12) E / F 'D', 'E', 'F', G 'L', 'A', 'B', 'E', 'L', H 'L', 'I', 'S', 'T' / C C MARK THE CURRENT LINE POSITION, POP THE NAME OFF THE STACK, C AND THEN DETERMINE THE TYPE OF SUBSTITUTION C ICBSUB = ICB2 CALL MPPOPN (ICN1, ICN2, LERROR) IF (LERROR) GO TO 999 ICN1SV = ICN1 CALL UTRDKY (CBUFFR, ICN1, ICN2, IK, IKYDIM, C, ICKDIM, I) IF(I.GT.IKYDIM) GO TO 10 C C CHECK IF WE ONLY HAPPENED TO MATCH A PREFIX C CALL UTRDNA (CBUFFR, ICN1, ICN2, ICL1NA, ICL2NA, LERROR) IF(LERROR) 1 GO TO (20, 30, 40), I C C IF SO, RESTORE ORIGINAL STATE AND PROCESS VARIABLE SUBSTITUTION C ICN1 = ICN1SV GO TO 10 C C A SIMPLE MACRO SUBSTITUTION HAS BEEN FOUND. C PUSH THE NEW NAME ONTO THE STACK C AND RESET THE CURRENT LINE POINTER. C SUBSEQUENT POPPING OF THE STACK WILL PUT THE VALUE C OF THE MACRO INTO THE I/O BUFFER. C 10 CONTINUE CALL MMPSHV (CBUFFR, ICN1, ICN2, 1, LEMPTY, LFOUND) IF (.NOT. LFOUND) GO TO 50 ICB2 = ICBSUB - 1 GO TO 999 C C A DEF SUBSTITUTION HAS BEEN ENCOUNTERED C 20 CONTINUE CALL MPPOPN (ICN1, ICN2, LERROR) CALL MMHASH (CBUFFR, ICN1, ICN2, IH, LFOUND) CALL UTCVLC (CBUFFR, ICBSUB, ICB2, ICBDIM, LFOUND, LERROR) GO TO 999 C C A LABEL SUBSTITUTION HAS BEEN ENCOUNTERED C 30 CONTINUE CALL MPLABL GO TO 999 C C A LIST SUBSTITUTION HAS POSSIBLY BEEN ENCOUNTERED C 40 CONTINUE CALL MPITEM GO TO 999 C C WARNING - NAME NOT FOUND IN SYMBOL TABLE C 50 CONTINUE CALL IOERRM (.FALSE., A '('' ******** MPMAC - VARIABLE NOT DEFINED'')') C 999 CONTINUE RETURN END SUBROUTINE MPPOPN (ICN1, ICN2, LERROR) C C----------------------------------------------------------------------- C C FAMILY C ------ C MACRO PROCESSOR C C PURPOSE C ------- C TO POP A NAME OFF THE SUBSTITUTION STACK INTO THE I/O BUFFER C C PARAMETERS C ---------- C ICN1 -O- INDEX IN THE BUFFER OF THE FIRST CHARACTER C IN THE NAME C ICN2 -O- INDEX OF THE LAST CHARACTER C LERROR -O- TRUE IF THE NAME WAS INVALID C C----------------------------------------------------------------------- C C GLOBAL CONSTANTS C CHARACTER*1 CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 COMMON / GLCOMC / CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 C C INPUT / OUTPUT CONTROL INTERFACE C CHARACTER*1 CBUFFR(2000) LOGICAL LBREAK, LFORT, LISTI, LISTO INTEGER ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOMC / CBUFFR COMMON / IOCOMI / ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOML / LBREAK, LFORT, LISTI, LISTO C C MEMORY MANAGER INTERFACE C CHARACTER*1 CSTORE(20000) INTEGER IHASH(601), ISTORE(6000) INTEGER ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS COMMON / MMCOMC / CSTORE COMMON / MMCOMH / IHASH COMMON / MMCOMS / ISTORE COMMON / MMCOMI / ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS C C MACRO PROCESSOR INTERFACE C CHARACTER*1 CDIV, CEOL, CEOR, CONC, CSUB, A CTOP LOGICAL LEMPTY, LSUB COMMON / MPCOMC / CDIV, CEOL, CEOR, CONC, CSUB, A CTOP COMMON / MPCOML / LEMPTY, LSUB C C LOCAL VARIABLES AND PARAMETERS C INTEGER ICN1, ICN2 CHARACTER*1 C LOGICAL LEFT, LERROR EXTERNAL MMPOPC, IOERRM C C POP BLANKS; LOOK FOR LEFT PAREN. C CALL MMPOPC (CBLANK, 4, CTOP, LEMPTY) LEFT = CLEFT .EQ. CTOP IF (.NOT. LEFT) GO TO 10 CALL MMPOPC (C, 2, CTOP, LEMPTY) CALL MMPOPC (CBLANK, 4, CTOP, LEMPTY) C 10 CONTINUE ICN1 = ICB2 + 1 C C CHECK FOR A LEGAL NAME C LERROR = .NOT. (LLE(CA,CTOP) A .AND. LLE(CTOP,CZ)) IF (LERROR) GO TO 20 C C POP THE CHAR'S OF THE NAME OFF C CALL MMPOPC (C, 6, CTOP, LEMPTY) ICN2 = ICB2 IF (.NOT. LEFT) GO TO 999 CALL MMPOPC (CBLANK, 4, CTOP, LEMPTY) LERROR = CRIGHT .NE. CTOP IF (LERROR) GO TO 30 CALL MMPOPC (C, 2, CTOP, LEMPTY) GO TO 999 C C WARNING - ILLEGAL NAME C 20 CONTINUE CALL IOERRM (.FALSE., A '('' ******** MPPOPN - ILLEGAL VARIABLE NAME'')') GO TO 999 C C WARNING - NO CLOSING RIGHT PARENTHESIS C 30 CONTINUE CALL IOERRM (.FALSE., A '('' ******** MPPOPN - MISSING RIGHT PARENTHESIS'')') C 999 CONTINUE RETURN END SUBROUTINE MPSUBS (LEOL, LSUBL) C C----------------------------------------------------------------------- C C FAMILY C ------ C MACRO PROCESSOR C C PURPOSE C ------- C TO EVALUATE OF THE SUBSTITUTION ESCAPE CHARACTER C AND DECIDE WHAT ACTION IS TO BE TAKEN C C PARAMETERS C ---------- C LEOL -O- TRUE IF AN END-OF-LINE MARKER WAS FOUND C LSUBL -I- TRUE IF NO SUBSTITUTION IS TO BE PERFORMED C ON THIS LINE C C----------------------------------------------------------------------- C C GLOBAL CONSTANTS C CHARACTER*1 CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 COMMON / GLCOMC / CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 C C INPUT / OUTPUT CONTROL INTERFACE C CHARACTER*1 CBUFFR(2000) LOGICAL LBREAK, LFORT, LISTI, LISTO INTEGER ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOMC / CBUFFR COMMON / IOCOMI / ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOML / LBREAK, LFORT, LISTI, LISTO C C MEMORY MANAGER INTERFACE C CHARACTER*1 CSTORE(20000) INTEGER IHASH(601), ISTORE(6000) INTEGER ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS COMMON / MMCOMC / CSTORE COMMON / MMCOMH / IHASH COMMON / MMCOMS / ISTORE COMMON / MMCOMI / ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS C C MACRO PROCESSOR INTERFACE C CHARACTER*1 CDIV, CEOL, CEOR, CONC, CSUB, A CTOP LOGICAL LEMPTY, LSUB COMMON / MPCOMC / CDIV, CEOL, CEOR, CONC, CSUB, A CTOP COMMON / MPCOML / LEMPTY, LSUB C C LOCAL VARIABLES AND PARAMETERS C CHARACTER*1 C LOGICAL LEOL, LSUBL EXTERNAL MPEOL, MPMAC, MMPOPC C C DETERMINE WHAT FOLLOWS THE SUBSTITUTION PREFIX CHARACTER C LEOL = .FALSE. CALL MMPOPC (C, 2, CTOP, LEMPTY) IF (CEOL .EQ. CTOP) GO TO 10 IF (CEOR .EQ. CTOP) GO TO 20 IF (CONC .EQ. CTOP) GO TO 30 IF (.NOT. (LSUB .AND. LSUBL)) GO TO 999 IF (CSUB .EQ. CTOP) GO TO 40 GO TO 50 C C PROCESS AN END-OF-LINE MARKER C 10 CONTINUE CALL MPEOL LEOL = .TRUE. GO TO 999 C C PROCESS AN END-OF-RECORD MARKER C 20 CONTINUE CALL MMPOPC (C, 3, CTOP, LEMPTY) ICB2 = ICB2 - 2 GO TO 999 C C PROCESS A CONTINUATION CHARACTER C 30 CONTINUE CALL MMPOPC (C, 2, CTOP, LEMPTY) CALL MMPOPC (C, 2, CTOP, LEMPTY) CALL MMPOPC (C, 2, CTOP, LEMPTY) ICB2 = ICB2 - 4 GO TO 999 C C PROCESS AN EMBEDDED SUBSTITUTION PREFIX CHARACTER C 40 CONTINUE CALL MMPOPC (C, 2, CTOP, LEMPTY) ICB2 = ICB2 - 1 GO TO 999 C C A LIST OR MACRO SUBSTITUTION HAS BEEN ENCOUNTERED C 50 CONTINUE CALL MPMAC C 999 CONTINUE RETURN END SUBROUTINE TPAPPE C C----------------------------------------------------------------------- C C FAMILY C ------ C TEMPLATE PROCESSOR C C PURPOSE C ------- C TO PROCESS APPEND DIRECTIVES C C----------------------------------------------------------------------- C C GLOBAL CONSTANTS C CHARACTER*1 CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 COMMON / GLCOMC / CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 C C INPUT / OUTPUT CONTROL INTERFACE C CHARACTER*1 CBUFFR(2000) LOGICAL LBREAK, LFORT, LISTI, LISTO INTEGER ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOMC / CBUFFR COMMON / IOCOMI / ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOML / LBREAK, LFORT, LISTI, LISTO C C MEMORY MANAGER INTERFACE C CHARACTER*1 CSTORE(20000) INTEGER IHASH(601), ISTORE(6000) INTEGER ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS COMMON / MMCOMC / CSTORE COMMON / MMCOMH / IHASH COMMON / MMCOMS / ISTORE COMMON / MMCOMI / ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS C C MACRO PROCESSOR INTERFACE C CHARACTER*1 CDIV, CEOL, CEOR, CONC, CSUB, A CTOP LOGICAL LEMPTY, LSUB COMMON / MPCOMC / CDIV, CEOL, CEOR, CONC, CSUB, A CTOP COMMON / MPCOML / LEMPTY, LSUB C C TEMPLATE PROCESSOR INTERFACE C CHARACTER*1 CDIR, CSTAR INTEGER ICBP1(4), ICBP2(4) INTEGER ITOPDO, IARGS, INESTD, INESTF LOGICAL LCOL1, LDIRL, LEND, LINITM, L1TRIP COMMON / TPCOMC / CDIR, CSTAR COMMON / TPCOMI / ICBP1, ITOPDO, IARGS, ICBP2, INESTD, B INESTF COMMON / TPCOML / LCOL1, LDIRL, LEND, LINITM, L1TRIP C C LOCAL VARIABLES AND PARAMETERS C CHARACTER*1 C(15) INTEGER ID(7), IK(3) INTEGER IKYDIM, ICKDIM, IDSDIM LOGICAL LERROR EXTERNAL TPSYNT, TPRDBL, MMAPPV, IOERRM SAVE IKYDIM, IK, ICKDIM, C, IDSDIM, ID DATA A IKYDIM, ICKDIM, B IK(1), C IK(2), D IK(3) E / 3, 15, F 6, G 6, H 3 / DATA B C(1), C(2), C(3), C(4), C(5), C(6), C C(7), C(8), C(9), C(10), C(11), C(12), D C(13), C(14), C(15) E / F 'A', 'P', 'P', 'E', 'N', 'D', G 'E', 'N', 'D', 'A', 'P', 'P', H 'E', 'N', 'D' / DATA A IDSDIM, B ID(1), ID(2), ID(3), ID(4), ID(5), ID(6), ID(7) C / 7, D 1, 5, -3, 6, 6, 2, 7 / C C CHECK SYNTAX C CALL TPSYNT (ID, IDSDIM, .FALSE., LERROR) IF (LERROR) GO TO 999 IF (IARGS .EQ. 2) GO TO 10 C C PROCESS A MULTI-LINE APPEND STATEMENT C ICBP1(2) = ICBEOL + 1 C C READ A BLOCK; UNTIL *ENDAPP C CALL TPRDBL (IK, IKYDIM, C, ICKDIM, ID, IDSDIM, A .TRUE., .FALSE., .TRUE., LERROR) IF (LEND) GO TO 20 IF (LERROR) GO TO 999 ICBP2(2) = ICB0 - 1 C C APPEND THE VALUE C 10 CONTINUE CALL MMAPPV (CBUFFR, ICBP1(1), ICBP2(1), A CBUFFR, ICBP1(2), ICBP2(2)) GO TO 999 C 20 CONTINUE CALL IOERRM (.FALSE., A '('' ******** TPAPPE - APPEND HAS NO MATCHING ENDAPP'')') C 999 CONTINUE RETURN END SUBROUTINE TPCHKD C C----------------------------------------------------------------------- C C FAMILY C ------ C TEMPLATE PROCESSOR C C PURPOSE C ------- C TO DETERMINE IF A LINE CONTAINS A DIRECTIVE C C----------------------------------------------------------------------- C C GLOBAL CONSTANTS C CHARACTER*1 CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 COMMON / GLCOMC / CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 C C INPUT / OUTPUT CONTROL INTERFACE C CHARACTER*1 CBUFFR(2000) LOGICAL LBREAK, LFORT, LISTI, LISTO INTEGER ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOMC / CBUFFR COMMON / IOCOMI / ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOML / LBREAK, LFORT, LISTI, LISTO C C MEMORY MANAGER INTERFACE C CHARACTER*1 CSTORE(20000) INTEGER IHASH(601), ISTORE(6000) INTEGER ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS COMMON / MMCOMC / CSTORE COMMON / MMCOMH / IHASH COMMON / MMCOMS / ISTORE COMMON / MMCOMI / ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS C C MACRO PROCESSOR INTERFACE C CHARACTER*1 CDIV, CEOL, CEOR, CONC, CSUB, A CTOP LOGICAL LEMPTY, LSUB COMMON / MPCOMC / CDIV, CEOL, CEOR, CONC, CSUB, A CTOP COMMON / MPCOML / LEMPTY, LSUB C C TEMPLATE PROCESSOR INTERFACE C CHARACTER*1 CDIR, CSTAR INTEGER ICBP1(4), ICBP2(4) INTEGER ITOPDO, IARGS, INESTD, INESTF LOGICAL LCOL1, LDIRL, LEND, LINITM, L1TRIP COMMON / TPCOMC / CDIR, CSTAR COMMON / TPCOMI / ICBP1, ITOPDO, IARGS, ICBP2, INESTD, B INESTF COMMON / TPCOML / LCOL1, LDIRL, LEND, LINITM, L1TRIP C C LOCAL VARIABLES AND PARAMETERS C LOGICAL LEOL EXTERNAL UTRDBL C LDIRL = .FALSE. IF (ICB1 .GT. ICB2) GO TO 999 IF (CBUFFR(ICB1) .EQ. CDIR) GO TO 10 IF (LCOL1) GO TO 999 CALL UTRDBL (CBUFFR, ICB1, ICB2, LEOL) IF (LEOL) GO TO 999 IF (CBUFFR(ICB1) .NE. CDIR) GO TO 999 C 10 CONTINUE ICB1 = ICB1 + 1 LDIRL = .TRUE. C 999 CONTINUE RETURN END SUBROUTINE TPCOMM C C----------------------------------------------------------------------- C C FAMILY C ------ C TEMPLATE PROCESSOR C C PURPOSE C ------- C TO PROCESS COMMENT DIRECTIVES C C----------------------------------------------------------------------- C C GLOBAL CONSTANTS C CHARACTER*1 CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 COMMON / GLCOMC / CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 C C INPUT / OUTPUT CONTROL INTERFACE C CHARACTER*1 CBUFFR(2000) LOGICAL LBREAK, LFORT, LISTI, LISTO INTEGER ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOMC / CBUFFR COMMON / IOCOMI / ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOML / LBREAK, LFORT, LISTI, LISTO C C MEMORY MANAGER INTERFACE C CHARACTER*1 CSTORE(20000) INTEGER IHASH(601), ISTORE(6000) INTEGER ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS COMMON / MMCOMC / CSTORE COMMON / MMCOMH / IHASH COMMON / MMCOMS / ISTORE COMMON / MMCOMI / ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS C C MACRO PROCESSOR INTERFACE C CHARACTER*1 CDIV, CEOL, CEOR, CONC, CSUB, A CTOP LOGICAL LEMPTY, LSUB COMMON / MPCOMC / CDIV, CEOL, CEOR, CONC, CSUB, A CTOP COMMON / MPCOML / LEMPTY, LSUB C C TEMPLATE PROCESSOR INTERFACE C CHARACTER*1 CDIR, CSTAR INTEGER ICBP1(4), ICBP2(4) INTEGER ITOPDO, IARGS, INESTD, INESTF LOGICAL LCOL1, LDIRL, LEND, LINITM, L1TRIP COMMON / TPCOMC / CDIR, CSTAR COMMON / TPCOMI / ICBP1, ITOPDO, IARGS, ICBP2, INESTD, B INESTF COMMON / TPCOML / LCOL1, LDIRL, LEND, LINITM, L1TRIP C C LOCAL VARIABLES AND PARAMETERS C CHARACTER*1 C(16) INTEGER ID(1), IK(3) INTEGER IKYDIM, ICKDIM, IDSDIM LOGICAL LERROR EXTERNAL TPSYNT, TPRDBL, IOERRM SAVE IKYDIM, IK, ICKDIM, C, IDSDIM, ID DATA IDSDIM, ID(1) / 1, 7 / DATA A IKYDIM, ICKDIM, B IK(1), C IK(2), D IK(3) E / 3, 16, F 7, G 6, H 3 / DATA B C(1), C(2), C(3), C(4), C(5), C(6), C(7), C C(8), C(9), C(10), C(11), C(12), C(13), D C(14), C(15), C(16) E / F 'C', 'O', 'M', 'M', 'E', 'N', 'T', G 'E', 'N', 'D', 'C', 'O', 'M', H 'E', 'N', 'D' / C C CHECK SYNTAX C CALL TPSYNT (ID, IDSDIM, .FALSE., LERROR) IF (LERROR) GO TO 999 C C READ A BLOCK; UNTIL *ENDCOM C CALL TPRDBL (IK, IKYDIM, C, ICKDIM, ID, IDSDIM, A .FALSE., .TRUE., .FALSE., LERROR) IF (.NOT. LEND) GO TO 999 C C AN -END- HAS POSSIBLY BEEN ENCOUNTERED C CALL IOERRM (.FALSE., A '('' ******** TPCOMM - COMMENT HAS NO MATCHING ENDCOM'')') C 999 CONTINUE RETURN END SUBROUTINE TPDELE C C----------------------------------------------------------------------- C C FAMILY C ------ C TEMPLATE PROCESSOR C C PURPOSE C ------- C TO PROCESS DELETE DIRECTIVES C C----------------------------------------------------------------------- C C GLOBAL CONSTANTS C CHARACTER*1 CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 COMMON / GLCOMC / CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 C C INPUT / OUTPUT CONTROL INTERFACE C CHARACTER*1 CBUFFR(2000) LOGICAL LBREAK, LFORT, LISTI, LISTO INTEGER ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOMC / CBUFFR COMMON / IOCOMI / ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOML / LBREAK, LFORT, LISTI, LISTO C C MEMORY MANAGER INTERFACE C CHARACTER*1 CSTORE(20000) INTEGER IHASH(601), ISTORE(6000) INTEGER ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS COMMON / MMCOMC / CSTORE COMMON / MMCOMH / IHASH COMMON / MMCOMS / ISTORE COMMON / MMCOMI / ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS C C MACRO PROCESSOR INTERFACE C CHARACTER*1 CDIV, CEOL, CEOR, CONC, CSUB, A CTOP LOGICAL LEMPTY, LSUB COMMON / MPCOMC / CDIV, CEOL, CEOR, CONC, CSUB, A CTOP COMMON / MPCOML / LEMPTY, LSUB C C TEMPLATE PROCESSOR INTERFACE C CHARACTER*1 CDIR, CSTAR INTEGER ICBP1(4), ICBP2(4) INTEGER ITOPDO, IARGS, INESTD, INESTF LOGICAL LCOL1, LDIRL, LEND, LINITM, L1TRIP COMMON / TPCOMC / CDIR, CSTAR COMMON / TPCOMI / ICBP1, ITOPDO, IARGS, ICBP2, INESTD, B INESTF COMMON / TPCOML / LCOL1, LDIRL, LEND, LINITM, L1TRIP C C LOCAL VARIABLES AND PARAMETERS C INTEGER ID(4) INTEGER IDSDIM LOGICAL LERROR, LFOUND EXTERNAL TPSYNT, MMDELV SAVE IDSDIM, ID DATA IDSDIM, ID(1), ID(2), ID(3), ID(4) A / 4, 1, 5, 2, 7 / C C CHECK SYNTAX C CALL TPSYNT (ID, IDSDIM, .FALSE., LERROR) IF (LERROR) GO TO 999 C C DELETE THE VARIABLE C CALL MMDELV (CBUFFR, ICBP1(1), ICBP2(1), LFOUND) C 999 CONTINUE RETURN END SUBROUTINE TPDO C C----------------------------------------------------------------------- C C FAMILY C ------ C TEMPLATE PROCESSOR C C PURPOSE C ------- C TO PROCESS DO DIRECTIVES C C----------------------------------------------------------------------- C C GLOBAL CONSTANTS C CHARACTER*1 CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 COMMON / GLCOMC / CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 C C INPUT / OUTPUT CONTROL INTERFACE C CHARACTER*1 CBUFFR(2000) LOGICAL LBREAK, LFORT, LISTI, LISTO INTEGER ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOMC / CBUFFR COMMON / IOCOMI / ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOML / LBREAK, LFORT, LISTI, LISTO C C MEMORY MANAGER INTERFACE C CHARACTER*1 CSTORE(20000) INTEGER IHASH(601), ISTORE(6000) INTEGER ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS COMMON / MMCOMC / CSTORE COMMON / MMCOMH / IHASH COMMON / MMCOMS / ISTORE COMMON / MMCOMI / ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS C C MACRO PROCESSOR INTERFACE C CHARACTER*1 CDIV, CEOL, CEOR, CONC, CSUB, A CTOP LOGICAL LEMPTY, LSUB COMMON / MPCOMC / CDIV, CEOL, CEOR, CONC, CSUB, A CTOP COMMON / MPCOML / LEMPTY, LSUB C C TEMPLATE PROCESSOR INTERFACE C CHARACTER*1 CDIR, CSTAR INTEGER ICBP1(4), ICBP2(4) INTEGER ITOPDO, IARGS, INESTD, INESTF LOGICAL LCOL1, LDIRL, LEND, LINITM, L1TRIP COMMON / TPCOMC / CDIR, CSTAR COMMON / TPCOMI / ICBP1, ITOPDO, IARGS, ICBP2, INESTD, B INESTF COMMON / TPCOML / LCOL1, LDIRL, LEND, LINITM, L1TRIP C C LOCAL VARIABLES AND PARAMETERS C CHARACTER*1 C(10), CD(1), CIN(1) INTEGER ID(11), IK(3) LOGICAL LERROR, LFOUND INTEGER IKYDIM, ICKDIM, ICN1, ICN2, I1, I2, I3, ITEMP, A ICV1 INTEGER ICDDIM, ICIDIM, IDSDIM EXTERNAL TPSYNT, UTBLDN, MMPUTV, UTCVCI, TPRDBL, A MMNEWI, MMPSHV, MMSETP, IOERRM SAVE ICDDIM, CD, ICIDIM, CIN SAVE IKYDIM, IK, ICKDIM, C, IDSDIM, ID DATA ICDDIM / 1 / DATA CD(1) / 'D' / DATA ICIDIM / 1 / DATA CIN(1) / 'I' / DATA A IKYDIM,ICKDIM,IK(1),IK(2),IK(3) B / 3, 10, 2, 5, 3 / DATA A C(1), C(2), B C(3), C(4), C(5), C(6), C(7), C C(8), C(9), C(10) D / 'D', 'O', E 'E', 'N', 'D', 'D', 'O', F 'E', 'N', 'D' / DATA A IDSDIM, B ID(1), ID(2), ID(3), ID(4), ID(5), C ID(6), ID(7), ID(8), ID(9), ID(10), ID(11) D / 11, E 1, 5, 4, 6, 3, F 6, -3, 10, 6, 2, 7 / C C CHECK SYNTAX C CALL TPSYNT (ID, IDSDIM, .FALSE., LERROR) IF (LERROR) GO TO 999 INESTD = INESTD + 1 ICN1 = ICBEND + 1 C C GET LOOP INDEX AND LOOP PARAMETERS C CALL UTBLDN (CSTAR, CIN, 1, ICIDIM, INESTD, A CBUFFR, ICN1, ICN2, ICBDIM, LERROR) ICBEND = ICN2 CALL MMPUTV (CBUFFR, ICN1, ICN2, A CBUFFR, ICBP1(1), ICBP2(1)) CALL MMPUTV (CBUFFR, ICBP1(1), ICBP2(1), A CBUFFR, ICBP1(2), ICBP2(2)) CALL UTCVCI (CBUFFR, ICBP1(2), ICBP2(2), I1, LERROR) CALL UTCVCI (CBUFFR, ICBP1(3), ICBP2(3), I2, LERROR) I3 = 1 IF (IARGS .EQ. 4) A CALL UTCVCI (CBUFFR, ICBP1(4), ICBP2(4), I3, LERROR) IF (L1TRIP .OR. ((I2-I1)*ISIGN(1,I3) .GE. 0)) GO TO 10 CALL TPRDBL (IK, IKYDIM, C, ICKDIM, ID, IDSDIM, A .FALSE., .TRUE., .FALSE., LERROR) IF (LEND) GO TO 30 INESTD = INESTD - 1 GO TO 999 C 10 CONTINUE CALL MMNEWI (ITEMP) ISTORE(ITEMP) = I2 ISTORE(ITEMP+1) = I3 ISTORE(ITEMP+2) = ITOPDO ITOPDO = ITEMP IF (INESTD .GT. 1) GO TO 20 CALL UTBLDN (CSTAR, CD, 1, ICDDIM, -1, A CBUFFR, 1, ICN2, ICBDIM, LERROR) ICBEOL = ICN2 ICV1 = ICN2 + 1 C C READ A BLOCK UNTIL *ENDDO. PUSH CONTENTS OF DO RANGE C ONTO STACK. C CALL TPRDBL (IK, IKYDIM, C, ICKDIM, ID, IDSDIM, A .FALSE., .FALSE., .FALSE., LERROR) IF (LEND) GO TO 30 CALL MMPUTV (CBUFFR, 1, ICN2, CBUFFR, ICV1, ICBEOL) CALL MMPSHV (CBUFFR, 1, ICN2, 1, LEMPTY, LFOUND) C 20 CONTINUE CALL UTBLDN (CSTAR, CD, 1, ICDDIM, INESTD, A CBUFFR, 1, ICN2, ICBDIM, LERROR) CALL MMSETP (CBUFFR, 1, ICN2) GO TO 999 C C WARNING - MATCHING ENDDO NOT FOUND C 30 CONTINUE CALL IOERRM (.FALSE., A '('' ******** TPDO - DO HAS NO MATCHING ENDDO'')') C 999 CONTINUE RETURN END SUBROUTINE TPELSE C C----------------------------------------------------------------------- C C FAMILY C ------ C TEMPLATE PROCESSOR C C PURPOSE C ------- C TO PROCESS ELSE DIRECTIVES C C----------------------------------------------------------------------- C C GLOBAL CONSTANTS C CHARACTER*1 CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 COMMON / GLCOMC / CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 C C INPUT / OUTPUT CONTROL INTERFACE C CHARACTER*1 CBUFFR(2000) LOGICAL LBREAK, LFORT, LISTI, LISTO INTEGER ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOMC / CBUFFR COMMON / IOCOMI / ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOML / LBREAK, LFORT, LISTI, LISTO C C MEMORY MANAGER INTERFACE C CHARACTER*1 CSTORE(20000) INTEGER IHASH(601), ISTORE(6000) INTEGER ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS COMMON / MMCOMC / CSTORE COMMON / MMCOMH / IHASH COMMON / MMCOMS / ISTORE COMMON / MMCOMI / ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS C C MACRO PROCESSOR INTERFACE C CHARACTER*1 CDIV, CEOL, CEOR, CONC, CSUB, A CTOP LOGICAL LEMPTY, LSUB COMMON / MPCOMC / CDIV, CEOL, CEOR, CONC, CSUB, A CTOP COMMON / MPCOML / LEMPTY, LSUB C C TEMPLATE PROCESSOR INTERFACE C CHARACTER*1 CDIR, CSTAR INTEGER ICBP1(4), ICBP2(4) INTEGER ITOPDO, IARGS, INESTD, INESTF LOGICAL LCOL1, LDIRL, LEND, LINITM, L1TRIP COMMON / TPCOMC / CDIR, CSTAR COMMON / TPCOMI / ICBP1, ITOPDO, IARGS, ICBP2, INESTD, B INESTF COMMON / TPCOML / LCOL1, LDIRL, LEND, LINITM, L1TRIP C C LOCAL VARIABLES AND PARAMETERS C CHARACTER*1 C(10) INTEGER ID(1), IDIF(4), IK(3) LOGICAL LERROR INTEGER IDSDIM, IDSDIF, IKYDIM, ICKDIM EXTERNAL TPSYNT, TPRDBL, IOERRM SAVE IKYDIM, IK, ICKDIM, C, IDSDIM, ID, IDSDIF, IDIF DATA IDSDIM, ID(1) / 1, 7 / DATA A IDSDIF, B IDIF(1), IDIF(2), IDIF(3), IDIF(4) C / 4, D 1, 6, 2, 8 / DATA A IKYDIM, ICKDIM, IK(1), IK(2), IK(3) B / 3, 10, 2, 5, 3 / DATA A C(1), C(2), B C(3), C(4), C(5), C(6), C(7), C C(8), C(9), C(10) / D 'I', 'F', E 'E', 'N', 'D', 'I', 'F', F 'E', 'N', 'D' / C C CHECK SYNTAX C CALL TPSYNT (ID, IDSDIM, .FALSE., LERROR) IF (LERROR) GO TO 999 INESTF = INESTF - 1 CALL TPRDBL (IK, IKYDIM, C, ICKDIM, IDIF, IDSDIF, A .TRUE., .TRUE., .FALSE., LERROR) IF (.NOT. LEND) GO TO 999 C C AN -END- HAS BEEN ENCOUNTERED C CALL IOERRM (.FALSE., A '('' ******** TPELSE - IF HAS NO MATCHING ENDIF'')') C 999 CONTINUE RETURN END SUBROUTINE TPENDO C C----------------------------------------------------------------------- C C FAMILY C ------ C TEMPLATE PROCESSOR C C PURPOSE C ------- C TO PROCESS ENDDO DIRECTIVES C C----------------------------------------------------------------------- C C GLOBAL CONSTANTS C CHARACTER*1 CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 COMMON / GLCOMC / CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 C C INPUT / OUTPUT CONTROL INTERFACE C CHARACTER*1 CBUFFR(2000) LOGICAL LBREAK, LFORT, LISTI, LISTO INTEGER ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOMC / CBUFFR COMMON / IOCOMI / ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOML / LBREAK, LFORT, LISTI, LISTO C C MEMORY MANAGER INTERFACE C CHARACTER*1 CSTORE(20000) INTEGER IHASH(601), ISTORE(6000) INTEGER ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS COMMON / MMCOMC / CSTORE COMMON / MMCOMH / IHASH COMMON / MMCOMS / ISTORE COMMON / MMCOMI / ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS C C MACRO PROCESSOR INTERFACE C CHARACTER*1 CDIV, CEOL, CEOR, CONC, CSUB, A CTOP LOGICAL LEMPTY, LSUB COMMON / MPCOMC / CDIV, CEOL, CEOR, CONC, CSUB, A CTOP COMMON / MPCOML / LEMPTY, LSUB C C TEMPLATE PROCESSOR INTERFACE C CHARACTER*1 CDIR, CSTAR INTEGER ICBP1(4), ICBP2(4) INTEGER ITOPDO, IARGS, INESTD, INESTF LOGICAL LCOL1, LDIRL, LEND, LINITM, L1TRIP COMMON / TPCOMC / CDIR, CSTAR COMMON / TPCOMI / ICBP1, ITOPDO, IARGS, ICBP2, INESTD, B INESTF COMMON / TPCOML / LCOL1, LDIRL, LEND, LINITM, L1TRIP C C LOCAL VARIABLES C CHARACTER*1 CD(1), CIN(1) INTEGER ID(1) INTEGER ICDDIM, ICIDIM, IDSDIM, ICN2, ICV2, ICV1, A I, I2, I3, ITEMP LOGICAL LERROR, LFOUND EXTERNAL TPSYNT, UTBLDN, MMGETV, UTCVCI, UTCVIC, A MMPUTV, MMPOPV, MMPSHV, MMRETI, IOERRM SAVE ICDDIM, CD, ICIDIM, CIN, IDSDIM, ID DATA ICDDIM / 1 / DATA CD(1) / 'D' / DATA ICIDIM / 1 / DATA CIN(1) / 'I' / DATA IDSDIM, ID(1) / 1, 7 / C C CHECK SYNTAX C CALL TPSYNT (ID, IDSDIM, .FALSE., LERROR) IF (LERROR) GO TO 999 IF (INESTD .LE. 0) GO TO 20 CALL UTBLDN (CSTAR, CIN, 1, ICIDIM, INESTD, A CBUFFR, 1, ICN2, ICBDIM, LERROR) CALL MMGETV (CBUFFR, 1, ICN2, CBUFFR, 1, ICV2, ICBDIM, LFOUND) ICN2 = ICV2 ICV1 = ICV2 + 1 CALL MMGETV (CBUFFR, 1, ICN2, A CBUFFR, ICV1, ICV2, ICBDIM, LFOUND) CALL UTCVCI (CBUFFR, ICV1, ICV2, I, LERROR) I2 = ISTORE(ITOPDO) I3 = ISTORE(ITOPDO+1) I = I + I3 IF ((I2-I)*ISIGN(1,I3) .LT. 0) GO TO 10 CALL UTCVIC (CBUFFR, ICV1, ICV2, ICBDIM, I, LERROR) CALL MMPUTV (CBUFFR, 1, ICN2, CBUFFR, ICV1, ICV2) CALL UTBLDN (CSTAR, CD, 1, ICDDIM, INESTD, A CBUFFR, 1, ICN2, ICBDIM, LERROR) IF (INESTD .GT. 1) CALL MMPOPV (LEMPTY) CALL MMPSHV (CBUFFR, 1, ICN2, 2, LEMPTY, LFOUND) GO TO 999 C 10 CONTINUE INESTD = INESTD - 1 ITEMP = ITOPDO ITOPDO = ISTORE(ITOPDO+2) CALL MMRETI (ITEMP) GO TO 999 C 20 CONTINUE CALL IOERRM (.FALSE., A '('' ******** TPENDO - MISPLACED ENDDO'')') C C 999 CONTINUE RETURN END SUBROUTINE TPENDF C C----------------------------------------------------------------------- C C FAMILY C ------ C TEMPLATE PROCESSOR C C PURPOSE C ------- C TO PROCESS ENDIF DIRECTIVES C C----------------------------------------------------------------------- C C GLOBAL CONSTANTS C CHARACTER*1 CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 COMMON / GLCOMC / CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 C C INPUT / OUTPUT CONTROL INTERFACE C CHARACTER*1 CBUFFR(2000) LOGICAL LBREAK, LFORT, LISTI, LISTO INTEGER ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOMC / CBUFFR COMMON / IOCOMI / ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOML / LBREAK, LFORT, LISTI, LISTO C C MEMORY MANAGER INTERFACE C CHARACTER*1 CSTORE(20000) INTEGER IHASH(601), ISTORE(6000) INTEGER ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS COMMON / MMCOMC / CSTORE COMMON / MMCOMH / IHASH COMMON / MMCOMS / ISTORE COMMON / MMCOMI / ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS C C MACRO PROCESSOR INTERFACE C CHARACTER*1 CDIV, CEOL, CEOR, CONC, CSUB, A CTOP LOGICAL LEMPTY, LSUB COMMON / MPCOMC / CDIV, CEOL, CEOR, CONC, CSUB, A CTOP COMMON / MPCOML / LEMPTY, LSUB C C TEMPLATE PROCESSOR INTERFACE C CHARACTER*1 CDIR, CSTAR INTEGER ICBP1(4), ICBP2(4) INTEGER ITOPDO, IARGS, INESTD, INESTF LOGICAL LCOL1, LDIRL, LEND, LINITM, L1TRIP COMMON / TPCOMC / CDIR, CSTAR COMMON / TPCOMI / ICBP1, ITOPDO, IARGS, ICBP2, INESTD, B INESTF COMMON / TPCOML / LCOL1, LDIRL, LEND, LINITM, L1TRIP C C LOCAL VARIABLES C INTEGER ID(1) LOGICAL LERROR INTEGER IDSDIM EXTERNAL TPSYNT, IOERRM SAVE IDSDIM, ID DATA IDSDIM, ID(1) / 1, 7 / C C CHECK SYNTAX C CALL TPSYNT (ID, IDSDIM, .FALSE., LERROR) IF (LERROR) GO TO 999 IF (INESTF .LE. 0) GO TO 10 INESTF = INESTF - 1 GO TO 999 C 10 CONTINUE CALL IOERRM (.FALSE., A '('' ******** TPENDF - MISPLACED ENDIF'')') C 999 CONTINUE RETURN END SUBROUTINE TPEVAL C C----------------------------------------------------------------------- C C FAMILY C ------ C TEMPLATE PROCESSOR C C PURPOSE C ------- C TO CALL ROUTINES TO PROCESS DIRECTIVES C C----------------------------------------------------------------------- C C GLOBAL CONSTANTS C CHARACTER*1 CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 COMMON / GLCOMC / CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 C C INPUT / OUTPUT CONTROL INTERFACE C CHARACTER*1 CBUFFR(2000) LOGICAL LBREAK, LFORT, LISTI, LISTO INTEGER ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOMC / CBUFFR COMMON / IOCOMI / ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOML / LBREAK, LFORT, LISTI, LISTO C C MEMORY MANAGER INTERFACE C CHARACTER*1 CSTORE(20000) INTEGER IHASH(601), ISTORE(6000) INTEGER ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS COMMON / MMCOMC / CSTORE COMMON / MMCOMH / IHASH COMMON / MMCOMS / ISTORE COMMON / MMCOMI / ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS C C MACRO PROCESSOR INTERFACE C CHARACTER*1 CDIV, CEOL, CEOR, CONC, CSUB, A CTOP LOGICAL LEMPTY, LSUB COMMON / MPCOMC / CDIV, CEOL, CEOR, CONC, CSUB, A CTOP COMMON / MPCOML / LEMPTY, LSUB C C TEMPLATE PROCESSOR INTERFACE C CHARACTER*1 CDIR, CSTAR INTEGER ICBP1(4), ICBP2(4) INTEGER ITOPDO, IARGS, INESTD, INESTF LOGICAL LCOL1, LDIRL, LEND, LINITM, L1TRIP COMMON / TPCOMC / CDIR, CSTAR COMMON / TPCOMI / ICBP1, ITOPDO, IARGS, ICBP2, INESTD, B INESTF COMMON / TPCOML / LCOL1, LDIRL, LEND, LINITM, L1TRIP C C LOCAL VARIABLES C CHARACTER*1 C(79) INTEGER IK(16) INTEGER IKYDIM, ICKDIM, I EXTERNAL TPCHKD, UTRDKY, TPAPPE, TPCOMM, TPDELE, TPDO, A TPELSE, TPENDO, TPENDF, TPIF, TPINCL, TPOPT, B TPRSET, TPSET, IOERRM SAVE IKYDIM, IK, ICKDIM, C DATA A IKYDIM, ICKDIM, B IK(1), C IK(2), D IK(3), E IK(4), F IK(5), G IK(6), H IK(7), I IK(8) J / 16, 79, K 6, L 7, M 6, N 2, O 4, P 5, Q 5, R 2 / DATA B C(1), C(2), C(3), C(4), C(5), C(6), C C(7), C(8), C(9), C(10), C(11), C(12), C(13), D C(14), C(15), C(16), C(17), C(18), C(19), E C(20), C(21), F C(22), C(23), C(24), C(25), G C(26), C(27), C(28), C(29), C(30), H C(31), C(32), C(33), C(34), C(35), I C(36), C(37) K / 'A', 'P', 'P', 'E', 'N', 'D', L 'C', 'O', 'M', 'M', 'E', 'N', 'T', M 'D', 'E', 'L', 'E', 'T', 'E', N 'D', 'O', O 'E', 'L', 'S', 'E', P 'E', 'N', 'D', 'D', 'O', Q 'E', 'N', 'D', 'I', 'F', R 'I', 'F' / DATA A IK(9), B IK(10), C IK(11), D IK(12), E IK(13), F IK(14), G IK(15), H IK(16) I / 7, J 6, K 5, L 3, M 6, N 6, O 6, P 3 / DATA A C(38), C(39), C(40), C(41), C(42), C(43), C(44), B C(45), C(46), C(47), C(48), C(49), C(50), C C(51), C(52), C(53), C(54), C(55), D C(56), C(57), C(58), E C(59), C(60), C(61), C(62), C(63), C(64), F C(65), C(66), C(67), C(68), C(69), C(70), G C(71), C(72), C(73), C(74), C(75), C(76), H C(77), C(78), C(79) I / 'I', 'N', 'C', 'L', 'U', 'D', 'E', J 'O', 'P', 'T', 'I', 'O', 'N', K 'R', 'E', 'S', 'E', 'T', L 'S', 'E', 'T', M 'E', 'N', 'D', 'A', 'P', 'P', N 'E', 'N', 'D', 'C', 'O', 'M', O 'E', 'N', 'D', 'S', 'E', 'T', P 'E', 'N', 'D' / C ICB1 = ICB0 ICB2 = ICB3 CALL TPCHKD IF (.NOT. LDIRL) GO TO 999 C C A DIRECTIVE LINE HAS BEEN FOUND. CHECK WHICH ONE IT IS C CALL UTRDKY (CBUFFR, ICB1, ICB2, IK, IKYDIM, C, ICKDIM, I) GO TO (10, 20, 30, 40, 50, 60, 70, 80, 90, A 100, 110, 120, 130, 140, 150, 160, 170), I C C PROCESS -APPEND- C 10 CONTINUE CALL TPAPPE GO TO 999 C C PROCESS -COMMENT- C 20 CONTINUE CALL TPCOMM GO TO 999 C C PROCESS -DELETE- C 30 CONTINUE CALL TPDELE GO TO 999 C C PROCESS -DO- C 40 CONTINUE CALL TPDO GO TO 999 C C PROCESS -ELSE- C 50 CONTINUE CALL TPELSE GO TO 999 C C PROCESS -ENDDO- C 60 CONTINUE CALL TPENDO GO TO 999 C C PROCESS -ENDIF- C 70 CONTINUE CALL TPENDF GO TO 999 C C PROCESS -IF- C 80 CONTINUE CALL TPIF GO TO 999 C C PROCESS -INCLUDE- C 90 CONTINUE CALL TPINCL GO TO 999 C C PROCESS -OPTION- C 100 CONTINUE CALL TPOPT GO TO 999 C C PROCESS -RESET- C 110 CONTINUE CALL TPRSET GO TO 999 C C PROCESS -SET- C 120 CONTINUE CALL TPSET GO TO 999 C C PROCESS -ENDAPP- C 130 CONTINUE CALL IOERRM (.FALSE., A '('' ******** TPEVAL - MISPLACED ENDAPP'')') GO TO 999 C C PROCESS -ENDCOM- C 140 CONTINUE CALL IOERRM (.FALSE., A '('' ******** TPEVAL - MISPLACED ENDCOM'')') GO TO 999 C C PROCESS -ENDSET- C 150 CONTINUE CALL IOERRM (.FALSE., A '('' ******** TPEVAL - MISPLACED ENDSET'')') GO TO 999 C C PROCESS -END- C 160 CONTINUE LEND = .TRUE. GO TO 999 C C PROCESS UNRECOGNIZED DIRECTIVES C 170 CONTINUE CALL IOERRM (.FALSE., A '('' ******** TPEVAL - ILLEGAL OR MISSPELLED DIRECTIVE'')') C 999 CONTINUE RETURN END SUBROUTINE TPEXPR (ICV1, ICV2, LSCAN, LERROR) C C----------------------------------------------------------------------- C C FAMILY C ------ C TEMPLATE PROCESSOR C C PURPOSE C ------- C TO DETERMINE IF AN EXPRESSION IS VALID AND RETURN ITS VALUE. C CURRENTLY, EXPRESSIONS MAY CONSIST ONLY OF VARIABLES OR CONSTANTS. C C PARAMETERS C ---------- C ICV1 -I- INDEX INTO CBUFFR OF THE FIRST C CHARACTER IN THE EXPRESSION C ICV2 -I- INDEX OF THE LAST CHARACTER C LSCAN -I- IF TRUE, THEN VALIDATE (SCAN) BUT DO NOT EVALUATE C LERROR -O- TRUE IF THE EXPRESSION WAS INVALID C C----------------------------------------------------------------------- C C GLOBAL CONSTANTS C CHARACTER*1 CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 COMMON / GLCOMC / CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 C C INPUT / OUTPUT CONTROL INTERFACE C CHARACTER*1 CBUFFR(2000) LOGICAL LBREAK, LFORT, LISTI, LISTO INTEGER ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOMC / CBUFFR COMMON / IOCOMI / ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOML / LBREAK, LFORT, LISTI, LISTO C C MEMORY MANAGER INTERFACE C CHARACTER*1 CSTORE(20000) INTEGER IHASH(601), ISTORE(6000) INTEGER ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS COMMON / MMCOMC / CSTORE COMMON / MMCOMH / IHASH COMMON / MMCOMS / ISTORE COMMON / MMCOMI / ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS C C MACRO PROCESSOR INTERFACE C CHARACTER*1 CDIV, CEOL, CEOR, CONC, CSUB, A CTOP LOGICAL LEMPTY, LSUB COMMON / MPCOMC / CDIV, CEOL, CEOR, CONC, CSUB, A CTOP COMMON / MPCOML / LEMPTY, LSUB C C TEMPLATE PROCESSOR INTERFACE C CHARACTER*1 CDIR, CSTAR INTEGER ICBP1(4), ICBP2(4) INTEGER ITOPDO, IARGS, INESTD, INESTF LOGICAL LCOL1, LDIRL, LEND, LINITM, L1TRIP COMMON / TPCOMC / CDIR, CSTAR COMMON / TPCOMI / ICBP1, ITOPDO, IARGS, ICBP2, INESTD, B INESTF COMMON / TPCOML / LCOL1, LDIRL, LEND, LINITM, L1TRIP C C LOCAL VARIABLES AND PARAMETERS C INTEGER ICV1, ICV2 LOGICAL L, LERROR, LSCAN INTEGER ICN1, ICN2 EXTERNAL UTRDNA, MMGETV, UTRDNU, UTRDQS C IF (LLE(CA,CBUFFR(ICB1)) .AND. A LLE(CBUFFR(ICB1),CZ)) GO TO 10 IF (LLE(C0,CBUFFR(ICB1)) .AND. A LLE(CBUFFR(ICB1),C9)) GO TO 20 IF (CBUFFR(ICB1) .EQ. CMINUS) GO TO 20 IF (CBUFFR(ICB1) .EQ. CPLUS) GO TO 20 IF (CBUFFR(ICB1) .EQ. CQUOTE) GO TO 30 IF (CBUFFR(ICB1) .EQ. CPOINT) GO TO 40 LERROR = .TRUE. GO TO 999 C C PROCESS A NAME C 10 CONTINUE CALL UTRDNA (CBUFFR, ICB1, ICB2, ICN1, ICN2, LERROR) IF (LERROR) GO TO 999 IF (LSCAN) GO TO 999 ICV1 = ICBEND + 1 CALL MMGETV (CBUFFR, ICN1, ICN2, CBUFFR, ICV1, ICV2, ICBDIM, L) ICBEND = ICV2 LERROR = .NOT. L GO TO 999 C C PROCESS A NUMBER C 20 CONTINUE CALL UTRDNU (CBUFFR, ICB1, ICB2, ICV1, ICV2, LERROR) GO TO 999 C C PROCESS A QUOTED STRING C 30 CONTINUE CALL UTRDQS (CBUFFR, ICB1, ICB2, ICV1, ICV2, LERROR) GO TO 999 C C PROCESS A LOGICAL CONSTANT C 40 CONTINUE CALL UTRDQS (CBUFFR, ICB1, ICB2, ICV1, ICV2, LERROR) IF (LERROR) GO TO 999 ICV1 = ICV1 - 1 ICV2 = ICV2 + 1 C 999 CONTINUE RETURN END SUBROUTINE TPIF C C----------------------------------------------------------------------- C C FAMILY C ------ C TEMPLATE PROCESSOR C C PURPOSE C ------- C TO PROCESS IF DIRECTIVES C C----------------------------------------------------------------------- C C GLOBAL CONSTANTS C CHARACTER*1 CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 COMMON / GLCOMC / CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 C C INPUT / OUTPUT CONTROL INTERFACE C CHARACTER*1 CBUFFR(2000) LOGICAL LBREAK, LFORT, LISTI, LISTO INTEGER ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOMC / CBUFFR COMMON / IOCOMI / ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOML / LBREAK, LFORT, LISTI, LISTO C C MEMORY MANAGER INTERFACE C CHARACTER*1 CSTORE(20000) INTEGER IHASH(601), ISTORE(6000) INTEGER ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS COMMON / MMCOMC / CSTORE COMMON / MMCOMH / IHASH COMMON / MMCOMS / ISTORE COMMON / MMCOMI / ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS C C MACRO PROCESSOR INTERFACE C CHARACTER*1 CDIV, CEOL, CEOR, CONC, CSUB, A CTOP LOGICAL LEMPTY, LSUB COMMON / MPCOMC / CDIV, CEOL, CEOR, CONC, CSUB, A CTOP COMMON / MPCOML / LEMPTY, LSUB C C TEMPLATE PROCESSOR INTERFACE C CHARACTER*1 CDIR, CSTAR INTEGER ICBP1(4), ICBP2(4) INTEGER ITOPDO, IARGS, INESTD, INESTF LOGICAL LCOL1, LDIRL, LEND, LINITM, L1TRIP COMMON / TPCOMC / CDIR, CSTAR COMMON / TPCOMI / ICBP1, ITOPDO, IARGS, ICBP2, INESTD, B INESTF COMMON / TPCOML / LCOL1, LDIRL, LEND, LINITM, L1TRIP C C LOCAL VARIABLES AND PARAMETERS C CHARACTER*1 C(14), CN(2) INTEGER ID(7), IK(4) INTEGER ICNDIM, IKYDIM, ICKDIM, IDSDIM, LEN1, LEN2, A I1, I2, I, INEST LOGICAL LERROR, LFOUND, LVALUE EXTERNAL TPSYNT, UTCVCL, MMPUTV, MMPSHV, MPLINE, A TPCHKD, UTRDKY, IOERRM SAVE IKYDIM, IK, ICKDIM, C, ICNDIM, CN, IDSDIM, ID DATA ICNDIM / 2 / DATA CN(1), CN(2) / '*', 'F' / DATA A IKYDIM, ICKDIM, B IK(1), C IK(2), D IK(3), E IK(4) F / 4, 14, G 2, H 4, I 5, J 3 / DATA B C(1), C(2), C C(3), C(4), C(5), C(6), D C(7), C(8), C(9), C(10), C(11), E C(12), C(13), C(14) G / 'I', 'F', H 'E', 'L', 'S', 'E', I 'E', 'N', 'D', 'I', 'F', J 'E', 'N', 'D' / DATA IDSDIM, ID(1), ID(2), ID(3), ID(4), ID(5), ID(6), ID(7) A / 7, 1, 6, -4, 6, 6, 2, 8 / C C CHECK SYNTAX C CALL TPSYNT (ID, IDSDIM, .FALSE., LERROR) IF (LERROR) GO TO 999 IF ((IARGS .EQ. 3) .OR. A ((IARGS .EQ. 2) .AND. (ICBEOL.NE.ICBP2(2)))) GO TO 3 C C HAVE FOUND FORM: '*IF(L)' C CALL UTCVCL (CBUFFR, ICBP1(1), ICBP2(1), LVALUE, LERROR) IF (IARGS .EQ. 1) GO TO 10 GO TO 9 3 CONTINUE C C HAVE FOUND FORM: '*IF(EXP1=EXP2)' C LVALUE = .FALSE. LEN1 = ICBP2(1) - ICBP1(1) + 1 LEN2 = ICBP2(2) - ICBP1(2) + 1 IF (LEN1 .NE. LEN2) GO TO 8 I1 = ICBP1(1) I2 = ICBP1(2) DO 5 I = 1, LEN1 IF (CBUFFR(I1) .NE. CBUFFR(I2)) GO TO 8 I1 = I1 + 1 I2 = I2 + 1 5 CONTINUE LVALUE = .TRUE. 8 CONTINUE IF (IARGS .EQ. 2) GO TO 10 C C C PROCESS A ONE-LINE IF STATEMENT C 9 CONTINUE IF (.NOT. LVALUE) GO TO 999 CALL MMPUTV (CN, 1, ICNDIM, CBUFFR, ICBP1(IARGS), ICBP2(IARGS)) CALL MMPSHV (CN, 1, ICNDIM, 1, LEMPTY, LFOUND) GO TO 999 C C PROCESS A MULTI-LINE IF STATEMENT C 10 CONTINUE INESTF = INESTF + 1 IF (LVALUE) GO TO 999 INEST = INESTF C 20 CONTINUE CALL MPLINE (.FALSE.) CALL TPCHKD IF (.NOT. LDIRL) GO TO 20 CALL UTRDKY (CBUFFR, ICB1, ICB2, IK, IKYDIM, C, ICKDIM, I) GO TO (30, 40, 50, 60, 20), I C C AN -IF- HAS BEEN ENCOUNTERED C 30 CONTINUE CALL TPSYNT (ID, IDSDIM, .TRUE., LERROR) IF (IARGS .EQ. 1) INESTF = INESTF + 1 C C IF IARGS=2 AND ICB1 > ICB2, ASSUME C DIRECTIVE IS OF FORM '*IF(ARG1 = ARG2)' C IF ((IARGS .EQ. 2) .AND. (ICB1 .GT. ICB2)) INESTF = INESTF + 1 GO TO 20 C C AN -ELSE- HAS BEEN ENCOUNTERED C 40 CONTINUE IF (INESTF .LE. INEST) GO TO 999 GO TO 20 C C AN -ENDIF- HAS BEEN ENCOUNTERED C 50 CONTINUE INESTF = INESTF - 1 IF (INESTF .LT. INEST) GO TO 999 GO TO 20 C C AN -END- HAS POSSIBLY BEEN ENCOUNTERED C 60 CONTINUE LEND = ICB1 .GT. ICB2 IF (.NOT. LEND) GO TO 20 CALL IOERRM (.FALSE., A '('' ******** TPIF - IF HAS NO MATCHING ENDIF'')') C 999 CONTINUE RETURN END SUBROUTINE TPINCL C C----------------------------------------------------------------------- C C FAMILY C ------ C TEMPLATE PROCESSOR C C PURPOSE C ------- C TO PROCESS INCLUDE DIRECTIVES C C----------------------------------------------------------------------- C C GLOBAL CONSTANTS C CHARACTER*1 CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 COMMON / GLCOMC / CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 C C INPUT / OUTPUT CONTROL INTERFACE C CHARACTER*1 CBUFFR(2000) LOGICAL LBREAK, LFORT, LISTI, LISTO INTEGER ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOMC / CBUFFR COMMON / IOCOMI / ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOML / LBREAK, LFORT, LISTI, LISTO C C MEMORY MANAGER INTERFACE C CHARACTER*1 CSTORE(20000) INTEGER IHASH(601), ISTORE(6000) INTEGER ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS COMMON / MMCOMC / CSTORE COMMON / MMCOMH / IHASH COMMON / MMCOMS / ISTORE COMMON / MMCOMI / ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS C C MACRO PROCESSOR INTERFACE C CHARACTER*1 CDIV, CEOL, CEOR, CONC, CSUB, A CTOP LOGICAL LEMPTY, LSUB COMMON / MPCOMC / CDIV, CEOL, CEOR, CONC, CSUB, A CTOP COMMON / MPCOML / LEMPTY, LSUB C C TEMPLATE PROCESSOR INTERFACE C CHARACTER*1 CDIR, CSTAR INTEGER ICBP1(4), ICBP2(4) INTEGER ITOPDO, IARGS, INESTD, INESTF LOGICAL LCOL1, LDIRL, LEND, LINITM, L1TRIP COMMON / TPCOMC / CDIR, CSTAR COMMON / TPCOMI / ICBP1, ITOPDO, IARGS, ICBP2, INESTD, B INESTF COMMON / TPCOML / LCOL1, LDIRL, LEND, LINITM, L1TRIP C C LOCAL VARIABLES AND PARAMETERS C INTEGER ID(4), IDSDIM LOGICAL LERROR, LFOUND EXTERNAL TPSYNT, MMPSHV, IOERRM SAVE IDSDIM, ID DATA IDSDIM, ID(1), ID(2), ID(3), ID(4) A / 4, 1, 5, 2, 8 / C C CHECK SYNTAX, AND PUSH THE VARIABLE ON THE STACK C CALL TPSYNT (ID, IDSDIM, .FALSE., LERROR) IF (LERROR) GO TO 999 CALL MMPSHV (CBUFFR, ICBP1(1), ICBP2(1), 1, LEMPTY, LFOUND) IF (LFOUND) GO TO 999 CALL IOERRM (.FALSE., A '('' ******** TPINCL - VARIABLE NOT DEFINED'')') C 999 CONTINUE RETURN END SUBROUTINE TPINIT (IUE0, IUI0, IUL0, IUO0) C C----------------------------------------------------------------------- C C FAMILY C ------ C TEMPLATE PROCESSOR C C PURPOSE C ------- C TO INITIALIZE TEMPLATE PROCESSOR VATIABLES C C PARAMETERS C ---------- C IUE0 -I- UNIT NUMBER OF THE ERROR FILE C IUI0 -I- UNIT NUMBER OF THE INPUT FILE C IUL0 -I- UNIT NUMBER OF THE LISTING FILE C IUO0 -I- UNIT NUMBER OF THE OUTPUT FILE C C----------------------------------------------------------------------- C C GLOBAL CONSTANTS C CHARACTER*1 CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 COMMON / GLCOMC / CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 C C INPUT / OUTPUT CONTROL INTERFACE C CHARACTER*1 CBUFFR(2000) LOGICAL LBREAK, LFORT, LISTI, LISTO INTEGER ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOMC / CBUFFR COMMON / IOCOMI / ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOML / LBREAK, LFORT, LISTI, LISTO C C MEMORY MANAGER INTERFACE C CHARACTER*1 CSTORE(20000) INTEGER IHASH(601), ISTORE(6000) INTEGER ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS COMMON / MMCOMC / CSTORE COMMON / MMCOMH / IHASH COMMON / MMCOMS / ISTORE COMMON / MMCOMI / ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS C C MACRO PROCESSOR INTERFACE C CHARACTER*1 CDIV, CEOL, CEOR, CONC, CSUB, A CTOP LOGICAL LEMPTY, LSUB COMMON / MPCOMC / CDIV, CEOL, CEOR, CONC, CSUB, A CTOP COMMON / MPCOML / LEMPTY, LSUB C C TEMPLATE PROCESSOR INTERFACE C CHARACTER*1 CDIR, CSTAR INTEGER ICBP1(4), ICBP2(4) INTEGER ITOPDO, IARGS, INESTD, INESTF LOGICAL LCOL1, LDIRL, LEND, LINITM, L1TRIP COMMON / TPCOMC / CDIR, CSTAR COMMON / TPCOMI / ICBP1, ITOPDO, IARGS, ICBP2, INESTD, B INESTF COMMON / TPCOML / LCOL1, LDIRL, LEND, LINITM, L1TRIP INTEGER IUE0, IUI0, IUL0, IUO0 EXTERNAL MMINIT C IUNITE = IUE0 IUNITI = IUI0 IUNITL = IUL0 IUNITO = IUO0 C ILNMBR = 0 ILCTR = ILPP INESTD = 0 INESTF = 0 IPAGE = 0 ITOPDO = 0 LEMPTY = .TRUE. LEND = .FALSE. IF (.NOT. LINITM) CALL MMINIT LINITM = .TRUE. C RETURN END SUBROUTINE TPMMIN C C---------------------------------------------------------------------- C C FAMILY C ------ C TEMPLATE PROCESSOR C C PURPOSE C ------- C THIS ROUTINE INITIALIZES TEMPLATE PROCESSOR CONSTANTS. C C---------------------------------------------------------------------- C C GLOBAL CONSTANTS C CHARACTER*1 CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 COMMON / GLCOMC / CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 C C INPUT / OUTPUT CONTROL INTERFACE C CHARACTER*1 CBUFFR(2000) LOGICAL LBREAK, LFORT, LISTI, LISTO INTEGER ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOMC / CBUFFR COMMON / IOCOMI / ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOML / LBREAK, LFORT, LISTI, LISTO C C MEMORY MANAGER INTERFACE C CHARACTER*1 CSTORE(20000) INTEGER IHASH(601), ISTORE(6000) INTEGER ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS COMMON / MMCOMC / CSTORE COMMON / MMCOMH / IHASH COMMON / MMCOMS / ISTORE COMMON / MMCOMI / ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS C C MACRO PROCESSOR INTERFACE C CHARACTER*1 CDIV, CEOL, CEOR, CONC, CSUB, A CTOP LOGICAL LEMPTY, LSUB COMMON / MPCOMC / CDIV, CEOL, CEOR, CONC, CSUB, A CTOP COMMON / MPCOML / LEMPTY, LSUB C C TEMPLATE PROCESSOR INTERFACE C CHARACTER*1 CDIR, CSTAR INTEGER ICBP1(4), ICBP2(4) INTEGER ITOPDO, IARGS, INESTD, INESTF LOGICAL LCOL1, LDIRL, LEND, LINITM, L1TRIP COMMON / TPCOMC / CDIR, CSTAR COMMON / TPCOMI / ICBP1, ITOPDO, IARGS, ICBP2, INESTD, B INESTF COMMON / TPCOML / LCOL1, LDIRL, LEND, LINITM, L1TRIP C CHARACTER*1 CA0, CBLAN0, CC0, CI0, CLEFT0, A CMINU0, CPLUS0, CPOIN0, CQUOT0, CRIGH0, B CZ0, C00, C90, C CDIR0, CDIV0, CEOL0, CEOR0, CONC0, D CSTAR0, CSUB0 DATA CA0, CBLAN0, CC0, CI0, CLEFT0, A CMINU0, CPLUS0, CPOIN0, CQUOT0, CRIGH0, B CZ0, C00, C90 C / 'A', ' ', 'C', 'I', '(', D '-', '+', '.', '''', ')', E 'Z', '0', '9' / DATA CDIR0 / '*' / DATA CDIV0 / '/' / DATA CEOL0 / '-' / DATA CEOR0 / '/' / DATA CONC0 / '+' / DATA CSTAR0 / '*' / DATA CSUB0 / '$' / CA = CA0 CBLANK = CBLAN0 CC = CC0 CI = CI0 CLEFT = CLEFT0 CMINUS = CMINU0 CPLUS = CPLUS0 CPOINT = CPOIN0 CQUOTE = CQUOT0 CRIGHT = CRIGH0 CZ = CZ0 C0 = C00 C9 = C90 C CDIR = CDIR0 CDIV = CDIV0 CEOL = CEOL0 CEOR = CEOR0 CONC = CONC0 CSTAR = CSTAR0 CSUB = CSUB0 C ICBADD = 1 ICPLI = 72 ICPLO = 72 ILPP = 58 LBREAK = .FALSE. LCOL1 = .TRUE. LFORT = .FALSE. LINITM = .FALSE. LISTI = .FALSE. LISTO = .FALSE. LSUB = .TRUE. L1TRIP = .FALSE. C RETURN END SUBROUTINE TPOPT C C----------------------------------------------------------------------- C C FAMILY C ------ C TEMPLATE PROCESSOR C C PURPOSE C ------- C TO PROCESS OPTION DIRECTIVES C C----------------------------------------------------------------------- C C GLOBAL CONSTANTS C CHARACTER*1 CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 COMMON / GLCOMC / CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 C C INPUT / OUTPUT CONTROL INTERFACE C CHARACTER*1 CBUFFR(2000) LOGICAL LBREAK, LFORT, LISTI, LISTO INTEGER ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOMC / CBUFFR COMMON / IOCOMI / ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOML / LBREAK, LFORT, LISTI, LISTO C C MEMORY MANAGER INTERFACE C CHARACTER*1 CSTORE(20000) INTEGER IHASH(601), ISTORE(6000) INTEGER ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS COMMON / MMCOMC / CSTORE COMMON / MMCOMH / IHASH COMMON / MMCOMS / ISTORE COMMON / MMCOMI / ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS C C MACRO PROCESSOR INTERFACE C CHARACTER*1 CDIV, CEOL, CEOR, CONC, CSUB, A CTOP LOGICAL LEMPTY, LSUB COMMON / MPCOMC / CDIV, CEOL, CEOR, CONC, CSUB, A CTOP COMMON / MPCOML / LEMPTY, LSUB C C TEMPLATE PROCESSOR INTERFACE C CHARACTER*1 CDIR, CSTAR INTEGER ICBP1(4), ICBP2(4) INTEGER ITOPDO, IARGS, INESTD, INESTF LOGICAL LCOL1, LDIRL, LEND, LINITM, L1TRIP COMMON / TPCOMC / CDIR, CSTAR COMMON / TPCOMI / ICBP1, ITOPDO, IARGS, ICBP2, INESTD, B INESTF COMMON / TPCOML / LCOL1, LDIRL, LEND, LINITM, L1TRIP C C LOCAL VARIABLES AND PARAMETERS C CHARACTER*1 C(84), CVALUE INTEGER ID(6), IK(17) INTEGER IKYDIM, ICKDIM, IDSDIM, ICB, I, IVALUE LOGICAL LERROR, LVALUE EXTERNAL TPSYNT, UTRDKY, UTCVCI, UTCVCL, IOERRM SAVE IKYDIM, IK, ICKDIM, C, IDSDIM, ID DATA A IKYDIM, ICKDIM, B IK(1), C IK(2), D IK(3), E IK(4), F IK(5) G / 17, 84, H 4, I 4, J 4, K 4, L 4 / DATA B C(1), C(2), C(3), C(4), C C(5), C(6), C(7), C(8), D C(9), C(10), C(11), C(12), E C(13), C(14), C(15), C(16), F C(17), C(18), C(19), C(20) G / H 'C', 'D', 'I', 'R', I 'C', 'E', 'O', 'L', J 'C', 'E', 'O', 'R', K 'C', 'O', 'N', 'C', L 'C', 'S', 'U', 'B' / DATA A IK(6), B IK(7), C IK(8), D IK(9), E IK(10) F / 5, G 5, H 6, I 6, J 6 / DATA A C(21), C(22), C(23), C(24), C(25), B C(26), C(27), C(28), C(29), C(30), C C(31), C(32), C(33), C(34), C(35), C(36), D C(37), C(38), C(39), C(40), C(41), C(42), E C(43), C(44), C(45), C(46), C(47), C(48) F / 'I', 'C', 'P', 'L', 'I', G 'I', 'C', 'P', 'L', 'O', H 'I', 'U', 'N', 'I', 'T', 'I', I 'I', 'U', 'N', 'I', 'T', 'L', J 'I', 'U', 'N', 'I', 'T', 'O' / DATA A IK(11), B IK(12), C IK(13), D IK(14), E IK(15), F IK(16), G IK(17) H / 6, I 5, K 5, L 5, M 5, N 4, O 6 / DATA A C(49), C(50), C(51), C(52), C(53), C(54), B C(55), C(56), C(57), C(58), C(59), C C(60), C(61), C(62), C(63), C(64), D C(65), C(66), C(67), C(68), C(69), E C(70), C(71), C(72), C(73), C(74), F C(75), C(76), C(77), C(78), G C(79), C(80), C(81), C(82), C(83), C(84) H / 'L', 'B', 'R', 'E', 'A', 'K', I 'L', 'C', 'O', 'L', '1', K 'L', 'F', 'O', 'R', 'T', L 'L', 'I', 'S', 'T', 'I', M 'L', 'I', 'S', 'T', 'O', N 'L', 'S', 'U', 'B', O 'L', '1', 'T', 'R', 'I', 'P' / DATA A IDSDIM, ID(1), ID(2), ID(3), ID(4), ID(5), ID(6) B / 6, 1, 5, 4, 6, 2, 7 / C C CHECK SYNTAX C CALL TPSYNT (ID, IDSDIM, .FALSE., LERROR) IF (LERROR) GO TO 999 ICB = ICBP1(1) CALL UTRDKY (CBUFFR, ICBP1(1), ICBP2(1), IK, IKYDIM, A C, ICKDIM, I) IF (I .GT. IKYDIM) GO TO 220 IF (CBUFFR(ICB) .EQ. CC) GO TO 10 IF (CBUFFR(ICB) .EQ. CI) GO TO 20 GO TO 30 C 10 CONTINUE IF (ICBP1(2) .NE. ICBP2(2)) GO TO 230 ICB = ICBP1(2) CVALUE = CBUFFR(ICB) GO TO 40 C 20 CONTINUE CALL UTCVCI (CBUFFR, ICBP1(2), ICBP2(2), IVALUE, LERROR) IF (LERROR) GO TO 240 GO TO 40 C 30 CONTINUE CALL UTCVCL (CBUFFR, ICBP1(2), ICBP2(2), LVALUE, LERROR) IF (LERROR) GO TO 250 C 40 CONTINUE GO TO (50, 60, 70, 80, 90, 100, 110, 120, A 130, 140, 150, 160, 170, 180, 190, 200, 210), I C C PROCESS -CDIR- C 50 CONTINUE CDIR = CVALUE GO TO 999 C C PROCESS -CEOL- C 60 CONTINUE CEOL = CVALUE GO TO 999 C C PROCESS -CEOR- C 70 CONTINUE CEOR = CVALUE GO TO 999 C C PROCESS -CONC- C 80 CONTINUE CONC = CVALUE GO TO 999 C C PROCESS -CSUB- C 90 CONTINUE CSUB = CVALUE GO TO 999 C C PROCESS -ICPLI- C 100 CONTINUE ICPLI = IVALUE GO TO 999 C C PROCESS -ICPLO- C 110 CONTINUE ICPLO = IVALUE GO TO 999 C C PROCESS -IUNITI- C 120 CONTINUE IUNITI = IVALUE GO TO 999 C C PROCESS -IUNITL- C 130 CONTINUE IUNITL = IVALUE GO TO 999 C C PROCESS -IUNITO- C 140 CONTINUE IUNITO = IVALUE GO TO 999 C C PROCESS -LBREAK- C 150 CONTINUE LBREAK = LVALUE ICBADD = 1 IF (LFORT) ICBADD = -5 IF (LFORT .AND. LBREAK) ICBADD = -9 GO TO 999 C C PROCESS -LCOL1- C 160 CONTINUE LCOL1 = LVALUE GO TO 999 C C PROCESS -LFORT- C 170 CONTINUE LFORT = LVALUE ICBADD = 1 IF (LFORT) ICBADD = -5 IF (LFORT .AND. LBREAK) ICBADD = -9 GO TO 999 C C PROCESS -LISTI- C 180 CONTINUE LISTI = LVALUE GO TO 999 C C PROCESS -LISTO- C 190 CONTINUE LISTO = LVALUE GO TO 999 C C PROCESS -LSUB- C 200 CONTINUE LSUB = LVALUE GO TO 999 C C PROCESS -L1TRIP- C 210 CONTINUE L1TRIP = LVALUE GO TO 999 C C ERROR - UNKNOWN OPTION NAME C 220 CONTINUE CALL IOERRM (.FALSE., A '('' ******** TPOPT - ILLEGAL OR MISSPELLED OPTION'')') GO TO 999 C C ERROR - SINGLE CHARACTER EXPECTED C 230 CONTINUE CALL IOERRM (.FALSE., A '('' ******** TPOPT - OPTION REQUIRES SINGLE CHARACTER'')') GO TO 999 C C ERROR - INTEGER EXPECTED C 240 CONTINUE CALL IOERRM (.FALSE., A '('' ******** TPOPT - OPTION REQUIRES AN INTEGER'')') GO TO 999 C C ERROR - LOGICAL VALUE EXPECTED C 250 CONTINUE CALL IOERRM (.FALSE., A '('' ******** TPOPT - OPTION REQUIRES A LOGICAL VALUE'')') C 999 CONTINUE RETURN END SUBROUTINE TPRDBL (IK, IKYDIM, C, ICKDIM, ID, IDSDIM, A LSCAN, LSKIP, LSUBL, LERROR) C C----------------------------------------------------------------------- C C FAMILY C ------ C TEMPLATE PROCESSOR C C PURPOSE C ------- C TO READ A BLOCK OF STATEMENTS DELIMITED BY C DIRECTIVES OF THE FORM -NAME- AND -ENDNAME-. C THESE DIRECTIVES MAY BE NESTED. C C PARAMETERS C ---------- C IK -I- INDEXES OF DIRECTIVES IN ARRAY C C IKYDIM -I- DIMENSION OF IK (SHOULD BE 3) C C -I- CONTAINS DIRECTIVE NAMES. DIRECTIVE 1 IS -NAME-, C 2 IS -ENDNAME, AND 3 IS -END-. C ICKDIM -I- DIMENSION OF C (TOTAL NUMBER OF CHARACTERS) C ID -I- CONTAINS THE SYNTAX PATTERN FOR DIRECTIVE -NAME- C IDSDIM -I- DIMENSION OF ID C LSCAN -I- IF TRUE, EXPRESSIONS WILL BE SCANNED FOR ERRORS C BUT NOT EVALUATED C LSKIP -I- IF TRUE, INPUT LINES ARE SKIPPED, NOT SAVED C LSUBL -I- IF TRUE, MACRO SUBSTITUTIONS WILL BE PERFORMED C WHEN ENCOUNTERED WITHIN THE BLOCK C LERROR -O- TRUE IF AN ERROR WAS ENCOUNTERED C C----------------------------------------------------------------------- C C GLOBAL CONSTANTS C CHARACTER*1 CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 COMMON / GLCOMC / CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 C C INPUT / OUTPUT CONTROL INTERFACE C CHARACTER*1 CBUFFR(2000) LOGICAL LBREAK, LFORT, LISTI, LISTO INTEGER ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOMC / CBUFFR COMMON / IOCOMI / ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOML / LBREAK, LFORT, LISTI, LISTO C C MEMORY MANAGER INTERFACE C CHARACTER*1 CSTORE(20000) INTEGER IHASH(601), ISTORE(6000) INTEGER ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS COMMON / MMCOMC / CSTORE COMMON / MMCOMH / IHASH COMMON / MMCOMS / ISTORE COMMON / MMCOMI / ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS C C MACRO PROCESSOR INTERFACE C CHARACTER*1 CDIV, CEOL, CEOR, CONC, CSUB, A CTOP LOGICAL LEMPTY, LSUB COMMON / MPCOMC / CDIV, CEOL, CEOR, CONC, CSUB, A CTOP COMMON / MPCOML / LEMPTY, LSUB C C TEMPLATE PROCESSOR INTERFACE C CHARACTER*1 CDIR, CSTAR INTEGER ICBP1(4), ICBP2(4) INTEGER ITOPDO, IARGS, INESTD, INESTF LOGICAL LCOL1, LDIRL, LEND, LINITM, L1TRIP COMMON / TPCOMC / CDIR, CSTAR COMMON / TPCOMI / ICBP1, ITOPDO, IARGS, ICBP2, INESTD, B INESTF COMMON / TPCOML / LCOL1, LDIRL, LEND, LINITM, L1TRIP C C LOCAL VARIABLES AND PARAMETERS C INTEGER IKYDIM, ICKDIM, IDSDIM CHARACTER*(*) C(ICKDIM) INTEGER ID(IDSDIM), IK(IKYDIM) LOGICAL LERROR, LSCAN, LSKIP, LSUBL INTEGER I, INEST EXTERNAL MPLINE, TPCHKD, UTRDKY, TPSYNT C INEST = 1 C 10 CONTINUE IF (LSKIP) ICBEOL = 0 CALL MPLINE (LSUBL) CALL TPCHKD IF (.NOT. LDIRL) GO TO 10 CALL UTRDKY (CBUFFR, ICB1, ICB2, IK, IKYDIM, C, ICKDIM, I) GO TO (20, 30, 40, 10), I C C A -NAME- DIRECTIVE HAS BEEN ENCOUNTERED C 20 CONTINUE IF (LSCAN) CALL TPSYNT (ID, IDSDIM, LSCAN, LERROR) IF (LSCAN .AND. (IARGS .GE. 2)) GO TO 10 INEST = INEST + 1 GO TO 10 C C AN -ENDNAME- DIRECTIVE HAS BEEN ENCOUNTERED C 30 CONTINUE INEST = INEST - 1 IF (INEST .GT. 0) GO TO 10 GO TO 999 C C AN -END- DIRECTIVE HAS POSSIBLY BEEN ENCOUNTERED C 40 CONTINUE LEND = ICB1 .GT. ICB2 IF (.NOT. LEND) GO TO 10 C 999 CONTINUE RETURN END SUBROUTINE TPRSET C C----------------------------------------------------------------------- C C FAMILY C ------ C TEMPLATE PROCESSOR C C PURPOSE C ------- C TO PROCESS RESET DIRECTIVES C C----------------------------------------------------------------------- C C GLOBAL CONSTANTS C CHARACTER*1 CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 COMMON / GLCOMC / CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 C C INPUT / OUTPUT CONTROL INTERFACE C CHARACTER*1 CBUFFR(2000) LOGICAL LBREAK, LFORT, LISTI, LISTO INTEGER ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOMC / CBUFFR COMMON / IOCOMI / ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOML / LBREAK, LFORT, LISTI, LISTO C C MEMORY MANAGER INTERFACE C CHARACTER*1 CSTORE(20000) INTEGER IHASH(601), ISTORE(6000) INTEGER ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS COMMON / MMCOMC / CSTORE COMMON / MMCOMH / IHASH COMMON / MMCOMS / ISTORE COMMON / MMCOMI / ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS C C MACRO PROCESSOR INTERFACE C CHARACTER*1 CDIV, CEOL, CEOR, CONC, CSUB, A CTOP LOGICAL LEMPTY, LSUB COMMON / MPCOMC / CDIV, CEOL, CEOR, CONC, CSUB, A CTOP COMMON / MPCOML / LEMPTY, LSUB C C TEMPLATE PROCESSOR INTERFACE C CHARACTER*1 CDIR, CSTAR INTEGER ICBP1(4), ICBP2(4) INTEGER ITOPDO, IARGS, INESTD, INESTF LOGICAL LCOL1, LDIRL, LEND, LINITM, L1TRIP COMMON / TPCOMC / CDIR, CSTAR COMMON / TPCOMI / ICBP1, ITOPDO, IARGS, ICBP2, INESTD, B INESTF COMMON / TPCOML / LCOL1, LDIRL, LEND, LINITM, L1TRIP C C LOCAL VARIABLES AND PARAMETERS C INTEGER IDSDIM, ICP1,ICP2 INTEGER ID(4) LOGICAL LERROR, LFOUND EXTERNAL TPSYNT, UTBLDN, MMPUTP SAVE IDSDIM, ID DATA IDSDIM, ID(1), ID(2), ID(3), ID(4) A / 4, 1, 5, 2, 7 / C C CHECK SYNTAX C CALL TPSYNT (ID, IDSDIM, .FALSE., LERROR) IF (LERROR) GO TO 999 ICP1 = ICBEND + 1 CALL UTBLDN (CDIV, CBUFFR, ICBP1(1), ICBP2(1), 1, A CBUFFR, ICP1, ICP2, ICBDIM, LERROR) ICBEND = ICP2 CALL MMPUTP (CBUFFR, ICBP1(1), ICBP2(1), A CBUFFR, ICP1, ICP2, LFOUND) C 999 CONTINUE RETURN END SUBROUTINE TPSET C C----------------------------------------------------------------------- C C FAMILY C ------ C TEMPLATE PROCESSOR C C PURPOSE C ------- C TO PROCESS SET DIRECTIVES C C----------------------------------------------------------------------- C C GLOBAL CONSTANTS C CHARACTER*1 CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 COMMON / GLCOMC / CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 C C INPUT / OUTPUT CONTROL INTERFACE C CHARACTER*1 CBUFFR(2000) LOGICAL LBREAK, LFORT, LISTI, LISTO INTEGER ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOMC / CBUFFR COMMON / IOCOMI / ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOML / LBREAK, LFORT, LISTI, LISTO C C MEMORY MANAGER INTERFACE C CHARACTER*1 CSTORE(20000) INTEGER IHASH(601), ISTORE(6000) INTEGER ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS COMMON / MMCOMC / CSTORE COMMON / MMCOMH / IHASH COMMON / MMCOMS / ISTORE COMMON / MMCOMI / ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS C C MACRO PROCESSOR INTERFACE C CHARACTER*1 CDIV, CEOL, CEOR, CONC, CSUB, A CTOP LOGICAL LEMPTY, LSUB COMMON / MPCOMC / CDIV, CEOL, CEOR, CONC, CSUB, A CTOP COMMON / MPCOML / LEMPTY, LSUB C C TEMPLATE PROCESSOR INTERFACE C CHARACTER*1 CDIR, CSTAR INTEGER ICBP1(4), ICBP2(4) INTEGER ITOPDO, IARGS, INESTD, INESTF LOGICAL LCOL1, LDIRL, LEND, LINITM, L1TRIP COMMON / TPCOMC / CDIR, CSTAR COMMON / TPCOMI / ICBP1, ITOPDO, IARGS, ICBP2, INESTD, B INESTF COMMON / TPCOML / LCOL1, LDIRL, LEND, LINITM, L1TRIP C C LOCAL VARIABLES AND PARAMETERS C INTEGER IKYDIM, ICKDIM, IDSDIM CHARACTER*1 C(12) INTEGER ID(8), IK(3) LOGICAL LERROR EXTERNAL TPSYNT, TPSETM, TPRDBL, MMPUTV, IOERRM SAVE IKYDIM, IK, ICKDIM, C, IDSDIM, ID DATA A IKYDIM, ICKDIM, B IK(1), C IK(2), D IK(3) E / 3, 12, F 3, G 6, H 3 / DATA B C(1), C(2), C(3), C C(4), C(5), C(6), C(7), C(8), C(9), D C(10), C(11), C(12) E / F 'S', 'E', 'T', G 'E', 'N', 'D', 'S', 'E', 'T', H 'E', 'N', 'D' / DATA A IDSDIM, B ID(1), ID(2), ID(3), ID(4), ID(5), ID(6), ID(7), ID(8) C / 8, D -1, 8, 5, -4, 7, 6, 2, 7 / C C CHECK SYNTAX C CALL TPSYNT (ID, IDSDIM, .FALSE., LERROR) IF (LERROR) GO TO 999 IF (IARGS .EQ. 2) GO TO 20 IF (IARGS .EQ. 1) GO TO 10 CALL TPSETM IF (LEND) GO TO 30 GO TO 999 C C PROCESS A MULTI-LINE SET STATEMENT C 10 CONTINUE ICBP1(2) = ICBEOL + 1 CALL TPRDBL (IK, IKYDIM, C, ICKDIM, ID, IDSDIM, A .TRUE., .FALSE., .TRUE., LERROR) IF (LEND) GO TO 30 IF (LERROR) GO TO 999 ICBP2(2) = ICB0 - 1 C C SET THE VALUE C 20 CONTINUE CALL MMPUTV (CBUFFR, ICBP1(1), ICBP2(1), A CBUFFR, ICBP1(2), ICBP2(2)) GO TO 999 C 30 CONTINUE CALL IOERRM (.FALSE., A '('' ******** TPSET - SET HAS NO MATCHING ENDSET'')') C 999 CONTINUE RETURN END SUBROUTINE TPSETM C C----------------------------------------------------------------------- C C FAMILY C ------ C TEMPLATE PROCESSOR C C PURPOSE C ------- C TO PROCESS MULTILINE SET DIRECTIVES C C----------------------------------------------------------------------- C C GLOBAL CONSTANTS C CHARACTER*1 CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 COMMON / GLCOMC / CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 C C INPUT / OUTPUT CONTROL INTERFACE C CHARACTER*1 CBUFFR(2000) LOGICAL LBREAK, LFORT, LISTI, LISTO INTEGER ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOMC / CBUFFR COMMON / IOCOMI / ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOML / LBREAK, LFORT, LISTI, LISTO C C MEMORY MANAGER INTERFACE C CHARACTER*1 CSTORE(20000) INTEGER IHASH(601), ISTORE(6000) INTEGER ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS COMMON / MMCOMC / CSTORE COMMON / MMCOMH / IHASH COMMON / MMCOMS / ISTORE COMMON / MMCOMI / ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS C C MACRO PROCESSOR INTERFACE C CHARACTER*1 CDIV, CEOL, CEOR, CONC, CSUB, A CTOP LOGICAL LEMPTY, LSUB COMMON / MPCOMC / CDIV, CEOL, CEOR, CONC, CSUB, A CTOP COMMON / MPCOML / LEMPTY, LSUB C C TEMPLATE PROCESSOR INTERFACE C CHARACTER*1 CDIR, CSTAR INTEGER ICBP1(4), ICBP2(4) INTEGER ITOPDO, IARGS, INESTD, INESTF LOGICAL LCOL1, LDIRL, LEND, LINITM, L1TRIP COMMON / TPCOMC / CDIR, CSTAR COMMON / TPCOMI / ICBP1, ITOPDO, IARGS, ICBP2, INESTD, B INESTF COMMON / TPCOML / LCOL1, LDIRL, LEND, LINITM, L1TRIP C C LOCAL VARIABLES AND PARAMETERS C INTEGER IKYDIM,ICKDIM, IDSDIM, I CHARACTER*1 C(9) INTEGER ID(5), IK(2) LOGICAL LERROR, LSKIP EXTERNAL MPLINE, TPCHKD, UTRDKY, TPSYNT, MMPUTV SAVE IKYDIM, IK, ICKDIM, C, IDSDIM, ID DATA A IKYDIM, ICKDIM, B IK(1), C IK(2) D / 2, 9, E 6, F 3 / DATA B C(1), C(2), C(3), C(4), C(5), C(6), C C(7), C(8), C(9) D / E 'E', 'N', 'D', 'S', 'E', 'T', F 'E', 'N', 'D' / DATA IDSDIM, ID(1), ID(2), ID(3), ID(4), ID(5) A / 5, 5, 4, -6, 5, 7 / C LSKIP = .TRUE. C 10 CONTINUE IF (LSKIP) ICBEOL = 0 CALL MPLINE (.TRUE.) CALL TPCHKD IF (.NOT. LDIRL) GO TO 20 IF (ICB1 .GT. ICB2) GO TO 30 CALL UTRDKY (CBUFFR, ICB1, ICB2, IK, IKYDIM, C, ICKDIM, I) IF (I .EQ. 1) GO TO 50 IF (I .EQ. 2) GO TO 60 IF (I .EQ. 3) GO TO 10 C C A TEXT LINE HAS BEEN ENCOUNTERED C 20 CONTINUE IF (.NOT. LSKIP) GO TO 10 CALL TPSYNT (ID, IDSDIM, .FALSE., LERROR) IF (LERROR) GO TO 10 IF (IARGS .EQ. 2) GO TO 40 ICBEOL = ICBP2(1) LSKIP = .FALSE. GO TO 10 C C A DIRECTIVE PREFIX CHARACTER HAS BEEN C ENCOUNTERED ON A LINE BY ITSELF C 30 CONTINUE IF (LSKIP) GO TO 10 ICBP1(2) = ICBP2(1) + 1 ICBP2(2) = ICB0 - 1 LSKIP = .TRUE. C C SAVE THE VALUE C 40 CONTINUE CALL MMPUTV (CBUFFR, ICBP1(1), ICBP2(1), A CBUFFR, ICBP1(2), ICBP2(2)) GO TO 10 C C AN ENDSET DIRECTIVE HAS BEEN ENCOUNTERED C 50 CONTINUE IF (.NOT. LSKIP) GO TO 10 GO TO 999 C C AN -END- DIRECTIVE HAS POSSIBLY BEEN ENCOUNTERED C 60 CONTINUE LEND = ICB1 .GT. ICB2 IF (.NOT. LEND) GO TO 10 C 999 CONTINUE RETURN END SUBROUTINE TPSYNT (IDSYNT, IDSDIM, LSCAN, LERROR) C C----------------------------------------------------------------------- C C FAMILY C ------ C TEMPLATE PROCESSOR C C PURPOSE C ------- C TO CHECK A DIRECTIVE LINE FOR CORRECT SYNTAX C C PARAMETERS C ---------- C IDSYNT -I- CONTAINS THE DIRECTIVE SYNTAX PATTERN. C THE VECTOR IDSYNT DESCRIBES THE TOKENS THAT C ARE ALLOWED. POSSIBLE VALUES OF IDSYNT(I): C ABS(IDSYNT(I)) TOKEN C -------------- ----- C 1 ( C 2 ) C 3 , C 4 = C 5 ID C 6 EXP C 7 EOL C 8 EOL C WHEN IDSYNT(I) < 0, TWO THINGS CAN HAPPEN: C - IF ABS(IDSYNT(I)) 'MATCHES' CURRENT TOKEN, C SKIP TO IDSYNT(I+2) FOR NEXT MATCH. C - IF NOT, SKIP TO IDSYNT(IDSYNT(I+1)) C FOR NEXT MATCH. C C IDSDIM -I- DIMENSION OF IDSYNT C LSCAN -I- IF TRUE, DIRECTIVES ARE TO BE SCANNED C BUT NOT EXECUTED C LERROR -O- TRUE IF THE DIRECTIVE HAS A SYNTAX ERROR C C----------------------------------------------------------------------- C C GLOBAL CONSTANTS C CHARACTER*1 CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 COMMON / GLCOMC / CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 C C INPUT / OUTPUT CONTROL INTERFACE C CHARACTER*1 CBUFFR(2000) LOGICAL LBREAK, LFORT, LISTI, LISTO INTEGER ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOMC / CBUFFR COMMON / IOCOMI / ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOML / LBREAK, LFORT, LISTI, LISTO C C MEMORY MANAGER INTERFACE C CHARACTER*1 CSTORE(20000) INTEGER IHASH(601), ISTORE(6000) INTEGER ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS COMMON / MMCOMC / CSTORE COMMON / MMCOMH / IHASH COMMON / MMCOMS / ISTORE COMMON / MMCOMI / ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS C C MACRO PROCESSOR INTERFACE C CHARACTER*1 CDIV, CEOL, CEOR, CONC, CSUB, A CTOP LOGICAL LEMPTY, LSUB COMMON / MPCOMC / CDIV, CEOL, CEOR, CONC, CSUB, A CTOP COMMON / MPCOML / LEMPTY, LSUB C C TEMPLATE PROCESSOR INTERFACE C CHARACTER*1 CDIR, CSTAR INTEGER ICBP1(4), ICBP2(4) INTEGER ITOPDO, IARGS, INESTD, INESTF LOGICAL LCOL1, LDIRL, LEND, LINITM, L1TRIP COMMON / TPCOMC / CDIR, CSTAR COMMON / TPCOMI / ICBP1, ITOPDO, IARGS, ICBP2, INESTD, B INESTF COMMON / TPCOML / LCOL1, LDIRL, LEND, LINITM, L1TRIP C C LOCAL VARIABLES AND PARAMETERS C INTEGER IDSDIM CHARACTER*1 C(4) INTEGER IDSYNT(IDSDIM) LOGICAL L, LEOL, LERROR, LSCAN INTEGER I, ICV1, IJUMP, ICV2 EXTERNAL UTRDBL, UTRDNA, TPEXPR, IOERRM SAVE C DATA C(1), C(2), C(3), C(4) A / '(', ')', ',', '=' / C I = 1 IARGS = 0 LERROR = .FALSE. C C DETERMINE WHICH TOKEN TO CHECK FOR C 10 CONTINUE ICV1 = ICB1 CALL UTRDBL (CBUFFR, ICB1, ICB2, LEOL) IJUMP = IABS(IDSYNT(I)) GO TO (20, 20, 20, 20, 30, 40, 50, 50), IJUMP C C CHECK FOR DELIMITERS AND SEPARATERS C 20 CONTINUE IF (LEOL) GO TO 80 IF (C(IJUMP) .NE. CBUFFR(ICB1)) GO TO 80 ICB1 = ICB1 + 1 GO TO 70 C C CHECK FOR A NAME C 30 CONTINUE IF (LEOL) GO TO 80 CALL UTRDNA (CBUFFR, ICB1, ICB2, ICV1, ICV2, L) IF (L) GO TO 80 GO TO 60 C C CHECK FOR AN EXPRESSION C 40 CONTINUE IF (LEOL) GO TO 80 CALL TPEXPR (ICV1, ICV2, LSCAN, L) IF (L) GO TO 80 GO TO 60 C C CHECK FOR END OF LINE C 50 CONTINUE IF (LEOL) GO TO 999 IF (IJUMP .NE. 8) GO TO 80 ICV2 = ICBEOL C 60 CONTINUE IARGS = IARGS + 1 IF (LSCAN) GO TO 70 ICBP1(IARGS) = ICV1 ICBP2(IARGS) = ICV2 C 70 CONTINUE IF (IDSYNT(I) .LT. 0) I = I + 1 I = I + 1 IF (I .LE. IDSDIM) GO TO 10 GO TO 999 C C IF THERE IS AN ALTERNATE SYNTAX FOR THIS STATEMENT C THEN TRY IT, OTHERWISE PRINT AN ERROR MESSAGE C 80 CONTINUE IF (IDSYNT(I).GT. 0) GO TO 90 I = IDSYNT(I+1) IF (I .LE. IDSDIM) GO TO 10 C C ERROR EXITS C 90 CONTINUE LERROR = .TRUE. GO TO (100, 110, 120, 130, 140, 150, 160, 160), IJUMP C 100 CONTINUE CALL IOERRM (.FALSE., A '('' ******** TPSYNT - LEFT PARENTHESIS EXPECTED'')') GO TO 999 C 110 CONTINUE CALL IOERRM (.FALSE., A '('' ******** TPSYNT - RIGHT PARENTHESIS EXPECTED'')') GO TO 999 C 120 CONTINUE CALL IOERRM (.FALSE., A '('' ******** TPSYNT - COMMA EXPECTED'')') GO TO 999 C 130 CONTINUE CALL IOERRM (.FALSE., A '('' ******** TPSYNT - EQUALS SIGN EXPECTED'')') GO TO 999 C 140 CONTINUE CALL IOERRM (.FALSE., A '('' ******** TPSYNT - VARIABLE EXPECTED'')') GO TO 999 C 150 CONTINUE CALL IOERRM (.FALSE., A '('' ******** TPSYNT - MISSING OR UNRECOGNIZED EXPRESSION'')') GO TO 999 C 160 CONTINUE CALL IOERRM (.FALSE., A '('' ******** TPSYNT - ILLEGAL CHARACTERS AT END OF LINE'')') C 999 CONTINUE RETURN END SUBROUTINE UTBLDN (CPREFX, CROOT, ICR1, ICR2, ISUFFX, A CNAME, ICN1, ICN2, ICNDIM, LERROR) C C----------------------------------------------------------------------- C C FAMILY C ------ C UTILITY C C PURPOSE C ------- C TO BUILD A NAME GIVEN A PREFIX, ROOT, AND SUFFIX C C PARAMETERS C ---------- C CPREFX -I- A ONE CHARACTER PREFIX C CROOT -I- ROOT OF THE NAME C ICR1 -I- INDEX OF THE FIRST CHARACTER IN THE ROOT C ICR2 -I- INDEX OF THE LAST CHARACTER IN THE ROOT C ISUFFX -I- INTEGER SUFFIX C CNAME -O- THE NAME C ICN1 -I- INDEX OF THE FIRST CHARACTER IN THE NAME C ICN2 -O- INDEX OF THE LAST CHARACTER IN THE NAME C ICNDIM -I- DIMENSION OF CNAME C LERROR -O- TRUE IF AN ERROR OCCURED C C----------------------------------------------------------------------- C C GLOBAL CONSTANTS C CHARACTER*1 CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 COMMON / GLCOMC / CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 C C LOCAL VARIABLES AND PARAMETERS C INTEGER ICR1, ICR2, ISUFFX, ICN1, ICN2, ICNDIM CHARACTER*(*) CNAME(ICNDIM), CPREFX, CROOT(ICR2) LOGICAL LERROR INTEGER I EXTERNAL UTCVIC C LERROR = ICN1 + ICR2 - ICR1 + 1 .GT. ICNDIM IF (LERROR) GO TO 999 ICN2 = ICN1 CNAME(ICN2) = CPREFX IF (ICR1 .GT. ICR2) GO TO 20 DO 10 I=ICR1,ICR2 ICN2 = ICN2 + 1 CNAME(ICN2) = CROOT(I) 10 CONTINUE 20 CONTINUE IF (ISUFFX .LT. 0) GO TO 999 I = ICN2 + 1 CALL UTCVIC (CNAME, I, ICN2, ICNDIM, ISUFFX, LERROR) C 999 CONTINUE RETURN END SUBROUTINE UTCVCI (CLINE, ICL1, ICL2, IVALUE, LERROR) C C----------------------------------------------------------------------- C C FAMILY C ------ C UTILITY C C PURPOSE C ------- C TO CONVERT A CHARACTER STRING INTO AN INTEGER C C PARAMETERS C ---------- C CLINE -I- STRING TO BE CONVERTED C ICL1 -I- INDEX OF THE FIRST CHARACTER IN THE STRING C ICL2 -I- INDEX OF THE LAST CHARACTER IN THE STRING C IVALUE -O- INTEGER RESULT C LERROR -O- TRUE IF AN ERROR OCCURED C C----------------------------------------------------------------------- C C GLOBAL CONSTANTS C CHARACTER*1 CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 COMMON / GLCOMC / CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 C C LOCAL VARIABLES AND PARAMETERS C INTEGER ICL1, ICL2, IVALUE CHARACTER*(*) CLINE(ICL2) CHARACTER*1 C(10), CLINEI LOGICAL LERROR, LMINUS INTEGER I, I1, IC EXTERNAL UTRDBL SAVE C DATA C(1), C(2), C(3), C(4), C(5), A C(6), C(7), C(8), C(9), C(10) B / '0', '1', '2', '3', '4', C '5', '6', '7', '8', '9' / C IVALUE = 0 I = ICL1 CALL UTRDBL (CLINE, I, ICL2, LERROR) IF (LERROR) GO TO 999 LMINUS = CLINE(I) .EQ. CMINUS IF ((.NOT. LMINUS) .AND. (CLINE(I) .NE. CPLUS)) GO TO 10 I = I + 1 CALL UTRDBL (CLINE, I, ICL2, LERROR) IF (LERROR) GO TO 999 C 10 CONTINUE I1 = I DO 40 I=I1,ICL2 CLINEI = CLINE(I) DO 20 IC=1,10 IF (CLINEI .EQ. C(IC)) GO TO 30 20 CONTINUE IF (I .GT. I1) GO TO 50 GO TO 999 30 CONTINUE IVALUE = IVALUE*10 + IC - 1 40 CONTINUE C 50 CONTINUE LERROR = .FALSE. IF (LMINUS) IVALUE = -IVALUE C 999 CONTINUE RETURN END SUBROUTINE UTCVCL (CLINE, ICL1, ICL2, LVALUE, LERROR) C C----------------------------------------------------------------------- C C FAMILY C ------ C UTILITY C C PURPOSE C ------- C TO CONVERT A CHARACTER STRING TO A LOGICAL VALUE C C PARAMETERS C ---------- C CLINE -I- STRING TO BE CONVERTED C ICL1 -I- INDEX OF THE FIRST CHARACTER IN THE STRING C ICL2 -I- INDEX OF THE LAST CHARACTER IN THE STRING C LVALUE -O- THE LOGICAL RESULT C LERROR -I- TRUE IF AN ERROR OCCURED C C----------------------------------------------------------------------- C C GLOBAL CONSTANTS C CHARACTER*1 CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 COMMON / GLCOMC / CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 C C LOCAL VARIABLES AND PARAMETERS C INTEGER ICL1, ICL2 CHARACTER*(*) CLINE(ICL2) CHARACTER*1 C(13) INTEGER IK(2) LOGICAL LERROR, LV(3), LVALUE INTEGER IKYDIM, ICKDIM, I EXTERNAL UTRDKY SAVE IKYDIM, IK, ICKDIM, C, LV DATA A IKYDIM, ICKDIM, B IK(1), C IK(2) D / 6, 13, E 6, F 7 / DATA B C(1), C(2), C(3), C(4), C(5), C(6), C C(7), C(8), C(9), C(10), C(11), C(12), C(13) D / E '.', 'T', 'R', 'U', 'E', '.', F '.', 'F', 'A', 'L', 'S', 'E', '.' / DATA A LV(1), LV(2), LV(3) B / .TRUE., .FALSE., .TRUE. / C LERROR = .TRUE. IF (ICL1 .GT. ICL2) GO TO 999 DO 10 I=ICL1,ICL2 IF (CLINE(I) .NE. CBLANK) GO TO 20 10 CONTINUE GO TO 999 C 20 CONTINUE CALL UTRDKY (CLINE, ICL1, ICL2, IK, IKYDIM, C, ICKDIM, I) LERROR = I .GT. IKYDIM LVALUE = LV(I) C 999 CONTINUE RETURN END SUBROUTINE UTCVIC (CLINE, ICL1, ICL2, ICLDIM, IVALUE, LERROR) C C----------------------------------------------------------------------- C C FAMILY C ------ C UTILITY C C PURPOSE C ------- C TO CONVERT AN INTEGER INTO A CHARACTER STRING C C PARAMETERS C ---------- C CLINE -O- STRING RESULT C ICL1 -I- INDEX OF THE FIRST CHARACTER IN THE STRING C ICL2 -O- INDEX OF THE LAST CHARACTER IN THE STRING C ICLDIM -I- DIMENSION OF CLINE C IVALUE -I- INTEGER TO BE CONVERTED C LERROR -O- TRUE IF AN ERROR OCCURED C C----------------------------------------------------------------------- C C GLOBAL CONSTANTS C CHARACTER*1 CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 COMMON / GLCOMC / CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 C C LOCAL VARIABLES AND PARAMETERS C INTEGER ICL1, ICL2, ICLDIM, IVALUE CHARACTER*(*) CLINE(ICLDIM) CHARACTER*1 C(10), CTEMP LOGICAL LERROR INTEGER I1, I2, ICL2MD SAVE C DATA C(1), C(2), C(3), C(4), C(5), A C(6), C(7), C(8), C(9), C(10) B / '0', '1', '2', '3', '4', C '5', '6', '7', '8', '9' / C I1 = IABS(IVALUE) LERROR = .TRUE. ICL2 = ICL1 - 1 C C CONVERT AND THEN REMOVE THE LEAST SIGNIFICANT DIGITS FIRST C 10 CONTINUE I2 = I1 I1 = I1 / 10 I2 = I2 - I1*10 ICL2 = ICL2 + 1 IF (ICL2 .GT. ICLDIM) GO TO 999 CLINE(ICL2) = C(I2+1) IF (I1 .GT. 0) GO TO 10 C C IF NECESSARY, ADD THE MINUS SIGN C IF (IVALUE .GE. 0) GO TO 20 ICL2 = ICL2 + 1 IF (ICL2 .GT. ICLDIM) GO TO 999 CLINE(ICL2) = CMINUS C C REVERSE THE STRING TO PUT THE DIGITS IN THE PROPER ORDER C 20 CONTINUE LERROR = .FALSE. IF (ICL1 .GE. ICL2) GO TO 999 ICL2MD = (ICL1 + ICL2 - 1) / 2 I2 = ICL2 DO 30 I1=ICL1,ICL2MD CTEMP = CLINE(I1) CLINE(I1) = CLINE(I2) CLINE(I2) = CTEMP I2 = I2 - 1 30 CONTINUE C 999 CONTINUE RETURN END SUBROUTINE UTCVLC (CLINE, ICL1, ICL2, ICLDIM, LVALUE, LERROR) C C----------------------------------------------------------------------- C C FAMILY C ------ C UTILITY C C PURPOSE C ------- C TO CONVERT A LOGICAL VALUE TO A CHARACTER C C PARAMETERS C ---------- C CLINE -O- STRING RESULT C ICL1 -I- INDEX OF THE FIRST CHARACTER IN THE STRING C ICL2 -O- INDEX OF THE LAST CHARACTER IN THE STRING C ICLDIM -I- DIMENSION OF CLINE C LVALUE -I- LOGICAL VALUE TO BE CONVERTED C LERROR -O- TRUE IF AN ERROR OCCURED C C----------------------------------------------------------------------- C C GLOBAL CONSTANTS C CHARACTER*1 CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 COMMON / GLCOMC / CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 C C LOCAL VARIABLES AND PARAMETERS C INTEGER ICL1, ICL2, ICLDIM CHARACTER*(*) CLINE(ICLDIM) CHARACTER*1 CF(7), CT(6) LOGICAL LERROR, LVALUE INTEGER ICFDIM, ICTDIM, I SAVE ICFDIM, CF, ICTDIM, CT DATA A ICFDIM, B ICTDIM C / 7, D 6 / DATA A CF(1), CF(2), CF(3), CF(4), CF(5), CF(6), CF(7), B CT(1), CT(2), CT(3), CT(4), CT(5), CT(6) C / '.', 'F', 'A', 'L', 'S', 'E', '.', D '.', 'T', 'R', 'U', 'E', '.' / C ICL2 = ICL1 - 1 IF (LVALUE) GO TO 20 LERROR = (ICL2 + ICFDIM) .GT. ICLDIM IF (LERROR) GO TO 999 DO 10 I=1,ICFDIM ICL2 = ICL2 + 1 CLINE(ICL2) = CF(I) 10 CONTINUE GO TO 999 C 20 CONTINUE LERROR = (ICL2 + ICTDIM) .GT. ICLDIM IF (LERROR) GO TO 999 DO 30 I=1,ICTDIM ICL2 = ICL2 + 1 CLINE(ICL2) = CT(I) 30 CONTINUE C 999 CONTINUE RETURN END SUBROUTINE UTCVNI (CNAME, ICN1, ICN2, INAME, LERROR) C----------------------------------------------------------------------- C C FAMILY C ------ C UTILITY C C PURPOSE C ------- C TO CONVERT (HASH) A NAME INTO AN INTEGER C C PARAMETERS C ---------- C CNAME -I- THE NAME TO BE HASHED C ICN1 -I- INDEX OF THE FIRST CHARACTER IN THE NAME C ICN2 -I- INDEX OF THE LAST CHARACTER IN THE NAME C INAME -O- INTEGER RESULT C LERROR -O- TRUE IF AN ERROR OCCURED C C----------------------------------------------------------------------- C C GLOBAL CONSTANTS C CHARACTER*1 CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 COMMON / GLCOMC / CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 C C LOCAL VARIABLES AND PARAMETERS C INTEGER ICN1, ICN2, INAME CHARACTER*(*) CNAME(ICN2) INTEGER ICHDIM, ICIDIM, I, ICNMIN, ICN, ICH INTEGER IC(6) LOGICAL LERROR CHARACTER*1 C(48), CNAMEI SAVE ICIDIM, IC, ICHDIM, C DATA A ICHDIM, B C(1), C(2), C(3), C(4), C(5), C(6), C C(7), C(8), C(9), C(10), C(11), C(12), D C(13), C(14), C(15), C(16), C(17), C(18), E C(19), C(20), C(21), C(22), C(23), C(24), F C(25), C(26), C(27), C(28), C(29), C(30), G C(31), C(32), C(33), C(34), C(35), C(36), H C(37), C(38), C(39), C(40), C(41), C(42), I C(43), C(44), C(45), C(46), C(47), C(48) J / 48, K 'A', 'B', 'C', 'D', 'E', 'F', L 'G', 'H', 'I', 'J', 'K', 'L', M 'M', 'N', 'O', 'P', 'Q', 'R', N 'S', 'T', 'U', 'V', 'W', 'X', O 'Y', 'Z', '0', '1', '2', '3', P '4', '5', '6', '7', '8', '9', Q '+', '-', '*', ',', '=', '(', R ')', '.', ',', '''', '$', ' ' / DATA A ICIDIM, B IC(1), IC(2), IC(3), IC(4), IC(5), IC(6) C / 6, D 61, 1, 47, 61, 1, 47 / C LERROR = ICN1 .GT. ICN2 IF (LERROR) GO TO 999 I = 0 INAME = 0 ICNMIN = MIN0(ICN2, ICN1+ICIDIM-1) C C DO 30 ICN=ICN1,ICNMIN CNAMEI = CNAME(ICN) DO 10 ICH=1,ICHDIM IF (CNAMEI .EQ. C(ICH)) GO TO 20 10 CONTINUE ICH = ICHDIM + 1 20 CONTINUE I = I + 1 INAME = INAME + IC(I)*ICH 30 CONTINUE C 999 CONTINUE RETURN END SUBROUTINE UTRDBL (CLINE, ICL1, ICL2, LEOL) C C----------------------------------------------------------------------- C C FAMILY C ------ C UTILITY C C PURPOSE C ------- C TO READ (SKIP) BLANKS IN A LINE C C PARAMETERS C ---------- C CLINE -I- LINE OF CHARACTERS C ICL1 -I- INDEX OF THE FIRST CHARACTER IN THE LINE C ICL2 -I- INDEX OF THE LAST CHARACTER IN THE LINE C LEOL -O- TRUE IF THE END OF THE LINE WAS REACHED C C----------------------------------------------------------------------- C C GLOBAL CONSTANTS C CHARACTER*1 CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 COMMON / GLCOMC / CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 C C LOCAL VARIABLES AND PARAMETERS C INTEGER ICL1, ICL2 CHARACTER*(*) CLINE(ICL2) LOGICAL LEOL INTEGER I C IF (ICL1 .GT. ICL2) GO TO 20 C DO 10 I=ICL1,ICL2 IF (CBLANK .NE. CLINE(I)) GO TO 30 10 CONTINUE C 20 CONTINUE ICL1 = ICL2 + 1 LEOL = .TRUE. GO TO 999 C 30 CONTINUE ICL1 = I LEOL = .FALSE. C 999 CONTINUE RETURN END SUBROUTINE UTRDKY (CLINE, ICL1, ICL2, IKEY, IKYDIM, A CKEY, ICKDIM, IK) C C----------------------------------------------------------------------- C C FAMILY C ------ C UTILITY C C PURPOSE C ------- C TO MATCH CHARACTERS WITH ONE OF A GIVEN SET OF KEYS C C PARAMETERS C ---------- C CLINE -I- LINE OF CHARACTERS C ICL1 -I- INDEX OF THE FIRST CHARACTER IN THE LINE C ICL2 -I- INDEX OF THE LAST CHARACTER IN THE LINE C IKEY -I- CONTAINS THE LENGTH OF EACH KEY C IKYDIM -I- NUMBER OF KEYS C CKEY -I- CONTAINS THE KEYS C CKYDIM -I- DIMENSION OF CKEY C IK -O- NUMBER OF THE MATCHED KEY C C----------------------------------------------------------------------- C C GLOBAL CONSTANTS C CHARACTER*1 CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 COMMON / GLCOMC / CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 C C LOCAL VARIABLES AND PARAMETERS C INTEGER ICL1, ICL2, IKYDIM, ICKDIM, IK CHARACTER*(*) CLINE(ICL2), CKEY(ICKDIM) INTEGER IKEY(IKYDIM) INTEGER ICK2, ICLDIF, ICK1, I, ICK C IF (ICL1 .GT. ICL2) GO TO 30 ICK2 = 0 ICLDIF = ICL2 - ICL1 + 1 C DO 20 IK=1,IKYDIM ICK1 = ICK2 + 1 ICK2 = ICK2 + IKEY(IK) IF (ICLDIF .LT. IKEY(IK)) GO TO 20 I = ICL1 DO 10 ICK=ICK1,ICK2 IF (CLINE(I) .NE. CKEY(ICK)) GO TO 20 I = I + 1 10 CONTINUE GO TO 40 20 CONTINUE C 30 CONTINUE IK = IKYDIM + 1 GO TO 999 C 40 CONTINUE ICL1 = ICL1 + IKEY(IK) C 999 CONTINUE RETURN END SUBROUTINE UTRDNA (CLINE, ICL1, ICL2, ICL1NA, ICL2NA, LERROR) C C----------------------------------------------------------------------- C C FAMILY C ------ C UTILITY C C PURPOSE C ------- C TO READ A NAME ON A LINE C C PARAMETERS C ---------- C CLINE -I- LINE OF CHARACTERS C ICL1 -I- INDEX OF THE FIRST CHARACTER IN THE LINE C ICL2 -I- INDEX OF THE LAST CHARACTER IN THE LINE C ICL1NA -O- INDEX OF THE FIRST CHARACTER IN THE NAME C ICL2NA -O- INDEX OF THE LAST CHARACTER IN THE NAME C LERROR -O- TRUE IF AN ERROR OCCURED C C----------------------------------------------------------------------- C C GLOBAL CONSTANTS C CHARACTER*1 CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 COMMON / GLCOMC / CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 C C LOCAL VARIABLES AND PARAMETERS C INTEGER ICL1, ICL2, ICL1NA, ICL2NA CHARACTER*(*) CLINE(ICL2) LOGICAL LERROR INTEGER I C LERROR = .TRUE. IF (ICL1 .GT. ICL2) GO TO 999 C DO 10 I=ICL1,ICL2 IF (.NOT. ((LLE(CA,CLINE(I)) A .AND. LLE(CLINE(I),CZ)) B .OR. (LLE(C0,CLINE(I)) C .AND. LLE(CLINE(I),C9)))) GO TO 20 10 CONTINUE C I = ICL2 + 1 C 20 CONTINUE IF (.NOT. (LLE(CA,CLINE(ICL1)) A .AND. LLE(CLINE(ICL1),CZ))) GO TO 999 ICL1NA = ICL1 ICL1 = I ICL2NA = I - 1 LERROR = .FALSE. C 999 CONTINUE RETURN END SUBROUTINE UTRDNU (CLINE, ICL1, ICL2, ICL1NU, ICL2NU, LERROR) C C----------------------------------------------------------------------- C C FAMILY C ------ C UTILITY C C PURPOSE C ------- C TO READ A NUMBER ON A LINE C C PARAMETERS C ---------- C CLINE -I- LINE OF CHARACTERS C ICL1 -I- INDEX OF THE FIRST CHARACTER IN THE LINE C ICL2 -I- INDEX OF THE LAST CHARACTER IN THE LINE C ICL1NU -O- INDEX OF THE FIRST CHARACTER IN THE NUMBER C ICL2NU -O- INDEX OF THE LAST CHARACTER IN THE NUMBER C LERROR -O- TRUE IF AN ERROR OCCURED C C----------------------------------------------------------------------- C C GLOBAL CONSTANTS C CHARACTER*1 CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 COMMON / GLCOMC / CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 C C LOCAL VARIABLES AND PARAMETERS C INTEGER ICL1, ICL2, ICL1NU, ICL2NU CHARACTER*(*) CLINE(ICL2) LOGICAL LERROR INTEGER I, ICL EXTERNAL UTRDBL C LERROR = ICL1 .GT. ICL2 IF (LERROR) GO TO 999 I = ICL1 IF ((CLINE(I) .NE. CMINUS) A .AND. (CLINE(I) .NE. CPLUS)) GO TO 10 I = I + 1 CALL UTRDBL (CLINE, I, ICL2, LERROR) IF (LERROR) GO TO 999 C 10 CONTINUE ICL = I DO 20 I=ICL,ICL2 IF (.NOT. (LLE(C0,CLINE(I)) A .AND. LLE(CLINE(I),C9))) GO TO 30 20 CONTINUE C I = ICL2 + 1 C 30 CONTINUE ICL1NU = ICL1 ICL1 = I ICL2NU = I - 1 LERROR = ICL1NU .GT. ICL2NU C 999 CONTINUE RETURN END SUBROUTINE UTRDQS (CLINE, ICL1, ICL2, ICL1QS, ICL2QS, LERROR) C C----------------------------------------------------------------------- C C FAMILY C ------ C UTILITY C C PURPOSE C ------- C TO READ A QUOTED STRING ON A LINE C C PARAMETERS C ---------- C CLINE -I- LINE OF CHARACTERS C ICL1 -I- INDEX OF THE FIRST CHARACTER IN THE LINE C ICL2 -I- INDEX OF THE LAST CHARACTER IN THE LINE C ICL1QS -O- INDEX OF THE FIRST CHARACTER IN THE STRING C ICL2QS -O- INDEX OF THE LAST CHARACTER IN THE STRING C LERROR -O- TRUE IF AN ERROR OCCURED C C----------------------------------------------------------------------- C C GLOBAL CONSTANTS C CHARACTER*1 CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 COMMON / GLCOMC / CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 C C LOCAL VARIABLES AND PARAMETERS C INTEGER ICL1, ICL2, ICL1QS, ICL2QS CHARACTER*(*) CLINE(ICL2) CHARACTER*1 CQTEMP LOGICAL LERROR INTEGER I C LERROR = .TRUE. ICL1QS = ICL1 + 1 IF (ICL1QS .GT. ICL2) GO TO 999 CQTEMP = CLINE(ICL1) C DO 10 I=ICL1QS,ICL2 IF (CLINE(I) .EQ. CQTEMP) GO TO 20 10 CONTINUE C GO TO 999 C 20 CONTINUE ICL1 = I + 1 ICL2QS = I - 1 LERROR = .FALSE. C 999 CONTINUE RETURN END SHAR_EOF fi # end of overwriting check if test -f 'simple' then echo shar: will not over-write existing file "'simple'" else cat << SHAR_EOF > 'simple' *COMMENT FILE 8. THE SIMPLE EXAMPLES FROM THE USER'S GUIDE. A SIMPLE EXAMPLE *ENDCOM *SET LASTNAME = 'DOE' FIRSTNAME = 'JOHN' MONTH = 08 DAY = 24 YEAR = 81 SEMESTER = 'FALL' *ENDSET *SET ( NCOURSES = 3 ) *SET ( COURSES = 'BIO 255$$/' ) *APPEND ( COURSES, 'GEO 110$$/' ) *APPEND ( COURSES, 'PSY 201' ) *SET ( NAME = '$$LASTNAME, $$FIRSTNAME' ) *SET ( DATE = '$$MONTH/$$DAY/$$YEAR' ) NAME: $NAME DATE: $DATE SEMESTER: $SEMESTER LIST OF COURSES: *DO ( I = 1, NCOURSES ) $I. $LIST(COURSES) *ENDDO *COMMENT EXAMPLE OF $LIST FUNCTION *ENDCOM *SET(XYZ = ' A $$/ B+C $$/ D*E $$/ ') *APPEND (XYZ, ' F-G $$/ HIJ $$/ ') X = $LIST(XYZ) Y = $LIST(XYZ) Z = $LIST(XYZ) - ($LIST(XYZ)) *RESET(XYZ) K = $LIST(XYZ) *COMMENT EXAMPLE OF ESCAPE CHARACTERS *ENDCOM *SET(LINES = ' T = A $$- A = B $$- B = T $$-' ) *INCLUDE(LINES) *COMMENT EXAMPLE OF *DO STATEMENT *ENDCOM *SET( COEFS = '-12.3 $$/ 16.2 $$/ -4.9 $$/' ) *DO (I = 1, 5, 2) A($I,1) = B($I) * ($LIST(COEFS)) *ENDDO *COMMENT EXAMPLE OF IF'S *ENDCOM *OPTION (LCOL1 = .FALSE.) *SET ( TYPEV = 'VALU' ) *SET ( L1 = 'VALU' ) *SET ( L2 = 6 ) *SET ( L3 = .FALSE. ) *IF ( L1 = TYPEV ) A = B *IF ( L2 = 6 ) B = C *ELSE B = D *ENDIF *IF ( L3 ) C = D *IF ( $DEF(L3)) D = E *ENDIF *COMMENT EXAMPLE OF INCLUDES *ENDCOM *OPTION( LSUB = .FALSE. ) *SET TIMELABEL= 1000 TIMER = .TRUE. NAME = 'SOLVE' MATRIX = 'A' SOLUTION = 'U' RHS = 'B' NUMBEQNS = 20 *ENDSET *SET(LINSYSCALL) *IF(TIMER) *INCLUDE(TIME1) *ENDIF CALL $NAME($MATRIX,$SOLUTION,$RHS,$NUMBEQNS,WORK,IER) *IF(TIMER) *INCLUDE(TIME2) *ENDIF *ENDSET *SET(TIME1) CALL SECOND(TIME1) *ENDSET *SET(TIME2) CALL SECOND(TIME2) TIME(KTIME) = TIME2-TIME1 PRINT $TIMELABEL, TIME(KTIME), '$NAME' KTIME = KTIME+1 *ENDSET *OPTION(LSUB=.TRUE.) *INCLUDE(LINSYSCALL) *END SHAR_EOF fi # end of overwriting check if test -f 'simple.out' then echo shar: will not over-write existing file "'simple.out'" else cat << SHAR_EOF > 'simple.out' NAME: DOE, JOHN DATE: 08/24/81 SEMESTER: FALL LIST OF COURSES: 1. BIO 255 2. GEO 110 3. PSY 201 X = A Y = B+C Z = D*E - ( F-G ) K = A T = A A = B B = T A(1,1) = B(1) * (-12.3 ) A(3,1) = B(3) * ( 16.2 ) A(5,1) = B(5) * ( -4.9 ) A = B B = C D = E CALL SECOND(TIME1) CALL SOLVE(A,U,B,20,WORK,IER) CALL SECOND(TIME2) TIME(KTIME) = TIME2-TIME1 PRINT 1000, TIME(KTIME), 'SOLVE' KTIME = KTIME+1 SHAR_EOF fi # end of overwriting check cd .. cd .. if test ! -d 'Src' then mkdir 'Src' fi cd 'Src' if test ! -d 'Sp' then mkdir 'Sp' fi cd 'Sp' if test -f 'src.f' then echo shar: will not over-write existing file "'src.f'" else cat << SHAR_EOF > 'src.f' C PROGRAM GO C C---------------------------------------------------------------------- C C FAMILY C ------ C SYSTEM/USER INTERFACE C C PURPOSE C ------- C THIS IS A SAMPLE MAIN PROGRAM TO CALL THE C DRIVING ROUTINE OF THE MACRO PROCESSOR. C C---------------------------------------------------------------------- C C GLOBAL CONSTANTS C CHARACTER*1 CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 COMMON / GLCOMC / CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 C C INPUT / OUTPUT CONTROL INTERFACE C CHARACTER*1 CBUFFR(2000) LOGICAL LBREAK, LFORT, LISTI, LISTO INTEGER ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOMC / CBUFFR COMMON / IOCOMI / ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOML / LBREAK, LFORT, LISTI, LISTO C C MEMORY MANAGER INTERFACE C CHARACTER*1 CSTORE(20000) INTEGER IHASH(601), ISTORE(6000) INTEGER ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS COMMON / MMCOMC / CSTORE COMMON / MMCOMH / IHASH COMMON / MMCOMS / ISTORE COMMON / MMCOMI / ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS C C MACRO PROCESSOR INTERFACE C CHARACTER*1 CDIV, CEOL, CEOR, CONC, CSUB, A CTOP LOGICAL LEMPTY, LSUB COMMON / MPCOMC / CDIV, CEOL, CEOR, CONC, CSUB, A CTOP COMMON / MPCOML / LEMPTY, LSUB C C TEMPLATE PROCESSOR INTERFACE C CHARACTER*1 CDIR, CSTAR INTEGER ICBP1(4), ICBP2(4) INTEGER ITOPDO, IARGS, INESTD, INESTF LOGICAL LCOL1, LDIRL, LEND, LINITM, L1TRIP COMMON / TPCOMC / CDIR, CSTAR COMMON / TPCOMI / ICBP1, ITOPDO, IARGS, ICBP2, INESTD, B INESTF COMMON / TPCOML / LCOL1, LDIRL, LEND, LINITM, L1TRIP EXTERNAL TPDRV, TPMMIN C C SET DIMENSIONS FOR ARRAYS C ICBDIM = 2000 ICSDIM = 20000 IHADIM = 601 ISTDIM = 6000 C C INITIALIZE TEMPLATE PROCESSOR C CALL TPMMIN C C CALL DRIVER C USING UNIX STANDARD ERROR, INPUT, AND OUTPUT UNITS C CALL TPDRV (0, 5, 0, 6) C STOP 0 END SUBROUTINE TPDRV (IUE0, IUI0, IUL0, IUO0) C C----------------------------------------------------------------------- C C FAMILY C ------ C TEMPLATE PROCESSOR C C PURPOSE C ------- C THIS IS THE DRIVING ROUTINE OF THE TEMPLATE PROCESSOR. C IT CALLS ROUTINES TO READ, EVALUATE, AND WRITE LINES C UNTIL AN END DIRECTIVE IS ENCOUNTERED C C PARAMETERS C ---------- C IUE0 -I- UNIT NUMBER FOR THE ERROR FILE C IUI0 -I- UNIT NUMBER FOR THE INPUT FILE C IUL0 -I- UNIT NUMBER FOR THE LISTING FILE C IUO0 -I- UNIT NUMBER FOR THE OUTPUT FILE C C COMMON VARIABLES AND DATA STRUCTURES C ------------------------------------ C THE COMMENTS BELOW GIVE A BRIEF DESCRIPTION OF THE COMMON C VARIABLES USED BY THE ROUTINES OF THE TEMPLATE PROCESSOR. C A MORE DETAILED LOOK AT THE MAIN DATA STRUCTURES IS ALSO C INCLUDED. C C GLOBAL CONSTANTS C C COMMON / GLCOMC / C CA - 'A' CPOINT - '.' C CBLANK - ' ' CQUOTE - ''' C CC - 'C' CRIGHT - '(' C CI - 'I' CZ - 'Z' C CLEFT - '(' C0 - '0' C CMINUS - '-' C9 - '9' C CPLUS - '+' C C INPUT / OUTPUT CONTROL INTERFACE C C COMMON / IOCOMC / C CBUFFR - I/O BUFFER C COMMON / IOCOMI / C ICBADD - NUMBER OF SPACES TO SKIP BEFORE THE CONTINUATION C OF A BROKEN LINE C ICBEND - BUFFER POSITION OF END OF CURRENT LOGICAL LINE C (LOGICAL LINE MAY INCLUDE SEVERAL ACTUAL LINES) C ICBEOL - BUFFER POSITION OF CURRENT EOL. C ICBSUB - BUFFER POSITION OF CURRENT SUB. PREF. CHARACTER C ICB0 - BUFFER POSITION OF START OF CURRENT LINE C ICB1 - BUFFER POSITION WHERE CURRENT PROCESSING BEGINS C ICB2 - BUFFER POSITION WHERE CURRENT PROCESSING ENDS C ICB3 - BUFFER POSITION OF END OF CURRENT LINE C ICBDIM - DIMENSION OF CBUFFR C ICPLI - INPUT LINE LENGTH C ICPLO - OUPUT LINE LENGTH C ILCTR - LINE NUMBER ON CURRENT LISTING PAGE C ILNMBR - LINE NUMBER FOR LISTING (OVER ALL PAGES) C ILPP - MAX NUMBER OF LINES PER LISTING PAGE C IPAGE - PAGE NUMBER ON LISTING C IUNITE - ERROR OUTPUT UNIT C IUNITI - INPUT UNIT C IUNITL - LISTING OUTPUT UNIT C IUNITO - STANDARD OUTPUT UNIT C COMMON / IOCOML / C LBREAK - BREAK LONG LINES AT NICE PLACE IF TRUE C LFORT - USE FORTRAN CONTINUATION CHAR. IF TRUE C LISTI - LIST INPUT IF TRUE C LISTO - LIST OUTPUT IF TRUE C C MEMORY MANAGER INTERFACE C C COMMON / MMCOMC / C CSTORE - CHARACTER STORAGE C COMMON / MMCOMH / C IHASH - HASH TABLE (IHASH(I) IS AN INDEX INTO ISTORE) C COMMON / MMCOMS / C ISTORE - INTEGER STORAGE; HOLDS THE POINTERS WHICH C IMPLEMENT THE SYMBOL TABLE AND THE STACK C COMMON / MMCOMI / C ICSDIM - DIMENSION OF ICSDIM C ICSP1 - PTR. TO TOP CHARACTER IN SUBSTITUTION STACK C ICSP2 - PTR. TO LAST CHAR. IN FIRST STRING ON STACK C IHADIM - DIMENSION OF IHASH C ISFREE - PTR. TO HEAD OF ISTORE FREELIST C ISTDIM - DIMENSION OF ISTORE C IS2HDC - PTR. TO HEAD OF FREE CHARACTER STORAGE BLOCKS C (ACTUALLY AN INDEX INTO ISTORE) C IS2HDS - PTR. TO TOP OF STACK C (ACTUALLY AN INDEX INTO ISTORE) C C MACRO PROCESSOR INTERFACE C C COMMON / MPCOMC / C CDIV - '/' C CEOL - '-' C CEOR - '/' C CONC - '+' C CSUB - DOLLAR SIGN C CTOP - TOP CHAR. IN STACK C COMMON / MPCOML / C LEMPTY - TRUE IF SUBSTITUTION STACK EMPTY C LSUB - TRUE IF SUBSTITUTIONS ARE TO BE PERFORMED C C TEMPLATE PROCESSOR INTERFACE C C COMMON / TPCOMC / C CDIR - '*' C CSTAR - '*' C COMMON / TPCOMI / C ICBP1 - ICBP1(I) IS BUFF. POSITION OF START OF C ITH ARGUMENT C ITOPDO - PTR. TO 'TOP' (INNERMOST) DO LOOP ENTRY C IN ISTORE C IARGS - NUMBER OF ARGUMENTS IN A DIRECTIVE C ICBP2 - ICBP2(I) IS BUFF. POSITION OF END OF C ITH ARGUMENT C INESTD - DO LOOP NESTING DEPTH C INESTF - IF-ELSE-ENDIF NESTING DEPTH C COMMON / TPCOML / C LCOL1 - TRUE IF DIRECTIVES MUST BEGIN IN COL 1 C LDIRL - TRUE IF A DIRECTIVE HAS BEEN FOUND C LEND - TRUE IF AN END DIRECTIVE HAS BEEN FOUND C LINITM - TRUE IF MMINIT HAS BEEN CALLED C L1TRIP - TRUE IF ONE TRIP DO-LOOPS SHOULD BE ASSUMED C C C DATA STRUCTURES C --------------- C C I/O BUFFER C THE ARRAY CBUFFR HOLDS THE I/O BUFFER. INPUT LINES ARE READ C IN, MACRO SUBSTITUTIONS PERFORMED, AND LISTING AND OUTPUT C (WHEN APPROPRIATE) ARE DONE FROM THE I/O BUFFER. C C INTEGER STORAGE C THE ARRAY ISTORE IS USED TO HOLD THE POINTERS WHICH IMPLEMENT C THE SYMBOL TABLE AND THE SUBSTITUTION STACK. IT IS USED IN C BLOCKS OF 3 ELEMENTS AT A TIME. THE VARIABLE ISFREE POINTS C TO THE HEAD OF A LINKED LIST OF FREE ISTORE BLOCKS. INITIALLY C ALL BLOCKS ARE FREE (THE 3RD ELEMENT IN A BLOCK POINTS TO THE C NEXT FREE BLOCK). C C CHARACTER STORAGE C THE ARRAY CSTORE PROVIDES A POOL OF CHARACTER STORAGE. IT C IS USED TO RECORD MACRO NAMES AND VALUES, AS WELL AS STRINGS C WHICH MUST BE PUSHED ONTO THE SUBSTITUTION STACK. THE VARIABLE C IS2HDC POINTS TO THE HEAD OF A FREELIST OF CHARACTER STORAGE C BLOCKS. THIS FREELIST IS MADE UP OF ISTORE BLOCKS OF THE C FOLLOWING FORMAT: C ISTORE(I) = CSTORE INDEX OF FIRST CHAR. IN BLOCK C ISTORE(I+1)= CSTORE INDEX OF LAST CHAR. IN BLOCK C ISTORE(I+2)= POINTER TO NEXT BLOCK C C SYMBOL TABLE C THE SYMBOL TABLE KEEPS TRACK OF MACRO NAMES AND VALUES. IT C IS BUILT OUT OF ISTORE BLOCKS WHICH CONTAIN POINTERS TO C OTHER ISTORE BLOCKS OR INDEXES INTO CSTORE. GIVEN A MACRO C NAME, ROUTINE MMHASH COMPUTES ITS HASH INDEX IH. THEN C IHASH(IH) IS THE ISTORE INDEX OF THE SYMBOL TABLE ENTRY FOR C THAT NAME. IF IHASH(IH)=I SAY, THE ISTORE BLOCK AT I HOLDS C THE FOLLOWING: C ISTORE(I) = PTR. TO ISTORE BLOCK FOR VARIABLE NAME C ISTORE(I+1) = PTR. TO HEAD OF LINKED LIST OF ISTORE C BLOCKS FOR VALUE OF VARIABLE C ISTORE(I+2) = PTR. TO TAIL OF THE LINKED LIST FOR THE C VALUE C C AN ISTORE BLOCK FOR THE NAME OF A VARIABLE CONTAINS: C ISTORE(J) = CSTORE INDEX OF FIRST CHAR. IN NAME C ISTORE(J+1) = CSTORE INDEX OF LAST CHAR. IN NAME C ISTORE(J+2) = 0 C C AN ISTORE BLOCK IN THE LINKED LIST WHICH KEEPS TRACK OF C THE VALUE OF A VARIABLE LOOKS LIKE: C ISTORE(K) = CSTORE INDEX OF FIRST CHAR. ASSOCIATED C WITH THIS BLOCK C ISTORE(K+1) = CSTORE INDEX OF LAST CHAR. ASSOCIATED C WITH THIS BLOCK C ISTORE(K+2) = ISTORE INDEX OF NEXT BLOCK IN LIST C (0 IF LAST ONE) C C SUBSTITUTION STACK C WHEN A MACRO SUBSTITUTION IS FOUND, IT AND THE REST OF THE C CURRENT LINE ARE PUSHED ONTO THE SUBSTITUTION STACK. THE C MACRO NAME IS POPPED OFF AND REPLACED BY ITS VALUE. CHARACTERS C ARE THEN POPPED OFF THE STACK, INTO THE I/O BUFFER, UNTIL C THE STACK IS EMPTY OR ANOTHER SUBSTITUTION IS CALLED FOR. C IF ANOTHER MACRO SUBSTITUTION IS NEEDED THE SAME PROCESS IS C REPEATED--THE MACRO NAME IS REPLACED BY ITS VALUE, AND THE C STACK POPPING RESUMES. C C THE STACK IS IMPLEMENTED AS A LINKED LIST OF ISTORE BLOCKS. C THE VARIABLE IS2HDS POINTS TO THE TOP BLOCK ON THE STACK. C A BLOCK AT INDEX I CONTAINS: C ISTORE(I) = PTR. TO ISTORE BLOCK WHICH POINTS TO A C STRING ON THE STACK C ISTORE(I+1) = CSTORE INDEX OF 1ST CHAR. OF C CORRESPONDING STRING C ISTORE(I+2) = LINK TO NEXT ISTORE BLOCK ON STACK C (0 IF THERE IS NONE) C C THE FORMAT OF AN ISTORE BLOCK WHICH POINTS TO A STRING ON THE C STACK IS LIKE THAT OF ONE WHICH POINTS TO A VARIABLE NAME: C ISTORE(J) = CSTORE INDEX OF FIRST CHAR. IN STRING C ISTORE(J+1) = CSTORE INDEX OF LAST CHAR. IN STRING C ISTORE(J+2) = 0 C C C C----------------------------------------------------------------------- C C GLOBAL CONSTANTS C CHARACTER*1 CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 COMMON / GLCOMC / CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 C C INPUT / OUTPUT CONTROL INTERFACE C CHARACTER*1 CBUFFR(2000) LOGICAL LBREAK, LFORT, LISTI, LISTO INTEGER ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOMC / CBUFFR COMMON / IOCOMI / ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOML / LBREAK, LFORT, LISTI, LISTO C C MEMORY MANAGER INTERFACE C CHARACTER*1 CSTORE(20000) INTEGER IHASH(601), ISTORE(6000) INTEGER ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS COMMON / MMCOMC / CSTORE COMMON / MMCOMH / IHASH COMMON / MMCOMS / ISTORE COMMON / MMCOMI / ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS C C MACRO PROCESSOR INTERFACE C CHARACTER*1 CDIV, CEOL, CEOR, CONC, CSUB, A CTOP LOGICAL LEMPTY, LSUB COMMON / MPCOMC / CDIV, CEOL, CEOR, CONC, CSUB, A CTOP COMMON / MPCOML / LEMPTY, LSUB C C TEMPLATE PROCESSOR INTERFACE C CHARACTER*1 CDIR, CSTAR INTEGER ICBP1(4), ICBP2(4) INTEGER ITOPDO, IARGS, INESTD, INESTF LOGICAL LCOL1, LDIRL, LEND, LINITM, L1TRIP COMMON / TPCOMC / CDIR, CSTAR COMMON / TPCOMI / ICBP1, ITOPDO, IARGS, ICBP2, INESTD, B INESTF COMMON / TPCOML / LCOL1, LDIRL, LEND, LINITM, L1TRIP INTEGER IUE0, IUI0, IUL0, IUO0 EXTERNAL TPINIT, MPLINE, TPEVAL, IOWRIT C CALL TPINIT (IUE0, IUI0, IUL0, IUO0) C 10 CONTINUE ICBEOL = 0 CALL MPLINE (.TRUE.) CALL TPEVAL IF (.NOT. LDIRL) CALL IOWRIT IF (.NOT. LEND) GO TO 10 C RETURN END SUBROUTINE IOERRM (LFATAL, CFMT) C C---------------------------------------------------------------------- C C FAMILY C ------ C INPUT/OUTPUT C C PURPOSE C ------- C TO PRINT OUT THE OFFENDING LINE AND AN ERROR MESSAGE BENEATH IT. C IF THE ERROR IS FATAL, PROCESSOR EXECUTION IS TERMINATED. C C PARAMETERS C ---------- C LFATAL -I- TRUE FOR FATAL ERRORS C CFMT -I- FORMAT FOR ERROR MESSAGE C C---------------------------------------------------------------------- C C INPUT / OUTPUT CONTROL INTERFACE C CHARACTER*1 CBUFFR(2000) LOGICAL LBREAK, LFORT, LISTI, LISTO INTEGER ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOMC / CBUFFR COMMON / IOCOMI / ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOML / LBREAK, LFORT, LISTI, LISTO C C LOCAL VARIABLES AND PARAMETERS C CHARACTER*(*) CFMT LOGICAL LFATAL INTEGER I EXTERNAL IOPAGE C IF (IUNITE .EQ. IUNITL) CALL IOPAGE (2) IF (ICB0 .GT. ICB2) GO TO 10 WRITE (IUNITE, 1010) (CBUFFR(I), I=ICB0,ICB2) 1010 FORMAT(' ******** ', 117A1) 10 CONTINUE WRITE (IUNITE, CFMT) IF (LFATAL) STOP 1 C RETURN END SUBROUTINE IOLIST (LNUMBR) C C---------------------------------------------------------------------- C C INPUT/OUTPUT C C PURPOSE C ------- C TO LIST THE LINE CURRENTLY IN THE INPUT/OUTPUT BUFFER. C C PARAMETER C --------- C LNUMBR -I- TRUE IF THE LINE SHOULD BE NUMBERED C C---------------------------------------------------------------------- C C INPUT / OUTPUT CONTROL INTERFACE C CHARACTER*1 CBUFFR(2000) LOGICAL LBREAK, LFORT, LISTI, LISTO INTEGER ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOMC / CBUFFR COMMON / IOCOMI / ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOML / LBREAK, LFORT, LISTI, LISTO C C LOCAL VARIABLES AND PARAMETERS C LOGICAL LNUMBR INTEGER I EXTERNAL IOPAGE C CALL IOPAGE (1) IF (.NOT. LNUMBR) GO TO 20 ILNMBR = ILNMBR + 1 C IF (ICB1 .LE. ICB2) GO TO 10 WRITE (IUNITL, 1010) ILNMBR GO TO 999 C 10 CONTINUE WRITE (IUNITL, 1020) ILNMBR, (CBUFFR(I), I=ICB1,ICB2) GO TO 999 C 20 CONTINUE IF (ICB1 .LE. ICB2) GO TO 30 WRITE (IUNITL, 1030) GO TO 999 C 30 CONTINUE WRITE (IUNITL, 1040) (CBUFFR(I), I=ICB1,ICB2) C 999 CONTINUE RETURN 1010 FORMAT(' ', I8) 1020 FORMAT(' ', I8, 3X, 117A1) 1030 FORMAT(' ') 1040 FORMAT(' ', 11X, 117A1) END SUBROUTINE IOPAGE (IL) C C---------------------------------------------------------------------- C C FAMILY C ------ C INPUT/OUTPUT C C PURPOSE C ------- C TO DETERMINE IF THERE IS ROOM TO PRINT THE SPECIFIED NUMBER C OF LINES ON THE CURRENT PAGE. IF THERE IS NOT, A NEW PAGE C IS BEGUN AND A HEADING IS PRINTED. C C PARAMETERS C ---------- C IL -I- NUMBER OF LINES TO BE PRINTED C C---------------------------------------------------------------------- INTEGER IL C C INPUT / OUTPUT CONTROL INTERFACE C CHARACTER*1 CBUFFR(2000) LOGICAL LBREAK, LFORT, LISTI, LISTO INTEGER ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOMC / CBUFFR COMMON / IOCOMI / ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOML / LBREAK, LFORT, LISTI, LISTO C ILCTR = ILCTR + IL IF (ILCTR .LE. ILPP) GO TO 999 IPAGE = IPAGE + 1 ILCTR = 3 + IL WRITE (IUNITL,1010) IPAGE C 999 CONTINUE RETURN 1010 FORMAT('1', 'PURDUE UNIVERSITY TEMPLATE PROCESSOR ', A '(V2 - 07/31/83) PAGE', I6 //) END SUBROUTINE IORDLN (CLINE, ICL1, ICL2, IUNIT) C C---------------------------------------------------------------------- C C FAMILY C ------ C INPUT/OUTPUT C C PURPOSE C ------- C TO READ A LINE INTO THE INPUT/OUTPUT BUFFER. THIS C MAY BE REPLACED BY A MORE EFFICIENT LOCAL I/O ROUTINE C C PARAMETERS C ---------- C CLINE -I- I/O BUFFER C ICL1 -I- INDEX OF THE FIRST CHARACTER TO BE READ C ICL2 -I- INDEX OF THE LAST CHARACTER TO BE READ C IUNIT -I- INPUT UNIT NUMBER C C---------------------------------------------------------------------- C INTEGER ICL1, ICL2, IUNIT CHARACTER*(*) CLINE(ICL2) INTEGER I, IBOT C C ACCESS CDIR DIRECTIVE PREFIX C C C TEMPLATE PROCESSOR INTERFACE C CHARACTER*1 CDIR, CSTAR INTEGER ICBP1(4), ICBP2(4) INTEGER ITOPDO, IARGS, INESTD, INESTF LOGICAL LCOL1, LDIRL, LEND, LINITM, L1TRIP COMMON / TPCOMC / CDIR, CSTAR COMMON / TPCOMI / ICBP1, ITOPDO, IARGS, ICBP2, INESTD, B INESTF COMMON / TPCOML / LCOL1, LDIRL, LEND, LINITM, L1TRIP C CHARACTER*1 STREND(5) SAVE STREND DATA STREND(1)/'*'/,STREND(2)/'E'/,STREND(3)/'N'/ DATA STREND(4)/'D'/,STREND(5)/' '/ C READ (IUNIT, 1010, END=999) (CLINE(I), I=ICL1,ICL2) RETURN 999 CONTINUE STREND(1) = CDIR DO 10 I=1,4 CLINE(ICL1+I-1)=STREND(I) 10 CONTINUE IBOT=ICL1+4 DO 20 I=IBOT,ICL2 CLINE(I)=STREND(5) 20 CONTINUE 1010 FORMAT(132A1) END SUBROUTINE IOREAD C C---------------------------------------------------------------------- C C FAMILY C ------ C SUBSTITUTION PROCESSING C C PURPOSE C ------- C TO FILL THE BUFFER WITH A LINE, REMOVE THE TRAILING BLANKS, C SET THE BUFFER POINTERS, AND APPEND AN END-OF-LINE MARKER. C C---------------------------------------------------------------------- C C GLOBAL CONSTANTS C CHARACTER*1 CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 COMMON / GLCOMC / CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 C C INPUT / OUTPUT CONTROL INTERFACE C CHARACTER*1 CBUFFR(2000) LOGICAL LBREAK, LFORT, LISTI, LISTO INTEGER ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOMC / CBUFFR COMMON / IOCOMI / ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOML / LBREAK, LFORT, LISTI, LISTO C C MEMORY MANAGER INTERFACE C CHARACTER*1 CSTORE(20000) INTEGER IHASH(601), ISTORE(6000) INTEGER ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS COMMON / MMCOMC / CSTORE COMMON / MMCOMH / IHASH COMMON / MMCOMS / ISTORE COMMON / MMCOMI / ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS C C MACRO PROCESSOR INTERFACE C CHARACTER*1 CDIV, CEOL, CEOR, CONC, CSUB, A CTOP LOGICAL LEMPTY, LSUB COMMON / MPCOMC / CDIV, CEOL, CEOR, CONC, CSUB, A CTOP COMMON / MPCOML / LEMPTY, LSUB EXTERNAL IORDLN, IOLIST, IOERRM C C IF THERE IS ENOUGH SPACE IN THE BUFFER C READ A LINE FROM THE INPUT FILE C ICB1 = ICB2 + 1 ICB2 = ICB2 + ICPLI IF (ICB2+2 .GT. ICBDIM) GO TO 30 CALL IORDLN (CBUFFR, ICB1, ICB2, IUNITI) IF (LISTI) CALL IOLIST (.TRUE.) C C REMOVE TRAILING BLANKS C 10 CONTINUE IF (CBUFFR(ICB2) .NE. CBLANK) GO TO 20 ICB2 = ICB2 - 1 IF (ICB2 .GE. ICB1) GO TO 10 C C ADD THE END-OF-LINE MARKER C 20 CONTINUE CBUFFR(ICB2+1) = CSUB CBUFFR(ICB2+2) = CEOL ICB3 = ICB2 ICBEOL = ICB2 + 2 ICBEND = ICBEOL GO TO 999 C 30 CONTINUE CALL IOERRM (.TRUE., A '('' ******** IOREAD - BUFFER SPACE EXCEEDED'')') C 999 CONTINUE RETURN END SUBROUTINE IOWRIT C C---------------------------------------------------------------------- C C FAMILY C ------ C SUBSTITUTION PROCESSING C C PURPOSE C ------- C TO WRITE THE LINE CURRENTLY IN THE BUFFER TO THE OUTPUT FILE. C IF THE -BREAK- OPTION IS SPECIFIED, AN ATTEMPT WILL BE MADE TO C BREAK LONG LINES AT A BLANK, RIGHT PARENTHESIS, COMMA, OR AN C ARITHMETIC OPERATOR. IF THE -FORTRAN- OPTION IS SPECIFIED, C CONTINUATION LINES WILL BE WRITTEN WITH CONTINUATION CHARACTERS C IN COLUMN SIX UNLESS THE LINE IS A COMMENT. C C---------------------------------------------------------------------- C C GLOBAL CONSTANTS C CHARACTER*1 CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 COMMON / GLCOMC / CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 C C INPUT / OUTPUT CONTROL INTERFACE C CHARACTER*1 CBUFFR(2000) LOGICAL LBREAK, LFORT, LISTI, LISTO INTEGER ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOMC / CBUFFR COMMON / IOCOMI / ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOML / LBREAK, LFORT, LISTI, LISTO C C MEMORY MANAGER INTERFACE C CHARACTER*1 CSTORE(20000) INTEGER IHASH(601), ISTORE(6000) INTEGER ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS COMMON / MMCOMC / CSTORE COMMON / MMCOMH / IHASH COMMON / MMCOMS / ISTORE COMMON / MMCOMI / ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS C C MACRO PROCESSOR INTERFACE C CHARACTER*1 CDIV, CEOL, CEOR, CONC, CSUB, A CTOP LOGICAL LEMPTY, LSUB COMMON / MPCOMC / CDIV, CEOL, CEOR, CONC, CSUB, A CTOP COMMON / MPCOML / LEMPTY, LSUB C C LOCAL VARIABLES AND PARAMETERS C CHARACTER*1 C(7), CBI, COL1 INTEGER ICDIM, I, IC, ICB SAVE ICDIM, C EXTERNAL IOWRLN, IOLIST DATA ICDIM / 7 / DATA A C(1), C(2), C(3), C(4), C(5), C(6), C(7) B / ' ', ')', ',', '/', '*', '-', '+' / C ICB1 = ICB0 COL1 = CBUFFR(ICB1) IF (ICB1 .LE. ICB3) GO TO 10 CBUFFR(ICB1) = CBLANK ICB2 = ICB1 GO TO 60 C 10 CONTINUE ICB2 = MIN0(ICB1+ICPLO-1,ICB3) IF (ICB2 .EQ. ICB3) GO TO 60 IF (.NOT. LBREAK) GO TO 40 C C FIND A PLACE TO BREAK THE LINE. C DO 30 I=1,10 CBI = CBUFFR(ICB2) DO 20 IC=1,ICDIM IF (C(IC) .EQ. CBI) GO TO 30 20 CONTINUE ICB2 = ICB2 - 1 30 CONTINUE C C WRITE THE LINE C 40 CONTINUE CALL IOWRLN (CBUFFR, ICB1, ICB2, IUNITO) IF (LISTO) CALL IOLIST (.NOT.LISTI) ICB1 = ICB2 + ICBADD IF (.NOT. LFORT) GO TO 10 C C PAD THE BEGINNING OF THE THE LINE C WITH THE STRING BBBBBZBBBB (B=BLANK) C DO 50 ICB=ICB1,ICB2 CBUFFR(ICB) = CBLANK 50 CONTINUE IF (COL1 .EQ. CC) CBUFFR(ICB1) = CC IF (COL1 .NE. CC) CBUFFR(ICB1+5) = CZ GO TO 10 C 60 CONTINUE CALL IOWRLN (CBUFFR, ICB1, ICB2, IUNITO) IF (LISTO) CALL IOLIST (.NOT.LISTI) C RETURN END SUBROUTINE IOWRLN (CLINE, ICL1, ICL2, IUNIT) C C---------------------------------------------------------------------- C C FAMILY C ------ C INPUT/OUTPUT C C PURPOSE C ------- C TO WRITE A LINE FROM THE INPUT/OUTPUT BUFFER. THIS C MAY BE REPLACED BY A MORE EFFICIENT LOCAL I/O ROUTINE C C PARAMETERS C ---------- C CLINE -I- I/O BUFFER C ICL1 -I- INDEX OF THE FIRST CHARACTER TO BE WRITTEN C ICL2 -I- INDEX OF THE LAST CHARACTER TO BE WRITTEN C IUNIT -I- OUTPUT UNIT NUMBER C C---------------------------------------------------------------------- INTEGER ICL1, ICL2, IUNIT CHARACTER*(*) CLINE(ICL2) INTEGER I C WRITE (IUNIT, 1010) (CLINE(I), I=ICL1,ICL2) C RETURN 1010 FORMAT(132A1) END SUBROUTINE MMAPPV (CNAME, ICN1, ICN2, CVALUE, ICV1, ICV2) C C---------------------------------------------------------------------- C C FAMILY C ------ C MEMORY MANAGER C C PURPOSE C ------- C TO APPEND A STRING TO A VARIABLE C C PARAMETERS C ---------- C CNAME -I- ARRAY CONTAINING THE NAME OF THE VARIABLE C ICN1 -I- INDEX OF THE FIRST CHARACTER IN THE NAME C ICN2 -I- INDEX OF THE LAST CHARACTER IN THE NAME C CVALUE -I- ARRAY CONTAINING THE STRING TO BE APPENDED C ICV1 -I- INDEX OF THE FIRST CHARACTER IN THE STRING C ICV2 -I- INDEX OF THE LAST CHARACTER IN THE STRING C C---------------------------------------------------------------------- C C GLOBAL CONSTANTS C CHARACTER*1 CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 COMMON / GLCOMC / CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 C C INPUT / OUTPUT CONTROL INTERFACE C CHARACTER*1 CBUFFR(2000) LOGICAL LBREAK, LFORT, LISTI, LISTO INTEGER ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOMC / CBUFFR COMMON / IOCOMI / ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOML / LBREAK, LFORT, LISTI, LISTO C C MEMORY MANAGER INTERFACE C CHARACTER*1 CSTORE(20000) INTEGER IHASH(601), ISTORE(6000) INTEGER ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS COMMON / MMCOMC / CSTORE COMMON / MMCOMH / IHASH COMMON / MMCOMS / ISTORE COMMON / MMCOMI / ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS C C LOCAL VARIABLES AND PARAMETERS C INTEGER ICN1, ICN2, ICV1, ICV2 CHARACTER*(*) CNAME(ICN2), CVALUE(ICV2) LOGICAL LFOUND INTEGER IH, IS1, I, IS2 EXTERNAL MMHASH, MMNEWI, MMPUT1 C C HASH THE VARIABLE NAME TO SEE IF IT EXISTS. C IF IT DOES NOT, CREATE IT AND RETURN. C CALL MMHASH (CNAME, ICN1, ICN2, IH, LFOUND) IF (LFOUND) GO TO 10 CALL MMNEWI (IS1) IHASH(IH) = IS1 CALL MMPUT1 (CNAME, ICN1, ICN2, ISTORE(IS1), I) CALL MMPUT1 (CVALUE, ICV1, ICV2, ISTORE(IS1+1), A ISTORE(IS1+2)) GO TO 999 C C THE VARIABLE ALREADY EXISTS. APPEND THE VALUE. C 10 CONTINUE IS1 = IHASH(IH) IS2 = ISTORE(IS1+2) CALL MMPUT1 (CVALUE, ICV1, ICV2, ISTORE(IS2+2), ISTORE(IS1+2)) C 999 CONTINUE RETURN END SUBROUTINE MMDELV (CNAME, ICN1, ICN2, LFOUND) C C---------------------------------------------------------------------- C C FAMILY C ------ C MEMORY MANAGER C C PURPOSE C ------- C TO DELETE A VARIABLE C C PARAMETERS C ---------- C CNAME -I- ARRAY CONTAINING THE NAME OF THE VARIABLE C ICN1 -I- INDEX OF THE FIRST CHARACTER IN THE NAME C ICN2 -I- INDEX OF THE LAST CHARACTER IN THE NAME C LFOUND -O- TRUE IF THE VARIABLE EXISTED C C---------------------------------------------------------------------- C C GLOBAL CONSTANTS C CHARACTER*1 CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 COMMON / GLCOMC / CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 C C INPUT / OUTPUT CONTROL INTERFACE C CHARACTER*1 CBUFFR(2000) LOGICAL LBREAK, LFORT, LISTI, LISTO INTEGER ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOMC / CBUFFR COMMON / IOCOMI / ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOML / LBREAK, LFORT, LISTI, LISTO C C MEMORY MANAGER INTERFACE C CHARACTER*1 CSTORE(20000) INTEGER IHASH(601), ISTORE(6000) INTEGER ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS COMMON / MMCOMC / CSTORE COMMON / MMCOMH / IHASH COMMON / MMCOMS / ISTORE COMMON / MMCOMI / ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS C C LOCAL VARIABLES AND PARAMETERS C INTEGER ICN1, ICN2 CHARACTER*(*) CNAME(ICN2) LOGICAL LFOUND INTEGER IH, IS1 EXTERNAL MMHASH, MMDEL1, MMRETI C C IF THE VARIABLE EXISTS, DELETE IT BY RETURNING THE SPACE C TAKEN UP BY IT-S NAME AND VALUE, RETURNING THE SPACE POINTER, C AND ZEROING OUT THE HASH TABLE ENTRY. C CALL MMHASH (CNAME, ICN1, ICN2, IH, LFOUND) IF (.NOT. LFOUND) GO TO 999 IS1 = IHASH(IH) CALL MMDEL1 (ISTORE(IS1)) CALL MMDEL1 (ISTORE(IS1+1)) CALL MMRETI (IS1) IHASH(IH) = 0 C 999 CONTINUE RETURN END SUBROUTINE MMDEL1 (IS2) C C---------------------------------------------------------------------- C C FAMILY C ------ C MEMORY MANAGER C C PURPOSE C ------- C TO RETURN BLOCKS OF CHARACTER STORAGE TO THE FREE SPACE POOL C C PARAMETERS C ---------- C IS2 -I- POINTER TO THE FIRST LINK IN A LIST C OF CHARACTER STORAGE BLOCKS C C---------------------------------------------------------------------- INTEGER IS2 C C GLOBAL CONSTANTS C CHARACTER*1 CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 COMMON / GLCOMC / CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 C C INPUT / OUTPUT CONTROL INTERFACE C CHARACTER*1 CBUFFR(2000) LOGICAL LBREAK, LFORT, LISTI, LISTO INTEGER ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOMC / CBUFFR COMMON / IOCOMI / ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOML / LBREAK, LFORT, LISTI, LISTO C C MEMORY MANAGER INTERFACE C CHARACTER*1 CSTORE(20000) INTEGER IHASH(601), ISTORE(6000) INTEGER ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS COMMON / MMCOMC / CSTORE COMMON / MMCOMH / IHASH COMMON / MMCOMS / ISTORE COMMON / MMCOMI / ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS INTEGER IS C IS = IS2 IF (IS .EQ. 0) GO TO 999 C C LOOP THROUGH EVERY LINK TO FIND THE TAIL C 10 CONTINUE IF (ISTORE(IS+2) .EQ. 0) GO TO 20 IS = ISTORE(IS+2) GO TO 10 C C ATTACH THE LIST TO THE FREE SPACE POOL AND C RESET THE FREE SPACE HEAD POINTER C 20 CONTINUE ISTORE(IS+2) = IS2HDC IS2HDC = IS2 C C 999 CONTINUE RETURN END SUBROUTINE MMGETV (CNAME, ICN1, ICN2, A CVALUE, ICV1, ICV2, ICVDIM, LFOUND) C C---------------------------------------------------------------------- C C FAMILY C ------ C MEMORY MANAGER C C PURPOSE C ------- C TO GET THE VALUE OF THE NAMED VARIABLE FROM THE STORAGE C POOL AND COPY IT INTO THE SPECIFIED ARRAY. C C PARAMETERS C ---------- C CNAME -I- ARRAY CONTAINING THE NAME OF THE VARIABLE C ICN1 -I- INDEX OF THE FIRST CHARACTER IN THE NAME C ICN2 -I- INDEX OF THE LAST CHARACTER IN THE NAME C CVALUE -O- ARRAY TO CONTAIN THE VALUE OF THE VARIABLE C ICV1 -O- INDEX OF THE FIRST CHARACTER IN THE VALUE C ICV2 -O- INDEX OF THE LAST CHARACTER IN THE VALUE C ICVDIM -I- LENGTH OF ARRAY CVALUE C LFOUND -O- TRUE IF THE VARIABLE EXISTS C C---------------------------------------------------------------------- C C GLOBAL CONSTANTS C CHARACTER*1 CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 COMMON / GLCOMC / CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 C C INPUT / OUTPUT CONTROL INTERFACE C CHARACTER*1 CBUFFR(2000) LOGICAL LBREAK, LFORT, LISTI, LISTO INTEGER ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOMC / CBUFFR COMMON / IOCOMI / ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOML / LBREAK, LFORT, LISTI, LISTO C C MEMORY MANAGER INTERFACE C CHARACTER*1 CSTORE(20000) INTEGER IHASH(601), ISTORE(6000) INTEGER ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS COMMON / MMCOMC / CSTORE COMMON / MMCOMH / IHASH COMMON / MMCOMS / ISTORE COMMON / MMCOMI / ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS C C LOCAL VARIABLES AND PARAMETERS C INTEGER ICN1, ICN2, ICV1, ICV2, ICVDIM CHARACTER*(*) CNAME(ICN2), CVALUE(ICVDIM) LOGICAL LFOUND INTEGER IH, IS1, IS2H EXTERNAL MMHASH, MMGET1 C C IF THE VARIABLE EXISTS, COPY ITS VALUE C ICV2 = 0 CALL MMHASH (CNAME, ICN1, ICN2, IH, LFOUND) IF (.NOT. LFOUND) GO TO 999 IS1 = IHASH(IH) IS2H = ISTORE(IS1+1) CALL MMGET1 (CVALUE, ICV1, ICV2, ICVDIM, IS2H) C 999 CONTINUE RETURN END SUBROUTINE MMGET1 (CVALUE, ICV1, ICV2, ICVDIM, IS2H) C C---------------------------------------------------------------------- C C FAMILY C ------ C MEMORY MANAGER C C PURPOSE C ------- C TO COPY THE STRING SPECIFIED BY THE POINTER IS2H C AND COPY IT INTO A SPECIFIED ARRAY. C C PARAMETERS C ---------- C CVALUE -O- ARRAY TO CONTAIN THE VALUE OF THE VARIABLE C ICV1 -O- INDEX OF THE FIRST CHARACTER IN THE VALUE C ICV2 -O- INDEX OF THE LAST CHARACTER IN THE VALUE C ICVDIM -I- LENGTH OF ARRAY CVALUE C IS2H -I- HEAD POINTER TO THE LINKED LIST OF C BLOCKS CONTAINING THE STRING VALUE C C---------------------------------------------------------------------- C C GLOBAL CONSTANTS C CHARACTER*1 CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 COMMON / GLCOMC / CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 C C INPUT / OUTPUT CONTROL INTERFACE C CHARACTER*1 CBUFFR(2000) LOGICAL LBREAK, LFORT, LISTI, LISTO INTEGER ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOMC / CBUFFR COMMON / IOCOMI / ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOML / LBREAK, LFORT, LISTI, LISTO C C MEMORY MANAGER INTERFACE C CHARACTER*1 CSTORE(20000) INTEGER IHASH(601), ISTORE(6000) INTEGER ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS COMMON / MMCOMC / CSTORE COMMON / MMCOMH / IHASH COMMON / MMCOMS / ISTORE COMMON / MMCOMI / ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS C C LOCAL VARIABLES AND PARAMETERS C INTEGER ICV1, ICV2, ICVDIM, IS2H CHARACTER*(*) CVALUE(ICVDIM) INTEGER ICS1, ICS2, ICS, IS2 EXTERNAL IOERRM C IS2 = IS2H ICV2 = ICV1 - 1 C C LOOP THROUGH EACH BLOCK IN WHICH THE STRING IS STORED C 10 CONTINUE IF (IS2 .EQ. 0) GO TO 999 ICS1 = ISTORE(IS2) ICS2 = ISTORE(IS2+1) IS2 = ISTORE(IS2+2) IF (ICV2+ICS2-ICS1 .GE. ICVDIM) GO TO 30 C C LOOP OVER EACH CHARACTER IN THIS BLOCK C DO 20 ICS=ICS1,ICS2 ICV2 = ICV2 + 1 CVALUE(ICV2) = CSTORE(ICS) 20 CONTINUE GO TO 10 C 30 CONTINUE CALL IOERRM (.TRUE., A '('' ******** MMGET1 - STRING TOO LONG FOR CVALUE(*)'')') C 999 CONTINUE RETURN END SUBROUTINE MMHASH (CNAME, ICN1, ICN2, IH, LFOUND) C C---------------------------------------------------------------------- C C FAMILY C ------ C MEMORY MANAGER C C PURPOSE C ------- C TO HASH A NAME AND RETURN IT-S HASH TABLE INDEX C C PARAMETERS C ---------- C CNAME -I- ARRAY CONTAINING THE NAME OF THE VARIABLE C ICN1 -I- INDEX OF THE FIRST CHARACTER IN THE NAME C ICN2 -I- INDEX OF THE LAST CHARACTER IN THE NAME C IH -O- HASH INDEX INTO ARRAY IHASH C LFOUND -O- TRUE IF THE VARIABLE IS ALREADY IN THE TABLE C C---------------------------------------------------------------------- C C GLOBAL CONSTANTS C CHARACTER*1 CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 COMMON / GLCOMC / CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 C C INPUT / OUTPUT CONTROL INTERFACE C CHARACTER*1 CBUFFR(2000) LOGICAL LBREAK, LFORT, LISTI, LISTO INTEGER ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOMC / CBUFFR COMMON / IOCOMI / ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOML / LBREAK, LFORT, LISTI, LISTO C C MEMORY MANAGER INTERFACE C CHARACTER*1 CSTORE(20000) INTEGER IHASH(601), ISTORE(6000) INTEGER ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS COMMON / MMCOMC / CSTORE COMMON / MMCOMH / IHASH COMMON / MMCOMS / ISTORE COMMON / MMCOMI / ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS C C LOCAL VARIABLES AND PARAMETERS C INTEGER ICN1, ICN2, IH CHARACTER*(*) CNAME(ICN2) LOGICAL LERROR, LFOUND INTEGER INAME, IADD, I, IS1 EXTERNAL UTCVNI, MMTEST, IOERRM C C ENCODE THE NAME INTO AN INTEGER C CALL UTCVNI (CNAME, ICN1, ICN2, INAME, LERROR) INAME = MOD(INAME, IHADIM) IADD = MAX0(1, INAME) LFOUND = .FALSE. C C LOOP THROUGH ENTRIES IN THE TABLE UNTIL THE C NAME IS FOUND OR AN EMPTY BUCKET IS REACHED C DO 10 I=1,IHADIM IH = INAME + 1 IS1 = IHASH(IH) IF (IS1 .EQ. 0) GO TO 999 CALL MMTEST (CNAME, ICN1, ICN2, ISTORE(IS1), LFOUND) IF (LFOUND) GO TO 999 INAME = MOD(INAME+IADD, IHADIM) 10 CONTINUE C C EXIT FROM THE ABOVE LOOP INDICATES THAT THE HASH C TABLE IS FULL. TO OBTAIN MORE SPACE THE PROCESSOR C MUST BE RECOMPILED WITH A LARGER DIMENSION -IHADIM- C FOR ARRAY IHASH. IHADIM SHOULD BE A PRIME NUMBER. C CALL IOERRM (.TRUE., A '('' ******** MMHASH - HASH TABLE ARRAY IHASH(*) IS FULL'')') C 999 CONTINUE RETURN END SUBROUTINE MMINIT C C----------------------------------------------------------------------- C C FAMILY C ------ C MEMORY MANAGER C C PURPOSE C ------- C TO INITIALIZE MEMORY MANAGER VARIABLES C C----------------------------------------------------------------------- C C GLOBAL CONSTANTS C CHARACTER*1 CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 COMMON / GLCOMC / CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 C C INPUT / OUTPUT CONTROL INTERFACE C CHARACTER*1 CBUFFR(2000) LOGICAL LBREAK, LFORT, LISTI, LISTO INTEGER ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOMC / CBUFFR COMMON / IOCOMI / ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOML / LBREAK, LFORT, LISTI, LISTO C C MEMORY MANAGER INTERFACE C CHARACTER*1 CSTORE(20000) INTEGER IHASH(601), ISTORE(6000) INTEGER ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS COMMON / MMCOMC / CSTORE COMMON / MMCOMH / IHASH COMMON / MMCOMS / ISTORE COMMON / MMCOMI / ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS INTEGER I EXTERNAL MMNEWI C DO 10 I=1,IHADIM IHASH(I) = 0 10 CONTINUE C DO 20 I=1,ISTDIM,3 ISTORE(I) = 0 ISTORE(I+1) = 0 ISTORE(I+2) = I + 3 20 CONTINUE C ISTORE(ISTDIM) = 0 ISFREE = 1 C CALL MMNEWI (IS2HDC) ISTORE(IS2HDC) = 1 ISTORE(IS2HDC+1) = ICSDIM ISTORE(IS2HDC+2) = 0 IS2HDS = 0 ICSP1 = 1 ICSP2 = 0 C RETURN END SUBROUTINE MMNEWI (IS) C C----------------------------------------------------------------------- C C FAMILY C ------ C MEMORY MANAGER C C PURPOSE C ------- C TO RETURN A POINTER TO AN AVAILABLE BLOCK FROM THE INTEGER C STORAGE POOL C C PARAMETERS C ---------- C IS -O- INDEX INTO ARRAY ISTORE OF THE FREE BLOCK C C----------------------------------------------------------------------- C C GLOBAL CONSTANTS C CHARACTER*1 CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 COMMON / GLCOMC / CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 C C INPUT / OUTPUT CONTROL INTERFACE C CHARACTER*1 CBUFFR(2000) LOGICAL LBREAK, LFORT, LISTI, LISTO INTEGER ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOMC / CBUFFR COMMON / IOCOMI / ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOML / LBREAK, LFORT, LISTI, LISTO C C MEMORY MANAGER INTERFACE C CHARACTER*1 CSTORE(20000) INTEGER IHASH(601), ISTORE(6000) INTEGER ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS COMMON / MMCOMC / CSTORE COMMON / MMCOMH / IHASH COMMON / MMCOMS / ISTORE COMMON / MMCOMI / ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS INTEGER IS EXTERNAL IOERRM C IF (ISFREE .EQ. 0) GO TO 10 IS = ISFREE ISFREE = ISTORE(ISFREE+2) GO TO 999 C 10 CONTINUE CALL IOERRM (.TRUE., A '('' ******** MMNEWI - STORAGE ARRAY ISTORE(*) IS FULL'')') C 999 CONTINUE RETURN END SUBROUTINE MMPOPC (CTEST, IPOP, CTOP, LEMPTY) C C----------------------------------------------------------------------- C C FAMILY C ------ C MEMORY MANAGER C C PURPOSE C ------- C TO POP CHARACTERS OFF THE SUBSTITUTION STACK C C PARAMETERS C ---------- C CTEST -I- CHARACTER WHOSE PURPOSE DEPENDS ON IPOP C IPOP -I- INDICATES THE OPERATION TO BE PERFORMED C 1 - LOOK AT THE TOP CHARACTER C 2 - POP ONE CHARACTER OFF THE STACK C 3 - POP ONE VARIABLE OFF THE STACK C 4 - POP UNTIL TOP .NE. CTEST C 5 - POP UNTIL TOP .EQ. CTEST C 6 - POP ALL ALPHNUMERICS C CTOP -O- TOP CHARACTER ON STACK C LEMPTY -I- TRUE IF STACK IS EMPTY C C----------------------------------------------------------------------- C C GLOBAL CONSTANTS C CHARACTER*1 CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 COMMON / GLCOMC / CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 C C INPUT / OUTPUT CONTROL INTERFACE C CHARACTER*1 CBUFFR(2000) LOGICAL LBREAK, LFORT, LISTI, LISTO INTEGER ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOMC / CBUFFR COMMON / IOCOMI / ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOML / LBREAK, LFORT, LISTI, LISTO C C MEMORY MANAGER INTERFACE C CHARACTER*1 CSTORE(20000) INTEGER IHASH(601), ISTORE(6000) INTEGER ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS COMMON / MMCOMC / CSTORE COMMON / MMCOMH / IHASH COMMON / MMCOMS / ISTORE COMMON / MMCOMI / ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS C C LOCAL VARIABLES AND PARAMETERS C INTEGER IPOP CHARACTER*(*) CTEST, CTOP INTEGER ICS LOGICAL LEMPTY EXTERNAL MMPOP1, MMPOPV, IOERRM C 10 CONTINUE CTOP = CBLANK C C CHECK FOR NULL ENTRIES ON STACK C IF (ICSP1 .GT. ICSP2) CALL MMPOP1 (LEMPTY) IF (LEMPTY) GO TO 999 GO TO (20, 30, 40, 50, 70, 90), IPOP C C IPOP = 1 - LOOK AT THE TOP OF THE STACK C 20 CONTINUE CTOP = CSTORE(ICSP1) GO TO 999 C C IPOP = 2 - POP ONE CHARACTER OFF THE STACK C 30 CONTINUE ICB2 = ICB2 + 1 IF (ICB2 .GT. ICBDIM) GO TO 130 CBUFFR(ICB2) = CSTORE(ICSP1) ICSP1 = ICSP1 + 1 ISTORE(IS2HDS+1) = ICSP1 IF (ICSP1 .GT. ICSP2) CALL MMPOP1 (LEMPTY) IF (.NOT. LEMPTY) CTOP = CSTORE(ICSP1) GO TO 999 C C IPOP = 3 - POP ONE VARIABLE OFF THE STACK C 40 CONTINUE ICB2 = ICB2 + 1 IF (ICB2 .GT. ICBDIM) GO TO 130 CBUFFR(ICB2) = CSTORE(ICSP1) ISTORE(IS2HDS+1) = ICSP1 + 1 CALL MMPOPV (LEMPTY) CALL MMPOP1 (LEMPTY) IF (.NOT. LEMPTY) CTOP = CSTORE(ICSP1) GO TO 999 C C IPOP = 4 - POP UNTIL TOP CHAR .NE. CTEST C 50 CONTINUE IF (ICSP2-ICSP1 .GE. ICBDIM-ICB2) GO TO 130 DO 60 ICS=ICSP1,ICSP2 IF (CSTORE(ICS) .NE. CTEST) GO TO 120 ICB2 = ICB2 + 1 CBUFFR(ICB2) = CSTORE(ICS) 60 CONTINUE GO TO 110 C C IPOP = 5 - POP UNTIL TOP CHAR .EQ. CTEST C 70 CONTINUE IF (ICSP2-ICSP1 .GE. ICBDIM-ICB2) GO TO 130 DO 80 ICS=ICSP1,ICSP2 IF (CSTORE(ICS) .EQ. CTEST) GO TO 120 ICB2 = ICB2 + 1 CBUFFR(ICB2) = CSTORE(ICS) 80 CONTINUE GO TO 110 C C IPOP = 6 - POP ALL ALPHANUMERICS OFF THE STACK C 90 CONTINUE IF (ICSP2-ICSP1 .GE. ICBDIM-ICB2) GO TO 130 DO 100 ICS=ICSP1,ICSP2 IF (.NOT. ((LLE(CA,CSTORE(ICS)) A .AND. LLE(CSTORE(ICS),CZ)) B .OR. (LLE(C0,CSTORE(ICS)) C .AND. LLE(CSTORE(ICS),C9)))) GO TO 120 ICB2 = ICB2 + 1 CBUFFR(ICB2) = CSTORE(ICS) 100 CONTINUE C C THE SPECIFIED CONDITION HAS NOT BEEN MET. C GET ANOTHER PIECE OF THE STACK AND TRY AGAIN. C 110 CONTINUE ICSP1 = ICSP2 + 1 ISTORE(IS2HDS+1) = ICSP1 GO TO 10 C C THE SPECIFIED CONDITION HAS BEEN MET. C SAVE THE STACK POINTER AND RETURN. C 120 CONTINUE ICSP1 = ICS ISTORE(IS2HDS+1) = ICS CTOP = CSTORE(ICS) GO TO 999 C C THE BUFFER SPACE HAS BEEN EXCEEDED C 130 CONTINUE CALL IOERRM (.TRUE., A '('' ******** MMPOPC - STRING TOO LONG FOR BUFFER'')') C 999 CONTINUE RETURN END SUBROUTINE MMPOPV (LEMPTY) C C----------------------------------------------------------------------- C C FAMILY C ------ C MEMORY MANAGER C C PURPOSE C ------- C TO POP A VARIABLE OFF THE SUBSTITUTION STACK C C PARAMETERS C ---------- C LEMPTY -O- TRUE IF THE STACK IS EMPTY C C----------------------------------------------------------------------- C C GLOBAL CONSTANTS C CHARACTER*1 CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 COMMON / GLCOMC / CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 C C INPUT / OUTPUT CONTROL INTERFACE C CHARACTER*1 CBUFFR(2000) LOGICAL LBREAK, LFORT, LISTI, LISTO INTEGER ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOMC / CBUFFR COMMON / IOCOMI / ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOML / LBREAK, LFORT, LISTI, LISTO C C MEMORY MANAGER INTERFACE C CHARACTER*1 CSTORE(20000) INTEGER IHASH(601), ISTORE(6000) INTEGER ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS COMMON / MMCOMC / CSTORE COMMON / MMCOMH / IHASH COMMON / MMCOMS / ISTORE COMMON / MMCOMI / ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS C C LOCAL VARIABLES AND PARAMETERS C LOGICAL LEMPTY INTEGER IS2 EXTERNAL MMRETI C LEMPTY = IS2HDS .EQ. 0 IF (LEMPTY) GO TO 999 IS2 = IS2HDS IS2HDS = ISTORE(IS2+2) ISTORE(IS2+2) = 0 LEMPTY = IS2HDS .EQ. 0 IF (ISTORE(IS2) .GT. 0) CALL MMRETI (IS2) C 999 CONTINUE RETURN END SUBROUTINE MMPOP1 (LEMPTY) C C----------------------------------------------------------------------- C C FAMILY C ------ C MEMORY MANAGER C C PURPOSE C ------- C TO POP NULL ENTRIES OFF THE SUBSTITUTION STACK C C PARAMETERS C ---------- C LEMPTY -O- TRUE IF THE STACK IS EMPTY C C----------------------------------------------------------------------- C C GLOBAL CONSTANTS C CHARACTER*1 CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 COMMON / GLCOMC / CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 C C INPUT / OUTPUT CONTROL INTERFACE C CHARACTER*1 CBUFFR(2000) LOGICAL LBREAK, LFORT, LISTI, LISTO INTEGER ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOMC / CBUFFR COMMON / IOCOMI / ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOML / LBREAK, LFORT, LISTI, LISTO C C MEMORY MANAGER INTERFACE C CHARACTER*1 CSTORE(20000) INTEGER IHASH(601), ISTORE(6000) INTEGER ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS COMMON / MMCOMC / CSTORE COMMON / MMCOMH / IHASH COMMON / MMCOMS / ISTORE COMMON / MMCOMI / ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS C C LOCAL VARIABLES AND PARAMETERS C LOGICAL LEMPTY INTEGER IS2 EXTERNAL MMPOPV C 10 CONTINUE LEMPTY = IS2HDS .EQ. 0 IF (LEMPTY) GO TO 999 IS2 = IABS(ISTORE(IS2HDS)) IF (IS2 .NE. 0) GO TO 30 20 CONTINUE CALL MMPOPV (LEMPTY) GO TO 10 C 30 CONTINUE ICSP1 = ISTORE(IS2HDS+1) ICSP2 = ISTORE(IS2+1) IF (ICSP1 .LE. ICSP2) GO TO 999 IS2 = ISTORE(IS2+2) IF (IS2 .EQ. 0) GO TO 20 ISTORE(IS2HDS) = ISIGN(IS2, ISTORE(IS2HDS)) ISTORE(IS2HDS+1) = ISTORE(IS2) GO TO 30 C 999 CONTINUE RETURN END SUBROUTINE MMPSHV (CNAME, ICN1, ICN2, IPUSH, LEMPTY, LFOUND) C C----------------------------------------------------------------------- C C FAMILY C ------ C MEMORY MANAGER C C PURPOSE C ------- C TO PUSH A VARIABLE ONTO THE SUBSTITUTION STACK C C PARAMETERS C ---------- C CNAME -I- THE NAME OF THE VARIABLE TO PUSH ONTO THE STACK C ICN1 -I- INDEX OF THE FIRST CHARACTER IN THE NAME C ICN2 -I- INDEX OF THE LAST CHARACTER IN THE NAME C IPUSH -I- INDICATES THE OPERATION TO BE PERFORMED C 1 - PUSH A VARIABLE ONTO THE STACK C 2 - PUSH A POINTER ONTO THE STACK C 3 - PUSH THE ACTUAL POINTER ONTO THE STACK C C----------------------------------------------------------------------- C C GLOBAL CONSTANTS C CHARACTER*1 CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 COMMON / GLCOMC / CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 C C INPUT / OUTPUT CONTROL INTERFACE C CHARACTER*1 CBUFFR(2000) LOGICAL LBREAK, LFORT, LISTI, LISTO INTEGER ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOMC / CBUFFR COMMON / IOCOMI / ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOML / LBREAK, LFORT, LISTI, LISTO C C MEMORY MANAGER INTERFACE C CHARACTER*1 CSTORE(20000) INTEGER IHASH(601), ISTORE(6000) INTEGER ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS COMMON / MMCOMC / CSTORE COMMON / MMCOMH / IHASH COMMON / MMCOMS / ISTORE COMMON / MMCOMI / ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS C C LOCAL VARIABLES AND PARAMETERS C INTEGER ICN1, ICN2, IPUSH CHARACTER*(*) CNAME(ICN2) LOGICAL LEMPTY, LFOUND INTEGER IH, IS1, IS2, ITEMP EXTERNAL MMHASH, MMNEWI, MMPOP1 C CALL MMHASH (CNAME, ICN1, ICN2, IH, LFOUND) IF (.NOT. LFOUND) GO TO 999 IS1 = IHASH(IH) IS2 = ISTORE(IS1+1) IF (IS2 .EQ. 0) GO TO 999 IF (IPUSH .EQ. 1) GO TO 10 IF (IPUSH .EQ. 2) GO TO 20 GO TO 30 C C PUSH A VARIABLE ONTO THE STACK; NEW ENTRY WILL POINT TO C VALUE OF THE VARIABLE C 10 CONTINUE CALL MMNEWI (ITEMP) ISTORE(ITEMP) = IS2 ISTORE(ITEMP+1) = ISTORE(IS2) ISTORE(ITEMP+2) = IS2HDS IS2HDS = ITEMP GO TO 40 C C PUSH A POINTER ONTO THE STACK C 20 CONTINUE CALL MMNEWI (ITEMP) ISTORE(ITEMP) = ISTORE(IS2) ISTORE(ITEMP+1) = ISTORE(IS2+1) ISTORE(ITEMP+2) = IS2HDS IS2HDS = ITEMP GO TO 40 C C PUSH THE ACTUAL POINTER ONTO THE STACK C 30 CONTINUE ISTORE(IS2) = -IABS(ISTORE(IS2)) ISTORE(IS2+2) = IS2HDS IS2HDS = IS2 C C CALL MMPOP1 TO SET THE POINTERS (ICSP1, ICSP2) INTO CSTORE C 40 CONTINUE CALL MMPOP1 (LEMPTY) C 999 CONTINUE RETURN END SUBROUTINE MMPUTP (CNAME, ICN1, ICN2, CPTR, ICP1, ICP2, LFOUND) C C----------------------------------------------------------------------- C C FAMILY C ------ C MEMORY MANAGER C C PURPOSE C ------- C TO PUT A POINTER TO A VARIABLE IN THE SYMBOL TABLE C C PARAMETERS C ---------- C CNAME -I- NAME OF THE VARIABLE C ICN1 -I- INDEX OF THE FIRST CHARACTER IN THE NAME C ICN2 -I- INDEX OF THE LAST CHARACTER IN THE NAME C CPTR -I- NAME OF THE POINTER C ICP1 -I- INDEX OF THE FIRST CHARACTER IN THE POINTER NAME C ICP2 -I- INDEX OF THE LAST CHARACTER IN THE POINTER NAME C LFOUND -O- TRUE IF THE VARIABLE WAS FOUND IN THE TABLE C C----------------------------------------------------------------------- C C GLOBAL CONSTANTS C CHARACTER*1 CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 COMMON / GLCOMC / CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 C C INPUT / OUTPUT CONTROL INTERFACE C CHARACTER*1 CBUFFR(2000) LOGICAL LBREAK, LFORT, LISTI, LISTO INTEGER ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOMC / CBUFFR COMMON / IOCOMI / ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOML / LBREAK, LFORT, LISTI, LISTO C C MEMORY MANAGER INTERFACE C CHARACTER*1 CSTORE(20000) INTEGER IHASH(601), ISTORE(6000) INTEGER ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS COMMON / MMCOMC / CSTORE COMMON / MMCOMH / IHASH COMMON / MMCOMS / ISTORE COMMON / MMCOMI / ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS C C LOCAL VARIABLES AND PARAMETERS C INTEGER ICN1, ICN2, ICP1, ICP2 CHARACTER*(*) CNAME(ICN2), CPTR(ICP2) LOGICAL L, LFOUND INTEGER IH, IS1, IS2CN, I, IS2 EXTERNAL MMHASH, MMNEWI, MMPUT1 C CALL MMHASH (CNAME, ICN1, ICN2, IH, LFOUND) IF (.NOT. LFOUND) GO TO 999 IS1 = IHASH(IH) IS2CN = ISTORE(IS1+1) CALL MMHASH (CPTR, ICP1, ICP2, IH, L) IF (L) GO TO 10 CALL MMNEWI (IS1) IHASH(IH) = IS1 CALL MMPUT1 (CPTR, ICP1, ICP2, ISTORE(IS1), I) CALL MMNEWI (IS2) ISTORE(IS1+1) = IS2 ISTORE(IS1+2) = 0 GO TO 20 C 10 CONTINUE IS1 = IHASH(IH) IS2 = ISTORE(IS1+1) C 20 CONTINUE IF (IS2CN .NE. 0) GO TO 30 ISTORE(IS2) = 0 ISTORE(IS2+1) = 0 ISTORE(IS2+2) = 0 GO TO 999 C 30 CONTINUE ISTORE(IS2) = IS2CN ISTORE(IS2+1) = ISTORE(IS2CN) ISTORE(IS2+2) = 0 C 999 CONTINUE RETURN END SUBROUTINE MMPUTV (CNAME, ICN1, ICN2, CVALUE, ICV1, ICV2) C C----------------------------------------------------------------------- C C FAMILY C ------ C MEMORY MANAGER C C PURPOSE C ------- C TO PUT A VARIABLE INTO THE SYMBOL TABLE C C PARAMETERS C ---------- C CNAME -I- NAME OF THE VARIABLE C ICN1 -I- INDEX OF THE FIRST CHARACTER IN THE NAME C ICN2 -I- INDEX OF THE LAST CHARACTER IN THE NAME C CVALUE -I- VALUE OF THE VARIABLE C ICV1 -I- INDEX OF THE FIRST CHARACTER IN THE VALUE C ICV2 -I- INDEX OF THE LAST CHARACTER IN THE VALUE C C----------------------------------------------------------------------- C C GLOBAL CONSTANTS C CHARACTER*1 CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 COMMON / GLCOMC / CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 C C INPUT / OUTPUT CONTROL INTERFACE C CHARACTER*1 CBUFFR(2000) LOGICAL LBREAK, LFORT, LISTI, LISTO INTEGER ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOMC / CBUFFR COMMON / IOCOMI / ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOML / LBREAK, LFORT, LISTI, LISTO C C MEMORY MANAGER INTERFACE C CHARACTER*1 CSTORE(20000) INTEGER IHASH(601), ISTORE(6000) INTEGER ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS COMMON / MMCOMC / CSTORE COMMON / MMCOMH / IHASH COMMON / MMCOMS / ISTORE COMMON / MMCOMI / ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS C C LOCAL VARIABLES AND PARAMETERS C INTEGER ICN1, ICN2, ICV1, ICV2 CHARACTER*(*) CNAME(ICN2), CVALUE(ICV2) LOGICAL LFOUND INTEGER IH, IS1, I EXTERNAL MMHASH, MMNEWI, MMPUT1, MMDEL1 C C HASH THE NAME TO SEE IF IT IS IN THE TABLE. C IF IT IS NOT, STORE A NEW NAME IN THE TABLE. C CALL MMHASH (CNAME, ICN1, ICN2, IH, LFOUND) IF (LFOUND) GO TO 10 CALL MMNEWI (IS1) IHASH(IH) = IS1 CALL MMPUT1 (CNAME, ICN1, ICN2, ISTORE(IS1), I) GO TO 20 C C RETURN THE SPACE ALLOCATED TO THE OLD VALUE C 10 CONTINUE IS1 = IHASH(IH) CALL MMDEL1 (ISTORE(IS1+1)) C C STORE THE NEW VALUE IN THE TABLE C 20 CONTINUE CALL MMPUT1 (CVALUE, ICV1, ICV2, ISTORE(IS1+1), ISTORE(IS1+2)) C RETURN END SUBROUTINE MMPUT1 (CVALUE, ICV1, ICV2, IS2H, IS2T) C C----------------------------------------------------------------------- C C FAMILY C ------ C MEMORY MANAGER C C PURPOSE C ------- C TO PUT A STRING VALUE INTO CHARACTER STORAGE C AND RETURN POINTERS TO ITS LOCATION C C PARAMETERS C ---------- C CVALUE -I- CONTAINS THE CHARACTER STRING C ICV1 -I- INDEX OF THE FIRST CHARACTER IN THE STRING C ICV2 -I- INDEX OF THE LAST CHARACTER IN THE STRING C IS2H -O- POINTER TO THE FIRST BLOCK CONTAINING THE STRING C IS2T -O- POINTER TO THE LAST BLOCK CONTAINING THE STRING C C LOCAL VARIABLES C --------------- C ICV - INDEX OF THE CURRENT CHARACTER IN THE STRING C IS2 - POINTER TO CURRENT BLOCK FOR THE STRING C ICS - INDEX OF CURRENT STORE POSITION IN CSTORE C ICS1 - INDEX OF BEGINNING OF CURRENT CSTORE BLOCK C ICS2 - INDEX OF END OF CURRENT CSTORE BLOCK C ICSTST - INDEX OF LAST CSTORE POSITION NEEDED C ICSMIN - INDEX OF LAST CSTORE POSITION NEEDED IN CURRENT BLOCK C C----------------------------------------------------------------------- C C GLOBAL CONSTANTS C CHARACTER*1 CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 COMMON / GLCOMC / CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 C C INPUT / OUTPUT CONTROL INTERFACE C CHARACTER*1 CBUFFR(2000) LOGICAL LBREAK, LFORT, LISTI, LISTO INTEGER ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOMC / CBUFFR COMMON / IOCOMI / ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOML / LBREAK, LFORT, LISTI, LISTO C C MEMORY MANAGER INTERFACE C CHARACTER*1 CSTORE(20000) INTEGER IHASH(601), ISTORE(6000) INTEGER ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS COMMON / MMCOMC / CSTORE COMMON / MMCOMH / IHASH COMMON / MMCOMS / ISTORE COMMON / MMCOMI / ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS C C LOCAL VARIABLES AND PARAMETERS C INTEGER ICV1, ICV2, IS2H, IS2T CHARACTER*(*) CVALUE(ICV2) INTEGER ICV, IS2, ICS1, ICS2, ICSTST, ICSMIN, ICS EXTERNAL MMNEWI, IOERRM C IF ((ICV1 .GT. 0) .AND. (ICV1 .LE. ICV2)) GO TO 10 IS2H = 0 IS2T = 0 GO TO 999 C 10 CONTINUE ICV = ICV1 IS2 = IS2HDC IS2H = IS2HDC C C LOOP THROUGH THE LINKED LIST OF AVAILABLE MEMORY BLOCKS C 20 CONTINUE IF (IS2 .EQ. 0) GO TO 60 IS2T = IS2 ICS1 = ISTORE(IS2T) ICS2 = ISTORE(IS2T+1) IS2 = ISTORE(IS2T+2) ICSTST = ICS1 + ICV2 - ICV ICSMIN = MIN0(ICS2, ICSTST) C C STORE CHARACTERS INTO A PARTICULAR BLOCK C DO 30 ICS=ICS1,ICSMIN CSTORE(ICS) = CVALUE(ICV) ICV = ICV + 1 30 CONTINUE IF (ICSTST .GT. ICS2) GO TO 20 C C IF THE LAST BLOCK USED WAS COMPLETELY FILLED, GO TO 40 C IF (ICSTST .NE. ICS2) GO TO 40 IS2HDC = IS2 GO TO 50 C C THE LAST BLOCK OF MEMORY WAS NOT COMPLETELY USED. C PUT A NEW BLOCK ON THE AVAILABLE MEMORY STACK C CORRESPONDING TO THE REMAINING CHARACTERS. C 40 CONTINUE CALL MMNEWI (IS2HDC) ISTORE(IS2HDC) = ICSMIN+1 ISTORE(IS2HDC+1) = ICS2 ISTORE(IS2HDC+2) = IS2 C 50 CONTINUE ISTORE(IS2T+1) = ICSTST ISTORE(IS2T+2) = 0 GO TO 999 C C FATAL ERROR - NO MORE CHARACTER STORAGE SPACE C 60 CONTINUE CALL IOERRM (.TRUE., A '('' ******** MMPUT1 - STORAGE ARRAY CSTORE(*) FULL'')') C 999 CONTINUE RETURN END SUBROUTINE MMRETI (IS) C C----------------------------------------------------------------------- C C FAMILY C ------ C MEMORY MANAGER C C PURPOSE C ------- C TO RETURN AN INTEGER BLOCK TO THE FREE LIST C C PARAMETERS C ---------- C IS -I- POINTER TO THE BLOCK TO BE RETURNED C C----------------------------------------------------------------------- C C GLOBAL CONSTANTS C CHARACTER*1 CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 COMMON / GLCOMC / CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 C C INPUT / OUTPUT CONTROL INTERFACE C CHARACTER*1 CBUFFR(2000) LOGICAL LBREAK, LFORT, LISTI, LISTO INTEGER ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOMC / CBUFFR COMMON / IOCOMI / ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOML / LBREAK, LFORT, LISTI, LISTO C C MEMORY MANAGER INTERFACE C CHARACTER*1 CSTORE(20000) INTEGER IHASH(601), ISTORE(6000) INTEGER ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS COMMON / MMCOMC / CSTORE COMMON / MMCOMH / IHASH COMMON / MMCOMS / ISTORE COMMON / MMCOMI / ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS C INTEGER IS EXTERNAL IOERRM IF (IS .EQ. 0) GO TO 999 IF ((IS .LT. 0) .OR. (IS .GT. ISTDIM) A .OR. (MOD(IS,3) .NE. 1)) GO TO 10 ISTORE(IS+2) = ISFREE ISFREE = IS GO TO 999 C 10 CONTINUE CALL IOERRM (.FALSE., A '('' ******** MMRETI - ATTEMPT TO RETURN INVALID POINTER'')') C 999 CONTINUE RETURN END SUBROUTINE MMSETP (CPTR, ICP1, ICP2) C C----------------------------------------------------------------------- C C FAMILY C ------ C MEMORY MANAGER C C PURPOSE C ------- C TO SAVE A POINTER TO THE CURRENT TOP OF THE SUBSTITUTION STACK C C PARAMETERS C ---------- C CPTR -I- NAME OF THE POINTER C ICP1 -I- INDEX OF THE FIRST CHARACTER IN THE NAME C ICP2 -I- INDEX OF THE LAST CHARACTER IN THE NAME C C----------------------------------------------------------------------- C C GLOBAL CONSTANTS C CHARACTER*1 CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 COMMON / GLCOMC / CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 C C INPUT / OUTPUT CONTROL INTERFACE C CHARACTER*1 CBUFFR(2000) LOGICAL LBREAK, LFORT, LISTI, LISTO INTEGER ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOMC / CBUFFR COMMON / IOCOMI / ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOML / LBREAK, LFORT, LISTI, LISTO C C MEMORY MANAGER INTERFACE C CHARACTER*1 CSTORE(20000) INTEGER IHASH(601), ISTORE(6000) INTEGER ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS COMMON / MMCOMC / CSTORE COMMON / MMCOMH / IHASH COMMON / MMCOMS / ISTORE COMMON / MMCOMI / ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS C C LOCAL VARIABLES AND PARAMETERS C INTEGER ICP1, ICP2 CHARACTER*(*) CPTR(ICP2) LOGICAL LFOUND INTEGER I, IH, IS1, IS2 EXTERNAL MMHASH, MMNEWI, MMPUT1 C CALL MMHASH (CPTR, ICP1, ICP2, IH, LFOUND) IF (.NOT. LFOUND) GO TO 10 IS1 = IHASH(IH) IS2 = ISTORE(IS1+1) GO TO 20 C 10 CONTINUE CALL MMNEWI (IS1) IHASH(IH) = IS1 CALL MMPUT1 (CPTR, ICP1, ICP2, ISTORE(IS1), I) CALL MMNEWI (IS2) ISTORE(IS1+1) = IS2 ISTORE(IS1+2) = 0 C 20 CONTINUE IF (IS2HDS .NE. 0) GO TO 30 ISTORE(IS2) = 0 ISTORE(IS2+1) = 0 ISTORE(IS2+2) = 0 GO TO 999 C 30 CONTINUE ISTORE(IS2) = ISTORE(IS2HDS) ISTORE(IS2+1) = ISTORE(IS2HDS+1) ISTORE(IS2+2) = 0 C 999 CONTINUE RETURN END SUBROUTINE MMTEST (CVALUE, ICV1, ICV2, IS2H, LEQUAL) C C----------------------------------------------------------------------- C C FAMILY C ------ C MEMORY MANAGER C C PURPOSE C ------- C TO SEE IF A GIVEN STRING IS EQUAL TO ONE IN THE SYMBOL TABLE C C PARAMETERS C ---------- C CVALUE -I- CONTAINS THE STRING TO BE TESTED C ICV1 -I- INDEX OF THE FIRST CHARACTER IN THE STRING C ICV2 -I- INDEX OF THE LAST CHARACTER IN THE STRING C IS2H -I- POINTER TO THE STRING IN THE SYMBOL TABLE C LEQUAL -O- TRUE IF THE STRINGS ARE EQUAL C C----------------------------------------------------------------------- C C GLOBAL CONSTANTS C CHARACTER*1 CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 COMMON / GLCOMC / CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 C C INPUT / OUTPUT CONTROL INTERFACE C CHARACTER*1 CBUFFR(2000) LOGICAL LBREAK, LFORT, LISTI, LISTO INTEGER ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOMC / CBUFFR COMMON / IOCOMI / ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOML / LBREAK, LFORT, LISTI, LISTO C C MEMORY MANAGER INTERFACE C CHARACTER*1 CSTORE(20000) INTEGER IHASH(601), ISTORE(6000) INTEGER ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS COMMON / MMCOMC / CSTORE COMMON / MMCOMH / IHASH COMMON / MMCOMS / ISTORE COMMON / MMCOMI / ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS C C LOCAL VARIABLES AND PARAMETERS C INTEGER ICV1, ICV2, IS2H CHARACTER*(*) CVALUE(ICV2) LOGICAL LEQUAL INTEGER ICS, ICS1, ICS2, ICV, IS2 C ICV = ICV1 IS2 = IS2H LEQUAL = .FALSE. C 10 CONTINUE IF (IS2 .EQ. 0) GO TO 30 ICS1 = ISTORE(IS2) ICS2 = ISTORE(IS2+1) IS2 = ISTORE(IS2+2) IF (ICS2-ICS1 .GT. ICV2-ICV) GO TO 999 DO 20 ICS=ICS1,ICS2 IF (CSTORE(ICS) .NE. CVALUE(ICV)) GO TO 999 ICV = ICV + 1 20 CONTINUE GO TO 10 C 30 CONTINUE LEQUAL = ICV .GT. ICV2 C 999 CONTINUE RETURN END SUBROUTINE MPEOL C C----------------------------------------------------------------------- C C FAMILY C ------ C MACRO PROCESSOR C C PURPOSE C ------- C TO REMOVE TRAILING BLANKS AND ADD AN END-OF-LINE MARKER C TO THE LINE IN THE INPUT/OUTPUT BUFFER C C----------------------------------------------------------------------- C C GLOBAL CONSTANTS C CHARACTER*1 CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 COMMON / GLCOMC / CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 C C INPUT / OUTPUT CONTROL INTERFACE C CHARACTER*1 CBUFFR(2000) LOGICAL LBREAK, LFORT, LISTI, LISTO INTEGER ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOMC / CBUFFR COMMON / IOCOMI / ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOML / LBREAK, LFORT, LISTI, LISTO C C MEMORY MANAGER INTERFACE C CHARACTER*1 CSTORE(20000) INTEGER IHASH(601), ISTORE(6000) INTEGER ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS COMMON / MMCOMC / CSTORE COMMON / MMCOMH / IHASH COMMON / MMCOMS / ISTORE COMMON / MMCOMI / ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS C C MACRO PROCESSOR INTERFACE C CHARACTER*1 CDIV, CEOL, CEOR, CONC, CSUB, A CTOP LOGICAL LEMPTY, LSUB COMMON / MPCOMC / CDIV, CEOL, CEOR, CONC, CSUB, A CTOP COMMON / MPCOML / LEMPTY, LSUB C C LOCAL VARIABLES AND PARAMETERS C CHARACTER*1 C EXTERNAL MMPOPC C CALL MMPOPC (C, 2, CTOP, LEMPTY) ICBEOL = ICB2 ICBEND = ICBEOL ICB2 = ICB2 - 2 ICB3 = ICB2 IF (ICB1 .GT. ICB2) GO TO 999 IF (CBUFFR(ICB2) .NE. CBLANK) GO TO 999 C C REMOVE TRAILING BLANKS C 10 CONTINUE ICB2 = ICB2 - 1 IF (ICB1 .GT. ICB2) GO TO 20 IF (CBUFFR(ICB2) .EQ. CBLANK) GO TO 10 C C ADD THE END-OF-LINE MARKER C 20 CONTINUE CBUFFR(ICB2+1) = CSUB CBUFFR(ICB2+2) = CEOL ICB3 = ICB2 ICBEOL = ICB2 + 2 ICBEND = ICBEOL C 999 CONTINUE RETURN END SUBROUTINE MPITEM C C----------------------------------------------------------------------- C C FAMILY C ------ C MACRO PROCESSOR C C PURPOSE C ------- C TO PUSH THE NEXT ITEM IN A LIST ONTO THE SUBSTITUTION STACK C C----------------------------------------------------------------------- C C GLOBAL CONSTANTS C CHARACTER*1 CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 COMMON / GLCOMC / CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 C C INPUT / OUTPUT CONTROL INTERFACE C CHARACTER*1 CBUFFR(2000) LOGICAL LBREAK, LFORT, LISTI, LISTO INTEGER ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOMC / CBUFFR COMMON / IOCOMI / ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOML / LBREAK, LFORT, LISTI, LISTO C C MEMORY MANAGER INTERFACE C CHARACTER*1 CSTORE(20000) INTEGER IHASH(601), ISTORE(6000) INTEGER ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS COMMON / MMCOMC / CSTORE COMMON / MMCOMH / IHASH COMMON / MMCOMS / ISTORE COMMON / MMCOMI / ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS C C MACRO PROCESSOR INTERFACE C CHARACTER*1 CDIV, CEOL, CEOR, CONC, CSUB, A CTOP LOGICAL LEMPTY, LSUB COMMON / MPCOMC / CDIV, CEOL, CEOR, CONC, CSUB, A CTOP COMMON / MPCOML / LEMPTY, LSUB C C LOCAL VARIABLES AND PARAMETERS C LOGICAL LERROR, LFOUND INTEGER ICN1, ICN2, ICP1, ICP2 EXTERNAL MPPOPN, UTBLDN, MMPSHV, MMPUTP, IOERRM C CALL MPPOPN (ICN1, ICN2, LERROR) ICP1 = ICB2 + 1 CALL UTBLDN (CDIV, CBUFFR, ICN1, ICN2, 1, A CBUFFR, ICP1, ICP2, ICBDIM, LERROR) CALL MMPSHV (CBUFFR, ICP1, ICP2, 3, LEMPTY, LFOUND) IF (LFOUND) GO TO 10 CALL MMPUTP (CBUFFR, ICN1, ICN2, CBUFFR, ICP1, ICP2, LFOUND) IF (.NOT. LFOUND) GO TO 20 CALL MMPSHV (CBUFFR, ICP1, ICP2, 3, LEMPTY, LFOUND) C 10 CONTINUE ICB2 = ICBSUB - 1 GO TO 999 C 20 CONTINUE CALL IOERRM (.FALSE., A '('' ******** MPITEM - VARIABLE NOT DEFINED'')') C 999 CONTINUE RETURN END SUBROUTINE MPLABL C C----------------------------------------------------------------------- C C FAMILY C ------ C MACRO PROCESSOR C C PURPOSE C ------- C TO COPY THE CURRENT LABEL TO THE BUFFER AND THEN C INCREMENT AND SAVE ITS VALUE C C----------------------------------------------------------------------- C C GLOBAL CONSTANTS C CHARACTER*1 CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 COMMON / GLCOMC / CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 C C INPUT / OUTPUT CONTROL INTERFACE C CHARACTER*1 CBUFFR(2000) LOGICAL LBREAK, LFORT, LISTI, LISTO INTEGER ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOMC / CBUFFR COMMON / IOCOMI / ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOML / LBREAK, LFORT, LISTI, LISTO C C MEMORY MANAGER INTERFACE C CHARACTER*1 CSTORE(20000) INTEGER IHASH(601), ISTORE(6000) INTEGER ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS COMMON / MMCOMC / CSTORE COMMON / MMCOMH / IHASH COMMON / MMCOMS / ISTORE COMMON / MMCOMI / ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS C C MACRO PROCESSOR INTERFACE C CHARACTER*1 CDIV, CEOL, CEOR, CONC, CSUB, A CTOP LOGICAL LEMPTY, LSUB COMMON / MPCOMC / CDIV, CEOL, CEOR, CONC, CSUB, A CTOP COMMON / MPCOML / LEMPTY, LSUB C C LOCAL VARIABLES AND PARAMETERS C INTEGER I, ICV1, ICV2, ICV2M4, ICV1M1 CHARACTER*1 C(5) LOGICAL L INTEGER ICNDIM EXTERNAL MMGETV, UTCVCI, UTCVIC, MMPUTV, IOERRM SAVE ICNDIM, C DATA ICNDIM / 5 / DATA C(1), C(2), C(3), C(4), C(5) A / 'L', 'A', 'B', 'E', 'L' / C C GET CURRENT VALUE OF LABEL, CONVERT TO AN INTEGER AND C CHECK IT. ADD ONE, CONVERT BACK TO CHARACTERS AND PLACE C IN CBUFFR C ICV1 = ICB2 + 5 CALL MMGETV (C, 1, ICNDIM, CBUFFR, ICV1, ICV2, ICBDIM, L) IF (.NOT. L) GO TO 40 CALL UTCVCI (CBUFFR, ICV1, ICV2, I, L) IF ((I .LT. 0) .OR. (99999 .LT. I)) GO TO 40 I = I + 1 CALL UTCVIC (CBUFFR, ICV1, ICV2, ICBDIM, I, L) ICV2M4 = ICV2 - 4 ICV1M1 = ICV1 - 1 IF (ICV2M4 .GT. ICV1M1) GO TO 20 C DO 10 I=ICV2M4,ICV1M1 CBUFFR(I) = CBLANK 10 CONTINUE C 20 CONTINUE CALL MMPUTV (C, 1, ICNDIM, CBUFFR, ICV2M4, ICV2) ICB2 = ICBSUB - 1 DO 30 I=ICV2M4,ICV2 ICB2 = ICB2 + 1 CBUFFR(ICB2) = CBUFFR(I) 30 CONTINUE GO TO 999 C C WARNING - INVALID LABEL VALUE C 40 CONTINUE CALL IOERRM (.FALSE., A '('' ******** MPLABL - ILLEGAL LABEL VALUE'')') C 999 CONTINUE RETURN END SUBROUTINE MPLINE (LSUBL) C C----------------------------------------------------------------------- C C FAMILY C ------ C MACRO PROCESSOR C C PURPOSE C ------- C TO BUILD THE NEXT LINE IN THE I/O BUFFER C C PARAMETERS C ---------- C LSUBL -I- LOCAL SUBSTITUTION FLAG INDICATING WHETHER C OR NOT MACROS ON THIS LINE ARE TO BE EXPANDED C C----------------------------------------------------------------------- C C GLOBAL CONSTANTS C CHARACTER*1 CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 COMMON / GLCOMC / CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 C C INPUT / OUTPUT CONTROL INTERFACE C CHARACTER*1 CBUFFR(2000) LOGICAL LBREAK, LFORT, LISTI, LISTO INTEGER ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOMC / CBUFFR COMMON / IOCOMI / ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOML / LBREAK, LFORT, LISTI, LISTO C C MEMORY MANAGER INTERFACE C CHARACTER*1 CSTORE(20000) INTEGER IHASH(601), ISTORE(6000) INTEGER ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS COMMON / MMCOMC / CSTORE COMMON / MMCOMH / IHASH COMMON / MMCOMS / ISTORE COMMON / MMCOMI / ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS C C MACRO PROCESSOR INTERFACE C CHARACTER*1 CDIV, CEOL, CEOR, CONC, CSUB, A CTOP LOGICAL LEMPTY, LSUB COMMON / MPCOMC / CDIV, CEOL, CEOR, CONC, CSUB, A CTOP COMMON / MPCOML / LEMPTY, LSUB C C LOCAL VARIABLES AND PARAMETERS C INTEGER ICB CHARACTER*1 C(2) LOGICAL LEOL, LFOUND, LSUBL INTEGER ICNDIM EXTERNAL MMPOPC, MPSUBS, IOREAD, MMPUTV, MMPSHV SAVE ICNDIM, C DATA ICNDIM / 2 / DATA C(1), C(2) /'*', 'L' / C C SET I/O BUFFER POINTERS C ICB0 = ICBEOL + 1 ICB1 = ICBEOL + 1 ICB2 = ICBEOL IF (LEMPTY) GO TO 20 C C IF THE STACK IS NONEMPTY, POP INTO THE I/O BUFFER UNTIL A C SUB. CHAR. IS FOUND. THEN CALL MPSUBS. C 10 CONTINUE CALL MMPOPC (CSUB, 5, CTOP, LEMPTY) IF (LEMPTY) GO TO 20 CALL MPSUBS (LEOL, LSUBL) IF (LEOL) GO TO 999 GO TO 10 C C IF THE STACK IS EMPTY, GET MORE INPUT C 20 CONTINUE CALL IOREAD IF ((.NOT. LSUBL) .OR. (ICB1 .GT. ICB2)) GO TO 999 C C LOOK FOR SUBSTITUTION CHARACTER C DO 30 ICB=ICB1,ICB2 IF (CBUFFR(ICB) .EQ. CSUB) GO TO 40 30 CONTINUE GO TO 999 C C WHEN A SUB. CHAR IS FOUND, PUT THE VARIABLE '*L' IN THE C SYMBOL TABLE. THE VALUE OF THIS SPECIAL VARIABLE IS THE C REST OF THE LINE. ALSO PUSH *L ONTO THE SUBST. STACK. C 40 CONTINUE CALL MMPUTV (C, 1, ICNDIM, CBUFFR, ICB, ICBEOL) CALL MMPSHV (C, 1, ICNDIM, 1, LEMPTY, LFOUND) ICB2 = ICB - 1 CALL MPSUBS (LEOL, LSUBL) IF (.NOT. LEOL) GO TO 10 C 999 CONTINUE RETURN END SUBROUTINE MPMAC C C----------------------------------------------------------------------- C C FAMILY C ------ C MACRO PROCESSOR C C PURPOSE C ------- C TO DETERMINE THE TYPE OF MACRO EXPANSION INDICATED C AND CALL THE APPROPRIATE ROUTINES C C----------------------------------------------------------------------- C C GLOBAL CONSTANTS C CHARACTER*1 CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 COMMON / GLCOMC / CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 C C INPUT / OUTPUT CONTROL INTERFACE C CHARACTER*1 CBUFFR(2000) LOGICAL LBREAK, LFORT, LISTI, LISTO INTEGER ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOMC / CBUFFR COMMON / IOCOMI / ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOML / LBREAK, LFORT, LISTI, LISTO C C MEMORY MANAGER INTERFACE C CHARACTER*1 CSTORE(20000) INTEGER IHASH(601), ISTORE(6000) INTEGER ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS COMMON / MMCOMC / CSTORE COMMON / MMCOMH / IHASH COMMON / MMCOMS / ISTORE COMMON / MMCOMI / ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS C C MACRO PROCESSOR INTERFACE C CHARACTER*1 CDIV, CEOL, CEOR, CONC, CSUB, A CTOP LOGICAL LEMPTY, LSUB COMMON / MPCOMC / CDIV, CEOL, CEOR, CONC, CSUB, A CTOP COMMON / MPCOML / LEMPTY, LSUB C C LOCAL VARIABLES AND PARAMETERS C CHARACTER*1 C(12) INTEGER IK(3) INTEGER IKYDIM, ICKDIM, ICN1, ICN2, ICN1SV, I, A ICL1NA, ICL2NA, IH LOGICAL LERROR, LFOUND EXTERNAL MMHASH, MPPOPN, UTRDKY, UTRDNA, MMPSHV, A UTCVLC, MPLABL, MPITEM, IOERRM SAVE IKYDIM, IK, ICKDIM, C DATA A IKYDIM, ICKDIM, B IK(1), C IK(2), D IK(3) E / 3, 12, F 3, G 5, H 4 / DATA B C(1), C(2), C(3), C C(4), C(5), C(6), C(7), C(8), D C(9), C(10), C(11), C(12) E / F 'D', 'E', 'F', G 'L', 'A', 'B', 'E', 'L', H 'L', 'I', 'S', 'T' / C C MARK THE CURRENT LINE POSITION, POP THE NAME OFF THE STACK, C AND THEN DETERMINE THE TYPE OF SUBSTITUTION C ICBSUB = ICB2 CALL MPPOPN (ICN1, ICN2, LERROR) IF (LERROR) GO TO 999 ICN1SV = ICN1 CALL UTRDKY (CBUFFR, ICN1, ICN2, IK, IKYDIM, C, ICKDIM, I) IF(I.GT.IKYDIM) GO TO 10 C C CHECK IF WE ONLY HAPPENED TO MATCH A PREFIX C CALL UTRDNA (CBUFFR, ICN1, ICN2, ICL1NA, ICL2NA, LERROR) IF(LERROR) 1 GO TO (20, 30, 40), I C C IF SO, RESTORE ORIGINAL STATE AND PROCESS VARIABLE SUBSTITUTION C ICN1 = ICN1SV GO TO 10 C C A SIMPLE MACRO SUBSTITUTION HAS BEEN FOUND. C PUSH THE NEW NAME ONTO THE STACK C AND RESET THE CURRENT LINE POINTER. C SUBSEQUENT POPPING OF THE STACK WILL PUT THE VALUE C OF THE MACRO INTO THE I/O BUFFER. C 10 CONTINUE CALL MMPSHV (CBUFFR, ICN1, ICN2, 1, LEMPTY, LFOUND) IF (.NOT. LFOUND) GO TO 50 ICB2 = ICBSUB - 1 GO TO 999 C C A DEF SUBSTITUTION HAS BEEN ENCOUNTERED C 20 CONTINUE CALL MPPOPN (ICN1, ICN2, LERROR) CALL MMHASH (CBUFFR, ICN1, ICN2, IH, LFOUND) CALL UTCVLC (CBUFFR, ICBSUB, ICB2, ICBDIM, LFOUND, LERROR) GO TO 999 C C A LABEL SUBSTITUTION HAS BEEN ENCOUNTERED C 30 CONTINUE CALL MPLABL GO TO 999 C C A LIST SUBSTITUTION HAS POSSIBLY BEEN ENCOUNTERED C 40 CONTINUE CALL MPITEM GO TO 999 C C WARNING - NAME NOT FOUND IN SYMBOL TABLE C 50 CONTINUE CALL IOERRM (.FALSE., A '('' ******** MPMAC - VARIABLE NOT DEFINED'')') C 999 CONTINUE RETURN END SUBROUTINE MPPOPN (ICN1, ICN2, LERROR) C C----------------------------------------------------------------------- C C FAMILY C ------ C MACRO PROCESSOR C C PURPOSE C ------- C TO POP A NAME OFF THE SUBSTITUTION STACK INTO THE I/O BUFFER C C PARAMETERS C ---------- C ICN1 -O- INDEX IN THE BUFFER OF THE FIRST CHARACTER C IN THE NAME C ICN2 -O- INDEX OF THE LAST CHARACTER C LERROR -O- TRUE IF THE NAME WAS INVALID C C----------------------------------------------------------------------- C C GLOBAL CONSTANTS C CHARACTER*1 CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 COMMON / GLCOMC / CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 C C INPUT / OUTPUT CONTROL INTERFACE C CHARACTER*1 CBUFFR(2000) LOGICAL LBREAK, LFORT, LISTI, LISTO INTEGER ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOMC / CBUFFR COMMON / IOCOMI / ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOML / LBREAK, LFORT, LISTI, LISTO C C MEMORY MANAGER INTERFACE C CHARACTER*1 CSTORE(20000) INTEGER IHASH(601), ISTORE(6000) INTEGER ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS COMMON / MMCOMC / CSTORE COMMON / MMCOMH / IHASH COMMON / MMCOMS / ISTORE COMMON / MMCOMI / ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS C C MACRO PROCESSOR INTERFACE C CHARACTER*1 CDIV, CEOL, CEOR, CONC, CSUB, A CTOP LOGICAL LEMPTY, LSUB COMMON / MPCOMC / CDIV, CEOL, CEOR, CONC, CSUB, A CTOP COMMON / MPCOML / LEMPTY, LSUB C C LOCAL VARIABLES AND PARAMETERS C INTEGER ICN1, ICN2 CHARACTER*1 C LOGICAL LEFT, LERROR EXTERNAL MMPOPC, IOERRM C C POP BLANKS; LOOK FOR LEFT PAREN. C CALL MMPOPC (CBLANK, 4, CTOP, LEMPTY) LEFT = CLEFT .EQ. CTOP IF (.NOT. LEFT) GO TO 10 CALL MMPOPC (C, 2, CTOP, LEMPTY) CALL MMPOPC (CBLANK, 4, CTOP, LEMPTY) C 10 CONTINUE ICN1 = ICB2 + 1 C C CHECK FOR A LEGAL NAME C LERROR = .NOT. (LLE(CA,CTOP) A .AND. LLE(CTOP,CZ)) IF (LERROR) GO TO 20 C C POP THE CHAR'S OF THE NAME OFF C CALL MMPOPC (C, 6, CTOP, LEMPTY) ICN2 = ICB2 IF (.NOT. LEFT) GO TO 999 CALL MMPOPC (CBLANK, 4, CTOP, LEMPTY) LERROR = CRIGHT .NE. CTOP IF (LERROR) GO TO 30 CALL MMPOPC (C, 2, CTOP, LEMPTY) GO TO 999 C C WARNING - ILLEGAL NAME C 20 CONTINUE CALL IOERRM (.FALSE., A '('' ******** MPPOPN - ILLEGAL VARIABLE NAME'')') GO TO 999 C C WARNING - NO CLOSING RIGHT PARENTHESIS C 30 CONTINUE CALL IOERRM (.FALSE., A '('' ******** MPPOPN - MISSING RIGHT PARENTHESIS'')') C 999 CONTINUE RETURN END SUBROUTINE MPSUBS (LEOL, LSUBL) C C----------------------------------------------------------------------- C C FAMILY C ------ C MACRO PROCESSOR C C PURPOSE C ------- C TO EVALUATE OF THE SUBSTITUTION ESCAPE CHARACTER C AND DECIDE WHAT ACTION IS TO BE TAKEN C C PARAMETERS C ---------- C LEOL -O- TRUE IF AN END-OF-LINE MARKER WAS FOUND C LSUBL -I- TRUE IF NO SUBSTITUTION IS TO BE PERFORMED C ON THIS LINE C C----------------------------------------------------------------------- C C GLOBAL CONSTANTS C CHARACTER*1 CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 COMMON / GLCOMC / CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 C C INPUT / OUTPUT CONTROL INTERFACE C CHARACTER*1 CBUFFR(2000) LOGICAL LBREAK, LFORT, LISTI, LISTO INTEGER ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOMC / CBUFFR COMMON / IOCOMI / ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOML / LBREAK, LFORT, LISTI, LISTO C C MEMORY MANAGER INTERFACE C CHARACTER*1 CSTORE(20000) INTEGER IHASH(601), ISTORE(6000) INTEGER ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS COMMON / MMCOMC / CSTORE COMMON / MMCOMH / IHASH COMMON / MMCOMS / ISTORE COMMON / MMCOMI / ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS C C MACRO PROCESSOR INTERFACE C CHARACTER*1 CDIV, CEOL, CEOR, CONC, CSUB, A CTOP LOGICAL LEMPTY, LSUB COMMON / MPCOMC / CDIV, CEOL, CEOR, CONC, CSUB, A CTOP COMMON / MPCOML / LEMPTY, LSUB C C LOCAL VARIABLES AND PARAMETERS C CHARACTER*1 C LOGICAL LEOL, LSUBL EXTERNAL MPEOL, MPMAC, MMPOPC C C DETERMINE WHAT FOLLOWS THE SUBSTITUTION PREFIX CHARACTER C LEOL = .FALSE. CALL MMPOPC (C, 2, CTOP, LEMPTY) IF (CEOL .EQ. CTOP) GO TO 10 IF (CEOR .EQ. CTOP) GO TO 20 IF (CONC .EQ. CTOP) GO TO 30 IF (.NOT. (LSUB .AND. LSUBL)) GO TO 999 IF (CSUB .EQ. CTOP) GO TO 40 GO TO 50 C C PROCESS AN END-OF-LINE MARKER C 10 CONTINUE CALL MPEOL LEOL = .TRUE. GO TO 999 C C PROCESS AN END-OF-RECORD MARKER C 20 CONTINUE CALL MMPOPC (C, 3, CTOP, LEMPTY) ICB2 = ICB2 - 2 GO TO 999 C C PROCESS A CONTINUATION CHARACTER C 30 CONTINUE CALL MMPOPC (C, 2, CTOP, LEMPTY) CALL MMPOPC (C, 2, CTOP, LEMPTY) CALL MMPOPC (C, 2, CTOP, LEMPTY) ICB2 = ICB2 - 4 GO TO 999 C C PROCESS AN EMBEDDED SUBSTITUTION PREFIX CHARACTER C 40 CONTINUE CALL MMPOPC (C, 2, CTOP, LEMPTY) ICB2 = ICB2 - 1 GO TO 999 C C A LIST OR MACRO SUBSTITUTION HAS BEEN ENCOUNTERED C 50 CONTINUE CALL MPMAC C 999 CONTINUE RETURN END SUBROUTINE TPAPPE C C----------------------------------------------------------------------- C C FAMILY C ------ C TEMPLATE PROCESSOR C C PURPOSE C ------- C TO PROCESS APPEND DIRECTIVES C C----------------------------------------------------------------------- C C GLOBAL CONSTANTS C CHARACTER*1 CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 COMMON / GLCOMC / CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 C C INPUT / OUTPUT CONTROL INTERFACE C CHARACTER*1 CBUFFR(2000) LOGICAL LBREAK, LFORT, LISTI, LISTO INTEGER ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOMC / CBUFFR COMMON / IOCOMI / ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOML / LBREAK, LFORT, LISTI, LISTO C C MEMORY MANAGER INTERFACE C CHARACTER*1 CSTORE(20000) INTEGER IHASH(601), ISTORE(6000) INTEGER ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS COMMON / MMCOMC / CSTORE COMMON / MMCOMH / IHASH COMMON / MMCOMS / ISTORE COMMON / MMCOMI / ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS C C MACRO PROCESSOR INTERFACE C CHARACTER*1 CDIV, CEOL, CEOR, CONC, CSUB, A CTOP LOGICAL LEMPTY, LSUB COMMON / MPCOMC / CDIV, CEOL, CEOR, CONC, CSUB, A CTOP COMMON / MPCOML / LEMPTY, LSUB C C TEMPLATE PROCESSOR INTERFACE C CHARACTER*1 CDIR, CSTAR INTEGER ICBP1(4), ICBP2(4) INTEGER ITOPDO, IARGS, INESTD, INESTF LOGICAL LCOL1, LDIRL, LEND, LINITM, L1TRIP COMMON / TPCOMC / CDIR, CSTAR COMMON / TPCOMI / ICBP1, ITOPDO, IARGS, ICBP2, INESTD, B INESTF COMMON / TPCOML / LCOL1, LDIRL, LEND, LINITM, L1TRIP C C LOCAL VARIABLES AND PARAMETERS C CHARACTER*1 C(15) INTEGER ID(7), IK(3) INTEGER IKYDIM, ICKDIM, IDSDIM LOGICAL LERROR EXTERNAL TPSYNT, TPRDBL, MMAPPV, IOERRM SAVE IKYDIM, IK, ICKDIM, C, IDSDIM, ID DATA A IKYDIM, ICKDIM, B IK(1), C IK(2), D IK(3) E / 3, 15, F 6, G 6, H 3 / DATA B C(1), C(2), C(3), C(4), C(5), C(6), C C(7), C(8), C(9), C(10), C(11), C(12), D C(13), C(14), C(15) E / F 'A', 'P', 'P', 'E', 'N', 'D', G 'E', 'N', 'D', 'A', 'P', 'P', H 'E', 'N', 'D' / DATA A IDSDIM, B ID(1), ID(2), ID(3), ID(4), ID(5), ID(6), ID(7) C / 7, D 1, 5, -3, 6, 6, 2, 7 / C C CHECK SYNTAX C CALL TPSYNT (ID, IDSDIM, .FALSE., LERROR) IF (LERROR) GO TO 999 IF (IARGS .EQ. 2) GO TO 10 C C PROCESS A MULTI-LINE APPEND STATEMENT C ICBP1(2) = ICBEOL + 1 C C READ A BLOCK; UNTIL *ENDAPP C CALL TPRDBL (IK, IKYDIM, C, ICKDIM, ID, IDSDIM, A .TRUE., .FALSE., .TRUE., LERROR) IF (LEND) GO TO 20 IF (LERROR) GO TO 999 ICBP2(2) = ICB0 - 1 C C APPEND THE VALUE C 10 CONTINUE CALL MMAPPV (CBUFFR, ICBP1(1), ICBP2(1), A CBUFFR, ICBP1(2), ICBP2(2)) GO TO 999 C 20 CONTINUE CALL IOERRM (.FALSE., A '('' ******** TPAPPE - APPEND HAS NO MATCHING ENDAPP'')') C 999 CONTINUE RETURN END SUBROUTINE TPCHKD C C----------------------------------------------------------------------- C C FAMILY C ------ C TEMPLATE PROCESSOR C C PURPOSE C ------- C TO DETERMINE IF A LINE CONTAINS A DIRECTIVE C C----------------------------------------------------------------------- C C GLOBAL CONSTANTS C CHARACTER*1 CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 COMMON / GLCOMC / CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 C C INPUT / OUTPUT CONTROL INTERFACE C CHARACTER*1 CBUFFR(2000) LOGICAL LBREAK, LFORT, LISTI, LISTO INTEGER ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOMC / CBUFFR COMMON / IOCOMI / ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOML / LBREAK, LFORT, LISTI, LISTO C C MEMORY MANAGER INTERFACE C CHARACTER*1 CSTORE(20000) INTEGER IHASH(601), ISTORE(6000) INTEGER ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS COMMON / MMCOMC / CSTORE COMMON / MMCOMH / IHASH COMMON / MMCOMS / ISTORE COMMON / MMCOMI / ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS C C MACRO PROCESSOR INTERFACE C CHARACTER*1 CDIV, CEOL, CEOR, CONC, CSUB, A CTOP LOGICAL LEMPTY, LSUB COMMON / MPCOMC / CDIV, CEOL, CEOR, CONC, CSUB, A CTOP COMMON / MPCOML / LEMPTY, LSUB C C TEMPLATE PROCESSOR INTERFACE C CHARACTER*1 CDIR, CSTAR INTEGER ICBP1(4), ICBP2(4) INTEGER ITOPDO, IARGS, INESTD, INESTF LOGICAL LCOL1, LDIRL, LEND, LINITM, L1TRIP COMMON / TPCOMC / CDIR, CSTAR COMMON / TPCOMI / ICBP1, ITOPDO, IARGS, ICBP2, INESTD, B INESTF COMMON / TPCOML / LCOL1, LDIRL, LEND, LINITM, L1TRIP C C LOCAL VARIABLES AND PARAMETERS C LOGICAL LEOL EXTERNAL UTRDBL C LDIRL = .FALSE. IF (ICB1 .GT. ICB2) GO TO 999 IF (CBUFFR(ICB1) .EQ. CDIR) GO TO 10 IF (LCOL1) GO TO 999 CALL UTRDBL (CBUFFR, ICB1, ICB2, LEOL) IF (LEOL) GO TO 999 IF (CBUFFR(ICB1) .NE. CDIR) GO TO 999 C 10 CONTINUE ICB1 = ICB1 + 1 LDIRL = .TRUE. C 999 CONTINUE RETURN END SUBROUTINE TPCOMM C C----------------------------------------------------------------------- C C FAMILY C ------ C TEMPLATE PROCESSOR C C PURPOSE C ------- C TO PROCESS COMMENT DIRECTIVES C C----------------------------------------------------------------------- C C GLOBAL CONSTANTS C CHARACTER*1 CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 COMMON / GLCOMC / CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 C C INPUT / OUTPUT CONTROL INTERFACE C CHARACTER*1 CBUFFR(2000) LOGICAL LBREAK, LFORT, LISTI, LISTO INTEGER ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOMC / CBUFFR COMMON / IOCOMI / ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOML / LBREAK, LFORT, LISTI, LISTO C C MEMORY MANAGER INTERFACE C CHARACTER*1 CSTORE(20000) INTEGER IHASH(601), ISTORE(6000) INTEGER ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS COMMON / MMCOMC / CSTORE COMMON / MMCOMH / IHASH COMMON / MMCOMS / ISTORE COMMON / MMCOMI / ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS C C MACRO PROCESSOR INTERFACE C CHARACTER*1 CDIV, CEOL, CEOR, CONC, CSUB, A CTOP LOGICAL LEMPTY, LSUB COMMON / MPCOMC / CDIV, CEOL, CEOR, CONC, CSUB, A CTOP COMMON / MPCOML / LEMPTY, LSUB C C TEMPLATE PROCESSOR INTERFACE C CHARACTER*1 CDIR, CSTAR INTEGER ICBP1(4), ICBP2(4) INTEGER ITOPDO, IARGS, INESTD, INESTF LOGICAL LCOL1, LDIRL, LEND, LINITM, L1TRIP COMMON / TPCOMC / CDIR, CSTAR COMMON / TPCOMI / ICBP1, ITOPDO, IARGS, ICBP2, INESTD, B INESTF COMMON / TPCOML / LCOL1, LDIRL, LEND, LINITM, L1TRIP C C LOCAL VARIABLES AND PARAMETERS C CHARACTER*1 C(16) INTEGER ID(1), IK(3) INTEGER IKYDIM, ICKDIM, IDSDIM LOGICAL LERROR EXTERNAL TPSYNT, TPRDBL, IOERRM SAVE IKYDIM, IK, ICKDIM, C, IDSDIM, ID DATA IDSDIM, ID(1) / 1, 7 / DATA A IKYDIM, ICKDIM, B IK(1), C IK(2), D IK(3) E / 3, 16, F 7, G 6, H 3 / DATA B C(1), C(2), C(3), C(4), C(5), C(6), C(7), C C(8), C(9), C(10), C(11), C(12), C(13), D C(14), C(15), C(16) E / F 'C', 'O', 'M', 'M', 'E', 'N', 'T', G 'E', 'N', 'D', 'C', 'O', 'M', H 'E', 'N', 'D' / C C CHECK SYNTAX C CALL TPSYNT (ID, IDSDIM, .FALSE., LERROR) IF (LERROR) GO TO 999 C C READ A BLOCK; UNTIL *ENDCOM C CALL TPRDBL (IK, IKYDIM, C, ICKDIM, ID, IDSDIM, A .FALSE., .TRUE., .FALSE., LERROR) IF (.NOT. LEND) GO TO 999 C C AN -END- HAS POSSIBLY BEEN ENCOUNTERED C CALL IOERRM (.FALSE., A '('' ******** TPCOMM - COMMENT HAS NO MATCHING ENDCOM'')') C 999 CONTINUE RETURN END SUBROUTINE TPDELE C C----------------------------------------------------------------------- C C FAMILY C ------ C TEMPLATE PROCESSOR C C PURPOSE C ------- C TO PROCESS DELETE DIRECTIVES C C----------------------------------------------------------------------- C C GLOBAL CONSTANTS C CHARACTER*1 CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 COMMON / GLCOMC / CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 C C INPUT / OUTPUT CONTROL INTERFACE C CHARACTER*1 CBUFFR(2000) LOGICAL LBREAK, LFORT, LISTI, LISTO INTEGER ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOMC / CBUFFR COMMON / IOCOMI / ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOML / LBREAK, LFORT, LISTI, LISTO C C MEMORY MANAGER INTERFACE C CHARACTER*1 CSTORE(20000) INTEGER IHASH(601), ISTORE(6000) INTEGER ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS COMMON / MMCOMC / CSTORE COMMON / MMCOMH / IHASH COMMON / MMCOMS / ISTORE COMMON / MMCOMI / ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS C C MACRO PROCESSOR INTERFACE C CHARACTER*1 CDIV, CEOL, CEOR, CONC, CSUB, A CTOP LOGICAL LEMPTY, LSUB COMMON / MPCOMC / CDIV, CEOL, CEOR, CONC, CSUB, A CTOP COMMON / MPCOML / LEMPTY, LSUB C C TEMPLATE PROCESSOR INTERFACE C CHARACTER*1 CDIR, CSTAR INTEGER ICBP1(4), ICBP2(4) INTEGER ITOPDO, IARGS, INESTD, INESTF LOGICAL LCOL1, LDIRL, LEND, LINITM, L1TRIP COMMON / TPCOMC / CDIR, CSTAR COMMON / TPCOMI / ICBP1, ITOPDO, IARGS, ICBP2, INESTD, B INESTF COMMON / TPCOML / LCOL1, LDIRL, LEND, LINITM, L1TRIP C C LOCAL VARIABLES AND PARAMETERS C INTEGER ID(4) INTEGER IDSDIM LOGICAL LERROR, LFOUND EXTERNAL TPSYNT, MMDELV SAVE IDSDIM, ID DATA IDSDIM, ID(1), ID(2), ID(3), ID(4) A / 4, 1, 5, 2, 7 / C C CHECK SYNTAX C CALL TPSYNT (ID, IDSDIM, .FALSE., LERROR) IF (LERROR) GO TO 999 C C DELETE THE VARIABLE C CALL MMDELV (CBUFFR, ICBP1(1), ICBP2(1), LFOUND) C 999 CONTINUE RETURN END SUBROUTINE TPDO C C----------------------------------------------------------------------- C C FAMILY C ------ C TEMPLATE PROCESSOR C C PURPOSE C ------- C TO PROCESS DO DIRECTIVES C C----------------------------------------------------------------------- C C GLOBAL CONSTANTS C CHARACTER*1 CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 COMMON / GLCOMC / CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 C C INPUT / OUTPUT CONTROL INTERFACE C CHARACTER*1 CBUFFR(2000) LOGICAL LBREAK, LFORT, LISTI, LISTO INTEGER ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOMC / CBUFFR COMMON / IOCOMI / ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOML / LBREAK, LFORT, LISTI, LISTO C C MEMORY MANAGER INTERFACE C CHARACTER*1 CSTORE(20000) INTEGER IHASH(601), ISTORE(6000) INTEGER ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS COMMON / MMCOMC / CSTORE COMMON / MMCOMH / IHASH COMMON / MMCOMS / ISTORE COMMON / MMCOMI / ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS C C MACRO PROCESSOR INTERFACE C CHARACTER*1 CDIV, CEOL, CEOR, CONC, CSUB, A CTOP LOGICAL LEMPTY, LSUB COMMON / MPCOMC / CDIV, CEOL, CEOR, CONC, CSUB, A CTOP COMMON / MPCOML / LEMPTY, LSUB C C TEMPLATE PROCESSOR INTERFACE C CHARACTER*1 CDIR, CSTAR INTEGER ICBP1(4), ICBP2(4) INTEGER ITOPDO, IARGS, INESTD, INESTF LOGICAL LCOL1, LDIRL, LEND, LINITM, L1TRIP COMMON / TPCOMC / CDIR, CSTAR COMMON / TPCOMI / ICBP1, ITOPDO, IARGS, ICBP2, INESTD, B INESTF COMMON / TPCOML / LCOL1, LDIRL, LEND, LINITM, L1TRIP C C LOCAL VARIABLES AND PARAMETERS C CHARACTER*1 C(10), CD(1), CIN(1) INTEGER ID(11), IK(3) LOGICAL LERROR, LFOUND INTEGER IKYDIM, ICKDIM, ICN1, ICN2, I1, I2, I3, ITEMP, A ICV1 INTEGER ICDDIM, ICIDIM, IDSDIM EXTERNAL TPSYNT, UTBLDN, MMPUTV, UTCVCI, TPRDBL, A MMNEWI, MMPSHV, MMSETP, IOERRM SAVE ICDDIM, CD, ICIDIM, CIN SAVE IKYDIM, IK, ICKDIM, C, IDSDIM, ID DATA ICDDIM / 1 / DATA CD(1) / 'D' / DATA ICIDIM / 1 / DATA CIN(1) / 'I' / DATA A IKYDIM,ICKDIM,IK(1),IK(2),IK(3) B / 3, 10, 2, 5, 3 / DATA A C(1), C(2), B C(3), C(4), C(5), C(6), C(7), C C(8), C(9), C(10) D / 'D', 'O', E 'E', 'N', 'D', 'D', 'O', F 'E', 'N', 'D' / DATA A IDSDIM, B ID(1), ID(2), ID(3), ID(4), ID(5), C ID(6), ID(7), ID(8), ID(9), ID(10), ID(11) D / 11, E 1, 5, 4, 6, 3, F 6, -3, 10, 6, 2, 7 / C C CHECK SYNTAX C CALL TPSYNT (ID, IDSDIM, .FALSE., LERROR) IF (LERROR) GO TO 999 INESTD = INESTD + 1 ICN1 = ICBEND + 1 C C GET LOOP INDEX AND LOOP PARAMETERS C CALL UTBLDN (CSTAR, CIN, 1, ICIDIM, INESTD, A CBUFFR, ICN1, ICN2, ICBDIM, LERROR) ICBEND = ICN2 CALL MMPUTV (CBUFFR, ICN1, ICN2, A CBUFFR, ICBP1(1), ICBP2(1)) CALL MMPUTV (CBUFFR, ICBP1(1), ICBP2(1), A CBUFFR, ICBP1(2), ICBP2(2)) CALL UTCVCI (CBUFFR, ICBP1(2), ICBP2(2), I1, LERROR) CALL UTCVCI (CBUFFR, ICBP1(3), ICBP2(3), I2, LERROR) I3 = 1 IF (IARGS .EQ. 4) A CALL UTCVCI (CBUFFR, ICBP1(4), ICBP2(4), I3, LERROR) IF (L1TRIP .OR. ((I2-I1)*ISIGN(1,I3) .GE. 0)) GO TO 10 CALL TPRDBL (IK, IKYDIM, C, ICKDIM, ID, IDSDIM, A .FALSE., .TRUE., .FALSE., LERROR) IF (LEND) GO TO 30 INESTD = INESTD - 1 GO TO 999 C 10 CONTINUE CALL MMNEWI (ITEMP) ISTORE(ITEMP) = I2 ISTORE(ITEMP+1) = I3 ISTORE(ITEMP+2) = ITOPDO ITOPDO = ITEMP IF (INESTD .GT. 1) GO TO 20 CALL UTBLDN (CSTAR, CD, 1, ICDDIM, -1, A CBUFFR, 1, ICN2, ICBDIM, LERROR) ICBEOL = ICN2 ICV1 = ICN2 + 1 C C READ A BLOCK UNTIL *ENDDO. PUSH CONTENTS OF DO RANGE C ONTO STACK. C CALL TPRDBL (IK, IKYDIM, C, ICKDIM, ID, IDSDIM, A .FALSE., .FALSE., .FALSE., LERROR) IF (LEND) GO TO 30 CALL MMPUTV (CBUFFR, 1, ICN2, CBUFFR, ICV1, ICBEOL) CALL MMPSHV (CBUFFR, 1, ICN2, 1, LEMPTY, LFOUND) C 20 CONTINUE CALL UTBLDN (CSTAR, CD, 1, ICDDIM, INESTD, A CBUFFR, 1, ICN2, ICBDIM, LERROR) CALL MMSETP (CBUFFR, 1, ICN2) GO TO 999 C C WARNING - MATCHING ENDDO NOT FOUND C 30 CONTINUE CALL IOERRM (.FALSE., A '('' ******** TPDO - DO HAS NO MATCHING ENDDO'')') C 999 CONTINUE RETURN END SUBROUTINE TPELSE C C----------------------------------------------------------------------- C C FAMILY C ------ C TEMPLATE PROCESSOR C C PURPOSE C ------- C TO PROCESS ELSE DIRECTIVES C C----------------------------------------------------------------------- C C GLOBAL CONSTANTS C CHARACTER*1 CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 COMMON / GLCOMC / CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 C C INPUT / OUTPUT CONTROL INTERFACE C CHARACTER*1 CBUFFR(2000) LOGICAL LBREAK, LFORT, LISTI, LISTO INTEGER ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOMC / CBUFFR COMMON / IOCOMI / ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOML / LBREAK, LFORT, LISTI, LISTO C C MEMORY MANAGER INTERFACE C CHARACTER*1 CSTORE(20000) INTEGER IHASH(601), ISTORE(6000) INTEGER ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS COMMON / MMCOMC / CSTORE COMMON / MMCOMH / IHASH COMMON / MMCOMS / ISTORE COMMON / MMCOMI / ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS C C MACRO PROCESSOR INTERFACE C CHARACTER*1 CDIV, CEOL, CEOR, CONC, CSUB, A CTOP LOGICAL LEMPTY, LSUB COMMON / MPCOMC / CDIV, CEOL, CEOR, CONC, CSUB, A CTOP COMMON / MPCOML / LEMPTY, LSUB C C TEMPLATE PROCESSOR INTERFACE C CHARACTER*1 CDIR, CSTAR INTEGER ICBP1(4), ICBP2(4) INTEGER ITOPDO, IARGS, INESTD, INESTF LOGICAL LCOL1, LDIRL, LEND, LINITM, L1TRIP COMMON / TPCOMC / CDIR, CSTAR COMMON / TPCOMI / ICBP1, ITOPDO, IARGS, ICBP2, INESTD, B INESTF COMMON / TPCOML / LCOL1, LDIRL, LEND, LINITM, L1TRIP C C LOCAL VARIABLES AND PARAMETERS C CHARACTER*1 C(10) INTEGER ID(1), IDIF(4), IK(3) LOGICAL LERROR INTEGER IDSDIM, IDSDIF, IKYDIM, ICKDIM EXTERNAL TPSYNT, TPRDBL, IOERRM SAVE IKYDIM, IK, ICKDIM, C, IDSDIM, ID, IDSDIF, IDIF DATA IDSDIM, ID(1) / 1, 7 / DATA A IDSDIF, B IDIF(1), IDIF(2), IDIF(3), IDIF(4) C / 4, D 1, 6, 2, 8 / DATA A IKYDIM, ICKDIM, IK(1), IK(2), IK(3) B / 3, 10, 2, 5, 3 / DATA A C(1), C(2), B C(3), C(4), C(5), C(6), C(7), C C(8), C(9), C(10) / D 'I', 'F', E 'E', 'N', 'D', 'I', 'F', F 'E', 'N', 'D' / C C CHECK SYNTAX C CALL TPSYNT (ID, IDSDIM, .FALSE., LERROR) IF (LERROR) GO TO 999 INESTF = INESTF - 1 CALL TPRDBL (IK, IKYDIM, C, ICKDIM, IDIF, IDSDIF, A .TRUE., .TRUE., .FALSE., LERROR) IF (.NOT. LEND) GO TO 999 C C AN -END- HAS BEEN ENCOUNTERED C CALL IOERRM (.FALSE., A '('' ******** TPELSE - IF HAS NO MATCHING ENDIF'')') C 999 CONTINUE RETURN END SUBROUTINE TPENDO C C----------------------------------------------------------------------- C C FAMILY C ------ C TEMPLATE PROCESSOR C C PURPOSE C ------- C TO PROCESS ENDDO DIRECTIVES C C----------------------------------------------------------------------- C C GLOBAL CONSTANTS C CHARACTER*1 CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 COMMON / GLCOMC / CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 C C INPUT / OUTPUT CONTROL INTERFACE C CHARACTER*1 CBUFFR(2000) LOGICAL LBREAK, LFORT, LISTI, LISTO INTEGER ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOMC / CBUFFR COMMON / IOCOMI / ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOML / LBREAK, LFORT, LISTI, LISTO C C MEMORY MANAGER INTERFACE C CHARACTER*1 CSTORE(20000) INTEGER IHASH(601), ISTORE(6000) INTEGER ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS COMMON / MMCOMC / CSTORE COMMON / MMCOMH / IHASH COMMON / MMCOMS / ISTORE COMMON / MMCOMI / ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS C C MACRO PROCESSOR INTERFACE C CHARACTER*1 CDIV, CEOL, CEOR, CONC, CSUB, A CTOP LOGICAL LEMPTY, LSUB COMMON / MPCOMC / CDIV, CEOL, CEOR, CONC, CSUB, A CTOP COMMON / MPCOML / LEMPTY, LSUB C C TEMPLATE PROCESSOR INTERFACE C CHARACTER*1 CDIR, CSTAR INTEGER ICBP1(4), ICBP2(4) INTEGER ITOPDO, IARGS, INESTD, INESTF LOGICAL LCOL1, LDIRL, LEND, LINITM, L1TRIP COMMON / TPCOMC / CDIR, CSTAR COMMON / TPCOMI / ICBP1, ITOPDO, IARGS, ICBP2, INESTD, B INESTF COMMON / TPCOML / LCOL1, LDIRL, LEND, LINITM, L1TRIP C C LOCAL VARIABLES C CHARACTER*1 CD(1), CIN(1) INTEGER ID(1) INTEGER ICDDIM, ICIDIM, IDSDIM, ICN2, ICV2, ICV1, A I, I2, I3, ITEMP LOGICAL LERROR, LFOUND EXTERNAL TPSYNT, UTBLDN, MMGETV, UTCVCI, UTCVIC, A MMPUTV, MMPOPV, MMPSHV, MMRETI, IOERRM SAVE ICDDIM, CD, ICIDIM, CIN, IDSDIM, ID DATA ICDDIM / 1 / DATA CD(1) / 'D' / DATA ICIDIM / 1 / DATA CIN(1) / 'I' / DATA IDSDIM, ID(1) / 1, 7 / C C CHECK SYNTAX C CALL TPSYNT (ID, IDSDIM, .FALSE., LERROR) IF (LERROR) GO TO 999 IF (INESTD .LE. 0) GO TO 20 CALL UTBLDN (CSTAR, CIN, 1, ICIDIM, INESTD, A CBUFFR, 1, ICN2, ICBDIM, LERROR) CALL MMGETV (CBUFFR, 1, ICN2, CBUFFR, 1, ICV2, ICBDIM, LFOUND) ICN2 = ICV2 ICV1 = ICV2 + 1 CALL MMGETV (CBUFFR, 1, ICN2, A CBUFFR, ICV1, ICV2, ICBDIM, LFOUND) CALL UTCVCI (CBUFFR, ICV1, ICV2, I, LERROR) I2 = ISTORE(ITOPDO) I3 = ISTORE(ITOPDO+1) I = I + I3 IF ((I2-I)*ISIGN(1,I3) .LT. 0) GO TO 10 CALL UTCVIC (CBUFFR, ICV1, ICV2, ICBDIM, I, LERROR) CALL MMPUTV (CBUFFR, 1, ICN2, CBUFFR, ICV1, ICV2) CALL UTBLDN (CSTAR, CD, 1, ICDDIM, INESTD, A CBUFFR, 1, ICN2, ICBDIM, LERROR) IF (INESTD .GT. 1) CALL MMPOPV (LEMPTY) CALL MMPSHV (CBUFFR, 1, ICN2, 2, LEMPTY, LFOUND) GO TO 999 C 10 CONTINUE INESTD = INESTD - 1 ITEMP = ITOPDO ITOPDO = ISTORE(ITOPDO+2) CALL MMRETI (ITEMP) GO TO 999 C 20 CONTINUE CALL IOERRM (.FALSE., A '('' ******** TPENDO - MISPLACED ENDDO'')') C C 999 CONTINUE RETURN END SUBROUTINE TPENDF C C----------------------------------------------------------------------- C C FAMILY C ------ C TEMPLATE PROCESSOR C C PURPOSE C ------- C TO PROCESS ENDIF DIRECTIVES C C----------------------------------------------------------------------- C C GLOBAL CONSTANTS C CHARACTER*1 CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 COMMON / GLCOMC / CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 C C INPUT / OUTPUT CONTROL INTERFACE C CHARACTER*1 CBUFFR(2000) LOGICAL LBREAK, LFORT, LISTI, LISTO INTEGER ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOMC / CBUFFR COMMON / IOCOMI / ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOML / LBREAK, LFORT, LISTI, LISTO C C MEMORY MANAGER INTERFACE C CHARACTER*1 CSTORE(20000) INTEGER IHASH(601), ISTORE(6000) INTEGER ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS COMMON / MMCOMC / CSTORE COMMON / MMCOMH / IHASH COMMON / MMCOMS / ISTORE COMMON / MMCOMI / ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS C C MACRO PROCESSOR INTERFACE C CHARACTER*1 CDIV, CEOL, CEOR, CONC, CSUB, A CTOP LOGICAL LEMPTY, LSUB COMMON / MPCOMC / CDIV, CEOL, CEOR, CONC, CSUB, A CTOP COMMON / MPCOML / LEMPTY, LSUB C C TEMPLATE PROCESSOR INTERFACE C CHARACTER*1 CDIR, CSTAR INTEGER ICBP1(4), ICBP2(4) INTEGER ITOPDO, IARGS, INESTD, INESTF LOGICAL LCOL1, LDIRL, LEND, LINITM, L1TRIP COMMON / TPCOMC / CDIR, CSTAR COMMON / TPCOMI / ICBP1, ITOPDO, IARGS, ICBP2, INESTD, B INESTF COMMON / TPCOML / LCOL1, LDIRL, LEND, LINITM, L1TRIP C C LOCAL VARIABLES C INTEGER ID(1) LOGICAL LERROR INTEGER IDSDIM EXTERNAL TPSYNT, IOERRM SAVE IDSDIM, ID DATA IDSDIM, ID(1) / 1, 7 / C C CHECK SYNTAX C CALL TPSYNT (ID, IDSDIM, .FALSE., LERROR) IF (LERROR) GO TO 999 IF (INESTF .LE. 0) GO TO 10 INESTF = INESTF - 1 GO TO 999 C 10 CONTINUE CALL IOERRM (.FALSE., A '('' ******** TPENDF - MISPLACED ENDIF'')') C 999 CONTINUE RETURN END SUBROUTINE TPEVAL C C----------------------------------------------------------------------- C C FAMILY C ------ C TEMPLATE PROCESSOR C C PURPOSE C ------- C TO CALL ROUTINES TO PROCESS DIRECTIVES C C----------------------------------------------------------------------- C C GLOBAL CONSTANTS C CHARACTER*1 CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 COMMON / GLCOMC / CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 C C INPUT / OUTPUT CONTROL INTERFACE C CHARACTER*1 CBUFFR(2000) LOGICAL LBREAK, LFORT, LISTI, LISTO INTEGER ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOMC / CBUFFR COMMON / IOCOMI / ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOML / LBREAK, LFORT, LISTI, LISTO C C MEMORY MANAGER INTERFACE C CHARACTER*1 CSTORE(20000) INTEGER IHASH(601), ISTORE(6000) INTEGER ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS COMMON / MMCOMC / CSTORE COMMON / MMCOMH / IHASH COMMON / MMCOMS / ISTORE COMMON / MMCOMI / ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS C C MACRO PROCESSOR INTERFACE C CHARACTER*1 CDIV, CEOL, CEOR, CONC, CSUB, A CTOP LOGICAL LEMPTY, LSUB COMMON / MPCOMC / CDIV, CEOL, CEOR, CONC, CSUB, A CTOP COMMON / MPCOML / LEMPTY, LSUB C C TEMPLATE PROCESSOR INTERFACE C CHARACTER*1 CDIR, CSTAR INTEGER ICBP1(4), ICBP2(4) INTEGER ITOPDO, IARGS, INESTD, INESTF LOGICAL LCOL1, LDIRL, LEND, LINITM, L1TRIP COMMON / TPCOMC / CDIR, CSTAR COMMON / TPCOMI / ICBP1, ITOPDO, IARGS, ICBP2, INESTD, B INESTF COMMON / TPCOML / LCOL1, LDIRL, LEND, LINITM, L1TRIP C C LOCAL VARIABLES C CHARACTER*1 C(79) INTEGER IK(16) INTEGER IKYDIM, ICKDIM, I EXTERNAL TPCHKD, UTRDKY, TPAPPE, TPCOMM, TPDELE, TPDO, A TPELSE, TPENDO, TPENDF, TPIF, TPINCL, TPOPT, B TPRSET, TPSET, IOERRM SAVE IKYDIM, IK, ICKDIM, C DATA A IKYDIM, ICKDIM, B IK(1), C IK(2), D IK(3), E IK(4), F IK(5), G IK(6), H IK(7), I IK(8) J / 16, 79, K 6, L 7, M 6, N 2, O 4, P 5, Q 5, R 2 / DATA B C(1), C(2), C(3), C(4), C(5), C(6), C C(7), C(8), C(9), C(10), C(11), C(12), C(13), D C(14), C(15), C(16), C(17), C(18), C(19), E C(20), C(21), F C(22), C(23), C(24), C(25), G C(26), C(27), C(28), C(29), C(30), H C(31), C(32), C(33), C(34), C(35), I C(36), C(37) K / 'A', 'P', 'P', 'E', 'N', 'D', L 'C', 'O', 'M', 'M', 'E', 'N', 'T', M 'D', 'E', 'L', 'E', 'T', 'E', N 'D', 'O', O 'E', 'L', 'S', 'E', P 'E', 'N', 'D', 'D', 'O', Q 'E', 'N', 'D', 'I', 'F', R 'I', 'F' / DATA A IK(9), B IK(10), C IK(11), D IK(12), E IK(13), F IK(14), G IK(15), H IK(16) I / 7, J 6, K 5, L 3, M 6, N 6, O 6, P 3 / DATA A C(38), C(39), C(40), C(41), C(42), C(43), C(44), B C(45), C(46), C(47), C(48), C(49), C(50), C C(51), C(52), C(53), C(54), C(55), D C(56), C(57), C(58), E C(59), C(60), C(61), C(62), C(63), C(64), F C(65), C(66), C(67), C(68), C(69), C(70), G C(71), C(72), C(73), C(74), C(75), C(76), H C(77), C(78), C(79) I / 'I', 'N', 'C', 'L', 'U', 'D', 'E', J 'O', 'P', 'T', 'I', 'O', 'N', K 'R', 'E', 'S', 'E', 'T', L 'S', 'E', 'T', M 'E', 'N', 'D', 'A', 'P', 'P', N 'E', 'N', 'D', 'C', 'O', 'M', O 'E', 'N', 'D', 'S', 'E', 'T', P 'E', 'N', 'D' / C ICB1 = ICB0 ICB2 = ICB3 CALL TPCHKD IF (.NOT. LDIRL) GO TO 999 C C A DIRECTIVE LINE HAS BEEN FOUND. CHECK WHICH ONE IT IS C CALL UTRDKY (CBUFFR, ICB1, ICB2, IK, IKYDIM, C, ICKDIM, I) GO TO (10, 20, 30, 40, 50, 60, 70, 80, 90, A 100, 110, 120, 130, 140, 150, 160, 170), I C C PROCESS -APPEND- C 10 CONTINUE CALL TPAPPE GO TO 999 C C PROCESS -COMMENT- C 20 CONTINUE CALL TPCOMM GO TO 999 C C PROCESS -DELETE- C 30 CONTINUE CALL TPDELE GO TO 999 C C PROCESS -DO- C 40 CONTINUE CALL TPDO GO TO 999 C C PROCESS -ELSE- C 50 CONTINUE CALL TPELSE GO TO 999 C C PROCESS -ENDDO- C 60 CONTINUE CALL TPENDO GO TO 999 C C PROCESS -ENDIF- C 70 CONTINUE CALL TPENDF GO TO 999 C C PROCESS -IF- C 80 CONTINUE CALL TPIF GO TO 999 C C PROCESS -INCLUDE- C 90 CONTINUE CALL TPINCL GO TO 999 C C PROCESS -OPTION- C 100 CONTINUE CALL TPOPT GO TO 999 C C PROCESS -RESET- C 110 CONTINUE CALL TPRSET GO TO 999 C C PROCESS -SET- C 120 CONTINUE CALL TPSET GO TO 999 C C PROCESS -ENDAPP- C 130 CONTINUE CALL IOERRM (.FALSE., A '('' ******** TPEVAL - MISPLACED ENDAPP'')') GO TO 999 C C PROCESS -ENDCOM- C 140 CONTINUE CALL IOERRM (.FALSE., A '('' ******** TPEVAL - MISPLACED ENDCOM'')') GO TO 999 C C PROCESS -ENDSET- C 150 CONTINUE CALL IOERRM (.FALSE., A '('' ******** TPEVAL - MISPLACED ENDSET'')') GO TO 999 C C PROCESS -END- C 160 CONTINUE LEND = .TRUE. GO TO 999 C C PROCESS UNRECOGNIZED DIRECTIVES C 170 CONTINUE CALL IOERRM (.FALSE., A '('' ******** TPEVAL - ILLEGAL OR MISSPELLED DIRECTIVE'')') C 999 CONTINUE RETURN END SUBROUTINE TPEXPR (ICV1, ICV2, LSCAN, LERROR) C C----------------------------------------------------------------------- C C FAMILY C ------ C TEMPLATE PROCESSOR C C PURPOSE C ------- C TO DETERMINE IF AN EXPRESSION IS VALID AND RETURN ITS VALUE. C CURRENTLY, EXPRESSIONS MAY CONSIST ONLY OF VARIABLES OR CONSTANTS. C C PARAMETERS C ---------- C ICV1 -I- INDEX INTO CBUFFR OF THE FIRST C CHARACTER IN THE EXPRESSION C ICV2 -I- INDEX OF THE LAST CHARACTER C LSCAN -I- IF TRUE, THEN VALIDATE (SCAN) BUT DO NOT EVALUATE C LERROR -O- TRUE IF THE EXPRESSION WAS INVALID C C----------------------------------------------------------------------- C C GLOBAL CONSTANTS C CHARACTER*1 CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 COMMON / GLCOMC / CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 C C INPUT / OUTPUT CONTROL INTERFACE C CHARACTER*1 CBUFFR(2000) LOGICAL LBREAK, LFORT, LISTI, LISTO INTEGER ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOMC / CBUFFR COMMON / IOCOMI / ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOML / LBREAK, LFORT, LISTI, LISTO C C MEMORY MANAGER INTERFACE C CHARACTER*1 CSTORE(20000) INTEGER IHASH(601), ISTORE(6000) INTEGER ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS COMMON / MMCOMC / CSTORE COMMON / MMCOMH / IHASH COMMON / MMCOMS / ISTORE COMMON / MMCOMI / ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS C C MACRO PROCESSOR INTERFACE C CHARACTER*1 CDIV, CEOL, CEOR, CONC, CSUB, A CTOP LOGICAL LEMPTY, LSUB COMMON / MPCOMC / CDIV, CEOL, CEOR, CONC, CSUB, A CTOP COMMON / MPCOML / LEMPTY, LSUB C C TEMPLATE PROCESSOR INTERFACE C CHARACTER*1 CDIR, CSTAR INTEGER ICBP1(4), ICBP2(4) INTEGER ITOPDO, IARGS, INESTD, INESTF LOGICAL LCOL1, LDIRL, LEND, LINITM, L1TRIP COMMON / TPCOMC / CDIR, CSTAR COMMON / TPCOMI / ICBP1, ITOPDO, IARGS, ICBP2, INESTD, B INESTF COMMON / TPCOML / LCOL1, LDIRL, LEND, LINITM, L1TRIP C C LOCAL VARIABLES AND PARAMETERS C INTEGER ICV1, ICV2 LOGICAL L, LERROR, LSCAN INTEGER ICN1, ICN2 EXTERNAL UTRDNA, MMGETV, UTRDNU, UTRDQS C IF (LLE(CA,CBUFFR(ICB1)) .AND. A LLE(CBUFFR(ICB1),CZ)) GO TO 10 IF (LLE(C0,CBUFFR(ICB1)) .AND. A LLE(CBUFFR(ICB1),C9)) GO TO 20 IF (CBUFFR(ICB1) .EQ. CMINUS) GO TO 20 IF (CBUFFR(ICB1) .EQ. CPLUS) GO TO 20 IF (CBUFFR(ICB1) .EQ. CQUOTE) GO TO 30 IF (CBUFFR(ICB1) .EQ. CPOINT) GO TO 40 LERROR = .TRUE. GO TO 999 C C PROCESS A NAME C 10 CONTINUE CALL UTRDNA (CBUFFR, ICB1, ICB2, ICN1, ICN2, LERROR) IF (LERROR) GO TO 999 IF (LSCAN) GO TO 999 ICV1 = ICBEND + 1 CALL MMGETV (CBUFFR, ICN1, ICN2, CBUFFR, ICV1, ICV2, ICBDIM, L) ICBEND = ICV2 LERROR = .NOT. L GO TO 999 C C PROCESS A NUMBER C 20 CONTINUE CALL UTRDNU (CBUFFR, ICB1, ICB2, ICV1, ICV2, LERROR) GO TO 999 C C PROCESS A QUOTED STRING C 30 CONTINUE CALL UTRDQS (CBUFFR, ICB1, ICB2, ICV1, ICV2, LERROR) GO TO 999 C C PROCESS A LOGICAL CONSTANT C 40 CONTINUE CALL UTRDQS (CBUFFR, ICB1, ICB2, ICV1, ICV2, LERROR) IF (LERROR) GO TO 999 ICV1 = ICV1 - 1 ICV2 = ICV2 + 1 C 999 CONTINUE RETURN END SUBROUTINE TPIF C C----------------------------------------------------------------------- C C FAMILY C ------ C TEMPLATE PROCESSOR C C PURPOSE C ------- C TO PROCESS IF DIRECTIVES C C----------------------------------------------------------------------- C C GLOBAL CONSTANTS C CHARACTER*1 CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 COMMON / GLCOMC / CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 C C INPUT / OUTPUT CONTROL INTERFACE C CHARACTER*1 CBUFFR(2000) LOGICAL LBREAK, LFORT, LISTI, LISTO INTEGER ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOMC / CBUFFR COMMON / IOCOMI / ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOML / LBREAK, LFORT, LISTI, LISTO C C MEMORY MANAGER INTERFACE C CHARACTER*1 CSTORE(20000) INTEGER IHASH(601), ISTORE(6000) INTEGER ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS COMMON / MMCOMC / CSTORE COMMON / MMCOMH / IHASH COMMON / MMCOMS / ISTORE COMMON / MMCOMI / ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS C C MACRO PROCESSOR INTERFACE C CHARACTER*1 CDIV, CEOL, CEOR, CONC, CSUB, A CTOP LOGICAL LEMPTY, LSUB COMMON / MPCOMC / CDIV, CEOL, CEOR, CONC, CSUB, A CTOP COMMON / MPCOML / LEMPTY, LSUB C C TEMPLATE PROCESSOR INTERFACE C CHARACTER*1 CDIR, CSTAR INTEGER ICBP1(4), ICBP2(4) INTEGER ITOPDO, IARGS, INESTD, INESTF LOGICAL LCOL1, LDIRL, LEND, LINITM, L1TRIP COMMON / TPCOMC / CDIR, CSTAR COMMON / TPCOMI / ICBP1, ITOPDO, IARGS, ICBP2, INESTD, B INESTF COMMON / TPCOML / LCOL1, LDIRL, LEND, LINITM, L1TRIP C C LOCAL VARIABLES AND PARAMETERS C CHARACTER*1 C(14), CN(2) INTEGER ID(7), IK(4) INTEGER ICNDIM, IKYDIM, ICKDIM, IDSDIM, LEN1, LEN2, A I1, I2, I, INEST LOGICAL LERROR, LFOUND, LVALUE EXTERNAL TPSYNT, UTCVCL, MMPUTV, MMPSHV, MPLINE, A TPCHKD, UTRDKY, IOERRM SAVE IKYDIM, IK, ICKDIM, C, ICNDIM, CN, IDSDIM, ID DATA ICNDIM / 2 / DATA CN(1), CN(2) / '*', 'F' / DATA A IKYDIM, ICKDIM, B IK(1), C IK(2), D IK(3), E IK(4) F / 4, 14, G 2, H 4, I 5, J 3 / DATA B C(1), C(2), C C(3), C(4), C(5), C(6), D C(7), C(8), C(9), C(10), C(11), E C(12), C(13), C(14) G / 'I', 'F', H 'E', 'L', 'S', 'E', I 'E', 'N', 'D', 'I', 'F', J 'E', 'N', 'D' / DATA IDSDIM, ID(1), ID(2), ID(3), ID(4), ID(5), ID(6), ID(7) A / 7, 1, 6, -4, 6, 6, 2, 8 / C C CHECK SYNTAX C CALL TPSYNT (ID, IDSDIM, .FALSE., LERROR) IF (LERROR) GO TO 999 IF ((IARGS .EQ. 3) .OR. A ((IARGS .EQ. 2) .AND. (ICBEOL.NE.ICBP2(2)))) GO TO 3 C C HAVE FOUND FORM: '*IF(L)' C CALL UTCVCL (CBUFFR, ICBP1(1), ICBP2(1), LVALUE, LERROR) IF (IARGS .EQ. 1) GO TO 10 GO TO 9 3 CONTINUE C C HAVE FOUND FORM: '*IF(EXP1=EXP2)' C LVALUE = .FALSE. LEN1 = ICBP2(1) - ICBP1(1) + 1 LEN2 = ICBP2(2) - ICBP1(2) + 1 IF (LEN1 .NE. LEN2) GO TO 8 I1 = ICBP1(1) I2 = ICBP1(2) DO 5 I = 1, LEN1 IF (CBUFFR(I1) .NE. CBUFFR(I2)) GO TO 8 I1 = I1 + 1 I2 = I2 + 1 5 CONTINUE LVALUE = .TRUE. 8 CONTINUE IF (IARGS .EQ. 2) GO TO 10 C C C PROCESS A ONE-LINE IF STATEMENT C 9 CONTINUE IF (.NOT. LVALUE) GO TO 999 CALL MMPUTV (CN, 1, ICNDIM, CBUFFR, ICBP1(IARGS), ICBP2(IARGS)) CALL MMPSHV (CN, 1, ICNDIM, 1, LEMPTY, LFOUND) GO TO 999 C C PROCESS A MULTI-LINE IF STATEMENT C 10 CONTINUE INESTF = INESTF + 1 IF (LVALUE) GO TO 999 INEST = INESTF C 20 CONTINUE CALL MPLINE (.FALSE.) CALL TPCHKD IF (.NOT. LDIRL) GO TO 20 CALL UTRDKY (CBUFFR, ICB1, ICB2, IK, IKYDIM, C, ICKDIM, I) GO TO (30, 40, 50, 60, 20), I C C AN -IF- HAS BEEN ENCOUNTERED C 30 CONTINUE CALL TPSYNT (ID, IDSDIM, .TRUE., LERROR) IF (IARGS .EQ. 1) INESTF = INESTF + 1 C C IF IARGS=2 AND ICB1 > ICB2, ASSUME C DIRECTIVE IS OF FORM '*IF(ARG1 = ARG2)' C IF ((IARGS .EQ. 2) .AND. (ICB1 .GT. ICB2)) INESTF = INESTF + 1 GO TO 20 C C AN -ELSE- HAS BEEN ENCOUNTERED C 40 CONTINUE IF (INESTF .LE. INEST) GO TO 999 GO TO 20 C C AN -ENDIF- HAS BEEN ENCOUNTERED C 50 CONTINUE INESTF = INESTF - 1 IF (INESTF .LT. INEST) GO TO 999 GO TO 20 C C AN -END- HAS POSSIBLY BEEN ENCOUNTERED C 60 CONTINUE LEND = ICB1 .GT. ICB2 IF (.NOT. LEND) GO TO 20 CALL IOERRM (.FALSE., A '('' ******** TPIF - IF HAS NO MATCHING ENDIF'')') C 999 CONTINUE RETURN END SUBROUTINE TPINCL C C----------------------------------------------------------------------- C C FAMILY C ------ C TEMPLATE PROCESSOR C C PURPOSE C ------- C TO PROCESS INCLUDE DIRECTIVES C C----------------------------------------------------------------------- C C GLOBAL CONSTANTS C CHARACTER*1 CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 COMMON / GLCOMC / CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 C C INPUT / OUTPUT CONTROL INTERFACE C CHARACTER*1 CBUFFR(2000) LOGICAL LBREAK, LFORT, LISTI, LISTO INTEGER ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOMC / CBUFFR COMMON / IOCOMI / ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOML / LBREAK, LFORT, LISTI, LISTO C C MEMORY MANAGER INTERFACE C CHARACTER*1 CSTORE(20000) INTEGER IHASH(601), ISTORE(6000) INTEGER ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS COMMON / MMCOMC / CSTORE COMMON / MMCOMH / IHASH COMMON / MMCOMS / ISTORE COMMON / MMCOMI / ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS C C MACRO PROCESSOR INTERFACE C CHARACTER*1 CDIV, CEOL, CEOR, CONC, CSUB, A CTOP LOGICAL LEMPTY, LSUB COMMON / MPCOMC / CDIV, CEOL, CEOR, CONC, CSUB, A CTOP COMMON / MPCOML / LEMPTY, LSUB C C TEMPLATE PROCESSOR INTERFACE C CHARACTER*1 CDIR, CSTAR INTEGER ICBP1(4), ICBP2(4) INTEGER ITOPDO, IARGS, INESTD, INESTF LOGICAL LCOL1, LDIRL, LEND, LINITM, L1TRIP COMMON / TPCOMC / CDIR, CSTAR COMMON / TPCOMI / ICBP1, ITOPDO, IARGS, ICBP2, INESTD, B INESTF COMMON / TPCOML / LCOL1, LDIRL, LEND, LINITM, L1TRIP C C LOCAL VARIABLES AND PARAMETERS C INTEGER ID(4), IDSDIM LOGICAL LERROR, LFOUND EXTERNAL TPSYNT, MMPSHV, IOERRM SAVE IDSDIM, ID DATA IDSDIM, ID(1), ID(2), ID(3), ID(4) A / 4, 1, 5, 2, 8 / C C CHECK SYNTAX, AND PUSH THE VARIABLE ON THE STACK C CALL TPSYNT (ID, IDSDIM, .FALSE., LERROR) IF (LERROR) GO TO 999 CALL MMPSHV (CBUFFR, ICBP1(1), ICBP2(1), 1, LEMPTY, LFOUND) IF (LFOUND) GO TO 999 CALL IOERRM (.FALSE., A '('' ******** TPINCL - VARIABLE NOT DEFINED'')') C 999 CONTINUE RETURN END SUBROUTINE TPINIT (IUE0, IUI0, IUL0, IUO0) C C----------------------------------------------------------------------- C C FAMILY C ------ C TEMPLATE PROCESSOR C C PURPOSE C ------- C TO INITIALIZE TEMPLATE PROCESSOR VATIABLES C C PARAMETERS C ---------- C IUE0 -I- UNIT NUMBER OF THE ERROR FILE C IUI0 -I- UNIT NUMBER OF THE INPUT FILE C IUL0 -I- UNIT NUMBER OF THE LISTING FILE C IUO0 -I- UNIT NUMBER OF THE OUTPUT FILE C C----------------------------------------------------------------------- C C GLOBAL CONSTANTS C CHARACTER*1 CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 COMMON / GLCOMC / CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 C C INPUT / OUTPUT CONTROL INTERFACE C CHARACTER*1 CBUFFR(2000) LOGICAL LBREAK, LFORT, LISTI, LISTO INTEGER ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOMC / CBUFFR COMMON / IOCOMI / ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOML / LBREAK, LFORT, LISTI, LISTO C C MEMORY MANAGER INTERFACE C CHARACTER*1 CSTORE(20000) INTEGER IHASH(601), ISTORE(6000) INTEGER ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS COMMON / MMCOMC / CSTORE COMMON / MMCOMH / IHASH COMMON / MMCOMS / ISTORE COMMON / MMCOMI / ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS C C MACRO PROCESSOR INTERFACE C CHARACTER*1 CDIV, CEOL, CEOR, CONC, CSUB, A CTOP LOGICAL LEMPTY, LSUB COMMON / MPCOMC / CDIV, CEOL, CEOR, CONC, CSUB, A CTOP COMMON / MPCOML / LEMPTY, LSUB C C TEMPLATE PROCESSOR INTERFACE C CHARACTER*1 CDIR, CSTAR INTEGER ICBP1(4), ICBP2(4) INTEGER ITOPDO, IARGS, INESTD, INESTF LOGICAL LCOL1, LDIRL, LEND, LINITM, L1TRIP COMMON / TPCOMC / CDIR, CSTAR COMMON / TPCOMI / ICBP1, ITOPDO, IARGS, ICBP2, INESTD, B INESTF COMMON / TPCOML / LCOL1, LDIRL, LEND, LINITM, L1TRIP INTEGER IUE0, IUI0, IUL0, IUO0 EXTERNAL MMINIT C IUNITE = IUE0 IUNITI = IUI0 IUNITL = IUL0 IUNITO = IUO0 C ILNMBR = 0 ILCTR = ILPP INESTD = 0 INESTF = 0 IPAGE = 0 ITOPDO = 0 LEMPTY = .TRUE. LEND = .FALSE. IF (.NOT. LINITM) CALL MMINIT LINITM = .TRUE. C RETURN END SUBROUTINE TPMMIN C C---------------------------------------------------------------------- C C FAMILY C ------ C TEMPLATE PROCESSOR C C PURPOSE C ------- C THIS ROUTINE INITIALIZES TEMPLATE PROCESSOR CONSTANTS. C C---------------------------------------------------------------------- C C GLOBAL CONSTANTS C CHARACTER*1 CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 COMMON / GLCOMC / CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 C C INPUT / OUTPUT CONTROL INTERFACE C CHARACTER*1 CBUFFR(2000) LOGICAL LBREAK, LFORT, LISTI, LISTO INTEGER ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOMC / CBUFFR COMMON / IOCOMI / ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOML / LBREAK, LFORT, LISTI, LISTO C C MEMORY MANAGER INTERFACE C CHARACTER*1 CSTORE(20000) INTEGER IHASH(601), ISTORE(6000) INTEGER ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS COMMON / MMCOMC / CSTORE COMMON / MMCOMH / IHASH COMMON / MMCOMS / ISTORE COMMON / MMCOMI / ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS C C MACRO PROCESSOR INTERFACE C CHARACTER*1 CDIV, CEOL, CEOR, CONC, CSUB, A CTOP LOGICAL LEMPTY, LSUB COMMON / MPCOMC / CDIV, CEOL, CEOR, CONC, CSUB, A CTOP COMMON / MPCOML / LEMPTY, LSUB C C TEMPLATE PROCESSOR INTERFACE C CHARACTER*1 CDIR, CSTAR INTEGER ICBP1(4), ICBP2(4) INTEGER ITOPDO, IARGS, INESTD, INESTF LOGICAL LCOL1, LDIRL, LEND, LINITM, L1TRIP COMMON / TPCOMC / CDIR, CSTAR COMMON / TPCOMI / ICBP1, ITOPDO, IARGS, ICBP2, INESTD, B INESTF COMMON / TPCOML / LCOL1, LDIRL, LEND, LINITM, L1TRIP C CHARACTER*1 CA0, CBLAN0, CC0, CI0, CLEFT0, A CMINU0, CPLUS0, CPOIN0, CQUOT0, CRIGH0, B CZ0, C00, C90, C CDIR0, CDIV0, CEOL0, CEOR0, CONC0, D CSTAR0, CSUB0 DATA CA0, CBLAN0, CC0, CI0, CLEFT0, A CMINU0, CPLUS0, CPOIN0, CQUOT0, CRIGH0, B CZ0, C00, C90 C / 'A', ' ', 'C', 'I', '(', D '-', '+', '.', '''', ')', E 'Z', '0', '9' / DATA CDIR0 / '*' / DATA CDIV0 / '/' / DATA CEOL0 / '-' / DATA CEOR0 / '/' / DATA CONC0 / '+' / DATA CSTAR0 / '*' / DATA CSUB0 / '$' / CA = CA0 CBLANK = CBLAN0 CC = CC0 CI = CI0 CLEFT = CLEFT0 CMINUS = CMINU0 CPLUS = CPLUS0 CPOINT = CPOIN0 CQUOTE = CQUOT0 CRIGHT = CRIGH0 CZ = CZ0 C0 = C00 C9 = C90 C CDIR = CDIR0 CDIV = CDIV0 CEOL = CEOL0 CEOR = CEOR0 CONC = CONC0 CSTAR = CSTAR0 CSUB = CSUB0 C ICBADD = 1 ICPLI = 72 ICPLO = 72 ILPP = 58 LBREAK = .FALSE. LCOL1 = .TRUE. LFORT = .FALSE. LINITM = .FALSE. LISTI = .FALSE. LISTO = .FALSE. LSUB = .TRUE. L1TRIP = .FALSE. C RETURN END SUBROUTINE TPOPT C C----------------------------------------------------------------------- C C FAMILY C ------ C TEMPLATE PROCESSOR C C PURPOSE C ------- C TO PROCESS OPTION DIRECTIVES C C----------------------------------------------------------------------- C C GLOBAL CONSTANTS C CHARACTER*1 CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 COMMON / GLCOMC / CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 C C INPUT / OUTPUT CONTROL INTERFACE C CHARACTER*1 CBUFFR(2000) LOGICAL LBREAK, LFORT, LISTI, LISTO INTEGER ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOMC / CBUFFR COMMON / IOCOMI / ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOML / LBREAK, LFORT, LISTI, LISTO C C MEMORY MANAGER INTERFACE C CHARACTER*1 CSTORE(20000) INTEGER IHASH(601), ISTORE(6000) INTEGER ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS COMMON / MMCOMC / CSTORE COMMON / MMCOMH / IHASH COMMON / MMCOMS / ISTORE COMMON / MMCOMI / ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS C C MACRO PROCESSOR INTERFACE C CHARACTER*1 CDIV, CEOL, CEOR, CONC, CSUB, A CTOP LOGICAL LEMPTY, LSUB COMMON / MPCOMC / CDIV, CEOL, CEOR, CONC, CSUB, A CTOP COMMON / MPCOML / LEMPTY, LSUB C C TEMPLATE PROCESSOR INTERFACE C CHARACTER*1 CDIR, CSTAR INTEGER ICBP1(4), ICBP2(4) INTEGER ITOPDO, IARGS, INESTD, INESTF LOGICAL LCOL1, LDIRL, LEND, LINITM, L1TRIP COMMON / TPCOMC / CDIR, CSTAR COMMON / TPCOMI / ICBP1, ITOPDO, IARGS, ICBP2, INESTD, B INESTF COMMON / TPCOML / LCOL1, LDIRL, LEND, LINITM, L1TRIP C C LOCAL VARIABLES AND PARAMETERS C CHARACTER*1 C(84), CVALUE INTEGER ID(6), IK(17) INTEGER IKYDIM, ICKDIM, IDSDIM, ICB, I, IVALUE LOGICAL LERROR, LVALUE EXTERNAL TPSYNT, UTRDKY, UTCVCI, UTCVCL, IOERRM SAVE IKYDIM, IK, ICKDIM, C, IDSDIM, ID DATA A IKYDIM, ICKDIM, B IK(1), C IK(2), D IK(3), E IK(4), F IK(5) G / 17, 84, H 4, I 4, J 4, K 4, L 4 / DATA B C(1), C(2), C(3), C(4), C C(5), C(6), C(7), C(8), D C(9), C(10), C(11), C(12), E C(13), C(14), C(15), C(16), F C(17), C(18), C(19), C(20) G / H 'C', 'D', 'I', 'R', I 'C', 'E', 'O', 'L', J 'C', 'E', 'O', 'R', K 'C', 'O', 'N', 'C', L 'C', 'S', 'U', 'B' / DATA A IK(6), B IK(7), C IK(8), D IK(9), E IK(10) F / 5, G 5, H 6, I 6, J 6 / DATA A C(21), C(22), C(23), C(24), C(25), B C(26), C(27), C(28), C(29), C(30), C C(31), C(32), C(33), C(34), C(35), C(36), D C(37), C(38), C(39), C(40), C(41), C(42), E C(43), C(44), C(45), C(46), C(47), C(48) F / 'I', 'C', 'P', 'L', 'I', G 'I', 'C', 'P', 'L', 'O', H 'I', 'U', 'N', 'I', 'T', 'I', I 'I', 'U', 'N', 'I', 'T', 'L', J 'I', 'U', 'N', 'I', 'T', 'O' / DATA A IK(11), B IK(12), C IK(13), D IK(14), E IK(15), F IK(16), G IK(17) H / 6, I 5, K 5, L 5, M 5, N 4, O 6 / DATA A C(49), C(50), C(51), C(52), C(53), C(54), B C(55), C(56), C(57), C(58), C(59), C C(60), C(61), C(62), C(63), C(64), D C(65), C(66), C(67), C(68), C(69), E C(70), C(71), C(72), C(73), C(74), F C(75), C(76), C(77), C(78), G C(79), C(80), C(81), C(82), C(83), C(84) H / 'L', 'B', 'R', 'E', 'A', 'K', I 'L', 'C', 'O', 'L', '1', K 'L', 'F', 'O', 'R', 'T', L 'L', 'I', 'S', 'T', 'I', M 'L', 'I', 'S', 'T', 'O', N 'L', 'S', 'U', 'B', O 'L', '1', 'T', 'R', 'I', 'P' / DATA A IDSDIM, ID(1), ID(2), ID(3), ID(4), ID(5), ID(6) B / 6, 1, 5, 4, 6, 2, 7 / C C CHECK SYNTAX C CALL TPSYNT (ID, IDSDIM, .FALSE., LERROR) IF (LERROR) GO TO 999 ICB = ICBP1(1) CALL UTRDKY (CBUFFR, ICBP1(1), ICBP2(1), IK, IKYDIM, A C, ICKDIM, I) IF (I .GT. IKYDIM) GO TO 220 IF (CBUFFR(ICB) .EQ. CC) GO TO 10 IF (CBUFFR(ICB) .EQ. CI) GO TO 20 GO TO 30 C 10 CONTINUE IF (ICBP1(2) .NE. ICBP2(2)) GO TO 230 ICB = ICBP1(2) CVALUE = CBUFFR(ICB) GO TO 40 C 20 CONTINUE CALL UTCVCI (CBUFFR, ICBP1(2), ICBP2(2), IVALUE, LERROR) IF (LERROR) GO TO 240 GO TO 40 C 30 CONTINUE CALL UTCVCL (CBUFFR, ICBP1(2), ICBP2(2), LVALUE, LERROR) IF (LERROR) GO TO 250 C 40 CONTINUE GO TO (50, 60, 70, 80, 90, 100, 110, 120, A 130, 140, 150, 160, 170, 180, 190, 200, 210), I C C PROCESS -CDIR- C 50 CONTINUE CDIR = CVALUE GO TO 999 C C PROCESS -CEOL- C 60 CONTINUE CEOL = CVALUE GO TO 999 C C PROCESS -CEOR- C 70 CONTINUE CEOR = CVALUE GO TO 999 C C PROCESS -CONC- C 80 CONTINUE CONC = CVALUE GO TO 999 C C PROCESS -CSUB- C 90 CONTINUE CSUB = CVALUE GO TO 999 C C PROCESS -ICPLI- C 100 CONTINUE ICPLI = IVALUE GO TO 999 C C PROCESS -ICPLO- C 110 CONTINUE ICPLO = IVALUE GO TO 999 C C PROCESS -IUNITI- C 120 CONTINUE IUNITI = IVALUE GO TO 999 C C PROCESS -IUNITL- C 130 CONTINUE IUNITL = IVALUE GO TO 999 C C PROCESS -IUNITO- C 140 CONTINUE IUNITO = IVALUE GO TO 999 C C PROCESS -LBREAK- C 150 CONTINUE LBREAK = LVALUE ICBADD = 1 IF (LFORT) ICBADD = -5 IF (LFORT .AND. LBREAK) ICBADD = -9 GO TO 999 C C PROCESS -LCOL1- C 160 CONTINUE LCOL1 = LVALUE GO TO 999 C C PROCESS -LFORT- C 170 CONTINUE LFORT = LVALUE ICBADD = 1 IF (LFORT) ICBADD = -5 IF (LFORT .AND. LBREAK) ICBADD = -9 GO TO 999 C C PROCESS -LISTI- C 180 CONTINUE LISTI = LVALUE GO TO 999 C C PROCESS -LISTO- C 190 CONTINUE LISTO = LVALUE GO TO 999 C C PROCESS -LSUB- C 200 CONTINUE LSUB = LVALUE GO TO 999 C C PROCESS -L1TRIP- C 210 CONTINUE L1TRIP = LVALUE GO TO 999 C C ERROR - UNKNOWN OPTION NAME C 220 CONTINUE CALL IOERRM (.FALSE., A '('' ******** TPOPT - ILLEGAL OR MISSPELLED OPTION'')') GO TO 999 C C ERROR - SINGLE CHARACTER EXPECTED C 230 CONTINUE CALL IOERRM (.FALSE., A '('' ******** TPOPT - OPTION REQUIRES SINGLE CHARACTER'')') GO TO 999 C C ERROR - INTEGER EXPECTED C 240 CONTINUE CALL IOERRM (.FALSE., A '('' ******** TPOPT - OPTION REQUIRES AN INTEGER'')') GO TO 999 C C ERROR - LOGICAL VALUE EXPECTED C 250 CONTINUE CALL IOERRM (.FALSE., A '('' ******** TPOPT - OPTION REQUIRES A LOGICAL VALUE'')') C 999 CONTINUE RETURN END SUBROUTINE TPRDBL (IK, IKYDIM, C, ICKDIM, ID, IDSDIM, A LSCAN, LSKIP, LSUBL, LERROR) C C----------------------------------------------------------------------- C C FAMILY C ------ C TEMPLATE PROCESSOR C C PURPOSE C ------- C TO READ A BLOCK OF STATEMENTS DELIMITED BY C DIRECTIVES OF THE FORM -NAME- AND -ENDNAME-. C THESE DIRECTIVES MAY BE NESTED. C C PARAMETERS C ---------- C IK -I- INDEXES OF DIRECTIVES IN ARRAY C C IKYDIM -I- DIMENSION OF IK (SHOULD BE 3) C C -I- CONTAINS DIRECTIVE NAMES. DIRECTIVE 1 IS -NAME-, C 2 IS -ENDNAME, AND 3 IS -END-. C ICKDIM -I- DIMENSION OF C (TOTAL NUMBER OF CHARACTERS) C ID -I- CONTAINS THE SYNTAX PATTERN FOR DIRECTIVE -NAME- C IDSDIM -I- DIMENSION OF ID C LSCAN -I- IF TRUE, EXPRESSIONS WILL BE SCANNED FOR ERRORS C BUT NOT EVALUATED C LSKIP -I- IF TRUE, INPUT LINES ARE SKIPPED, NOT SAVED C LSUBL -I- IF TRUE, MACRO SUBSTITUTIONS WILL BE PERFORMED C WHEN ENCOUNTERED WITHIN THE BLOCK C LERROR -O- TRUE IF AN ERROR WAS ENCOUNTERED C C----------------------------------------------------------------------- C C GLOBAL CONSTANTS C CHARACTER*1 CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 COMMON / GLCOMC / CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 C C INPUT / OUTPUT CONTROL INTERFACE C CHARACTER*1 CBUFFR(2000) LOGICAL LBREAK, LFORT, LISTI, LISTO INTEGER ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOMC / CBUFFR COMMON / IOCOMI / ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOML / LBREAK, LFORT, LISTI, LISTO C C MEMORY MANAGER INTERFACE C CHARACTER*1 CSTORE(20000) INTEGER IHASH(601), ISTORE(6000) INTEGER ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS COMMON / MMCOMC / CSTORE COMMON / MMCOMH / IHASH COMMON / MMCOMS / ISTORE COMMON / MMCOMI / ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS C C MACRO PROCESSOR INTERFACE C CHARACTER*1 CDIV, CEOL, CEOR, CONC, CSUB, A CTOP LOGICAL LEMPTY, LSUB COMMON / MPCOMC / CDIV, CEOL, CEOR, CONC, CSUB, A CTOP COMMON / MPCOML / LEMPTY, LSUB C C TEMPLATE PROCESSOR INTERFACE C CHARACTER*1 CDIR, CSTAR INTEGER ICBP1(4), ICBP2(4) INTEGER ITOPDO, IARGS, INESTD, INESTF LOGICAL LCOL1, LDIRL, LEND, LINITM, L1TRIP COMMON / TPCOMC / CDIR, CSTAR COMMON / TPCOMI / ICBP1, ITOPDO, IARGS, ICBP2, INESTD, B INESTF COMMON / TPCOML / LCOL1, LDIRL, LEND, LINITM, L1TRIP C C LOCAL VARIABLES AND PARAMETERS C INTEGER IKYDIM, ICKDIM, IDSDIM CHARACTER*(*) C(ICKDIM) INTEGER ID(IDSDIM), IK(IKYDIM) LOGICAL LERROR, LSCAN, LSKIP, LSUBL INTEGER I, INEST EXTERNAL MPLINE, TPCHKD, UTRDKY, TPSYNT C INEST = 1 C 10 CONTINUE IF (LSKIP) ICBEOL = 0 CALL MPLINE (LSUBL) CALL TPCHKD IF (.NOT. LDIRL) GO TO 10 CALL UTRDKY (CBUFFR, ICB1, ICB2, IK, IKYDIM, C, ICKDIM, I) GO TO (20, 30, 40, 10), I C C A -NAME- DIRECTIVE HAS BEEN ENCOUNTERED C 20 CONTINUE IF (LSCAN) CALL TPSYNT (ID, IDSDIM, LSCAN, LERROR) IF (LSCAN .AND. (IARGS .GE. 2)) GO TO 10 INEST = INEST + 1 GO TO 10 C C AN -ENDNAME- DIRECTIVE HAS BEEN ENCOUNTERED C 30 CONTINUE INEST = INEST - 1 IF (INEST .GT. 0) GO TO 10 GO TO 999 C C AN -END- DIRECTIVE HAS POSSIBLY BEEN ENCOUNTERED C 40 CONTINUE LEND = ICB1 .GT. ICB2 IF (.NOT. LEND) GO TO 10 C 999 CONTINUE RETURN END SUBROUTINE TPRSET C C----------------------------------------------------------------------- C C FAMILY C ------ C TEMPLATE PROCESSOR C C PURPOSE C ------- C TO PROCESS RESET DIRECTIVES C C----------------------------------------------------------------------- C C GLOBAL CONSTANTS C CHARACTER*1 CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 COMMON / GLCOMC / CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 C C INPUT / OUTPUT CONTROL INTERFACE C CHARACTER*1 CBUFFR(2000) LOGICAL LBREAK, LFORT, LISTI, LISTO INTEGER ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOMC / CBUFFR COMMON / IOCOMI / ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOML / LBREAK, LFORT, LISTI, LISTO C C MEMORY MANAGER INTERFACE C CHARACTER*1 CSTORE(20000) INTEGER IHASH(601), ISTORE(6000) INTEGER ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS COMMON / MMCOMC / CSTORE COMMON / MMCOMH / IHASH COMMON / MMCOMS / ISTORE COMMON / MMCOMI / ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS C C MACRO PROCESSOR INTERFACE C CHARACTER*1 CDIV, CEOL, CEOR, CONC, CSUB, A CTOP LOGICAL LEMPTY, LSUB COMMON / MPCOMC / CDIV, CEOL, CEOR, CONC, CSUB, A CTOP COMMON / MPCOML / LEMPTY, LSUB C C TEMPLATE PROCESSOR INTERFACE C CHARACTER*1 CDIR, CSTAR INTEGER ICBP1(4), ICBP2(4) INTEGER ITOPDO, IARGS, INESTD, INESTF LOGICAL LCOL1, LDIRL, LEND, LINITM, L1TRIP COMMON / TPCOMC / CDIR, CSTAR COMMON / TPCOMI / ICBP1, ITOPDO, IARGS, ICBP2, INESTD, B INESTF COMMON / TPCOML / LCOL1, LDIRL, LEND, LINITM, L1TRIP C C LOCAL VARIABLES AND PARAMETERS C INTEGER IDSDIM, ICP1,ICP2 INTEGER ID(4) LOGICAL LERROR, LFOUND EXTERNAL TPSYNT, UTBLDN, MMPUTP SAVE IDSDIM, ID DATA IDSDIM, ID(1), ID(2), ID(3), ID(4) A / 4, 1, 5, 2, 7 / C C CHECK SYNTAX C CALL TPSYNT (ID, IDSDIM, .FALSE., LERROR) IF (LERROR) GO TO 999 ICP1 = ICBEND + 1 CALL UTBLDN (CDIV, CBUFFR, ICBP1(1), ICBP2(1), 1, A CBUFFR, ICP1, ICP2, ICBDIM, LERROR) ICBEND = ICP2 CALL MMPUTP (CBUFFR, ICBP1(1), ICBP2(1), A CBUFFR, ICP1, ICP2, LFOUND) C 999 CONTINUE RETURN END SUBROUTINE TPSET C C----------------------------------------------------------------------- C C FAMILY C ------ C TEMPLATE PROCESSOR C C PURPOSE C ------- C TO PROCESS SET DIRECTIVES C C----------------------------------------------------------------------- C C GLOBAL CONSTANTS C CHARACTER*1 CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 COMMON / GLCOMC / CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 C C INPUT / OUTPUT CONTROL INTERFACE C CHARACTER*1 CBUFFR(2000) LOGICAL LBREAK, LFORT, LISTI, LISTO INTEGER ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOMC / CBUFFR COMMON / IOCOMI / ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOML / LBREAK, LFORT, LISTI, LISTO C C MEMORY MANAGER INTERFACE C CHARACTER*1 CSTORE(20000) INTEGER IHASH(601), ISTORE(6000) INTEGER ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS COMMON / MMCOMC / CSTORE COMMON / MMCOMH / IHASH COMMON / MMCOMS / ISTORE COMMON / MMCOMI / ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS C C MACRO PROCESSOR INTERFACE C CHARACTER*1 CDIV, CEOL, CEOR, CONC, CSUB, A CTOP LOGICAL LEMPTY, LSUB COMMON / MPCOMC / CDIV, CEOL, CEOR, CONC, CSUB, A CTOP COMMON / MPCOML / LEMPTY, LSUB C C TEMPLATE PROCESSOR INTERFACE C CHARACTER*1 CDIR, CSTAR INTEGER ICBP1(4), ICBP2(4) INTEGER ITOPDO, IARGS, INESTD, INESTF LOGICAL LCOL1, LDIRL, LEND, LINITM, L1TRIP COMMON / TPCOMC / CDIR, CSTAR COMMON / TPCOMI / ICBP1, ITOPDO, IARGS, ICBP2, INESTD, B INESTF COMMON / TPCOML / LCOL1, LDIRL, LEND, LINITM, L1TRIP C C LOCAL VARIABLES AND PARAMETERS C INTEGER IKYDIM, ICKDIM, IDSDIM CHARACTER*1 C(12) INTEGER ID(8), IK(3) LOGICAL LERROR EXTERNAL TPSYNT, TPSETM, TPRDBL, MMPUTV, IOERRM SAVE IKYDIM, IK, ICKDIM, C, IDSDIM, ID DATA A IKYDIM, ICKDIM, B IK(1), C IK(2), D IK(3) E / 3, 12, F 3, G 6, H 3 / DATA B C(1), C(2), C(3), C C(4), C(5), C(6), C(7), C(8), C(9), D C(10), C(11), C(12) E / F 'S', 'E', 'T', G 'E', 'N', 'D', 'S', 'E', 'T', H 'E', 'N', 'D' / DATA A IDSDIM, B ID(1), ID(2), ID(3), ID(4), ID(5), ID(6), ID(7), ID(8) C / 8, D -1, 8, 5, -4, 7, 6, 2, 7 / C C CHECK SYNTAX C CALL TPSYNT (ID, IDSDIM, .FALSE., LERROR) IF (LERROR) GO TO 999 IF (IARGS .EQ. 2) GO TO 20 IF (IARGS .EQ. 1) GO TO 10 CALL TPSETM IF (LEND) GO TO 30 GO TO 999 C C PROCESS A MULTI-LINE SET STATEMENT C 10 CONTINUE ICBP1(2) = ICBEOL + 1 CALL TPRDBL (IK, IKYDIM, C, ICKDIM, ID, IDSDIM, A .TRUE., .FALSE., .TRUE., LERROR) IF (LEND) GO TO 30 IF (LERROR) GO TO 999 ICBP2(2) = ICB0 - 1 C C SET THE VALUE C 20 CONTINUE CALL MMPUTV (CBUFFR, ICBP1(1), ICBP2(1), A CBUFFR, ICBP1(2), ICBP2(2)) GO TO 999 C 30 CONTINUE CALL IOERRM (.FALSE., A '('' ******** TPSET - SET HAS NO MATCHING ENDSET'')') C 999 CONTINUE RETURN END SUBROUTINE TPSETM C C----------------------------------------------------------------------- C C FAMILY C ------ C TEMPLATE PROCESSOR C C PURPOSE C ------- C TO PROCESS MULTILINE SET DIRECTIVES C C----------------------------------------------------------------------- C C GLOBAL CONSTANTS C CHARACTER*1 CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 COMMON / GLCOMC / CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 C C INPUT / OUTPUT CONTROL INTERFACE C CHARACTER*1 CBUFFR(2000) LOGICAL LBREAK, LFORT, LISTI, LISTO INTEGER ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOMC / CBUFFR COMMON / IOCOMI / ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOML / LBREAK, LFORT, LISTI, LISTO C C MEMORY MANAGER INTERFACE C CHARACTER*1 CSTORE(20000) INTEGER IHASH(601), ISTORE(6000) INTEGER ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS COMMON / MMCOMC / CSTORE COMMON / MMCOMH / IHASH COMMON / MMCOMS / ISTORE COMMON / MMCOMI / ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS C C MACRO PROCESSOR INTERFACE C CHARACTER*1 CDIV, CEOL, CEOR, CONC, CSUB, A CTOP LOGICAL LEMPTY, LSUB COMMON / MPCOMC / CDIV, CEOL, CEOR, CONC, CSUB, A CTOP COMMON / MPCOML / LEMPTY, LSUB C C TEMPLATE PROCESSOR INTERFACE C CHARACTER*1 CDIR, CSTAR INTEGER ICBP1(4), ICBP2(4) INTEGER ITOPDO, IARGS, INESTD, INESTF LOGICAL LCOL1, LDIRL, LEND, LINITM, L1TRIP COMMON / TPCOMC / CDIR, CSTAR COMMON / TPCOMI / ICBP1, ITOPDO, IARGS, ICBP2, INESTD, B INESTF COMMON / TPCOML / LCOL1, LDIRL, LEND, LINITM, L1TRIP C C LOCAL VARIABLES AND PARAMETERS C INTEGER IKYDIM,ICKDIM, IDSDIM, I CHARACTER*1 C(9) INTEGER ID(5), IK(2) LOGICAL LERROR, LSKIP EXTERNAL MPLINE, TPCHKD, UTRDKY, TPSYNT, MMPUTV SAVE IKYDIM, IK, ICKDIM, C, IDSDIM, ID DATA A IKYDIM, ICKDIM, B IK(1), C IK(2) D / 2, 9, E 6, F 3 / DATA B C(1), C(2), C(3), C(4), C(5), C(6), C C(7), C(8), C(9) D / E 'E', 'N', 'D', 'S', 'E', 'T', F 'E', 'N', 'D' / DATA IDSDIM, ID(1), ID(2), ID(3), ID(4), ID(5) A / 5, 5, 4, -6, 5, 7 / C LSKIP = .TRUE. C 10 CONTINUE IF (LSKIP) ICBEOL = 0 CALL MPLINE (.TRUE.) CALL TPCHKD IF (.NOT. LDIRL) GO TO 20 IF (ICB1 .GT. ICB2) GO TO 30 CALL UTRDKY (CBUFFR, ICB1, ICB2, IK, IKYDIM, C, ICKDIM, I) IF (I .EQ. 1) GO TO 50 IF (I .EQ. 2) GO TO 60 IF (I .EQ. 3) GO TO 10 C C A TEXT LINE HAS BEEN ENCOUNTERED C 20 CONTINUE IF (.NOT. LSKIP) GO TO 10 CALL TPSYNT (ID, IDSDIM, .FALSE., LERROR) IF (LERROR) GO TO 10 IF (IARGS .EQ. 2) GO TO 40 ICBEOL = ICBP2(1) LSKIP = .FALSE. GO TO 10 C C A DIRECTIVE PREFIX CHARACTER HAS BEEN C ENCOUNTERED ON A LINE BY ITSELF C 30 CONTINUE IF (LSKIP) GO TO 10 ICBP1(2) = ICBP2(1) + 1 ICBP2(2) = ICB0 - 1 LSKIP = .TRUE. C C SAVE THE VALUE C 40 CONTINUE CALL MMPUTV (CBUFFR, ICBP1(1), ICBP2(1), A CBUFFR, ICBP1(2), ICBP2(2)) GO TO 10 C C AN ENDSET DIRECTIVE HAS BEEN ENCOUNTERED C 50 CONTINUE IF (.NOT. LSKIP) GO TO 10 GO TO 999 C C AN -END- DIRECTIVE HAS POSSIBLY BEEN ENCOUNTERED C 60 CONTINUE LEND = ICB1 .GT. ICB2 IF (.NOT. LEND) GO TO 10 C 999 CONTINUE RETURN END SUBROUTINE TPSYNT (IDSYNT, IDSDIM, LSCAN, LERROR) C C----------------------------------------------------------------------- C C FAMILY C ------ C TEMPLATE PROCESSOR C C PURPOSE C ------- C TO CHECK A DIRECTIVE LINE FOR CORRECT SYNTAX C C PARAMETERS C ---------- C IDSYNT -I- CONTAINS THE DIRECTIVE SYNTAX PATTERN. C THE VECTOR IDSYNT DESCRIBES THE TOKENS THAT C ARE ALLOWED. POSSIBLE VALUES OF IDSYNT(I): C ABS(IDSYNT(I)) TOKEN C -------------- ----- C 1 ( C 2 ) C 3 , C 4 = C 5 ID C 6 EXP C 7 EOL C 8 EOL C WHEN IDSYNT(I) < 0, TWO THINGS CAN HAPPEN: C - IF ABS(IDSYNT(I)) 'MATCHES' CURRENT TOKEN, C SKIP TO IDSYNT(I+2) FOR NEXT MATCH. C - IF NOT, SKIP TO IDSYNT(IDSYNT(I+1)) C FOR NEXT MATCH. C C IDSDIM -I- DIMENSION OF IDSYNT C LSCAN -I- IF TRUE, DIRECTIVES ARE TO BE SCANNED C BUT NOT EXECUTED C LERROR -O- TRUE IF THE DIRECTIVE HAS A SYNTAX ERROR C C----------------------------------------------------------------------- C C GLOBAL CONSTANTS C CHARACTER*1 CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 COMMON / GLCOMC / CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 C C INPUT / OUTPUT CONTROL INTERFACE C CHARACTER*1 CBUFFR(2000) LOGICAL LBREAK, LFORT, LISTI, LISTO INTEGER ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOMC / CBUFFR COMMON / IOCOMI / ICBADD, ICBEND, ICBEOL, ICBSUB, ICB0, A ICB1, ICB2, ICB3, ICBDIM, ICPLI, B ICPLO, ILCTR, ILNMBR, ILPP, IPAGE, A IUNITE, IUNITI, IUNITL, IUNITO COMMON / IOCOML / LBREAK, LFORT, LISTI, LISTO C C MEMORY MANAGER INTERFACE C CHARACTER*1 CSTORE(20000) INTEGER IHASH(601), ISTORE(6000) INTEGER ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS COMMON / MMCOMC / CSTORE COMMON / MMCOMH / IHASH COMMON / MMCOMS / ISTORE COMMON / MMCOMI / ICSDIM, ICSP1, ICSP2, IHADIM, A ISFREE, ISTDIM, IS2HDC, IS2HDS C C MACRO PROCESSOR INTERFACE C CHARACTER*1 CDIV, CEOL, CEOR, CONC, CSUB, A CTOP LOGICAL LEMPTY, LSUB COMMON / MPCOMC / CDIV, CEOL, CEOR, CONC, CSUB, A CTOP COMMON / MPCOML / LEMPTY, LSUB C C TEMPLATE PROCESSOR INTERFACE C CHARACTER*1 CDIR, CSTAR INTEGER ICBP1(4), ICBP2(4) INTEGER ITOPDO, IARGS, INESTD, INESTF LOGICAL LCOL1, LDIRL, LEND, LINITM, L1TRIP COMMON / TPCOMC / CDIR, CSTAR COMMON / TPCOMI / ICBP1, ITOPDO, IARGS, ICBP2, INESTD, B INESTF COMMON / TPCOML / LCOL1, LDIRL, LEND, LINITM, L1TRIP C C LOCAL VARIABLES AND PARAMETERS C INTEGER IDSDIM CHARACTER*1 C(4) INTEGER IDSYNT(IDSDIM) LOGICAL L, LEOL, LERROR, LSCAN INTEGER I, ICV1, IJUMP, ICV2 EXTERNAL UTRDBL, UTRDNA, TPEXPR, IOERRM SAVE C DATA C(1), C(2), C(3), C(4) A / '(', ')', ',', '=' / C I = 1 IARGS = 0 LERROR = .FALSE. C C DETERMINE WHICH TOKEN TO CHECK FOR C 10 CONTINUE ICV1 = ICB1 CALL UTRDBL (CBUFFR, ICB1, ICB2, LEOL) IJUMP = IABS(IDSYNT(I)) GO TO (20, 20, 20, 20, 30, 40, 50, 50), IJUMP C C CHECK FOR DELIMITERS AND SEPARATERS C 20 CONTINUE IF (LEOL) GO TO 80 IF (C(IJUMP) .NE. CBUFFR(ICB1)) GO TO 80 ICB1 = ICB1 + 1 GO TO 70 C C CHECK FOR A NAME C 30 CONTINUE IF (LEOL) GO TO 80 CALL UTRDNA (CBUFFR, ICB1, ICB2, ICV1, ICV2, L) IF (L) GO TO 80 GO TO 60 C C CHECK FOR AN EXPRESSION C 40 CONTINUE IF (LEOL) GO TO 80 CALL TPEXPR (ICV1, ICV2, LSCAN, L) IF (L) GO TO 80 GO TO 60 C C CHECK FOR END OF LINE C 50 CONTINUE IF (LEOL) GO TO 999 IF (IJUMP .NE. 8) GO TO 80 ICV2 = ICBEOL C 60 CONTINUE IARGS = IARGS + 1 IF (LSCAN) GO TO 70 ICBP1(IARGS) = ICV1 ICBP2(IARGS) = ICV2 C 70 CONTINUE IF (IDSYNT(I) .LT. 0) I = I + 1 I = I + 1 IF (I .LE. IDSDIM) GO TO 10 GO TO 999 C C IF THERE IS AN ALTERNATE SYNTAX FOR THIS STATEMENT C THEN TRY IT, OTHERWISE PRINT AN ERROR MESSAGE C 80 CONTINUE IF (IDSYNT(I).GT. 0) GO TO 90 I = IDSYNT(I+1) IF (I .LE. IDSDIM) GO TO 10 C C ERROR EXITS C 90 CONTINUE LERROR = .TRUE. GO TO (100, 110, 120, 130, 140, 150, 160, 160), IJUMP C 100 CONTINUE CALL IOERRM (.FALSE., A '('' ******** TPSYNT - LEFT PARENTHESIS EXPECTED'')') GO TO 999 C 110 CONTINUE CALL IOERRM (.FALSE., A '('' ******** TPSYNT - RIGHT PARENTHESIS EXPECTED'')') GO TO 999 C 120 CONTINUE CALL IOERRM (.FALSE., A '('' ******** TPSYNT - COMMA EXPECTED'')') GO TO 999 C 130 CONTINUE CALL IOERRM (.FALSE., A '('' ******** TPSYNT - EQUALS SIGN EXPECTED'')') GO TO 999 C 140 CONTINUE CALL IOERRM (.FALSE., A '('' ******** TPSYNT - VARIABLE EXPECTED'')') GO TO 999 C 150 CONTINUE CALL IOERRM (.FALSE., A '('' ******** TPSYNT - MISSING OR UNRECOGNIZED EXPRESSION'')') GO TO 999 C 160 CONTINUE CALL IOERRM (.FALSE., A '('' ******** TPSYNT - ILLEGAL CHARACTERS AT END OF LINE'')') C 999 CONTINUE RETURN END SUBROUTINE UTBLDN (CPREFX, CROOT, ICR1, ICR2, ISUFFX, A CNAME, ICN1, ICN2, ICNDIM, LERROR) C C----------------------------------------------------------------------- C C FAMILY C ------ C UTILITY C C PURPOSE C ------- C TO BUILD A NAME GIVEN A PREFIX, ROOT, AND SUFFIX C C PARAMETERS C ---------- C CPREFX -I- A ONE CHARACTER PREFIX C CROOT -I- ROOT OF THE NAME C ICR1 -I- INDEX OF THE FIRST CHARACTER IN THE ROOT C ICR2 -I- INDEX OF THE LAST CHARACTER IN THE ROOT C ISUFFX -I- INTEGER SUFFIX C CNAME -O- THE NAME C ICN1 -I- INDEX OF THE FIRST CHARACTER IN THE NAME C ICN2 -O- INDEX OF THE LAST CHARACTER IN THE NAME C ICNDIM -I- DIMENSION OF CNAME C LERROR -O- TRUE IF AN ERROR OCCURED C C----------------------------------------------------------------------- C C GLOBAL CONSTANTS C CHARACTER*1 CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 COMMON / GLCOMC / CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 C C LOCAL VARIABLES AND PARAMETERS C INTEGER ICR1, ICR2, ISUFFX, ICN1, ICN2, ICNDIM CHARACTER*(*) CNAME(ICNDIM), CPREFX, CROOT(ICR2) LOGICAL LERROR INTEGER I EXTERNAL UTCVIC C LERROR = ICN1 + ICR2 - ICR1 + 1 .GT. ICNDIM IF (LERROR) GO TO 999 ICN2 = ICN1 CNAME(ICN2) = CPREFX IF (ICR1 .GT. ICR2) GO TO 20 DO 10 I=ICR1,ICR2 ICN2 = ICN2 + 1 CNAME(ICN2) = CROOT(I) 10 CONTINUE 20 CONTINUE IF (ISUFFX .LT. 0) GO TO 999 I = ICN2 + 1 CALL UTCVIC (CNAME, I, ICN2, ICNDIM, ISUFFX, LERROR) C 999 CONTINUE RETURN END SUBROUTINE UTCVCI (CLINE, ICL1, ICL2, IVALUE, LERROR) C C----------------------------------------------------------------------- C C FAMILY C ------ C UTILITY C C PURPOSE C ------- C TO CONVERT A CHARACTER STRING INTO AN INTEGER C C PARAMETERS C ---------- C CLINE -I- STRING TO BE CONVERTED C ICL1 -I- INDEX OF THE FIRST CHARACTER IN THE STRING C ICL2 -I- INDEX OF THE LAST CHARACTER IN THE STRING C IVALUE -O- INTEGER RESULT C LERROR -O- TRUE IF AN ERROR OCCURED C C----------------------------------------------------------------------- C C GLOBAL CONSTANTS C CHARACTER*1 CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 COMMON / GLCOMC / CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 C C LOCAL VARIABLES AND PARAMETERS C INTEGER ICL1, ICL2, IVALUE CHARACTER*(*) CLINE(ICL2) CHARACTER*1 C(10), CLINEI LOGICAL LERROR, LMINUS INTEGER I, I1, IC EXTERNAL UTRDBL SAVE C DATA C(1), C(2), C(3), C(4), C(5), A C(6), C(7), C(8), C(9), C(10) B / '0', '1', '2', '3', '4', C '5', '6', '7', '8', '9' / C IVALUE = 0 I = ICL1 CALL UTRDBL (CLINE, I, ICL2, LERROR) IF (LERROR) GO TO 999 LMINUS = CLINE(I) .EQ. CMINUS IF ((.NOT. LMINUS) .AND. (CLINE(I) .NE. CPLUS)) GO TO 10 I = I + 1 CALL UTRDBL (CLINE, I, ICL2, LERROR) IF (LERROR) GO TO 999 C 10 CONTINUE I1 = I DO 40 I=I1,ICL2 CLINEI = CLINE(I) DO 20 IC=1,10 IF (CLINEI .EQ. C(IC)) GO TO 30 20 CONTINUE IF (I .GT. I1) GO TO 50 GO TO 999 30 CONTINUE IVALUE = IVALUE*10 + IC - 1 40 CONTINUE C 50 CONTINUE LERROR = .FALSE. IF (LMINUS) IVALUE = -IVALUE C 999 CONTINUE RETURN END SUBROUTINE UTCVCL (CLINE, ICL1, ICL2, LVALUE, LERROR) C C----------------------------------------------------------------------- C C FAMILY C ------ C UTILITY C C PURPOSE C ------- C TO CONVERT A CHARACTER STRING TO A LOGICAL VALUE C C PARAMETERS C ---------- C CLINE -I- STRING TO BE CONVERTED C ICL1 -I- INDEX OF THE FIRST CHARACTER IN THE STRING C ICL2 -I- INDEX OF THE LAST CHARACTER IN THE STRING C LVALUE -O- THE LOGICAL RESULT C LERROR -I- TRUE IF AN ERROR OCCURED C C----------------------------------------------------------------------- C C GLOBAL CONSTANTS C CHARACTER*1 CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 COMMON / GLCOMC / CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 C C LOCAL VARIABLES AND PARAMETERS C INTEGER ICL1, ICL2 CHARACTER*(*) CLINE(ICL2) CHARACTER*1 C(13) INTEGER IK(2) LOGICAL LERROR, LV(3), LVALUE INTEGER IKYDIM, ICKDIM, I EXTERNAL UTRDKY SAVE IKYDIM, IK, ICKDIM, C, LV DATA A IKYDIM, ICKDIM, B IK(1), C IK(2) D / 6, 13, E 6, F 7 / DATA B C(1), C(2), C(3), C(4), C(5), C(6), C C(7), C(8), C(9), C(10), C(11), C(12), C(13) D / E '.', 'T', 'R', 'U', 'E', '.', F '.', 'F', 'A', 'L', 'S', 'E', '.' / DATA A LV(1), LV(2), LV(3) B / .TRUE., .FALSE., .TRUE. / C LERROR = .TRUE. IF (ICL1 .GT. ICL2) GO TO 999 DO 10 I=ICL1,ICL2 IF (CLINE(I) .NE. CBLANK) GO TO 20 10 CONTINUE GO TO 999 C 20 CONTINUE CALL UTRDKY (CLINE, ICL1, ICL2, IK, IKYDIM, C, ICKDIM, I) LERROR = I .GT. IKYDIM LVALUE = LV(I) C 999 CONTINUE RETURN END SUBROUTINE UTCVIC (CLINE, ICL1, ICL2, ICLDIM, IVALUE, LERROR) C C----------------------------------------------------------------------- C C FAMILY C ------ C UTILITY C C PURPOSE C ------- C TO CONVERT AN INTEGER INTO A CHARACTER STRING C C PARAMETERS C ---------- C CLINE -O- STRING RESULT C ICL1 -I- INDEX OF THE FIRST CHARACTER IN THE STRING C ICL2 -O- INDEX OF THE LAST CHARACTER IN THE STRING C ICLDIM -I- DIMENSION OF CLINE C IVALUE -I- INTEGER TO BE CONVERTED C LERROR -O- TRUE IF AN ERROR OCCURED C C----------------------------------------------------------------------- C C GLOBAL CONSTANTS C CHARACTER*1 CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 COMMON / GLCOMC / CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 C C LOCAL VARIABLES AND PARAMETERS C INTEGER ICL1, ICL2, ICLDIM, IVALUE CHARACTER*(*) CLINE(ICLDIM) CHARACTER*1 C(10), CTEMP LOGICAL LERROR INTEGER I1, I2, ICL2MD SAVE C DATA C(1), C(2), C(3), C(4), C(5), A C(6), C(7), C(8), C(9), C(10) B / '0', '1', '2', '3', '4', C '5', '6', '7', '8', '9' / C I1 = IABS(IVALUE) LERROR = .TRUE. ICL2 = ICL1 - 1 C C CONVERT AND THEN REMOVE THE LEAST SIGNIFICANT DIGITS FIRST C 10 CONTINUE I2 = I1 I1 = I1 / 10 I2 = I2 - I1*10 ICL2 = ICL2 + 1 IF (ICL2 .GT. ICLDIM) GO TO 999 CLINE(ICL2) = C(I2+1) IF (I1 .GT. 0) GO TO 10 C C IF NECESSARY, ADD THE MINUS SIGN C IF (IVALUE .GE. 0) GO TO 20 ICL2 = ICL2 + 1 IF (ICL2 .GT. ICLDIM) GO TO 999 CLINE(ICL2) = CMINUS C C REVERSE THE STRING TO PUT THE DIGITS IN THE PROPER ORDER C 20 CONTINUE LERROR = .FALSE. IF (ICL1 .GE. ICL2) GO TO 999 ICL2MD = (ICL1 + ICL2 - 1) / 2 I2 = ICL2 DO 30 I1=ICL1,ICL2MD CTEMP = CLINE(I1) CLINE(I1) = CLINE(I2) CLINE(I2) = CTEMP I2 = I2 - 1 30 CONTINUE C 999 CONTINUE RETURN END SUBROUTINE UTCVLC (CLINE, ICL1, ICL2, ICLDIM, LVALUE, LERROR) C C----------------------------------------------------------------------- C C FAMILY C ------ C UTILITY C C PURPOSE C ------- C TO CONVERT A LOGICAL VALUE TO A CHARACTER C C PARAMETERS C ---------- C CLINE -O- STRING RESULT C ICL1 -I- INDEX OF THE FIRST CHARACTER IN THE STRING C ICL2 -O- INDEX OF THE LAST CHARACTER IN THE STRING C ICLDIM -I- DIMENSION OF CLINE C LVALUE -I- LOGICAL VALUE TO BE CONVERTED C LERROR -O- TRUE IF AN ERROR OCCURED C C----------------------------------------------------------------------- C C GLOBAL CONSTANTS C CHARACTER*1 CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 COMMON / GLCOMC / CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 C C LOCAL VARIABLES AND PARAMETERS C INTEGER ICL1, ICL2, ICLDIM CHARACTER*(*) CLINE(ICLDIM) CHARACTER*1 CF(7), CT(6) LOGICAL LERROR, LVALUE INTEGER ICFDIM, ICTDIM, I SAVE ICFDIM, CF, ICTDIM, CT DATA A ICFDIM, B ICTDIM C / 7, D 6 / DATA A CF(1), CF(2), CF(3), CF(4), CF(5), CF(6), CF(7), B CT(1), CT(2), CT(3), CT(4), CT(5), CT(6) C / '.', 'F', 'A', 'L', 'S', 'E', '.', D '.', 'T', 'R', 'U', 'E', '.' / C ICL2 = ICL1 - 1 IF (LVALUE) GO TO 20 LERROR = (ICL2 + ICFDIM) .GT. ICLDIM IF (LERROR) GO TO 999 DO 10 I=1,ICFDIM ICL2 = ICL2 + 1 CLINE(ICL2) = CF(I) 10 CONTINUE GO TO 999 C 20 CONTINUE LERROR = (ICL2 + ICTDIM) .GT. ICLDIM IF (LERROR) GO TO 999 DO 30 I=1,ICTDIM ICL2 = ICL2 + 1 CLINE(ICL2) = CT(I) 30 CONTINUE C 999 CONTINUE RETURN END SUBROUTINE UTCVNI (CNAME, ICN1, ICN2, INAME, LERROR) C----------------------------------------------------------------------- C C FAMILY C ------ C UTILITY C C PURPOSE C ------- C TO CONVERT (HASH) A NAME INTO AN INTEGER C C PARAMETERS C ---------- C CNAME -I- THE NAME TO BE HASHED C ICN1 -I- INDEX OF THE FIRST CHARACTER IN THE NAME C ICN2 -I- INDEX OF THE LAST CHARACTER IN THE NAME C INAME -O- INTEGER RESULT C LERROR -O- TRUE IF AN ERROR OCCURED C C----------------------------------------------------------------------- C C GLOBAL CONSTANTS C CHARACTER*1 CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 COMMON / GLCOMC / CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 C C LOCAL VARIABLES AND PARAMETERS C INTEGER ICN1, ICN2, INAME CHARACTER*(*) CNAME(ICN2) INTEGER ICHDIM, ICIDIM, I, ICNMIN, ICN, ICH INTEGER IC(6) LOGICAL LERROR CHARACTER*1 C(48), CNAMEI SAVE ICIDIM, IC, ICHDIM, C DATA A ICHDIM, B C(1), C(2), C(3), C(4), C(5), C(6), C C(7), C(8), C(9), C(10), C(11), C(12), D C(13), C(14), C(15), C(16), C(17), C(18), E C(19), C(20), C(21), C(22), C(23), C(24), F C(25), C(26), C(27), C(28), C(29), C(30), G C(31), C(32), C(33), C(34), C(35), C(36), H C(37), C(38), C(39), C(40), C(41), C(42), I C(43), C(44), C(45), C(46), C(47), C(48) J / 48, K 'A', 'B', 'C', 'D', 'E', 'F', L 'G', 'H', 'I', 'J', 'K', 'L', M 'M', 'N', 'O', 'P', 'Q', 'R', N 'S', 'T', 'U', 'V', 'W', 'X', O 'Y', 'Z', '0', '1', '2', '3', P '4', '5', '6', '7', '8', '9', Q '+', '-', '*', ',', '=', '(', R ')', '.', ',', '''', '$', ' ' / DATA A ICIDIM, B IC(1), IC(2), IC(3), IC(4), IC(5), IC(6) C / 6, D 61, 1, 47, 61, 1, 47 / C LERROR = ICN1 .GT. ICN2 IF (LERROR) GO TO 999 I = 0 INAME = 0 ICNMIN = MIN0(ICN2, ICN1+ICIDIM-1) C C DO 30 ICN=ICN1,ICNMIN CNAMEI = CNAME(ICN) DO 10 ICH=1,ICHDIM IF (CNAMEI .EQ. C(ICH)) GO TO 20 10 CONTINUE ICH = ICHDIM + 1 20 CONTINUE I = I + 1 INAME = INAME + IC(I)*ICH 30 CONTINUE C 999 CONTINUE RETURN END SUBROUTINE UTRDBL (CLINE, ICL1, ICL2, LEOL) C C----------------------------------------------------------------------- C C FAMILY C ------ C UTILITY C C PURPOSE C ------- C TO READ (SKIP) BLANKS IN A LINE C C PARAMETERS C ---------- C CLINE -I- LINE OF CHARACTERS C ICL1 -I- INDEX OF THE FIRST CHARACTER IN THE LINE C ICL2 -I- INDEX OF THE LAST CHARACTER IN THE LINE C LEOL -O- TRUE IF THE END OF THE LINE WAS REACHED C C----------------------------------------------------------------------- C C GLOBAL CONSTANTS C CHARACTER*1 CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 COMMON / GLCOMC / CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 C C LOCAL VARIABLES AND PARAMETERS C INTEGER ICL1, ICL2 CHARACTER*(*) CLINE(ICL2) LOGICAL LEOL INTEGER I C IF (ICL1 .GT. ICL2) GO TO 20 C DO 10 I=ICL1,ICL2 IF (CBLANK .NE. CLINE(I)) GO TO 30 10 CONTINUE C 20 CONTINUE ICL1 = ICL2 + 1 LEOL = .TRUE. GO TO 999 C 30 CONTINUE ICL1 = I LEOL = .FALSE. C 999 CONTINUE RETURN END SUBROUTINE UTRDKY (CLINE, ICL1, ICL2, IKEY, IKYDIM, A CKEY, ICKDIM, IK) C C----------------------------------------------------------------------- C C FAMILY C ------ C UTILITY C C PURPOSE C ------- C TO MATCH CHARACTERS WITH ONE OF A GIVEN SET OF KEYS C C PARAMETERS C ---------- C CLINE -I- LINE OF CHARACTERS C ICL1 -I- INDEX OF THE FIRST CHARACTER IN THE LINE C ICL2 -I- INDEX OF THE LAST CHARACTER IN THE LINE C IKEY -I- CONTAINS THE LENGTH OF EACH KEY C IKYDIM -I- NUMBER OF KEYS C CKEY -I- CONTAINS THE KEYS C CKYDIM -I- DIMENSION OF CKEY C IK -O- NUMBER OF THE MATCHED KEY C C----------------------------------------------------------------------- C C GLOBAL CONSTANTS C CHARACTER*1 CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 COMMON / GLCOMC / CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 C C LOCAL VARIABLES AND PARAMETERS C INTEGER ICL1, ICL2, IKYDIM, ICKDIM, IK CHARACTER*(*) CLINE(ICL2), CKEY(ICKDIM) INTEGER IKEY(IKYDIM) INTEGER ICK2, ICLDIF, ICK1, I, ICK C IF (ICL1 .GT. ICL2) GO TO 30 ICK2 = 0 ICLDIF = ICL2 - ICL1 + 1 C DO 20 IK=1,IKYDIM ICK1 = ICK2 + 1 ICK2 = ICK2 + IKEY(IK) IF (ICLDIF .LT. IKEY(IK)) GO TO 20 I = ICL1 DO 10 ICK=ICK1,ICK2 IF (CLINE(I) .NE. CKEY(ICK)) GO TO 20 I = I + 1 10 CONTINUE GO TO 40 20 CONTINUE C 30 CONTINUE IK = IKYDIM + 1 GO TO 999 C 40 CONTINUE ICL1 = ICL1 + IKEY(IK) C 999 CONTINUE RETURN END SUBROUTINE UTRDNA (CLINE, ICL1, ICL2, ICL1NA, ICL2NA, LERROR) C C----------------------------------------------------------------------- C C FAMILY C ------ C UTILITY C C PURPOSE C ------- C TO READ A NAME ON A LINE C C PARAMETERS C ---------- C CLINE -I- LINE OF CHARACTERS C ICL1 -I- INDEX OF THE FIRST CHARACTER IN THE LINE C ICL2 -I- INDEX OF THE LAST CHARACTER IN THE LINE C ICL1NA -O- INDEX OF THE FIRST CHARACTER IN THE NAME C ICL2NA -O- INDEX OF THE LAST CHARACTER IN THE NAME C LERROR -O- TRUE IF AN ERROR OCCURED C C----------------------------------------------------------------------- C C GLOBAL CONSTANTS C CHARACTER*1 CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 COMMON / GLCOMC / CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 C C LOCAL VARIABLES AND PARAMETERS C INTEGER ICL1, ICL2, ICL1NA, ICL2NA CHARACTER*(*) CLINE(ICL2) LOGICAL LERROR INTEGER I C LERROR = .TRUE. IF (ICL1 .GT. ICL2) GO TO 999 C DO 10 I=ICL1,ICL2 IF (.NOT. ((LLE(CA,CLINE(I)) A .AND. LLE(CLINE(I),CZ)) B .OR. (LLE(C0,CLINE(I)) C .AND. LLE(CLINE(I),C9)))) GO TO 20 10 CONTINUE C I = ICL2 + 1 C 20 CONTINUE IF (.NOT. (LLE(CA,CLINE(ICL1)) A .AND. LLE(CLINE(ICL1),CZ))) GO TO 999 ICL1NA = ICL1 ICL1 = I ICL2NA = I - 1 LERROR = .FALSE. C 999 CONTINUE RETURN END SUBROUTINE UTRDNU (CLINE, ICL1, ICL2, ICL1NU, ICL2NU, LERROR) C C----------------------------------------------------------------------- C C FAMILY C ------ C UTILITY C C PURPOSE C ------- C TO READ A NUMBER ON A LINE C C PARAMETERS C ---------- C CLINE -I- LINE OF CHARACTERS C ICL1 -I- INDEX OF THE FIRST CHARACTER IN THE LINE C ICL2 -I- INDEX OF THE LAST CHARACTER IN THE LINE C ICL1NU -O- INDEX OF THE FIRST CHARACTER IN THE NUMBER C ICL2NU -O- INDEX OF THE LAST CHARACTER IN THE NUMBER C LERROR -O- TRUE IF AN ERROR OCCURED C C----------------------------------------------------------------------- C C GLOBAL CONSTANTS C CHARACTER*1 CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 COMMON / GLCOMC / CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 C C LOCAL VARIABLES AND PARAMETERS C INTEGER ICL1, ICL2, ICL1NU, ICL2NU CHARACTER*(*) CLINE(ICL2) LOGICAL LERROR INTEGER I, ICL EXTERNAL UTRDBL C LERROR = ICL1 .GT. ICL2 IF (LERROR) GO TO 999 I = ICL1 IF ((CLINE(I) .NE. CMINUS) A .AND. (CLINE(I) .NE. CPLUS)) GO TO 10 I = I + 1 CALL UTRDBL (CLINE, I, ICL2, LERROR) IF (LERROR) GO TO 999 C 10 CONTINUE ICL = I DO 20 I=ICL,ICL2 IF (.NOT. (LLE(C0,CLINE(I)) A .AND. LLE(CLINE(I),C9))) GO TO 30 20 CONTINUE C I = ICL2 + 1 C 30 CONTINUE ICL1NU = ICL1 ICL1 = I ICL2NU = I - 1 LERROR = ICL1NU .GT. ICL2NU C 999 CONTINUE RETURN END SUBROUTINE UTRDQS (CLINE, ICL1, ICL2, ICL1QS, ICL2QS, LERROR) C C----------------------------------------------------------------------- C C FAMILY C ------ C UTILITY C C PURPOSE C ------- C TO READ A QUOTED STRING ON A LINE C C PARAMETERS C ---------- C CLINE -I- LINE OF CHARACTERS C ICL1 -I- INDEX OF THE FIRST CHARACTER IN THE LINE C ICL2 -I- INDEX OF THE LAST CHARACTER IN THE LINE C ICL1QS -O- INDEX OF THE FIRST CHARACTER IN THE STRING C ICL2QS -O- INDEX OF THE LAST CHARACTER IN THE STRING C LERROR -O- TRUE IF AN ERROR OCCURED C C----------------------------------------------------------------------- C C GLOBAL CONSTANTS C CHARACTER*1 CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 COMMON / GLCOMC / CA, CBLANK, CC, CI, CLEFT, A CMINUS, CPLUS, CPOINT, CQUOTE, CRIGHT, B CZ, C0, C9 C C LOCAL VARIABLES AND PARAMETERS C INTEGER ICL1, ICL2, ICL1QS, ICL2QS CHARACTER*(*) CLINE(ICL2) CHARACTER*1 CQTEMP LOGICAL LERROR INTEGER I C LERROR = .TRUE. ICL1QS = ICL1 + 1 IF (ICL1QS .GT. ICL2) GO TO 999 CQTEMP = CLINE(ICL1) C DO 10 I=ICL1QS,ICL2 IF (CLINE(I) .EQ. CQTEMP) GO TO 20 10 CONTINUE C GO TO 999 C 20 CONTINUE ICL1 = I + 1 ICL2QS = I - 1 LERROR = .FALSE. C 999 CONTINUE RETURN END SHAR_EOF fi # end of overwriting check cd .. cd .. cd .. # End of shell archive exit 0