CGRAM: MAIN PROG 17/5/77 REVISED 17/5/21 EXTENDED SVG DRIVER 10/07/21 C C+ is a comment not in the original version IMPLICIT INTEGER*2 (I-N) COMMON LIST(5000),LNK(5000) COMMON/MAT/MA(1000),MX(256),MY(256),MZ(256) COMMON/MAIN/IW,IA,LSTAK,MS,LS,MC,NC,M0,M1,M2,NAMCH,IARG,JARG,NARG COMMON/TYPES/MNEG,MSYM,MADR COMMON/IO1/ICH(71),ISB(71),IOB(72),INP,IOP,NCL,NCW,KSHIFT(4) COMMON/IO2/JQ,LQ,NQ,KSYM(18),KBLANK COMMON/IO3/MIP,MOP,NID,NOD COMMON/OVL/NOL COMMON/OUPT/NIB,NOF COMMON/BUG/KBUG(6),LADR COMMON/SEP/LLS COMMON/EXTEND/LINIT,IOCH,NCOLS,IPRMX COMMON/FIGS/IFIG(20),ICOL(20),FADE(20),LEV(20), + IOUT(50),NFIG,NOUT,MFIG,MOUT,IEXTR COMMON/TREEC/XX,YX,ZX,XY,YY,ZY,XZ,YZ,ZZ,XO,YO,ZO, + PERSP,MWS,NWS,MSTOR,LTREE COMMON/GRAF/RS(240),FRACT,IT,MTREE,LINC,NCC,MAT,MTYPE,KDUM(30) DIMENSION NFN(20) EQUIVALENCE (KDUM(1),IRP),(KDUM(2),MRS),(KDUM(3),I1), + (KDUM(4),I2), (KDUM(5),I3),(KDUM(6),I4), + (KDUM(7),I5), (KDUM(8),I6),(KDUM(9),I7), + (KDUM(10),I8),(NFN(1),KDUM(11)) OPEN(UNIT=2,FILE='gram_outputv01.txt') OPEN(UNIT=5,FILE='gram_inputv01.txt') OPEN(UNIT=7,FILE='gram_outputv01.htm') OPEN(UNIT=8,FILE='gram_outputv01.svg') OPEN(UNIT=9,FILE='gram_outputv01_nod.txt') OPEN(UNIT=10,FILE='gram_outputv01_anim.htm') C+ INITIALISATIONs NOT IN ORIGINAL CALL INIT1 C+ C+ Initialise HTML file for SVG animation output C+ CALL INIHTM C CALL SETUP IQ=0 C C I/O CONTROL POINT 4 IF(NIB.LE.0) GOTO 5 CALL OUTPUT C 5 CONTINUE CALL INPUT C 7 IF(IQ)1,1,12 C C MAIN CYCLE C 2 CALL LOAD 1 CONTINUE CALL NEXT IF(IW.GT.MSYM) GOTO 2 N=IW-MNEG GOTO(10,2,30,40,60,70,50),N C C L.H.ANGLE BRACKET 10 CONTINUE IQ=IQ+1 12 CALL NEXT IF(IW.EQ.MSYM) GOTO 50 IF(IW.NE.MNEG+2) GOTO 15 IQ=IQ-1 IF(IQ.EQ.0) GOTO 1 15 CALL LOAD IF(IW.EQ.MNEG+1) GOTO 10 GOTO 12 C C STACK BEGINNING OF CALL 30 CONTINUE M=LSTAK CALL STACK(MS) MS=M GOTO 1 C C EXECUTE CALL 40 CONTINUE IF(MS.EQ.0) GOTO 2 M0=MS M1=LNK(M0) MS=LIST(M1) IF(M1.EQ.LSTAK) GOTO 48 M2=LNK(M1) N=LIST(M2) CALL ADRES(N) IF(IA) 41,80,41 41 IF(IW) 90,42,45 C 42 LSTAK=M0 IF(MS.EQ.0) WRITE(2,43) 43 FORMAT(6H WHAT?) GOTO 1 C 45 CALL SETARG LS=IW GOTO 1 C 48 LSTAK=M0 GOTO 1 C C END CALL 50 I=0 52 CONTINUE IF(LS.LE.0) GOTO 4 IF(MS.GE.0) GOTO 54 MS=-MS-1 IF(MS.EQ.0) CALL OUT(MSYM-INT(1,2)) C C REMOVE ARGUMENTS,ETC. 54 CONTINUE M1=LNK(MC) N=LNK(NC) NC=LIST(NC) LS=LIST(N) IF(LSTAK.EQ.N) GOTO 55 LNK(MC)=LNK(N) LNK(N)=LNK(LSTAK) LNK(LSTAK)=M1 GOTO 56 55 LSTAK=MC 56 MC=LIST(M1) NARG=0 IF(I)7,7,57 C C MULTIPLE EXIT 57 I=I-1 GOTO 52 C C LOAD ARGUMENT 60 CONTINUE CALL NEXT N=IW GOTO 64 C 62 N=LIST(LSTAK) LSTAK=M0 64 CONTINUE IF(MC)1,1,66 C C N>0: LOAD ARGUMENT N C N<0: LOAD ARGUMENTS UP TO & INCLUDING -N C N=0: LOAD MACRO NAME C N.B. NARG IS ONE MORE THAN ARG.NO. C 66 CONTINUE L=0 IF(N.LT.0) L=1 IF(N.LT.0) N=-N IF(NARG.GT.0.AND.N.GE.NARG) GOTO 68 C IARG=LNK(MC) IARG=LNK(IARG) NARG=1 C 68 I=N-NARG IF(I.LT.0) GOTO 69 CALL ADVAN(IARG,I,L) M=1 CALL ADVAN(IARG,M,INT(1,2)) NARG=NARG+I+M GOTO 1 C 69 IW=LIST(IARG) GOTO 2 C C STORE SEPARATOR ADDRESS 70 CONTINUE LADR=LLS GOTO 1 C C PRIMITIVES 90 IF(IW+40) 93,92,91 C C EXPRESSION 80 M2=M1 IW=-1 C 91 CONTINUE C++ IF(NOL.NE.4) CALL OLAY(4) CALL PRIM GOTO 1 C C READ WITHOUT EXECUTING 92 CONTINUE CALL READIN GOTO 1 C 93 IF(IW+50) 95,62,94 94 CONTINUE CALL SPOP(-IW-INT(40,2)) GOTO 1 C 95 IF(IW+60) 98,97,96 96 CONTINUE CALL PRIX(-IW-INT(50,2)) GOTO 1 C C FORCE OUTPUT 97 IF(NIB.LE.0) GOTO 1 NQ=LIST(LSTAK) CALL OUTPUT NQ=0 GOTO 1 C 98 IF(IW+90)99,900,600 C 600 CONTINUE CALL TOTREE(-IW-INT(60,2)) GOTO 1 C C EXIT FROM MACRO 900 I=LIST(LSTAK) LSTAK=M0 IF(I)52,1,57 C 99 IF(IW+100)110,100,910 C C EXECUTE TREE 910 CONTINUE CALL EXTREE GOTO 1 C 100 CONTINUE C FILE COMPLETIONS FOR OUTPUT WRITE(2,2020) 2020 FORMAT(4hSTOP) CALL PSTACK(INT(1,2),INT(2320,2),INT(13,2),'STACK AT EXIT') WRITE(7,2021) 2021 FORMAT(14H) WRITE(8,2022) 2022 FORMAT(4H,6H) WRITE(10,2022) WRITE(10,2021) STOP C C USER ROUTINE 110 CONTINUE CALL USER(-IW-INT(100,2)) GOTO 1 C END C BLOCK DATA C 20/5/77 IMPLICIT INTEGER*2 (I-N) COMMON LIST(5000),LNK(5000) COMMON/MAT/MA(1000),MX(256),MY(256),MZ(256) COMMON/GRAF/RS(240),FRACT,IT,MTREE,LINC,NCC,MAT,MTYPE,KDUM(30) COMMON/TREEC/XX,YX,ZX,XY,YY,ZY,XZ,YZ,ZZ,XO,YO,ZO, + PERSP,MWS,NWS,MSTOR,LTREE COMMON/FIGS/IFIG(20),ICOL(20),FADE(20),LEV(20), + IOUT(50),NFIG,NOUT,MFIG,MOUT,IEXTR COMMON/MAIN/IW,IA,LSTAK,MS,LS,MC,NC,M0,M1,M2,NAMCH,IARG,JARG,NARG COMMON/TYPES/MNEG,MSYM,MADR COMMON/INPT/INB(148),LCONT COMMON/IO1/ICH(71),ISB(71),IOB(72),ISP,IOP,NCL,NCW,KSHIFT(2) + ,KPITCH,KBIT COMMON/IO2/JQ,LQ,NQ,KSYM(18),KBLANK COMMON/IO3/MIP,MOP,NID,NOD COMMON/OUPT/NIB,NOF COMMON/BUG/KBUG(7) COMMON/SEP/LLS COMMON/GIP/LGRIN COMMON/WINDO/XMIN,XMAX,YMIN,YMAX DIMENSION NFN(20) EQUIVALENCE (KDUM(1),IRP),(KDUM(2),MRS),(KDUM(3),I1), + (KDUM(4),I2), (KDUM(5),I3), (KDUM(6),I4), + (KDUM(7),I5), (KDUM(8),I6), (KDUM(9),I7), + (KDUM(10),I8),(NFN(1),KDUM(11)) C DATA LSTAK/1/,MS,LS,NARG,MC,NC/5*0/,IOP/1/, + NCL/71/,IOB(1)/0/,ISP/72/,JQ,LQ,LGRIN/3*0/, + NQ/0/,NIB,NOF/2*0/,LCONT/0/,KBUG/7*0/, + XMIN,XMAX,YMIN,YMAX/-8191.,8191.,-6080.,6080./ C I/O STREAMS DATA MIP,NID/2*5/,MOP,NOD/2*2/ C 16-BIT BOUNDARIES DATA MNEG,MSYM,MADR/-32767,-32760,-8192/ C 16-BIT ASCII CHARACTER SYSTEM DATA NCW/2/,KSHIFT/1,256/,KPITCH/256/,KBIT/0/,KBLANK/32/, + KSYM/2H< ,2H> ,2H( ,2H) ,2H# ,2H^ ,2H; ,2H! , + 2H, ,2H[ ,2H] ,2H" ,2H- ,2H0 ,2H9 ,2HA ,2HZ ,2H / DATA LINC,NCC,MAT,MTYPE/4*0/, + MTREE/1000/,FRACT/0./,INB/148*0/ END C SUBROUTINE NEXT C 13/10/76 IMPLICIT INTEGER*2 (I-N) COMMON LIST(5000),LNK(5000) COMMON/MAT/MA(1000),MX(256),MY(256),MZ(256) COMMON/MAIN/IW,IA,LSTAK,MS,LS,MC,NC,M0,M1,M2,NAMCH,IARG,JARG,NARG COMMON/INPT/INB(148),LCONT COMMON/SEP/LLS COMMON/IO1/ICH(71),ISB(71),IOB(72),ISP,IOP,NCL,NCW,KSHIFT(2) + ,KPITCH,KBIT LLS=LS IF(LS.GT.0) GOTO 2 I=-LS IW=INB(I) LS=LS-1 RETURN C 2 IW=LIST(LS) LS=LNK(LS) RETURN END C SUBROUTINE LOAD C 13/10/76 IMPLICIT INTEGER*2 (I-N) COMMON/MAIN/IW,IA,LSTAK,MS,LS,MC,NC,M0,M1,M2,NAMCH,IARG,JARG,NARG IF(MS) 3,2,1 1 CALL STACK(IW) RETURN 2 CALL OUT(IW) RETURN 3 IF(MS+1)1,2,1 END C SUBROUTINE STACK(N) C 13/10/76 IMPLICIT INTEGER*2 (I-N) COMMON LIST(5000),LNK(5000) COMMON/MAT/MA(1000),MX(256),MY(256),MZ(256) COMMON/MAIN/IW,IA,LSTAK,MS,LS,MC,NC,M0,M1,M2,NAMCH,IARG,JARG,NARG COMMON/IO3/MIP,MOP,NID,NOD IF(LNK(LSTAK)) 2,2,1 1 LSTAK=LNK(LSTAK) LIST(LSTAK)=N RETURN C 2 WRITE(2,3) 3 FORMAT(17H MACRO STORE FULL) STOP END C SUBROUTINE ADVAN(J,N,L) C 13/10/76 IMPLICIT INTEGER*2 (I-N) COMMON LIST(5000),LNK(5000) COMMON/MAT/MA(1000),MX(256),MY(256),MZ(256) COMMON/MAIN/IW,IA,LSTAK,MS,LS,MC,NC,M0,M1,M2,NAMCH,IARG,JARG,NARG COMMON/TYPES/MNEG,MSYM,MADR C IF(N.LE.0.OR.J.LE.0) GOTO 4 C DO 2 I=1,N K=LNK(J) IW=LIST(K) IF(IW.EQ.MSYM) GOTO 3 IF(L.EQ.1) CALL LOAD 2 J=K RETURN C 3 N=I-1 RETURN C 4 N=0 RETURN END C SUBROUTINE SETARG C 13/10/76 IMPLICIT INTEGER*2 (I-N) COMMON LIST(5000),LNK(5000) COMMON/MAT/MA(1000),MX(256),MY(256),MZ(256) COMMON/MAIN/IW,IA,LSTAK,MS,LS,MC,NC,M0,M1,M2,NAMCH,IARG,JARG,NARG COMMON/TYPES/MNEG,MSYM,MADR LIST(M1)=MC MC=M0 CALL STACK(MSYM) CALL STACK(NC) NC=LSTAK CALL STACK(LS) NARG=0 RETURN END C INTEGER*2 FUNCTION ALPHA(N) C 13/5/76 IMPLICIT INTEGER*2 (I-N) COMMON/TYPES/MNEG,MSYM,MADR IF(N.GE.-MADR)ALPHA=1 IF(N.LT.-MADR)ALPHA=0 RETURN END C SUBROUTINE ADRES(M) C 13/10/76 IMPLICIT INTEGER*2 (I-N) COMMON LIST(5000),LNK(5000) COMMON/MAT/MA(1000),MX(256),MY(256),MZ(256) COMMON/MAIN/IW,IA,LSTAK,MS,LS,MC,NC,M0,M1,M2,NAMCH,IARG,JARG,NARG COMMON/TYPES/MNEG,MSYM,MADR IF(M.GE.MADR.OR.M.LE.MSYM+1) GOTO 1 IA=MADR-M IW=LNK(IA) RETURN 1 IA=0 RETURN END C SUBROUTINE OUT(N) C 13/5/77 IMPLICIT INTEGER*2 (I-N) COMMON/IO1/ICH(71),ISB(71),IOB(80) C++ ADDED COMMON BLOCK FOR I/O CHANNELS COMMON/IO3/MIP,MOP,NID,NOD COMMON/OUPT/NIB,NOF C++ psuedo output file COMMON/OBUF/IOUTBP,IOUTB(710),MAXOUT C C++ IF(NIB-71)2,1,1 1 NOF=NOF+1 C++ original C++ WRITE BINARY(5) ISB C++ C++ replace with pseudo file OUTB array C++ test for overflow IF(IOUTBP+NIB.LT.MAXOUT)GOTO 1001 WRITE(NOD,1000)IOUTBP, NIB, MAXOUT 1000 FORMAT(41HOUT SIZE OF OUTB BUFFER EXCEEDED, IOUTBP=,I6,5H NIB=, + I6,8H MAXOUT=,I6) STOP 1001 CONTINUE DO 100 I=1,NIB IOUTBP=IOUTBP+1 IOUTB(IOUTBP)=ISB(I) 100 CONTINUE NIB=0 2 NIB=NIB+1 ISB(NIB)=N RETURN END C SUBROUTINE FIND(N) C 19/11/76 IMPLICIT INTEGER*2 (I-N) COMMON LIST(5000),LNK(5000) COMMON/MAT/MA(1000),MX(256),MY(256),MZ(256) COMMON/MAIN/IW,IA,LSTAK,MS,LS,MC,NC,M0,M1,M2,NAMCH,IARG,JARG,NARG COMMON/IO1/ICH(71),ISB(71),IOB(72),ISP,IOP,NCL,NCW,KSHIFT(4) INTEGER*2 ALPHA I=NAMCH GOTO 2 C SEARCH NAME-CHAIN FOR MATCH 1 I=LIST(I) 2 IF(I.LE.0) GOTO 4 IA=LNK(I) IF(IA)1,1,20 20 DO 3 K=1,N IF(LIST(IA).NE.ICH(K)) GOTO 1 IA=LNK(IA) 3 CONTINUE IF(ALPHA(LIST(IA)).EQ.1) GOTO 1 RETURN C C NAME NOT FOUND: INSERT 4 I=LSTAK CALL STACK(NAMCH) NAMCH=LSTAK DO 5 K=1,N CALL STACK(ICH(K)) 5 CONTINUE CALL STACK(NAMCH) IA=LSTAK LNK(I)=LNK(IA) LNK(IA)=0 LSTAK=I RETURN END C SUBROUTINE PRIM C 10/5/77 IMPLICIT INTEGER*2 (I-N) COMMON LIST(5000),LNK(5000) COMMON/MAT/MA(1000),MX(256),MY(256),MZ(256) COMMON/MAIN/IW,IA,LSTAK,MS,LS,MC,NC,M0,M1,M2,NAMCH,IARG,JARG,NARG COMMON/TYPES/MNEG,MSYM,MADR COMMON/IO1/IOPS(35),NOS(187) COMMON/BUG/IBUG,ITEMS,NGRPS,LINES,IRHA,LINA,LADR DIMENSION KBUG(7) EQUIVALENCE (KBUG(1),IBUG) COMMON/SEP/LLS COMMON/PRI/IPRI(17) INTEGER*2 ALPHA,LL DATA IPRI/1,2,3,4,4,4,5,5,5,5,5,5,6,6,7,7,8/ 5 M=-IW-20 IF(M) 600,500,10 C 10 IF(M-12)11,11,350 11 CONTINUE IF(M2.EQ.LSTAK) GOTO 70 M2=LNK(M2) N=LIST(M2) CALL ADRES(N) IF(IA.EQ.0) +GOTO(215,220,222,230,238,240,254,255, 70, 10,280,300),M C GO AV @ CY FN FND RP : NEW OLD PRIM IF GOTO(210,221,225,234, 70,240, 70,250,260,270,270, 70),M C C GOTO MACRO 210 IF(IW)5,70,211 211 LS=IW GOTO 70 C CONDITIONAL GOTO 215 CONTINUE IF(N) 10,70,216 C GOTO N 216 LS=LNK(N) GOTO 10 C ADVANCE BUG N SYMBOLS 220 CONTINUE CALL ADVAN(IBUG,N,INT(0,2)) ITEMS=N GOTO 10 C 221 CONTINUE IF(IW)5,10,10 C C SET BUG ADDRESS 222 CONTINUE IF(N)228,223,223 223 IBUG=N GOTO 229 C C SET BUG TO START OF MACRO 225 CONTINUE IBUG=IA IF(IW.LE.0) IBUG=0 LINA=IBUG GOTO 229 C C SET BUG TO START OF ARGUMENT LIST 228 CONTINUE IF(MC.GT.0) IBUG=LNK(MC) 229 M=2 GOTO 10 C C LOAD N SYMBOLS 230 I=IBUG 232 LSTAK=M0 CALL ADVAN(I,N,INT(1,2)) ITEMS=N RETURN C C COPY MACRO 234 CONTINUE IF(IW)236,70,235 235 I=IA N=10000 GOTO 232 C C RETURN PRIMITIVE NO. 236 IW=-IW GOTO 80 C C FIND NTH GROUP 238 IF(M2.EQ.LSTAK) GOTO 239 M2=LNK(M2) GOTO 241 C C FIND NTH ITEM 239 IW=IBUG CALL ADVAN(IW,N,INT(0,2)) ITEMS=N GOTO 80 C C FIND GROUP 240 CONTINUE N=1 241 L=IBUG LINA=0 LINES=0 IF(N.LE.0.OR.L.LE.0) GOTO 248 ITEMS=-1 NGRPS=N C DO 246 N=1,NGRPS C 242 ITEMS=ITEMS+1 I=L L=LNK(I) K=LIST(L) IF(K.EQ.LIST(M2)) GOTO 243 IF(K.EQ.MSYM) GOTO 247 IF(K.NE.MSYM-1) GOTO 242 LINA=L LINES=LINES+1 GOTO 242 C 243 J=L M=M2 GOTO 245 C 244 J=LNK(J) M=LNK(M) IF(LIST(J).NE.LIST(M)) GOTO 242 245 IF(M.NE.LSTAK) GOTO 244 C 246 CONTINUE C C FOUND IW=I IRHA=J GOTO 80 C C NOT FOUND 247 NGRPS=N-1 IW=I GOTO 249 C 248 NGRPS=0 ITEMS=0 IW=0 C 249 IRHA=0 GOTO 80 C C REPLACE MACRO 250 CONTINUE J=LIST(IA) IF(J.LE.0) GOTO 70 CALL STACK(MSYM) IF(IW)252,262,251 C MACRO EXISTING 251 CALL STACK(LIST(J)) LIST(IA)=LSTAK GOTO 258 C PRIMITIVE EXISTING 252 LNK(IA)=LNK(M2) LNK(M2)=LNK(LSTAK) LNK(LSTAK)=J GOTO 70 C C REPLACE FROM IBUG TO N 254 IF(N.LE.0) GOTO 70 J=N GOTO 256 C C REPLACE N ITEMS 255 J=IBUG CALL ADVAN(J,N,INT(0,2)) C 256 IF(IBUG.LE.0) GOTO 70 IA=IBUG IRHA=LSTAK C C DO SUBSTITUTION 258 K=LNK(J) LNK(J)=LNK(LSTAK) LNK(LSTAK)=K K=LNK(IA) LNK(IA)=LNK(M2) LNK(M2)=K GOTO 70 C C STACK MACRO 260 CONTINUE J=LIST(IA) CALL STACK(MSYM) 262 CALL STACK(J) LIST(IA)=LSTAK LNK(IA)=LNK(M2) LNK(M2)=LNK(LSTAK) LNK(LSTAK)=IW GOTO 70 C C DELETE MACRO 270 CONTINUE I=IA J=LIST(I) IF(J.LE.0) GOTO 278 IF(IW) 272,276,274 272 IW=J 274 LIST(I)=LIST(J) LNK(I)=LNK(J) LNK(J)=LNK(LSTAK) LNK(LSTAK)=IW 276 M=11 GOTO 10 278 M=10 GOTO 10 C C DEFINE PRIMITIVE 280 CONTINUE IF(N.LE.0) GOTO 10 K=M1 LIST(K)=LIST(I) LIST(I)=K M1=LNK(K) LNK(K)=LNK(I) LNK(M0)=M1 LNK(I)=-N GOTO 10 C C CONDITIONAL OPERATION 300 CONTINUE IF(N.EQ.0) GOTO 70 CALL SETARG LS=LNK(M2) RETURN C C RETURN MISCELLANEOUS VALUES 350 IW=KBUG(M-12) GOTO 80 C C ENTER GRAPHICS 500 CALL SETARG LS=LNK(M2) IF(MS)530,524,526 524 CALL OUT(MSYM) 526 MS=-MS-1 530 RETURN C C EXPRESSION C 600 M2=M1 J=1 K=0 605 L=M2 M=0 610 I=0 615 IF(M2.EQ.LSTAK) GOTO 655 M1=M2 M2=LNK(M2) IW=LIST(M2) CALL ADRES(IW) IF(IA.EQ.0) GOTO 625 IF(IW) 640,605,620 C C VARIABLE 620 CONTINUE L=IW IF(LIST(L).EQ.MSYM) GOTO 605 MM=M-1 CALL ADVAN(L,MM,INT(0,2)) M=LIST(L) GOTO 610 C C CONSTANT 625 IF(IW)626,627,627 626 IF(I)627,630,627 627 M=IW GOTO 610 C NEGATIVE CONSTANT 630 LIST(M2)=-IW M2=M1 IW=-13 C C OPERATOR 640 I=1-IW IF(I.EQ.3) M=L IF(I-18)642,680,615 642 IF(IPRI(I).LE.IPRI(J)) GOTO 660 C STACK K=K+1 IOPS(K)=J NOS(K)=N 645 J=I N=M M=0 GOTO 615 C C SET LOGICAL 648 M=0 IF(LL.EQ.1) M=-1 C 650 IF(IPRI(I).EQ.IPRI(J)) GOTO 645 C UNSTACK J=IOPS(K) N=NOS(K) K=K-1 GOTO 642 C C END OF EXPRESSION 655 I=1 C C OPERATIONS 660 GOTO(661,70,661,663,664,665,666,667,668,669,670, + 671,672,673,674,675,676),J C LOAD RESULT AND EXIT 661 IF(M.LT.MADR) M=MSYM+1 IW=M IF(J.EQ.1) GOTO 80 C ASSIGN LIST(N)=M GOTO 650 C C LOGICALS 663 LL=0 IF(M.NE.0.OR.N.NE.0)LL=1 GOTO 648 664 LL=0 IF(M.NE.0.AND.N.NE.0)LL=1 GOTO 648 665 LL=0 IF(.NOT.M.NE.0)LL=1 GOTO 648 C C RELATIONS 666 LL=0 IF(N.LT.M)LL=1 GOTO 648 667 LL=0 IF(N.LE.M)LL=1 GOTO 648 668 LL=0 IF(N.EQ.M)LL=1 GOTO 648 669 LL=0 IF(N.NE.M)LL=1 GOTO 648 670 LL=0 IF(N.GE.M)LL=1 GOTO 648 671 LL=0 IF(N.GT.M)LL=1 GOTO 648 C C ARITHMETIC 672 M=N+M GOTO 650 673 M=N-M GOTO 650 674 M=N*M GOTO 650 675 M=N/M GOTO 650 676 M=N**M GOTO 650 C C ITEM TYPE 680 IF(IBUG.EQ.0) GOTO 685 I=LNK(IBUG) I=LIST(I) M=1 IF(ALPHA(I).EQ.1) M=2 IF(I.LT.MADR) M=3 IF(I.LE.MSYM+1) M=4 IF(I.NE.MSYM) GOTO 610 685 M=0 GOTO 610 C C END PRIMITIVE WITH NO RESULTS 70 CONTINUE LSTAK=M0 RETURN C C END PRIMITIVE, LOAD ONE RESULT 80 CONTINUE LSTAK=M0 CALL LOAD RETURN END C SUBROUTINE SETUP IMPLICIT INTEGER*2 (I-N) COMMON LIST(5000),LNK(5000) COMMON/MAT/MA(1000),MX(256),MY(256),MZ(256) COMMON/MAIN/IW,IA,LSTAK,MS,LS,MC,NC,M0,M1,M2,NAMCH,IARG,JARG,NARG COMMON/TYPES/MNEG,MSYM,MADR COMMON/IO2/JQ,LG,NQ,KSYM(17),KS,KBLANK C NLIST=5000 C SET UP LIST LINKS DO 5 I=1,NLIST 5 LNK(I)=I+1 C SET UP PRIM NAMCH=NLIST-4 LNK(NAMCH-1)=0 LIST(NAMCH)=0 LIST(NAMCH+1)=ISHFT(ICHAR('P'),8) + ICHAR('R') LIST(NAMCH+2)=ISHFT(ICHAR('I'),8) + ICHAR('M') LIST(NAMCH+3)=NLIST LNK(NAMCH+3)=-30 LIST(NLIST)=NAMCH LNK(NLIST)=0 RETURN END C SUBROUTINE SPOP(NP) C 13/5/77 IMPLICIT INTEGER*2 (I-N) COMMON LIST(5000),LNK(5000) COMMON/MAT/MA(1000),MX(256),MY(256),MZ(256) COMMON/MAIN/IW,IA,LSTAK,MS,LS,MC,NC,M0,M1,M2,NAMCH,IARG,JARG,NARG COMMON/TYPES/MNEG,MSYM,MADR COMMON/INPT/INB(148),LCONT COMMON/IO1/ICH(222) COMMON/IO3/MIP,MOP,NID,NOD COMMON/GIP/LGRIN M=NP N=0 LCANC=INT(0,2) C 1 IF(M2.EQ.LSTAK) GOTO(10,20,100,100,55,100,100,80,90,53),M M2=LNK(M2) N=LIST(M2) CALL ADRES(N) IF(IA.EQ.0) +GOTO( 10, 20, 5, 5, 55, 100, 70, 80, 90, 52 ),M C GRIN AIN PROT LOC DIR SPARE SS LEFT GRB ATR GOTO( 10, 20, 30, 40, 50, 100, 100, 80, 90, 50 ),M C CANCEL 5 LCANC=0 IF(N.EQ.0)LCANC=1 GOTO 1 C C ENTER GRAPHIC INPUT MODE 10 LGRIN=INT(1,2) GOTO 100 C EXIT GRAPHIC INPUT MODE 20 LGRIN=INT(0,2) GOTO 100 C C PROTECT MACRO 30 I=LIST(IA) IF(I.GT.0.AND.LCANC.EQ.0.OR.I.LT.0.AND.LCANC.EQ.1) LIST(IA)=-I GOTO 1 C C LOCALIZE MACRO 40 I=IA 42 L=LNK(I) I=LIST(I) IF(I.LT.0) I=-I IF(L.NE.0) GOTO 42 C L=LNK(I) IF(L.GT.0.AND.LCANC.EQ.0.OR.L.LT.0.AND.LCANC.EQ.1) LNK(I)=-L GOTO 1 C C FIND NAME ATTRIBUTES 50 I=0 J=LIST(IA) K=0 IF(J.GT.0) GOTO 502 J=-J K=1 502 IF(IW.EQ.0) GOTO 506 C 504 I=I+1 L=LNK(J) J=LIST(J) IF(J.LT.0) J=-J IF(L.NE.0) GOTO 504 C 506 IF(LNK(J).LT.0) K=-1 M=10 GOTO 1 C C PASS ATTRIBUTES 52 IW=0 IF(N.EQ.K) IW=-1 GOTO 200 C 53 IF(IW.LT.0) I=-I IW=I GOTO 200 C C LIST DIRECTORY 55 CONTINUE C++ added CALL PSTACK(INT(1,2),INT(500,2),INT(12,2),'STACK AT DIR') LSTAK=M0 J=NAMCH C 552 I=LNK(J) IF(I.GT.0) GOTO 554 I=-I IF(N)555,559,559 C 554 IF(N.LT.0) GOTO 559 C 555 I=LNK(I) L=LIST(I) IF(L.GE.-MADR) GOTO 555 C C++ IW is the address of the macro, converted to name by OUTPUT C++ IW=MADR-I IF(N)558,557,556 556 IF(L)558,559,559 557 IF(L)559,559,558 558 CONTINUE CALL LOAD 559 J=LIST(J) IF(J)300,300,552 C C PASS CONTROL ITEM 70 IF(N.LE.0) GOTO 100 IW=MNEG+N GOTO 200 C C REPORT STACK LEFT 80 M=M1 DO 82 IW=1,10000 IF(M)200,200,82 82 M=LNK(M) C C EXIT, PASS ONE RESULT 200 LSTAK=M0 CALL LOAD RETURN C C GARBAGE COLLECTION C PASS THROUGH DEFINITIONS,FLAGGING REFERENCES C 90 N=NAMCH 91 N=LNK(N) 92 I=N IF(I.LT.0) I=-I C 93 N=LIST(I) I=LNK(I) IF(I)95,96,94 94 IF(N.GT.0) GOTO 93 C CALL ADRES(N) IF(IA.GT.0.AND.IW.EQ.0) LNK(IA)=MNEG GOTO 93 C 95 IF(I.NE.MNEG) GOTO 92 96 IF(N.LT.0) N=-N N=LIST(N) IF(N.GT.0) GOTO 91 C C DO SAME FOR STACK I=1 98 IF(LSTAK-I)99,912,99 99 I=LNK(I) CALL ADRES(LIST(I)) IF(IA)98,98,910 C 910 IF(IW)98,911,98 911 LNK(IA)=MNEG GOTO 98 C C ELIMINATE REDUNDANT ENTRIES 912 M=0 N=NAMCH C 914 I=LNK(N) IF(I.LE.0) I=-I 915 I=LNK(I) IF(LIST(I).GE.-MADR) GOTO 915 C IF(LNK(I))916,917,916 916 IF(LNK(I).EQ.MNEG) LNK(I)=0 M=N GOTO 920 C 917 LNK(I)=LNK(LSTAK) LNK(LSTAK)=N IF(LNK(N).LT.0) LNK(N)=-LNK(N) IF(M)918,918,919 918 NAMCH=LIST(N) GOTO 920 C 919 LIST(M)=LIST(N) 920 N=LIST(N) IF(N)100,100,914 C C EXIT,NO RESULT 100 LSTAK=M0 300 RETURN END C SUBROUTINE PRIX(NP) C 24/11/76 IMPLICIT INTEGER*2 (I-N) COMMON LIST(5000),LNK(5000) COMMON/MAT/MA(1000),MX(256),MY(256),MZ(256) COMMON/MAIN/IW,IA,LSTAK,MS,LS,MC,NC,M0,M1,M2,NAMCH,IARG,JARG,NARG COMMON/TYPES/MNEG,MSYM,MADR COMMON/INPT/INB(148),LCONT COMMON/IO1/ICH(222) COMMON/IO3/MIP,MOP,NID,NOD INTEGER*2 ALPHA DIMENSION MD(2),ND(2) EQUIVALENCE (MD(1),MIP),(ND(1),NID) C IF(NP-10)5,1,1 1 LSTAK=M0 RETURN C 2 LSTAK=M0 CALL LOAD RETURN C C FILE HANDLING 5 CALL STACK(MSYM) M=M2 C 10 M=LNK(M) IF(M-LSTAK)25,1,25 25 N=LIST(M) L=M IF(ALPHA(N).EQ.1) GOTO 60 CALL ADRES(N) L=IA IF(L)90,90,40 C 40 N=LNK(L) L=LIST(L) IF(L.LT.0) L=-L IF(N)40,50,40 50 L=LNK(L) IF(L.LT.0) L=-L C 60 DO 70 I=1,70 N=LIST(L) IF(ALPHA(N).EQ.0) GOTO 80 ICH(I)=N 70 L=LNK(L) C 80 ICH(I)=0 N=I-1 C NAME GOTO(150,300,200,400,500,500,700,800),NP C C NUMBER 90 CONTINUE GOTO(100,100,10,400,510,510,1,1),NP C C CHANGE OR REVERT TO MAIN I/O 100 IF(N)120,130,110 110 MD(NP)=2+NP GOTO 130 120 MD(NP)=12-NP 130 ND(NP)=MD(NP) GOTO 1 C C CHANGE SOURCE FILE 150 CONTINUE C++ CALL CLOSE(1,I) 160 CONTINUE C++ CALL OPEN(1,ICH(1),3,I) NID=1 N=2 GOTO 240 C C CHANGE DESTINATION FILE 200 CONTINUE C++ CALL CLOSE(2,I) 220 CONTINUE C++ CALL APPEND(2,ICH(1),3,I) NOD=2 N=1 240 IF(I-1)250,1,250 C C IF FILE IN USE,CLOSE OTHER CHANNEL 250 IF(I-51)600,260,600 260 CONTINUE ND(N)=MD(N) GOTO(160,320,220),NP C C DELETE FILE AND REOPEN AS DESTINATION 300 CONTINUE 320 CONTINUE IF(I-51)220,340,220 340 N=1 GOTO 260 C C CONTINUE READING SOURCE FILE 400 NID=1 GOTO 1 C C RESUME OR SAVE 500 CONTINUE GOTO 520 510 CONTINUE 520 IF(I-1)600,530,600 530 IF(NP-6)550,560,550 C C RESUME 550 CONTINUE LSTAK=1 MS=0 MC=MS NC=MC NARG=NC LS=-1 INB(1)=MSYM RETURN C C SAVE 560 CONTINUE GOTO 1 C C FILE ERROR CONDITION 600 WRITE(2,610) I,ICH(1) 610 FORMAT(6HERROR ,1X,2I6) NID=MIP GOTO 1 C C CONVERT ALPHA STRING TO MACRO ADDRESS 700 CALL FIND(N) IW=MADR-IA GOTO 2 C C CONVERT MACRO ADDRESS TO ALPHA STRING 800 LSTAK=M0 DO 850 I=1,N IW=ICH(I) 850 CALL LOAD RETURN C END C SUBROUTINE INPUT C 13/10/76 IMPLICIT INTEGER*2 (I-N) COMMON/MAIN/IW,IA,LSTAK,MS,LS,MC,NC,M0,M1,M2,NAMCH,IARG,JARG,NARG COMMON/IO1/ICH(71),ISB(71),IOB(72),INP,IOP,NCL,NCW,KSHIFT(4) COMMON/IO3/MIP,MOP,NID,NOD COMMON/GIP/LGRIN INTEGER*2 LGRIN C INP=1 IF(NID.NE.MIP) GOTO 20 IF(LGRIN.EQ.1) GOTO 50 C C ALPHA INPUT 20 READ(5,30,END=40) ISB 30 FORMAT(71A1) C MOVE CHARACTERS TO TOP BYTE POSITION DO 2000 I=1,71 ISB(I)=ISHFT(ISB(I),8) + ICHAR(' ') 2000 CONTINUE C WRITE(7,3407)(ISHFT(ISB(I),-8),I=1,71) 3407 FORMAT(4H

,71A1,5H

) C LS=-INP CALL ALFIN(INT(0,2)) GOTO 99 C C RETURN TO CONSOLE 40 CONTINUE WRITE(2,600) 600 FORMAT(4hSTOP) C COMPLETE GRAPHICAL OUTPUT 800 FORMAT(6H) WRITE(7,700) 700 FORMAT(14H) WRITE(8,800) WRITE(10,800) WRITE(10,700) STOP C C GRAPHIC INPUT 50 CONTINUE C 99 RETURN END C SUBROUTINE ALFIN(NOBRAC) C 13/10/76 IMPLICIT INTEGER*2 (I-N) COMMON LIST(5000),LNK(5000) COMMON/MAT/MA(1000),MX(256),MY(256),MZ(256) COMMON/MAIN/II,IA,LSTAK,MS,LS,MC,NC,M0,M1,M2,NAMCH,IARG,JARG,NARG COMMON/TYPES/MNEG,MSYM,MADR COMMON/INPT/INB(148),LCONT COMMON/IO1/ICH(71),IB(71),IOB(72),INP,IOP,NCL,NCW,KSHIFT(2) + ,KPITCH,KBIT COMMON/IO2/JQ,LQ,NQ,KL,KG,KO,KR,KH,KU,KT,KX,KC,KB,KE,KQ,KM, + K0,K9,KA,KZ,KS,KBLANK DIMENSION KSYM(13) EQUIVALENCE (KSYM(1),KL) COMMON/IO3/MIP,MOP,NID,NOD NCL=71 DO 7 N=1,71 IF(IB(N).NE.KS) GOTO 8 7 CONTINUE GOTO 70 C 8 IF(NOBRAC.EQ.1) GOTO 11 IF(IB(N).EQ.KR) GOTO 9 IF(IB(N).EQ.KE) GOTO 14 INB(INP)=MNEG+3 INP=INP+1 LCONT=LCONT+1 GOTO 11 C 14 IB(N)=KG GOTO 11 C 9 N=N+1 C 11 DO 50 INP=INP,145 3 IF(N.GT.NCL) GOTO 60 K=IB(N) IF(K.NE.KS.OR.JQ.EQ.1) GOTO 4 13 N=N+1 GOTO 3 C 4 IW=0 IF(JQ.EQ.1) GOTO 32 K=IB(N) IF(K.GE.KA.AND.K.LE.KZ) GOTO 10 IF(K.GE.K0.AND.K.LE.K9) GOTO 20 C LOOK FOR SPECIAL SYMBOLS DO 5 I=1,13 IF(K.EQ.KSYM(I)) GOTO 40 5 CONTINUE C MUST BE A NON-SPECIAL SYMBOL N=N+1 6 ICH(1)=(K-KBLANK)/KSHIFT(1)+KBIT I=1 GOTO 18 C C MACRO NAME 10 CONTINUE I=1 12 ICH(I)=KBIT DO 16 IW=1,NCW IF(K.LT.K0.OR.K.GT.K9.AND.K.LT.KA.OR.K.GT.KZ) GOTO 18 ICH(I)=ICH(I)+(K-KBLANK)/KSHIFT(IW) N=N+1 IF(N.GT.NCL) GOTO 18 16 K=IB(N) I=I+1 GOTO 12 18 IF(ICH(I).EQ.KBIT) I=I-1 CALL FIND(I) IW=MADR-IA GOTO 50 C C NUMERIC LITERAL 20 I=1 22 DO 25 N=N,NCL K=IB(N) IF(K.LT.K0.OR.K.GT.K9) GOTO 26 25 IW=IW*10+(K-K0)/KSHIFT(NCW) N=NCL+1 26 IF(IW+MADR)28,27,27 27 IW=-MADR-1 28 IW=IW*I GOTO 50 C C ALPHA STRING 30 JQ=INT(1,2) 32 IW=KBIT DO 34 K=1,NCW IF(N.GT.NCL) GOTO 50 IF(IB(N).EQ.KQ) GOTO 36 IW=IW+(IB(N)-KBLANK)/KSHIFT(K) 34 N=N+1 GOTO 50 36 CONTINUE IF(K.GT.1) GOTO 50 JQ=INT(0,2) GOTO 13 C C SPECIAL SYMBOL 40 N=N+1 GOTO(41,48,41,48,49,49,60,49,42,43,46,30,45),I C < > ( ) # ^ ; ! , [ ] " - C < OR ( 41 LCONT=LCONT+1 GOTO 49 C , 42 I=4 LCONT=LCONT-1 GOTO 44 C [ 43 I=1 LCONT=LCONT+1 44 N=N-1 IB(N)=KO GOTO 49 C - 45 IF(IB(N).LT.K0.OR.IB(N).GT.K9) GOTO 6 I=-1 GOTO 22 C ] 46 I=4 N=N-1 IB(N)=KG C > OR ) 48 LCONT=LCONT-1 C 49 IW=MNEG+I C 50 INB(INP)=IW WRITE(2,55) 55 FORMAT(22H INPUT BUFFER OVERFLOW) STOP C 60 IF(NOBRAC.EQ.1) GOTO 70 LCONT=LCONT-1 INB(INP)=MNEG+4 IF(INB(INP-1).EQ.MNEG+3) INP=INP-2 INP=INP+1 C 70 INB(INP)=MSYM-1 INB(INP+1)=MSYM INP=INP+2 RETURN C END C SUBROUTINE READIN C 13/10/76 IMPLICIT INTEGER*2 (I-N) COMMON LIST(5000),LNK(5000) COMMON/MAT/MA(1000),MX(256),MY(256),MZ(256) COMMON/MAIN/IW,IA,LSTAK,MS,LS,MC,NC,M0,M1,M2,NAMCH,IARG,JARG,NARG COMMON/IO1/ICH(71),ISB(71),IOB(72),INP,IOP,NCL,NCW,KSHIFT(4) COMMON/IO3/MIP,MOP,NID,NOD COMMON/INPT/INB(148),LCONT COMMON/BUG/IBUG,ITEMS,NGRPS,LINES,IRHA,LINA,LADR COMMON/PRIND/IPRMPT,INDENT INTEGER*2 ALPHA C LINES=0 IMES=INP JMES=IMES-1 C C SET UP MESSAGE/PROMPT 10 IF(M2.EQ.LSTAK) GOTO 30 M2=LNK(M2) N=LIST(M2) IF(ALPHA(N).EQ.0) GOTO 20 JMES=JMES+1 INB(JMES)=N GOTO 10 C C IMPLICIT BRACKETS OPTION? 20 IF(N.GE.0) GOTO 31 C IMPLICIT BRACKETS N=-N NOBRAC=INT(0,2) GOTO 40 C C NO IMPLICIT BRACKETS 30 N=0 31 NOBRAC=INT(1,2) C 40 LSTAK=M0 INP0=JMES+1 C C OUTPUT MESSAGE/PROMPT 50 CONTINUE IF(IMES.LE.JMES) GOTO 52 GOTO 55 52 CONTINUE 55 CONTINUE IF(LCONT.LE.0.OR.NOBRAC.EQ.1) GOTO 70 C C INDENTING DO 60 I=1,LCONT C BINARY OUTPUT DELETED 60 CONTINUE C C READ A LINE 70 CONTINUE READ(5,77,END=90) ISB 77 FORMAT(71A1) C WRITE(2,77)(ISB(I),I=1,71) C MOVE CHARACTER TO TOP BYTE POSITION DO 2000 I=1,71 ISB(I)=ISHFT(ISB(I),8) + ICHAR(' ') 2000 CONTINUE C WRITE(2,3107)(ISHFT(ISB(I),-8),I=1,71) C C COMPILE INP=INP0 CALL ALFIN(NOBRAC) INP=INP-2 IF(N.LT.2) INP=INP-1 C C COPY TO STACK DO 80 I=INP0,INP IW=INB(I) 80 CALL LOAD C C SINGLE OR MULTIPLE LINES? LINES=LINES+1 IF(N-1) 99,99,50 C C EXIT 90 NID=MIP 99 INP=IMES RETURN END C SUBROUTINE OUTPUT C 13/5/77 IMPLICIT INTEGER*2 (I-N) COMMON/TYPES/MNEG,MSYM,MADR COMMON/IO1/ICH(71),ISB(71),IOB(72),ISP,IOP,NCL,NCW,KSHIFT(4) COMMON/IO2/JQ,LQ,NQ,KSYM(18),KBLANK COMMON/IO3/MIP,MOP,NID,NOD COMMON/OUPT/NIB,NOF COMMON/INDOUT/IND,SPACE,LNO,ITEM1 C++ psuedo output file COMMON/OBUF/IOUTBP,IOUTB(710),MAXOUT INTEGER*2 SPACE C NGO=0 IND=1 SPACE=INT(0,2) ITEM1=0 IF(NQ.GT.0)ITEM1=1 IOP=1 C IF(NQ)9,13,8 8 LNO=NQ IOP=2 IOB(2)=KSYM(4) GOTO 11 9 LNO=-NQ 11 IF(LNO.GT.999) GOTO 13 NCL=66 GOTO 14 13 NCL=71 C 14 IF(NOF)6,6,1 1 IF(NIB)3,3,2 2 CONTINUE C++ C++ write to pseudo file C++ replace with pseudo file OUTB array IF(IOUTBP+NIB.LT.MAXOUT)GOTO 1005 WRITE(NOD,1000)IOUTBP, NIB, MAXOUT 1000 FORMAT(41HOUT SIZE OF OUTB BUFFER EXCEEDED, IOUTBP=,I6,5H NIB=, + I6,8H MAXOUT=,I6) STOP 1005 CONTINUE DO 100 I=1,NIB IOUTBP=IOUTBP+1 IOUTB(IOUTBP)=ISB(I) 100 CONTINUE C++ original C++ 2 WRITE BINARY(5)(ISB(I),I=1,NIB) C++ 3 CALL CLOSE(5) 3 CONTINUE C++ CALL OPEN(5,"OBUF",1,I) M=71 C++ original C++ 4 READ BINARY(5,END=5) ISB C++ NEW: IOUTIP initialised so first iteration through loop from label 4 to C++ IF statement after label 70 will start at 1 and subsequently at C++ 72, ... IOUTIP=0 4 CONTINUE DO 120 I=1,M IOUTIP=IOUTIP+1 ISB(I)=IOUTB(IOUTIP) 120 CONTINUE C++ original C++ READ BINARY(5,END=5) ISB IF(NOF)5,5,7 C++ 5 CALL CLOSE(5) C++ CALL OPEN(5,"OBUF",3,I) 5 CONTINUE C++ initialise IOUTBP IOUTBP=1 6 M=NIB 7 I=1 IF(NGO)10,10,20 C C GRAM TEXT 10 IF(ISB(1).EQ.MSYM) GOTO 15 12 CONTINUE CALL AOUT(I,M) IF(I)70,70,15 C C ENTER GRAPHICS 15 NGO=1 CALL BUFOUT LINE=0 C C TEKTRONIX 20 DO 60 II=I,M N=ISB(II) IF(N.LE.MADR.OR.N.GE.-MADR) GOTO 50 GOTO(25,30),NGO C C X-COORDINATE 25 IX=N NGO=2 GOTO 60 C C Y-COORDINATE & PLOT 30 CALL VECTO(IX,N,LINE) NGO=1 LINE=1 GOTO 60 C C EXIT GRAPHICS 40 CALL VECTO(INT(0,2),INT(0,2),INT(-1,2)) NGO=0 SPACE=INT(0,2) I=I+1 GOTO 12 C C NAME OR SPECIAL SYMBOL 50 IF(N.EQ.MSYM-1) GOTO 40 C LINE BREAK NGO=1 LINE=0 C 60 CONTINUE C 70 NOF=NOF-1 IF(NOF)90,4,4 90 NIB=0 NOF=0 CALL BUFOUT RETURN END C SUBROUTINE AOUT(JP,MP) C 19/11/76 IMPLICIT INTEGER*2 (I-N) COMMON LIST(5000),LNK(5000) COMMON/MAT/MA(1000),MX(256),MY(256),MZ(256) COMMON/TYPES/MNEG,MSYM,MADR COMMON/IO1/ICH(71),ISB(71),IOB(72),ISP,IOP,NCL,NCW,KSHIFT(4) COMMON/IO2/JQ,LQ,NQ,KL,KG,KO,KR,KH,KU,KT,KX,KC,KB,KE,KQ,KM, + K0,K9,KA,KZ,KS,KBLANK DIMENSION KSYM(13) EQUIVALENCE (KSYM(1),KL) COMMON/INDOUT/IND,SPACE,LNO,ITEM1 INTEGER*2 ALPHA,ALFOUT,SPACE C DO 200 IP=JP,MP M=ISB(IP) IF(ALPHA(M).EQ.1) GOTO 30 IF(LQ.EQ.0) GOTO 5 C LQ=INT(0,2) CALL OUTCH(KQ) C 5 IF(M.LE.MSYM+1) GOTO 40 IF(SPACE.EQ.1) CALL OUTCH(KS) IF(M.LT.MADR) GOTO 20 C C NUMERIC LITERAL N=M IF(N.LT.0) N=-N DO 10 I=1,20 J=N/10 ICH(I)=(N-J*10)*KSHIFT(2)+K0 IF(J.LE.0) GOTO 11 10 N=J 11 IF(M.GE.0) GOTO 12 I=I+1 ICH(I)=KM 12 IF(IOP+I.GT.NCL) CALL BUFOUT L=IOP+1 N=IOP+I DO 13 J=L,N IOB(J)=ICH(I) 13 I=I-1 IOP=N GOTO 24 C C MACRO NAME 20 N=MADR-M 21 L=LNK(N) N=LIST(N) IF(N.LT.0) N=-N IF(L.NE.0) GOTO 21 22 I=IOP L=LNK(N) IF(L.LT.0) L=-L 23 J=LIST(L) IF(ALFOUT(J).EQ.1) GOTO 26 IOP=I CALL BUFOUT GOTO 22 26 L=LNK(L) IF(ALPHA(LIST(L)).EQ.1) GOTO 23 I=IOB(I+1) IF(I.LT.KA.OR.I.GT.KZ) GOTO 27 C 24 SPACE=INT(1,2) GOTO 180 C 27 IF(SPACE.EQ.0) GOTO 180 IOP=IOP-1 IOB(IOP)=IOB(IOP+1) GOTO 150 C C ALPHA STRING 30 CONTINUE J=M 32 IF(LQ.EQ.1.OR.NQ.LT.0) GOTO 33 CALL OUTCH(KQ) LQ=INT(1,2) 33 IF(ALFOUT(J).EQ.1) GOTO 150 CALL BUFOUT GOTO 32 C C SPECIAL SYMBOL 40 N=M-MNEG IF(NQ.EQ.0.AND.N.NE.7) GOTO 100 I=IOB(IOP) GOTO(44,50,45,55,100,60,300,100),N C < > ( ) # NL GR ! C< 44 IND=IND+2 GOTO 100 C( 45 IND=IND+2 IF(I.EQ.KL) GOTO 48 IF(I.NE.KR) GOTO 100 IF(ITEM1.EQ.1) GOTO 47 IOB(IOP)=KC GOTO 150 C 47 IOP=IOP-1 GOTO 180 C 48 IOB(IOP)=KB GOTO 150 C> 50 IF(I.EQ.KR) GOTO 57 C) 55 CALL OUTCH(KSYM(N)) GOTO 58 C 57 IOB(IOP)=KE 58 IND=IND-2 GOTO 150 C C NEWLINE 60 CALL BUFOUT LNO=LNO+1 ITEM1=0 IF(NQ.GT.0)ITEM1=1 GOTO 200 C 100 CALL OUTCH(KSYM(N)) 150 SPACE=INT(0,2) 180 ITEM1=INT(0,2) 200 CONTINUE IP=0 C 300 JP=IP RETURN END C INTEGER*2 FUNCTION ALFOUT(J) C 25/8/76 IMPLICIT INTEGER*2 (I-N) COMMON/IO1/ICHISB(142),IOB(72),ISP,IOP,NCL,NCW,KSHIFT(2) + ,KPITCH,KBIT COMMON/IO2/KSYM(21),KBLANK C 1 IF(IOP+1-NCL) 2,4,4 2 IOP=IOP+1 K=MOD(J,KSHIFT(NCW)) IOB(IOP)=J-K+KBLANK J=K*KPITCH IF(J) 1,3,1 3 ALFOUT=INT(1,2) RETURN 4 ALFOUT=INT(0,2) RETURN END C SUBROUTINE OUTCH(K) C 25/8/76 IMPLICIT INTEGER*2 (I-N) COMMON/IO1/ICH(71),ISB(71),IOB(72),ISP,IOP,NCL,NCW,KSHIFT(4) IF(IOP.GE.NCL) CALL BUFOUT IOP=IOP+1 IOB(IOP)=K RETURN END C SUBROUTINE BUFOUT C 25/8/76 IMPLICIT INTEGER*2 (I-N) COMMON/IO1/ICHISB(142),IOB(72),ISP,IOP,NCL,NCW,KSHIFT(4) COMMON/IO2/JQ,LQ,NQ,KL,KG,KO,KR,KH,KU,KT,KX,KC,KB,KE,KQ,KM, + K0,K9,KA,KZ,KS,KBLANK COMMON/IO3/MIP,MOP,NID,NOD COMMON/INDOUT/IND,SPACE,LNO,ITEM1 INTEGER*2 SPACE SPACE=INT(0,2) C IF(IOP.EQ.1) GOTO 20 IF(LQ) 3,4,3 3 IOP=IOP+1 IOB(IOP)=KQ LQ=0 C 4 IF(NQ)11,12,7 C 7 CONTINUE IF(IOB(IOP).EQ.KR) GOTO 10 IF(IOB(IOP).EQ.KL) GOTO 8 IOP=IOP+1 IOB(IOP)=KO GOTO 11 C 8 IOB(IOP)=KB GOTO 11 C 10 IOB(IOP)=KS IOP=IOP-1 C 11 IF(LNO.LT.1000) GOTO 13 C 12 WRITE(NOD,1) (ISHFT(IOB(I),-8),I=2,IOP) 1 FORMAT(1X,72A1) GOTO 14 C 13 WRITE(NOD,2) LNO,(ISHFT(IOB(I),-8),I=2,IOP) 2 FORMAT(1X,I3,2X,67A1) C 14 IND=1 C++ C++ added IOP=1 as found in 1906A version; resets buffer pointer C++ IOP=1 IF(NQ)20,20,15 C C INDENT NEXT LINE 15 IF(IND.LT.1) IND=1 DO 16 IOP=1,IND 16 IOB(IOP)=KS IOP=IND+1 IOB(IOP)=KR C 20 CONTINUE RETURN END C SUBROUTINE TOTREE(M) C 20/5/77 IMPLICIT INTEGER*2 (I-N) COMMON LIST(5000),LNK(5000) COMMON/MAT/MA(1000),MX(256),MY(256),MZ(256) COMMON/MAIN/IW,IA,LSTAK,MS,LS,MM,NC,M0,M1,M2,NAMCH,IARG,JARG,NARG COMMON/GRAF/RS(240),FRACT,IT,MTREE,LINC,NCC,MAT,MTYPE,KDUM(30) DIMENSION MB(999),MC(998) EQUIVALENCE (MA(2),MB(1)),(MA(3),MC(1)) DIMENSION II(8),SMAT(12),OS(231) EQUIVALENCE (II(1),I1),(RS(1),SMAT(1)),(RS(10),OS(1)) DIMENSION NFN(20) EQUIVALENCE (KDUM(1),IRP),(KDUM(2),MRS),(KDUM(3),I1), + (KDUM(4),I2),(KDUM(5),I3),(KDUM(6),I4), +(KDUM(7),I5),(KDUM(8),I6),(KDUM(9),I7), +(KDUM(10),I8),(NFN(1),KDUM(11)) C IF(M.GE.17) GOTO 200 N=NFN(M) IF(IT+N.GT.MTREE) GOTO 910 C IF(M2.EQ.LSTAK) GOTO 2 C PASS ARGUMENTS DO 1 NARGS=1,8 M2=LNK(M2) II(NARGS)=LIST(M2) IF(M2.EQ.LSTAK) GOTO 3 1 CONTINUE NARGS=8 GOTO 3 C 2 NARGS=0 3 LSTAK=M0 GOTO(10,20,30,40,50,50,50,50,50,100,110,110,180,190),M C C RESET TREE 10 MAT=0 IRP=12 FRACT=0. IT=1 GOTO 999 C C DOWN 20 MA(IT)=2 MB(IT)=LINC LINC=IT MC(IT)=NCC NCC=0 MTYPE=0 GOTO 900 C C UP 30 MA(IT)=3 MB(IT)=MAT MC(IT)=MTYPE I=LINC IF(I.LE.0) GOTO 35 LINC=MB(I) MB(I)=NCC NCC=NCC+MC(I) MC(I)=IT+3 35 MTYPE=0 FRACT=0. GOTO 900 C C FIG 40 CALL ADRES(I1) IF(IA.EQ.0.OR.IW.LE.0) GOTO 999 NCC=NCC+LIST(IW) IF(NARGS.GT.3) NARGS=3 MA(IT)=NARGS+3 MB(IT)=IW IF(NARGS-2)900,43,42 42 MC(IT+1)=I3 43 MC(IT)=I2 N=NARGS+1 GOTO 900 C C MATRIX FUNCTIONS 50 IF(NARGS.EQ.0) GOTO 999 IF(MTYPE.NE.0) GOTO 53 C MAT=IRP IRP=IRP+12 IF(MAT.GT.MRS-12) GOTO 920 DO 52 I=1,12 52 RS(MAT+I)=SMAT(I) C 53 M=M-4 GOTO(54,54,70,80,90),M C 54 IF(NARGS.GT.3) GOTO 55 FRACT=0. GOTO 56 55 NARGS=NARGS/2 56 IF(M.GT.1) GOTO 60 C C MOVE DO 58 I=1,NARGS J=MAT+I L=I+NARGS 58 OS(J)=OS(J)+FLOAT(II(I))+FLOAT(II(L)-II(I))*FRACT GOTO 68 C C SCALE 60 DO 66 I=1,NARGS N=I+NARGS S=(FLOAT(II(I))+FLOAT(II(N)-II(I))*FRACT)/100. JJ=MAT+I N=JJ+9 DO 66 J=JJ,N,3 66 RS(J)=RS(J)*S C 68 IF(NARGS.EQ.3) M=4 69 IF(M.GT.MTYPE) MTYPE=M GOTO 999 C C ROTATE ABOUT Z-AXIS 70 CONTINUE J=1 71 L=MAT+1 C 72 IF(NARGS.EQ.1) GOTO 73 S=(FLOAT(I1)+FLOAT(I2-I1)*FRACT)*.017456 GOTO 74 C 73 S=FLOAT(I1)*.017456 74 C=COS(S) S=SIN(S) N=L+9 C DO 77 I=L,N,3 JJ=I+J X=RS(I) Y=RS(JJ) RS(I)=C*X-S*Y 77 RS(JJ)=S*X+C*Y GOTO 69 C C ROTATE ABOUT X-AXIS 80 L=MAT+2 J=1 GOTO 72 C C ROTATE ABOUT Y-AXIS 90 M=4 J=2 GOTO 71 C C UNITY 100 FRACT=1.0 GOTO 999 C C LINEAR FRACTION 110 CONTINUE FRACT=FLOAT(I3-I1)/FLOAT(I2-I1) IF(M.EQ.11) GOTO 999 C C HARMONIC FRACTION FRACT=(1.-COS(3.14159*FRACT))/2. GOTO 999 C C C GENERATE ARC 180 X=FLOAT(I2-I4) Y=FLOAT(I3-I5) A=ATANN(Y,X) IF((I3-I5).NE.0) X=Y/SIN(A) IF(X.LT.0) X=-X C N=I1 IF(N)187,999,188 187 N=-N 188 DA=6.28318/FLOAT(I1) IF(NARGS-5)999,185,181 C 181 B=ATANN(FLOAT(I7-I5),FLOAT(I6-I4))-A IF(I1)183,182,182 182 IF(B.LT.0.) B=B+6.28318 GOTO 184 183 IF(B.GT.0.) B=B-6.28318 C 184 N=INT(B/DA+0.999) IF(N.EQ.0) N=1 DA=B/FLOAT(N) C 185 IW=N*2 CALL LOAD C DO 186 I=1,N B=A+DA*FLOAT(I) IW=I4+INT(X*COS(B)) CALL LOAD IW=I5+INT(X*SIN(B)) 186 CALL LOAD GOTO 999 C C LOAD TREE 190 J=IT-1 IF(J.LE.0) GOTO 999 DO 195 I=1,J IW=MA(I) 195 CALL LOAD GOTO 999 C C GENERAL FUNCTION 200 M=M-10 N=NFN(M) IF(IT+N.GT.MTREE) GOTO 910 MA(IT)=M J=1 IF(M.LT.10) GOTO 205 C J=3 MB(IT)=MAT MC(IT)=MTYPE MTYPE=0 C 205 IF(N.LE.J) GOTO 900 J=IT+J K=IT+N-1 C PASS ARGUMENTS DO 220 I=J,K IF(M2.EQ.LSTAK) GOTO 210 M2=LNK(M2) MA(I)=LIST(M2) GOTO 220 210 MA(I)=0 220 CONTINUE C C WAY OUT 900 IT=IT+N 999 CONTINUE RETURN C C ERROR CONDITIONS 910 WRITE(2,915) 915 FORMAT(14H TREE OVERFLOW) GOTO 999 920 WRITE(2,925) 925 FORMAT(22H MATRIX STORE OVERFLOW) GOTO 999 END C REAL FUNCTION ATANN(Y,X) C 20/9/76 IMPLICIT INTEGER*2 (I-N) IF(ABS(X).LT.0.0001) GOTO 1 ATANN=ATAN2(Y,X) GOTO 2 1 A=1.57079 IF(Y.LT.0.) A=-A ATANN=A 2 RETURN END C SUBROUTINE EXTREE C 20/5/77 IMPLICIT INTEGER*2 (I-N) COMMON LIST(5000),LNK(5000) COMMON/MAT/MA(1000),MX(256),MY(256),MZ(256) COMMON/MAIN/IW,IA,LSTAK,MS,LS,MM,NC,M0,M1,M2,NAMCH,IARG,JARG,NARG COMMON/TYPES/MNEG,MSYM,MADR COMMON/GRAF/RS(240),FRACT,IT,MTREE,LINC,NCC,MAT,MTYPE,KDUM(30) DIMENSION MB(999),MC(998) EQUIVALENCE (MA(2),MB(1)),(MA(3),MC(1)) COMMON/TREEC/XX,YX,ZX,XY,YY,ZY,XZ,YZ,ZZ,XO,YO,ZO, + PERSP,MWS,NWS,MSTOR,LTREE COMMON/FIGS/IFIG(20),ICOL(20),FADE(20),LEV(20), + IOUT(50),NFIG,NOUT,MFIG,MOUT,IEXTR DIMENSION NTS(10),NFS(10) DIMENSION NFN(20) EQUIVALENCE (KDUM(1),IRP),(KDUM(2),MRS),(KDUM(3),I1), + (KDUM(4),I2), (KDUM(5),I3), (KDUM(6),I4), + (KDUM(7),I5), (KDUM(8),I6), (KDUM(9),I7), + (KDUM(10),I8),(NFN(1),KDUM(11)) C IF(LINC)16,2,16 C 2 MTS=10 IEXTR=LIST(LSTAK) LSTAK=M0 MA(IT)=1 MTYPE=-1 CALL MATRIX LTREE=1 C 1 IT=LTREE LFIG=1 NFIG=0 NOUT=0 MWS=1 NWS=0 LTREE=0 ITS=0 GOTO 8 C 5 IT=IT+NFN(IFN) C 8 CONTINUE IFN=MA(IT) GOTO(10,20,30,40,50,60,70,70,70,100),IFN C C TOP OF TREE 10 IF(NWS)15,15,11 11 CONTINUE CALL MATRIX CALL GROUT IF(LTREE)15,15,1 15 CONTINUE 16 RETURN C C DOWN 20 CONTINUE IF(LTREE)25,21,26 21 IF(MB(IT)+NWS-MSTOR)22,22,24 C 22 IF(ITS.GE.MTS) GOTO 25 ITS=ITS+1 NTS(ITS)=MWS MWS=NWS+1 NFS(ITS)=LFIG LFIG=NFIG+1 GOTO 5 C 24 IF(MB(IT).GT.MSTOR) GOTO 22 25 LTREE=IT 26 IT=MC(IT) GOTO 8 C C UP 30 CALL MATMAT IF(MTYPE.GT.0.AND.LTREE.EQ.0) LTREE=-1 IF(ITS.EQ.0) GOTO 5 N=NTS(ITS) LFIG=NFS(ITS) ITS=ITS-1 IF(N.EQ.MWS) GOTO 5 CALL MATRIX MWS=N GOTO 5 C COPY FIGURE TO WORKSPACE 40 NCOL=0 NLEV=0 GOTO 66 C C FIGURE + COLOUR 50 NLEV=0 GOTO 61 C C FIGURE + COLOUR + LEVEL 60 NLEV=MC(IT+1) 61 NCOL=MC(IT) C 66 IF(LTREE)991,401,5 401 M=MB(IT) L=LIST(M) IF(L)41,5,42 41 N=-L GOTO 43 42 N=L 43 I=NWS+1 N=NWS+N IF(N.GT.MSTOR.OR.NFIG.GE.MFIG.OR.NOUT.GE.MOUT) GOTO 949 431 M=LNK(M) C INF=0 IST=I IF(IST.GT.N) GOTO 46 DO 45 I=IST,N INF=INF+1 IF(INF.LT.400)GOTO 44 WRITE(2,999) 999 FORMAT(13HINFINITE LOOP) STOP 44 M=LNK(M) J=LIST(M) IF(J.LE.MADR) GOTO 47 MX(I)=J M=LNK(M) MY(I)=LIST(M) J=0 IF(L)441,441,451 441 M=LNK(M) J=LIST(M) 451 MZ(I)=J GOTO 45 C C END OF OUTLINE 47 IF(J.NE.MSYM) GOTO 48 N=I-1 GOTO 46 C 48 NOUT=NOUT+1 IOUT(NOUT)=I-1 IF(NOUT.LT.MOUT) GOTO 44 C 45 CONTINUE C 46 NOUT=NOUT+1 IOUT(NOUT)=N NFIG=NFIG+1 IFIG(NFIG)=NOUT NWS=N ICOL(NFIG)=NCOL FADE(NFIG)=1.0 LEV(NFIG)=NLEV GOTO 5 C ABANDON 949 IF(NWS.GT.0) GOTO 991 N=MSTOR GOTO 431 991 LTREE=IT GOTO 5 C COLOUR,LEVEL,ETC. 70 IF(NFIG.LT.LFIG) GOTO 5 N=MB(IT) IF(IFN-8)75,80,90 C C COLOUR 75 DO 77 I=LFIG,NFIG 77 ICOL(I)=N GOTO 5 C C FADE 80 I=MC(IT) IF(I.EQ.0) I=100 F=FLOAT(N)/FLOAT(I) DO 88 I=LFIG,NFIG 88 FADE(I)=FADE(I)*F GOTO 5 C C LEVEL 90 DO 99 I=LFIG,NFIG 99 LEV(I)=LEV(I)+N GOTO 5 C C PERSPECTIVE PROJECTION 100 IF(NWS.LT.MWS) GOTO 5 CALL MATMAT CALL MATRIX PERSP=MC(IT+1)/3200000. C DO 105 I=MWS,NWS Z=MZ(I)*PERSP+1.0 MX(I)=MX(I)/Z MY(I)=MY(I)/Z MZ(I)=0 105 CONTINUE GOTO 5 C END C SUBROUTINE MATMAT C 20/5/77 IMPLICIT INTEGER*2 (I-N) COMMON LIST(5000),LNK(5000) COMMON/MAT/MA(1000),MX(256),MY(256),MZ(256) DIMENSION MB(999),MC(998) EQUIVALENCE (MA(2),MB(1)),(MA(3),MC(1)) COMMON/GRAF/RS(240),FRACT,IT,MTREE,LINC,NCC,MAT,MTYPE,KDUM(30) COMMON/TREEC/XX,YX,ZX,XY,YY,ZY,XZ,YZ,ZZ,XO,YO,ZO, + PERSP,MWS,NWS,MSTOR,LTREE DIMENSION XXS(240),XYS(237),XZS(234),XOS(231), + YXS(239),YYS(236),YZS(233),YOS(230), + ZXS(238),ZYS(235),ZZS(232),ZOS(229), + XM(12),YM(11),ZM(10) EQUIVALENCE (RS(12), + XXS(12),YXS(11),ZXS(10),XYS(9),YYS(8),ZYS(7), + XZS(6), YZS(5), ZZS(4), XOS(3),YOS(2),ZOS(1)) EQUIVALENCE (XM(1),XX),(YM(1),YX),(ZM(1),ZX) C I=MB(IT) IF(I)90,90,1 1 J=MC(IT) IF(J)90,90,2 2 IF(MTYPE)60,60,3 3 I=I+1 GOTO(10,20,30,40),J C C TYPE 1 10 XO=XO+XOS(I) YO=YO+YOS(I) GOTO 80 C C TYPE 2 20 DO 22 K=1,12,3 XM(K)=XXS(I)*XM(K) 22 YM(K)=YYS(I)*YM(K) GOTO 10 C C TYPE 3 30 DO 33 K=1,12,3 X=XM(K) Y=YM(K) XM(K)=XXS(I)*X+XYS(I)*Y 33 YM(K)=YXS(I)*X+YYS(I)*Y GOTO 10 C C TYPE 4 40 DO 44 K=1,12,3 X=XM(K) Y=YM(K) Z=ZM(K) XM(K)=XXS(I)*X+XYS(I)*Y+XZS(I)*Z YM(K)=YXS(I)*X+YYS(I)*Y+YZS(I)*Z 44 ZM(K)=ZXS(I)*X+ZYS(I)*Y+ZZS(I)*Z ZO=ZO+ZOS(I) GOTO 10 C 60 CONTINUE DO 70 K=1,12 70 XM(K)=XXS(I+K) C 80 IF(J.GT.MTYPE) MTYPE=J 90 RETURN END C SUBROUTINE MATRIX C 20/5/77 IMPLICIT INTEGER*2 (I-N) COMMON LIST(5000),LNK(5000) COMMON/MAT/MA(1000),MX(256),MY(256),MZ(256) DIMENSION MB(999),MC(998) EQUIVALENCE (MA(2),MB(1)),(MA(3),MC(1)) COMMON/GRAF/RS(240),FRACT,IT,MTREE,LINC,NCC,MAT,MTYPE,KDUM(30) COMMON/TREEC/XX,YX,ZX,XY,YY,ZY,XZ,YZ,ZZ,XO,YO,ZO, + PERSP,MWS,NWS,MSTOR,LTREE DIMENSION AMAT(12) EQUIVALENCE (AMAT(1),XX) DIMENSION SMAT(240) EQUIVALENCE (RS(1),SMAT(1)) C I=MTYPE+2 GOTO(90,999,10,20,30,40),I C C TYPE 1: MOVE ORIGIN (2D) 10 DO 11 I=MWS,NWS MX(I)=MX(I)+XO MY(I)=MY(I)+YO 11 CONTINUE GOTO 90 C C TYPE 2: SCALE + MOVE ORIGIN (2D) 20 DO 22 I=MWS,NWS MX(I)=XX*MX(I)+XO MY(I)=YY*MY(I)+YO 22 CONTINUE GOTO 90 C C TYPE 3: COMPLETE 2D MATRIX 30 DO 33 I=MWS,NWS X=MX(I) Y=MY(I) MX(I)=XX*X+XY*Y+XO MY(I)=YX*X+YY*Y+YO 33 CONTINUE GOTO 90 C C TYPE 4: COMPLETE 3D MATRIX 40 DO 44 I=MWS,NWS X=MX(I) Y=MY(I) Z=MZ(I) MX(I)=XX*X+XY*Y+XZ*Z+XO MY(I)=YX*X+YY*Y+YZ*Z+YO MZ(I)=ZX*X+ZY*Y+ZZ*Z+ZO 44 CONTINUE C C RESET ACCUMULATOR MATRIX 90 CONTINUE DO 99 I=1,12 99 AMAT(I)=SMAT(I) MTYPE=0 999 RETURN END C SUBROUTINE GROUT C 17/5/77 IMPLICIT INTEGER*2 (I-N) COMMON LIST(5000),LNK(5000) COMMON/MAT/MA(1000),MX(256),MY(256),MZ(256) COMMON/FIGS/IFIG(20),ICOL(20),FADE(20),LEV(20), + IOUT(50),NFIG,NOUT,MFIG,MOUT,IEXTR COMMON/WINDO/XMIN,XMAX,YMIN,YMAX DIMENSION XLIM(2),YLIM(2) EQUIVALENCE (XLIM(1),XMIN),(YLIM(1),YMIN) EQUIVALENCE (XLIM(2),XMAX),(YLIM(2),YMAX) C NO=1 N=1 C DO 300 NF=1,NFIG CALL ATTRIB(NF) MO=IFIG(NF) C DO 200 IO=NO,MO M=IOUT(IO) NLINE=INT(1,2) C DO 100 I=N,M X=MX(I) Y=MY(I) C C SCISSORING C NXC=0 NYC=0 IF(X.LT.XMIN) NXC=1 IF(X.GT.XMAX) NXC=2 IF(Y.LT.YMIN) NYC=1 IF(Y.GT.YMAX) NYC=2 NIN=0 IF(NXC+NYC.EQ.0)NIN=1 C IF(NLINE.EQ.1) GOTO 28 IF(LIN.EQ.1.AND.NIN.EQ.1) GOTO 32 IF(LXC.EQ.NXC.AND.LXC.NE.0.OR.LYC.EQ.NYC.AND.LYC.NE.0) GOTO 38 C C COMPUTE SLOPE DY=Y-YL IF(INT(DY).EQ.0) GOTO 22 DX=X-XL IF(INT(DX).EQ.0) GOTO 24 S=DY/DX C IF(LXC.EQ.0) GOTO 14 XL=XLIM(LXC) YL=Y+(XL-X)*S IF(YL.GE.YMIN) GOTO 12 IF(LYC.NE.1) GOTO 38 GOTO 16 C 12 IF(YL.LE.YMAX) GOTO 18 IF(LYC.NE.2) GOTO 38 GOTO 16 C 14 IF(LYC.EQ.0) GOTO 18 16 YL=YLIM(LYC) XL=X+(YL-Y)/S IF(XL.LT.XMIN.OR.XL.GT.XMAX) GOTO 38 C 18 IF(NXC.EQ.0) GOTO 20 X=XLIM(NXC) Y=YL+(X-XL)*S C 20 IF(Y.GE.YMIN.AND.Y.LE.YMAX) GOTO 30 Y=YLIM(NYC) X=XL+(Y-YL)/S GOTO 30 C C HORIZONTAL CASE 22 IF(LXC.NE.0) XL=XLIM(LXC) IF(NXC.NE.0) X=XLIM(NXC) GOTO 30 C C VERTICAL CASE 24 IF(LYC.NE.0) YL=YLIM(LYC) IF(NYC.NE.0) Y=YLIM(NYC) GOTO 30 C C DRAW START POINT 28 IF(NIN.EQ.1) CALL GDRAW(X,Y,INT(0,2)) GOTO 38 C 30 IF(LIN.EQ.1) GOTO 32 C DRAW MODIFIED LAST POINT CALL GDRAW(XL,YL,INT(0,2)) C DRAW LINE TO NEW POINT 32 CALL GDRAW(X,Y,INT(1,2)) C 38 LXC=NXC LYC=NYC LIN=NIN XL=MX(I) YL=MY(I) 100 NLINE=INT(0,2) C 200 N=M+1 C 300 NO=MO+1 C C END GRAPHIC OUTPUT CALL GDRAW(0.,0.,INT(-1,2)) RETURN END C SUBROUTINE ATTRIB(NF) C 17/5/77 C NOVA/TEKTRONIX VERSION IMPLICIT INTEGER*2 (I-N) COMMON/FIGS/IFIG(20),ICOL(20),FADE(20),LEV(20), + IOUT(50),NFIG,NOUT,MFIG,MOUT,IEXTR COMMON/ATTR/NCOL,NLEV,NFAD,NATS C NATS=0 C++ IF(IEXTR.LT.0) RETURN C C COLOUR NCOL=ICOL(NF) NATS=1 C C LEVEL NLEV=LEV(NF) IF(NLEV.NE.0) NATS=2 C C FADE NFAD=IFIX(FADE(NF)*100.) IF(NFAD.LT.100) NATS=3 C RETURN END C SUBROUTINE GDRAW(X,Y,LINE) C 17/5/77 IMPLICIT INTEGER*2 (I-N) COMMON/MAIN/IW,IA,LSTAK,MS,IREST(10) COMMON/TYPES/MNEG,MSYM,MADR COMMON/ATTR/IATR(3),NATS COMMON/TEK/IGS,IUS COMMON/DADGD/IFLAG C++ added INTEGER*2 ALPHA C++ C++ enhanced SVG driver, limited support for colour and fade C++ IF(LINE)2000,2001,2002 2000 CONTINUE WRITE(8,3000) C++ C++ send output to stream 10 (SVG animation) as well as 8 (SVG) WRITE(10,3000) 3000 FORMAT(3H"/>) IFLAG=0 GOTO 99 2001 CONTINUE C IF(IFLAG.EQ.1)WRITE(8,3000) IF(IFLAG.EQ.1)WRITE(10,3000) IF (IATR(1).NE.0)GOTO 1000 C++ C++ no attributes specified for this element C++ WRITE(8,3001, ADVANCE="NO")INT(IFIX(X),2), INT(IFIX(Y),2) WRITE(10,3001, ADVANCE="NO")INT(IFIX(X),2), INT(IFIX(Y),2) 3001 FORMAT(10H) WRITE(IOCH,102) MSG(1:LMCH) 102 FORMAT(80A1) WRITE(IOCH,103) 103 FORMAT(5H) WRITE(IOCH,104) 104 FORMAT(7H) WRITE(IOCH,105) 105 FORMAT(4H) WRITE(IOCH,107) 107 FORMAT(47H ) WRITE(IOCH,108) 108 FORMAT(44H ) WRITE(IOCH,112) 112 FORMAT(49H) WRITE(IOCH,109) 109 FORMAT(5H) WRITE(IOCH,105) WRITE(IOCH,110) IW,IA,LSTAK,MS,LS,MC,NC,M0,M1,M2,NAMCH,NARG 110 FORMAT(12(4H)) WRITE(IOCH,109) WRITE(IOCH,111) 111 FORMAT(8H
IWIALSTAKMSLSMCNCM0M1M2NAMCHNARG
,I6,5H
) C PRINT STACK,GROUPS OF 4 ROWS C COMPUTE NUMBER OF NCOLS TO PRINT ICELLS=(IEND-ISTART+1) IBLOCK=ICELLS/NCOLS IF(IBLOCK.LE.0)GOTO 100 DO 20 I=1,IBLOCK CALL PRTBLK(INT(ISTART+(I-1)*NCOLS,2),NCOLS) 20 CONTINUE 100 CONTINUE C C OUTPUT PART-FILLED BLOCK IF ANY C IREM=ICELLS-(ICELLS/NCOLS)*NCOLS IF(IREM.GT.0) CALL PRTBLK(ISTART+IBLOCK*NCOLS,IREM) C RETURN END C C SUBROUTINE PRTBLK(ISTART, NUMCOL) C 14/2/21 print block of cells as html table IMPLICIT INTEGER*2 (I-N) INTEGER*2 ISTART,NCOLS COMMON LIST(5000),LNK(5000) COMMON/MAT/MA(1000),MX(256),MY(256),MZ(256) COMMON/EXTEND/LINIT,IOCH,NCOLS,IPRMX WRITE(IOCH,112) ISTART,NUMCOL 112 FORMAT(2H) C PRINT GROUP OF CELLS WRITE(IOCH,113) 113 FORMAT(21H) WRITE(IOCH,105) 105 FORMAT(4H) WRITE(IOCH,106) 106 FORMAT(10H) DO 30 J=1,NUMCOL WRITE(IOCH,114) J+ISTART-1 114 FORMAT(4H) 30 CONTINUE WRITE(IOCH,109) 109 FORMAT(5H) WRITE(IOCH,105) WRITE(IOCH,117) DO 40 J=1,NUMCOL WRITE(IOCH,114)LIST(J+ISTART-1) 40 CONTINUE WRITE(IOCH,109) WRITE(IOCH,105) WRITE(IOCH,117) 117 FORMAT(16H) DO 50 J=1,NUMCOL WRITE(IOCH,118) LIST(J+ISTART-1) 118 FORMAT(4H) 50 CONTINUE WRITE(IOCH,109) WRITE(IOCH,105) WRITE(IOCH,116) 116 FORMAT(15H) DO 60 J=1,NUMCOL IF(LNK(J+ISTART-1).NE.(J+ISTART))GOTO 61 WRITE(IOCH,114) LNK(J+ISTART-1) GOTO 62 61 CONTINUE WRITE(IOCH,115) LNK(J+ISTART-1) 115 FORMAT(22H) 62 CONTINUE 60 CONTINUE WRITE(IOCH,109) WRITE(IOCH,111) 111 FORMAT(8H
I,I6,5H
LIST(I),Z4,5HLNK(I),I6,5H
) RETURN END C SUBROUTINE PARGS(NENTS,IARGPT,IARG2) C 17/2/21 IMPLICIT INTEGER*2 (I-N) COMMON LIST(5000),LNK(5000) COMMON/MAT/MA(1000),MX(256),MY(256),MZ(256) COMMON/MAIN/IW,IA,LSTAK,MS,LS,MC,NC,M0,M1,M2,NAMCH,IARG,JARG,NARG C LINIT SET TO TRUE AT INITIALISATION C IOCH OUTPUT CHANNEL C NCOLS number of columns in table COMMON/EXTEND/LINIT,IOCH,NCOLS,IPRMX INTEGER*2 IARGPT(3),IARG2(3) IF(NENTS.LE.1.OR.NENTS.GT.3)GOTO 30 WRITE(IOCH,113) 113 FORMAT(7H) WRITE(IOCH,105) 105 FORMAT(54H) DO 20 I=1,NENTS WRITE(IOCH,106) 106 FORMAT(4H) WRITE(IOCH,107)I 107 FORMAT(4H) WRITE(IOCH,107)IARGPT(I) WRITE(IOCH,107)IARG2(I) WRITE(IOCH,109) 109 FORMAT(5H) 20 CONTINUE WRITE(IOCH,111) 111 FORMAT(8H
IIARGPT(I)IARG2(I)
,I6,5H
) RETURN 30 CONTINUE C C ERROR NENTS OUT OF RANGE C WRITE(2,222) 222 FORMAT(28HERROR: PARGS NENTS NOT 1,2,3) END C C INIT1 ADDED ALL INITIALISATIONS NOT IN ORIGINAL VERSIONS C SUBROUTINE INIT1 IMPLICIT INTEGER*2 (I-N) COMMON LIST(5000),LNK(5000) COMMON/MAT/MA(1000),MX(256),MY(256),MZ(256) COMMON/MAIN/IW,IA,LSTAK,MS,LS,MM,NC,M0,M1,M2,NAMCH,IARG,JARG,NARG COMMON/FIGS/IFIG(20),ICOL(20),FADE(20),LEV(20), + IOUT(50),NFIG,NOUT,MFIG,MOUT,IEXTR COMMON/TREEC/XX,YX,ZX,XY,YY,ZY,XZ,YZ,ZZ,XO,YO,ZO, + PERSP,MWS,NWS,MSTOR,LTREE COMMON/GRAF/RS(240),FRACT,IT,MTREE,LINC,NCC,MAT,MTYPE,KDUM(30) COMMON/IO1/ICH(71),ISB(71),IOB(72),INP,IOP,NCL,NCW,KSHIFT(4) COMMON/IO2/JQ,LQ,NQ,KSYM(18),KBLANK COMMON/IO3/MIP,MOP,NID,NOD COMMON/EXTEND/LINIT,IOCH,NCOLS,IPRMX DIMENSION MB(999),MC(998) EQUIVALENCE (MA(2),MB(1)),(MA(3),MC(1)) DIMENSION II(8),SMAT(12),OS(231) EQUIVALENCE (II(1),I1),(RS(1),SMAT(1)),(RS(10),OS(1)) DIMENSION NFN(20) EQUIVALENCE (KDUM(1),IRP),(KDUM(2),MRS),(KDUM(3),I1), + (KDUM(4),I2), (KDUM(5),I3),(KDUM(6),I4), + (KDUM(7),I5), (KDUM(8),I6),(KDUM(9),I7), + (KDUM(10),I8),(NFN(1),KDUM(11)) C++ psuedo output file COMMON/OBUF/IOUTBP,IOUTB(710),MAXOUT C++ initiase pointer and max. buffer size IOUTBP=0 MAXOUT=710 C ADDITIONAL INITIALISATION REQUIRED BY CURRENT FORTRAN SYSTEMS C AND THE 32-BIT ARCHITECTURE DO 2023 I=1,30 KDUM(I)=0 2023 CONTINUE MFIG=20 MOUT=50 MSTOR=256 NFN(1)=0 NFN(2)=3 NFN(3)=3 NFN(4)=2 NFN(5)=3 NFN(6)=4 NFN(7)=2 NFN(8)=3 NFN(9)=2 NFN(10)=4 NFN(11)=0 NFN(12)=0 NFN(13)=0 NFN(14)=0 NFN(15)=0 NFN(16)=0 NFN(17)=0 NFN(18)=0 NFN(19)=0 NFN(20)=0 IT=1 LINC=0 NCC=0 MAT=0 MTYPE=0 MRS=240 MTREE=1000 FRACT=0. SMAT(1)=1. SMAT(2)=0. SMAT(3)=0. SMAT(4)=0. SMAT(5)=1. SMAT(6)=0. SMAT(7)=0. SMAT(8)=0. SMAT(9)=1. SMAT(10)=0. SMAT(11)=0. SMAT(12)=0. LINIT=1 IOCH=7 NCOLS=20 IPRMX=100 M0=0 M1=0 M2=0 NOD=9 C REPLACES DATA STATEMENTS IN BLOCKDATA KSYM(1)=ICHAR('<') KSYM(2)=ICHAR('>') KSYM(3)=ICHAR('(') KSYM(4)=ICHAR(')') KSYM(5)=ICHAR('#') KSYM(6)=ICHAR('^') KSYM(7)=ICHAR(';') KSYM(8)=ICHAR('!') KSYM(9)=ICHAR(',') KSYM(10)=ICHAR('[') KSYM(11)=ICHAR(']') KSYM(12)=ICHAR('"') KSYM(13)=ICHAR('-') KSYM(14)=ICHAR('0') KSYM(15)=ICHAR('9') KSYM(16)=ICHAR('A') KSYM(17)=ICHAR('Z') KSYM(18)=ICHAR(' ') C MOVE CHARACTER POSITIONS TO LEFT DO 2000 I=1,18 KSYM(I)=ISHFT(KSYM(I),8) + ICHAR(' ') 2000 CONTINUE KBLANK=ICHAR(' ') C INITIALISE DUMP OF STACK WRITE(7,701) 701 FORMAT(31HDump) WRITE(7,702) 702 FORMAT(53H) WRITE(7,703) 703 FORMAT(13H ) WRITE(7,704) 704 FORMAT(19H

Print Dump

) C INITIALISE GRAPHICAL OUTPUT FILE WRITE(8,705) 705 FORMAT(39H) WRITE(8,707) 707 FORMAT(44H) WRITE(8,708) 708 FORMAT(39H) WRITE(8,709) 709 FORMAT(27H) RETURN END C SUBROUTINE USER(IFN) C 17/5/21 USER ROUTINE ADDED FOR SVG OUTPUT IMPLICIT INTEGER*2 (I-N) COMMON LIST(5000),LNK(5000) COMMON/MAIN/IW,IA,LSTAK,MS,LS,MM,NC,M0,M1,M2,NAMCH,IARG,JARG,NARG COMMON/IO3/MIP,MOP,NID,NOD COMMON/SVGANI/IFRAME C C write output to stream 8 (.svg) and stream 10 (SVG animation .htm) C ISVG=8 IHTMA=10 IF(IFN.LE.0.OR.IFN.GT.7)GOTO 800 GOTO(10,20,200,400,500,600,700)IFN 500 CALL SETWAV RETURN 600 CALL WOBBLE RETURN 700 CALL BURN RETURN 800 CONTINUE WRITE(NOD,30)IFN 30 FORMAT(31HUSER FUNCTION OUT OF RANGE IFN=,I6) GOTO 100 10 CONTINUE IF(M2.NE.LSTAK)GOTO 40 WRITE(ISVG,11) 11 FORMAT(3H) WRITE(IHTMA,11) GOTO 100 40 CONTINUE M2=LNK(M2) WRITE(ISVG,12)IFRAME,LIST(M2) C++ C++ IFRAME is initialised to 0 in INIHTM, increment by one C++ IFRAME=IFRAME+1 WRITE(IHTMA,12)IFRAME,LIST(M2) 12 FORMAT(8H) GOTO 100 20 CONTINUE WRITE(ISVG,13) WRITE(IHTMA,13) 13 FORMAT(4H) 100 RETURN C++ C++ print the names of macros in the name chain C++ 200 CONTINUE CALL PRMACS RETURN C++ C++ generate coordinates of arc C++ 400 CONTINUE CALL ARCGEN END C SUBROUTINE INIHTM IMPLICIT INTEGER*2 (I-N) COMMON/SVGANI/IFRAME C++ C++ subroutine to initialise HTML file for SVG + JavaScript animation C++ IHTMA=10 IFRAME=0 WRITE(IHTMA, 100) 100 FORMAT(15H, +16H, +6H, +23H) WRITE(IHTMA,101) 101 FORMAT(7H) WRITE(IHTMA,102) 102 FORMAT(29HGRAM Animation) WRITE(IHTMA,103) 103 FORMAT(36H) WRITE(IHTMA,104) 104 FORMAT(7H) WRITE(IHTMA,105) 105 FORMAT(22H) WRITE(IHTMA,106) 106 FORMAT(3H

) WRITE(IHTMA,107) 107 FORMAT(47H) WRITE(IHTMA,108) 108 FORMAT(34H) WRITE(IHTMA,109) 109 FORMAT(46H) WRITE(IHTMA,110) 110 FORMAT(48H) WRITE(IHTMA,111) 111 FORMAT(49H) WRITE(IHTMA,112) 112 FORMAT(47H) WRITE(IHTMA,113) 113 FORMAT(52H) WRITE(IHTMA,114) 114 FORMAT(32H) WRITE(IHTMA,115) 115 FORMAT(4H

) WRITE(IHTMA,116) 116 FORMAT(49H

Frame: 0 Frame name:, +33H0

) C++ C++ now initialise the SVG part of the file; same as channel 8 C++ WRITE(IHTMA,705) 705 FORMAT(39H) WRITE(IHTMA,707) 707 FORMAT(44H) WRITE(IHTMA,708) 708 FORMAT(39H) WRITE(IHTMA,709) 709 FORMAT(27H) RETURN END C SUBROUTINE PRMACS IMPLICIT INTEGER*2 (I-N) COMMON LIST(5000),LNK(5000) COMMON/MAT/MA(1000),MX(256),MY(256),MZ(256) COMMON/MAIN/IW,IA,LSTAK,MS,LS,MC,NC,M0,M1,M2,NAMCH,IARG,JARG,NARG COMMON/IO3/MIP,MOP,NID,NOD INTEGER *2 ALPHA DIMENSION LBUF(40) C++ C++ added by David 24/5/21 C++ routine to print names and locations of macros in the name chain C++ C++ start of namechain is at NAMECH C++ C++ NOD=9 I=NAMCH WRITE(NOD,24) 24 FORMAT(6HI ,6HBODY ,6HSTART ,10HMACRO NAME) GOTO 2 1 CONTINUE C WRITE(NOD,22)I C22 FORMAT(2HI=,I6) I=LIST(I) 2 CONTINUE IF(I.LE.0) GOTO 5 IA=LNK(I) IF(IA) 1,1,6 C++ scan for end of name, allow max of 20 words (40 chars) 6 CONTINUE ISTART=IA C IEND=IA IBUF=0 C KPOS=0 DO 3 J=ISTART, ISTART+20 C++ exit loop if not alphanumeric C IEND=IA IBUF=IBUF+1 C++ unpack to 1 character per word LBUF(IBUF)=ISHFT(LIST(IA),-8) C++ only print second character if not zero ICH=ISHFT(ISHFT(LIST(IA),8),-8) IF(ICH.EQ.0)GOTO 7 IBUF=IBUF+1 LBUF(IBUF)=ICH 7 CONTINUE IA=LNK(IA) IF(ALPHA(LIST(IA)).LT.1) GOTO 4 3 CONTINUE 4 CONTINUE C IF(ISTART.NE.IEND) WRITE(NOD,20)ISTART,IEND,IBUF C 20 FORMAT(7HISTART=,I6,6H IEND=,I6,6H IBUF=,I6) WRITE(NOD,23)I,LNK(IA),ISTART,(LBUF(K),K=1,IBUF) 23 FORMAT(I6,I6,I6,2X,40(A1)) C++ look at next entry in chain GOTO 1 5 WRITE(NOD,21) 21 FORMAT(17HEND OF NAME CHAIN) RETURN END C SUBROUTINE ARCGEN IMPLICIT INTEGER*2 (I-N) COMMON LIST(5000),LNK(5000) COMMON/MAT/MA(1000),MX(256),MY(256),MZ(256) COMMON/MAIN/IW,IA,LSTAK,MS,LS,MM,NC,M0,M1,M2,NAMCH,IARG,JARG,NARG COMMON/GRAF/RS(240),FRACT,IT,MTREE,LINC,NCC,MAT,MTYPE,KDUM(30) COMMON/IO3/MIP,MOP,NID,NOD DIMENSION MB(999),MC(998) EQUIVALENCE (MA(2),MB(1)),(MA(3),MC(1)) DIMENSION II(8),SMAT(12),OS(231) EQUIVALENCE (II(1),I1),(RS(1),SMAT(1)),(RS(10),OS(1)) DIMENSION NFN(20) EQUIVALENCE (KDUM(1),IRP),(KDUM(2),MRS),(KDUM(3),I1), + (KDUM(4),I2),(KDUM(5),I3),(KDUM(6),I4), +(KDUM(7),I5),(KDUM(8),I6),(KDUM(9),I7), +(KDUM(10),I8),(NFN(1),KDUM(11)) C++ C++ code taken from TOTREE C++ generates coordinates of ARC on stack, but unlike TOTREE C++ includes the start point and sets first entry to number of POINTS C++ then ! separator C++ TOTREE arc code sets first entry to number of COORDINATES with no C++ separator C++ IF(M2.EQ.LSTAK) GOTO 2 C PASS ARGUMENTS DO 1 NARGS=1,8 M2=LNK(M2) II(NARGS)=LIST(M2) IF(M2.EQ.LSTAK) GOTO 3 1 CONTINUE NARGS=8 GOTO 3 C 2 NARGS=0 3 LSTAK=M0 C++ C++ check number of arguments, should be between 5 and 7 C++ IF(NARGS.GE.5.AND.NARGS.LE.7) GOTO 100 WRITE(NOD,20)NARGS 20 FORMAT(34HGENARC INVALID NUMBER OF ARGUMENTS, I6, 9HSHOULD BE, + 15H BETWEEN 5 to 7) GOTO 200 100 CONTINUE C C GENERATE ARC C X=FLOAT(I2-I4) C Y=FLOAT(I3-I5) A=ATANN(Y,X) IF((I3-I5).NE.0) X=Y/SIN(A) IF(X.LT.0) X=-X C N=I1 IF(N)187,200,188 187 N=-N 188 DA=6.28318/FLOAT(I1) IF(NARGS-5)200,185,181 C 181 B=ATANN(FLOAT(I7-I5),FLOAT(I6-I4))-A IF(I1)183,182,182 182 IF(B.LT.0.) B=B+6.28318 GOTO 184 183 IF(B.GT.0.) B=B-6.28318 C 184 N=INT(B/DA+0.999) IF(N.EQ.0) N=1 DA=B/FLOAT(N) C 185 CONTINUE C++ C++ IW=N as N is the number of points C++ added ! separator C++ IW=N+1 CALL LOAD IW=-32759 C++ C++ load start point C++ CALL LOAD IW=I2 CALL LOAD IW=I3 CALL LOAD C DO 186 I=1,N B=A+DA*FLOAT(I) IW=I4+INT(X*COS(B)) CALL LOAD IW=I5+INT(X*SIN(B)) 186 CALL LOAD 200 CONTINUE RETURN END C++ C++ from Alien_batch 01 1100614.jpg SUBROUTINE WOBBLE IMPLICIT INTEGER*2 (I-N) C++ original source ended at IREST(4) COMMON/GRAF/RS(240),FRACT,IREST(4),MAT,MTYPE,KDUM(30) DIMENSION II(3) DATA TWOPI/6.28318/,A/0.0/ C C NARGS=IARGS(II,INT(3,2)) CALL IARGS(II,INT(3,2),NARGS) NF=II(3) IPER=II(1) N=NF-NF/IPER*IPER A=TWOPI*FLOAT(N)/FLOAT(IPER) FRACT=FRACT+(SIN(A)*FRACT-1.0)*FLOAT(II(2))/100. RETURN END C C SUBROUTINE SPFUNC(IFN) C IMPLICIT INTEGER*2 (I-N) C COMMON/GRAF/RS(240),FRACT,IT,MTREE,LINC,NCC, C +MAT,MTYPE,IRP,MRS,I1,I2,I3,I4,I5,I6,I7,I8,NFN(20) C COMMON/TREEC/XX,YX,ZX,XY,YY,ZY,XZ,YZ,ZZ,XO,YO,ZO, C + PERSP,MWS,NWS,MSTOR,LTREE C DATA NFN/0,3,3,4,5,1,2,3,2,4,5,9*1/ C IF(NWS.LT.MWS)RETURN C CALL MATMAT C CALL MATRIX C C CALL WAVE C C RETURN C END C C++ 100615.jpg C SUBROUTINE SETWAV IMPLICIT INTEGER*2 (I-N) COMMON/FSTORE/IPT(10000),IOST(10000),LTH(1000),IFST(100), + MPT,NPT,MOST,NOST,MFST,NFST,LFULL COMMON/WAVES/XWAVE(200),YWAVE(200),WLX,WLY,VELX,VELY,TEDGE,BEDGE, + KFIG,KPTS DIMENSION II(7),PARAM(6) EQUIVALENCE(II(1),I1),(II(2),I2),(II(7),I7),(PARAM(1),WLX) DATA XORIG,YORIG/2*0.0/,TWOPI/6.28318/ C C SET UP PARAMETERS C CALL IARGS(II,INT(7,2),NARGS) C NARGS=IARGS(II,INT(7,2)) DO 10 I=1,NARGS 10 PARAM(I)=FLOAT(II(I)) IF(I1.LE.0.OR.I2.LE.0)GOTO 30 C C SET UP WAVE ARRAYS C XORIG=XORIG+VELX YORIG=YORIG+VELY XP=TWOPI/WLX YP=TWOPI/WLY C I=IFST(I7) KFIG=IOST(I) J=IFST(I7+1) KPTS=(IOST(J)-KFIG)/2 IF(KPTS.GE.200) KPTS=200 J=KFIG C DO 20 I=1,KPTS XWAVE(I)=SIN((FLOAT(IPT(J))-XORIG)+XP) IY=IPT(J+1) IF(IY.LT.0) IY=-IY YWAVE(I)=SIN((FLOAT(IY)-YORIG)*YP) 20 J=J+2 RETURN C C RESET ORIGINS 30 XORIG=VELX YORIG=VELY RETURN C END C C 1100616.jpg C SUBROUTINE WAVE IMPLICIT INTEGER*2 (I-N) COMMON/GRAF/RS(240),FRACT,IT,MTREE,LINC,NCC, + MAT,MTYPE,IRP,MRS,I1,I2,I3,I4,I5,I6,I7,I8,NFN(20) COMMON/TRIC/MA(1000) COMMON/GSTACK/RX(256),RY(256),RZ(256) COMMON/TREEC/XX,YX,ZX,XY,YY,ZY,XZ,YZ,ZZ,XO,YO,ZO, + PERSP,MWS,NWS,MSTOR,LTREE COMMON/FSTORE/IPT(10000),IOST(10000),LTH(1000),IFST(100), + MPT,NPT,MOST,NOST,MFST,NFST,LFULL COMMON/WAVES/XWAV(200),YWAV(200),WLX,WLY,VELX,VELY,TEDGE,BEDGE, + KFIG,KPTS C FE=FLOAT(MA(IT+3))/100. PHASE=FLOAT(MA(IT+4)) C N=NWS-MWS+1 IF(N.GT.KPTS) N=KPTS J=MWS K=KFIG C DO 10 I=1,N X=FLOAT(IPT(K)) Y=FLOAT(IPT(K+1)) E=TEDGE IF(Y.LT.0.) E=BEDGE YY=E-(E-Y)*FE RX(J)=X+(RX(J)-X)*YWAV(I)*FE+PHASE RY(J)=YY+(RY(J)-Y)*XWAV(I)*FE J=J+1 10 K=K+2 C RETURN END SUBROUTINE BURN IMPLICIT INTEGER*2 (I-N) COMMON/MAIN/IW,IREST(13) COMMON/GRAF/RS(240),FRACT,IT,MTREE,LINC,NCC, + MAT,MTYPE,IRP,MRS,I1,I2,I3,I4,i5,I6,I7,I8,NFN(20) DIMENSION SMAT(12),OS(231) EQUIVALENCE (RS(1),SMAT(1)),(RS(10),OS(1)) COMMON/BURNC/DVX,DVY,DVZ,VX,VY,VZ,X,Y,Z COMMON/IO3/MIP,MOP,NID,NOD DIMENSION P(3),PARAM(9),II(9) EQUIVALENCE(PARAM(1),DVX),(P(1),PARAM(7)) DATA PARAM/9*0.0/ C C WRITE(2,900)MTYPE C900 FORMAT(10X,12H BURN MTYPE=,I6) IF(MTYPE.NE.0) GOTO 10 C MAT=IRP IRP=IRP+12 IF(MAT.GT.MRS-12) GOTO 920 DO 15 I=1,12 J=MAT+I 15 RS(J)=SMAT(I) C 10 CALL IARGS(II,INT(9,2),NARGS) CNARGS=IARGS(II,INT(9,2)) C WRITE(2,930)NARGS,(II(I),I=1,NARGS) C930 FORMAT(10X,8H BURN II,10I6) IF(NARGS.LE.0) GOTO 22 DO 20 I=1,NARGS 20 PARAM(I)=FLOAT(II(I)) C 22 VX=VX+DVX X=X+VX VY=VY+DVY Y=Y+VY VZ=VZ+DVZ Z=Z+VZ C DO 30 I=1,3 J=MAT+I OS(J)=OS(J)+P(I) C WRITE(2,940)P(I),OS(J) C940 FORMAT(10X,11H BURN P(I)=,F9.2, 7H OS(J)=,F9.2) 30 CONTINUE C MTYPE=4 C C following code was crossed out on listing C C DO 40 I=1,3 C IW=IFIX(PARAM(I)) C 40 CALL LOAD C C DO 50 I=4,9 C IW=IFIX(PARAM(I))/10 C 50 CALL LOAD C RETURN C C ERROR CONDITIONS C C 1100618.jpg C 920 WRITE(NOD,925) 925 FORMAT(2X,20HMATRIX STORE OVERLOW) RETURN END SUBROUTINE IARGS(IAR,N,IRG) IMPLICIT INTEGER*2 (I-N) COMMON LIST(5000),LNK(5000) COMMON/MAIN/IW,IA,LSTAK,MS,LS,MC,NC,M0,M1,M2,NAMCH,IARG,JARG,NARG DIMENSION IAR(9) C DO 1 I=1,N IF(M2.EQ.LSTAK) GOTO 2 M2=LNK(M2) 1 IAR(I)=LIST(M2) I=N+1 C 2 IRG=I-1 LSTAK=M0 RETURN END