C**************************************************************** C C Outer interface JAKED1 for calling JAKEF via JAKEF1. C C**************************************************************** SUBROUTINE JAKED1(IWA,LIWA,CWA,LCWA) INTEGER LIWA,LCWA INTEGER IWA(LIWA) CHARACTER*1 CWA(LCWA) INTEGER TLIM,LSAVE,LSTM,LVAR,LVARD,LCRYSP,LOPNDS, * LLBL,LEXPR,LRHS,LFLAG,LNMTBL,LPFILE,LINDX, * LSTACK,NREAD,NWRITE,RFORT REAL DCWA,DIWA,PCWA,PIWA DATA DCWA,DIWA /4.5E3,7.6E3/ C C THIS ROUTINE CONNECTS EXTERNAL UNITS 5 AND 6 TO THE C STANDARD INPUT AND OUTPUT. A SCRATCH FILE REQUIRED BY C JAKEF IS ARBITRARILY CONNECTED TO UNIT 1. OTHER C INSTALLATIONS MAY REQUIRE THE JAKEF INSTALLER TO CHANGE C THESE DESIGNATIONS. C NREAD = 5 NWRITE = 6 RFORT = 1 C C THE FOLLOWING DIMENSION PARAMETERS ARE SET TO FRACTIONS C OF WORK ARRAY DIMENSIONS LIWA AND LCWA. C PIWA = FLOAT(LIWA)/DIWA PCWA = FLOAT(LCWA)/DCWA TLIM = 10*PCWA TLIM = MIN(TLIM,999) LSAVE = 50*PIWA LSTM = 50*PIWA LVAR = 200*PCWA LVARD = 200*PIWA LCRYSP = 100*PCWA LOPNDS = 5*PIWA LLBL = 10*PIWA LEXPR = 1000*PIWA LRHS = 50*PIWA LFLAG = 1000*PCWA LNMTBL = 500*PCWA LPFILE = 500*PIWA LINDX = 50*PIWA LSTACK = 150*PIWA CALL JAKEF1(NREAD,NWRITE,RFORT,TLIM,LSAVE,LSTM,LVAR,LVARD, * LCRYSP,LOPNDS,LLBL,LEXPR,LRHS,LFLAG,LNMTBL, * LPFILE,LINDX,LSTACK,IWA,LIWA,CWA,LCWA) RETURN END C C LAST CARD OF JAKEF INTERFACE ROUTINE JAKED1. C C****************************************************************** C C Inner interface routine JAKEF1 for calling JAKEF C C****************************************************************** C SUBROUTINE JAKEF1(NREAD,NWRITE,RFORT,TLIM,LSAVE,LSTM,LVAR, * LVARD,LCRYSP,LOPNDS,LLBL,LEXPR,LRHS,LFLAG, * LNMTBL,LPFILE,LINDX,LSTACK,IWA,LIWA,CWA, * LCWA) INTEGER NREAD,NWRITE,RFORT,TLIM,LSAVE,LSTM,LVAR,LVARD,LCRYSP, * LOPNDS,LLBL,LEXPR,LRHS,LFLAG,LNMTBL,LPFILE,LINDX, * LSTACK,LIWA,LCWA INTEGER IWA(LIWA) CHARACTER*1 CWA(LCWA) C C THIS ROUTINE PARTITIONS THE INTEGER AND CHARACTER WORK C ARRAYS IWA AND CWA USING THE INPUT DIMENSION PARAMETERS. C INTEGER INDX1,INDX2,INDX3,INDX4,INDX5,INDX6,INDX7,INDX8,INDX9, * INDX10,INDX11,INDX12 INDX1 = 5*LSAVE + 4 INDX2 = INDX1 + 4*LEXPR + 2 INDX3 = INDX2 + LRHS INDX4 = INDX3 + LPFILE INDX5 = INDX4 + 16*LSTM + 6 INDX6 = INDX5 + 8*LVARD INDX7 = INDX6 + 2*LSTACK + 2 INDX8 = INDX7 + LOPNDS INDX9 = INDX8 + LLBL INDX10 = 2*LFLAG + 1 INDX11 = INDX10 + LNMTBL + 1 INDX12 = INDX11 + LCRYSP CALL JAKEF(IWA(1),LSAVE,IWA(INDX1+1),LEXPR,IWA(INDX2+1),LRHS, * CWA(1),LFLAG,CWA(INDX10+1),LNMTBL,CWA(INDX11+1), * LCRYSP,IWA(INDX3+1),LPFILE,IWA(INDX4+1),LSTM, * CWA(INDX12+1),LVAR,IWA(INDX5+1),LVARD,IWA(INDX6+1), * LSTACK,IWA(INDX7+1),LOPNDS,IWA(INDX8+1),LLBL, * IWA(INDX9+1),LINDX,TLIM,RFORT,NREAD,NWRITE) RETURN C C LAST CARD OF SUBROUTINE JAKEF1. C END C***************************************************************** C C JAKEF EXECUTIVE PROGRAM FOR THE AUTOMATIC DIFFERENTIATION OF C FUNCTIONS. C C***************************************************************** SUBROUTINE JAKEF(SAVE,LSAVE,EXPR,LEXPR,RHS,LRHS,FLAG,LFLAG, * NMTBL,LNMTBL,CRYSP,LCRYSP,PFILE,LPFILE,STM, * LSTM,VAR,LVAR,VARD,LVARD,STACK,LSTACK,OPNDS, * LOPNDS,LBL,LLBL,INDX,LINDX,TLIM,RFORT,NREAD, * NWRITE) C C GLOBAL VARIABLES. C INTEGER LSAVE,LEXPR,LRHS,LFLAG,LNMTBL,LCRYSP,LPFILE,LSTM,LVAR, * LVARD,LSTACK,LOPNDS,LLBL,LINDX,TLIM,RFORT,NREAD,NWRITE CHARACTER FLAG(0:2*LFLAG),NMTBL(0:LNMTBL),CRYSP(LCRYSP), * VAR(9*LVAR) INTEGER SAVE(0:5*LSAVE+4),EXPR(0:4*LEXPR),RHS(LRHS),PFILE(LPFILE), * STM(16*LSTM+6),VARD(8*LVARD),STACK(0:2*LSTACK+1), * OPNDS(0:LOPNDS),LBL(LLBL),INDX(LINDX) CHARACTER EOF,EOL,EOS,EOT CHARACTER ADC(86) INTEGER CRYPNT,COL,CONFLG,EXPFRE,IN,INDS,INITBD,INTADD,INTONE, * INTTWO,JFLG,LABCNT,LASTCH,NEXTCH,NTFREE,NSMTAB,NTIND, * OUT,OUTP,RESULT,RHSFST,RHSLST,SENTNL,STNCNT,TYPRSL, * LEVEL,LNESTA,LNESTB INTEGER AD(86),ARITY(0:255),CHAIN(0:255),DEFLEN(42),DEFTYP(42), * LIBDBL(14),LIBSGL(14),LIBTKN(0:14),STYPEF(52), * YYACT(0:388),YYCHK(0:189),YYDEF(0:189),YYEXCA(0:11), * YYLEXF(52),YYPACT(0:189),YYPGO(0:42),YYR1(0:102), * YYR2(0:102),YYVALF(52) INTEGER DEPS(1000),DESCR(1000),PRIOR(1000),TEMP(1000) LOGICAL AFLAG,BFLAG,CFLAG,LVFLAG C C LOCAL VARIABLES. C CHARACTER*12 NAMES(126),STR(34) CHARACTER*70 ERRM1,ERRM2 INTEGER DIMOF,FREEPD,I,INDEX,J,K,KEEP,L,P,PRDLST,PROG,ST,T,V,VD INTEGER AETAB(126),EATAB(0:255) C C FUNCTION NAMES. C INTEGER ADDR,ALCADD,DISTBR,LABELU,LOCSTR,MAKETR,NTLOCT,SRCHLB, * TYPEOF C C COMMON STORAGE. C COMMON /ENDSYM/ EOF,EOL,EOS,EOT COMMON /XCHAR/ ADC COMMON /ZCHAR/ AD COMMON /FLAGS/ OUTP,SENTNL,JFLG,CONFLG COMMON /PARSE/ STYPEF,YYACT,YYCHK,YYDEF,YYEXCA,YYLEXF,YYPACT, * YYPGO,YYR1,YYR2,YYVALF COMMON /COUNTS/ COL,LASTCH,NEXTCH COMMON /COUNTR/ CRYPNT,EXPFRE,NSMTAB,NTFREE COMMON /CONTRL/ IN,OUT,RESULT,TYPRSL COMMON /INDEX/ INDS,LABCNT,RHSFST,RHSLST,STNCNT COMMON /DATAB/ ARITY,DEFLEN,DEFTYP,DESCR COMMON /NAME/ NAMES COMMON /LIB/ LIBDBL,LIBSGL,LIBTKN COMMON /ADDX/ INITBD,INTADD COMMON /INTS/ INTONE,INTTWO COMMON /NODE/ CHAIN COMMON /CTBL/ AETAB,EATAB COMMON /STORE/ DEPS,PRIOR,TEMP COMMON /TRACK/ LEVEL COMMON /SGNL/ AFLAG,BFLAG,CFLAG,LVFLAG COMMON /NEST/ LNESTA,LNESTB DATA STR */'0.@','0.D0@','1.@','1.D0@','2.@','2.D0@','.5@','.5D0@','SNGL@', *'EXP@','ALOG@','SIN@','COS@','SQRT@','ATAN@','TAN@','ASIN@', *'SINH@','COSH@','ABS@','SIGN(1.,@','DBLE@','DEXP@','DLOG@', *'DSIN@','DCOS@','DSQRT@','DATAN@','DTAN@','DASIN@','DSINH@', *'DCOSH@','DABS@','DSIGN(1.D0,@'/ DATA ERRM1 /' MISSING CONSTRUCT STATEMENT'/ DATA ERRM2 /' WRONG GO-TO STRUCTURE'/ C C CONNECT RFORTD FILE AND CONSTRUCT TRANSLATION TABLE. C OPEN (RFORT,STATUS='NEW',FILE='RFORTD') REWIND RFORT DO 5 I = 1, 86 INDEX = ICHAR(ADC(I)(1:1)) EATAB(INDEX) = AD(I) AETAB(AD(I)) = INDEX 5 CONTINUE SENTNL = 0 OUTP = 0 JFLG = 0 CONFLG = 0 LEVEL = 0 LVFLAG = .FALSE. CFLAG = .FALSE. LNESTA = 0 LNESTB = 0 C C READ INITIAL STATEMENT. C CALL GETCRD(NREAD) CALL GETSTM(NREAD,NWRITE,VAR,LVAR) C C SUBSEQUENT STATEMENTS ARE PROCESSED UNTIL AN EOF IS ENCOUNTERED. C 10 CONTINUE IF (SENTNL .NE. -1) THEN CALL SCAN(RFORT,NREAD,NWRITE,VAR,LVAR) GO TO 10 END IF REWIND RFORT IF (CONFLG .EQ. 0) CALL ERRORM(ERRM1,NWRITE) C******************************************************************* C C LEXICAL PREPROCESSING FINISHED. BEGIN PARSING. C C******************************************************************* OUTP = 1 CRYPNT = 1 CALL GETLIN(RFORT,VAR,LVAR) C C INITIALIZE NAME TABLE. C NTFREE = 1 INDX(1) = -1 NMTBL(1) = ADC(22) DO 20 J = 1, 34 I = NTLOCT(STR(J),NWRITE,NMTBL,LNMTBL,INDX,LINDX) 20 CONTINUE CALL YYPARS(RFORT,NWRITE,NMTBL,LNMTBL,CRYSP,LCRYSP, * PFILE,LPFILE,VAR,LVAR,STACK,LSTACK,INDX, * LINDX) CALL PUT(PFILE,LPFILE,NWRITE,-1) NMTBL(NTFREE) = ADC(22) CRYPNT = CRYPNT + 1 C******************************************************************* C C PARSING IS FINISHED. NOW BEGIN TREE BUILDING AND FLOW GRAPH C ANALYSIS. C C******************************************************************* C C ENTER DEFAULT CONVENTION OF FORTRAN: I-N INTEGER; A-H,O-Z REAL. C CALL IMPLCT(ADC(16),ADC(19),3,0) CALL IMPLCT(ADC(52),ADC(47),2,0) DO 30 I = 0, 255 ARITY(I) = -1 CHAIN(I) = 0 30 CONTINUE C C INITIALIZE TOKENS. C ARITY(AD(23)) = 2 ARITY(AD(24)) = 2 ARITY(AD(25)) = 2 ARITY(AD(26)) = 2 ARITY(AD(36)) = 2 ARITY(AD(31)) = 2 ARITY(AD(34)) = 2 ARITY(AD(30)) = 2 ARITY(AD(27)) = 2 ARITY(AD(43)) = 2 ARITY(AD(44)) = 2 ARITY(AD(45)) = 2 ARITY(AD(46)) = 2 ARITY(AD(47)) = 2 ARITY(AD(48)) = 2 ARITY(AD(41)) = 2 ARITY(AD(40)) = 2 ARITY(AD(28)) = 2 ARITY(AD(10)) = 2 ARITY(28) = 2 ARITY(27) = 2 ARITY(26) = 2 ARITY(32) = 2 ARITY(33) = 2 ARITY(25) = 2 ARITY(24) = 2 ARITY(15) = 2 ARITY(13) = 2 ARITY(19) = 2 ARITY(17) = 2 ARITY(16) = 2 ARITY(4) = 2 ARITY(AD(35)) = 1 ARITY(AD(4)) = 1 ARITY(AD(5)) = 1 ARITY(AD(7)) = 1 ARITY(AD(8)) = 1 ARITY(AD(9)) = 1 ARITY(AD(2)) = 1 ARITY(AD(3)) = 1 ARITY(AD(6)) = 1 ARITY(AD(37)) = 1 ARITY(AD(12)) = 1 ARITY(AD(11)) = 1 ARITY(AD(14)) = 1 ARITY(AD(15)) = 1 ARITY(AD(16)) = 1 ARITY(20) = 1 ARITY(18) = 1 ARITY(10) = 1 ARITY(9) = 1 ARITY(8) = 1 ARITY(AD(13)) = 0 ARITY(AD(33)) = 0 ARITY(AD(42)) = 0 ARITY(AD(29)) = 0 ARITY(23) = 0 ARITY(22) = 0 ARITY(21) = 0 ARITY(12) = 0 ARITY(14) = 0 ARITY(11) = 0 ARITY(31) = 0 ARITY(6) = 0 ARITY(5) = 0 C C INITIALIZE ARRAYS FOR LIBRARY FUNCTIONS. C LIBTKN(0) = 0 DO 35 I = 1, 13 LIBTKN(I) = AD(I) LIBSGL(I) = LOCSTR(STR(I+8),NMTBL,LNMTBL) LIBDBL(I) = LOCSTR(STR(I+21),NMTBL,LNMTBL) 35 CONTINUE LIBTKN(10) = AD(11) LIBTKN(11) = AD(14) LIBTKN(12) = AD(15) LIBTKN(13) = AD(16) LIBTKN(14) = 0 LIBSGL(14) = 0 LIBDBL(14) = 0 NSMTAB = 0 EXPFRE = 1 C C BUILD EXPRESSION TREE. C PROG = MAKETR(NWRITE,EXPR,LEXPR,NMTBL,LNMTBL,PFILE,LPFILE, * VARD,LVARD,OPNDS,LOPNDS) C C BEGIN FLOW GRAPH ANALYSIS. C SET ALL DEFAULT TYPES (AFTER ALL EXPLICIT DECLARATIONS). C DO 40 VD = 1, NSMTAB IF (VARD(LVARD+VD) .EQ. 0) THEN NTIND = VARD(VD) I = ADDR(NMTBL(NTIND)) - AD(16) + 1 VARD(LVARD+VD) = DEFTYP(I)*256 + DEFLEN(I) END IF 40 CONTINUE C C ORIGINALLY, VARTYPE IS CODED AS 256*TYPE + LENGTH. THIS IS NOW C CHANGED TO 8*TYPE + LENGTH. THE OLD CODING ALLOWS UNIQUELY C DETERMINED EXTRACTION OF TYPE AND LENGTH. THE NEW CODING C DELIBERATELY MAKES OBLIVIOUS THE DIFFERENCE BETWEEN REAL*8 AND C DOUBLE PRECISION BY USING THE FACTOR OF 8. C DO 50 VD = 1, NSMTAB T = VARD(LVARD+VD)/256 L = VARD(LVARD+VD) - 256*T VARD(LVARD+VD) = 8*T + L 50 CONTINUE STNCNT = 0 LABCNT = 1 CALL SEQN(PROG,SAVE,LSAVE,NWRITE,EXPR,LEXPR,STM,LSTM) C C DETERMINE SEQUENCE NUMBERS FOR ALL STATEMENTS IN THE PROGRAM. C INDS = 1 IF (EXPR(2*LEXPR+STM(STNCNT)) .EQ. 6) STNCNT = STNCNT - 1 DO 60 ST = 1, STNCNT P = STM(ST) KEEP = STM(LSTM+ST) STM(LSTM+ST) = INDS IF (EXPR(2*LEXPR+P) .EQ. AD(12)) THEN J = EXPR(3*LEXPR+P) IF (EXPR(2*LEXPR+J) .NE. AD(33)) * CALL ERRORM(ERRM2,NWRITE) K = SRCHLB(NWRITE,EXPR(3*LEXPR+J),EXPR,LEXPR,STM,LSTM, * LBL,LLBL) STM(2*LSTM+INDS) = K INDS = INDS + 1 ELSE IF (EXPR(2*LEXPR+P) .EQ. 6) THEN STM(2*LSTM+INDS) = STNCNT + 1 INDS = INDS + 1 ELSE IF (EXPR(2*LEXPR+P) .EQ. 5) THEN STM(2*LSTM+INDS) = STNCNT + 2 INDS = INDS + 1 ELSE IF (EXPR(2*LEXPR+P) .EQ. 24) THEN STM(2*LSTM+INDS) = ST + 1 STM(2*LSTM+INDS+1) = ST + 2 INDS = INDS + 2 ELSE IF (EXPR(2*LEXPR+P) .EQ. 27) THEN CALL SUCLST(NWRITE,EXPR(P),EXPR,LEXPR,STM,LSTM,LBL,LLBL) ELSE IF ((EXPR(2*LEXPR+P) .EQ. 21).OR.(EXPR(2*LEXPR+P) .EQ. * 25)) THEN CALL SUCLST(NWRITE,EXPR(3*LEXPR+P),EXPR,LEXPR,STM,LSTM,LBL, * LLBL) ELSE STM(2*LSTM+INDS) = ST + 1 INDS = INDS + 1 END IF IF (KEEP .NE. 0) THEN STM(2*LSTM+INDS) = KEEP INDS = INDS + 1 END IF STM(2*LSTM+INDS) = 0 INDS = INDS + 1 60 CONTINUE C C NOW REMOVE ALL STATEMENTS OF THE FORM "LABEL:CONTINUE" WHERE C THE LABEL IS NOT REFERENCED ANYWHERE. C DO 70 ST = 1, STNCNT P = STM(ST) IF (((EXPR(2*LEXPR+P) .EQ. AD(28)) .AND. * (EXPR(2*LEXPR+EXPR(3*LEXPR+P)) .EQ. 31)) .AND. * (LABELU(EXPR(3*LEXPR+EXPR(P)),LBL,LLBL)) .EQ. 0) * STM(ST) = 0 70 CONTINUE PRDLST = 1 DO 80 ST = 1, STNCNT + 2 STM(6*LSTM+ST) = FREEPD(PRDLST,NWRITE,STM,LSTM) 80 CONTINUE DO 100 ST = 1, STNCNT I = STM(LSTM+ST) 90 CONTINUE J = STM(2*LSTM+I) IF (J .NE. 0) THEN CALL INPRD(J,ST,PRDLST,NWRITE,STM,LSTM) I = I + 1 GO TO 90 END IF 100 CONTINUE RHSLST = 1 DO 110 ST = 1, STNCNT P = STM(ST) STM(4*LSTM+ST) = 0 STM(5*LSTM+ST) = 0 IF (EXPR(2*LEXPR+P) .EQ. AD(28)) P = EXPR(3*LEXPR+P) IF (EXPR(2*LEXPR+P) .NE. AD(31)) GO TO 110 V = EXPR(P) IF (EXPR(2*LEXPR+V) .EQ. AD(34)) V = EXPR(V) T = TYPEOF(V,EXPR,LEXPR,VARD,LVARD) IF (T .GE. 24) THEN VD = EXPR(3*LEXPR+V) STM(4*LSTM+ST) = VD RHSFST = RHSLST STM(5*LSTM+ST) = RHSFST DIMOF = -1 IF (EXPR(2*LEXPR+V) .EQ. AD(13)) * DIMOF = VARD(2*LVARD+EXPR(3*LEXPR+V)) IF (DIMOF .NE. 0) CALL INRTS(VD,NWRITE,RHS,LRHS) CALL GETRHS(EXPR(3*LEXPR+P),SAVE,LSAVE,NWRITE,EXPR,LEXPR, * RHS,LRHS,VARD,LVARD) CALL INRTS(0,NWRITE,RHS,LRHS) END IF 110 CONTINUE STM(4*LSTM+STNCNT+1) = 0 STM(4*LSTM+STNCNT+2) = STM(4*LSTM+STNCNT+1) CALL DEPEND(NWRITE,EXPR,LEXPR,RHS,LRHS,FLAG,LFLAG,STM,LSTM, * VAR,LVAR) CALL NEED(NWRITE,EXPR,LEXPR,RHS,LRHS,FLAG,LFLAG,STM,LSTM,VAR, * LVAR) CALL RELEV(EXPR,LEXPR,RHS,LRHS,STM,LSTM,VAR,LVAR) C******************************************************************* C C TREE BUILDING AND FLOW GRAPH ANALYSIS ARE FINISHED. BEGIN C SYMBOLIC DIFFERENTIATION. C C******************************************************************* NMTBL(0) = ADC(22) C C INITIALIZE TOKENS. C ARITY(1) = 1 ARITY(2) = 1 ARITY(3) = 1 ARITY(8) = -1 ARITY(9) = -1 ARITY(10) = -1 DO 120 I = 18, 23 ARITY(I) = -1 120 CONTINUE ARITY(AD(1)) = 1 ARITY(AD(34)) = 0 DO 130 P = 1, EXPFRE - 1 T = EXPR(2*LEXPR+P) EXPR(LEXPR+P) = CHAIN(T) CHAIN(T) = P 130 CONTINUE COL = 1 INTONE = DISTBR(AD(33),0,1,NWRITE,EXPR,LEXPR) TYPRSL = TYPEOF(RESULT,EXPR,LEXPR,VARD,LVARD) INTADD = ALCADD(SAVE,LSAVE,NWRITE,EXPR,LEXPR,NMTBL,LNMTBL, * VAR,LVAR,VARD,LVARD,TLIM) CALL GRDENT(SAVE,LSAVE,NWRITE,EXPR,LEXPR,RHS,LRHS,NMTBL,LNMTBL, * STM,LSTM,VARD,LVARD) CALL EMITS(SAVE,LSAVE,NWRITE,EXPR,LEXPR,NMTBL,LNMTBL,CRYSP, * LCRYSP,STM,LSTM,VAR,LVAR,VARD,LVARD,LBL,LLBL,TLIM) CLOSE (RFORT,STATUS='DELETE') C C LAST CARD OF JAKEF EXECUTIVE PROGRAM. C END C********************************************************************* C C JAKEF - BLOCK DATA ROUTINE. C BLOCK DATA JAKEBD CHARACTER EOF,EOL,EOS,EOT CHARACTER ADC(86) CHARACTER*5 NTC(6) CHARACTER*7 CHS(6) CHARACTER*12 NAMES(126) CHARACTER*13 RCALL(9),SUPR(4) CHARACTER*16 KEYWD1(45) CHARACTER*17 KEYWD2(52),PRDLST(14) CHARACTER*18 TYPNAM(5) INTEGER AD(86),STYPEF(52),YYACT(0:388),YYCHK(0:189),YYDEF(0:189), * YYEXCA(0:11),YYLEXF(52),YYPACT(0:189),YYPGO(0:42), * YYR1(0:102),YYR2(0:102),YYVALF(52) COMMON /NAME/ NAMES COMMON /ENDSYM/ EOF,EOL,EOS,EOT COMMON /XCHAR/ ADC COMMON /ZCHAR/ AD COMMON /TNTC/ NTC COMMON /CHSTR/ CHS,SUPR COMMON /CALLS/ RCALL COMMON /KTYPE/ TYPNAM COMMON /KEY/ KEYWD1,KEYWD2,PRDLST COMMON /PARSE/ STYPEF,YYACT,YYCHK,YYDEF,YYEXCA,YYLEXF,YYPACT, * YYPGO,YYR1,YYR2,YYVALF DATA EOF,EOL,EOS,EOT /'$','%','&','@'/ DATA ADC */'?','e','l','s','c','r','a','t','b','d','f','g','i','o','z', *'A','F','T','Z','0','9','@','+','-','*','/',';',':','.',',', *'=',' ','#','[','_','?','_','(',')','|','&','''','>','E','<', *'G','N','L','k','D','1','I','Y','R','J','C','O','H','h','j', *'m','n','p','q','u','v','w','x','y','B','K','M','P','Q','S', *'U','V','W','X','2','3','4','5','6','7','8'/ DATA AD */63,101,108,115,99,114,97,116,98,100,102,103,105,111,122,65,70, *84,90,48,57,64,43,45,42,47,59,58,46,44,61,32,35,91,95,94,126, *40,41,124,38,34,62,69,60,71,78,76,107,68,49,73,89,82,74,67,79, *72,104,106,109,110,112,113,117,118,119,120,121,66,75,77,80,81, *83,85,86,87,88,50,51,52,53,54,55,56/ DATA NTC */'0.@','0.D0@','1.@','1.D0@','.5@','.5D0@'/ DATA CHS */'DO @','END@',' = 0@',' = 1,@','RETURN@','TEMP@'/ DATA SUPR */'CALL DPINIT(@','CALL SPINIT(@','CALL DPGRAD(@','CALL SPGRAD(@'/ DATA RCALL */'D','DBLE@','DLOG@','CALL DMIT0@','CALL DMIT1@','CALL DMIT2@', *'+1@','CALL DPCOPY(@','CALL SPCOPY(@'/ DATA TYPNAM */'LOGICAL @','INTEGER @','REAL @','DOUBLE PRECISION @', *'CHARACTER@'/ DATA NAMES */'CALL EMIT0@','CALL EMIT1@','CALL EMIT2@','0','0','RETURN@','0',' *0','0','0','0','0','SUBROUTINE @','0','COMMON@','*@','0','0','0',' *0','0','0','0','IF @','IF@','0','GO TO @','GO TO @','0','0','CONTI *NUE@','0','0','0','0','0','0','.AND.@','0','0','0','0','0','0','0' *,'0','0','0','0','0','0','0','0','0','0','0','0','0','0','.LT.@',' *0','.GT.@','SNGL@','0','SIGN@','0','0','0','.EQ.@','0','.GE.@','0' *,'0','0','0','.LE.@','0','.NE.@','0','0','0','0','0','0','0','0',' *0','0','0','0','0','0','0','**@','-@','0','ATAN@','ASIN@','COS@',' *DO @','EXP@','SINH@','GO TO @','0','0','0','0','ALOG@','0','0','CO *SH@','0','0','SQRT@','SIN@','TAN@','0','0','0','0','0','ABS@','0', *'.OR.@','0','.NOT.@'/ DATA KEYWD1 */'assign@','backspace@','blockdata@','call@','character@','close@' *,'common@','complex@','construct@','continue@','data@','dimension@ *','doubleprecision@','endfile@','end@','entry@','equivalence@','ex *ternal@','format@','function@','goto@','implicit@','integerfunctio *n@','integer@','intrinsic@','logicalfunction@','logical@','open@', *'parameter@','pause@','print@','program@','read@','realfunction@', *'real@','return@','rewind@','stop@','subroutine@','write@','else@' *,'save@','endfile@','inquire@','0'/ DATA KEYWD2 */'@','continue@','if@','goto@','return@','do@','common@','stop@',' *read@','subroutine@','else@','elseif@','endif@','integer@','real@' *,'doubleprecision@','logical@','character@','dimension@','implicit *@','construct@','assign@','backspace@','call@','close@','data@','e *ntry@','equivalence@','external@','format@','open@','pause@','prin *t@','rewind@','endfile@','write@','save@','gt@','ge@','eq@','ne@', *'le@','lt@','true@','false@','and@','or@','not@','end@','parameter *@','inquire@','0'/ DATA PRDLST */'@','sin@','cos@','tan@','atan@','sqrt@','exp@','alog@','asin@',' *sinh@','cosh@','abs@','sign@','0'/ DATA YYACT /28,42,25,27,3,42,66,12,14,11,15,16,17,18,22,23,24,28, *27,20,19,21,164,46,12,14,11,15,16,17,18,22,23,24,42,27,20,19,21, *144,100,98,151,99,81,101,130,100,98,75,99,186,101,129,100,98,167, *99,28,101,100,98,6,99,61,101,166,63,87,62,100,98,26,99,169,101, *100,98,78,99,72,101,28,42,102,118,100,98,153,99,44,101,102,100,8, *45,77,13,101,102,50,69,55,124,31,35,102,70,73,32,170,79,102,60,83, *123,173,65,10,172,51,119,102,10,150,56,40,178,102,59,84,119,188, *181,41,43,179,128,102,180,111,70,179,52,10,102,175,176,146,79,177, *114,97,133,121,127,134,92,128,113,95,115,114,96,88,91,85,174,117, *135,112,10,36,120,145,122,86,132,46,68,125,53,48,47,34,29,30,147, *73,51,39,4,131,38,79,9,148,158,162,152,156,28,149,74,116,165,93, *49,12,14,11,15,16,17,18,22,23,24,158,27,20,19,21,158,163,171,57, *161,76,82,37,71,110,67,33,157,54,155,5,7,28,42,159,10,185,2,160, *88,158,154,1,0,158,58,80,0,0,0,103,104,105,158,182,159,0,103,104, *105,159,0,0,0,103,104,105,0,0,0,103,104,105,28,42,66,0,0,184,64, *103,104,187,155,0,159,103,0,0,159,0,189,0,89,90,154,183,0,159,94, *0,0,0,0,0,0,0,106,107,108,109,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, *0,0,0,126,0,0,0,0,0,0,0,0,0,0,0,136,137,138,139,140,141,142,143,0, *0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,168/ DATA YYPACT /-270,-1000,181,-195,-56,145,-1000,176,-1000,-240,48, *144,-1000,130,79,-1000,-224,-17,143,142,-1000,-1000,-272,-1000, *-1000,-224,141,-1000,-1000,-199,-56,-1000,24,139,-199,-199,-209, *79,-199,-1000,-3,-199,-1000,-1000,122,122,-224,24,24,121,-1000, *130,-1000,24,119,-1000,-1000,-240,18,-1000,-1000,24,24,24,24, *-1000,-1000,-199,-199,118,-1000,117,-1000,126,74,-1000,-199,110, *-1000,138,68,-1000,-1000,42,138,-1000,24,114,-1000,12,5,-272,137, *112,18,-1000,-199,-1000,24,24,24,24,24,24,24,24,-2,-10,-10,34, *-1000,134,107,-1000,-199,-199,84,-216,-1000,-253,110,-199,-1000, *-1000,-175,-1000,18,-1000,-224,-257,-1000,-1000,-201,-1000,24, *-1000,51,51,-10,-10,-10,44,34,28,-1000,-175,-1000,-1000,-1000, *-1000,-175,-1000,72,-1000,-1000,125,-1000,102,-1000,-1000,-1000, *-1000,93,-1000,-1000,106,-1000,82,18,98,-1000,92,-1000,-253,-253, *-175,-1000,-201,-206,-175,-1000,-1000,-1000,-1000,88,-1000,-1000, *-1000,-175,-1000/ DATA YYPGO /0,250,245,239,238,236,94,195,117,113,253,234,233,232, *97,105,231,230,229,72,130,95,227,207,206,129,68,110,100,205,66, *80,204,85,203,74,199,88,193,96,190,78,101/ DATA YYR1/0,1,2,4,3,3,3,3,7,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,9,9, *19,8,24,24,10,10,10,10,10,10,10,10,10,10,10,10,10,10,20,20, *22,22,22,27,27,18,18,14,5,5,23,23,28,15,15,29,29,30,30,16,16, *31,31,34,35,35,32,32,33,33,36,36,37,37,25,25,21,26,26,17,17, *38,38,40,40,39,39,41,41,11,12,42,42,13,13/ DATA YYR2/0,4,5,1,1,2,3,4,2,3,4,1,3,2,1,3,2,4,4,5,4,1,1,2,1,1,1,4, *1,1,1,3,1,1,3,3,3,3,3,3,2,2,3,3,3,2,0,1,1,1,1,1,1,7,5,1,1,3,1, *3,5,0,2,1,3,3,1,1,3,3,2,5,1,3,0,2,0,3,1,3,1,3,1,1,3,1,3,2,3, *0,1,3,2,1,3,1,2,3,3,1,3,1,4/ DATA YYCHK/-1000,-1,-2,274,10,-4,257,-3,-6,-7,-9,266,264,-14,265, *267,268,269,270,277,276,278,271,272,273,58,-19,275,257,40,10,-6, *61,-11,40,-15,42,-17,-38,-40,47,-8,258,-8,-19,-21,40,40,40,-23, *-28,-14,-8,40,-5,-19,-6,-7,-10,-25,-9,40,45,43,263,-8,259,-12,40, *-42,-19,-16,-31,-19,-34,258,-40,-39,-41,-19,257,47,-18,-19, *-20,44,-20,-26,-8,-10,-10,44,-15,-24,-10,41,44,-6,43,45,42,47,94, *260,261,262,-10,-10,-10,-10,-13,-19,-42,41,44,44,-32,42,-33, *47,-39,44,-21,47,61,-21,-10,41,44,41,41,-28,40,41,44,-19,-10,-10, *-10,-10,-10,-10,-10,-10,41,40,41,-19,-31,-33,40,258, *-36,-37,-25,-8,-41,-27,-19,-8,-8,-22,-26,-6,279,-29,-30,257, *-10,-35,-27,-35,47,44,42,44,41,44,45,44,41,41,-37,-25,-27,-30, *257,-27,44,-27/ DATA YYDEF/0,-2,0,0,0,0,3,0,4,0,0,0,11,61,89,14,0,0,0,0,21,22,0, *24,25,0,26,55,28,0,1,5,0,0,0,0,0,13,0,90,0,0,29,16,46,46,0,0,0, *23,58,61,8,0,0,56,6,0,9,32,33,0,0,0,0,82,83,0,0,0,99,12,67,74, *76,62,0,87,93,95,0,92,15,0,0,47,0,0,85,0,0,0,0,0,30,2,0,7,0,0,0, *0,0,0,0,0,0,40,41,45,10,101,0,97,0,0,76,0,70,0,88,0,96,91,0,17, *18,84,0,0,20,59,0,27,0,57,35,36,37,38,39,-2,43,44,34,0,98,100,68, *69,0,75,0,78,80,82,94,0,51,52,86,19,48,49,50,0,63,66,31,0,72, *0,77,0,0,0,60,0,0,0,102,71,79,81,54,64,65,73,0,53/ DATA YYEXCA /-1,1,0,-1,-2,0,-1,141,260,0,-2,42/ DATA STYPEF /0,5*1,2,2*1,2,4*1,8*2,3*1,3,3*2,3,7*1,15*0/ DATA YYLEXF /0,267,270,269,272,268,265,273,264,274,276,277,278, *5*275,264,271,266,16*264,6*260,2*259,261,262,263,0,264,264,0/ DATA YYVALF /13*0,2,3,4,1,5,19*0,62,71,69,78,76,60,84,70,7*0/ C C LAST CARD OF BLOCK DATA ROUTINE. C END C**************************************************************** SUBROUTINE EMIT(C,RFORT,VAR,LVAR) C C THIS ROUTINE EMITS LINES OF PROCESSED FORTRAN. C INTEGER RFORT,LVAR CHARACTER C,VAR(9*LVAR) CHARACTER EOF,EOL,EOS,EOT INTEGER CONFLG,I,JFLG,OUTP,SENTNL COMMON /ENDSYM/ EOF,EOL,EOS,EOT COMMON /FLAGS/ OUTP,SENTNL,JFLG,CONFLG OUTP = OUTP + 1 VAR(8*LVAR+OUTP) = C IF (C .EQ. EOL) THEN VAR(8*LVAR+OUTP) = EOS CALL TRFORM(VAR(8*LVAR+1)) WRITE(RFORT,'(80A1)') (VAR(8*LVAR+I),I=1,OUTP) OUTP = 0 END IF RETURN C C LAST CARD OF SUBROUTINE EMIT. C END C***************************************************************** SUBROUTINE GETCRD(NREAD) C C THIS ROUTINE READS A CARD, PUTS COLUMNS 1-72 IN "CARD" AND C CAPITALIZES LOWER CASE LETTERS. C INTEGER NREAD CHARACTER ACHAR,EOF,EOL,EOS,EOT CHARACTER CARD(74) INTEGER AC,ADDR,COL,CONFLG,I,JFLG,OUTP,SENTNL,TEMP INTEGER AD(86) COMMON /ENDSYM/ EOF,EOL,EOS,EOT COMMON /IMAGE/ CARD COMMON /FLAGS/ OUTP,SENTNL,JFLG,CONFLG COMMON /ZCHAR/ AD READ (NREAD,'(74A1)',IOSTAT = TEMP) CARD DO 10 COL = 1, 72 AC = ADDR(CARD(COL)) IF ((AC .GE. AD(7)) .AND. (AC .LE. AD(15))) THEN I = AC - AD(7) + AD(16) CARD(COL) = ACHAR(I) END IF 10 CONTINUE C C RETURNS EITHER EOS OR EOF: LAST ENCOUNTERED SENTINEL. C IF (TEMP .EQ. 0) SENTNL = 0 IF (TEMP .LT. 0) SENTNL = -1 CARD(73) = EOS RETURN C C LAST CARD OF SUBROUTINE GETCRD. C END C******************************************************************* SUBROUTINE GETCON(NREAD,NWRITE,VAR,LVAR) C C THIS ROUTINE GETS A CONTINUE STATEMENT. C INTEGER NREAD,NWRITE,LVAR CHARACTER VAR(9*LVAR) CHARACTER EOF,EOL,EOS,EOT CHARACTER ADC(86),CARD(74),CON(10) CHARACTER*17 TABLE(3) CHARACTER*70 ERRM INTEGER COL,COMP,CONFLG,I,IG,IJ,J,JFLG,LASTCH,MATCH,NEXTCH, * OUTP,SENTNL COMMON /IMAGE/ CARD COMMON /ENDSYM/ EOF,EOL,EOS,EOT COMMON /COUNTS/ COL,LASTCH,NEXTCH COMMON /FLAGS/ OUTP,SENTNL,JFLG,CONFLG COMMON /XCHAR/ ADC DATA TABLE /'JACOB@','GRAD@','0'/ DATA ERRM /' CONSTRUCT STATEMENT ERROR'/ DATA CON /'C','O','N','S','T','R','U','C','T','@'/ 10 CONTINUE IF (SENTNL .EQ. -1) THEN LASTCH = 199 NEXTCH = LASTCH VAR(4*LVAR+NEXTCH) = EOF GO TO 20 ELSE CALL GETCRD(NREAD) IF (CARD(1) .EQ. ADC(56)) THEN IF (MATCH(CARD,CON) .NE. 1) GO TO 10 CONFLG = 1 I = 9 J = 0 15 CONTINUE I = I + 1 IF (I .GT. 72) CALL ERRORM(ERRM,NWRITE) IF (CARD(I) .NE. ADC(38)) GO TO 15 J = J + 1 IF (J .LT. 3) GO TO 15 CARD(I) = ADC(22) IJ = COMP(CARD(I-5),TABLE) IG = COMP(CARD(I-4),TABLE) IF ((IJ .LT. 0) .AND. (IG .LT. 0)) CALL ERRORM(ERRM,NWRITE) CARD(I) = ADC(38) CALL USECRD(1,VAR,LVAR,NWRITE) GO TO 20 ELSE IF (CARD(6) .NE. ADC(32)) THEN CALL USECRD(7,VAR,LVAR,NWRITE) GO TO 30 END IF END IF CALL GETSTM(NREAD,NWRITE,VAR,LVAR) 20 CONTINUE NEXTCH = NEXTCH - 1 VAR(4*LVAR+NEXTCH) = EOL 30 CONTINUE RETURN C C LAST CARD OF SUBROUTINE GETCON. C END C******************************************************************* SUBROUTINE HOLERH(C,NREAD,NWRITE,VAR,LVAR) C C THIS ROUTINE CONVERTS A HOLLERITH STRING INTO A QUOTED STRING. C INTEGER NREAD,NWRITE,LVAR CHARACTER C,VAR(9*LVAR) CHARACTER EOF,EOL,EOS,EOT CHARACTER ADC(86) INTEGER ADDR,COL,K,L,LASTCH,LENGTH,NEXTCH INTEGER AD(86) COMMON /ENDSYM/ EOF,EOL,EOS,EOT COMMON /COUNTS/ COL,LASTCH,NEXTCH COMMON /XCHAR/ ADC COMMON /ZCHAR/ AD LENGTH = 0 K = 1 10 CONTINUE IF (VAR(6*LVAR+K) .NE. ADC(22) ) THEN LENGTH = 10*LENGTH + ADDR(VAR(6*LVAR+K)) - AD(20) K = K + 1 GO TO 10 END IF IF (LENGTH .GT. 256) LENGTH = 256 VAR(6*LVAR+1) = ADC(42) L = 2 NEXTCH = NEXTCH + 1 IF (NEXTCH .GT. LASTCH) CALL GETCON(NREAD,NWRITE,VAR,LVAR) DO 30 K = 1, LENGTH C = VAR(4*LVAR+NEXTCH) IF ((C .EQ. ADC(42)) .OR. (C .EQ. EOL)) THEN VAR(6*LVAR+L) = ADC(32) GO TO 20 END IF IF (C .EQ. EOT) GO TO 40 VAR(6*LVAR+L) = C 20 CONTINUE L = L + 1 NEXTCH = NEXTCH + 1 IF (NEXTCH .GT. LASTCH) CALL GETCON(NREAD,NWRITE,VAR,LVAR) 30 CONTINUE 40 CONTINUE VAR(6*LVAR+L) = ADC(42) L = L + 1 VAR(6*LVAR+L) = ADC(22) C = ADC(4) RETURN C C LAST CARD OF SUBROUTINE HOLERH. C END C***************************************************************** SUBROUTINE KEYWDS(BUFERP,RFORT,NWRITE,VAR,LVAR) C C UPON ENTERING THIS ROUTINE A STATEMENT HAS BEEN FOUND TO BEGIN C WITH A KEYWORD. THIS KEYWORD MUST BE IDENTIFIED, PUT IN LOWER C CASE, AND SEPARATED BY A BLANK FROM SUBSEQUENT TOKENS. THEN, C DEPENDING ON THE KEYWORD, DIFFERENT WAYS OF SCANNING MUST BE C PERFORMED. C INTEGER BUFERP,RFORT,NWRITE,LVAR CHARACTER VAR(9*LVAR) CHARACTER ACHAR,C,EOF,EOL,EOS,EOT CHARACTER ADC(86) CHARACTER*16 KEYWD1(45) CHARACTER*17 KEYWD2(52),PRDLST(14) CHARACTER*70 ERRM INTEGER ADDR,FLAG,I,IADD,J,LOOKUP INTEGER AD(86) COMMON /ENDSYM/ EOF,EOL,EOS,EOT COMMON /KEY/ KEYWD1,KEYWD2,PRDLST COMMON /XCHAR/ ADC COMMON /ZCHAR/ AD DATA ERRM /' UNRECOGNIZED KEYWORD'/ I = LOOKUP(BUFERP,VAR,LVAR) IF (I .EQ. (-1)) CALL ERRORM(ERRM,NWRITE) J = 1 10 CONTINUE C = KEYWD1(I) (J:16) IF (C .NE. ADC(22)) THEN CALL EMIT(C,RFORT,VAR,LVAR) BUFERP = BUFERP + 1 J = J + 1 GO TO 10 END IF IF (I .NE. 5) CALL EMIT(ADC(32),RFORT,VAR,LVAR) IF (I .EQ. 22) THEN 20 CONTINUE C = VAR(5*LVAR+BUFERP) IF (C .EQ. ADC(22)) GO TO 90 IADD = ADDR(C) IF ((IADD .GE. AD(16)) .AND. (IADD .LE. AD(19))) THEN IADD = IADD - AD(16) + AD(7) CALL EMIT(ACHAR(IADD),RFORT,VAR,LVAR) GO TO 40 END IF IF (C .EQ. ADC(38)) THEN 30 CONTINUE C C COPY UNTIL A RIGHT PARENTHESIS (NO NESTING) IS ENCOUNTERED. C IF ((C .NE. ADC(39)) .AND. (C .NE. ADC(22))) THEN CALL EMIT(C,RFORT,VAR,LVAR) BUFERP = BUFERP + 1 C = VAR(5*LVAR+BUFERP) GO TO 30 END IF IF (C .EQ. ADC(39)) CALL EMIT(C,RFORT,VAR,LVAR) GO TO 40 END IF CALL EMIT(C,RFORT,VAR,LVAR) 40 CONTINUE BUFERP = BUFERP + 1 GO TO 20 END IF C = VAR(5*LVAR+BUFERP) C C THIS ASTERISK MAY BE A LENGTH QUALIFIER. THE LENGTH MUST BE C REGARDED AS AN INTEGER EVEN IF FOLLOWED BY AN E OR A D. C IF (C .EQ. ADC(25)) THEN CALL EMIT(C,RFORT,VAR,LVAR) 45 CONTINUE BUFERP = BUFERP + 1 C = VAR(5*LVAR+BUFERP) IADD = ADDR(C) IF ((IADD .GE. AD(20)) .AND. (IADD .LE. AD(21))) THEN CALL EMIT(C,RFORT,VAR,LVAR) GO TO 45 END IF CALL EMIT(ADC(32),RFORT,VAR,LVAR) GO TO 90 END IF IF (I .NE. 9) GO TO 90 FLAG = 2 GO TO 60 50 CONTINUE BUFERP = BUFERP + 1 60 CONTINUE C = VAR(5*LVAR+BUFERP) 70 CONTINUE IF (C .EQ. ADC(22)) GO TO 90 IF ((C .EQ. ADC(50)) .AND. (FLAG .GT. 0)) THEN C C DELETE PARTIAL SIGNS. C BUFERP = BUFERP + 1 C = VAR(5*LVAR+BUFERP) IF (C .NE. ADC(38)) THEN C C THIS D WAS NOT A PARTIAL. C CALL EMIT(ADC(10),RFORT,VAR,LVAR) GO TO 70 END IF C C COPY UNTIL A MATCHING RIGHT PARENTHESIS IS ENCOUNTERED. C FLAG = FLAG - 1 80 CONTINUE IF ((C .NE. ADC(39)) .AND. (C .NE. ADC(22))) THEN CALL EMIT(C,RFORT,VAR,LVAR) BUFERP = BUFERP + 1 C = VAR(5*LVAR+BUFERP) GO TO 80 END IF IF (C .EQ. ADC(39)) THEN CALL EMIT(C,RFORT,VAR,LVAR) BUFERP = BUFERP + 1 C = VAR(5*LVAR+BUFERP) END IF IF (C .EQ. ADC(26)) GO TO 50 IF (C .NE. ADC(52)) GO TO 70 BUFERP = BUFERP + 1 C = VAR(5*LVAR+BUFERP) IF (C .EQ. ADC(47)) GO TO 50 CALL EMIT(ADC(13),RFORT,VAR,LVAR) GO TO 70 END IF CALL EMIT(C,RFORT,VAR,LVAR) GO TO 50 90 CONTINUE IF ((I .EQ. 5) .AND. (C .EQ. ADC(38))) THEN CALL EMIT(ADC(20),RFORT,VAR,LVAR) CALL EMIT(ADC(32),RFORT,VAR,LVAR) BUFERP = BUFERP + 3 END IF 100 CONTINUE C = VAR(5*LVAR+BUFERP) IF (C .NE. ADC(22)) THEN CALL EMIT(C,RFORT,VAR,LVAR) BUFERP = BUFERP + 1 GO TO 100 END IF CALL EMIT(EOL,RFORT,VAR,LVAR) RETURN C C LAST CARD OF SUBROUTINE KEYWDS. C END C******************************************************************* INTEGER FUNCTION LOOKUP(BUFERP,VAR,LVAR) C C THIS ROUTINE ATTEMPTS TO IDENTIFY A KEYWORD IN THE STATEMENT C BUFFER. C INTEGER BUFERP,LVAR CHARACTER VAR(9*LVAR) CHARACTER ACHAR,C CHARACTER ADC(86) CHARACTER*16 KEYWD1(45) CHARACTER*17 KEYWD2(52),PRDLST(14) INTEGER ADDR,J,K INTEGER AD(86) COMMON /KEY/ KEYWD1,KEYWD2,PRDLST COMMON /XCHAR/ ADC COMMON /ZCHAR/ AD LOOKUP = 1 10 CONTINUE IF (KEYWD1(LOOKUP) .NE. ADC(20)) THEN J = 0 20 CONTINUE J = J + 1 C = KEYWD1(LOOKUP) (J:16) IF (C .NE. ADC(22)) THEN K = ADDR(C) - AD(7) + AD(16) C = ACHAR(K) END IF IF ((C .EQ. VAR(5*LVAR+BUFERP+J-1)) .AND. (C .NE. ADC(22))) * GO TO 20 IF (C .EQ. ADC(22)) GO TO 30 LOOKUP = LOOKUP + 1 GO TO 10 END IF LOOKUP = -1 30 CONTINUE RETURN C C LAST CARD OF INTEGER FUNCTION LOOKUP. C END C******************************************************************* INTEGER FUNCTION MATCH(STRING,SUBSTR) C C THIS ROUTINE TESTS WHETHER "SUBSTR" IS A SUB-STRING OF "STRING". C CHARACTER STRING(*),SUBSTR(*) CHARACTER ADC(86) INTEGER I COMMON /XCHAR/ ADC I = 0 MATCH = 0 10 CONTINUE I = I + 1 IF (STRING(I) .EQ. SUBSTR(I)) GO TO 10 IF (SUBSTR(I) .EQ. ADC(22)) MATCH = 1 RETURN C C LAST CARD OF INTEGER FUNCTION MATCH. C END C****************************************************************** SUBROUTINE SCAN(RFORT,NREAD,NWRITE,VAR,LVAR) C C THIS ROUTINE SCANS A SINGLE STATEMENT AND FINDS KEYWORDS. C INTEGER RFORT,NREAD,NWRITE,LVAR CHARACTER VAR(9*LVAR) CHARACTER C,EOF,EOL,EOS,EOT CHARACTER ADC(86) CHARACTER*70 ERRM INTEGER BUFERP,I,K,RESTRP,TEMP,TRYART,TRYASG,TRYDO COMMON /ENDSYM/ EOF,EOL,EOS,EOT COMMON /XCHAR/ ADC DATA ERRM /' FORTRAN STATEMENT EXCEEDS CHARACTER LIMIT'/ BUFERP = 1 10 CONTINUE CALL SCAN1(C,NREAD,NWRITE,VAR,LVAR) IF ((C .NE. EOL) .AND. (C .NE. EOF)) THEN I = 1 20 CONTINUE IF (VAR(6*LVAR+I) .NE. ADC(22)) THEN VAR(5*LVAR+BUFERP) = VAR(6*LVAR+I) BUFERP = BUFERP + 1 IF (BUFERP .GT. LVAR) CALL ERRORM(ERRM,NWRITE) I = I + 1 GO TO 20 END IF GO TO 10 END IF VAR(5*LVAR+BUFERP) = ADC(22) BUFERP = 1 RESTRP = 1 CALL SKIPLB(BUFERP,RESTRP,RFORT,VAR,LVAR) BUFERP = RESTRP TEMP = RESTRP CALL IFTLSE(BUFERP,RESTRP,RFORT,VAR,LVAR) IF (VAR(5*LVAR+RESTRP) .EQ. ADC(22)) GO TO 30 RESTRP = TEMP BUFERP = RESTRP CALL SKIPIF(BUFERP,RESTRP,RFORT,VAR,LVAR) IF (VAR(5*LVAR+RESTRP) .EQ. ADC(22)) GO TO 30 BUFERP = RESTRP K = TRYDO(BUFERP,RESTRP,RFORT,VAR,LVAR) IF (K .EQ. 1) GO TO 30 BUFERP = RESTRP K = TRYASG(BUFERP,RESTRP,RFORT,VAR,LVAR) IF (K .EQ. 1) GO TO 30 BUFERP = RESTRP K = TRYART(BUFERP,RESTRP,RFORT,VAR,LVAR) IF (K .EQ. 1) GO TO 30 BUFERP = RESTRP CALL KEYWDS(BUFERP,RFORT,NWRITE,VAR,LVAR) 30 CONTINUE RETURN C C LAST CARD OF SUBROUTINE SCAN. C END C**************************************************************************** SUBROUTINE IFTLSE(BUFERP,RESTRP,RFORT,VAR,LVAR) C C THIS ROUTINE PROCESSES "IF BLOCK" STATEMENTS. C INTEGER BUFERP,RESTRP,RFORT,LVAR CHARACTER VAR(9*LVAR) CHARACTER ACHAR,EOF,EOL,EOS,EOT CHARACTER ADC(86) LOGICAL AFLAG,BFLAG,CFLAG,LVFLAG INTEGER ALPHA,BETA,I,LEVEL INTEGER A(25),B(25),ID(5) COMMON /XCHAR/ ADC COMMON /CNUM/ ID COMMON /ENDSYM/ EOF,EOL,EOS,EOT COMMON /TRACK/ LEVEL COMMON /SGNL/ AFLAG,BFLAG,CFLAG,LVFLAG IF ((VAR(5*LVAR+BUFERP) .EQ. ADC(52)) .AND. * (VAR(5*LVAR+BUFERP+1) .EQ. ADC(17)) .AND. * (VAR(5*LVAR+BUFERP+2) .EQ. ADC(38))) THEN BUFERP = BUFERP + 2 CALL BALNCR(BUFERP,VAR,LVAR) IF (VAR(5*LVAR+BUFERP) .NE. ADC(31)) THEN IF ((VAR(5*LVAR+BUFERP) .EQ. ADC(18)) .AND. * (VAR(5*LVAR+BUFERP+1) .EQ. ADC(58)) .AND. * (VAR(5*LVAR+BUFERP+2) .EQ. ADC(44)) .AND. * (VAR(5*LVAR+BUFERP+3) .EQ. ADC(47))) THEN C C "IF (expr) THEN" STATEMENT HAS BEEN ENCOUNTERED. C IF (.NOT. LVFLAG) THEN ALPHA = 69999 BETA = 79999 LVFLAG = .TRUE. END IF LEVEL = LEVEL + 1 AFLAG = .TRUE. BFLAG = .FALSE. ALPHA = ALPHA + 1 BETA = BETA + 1 A(LEVEL) = ALPHA B(LEVEL) = BETA C C EMIT "IF ( NOT (expr)) GO TO A(LEVEL)". C CALL STCR(A(LEVEL)) CALL IFNOT(BUFERP,RESTRP,RFORT,VAR,LVAR) RESTRP = BUFERP + 4 GO TO 20 END IF END IF END IF IF ((VAR(5*LVAR+BUFERP) .EQ. ADC(44)) .AND. * (VAR(5*LVAR+BUFERP+1) .EQ. ADC(48)) .AND. * (VAR(5*LVAR+BUFERP+2) .EQ. ADC(75)) .AND. * (VAR(5*LVAR+BUFERP+3) .EQ. ADC(44))) THEN C C "ELSE" STATEMENT HAS BEEN ENCOUNTERED. C AFLAG = .FALSE. BFLAG = .TRUE. IF (.NOT. CFLAG) THEN C C EMIT "GO TO B(LEVEL)". C CALL STCR(B(LEVEL)) CALL EMIT(ADC(12),RFORT,VAR,LVAR) CALL EMIT(ADC(14),RFORT,VAR,LVAR) CALL EMIT(ADC(8),RFORT,VAR,LVAR) CALL EMIT(ADC(14),RFORT,VAR,LVAR) CALL EMIT(ADC(32),RFORT,VAR,LVAR) DO 10 I = 1, 5 CALL EMIT(ACHAR(ID(I)+48),RFORT,VAR,LVAR) 10 CONTINUE CALL EMIT(EOL,RFORT,VAR,LVAR) END IF C C EMIT "A(LEVEL) CONTINUE". C CALL STCR(A(LEVEL)) CALL NCON(RFORT,VAR,LVAR) BUFERP = BUFERP + 4 RESTRP = BUFERP IF ((VAR(5*LVAR+BUFERP) .EQ. ADC(52)) .AND. * (VAR(5*LVAR+BUFERP+1) .EQ. ADC(17))) THEN C C "ELSE IF(expr) THEN" STATEMENT HAS BEEN ENCOUNTERED. C ALPHA = ALPHA + 1 A(LEVEL) = ALPHA BUFERP = BUFERP + 2 CALL BALNCR(BUFERP,VAR,LVAR) C C EMIT "IF ( NOT (expr)) GO TO A(LEVEL)". C CALL STCR(A(LEVEL)) CALL IFNOT(BUFERP,RESTRP,RFORT,VAR,LVAR) END IF GO TO 20 END IF IF ((VAR(5*LVAR+BUFERP) .EQ. ADC(44)) .AND. * (VAR(5*LVAR+BUFERP+1) .EQ. ADC(47)) .AND. * (VAR(5*LVAR+BUFERP+2) .EQ. ADC(50)) .AND. * (VAR(5*LVAR+BUFERP+3) .EQ. ADC(52)) .AND. * (VAR(5*LVAR+BUFERP+4) .EQ. ADC(17))) THEN C C AN "ENDIF" STATEMENT HAS BEEN ENCOUNTERED. C EMIT "ALPHA(LEVEL)" or "BETA(LEVEL) CONTINUE". C IF (AFLAG) CALL STCR(A(LEVEL)) IF (BFLAG) CALL STCR(B(LEVEL)) CALL NCON(RFORT,VAR,LVAR) LEVEL = LEVEL - 1 RESTRP = BUFERP + 5 END IF 20 CONTINUE CFLAG = .FALSE. IF ((VAR(5*LVAR+BUFERP) .EQ. ADC(46)) .AND. * (VAR(5*LVAR+BUFERP+1) .EQ. ADC(57)) .AND. * (VAR(5*LVAR+BUFERP+2) .EQ. ADC(18)) .AND. * (VAR(5*LVAR+BUFERP+3) .EQ. ADC(57))) THEN C C A "GO TO" STATEMENT HAS BEEN ENCOUNTERED. C CFLAG = .TRUE. END IF BUFERP = RESTRP RETURN C C LAST CARD OF SUBROUTINE IFTLSE. C END C ******************************************************************** SUBROUTINE STCR(INO) C C THIS ROUTINE PROCESSES STATEMENT NUMBERS. C INTEGER INO,INOT INTEGER ID(5) COMMON /CNUM/ ID ID(1) = INO/10000 INOT = INO - ID(1)*10000 ID(2) = INOT/1000 INOT = INOT - ID(2)*1000 ID(3) = INOT/100 INOT = INOT - ID(3)*100 ID(4) = INOT/10 ID(5) = INOT - ID(4)*10 RETURN C C LAST CARD OF SUBROUTINE STCR. C END C ******************************************************************** SUBROUTINE IFNOT(BUFERP,RESTRP,RFORT,VAR,LVAR) C C THIS ROUTINE EMITS "IF ( NOT (expr)) GOTO XXXX%". C INTEGER BUFERP,RESTRP,RFORT,LVAR CHARACTER VAR(9*LVAR) INTEGER I,ID(5) CHARACTER ADC(86) CHARACTER ACHAR,EOF,EOL,EOS,EOT COMMON /XCHAR/ ADC COMMON /CNUM/ ID COMMON /ENDSYM/ EOF,EOL,EOS,EOT CALL EMIT(ADC(13),RFORT,VAR,LVAR) CALL EMIT(ADC(11),RFORT,VAR,LVAR) CALL EMIT(ADC(32),RFORT,VAR,LVAR) CALL EMIT(ADC(38),RFORT,VAR,LVAR) CALL EMIT(ADC(32),RFORT,VAR,LVAR) CALL EMIT(ADC(62),RFORT,VAR,LVAR) CALL EMIT(ADC(14),RFORT,VAR,LVAR) CALL EMIT(ADC(8),RFORT,VAR,LVAR) CALL EMIT(ADC(32),RFORT,VAR,LVAR) RESTRP = RESTRP + 2 10 CONTINUE IF (RESTRP .LT. BUFERP) THEN CALL EMIT(VAR(5*LVAR+RESTRP),RFORT,VAR,LVAR) RESTRP = RESTRP + 1 GO TO 10 END IF CALL EMIT(ADC(39),RFORT,VAR,LVAR) CALL EMIT(ADC(12),RFORT,VAR,LVAR) CALL EMIT(ADC(14),RFORT,VAR,LVAR) CALL EMIT(ADC(8),RFORT,VAR,LVAR) CALL EMIT(ADC(14),RFORT,VAR,LVAR) CALL EMIT(ADC(32),RFORT,VAR,LVAR) DO 20 I = 1, 5 CALL EMIT(ACHAR(ID(I)+48),RFORT,VAR,LVAR) 20 CONTINUE CALL EMIT(EOL,RFORT,VAR,LVAR) RESTRP = RESTRP + 4 RETURN C C LAST CARD OF SUBROUTINE IFNOT. C END C ********************************************************************* SUBROUTINE NCON(RFORT,VAR,LVAR) C C THIS ROUTINE EMITS ":XXXX CONTINUE %". C INTEGER RFORT,LVAR CHARACTER VAR(9*LVAR) CHARACTER ADC(86) CHARACTER ACHAR,C,EOF,EOL,EOS,EOT INTEGER I,ID(5) CHARACTER*16 KEYWD1(45) CHARACTER*17 KEYWD2(52),PRDLST(14) COMMON /CNUM/ ID COMMON /KEY/ KEYWD1,KEYWD2,PRDLST COMMON /ENDSYM/ EOF,EOL,EOS,EOT COMMON /XCHAR/ ADC CALL EMIT(ADC(28),RFORT,VAR,LVAR) CALL EMIT(ACHAR(ID(1)+48),RFORT,VAR,LVAR) CALL EMIT(ACHAR(ID(2)+48),RFORT,VAR,LVAR) CALL EMIT(ACHAR(ID(3)+48),RFORT,VAR,LVAR) CALL EMIT(ACHAR(ID(4)+48),RFORT,VAR,LVAR) CALL EMIT(ACHAR(ID(5)+48),RFORT,VAR,LVAR) CALL EMIT(ADC(32),RFORT,VAR,LVAR) DO 10 I = 1, 8 C = KEYWD1(10) (I:16) CALL EMIT(C,RFORT,VAR,LVAR) 10 CONTINUE CALL EMIT(ADC(32),RFORT,VAR,LVAR) CALL EMIT(EOL,RFORT,VAR,LVAR) RETURN C C LAST CARD OF SUBROUTINE NCON. C END C******************************************************************* SUBROUTINE SKIPIF(BUFERP,RESTRP,RFORT,VAR,LVAR) C C THIS ROUTINE REMOVES AN IF(EXPR) PREFIX IF PRESENT. THE IF(EXPR) C BY ITSELF IS CONSIDERED A STATEMENT. THUS AN EOL IS INSERTED C AFTER THE RIGHT PARENTHESIS. C C AN IF STATEMENT IS CHARACTERIZED BY THE PREFIX "IF(", AND BY C THE APPEARANCE OF A CHARACTER OTHER THAN "=" FOLLOWING THE C RIGHT PARENTHESIS OF THE IF(EXPR). C INTEGER BUFERP,RESTRP,RFORT,LVAR CHARACTER VAR(9*LVAR) CHARACTER C CHARACTER ADC(86) COMMON /XCHAR/ ADC IF (VAR(5*LVAR+BUFERP) .EQ. ADC(52)) THEN BUFERP = BUFERP + 1 C = VAR(5*LVAR+BUFERP) IF (C .EQ. ADC(17)) THEN BUFERP = BUFERP + 1 C = VAR(5*LVAR+BUFERP) IF (C .EQ. ADC(38)) THEN CALL BALNCR(BUFERP,VAR,LVAR) IF (VAR(5*LVAR+BUFERP) .NE. ADC(31)) THEN C C A GENUINE IF STATEMENT HAS BEEN ENCOUNTERED. C CALL EMIT(ADC(13),RFORT,VAR,LVAR) CALL EMIT(ADC(11),RFORT,VAR,LVAR) CALL EMIT(ADC(32),RFORT,VAR,LVAR) RESTRP = RESTRP + 2 10 CONTINUE IF (RESTRP .LT. BUFERP) THEN CALL EMIT(VAR(5*LVAR+RESTRP),RFORT,VAR,LVAR) RESTRP = RESTRP + 1 GO TO 10 END IF END IF END IF END IF END IF BUFERP = RESTRP RETURN C C LAST CARD OF SUBROUTINE SKIPIF. C END C******************************************************************** SUBROUTINE SKIPLB(BUFERP,RESTRP,RFORT,VAR,LVAR) C C THIS ROUTINE REMOVES A LABEL PREFIX, IF PRESENT. C INTEGER BUFERP,RESTRP,RFORT,LVAR CHARACTER VAR(9*LVAR) CHARACTER ADC(86) COMMON /XCHAR/ ADC IF (VAR(5*LVAR+BUFERP) .EQ. ADC(28)) THEN CALL EMIT(ADC(28),RFORT,VAR,LVAR) 10 CONTINUE BUFERP = BUFERP + 1 IF (VAR(5*LVAR+BUFERP) .NE. ADC(28)) THEN CALL EMIT(VAR(5*LVAR+BUFERP),RFORT,VAR,LVAR) GO TO 10 END IF CALL EMIT(ADC(32),RFORT,VAR,LVAR) BUFERP = BUFERP + 1 RESTRP = BUFERP END IF RETURN C C LAST CARD OF SUBROUTINE SKIPLB. C END C******************************************************************** SUBROUTINE SKPSTR(BUFERP,VAR,LVAR) C C IF BUFERP POINTS AT THE LEFT QUOTE OF A STRING, THIS ROUTINE SKIPS C OVER THE ENTIRE STRING. ON RETURN, BUFERP POINTS AT THE RIGHT C QUOTE OF THE STRING. C INTEGER BUFERP,LVAR CHARACTER VAR(9*LVAR) CHARACTER C,EOF,EOL,EOS,EOT CHARACTER ADC(86) COMMON /ENDSYM/ EOF,EOL,EOS,EOT COMMON /XCHAR/ ADC 10 CONTINUE BUFERP = BUFERP + 1 C = VAR(5*LVAR+BUFERP) IF (C .NE. ADC(42)) THEN IF (C .EQ. EOL) BUFERP = BUFERP + 1 GO TO 10 END IF RETURN C C LAST CARD OF SUBROUTINE SKPSTR. C END C****************************************************************** SUBROUTINE TRFORM(BUF) C C THIS ROUTINE REPLACES ALL OCCURRENCES OF .GT. ,ETC. BY GT ,ETC. C CHARACTER BUF(*) CHARACTER ACHAR,C,EOF,EOL,EOS,EOT CHARACTER ADC(86) INTEGER ADDR,I,IADD,INP,MARK INTEGER AD(86) COMMON /ENDSYM/ EOF,EOL,EOS,EOT COMMON /XCHAR/ ADC COMMON /ZCHAR/ AD INP = 0 10 CONTINUE INP = INP + 1 C = BUF(INP) 20 CONTINUE IF (C .NE. EOS) THEN IF (C .EQ. ADC(42)) THEN 30 CONTINUE INP = INP + 1 C = BUF(INP) IF (C .NE. ADC(42)) THEN IF (C .NE. EOL) GO TO 30 INP = INP + 1 C = BUF(INP) GO TO 30 END IF ELSE IF (C .EQ. ADC(29)) THEN MARK = INP + 1 40 CONTINUE INP = INP + 1 C = BUF(INP) IADD = ADDR(C) IF ((IADD .GE. AD(16)) .AND. (IADD .LE. AD(19))) * GO TO 40 IF ((C .NE. ADC(29)) .OR. (INP .LE. MARK)) GO TO 20 BUF(INP) = ADC(32) I = INP 50 CONTINUE I = I - 1 IF (BUF(I) .NE. ADC(29)) THEN IADD = ADDR(BUF(I)) - AD(16) + AD(7) BUF(I) = ACHAR(IADD) GO TO 50 END IF BUF(I) = ADC(32) END IF GO TO 10 END IF RETURN C C LAST CARD OF SUBROUTINE TRFORM. C END C******************************************************************** INTEGER FUNCTION TRYDO(BUFERP,RESTRP,RFORT,VAR,LVAR) C C THIS ROUTINE RETURNS 1 IF A GENUINE DO-STATEMENT IS ENCOUNTERED. C THE DO-STATEMENT IS EMITTED WITH PROPER LEXICOGRAPHICAL C SEPARATION. C CHARACTER VAR(9*LVAR) INTEGER BUFERP,RESTRP,RFORT,LVAR CHARACTER ACHAR,ASGNFL,C,EOF,EOL,EOS,EOT CHARACTER ADC(86),BUF(3,65) INTEGER ADDR,I,IADD,J,L,LNESTA,LNESTB,XESTRP INTEGER AD(86),LXA(3),LXB(3) COMMON /ENDSYM/ EOF,EOL,EOS,EOT COMMON /XCHAR/ ADC COMMON /ZCHAR/ AD COMMON /NEST/ LNESTA,LNESTB IF (VAR(5*LVAR+BUFERP) .EQ. ADC(50)) THEN BUFERP = BUFERP + 1 C = VAR(5*LVAR+BUFERP) IF (C .EQ. ADC(57)) THEN ASGNFL = ADC(32) 10 CONTINUE BUFERP = BUFERP + 1 C = VAR(5*LVAR+BUFERP) IF (C .NE. ADC(22)) THEN IF (C .EQ. ADC(30)) THEN IF (ASGNFL .NE. ADC(31)) GO TO 90 C C THIS IS A REAL DO-LOOP. C I = 1 20 CONTINUE J = 1 30 CONTINUE IF ((VAR(5*LVAR+XESTRP) .NE. ADC(30)) .AND. * (VAR(5*LVAR+XESTRP) .NE. ADC(22))) THEN BUF(I,J) = VAR(5*LVAR+XESTRP) XESTRP = XESTRP + 1 J = J + 1 GO TO 30 END IF BUF(I,J) = ADC(22) I = I + 1 XESTRP = XESTRP + 1 IF (VAR(5*LVAR+XESTRP-1) .NE. ADC(22)) GO TO 20 L = I - 1 DO 50 I = 1, L J = 1 LXA(I) = LNESTA LXB(I) = LNESTB CALL EMIT(ADC(48),RFORT,VAR,LVAR) CALL EMIT(ADC(74),RFORT,VAR,LVAR) CALL EMIT(ACHAR(LNESTA+48),RFORT,VAR,LVAR) CALL EMIT(ACHAR(LNESTB+48),RFORT,VAR,LVAR) CALL EMIT(ADC(31),RFORT,VAR,LVAR) LNESTB = LNESTB + 1 IF (LNESTB .GT. 9) THEN LNESTA = LNESTA + 1 IF (LNESTA .GT. 9) LNESTA = 0 LNESTB = 0 END IF 40 CONTINUE IF (BUF(I,J) .NE. ADC(22)) THEN CALL EMIT(BUF(I,J),RFORT,VAR,LVAR) J = J + 1 GO TO 40 END IF CALL EMIT(EOL,RFORT,VAR,LVAR) 50 CONTINUE CALL EMIT(ADC(10),RFORT,VAR,LVAR) CALL EMIT(ADC(14),RFORT,VAR,LVAR) CALL EMIT(ADC(32),RFORT,VAR,LVAR) RESTRP = RESTRP + 2 60 CONTINUE IADD = ADDR(VAR(5*LVAR+RESTRP)) IF ((IADD .GE. AD(20)) .AND. (IADD .LE. AD(21))) THEN CALL EMIT(VAR(5*LVAR+RESTRP),RFORT,VAR,LVAR) RESTRP = RESTRP + 1 GO TO 60 END IF CALL EMIT(ADC(32),RFORT,VAR,LVAR) 70 CONTINUE IF (VAR(5*LVAR+RESTRP) .NE. ADC(31)) THEN CALL EMIT(VAR(5*LVAR+RESTRP),RFORT,VAR,LVAR) RESTRP = RESTRP + 1 GO TO 70 END IF CALL EMIT(VAR(5*LVAR+RESTRP),RFORT,VAR,LVAR) CALL EMIT(ADC(48),RFORT,VAR,LVAR) CALL EMIT(ADC(74),RFORT,VAR,LVAR) CALL EMIT(ACHAR(LXA(1)+48),RFORT,VAR,LVAR) CALL EMIT(ACHAR(LXB(1)+48),RFORT,VAR,LVAR) CALL EMIT(ADC(30),RFORT,VAR,LVAR) CALL EMIT(ADC(48),RFORT,VAR,LVAR) CALL EMIT(ADC(74),RFORT,VAR,LVAR) CALL EMIT(ACHAR(LXA(2)+48),RFORT,VAR,LVAR) CALL EMIT(ACHAR(LXB(2)+48),RFORT,VAR,LVAR) IF (L .EQ. 3) THEN CALL EMIT(ADC(30),RFORT,VAR,LVAR) CALL EMIT(ADC(48),RFORT,VAR,LVAR) CALL EMIT(ADC(74),RFORT,VAR,LVAR) CALL EMIT(ACHAR(LXA(3)+48),RFORT,VAR,LVAR) CALL EMIT(ACHAR(LXB(3)+48),RFORT,VAR,LVAR) END IF CALL EMIT(EOL,RFORT,VAR,LVAR) TRYDO = 1 GO TO 100 END IF IF (C .EQ. ADC(31)) THEN ASGNFL = C XESTRP = BUFERP + 1 GO TO 10 END IF IF (C .EQ. ADC(42)) GO TO 90 IF (C .NE. ADC(38)) GO TO 10 END IF END IF END IF 90 CONTINUE TRYDO = 0 100 CONTINUE RETURN C C LAST CARD OF INTEGER FUNCTION TRYDO. C END C********************************************************************* INTEGER FUNCTION TRYART(BUFERP,RESTRP,RFORT,VAR,LVAR) C C THIS ROUTINE TESTS FOR AN ARITHMETIC IF. REMEMBER, THE "IF(EXPR)" C PART HAS ALREADY BEEN SEPARATED. THUS ALL WE NEED DO IS TEST FOR C A DIGIT AS THE FIRST CHARACTER. C INTEGER BUFERP,RESTRP,RFORT,LVAR CHARACTER VAR(9*LVAR) CHARACTER C,EOF,EOL,EOS,EOT CHARACTER ADC(86) INTEGER ADDR,IADD INTEGER AD(86) COMMON /ENDSYM/ EOF,EOL,EOS,EOT COMMON /XCHAR/ ADC COMMON /ZCHAR/ AD C = VAR(5*LVAR+BUFERP) IADD = ADDR(C) IF ((IADD .GE. AD(20)) .AND. (IADD .LE. AD(21))) THEN 10 CONTINUE IF (C .NE. ADC(22)) THEN CALL EMIT(C,RFORT,VAR,LVAR) BUFERP = BUFERP + 1 C = VAR(5*LVAR+BUFERP) GO TO 10 END IF CALL EMIT(EOT,RFORT,VAR,LVAR) TRYART = 1 GO TO 20 END IF TRYART = 0 20 CONTINUE RETURN C C LAST CARD OF INTEGER FUNCTION TRYART. C END C******************************************************************** INTEGER FUNCTION TRYASG(BUFERP,RESTRP,RFORT,VAR,LVAR) C C THIS ROUTINE RETURNS 1 IF THE STATEMENT IS A GENUINE STATEMENT. C IF SO, EMIT THE STATEMENT WITH PROPER LEXICOGRAPHICAL C SEPARATION. C INTEGER BUFERP,RESTRP,RFORT,LVAR CHARACTER VAR(9*LVAR) CHARACTER C,EOF,EOL,EOS,EOT CHARACTER ADC(86) COMMON /ENDSYM/ EOF,EOL,EOS,EOT COMMON /XCHAR/ ADC RESTRP = BUFERP 10 CONTINUE C = VAR(5*LVAR+BUFERP) IF (C .NE. ADC(22)) THEN IF (C .EQ. ADC(38)) THEN CALL BALNCR(BUFERP,VAR,LVAR) GO TO 10 END IF IF (C .EQ. ADC(31)) THEN 20 CONTINUE C C THIS IS A GENUINE ASSIGNMENT STATEMENT. C IF (VAR(5*LVAR+RESTRP) .NE. ADC(22)) THEN CALL EMIT(VAR(5*LVAR+RESTRP),RFORT,VAR,LVAR) RESTRP = RESTRP + 1 GO TO 20 END IF CALL EMIT(EOL,RFORT,VAR,LVAR) TRYASG = 1 GO TO 30 END IF IF (C .EQ. ADC(42)) THEN CALL SKPSTR(BUFERP,VAR,LVAR) BUFERP = BUFERP + 1 GO TO 10 END IF BUFERP = BUFERP + 1 GO TO 10 END IF TRYASG = 0 30 CONTINUE RETURN C C LAST CARD OF INTEGER FUNCTION TRYASG. C END C******************************************************************* SUBROUTINE USECRD(FROM,VAR,LVAR,NWRITE) C C THIS ROUTINE COPIES A CARD INTO BUFFER, STARTING AT COLUMN "FROM" C UP TO 72. C INTEGER FROM,LVAR,NWRITE CHARACTER VAR(9*LVAR) CHARACTER CARD(74) CHARACTER*70 ERRM INTEGER COL,LASTCH,NEXTCH COMMON /IMAGE/ CARD COMMON /COUNTS/ COL,LASTCH,NEXTCH DATA ERRM /' FORTRAN STATEMENT ARRAY INSUFFICIENCY'/ LASTCH = 199 NEXTCH = LASTCH + 1 IF (NEXTCH .GT. LVAR) CALL ERRORM(ERRM,NWRITE) DO 10 COL = 72, FROM, -1 NEXTCH = NEXTCH - 1 VAR(4*LVAR+NEXTCH) = CARD(COL) 10 CONTINUE RETURN C C LAST CARD OF SUBROUTINE USECRD. C END C****************************************************************** SUBROUTINE BALNCR(BUFERP,VAR,LVAR) C C THIS ROUTINE SKIPS OVER INPUT UNTIL A MATCHING RIGHT PARENTHESIS C IS ENCOUNTERED. BALNCR IS CALLED AFTER A LEFT PARENTHESIS HAS C BEEN SEEN. C BUFERP POINTS AT THE LEFT PARENTHESIS ON ENTRY, AND WILL POINT C JUST BEYOND THE RIGHT PARENTHESIS ON EXIT; IF THERE IS NO RIGHT C PARENTHESIS, IT WILL POINT TO EOS. C INTEGER BUFERP,LVAR CHARACTER VAR(9*LVAR) CHARACTER C CHARACTER ADC(86) INTEGER LEVEL COMMON /XCHAR/ ADC LEVEL = 1 10 CONTINUE BUFERP = BUFERP + 1 C = VAR(5*LVAR+BUFERP) IF ((C .NE. ADC(22)) .AND. (LEVEL .GT. 0)) THEN IF (C .EQ. ADC(42)) THEN CALL SKPSTR(BUFERP,VAR,LVAR) ELSE IF (C .EQ. ADC(38)) THEN LEVEL = LEVEL + 1 ELSE IF (C .EQ. ADC(39)) THEN LEVEL = LEVEL - 1 END IF GO TO 10 END IF C C STATEMENT IS NOT BALANCED. TO AVOID ERRORS IN LATER STAGES, C FORCE AN EXTRA RIGHT PARENTHESIS. C IF (LEVEL .GT. 0) THEN BUFERP = BUFERP - 1 20 CONTINUE IF (LEVEL .GT. 0) THEN VAR(5*LVAR+BUFERP) = ADC(39) BUFERP = BUFERP + 1 LEVEL = LEVEL - 1 GO TO 20 END IF VAR(5*LVAR+BUFERP) = ADC(22) END IF RETURN C C LAST CARD OF SUBROUTINE BALNCR. C END C**************************************************************** SUBROUTINE ERRORM(STR,NWRITE) C C THIS ROUTINE WRITES AN ERROR MESSAGE AND ABORTS. C CHARACTER*70 STR INTEGER NWRITE CHARACTER ADC(86) COMMON /XCHAR/ ADC WRITE (NWRITE,'('' FATAL ERROR IN JAKEF'')') WRITE (NWRITE,'(A70)') STR STOP C C LAST CARD OF SUBROUTINE ERRORM. C END C******************************************************************* SUBROUTINE GETSTM(NREAD,NWRITE,VAR,LVAR) C C THIS ROUTINE GETS A STATEMENT, SKIPPING ALL COMMENTS WHILE C RETAINING 'CONSTRUCT'. C INTEGER NREAD,NWRITE,LVAR CHARACTER VAR(9*LVAR) CHARACTER EOF,EOL,EOS,EOT CHARACTER ADC(86),CARD(74),CON(10) CHARACTER*17 TABLE(3) CHARACTER*70 ERRM1,ERRM2,ERRM3 INTEGER COL,CCOL,COMP,CONFLG,I,IG,IJ,J,JFLG,LASTCH,MATCH,NEXTCH, * OUTP,SENTNL COMMON /ENDSYM/ EOF,EOL,EOS,EOT COMMON /FLAGS/ OUTP,SENTNL,JFLG,CONFLG COMMON /IMAGE/ CARD COMMON /COUNTS/ COL,LASTCH,NEXTCH COMMON /XCHAR/ ADC DATA TABLE /'JACOB@','GRAD@','0'/ DATA ERRM1 /' CONSTRUCT STATEMENT ERROR'/ DATA ERRM2 /' FORTRAN STATEMENT ARRAY INSUFFICIENCY'/ DATA ERRM3 /' LEXICAL PREPROCESSING - NO CONTINUATION CARD EXPECTE *D HERE'/ DATA CON /'C','O','N','S','T','R','U','C','T','@'/ 10 CONTINUE IF ((CARD(1) .EQ. ADC(56)) .OR. (CARD(1) .EQ. ADC(25))) THEN IF (MATCH(CARD,CON) .EQ. 1) THEN CONFLG = 1 I = 9 J = 0 15 CONTINUE I = I + 1 IF (I .GT. 72) CALL ERRORM(ERRM1,NWRITE) IF (CARD(I) .NE. ADC(38)) GO TO 15 J = J + 1 IF (J .LT. 3) GO TO 15 CARD(I) = ADC(22) IJ = COMP(CARD(I-5),TABLE) IG = COMP(CARD(I-4),TABLE) IF ((IJ .LT. 0) .AND. (IG .LT. 0)) CALL ERRORM(ERRM1,NWRITE) CARD(I) = ADC(38) CALL USECRD(1,VAR,LVAR,NWRITE) GO TO 40 ELSE IF (SENTNL .EQ. -1) THEN LASTCH = 199 NEXTCH = LASTCH IF (NEXTCH .GT. LVAR) CALL ERRORM(ERRM2,NWRITE) VAR(4*LVAR+NEXTCH) = EOF GO TO 40 ELSE CALL GETCRD(NREAD) GO TO 10 END IF END IF IF (CARD(6) .NE. ADC(32)) CALL ERRORM(ERRM3,NWRITE) CALL USECRD(7,VAR,LVAR,NWRITE) C C PUT ANY LABEL FIELD INTO BUFFER PRECEDED AND FOLLOWED BY C A AD(28)(:). C DO 30 COL = 5, 1, -1 IF (CARD(COL) .NE. ADC(32)) THEN NEXTCH = NEXTCH - 1 VAR(4*LVAR+NEXTCH) = ADC(28) CCOL = COL 20 CONTINUE IF (CCOL .GE. 1) THEN IF (CARD(CCOL) .NE. ADC(32)) THEN NEXTCH = NEXTCH - 1 VAR(4*LVAR+NEXTCH) = CARD(CCOL) END IF CCOL = CCOL - 1 GO TO 20 END IF NEXTCH = NEXTCH - 1 VAR(4*LVAR+NEXTCH) = ADC(28) GO TO 40 END IF 30 CONTINUE 40 CONTINUE RETURN C C LAST CARD OF SUBROUTINE GETSTM. C END C****************************************************************** SUBROUTINE SCAN1(C,NREAD,NWRITE,VAR,LVAR) INTEGER NREAD,NWRITE,LVAR CHARACTER C,VAR(9*LVAR) CHARACTER EOF,EOL,EOS,EOT CHARACTER ADC(86) INTEGER ADDR,COL,IADD,K,L,LASTCH,NEXTCH INTEGER AD(86) COMMON /ENDSYM/ EOF,EOL,EOS,EOT COMMON /COUNTS/ COL,LASTCH,NEXTCH COMMON /XCHAR/ ADC COMMON /ZCHAR/ AD K = 1 L = 1 10 CONTINUE C = VAR(4*LVAR+NEXTCH) IF (C .EQ. ADC(32)) THEN NEXTCH = NEXTCH + 1 IF (NEXTCH .GT. LASTCH) CALL GETCON(NREAD,NWRITE,VAR,LVAR) GO TO 10 END IF IF (C .EQ. EOL) THEN NEXTCH = NEXTCH + 1 GO TO 90 END IF IF (C .EQ. ADC(42)) GO TO 50 IADD = ADDR(C) IF ((IADD .GE. AD(16)) .AND. (IADD .LE. AD(19))) THEN 20 CONTINUE C C C IS IN [A - Z] INDICATING AN ALPHABETIC. C IF (K .GT. 0) THEN IF (C .NE. ADC(32)) THEN VAR(6*LVAR+L) = C L = L + 1 END IF NEXTCH = NEXTCH + 1 IF (NEXTCH .GT. LASTCH) CALL GETCON(NREAD,NWRITE,VAR,LVAR) C = VAR(4*LVAR+NEXTCH) IF (C .EQ. ADC(32)) GO TO 20 C C FOR C IN [A - Z,0 - 9], EXTEND LEXEME. C IADD = ADDR(C) IF ((IADD .GE. AD(16)) .AND. (IADD .LE. AD(19))) * GO TO 20 IF ((IADD .GE. AD(20)) .AND. (IADD .LE. AD(21))) GO TO 20 END IF VAR(6*LVAR+L) = ADC(22) C = ADC(13) GO TO 90 ELSE IF ((IADD .GE. AD(20)) .AND. (IADD .LE. AD(21))) THEN 30 CONTINUE C C C IS IN [0 - 9] INDICATING A NUMBER OR HOLLERITH COUNT. C IF (K .GT. 0) THEN IF (C .NE. ADC(32)) THEN VAR(6*LVAR+L) = C L = L + 1 END IF NEXTCH = NEXTCH + 1 IF (NEXTCH .GT. LASTCH) CALL GETCON(NREAD,NWRITE,VAR,LVAR) C = VAR(4*LVAR+NEXTCH) IF (C .EQ. ADC(32)) GO TO 30 C C FOR C IN [0 - 9], EXTEND LEXEME. C IADD = ADDR(C) IF ((IADD .GE. AD(20)) .AND. (IADD .LE. AD(21))) GO TO 30 END IF VAR(6*LVAR+L) = ADC(22) IF (C .EQ. ADC(58)) THEN CALL HOLERH(C,NREAD,NWRITE,VAR,LVAR) GO TO 40 END IF C = ADC(47) 40 CONTINUE ELSE C C C IS IN [/+-*.,:()=], INDICATING A DELIMITER. C IF (C .NE. ADC(32)) THEN VAR(6*LVAR+L) = C L = L + 1 END IF NEXTCH = NEXTCH + 1 IF (NEXTCH .GT. LASTCH) CALL GETCON(NREAD,NWRITE,VAR,LVAR) VAR(6*LVAR+L) = ADC(22) GO TO 90 50 CONTINUE C C C IS A QUOTE, INDICATING A STRING. C VAR(6*LVAR+L) = C 60 CONTINUE L = L + 1 IF (K .GT. 0) THEN NEXTCH = NEXTCH + 1 IF (NEXTCH .GT. LASTCH) CALL GETCON(NREAD,NWRITE,VAR,LVAR) C = VAR(4*LVAR+NEXTCH) IF (C .EQ. ADC(42)) THEN NEXTCH = NEXTCH + 1 IF (NEXTCH .GT. LASTCH) * CALL GETCON(NREAD,NWRITE,VAR,LVAR) C = VAR(4*LVAR+NEXTCH) IF (C .EQ. ADC(42)) THEN VAR(6*LVAR+L) = EOL L = L + 1 VAR(6*LVAR+L) = ADC(42) GO TO 60 END IF 70 CONTINUE C = VAR(4*LVAR+NEXTCH) IF (C .EQ. ADC(32)) THEN NEXTCH = NEXTCH + 1 IF (NEXTCH .GT. LASTCH) * CALL GETCON(NREAD,NWRITE,VAR,LVAR) GO TO 70 END IF IF (C .EQ. ADC(42)) GO TO 60 VAR(6*LVAR+L) = ADC(42) L = L + 1 GO TO 80 END IF VAR(6*LVAR+L) = C IF (C .NE. EOL) GO TO 60 L = L + 1 VAR(6*LVAR+L) = C GO TO 60 END IF 80 CONTINUE VAR(6*LVAR+L) = ADC(22) C = ADC(4) 90 CONTINUE END IF RETURN C C LAST CARD OF SUBROUTINE SCAN1. C END C******************************************************************** C SUBROUTINES FOR PARSER. C******************************************************************** SUBROUTINE GETLIN(RFORT,VAR,LVAR) C C THIS ROUTINE GETS A LINE OF PROCESSED FORTRAN. C INTEGER RFORT,LVAR CHARACTER VAR(9*LVAR) CHARACTER EOF,EOL,EOS,EOT CHARACTER ADC(86),CARD(80) INTEGER COL,I,J,LASTCH,NEXTCH COMMON /ENDSYM/ EOF,EOL,EOS,EOT COMMON /COUNTS/ COL,LASTCH,NEXTCH COMMON /XCHAR/ ADC NEXTCH = 20 J = NEXTCH 10 CONTINUE READ (RFORT,'(80A1)') CARD DO 20 I = 1, 80 VAR(4*LVAR+J) = CARD(I) IF(VAR(4*LVAR+J) .EQ. EOS) GO TO 30 J = J + 1 20 CONTINUE GO TO 10 30 CONTINUE VAR(4*LVAR+J) = ADC(22) LASTCH = J RETURN C C LAST CARD OF SUBROUTINE GETLIN. C END C********************************************************************* INTEGER FUNCTION NTLOCT(STR,NWRITE,NMTBL,LNMTBL,INDX,LINDX) C C THIS ROUTINE RETURNS A POINTER TO THE LOCATION OF "STR" IN THE C NAME TABLE. IF "STR" IS NOT IN THE NAME TABLE, IT IS ENTERED C FIRST. C INTEGER NWRITE,LNMTBL,LINDX CHARACTER STR(*),NMTBL(0:LNMTBL) INTEGER INDX(LINDX) CHARACTER ADC(86) CHARACTER*70 ERRM1,ERRM2 INTEGER CRYPNT,EXPFRE,I,J,K,NSMTAB,NTFREE COMMON /COUNTR/ CRYPNT,EXPFRE,NSMTAB,NTFREE COMMON /XCHAR/ ADC DATA ERRM1 /' OVERFLOW OF NAME TABLE INDEX SPACE'/ DATA ERRM2 /' OVERFLOW OF NAME TABLE SPACE'/ I = 1 10 CONTINUE J = INDX(I) IF (J .NE. (-1)) THEN K = 1 20 CONTINUE IF ((NMTBL(J) .EQ. STR(K)) .AND. (STR(K) .NE. ADC(22))) * THEN J = J + 1 K = K + 1 GO TO 20 END IF IF (NMTBL(J) .EQ. STR(K)) THEN NTLOCT = INDX(I) GO TO 40 END IF I = I + 1 GO TO 10 END IF IF (I .GE. LINDX) CALL ERRORM(ERRM1,NWRITE) INDX(I+1) = -1 INDX(I) = NTFREE K = 1 30 CONTINUE IF (STR(K) .NE. ADC(22)) THEN IF (NTFREE .GT. LNMTBL-2) CALL ERRORM(ERRM2,NWRITE) NMTBL(NTFREE) = STR(K) NTFREE = NTFREE + 1 K = K + 1 GO TO 30 END IF NMTBL(NTFREE) = ADC(22) NTFREE = NTFREE + 1 NTLOCT = INDX(I) 40 CONTINUE RETURN C C LAST CARD OF INTEGER FUNCTION NTLOCT. C END C******************************************************************** SUBROUTINE YYPARS(RFORT,NWRITE,NMTBL,LNMTBL,CRYSP,LCRYSP,PFILE, * LPFILE,VAR,LVAR,STACK,LSTACK,INDX,LINDX) INTEGER RFORT,NWRITE,LNMTBL,LCRYSP,LPFILE,LVAR,LSTACK,LINDX CHARACTER NMTBL(0:LNMTBL),CRYSP(LCRYSP),VAR(9*LVAR) CHARACTER*70 ERRM INTEGER PFILE(LPFILE),STACK(0:2*LSTACK),INDX(LINDX) INTEGER CONSTP,IADD,STTYPE,YYCHAR,YYERFL,YYFLAG,YYJ,YYLEX,YYLVAL, * YYM,YYN,YYNERS,YYPS,YYPV,YYPVT,YYSTAT,YYVAL,YYXI INTEGER AD(86),STYPEF(52),YYACT(0:388),YYCHK(0:189),YYDEF(0:189), * YYEXCA(0:11),YYLEXF(52),YYPACT(0:189),YYPGO(0:42), * YYR1(0:102),YYR2(0:102),YYVALF(52) COMMON /PARSE/ STYPEF,YYACT,YYCHK,YYDEF,YYEXCA,YYLEXF,YYPACT, * YYPGO,YYR1,YYR2,YYVALF COMMON /LVAL/ STTYPE,YYLVAL COMMON /ZCHAR/ AD DATA ERRM /' PARSING STACK OVERFLOW'/ YYFLAG = -1000 YYCHAR = -1 YYNERS = 0 YYERFL = 0 YYSTAT = 0 YYPS = -1 YYPV = -1 10 CONTINUE C C PUT A STATE AND VALUE ONTO THE STACK. C YYPS = YYPS + 1 IF (YYPS .GT. LSTACK) CALL ERRORM(ERRM,NWRITE) STACK(YYPS) = YYSTAT YYPV = YYPV + 1 STACK(LSTACK+YYPV+1) = YYVAL 20 CONTINUE YYN = YYPACT(YYSTAT) C C SIMPLE STATE. C IF (YYN .GT. YYFLAG) THEN IF (YYCHAR .LT. 0) THEN YYCHAR = YYLEX(CONSTP,RFORT,NWRITE,NMTBL,LNMTBL, * CRYSP,LCRYSP,VAR,LVAR,INDX,LINDX) IF (YYCHAR .LT. 0) YYCHAR = 0 END IF YYN = YYN+YYCHAR IF ((YYN .GE. 0) .AND. (YYN .LT. 395)) THEN YYN = YYACT(YYN) C C VALID SHIFT. C IF (YYCHK(YYN) .EQ. YYCHAR) THEN YYCHAR = -1 YYVAL = YYLVAL YYSTAT = YYN IF (YYERFL .GT. 0) YYERFL = YYERFL - 1 GO TO 10 END IF END IF END IF C C DEFAULT STATE ACTION. C YYN = YYDEF(YYSTAT) IF (YYN .EQ. (-2)) THEN IF (YYCHAR .LT. 0) THEN YYCHAR = YYLEX(CONSTP,RFORT,NWRITE,NMTBL,LNMTBL, * CRYSP,LCRYSP,VAR,LVAR,INDX,LINDX) IF (YYCHAR .LT. 0) YYCHAR = 0 END IF C C LOOK THROUGH EXCEPTION TABLE. C YYXI = 0 30 CONTINUE IF ((YYEXCA(YYXI) .NE. (-1)) .OR. * (YYEXCA(YYXI+1) .NE. YYSTAT)) THEN YYXI = YYXI + 2 GO TO 30 END IF 40 CONTINUE YYXI = YYXI + 2 IF (YYEXCA(YYXI) .GE. 0) THEN IF (YYEXCA(YYXI) .EQ. YYCHAR) GO TO 50 GO TO 40 END IF 50 CONTINUE YYN = YYEXCA(YYXI+1) IF (YYN .LT. 0) THEN GO TO 750 END IF C C ERROR ... ATTEMPT TO RESUME PARSING. C END IF IF (YYN .EQ. 0) THEN IF (YYERFL .GE. 1 .AND. YYERFL .LE. 4) * GO TO (60,60,90,100), YYERFL C C BRAND NEW ERROR. C WRITE (NWRITE,'(''SYNTAX ERROR IN PARSING PHASE'')') YYNERS = YYNERS + 1 60 CONTINUE C C INCOMPLETELY RECOVERED ERROR ... TRY AGAIN. C YYERFL = 3 C C FIND A STATE WHERE "ERROR" IS A LEGAL SHIFT ACTION. C 70 CONTINUE IF (YYPS .GE. 0) THEN YYN = YYPACT(STACK(YYPS)) + 256 IF ((YYN .GE. 0) .AND. (YYN .LT. 395)) THEN C C SIMULATE A SHIFT OF "ERROR". C IF (YYCHK(YYACT(YYN)) .EQ. 256) THEN YYSTAT = YYACT(YYN) GO TO 10 END IF END IF C C THE CURRENT YYPS HAS NO SHIFT ON "ERROR", POP STACK. C YYN = YYPACT(STACK(YYPS)) YYPS = YYPS - 1 YYPV = YYPV - 1 GO TO 70 END IF 80 CONTINUE GO TO 750 90 CONTINUE C C IF YYCHAR .EQ. 0, DO NOT DISCARD EOF, QUIT. C IF (YYCHAR .EQ. 0) GO TO 80 C C TRY AGAIN IN THE SAME STATE. C YYCHAR = -1 GO TO 20 END IF 100 CONTINUE C C REDUCTION BY PRODUCTION YYN. C YYPS = YYPS-YYR2(YYN) YYPVT = YYPV YYPV = YYPV-YYR2(YYN) YYVAL = STACK(LSTACK+YYPV+2) YYM = YYN C C CONSULT "GO TO" TABLE TO FIND NEXT STATE. C YYN = YYR1(YYN) YYJ = YYPGO(YYN) + STACK(YYPS) + 1 IF (YYJ .LT. 395) THEN YYSTAT = YYACT(YYJ) IF (YYCHK(YYSTAT) .EQ. (-YYN)) GO TO 110 END IF YYSTAT = YYACT(YYPGO(YYN)) 110 CONTINUE IF (YYM .GT. 0 .AND. YYM .LE. 102) GO TO (120,130,140,10,150, * 160,170,10,180,190,200,210,10,220,230,240,250,260,10,262,264, * 266,270,280,290,10,300,310,320,10,330,10,10,10,340,350,360, * 370,380,390,10,400,410,420,430,10,10,440,450,452,10,10,460, * 470,480,10,490,10,10,10,10,500,10,10,510,520,10,10,530,540, * 550,10,560,10,570,10,580,10,590,10,600,10,610,10,10,620,630, * 640,650,10,660,670,10,680,10,690,700,710,10,720,10,730) YYM 120 CONTINUE IADD = AD(27) GO TO 740 130 CONTINUE CALL PUT(PFILE,LPFILE,NWRITE,13) GO TO 10 140 CONTINUE CALL PUT(PFILE,LPFILE,NWRITE,12) CALL PUT(PFILE,LPFILE,NWRITE,STACK(LSTACK+YYPVT+1)) GO TO 10 150 CONTINUE IADD = AD(28) GO TO 740 160 CONTINUE IADD = AD(27) GO TO 740 170 CONTINUE IADD = AD(28) CALL PUT(PFILE,LPFILE,NWRITE,IADD) IADD = AD(27) GO TO 740 180 CONTINUE IADD = AD(31) GO TO 740 190 CONTINUE CALL PUT(PFILE,LPFILE,NWRITE,10) CALL PUT(PFILE,LPFILE,NWRITE,0) GO TO 10 200 CONTINUE CALL PUT(PFILE,LPFILE,NWRITE,11) CALL PUT(PFILE,LPFILE,NWRITE,STTYPE) CALL PUT(PFILE,LPFILE,NWRITE,STACK(LSTACK+YYPVT+1)) GO TO 10 210 CONTINUE CALL PUT(PFILE,LPFILE,NWRITE,0) GO TO 10 220 CONTINUE CALL PUT(PFILE,LPFILE,NWRITE,31) GO TO 10 230 CONTINUE IADD = AD(10) GO TO 740 240 CONTINUE IADD = AD(12) GO TO 740 250 CONTINUE CALL PUT(PFILE,LPFILE,NWRITE,28) GO TO 10 260 CONTINUE CALL PUT(PFILE,LPFILE,NWRITE,27) GO TO 10 262 CONTINUE CALL PUT(PFILE,LPFILE,NWRITE,36) GO TO 10 264 CONTINUE CALL PUT(PFILE,LPFILE,NWRITE,33) GO TO 10 266 CONTINUE CALL PUT(PFILE,LPFILE,NWRITE,37) GO TO 10 270 CONTINUE CALL PUT(PFILE,LPFILE,NWRITE,0) GO TO 10 280 CONTINUE CALL PUT(PFILE,LPFILE,NWRITE,6) GO TO 10 290 CONTINUE CALL PUT(PFILE,LPFILE,NWRITE,5) GO TO 10 300 CONTINUE IADD = AD(34) GO TO 740 310 CONTINUE IADD = AD(13) CALL PUT(PFILE,LPFILE,NWRITE,IADD) CALL PUT(PFILE,LPFILE,NWRITE,STACK(LSTACK+YYPVT+1)) GO TO 10 320 CONTINUE IADD = AD(33) CALL PUT(PFILE,LPFILE,NWRITE,IADD) CALL PUT(PFILE,LPFILE,NWRITE,STACK(LSTACK+YYPVT+1)) GO TO 10 330 CONTINUE IADD = AD(30) GO TO 740 340 CONTINUE IADD = AD(23) GO TO 740 350 CONTINUE IADD = AD(24) GO TO 740 360 CONTINUE IADD = AD(25) GO TO 740 370 CONTINUE IADD = AD(26) GO TO 740 380 CONTINUE IADD = AD(36) GO TO 740 390 CONTINUE IADD = AD(35) GO TO 740 400 CONTINUE CALL PUT(PFILE,LPFILE,NWRITE,STACK(LSTACK+YYPVT)) GO TO 10 410 CONTINUE IADD = AD(41) GO TO 740 420 CONTINUE IADD = AD(40) GO TO 740 430 CONTINUE IADD = AD(37) GO TO 740 440 CONTINUE CALL PUT(PFILE,LPFILE,NWRITE,25) GO TO 10 450 CONTINUE CALL PUT(PFILE,LPFILE,NWRITE,24) GO TO 10 452 CONTINUE CALL PUT(PFILE,LPFILE,NWRITE,36) GO TO 10 460 CONTINUE IADD = AD(30) CALL PUT(PFILE,LPFILE,NWRITE,IADD) CALL PUT(PFILE,LPFILE,NWRITE,IADD) IADD = AD(31) GO TO 740 470 CONTINUE IADD = AD(30) CALL PUT(PFILE,LPFILE,NWRITE,IADD) IADD = AD(31) GO TO 740 480 CONTINUE CALL PUT(PFILE,LPFILE,NWRITE,23) CALL PUT(PFILE,LPFILE,NWRITE,STACK(LSTACK+YYPVT+1)) GO TO 10 490 CONTINUE IADD = AD(30) GO TO 740 500 CONTINUE CALL PUT(PFILE,LPFILE,NWRITE,22) CALL PUT(PFILE,LPFILE,NWRITE,STACK(LSTACK+YYPVT+1)) GO TO 10 510 CONTINUE CALL PUT(PFILE,LPFILE,NWRITE,21) CALL PUT(PFILE,LPFILE,NWRITE,STACK(LSTACK+YYPVT-1)) CALL PUT(PFILE,LPFILE,NWRITE,STACK(LSTACK+YYPVT+1)) GO TO 10 520 CONTINUE CALL PUT(PFILE,LPFILE,NWRITE,21) CALL PUT(PFILE,LPFILE,NWRITE,STACK(LSTACK+YYPVT+1)) CALL PUT(PFILE,LPFILE,NWRITE,STACK(LSTACK+YYPVT+1)) GO TO 10 530 CONTINUE CALL PUT(PFILE,LPFILE,NWRITE,20) GO TO 10 540 CONTINUE CALL PUT(PFILE,LPFILE,NWRITE,20) GO TO 10 550 CONTINUE CALL PUT(PFILE,LPFILE,NWRITE,19) GO TO 10 560 CONTINUE IADD = AD(30) GO TO 740 570 CONTINUE CALL PUT(PFILE,LPFILE,NWRITE,18) CALL PUT(PFILE,LPFILE,NWRITE,STACK(LSTACK+YYPVT+1)) GO TO 10 580 CONTINUE CALL PUT(PFILE,LPFILE,NWRITE,17) GO TO 10 590 CONTINUE IADD = AD(30) GO TO 740 600 CONTINUE CALL PUT(PFILE,LPFILE,NWRITE,16) GO TO 10 610 CONTINUE IADD = AD(29) CALL PUT(PFILE,LPFILE,NWRITE,IADD) CALL PUT(PFILE,LPFILE,NWRITE,8*CONSTP) CALL PUT(PFILE,LPFILE,NWRITE,STACK(LSTACK+YYPVT+1)) GO TO 10 620 CONTINUE IADD = AD(30) GO TO 740 630 CONTINUE CALL PUT(PFILE,LPFILE,NWRITE,15) GO TO 10 640 CONTINUE CALL PUT(PFILE,LPFILE,NWRITE,15) IADD = AD(27) GO TO 740 650 CONTINUE CALL PUT(PFILE,LPFILE,NWRITE,14) CALL PUT(PFILE,LPFILE,NWRITE,0) GO TO 10 660 CONTINUE CALL PUT(PFILE,LPFILE,NWRITE,14) CALL PUT(PFILE,LPFILE,NWRITE,STACK(LSTACK+YYPVT)) GO TO 10 670 CONTINUE CALL PUT(PFILE,LPFILE,NWRITE,14) CALL PUT(PFILE,LPFILE,NWRITE,0) GO TO 10 680 CONTINUE IADD = AD(30) GO TO 740 690 CONTINUE CALL PUT(PFILE,LPFILE,NWRITE,19) GO TO 10 700 CONTINUE CALL PUT(PFILE,LPFILE,NWRITE,9) GO TO 10 710 CONTINUE CALL PUT(PFILE,LPFILE,NWRITE,8) CALL PUT(PFILE,LPFILE,NWRITE,23) CALL PUT(PFILE,LPFILE,NWRITE,0) GO TO 10 720 CONTINUE IADD = AD(30) GO TO 740 730 CONTINUE CALL PUT(PFILE,LPFILE,NWRITE,19) GO TO 10 740 CONTINUE CALL PUT(PFILE,LPFILE,NWRITE,IADD) GO TO 10 750 CONTINUE RETURN C C LAST CARD OF SUBROUTINE YYPARS. C END C******************************************************************* INTEGER FUNCTION YYLEX(CONSTP,RFORT,NWRITE,NMTBL,LNMTBL,CRYSP, * LCRYSP,VAR,LVAR,INDX,LINDX) INTEGER CONSTP,RFORT,NWRITE,LNMTBL,LCRYSP,LVAR,LINDX CHARACTER NMTBL(0:LNMTBL),CRYSP(LCRYSP),VAR(9*LVAR) INTEGER INDX(LINDX) CHARACTER EOF,EOL,EOS,EOT,LEXCL CHARACTER ADC(86),C1(7),C2(8) CHARACTER*16 KEYWD1(45) CHARACTER*17 KEYWD2(52),PRDLST(14) CHARACTER*70 ERRM INTEGER ADDR,COMP,I,LEX,NTLOCT,STORST,STTYPE,YYLVAL INTEGER AD(86),STYPEF(52),YYACT(0:388),YYCHK(0:189), * YYDEF(0:189),YYEXCA(0:11),YYLEXF(52),YYPACT(0:189), * YYPGO(0:42),YYR1(0:102),YYR2(0:102),YYVALF(52) COMMON /ENDSYM/ EOF,EOL,EOS,EOT COMMON /PARSE/ STYPEF,YYACT,YYCHK,YYDEF,YYEXCA,YYLEXF,YYPACT, * YYPGO,YYR1,YYR2,YYVALF COMMON /LVAL/ STTYPE,YYLVAL COMMON /KEY/ KEYWD1,KEYWD2,PRDLST COMMON /XCHAR/ ADC COMMON /ZCHAR/ AD DATA ERRM /' UNRECOGNIZED KEYWORD'/ DATA C1 /'.','T','R','U','E','.','@'/ DATA C2 /'.','F','A','L','S','E','.','@'/ CALL SCANP(LEXCL,RFORT,NWRITE,VAR,LVAR) C C CASE EOF C IF (LEXCL .EQ. EOF) THEN YYLEX = 0 C C CASE KEYWORD C ELSE IF (LEXCL .EQ. ADC(49)) THEN I = COMP(VAR(6*LVAR+1),KEYWD2) IF (I .EQ. (-1)) CALL ERRORM(ERRM,NWRITE) LEX = YYLEXF(I) IF (LEX .EQ. 264) THEN STTYPE = STYPEF(I) YYLVAL = STORST(RFORT,NWRITE,CRYSP,LCRYSP,VAR,LVAR) ELSE IF (YYVALF(I) .EQ. AD(18)) THEN YYLVAL = NTLOCT(C1,NWRITE,NMTBL,LNMTBL,INDX,LINDX) CONSTP = 1 ELSE IF (YYVALF(I) .EQ. AD(17)) THEN YYLVAL = NTLOCT(C2,NWRITE,NMTBL,LNMTBL,INDX,LINDX) CONSTP = 1 ELSE YYLVAL = YYVALF(I) END IF YYLEX = LEX C C CASE ID C ELSE IF (LEXCL .EQ. ADC(13)) THEN I = COMP(VAR(6*LVAR+1),PRDLST) YYLVAL = NTLOCT(VAR(6*LVAR+1),NWRITE,NMTBL,LNMTBL,INDX,LINDX) YYLEX = 257 C C CASE INT C ELSE IF (LEXCL .EQ. ADC(33)) THEN YYLVAL = 0 I = 1 10 CONTINUE IF (VAR(6*LVAR+I) .NE. ADC(22)) THEN YYLVAL = 10*YYLVAL + ADDR(VAR(6*LVAR+I)) - AD(20) I = I + 1 GO TO 10 END IF YYLEX = 258 C C CASE LIT C ELSE IF (LEXCL .EQ. ADC(3)) THEN YYLVAL = NTLOCT(VAR(6*LVAR+1),NWRITE,NMTBL,LNMTBL,INDX,LINDX) CONSTP = 1 YYLEX = 259 C C CASE REAL C ELSE IF (LEXCL .EQ. ADC(6)) THEN YYLVAL = NTLOCT(VAR(6*LVAR+1),NWRITE,NMTBL,LNMTBL,INDX,LINDX) CONSTP = 3 YYLEX = 259 C C CASE DOUBLE C ELSE IF (LEXCL .EQ. ADC(10)) THEN YYLVAL = NTLOCT(VAR(6*LVAR+1),NWRITE,NMTBL,LNMTBL,INDX,LINDX) CONSTP = 4 YYLEX = 259 C C CASE DEFAULT C ELSE YYLVAL = 0 YYLEX = ADDR(LEXCL) IF (LEXCL .EQ. ADC(22)) YYLEX = 10 END IF RETURN C C LAST CARD OF INTEGER FUNCTION YYLEX. C END C******************************************************************* SUBROUTINE SCANP(C,RFORT,NWRITE,VAR,LVAR) INTEGER RFORT,NWRITE,LVAR CHARACTER C,VAR(9*LVAR) CHARACTER EOF,EOL,EOS,EOT,LEX CHARACTER ADC(86) CHARACTER*70 ERRM INTEGER ADDR,COL,IADD,KK,LASTCH,LIND,NEXTCH INTEGER AD(86) COMMON /ENDSYM/ EOF,EOL,EOS,EOT COMMON /COUNTS/ COL,LASTCH,NEXTCH COMMON /XCHAR/ ADC COMMON /ZCHAR/ AD DATA ERRM /' WRONG FLOATING POINT CONSTANT'/ LIND = 1 KK = 1 10 CONTINUE C = VAR(4*LVAR+NEXTCH) IF (C .EQ. ADC(32)) THEN NEXTCH = NEXTCH + 1 IF (NEXTCH .GT. LASTCH) CALL GETLIN(RFORT,VAR,LVAR) GO TO 10 END IF IADD = ADDR(C) C C CASE UPPER. C IF (IADD .GE. AD(16) .AND. IADD .LE. AD(19)) THEN 20 CONTINUE IF (KK .GT. 0) THEN CALL ADVNCE(C,LIND,RFORT,VAR,LVAR) IADD = ADDR(C) IF ((IADD .GE. AD(16) .AND. IADD .LE. AD(19)) .OR. * (IADD .GE. AD(20) .AND. IADD .LE. AD(21))) GO TO 20 END IF VAR(6*LVAR+LIND) = ADC(22) C = ADC(13) C C CASE LOWER. C ELSE IF (IADD .GE. AD(7) .AND. IADD .LE. AD(15)) THEN 30 CONTINUE IF (KK .GT. 0) THEN CALL ADVNCE(C,LIND,RFORT,VAR,LVAR) IADD = ADDR(C) IF (IADD .GE. AD(7) .AND. IADD .LE. AD(15)) * GO TO 30 END IF VAR(6*LVAR+LIND) = ADC(22) C = ADC(49) C C CASE DIGIT. C ELSE IF (IADD .GE. AD(20) .AND. IADD .LE. AD(21)) THEN 40 CONTINUE IF (KK .GT. 0) THEN CALL ADVNCE(C,LIND,RFORT,VAR,LVAR) IADD = ADDR(C) IF (IADD .GE. AD(20) .AND. IADD .LE. AD(21)) GO TO 40 END IF LEX = ADC(33) GO TO 50 C C CASE FLOATING. C ELSE IF (C .EQ. ADC(29)) THEN 50 CONTINUE IF ( C .EQ. ADC(29)) THEN LEX = ADC(6) 60 CONTINUE IF (KK .GT. 0) THEN CALL ADVNCE(C,LIND,RFORT,VAR,LVAR) IADD = ADDR(C) IF (IADD .GE. AD(20) .AND. IADD .LE. AD(21)) GO TO 60 END IF END IF IF ((C .EQ. ADC(44)) .OR. (C .EQ. ADC(50))) THEN LEX = ADC(6) IF (C .EQ. ADC(50)) LEX = ADC(10) CALL ADVNCE(C,LIND,RFORT,VAR,LVAR) IF ((C .EQ. ADC(23)) .OR. (C .EQ. ADC(24))) * CALL ADVNCE(C,LIND,RFORT,VAR,LVAR) IADD = ADDR(C) IF (IADD .LT. AD(20) .OR. IADD .GT. AD(21)) * CALL ERRORM(ERRM,NWRITE) 70 CONTINUE IF (KK .GT. 0) THEN CALL ADVNCE(C,LIND,RFORT,VAR,LVAR) IADD = ADDR(C) IF (IADD .GE. AD(20) .AND. IADD .LE. AD(21)) GO TO 70 END IF END IF VAR(6*LVAR+LIND) = ADC(22) C = LEX C C CASE STAR. C ELSE IF (C .EQ. ADC(25)) THEN CALL ADVNCE(C,LIND,RFORT,VAR,LVAR) IF (C .EQ. ADC(25)) THEN CALL ADVNCE(C,LIND,RFORT,VAR,LVAR) VAR(6*LVAR+LIND) = ADC(22) C = ADC(36) GO TO 90 END IF VAR(6*LVAR+LIND) = ADC(22) C = ADC(25) C C CASE STRING. C ELSE IF (C .EQ. ADC(42)) THEN CALL ADVNCE(C,LIND,RFORT,VAR,LVAR) 80 CONTINUE IF (C .NE. ADC(42)) THEN IF (C .EQ. EOL) CALL ADVNCE(C,LIND,RFORT,VAR,LVAR) CALL ADVNCE(C,LIND,RFORT,VAR,LVAR) GO TO 80 END IF CALL ADVNCE(C,LIND,RFORT,VAR,LVAR) VAR(6*LVAR+LIND) = ADC(22) C = ADC(3) ELSE VAR(6*LVAR+LIND) = C LIND = LIND + 1 NEXTCH = NEXTCH + 1 IF (NEXTCH .GT. LASTCH) CALL GETLIN(RFORT,VAR,LVAR) VAR(6*LVAR+LIND) = ADC(22) END IF 90 CONTINUE RETURN C C LAST CARD OF SUBROUTINE SCANP. C END C********************************************************************* SUBROUTINE ADVNCE(C,LIND,RFORT,VAR,LVAR) INTEGER LIND,RFORT,LVAR CHARACTER C,VAR(9*LVAR) INTEGER COL,LASTCH,NEXTCH COMMON /COUNTS/ COL,LASTCH,NEXTCH VAR(6*LVAR+LIND) = C LIND = LIND + 1 NEXTCH = NEXTCH + 1 IF (NEXTCH .GT. LASTCH) CALL GETLIN(RFORT,VAR,LVAR) C = VAR(4*LVAR+NEXTCH) RETURN C C LAST CARD OF SUBROUTINE ADVNCE. C END C********************************************************************** INTEGER FUNCTION COMP(STRING,TABLE) CHARACTER STRING(*) CHARACTER*17 TABLE(*) CHARACTER C CHARACTER ADC(86) INTEGER I,J COMMON /XCHAR/ ADC I = 1 10 CONTINUE IF (TABLE(I) .NE. ADC(20)) THEN J = 1 20 CONTINUE C = TABLE(I) (J:17) IF ((STRING(J) .EQ. C) .AND. (STRING(J) .NE. ADC(22))) THEN J = J + 1 GO TO 20 END IF IF (STRING(J) .EQ. C) THEN COMP = I GO TO 30 END IF I = I + 1 GO TO 10 END IF COMP = -1 30 CONTINUE RETURN C C LAST CARD OF INTEGER FUNCTION COMP. C END C********************************************************************* INTEGER FUNCTION STORST(RFORT,NWRITE,CRYSP,LCRYSP,VAR,LVAR) C C THIS ROUTINE STORES A STATEMENT AND RETURNS THE POINTER TO IT. C INTEGER RFORT,NWRITE,LCRYSP,LVAR CHARACTER CRYSP(LCRYSP),VAR(9*LVAR) CHARACTER ACHAR,C,EOF,EOL,EOS,EOT CHARACTER ADC(86) CHARACTER*70 ERRM INTEGER ADDR,COL,CRYPNT,EXPFRE,I,J,K,LASTCH,NEXTCH,NSMTAB,NTFREE INTEGER AD(86) COMMON /ENDSYM/ EOF,EOL,EOS,EOT COMMON /COUNTS/ COL,LASTCH,NEXTCH COMMON /COUNTR/ CRYPNT,EXPFRE,NSMTAB,NTFREE COMMON /XCHAR/ ADC COMMON /ZCHAR/ AD DATA ERRM /' OVERFLOW OF CARRY SPACE'/ K = CRYPNT J = 1 10 CONTINUE IF (VAR(6*LVAR+J) .NE. ADC(22)) THEN IF (CRYPNT .GT. LCRYSP-2) CALL ERRORM(ERRM,NWRITE) I = ADDR(VAR(6*LVAR+J)) + AD(16) - AD(7) CRYSP(CRYPNT) = ACHAR(I) CRYPNT = CRYPNT + 1 J = J + 1 GO TO 10 END IF NEXTCH = NEXTCH + 1 IF (NEXTCH .GT. LASTCH) CALL GETLIN(RFORT,VAR,LVAR) CRYSP(CRYPNT) = ADC(32) CRYPNT = CRYPNT + 1 20 CONTINUE C = VAR(4*LVAR+NEXTCH) IF (C .NE. ADC(22)) THEN IF (CRYPNT .GT. LCRYSP-2) CALL ERRORM(ERRM,NWRITE) CRYSP(CRYPNT) = C CRYPNT = CRYPNT + 1 NEXTCH = NEXTCH + 1 IF (NEXTCH .GT. LASTCH) CALL GETLIN(RFORT,VAR,LVAR) GO TO 20 END IF CRYSP(CRYPNT) = EOS CRYPNT = CRYPNT + 1 STORST = K RETURN C C LAST CARD OF INTEGER FUNCTION STORST. C END C********************************************************************** SUBROUTINE PUT(PFILE,LPFILE,NWRITE,C) INTEGER LPFILE,NWRITE,C INTEGER PFILE(LPFILE) INTEGER CONFLG,JFLG,OUTP,SENTNL CHARACTER*70 ERRM COMMON /FLAGS/ OUTP,SENTNL,JFLG,CONFLG DATA ERRM /' OVERFLOW OF PARSE BUFFER'/ PFILE(OUTP) = C IF (C .NE. -1) OUTP = OUTP + 1 IF (OUTP .GT. LPFILE) CALL ERRORM(ERRM,NWRITE) RETURN C C LAST CARD OF SUBROUTINE PUT. C END C*********************************************************************** C SUBROUTINES FOR TREE BUILDING AND FLOW GRAPH ANALYSIS. C*********************************************************************** SUBROUTINE IMPLCT(FIRST,LAST,TY,LTH) C C THIS ROUTINE SETS ALL VARIABLES STARTING WITH A CHARACTER C BETWEEN "FIRST" AND "LAST" TO HAVE DEFAULT TYPE "TY" UNTIL C OVERRIDDEN. C INTEGER TY,LTH CHARACTER FIRST,LAST INTEGER ADDR,F,I,L INTEGER AD(86),ARITY(0:255),DEFLEN(42),DEFTYP(42),DESCR(1000) COMMON /DATAB/ ARITY,DEFLEN,DEFTYP,DESCR COMMON /ZCHAR/ AD F = ADDR(FIRST) - AD(16) + 1 L = ADDR(LAST) - AD(16) + 1 DO 10 I = F, L DEFTYP(I) = TY DEFLEN(I) = LTH 10 CONTINUE RETURN C C LAST CARD OF SUBROUTINE IMPLCT. C END C******************************************************************** INTEGER FUNCTION MAKETR(NWRITE,EXPR,LEXPR,NMTBL,LNMTBL,PFILE, * LPFILE,VARD,LVARD,OPNDS,LOPNDS) C C THIS ROUTINE CONSTRUCTS THE EXPRESSION TREE. C INTEGER NWRITE,LEXPR,LNMTBL,LPFILE,LVARD,LOPNDS CHARACTER NMTBL(0:LNMTBL) INTEGER EXPR(0:4*LEXPR),PFILE(LPFILE),VARD(8*LVARD), * OPNDS(0:LOPNDS) CHARACTER FIRST,LAST CHARACTER*70 ERRM1,ERRM2,ERRM3 INTEGER ALLOCT,CMP,CRYPNT,DIMOF,DOTOP,EXPFRE,FCN,I,IN,K,LNGFLG, * NSMTAB,NTFREE,NTIND,OUT,OUTB,RESULT,T,TEMP1,TOP,TYPFLG, * TYPRSL,VD INTEGER AD(86),ARITY(0:255),DEFLEN(42),DEFTYP(42),DESCR(1000), * LIBDBL(14),LIBSGL(14),LIBTKN(0:14) LOGICAL TEMP2 COMMON /CONTRL/ IN,OUT,RESULT,TYPRSL COMMON /DATAB/ ARITY,DEFLEN,DEFTYP,DESCR COMMON /LIB/ LIBDBL,LIBSGL,LIBTKN COMMON /COUNTR/ CRYPNT,EXPFRE,NSMTAB,NTFREE COMMON /ZCHAR/ AD DATA ERRM1 /' UNKNOWN TOKEN IN MAKETREE'/ DATA ERRM2 /' NESTED DO-LOOP LIMIT EXCEEDED'/ DATA ERRM3 /' PARSE TREE HAS WRONG STRUCTURE'/ DOTOP = 0 TOP = 1 OUTB = 0 10 CONTINUE TOP = TOP - 1 20 CONTINUE OUTB = OUTB + 1 T = PFILE(OUTB) IF (T .NE. -1) THEN IF (T .NE. 0) THEN TEMP1 = ARITY(T) + 1 IF (TEMP1 .GT. 0 .AND. TEMP1 .LE. 3) * GO TO (30,70,80), TEMP1 CALL ERRORM(ERRM1,NWRITE) END IF TOP = TOP + 1 DESCR(TOP) = 0 GO TO 20 30 CONTINUE OUTB = OUTB + 1 IF (T .EQ. 23) THEN TYPFLG = PFILE(OUTB) LNGFLG = 0 GO TO 20 ELSE IF (T .EQ. 22) THEN LNGFLG = PFILE(OUTB) GO TO 20 ELSE IF (T .EQ. 21) THEN NTIND = PFILE(OUTB) OUTB = OUTB + 1 FIRST = NMTBL(NTIND) NTIND = PFILE(OUTB) LAST = NMTBL(NTIND) CALL IMPLCT(FIRST,LAST,TYPFLG,LNGFLG) GO TO 20 ELSE IF ((T .EQ. AD(29)) .OR. (T .EQ. 11)) THEN K = PFILE(OUTB) OUTB = OUTB + 1 TOP = TOP + 1 NTIND = PFILE(OUTB) DESCR(TOP) = ALLOCT(T,K,NTIND,NWRITE,EXPR,LEXPR) GO TO 20 END IF TEMP2 = T .EQ. 31 IF (.NOT. TEMP2) TEMP2 = T .EQ. 6 IF (.NOT. TEMP2) TEMP2 = T .EQ. 5 IF (TEMP2) THEN K = 0 OUTB = OUTB - 1 GO TO 40 END IF K = PFILE(OUTB) 40 CONTINUE IF (T .EQ. AD(13)) THEN C C ENTER VARIABLE IN SYMBOL TABLE, CHECK FOR DUPLICATES AND C SET UNDECLARED TYPE AND DIMENSION. C DO 50 I = 1, NSMTAB IF (VARD(I) .NE. K) GO TO 50 K = I GO TO 60 50 CONTINUE NSMTAB = NSMTAB + 1 VARD(NSMTAB) = K VARD(LVARD+NSMTAB) = 0 VARD(2*LVARD+NSMTAB) = 0 VARD(3*LVARD+NSMTAB) = 0 K = NSMTAB END IF 60 CONTINUE TOP = TOP + 1 DESCR(TOP) = ALLOCT(T,0,K,NWRITE,EXPR,LEXPR) GO TO 20 70 CONTINUE IF (T .EQ. 18) THEN OUTB = OUTB + 1 NTIND = PFILE(OUTB) C C ENTER ITEM LENGTH IN SYMBOL TABLE. OVERRIDE ANY PREVIOUSLY C ENCOUNTERED LENGTH. C VD = EXPR(3*LEXPR+DESCR(TOP)) T = VARD(LVARD+VD)/256 VARD(LVARD+VD) = 256*T*NTIND GO TO 20 END IF IF (T .EQ. 20) THEN C C ENTER TYPE AND ITEM LENGTH IN SYMBOL TABLE. C VD = EXPR(3*LEXPR+DESCR(TOP)) VARD(6*LVARD+VD) = TYPFLG VARD(LVARD+VD) = 256*TYPFLG + LNGFLG VARD(5*LVARD+VD) = LNGFLG GO TO 10 ELSE IF (T .EQ. 8) THEN IN = DESCR(TOP) GO TO 10 ELSE IF (T .EQ. 9) THEN OUT = DESCR(TOP) GO TO 10 ELSE IF (T .EQ. 10) THEN RESULT = DESCR(TOP) GO TO 10 END IF DESCR(TOP) = ALLOCT(T,0,DESCR(TOP),NWRITE,EXPR,LEXPR) GO TO 20 80 CONTINUE IF (T .EQ. 19) THEN C C ENTER DIMENSIONS IN SYMBOL TABLE. A SCALAR HAS 0, OTHERS C HAVE AN EXPRESSION LIST. C VD = EXPR(3*LEXPR+DESCR(TOP-1)) VARD(2*LVARD+VD) = DESCR(TOP) GO TO 10 END IF IF (T .EQ. 17) THEN C C ENTER INITIALIZATION EXPRESSION IN SYMBOL TABLE. C VD = EXPR(3*LEXPR+DESCR(TOP-1)) VARD(3*LVARD+VD) = DESCR(TOP) GO TO 10 END IF IF (T .EQ. AD(10)) THEN DOTOP = DOTOP + 1 IF (DOTOP .GT. LOPNDS) CALL ERRORM(ERRM2,NWRITE) OPNDS(DOTOP) = DESCR(TOP-1) DESCR(TOP-1) = DESCR(TOP) DESCR(TOP) = 0 TOP = TOP + 1 DESCR(TOP) = 0 GO TO 20 END IF IF (T .EQ. AD(28)) THEN CMP = DESCR(TOP-1) DESCR(TOP-1) = ALLOCT(AD(28),CMP,DESCR(TOP),NWRITE,EXPR, * LEXPR) TOP = TOP - 1 90 CONTINUE IF (CMP .EQ. OPNDS(DOTOP)) THEN DESCR(TOP-1) = ALLOCT(AD(27),DESCR(TOP-1),DESCR(TOP), * NWRITE,EXPR,LEXPR) TOP = TOP - 1 DESCR(TOP-1) = ALLOCT(AD(10),DESCR(TOP-1),DESCR(TOP), * NWRITE,EXPR,LEXPR) TOP = TOP - 1 DOTOP = DOTOP - 1 GO TO 90 END IF GO TO 20 END IF IF ((T .EQ. AD(27)) .AND. (DESCR(TOP) .EQ. 0)) GO TO 10 IF ((T .EQ. AD(27)) .AND. (DESCR(TOP-1) .EQ. 0)) THEN DESCR(TOP-1) = DESCR(TOP) GO TO 10 END IF DIMOF = -1 IF (EXPR(2*LEXPR+DESCR(TOP-1)) .EQ. AD(13)) * DIMOF = VARD(2*LVARD+EXPR(3*LEXPR+DESCR(TOP-1))) IF ((T .EQ. AD(34)) .AND. (DIMOF .EQ. 0)) THEN DESCR(TOP-1) = FCN(DESCR(TOP-1),DESCR(TOP),NWRITE, * EXPR,LEXPR,VARD,LVARD) GO TO 10 END IF DESCR(TOP-1) = ALLOCT(T,DESCR(TOP-1),DESCR(TOP),NWRITE, * EXPR,LEXPR) GO TO 10 END IF IF (TOP .NE. 1) CALL ERRORM(ERRM3,NWRITE) MAKETR = DESCR(1) RETURN C C LAST CARD OF INTEGER FUNCTION MAKETR. C END C*********************************************************************** SUBROUTINE DEPEND(NWRITE,EXPR,LEXPR,RHS,LRHS,FLAG,LFLAG,STM, * LSTM,VAR,LVAR) INTEGER NWRITE,LEXPR,LRHS,LFLAG,LSTM,LVAR CHARACTER FLAG(0:2*LFLAG),VAR(9*LVAR) INTEGER EXPR(0:4*LEXPR),RHS(LRHS),STM(16*LSTM+6) CHARACTER CNVERG CHARACTER ADC(86) CHARACTER*70 ERRM INTEGER ADDR,CRYPNT,EXPFRE,I,IN,INDS,K,KK,L,LABCNT,NSMTAB,NTFREE, * OUT,P,PF,Q,RESULT,RHSFST,RHSLST,SF,ST,STNCNT,TYPRSL COMMON /CONTRL/ IN,OUT,RESULT,TYPRSL COMMON /INDEX/ INDS,LABCNT,RHSFST,RHSLST,STNCNT COMMON /COUNTR/ CRYPNT,EXPFRE,NSMTAB,NTFREE COMMON /XCHAR/ ADC DATA ERRM /' RIGHT-HAND SIDE SPACE OVERFLOW'/ CALL INITDP(NWRITE,EXPR,LEXPR,FLAG,LFLAG,STM,LSTM,VAR,LVAR) CNVERG = ADC(20) 10 CONTINUE IF (CNVERG .EQ. ADC(20)) THEN CNVERG = ADC(51) ST = 0 20 CONTINUE ST = ST + 1 IF (ST .GT. STNCNT) GO TO 10 SF = STM(7*LSTM+ST+2) K = STM(6*LSTM+ST) 30 CONTINUE P = STM(8*LSTM+K+4) IF (P .NE. 0) THEN IF (P .NE. (-1)) THEN PF = STM(7*LSTM+P+2) IF (PF .NE. 0) THEN DO 40 I = 1, NSMTAB IF ((ADDR(FLAG(SF+I)) - ADDR(FLAG(PF+I))) * .GE. 0) GO TO 40 FLAG(SF+I) = ADC(51) CNVERG = ADC(20) 40 CONTINUE END IF K = K + 1 GO TO 30 END IF K = STM(8*LSTM+K+5) GO TO 30 END IF IF (STM(4*LSTM+ST) .NE. 0) K = STM(5*LSTM+ST) IF ((STM(4*LSTM+ST) .EQ. 0) .OR. (K .EQ. 0)) GO TO 20 L = SF + STM(4*LSTM+ST) VAR(LVAR+ST) = FLAG(L) IF (FLAG(L) .NE. ADC(20)) GO TO 20 VAR(LVAR+ST) = ADC(51) 50 CONTINUE Q = RHS(K) IF (Q .EQ. 0) GO TO 20 IF (FLAG(SF+Q) .EQ. ADC(51)) THEN FLAG(L) = ADC(51) CNVERG = ADC(20) GO TO 20 END IF K = K + 1 GO TO 50 END IF DO 70 ST = 1, STNCNT SF = STM(7*LSTM+ST+2) K = STM(5*LSTM+ST) IF (K .NE. 0) THEN IF ((STM(4*LSTM+ST) .NE. 0) .AND. (VAR(LVAR+ST) .EQ. * ADC(20))) FLAG(SF+STM(4*LSTM+ST)) = ADC(20) KK = K 60 CONTINUE Q = RHS(K) IF (Q .NE. 0) THEN IF (FLAG(SF+Q) .EQ. ADC(51)) THEN RHS(KK) = Q KK = KK + 1 IF (KK .GE. LRHS) CALL ERRORM(ERRM,NWRITE) END IF K = K + 1 GO TO 60 END IF IF (KK .EQ. STM(5*LSTM+ST)) THEN STM(5*LSTM+ST) = 0 GO TO 70 END IF RHS(KK) = 0 END IF 70 CONTINUE RETURN C C LAST CARD OF SUBROUTINE DEPEND. C END C********************************************************************** SUBROUTINE NEED(NWRITE,EXPR,LEXPR,RHS,LRHS,FLAG,LFLAG,STM, * LSTM,VAR,LVAR) INTEGER NWRITE,LEXPR,LRHS,LFLAG,LSTM,LVAR CHARACTER FLAG(0:2*LFLAG),VAR(9*LVAR) INTEGER EXPR(0:4*LEXPR),RHS(LRHS),STM(16*LSTM+6) CHARACTER CNVERG CHARACTER ADC(86) CHARACTER*70 ERRM INTEGER ADDR,CRYPNT,EXPFRE,I,IN,INDS,K,L,LABCNT,NSMTAB,NTFREE, * OUT,P,RESULT,RHSFST,RHSLST,S,SF,ST,STF,STNCNT,TYPRSL COMMON /CONTRL/ IN,OUT,RESULT,TYPRSL COMMON /INDEX/ INDS,LABCNT,RHSFST,RHSLST,STNCNT COMMON /COUNTR/ CRYPNT,EXPFRE,NSMTAB,NTFREE COMMON /XCHAR/ ADC DATA ERRM /' WRONG SUCCESSOR STRUCTURE'/ CALL INITND(EXPR,LEXPR,FLAG,LFLAG,STM,LSTM,VAR,LVAR) CNVERG = ADC(20) 10 CONTINUE IF (CNVERG .EQ. ADC(20)) THEN CNVERG = ADC(51) ST = STNCNT + 1 20 CONTINUE ST = ST - 1 IF (ST .LT. 1) GO TO 10 K = STM(LSTM+ST) S = STM(2*LSTM+K) IF (S .EQ. 0) CALL ERRORM(ERRM,NWRITE) SF = STM(7*LSTM+S+2) DO 30 I = 1, NSMTAB VAR(2*LVAR+I) = FLAG(LFLAG+SF+I+1) 30 CONTINUE K = K + 1 40 CONTINUE S = STM(2*LSTM+K) IF (S .NE. 0) THEN SF = STM(7*LSTM+S+2) DO 50 I = 1, NSMTAB IF ((ADDR(VAR(2*LVAR+I)) - ADDR(FLAG(LFLAG+SF+I+1))) * .LT. 0) VAR(2*LVAR+I) = ADC(51) 50 CONTINUE K = K + 1 GO TO 40 END IF L = STM(4*LSTM+ST) IF (L .NE. 0) THEN VAR(ST) = VAR(2*LVAR+L) IF (VAR(2*LVAR+L) .EQ. ADC(51)) THEN VAR(2*LVAR+L) = ADC(20) K = STM(5*LSTM+ST) IF (K .NE. 0) THEN 60 CONTINUE P = RHS(K) IF (P .NE. 0) THEN VAR(2*LVAR+P) = ADC(51) K = K + 1 GO TO 60 END IF END IF END IF END IF STF = STM(7*LSTM+ST+2) I = 0 70 CONTINUE I = I + 1 IF (I .GT. NSMTAB) GO TO 20 IF ((ADDR(FLAG(LFLAG+STF+I+1)) - ADDR(VAR(2*LVAR+I))) .GE. 0) * GO TO 70 FLAG(LFLAG+STF+I+1) = ADC(51) CNVERG = ADC(20) GO TO 70 END IF DO 80 ST = 1, STNCNT IF ((STM(4*LSTM+ST) .NE. 0) .AND. (VAR(ST) .EQ. ADC(20))) * STM(4*LSTM+ST) = 0 80 CONTINUE RETURN C C LAST CARD OF SUBROUTINE NEED. C END C********************************************************************** SUBROUTINE RELEV(EXPR,LEXPR,RHS,LRHS,STM,LSTM,VAR,LVAR) INTEGER LEXPR,LRHS,LSTM,LVAR CHARACTER VAR(9*LVAR) INTEGER EXPR(0:4*LEXPR),RHS(LRHS),STM(16*LSTM+6) CHARACTER ADC(86) INTEGER CRYPNT,EXPFRE,I,IN,INDS,K,LABCNT,NSMTAB,NTFREE,OUT,P, * Q,RESULT,RHSFST,RHSLST,ST,STNCNT,TYPRSL INTEGER AD(86) COMMON /INDEX/ INDS,LABCNT,RHSFST,RHSLST,STNCNT COMMON /CONTRL/ IN,OUT,RESULT,TYPRSL COMMON /COUNTR/ CRYPNT,EXPFRE,NSMTAB,NTFREE COMMON /ZCHAR/ AD COMMON /XCHAR/ ADC DO 10 I = 1, NSMTAB VAR(3*LVAR+I) = ADC(20) 10 CONTINUE P = IN 20 CONTINUE IF (EXPR(2*LEXPR+P) .EQ. AD(30)) THEN I = EXPR(3*LEXPR+EXPR(3*LEXPR+P)) VAR(3*LVAR+I) = ADC(51) P = EXPR(P) GO TO 20 END IF DO 40 ST = 1, STNCNT IF (STM(4*LSTM+ST) .EQ. 0) GO TO 40 VAR(3*LVAR+STM(4*LSTM+ST)) = ADC(51) K = STM(5*LSTM+ST) IF (K .EQ. 0) GO TO 40 30 CONTINUE Q = RHS(K) IF (Q .EQ. 0) GO TO 40 VAR(3*LVAR+Q) = ADC(51) K = K + 1 GO TO 30 40 CONTINUE RETURN C C LAST CARD OF SUBROUTINE RELEV. C END C*********************************************************************** INTEGER FUNCTION ALLOCT(OPER,L,R,NWRITE,EXPR,LEXPR) C C THIS ROUTINE RETURNS THE INDEX OF A NODE, IN THE EXPRESSION C TREE, WITH FIELDS OPER, L AND R. C INTEGER OPER,L,R,NWRITE,LEXPR INTEGER EXPR(0:4*LEXPR) INTEGER CRYPNT,EXPFRE,NSMTAB,NTFREE,P CHARACTER*70 ERRM LOGICAL TEMP COMMON /COUNTR/ CRYPNT,EXPFRE,NSMTAB,NTFREE DATA ERRM /' OVERFLOW OF EXPRESSION SPACE'/ IF (EXPFRE .GT. LEXPR) CALL ERRORM(ERRM,NWRITE) DO 10 P = 1, EXPFRE-1 TEMP = OPER .EQ. EXPR(2*LEXPR+P) IF (TEMP) TEMP = L .EQ. EXPR(P) IF (TEMP) TEMP = R .EQ. EXPR(3*LEXPR+P) IF (.NOT. TEMP) GO TO 10 GO TO 20 10 CONTINUE P = EXPFRE EXPFRE = EXPFRE + 1 EXPR(2*LEXPR+P) = OPER EXPR(P) = L EXPR(3*LEXPR+P) = R 20 CONTINUE ALLOCT = P RETURN C C LAST CARD OF INTEGER FUNCTION ALLOCT. C END C************************************************************************ INTEGER FUNCTION FCN(ID,ARG,NWRITE,EXPR,LEXPR,VARD,LVARD) C C THIS ROUTINE CHECKS WHETHER THE ID CORRESPONDS TO A LIBRARY C FUNCTION. IF IT DOES, THE NODE CORRESPONDING TO THAT FUNCTION C IS RETURNED. IF IT DOES NOT, A GAMMA NODE IS RETURNED. C INTEGER ID,ARG,NWRITE,LEXPR,LVARD INTEGER EXPR(0:4*LEXPR),VARD(8*LVARD) INTEGER ALLOCT,I,LEX,T,VD INTEGER AD(86),LIBDBL(14),LIBSGL(14),LIBTKN(0:14) COMMON /LIB/ LIBDBL,LIBSGL,LIBTKN COMMON /ZCHAR/ AD LEX = -1 IF (EXPR(2*LEXPR+ID) .EQ. AD(13)) LEX = VARD(EXPR(3*LEXPR+ID)) I = 0 10 CONTINUE I = I + 1 IF (LIBSGL(I) .NE. 0) THEN IF (LEX .NE. LIBSGL(I)) GO TO 10 T = LIBTKN(I) VD = EXPR(3*LEXPR+ID) VARD(6*LVARD+VD) = 3 VARD(LVARD+VD) = 768 VARD(5*LVARD+VD) = 0 FCN = ALLOCT(T,24,ARG,NWRITE,EXPR,LEXPR) GO TO 30 ELSE I = 0 20 CONTINUE I = I + 1 IF (LIBDBL(I) .NE. 0) THEN IF (LEX .NE. LIBDBL(I)) GO TO 20 T = LIBTKN(I) VD= EXPR(3*LEXPR+ID) VARD(6*LVARD+VD) = 4 VARD(LVARD+VD) = 1024 VARD(5*LVARD+VD) = 0 FCN = ALLOCT(T,32,ARG,NWRITE,EXPR,LEXPR) GO TO 30 END IF END IF FCN = ALLOCT(4,ID,ARG,NWRITE,EXPR,LEXPR) 30 CONTINUE RETURN C C LAST CARD OF INTEGER FUNCTION FCN. C END C****************************************************************** SUBROUTINE SEQN(P,SAVE,LSAVE,NWRITE,EXPR,LEXPR,STM,LSTM) INTEGER P,LSAVE,NWRITE,LEXPR,LSTM INTEGER SAVE(0:5*LSAVE+4),EXPR(0:4*LEXPR),STM(16*LSTM+6) INTEGER ALLOCT,IEXIT,INDS,LABCNT,RHSFST,RHSLST,STHOLD,STNCNT, * T,TP INTEGER AD(86) CHARACTER*70 ERRM COMMON /INDEX/ INDS,LABCNT,RHSFST,RHSLST,STNCNT COMMON /ZCHAR/ AD DATA ERRM /' SAVE SPACE OVERFLOW IN SEQN'/ IEXIT = 0 GO TO 20 10 CONTINUE IEXIT = IEXIT + 1 SAVE(IEXIT) = STHOLD SAVE(IEXIT+LSAVE+1) = TP 20 CONTINUE IF (IEXIT .GE. LSAVE) CALL ERRORM(ERRM,NWRITE) IF (P .EQ. 0) GO TO 100 IF (EXPR(2*LEXPR+P) .EQ. AD(27)) GO TO 30 IF (EXPR(2*LEXPR+P) .EQ. AD(10)) GO TO 50 IF (EXPR(2*LEXPR+P) .EQ. 24) GO TO 70 IF (EXPR(2*LEXPR+P) .EQ. AD(28)) GO TO 80 GO TO 90 30 CONTINUE TP = P P = EXPR(P) SAVE(3*LSAVE+IEXIT+3) = 1 GO TO 10 40 CONTINUE TP = P P = EXPR(3*LEXPR+P) SAVE(3*LSAVE+IEXIT+3) = 2 GO TO 10 50 CONTINUE CALL COUNT(NWRITE,P,STM,LSTM) STHOLD = STNCNT TP = P P = EXPR(3*LEXPR+P) SAVE(3*LSAVE+IEXIT+3) = 3 GO TO 10 60 CONTINUE STM(LSTM+STNCNT) = STHOLD T = ALLOCT(AD(33),0,STNCNT+1,NWRITE,EXPR,LEXPR) STM(STHOLD) = ALLOCT(AD(10),EXPR(P),T,NWRITE,EXPR,LEXPR) GO TO 100 70 CONTINUE CALL COUNT(NWRITE,P,STM,LSTM) CALL COUNT(NWRITE,EXPR(3*LEXPR+P),STM,LSTM) GO TO 100 80 CONTINUE IF ((EXPR(2*LEXPR+EXPR(3*LEXPR+P)) .EQ. 31) .OR. * (EXPR(2*LEXPR+EXPR(3*LEXPR+P)) .EQ. 11)) THEN CALL COUNT(NWRITE,P,STM,LSTM) GO TO 100 END IF T = ALLOCT(31,0,0,NWRITE,EXPR,LEXPR) T = ALLOCT(AD(28),EXPR(P),T,NWRITE,EXPR,LEXPR) CALL COUNT(NWRITE,T,STM,LSTM) TP = P P = EXPR(3*LEXPR+P) SAVE(3*LSAVE+IEXIT+3) = 4 GO TO 10 90 CONTINUE CALL COUNT(NWRITE,P,STM,LSTM) 100 CONTINUE IF (IEXIT .NE. 0) THEN STHOLD = SAVE(IEXIT) P = SAVE(IEXIT+LSAVE+1) IEXIT = IEXIT - 1 GO TO (40,100,60,100),SAVE(3*LSAVE+IEXIT+3) END IF RETURN C C LAST CARD OF SUBROUTINE SEQN. C END C*********************************************************************** INTEGER FUNCTION SRCHLB(NWRITE,LABEL,EXPR,LEXPR,STM,LSTM,LBL,LLBL) INTEGER NWRITE,LABEL,LEXPR,LSTM,LLBL INTEGER EXPR(0:4*LEXPR),STM(16*LSTM+6),LBL(LLBL) INTEGER I,INDS,LABCNT,P,RHSFST,RHSLST,ST,STNCNT INTEGER AD(86) CHARACTER*70 ERRM COMMON /INDEX/ INDS,LABCNT,RHSFST,RHSLST,STNCNT COMMON /ZCHAR/ AD DATA ERRM /' LABEL LIMIT EXCEEDED'/ ST = 0 10 CONTINUE ST = ST + 1 IF (ST .LE. STNCNT) THEN P = STM(ST) IF (EXPR(2*LEXPR+P) .NE. AD(28)) GO TO 10 IF (EXPR(3*LEXPR+EXPR(P)) .NE. LABEL) GO TO 10 DO 20 I = 1, LABCNT IF (LBL(I) .EQ. LABEL) GO TO 30 20 CONTINUE LABCNT = LABCNT + 1 IF (LABCNT .GT. LLBL) CALL ERRORM(ERRM,NWRITE) LBL(LABCNT) = LABEL 30 CONTINUE SRCHLB = ST GO TO 40 END IF SRCHLB = -1 40 CONTINUE RETURN C C LAST CARD OF INTEGER FUNCTION SRCHLB. C END C*********************************************************************** SUBROUTINE SUCLST(NWRITE,P,EXPR,LEXPR,STM,LSTM,LBL,LLBL) INTEGER NWRITE,P,LEXPR,LSTM,LLBL INTEGER EXPR(0:4*LEXPR),STM(16*LSTM+6),LBL(LLBL) INTEGER INDS,LABCNT,PP,Q,RHSFST,RHSLST,SRCHLB,STNCNT INTEGER AD(86) COMMON /INDEX/ INDS,LABCNT,RHSFST,RHSLST,STNCNT COMMON /ZCHAR/ AD PP = P 10 CONTINUE IF (EXPR(2*LEXPR+PP) .EQ. AD(30)) THEN Q = EXPR(3*LEXPR+PP) STM(2*LSTM+INDS) = SRCHLB(NWRITE,EXPR(3*LEXPR+Q),EXPR,LEXPR, * STM,LSTM,LBL,LLBL) INDS = INDS + 1 PP = EXPR(PP) GO TO 10 END IF STM(2*LSTM+INDS) = SRCHLB(NWRITE,EXPR(3*LEXPR+PP),EXPR,LEXPR, * STM,LSTM,LBL,LLBL) INDS = INDS + 1 RETURN C C LAST CARD OF SUBROUTINE SUCLST. C END C*********************************************************************** INTEGER FUNCTION LABELU(LABEL,LBL,LLBL) INTEGER LABEL,LLBL INTEGER LBL(LLBL) INTEGER I,INDS,LABCNT,RHSFST,RHSLST,STNCNT COMMON /INDEX/ INDS,LABCNT,RHSFST,RHSLST,STNCNT LABELU = 1 DO 10 I = 1, LABCNT IF (LBL(I) .EQ. LABEL) GO TO 20 10 CONTINUE LABELU = 0 20 CONTINUE RETURN C C LAST CARD OF INTEGER FUNCTION LABELU. C END C************************************************************************ INTEGER FUNCTION FREEPD(PRDLST,NWRITE,STM,LSTM) C C THIS ROUTINE ALLOCATES A BATCH OF 8 CONSECUTIVE PREDECESSOR C SLOTS AND ZEROS THEM OUT. C INTEGER PRDLST,NWRITE,LSTM INTEGER STM(16*LSTM+6) INTEGER F,I CHARACTER*70 ERRM DATA ERRM /' OVERFLOW OF STATEMENT SPACE'/ F = PRDLST DO 10 I = 1, 8 IF (PRDLST .GT. 8*LSTM) CALL ERRORM(ERRM,NWRITE) STM(8*LSTM+PRDLST+4) = 0 PRDLST = PRDLST + 1 10 CONTINUE FREEPD = F RETURN C C LAST CARD OF INTEGER FUNCTION FREEPD. C END C************************************************************************ INTEGER FUNCTION TYPEOF(V,EXPR,LEXPR,VARD,LVARD) C C THIS ROUTINE RETURNS THE TYPE OF VARIABLE V WHICH DEPENDS ON C WHETHER IT IS CALLED BEFORE OR AFTER THE TYPE HAS BEEN C RECODED. IF BEFORE WE GET 256*TYPE + LENGTH. IF AFTER WE GET C 8*TYPE + LENGTH. C INTEGER V,LEXPR,LVARD INTEGER EXPR(0:4*LEXPR),VARD(8*LVARD) INTEGER AD(86) COMMON /ZCHAR/ AD TYPEOF = -1 IF (EXPR(2*LEXPR+V) .EQ. AD(13)) * TYPEOF = VARD(LVARD+EXPR(3*LEXPR+V)) IF (EXPR(2*LEXPR+V) .EQ. AD(34)) * TYPEOF = VARD(LVARD+EXPR(3*LEXPR+EXPR(V))) RETURN C C LAST CARD OF INTEGER FUNCTION TYPEOF. C END C*********************************************************************** SUBROUTINE INPRD(ST,PREDST,PRDLST,NWRITE,STM,LSTM) C C THIS ROUTINE ENTERS PREDST BEFORE ST IN THE DATA STRUCTURE. C INTEGER ST,PREDST,PRDLST,NWRITE,LSTM INTEGER STM(16*LSTM+6) INTEGER FREEPD,I,IT,J,PRDST1 I = STM(6*LSTM+ST) 10 CONTINUE IF (STM(8*LSTM+I+4) .NE. 0) THEN IF (STM(8*LSTM+I+4) .EQ. (-1)) THEN I = STM(8*LSTM+I+5) GO TO 10 END IF I = I + 1 GO TO 10 END IF IT = I/8 IT = 8*IT IT = I - IT IF (IT .NE. 0) THEN STM(8*LSTM+I+4) = PREDST ELSE PRDST1 = STM(8*LSTM+I+3) STM(8*LSTM+I+3) = -1 STM(8*LSTM+I+4) = FREEPD(PRDLST,NWRITE,STM,LSTM) J = STM(8*LSTM+I+4) STM(8*LSTM+J+4) = PRDST1 STM(8*LSTM+J+5) = PREDST END IF RETURN C C LAST CARD OF SUBROUTINE INPRD. C END C************************************************************************* SUBROUTINE INRTS(VD,NWRITE,RHS,LRHS) INTEGER VD,NWRITE,LRHS INTEGER RHS(LRHS) INTEGER INDS,J,LABCNT,RHSFST,RHSLST,STNCNT CHARACTER*70 ERRM COMMON /INDEX/ INDS,LABCNT,RHSFST,RHSLST,STNCNT DATA ERRM /' RIGHT-HAND-SIDE SPACE OVERFLOW'/ DO 10 J = RHSFST, RHSLST-1 IF (RHS(J) .EQ. VD) GO TO 20 10 CONTINUE RHS(RHSLST) = VD RHSLST = RHSLST + 1 IF (RHSLST .GT. LRHS) CALL ERRORM(ERRM,NWRITE) 20 CONTINUE RETURN C C LAST CARD OF SUBROUTINE INRTS. C END C************************************************************************* SUBROUTINE GETRHS(P,SAVE,LSAVE,NWRITE,EXPR,LEXPR,RHS,LRHS,VARD, * LVARD) INTEGER P,LSAVE,NWRITE,LEXPR,LRHS,LVARD INTEGER SAVE(0:5*LSAVE+4),EXPR(0:4*LEXPR),RHS(LRHS),VARD(8*LVARD) INTEGER IEXIT,T,TEMP,TKN,TP,TYPEOF,VD INTEGER AD(86),ARITY(0:255),DEFLEN(42),DEFTYP(42),DESCR(1000) CHARACTER*70 ERRM COMMON /DATAB/ ARITY,DEFLEN,DEFTYP,DESCR COMMON /ZCHAR/ AD DATA ERRM /' SAVE SPACE OVERFLOW IN GETRHS'/ IEXIT = 0 GO TO 20 10 CONTINUE IEXIT = IEXIT + 1 SAVE(IEXIT) = TP 20 CONTINUE IF (IEXIT .GE. LSAVE) CALL ERRORM(ERRM,NWRITE) IF (P .EQ. 0) GO TO 70 TKN = EXPR(2*LEXPR+P) TEMP = ARITY(TKN) + 1 IF (TEMP .GT. 0 .AND. TEMP .LE. 3) GO TO (30,40,50), TEMP GO TO 70 30 CONTINUE IF (TKN .NE. AD(13)) GO TO 70 VD = EXPR(3*LEXPR+P) T = TYPEOF(P,EXPR,LEXPR,VARD,LVARD) IF (T .GE. 24) CALL INRTS(VD,NWRITE,RHS,LRHS) GO TO 70 40 CONTINUE TP = P P = EXPR(3*LEXPR+P) SAVE(3*LSAVE+IEXIT+3) = 1 GO TO 10 50 CONTINUE IF (TKN .EQ. 4) THEN IF (TYPEOF(EXPR(P),EXPR,LEXPR,VARD,LVARD) .LT. 24) * GO TO 70 TP = P P = EXPR(3*LEXPR+P) SAVE(3*LSAVE+IEXIT+3) = 2 GO TO 10 END IF IF (TKN .EQ. AD(34)) THEN TP = P P = EXPR(P) SAVE(3*LSAVE+IEXIT+3) = 3 GO TO 10 END IF TP = P P = EXPR(P) SAVE(3*LSAVE+IEXIT+3) = 4 GO TO 10 60 CONTINUE TP = P P = EXPR(3*LEXPR+P) SAVE(3*LSAVE+IEXIT+3) = 5 GO TO 10 70 CONTINUE IF (IEXIT .NE. 0) THEN P = SAVE(IEXIT) IEXIT = IEXIT - 1 GO TO (70,70,70,60,70), SAVE(3*LSAVE+IEXIT+3) END IF RETURN C C LAST CARD OF SUBROUTINE GETRHS. C END C*********************************************************************** SUBROUTINE INITDP(NWRITE,EXPR,LEXPR,FLAG,LFLAG,STM,LSTM,VAR,LVAR) INTEGER NWRITE,LEXPR,LFLAG,LSTM,LVAR CHARACTER FLAG(0:2*LFLAG),VAR(9*LVAR) INTEGER EXPR(0:4*LEXPR),STM(16*LSTM+6) CHARACTER ADC(86) CHARACTER*70 ERRM INTEGER CRYPNT,EXPFRE,I,IN,INDS,K,LABCNT,NSMTAB,NTFREE,OUT, * RESULT,RHSFST,RHSLST,ST,STFRST,STNCNT,TYPRSL INTEGER AD(86) COMMON /COUNTR/ CRYPNT,EXPFRE,NSMTAB,NTFREE COMMON /INDEX/ INDS,LABCNT,RHSFST,RHSLST,STNCNT COMMON /CONTRL/ IN,OUT,RESULT,TYPRSL COMMON /ZCHAR/ AD COMMON /XCHAR/ ADC DATA ERRM /' OVERFLOW OF FLAG SPACE'/ DO 10 I = 1, NSMTAB FLAG(I) = ADC(20) 10 CONTINUE K = IN 20 CONTINUE IF (EXPR(2*LEXPR+K) .EQ. AD(30)) THEN FLAG(EXPR(3*LEXPR+EXPR(3*LEXPR+K))) = ADC(51) K = EXPR(K) GO TO 20 END IF FLAG(EXPR(3*LEXPR+K)) = ADC(51) STM(7*LSTM+2) = 0 DO 40 ST = 1, STNCNT+2 STFRST = STM(7*LSTM+ST+1) + NSMTAB STM(7*LSTM+ST+2) = STFRST IF (STFRST + NSMTAB .GT. LFLAG) CALL ERRORM(ERRM,NWRITE) DO 30 I = 1, NSMTAB FLAG(STFRST+I) = FLAG(I) 30 CONTINUE VAR(LVAR+ST) = ADC(20) 40 CONTINUE RETURN C C LAST CARD OF SUBROUTINE INITDP. C END C*********************************************************************** SUBROUTINE INITND(EXPR,LEXPR,FLAG,LFLAG,STM,LSTM,VAR,LVAR) INTEGER LEXPR,LFLAG,LSTM,LVAR CHARACTER FLAG(0:2*LFLAG),VAR(9*LVAR) INTEGER EXPR(0:4*LEXPR),STM(16*LSTM+6) CHARACTER ADC(86) INTEGER CRYPNT,EXPFRE,I,IN,INDS,K,LABCNT,NSMTAB,NTFREE,OUT, * RESULT,RHSFST,RHSLST,ST,STFRST,STNCNT,TYPRSL INTEGER AD(86) COMMON /COUNTR/ CRYPNT,EXPFRE,NSMTAB,NTFREE COMMON /INDEX/ INDS,LABCNT,RHSFST,RHSLST,STNCNT COMMON /CONTRL/ IN,OUT,RESULT,TYPRSL COMMON /ZCHAR/ AD COMMON /XCHAR/ ADC DO 20 ST = 1, STNCNT+2 STFRST = STM(7*LSTM+ST+2) DO 10 I = 1, NSMTAB FLAG(LFLAG+STFRST+I+1) = ADC(20) 10 CONTINUE VAR(ST) = ADC(20) 20 CONTINUE K = OUT STFRST = STM(7*LSTM+STNCNT+3) 30 CONTINUE IF (EXPR(2*LEXPR+K) .EQ. AD(30)) THEN FLAG(LFLAG+STFRST+EXPR(3*LEXPR+EXPR(3*LEXPR+K))+1) = ADC(51) K = EXPR(K) GO TO 30 END IF FLAG(LFLAG+STFRST+EXPR(3*LEXPR+K)+1) = ADC(51) RETURN C C LAST CARD OF SUBROUTINE INITND. C END C*********************************************************************** INTEGER FUNCTION LOCSTR(STR,NMTBL,LNMTBL) C C THIS ROUTINE RETURNS THE POINTER TO THE LOCATION OF "STR" IN THE C NAME TABLE. IN THIS VERSION, STR MUST BE IN THE NAME TABLE. IT IS C NOT ADDED TO IT. C INTEGER LNMTBL CHARACTER STR(*),NMTBL(0:LNMTBL) CHARACTER ADC(86) INTEGER J,K,NTIND COMMON /XCHAR/ ADC J = 1 10 CONTINUE IF (NMTBL(J) .NE. ADC(22)) THEN NTIND = J K = 1 20 CONTINUE IF ((NMTBL(J) .EQ. STR(K)) .AND. * (STR(K) .NE. ADC(22))) THEN J = J + 1 K = K + 1 GO TO 20 END IF IF (NMTBL(J) .EQ. STR(K)) THEN LOCSTR = NTIND GO TO 40 END IF 30 CONTINUE IF (NMTBL(J) .NE. ADC(22)) THEN J = J + 1 GO TO 30 END IF J = J + 1 GO TO 10 END IF LOCSTR = -1 40 CONTINUE RETURN C C LAST CARD OF INTEGER FUNCTION LOCSTR. C END C********************************************************************** SUBROUTINE COUNT(NWRITE,P,STM,LSTM) INTEGER NWRITE,P,LSTM INTEGER STM(16*LSTM+6) INTEGER INDS,LABCNT,RHSFST,RHSLST,STNCNT CHARACTER*70 ERRM COMMON /INDEX/ INDS,LABCNT,RHSFST,RHSLST,STNCNT DATA ERRM /' OVERFLOW OF STATEMENT SPACE'/ STNCNT = STNCNT + 1 IF (STNCNT .GT. LSTM) CALL ERRORM(ERRM,NWRITE) STM(STNCNT) = P STM(LSTM+STNCNT) = 0 RETURN C C LAST CARD OF SUBROUTINE COUNT. C END C*********************************************************************** C SUBROUTINES FOR SYMBOLIC DIFFERENTIATOR. C*********************************************************************** INTEGER FUNCTION DISTBR(OPER,L,R,NWRITE,EXPR,LEXPR) C C THIS ROUTINE RETURNS THE INDEX OF A NODE, IN THE EXPRESION TREE, C WITH FIELDS OPER, L, AND R. C INTEGER OPER,L,R,NWRITE,LEXPR INTEGER CRYPNT,EXPFRE,NSMTAB,NTFREE,P INTEGER CHAIN(0:255),EXPR(0:4*LEXPR) CHARACTER*70 ERRM COMMON /COUNTR/ CRYPNT,EXPFRE,NSMTAB,NTFREE COMMON /NODE/ CHAIN DATA ERRM /' OVERFLOW OF EXPRESSION SPACE'/ P = CHAIN(OPER) 10 CONTINUE IF (P .NE. 0) THEN IF (R .EQ. EXPR(3*LEXPR+P) .AND. L .EQ. EXPR(P)) THEN DISTBR = P GO TO 20 END IF P = EXPR(LEXPR+P) GO TO 10 END IF IF (EXPFRE .GT. LEXPR) CALL ERRORM(ERRM,NWRITE) P = EXPFRE EXPFRE = EXPFRE + 1 EXPR(2*LEXPR+P) = OPER EXPR(P) = L EXPR(3*LEXPR+P) = R EXPR(LEXPR+P) = CHAIN(OPER) CHAIN(OPER) = P DISTBR = P 20 CONTINUE RETURN C C LAST CARD OF INTEGER FUNCTION DISTBR. C END C********************************************************************** INTEGER FUNCTION ALCADD(SAVE,LSAVE,NWRITE,EXPR,LEXPR,NMTBL, * LNMTBL,VAR,LVAR,VARD,LVARD,TLIM) INTEGER LSAVE,NWRITE,LEXPR,LNMTBL,LVAR,LVARD,TLIM CHARACTER NMTBL(0:LNMTBL),VAR(9*LVAR) INTEGER SAVE(0:5*LSAVE+4),EXPR(0:4*LEXPR),VARD(8*LVARD) CHARACTER ADC(86) INTEGER ADDRX,CRYPNT,DISTBR,EXPFRE,GENNAM,I,INIT,INITBD,INTADD, * MULTPL,NSMTAB,NTFREE,P INTEGER AD(86) COMMON /COUNTR/ CRYPNT,EXPFRE,NSMTAB,NTFREE COMMON /ADDX/ INITBD,INTADD COMMON /ZCHAR/ AD COMMON /XCHAR/ ADC CALL GENGRV(NWRITE,EXPR,LEXPR,NMTBL,LNMTBL,VAR,LVAR,VARD, * LVARD,TLIM) INTADD = 0 ADDRX = 0 DO 10 I = 1, NSMTAB IF (VAR(3*LVAR+I) .NE. ADC(51) .OR. VARD(2*LVARD+I) .NE. 0) * GO TO 10 ADDRX = ADDRX + 1 VARD(4*LVARD+I) = DISTBR(AD(33),0,ADDRX,NWRITE,EXPR,LEXPR) 10 CONTINUE INITBD = DISTBR(AD(33),0,ADDRX,NWRITE,EXPR,LEXPR) DO 20 I = NSMTAB, 1, -1 P = VARD(2*LVARD+I) IF (VAR(3*LVAR+I) .EQ. ADC(51) .AND. P .NE. 0) THEN NSMTAB = NSMTAB + 1 VARD(NSMTAB) = GENNAM(VARD(I),NWRITE,ADC(52),NMTBL, * LNMTBL) VARD(LVARD+NSMTAB) = 16 VARD(2*LVARD+NSMTAB) = 0 VARD(3*LVARD+NSMTAB) = 0 VARD(4*LVARD+NSMTAB) = -1 VAR(3*LVAR+NSMTAB) = ADC(20) VARD(4*LVARD+I) = DISTBR(AD(13),0,NSMTAB,NWRITE,EXPR,LEXPR) INIT = DISTBR(AD(31),VARD(4*LVARD+I),INITBD,NWRITE,EXPR, * LEXPR) INITBD = DISTBR(AD(23),VARD(4*LVARD+I),MULTPL(P,SAVE,LSAVE, * NWRITE,EXPR,LEXPR),NWRITE,EXPR,LEXPR) INTADD = DISTBR(AD(27),INTADD,INIT,NWRITE,EXPR,LEXPR) END IF 20 CONTINUE ALCADD = INTADD RETURN C C LAST CARD OF INTEGER FUNCTION ALCADD. C END C*********************************************************************** SUBROUTINE GENGRV(NWRITE,EXPR,LEXPR,NMTBL,LNMTBL,VAR,LVAR, * VARD,LVARD,TLIM) INTEGER NWRITE,LEXPR,LNMTBL,LVAR,LVARD,TLIM CHARACTER NMTBL(0:LNMTBL),VAR(9*LVAR) INTEGER EXPR(0:4*LEXPR),VARD(8*LVARD) CHARACTER ADC(86) CHARACTER ACHAR CHARACTER*70 ERRM1,ERRM2 INTEGER ADDR,CRYPNT,DISTBR,EXPFRE,GENNAM,I,IGRAD,IN,J,J1,JGRAD, * LEXOF,LGRAD,LYGRAD,NSMTAB,NTFREE,NTGRAD,NTLYGD,NTYGRD, * OUT,RESULT,RGRAD,T,T1,T2,TYPRSL,YGRAD INTEGER AD(86),DEPS(1000),PRIOR(1000),TEMP(1000) COMMON /GRAD/ IGRAD,JGRAD,LGRAD,LYGRAD,RGRAD,YGRAD COMMON /COUNTR/ CRYPNT,EXPFRE,NSMTAB,NTFREE COMMON /STORE/ DEPS,PRIOR,TEMP COMMON /NGRAD/ NTGRAD,NTLYGD,NTYGRD COMMON /CONTRL/ IN,OUT,RESULT,TYPRSL COMMON /ZCHAR/ AD COMMON /XCHAR/ ADC DATA ERRM1 /' VARIABLE LIMIT EXCEEDED'/ DATA ERRM2 /' OVERFLOW OF NAME TABLE SPACE'/ NTGRAD = LEXOF(RESULT,EXPR,LEXPR,VARD,LVARD) NTYGRD = GENNAM(NTGRAD,NWRITE,ADC(53),NMTBL,LNMTBL) NTLYGD = GENNAM(NTYGRD,NWRITE,ADC(48),NMTBL,LNMTBL) NSMTAB = NSMTAB + 1 VARD(NSMTAB) = NTLYGD VARD(LVARD+NSMTAB) = 16 VARD(2*LVARD+NSMTAB) = 0 VARD(3*LVARD+NSMTAB) = 0 VAR(3*LVAR+NSMTAB) = ADC(20) LYGRAD = DISTBR(AD(13),0,NSMTAB,NWRITE,EXPR,LEXPR) NSMTAB = NSMTAB + 1 VARD(NSMTAB) = NTYGRD VARD(LVARD+NSMTAB) = TYPRSL VARD(2*LVARD+NSMTAB) = LYGRAD VARD(3*LVARD+NSMTAB) = 0 VAR(3*LVAR+NSMTAB) = ADC(20) YGRAD = DISTBR(AD(13),0,NSMTAB,NWRITE,EXPR,LEXPR) NSMTAB = NSMTAB + 1 VARD(NSMTAB) = GENNAM(NTGRAD,NWRITE,ADC(52),NMTBL,LNMTBL) VARD(LVARD+NSMTAB) = 16 VARD(2*LVARD+NSMTAB) = 0 VARD(3*LVARD+NSMTAB) = 0 VAR(3*LVAR+NSMTAB) = ADC(20) IGRAD = DISTBR(AD(13),0,NSMTAB,NWRITE,EXPR,LEXPR) NSMTAB = NSMTAB + 1 VARD(NSMTAB) = GENNAM(NTGRAD,NWRITE,ADC(54),NMTBL,LNMTBL) VARD(LVARD+NSMTAB) = 16 VARD(2*LVARD+NSMTAB) = 0 VARD(3*LVARD+NSMTAB) = 0 VAR(3*LVAR+NSMTAB) = ADC(20) RGRAD = DISTBR(AD(13),0,NSMTAB,NWRITE,EXPR,LEXPR) IF (NMTBL(NTGRAD) .EQ. ADC(46)) GO TO 10 NSMTAB = NSMTAB + 1 VARD(NSMTAB) = GENNAM(NTGRAD,NWRITE,ADC(48),NMTBL,LNMTBL) VARD(LVARD+NSMTAB) = 16 VARD(2*LVARD+NSMTAB) = 0 VARD(3*LVARD+NSMTAB) = 0 VAR(3*LVAR+NSMTAB) = ADC(20) LGRAD = DISTBR(AD(13),0,NSMTAB,NWRITE,EXPR,LEXPR) NSMTAB = NSMTAB + 1 VARD(NSMTAB) = GENNAM(NTGRAD,NWRITE,ADC(55),NMTBL,LNMTBL) VARD(LVARD+NSMTAB) = 16 VARD(2*LVARD+NSMTAB) = 0 VARD(3*LVARD+NSMTAB) = 0 VAR(3*LVAR+NSMTAB) = ADC(20) JGRAD = DISTBR(AD(13),0,NSMTAB,NWRITE,EXPR,LEXPR) 10 CONTINUE T = ADDR('1') T1 = ADDR('0') T2 = ADDR('0') J = 1 J1 = 1 DO 20 I = 1, TLIM NSMTAB = NSMTAB + 1 IF (NSMTAB .GT. LVARD .OR. NSMTAB .GT. LVAR) * CALL ERRORM(ERRM1,NWRITE) VARD(NSMTAB) = GENNAM(NTGRAD,NWRITE,ADC(18),NMTBL,LNMTBL) NMTBL(NTFREE-2) = ADC(38) IF (J .GT. 9) THEN T = ADDR('0') J = 0 T1 = T1 + 1 END IF IF (J1 .GT. 99) THEN T1 = ADDR('0') J1 = 0 T2 = T2 + 1 END IF IF (I .GT. 99) THEN NMTBL(NTFREE-1) = ACHAR(T2) NTFREE = NTFREE + 1 END IF IF (I .GT. 9) THEN NMTBL(NTFREE-1) = ACHAR(T1) NTFREE = NTFREE + 1 END IF IF (NTFREE .GT. LNMTBL-2) CALL ERRORM(ERRM2,NWRITE) NMTBL(NTFREE-1) = ACHAR(T) NMTBL(NTFREE) = ADC(39) NMTBL(NTFREE+1) = ADC(22) NMTBL(NTFREE+2) = ADC(22) NTFREE = NTFREE + 2 J = J + 1 J1 = J1 + 1 T = T + 1 VARD(LVARD+NSMTAB) = TYPRSL VARD(2*LVARD+NSMTAB) = 0 VARD(3*LVARD+NSMTAB) = 0 VAR(3*LVAR+NSMTAB) = ADC(51) TEMP(I) = DISTBR(AD(13),0,NSMTAB,NWRITE,EXPR,LEXPR) 20 CONTINUE RETURN C C LAST CARD OF SUBROUTINE GENGRV. C END C*********************************************************************** INTEGER FUNCTION LEXOF(V,EXPR,LEXPR,VARD,LVARD) C C THIS ROUTINE RETURNS THE LEXICAL NAME OF THE VARIABLE V. C INTEGER V,LEXPR,LVARD INTEGER EXPR(0:4*LEXPR),VARD(8*LVARD) INTEGER AD(86) COMMON /ZCHAR/ AD LEXOF = -1 IF (EXPR(2*LEXPR+V) .EQ. AD(13)) LEXOF = VARD(EXPR(3*LEXPR+V)) RETURN C C LAST CARD OF INTEGER FUNCTION LEXOF. C END C*********************************************************************** INTEGER FUNCTION GENNAM(BASIND,NWRITE,FIRST,NMTBL,LNMTBL) C C THIS ROUTINE GENERATES AN UNUSED NAME RESEMBLING LEXEME BASIND. C CHARACTER FIRST,NMTBL(0:LNMTBL) INTEGER BASIND,NWRITE,LNMTBL CHARACTER ACHAR CHARACTER ADC(86),NAME(10) CHARACTER*70 ERRM INTEGER CRYPNT,D,EXPFRE,K,L,LNM,LOCSTR,N,NSMTAB,NTFREE,OFFSET,T INTEGER AD(86) COMMON /COUNTR/ CRYPNT,EXPFRE,NSMTAB,NTFREE COMMON /XCHAR/ ADC COMMON /ZCHAR/ AD DATA ERRM /' OVERFLOW OF NAME TABLE SPACE'/ LNM = 1 NAME(LNM) = FIRST K = BASIND 10 CONTINUE IF (NMTBL(K) .NE. ADC(22)) THEN LNM = LNM + 1 NAME(LNM) = NMTBL(K) K = K + 1 GO TO 10 END IF DO 30 OFFSET = 0, 9999 D = 4 IF (OFFSET .LT. 1000) D = 3 IF (OFFSET .LT. 100) D = 2 IF (OFFSET .LT. 10) D = 1 IF (OFFSET .EQ. 0) D = 0 IF (LNM+D .GT. 6) LNM = 6 - D L = LNM N = OFFSET 20 CONTINUE IF (N .GT. 0) THEN L = L + 1 T = N/10 T = N - T*10 + AD(20) NAME(L) = ACHAR(T) N = N/10 GO TO 20 END IF NAME(L+1) = ADC(22) IF (LOCSTR(NAME,NMTBL,LNMTBL) .EQ. -1) GO TO 40 30 CONTINUE 40 CONTINUE GENNAM = NTFREE K = 1 50 CONTINUE IF (NAME(K) .NE. ADC(22)) THEN IF (NTFREE .GT. LNMTBL-2) CALL ERRORM(ERRM,NWRITE) NMTBL(NTFREE) = NAME(K) NTFREE = NTFREE + 1 K = K + 1 GO TO 50 END IF NMTBL(NTFREE) = ADC(22) NTFREE = NTFREE + 1 NMTBL(NTFREE) = ADC(22) RETURN C C LAST CARD OF INTEGER FUNCTION GENNAM. C END C*********************************************************************** INTEGER FUNCTION MULTPL(PP,SAVE,LSAVE,NWRITE,EXPR,LEXPR) C C THIS ROUTINE CHANGES ALL TOP-LEVEL LISTERS IN P TO MULTS. C INTEGER PP,LSAVE,NWRITE,LEXPR INTEGER SAVE(0:5*LSAVE+4),EXPR(0:4*LEXPR) INTEGER DISTBR,IEXIT,P,TEMP1,TEMP2 INTEGER AD(86) CHARACTER*70 ERRM COMMON /ZCHAR/ AD DATA ERRM /' SAVE SPACE OVERFLOW IN MULTPL'/ IEXIT = 0 P = PP 10 CONTINUE MULTPL = P IF (IEXIT .GE. LSAVE) CALL ERRORM(ERRM,NWRITE) IF ((P .EQ. 0) .OR. (EXPR(2*LEXPR+P) .NE. AD(30))) GO TO 40 IEXIT = IEXIT + 1 SAVE(IEXIT) = P P = EXPR(P) SAVE(3*LSAVE+IEXIT+2) = 1 GO TO 10 20 CONTINUE TEMP1 = MULTPL IEXIT = IEXIT + 1 SAVE(IEXIT) = P P = EXPR(3*LEXPR+P) SAVE(3*LSAVE+IEXIT+2) = 2 GO TO 10 30 CONTINUE TEMP2 = MULTPL MULTPL = DISTBR(AD(25),TEMP1,TEMP2,NWRITE,EXPR,LEXPR) 40 CONTINUE IF (IEXIT .NE. 0) THEN P = SAVE(IEXIT) IEXIT = IEXIT - 1 GO TO (20,30),SAVE(3*LSAVE+IEXIT+3) END IF RETURN C C LAST CARD OF INTEGER FUNCTION MULTPL. C END C*********************************************************************** INTEGER FUNCTION HANDLE(ST,SAVE,LSAVE,NWRITE,EXPR,LEXPR,STM, * LSTM,VARD,LVARD) C C THIS ROUTINE EMITS FACTORS FOR STATEMENT ST. C INTEGER ST,LSAVE,NWRITE,LEXPR,LSTM,LVARD INTEGER SAVE(0:5*LSAVE+4),EXPR(0:4*LEXPR),STM(16*LSTM+6), * VARD(8*LVARD) INTEGER BLOCK,DEPCNT,DIFFER,DISTBR,P,PRIND,RADDR,S,TMPIND INTEGER AD(86),DEPS(1000),PRIOR(1000),TEMP(1000) COMMON /STORE/ DEPS,PRIOR,TEMP COMMON /TIND/ DEPCNT,PRIND,RADDR,TMPIND COMMON /ZCHAR/ AD BLOCK = 0 PRIND = 1 PRIOR(PRIND) = STM(ST) TMPIND = 0 10 CONTINUE IF (PRIND .GT. 0) THEN S = PRIOR(PRIND) PRIND = PRIND - 1 P = DIFFER(S,SAVE,LSAVE,NWRITE,EXPR,LEXPR,VARD,LVARD) BLOCK = DISTBR(AD(27),P,BLOCK,NWRITE,EXPR,LEXPR) GO TO 10 END IF HANDLE = BLOCK RETURN C C LAST CARD OF INTEGER FUNCTION HANDLE. C END C*********************************************************************** INTEGER FUNCTION MAKEEL(P,SAVE,LSAVE,NWRITE,EXPR,LEXPR,VARD,LVARD) INTEGER P,LSAVE,NWRITE,LEXPR,LVARD INTEGER SAVE(0:5*LSAVE+4),EXPR(0:4*LEXPR),VARD(8*LVARD) INTEGER ADDROF,CONST,DEPCNT,DISTBR,PRIND,RADDR,S,T,TKN,TMPIND INTEGER AD(86),ARITY(0:255),DEFLEN(42),DEFTYP(42),DEPS(1000), * DESCR(1000),PRIOR(1000),TEMP(1000) COMMON /TIND/ DEPCNT,PRIND,RADDR,TMPIND COMMON /STORE/ DEPS,PRIOR,TEMP COMMON /DATAB/ ARITY,DEFLEN,DEFTYP,DESCR COMMON /ZCHAR/ AD TKN = EXPR(2*LEXPR+P) IF ((TKN .EQ. AD(13)) .OR. (TKN .EQ. AD(34))) THEN RADDR = ADDROF(P,NWRITE,EXPR,LEXPR,VARD,LVARD) MAKEEL = P ELSE IF (ARITY(TKN) .EQ. 0) THEN RADDR = 0 MAKEEL = P ELSE TMPIND = TMPIND + 1 T = TEMP(TMPIND) S = DISTBR(AD(31),T,P,NWRITE,EXPR,LEXPR) IF (CONST(P,SAVE,LSAVE,NWRITE,EXPR,LEXPR,VARD,LVARD) * .EQ. 0) THEN DEPCNT = DEPCNT + 1 DEPS(DEPCNT) = EXPR(3*LEXPR+T) END IF PRIND = PRIND + 1 PRIOR(PRIND) = S RADDR = ADDROF(T,NWRITE,EXPR,LEXPR,VARD,LVARD) MAKEEL = T END IF RETURN C C LAST CARD OF INTEGER FUNCTION MAKEEL. C END C*********************************************************************** INTEGER FUNCTION COERCE(P,SAVE,LSAVE,NWRITE,EXPR,LEXPR,VARD,LVARD) C C THIS ROUTINE MAKES P OF TYPE "TYPRSL". C INTEGER P,LSAVE,NWRITE,LEXPR,LVARD INTEGER SAVE(0:5*LSAVE+4),EXPR(0:4*LEXPR),VARD(8*LVARD) INTEGER DISTBR,EXPTYP,FLTHLF,FLTNEG,FLTONE,FLTZER,IN,OUT,RESULT, * TIN,TOUT,TYPRSL INTEGER AD(86) COMMON /CONTRL/ IN,OUT,RESULT,TYPRSL COMMON /FLT/ FLTONE,FLTHLF,FLTNEG,FLTZER COMMON /ZCHAR/ AD TIN = EXPTYP(P,SAVE,LSAVE,NWRITE,EXPR,LEXPR,VARD,LVARD)/8 TOUT = TYPRSL/8 COERCE = P IF (TIN .LT. TOUT) COERCE = DISTBR(AD(23),P,FLTZER,NWRITE,EXPR, * LEXPR) IF (TIN .GT. TOUT) COERCE = DISTBR(AD(1),TYPRSL,P,NWRITE,EXPR, * LEXPR) RETURN C C LAST CARD OF INTEGER FUNCTION COERCE. C END C*********************************************************************** INTEGER FUNCTION CONST(PP,SAVE,LSAVE,NWRITE,EXPR,LEXPR,VARD,LVARD) INTEGER PP,LSAVE,NWRITE,LEXPR,LVARD INTEGER SAVE(0:5*LSAVE+4),EXPR(0:4*LEXPR),VARD(8*LVARD) INTEGER DEPCNT,I,IEXIT,P,PRIND,RADDR,TEMP1,TMPIND,TYPEOF INTEGER AD(86),ARITY(0:255),DEFLEN(42),DEFTYP(42),DEPS(1000), * DESCR(1000),PRIOR(1000),TEMP(1000) CHARACTER*70 ERRM COMMON /STORE/ DEPS,PRIOR,TEMP COMMON /TIND/ DEPCNT,PRIND,RADDR,TMPIND COMMON /DATAB/ ARITY,DEFLEN,DEFTYP,DESCR COMMON /ZCHAR/ AD DATA ERRM /' SAVE SPACE OVERFLOW IN CONST'/ IEXIT = 0 P = PP 10 CONTINUE IF (IEXIT .GE. LSAVE) CALL ERRORM(ERRM,NWRITE) CONST = 1 IF (P .EQ. 0) GO TO 70 TEMP1 = ARITY(EXPR(2*LEXPR+P)) + 1 IF (TEMP1 .GT. 0 .AND. TEMP1 .LE. 3) GO TO (20,40,50),TEMP1 GO TO 70 20 CONTINUE IF (EXPR(2*LEXPR+P) .EQ. AD(34)) P = EXPR(P) IF (EXPR(2*LEXPR+P) .NE. AD(13)) GO TO 70 DO 30 I = 1, DEPCNT IF (EXPR(3*LEXPR+P) .NE. DEPS(I)) GO TO 30 CONST = 0 GO TO 70 30 CONTINUE GO TO 70 40 CONTINUE IEXIT = IEXIT + 1 SAVE(IEXIT) = P P = EXPR(3*LEXPR+P) SAVE(3*LSAVE+IEXIT+2) = 1 GO TO 10 50 CONTINUE IF (EXPR(2*LEXPR+P) .EQ. 4) THEN IF (TYPEOF(EXPR(P),EXPR,LEXPR,VARD,LVARD) .GE. 24) * GO TO 40 CONST = 1 GO TO 70 END IF IEXIT = IEXIT + 1 SAVE(IEXIT) = P P = EXPR(P) SAVE(3*LSAVE+IEXIT+2) = 2 GO TO 10 60 CONTINUE IF (CONST .EQ. 1) GO TO 40 CONST = 0 70 CONTINUE IF (IEXIT .NE. 0) THEN P = SAVE(IEXIT) IEXIT = IEXIT - 1 GO TO (70,60),SAVE(3*LSAVE+IEXIT+3) END IF RETURN C C LAST CARD OF INTEGER FUNCTION CONST. C END C********************************************************************** INTEGER FUNCTION EXPTYP(PP,SAVE,LSAVE,NWRITE,EXPR,LEXPR,VARD, * LVARD) C C THIS ROUTINE RETURNS THE TYPE OF EXPRESSION USING MIXED MODE C ARITHMETIC RULES. C INTEGER PP,LSAVE,NWRITE,LEXPR,LVARD INTEGER SAVE(0:5*LSAVE+4),EXPR(0:4*LEXPR),VARD(8*LVARD) INTEGER IEXIT,J,P,T,TEMP,TYPEOF INTEGER AD(86),ARITY(0:255),DEFLEN(42),DEFTYP(42),DESCR(1000) CHARACTER*70 ERRM COMMON /DATAB/ ARITY,DEFLEN,DEFTYP,DESCR COMMON /ZCHAR/ AD DATA ERRM /' SAVE SPACE OVERFLOW IN EXPTYP'/ IEXIT = 0 P = PP 10 CONTINUE IF (IEXIT .GE. LSAVE) CALL ERRORM(ERRM,NWRITE) IF (P .EQ. 0) THEN EXPTYP = 16 GO TO 70 END IF T = EXPR(2*LEXPR+P) TEMP = ARITY(T) + 1 IF (TEMP .GT. 0 .AND. TEMP .LE. 3) GO TO (20,30,40), TEMP GO TO 70 20 CONTINUE IF (T .EQ. AD(34)) THEN P = EXPR(P) T = AD(13) END IF EXPTYP = 16 IF (T .EQ. AD(13)) EXPTYP = TYPEOF(P,EXPR,LEXPR,VARD,LVARD) IF (T .EQ. AD(29)) EXPTYP = EXPR(P) GO TO 70 30 CONTINUE IF (T .EQ. AD(35)) THEN IEXIT = IEXIT + 1 SAVE(IEXIT) = P P = EXPR(3*LEXPR+P) SAVE(3*LSAVE+IEXIT+2) = 1 GO TO 10 END IF EXPTYP = EXPR(P) GO TO 70 40 CONTINUE IF (T .EQ. 4) THEN EXPTYP = TYPEOF(EXPR(P),EXPR,LEXPR,VARD,LVARD) GO TO 70 END IF IEXIT = IEXIT + 1 SAVE(IEXIT) = P P = EXPR(P) SAVE(3*LSAVE+IEXIT+2) = 2 GO TO 10 50 CONTINUE J = EXPTYP IEXIT = IEXIT + 1 SAVE(IEXIT) = P P = EXPR(3*LEXPR+P) SAVE(3*LSAVE+IEXIT+2) = 3 GO TO 10 60 CONTINUE IF (J .GT. EXPTYP) EXPTYP = J 70 CONTINUE IF (IEXIT .NE. 0) THEN P = SAVE(IEXIT) IEXIT = IEXIT - 1 GO TO (70,50,60),SAVE(3*LSAVE+IEXIT+3) END IF RETURN C C LAST CARD OF INTEGER FUNCTION EXPTYP. C END C*********************************************************************** INTEGER FUNCTION ADDROF(V,NWRITE,EXPR,LEXPR,VARD,LVARD) INTEGER V,NWRITE,LEXPR,LVARD INTEGER EXPR(0:4*LEXPR),VARD(8*LVARD) INTEGER A,ARR,DIM,DIMOF,DISTBR,IND,INTONE,INTTWO,T INTEGER AD(86) CHARACTER*70 ERRM COMMON /INTS/ INTONE,INTTWO COMMON /ZCHAR/ AD DATA ERRM /' SUBSCRIPTED SCALAR ENCOUNTERED'/ IF (EXPR(2*LEXPR+V) .NE. AD(34)) THEN ADDROF = VARD(4*LVARD+EXPR(3*LEXPR+V)) GO TO 20 END IF ARR = EXPR(V) A = VARD(4*LVARD+EXPR(3*LEXPR+ARR)) IND = EXPR(3*LEXPR+V) IF (EXPR(2*LEXPR+IND) .NE. AD(30)) THEN ADDROF = DISTBR(AD(23),A,IND,NWRITE,EXPR,LEXPR) GO TO 20 END IF T = EXPR(3*LEXPR+IND) IND = EXPR(IND) DIM = DIMOF(ARR,EXPR,LEXPR,VARD,LVARD) IF (DIM .EQ. 0) CALL ERRORM(ERRM,NWRITE) DIM = EXPR(DIM) 10 CONTINUE IF (EXPR(2*LEXPR+IND) .EQ. AD(30)) THEN T = DISTBR(AD(23),DISTBR(AD(25),DISTBR(AD(24),T,INTONE, * NWRITE,EXPR,LEXPR),EXPR(3*LEXPR+DIM),NWRITE,EXPR,LEXPR), * EXPR(3*LEXPR+IND),NWRITE,EXPR,LEXPR) IND = EXPR(IND) DIM = EXPR(DIM) GO TO 10 END IF T = DISTBR(AD(23),DISTBR(AD(25),DISTBR(AD(24),T,INTONE, * NWRITE,EXPR,LEXPR),DIM,NWRITE,EXPR,LEXPR), * IND,NWRITE,EXPR,LEXPR) ADDROF = DISTBR(AD(23),A,T,NWRITE,EXPR,LEXPR) 20 CONTINUE RETURN C C LAST CARD OF INTEGER FUNCTION ADDROF. C END C*********************************************************************** INTEGER FUNCTION DIMOF(V,EXPR,LEXPR,VARD,LVARD) C C THIS ROUTINE RETURNS DIMENSION INFORMATION OF VARIABLE V. C INTEGER V,LEXPR,LVARD INTEGER EXPR(0:4*LEXPR),VARD(8*LVARD) INTEGER AD(86) COMMON /ZCHAR/ AD DIMOF = -1 IF (EXPR(2*LEXPR+V) .EQ. AD(13)) * DIMOF = VARD(2*LVARD+EXPR(3*LEXPR+V)) RETURN C C LAST CARD OF INTEGER FUNCTION DIMOF. C END C*********************************************************************** SUBROUTINE GRDENT(SAVE,LSAVE,NWRITE,EXPR,LEXPR,RHS,LRHS,NMTBL, * LNMTBL,STM,LSTM,VARD,LVARD) C C THIS ROUTINE CONSTRUCTS THE ROUGH STRUCTURE OF THE FORTRAN C GRADIENT PROGRAM. C CHARACTER NMTBL(0:LNMTBL) INTEGER LSAVE,NWRITE,LEXPR,LRHS,LNMTBL,LSTM,LVARD INTEGER SAVE(0:5*LSAVE+4),EXPR(0:4*LEXPR),RHS(LRHS), * STM(16*LSTM+6),VARD(8*LVARD) CHARACTER*5 NTC(6) INTEGER ADDROF,DEPCNT,DISTBR,FLTHLF,FLTNEG,FLTONE,FLTZER,HANDLE, * I,IN,INDS,INTONE,INTTWO,LABCNT,LOCSTR,OUT,P,PRIND,RADDR, * RESULT,RHSFST,RHSLST,S,ST,STNCNT,TMPIND,TYPRSL,TZL INTEGER AD(86),DEPS(1000),PRIOR(1000),TEMP(1000) CHARACTER*70 ERRM COMMON /CONTRL/ IN,OUT,RESULT,TYPRSL COMMON /FLT/ FLTONE,FLTHLF,FLTNEG,FLTZER COMMON /INTS/ INTONE,INTTWO COMMON /INDEX/ INDS,LABCNT,RHSFST,RHSLST,STNCNT COMMON /STORE/ DEPS,PRIOR,TEMP COMMON /TIND/ DEPCNT,PRIND,RADDR,TMPIND COMMON /ZCHAR/ AD COMMON /TNTC/ NTC DATA ERRM /' CONSTRUCT STATEMENT VARIABLE SHOULD BE TYPED REAL OR *DOUBLE PRECISION'/ INTONE = DISTBR(AD(33),0,1,NWRITE,EXPR,LEXPR) INTTWO = DISTBR(AD(33),0,2,NWRITE,EXPR,LEXPR) IF (TYPRSL .LT. 24) CALL ERRORM(ERRM,NWRITE) TZL = 1 IF (TYPRSL .GE. 32) TZL = 2 I = LOCSTR(NTC(TZL),NMTBL,LNMTBL) FLTZER = DISTBR(AD(29),TYPRSL,I,NWRITE,EXPR,LEXPR) TZL = 3 IF (TYPRSL .GE. 32) TZL = 4 I = LOCSTR(NTC(TZL),NMTBL,LNMTBL) FLTONE = DISTBR(AD(29),TYPRSL,I,NWRITE,EXPR,LEXPR) TZL = 5 IF (TYPRSL .GE. 32) TZL = 6 I = LOCSTR(NTC(TZL),NMTBL,LNMTBL) FLTHLF = DISTBR(AD(29),32,I,NWRITE,EXPR,LEXPR) FLTNEG = DISTBR(AD(35),0,FLTONE,NWRITE,EXPR,LEXPR) DO 20 ST = 1, STNCNT IF (STM(4*LSTM+ST) .EQ. 0) GO TO 20 IF (STM(5*LSTM+ST) .EQ. 0) THEN S = STM(ST) P = DISTBR(1,TYPRSL,ADDROF(EXPR(S),NWRITE,EXPR,LEXPR, * VARD,LVARD),NWRITE,EXPR,LEXPR) STM(ST) = DISTBR(AD(27),P,S,NWRITE,EXPR,LEXPR) GO TO 20 END IF DEPCNT = 0 I = STM(5*LSTM+ST) 10 CONTINUE IF (RHS(I) .NE. 0) THEN DEPCNT = DEPCNT + 1 DEPS(DEPCNT) = RHS(I) I = I + 1 GO TO 10 END IF STM(ST) = HANDLE(ST,SAVE,LSAVE,NWRITE,EXPR,LEXPR,STM, * LSTM,VARD,LVARD) 20 CONTINUE RETURN C C LAST CARD OF SUBROUTINE GRDENT. C END C*********************************************************************** SUBROUTINE EMITS(SAVE,LSAVE,NWRITE,EXPR,LEXPR,NMTBL,LNMTBL, * CRYSP,LCRYSP,STM,LSTM,VAR,LVAR,VARD,LVARD, * LBL,LLBL,TLIM) C C THIS ROUTINE EMITS THE FORTRAN GRADIENT PROGRAM. THE ROUGH C STRUCTURE OF THE PROGRAM HAS BEEN CONSTRUCTED IN GRDENT. C THE DECLARATIONS AND INITIALIZATIONS ARE ADDED AND THE C APPEARANCE IS CHANGED TO SATISFY FORTRAN SYNTAX. C CHARACTER NMTBL(0:LNMTBL),CRYSP(LCRYSP),VAR(9*LVAR) INTEGER LSAVE,NWRITE,LEXPR,LNMTBL,LCRYSP,LSTM,LVAR,LVARD,LLBL, * TLIM INTEGER SAVE(0:5*LSAVE+4),EXPR(0:4*LEXPR),STM(16*LSTM+6), * VARD(8*LVARD),LBL(LLBL) CHARACTER ACHAR,EOF,EOL,EOS,EOT CHARACTER ADC(86),CT(10),C1(13),C2(21),C3(32),C4(33),C5(20), * C6(21),C7(13) CHARACTER*7 CHS(6) CHARACTER*13 SUPR(4) INTEGER ADDR,ADDROF,ARRFLG,CONFLG,CONT,CRYPNT,DIMOF,DISTBR,EXPFRE, * GENLAB,GROUP,I,ID,IGRAD,IN,INDS,INITBD,INTADD,IVAR,JAKELB, * JFLG,JGRAD,LABCNT,LC,LGRAD,LYGRAD,NEGATE,NINVAR,NOTVAR, * NSMTAB,NTFREE,OUT,OUTP,OUTVAR,P,Q,RESULT,RETLAB,RGRAD, * RHSFST,RHSLST,SCALL,SENTNL,SIZOVR,ST,STNCNT,ST1,T,TYPRSL, * YGRAD INTEGER AD(86),IVRLST(1000),OVRLST(1000),TC(10) COMMON /ENDSYM/ EOF,EOL,EOS,EOT COMMON /GRAD/ IGRAD,JGRAD,LGRAD,LYGRAD,RGRAD,YGRAD COMMON /FLAGS/ OUTP,SENTNL,JFLG,CONFLG COMMON /ADDX/ INITBD,INTADD COMMON /CONTRL/ IN,OUT,RESULT,TYPRSL COMMON /LABL/ JAKELB COMMON /INDEX/ INDS,LABCNT,RHSFST,RHSLST,STNCNT COMMON /COUNTR/ CRYPNT,EXPFRE,NSMTAB,NTFREE COMMON /XCHAR/ ADC COMMON /ZCHAR/ AD COMMON /CHSTR/ CHS,SUPR DATA C1 /'I','N','T','E','G','E','R',' ','L','J','A','C','@'/ DATA C2 /'I','N','T','E','G','E','R',' ','L','F','S',',','I','F',' *S','(','L','F','S',')','@'/ DATA C3 /'D','O','U','B','L','E',' ','P','R','E','C','I','S','I',' *O','N',' ','R','F','S','(','L','F','S',')',',','T','G','R','A','(' *,'@'/ DATA C4 /'D','O','U','B','L','E',' ','P','R','E','C','I','S','I',' *O','N',' ','R','F','S','(','L','F','S',')',',','T','J','A','C','O' *,'(','@'/ DATA C5 /'R','E','A','L',' ','R','F','S','(','L','F','S',')',',',' *T','G','R','A','(','@'/ DATA C6 /'R','E','A','L',' ','R','F','S','(','L','F','S',')',',',' *T','J','A','C','O','(','@'/ DATA C7 /',','R','F','S',',','I','F','S',',','L','F','S','@'/ JAKELB = 89999 P = GENLAB(NWRITE,EXPR,LEXPR,LBL,LLBL) STM(STNCNT+1) = P RETLAB = EXPR(P) C C OBTAIN THE CARRYALONG INFORMATION GENERATED IN THE PARSE PASS. C DO 10 I = 1, CRYPNT IF (CRYSP(I) .EQ. EOS) CRYSP(I) = ADC(22) 10 CONTINUE CALL SHOWST(STM(1),SAVE,LSAVE,NWRITE,EXPR,LEXPR,NMTBL,LNMTBL, * CRYSP,LCRYSP,VAR,LVAR,VARD,LVARD,TLIM) CALL INITST(NWRITE) CALL FORWRD(7) IF (JFLG .EQ. 1) THEN CALL OUTSTR(C1,NWRITE) CALL INITST(NWRITE) CALL FORWRD(7) END IF CALL OUTSTR(C2,NWRITE) CALL INITST(NWRITE) CALL FORWRD(7) LC = 1 ID = 1 20 CONTINUE T = TLIM/ID IF (T .LT. 10) GO TO 30 TC(LC) = T - (TLIM/(10*ID))*10 LC = LC + 1 ID = 10*ID GO TO 20 30 CONTINUE TC(LC) = T DO 40 I = 1, LC CT(I) = ACHAR(TC(LC-I+1)+ADDR('0')) 40 CONTINUE IF (TYPRSL .GE. 32) THEN IF (JFLG .EQ. 0) CALL OUTSTR(C3,NWRITE) IF (JFLG .EQ. 1) CALL OUTSTR(C4,NWRITE) ELSE IF (JFLG .EQ. 0) CALL OUTSTR(C5,NWRITE) IF (JFLG .EQ. 1) CALL OUTSTR(C6,NWRITE) END IF DO 50 I = 1, LC CALL CEMIT(CT(I),NWRITE) 50 CONTINUE CALL CEMIT(ADC(39),NWRITE) CALL GENDCL(SAVE,LSAVE,NWRITE,EXPR,LEXPR,NMTBL,LNMTBL,CRYSP, * LCRYSP,VAR,LVAR,VARD,LVARD,TLIM) CALL INITST(NWRITE) GROUP = 2 ST = 2 60 CONTINUE P = STM(ST) IF (P .EQ. 0) GO TO 90 IF (GROUP .EQ. 2) THEN Q = EXPR(3*LEXPR+P) IF (EXPR(2*LEXPR+P) .NE. AD(28)) Q = P IF (EXPR(2*LEXPR+Q) .EQ. 11) THEN IF (EXPR(Q) .EQ. 1) GROUP = 1 GO TO 70 END IF IF (EXPR(2*LEXPR+Q) .NE. 15) GROUP = 1 70 CONTINUE IF (GROUP .EQ. 1) THEN CALL SHOWST(INTADD,SAVE,LSAVE,NWRITE,EXPR,LEXPR,NMTBL, * LNMTBL,CRYSP,LCRYSP,VAR,LVAR,VARD,LVARD, * TLIM) CALL INITST(NWRITE) CALL FORWRD(7) SCALL = 1 IF (TYPRSL .LT. 32) SCALL = 2 CALL OUTSTR(SUPR(SCALL),NWRITE) CALL SHOWEX(INITBD,SAVE,LSAVE,NWRITE,EXPR,LEXPR,NMTBL, * LNMTBL,CRYSP,LCRYSP,VAR,LVAR,VARD,LVARD, * TLIM) CALL CEMIT(ADC(30),NWRITE) CALL SHOWEX(LYGRAD,SAVE,LSAVE,NWRITE,EXPR,LEXPR,NMTBL, * LNMTBL,CRYSP,LCRYSP,VAR,LVAR,VARD,LVARD, * TLIM) CALL CEMIT(ADC(39),NWRITE) CALL INITST(NWRITE) END IF END IF T = EXPR(2*LEXPR+P) 80 CONTINUE IF (T .EQ. AD(27)) THEN CALL SHOWST(EXPR(P),SAVE,LSAVE,NWRITE,EXPR,LEXPR,NMTBL, * LNMTBL,CRYSP,LCRYSP,VAR,LVAR,VARD,LVARD,TLIM) CALL INITST(NWRITE) P = EXPR(3*LEXPR+P) T = EXPR(2*LEXPR+P) GO TO 80 END IF IF (T .EQ. AD(10)) THEN ST1 = EXPR(3*LEXPR+EXPR(3*LEXPR+P)) CONT = GENLAB(NWRITE,EXPR,LEXPR,LBL,LLBL) STM(ST1)=DISTBR(AD(27),CONT,STM(ST1),NWRITE,EXPR,LEXPR) P = DISTBR(AD(10),EXPR(CONT),EXPR(P),NWRITE,EXPR,LEXPR) ELSE IF (T .EQ. 24) THEN Q = STM(ST+1) IF (EXPR(2*LEXPR+Q) .EQ. AD(27)) THEN CONT = GENLAB(NWRITE,EXPR,LEXPR,LBL,LLBL) STM(ST+2) = DISTBR(AD(27),CONT,STM(ST+2),NWRITE,EXPR, * LEXPR) Q = DISTBR(AD(12),0,EXPR(CONT),NWRITE,EXPR,LEXPR) P = DISTBR(24,NEGATE(EXPR(P),NWRITE,EXPR,LEXPR), * Q,NWRITE,EXPR,LEXPR) ELSE IF (EXPR(2*LEXPR+Q) .EQ. 6) THEN P = DISTBR(24,EXPR(P),DISTBR(AD(12),0,RETLAB,NWRITE,EXPR, * LEXPR),NWRITE,EXPR,LEXPR) ST = ST + 1 ELSE ST = ST + 1 END IF ELSE IF (T .EQ. 6) THEN P = DISTBR(AD(12),0,RETLAB,NWRITE,EXPR,LEXPR) END IF CALL SHOWST(P,SAVE,LSAVE,NWRITE,EXPR,LEXPR,NMTBL,LNMTBL,CRYSP, * LCRYSP,VAR,LVAR,VARD,LVARD,TLIM) CALL INITST(NWRITE) 90 CONTINUE ST = ST + 1 IF (ST .LE. STNCNT+1) GO TO 60 NOTVAR = 0 100 CONTINUE IF (EXPR(2*LEXPR+OUT) .EQ. AD(30)) THEN NOTVAR = NOTVAR + 1 OVRLST(NOTVAR) = EXPR(3*LEXPR+OUT) OUT = EXPR(OUT) GO TO 100 END IF NOTVAR = NOTVAR + 1 OVRLST(NOTVAR) = OUT NINVAR = 0 110 CONTINUE IF (EXPR(2*LEXPR+IN) .EQ. AD(30)) THEN NINVAR = NINVAR + 1 IVRLST(NINVAR) = EXPR(3*LEXPR+IN) IN = EXPR(IN) GO TO 110 END IF NINVAR = NINVAR + 1 IVRLST(NINVAR) = IN CALL FORWRD(7) CALL SHOWEX(RGRAD,SAVE,LSAVE,NWRITE,EXPR,LEXPR,NMTBL,LNMTBL, * CRYSP,LCRYSP,VAR,LVAR,VARD,LVARD,TLIM) CALL OUTSTR(CHS(3),NWRITE) CALL INITST(NWRITE) 120 CONTINUE IF (NOTVAR .GE. 1) THEN OUTVAR = OVRLST(NOTVAR) ARRFLG = 0 IF (DIMOF(OUTVAR,EXPR,LEXPR,VARD,LVARD) .NE. 0) THEN ARRFLG = 1 CONT = GENLAB(NWRITE,EXPR,LEXPR,LBL,LLBL) CALL FORWRD(7) CALL SHOWEX(LGRAD,SAVE,LSAVE,NWRITE,EXPR,LEXPR,NMTBL,LNMTBL, * CRYSP,LCRYSP,VAR,LVAR,VARD,LVARD,TLIM) CALL CEMIT(ADC(31),NWRITE) CALL SHOWEX(SIZOVR(OUTVAR,SAVE,LSAVE,NWRITE,EXPR,LEXPR,VARD, * LVARD),SAVE,LSAVE,NWRITE,EXPR,LEXPR,NMTBL, * LNMTBL,CRYSP,LCRYSP,VAR,LVAR,VARD,LVARD,TLIM) CALL INITST(NWRITE) CALL FORWRD(7) CALL OUTSTR(CHS(1),NWRITE) CALL SHOWEX(EXPR(CONT),SAVE,LSAVE,NWRITE,EXPR,LEXPR,NMTBL, * LNMTBL,CRYSP,LCRYSP,VAR,LVAR,VARD,LVARD,TLIM) CALL CEMIT(ADC(32),NWRITE) CALL SHOWEX(JGRAD,SAVE,LSAVE,NWRITE,EXPR,LEXPR,NMTBL,LNMTBL, * CRYSP,LCRYSP,VAR,LVAR,VARD,LVARD,TLIM) CALL OUTSTR(CHS(4),NWRITE) CALL SHOWEX(LGRAD,SAVE,LSAVE,NWRITE,EXPR,LEXPR,NMTBL,LNMTBL, * CRYSP,LCRYSP,VAR,LVAR,VARD,LVARD,TLIM) CALL INITST(NWRITE) END IF CALL FORWRD(7) SCALL = 3 IF (TYPRSL .LT. 32) SCALL = 4 CALL OUTSTR(SUPR(SCALL),NWRITE) CALL SHOWEX(YGRAD,SAVE,LSAVE,NWRITE,EXPR,LEXPR,NMTBL,LNMTBL, * CRYSP,LCRYSP,VAR,LVAR,VARD,LVARD,TLIM) CALL CEMIT(ADC(30),NWRITE) CALL SHOWEX(LYGRAD,SAVE,LSAVE,NWRITE,EXPR,LEXPR,NMTBL,LNMTBL, * CRYSP,LCRYSP,VAR,LVAR,VARD,LVARD,TLIM) CALL CEMIT(ADC(30),NWRITE) CALL SHOWEX(ADDROF(OUTVAR,NWRITE,EXPR,LEXPR,VARD,LVARD),SAVE, * LSAVE,NWRITE,EXPR,LEXPR,NMTBL,LNMTBL,CRYSP,LCRYSP, * VAR,LVAR,VARD,LVARD,TLIM) IF (ARRFLG .EQ. 1) THEN CALL CEMIT(ADC(23),NWRITE) CALL SHOWEX(JGRAD,SAVE,LSAVE,NWRITE,EXPR,LEXPR,NMTBL,LNMTBL, * CRYSP,LCRYSP,VAR,LVAR,VARD,LVARD,TLIM) END IF CALL CEMIT(ADC(30),NWRITE) CALL SHOWEX(RGRAD,SAVE,LSAVE,NWRITE,EXPR,LEXPR,NMTBL,LNMTBL, * CRYSP,LCRYSP,VAR,LVAR,VARD,LVARD,TLIM) CALL CEMIT(ADC(30),NWRITE) CALL SHOWEX(IGRAD,SAVE,LSAVE,NWRITE,EXPR,LEXPR,NMTBL,LNMTBL, * CRYSP,LCRYSP,VAR,LVAR,VARD,LVARD,TLIM) CALL OUTSTR(C7,NWRITE) CALL CEMIT(ADC(39),NWRITE) CALL INITST(NWRITE) DO 130 IVAR = NINVAR, 1, -1 CALL GRDCOP(IVRLST(IVAR),SAVE,LSAVE,NWRITE,EXPR,LEXPR, * NMTBL,LNMTBL,CRYSP,LCRYSP,VAR,LVAR,VARD,LVARD, * TLIM) 130 CONTINUE IF (ARRFLG .EQ. 1) THEN CALL SHOWST(CONT,SAVE,LSAVE,NWRITE,EXPR,LEXPR,NMTBL,LNMTBL, * CRYSP,LCRYSP,VAR,LVAR,VARD,LVARD,TLIM) CALL INITST(NWRITE) END IF NOTVAR = NOTVAR - 1 GO TO 120 END IF CALL FORWRD(7) CALL OUTSTR(CHS(5),NWRITE) CALL INITST(NWRITE) CALL FORWRD(7) CALL OUTSTR(CHS(2),NWRITE) CALL INITST(NWRITE) RETURN C C LAST CARD OF SUBROUTINE EMITS. C END C*********************************************************************** INTEGER FUNCTION GENLAB(NWRITE,EXPR,LEXPR,LBL,LLBL) C C THIS ROUTINE TAKES AN UNUSED LABEL AND GENERATES A C "LABEL:CONTINUE". C INTEGER NWRITE,LEXPR,LLBL INTEGER EXPR(0:4*LEXPR),LBL(LLBL) INTEGER DISTBR,JAKELB,LABELU INTEGER AD(86) COMMON /LABL/ JAKELB COMMON /ZCHAR/ AD 10 CONTINUE JAKELB = JAKELB + 1 IF (LABELU(JAKELB,LBL,LLBL) .EQ. 1) GO TO 10 GENLAB = DISTBR(AD(28),DISTBR(AD(33),0,JAKELB,NWRITE,EXPR,LEXPR), * DISTBR(31,0,0,NWRITE,EXPR,LEXPR),NWRITE,EXPR,LEXPR) RETURN C C LAST CARD OF INTEGER FUNCTION GENLAB. C END C*********************************************************************** SUBROUTINE SHOWST(P,SAVE,LSAVE,NWRITE,EXPR,LEXPR,NMTBL,LNMTBL, * CRYSP,LCRYSP,VAR,LVAR,VARD,LVARD,TLIM) CHARACTER NMTBL(0:LNMTBL),CRYSP(LCRYSP),VAR(9*LVAR) INTEGER P,LSAVE,NWRITE,LEXPR,LNMTBL,LCRYSP,LVAR,LVARD,TLIM INTEGER SAVE(0:5*LSAVE+4),EXPR(0:4*LEXPR),VARD(8*LVARD) INTEGER Q INTEGER AD(86) COMMON /ZCHAR/ AD CALL INITST(NWRITE) IF (P .NE. 0) THEN Q = P IF (EXPR(2*LEXPR+P) .EQ. AD(28)) THEN CALL OUTINT(EXPR(3*LEXPR+EXPR(P)),SAVE,LSAVE,NWRITE) Q = EXPR(3*LEXPR+P) END IF CALL FORWRD(7) CALL SHOWEX(Q,SAVE,LSAVE,NWRITE,EXPR,LEXPR,NMTBL,LNMTBL, * CRYSP,LCRYSP,VAR,LVAR,VARD,LVARD,TLIM) END IF RETURN C C LAST CARD OF SUBROUTINE SHOWST. C END C*********************************************************************** SUBROUTINE SHOWEX(PP,SAVE,LSAVE,NWRITE,EXPR,LEXPR,NMTBL,LNMTBL, * CRYSP,LCRYSP,VAR,LVAR,VARD,LVARD,TLIM) C C THIS ROUTINE SHOWS EXPRESSIONS. C CHARACTER NMTBL(0:LNMTBL),CRYSP(LCRYSP),VAR(9*LVAR) INTEGER PP,LSAVE,NWRITE,LEXPR,LNMTBL,LCRYSP,LVAR,LVARD,TLIM INTEGER SAVE(0:5*LSAVE+4),EXPR(0:4*LEXPR),VARD(8*LVARD) CHARACTER ADC(86),CARD(74),NAME(1000),TEMP(5),C1(7),C2(5), * C3(13),C4(6),C5(14) CHARACTER*13 RCALL(9) CHARACTER*17 TABLE(2) CHARACTER*70 ERRM1,ERRM2,ERRM3 INTEGER ADDR,COL,COMP,CONFLG,I,IEXIT,ILT,JFLG,K,L,LASTCH,LEXOF,LT, * NEXTCH,NTGRAD,NTIND,NTLYGD,NTYGRD,OUTP,P,Q,SENTNL,T, * TFLAG,TP,TQ INTEGER AD(86),ARITY(0:255),DEFLEN(42),DEFTYP(42),DESCR(1000) COMMON /NGRAD/ NTGRAD,NTLYGD,NTYGRD COMMON /DATAB/ ARITY,DEFLEN,DEFTYP,DESCR COMMON /COUNTS/ COL,LASTCH,NEXTCH COMMON /IMAGE/ CARD COMMON /XCHAR/ ADC COMMON /ZCHAR/ AD COMMON /CALLS/ RCALL COMMON /FLAGS/ OUTP,SENTNL,JFLG,CONFLG DATA TABLE /'SIGN@','0'/ DATA ERRM1 /' SAVE SPACE OVERFLOW IN SHOWEX'/ DATA ERRM2 /' MORE THAN 999 TEMPORARIES REQUIRED'/ DATA ERRM3 /' TLIM IS NOT LARGE ENOUGH'/ DATA C1 /'(','1','.','D','0',',','@'/ DATA C2 /'(','1','.',',','@'/ DATA C3 /',','R','F','S',',','I','F','S',',','L','F','S','@'/ DATA C4 /'L','J','A','C',',','@'/ DATA C5 /',','R','F','S',',','I','F','S',',','L','F','S',')','@'/ IF (PP .LE. 0) GO TO 230 IEXIT = -1 P = PP TQ = P T = EXPR(2*LEXPR+P) 10 CONTINUE IF (P .EQ. 0) GO TO 220 IEXIT = IEXIT + 1 SAVE(IEXIT) = TQ SAVE(IEXIT+LSAVE+1) = T SAVE(IEXIT+2*LSAVE+2) = TFLAG IF (IEXIT .GE. LSAVE) CALL ERRORM(ERRM1,NWRITE) T = EXPR(2*LEXPR+P) IF (ARITY(T) .EQ. 0) THEN IF (T .EQ. AD(33)) THEN CALL OUTINT(EXPR(3*LEXPR+P),SAVE,LSAVE,NWRITE) ELSE IF (T .EQ. AD(13)) THEN L = LEXOF(P,EXPR,LEXPR,VARD,LVARD) LT = L + 4 IF (JFLG .EQ. 1) LT = LT + 1 IF (NMTBL(LT) .NE. ADC(38)) GO TO 15 ILT = ADDR(NMTBL(LT+1)) - ADDR(ADC(20)) IF (NMTBL(LT+2) .NE. ADC(39)) * ILT = 10*ILT + ADDR(NMTBL(LT+1)) - ADDR(ADC(20)) IF (ILT .GE. 1000) CALL ERRORM(ERRM2,NWRITE) IF (ILT .GE. TLIM) CALL ERRORM(ERRM3,NWRITE) 15 CONTINUE CALL NTDSPL(L,SAVE,LSAVE,NWRITE,NMTBL,LNMTBL,VAR,LVAR) ELSE IF (T .EQ. AD(29)) THEN CALL NTDSPL(EXPR(3*LEXPR+P),SAVE,LSAVE,NWRITE,NMTBL, * LNMTBL,VAR,LVAR) ELSE IF (T .EQ. AD(34)) THEN TQ = P P = EXPR(P) SAVE(3*LSAVE+IEXIT+3) = 1 GO TO 10 20 CONTINUE CALL CEMIT(ADC(38),NWRITE) TQ = P P = EXPR(3*LEXPR+P) SAVE(3*LSAVE+IEXIT+3) = 2 GO TO 10 30 CONTINUE CALL CEMIT(ADC(39),NWRITE) ELSE IF (T .EQ. 14) THEN CALL CEMIT(ADC(26),NWRITE) CALL NTDSPL(EXPR(3*LEXPR+P),SAVE,LSAVE,NWRITE,NMTBL, * LNMTBL,VAR,LVAR) CALL CEMIT(ADC(26),NWRITE) ELSE IF (T .EQ. 11) THEN CALL FORMTR(CRYSP(EXPR(3*LEXPR+P)),SAVE,LSAVE,NWRITE, * VAR,LVAR) ELSE IF (T .EQ. 12) THEN NTIND = EXPR(3*LEXPR+P) K = 1 40 CONTINUE IF (NMTBL(NTIND) .NE. ADC(22)) THEN NAME(K) = NMTBL(NTIND) K = K + 1 NTIND = NTIND + 1 GO TO 40 END IF IF (K .GT. 6) K = 6 NAME(K) = ADC(55) NAME(K+1) = ADC(22) CALL OUTSTR(NAME,NWRITE) ELSE CALL TKDSPL(T,NWRITE) CALL NTDSPL(EXPR(3*LEXPR+P),SAVE,LSAVE,NWRITE,NMTBL, * LNMTBL,VAR,LVAR) END IF GO TO 220 END IF IF (ARITY(T) .EQ. 1) THEN IF (T .EQ. AD(12)) THEN IF (COL .GT. 7) T = 28 CALL TKDSPL(T,NWRITE) TQ = P P = EXPR(3*LEXPR+P) SAVE(3*LSAVE+IEXIT+3) = 3 GO TO 10 END IF TFLAG = 0 IF ((T .EQ. 1) .OR. (T .EQ. 2) .OR. (T .EQ. 3)) TFLAG = 1 IF (EXPR(P) .GE. 32) THEN IF (T .EQ. AD(1)) THEN CALL OUTSTR(RCALL(2),NWRITE) ELSE IF (T .EQ. AD(3)) THEN CALL OUTSTR(RCALL(3),NWRITE) ELSE IF (T .EQ. 1) THEN CALL OUTSTR(RCALL(4),NWRITE) ELSE IF (T .EQ. 2) THEN CALL OUTSTR(RCALL(5),NWRITE) ELSE IF (T .EQ. 3) THEN CALL OUTSTR(RCALL(6),NWRITE) ELSE IF (T .NE. AD(35)) CALL CEMIT(RCALL(1),NWRITE) CALL TKDSPL(T,NWRITE) END IF ELSE CALL TKDSPL(T,NWRITE) END IF TEMP(1) = CARD(COL-4) TEMP(2) = CARD(COL-3) TEMP(3) = CARD(COL-2) TEMP(4) = CARD(COL-1) TEMP(5) = ADC(22) I = COMP(TEMP,TABLE) IF ((I .GT. 0) .AND. (EXPR(P) .GE. 32)) * CALL OUTSTR(C1,NWRITE) IF ((I .GT. 0) .AND. (EXPR(P) .LT. 32)) * CALL OUTSTR(C2,NWRITE) IF (I .LE. 0) CALL CEMIT(ADC(38),NWRITE) TQ = P P = EXPR(3*LEXPR+P) SAVE(3*LSAVE+IEXIT+3) = 4 GO TO 10 50 CONTINUE IF (TFLAG .EQ. 1) CALL OUTSTR(C3,NWRITE) CALL CEMIT(ADC(39),NWRITE) GO TO 220 END IF IF (T .EQ. AD(27)) THEN TP = EXPR(P) CALL INITST(NWRITE) IF (TP .NE. 0) THEN IF (EXPR(2*LEXPR+TP) .EQ. AD(28)) THEN CALL OUTINT(EXPR(3*LEXPR+EXPR(TP)),SAVE,LSAVE,NWRITE) Q = EXPR(3*LEXPR+TP) GO TO 60 END IF Q = TP 60 CONTINUE CALL FORWRD(7) TQ = P P = Q SAVE(3*LSAVE+IEXIT+3) = 23 GO TO 10 END IF 70 CONTINUE TP = EXPR(3*LEXPR+P) CALL INITST(NWRITE) IF (TP .EQ. 0) GO TO 220 IF (EXPR(2*LEXPR+TP) .EQ. AD(28)) THEN CALL OUTINT(EXPR(3*LEXPR+EXPR(TP)),SAVE,LSAVE,NWRITE) Q = EXPR(3*LEXPR+TP) GO TO 80 END IF Q = TP 80 CONTINUE CALL FORWRD(7) TQ = P P = Q SAVE(3*LSAVE+IEXIT+3) = 24 GO TO 10 END IF IF ((T .EQ. AD(30)) .OR. (T .EQ. AD(31))) THEN TQ = P P = EXPR(P) SAVE(3*LSAVE+IEXIT+3) = 5 GO TO 10 90 CONTINUE CALL TKDSPL(T,NWRITE) TQ = P P = EXPR(3*LEXPR+P) SAVE(3*LSAVE+IEXIT+3) = 6 GO TO 10 END IF IF (T .EQ. 4) THEN TQ = P P = EXPR(P) SAVE(3*LSAVE+IEXIT+3) = 7 GO TO 10 100 CONTINUE CALL CEMIT(ADC(38),NWRITE) TQ = P P = EXPR(3*LEXPR+P) SAVE(3*LSAVE+IEXIT+3) = 8 GO TO 10 110 CONTINUE CALL CEMIT(ADC(39),NWRITE) GO TO 220 END IF IF (T .EQ. 13) THEN CALL TKDSPL(T,NWRITE) TQ = P P = EXPR(P) SAVE(3*LSAVE+IEXIT+3) = 9 GO TO 10 120 CONTINUE CALL CEMIT(ADC(38),NWRITE) TQ = P P = EXPR(3*LEXPR+P) SAVE(3*LSAVE+IEXIT+3) = 10 GO TO 10 130 CONTINUE CALL CEMIT(ADC(30),NWRITE) CALL NTDSPL(NTGRAD,SAVE,LSAVE,NWRITE,NMTBL,LNMTBL,VAR,LVAR) CALL CEMIT(ADC(30),NWRITE) IF (NMTBL(NTGRAD) .EQ. 'J') THEN CALL OUTSTR(C4,NWRITE) JFLG = 1 END IF CALL NTDSPL(NTYGRD,SAVE,LSAVE,NWRITE,NMTBL,LNMTBL,VAR,LVAR) CALL CEMIT(ADC(30),NWRITE) CALL NTDSPL(NTLYGD,SAVE,LSAVE,NWRITE,NMTBL,LNMTBL,VAR,LVAR) CALL OUTSTR(C5,NWRITE) GO TO 220 END IF IF ((T .EQ. 24) .OR. (T .EQ. 25)) THEN CALL TKDSPL(T,NWRITE) CALL CEMIT(ADC(38),NWRITE) TQ = P P = EXPR(P) SAVE(3*LSAVE+IEXIT+3) = 11 GO TO 10 140 CONTINUE CALL CEMIT(ADC(39),NWRITE) TQ = P P = EXPR(3*LEXPR+P) SAVE(3*LSAVE+IEXIT+3) = 12 GO TO 10 END IF IF ((T .EQ. AD(10)) .OR. (T .EQ. 15)) THEN CALL TKDSPL(T,NWRITE) TQ = P P = EXPR(P) SAVE(3*LSAVE+IEXIT+3) = 13 GO TO 10 150 CONTINUE CALL CEMIT(ADC(32),NWRITE) TQ = P P = EXPR(3*LEXPR+P) SAVE(3*LSAVE+IEXIT+3) = 14 GO TO 10 END IF IF (T .EQ. 27) THEN CALL TKDSPL(T,NWRITE) CALL CEMIT(ADC(38),NWRITE) TQ = P P = EXPR(P) SAVE(3*LSAVE+IEXIT+3) = 15 GO TO 10 160 CONTINUE CALL CEMIT(ADC(39),NWRITE) CALL CEMIT(ADC(30),NWRITE) TQ = P P = EXPR(3*LEXPR+P) SAVE(3*LSAVE+IEXIT+3) = 16 GO TO 10 END IF IF (T .EQ. 28) THEN CALL TKDSPL(T,NWRITE) TQ = P P = EXPR(P) SAVE(3*LSAVE+IEXIT+3) = 17 GO TO 10 170 CONTINUE CALL CEMIT(ADC(30),NWRITE) CALL CEMIT(ADC(38),NWRITE) TQ = P P = EXPR(3*LEXPR+P) SAVE(3*LSAVE+IEXIT+3) = 18 GO TO 10 180 CONTINUE CALL CEMIT(ADC(39),NWRITE) GO TO 220 END IF IF (ARITY(EXPR(2*LEXPR+EXPR(P))) .EQ. 2) THEN CALL CEMIT(ADC(38),NWRITE) TQ = P P = EXPR(P) SAVE(3*LSAVE+IEXIT+3) = 19 GO TO 10 190 CONTINUE CALL CEMIT(ADC(39),NWRITE) GO TO 200 END IF TQ = P P = EXPR(P) SAVE(3*LSAVE+IEXIT+3) = 20 GO TO 10 200 CONTINUE CALL TKDSPL(T,NWRITE) IF (ARITY(EXPR(2*LEXPR+EXPR(3*LEXPR+P))) .EQ. 2) THEN CALL CEMIT(ADC(38),NWRITE) TQ = P P = EXPR(3*LEXPR+P) SAVE(3*LSAVE+IEXIT+3) = 21 GO TO 10 210 CONTINUE CALL CEMIT(ADC(39),NWRITE) GO TO 220 END IF TQ = P P = EXPR(3*LEXPR+P) SAVE(3*LSAVE+IEXIT+3) = 22 GO TO 10 220 CONTINUE IF (IEXIT .NE. 0) THEN P = SAVE(IEXIT) T = SAVE(IEXIT+LSAVE+1) TFLAG = SAVE(IEXIT+2*LSAVE+2) IEXIT = IEXIT - 1 GO TO (20,30,220,50,90,220,100,110,120,130,140,220,150,220,160, * 220,170,180,190,200,210,220,70,220),SAVE(3*LSAVE+IEXIT+3) END IF 230 CONTINUE RETURN C C LAST CARD OF SUBROUTINE SHOWEX. C END C********************************************************************** SUBROUTINE CEMIT(C,NWRITE) CHARACTER C INTEGER NWRITE CHARACTER ADC(86),CARD(74) INTEGER COL,LASTCH,NEXTCH COMMON /IMAGE/ CARD COMMON /COUNTS/ COL,LASTCH,NEXTCH COMMON /XCHAR/ ADC IF (COL .GT. 72) CALL CONTST(NWRITE) IF (C .EQ. ADC(31)) CARD(COL) = ADC(32) IF (C .EQ. ADC(31)) COL = COL + 1 IF (COL .GT. 72) CALL CONTST(NWRITE) CARD(COL) = C COL = COL + 1 IF (COL .GT. 72) CALL CONTST(NWRITE) IF (C .EQ. ADC(31)) CARD(COL) = ADC(32) IF (C .EQ. ADC(31)) COL = COL + 1 IF (COL .GT. 72) CALL CONTST(NWRITE) RETURN C C LAST CARD OF SUBROUTINE CEMIT. C END C*********************************************************************** INTEGER FUNCTION NEGATE(P,NWRITE,EXPR,LEXPR) C C THIS ROUTINE CONSTRUCTS THE NEGATION OF EXPRESSION P. C INTEGER P,NWRITE,LEXPR INTEGER EXPR(0:4*LEXPR) INTEGER DISTBR,I INTEGER AD(86) COMMON /ZCHAR/ AD NEGATE = EXPR(3*LEXPR+P) IF (EXPR(2*LEXPR+P) .EQ. AD(37)) GO TO 20 DO 10 I = 1, 6 IF (EXPR(2*LEXPR+P) .NE. AD(I+42)) GO TO 10 NEGATE = DISTBR(AD(49-I),EXPR(P),EXPR(3*LEXPR+P),NWRITE,EXPR, * LEXPR) GO TO 20 10 CONTINUE NEGATE = DISTBR(AD(37),0,P,NWRITE,EXPR,LEXPR) 20 CONTINUE RETURN C C LAST CARD OF INTEGER FUNCTION NEGATE. C END C*********************************************************************** SUBROUTINE FORWRD(K) INTEGER K CHARACTER ADC(86),CARD(74) INTEGER COL,LASTCH,NEXTCH COMMON /COUNTS/ COL,LASTCH,NEXTCH COMMON /IMAGE/ CARD COMMON /XCHAR/ ADC 10 CONTINUE IF (COL .LT. K) THEN CARD(COL) = ADC(32) COL = COL + 1 GO TO 10 END IF RETURN C C LAST CARD OF SUBROUTINE FORWRD. C END C*********************************************************************** SUBROUTINE OUTSTR(STR,NWRITE) CHARACTER STR(*) INTEGER NWRITE CHARACTER ADC(86),CARD(74) INTEGER COL,LASTCH,NEXTCH,I COMMON /COUNTS/ COL,LASTCH,NEXTCH COMMON /IMAGE/ CARD COMMON /XCHAR/ ADC I = 1 10 CONTINUE IF (STR(I) .NE. ADC(22)) THEN IF (COL .GT. 72) CALL CONTST(NWRITE) CARD(COL) = STR(I) COL = COL + 1 I = I + 1 GO TO 10 END IF RETURN C C LAST CARD OF SUBROUTINE OUTSTR. C END C********************************************************************* SUBROUTINE INITST(NWRITE) INTEGER NWRITE CHARACTER CARD(74) INTEGER COL,I,LASTCH,NEXTCH COMMON /IMAGE/ CARD COMMON /COUNTS/ COL,LASTCH,NEXTCH IF (COL .GT. 7) THEN COL = COL - 1 WRITE (NWRITE,'(74A1)') (CARD(I),I=1,COL) END IF COL = 1 RETURN C C LAST CARD OF SUBROUTINE INITST. C END C*********************************************************************** SUBROUTINE CONTST(NWRITE) INTEGER NWRITE CHARACTER ADC(86),CARD(74) INTEGER COL,LASTCH,NEXTCH COMMON /COUNTS/ COL,LASTCH,NEXTCH COMMON /IMAGE/ CARD COMMON /XCHAR/ ADC CALL INITST(NWRITE) CALL FORWRD(6) CARD(6) = ADC(25) COL = 7 RETURN C C LAST CARD OF SUBROUTINE CONTST. C END C*********************************************************************** SUBROUTINE OUTINT(LL,SAVE,LSAVE,NWRITE) INTEGER LL,LSAVE,NWRITE INTEGER SAVE(0:5*LSAVE+4) CHARACTER ADC(86),CARD(74) INTEGER COL,L,LASTCH,NEXTCH COMMON /IMAGE/ CARD COMMON /COUNTS/ COL,LASTCH,NEXTCH COMMON /XCHAR/ ADC L = LL IF (L .LT. 0) THEN IF (COL .GT. 72) CALL CONTST(NWRITE) CARD(COL) = ADC(24) COL = COL + 1 L = -L CALL PUTINT(L,SAVE,LSAVE,NWRITE) ELSE IF (L .EQ. 0) THEN IF (COL .GT. 72) CALL CONTST(NWRITE) CARD(COL) = ADC(20) COL = COL + 1 ELSE CALL PUTINT(L,SAVE,LSAVE,NWRITE) END IF RETURN C C LAST CARD OF SUBROUTINE OUTINT. C END C*********************************************************************** SUBROUTINE PUTINT(LX,SAVE,LSAVE,NWRITE) INTEGER LX,LSAVE,NWRITE INTEGER SAVE(0:5*LSAVE+4) CHARACTER ACHAR CHARACTER CARD(74) CHARACTER*70 ERRM INTEGER COL,D,IEXIT,L,LASTCH,NEXTCH INTEGER AD(86) COMMON /COUNTS/ COL,LASTCH,NEXTCH COMMON /IMAGE/ CARD COMMON /ZCHAR/ AD DATA ERRM /' SAVE SPACE OVERFLOW IN PUTINT'/ IEXIT = 0 L = LX 10 CONTINUE IF (IEXIT .GE. LSAVE) CALL ERRORM(ERRM,NWRITE) D = L/10 D = L - 10*D L = L/10 IF (L .NE. 0) THEN IEXIT = IEXIT + 1 SAVE(IEXIT+4*LSAVE+3) = D GO TO 10 END IF 20 CONTINUE D = D + AD(20) IF (COL .GT. 72) CALL CONTST(NWRITE) CARD(COL) = ACHAR(D) COL = COL + 1 IF (IEXIT .NE. 0) THEN D = SAVE(IEXIT+4*LSAVE+3) IEXIT = IEXIT - 1 GO TO 20 END IF RETURN C C LAST CARD OF SUBROUTINE PUTINT. C END C*********************************************************************** SUBROUTINE FORMTR(STR,SAVE,LSAVE,NWRITE,VAR,LVAR) INTEGER LSAVE,NWRITE,LVAR CHARACTER STR(*),VAR(9*LVAR) INTEGER SAVE(0:5*LSAVE+4) CHARACTER EOF,EOL,EOS,EOT CHARACTER ADC(86),CARD(74) INTEGER COL,I,L,LASTCH,NEXTCH LOGICAL DATAX COMMON /ENDSYM/ EOF,EOL,EOS,EOT COMMON /COUNTS/ COL,LASTCH,NEXTCH COMMON /IMAGE/ CARD COMMON /XCHAR/ ADC DATAX = .FALSE. IF ((STR(1) .EQ. ADC(50)) .AND. (STR(2) .EQ. ADC(16))) * DATAX = .TRUE. I = 0 10 CONTINUE I = I + 1 IF (STR(I) .NE. ADC(22)) THEN IF (STR(I) .EQ. ADC(42)) THEN IF (.NOT. DATAX) VAR(7*LVAR+1) = STR(I) I = I + 1 L = 1 IF (.NOT. DATAX) L = L + 1 20 CONTINUE IF (STR(I) .NE. ADC(42)) THEN IF (STR(I) .EQ. EOL) I = I + 1 VAR(7*LVAR+L) = STR(I) L = L + 1 I = I + 1 GO TO 20 END IF IF (DATAX) THEN VAR(7*LVAR+L) = ADC(22) CALL OUTINT(L-1,SAVE,LSAVE,NWRITE) IF (COL .GT. 72) CALL CONTST(NWRITE) CARD(COL) = ADC(58) COL = COL + 1 ELSE VAR(7*LVAR+L) = STR(I) VAR(7*LVAR+L+1) = ADC(22) END IF CALL OUTSTR(VAR(7*LVAR+1),NWRITE) GO TO 10 END IF IF (COL .GT. 72) CALL CONTST(NWRITE) CARD(COL) = STR(I) COL = COL + 1 GO TO 10 END IF RETURN C C LAST CARD OF SUBROUTINE FORMTR. C END C*********************************************************************** SUBROUTINE GRDCOP(INVAR,SAVE,LSAVE,NWRITE,EXPR,LEXPR,NMTBL,LNMTBL, * CRYSP,LCRYSP,VAR,LVAR,VARD,LVARD,TLIM) C C THIS ROUTINE COPIES PART OF THE ROWVECTOR CORRESPONDING TO GRAD. C INTEGER INVAR,LSAVE,NWRITE,LEXPR,LNMTBL,LCRYSP,LVAR,LVARD,TLIM CHARACTER NMTBL(0:LNMTBL),CRYSP(LCRYSP),VAR(9*LVAR) INTEGER SAVE(0:5*LSAVE+4),EXPR(0:4*LEXPR),VARD(8*LVARD) CHARACTER ADC(86),C(5) CHARACTER*13 RCALL(9) INTEGER ADDROF,CONFLG,DIMOF,IGRAD,IN,JFLG,JGRAD,LGRAD,LYGRAD,OUT, * OUTP,RESULT,RGRAD,SENTNL,SIZOVR,STDOVR,TYPRSL,YGRAD COMMON /CONTRL/ IN,OUT,RESULT,TYPRSL COMMON /GRAD/ IGRAD,JGRAD,LGRAD,LYGRAD,RGRAD,YGRAD COMMON /XCHAR/ ADC COMMON /CALLS/ RCALL COMMON /FLAGS/ OUTP,SENTNL,JFLG,CONFLG DATA C /'L','J','A','C','@'/ CALL FORWRD(7) IF (TYPRSL .GE. 32) CALL OUTSTR(RCALL(8),NWRITE) IF (TYPRSL .LT. 32) CALL OUTSTR(RCALL(9),NWRITE) CALL SHOWEX(RESULT,SAVE,LSAVE,NWRITE,EXPR,LEXPR,NMTBL,LNMTBL, * CRYSP,LCRYSP,VAR,LVAR,VARD,LVARD,TLIM) CALL CEMIT(ADC(30),NWRITE) CALL SHOWEX(IGRAD,SAVE,LSAVE,NWRITE,EXPR,LEXPR,NMTBL,LNMTBL, * CRYSP,LCRYSP,VAR,LVAR,VARD,LVARD,TLIM) CALL CEMIT(ADC(30),NWRITE) IF (JFLG .EQ. 1) CALL OUTSTR(C,NWRITE) IF (JFLG .NE. 1) * CALL SHOWEX(STDOVR(RESULT,SAVE,LSAVE,NWRITE,EXPR,LEXPR,VARD, * LVARD),SAVE,LSAVE,NWRITE,EXPR,LEXPR,NMTBL,LNMTBL, * CRYSP,LCRYSP,VAR,LVAR,VARD,LVARD,TLIM) CALL CEMIT(ADC(30),NWRITE) CALL SHOWEX(YGRAD,SAVE,LSAVE,NWRITE,EXPR,LEXPR,NMTBL,LNMTBL, * CRYSP,LCRYSP,VAR,LVAR,VARD,LVARD,TLIM) CALL CEMIT(ADC(38),NWRITE) CALL SHOWEX(ADDROF(INVAR,NWRITE,EXPR,LEXPR,VARD,LVARD),SAVE, * LSAVE,NWRITE,EXPR,LEXPR,NMTBL,LNMTBL,CRYSP,LCRYSP, * VAR,LVAR,VARD,LVARD,TLIM) IF (DIMOF(INVAR,EXPR,LEXPR,VARD,LVARD) .NE. 0) * CALL OUTSTR(RCALL(7),NWRITE) CALL CEMIT(ADC(39),NWRITE) CALL CEMIT(ADC(30),NWRITE) CALL SHOWEX(SIZOVR(INVAR,SAVE,LSAVE,NWRITE,EXPR,LEXPR,VARD,LVARD), * SAVE,LSAVE,NWRITE,EXPR,LEXPR,NMTBL,LNMTBL,CRYSP, * LCRYSP,VAR,LVAR,VARD,LVARD,TLIM) CALL CEMIT(ADC(39),NWRITE) CALL INITST(NWRITE) RETURN C C LAST CARD OF SUBROUTINE GRDCOP. C END C*********************************************************************** SUBROUTINE GENDCL(SAVE,LSAVE,NWRITE,EXPR,LEXPR,NMTBL,LNMTBL, * CRYSP,LCRYSP,VAR,LVAR,VARD,LVARD,TLIM) C C THIS ROUTINE GENERATES ALL NECESSARY DECLARATIONS AND DUMPS C THEM IN FORTRAN READABLE FORM. "GENDCL" CAN BE CALLED C IMMEDIATELY AFTER OUTPUTTING THE SUBROUTINE HEADING. C CHARACTER NMTBL(0:LNMTBL),CRYSP(LCRYSP),VAR(9*LVAR) INTEGER LSAVE,NWRITE,LEXPR,LNMTBL,LCRYSP,LVAR,LVARD,TLIM INTEGER SAVE(0:5*LSAVE+4),EXPR(0:4*LEXPR),VARD(8*LVARD) CHARACTER ADC(86),CARD(74),TEMP(10),C1(8),C2(6) CHARACTER*17 TABLE(2),STABLE(2),DTABLE(2) CHARACTER*18 TYPNAM(5) INTEGER COL,COMP,CRYPNT,EXPFRE,I,J,K,LASTCH,LENGTH,NEXTCH,NSMTAB, * NTFREE,NTIND,T,T1,TX,VD INTEGER CHAIN(0:500) COMMON /COUNTR/ CRYPNT,EXPFRE,NSMTAB,NTFREE COMMON /XCHAR/ ADC COMMON /KTYPE/ TYPNAM COMMON /IMAGE/ CARD COMMON /COUNTS/ COL,LASTCH,NEXTCH COMMON /SIGN/ K DATA TABLE /'JACOB@','0'/ DATA STABLE /'SIGN@','0'/ DATA DTABLE /'DSIGN@','0'/ DATA C1 /',','J','A','C','O','B','(','@'/ DATA C2 /'L','J','A','C',',','@'/ K = 0 NTIND = 1 5 CONTINUE IF ((COMP(NMTBL(NTIND),STABLE) .GT. 0) .OR. * (COMP(NMTBL(NTIND),DTABLE) .GT. 0)) K = 1 NTIND = NTIND + 1 IF (NTIND .LT. NTFREE) GO TO 5 DO 10 T = 0, 500 CHAIN(T) = 0 10 CONTINUE DO 20 VD = NSMTAB, 1, -1 T = VARD(LVARD+VD)/8 IF (T .GE. 5) T = VARD(LVARD+VD) - 40 VARD(7*LVARD+VD) = CHAIN(T) CHAIN(T) = VD 20 CONTINUE DO 80 T = 0, 500 IF (CHAIN(T) .EQ. 0) GO TO 80 T1 = MIN(T,5) IF (T1 .EQ. 0) T1 = 5 VD = CHAIN(T) NTIND = VARD(VD) I = COMP(NMTBL(NTIND),DTABLE) IF ((I .GT. 0) .AND. (T .EQ. 3)) T1 = 4 CALL INITST(NWRITE) CALL FORWRD(7) CALL OUTSTR(TYPNAM(T1),NWRITE) IF (T1 .EQ. 5) THEN IF (VARD(LVARD+VD) .EQ. 40) THEN CALL CEMIT(ADC(25),NWRITE) CALL CEMIT(ADC(38),NWRITE) CALL CEMIT(ADC(25),NWRITE) CALL CEMIT(ADC(39),NWRITE) GO TO 25 END IF LENGTH = VARD(LVARD+VD) - 40 CALL CEMIT(ADC(25),NWRITE) CALL OUTINT(LENGTH,SAVE,LSAVE,NWRITE) 25 CONTINUE CALL CEMIT(ADC(32),NWRITE) END IF CALL DCLVAR(VD,SAVE,LSAVE,NWRITE,EXPR,LEXPR,NMTBL,LNMTBL, * CRYSP,LCRYSP,VAR,LVAR,VARD,LVARD,TLIM,T1) 30 CONTINUE VD = VARD(7*LVARD+VD) IF (VD .EQ. 0) GO TO 80 TX = VARD(VD) IF ((T .EQ. 3) .OR. (T .EQ. 4)) THEN IF ((NMTBL(TX+5) .EQ. ADC(38)) .AND. * (NMTBL(TX+6) .EQ. ADC(51))) GO TO 80 IF ((NMTBL(TX+4) .EQ. ADC(38)) .AND. * (NMTBL(TX+5) .EQ. ADC(51))) GO TO 80 END IF IF (COMP(NMTBL(TX),TABLE) .LE. 0) GO TO 70 CALL OUTSTR(C1,NWRITE) CALL SHOWEX(VARD(2*LVARD+VD),SAVE,LSAVE,NWRITE,EXPR,LEXPR, * NMTBL,LNMTBL,CRYSP,LCRYSP,VAR,LVAR,VARD,LVARD, * TLIM) I = 10 40 CONTINUE COL = COL - 1 IF (CARD(COL) .EQ. ADC(30)) GO TO 50 TEMP(I) = CARD(COL) I = I - 1 GO TO 40 50 CONTINUE COL = COL - 1 IF (CARD(COL) .NE. ADC(38)) GO TO 50 COL = COL + 1 CALL OUTSTR(C2,NWRITE) DO 60 J = I+1, 10 CARD(COL) = TEMP(J) COL = COL + 1 IF (COL .GT. 72) CALL CONTST(NWRITE) 60 CONTINUE CALL CEMIT(ADC(39),NWRITE) GO TO 30 70 CONTINUE CALL CEMIT(ADC(30),NWRITE) CALL DCLVAR(VD,SAVE,LSAVE,NWRITE,EXPR,LEXPR,NMTBL,LNMTBL, * CRYSP,LCRYSP,VAR,LVAR,VARD,LVARD,TLIM,T1) GO TO 30 80 CONTINUE RETURN C C LAST CARD OF SUBROUTINE GENDCL. C END C*********************************************************************** SUBROUTINE DCLVAR(VD,SAVE,LSAVE,NWRITE,EXPR,LEXPR,NMTBL,LNMTBL, * CRYSP,LCRYSP,VAR,LVAR,VARD,LVARD,TLIM,T1) CHARACTER NMTBL(0:LNMTBL),CRYSP(LCRYSP),VAR(9*LVAR) INTEGER VD,LSAVE,NWRITE,LEXPR,LNMTBL,LCRYSP,LVAR,LVARD,TLIM,T1 INTEGER SAVE(0:5*LSAVE+4),EXPR(0:4*LEXPR),VARD(8*LVARD) INTEGER COMP,I,K CHARACTER ADC(86),C1(6),C2(7) CHARACTER*7 CHS(6) CHARACTER*13 SUPR(4) CHARACTER*17 STABLE(2),DTABLE(2) INTEGER LENGTH,NTIND,T COMMON /XCHAR/ ADC COMMON /CHSTR/ CHS,SUPR COMMON /SIGN/ K DATA STABLE /'ABS@','0'/ DATA DTABLE /'DABS@','0'/ DATA C1 /',','S','I','G','N','@'/ DATA C2 /',','D','S','I','G','N','@'/ NTIND = VARD(VD) IF (NTIND .LT. 0) THEN CALL NTDSPL(-NTIND,SAVE,LSAVE,NWRITE,NMTBL,LNMTBL,VAR,LVAR) ELSE IF (NTIND .EQ. 0) THEN CALL OUTSTR(CHS(6),NWRITE) CALL OUTINT(VD,SAVE,LSAVE,NWRITE) ELSE CALL NTDSPL(NTIND,SAVE,LSAVE,NWRITE,NMTBL,LNMTBL,VAR,LVAR) I = COMP(NMTBL(NTIND),STABLE) IF ((I .GT. 0) .AND. (K .NE. 1)) CALL OUTSTR(C1,NWRITE) I = COMP(NMTBL(NTIND),DTABLE) IF ((I .GT. 0) .AND. (K .NE. 1)) CALL OUTSTR(C2,NWRITE) END IF IF (T1 .EQ. 5) GO TO 10 T = VARD(LVARD+VD)/8 LENGTH = VARD(LVARD+VD) - 8*T IF (LENGTH .NE. 0) THEN CALL CEMIT(ADC(25),NWRITE) CALL OUTINT(LENGTH,SAVE,LSAVE,NWRITE) END IF 10 CONTINUE IF (VARD(2*LVARD+VD) .NE. 0) THEN CALL CEMIT(ADC(38),NWRITE) CALL SHOWEX(VARD(2*LVARD+VD),SAVE,LSAVE,NWRITE,EXPR,LEXPR, * NMTBL,LNMTBL,CRYSP,LCRYSP,VAR,LVAR,VARD,LVARD, * TLIM) CALL CEMIT(ADC(39),NWRITE) END IF IF (VARD(3*LVARD+VD) .NE. 0) THEN CALL CEMIT(ADC(26),NWRITE) CALL SHOWEX(VARD(3*LVARD+VD),SAVE,LSAVE,NWRITE,EXPR,LEXPR, * NMTBL,LNMTBL,CRYSP,LCRYSP,VAR,LVAR,VARD,LVARD, * TLIM) CALL CEMIT(ADC(26),NWRITE) END IF RETURN C C LAST CARD OF SUBROUTINE DCLVAR. C END C********************************************************************* INTEGER FUNCTION SIZOVR(V,SAVE,LSAVE,NWRITE,EXPR,LEXPR,VARD, * LVARD) C C THIS ROUTINE RETURNS AN EXPRESSION REPRESENTING THE SIZE OF C THE ARENA V. C INTEGER V,LSAVE,NWRITE,LEXPR,LVARD INTEGER SAVE(0:5*LSAVE+4),EXPR(0:4*LEXPR),VARD(8*LVARD) INTEGER INTONE,INTTWO,MULTPL INTEGER AD(86) COMMON /INTS/ INTONE,INTTWO COMMON /ZCHAR/ AD SIZOVR = -1 IF (EXPR(2*LEXPR+V) .EQ. AD(13)) SIZOVR = INTONE IF (VARD(2*LVARD+EXPR(3*LEXPR+V)) .NE. 0) * SIZOVR = MULTPL(VARD(2*LVARD+EXPR(3*LEXPR+V)),SAVE,LSAVE, * NWRITE,EXPR,LEXPR) RETURN C C LAST CARD OF INTEGER FUNCTION SIZOVR. C END C*********************************************************************** SUBROUTINE NTDSPL(NTIND,SAVE,LSAVE,NWRITE,NMTBL,LNMTBL,VAR, * LVAR) C C THIS ROUTINE DISPLAYS THE LEXSEG IN NAME TABLE STARTING AT NTIND. C CHARACTER NMTBL(0:LNMTBL),VAR(9*LVAR) INTEGER NTIND,LSAVE,NWRITE,LNMTBL,LVAR INTEGER SAVE(0:5*LSAVE+4) CHARACTER C(6) DATA C /'!','*','*','*','!','@'/ IF (NTIND .EQ. -1) CALL OUTSTR(C,NWRITE) IF (NTIND .NE. -1) * CALL FORMTR(NMTBL(NTIND),SAVE,LSAVE,NWRITE,VAR,LVAR) RETURN C C LAST CARD OF SUBROUTINE NTDSPL. C END C*********************************************************************** INTEGER FUNCTION DIFFER(S,SAVE,LSAVE,NWRITE,EXPR,LEXPR,VARD,LVARD) C C THIS ROUTINE RETURNS THE DERIVATIVE OF AN ASSIGNMENT S. C INTEGER S,LSAVE,NWRITE,LEXPR,LVARD INTEGER SAVE(0:5*LSAVE+4),EXPR(0:4*LEXPR),VARD(8*LVARD) INTEGER ADDROF,COERCE,CONST,DEPCNT,DISTBR,EXPTYP,FLTHLF,FLTNEG, * FLTONE,FLTZER,IN,INTONE,INTTWO,L,LADDR,LD,MAKEEL,OUT,P, * PRIND,Q,R,RADDR,RD,RESULT,SS,TEMP,TKN,TMPIND,TYPRSL,V INTEGER AD(86),ARITY(0:255),DEFLEN(42),DEFTYP(42),DESCR(1000) CHARACTER*70 ERRM1,ERRM2 COMMON /INTS/ INTONE,INTTWO COMMON /FLT/ FLTONE,FLTHLF,FLTNEG,FLTZER COMMON /DATAB/ ARITY,DEFLEN,DEFTYP,DESCR COMMON /CONTRL/ IN,OUT,RESULT,TYPRSL COMMON /TIND/ DEPCNT,PRIND,RADDR,TMPIND COMMON /ZCHAR/ AD DATA ERRM1 /' UNRECOGNIZED UNARY OPERATION'/ DATA ERRM2 /' WRONG BINARY OPERATION'/ P = EXPR(3*LEXPR+S) V = EXPR(S) TKN = EXPR(2*LEXPR+P) DIFFER = S IF (CONST(P,SAVE,LSAVE,NWRITE,EXPR,LEXPR,VARD,LVARD) * .EQ. 1) GO TO 40 TEMP = ARITY(TKN) + 1 C C BECAUSE NON-CONSTANT, THIS MUST EITHER BE AN IDENTIFIER OR AN C INDEXED VARIABLE. C IF (TEMP .EQ. 1) THEN RD = FLTONE Q = DISTBR(AD(30),DISTBR(AD(30),ADDROF(P,NWRITE,EXPR,LEXPR, * VARD,LVARD),RD,NWRITE,EXPR,LEXPR),ADDROF(V,NWRITE, * EXPR,LEXPR,VARD,LVARD),NWRITE,EXPR,LEXPR) Q = DISTBR(2,TYPRSL,Q,NWRITE,EXPR,LEXPR) DIFFER = DISTBR(AD(27),Q,S,NWRITE,EXPR,LEXPR) ELSE IF (TEMP .EQ. 2) THEN R = EXPR(3*LEXPR+P) R = MAKEEL(R,SAVE,LSAVE,NWRITE,EXPR,LEXPR,VARD,LVARD) P = DISTBR(TKN,EXPR(P),R,NWRITE,EXPR,LEXPR) IF (TKN .NE. AD(1)) * P = DISTBR(TKN,EXPTYP(R,SAVE,LSAVE,NWRITE,EXPR,LEXPR, * VARD,LVARD),R,NWRITE,EXPR,LEXPR) SS = DISTBR(AD(31),V,P,NWRITE,EXPR,LEXPR) IF (TKN .EQ. AD(35)) THEN RD = FLTNEG ELSE IF (TKN .EQ. AD(4)) THEN RD = DISTBR(AD(5),TYPRSL,COERCE(R,SAVE,LSAVE,NWRITE, * EXPR,LEXPR,VARD,LVARD),NWRITE,EXPR,LEXPR) ELSE IF (TKN .EQ. AD(5)) THEN RD = DISTBR(AD(35),0,DISTBR(AD(4),TYPRSL,COERCE(R,SAVE, * LSAVE,NWRITE,EXPR,LEXPR,VARD,LVARD),NWRITE,EXPR, * LEXPR),NWRITE,EXPR,LEXPR) ELSE IF (TKN .EQ. AD(11)) THEN RD = DISTBR(AD(14),TYPRSL,COERCE(R,SAVE,LSAVE,NWRITE, * EXPR,LEXPR,VARD,LVARD),NWRITE,EXPR,LEXPR) ELSE IF (TKN .EQ. AD(14)) THEN RD = DISTBR(AD(11),TYPRSL,COERCE(R,SAVE,LSAVE,NWRITE, * EXPR,LEXPR,VARD,LVARD),NWRITE,EXPR,LEXPR) ELSE IF (TKN .EQ. AD(15)) THEN RD = DISTBR(AD(16),TYPRSL,COERCE(R,SAVE,LSAVE,NWRITE, * EXPR,LEXPR,VARD,LVARD),NWRITE,EXPR,LEXPR) ELSE IF (TKN .EQ. AD(3)) THEN RD = DISTBR(AD(26),FLTONE,R,NWRITE,EXPR,LEXPR) RD = COERCE(RD,SAVE,LSAVE,NWRITE,EXPR,LEXPR,VARD,LVARD) ELSE IF (TKN .EQ. AD(2)) THEN RD = COERCE(V,SAVE,LSAVE,NWRITE,EXPR,LEXPR,VARD,LVARD) ELSE IF (TKN .EQ. AD(6)) THEN RD = DISTBR(AD(26),FLTHLF,COERCE(V,SAVE,LSAVE,NWRITE, * EXPR,LEXPR,VARD,LVARD),NWRITE,EXPR,LEXPR) ELSE IF (TKN .EQ. AD(7)) THEN RD = DISTBR(AD(26),FLTONE,DISTBR(AD(23),FLTONE, * DISTBR(AD(36),COERCE(R,SAVE,LSAVE,NWRITE,EXPR,LEXPR, * VARD,LVARD),INTTWO,NWRITE,EXPR,LEXPR),NWRITE,EXPR, * LEXPR),NWRITE,EXPR,LEXPR) ELSE IF (TKN .EQ. AD(8)) THEN RD = DISTBR(AD(5),TYPRSL,COERCE(R,SAVE,LSAVE,NWRITE, * EXPR,LEXPR,VARD,LVARD),NWRITE,EXPR,LEXPR) RD = DISTBR(AD(26),FLTONE,DISTBR(AD(36),COERCE(RD,SAVE, * LSAVE,NWRITE,EXPR,LEXPR,VARD,LVARD),INTTWO, * NWRITE,EXPR,LEXPR),NWRITE,EXPR,LEXPR) ELSE IF (TKN .EQ. AD(9)) THEN RD = DISTBR(AD(24),FLTONE,DISTBR(AD(36),COERCE(R,SAVE, * LSAVE,NWRITE,EXPR,LEXPR,VARD,LVARD),INTTWO, * NWRITE,EXPR,LEXPR),NWRITE,EXPR,LEXPR) RD = DISTBR(AD(26),FLTONE,DISTBR(AD(6),TYPRSL, * COERCE(RD,SAVE,LSAVE,NWRITE,EXPR,LEXPR,VARD, * LVARD),NWRITE,EXPR,LEXPR),NWRITE,EXPR,LEXPR) ELSE IF (TKN .EQ. AD(1)) THEN RD = FLTONE ELSE CALL ERRORM(ERRM1,NWRITE) END IF Q = DISTBR(AD(30),DISTBR(AD(30),RADDR,RD,NWRITE,EXPR,LEXPR), * ADDROF(V,NWRITE,EXPR,LEXPR,VARD,LVARD),NWRITE,EXPR, * LEXPR) Q = DISTBR(2,TYPRSL,Q,NWRITE,EXPR,LEXPR) IF ((TKN .EQ. AD(2)) .OR. (TKN .EQ. AD(6))) THEN DIFFER = DISTBR(AD(27),SS,Q,NWRITE,EXPR,LEXPR) GO TO 40 END IF DIFFER = DISTBR(AD(27),Q,SS,NWRITE,EXPR,LEXPR) ELSE IF (TEMP .EQ. 3) THEN IF (TKN .EQ. 4) THEN Q = DISTBR(1,TYPRSL,ADDROF(V,NWRITE,EXPR,LEXPR,VARD,LVARD), * NWRITE,EXPR,LEXPR) DIFFER = DISTBR(AD(27),Q,S,NWRITE,EXPR,LEXPR) GO TO 40 END IF L = EXPR(P) R = EXPR(3*LEXPR+P) IF (CONST(L,SAVE,LSAVE,NWRITE,EXPR,LEXPR,VARD,LVARD) * .EQ. 1) THEN L = MAKEEL(L,SAVE,LSAVE,NWRITE,EXPR,LEXPR,VARD,LVARD) R = MAKEEL(R,SAVE,LSAVE,NWRITE,EXPR,LEXPR,VARD,LVARD) P = DISTBR(TKN,L,R,NWRITE,EXPR,LEXPR) SS = DISTBR(AD(31),V,P,NWRITE,EXPR,LEXPR) IF (TKN .EQ. AD(23)) THEN RD = FLTONE ELSE IF (TKN .EQ. AD(24)) THEN RD = FLTNEG ELSE IF (TKN .EQ. AD(25)) THEN RD = COERCE(L,SAVE,LSAVE,NWRITE,EXPR,LEXPR,VARD,LVARD) ELSE IF (TKN .EQ. AD(26)) THEN RD = DISTBR(AD(35),0,DISTBR(AD(26),L,DISTBR(AD(36), * R,INTTWO,NWRITE,EXPR,LEXPR),NWRITE,EXPR, * LEXPR),NWRITE,EXPR,LEXPR) RD = COERCE(RD,SAVE,LSAVE,NWRITE,EXPR,LEXPR,VARD,LVARD) ELSE IF (TKN .EQ. AD(36)) THEN RD = DISTBR(AD(25),DISTBR(AD(3),TYPRSL,COERCE(L,SAVE, * LSAVE,NWRITE,EXPR,LEXPR,VARD,LVARD),NWRITE, * EXPR,LEXPR),COERCE(V,SAVE,LSAVE,NWRITE,EXPR, * LEXPR,VARD,LVARD),NWRITE,EXPR,LEXPR) ELSE CALL ERRORM(ERRM2,NWRITE) END IF Q = DISTBR(AD(30),DISTBR(AD(30),RADDR,RD,NWRITE,EXPR, * LEXPR),ADDROF(V,NWRITE,EXPR,LEXPR,VARD,LVARD), * NWRITE,EXPR,LEXPR) Q = DISTBR(2,TYPRSL,Q,NWRITE,EXPR,LEXPR) DIFFER = DISTBR(AD(27),SS,Q,NWRITE,EXPR,LEXPR) IF (TKN .NE. AD(36)) * DIFFER = DISTBR(AD(27),Q,SS,NWRITE,EXPR,LEXPR) GO TO 40 END IF IF (CONST(R,SAVE,LSAVE,NWRITE,EXPR,LEXPR,VARD,LVARD) * .EQ. 1) THEN L = MAKEEL(L,SAVE,LSAVE,NWRITE,EXPR,LEXPR,VARD,LVARD) LADDR = RADDR R = MAKEEL(R,SAVE,LSAVE,NWRITE,EXPR,LEXPR,VARD,LVARD) P = DISTBR(TKN,L,R,NWRITE,EXPR,LEXPR) SS = DISTBR(AD(31),V,P,NWRITE,EXPR,LEXPR) IF (TKN .EQ. AD(23)) THEN LD = FLTONE ELSE IF (TKN .EQ. AD(24)) THEN LD = FLTONE ELSE IF (TKN .EQ. AD(25)) THEN LD = COERCE(R,SAVE,LSAVE,NWRITE,EXPR,LEXPR,VARD, * LVARD) ELSE IF (TKN .EQ. AD(26)) THEN LD = DISTBR(AD(26),FLTONE,R,NWRITE,EXPR,LEXPR) LD = COERCE(LD,SAVE,LSAVE,NWRITE,EXPR,LEXPR,VARD, * LVARD) ELSE IF (TKN .EQ. AD(36)) THEN GO TO 10 ELSE CALL ERRORM(ERRM2,NWRITE) END IF GO TO 30 10 CONTINUE IF (EXPR(2*LEXPR+R) .EQ. AD(33)) THEN IF (EXPR(3*LEXPR+R) .EQ. 0) THEN LD = FLTZER ELSE IF (EXPR(3*LEXPR+R) .EQ. 1) THEN LD = L ELSE IF (EXPR(3*LEXPR+R) .EQ. 2) THEN LD = DISTBR(AD(23),L,L,NWRITE,EXPR,LEXPR) ELSE P=DISTBR(AD(33),0,EXPR(3*LEXPR+R)-1,NWRITE,EXPR, * LEXPR) LD = DISTBR(AD(25),R,DISTBR(AD(36),L,P,NWRITE,EXPR, * LEXPR),NWRITE,EXPR,LEXPR) END IF GO TO 20 END IF P = DISTBR(AD(24),R,INTONE,NWRITE,EXPR,LEXPR) LD = DISTBR(AD(25),R,DISTBR(AD(36),L,P,NWRITE,EXPR,LEXPR), * NWRITE,EXPR,LEXPR) 20 CONTINUE LD = COERCE(LD,SAVE,LSAVE,NWRITE,EXPR,LEXPR,VARD,LVARD) 30 CONTINUE Q = DISTBR(AD(30),DISTBR(AD(30),LADDR,LD,NWRITE,EXPR,LEXPR), * ADDROF(V,NWRITE,EXPR,LEXPR,VARD,LVARD),NWRITE, * EXPR,LEXPR) Q = DISTBR(2,TYPRSL,Q,NWRITE,EXPR,LEXPR) DIFFER = DISTBR(AD(27),Q,SS,NWRITE,EXPR,LEXPR) GO TO 40 END IF L = MAKEEL(L,SAVE,LSAVE,NWRITE,EXPR,LEXPR,VARD,LVARD) LADDR = RADDR R = MAKEEL(R,SAVE,LSAVE,NWRITE,EXPR,LEXPR,VARD,LVARD) P = DISTBR(TKN,L,R,NWRITE,EXPR,LEXPR) SS = DISTBR(AD(31),V,P,NWRITE,EXPR,LEXPR) IF (TKN .EQ. AD(23)) THEN LD = FLTONE RD = FLTONE ELSE IF (TKN .EQ. AD(24)) THEN LD = FLTONE RD = FLTNEG ELSE IF (TKN .EQ. AD(25)) THEN LD = COERCE(R,SAVE,LSAVE,NWRITE,EXPR,LEXPR,VARD,LVARD) RD = COERCE(L,SAVE,LSAVE,NWRITE,EXPR,LEXPR,VARD,LVARD) ELSE IF (TKN .EQ. AD(26)) THEN LD = DISTBR(AD(26),FLTONE,R,NWRITE,EXPR,LEXPR) LD = COERCE(LD,SAVE,LSAVE,NWRITE,EXPR,LEXPR,VARD,LVARD) RD = DISTBR(AD(35),0,DISTBR(AD(26),L,DISTBR(AD(36),R, * INTTWO,NWRITE,EXPR,LEXPR),NWRITE,EXPR,LEXPR), * NWRITE,EXPR,LEXPR) RD = COERCE(RD,SAVE,LSAVE,NWRITE,EXPR,LEXPR,VARD,LVARD) ELSE IF (TKN .EQ. AD(36)) THEN LD = DISTBR(AD(25),R,DISTBR(AD(36),L,DISTBR(AD(24),R, * INTONE,NWRITE,EXPR,LEXPR),NWRITE,EXPR,LEXPR), * NWRITE,EXPR,LEXPR) LD = COERCE(LD,SAVE,LSAVE,NWRITE,EXPR,LEXPR,VARD,LVARD) RD = DISTBR(AD(25),DISTBR(AD(3),TYPRSL,L,NWRITE,EXPR, * LEXPR),DISTBR(AD(36),L,R,NWRITE,EXPR,LEXPR), * NWRITE,EXPR,LEXPR) RD = COERCE(RD,SAVE,LSAVE,NWRITE,EXPR,LEXPR,VARD,LVARD) ELSE CALL ERRORM(ERRM2,NWRITE) END IF Q = DISTBR(AD(30),DISTBR(AD(30),RADDR,RD,NWRITE,EXPR,LEXPR), * ADDROF(V,NWRITE,EXPR,LEXPR,VARD,LVARD),NWRITE, * EXPR,LEXPR) Q = DISTBR(AD(30),DISTBR(AD(30),LADDR,LD,NWRITE,EXPR,LEXPR), * Q,NWRITE,EXPR,LEXPR) Q = DISTBR(3,TYPRSL,Q,NWRITE,EXPR,LEXPR) DIFFER = DISTBR(AD(27),Q,SS,NWRITE,EXPR,LEXPR) END IF 40 CONTINUE RETURN C C LAST CARD OF INTEGER FUNCTION DIFFER. C END C*********************************************************************** INTEGER FUNCTION ADDR(C) C C THIS ROUTINE FINDS THE INTEGER VALUE OF THE CHARACTER C. C CHARACTER C INTEGER INDEX INTEGER AETAB(126),EATAB(0:255) COMMON /CTBL/ AETAB,EATAB INDEX = ICHAR(C(1:1)) ADDR = EATAB(INDEX) RETURN END C*********************************************************************** CHARACTER FUNCTION ACHAR(K) C C THIS ROUTINE FINDS THE CHARACTER EQUIVALENT OF THE INTEGER K. C INTEGER K INTEGER INDEX INTEGER AETAB(126),EATAB(0:255) COMMON /CTBL/ AETAB,EATAB INDEX = AETAB(K) ACHAR = CHAR(INDEX) RETURN C C LAST CARD OF CHARACTER FUNCTION ACHAR. C END C********************************************************************* INTEGER FUNCTION STDOVR(V,SAVE,LSAVE,NWRITE,EXPR,LEXPR,VARD, * LVARD) C C THIS ROUTINE RETURNS AN EXPRESSION REPRESENTING THE STRIDE C OF THE VARIABLE V. THE STRIDE IS THE DISTANCE IN MEMORY C BETWEEN V(.,I) AND V(.,I+1). C INTEGER V,LSAVE,NWRITE,LEXPR,LVARD INTEGER SAVE(0:5*LSAVE+4),EXPR(0:4*LEXPR),VARD(8*LVARD) INTEGER INTONE,INTTWO,MULTPL,P,VD INTEGER AD(86) COMMON /INTS/ INTONE,INTTWO COMMON /ZCHAR/ AD STDOVR = INTONE IF (EXPR(2*LEXPR+V) .NE. AD(13)) THEN STDOVR = -1 ELSE VD = EXPR(3*LEXPR+V) IF (VARD(2*LVARD+VD) .EQ. 0) GO TO 10 P = VARD(2*LVARD+VD) IF (EXPR(2*LEXPR+P) .EQ. AD(30)) * STDOVR = MULTPL(EXPR(P),SAVE,LSAVE,NWRITE,EXPR,LEXPR) END IF 10 CONTINUE RETURN C C LAST CARD OF INTEGER FUNCTION STDOVR. C END C*********************************************************************** SUBROUTINE TKDSPL(T,NWRITE) C C THIS ROUTINE PRINTS A TOKEN. C INTEGER T,NWRITE CHARACTER ACHAR,CADD CHARACTER ADC(86) CHARACTER*12 NIL CHARACTER*12 NAMES(126) COMMON /NAME/ NAMES COMMON /XCHAR/ ADC NIL = ADC(20) IF (NAMES(T) .NE. NIL) CALL OUTSTR(NAMES(T),NWRITE) IF (NAMES(T) .EQ. NIL) THEN IF (T .GT. 32) THEN CADD = ACHAR(T) CALL CEMIT(CADD,NWRITE) GO TO 10 END IF WRITE (NWRITE,'(I3)') T END IF 10 CONTINUE RETURN C C LAST CARD OF SUBROUTINE TKDSPL. C END .