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