PWCNVT CSY/ 01A P€1_$SUBROUTINE CNVT_^1_#*_2/DECK-ID 01A FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^13_]_^1C ALL FORTRAN ROUTINES FOLLOWED BY ALL ASSEMBLY ROUTINES_^1C FTN IS IN PHASE A ASSEMBLY ROUTINES_^1C GOA IS ASSEMBLY_^1C CNVT IS USED IN PHASES A1,A2,A3,A4,A5,€€B1_^1C_]_^1C CNVT USED IN PHASE B_^1C_]_^1C_#MASTER LABELED COMMON BLOCK._^1*_] FTN 3.3_^1_$COMMON /A/ IFLAGS,LINECT,LINCT1_^1_$COMMON /A/ IR,IK,IP,IA,IL,IM,IXLGO,IOPTO,IOPTV,IOPTC,IOPTD_^1_$COMMON /A/ MCSTRT,MACRNB,MACSEC_^1_$COMMON /A/ IERRS(16),ISRFAD_^1_$COMMON /A/ LGO,ISCRI,ISCRO,IX_^1*_] FTN 3.3_^1_$COMMON /A/ IGLAB(3),IGLAB1,IGLAB2_^1_$COMMON /A/ ICOMT(12),ICOMTS,ICOMX2,I€€COMTL,ISUBP,NDPRS,_^1_#$LABX,IBCDTB(48)_^1_$EQUIVALENCE(ICOMB,ICOMT(1)),(ICOMBX,ICOMT(2)),(ICOMDF,_^1_#$ICOMT(3)),(ICOMBN,ICOMT(4))_^1_$DIMENSION ICOMB(6),ICOMBX(6),ICOMDF(6),ICOMBN(7)_^1_$COMMON /A/ LOOPTS,LOOPTX,LOOPTB,LOOPT(50)_^1_$EQUIVALENCE(LINDUC,LOOPT(1))_^1_$DIMENSION LINDUC(10)_^1_$EQUIVALENCE (LBEG,LOOPT(2))_^1_$DIMENSION LBEG(10)_^1_$EQUIVALENCE (LINC,LOOPT(3))_^1_$DIME€€NSION LINC(10)_^1_$EQUIVALENCE (LEND,LOOPT(4))_^1_$DIMENSION LEND(10)_^1_$BYTE(LLABL,LOOPT(5)(14=0)_))_^1_$DIMENSION LLABL(10)_^1_$BYTE(LID,LOOPT(5)(15=15) )_^1_$DIMENSION LID(10)_^1_$COMMON/A/IEQV(255), IEQVS,IEQVN2_^1_$COMMON /A/ ISTAB(150),ISTABS,ISTAB2_^1_$COMMON /A/ IBUFS,ISET(25),LBLANK,KSFCNT,KSNCNT,ISORSC,_^1_#$IHOBIT,ISTNO,ISSFLG,ISUBPN,ITERM,JSORSC,KEQVS_^1C_#SYMBOL TAB€€LE LABELED COMMON BLOCK_^1_$COMMON /A/ ISYMN, ISYMFL,ISYMD,ISYMX,ISYMS,ISYMP,ISYMPC,ISYMPS,_^1_#$ ISYMNS, SYMTAB(960)_^1_$INTEGER SYMTAB_^1_$BYTE (IDUM,SYMTAB(1)(15=15)),(KDUMY,SYMTAB(1)(15=15)),_^1_#$(ICLASS,SYMTAB(1)(14=11)),(ITYPE,SYMTAB(1)(10=9))_^1_$DIMENSION IDUM(100),KDUMY(100),ICLASS(100),ITYPE(100)_^1_$BYTE (ISNGL, SYMTAB(1)(8=8)),(KELSIZ,SYMTAB(1)(8=8)),_^1_#$ (ICOM,SYMTA€€B(1)(7=5)),(IPART,SYMTAB(1)(4=3))_^1_$DIMENSION ISNGL(100),KELSIZ(100),ICOM(100),IPART(100)_^1_$BYTE (KRFCNT,SYMTAB(1)(2=2)),(IDIM,SYMTAB(1)(1=0)),_^1_#$ (IREL,SYMTAB(1)(1=1)),(IEXT,SYMTAB(1)(0=0))_^1_$DIMENSION KRFCNT(100),IDIM(100),IREL(100),IEXT(100)_^1_$EQUIVALENCE (IRSA,SYMTAB(2)),(ICOMTX,SYMTAB(2)),(ISNOL,SYMTAB(2))_^1_$DIMENSION IRSA(100), ICOMTX(100),ISNOL(100)_^1_$BYTE (ID€€ATAS,SYMTAB(3)(15=15)),(IREF,SYMTAB(3)(15=15)),_^1_#$ (IEQVX,SYMTAB(3)(14=8)),(ITILF,SYMTAB(3)(14=8))_^1_$DIMENSION IDATAS(100),IREF(100),IEQVX(100),ITILF(100)_^1_$BYTE (IPARTR,SYMTAB(3)(7=4)),(INDUCV,SYMTAB(3)(7=7)),(ISFARG,_^1_#$ SYMTAB(3)(6=6)),(IARGNO,SYMTAB(3)(5=0)),(IPARTL,SYMTAB(3)(3=0))_^1_$DIMENSION IPARTR(100),INDUCV(100),ISFARG(100),IARGNO(100),_^1_#$ IPARTL(100)_^1_$EQU€€IVALENCE (ISYM,SYMTAB(4))_^1_$DIMENSION ISYM(100)_^1C_]_^1C_#SPECIFICATION-TABLE INDEX LABELLED COMMON BLOCK_^1_$COMMON /A/ ISTABX(96)_^1C_]_^1_$COMMON//JSYM(3)_^1_$DIMENSION KSYM(3)_^1_$DO 10 I = 1, 3_^1_$KSYM(I) = JSYM(I)/256_^1_$IF (KSYM(I) .EQ. 46) KSYM(I) = 38_^1_$JSYM(I) = AND(JSYM(I),$FF)_^1_$IF (JSYM(I) .EQ.46) JSYM(I) = 38_^1 10_!CONTINUE_^1_$JSYM(1) = KSYM(1)*1521+JSYM(1€j)*39 + KSYM(2)_^1_$JSYM(2) = JSYM(2)*1521 + KSYM(3)*39 + JSYM(3)_^1_$JSYM(3) = 0_^1_$RETURN_^1_$END_]_^__ jPWGPUT CSY/ 02A P€1_$SUBROUTINE GPUT_^1_#*_2/DECK-ID 02A FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^13_]_^1C GPUT IS USED IN PHASES A1,A2,A3,A4,A5_^1C_]_^1C_#MASTER LABELED COMMON BLOCK._^1*_] FTN 3.3_^1_$COMMON /A/ IFLAGS,LINECT,LINCT1_^1_$COMMON /A/ IR,IK,IP,IA,IL,I€€M,IXLGO,IOPTO,IOPTV,IOPTC,IOPTD_^1_$COMMON /A/ MCSTRT,MACRNB,MACSEC_^1_$COMMON /A/ IERRS(16),ISRFAD_^1_$COMMON /A/ LGO,ISCRI,ISCRO,IX_^1*_] FTN 3.3_^1_$COMMON /A/ IGLAB(3),IGLAB1,IGLAB2_^1_$COMMON /A/ ICOMT(12),ICOMTS,ICOMX2,ICOMTL,ISUBP,NDPRS,_^1_#$LABX,IBCDTB(48)_^1_$EQUIVALENCE(ICOMB,ICOMT(1)),(ICOMBX,ICOMT(2)),(ICOMDF,_^1_#$ICOMT(3)),(ICOMBN,ICOMT(4))_^1_$DIMENSION ICOMB(6),IC€€OMBX(6),ICOMDF(6),ICOMBN(7)_^1_$COMMON /A/ LOOPTS,LOOPTX,LOOPTB,LOOPT(50)_^1_$EQUIVALENCE(LINDUC,LOOPT(1))_^1_$DIMENSION LINDUC(10)_^1_$EQUIVALENCE (LBEG,LOOPT(2))_^1_$DIMENSION LBEG(10)_^1_$EQUIVALENCE (LINC,LOOPT(3))_^1_$DIMENSION LINC(10)_^1_$EQUIVALENCE (LEND,LOOPT(4))_^1_$DIMENSION LEND(10)_^1_$BYTE(LLABL,LOOPT(5)(14=0)_))_^1_$DIMENSION LLABL(10)_^1_$BYTE(LID,LOOPT(5)(15=15) €€ )_^1_$DIMENSION LID(10)_^1_$COMMON/A/IEQV(255), IEQVS,IEQVN2_^1_$COMMON /A/ ISTAB(150),ISTABS,ISTAB2_^1_$COMMON /A/ IBUFS,ISET(25),LBLANK,KSFCNT,KSNCNT,ISORSC,_^1_#$IHOBIT,ISTNO,ISSFLG,ISUBPN,ITERM,JSORSC,KEQVS_^1C_#SYMBOL TABLE LABELED COMMON BLOCK_^1_$COMMON /A/ ISYMN, ISYMFL,ISYMD,ISYMX,ISYMS,ISYMP,ISYMPC,ISYMPS,_^1_#$ ISYMNS, SYMTAB(960)_^1_$INTEGER SYMTAB_^1_$BYTE (IDUM,SYMTA€€B(1)(15=15)),(KDUMY,SYMTAB(1)(15=15)),_^1_#$(ICLASS,SYMTAB(1)(14=11)),(ITYPE,SYMTAB(1)(10=9))_^1_$DIMENSION IDUM(100),KDUMY(100),ICLASS(100),ITYPE(100)_^1_$BYTE (ISNGL, SYMTAB(1)(8=8)),(KELSIZ,SYMTAB(1)(8=8)),_^1_#$ (ICOM,SYMTAB(1)(7=5)),(IPART,SYMTAB(1)(4=3))_^1_$DIMENSION ISNGL(100),KELSIZ(100),ICOM(100),IPART(100)_^1_$BYTE (KRFCNT,SYMTAB(1)(2=2)),(IDIM,SYMTAB(1)(1=0)),_^1_#$ (IR€€EL,SYMTAB(1)(1=1)),(IEXT,SYMTAB(1)(0=0))_^1_$DIMENSION KRFCNT(100),IDIM(100),IREL(100),IEXT(100)_^1_$EQUIVALENCE (IRSA,SYMTAB(2)),(ICOMTX,SYMTAB(2)),(ISNOL,SYMTAB(2))_^1_$DIMENSION IRSA(100), ICOMTX(100),ISNOL(100)_^1_$BYTE (IDATAS,SYMTAB(3)(15=15)),(IREF,SYMTAB(3)(15=15)),_^1_#$ (IEQVX,SYMTAB(3)(14=8)),(ITILF,SYMTAB(3)(14=8))_^1_$DIMENSION IDATAS(100),IREF(100),IEQVX(100),ITILF(10€€0)_^1_$BYTE (IPARTR,SYMTAB(3)(7=4)),(INDUCV,SYMTAB(3)(7=7)),(ISFARG,_^1_#$ SYMTAB(3)(6=6)),(IARGNO,SYMTAB(3)(5=0)),(IPARTL,SYMTAB(3)(3=0))_^1_$DIMENSION IPARTR(100),INDUCV(100),ISFARG(100),IARGNO(100),_^1_#$ IPARTL(100)_^1_$EQUIVALENCE (ISYM,SYMTAB(4))_^1_$DIMENSION ISYM(100)_^1C_]_^1C_#SPECIFICATION-TABLE INDEX LABELLED COMMON BLOCK_^1_$COMMON /A/ ISTABX(96)_^1C_]_^1C_#PHASE A BLA€€NK COMMON BLOCK._^1_$COMMON // JSYM(3),JTERM,JMODE,JERR,JESWT,JFLOT,JCHAR,_^1_#$JOCHAR,JO1,JE,JE1,JBLANK,JCT,JCT1_^1C_#JSYM-JCT1 MUST REMAIN IN ORDER_^1_$COMMON//IERR_^1_$COMMON//ISORS(208),ISORSX_^1_$COMMON//IDEFF,ISTOP,IRET,ISPEC,NERR,OCT_^1_$INTEGER OCT_^1_$COMMON//ILLABL,LEST,ISNGL1,ICOMX1,NXTYPE,LOGIF,IOVFL1,IOVFL2_^1_$COMMON//IVCFLG,ISFLG,LOGEX,KEQVX_^1_$COMMON//IBUF2X,IBUF2(€€304)_^1C_$TEMPORARY ARITHMETIC BUFFERS_^1_$COMMON//IBUF1( 304),IBUF1X,IWORK (304)_^1C_#TEMPORARY EQUIVALENCE BUFFERS_^1_$DIMENSION KEQV(460),MEQV(255)_^1_$EQUIVALENCE (KEQV,IBUF1(66)),(MEQV,IBUF2(100))_^1C_#LS1-ITEM MUST REMAIN IN ORDER_^1_$COMMON//LS1,LPREN,LRELRQ,LRELEN,LSWITC,LO,ITEM_^1_$COMMON//MODE_^1_$COMMON//IPHAT(4),IGNSTT(49),IOSPRT(17)_^1C_]_^1C_]_^1C_#PUT ONE CHARACTER I€ðN JSYM_^1C_#THIS ROUTINE MAY HAVE TO BE REWRITTEN FOR 1700 FORTRAN ON 1700_^1C_]_^1_$JCT1=JCT1+1_^1_$JCT=JCT1/JSORSC_^1_$J=JCHAR_^1_$IF(JCT*JSORSC.EQ.JCT1)GO TO 1_^1_$JCT=JCT+1_^1_$J=JCHAR*256_^1_"1 JSYM(JCT)=OR(JSYM(JCT),J)_^1_$END_]_^__ ðPWSMBL1 CSY/ 03A P€1_$SUBROUTINE SYMBOL_^1_#*_2/DECK-ID 03A FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^13_]_^1C SYMBOL IS USED IN PHASES A1,A2,A3,A4,A5_^1C_]_^1C_#MASTER LABELED COMMON BLOCK._^1*_] FTN 3.3_^1_$COMMON /A/ IFLAGS,LINECT,LINCT1_^1_$COMMON /A/ IR,IK,IP,IA,€€IL,IM,IXLGO,IOPTO,IOPTV,IOPTC,IOPTD_^1_$COMMON /A/ MCSTRT,MACRNB,MACSEC_^1_$COMMON /A/ IERRS(16),ISRFAD_^1_$COMMON /A/ LGO,ISCRI,ISCRO,IX_^1*_] FTN 3.3_^1_$COMMON /A/ IGLAB(3),IGLAB1,IGLAB2_^1_$COMMON /A/ ICOMT(12),ICOMTS,ICOMX2,ICOMTL,ISUBP,NDPRS,_^1_#$LABX,IBCDTB(48)_^1_$EQUIVALENCE(ICOMB,ICOMT(1)),(ICOMBX,ICOMT(2)),(ICOMDF,_^1_#$ICOMT(3)),(ICOMBN,ICOMT(4))_^1_$DIMENSION ICOMB(6€€),ICOMBX(6),ICOMDF(6),ICOMBN(7)_^1_$COMMON /A/ LOOPTS,LOOPTX,LOOPTB,LOOPT(50)_^1_$EQUIVALENCE(LINDUC,LOOPT(1))_^1_$DIMENSION LINDUC(10)_^1_$EQUIVALENCE (LBEG,LOOPT(2))_^1_$DIMENSION LBEG(10)_^1_$EQUIVALENCE (LINC,LOOPT(3))_^1_$DIMENSION LINC(10)_^1_$EQUIVALENCE (LEND,LOOPT(4))_^1_$DIMENSION LEND(10)_^1_$BYTE(LLABL,LOOPT(5)(14=0)_))_^1_$DIMENSION LLABL(10)_^1_$BYTE(LID,LOOPT(5)(15=€€15) )_^1_$DIMENSION LID(10)_^1_$COMMON/A/IEQV(255), IEQVS,IEQVN2_^1_$COMMON /A/ ISTAB(150),ISTABS,ISTAB2_^1_$COMMON /A/ IBUFS,ISET(25),LBLANK,KSFCNT,KSNCNT,ISORSC,_^1_#$IHOBIT,ISTNO,ISSFLG,ISUBPN,ITERM,JSORSC,KEQVS_^1C_#SYMBOL TABLE LABELED COMMON BLOCK_^1_$COMMON /A/ ISYMN, ISYMFL,ISYMD,ISYMX,ISYMS,ISYMP,ISYMPC,ISYMPS,_^1_#$ ISYMNS, SYMTAB(960)_^1_$INTEGER SYMTAB_^1_$BYTE (IDUM,S€€YMTAB(1)(15=15)),(KDUMY,SYMTAB(1)(15=15)),_^1_#$(ICLASS,SYMTAB(1)(14=11)),(ITYPE,SYMTAB(1)(10=9))_^1_$DIMENSION IDUM(100),KDUMY(100),ICLASS(100),ITYPE(100)_^1_$BYTE (ISNGL, SYMTAB(1)(8=8)),(KELSIZ,SYMTAB(1)(8=8)),_^1_#$ (ICOM,SYMTAB(1)(7=5)),(IPART,SYMTAB(1)(4=3))_^1_$DIMENSION ISNGL(100),KELSIZ(100),ICOM(100),IPART(100)_^1_$BYTE (KRFCNT,SYMTAB(1)(2=2)),(IDIM,SYMTAB(1)(1=0)),_^1_#$€€ (IREL,SYMTAB(1)(1=1)),(IEXT,SYMTAB(1)(0=0))_^1_$DIMENSION KRFCNT(100),IDIM(100),IREL(100),IEXT(100)_^1_$EQUIVALENCE (IRSA,SYMTAB(2)),(ICOMTX,SYMTAB(2)),(ISNOL,SYMTAB(2))_^1_$DIMENSION IRSA(100), ICOMTX(100),ISNOL(100)_^1_$BYTE (IDATAS,SYMTAB(3)(15=15)),(IREF,SYMTAB(3)(15=15)),_^1_#$ (IEQVX,SYMTAB(3)(14=8)),(ITILF,SYMTAB(3)(14=8))_^1_$DIMENSION IDATAS(100),IREF(100),IEQVX(100),ITIL€€F(100)_^1_$BYTE (IPARTR,SYMTAB(3)(7=4)),(INDUCV,SYMTAB(3)(7=7)),(ISFARG,_^1_#$ SYMTAB(3)(6=6)),(IARGNO,SYMTAB(3)(5=0)),(IPARTL,SYMTAB(3)(3=0))_^1_$DIMENSION IPARTR(100),INDUCV(100),ISFARG(100),IARGNO(100),_^1_#$ IPARTL(100)_^1_$EQUIVALENCE (ISYM,SYMTAB(4))_^1_$DIMENSION ISYM(100)_^1C_]_^1C_#SPECIFICATION-TABLE INDEX LABELLED COMMON BLOCK_^1_$COMMON /A/ ISTABX(96)_^1C_]_^1C_8BEGIN_4€€***** FTN 3.1 *****_^1_$COMMON // JSYM(3),IFILL,JMODE_^1C_8END_6***** FTN 3.1 *****_^1C_]_^1C_#MESSAGE ' *F,58'...'SYMBOL TABLE OVERFLOW.'_^1_$DIMENSION IOVFL(3)_^1_$DATA IOVFL(1),IOVFL(2),IOVFL(3) /$202A,$462C,$3538/_^1_$DIMENSION ISMREF(100)_^1_$DATA NSMREF,LASTST/0,-1/_^1C_#INITIALIZE TO FIRST ENTRY OF SYMTAB._^1_$I=0_]_^1_$IFIRST=ISYMPC_^1_$ISYMX =1_^1_$ISYMD =1_^1C ***********€€*********************** FTN 3.2 **************************_^1C_]_^1C_FINCORE = 1, CHECK FROM CURRENT_^1C_HSYMTAB PAGE TO END OF SYMTAB._^1C_]_^1C_FINCORE = 2, CHECK FROM BEGINNING_^1C_HSYMTAB PAGE TO CURRENT PAGE._^1C_]_^1C_FINCORE = 3, CHECK FROM BEGINNING_^1C_HTO END OF SYMTAB (IF FIRST_^1C_HPAGE IS CURRENT PAGE OR FOR_^1C_HSTATEMENT FUNCTION DUMMY_^1C_HARGUMENTS)._^1C_]_^1C_FNX€€TSLT = NEXT SLOT FOR SYMTAB._^1C_]_^1_$INCORE = 3_^1_$IF (ISYMPC .EQ. 0) GO TO 10_^1_$IF (ISSFLG .NE. 0) GO TO 10_^1_$INCORE = 1_^1_$ISYMX = IFIRST+1_^1_!10 IF (IFIRST .NE. ISYMPC) ISYMX = -ISYMX_^1_$CALL GETSYM_^1_$GO TO (20,15,20), INCORE_^1C_]_^1C_FJUMP IF FINISHED SEARCHING_^1C_HSYMTAB._^1C_]_^1_!15 IF (IFIRST+1 .EQ. ISYMX+ISYMP) GO TO 40_^1_$GO TO 25_^1_!20 IF (ISYMN .EQ. ISYM€€X+ISYMP) GO TO 40_^1_!25 CONTINUE_^1C_]_^1C ********************************** FTN 3.2 ($) **********************_^1C_#COMPARE 'JSYM' TO CURRENT SYMTAB ENTRY._^1_$ASSEM $E400,+ISYMX,$0DFE,$C400,+JSYM(1),$B600,+ISYM,$0102,$1400,_^1C_8BEGIN_4***** FTN 3.1 *****_^1_#1 +30,$0D01,$C400,+JSYM(2),$BEF8,$0101,$1CF9,$C400,+JMODE,$09F9,_^1_#2 $0101,$1C09,$0DFB,$CEEF,$A000,$7E00,$9000,$1600,€€$0102,$1400,_^1_#3 +27,$CEE7,$A027,$0FCB,$6400,+ITHIRD,$0D02,$CEE1,$A011,$BCFB,_^1_#4 $B400,+JSYM(3),$0112,$1400,+29_^1C_8END_6***** FTN 3.1 *****_^1C_#'JSYM' = 'ISYM(ISYMX)'. PERHAPS?_^1C_8BEGIN_4***** FTN 3.1 *****_^1_!27 IF (JSYM(3).EQ.0) GO TO 28_^1C_8END_6***** FTN 3.1 *****_^1_$IF (ITYPE(ISYMX) .EQ. 1 .AND. JSYM(3) .EQ. $2424 .OR._^1_#$ ITYPE(ISYMX) .EQ. 2 .AND. JSYM(3) .EQ.€€ $2525) GO TO 29_^1_$GO TO 30_^1_!28 IF (ICLASS(ISYMX) .EQ. 2) GO TO 30_^1C_#'JSYM' = 'ISYM(ISYMX)'. RETURN UNLESS PROCESSING STATEMENT_^1C_#FUNCTION DUMMY ARGUMENTS._^1_!29 IF(ISSFLG.EQ.0) GO TO 42_^1_$I=ISYMP+ISYMX_^1C_#GET NEXT SYMBOL IN SYMTAB._^1_!30 ISYMX=ISYMP+ISYMX+ISYMFL_^1_$GOTO 10_^1C_#AT CURRENT END OF SYMTAB. JUMP IF DID NOT FIND A MATCH._^1_!40 IF (I.EQ.0) GOTO 50€€_^1C_#SET 'ISYMX' TO MATCHING SYMBOL, GET THAT PAGE IN, RETURN._^1_$ISYMX=I_^1C ********************************** FTN 3.2 **************************_^1_$IF (IFIRST .NE. ISYMPC) ISYMX = -ISYMX_^1_$CALL GETSYM_^1_!42 IF(IOPTC.EQ.0) RETURN_^1_$NREF=ISYMX+ISYMP_^1_$IF(LASTST.EQ.ISTNO) GO TO 43_^1_$CALL WRITE(0,0,1,-ISTNO)_^1_$LASTST=ISTNO_^1_$NSMREF=1_^1_$GO TO 45_^1_!43 DO 44 I=1,NS€€MREF_^1_$IF(ISMREF(I).EQ.NREF) RETURN_^1_!44 CONTINUE_^1_$IF(NSMREF.EQ.100) GO TO 46_^1_$NSMREF=NSMREF+1_^1_!45 ISMREF(NSMREF)=NREF_^1_!46 IF(NREF.NE.ISYMN) CALL WRITE(0,0,1,NREF)_^1_$RETURN_^1C_]_^1C_#AT CURRENT END OF SYMTAB AND NO MATCH. (IF AT ABSOLUTE END OF_^1C_#SYMTAB, ERROR 58 AND 'SKIPIT'.) CLEAR NEXT SYMBOL LOC'N AND RTN._^1C_]_^1_!50 GO TO (52,54,56), INCORE_^1_!52 INCO€€RE = 2_^1_$NXTSLT = ISYMP+ISYMX+ISYMFL_^1_$ISYMX = 1_^1_$GO TO 10_^1_!54 IF (NXTSLT .GT. ISYMS) GO TO 58_^1C_]_^1C_FISYMX SET NEGATIVE AS SYMTAB_^1C_HPAGE INITIALLY IN CORE_^1C_HALREADY WRITTEN TO DISK._^1C_]_^1_$ISYMX = ISYMFL - NXTSLT_^1_$CALL GETSYM_^1_$GO TO 60_^1_!56 IF (ISYMP+ISYMX+ISYMFL .LE. ISYMS) GO TO 60_^1_!58 CALL WRITE(3,1,3,IOVFL)_^1C ********************************€ž** FTN 3.2 ($) **********************_^1_$IXLGO = 0_^1_$CALL SKIPIT_^1_!60 ISYMD=0_^1_$J=ISYMX+ISYMFL-1_^1_$DO 70 I=ISYMX,J_^1_!70_!SYMTAB(I)=0_^1_$END_]_^__žPWGETF1 CSY/ 04A P€1_$SUBROUTINE GETF_^1_#*_2/DECK-ID 04A FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^13_]_^1C INPUT IS FROM 'ISORS' IF BIT 4 OF 'IFLAGS' IS 0, ELSE FROM 'IBUF2'._^1C GETF IS USED IN PHASES A1,A2,A3,A4,A5_^1C_]_^1C_#MASTER LABELED COMMON BLOCK._^1*_] FTN€€ 3.3_^1_$COMMON /A/ IFLAGS,LINECT,LINCT1_^1_$COMMON /A/ IR,IK,IP,IA,IL,IM,IXLGO,IOPTO,IOPTV,IOPTC,IOPTD_^1_$COMMON /A/ MCSTRT,MACRNB,MACSEC_^1_$COMMON /A/ IERRS(16),ISRFAD_^1_$COMMON /A/ LGO,ISCRI,ISCRO,IX_^1*_] FTN 3.3_^1_$COMMON /A/ IGLAB(3),IGLAB1,IGLAB2_^1_$COMMON /A/ ICOMT(12),ICOMTS,ICOMX2,ICOMTL,ISUBP,NDPRS,_^1_#$LABX,IBCDTB(48)_^1_$EQUIVALENCE(ICOMB,ICOMT(1)),(ICOMBX,ICOMT€€(2)),(ICOMDF,_^1_#$ICOMT(3)),(ICOMBN,ICOMT(4))_^1_$DIMENSION ICOMB(6),ICOMBX(6),ICOMDF(6),ICOMBN(7)_^1_$COMMON /A/ LOOPTS,LOOPTX,LOOPTB,LOOPT(50)_^1_$EQUIVALENCE(LINDUC,LOOPT(1))_^1_$DIMENSION LINDUC(10)_^1_$EQUIVALENCE (LBEG,LOOPT(2))_^1_$DIMENSION LBEG(10)_^1_$EQUIVALENCE (LINC,LOOPT(3))_^1_$DIMENSION LINC(10)_^1_$EQUIVALENCE (LEND,LOOPT(4))_^1_$DIMENSION LEND(10)_^1_$BYTE(LLABL,€€LOOPT(5)(14=0)_))_^1_$DIMENSION LLABL(10)_^1_$BYTE(LID,LOOPT(5)(15=15) )_^1_$DIMENSION LID(10)_^1_$COMMON/A/IEQV(255), IEQVS,IEQVN2_^1_$COMMON /A/ ISTAB(150),ISTABS,ISTAB2_^1_$COMMON /A/ IBUFS,ISET(25),LBLANK,KSFCNT,KSNCNT,ISORSC,_^1_#$IHOBIT,ISTNO,ISSFLG,ISUBPN,ITERM,JSORSC,KEQVS_^1C_#SYMBOL TABLE LABELED COMMON BLOCK_^1_$COMMON /A/ ISYMN, ISYMFL,ISYMD,ISYMX,ISYMS,ISYMP,ISYMPC,I€€SYMPS,_^1_#$ ISYMNS, SYMTAB(960)_^1_$INTEGER SYMTAB_^1_$BYTE (IDUM,SYMTAB(1)(15=15)),(KDUMY,SYMTAB(1)(15=15)),_^1_#$(ICLASS,SYMTAB(1)(14=11)),(ITYPE,SYMTAB(1)(10=9))_^1_$DIMENSION IDUM(100),KDUMY(100),ICLASS(100),ITYPE(100)_^1_$BYTE (ISNGL, SYMTAB(1)(8=8)),(KELSIZ,SYMTAB(1)(8=8)),_^1_#$ (ICOM,SYMTAB(1)(7=5)),(IPART,SYMTAB(1)(4=3))_^1_$DIMENSION ISNGL(100),KELSIZ(100),ICOM(100),IPAR€€T(100)_^1_$BYTE (KRFCNT,SYMTAB(1)(2=2)),(IDIM,SYMTAB(1)(1=0)),_^1_#$ (IREL,SYMTAB(1)(1=1)),(IEXT,SYMTAB(1)(0=0))_^1_$DIMENSION KRFCNT(100),IDIM(100),IREL(100),IEXT(100)_^1_$EQUIVALENCE (IRSA,SYMTAB(2)),(ICOMTX,SYMTAB(2)),(ISNOL,SYMTAB(2))_^1_$DIMENSION IRSA(100), ICOMTX(100),ISNOL(100)_^1_$BYTE (IDATAS,SYMTAB(3)(15=15)),(IREF,SYMTAB(3)(15=15)),_^1_#$ (IEQVX,SYMTAB(3)(14=8)),(ITILF,€€SYMTAB(3)(14=8))_^1_$DIMENSION IDATAS(100),IREF(100),IEQVX(100),ITILF(100)_^1_$BYTE (IPARTR,SYMTAB(3)(7=4)),(INDUCV,SYMTAB(3)(7=7)),(ISFARG,_^1_#$ SYMTAB(3)(6=6)),(IARGNO,SYMTAB(3)(5=0)),(IPARTL,SYMTAB(3)(3=0))_^1_$DIMENSION IPARTR(100),INDUCV(100),ISFARG(100),IARGNO(100),_^1_#$ IPARTL(100)_^1_$EQUIVALENCE (ISYM,SYMTAB(4))_^1_$DIMENSION ISYM(100)_^1C_]_^1C_#SPECIFICATION-TABLE INDE€€X LABELLED COMMON BLOCK_^1_$COMMON /A/ ISTABX(96)_^1C_]_^1C_#PHASE A BLANK COMMON BLOCK._^1_$COMMON // JSYM(3),JTERM,JMODE,JERR,JESWT,JFLOT,JCHAR,_^1_#$JOCHAR,JO1,JE,JE1,JBLANK,JCT,JCT1_^1C_#JSYM-JCT1 MUST REMAIN IN ORDER_^1_$COMMON//IERR_^1_$COMMON//ISORS(208),ISORSX_^1_$COMMON//IDEFF,ISTOP,IRET,ISPEC,NERR,OCT_^1_$INTEGER OCT_^1_$COMMON//ILLABL,LEST,ISNGL1,ICOMX1,NXTYPE,LOGIF,IOVF€€L1,IOVFL2_^1_$COMMON//IVCFLG,ISFLG,LOGEX,KEQVX_^1_$COMMON//IBUF2X,IBUF2(304)_^1C_$TEMPORARY ARITHMETIC BUFFERS_^1_$COMMON//IBUF1( 304),IBUF1X,IWORK (304)_^1C_#TEMPORARY EQUIVALENCE BUFFERS_^1_$DIMENSION KEQV(460),MEQV(255)_^1_$EQUIVALENCE (KEQV,IBUF1(66)),(MEQV,IBUF2(100))_^1C_#LS1-ITEM MUST REMAIN IN ORDER_^1_$COMMON//LS1,LPREN,LRELRQ,LRELEN,LSWITC,LO,ITEM_^1_$COMMON//MODE_^1_$COM€€MON//IPHAT(4),IGNSTT(49),IOSPRT(17)_^1C_]_^1C_]_^1C_#ROUTINE TO GET ONE FIELD AND ITS TERMINATOR FROM ISORS_^1C_#(IF BIT 4 OF 'IFLAGS' =1, FROM IBUF2.)_^1C_#UPON EXIT JSYM HAS FIELD_^1C_.JTERM HAS TERMINATOR_^1C_.JMODE IS MODE OF JSYM_^1_$DIMENSION JDUM (16)_^1_$EQUIVALENCE (JDUM(1),JSYM(1))_^1C_8BEGIN_4***** FTN 3.1 *****_^1C_(TEMPORARY DOUBLE PRECISION CONSTANT HOLDER_^1_$DIMENSI€€ON ITEMP(4)_^1C_8END_6***** FTN 3.1 *****_^1C_]_^1C_#INITIALIZE OUTPUT PARAMETERS AND WORKING REGISTERS_^1C_8BEGIN_4***** FTN 3.1 *****_^1C_#EXTENDED ASCII CHARACTER TABLE_^1_$INTEGER ASCIIX(17)_^1_$DATA ASCIIX/$27,$21,$22,$23,$25,$26,$3A,$3B,$3C,$3E,$3F,$40,$5B,_^1_#1_+$5C,$5D,$5E,$5F/_^1_$IOVFLO=0_^1_$ITEMP(1)=0_^1_$ITEMP(2)=0_^1_$ITEMP(3)=0_^1_$ITEMP(4)=0_^1C_8END_6***** FTN 3.1€€ *****_^1_$INERR=NERR_^1_$DO 1 I=1,16,1_^1_"1 JDUM(I)=0_^1_"2 CALL GETC_^1_"3 I=JMODE+1_^1_$IF (JCHAR.LT.10)GO TO 10_^1_$IF(JCHAR-36)11,13,4_^14_#IF(JCHAR.EQ.37) GO TO 12_^1_$IF(JCHAR.EQ.45)GO TO 14_^1_$GO TO (600,403,404,5,600),I_^1C_#=,+,-,(,),,,/,EOS IN NUMERIC MODE_^1_"5 IF(JCHAR.GT.39) GO TO 101_^1C_#+,- IN NUMERIC MODE-NS ON FLOW CHART_^1_$IF(JESWT.NE.2)GO TO 101_^1_$JESWT=3_€€^1_$IF(JCHAR.EQ.39)JESWT=4_^1_$GO TO 2_^1C_#0-9_]_^1_!10 GO TO (200,201,202,203,2),I_^1C_#A-Z_]_^1_!11 GO TO (300,206,202,301,2),I_^1C_#._]_^1_!12 GO TO (400,403,404,402,401),I_^1C_#$_]_^1_!13 IF(JMODE.EQ.4) GO TO 2_^1C_#$ IN INITIAL MODE-IL ON FLOWCHART_^1_$IF(JMODE+OCT.NE.0)GO TO 204_^1_$JMODE=1_^1_$GO TO 2_^1C_#*_]_^1_!14 GO TO (500,403,404,101,500),I_^1C_#* IN MOST MODES-IAT ON€€ FLOWCHART_^1C_#=,+,-,(,),,,/,EOS IN NON-NUMERIC MODE_^1 403 JMODE=3_^1C_#PUT IN $$_^1 405 JSYM(3)=9252_^1_$GO TO 423_^1C ***TERMINATOR IN ALPHA MODE_^1 404 JTERM=JCHAR_^1_$JCHAR=46_^1 414 IF(JOCHAR.EQ.0) GO TO 424_^1_$JOCHAR=JOCHAR-1_^1_$CALL GPUT_^1_$GO TO 414_^1 424 JCHAR=JTERM_^1 423 IF(JCHAR.EQ.45) GO TO 500_^1_$IF(JCHAR.EQ.37)GO TO 401_^1C_#MOST TERMINATORS-IT ON FLOWC€€HART_^1 600 JTERM=JCHAR_^1_$GO TO 1000_^1C_#A-Z IN INITIAL MODE-IA ON FLOWCHART_^1 300 IF(OCT.NE.0)GO TO204_^1_$JMODE=2_^1C_#SET CHARACTER COUNT AND PUT CHARACTER AWAY_^1_$JOCHAR=6_^1_$JESWT=1_^1_$IF(JCHAR.LT.18.OR.JCHAR.GT.23)JESWT=2_^1C_#STATEMENT LABEL_^1 211 JOCHAR=JOCHAR-1_^1 310 CALL GPUT_^1_$GO TO 2_^1C_#** TERMINATOR_^1 501 JTERM=JTERM*256+JCHAR_^1_$GO TO 1000_^1C_#0-9€€_"IN INITIAL MODE-IN ON FLOWCHART_^1 200 JMODE=3_^1_$IF(JCHAR.GT.7) GO TO 220_^1_$IF(OCT.NE.0) GO TO 210_^1C_] FTN 3.3_^1_$IF(JCHAR.GT.2) GO TO 230_^1_$ITEMP(4)=JCHAR_^1_$IHOL=JCHAR_^1_$CALL GETC_^1_$IF(JCHAR.NE.17.AND.JCHAR.NE.27) GO TO 3_^1_$JSYM(2)=0_^1_$IF(JCHAR.EQ.17) JSYM(2)=$20_^1_$KHOL=JCHAR_^1_$JBLANK=1_^1_$DO 1500 I=1,IHOL_^1_$CALL GETC_^1_$IF(JCHAR-47) 1501,1502,1503_^€€1C_#HERE IF NORMAL CHARACTER_^1 1501 JSYM(I)=IBCDTB(JCHAR+1)_^1_$GO TO 1500_^1C_#HERE IF EOS ENCOUNTERED AND FIELD NOT COMPLETED_^1 1502 JSYM(I)=$20_^1_$IF(I.EQ.1.AND.IHOL.EQ.2) JSYM(2)=$20_^1_$ISORSX=ISORSX-1_^1_$GO TO 1505_^1C_#HERE IF CHARACTER FORM EXTENDED ASCII SET_^1 1503 JSYM(I)=ASCIIX(JCHAR-47)_^1 1500 CONTINUE_^1 1505 JBLANK=0_^1_$IF(KHOL.EQ.17.OR.IHOL.EQ.2) GO TO 1510_^1€€_$JSYM(3)=JSYM(1)_^1_$JSYM(1)=JSYM(2)_^1_$JSYM(2)=JSYM(3)_^1 1510 JSYM(1)=JSYM(1)*$100+JSYM(2)_^1_$CALL GETC_^1_$GO TO 112_^1C_] FTN 3.3_^1C_8BEGIN_4***** FTN 3.1 *****_^1C_(NUMBER WILL BE BUILT IN ITEMP(1) - ITEMP(4)_^1 230 ITEMP(4)=JCHAR_^1C_8END_6***** FTN 3.1 *****_^1_$GO TO 2_^1C_#OCTAL CONSTANT ONLY IS ALLOWED_^1 210 JOCHAR=4_^1_$JSYM(1)=JCHAR_^1_$GO TO 2_^1220_!IF(OCT.EQ.€€0) GO TO 230_^1C_#ERROR_^1 204 IF(NERR.NE.0)GO TO 214_^1_$CALL DIAG (1)_^1C_#SET ERROR INDICATORS AND CLEAR HOLDER_^1224_!NERR=1_^1 214 JSYM(1)=0_^1_$JERR=1_^1 234 JMODE=4_^1_$GO TO 2_^1C_#A-Z IN HEXADECIMAL MODE-GH ON FLOW_^1 206 IF(JCHAR.GT.15) GO TO 204_^1C_(0-F IN HEXADECIMAL MODE-GL ON FLOW_#*** PSR62*1252 ***_^1 201 IF (JSYM(1).GT.4095.OR.JSYM(1).LT.0) GO TO 213_^1C_O***€€_#END_"***_^1_$JSYM(1)=16*JSYM(1)_^1_$JSYM(1)=OR(JSYM(1),JCHAR)_^1_$GO TO 2_^1C_#A-Z IN ALPHA MODE-GA ON FLOWCHART_^1 202 IF(JOCHAR.NE.0)GO TO 211_^1_$IF(NERR.EQ.0)CALL DIAG(8195)_^1_$GO TO 234_^1C_#. IN INITIAL MODE_^1 400 CALL GETC_^1_$IF(JCHAR-10)410,420,430_^1C_#LOOK FOR A LEGAL ALPHABETIC FOR LOGICAL TERMINATOR-A HAS BEEN FOUN_^1C_#T OR F WOULD BE LEAGAL FOR .TRUE. OR .FALSE€€. ONLY IF WE HAD LOGICA_^1C_#E_]_^1 430 IF(JCHAR.EQ.14)GO TO 440_^1C_#G_]_^1_$IF(JCHAR.EQ.16)GO TO 450_^1C_#L_]_^1_$IF (JCHAR.EQ.21)GO TO 450_^1C_#N_]_^1_$IF (JCHAR.EQ.23)GO TO 470_^1C_#O_]_^1_$IF (JCHAR.EQ.24) GO TO 480_^1C_#ERROR-IPA ON FLOWCHART_^1 490 IF (NERR.NE.0)GO TO 491_^1_$CALL DIAG (1)_^1_$NERR=1_^1 491 JMODE=4_^1_$JERR=1_^1_$GO TO 3_^1 440 JTERM=JCHAR*256_^1_$I=26_]€€_^1 482 CALL GETC_^1 481 IF(JCHAR.NE.I)GO TO 490_^1 460 JTERM=JTERM+JCHAR_^1_$CALL GETC_^1_$IF(JCHAR-37)490,1000,490_^1 450 JTERM=JCHAR*256_^1_$CALL GETC_^1_$IF(JCHAR.EQ.14)GO TO 460_^1 452 I=29_]_^1_$GO TO 481_^1 470 JTERM=JCHAR*256_^1_$CALL GETC_^1_$IF(JCHAR.EQ.14)GO TO 460_^1_$IF (JCHAR.NE.24)GO TO 490_^1_$CALL GETC_^1_$GO TO 452_^1 480 JTERM=JCHAR*256_^1C_#.OR_]_^1_$I=27€€_]_^1_$GO TO 482_^1C_#. IN ALPHA,HEXADECIMAL,NUMERIC MODE-PT ON FLOW_^1 401 CALL GETC_^1_$IF(JCHAR.NE.10) GO TO 430_^1C_#A_]_^1 420 JTERM=JCHAR*256_^1_$CALL GETC_^1_$IF(JCHAR.NE.23)GO TO 490_^1_$I=13_]_^1_$GO TO 482_^1C_#0-9 IN NUMERIC MODE-GN ON FLOWCHART_^1 203 IF(OCT.EQ.0)GO TO 223_^1_$IF(JOCHAR.EQ.0)GO TO 213_^1_$IF(JCHAR.GT.7)GO TO 204_^1_$JSYM(1)=8*JSYM(1)+JCHAR_^1_$JOCHAR€€=JOCHAR-1_^1_$GO TO 2_^1 213 IF(NERR.NE.0)GO TO 214_^1_$CALL DIAG (4)_^1_$GO TO 224_^1 410 IF (OCT.NE.0) GO TO 204_^1_$JMODE=3_^1 412 JESWT=1_^1C_8BEGIN_4***** FTN 3.1 *****_^1_$IF (JFLOT.EQ.3) GO TO 223_^1C_8END_6***** FTN 3.1 *****_^1_$JFLOT=2_^1223_!IF(JESWT.GT.1)GO TO 233_^1_$IF(JO1.NE.0)GO TO 293_^1C_#******MACHINE DEPENDENT PORTION ******_^1C_8BEGIN_4***** FTN 3.1 *****_^1€€_$ITEMP(4)=(ITEMP(4)*10)+JCHAR_^1_$ITEMP(3)=(ITEMP(3)*10)+AND((AND(ITEMP(4),$F000)/$1000),$F)_^1C_!WHEN ACCURACY EXCEEDS 2**15-1 SET INTEGER OVERFLOW FLAG_^1_$IF (ITEMP(3).GT.7) IOVFLO=1_^1_$ITEMP(2)=(ITEMP(2)*10)+AND((AND(ITEMP(3),$F000)/$1000),$F)_^1_$ITEMP(1)=(ITEMP(1)*10)+AND((AND(ITEMP(2),$F000)/$1000),$F)_^1_$ITEMP(4)=AND(ITEMP(4),$FFF)_^1_$ITEMP(3)=AND(ITEMP(3),$FFF)_^1_$ITE€€MP(2)=AND(ITEMP(2),$FFF)_^1_$IF (ITEMP(1).GT.$F) JO1=1_^1C ************************************************************_!84*2503_^1C_!WHEN ACCURACY EXCEEDS 2**39-1 SET COUNT EXPONENT FLAG_^1C ****************** 2 CARDS DELETED_"**********************_!84*2503_^1C_8END_6***** FTN 3.1 *****_^1C_#********_^1263_!IF(JESWT.EQ.1)JE=JE-1_^1_$GO TO 2_^1C_#******_8OVERFLOW TEST******_^1 2€€33 IF(JE1.LT.3276.OR.(JE1.EQ.3276.AND.JCHAR.LT.8))JE1=JE1*10+JCHAR_^1_$IF(JESWT-4)243,253,2_^1 243 JESWT=5_^1_$GO TO 2_^1 253 JESWT=6_^1_$GO TO 2_^1 293 IF(JESWT.EQ.0)JE=JE+1_^1_$GO TO 2_^1C_#. IN NUMERIC MODE-NP ON FLOWCHART_^1 402 IF(JESWT+OCT.NE.0)GO TO 101_^1_$I=ISORSX_^1_$IF (AND(IFLAGS,16).NE.0) I=IBUF2X_^1_$CALL GETC_^1_$IF(JCHAR.LT.10)GO TO 412_^1_$IF(JCHAR.GT.36)GO TO €€422_^1C_8BEGIN_4***** FTN 3.1 *****_^1_$IF(JCHAR.NE.13)GO TO 441_^1_$JESWT=2_^1_$JFLOT=3_^1_$GO TO 2_^1 441 IF(JCHAR.NE.14)GO TO 442_^1C_8END_6***** FTN 3.1 *****_^1_$CALL GETC_^1_$IF(JCHAR.EQ.26)GO TO 442_^1_$JESWT=2_^1_$JFLOT=2_^1_$GO TO 3_^1 442 IF (AND(IFLAGS,16).NE.0) GOTO 900_^1_$ISORSX=I_^1_$GOTO 901_^1 900 IBUF2X=I_^1 901 JCHAR=37_^1_$GO TO 101_^1 422 JESWT=1_^1C_8BEGI€€N_4***** FTN 3.1 *****_^1_$IF (JFLOT.NE.3) JFLOT=2_^1C_8END_6***** FTN 3.1 *****_^1C_#TERMINATOR IN NUMERIC MODE-NT ON FLOW CHART_^1101_!IF(OCT.NE.0) GO TO 112_^1C_8BEGIN_4***** FTN 3.1 *****_^1C JESWT = 0 MEANS WE HAVE AN INTEGER CONSTANT_^1_$IF (JESWT.NE.0) GO TO 121_^1C_8END_6***** FTN 3.1 *****_^1C_#OVERFLOW TEST_^1C_8BEGIN_4***** FTN 3.1 *****_^1_$IF(IOVFLO.EQ.1) GO TO 131_^1€€C_8END_6***** FTN 3.1 *****_^1C**********MACHINE DEPENDENT************_^1C_#SHIFT MOST SIGNIFICANT PART AND ADD IN LEAST SIGNIFICANT_^1C_8BEGIN_4***** FTN 3.1 *****_^1_$JSYM(1)=ITEMP(3)*$1000+ITEMP(4)_^1C_8END_6***** FTN 3.1 *****_^1112_!JSYM(2)=0_^1_$GO TO 405_^1 121 IF(JESWT.GT.1.AND.JESWT.LT.5)GO TO 141_^1C_#NEG EXPONENT_^1_$IF(JESWT.EQ.6)JE1=-JE1_^1C(********************FLOAT €€JSYM************_^1 151 JE=JE1+JE_^1C ************************************************************_!89*2933_^1C_#ZERO INTEGER COEFFICIENT IS ZERO CONSTANT_^1_'JSYM(1) = ITEMP(1)+ITEMP(2)+ITEMP(3)+ITEMP(4)_^1_'IF (JSYM(1).NE.0) GO TO 155_^1C_%CLEAR EXPONENT FOR LATER ERROR CHECK_^1_'JE = 0_^1_'GO TO 160_^1 155 CALL DXP9(ITEMP(1),JE)_^1C_%STORE NORMALIZED FLOATING POINT CONSTANT IN€€TO ARRAY JSYM_^1 160 JSYM(1)=ITEMP(1)_^1C ************************************************************_!89*2933_^1_$JSYM(2)=ITEMP(2)_^1_$JSYM(3)=ITEMP(3)_^1C_8END_6***** FTN 3.1 *****_^1_$IF(JE.EQ.0.OR.NERR.NE.0) GO TO 191_^1_$IF(JSYM(1).EQ.0) GO TO 1310_^1_$CALL DIAG (8196)_^1_$GO TO 191_^1 1310 CALL DIAG(8194)_^1C_8BEGIN_4***** FTN 3.1 *****_^1 191 IF (JFLOT.EQ.3) GO TO 192_^1C€€_(JMODE = 5 FOR REAL CONSTANT_^1_$JMODE=5_^1C_8END_6***** FTN 3.1 *****_^1_$JSYM(3)=9509_^1C_#GO TEST TERMINATOR_^1_$GO TO 423_^1C_8BEGIN_4***** FTN 3.1 *****_^1C_(JMODE = 6 FOR DOUBLE PRECISION CONSTANT_^1 192 JMODE=6_^1_$GO TO 423_^1C_8END_6***** FTN 3.1 *****_^1 131 JSYM(1)=32767_^1_$IF(NERR.EQ.0)CALL DIAG(8196)_^1_$GO TO 112_^1 141 IF(NERR.EQ.0) CALL DIAG (8197)_^1_$GO TO 15€€1_^1C_#A-Z IN NUMERIC MODE-NA ON FLOW CHART_^1C_8BEGIN_4***** FTN 3.1 *****_^1 301 IF (JCHAR.NE.14) GOTO 302_^1C_8END_6***** FTN 3.1 *****_^1_$JFLOT=2_^1_$JESWT=2_^1_$GO TO 2_^1C_8BEGIN_4***** FTN 3.1 *****_^1 302 IF (JCHAR.NE.13) GOTO 204_^1_$JFLOT=3_^1_$JESWT=2_^1_$GOTO 2_^1C_8END_6***** FTN 3.1 *****_^1 500 JTERM=JCHAR_^1_$I=ISORSX_^1_$IF (AND(IFLAGS,16).NE.0) I=IBUF2X_^1_$CA€€LL GETC_^1_$IF(JCHAR.EQ.45)GO TO 501_^1_$IF (AND(IFLAGS,16).NE.0) GOTO 902_^1_$ISORSX=I_^1_$GOTO 1000_^1 902 IBUF2X=I_^1 1000 OCT=0_^1_$IF (JERR+INERR.EQ.0.AND.JMODE.NE.0) GO TO 9001_^1 9000 IF (JMODE.EQ.4.AND.JERR.EQ.0) JMODE=2_^1_$IF(JERR.NE.0)JMODE =4_^1_$NERR=0_^1_$RETURN_^1C_8BEGIN_4***** FTN 3.1 *****_^1 9001 IF (JMODE.EQ.6.AND.JFLOT.EQ.3) GO TO 9002_^1_$IF (JSYM(3).NE.9509.€nAND.JSYM(3).NE.9252) CALL CNVT_^1 9002 CALL SYMBOL_^1C_8END_6***** FTN 3.1 *****_^1_$GO TO 9000_^1_$END_]_^__ nPWGNST CSY/ 05A P€1_$SUBROUTINE GNST_^1_#*_2/DECK-ID 05A FORTRAN 3.3B_)SUMMARY-102_^1*_#READ NEXT STATEMENT FROM STANDARD INPUT DEVICE, CONVERT IT_^1*_#TO INTERNAL CODE AND STORE IN 'ISORS'_^1*_#1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_#SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_#COPYRIGHT, CONTROL DATA CORPORATION - 1975_^13_]_^1C_#MASTER LABELED COMMON BLOCK._^1*_] FTN 3.3_^1_$C€€OMMON /A/ IFLAGS,LINECT,LINCT1_^1_$COMMON /A/ IR,IK,IP,IA,IL,IM,IXLGO,IOPTO,IOPTV,IOPTC,IOPTD_^1_$COMMON /A/ MCSTRT,MACRNB,MACSEC_^1_$COMMON /A/ IERRS(16),ISRFAD_^1_$COMMON /A/ LGO,ISCRI,ISCRO,IX_^1*_] FTN 3.3_^1_$COMMON /A/ IGLAB(3),IGLAB1,IGLAB2_^1_$COMMON /A/ ICOMT(12),ICOMTS,ICOMX2,ICOMTL,ISUBP,NDPRS,_^1_#$LABX,IBCDTB(48)_^1_$EQUIVALENCE(ICOMB,ICOMT(1)),(ICOMBX,ICOMT(2)),(ICOM€€DF,_^1_#$ICOMT(3)),(ICOMBN,ICOMT(4))_^1_$DIMENSION ICOMB(6),ICOMBX(6),ICOMDF(6),ICOMBN(7)_^1_$COMMON /A/ LOOPTS,LOOPTX,LOOPTB,LOOPT(50)_^1_$EQUIVALENCE(LINDUC,LOOPT(1))_^1_$DIMENSION LINDUC(10)_^1_$EQUIVALENCE (LBEG,LOOPT(2))_^1_$DIMENSION LBEG(10)_^1_$EQUIVALENCE (LINC,LOOPT(3))_^1_$DIMENSION LINC(10)_^1_$EQUIVALENCE (LEND,LOOPT(4))_^1_$DIMENSION LEND(10)_^1_$BYTE(LLABL,LOOPT(5)(1€€4=0)_))_^1_$DIMENSION LLABL(10)_^1_$BYTE(LID,LOOPT(5)(15=15) )_^1_$DIMENSION LID(10)_^1_$COMMON/A/IEQV(255), IEQVS,IEQVN2_^1_$COMMON /A/ ISTAB(150),ISTABS,ISTAB2_^1_$COMMON /A/ IBUFS,ISET(25),LBLANK,KSFCNT,KSNCNT,ISORSC,_^1_#$IHOBIT,ISTNO,ISSFLG,ISUBPN,ITERM,JSORSC,KEQVS_^1C_#SYMBOL TABLE LABELED COMMON BLOCK_^1_$COMMON /A/ ISYMN, ISYMFL,ISYMD,ISYMX,ISYMS,ISYMP,ISYMPC,ISYMPS,_^1_€€#$ ISYMNS, SYMTAB(960)_^1_$INTEGER SYMTAB_^1_$BYTE (IDUM,SYMTAB(1)(15=15)),(KDUMY,SYMTAB(1)(15=15)),_^1_#$(ICLASS,SYMTAB(1)(14=11)),(ITYPE,SYMTAB(1)(10=9))_^1_$DIMENSION IDUM(100),KDUMY(100),ICLASS(100),ITYPE(100)_^1_$BYTE (ISNGL, SYMTAB(1)(8=8)),(KELSIZ,SYMTAB(1)(8=8)),_^1_#$ (ICOM,SYMTAB(1)(7=5)),(IPART,SYMTAB(1)(4=3))_^1_$DIMENSION ISNGL(100),KELSIZ(100),ICOM(100),IPART(100)_^1_€€$BYTE (KRFCNT,SYMTAB(1)(2=2)),(IDIM,SYMTAB(1)(1=0)),_^1_#$ (IREL,SYMTAB(1)(1=1)),(IEXT,SYMTAB(1)(0=0))_^1_$DIMENSION KRFCNT(100),IDIM(100),IREL(100),IEXT(100)_^1_$EQUIVALENCE (IRSA,SYMTAB(2)),(ICOMTX,SYMTAB(2)),(ISNOL,SYMTAB(2))_^1_$DIMENSION IRSA(100), ICOMTX(100),ISNOL(100)_^1_$BYTE (IDATAS,SYMTAB(3)(15=15)),(IREF,SYMTAB(3)(15=15)),_^1_#$ (IEQVX,SYMTAB(3)(14=8)),(ITILF,SYMTAB(3)(€€14=8))_^1_$DIMENSION IDATAS(100),IREF(100),IEQVX(100),ITILF(100)_^1_$BYTE (IPARTR,SYMTAB(3)(7=4)),(INDUCV,SYMTAB(3)(7=7)),(ISFARG,_^1_#$ SYMTAB(3)(6=6)),(IARGNO,SYMTAB(3)(5=0)),(IPARTL,SYMTAB(3)(3=0))_^1_$DIMENSION IPARTR(100),INDUCV(100),ISFARG(100),IARGNO(100),_^1_#$ IPARTL(100)_^1_$EQUIVALENCE (ISYM,SYMTAB(4))_^1_$DIMENSION ISYM(100)_^1C_]_^1C_#SPECIFICATION-TABLE INDEX LABELLED€€ COMMON BLOCK_^1_$COMMON /A/ ISTABX(96)_^1C_]_^1C_#PHASE A BLANK COMMON BLOCK._^1_$COMMON // JSYM(3),JTERM,JMODE,JERR,JESWT,JFLOT,JCHAR,_^1_#$JOCHAR,JO1,JE,JE1,JBLANK,JCT,JCT1_^1C_#JSYM-JCT1 MUST REMAIN IN ORDER_^1_$COMMON//IERR_^1_$COMMON//ISORS(208),ISORSX_^1_$COMMON//IDEFF,ISTOP,IRET,ISPEC,NERR,OCT_^1_$INTEGER OCT_^1_$COMMON//ILLABL,LEST,ISNGL1,ICOMX1,NXTYPE,LOGIF,IOVFL1,IOVFL2_€€^1_$COMMON//IVCFLG,ISFLG,LOGEX,KEQVX_^1_$COMMON//IBUF2X,IBUF2(304)_^1C_$TEMPORARY ARITHMETIC BUFFERS_^1_$COMMON//IBUF1( 304),IBUF1X,IWORK (304)_^1C_#TEMPORARY EQUIVALENCE BUFFERS_^1_$DIMENSION KEQV(460),MEQV(255)_^1_$EQUIVALENCE (KEQV,IBUF1(66)),(MEQV,IBUF2(100))_^1C_#LS1-ITEM MUST REMAIN IN ORDER_^1_$COMMON//LS1,LPREN,LRELRQ,LRELEN,LSWITC,LO,ITEM_^1_$COMMON//MODE_^1C_]_^1C STORAGE€€ FOR LOCAL VARIABLES OF ROUTINES TO BE OVERLAID..._^1_$COMMON IPHAT(4),IHEAD(48),LENSAV,IOSPRT(17)_^1_$DIMENSION ISRS(41)_^1_$EQUIVALENCE (IHEAD(8),ISRS)_^1C_]_^1_$DIMENSION IENDBF(3)_^1_$DATA IENDBF(1),IENDBF(2),IENDBF(3) /$45,$4E,$44/_^1C_8BEGIN_4***** FTN 3.1 *****_^1C EXTENDED ASCII CHARACTER TABLE_^1C_#********BEGIN********** FTN 3.2 *********************************_^1C_#EXTE€€NDED ASCII CHARACTER TABLE_^1_$INTEGER ASCIIX(17)_^1C_#DATA ASCIIX/ '_!!_!"_!#_!%_!%_!:_!;_!<_!>_!?_!@_![_^1_$DATA ASCIIX/$27,$21,$22,$23,$25,$26,$3A,$3B,$3C,$3E,$3F,$40,$5B_^1_#1,$5C,$5D,$5E,$5F/_^1C_"1, \_!]_!^_!_ /_^1C_#*********************** FTN 3.2 ******END************************_^1C_8END_6***** FTN 3.1 *****_^1C_YBEGIN FTN 3.3_^1_$INTEGER FC(8)_^1_$DATA FC/' C * $ . + O €€M '/_^12_]_^1_$INTEGER W(89)_^12_]_^1_$DATA (W(I),I=01,07)_^1_#+/$50,$52,$4F,$47,$52,$41,$4D/_^1C_'P_!R_!O_!G_!R A_"M_^12_]_^1_$DATA (W(I),I=08,17)_^1_#+/$53,$55,$42,$52,$4F,$55,$54,$49,$4E,$45/_^1C_'S_!U_!B_!R_!O_!U_!T_!I_!N_!E_^12_]_^1_$DATA (W(I),I=18,25)_^1_#+/$46,$55,$4E,$43,$54,$49,$4F,$4E/_^1C_'F_!U_!N_!C_!T_!I_!O_!N_^12_]_^1_$DATA (W(I),I=26,37)_^1_#+/$52,$45,$41,$4C,$46,$€€55,$4E,$43,$54,$49,$4F,$4E/_^1C_'R_!E_!A_!L_!F_!U_!N_!C_!T_!I_!O_!N_^12_]_^1_$DATA (W(I),I=38,52)_^1_#+/$49,$4E,$54,$45,$47,$45,$52,$46,$55,$4E,$43,$54,$49,$4F,$4E/_^1C_'I_!N_!T_!E_!G_!E_!R_!F_!U_!N_!C_!T_!I_!O_!N_^12_]_^1_$DATA (W(I),I=53,61)_^1_#+/$42,$4C,$4F,$43,$4B,$44,$41,$54,$41/_^1C_'B_!L_!O_!C_!K_!D_!A_!T_!A_^12_]_^1_$DATA (W(I),I=62,66)_^1_#+/$4D,$41,$43,$52,$4F/_^1C_'M_!A€€_!C_!R_!O_^1_$DATA (W(I),I=67,89)_^1_#*/1RD,1RO,1RU,1RB,1RL,1RE,1RP,1RR,1RE,1RC,1RI,1RS,1RI,1RO,1RN,_^1_#* 1RF,1RU,1RN,1RC,1RT,1RI,1RO,1RN/_^12_]_^1_$INTEGER QN(3)_^1_$DATA QN/'Q8QNAM'/_^12_]_^1_$INTEGER QB(3)_^1_$DATA QB/'Q8QBDS'/_^12_]_^1_$DATA MODMAC/1/_^1*_#MODMAC = 1 IF NORMAL PROCESSING_^1*_-2 IF LOADING A MACRO_^1*_-3 IF READING BACK A MACRO_^1*_-4 IF END OF MACRO LOADING_^1€€2_]_^1_$INTEGER Z(9)_^1_$DATA Z/1,8,18,26,38,53,62,67,90/_^12_]_^1_$INTEGER Q(6)_^1C_[END FTN 3.3_^1._]_^1C_]_^1C THE BASIC PROCEDURE IS TO READ STATEMENTS INTO THE INTERMEDIATE_^1C BUFFER 'ISRS' AND TRANSFER THEM TO THE MAIN STATEMENT BUFFER 'ISORS'._^1C IN 'ISRS', BLANK STATEMENTS ARE IGNORED AND COMMENTS ARE PRINTED AND_^1C IGNORED. CONTINUATION LINES ARE TRANSFERRED THROUGH 'I€€SRS' UNTIL AN_^1C INITIAL LINE APPEARS...THEN THE CONTENTS OF 'ISRS' ARE HELD UNTIL THE_^1C NEXT CALL TO 'GNST'. IN GENERAL, AT ENTRY TO 'GNST' THERE IS_^1C GARBAGE IN 'ISORS' AND THE FIRST LINE OF THE NEXT STATEMENT IN 'ISRS'._^1C_]_^1C INITIALIZE STATEMENT BUFFER INDEX, CONTINUATION CARD COUNTER, AND_^1C ERROR FLAGS._^15_]_^1 100 ISORSX=1_^1_$ITALLY=0_^1_$IERR47=0_^1_$IERR35=0_€€^1*_YBEGIN FTN 3.3_^1_$IER115=0_^1*_[END FTN 3.3_^1C_]_^1C JUMP IF THIS IS THE FIRST CARD OF THE PROGRAM. 'LENSAV' CONTAINS THE_^1C LENGTH OF THE LAST LINE PUT INTO 'ISRS'...THIS IS INITIALLY ZERO._^1 200 IF (LENSAV.EQ.0) GOTO 800_^1_$LENGTH=LENSAV_^1C_]_^1C PRINT THE INTERMEDIATE BUFFER CONTENTS, IN 'STATEMENT' FORMAT._^1 300 ASSIGN 400 TO JUMP_^1 310 IF (IL.EQ.0) GOTO JUMP_^1€€C CONVERT CURRENT STATEMENT NUMBER AND PACK INTO 'IHEAD'._^1_$CALL CONV (ISTNO,IHEAD(2))_^1_$CALL PACK (IHEAD(2),6)_^1C JUMP IF STANDARD LIST OUTPUT DEVICE IS PT PUNCH OR TTY._^1_$IF (AND(IFLAGS,1).EQ.0) GOTO 330_^1C_#********BEGIN********** FTN 3.2 *********************************_^1_$IHEAD(5) = $2020_^1_$IHEAD(6) = $2020_^1_$IHEAD(7) = $2020_^1C_#*********************** FTN 3.2 €€******END************************_^1_$CALL WRITE (3,1,47,IHEAD)_^1_$GOTO JUMP_^1 330 CALL WRITE (3,1,4,IHEAD)_^1_$CALL WRITE (3,1,LENGTH,ISRS)_^1_$GOTO JUMP_^1C_]_^1C JUMP IF ERROR FLAG 'IERR35' IS SET._^1 400 IF (IERR35.NE.0) GOTO 1800_^1C_]_^1C MOVE A LINE FROM INTERMEDIATE BUFFER TO MAIN ONE. MOVE COLS 1-72 SO_^1C AS TO BLANK OUT 'ISORS' IN CASE THIS STATEMENT HAS CONTINUATIO€€NS._^1C RECORD LENGTH OF NON-BLANK DATA MOVED, IN 'LENSAV'._^1 500 DO 600 I=1,36_^1 600_!ISORS(I)=ISRS(I)_^1_$LENSAV=LENGTH_^1C_]_^1C JUMP IF 'ISRS' CONTAINS AN 'END' CARD._^1 700 J=1_]_^1_$L=2*LENGTH_^1_$DO 710 I=7,L_^1_'K=IGETCF(ISRS,I)_^1_'IF (K.EQ.$20) GOTO 710_^1*_YBEGIN FTN 3.3_^1_$IF(K.NE.IENDBF(J))GO TO 715_^1*_[END FTN 3.3_^1_'J=J+1_^1 710_!CONTINUE_^1*_YBEGIN FTN 3.3_€€^1_$IF(J.NE.4)GO TO 715_^1C_]_^1C HERE IF END CARD._^1C_]_^1_$GO TO (711,712,711),MODMAC_^1 711 IF(LENSAV.EQ.0) GO TO 3500_^1_$GO TO 1400_^1C_]_^1C HERE IF END OF MACRO LOADING._^1C_]_^1 712 MODMAC=4_^1_$IF(MAGO.EQ.2) GO TO 2000_^1_$IF(IBUF2X.EQ.1) GO TO 713_^1_$CALL WRITE(18,MACSEC,96,IBUF2)_^1_$MACSEC=MACSEC+1_^1 713 CALL WRITE(18,0,96,IBUF1)_^1_$GO TO 2000_^1C_]_^1C HERE I€€F NOT END CARD._^1C_]_^1 715 GO TO (810,1001,810),MODMAC_^1*_[END FTN 3.3_^1C_]_^1C JUMP IF THIS IS A STACKED COMPILATION...'GOA' HAS ALREADY FILLED_^1C 'ISRS', LOOKING FOR A 'MON' CARD._^1 800 IF (AND(IFLAGS,2).NE.0) GOTO 1000_^1C_]_^1C REFILL THE INTERMEDIATE STATEMENT BUFFER._^1*_YBEGIN FTN 3.3_^1 810 CONTINUE_^1 900 GO TO (902,902,1170),MODMAC_^1 902 CALL READ(1,1,41,ISRS)€€_^1_$GO TO 1000_^1*_[END FTN 3.3_^1C_]_^1C SCAN INTERMEDIATE STATEMENT BUFFER FROM RIGHT TO LEFT, CHANGING ANY_^1C $FF'S (FROM THE PAPER TAPE OR MAG TAPE DRIVERS) TO BLANKS AND NOTING,_^1C IN 'LENGTH', THE INDEX OF THE RIGHTMOST NONBLANK WORD._^1*_YBEGIN FTN 3.3_^1 1001 IF(MAGO.EQ.2) GO TO 2000_^1_$DO 1002 I=1,40_^1_$IBUF2(IBUF2X)=ISRS(I)_^1_$IBUF2X=IBUF2X+1_^1 1002 CONTINUE_^1_$IB€€UF1(NBMC+3)=IBUF1(NBMC+3)+$100_^1_$IF(IBUF2X.EQ.41)GO TO 2000_^1_$CALL WRITE(18,MACSEC,96,IBUF2)_^1_$MACSEC=MACSEC+1_^1_$IBUF2X=1_^1_$GO TO 2000_^1 1000 LENGTH=0_^1*_[END FTN 3.3_^1_$DO 1020 I=72,1,-1_^1_'J=IGETCF(ISRS,I)_^1_'IF (J.NE.$FF) GOTO 1010_^1_'CALL STCHAR (ISRS,I,$20)_^1_'J=$20_^1 1010_!IF (LENGTH.NE.0) GOTO 1020_^1_'IF (J.NE.$20) LENGTH=(I+1)/2_^1 1020_!CONTINUE_^1C IGNO€€RE BLANK LINES._^1_$IF (LENGTH.EQ.0) GOTO 900_^1C_]_^1C_YBEGIN FTN 3.3_^1_$GO TO (1111,700,1110),MODMAC_^1 1110 IHEAD(1)=$204D_^1_$GO TO 1100_^1 1111 IHEAD(1)=$2020_^1C_#CHECK FIRST COLUMN_^1 1100 J=AND(ISRS(1),$FF00)_^1_$DO 1101 I=1,8_^1_$IF(AND(EOR(J,FC(I)),$FF00).EQ.0) GO TO 1102_^1 1101 CONTINUE_^1_$IF(J.LT.$3000.OR.J.GT.$3900) GO TO 1190_^1 1102 GO TO (1190,2000,2000,2000,1130€€,1140,1150,1160,1180),I_^1C_*BLANK C_"*_"$_"._"+_"O_"M_!NUM_^1C_#HERE IF '.' (PAGE EJECT)_^1 1130 LINCT1=0_^1_$GO TO 900_^1C_#HERE IF '+' (OVER PRINTED COMMENT CARD)_^1 1140 IHEAD(1)=$2B20_^1_$LINCT1=LINCT1+1_^1_$GO TO 2000_^1C_#HERE IF 'O' (COMPILE IF OPTION 'O' ONLY)_^1 1150 IF(IOPTO.EQ.0) GO TO 2000_^1_$CALL STCHAR(ISRS,1,$20)_^1_$IHEAD(1)=2H O_^1_$GO TO 1190_^1C_#HERE IF 'M' (€€MACRO CALL)_^1 1160 IF(MODMAC.EQ.1)GO TO 11610_^1_$IER115=2_^1_$GO TO 2000_^111610 L=MACRNB_^1C JUMP IF NO MACRO DEFINED_^1_$IF(L.LE.0)GO TO 1166_^1_$DO 1161 I=1,6_^1_$Q(I)=$20_^1 1161 CONTINUE_^1C GET NAME OF CALLED MACRO_^1_$I=1_]_^1_$DO 1162 J=2,72_^1_$K=IGETCF(ISRS,J)_^1_$IF(K.EQ.$20)GO TO 1162_^1_$Q(I)=K_^1_$IF(I.EQ.6)GO TO 1163_^1_$I=I+1_^1 1162 CONTINUE_^1 1163 CALL PACK(Q€€,6)_^1_$DO 1164 J=1,3_^1_$JSYM(J)=Q(J)_^1 1164 CONTINUE_^1_$CALL CNVT_^1C GET TABLE OF ALREADY DEFINED MACROS,IN IBUF2._^1_$CALL READ(18,0,96,IBUF2)_^1_$J=L*3_^1C SEARCH IT FOR THE CALLED MACRO._^1_$DO 1165 I=1,J,3_^1_$IF(IBUF2(I).EQ.JSYM(1).AND.IBUF2(I+1).EQ.JSYM(2))GO TO 1167_^1 1165 CONTINUE_^1C MACRO NOT DEFINED,ERROR NO.115_^1 1166 IER115=1_^1_$GO TO 2000_^1C MACRO NAME FOUND.€€_^1 1167 MACS=AND(IBUF2(I+2),$FF)_^1_$NBMAC=AND(IBUF2(I+2),$FF00)/$100_^1_$MODMAC=3_^1_$NOMAC=1_^1_$GO TO 2000_^1C READ-FROM-MACRO MAIN LOOP_^1 1170 IF(NOMAC.LE.NBMAC)GO TO 1171_^1_$MODMAC=1_^1_$GO TO 902_^1 1171 CALL READ(18,MACS,96,IBUF2)_^1_$J=(1-AND(NOMAC,1))*40_^1_$DO 1172 I=1,40_^1_$K=I+J_^1_$ISRS(I)=IBUF2(K)_^1 1172 CONTINUE_^1_$IF(J.EQ.40)MACS=MACS+1_^1_$NOMAC=NOMAC+1_^1_$€€GO TO 1000_^1C_#HERE IF NUMERIC IN COL 1_^1 1180 IF(LENGTH.GT.1) GO TO 1190_^1_$IF(IL.EQ.0) GO TO 900_^1_$J=(J-$3000)/$100_^1_$DO 1181 I=1,J_^1_$CALL WRITE(3,1,1,$2020)_^1 1181 CONTINUE_^1_$GO TO 900_^1 1190 CONTINUE_^1C_[END FTN 3.3_^1C EXIT TO JOB PROCESSOR IF THIS IS A 'MON' CARD._^1_$IF (ISRS(1).EQ.$204D.AND.ISRS(2).EQ.$4F4E) CALL EXIT_^1_%IF(ISRS(1).EQ.$4D4F.AND.ISRS(2).EQ.$4E€€20) CALL EXIT_^1C_]_^1C IF COLUMN 6 CONTAINS A ZERO, BLANK IT OUT. LATER PROGRAMS REQUIRE_^1C THAT THE INITIAL LINE OF A STATEMENT BE BLANK IN 1-6._^1 1200 I=AND(ISRS(3),$00FF)_^1_$IF (I.NE.$30) GOTO 1210_^1_$CALL STCHAR (ISRS,6,$20)_^1_$GOTO 1300_^1C_]_^1C NOW JUMP IF THIS IS A CONTINUATION CARD._^1 1210 IF (I.NE.$20) GOTO 2100_^1C_]_^13_]_^1*_YBEGIN FTN 3.3_^1C IF THIS IS THE FI€€RST NON-COMMENT CARD,FIND THE PROGRAM NAME._^1 1300 IF(LENSAV.NE.0)GO TO 1400_^1_$DO 1350 I=1,8_^1_$I1=Z(I)_^1_$I2=Z(I+1)_^1_$DO 1340 J=6,72_^1_$K=IGETCF(ISRS,J)_^1_$IF(K.EQ.$20)GO TO 1340_^1_$IF(K.NE.W(I1))GO TO 1350_^1_$I1=I1+1_^1_$IF(I1.LT.I2)GO TO 1340_^1C_]_^1C STATEMENT TYPE IS FOUND SO :_^1C 1/ IF IT IS A BLOCK DATA,SEND "Q8QBDS" AS NAME AND THAT'S IT._^1_$IF(I.NE.6)GO TO €€1306_^1_$CALL VALNAM(QB)_^1_$GO TO 300_^1C_]_^1C 2/ IF NOT,FIND THE PROGRAM NAME._^1C_]_^1 1306 DO 1311 K=1,6_^1_$Q(K)=$20_^1 1311 CONTINUE_^1_$I1=0_]_^1_$I2=J_]_^1 1312 I1=I1+1_^1 1313 I2=I2+1_^1_$IF(I2.GT.72.OR.I1.GT.6) GO TO 1320_^1_$K=IGETCF(ISRS,I2)_^1_$IF(K.EQ.$20)GO TO 1313_^1_$IF(I1.GT.1)GO TO 1314_^1_$IF(K.LT.$41.OR.K.GT.$5A)GO TO 1360_^1_$GO TO 1315_^1 1314 IF(K.LT.$30.OR€€.K.GT.$5A)GO TO 1320_^1C_!LEGAL CHARACTER FOUND._^1 1315 Q(I1)=K_^1_$GO TO 1312_^1 1316 I2=I2+1_^1C_!NAME FOUND_^1 1320 CALL PACK(Q,6)_^1_$CALL VALNAM(Q)_^1_$IF(I.EQ.7)GO TO 1370_^1_$GO TO 300_^1 1340 CONTINUE_^1 1350 CONTINUE_^1C HERE IF FIRST CARD NOT RECOGNIZED.SEND NAME = "Q8QNAM"_^1 1360 CALL VALNAM(QN)_^1_$GO TO 300_^1C HER IF FIRST CARD IS A MACRO DEFINITION._^1 1370 IF(MO€€DMAC.EQ.1)GO TO 13710_^1_$IER115=2_^1_$MODMAC=1_^1_$GO TO 2000_^113710 J=MACRNB_^1C JUMP IF MACRO LIBRARY NOT FULL._^1_$IF(J.LT.32.AND.MACSEC.LT.160) GO TO 1372_^1_$CALL DIAG($7071)_^1 1371 MAGO=2_^1_$GO TO 1380_^1 1372 DO 1373 K=1,3_^1_$JSYM(K)=Q(K)_^1 1373 CONTINUE_^1_$CALL CNVT_^1_$NBMC=J*3_^1_$IF(J.EQ.0)GO TO 1376_^1_$CALL READ(18,0,96,IBUF1)_^1_$DO 1374 K=1,NBMC,3_^1_$IF(IBUF1€€(K).NE.JSYM(1).OR.IBUF1(K+1).NE.JSYM(2))GO TO 1374_^1C MACRO ALREADY IN LIBRARY : ERROR 124._^1_$CALL DIAG($7072)_^1_$GO TO 1371_^1 1374 CONTINUE_^1 1376 IBUF1(NBMC+1)=JSYM(1)_^1_$IBUF1(NBMC+2)=JSYM(2)_^1_$IBUF1(NBMC+3)=MACSEC_^1_$MAGO=1_^1_$MACRNB=MACRNB+1_^1 1380 MODMAC=2_^1_$IBUF2X=1_^1_$GO TO 2000_^1*_[END FTN 3.3_^13_]_^1C_]_^1C AN INITIAL LINE HAS BEEN READ. HOLD IT IN THE I€€NTERMEDIATE STATEMENT_^1C BUFFER UNTIL THE NEXT CALL TO 'GNST'. CONVERT THE STATEMENT IN THE_^1C MAIN STATEMENT BUFFER TO INTERNAL CODE, DIAGNOSING AND BLANKING ANY_^1C ILLEGAL CHARACTERS._^1 1400 J=2*(ISORSX+LENSAV-1)_^1_$DO 1430 I=1,J_^1_'K=IGETCF(ISORS,I)_^1C_#********BEGIN********** FTN 3.2 *********************************_^1_%DO 1410 L=1,47,1_^1C_#*********************** FTN€€ 3.2 ******END************************_^1_)IF (K.EQ.IBCDTB(L)) GOTO 1420_^1 1410_#CONTINUE_^1C_8BEGIN_4***** FTN 3.1 *****_^1C SEARCH EXTENDED SET_^1C_#********BEGIN********** FTN 3.2 *********************************_^1_$DO 1415 M=1,17,1_^1C_#*********************** FTN 3.2 ******END************************_^1_$L=M+48_^1_$IF (K.EQ.ASCIIX(M)) GO TO 1420_^1 1415 CONTINUE_^1C_8END_6*€€**** FTN 3.1 *****_^1_'CALL DIAG ($3022)_^1_'L=47_^1 1420_!CALL STCHAR (ISORS,I,L-1)_^1 1430_!CONTINUE_^1C_]_^1C INSERT AN END-OF-STATEMENT MARK INTO THE STATEMENT BUFFER._^1 1500 CALL STCHAR (ISORS,J+1,47)_^1C_]_^1C IF ERROR FLAG 'IERR47' IS SET, PRINT ERROR MESSAGE 47 BEFORE RETURN._^1 1600 IF (IERR47.NE.0) GOTO 3400_^1 1700 LENSAV=LENGTH_^1_$RETURN_^1C_]_^1C DIAGNOSTIC...'THIS L€€INE, WHICH BEGINS A STATEMENT, HAS OTHER THAN_^1C ZERO OR BLANK IN COLUMN 6. BLANK IS ASSUMED.'_^1 1800 CALL DIAG ($3023)_^1 1900 IERR35=0_^1_$GOTO 500_^1C_]_^1C PRINT THE INTERMEDIATE STATEMENT BUFFER AS A COMMENT CARD._^1*_YBEGIN FTN 3.3_^1 2000 IF(IL.EQ.0)GO TO 2030_^1*_[END FTN 3.3_^1_$IF (AND(IFLAGS,1).EQ.0) GOTO 2020_^1_$DO 2010 I=2,7_^1 2010_!IHEAD(I)=$2020_^1_$CALL WRITE (€€3,1,47,IHEAD)_^1*_YBEGIN FTN 3.3_^1_$GO TO 2030_^1*_[END FTN 3.3_^1 2020 CALL WRITE (3,1,LENGTH,ISRS)_^1*_YBEGIN FTN 3.3_^1 2030 GO TO (2031,2031,1170,2032),MODMAC_^1 2031 IF(IER115.EQ.0) GO TO 810_^1_$CALL DIAG($7072+IER115)_^1_$IER115=0_^1_$GO TO 810_^1 2032 CALL SKIPIT_^1*_[END FTN 3.3_^1C_]_^1C THE INTERMEDIATE STATEMENT BUFFER CONTAINS A CONTINUATION CARD._^1C THIS IS ILLEGAL €€IF THIS IS THE FIRST NON-COMMENT CARD OF THE PROGRAM._^1 2100 IF (LENSAV.EQ.0) GOTO 2700_^1C PRINT THE BUFFER IN STATEMENT FORMAT._^1 2200 ASSIGN 2300 TO JUMP_^1_$GOTO 310_^1 2300 ITALLY=ITALLY+1_^1C_#********BEGIN********** 1672*72 ********************************_^1C_#LABELED CONTINUATION CARD IS NOT ALLOWED_^1_$IF(ISRS(1).NE.$2020.OR.ISRS(2).NE.$2020.OR.(AND(ISRS(3),$FF00)_^1_#€€$ .NE.$2000)) CALL_!DIAG ($3036)_^1C_#*********************** 1672*72 *****END************************_^1C JUMP IF THIS IS MORE THAN THE 5TH CONTINUATION CARD._^1 2400 IF (ITALLY.GT.5) GOTO 2900_^1C MOVE COLUMNS 7-72 OF THE INTERMEDIATE STATEMENT BUFFER INTO THE_^1C NEXT 33 WORDS OF THE MAIN STATEMENT BUFFER._^1 2500 ISORSX=ISORSX+33_^1_$IF (ITALLY.EQ.1) ISORSX=ISORSX+3_^1_$J=IS€€ORSX_^1_$DO 2510 I=4,36_^1_'ISORS(J)=ISRS(I)_^1 2510_!J=J+1_^1C_#********BEGIN********** 1661*72 ********************************_^1C_$LENGTH OF THREE MEANS A BLANK CONTINUATION LINE_^1_$IF (LENGTH.EQ.3) LENGTH = 36_^1C_#*********************** 1661*72 *****END************************_^1_$LENSAV=LENGTH-3_^1C_#********BEGIN********** FTN 3.2 *********************************_^1_$G€€OTO 900_^1C_#*********************** FTN 3.2 ******END************************_^1C_]_^1C SET ERROR FLAG 'IERR35'...THE FIRST NON-COMMENT CARD WAS A CONTINUE_^1C CARD. THE DIAGNOSTIC WILL BE PRINTED LATER, AFTER THE STATEMENT._^1C BLANK OUT COLUMN 6...FORCE THE LINE TO BE TREATED AS AN INITIAL LINE._^1 2700 IERR35=1_^1 2800 CALL STCHAR (ISRS,6,$20)_^1*_YBEGIN FTN 3.3_^1_$GO TO 1360€€_^1*_[END FTN 3.3_^1C_]_^1C SET ERROR FLAG 'IERR47'...THE STATEMENT HAS TOO MANY CONTINUATIONS._^1C THE DIAGNOSTIC WILL BE PRINTED AFTER ALL CONTINUATIONS HAVE BEEN_^1C SLEWED OVER._^1 2900 IERR47=1_^1C_#********BEGIN********** FTN 3.2 *********************************_^1_$GOTO 900_^1C_#*********************** FTN 3.2 ******END************************_^1C_]_^1C PRINT DIAGNOSTIC...'€€STATEMENT HAS MORE THAN FIVE CONTINUATION CARDS._^1C ALL BUT THE FIRST FIVE ARE IGNORED.'_^1C_#********BEGIN********** FTN 3.2 *********************************_^1 3400 CALL DIAG($302F)_^1C_#*********************** FTN 3.2 ******END************************_^1_$GOTO 1700_^1C_]_^1C PRINT DIAGNOSTIC...'A PROGRAM CONSISTING OF ONLY AN END CARD IS_^1C ILLEGAL.' RESTART PHASE A._^1 350€20 CALL DIAG ($104B)_^1_$CALL SKIPIT_^1_$END_]_^__ 2PWOTENT CSY/ 06A P€1_$SUBROUTINE OUTENT(IOBUF)_^1_#*_2/DECK-ID 06A FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^13_]_^1C OUTENT IS USED IN PHASES A1,A2,A3,A4,A5_^1C_]_^1C_#MASTER LABELED COMMON BLOCK._^1*_] FTN 3.3_^1_$COMMON /A/ IFLAGS,LINECT,LINCT1_^1_$COMMON /A/ IR,IK€€,IP,IA,IL,IM,IXLGO,IOPTO,IOPTV,IOPTC,IOPTD_^1_$COMMON /A/ MCSTRT,MACRNB,MACSEC_^1_$COMMON /A/ IERRS(16),ISRFAD_^1_$COMMON /A/ LGO,ISCRI,ISCRO,IX_^1*_] FTN 3.3_^1_$COMMON /A/ IGLAB(3),IGLAB1,IGLAB2_^1_$COMMON /A/ ICOMT(12),ICOMTS,ICOMX2,ICOMTL,ISUBP,NDPRS,_^1_#$LABX,IBCDTB(48)_^1_$EQUIVALENCE(ICOMB,ICOMT(1)),(ICOMBX,ICOMT(2)),(ICOMDF,_^1_#$ICOMT(3)),(ICOMBN,ICOMT(4))_^1_$DIMENSION €€ICOMB(6),ICOMBX(6),ICOMDF(6),ICOMBN(7)_^1_$COMMON /A/ LOOPTS,LOOPTX,LOOPTB,LOOPT(50)_^1_$EQUIVALENCE(LINDUC,LOOPT(1))_^1_$DIMENSION LINDUC(10)_^1_$EQUIVALENCE (LBEG,LOOPT(2))_^1_$DIMENSION LBEG(10)_^1_$EQUIVALENCE (LINC,LOOPT(3))_^1_$DIMENSION LINC(10)_^1_$EQUIVALENCE (LEND,LOOPT(4))_^1_$DIMENSION LEND(10)_^1_$BYTE(LLABL,LOOPT(5)(14=0)_))_^1_$DIMENSION LLABL(10)_^1_$BYTE(LID,LOOPT€€(5)(15=15) )_^1_$DIMENSION LID(10)_^1_$COMMON/A/IEQV(255), IEQVS,IEQVN2_^1_$COMMON /A/ ISTAB(150),ISTABS,ISTAB2_^1_$COMMON /A/ IBUFS,ISET(25),LBLANK,KSFCNT,KSNCNT,ISORSC,_^1_#$IHOBIT,ISTNO,ISSFLG,ISUBPN,ITERM,JSORSC,KEQVS_^1C_#SYMBOL TABLE LABELED COMMON BLOCK_^1_$COMMON /A/ ISYMN, ISYMFL,ISYMD,ISYMX,ISYMS,ISYMP,ISYMPC,ISYMPS,_^1_#$ ISYMNS, SYMTAB(960)_^1_$INTEGER SYMTAB_^1_$BYTE €€(IDUM,SYMTAB(1)(15=15)),(KDUMY,SYMTAB(1)(15=15)),_^1_#$(ICLASS,SYMTAB(1)(14=11)),(ITYPE,SYMTAB(1)(10=9))_^1_$DIMENSION IDUM(100),KDUMY(100),ICLASS(100),ITYPE(100)_^1_$BYTE (ISNGL, SYMTAB(1)(8=8)),(KELSIZ,SYMTAB(1)(8=8)),_^1_#$ (ICOM,SYMTAB(1)(7=5)),(IPART,SYMTAB(1)(4=3))_^1_$DIMENSION ISNGL(100),KELSIZ(100),ICOM(100),IPART(100)_^1_$BYTE (KRFCNT,SYMTAB(1)(2=2)),(IDIM,SYMTAB(1)(1=0))€€,_^1_#$ (IREL,SYMTAB(1)(1=1)),(IEXT,SYMTAB(1)(0=0))_^1_$DIMENSION KRFCNT(100),IDIM(100),IREL(100),IEXT(100)_^1_$EQUIVALENCE (IRSA,SYMTAB(2)),(ICOMTX,SYMTAB(2)),(ISNOL,SYMTAB(2))_^1_$DIMENSION IRSA(100), ICOMTX(100),ISNOL(100)_^1_$BYTE (IDATAS,SYMTAB(3)(15=15)),(IREF,SYMTAB(3)(15=15)),_^1_#$ (IEQVX,SYMTAB(3)(14=8)),(ITILF,SYMTAB(3)(14=8))_^1_$DIMENSION IDATAS(100),IREF(100),IEQVX(10€€0),ITILF(100)_^1_$BYTE (IPARTR,SYMTAB(3)(7=4)),(INDUCV,SYMTAB(3)(7=7)),(ISFARG,_^1_#$ SYMTAB(3)(6=6)),(IARGNO,SYMTAB(3)(5=0)),(IPARTL,SYMTAB(3)(3=0))_^1_$DIMENSION IPARTR(100),INDUCV(100),ISFARG(100),IARGNO(100),_^1_#$ IPARTL(100)_^1_$EQUIVALENCE (ISYM,SYMTAB(4))_^1_$DIMENSION ISYM(100)_^1C_]_^1C_#SPECIFICATION-TABLE INDEX LABELLED COMMON BLOCK_^1_$COMMON /A/ ISTABX(96)_^1C_]_^1C_#€€PHASE A BLANK COMMON BLOCK._^1_$COMMON // JSYM(3),JTERM,JMODE,JERR,JESWT,JFLOT,JCHAR,_^1_#$JOCHAR,JO1,JE,JE1,JBLANK,JCT,JCT1_^1C_#JSYM-JCT1 MUST REMAIN IN ORDER_^1_$COMMON//IERR_^1_$COMMON//ISORS(208),ISORSX_^1_$COMMON//IDEFF,ISTOP,IRET,ISPEC,NERR,OCT_^1_$INTEGER OCT_^1_$COMMON//ILLABL,LEST,ISNGL1,ICOMX1,NXTYPE,LOGIF,IOVFL1,IOVFL2_^1_$COMMON//IVCFLG,ISFLG,LOGEX,KEQVX_^1_$COMMON//IB€€UF2X,IBUF2(304)_^1C_$TEMPORARY ARITHMETIC BUFFERS_^1_$COMMON//IBUF1( 304),IBUF1X,IWORK (304)_^1C_#TEMPORARY EQUIVALENCE BUFFERS_^1_$DIMENSION KEQV(460),MEQV(255)_^1_$EQUIVALENCE (KEQV,IBUF1(66)),(MEQV,IBUF2(100))_^1C_#LS1-ITEM MUST REMAIN IN ORDER_^1_$COMMON//LS1,LPREN,LRELRQ,LRELEN,LSWITC,LO,ITEM_^1_$COMMON//MODE_^1_$COMMON//IPHAT(4),IGNSTT(49),IOSPRT(17)_^1C_]_^1C_]_^1C_]_^1C_#OU€€TPUTS ONE STATEMENT OR PSEUDO STATEMENT_^1_$DIMENSION IOBUF(404)_^1_$DIMENSION IBUF(2)_^1C_]_^1C IF NO FATAL ERROR IN STATEMENT, OUTPUT IT. IF FATAL ERROR DURING_^1C SPECIFICATION PROCESSING (DATA AND FORMAT STATEMENTS), IGNORE_^1C STATEMENT. OTHERWISE CHANGE TO CONTINUE STATEMENT, PRESERVING_^1C LABEL IF ANY._^1C_]_^1_$IF(IERR.EQ.0) GO TO 4_^1_$IERR=0_^1_$IF (ISPEC.EQ.0) RETURN_€ž^1_$IOBUF(3)=27_^1_$IF(IOBUF(2).LT.0) GO TO 6_^1_$IOBUF(1)=4_^1_$GO TO 4_^1_"6 IOBUF(1)=5_^1_"4 CONTINUE_^1_$CALL WRITE(ISCRO,0,IOBUF(1),IOBUF)_^1_$END_]_^__ žPWPHSEA CSY/ 07A P€1_$SUBROUTINE PHASEA_^1_#*_2/DECK-ID 07A FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^13_]_^1C PHASEA IS USED IN PHASES A1,A2,A3,A4,A5_^1C THIS IS THE PHASE A CONTROL ROUTINE._^1C IN PHASE A, THE SOURCE PROGRAM IS READ AND ANALYZED. IF ASSEMBLY_^1C WAS€€ REQUESTED, AND IF NO FATAL ERRORS HAVE BEEN DETECTED, THE PROGRAM_^1C IS PASSED, IN CONDENSED FORM, TO PHASE B FOR GENERATION OF PSEUDO-_^1C ASSEMBLY CODE. IF NO FATAL ERRORS ARE DETECTED IN THAT PHASE, THE_^1C CODE IS PASSED TO PHASES C AND D FOR GENERATION OF THE OBJECT CODE._^1C_]_^1C_#MASTER LABELED COMMON BLOCK._^1*_] FTN 3.3_^1_$COMMON /A/ IFLAGS,LINECT,LINCT1_^1_$COMMON /€€A/ IR,IK,IP,IA,IL,IM,IXLGO,IOPTO,IOPTV,IOPTC,IOPTD_^1_$COMMON /A/ MCSTRT,MACRNB,MACSEC_^1_$COMMON /A/ IERRS(16),ISRFAD_^1_$COMMON /A/ LGO,ISCRI,ISCRO,IX_^1*_] FTN 3.3_^1_$COMMON /A/ IGLAB(3),IGLAB1,IGLAB2_^1_$COMMON /A/ ICOMT(12),ICOMTS,ICOMX2,ICOMTL,ISUBP,NDPRS,_^1_#$LABX,IBCDTB(48)_^1_$EQUIVALENCE(ICOMB,ICOMT(1)),(ICOMBX,ICOMT(2)),(ICOMDF,_^1_#$ICOMT(3)),(ICOMBN,ICOMT(4))_^1_$DI€€MENSION ICOMB(6),ICOMBX(6),ICOMDF(6),ICOMBN(7)_^1_$COMMON /A/ LOOPTS,LOOPTX,LOOPTB,LOOPT(50)_^1_$EQUIVALENCE(LINDUC,LOOPT(1))_^1_$DIMENSION LINDUC(10)_^1_$EQUIVALENCE (LBEG,LOOPT(2))_^1_$DIMENSION LBEG(10)_^1_$EQUIVALENCE (LINC,LOOPT(3))_^1_$DIMENSION LINC(10)_^1_$EQUIVALENCE (LEND,LOOPT(4))_^1_$DIMENSION LEND(10)_^1_$BYTE(LLABL,LOOPT(5)(14=0)_))_^1_$DIMENSION LLABL(10)_^1_$BYTE(L€€ID,LOOPT(5)(15=15) )_^1_$DIMENSION LID(10)_^1_$COMMON/A/IEQV(255), IEQVS,IEQVN2_^1_$COMMON /A/ ISTAB(150),ISTABS,ISTAB2_^1_$COMMON /A/ IBUFS,ISET(25),LBLANK,KSFCNT,KSNCNT,ISORSC,_^1_#$IHOBIT,ISTNO,ISSFLG,ISUBPN,ITERM,JSORSC,KEQVS_^1C_#SYMBOL TABLE LABELED COMMON BLOCK_^1_$COMMON /A/ ISYMN, ISYMFL,ISYMD,ISYMX,ISYMS,ISYMP,ISYMPC,ISYMPS,_^1_#$ ISYMNS, SYMTAB(960)_^1_$INTEGER SYMTAB_^€€1_$BYTE (IDUM,SYMTAB(1)(15=15)),(KDUMY,SYMTAB(1)(15=15)),_^1_#$(ICLASS,SYMTAB(1)(14=11)),(ITYPE,SYMTAB(1)(10=9))_^1_$DIMENSION IDUM(100),KDUMY(100),ICLASS(100),ITYPE(100)_^1_$BYTE (ISNGL, SYMTAB(1)(8=8)),(KELSIZ,SYMTAB(1)(8=8)),_^1_#$ (ICOM,SYMTAB(1)(7=5)),(IPART,SYMTAB(1)(4=3))_^1_$DIMENSION ISNGL(100),KELSIZ(100),ICOM(100),IPART(100)_^1_$BYTE (KRFCNT,SYMTAB(1)(2=2)),(IDIM,SYMTAB(€€1)(1=0)),_^1_#$ (IREL,SYMTAB(1)(1=1)),(IEXT,SYMTAB(1)(0=0))_^1_$DIMENSION KRFCNT(100),IDIM(100),IREL(100),IEXT(100)_^1_$EQUIVALENCE (IRSA,SYMTAB(2)),(ICOMTX,SYMTAB(2)),(ISNOL,SYMTAB(2))_^1_$DIMENSION IRSA(100), ICOMTX(100),ISNOL(100)_^1_$BYTE (IDATAS,SYMTAB(3)(15=15)),(IREF,SYMTAB(3)(15=15)),_^1_#$ (IEQVX,SYMTAB(3)(14=8)),(ITILF,SYMTAB(3)(14=8))_^1_$DIMENSION IDATAS(100),IREF(100),€€IEQVX(100),ITILF(100)_^1_$BYTE (IPARTR,SYMTAB(3)(7=4)),(INDUCV,SYMTAB(3)(7=7)),(ISFARG,_^1_#$ SYMTAB(3)(6=6)),(IARGNO,SYMTAB(3)(5=0)),(IPARTL,SYMTAB(3)(3=0))_^1_$DIMENSION IPARTR(100),INDUCV(100),ISFARG(100),IARGNO(100),_^1_#$ IPARTL(100)_^1_$EQUIVALENCE (ISYM,SYMTAB(4))_^1_$DIMENSION ISYM(100)_^1C_]_^1C_#SPECIFICATION-TABLE INDEX LABELLED COMMON BLOCK_^1_$COMMON /A/ ISTABX(96)_^1C€€_]_^1C_#PHASE A BLANK COMMON BLOCK._^1_$COMMON // JSYM(3),JTERM,JMODE,JERR,JESWT,JFLOT,JCHAR,_^1_#$JOCHAR,JO1,JE,JE1,JBLANK,JCT,JCT1_^1C_#JSYM-JCT1 MUST REMAIN IN ORDER_^1_$COMMON//IERR_^1_$COMMON//ISORS(208),ISORSX_^1_$COMMON//IDEFF,ISTOP,IRET,ISPEC,NERR,OCT_^1_$INTEGER OCT_^1_$COMMON//ILLABL,LEST,ISNGL1,ICOMX1,NXTYPE,LOGIF,IOVFL1,IOVFL2_^1_$COMMON//IVCFLG,ISFLG,LOGEX,KEQVX_^1_$CO€€MMON//IBUF2X,IBUF2(304)_^1C_$TEMPORARY ARITHMETIC BUFFERS_^1_$COMMON//IBUF1( 304),IBUF1X,IWORK (304)_^1C_#TEMPORARY EQUIVALENCE BUFFERS_^1_$DIMENSION KEQV(460),MEQV(255)_^1_$EQUIVALENCE (KEQV,IBUF1(66)),(MEQV,IBUF2(100))_^1C_#LS1-ITEM MUST REMAIN IN ORDER_^1_$COMMON//LS1,LPREN,LRELRQ,LRELEN,LSWITC,LO,ITEM_^1_$COMMON//MODE_^1C_]_^1C_]_^1C STORAGE FOR LOCAL VARIABLES OF PROGRAMS WHIC€€H WILL BE OVERLAID..._^1_$COMMON IPHAT(4),IHEAD(48),LENSAV,IOSPRT(17)_^1_$EQUIVALENCE (ITEMP3,IPHAT(3))_^1C_]_^1C_#SET ROUTINE NAME TO Q8QNAM._^1_$DATA LABX/0/_^1._]_^1*_#RESET LINE COUNTER TO ZERO_^1_$LINCT1=0_^1C ********************************** FTN 3.0 **************************_^1C THE SAVEID PROGRAM ON THE FIRST PASS THROUGH WILL SET THE LOAD-AND-GO_^1C_!SECTOR TO BLANKS. €€THE LOAD-AND-GO SECTOR IS USED TO HOLD_^1C_!INFORMATION FOLLOWING A / ON THE ROUTINE IDENTIFICATION CARD_^1C_!TO BE OUTPUT ON THE BINARY NAM CARD_^1_$CALL SAVEID_^1C ********************************** FTN 3.0 **************************_^1C ZERO OUT THE LOOP STRUCTURE TABLE._^1_$DO 100 I=1,LOOPTS_^1 100_!LOOPT(I)=0_^1C SET UP PHASE ONE EQUIVALENCE TABLES._^1_$DO 200 I=1,KEQVS_^1 €€200_!KEQV(I)=0_^1_$KEQVX=1_^1C INITIALIZE COUNTERS AND SWITCHES._^1_$IHEAD(1)=$2020_^1_$LENSAV=0_^1_$JBLANK=0_^1_$IERR=0_^1_$ISTOP=0_^1_$NERR=0_^1_$OCT=0_^1_$ISPEC=0_^1_$IDEFF=0_^1C CLEAR LAST-EXECUTABLE-STATEMENT TYPE._^1_$LEST=0_^1C SET NUMBER OF WORDS IN LAST OUTPUT ENTRY TO ZERO, AND TYPE OF LAST_^1C STATEMENT TO ZERO._^1_$IBUF2(1)=0_^1_$IBUF2(3)=0_^1 300 LOGIF=0_^1 400 ISTNO€€=ISTNO+1_^1C IF LAST STATEMENT WAS EXECUTABLE OR STATEMENT FUNCTION, RECORD TYPE._^1C_8BEGIN_4***** FTN 3.1 *****_^1_$IF (IBUF2(3).GT.17 .AND.IBUF2(3).LT.46) LEST=IBUF2(3)_^1C_8END_6***** FTN 3.1 *****_^1C READ NEXT STATEMENT._^1_$CALL GNST_^1C INITIALIZE THE INTER-PASS FILE OUTPUT BUFFER._^1 600 IBUF2(2)=ISTNO_^1 650 IBUF2X=5_^1_$IBUF2(4) = IBUF2(1)_^1C PROCESS THE STATEMENT LAB€€EL._^1 700 CALL PLABEL_^1C DETERMINE STATEMENT TYPE._^1_$NERR=1_^1_$CALL TYPE(I)_^1_$NERR=0_^1_$JMODE=0_^1C JUMP IF TYPE IS RECOGNIZABLE._^1_$IF (I.EQ.0) GOTO 1100_^1_$CALL DIAG ($1034)_^1_$IF (ISPEC.EQ.0) GOTO 1700_^1 800 CALL OUTENT (IBUF2)_^1 850 IF (LOGIF.NE.1) GOTO 300_^1_$LOGIF=2_^1_$GOTO 600_^1C JUMP IF NOT PROCESSING SPECIFICATION STATEMENTS._^1 1100 IF (ISPEC.NE.0) GOTO€€ 1300_^1C JUMP IF CURRENT STATEMENT IS SPECIFICATION._^1C_8BEGIN_4***** FTN 3.1 *****_^1 1200 IF (IBUF2(3).LE.17 .OR. IBUF2(3).GE.46) GOTO 1400_^1C_8END_6***** FTN 3.1 *****_^1C THIS IS EITHER A STATEMENT FUNCTION OR THE FIRST EXECUTABLE STATEMENT_^1C IF NO NON-SPECIFICATION STATEMENTS HAVE BEEN PROCESSED YET, NOW_^1C PROCESS THE EQUIVALENCES._^1_$IF (LEST.EQ.0) CALL PEQVS_^1_$IERR€€=0_^1C IF THIS STATEMENT IS CLEARLY NON-SPECIFICATION, TURN OFF THE FLAG FOR_^1C 'PROCESSING SPEC. STATEMENTS.' THE ARITHMETIC-REPLACEMENT-_^1C STATEMENT PROCESSING WILL HANDLE THE FLAG IN THE CASE OF STATEMENT_^1C FUNCTIONS (TYPE 19) AND REPLACEMENT STATEMENTS (18), WHICH CANNOT_^1C BE DISTINGUISHED AT THIS POINT._^1C_8BEGIN_4***** FTN 3.1 *****_^1_$IF (IBUF2(3).GT.19 .AND.IBUF2(€€3).LT.46) ISPEC=1_^1C_8END_6***** FTN 3.1 *****_^1C JUMP IF NOT ILLEGAL SECOND OF LOGICAL IF._^1 1300 IF (LOGIF.EQ.0.OR.(IBUF2(3).NE.16.AND.IBUF2(3).NE.17.AND.IBUF2(3)_^1_#* .NE.40)) GOTO 1400_^1_$CALL DIAG ($1C)_^1_$GOTO 800_^1 1400 ITEMPX=IBUF2(3)+1_^1C JUMP IF STATEMENT UNLABELLED OR LABEL OK FOR THIS STATEMENT TYPE._^1C_8BEGIN_4***** FTN 3.1 *****_^1_$IF (IBUF2(2).GE.0.OR.(IBU€€F2(3).GE.17.AND.IBUF2(3).LT.46.AND._^1_#* IBUF2(3).NE.32)) GOTO 1500_^1C_8END_6***** FTN 3.1 *****_^1C_#********BEGIN********** FTN 3.2 *********************************_^1_$IF (IBUF2(3).EQ.32) CALL DIAG($300C)_^1C_#*********************** FTN 3.2 ******END************************_^1_$CALL DIAG ($3036)_^1_$IBUF2(2)=-IBUF2(2)_^1_$IBUF2X=5_^1C BRANCH ON STATEMENT TYPE._^1 1500 GOTO €€(1600,1800,2100,2100,2200,2200,2200,2100,2900,2900,_^1_#*_$3100,3100,2900,2200,2200,2200,3500,3600,3700,3700,_^1_#*_$3800,3900,4000,4100,4400,4400,4400,4600,5000,5000,_^1_#*_$5000,5000,5200,5800,5800,5800,6100,6100,6100,6100,_^1C_8BEGIN_4***** FTN 3.1 *****_^1_#*_$6800,6800,7000,7000,8200,6100,2100,2200),ITEMPX_^1C_8END_6***** FTN 3.1 *****_^1C-----_]_^1C 'DIMENSION' STATEMENT -_^1€€ 1600 ISFLG=1_^1_$CALL DIMPR_^1 1700 IERR=0_^1_$IBUF2(1) = IBUF2(4)_^1_$GOTO 400_^1C-----_]_^1C 'COMMON' STATEMENT -_^1 1800 CALL COMNPR_^1_$GOTO 1700_^1C-----_]_^1C_8BEGIN_4***** FTN 3.1 *****_^1C 'INTEGER', 'REAL', 'SINGLE', AND 'DOUBLE PRECISION' STATEMENTS -_^1C_8END_6***** FTN 3.1 *****_^1 2100 CALL TYPEPR_^1_$GOTO 1700_^1C-----_]_^1C PROGRAM TYPE DECLARATIONS - CHECK FOR PREV€€IOUS DECLARATION._^1C_#********BEGIN********** FTN 3.2 *********************************_^1C_$PROGRAM DECLARATOR MUST BE FIRST STATEMENT_^1 2200 IF (ISTNO.EQ.1) GOTO 2202_^1_$CALL DIAG ($101E)_^1_$GOTO 1700_^1 2202 IF (LABX+ISUBP.EQ.0) GOTO 2205_^1C_#*********************** FTN 3.2 ******END************************_^1_$CALL DIAG ($2065)_^1_$GOTO 1700_^1C_8BEGIN_4***** FTN 3.1 ****€€*_^1 2205 IF (ITEMPX-48) 2210,2300,2210_^1C_8END_6***** FTN 3.1 *****_^1 2210 IF (ITEMPX-7) 2300,2400,2220_^1 2220 IF (ITEMPX-15) 3200,3400,3400_^1C-----_]_^1C 'INTEGER FUNCTION', 'REAL FUNCTION', AND 'DOUBLE PRECISION FUNCTION'_^1C STATEMENTS -_^1 2300 IVCFLG=IBUF2(3)-3_^1C_8BEGIN_4***** FTN 3.1 *****_^1_$IF (IBUF2(3).EQ.47) IVCFLG=3_^1C_8END_6***** FTN 3.1 *****_^1_$IBUF2(3)=14_€€^1_$CALL SUBPPR_^1_$GOTO 800_^1C-----_]_^1C 'PROGRAM' STATEMENT -_^1 2400 CALL GETF_^1C JUMP IF NAME._^1_$IF (JMODE.EQ.2) GOTO 2500_^1_$CALL DIAG ($2038)_^1_$GOTO 1700_^1 2500 CALL STORE_^1_$ICLASS(ISYMX)=9_^1_$LABX=ISYMX+ISYMP_^1C ********************************** FTN 3.0 **************************_^1C THIS TIME THROUGH SAVEID THE INFORMATION FOLLOWING A / IS WRITTEN_^1C_!ONTO T€€HE LOAD-AND-GO SECTOR_^1_$CALL SAVEID_^1C ********************************** FTN 3.0 **************************_^1_$GOTO 1700_^1C-----_]_^1C 'BYTE', 'SIGNED BYTE', AND 'EQUIVALENCE' STATEMENTS -_^1 2900 CALL BYEQPR_^1_$GOTO 1700_^1C-----_]_^1C 'EXTERNAL' AND 'RELATIVE' STATEMENTS -_^1 3100 CALL EXRLPR_^1_$GOTO 1700_^1C-----_]_^1C 'BLOCK DATA' STATEMENT -_^1 3200 ISUBP=1_^1C ******€€**************************** FTN 3.0 **************************_^1C THIS TIME THROUGH SAVEID THE INFORMATION FOLLOWING A / IS WRITTEN_^1C_!ONTO THE LOAD-AND-GO SECTOR_^1_$JTERM = 0_^1_$CALL SAVEID_^1C ********************************** FTN 3.0 **************************_^1C ********************************** FTN 3.0 **************************_^1_$GOTO 1700_^1C-----_]_^1C 'SUBROU€€TINE' AND 'FUNCTION' STATEMENTS -_^1 3400 IVCFLG=0_^1_$CALL SUBPPR_^1_$GOTO 800_^1C-----_]_^1C 'DATA' STATEMENT -_^1 3500 CALL DATAPR_^1_$GOTO 6150_^1C-----_]_^1C 'FORMAT' STATEMENT -_^1 3600 CALL CHECKF_^1_$GOTO 800_^1C-----_]_^1C REPLACEMENT STATEMENT AND STATEMENT FUNCTION -_^1 3700 ISSFLG=0_^1_$ISORSX=7_^1_$CALL GETF_^1C JUMP IF FIELD IS A NAME._^1_$IF (JMODE.EQ.2) GOTO 3715_^1€€ 3705 CALL DIAG ($19)_^1C RETURN IF TERMINATOR IS EOS._^1 3710 IF (JTERM.EQ.47) GOTO 3750_^1C JUMP IF TERMINATOR IS EQUAL SIGN._^1_$IF (JTERM.EQ.40) GOTO 3745_^1_$CALL GETF_^1_$GOTO 3710_^1C JUMP IF SYMBOL NOT IN SYMBOL TABLE._^1 3715 IF (ISYMD.EQ.0) GOTO 3720_^1C JUMP IF NAME IS VARIABLE OR UNASSIGNED._^1C_8BEGIN ***PSR 69 * 1239 ***_^1_$IF(ICLASS(ISYMX).EQ.1.OR.(ICLASS(ISYMX).EQ.€€0.AND._^1_#* IEXT(ISYMX).EQ.0)) GO TO 3725_^1C_8END_!***PSR 69 * 1239 ***_^1_$CALL DIAG ($53)_^1_$GOTO 3710_^1C STORE NAME IN SYMBOL TABLE._^1 3720 CALL STORE_^1C JUMP IF TERMINATOR IS LEFT PARENTHESIS._^1 3725 IF (JTERM.EQ.41) GOTO 3760_^1C JUMP IF TERMINATOR NOT EQUAL SIGN._^1_$IF (JTERM.NE.40) GOTO 3705_^1C BUILD TREE OF EXPRESSION TO LEFT OF EQUAL SIGN._^1 3730 ISORSX=7_^1_$ISP€€EC=1_^1_$ICLASS(ISYMX)=1_^1_$ISTOP=2_^1_$CALL ARITH_^1C JUMP IF TERMINATOR IS PROPERLY AN EQUAL SIGN._^1_$IF (JTERM.EQ.40) GOTO 3745_^1C JUMP IF TERMINATOR NOT RIGHT PARENTHESIS._^1 3735 IF (JTERM.NE.42) GOTO 3705_^1 3740 CALL GETF_^1C JUMP IF EXPRESSION NOT IMMEDIATELY FOLLOWED BY EQUAL SIGN._^1_$IF (JMODE.NE.0.OR.JTERM.NE.40) GOTO 3705_^1C BUILD TREE OF EXPRESSION TO RIGHT OF EQU€€AL SIGN._^1 3745 ISTOP=0_^1_$CALL ARITH_^1C SET UP OUTPUT BUFFER._^1_$IBUF2(1)=IBUF2X-1_^1C RETURN IF NOT STATEMENT FUNCTION._^1 3750 IF (ISSFLG.EQ.0) GOTO 6150_^1C_!VOID SYMBOL TABLE ENTRIES FOR DUMMY ARGUMENTS_^1_$J=5+ISSFLG_^1_$DO 3755 I=6,J_^1_'ISYMX=IBUF2(I)_^1_'CALL GETSYM_^1 3755_!ISYM(ISYMX)=0_^1_$ISSFLG=0_^1_$GOTO 6150_^1C JUMP IF CLASS OF NAME IS NOT UNASSIGNED._^1 3760 I€€F (ICLASS(ISYMX)+ISPEC.NE.0) GOTO 3730_^1_$IF (IBUF2(2).LT.0) GOTO 3775_^1C SET UP OUTPUT BUFFER FOR STATEMENT FUNCTION._^1 3765 ICLASS(ISYMX)=4_^1_$IF (ITYPE(ISYMX).EQ.0) ITYPE(ISYMX)=JESWT_^1_$KSFCNT=KSFCNT+1_^1_$IBUF2(3)=19_^1_$IBUF2(IBUF2X)=ISYMX+ISYMP_^1_$IBUF2X=IBUF2X+1_^1 3770 CALL GETF_^1C JUMP IF FIELD NOT A NAME._^1_$IF (JMODE.NE.2) GOTO 3705_^1_$ISSFLG=ISSFLG+1_^1C TO GE€€NERATE A NEW SYMBOL TABLE POINTER FOR THIS NAME (WHICH MAY MATCH_^1C A PREVIOUSLY-DECLARED NAME), FORCE THE NAME TO BE ILLEGAL BY SETTING_^1C ITS FIRST 3 CHARACTERS TO '1AB'. 'SYMBOL' WILL RETURN WITH ISYMX_^1C POINTING TO A CLEARED SYMTAB ENTRY AT THE TOP OF THE TABLE._^1C_8BEGIN_4***** FTN 3.1 *****_^1C_(IF A PREVIOUSLY DECLARED MATCH EXISTS ITS TYPE BECOMES THE_^1C_#TYPE FOR TH€€E DUMMY ARGUMENT. TYPE MUST BE GREATER THAN ZERO_^1C_#ELSE IMPLICIT TYPE IS USED._^1_$CALL SYMBOL_^1_$IF(ISYMD.NE.0 .AND. ITYPE(ISYMX).GT.0) JESWT=ITYPE(ISYMX)_^1C_8END_6***** FTN 3.1 *****_^1_$J=JSYM(1)_^1_$JSYM(1)=$0623_^1_$CALL SYMBOL_^1_$JSYM(1)=J_^1_$CALL STORE_^1C SET POINTER UP AS STATEMENT FUNCTION DUMMY ARGUMENT AND STORE INTO_^1C OUTPUT FILE._^1_$ICLASS(ISYMX)=1_^1_$IDUM€€(ISYMX)=1_^1_$ISFARG(ISYMX)=1_^1_$ITYPE(ISYMX)=JESWT_^1_$IBUF2(IBUF2X)=ISYMX+ISYMP_^1_$IBUF2X=IBUF2X+1_^1C JUMP IF TERMINATOR IS COMMA._^1_$IF (JTERM.EQ.43) GOTO 3770_^1_$GOTO 3735_^1 3775 CALL DIAG ($3036)_^1_$IBUF2(2)=-IBUF2(2)_^1_$IBUF2X=5_^1_$GOTO 3765_^1C-----_]_^1C 'ASSIGN' STATEMENT -_^1 3800 CALL ASGNPR_^1_$GOTO 6150_^1C-----_]_^1C 'CALL' STATEMENT -_^1 3900 CALL ARITH_^1_$€€IBUF2(1)=IBUF2X-1_^1_$GOTO 6150_^1C-----_]_^1C 'RETURN' STATEMENT -_^1C JUMP IF IN A SUBPROGRAM._^1 4000 IF (ISUBP.NE.0) GOTO 4100_^1_$CALL DIAG ($2041)_^1C CREATE A 'STOP' STATEMENT._^1_$IBUF2(3)=28_^1_$LEST=28_^1 4100 IBUF2(1)=IBUF2X-1_^1_$GOTO 6150_^1C-----_]_^1C 'GO TO' STATEMENTS -_^1C JUMP IF COMPUTED GO-TO._^1 4400 I=ISORSX_^1_$CALL GETF_^1_$IF (JMODE.EQ.0.AND.JTERM.EQ.41) G€€OTO 4435_^1C JUMP IF UNCONDITIONAL GO-TO._^1_$IF (JMODE.EQ.3) GOTO 4410_^1C JUMP IF ASSIGNED GO-TO._^1_$IF (JMODE.EQ.2) GOTO 4455_^1C DIAGNOSTIC 'SYNTAX ERROR'._^1 4405 CALL DIAG ($0019)_^1_$GOTO 6150_^1C UNCONDITIONAL GO-TO._^14410 ISORSX=I_^1_$ASSIGN 4425 TO J_^1 4415 CALL RDLABL_^1C JUMP IF LABEL IN SYMBOL TABLE._^1_$IF (ISYMD.NE.0) GOTO 4420_^1C STORE LABEL IN SYMBOL TABLE._^1€€_$CALL STORE_^1_$ICLASS(ISYMX)=7_^1C STORE LABEL IN OUTPUT FILE._^1 4420 IBUF2(IBUF2X)=ISYMX+ISYMP_^1_$IBUF2X=IBUF2X+1_^1C CALL DIAG IF JUMP TO SELF._^1_$IF (IBUF2(2).LT.0.AND.IBUF2(IBUF2X-1).EQ.IBUF2(5))_^1_#* CALL DIAG ($204A)_^1_$GOTO J_^1C CALL DIAG IF TERMINATOR NOT EOS._^1 4425 IF (JTERM.NE.47) CALL DIAG ($2042)_^1 4430 IBUF2(1)=IBUF2X-1_^1_$GOTO 6150_^1C COMPUTED GO-TO._^1 €€4435 IBUF2(3)=25_^1_$ASSIGN 4440 TO J_^1_$GOTO 4415_^1C JUMP IF TERMINATOR A COMMA._^1 4440 IF (JTERM.EQ.43) GOTO 4415_^1C JUMP IF TERMINATOR RIGHT PARENTHESIS._^1_$IF (JTERM.NE.42) GOTO 4405_^1 4445 I=ISORSX_^1_$CALL GETC_^1C JUMP IF NEXT CHARACTER IS A COMMA._^1_$IF (JCHAR.EQ.43) GOTO 4450_^1_$CALL DIAG ($2020)_^1_$ISORSX=I_^1C BUILD TREE FOR ARITHMETIC EXPRESSION._^1 4450 ISTOP=€€0_^1_$CALL ARITH_^1_$GOTO 4430_^1C ASSIGNED GO-TO._^1C JUMP IF NAME IS NOT IN SYMBOL TABLE._^1 4455 IF (ISYMD.EQ.0) GOTO 4460_^1C JUMP IF FIELD IS AN INTEGER VARIABLE._^1_$IF (ICLASS(ISYMX).LE.1.AND.ITYPE(ISYMX).LE.1_^1_#* .AND.IDIM(ISYMX).EQ.0) GOTO 4465_^1_$CALL DIAG ($0045)_^1_$GOTO 6150_^1 4460 CALL STORE_^1C JUMP IF NAME IMPLICITLY INTEGER._^1_$IF (JESWT.EQ.1) GOTO 4465_^1_$C€€ALL DIAG ($2040)_^1 4465 ICLASS(ISYMX)=1_^1_$ITYPE(ISYMX)=1_^1C SET UP FILE ENTRY._^1 4470 IBUF2(IBUF2X)=ISYMX+ISYMP_^1_$IBUF2(1)=IBUF2X_^1_$IBUF2(3)=26_^1_$GOTO 6150_^1C-----_]_^1C 'CONTINUE' STATEMENT -_^1C ********************************** PSR 753 **************************_^1C ********************************** PSR 753 **************************_^1 4600_"CALL GETC_^1C_)ERROR€€ IF MORE IN STATEMENT_^1_(IF(JCHAR.NE.47) CALL DIAG($42)_^1_(IERR=1_^1C ********************************** PSR 753 *****8********************_^1C ********************************** PSR 753 **************************_^1_$GOTO 6150_^1C-----_]_^1C 'STOP' AND 'PAUSE' STATEMENTS -_^1 5000 OCT=1_^1_$CALL GETF_^1C JUMP IF 'STOP N' OR 'PAUSE N' STATEMENT._^1_$IF (JMODE.EQ.3.AND.JTERM.EQ.€€47) GOTO 5100_^1C DIAGNOSTIC IF SUPERFLUOUS INFORMATION._^1_$IF (JMODE.NE.0.OR.JTERM.NE.47) CALL DIAG ($1042)_^1_$GOTO 4100_^1 5100 IBUF2(IBUF2X)=JSYM(1)_^1_$IBUF2(3)=IBUF2(3)+1_^1_$IBUF2(1)=IBUF2X_^1_$GOTO 6150_^1C-----_]_^1C 'END' STATEMENT -_^1C JUMP IF DO NOT NEED TO CREATE A 'STOP'._^1C_#********BEGIN********** 1800*74 ********************************_^15200 IF(ISUBP.NE.0.OR€€.LOGFLG.EQ.0.AND.(LEST.GE.24.AND.LEST.LE.29_^1_#*.AND.LEST.NE.27.OR.LEST.EQ.42)) GO TO 5300_^1C_#*********************** 1800*74 *****END************************_^1_$IBUF2(1)=4_^1_$IBUF2(3)=28_^1_$CALL OUTENT(IBUF2)_^1_%IBUF2(3)=43_^1_$IBUF2(4) = IBUF2(1)_^1C CHECK FOR OPEN 'DO' LOOPS._^1 5300 IF (LOOPTX.EQ.1) GOTO 5500_^1_$CALL DIAG ($5017)_^1 5400 I=LOOPTX-LOOPTB_^1_$ILLABL=LLAB€€L(I)_^1_$IBUF2(3)=27_^1_$IERR=0_^1_$CALL ENDDO_^1_$IF (LOOPTX.NE.1) GOTO 5400_^1 5500 IBUF2(1)=4_^1_$IBUF2(3)=32_^1_$CALL OUTENT (IBUF2)_^1_$CALL CPLOOP_^1C IF A FATAL ERROR HAS BEEN DETECTED, OR IF NO ASSEMBLY/EXECUTE OPTIONS_^1C ARE SET, STOP COMPILATION AT THIS POINT._^1_$IF(AND(IFLAGS,8).NE.0.OR.IA+IM+IP+IXLGO+IOPTC.EQ.0) CALL SKIPIT_^1C_#IF CROSS REFERENCE SELECTED, OUTPUT EOF€€ TO REFERENCE FILE_^1_$IF(IOPTC.NE.0) CALL WRITE(0,0,97,$8000)_^1C IF ASSEMBLY LISTING IS REQUESTED AND STANDARD LIST DEVICE IS NOT A_^1*_YBEGIN FTN 3.3_^1C TTY OR PAPER TAPE PUNCH, FORCE A PAGE EJECT_^1_$LINCT1=0_^1*_[END FTN 3.3_^1_$RETURN_^1C-----_]_^1C 'END FILE', 'REWIND', AND 'BACKSPACE' STATEMENTS -_^1 5800 CALL ERBPR_^1_$GOTO 6150_^1C-----_]_^1C 'READ', 'WRITE', AND 'OPEN' €€STATEMENTS -_^1 6100 CALL IOSPR_^1_$IERR=0_^1_$IVCFLG=0_^1_$GOTO 6200_^1 6150 CALL OUTENT (IBUF2)_^1C RECORD TYPE OF LAST EXECUTABLE STATEMENT._^1C_8BEGIN_4***** FTN 3.1 *****_^1 6200 IABSF=IABS(IBUF2(3))_^1_$IF (LOGIF.NE.2.AND.IABSF.GE.17.AND.IABSF.LT.46) LEST=IABSF_^1C_8END_6***** FTN 3.1 *****_^1C JUMP IF NOT PROCESSING EITHER HALF OF LOGICAL IF._^1C_#********BEGIN********** 180€€0*74 ********************************_^16300 LOGFLG = 0_^1_$IF(LOGIF.EQ.0) GO TO 6500_^1_$LOGFLG = 1_^1C_#*********************** 1800*74 ******END************************_^1C JUMP IF HAVE JUST PROCESSED FIRST HALF OF LOGICAL IF._^1_$IF (LOGIF.EQ.1) GOTO 6400_^1C HAVE JUST PROCESSED SECOND HALF OF LOGICAL IF._^1_$LOGIF=0_^1_$ILLABL=IPHAT(4)_^1*_#JUMP IF NO LABEL_^1_$IF(ILLABL.EQ.€€0) GO TO 400_^1_$GO TO 6600_^1*_#HAVE JUST PROCESSED FIRST HALF OF LOGIACL IF_^1 6400 IPHAT(4)=0_^1_$IF(IBUF2(2).LT.0) IPHAT(4)=IBUF2(5)_^1_$LOGIF=2_^1_$IBUF2(2)=IABS(IBUF2(2))_^1_$GO TO 650_^1*_#JUMP IF NOT LABELLED_^1 6500 IF(IBUF2(2).GE.0) GO TO 400_^1_$ILLABL=IBUF2(5)_^1 6600 CALL ENDDO_^1_$GO TO 400_^1C-----_]_^1C 'DO' STATEMENT -_^1 6800 CALL BDOPR_^1_$GOTO 6150_^1C-----_]_^1€€C 'IF' STATEMENT -_^1 7000 IPHAT(1)=0_^1_$IPHAT(2)=0_^1_$I=ISORSX_^1C SKIP TO END OF EXPRESSION, DETERMINING IN THE PROCESS WHETHER OR NOT_^1C IT IS LOGICAL._^1 7100 CALL GETF_^1C JUMP IF EOS._^1C ********************************** PSR 717 **************************_^1C ********************************** PSR 717 **************************_^1_(IF(JTERM.EQ.47) GO TO 7750_^1C ******€€**************************** PSR 717 **************************_^1C JUMP IF NOT LEFT PARENTHESIS._^1_$IF (JTERM.NE.41) GO TO 7200_^1_$IPHAT(1)=IPHAT(1)+1_^1_$GO TO 7100_^1C JUMP IF NOT RIGHT PARENTHESIS_^1 7200 IF (JTERM.NE.42) GO TO 8000_^1_$IPHAT(1)=IPHAT(1)-1_^1C DIAGNOSTIC 7 IF NO INITIAL LEFT PARENTHESIS._^1_$IF (IPHAT(1).GE.0) GOTO 7205_^1_$CALL DIAG ($1007)_^1_$GOTO 6150_€€^1C JUMP IF NOT ZERO PARENTHESIS LEVEL._^1 7205 IF (IPHAT(1).NE.0) GOTO 7100_^1C JUMP IF LOGICAL IF._^1_$IF (IPHAT(2).NE.0) GOTO 7300_^1_$ISORSX=I_^1C ARITHMETIC 'IF' STATEMENT._^1_$ILLABL=IBUF2X_^1_$IBUF2X=IBUF2X+3_^1_$ISTOP=1_^1C BUILD ARITHMETIC EXPRESSION._^1_$CALL ARITH_^1_$ISTOP=0_^1C READ THE FIRST LABEL._^1_$I=1_]_^1_$J=ILLABL_^1 7210 CALL RDLABL_^1C JUMP IF A LABEL WAS PRE€€SENT._^1_$IF (ILLABL.EQ.0) GOTO 7230_^1C JUMP IF LABEL IN SYMBOL TABLE._^1_$IF (ISYMD.NE.0) GOTO 7220_^1C SET UP LABEL IN SYMBOL TABLE._^1_$CALL STORE_^1_$ICLASS(ISYMX)=7_^1C STORE LABEL IN OUTPUT FILE._^1 7220 IBUF2(J)=ISYMX+ISYMP_^1_$J=J+1_^1C HAVE ALL THREE LABELS BEEN PROCESSED_^1_$IF (I.EQ.3) GOTO 7240_^1_$I=I+1_^1C JUMP TO PROCESS NEXT LABEL IF TERMINATOR COMMA._^1_$IF (JTERM€€.EQ.43) GOTO 7210_^1 7230 CALL DIAG ($0019)_^1_$GOTO 6150_^1C SET UP OUTPUT FILE._^1 7240 IBUF2(1)=IBUF2X-1_^1C OUTPUT STATEMENT IF EOS._^1_$IF (JTERM.EQ.47) GOTO 6150_^1_$CALL DIAG ($2042)_^1_$GOTO 6150_^1 7300 IBUF2(3) = 43_^1_$CALL GETC_^1_$IPHAT(1)=ISORSX-1_^1C SAVE CHARACTER._^1_$IPHAT(2)=JCHAR_^1C SET EOS CHARACTER IN BUFFER._^1_$CALL STCHAR (ISORS,IPHAT(1),47)_^1_$ASSIGN 740€€0 TO ITEMP3_^1_$ISORSX=I_^1_$GO TO 7900_^1C SET UP SECOND STATEMENT IN ISORS._^1 7400 DO 7500 I=1,6_^1 7500_!CALL STCHAR (ISORS,I,46)_^1_$J=7_]_^1_$JCHAR=IPHAT(2)_^1_$ISORSX=IPHAT(1)+1_^1_$GOTO 7700_^1 7600 CALL GETC_^1 7700 CALL STCHAR (ISORS,J,JCHAR)_^1_$J=J+1_^1_$IF (JCHAR.NE.47) GOTO 7600_^1_$LOGIF=1_^1_$GOTO 6150_^1C ********************************** PSR 717 ***************€€***********_^1C_)ARE ALL PAREN MATCHED_^17750_#IF(IPHAT(1).EQ.0) GO TO 7800_^1_(CALL DIAG($10)_^1_(GO TO 6150_^1C ********************************** PSR 717 **************************_^1C ********************************** PSR 717 **************************_^1 7800 ASSIGN 6150 TO ITEMP3_^1 7900 ISTOP=1_^1_$CALL ARITH_^1_$ISTOP=0_^1_$IBUF2(1)=IBUF2X-1_^1_$GOTO ITEMP3_^1C JUMP IF N€,OT LOGICAL IF._^1 8000 IF (JTERM.LE.47.OR.JTERM.EQ.$2D2D) GOTO 7100_^1C JUMP IF NOT PROCESSING SECOND HALF OF LOGICAL IF._^1_$IF (LOGIF.EQ.0) GOTO 8100_^1_$CALL DIAG ($1C)_^1_$GOTO 800_^1 8100 IPHAT(2)=1_^1_$GOTO 7100_^1C-----_]_^1C 'ASSEM' STATEMENT -_^1 8200 CALL ASEMPR_^1_$GOTO 6150_^1_$END_]_^__,PWPLBEL CSY/ 08A P€1_$SUBROUTINE PLABEL_^1_#*_2/DECK-ID 08A FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^13_]_^1C PLABEL IS USED IN PHASES A1,A2,A3,A4,A5_^1C_]_^1C_#MASTER LABELED COMMON BLOCK._^1*_] FTN 3.3_^1_$COMMON /A/ IFLAGS,LINECT,LINCT1_^1_$COMMON /A/ IR,IK,IP,IA,€€IL,IM,IXLGO,IOPTO,IOPTV,IOPTC,IOPTD_^1_$COMMON /A/ MCSTRT,MACRNB,MACSEC_^1_$COMMON /A/ IERRS(16),ISRFAD_^1_$COMMON /A/ LGO,ISCRI,ISCRO,IX_^1*_] FTN 3.3_^1_$COMMON /A/ IGLAB(3),IGLAB1,IGLAB2_^1_$COMMON /A/ ICOMT(12),ICOMTS,ICOMX2,ICOMTL,ISUBP,NDPRS,_^1_#$LABX,IBCDTB(48)_^1_$EQUIVALENCE(ICOMB,ICOMT(1)),(ICOMBX,ICOMT(2)),(ICOMDF,_^1_#$ICOMT(3)),(ICOMBN,ICOMT(4))_^1_$DIMENSION ICOMB(6€€),ICOMBX(6),ICOMDF(6),ICOMBN(7)_^1_$COMMON /A/ LOOPTS,LOOPTX,LOOPTB,LOOPT(50)_^1_$EQUIVALENCE(LINDUC,LOOPT(1))_^1_$DIMENSION LINDUC(10)_^1_$EQUIVALENCE (LBEG,LOOPT(2))_^1_$DIMENSION LBEG(10)_^1_$EQUIVALENCE (LINC,LOOPT(3))_^1_$DIMENSION LINC(10)_^1_$EQUIVALENCE (LEND,LOOPT(4))_^1_$DIMENSION LEND(10)_^1_$BYTE(LLABL,LOOPT(5)(14=0)_))_^1_$DIMENSION LLABL(10)_^1_$BYTE(LID,LOOPT(5)(15=€€15) )_^1_$DIMENSION LID(10)_^1_$COMMON/A/IEQV(255), IEQVS,IEQVN2_^1_$COMMON /A/ ISTAB(150),ISTABS,ISTAB2_^1_$COMMON /A/ IBUFS,ISET(25),LBLANK,KSFCNT,KSNCNT,ISORSC,_^1_#$IHOBIT,ISTNO,ISSFLG,ISUBPN,ITERM,JSORSC,KEQVS_^1C_#SYMBOL TABLE LABELED COMMON BLOCK_^1_$COMMON /A/ ISYMN, ISYMFL,ISYMD,ISYMX,ISYMS,ISYMP,ISYMPC,ISYMPS,_^1_#$ ISYMNS, SYMTAB(960)_^1_$INTEGER SYMTAB_^1_$BYTE (IDUM,S€€YMTAB(1)(15=15)),(KDUMY,SYMTAB(1)(15=15)),_^1_#$(ICLASS,SYMTAB(1)(14=11)),(ITYPE,SYMTAB(1)(10=9))_^1_$DIMENSION IDUM(100),KDUMY(100),ICLASS(100),ITYPE(100)_^1_$BYTE (ISNGL, SYMTAB(1)(8=8)),(KELSIZ,SYMTAB(1)(8=8)),_^1_#$ (ICOM,SYMTAB(1)(7=5)),(IPART,SYMTAB(1)(4=3))_^1_$DIMENSION ISNGL(100),KELSIZ(100),ICOM(100),IPART(100)_^1_$BYTE (KRFCNT,SYMTAB(1)(2=2)),(IDIM,SYMTAB(1)(1=0)),_^1_#$€€ (IREL,SYMTAB(1)(1=1)),(IEXT,SYMTAB(1)(0=0))_^1_$DIMENSION KRFCNT(100),IDIM(100),IREL(100),IEXT(100)_^1_$EQUIVALENCE (IRSA,SYMTAB(2)),(ICOMTX,SYMTAB(2)),(ISNOL,SYMTAB(2))_^1_$DIMENSION IRSA(100), ICOMTX(100),ISNOL(100)_^1_$BYTE (IDATAS,SYMTAB(3)(15=15)),(IREF,SYMTAB(3)(15=15)),_^1_#$ (IEQVX,SYMTAB(3)(14=8)),(ITILF,SYMTAB(3)(14=8))_^1_$DIMENSION IDATAS(100),IREF(100),IEQVX(100),ITIL€€F(100)_^1_$BYTE (IPARTR,SYMTAB(3)(7=4)),(INDUCV,SYMTAB(3)(7=7)),(ISFARG,_^1_#$ SYMTAB(3)(6=6)),(IARGNO,SYMTAB(3)(5=0)),(IPARTL,SYMTAB(3)(3=0))_^1_$DIMENSION IPARTR(100),INDUCV(100),ISFARG(100),IARGNO(100),_^1_#$ IPARTL(100)_^1_$EQUIVALENCE (ISYM,SYMTAB(4))_^1_$DIMENSION ISYM(100)_^1C_]_^1C_#SPECIFICATION-TABLE INDEX LABELLED COMMON BLOCK_^1_$COMMON /A/ ISTABX(96)_^1C_]_^1C_#PHASE A€€ BLANK COMMON BLOCK._^1_$COMMON // JSYM(3),JTERM,JMODE,JERR,JESWT,JFLOT,JCHAR,_^1_#$JOCHAR,JO1,JE,JE1,JBLANK,JCT,JCT1_^1C_#JSYM-JCT1 MUST REMAIN IN ORDER_^1_$COMMON//IERR_^1_$COMMON//ISORS(208),ISORSX_^1_$COMMON//IDEFF,ISTOP,IRET,ISPEC,NERR,OCT_^1_$INTEGER OCT_^1_$COMMON//ILLABL,LEST,ISNGL1,ICOMX1,NXTYPE,LOGIF,IOVFL1,IOVFL2_^1_$COMMON//IVCFLG,ISFLG,LOGEX,KEQVX_^1_$COMMON//IBUF2X,IB€€UF2(304)_^1C_$TEMPORARY ARITHMETIC BUFFERS_^1_$COMMON//IBUF1( 304),IBUF1X,IWORK (304)_^1C_#TEMPORARY EQUIVALENCE BUFFERS_^1_$DIMENSION KEQV(460),MEQV(255)_^1_$EQUIVALENCE (KEQV,IBUF1(66)),(MEQV,IBUF2(100))_^1C_#LS1-ITEM MUST REMAIN IN ORDER_^1_$COMMON//LS1,LPREN,LRELRQ,LRELEN,LSWITC,LO,ITEM_^1_$COMMON//MODE_^1_$COMMON//IPHAT(4),IGNSTT(49),IOSPRT(17)_^1C_]_^1C_]_^1C_]_^1C_#THIS ROUT€€INE PROCESSES THE STATEMENT LABEL._^1_$ISORSX=1_^1C_]_^1C_#READ THE LABEL_^1C_]_^1_$IF (AND(ISORS(3),$FF00).EQ.$2E00.AND.ISORS(2).EQ.LBLANK_^1_#* .AND.ISORS(1).EQ.LBLANK) GO TO 5_^1_$CALL RDLABL_^1C_]_^1C_#RETURN IF NO LABEL._^1C_]_^1_$IF(ILLABL.EQ.0) GO TO 5_^1C_]_^1C_#JUMP IF LABEL IS IN SYMBOL TABLE._^1C_]_^1_$IF(ISYMD.NE.0) GO TO 1_^1C_#STORE LABEL IN SYMBOL TABLE._^1_$CALL ST€€ORE_^1_$ICLASS(ISYMX)=7_^1_$GO TO 2_^1C_#JUMP IF LABEL IS NOT PREVIOUSLY DEFINED._^1_"1 IF(ISNOL(ISYMX).EQ.0) GO TO 2_^1_$CALL DIAG($1037)_^1_$ILLABL=0_^1_$GO TO 5_^1C_]_^1C_#SET ENTRY UP FOR LABEL._^1C_]_^1C_#STORE GENERATED STATEMENT NUMBER OF THIS STATEMENT IN SYMBOL_^1C_#TABLE ENTRY OF LABEL._^1C_]_^1_"2 ISNOL(ISYMX)=ISTNO_^1_"4 IBUF2(2)=-IBUF2(2)_^1_$IBUF2(IBUF2X)=ISYMX+ISYMP_€0^1_$IBUF2X=IBUF2X+1_^1_"5 ISORSX=7_^1_$END_]_^__0PWQ8QBS CSY/ 09A P€1_$BLOCK DATA_^1_#*_2/DECK-ID 09A FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^13_]_^1C THIS ROUTINE IS USED IN PHASE A1_^1C THIS BLOCK DATA SUBPROGRAM IS LISTED ON THE LOAD MAPS AS Q8QBDS_^1C THIS ROUTINE SETS UP MASTER LABELLED COMMON AND SYMBOL TABL€€E PRESETS._^1C_]_^1C_#MASTER LABELED COMMON BLOCK._^1*_] FTN 3.3_^1_$COMMON /A/ IFLAGS,LINECT,LINCT1_^1_$COMMON /A/ IR,IK,IP,IA,IL,IM,IXLGO,IOPTO,IOPTV,IOPTC,IOPTD_^1_$COMMON /A/ MCSTRT,MACRNB,MACSEC_^1_$COMMON /A/ IERRS(16),ISRFAD_^1_$COMMON /A/ LGO,ISCRI,ISCRO,IX_^1*_] FTN 3.3_^1_$COMMON /A/ IGLAB(3),IGLAB1,IGLAB2_^1_$COMMON /A/ ICOMT(12),ICOMTS,ICOMX2,ICOMTL,ISUBP,NDPRS,_^1_#$€€LABX,IBCDTB(48)_^1_$EQUIVALENCE(ICOMB,ICOMT(1)),(ICOMBX,ICOMT(2)),(ICOMDF,_^1_#$ICOMT(3)),(ICOMBN,ICOMT(4))_^1_$DIMENSION ICOMB(6),ICOMBX(6),ICOMDF(6),ICOMBN(7)_^1_$COMMON /A/ LOOPTS,LOOPTX,LOOPTB,LOOPT(50)_^1_$EQUIVALENCE(LINDUC,LOOPT(1))_^1_$DIMENSION LINDUC(10)_^1_$EQUIVALENCE (LBEG,LOOPT(2))_^1_$DIMENSION LBEG(10)_^1_$EQUIVALENCE (LINC,LOOPT(3))_^1_$DIMENSION LINC(10)_^1_$EQUIV€€ALENCE (LEND,LOOPT(4))_^1_$DIMENSION LEND(10)_^1_$BYTE(LLABL,LOOPT(5)(14=0)_))_^1_$DIMENSION LLABL(10)_^1_$BYTE(LID,LOOPT(5)(15=15) )_^1_$DIMENSION LID(10)_^1_$COMMON/A/IEQV(255), IEQVS,IEQVN2_^1_$COMMON /A/ ISTAB(150),ISTABS,ISTAB2_^1_$COMMON /A/ IBUFS,ISET(25),LBLANK,KSFCNT,KSNCNT,ISORSC,_^1_#$IHOBIT,ISTNO,ISSFLG,ISUBPN,ITERM,JSORSC,KEQVS_^1C_]_^1C_#SYMBOL TABLE LABELED COMMON €€BLOCK_^1_$COMMON /A/ ISYMN, ISYMFL,ISYMD,ISYMX,ISYMS,ISYMP,ISYMPC,ISYMPS,_^1_#$ ISYMNS, SYMTAB(960)_^1_$INTEGER SYMTAB_^1_$BYTE (IDUM,SYMTAB(1)(15=15)),(KDUMY,SYMTAB(1)(15=15)),_^1_#$(ICLASS,SYMTAB(1)(14=11)),(ITYPE,SYMTAB(1)(10=9))_^1_$DIMENSION IDUM(100),KDUMY(100),ICLASS(100),ITYPE(100)_^1_$BYTE (ISNGL, SYMTAB(1)(8=8)),(KELSIZ,SYMTAB(1)(8=8)),_^1_#$ (ICOM,SYMTAB(1)(7=5)),(IPART,€€SYMTAB(1)(4=3))_^1_$DIMENSION ISNGL(100),KELSIZ(100),ICOM(100),IPART(100)_^1_$BYTE (KRFCNT,SYMTAB(1)(2=2)),(IDIM,SYMTAB(1)(1=0)),_^1_#$ (IREL,SYMTAB(1)(1=1)),(IEXT,SYMTAB(1)(0=0))_^1_$DIMENSION KRFCNT(100),IDIM(100),IREL(100),IEXT(100)_^1_$EQUIVALENCE (IRSA,SYMTAB(2)),(ICOMTX,SYMTAB(2)),(ISNOL,SYMTAB(2))_^1_$DIMENSION IRSA(100), ICOMTX(100),ISNOL(100)_^1_$BYTE (IDATAS,SYMTAB(3)(15=€€15)),(IREF,SYMTAB(3)(15=15)),_^1_#$ (IEQVX,SYMTAB(3)(14=8)),(ITILF,SYMTAB(3)(14=8))_^1_$DIMENSION IDATAS(100),IREF(100),IEQVX(100),ITILF(100)_^1_$BYTE (IPARTR,SYMTAB(3)(7=4)),(INDUCV,SYMTAB(3)(7=7)),(ISFARG,_^1_#$ SYMTAB(3)(6=6)),(IARGNO,SYMTAB(3)(5=0)),(IPARTL,SYMTAB(3)(3=0))_^1_$DIMENSION IPARTR(100),INDUCV(100),ISFARG(100),IARGNO(100),_^1_#$ IPARTL(100)_^1_$EQUIVALENCE (ISYM,SYM€€TAB(4))_^1_$DIMENSION ISYM(100)_^1C_]_^1C_#SPECIFICATION-TABLE INDEX LABELLED COMMON BLOCK_^1_$COMMON /A/ ISTABX(96)_^1C_]_^1*_YBEGIN FTN 3.3_^1_$DATA IFLAGS,LINECT/0,56/_^1_$DATA IERRS/16*0/_^1*_[END FTN 3.3_^1_$DATA IR,IK,IP,IA,IL,IM,IXLGO/0,0,0,0,0,0,0/_^1*_] FTN 3.3_^1_$DATA IOPTO,IOPTV,IOPTC,IOPTD/0,0,0,0/_^1*_] FTN 3.3_^1_$DATA ISCRI,ISCRO/9,10/_^1*_] FTN 3.3_^1_$DATA MCST€€RT,MACRNB,MACSEC,ISRFAD/0,0,1,0/_^1*_] FTN 3.3_^1_$DATA ISYMN,ISYMFL,ISYMS,ISYMP,ISYMPC,ISYMPS,ISYMNS_^1C*************************************************************** 81*2193_^1_#* /236,5,12501,0,0,960,11/_^1C_!INCREASED SYMBOL TABLE ENTRIES TO 2500_!( 5 WORDS PER ENTRY )_^1C_]_^1C*************************************************************** 81*2193_^1_$DATA KSFCNT/0/_^1C_]_^€€1C_#SET UP CONSTANT ONE IN SYMBOL TABLE_^1_$DATA SYMTAB( 1),SYMTAB( 2),SYMTAB( 3),SYMTAB( 4),SYMTAB( 5)_^1_#* /$1200,$0000,$0000,$_!1,$0000/_^1C_]_^1C_#FLOATING PT. CONSTANT 1.0_^1_$DATA SYMTAB( 6),SYMTAB( 7),SYMTAB( 8),SYMTAB( 9),SYMTAB( 10)_^1_#* /$1400,$0000,$0000,$40C0,$0000/_^1C_]_^1C_#Q8QFLT_^1_$DATA SYMTAB( 11),SYMTAB( 12),SYMTAB( 13),SYMTAB( 14),SYMTAB( 15)_^1_#*€€ /$2C00,$0000,$0000,$9BCC,$5C6F/_^1C_]_^1C_#Q8QFIX_^1_$DATA SYMTAB( 16),SYMTAB( 17),SYMTAB( 18),SYMTAB( 19),SYMTAB( 20)_^1_#* /$2A00,$0000,$0000,$9BCC,$5BFE/_^1C_]_^1C_#FLOT_]_^1_$DATA SYMTAB( 21),SYMTAB( 22),SYMTAB( 23),SYMTAB( 24),SYMTAB( 25)_^1*_YBEGIN FTN 3.3_^1_#* /$2C00,$0000,$0000,$675F,$9329/_^1*_[END FTN 3.3_^1C_]_^1C_#CONSTANT 0_^1_$DATA SYMTAB( 26),SYMTAB( 27),SYMTAB(€€ 28),SYMTAB( 29),SYMTAB( 30)_^1_#* /$1200,$0000,$0000,$0000,$0000/_^1C_]_^1C_#Q8QF2F_^1_$DATA SYMTAB( 31),SYMTAB( 32),SYMTAB( 33),SYMTAB( 34),SYMTAB( 35)_^1_#* /$2C00,$0000,$0000,$9BCC,$597C/_^1C_]_^1C_#Q8QF2I_^1_$DATA SYMTAB( 36),SYMTAB( 37),SYMTAB( 38),SYMTAB( 39),SYMTAB( 40)_^1_#* /$2C00,$0000,$0000,$9BCC,$597F/_^1C_]_^1C_#Q8QI2F (MEANING INTEGER TO INTEGER)_^1_$DATA SYMTAB( €€41),SYMTAB( 42),SYMTAB( 43),SYMTAB( 44),SYMTAB( 45)_^1_#* /$2A00,$0000,$0000,$9BCC,$6B4F/_^1C_]_^1C_#Q8STP_^1_$DATA SYMTAB( 46),SYMTAB( 47),SYMTAB( 48),SYMTAB( 49),SYMTAB( 50)_^1_#* /$2A00,$0000,$0000,$9BCE,$B042/_^1C_]_^1C_#Q8STPN_^1_$DATA SYMTAB( 51),SYMTAB( 52),SYMTAB( 53),SYMTAB( 54),SYMTAB( 55)_^1_#* /$2A00,$0000,$0000,$9BCE,$B033/_^1C_]_^1C_#Q8PSE_^1_$DATA SYMTAB( 56),SYMT€€AB( 57),SYMTAB( 58),SYMTAB( 59),SYMTAB( 60)_^1_#* /$2A00,$0000,$0000,$9BCB,$A8A4/_^1C_]_^1C_#Q8PSEN_^1_$DATA SYMTAB( 61),SYMTAB( 62),SYMTAB( 63),SYMTAB( 64),SYMTAB( 65)_^1_#* /$2A00,$0000,$0000,$9BCB,$A895/_^1C_]_^1C_#Q8PKUP_^1_$DATA SYMTAB( 66),SYMTAB( 67),SYMTAB( 68),SYMTAB( 69),SYMTAB( 70)_^1_#* /$2A00,$0000,$0000,$9BCB,$7B7F/_^1C_]_^1C_#Q8PREP_^1_$DATA SYMTAB( 71),SYMTAB( 72€€),SYMTAB( 73),SYMTAB( 74),SYMTAB( 75)_^1_#* /$2A00,$0000,$0000,$9BCB,$A2A6/_^1C_]_^1C_#Q8QFLE_^1_$DATA SYMTAB( 76),SYMTAB( 77),SYMTAB( 78),SYMTAB( 79),SYMTAB( 80)_^1_#* /$2A00,$0000,$0000,$9BCC,$5C60/_^1C_]_^1C_#Q8QWND_^1_$DATA SYMTAB( 81),SYMTAB( 82),SYMTAB( 83),SYMTAB( 84),SYMTAB( 85)_^1_#* /$2A00,$0000,$0000,$9BCC,$C1AE/_^1C_]_^1C_#Q8QBCK_^1_$DATA SYMTAB( 86),SYMTAB( 87),SYMT€€AB( 88),SYMTAB( 89),SYMTAB( 90)_^1_#* /$2A00,$0000,$0000,$9BCC,$4343/_^1C_]_^1C_#Q8QINI_^1_$DATA SYMTAB( 91),SYMTAB( 92),SYMTAB( 93),SYMTAB( 94),SYMTAB( 95)_^1_#* /$2A00,$0000,$0000,$9BCC,$6E85/_^1C_]_^1C_#Q8QX1_^1_$DATA SYMTAB( 96),SYMTAB( 97),SYMTAB( 98),SYMTAB( 99),SYMTAB(100)_^1_#* /$ A00,$0000,$0000,$9BCC,$C45E/_^1C_]_^1C_#Q8QX2_^1_$DATA SYMTAB(101),SYMTAB(102),SYMTAB(103),€€SYMTAB(104),SYMTAB(105)_^1_#* /$ A00,$0000,$0000,$9BCC,$C485/_^1C_]_^1C_#Q8QX3_^1_$DATA SYMTAB(106),SYMTAB(107),SYMTAB(108),SYMTAB(109),SYMTAB(110)_^1_#* /$ A00,$0000,$0000,$9BCC,$C4AC/_^1C_]_^1C_#Q8QX_]_^1_$DATA SYMTAB(111),SYMTAB(112),SYMTAB(113),SYMTAB(114),SYMTAB(115)_^1_#* /$3200,$0000,$0000,$9BCC,$CA01/_^1C_]_^1C_#Q8QEND_^1_$DATA SYMTAB(116),SYMTAB(117),SYMTAB(118),SYMTAB(€€119),SYMTAB(120)_^1_#* /$2A00,$0000,$0000,$9BCC,$56BC/_^1C_]_^1C_#Q8DFNF_^1_$DATA SYMTAB(121),SYMTAB(122),SYMTAB(123),SYMTAB(124),SYMTAB(125)_^1_#* /$2A00,$0000,$0000,$9BBF,$5CAF/_^1C_]_^1C_#Q8QY_]_^1_$DATA SYMTAB(126),SYMTAB(127),SYMTAB(128),SYMTAB(129),SYMTAB(130)_^1_#* /$3200,$0000,$0000,$9BCC,$CFF2/_^1C_8BEGIN_4***** FTN 3.1 *****_^1C_]_^1C_#DFLOT_^1_$DATA SYMTAB(131),SYMTAB€€(132),SYMTAB(133),SYMTAB(134),SYMTAB(135)_^1*_YBEGIN FTN 3.3_^1_#* /$2E00,$0000,$0000,$670B,$808A/_^1*_[END FTN 3.3_^1C_]_^1C_#DSTOR1_^1_$DATA SYMTAB(136),SYMTAB(137),SYMTAB(138),SYMTAB(139),SYMTAB(140)_^1_#* /$2E00,$0000,$0000,$519E,$92B6/_^1C_]_^1C_#DSTOR2_^1_$DATA SYMTAB(141),SYMTAB(142),SYMTAB(143),SYMTAB(144),SYMTAB(145)_^1_#* /$2E00,$0000,$0000,$519E,$92B7/_^1C_]_^1C_#FLOA€€T_^1_$DATA SYMTAB(146),SYMTAB(147),SYMTAB(148),SYMTAB(149),SYMTAB(150)_^1_#* /$2C00,$0000,$0002,$5C6A,$3FFB/_^1C_]_^1C_#DFLT_]_^1_$DATA SYMTAB(151),SYMTAB(152),SYMTAB(153),SYMTAB(154),SYMTAB(155)_^1_#* /$2E00,$0000,$0002,$4F9B,$B23D/_^1C_]_^1C_#DBLE_]_^1_$DATA SYMTAB(156),SYMTAB(157),SYMTAB(158),SYMTAB(159),SYMTAB(160)_^1_#* /$2E00,$0000,$0002,$4EFF,$591E/_^1C_]_^1C_#RSTOR1_^1_$€€DATA SYMTAB(161),SYMTAB(162),SYMTAB(163),SYMTAB(164),SYMTAB(165)_^1_#* /$2A00,$0000,$0000,$A4CC,$92B6/_^1C_]_^1C_#Q8DFLT_^1_$DATA SYMTAB(166),SYMTAB(167),SYMTAB(168),SYMTAB(169),SYMTAB(170)_^1_#* /$2E00,$0000,$0000,$9BBF,$5C6F/_^1C_]_^1C_#Q8QD2I_^1_$DATA SYMTAB(171),SYMTAB(172),SYMTAB(173),SYMTAB(174),SYMTAB(175)_^1_#* /$2E00,$0000,$0000,$9BCC,$4D9D/_^1C_]_^1C_#Q8QD2F_^1_$DATA S€€YMTAB(176),SYMTAB(177),SYMTAB(178),SYMTAB(179),SYMTAB(180)_^1_#* /$2E00,$0000,$0000,$9BCC,$4D9A/_^1C_]_^1C_#Q8QD2D_^1_$DATA SYMTAB(181),SYMTAB(182),SYMTAB(183),SYMTAB(184),SYMTAB(185)_^1_#* /$2E00,$0000,$0000,$9BCC,$4D98/_^1C_]_^1C_#Q8QZ_]_^1_$DATA SYMTAB(186),SYMTAB(187),SYMTAB(188),SYMTAB(189),SYMTAB(190)_^1_#* /$3200,$0000,$0000,$9BCC,$D5E3/_^1C_]_^1C_#DABS_]_^1_$DATA SYMTAB(€€191),SYMTAB(192),SYMTAB(193),SYMTAB(194),SYMTAB(195)_^1_#* /$2E00,$0000,$0002,$4ECE,$AC4C/_^1C_]_^1C_#DSIGN_^1_$DATA SYMTAB(196),SYMTAB(197),SYMTAB(198),SYMTAB(199),SYMTAB(200)_^1_#* /$2E00,$0000,$0003,$5193,$62B7/_^1C_]_^1C_#DSIN_]_^1_$DATA SYMTAB(201),SYMTAB(202),SYMTAB(203),SYMTAB(204),SYMTAB(205)_^1_#* /$2E00,$0000,$0002,$5193,$8E97/_^1C_]_^1C_#DCOS_]_^1_$DATA SYMTAB(206),SY€€MTAB(207),SYMTAB(208),SYMTAB(209),SYMTAB(210)_^1_#* /$2E00,$0000,$0002,$4F29,$AC4C/_^1C_]_^1C_#DATAN_^1_$DATA SYMTAB(211),SYMTAB(212),SYMTAB(213),SYMTAB(214),SYMTAB(215)_^1_#* /$2E00,$0000,$0002,$4EE0,$3F11/_^1C_]_^1C_#DSQRT_^1_$DATA SYMTAB(216),SYMTAB(217),SYMTAB(218),SYMTAB(219),SYMTAB(220)_^1_#* /$2E00,$0000,$0002,$519B,$A4FC/_^1C_]_^1C_#DLOG_]_^1_$DATA SYMTAB(221),SYMTAB(222€€),SYMTAB(223),SYMTAB(224),SYMTAB(225)_^1_#* /$2E00,$0000,$0002,$5088,$6500/_^1C_]_^1C_#DEXP_]_^1_$DATA SYMTAB(226),SYMTAB(227),SYMTAB(228),SYMTAB(229),SYMTAB(230)_^1_#* /$2E00,$0000,$0002,$4F80,$9A79/_^1C_]_^1C_#DFIX_]_^1_$DATA SYMTAB(231),SYMTAB(232),SYMTAB(233),SYMTAB(234),SYMTAB(235)_^1_#* /$2A00,$0000,$0002,$4F98,$CA01/_^1C_8END_6***** FTN 3.1 *****_^1C_]_^1C_#LOOP, EQUIVALE€€NCE, AND SPECIFICATION TABLES_^1_$DATA LOOPTS,LOOPTX,LOOPTB/50,1,5/_^1_$DATA IEQVS,IEQVN2 /255,1/_^1_$DATA ISTABS,ISTAB2/150,1/_^1_$DATA KEQVS /460/_^1C_]_^1C_#TABLE SIZE CONTROL-IBUF1,IBUF2,IWORK,INTRAS,INBUFF_^1_$DATA IBUFS/304/_^1C_]_^1C_#COMMON TABLE_^1_$DATA ICOMTS,ICOMX2,ICOMTL/12,7,6/_^1_$DATA ICOMT(1),ICOMT(2),ICOMT(3),ICOMT(4),ICOMT(5),ICOMT(6),_^1_#1ICOMT(7),ICOMT(8),ICOM€€T(9),ICOMT(10),ICOMT(11),ICOMT(12)/_^1_#10,1,0,0,0,0,0,1,0,0,0,0/_^1C_]_^1_$DATA ISSFLG/0/_^1_$DATA ISUBP,LBLANK,KSFCNT,KSNCNT,ISORSC/0,$2E2E,0,0,2/_^1_$DATA ISTNO/0/_^1_$DATA IGLAB(1),IGLAB(2),IGLAB(3),IGLAB1,IGLAB2/$2500,0,0,3,35/_^1_$DATA IHOBIT/15/_^1_$DATA JSORSC/2/_^1C_]_^1C_#TABLE OF POINTERS TO SYMBOL TABLE PRESETS_^1_$DATA ISET(1),ISET(2),ISET(3),ISET(4),ISET(5),ISET(6),IS€€ET(7),_^1_#1 ISET(8),ISET(9),ISET(10),ISET(11),ISET(12),ISET(13),ISET(14),_^1_#2 ISET(15),ISET(16),ISET(17),ISET(18),ISET(19),ISET(20),ISET(21),_^1_#3 ISET(22),ISET(23),ISET(24),ISET(25) /1,76,81,86,91,96,101,106,_^1_#4 111,116,6,11,16,21,26,31,36,41,46,51,56,61,66,71,121/_^1C_]_^1C_#INTERNAL TO BCD CONVERSION TABLE_^1_$DATA IBCDTB(1),IBCDTB(2),IBCDTB(3),IBCDTB(4)/$30,$31,$32,$33/_€€^1_$DATA IBCDTB(5),IBCDTB(6),IBCDTB(7),IBCDTB(8)/$34,$35,$36,$37/_^1_$DATA IBCDTB(9),IBCDTB(10),IBCDTB(11),IBCDTB(12)/$38,$39,$41,$42/_^1_$DATA IBCDTB(13),IBCDTB(14),IBCDTB(15),IBCDTB(16)/$43,$44,$45,$46/_^1_$DATA IBCDTB(17),IBCDTB(18),IBCDTB(19),IBCDTB(20)/$47,$48,$49,$4A/_^1_$DATA IBCDTB(21),IBCDTB(22),IBCDTB(23),IBCDTB(24)/$4B,$4C,$4D,$4E/_^1_$DATA IBCDTB(25),IBCDTB(26),IBCDTB(2€€7),IBCDTB(28)/$4F,$50,$51,$52/_^1_$DATA IBCDTB(29),IBCDTB(30),IBCDTB(31),IBCDTB(32)/$53,$54,$55,$56/_^1_$DATA IBCDTB(33),IBCDTB(34),IBCDTB(35),IBCDTB(36)/$57,$58,$59,$5A/_^1_$DATA IBCDTB(37),IBCDTB(38),IBCDTB(39),IBCDTB(40)/$24,$2E,$2B,$2D/_^1_$DATA IBCDTB(41),IBCDTB(42),IBCDTB(43),IBCDTB(44)/$3D,$28,$29,$2C/_^1_$DATA IBCDTB(45),IBCDTB(46),IBCDTB(47),IBCDTB(48)/$2F,$2A,$20,$20/_^1_€$END_]_^__ PWRLABL CSY/ 10A P€1_$SUBROUTINE RDLABL_^1_#*_2/DECK-ID 10A FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^13_]_^1C RDLABL IS USED IN PHASES A1,A2,A3,A4,A5_^1C_]_^1C_#MASTER LABELED COMMON BLOCK._^1*_] FTN 3.3_^1_$COMMON /A/ IFLAGS,LINECT,LINCT1_^1_$COMMON /A/ IR,IK,IP,IA,€€IL,IM,IXLGO,IOPTO,IOPTV,IOPTC,IOPTD_^1_$COMMON /A/ MCSTRT,MACRNB,MACSEC_^1_$COMMON /A/ IERRS(16),ISRFAD_^1_$COMMON /A/ LGO,ISCRI,ISCRO,IX_^1*_] FTN 3.3_^1_$COMMON /A/ IGLAB(3),IGLAB1,IGLAB2_^1_$COMMON /A/ ICOMT(12),ICOMTS,ICOMX2,ICOMTL,ISUBP,NDPRS,_^1_#$LABX,IBCDTB(48)_^1_$EQUIVALENCE(ICOMB,ICOMT(1)),(ICOMBX,ICOMT(2)),(ICOMDF,_^1_#$ICOMT(3)),(ICOMBN,ICOMT(4))_^1_$DIMENSION ICOMB(6€€),ICOMBX(6),ICOMDF(6),ICOMBN(7)_^1_$COMMON /A/ LOOPTS,LOOPTX,LOOPTB,LOOPT(50)_^1_$EQUIVALENCE(LINDUC,LOOPT(1))_^1_$DIMENSION LINDUC(10)_^1_$EQUIVALENCE (LBEG,LOOPT(2))_^1_$DIMENSION LBEG(10)_^1_$EQUIVALENCE (LINC,LOOPT(3))_^1_$DIMENSION LINC(10)_^1_$EQUIVALENCE (LEND,LOOPT(4))_^1_$DIMENSION LEND(10)_^1_$BYTE(LLABL,LOOPT(5)(14=0)_))_^1_$DIMENSION LLABL(10)_^1_$BYTE(LID,LOOPT(5)(15=€€15) )_^1_$DIMENSION LID(10)_^1_$COMMON/A/IEQV(255), IEQVS,IEQVN2_^1_$COMMON /A/ ISTAB(150),ISTABS,ISTAB2_^1_$COMMON /A/ IBUFS,ISET(25),LBLANK,KSFCNT,KSNCNT,ISORSC,_^1_#$IHOBIT,ISTNO,ISSFLG,ISUBPN,ITERM,JSORSC,KEQVS_^1C_#SYMBOL TABLE LABELED COMMON BLOCK_^1_$COMMON /A/ ISYMN, ISYMFL,ISYMD,ISYMX,ISYMS,ISYMP,ISYMPC,ISYMPS,_^1_#$ ISYMNS, SYMTAB(960)_^1_$INTEGER SYMTAB_^1_$BYTE (IDUM,S€€YMTAB(1)(15=15)),(KDUMY,SYMTAB(1)(15=15)),_^1_#$(ICLASS,SYMTAB(1)(14=11)),(ITYPE,SYMTAB(1)(10=9))_^1_$DIMENSION IDUM(100),KDUMY(100),ICLASS(100),ITYPE(100)_^1_$BYTE (ISNGL, SYMTAB(1)(8=8)),(KELSIZ,SYMTAB(1)(8=8)),_^1_#$ (ICOM,SYMTAB(1)(7=5)),(IPART,SYMTAB(1)(4=3))_^1_$DIMENSION ISNGL(100),KELSIZ(100),ICOM(100),IPART(100)_^1_$BYTE (KRFCNT,SYMTAB(1)(2=2)),(IDIM,SYMTAB(1)(1=0)),_^1_#$€€ (IREL,SYMTAB(1)(1=1)),(IEXT,SYMTAB(1)(0=0))_^1_$DIMENSION KRFCNT(100),IDIM(100),IREL(100),IEXT(100)_^1_$EQUIVALENCE (IRSA,SYMTAB(2)),(ICOMTX,SYMTAB(2)),(ISNOL,SYMTAB(2))_^1_$DIMENSION IRSA(100), ICOMTX(100),ISNOL(100)_^1_$BYTE (IDATAS,SYMTAB(3)(15=15)),(IREF,SYMTAB(3)(15=15)),_^1_#$ (IEQVX,SYMTAB(3)(14=8)),(ITILF,SYMTAB(3)(14=8))_^1_$DIMENSION IDATAS(100),IREF(100),IEQVX(100),ITIL€€F(100)_^1_$BYTE (IPARTR,SYMTAB(3)(7=4)),(INDUCV,SYMTAB(3)(7=7)),(ISFARG,_^1_#$ SYMTAB(3)(6=6)),(IARGNO,SYMTAB(3)(5=0)),(IPARTL,SYMTAB(3)(3=0))_^1_$DIMENSION IPARTR(100),INDUCV(100),ISFARG(100),IARGNO(100),_^1_#$ IPARTL(100)_^1_$EQUIVALENCE (ISYM,SYMTAB(4))_^1_$DIMENSION ISYM(100)_^1C_]_^1C_#SPECIFICATION-TABLE INDEX LABELLED COMMON BLOCK_^1_$COMMON /A/ ISTABX(96)_^1C_]_^1C_#PHASE A€€ BLANK COMMON BLOCK._^1_$COMMON // JSYM(3),JTERM,JMODE,JERR,JESWT,JFLOT,JCHAR,_^1_#$JOCHAR,JO1,JE,JE1,JBLANK,JCT,JCT1_^1C_#JSYM-JCT1 MUST REMAIN IN ORDER_^1_$COMMON//IERR_^1_$COMMON//ISORS(208),ISORSX_^1_$COMMON//IDEFF,ISTOP,IRET,ISPEC,NERR,OCT_^1_$INTEGER OCT_^1_$COMMON//ILLABL,LEST,ISNGL1,ICOMX1,NXTYPE,LOGIF,IOVFL1,IOVFL2_^1_$COMMON//IVCFLG,ISFLG,LOGEX,KEQVX_^1_$COMMON//IBUF2X,IB€€UF2(304)_^1C_$TEMPORARY ARITHMETIC BUFFERS_^1_$COMMON//IBUF1( 304),IBUF1X,IWORK (304)_^1C_#TEMPORARY EQUIVALENCE BUFFERS_^1_$DIMENSION KEQV(460),MEQV(255)_^1_$EQUIVALENCE (KEQV,IBUF1(66)),(MEQV,IBUF2(100))_^1C_#LS1-ITEM MUST REMAIN IN ORDER_^1_$COMMON//LS1,LPREN,LRELRQ,LRELEN,LSWITC,LO,ITEM_^1_$COMMON//MODE_^1_$COMMON//IPHAT(4),IGNSTT(49),IOSPRT(17)_^1C_]_^1C_]_^1C_#READ A LABEL FR€€OM ISORS AND PACK IT INTO JSYM._^1_$DIMENSION LCHARS(6)_^1_$ILLABL=0_^1_$IZC = 0_^1C_#INITIALIZE LEADING ZERO COUNTER_^1C_]_^1C_#SAVE INITIAL VALUE OF JBLANK IN ORDER TO BE ABLE TO RESTORE_^1C_(UPON EXIT_^1C_#INITIALIZE COLUMN COUNTER - ICOLMC_^1_$JBTEMP = JBLANK_^1C_]_^1_$ICOLMC = 0_^1C_]_^1C_#SET CHARACTERS TO BLANKS_^1C_#LCHARS(I) IS THE ARRAY OF CHARACTERS IN THE LABEL - WHAT €€THE_^1C_(CHARACTER ACTUALLY IS_^1C_]_^1_$DO 3 I=1,6_^1_"3 LCHARS(I)=46_^1C_]_^1C_#SET PACKING PARAMETERS._^1C_#ILEAD IS A FLAG FOR LEADING ZEROS - IF ILEAD=0, THEN CHARACTER_^1C_(IS A LEADING ZERO, OTHERWISE IT IS NOT A LEADING ZERO_^1C_#LCHARC IS THE CHARACTER COUNTER OF THE LABEL_^1C_]_^1_$ILEAD=0_^1_$LCHARC=1_^1_$GO TO 1_^1C_#STORE LABEL CHARACTER_^1C_]_^1_"2 LCHARS(LCHARC)=JCHA€€R_^1_$ILLABL=1_^1_$ILEAD=1_^1_$LCHARC=LCHARC+1_^1C_]_^1C_#JUMP IF EITHER 5 NUMBERS HAVE BEEN PROCESSED FOR THE LABEL OR IF_^1C_#THE NEXT COLUMN TO BE PROCESSED IS COLUMN 7._^1C_]_^1C_#INITIALIZE JBLANK FOR GETC - TO ALLOW BLANKS TO BE PRESENTED_^1_"1 JBLANK = 1_^1_$CALL GETC_^1_$IF (LCHAR.EQ.7) GO TO 4_^1C_#ISORSX IS THE PARAMETER USED BY GETC TO DETERMINE AT WHICH COLUMN_^1C_(TO S€€TART GETTING A CHARACTER_^1_$IF (ICOLMC.EQ.5.AND.ISORSX.LE.6) GO TO 4_^1C_#PROCESS THE NEXT CHARACTER._^1_$GO TO 5_^1C_#SET LEADING ZERO COUNTER - TO BE ABLE TO CHECK FOR A ZERO LABEL_^1_!10 IZC = 1_^1_$GO TO 1_^1C_#INCREMENT COLUMN COUNTER_^1_"5 ICOLMC = ICOLMC + 1_^1C_#JUMP IF CHATACTER IS A LEADING ZERO_^1C_#JCHAR IS THE CHARACTER WHICH IS READ BY GETC AND PASSED TO RDLABL_^1_$I€€F(ILEAD+JCHAR.EQ.0) GO TO 10_^1C_#JUMP IF CHARACTER IS A BLANK_^1_$IF (JCHAR.EQ.46) GO TO 1_^1C_#JUMP IF CHARACTER IS A NUMBER._^1_$IF(JCHAR.LE.9) GO TO 2_^1C_#PRINT DIAGNOSTIC 54 IF CHARACTER IN THE LABEL WHICH LIES IN_^1C_(COLUMNS 1-5 IS NOT A NUMBER, BLANK, OR STATEMENT TERMINATOR_^1_$IF (JCHAR.LE.45.AND.ISORSX.LE.6) CALL DIAG($3036)_^1C_#SET TERMINATOR, PACK LABEL INTO JSYM, AN€€D RETURN._^1_"4 JTERM=JCHAR_^1C_#RESTORE JBLANK TO VALUE IT ENTERED WITH_^1_$JBLANK = JBTEMP_^1C_#CHECK FOR A ZERO LABEL_^1C_#IF ZERO STATEMENT LABEL, PRINT DIAGNOSTIC 59_^1_$IF (IZC.EQ.1.AND.ILLABL.EQ.0) CALL DIAG($103B)_^1C ********************************** PSR 1115 **************************_^1C ********************************** PSR 1115 **************************_^1_$IF(JCHAR€€.GE.10.AND.JCHAR.LE.35) GO TO 31_^1_$DO 30 IT15=1,6_^1_$IF(LCHARS(IT15).NE.46) GO TO 31_^1_!30 CONTINUE_^1C ALL SPACES -- OUTPUT FATAL ERROR 59_^1_$CALL DIAG($3B)_^1_!31 CONTINUE_^1C ********************************** PSR 1115 **************************_^1C ********************************** PSR 1115 **************************_^1_$JSYM(1)=LCHARS(1)*256+LCHARS(2)_^1_$JSYM(2)=LCHARS€b(3)*256+LCHARS(4)_^1_$JSYM(3)=LCHARS(5)*256+LCHARS(6)_^1_$CALL CNVT_^1_$CALL SYMBOL_^1_$END_]_^__ bPWSCHAR CSY/ 11A P€1_$SUBROUTINE STCHAR(IMAGE,ICOLMN,ICHARC)_^1_#*_2/DECK-ID 11A FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^13_]_^1C STCHAR IS USED IN PHASES A1,A2,A3,A4,A5_^1C_]_^1C_]_^1C_]_^1C_#THIS ROUTINE STORES ICHARC INTO THE ICOLMN TH CHARACTER OF IMAGE._^1C_]_^1€_$DIMENSION IMAGE(36),IHOCHR(36),ILOCHR(36)_^1_$BYTE(IOEBIT,ICOLMN(0=0)),(IHOCHR_!,IMAGE(1)(15=8)),_^1_#1(ILOCHR_!,IMAGE(1)(7=0))_^1_$ITEMP1=(ICOLMN+1)/2_^1_$IF(IOEBIT.NE.0) GO TO 1_^1_$ILOCHR(ITEMP1)=ICHARC_^1_$RETURN_^1_"1 IHOCHR(ITEMP1)=ICHARC_^1_$END_]_^__PWTYPE CSY/ 12A P€1_$SUBROUTINE TYPE(IX1)_^1_#*_2/DECK-ID 12A FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^13_]_^1C TYPE IS USED IN PHASES A1,A2,A3,A4,A5_^1C_]_^1C_#MASTER LABELED COMMON BLOCK._^1*_] FTN 3.3_^1_$COMMON /A/ IFLAGS,LINECT,LINCT1_^1_$COMMON /A/ IR,IK,IP,IA€€,IL,IM,IXLGO,IOPTO,IOPTV,IOPTC,IOPTD_^1_$COMMON /A/ MCSTRT,MACRNB,MACSEC_^1_$COMMON /A/ IERRS(16),ISRFAD_^1_$COMMON /A/ LGO,ISCRI,ISCRO,IX_^1*_] FTN 3.3_^1_$COMMON /A/ IGLAB(3),IGLAB1,IGLAB2_^1_$COMMON /A/ ICOMT(12),ICOMTS,ICOMX2,ICOMTL,ISUBP,NDPRS,_^1_#$LABX,IBCDTB(48)_^1_$EQUIVALENCE(ICOMB,ICOMT(1)),(ICOMBX,ICOMT(2)),(ICOMDF,_^1_#$ICOMT(3)),(ICOMBN,ICOMT(4))_^1_$DIMENSION ICOMB(€€6),ICOMBX(6),ICOMDF(6),ICOMBN(7)_^1_$COMMON /A/ LOOPTS,LOOPTX,LOOPTB,LOOPT(50)_^1_$EQUIVALENCE(LINDUC,LOOPT(1))_^1_$DIMENSION LINDUC(10)_^1_$EQUIVALENCE (LBEG,LOOPT(2))_^1_$DIMENSION LBEG(10)_^1_$EQUIVALENCE (LINC,LOOPT(3))_^1_$DIMENSION LINC(10)_^1_$EQUIVALENCE (LEND,LOOPT(4))_^1_$DIMENSION LEND(10)_^1_$BYTE(LLABL,LOOPT(5)(14=0)_))_^1_$DIMENSION LLABL(10)_^1_$BYTE(LID,LOOPT(5)(15€€=15) )_^1_$DIMENSION LID(10)_^1_$COMMON/A/IEQV(255), IEQVS,IEQVN2_^1_$COMMON /A/ ISTAB(150),ISTABS,ISTAB2_^1_$COMMON /A/ IBUFS,ISET(25),LBLANK,KSFCNT,KSNCNT,ISORSC,_^1_#$IHOBIT,ISTNO,ISSFLG,ISUBPN,ITERM,JSORSC,KEQVS_^1C_#SYMBOL TABLE LABELED COMMON BLOCK_^1_$COMMON /A/ ISYMN, ISYMFL,ISYMD,ISYMX,ISYMS,ISYMP,ISYMPC,ISYMPS,_^1_#$ ISYMNS, SYMTAB(960)_^1_$INTEGER SYMTAB_^1_$BYTE (IDUM,€€SYMTAB(1)(15=15)),(KDUMY,SYMTAB(1)(15=15)),_^1_#$(ICLASS,SYMTAB(1)(14=11)),(ITYPE,SYMTAB(1)(10=9))_^1_$DIMENSION IDUM(100),KDUMY(100),ICLASS(100),ITYPE(100)_^1_$BYTE (ISNGL, SYMTAB(1)(8=8)),(KELSIZ,SYMTAB(1)(8=8)),_^1_#$ (ICOM,SYMTAB(1)(7=5)),(IPART,SYMTAB(1)(4=3))_^1_$DIMENSION ISNGL(100),KELSIZ(100),ICOM(100),IPART(100)_^1_$BYTE (KRFCNT,SYMTAB(1)(2=2)),(IDIM,SYMTAB(1)(1=0)),_^1_#€€$ (IREL,SYMTAB(1)(1=1)),(IEXT,SYMTAB(1)(0=0))_^1_$DIMENSION KRFCNT(100),IDIM(100),IREL(100),IEXT(100)_^1_$EQUIVALENCE (IRSA,SYMTAB(2)),(ICOMTX,SYMTAB(2)),(ISNOL,SYMTAB(2))_^1_$DIMENSION IRSA(100), ICOMTX(100),ISNOL(100)_^1_$BYTE (IDATAS,SYMTAB(3)(15=15)),(IREF,SYMTAB(3)(15=15)),_^1_#$ (IEQVX,SYMTAB(3)(14=8)),(ITILF,SYMTAB(3)(14=8))_^1_$DIMENSION IDATAS(100),IREF(100),IEQVX(100),ITI€€LF(100)_^1_$BYTE (IPARTR,SYMTAB(3)(7=4)),(INDUCV,SYMTAB(3)(7=7)),(ISFARG,_^1_#$ SYMTAB(3)(6=6)),(IARGNO,SYMTAB(3)(5=0)),(IPARTL,SYMTAB(3)(3=0))_^1_$DIMENSION IPARTR(100),INDUCV(100),ISFARG(100),IARGNO(100),_^1_#$ IPARTL(100)_^1_$EQUIVALENCE (ISYM,SYMTAB(4))_^1_$DIMENSION ISYM(100)_^1C_]_^1C_#SPECIFICATION-TABLE INDEX LABELLED COMMON BLOCK_^1_$COMMON /A/ ISTABX(96)_^1C_]_^1C_#PHASE €€A BLANK COMMON BLOCK._^1_$COMMON // JSYM(3),JTERM,JMODE,JERR,JESWT,JFLOT,JCHAR,_^1_#$JOCHAR,JO1,JE,JE1,JBLANK,JCT,JCT1_^1C_#JSYM-JCT1 MUST REMAIN IN ORDER_^1_$COMMON//IERR_^1_$COMMON//ISORS(208),ISORSX_^1_$COMMON//IDEFF,ISTOP,IRET,ISPEC,NERR,OCT_^1_$INTEGER OCT_^1_$COMMON//ILLABL,LEST,ISNGL1,ICOMX1,NXTYPE,LOGIF,IOVFL1,IOVFL2_^1_$COMMON//IVCFLG,ISFLG,LOGEX,KEQVX_^1_$COMMON//IBUF2X,I€€BUF2(304)_^1C_$TEMPORARY ARITHMETIC BUFFERS_^1_$COMMON//IBUF1( 304),IBUF1X,IWORK (304)_^1C_#TEMPORARY EQUIVALENCE BUFFERS_^1_$DIMENSION KEQV(460),MEQV(255)_^1_$EQUIVALENCE (KEQV,IBUF1(66)),(MEQV,IBUF2(100))_^1C_#LS1-ITEM MUST REMAIN IN ORDER_^1_$COMMON//LS1,LPREN,LRELRQ,LRELEN,LSWITC,LO,ITEM_^1_$COMMON//MODE_^1_$COMMON//IPHAT(4),IGNSTT(49),IOSPRT(17)_^1C_]_^1C_]_^1C_#THIS ROUTINE C€€OMPUTES THE STATEMENT TYPE OF THE STATEMENT IN ISORS_^1C_#THE SPECIFICATION TABLE AND ASSOCIATED PARAMETERS._^1C_8BEGIN_4***** FTN 3.1 *****_^1_$DIMENSION ISTN (340)_^1C_8END_6***** FTN 3.1 *****_^1_$DATA ISTN(1),ISTN(2),ISTN(3),ISTN(4)/12,13,18,22/_^1C_MD I M_^1_$DATA ISTN(5),ISTN(6),ISTN(7),ISTN(8)/14,23,28,18/_^1C_JE N S I_^1_$DATA ISTN(9),ISTN(10),ISTN(11),ISTN(12)/24,23,0€€,26/_^1C_MO N 0 26_^1_$DATA ISTN(13),ISTN(14),ISTN(15),ISTN(16)/27,14,10,21/_^1C_NR E A L_^1_$DATA ISTN(17),ISTN(18),ISTN(19),ISTN(20)/15,30,23,12/_^1C_NF U N C_^1_$DATA ISTN(21),ISTN(22),ISTN(23),ISTN(24)/29,18,24,23/_^1C_NT I O N_^1_$DATA ISTN(25),ISTN(26),ISTN(27),ISTN(28)/5,32,27,14/_^1C_M5_#R E_^1_$DATA ISTN(29),ISTN(30),ISTN(31),ISTN(32)/10,21,3,49/_^1C_NA L 3_^1€€_$DATA ISTN(33),ISTN(34),ISTN(35),ISTN(36)/18,23,29,14/_^1C_NI N T E_^1_$DATA ISTN(37),ISTN(38),ISTN(39),ISTN(40)/16,14,27,15/_^1C_NG E R F_^1_$DATA ISTN(41),ISTN(42),ISTN(43),ISTN(44)/30,23,12,29/_^1C_NU N C T_^1_$DATA ISTN(45),ISTN(46),ISTN(47),ISTN(48)/18,24,23,4/_^1C_NI O N 4_^1_$DATA ISTN(49),ISTN(50),ISTN(51),ISTN(52)/58,18,23,29/_^1C_QI N T_^1_$DATA ISTN(53),IST€€N(54),ISTN(55),ISTN(56)/14,16,14,27/_^1C_NE G E R_^1_$DATA ISTN(57),ISTN(58),ISTN(59),ISTN(60)/2,64,11,34/_^1C_M2_#B Y_^1_$DATA ISTN(61),ISTN(62),ISTN(63),ISTN(64)/29,14,8,76/_^1C_NT E 8_^1_$DATA ISTN(65),ISTN(66),ISTN(67),ISTN(68)/28,18,16,23/_^1C_NS I G N_^1_$DATA ISTN(69),ISTN(70),ISTN(71),ISTN(72)/14,13,11,34/_^1C_NE D B Y_^1_$DATA ISTN(73),ISTN(74),ISTN(75),ISTN(76)€€/29,14,9,84/_^1C_NT E 9_^1_$DATA ISTN(77),ISTN(78),ISTN(79),ISTN(80)/12,24,22,22/_^1C_NC O M M_^1_$DATA ISTN(81),ISTN(82),ISTN(83),ISTN(84)/24,23,1,96/_^1C_NO N 1_^1_$DATA ISTN(85),ISTN(86),ISTN(87),ISTN(88)/28,30,11,27/_^1C_NS U B R_^1_$DATA ISTN(89),ISTN(90),ISTN(91),ISTN(92)/24,30,29,18/_^1C_NO U T I_^1_$DATA ISTN(93),ISTN(94),ISTN(95),ISTN(96)/23,14,15,109/_^1C_NN E€€ 15_^1_$DATA ISTN(97),ISTN(98),ISTN(99),ISTN(100)/14,26,30,18/_^1C_OE Q U I_^1_$DATA ISTN(101),ISTN(102),ISTN(103),ISTN(104)/31,10,21,14/_^1C_RV A L E_^1_$DATA ISTN(105),ISTN(106),ISTN(107),ISTN(108)/23,12,14,12/_^1C_RN C E 12_^1_$DATA ISTN(109),ISTN(110),ISTN(111),ISTN(112)/119,15,30,23/_^1C_VF U N_^1_$DATA ISTN(113),ISTN(114),ISTN(115),ISTN(116)/12,29,18,24/_^1C_RC T €€I O_^1_$DATA ISTN(117),ISTN(118),ISTN(119),ISTN(120)/23,14,129,14/_^1C_RN 14_$E_^1_$DATA ISTN(121),ISTN(122),ISTN(123),ISTN(124)/33,29,14,27/_^1C_RX T E R_^1_$DATA ISTN(125),ISTN(126),ISTN(127),ISTN(128)/23,10,21,10/_^1C_RN A L 10_^1_$DATA ISTN(129),ISTN(130),ISTN(131),ISTN(132)/138,25,27,24/_^1C_VP R O_^1_$DATA ISTN(133),ISTN(134),ISTN(135),ISTN(136)/16,27,10,22/_^1C_RG R€€ A M_^1_$DATA ISTN(137),ISTN(138),ISTN(139),ISTN(140)/6,149,11,21/_^1C_Q6_$B L_^1_$DATA ISTN(141),ISTN(142),ISTN(143),ISTN(144)/24,12,20,13/_^1C_RO C K D_^1_$DATA ISTN(145),ISTN(146),ISTN(147),ISTN(148)/10,29,10,13/_^1C_RA T A 13_^1_$DATA ISTN(149),ISTN(150),ISTN(151),ISTN(152)/159,27,14,21/_^1C_VR E L_^1_$DATA ISTN(153),ISTN(154),ISTN(155),ISTN(156)/10,29,18,31/_^1C_RA €€T I V_^1_$DATA ISTN(157),ISTN(158),ISTN(159),ISTN(160)/14,11,167,28/_^1C_RE 11_$S_^1_$DATA ISTN(161),ISTN(162),ISTN(163),ISTN(164)/18,23,16,21/_^1C_RI N G L_^1C_8BEGIN_4***** FTN 3.1 *****_^1_$DATA ISTN(165),ISTN(166),ISTN(167),ISTN(168)/14,7,192,13/_^1C_RE 7_$D_^1_$DATA ISTN(169),ISTN(170),ISTN(171),ISTN(172)/24,30,11,21/_^1C_RO U B L_^1_$DATA ISTN(173),ISTN(174),ISTN(175)€€,ISTN(176)/14,25,27,14/_^1C_RE P R E_^1_$DATA ISTN(177),ISTN(178),ISTN(179),ISTN(180)/12,18,28,18/_^1C_RC I S I_^1_$DATA ISTN(181),ISTN(182),ISTN(183),ISTN(184)/24,23,15,30/_^1C_RO N F U_^1_$DATA ISTN(185),ISTN(186),ISTN(187),ISTN(188)/23,12,29,18/_^1C_RN C T I_^1_$DATA ISTN(189),ISTN(190),ISTN(191),ISTN(192)/24,23,47,209/_^1C_RO N 47_^1_$DATA ISTN(193),ISTN(194),ISTN(€€195),ISTN(196)/13,24,30,11/_^1C_RD O U B_^1_$DATA ISTN(197),ISTN(198),ISTN(199),ISTN(200)/21,14,25,27/_^1C_RL E P R_^1_$DATA ISTN(201),ISTN(202),ISTN(203),ISTN(204)/14,12,18,28/_^1C_RE C I S_^1_$DATA ISTN(205),ISTN(206),ISTN(207),ISTN(208)/18,24,23,46/_^1C_RI O N 46_^1_$DATA ISTN(209),ISTN(210),ISTN(211),ISTN(212)/213,18,15,42/_^1C_RI F 42_^1_$DATA ISTN(213),ISTN(214),I€€STN(215),ISTN(216)/219,16,24,29/_^1C_VG O T_^1_$DATA ISTN(217),ISTN(218),ISTN(219),ISTN(220)/24,24,225,12/_^1C_RO 24_$C_^1_$DATA ISTN(221),ISTN(222),ISTN(223),ISTN(224)/10,21,21,21/_^1C_RA L L 21_^1_$DATA ISTN(225),ISTN(226),ISTN(227),ISTN(228)/235,12,24,23/_^1C_VC O N_^1_$DATA ISTN(229),ISTN(230),ISTN(231),ISTN(232)/29,18,23,30/_^1C_RT I N U_^1_$DATA ISTN(233),ISTN(234),€€ISTN(235),ISTN(236)/14,27,239,13/_^1C_RE 27_$D_^1_$DATA ISTN(237),ISTN(238),ISTN(239),ISTN(240)/24,40,247,15/_^1C_RO 40_$F_^1_$DATA ISTN(241),ISTN(242),ISTN(243),ISTN(244)/24,27,22,10/_^1C_RO R M A_^1_$DATA ISTN(245),ISTN(246),ISTN(247),ISTN(248)/29,17,253,13/_^1C_RT 17_$D_^1_$DATA ISTN(249),ISTN(250),ISTN(251),ISTN(252)/10,29,10,16/_^1C_RA T A 16_^1_$DATA ISTN(253),ISTN(254),€€ISTN(255),ISTN(256)/259,27,14,10/_^1C_VR E A_^1_$DATA ISTN(257),ISTN(258),ISTN(259),ISTN(260)/13,36,266,32/_^1C_RD 36_$W_^1_$DATA ISTN(261),ISTN(262),ISTN(263),ISTN(264)/27,18,29,14/_^1C_RR I T E_^1_$DATA ISTN(265),ISTN(266),ISTN(267),ISTN(268)/38,274,27,14/_^1C_R38_$R E_^1_$DATA ISTN(269),ISTN(270),ISTN(271),ISTN(272)/29,30,27,23/_^1C_RT U R N_^1_$DATA ISTN(273),ISTN(274)€€,ISTN(275),ISTN(276)/22,282,27,14/_^1C_R22_$R E_^1_$DATA ISTN(277),ISTN(278),ISTN(279),ISTN(280)/32,18,23,13/_^1C_RW I N D_^1_$DATA ISTN(281),ISTN(282),ISTN(283),ISTN(284)/34,293,11,10/_^1C_R34_$B A_^1_$DATA ISTN(285),ISTN(286),ISTN(287),ISTN(288)/12,20,28,25/_^1C_RC K S P_^1_$DATA ISTN(289),ISTN(290),ISTN(291),ISTN(292)/10,12,14,35/_^1C_RA C E 35_^1_$DATA ISTN(293),ISTN(€€294),ISTN(295),ISTN(296)/302,14,23,13/_^1C_VE N D_^1_$DATA ISTN(297),ISTN(298),ISTN(299),ISTN(300)/15,18,21,14/_^1C_RF I L E_^1_$DATA ISTN(301),ISTN(302),ISTN(303),ISTN(304)/33,310,10,28/_^1C_R33_$A S_^1_$DATA ISTN(305),ISTN(306),ISTN(307),ISTN(308)/28,18,16,23/_^1C_RS I G N_^1_$DATA ISTN(309),ISTN(310),ISTN(311),ISTN(312)/20,316,28,29/_^1C_Q20_$S T_^1_$DATA ISTN(313),IST€€N(314),ISTN(315),ISTN(316)/24,25,28,323/_^1C_R0 P 28_^1_$DATA ISTN(317),ISTN(318),ISTN(319),ISTN(320)/25,10,30,28/_^1C_RP A U S_^1_$DATA ISTN(321),ISTN(322),ISTN(323),ISTN(324)/14,30,330,10/_^1C_RE 30_$A_^1_$DATA ISTN(325),ISTN(326),ISTN(327),ISTN(328)/28,28,14,22/_^1C_RS S E M_^1_$DATA ISTN(329),ISTN(330),ISTN(331),ISTN(332)/44,336,24,25/_^1C_Q44_$O P_^1_$DATA ISTN(333),IS€€TN(334),ISTN(335),ISTN(336)/14,23,45,341/_^1C_RE N 45_^1_$DATA ISTN(337),ISTN(338),ISTN(339),ISTN(340)/14,23,13,32/_^1C_"THIS IS_!END OF TABLE_8E N D 32_^1C_8END_6***** FTN 3.1 *****_^1_$IX1=0_^1_$ITS1=0_^1_$ISORSX=7_^1 1000 JCHAR=43_^1C_]_^1C_#READ THE NEXT CHARACTER._^1C_]_^1 1001 ITEMP1=JCHAR_^1_$CALL GETC_^1C_]_^1C_#JUMP IF NOT ALPHANUMERIC_^1C_]_^1 957 IF(JCHAR.GT.35) GO T€€O 1_^1C_]_^1C_#JUMP IF ALPHABETIC._^1C_]_^1_$IF(JCHAR.GE.10) GO TO 1001_^1C_]_^1C_#JUMP IF CANNOT BE HOLLERITH CONSTANT._^1C_]_^1_$IF(ITEMP1.LE.35) GO TO 1001_^1_$ITEMP2=JCHAR_^1_"3 CALL GETC_^1C_]_^1C_#JUMP IF NOT NUMERIC._^1C_]_^1_$IF(JCHAR.GE.10) GO TO 2_^1_$IF(ITEMP2.GT.400 ) GO TO 1001_^1_$ITEMP2=ITEMP2*10+JCHAR_^1_$GO TO 3_^1C_]_^1C_#JUMP IF NOT H._^1C_]_^1_"2 IF(JCHAR.EQ.17)€€ GO TO 956_^1_$ITEMP1=JCHAR_^1_$GO TO 957_^1 956 JBLANK=1_^1_$DO 4 I=1,ITEMP2_^1_$CALL GETC_^1_$IF(JCHAR.NE.47) GO TO 4_^1_$JBLANK=0_^1_$GO TO 1006_^1_"4 CONTINUE_^1_$JBLANK=0_^1_$GO TO 1000_^1C_]_^1C_!*************************************** 1635*71 ********************_^1C_#JUMP IF CHARACTER IS A SINGLE QUOTE_^1C_#CAN NOT BE A REPLACEMENT STATEMENT_^1_"1 IF (JCHAR.EQ.48) GOTO 100€€6_^1C_!*************************************** 1635*71 ********************_^1C_#JUMP IF TERMINATOR NOT (_^1C_]_^1_$IF (JCHAR.NE.41) GOTO 1003_^1_$ITS1=ITS1+1_^1_$GO TO 1001_^1C_]_^1C_#JUMP IF TERMINATOR NOT )_^1C_]_^1 1003 IF(JCHAR.NE.42) GO TO 1004_^1_$ITS1=ITS1-1_^1_$GO TO 1001_^1C_]_^1C_#JUMP IF TERMINATOR NOT ,_^1C_]_^1 1004 IF(JCHAR.NE.43) GO TO 1005_^1_$IF(ITS1.EQ.0) GO TO 1€€006_^1_$GO TO 1001_^1C_]_^1C_#JUMP IF TERMINATOR NOT UNPARENTHESIZED =_^1C_]_^1 1005 IF(JCHAR.NE.40.OR.ITS1.NE.0) GO TO 1007_^1C ********************************** PSR 705 **************************_^1C ********************************** PSR 705 **************************_^1C_]_^1C_$JUMP IF 1ST CHAR NOT ALPHANUMERIC OR $_^1C_]_^1_%CALL GETC_^1_%IF(JCHAR.GT.36) GO TO 999_^1C *****€€***************************** PSR 705 **************************_^1C_] FTN 3.3_^1_$IF(JCHAR.EQ.0.OR.JCHAR.GT.2) GO TO 955_^1_$ITEMP2=JCHAR_^1_$CALL GETC_^1_$IF(JCHAR.NE.10.AND.JCHAR.NE.17) GO TO 955_^1_$JBLANK=1_^1_$DO 50 I=1,ITEMP2_^1_$CALL GETC_^1_$IF(JCHAR.EQ.47) GO TO 999_^1_!50 CONTINUE_^1_$JBLANK=0_^1C_] FTN 3.3_^1 954 CALL GETC_^1C_]_^1C_#JUMP IF ALPHANUMERIC._^1C_]_^1C_€€] FTN 3.3_^1 955 IF(JCHAR.LE.35) GO TO 954_^1C_] FTN 3.3_^1C_]_^1C_#JUMP IF TERMINATOR ,_^1C ********************************** PSR 705 **************************_^1 999_!IF(JCHAR.EQ.43) GO TO 1006_^1C ********************************** PSR 705 **************************_^1C ********************************** PSR 705 **************************_^1C_#SET UP AS ARITHMETIC REPLAC€€EMENT._^1C_]_^1_$IBUF2(3)=18_^1_$RETURN_^1C_]_^1C_#JUMP IF NOT END-OF-STATEMENT_^1C_]_^1 1007 IF(JCHAR.NE.37) GO TO 961_^1_$ISORSX=ISORSX-1_^1_$NERR=1_^1_$CALL GETF_^1C_]_^1C_#JUMP IF RELATIONAL._^1C_]_^1C ************************************************************_!85*2017_^1C_]_^1_$IF ((JMODE.EQ.0.OR.JMODE.EQ.5.OR.JMODE.EQ.6).AND.JTERM.GE.256)_^1_#*_!GO TO 1006_^1C_]_^1C *******€€*****************************************************_!85*2017_^1C_]_^1C_#JUMP IF NOT END-OF-STATEMENT_^1C_]_^1 961 IF(JCHAR.NE.47) GO TO 1001_^1 1006 I=2_]_^1C_8BEGIN_4***** FTN 3.1 *****_^1_$IF(ISPEC.NE.0) I=210_^1C_8END_6***** FTN 3.1 *****_^1 953 ISORSX=7_^1_$ITEMP1=ISTN(I-1)_^1C_]_^1C_#COMPARE TO TABLE DELIMETER._^1C_]_^1_$ITEMP2=ITEMP1-I-1_^1_$DO 951 ITS1=1,ITEMP2_^1_$CALL €TGETC_^1C_]_^1C_#JUMP IF NOT THIS DELIMETER._^1C_]_^1_$IF(JCHAR-ISTN(I))952 ,951,952_^1 952 I=ITEMP1+1_^1C_]_^1C_#JUMP IF MORE IN ISTN._^1C_]_^1_$IF(ISTN(I-2).NE.32) GO TO 953_^1C_]_^1C_#STATEMENT TYPE UNRECOGNIZABLE._^1C_]_^1 1002 IX1=1_^1_$RETURN_^1 951 I=I+1_^1C_]_^1C_#HAVE FOUND CORRECT TYPE._^1C_]_^1_$IBUF2(3)=ISTN(I)_^1_$END_]_^__ TPWSAVID CSY/ 13A P€1_$SUBROUTINE SAVEID_^1_#*_2/DECK-ID 13A FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^13_]_^1C ********************************** FTN 3.0 **************************_^1C ********************************** FTN 3.0 **************************_^1C_#THIS PR€€OGRAM WILL STORE 47 LEGAL FORTRAN CHARACTERS, PRECEEDED_^1C_#BY A /, FROM THE ROUTINE IDENTIFICATION CARD (PROGRAM, SUBROUTINE,_^1C_#FUNCTION, REAL FUNCTION, INTEGER FUNCTION, OR BLOCK DATA)_^1C_-ON MASS MEMORY. THIS INFORMATION WILL BE ADDED ON TO THE_^1C_#BINARY NAM CARD IN ASCII BEGINNING IN COL. 17. IF THE CHARACTERS_^1C_#ARE NOT PRECEEDED BY A /, A DIAGNOSTIC WILL BE ISSUED(€€ERROR 3-MORE_^1C_#THAN 6 CHARACTERS IN A NAME, OR ERROR 66-SUPERFLOUOUS INFORMATION_^1C_#IN THIS STATEMENT IS IGNORED) DEPENDING ON THE TYPE OF STATEMENT_^1C_#BEING USED. THE CHARACTERS MAY CONTINUE ON A CONTINUATION CARD._^1C_#**MOD** ONLY 45 CHARACTERS ARE TAKEN FROM THE IDENT CARD. TWO_^1C_#SPACES ARE INSERTED IMMEDIATELY AFTER THE SLASH. THE RESULT_^1C_#IS THE SAME AS AN AS€€SEMBLY-PRODUCED BINARY NAM CARD WITH COMMENTS_^1C_#STARTING IN COLUMN 27. **MOD**_^1C_]_^1C_#MASTER LABELED COMMON BLOCK._^1*_] FTN 3.3_^1_$COMMON /A/ IFLAGS,LINECT,LINCT1_^1_$COMMON /A/ IR,IK,IP,IA,IL,IM,IXLGO,IOPTO,IOPTV,IOPTC,IOPTD_^1_$COMMON /A/ MCSTRT,MACRNB,MACSEC_^1_$COMMON /A/ IERRS(16),ISRFAD_^1_$COMMON /A/ LGO,ISCRI,ISCRO,IX_^1*_] FTN 3.3_^1_$COMMON /A/ IGLAB(3),IGLAB1€€,IGLAB2_^1_$COMMON /A/ ICOMT(12),ICOMTS,ICOMX2,ICOMTL,ISUBP,NDPRS,_^1_#$LABX,IBCDTB(48)_^1_$EQUIVALENCE(ICOMB,ICOMT(1)),(ICOMBX,ICOMT(2)),(ICOMDF,_^1_#$ICOMT(3)),(ICOMBN,ICOMT(4))_^1_$DIMENSION ICOMB(6),ICOMBX(6),ICOMDF(6),ICOMBN(7)_^1_$COMMON /A/ LOOPTS,LOOPTX,LOOPTB,LOOPT(50)_^1_$EQUIVALENCE(LINDUC,LOOPT(1))_^1_$DIMENSION LINDUC(10)_^1_$EQUIVALENCE (LBEG,LOOPT(2))_^1_$DIMENSION L€€BEG(10)_^1_$EQUIVALENCE (LINC,LOOPT(3))_^1_$DIMENSION LINC(10)_^1_$EQUIVALENCE (LEND,LOOPT(4))_^1_$DIMENSION LEND(10)_^1_$BYTE(LLABL,LOOPT(5)(14=0)_))_^1_$DIMENSION LLABL(10)_^1_$BYTE(LID,LOOPT(5)(15=15) )_^1_$DIMENSION LID(10)_^1_$COMMON/A/IEQV(255), IEQVS,IEQVN2_^1_$COMMON /A/ ISTAB(150),ISTABS,ISTAB2_^1_$COMMON /A/ IBUFS,ISET(25),LBLANK,KSFCNT,KSNCNT,ISORSC,_^1_#$IHOBIT,ISTNO,€€ISSFLG,ISUBPN,ITERM,JSORSC,KEQVS_^1C_#SYMBOL TABLE LABELED COMMON BLOCK_^1_$COMMON /A/ ISYMN, ISYMFL,ISYMD,ISYMX,ISYMS,ISYMP,ISYMPC,ISYMPS,_^1_#$ ISYMNS, SYMTAB(960)_^1_$INTEGER SYMTAB_^1_$BYTE (IDUM,SYMTAB(1)(15=15)),(KDUMY,SYMTAB(1)(15=15)),_^1_#$(ICLASS,SYMTAB(1)(14=11)),(ITYPE,SYMTAB(1)(10=9))_^1_$DIMENSION IDUM(100),KDUMY(100),ICLASS(100),ITYPE(100)_^1_$BYTE (ISNGL, SYMTAB(1)(€€8=8)),(KELSIZ,SYMTAB(1)(8=8)),_^1_#$ (ICOM,SYMTAB(1)(7=5)),(IPART,SYMTAB(1)(4=3))_^1_$DIMENSION ISNGL(100),KELSIZ(100),ICOM(100),IPART(100)_^1_$BYTE (KRFCNT,SYMTAB(1)(2=2)),(IDIM,SYMTAB(1)(1=0)),_^1_#$ (IREL,SYMTAB(1)(1=1)),(IEXT,SYMTAB(1)(0=0))_^1_$DIMENSION KRFCNT(100),IDIM(100),IREL(100),IEXT(100)_^1_$EQUIVALENCE (IRSA,SYMTAB(2)),(ICOMTX,SYMTAB(2)),(ISNOL,SYMTAB(2))_^1_$DIMENSIO€€N IRSA(100), ICOMTX(100),ISNOL(100)_^1_$BYTE (IDATAS,SYMTAB(3)(15=15)),(IREF,SYMTAB(3)(15=15)),_^1_#$ (IEQVX,SYMTAB(3)(14=8)),(ITILF,SYMTAB(3)(14=8))_^1_$DIMENSION IDATAS(100),IREF(100),IEQVX(100),ITILF(100)_^1_$BYTE (IPARTR,SYMTAB(3)(7=4)),(INDUCV,SYMTAB(3)(7=7)),(ISFARG,_^1_#$ SYMTAB(3)(6=6)),(IARGNO,SYMTAB(3)(5=0)),(IPARTL,SYMTAB(3)(3=0))_^1_$DIMENSION IPARTR(100),INDUCV(100),IS€€FARG(100),IARGNO(100),_^1_#$ IPARTL(100)_^1_$EQUIVALENCE (ISYM,SYMTAB(4))_^1_$DIMENSION ISYM(100)_^1C_]_^1C_#SPECIFICATION-TABLE INDEX LABELLED COMMON BLOCK_^1_$COMMON /A/ ISTABX(96)_^1C_]_^1C_#PHASE A BLANK COMMON BLOCK._^1_$COMMON // JSYM(3),JTERM,JMODE,JERR,JESWT,JFLOT,JCHAR,_^1_#$JOCHAR,JO1,JE,JE1,JBLANK,JCT,JCT1_^1C_#JSYM-JCT1 MUST REMAIN IN ORDER_^1_$COMMON//IERR_^1_$COMMON//€€ISORS(208),ISORSX_^1_$COMMON//IDEFF,ISTOP,IRET,ISPEC,NERR,OCT_^1_$INTEGER OCT_^1_$COMMON//ILLABL,LEST,ISNGL1,ICOMX1,NXTYPE,LOGIF,IOVFL1,IOVFL2_^1_$COMMON//IVCFLG,ISFLG,LOGEX,KEQVX_^1_$COMMON//IBUF2X,IBUF2(304)_^1C_$TEMPORARY ARITHMETIC BUFFERS_^1_$COMMON//IBUF1( 304),IBUF1X,IWORK (304)_^1C_#TEMPORARY EQUIVALENCE BUFFERS_^1_$DIMENSION KEQV(460),MEQV(255)_^1_$EQUIVALENCE (KEQV,IBUF1(€€66)),(MEQV,IBUF2(100))_^1C_#LS1-ITEM MUST REMAIN IN ORDER_^1_$COMMON//LS1,LPREN,LRELRQ,LRELEN,LSWITC,LO,ITEM_^1_$COMMON//MODE_^1C_]_^1C_]_^1C STORAGE FOR LOCAL VARIABLES OF PROGRAMS WHICH WILL BE OVERLAID..._^1_$COMMON IPHAT(4),IHEAD(48),LENSAV,IOSPRT(17)_^1_$EQUIVALENCE (ITEMP3,IPHAT(3))_^1_$DIMENSION MESS(47)_^1C_#IF THIS IS THE FIRST TIME THROUGH, CLEAR THE LOAD-AND-GO SECTOR_^1€€C_#********BEGIN********** FTN 3.2 *********************************_^1_$IF (ISTNO .NE. 0) GO TO 20_^1C_#*********************** FTN 3.2 ******END************************_^1_$DO 10 I=1,47_^1_$MESS(I)=$2E2E_^110_"CONTINUE_^1_$GO TO 80_^1C_#IS ANY CHARACTER A SLASH_^120_"IF (JTERM .EQ. 44) GO TO 30_^1_$IF (JTERM .EQ. 47) RETURN_^1_$CALL GETC_^1_$IF (JCHAR .EQ. 44) GO TO 30_^1_$IF (JC€€HAR .EQ. 47) RETURN_^1C_#NO, OUTPUT ERROR 66_^1_$CALL DIAG($2042)_^1_$RETURN_^1C_#YES, STORE THE CHARACTERS FOLLOWING IN THE BUFFER_^1_!30 DO 50 M=3,94_^1_$I=ISORSX/ISORSC_^1_$J=ISORS(I)_^1_$IF (I*ISORSC .EQ. ISORSX) GO TO 40_^1_$I=I+1_^1_$J=ISORS(I)/256_^140_"JCHAR=AND(J,255)_^1_$ISORSX=ISORSX+1_^1_$IF (JCHAR .EQ. 47) GO TO 60_^1_$CALL STCHAR (MESS,M,JCHAR)_^150_"CONTINUE_^1_$GO T€€O 80_^160_"DO 70 N=M,94_^1_$CALL STCHAR (MESS,N,46)_^170_"CONTINUE_^1C_#WRITE THE BUFFER ONTO THE LOAD-AND-GO SECTOR_^180_"ILGO = LGO+1_^1C_#********BEGIN********** FTN 3.2 *********************************_^1C_!MESS(1) MUST EQUAL INTERNAL BLANKS_^1_$MESS(1) = $2E2E_^1C_#*********************** FTN 3.2 ******END************************_^1_$CALL WRITE (12,ILGO,47,MESS(1))_^1_$RETURN€¤_^1C ********************************** FTN 3.0 **************************_^1C ********************************** FTN 3.0 **************************_^1_$END_]_^__¤PWARITH CSY/ 14A P€1_$SUBROUTINE ARITH_^1_#*_2/DECK-ID 14A FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^13_]_^1C INPUT IS FROM 'ISORS' IF BIT 4 OF 'IFLAGS' IS 0, ELSE FROM 'IBUF2'._^1C MIXED-MODE ARITHMETIC IS HANDLED BY 'ARITH'_^1C ARITH IS USED IN PHASE A4_^1C_]_^1C_#MA€€STER LABELED COMMON BLOCK._^1*_] FTN 3.3_^1_$COMMON /A/ IFLAGS,LINECT,LINCT1_^1_$COMMON /A/ IR,IK,IP,IA,IL,IM,IXLGO,IOPTO,IOPTV,IOPTC,IOPTD_^1_$COMMON /A/ MCSTRT,MACRNB,MACSEC_^1_$COMMON /A/ IERRS(16),ISRFAD_^1_$COMMON /A/ LGO,ISCRI,ISCRO,IX_^1*_] FTN 3.3_^1_$COMMON /A/ IGLAB(3),IGLAB1,IGLAB2_^1_$COMMON /A/ ICOMT(12),ICOMTS,ICOMX2,ICOMTL,ISUBP,NDPRS,_^1_#$LABX,IBCDTB(48)_^1_$EQUI€€VALENCE(ICOMB,ICOMT(1)),(ICOMBX,ICOMT(2)),(ICOMDF,_^1_#$ICOMT(3)),(ICOMBN,ICOMT(4))_^1_$DIMENSION ICOMB(6),ICOMBX(6),ICOMDF(6),ICOMBN(7)_^1_$COMMON /A/ LOOPTS,LOOPTX,LOOPTB,LOOPT(50)_^1_$EQUIVALENCE(LINDUC,LOOPT(1))_^1_$DIMENSION LINDUC(10)_^1_$EQUIVALENCE (LBEG,LOOPT(2))_^1_$DIMENSION LBEG(10)_^1_$EQUIVALENCE (LINC,LOOPT(3))_^1_$DIMENSION LINC(10)_^1_$EQUIVALENCE (LEND,LOOPT(4))_^€€1_$DIMENSION LEND(10)_^1_$BYTE(LLABL,LOOPT(5)(14=0)_))_^1_$DIMENSION LLABL(10)_^1_$BYTE(LID,LOOPT(5)(15=15) )_^1_$DIMENSION LID(10)_^1_$COMMON/A/IEQV(255), IEQVS,IEQVN2_^1_$COMMON /A/ ISTAB(150),ISTABS,ISTAB2_^1_$COMMON /A/ IBUFS,ISET(25),LBLANK,KSFCNT,KSNCNT,ISORSC,_^1_#$IHOBIT,ISTNO,ISSFLG,ISUBPN,ITERM,JSORSC,KEQVS_^1C_#SYMBOL TABLE LABELED COMMON BLOCK_^1_$COMMON /A/ ISYMN, IS€€YMFL,ISYMD,ISYMX,ISYMS,ISYMP,ISYMPC,ISYMPS,_^1_#$ ISYMNS, SYMTAB(960)_^1_$INTEGER SYMTAB_^1_$BYTE (IDUM,SYMTAB(1)(15=15)),(KDUMY,SYMTAB(1)(15=15)),_^1_#$(ICLASS,SYMTAB(1)(14=11)),(ITYPE,SYMTAB(1)(10=9))_^1_$DIMENSION IDUM(100),KDUMY(100),ICLASS(100),ITYPE(100)_^1_$BYTE (ISNGL, SYMTAB(1)(8=8)),(KELSIZ,SYMTAB(1)(8=8)),_^1_#$ (ICOM,SYMTAB(1)(7=5)),(IPART,SYMTAB(1)(4=3))_^1_$DIMENSION €€ISNGL(100),KELSIZ(100),ICOM(100),IPART(100)_^1_$BYTE (KRFCNT,SYMTAB(1)(2=2)),(IDIM,SYMTAB(1)(1=0)),_^1_#$ (IREL,SYMTAB(1)(1=1)),(IEXT,SYMTAB(1)(0=0))_^1_$DIMENSION KRFCNT(100),IDIM(100),IREL(100),IEXT(100)_^1_$EQUIVALENCE (IRSA,SYMTAB(2)),(ICOMTX,SYMTAB(2)),(ISNOL,SYMTAB(2))_^1_$DIMENSION IRSA(100), ICOMTX(100),ISNOL(100)_^1_$BYTE (IDATAS,SYMTAB(3)(15=15)),(IREF,SYMTAB(3)(15=15)),_€€^1_#$ (IEQVX,SYMTAB(3)(14=8)),(ITILF,SYMTAB(3)(14=8))_^1_$DIMENSION IDATAS(100),IREF(100),IEQVX(100),ITILF(100)_^1_$BYTE (IPARTR,SYMTAB(3)(7=4)),(INDUCV,SYMTAB(3)(7=7)),(ISFARG,_^1_#$ SYMTAB(3)(6=6)),(IARGNO,SYMTAB(3)(5=0)),(IPARTL,SYMTAB(3)(3=0))_^1_$DIMENSION IPARTR(100),INDUCV(100),ISFARG(100),IARGNO(100),_^1_#$ IPARTL(100)_^1_$EQUIVALENCE (ISYM,SYMTAB(4))_^1_$DIMENSION ISYM(100€€)_^1C_]_^1C_#SPECIFICATION-TABLE INDEX LABELLED COMMON BLOCK_^1_$COMMON /A/ ISTABX(96)_^1C_]_^1C_#PHASE A BLANK COMMON BLOCK._^1_$COMMON // JSYM(3),JTERM,JMODE,JERR,JESWT,JFLOT,JCHAR,_^1_#$JOCHAR,JO1,JE,JE1,JBLANK,JCT,JCT1_^1C_#JSYM-JCT1 MUST REMAIN IN ORDER_^1_$COMMON//IERR_^1_$COMMON//ISORS(208),ISORSX_^1_$COMMON//IDEFF,ISTOP,IRET,ISPEC,NERR,OCT_^1_$INTEGER OCT_^1_$COMMON//ILLABL€€,LEST,ISNGL1,ICOMX1,NXTYPE,LOGIF,IOVFL1,IOVFL2_^1_$COMMON//IVCFLG,ISFLG,LOGEX,KEQVX_^1_$COMMON//IBUF2X,IBUF2(304)_^1C_$TEMPORARY ARITHMETIC BUFFERS_^1_$COMMON//IBUF1( 304),IBUF1X,IWORK (304)_^1C_#TEMPORARY EQUIVALENCE BUFFERS_^1_$DIMENSION KEQV(460),MEQV(255)_^1_$EQUIVALENCE (KEQV,IBUF1(66)),(MEQV,IBUF2(100))_^1C_#LS1-ITEM MUST REMAIN IN ORDER_^1_$COMMON//LS1,LPREN,LRELRQ,LRELEN,LS€€WITC,LO,ITEM_^1_$COMMON//MODE_^1_$COMMON//IPHAT(4),IGNSTT(49),IOSPRT(17)_^1C_]_^1C_]_^1C_#ROUTINE TO SYNTAX CHECK AND TREE STRUCTURE ARITHMETIC EXPRESSIONS_^1C_]_^1C_#SYNTAX LEGALITY TABLE_^1C_#V=VARIABLE_^1C_#C=CONSTANT_^1C_#F=FUNCTION_^1C_]_^1C_#REL OR AND NOT V */** +- ( ) , END C F H_^1C REL_/P_$P P_(P P_^1C OR_,P_!P_$P P_(P P_^1C AND_+P_!P_$P P_(P P_^1C NOT_/P_$P P_(P P_^€€1C V_!P_!P P_(P_"P P P P P_^1C */**_.P_(P_(P P_^1C +-_0P_(P_(P P_^1C (_-P_!P_$P P_(P P P_^1C )_!P_!P P_(P_"P_"P P P_^1C ,_1P_$P P_(P P P_^1C BEG_+P_!P_$P P_#P_!P P_^1C C_!P_!P P_(P_"P_"P P P_^1C F_;P P P_^1_$DIMENSION JDUM(7)_^1_$DIMENSION MTERM(18)_^1C_]_^1_$EQUIVALENCE(JDUM(1),LS1)_^1_$BYTE(IC,SYMTAB(1)(14=11))_^1_$DIMENSION IC(100)_^1C_#INTRINSIC AND BASIC FUNCTIONS WHOSE€€ NAMES CONFLICT W/TYPE_^1C_#3 WORDS PER FUNCTION...NAME (AND,OR,EOR,EOF) IN TWO-WORD SYMTAB_^1C_#FORM, NUMBER OF PARAMETERS MINUS ONE_^1_$DIMENSION IIBFN(12)_^1_$DATA IIBFN(1),IIBFN(2),IIBFN(3),IIBFN(4),IIBFN(5),IIBFN(6),_^1_#1 IIBFN(7),IIBFN(8),IIBFN(9),IIBFN(10),IIBFN(11),IIBFN(12)_^1_#2 /$3EF8,$E7B6,1,$92DB,$E7B6,1,$56F1,$E7B6,1,$56E5,$E7B6,0/_^1C_#TABLE OF TERMINATORS_^1_$DATA €€MTERM(1),MTERM(2),MTERM(3),MTERM(4)/43,$A0D,$181B,$171D/_^1_$DATA MTERM(5),MTERM(6),MTERM(7),MTERM(8)/$151D,$101D,$150E,$100E/_^1_$DATA MTERM(9),MTERM(10),MTERM(11),MTERM(12)/$E1A,$170E,38,39/_^1_$DATA MTERM(13),MTERM(14),MTERM(15),MTERM(16)/45,44,$2D2D,41/_^1_$DATA MTERM(17),MTERM(18)/42,47/_^1_$EXTERNAL LOCAL_^1C_]_^1C_#INITIALIZE WORKING REGISTERS_^1_$DO 1 I=1,7,1_^1_"1 JDUM(I)=€€0_^1C_#CLEAR LOGICAL EXCPRESSION FLAG_^1_$LOGEX=0_^1_$MODE=0_^1_$MXMOD = 0_^1_$IMSW=0_^1_$NULMI=0_^1_$IBUF1X=1_^1C_]_^1_$CALL GETF_^1C_#END OF STATEMENT_^1_$IF(JERR.NE.0) JMODE=0_^1_$IF(JMODE.EQ.0.AND.JTERM.EQ.47)GO TO 80_^1C_#CALL STATEMENT_^1_$IF(IBUF2(3).EQ.21) GO TO 100_^1C_#IF ALPHA OR NUMERIC PORTION IS IN ERROR-IGNORE IT_^1C_#ISTOP=1 SAYS WE ARE PROCESSING IF_^1_$IF(ISTOP.NE€€.1) GO TO 2_^1C_#IF-MUST START WITH (_^1_$IF(JTERM.EQ.41.AND.JMODE.EQ.0) GO TO 12_^1_$CALL DIAG (7)_^1_$LPREN=LPREN+1_^1_$IBUF1(IBUF1X)=16_^1_$IBUF1(IBUF1X+1)=8_^1_$LS1=16_^1_$IBUF1X=IBUF1X+2_^1_"2 IF(ISTOP.NE.2) GO TO 3_^1_$IF (JMODE.EQ.0) GO TO 999_^1_$IF(JMODE.EQ.2) GO TO 4_^1_!20 CALL DIAG(10)_^1_$GO TO 999_^1_"4 ASSIGN 5 TO IAD_^1_$GO TO 205_^1_"5 IF(ICLASS(ISYMX).GT.1) GO TO €€20_^1_$IF(IDIM(ISYMX).EQ.0.AND.JTERM.EQ.41) GO TO 222_^1_$GO TO 145_^1C_(PROCESS RIGHT HALF OF = SIGN_^1_"3 IF(JMODE.NE.0) GO TO 200_^1C_#(_]_^1_!11 IF(JTERM.NE.41) GO TO 201_^1_!12 LPREN=LPREN+1_^1C_#OPERATOR_^1C_%TREE TYPE 16 = (_^1_$IBUF1(IBUF1X)=16_^1_$LS1=16_^1C_#CHECK BUFFER OVERFLOW_^1 5012 ASSIGN 50120 TO IAD_^1_$GO TO 144_^1C_#SET LEVEL_^1C_(ARITH LEVEL 8 MEANS (, ), OR F€€UNCTION_^150120 IBUF1(IBUF1X)=8_^1C ***LPREN .LT. 0-ERROR,=0-CHECK FOR EXIT,.GT.0-ONWARD_^1_$IF(LPREN) 5013,5014,13_^1 5013 CALL DIAG (16)_^1_!13 IBUF1X=IBUF1X+1_^1C_#******TEST IBUF1 OVERFLOW HERE_^1_$IF(IBUF1X.GT.IBUFS)CALL PUNT_^1 131 CALL GETF_^1_$IF(JERR.EQ.0)GO TO 1310_^1_$NULMI=0_^1_$LS1=24_^1_$GO TO 181_^1C_#NULL FIELD_^1 1310 IF(JMODE.EQ.0)GO TO 1311_^1_$IF(JMODE.NE.2)GO€€ TO 132_^1_$NULMI=0_^1C_=._^1C_#ALPHABETIC FIELD_^1_$ASSIGN 149 TO IAD_^1C_#PUT SYMBOL IN TABLE IF NOT ALREADY THERE_^1_$GO TO 205_^1C_#IF NULL FIELD WITH - TERMINATOR,SET SWITCH_^1 1311 NULMI=0_^1_$IF(JTERM.EQ._!39)NULMI=LS1_^1_$GO TO 181_^1C_#IS FIELD IN SYMBOL TABLE_^1 149 IF(ISYMD.EQ.0) GO TO 141_^1_$IF(IC(ISYMX).NE.1) GO TO 142_^1C_#CLASS= VARIABLE_^1 145 IF(ICLASS(ISYMX).EQ€€.0.AND.IREL(ISYMX)+IEXT(ISYMX).NE.0)_^1_#1 CALL DIAG(21)_^1_$ICLASS(ISYMX)=1_^1C_#VARIABLE_^1_$ASSIGN 147 TO IAD_^1C_(TREE TYPE 24 MEANS NON-SUBSCRIPTED VARIABLE_^1 143 IBUF1(IBUF1X)=24_^1 144 IBUF1X=IBUF1X+1_^1C_#IBUF1 OVERFLOW CJECK_^1_$IF(IBUF1X.GT.IBUFS) CALL PUNT_^1C_#SYMTAB ENTRY NO._^1_$IBUF1(IBUF1X)=ISYMX+ISYMP_^1_$GO TO IAD_^1 147 IF(IPART(ISYMX).NE.0)IBUF1(IBUF1X-1)=2€€9_^1_$ITEM=IBUF1(IBUF1X-1)_^1C_#IF NOT DIMENSIONED OR IF TERMINATOR IS ( -ONWARD_^1_$IF(IDIM(ISYMX).EQ.0.OR.JTERM.EQ.41) GO TO 15_^1_$IBUF1(IBUF1X-1)=IBUF1(IBUF1X-1)+2_^1_$JSYM(1)=ITYPE(ISYMX)_^1*_] FTN 3.3_^1_$IF(IBUF2(3).EQ.18.OR.IBUF2(3).EQ.19.OR.IBUF2(3).EQ.21.OR._^1_#*_!IBUF2(3).EQ.42.OR.IBUF2(3).EQ.43) JSYM(1)=1_^1*_] FTN 3.3_^1C_#TWO WORD INTEGER_^1_$IF(ITYPE(ISYMX).EQ.1.A€€ND.IK.NE.0.AND.ISNGL(ISYMX).EQ.0)JSYM(1)=2_^1_$ASSIGN 146 TO IAD_^1_$GO TO 144_^1 146 IBUF1(IBUF1X)=JSYM(1)_^1C_#CHECK PREDECESSOR AND MODE_^1C_#PREDECESSOR=VARIABLE,CONSTANT,SUBROUTINE,STATEMENT LABEL,)-BAD_^1_!15 IF(LS1.LT.17)GO TO 151_^1C_#ILLEGAL PREDECESSOR_^1 150 CALL DIAG(10)_^1 151 ASSIGN 16 TO IAD1_^1C_#CHECK MODE_^1 153 IF(MODE.EQ.0)MODE=ITYPE(ISYMX)_^1C_(LS1 OF 15 = €€** TREE TYPE_^1_$IF(LS1.EQ.15.AND.ITYPE(ISYMX).EQ.1)GO TO IAD1_^1_$IF(MODE.EQ.ITYPE(ISYMX))GO TO IAD1_^1_$MXMOD = 1_^1C_8BEGIN_4***** FTN 3.1 *****_^1_$IF (MODE.LT.ITYPE(ISYMX)) MODE=ITYPE(ISYMX)_^1C_8END_6***** FTN 3.1 *****_^1_$GO TO IAD1_^1C_=._^1C_#ANALYZE TERMINATOR_^1 306 IF(LS1.GE.(-1).AND.LS1.LT.17)GO TO 16_^1C_#ILLEGAL PREDECESSOR_^1 304 CALL DIAG(10)_^1_!16 LS1=ITEM_^1_€€!18 IBUF1X=IBUF1X+1_^1_$IF(ISTOP.NE.2) GO TO 18 1_^1_$IF(IDIM(ISYMX).EQ.0.OR.JTERM.NE.41) GO TO 5004_^1_$GO TO 600_^1C_#IDENTIFY TERMINATOR_^1 181 DO 19 I=1,18,1_^1_$IF(JTERM.NE.MTERM(I)) GO TO 19_^1_$IF(IBUF1X+1.GT.IBUFS) CALL PUNT_^1_$IBUF1(IBUF1X)=I_^1_$ITEM=I_^1C_,,_!AD OR NT LT GT LE GE EQ NE +_!-_!*_!/_^1_$GO TO (511,503,504,517,505,505,505,505,505,505,512,512,514,€€514,_^1_#1516,502,501,500),I_^1C_$** (_!) EOS_^1_!19 CONTINUE_^1C_=._^1C_#ILLEGAL TERMINATOR_^1 191 ITEM=-1_^1_$GO TO 5037_^1C_=._^1C_#END OF EXPRESSION_^1C_#),VARIABLE,CONSTANT,BEGINNING ARE LEGAL PREDECESSORS_^1 500 IF(LS1.LE.0.OR.LS1.GT.16)GO TO 5000_^1C_#ILLEGAL PREDECESSOR-FATAL ERROR_^15005 CALL DIAG(4111)_^15000 IF(LPREN.LE.0)GO TO 5001_^1C_#UNMATCHED PARENTHESES-FATAL€€ ERROR_^1_$CALL DIAG(4112)_^1 5001 IF(LRELRQ.EQ.0)GO TO 5002_^1C_#RELATIONAL OPERATOR IS MISSING-FATAL ERROR_^1_$CALL DIAG(4113)_^1C_#SET STATEMENT TYPE TO CONTINUE_^1_$GO TO 999_^1 5002 IF(LOGEX.NE.0.AND.IBUF2(3).NE.43)_%CALL DIAG(4114)_^1C_#FORM TREE AND PUT IN IBUF2_^1 5004 IF (IERR.NE.0) GO TO 999_^1_$IF (AND(IFLAGS,16).NE.0) IBUF2X=5_^1_$CALL TREE_^1C IF MIXED-MODE EXPRESSION,€€ REORDER THE TREE TO INCLUDE 'FLOAT' CALLS._^1_$IF (MXMOD.EQ.0) GO TO 999_^1_$ASSEM $1802,.902,+999,$5400,+LOCAL,+902,$3,$6,.903,$1_^1 999 ASSEM $0AFE,$6800,903_^1_$RETURN_^1C_,._^1C_,._^1 501 LPREN=LPREN-1_^1_$IF(LPREN.EQ.LSWITC-8192) LSWITC=0_^1C_#ERASE 1 ENTRY FROM MODE CONTROL TABLE IF ANY EXIST_^1_$IF(IMSW.NE.0)GO TO 5015_^1C_#VARIABLE,CONSTANT,NOPAR FUNC OR SBRT,) ARE LEGAL€€ PREDECESSORS_^1 5011 IF(LS1.GT.21.OR.LS1.EQ.17.OR.LS1.LT.0)GO TO 5016_^1_$CALL DIAG(10)_^1 5016 LS1=17_^1_$GO TO 5012_^1 5014 IF(ISTOP.NE.0) GO TO 5001_^1C_=._^1C_#CALL STATEMENT_^1_$IF(IBUF2(3).NE.21)GO TO 13_^1_$CALL GETF_^1C_2BEGIN_(*** PSR 71 * 1657 ***_^1_$IF (JTERM.EQ.47.AND.JMODE.EQ.0)GO TO 5001_^1C_2END_**** PSR 71 * 1657 ***_^1_$GO TO 5005_^1 5015 IF(IWORK(IMSW).NE.LPREN)€€GO TO 5011_^1_$MODE=IWORK(IMSW-1)_^1_$IMSW=IMSW-2_^1_$GO TO 5011_^1C_#(_]_^1C_#TREE TYPE 17 = ) TREE TYPE 35 = NUMERIC CONSTANT_^1C_(LS1 LT 24 MEANS NOT A VARIABLE CONSTANT_^1 502 IF (LS1.EQ.17.OR.LS1.EQ.35) GO TO 5021_^1_$IF (LS1.LT.24) GO TO 5020_^1_$ISYMX=IBUF1(IBUF1X-1)_^1_$CALL GETSYM_^1_$IF(IDIM(ISYMX).NE.0) GO TO 600_^1C_#SUBSCRIPTED VARIABLE NOT DIMENSIONED-FATAL IF STATE€€MENT IS_^1C_#READ,WRITE,OR REPLACEMENT_^1C_#AND WE ARE PROCESSING TO LEFT OF =_^1_$IF (AND(IFLAGS,16).EQ.0 .OR. IBUF2(3).EQ.18.AND.ISTOP.EQ.0)_^1_#* GO TO 5021_^1 222 CALL DIAG(6)_^1C_#SLEW TO )_^1 5022 CALL GETF_^1C_#END OF STATEMENT_^1_$IF(JTERM.EQ.47)GO TO 5005_^1_$IF(JTERM.EQ.42)GO TO 601_^1_$GO TO 5022_^1C_#NON-FATAL INSERT * AND PROCEED_^1 5021 CALL DIAG (8211)_^1_$IBUF1(IB€€UF1X)=13_^1_$LS1=13_^1_$IF(IBUF1X+2.GT.IBUFS) CALL PUNT_^1_$IBUF1(IBUF1X+1)=6_^1_$IBUF1X=IBUF1X+2_^1_$GO TO 12_^1C_#** PREDECESSOR MEANS MAYBE IWORK ENTRY MUST BE MAYBE_^1 5020 IF(LS1.NE.15.OR.MODE.EQ.1)GO TO 12_^1C_#** PREDECESSOR_^1_$ASSIGN 12 TO IAD1_^1_$GO TO 301_^1C_#.AND._^1 503 IBUF1(IBUF1X+1)=2_^1 5032 IBUF1X=IBUF1X+1_^1C_#LOGICAL OR RELATIONAL ONLY OK IN LOGICAL IF_^1_$IF€€(ISTOP .NE.1)GO TO 5037_^1_$IF(LRELEN.EQ.0) GO TO 5031_^1_$LRELEN=0_^1 5030 MODE=0_^1C_#SET RELATIONAL OPERATOR REQUIRED SWITCH_^1_$LRELRQ=1_^1 5033 IF(LS1.LT.0.OR.LS1.EQ.17.OR.LS1.GT.23)GO TO 5035_^1 5037 CALL DIAG (10)_^1 5035 LS1=ITEM_^1_$GO TO 13_^1 5031 CALL DIAG (17)_^1_$GO TO 5030_^1C_#.OR._]_^1 504 IBUF1(IBUF1X+1)=1_^1_$GO TO 5032_^1C_#GT,LT,LE,GE,EQ,NE_^1 505 IBUF1(IBUF1€€X+1)=4_^1C_#LOGICAL OR RELATIONAL ONLY OK IN LOGICAL IF_^1_$IF(ISTOP .NE.1)GO TO 5037_^1C_#SET LOGICAL EXPRESSION FLAG_^1_$LOGEX=1_^1_$LRELEN=1_^1_$LRELRQ=0_^1506_!IBUF1X=IBUF1X+1_^1_$GO TO 5033_^1C_#,_]_^1C_#ILLEGAL IF FUNCTION OR SUBROUTINE SWITCH NOT SET_^1C_#OR WE ARE PROCESSING LIST ELEMENTS_^1 511 IF(LSWITC.EQ.0) GO TO 5037_^1_$MODE=0_^1_$IBUF1(IBUF1X+1)=0_^1_$IBUF1X=IBUF1X+€€1_^1_$IF(LS1.GT.21)GO TO 5035_^1_$GO TO 5033_^1C_#+_]_^1 211 IBUF1(IBUF1X)=11_^1 212 ITEM=IBUF1(IBUF1X)_^1C_#+,-_]_^1 512 IBUF1X=IBUF1X+1_^1_$IBUF1(IBUF1X)=5_^1C_#+,-,**,*,/ ARE ILLEGAL PREDECESSORS_^1_$IF(LS1.GT.10.AND.LS1.LT.16)GO TO 5037_^1_$GO TO 5035_^1C_#*,/_]_^1 514 IBUF1(IBUF1X+1)=6_^1_$IF(IBUF1(IBUF1X).EQ.13)GO TO 506_^1_$IBUF1X=IBUF1X+1_^1_*IBUF1(IBUF1X+1)=0_^1_$IF(MO€€DE.LT.2)IBUF1(IBUF1X+1)=1_^1_$GO TO 506_^1C_#**_]_^1 516 IBUF1(IBUF1X+1)=7_^1_$GO TO 506_^1 517 IBUF1X=IBUF1X+1_^1_$IBUF1(IBUF1X)=3_^1C_#LOGICAL OR RELATIONAL ONLY OK IN LOGICAL IF_^1_$IF(ISTOP .NE.1)GO TO 5037_^1C_#AND OR ( ARE LEGAL PREDECESSORS_^1_$IF(LS1.GT.0.AND.LS1.NE.2.AND.LS1.NE.3.AND.LS1.NE.16)GO TO 5037_^1_$LRELRQ=1_^1_$GO TO 5035_^1 600 CALL SUBSCR_^1_$IF(JTERM.EQ€€.47)GO TO 5005_^1 601 IF(ISTOP.NE.0.AND.LPREN.EQ.0)GO TO 5001_^1_$GO TO 131_^1C_]_^1C_#PROCESS CALL STATEMENT_^1C_#CLEAR NEXT HOLDER IN OUTPUT BUFFER FOR FUTURE USE_^1 100 IBUF1(IBUF1X)=0_^1C_#LOOK AT SUBROUTINE NAME_^1_$IF(JERR.NE.0)GO TO 106_^1_$IF(JMODE.NE.2)GO TO 102_^1C_#NAME NOT YET IN TABLE-PUT IT IN_^1_$IF(ISYMD.EQ.0) CALL STORE_^1C_#SEE IF WE ARE CALLING THE SUBROUTINE W€€E ARE IN_^1_$IF(ISYMX+ISYMP.EQ.ISUBPN)GO TO 102_^1C_#NAME IN TABLE_^1C_#SET TO EXTERNAL SUBROUTINE_^1_$IF(IC(ISYMX).EQ.0)IC(ISYMX)=6_^1_$IF(IC(ISYMX).EQ.6)GO TO 106_^1C_#ILLEGAL SUBPROGRAM REFERENCE_^1102_!CALL DIAG(11)_^1C_#(_]_^1 106 IF(JTERM.EQ.41)GO TO 107_^1_$IF(JTERM.EQ.47)GO TO 108_^1_$IF(IERR.EQ.0)CALL DIAG(21)_^1_$GO TO 999_^1 108 IBUF1(IBUF1X)=23_^1_$IF(IARGNO(ISYMX).EQ€€.0)IARGNO(ISYMX)=1_^1_$IF(IARGNO(ISYMX).NE.1.AND._%IOPTV .EQ.0)CALL DIAG(12301)_^1_$GO TO 232_^1C_#MAKE IWORK ENTRY_^1 107 LSWITC=8192+LPREN_^1_$IMSW=2_^1_$IWORK(2)=LPREN_^1_$IWORK(1)=0_^1_$IBUF1(IBUF1X)=IBUF1(IBUF1X)+20_^1C_#LEVEL_^1_$IBUF1(IBUF1X+1)=8_^1_$IBUF1X=IBUF1X+3_^1_$IBUF1(IBUF1X-1)=ISYMX+ISYMP_^1_$GO TO 12_^1C_#ALPHA OR NUMERIC PORTION OF FIRST FIELD_^1 200 ASSIGN 260 €€TO IAD_^1C_#PUT IN SYMBOL TABLE IF NOT ALREADY THERE_^1 205 IF(ISYMD.EQ.0)CALL STORE_^1_$IBUF1(IBUF1X)=0_^1C_#TYPE FIELD,IF NOT ALREADY DONE_^1_$IF(JMODE.NE.2.OR.ITYPE(ISYMX).NE.0)GO TO IAD_^1_$ITYPE(ISYMX)=JESWT_^1_$GO TO IAD_^1 260 I=ISYMD+1_^1_$IF(JMODE.EQ.2) GO TO (220,240) ,I_^1_$ASSIGN 230 TO IAD_^1_$GO TO (1320,134),I_^1 230 MODE=ITYPE(ISYMX)_^1 232 LS1=IBUF1(IBUF1X)_^1_€€$ASSIGN 18 TO IAD_^1_$GO TO 144_^1 220 IF(JTERM.NE.41) GO TO 145_^1C_#SET SYM+ABENTRY TO FUNCTION_^1_$ASSIGN 280 TO IAD_^1 231 DO 225 I=1,12,3_^1_$IF (JSYM(1).NE.IIBFN(I).OR.JSYM(2).NE.IIBFN(I+1)) GO TO 225_^1_$K=0_]_^1_$J=ISORSX_^1_$IF (AND(IFLAGS,16).NE.0) J=IBUF2X_^1 227 CALL GETC_^1_$IF(JCHAR.EQ.41) GO TO 226_^1_$IF(JCHAR.EQ.42.OR.JCHAR.EQ.47) GO TO 228_^1_$IF(JCHAR.EQ.43) K€€=K+1_^1_$GO TO 227_^1 228 IF (AND(IFLAGS,16).NE.0) GOTO 900_^1_$ISORSX=J_^1_$GOTO 901_^1 900 IBUF2X=J_^1C_#FOUND NAME IN INTRINSIC TABLE-IF NO. PARAMS SAME,SET TYPE INTEGER_^1 901 IF (K.EQ.IIBFN(I+2)) ITYPE(ISYMX)=1_^1_$GO TO 229_^1 226 K1=1_]_^1 2261 CALL GETC_^1_$IF(JCHAR.EQ.47) GO TO 228_^1_$IF(JCHAR.EQ.42)K1=K1-1_^1_$IF(JCHAR.EQ.41)K1=K1+1_^1_$IF(K1.EQ.0)GO TO 227_^1_$GO TO€€ 2261_^1 225 CONTINUE_^1 229 ICLASS(ISYMX)=5_^1_$GO TO IAD_^1C_#ILLEGAL SUBROUTINE REFERENCE_^1 295 CALL DIAG(11)_^1_$IBUF1(IBUF1X)=IBUF1(IBUF1X)+20_^1_$GO TO 296_^1C_#CLASS-UNASSIGNED,VARIABLE,OTHER_^1 240 IF(IC(ISYMX)-1)_!220,145,280_^1 280 IF(JTERM.EQ.41)GO TO 284_^1_$CALL DIAG(11)_^1C_#TERMINATOR OF FIRST FIELD-A02_^1C_#+_]_^1 201 IF(JTERM.EQ.MTERM(11))GO TO 211_^1C_#-_]_€€^1_$IF(JTERM.EQ.MTERM(12)) GO TO 221_^1_$GO TO 191_^1C_#-_]_^1 221 IBUF1(IBUF1X)=12_^1C_#LEADING -,SET SWITCH_^1_$NULMI=NULMI+1_^1_$GO TO 212_^1 284 LSWITC=8192+LPREN_^1C_#FUNCTION OR SUBROUTINE CALL WITH PARAMETERS-AR121_^1 290 IF(IC(ISYMX).EQ.6) GO TO 295_^1C_(IC OF 6 = EXTERNAL SUBROUTINE CLASS_^1C_(TREE TYPE 18 MEANS FUNCTION_^1_$IBUF1(IBUF1X)=IBUF1(IBUF1X)+18_^1C_#CHECK BUF€€FER OVERFLOW+SET ITEM FOR COMPARISON_^1 296 ASSIGN 2960 TO IAD_^1_$GO TO 74_^1C_(ARITH LEVEL 8 MEANS (, ), OR FUNCTION_^1C_#PUT AWAY LEVEL_^1 2960 IBUF1(IBUF1X)=8_^1_$ASSIGN 297 TO IAD_^1_$GO TO 144_^1 297 ASSIGN 300 TO IAD1_^1_$GO TO 153_^1 300 ASSIGN 306 TO IAD1_^1C_#MAKE IWORK ENTRY_^1 301 IWORK(IMSW+1)=MODE_^1_$IWORK(IMSW+2)=LPREN_^1_$IMSW=IMSW+2_^1 303 MODE=0_^1_$GO TO IA€€D1_^1C_#PUT CONSTANT IN SYMTAB IF NOT ALREADY THERE_^1 132 IF(NULMI.EQ.0)GO TO 1321_^1_$IF(JTERM.EQ.$2D2D .OR.NULMI.GE.24)GO TO 13210_^1C_#LEADING MINUS,MODIFY CONSTANT_^1_$JSYM(1)=-JSYM(1)_^1_$IF(JMODE.NE.3) JSYM(2)=-JSYM(2)_^1C_8BEGIN_4***** FTN 3.1 *****_^1_$IF (JMODE.EQ.6) JSYM(3)=-JSYM(3)_^1C_8END_6***** FTN 3.1 *****_^1C_#FIND NEW NUMBER_^1_$CALL SYMBOL_^1_$IBUF1(IBUF1X-2)=1€€1_^1_$IF(NULMI.NE.17)IBUF1X=IBUF1X-2_^113210 NULMI=0_^1 1321 ASSIGN 1323 TO IAD_^1_$IF(ISYMD.NE.0)GO TO 134_^1_$CALL STORE_^1 1320 ITYPE(ISYMX)=JMODE-3_^1_$IF(JMODE.EQ.3) ITYPE(ISYMX)=1_^1_$ICLASS(ISYMX)=2_^1 134 IBUF1(IBUF1X)=35_^1_$GO TO IAD_^1 1323 ASSIGN 15 TO IAD_^1_$GO TO 74_^1C_#CLASS=FUNCTION_^1C_#SET FUNCTION OR SUBROUTINE INDICATOR IF NOT ALREADY SET_^1_!70 IF(LSWITC.EQ€€.0) GO TO 284_^1_$GO TO 290_^1 141 IF(JTERM.NE.41)GO TO 145_^1C_#SET TO FUNCTION_^1_$ASSIGN 142 TO IAD_^1_$GO TO 231_^1C_#IF CLASS NO T SET,DETERMINE IT BY USAGE_^1 142 IF(IC(ISYMX).EQ.0.AND.IEXT(ISYMX).EQ.0)GO TO 141_^1C_#(_]_^1_$IF(JTERM.EQ.41)GO TO 70_^1_$IF(JTERM.EQ.42.OR.JTERM.EQ.43)GO TO 72_^1 75 CALL DIAG(11)_^1C_#SET NO PARAMETER FUNCION OR SUBROUTINE_^173_"IBUF1(IBUF1€€X)=22_^1_$IF(IC(ISYMX).EQ.6)IBUF1(IBUF1X)=IBUF1(IBUF1X)+1_^1C_=._^1C_#ITEM TYPE IS SUBROUTINE OR FUMCTION_^1_$ASSIGN 76 TO IAD_^174_"ITEM=IBUF1(IBUF1X)_^1_$GO TO 144_^1C_#PREDECESSOR , )_^1_!76 IF(LS1.LT.0.OR.LS1.EQ.1.OR.LS1.EQ.16)GO TO 16_^1_$GO TO 304_^1C_#RELATIVE EXTERNAL IS ILLEGAL AS AN ARGUMENT_^172_"IF(IREL(ISYMX).NE.0.OR.IC(ISYMX).EQ.4.OR.(IC(ISYMX).EQ.3.AND._^1_#1IEXT(ISY€®MX).EQ.0))GO TO 75_^1_$IF(ICLASS(ISYMX).GE.8)GO TO 73_^1_$IF(IEXT(ISYMX).EQ.0)CALL DIAG(8214)_^1_$IEXT(ISYMX)=1_^1_$GO TO 73_^1_!80 CALL DIAG(25)_^1_$GO TO 999_^1_$END_]_^__ ®PWCMNPR CSY/ 15A P€1_$SUBROUTINE COMNPR_^1_#*_2/DECK-ID 15A FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^13_]_^1C COMNPR IS USED IN PHASE A2_^1C_]_^1C_#MASTER LABELED COMMON BLOCK._^1*_] FTN 3.3_^1_$COMMON /A/ IFLAGS,LINECT,LINCT1_^1_$COMMON /A/ IR,IK,IP,IA,IL,IM,IXLGO,I€€OPTO,IOPTV,IOPTC,IOPTD_^1_$COMMON /A/ MCSTRT,MACRNB,MACSEC_^1_$COMMON /A/ IERRS(16),ISRFAD_^1_$COMMON /A/ LGO,ISCRI,ISCRO,IX_^1*_] FTN 3.3_^1_$COMMON /A/ IGLAB(3),IGLAB1,IGLAB2_^1_$COMMON /A/ ICOMT(12),ICOMTS,ICOMX2,ICOMTL,ISUBP,NDPRS,_^1_#$LABX,IBCDTB(48)_^1_$EQUIVALENCE(ICOMB,ICOMT(1)),(ICOMBX,ICOMT(2)),(ICOMDF,_^1_#$ICOMT(3)),(ICOMBN,ICOMT(4))_^1_$DIMENSION ICOMB(6),ICOMBX(6),I€€COMDF(6),ICOMBN(7)_^1_$COMMON /A/ LOOPTS,LOOPTX,LOOPTB,LOOPT(50)_^1_$EQUIVALENCE(LINDUC,LOOPT(1))_^1_$DIMENSION LINDUC(10)_^1_$EQUIVALENCE (LBEG,LOOPT(2))_^1_$DIMENSION LBEG(10)_^1_$EQUIVALENCE (LINC,LOOPT(3))_^1_$DIMENSION LINC(10)_^1_$EQUIVALENCE (LEND,LOOPT(4))_^1_$DIMENSION LEND(10)_^1_$BYTE(LLABL,LOOPT(5)(14=0)_))_^1_$DIMENSION LLABL(10)_^1_$BYTE(LID,LOOPT(5)(15=15) )_^1_$DI€€MENSION LID(10)_^1_$COMMON/A/IEQV(255), IEQVS,IEQVN2_^1_$COMMON /A/ ISTAB(150),ISTABS,ISTAB2_^1_$COMMON /A/ IBUFS,ISET(25),LBLANK,KSFCNT,KSNCNT,ISORSC,_^1_#$IHOBIT,ISTNO,ISSFLG,ISUBPN,ITERM,JSORSC,KEQVS_^1C_#SYMBOL TABLE LABELED COMMON BLOCK_^1_$COMMON /A/ ISYMN, ISYMFL,ISYMD,ISYMX,ISYMS,ISYMP,ISYMPC,ISYMPS,_^1_#$ ISYMNS, SYMTAB(960)_^1_$INTEGER SYMTAB_^1_$BYTE (IDUM,SYMTAB(1)(15=1€€5)),(KDUMY,SYMTAB(1)(15=15)),_^1_#$(ICLASS,SYMTAB(1)(14=11)),(ITYPE,SYMTAB(1)(10=9))_^1_$DIMENSION IDUM(100),KDUMY(100),ICLASS(100),ITYPE(100)_^1_$BYTE (ISNGL, SYMTAB(1)(8=8)),(KELSIZ,SYMTAB(1)(8=8)),_^1_#$ (ICOM,SYMTAB(1)(7=5)),(IPART,SYMTAB(1)(4=3))_^1_$DIMENSION ISNGL(100),KELSIZ(100),ICOM(100),IPART(100)_^1_$BYTE (KRFCNT,SYMTAB(1)(2=2)),(IDIM,SYMTAB(1)(1=0)),_^1_#$ (IREL,SYMTAB€€(1)(1=1)),(IEXT,SYMTAB(1)(0=0))_^1_$DIMENSION KRFCNT(100),IDIM(100),IREL(100),IEXT(100)_^1_$EQUIVALENCE (IRSA,SYMTAB(2)),(ICOMTX,SYMTAB(2)),(ISNOL,SYMTAB(2))_^1_$DIMENSION IRSA(100), ICOMTX(100),ISNOL(100)_^1_$BYTE (IDATAS,SYMTAB(3)(15=15)),(IREF,SYMTAB(3)(15=15)),_^1_#$ (IEQVX,SYMTAB(3)(14=8)),(ITILF,SYMTAB(3)(14=8))_^1_$DIMENSION IDATAS(100),IREF(100),IEQVX(100),ITILF(100)_^1_$BY€€TE (IPARTR,SYMTAB(3)(7=4)),(INDUCV,SYMTAB(3)(7=7)),(ISFARG,_^1_#$ SYMTAB(3)(6=6)),(IARGNO,SYMTAB(3)(5=0)),(IPARTL,SYMTAB(3)(3=0))_^1_$DIMENSION IPARTR(100),INDUCV(100),ISFARG(100),IARGNO(100),_^1_#$ IPARTL(100)_^1_$EQUIVALENCE (ISYM,SYMTAB(4))_^1_$DIMENSION ISYM(100)_^1C_]_^1C_#SPECIFICATION-TABLE INDEX LABELLED COMMON BLOCK_^1_$COMMON /A/ ISTABX(96)_^1C_]_^1C_#PHASE A BLANK COMMON€€ BLOCK._^1_$COMMON // JSYM(3),JTERM,JMODE,JERR,JESWT,JFLOT,JCHAR,_^1_#$JOCHAR,JO1,JE,JE1,JBLANK,JCT,JCT1_^1C_#JSYM-JCT1 MUST REMAIN IN ORDER_^1_$COMMON//IERR_^1_$COMMON//ISORS(208),ISORSX_^1_$COMMON//IDEFF,ISTOP,IRET,ISPEC,NERR,OCT_^1_$INTEGER OCT_^1_$COMMON//ILLABL,LEST,ISNGL1,ICOMX1,NXTYPE,LOGIF,IOVFL1,IOVFL2_^1_$COMMON//IVCFLG,ISFLG,LOGEX,KEQVX_^1_$COMMON//IBUF2X,IBUF2(304)_^1C_€€$TEMPORARY ARITHMETIC BUFFERS_^1_$COMMON//IBUF1( 304),IBUF1X,IWORK (304)_^1C_#TEMPORARY EQUIVALENCE BUFFERS_^1_$DIMENSION KEQV(460),MEQV(255)_^1_$EQUIVALENCE (KEQV,IBUF1(66)),(MEQV,IBUF2(100))_^1C_#LS1-ITEM MUST REMAIN IN ORDER_^1_$COMMON//LS1,LPREN,LRELRQ,LRELEN,LSWITC,LO,ITEM_^1_$COMMON//MODE_^1_$COMMON//IPHAT(4),IGNSTT(49),IOSPRT(17)_^1C_]_^1C_]_^1C_]_^1C_#THIS IS THE PROCESSOR €€FOR COMMON STATEMENTS_^1C_#JUMP IF FIELD IS NOT NUL_^1C_]_^1_$ITEMP1=ISORSX_^1_$CALL GETF_^1_$IF(JMODE.NE.0) GO TO 2_^1C_]_^1C_#JUMP IF TERMINATOR IS NOT 1_^1C_]_^1_$IF(JTERM.NE.44) GO TO 4_^1_"1 CALL GETF_^1C_]_^1C_#JUMP IF FIELD NEITHER VARIABLE NOR NUL_^1C_]_^1_$IF(JMODE.GT.2) GO TO 4_^1C_]_^1C_#JUMP IF FIELD IS NUL OR BLANK_^1_$IF(JMODE.EQ.0)GO TO 8_^1C_#JUMP TO 10 IF COMMON BL€€OCK NAME IS IN ICOMT_^1C_]_^1_$ITEMP2=ICOMTL+2_^1_$DO 11 I=ITEMP2,ICOMX2,ICOMTL_^1_$IF (ICOMBN(I-1).EQ.JSYM(1).AND.ICOMBN(I).EQ.JSYM(2)) GO TO 10_^1_!11 CONTINUE_^1C_]_^1C_#JUMP IF NO MORE COMMON BLOCK ENTRIES AVAILABLE IN ICOMT_^1C_]_^1_$IF(ICOMX2-1.EQ.ICOMTS) GO TO 12_^1C_]_^1C_#SET UP NEW ICOMT ENTRY_^1C_]_^1_$ICOMX1=ICOMX2_^1_$ITEMP1=ICOMX1_^1_$DO 13 I=1,2_^1_$ICOMBN(ITEMP1)=JS€€YM(I)_^1_!13 ITEMP1=ITEMP1+1_^1_$ICOMX2=ICOMX2+ICOMTL_^1C_]_^1C_#JUMP IF FIELD TERMINATOR NOT 1_^1C_]_^1_"9 IF(JTERM.NE.44) GO TO 4_^1C_]_^1C_#CALL DIMENSIONING PROCESSOR_^1C_]_^1_"3 ISFLG=2_^1_$CALL DIMPR_^1_$IF(JTERM.EQ.47) RETURN_^1_$GO TO 1_^1C_]_^1C_#FIND BLANK COMMON ICOMT INDEX AND RESTORE ISORS INDEX_^1C_]_^1_"2 ICOMX1=1_^1_$ISORSX=ITEMP1_^1_$GO TO 3_^1C_]_^1C_#SYNTAX ERROR€€_^1C_]_^1_"4 CALL DIAG($19)_^1_$GO TO 5_^1_"6 CALL GETF_^1_$IF(JTERM.EQ.44) GO TO 1_^1_$IF(JTERM.EQ.47) RETURN_^1_$GO TO 6_^1C_]_^1C_#STORE BLANK COMMON INDEX_^1C_]_^1_"8 ICOMX1=1_^1_$GO TO 9_^1C_]_^1C_#SAVE COMMON BLOK INDEX_^1C_]_^1_!10 ICOMX1=I-1_^1_$GO TO 9_^1C_]_^1C_#ICOMT HAS OVERFLOWED_^1C_]_^1_!12 CALL DIAG($24)_^1_$ICOMX1=ICOMX2-ICOMTL_^1_$GO TO 9_^1C_#SCAN TO NEXT COMMON €xBLOCK NAME_^1C_]_^1_"7 CALL GETF_^1_"5 IF(JTERM.GE.41.AND.JTERM.LE.43) GO TO 6_^1_$IF(JTERM.NE.47) GO TO 7_^1_$END_]_^__xPWDIMPR CSY/ 16A P€1_$SUBROUTINE DIMPR_^1_#*_2/DECK-ID 16A FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^13_]_^1C DIMPR IS USED IN PHASE A2_^1C_]_^1C_#MASTER LABELED COMMON BLOCK._^1*_] FTN 3.3_^1_$COMMON /A/ IFLAGS,LINECT,LINCT1_^1_$COMMON /A/ IR,IK,IP,IA,IL,IM,IXLGO,IOP€€TO,IOPTV,IOPTC,IOPTD_^1_$COMMON /A/ MCSTRT,MACRNB,MACSEC_^1_$COMMON /A/ IERRS(16),ISRFAD_^1_$COMMON /A/ LGO,ISCRI,ISCRO,IX_^1*_] FTN 3.3_^1_$COMMON /A/ IGLAB(3),IGLAB1,IGLAB2_^1_$COMMON /A/ ICOMT(12),ICOMTS,ICOMX2,ICOMTL,ISUBP,NDPRS,_^1_#$LABX,IBCDTB(48)_^1_$EQUIVALENCE(ICOMB,ICOMT(1)),(ICOMBX,ICOMT(2)),(ICOMDF,_^1_#$ICOMT(3)),(ICOMBN,ICOMT(4))_^1_$DIMENSION ICOMB(6),ICOMBX(6),ICO€€MDF(6),ICOMBN(7)_^1_$COMMON /A/ LOOPTS,LOOPTX,LOOPTB,LOOPT(50)_^1_$EQUIVALENCE(LINDUC,LOOPT(1))_^1_$DIMENSION LINDUC(10)_^1_$EQUIVALENCE (LBEG,LOOPT(2))_^1_$DIMENSION LBEG(10)_^1_$EQUIVALENCE (LINC,LOOPT(3))_^1_$DIMENSION LINC(10)_^1_$EQUIVALENCE (LEND,LOOPT(4))_^1_$DIMENSION LEND(10)_^1_$BYTE(LLABL,LOOPT(5)(14=0)_))_^1_$DIMENSION LLABL(10)_^1_$BYTE(LID,LOOPT(5)(15=15) )_^1_$DIME€€NSION LID(10)_^1_$COMMON/A/IEQV(255), IEQVS,IEQVN2_^1_$COMMON /A/ ISTAB(150),ISTABS,ISTAB2_^1_$COMMON /A/ IBUFS,ISET(25),LBLANK,KSFCNT,KSNCNT,ISORSC,_^1_#$IHOBIT,ISTNO,ISSFLG,ISUBPN,ITERM,JSORSC,KEQVS_^1C_#SYMBOL TABLE LABELED COMMON BLOCK_^1_$COMMON /A/ ISYMN, ISYMFL,ISYMD,ISYMX,ISYMS,ISYMP,ISYMPC,ISYMPS,_^1_#$ ISYMNS, SYMTAB(960)_^1_$INTEGER SYMTAB_^1_$BYTE (IDUM,SYMTAB(1)(15=15)€€),(KDUMY,SYMTAB(1)(15=15)),_^1_#$(ICLASS,SYMTAB(1)(14=11)),(ITYPE,SYMTAB(1)(10=9))_^1_$DIMENSION IDUM(100),KDUMY(100),ICLASS(100),ITYPE(100)_^1_$BYTE (ISNGL, SYMTAB(1)(8=8)),(KELSIZ,SYMTAB(1)(8=8)),_^1_#$ (ICOM,SYMTAB(1)(7=5)),(IPART,SYMTAB(1)(4=3))_^1_$DIMENSION ISNGL(100),KELSIZ(100),ICOM(100),IPART(100)_^1_$BYTE (KRFCNT,SYMTAB(1)(2=2)),(IDIM,SYMTAB(1)(1=0)),_^1_#$ (IREL,SYMTAB(1€€)(1=1)),(IEXT,SYMTAB(1)(0=0))_^1_$DIMENSION KRFCNT(100),IDIM(100),IREL(100),IEXT(100)_^1_$EQUIVALENCE (IRSA,SYMTAB(2)),(ICOMTX,SYMTAB(2)),(ISNOL,SYMTAB(2))_^1_$DIMENSION IRSA(100), ICOMTX(100),ISNOL(100)_^1_$BYTE (IDATAS,SYMTAB(3)(15=15)),(IREF,SYMTAB(3)(15=15)),_^1_#$ (IEQVX,SYMTAB(3)(14=8)),(ITILF,SYMTAB(3)(14=8))_^1_$DIMENSION IDATAS(100),IREF(100),IEQVX(100),ITILF(100)_^1_$BYTE€€ (IPARTR,SYMTAB(3)(7=4)),(INDUCV,SYMTAB(3)(7=7)),(ISFARG,_^1_#$ SYMTAB(3)(6=6)),(IARGNO,SYMTAB(3)(5=0)),(IPARTL,SYMTAB(3)(3=0))_^1_$DIMENSION IPARTR(100),INDUCV(100),ISFARG(100),IARGNO(100),_^1_#$ IPARTL(100)_^1_$EQUIVALENCE (ISYM,SYMTAB(4))_^1_$DIMENSION ISYM(100)_^1C_]_^1C_#SPECIFICATION-TABLE INDEX LABELLED COMMON BLOCK_^1_$COMMON /A/ ISTABX(96)_^1C_]_^1C_#PHASE A BLANK COMMON B€€LOCK._^1_$COMMON // JSYM(3),JTERM,JMODE,JERR,JESWT,JFLOT,JCHAR,_^1_#$JOCHAR,JO1,JE,JE1,JBLANK,JCT,JCT1_^1C_#JSYM-JCT1 MUST REMAIN IN ORDER_^1_$COMMON//IERR_^1_$COMMON//ISORS(208),ISORSX_^1_$COMMON//IDEFF,ISTOP,IRET,ISPEC,NERR,OCT_^1_$INTEGER OCT_^1_$COMMON//ILLABL,LEST,ISNGL1,ICOMX1,NXTYPE,LOGIF,IOVFL1,IOVFL2_^1_$COMMON//IVCFLG,ISFLG,LOGEX,KEQVX_^1_$COMMON//IBUF2X,IBUF2(304)_^1C_$T€€EMPORARY ARITHMETIC BUFFERS_^1_$COMMON//IBUF1( 304),IBUF1X,IWORK (304)_^1C_#TEMPORARY EQUIVALENCE BUFFERS_^1_$DIMENSION KEQV(460),MEQV(255)_^1_$EQUIVALENCE (KEQV,IBUF1(66)),(MEQV,IBUF2(100))_^1C_#LS1-ITEM MUST REMAIN IN ORDER_^1_$COMMON//LS1,LPREN,LRELRQ,LRELEN,LSWITC,LO,ITEM_^1_$COMMON//MODE_^1_$COMMON//IPHAT(4),IGNSTT(49),IOSPRT(17)_^1C_]_^1C_]_^1C_]_^1C_#THIS SUBROUTINE PROCESSE€€S DIMENSION,TYPE, AND COMMON STATEMENTS,_^1C_#DEPENDING UPON WHETHER ISFLG=1,2, OR 3._^1C_#GET NEXT FIELD AND TERMINATOR_^1C_]_^1_"4 CALL GETF_^1C_#JUMP IF FIELD IS A NAME_^1_!39 IF(JMODE.EQ.2) GO TO 2_^1C_#SYNTAX ERROR. PRINT DIAGNOSTIC AND SKIP TO NEXT COMMA,SLASH, OR_^1C_#EOS. THIS IN A FATAL ERROR._^1_"3 CALL DIAG($19)_^1_$IF(JTERM.EQ.47)RETURN_^1_"1 CALL GETF_^1_!18 IF(JTERM€€.NE.42) GO TO 105_^1_$CALL GETF_^1 132 IF(JTERM.EQ.43) GO TO 4_^1 105 IF(JTERM.EQ.47) RETURN_^1 213 IF(JTERM.NE.44) GO TO 1_^1C_]_^1C_#HAVE FOUND A SLASH. JUMP IF COMMON NOT BEING PROCESSED_^1 2130 IF(ISFLG.NE.2)GO TO 3_^1_$RETURN_^1C_]_^1C_#JUMP IF NAME NOT IN SYMBOL TABLE_^1C_]_^1_"2 IF(ISYMD.EQ.0)GO TO 5_^1C_]_^1C_#JUMP IF IS IN SYMBOL TABLE AS EITHER VARIABLE OR UNASSIGNED€€_^1C_]_^1_$IF(ICLASS(ISYMX).LE.1) GO TO 10_^1C_]_^1C_#JUMP IF NAME IS A FUNCTION AND ARE PROCESSING A TYPE STATEMENT._^1C_#OTHERWISE PRINT DIAGNOSTIC AND SKIP TO LIKELY STATEMENT CHARACTER_^1C_]_^1_$IF(ICLASS(ISYMX).LE.5.AND.ICLASS(ISYMX).NE.3.AND.ISFLG.EQ.3) GO_^1_#1TO 10_^1_"8 CALL DIAG($1B)_^1_$GO TO 132_^1C_]_^1C_#STORE SYMBOL INTO SYMBOL TABLE_^1C_]_^1_"5 CALL STORE_^1C_]_^1C_€€#SET UP THE COMPUTATION OF THE DIMENSIONALITY INFORMATION_^1C_]_^1_!10 ISTAB1=ISTAB2_^1_$ITEMP1=0_^1_$ITEMP2=ISYMX+ISYMP_^1_$ITEMP3=IDUM(ISYMX)_^1C_]_^1C_#JUMP IF COMMON BEING PROCESSED_^1C_]_^1_$IF(ISFLG.EQ.2) GO TO 19_^1C_]_^1C_#JUMP IF A TYPE STATEMENT IS BEING PROCESSED_^1C_]_^1_$IF(ISFLG.EQ.3) GO TO 7_^1_$GO TO 108_^1 122 CALL DIAG($2C)_^1_$GO TO 18_^1_!31 CALL GETF_^1C_]_^1C€€_#JUMP IF FIELD IS NOT AN INTEGER_^1C_]_^1C*************************************************************** 81*2192_^1_$IF(JMODE.NE.3) GO TO 122_^1_$IF(ISTAB1.LE.ISTABS) GO TO 120_^1C_#TOO MANY DECLARED DIMMENSIONS CAUSED TABLE OVERFLOW_^1_$CALL DIAG ($39)_^1_$GO TO 36_^1 120 ISTAB (ISTAB1) = JSYM(1)_^1_$ITEMP1 = ITEMP1 + 1_^1C*******************************************************€€******** 81*2192_^1_!35 ISTAB1=ISTAB1+1_^1C_]_^1C_#JUMP IF ALL SUBSCRIPTS HAVE BEEN PROCESSED_^1C_]_^1_!36 IF(JTERM.EQ.42) GO TO 33_^1C_]_^1C_#JUMP IF THREE DIMENSIONS HAVE ALREADY BEEN PROCESSED_^1C_]_^1_$IF(ITEMP1.EQ.3) GO TO 34_^1C_#JUMP IF TERMINATOR IS ,_^1C_]_^1 106 IF(JTERM.EQ.43) GO TO 31_^1_$GO TO 3_^1C_#SET UP DIMENSIONING INFORMATION IN SYMBOL TABLE_^1_!33 ISYMX=ITEMP2_€€^1_$CALL GETSYM_^1_$IDIM(ISYMX)=ITEMP1_^1_$I=ISYMX/(2*ISYMFL) +1_^1_$IF (AND(ISYMX,1).EQ.1) GO TO 910_^1_$ISTABX(I)=AND(ISTABX(I),$FF00)+ISTAB2_^1_$GO TO 920_^1 910 ISTABX(I)=AND(ISTABX(I),$00FF)+ISTAB2*$0100_^1 920 ISTAB2=ISTAB1_^1_$CALL GETF_^1C_#JUMP IF FIELD NOT NUL_^1_$IF(JMODE.NE.0) GO TO 38_^1C_#JUMP IF END OF STATEMENT_^1 211 IF(JTERM.EQ.47) RETURN_^1_$IF(JTERM.EQ.44)GO €€TO 2130_^1C_#JUMP IF COMMA_^1C_]_^1_$IF(JTERM.EQ.43) GO TO 4_^1_$GO TO 3_^1_!38 CALL DIAG($2020)_^1_$GO TO 39_^1C_]_^1C_#COMMON BEING PROCESSED - INSERT SYMBOL TABLE INFORMATION_^1C_]_^1C_]_^1C_#JUMP IF NAME IS NOT A DUMMY ARGUMENT NOR HAS PREVIOUSLY_^1C_#APPEARED IN COMMON._^1C_]_^1_!19 ITEMP4=ICOM(ISYMX)_^1_$IF(ITEMP3.EQ.0.AND.ITEMP4.EQ.0) GO TO 171_^1_$CALL DIAG(37)_^1_$GO TO 13€€2_^1 171 ICOM(ISYMX)=ICOMX1_^1C_]_^1C_#JUMP IF THIS IS AN ATTEMPT TO DIMENSION AN ARRAY AGAIN._^1C_]_^1_$IF(JTERM.EQ.41.AND.IDIM(ISYMX).NE.0) GO TO 212_^1C_]_^1C_#THREAD THE COMMON BLOCK ARRAYS_^1C_]_^1_$ICOMTX(ISYMX)=ICOMBX(ICOMX1)_^1_$ICOMBX(ICOMX1)=ISYMX+ISYMP_^1 108 ICLASS(ISYMX)=1_^1C_]_^1C_#JUMP IF NO DIMENSIONING_^1C_]_^1 107 IF (JTERM.NE.41) GO TO 15_^1_$ICLASS(ISYMX)=1_€€^1C_]_^1C_#JUMP IF NOT PREVIOUSLY DIMENSIONED_^1C_]_^1_$IF(IDIM(ISYMX).EQ.0) GO TO 31_^1 212 CALL DIAG($201A)_^1_$GO TO 213_^1C_]_^1C_#JUMP IF TERMINATOR NOT COMMA_^1_!15 IF(JTERM.NE.43)GO TO 211_^1C_#JUMP IF PROCESSING COMMON OR TYPE_^1C_]_^1_$IF(ISFLG.GE.2) GO TO 4_^1_$CALL DIAG($19)_^1_$GO TO 132_^1C_#JUMP IF NOT PREVIOUSLY TYPED DIFFERENTLY_^1C_]_^1_"7 IF(ITYPE(ISYMX).EQ.IBUF2€€(3)-1.OR.ITYPE(ISYMX).EQ.0) GO TO 21_^1C_8BEGIN_4***** FTN 3.1 *****_^1_$IF (IBUF2(3).EQ.46.AND.ITYPE(ISYMX).EQ.3) GO TO 21_^1C_8END_6***** FTN 3.1 *****_^1_$CALL DIAG($2026)_^1_$GO TO 107_^1C_#A TYPE STATEMENT IS BEING PROCESSED, SO SET SYMBOL TABLE INFO_^1C_]_^1C_8BEGIN_4***** FTN 3.1 *****_^1_!21 IF (IBUF2(3).EQ.46) ITYPE(ISYMX)=3_^1_$IF(IBUF2(3).EQ.3) ITYPE(ISYMX)=2_^1_$IF(IBU€œF2(3).EQ.2) ITYPE(ISYMX)=1_^1C_8END_6***** FTN 3.1 *****_^1_$IF(ISNGL1.NE.0)ISNGL(ISYMX)=1_^1_$GO TO 107_^1_!34 CALL DIAG (45)_^1_$GO TO 106_^1_$END_]_^__ œPWSBSCR CSY/ 17A P€1_$SUBROUTINE SUBSCR_^1_#*_2/DECK-ID 17A FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^13_]_^1C_]_^1C SUBSCR IS USED IN PHASE A4_^1C_]_^1C_#MASTER LABELED COMMON BLOCK._^1*_] FTN 3.3_^1_$COMMON /A/ IFLAGS,LINECT,LINCT1_^1_$COMMON /A/ IR,IK,IP,IA,IL,IM,I€€XLGO,IOPTO,IOPTV,IOPTC,IOPTD_^1_$COMMON /A/ MCSTRT,MACRNB,MACSEC_^1_$COMMON /A/ IERRS(16),ISRFAD_^1_$COMMON /A/ LGO,ISCRI,ISCRO,IX_^1*_] FTN 3.3_^1_$COMMON /A/ IGLAB(3),IGLAB1,IGLAB2_^1_$COMMON /A/ ICOMT(12),ICOMTS,ICOMX2,ICOMTL,ISUBP,NDPRS,_^1_#$LABX,IBCDTB(48)_^1_$EQUIVALENCE(ICOMB,ICOMT(1)),(ICOMBX,ICOMT(2)),(ICOMDF,_^1_#$ICOMT(3)),(ICOMBN,ICOMT(4))_^1_$DIMENSION ICOMB(6),ICOMB€€X(6),ICOMDF(6),ICOMBN(7)_^1_$COMMON /A/ LOOPTS,LOOPTX,LOOPTB,LOOPT(50)_^1_$EQUIVALENCE(LINDUC,LOOPT(1))_^1_$DIMENSION LINDUC(10)_^1_$EQUIVALENCE (LBEG,LOOPT(2))_^1_$DIMENSION LBEG(10)_^1_$EQUIVALENCE (LINC,LOOPT(3))_^1_$DIMENSION LINC(10)_^1_$EQUIVALENCE (LEND,LOOPT(4))_^1_$DIMENSION LEND(10)_^1_$BYTE(LLABL,LOOPT(5)(14=0)_))_^1_$DIMENSION LLABL(10)_^1_$BYTE(LID,LOOPT(5)(15=15) )_€€^1_$DIMENSION LID(10)_^1_$COMMON/A/IEQV(255), IEQVS,IEQVN2_^1_$COMMON /A/ ISTAB(150),ISTABS,ISTAB2_^1_$COMMON /A/ IBUFS,ISET(25),LBLANK,KSFCNT,KSNCNT,ISORSC,_^1_#$IHOBIT,ISTNO,ISSFLG,ISUBPN,ITERM,JSORSC,KEQVS_^1C_#SYMBOL TABLE LABELED COMMON BLOCK_^1_$COMMON /A/ ISYMN, ISYMFL,ISYMD,ISYMX,ISYMS,ISYMP,ISYMPC,ISYMPS,_^1_#$ ISYMNS, SYMTAB(960)_^1_$INTEGER SYMTAB_^1_$BYTE (IDUM,SYMTAB(1€€)(15=15)),(KDUMY,SYMTAB(1)(15=15)),_^1_#$(ICLASS,SYMTAB(1)(14=11)),(ITYPE,SYMTAB(1)(10=9))_^1_$DIMENSION IDUM(100),KDUMY(100),ICLASS(100),ITYPE(100)_^1_$BYTE (ISNGL, SYMTAB(1)(8=8)),(KELSIZ,SYMTAB(1)(8=8)),_^1_#$ (ICOM,SYMTAB(1)(7=5)),(IPART,SYMTAB(1)(4=3))_^1_$DIMENSION ISNGL(100),KELSIZ(100),ICOM(100),IPART(100)_^1_$BYTE (KRFCNT,SYMTAB(1)(2=2)),(IDIM,SYMTAB(1)(1=0)),_^1_#$ (IREL,€€SYMTAB(1)(1=1)),(IEXT,SYMTAB(1)(0=0))_^1_$DIMENSION KRFCNT(100),IDIM(100),IREL(100),IEXT(100)_^1_$EQUIVALENCE (IRSA,SYMTAB(2)),(ICOMTX,SYMTAB(2)),(ISNOL,SYMTAB(2))_^1_$DIMENSION IRSA(100), ICOMTX(100),ISNOL(100)_^1_$BYTE (IDATAS,SYMTAB(3)(15=15)),(IREF,SYMTAB(3)(15=15)),_^1_#$ (IEQVX,SYMTAB(3)(14=8)),(ITILF,SYMTAB(3)(14=8))_^1_$DIMENSION IDATAS(100),IREF(100),IEQVX(100),ITILF(100)_€€^1_$BYTE (IPARTR,SYMTAB(3)(7=4)),(INDUCV,SYMTAB(3)(7=7)),(ISFARG,_^1_#$ SYMTAB(3)(6=6)),(IARGNO,SYMTAB(3)(5=0)),(IPARTL,SYMTAB(3)(3=0))_^1_$DIMENSION IPARTR(100),INDUCV(100),ISFARG(100),IARGNO(100),_^1_#$ IPARTL(100)_^1_$EQUIVALENCE (ISYM,SYMTAB(4))_^1_$DIMENSION ISYM(100)_^1C_]_^1C_#SPECIFICATION-TABLE INDEX LABELLED COMMON BLOCK_^1_$COMMON /A/ ISTABX(96)_^1C_]_^1C_#PHASE A BLANK €€COMMON BLOCK._^1_$COMMON // JSYM(3),JTERM,JMODE,JERR,JESWT,JFLOT,JCHAR,_^1_#$JOCHAR,JO1,JE,JE1,JBLANK,JCT,JCT1_^1C_#JSYM-JCT1 MUST REMAIN IN ORDER_^1_$COMMON//IERR_^1_$COMMON//ISORS(208),ISORSX_^1_$COMMON//IDEFF,ISTOP,IRET,ISPEC,NERR,OCT_^1_$INTEGER OCT_^1_$COMMON//ILLABL,LEST,ISNGL1,ICOMX1,NXTYPE,LOGIF,IOVFL1,IOVFL2_^1_$COMMON//IVCFLG,ISFLG,LOGEX,KEQVX_^1_$COMMON//IBUF2X,IBUF2(304€€)_^1C_$TEMPORARY ARITHMETIC BUFFERS_^1_$COMMON//IBUF1( 304),IBUF1X,IWORK (304)_^1C_#TEMPORARY EQUIVALENCE BUFFERS_^1_$DIMENSION KEQV(460),MEQV(255)_^1_$EQUIVALENCE (KEQV,IBUF1(66)),(MEQV,IBUF2(100))_^1C_#LS1-ITEM MUST REMAIN IN ORDER_^1_$COMMON//LS1,LPREN,LRELRQ,LRELEN,LSWITC,LO,ITEM_^1_$COMMON//MODE_^1_$COMMON//IPHAT(4),IGNSTT(49),IOSPRT(17)_^1C_]_^1C_,._^1C_#ANALYZE A SUBSCRIPT_^€€1C_#JDUM1 IS SUBSCRIPT ANALYSIS HODLERS_^1_$DIMENSION JDUM1(10)_^1_$BYTE (IC,SYMTAB(1)(14=11))_^1_(DIMENSION IC(200)_^1C_#SUBSCRIPT ANALYSIS HOLDERS_^1_(DIMENSION IX1(3),ID1(3),ISS(3),IC1(3)_^1C_]_^1_$EQUIVALENCE (JDUM1(1),ISFLAG),(JDUM1(2),IX1(1)),(JDUM1(5),ID1(1)),_^1_#1(JDUM1(8),ISS(1))_^1 600 IV=ISYMX_^1_$DO 601 I=1,10_^1 601 JDUM1(I)=0_^1_$IVM=ITYPE(IV)_^1C_] FTN 3.3_^1_$IF€€(IBUF2(3).EQ.18.OR.IBUF2(3).EQ.19.OR.IBUF2(3).EQ.21.OR._^1_#*_!IBUF2(3).EQ.42.OR.IBUF2(3).EQ.43) IVM=1_^1C_] FTN 3.3_^1C_#TWO WORD INTEGER_^1_$IF(ITYPE(IV).EQ.1.AND.IK.NE.0.AND.ISNGL(IV).EQ.0)IVM=2_^1_$K=IDIM(IV)_^1_$DO 602 I=1,K,1_^1C_#SET MAXIMUM DIMENSIONS IN ISS_^1_$J=IV/(2*ISYMFL) +1_^1_$J=ISTABX(J)_^1_$IF (AND(IV,1).EQ.1) J=J/$0100_^1_$J=AND(J,$FF)+I-1_^1 602 ISS(I)=ISTAB(J€€)_^1_$ISSX=1_^1_$DO 6020 I=1,3_^1 6020 IC1(I)=IVM_^1_$IV=IBUF1X-2_^1C_#GET FIRST FIELD IN SUBSCRIPT AFTER , OR (_^1 606 CALL GETF_^1_$IF(JERR.NE.0)GO TO 610_^1_$IF(JMODE.EQ.3) GO TO 603_^1 6060 IF(JMODE.EQ.2)GO TO 205_^1 605 CALL DIAG (24)_^1610_!IF(JTERM.NE.43) GO TO 620_^1C_#IF WE ALREADY HAVE 3 DIMENSIONS,ERROR_^1612_!IF(ISSX.EQ.3)GO TO 621_^1_$ISSX=ISSX+1_^1_$IF(ISS(ISSX).NE.€€0) GO TO 606_^1_$GO TO 621_^1C_#INTEGER-FIRST FIELD_^1 603 IF(JTERM.NE.43) GO TO 640_^1C_#DIMENSION IS A CONSTANT_^1_$IF(JSYM(1).EQ.0)CALL DIAG(24)_^1_$GO TO 615_^1 205 IF(ISYMD.EQ.0)CALL STORE_^1_$IF(ITYPE(ISYMX).EQ.0)ITYPE(ISYMX)=JESWT_^1_$IF(IC(ISYMX).EQ.0)IC(ISYMX)=1_^1_$IF(IC(ISYMX).EQ.1.AND.ITYPE(ISYMX).EQ.1.AND.IDIM(ISYMX).EQ.0)_^1_#1 GO TO 6090_^1C DIAG -24 ILLEGAL SUBSCR€€IPT_^1_%CALL DIAG(24)_^1 6090 IX1(ISSX)=ISYMX+ISYMP_^1_$IF(JTERM.EQ.39)ISFLAG=1_^1C_#+ OR -_0TERMINATOR_^1_$IF(JTERM.NE.38.AND.JTERM.NE.39) GO TO 610_^1_$CALL GETF_^1_$IF(JERR.NE.0) GO TO 610_^1_$IF(JMODE.NE.3) GO TO 605_^1C_#CONSTANT INCREMENT_^1_$IF(ISFLAG.NE.0) GO TO 613_^1C_#POSITIVE CONSTANT_^1615_!ID1(ISSX)=JSYM(1)_^1_$GO TO 610_^1 613 ID1(ISSX)=-JSYM(1)_^1_$ISFLAG=0_^1_$GO €€TO 610_^1C_#DIMENSION TERMINATOR_^1 620 IF(JTERM.EQ.42) GO TO 645_^1 621 CALL DIAG(24)_^1 622 IF(JTERM.EQ.47)RETURN_^1_$CALL GETF_^1_$IF(JTERM.EQ.43) GO TO 612_^1_$IF(JTERM.EQ.42) GO TO 645_^1_$GO TO 622_^1C_#FIRST FIELD IN DIMENSION IS A CONSTANT_^1 640 IF(JTERM.EQ.42)GO TO 641_^1_$IF(JTERM.NE.45)GO TO 621_^1_$IC1(ISSX)=IC1(ISSX)*JSYM(1)_^1_$CALL GETF_^1_$IF(JERR.NE.0) GO TO 6€€10_^1_$GO TO 6060_^1 649 CALL DIAG(24)_^1646_!RETURN_^1 642 IF(ISSX.NE.1)GO TO 644_^1_$IBUF1(IBUF1X)=IVM_^1_$ASSIGN 646 TO IAD_^1 643 IBUF1(IV)=IBUF1(IV)+2_^1_$IBUF1X=IBUF1X+1_^1_$IF(IBUF1X.GT.IBUFS)CALL PUNT_^1_$GO TO IAD_^1 641 IF(JSYM(1).EQ.1) GO TO 642_^1 644 IF(JSYM(1).EQ.0) GO TO 649_^1_$ID1(ISSX)=JSYM(1)_^1C_#IS THIS LAST DIMENSION SPECIFIED AS WALL AS LAST GIVEN_^1 64€€5 IF(ISSX.NE.3.AND.ISS(ISSX+1).NE.0) GO TO 649_^1_$IF(IERR.NE.0) GO TO 646_^1C_=._^1C_#THE SUBSCRIPT HAS BEEN BROKEN INTO COMPONENTS-PUT IT INTO POLYNOM_^1_$IF(ISS(2).NE.0)ID1(2)=ID1(2)-1_^1_$IF(ISS(3).NE.0) ID1(3)=ID1(3)-1_^1_$IC1(3)=IC1(3)*ISS(1)*ISS(2)_^1_$IC1(2)=IC1(2)*ISS(1)_^1_$JSYM(1)=_$(ISS(1)*(ID1(2)+ID1(3)*ISS(2))+ID1(1))*IVM_^1_$J=0_]_^1_$DO 661 I=1,3_^1_$IF(IX1(I).NE.0)€€J=J+1_^1 661 CONTINUE_^1_$IF(J.EQ.0)GO TO 665_^1_$DO 662 I=1,3_^1C_#UP COUNT IF THERE IS A CONSTANT MULTIPLIER FIR N_^1C_#NON ZERO VARIABLE_^1_$IF(IC1(I).NE.1.AND.IX1(I).NE.0)J=J+1_^1 662 CONTINUE_^1 665 IF(JSYM(1).EQ.0) GO TO 664_^16651 IBUF1(IBUF1X)=JSYM(1)_^1_$ASSIGN 663 TO IAD_^1_$GO TO 643_^1 663 IF(J.EQ.0)GO TO 646_^1_$IF(J.NE.1) GO TO 667_^1C_#SET VARIABLE PORTION OF SU€€BSCRIPT FOR TYPES 1 AND 3_^1 666 IBUF1(IBUF1X+1)=IX1(1)+IX1(2)+IX1(3)_^1C_#GET VARIABLE IN SUBSCRIPT AND LOOK AT IT_^1_$ISYMX=IBUF1(IBUF1X+1)_^1_$CALL GETSYM_^1_$IBUF1(IBUF1X)=24_^1_$IF(IPART(ISYMX).NE.0)IBUF1(IBUF1X)=29_^1_$IBUF1X=IBUF1X+2_^1_$IBUF1(IV)=IBUF1(IV)+1_^1_$GO TO 646_^1 664 IF(J.EQ.0) GO TO 649_^1_$IF(J.NE.1) GO TO 6651_^1_$GO TO 666_^1C_#SAVE START OF SUBSCRIPT_^1 €€667 IBUF1(IBUF1X)=IBUF1X_^1_$IF(IBUF1X+3.GT.IBUFS)CALL PUNT_^1_$IBUF1(IBUF1X+1)=16_^1_$IBUF1(IBUF1X+2)=8_^1_$IBUF1X=IBUF1X+3_^1_$J=IBUF1(IV)_^1_$DO 670 I=1,3_^1_$IF(IX1(I).EQ.0) GO TO 670_^1_$IF(IC1(I).EQ.1) GO TO 669_^1_$JSYM(1)=IC1(I)_^1_$JSYM(2)=0_^1_$JSYM(3)=9252_^1_$IBUF1(IBUF1X)=35_^1_$IBUF1X=IBUF1X+1_^1_$IF(IBUF1X.GT.IBUFS) CALL PUNT_^1_$CALL SYMBOL_^1_$IF(ISYMD.EQ.0)CALL S€€TORE_^1_$IC(ISYMX)=2_^1_$ITYPE(ISYMX)=1_^1_$IBUF1(IBUF1X)=ISYMX+ISYMP_^1_$ASSIGN 668 TO IAD_^1_$GO TO 643_^1 668 IBUF1(IBUF1X)=13_^1_$IF(IBUF1X+2.GT.IBUFS)CALL PUNT_^1_$IBUF1(IBUF1X+1)=6_^1_$IBUF1X=IBUF1X+2_^1 669 IBUF1(IBUF1X)=24_^1_$ISYMX=IX1(I)_^1_$CALL GETSYM_^1_$IF(IPART(ISYMX).NE.0)IBUF1(IBUF1X)=29_^1_$IF(IBUF1X+4.GT.IBUFS)CALL PUNT_^1_$IBUF1(IBUF1X+1)=IX1(I)_^1_$IBUF1(IBUF€ô1X+2)=11_^1_$IBUF1(IBUF1X+3)=5_^1_$IBUF1X=IBUF1X+4_^1 670 CONTINUE_^1_$IBUF1(IBUF1X-2)=17_^1_$IBUF1(IBUF1X-1)=8_^1C_#SET NO OF WORDS IN COMPLEX PART OF SUBSCRIPT_^1_$IBUF1(IV+3)=IBUF1X-IBUF1(IV+3)_^1_$IBUF1(IV)=J+2_^1_$GO TO 646_^1_$END_]_^__ ôPWTYPPR CSY/ 18A P€1_$SUBROUTINE TYPEPR_^1_#*_2/DECK-ID 18A FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^13_]_^1C TYPEPR IS USED IN PHASE A2_^1C_]_^1C_#MASTER LABELED COMMON BLOCK._^1*_] FTN 3.3_^1_$COMMON /A/ IFLAGS,LINECT,LINCT1_^1_$COMMON /A/ IR,IK,IP,IA,IL,IM,IXLGO,I€€OPTO,IOPTV,IOPTC,IOPTD_^1_$COMMON /A/ MCSTRT,MACRNB,MACSEC_^1_$COMMON /A/ IERRS(16),ISRFAD_^1_$COMMON /A/ LGO,ISCRI,ISCRO,IX_^1*_] FTN 3.3_^1_$COMMON /A/ IGLAB(3),IGLAB1,IGLAB2_^1_$COMMON /A/ ICOMT(12),ICOMTS,ICOMX2,ICOMTL,ISUBP,NDPRS,_^1_#$LABX,IBCDTB(48)_^1_$EQUIVALENCE(ICOMB,ICOMT(1)),(ICOMBX,ICOMT(2)),(ICOMDF,_^1_#$ICOMT(3)),(ICOMBN,ICOMT(4))_^1_$DIMENSION ICOMB(6),ICOMBX(6),I€€COMDF(6),ICOMBN(7)_^1_$COMMON /A/ LOOPTS,LOOPTX,LOOPTB,LOOPT(50)_^1_$EQUIVALENCE(LINDUC,LOOPT(1))_^1_$DIMENSION LINDUC(10)_^1_$EQUIVALENCE (LBEG,LOOPT(2))_^1_$DIMENSION LBEG(10)_^1_$EQUIVALENCE (LINC,LOOPT(3))_^1_$DIMENSION LINC(10)_^1_$EQUIVALENCE (LEND,LOOPT(4))_^1_$DIMENSION LEND(10)_^1_$BYTE(LLABL,LOOPT(5)(14=0)_))_^1_$DIMENSION LLABL(10)_^1_$BYTE(LID,LOOPT(5)(15=15) )_^1_$DI€€MENSION LID(10)_^1_$COMMON/A/IEQV(255), IEQVS,IEQVN2_^1_$COMMON /A/ ISTAB(150),ISTABS,ISTAB2_^1_$COMMON /A/ IBUFS,ISET(25),LBLANK,KSFCNT,KSNCNT,ISORSC,_^1_#$IHOBIT,ISTNO,ISSFLG,ISUBPN,ITERM,JSORSC,KEQVS_^1C_#SYMBOL TABLE LABELED COMMON BLOCK_^1_$COMMON /A/ ISYMN, ISYMFL,ISYMD,ISYMX,ISYMS,ISYMP,ISYMPC,ISYMPS,_^1_#$ ISYMNS, SYMTAB(960)_^1_$INTEGER SYMTAB_^1_$BYTE (IDUM,SYMTAB(1)(15=1€€5)),(KDUMY,SYMTAB(1)(15=15)),_^1_#$(ICLASS,SYMTAB(1)(14=11)),(ITYPE,SYMTAB(1)(10=9))_^1_$DIMENSION IDUM(100),KDUMY(100),ICLASS(100),ITYPE(100)_^1_$BYTE (ISNGL, SYMTAB(1)(8=8)),(KELSIZ,SYMTAB(1)(8=8)),_^1_#$ (ICOM,SYMTAB(1)(7=5)),(IPART,SYMTAB(1)(4=3))_^1_$DIMENSION ISNGL(100),KELSIZ(100),ICOM(100),IPART(100)_^1_$BYTE (KRFCNT,SYMTAB(1)(2=2)),(IDIM,SYMTAB(1)(1=0)),_^1_#$ (IREL,SYMTAB€€(1)(1=1)),(IEXT,SYMTAB(1)(0=0))_^1_$DIMENSION KRFCNT(100),IDIM(100),IREL(100),IEXT(100)_^1_$EQUIVALENCE (IRSA,SYMTAB(2)),(ICOMTX,SYMTAB(2)),(ISNOL,SYMTAB(2))_^1_$DIMENSION IRSA(100), ICOMTX(100),ISNOL(100)_^1_$BYTE (IDATAS,SYMTAB(3)(15=15)),(IREF,SYMTAB(3)(15=15)),_^1_#$ (IEQVX,SYMTAB(3)(14=8)),(ITILF,SYMTAB(3)(14=8))_^1_$DIMENSION IDATAS(100),IREF(100),IEQVX(100),ITILF(100)_^1_$BY€€TE (IPARTR,SYMTAB(3)(7=4)),(INDUCV,SYMTAB(3)(7=7)),(ISFARG,_^1_#$ SYMTAB(3)(6=6)),(IARGNO,SYMTAB(3)(5=0)),(IPARTL,SYMTAB(3)(3=0))_^1_$DIMENSION IPARTR(100),INDUCV(100),ISFARG(100),IARGNO(100),_^1_#$ IPARTL(100)_^1_$EQUIVALENCE (ISYM,SYMTAB(4))_^1_$DIMENSION ISYM(100)_^1C_]_^1C_#SPECIFICATION-TABLE INDEX LABELLED COMMON BLOCK_^1_$COMMON /A/ ISTABX(96)_^1C_]_^1C_#PHASE A BLANK COMMON€€ BLOCK._^1_$COMMON // JSYM(3),JTERM,JMODE,JERR,JESWT,JFLOT,JCHAR,_^1_#$JOCHAR,JO1,JE,JE1,JBLANK,JCT,JCT1_^1C_#JSYM-JCT1 MUST REMAIN IN ORDER_^1_$COMMON//IERR_^1_$COMMON//ISORS(208),ISORSX_^1_$COMMON//IDEFF,ISTOP,IRET,ISPEC,NERR,OCT_^1_$INTEGER OCT_^1_$COMMON//ILLABL,LEST,ISNGL1,ICOMX1,NXTYPE,LOGIF,IOVFL1,IOVFL2_^1_$COMMON//IVCFLG,ISFLG,LOGEX,KEQVX_^1_$COMMON//IBUF2X,IBUF2(304)_^1C_€€$TEMPORARY ARITHMETIC BUFFERS_^1_$COMMON//IBUF1( 304),IBUF1X,IWORK (304)_^1C_#TEMPORARY EQUIVALENCE BUFFERS_^1_$DIMENSION KEQV(460),MEQV(255)_^1_$EQUIVALENCE (KEQV,IBUF1(66)),(MEQV,IBUF2(100))_^1C_#LS1-ITEM MUST REMAIN IN ORDER_^1_$COMMON//LS1,LPREN,LRELRQ,LRELEN,LSWITC,LO,ITEM_^1_$COMMON//MODE_^1_$COMMON//IPHAT(4),IGNSTT(49),IOSPRT(17)_^1C_]_^1C_]_^1C_#THIS ROUTINE IS THE PROCESSO€¾R FOR TYPE STATEMENTS_^1_$ISFLG=3_^1_$ISNGL1=1_^1C_]_^1C_#JUMP IF TYPE NOT SINGLE_^1C_]_^1_$IF(IBUF2(3).NE.7) GO TO 1_^1_$IBUF2(3)=2_^1_$GO TO 2_^1_"1 ISNGL1=0_^1_"2 CALL DIMPR_^1_$END_]_^__¾PWBYEQ CSY/ 19A P€1_$SUBROUTINE BYEQPR_^1_#*_2/DECK-ID 19A FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^13_]_^1C BYEQPR IS USED IN PHASE A2_^1C_]_^1C_#MASTER LABELED COMMON BLOCK._^1*_] FTN 3.3_^1_$COMMON /A/ IFLAGS,LINECT,LINCT1_^1_$COMMON /A/ IR,IK,IP,IA,IL,IM,IXLGO,I€€OPTO,IOPTV,IOPTC,IOPTD_^1_$COMMON /A/ MCSTRT,MACRNB,MACSEC_^1_$COMMON /A/ IERRS(16),ISRFAD_^1_$COMMON /A/ LGO,ISCRI,ISCRO,IX_^1*_] FTN 3.3_^1_$COMMON /A/ IGLAB(3),IGLAB1,IGLAB2_^1_$COMMON /A/ ICOMT(12),ICOMTS,ICOMX2,ICOMTL,ISUBP,NDPRS,_^1_#$LABX,IBCDTB(48)_^1_$EQUIVALENCE(ICOMB,ICOMT(1)),(ICOMBX,ICOMT(2)),(ICOMDF,_^1_#$ICOMT(3)),(ICOMBN,ICOMT(4))_^1_$DIMENSION ICOMB(6),ICOMBX(6),I€€COMDF(6),ICOMBN(7)_^1_$COMMON /A/ LOOPTS,LOOPTX,LOOPTB,LOOPT(50)_^1_$EQUIVALENCE(LINDUC,LOOPT(1))_^1_$DIMENSION LINDUC(10)_^1_$EQUIVALENCE (LBEG,LOOPT(2))_^1_$DIMENSION LBEG(10)_^1_$EQUIVALENCE (LINC,LOOPT(3))_^1_$DIMENSION LINC(10)_^1_$EQUIVALENCE (LEND,LOOPT(4))_^1_$DIMENSION LEND(10)_^1_$BYTE(LLABL,LOOPT(5)(14=0)_))_^1_$DIMENSION LLABL(10)_^1_$BYTE(LID,LOOPT(5)(15=15) )_^1_$DI€€MENSION LID(10)_^1_$COMMON/A/IEQV(255), IEQVS,IEQVN2_^1_$COMMON /A/ ISTAB(150),ISTABS,ISTAB2_^1_$COMMON /A/ IBUFS,ISET(25),LBLANK,KSFCNT,KSNCNT,ISORSC,_^1_#$IHOBIT,ISTNO,ISSFLG,ISUBPN,ITERM,JSORSC,KEQVS_^1C_#SYMBOL TABLE LABELED COMMON BLOCK_^1_$COMMON /A/ ISYMN, ISYMFL,ISYMD,ISYMX,ISYMS,ISYMP,ISYMPC,ISYMPS,_^1_#$ ISYMNS, SYMTAB(960)_^1_$INTEGER SYMTAB_^1_$BYTE (IDUM,SYMTAB(1)(15=1€€5)),(KDUMY,SYMTAB(1)(15=15)),_^1_#$(ICLASS,SYMTAB(1)(14=11)),(ITYPE,SYMTAB(1)(10=9))_^1_$DIMENSION IDUM(100),KDUMY(100),ICLASS(100),ITYPE(100)_^1_$BYTE (ISNGL, SYMTAB(1)(8=8)),(KELSIZ,SYMTAB(1)(8=8)),_^1_#$ (ICOM,SYMTAB(1)(7=5)),(IPART,SYMTAB(1)(4=3))_^1_$DIMENSION ISNGL(100),KELSIZ(100),ICOM(100),IPART(100)_^1_$BYTE (KRFCNT,SYMTAB(1)(2=2)),(IDIM,SYMTAB(1)(1=0)),_^1_#$ (IREL,SYMTAB€€(1)(1=1)),(IEXT,SYMTAB(1)(0=0))_^1_$DIMENSION KRFCNT(100),IDIM(100),IREL(100),IEXT(100)_^1_$EQUIVALENCE (IRSA,SYMTAB(2)),(ICOMTX,SYMTAB(2)),(ISNOL,SYMTAB(2))_^1_$DIMENSION IRSA(100), ICOMTX(100),ISNOL(100)_^1_$BYTE (IDATAS,SYMTAB(3)(15=15)),(IREF,SYMTAB(3)(15=15)),_^1_#$ (IEQVX,SYMTAB(3)(14=8)),(ITILF,SYMTAB(3)(14=8))_^1_$DIMENSION IDATAS(100),IREF(100),IEQVX(100),ITILF(100)_^1_$BY€€TE (IPARTR,SYMTAB(3)(7=4)),(INDUCV,SYMTAB(3)(7=7)),(ISFARG,_^1_#$ SYMTAB(3)(6=6)),(IARGNO,SYMTAB(3)(5=0)),(IPARTL,SYMTAB(3)(3=0))_^1_$DIMENSION IPARTR(100),INDUCV(100),ISFARG(100),IARGNO(100),_^1_#$ IPARTL(100)_^1_$EQUIVALENCE (ISYM,SYMTAB(4))_^1_$DIMENSION ISYM(100)_^1C_]_^1C_#SPECIFICATION-TABLE INDEX LABELLED COMMON BLOCK_^1_$COMMON /A/ ISTABX(96)_^1C_]_^1C_#PHASE A BLANK COMMON€€ BLOCK._^1_$COMMON // JSYM(3),JTERM,JMODE,JERR,JESWT,JFLOT,JCHAR,_^1_#$JOCHAR,JO1,JE,JE1,JBLANK,JCT,JCT1_^1C_#JSYM-JCT1 MUST REMAIN IN ORDER_^1_$COMMON//IERR_^1_$COMMON//ISORS(208),ISORSX_^1_$COMMON//IDEFF,ISTOP,IRET,ISPEC,NERR,OCT_^1_$INTEGER OCT_^1_$COMMON//ILLABL,LEST,ISNGL1,ICOMX1,NXTYPE,LOGIF,IOVFL1,IOVFL2_^1_$COMMON//IVCFLG,ISFLG,LOGEX,KEQVX_^1_$COMMON//IBUF2X,IBUF2(304)_^1C_€€$TEMPORARY ARITHMETIC BUFFERS_^1_$COMMON//IBUF1( 304),IBUF1X,IWORK (304)_^1C_#TEMPORARY EQUIVALENCE BUFFERS_^1_$DIMENSION KEQV(460),MEQV(255)_^1_$EQUIVALENCE (KEQV,IBUF1(66)),(MEQV,IBUF2(100))_^1C_#LS1-ITEM MUST REMAIN IN ORDER_^1_$COMMON//LS1,LPREN,LRELRQ,LRELEN,LSWITC,LO,ITEM_^1_$COMMON//MODE_^1_$COMMON//IPHAT(4),IGNSTT(49),IOSPRT(17)_^1C_]_^1C_]_^1C_]_^1C_#THIS IS THE PASS 1 PRO€€CESSOR FOR BYTE, SIGNED BYTE, AND_^1C_#EQUIVALENCE STATEMENTS._^1_$EQUIVALENCE (JTEMP,ITEMP(1))_^1_$DIMENSION ITEMP(3)_^1_"1 LEQVX=KEQVX_^1_$IFLG1=0_^1_$IERRFG=0_^1_$CALL GETF_^1C_]_^1C_#JUMP IF FIELD IS NOT NUL._^1C_]_^1_$IF(JMODE.NE.0) GO TO 2_^1C_]_^1C_#JUMP IF TERMINATOR IS (._^1C_]_^1_$IF(JTERM.EQ.41) GO TO 3_^1C_#RETURN IF END-OF-STATEMENT._^1_!14 IF(JTERM.EQ.47) RETURN_^1_$€€GO TO 2_^1_"3 I=1_]_^1_!30 CALL GETF_^1C_]_^1C_#JUMP IF FIELD IS A NAME._^1C_]_^1_$IF(JMODE.EQ.2) GO TO 4_^1C_]_^1C_#A SYNTAX ERROR HAS BEEN FOUND._^1C_]_^1_"2 CALL DIAG($19)_^1C_]_^1C_#SET LATEST INCORRECT ENTRIES TO ZERO._^1C_]_^1_"5 ITEMP1=LEQVX-1_^1_$DO 150 J=KEQVX,ITEMP1_^1 150 KEQV(J)=0_^1C_]_^1C_#SEARCH TO EITHER END-OF-STATEMENT OR TO THE CONFIGURATION ),( ._^1C_#RETURN €€IF END-OF STATEMENT. CONTINUE IF FIND CONFIGURATION._^1C_]_^1 151 IF(JTERM.EQ.47) RETURN_^1_$IF(JTERM.EQ.42) GO TO 6_^1_"8 CALL GETF_^1_$GO TO 151_^1_"6 CALL GETF_^1_$IF(JMODE.NE.0.OR.JTERM.NE.43) GO TO 151_^1_$CALL GETF_^1_$IF(JMODE.NE.0.OR.JTERM.NE.41) GO TO 151_^1_$LEQVX=KEQVX_^1_$IFLG1=0_^1_$IERRFG=0_^1_$GO TO 3_^1C_]_^1C_#JUMP IF NAME IN SYMBOL TABLE_^1C_]_^1_"4 IF(ISYMD.NE.0€€) GO TO 9_^1C_#STORE SYMBOL IN SYMBOL TABLE._^1_$CALL STORE_^1C_#JUMP IF NAME IS EITHER A VARIABLE OR UNASSIGNED AND NEITHER_^1C_#IREL NOR IEXT ARE SET_^1_"9 IF(ICLASS(ISYMX).EQ.1.OR.ICLASS(ISYMX)+IREL(ISYMX)+IEXT(ISYMX)_^1_#1.EQ.0) GO TO 10_^1_$CALL DIAG($1B)_^1_$GO TO 5_^1C_#SET CLASS TO STORAGE UNIT, STORE NAME IN EQUIVALENCE TABLES, AND_^1C_#UPDATE TEMPORARY EQUIVALENCE TABLE I€€NDEX._^1C_]_^1_!10 ICLASS(ISYMX)=1_^1_$KEQV(LEQVX)=ISYMX+ISYMP_^1_$LEQVX=LEQVX+4_^1C ********************************** PSR 528 **************************_^1C ********************************** PSR 528 **************************_^1C IF EQUIVALENCE TABLE HAS NOT OVERFLOWED, CONTINUE PROCESSING_^1_$IF(LEQVX.LE.KEQVS) GO TO 200_^1C CALL DIAG 88 WHEN EQUIVALENCE TABLE OVERFLOWS_^1_$C€€ALL DIAG($5058)_^1C ERASE LAST ENTRIES_^1_$GO TO 5_^1C ********************************** PSR 528 **************************_^1C_]_^1C_#JUMP IF THIS IS A BYTE OR SIGNED BYTE STATEMENT._^1C_]_^1C ********************************** PSR 528 **************************_^1 200 IF(IBUF2(3).LT.10) GO TO 11_^1C ********************************** PSR 528 **************************_^1C **€€******************************** PSR 528 **************************_^1C_]_^1C_#JUMP IF TERMINATOR ,_^1C_]_^1_!20 IF(JTERM.EQ.43) GO TO 3_^1C_]_^1C_#JUMP IF NOT END OF CHAIN, I.E. TERMINATOR IS NOT )._^1C_]_^1_!24 IF(JTERM.NE.42) GO TO 12_^1C_]_^1C_#ENTER CHAIN INTO EQUIVALENCE CLASS TABLE. SET END-OF-CHAIN FLAG._^1C_]_^1C_]_^1C_#JUMP IF AT LEAST TWO ELEMENTS ARE IN CHAIN._^1_$IF(L€€EQVX.GT.KEQVX+4) GO TO 51_^1_$CALL DIAG($2059)_^1_$KEQV(KEQVX)=0_^1_$KEQV(KEQVX+1)=0_^1_$KEQV(KEQVX+2)=0_^1_$KEQV(KEQVX+3)=0_^1_$LEQVX=KEQVX_^1_$GO TO 52_^1 51 KEQV(LEQVX)=-1_^1_$KEQVX=LEQVX+1_^1_!52 CALL GETF_^1C_]_^1C_#JUMP IF FIELD IS NUL._^1C_]_^1_$IF(JMODE.EQ.0) GO TO 13_^1C_]_^1C_#A SYNTAX ERROR HAS BEEN FOUND._^1C_]_^1_$CALL DIAG($19)_^1C_]_^1C_#JUMP IF TERMINATOR ,._^1C_]€€_^1_$IF(JTERM.EQ.43) GO TO 1_^1C_]_^1C_#RETURN IF TERMINATOR IS END-OF-STATEMENT._^1_$IF(JTERM.EQ.47) RETURN_^1_$GO TO 5_^1C_#JUMP TO BEGIN NEW CHAIN IF TERMINATOR IS ,._^1C_]_^1_!13 IF(JTERM.EQ.43) GO TO 1_^1C_#JUMP IF TERMINATOR NOT (._^1_$IF(JTERM.NE.41) GO TO 14_^1_$CALL DIAG($2020)_^1_$LEQVX=KEQVX_^1_$IFLG1=0_^1_$IERRFG=0_^1_$GO TO 3_^1C_#JUMP IF FIELD HAS BEEN PREVIOUSLY SUBS€€CRIPTED._^1_!12 IF(I.NE.1) GO TO 2_^1C_#JUMP IF TERMINATOR NOT (._^1_!42 CONTINUE_^1_!25 IF(JTERM.NE.41) GO TO 2_^1_!19 CALL GETF_^1C_#JUMP IF FIELD INTEGER CONSTANT._^1C_]_^1_$IF(JMODE.EQ.3.AND.JSYM(1).GE.0) GO TO 15_^1 149 CALL DIAG($2C)_^1_$GO TO 5_^1C_]_^1C_#JUMP IF BYTE OR SIGNED BYTE STATEMENT._^1_!15 IF(IFLG1.GT.1.OR.IFLG1.EQ.1.AND.JTERM.EQ.40)_^1_#1GO TO 16_^1C_]_^1C_#JUMP€€ IF SUBSCRIPT ZERO._^1C_]_^1_$IF(JSYM(1).EQ.0) GO TO 149_^1C_]_^1C_#JUMP IF NOT FOURTH OR MORE INDEX._^1C_]_^1_$IF(I.LT.4) GO TO 17_^1_$CALL DIAG($2D)_^1_$GO TO 18_^1C_]_^1C_#STORE SUBSCRIPT IN EQUIVALENCE TABLE._^1_!17 JTEMP=LEQVX+I_^1_$KEQV(JTEMP-4)=JSYM(1)_^1_$I=I+1_^1C_]_^1C_#IF TERMINATOR COMMA, JUMP TO PICK UP NEXT INDEX._^1_!18 IF(JTERM.EQ.43) GO TO 19_^1C_]_^1C_#IF END OF €€SUBSCRIPT, JUMP TO PICK UP NEXT ELEMEN IN CHAIN._^1C_]_^1_!40 IF(JTERM.NE.42) GO TO 2_^1C_]_^1C_#SET UP THE PROCESSING OF THE NEXT ELEMENT._^1C_]_^1_!55 CALL GETF_^1C_]_^1C_#JUMP IF FIELD NUL, OTHERWISE ERROR._^1C_]_^1_$IF(JMODE.NE.0) GO TO 2_^1C_]_^1C_#JUMP IF NOT SECOND VARIABLE IN BYTE STATEMENT._^1C_]_^1_$IF(IFLG1.EQ.0) GO TO 20_^1_$IF(IFLG1.EQ.1) GO TO 42_^1C_]_^1C_#JUMP IF TE€€RMINATOR NOT )._^1C_]_^1_$IF(JTERM.NE.42) GO TO 2_^1_$GO TO 51_^1C_#BYTE STATEMENT PROCESSING. JUMP IF INTEGER IN RANGE FOR BYTE._^1C_]_^1_!16 IF(JSYM(1).LE.IHOBIT) GO TO 21_^1_$IERRFG=1_^1_$CALL DIAG($29)_^1C_]_^1C_#SAVE BYTE LIMIT._^1C_]_^1_!21 ITEMP(IFLG1+1)=JSYM(1)_^1_$IFLG1=IFLG1+1_^1C_]_^1C_#JUMP IF TERMINATOR IS NOT EQUAL SIGN._^1_$IF(JTERM.NE.40) GO TO 22_^1C_#JUMP IF THIS€€ IS LEFT-MOST BIT._^1_$IF(IFLG1.EQ.2) GO TO 19_^1_$GO TO 2_^1C_#JUMP IF NOT RIGHT-MOST BIT. ERROR._^1_!22 IF(IFLG1.NE.3) GO TO 2_^1C_#JUMP IF NO ERROR WAS ENCOUNTERED IN STATEMENT._^1_$IF(IERRFG.EQ.0) GO TO 23_^1_$ITEMP(2)=15_^1_$ITEMP(3)=0_^1_$GO TO 50_^1C_#JUMP IF LEFT-MOST BI T NOT GREATER THAN RIGHTMOST._^1_!23 IF(ITEMP(2).GE.ITEMP(3)) GO TO 50_^1_$CALL DIAG($2A)_^1_$GO TO 5_^1€€C_#JUMP IF TERMINATOR NOT ). ERROR._^1_!50 IF(JTERM .NE.42) GO TO 2_^1C_]_^1C_#FIND BYTE ENTRY IN SYMBOL TABLE._^1C_]_^1_$ISYMX=KEQV(LEQVX-8)_^1_$CALL GETSYM_^1C_#STORE BYTE INFORMATION INTO SYMBOL TABLE ENTRY._^1C_]_^1_$IPARTL(ISYMX)=ITEMP(2)_^1_$IPARTR(ISYMX)=ITEMP(3)_^1_$IPART(ISYMX)=IBUF2(3)-7_^1_$I=2_]_^1_$GO TO 40_^1C_]_^1C_#IS THIS NAME OF NON-BYTE(SECOND NAME). JUMP IF SO._€€^1C_]_^1_!11 IF(IFLG1.EQ.1) GO TO 25_^1C_]_^1C_#JUMP IF NAME IS A POSSIBLE INTEGER BUT NOT A DUMMY ARGUMENT._^1C_]_^1_$IF(ITYPE(ISYMX).LE.1.AND.IDUM(ISYMX).EQ.0) GO TO 27_^1_$CALL DIAG($27)_^1_$GO TO 5_^1C_]_^1C_#JUMP IF NAME DECLARED INTEGER OR NOT DECLARED BUT IMPLICIT._^1C_]_^1_!27 IF(ITYPE(ISYMX).NE.1.AND.JESWT.NE.1) CALL DIAG($2040)_^1C_]_^1C_#SET TYPE AS INTEGER_^1C_]_^1_$ITY€PE(ISYMX)=1_^1C_]_^1C_#JUMP IF NAME NOT PREVIOUSLY SPECIFIED AS BYTE._^1C_]_^1_$IF(IPART(ISYMX).EQ.0)GO TO 29_^1_$CALL DIAG($28)_^1_$GO TO 5_^1C_]_^1C_#JUMP TO PROCESS NEXT NAME IF TERMINATOR COMMA._^1C_]_^1_!29 IFLG1=1_^1_$IF(JTERM.EQ.43) GO TO 30_^1_$GO TO 2_^1_$END_]_^__PWCKF CSY/ 20A P€1_$SUBROUTINE CHECKF_^1_#*_2/DECK-ID 20A FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^13_]_^1C CHECKF IS USED IN PHASES A2,A3_^1C_]_^1C_#MASTER LABELED COMMON BLOCK._^1*_] FTN 3.3_^1_$COMMON /A/ IFLAGS,LINECT,LINCT1_^1_$COMMON /A/ IR,IK,IP,IA,IL,IM,IXL€€GO,IOPTO,IOPTV,IOPTC,IOPTD_^1_$COMMON /A/ MCSTRT,MACRNB,MACSEC_^1_$COMMON /A/ IERRS(16),ISRFAD_^1_$COMMON /A/ LGO,ISCRI,ISCRO,IX_^1*_] FTN 3.3_^1_$COMMON /A/ IGLAB(3),IGLAB1,IGLAB2_^1_$COMMON /A/ ICOMT(12),ICOMTS,ICOMX2,ICOMTL,ISUBP,NDPRS,_^1_#$LABX,IBCDTB(48)_^1_$EQUIVALENCE(ICOMB,ICOMT(1)),(ICOMBX,ICOMT(2)),(ICOMDF,_^1_#$ICOMT(3)),(ICOMBN,ICOMT(4))_^1_$DIMENSION ICOMB(6),ICOMBX(€€6),ICOMDF(6),ICOMBN(7)_^1_$COMMON /A/ LOOPTS,LOOPTX,LOOPTB,LOOPT(50)_^1_$EQUIVALENCE(LINDUC,LOOPT(1))_^1_$DIMENSION LINDUC(10)_^1_$EQUIVALENCE (LBEG,LOOPT(2))_^1_$DIMENSION LBEG(10)_^1_$EQUIVALENCE (LINC,LOOPT(3))_^1_$DIMENSION LINC(10)_^1_$EQUIVALENCE (LEND,LOOPT(4))_^1_$DIMENSION LEND(10)_^1_$BYTE(LLABL,LOOPT(5)(14=0)_))_^1_$DIMENSION LLABL(10)_^1_$BYTE(LID,LOOPT(5)(15=15) )_^1€€_$DIMENSION LID(10)_^1_$COMMON/A/IEQV(255), IEQVS,IEQVN2_^1_$COMMON /A/ ISTAB(150),ISTABS,ISTAB2_^1_$COMMON /A/ IBUFS,ISET(25),LBLANK,KSFCNT,KSNCNT,ISORSC,_^1_#$IHOBIT,ISTNO,ISSFLG,ISUBPN,ITERM,JSORSC,KEQVS_^1C_#SYMBOL TABLE LABELED COMMON BLOCK_^1_$COMMON /A/ ISYMN, ISYMFL,ISYMD,ISYMX,ISYMS,ISYMP,ISYMPC,ISYMPS,_^1_#$ ISYMNS, SYMTAB(960)_^1_$INTEGER SYMTAB_^1_$BYTE (IDUM,SYMTAB(1)(€€15=15)),(KDUMY,SYMTAB(1)(15=15)),_^1_#$(ICLASS,SYMTAB(1)(14=11)),(ITYPE,SYMTAB(1)(10=9))_^1_$DIMENSION IDUM(100),KDUMY(100),ICLASS(100),ITYPE(100)_^1_$BYTE (ISNGL, SYMTAB(1)(8=8)),(KELSIZ,SYMTAB(1)(8=8)),_^1_#$ (ICOM,SYMTAB(1)(7=5)),(IPART,SYMTAB(1)(4=3))_^1_$DIMENSION ISNGL(100),KELSIZ(100),ICOM(100),IPART(100)_^1_$BYTE (KRFCNT,SYMTAB(1)(2=2)),(IDIM,SYMTAB(1)(1=0)),_^1_#$ (IREL,SY€€MTAB(1)(1=1)),(IEXT,SYMTAB(1)(0=0))_^1_$DIMENSION KRFCNT(100),IDIM(100),IREL(100),IEXT(100)_^1_$EQUIVALENCE (IRSA,SYMTAB(2)),(ICOMTX,SYMTAB(2)),(ISNOL,SYMTAB(2))_^1_$DIMENSION IRSA(100), ICOMTX(100),ISNOL(100)_^1_$BYTE (IDATAS,SYMTAB(3)(15=15)),(IREF,SYMTAB(3)(15=15)),_^1_#$ (IEQVX,SYMTAB(3)(14=8)),(ITILF,SYMTAB(3)(14=8))_^1_$DIMENSION IDATAS(100),IREF(100),IEQVX(100),ITILF(100)_^1€€_$BYTE (IPARTR,SYMTAB(3)(7=4)),(INDUCV,SYMTAB(3)(7=7)),(ISFARG,_^1_#$ SYMTAB(3)(6=6)),(IARGNO,SYMTAB(3)(5=0)),(IPARTL,SYMTAB(3)(3=0))_^1_$DIMENSION IPARTR(100),INDUCV(100),ISFARG(100),IARGNO(100),_^1_#$ IPARTL(100)_^1_$EQUIVALENCE (ISYM,SYMTAB(4))_^1_$DIMENSION ISYM(100)_^1C_]_^1C_#SPECIFICATION-TABLE INDEX LABELLED COMMON BLOCK_^1_$COMMON /A/ ISTABX(96)_^1C_]_^1C_#PHASE A BLANK CO€€MMON BLOCK._^1_$COMMON // JSYM(3),JTERM,JMODE,JERR,JESWT,JFLOT,JCHAR,_^1_#$JOCHAR,JO1,JE,JE1,JBLANK,JCT,JCT1_^1C_#JSYM-JCT1 MUST REMAIN IN ORDER_^1_$COMMON//IERR_^1_$COMMON//ISORS(208),ISORSX_^1_$COMMON//IDEFF,ISTOP,IRET,ISPEC,NERR,OCT_^1_$INTEGER OCT_^1_$COMMON//ILLABL,LEST,ISNGL1,ICOMX1,NXTYPE,LOGIF,IOVFL1,IOVFL2_^1_$COMMON//IVCFLG,ISFLG,LOGEX,KEQVX_^1_$COMMON//IBUF2X,IBUF2(304)_€€^1C_$TEMPORARY ARITHMETIC BUFFERS_^1_$COMMON//IBUF1( 304),IBUF1X,IWORK (304)_^1C_#TEMPORARY EQUIVALENCE BUFFERS_^1_$DIMENSION KEQV(460),MEQV(255)_^1_$EQUIVALENCE (KEQV,IBUF1(66)),(MEQV,IBUF2(100))_^1C_#LS1-ITEM MUST REMAIN IN ORDER_^1_$COMMON//LS1,LPREN,LRELRQ,LRELEN,LSWITC,LO,ITEM_^1_$COMMON//MODE_^1_$COMMON//IPHAT(4),IGNSTT(49),IOSPRT(17)_^1C_]_^1C_]_^1C_#CHECK FORMAT STATEMENT_^€€1_$JTERM=0_^1_$LPREN=0_^1_$JE=0_]_^1_$JSYM(2)=0_^1_!10 JSYM(3)=JTERM_^1_$CALL FORK(JESWT,JTERM,JSYM(1),JE1,JERR)_^1_$IF(JSYM(2).NE.0) GO TO 11_^1_$JSYM(2)=1_^1_$IF(JESWT.EQ.1.AND.JTERM.EQ.1)GO TO 6_^1_$CALL DIAG(8)_^1C_+NL X H A R $ I F E ER_^1_!11 GO TO (1,10,2,3,3,3,3,3,3,4),JESWT_^1C_#ERROR_^1_"4 CALL DIAG(8)_^1C_#LOOK AT TERMINATOR_^1_"1 JTERM=JTERM+2_^1_$GO TO(5,10,6,7,10,10)€€,JTERM_^1C_#(_]_^1_"6 LPREN= LPREN+1_^1_$IF(LPREN.GT.2)CALL DIAG(8)_^1_$GO TO 10_^1C_#)_]_^1_"7 LPREN=LPREN-1_^1_$JO1=JE_^1C_#PARENTHESES COUNT SHOULD NEVER BE LESS THAN ZERO_^1_$IF(LPREN.LT.0)CALL DIAG(16)_^1_$GO TO 10_^1C_#H_]_^1_"2 IF(JSYM(1).EQ.0) CALL DIAG(8)_^1_!20 IF(JSYM(1).EQ.0) GO TO 10_^1_$JBLANK=1_^1C ********************************** FTN 3.0 *************************€€*_^1C ********************************** FTN 3.0 **************************_^1_$JAST = 1_^1_$CALL FGETC(JESWT,JAST)_^1C ********************************** FTN 3.0 **************************_^1C ********************************** FTN 3.0 **************************_^1_$JSYM(1)=JSYM(1)-1_^1_$JBLANK=0_^1_$IF(JCHAR.NE.47) GO TO 20_^1_$CALL DIAG(8)_^1_$RETURN_^1C_#A,R,$,I,F,E_^1C_#E€6RROR IF W=0 OR IF F,E AND W LT D_^1_"3 IF (JE1.EQ.0 .OR. (JESWT.GE.8.AND.JE1.LT.JERR)) GO TO 4_^1_$GO TO 1_^1C_#EOS_]_^1_"5 IF(LPREN.EQ.0) GO TO 50_^1_$CALL DIAG(4112)_^1_$RETURN_^1_!50 IF(JESWT.NE.1.OR.JSYM(3).NE.4)CALL DIAG(4104_")_^1C_#SET NUMBER OF WORDS IN RECORD_^1_$IBUF2(1)=5+((JO1+1)/2)_^1_$END_]_^__6PWFGETC CSY/ 21A P€1_$SUBROUTINE FGETC(I,IAST)_^1_#*_2/DECK-ID 21A FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^13_]_^1C FGETC IS USED IN PHASES A2,A3_^1C_]_^1C_#MASTER LABELED COMMON BLOCK._^1*_] FTN 3.3_^1_$COMMON /A/ IFLAGS,LINECT,LINCT1_^1_$COMMON /A/ IR,IK,IP,IA,IL,€€IM,IXLGO,IOPTO,IOPTV,IOPTC,IOPTD_^1_$COMMON /A/ MCSTRT,MACRNB,MACSEC_^1_$COMMON /A/ IERRS(16),ISRFAD_^1_$COMMON /A/ LGO,ISCRI,ISCRO,IX_^1*_] FTN 3.3_^1_$COMMON /A/ IGLAB(3),IGLAB1,IGLAB2_^1_$COMMON /A/ ICOMT(12),ICOMTS,ICOMX2,ICOMTL,ISUBP,NDPRS,_^1_#$LABX,IBCDTB(48)_^1_$EQUIVALENCE(ICOMB,ICOMT(1)),(ICOMBX,ICOMT(2)),(ICOMDF,_^1_#$ICOMT(3)),(ICOMBN,ICOMT(4))_^1_$DIMENSION ICOMB(6),I€€COMBX(6),ICOMDF(6),ICOMBN(7)_^1_$COMMON /A/ LOOPTS,LOOPTX,LOOPTB,LOOPT(50)_^1_$EQUIVALENCE(LINDUC,LOOPT(1))_^1_$DIMENSION LINDUC(10)_^1_$EQUIVALENCE (LBEG,LOOPT(2))_^1_$DIMENSION LBEG(10)_^1_$EQUIVALENCE (LINC,LOOPT(3))_^1_$DIMENSION LINC(10)_^1_$EQUIVALENCE (LEND,LOOPT(4))_^1_$DIMENSION LEND(10)_^1_$BYTE(LLABL,LOOPT(5)(14=0)_))_^1_$DIMENSION LLABL(10)_^1_$BYTE(LID,LOOPT(5)(15=15)€€ )_^1_$DIMENSION LID(10)_^1_$COMMON/A/IEQV(255), IEQVS,IEQVN2_^1_$COMMON /A/ ISTAB(150),ISTABS,ISTAB2_^1_$COMMON /A/ IBUFS,ISET(25),LBLANK,KSFCNT,KSNCNT,ISORSC,_^1_#$IHOBIT,ISTNO,ISSFLG,ISUBPN,ITERM,JSORSC,KEQVS_^1C_#SYMBOL TABLE LABELED COMMON BLOCK_^1_$COMMON /A/ ISYMN, ISYMFL,ISYMD,ISYMX,ISYMS,ISYMP,ISYMPC,ISYMPS,_^1_#$ ISYMNS, SYMTAB(960)_^1_$INTEGER SYMTAB_^1_$BYTE (IDUM,SYMT€€AB(1)(15=15)),(KDUMY,SYMTAB(1)(15=15)),_^1_#$(ICLASS,SYMTAB(1)(14=11)),(ITYPE,SYMTAB(1)(10=9))_^1_$DIMENSION IDUM(100),KDUMY(100),ICLASS(100),ITYPE(100)_^1_$BYTE (ISNGL, SYMTAB(1)(8=8)),(KELSIZ,SYMTAB(1)(8=8)),_^1_#$ (ICOM,SYMTAB(1)(7=5)),(IPART,SYMTAB(1)(4=3))_^1_$DIMENSION ISNGL(100),KELSIZ(100),ICOM(100),IPART(100)_^1_$BYTE (KRFCNT,SYMTAB(1)(2=2)),(IDIM,SYMTAB(1)(1=0)),_^1_#$ (I€€REL,SYMTAB(1)(1=1)),(IEXT,SYMTAB(1)(0=0))_^1_$DIMENSION KRFCNT(100),IDIM(100),IREL(100),IEXT(100)_^1_$EQUIVALENCE (IRSA,SYMTAB(2)),(ICOMTX,SYMTAB(2)),(ISNOL,SYMTAB(2))_^1_$DIMENSION IRSA(100), ICOMTX(100),ISNOL(100)_^1_$BYTE (IDATAS,SYMTAB(3)(15=15)),(IREF,SYMTAB(3)(15=15)),_^1_#$ (IEQVX,SYMTAB(3)(14=8)),(ITILF,SYMTAB(3)(14=8))_^1_$DIMENSION IDATAS(100),IREF(100),IEQVX(100),ITILF(1€€00)_^1_$BYTE (IPARTR,SYMTAB(3)(7=4)),(INDUCV,SYMTAB(3)(7=7)),(ISFARG,_^1_#$ SYMTAB(3)(6=6)),(IARGNO,SYMTAB(3)(5=0)),(IPARTL,SYMTAB(3)(3=0))_^1_$DIMENSION IPARTR(100),INDUCV(100),ISFARG(100),IARGNO(100),_^1_#$ IPARTL(100)_^1_$EQUIVALENCE (ISYM,SYMTAB(4))_^1_$DIMENSION ISYM(100)_^1C_]_^1C_#SPECIFICATION-TABLE INDEX LABELLED COMMON BLOCK_^1_$COMMON /A/ ISTABX(96)_^1C_]_^1C_#PHASE A BL€€ANK COMMON BLOCK._^1_$COMMON // JSYM(3),JTERM,JMODE,JERR,JESWT,JFLOT,JCHAR,_^1_#$JOCHAR,JO1,JE,JE1,JBLANK,JCT,JCT1_^1C_#JSYM-JCT1 MUST REMAIN IN ORDER_^1_$COMMON//IERR_^1_$COMMON//ISORS(208),ISORSX_^1_$COMMON//IDEFF,ISTOP,IRET,ISPEC,NERR,OCT_^1_$INTEGER OCT_^1_$COMMON//ILLABL,LEST,ISNGL1,ICOMX1,NXTYPE,LOGIF,IOVFL1,IOVFL2_^1_$COMMON//IVCFLG,ISFLG,LOGEX,KEQVX_^1_$COMMON//IBUF2X,IBUF2€€(304)_^1C_$TEMPORARY ARITHMETIC BUFFERS_^1_$COMMON//IBUF1( 304),IBUF1X,IWORK (304)_^1C_#TEMPORARY EQUIVALENCE BUFFERS_^1_$DIMENSION KEQV(460),MEQV(255)_^1_$EQUIVALENCE (KEQV,IBUF1(66)),(MEQV,IBUF2(100))_^1C_#LS1-ITEM MUST REMAIN IN ORDER_^1_$COMMON//LS1,LPREN,LRELRQ,LRELEN,LSWITC,LO,ITEM_^1_$COMMON//MODE_^1_$COMMON//IPHAT(4),IGNSTT(49),IOSPRT(17)_^1C_]_^1C_]_^1C *******************€€*************** FTN 3.0 **************************_^1_$DIMENSION NUMBUF(7)_^1C_3ASCII_!$48 = H_^1_$DATA NUMBUF(7)/$48/_^1C ********************************** FTN 3.0 **************************_^1C_8BEGIN_4***** FTN 3.1 *****_^1_$INTEGER ASCII(48)_^1_$EQUIVALENCE (ASCII(1),IBCDTB(1))_^1C_#********BEGIN********** FTN 3.2 *********************************_^1C_#EXTENDED ASCII CHARACT€€ER TABLE_^1_$INTEGER ASCIIX(17)_^1C_#DATA ASCIIX/ '_!!_!"_!#_!%_!%_!:_!;_!<_!>_!?_!@_![_^1_$DATA ASCIIX/$27,$21,$22,$23,$25,$26,$3A,$3B,$3C,$3E,$3F,$40,$5B_^1_#1,$5C,$5D,$5E,$5F/_^1C_"1, \_!]_!^_!_ /_^1C_#*********************** FTN 3.2 ******END************************_^1C_8END_6***** FTN 3.1 *****_^1C ********************************** FTN 3.0 **************************_^1_"1 J€€E = JE + 1_^1C_8BEGIN_4***** FTN 3.1 *****_^1_$IQUOTE = 0_^1C_8END_6***** FTN 3.1 *****_^1C ********************************** FTN 3.0 **************************_^1_$CALL GETC_^1C_8BEGIN_4***** FTN 3.1 *****_^1_$IF (JCHAR .EQ. 48) IQUOTE = 1_^1C_8END_6***** FTN 3.1 *****_^1C ********************************** FTN 3.0 **************************_^1C CHECK FOR ASTERISK_^1C_8BEGIN_4€€***** FTN 3.1 *****_^1_$IF (IAST.NE.0.OR.JCHAR.NE.45.AND.IQUOTE.EQ.0) GO TO 9_^1C_8END_6***** FTN 3.1 *****_^1_$JE =JE - 1_^1_$JBLANK = 1_^1_$ITEMP = ISORSX_^1_$DO 2 INUM=1,208_^1_$CALL GETC_^1_$IF(JCHAR.NE.47) GO TO 3_^1_$CALL DIAG($105C)_^1_$I = -1_^1_$RETURN_^1C_8BEGIN_4***** FTN 3.1 *****_^1_"3 IF(JCHAR.EQ.45.AND.IQUOTE.EQ.0) GO TO 4_^1_$IF(JCHAR.EQ.48.AND.IQUOTE.EQ.1) GO TO 4_€€^1C_8END_6***** FTN 3.1 *****_^1_"2 CONTINUE_^1_"4 ISORSX=ITEMP_^1_$INUM = INUM -1_^1_$IF(INUM.NE.0) GO TO 5_^1_$CALL DIAG(8)_^1_$GO TO 8_^1_"5 CALL CONV(INUM,NUMBUF(1))_^1_$DO 6 J=1,7_^1_$IF(NUMBUF(J).EQ.$20) GO TO 6_^1_$JE = JE + 1_^1_$CALL STCHAR(IBUF2(6),JE,NUMBUF(J))_^1_"6 CONTINUE_^1_$DO 7 IKKX=1,INUM_^1_$JE = JE +1_^1_$CALL GETC_^1C_8BEGIN_4***** FTN 3.1 *****_^1_$I = ASCII(€€JCHAR+1)_^1C_#CHECK TO SEE IF CHARACTER IS IN EXTENDED SET_^1_$IF (JCHAR.GT.47) I= ASCIIX(JCHAR-47)_^1C_8END_6***** FTN 3.1 *****_^1_$CALL STCHAR(IBUF2(6),JE,I)_^1_"7 CONTINUE_^1_"8 ISORSX = ISORSX + 1_^1_$JBLANK = 0_^1_$GO TO 1_^1C_8BEGIN_4***** FTN 3.1 *****_^1_"9 I = ASCII(JCHAR+1)_^1_$IF (JCHAR.GT.47) I= ASCIIX(JCHAR-47)_^1C_8END_6***** FTN 3.1 *****_^1C ***********************€€*********** FTN 3.0 **************************_^1C ********************************** FTN 3.0 **************************_^1_$CALL STCHAR(IBUF2(6),JE,I)_^1_$IF(JCHAR.EQ.47)I=-1_^1C_8BEGIN_4***** FTN 3.1 *****_^1C_(SCAN FOR D FORMAT SAME AS E_^1_$IF(JCHAR.EQ.13)I=$45_^1C_8END_6***** FTN 3.1 *****_^1C_#********BEGIN********** FTN 3.2 *********************************_^1C_(SCAN FOR Z€Œ FORMAT SAME AS FOR $ FORMAT_^1_$IF (JCHAR.EQ.35) I=$24_^1C_#*********************** FTN 3.2 ******END************************_^1_$END_]_^__ŒPWFORK CSY/ 22A P€1_$SUBROUTINE FORK(I1,I2,I3,I4,I5)_^1_#*_2/DECK-ID 22A FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^13_]_^1C FORK IS USED IN PHASES A2,A3_^1C_]_^1C_]_^1C_#ROUTINE TO SYNTAX CHECK FORMAT STATEMENT_^1C_]_^1C_#INPUT PARAMETERS ARE HOLDERS IN WHICH OUTPUT I€€NFORMATION IS GIVEN_^1C_]_^1C_#I1 - FIELD TYPE_!1=NULL_^1C_72 X_^1C_73 H_^1C_74 A_^1C_75 R_^1C_76 $ OR Z_^1C_77 I_^1C_78 F_^1C_79 E OR D_^1C_610 ERROR_^1C_#I2 - TERMINATOR_"0=NONE (H AND X FIELDS)_^1C_71 (_^1C_72 )_^1C_73 ,_^1C_74 /_^1C_6-1 EOS_^1C_#I3 REPEAT COUNT_^1C_#I4 W_!F,E ONLY_^1C_#I5 D_!F,E ONLY_^1_$DIMENSION MTERM(13)_^1_$DATA IZERO/$30/_^1_$DATA MTERM(1),MTERM(2)€€,MTERM(3),MTERM(4)/$41,$45,$46,$48/_^1_$DATA MTERM(5),MTERM(6),MTERM(7),MTERM(8)/$49,$2E,$29,$52/_^1_$DATA MTERM(9),MTERM(10),MTERM(11),MTERM(12)/$24,$2F,$58,$2C/_^1_$DATA MTERM(13)/$28/_^1C_#SET INITIAL MODE_^1_$I1=1_]_^1C_#CLEAR HOLDERS_^1_$I2=0_]_^1_$I3=0_]_^1_$I4=0_]_^1_$I5=0_]_^1C_#DECIMAL AT. ENCOUNTERED SWITCH_^1_$IDEC=0_^1_$IAUX=0_^1C ********************************** FTN €€ 3.0 **************************_^1C ********************************** FTN 3.0 **************************_^1_$IAST = 0_^1_"1 CALL FGETC(ICF,IAST)_^1_$IAST = 1_^1_$IF(ICF.EQ.$28.OR.ICF.EQ.$29.OR.ICF.EQ.$2C.OR.ICF.EQ.$2F) IAST = 0_^1C_/(_,)_+,_-/_^1C ********************************** FTN 3.0 **************************_^1_$I = 15_^1C_#EOS_]_^1_$IF (ICF .EQ. -1 ) GO TO (20,160,220,2€€30,230), I1_^1C_]_^1_$IF(ICF.LT.IZERO.OR.ICF.GE.IZERO+10) GO TO 2_^1C_#0-9_]_^1C ********************************** FTN 3.0 **************************_^1_$GO TO (10,150,200,200,1),I1_^1C ********************************** FTN 3.0 **************************_^1_"2 DO 4 I=1,13_^1_$IF ( ICF .EQ. MTERM(I) ) GO TO (15,15,35,45,45 ), I1_^1_"4 CONTINUE_^1_$GO TO 120_^1C_#INITIAL MODE,REP€€EAT MODE_^1C_#)_]_^1_!15 IF(I.EQ.7) GO TO(140,180),I1_^1C_#/_]_^1_$IF(I.EQ.10) GO TO(20,160),I1_^1C_#,_]_^1_$IF(I.EQ.12) GO TO(1,190),I1_^1C_,A E F_"H I ._!) R $ / X , (_^1_$GO TO (50,40,30,100,80,120,1,60,70,1,90,1,129),I_^1_!35 J=I-5_^1_$IF(J.LT.1)GO TO 120_^1C_+._")_)/_%,_"(_^1_$GO TO (260,270,120,120,220,120,270,270),J_^1C_#AR$I MODE + ERROR MODE_^1 45_!J = I - 6_^1C ****€€****************************** FTN 3.0 **************************_^1_$IF(I1+IAUX.EQ.7.AND.J.EQ.0) GO TO 260_^1C ********************************** FTN 3.0 **************************_^1_$IF (J .LE.0 ) GO TO 120_^1C_-)_!R_!$ /_!X_!, (_^1_$GO TO (140,120,120,230,120,210,130), J_^1C_]_^1C_#0-9 INITIAL MODE_^1_!10 I3=ICF-IZERO_^1C_#SET REPEAT MODE_^1_$I1=2_]_^1_$GO TO 1_^1C_#/ OR E€€OS IN F,E MODE_^1 220 IF(IDEC.NE.0)GO TO 230_^1 160 I1=10_^1C_#/ OR EOS IN INITIAL MODE_^1 20_!I2 = 14 - I_^1_$RETURN_^1C_]_^1C_#F IN INITIAL MODE_^1_!30 IAUX=5_^1C_#SET F,E MODE_^1 301 I1=3_]_^1_$GO TO 1_^1C_#E IN INITIAL,REPEAT MODES_^1_!40 IAUX=6_^1_$GO TO 301_^1C_]_^1C_#I IN INITIAL,REPEAT MODES_^1_!80 IAUX=1_^1C_#$ IN INITIAL,REPEAT MODES_^1_!70 IAUX=IAUX+1_^1C_#R IN INITIA€€L,REPEAT MODES_^1_!60 IAUX=IAUX+1_^1C_#A IN INITIAL,REPEAT MODES_^1_!50 I1=4_]_^1_$GO TO 1_^1C_#H IN INITIAL,REPEAT MODES_^1 100 I1=3_]_^1_$RETURN_^1C_]_^1C_#ERROR_^1 120 I1=5_]_^1_$IAUX=5_^1_$GO TO 1_^1C_]_^1C_#( IN INITIAL,REPEAT_^1 129 I1=1_]_^1C_#( IN ALL_^1 130 I2=1_]_^1 199 I1=I1+IAUX_^1_$RETURN_^1C_]_^1C_#) IN REPEAT MODE,ERROR_^1 180 I1=10_^1C_#) IN ALL_^1 140 I2=2_€€]_^1_$GO TO 199_^1C_]_^1C_#, IN REPEAT,ERROR_^1 190 I1=10_^1C_#, ALL OTHERS EXCEPT INITIAL_^1 210 I2=3_]_^1_$GO TO 199_^1C_]_^1C_#0-9 IN REPEAT MODE_^1 150 I=10*I3+(ICF-IZERO)_^1_$IF(I.LT.I3) GO TO 120_^1_$I3=I_]_^1_$GO TO 1_^1C_]_^1C_#0-9 IN FE MODE_^1 200 IF(IDEC.EQ.0) GO TO 240_^1 201 ASSEM $01B1, $0B00_^1_$I5=10*I5+(ICF-IZERO)_^1C_#BRANCH ON OVERFLOW TO 120_^1_$ASSEM $01B2€€, $1800, 120_^1_$GO TO 1_^1 240 ASSEM $01B1, $0B00_^1_$I4=10*I4+(ICF-IZERO)_^1C_#BRANCH ON OVERFLOW TO 120_^1_$ASSEM $01B2, $1800, 120_^1_$GO TO 1_^1C_]_^1C_#/ OR EOS IN AR$I + ERROR_^1 230 I1=I1+IAUX_^1_$GO TO 20_^1C_]_^1C_#. IN F,E_^1 260 IF(IDEC.NE.0) GO TO 120_^1_$IDEC=1_^1C ********************************** FTN 3.0 **************************_^1 261 IAST = 1_^1_$CALL FGET€€C(ICF,IAST)_^1C ********************************** FTN 3.0 **************************_^1C ********************************** FTN 3.0 **************************_^1_$IF(ICF.LT.IZERO+10.AND.ICF.GE.IZERO) GO TO 201_^1_$I1=5_]_^1_$IAUX=5_^1_$GO TO 2_^1C_]_^1C_#),( IN FE MODE_^1 270 IF(IDEC.EQ.0) IAUX=7_^1_$IF(J-7)140,210,130_^1C_#X IN INITIAL,REPEAT MODES_^1_!90 I1=2_]_^1_$END_]_^__ €PWSUB CSY/ 23A P€1_$SUBROUTINE SUBPPR_^1_#*_2/DECK-ID 23A FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^13_]_^1C SUBPPR IS USED IN PHASE A2_^1C_#MASTER LABELED COMMON BLOCK._^1*_] FTN 3.3_^1_$COMMON /A/ IFLAGS,LINECT,LINCT1_^1_$COMMON /A/ IR,IK,IP,IA,IL,IM,IXLGO,IOPTO,I€€OPTV,IOPTC,IOPTD_^1_$COMMON /A/ MCSTRT,MACRNB,MACSEC_^1_$COMMON /A/ IERRS(16),ISRFAD_^1_$COMMON /A/ LGO,ISCRI,ISCRO,IX_^1*_] FTN 3.3_^1_$COMMON /A/ IGLAB(3),IGLAB1,IGLAB2_^1_$COMMON /A/ ICOMT(12),ICOMTS,ICOMX2,ICOMTL,ISUBP,NDPRS,_^1_#$LABX,IBCDTB(48)_^1_$EQUIVALENCE(ICOMB,ICOMT(1)),(ICOMBX,ICOMT(2)),(ICOMDF,_^1_#$ICOMT(3)),(ICOMBN,ICOMT(4))_^1_$DIMENSION ICOMB(6),ICOMBX(6),ICOMDF(€€6),ICOMBN(7)_^1_$COMMON /A/ LOOPTS,LOOPTX,LOOPTB,LOOPT(50)_^1_$EQUIVALENCE(LINDUC,LOOPT(1))_^1_$DIMENSION LINDUC(10)_^1_$EQUIVALENCE (LBEG,LOOPT(2))_^1_$DIMENSION LBEG(10)_^1_$EQUIVALENCE (LINC,LOOPT(3))_^1_$DIMENSION LINC(10)_^1_$EQUIVALENCE (LEND,LOOPT(4))_^1_$DIMENSION LEND(10)_^1_$BYTE(LLABL,LOOPT(5)(14=0)_))_^1_$DIMENSION LLABL(10)_^1_$BYTE(LID,LOOPT(5)(15=15) )_^1_$DIMENSIO€€N LID(10)_^1_$COMMON/A/IEQV(255), IEQVS,IEQVN2_^1_$COMMON /A/ ISTAB(150),ISTABS,ISTAB2_^1_$COMMON /A/ IBUFS,ISET(25),LBLANK,KSFCNT,KSNCNT,ISORSC,_^1_#$IHOBIT,ISTNO,ISSFLG,ISUBPN,ITERM,JSORSC,KEQVS_^1C_#SYMBOL TABLE LABELED COMMON BLOCK_^1_$COMMON /A/ ISYMN, ISYMFL,ISYMD,ISYMX,ISYMS,ISYMP,ISYMPC,ISYMPS,_^1_#$ ISYMNS, SYMTAB(960)_^1_$INTEGER SYMTAB_^1_$BYTE (IDUM,SYMTAB(1)(15=15)),(K€€DUMY,SYMTAB(1)(15=15)),_^1_#$(ICLASS,SYMTAB(1)(14=11)),(ITYPE,SYMTAB(1)(10=9))_^1_$DIMENSION IDUM(100),KDUMY(100),ICLASS(100),ITYPE(100)_^1_$BYTE (ISNGL, SYMTAB(1)(8=8)),(KELSIZ,SYMTAB(1)(8=8)),_^1_#$ (ICOM,SYMTAB(1)(7=5)),(IPART,SYMTAB(1)(4=3))_^1_$DIMENSION ISNGL(100),KELSIZ(100),ICOM(100),IPART(100)_^1_$BYTE (KRFCNT,SYMTAB(1)(2=2)),(IDIM,SYMTAB(1)(1=0)),_^1_#$ (IREL,SYMTAB(1)(1=€€1)),(IEXT,SYMTAB(1)(0=0))_^1_$DIMENSION KRFCNT(100),IDIM(100),IREL(100),IEXT(100)_^1_$EQUIVALENCE (IRSA,SYMTAB(2)),(ICOMTX,SYMTAB(2)),(ISNOL,SYMTAB(2))_^1_$DIMENSION IRSA(100), ICOMTX(100),ISNOL(100)_^1_$BYTE (IDATAS,SYMTAB(3)(15=15)),(IREF,SYMTAB(3)(15=15)),_^1_#$ (IEQVX,SYMTAB(3)(14=8)),(ITILF,SYMTAB(3)(14=8))_^1_$DIMENSION IDATAS(100),IREF(100),IEQVX(100),ITILF(100)_^1_$BYTE (IP€€ARTR,SYMTAB(3)(7=4)),(INDUCV,SYMTAB(3)(7=7)),(ISFARG,_^1_#$ SYMTAB(3)(6=6)),(IARGNO,SYMTAB(3)(5=0)),(IPARTL,SYMTAB(3)(3=0))_^1_$DIMENSION IPARTR(100),INDUCV(100),ISFARG(100),IARGNO(100),_^1_#$ IPARTL(100)_^1_$EQUIVALENCE (ISYM,SYMTAB(4))_^1_$DIMENSION ISYM(100)_^1C_]_^1C_#SPECIFICATION-TABLE INDEX LABELLED COMMON BLOCK_^1_$COMMON /A/ ISTABX(96)_^1C_]_^1C_#PHASE A BLANK COMMON BLOCK€€._^1_$COMMON // JSYM(3),JTERM,JMODE,JERR,JESWT,JFLOT,JCHAR,_^1_#$JOCHAR,JO1,JE,JE1,JBLANK,JCT,JCT1_^1C_#JSYM-JCT1 MUST REMAIN IN ORDER_^1_$COMMON//IERR_^1_$COMMON//ISORS(208),ISORSX_^1_$COMMON//IDEFF,ISTOP,IRET,ISPEC,NERR,OCT_^1_$INTEGER OCT_^1_$COMMON//ILLABL,LEST,ISNGL1,ICOMX1,NXTYPE,LOGIF,IOVFL1,IOVFL2_^1_$COMMON//IVCFLG,ISFLG,LOGEX,KEQVX_^1_$COMMON//IBUF2X,IBUF2(304)_^1C_$TEMPO€€RARY ARITHMETIC BUFFERS_^1_$COMMON//IBUF1( 304),IBUF1X,IWORK (304)_^1C_#TEMPORARY EQUIVALENCE BUFFERS_^1_$DIMENSION KEQV(460),MEQV(255)_^1_$EQUIVALENCE (KEQV,IBUF1(66)),(MEQV,IBUF2(100))_^1C_#LS1-ITEM MUST REMAIN IN ORDER_^1_$COMMON//LS1,LPREN,LRELRQ,LRELEN,LSWITC,LO,ITEM_^1_$COMMON//MODE_^1_$COMMON//IPHAT(4),IGNSTT(49),IOSPRT(17)_^1C_]_^1C_]_^1C_#PROCESS SUBROUTINE,FUNCTION STATEM€€ENT_^1C_#SET SUBROUTINE OR FUNCTION INDICATOR 3=SUB,2=FUNC_^1_$IOFFLG=0_^1_$ISUBP=IBUF2(3)-12_^1_$CALL GETF_^1C_#SYMBOLIC_^1_$IF(JMODE.EQ.2) GO TO 2_^1C_#NO_]_^1_$CALL DIAG(43)_^1C_#TERMINATOR=(_^1_$IF(JTERM.EQ.41)GO TO 3_^1_$IF(JTERM.NE.47)GO TO 21_^1_$RETURN_^1C_#YES_]_^1_"3 CALL GETF_^1C_#SYMBOLIC_^1_$IF(JMODE.EQ.2) GO TO 30_^1_$CALL DIAG (25)_^1_$GO TO 40_^1_!30 IF (ISYMD.EQ.0€€) GO TO 4_^1C_#NAME IN TABLE-ERROR_^1_$CALL DIAG(81)_^1C_#CHECK PARAMETER TERMINATOR- ,_^1_!40 IF(JTERM.EQ.43) GO TO 3_^1C_#NO-MAYBE )_^1_$IF(JTERM.NE.42) GO TO 21_^1C_#YES-SET NO.WDS_^1C ********************************** FTN 3.0 **************************_^1C ********************************** FTN 3.0 **************************_^1C THIS TIME THROUGH SAVEID THE INFORMATION FOLLO€€WING A / IS WRITTEN_^1C_!ONTO THE LOAD-AND-GO SECTOR_^1_!50 CALL SAVEID_^1C ********************************** FTN 3.0 **************************_^1_!22 IBUF2(1)=IBUF2X-1_^1_$RETURN_^1C_#PUT FUNC-SUB NAME IN SYMTAB_^1_"2 CALL STORE_^1_$ICLASS(ISYMX)=1_^1_$IF(ISUBP.EQ.3) ICLASS(ISYMX)=8_^1_$ITYPE(ISYMX)=IVCFLG_^1_$IF(IVCFLG.EQ.0) ITYPE(ISYMX)=JESWT_^1_$IBUF2(IBUF2X)=ISYMX+ISYMP_^1_€€$IBUF2X=IBUF2X+1_^1_$IF(JTERM.EQ.41) GO TO 3_^1C ********************************** FTN 3.0 **************************_^1_$IF (ISUBP.EQ.3) GO TO 50_^1C ********************************** FTN 3.0 **************************_^1C ********************************** FTN 3.0 **************************_^1_!21 CALL DIAG (25)_^1_$RETURN_^1C_#PUT NAME IN SYMTAB_^1_"4 CALL STORE_^1_$IDUM(IS€øYMX)=1_^1_$IBUF2(IBUF2X)=ISYMX+ISYMP_^1_$IBUF2X=IBUF2X+1_^1C_#CHECK TOO MANY PARAMETERS_^1_$IF(IBUF2X.LE.66)GO TO 40_^1_$IBUF2X=IBUF2X-1_^1_$IF(IOFFLG.NE.0) GO TO 40_^1_$CALL DIAG(82)_^1_$IOFFLG=1_^1_$GO TO 40_^1 1559 CALL DIAG(8293)_^1_$END_]_^__ øPWEXRL CSY/ 24A P€1_$SUBROUTINE EXRLPR_^1_#*_2/DECK-ID 24A FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^13_]_^1C EXRLPR IS USED IN PHASE A2_^1C_#MASTER LABELED COMMON BLOCK._^1*_] FTN 3.3_^1_$COMMON /A/ IFLAGS,LINECT,LINCT1_^1_$COMMON /A/ IR,IK,IP,IA,IL,IM,IXLGO,IOPTO,I€€OPTV,IOPTC,IOPTD_^1_$COMMON /A/ MCSTRT,MACRNB,MACSEC_^1_$COMMON /A/ IERRS(16),ISRFAD_^1_$COMMON /A/ LGO,ISCRI,ISCRO,IX_^1*_] FTN 3.3_^1_$COMMON /A/ IGLAB(3),IGLAB1,IGLAB2_^1_$COMMON /A/ ICOMT(12),ICOMTS,ICOMX2,ICOMTL,ISUBP,NDPRS,_^1_#$LABX,IBCDTB(48)_^1_$EQUIVALENCE(ICOMB,ICOMT(1)),(ICOMBX,ICOMT(2)),(ICOMDF,_^1_#$ICOMT(3)),(ICOMBN,ICOMT(4))_^1_$DIMENSION ICOMB(6),ICOMBX(6),ICOMDF(€€6),ICOMBN(7)_^1_$COMMON /A/ LOOPTS,LOOPTX,LOOPTB,LOOPT(50)_^1_$EQUIVALENCE(LINDUC,LOOPT(1))_^1_$DIMENSION LINDUC(10)_^1_$EQUIVALENCE (LBEG,LOOPT(2))_^1_$DIMENSION LBEG(10)_^1_$EQUIVALENCE (LINC,LOOPT(3))_^1_$DIMENSION LINC(10)_^1_$EQUIVALENCE (LEND,LOOPT(4))_^1_$DIMENSION LEND(10)_^1_$BYTE(LLABL,LOOPT(5)(14=0)_))_^1_$DIMENSION LLABL(10)_^1_$BYTE(LID,LOOPT(5)(15=15) )_^1_$DIMENSIO€€N LID(10)_^1_$COMMON/A/IEQV(255), IEQVS,IEQVN2_^1_$COMMON /A/ ISTAB(150),ISTABS,ISTAB2_^1_$COMMON /A/ IBUFS,ISET(25),LBLANK,KSFCNT,KSNCNT,ISORSC,_^1_#$IHOBIT,ISTNO,ISSFLG,ISUBPN,ITERM,JSORSC,KEQVS_^1C_#SYMBOL TABLE LABELED COMMON BLOCK_^1_$COMMON /A/ ISYMN, ISYMFL,ISYMD,ISYMX,ISYMS,ISYMP,ISYMPC,ISYMPS,_^1_#$ ISYMNS, SYMTAB(960)_^1_$INTEGER SYMTAB_^1_$BYTE (IDUM,SYMTAB(1)(15=15)),(K€€DUMY,SYMTAB(1)(15=15)),_^1_#$(ICLASS,SYMTAB(1)(14=11)),(ITYPE,SYMTAB(1)(10=9))_^1_$DIMENSION IDUM(100),KDUMY(100),ICLASS(100),ITYPE(100)_^1_$BYTE (ISNGL, SYMTAB(1)(8=8)),(KELSIZ,SYMTAB(1)(8=8)),_^1_#$ (ICOM,SYMTAB(1)(7=5)),(IPART,SYMTAB(1)(4=3))_^1_$DIMENSION ISNGL(100),KELSIZ(100),ICOM(100),IPART(100)_^1_$BYTE (KRFCNT,SYMTAB(1)(2=2)),(IDIM,SYMTAB(1)(1=0)),_^1_#$ (IREL,SYMTAB(1)(1=€€1)),(IEXT,SYMTAB(1)(0=0))_^1_$DIMENSION KRFCNT(100),IDIM(100),IREL(100),IEXT(100)_^1_$EQUIVALENCE (IRSA,SYMTAB(2)),(ICOMTX,SYMTAB(2)),(ISNOL,SYMTAB(2))_^1_$DIMENSION IRSA(100), ICOMTX(100),ISNOL(100)_^1_$BYTE (IDATAS,SYMTAB(3)(15=15)),(IREF,SYMTAB(3)(15=15)),_^1_#$ (IEQVX,SYMTAB(3)(14=8)),(ITILF,SYMTAB(3)(14=8))_^1_$DIMENSION IDATAS(100),IREF(100),IEQVX(100),ITILF(100)_^1_$BYTE (IP€€ARTR,SYMTAB(3)(7=4)),(INDUCV,SYMTAB(3)(7=7)),(ISFARG,_^1_#$ SYMTAB(3)(6=6)),(IARGNO,SYMTAB(3)(5=0)),(IPARTL,SYMTAB(3)(3=0))_^1_$DIMENSION IPARTR(100),INDUCV(100),ISFARG(100),IARGNO(100),_^1_#$ IPARTL(100)_^1_$EQUIVALENCE (ISYM,SYMTAB(4))_^1_$DIMENSION ISYM(100)_^1C_]_^1C_#SPECIFICATION-TABLE INDEX LABELLED COMMON BLOCK_^1_$COMMON /A/ ISTABX(96)_^1C_]_^1C_#PHASE A BLANK COMMON BLOCK€€._^1_$COMMON // JSYM(3),JTERM,JMODE,JERR,JESWT,JFLOT,JCHAR,_^1_#$JOCHAR,JO1,JE,JE1,JBLANK,JCT,JCT1_^1C_#JSYM-JCT1 MUST REMAIN IN ORDER_^1_$COMMON//IERR_^1_$COMMON//ISORS(208),ISORSX_^1_$COMMON//IDEFF,ISTOP,IRET,ISPEC,NERR,OCT_^1_$INTEGER OCT_^1_$COMMON//ILLABL,LEST,ISNGL1,ICOMX1,NXTYPE,LOGIF,IOVFL1,IOVFL2_^1_$COMMON//IVCFLG,ISFLG,LOGEX,KEQVX_^1_$COMMON//IBUF2X,IBUF2(304)_^1C_$TEMPO€€RARY ARITHMETIC BUFFERS_^1_$COMMON//IBUF1( 304),IBUF1X,IWORK (304)_^1C_#TEMPORARY EQUIVALENCE BUFFERS_^1_$DIMENSION KEQV(460),MEQV(255)_^1_$EQUIVALENCE (KEQV,IBUF1(66)),(MEQV,IBUF2(100))_^1C_#LS1-ITEM MUST REMAIN IN ORDER_^1_$COMMON//LS1,LPREN,LRELRQ,LRELEN,LSWITC,LO,ITEM_^1_$COMMON//MODE_^1_$COMMON//IPHAT(4),IGNSTT(49),IOSPRT(17)_^1C_]_^1C_]_^1C_#PROCESS EXTERNAL STATEMENT_^1_"1 C€€ALL GETF_^1_$IF(JMODE.EQ.2) GO TO 3_^1C_]_^1C_#RETURN IF NO NAMES IN STATEMENT_^1C_]_^1_$IF(JMODE.EQ.0.AND.JTERM.EQ.47) RETURN_^1_$CALL DIAG (25)_^1_"2 IF(JTERM.NE.43) RETURN_^1_$GO TO 1_^1C_#FIELD IS NAME-IS IT IN SYMTAB_^1_"3 IF(ISYMD.EQ.0) GO TO 4_^1C_#YES-IS IT FUNC,SUB,OR UNASSIGNED_^1_$IF(ICLASS(ISYMX).EQ.0.OR.ICLASS(ISYMX).EQ.5.OR.ICLASS(ISYMX).EQ.6)_^1_#1GO TO 5_^1_$CALL D€ìIAG(43)_^1_$GO TO 2_^1_"4 CALL STORE_^1_"5 IEXT(ISYMX)=1_^1_$IF(IBUF2(3).NE.11) GO TO 6_^1_$IREL(ISYMX)=1_^1C_]_^1C_#PRINT DIAGNOSTIC IF DUMMY ARGUMENT_^1C_]_^1_"6 IF(JTERM.EQ.43) GO TO 1_^1_$IF(JTERM.NE.47) CALL DIAG(25)_^1_$END_]_^__ ìPWPEQVS CSY/ 25A P€1_$SUBROUTINE PEQVS_^1_#*_2/DECK-ID 25A FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^13_]_^1C PEQVS IS USED IN PHASE A2_^1C_]_^1C_#MASTER LABELED COMMON BLOCK._^1*_] FTN 3.3_^1_$COMMON /A/ IFLAGS,LINECT,LINCT1_^1_$COMMON /A/ IR,IK,IP,IA,IL,IM,IXLGO,IOP€€TO,IOPTV,IOPTC,IOPTD_^1_$COMMON /A/ MCSTRT,MACRNB,MACSEC_^1_$COMMON /A/ IERRS(16),ISRFAD_^1_$COMMON /A/ LGO,ISCRI,ISCRO,IX_^1*_] FTN 3.3_^1_$COMMON /A/ IGLAB(3),IGLAB1,IGLAB2_^1_$COMMON /A/ ICOMT(12),ICOMTS,ICOMX2,ICOMTL,ISUBP,NDPRS,_^1_#$LABX,IBCDTB(48)_^1_$EQUIVALENCE(ICOMB,ICOMT(1)),(ICOMBX,ICOMT(2)),(ICOMDF,_^1_#$ICOMT(3)),(ICOMBN,ICOMT(4))_^1_$DIMENSION ICOMB(6),ICOMBX(6),ICO€€MDF(6),ICOMBN(7)_^1_$COMMON /A/ LOOPTS,LOOPTX,LOOPTB,LOOPT(50)_^1_$EQUIVALENCE(LINDUC,LOOPT(1))_^1_$DIMENSION LINDUC(10)_^1_$EQUIVALENCE (LBEG,LOOPT(2))_^1_$DIMENSION LBEG(10)_^1_$EQUIVALENCE (LINC,LOOPT(3))_^1_$DIMENSION LINC(10)_^1_$EQUIVALENCE (LEND,LOOPT(4))_^1_$DIMENSION LEND(10)_^1_$BYTE(LLABL,LOOPT(5)(14=0)_))_^1_$DIMENSION LLABL(10)_^1_$BYTE(LID,LOOPT(5)(15=15) )_^1_$DIME€€NSION LID(10)_^1_$COMMON/A/IEQV(255), IEQVS,IEQVN2_^1_$COMMON /A/ ISTAB(150),ISTABS,ISTAB2_^1_$COMMON /A/ IBUFS,ISET(25),LBLANK,KSFCNT,KSNCNT,ISORSC,_^1_#$IHOBIT,ISTNO,ISSFLG,ISUBPN,ITERM,JSORSC,KEQVS_^1C_#SYMBOL TABLE LABELED COMMON BLOCK_^1_$COMMON /A/ ISYMN, ISYMFL,ISYMD,ISYMX,ISYMS,ISYMP,ISYMPC,ISYMPS,_^1_#$ ISYMNS, SYMTAB(960)_^1_$INTEGER SYMTAB_^1_$BYTE (IDUM,SYMTAB(1)(15=15)€€),(KDUMY,SYMTAB(1)(15=15)),_^1_#$(ICLASS,SYMTAB(1)(14=11)),(ITYPE,SYMTAB(1)(10=9))_^1_$DIMENSION IDUM(100),KDUMY(100),ICLASS(100),ITYPE(100)_^1_$BYTE (ISNGL, SYMTAB(1)(8=8)),(KELSIZ,SYMTAB(1)(8=8)),_^1_#$ (ICOM,SYMTAB(1)(7=5)),(IPART,SYMTAB(1)(4=3))_^1_$DIMENSION ISNGL(100),KELSIZ(100),ICOM(100),IPART(100)_^1_$BYTE (KRFCNT,SYMTAB(1)(2=2)),(IDIM,SYMTAB(1)(1=0)),_^1_#$ (IREL,SYMTAB(1€€)(1=1)),(IEXT,SYMTAB(1)(0=0))_^1_$DIMENSION KRFCNT(100),IDIM(100),IREL(100),IEXT(100)_^1_$EQUIVALENCE (IRSA,SYMTAB(2)),(ICOMTX,SYMTAB(2)),(ISNOL,SYMTAB(2))_^1_$DIMENSION IRSA(100), ICOMTX(100),ISNOL(100)_^1_$BYTE (IDATAS,SYMTAB(3)(15=15)),(IREF,SYMTAB(3)(15=15)),_^1_#$ (IEQVX,SYMTAB(3)(14=8)),(ITILF,SYMTAB(3)(14=8))_^1_$DIMENSION IDATAS(100),IREF(100),IEQVX(100),ITILF(100)_^1_$BYTE€€ (IPARTR,SYMTAB(3)(7=4)),(INDUCV,SYMTAB(3)(7=7)),(ISFARG,_^1_#$ SYMTAB(3)(6=6)),(IARGNO,SYMTAB(3)(5=0)),(IPARTL,SYMTAB(3)(3=0))_^1_$DIMENSION IPARTR(100),INDUCV(100),ISFARG(100),IARGNO(100),_^1_#$ IPARTL(100)_^1_$EQUIVALENCE (ISYM,SYMTAB(4))_^1_$DIMENSION ISYM(100)_^1C_]_^1C_#SPECIFICATION-TABLE INDEX LABELLED COMMON BLOCK_^1_$COMMON /A/ ISTABX(96)_^1C_]_^1C_#PHASE A BLANK COMMON B€€LOCK._^1_$COMMON // JSYM(3),JTERM,JMODE,JERR,JESWT,JFLOT,JCHAR,_^1_#$JOCHAR,JO1,JE,JE1,JBLANK,JCT,JCT1_^1C_#JSYM-JCT1 MUST REMAIN IN ORDER_^1_$COMMON//IERR_^1_$COMMON//ISORS(208),ISORSX_^1_$COMMON//IDEFF,ISTOP,IRET,ISPEC,NERR,OCT_^1_$INTEGER OCT_^1_$COMMON//ILLABL,LEST,ISNGL1,ICOMX1,NXTYPE,LOGIF,IOVFL1,IOVFL2_^1_$COMMON//IVCFLG,ISFLG,LOGEX,KEQVX_^1_$COMMON//IBUF2X,IBUF2(304)_^1C_$T€€EMPORARY ARITHMETIC BUFFERS_^1_$COMMON//IBUF1( 304),IBUF1X,IWORK (304)_^1C_#TEMPORARY EQUIVALENCE BUFFERS_^1_$DIMENSION KEQV(460),MEQV(255)_^1_$EQUIVALENCE (KEQV,IBUF1(66)),(MEQV,IBUF2(100))_^1C_#LS1-ITEM MUST REMAIN IN ORDER_^1_$COMMON//LS1,LPREN,LRELRQ,LRELEN,LSWITC,LO,ITEM_^1_$COMMON//MODE_^1_$COMMON//IPHAT(4),IGNSTT(49),IOSPRT(17)_^1C_]_^1C_]_^1C_]_^1C_#THIS ROUTINE SETS UP THE€€ EQUIVALENCE TABLES AFTER ALL_^1C_#SPECIFICATION STATEMENTS HAVE BEEN PROCESSED._^1C_#SEARCH THROUGH SYMBOL TABLE SETTING UNDECLARED TYPES._^1C_]_^1_$ISYMX=0_^1_$ISYMP=0_^1 971 CALL SYMSCN_^1C_]_^1C_#JUMP IF NO MORE SYMBOLS._^1C_]_^1_$IF(ISYMP.EQ.1) GO TO 969_^1_$IF(_5ITYPE(ISYMX).NE.0) GO TO 971_^1_$ITEMP1=1_^1_$IF (ISYM(ISYMX).GE.0.AND.ISYM(ISYMX).LT.$6AF2.OR._^1_#1 ISYM(ISYMX).€€LT.0.AND.ISYM(ISYMX).GT.$8E97) ITEMP1=2_^1_$ITYPE(ISYMX)=ITEMP1_^1_$GO TO 971_^1C_]_^1C_#********** PART 1 **********_^1C_#CONVERT SUBSCRIPTS TO INCREMENTS._^1C_#****************************_^1C_]_^1 969 IF(KEQVX.EQ.1)RETURN_^1_$JEQVX=-3_^1_$ITEMP5=1_^1C_]_^1C_#SET KEQV INDEX TO NEXT ENTRY._^1C_]_^1_"7 JEQVX=JEQVX+4_^1C_]_^1C_8BEGIN ***PSR 72 * 1577 ***_^1_$IZZY =0_^1_$IZZZ =0_^1C€€_8END_!***PSR 72 * 1577 ***_^1C_#JUMP IF ALL KEQV ENTRIES HAVE BEEN PROCESSED._^1C_]_^1_"3 IF(JEQVX.GE.KEQVX) GO TO 1_^1C_]_^1C_#JUMP IF NOT END OF CHAIN_^1C_]_^1_$IF(KEQV(JEQVX).NE.(-1)) GO TO 2_^1C_]_^1C_#SET JEQVX TO NEXT ENTRY._^1C_]_^1 103 JEQVX=JEQVX+1_^1_$ITEMP5=JEQVX_^1C_8BEGIN ***PSR 72 * 1577 ***_^1_$IZZY =0_^1_$IZZZ =0_^1C_8END_!***PSR 72 * 1577 ***_^1_$GO TO 3_^1C_]_^1€€C_#TEST FOR CORRECT NUMBER OF SUBSCRIPTS. JUMP IF CORRECT._^1C_]_^1_"2 ISYMX=KEQV(JEQVX)_^1_$CALL GETSYM_^1C_8BEGIN ***PSR 72 * 1577 ***_^1C_#CHECK FOR FORMAL PARAMETER EQUIVALENCED TO VARIABLE INITIALIZED_^1C_0BY A DATA STATEMENT_^1_$IF (IDATAS(ISYMX).NE.0) IZZY=IZZY+1_^1_$IF (IDUM (ISYMX).NE.0) IZZZ=IZZZ+1_^1_$IF ((IZZY+IZZZ).EQ.2) CALL DIAG ($5055)_^1C_8END_!***PSR 72 * 157€€7 ***_^1_$ITEMP1=IDIM(ISYMX)_^1_$ITEMP2=0_^1_$IF(KEQV(JEQVX+1).EQ.0) GO TO 4_^1_$ITEMP2=1_^1_$IF(KEQV(JEQVX+2).EQ.0) GO TO 4_^1_$ITEMP2=2_^1_$IF(KEQV(JEQVX+3).EQ.0) GO TO 4_^1_$ITEMP2=3_^1_"4 IF(ITEMP1.EQ.ITEMP2) GO TO 5_^1C_]_^1C_#JUMP IF NUMBER OF DIMENSIONS IN EQUIVALENCE IS NOT ZERO._^1C_]_^1_$IF(ITEMP2.GT.0) GO TO 6_^1C_]_^1C_#SET INDICES TO 1._^1C_]_^1_$KEQV(JEQVX+1)=1_^1_$G€€O TO 765_^1C_]_^1C_#PRINT NAME_^1C_]_^1_"6 CALL PRNTNM(KEQV(JEQVX))_^1_$CALL DIAG($5057)_^1C_]_^1C_#ELIMINATE ENTRY._^1C_]_^1_$KEQV(JEQVX)=0_^1_$GO TO 7_^1C_]_^1C_#JUMP IF ARRAY ELEMENT._^1C_]_^1_"5 IF(ITEMP1.NE.0) GO TO 60_^1C_]_^1C_#SET UP AS IF ONE DIMENSIONAL._^1C_]_^1_$KEQV(JEQVX+1)=1_^1_$GO TO 765_^1C_]_^1C_#JUMP IF FIRST SUBSCRIPT EXCEEDS DIMENSION._^1C_]_^1_!60 ASSIGN 910 T€€O JUMP_^1 900 I=ISYMX/(2*ISYMFL) +1_^1_$I=ISTABX(I)_^1_$IF (AND(ISYMX,1).EQ.1) I=I/$0100_^1_$I=AND(I,$FF)_^1_$GO TO JUMP_^1 910 ITEMP1=I_^1_$IF(KEQV(JEQVX+1).GT.ISTAB(ITEMP1)) GO TO 6_^1C_]_^1C_#JUMP IF THERE IS A SECOND SUBSCRIPT._^1C_]_^1_$IF(KEQV(JEQVX+2).GT.0) GO TO 8_^1C_]_^1C_#JUMP IF ARRAY ELEMENT SIZE IS ONE WORD, OTHERWISE DOUBLE SIZE._^1C_]_^1C_8BEGIN_4***** FTN 3.1 ***€€**_^1C_(IF ARRAY IS DOUBLE PRECISION TRIPLE ELEMENT SIZE._^1 765 IF (ITYPE(ISYMX).EQ.2.OR.(ITYPE(ISYMX).EQ.1.AND.IK.NE.0.AND._^1_#-_!ISNGL(ISYMX).EQ.0)) KEQV(JEQVX+1)=KEQV(JEQVX+1)*2-1_^1_$IF(ITYPE(ISYMX).EQ.3) KEQV(JEQVX+1)=KEQV(JEQVX+1)*3-2_^1C_8END_6***** FTN 3.1 *****_^1C_]_^1C_#JUMP IF NOT AN ELEMENT OF COMMON._^1C_]_^1_$IF(ICOM(ISYMX).EQ.0) GO TO 7_^1 102 ITEMP9=ICOMTX(ISY€€MX)_^1C_]_^1C_#JUMP IF THIS IS FIRST ARRAY OF COMMON OR EQUIVALENCED TO COMMON._^1C_]_^1_$IF(ITEMP9.LE.1) GO TO 100_^1C_]_^1C_#FIND SIZE OF PRECEDING ARRAY OF COMMON._^1C_]_^1_$ISYMX=ITEMP9_^1_$CALL GETSYM_^1_$ITEMP8=1_^1_$ITEMP7=IDIM(ISYMX)_^1_$ASSIGN 920 TO JUMP_^1_$DO 101 ITEMP6=1,ITEMP7_^1_$GO TO 900_^1 920 ITEMPA=I+ITEMP6-1_^1 101 ITEMP8=ITEMP8*ISTAB(ITEMPA)_^1C_8BEGIN_4****€€* FTN 3.1 *****_^1_$IF(ITYPE(ISYMX).EQ.2.OR.(ITYPE(ISYMX).EQ.1.AND.IK.NE.0.AND._^1_#-_!ISNGL(ISYMX).EQ.0)) ITEMP8=ITEMP8*2_^1_$IF (ITYPE(ISYMX).EQ.3)_!ITEMP8=ITEMP8*3_^1C_8END_6***** FTN 3.1 *****_^1_$KEQV(JEQVX+1)=KEQV(JEQVX+1)+ITEMP8_^1_$GO TO 102_^1 100 KEQV(JEQVX)=ISYMX+ISYMP_^1_$GO TO 7_^1C_]_^1C_#JUMP IF SECOND SUBSCRIPT EXCEEDS DIMENSION._^1C_]_^1_"8 IF(KEQV(JEQVX+2).GT.IST€€AB(ITEMP1+1)) GO TO 6_^1_$KEQV(JEQVX+1)=(KEQV(JEQVX+2)-1)*ISTAB(ITEMP1)+KEQV(JEQVX+1)_^1C_]_^1C_#JUMP IF THERE IS NO THIRD SUBSCRIPT._^1C_]_^1_$IF(KEQV(JEQVX+3).EQ.0) GO TO 765_^1C_]_^1C_#JUMP IF THIRD SUBSCRIPT NOT IN RANGE._^1C_]_^1_$IF(KEQV(JEQVX+3).GT.ISTAB(ITEMP1+2)) GO TO 6_^1_$KEQV(JEQVX+1)=(KEQV(JEQVX+3)-1)* ISTAB(ITEMP1)*ISTAB(ITEMP1+1) +_^1_#1KEQV(JEQVX+1)_^1_$GO TO 765_€€^1C_]_^1C_#********** PART 2 **********_^1C_#MERGE SETS OF EQUIVALENCE CHAINS INTO EQUIVALENCE CLASSES._^1C_#****************************_^1C_]_^1_"1 JEQVX=1_^1_$LEQVX=1_^1_$MEQVX=1_^1_$ITEMP1=1_^1C_]_^1C_#FIND UNUSED CHAIN FOR NEW EQUIVALENCE CLASS._^1C_]_^1C_]_^1C_#JUMP IF END OF ENTRIES_^1C_]_^1_!10 IF(ITEMP1.GE.KEQVX) GO TO 11_^1C_]_^1C_#JUMP IF THIS CHAIN HAS NOT BEEN PREVIOUS€€LY REMOVED._^1C_]_^1_!12 IF(KEQV(ITEMP1+1).NE.0) GO TO 762_^1C_]_^1C_#MOVE TO NEXT CHAIN_^1C_]_^1_$ITEMP1=KEQV(ITEMP1+2)_^1_$GO TO 10_^1C_]_^1C_#MOVE CHAIN INTO MEQV, DELETING ILLEGAL ENTRIES._^1C_]_^1 762 ITEMP2=ITEMP1_^1_!13 IF(KEQV(ITEMP1).EQ.0) GO TO 14_^1_$MEQV(LEQVX)=KEQV(ITEMP1)_^1_$MEQV(LEQVX+1) =KEQV(ITEMP1+1)_^1_$LEQVX=LEQVX+2_^1_!14 ITEMP1=ITEMP1+4_^1C_]_^1C_#JUMP IF NO€€T END OF CHAIN_^1C_]_^1_$IF(KEQV(ITEMP1).NE.(-1)) GO TO 13_^1_$KEQV(ITEMP2+1)=0_^1_$ITEMP1=ITEMP1+1_^1_$KEQV(ITEMP2+2)=ITEMP1_^1C_]_^1C_#JUMP IF THERE ARE MEQV CLASS ELEMENTS LEFT_^1C_]_^1_!19 IF(MEQVX.LT.LEQVX) GO TO 15_^1C_]_^1C_#SET END OF CLASS MARK._^1C_]_^1_$MEQV(LEQVX)=-1_^1_$LEQVX=LEQVX+1_^1_$MEQVX=LEQVX_^1_$GO TO 10_^1C_]_^1C_#TRY TO FIND EQUIVALENT CHAIN, EQUIVALENCE ESTA€€BLISHED BY MEQV._^1C_]_^1_!15 JEQVX=ITEMP1_^1_$IENDFG=0_^1C_]_^1C_#JUMP IF NOT END OF ENTRIES._^1C_]_^1_!17 IF(JEQVX.LT.KEQVX) GO TO 18_^1_$MEQVX=MEQVX+2_^1C_]_^1C_#JUMP IF SOMETHING LEFT IN KEQV._^1C_]_^1_$IF(IENDFG.GT.0) GO TO 19_^1_!11 MEQV(LEQVX)=-1_^1_$MEQVX=LEQVX_^1_$GO TO 26_^1C_]_^1C_#JUMP IF NOT END OF CHAIN._^1C_]_^1_!18 IF(KEQV(JEQVX).NE.(-1)) GO TO 54_^1_$JEQVX=JEQVX+1_€€^1_$GO TO 17_^1C_]_^1C_#JUMP IF CHAIN HAS NOT BEEN ASSIGNED TO CLASS._^1C_]_^1_!54 IF(KEQV(JEQVX+1).NE.0) GO TO 52_^1C_]_^1C_#JUMP TO NEXT CHAIN._^1C_]_^1_$JEQVX=KEQV(JEQVX+2)_^1_$GO TO 17_^1C_]_^1C_#IS MEQV(MEQVX) AN ELEMENT IN THIS CHAIN. JUMP TO 20 IF SO._^1C_]_^1C_]_^1C_#JUMP IF NOT END OF CHAIN._^1C_]_^1_!52 ITEMP2=JEQVX_^1_$ITEMP3=JEQVX_^1_!22 IF(KEQV(JEQVX).NE.(-1)) GO TO 2€€1_^1_$JEQVX=JEQVX+1_^1_$IENDFG=1_^1_$GO TO 17_^1_!21 IF(MEQV(MEQVX).EQ.KEQV(JEQVX))GO TO 20_^1_$JEQVX=JEQVX+4_^1_$GO TO 22_^1C_]_^1C_#INTEGRATE CHAIN INTO PARTIAL CLASS. MUST ADJUST TO COMMON INCREM._^1C_]_^1_!20 ITEMPB=KEQV(JEQVX+1)-MEQV(MEQVX+1)_^1C_]_^1C_#JUMP IF END OF CHAIN_^1C_]_^1_!33 IF(KEQV(ITEMP2).EQ.(-1)) GO TO 23_^1C_]_^1C_#JUMP IF ILLEGAL ENTRY._^1C_]_^1_$IF(KEQV(ITEM€€P2).EQ.0) GO TO 766_^1_$MEQV(LEQVX)=KEQV(ITEMP2)_^1_$MEQV(LEQVX+1)=KEQV(ITEMP2+1)-ITEMPB_^1_!24 LEQVX=LEQVX+2_^1 766 ITEMP2=ITEMP2+4_^1_$GO TO 33_^1C_]_^1C_#REMOVE THIS CHAIN FROM KEQV._^1C_]_^1_!23 KEQV(ITEMP3+1)=0_^1_$KEQV (ITEMP3+2)=ITEMP2+1_^1_$JEQVX=ITEMP2+1_^1_$GO TO 17_^1C_]_^1C_#********** PART 3 **********_^1C_#SET UP IEQV BY ORDERING INCREMENTS CORRECTLY AND DELETING_^1C€€_#ILLEGALITIES._^1C_#****************************_^1C_]_^1C_]_^1C_#SORT CLASS BY INCREASING INCREMENT SIZE._^1C_]_^1_!26 IF(MEQVX.EQ.1) RETURN_^1_$ITEMP1=1_^1_$ITEMP4=1_^1_$IOFFG=0_^1_$GO TO 31_^1_!28 IF(MEQV(ITEMP1+1).GE.MEQV(ITEMP2+1)) GO TO 29_^1_$ITEMP3=MEQV(ITEMP1)_^1_$MEQV(ITEMP1)=MEQV(ITEMP2)_^1_$MEQV(ITEMP2)=ITEMP3_^1_$ITEMP3=MEQV(ITEMP1+1)_^1_$MEQV(ITEMP1+1)=MEQV(ITEMP2+1)€€_^1_$MEQV(ITEMP2+1)=ITEMP3_^1_!29 ITEMP2=ITEMP2+2_^1C_]_^1C_#JUMP IF NOT END OF CHAIN FOR SECONDARY SCAN._^1C_]_^1_!30 IF(MEQV(ITEMP2).NE.(-1)) GO TO 28_^1_$ITEMP1=ITEMP1+2_^1_!31 ITEMP2=ITEMP1+2_^1C_]_^1C_#JUMP IF NOT END OF CHAIN FOR PRIMARY SCAN._^1C_]_^1_$IF(MEQV(ITEMP1).NE.(-1)) GO TO 30_^1C_]_^1C_#JUMP IF CLASS EMPTY._^1C_]_^1_$IF(ITEMP4.EQ.ITEMP1) GO TO 763_^1C_]_^1C_#SORT C€€OMPLETED FOR THIS CLASS._^1C_]_^1C_]_^1C_#SET UP CLASS AS INCREMENT OVER BASE AND FIND FIRST COMMON BLOCK._^1C_]_^1_$ITEMP2=MEQV(ITEMP4+1)+1_^1_$ITEMP5=ITEMP4+1_^1_$ICOMFG=0_^1_$ITEMPC=ITEMP4_^1_$DO 34 ITEMP5=ITEMP5,ITEMP1,2_^1_$IF(ICOMFG.NE.0) GO TO 34_^1_$ISYMX=MEQV(ITEMP5-1)_^1_$CALL GETSYM_^1_$ICOMFG=ICOM(ISYMX)_^1_$IF(MEQV(ITEMP5).EQ.1.OR.ICOMFG.EQ.0) GO TO 34_^1_$ITEMPC=ITEMP€€5-1_^1_!34 MEQV(ITEMP5)=ITEMP2-MEQV(ITEMP5)_^1C_]_^1C_#COMPARE ALL PAIRS FOR LEGALITY AND ENTER INTO IEQV._^1C_]_^1_$ITEMP5=ITEMP1-1_^1C******************************************************** *3.1*79*1839_^1C_83-CARDS DELETED_^1C******************************************************** *3.1*79*1839_^1_$IDUMFG=0_^1C******************************************************** *3.1*79*183€€9_^1C_#ASSUMES ALL ENTRIES IN A CLASS ARE RELATED_^1C_]_^1_$DO 110 ITEMP6 = ITEMP4,ITEMP5,2_^1C******************************************************** *3.1*79*1839_^1C_]_^1C_#JUMP IF HAS BEEN DELETED._^1C_]_^1_$IF(MEQV(ITEMP6).EQ.0) GO TO 110_^1_$ISYMX=MEQV(ITEMP6)_^1_$CALL GETSYM_^1_$ITEMP8=ICOM(ISYMX)_^1_$ITEMP9=IDUM(ISYMX)_^1_$IF(ITEMP9.EQ.0) GO TO 32_^1_$IF(IDUMFG.NE.0) GO TO €€32_^1_$IDUMFG=1_^1_$DO 38 ITEMPD=ITEMPC,ITEMP6,2_^1C ********************************** PSR 658 **************************_^1C ********************************** PSR 658 **************************_^1C_]_^1C_$JUMP IF ENTRY HAS BEEN DELETED_^1C_]_^1_%IF(MEQV(ITEMPD).EQ.0) GO TO 38_^1C ********************************** PSR 658 **************************_^1_$ISYMX=MEQV(ITEMPD)_^1_$€€CALL GETSYM_^1C ********************************** PSR 658 **************************_^1_%IDUM(ISYMX)=IDUMFG_^1 38_"CONTINUE_^1C ********************************** PSR 658 **************************_^1C ********************************** PSR 658 **************************_^1_!32 IDUM(ISYMX)=IDUMFG_^1_$ITEMP7=ITEMP6+2_^1C_]_^1C_#SET SYMBOL TABLE ENTRY TO CORRECT COMMON BLOCK, IF €€ANY._^1C_]_^1_$IF(ICOMFG.EQ.0) GO TO 833_^1_$IF((ITEMP8.EQ.0.OR.ITEMP8.EQ.ICOMFG).AND.ITEMP9.EQ.0) GO TO 832_^1_$CALL PRNTNM(MEQV(ITEMP6))_^1_$CALL DIAG($5054)_^1_$MEQV(ITEMP6)=0_^1_$GO TO 110_^1 832 ICOM(ISYMX)=ICOMFG_^1_$ITEMP8=ICOMFG_^1 833 DO 35 ITEMP7=ITEMP7,ITEMP5,2_^1C_]_^1C_#JUMP IF HAS BEEN DELETED._^1C_]_^1_$IF(MEQV(ITEMP7).EQ.0) GO TO 35_^1C_]_^1C_#JUMP IF NOT TWO ELEM€€ENTS OF SAME ARRAY._^1C_]_^1_$IF(MEQV(ITEMP6).NE.MEQV(ITEMP7)) GO TO 36_^1C_]_^1C_#JUMP IF INCREMENTS THE SAME._^1C_]_^1_$IF(MEQV(ITEMP6+1).EQ.MEQV(ITEMP7+1))GO TO 37_^1_$GO TO 44_^1C_]_^1C_#JUMP IF TWO DUMMY ARGUMENTS._^1C_]_^1_!36 ISYMX=MEQV(ITEMP7)_^1_$CALL GETSYM_^1_$IF(ITEMP9.EQ.0.OR.IDUM(ISYMX).EQ.0) GO TO 35_^1_!44 CALL PRNTNM(MEQV(ITEMP6))_^1_$CALL PRNTNM(MEQV(ITEMP7))_^1_$€€CALL DIAG($5054)_^1_!37 MEQV(ITEMP7)=0_^1_!35 CONTINUE_^1 110 CONTINUE_^1C_]_^1C_#JUMP TO PROCESSES MORE CLASSES._^1C_]_^1 763 ITEMP1=ITEMP1+1_^1_$ITEMP4=ITEMP1_^1_$IF(ITEMP1.LT.MEQVX) GO TO 31_^1C_]_^1C_#SET UP IEQV TABLES._^1C_]_^1_$IEQVN2=1_^1_$ITEMP1=1_^1_$ITEMP2=1_^1C ********************************** PSR 886 **************************_^1C *********************************€€* PSR 886 **************************_^1_$IPTROV=0_^1C ********************************** PSR 886 **************************_^1C_]_^1C_#JUMP IF NOT END-OF-CLASS_^1C_]_^1_!43 IF(MEQV(ITEMP1).NE.(-1)) GO TO 40_^1C_]_^1C_#JUMP IF CLASS CONTAINS TWO OR MORE NAMES._^1C_]_^1_$IF(ITEMP2.GT.IEQVN2+2) GO TO 41_^1_$ITEMP2=IEQVN2_^1_$GO TO 45_^1C_]_^1C_#SET UP NUMBER OF ELEMENTS IN THIS CLAS€€S_^1C_]_^1_!41 IEQV(IEQVN2+1)=(ITEMP2-IEQVN2)/2_^1C_]_^1C_#SET END OF CLASS FLAG._^1C_]_^1_$IEQV(ITEMP2)=-1_^1_$ITEMP3=ITEMP2-1_^1_$DO 761 ITEMP4=IEQVN2,ITEMP3,2_^1_$ISYMX=IEQV(ITEMP4)_^1_$CALL GETSYM_^1 761 IEQVX(ISYMX)=IEQVN2_^1C ********************************** PSR 886 **************************_^1_$IF(IEQVN2.GT.$7F) GO TO 951_^1 952 ITEMP2=ITEMP2+1_^1C ********************€€************** PSR 886 **************************_^1_$IEQVN2=ITEMP2_^1_!45 ITEMP1=ITEMP1+1_^1C_]_^1C_#RETURN IF ALL EQUIVALENCE ENTRIES HAVE BEEN PROCESSED._^1C_]_^1_$IF(ITEMP1.GE.MEQVX) RETURN_^1_$GO TO 43_^1C_]_^1C_#JUMP IF ENTRY IS NOT TO BE DELETED_^1C_]_^1_!40 IF(MEQV(ITEMP1).NE.0) GO TO 42_^1_$ITEMP1=ITEMP1+2_^1_$GO TO 43_^1C_]_^1C_#CHECK FOR TABLE OVERFLOW. JUMP IF NONE_^1€€C_]_^1_!42 IF(ITEMP2.LE.IEQVS-1) GO TO 50_^1_$IF(IOVFFG.NE.0) GO TO 764_^1_$IOVFFG=1_^1_$CALL DIAG($5058)_^1_$GO TO 764_^1C_]_^1C_#STORE NAME INTO EQUIVALENCE TABLE._^1C_]_^1_!50 IEQV (ITEMP2)=MEQV(ITEMP1)_^1_$IEQV(ITEMP2+1)=MEQV(ITEMP1+1)_^1 764 ITEMP2=ITEMP2+2_^1_$ITEMP1=ITEMP1+2_^1_$GO TO 43_^1C ********************************** PSR 886 **************************_^1 951 IF(I€êPTROV.NE.0) GO TO 952_^1_$IPTROV=1_^1_$CALL DIAG($5058)_^1_$GO TO 952_^1C ********************************** PSR 886 **************************_^1C ********************************** PSR 886 **************************_^1_$END_]_^__ êPWPRTNM CSY/ 26A P€1_$SUBROUTINE PRNTNM(NAM)_^1_#*_2/DECK-ID 26A FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^13_]_^1C PRNTNM IS USED IN PHASE A2_^1C_]_^1C_#MASTER LABELED COMMON BLOCK._^1*_] FTN 3.3_^1_$COMMON /A/ IFLAGS,LINECT,LINCT1_^1_$COMMON /A/ IR,IK,IP,IA,IL,IM,IX€€LGO,IOPTO,IOPTV,IOPTC,IOPTD_^1_$COMMON /A/ MCSTRT,MACRNB,MACSEC_^1_$COMMON /A/ IERRS(16),ISRFAD_^1_$COMMON /A/ LGO,ISCRI,ISCRO,IX_^1*_] FTN 3.3_^1_$COMMON /A/ IGLAB(3),IGLAB1,IGLAB2_^1_$COMMON /A/ ICOMT(12),ICOMTS,ICOMX2,ICOMTL,ISUBP,NDPRS,_^1_#$LABX,IBCDTB(48)_^1_$EQUIVALENCE(ICOMB,ICOMT(1)),(ICOMBX,ICOMT(2)),(ICOMDF,_^1_#$ICOMT(3)),(ICOMBN,ICOMT(4))_^1_$DIMENSION ICOMB(6),ICOMBX€€(6),ICOMDF(6),ICOMBN(7)_^1_$COMMON /A/ LOOPTS,LOOPTX,LOOPTB,LOOPT(50)_^1_$EQUIVALENCE(LINDUC,LOOPT(1))_^1_$DIMENSION LINDUC(10)_^1_$EQUIVALENCE (LBEG,LOOPT(2))_^1_$DIMENSION LBEG(10)_^1_$EQUIVALENCE (LINC,LOOPT(3))_^1_$DIMENSION LINC(10)_^1_$EQUIVALENCE (LEND,LOOPT(4))_^1_$DIMENSION LEND(10)_^1_$BYTE(LLABL,LOOPT(5)(14=0)_))_^1_$DIMENSION LLABL(10)_^1_$BYTE(LID,LOOPT(5)(15=15) )_^€€1_$DIMENSION LID(10)_^1_$COMMON/A/IEQV(255), IEQVS,IEQVN2_^1_$COMMON /A/ ISTAB(150),ISTABS,ISTAB2_^1_$COMMON /A/ IBUFS,ISET(25),LBLANK,KSFCNT,KSNCNT,ISORSC,_^1_#$IHOBIT,ISTNO,ISSFLG,ISUBPN,ITERM,JSORSC,KEQVS_^1C_#SYMBOL TABLE LABELED COMMON BLOCK_^1_$COMMON /A/ ISYMN, ISYMFL,ISYMD,ISYMX,ISYMS,ISYMP,ISYMPC,ISYMPS,_^1_#$ ISYMNS, SYMTAB(960)_^1_$INTEGER SYMTAB_^1_$BYTE (IDUM,SYMTAB(1)€€(15=15)),(KDUMY,SYMTAB(1)(15=15)),_^1_#$(ICLASS,SYMTAB(1)(14=11)),(ITYPE,SYMTAB(1)(10=9))_^1_$DIMENSION IDUM(100),KDUMY(100),ICLASS(100),ITYPE(100)_^1_$BYTE (ISNGL, SYMTAB(1)(8=8)),(KELSIZ,SYMTAB(1)(8=8)),_^1_#$ (ICOM,SYMTAB(1)(7=5)),(IPART,SYMTAB(1)(4=3))_^1_$DIMENSION ISNGL(100),KELSIZ(100),ICOM(100),IPART(100)_^1_$BYTE (KRFCNT,SYMTAB(1)(2=2)),(IDIM,SYMTAB(1)(1=0)),_^1_#$ (IREL,S€€YMTAB(1)(1=1)),(IEXT,SYMTAB(1)(0=0))_^1_$DIMENSION KRFCNT(100),IDIM(100),IREL(100),IEXT(100)_^1_$EQUIVALENCE (IRSA,SYMTAB(2)),(ICOMTX,SYMTAB(2)),(ISNOL,SYMTAB(2))_^1_$DIMENSION IRSA(100), ICOMTX(100),ISNOL(100)_^1_$BYTE (IDATAS,SYMTAB(3)(15=15)),(IREF,SYMTAB(3)(15=15)),_^1_#$ (IEQVX,SYMTAB(3)(14=8)),(ITILF,SYMTAB(3)(14=8))_^1_$DIMENSION IDATAS(100),IREF(100),IEQVX(100),ITILF(100)_^€€1_$BYTE (IPARTR,SYMTAB(3)(7=4)),(INDUCV,SYMTAB(3)(7=7)),(ISFARG,_^1_#$ SYMTAB(3)(6=6)),(IARGNO,SYMTAB(3)(5=0)),(IPARTL,SYMTAB(3)(3=0))_^1_$DIMENSION IPARTR(100),INDUCV(100),ISFARG(100),IARGNO(100),_^1_#$ IPARTL(100)_^1_$EQUIVALENCE (ISYM,SYMTAB(4))_^1_$DIMENSION ISYM(100)_^1C_]_^1C_#SPECIFICATION-TABLE INDEX LABELLED COMMON BLOCK_^1_$COMMON /A/ ISTABX(96)_^1C_]_^1_$DIMENSION ICONF(€€4),ITEMP(3)_^1_$DATA IADD/0/_^1_$DATA ICONF(1),ICONF(2),ICONF(3),ICONF(4) /1521,39,1,0/_^1_$EQUIVALENCE (ICONF(4),ITEMP(1)),(ITEMP(3),KTEMP)_^1_$DIMENSION NAMBUF(4),NHOLD(6)_^1_$DATA NAMBUF(1) /$2020/_^1_$L=1_]_^1_$ISYMX=NAM_^1_$CALL GETSYM_^1_$DO 1 I=1,2_^1_$K=ISYMX+I-1_^1_$ITEMP(1)=0_^1_$ITEMP(2)=0_^1_$KTEMP=ISYM(K)_^1_$IF (KTEMP .GE. 0) GO TO 4_^1_$KTEMP=ISYM(K)-30420_^1_$IADD=€N20_^1_"4 DO 2 J=1,3_^1_$ITEMP(J) = (KTEMP-ITEMP(1)*ICONF(1)-ITEMP(2)*ICONF(2))/ICONF(J)_^1_$KK=ITEMP(J)+IADD_^1_$IF (KK .EQ. 38) KK=46_^1_$NHOLD(L) = IBCDTB(KK+1)_^1_$L=L+1_^1_"2 IADD=0_^1_"1 CONTINUE_^1_$DO 3 I=1,6,2_^1_$J=2+I/2_^1_"3 NAMBUF (J_") = 256*NHOLD(I) + NHOLD(I+1)_^1_$CALL WRITE (3,1,4,NAMBUF(1))_^1_$RETURN_^1_$END_]_^__NPWPUNT1 CSY/ 27A P€1_$SUBROUTINE PUNT_^1_#*_2/DECK-ID 27A FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^13_]_^1C PUNT IS USED IN PHASE A3_^1C_]_^1C_#PHASE A BLANK COMMON BLOCK._^1_$COMMON // JSYM(3),JTERM,JMODE,JERR,JESWT,JFLOT,JCHAR,_^1_#$JOCHAR,JO1,JE,JE1,JBLANK,JCT,JCT1€€_^1C_#JSYM-JCT1 MUST REMAIN IN ORDER_^1_$COMMON//IERR_^1_$COMMON//ISORS(208),ISORSX_^1_$COMMON//IDEFF,ISTOP,IRET,ISPEC,NERR,OCT_^1_$INTEGER OCT_^1_$COMMON//ILLABL,LEST,ISNGL1,ICOMX1,NXTYPE,LOGIF,IOVFL1,IOVFL2_^1_$COMMON//IVCFLG,ISFLG,LOGEX,KEQVX_^1_$COMMON//IBUF2X,IBUF2(304)_^1C_$TEMPORARY ARITHMETIC BUFFERS_^1_$COMMON//IBUF1( 304),IBUF1X,IWORK (304)_^1C_#TEMPORARY EQUIVALENCE BUFF€€ERS_^1_$DIMENSION KEQV(460),MEQV(255)_^1_$EQUIVALENCE (KEQV,IBUF1(66)),(MEQV,IBUF2(100))_^1C_#LS1-ITEM MUST REMAIN IN ORDER_^1_$COMMON//LS1,LPREN,LRELRQ,LRELEN,LSWITC,LO,ITEM_^1_$COMMON//MODE_^1_$COMMON//IPHAT(4),IGNSTT(49),IOSPRT(17)_^1C_]_^1C_]_^1_$DIMENSION IENDBF(3)_^1_$DATA IENDBF(1),IENDBF(2),IENDBF(3) /$45,$4E,$44/_^1_$JMODE=0_^1_$CALL DIAG(4196)_^1C SLEW THRU 'END' CARD._^1€ú_"1 CALL READ (1,1,41,ISORS)_^1_$I = 1_^1_$DO 2 J=7,72_^1_'K = IGETCF(ISORS,J)_^1_'IF (K.EQ.$20) GO TO 2_^1_'IF (K.NE.IENDBF(I)) GO TO 1_^1_'I = I+1_^1_"2_!CONTINUE_^1_$IF (I.NE.4) GO TO 1_^1C TERMINATE COMPILATION._^1_$CALL SKIPIT_^1_$END_]_^__ úPWSYMS1 CSY/ 28A P€1_$SUBROUTINE SYMSCN_^1_#*_2/DECK-ID 28A FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^13_]_^1C THIS SYMSCN IS USED IN PHASES A2,B1_^1C NON-IDENTICAL SYMSCN IS USED IN PHASES C1,D1,E1_^1C_]_^1C_#MASTER LABELED COMMON BLOCK._^1*_] FTN 3.3_^1_$COMMON /A/ €€IFLAGS,LINECT,LINCT1_^1_$COMMON /A/ IR,IK,IP,IA,IL,IM,IXLGO,IOPTO,IOPTV,IOPTC,IOPTD_^1_$COMMON /A/ MCSTRT,MACRNB,MACSEC_^1_$COMMON /A/ IERRS(16),ISRFAD_^1_$COMMON /A/ LGO,ISCRI,ISCRO,IX_^1*_] FTN 3.3_^1_$COMMON /A/ IGLAB(3),IGLAB1,IGLAB2_^1_$COMMON /A/ ICOMT(12),ICOMTS,ICOMX2,ICOMTL,ISUBP,NDPRS,_^1_#$LABX,IBCDTB(48)_^1_$EQUIVALENCE(ICOMB,ICOMT(1)),(ICOMBX,ICOMT(2)),(ICOMDF,_^1_#$I€€COMT(3)),(ICOMBN,ICOMT(4))_^1_$DIMENSION ICOMB(6),ICOMBX(6),ICOMDF(6),ICOMBN(7)_^1_$COMMON /A/ LOOPTS,LOOPTX,LOOPTB,LOOPT(50)_^1_$EQUIVALENCE(LINDUC,LOOPT(1))_^1_$DIMENSION LINDUC(10)_^1_$EQUIVALENCE (LBEG,LOOPT(2))_^1_$DIMENSION LBEG(10)_^1_$EQUIVALENCE (LINC,LOOPT(3))_^1_$DIMENSION LINC(10)_^1_$EQUIVALENCE (LEND,LOOPT(4))_^1_$DIMENSION LEND(10)_^1_$BYTE(LLABL,LOOPT(5)(14=0)_))_^1€€_$DIMENSION LLABL(10)_^1_$BYTE(LID,LOOPT(5)(15=15) )_^1_$DIMENSION LID(10)_^1_$COMMON/A/IEQV(255), IEQVS,IEQVN2_^1_$COMMON /A/ ISTAB(150),ISTABS,ISTAB2_^1_$COMMON /A/ IBUFS,ISET(25),LBLANK,KSFCNT,KSNCNT,ISORSC,_^1_#$IHOBIT,ISTNO,ISSFLG,ISUBPN,ITERM,JSORSC,KEQVS_^1C_#SYMBOL TABLE LABELED COMMON BLOCK_^1_$COMMON /A/ ISYMN, ISYMFL,ISYMD,ISYMX,ISYMS,ISYMP,ISYMPC,ISYMPS,_^1_#$ ISYMNS,€€ SYMTAB(960)_^1_$INTEGER SYMTAB_^1_$BYTE (IDUM,SYMTAB(1)(15=15)),(KDUMY,SYMTAB(1)(15=15)),_^1_#$(ICLASS,SYMTAB(1)(14=11)),(ITYPE,SYMTAB(1)(10=9))_^1_$DIMENSION IDUM(100),KDUMY(100),ICLASS(100),ITYPE(100)_^1_$BYTE (ISNGL, SYMTAB(1)(8=8)),(KELSIZ,SYMTAB(1)(8=8)),_^1_#$ (ICOM,SYMTAB(1)(7=5)),(IPART,SYMTAB(1)(4=3))_^1_$DIMENSION ISNGL(100),KELSIZ(100),ICOM(100),IPART(100)_^1_$BYTE (KRF€€CNT,SYMTAB(1)(2=2)),(IDIM,SYMTAB(1)(1=0)),_^1_#$ (IREL,SYMTAB(1)(1=1)),(IEXT,SYMTAB(1)(0=0))_^1_$DIMENSION KRFCNT(100),IDIM(100),IREL(100),IEXT(100)_^1_$EQUIVALENCE (IRSA,SYMTAB(2)),(ICOMTX,SYMTAB(2)),(ISNOL,SYMTAB(2))_^1_$DIMENSION IRSA(100), ICOMTX(100),ISNOL(100)_^1_$BYTE (IDATAS,SYMTAB(3)(15=15)),(IREF,SYMTAB(3)(15=15)),_^1_#$ (IEQVX,SYMTAB(3)(14=8)),(ITILF,SYMTAB(3)(14=8))_^1_€€$DIMENSION IDATAS(100),IREF(100),IEQVX(100),ITILF(100)_^1_$BYTE (IPARTR,SYMTAB(3)(7=4)),(INDUCV,SYMTAB(3)(7=7)),(ISFARG,_^1_#$ SYMTAB(3)(6=6)),(IARGNO,SYMTAB(3)(5=0)),(IPARTL,SYMTAB(3)(3=0))_^1_$DIMENSION IPARTR(100),INDUCV(100),ISFARG(100),IARGNO(100),_^1_#$ IPARTL(100)_^1_$EQUIVALENCE (ISYM,SYMTAB(4))_^1_$DIMENSION ISYM(100)_^1_$IF (ISYMX.NE.0) GOTO 10_^1_$ISYMX=1_^1_$GOTO 20_^1_€t!10 ISYMX=ISYMP+ISYMX+ISYMFL_^1_$IF (ISYMX.LT.ISYMN) GOTO 20_^1_$ISYMP=1_^1_$RETURN_^1_!20 CALL GETSYM_^1_$END_]_^__tPWENDDO CSY/ 29A P€1_$SUBROUTINE ENDDO_^1_#*_2/DECK-ID 29A FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^13_]_^1C ENDDO IS USED IN PHASES A1,A2,A3,A4,A5_^1C_]_^1C_#MASTER LABELED COMMON BLOCK._^1*_] FTN 3.3_^1_$COMMON /A/ IFLAGS,LINECT,LINCT1_^1_$COMMON /A/ IR,IK,IP,IA,IL€€,IM,IXLGO,IOPTO,IOPTV,IOPTC,IOPTD_^1_$COMMON /A/ MCSTRT,MACRNB,MACSEC_^1_$COMMON /A/ IERRS(16),ISRFAD_^1_$COMMON /A/ LGO,ISCRI,ISCRO,IX_^1*_] FTN 3.3_^1_$COMMON /A/ IGLAB(3),IGLAB1,IGLAB2_^1_$COMMON /A/ ICOMT(12),ICOMTS,ICOMX2,ICOMTL,ISUBP,NDPRS,_^1_#$LABX,IBCDTB(48)_^1_$EQUIVALENCE(ICOMB,ICOMT(1)),(ICOMBX,ICOMT(2)),(ICOMDF,_^1_#$ICOMT(3)),(ICOMBN,ICOMT(4))_^1_$DIMENSION ICOMB(6),€€ICOMBX(6),ICOMDF(6),ICOMBN(7)_^1_$COMMON /A/ LOOPTS,LOOPTX,LOOPTB,LOOPT(50)_^1_$EQUIVALENCE(LINDUC,LOOPT(1))_^1_$DIMENSION LINDUC(10)_^1_$EQUIVALENCE (LBEG,LOOPT(2))_^1_$DIMENSION LBEG(10)_^1_$EQUIVALENCE (LINC,LOOPT(3))_^1_$DIMENSION LINC(10)_^1_$EQUIVALENCE (LEND,LOOPT(4))_^1_$DIMENSION LEND(10)_^1_$BYTE(LLABL,LOOPT(5)(14=0)_))_^1_$DIMENSION LLABL(10)_^1_$BYTE(LID,LOOPT(5)(15=15€€) )_^1_$DIMENSION LID(10)_^1_$COMMON/A/IEQV(255), IEQVS,IEQVN2_^1_$COMMON /A/ ISTAB(150),ISTABS,ISTAB2_^1_$COMMON /A/ IBUFS,ISET(25),LBLANK,KSFCNT,KSNCNT,ISORSC,_^1_#$IHOBIT,ISTNO,ISSFLG,ISUBPN,ITERM,JSORSC,KEQVS_^1C_#SYMBOL TABLE LABELED COMMON BLOCK_^1_$COMMON /A/ ISYMN, ISYMFL,ISYMD,ISYMX,ISYMS,ISYMP,ISYMPC,ISYMPS,_^1_#$ ISYMNS, SYMTAB(960)_^1_$INTEGER SYMTAB_^1_$BYTE (IDUM,SYM€€TAB(1)(15=15)),(KDUMY,SYMTAB(1)(15=15)),_^1_#$(ICLASS,SYMTAB(1)(14=11)),(ITYPE,SYMTAB(1)(10=9))_^1_$DIMENSION IDUM(100),KDUMY(100),ICLASS(100),ITYPE(100)_^1_$BYTE (ISNGL, SYMTAB(1)(8=8)),(KELSIZ,SYMTAB(1)(8=8)),_^1_#$ (ICOM,SYMTAB(1)(7=5)),(IPART,SYMTAB(1)(4=3))_^1_$DIMENSION ISNGL(100),KELSIZ(100),ICOM(100),IPART(100)_^1_$BYTE (KRFCNT,SYMTAB(1)(2=2)),(IDIM,SYMTAB(1)(1=0)),_^1_#$ (€€IREL,SYMTAB(1)(1=1)),(IEXT,SYMTAB(1)(0=0))_^1_$DIMENSION KRFCNT(100),IDIM(100),IREL(100),IEXT(100)_^1_$EQUIVALENCE (IRSA,SYMTAB(2)),(ICOMTX,SYMTAB(2)),(ISNOL,SYMTAB(2))_^1_$DIMENSION IRSA(100), ICOMTX(100),ISNOL(100)_^1_$BYTE (IDATAS,SYMTAB(3)(15=15)),(IREF,SYMTAB(3)(15=15)),_^1_#$ (IEQVX,SYMTAB(3)(14=8)),(ITILF,SYMTAB(3)(14=8))_^1_$DIMENSION IDATAS(100),IREF(100),IEQVX(100),ITILF(€€100)_^1_$BYTE (IPARTR,SYMTAB(3)(7=4)),(INDUCV,SYMTAB(3)(7=7)),(ISFARG,_^1_#$ SYMTAB(3)(6=6)),(IARGNO,SYMTAB(3)(5=0)),(IPARTL,SYMTAB(3)(3=0))_^1_$DIMENSION IPARTR(100),INDUCV(100),ISFARG(100),IARGNO(100),_^1_#$ IPARTL(100)_^1_$EQUIVALENCE (ISYM,SYMTAB(4))_^1_$DIMENSION ISYM(100)_^1C_]_^1C_#SPECIFICATION-TABLE INDEX LABELLED COMMON BLOCK_^1_$COMMON /A/ ISTABX(96)_^1C_]_^1C_#PHASE A B€€LANK COMMON BLOCK._^1_$COMMON // JSYM(3),JTERM,JMODE,JERR,JESWT,JFLOT,JCHAR,_^1_#$JOCHAR,JO1,JE,JE1,JBLANK,JCT,JCT1_^1C_#JSYM-JCT1 MUST REMAIN IN ORDER_^1_$COMMON//IERR_^1_$COMMON//ISORS(208),ISORSX_^1_$COMMON//IDEFF,ISTOP,IRET,ISPEC,NERR,OCT_^1_$INTEGER OCT_^1_$COMMON//ILLABL,LEST,ISNGL1,ICOMX1,NXTYPE,LOGIF,IOVFL1,IOVFL2_^1_$COMMON//IVCFLG,ISFLG,LOGEX,KEQVX_^1_$COMMON//IBUF2X,IBUF€€2(304)_^1C_$TEMPORARY ARITHMETIC BUFFERS_^1_$COMMON//IBUF1( 304),IBUF1X,IWORK (304)_^1C_#TEMPORARY EQUIVALENCE BUFFERS_^1_$DIMENSION KEQV(460),MEQV(255)_^1_$EQUIVALENCE (KEQV,IBUF1(66)),(MEQV,IBUF2(100))_^1C_#LS1-ITEM MUST REMAIN IN ORDER_^1_$COMMON//LS1,LPREN,LRELRQ,LRELEN,LSWITC,LO,ITEM_^1_$COMMON//MODE_^1_$COMMON//IPHAT(4),IGNSTT(49),IOSPRT(17)_^1C_]_^1C_]_^1C_]_^1C_#THIS SUBROU€€TINE TEST THE CURRENT STATEMENT FOR BEING A D0 L00P_^1C_#TERMINATOR_^1C_]_^1_$DIMENSION IENDOB(4)_^1_$DATA IENDOB(1),IENDOB(3)/4,41/_^1_$NXTYPE=18_^1_$ITEMPX=IVCFLG_^1C_]_^1C_#RETURN IF STATEMENT IS NOT IN A LOOP._^1C_]_^1_$IF(LOOPTX.EQ.1) RETURN_^1_$ITERMF=0_^1C_]_^1C_#JUMP IF THIS STATEMENT DOES NOT TERMINATE THE INNERM0ST LOOP._^1_"2 LOOPTX=LOOPTX-LOOPTB_^1_$IF(LLABL(LOOPTX).NE.€€ILLABL) GO TO 1_^1_$ITERMF=1_^1_$ASSIGN 7 TO IGO1_^1C_]_^1C_#CLEAR INDUCTION VARIABLE FLAGS_^1_"9 I=LOOPTX_^1_!11 ISYMX=LINDUC(I)_^1_$CALL GETSYM_^1_$INDUCV(ISYMX)=0_^1_$ISYMX=LBEG(I)_^1_$CALL GETSYM_^1_$INDUCV(ISYMX)=0_^1_$ISYMX=LINC(I)_^1_$CALL GETSYM_^1_$INDUCV(ISYMX)=0_^1_$ISYMX=LEND(I)_^1_$CALL GETSYM_^1_$INDUCV(ISYMX)=0_^1_$GO TO IGO1_^1C_]_^1C_#OUTPUT END DO FILE ITEM._^1C_]€€_^1_"7 IENDOB(4)=IBUF2(1)_^1_$IF(ITEMPX.EQ.(-1).AND.LOGIF.EQ.2)IENDOB(4)=-IENDOB(4)_^1_$IENDOB(2)=ISTNO_^1_$IBUF2(1)=4_^1_$CALL OUTENT(IENDOB)_^1C_]_^1C_#ELIMINATE INNERMOST DO LOOP._^1C_#JUMP IF MORE DO LOOPS LEFT._^1_$IF (ITEMPX.EQ.(-1)) RETURN_^1_$IF (LOOPTX.NE.1) GO TO 2_^1_$GO TO 10_^1C_]_^1C_#PRINT DIAGNOSTIC FOR EVERY OUTER DO THIS LABEL TERMINATES. REMOVE_^1C_#THE LOOP FRO€€M FURTHER CONSIDERATION._^1_"1 J=LOOPTX-LOOPTB_^1_$LOOPTX=LOOPTX+LOOPTB_^1_$ASSIGN 44 TO IGO1_^1_$GO TO 3_^1_"4 IF(LLABL(J).NE.ILLABL ) GO TO 6_^1_$ITERMF=1_^1_$CALL DIAG($49)_^1_$I=J_]_^1_$GO TO 11_^1_!44 K=J+LOOPTB+1_^1_$DO 5 I=K,LOOPTX_^1_$L=I-LOOPTB-1_^1_"5 LOOPT(L)=LOOPT(I-1)_^1_$LOOPTX=LOOPTX-LOOPTB_^1_"6 J=J-LOOPTB_^1_"3 IF(J.GE.1) GO TO 4_^1C_]_^1C_#RETURN IF STATEMENT HAS€€ NEVER TERMINATED A LOOP._^1C_]_^1_!10 IF(ITERMF.EQ.0.OR.ITEMPX.EQ.(-1))RETURN_^1C_]_^1C_#PRINT DIAGNOSTIC IF STATEMENT TYPE ILLEGAL FOR DO LOOP TERMINATOR._^1_$I=IABS(IBUF2(3))_^1_$IF(I.GE.22.AND.I.LE.32.AND.I.NE.27.OR.I.EQ.40.OR.I.EQ.42)_^1_#1_!CALL DIAG(72)_^1_$IF(I.EQ.43.AND.(NXTYPE.GE.22.AND.NXTYPE.LE.32_^1_#1.AND.NXTYPE.NE.27.OR._^1_#2NXTYPE.EQ.40.OR.NXTYPE.EQ.42))CALL DIAG(7€2)_^1_$END_]_^__ PWCONSB CSY/ 30A P€1_$SUBROUTINE CONSUB_^1_#*_2/DECK-ID 30A FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^13_]_^1C CONSUB IS USED IN PHASES A2,A3_^1C_]_^1C_#MASTER LABELED COMMON BLOCK._^1*_] FTN 3.3_^1_$COMMON /A/ IFLAGS,LINECT,LINCT1_^1_$COMMON /A/ IR,IK,IP,IA,IL,IM,IXL€€GO,IOPTO,IOPTV,IOPTC,IOPTD_^1_$COMMON /A/ MCSTRT,MACRNB,MACSEC_^1_$COMMON /A/ IERRS(16),ISRFAD_^1_$COMMON /A/ LGO,ISCRI,ISCRO,IX_^1*_] FTN 3.3_^1_$COMMON /A/ IGLAB(3),IGLAB1,IGLAB2_^1_$COMMON /A/ ICOMT(12),ICOMTS,ICOMX2,ICOMTL,ISUBP,NDPRS,_^1_#$LABX,IBCDTB(48)_^1_$EQUIVALENCE(ICOMB,ICOMT(1)),(ICOMBX,ICOMT(2)),(ICOMDF,_^1_#$ICOMT(3)),(ICOMBN,ICOMT(4))_^1_$DIMENSION ICOMB(6),ICOMBX(€€6),ICOMDF(6),ICOMBN(7)_^1_$COMMON /A/ LOOPTS,LOOPTX,LOOPTB,LOOPT(50)_^1_$EQUIVALENCE(LINDUC,LOOPT(1))_^1_$DIMENSION LINDUC(10)_^1_$EQUIVALENCE (LBEG,LOOPT(2))_^1_$DIMENSION LBEG(10)_^1_$EQUIVALENCE (LINC,LOOPT(3))_^1_$DIMENSION LINC(10)_^1_$EQUIVALENCE (LEND,LOOPT(4))_^1_$DIMENSION LEND(10)_^1_$BYTE(LLABL,LOOPT(5)(14=0)_))_^1_$DIMENSION LLABL(10)_^1_$BYTE(LID,LOOPT(5)(15=15) )_^1€€_$DIMENSION LID(10)_^1_$COMMON/A/IEQV(255), IEQVS,IEQVN2_^1_$COMMON /A/ ISTAB(150),ISTABS,ISTAB2_^1_$COMMON /A/ IBUFS,ISET(25),LBLANK,KSFCNT,KSNCNT,ISORSC,_^1_#$IHOBIT,ISTNO,ISSFLG,ISUBPN,ITERM,JSORSC,KEQVS_^1C_#SYMBOL TABLE LABELED COMMON BLOCK_^1_$COMMON /A/ ISYMN, ISYMFL,ISYMD,ISYMX,ISYMS,ISYMP,ISYMPC,ISYMPS,_^1_#$ ISYMNS, SYMTAB(960)_^1_$INTEGER SYMTAB_^1_$BYTE (IDUM,SYMTAB(1)(€€15=15)),(KDUMY,SYMTAB(1)(15=15)),_^1_#$(ICLASS,SYMTAB(1)(14=11)),(ITYPE,SYMTAB(1)(10=9))_^1_$DIMENSION IDUM(100),KDUMY(100),ICLASS(100),ITYPE(100)_^1_$BYTE (ISNGL, SYMTAB(1)(8=8)),(KELSIZ,SYMTAB(1)(8=8)),_^1_#$ (ICOM,SYMTAB(1)(7=5)),(IPART,SYMTAB(1)(4=3))_^1_$DIMENSION ISNGL(100),KELSIZ(100),ICOM(100),IPART(100)_^1_$BYTE (KRFCNT,SYMTAB(1)(2=2)),(IDIM,SYMTAB(1)(1=0)),_^1_#$ (IREL,SY€€MTAB(1)(1=1)),(IEXT,SYMTAB(1)(0=0))_^1_$DIMENSION KRFCNT(100),IDIM(100),IREL(100),IEXT(100)_^1_$EQUIVALENCE (IRSA,SYMTAB(2)),(ICOMTX,SYMTAB(2)),(ISNOL,SYMTAB(2))_^1_$DIMENSION IRSA(100), ICOMTX(100),ISNOL(100)_^1_$BYTE (IDATAS,SYMTAB(3)(15=15)),(IREF,SYMTAB(3)(15=15)),_^1_#$ (IEQVX,SYMTAB(3)(14=8)),(ITILF,SYMTAB(3)(14=8))_^1_$DIMENSION IDATAS(100),IREF(100),IEQVX(100),ITILF(100)_^1€€_$BYTE (IPARTR,SYMTAB(3)(7=4)),(INDUCV,SYMTAB(3)(7=7)),(ISFARG,_^1_#$ SYMTAB(3)(6=6)),(IARGNO,SYMTAB(3)(5=0)),(IPARTL,SYMTAB(3)(3=0))_^1_$DIMENSION IPARTR(100),INDUCV(100),ISFARG(100),IARGNO(100),_^1_#$ IPARTL(100)_^1_$EQUIVALENCE (ISYM,SYMTAB(4))_^1_$DIMENSION ISYM(100)_^1C_]_^1C_#SPECIFICATION-TABLE INDEX LABELLED COMMON BLOCK_^1_$COMMON /A/ ISTABX(96)_^1C_]_^1C_#PHASE A BLANK CO€€MMON BLOCK._^1_$COMMON // JSYM(3),JTERM,JMODE,JERR,JESWT,JFLOT,JCHAR,_^1_#$JOCHAR,JO1,JE,JE1,JBLANK,JCT,JCT1_^1C_#JSYM-JCT1 MUST REMAIN IN ORDER_^1_$COMMON//IERR_^1_$COMMON//ISORS(208),ISORSX_^1_$COMMON//IDEFF,ISTOP,IRET,ISPEC,NERR,OCT_^1_$INTEGER OCT_^1_$COMMON//ILLABL,LEST,ISNGL1,ICOMX1,NXTYPE,LOGIF,IOVFL1,IOVFL2_^1_$COMMON//IVCFLG,ISFLG,LOGEX,KEQVX_^1_$COMMON//IBUF2X,IBUF2(304)_€€^1C_$TEMPORARY ARITHMETIC BUFFERS_^1_$COMMON//IBUF1( 304),IBUF1X,IWORK (304)_^1C_#TEMPORARY EQUIVALENCE BUFFERS_^1_$DIMENSION KEQV(460),MEQV(255)_^1_$EQUIVALENCE (KEQV,IBUF1(66)),(MEQV,IBUF2(100))_^1C_#LS1-ITEM MUST REMAIN IN ORDER_^1_$COMMON//LS1,LPREN,LRELRQ,LRELEN,LSWITC,LO,ITEM_^1_$COMMON//MODE_^1_$COMMON//IPHAT(4),IGNSTT(49),IOSPRT(17)_^1C_]_^1C_]_^1C_]_^1C_#THIS ROUTINE COMPU€€TES THE VALUE OF A CONSTANT SUBSCRIPT._^1_$DIMENSION IDIM1(3)_^1_$IDIM1(1)=1_^1_$IDIM1(2)=1_^1_$IDIM1(3)=1_^1_$IVCFLG=0_^1_$ITEMP1=IDIM(ISYMX)_^1_$I=ISYMX/(2*ISYMFL) +1_^1_$I=ISTABX(I)_^1_$IF (AND(ISYMX,1).EQ.1) I=I/$0100_^1_$ITEMP2=AND(I,$FF)_^1_$ICOUNT=0_^1C_]_^1C_#SET UP COMPUTATION._^1C_]_^1C_]_^1C_#JUMP IF NOT ALL DIMENSIONS HAVE BEEN PROCESSED._^1C_]_^1_"1 ITEMP1=ITEMP1-1_^1_€€"2 IF(ITEMP1.GE.0) GO TO 3_^1_"4 CALL DIAG($57)_^1_"5 IVCFLG=0_^1_$RETURN_^1_"3 CALL GETF_^1C_]_^1C_#JUMP IF FIELD IS A NON-ZERO,POSITIVE INTEGER CONSTANT._^1C_]_^1_$IF(JMODE.EQ.3.AND.JSYM(1).GT.0) GO TO 6_^1_"7 CALL DIAG($2C)_^1_$GO TO 5_^1C_]_^1C_#JUMP IF SUBSCRIPT IS SMALLER THAN OR EQUAL TO DIMENSIONALITY._^1C_]_^1_"6 ITEMP3=ITEMP2+ICOUNT_^1_$IF(JSYM(1).LE.ISTAB(ITEMP3)) GO TO €€8_^1_$CALL DIAG($57)_^1C_]_^1C_#SAVE SUBSCRIPT._^1C_]_^1_"8 IDIM1(ICOUNT+1)=JSYM(1)_^1_$ICOUNT=ICOUNT+1_^1C_]_^1C_#JUMP IF TERMINATOR IS COMA._^1C_]_^1_$IF(JTERM.EQ.43) GO TO 1_^1C_]_^1C_#JUMP IF TERMINATOR IS ) AND ALL DIMENSIONS HAVE BEEN PROCESSED._^1C_]_^1_$IF(JTERM.EQ.42.AND.ITEMP1.EQ.0) GO TO 9_^1_$CALL DIAG($19)_^1_$GO TO 5_^1C_]_^1C_#COMPUTE INCREMENT FROM SUBSCRIPTS._^1C_]€p_^1_"9 IVCFLG=(IDIM1(3)-1)*ISTAB(ITEMP2+1)*ISTAB(ITEMP2)+(IDIM1(2)-1)*_^1_#1ISTAB(ITEMP2)+IDIM1(1)_^1_$END_]_^__pPWDATA CSY/ 31A P€1_$SUBROUTINE DATAPR_^1_#*_2/DECK-ID 31A FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^13_]_^1C DATAPR IS USED IN PHASES A2,A3_^1C_]_^1C_#MASTER LABELED COMMON BLOCK._^1*_] FTN 3.3_^1_$COMMON /A/ IFLAGS,LINECT,LINCT1_^1_$COMMON /A/ IR,IK,IP,IA,IL,IM,IXL€€GO,IOPTO,IOPTV,IOPTC,IOPTD_^1_$COMMON /A/ MCSTRT,MACRNB,MACSEC_^1_$COMMON /A/ IERRS(16),ISRFAD_^1_$COMMON /A/ LGO,ISCRI,ISCRO,IX_^1*_] FTN 3.3_^1_$COMMON /A/ IGLAB(3),IGLAB1,IGLAB2_^1_$COMMON /A/ ICOMT(12),ICOMTS,ICOMX2,ICOMTL,ISUBP,NDPRS,_^1_#$LABX,IBCDTB(48)_^1_$EQUIVALENCE(ICOMB,ICOMT(1)),(ICOMBX,ICOMT(2)),(ICOMDF,_^1_#$ICOMT(3)),(ICOMBN,ICOMT(4))_^1_$DIMENSION ICOMB(6),ICOMBX(€€6),ICOMDF(6),ICOMBN(7)_^1_$COMMON /A/ LOOPTS,LOOPTX,LOOPTB,LOOPT(50)_^1_$EQUIVALENCE(LINDUC,LOOPT(1))_^1_$DIMENSION LINDUC(10)_^1_$EQUIVALENCE (LBEG,LOOPT(2))_^1_$DIMENSION LBEG(10)_^1_$EQUIVALENCE (LINC,LOOPT(3))_^1_$DIMENSION LINC(10)_^1_$EQUIVALENCE (LEND,LOOPT(4))_^1_$DIMENSION LEND(10)_^1_$BYTE(LLABL,LOOPT(5)(14=0)_))_^1_$DIMENSION LLABL(10)_^1_$BYTE(LID,LOOPT(5)(15=15) )_^1€€_$DIMENSION LID(10)_^1_$COMMON/A/IEQV(255), IEQVS,IEQVN2_^1_$COMMON /A/ ISTAB(150),ISTABS,ISTAB2_^1_$COMMON /A/ IBUFS,ISET(25),LBLANK,KSFCNT,KSNCNT,ISORSC,_^1_#$IHOBIT,ISTNO,ISSFLG,ISUBPN,ITERM,JSORSC,KEQVS_^1C_#SYMBOL TABLE LABELED COMMON BLOCK_^1_$COMMON /A/ ISYMN, ISYMFL,ISYMD,ISYMX,ISYMS,ISYMP,ISYMPC,ISYMPS,_^1_#$ ISYMNS, SYMTAB(960)_^1_$INTEGER SYMTAB_^1_$BYTE (IDUM,SYMTAB(1)(€€15=15)),(KDUMY,SYMTAB(1)(15=15)),_^1_#$(ICLASS,SYMTAB(1)(14=11)),(ITYPE,SYMTAB(1)(10=9))_^1_$DIMENSION IDUM(100),KDUMY(100),ICLASS(100),ITYPE(100)_^1_$BYTE (ISNGL, SYMTAB(1)(8=8)),(KELSIZ,SYMTAB(1)(8=8)),_^1_#$ (ICOM,SYMTAB(1)(7=5)),(IPART,SYMTAB(1)(4=3))_^1_$DIMENSION ISNGL(100),KELSIZ(100),ICOM(100),IPART(100)_^1_$BYTE (KRFCNT,SYMTAB(1)(2=2)),(IDIM,SYMTAB(1)(1=0)),_^1_#$ (IREL,SY€€MTAB(1)(1=1)),(IEXT,SYMTAB(1)(0=0))_^1_$DIMENSION KRFCNT(100),IDIM(100),IREL(100),IEXT(100)_^1_$EQUIVALENCE (IRSA,SYMTAB(2)),(ICOMTX,SYMTAB(2)),(ISNOL,SYMTAB(2))_^1_$DIMENSION IRSA(100), ICOMTX(100),ISNOL(100)_^1_$BYTE (IDATAS,SYMTAB(3)(15=15)),(IREF,SYMTAB(3)(15=15)),_^1_#$ (IEQVX,SYMTAB(3)(14=8)),(ITILF,SYMTAB(3)(14=8))_^1_$DIMENSION IDATAS(100),IREF(100),IEQVX(100),ITILF(100)_^1€€_$BYTE (IPARTR,SYMTAB(3)(7=4)),(INDUCV,SYMTAB(3)(7=7)),(ISFARG,_^1_#$ SYMTAB(3)(6=6)),(IARGNO,SYMTAB(3)(5=0)),(IPARTL,SYMTAB(3)(3=0))_^1_$DIMENSION IPARTR(100),INDUCV(100),ISFARG(100),IARGNO(100),_^1_#$ IPARTL(100)_^1_$EQUIVALENCE (ISYM,SYMTAB(4))_^1_$DIMENSION ISYM(100)_^1C_]_^1C_#SPECIFICATION-TABLE INDEX LABELLED COMMON BLOCK_^1_$COMMON /A/ ISTABX(96)_^1C_]_^1C_#PHASE A BLANK CO€€MMON BLOCK._^1_$COMMON // JSYM(3),JTERM,JMODE,JERR,JESWT,JFLOT,JCHAR,_^1_#$JOCHAR,JO1,JE,JE1,JBLANK,JCT,JCT1_^1C_#JSYM-JCT1 MUST REMAIN IN ORDER_^1_$COMMON//IERR_^1_$COMMON//ISORS(208),ISORSX_^1_$COMMON//IDEFF,ISTOP,IRET,ISPEC,NERR,OCT_^1_$INTEGER OCT_^1_$COMMON//ILLABL,LEST,ISNGL1,ICOMX1,NXTYPE,LOGIF,IOVFL1,IOVFL2_^1_$COMMON//IVCFLG,ISFLG,LOGEX,KEQVX_^1_$COMMON//IBUF2X,IBUF2(304)_€€^1C_$TEMPORARY ARITHMETIC BUFFERS_^1_$COMMON//IBUF1( 304),IBUF1X,IWORK (304)_^1C_#TEMPORARY EQUIVALENCE BUFFERS_^1_$DIMENSION KEQV(460),MEQV(255)_^1_$EQUIVALENCE (KEQV,IBUF1(66)),(MEQV,IBUF2(100))_^1C_#LS1-ITEM MUST REMAIN IN ORDER_^1_$COMMON//LS1,LPREN,LRELRQ,LRELEN,LSWITC,LO,ITEM_^1_$COMMON//MODE_^1_$COMMON//IPHAT(4),IGNSTT(49),IOSPRT(17)_^1C_]_^1C_8BEGIN_4***** FTN 3.1 *****_^1C€€_#********BEGIN********** FTN 3.2 *********************************_^1_%INTEGER ASCII(48),ASCIIX(17),IARAY(18)_^1C_#*********************** FTN 3.2 ******END************************_^1_$EQUIVALENCE ( ASCII(1),IBCDTB(1)),(IRPNTR,IARAY(13)),(IRTYPE,_^1_#1IARAY(14)),(NDIM,IARAY(15)),(IA2,IARAY(16)),(IB2,IARAY(17)),(IC2,_^1_#2IARAY(18))_^1C_8END_6***** FTN 3.1 *****_^1C_#********BEGIN*€€********* FTN 3.2 *********************************_^1C_#EXTENDED ASCII CHARACTER TABLE_^1C_#DATA ASCIIX/ '_!!_!"_!#_!%_!%_!:_!;_!<_!>_!?_!@_![_^1_$DATA ASCIIX/$27,$21,$22,$23,$25,$26,$3A,$3B,$3C,$3E,$3F,$40,$5B_^1_#1,$5C,$5D,$5E,$5F/_^1C_"1, \_!]_!^_!_ /_^1C_#*********************** FTN 3.2 ******END************************_^1C_]_^1C_]_^1C_#SET UP READING INTO OUTPUT BUFFER._^1C_€€]_^1_$ITEMP1=5_^1C_8BEGIN_4***** FTN 3.1 *****_^1_$ASSIGN 190 TO JUMPI_^1_$ISCAN=0_^1_$IVBUF=0_^1_"1 LEMNT=0_^1_$IPAREN=0_^1_"5 CALL GETF_^1_$IF(JMODE.NE.0) GO TO 20_^1C_(TERMINATOR LEFT PAREN ?_^1_!10 IF(JTERM.NE.41) GO TO 15_^1_$IPAREN= IPAREN+1_^1_$GO TO 5_^1C_(SYNTAX ERROR_^1_!15 CALL DIAG($19)_^1_$RETURN_^1C_(JUMP IF FIELD IS NOT A NAME._^1_!20 IF(JMODE.NE.2) GO TO 15_^1C_(JUM€€P IF NAME IN SYMBOL TABLE._^1_$IF(ISYMD.NE.0) GO TO 25_^1C_(STORE NAME IN SYMBOL TABLE_^1_$CALL STORE_^1C_(IF NO TYPE USE IMPLICIT TYPE_^1_!25 IF (ITYPE(ISYMX).EQ.0) ITYPE(ISYMX) = JESWT_^1C_(IF UNCLASSIFIED, CLASS AS VARIABLE_^1_$IF (ICLASS(ISYMX).EQ.0) ICLASS(ISYMX) = 1_^1C_;BEGIN_.*** PSR 69*1508 ***_^1C A VARIABLE APPEARING IN A DATA STATEMENT MUST NOT APPEAR IN AN_^1C EXTERNA€€L STATEMENT_^1_$IF(ICLASS(ISYMX).NE.0.OR.(ICLASS(ISYMX).EQ.0.AND._^1_#* IEXT(ISYMX).EQ.0)) GO TO 99_^1_$CALL DIAG (83)_^1_!99 CONTINUE_^1C_;END_0*** PSR 69*1508 ***_^1C_(JUMP IF NAME IS A VARIABLE_^1_$IF (ICLASS(ISYMX).EQ.1.AND.IPART(ISYMX).EQ.0) GO TO 30_^1C_(FIELD MUST BE VARIABLE OR ARRAY NAME_^1_$CALL DIAG($1B)_^1_$GO TO 35_^1C_(JUMP IF NAME NOT IN BLANK COMMON OR DUMMY ARGUME€€NT_^1_!30 IF (ICOM(ISYMX).NE.1.AND.IDUM(ISYMX).EQ.0) GO TO 35_^1C_(BLANK COMMON AND FORMAL ARGUMENTS MAY NOT BE INITIALIZED_^1C_(WITH DATA STATEMENTS._^1_$CALL DIAG($55)_^1_!35 ASSIGN 50 TO JUMPV_^1C_(JUMP IF NAME IS AN ARRAY_^1_$IF (IDIM(ISYMX).NE.0) GO TO 45_^1C_(ONLY AN ARRAY NAME MAY BE IN AN IMPLIED-DO_^1_$IF (IPAREN.EQ.0) GO TO 40_^1_$CALL DIAG ($1D)_^1_$RETURN_^1C_(SKIP ARR€€AY LOGIC IF VARIABLE NAME._^1_!40 ASSIGN 140 TO JUMPV_^1C_#1_!INITIALIZE ARAY DATA TABLE IARAY_^1_!45 DO 46 NDX=1,18_^1_!46 IARAY(NDX) = 1_^1_$LMNTSZ=1_^1_$ISA = 1_^1_$ISB = 1_^1_$ISC = 1_^1C_#SAVE SYMTAB POINTER OF NAME_^1_$IRPNTR = ISYMX+ISYMP_^1_$IRTYPE = ITYPE(ISYMX)_^1_$LMNTSZ = IRTYPE_^1C_#IF INTEGER AND ASA OPTION SET THEN ALLOW 2 WORDS PER ELEMENT_^1_$IF (IRTYPE.EQ.1.AND.IK€€.NE.0.AND.ISNGL(ISYMX).EQ.0) LMNTSZ =2_^1_$NDIM = IDIM(ISYMX)_^1_$IDATAS(ISYMX) = 1_^1_$GO TO JUMPV_^1C_]_^1C_#ARRAY NAME._^1C_(COMPUTE INDEX TO ISTABX_^1_!50 ITMP1 = ISYMX/(2*ISYMFL)+1_^1C_(COMPUTE INDEX TO ISTAB_^1_$ITMP1 = ISTABX(ITMP1)_^1_$IF(AND(ISYMX,1).EQ.1) ITMP1= ITMP1/$100_^1_$ITMP1 = AND(ITMP1,$FF)_^1_$NDX=16_^1_$ITMP2 = NDIM_^1C_(ENTER ARRAY DIMENSION LIMITS_^1_!55 IARA€€Y(NDX) = ISTAB(ITMP1)_^1_$ITMP2=ITMP2-1_^1_$IF(ITMP2.EQ.0) GO TO 60_^1_$NDX=NDX+1_^1_$ITMP1=ITMP1+1_^1_$GO TO 55_^1C_(JUMP IF THIS IS AN IMPLIED-DO_^1_!60 IF (IPAREN .GT.0) GO TO 70_^1C_(JUMP IF AN ARRAY ELEMENT_^1_$IF(JTERM.EQ.41) GO TO 65_^1C_(SET INDUCTION LIMITS FOR NON-SUBSCRIPTED ARRAY NAME_^1_$IARAY(3)=IA2_^1_$IARAY(7)=IB2_^1_$IARAY(11)=IC2_^1_$GO TO 140_^1C_#COMPUTE ARRAY E€€LEMENT CONSTANT SUBSCRIPT_^1_!65 CALL CONSUB_^1_$INCR=IVCFLG_^1_$LEMNT=1_^1_$GO TO 135_^1C_]_^1C_]_^1C_(ANALYSE IMPLIED-DO_^1C_(TERMINATOR = (_^1_!70 IF (JTERM.NE.41) GO TO 15_^1_$IPAREN = IPAREN+1_^1_$NDX=1_^1_$ITMP1=NDIM_^1C_(ANALYSE SUBSCRIPTS OF IMPLIED-DO_^1_!75 CALL GETF_^1_$IF (JMODE.NE.2) GOTO 15_^1_$IF (ISYMD.NE.0) GO TO 80_^1_$CALL STORE_^1_!80 IF (ITYPE(ISYMX).EQ.0) ITYP€€E(ISYMX)=JESWT_^1_$IF (ICLASS(ISYMX).EQ.0) ICLASS(ISYMX) = 1_^1_$IF (ITYPE(ISYMX).EQ.1) GO TO 90_^1C_#SUBSCRIPT VARIABLE MUST BE INTEGER VARIABLE_^1_!85 CALL DIAG($18)_^1_$RETURN_^1C_]_^1_!90 IF (ICLASS(ISYMX).NE.1) GO TO 85_^1C_(SAVE SYMTAB POINTER TO SUBSCRIPT NAME_^1_$IARAY(NDX) = ISYMX+ISYMP_^1_$ITMP1 = ITMP1-1_^1C_(TERMINATOR = )_^1_$IF (JTERM.EQ.42) GO TO 105_^1C_(TERMINATOR.€€NE. , THEN ERROR_^1_$IF (JTERM.NE.43) GO TO 15_^1C_(MORE SUBSCRIPTS THAN DIMENSIONS MEANS ERROR_^1_$IF(ITMP1.GT.0) GO TO 100_^1_!95 CALL DIAG($E)_^1_$RETURN_^1C_]_^1C_(INCREMENT IARAY INDEX_^1 100 NDX=NDX+4_^1_$GO TO 75_^1C_#ERROR IF WRONG NUMBER OF SUBSCRIPTS_^1 105 IF (ITMP1.NE.0) GO TO 95_^1C_(COMPLETED ANALYSING SUBSCRIPTS_^1_$IPAREN =IPAREN-1_^1_$ITMP1 = NDIM_^1_$NDX=1_^1_$I€€TMP2=16_^1C_#ANALYSE INDUCTION VARIABLES OF IMPLIED DO_^1 110 CALL GETC_^1C_(ERROR IF ) NOT FOLLOWED BY ,_^1C_]_^1_$IF (JCHAR.NE.43) GO TO 15_^1_$CALL GETF_^1C_(ERROR IF FIELD TERMINATOR NE TO EQUAL SIGN_^1C ************************************************************_!84*2591_^1C_$SYNTAX ERROR IF NOT AN INDUCTION VARIABLE_^1C_#IF(JTERM.NE.40.OR.JMODE.NE.2) GO TO 15_^1C **********€€**************************************************_!84*2591_^1C_(INDUCTION VARIABLE NAME MUST BE SAME AS SUBSCRIPT_^1_$IF (IARAY(NDX).NE.ISYMX+ISYMP) GO TO 85_^1C_(GET INITIAL VALUE_^1_$CALL GETF_^1C_(TERMINATOR .NE. , MEANS ERROR_^1_$IF (JTERM.NE.43) GO TO 15_^1C_(CONSTANT MUST BE NON-ZERO POSITIVE INTEGER_^1_$IF (JMODE.EQ.3.AND.JSYM(1).GT.0) GO TO 120_^1C_8BEGIN ***PSR 68 * 1542 €€***_^1 115 CALL DIAG ($2C)_^1C_8END_!***PSR 68 * 1542 ***_^1_$RETURN_^1C_]_^1C_]_^1C_#SAVE INITIAL VALUE_^1 120 IARAY(NDX+1) = JSYM(1)_^1C_]_^1C_(GET LIMIT VALUE_^1_$CALL GETF_^1_$IF (JMODE.NE.3.OR.JSYM(1).LE.0) GO TO 115_^1C_(LIMIT MUST NOT BE GT DIMENSION OR LT INITIAL VALUE_^1_$IF (JSYM(1).GT.IARAY(ITMP2).OR.JSYM(1).LT.IARAY(NDX+1)) GO TO 95_^1C_(SAVE LIMIT VALUE_^1_$IARAY(ND€€X+2) = JSYM(1)_^1C_(TERMINATOR MUST BE COMMA OR )_^1_$IF (JTERM.NE.43) GO TO 125_^1C_(GET INCREMENT VALUE_^1_$CALL GETF_^1_$IF (JMODE.NE.3.OR.JSYM(1).LE.0) GO TO 115_^1C_(SAVE INCREMENT VALUE_^1_$IARAY(NDX+3) = JSYM(1)_^1C_(TERMINATOR MUST BE )_^1 125 IF (JTERM.NE.42) GO TO 15_^1_$IPAREN =IPAREN-1_^1_$ITMP1= ITMP1-1_^1C_(JUMP IF FINISHED WITH INDUCTION VARIABLES_^1_$IF (ITMP1.EQ.0€€) GO TO 130_^1_$NDX=NDX+4_^1_$ITMP2 = ITMP2+1_^1_$GO TO 110_^1C_]_^1C_(DO LEFT PARENS MATCH RIGHT PARENS ?_^1 130 IF (IPAREN .EQ.0) GO TO 135_^1C_(UNCLOSED IMPLIED-DO_^1_$CALL DIAG($3D)_^1_$RETURN_^1C_(GET TERMINATOR FOLLOWING ) FOR LATER TESTING_^1 135 CALL GETF_^1_$IF (JMODE.NE.0) GO TO 15_^1C_(TERMINATOR COMMA OR SLASH_^1 140 IF (JTERM.EQ.43.OR.JTERM.EQ.44) GO TO 145_^1C_(SYN€€TAX ERROR_^1_$GO TO 15_^1C_]_^1C_#SAVE SOURCE POINTER TO NEXT FIELD_^1 145 ISRCE1 = ISORSX_^1C_#SAVE TERMINATOR OF CURRENT FIELD_^1_$ITRM1= JTERM_^1C_(INITIALIZE SUBSCRIPTS FOR COMPUTING INCREMENTS WITHIN ARRAY_^1_$ISC = IARAY(10)_^1 150 ISB = IARAY(6)_^1 155 ISA = IARAY(2)_^1C_(JUMP IF THIS ARAY ELEMENT INCREMENT HAS BEEN COMPUTED_^1_$IF (LEMNT.EQ.1) GO TO 165_^1 160 INCR = IA€€2*IB2*(ISC-1) + IA2*(ISB-1) + ISA_^1 165 INCR = INCR*LMNTSZ - LMNTSZ_^1C_(SET ENTRIES INTO OUTPUT BUFFER_^1_$IBUF2(IBUF2X)_!= IRPNTR_^1_$IBUF2(IBUF2X+1) = INCR_^1_$IBUF2(IBUF2X+2) = IRTYPE_^1_$IBUF2X = IBUF2X+IBUF2(IBUF2X+2)+2_^1C_]_^1C_(IS ENOUGH ROOM IN OUTPUT BUFFER FOR NEXT ENTRY ?_^1C ********** PHASE C HAS A 202 WORD MAX FOR BUFFER *********_^1C_(ALLOW 5 CELLS FOR VARIABLE €€OF NEW SET_^1_$IF (IBUF2X+5.LT.197) GO TO 180_^1C_(NOT ENOUGH ROOM SO GO INITIALIZE WITH CONSTANT ELEMENTS_^1C_(THEN OUTPUT THE BUFFER AND CONTINUE._^1C_(SET END OF BUFFER FLAG_^1_$IBUF2(IBUF2X) = -1_^1C_(SET REFILL BUFFER FLAG_^1_$IVBUF = 1_^1C_(SCAN FOR START OF DATA - LOOK FOR /_^1_$IF (ISCAN.EQ.1) GO TO JUMPI_^1C_(TURN OFF SCAN SWITCH_^1_$ISCAN=1_^1C_(DID OUR LAST FIELD TERMINA€€TE WITH A /_^1_$IF(JTERM.EQ.44) GO TO JUMPI_^1C_(EXAMINE NEXT CHARACTER_^1 170 CALL GETC_^1_$IF(JCHAR.EQ.44) GO TO JUMPI_^1C_]_^1C_(IF EOS WE HAVE AN ERROR_^1_$IF (JCHAR.NE.47) GO TO 170_^1_$CALL DIAG ($1030)_^1_$RETURN_^1C_]_^1C_]_^1C_#CLEAR BUFFER REFILL FLAG_^1 175 IVBUF=0_^1C_(RESTORE SOURCE POINTER_^1_$ISORSX=ISRCE1_^1C_(CONTINUE WITH VARIABLE LIST_^1C_]_^1C_(INCREMENT SUBSC€€RIPTS_^1 180 ISA = ISA + IARAY(4)_^1C_(JUMP IF ISA NOT GREATER THAN LIMIT._^1_$IF (ISA.LE.IARAY(3)) GO TO 160_^1_$ISB = ISB+IARAY(8)_^1C_(JUMP IF ISB NOT GREATER THAN LIMIT_^1_$IF (ISB.LE.IARAY(7)) GO TO 155_^1_$ISC = ISC + IARAY(12)_^1C_(JUMP IF ISC NOT GREATER THAN LIMIT_^1_$IF (ISC.LE.IARAY(11)) GO TO 150_^1C_]_^1C_]_^1C_(FINISHED WITH ONE VARIABLE FIELD_^1C_(CHECK FIELD TERMIN€€ATOR FOR COMMA ,_^1_$IF (ITRM1.EQ.43) GO TO 1_^1C_(CHECK TERMINATOR FOR SLASH / ELSE ERROR_^1_$IF (ITRM1.NE.44) GO TO 15_^1C_(SET END OF VARIABLE ENTRIES FLAG_^1_$IBUF2(IBUF2X) = -1_^1_$GO TO JUMPI_^1C_]_^1C_#ENTER CONSTANTS IN OUTPUT FILE_^1C_]_^1C_(SAVE OUTPUT FILE POINTERS_^1 190 ITEMP2 = IBUF2X_^1_$IBUF2X = ITEMP1_^1_$ITEMP1 = ITEMP2_^1C_(SET FLAGS FOR READING ONE CONSTANT_^1 €€ 195 ICOUNT = 1_^1_$IQUOTE = 0_^1 200 CALL GETF_^1C_(JUMP IF TERMINATOR NOT EQUAL TO ASTERISK *_^1_$IF(JTERM.NE.45) GO TO 205_^1C_(REPEAT COUNT_^1C_(JUMP IF CONSTANT NOT INTEGER_^1_$IF (JMODE.NE.3) GO TO 15_^1C_(JUMP IF NOT NON ZERO POSITIVE INTEGER_^1_$IF (JSYM(1).LE.0) GO TO 115_^1_$ICOUNT = JSYM(1)_^1_$CALL GETF_^1 205 IF(JMODE.EQ.6.OR.JMODE.EQ.5.OR.JMODE.EQ.3) GO TO 270_^1_$€€IF(JMODE.EQ.0) GO TO 215_^1C_(ERROR IF FIELD NOT LITERAL OR CONSTANT_^1 210 CALL DIAG($5B)_^1_$GO TO 275_^1C_(BEGINNING OF LITERAL IF JTERM EQUALS QUOTE '_^1 215 IF (JTERM.NE.48) GO TO 265_^1C_]_^1C_(THIS SECTION CONTAINS LITERAL LOGIC_^1C_]_^1C_(SET LITERAL FLAG_^1 220 IQUOTE = 1_^1C_(SAVE SOURCE POINTER FOR REPEATING LITERAL_^1_$ISRCE3 = ISORSX_^1C_(SET SWITCH TO RECOGNIZE BLA€€NKS_^1 225 JBLANK=1_^1C_#GET NEXT CHARACTER TO CHECK FOR SUCCESSIVE QUOTES '' OR PREMATURE_^1C_#********BEGIN********** 1798*74 *********************************_^1C_#EOS_]_^1_$CALL GETC_^1_$IF(JCHAR.NE.48.AND.JCHAR.NE.47) GOTO 230_^1C_#*********************** 1798*74 *********END ********************_^1C_(SET BLANK RECOGNITION SWITCH OFF_^1_$JBLANK = 0_^1_$CALL DIAG($19)_^1_$RET€€URN_^1C_]_^1C_(SET OUTPUTFILE FOR ENTRY OF LITERAL_^1 230 IENTRY = IBUF2(IBUF2X+2)_^1C_(INITIALIZE CHARACTER STORE SWITCH_^1_$KSTOR = 4_^1C_]_^1C_(INITIALIZE CHARACTERS PER ENTRY COUNT_^1_$JCOUNT = IENTRY * 2_^1C_(CONVERT CHARACTER TO ASCII_^1 235 ICHAR = ASCII(JCHAR+1)_^1C_#********BEGIN********** FTN 3.2 *********************************_^1C_$SEE IF CHARACTER IS IN EXTENDED ASC€€II TABLE_^1_$IF (JCHAR.GT.47) ICHAR = ASCIIX(JCHAR-47)_^1C_#*********************** FTN 3.2 ******END************************_^1C_(INCREMENT CHARACTER STORE COUNT_^1_$KSTOR = KSTOR + 1_^1C_(DECREMENT CHARACTERS PER ENTRY COUNT_^1_$JCOUNT = JCOUNT - 1_^1C_(STORE ONE CHARACTER IN OUTPUT FILE_^1_$CALL STCHAR(IBUF2(IBUF2X),KSTOR,ICHAR)_^1C_(GET NEXT CHARACTER_^1_$CALL GETC_^1C_(END OF €€LITERAL IF JCHAR = QUOTE '_^1_$IF (JCHAR.EQ.48) GO TO 250_^1C_#********BEGIN********** 1798*74 *********************************_^1C_'PREMATURE EOS = ERROR_^1_$IF(JCHAR.NE.47) GOTO 240_^1C_#*********************** 1798*74 ********************* END *******_^1_$JBLANK=0_^1_$CALL DIAG($105C)_^1_$RETURN_^1C_]_^1C_(JUMP IF VARIABLE ENTRY NOT FULL_^1 240 IF (JCOUNT.NE.0) GO TO 235_^1_$I€€BUF2X = IBUF2X+IENTRY+2_^1C_(JUMP IF OUTPUT FILE NOT FULL_^1_$IF(IBUF2(IBUF2X).NE.-1) GO TO 230_^1_$JBLANK = 0_^1_$LCHAR = JCHAR_^1_$IBUF2(1) =IBUF2X-1_^1_$ASSIGN 245 TO JUMPI_^1_$GO TO 305_^1C_]_^1C_(RETURNED WITH NEW OUTPUT FILE_^1C_(SET JBLANK TO RECOGNIZE BLANKS_^1 245 JBLANK = 1_^1C_(RESTORE SOURCE POINTER_^1_$ISORSX = ISRCE2_^1_$ITEMP1 = 5_^1_$ITEMP2 = 5_^1_$IBUF2X = 5_^1_$€€JCHAR = LCHAR_^1C_(GO STORE CHARACTER_^1_$GO TO 230_^1C_]_^1C_(LITERAL HAS BEEN PROPERLY TERMINATED_^1C_(IF CURRENT VARIABLE NOT FULL, FILL WITH BLANKS_^1 250 IF (JCOUNT.EQ.0) GO TO 255_^1C_(ICHAR = ASCII BLANK_^1_$ICHAR = $20_^1_$KSTOR = KSTOR+1_^1_$CALL STCHAR(IBUF2(IBUF2X),KSTOR,ICHAR)_^1_$JCOUNT = JCOUNT-1_^1_$GO TO 250_^1C_]_^1C_(DECREMENT REPEAT COUNT_^1 255 ICOUNT = ICOUNT€€-1_^1_$IBUF2X = IBUF2X+IENTRY+2_^1_$JBLANK = 0_^1C_(JUMP IF FINISHED WITH THIS LITERAL-_^1_$IF (ICOUNT.EQ.0) GO TO 260_^1C_(THIS IS A REPEATING LITERAL RESTORE SOURCE POINTER_^1_$ISORSX = ISRCE3_^1C_+SEE IF OUTPUT BUFFER HAS ROOM FOR NEXT ENTRY_^1_$GO TO 300_^1C_(GET TERMINATOR FOLLOWING LITERAL_^1 260 CALL GETF_^1C_(CLEAR LITERAL FLAG_^1_$IQUOTE = 0_^1_$GO TO 300_^1C_]_^1C_(SEE I€€F CONSTANT IS PRECEDED BY SIGN_^1C_(JUMP IF SIGN IS +_^1 265 IF(JTERM.EQ.38) GO TO 200_^1C_(IF SIGN NE - THEN ERROR_^1_$IF(JTERM.NE.39) GO TO 210_^1_$CALL GETF_^1C_(TEST FOR NUMERIC CONSTANT_^1_$IF(JMODE.NE.6.AND.JMODE.NE.5.AND.JMODE.NE.3) GO TO 210_^1C_(COMPLEMENT CONSTANT FOR - SIGN_^1_$JSYM(1) = -JSYM(1)_^1_$JSYM(2) = -JSYM(2)_^1_$JSYM(3) = -JSYM(3)_^1C_]_^1C_(CONSTANT AND VARI€€ABLE MUST BE OF SAME TYPE_^1 270 IF (JMODE.EQ.3.AND.IBUF2(IBUF2X+2).EQ.1.OR.JMODE.EQ.5.AND.IBUF2_^1_#1(IBUF2X+2).EQ.2.OR.JMODE.EQ.6.AND.IBUF2(IBUF2X+2).EQ.3)GO TO 280_^1_$CALL DIAG($32)_^1 275 JSYM(1)=0_^1_$JSYM(2)=0_^1_$JSYM(3)=0_^1C_]_^1C_(STORE CONSTANT_^1 280 IF(IBUF2(IBUF2X+2).NE.3)GO TO 285_^1_$IBUF2(IBUF2X+2)= JSYM(1)_^1_$IBUF2(IBUF2X+3)= JSYM(2)_^1_$IBUF2(IBUF2X+4)= JSYM€€(3)_^1_$IBUF2X = IBUF2X+5_^1_$GO TO 295_^1 285 IF(IBUF2(IBUF2X+2) .NE. 2) GO TO 290_^1_$IBUF2(IBUF2X+2) = JSYM(1)_^1_$IBUF2(IBUF2X+3) = JSYM(2)_^1_$IBUF2X = IBUF2X + 4_^1_$GO TO 295_^1 290 IBUF2(IBUF2X+2) = JSYM(1)_^1_$IBUF2X =IBUF2X + 3_^1C_#DECREMENT REPEAT COUNT_^1 295 ICOUNT = ICOUNT - 1_^1C_(DOES OUTPUT FILE HAVE ROOM FOR NEXT ENTRY_^1 300 IF(IBUF2(IBUF2X).NE.-1) GO TO 330€€_^1_$IBUF2(1)= IBUF2X-1_^1_$ASSIGN 315 TO JUMPI_^1C_(JUMP IF REFILL BUFFER FLAG IS SET_^1 305 IF (IVBUF.NE.0) GO TO 310_^1C_(JUMP IF END OF CONSTANTS_^1_$IF (ICOUNT.EQ.0.AND. JTERM.EQ.44) GO TO 320_^1_$CALL DIAG($2E)_^1_$RETURN_^1C_]_^1C_#SAVE RESTART DATA_^1 310 ISRCE2 = ISORSX_^1_$LTERM = JTERM_^1_$LMODE = JMODE_^1_$LSYM1 = JSYM(1)_^1_$LSYM2 = JSYM(2)_^1_$LSYM3 = JSYM(3)_^€€1C_]_^1_$ITEMP1 = 5_^1_$ITEMP2 = 5_^1_$IBUF2X = 5_^1C_]_^1_$CALL OUTENT(IBUF2)_^1_$GO TO 175_^1C_]_^1C_(RETURN WITH NEW OUTPUT BUFFER_^1C_(RESTORE DATA_^1 315 ISORSX = ISRCE2_^1C_8BEGIN ***PSR 69 * 1561 ***_^1_$IF (IBUF2(5).EQ.-1) GO TO 320_^1C_8END_!***PSR 69 * 1561 ***_^1_$ITEMP1 = 5_^1_$ITEMP2 = 5_^1_$IBUF2X = 5_^1_$JTERM = LTERM_^1_$JMODE = LMODE_^1_$JSYM(1) = LSYM1_^1_$JSYM€€(2) = LSYM2_^1_$JSYM(3) = LSYM3_^1C_(CHECK REPEAT COUNT_^1_$GO TO 330_^1C_]_^1C_(BEGIN NEW SET OF VARIABLES AND CONSTANTS/LITERALS_^1 320 LEMNT = 0_^1_$IPAREN = 0_^1_$ISCAN = 0_^1C_(SAVE POINTER TO BEGINNING OF NEW SET OF VARIABLES_^1_$ITEMP1 = IBUF2X_^1C_(CHECK FIELD TERMINATOR_^1_$CALL GETF_^1_$IF (JMODE.EQ.0) GO TO 325_^1C_(ASSUME MISSING COMMA_^1_$CALL DIAG($1020)_^1_$ASSIGN 1€€90 TO JUMPI_^1_$GO TO 20_^1C_]_^1C_(TERMINATOR EOS_^1C_8BEGIN ***PSR 69 * 1561 ***_^1C IF NO ENTRIES IN IBUF2 CANCEL EXECUTION OF OUTENT_^1 325 IF (JTERM.EQ.47.AND.IBUF2(5).EQ.-1) IERR=1_^1_%IF (JTERM.EQ.47) RETURN_^1C_8END_!***PSR 69 * 1561 ***_^1_$ASSIGN 190 TO JUMPI_^1C_(TERMINATOR A COMMA_^1_$IF (JTERM.EQ.43) GO TO 1_^1C_(ASSUME MISSING COMMA_^1_$CALL DIAG($1020)_^1_$GO TO 10€X_^1C_]_^1C_(CHECK REPEAT COUNT_^1 330 IF (ICOUNT .LE.0) GO TO 335_^1C_(IF IQUOTE SET RETURN TO LITERAL ELSE TO CONSTANT_^1_$IF (IQUOTE.EQ.1) GO TO 225_^1_$GO TO 270_^1C_]_^1C_(TERMINATOR A COMMA_^1 335 IF (JTERM.EQ.43) GO TO 195_^1C_(ERROR IF EOS_^1_$IF (JTERM.NE.47) GO TO 15_^1_$CALL DIAG($1030)_^1C_8END_6***** FTN 3.1 *****_^1_$END_]_^__XPWASGN CSY/ 32A P€1_$SUBROUTINE ASGNPR_^1_#*_2/DECK-ID 32A FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^13_]_^1C ASGNPR IS USED IN PHASE A3_^1C_]_^1C_#MASTER LABELED COMMON BLOCK._^1*_] FTN 3.3_^1_$COMMON /A/ IFLAGS,LINECT,LINCT1_^1_$COMMON /A/ IR,IK,IP,IA,IL,IM,IXLGO,I€€OPTO,IOPTV,IOPTC,IOPTD_^1_$COMMON /A/ MCSTRT,MACRNB,MACSEC_^1_$COMMON /A/ IERRS(16),ISRFAD_^1_$COMMON /A/ LGO,ISCRI,ISCRO,IX_^1*_] FTN 3.3_^1_$COMMON /A/ IGLAB(3),IGLAB1,IGLAB2_^1_$COMMON /A/ ICOMT(12),ICOMTS,ICOMX2,ICOMTL,ISUBP,NDPRS,_^1_#$LABX,IBCDTB(48)_^1_$EQUIVALENCE(ICOMB,ICOMT(1)),(ICOMBX,ICOMT(2)),(ICOMDF,_^1_#$ICOMT(3)),(ICOMBN,ICOMT(4))_^1_$DIMENSION ICOMB(6),ICOMBX(6),I€€COMDF(6),ICOMBN(7)_^1_$COMMON /A/ LOOPTS,LOOPTX,LOOPTB,LOOPT(50)_^1_$EQUIVALENCE(LINDUC,LOOPT(1))_^1_$DIMENSION LINDUC(10)_^1_$EQUIVALENCE (LBEG,LOOPT(2))_^1_$DIMENSION LBEG(10)_^1_$EQUIVALENCE (LINC,LOOPT(3))_^1_$DIMENSION LINC(10)_^1_$EQUIVALENCE (LEND,LOOPT(4))_^1_$DIMENSION LEND(10)_^1_$BYTE(LLABL,LOOPT(5)(14=0)_))_^1_$DIMENSION LLABL(10)_^1_$BYTE(LID,LOOPT(5)(15=15) )_^1_$DI€€MENSION LID(10)_^1_$COMMON/A/IEQV(255), IEQVS,IEQVN2_^1_$COMMON /A/ ISTAB(150),ISTABS,ISTAB2_^1_$COMMON /A/ IBUFS,ISET(25),LBLANK,KSFCNT,KSNCNT,ISORSC,_^1_#$IHOBIT,ISTNO,ISSFLG,ISUBPN,ITERM,JSORSC,KEQVS_^1C_#SYMBOL TABLE LABELED COMMON BLOCK_^1_$COMMON /A/ ISYMN, ISYMFL,ISYMD,ISYMX,ISYMS,ISYMP,ISYMPC,ISYMPS,_^1_#$ ISYMNS, SYMTAB(960)_^1_$INTEGER SYMTAB_^1_$BYTE (IDUM,SYMTAB(1)(15=1€€5)),(KDUMY,SYMTAB(1)(15=15)),_^1_#$(ICLASS,SYMTAB(1)(14=11)),(ITYPE,SYMTAB(1)(10=9))_^1_$DIMENSION IDUM(100),KDUMY(100),ICLASS(100),ITYPE(100)_^1_$BYTE (ISNGL, SYMTAB(1)(8=8)),(KELSIZ,SYMTAB(1)(8=8)),_^1_#$ (ICOM,SYMTAB(1)(7=5)),(IPART,SYMTAB(1)(4=3))_^1_$DIMENSION ISNGL(100),KELSIZ(100),ICOM(100),IPART(100)_^1_$BYTE (KRFCNT,SYMTAB(1)(2=2)),(IDIM,SYMTAB(1)(1=0)),_^1_#$ (IREL,SYMTAB€€(1)(1=1)),(IEXT,SYMTAB(1)(0=0))_^1_$DIMENSION KRFCNT(100),IDIM(100),IREL(100),IEXT(100)_^1_$EQUIVALENCE (IRSA,SYMTAB(2)),(ICOMTX,SYMTAB(2)),(ISNOL,SYMTAB(2))_^1_$DIMENSION IRSA(100), ICOMTX(100),ISNOL(100)_^1_$BYTE (IDATAS,SYMTAB(3)(15=15)),(IREF,SYMTAB(3)(15=15)),_^1_#$ (IEQVX,SYMTAB(3)(14=8)),(ITILF,SYMTAB(3)(14=8))_^1_$DIMENSION IDATAS(100),IREF(100),IEQVX(100),ITILF(100)_^1_$BY€€TE (IPARTR,SYMTAB(3)(7=4)),(INDUCV,SYMTAB(3)(7=7)),(ISFARG,_^1_#$ SYMTAB(3)(6=6)),(IARGNO,SYMTAB(3)(5=0)),(IPARTL,SYMTAB(3)(3=0))_^1_$DIMENSION IPARTR(100),INDUCV(100),ISFARG(100),IARGNO(100),_^1_#$ IPARTL(100)_^1_$EQUIVALENCE (ISYM,SYMTAB(4))_^1_$DIMENSION ISYM(100)_^1C_]_^1C_#SPECIFICATION-TABLE INDEX LABELLED COMMON BLOCK_^1_$COMMON /A/ ISTABX(96)_^1C_]_^1C_#PHASE A BLANK COMMON€€ BLOCK._^1_$COMMON // JSYM(3),JTERM,JMODE,JERR,JESWT,JFLOT,JCHAR,_^1_#$JOCHAR,JO1,JE,JE1,JBLANK,JCT,JCT1_^1C_#JSYM-JCT1 MUST REMAIN IN ORDER_^1_$COMMON//IERR_^1_$COMMON//ISORS(208),ISORSX_^1_$COMMON//IDEFF,ISTOP,IRET,ISPEC,NERR,OCT_^1_$INTEGER OCT_^1_$COMMON//ILLABL,LEST,ISNGL1,ICOMX1,NXTYPE,LOGIF,IOVFL1,IOVFL2_^1_$COMMON//IVCFLG,ISFLG,LOGEX,KEQVX_^1_$COMMON//IBUF2X,IBUF2(304)_^1C_€€$TEMPORARY ARITHMETIC BUFFERS_^1_$COMMON//IBUF1( 304),IBUF1X,IWORK (304)_^1C_#TEMPORARY EQUIVALENCE BUFFERS_^1_$DIMENSION KEQV(460),MEQV(255)_^1_$EQUIVALENCE (KEQV,IBUF1(66)),(MEQV,IBUF2(100))_^1C_#LS1-ITEM MUST REMAIN IN ORDER_^1_$COMMON//LS1,LPREN,LRELRQ,LRELEN,LSWITC,LO,ITEM_^1_$COMMON//MODE_^1_$COMMON//IPHAT(4),IGNSTT(49),IOSPRT(17)_^1C_]_^1C_]_^1C_]_^1C_#THIS ROUTINE PROCESSES€€ ASSIGN STATEMENTS._^1C_]_^1C_]_^1C_#SET ASSIGN FLAG TO ASSIGN FLAG ENCOUNTERED._^1C_]_^1_$CALL RDLABL_^1C_]_^1C_#JUMP IF FIELD IS A LABEL._^1C_]_^1_$IF(ILLABL.NE.0) GO TO 1_^1_$CALL DIAG($46)_^1C_]_^1C_#TRANSLATE STATEMENT INTO A CONTINUE STATEMENT._^1C_]_^1_$RETURN_^1C_]_^1C_#JUMP IF LABEL IS IN SYMBOL TABLE._^1C_]_^1_"1 CALL SYMBOL_^1_$IF(ISYMD.NE.0) GO TO 3_^1C_]_^1C_#STORE LAB€€EL IN SYMBOL TABLE AS A LABEL._^1C_]_^1_$CALL STORE_^1_$ICLASS(ISYMX)=7_^1C_]_^1C_#NOTE THAT ICLAS7(ISYMX) IS ALREAD A ZERO._^1C_]_^1C_]_^1C_#JUMP TO 4 IF NEXT TWO CHARACTERS ARE T AND O AFTER SAVING LABEL._^1C_]_^1_"3 IBUF2(IBUF2X)=ISYMX+ISYMP_^1_$IF(JTERM.NE.29) GO TO 5_^1_$CALL GETC_^1_$IF(JCHAR.EQ.24) GO TO 6_^1_"5 CALL DIAG($19)_^1_$RETURN_^1C_]_^1C_#CHECK FOR INTEGER VARIABLE€Œ_^1C_]_^1_"6 CALL CKNAME_^1C_]_^1C_#STORE VARIABLE IN OUTPUT FILE._^1C_]_^1_$IBUF2(IBUF2X+1)=ISYMX+ISYMP_^1_$IBUF2(1)=IBUF2X+1_^1_$END_]_^__ŒPWBDOPR CSY/ 33A P€1_$SUBROUTINE BDOPR_^1_#*_2/DECK-ID 33A FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^13_]_^1C BDOPR IS USED IN PHASES A3,A5_^1C_]_^1C_#MASTER LABELED COMMON BLOCK._^1*_] FTN 3.3_^1_$COMMON /A/ IFLAGS,LINECT,LINCT1_^1_$COMMON /A/ IR,IK,IP,IA,IL,IM,IXLGO€€,IOPTO,IOPTV,IOPTC,IOPTD_^1_$COMMON /A/ MCSTRT,MACRNB,MACSEC_^1_$COMMON /A/ IERRS(16),ISRFAD_^1_$COMMON /A/ LGO,ISCRI,ISCRO,IX_^1*_] FTN 3.3_^1_$COMMON /A/ IGLAB(3),IGLAB1,IGLAB2_^1_$COMMON /A/ ICOMT(12),ICOMTS,ICOMX2,ICOMTL,ISUBP,NDPRS,_^1_#$LABX,IBCDTB(48)_^1_$EQUIVALENCE(ICOMB,ICOMT(1)),(ICOMBX,ICOMT(2)),(ICOMDF,_^1_#$ICOMT(3)),(ICOMBN,ICOMT(4))_^1_$DIMENSION ICOMB(6),ICOMBX(6)€€,ICOMDF(6),ICOMBN(7)_^1_$COMMON /A/ LOOPTS,LOOPTX,LOOPTB,LOOPT(50)_^1_$EQUIVALENCE(LINDUC,LOOPT(1))_^1_$DIMENSION LINDUC(10)_^1_$EQUIVALENCE (LBEG,LOOPT(2))_^1_$DIMENSION LBEG(10)_^1_$EQUIVALENCE (LINC,LOOPT(3))_^1_$DIMENSION LINC(10)_^1_$EQUIVALENCE (LEND,LOOPT(4))_^1_$DIMENSION LEND(10)_^1_$BYTE(LLABL,LOOPT(5)(14=0)_))_^1_$DIMENSION LLABL(10)_^1_$BYTE(LID,LOOPT(5)(15=15) )_^1_$€€DIMENSION LID(10)_^1_$COMMON/A/IEQV(255), IEQVS,IEQVN2_^1_$COMMON /A/ ISTAB(150),ISTABS,ISTAB2_^1_$COMMON /A/ IBUFS,ISET(25),LBLANK,KSFCNT,KSNCNT,ISORSC,_^1_#$IHOBIT,ISTNO,ISSFLG,ISUBPN,ITERM,JSORSC,KEQVS_^1C_#SYMBOL TABLE LABELED COMMON BLOCK_^1_$COMMON /A/ ISYMN, ISYMFL,ISYMD,ISYMX,ISYMS,ISYMP,ISYMPC,ISYMPS,_^1_#$ ISYMNS, SYMTAB(960)_^1_$INTEGER SYMTAB_^1_$BYTE (IDUM,SYMTAB(1)(15€€=15)),(KDUMY,SYMTAB(1)(15=15)),_^1_#$(ICLASS,SYMTAB(1)(14=11)),(ITYPE,SYMTAB(1)(10=9))_^1_$DIMENSION IDUM(100),KDUMY(100),ICLASS(100),ITYPE(100)_^1_$BYTE (ISNGL, SYMTAB(1)(8=8)),(KELSIZ,SYMTAB(1)(8=8)),_^1_#$ (ICOM,SYMTAB(1)(7=5)),(IPART,SYMTAB(1)(4=3))_^1_$DIMENSION ISNGL(100),KELSIZ(100),ICOM(100),IPART(100)_^1_$BYTE (KRFCNT,SYMTAB(1)(2=2)),(IDIM,SYMTAB(1)(1=0)),_^1_#$ (IREL,SYMT€€AB(1)(1=1)),(IEXT,SYMTAB(1)(0=0))_^1_$DIMENSION KRFCNT(100),IDIM(100),IREL(100),IEXT(100)_^1_$EQUIVALENCE (IRSA,SYMTAB(2)),(ICOMTX,SYMTAB(2)),(ISNOL,SYMTAB(2))_^1_$DIMENSION IRSA(100), ICOMTX(100),ISNOL(100)_^1_$BYTE (IDATAS,SYMTAB(3)(15=15)),(IREF,SYMTAB(3)(15=15)),_^1_#$ (IEQVX,SYMTAB(3)(14=8)),(ITILF,SYMTAB(3)(14=8))_^1_$DIMENSION IDATAS(100),IREF(100),IEQVX(100),ITILF(100)_^1_$€€BYTE (IPARTR,SYMTAB(3)(7=4)),(INDUCV,SYMTAB(3)(7=7)),(ISFARG,_^1_#$ SYMTAB(3)(6=6)),(IARGNO,SYMTAB(3)(5=0)),(IPARTL,SYMTAB(3)(3=0))_^1_$DIMENSION IPARTR(100),INDUCV(100),ISFARG(100),IARGNO(100),_^1_#$ IPARTL(100)_^1_$EQUIVALENCE (ISYM,SYMTAB(4))_^1_$DIMENSION ISYM(100)_^1C_]_^1C_#SPECIFICATION-TABLE INDEX LABELLED COMMON BLOCK_^1_$COMMON /A/ ISTABX(96)_^1C_]_^1C_#PHASE A BLANK COMM€€ON BLOCK._^1_$COMMON // JSYM(3),JTERM,JMODE,JERR,JESWT,JFLOT,JCHAR,_^1_#$JOCHAR,JO1,JE,JE1,JBLANK,JCT,JCT1_^1C_#JSYM-JCT1 MUST REMAIN IN ORDER_^1_$COMMON//IERR_^1_$COMMON//ISORS(208),ISORSX_^1_$COMMON//IDEFF,ISTOP,IRET,ISPEC,NERR,OCT_^1_$INTEGER OCT_^1_$COMMON//ILLABL,LEST,ISNGL1,ICOMX1,NXTYPE,LOGIF,IOVFL1,IOVFL2_^1_$COMMON//IVCFLG,ISFLG,LOGEX,KEQVX_^1_$COMMON//IBUF2X,IBUF2(304)_^1€€C_$TEMPORARY ARITHMETIC BUFFERS_^1_$COMMON//IBUF1( 304),IBUF1X,IWORK (304)_^1C_#TEMPORARY EQUIVALENCE BUFFERS_^1_$DIMENSION KEQV(460),MEQV(255)_^1_$EQUIVALENCE (KEQV,IBUF1(66)),(MEQV,IBUF2(100))_^1C_#LS1-ITEM MUST REMAIN IN ORDER_^1_$COMMON//LS1,LPREN,LRELRQ,LRELEN,LSWITC,LO,ITEM_^1_$COMMON//MODE_^1_$COMMON//IPHAT(4),IGNSTT(49),IOSPRT(17)_^1C_]_^1C_]_^1C_#THIS ROUTINE PROCESSES DO €€STATEMENTS._^1C_#JUMP IF PROCESSING I/O STATEMENTS._^1C_]_^1_$ITEMPX=IVCFLG_^1_$IF(IVCFLG.EQ.(-1))GO TO 4_^1_$CALL RDLABL_^1C_]_^1C_#JUMP IF FIELD IS A LABEL._^1C_]_^1_$IF(ILLABL.NE.0) GO TO 1_^1_"2 CALL DIAG($19)_^1_$RETURN_^1C_]_^1C_#JUMP IF LABEL IS NOT IN SYMBOL TABLE._^1C_]_^1_"1 IF(ISYMD.NE.1) GO TO 3_^1C_]_^1C_#JUMP IF LABEL NOT PREVIOUSLY ENCOUNTERED(DEFINED)._^1_$IF(ISNOL(€€ISYMX).EQ.0.OR.ISNOL(ISYMX).GT.ISTNO)GO TO 4_^1_$CALL DIAG($4E)_^1_$GO TO 5_^1C_]_^1C_#STORE LABEL IN SYMBOL TABLE._^1C_]_^1_"3 CALL STORE_^1_!17 ICLASS(ISYMX)=7_^1C_]_^1C_#JUMP IF NOT TOO MANY NESTED DO LOOPS_^1C_]_^1_"4 IF(LOOPTX+LOOPTB.LE.LOOPTS+1) GO TO 6_^1_$CALL DIAG(79)_^1_$RETURN_^1C_#SET UP PART OF IDOTAB AND LOOPT ENTRIES._^1C_]_^1_"6 LLABL(LOOPTX)=ISYMX+ISYMP_^1_$IF(IVCF€€LG.EQ.(-1))LLABL(LOOPTX)=1_^1_$LID(LOOPTX)=0_^1_"5 ISORSX=ISORSX-1_^1_$CALL CKNAME_^1_$IF(IVCFLG.NE.2)RETURN_^1C_]_^1C_#PRINT DIAGNOSTIC IF RE-DEFINING AN INDUCTION VARIABLE._^1C_]_^1_$IF(INDUCV(ISYMX).NE.0) CALL DIAG($33)_^1_$LINDUC(LOOPTX)=ISYMX+ISYMP_^1C_]_^1C_#JUMP IF TERMINATOR IS EQUAL SIGN._^1C_]_^1_"9 IF(JTERM.EQ.40) GO TO 10_^1_$GO TO 2_^1_!10 CALL CKIVC_^1_$IF(IVCFLG.EQ.0€€)RETURN_^1_$LBEG(LOOPTX)=ISYMX+ISYMP_^1C_]_^1C_#JUMP IF TERMINATOR NOT COMMA._^1C_]_^1_$IF(JTERM.NE.43) GO TO 2_^1_$CALL CKIVC_^1_$IF(IVCFLG.EQ.0)RETURN_^1_$LEND(LOOPTX)=ISYMX+ISYMP_^1C_]_^1C_#JUMP IF EOS._^1C_]_^1_$IF(JTERM.EQ.47.OR.JTERM.EQ.42.AND.ITEMPX.EQ.(-1)) GO TO 16_^1C_]_^1C_#JUMP IF NOT COMMA._^1C_]_^1_$IF(JTERM.NE.43) GO TO 2_^1_$ITEMP1=ISORSX_^1_$CALL GETC_^1C_]_^1C_#JU€€MP IF CHARACTER IS NOT A MINUS SIGN._^1C_]_^1_$IF(JCHAR.NE.39) GO TO 13_^1_$LID(LOOPTX)=1_^1_$GO TO 12_^1_!16 LINC(LOOPTX)=ISET(1)_^1_$GO TO 14_^1_!13 ISORSX=ITEMP1_^1_!12 CALL CKIVC_^1_$IF(IVCFLG.EQ.0)RETURN_^1C_]_^1C_#JUMP IF FIELD NOT INTEGER VARIABLE OR CONSTANT._^1C_]_^1_$LINC(LOOPTX)=ISYMX+ISYMP_^1_!14 DO 140 I=1,LOOPTB_^1_$J= LOOPTX+I-1_^1_$IBUF2(IBUF2X)=LOOPT(J)_^1 140 I€€BUF2X=IBUF2X+1_^1_$IBUF2(1)=IBUF2X-1_^1C_#RETURN IF TERMINATOR EOS._^1C_]_^1_$IF(JTERM.EQ.47.OR.JTERM.EQ.42.AND.ITEMPX.EQ.(-1))GO TO 2000_^1_$GO TO 2_^1 2000 ISYMX=LINC(LOOPTX)_^1_$CALL GETSYM_^1_$INDUCV(ISYMX)=1_^1_$ISYMX=LEND(LOOPTX)_^1_$CALL GETSYM_^1_$INDUCV(ISYMX)=1_^1_$ISYMX=LBEG(LOOPTX)_^1_$CALL GETSYM_^1_$INDUCV(ISYMX)=1_^1_$ISYMX=LINDUC(LOOPTX)_^1_$CALL GETSYM_^1_$INDUCV(I€.SYMX)=1_^1_$LOOPTX=LOOPTX+LOOPTB_^1_$END_]_^__.PWCFVOC CSY/ 34A P€1_$SUBROUTINE CFIVOC_^1_#*_2/DECK-ID 34A FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^13_]_^1C CFIVOC IS USED IN PHASES A1,A2,A3,A4,A5_^1C_]_^1C_]_^1C_#MASTER LABELED COMMON BLOCK._^1*_] FTN 3.3_^1_$COMMON /A/ IFLAGS,LINECT,LINCT1_^1_$COMMON /A/ IR,IK,€€IP,IA,IL,IM,IXLGO,IOPTO,IOPTV,IOPTC,IOPTD_^1_$COMMON /A/ MCSTRT,MACRNB,MACSEC_^1_$COMMON /A/ IERRS(16),ISRFAD_^1_$COMMON /A/ LGO,ISCRI,ISCRO,IX_^1*_] FTN 3.3_^1_$COMMON /A/ IGLAB(3),IGLAB1,IGLAB2_^1_$COMMON /A/ ICOMT(12),ICOMTS,ICOMX2,ICOMTL,ISUBP,NDPRS,_^1_#$LABX,IBCDTB(48)_^1_$EQUIVALENCE(ICOMB,ICOMT(1)),(ICOMBX,ICOMT(2)),(ICOMDF,_^1_#$ICOMT(3)),(ICOMBN,ICOMT(4))_^1_$DIMENSION I€€COMB(6),ICOMBX(6),ICOMDF(6),ICOMBN(7)_^1_$COMMON /A/ LOOPTS,LOOPTX,LOOPTB,LOOPT(50)_^1_$EQUIVALENCE(LINDUC,LOOPT(1))_^1_$DIMENSION LINDUC(10)_^1_$EQUIVALENCE (LBEG,LOOPT(2))_^1_$DIMENSION LBEG(10)_^1_$EQUIVALENCE (LINC,LOOPT(3))_^1_$DIMENSION LINC(10)_^1_$EQUIVALENCE (LEND,LOOPT(4))_^1_$DIMENSION LEND(10)_^1_$BYTE(LLABL,LOOPT(5)(14=0)_))_^1_$DIMENSION LLABL(10)_^1_$BYTE(LID,LOOPT(€€5)(15=15) )_^1_$DIMENSION LID(10)_^1_$COMMON/A/IEQV(255), IEQVS,IEQVN2_^1_$COMMON /A/ ISTAB(150),ISTABS,ISTAB2_^1_$COMMON /A/ IBUFS,ISET(25),LBLANK,KSFCNT,KSNCNT,ISORSC,_^1_#$IHOBIT,ISTNO,ISSFLG,ISUBPN,ITERM,JSORSC,KEQVS_^1C_#SYMBOL TABLE LABELED COMMON BLOCK_^1_$COMMON /A/ ISYMN, ISYMFL,ISYMD,ISYMX,ISYMS,ISYMP,ISYMPC,ISYMPS,_^1_#$ ISYMNS, SYMTAB(960)_^1_$INTEGER SYMTAB_^1_$BYTE (€€IDUM,SYMTAB(1)(15=15)),(KDUMY,SYMTAB(1)(15=15)),_^1_#$(ICLASS,SYMTAB(1)(14=11)),(ITYPE,SYMTAB(1)(10=9))_^1_$DIMENSION IDUM(100),KDUMY(100),ICLASS(100),ITYPE(100)_^1_$BYTE (ISNGL, SYMTAB(1)(8=8)),(KELSIZ,SYMTAB(1)(8=8)),_^1_#$ (ICOM,SYMTAB(1)(7=5)),(IPART,SYMTAB(1)(4=3))_^1_$DIMENSION ISNGL(100),KELSIZ(100),ICOM(100),IPART(100)_^1_$BYTE (KRFCNT,SYMTAB(1)(2=2)),(IDIM,SYMTAB(1)(1=0)),€€_^1_#$ (IREL,SYMTAB(1)(1=1)),(IEXT,SYMTAB(1)(0=0))_^1_$DIMENSION KRFCNT(100),IDIM(100),IREL(100),IEXT(100)_^1_$EQUIVALENCE (IRSA,SYMTAB(2)),(ICOMTX,SYMTAB(2)),(ISNOL,SYMTAB(2))_^1_$DIMENSION IRSA(100), ICOMTX(100),ISNOL(100)_^1_$BYTE (IDATAS,SYMTAB(3)(15=15)),(IREF,SYMTAB(3)(15=15)),_^1_#$ (IEQVX,SYMTAB(3)(14=8)),(ITILF,SYMTAB(3)(14=8))_^1_$DIMENSION IDATAS(100),IREF(100),IEQVX(100€€),ITILF(100)_^1_$BYTE (IPARTR,SYMTAB(3)(7=4)),(INDUCV,SYMTAB(3)(7=7)),(ISFARG,_^1_#$ SYMTAB(3)(6=6)),(IARGNO,SYMTAB(3)(5=0)),(IPARTL,SYMTAB(3)(3=0))_^1_$DIMENSION IPARTR(100),INDUCV(100),ISFARG(100),IARGNO(100),_^1_#$ IPARTL(100)_^1_$EQUIVALENCE (ISYM,SYMTAB(4))_^1_$DIMENSION ISYM(100)_^1C_]_^1C_#SPECIFICATION-TABLE INDEX LABELLED COMMON BLOCK_^1_$COMMON /A/ ISTABX(96)_^1C_]_^1C_#P€€HASE A BLANK COMMON BLOCK._^1_$COMMON // JSYM(3),JTERM,JMODE,JERR,JESWT,JFLOT,JCHAR,_^1_#$JOCHAR,JO1,JE,JE1,JBLANK,JCT,JCT1_^1C_#JSYM-JCT1 MUST REMAIN IN ORDER_^1_$COMMON//IERR_^1_$COMMON//ISORS(208),ISORSX_^1_$COMMON//IDEFF,ISTOP,IRET,ISPEC,NERR,OCT_^1_$INTEGER OCT_^1_$COMMON//ILLABL,LEST,ISNGL1,ICOMX1,NXTYPE,LOGIF,IOVFL1,IOVFL2_^1_$COMMON//IVCFLG,ISFLG,LOGEX,KEQVX_^1_$COMMON//IBU€€F2X,IBUF2(304)_^1C_$TEMPORARY ARITHMETIC BUFFERS_^1_$COMMON//IBUF1( 304),IBUF1X,IWORK (304)_^1C_#TEMPORARY EQUIVALENCE BUFFERS_^1_$DIMENSION KEQV(460),MEQV(255)_^1_$EQUIVALENCE (KEQV,IBUF1(66)),(MEQV,IBUF2(100))_^1C_#LS1-ITEM MUST REMAIN IN ORDER_^1_$COMMON//LS1,LPREN,LRELRQ,LRELEN,LSWITC,LO,ITEM_^1_$COMMON//MODE_^1_$COMMON//IPHAT(4),IGNSTT(49),IOSPRT(17)_^1C_]_^1C_]_^1C_]_^1C_#THI€€S ROUTINE READS THE NEXT FIELD AND TESTS IT FOR BEING AN_^1C_#INTEGER CONSTANT OR AN INTEGER VARIABLE._^1C_]_^1C_#SET FLAG TO NEITHER INTEGER VARIABLE NOR INTEGER CONSTANT._^1C_]_^1_$IVCFLG=0_^1_$CALL GETF_^1C_]_^1C_#RETURN IF NOT NAME OR INTEGER CONSTANT_^1C_]_^1_$IF(.NOT.(JMODE.EQ.2.OR.JMODE.EQ.3)) RETURN_^1C_]_^1C_#JUMP IF FIELD NOT IN SYMBOL TABLE._^1C_]_^1_$IF(ISYMD.EQ.0) GO T€€O 1_^1C_]_^1C_#RETURN IF SYMBOL IN SYMBOL TABLE NOT INTEGER VARIABLE OR CONSTANT._^1C_]_^1_$IF(ITYPE(ISYMX).GE.2.OR.ICLASS(ISYMX).GE.3.OR.IDIM(ISYMX).NE.0)_^1_#1RETURN_^1_$IF(IPART(ISYMX).NE.0)RETURN_^1_$GO TO 2_^1C_#PRINT DIAGNOSTIC IF MUST ASSUME INTEGER._^1C_]_^1_"1 IF(JMODE.EQ.2.AND.JESWT.NE.1) CALL DIAG($2040)_^1C_]_^1C_#STORE FIELD IN SYMBOL TABLE._^1C_]_^1_$CALL STORE_^1_"2 €bITYPE(ISYMX) = 1_^1_$ICLASS(ISYMX)=JMODE-1_^1_$IVCFLG = 2_^1_$IF(JMODE.EQ.3)IVCFLG=1_^1_$END_]_^__bPWCKVC CSY/ 35A P€1_$SUBROUTINE CKIVC_^1_#*_2/DECK-ID 35A FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^13_]_^1C CFIVC IS USED IN PHASES A3,A5_^1C_]_^1C_]_^1C_#PHASE A BLANK COMMON BLOCK._^1_$COMMON // JSYM(3),JTERM,JMODE,JERR,JESWT,JFLOT,JCHAR,_^1_#$JOCHAR,JO1,JE,JE1,JBL€€ANK,JCT,JCT1_^1C_#JSYM-JCT1 MUST REMAIN IN ORDER_^1_$COMMON//IERR_^1_$COMMON//ISORS(208),ISORSX_^1_$COMMON//IDEFF,ISTOP,IRET,ISPEC,NERR,OCT_^1_$INTEGER OCT_^1_$COMMON//ILLABL,LEST,ISNGL1,ICOMX1,NXTYPE,LOGIF,IOVFL1,IOVFL2_^1_$COMMON//IVCFLG,ISFLG,LOGEX,KEQVX_^1_$COMMON//IBUF2X,IBUF2(304)_^1C_$TEMPORARY ARITHMETIC BUFFERS_^1_$COMMON//IBUF1( 304),IBUF1X,IWORK (304)_^1C_#TEMPORARY EQUI€€VALENCE BUFFERS_^1_$DIMENSION KEQV(460),MEQV(255)_^1_$EQUIVALENCE (KEQV,IBUF1(66)),(MEQV,IBUF2(100))_^1C_#LS1-ITEM MUST REMAIN IN ORDER_^1_$COMMON//LS1,LPREN,LRELRQ,LRELEN,LSWITC,LO,ITEM_^1_$COMMON//MODE_^1_$COMMON//IPHAT(4),IGNSTT(49),IOSPRT(17)_^1C_]_^1C_]_^1C_]_^1C_#THIS ROUTINE CHECKS FOR A FIELD BEING AN INTEGER VARIABLE OR_^1C_#CONSTANT._^1_$CALL CFIVOC_^1C_]_^1C_#RETURN IF I€XNTEGER VARIABLE OR CONSTANT._^1_$IF(IVCFLG.NE.0) RETURN_^1_$CALL DIAG(63)_^1_$END_]_^__ XPWCKNAM CSY/ 36A P€1_$SUBROUTINE CKNAME_^1_#*_2/DECK-ID 36A FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^13_]_^1C CKNAME IS USED IN PHASES A1,A2,A3,A4,A5_^1C_]_^1C_#PHASE A BLANK COMMON BLOCK._^1_$COMMON // JSYM(3),JTERM,JMODE,JERR,JESWT,JFLOT,JCHAR,_^1_#$JOCHAR,JO1,JE,JE€€1,JBLANK,JCT,JCT1_^1C_#JSYM-JCT1 MUST REMAIN IN ORDER_^1_$COMMON//IERR_^1_$COMMON//ISORS(208),ISORSX_^1_$COMMON//IDEFF,ISTOP,IRET,ISPEC,NERR,OCT_^1_$INTEGER OCT_^1_$COMMON//ILLABL,LEST,ISNGL1,ICOMX1,NXTYPE,LOGIF,IOVFL1,IOVFL2_^1_$COMMON//IVCFLG,ISFLG,LOGEX,KEQVX_^1_$COMMON//IBUF2X,IBUF2(304)_^1C_$TEMPORARY ARITHMETIC BUFFERS_^1_$COMMON//IBUF1( 304),IBUF1X,IWORK (304)_^1C_#TEMPORARY€€ EQUIVALENCE BUFFERS_^1_$DIMENSION KEQV(460),MEQV(255)_^1_$EQUIVALENCE (KEQV,IBUF1(66)),(MEQV,IBUF2(100))_^1C_#LS1-ITEM MUST REMAIN IN ORDER_^1_$COMMON//LS1,LPREN,LRELRQ,LRELEN,LSWITC,LO,ITEM_^1_$COMMON//MODE_^1_$COMMON//IPHAT(4),IGNSTT(49),IOSPRT(17)_^1C_]_^1C_]_^1C_]_^1C_#THIS ROUTINE CHECKS A FIELD FOR BEING AN INTEGER VARIABLE._^1_$CALL CFIVOC_^1C_]_^1C_#RETURN IF FIELD INTEGER€L VARIABLE._^1C_]_^1_$IF(IVCFLG.EQ.2) RETURN_^1_$CALL DIAG($40)_^1_$END_]_^__LPWIOSPR CSY/ 37A P€1_$SUBROUTINE IOSPR_^1_#*_2/DECK-ID 37A FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^13_]_^1C IOSPR IS USED IN PHASE A5_^1C BIT 4 OF 'IFLAGS' IS SET TO 1 BEFORE CALLING 'ARITH'._^1C_]_^1C_#MASTER LABELED COMMON BLOCK._^1*_] FTN 3.3_^1_$COMMON /A/ IFLAG€€S,LINECT,LINCT1_^1_$COMMON /A/ IR,IK,IP,IA,IL,IM,IXLGO,IOPTO,IOPTV,IOPTC,IOPTD_^1_$COMMON /A/ MCSTRT,MACRNB,MACSEC_^1_$COMMON /A/ IERRS(16),ISRFAD_^1_$COMMON /A/ LGO,ISCRI,ISCRO,IX_^1*_] FTN 3.3_^1_$COMMON /A/ IGLAB(3),IGLAB1,IGLAB2_^1_$COMMON /A/ ICOMT(12),ICOMTS,ICOMX2,ICOMTL,ISUBP,NDPRS,_^1_#$LABX,IBCDTB(48)_^1_$EQUIVALENCE(ICOMB,ICOMT(1)),(ICOMBX,ICOMT(2)),(ICOMDF,_^1_#$ICOMT(€€3)),(ICOMBN,ICOMT(4))_^1_$DIMENSION ICOMB(6),ICOMBX(6),ICOMDF(6),ICOMBN(7)_^1_$COMMON /A/ LOOPTS,LOOPTX,LOOPTB,LOOPT(50)_^1_$EQUIVALENCE(LINDUC,LOOPT(1))_^1_$DIMENSION LINDUC(10)_^1_$EQUIVALENCE (LBEG,LOOPT(2))_^1_$DIMENSION LBEG(10)_^1_$EQUIVALENCE (LINC,LOOPT(3))_^1_$DIMENSION LINC(10)_^1_$EQUIVALENCE (LEND,LOOPT(4))_^1_$DIMENSION LEND(10)_^1_$BYTE(LLABL,LOOPT(5)(14=0)_))_^1_$DIM€€ENSION LLABL(10)_^1_$BYTE(LID,LOOPT(5)(15=15) )_^1_$DIMENSION LID(10)_^1_$COMMON/A/IEQV(255), IEQVS,IEQVN2_^1_$COMMON /A/ ISTAB(150),ISTABS,ISTAB2_^1_$COMMON /A/ IBUFS,ISET(25),LBLANK,KSFCNT,KSNCNT,ISORSC,_^1_#$IHOBIT,ISTNO,ISSFLG,ISUBPN,ITERM,JSORSC,KEQVS_^1C_#SYMBOL TABLE LABELED COMMON BLOCK_^1_$COMMON /A/ ISYMN, ISYMFL,ISYMD,ISYMX,ISYMS,ISYMP,ISYMPC,ISYMPS,_^1_#$ ISYMNS, SYMT€€AB(960)_^1_$INTEGER SYMTAB_^1_$BYTE (IDUM,SYMTAB(1)(15=15)),(KDUMY,SYMTAB(1)(15=15)),_^1_#$(ICLASS,SYMTAB(1)(14=11)),(ITYPE,SYMTAB(1)(10=9))_^1_$DIMENSION IDUM(100),KDUMY(100),ICLASS(100),ITYPE(100)_^1_$BYTE (ISNGL, SYMTAB(1)(8=8)),(KELSIZ,SYMTAB(1)(8=8)),_^1_#$ (ICOM,SYMTAB(1)(7=5)),(IPART,SYMTAB(1)(4=3))_^1_$DIMENSION ISNGL(100),KELSIZ(100),ICOM(100),IPART(100)_^1_$BYTE (KRFCNT,S€€YMTAB(1)(2=2)),(IDIM,SYMTAB(1)(1=0)),_^1_#$ (IREL,SYMTAB(1)(1=1)),(IEXT,SYMTAB(1)(0=0))_^1_$DIMENSION KRFCNT(100),IDIM(100),IREL(100),IEXT(100)_^1_$EQUIVALENCE (IRSA,SYMTAB(2)),(ICOMTX,SYMTAB(2)),(ISNOL,SYMTAB(2))_^1_$DIMENSION IRSA(100), ICOMTX(100),ISNOL(100)_^1_$BYTE (IDATAS,SYMTAB(3)(15=15)),(IREF,SYMTAB(3)(15=15)),_^1_#$ (IEQVX,SYMTAB(3)(14=8)),(ITILF,SYMTAB(3)(14=8))_^1_$DIME€€NSION IDATAS(100),IREF(100),IEQVX(100),ITILF(100)_^1_$BYTE (IPARTR,SYMTAB(3)(7=4)),(INDUCV,SYMTAB(3)(7=7)),(ISFARG,_^1_#$ SYMTAB(3)(6=6)),(IARGNO,SYMTAB(3)(5=0)),(IPARTL,SYMTAB(3)(3=0))_^1_$DIMENSION IPARTR(100),INDUCV(100),ISFARG(100),IARGNO(100),_^1_#$ IPARTL(100)_^1_$EQUIVALENCE (ISYM,SYMTAB(4))_^1_$DIMENSION ISYM(100)_^1C_]_^1C_#SPECIFICATION-TABLE INDEX LABELLED COMMON BLOCK_^€€1_$COMMON /A/ ISTABX(96)_^1C_]_^1C_#PHASE A BLANK COMMON BLOCK._^1_$COMMON // JSYM(3),JTERM,JMODE,JERR,JESWT,JFLOT,JCHAR,_^1_#$JOCHAR,JO1,JE,JE1,JBLANK,JCT,JCT1_^1C_#JSYM-JCT1 MUST REMAIN IN ORDER_^1_$COMMON//IERR_^1_$COMMON//ISORS(208),ISORSX_^1_$COMMON//IDEFF,ISTOP,IRET,ISPEC,NERR,OCT_^1_$INTEGER OCT_^1_$COMMON//ILLABL,LEST,ISNGL1,ICOMX1,NXTYPE,LOGIF,IOVFL1,IOVFL2_^1_$COMMON//IVC€€FLG,ISFLG,LOGEX,KEQVX_^1_$COMMON//IBUF2X,IBUF2(304)_^1C_$TEMPORARY ARITHMETIC BUFFERS_^1_$COMMON//IBUF1( 304),IBUF1X,IWORK (304)_^1C_#TEMPORARY EQUIVALENCE BUFFERS_^1_$DIMENSION KEQV(460),MEQV(255)_^1_$EQUIVALENCE (KEQV,IBUF1(66)),(MEQV,IBUF2(100))_^1C_#LS1-ITEM MUST REMAIN IN ORDER_^1_$COMMON//LS1,LPREN,LRELRQ,LRELEN,LSWITC,LO,ITEM_^1_$COMMON//MODE_^1C_]_^1C COMMON FOR LOCAL VARIA€€BLES OF 'PHASEA' AND 'GNST'..._^1_$COMMON//IPHAT(4),IHED(48),LENSAV_^1C COMMON FOR LOCAL VARIABLES OF 'IOSPR'..._^1_$COMMON//JDIM(3),M,IPAREN,KBITW,KBITR,KBITF,IAD,ITYC,ITEMP1,_^1_#1 ITEMP3,IGO3,ITEMP4,J,ITEMPB,K2WRDS_^1_$EXTERNAL LOCAL_^1C_]_^1C_]_^1C_#THIS ROUTINE PROCESSES READ AND WRITE STATEMENTS._^1_$DIMENSION IPARM(9)_^1_$DATA IPARM(1),IPARM(2),IPARM(3)/$1A08,$1A21,$012B/_^1€€_$DATA IPARM(4),IPARM(5),IPARM(6)/$1A08,$1A21,$022B/_^1_$DATA IPARM(7),IPARM(8),IPARM(9)/$1A08,$1A21,$032B/_^1_$DIMENSION IHEAD(4)_^1_$DATA IHEAD(1),IHEAD(2),IHEAD(3),IHEAD(4) /$1A08,$1A21,$292E,$1A22/_^1C_]_^1C_#ALL NEW STATEMENTS ADDED FOR DISK USE N INSTEAD OF IBUF2X_^1_$EQUIVALENCE (IBUF2X, N)_^1C_]_^1C_#SET PARENTHESIS COUNT TO ZERO._^1C_]_^1_$IPAREN=0_^1C_]_^1C_#SET FLAG BITS€€ TO ZERO. NOT ON 1700._^1C_]_^1_$KBITW=0_^1_$KBITR=0_^1_$KBITL=0_^1_$KBITF=0_^1_$KBITFF=0_^1_$KBITU=0_^1_$M =0_]_^1_$IDISK =0_^1_$IRECN =0_^1_$IPARC =0_^1C_]_^1C USE UNNEEDED WORDS OF 'ISORS' FOR TEMPORARIES._^1_$ISORS(1)=IBUF2(2)_^1_$ISORS(2)=IBUF2(5)_^1C_#JUMP IF A READ STATEMENT._^1C_]_^1_$IF(IBUF2(3).EQ.36) GO TO 2_^1_$IF(IBUF2(3).EQ.45) GOTO 100_^1_$KBITW=1_^1_$GO TO 3_^1_"2 €€KBITR=1_^1C_#PARTIALLY SET UP A CALL TREE TO Q8QINI._^1_"3 IBUF2(3)=21_^1_$IBUF2(IBUF2X+3)=21_^1_$IBUF2(IBUF2X)=-1_^1_$IBUF2(IBUF2X+2)=0_^1_$IBUF2(IBUF2X+10)=0_^1_$IBUF2(IBUF2X+13)=0_^1_$IBUF2(IBUF2X+16)=0_^1_$IBUF2(IBUF2X+19)=0_^1_$IBUF2(IBUF2X+20)=24_^1_$IBUF2(IBUF2X+11)=37_^1_$IBUF2(IBUF2X+14)=37_^1_$IBUF2(IBUF2X+4)=ISET(5)_^1_$IBUF2(IBUF2X+15)=ISTNO_^1_$CALL GETF_^1C_#JUMP IF F€€IELD NUL AND TERMINATOR IS LEFT PAREN._^1_$IF(JMODE.EQ.0.AND.JTERM.EQ.41) GO TO 4_^1C_#ERROR. PRINT DIAGNOSTIC AND RETURN._^1C DIAG 25 WITHOUT ISORS BUFFER_^1 5_#CALL DIAG($1019)_^1_$GO TO 51_^1C --- THE FOLLOWING SECTION PROCESSES 'OPEN' STATEMENTS. ---_^1 100 IBUF2(N) = -1_^1_$IBUF2(3)=21_^1_$IBUF2(N+1) = 27_^1_$IBUF2(N+2)= 0_^1_$IBUF2(N+3)= 21_^1_$IBUF2(N+4)= ISET(25)_^1_$IBUF€€2(N+5) = 6_^1_$IBUF2(N+6) = 24_^1_$IBUF2 (N+7) = 21_^1_$IBUF2(N+8) = 18_^1_$IBUF2(N+9) = 15_^1_$IBUF2(N+10) = 12_^1_$IBUF2(N+11) = 9_^1_$M = M+N+12_^1_$IBUF2(M) = 0_^1_$IBUF2(M+1) = 37_^1_$IBUF2(M+2) = ISTNO_^1_$M=M+3_^1 102 ITYC = 35_^1_$ASSIGN 103 TO IAD_^1_$GO TO 150_^1 103 IF(JTERM.NE.47) GOTO 105_^1_$IF(IPARC.NE.5) GOTO 106_^1_$IF(IDEFF.EQ.1) GOTO 5_^1_$IDEFF = 2_^1 104 I€€BUF2(1) = N + 30_^1_$ASSIGN 51 TO IGO3_^1_$GO TO 900_^1 105 IF (JTERM.NE.43) GOTO 5_^1_$GOTO 102_^1 106 IF(IPARC.NE.4.OR.IDEFF.EQ.2) GOTO 5_^1_$IDEFF =1_^1_$IBUF2(N+27) = 0_^1_$IBUF2(N+28) = 35_^1_$JSYM(1) =0_^1_$JSYM(2) =0_^1_$JSYM(3) = 9252_^1_$CALL SYMBOL_^1_$IF(ISYMD.EQ.0) CALL STORE_^1_$IBUF2(N+29) = ISYMX + ISYMP_^1_$GOTO 104_^1 150 CALL CKIVC_^1 151 IRECN =0_^1_$IF (IVC€€FLG.EQ.0) GOTO 51_^1_$IBUF2(M) =0_^1_$IF (IVCFLG.EQ.1) GOTO 152_^1_$IBUF2(M+1) =24_^1_$IBUF2(M+2) = ISYMX + ISYMP_^1_$GOTO 153_^1 152 IBUF2(M+1) = ITYC_^1_$IBUF2(M+2) = JSYM(1)_^1_$IF(ITYC.EQ.35)IBUF2(M+2) = ISYMX +ISYMP_^1_$IRECN =1_^1 153 M= M +3_^1_$IPARC = IPARC +1_^1_$GO TO IAD_^1C --- THIS IS THE END OF THE 'OPEN' STATEMENT PROCESSING. ---_^1_"4 CALL CKIVC_^1_$IF(JTERM.EQ.4€€1) GOTO 56_^1C_#RETURN IF FIELD NOT INTEGER VARIABLE OR CONSTANT. ERROR._^1_$IF(IVCFLG.EQ.0)GO TO 51_^1C_#JUMP IF FIELD WAS AN INTEGER._^1_$IF(IVCFLG.EQ.1) GO TO 6_^1_$IBUF2(IBUF2X+17)=24_^1_$IBUF2(IBUF2X+18)=ISYMX+ISYMP_^1_$GO TO 7_^156_"IDISK=1_^1_$M=N+17_^1_$ITYC=37_^1_$ASSIGN 57 TO IAD_^1_$GO TO 151_^1_!57 KBITU=IRECN_^1_$CALL CKIVC_^1_$IF(JTERM.NE.42) GO TO 5_^1_$M=N+20_^1_$I€€TYC=37_^1_$ASSIGN 58 TO IAD_^1_$GO TO 151_^1_!58 CALL GETF_^1C_#RESET DISK PARAMETERS IN TREE_^1_$IBUF2 (N+11) = 0_^1_$IBUF2 (N+12) = 37_^1_$IBUF2 (N+14) = 0_^1_$IBUF2 (N+15) = 37_^1_$IBUF2 (N+16) = ISTNO_^1_$IBUF2 (N+23) = 0_^1_$IBUF2 (N+24) = 24_^1_$IF(JTERM.EQ.43) GOTO 59_^1_$IF (JMODE.NE.0) GO TO 5_^1_$IBUF2 (N+5) = 4_^1_$IBUF2 (N+1) = 20_^1_$IBUF2 (N+6) = 17_^1_$IBUF2 (N+7) = €€14_^1_$IBUF2 (N+8) = 11_^1_$IBUF2 (N+9) = 8_^1_$GOTO 41_^1_!59 IBUF2 (N+5) = 5_^1_$IBUF2 (N+1) = 23_^1_$IBUF2 (N+6) = 20_^1_$IBUF2 (N+7) = 17_^1_$IBUF2 (N+8) = 14_^1_$IBUF2 (N+9) = 11_^1_$IBUF2 (N+10) = 8_^1_$GOTO 85_^1_"6 KBITU=1_^1_$IBUF2(IBUF2X+17)=37_^1_$IBUF2(IBUF2X+18)=JSYM(1)_^1C_#JUMP IF TERMINATOR IS COMMA._^1_"7 IF(JTERM.EQ.43) GO TO 8_^1_$IBUF2(IBUF2X+5)=3_€€^1_$IBUF2(IBUF2X+1)=15_^1_$IBUF2(IBUF2X+6)=13_^1_$IBUF2(IBUF2X+7)=10_^1_$IBUF2(IBUF2X+8)=7_^1_$GO TO 41_^1C_#SET UP FORMATTED I/O._^1_"8 IBUF2(IBUF2X+5)=4_^1_$IBUF2(IBUF2X+1)=19_^1_$IBUF2(IBUF2X+6)=16_^1_$IBUF2(IBUF2X+7)=13_^1_$IBUF2(IBUF2X+8)=10_^1_$IBUF2(IBUF2X+9)=7_^1_!85 KBITF =1_^1_$ITEMP1=ISORSX_^1_$M=N+20_^1_$IF (IDISK.EQ.1) M=M+4_^1C_#TRY TO READ A LABEL._^1_$CALL RDLABL_^€€1C_#JUMP IF NOT A STATEMENT LABEL._^1_$IF(ILLABL.EQ.0) GO TO 10_^1C_#JUMP IF LABEL IN SYMBOL TABLE._^1_$IF(ISYMD.NE.0) GO TO 38_^1C_#SET UP LABEL IN SYMBOL TABLE._^1_$CALL STORE_^1_$ICLASS(ISYMX)=7_^1_$GO TO 38_^1_!10 ISORSX=ITEMP1_^1C_]_^1C_#RE-READ THE FIELD._^1_$CALL GETF_^1C_#JUMP IF FIELD IS NOT A NAME._^1_$IF(JMODE.NE.2) GO TO 5_^1C_#JUMP IF NAME IN SYMBOL TABLE._^1_$IF(ISYMD€€.NE.0) GO TO 11_^1C_#SET UP NAME IN SYMBOL TABLE._^1_$CALL STORE_^1_$ICLASS(ISYMX)=1_^1_$ITYPE(ISYMX)=JESWT_^1_$GO TO 40_^1C_#JUMP IF NAME AN ARRAY OR VARIABLE._^1_!11 IF(ICLASS(ISYMX).LE.1) GO TO 13_^1_$CALL DIAG(83)_^1_$GO TO 51_^1_!13 ICLASS(ISYMX)=1_^1C_#JUMP IF NAME IS AN ARRAY._^1_$IF(IDIM(ISYMX).NE.0)GO TO 48_^1C_#PRINT WARNING DIAGNOSTIC IF NAME NOT AN INTEGER._^1_!40 IF (I€€TYPE(ISYMX).NE.1) CALL DIAG ($2040)_^1_$GO TO 9_^1_!48 M= N +20_^1_$IF (IDISK.EQ.1) M= M +4_^1_$IBUF2(M) = 26_^1_$I=1_]_^1_$IF(ITYPE(ISYMX).NE.1.OR.(IK.NE.0.AND.ISNGL(ISYMX).EQ.0))I=2_^1C_8BEGIN_4***** FTN 3.1 *****_^1C_(FOR DOUBLE PRECISION I=3 WORDS PER ELEMENT_^1_$IF (ITYPE(ISYMX).EQ.3) I=3_^1C_8END_6***** FTN 3.1 *****_^1_$IBUF2(M+2) = I_^1_!38 KBITFF=1_^1_"9 IBUF2(M+1) = ISYM€€X + ISYMP_^1C_#JUMP IF TERMINATOR NOT RIGHT PARENTHESIS._^1_!41 IF(JTERM.NE.42) GO TO 5_^1C_#SAVE THE SOURCE INDEX._^1_$ITEMP3=ISORSX_^1_$CALL GETF_^1C_#SET BIT IF LIST IS NOT EMPTY._^1_$IF(.NOT.(JMODE.EQ.0.AND.JTERM.EQ.47))KBITL=1_^1_$IF(KBITL.EQ.0) IBUF2(4)=-1_^1_$IBUF2(1)=N+26_^1_$M= N + 12_^1_$IF(IDISK.EQ.1) M=M+1_^1_$IBUF2(M) =KBITW*512 + KBITR*1024 + KBITL*2048 + KBITFF*4096_€€^1_#*+ KBITU* 8192 + KBITF* 16384 + IDISK*256 + IRECN*128_^1C_#OUTPUT THE STATEMENT._^1_$ASSIGN 904 TO IGO3_^1_$GO TO 900_^1C_#JUMP IF LIST IS NOT NUL_^1 904 IF (KBITL.NE.0) GO TO 14_^1C_#PRINT DIAGNOSTIC IF UNFORMATTED WRITE._^1C_]_^1_$IF(KBITW.EQ.1.AND.KBITF.EQ.0) CALL DIAG(62)_^1_$GO TO 51_^1_!14 IPAREN=0_^1_$GO TO 42_^1C_#JUMP IF NOT END OF STATEMENT._^1_!15 IF(JTERM.NE.47)€€ GO TO 24_^1C_#SET UP END TRANSMISSION CALL._^1_$IBUF2(1)=9_^1_$IBUF2(3)=21_^1_$IBUF2(4)=-1_^1_$IBUF2(5)=-1_^1_$IBUF2(6)=1_^1_$IBUF2(7)=0_^1_$IBUF2(8)=23_^1_$IBUF2(9)=ISET(10)_^1C_#OUTPUT THE STATEMENT._^1_$ASSIGN 51 TO IGO3_^1_$GO TO 900_^1_!24 ITEMP3=ISORSX_^1_$CALL GETF_^1C_#JUMP IF THIS IS THE BEGINNING OF A DO-LOOP._^1_!42 IF(JMODE.EQ.0.AND.JTERM.EQ.41) GO TO 16_^1C_#JUMP IF N€€OT A NAME._^1_$IF(JMODE.NE.2) GO TO 5_^1C_#JUMP IF IN SYMBOL TABLE._^1_$IF(ISYMD.NE.0) GO TO 44_^1C_#STORE SYMBOL TABLE._^1_$CALL STORE_^1_$ITYPE(ISYMX)=JESWT_^1_$GO TO 45_^1C_#PRINT DIAGNOSTIC IF NOT VARIABLE OR ARRAY._^1_!44 IF(ICLASS(ISYMX).LE.1) GO TO 45_^1_$CALL DIAG(83)_^1_$GO TO 51_^1_!45 ICLASS(ISYMX)=1_^1_$K2WRDS = 0_^1_$IF (ITYPE(ISYMX).EQ.2 .OR._^1_#* (IK.NE.0 .AND. ISN€€GL(ISYMX).EQ.0)) K2WRDS = 1_^1C_8BEGIN_4***** FTN 3.1 *****_^1C_%FOR DOUBLE PRECISION K2WRDS = 2_^1_$IF (ITYPE(ISYMX).EQ.3) K2WRDS = 2_^1C_8END_6***** FTN 3.1 *****_^1C_]_^1C_#JUMP IF TERMINATOR IS NOT EQUAL SIGN._^1C_]_^1_$IF(JTERM.NE.40) GO TO 39_^1C_]_^1C_#JUMP IF NOT IN DO LOOP._^1C_]_^1_$IF(IPAREN.LE.0) GO TO 5_^1_$IPAREN=IPAREN-1_^1C_]_^1C_#DO LOOP TERMINATION. SCAN PAST RI€€GHT PARENTHESIS._^1C_]_^1_!17 CALL GETC_^1_$IF(JCHAR.NE.42) GO TO 17_^1_$CALL GETF_^1C_]_^1C_#JUMP IF FIELD NOT NUL OR TERMINATOR NOT COMMA OR EOS._^1C_]_^1_$IF(JMODE.NE.0.OR.JTERM.NE.43.AND.JTERM.NE.47) GO TO 5_^1_$ASSIGN 15 TO ISTMNT_^1_$GO TO 18_^1C_]_^1C_#JUMP IF TERMINATOR IS COMMA OR END-OF-STATEMENT._^1C_]_^1_!39 IF(JTERM.EQ.43.OR.JTERM.EQ.47) GO TO 19_^1C_]_^1C_#JUMP IF TER€€MINATOR NOT LEFT PAREN. ERROR._^1C_]_^1_$IF(JTERM.NE.41) GO TO 5_^1C_]_^1C_#SKIP PAST SUBSCRIPT._^1C_]_^1_!37 CALL GETC_^1_$IF(JCHAR.EQ.42) GO TO 36_^1_$IF(JCHAR.NE.47) GO TO 37_^1_$GO TO 5_^1_!36 ITEMP4=ISORSX-1_^1_$CALL GETF_^1C_]_^1C_#JUMP UNLESS FIELD IS NUL AND TERMINATOR IS COMMA OR EOS._^1C_]_^1_$IF(.NOT.(JMODE.EQ.0.AND.(JTERM.EQ.43.OR.JTERM.EQ.47))) GO TO 5_^1C_]_^1C_#MOVE€€_!Q8QX(PARAMETER)EOS INTO IBUF2 AS A CALL. SET UP_^1C_]_^1_!22 IBUF2(5)=IHEAD(1)_^1_$IBUF2(6)=IHEAD(2)_^1_$IF (KBITF.EQ.0 .AND. K2WRDS.EQ.1) IBUF2(6) = IHEAD(4)_^1C_8BEGIN_4***** FTN 3.1 *****_^1C_(IHEAD(1)=Q8 IHEAD(2)=QX IHEAD(4)=QY_^1C_(FOR DOUBLE PRECISION CALL Q8QZ_+QZ_^1_$IF (KBITF.EQ.0 .AND. K2WRDS.EQ.2) IBUF2(6) = $1A23_^1C_8END_6***** FTN 3.1 *****_^1_$IBUF2(7)=IHEAD(3)_^1€€_$IBUF2(3)=-21_^1_$IBUF2(1)=7+(ITEMP4-ITEMP3+4)/2_^1_$IBUF2(4)=1_^1_$J=1_]_^1_$ITEMPB=ISORSX_^1_$ISORSX=ITEMP3_^1_$JBLANK=1_^1_$DO 43 I=ITEMP3,ITEMP4_^1_$CALL GETC_^1C_]_^1C_#JUMP IF NOT A BLANK._^1C_]_^1_$IF(JCHAR.NE.46) GO TO 46_^1_$J=J-1_^1_$GO TO 43_^1_!46 CALL STCHAR(IBUF2(8),J,JCHAR)_^1_!43 J=J+1_^1_$JBLANK=0_^1_$CALL STCHAR(IBUF2(8),J,42)_^1_$CALL STCHAR(IBUF2(8),J+1,47)_^1_€€$ISORSX=ITEMPB_^1_!23 ASSIGN 15 TO IGO3_^1_$GO TO 900_^1C_]_^1C_#STORE THE DIMENSIONS OF THIS ARRAY INTO THE JDIM BUFFER._^1C_]_^1_!19 ITEMP1=IDIM(ISYMX)_^1_$ITEMP4=ISORSX-2_^1C_]_^1C_#JUMP IF NOT AN ARRAY._^1C_]_^1_$IF(ITEMP1_#.EQ.0) GO TO 22_^1_$ITEMP5=ISYMX/(2*ISYMFL) +1_^1_$ITEMP5=ISTABX(ITEMP5)_^1_$IF (AND(ISYMX,1).EQ.1) ITEMP5=ITEMP5/$0100_^1_$ITEMP5=AND(ITEMP5,$FF)_^1_$ITEMP€€B=ITEMP1_^1_$J=ITEMP1+1_^1_$JSYM(2)=0_^1_$JSYM(3)=9252_^1_$DO 20 I=1,ITEMP1_^1_$J=J-1_^1_$ITEMP6=ITEMP5+J-1_^1_$JSYM(1)=ISTAB(ITEMP6)_^1_$CALL SYMBOL_^1_$IF(ISYMD.EQ.0)CALL STORE_^1_!20 JDIM(J)=ISYMX+ISYMP_^1_!21 ITEMPB=ITEMPB-1_^1C_#JUMP IF NOT ALL OF THE BEGIN D0 S HAVE BEEN CREATED._^1C_]_^1_$IF(ITEMPB.GE.0) GO TO 28_^1C_]_^1C_#SET UP CALL TO TRANSMISSION ROUTINE._^1C_]_^1_$IBUF€€2(5)=IHEAD(1)_^1_$IBUF2(6)=IHEAD(2)_^1_$IF (KBITF.EQ.0 .AND. K2WRDS.EQ.1) IBUF2(6) = IHEAD(4)_^1C_8BEGIN_4***** FTN 3.1 *****_^1C_(FOR DOUBLE PRECISION CALL Q8QZ_+QZ_^1_$IF (KBITF.EQ.0 .AND. K2WRDS.EQ.2) IBUF2(6) = $1A23_^1C_8END_6***** FTN 3.1 *****_^1_$IBUF2(7)=IHEAD(3)_^1_$J=1_]_^1_$ITEMPC=ISORSX_^1_$ISORSX=ITEMP3_^1_$JBLANK=1_^1_$DO 25 I=ITEMP3,ITEMP4_^1_$CALL GETC_^1C_]_^1C_#€€JUMP IF NOT A BLANK._^1C_]_^1_$IF(JCHAR.NE.46) GO TO 47_^1_$J=J-1_^1_$GO TO 25_^1_!47 CALL STCHAR(IBUF2(8),J,JCHAR)_^1_!25 J=J+1_^1_$JBLANK=0_^1_$CALL STCHAR(IBUF2(8),J,41)_^1_$CALL STCHAR(IBUF2(8),J+1,46)_^1_$ISORSX=ITEMPC_^1_$J=(J+3)/2_^1_$DO 26 I=1,ITEMP1_^1_$L=(I-1)*3_^1_$DO 27 M=1,3_^1_$N=L+M_^1_$IBUF2(J+7)=IPARM(N)_^1_!27 J=J+1_^1_!26 CONTINUE_^1_$CALL STCHAR(IBUF2(8),2*J-2,4€€2)_^1_$CALL STCHAR(IBUF2(8),2*J-1,42)_^1_$CALL STCHAR(IBUF2(8),2*J,47)_^1_$IBUF2(3)=-21_^1_$IBUF2(4)=1_^1_$IBUF2(1)=J+7_^1C_]_^1C_#OUTPUT THIS STATEMENT._^1C_]_^1_$ASSIGN 906 TO IGO3_^1_$GO TO 900_^1 906 ASSIGN 200 TO ISTMNT_^1_$ITEMPB=ITEMP1_^1200_!ITEMPB=ITEMPB-1_^1_$IF (ITEMPB.GE.0) GO TO 18_^1_$GO TO 15_^1C_#JUMP IF DO-LOOPS NOT TOO DEEP._^1_!28 IF(LOOPTX+LOOPTB.LE.LOOPTS+1)GO€€ TO 30_^1_$CALL DIAG(79)_^1_$GO TO 51_^1C_#SET UP BEGIN DO._^1_!30 LLABL(LOOPTX)=1_^1_$LID(LOOPTX)=0_^1_$IBUF2(3)=40_^1_$LINDUC(LOOPTX)=ISET(ITEMPB+6)_^1_$LBEG(LOOPTX)=ISET(1)_^1_$LEND(LOOPTX)=JDIM(ITEMPB+1)_^1_$LINC(LOOPTX)=ISET(1)_^1_$DO 310 I=1,LOOPTB_^1_$J=LOOPTX+I-1_^1 310 IBUF2(I+4)=LOOPT(J)_^1_$IBUF2(1)=LOOPTB+3_^1_$LOOPTX=LOOPTX+LOOPTB_^1_$ASSIGN 21 TO IGO3_^1_$GO TO 900_^€€1C_#CREATE AN END DO._^1C_]_^1_!18 IVCFLG=-1_^1_$ILLABL=1_^1_$CALL ENDDO_^1_$IBUF2(4)=IBUF2(1)_^1_$GO TO ISTMNT_^1C_]_^1C_#SET UP A DO-IMPLIED LOOP. FIRST SCAN TO INDUCTION PARAMETERS._^1C_]_^1_!16 ITEMP1=ISORSX_^1_$I=0_]_^1_$IPAREN=IPAREN+1_^1_!32 J=ISORSX_^1_$K=JCHAR_^1_!31 CALL GETC_^1C_]_^1C_#JUMP IF ALPHAMERIC._^1C_]_^1_$IF(JCHAR.LE.35) GO TO 31_^1C_]_^1C_#JUMP IF COMMA._^1C_€€]_^1_$IF(JCHAR.EQ.43) GO TO 32_^1C_]_^1C_#JUMP IF EQUAL SIGN AND AT CORRECT PARENTHESIS LEVEL._^1C_]_^1_$IF(JCHAR.EQ.40.AND.I.EQ.0) GO TO 33_^1C_]_^1C_#JUMP IF NOT LEFT PAREN._^1C_]_^1_$IF(JCHAR.NE.41) GO TO 34_^1_$I=I+1_^1_$GO TO 32_^1C_]_^1C_#JUMP IF NOT RIGHT PAREN._^1_!34 IF(JCHAR.NE.42) GO TO 35_^1_$I=I-1_^1_$GO TO 32_^1C_#JUMP IF NOT END-OF-STATEMENT._^1_!35 IF(JCHAR.NE.47) G€€O TO 32_^1_$CALL DIAG(16)_^1_$GO TO 51_^1C_#JUMP IF PRECEDING SPECIAL CHARACTER NOT COMMA._^1C_]_^1_!33 IF(K.NE.43) GO TO 5_^1_$IBUF2(3)=40_^1_$IVCFLG=-1_^1_$ISORSX=J+1_^1C_]_^1C_#CREATE AN END DO LABEL._^1C_#CREATE A BEGIN DO._^1C_]_^1_$CALL BDOPR_^1_$ISORSX=ITEMP1_^1_$IVCFLG=0_^1_$JTERM=43_^1_$ASSIGN 15 TO IGO3_^1C *** THIS IS AN OUTPUT ROUTINE WHICH..._^1C_%(IF STATEMENT TYPE IS€€ NEGATIVE, SETS 'IBUF2X' AND CALLS_^1C_%'ARITH', PRESERVING 'GETF' VALUES, THEN...)_^1C_#OUTPUTS 'IBUF2' AND RE-INITIALIZES IT._^1 900 IF (LOGIF.EQ.2) IBUF2(4)=-IBUF2(4)_^1_$IF (IBUF2(3) .LT. 0) GO TO 902_^1_$CALL OUTENT(IBUF2)_^1 901 IBUF2(2)=ISTNO_^1_$IBUF2(4)=IBUF2(1)_^1_$IBUF2X=5_^1_$GO TO IGO3_^1 902 IBUF2X=9_^1_$IBUF2(3)=-IBUF2(3)_^1C USE UNNEEDED WORDS OF 'ISORS' AS TEMPO€€RARIES._^1_$ISORS(3)=JMODE_^1_$ISORS(4)=JTERM_^1_$ISORS(5)=JESWT_^1C SET BIT 4 OF 'IFLAGS' TO INDICATE TO 'ARITH', 'GETF', AND 'GETC' THAT_^1C THIS IS A CALL FROM 'IOSPR' AND INPUT IS FROM 'IBUF2'._^1_$IFLAGS=IFLAGS+16_^1_$ASSEM $1802,.907,+909,$5400,+LOCAL,+907,$4,$1,.908,$1_^1 909 IFLAGS=IFLAGS-16_^1_$IBUF2(1)=IBUF2X-1_^1_%CALL OUTENT(IBUF2)_^1_$IBUF2(3)=-IBUF2(3)_^1_$JMODE=ISOR€S(3)_^1_$JTERM=ISORS(4)_^1_$JESWT=ISORS(5)_^1_$GO TO 901_^1_!51 IBUF2(2)=ISORS(1)_^1_$IBUF2(5)=ISORS(2)_^1_$ASSEM $0AFE,$6800,908_^1_$END_]_^__ PWERBPR CSY/ 38A P€1_$SUBROUTINE ERBPR_^1_#*_2/DECK-ID 38A FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^13_]_^1C ERBPR IS USED IN PHASE A3_^1C_]_^1C_#MASTER LABELED COMMON BLOCK._^1*_] FTN 3.3_^1_$COMMON /A/ IFLAGS,LINECT,LINCT1_^1_$COMMON /A/ IR,IK,IP,IA,IL,IM,IXLGO,IOP€€TO,IOPTV,IOPTC,IOPTD_^1_$COMMON /A/ MCSTRT,MACRNB,MACSEC_^1_$COMMON /A/ IERRS(16),ISRFAD_^1_$COMMON /A/ LGO,ISCRI,ISCRO,IX_^1*_] FTN 3.3_^1_$COMMON /A/ IGLAB(3),IGLAB1,IGLAB2_^1_$COMMON /A/ ICOMT(12),ICOMTS,ICOMX2,ICOMTL,ISUBP,NDPRS,_^1_#$LABX,IBCDTB(48)_^1_$EQUIVALENCE(ICOMB,ICOMT(1)),(ICOMBX,ICOMT(2)),(ICOMDF,_^1_#$ICOMT(3)),(ICOMBN,ICOMT(4))_^1_$DIMENSION ICOMB(6),ICOMBX(6),ICO€€MDF(6),ICOMBN(7)_^1_$COMMON /A/ LOOPTS,LOOPTX,LOOPTB,LOOPT(50)_^1_$EQUIVALENCE(LINDUC,LOOPT(1))_^1_$DIMENSION LINDUC(10)_^1_$EQUIVALENCE (LBEG,LOOPT(2))_^1_$DIMENSION LBEG(10)_^1_$EQUIVALENCE (LINC,LOOPT(3))_^1_$DIMENSION LINC(10)_^1_$EQUIVALENCE (LEND,LOOPT(4))_^1_$DIMENSION LEND(10)_^1_$BYTE(LLABL,LOOPT(5)(14=0)_))_^1_$DIMENSION LLABL(10)_^1_$BYTE(LID,LOOPT(5)(15=15) )_^1_$DIME€€NSION LID(10)_^1_$COMMON/A/IEQV(255), IEQVS,IEQVN2_^1_$COMMON /A/ ISTAB(150),ISTABS,ISTAB2_^1_$COMMON /A/ IBUFS,ISET(25),LBLANK,KSFCNT,KSNCNT,ISORSC,_^1_#$IHOBIT,ISTNO,ISSFLG,ISUBPN,ITERM,JSORSC,KEQVS_^1C_#SYMBOL TABLE LABELED COMMON BLOCK_^1_$COMMON /A/ ISYMN, ISYMFL,ISYMD,ISYMX,ISYMS,ISYMP,ISYMPC,ISYMPS,_^1_#$ ISYMNS, SYMTAB(960)_^1_$INTEGER SYMTAB_^1_$BYTE (IDUM,SYMTAB(1)(15=15)€€),(KDUMY,SYMTAB(1)(15=15)),_^1_#$(ICLASS,SYMTAB(1)(14=11)),(ITYPE,SYMTAB(1)(10=9))_^1_$DIMENSION IDUM(100),KDUMY(100),ICLASS(100),ITYPE(100)_^1_$BYTE (ISNGL, SYMTAB(1)(8=8)),(KELSIZ,SYMTAB(1)(8=8)),_^1_#$ (ICOM,SYMTAB(1)(7=5)),(IPART,SYMTAB(1)(4=3))_^1_$DIMENSION ISNGL(100),KELSIZ(100),ICOM(100),IPART(100)_^1_$BYTE (KRFCNT,SYMTAB(1)(2=2)),(IDIM,SYMTAB(1)(1=0)),_^1_#$ (IREL,SYMTAB(1€€)(1=1)),(IEXT,SYMTAB(1)(0=0))_^1_$DIMENSION KRFCNT(100),IDIM(100),IREL(100),IEXT(100)_^1_$EQUIVALENCE (IRSA,SYMTAB(2)),(ICOMTX,SYMTAB(2)),(ISNOL,SYMTAB(2))_^1_$DIMENSION IRSA(100), ICOMTX(100),ISNOL(100)_^1_$BYTE (IDATAS,SYMTAB(3)(15=15)),(IREF,SYMTAB(3)(15=15)),_^1_#$ (IEQVX,SYMTAB(3)(14=8)),(ITILF,SYMTAB(3)(14=8))_^1_$DIMENSION IDATAS(100),IREF(100),IEQVX(100),ITILF(100)_^1_$BYTE€€ (IPARTR,SYMTAB(3)(7=4)),(INDUCV,SYMTAB(3)(7=7)),(ISFARG,_^1_#$ SYMTAB(3)(6=6)),(IARGNO,SYMTAB(3)(5=0)),(IPARTL,SYMTAB(3)(3=0))_^1_$DIMENSION IPARTR(100),INDUCV(100),ISFARG(100),IARGNO(100),_^1_#$ IPARTL(100)_^1_$EQUIVALENCE (ISYM,SYMTAB(4))_^1_$DIMENSION ISYM(100)_^1C_]_^1C_#SPECIFICATION-TABLE INDEX LABELLED COMMON BLOCK_^1_$COMMON /A/ ISTABX(96)_^1C_]_^1C_#PHASE A BLANK COMMON B€€LOCK._^1_$COMMON // JSYM(3),JTERM,JMODE,JERR,JESWT,JFLOT,JCHAR,_^1_#$JOCHAR,JO1,JE,JE1,JBLANK,JCT,JCT1_^1C_#JSYM-JCT1 MUST REMAIN IN ORDER_^1_$COMMON//IERR_^1_$COMMON//ISORS(208),ISORSX_^1_$COMMON//IDEFF,ISTOP,IRET,ISPEC,NERR,OCT_^1_$INTEGER OCT_^1_$COMMON//ILLABL,LEST,ISNGL1,ICOMX1,NXTYPE,LOGIF,IOVFL1,IOVFL2_^1_$COMMON//IVCFLG,ISFLG,LOGEX,KEQVX_^1_$COMMON//IBUF2X,IBUF2(304)_^1C_$T€€EMPORARY ARITHMETIC BUFFERS_^1_$COMMON//IBUF1( 304),IBUF1X,IWORK (304)_^1C_#TEMPORARY EQUIVALENCE BUFFERS_^1_$DIMENSION KEQV(460),MEQV(255)_^1_$EQUIVALENCE (KEQV,IBUF1(66)),(MEQV,IBUF2(100))_^1C_#LS1-ITEM MUST REMAIN IN ORDER_^1_$COMMON//LS1,LPREN,LRELRQ,LRELEN,LSWITC,LO,ITEM_^1_$COMMON//MODE_^1_$COMMON//IPHAT(4),IGNSTT(49),IOSPRT(17)_^1C_]_^1C_]_^1C_]_^1C_#THIS IS THE PROCESSOR FO€€R THE STATEMENTS END FILE, REWIND, AND_^1C_#BACKSPACE._^1_$CALL CKIVC_^1_$IF(IVCFLG .EQ. 0) RETURN_^1C_]_^1C_#SET UP FILE1 ENTRY._^1C_]_^1_"4 IBUF2(IBUF2X)=-1_^1C ************************************************************_!85*2720_^1_$IBUF2(IBUF2X+1)=11_^1C ************************************************************_!85*2720_^1_$IBUF2(IBUF2X+2)=0_^1_$IBUF2(IBUF2X+3)=20_^1_$I=IBU€€F2(3)-31_^1_$IBUF2(IBUF2X+4)=ISET(I)_^1C ************************************************************_!85*2720_^1_$IBUF2(IBUF2X+5)=2_^1_$IBUF2(IBUF2X+6)=8_^1_$IBUF2(IBUF2X+7)=5_^1_$IBUF2(IBUF2X+8)=0_^1_$IBUF2(IBUF2X+9)=37_^1_$IBUF2(IBUF2X+10)=ISTNO_^1_$IBUF2(IBUF2X+11)=0_^1_$IBUF2(IBUF2X+12)=24+11*(ICLASS(ISYMX)-1)_^1_$IBUF2(IBUF2X+13)=ISYMX+ISYMP_^1_$IBUF2(1)=IBUF2X+13_^1C *******€º*****************************************************_!85*2720_^1_$IBUF2(3)=21_^1C_]_^1C_#RETURN IF TERMINATOR IS EOS._^1C_]_^1_$IF(JTERM.EQ.47) RETURN_^1_$CALL DIAG($200C)_^1_$END_]_^__ºPWMODX CSY/ 39A P€1_$SUBROUTINE MODMXR_^1_#*_2/DECK-ID 39A FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^13_]_^1C MODMXR IS USED IN PHASE A3_^1C_#THIS ROUTINE PROVIDES FOR MIXED MODE BY INSERTING CALLS TO_^1C_.FLOAT_!INTEGER/REAL_^1C_.DFLT_"INTEGER/DOUBLE PRECISION_^1C_.D€€BLE_"REAL/DOUBLE PRECISION_^1C_$IN THE ARITHMETIC TREE AND REORDERING THE TREE AS NEEDED_^1C_$IT IS CALLED FROM ARITH ONLY IF MIXED MODE OCCURS_^1C_]_^1C_#MASTER LABELED COMMON BLOCK._^1*_] FTN 3.3_^1_$COMMON /A/ IFLAGS,LINECT,LINCT1_^1_$COMMON /A/ IR,IK,IP,IA,IL,IM,IXLGO,IOPTO,IOPTV,IOPTC,IOPTD_^1_$COMMON /A/ MCSTRT,MACRNB,MACSEC_^1_$COMMON /A/ IERRS(16),ISRFAD_^1_$COMMON /A/ LGO€€,ISCRI,ISCRO,IX_^1*_] FTN 3.3_^1_$COMMON /A/ IGLAB(3),IGLAB1,IGLAB2_^1_$COMMON /A/ ICOMT(12),ICOMTS,ICOMX2,ICOMTL,ISUBP,NDPRS,_^1_#$LABX,IBCDTB(48)_^1_$EQUIVALENCE(ICOMB,ICOMT(1)),(ICOMBX,ICOMT(2)),(ICOMDF,_^1_#$ICOMT(3)),(ICOMBN,ICOMT(4))_^1_$DIMENSION ICOMB(6),ICOMBX(6),ICOMDF(6),ICOMBN(7)_^1_$COMMON /A/ LOOPTS,LOOPTX,LOOPTB,LOOPT(50)_^1_$EQUIVALENCE(LINDUC,LOOPT(1))_^1_$DIMENSI€€ON LINDUC(10)_^1_$EQUIVALENCE (LBEG,LOOPT(2))_^1_$DIMENSION LBEG(10)_^1_$EQUIVALENCE (LINC,LOOPT(3))_^1_$DIMENSION LINC(10)_^1_$EQUIVALENCE (LEND,LOOPT(4))_^1_$DIMENSION LEND(10)_^1_$BYTE(LLABL,LOOPT(5)(14=0)_))_^1_$DIMENSION LLABL(10)_^1_$BYTE(LID,LOOPT(5)(15=15) )_^1_$DIMENSION LID(10)_^1_$COMMON/A/IEQV(255), IEQVS,IEQVN2_^1_$COMMON /A/ ISTAB(150),ISTABS,ISTAB2_^1_$COMMON /A/ I€€BUFS,ISET(25),LBLANK,KSFCNT,KSNCNT,ISORSC,_^1_#$IHOBIT,ISTNO,ISSFLG,ISUBPN,ITERM,JSORSC,KEQVS_^1C_#SYMBOL TABLE LABELED COMMON BLOCK_^1_$COMMON /A/ ISYMN, ISYMFL,ISYMD,ISYMX,ISYMS,ISYMP,ISYMPC,ISYMPS,_^1_#$ ISYMNS, SYMTAB(960)_^1_$INTEGER SYMTAB_^1_$BYTE (IDUM,SYMTAB(1)(15=15)),(KDUMY,SYMTAB(1)(15=15)),_^1_#$(ICLASS,SYMTAB(1)(14=11)),(ITYPE,SYMTAB(1)(10=9))_^1_$DIMENSION IDUM(100),€€KDUMY(100),ICLASS(100),ITYPE(100)_^1_$BYTE (ISNGL, SYMTAB(1)(8=8)),(KELSIZ,SYMTAB(1)(8=8)),_^1_#$ (ICOM,SYMTAB(1)(7=5)),(IPART,SYMTAB(1)(4=3))_^1_$DIMENSION ISNGL(100),KELSIZ(100),ICOM(100),IPART(100)_^1_$BYTE (KRFCNT,SYMTAB(1)(2=2)),(IDIM,SYMTAB(1)(1=0)),_^1_#$ (IREL,SYMTAB(1)(1=1)),(IEXT,SYMTAB(1)(0=0))_^1_$DIMENSION KRFCNT(100),IDIM(100),IREL(100),IEXT(100)_^1_$EQUIVALENCE (IRSA€€,SYMTAB(2)),(ICOMTX,SYMTAB(2)),(ISNOL,SYMTAB(2))_^1_$DIMENSION IRSA(100), ICOMTX(100),ISNOL(100)_^1_$BYTE (IDATAS,SYMTAB(3)(15=15)),(IREF,SYMTAB(3)(15=15)),_^1_#$ (IEQVX,SYMTAB(3)(14=8)),(ITILF,SYMTAB(3)(14=8))_^1_$DIMENSION IDATAS(100),IREF(100),IEQVX(100),ITILF(100)_^1_$BYTE (IPARTR,SYMTAB(3)(7=4)),(INDUCV,SYMTAB(3)(7=7)),(ISFARG,_^1_#$ SYMTAB(3)(6=6)),(IARGNO,SYMTAB(3)(5=0)),(IP€€ARTL,SYMTAB(3)(3=0))_^1_$DIMENSION IPARTR(100),INDUCV(100),ISFARG(100),IARGNO(100),_^1_#$ IPARTL(100)_^1_$EQUIVALENCE (ISYM,SYMTAB(4))_^1_$DIMENSION ISYM(100)_^1C_]_^1C_#SPECIFICATION-TABLE INDEX LABELLED COMMON BLOCK_^1_$COMMON /A/ ISTABX(96)_^1C_]_^1C_#PHASE A BLANK COMMON BLOCK._^1_$COMMON // JSYM(3),JTERM,JMODE,JERR,JESWT,JFLOT,JCHAR,_^1_#$JOCHAR,JO1,JE,JE1,JBLANK,JCT,JCT1_^1C_€€#JSYM-JCT1 MUST REMAIN IN ORDER_^1_$COMMON//IERR_^1_$COMMON//ISORS(208),ISORSX_^1_$COMMON//IDEFF,ISTOP,IRET,ISPEC,NERR,OCT_^1_$INTEGER OCT_^1_$COMMON//ILLABL,LEST,ISNGL1,ICOMX1,NXTYPE,LOGIF,IOVFL1,IOVFL2_^1_$COMMON//IVCFLG,ISFLG,LOGEX,KEQVX_^1_$COMMON//IBUF2X,IBUF2(304)_^1C_$TEMPORARY ARITHMETIC BUFFERS_^1_$COMMON//IBUF1( 304),IBUF1X,IWORK (304)_^1C_#TEMPORARY EQUIVALENCE BUFFERS_^€€1_$DIMENSION KEQV(460),MEQV(255)_^1_$EQUIVALENCE (KEQV,IBUF1(66)),(MEQV,IBUF2(100))_^1C_#LS1-ITEM MUST REMAIN IN ORDER_^1_$COMMON//LS1,LPREN,LRELRQ,LRELEN,LSWITC,LO,ITEM_^1_$COMMON//MODE_^1_$COMMON//IPHAT(4),IGNSTT(49),IOSPRT(17)_^1C_]_^1C_#NOP CONTAINS OPERATOR PER LEVEL OF TREE_^1C_#NBRNS CONTAINS NUMBER OF BRANCHES PER LEVEL OF TREE_^1C_#ICBRN USED AS CURRENT BRANCH RECORDER_^1C€€_#KOP CONTAINS IBUF2 POINTER TO OPERATOR AT CURRENT LEVEL_^1C_#IMOD CONTAINS MODE OF EACH BRANCH PER LEVEL_^1C_#IRBR CONTAINS IBUF1 POINTER TO BRANCH TRANSFERRED FROM IBUF2_^1_$DIMENSION NOP(30),NBRNS(30),ICBRN(30),KOP(30),IMOD(90), IRBR(90)_^1_$EQUIVALENCE (IBR,IWORK(301)),(IT,IWORK(302)),(IN,IWORK(303)),_^1_#*(IXT,IWORK(304)),(K,LPREN),(LEVEL,LRELRQ),_^1_#*(NDBK,LSWITC)_^1_$EQUIV€€ALENCE(NOP,IWORK),(NBRNS,IWORK(31)),(ICBRN,IWORK(61)),(KOP,_^1_#*IWORK(91)),(IMOD,IWORK(121)),(IRBR,IWORK(211))_^1C_8BEGIN_4***** FTN 3.1 *****_^1C_'ICNT1 = DFLT ITEM COUNTER, ICNT2 = DBLE COUNTER_^1_$ICNT1 = 0_^1_$ICNT2 = 0_^1C_8END_6***** FTN 3.1 *****_^1C*************************************************************** 83*2485_^1C_#SAVE POINTER TO START OF TREE IN J_^1_$J=ITEM_^1C€€*************************************************************** 83*2485_^1_$ITEM=0_^1_$NDBK = 0_^1_$IBUF2X=IBUF2X-1_^1C*******************_$5 CARDS DELETED_'***********_#83*2485_^1C_#LOX EQUALS POINTER TO NUMBER OF WORDS IN TREE_^1C_#LEVEL EQUALS LEVEL IN TREE_^1C_#LO EQUALS IBUF2 POINTER TO OPERATOR AT CURRENT LEVEL_^1_!20 LOX_"=J+1_^1_$LEVEL = 1_^1_$LO = J + 3_^1C_8BEGIN_4***** F€€TN 3.1 *****_^1C_#INITIALIZE FUNCTION CALL IN TREE FORM_^1_$IBUF1(2) = 18_^1C_8END_6***** FTN 3.1 *****_^1_$IBUF1(4) = 1_^1_$IBUF1(5) = 4_^1_$IBUF1 (6) =0_^1_$IBUF1X = 9_^1C_'PROCESS ONE LEVEL OF TREE_^1_!40 NOP(LEVEL) = IBUF2(LO)_^1_$KOP(LEVEL) = LO_^1_$K = 1_^1C_#IF OPERATOR IS FUNCTION OR SUBROUTINE K=2_^1_$IF (NOP(LEVEL) .GE.18.AND.NOP(LEVEL).LE.21) K = 2_^1C_#I=POINTER TO NUMB€€ER OF OPERANDS THIS LEVEL_^1_$I = LO +K_^1C_#SAVE NUMBER OF BRANCHES THIS LEVEL_^1_$NBRNS(LEVEL)=IBUF2(I)_^1C_#RECORD BRANCH CURRENTLY PROCESSING_^1_$ICBRN(LEVEL) = 1_^1C_#SET BRANCH COUNTER_^1_$IBR = 1_^1C_'FIND FIRST BRANCH AT THIS LEVEL_^1C_#J=IBUF2 POINTER TO DISPLACEMENT OF BRANCH FROM LEVEL OPERATOR_^1_$J = LO + K + 1_^1C_#LO POINTS TO OPERAND TYPE_^1_$LO= LO + IBUF2(J) + 1_^€€1C_'JUMP IF BRANCH NOT AN OPERATOR_^1_!50 IF(IBUF2(LO).GT.21) GO TO 60_^1C_'GO ONE LEVEL DEEPER IN TREE_^1_$LEVEL = LEVEL + 1_^1C_'TEST FOR OFLW OF NOP, KOP, ETC_^1_$IF (LEVEL.GT.30) CALL PUNT_^1_$GO TO 40_^1 60_!IF (NOP(LEVEL).LT.11.OR.NOP(LEVEL).GT.15) GO TO 70_^1C_#OPERATOR IS +,-,*,/,**_^1C_'PACK MODE OF THIS BRANCH WITH INVERSE SWITCH IN TREE_^1C_#ISYMX IS SYMBOL TABLE POINTER€€ OF BRANCH_^1_$ISYMX=IBUF2(LO+1)_^1C_#LOCATE BRANCH IN SYMBOL TABLE_^1_$CALL GETSYM_^1_$IBUF2(LO-1)=ITYPE(ISYMX)*2+IBUF2(LO-1)_^1C_'PROCESS NEXT BRANCH AT THIS LEVEL_^1_!70 ICBRN(LEVEL) = ICBRN (LEVEL) + 1_^1_$IBR = ICBRN (LEVEL)_^1_$LO = KOP(LEVEL)_^1C_'JUMP IF NO MORE BRANCHES THIS LEVEL_^1_$IF(IBR.GT.NBRNS(LEVEL)) GO TO 80_^1_$J = LO + IBR + K_^1_$LO = LO + IBUF2(J) + 1_^1_$GO T€€O 50_^1C_'MODE IS DETERMINED FOR ALL BRANCHES, CHECK FOR MIXED MODE_^1C_#IOP=OPERATOR AT THIS LEVEL_^1_!80 IOP = NOP(LEVEL)_^1_$MODE = 0_^1C_'JUMP IF OPERATOR IS + - * / **_^1_$IF(IOP.GE.11.AND. IOP.LE.15) GO TO 90_^1C_#ELSE GO ONE LEVEL HIGHER IN TREE_^1_$GO TO 500_^1C_#I=NUMBER OF BRANCHES THIS LEVEL_^1 90_!I = NBRNS(LEVEL)_^1C_'TEST FOR OFLW OF IMOD, IRBR_^1_$IF (I.GT.90) CALL €€PUNT_^1C_#SAVE MODE OF BRANCH IN IMOD_^1_$DO 100 IBR = 1,I_^1C_#J=IBUF2 POINTER TO BRANCH DISPLACEMENT_^1_$J = LO + IBR + 1_^1C_#J=IBUF2 POINTER TO BRANCH INVERSE FLAG_^1_$J = LO + IBUF2(J)_^1C_#STORE MODE OF BRANCH_^1_$IMOD(IBR) = IBUF2 (J)_!/2_^1C_#RESET INVERSE FLAG_^1_$IBUF2(J) = AND(IBUF2(J),1)_^1C_8BEGIN_4***** FTN 3.1 *****_^1C_#SET MODE FLAG_^1_$N = IMOD(IBR)_^1C_#IF MODE O€€F BRANCH IS DOUBLE PRECISION, OR THE MODE WITH 4_^1_$IF (N.EQ.3) N=4_^1_$MODE = OR(MODE,N)_^1 100 CONTINUE_^1C_#BRANCHES THIS LEVEL HAVE BEEN TESTED FOR MODE_^1C_#JUMP IF ALL INTEGER MODE_^1_$IF (MODE.EQ.1) GO TO 400_^1C_#JUMP IF ALL REAL MODE_^1_$IF (MODE.EQ.2) GO TO 500_^1C_#JUMP IF MIXED MODE_^1_$IF (MODE.NE.4) GO TO 104_^1C_#RESET MODE FROM 4 TO 3 ALL BRANCHES ARE DOUBLE PRECI€€SION_^1_$MODE = 3_^1_$GO TO 500_^1C_#FOUND MIXED MODE EXPRESSION - MODE OF 3 = REAL-INTEGER_^1C_J5 = DOUBLE PRECISION-INTEGER_^1C_J6 = DOUBLE PRECISION-REAL_^1C_J7 = DOUBLE-REAL-INTEGER_^1C_'INITIALIZE DBLE STRING LENGTH COUNTER_^1 104 IDBLEN = 8_^1C_#JUMP IF OPERATOR NOT **_^1_$IF (IOP .NE. 15) GO TO 150_^1C_8END_6***** FTN 3.1 *****_^1C_'EXPONENTIATION (A**I IS LEGAL)_^1C_#J=IBU€€F2 POINTER TO BRANCH INVERSE FLAG_^1_$J = LO + IBUF2(LO+2)_^1C_#IF FLAG IS NORMAL JUMP - FIRST BRANCH IS EXPONENT_^1_$IF (IBUF2(J).EQ.0) GO TO 140_^1C_8BEGIN_4***** FTN 3.1 *****_^1C_'SECOND BRANCH IS EXPONENT_^1C_+JUMP IF EXPONENT NOT AN INTEGER_^1_$IF (IMOD(2).NE.1) GO TO 106_^1C_+EXPONENT IS INTEGER_^1 105 MODE = IMOD(1)_^1_$GO TO 500_^1C_'IF EXPONENT NOT REAL THEN JUMP TO DOUB€€LE PRECISION EXPONENT_^1 106 IF (IMOD(2).NE.2) GO TO 120_^1C_'EXPONENT REAL (SECOND BRANCH)_^1C_'IF 1ST BRANCH VARIABLE NOT INTEGER THEN RETURN_^1_$IF (IMOD(1).NE.1) GO TO 105_^1C_'BRANCH NUMBER FOR FLOAT_^1_$IBR = 1_^1C_)FUNCTION INCREMENT FOR FLOAT_^1 110 N = 0_^1C_(MODE IS REAL_^1_$MODE = 2_^1_$GO TO 118_^1C_(BRANCH NUMBER FOR DBLE_^1 112 IBR = 2_^1C_+FUNCTION INCREMENT FOR €€DBLE_^1 114 N = 6_^1C_(MODE IS DOUBLE PRECISION_^1 116 MODE = 3_^1 118 ASSIGN 700 TO IFLOAT_^1_$GO TO 600_^1C_(EXPONENT IS DOUBLE PRECISION (SECOND BRANCH)_^1C_)JUMP VARIABLE IS NOT REAL THEN IT IS INTEGER_^1 120 IF (IMOD(1).NE.2) GO TO 124_^1C_'DOUBLE PRECISON EXPONENT AND REAL VARIABLE_^1C_0BRANCH NUMBER FOR DBLE_^1_$IBR = 1_^1_$GO TO 114_^1C_'DOUBLE PRECISION EXPONENT AND IN€€TEGER VARIABLE_^1C_*BRANCH NUMBER FOR DFLT_^1 124 IBR = 1_^1C_)FUNCTION INCREMENT FOR DFLT_^1 126 N = 4_^1_$GO TO 116_^1C_'****_!FIRST BRANCH IS EXPONENT ****_^1C_)JUMP IF EXPONENT NOT INTEGER_^1 140 IF (IMOD(1).NE.1) GO TO 142_^1 141 MODE = IMOD(2)_^1_$GO TO 500_^1C_)JUMP IF EXPONENT NOT REAL THEN IT IS DOUBLE PRECISION_^1 142 IF (IMOD(1).NE.2) GO TO 144_^1C_(EXPONENT IS REAL€€ (FIRST BRANCH)_^1C_/IF VARIABLE NOT INTEGER THEN RETURN_^1_$IF (IMOD(2).NE.1) GO TO 141_^1C_)BRANCH NUMBER FOR FLOAT_^1_$IBR = 2_^1_$GO TO 110_^1C_'DOUBLE PRECISION EXPONENT (FIRST BRANCH)_^1C_#JUMP IF VARIABLE IS REAL_^1 144 IF (IMOD(2).EQ.2) GO TO 112_^1C_'VARIABLE IS INTEGER_^1C_)BRANCH NUMBER FOR DFLT_^1_$IBR = 2_^1_$GO TO 126_^1C_#JUMP IF OPERATOR NOT NON-REORDERABLE INTEGE€€R DIVIDE_^1C_8END_6***** FTN 3.1 *****_^1C_'CORRECT FALSE INDICATION OF INTEGER DIVIDE_^1 150 IF(IOP.NE.14) GO TO 160_^1C_#SET OPERATOR TO *_^1_$NOP(LEVEL) = 13_^1_$IBUF2(LO) = 13_^1_$IOP = 13_^1C_'ARITHMETIC OPERATORS +-*/_^1 160 ASSIGN 170 TO IFLOAT_^1C_#MIXED MODE VALUES ARE 3,5,6,7_^1C_#I = NUMBER OF BRANCHES THIS LEVEL_^1_$I = NBRNS (LEVEL)_^1C_'SET FUNCTION INCREMENT FLAGS€€ FOR DBLE AND DFLT OPERANDS_^1_$DO 170 IBR = 1,I_^1C_8BEGIN_4***** FTN 3.1 *****_^1C_#JUMP IF BRANCH IS DOUBLE PRECISION_^1_$IF (IMOD(IBR).EQ.3) GO TO 170_^1C_#JUMP IF BRANCH NOT REAL THEN IT IS INTEGER_^1_$IF (IMOD(IBR).NE.2) GO TO 162_^1C_#JUMP IF MODE IS NOT DOUBLE PRECISION_^1C_'MODE OF 3 MEANS REAL/INTEGER MIXED MODE_^1_$IF (MODE.LE.3) GO TO 170_^1C_#FUNCTION INCREMENT FOR DBL€€E_^1_$N = 6_^1_$GO TO 600_^1C_#FUNCTION INCREMENT FOR FLOAT_^1 162 N = 0_^1C_#MODE GREATER THAN 4 INDICATES INTEGER-DOUBLE PRECISION MIX THEN_^1C_#SET FUNCTION INCREMENT FOR DFLT_^1_$IF (MODE.GT.4) N = 4_^1C_8END_6***** FTN 3.1 *****_^1_$GO TO 600_^1 170 CONTINUE_^1C_8BEGIN_4***** FTN 3.1 *****_^1_$N = 2_^1_$IF(MODE.GT.3) N=3_^1_$MODE = N_^1C_8END_6***** FTN 3.1 *****_^1_$GO TO €€700_^1C_'NO MIXED MODE, CORRECT UNINDICATED INTEGER DIVIDE_^1 400 IF(IOP.NE.13.OR.MODE.NE.1) GO TO 500_^1_$I = NBRNS(LEVEL)_^1_$DO 410 IBR =1,I_^1C_#J=IBUF2 POINTER TO BRANCH DISPLACEMENT_^1_$J = LO + IBR + 1_^1C_#J=IBUF2 POINTER TO BRANCH INVERSE FLAG_^1_$J = LO + IBUF2(J)_^1C_#JUMP IF INVERSE FLAG IS SET_^1_$IF (IBUF2(J).EQ.1) GO TO 420_^1 410 CONTINUE_^1_$GO TO 500_^1 420 N€€OP(LEVEL)= 14_^1_$IBUF2(LO) = 14_^1C_'GO TO NEXT HIGHER LEVEL_^1 500_!LEVEL = LEVEL -1_^1_$IF(LEVEL.LE.0) GO TO 910_^1_$K=1_]_^1C_#IF SUBROUTINE OR FUNCTION K=2_^1_$IF(NOP(LEVEL).GE.18.AND.NOP(LEVEL).LE.21) K =2_^1C_'SET MODE OF THIS BRANCH FOR HIGHER LEVEL, IF NEEDED_^1C_#JUMP IF OPERATOR NOT + - * / **_^1_$IF (NOP(LEVEL).LT.11.OR.NOP(LEVEL).GT.15) GO TO 70_^1_$IF (IOP.GE.18) GO T€€O 60_^1C_#SET MODE OF BRANCH INTO INVERSE FLAG_^1_$IBUF2(LO-1)=MODE*2 +IBUF2(LO-1)_^1_$GO TO 70_^1C_'MOVE INTEGER BRANCH TO IBUF1 TEMPORARILY_^1 600 ITEM= ITEM + 1_^1C_#J=IBUF2 POINTER TO BRANCH DISPLACEMENT_^1_$J = LO +IBR +1_^1C_8BEGIN_4***** FTN 3.1 *****_^1C_#SET FUNCTION INCREMENT INTO BRANCH INVERSE FLAG_^1C_#M=IBUF2 POINTER TO BRANCH INVERSE FLAG_^1_$M = LO + IBUF2(J)_^1C_€€#N = FUNCTION INCREMENT_!0 = FLOAT, 4 = DFLT, 6 = DBLE_^1_$IBUF2(M) = IBUF2(M) + N_^1C_8END_6***** FTN 3.1 *****_^1C_'FIND END OF THIS BRANCH_^1C_#JUMP IF NOT LAST BRANCH OF LEVEL_^1_$IF (IBR.LT.NBRNS(LEVEL)) GO TO 630_^1C_'FIND END OF THIS LEVEL IN TREE_^1C_#LS1 = TEMPORARY LEVEL HOLDER_^1_$LS1 = LEVEL_^1C_#JUMP IF THERE IS A HIGHER LEVEL_^1 610 IF (LS1 .GT.1) GO TO 620_^1C_#I€€N IS IBUF2 POINTER TO END OF BRANCH,LEVEL,TREE,AND IBUF2_^1_%IN = IBUF2X_^1C_#GO STORE BRANCH INTO IBUF1_^1_$GO TO 640_^1C_#LS1 = ONE LEVEL HIGHER IN TREE_^1 620 LS1 = LS1 - 1_^1C_#JUMP IF BRANCH IS LAST THIS LEVEL_^1_$IF (ICBRN(LS1 ).EQ.NBRNS(LS1 )) GO TO 610_^1C_#IXT = IBUF2 POINTER TO LEVEL OPERATOR_^1_$IXT = KOP(LS1 )_^1C_#K=INCREMENT TO SKIP IBUF2 CELL FOR NUMBER OF BRANCHES€€_^1C_#IF SUBROUTINE OR FUNCTION K=2_^1_$K = 1_^1_$IF(NOP(LS1 ).GE.18.AND.NOP(LS1 ).LE.21) K=2_^1C_#IN = IBUF2 POINTER TO BRANCH DISPLACEMENT_^1_%IN = IXT + ICBRN(LS1 ) + K_^1C_#IN = IBUF2 POINTER TO END OF BRANCH IN NEW LEVEL_^1_%IN = IXT + IBUF2( IN +1) - 1_^1C_#GO STORE BRANCH INTO IBUF1_^1_$GO TO 640_^1 630 IN = LO + IBUF2(J+1) - 1_^1C_#IN = IBUF2 POINTER TO END OF BRANCH_^1C€€_'STORE INTEGER BRANCH_^1C_#K = IBUF2 POINTER TO BEGINNING OF BRANCH_^1 640 K = LO + IBUF2(J)_^1C_'IRBR(ITEM) = IBUF1 POINTER TO BEGINNING OF STORAGE LOCATION_^1_$IRBR(ITEM) = IBUF1X_^1C_8BEGIN_4***** FTN 3.1 *****_^1C_'TEST FOR DOUBLE PRECISION ITEMS_^1C_'ICNT1 = DFLT ITEM COUNTER, ICNT2 = DBLE COUNTER_^1_$IF (N .EQ. 4) ICNT1 = ICNT1 + 1_^1_$IF (N .EQ. 6) ICNT2 = ICNT2 + 1_^1C_'A€€DD DBLE OPERAND LENGTH TO DBLE STRING LENGTH COUNTER_^1_$IF (N .EQ. 6) IDBLEN = IDBLEN + IN-K+1_^1C_8END_6***** FTN 3.1 *****_^1_$DO 650 IXT = K, IN_^1_$IBUF1(IBUF1X) =IBUF2(IXT)_^1 650 IBUF1X = IBUF1X+1_^1C_#JUMP IF NO PREVIOUS BRANCH STORED IN IBUF1_^1_$IF (NDBK.EQ.0) GO TO 680_^1C_)JUMP IF PREVIOUS BRANCH TRANSFERRED WAS ADJACENT TO THIS ONE_^1_$IF (NDBK.EQ.K-1) GO TO 690_^1C_€€'MOVE SUBSEQUENT BRANCHES TO FILL PREVIOUS GAP_^1C_8BEGIN_4***** FTN 3.1 *****_^1C_'IN IBUF2 LEFT BY TRANSFER OF PREVIOUS BRANCH_^1C_'IXT = IBUF2 POINTER TO FIRST WORD AFTER GAP LEFT BY PRIOR_^1C_'TRANSFER_^1C_'NDBK= IBUF2 POINTER TO END OF GAP_^1_$IXT = NDBK + 1_^1C_'IF LAST BRANCH TRANSFERRED IS LAST IN IBUF2 ADJUST IBUF2X,IN,_^1C_'AND LOX_^1_$IF (IN.NE.IBUF2X) GO TO 655_^1_$IN =€€ K-1_^1_$IBUF2(LOX) = IBUF2(LOX) + IN - IBUF2X_^1_$IBUF2X = IN_^1C_'K=IBUF2 POINTER TO BEGINNING OF GAP LEFT BY TRANSFER OF_^1C_'PREVIOUS BRANCHES_^1 655 K = IBK_^1C_'MOVE SUBSEQUENT BRANCHES UP TO FILL GAP_^1C_8END_6***** FTN 3.1 *****_^1_$DO 660 IXT = IXT, IN_^1_$IBUF2(K) = IBUF2(IXT)_^1 660 K = K + 1_^1C_'ADJUST BRANCH POINTERS IN THIS LEVEL_^1C_'IXT = IBUF2 POINTER TO SUBSEQU€€ENT BRANCH DISPLACEMENTS_^1C_'LRELEN = IBUF2 POINTER TO PREVIOUSLY TRANSFERRED BRANCH_^1C_'DISPLACEMENT_^1_$IXT = LRELEN + 1_^1_$LS1 = LO + IBR_^1C_'LS1 = IBUF2 LIMIT OF BRANCH DISPLACEMENTS TO BE ADJUSTED IT_^1C_'DOES NOT INCLUDE CURRENT BRANCH DISPLACEMENT_^1_$IT = NDBK + 1 - IBK_^1C_'IT = NUMBER OF WORDS IN GAP - ADJUSTMENT VALUE_^1_$DO 670 IXT = IXT, LS1_^1 670 IBUF2 (IXT) =€€ IBUF2 (IXT) - IT_^1C_'IBK = IBUF2 POINTER TO BEGINNING OF NEW GAP IN IBUF2_^1 680 IBK = K_^1C_8BEGIN_4***** FTN 3.1 *****_^1C_'LRELEN = IBUF2 POINTER TO DISPLACEMENT OF BRANCH JUST_^1C_'TRANSFERRED TO IBUF1_^1 690 LRELEN = LO + IBR + 1_^1C_'NDBK = IBUF2 POINTER TO END OF BRANCH JUST TRANSFERRED = GAP_^1C_'IF TRANSFERRED BRANCH WAS LAST IN IBUF2 THEN NDBK = POINTER TO_^1C_'END OF€€ IBUF2_^1_$NDBK = IN_^1C_'J=IBUF2 POINTER TO CURRENT BRANCH DISPLACEMENT_^1C_8END_6***** FTN 3.1 *****_^1_$IBUF2(J) = 0_^1_$GO TO IFLOAT_^1C_'NOW START INSERTING FUNCTION BRANCHES FLOAT, DFLT, AND/OR DBLE_^1C_'IF ALL OPERANDS IN A FUNCTION STRING ARE INVERSE THEN FUNCTION_^1C_'BECOMES INVERSE AND OPERANDS NORMAL_^1C_'IBUF1X POINTS TO LAST WORD IN IBUF1_^1 700 IBUF1X = IBUF1X -1_^€€1C_'STORE LEVEL OPERATOR INTO IBUF1_^1_$IBUF1(7) = IOP_^1C_8BEGIN_4***** FTN 3.1 *****_^1C_'JUMP IF A FLOAT STRING OR NO DBLE OPERANDS_^1_$IF (IBUF1(9) .LE. 1 .OR. ICNT2 .EQ. 0) GO TO 745_^1C_'SET FUNCTION OPERATOR FLAG INVERSE_^1_$IBUF1(1) = 1_^1C_'IBUF1(1) = DBLE OPERATOR INVERSE FLAG - IF ALL BRANCHES IN DBLE_^1C_'STRING ARE INVERSE, FLAG WILL REMAIN INVERSE_^1_$DO 1705 I = 1,I€€TEM_^1C_'IN = POINTER TO BRANCH INVERSE FLAG_^1_$IN = IRBR(I)_^1C_'JUMP IF BRANCH IS NOT DBLE_^1_$IF (IBUF1(IN) .LT. 6) GO TO 1705_^1_$IBUF1(1) = AND(IBUF1(1),IBUF1(IN))_^1 1705 CONTINUE_^1C_'SET SYMBOL TABLE POINTER FOR DBLE INTO IBUF1_^1_$IBUF1(3) = $9C_^1C_'JUMP IF AT LEAST ONE DBLE BRANCH IS NORMAL_^1_$IF (IBUF1(1) .EQ. 0) GO TO 1735_^1C_'SET DBLE BRANCH FLAGS TO NORMAL - DBLE €€OPERATOR FLAG IS INVERSE_^1_$DO 1710 I = 1,ITEM_^1_$IN = IRBR(I)_^1_$IF (IBUF1(IN).EQ.7) IBUF1(IN) = 6_^1 1710 CONTINUE_^1C_'TEST FOR NUMBER OF FUNCTION STRINGS_^1C_'JUMP IF NO DFLT OPERANDS ONLY ONE STRING_^1 1735 IF (ICNT1.EQ. 0 ) GO TO 1750_^1C_'JUMP 1 DFLT MEANS 2 STRINGS_^1_$IF (ICNT1_'.EQ. 1) GO TO 1730_^1C_'JUMP IF NO * / STRING MEANS 2 STRINGS_^1_$IF (IOP .NE. 13) GO TO 1€€730_^1C_'TEST FOR DFLT INVERSE BRANCH_^1_$DO 1720 I = ITEM,1,-1_^1_$J = IRBR(I)_^1C_'JUMP IF LAST DFLT BRANCH IS INVERSE MEANS 3 STRINGS_^1_$IF (IBUF1(J).EQ.5) GO TO 1740_^1C_'JUMP IF LAST DFLT BRANCH IS NORMAL MEANS 2 STRINGS_^1_$IF (IBUF1(J).EQ.4) GO TO 1730_^1 1720 CONTINUE_^1 1730 IT = 2_^1_$GO TO 1760_^1 1740 IT = 3_^1_$GO TO 1760_^1 1750 IT = 1_^1C_'ADJUST NUMBER OF BRANCHES €€THIS LEVEL IT=NUMBER OF BRANCHES TO_^1C_'ADD AND ITEM=NUMBER OF BRANCHES TO DELETE_^1 1760 IBUF2(LO+1) = IBUF2(LO+1) + IT - ITEM_^1C_'SAVE TOTAL NUMBER OF ITEMS_^1_$ITEM1 = ITEM_^1C_'SET ITEM TO NUMBER OF DBLE OPERANDS_^1_$ITEM = ICNT2_^1C_'SET INVERSE OPERAND COUNT TO ZERO_^1_$LS1 = 0_^1_$ASSIGN 1765 TO IRETRN_^1C_'GO ADJUST IBUF2 POINTERS FOR TRANSFER_^1_$GO TO 791_^1C_]_^1C_]_^€€1C_'TRANSFER DBLE STRING TO IBUF2_^1C_'JUMP IF THERE ARE DFLT OPERANDS_^1 1765 IF (ICNT1.GT.0_") GO TO 1780_^1C_'ALL ITEMS ARE DBLE OPERANDS - REMOVE DBLE FUNCTION INCREMENT_^1C_'FROM OPERAND INVERSE FLAGS_^1_$DO 1770 I =1,ITEM_^1C_'K=POINTER TO OPERAND INVERSE FLAG IN IBUF1_^1_$K = IRBR(I)_^1_$IBUF1(K) = IBUF1(K)-6_^1 1770 CONTINUE_^1_$GO TO 855_^1C_#MOVE DBLE OPERAND TO IBUF2, DB€€LE FUNCTION HAS ALREADY BEEN MOVED_^1C_'N = IBUF2 POINTER TO OPERATOR IN DBLE STRING_^1 1780 N = IBK-2_^1C_'M = IBUF2 POINTER TO OPERAND STORAGE LOCATION_^1_$M = IBK+ITEM_^1C_]_^1C_'FIND DBLE OPERAND IN IBUF1_^1_$DO 1785 I = 1,ITEM1_^1C_'J=POINTER TO OPERAND INVERSE FLAG IN IBUF1_^1_$J = IRBR(I)_^1C_'JUMP IF OPERAND NOT DBLE_^1_$IF (IBUF1(J).LT.6) GO TO 1785_^1C_'REMOVE DBLE FUNCTI€€ON INCREMENT FROM OPERAND INVERSE FLAG_^1_$IBUF1(J) = IBUF1(J) - 6_^1C_'K=IBUF1 POINTER TO END OF OPERAND_^1_$K = IRBR(I+1) - 1_^1C_'IF OPERAND IS LAST IN IBUF1 THEN END OF IBUF1 IS END OF OPERAND_^1_$IF (J.EQ. IRBR(ITEM1))K = IBUF1X_^1C_'NO DISPLACEMENTS NEEDED IF ONLY ONE DBLE OPERAND_^1_$IF (ICNT2 .NE. 1) GO TO 1773_^1C_'IBK = POINTER TO FREE LOCATION IN IBUF2_^1_$M = IBK_^1_$GO€€ TO 1774_^1C_'SET DISPLACEMENT VALUE INTO IBUF2_^1 1773 IBUF2(IBK) = M-N_^1C_'IBK = IBUF2 POINTER TO FUTURE LOCATION FOR DISPLACEMENT VALUE_^1_$IBK = IBK + 1_^1C_'TRANSFER OPERAND TO IBUF2 FROM IBUF1_^1C_,JUMP WHEN TRANSFER COMPLETED_^1 1774 IF (J .GT. K) GO TO 1785_^1_$IBUF2(M) = IBUF1(J)_^1C_'M = POINTER TO NEXT STORAGE LOCATION IN IBUF2_^1_$M = M+1_^1C_'J = POINTER TO NEXT WORD €€OF OPERAND IN IBUF1_^1_$J = J+1_^1_$GO TO 1774_^1 1785 CONTINUE_^1C_'IBK = IBUF2 POINTER FOR START OF DFLT STRING_^1_$IBK = M_^1C_'ITEM = COUNT OF DFLT OPERANDS_^1_$ITEM = ICNT1_^1C_'IBR = IBUF2 POINTER FOR DFLT DISPLACEMENT VALUE_^1_$IBR = IBR+1_^1C_'NDBK = POINTER TO END OF DBLE STRING IN IBUF2_^1_$NDBK = IBK - 1_^1C_]_^1C_'FILL IBUF1 GAPS LEFT BY TRANSFER OF DBLE OPERANDS_^1_$DO€€ 1805 I =1,ITEM1_^1C_'I=POINTER TO IBUF1 POINTER IN IRBR_^1C_'J=POINTER TO OPERAND INVERSE FLAG IN IBUF1_^1_$J = IRBR(I)_^1C_'SEARCH FOR DBLE OPERAND GAP_^1_$IF (IBUF1(J).GT.1) GO TO 1805_^1C_'JUMP IF END OF GAP IS END OF IBUF1 - NO IRBR POINTER ADJUSTMENT_^1C_'REQUIRED_^1_$IF (J .EQ. IRBR(ITEM1)) GO TO 1810_^1C_'CLEAR DBLE POINTER_^1_$IRBR(I) = 0_^1C_'ADJUST POINTERS FOLLOWING PO€€INTER TO DBLE_^1C_'M = IRBR POINTER AFTER DBLE_^1_$M = I + 1_^1C_'K=IBUF1 POINTER TO FIRST WORD OF NEXT OPERAND_^1_$K = IRBR(M)_^1C_'N=ADJUSTMENT VALUE - NUMBER OF WORDS IN GAP_^1_$N = K-J_^1_$DO 1790 M = M,ITEM1_^1 1790 IRBR(M) = IRBR(M)-N_^1C_]_^1C_]_^1C_'CLOSE IBUF1 GAP_^1_$DO 1795 K = K,IBUF1X_^1C_'J = IBUF1 POINTER TO FIRST WORD OF GAP_^1_$IBUF1(J) = IBUF1(K)_^1 1795 J=J+1_^1_€€$IBUF1X = IBUF1X - N_^1 1805 CONTINUE_^1_$GO TO 1815_^1C_'ADJUST IBUF1X - LAST OPERAND WAS DBLE_^1 1810 IBUF1X = J-1_^1C_)FIND CLEARED DBLE POINTER IN IRBR_^1 1815 I = 1_^1_$IRBRS = ITEM1_^1 1817 IF (I .GT.IRBRS) GO TO 1830_^1C_'JUMP IF THIS IS NOT A CLEARED DBLE POINTER_^1_$IF (IRBR(I).GT.0) GO TO 1825_^1C_'J = IRBR POINTER TO IBUF1 POINTER TO DBLE OPERAND_^1_$J = I_^1C_'K = IRBR €€PONTER TO NEXT IBUF1 POINTER_^1_$K=I+1_^1C_'MOVE IRBR UP TO REMOVE CLEARED DBLE POINTER_^1_$DO 1820 K=K,ITEM1_^1_$IRBR(J) = IRBR(K)_^1 1820 J = J+1_^1_$IRBRS = IRBRS - 1_^1_$GO TO 1817_^1 1825 I = I+1_^1_$GO TO 1817_^1C_'ADJUST IBUF2 POINTERS AT THIS LEVEL FOR SECTION OF IBUF2 MOVED_^1C_'JUMP IF NO POINTER ADJUSTMENT REQUIRED IN IBUF2_^1 1830 IF (IT .EQ. 0) GO TO 745_^1_$IXT = LO+1€€+IBUF2(LO+1)_^1_$DO 1835 I = IBR,IXT_^1 1835 IBUF2(I) = IBUF2(I) + IT_^1_$GO TO 745_^1C_]_^1C_'WE HAVE FINISHED PROCESSING DBLE OPERANDS_^1C_]_^1C_]_^1C_'BEGIN DFLT PROCESSING_^1C_'SET FUNCTION SYMBOL TABLE POINTER INTO IBUF1_(FLOAT_^1 745 IBUF1(3) = $92_^1C_'ICNT1 = NUMBER OF DFLT OPERANDS_4DFLT_^1_$IF (ICNT1.GT.0) IBUF1(3) = $97_^1C_'TEST IBUF1 OPERAND INVERSE FLAGS_^1C_'SET FUN€€CTION OPERATOR INVERSE FLAG TO ONE_^1C_8END_6***** FTN 3.1 *****_^1 746 IBUF1(1) = 1_^1C_'K=OPERAND INVERSE SWITCH_^1_$K = 0_^1_$DO 750 I = 1,ITEM_^1C_'IN = IBUF1 POINTER TO BRANCH INVERSE FLAG_^1_$IN = IRBR(I)_^1C_8BEGIN_4***** FTN 3.1 *****_^1C_'REMOVE DFLT FUNCTION VALUE FROM INVERSE FLAG_^1_$IF (IBUF1(IN).GE.4) IBUF1(IN) = IBUF1(IN) - 4_^1C_8END_6***** FTN 3.1 *****_^1_$K = OR€€(K, IBUF1(IN))_^1 750 IBUF1(1) = AND (IBUF1(1),IBUF1(IN))_^1C_'JUMP IF ONE OR MORE OPERAND INVERSE FLAGS WERE NORMAL_^1_$IF (IBUF1(1).EQ.0) GO TO 770_^1C_'ALL OPERAND INVERS FLAGS ARE INVERSE_^1C_'WE WILL SET OPERAND FLAGS TO NORMAL AND OPERATOR FLAG INVERSE_^1_$DO 760 I = 1, ITEM_^1_$IN = IRBR(I)_^1 760 IBUF1(IN) = 0_^1C_'SET OPERAND INVERSE SWITCH TO ZERO_^1_$K = 0_^1C_'CLEAR€€ INVERSE OPERAND COUNTER_^1 770 LS1 = 0_^1C_'IT = NUMBER OF FUNCTION BRANCHES_^1_$IT = 1_^1C_'JUMP UNLESS INTEGER * / STRING_^1_$IF (K.EQ.0.OR.ITEM.EQ.1.OR.IOP.NE.13) GO TO 790_^1C_'SIGNAL INTEGER DIVIDE_^1_$IBUF1(7) = 14_^1C_'J = POINTER TO FIRST WORD OF LAST OPERAND TRANSFERRED TO IBUF1_^1_$J = IRBR(ITEM)_^1C_'IF OP IS *, LAST BRANCH MUST NOT BE INVERSE_^1_$IF (IBUF1(J).NE.1) GO€€ TO 790_^1C_'FLOAT TWO INTEGER BRANCHES -- FLOAT LAST INVERSE BRANCH (ES)_^1C_,SEPARATELY_^1_$DO 774 I = ITEM,1,-1_^1C_'J = POINTER TO LAST OPERAND IN NORMAL BRANCH_^1_$J = IRBR(I)_^1C_'JUMP IF J POINTS TO NORMAL OPERAND_^1_$IF (IBUF1(J).EQ.0) GO TO 780_^1C_'CHANGE LAST INVERSE BRANCH (ES) TO NON- INVERSE (FLOAT OP WIL_^1C_,BE INVERSE)_^1 774 IBUF1(J) = 0_^1C_'LS1 = NUMBER ITEMS€€ IN INVERSE INTEGER BRANCH_^1 780 LS1 = ITEM - I_^1C_'ITEM = NUMBER ITEMS IN NORMAL INTEGER BRANCH_^1_$ITEM = I_^1C_'IT ALLOWS FOR TWO INTEGER BRANCH POINTERS_^1_$IT = 2_^1C_8BEGIN_4***** FTN 3.1 *****_^1 790 ASSIGN 855 TO IRETRN_^1C_'JUMP IF THERE WERE ANY DBLE OPERANDS - THIS SECTION WAS_^1C_'ALREADY EXECUTED_^1_$IF (ICNT2.GT.0) GO TO 740_^1C_'SET NEW BRANCH COUNT FOR THIS LEVE€€L_^1_$IBUF2(LO+1) = IBUF2(LO+1) + IT - ITEM - LS1_^1C_'J = IBUF2 POINTER TO FIRST BRANCH DISPLACEMENT_^1 791 J = LO + 2_^1C_8END_6***** FTN 3.1 *****_^1_$K = J_^1C_'IXT = IBUF2 POINTER TO LAST BRANCH DISPLACEMENT_^1_$IXT = LO + 1 + NBRNS(LEVEL)_^1C_'REMOVE ZEROED INTEGER BRANCH POINTERS AND ADJUST POINTER VALUE_^1_$DO 710 I=J, IXT_^1C_'JUMP IF DISPLACEMENT POINTER HAS BEEN CLEARED€€_^1_$IF (IBUF2(I).EQ. 0 ) GO TO 710_^1C_'JUMP IF POINTER IS .LE. TO POINTER OF LAST GAP_^1_$IF (I.LE.LRELEN) GO TO 705_^1C_'IBR = POINTER TO FIRST FREE BRANCH DISPLACEMENT SLOT IN IBUF2_^1_$IBR = K_^1C_'K = POINTER TO LAST IBUF2 DISPLACEMENT SLOT REQUIRED_^1_$K = K + IT_^1C_'LRELEN = POINTER TO END OF OPERAND GAP IN IBUF2_^1_$LRELEN = NDBK_^1C_'FILL SLOTS LEFT BY TRANSFERRED OPERAN€€D DISPLACEMENT POINTERS_^1 705 IBUF2(K) = IBUF2(I)_^1_$K = K+1_^1 710 CONTINUE_^1C_'COMPUTE POINTER ADJUSTMENT VALUE_^1C_'JUMP IF POINTER TO END OF LAST OPERAND GAP = POINTER TO END OF_^1C_'CURRENT OPERAND GAP_^1_$IF (LRELEN.EQ.NDBK) GO TO 715_^1C_'IBR = POINTER TO FIRST FREE IBUF2 BRANCH DISPLACEMENT_^1_$IBR = K_^1C_'K = IBUF2 POINTER TO LAST DISPLACEMENT SLOT NEEDED_^1_$K = K €€+ IT_^1C_'IT = POINTER ADJUSTMENT VALUE_^1 715 IT = IXT - K + 1_^1C_'JUMP IF NO ADJUSTMENT REQUIRED_^1_$IF (IT.EQ._#0) GO TO 740_^1C_'IN = POINTER TO IBUF2 SLOT FOR BRANCH DISPLACEMENT_^1_$IN = IBR - 1_^1_$DO 720 I = J, IN_^1C_'ADJUST DISPLACEMENT_^1 720 IBUF2(I) = IBUF2(I) - IT_^1C_'IN = IBUF2 POINTER TO FIRST WORD AFTER DISPLACEMENTS_^1_$IN = K_^1C_'LRELEN = IBUF2 POINTER TO L€€AST WORD OF OPERAND IN IBUF2_^1_$LRELEN = IBK - 1_^1C_'IXT = POINTER TO FIRST WORD OF OPERAND IN IBUF2_^1_$IXT = IXT+ 1_^1C_'FILL LOCATIONS FREED BY ZEROED BRANCH POINTERS_^1_$DO 730 I = IXT, LRELEN_^1_$IBUF2(IN) = IBUF2(I)_^1 730 IN = IN + 1_^1C_'IBK = IBUF2 POINTER TO FIRST WORD OF NEW GAP_^1_$IBK = IBK - IT_^1C_'SET POINTER IN THIS LEVEL TO FUTURE LOCATION OF INTEGER BRANCH_^€€1 740 IBUF2 (IBR) = IBK - LO_^1C_'NDBK = IBUF2 POINTER TO FIRST NEW WORD REQUIRED IN IBUF2_^1_$NDBK = NDBK + 1_^1C_'LRELEN = POINTER TO END OF IBUF1_^1_$LRELEN = IBUF1X_^1C_'IBUF1(8) = NUMBER OF OPERANDS IN BRANCH_^1_$IBUF1(8)=ITEM_^1_$K = ITEM_^1_$IF (K.EQ.1) K = -3_^1C_'IN = POINTER TO FIRST IBUF2 WORD AFTER BRANCH TRANSFER_^1_$IN = IBK + IBUF1X + K_^1C_8BEGIN_4***** FTN 3.1 **€€***_^1C_'IF PROCESSING DBLE STRING, ADD LENGTH OF DBLE STRING NOT_^1C_'LENGTH OF IBUF1_^1_$IF (IBUF1(3) .EQ. $9C)_!IN = IBK+IDBLEN+K_^1C_8END_6***** FTN 3.1 *****_^1C_'JUMP IF ONLY ONE INTEGER BRANCH MUST BE FLOATED_^1C_,(SEE BETWEEN LABELS 770 AND 790)_^1C_'LS1 SHOULD ALWAYS EQUAL 0 WHEN PROCESSING DBLE STRING AT THIS_^1C_'TEST_^1_$IF (LS1.EQ.0) GO TO 798_^1C_'ADJUST IN ASSUMING T€€WO INTEGER BRANCHES_^1C_'K = NUMBER OF INVERSE INTEGER OPERANDS_^1_$K = LS1_^1_$IF (K.EQ.1) K = -3_^1C_'IN = POINTER TO FIRST IBUF2 WORD AFTER BOTH BRANCH TRANSFERS_^1_$IN = IN + 8 + K_^1C_'LRELEN = END OF FIRST INTEGER BRANCH IN IBUF1_^1_$LRELEN = IRBR(ITEM+1) - 1_^1C_'ADJUST IBUF2 TO RECEIVE IBUF1 TRANSFER_^1 798_!J = 1_^1C_'IXT = FIRST INTEGER OPERAND IN THIS BRANCH IN IBUF1_^1_€€$IXT = 9_^1C_'IT = DIFFERENCE BETWEEN OLD AND NEW END OF INTEGER BRANCH_^1_$IT = IN - NDBK_^1_$IF(IT) 820,840,800_^1C_'IF MORE ROOM NEEDED, MOVE REST OF IBUF2 DOWN_^1C_'TEST FOR OFLW OF IBUF2_^1 800 IF (IBUF2X + IT.GT.304) CALL PUNT_^1_%DO 810 I=IBUF2X,NDBK,-1_^1C_'K=NEW POINTER TO END OF IBUF2_^1_%K = I + IT_^1C_'MOVE IBUF2 DOWN TO CREATE MORE SPACE_^1 810 IBUF2 (K) = IBUF2(I)_^€€1_$GO TO 840_^1C_'IF LESS ROOM NEEDED, MOVE END OF IBUF2 UP_^1 820 DO 830 I = NDBK, IBUF2X_^1C_'K=NEW END IN IBUF2 WHICH IS IT LESS THAN OLD END_^1_$K = I + IT_^1 830 IBUF2 (K) = IBUF2(I)_^1 840 IBUF2X = IBUF2X + IT_^1C_'ADJUST NUMBER OF WORDS IN TREE_^1_$IBUF2(LOX) = IBUF2(LOX) + IT_^1C_'INSERT FLOATED INTEGER BRANCH IN IBUF2_^1 844 K = 8_^1C_'OMIT INTEGER BRANCH OP IF ONLY O€€NE INTEGER OPERAND_^1_$IF (ITEM - J .EQ. 0) K = 5_^1C_'FLOAT OP AND INTEGER BRANCH OP_^1_$DO 850 I = 1, K_^1_$IBUF2(IBK) = IBUF1(I)_^1 850 IBK = IBK + 1_^1C_8BEGIN_4***** FTN 3.1 *****_^1C_'IF WE ARE PROCESSING DBLE BRANCH RETURN TO DBLE LOGIC_^1_$GO TO IRETRN_^1C_]_^1C_]_^1C_8END_6***** FTN 3.1 *****_^1C_*OMIT BRANCH POINTERS IF ONLY ONE INTEGER OPERAND_^1C_8BEGIN_4***** FTN 3.1 €€*****_^1 855 IF (ITEM-J.EQ.0) GO TO 864_^1C_8END_6***** FTN 3.1 *****_^1C_'BRANCH POINTERS TO INTEGER OPERANDS_^1_$K = IRBR(J) + J - 3 - ITEM_^1_$DO 860 I = J, ITEM_^1_$IBUF2(IBK) = IRBR(I) - K_^1 860 IBK = IBK + 1_^1C_#TRANSFER INTEGER OPERANDS TO IBUF2_^1 864 DO 870 I = IXT, LRELEN_^1_$IBUF2(IBK)= IBUF1(I)_^1 870 IBK = IBK + 1_^1C_'JUMP IF ONLY ONE INTEGER BRANCH MUST BE FLOA€€TED_^1C_,(SEE BETWEEN LABELS 770 AND 790)_^1_$IF (LS1.EQ.0) GO TO 872_^1C_'SET NEXT POINTER IN THIS LEVEL TO FUTURE LOCATION OF SECOND_^1C_,INTEGER BRANCH_^1C_'IBR = IBUF2 POINTER TO SECOND BRANCH DISPLACEMENT_^1_$IBR = IBR + 1_^1_$IBUF2 (IBR)_!= IBK - LO_^1C_'IXT = FIRST INTEGER OPERAND IN THIS BRANCH IN IBUF1_^1_$IXT = LRELEN + 1_^1C_'LRELEN = END OF SECOND INTEGER BRANCH IN IBUF€€1_^1_$LRELEN = IBUF1X_^1C_'J=OPERAND NUMBER OF FIRST OPERAND IN SECOND BRANCH_^1_$J = ITEM + 1_^1C_'ITEM = TOTAL NUMBER OF INTEGER OPERANDS_^1_$ITEM = LS1 + ITEM_^1C_'OPERATOR IS * BECAUSE NO INVERSES_^1_$IBUF1(7) = 13_^1_$IBUF1(8) = LS1_^1C_'INVERT FLOAT OP_^1_$IBUF1(1) = 1_^1_$LS1 = 0_^1_$GO TO 844_^1C_'IT = IBUF2 BUFFER LENGTH ADJUSTMENT VALUE_^1 872 IF (IT .EQ. 0) GO TO 900_^1€€C_'ADJUST ALL POINTERS TO SECTION OF IBUF2 THAT WAS MOVED_^1C_'IBR = IBUF2 POINTER TO FIRST SLOT AFTER LAST DISPLACEMENT ENTRY_^1C_'FOR TRANSFERRED BRANCH_^1_$IBR = IBR + 1_^1C_'IXT = IBUF2 POINTER TO LAST DISPLACEMENT IN IBUF2_^1_$IXT = LO + 1 + IBUF2(LO+1)_^1C_'ADJUST DISPLACEMENTS FOLLOWING LAST TRANSFERRED BRANCH_^1C_'DISPLACEMENT ENTRY_^1_$DO 875 I = IBR, IXT_^1 875 IBUF2(I) €€= IBUF2(I) + IT_^1C_'LS1 = COUNT OF CURRENT LEVEL_^1_$LS1 = LEVEL_^1C_'JUMP IF AT HIGHEST LEVEL_^1 880 IF (LS1 .LE.1) GO TO 900_^1C_'GO ONE LEVEL HIGHER IN TREE AND ADJUST POINTERS IN NEW LEVEL_^1_$LS1 = LS1 - 1_^1C_'JUMP IF AT END OF LEVEL_^1_$IF (ICBRN(LS1 ).EQ.NBRNS(LS1 )) GO TO 880_^1C_'IXT = POINTER TO OPERATOR THIS LEVEL_^1_$IXT = KOP(LS1 )_^1C_'K = INCREMENT USED TO SKIP€€ TO DISPLACEMENT VALUES_^1_$K = 1_^1C_'DETERMINE IF OPERATOR IS FUNCTION OR SUBROUTINE_^1_$IF (NOP(LS1 ).GE.18.AND.NOP(LS1 ).LE.21) K = 2_^1C_'J = IBUF2 POINTER TO DISPLACEMENT VALUE OF NEXT BRANCH_^1_$J = IXT + ICBRN(LS1 ) + K + 1_^1C_'IN = IBUF2 POINTER TO DISPLACEMENT VALUE OF LAST BRANCH_^1C_'AT THIS LEVEL_^1_$IN = IXT + NBRNS(LS1 ) + K_^1C_'ADJUST DISPLACEMENT POINTERS AT HIG€€HER LEVEL IN TREE_^1_$DO 890 I = J , IN_^1 890 IBUF2(I) = IBUF2(I) + IT_^1_$GO TO 880_^1C_'RE-INITIALIZE AND RETURN TO HIGHER LEVEL_^1C_8BEGIN_4***** FTN 3.1 *****_^1 900 MODE = 3_^1_$IF(ICNT1.EQ.0.AND.ICNT2.EQ.0) MODE = 2_^1_$IDBLEN = 8_^1_$ICNT1 = 0_^1_$ICNT2 = 0_^1C_8END_6***** FTN 3.1 *****_^1_$ITEM = 0_^1_$NDBK = 0_^1_$IBUF1X = 9_^1_$GO TO 500_^1 910_!IBUF2X = IBUF2X + 1_^1_€$END_]_^__ PWASEMP CSY/ 40A P€1_$SUBROUTINE ASEMPR_^1_#*_2/DECK-ID 40A FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^13_]_^1C ASEMPR IS USED IN PHASE A3_^1C_]_^1C_#MASTER LABELED COMMON BLOCK._^1*_] FTN 3.3_^1_$COMMON /A/ IFLAGS,LINECT,LINCT1_^1_$COMMON /A/ IR,IK,IP,IA,IL,IM,IXLGO,I€€OPTO,IOPTV,IOPTC,IOPTD_^1_$COMMON /A/ MCSTRT,MACRNB,MACSEC_^1_$COMMON /A/ IERRS(16),ISRFAD_^1_$COMMON /A/ LGO,ISCRI,ISCRO,IX_^1*_] FTN 3.3_^1_$COMMON /A/ IGLAB(3),IGLAB1,IGLAB2_^1_$COMMON /A/ ICOMT(12),ICOMTS,ICOMX2,ICOMTL,ISUBP,NDPRS,_^1_#$LABX,IBCDTB(48)_^1_$EQUIVALENCE(ICOMB,ICOMT(1)),(ICOMBX,ICOMT(2)),(ICOMDF,_^1_#$ICOMT(3)),(ICOMBN,ICOMT(4))_^1_$DIMENSION ICOMB(6),ICOMBX(6),I€€COMDF(6),ICOMBN(7)_^1_$COMMON /A/ LOOPTS,LOOPTX,LOOPTB,LOOPT(50)_^1_$EQUIVALENCE(LINDUC,LOOPT(1))_^1_$DIMENSION LINDUC(10)_^1_$EQUIVALENCE (LBEG,LOOPT(2))_^1_$DIMENSION LBEG(10)_^1_$EQUIVALENCE (LINC,LOOPT(3))_^1_$DIMENSION LINC(10)_^1_$EQUIVALENCE (LEND,LOOPT(4))_^1_$DIMENSION LEND(10)_^1_$BYTE(LLABL,LOOPT(5)(14=0)_))_^1_$DIMENSION LLABL(10)_^1_$BYTE(LID,LOOPT(5)(15=15) )_^1_$DI€€MENSION LID(10)_^1_$COMMON/A/IEQV(255), IEQVS,IEQVN2_^1_$COMMON /A/ ISTAB(150),ISTABS,ISTAB2_^1_$COMMON /A/ IBUFS,ISET(25),LBLANK,KSFCNT,KSNCNT,ISORSC,_^1_#$IHOBIT,ISTNO,ISSFLG,ISUBPN,ITERM,JSORSC,KEQVS_^1C_#SYMBOL TABLE LABELED COMMON BLOCK_^1_$COMMON /A/ ISYMN, ISYMFL,ISYMD,ISYMX,ISYMS,ISYMP,ISYMPC,ISYMPS,_^1_#$ ISYMNS, SYMTAB(960)_^1_$INTEGER SYMTAB_^1_$BYTE (IDUM,SYMTAB(1)(15=1€€5)),(KDUMY,SYMTAB(1)(15=15)),_^1_#$(ICLASS,SYMTAB(1)(14=11)),(ITYPE,SYMTAB(1)(10=9))_^1_$DIMENSION IDUM(100),KDUMY(100),ICLASS(100),ITYPE(100)_^1_$BYTE (ISNGL, SYMTAB(1)(8=8)),(KELSIZ,SYMTAB(1)(8=8)),_^1_#$ (ICOM,SYMTAB(1)(7=5)),(IPART,SYMTAB(1)(4=3))_^1_$DIMENSION ISNGL(100),KELSIZ(100),ICOM(100),IPART(100)_^1_$BYTE (KRFCNT,SYMTAB(1)(2=2)),(IDIM,SYMTAB(1)(1=0)),_^1_#$ (IREL,SYMTAB€€(1)(1=1)),(IEXT,SYMTAB(1)(0=0))_^1_$DIMENSION KRFCNT(100),IDIM(100),IREL(100),IEXT(100)_^1_$EQUIVALENCE (IRSA,SYMTAB(2)),(ICOMTX,SYMTAB(2)),(ISNOL,SYMTAB(2))_^1_$DIMENSION IRSA(100), ICOMTX(100),ISNOL(100)_^1_$BYTE (IDATAS,SYMTAB(3)(15=15)),(IREF,SYMTAB(3)(15=15)),_^1_#$ (IEQVX,SYMTAB(3)(14=8)),(ITILF,SYMTAB(3)(14=8))_^1_$DIMENSION IDATAS(100),IREF(100),IEQVX(100),ITILF(100)_^1_$BY€€TE (IPARTR,SYMTAB(3)(7=4)),(INDUCV,SYMTAB(3)(7=7)),(ISFARG,_^1_#$ SYMTAB(3)(6=6)),(IARGNO,SYMTAB(3)(5=0)),(IPARTL,SYMTAB(3)(3=0))_^1_$DIMENSION IPARTR(100),INDUCV(100),ISFARG(100),IARGNO(100),_^1_#$ IPARTL(100)_^1_$EQUIVALENCE (ISYM,SYMTAB(4))_^1_$DIMENSION ISYM(100)_^1C_]_^1C_#SPECIFICATION-TABLE INDEX LABELLED COMMON BLOCK_^1_$COMMON /A/ ISTABX(96)_^1C_]_^1C_#PHASE A BLANK COMMON€€ BLOCK._^1_$COMMON // JSYM(3),JTERM,JMODE,JERR,JESWT,JFLOT,JCHAR,_^1_#$JOCHAR,JO1,JE,JE1,JBLANK,JCT,JCT1_^1C_#JSYM-JCT1 MUST REMAIN IN ORDER_^1_$COMMON//IERR_^1_$COMMON//ISORS(208),ISORSX_^1_$COMMON//IDEFF,ISTOP,IRET,ISPEC,NERR,OCT_^1_$INTEGER OCT_^1_$COMMON//ILLABL,LEST,ISNGL1,ICOMX1,NXTYPE,LOGIF,IOVFL1,IOVFL2_^1_$COMMON//IVCFLG,ISFLG,LOGEX,KEQVX_^1_$COMMON//IBUF2X,IBUF2(304)_^1C_€€$TEMPORARY ARITHMETIC BUFFERS_^1_$COMMON//IBUF1( 304),IBUF1X,IWORK (304)_^1C_#TEMPORARY EQUIVALENCE BUFFERS_^1_$DIMENSION KEQV(460),MEQV(255)_^1_$EQUIVALENCE (KEQV,IBUF1(66)),(MEQV,IBUF2(100))_^1C_#LS1-ITEM MUST REMAIN IN ORDER_^1_$COMMON//LS1,LPREN,LRELRQ,LRELEN,LSWITC,LO,ITEM_^1_$COMMON//MODE_^1_$COMMON//IPHAT(4),IGNSTT(49),IOSPRT(17)_^1C_]_^1C_]_^1C_]_^1C_#THIS ROUTINE PROCESSES€€ THE ASSEM STATEMENT._^1_$DATA IDECTR,IMODE/-1,0/_^1C_]_^1C_#INSERT TYPE NO. FOR 16 BIT REL. ADDR. CONSTANT_^1C_(INTO INTERMEDIATE LANGUAGE_^1C_]_^1 201 IBUF2(IBUF2X) = 5_^1C_]_^1C_#CLEAR INDIRECT ADDRESS SWITCH_^1C_]_^1_$IMODE = 0_^1C_]_^1C_#INITIALIZE NET INCR. WORD FOR INCREMENT = 0_^1C_]_^1_$IBUF2(IBUF2X+2) = 0_^1_"1 ITEMP1 = ISORSX_^1_$CALL GETC_^1C_]_^1C_#TEST FOR AND JUMP €€IF NULL FIELD_^1C_]_^1_$IF (JCHAR.GT.35) GO TO 2_^1 206 ISORSX = ITEMP1_^1C_]_^1C_#TEST FOR AND JUMP IF FIELD NUMERIC_^1C_]_^1_$IF (JCHAR.LT.10) GO TO 3_^1_$CALL GETF_^1C_]_^1C_#RECORD POINTER TO SYMBOL TABLE ENTRY WITH NAME_^1C_]_^1_$IBUF2(IBUF2X+1) = ISYMP + ISYMX_^1C_]_^1C_#IF ADDR. CONST. HAS INCR., FIELD TERM = LEFT PAR_^1C_]_^1_$IF (JTERM.EQ.41) GO TO 14_^1_$ASSIGN 14 TO JUM€€PSW_^1C_]_^1C_#TEST FOR AND JUMP IF INDIRECT ADDRESSING_^1C_]_^1 200 IF (IMODE.EQ.1) GO TO 300_^1C_]_^1C_#TEST FOR AND JUMP IF FIELD TERMINATOR IS_^1C_(RIGHT PARENTHESIS_^1C_]_^1_$IF (JTERM.EQ.42) GO TO 7_^1_$GO TO JUMPSW_^1C_]_^1C_#TEST FOR AND JUMP IF FIELD TERMINATOR IS NOT_^1C_(RIGHT PARENTHESIS_^1 300 IF (JTERM.NE.42) GO TO 7_^1C_]_^1C_#CLEAR INDIRECT ADDRESSING FLAG_^1C_]_^€€1_$CALL GETC_^1C_]_^1C_#TEST FOR AND JUMP IF FIELD TERMINATOR IS_^1C_(LEFT PARENTHESIS_^1C_]_^1_$IF (JCHAR.EQ.41) GO TO 7_^1_$JTERM = JCHAR_^1_$GO TO JUMPSW_^1 207 CALL DIAG(71)_^1_$RETURN_^1C_]_^1C_#TEST FOR AND JUMP IF SYMBOL IN TABLE, OTHERWISE-_^1C_]_^1_!14 IF (ISYMD.NE.0) GO TO 301_^1C_]_^1C_#RECORD IN SYMBOL TABLE AND CLASSIFY_^1C_]_^1_$CALL STORE_^1_$ITYPE(ISYMX) = JESWT_€€^1_$GO TO 208_^1C_]_^1C_#TEST FOR AND JUMP TO ERROR EIXT IF EITHER -_^1C_]_^1C_(1. MODE OF ADDRESSING IS 16 BIT ABSOLUTE_^1C_,AND ADDRESS CONSTANT APPEARS IN COMMON_^1C_]_^1C_#OR -_]_^1C_]_^1C_(2. MODE OF ADDRESSING IS 15 BIT RELATIVE_^1C_,AND VARIABLE IS NAME OF EXTERNAL._^1C_]_^1 301 IF (IBUF2(IBUF2X).NE.4.AND.ICOM(ISYMX)+IDUM(ISYMX).NE.0._^1_#1_"OR.IBUF2(IBUF2X).LT.4.AND._^1_€€#2_"ICLASS(ISYMX).EQ.0.AND.IEXT(ISYMX).NE.0)_^1_#3_"GO TO 207_^1 208 IF (ICLASS(ISYMX) + IEXT(ISYMX).EQ.0) ICLASS(ISYMX) = 1_^1C_]_^1C_#TEST FOR AND JUMP IF ADDRESS DOES NOT HAVE_^1C_(INCREMENT, OTHERWISE -_^1C_]_^1_$IF (JTERM.NE.41) GO TO 18_^1C_]_^1C_#EXTRACT INCREMENT FROM SOURCE BUFFER_^1C_]_^1_$CALL GETF_^1C_]_^1C_#TEST FOR AND JUMP IF EITHER -_^1C_(1. NOT INTEGER CONSTANT, O€€R -_^1C_(2. FIELD TERMINATOR NOT RIGHT PARENTHESIS._^1C_]_^1_$IF (JMODE.NE.3.OR.JTERM.NE.42) GO TO 7_^1C_]_^1C_#INCREASE COLUMN COUNTER AND GET NEXT CHARACTER_^1C_]_^1_$CALL GETC_^1_$JTERM = JCHAR_^1_$ASSIGN 17 TO JUMPSW_^1_$GO TO 200_^1_!17 JSYM(1) = JSYM(1) - 1_^1C_]_^1C_#RETRIEVE PAGE IN SYMBOL TABLE WITH NAME_^1C_]_^1_$ISYMX = IBUF2(IBUF2X+1)_^1_$CALL GETSYM_^1C_]_^1C_#DOUBLE S€€IZE OF INCREMENT FOR ELEMENT LENGTH_^1C_(IF IT IS EITHER -_^1C_]_^1C_8BEGIN_4***** FTN 3.1 *****_^1C_(1. REAL CONSTANT,_^1C_]_^1C_(OR -_^1C_]_^1C_(2. NON-SINGLE INTEGER CONSTANT, AND_^1C_,ASA OPTION IS SELECTED_^1C_]_^1C_8END_6***** FTN 3.1 *****_^1C_]_^1C_8BEGIN_4***** FTN 3.1 *****_^1_$IF (ITYPE(ISYMX).EQ.2.OR.(ITYPE(ISYMX).EQ.1.AND.IK.NE.0.AND._^1_#-_"ISNGL(ISYMX).EQ.0)) JSYM(€€1) = JSYM(1)*2_^1C_]_^1C_#TRIPLE SIZE OF INCREMENT FOR ELEMENT LENGTH_^1C_(IF IT IS DOUBLE PRECISION_^1_$IF (ITYPE(ISYMX).EQ.3) JSYM(1)=JSYM(1)*3_^1C_8END_6***** FTN 3.1 *****_^1C_]_^1C_#RECORD INCREMENT IN OUTPUT ENTRY_^1C_]_^1_$IBUF2(IBUF2X+2) = JSYM(1)_^1_$GO TO 18_^1C_]_^1C_#BEGIN HERE TO PROCESS STATEMENT LABEL AS_^1C_(ADDRESS CONSTANT._^1C_]_^1_"3 CALL RDLABL_^1C_]_^1C_#RECOR€€D POINTER TO SYMBOL TABLE ENTRY WITH NAME_^1C_]_^1_$IBUF2(IBUF2X+1) = ISYMX + ISYMP_^1C_]_^1C_#IF LABEL IS NOT IN SYMBOL TABLE, RECORD IT_^1C_(AND ASSIGN CLASSIFICATION_^1C_]_^1_$IF (ISYMD.NE.0) GO TO 303_^1_$CALL STORE_^1_$ICLASS(ISYMX) = 7_^1 303 ASSIGN 18 TO JUMPSW_^1_$GO TO 200_^1C_]_^1C_#COMPUTE NET INCREMENT VALUE IF 15 BIT MODE OF_^1C_(ADDRESSING IS USED._^1C_]_^1_!18 IF (I€€BUF2(IBUF2X)-4.GE.0) GO TO 19_^1C_]_^1C_#GIVE ERROR DIAGNOSTIC IF DECTRMENT CTR. NEGATIVE_^1C_(OTHERWISE COMPUTE VALUE FOR NET INCREMENT_^1C_]_^1_$IF (IDECTR.LT.0) GO TO 203_^1_$IBUF2(IBUF2X+2) = IBUF2(IBUF2X+2) + IDECTR_^1_!19 CONTINUE_^1C_]_^1C_#INCREASE WORD COUNT FOR OUTPUT ENTRY_^1C_]_^1_!20 IBUF2X = IBUF2X + 3_^1C_]_^1C_#INCREASE DECREMENT COUNTER IF ALREADY POSITIVE_^1C_]_^1€€_!21 IF (IDECTR.GE.0) IDECTR = IDECTR+1_^1C_]_^1C_#IF FIELD TERMINATOR IS COMMA, GO BACK TO PROCESS_^1C_(NEXT ADDR. CONST. IN STATEMENT_^1C_]_^1_"5 IF (JTERM.EQ.43) GO TO 201_^1C_]_^1C_#GO TO ERROR EXIT IF FIELD TERMINATOR NOT EOS._^1C_]_^1_$IF (JTERM.NE.47) GO TO 7_^1C_]_^1C_#INSERT WORD LENGTH OF OUTPUT ENTRY INTO 1ST_^1C_(WORD OF OUTPUT BUFFER._^1C_]_^1_$IBUF2(1) = IBUF2X-1_^1_$€€RETURN_^1 203 CALL DIAG(103)_^1_$GO TO 19_^1C_]_^1C_#BEGIN HERE TO PROCESS NULL FIELD IN SOURCE_^1C_(STATEMENT, OR GO TO ERROR EXIT IF IT IS_^1C_(ILLEGAL TO HAVE NULL FIELD._^1C_]_^1_"2 IF (IBUF2(IBUF2X).NE.5) GO TO 7_^1C_]_^1C_#JUMP IF NEXT FIELD CONTAINS HEXADECIMAL CONST._^1C_(PRECEDED BY DOLLAR SIGN_^1C_]_^1_$IF (JCHAR.EQ.36) GO TO 9_^1_$IF (JCHAR.NE.38) GO TO 10_^1C_]_^1C_#IN€€SERT APPROPRIATE TYPE NUMBER INTO OUTPUT_^1C_(ENTRY FOR ABSOLUTE ADDRESS CONSTANT IN_^1C_(NEXT FIELD PRECEDED BY PLUS SIGN. THEN GO_^1C_(BACK TO PROCESS ADDRESS CONSTANT._^1C_]_^1_$IBUF2(IBUF2X) = 4_^1_$GO TO 1_^1_!10 IF (JCHAR.NE.37) GO TO 205_^1C_]_^1C_#BEGIN TO PROCESS FIELD CONTAINING STATEMENT_^1C_(LABEL PRECEDED BY PERIOD._^1C_]_^1_$CALL RDLABL_^1C_]_^1C_#GO TO ERROR EXIT IF€€ LABEL IN ERROR OR IF_^1C_(MISSING_^1C_]_^1_$IF (ILLABL.EQ.0) GO TO 7_^1C_]_^1C_#JUMP IF LABEL NOT IN SYMBOL TABLE_^1C_]_^1_$IF (ISYMD.EQ.0) GO TO 11_^1C_]_^1C_#JUMP IF LABEL IN SYMBOL TABLE BUT NOT DEFINED_^1C_]_^1_$IF (ISNOL(ISYMX).EQ.0) GO TO 12_^1C_]_^1C_#GIVE DIAGNOSTIC IF LABEL DEFINED MORE THAN ONCE._^1C_(THAN GO TO PROCESS NEXT FIELD._^1C_]_^1_$CALL DIAG(55)_^1_$GO TO 5_^1_€€!11 CALL STORE_^1_$ICLASS(ISYMX) = 7_^1C_]_^1C_#DEFINE LABEL BY ASSIGNING CURRENT STATEMENT NO._^1C_]_^1_!12 ISNOL(ISYMX) = ISTNO_^1C_]_^1C_#INSERT TYPE NO. IN OUTPUT ENTRY_^1C_]_^1_$IBUF2(IBUF2X) = 6_^1C_]_^1C_#INSERT POINTER_^1C_]_^1_$IBUF2(IBUF2X+1) = ISYMP + ISYMX_^1C_]_^1C_#INCREASE WORD COUNT FOR OUTPUT ENTRY_^1C_]_^1_$IBUF2X = IBUF2X + 2_^1_$GO TO 5_^1C_#ERROR EXIT_^1C_]_^1_€€"7 CALL DIAG(25)_^1_%RETURN_^1C_]_^1C_#CONTINUATION OF PROCESSING OF NULL FIELD-_^1C_#GO TO ERROR EXIT IF FIELD TERM CHAR NOT ASTERISK_^1C_]_^1 205 IF (JCHAR.NE.45) GO TO 7_^1C_]_^1C_#SAVE COLUMN COUNTER AND GET NEXT CHARACTER_^1C_]_^1_$ITEMP1 = ISORSX_^1_$CALL GETC_^1_$IF (JCHAR.NE.41) GO TO 304_^1C_]_^1C_#CURRENT FIELD CONTAINS ADDR. CONST. FOR 15 BIT_^1C_(INDIRECT MODE OF ADDRE€€SSING_^1C_#SET SWITCH TO INDICATE INDIRECT ADDRESSING AND_^1C_(INSERT APPROPRIATE TYPE NO. INTO OUTPUT ENT._^1C_(GO TO PROCESS ADDRESS CONSTANT._^1C_]_^1_$IMODE = 1_^1_$IBUF2(IBUF2X) = 3_^1_$GO TO 1_^1 304 IF (JCHAR.NE.43) GO TO 306_^1C_]_^1C_#RESET DECREMENT COUNTER. GO BACK TO PROCESS_^1C_(NEXT FIELD._^1C_]_^1_$IDECTR = 0_^1_$GO TO 1_^1C_#GO TO ERROR EXIT IF CURRENT FIELD DOES €€NOT_^1C_(CONTAIN ADDRESS CONSTANT FOR 15 BIT RELATIVE_^1C_(AND DIRECT MODE OF ADDRESSING. OTHERWISE,-_^1C_]_^1 305 IF (JCHAR.GT.35) GO TO 7_^1C_]_^1C_(INSERT APPROPRIATE TYPE NO. INTO OUTPUT ENT._^1C_]_^1_$IBUF2(IBUF2X) = 2_^1_$GO TO 206_^1C_]_^1C_#BEGIN HERE TO PROCESS HEXADECIMAL CONSTANT_^1C_]_^1_"9 ISORSX = ITEMP1_^1_$CALL GETF_^1C_]_^1C_#GO TO ERROR EXIT IF CURRENT FIELD DOE€€S NOT_^1C_(CONTAIN INTEGER CONSTANT_^1C_]_^1_$IF (JMODE.NE.3) GO TO 7_^1C_]_^1C_#INSERT VALUE OF HEX CONST AND TYPE NUMBER_^1C_(INTO OUTPUT ENTRY, THAN GO PROCESS FIELD_^1C_]_^1_$IBUF2(IBUF2X+1) = JSYM(1)_^1_$IBUF2(IBUF2X) = 1_^1C_]_^1C_#INCREASE WORD COUNT FOR OUTPUT ENTRY_^1C_]_^1_$IBUF2X = IBUF2X + 2_^1_$GO TO 21_^1 306 IF (JCHAR.NE.47) GO TO 305_^1C_]_^1C_#RESET DECREMENT COUN€JTER AND EXIT_^1C_]_^1_%IDECTR = 0_^1_$IBUF2(1) = IBUF2X - 1_^1_$END_]_^__ JPWTREE CSY/ 41A P€1_$SUBROUTINE TREE_^1_#*_2/DECK-ID 41A FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^13_]_^1C TREE IS USED IN PHASE A4_^1C MIXED MODE ARITHMETIC IS HANDLED BY 'ARITH' IN THE 2.0B VERSION._^1C_]_^1C_]_^1C_#MASTER LABELED COMMON BLOCK._^1*_] FTN 3.3_^1_$C€€OMMON /A/ IFLAGS,LINECT,LINCT1_^1_$COMMON /A/ IR,IK,IP,IA,IL,IM,IXLGO,IOPTO,IOPTV,IOPTC,IOPTD_^1_$COMMON /A/ MCSTRT,MACRNB,MACSEC_^1_$COMMON /A/ IERRS(16),ISRFAD_^1_$COMMON /A/ LGO,ISCRI,ISCRO,IX_^1*_] FTN 3.3_^1_$COMMON /A/ IGLAB(3),IGLAB1,IGLAB2_^1_$COMMON /A/ ICOMT(12),ICOMTS,ICOMX2,ICOMTL,ISUBP,NDPRS,_^1_#$LABX,IBCDTB(48)_^1_$EQUIVALENCE(ICOMB,ICOMT(1)),(ICOMBX,ICOMT(2)),(ICOM€€DF,_^1_#$ICOMT(3)),(ICOMBN,ICOMT(4))_^1_$DIMENSION ICOMB(6),ICOMBX(6),ICOMDF(6),ICOMBN(7)_^1_$COMMON /A/ LOOPTS,LOOPTX,LOOPTB,LOOPT(50)_^1_$EQUIVALENCE(LINDUC,LOOPT(1))_^1_$DIMENSION LINDUC(10)_^1_$EQUIVALENCE (LBEG,LOOPT(2))_^1_$DIMENSION LBEG(10)_^1_$EQUIVALENCE (LINC,LOOPT(3))_^1_$DIMENSION LINC(10)_^1_$EQUIVALENCE (LEND,LOOPT(4))_^1_$DIMENSION LEND(10)_^1_$BYTE(LLABL,LOOPT(5)(1€€4=0)_))_^1_$DIMENSION LLABL(10)_^1_$BYTE(LID,LOOPT(5)(15=15) )_^1_$DIMENSION LID(10)_^1_$COMMON/A/IEQV(255), IEQVS,IEQVN2_^1_$COMMON /A/ ISTAB(150),ISTABS,ISTAB2_^1_$COMMON /A/ IBUFS,ISET(25),LBLANK,KSFCNT,KSNCNT,ISORSC,_^1_#$IHOBIT,ISTNO,ISSFLG,ISUBPN,ITERM,JSORSC,KEQVS_^1C_#SYMBOL TABLE LABELED COMMON BLOCK_^1_$COMMON /A/ ISYMN, ISYMFL,ISYMD,ISYMX,ISYMS,ISYMP,ISYMPC,ISYMPS,_^1_€€#$ ISYMNS, SYMTAB(960)_^1_$INTEGER SYMTAB_^1_$BYTE (IDUM,SYMTAB(1)(15=15)),(KDUMY,SYMTAB(1)(15=15)),_^1_#$(ICLASS,SYMTAB(1)(14=11)),(ITYPE,SYMTAB(1)(10=9))_^1_$DIMENSION IDUM(100),KDUMY(100),ICLASS(100),ITYPE(100)_^1_$BYTE (ISNGL, SYMTAB(1)(8=8)),(KELSIZ,SYMTAB(1)(8=8)),_^1_#$ (ICOM,SYMTAB(1)(7=5)),(IPART,SYMTAB(1)(4=3))_^1_$DIMENSION ISNGL(100),KELSIZ(100),ICOM(100),IPART(100)_^1_€€$BYTE (KRFCNT,SYMTAB(1)(2=2)),(IDIM,SYMTAB(1)(1=0)),_^1_#$ (IREL,SYMTAB(1)(1=1)),(IEXT,SYMTAB(1)(0=0))_^1_$DIMENSION KRFCNT(100),IDIM(100),IREL(100),IEXT(100)_^1_$EQUIVALENCE (IRSA,SYMTAB(2)),(ICOMTX,SYMTAB(2)),(ISNOL,SYMTAB(2))_^1_$DIMENSION IRSA(100), ICOMTX(100),ISNOL(100)_^1_$BYTE (IDATAS,SYMTAB(3)(15=15)),(IREF,SYMTAB(3)(15=15)),_^1_#$ (IEQVX,SYMTAB(3)(14=8)),(ITILF,SYMTAB(3)(€€14=8))_^1_$DIMENSION IDATAS(100),IREF(100),IEQVX(100),ITILF(100)_^1_$BYTE (IPARTR,SYMTAB(3)(7=4)),(INDUCV,SYMTAB(3)(7=7)),(ISFARG,_^1_#$ SYMTAB(3)(6=6)),(IARGNO,SYMTAB(3)(5=0)),(IPARTL,SYMTAB(3)(3=0))_^1_$DIMENSION IPARTR(100),INDUCV(100),ISFARG(100),IARGNO(100),_^1_#$ IPARTL(100)_^1_$EQUIVALENCE (ISYM,SYMTAB(4))_^1_$DIMENSION ISYM(100)_^1C_]_^1C_#SPECIFICATION-TABLE INDEX LABELLED€€ COMMON BLOCK_^1_$COMMON /A/ ISTABX(96)_^1C_]_^1C_#PHASE A BLANK COMMON BLOCK._^1_$COMMON // JSYM(3),JTERM,JMODE,JERR,JESWT,JFLOT,JCHAR,_^1_#$JOCHAR,JO1,JE,JE1,JBLANK,JCT,JCT1_^1C_#JSYM-JCT1 MUST REMAIN IN ORDER_^1_$COMMON//IERR_^1_$COMMON//ISORS(208),ISORSX_^1_$COMMON//IDEFF,ISTOP,IRET,ISPEC,NERR,OCT_^1_$INTEGER OCT_^1_$COMMON//ILLABL,LEST,ISNGL1,ICOMX1,NXTYPE,LOGIF,IOVFL1,IOVFL2_€€^1_$COMMON//IVCFLG,ISFLG,LOGEX,KEQVX_^1_$COMMON//IBUF2X,IBUF2(304)_^1C_$TEMPORARY ARITHMETIC BUFFERS_^1_$COMMON//IBUF1( 304),IBUF1X,IWORK (304)_^1C_#TEMPORARY EQUIVALENCE BUFFERS_^1_$DIMENSION KEQV(460),MEQV(255)_^1_$EQUIVALENCE (KEQV,IBUF1(66)),(MEQV,IBUF2(100))_^1C_#LS1-ITEM MUST REMAIN IN ORDER_^1_$COMMON//LS1,LPREN,LRELRQ,LRELEN,LSWITC,LO,ITEM_^1_$COMMON//MODE_^1_$COMMON//IPHAT€€(4),IGNSTT(49),IOSPRT(17)_^1C_]_^1C_]_^1C_#FORM A TREE FROM AN ARITHMETIC EXPRESSION AND PUT IT IN IBUF2_^1_$DIMENSION JDUM1(7)_^1_$EQUIVALENCE(IPERAT,JDUM1(2)),(NLP,JDUM1(3)),(MINUS,JDUM1(4)),_^1_#1(NOOP,JDUM1(5)),(LPSWIT,JDUM1(6)),(IDSW,JDUM1(7)),_^1_#2(ISFLAG,JDUM1(1))_^1C_]_^1C INITIALIZE LOCAL VARIABLES._^1_$LS1=0_^1_$LSWITC=0_^1_$LO=0_]_^1_$LPREN=IBUF1X_^1_$LRELEN=1_^1_$LRELR€€Q=1_^1_$IBUF1X=1_^1_$ISTWK=1_^1C_#SET ARITHMETIC EXPRESSION INDICATOR+MODE OF EXPRESSION_^1_$IBUF2(IBUF2X)=-1_^1_$IF(IBUF2X+3.GT.IBUFS) CALL PUNT_^1_$IBUF2(IBUF2X+2)=MODE_^1_$IBUF2X=IBUF2X+3_^1_$IVM =IBUF2X_^1 1102 DO 1003 I=1,7_^1 1003 JDUM1(I)=0_^1_$ISSX=128_^1 1004 ITEM=IBUF1(IBUF1X)_^1C_#END OF EXPRESSION_^1_$IF(IBUF1X.GE.LPREN)GO TO 1011_^1_$IF(ITEM.LT.22) GO TO 1020_^1_$NLP=€€1_^1_$ASSIGN 1004 TO IAD_^1C_#GET IBUF1 INDEX NECESSARY TO SKIP ENTRY_^1 1016 IF(IBUF1(IBUF1X).LT.25.OR.IBUF1(IBUF1X).EQ.29.OR.IBUF1(IBUF1X).GT._^1_#133) GO TO 1006_^1_$DO 1018 I=1,3_^1_$IF(IBUF1(IBUF1X).EQ.24+I.OR.IBUF1(IBUF1X).EQ.29+I) GO TO (1007,_^1_#11008,1009),I_^1 1018 CONTINUE_^1C_#COMPLEX SUBSCRIPT_^1_$IBUF1X=IBUF1X+3+IBUF1(IBUF1X+3)_^1_$GO TO IAD_^1C_#VARIABLE + CONSTANT€€ SUBSCRIPT_^1 1009 IBUF1X=IBUF1X+1_^1C_#VARIABLE ONLY SUBSCRIPT_^1 1007 IBUF1X=IBUF1X+4_^1_$GO TO IAD_^1C_]_^1C_#ITEM IS AN OPERATOR_^1 1020 IF(IBUF1(IBUF1X+1).LT.ISSX) GO TO 1025_^1_$IF(ITEM.EQ.16) GO TO 1030_^1_$IF(ITEM.EQ.17) GO TO 1040_^1_$IF(IBUF1(IBUF1X+1).NE.ISSX)GO TO 1015_^1_$IF(ISSX.EQ.4) GO TO 5006_^1_$IF(IBUF1(IBUF1X).NE.4) GO TO 1021_^1_$CALL DIAG(4105)_^1_$RETURN_^1C_€€#BUILD IWORK TABLE_^1 1021 IF(LRELRQ.GE.IBUFS)CALL PUNT_^1 1022 IWORK(LRELRQ+1)=IBUF1X_^1_$LRELRQ=LRELRQ+4_^1_$NOOP=NOOP+1_^1_$IPERAT=IBUF1(IBUF1X)_^1_$IF(IPERAT.EQ.14.AND.IBUF1(IBUF1X+2).NE.0)IDSW=1_^1 1015 ASSIGN 1004 TO IAD_^1_$IF(IBUF1(IBUF1X).LT.18.AND.IBUF1(IBUF1X).NE.14)GO TO 1006_^1 1008 IBUF1X=IBUF1X+3_^1_$GO TO IAD_^1C_#LOWER LEVEL OPERATOR FOUND_^1 1025 IF(IBUF1(IBUF1X).€€NE.16) GO TO 1026_^1C_#IF FIRST OPERATOR HAS BEEN ENCOUNTERED,THIS IS IMBEDDED (_^1_$IF(ISFLAG.NE.0) GO TO 1030_^1 1017 ASSIGN 1004 TO IAD_^1 1006 IBUF1X=IBUF1X+2_^1_$GO TO IAD_^1 1026 IF(IBUF1(IBUF1X).NE.11.AND.IBUF1(IBUF1X).NE.12) GO TO 1027_^1C_#IF FIRST NON-( HAS BEEN ENCOUNTERED,DONT SET SWITCHES_^1_$IF(NLP.NE.0) GO TO 1029_^1_$MINUS=1_^1 1028 ISFLAG=1_^1C_#SET FIRST NON-( OPE€€RATOR HAS BEEN ENCOUNTERED SWITCH_^1_$NLP=1_^1C_#RESET IWORK BACK TO START THIS SCAN_^1 1029 LRELRQ=ISTWK_^1_$NOOP=0_^1_$IDSW=0_^1_$ISSX=IBUF1(IBUF1X+1)_^1C_#BUILD IWORK TABLE_^1_$GO TO 1022_^1C_#)_]_^1 1027 IF(IBUF1(IBUF1X).EQ.17) GO TO 1040_^1_$MINUS=0_^1_$GO TO 1028_^1C_#NON-IMBEBDED )-SET COUNT_^1 1040 LPSWIT=1_^1C_#IS THIS END OF EXPRESSION_^1 1042 IF(LPREN.LE.IBUF1X+2)GO TO 1€€041_^1C_#IF NO MORE ),GO PROCESS REST OF EXPRESSION_^1_$IF(IBUF1(IBUF1X+2).NE.17)GO TO 1019_^1C_#MORE )_^1_$IBUF1X=IBUF1X+2_^1_$LPSWIT=LPSWIT+1_^1_$GO TO 1042_^1C_#EXTRANEOUS PARENS-SHORTEN SCAN CONTROLS_^1 1041 LPREN=LPREN-2*LPSWIT_^1_$LRELEN=LRELEN+2*LPSWIT_^1 1011 IF(NOOP.NE.0) GO TO 1050_^1_$IBUF1X=LRELEN_^1 1012 IF(IBUF1(IBUF1X).NE.16) GO TO 1060_^1_$IBUF1X=IBUF1X+2_^1_$GO TO €€1012_^1 1019 MINUS=0_^1C_#NO-RESET LEVEL BACK TO MAXIMUM_^1_$ISSX=128_^1_$GO TO 1017_^1C_#WE FOUND AN IMBEDDED ( - SLEW TO )_^1 1030 ITEM=1_^1 1031 IBUF1X=IBUF1X+2_^1C_#END OF EXPRESSION_^1 1032 IF(IBUF1X.GE.LPREN) GO TO 1011_^1_$IF(IBUF1(IBUF1X).EQ.14)GO TO 1035_^1_$IF(IBUF1(IBUF1X)-16) 1031,1033,1034_^1 1033 ITEM=ITEM+1_^1_$GO TO 1031_^1 1034 IF(IBUF1(IBUF1X).NE. 17) GO TO 103€€5_^1_$ITEM=ITEM-1_^1_$IF(ITEM.EQ.0)GO TO 1017_^1_$GO TO 1031_^1 1035 ASSIGN 1032 TO IAD_^1_$IF(IBUF1(IBUF1X).LT.22) GO TO 1008_^1_$GO TO 1016_^1C_=._^1 1060 ASSIGN 1091 TO IAD_^1C_#IF THIS ISNT FIRST ENTRY IN IBUF2,CHANGE SWITCH_^1_$IF(IBUF2X.NE.IVM) GO TO 1161_^1C_#IF NO PAR SUBROUTINE,DONT PUT IN +1 THING_^1_$IF(IBUF1(IBUF1X).EQ.23)GO TO 1160_^1C_#SET + OF 1 OP IN IBUF2_^1_$IBU€€F2(IBUF2X)=11_^1_$IF(IBUF2X+4.GT.IBUFS) CALL PUNT_^1_$IBUF2(IBUF2X+1)=1_^1_$IBUF2(IBUF2X+2)=3_^1_$IBUF2(IBUF2X+3)=0_^1_$IBUF2X=IBUF2X+4_^1C_#PUT VARIABLE TYPE AND SYMTAB POINTER IN IBUF2_^1 1160 IBUF2(IBUF2X)=IBUF1(IBUF1X)_^1_$IF(IBUF2X+2.GT.IBUFS) CALL PUNT_^1_$IBUF2(IBUF2X+1)=IBUF1(IBUF1X+1)_^1_$IBUF2X=IBUF2X+2_^1_$IF(IBUF1(IBUF1X).LT.25.OR.IBUF1(IBUF1X).EQ.29.OR.IBUF1(IBUF1X).GT€€._^1_#133) GO TO IAD_^1C_#SUBSCRIPT IS AT LEAST ONE WORD LONGER_^1_$IBUF2(IBUF2X)=IBUF1(IBUF1X+2)_^1_$IBUF2X=IBUF2X+1_^1_$IF(IBUF2X.GT.IBUFS)CALL PUNT_^1_$IF(IBUF1(IBUF1X).EQ.28.OR.IBUF1(IBUF1X).EQ.33) GO TO 1061_^1_$IF(IBUF1(IBUF1X).EQ.26.OR.IBUF1(IBUF1X).EQ.31) GO TO IAD_^1_$IBUF2(IBUF2X)=IBUF1(IBUF1X+3)_^1_$IBUF2X=IBUF2X+1_^1_$IF(IBUF2X.GT.IBUFS)CALL PUNT_^1_$IF(IBUF1(IBUF1X).EQ€€.25.OR.IBUF1(IBUF1X).EQ.30) GO TO IAD_^1_$IBUF2(IBUF2X)=IBUF1(IBUF1X+4)_^1_$IBUF2X=IBUF2X+1_^1_$IF(IBUF2X.GT.IBUFS)CALL PUNT_^1_$GO TO IAD_^1 1061 IBUF1X=IBUF1X+4_^1C_#SET STARTING ITEM_^1_$LRELEN=IBUF1X_^1_$GO TO 1102_^1C_#SET EXIT SWITCH TO PROCESS MORE_^1 1161 ASSIGN 1063 TO IAD_^1_$IF(LSWITC.EQ.0)GO TO 1160_^1_$ISYMX=IBUF2(ISAV+1)_^1_$CALL GETSYM_^1_$IF(IARGNO(ISYMX).NE.0.AND.I€€ARGNO(ISYMX).NE.2.AND.IOPTV.EQ._^1_#+0) CALL DIAG(12301)_^1_$IARGNO(ISYMX)=2_^1_$LSWITC=0_^1_$GO TO 1160_^1C_#GET NEXT ENTRY IN WORK TO ANALYZE_^1 1063 LO=0_]_^1C_#IS IWORK EMPTY_^1 1065 IF(LRELRQ.EQ.1)GO TO 1091_^1_$LRELRQ=LRELRQ-4_^1_$IF(IWORK(LRELRQ).GE.0)GO TO 1165_^1_$LS1=LS1-1_^1_$GO TO 1065_^11165 LPREN=IWORK(LRELRQ)_^1_$GO TO 1074_^1C_#SET NUMBER OF WORDS IN EXPRESSION 109€€1_^1 1091 IBUF2(IVM-2)=IBUF2X-IVM_^1C_]_^1C*************************************************************** 83*2485_^1C_#PASS POINTER TO START OF TREE IN ITEM_^1_$ITEM = IVM-3_^1C*************************************************************** 83*2485_^1_$RETURN_^1 1153 CALL DIAG(4106)_^1_$RETURN_^1C_#CHECK SYNTAX OF LOGICAL OPERATORS_^1C_#IF OP IS NOT,SET SWITCH_^1 1050 IF(ISSX.NE.€€3) GO TO 1250_^1_$LS1=LS1+1_^1 1051 IF(LO.GT.1) GO TO 5006_^1_$LO=1_]_^1_$GO TO 1055_^1 1154 LRELRQ=LRELRQ-4_^1_$LRELEN=IWORK(LRELRQ+1)+2_^1_$GO TO 1171_^11250 IF(ISSX.EQ.2.OR.ISSX.EQ.1) GO TO 1251_^1C_#OPERATOR NOT .AND..OR..NOT_^1_$IF(ISSX.EQ.4)GO TO 1052_^1C_#OPERATOR NOT A RELATIONAL_^1_$IF(LO.EQ.1) GO TO 5006_^1C_#NO PRIOR LOGICAL ENCOUNTERED_^1_$LO=3_]_^1C_#IF PREVIOUS OPERA€€TOR WAS FUNC OR SUBR + THIS OPERATOR IS ,_^1C_#COMBINE IBUF2 ENTRY JUST MADE WITH ONE WE ARE ABOUT TO MAKE SO_^1C_#THAT INSTEAD OF_^1C_3FUNCT_^1C_3COMMA_^1C_5X_^1C_#IT SAYS_^1C_3FUNCT_^1C_5X_^1C_#NOT IN A SUB PRG CALL AND OP NOT ,_^1 1055 IF(LSWITC.EQ.0.AND.IPERAT.NE.1) GO TO 1056_^1C_#ERROR IF NOT IN SUBPRGM CALL AND OP IS ,_^1_$IF(LSWITC.EQ.0)GO TO 1153_^1_$ISYMX=IBUF2(ISAV+1)_€€^1_$CALL GETSYM_^1_$IF(IPERAT.NE.1)GO TO 10552_^1C_#CHECK NO.PARAMS THIS CALL VS. ANY PREVIOUS CALLS_^1_$IF(IARGNO(ISYMX).EQ.0)IARGNO(ISYMX)=NOOP+2_^1_$IF(IARGNO(ISYMX).NE.NOOP+2.AND.IOPTV_'.EQ.0)CALL DIAG(12301)_^1_$ASSIGN 1150 TO IAD_^1_$IBUF2X=ISAV+1_^1_$LSWITC=0_^1_$GO TO 1151_^1 1253 IPERAT=IPERAT+1_^1_$GO TO 1252_^1 1254 IPERAT=IPERAT-1_^1_$GO TO 1252_^1 1255 IPERAT=8_^1_$GO €€TO 1252_^1C_#AND,OR_^1 1251 I=LS1/2_^1_$IF(I*2.EQ.LS1) GO TO 1051_^1_$IF(ISSX.EQ.1) GO TO 1256_^1_$IPERAT=3_^1_$GO TO 1051_^1 1256 IPERAT=2_^1_$GO TO 1051_^1C_#OPERATOR IS A RELATIONAL_^1C_#IF .NOT. SWITCH IN EFFECT,SWITCH RELATIONAL TO COMPLEMENT_^1 1052 I=LS1/2_^1_$IF(I*2.EQ.LS1)GO TO 1252_^1_$IF(IPERAT.EQ.9.OR.IPERAT.EQ.6) GO TO 1253_^1_$IF(IPERAT.EQ.10.OR.IPERAT.EQ.7) GO TO 125€€4_^1_$IF(IPERAT.EQ.5) GO TO 1255_^1_$IPERAT=5_^1 1252 IF(LO.GT.1)GO TO 5006_^1_$LO=2_]_^1_$IBUF2(IBUF2X)=IPERAT_^1C_#NO. OPERANDS_^1_$IF(IBUF2X+4.GT.IBUFS)CALL PUNT_^1_$IBUF2(IBUF2X+1)=1_^1C_#POINTER TO OPERAND-BASE OPERATOR_^1_$IBUF2(IBUF2X+2)=3_^1_$IBUF2(IBUF2X+3)=0_^1_$IBUF2X=IBUF2X+4_^1_$I=IWORK(LRELRQ-3)_^1_$IF(IPERAT.EQ.6.OR.IPERAT.EQ.7) GO TO 1053_^1C_#IF WRITTEN A.RL.-B,CHA€€NGE TO .RL. A+B,ELSE MAKE IT .RL.A-B_^1_$IF(IBUF1(I+2).NE.12)GO TO 1057_^1_$IBUF1(I)=11_^1_$IBUF1(I+2)=11_^1_$GO TO 1058_^1 1057 IBUF1(I)=12_^1 1058 IPERAT=11_^1 1054 IBUF1(I+1)=5_^1_$GO TO 1055_^1C_"CHECK NO. PARAMS THIS CALL VS. NO. PARAMS ANY PREVIOUS CALL_^110552 IF(IARGNO(ISYMX).EQ.0)IARGNO(ISYMX)=2_^1_$IF(IARGNO(ISYMX).NE.2.AND.IOPTV_'.EQ.0)CALL DIAG(12301)_^1 1056 LSWITC=0_^€€1C_,._^1C_#MAKE TREE ENTRY FOR OPERATOR_^1_$IF(IPERAT.GT.17.AND.IPERAT.LT.22)GO TO 1059_^1C_#NOT_]_^1_$IF(IPERAT.EQ.4)GO TO 1170_^1_$IF(IPERAT.EQ.11.AND.MINUS.NE.0.AND.NOOP.EQ.1)GO TO 1154_^1_$IF(IPERAT.EQ.12.OR.IPERAT.EQ.14)IPERAT=IPERAT-1_^1_$IF(MINUS.NE.0) GO TO 1070_^1_$ASSIGN 1152 TO IAD_^1 1151 NOOP=NOOP+1_^1_$IF(LRELRQ.GE.IBUFS)CALL PUNT_^1_$GO TO IAD_^1C_$SET ASSUMED COMMA €€OPERATOR_^1 1150 IWORK(LRELRQ+1)=LRELEN-2047_^1_%LRELRQ=LRELRQ+4_^1_$GO TO 1075_^1C_#GT,LE -- CONST IS 12*1024_^1 1157 IPERAT=11_^1_$IWORK(LRELRQ+1)=-12288_^1_$GO TO 1159_^1C_#**--CONST IS 16*1024_^1 1158 IWORK(LRELRQ+1)=-16384_^1C_#IF OPERATOR IS **,ONLY ONE OP ALLOWED_^1_$IF(NOOP .NE.2)GO TO 5007_^1_$GO TO 1159_^1C_#SET +_"OPERATOR FOR -A+B WHEN RELATIONAL IS LE OR GT_^1 1053 I€€BUF1(I)=11_^1_$GO TO 1054_^1 1059 LSWITC=1_^1_$ISAV=IBUF2X_^1_$IBUF2(IBUF2X)=IPERAT_^1_$I=IWORK(LRELRQ-3)+2_^1_$IBUF2(IBUF2X+1)=IBUF1(I)_^1_$IBUF2X=IBUF2X+1_^1_$GO TO 1075_^1 1152 IF(IPERAT.EQ.6.OR.IPERAT.EQ.7) GO TO 1157_^1_$IF(IPERAT.EQ.15) GO TO 1158_^1_$IWORK(LRELRQ+1)= IPERAT*(-1024)_^1 1159 IWORK(LRELRQ+1)=AND(IWORK(LRELRQ+1),$FC00)_^1_$IWORK(LRELRQ+1)=IWORK(LRELRQ+1)+LRELEN_€€^1_$LRELRQ=LRELRQ+4_^1 1070 IF(IDSW.NE.0)IPERAT=14_^1_$IBUF2(IBUF2X)=IPERAT_^1_$ISAV=IBUF2X_^1C_#IBUF2 OVERFLOW TEST_^11075 IF(IBUF2X+2.GT.IBUFS)CALL PUNT_^1_$IBUF2(IBUF2X+1)=NOOP_^1_$IBUF2X=IBUF2X+2_^1_$IF(IWORK(LRELRQ-3).GT.0) GO TO 1172_^1C_#REORDER IWORK TO ASCEND_^1_$I=LRELRQ-3_^1_$J=IWORK(I)_^1 1071 IF(I.EQ.ISTWK+1) GO TO 1072_^1_$IWORK(I) =IWORK(I-4)_^1_$I=I-4_^1_$GO TO 10€€71_^1 1072 IWORK(I)=J_^1 1172 I=ISTWK+2_^1C_#PUT IN IBUF2 SETTINGS FOR OPERAND + OPERATOR IN IWORK_^1 1073 NOOP=NOOP-1_^1_$IWORK(I)=IBUF2X+NOOP_^1_$IWORK(I+1)=ISAV_^1C_#PUT IN STOP POINTER_^1_$IWORK(I-2)=IWORK(I+3)_^1_$I=I+4_^1_$IF(NOOP.NE.0) GO TO 1073_^1_$IBUF2X=IBUF2X+IBUF2(IBUF2X-1)_^1C_#CLEAR LAST STOP POINTER_^1_$IWORK(I-6)=0_^1_$LRELRQ=LRELRQ-4_^1 1074 ISTWK=LRELRQ_^1_$IF(I€€BUF2X+2.GT.IBUFS)CALL PUNT_^1_$J=IWORK(LRELRQ+2)_^1C_#J=LOC OF PTR IN IBUF2_^1_$IBUF2(J)=IBUF2X-IWORK(LRELRQ+3)_^1_$I=AND(IWORK(LRELRQ+1),1023)_^1C_#SET NEW STARTING ITEM_^1_$IF(IWORK(LRELRQ+1).LT.0) GO TO 1076_^1_$LRELEN=I+2_^1_$IF(IBUF1(I).GT.17.OR.IBUF1(I).EQ.14)LRELEN=LRELEN+1_^1C_#SET NEW IBUF1 INDEX_^1_$IBUF1X=LRELEN_^1_$IF(IBUF1(I).EQ.12.OR.IBUF1(I).EQ.14) GO TO 1077_^1_$IBU€€F2(IBUF2X)=0_^1_$IF(LO.NE.0)GO TO 1080_^1_$IF(IBUF1(I).EQ.2.OR.IBUF1(I).EQ.3)GO TO 1078_^1 1079 LO=3_]_^1 1080 IBUF2X=IBUF2X+1_^1_$GO TO 1102_^1C_".NOT. OPERATOR-SET UP IWORK BUT DONT SET IBUF2_^1 1170 IWORK(LRELRQ-4)=-1_^1_$LRELEN=IWORK(LRELRQ-3)+2_^1 1171 ISTWK=LRELRQ_^1_$IBUF1X=LRELEN_^1_$GO TO 1102_^1C_#GET ASSUMED OP_^1 1076 J=(-IWORK(LRELRQ+1))/1024_^1_$LRELEN=I_^1_$IBUF1X=I€8_^1_$IF(J.EQ.12.OR.J.EQ.14.OR.J.EQ.16) GO TO 1077_^1_$IBUF2(IBUF2X)=0_^1C_#AND,OR_^1_$IF(J.EQ.2.OR.J.EQ.3) GO TO 1078_^1_$GO TO 1079_^1 1077 IBUF2(IBUF2X)=1_^1_$GO TO 1079_^1 1078 LO=1_]_^1_$GO TO 1080_^1 5006 CALL DIAG(4114_")_^1_$RETURN_^1C_#MOORE THAN ONE ** ON ONE LEVEL_^1 5007 CALL DIAG(4116)_^1_$END_]_^__8PWARAY CSY/ 42A P€1_$SUBROUTINE ARAYSZ(IQ)_^1_#*_2/DECK-ID 42A FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^13_]_^1C ARAYSZ IS USED IN PHASES A3,B1_^1C_]_^1C_#MASTER LABELED COMMON BLOCK._^1*_] FTN 3.3_^1_$COMMON /A/ IFLAGS,LINECT,LINCT1_^1_$COMMON /A/ IR,IK,IP,IA,IL,IM€€,IXLGO,IOPTO,IOPTV,IOPTC,IOPTD_^1_$COMMON /A/ MCSTRT,MACRNB,MACSEC_^1_$COMMON /A/ IERRS(16),ISRFAD_^1_$COMMON /A/ LGO,ISCRI,ISCRO,IX_^1*_] FTN 3.3_^1_$COMMON /A/ IGLAB(3),IGLAB1,IGLAB2_^1_$COMMON /A/ ICOMT(12),ICOMTS,ICOMX2,ICOMTL,ISUBP,NDPRS,_^1_#$LABX,IBCDTB(48)_^1_$EQUIVALENCE(ICOMB,ICOMT(1)),(ICOMBX,ICOMT(2)),(ICOMDF,_^1_#$ICOMT(3)),(ICOMBN,ICOMT(4))_^1_$DIMENSION ICOMB(6),ICO€€MBX(6),ICOMDF(6),ICOMBN(7)_^1_$COMMON /A/ LOOPTS,LOOPTX,LOOPTB,LOOPT(50)_^1_$EQUIVALENCE(LINDUC,LOOPT(1))_^1_$DIMENSION LINDUC(10)_^1_$EQUIVALENCE (LBEG,LOOPT(2))_^1_$DIMENSION LBEG(10)_^1_$EQUIVALENCE (LINC,LOOPT(3))_^1_$DIMENSION LINC(10)_^1_$EQUIVALENCE (LEND,LOOPT(4))_^1_$DIMENSION LEND(10)_^1_$BYTE(LLABL,LOOPT(5)(14=0)_))_^1_$DIMENSION LLABL(10)_^1_$BYTE(LID,LOOPT(5)(15=15) €€)_^1_$DIMENSION LID(10)_^1_$COMMON/A/IEQV(255), IEQVS,IEQVN2_^1_$COMMON /A/ ISTAB(150),ISTABS,ISTAB2_^1_$COMMON /A/ IBUFS,ISET(25),LBLANK,KSFCNT,KSNCNT,ISORSC,_^1_#$IHOBIT,ISTNO,ISSFLG,ISUBPN,ITERM,JSORSC,KEQVS_^1C_#SYMBOL TABLE LABELED COMMON BLOCK_^1_$COMMON /A/ ISYMN, ISYMFL,ISYMD,ISYMX,ISYMS,ISYMP,ISYMPC,ISYMPS,_^1_#$ ISYMNS, SYMTAB(960)_^1_$INTEGER SYMTAB_^1_$BYTE (IDUM,SYMTAB€€(1)(15=15)),(KDUMY,SYMTAB(1)(15=15)),_^1_#$(ICLASS,SYMTAB(1)(14=11)),(ITYPE,SYMTAB(1)(10=9))_^1_$DIMENSION IDUM(100),KDUMY(100),ICLASS(100),ITYPE(100)_^1_$BYTE (ISNGL, SYMTAB(1)(8=8)),(KELSIZ,SYMTAB(1)(8=8)),_^1_#$ (ICOM,SYMTAB(1)(7=5)),(IPART,SYMTAB(1)(4=3))_^1_$DIMENSION ISNGL(100),KELSIZ(100),ICOM(100),IPART(100)_^1_$BYTE (KRFCNT,SYMTAB(1)(2=2)),(IDIM,SYMTAB(1)(1=0)),_^1_#$ (IRE€€L,SYMTAB(1)(1=1)),(IEXT,SYMTAB(1)(0=0))_^1_$DIMENSION KRFCNT(100),IDIM(100),IREL(100),IEXT(100)_^1_$EQUIVALENCE (IRSA,SYMTAB(2)),(ICOMTX,SYMTAB(2)),(ISNOL,SYMTAB(2))_^1_$DIMENSION IRSA(100), ICOMTX(100),ISNOL(100)_^1_$BYTE (IDATAS,SYMTAB(3)(15=15)),(IREF,SYMTAB(3)(15=15)),_^1_#$ (IEQVX,SYMTAB(3)(14=8)),(ITILF,SYMTAB(3)(14=8))_^1_$DIMENSION IDATAS(100),IREF(100),IEQVX(100),ITILF(100€€)_^1_$BYTE (IPARTR,SYMTAB(3)(7=4)),(INDUCV,SYMTAB(3)(7=7)),(ISFARG,_^1_#$ SYMTAB(3)(6=6)),(IARGNO,SYMTAB(3)(5=0)),(IPARTL,SYMTAB(3)(3=0))_^1_$DIMENSION IPARTR(100),INDUCV(100),ISFARG(100),IARGNO(100),_^1_#$ IPARTL(100)_^1_$EQUIVALENCE (ISYM,SYMTAB(4))_^1_$DIMENSION ISYM(100)_^1C_]_^1C_#SPECIFICATION-TABLE INDEX LABELLED COMMON BLOCK_^1_$COMMON /A/ ISTABX(96)_^1C_]_^1C_'COMPUTE ELEM€€ENT SIZE._^1C ********************************** FTN 3.1 **************************_^1_$NWDS = ITYPE(ISYMX)_^1_$IF (ITYPE(ISYMX).EQ.1 .AND. IK.NE.0 .AND. ISNGL(ISYMX).EQ.0)_^1_#-_!NWDS = 2_^1C_]_^1C_'NOTE KELSIZ AND ISNGL OCCUPY THE SAME BIT IN THE SYMBOL TABLE._^1C_]_^1_$J = 1_^1_$IF (ITYPE(ISYMX).EQ.1 .AND. (IK.EQ.0 .OR. ISNGL(ISYMX).NE.0))_^1_#-_!J = 0_^1_$KELSIZ(ISYMX) = J_^1C€€ ********************************** FTN 3.1 ($) **********************_^1C_]_^1C_'SET NUMBER OF DIMENSIONS AND INDEX_^1C_'ON ISTAB TABLE._^1_$NDIMS=IDIM(ISYMX)_^1_$I=ISYMX/(2*ISYMFL) +1_^1_$I=ISTABX(I)_^1_$IF (AND(ISYMX,1).EQ.1) I=I/$0100_^1_$I=AND(I,$FF)_^1_$INDX2=I_^1C_]_^1C_'ARE THERE ANY DIMENSIONS LEFT_^1 777 IF(NDIMS.EQ.0) GO TO 666_^1C_'YES, UPDATE ARRAY SIZE BY NEXT DIMEN€SION_^1_$NWDS=NWDS*ISTAB(INDX2)_^1C_]_^1_$NDIMS=NDIMS-1_^1_$INDX2=INDX2+1_^1_$GO TO 777_^1C_]_^1C_'WAS THIS ACTUALLY AN ARRAY, IF SO, TRANSFER_^1C_'ARRAY SIZE TO ISTAB TABLE._^1 666 IF(IDIM(ISYMX).EQ.0) GO TO 888_^1_$ISTAB(I)=NWDS_^1 888 IQ=NWDS_^1_$END_]_^__ PWLOOP CSY/ 43A P€1_$SUBROUTINE CPLOOP_^1_#*_2/DECK-ID 43A FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^13_]_^1C CPLOOP IS USED IN PHASE A3_^1C_]_^1C_#MASTER LABELED COMMON BLOCK._^1*_] FTN 3.3_^1_$COMMON /A/ IFLAGS,LINECT,LINCT1_^1_$COMMON /A/ IR,IK,IP,IA,IL,IM,IXLGO,I€€OPTO,IOPTV,IOPTC,IOPTD_^1_$COMMON /A/ MCSTRT,MACRNB,MACSEC_^1_$COMMON /A/ IERRS(16),ISRFAD_^1_$COMMON /A/ LGO,ISCRI,ISCRO,IX_^1*_] FTN 3.3_^1_$COMMON /A/ IGLAB(3),IGLAB1,IGLAB2_^1_$COMMON /A/ ICOMT(12),ICOMTS,ICOMX2,ICOMTL,ISUBP,NDPRS,_^1_#$LABX,IBCDTB(48)_^1_$EQUIVALENCE(ICOMB,ICOMT(1)),(ICOMBX,ICOMT(2)),(ICOMDF,_^1_#$ICOMT(3)),(ICOMBN,ICOMT(4))_^1_$DIMENSION ICOMB(6),ICOMBX(6),I€€COMDF(6),ICOMBN(7)_^1_$COMMON /A/ LOOPTS,LOOPTX,LOOPTB,LOOPT(50)_^1_$EQUIVALENCE(LINDUC,LOOPT(1))_^1_$DIMENSION LINDUC(10)_^1_$EQUIVALENCE (LBEG,LOOPT(2))_^1_$DIMENSION LBEG(10)_^1_$EQUIVALENCE (LINC,LOOPT(3))_^1_$DIMENSION LINC(10)_^1_$EQUIVALENCE (LEND,LOOPT(4))_^1_$DIMENSION LEND(10)_^1_$BYTE(LLABL,LOOPT(5)(14=0)_))_^1_$DIMENSION LLABL(10)_^1_$BYTE(LID,LOOPT(5)(15=15) )_^1_$DI€€MENSION LID(10)_^1_$COMMON/A/IEQV(255), IEQVS,IEQVN2_^1_$COMMON /A/ ISTAB(150),ISTABS,ISTAB2_^1_$COMMON /A/ IBUFS,ISET(25),LBLANK,KSFCNT,KSNCNT,ISORSC,_^1_#$IHOBIT,ISTNO,ISSFLG,ISUBPN,ITERM,JSORSC,KEQVS_^1C_#SYMBOL TABLE LABELED COMMON BLOCK_^1_$COMMON /A/ ISYMN, ISYMFL,ISYMD,ISYMX,ISYMS,ISYMP,ISYMPC,ISYMPS,_^1_#$ ISYMNS, SYMTAB(960)_^1_$INTEGER SYMTAB_^1_$BYTE (IDUM,SYMTAB(1)(15=1€€5)),(KDUMY,SYMTAB(1)(15=15)),_^1_#$(ICLASS,SYMTAB(1)(14=11)),(ITYPE,SYMTAB(1)(10=9))_^1_$DIMENSION IDUM(100),KDUMY(100),ICLASS(100),ITYPE(100)_^1_$BYTE (ISNGL, SYMTAB(1)(8=8)),(KELSIZ,SYMTAB(1)(8=8)),_^1_#$ (ICOM,SYMTAB(1)(7=5)),(IPART,SYMTAB(1)(4=3))_^1_$DIMENSION ISNGL(100),KELSIZ(100),ICOM(100),IPART(100)_^1_$BYTE (KRFCNT,SYMTAB(1)(2=2)),(IDIM,SYMTAB(1)(1=0)),_^1_#$ (IREL,SYMTAB€€(1)(1=1)),(IEXT,SYMTAB(1)(0=0))_^1_$DIMENSION KRFCNT(100),IDIM(100),IREL(100),IEXT(100)_^1_$EQUIVALENCE (IRSA,SYMTAB(2)),(ICOMTX,SYMTAB(2)),(ISNOL,SYMTAB(2))_^1_$DIMENSION IRSA(100), ICOMTX(100),ISNOL(100)_^1_$BYTE (IDATAS,SYMTAB(3)(15=15)),(IREF,SYMTAB(3)(15=15)),_^1_#$ (IEQVX,SYMTAB(3)(14=8)),(ITILF,SYMTAB(3)(14=8))_^1_$DIMENSION IDATAS(100),IREF(100),IEQVX(100),ITILF(100)_^1_$BY€€TE (IPARTR,SYMTAB(3)(7=4)),(INDUCV,SYMTAB(3)(7=7)),(ISFARG,_^1_#$ SYMTAB(3)(6=6)),(IARGNO,SYMTAB(3)(5=0)),(IPARTL,SYMTAB(3)(3=0))_^1_$DIMENSION IPARTR(100),INDUCV(100),ISFARG(100),IARGNO(100),_^1_#$ IPARTL(100)_^1_$EQUIVALENCE (ISYM,SYMTAB(4))_^1_$DIMENSION ISYM(100)_^1C_]_^1C_#SPECIFICATION-TABLE INDEX LABELLED COMMON BLOCK_^1_$COMMON /A/ ISTABX(96)_^1C_]_^1C_]_^1C_'COMMON PROCESS€€ING LOOP_^1C_]_^1_$COMMON//LCTABL(550)_^1_$EQUIVALENCE (IEQVV(1),IEQV(1)),(IEQINC(1),IEQV(2))_^1_$DIMENSION IEQVV(100),IEQINC(100)_^1C_'INITIALIZE INDEX THROUGH ICOMBX TABLE_^1_$INDX1=1_^1C_]_^1C_'HAVE ALL COMMON BLOCKS BEEN PROCESSED._^1_!10 IF(ICOMX2.LE.INDX1) RETURN_^1C_]_^1C_'NO, INITIALIZE BLOCK SIZE,EXCHANGE HOLDER, AND LCTABL INDEX._^1_$KBKSIZ=0_^1_$IHOLD=1_^1_$LCTABX=1_^1C_€€]_^1C_'PICKUP FIRST ENTRY_^1_$ISYMX=ICOMBX(INDX1)_^1C_'TEST FOR NULL ENTRY_^1_$IF(ISYMX.NE.1) GO TO 20_^1_$ICOMBX(INDX1)=0_^1_$GO TO 120_^1C_'LOOKUP ENTRY_^1_!40 KSW=1_^1C_'EXCHANGE POINTERS TO REVERSE CHAIN LINKAGE._^1_!41 ICOMTX(ISYMX)=IHOLD_^1_$IHOLD=ISYMX+ISYMP_^1C_'TEST SWITCH FOR CHAIN PROCESSING COMPLETED_^1_$IF(KSW.NE.0) GO TO 50_^1C_'NOT COMPLETED, SET ISYMX FOR NEXT COMMO€€N ELEMENT._^1_$ISYMX=ITEMP_^1_!20 CALL GETSYM_^1C_'COMPUTE ARRAY SIZE_^1_$CALL ARAYSZ(NWDS)_^1C_'PUT ARRAY SIZE TEMPORARILY IN PUSH DOWN TABLE LCTABL_^1_$LCTABL(LCTABX)=NWDS_^1_$LCTABX=LCTABX+1_^1C_]_^1C_'UPDATE BLOCKSIZE WITH ARRAY SIZE._^1_$KBKSIZ=KBKSIZ+NWDS_^1C_]_^1C_'HAS THE PROCESSING OF THE CHAIN BEEN_^1C_'COMPLETED._^1_$IF(ICOMTX(ISYMX).EQ.1) GO TO 40_^1C_]_^1C_'NO, SAVE PT€€R TO LOOKUP NEXT LINK IN CHAIN._^1_$ITEMP=ICOMTX(ISYMX)_^1C_'SET SWITCH_^1_$KSW=0_^1_$GO TO 41_^1C_]_^1C_]_^1C_'* PASS TO BE MADE ON THE EQUIVALENCE CHAIN TO THE_^1C_'* TOP ELEMENT IN THE COMMON CHAIN TO SET RELATIVE_^1C_'* LOCATIONS AND DETERMINE TOTAL SIZE._^1C_]_^1C_'PICKUP INDEX INTO EQUIVALENCE TABLE._^1_!50 INDX3=IEQVX(ISYMX)_^1C_]_^1C_'IF ZERO, NO EQUIVALENCING._^1_$IF(INDX€€3.EQ.0) GO TO 100_^1C_]_^1C_'MARK THIS EQUIVALENCE CLASS PROCESSED._^1_$IEQINC(INDX3)=1_^1_$GO TO 71_^1C_'UPDATE TO NEXT ELEMENT IN EQUIVALENCE CLASS_^1_!70 INDX3=INDX3+2_^1C_]_^1C_'SET ISYMX FOR NEXT ELEMENT_^1_!71 ISYMX=IEQVV(INDX3)_^1C_]_^1C_'HAS END OF EQUIVALENCE CLASS BEEN ENCOUNTERED._^1_$IF(ISYMX+1.EQ.0) GO TO 100_^1C_]_^1C_'NO, LOOKUP ENTRY_^1_$CALL GETSYM_^1_$IF(ICOMTX(IS€€YMX).NE.0) GO TO 70_^1C_]_^1C_'COMPUTE ARRAY SIZE_^1_$CALL ARAYSZ(NWDS)_^1C_]_^1C_'SET IRSA TO COMMON RELATIVE LOCATION._^1_$IRSA(ISYMX)=IEQINC(INDX3)-1_^1C_]_^1C_'SET KOMP TO COMMON RELATIVE LOCATION PLUS ARRAY SIZE._^1_$KOMP=IRSA(ISYMX)+NWDS_^1C_]_^1C_'IF NEW COMPUTED BLOCK SIZE IS LARGER DUE TO EQUIVALENCE_^1C_'EXTENSIONS, SET KBKSIZ TO NEW SIZE_^1_$IF(KBKSIZ.LT.KOMP) KBKSIZ=KOM€€P_^1_$GO TO 70_^1C_]_^1C_'PUT AWAY BLOCKSIZE FOR USE BY NEXT PASS_^1 100 ICOMBX(INDX1)=KBKSIZ_^1C_]_^1C_'* PASS DOWN COMMON BLOCK TO SET IRSA_^1C_'* WITH RELOCATION ADDRESSES_^1C_]_^1C_'INITIALIZE LOCATION COUNTER_^1_$ILOCNT=0_^1C_]_^1C_'SET POINTER OF FIRST/NEXT COMMON ELEMENT FROM JHOLD_^1C_'AND LOOK UP_^1 110 ISYMX=IHOLD_^1_$CALL GETSYM_^1_$IHOLD=ICOMTX(ISYMX)_^1C_]_^1C_'SET I€pRSA TO UPDATED LOCATION COUNTER_^1_$IRSA(ISYMX)=ILOCNT_^1C_'COMPUTE NEW LOCATION COUNTER_^1_$LCTABX=LCTABX-1_^1_$ILOCNT=ILOCNT+LCTABL(LCTABX)_^1C_'PICKUP POINTER TO NEXT COMMON ELEMENT_^1C_'HAS BOTTOM OF COMMON BLOCK BEEN REACHED._^1_$IF(IHOLD.NE.1) GO TO 110_^1C_]_^1C_'YES, INCREMENT TO PROCESS NEXT COMMON BLOCK_^1 120 INDX1=INDX1+ICOMTL_^1_$GO TO 10_^1_$END_]_^__pPWDUMMY CSY/ 01B P€1_$SUBROUTINE DUMMY(LP35,LP4)_^1_#*_2/DECK-ID 01B FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^13_]_^1C DUMMY IS USED IN PHASE B1_^1C_]_^1C_#MASTER LABELED COMMON BLOCK._^1*_] FTN 3.3_^1_$COMMON /A/ IFLAGS,LINECT,LINCT1_^1_$COMMON /A/ IR,IK,IP,IA,IL,IM€€,IXLGO,IOPTO,IOPTV,IOPTC,IOPTD_^1_$COMMON /A/ MCSTRT,MACRNB,MACSEC_^1_$COMMON /A/ IERRS(16),ISRFAD_^1_$COMMON /A/ LGO,ISCRI,ISCRO,IX_^1*_] FTN 3.3_^1_$COMMON /A/ IGLAB(3),IGLAB1,IGLAB2_^1_$COMMON /A/ ICOMT(12),ICOMTS,ICOMX2,ICOMTL,ISUBP,NDPRS,_^1_#$LABX,IBCDTB(48)_^1_$EQUIVALENCE(ICOMB,ICOMT(1)),(ICOMBX,ICOMT(2)),(ICOMDF,_^1_#$ICOMT(3)),(ICOMBN,ICOMT(4))_^1_$DIMENSION ICOMB(6),ICO€€MBX(6),ICOMDF(6),ICOMBN(7)_^1_$COMMON /A/ LOOPTS,LOOPTX,LOOPTB,LOOPT(50)_^1_$EQUIVALENCE(LINDUC,LOOPT(1))_^1_$DIMENSION LINDUC(10)_^1_$EQUIVALENCE (LBEG,LOOPT(2))_^1_$DIMENSION LBEG(10)_^1_$EQUIVALENCE (LINC,LOOPT(3))_^1_$DIMENSION LINC(10)_^1_$EQUIVALENCE (LEND,LOOPT(4))_^1_$DIMENSION LEND(10)_^1_$BYTE(LLABL,LOOPT(5)(14=0)_))_^1_$DIMENSION LLABL(10)_^1_$BYTE(LID,LOOPT(5)(15=15) €€)_^1_$DIMENSION LID(10)_^1_$COMMON /A/ IEQV(255),IEQVS,IEQVN2_^1_$COMMON /A/ ISTAB(150),ISTABS,ISTAB2_^1_$COMMON /A/ IBUFS,ISET(25),LBLANK,KSFCNT,KSNCNT,ISORSC,_^1_#$IHOBIT,ISTNO,ISSFLG,ISUBPN,ITERM,JSORSC,KEQVS_^1C_]_^1C_#SYMBOL TABLE LABELED COMMON BLOCK_^1_$COMMON /A/ ISYMN, ISYMFL,ISYMD,ISYMX,ISYMS,ISYMP,ISYMPC,ISYMPS,_^1_#$ ISYMNS, SYMTAB(960)_^1_$INTEGER SYMTAB_^1_$BYTE (IDUM€€,SYMTAB(1)(15=15)),(KDUMY,SYMTAB(1)(15=15)),_^1_#$(ICLASS,SYMTAB(1)(14=11)),(ITYPE,SYMTAB(1)(10=9))_^1_$DIMENSION IDUM(100),KDUMY(100),ICLASS(100),ITYPE(100)_^1_$BYTE (ISNGL, SYMTAB(1)(8=8)),(KELSIZ,SYMTAB(1)(8=8)),_^1_#$ (ICOM,SYMTAB(1)(7=5)),(IPART,SYMTAB(1)(4=3))_^1_$DIMENSION ISNGL(100),KELSIZ(100),ICOM(100),IPART(100)_^1_$BYTE (KRFCNT,SYMTAB(1)(2=2)),(IDIM,SYMTAB(1)(1=0)),_^1_€€#$ (IREL,SYMTAB(1)(1=1)),(IEXT,SYMTAB(1)(0=0))_^1_$DIMENSION KRFCNT(100),IDIM(100),IREL(100),IEXT(100)_^1_$EQUIVALENCE (IRSA,SYMTAB(2)),(ICOMTX,SYMTAB(2)),(ISNOL,SYMTAB(2))_^1_$DIMENSION IRSA(100), ICOMTX(100),ISNOL(100)_^1_$BYTE (IDATAS,SYMTAB(3)(15=15)),(IREF,SYMTAB(3)(15=15)),_^1_#$ (IEQVX,SYMTAB(3)(14=8)),(ITILF,SYMTAB(3)(14=8))_^1_$DIMENSION IDATAS(100),IREF(100),IEQVX(100),IT€€ILF(100)_^1_$BYTE (IPARTR,SYMTAB(3)(7=4)),(INDUCV,SYMTAB(3)(7=7)),(ISFARG,_^1_#$ SYMTAB(3)(6=6)),(IARGNO,SYMTAB(3)(5=0)),(IPARTL,SYMTAB(3)(3=0))_^1_$DIMENSION IPARTR(100),INDUCV(100),ISFARG(100),IARGNO(100),_^1_#$ IPARTL(100)_^1_$EQUIVALENCE (ISYM,SYMTAB(4))_^1_$DIMENSION ISYM(100)_^1C_]_^1C_#SPECIFICATION-TABLE INDEX LABELLED COMMON BLOCK_^1_$COMMON /A/ ISTABX(96)_^1C_]_^1C_#PHASE€€ 4 LABELED COMMON BLOCK._^1_$COMMON /A/ INDTAB(18),INFTB(18)_^1_#2,NBSS ,NADC ,NCON ,NEND ,NPST ,NSTN ,NJMP ,NRTJ ,NLDA_^1_#3,NLDQ ,NSTA ,NSTQ ,NRAO ,NADD ,NSUB ,NAND ,NDVI ,NADQ_^1_#4,NENA ,NINA ,NENQ ,NINQ ,NLRS ,NLLS ,NQRS ,NQLS ,NARS_^1_#5,NALS ,NAJLGZ,NAJEZ ,NAJLZ ,NAJGEZ,NAJLEZ,NAJGZ ,NQJEZ ,NMUI_^1_$COMMON/A/_^1_#1 NFCM ,NFSB ,NFMU ,NFDV ,NFLD ,€€NFST ,NFAD ,NCAQA_^1_#2,NTCQA ,NTRAQ ,KLDQ ,KSTQ ,NTCAA ,NEOR ,NTCQQ_^1_#3,INFTBL,INFTBN,INFTBX_^1_$DIMENSION KODNAM(18), KFTYPE(6),NLINE(6),NPMTRS(6),KSPTAB(14)_^1_$EQUIVALENCE (INFTB(1),KODNAM(1)),(ISET(11),KSPTAB(1))_^1_$BYTE (KFTYPE,INFTB(3)(15=14)),(NLINE,INFTB(3)(13=13)),_^1_#$ (NPMTRS,INFTB(3)(12=0))_^1C_]_^1C_#PHASE 4 BLANK COMMON BLOCK._^1_$COMMON//JSYM(3),_^1C ******€€**************************** FTN 3.1 **************************_^1_#1 INBUFF(304),OUTBUF(10),KART(2,3,3),KQ(5),KFCET(5,3),_^1C ********************************** FTN 3.1 ($) **********************_^1_#2 KSUBAT(240),KSFAT(12,2),KLLTB(10,2),LPTYP(10),_^1_#3 INTRAS(304),IMOD(30),NDTYP(30),NBRNS(30),ICBRN(30),_^1_#4 KOP(30),KTRUT(30)_^1_$DIMENSION KFALS(30),KFATH(30),KOMPSW(30),KSBPT€€R(30),KRESW(30)_^1_$EQUIVALENCE (KFALS(1),ISTAB(1)),(KFATH(1),ISTAB(31)),_^1_#1 (KOMPSW(1),ISTAB(61)),(KSBPTR(1),ISTAB(91)),(KRESW(1),ISTAB(121))_^1_$COMMON// LTYP,MBEGIN_^1_#1,IADDIT,INTRAX,IPTR,ISBSCP,JXX,KBEGIN,KBIAS,KBYTX,KENTER,KENTRY_^1_#2,KEXEC,KEXTYP,KFCSW,KFFSAV,KFINDX,KFLAM,KINTYP,KLLTBX,KNTROL_^1_#3,KOBX,KPRNAM,KQSAV,KRETRN,KSFNAM,KTCATX,LEVEL,LIFTX,LOGIF,KFCETX_^1_$DIME€€NSION NINVS(30),NINENC(30),NPASS(30)_^1_$EQUIVALENCE (KTRUT(1),NINVS(1)),(KFALS(1),NINENC(1))_^1_#1,(KFATH(1),NPASS(1))_^1_$INTEGER OUTBUF_^1C_]_^1_$EQUIVALENCE (IEQVV(1),IEQV(1)),(IEQINC(1),IEQV(2))_^1_$DIMENSION IEQVV(100),IEQINC(100)_^1C_]_^1_%DIMENSION MSG(3)_^1_%DATA MSG(1),MSG(2),MSG(3)/$202A,$462C,$3830/_^1_%DATA KSBATS/-1/_^1_%IF (KSBATS.NE.-1) GO TO 2_^1_%KSBATS=1_^1 1_#IF€€(KSUBAT(KSBATS).EQ.0) GO TO 2_^1_%KSBATS=KSBATS+KSUBAT(KSBATS+1)+1_^1_%GO TO 1_^1 2_#CONTINUE_^1C_#MAKE SURE ONLY PRIMARY IS USED_^1_$LP4K=LP4_^1_$LP35K=LP35_^1_$ISYMX=LP35_^1_$CALL GETSYM_^1_$IF(ICLASS(ISYMX).NE.1) GO TO 170_^1_$ITEMP=IEQVX(ISYMX)_^1_$IF(ITEMP.EQ.0) GO TO 17_^1_$LP35K=IEQVV(ITEMP)_^1_$IF(LP35.EQ.IEQVV(ITEMP)) GO TO 17_^1_!18 ITEMP=ITEMP+2_^1_$IF(LP35.NE.IEQVV(ITEM€€P)) GO TO 18_^1_$LP4K=LP4+IEQINC(ITEMP)-1_^1_!17 CONTINUE_^1C_-S IT A STATEMENT FUNCTION DUMMY ARGUMENT._^1_$IF(IPART(ISYMX).EQ.0.AND.ISFARG(ISYMX).NE.0) GO TO 7_^1C_'NO, LOOKUP IN SUBROUTINE ARGUMENT TABLE (KSUBAT)_^1 170 I=1_]_^1_!10 IF(KSUBAT(I).EQ.LP35K) GO TO 8_^1_$I=I+1+KSUBAT(I+1)_^1_$GO TO 10_^1C_'ARGUMENT FOUND, LOOKUP ADDITIVE._^1_"8 II=1_]_^1_$LENGTH=KSUBAT(I+1)_^1_!16 €€IF(II.EQ.LENGTH) GO TO 9_^1_$II=II+1_^1C_'NEXT TEST COMPARES INCREMENT OF INSTRUCTION_^1C_'WITH THE NEXT INCREMENT IN THE TABLE._^1C_'IF ITS .LT.,NEW INCREMENT MUST BE INSERTED THERE_^1C_3AND A NEW TEMPORARY STORAGE ASSIGNED_^1C_'IF ITS .EQ.,IT HAS BEEN LOCATED_^1C_'IF ITS .GT.,SEARCH CONTINUES_^1_$III=II+I_^1_$IF(LP4K-KSUBAT(III))11,12,13_^1_!13 II=II+1_^1_$GO TO 16_^1_"9 III=I+II€€+1_^1 11_"IF(KSBATS.GE.239) GO TO 210_^1_%KSBATS=KSBATS+2_^1_%NDPRS=NDPRS+1_^1_$L=238_^1_!15 KSUBAT(L+2)=KSUBAT(L)_^1_$IF(L.EQ.III) GO TO 14_^1_$L=L-1_^1_$GO TO 15_^1_!14 KSUBAT(III)=LP4K_^1_$III=III+1_^1_$CALL KSYMGN(KTS)_^1_$KSUBAT(III)=KTS_^1_$KSUBAT(I+1)=KSUBAT(I+1)+2_^1_!21 KDUMY(ISYMX)=1_^1_$ITYPE(ISYMX)=1_^1_$ICLASS(ISYMX)=1_^1_$GO TO 20_^1C_]_^1 210_!CALL WRITE(3,1,3,MSG)_^€€1_%IXLGO=0_^1_%CALL SKIPIT_^1C_'OPERAND IS A STATEMENT FUNCTION DUMMY ARGUMENT_^1C_'LOOKUP IN KSFAT_^1_"7 I=1_]_^1_!81 IF(KSFAT(I,1).EQ.LP35) GO TO 80_^1_$I=I+1_^1_$GO TO 81_^1C_]_^1C_'OPERAND FOUND, HAS TEMPORARY STORAGE BEEN ASSIGNED_^1_!80 KTS=KSFAT(I,2)_^1_$IF(KTS.NE.0) GO TO 20_^1_$CALL KSYMGN(KTS)_^1_$KSFAT(I,2)=KTS_^1_$GO TO 21_^1_!12 III=III+1_^1_$KTS=KSUBAT(III)_^1C_'REPLA€xCE ARGUMENT AND ADDITIVE WITH TEMPORARY CELL REF._^1C_'MODIFY COMMAND TO SHOW NO ADDITIVE._^1_!20 LP35=KTS_^1_$END_]_^__xPWFCMK CSY/ 02B P€1_$SUBROUTINE FCMSTK(KF1,KF2)_^1_#*_2/DECK-ID 02B FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^13_]_^1C FCMSTK IS USED IN PHASE B1_^1C_]_^1C_#MASTER LABELED COMMON BLOCK._^1*_] FTN 3.3_^1_$COMMON /A/ IFLAGS,LINECT,LINCT1_^1_$COMMON /A/ IR,IK,IP,IA,IL,I€€M,IXLGO,IOPTO,IOPTV,IOPTC,IOPTD_^1_$COMMON /A/ MCSTRT,MACRNB,MACSEC_^1_$COMMON /A/ IERRS(16),ISRFAD_^1_$COMMON /A/ LGO,ISCRI,ISCRO,IX_^1*_] FTN 3.3_^1_$COMMON /A/ IGLAB(3),IGLAB1,IGLAB2_^1_$COMMON /A/ ICOMT(12),ICOMTS,ICOMX2,ICOMTL,ISUBP,NDPRS,_^1_#$LABX,IBCDTB(48)_^1_$EQUIVALENCE(ICOMB,ICOMT(1)),(ICOMBX,ICOMT(2)),(ICOMDF,_^1_#$ICOMT(3)),(ICOMBN,ICOMT(4))_^1_$DIMENSION ICOMB(6),IC€€OMBX(6),ICOMDF(6),ICOMBN(7)_^1_$COMMON /A/ LOOPTS,LOOPTX,LOOPTB,LOOPT(50)_^1_$EQUIVALENCE(LINDUC,LOOPT(1))_^1_$DIMENSION LINDUC(10)_^1_$EQUIVALENCE (LBEG,LOOPT(2))_^1_$DIMENSION LBEG(10)_^1_$EQUIVALENCE (LINC,LOOPT(3))_^1_$DIMENSION LINC(10)_^1_$EQUIVALENCE (LEND,LOOPT(4))_^1_$DIMENSION LEND(10)_^1_$BYTE(LLABL,LOOPT(5)(14=0)_))_^1_$DIMENSION LLABL(10)_^1_$BYTE(LID,LOOPT(5)(15=15) €€ )_^1_$DIMENSION LID(10)_^1_$COMMON /A/ IEQV(255),IEQVS,IEQVN2_^1_$COMMON /A/ ISTAB(150),ISTABS,ISTAB2_^1_$COMMON /A/ IBUFS,ISET(25),LBLANK,KSFCNT,KSNCNT,ISORSC,_^1_#$IHOBIT,ISTNO,ISSFLG,ISUBPN,ITERM,JSORSC,KEQVS_^1C_]_^1C_#SYMBOL TABLE LABELED COMMON BLOCK_^1_$COMMON /A/ ISYMN, ISYMFL,ISYMD,ISYMX,ISYMS,ISYMP,ISYMPC,ISYMPS,_^1_#$ ISYMNS, SYMTAB(960)_^1_$INTEGER SYMTAB_^1_$BYTE (IDU€€M,SYMTAB(1)(15=15)),(KDUMY,SYMTAB(1)(15=15)),_^1_#$(ICLASS,SYMTAB(1)(14=11)),(ITYPE,SYMTAB(1)(10=9))_^1_$DIMENSION IDUM(100),KDUMY(100),ICLASS(100),ITYPE(100)_^1_$BYTE (ISNGL, SYMTAB(1)(8=8)),(KELSIZ,SYMTAB(1)(8=8)),_^1_#$ (ICOM,SYMTAB(1)(7=5)),(IPART,SYMTAB(1)(4=3))_^1_$DIMENSION ISNGL(100),KELSIZ(100),ICOM(100),IPART(100)_^1_$BYTE (KRFCNT,SYMTAB(1)(2=2)),(IDIM,SYMTAB(1)(1=0)),_^1€€_#$ (IREL,SYMTAB(1)(1=1)),(IEXT,SYMTAB(1)(0=0))_^1_$DIMENSION KRFCNT(100),IDIM(100),IREL(100),IEXT(100)_^1_$EQUIVALENCE (IRSA,SYMTAB(2)),(ICOMTX,SYMTAB(2)),(ISNOL,SYMTAB(2))_^1_$DIMENSION IRSA(100), ICOMTX(100),ISNOL(100)_^1_$BYTE (IDATAS,SYMTAB(3)(15=15)),(IREF,SYMTAB(3)(15=15)),_^1_#$ (IEQVX,SYMTAB(3)(14=8)),(ITILF,SYMTAB(3)(14=8))_^1_$DIMENSION IDATAS(100),IREF(100),IEQVX(100),I€€TILF(100)_^1_$BYTE (IPARTR,SYMTAB(3)(7=4)),(INDUCV,SYMTAB(3)(7=7)),(ISFARG,_^1_#$ SYMTAB(3)(6=6)),(IARGNO,SYMTAB(3)(5=0)),(IPARTL,SYMTAB(3)(3=0))_^1_$DIMENSION IPARTR(100),INDUCV(100),ISFARG(100),IARGNO(100),_^1_#$ IPARTL(100)_^1_$EQUIVALENCE (ISYM,SYMTAB(4))_^1_$DIMENSION ISYM(100)_^1C_]_^1C_#SPECIFICATION-TABLE INDEX LABELLED COMMON BLOCK_^1_$COMMON /A/ ISTABX(96)_^1C_]_^1C_#PHAS€€E 4 LABELED COMMON BLOCK._^1_$COMMON /A/ INDTAB(18),INFTB(18)_^1_#2,NBSS ,NADC ,NCON ,NEND ,NPST ,NSTN ,NJMP ,NRTJ ,NLDA_^1_#3,NLDQ ,NSTA ,NSTQ ,NRAO ,NADD ,NSUB ,NAND ,NDVI ,NADQ_^1_#4,NENA ,NINA ,NENQ ,NINQ ,NLRS ,NLLS ,NQRS ,NQLS ,NARS_^1_#5,NALS ,NAJLGZ,NAJEZ ,NAJLZ ,NAJGEZ,NAJLEZ,NAJGZ ,NQJEZ ,NMUI_^1_$COMMON/A/_^1_#1 NFCM ,NFSB ,NFMU ,NFDV ,NFLD €€,NFST ,NFAD ,NCAQA_^1_#2,NTCQA ,NTRAQ ,KLDQ ,KSTQ ,NTCAA ,NEOR ,NTCQQ_^1_#3,INFTBL,INFTBN,INFTBX_^1_$DIMENSION KODNAM(18), KFTYPE(6),NLINE(6),NPMTRS(6),KSPTAB(14)_^1_$EQUIVALENCE (INFTB(1),KODNAM(1)),(ISET(11),KSPTAB(1))_^1_$BYTE (KFTYPE,INFTB(3)(15=14)),(NLINE,INFTB(3)(13=13)),_^1_#$ (NPMTRS,INFTB(3)(12=0))_^1C_]_^1C_#PHASE 4 BLANK COMMON BLOCK._^1_$COMMON//JSYM(3),_^1C *****€€***************************** FTN 3.1 **************************_^1_#1 INBUFF(304),OUTBUF(10),KART(2,3,3),KQ(5),KFCET(5,3),_^1C ********************************** FTN 3.1 ($) **********************_^1_#2 KSUBAT(240),KSFAT(12,2),KLLTB(10,2),LPTYP(10),_^1_#3 INTRAS(304),IMOD(30),NDTYP(30),NBRNS(30),ICBRN(30),_^1_#4 KOP(30),KTRUT(30)_^1_$DIMENSION KFALS(30),KFATH(30),KOMPSW(30),KSBP€€TR(30),KRESW(30)_^1_$EQUIVALENCE (KFALS(1),ISTAB(1)),(KFATH(1),ISTAB(31)),_^1_#1 (KOMPSW(1),ISTAB(61)),(KSBPTR(1),ISTAB(91)),(KRESW(1),ISTAB(121))_^1_$COMMON// LTYP,MBEGIN_^1_#1,IADDIT,INTRAX,IPTR,ISBSCP,JXX,KBEGIN,KBIAS,KBYTX,KENTER,KENTRY_^1_#2,KEXEC,KEXTYP,KFCSW,KFFSAV,KFINDX,KFLAM,KINTYP,KLLTBX,KNTROL_^1_#3,KOBX,KPRNAM,KQSAV,KRETRN,KSFNAM,KTCATX,LEVEL,LIFTX,LOGIF,KFCETX_^1_$DIM€€ENSION NINVS(30),NINENC(30),NPASS(30)_^1_$EQUIVALENCE (KTRUT(1),NINVS(1)),(KFALS(1),NINENC(1))_^1_#1,(KFATH(1),NPASS(1))_^1_$INTEGER OUTBUF_^1C_]_^1C_]_^1C_'ROUTINE WHICH TAKES FLOATING COMMANDS FROM KPCSTK_^1C_'AND PLACES THEM IN KFCET. WHEN STOP CODE IS EN-_^1C_'COUNTERED OR ALL FOUR BYTES ARE FILLED THE ELEMENTS_^1C_'ARE STACKED AS VARIOUS CONSTANTS._^1C_]_^1C_]_^1C_'KBYTX INDE€€XES BYTES LEFT TO RIGHT (1-4) ACROSS THE_^1C_'FLOATING POINT BYTE WORD._^1_$MULT=4096_^1_$IF(KBYTX.EQ.2) MULT=256_^1_$IF(KBYTX.EQ.3) MULT=16_^1_$IF(KBYTX.EQ.4) MULT=1_^1_$KFCET(1,1)=KFCET(1,1)+KF1*MULT_^1C_]_^1C_'IS THERE AN OPERAND WITH THIS FLOATING COMMAND_^1_$IF(KF2.NE.0) GO TO 10_^1C_]_^1C_'NO, ARE ALL BYTES FILLED_^1_!70 IF(KBYTX.EQ.4) GO TO 20_^1C_]_^1C_'NO, BUT WAS THE COMM€€AND A STOP CODE._^1_$IF(KF1.EQ.4) GO TO 20_^1C_]_^1C_'NO, INCREMENT BYTE-INDEX AND EXIT._^1_$KBYTX=KBYTX+1_^1_$RETURN_^1C_]_^1C_]_^1C_'GENERATE KFCET(1,1) AS A CONSTANT_^1_!20 OUTBUF(5)=INDTAB(2)_^1_$OUTBUF(6)=NCON_^1_$OUTBUF(7)=KFCET(1,1)_^1_$I=1_]_^1_!60 KOBX=8_^1_!61 CALL KOUTPT_^1C_]_^1C_'GENERATE EACH ADDRESS AS AN ADDRESS CONSTANT._^1_!50 IF(KFCETX.EQ.I) GO TO 30_^1_$I=I+1_^1€€*_#5 CARDS DELETED FTN 3.3_^1_$OUTBUF(5) = KFCET(I,1)_^1_$OUTBUF(6) = NADC_^1_$OUTBUF(7) = KFCET(I,2)_^1*_#4 CARDS DELETED FTN 3.3_^1C_]_^1C_FDOES INDICATOR WORD SHOW_^1C_FADDITIVE_^1C_]_^1 54_!IF (KFCET(I,1).LT.8192) GO TO 60_^1_$OUTBUF(8)=KFCET(I,3)_^1_$KOBX=9_^1_$GO TO 61_^1C_]_^1C_]_^1C_'PLACE OPERAND AND OTHER DATA INTO KFCET_^1_!10 KFCETX=KFCETX+1_^1_$KFCET(KFCETX,2)= KF2_^1€8_$KFCET(KFCETX,1)= KQ(1)_^1_$IF(KF1.NE.15)GO TO 100_^1_$KFCET(KFCETX,1)=INDTAB(2)_^1_$IF(KFLAM.EQ.0) KFCET(KFCETX,1)=KFCET(KFCETX,1)+8_^1_$GO TO 70_^1 100 KFCET(KFCETX,3)=KQ(4)_^1_$GO TO 70_^1C_]_^1C_]_^1C_'REINITIALIZE FLOATING COMMAND ELEMENT TABLE._^1_!30 KFCET(1,1)=0_^1_$KFCETX=1_^1_$KBYTX=1_^1_$END_]_^__ 8PWKCPRT CSY/ 03B P€1_$SUBROUTINE KCPART(IAR,K)_^1_#*_2/DECK-ID 03B FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^13_]_^1C_]_^1C_'---- MASS STORAGE VERSION ---_^1C_]_^1C_'SUBROUTINE TO CLEAR ONLY THE REAL OR ONLY_^1C_'THE PSEUD0-ACCUMULATOR PORTIONS OF THE_^1C_'ACCUMULATO€ R RECORD TABLE,_^1C_]_^1C ********************************** FTN 3.1 **************************_^1_$DIMENSION IAR(2,3,3)_^1C ********************************** FTN 3.1 ($) **********************_^1_$DO 10 L=1,3,1_^1_$IAR(1,L,K)=0_^1_!10 IAR(2,L,K)=0_^1_$END_]_^__ PWKOTPT CSY/ 04B P€1_$SUBROUTINE KOUTPT_^1_#*_2/DECK-ID 04B FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^13_]_^1C KOUTPT IS USED IN PHASE B1_^1C_]_^1C_#MASTER LABELED COMMON BLOCK._^1*_] FTN 3.3_^1_$COMMON /A/ IFLAGS,LINECT,LINCT1_^1_$COMMON /A/ IR,IK,IP,IA,IL,IM,IXLGO,I€€OPTO,IOPTV,IOPTC,IOPTD_^1_$COMMON /A/ MCSTRT,MACRNB,MACSEC_^1_$COMMON /A/ IERRS(16),ISRFAD_^1_$COMMON /A/ LGO,ISCRI,ISCRO,IX_^1*_] FTN 3.3_^1_$COMMON /A/ IGLAB(3),IGLAB1,IGLAB2_^1_$COMMON /A/ ICOMT(12),ICOMTS,ICOMX2,ICOMTL,ISUBP,NDPRS,_^1_#$LABX,IBCDTB(48)_^1_$EQUIVALENCE(ICOMB,ICOMT(1)),(ICOMBX,ICOMT(2)),(ICOMDF,_^1_#$ICOMT(3)),(ICOMBN,ICOMT(4))_^1_$DIMENSION ICOMB(6),ICOMBX(6),I€€COMDF(6),ICOMBN(7)_^1_$COMMON /A/ LOOPTS,LOOPTX,LOOPTB,LOOPT(50)_^1_$EQUIVALENCE(LINDUC,LOOPT(1))_^1_$DIMENSION LINDUC(10)_^1_$EQUIVALENCE (LBEG,LOOPT(2))_^1_$DIMENSION LBEG(10)_^1_$EQUIVALENCE (LINC,LOOPT(3))_^1_$DIMENSION LINC(10)_^1_$EQUIVALENCE (LEND,LOOPT(4))_^1_$DIMENSION LEND(10)_^1_$BYTE(LLABL,LOOPT(5)(14=0)_))_^1_$DIMENSION LLABL(10)_^1_$BYTE(LID,LOOPT(5)(15=15) )_^1_$DI€€MENSION LID(10)_^1_$COMMON /A/ IEQV(255),IEQVS,IEQVN2_^1_$COMMON /A/ ISTAB(150),ISTABS,ISTAB2_^1_$COMMON /A/ IBUFS,ISET(25),LBLANK,KSFCNT,KSNCNT,ISORSC,_^1_#$IHOBIT,ISTNO,ISSFLG,ISUBPN,ITERM,JSORSC,KEQVS_^1C_]_^1C_#SYMBOL TABLE LABELED COMMON BLOCK_^1_$COMMON /A/ ISYMN, ISYMFL,ISYMD,ISYMX,ISYMS,ISYMP,ISYMPC,ISYMPS,_^1_#$ ISYMNS, SYMTAB(960)_^1_$INTEGER SYMTAB_^1_$BYTE (IDUM,SYMTAB(€€1)(15=15)),(KDUMY,SYMTAB(1)(15=15)),_^1_#$(ICLASS,SYMTAB(1)(14=11)),(ITYPE,SYMTAB(1)(10=9))_^1_$DIMENSION IDUM(100),KDUMY(100),ICLASS(100),ITYPE(100)_^1_$BYTE (ISNGL, SYMTAB(1)(8=8)),(KELSIZ,SYMTAB(1)(8=8)),_^1_#$ (ICOM,SYMTAB(1)(7=5)),(IPART,SYMTAB(1)(4=3))_^1_$DIMENSION ISNGL(100),KELSIZ(100),ICOM(100),IPART(100)_^1_$BYTE (KRFCNT,SYMTAB(1)(2=2)),(IDIM,SYMTAB(1)(1=0)),_^1_#$ (IREL€€,SYMTAB(1)(1=1)),(IEXT,SYMTAB(1)(0=0))_^1_$DIMENSION KRFCNT(100),IDIM(100),IREL(100),IEXT(100)_^1_$EQUIVALENCE (IRSA,SYMTAB(2)),(ICOMTX,SYMTAB(2)),(ISNOL,SYMTAB(2))_^1_$DIMENSION IRSA(100), ICOMTX(100),ISNOL(100)_^1_$BYTE (IDATAS,SYMTAB(3)(15=15)),(IREF,SYMTAB(3)(15=15)),_^1_#$ (IEQVX,SYMTAB(3)(14=8)),(ITILF,SYMTAB(3)(14=8))_^1_$DIMENSION IDATAS(100),IREF(100),IEQVX(100),ITILF(100)€€_^1_$BYTE (IPARTR,SYMTAB(3)(7=4)),(INDUCV,SYMTAB(3)(7=7)),(ISFARG,_^1_#$ SYMTAB(3)(6=6)),(IARGNO,SYMTAB(3)(5=0)),(IPARTL,SYMTAB(3)(3=0))_^1_$DIMENSION IPARTR(100),INDUCV(100),ISFARG(100),IARGNO(100),_^1_#$ IPARTL(100)_^1_$EQUIVALENCE (ISYM,SYMTAB(4))_^1_$DIMENSION ISYM(100)_^1C_]_^1C_#SPECIFICATION-TABLE INDEX LABELLED COMMON BLOCK_^1_$COMMON /A/ ISTABX(96)_^1C_]_^1C_#PHASE 4 LABEL€€ED COMMON BLOCK._^1_$COMMON /A/ INDTAB(18),INFTB(18)_^1_#2,NBSS ,NADC ,NCON ,NEND ,NPST ,NSTN ,NJMP ,NRTJ ,NLDA_^1_#3,NLDQ ,NSTA ,NSTQ ,NRAO ,NADD ,NSUB ,NAND ,NDVI ,NADQ_^1_#4,NENA ,NINA ,NENQ ,NINQ ,NLRS ,NLLS ,NQRS ,NQLS ,NARS_^1_#5,NALS ,NAJLGZ,NAJEZ ,NAJLZ ,NAJGEZ,NAJLEZ,NAJGZ ,NQJEZ ,NMUI_^1_$COMMON/A/_^1_#1 NFCM ,NFSB ,NFMU ,NFDV ,NFLD ,NFST ,N€€FAD ,NCAQA_^1_#2,NTCQA ,NTRAQ ,KLDQ ,KSTQ ,NTCAA ,NEOR ,NTCQQ_^1_#3,INFTBL,INFTBN,INFTBX_^1_$DIMENSION KODNAM(18), KFTYPE(6),NLINE(6),NPMTRS(6),KSPTAB(14)_^1_$EQUIVALENCE (INFTB(1),KODNAM(1)),(ISET(11),KSPTAB(1))_^1_$BYTE (KFTYPE,INFTB(3)(15=14)),(NLINE,INFTB(3)(13=13)),_^1_#$ (NPMTRS,INFTB(3)(12=0))_^1C_]_^1C_#PHASE 4 BLANK COMMON BLOCK._^1_$COMMON//JSYM(3),_^1C **************€€******************** FTN 3.1 **************************_^1_#1 INBUFF(304),OUTBUF(10),KART(2,3,3),KQ(5),KFCET(5,3),_^1C ********************************** FTN 3.1 ($) **********************_^1_#2 KSUBAT(240),KSFAT(12,2),KLLTB(10,2),LPTYP(10),_^1_#3 INTRAS(304),IMOD(30),NDTYP(30),NBRNS(30),ICBRN(30),_^1_#4 KOP(30),KTRUT(30)_^1_$DIMENSION KFALS(30),KFATH(30),KOMPSW(30),KSBPTR(30),KR€€ESW(30)_^1_$EQUIVALENCE (KFALS(1),ISTAB(1)),(KFATH(1),ISTAB(31)),_^1_#1 (KOMPSW(1),ISTAB(61)),(KSBPTR(1),ISTAB(91)),(KRESW(1),ISTAB(121))_^1_$COMMON// LTYP,MBEGIN_^1_#1,IADDIT,INTRAX,IPTR,ISBSCP,JXX,KBEGIN,KBIAS,KBYTX,KENTER,KENTRY_^1_#2,KEXEC,KEXTYP,KFCSW,KFFSAV,KFINDX,KFLAM,KINTYP,KLLTBX,KNTROL_^1_#3,KOBX,KPRNAM,KQSAV,KRETRN,KSFNAM,KTCATX,LEVEL,LIFTX,LOGIF,KFCETX_^1_$DIMENSION NI€NVS(30),NINENC(30),NPASS(30)_^1_$EQUIVALENCE (KTRUT(1),NINVS(1)),(KFALS(1),NINENC(1))_^1_#1,(KFATH(1),NPASS(1))_^1_$INTEGER OUTBUF_^1C_]_^1C_]_^1C_'ROUTINE TO WRITE OUT THE OUTPUT BUFFER_^1C_]_^1C_]_^1_$OUTBUF(1)=KOBX-1_^1_$CALL WRITE(ISCRO,0,OUTBUF(1),OUTBUF(1))_^1_$END_]_^__ PWKPCK CSY/ 05B P€1_$SUBROUTINE KPCSTK(KP1,KP2,KP3,KP4,KP5)_^1_#*_2/DECK-ID 05B FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^13_]_^1C ********************************** FTN 3.1 **************************_^1C_]_^1C_FKPCSTK IS USED IN PHASE B_^1C_]_^1C_FMASTER LABELED COM€€MON BLOCK_^1C_]_^1*_] FTN 3.3_^1_$COMMON /A/ IFLAGS,LINECT,LINCT1_^1_$COMMON /A/ IR,IK,IP,IA,IL,IM,IXLGO,IOPTO,IOPTV,IOPTC,IOPTD_^1_$COMMON /A/ MCSTRT,MACRNB,MACSEC_^1_$COMMON /A/ IERRS(16),ISRFAD_^1_$COMMON /A/ LGO,ISCRI,ISCRO,IX_^1*_] FTN 3.3_^1_$COMMON /A/ IGLAB(3),IGLAB1,IGLAB2_^1_$COMMON /A/ ICOMT(12),ICOMTS,ICOMX2,ICOMTL,ISUBP,NDPRS_^1_$COMMON /A/ LABX,IBCDTB(48)_^1_$COMMON€€ /A/ LOOPTS,LOOPTX,LOOPTB,LOOPT(50)_^1_$COMMON /A/ IEQV(255),IEQVS,IEQVN2_^1_$COMMON /A/ ISTAB(150),ISTABS,ISTAB2_^1_$COMMON /A/ IBUFS,ISET(25),LBLANK,KSFCNT,KSNCNT,ISORSC_^1_$COMMON /A/ IHOBIT,ISTNO,ISSFLG,ISUBPN,ITERM,JSORSC,KEQVS_^1C_]_^1_$EQUIVALENCE (KSPTAB,ISET(11))_^1_$DIMENSION KSPTAB(14)_^1C_]_^1C_FSYMBOL TABLE LABELED COMMON BLOC_^1C_]_^1_$COMMON /A/ ISYMN,ISYMFL,ISYMD,IS€€YMX,ISYMS,ISYMP,ISYMPC,ISYMPS_^1_$COMMON /A/ ISYMNS,SYMTAB(960)_^1C_]_^1_$INTEGER SYMTAB_^1_$EQUIVALENCE (ISYM,SYMTAB(4))_^1C_]_^1_$BYTE (IDUM,SYMTAB(1)(15=15)), (KDUMY,SYMTAB(1)(15=15))_^1_$BYTE (ICLASS,SYMTAB(1)(14=11)), (ITYPE,SYMTAB(1)(10=9))_^1_$BYTE (ISNGL,SYMTAB(1)(8=8)), (KELSIZ,SYMTAB(1)(8=8))_^1_$BYTE (ICOM,SYMTAB(1)(7=5)), (IPART,SYMTAB(1)(4=3))_^1_$BYTE (KRFCNT,SYMTAB(€€1)(2=2)), (IDIM,SYMTAB(1)(1=0))_^1_$BYTE (IREL,SYMTAB(1)(1=1)), (IEXT,SYMTAB(1)(0=0))_^1_$BYTE (IDATAS,SYMTAB(3)(15=15)), (IREF,SYMTAB(3)(15=15))_^1_$BYTE (IEQVX,SYMTAB(3)(14=8)), (ITILF,SYMTAB(3)(14=8))_^1C_]_^1_$DIMENSION ISYM(100)_^1_$DIMENSION IDUM(100), KDUMY(100), ICLASS(100), ITYPE(100)_^1_$DIMENSION ISNGL(100), KELSIZ(100), ICOM(100), IPART(100)_^1_$DIMENSION KRFCNT(100), €€IDIM(100), IREL(100), IEXT(100)_^1_$DIMENSION IDATAS(100), IREF(100), IEQVX(100), ITILF(100)_^1C_]_^1C_FSPECIFICATION-TABLE INDEX LABELD_^1C_FCOMMON BLOCK_^1C_]_^1_$COMMON /A/ ISTABX(96)_^1C_]_^1C_FPHASE 4 LABLED COMMON BLOCK_^1C_]_^1_$COMMON /A/ INDTAB(18),INFTB(18)_^1_$COMMON /A/ NBSS,NADC,NCON,NEND,NPST,NSTN,NJMP,NRTJ,NLDA_^1_$COMMON /A/ NLDQ,NSTA,NSTQ,NRAO,NADD,NSUB,NAND,NDVI,N€€ADQ_^1_$COMMON /A/ NENA,NINA,NENQ,NINQ,NLRS,NLLS,NQRS,NQLS,NARS_^1_$COMMON /A/ NALS,NAJLGZ,NAJEZ,NAJLZ,NAJGEZ,NAJLEZ,NAJGZ,NQJEZ,NMUI_^1_$COMMON /A/ NFCM,NFSB,NFMU,NFDV,NFLD,NFST,NFAD,NCAQA_^1_$COMMON /A/ NTCQA,NTRAQ,KLDQ,KSTQ,NTCAA,NEOR,NTCQQ_^1_$COMMON /A/ INFTBL,INFTBN,INFTBX_^1_$COMMON /A/ NDCM,NDSB,NDMU,NDDV,NDLD,NDST,NDAD_^1_$COMMON /A/ IDFLOT,IDSTR1,IDSTR2,IRSTR1,IQ8DFT_^1_$€€COMMON /A/ IEXD2I,IEXD2F,IEXD2D_^1_$COMMON /A/ IDPFLG_^1*_YBEGIN FTN 3.3_^1_$COMMON /A/ NFLOF,NFIXF,NDFLOF,NDFIXF_^1*_[END FTN 3.3_^1C_]_^1_$EQUIVALENCE (KODNAM,INFTB(1))_^1_$BYTE (KFTYPE,INFTB(3)(15=14)), (NLINE,INFTB(3)(13=13))_^1_$BYTE (NPMTRS,INFTB(3)(12=0))_^1_$DIMENSION KODNAM(18), KFTYPE(6), NLINE(6), NPMTRS(6)_^1C_]_^1C_FPHASE 4 BLANK COMMON BLOCK_^1C_]_^1_$COMMON // JSYM(3€€)_^1_$COMMON // INBUFF(304), OUTBUF(10), KART(2,3,3), KQ(5), KFCET(5,3)_^1_$COMMON // KSUBAT(240), KSFAT(12,2), KLLTB(10,2), LPTYP(10)_^1_$COMMON // INTRAS(304), IMOD(30), NDTYP(30), NBRNS(30), ICBRN(30)_^1_$COMMON // KOP(30), KTRUT(30)_^1_$COMMON // LTYP,MBEGIN,IADDIT,INTRAX,IPTR,ISBSCP,JXX,KBEGIN,KBIAS_^1_$COMMON // KBYTX,KENTER,KENTRY,KEXEC,KEXTYP,KFCSW,KFFSAV,KFINDX_^1_$COMMON €€// KFLAM,KINTYP,KLLTBX,KNTROL,KOBX,KPRNAM,KQSAV,KRETRN_^1_$COMMON // KSFNAM,KTCATX,LEVEL,LIFTX,LOGIF,KFCETX_^1_$COMMON // KSTYP,KRTNS,IDMM(5)_^1C_]_^1_$INTEGER OUTBUF_^1_$EQUIVALENCE (NINVS,KTRUT(1))_^1_$DIMENSION NINVS(30)_^1C_]_^1C_FKPCSTK LOCAL VARIABLES EQUIV_^1C_FTO BLANK COMMON_^1C_]_^1_$BYTE (KNDT,KQ(1)(14=14))_^1_$BYTE (KNDA,KQ(1)(13=13))_^1_$BYTE (KNDS,KQ(1)(12=12))_^1€€_$BYTE (KNDO,KQ(1)(7=2))_^1_$BYTE (KNDN,KQ(1)(1=0))_^1_$EQUIVALENCE (KRT111,KART(1,1,1)), (KRT121,KART(1,2,1))_^1_$EQUIVALENCE (KRT131,KART(1,3,1)), (KRT211,KART(2,1,1))_^1_$EQUIVALENCE (KRT221,KART(2,2,1)), (KRT231,KART(2,3,1))_^1_$EQUIVALENCE (KRT112,KART(1,1,2)), (KRT122,KART(1,2,2))_^1_$EQUIVALENCE (KRT132,KART(1,3,2)), (KRT212,KART(2,1,2))_^1_$EQUIVALENCE (KRT222,KART(€€2,2,2)), (KRT232,KART(2,3,2))_^1_$EQUIVALENCE (KRT113,KART(1,1,3)), (KRT123,KART(1,2,3))_^1_$EQUIVALENCE (KRT133,KART(1,3,3)), (KRT213,KART(2,1,3))_^1_$EQUIVALENCE (KRT223,KART(2,2,3)), (KRT233,KART(2,3,3))_^1_$EQUIVALENCE (K1,KQ(1)), (K2,KQ(2)), (K3,KQ(3)), (K4,KQ(4))_^1_$EQUIVALENCE (K5,KQ(5))_^1._]_^1C_]_^1C_FKPCSTK RECEIVES INSTRUCTIONS_^1C_FAND BUILDS THE OUTPUT BUFFER_^1€€*_$CARDS DELETED FTN 3.3_^1C_]_^1C_FTRANSFER CALLING SEQUENCE_^1C_FELEMENTS TO WORKING CELLS_^1C_]_^1_$K1 = KP1_^1_$K2 = KP2_^1_$K3 = KP3_^1_$K4 = KP4_^1_$K5 = KP5_^1_$KFLAG = 0_^1C_]_^1C_FIS THIS INSTR A LABEL OR CON_^1C_]_^1_$IF (KNDT.EQ.0 .AND. K2.NE.NCON) GO TO 10_^1C_]_^1C_FYES, CLEAR ACCUMS AND STACK INST_^1C_]_^1_$CALL KCPART(KART,1)_^1_$CALL KCPART(KART,2)_^1_$CALL KCPART(€€KART,3)_^1_$GO TO 430_^1 10_!IF (K2.EQ.NLDA) GO TO 20_^1_$IF (K2.EQ.NSTA) GO TO 30_^1_$IF (K2.EQ.NRAO) GO TO 40_^1_$IF (K2.EQ.NFLD) GO TO 50_^1_$IF (K2.EQ.NFST) GO TO 60_^1_$IF (K2.EQ.NDLD) GO TO 70_^1_$IF (K2.EQ.NDST) GO TO 80_^1C_]_^1C_FCLEAR KART IF INSTR IS JMP, RTJ_^1C_]_^1_$IF (K2 .EQ. NJMP .OR. K2 .EQ. NRTJ) GO TO 12_^1C_]_^1C_FIF INSTR MODIFIES A-REG, CLEAR_^1C_FA-R€€EG IN KART_^1C_]_^1_$IF (K2.EQ.NAND .OR. K2.EQ.NADD .OR. K2.EQ.NSUB .OR. K2.EQ.NDVI.OR._^1_#-_"K2.EQ.NMUI .OR. K2.EQ.NEOR .OR. K2.EQ.NENA .OR. K2.EQ.NINA.OR._^1_#-_"K2.EQ.NLRS .OR. K2.EQ.NLLS .OR. K2.EQ.NARS .OR. K2.EQ.NALS.OR._^1_#-_"K2.EQ.NCAQA.OR. K2.EQ.NTCQA.OR. K2.EQ.NTCAA)_^1_#- CALL KCPART(KART,1)_^1C_]_^1C_FIF INSTR MODIFIES FP-ACCUM,_^1C_FCLEAR FP-ACCUM IN KART_^1C_]_^1_$€€IF (K2.EQ.NFCM .OR. K2.EQ.NFSB .OR. K2.EQ.NFMU .OR. K2.EQ.NFDV.OR._^1*_YBEGIN FTN 3.3_^1_#-_"K2.EQ.NFLOF.OR.K2.EQ.NFIXF.OR._^1*_[END FTN 3.3_^1_#-_"K2.EQ.NFAD) CALL KCPART(KART,2)_^1C_]_^1C_FIF INSTR MODIFIES DP-ACCUM,_^1C_FCLEAR DP-ACCUM IN KART_^1C_]_^1_$IF (K2.EQ.NDCM .OR. K2.EQ.NDSB .OR. K2.EQ.NDMU .OR. K2.EQ.NDDV.OR._^1*_YBEGIN FTN 3.3_^1_#-_"K2.EQ.NDFLOF.OR.K2.EQ.NDFIXF.OR._€€^1*_[END FTN 3.3_^1_#-_"K2.EQ.NDAD) CALL KCPART(KART,3)_^1_$GO TO 200_^1 12_!CALL KCPART(KART,1)_^1_$CALL KCPART(KART,2)_^1_$CALL KCPART(KART,3)_^1_$GO TO 200_^1C_]_^1C_FLDA_^1C_]_^1 20_!IF (K3.EQ.KRT111 .AND. K4.EQ.KRT121 .AND. K5.EQ.KRT131 .AND._^1_#-_"(KRT211.NE.KRT131 .OR. KRT211.EQ.0)) RETURN_^1_$IF (K3.EQ.KRT211 .AND. K4.EQ.KRT221 .AND. K5.EQ.KRT231) RETURN_^1_$K = 1_^1_$G€€O TO 140_^1C_]_^1C_FSTA_^1C_]_^1 30_!K = 1_^1_$GO TO 100_^1C_]_^1C_FRAO_^1C_]_^1 40_!I = 0_^1_$ASSIGN 42 TO J_^1_$GO TO 190_^1 42_!IF (I.EQ.0) GO TO 44_^1_$CALL KCPART(KART,1)_^1_$GO TO 48_^1 44_!IF ((K3.NE.KRT211 .OR. K4.NE.KRT221 .OR. K5.NE.KRT231) .AND._^1_#-_"K3.NE.KRT231) GO TO 46_^1_$KRT211 = 0_^1_$KRT221 = 0_^1_$KRT231 = 0_^1 46_!IF ((K3.NE.KRT111 .OR. K4.NE.KRT121 .OR. K5€€.NE.KRT131) .AND._^1_#-_"K3.NE.KRT131) GO TO 48_^1_$KRT111 = KRT211_^1_$KRT121 = KRT221_^1_$KRT131 = KRT231_^1 48_!GO TO 185_^1C_]_^1C_FFLD_^1C_]_^1 50_!IF (K3.EQ.KRT112 .AND. K4.EQ.KRT122 .AND. K5.EQ.KRT132) RETURN_^1_$IF (K3.EQ.KRT212 .AND. K4.EQ.KRT222 .AND. K5.EQ.KRT232) RETURN_^1_$K = 2_^1_$GO TO 140_^1C_]_^1C_FFST_^1C_]_^1 60_!K = 2_^1_$GO TO 100_^1C_]_^1C_FDLD_^1C_]_^1 70€€_!IF (K3.EQ.KRT113 .AND. K4.EQ.KRT123 .AND. K5.EQ.KRT133) RETURN_^1_$IF (K3.EQ.KRT213 .AND. K4.EQ.KRT223 .AND. K5.EQ.KRT233) RETURN_^1_$K = 3_^1_$GO TO 140_^1C_]_^1C_FDST_^1C_]_^1 80_!K = 3_^1C_]_^1C_FREMEMBER STORES_^1C_]_^1 100 IF (KART(1,1,K).EQ.0) GO TO 140_^1_$I = 0_^1_$ASSIGN 110 TO J_^1_$GO TO 190_^1 110 IF (I.EQ.1) GO TO 130_^1_$DO 120 M=1,3_^1 120 KART(2,M,K) = KQ(M€€+2)_^1_$GO TO 200_^1 130 DO 135 M=1,3_^1 135 KART(2,M,K) = 0_^1_$GO TO 200_^1C_]_^1C_FREMEMBER LOADS_^1C_]_^1*_YBEGIN FTN 3.3_^1 140 I=0_]_^1*_[END FTN 3.3_^1_$ASSIGN 150 TO J_^1_$GO TO 190_^1 150 IF (I.EQ.1) GO TO 170_^1_$DO 160 M=1,3_^1_$KART(1,M,K) = KQ(M+2)_^1 160 KART(2,M,K) = 0_^1_$GO TO 180_^1 170 DO 175 M=1,3_^1_$KART(1,M,K) = 0_^1 175 KART(2,M,K) = 0_^1 180 IF (K.€€NE.1) GO TO 200_^1 185 CALL KCPART(KART,2)_^1_$CALL KCPART(KART,3)_^1_$GO TO 200_^1C_]_^1C_FEQUIVALENCE CHECK_^1C_]_^1 190 ISYMX = K3_^1_$CALL GETSYM_^1_$IF (ICLASS(ISYMX).NE.1) GO TO 192_^1_$IF (IEQVX(ISYMX).NE.0 .OR. IPART(ISYMX).NE.0) I = 1_^1 192 IF (K5.EQ.0) GO TO 194_^1_$ISYMX = K5_^1_$CALL GETSYM_^1_$IF (IEQVX(ISYMX).NE.0 .OR. IPART(ISYMX).NE.0) I = 1_^1 194 GO TO J€€_^1C_]_^1C_FIF S-BIT IS SET BUT INSTR IS NOT_^1C_FREALLY SUBSCRIPTED SET S-BIT TO_^1C_F0 AND REDUCE N-FIELD BY 1_^1C_]_^1 200 IF (KNDS.EQ.0 .OR. K5.NE.0) GO TO 210_^1_$K1 = K1 - 4097_^1_$GO TO 220_^1 210 IF (K5.EQ.0) GO TO 220_^1_$ISYMX = K5_^1_$CALL GETSYM_^1_$IF (IDUM(ISYMX).EQ.0) GO TO 220_^1_$CALL DUMMY(K5,0)_^1C_]_^1C_FIS OPERAND AN ABSOLUTE VALUE OR_^1C_FADC IN FP CALL_^€€1C_]_^1 220 IF (KNDO.EQ.2 .OR. (KNDO.EQ.1 .AND. K2.NE.NADC)) GO TO 430_^1C_]_^1C_FNO, TEST FOR NO OPERAND_^1C_]_^1_$IF (KNDO.EQ.7) GO TO 300_^1C_]_^1*_#3 CARDS DELETED FTN 3.3_^1C_]_^1C_FLOOK UP SYMTAB ENTRY_^1C_]_^1_$ISYMX = K3_^1_$CALL GETSYM_^1C_]_^1C_FIF OPERAND IS FP, ADD 2 TO KFLAG_^1C_]_^1_$IF (ITYPE(ISYMX).EQ.2 .OR. ITYPE(ISYMX).EQ.3) KFLAG = KFLAG + 2_^1C_]_^1C_FIS OPE€€RAND A CONSTANT_^1C_]_^1_$IF (ICLASS(ISYMX).NE.2) GO TO 230_^1C_]_^1C_FYES, IS IT A FP CONSTANT_^1C_]_^1_$IF (KFLAG.EQ.2) GO TO 300_^1C_]_^1C_FNO, IS THE COMMAND A LDA,ADD,SUB_^1C_]_^1_$IF (K2.NE.NLDA .AND. K2.NE.NADD .AND. K2.NE.NSUB) GO TO 270_^1C_]_^1C_FYES, IS CONSTANT LESS 128 AND_^1C_FGREATER -128_^1C_]_^1_$IF (ISYM(ISYMX).LT.128 .AND. ISYM(ISYMX).GT.(-128)) GO TO 400_^1_€€$GO TO 270_^1C_]_^1C_FIS OPERAND A VARIABLE_^1C_]_^1 230 IF (ICLASS(ISYMX).EQ.1) GO TO 240_^1C_]_^1C_FNO_^1C_]_^1_$IF ((ICLASS(ISYMX).EQ.5 .OR. ICLASS(ISYMX).EQ.6 .OR._^1_#-_#(ICLASS(ISYMX).EQ.0 .AND. IEXT(ISYMX).NE.0)) .AND._^1_#-_"IDUM(ISYMX).NE.0 .AND. K2.NE.NPST) CALL DUMMY(K3,K4)_^1_$GO TO 430_^1C_]_^1C_FIS VARIABLE AN ARRAY_^1C_]_^1 240 IF (IDIM(ISYMX).EQ.0 .OR. INBUFF(3)€€.EQ.44) GO TO 250_^1C_]_^1C_FYES, ADJUST ADDITIVE_^1C_]_^1_$K4 = K4 - KELSIZ(ISYMX) - 1_^1_$IF (ITYPE(ISYMX).EQ.3) K4 = K4 - 1_^1_$KFLAG = KFLAG + 1_^1C_]_^1C_FIS OPERAND A DUMMY ARGUMENT_^1C_]_^1 250 IF (IDUM(ISYMX).EQ.0 .OR. K2.EQ.NPST) GO TO 260_^1C_]_^1C_FYES_^1C_]_^1_$CALL DUMMY(K3,K4)_^1_$IF (KNDA.NE.0) KNDN = KNDN - 1_^1_$KNDA = 0_^1_$K4 = K5_^1_$GO TO 270_^1C_]_^1C_FIS€€ VARIABLE IN EQUIV CHAIN,_^1C_FIF SO, ADD 4 TO KFLAG_^1 260 IF (IEQVX(ISYMX).NE.0) KFLAG = KFLAG + 4_^1C_]_^1C_FTEST KFLAG_^1C_]_^1_$IF (KFLAG.EQ.0) GO TO 270_^1_$IF (KFLAG.NE.1) GO TO 300_^1C_]_^1C_FSET USE COUNT_^1C_]_^1 270 KRFCNT(ISYMX) = 1_^1_$IF (K5.EQ.0) GO TO 300_^1_$ISYMX = K5_^1_$CALL GETSYM_^1_$KRFCNT(ISYMX) = 1_^1_$ISYMX = K3_^1_$CALL GETSYM_^1C_]_^1C_FIS THIS A F€€P INSTRUCTION_^1C_]_^1 300 IF (K2.EQ.NFCM .OR. K2.EQ.NFSB .OR. K2.EQ.NFMU .OR. K2.EQ.NFDV.OR._^1*_YBEGIN FTN 3.3_^1_#-_"K2.EQ.NFLOF.OR.K2.EQ.NFIXF.OR._^1*_[END FTN 3.3_^1_#-_"K2.EQ.NFLD .OR. K2.EQ.NFST .OR. K2.EQ.NFAD) GO TO 305_^1_$IF (K2.EQ.NDCM .OR. K2.EQ.NDSB .OR. K2.EQ.NDMU .OR. K2.EQ.NDDV.OR._^1*_YBEGIN FTN 3.3_^1_#-_"K2.EQ.NDFLOF.OR.K2.EQ.NDFIXF.OR._^1*_[END FTN 3.3_^1_#-_€€"K2.EQ.NDLD .OR. K2.EQ.NDST .OR. K2.EQ.NDAD) GO TO 310_^1_$GO TO 430_^1 305 IF (KFCSW.EQ.1) GO TO 330_^1_$IF (KFCSW.NE.2) GO TO 308_^1_$CALL FCMSTK(4,0)_^1_$CALL KCPART(KART,3)_^1 308 KFCSW = 1_^1_$OUTBUF(7) = KSPTAB(4)_^1_$GO TO 320_^1 310 IF (KFCSW.EQ.2) GO TO 330_^1_$IF (KFCSW.NE.1) GO TO 315_^1_$CALL FCMSTK(4,0)_^1_$CALL KCPART(KART,2)_^1 315 KFCSW = 2_^1C_]_^1C_F131 I€€S SYMTAB PTR FOR DFLOT_^1C_]_^1_$OUTBUF(7) = IDFLOT_^1C_]_^1C_FGENERATE RTJ TO FLOT OR DFLOT_^1C_]_^1 320 OUTBUF(5) = INDTAB(5)_^1_$OUTBUF(6) = NRTJ_^1_$KOBX = 8_^1_$CALL KOUTPT_^1_$CALL KCPART(KART,1)_^1_$KFINDX = 0_^1_$KFLAM = 0_^1_$KFCET(1,1) = 0_^1_$KBYTX = 1_^1_$KFCETX = 1_^1C_]_^1C_FIS THIS A COMPLEMENT INSTRUCTION_^1C_]_^1 330 IF (K2.EQ.NFCM .OR. K2.EQ.NDCM) GO TO 395_^1C€€_]_^1*_] FTN 3.3_^12_]_^1*_#IS THERE ANY INDEXING ?_^12_]_^1_$IF(K5.EQ.0) GO TO 350_^12_]_^1*_#CLEAR S BIT AND REDUCE N FIELD BY 1_^12_]_^1_$K1=K1-$1001_^12_]_^1*_#DOES PRESENT INDEXING MATCH INDEX OF THIS COMMAND\_^12_]_^1_$IF(KFINDX.EQ.K5) GO TO 365_^1*_] FTN 3.3_^1C_]_^1C_FYES, GENERATE INDEXING COMMAND_^1C_]_^1_$ISYMX = K5_^1_$CALL GETSYM_^1_$ASSIGN 340 TO IAD_^1_$GO TO 380_^€€1*_] FTN 3.3_^1 340 CALL FCMSTK(15,K5)_^1*_] FTN 3.3_^1_$ISYMX = K3_^1_$CALL GETSYM_^1_$GO TO 360_^1C_]_^1C_FGENERATE NO-INDEXING COMMAND_^1C_]_^1*_] FTN 3.3_^1 350 IF(KFINDX.NE.0) CALL FCMSTK(6,0)_^1*_] FTN 3.3_^1C_]_^1C_FUPDATE CURRENT INDEXING_^1C_]_^1 360 KFINDX = K5_^1 365 ASSIGN 370 TO IAD_^1_$GO TO 380_^1 370 GO TO 390_^1C_]_^1C_FIF ADDRESSING MODE HAS CHANGED,_^1C_€€FGENERATE CHANGE OF ADDRESSING_^1C_FMODE_^1C_]_^1 380 IF (IR.NE.1) GO TO 389_^1*_#7 CARDS DELETED FTN 3.3_^1 382 IF ((ICOM(ISYMX)+KDUMY(ISYMX).NE.0 .AND. KFLAM.NE.0) .OR._^1_#-_"(ICOM(ISYMX)+KDUMY(ISYMX)+KFLAM.EQ.0))_^1_#- GO TO 385_^1_$GO TO 389_^1 385 CALL FCMSTK(5,0)_^1C_]_^1C_FREVERSE KFLAM FLIP-FLOP_^1C_]_^1_$KFLAM = KFLAM - KFLAM*2 + 1_^1 389 GO TO IAD_^1C_]_^1C_FGENERA€€TE ACTUAL FP INSTRUCTION_^1C_]_^1 390 K1 = K1 + 8_^1_$IF (KFLAM.EQ.0) K1 = K1 + 8_^1_$I = 45_^1_$IF (KFCSW.EQ.2) I = 65_^1*_YBEGIN FTN 3.3_^1_$IF(K2.EQ.NFLOF.OR.K2.EQ.NFIXF) I=49_^1_$IF(K2.EQ.NDFLOF.OR.K2.EQ.NDFIXF) I=69_^1*_[END FTN 3.3_^1_$CALL FCMSTK(K2-I,K3)_^1_$RETURN_^1C_]_^1C_FGENERATE FP COMPLEMENT INSTR_^1C_]_^1 395 CALL FCMSTK(7,0)_^1_$RETURN_^1C_]_^1C_FHAVE LDA, ADD,€€ OR SUB WITH CONST_^1C_FOPERAND LESS 128 AND GREATR -128_^1C_FMODIFYING INSTR TO ENA OR INA_^1C_]_^1 400 K3 = ISYM(ISYMX)_^1_$IF (K2.EQ.NSUB) K3 = -K3_^1_$IF (K2.EQ.NLDA) GO TO 410_^1_$K2 = NINA_^1_$GO TO 420_^1 410 K2 = NENA_^1 420 KNDO = 2_^1_$KNDN = 1_^1C_]_^1C_FDROP ADD OR SUBTRACT 0_^1C_]_^1_$IF (K2.NE.NENA .AND. ISYM(ISYMX).EQ.0) RETURN_^1C_]_^1C_FTEST KFCSW, IF THIS IS€f A STN_^1C_FDO NOT CHANGE KFCSW_^1C_]_^1 430 IF (K2.EQ.NSTN .OR. KFCSW.EQ.0) GO TO 440_^1_$CALL FCMSTK(4,0)_^1_$KFCSW = 0_^1C_]_^1C_FSTACK INSTRUCTION_^1C_]_^1 440 I = KNDN + 2_^1_$KOBX = I + 5_^1_$DO 450 J=1,I_^1 450 OUTBUF(J+4) = KQ(J)_^1_$CALL KOUTPT_^1_$RETURN_^1C ********************************** FTN 3.1 ($) **********************_^1_$END_]_^__ fPWKPC3 CSY/ 06B P>1_$SUBROUTINE KPC3PR(ILX,ILY,ILZ)_^1_#*_2/DECK-ID 06B FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^13_]_^1C KPC3PR IS USED IN PHASE B1_^1C_]_^1_$CALL KPCSTK(ILX,ILY,ILZ,0,0)_^1_$END_]_^__>PWKSYM CSY/ 07B P€1_$SUBROUTINE KSYMGN(I)_^1_#*_2/DECK-ID 07B FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^13_]_^1C KSYMGN IS USED IN PHASE B1_^1C_]_^1C_#MASTER LABELED COMMON BLOCK._^1*_] FTN 3.3_^1_$COMMON /A/ IFLAGS,LINECT,LINCT1_^1_$COMMON /A/ IR,IK,IP,IA,IL,IM,IXLG€€O,IOPTO,IOPTV,IOPTC,IOPTD_^1_$COMMON /A/ MCSTRT,MACRNB,MACSEC_^1_$COMMON /A/ IERRS(16),ISRFAD_^1_$COMMON /A/ LGO,ISCRI,ISCRO,IX_^1*_] FTN 3.3_^1_$COMMON /A/ IGLAB(3),IGLAB1,IGLAB2_^1_$COMMON /A/ ICOMT(12),ICOMTS,ICOMX2,ICOMTL,ISUBP,NDPRS,_^1_#$LABX,IBCDTB(48)_^1_$EQUIVALENCE(ICOMB,ICOMT(1)),(ICOMBX,ICOMT(2)),(ICOMDF,_^1_#$ICOMT(3)),(ICOMBN,ICOMT(4))_^1_$DIMENSION ICOMB(6),ICOMBX(6€€),ICOMDF(6),ICOMBN(7)_^1_$COMMON /A/ LOOPTS,LOOPTX,LOOPTB,LOOPT(50)_^1_$EQUIVALENCE(LINDUC,LOOPT(1))_^1_$DIMENSION LINDUC(10)_^1_$EQUIVALENCE (LBEG,LOOPT(2))_^1_$DIMENSION LBEG(10)_^1_$EQUIVALENCE (LINC,LOOPT(3))_^1_$DIMENSION LINC(10)_^1_$EQUIVALENCE (LEND,LOOPT(4))_^1_$DIMENSION LEND(10)_^1_$BYTE(LLABL,LOOPT(5)(14=0)_))_^1_$DIMENSION LLABL(10)_^1_$BYTE(LID,LOOPT(5)(15=15) )_^1_€€$DIMENSION LID(10)_^1_$COMMON /A/ IEQV(255),IEQVS,IEQVN2_^1_$COMMON /A/ ISTAB(150),ISTABS,ISTAB2_^1_$COMMON /A/ IBUFS,ISET(25),LBLANK,KSFCNT,KSNCNT,ISORSC,_^1_#$IHOBIT,ISTNO,ISSFLG,ISUBPN,ITERM,JSORSC,KEQVS_^1C_]_^1C_#SYMBOL TABLE LABELED COMMON BLOCK_^1_$COMMON /A/ ISYMN, ISYMFL,ISYMD,ISYMX,ISYMS,ISYMP,ISYMPC,ISYMPS,_^1_#$ ISYMNS, SYMTAB(960)_^1_$INTEGER SYMTAB_^1_$BYTE (IDUM,SYMT€€AB(1)(15=15)),(KDUMY,SYMTAB(1)(15=15)),_^1_#$(ICLASS,SYMTAB(1)(14=11)),(ITYPE,SYMTAB(1)(10=9))_^1_$DIMENSION IDUM(100),KDUMY(100),ICLASS(100),ITYPE(100)_^1_$BYTE (ISNGL, SYMTAB(1)(8=8)),(KELSIZ,SYMTAB(1)(8=8)),_^1_#$ (ICOM,SYMTAB(1)(7=5)),(IPART,SYMTAB(1)(4=3))_^1_$DIMENSION ISNGL(100),KELSIZ(100),ICOM(100),IPART(100)_^1_$BYTE (KRFCNT,SYMTAB(1)(2=2)),(IDIM,SYMTAB(1)(1=0)),_^1_#$ (I€€REL,SYMTAB(1)(1=1)),(IEXT,SYMTAB(1)(0=0))_^1_$DIMENSION KRFCNT(100),IDIM(100),IREL(100),IEXT(100)_^1_$EQUIVALENCE (IRSA,SYMTAB(2)),(ICOMTX,SYMTAB(2)),(ISNOL,SYMTAB(2))_^1_$DIMENSION IRSA(100), ICOMTX(100),ISNOL(100)_^1_$BYTE (IDATAS,SYMTAB(3)(15=15)),(IREF,SYMTAB(3)(15=15)),_^1_#$ (IEQVX,SYMTAB(3)(14=8)),(ITILF,SYMTAB(3)(14=8))_^1_$DIMENSION IDATAS(100),IREF(100),IEQVX(100),ITILF(1€€00)_^1_$BYTE (IPARTR,SYMTAB(3)(7=4)),(INDUCV,SYMTAB(3)(7=7)),(ISFARG,_^1_#$ SYMTAB(3)(6=6)),(IARGNO,SYMTAB(3)(5=0)),(IPARTL,SYMTAB(3)(3=0))_^1_$DIMENSION IPARTR(100),INDUCV(100),ISFARG(100),IARGNO(100),_^1_#$ IPARTL(100)_^1_$EQUIVALENCE (ISYM,SYMTAB(4))_^1_$DIMENSION ISYM(100)_^1C_]_^1C_#SPECIFICATION-TABLE INDEX LABELLED COMMON BLOCK_^1_$COMMON /A/ ISTABX(96)_^1C_]_^1C_#PHASE 4 LA€€BELED COMMON BLOCK._^1_$COMMON /A/ INDTAB(18),INFTB(18)_^1_#2,NBSS ,NADC ,NCON ,NEND ,NPST ,NSTN ,NJMP ,NRTJ ,NLDA_^1_#3,NLDQ ,NSTA ,NSTQ ,NRAO ,NADD ,NSUB ,NAND ,NDVI ,NADQ_^1_#4,NENA ,NINA ,NENQ ,NINQ ,NLRS ,NLLS ,NQRS ,NQLS ,NARS_^1_#5,NALS ,NAJLGZ,NAJEZ ,NAJLZ ,NAJGEZ,NAJLEZ,NAJGZ ,NQJEZ ,NMUI_^1_$COMMON/A/_^1_#1 NFCM ,NFSB ,NFMU ,NFDV ,NFLD ,NFST €€ ,NFAD ,NCAQA_^1_#2,NTCQA ,NTRAQ ,KLDQ ,KSTQ ,NTCAA ,NEOR ,NTCQQ_^1_#3,INFTBL,INFTBN,INFTBX_^1_$DIMENSION KODNAM(18), KFTYPE(6),NLINE(6),NPMTRS(6),KSPTAB(14)_^1_$EQUIVALENCE (INFTB(1),KODNAM(1)),(ISET(11),KSPTAB(1))_^1_$BYTE (KFTYPE,INFTB(3)(15=14)),(NLINE,INFTB(3)(13=13)),_^1_#$ (NPMTRS,INFTB(3)(12=0))_^1C_]_^1C_#PHASE 4 BLANK COMMON BLOCK._^1_$COMMON//JSYM(3),_^1C ***********€€*********************** FTN 3.1 **************************_^1_#1 INBUFF(304),OUTBUF(10),KART(2,3,3),KQ(5),KFCET(5,3),_^1C ********************************** FTN 3.1 ($) **********************_^1_#2 KSUBAT(240),KSFAT(12,2),KLLTB(10,2),LPTYP(10),_^1_#3 INTRAS(304),IMOD(30),NDTYP(30),NBRNS(30),ICBRN(30),_^1_#4 KOP(30),KTRUT(30)_^1_$DIMENSION KFALS(30),KFATH(30),KOMPSW(30),KSBPTR(30)€€,KRESW(30)_^1_$EQUIVALENCE (KFALS(1),ISTAB(1)),(KFATH(1),ISTAB(31)),_^1_#1 (KOMPSW(1),ISTAB(61)),(KSBPTR(1),ISTAB(91)),(KRESW(1),ISTAB(121))_^1_$COMMON// LTYP,MBEGIN_^1_#1,IADDIT,INTRAX,IPTR,ISBSCP,JXX,KBEGIN,KBIAS,KBYTX,KENTER,KENTRY_^1_#2,KEXEC,KEXTYP,KFCSW,KFFSAV,KFINDX,KFLAM,KINTYP,KLLTBX,KNTROL_^1_#3,KOBX,KPRNAM,KQSAV,KRETRN,KSFNAM,KTCATX,LEVEL,LIFTX,LOGIF,KFCETX_^1_$DIMENSION€€ NINVS(30),NINENC(30),NPASS(30)_^1_$EQUIVALENCE (KTRUT(1),NINVS(1)),(KFALS(1),NINENC(1))_^1_#1,(KFATH(1),NPASS(1))_^1_$INTEGER OUTBUF_^1C_]_^1C_]_^1C_#RETURNS EMPTY SYMBOL TABLE ENTRY IN I_^1C_]_^1_$ISYMP=0_^1_$JSYM(1)=IGLAB(1)_^1_$JSYM(2)=IGLAB(2)_^1_$JSYM(3)=IGLAB(3)_^1_$CALL CNVT_^1_$ISYMX=-ISYMX_^1_$CALL SYMBOL_^1C ********************************** FTN 3.1 *******************€€*******_^1_$CALL STOREB_^1C ********************************** FTN 3.1 ($) **********************_^1_$I=ISYMX+ISYMP_^1C_#GENERATE NEXT SYMBOL_^1_$IF(IGLAB(IGLAB1).EQ.IGLAB2)GO TO 1_^1_"3 IGLAB(IGLAB1)=IGLAB(IGLAB1)+1_^1_$RETURN_^1_"1 IF(IGLAB2.GE.8995)GO TO 2_^1_$IGLAB(IGLAB1)=IGLAB2+221_^1_$IGLAB2=IGLAB2+256_^1_$RETURN_^1_"2 IGLAB2=35_^1_$IGLAB1=IGLAB1-1_^1_$GO TO 3_^1_$END_]_^__€PWLBKPC CSY/ 08B P€1_$SUBROUTINE LABKPC(ILX)_^1_#*_2/DECK-ID 08B FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^13_]_^1C LABKPC IS USED IN PHASE B1_^1C_]_^1C_#MASTER LABELED COMMON BLOCK._^1*_] FTN 3.3_^1_$COMMON /A/ IFLAGS,LINECT,LINCT1_^1_$COMMON /A/ IR,IK,IP,IA,IL,IM,IX€€LGO,IOPTO,IOPTV,IOPTC,IOPTD_^1_$COMMON /A/ MCSTRT,MACRNB,MACSEC_^1_$COMMON /A/ IERRS(16),ISRFAD_^1_$COMMON /A/ LGO,ISCRI,ISCRO,IX_^1*_] FTN 3.3_^1_$COMMON /A/ IGLAB(3),IGLAB1,IGLAB2_^1_$COMMON /A/ ICOMT(12),ICOMTS,ICOMX2,ICOMTL,ISUBP,NDPRS,_^1_#$LABX,IBCDTB(48)_^1_$EQUIVALENCE(ICOMB,ICOMT(1)),(ICOMBX,ICOMT(2)),(ICOMDF,_^1_#$ICOMT(3)),(ICOMBN,ICOMT(4))_^1_$DIMENSION ICOMB(6),ICOMBX€€(6),ICOMDF(6),ICOMBN(7)_^1_$COMMON /A/ LOOPTS,LOOPTX,LOOPTB,LOOPT(50)_^1_$EQUIVALENCE(LINDUC,LOOPT(1))_^1_$DIMENSION LINDUC(10)_^1_$EQUIVALENCE (LBEG,LOOPT(2))_^1_$DIMENSION LBEG(10)_^1_$EQUIVALENCE (LINC,LOOPT(3))_^1_$DIMENSION LINC(10)_^1_$EQUIVALENCE (LEND,LOOPT(4))_^1_$DIMENSION LEND(10)_^1_$BYTE(LLABL,LOOPT(5)(14=0)_))_^1_$DIMENSION LLABL(10)_^1_$BYTE(LID,LOOPT(5)(15=15) )_^€€1_$DIMENSION LID(10)_^1_$COMMON /A/ IEQV(255),IEQVS,IEQVN2_^1_$COMMON /A/ ISTAB(150),ISTABS,ISTAB2_^1_$COMMON /A/ IBUFS,ISET(25),LBLANK,KSFCNT,KSNCNT,ISORSC,_^1_#$IHOBIT,ISTNO,ISSFLG,ISUBPN,ITERM,JSORSC,KEQVS_^1C_]_^1C_#SYMBOL TABLE LABELED COMMON BLOCK_^1_$COMMON /A/ ISYMN, ISYMFL,ISYMD,ISYMX,ISYMS,ISYMP,ISYMPC,ISYMPS,_^1_#$ ISYMNS, SYMTAB(960)_^1_$INTEGER SYMTAB_^1_$BYTE (IDUM,SY€€MTAB(1)(15=15)),(KDUMY,SYMTAB(1)(15=15)),_^1_#$(ICLASS,SYMTAB(1)(14=11)),(ITYPE,SYMTAB(1)(10=9))_^1_$DIMENSION IDUM(100),KDUMY(100),ICLASS(100),ITYPE(100)_^1_$BYTE (ISNGL, SYMTAB(1)(8=8)),(KELSIZ,SYMTAB(1)(8=8)),_^1_#$ (ICOM,SYMTAB(1)(7=5)),(IPART,SYMTAB(1)(4=3))_^1_$DIMENSION ISNGL(100),KELSIZ(100),ICOM(100),IPART(100)_^1_$BYTE (KRFCNT,SYMTAB(1)(2=2)),(IDIM,SYMTAB(1)(1=0)),_^1_#$ €€(IREL,SYMTAB(1)(1=1)),(IEXT,SYMTAB(1)(0=0))_^1_$DIMENSION KRFCNT(100),IDIM(100),IREL(100),IEXT(100)_^1_$EQUIVALENCE (IRSA,SYMTAB(2)),(ICOMTX,SYMTAB(2)),(ISNOL,SYMTAB(2))_^1_$DIMENSION IRSA(100), ICOMTX(100),ISNOL(100)_^1_$BYTE (IDATAS,SYMTAB(3)(15=15)),(IREF,SYMTAB(3)(15=15)),_^1_#$ (IEQVX,SYMTAB(3)(14=8)),(ITILF,SYMTAB(3)(14=8))_^1_$DIMENSION IDATAS(100),IREF(100),IEQVX(100),ITILF€€(100)_^1_$BYTE (IPARTR,SYMTAB(3)(7=4)),(INDUCV,SYMTAB(3)(7=7)),(ISFARG,_^1_#$ SYMTAB(3)(6=6)),(IARGNO,SYMTAB(3)(5=0)),(IPARTL,SYMTAB(3)(3=0))_^1_$DIMENSION IPARTR(100),INDUCV(100),ISFARG(100),IARGNO(100),_^1_#$ IPARTL(100)_^1_$EQUIVALENCE (ISYM,SYMTAB(4))_^1_$DIMENSION ISYM(100)_^1C_]_^1C_#SPECIFICATION-TABLE INDEX LABELLED COMMON BLOCK_^1_$COMMON /A/ ISTABX(96)_^1C_]_^1C_#PHASE 4 €€LABELED COMMON BLOCK._^1_$COMMON /A/ INDTAB(18),INFTB(18)_^1_#2,NBSS ,NADC ,NCON ,NEND ,NPST ,NSTN ,NJMP ,NRTJ ,NLDA_^1_#3,NLDQ ,NSTA ,NSTQ ,NRAO ,NADD ,NSUB ,NAND ,NDVI ,NADQ_^1_#4,NENA ,NINA ,NENQ ,NINQ ,NLRS ,NLLS ,NQRS ,NQLS ,NARS_^1_#5,NALS ,NAJLGZ,NAJEZ ,NAJLZ ,NAJGEZ,NAJLEZ,NAJGZ ,NQJEZ ,NMUI_^1_$COMMON/A/_^1_#1 NFCM ,NFSB ,NFMU ,NFDV ,NFLD ,NFS€€T ,NFAD ,NCAQA_^1_#2,NTCQA ,NTRAQ ,KLDQ ,KSTQ ,NTCAA ,NEOR ,NTCQQ_^1_#3,INFTBL,INFTBN,INFTBX_^1_$DIMENSION KODNAM(18), KFTYPE(6),NLINE(6),NPMTRS(6),KSPTAB(14)_^1_$EQUIVALENCE (INFTB(1),KODNAM(1)),(ISET(11),KSPTAB(1))_^1_$BYTE (KFTYPE,INFTB(3)(15=14)),(NLINE,INFTB(3)(13=13)),_^1_#$ (NPMTRS,INFTB(3)(12=0))_^1C_]_^1C_#PHASE 4 BLANK COMMON BLOCK._^1_$COMMON//JSYM(3),_^1C *********€€************************* FTN 3.1 **************************_^1_#1 INBUFF(304),OUTBUF(10),KART(2,3,3),KQ(5),KFCET(5,3),_^1C ********************************** FTN 3.1 ($) **********************_^1_#2 KSUBAT(240),KSFAT(12,2),KLLTB(10,2),LPTYP(10),_^1_#3 INTRAS(304),IMOD(30),NDTYP(30),NBRNS(30),ICBRN(30),_^1_#4 KOP(30),KTRUT(30)_^1_$DIMENSION KFALS(30),KFATH(30),KOMPSW(30),KSBPTR(3€€0),KRESW(30)_^1_$EQUIVALENCE (KFALS(1),ISTAB(1)),(KFATH(1),ISTAB(31)),_^1_#1 (KOMPSW(1),ISTAB(61)),(KSBPTR(1),ISTAB(91)),(KRESW(1),ISTAB(121))_^1_$COMMON// LTYP,MBEGIN_^1_#1,IADDIT,INTRAX,IPTR,ISBSCP,JXX,KBEGIN,KBIAS,KBYTX,KENTER,KENTRY_^1_#2,KEXEC,KEXTYP,KFCSW,KFFSAV,KFINDX,KFLAM,KINTYP,KLLTBX,KNTROL_^1_#3,KOBX,KPRNAM,KQSAV,KRETRN,KSFNAM,KTCATX,LEVEL,LIFTX,LOGIF,KFCETX_^1_$DIMENSI€ÀON NINVS(30),NINENC(30),NPASS(30)_^1_$EQUIVALENCE (KTRUT(1),NINVS(1)),(KFALS(1),NINENC(1))_^1_#1,(KFATH(1),NPASS(1))_^1_$INTEGER OUTBUF_^1C_]_^1_$CALL KPCSTK(INDTAB(1),ILX,0,0,0)_^1_$END_]_^__ÀPWLABLR CSY/ 09B P€1_$SUBROUTINE LABLER(I)_^1_#*_2/DECK-ID 09B FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^13_]_^1C LABLER IS USED IN PHASE B1_^1C_]_^1C_#MASTER LABELED COMMON BLOCK._^1*_] FTN 3.3_^1_$COMMON /A/ IFLAGS,LINECT,LINCT1_^1_$COMMON /A/ IR,IK,IP,IA,IL,IM,IXLG€€O,IOPTO,IOPTV,IOPTC,IOPTD_^1_$COMMON /A/ MCSTRT,MACRNB,MACSEC_^1_$COMMON /A/ IERRS(16),ISRFAD_^1_$COMMON /A/ LGO,ISCRI,ISCRO,IX_^1*_] FTN 3.3_^1_$COMMON /A/ IGLAB(3),IGLAB1,IGLAB2_^1_$COMMON /A/ ICOMT(12),ICOMTS,ICOMX2,ICOMTL,ISUBP,NDPRS,_^1_#$LABX,IBCDTB(48)_^1_$EQUIVALENCE(ICOMB,ICOMT(1)),(ICOMBX,ICOMT(2)),(ICOMDF,_^1_#$ICOMT(3)),(ICOMBN,ICOMT(4))_^1_$DIMENSION ICOMB(6),ICOMBX(6€€),ICOMDF(6),ICOMBN(7)_^1_$COMMON /A/ LOOPTS,LOOPTX,LOOPTB,LOOPT(50)_^1_$EQUIVALENCE(LINDUC,LOOPT(1))_^1_$DIMENSION LINDUC(10)_^1_$EQUIVALENCE (LBEG,LOOPT(2))_^1_$DIMENSION LBEG(10)_^1_$EQUIVALENCE (LINC,LOOPT(3))_^1_$DIMENSION LINC(10)_^1_$EQUIVALENCE (LEND,LOOPT(4))_^1_$DIMENSION LEND(10)_^1_$BYTE(LLABL,LOOPT(5)(14=0)_))_^1_$DIMENSION LLABL(10)_^1_$BYTE(LID,LOOPT(5)(15=15) )_^1_€€$DIMENSION LID(10)_^1_$COMMON /A/ IEQV(255),IEQVS,IEQVN2_^1_$COMMON /A/ ISTAB(150),ISTABS,ISTAB2_^1_$COMMON /A/ IBUFS,ISET(25),LBLANK,KSFCNT,KSNCNT,ISORSC,_^1_#$IHOBIT,ISTNO,ISSFLG,ISUBPN,ITERM,JSORSC,KEQVS_^1C_]_^1C_#SYMBOL TABLE LABELED COMMON BLOCK_^1_$COMMON /A/ ISYMN, ISYMFL,ISYMD,ISYMX,ISYMS,ISYMP,ISYMPC,ISYMPS,_^1_#$ ISYMNS, SYMTAB(960)_^1_$INTEGER SYMTAB_^1_$BYTE (IDUM,SYMT€€AB(1)(15=15)),(KDUMY,SYMTAB(1)(15=15)),_^1_#$(ICLASS,SYMTAB(1)(14=11)),(ITYPE,SYMTAB(1)(10=9))_^1_$DIMENSION IDUM(100),KDUMY(100),ICLASS(100),ITYPE(100)_^1_$BYTE (ISNGL, SYMTAB(1)(8=8)),(KELSIZ,SYMTAB(1)(8=8)),_^1_#$ (ICOM,SYMTAB(1)(7=5)),(IPART,SYMTAB(1)(4=3))_^1_$DIMENSION ISNGL(100),KELSIZ(100),ICOM(100),IPART(100)_^1_$BYTE (KRFCNT,SYMTAB(1)(2=2)),(IDIM,SYMTAB(1)(1=0)),_^1_#$ (I€€REL,SYMTAB(1)(1=1)),(IEXT,SYMTAB(1)(0=0))_^1_$DIMENSION KRFCNT(100),IDIM(100),IREL(100),IEXT(100)_^1_$EQUIVALENCE (IRSA,SYMTAB(2)),(ICOMTX,SYMTAB(2)),(ISNOL,SYMTAB(2))_^1_$DIMENSION IRSA(100), ICOMTX(100),ISNOL(100)_^1_$BYTE (IDATAS,SYMTAB(3)(15=15)),(IREF,SYMTAB(3)(15=15)),_^1_#$ (IEQVX,SYMTAB(3)(14=8)),(ITILF,SYMTAB(3)(14=8))_^1_$DIMENSION IDATAS(100),IREF(100),IEQVX(100),ITILF(1€€00)_^1_$BYTE (IPARTR,SYMTAB(3)(7=4)),(INDUCV,SYMTAB(3)(7=7)),(ISFARG,_^1_#$ SYMTAB(3)(6=6)),(IARGNO,SYMTAB(3)(5=0)),(IPARTL,SYMTAB(3)(3=0))_^1_$DIMENSION IPARTR(100),INDUCV(100),ISFARG(100),IARGNO(100),_^1_#$ IPARTL(100)_^1_$EQUIVALENCE (ISYM,SYMTAB(4))_^1_$DIMENSION ISYM(100)_^1C_]_^1C_#SPECIFICATION-TABLE INDEX LABELLED COMMON BLOCK_^1_$COMMON /A/ ISTABX(96)_^1C_]_^1_$CALL KSYMGN€&(I)_^1_$ICLASS(ISYMX)=7_^1_$END_]_^__ &PWPUNT2 CSY/ 10B P€1_$SUBROUTINE PUNT_^1_#*_2/DECK-ID 10B FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^13_]_^1C PUNT IS USED IN PHASE B1_^1C NON-IDENTICAL PUNT IS USED IN PHASE A3_^1C_#MASTER LABELED COMMON BLOCK._^1*_] FTN 3.3_^1_$COMMON /A/ IFLAGS,LINECT,LINCT1_^1_$COM€€MON /A/ IR,IK,IP,IA,IL,IM,IXLGO,IOPTO,IOPTV,IOPTC,IOPTD_^1_$COMMON /A/ MCSTRT,MACRNB,MACSEC_^1_$COMMON /A/ IERRS(16),ISRFAD_^1_$COMMON /A/ LGO,ISCRI,ISCRO,IX_^1*_] FTN 3.3_^1_$COMMON /A/ IGLAB(3),IGLAB1,IGLAB2_^1_$COMMON /A/ ICOMT(12),ICOMTS,ICOMX2,ICOMTL,ISUBP,NDPRS,_^1_#$LABX,IBCDTB(48)_^1_$EQUIVALENCE(ICOMB,ICOMT(1)),(ICOMBX,ICOMT(2)),(ICOMDF,_^1_#$ICOMT(3)),(ICOMBN,ICOMT(4))_^€€1_$DIMENSION ICOMB(6),ICOMBX(6),ICOMDF(6),ICOMBN(7)_^1_$COMMON /A/ LOOPTS,LOOPTX,LOOPTB,LOOPT(50)_^1_$EQUIVALENCE(LINDUC,LOOPT(1))_^1_$DIMENSION LINDUC(10)_^1_$EQUIVALENCE (LBEG,LOOPT(2))_^1_$DIMENSION LBEG(10)_^1_$EQUIVALENCE (LINC,LOOPT(3))_^1_$DIMENSION LINC(10)_^1_$EQUIVALENCE (LEND,LOOPT(4))_^1_$DIMENSION LEND(10)_^1_$BYTE(LLABL,LOOPT(5)(14=0)_))_^1_$DIMENSION LLABL(10)_^1_$B€€YTE(LID,LOOPT(5)(15=15) )_^1_$DIMENSION LID(10)_^1_$COMMON /A/ IEQV(255),IEQVS,IEQVN2_^1_$COMMON /A/ ISTAB(150),ISTABS,ISTAB2_^1_$COMMON /A/ IBUFS,ISET(25),LBLANK,KSFCNT,KSNCNT,ISORSC,_^1_#$IHOBIT,ISTNO,ISSFLG,ISUBPN,ITERM,JSORSC,KEQVS_^1C_]_^1C_]_^1C_#SYMBOL TABLE LABELED COMMON BLOCK_^1_$COMMON /A/ ISYMN, ISYMFL,ISYMD,ISYMX,ISYMS,ISYMP,ISYMPC,ISYMPS,_^1_#$ ISYMNS, SYMTAB(960)_^1€€_$INTEGER SYMTAB_^1_$BYTE (IDUM,SYMTAB(1)(15=15)),(KDUMY,SYMTAB(1)(15=15)),_^1_#$(ICLASS,SYMTAB(1)(14=11)),(ITYPE,SYMTAB(1)(10=9))_^1_$DIMENSION IDUM(100),KDUMY(100),ICLASS(100),ITYPE(100)_^1_$BYTE (ISNGL, SYMTAB(1)(8=8)),(KELSIZ,SYMTAB(1)(8=8)),_^1_#$ (ICOM,SYMTAB(1)(7=5)),(IPART,SYMTAB(1)(4=3))_^1_$DIMENSION ISNGL(100),KELSIZ(100),ICOM(100),IPART(100)_^1_$BYTE (KRFCNT,SYMTAB(1)(2€€=2)),(IDIM,SYMTAB(1)(1=0)),_^1_#$ (IREL,SYMTAB(1)(1=1)),(IEXT,SYMTAB(1)(0=0))_^1_$DIMENSION KRFCNT(100),IDIM(100),IREL(100),IEXT(100)_^1_$EQUIVALENCE (IRSA,SYMTAB(2)),(ICOMTX,SYMTAB(2)),(ISNOL,SYMTAB(2))_^1_$DIMENSION IRSA(100), ICOMTX(100),ISNOL(100)_^1_$BYTE (IDATAS,SYMTAB(3)(15=15)),(IREF,SYMTAB(3)(15=15)),_^1_#$ (IEQVX,SYMTAB(3)(14=8)),(ITILF,SYMTAB(3)(14=8))_^1_$DIMENSION IDAT€€AS(100),IREF(100),IEQVX(100),ITILF(100)_^1_$BYTE (IPARTR,SYMTAB(3)(7=4)),(INDUCV,SYMTAB(3)(7=7)),(ISFARG,_^1_#$ SYMTAB(3)(6=6)),(IARGNO,SYMTAB(3)(5=0)),(IPARTL,SYMTAB(3)(3=0))_^1_$DIMENSION IPARTR(100),INDUCV(100),ISFARG(100),IARGNO(100),_^1_#$ IPARTL(100)_^1_$EQUIVALENCE (ISYM,SYMTAB(4))_^1_$DIMENSION ISYM(100)_^1C_]_^1C_#SPECIFICATION-TABLE INDEX LABELLED COMMON BLOCK_^1_$COMMON €8/A/ ISTABX(96)_^1C***********************************************************_#83*2398_^1_$DIMENSION MSG(11)_^1_$DATA MSG/'*F,100',8*' '/_^1_$CALL CONV (ISTNO,MSG(6))_^1_$CALL WRITE (3,1,11,MSG(1))_^1C***********************************************************_#83*2398_^1_$IXLGO=0_^1_$CALL SKIPIT_^1_$END_]_^__8PWSMBL2 CSY/ 11B P€1_$SUBROUTINE SYMBOL_^1_#*_2/DECK-ID 11B FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^13_]_^1C SYMBOL IS USED IN PHASE B1_^1C NON-IDENTICAL SYMBOL IS USED IN PHASE A ROOT_^1C_#MASTER LABELED COMMON BLOCK._^1*_] FTN 3.3_^1_$COMMON /A/ IFLAGS,LINECT,LINC€€T1_^1_$COMMON /A/ IR,IK,IP,IA,IL,IM,IXLGO,IOPTO,IOPTV,IOPTC,IOPTD_^1_$COMMON /A/ MCSTRT,MACRNB,MACSEC_^1_$COMMON /A/ IERRS(16),ISRFAD_^1_$COMMON /A/ LGO,ISCRI,ISCRO,IX_^1*_] FTN 3.3_^1_$COMMON /A/ IGLAB(3),IGLAB1,IGLAB2_^1_$COMMON /A/ ICOMT(12),ICOMTS,ICOMX2,ICOMTL,ISUBP,NDPRS,_^1_#$LABX,IBCDTB(48)_^1_$EQUIVALENCE(ICOMB,ICOMT(1)),(ICOMBX,ICOMT(2)),(ICOMDF,_^1_#$ICOMT(3)),(ICOMBN,I€€COMT(4))_^1_$DIMENSION ICOMB(6),ICOMBX(6),ICOMDF(6),ICOMBN(7)_^1_$COMMON /A/ LOOPTS,LOOPTX,LOOPTB,LOOPT(50)_^1_$EQUIVALENCE(LINDUC,LOOPT(1))_^1_$DIMENSION LINDUC(10)_^1_$EQUIVALENCE (LBEG,LOOPT(2))_^1_$DIMENSION LBEG(10)_^1_$EQUIVALENCE (LINC,LOOPT(3))_^1_$DIMENSION LINC(10)_^1_$EQUIVALENCE (LEND,LOOPT(4))_^1_$DIMENSION LEND(10)_^1_$BYTE(LLABL,LOOPT(5)(14=0)_))_^1_$DIMENSION LLABL€€(10)_^1_$BYTE(LID,LOOPT(5)(15=15) )_^1_$DIMENSION LID(10)_^1_$COMMON /A/ IEQV(255),IEQVS,IEQVN2_^1_$COMMON /A/ ISTAB(150),ISTABS,ISTAB2_^1_$COMMON /A/ IBUFS,ISET(25),LBLANK,KSFCNT,KSNCNT,ISORSC,_^1_#$IHOBIT,ISTNO,ISSFLG,ISUBPN,ITERM,JSORSC,KEQVS_^1C_]_^1C_#SYMBOL TABLE LABELED COMMON BLOCK_^1_$COMMON /A/ ISYMN, ISYMFL,ISYMD,ISYMX,ISYMS,ISYMP,ISYMPC,ISYMPS,_^1_#$ ISYMNS, SYMTAB(960€€)_^1_$INTEGER SYMTAB_^1_$BYTE (IDUM,SYMTAB(1)(15=15)),(KDUMY,SYMTAB(1)(15=15)),_^1_#$(ICLASS,SYMTAB(1)(14=11)),(ITYPE,SYMTAB(1)(10=9))_^1_$DIMENSION IDUM(100),KDUMY(100),ICLASS(100),ITYPE(100)_^1_$BYTE (ISNGL, SYMTAB(1)(8=8)),(KELSIZ,SYMTAB(1)(8=8)),_^1_#$ (ICOM,SYMTAB(1)(7=5)),(IPART,SYMTAB(1)(4=3))_^1_$DIMENSION ISNGL(100),KELSIZ(100),ICOM(100),IPART(100)_^1_$BYTE (KRFCNT,SYMTAB(€€1)(2=2)),(IDIM,SYMTAB(1)(1=0)),_^1_#$ (IREL,SYMTAB(1)(1=1)),(IEXT,SYMTAB(1)(0=0))_^1_$DIMENSION KRFCNT(100),IDIM(100),IREL(100),IEXT(100)_^1_$EQUIVALENCE (IRSA,SYMTAB(2)),(ICOMTX,SYMTAB(2)),(ISNOL,SYMTAB(2))_^1_$DIMENSION IRSA(100), ICOMTX(100),ISNOL(100)_^1_$BYTE (IDATAS,SYMTAB(3)(15=15)),(IREF,SYMTAB(3)(15=15)),_^1_#$ (IEQVX,SYMTAB(3)(14=8)),(ITILF,SYMTAB(3)(14=8))_^1_$DIMENSION €€IDATAS(100),IREF(100),IEQVX(100),ITILF(100)_^1_$BYTE (IPARTR,SYMTAB(3)(7=4)),(INDUCV,SYMTAB(3)(7=7)),(ISFARG,_^1_#$ SYMTAB(3)(6=6)),(IARGNO,SYMTAB(3)(5=0)),(IPARTL,SYMTAB(3)(3=0))_^1_$DIMENSION IPARTR(100),INDUCV(100),ISFARG(100),IARGNO(100),_^1_#$ IPARTL(100)_^1_$EQUIVALENCE (ISYM,SYMTAB(4))_^1_$DIMENSION ISYM(100)_^1C_]_^1C_#SPECIFICATION-TABLE INDEX LABELLED COMMON BLOCK_^1_$COM€€MON /A/ ISTABX(96)_^1C_]_^1C_#PHASE B BLANK COMMON BLOCK._^1_$COMMON//JSYM(3)_^1C_#MESSAGE ' *F,58'...'SYMBOL TABLE OVERFLOW.'_^1_$DIMENSION MSG(3)_^1_$DATA MSG(1),MSG(2),MSG(3)/$202A,$462C,$3538/_^1_$IF (ISYMX .GE. 0) GO TO 5_^1_$ISYMX=ISYMN_^1_$CALL GETSYM_^1_$GO TO 50_^1_"5 I=0_]_^1_$ISYMX=1_^1_$ISYMD=1_^1_$ASSIGN 14 TO JUMP_^1_!10 CALL GETSYM_^1_$GO TO JUMP_^1C *** JUMP IF HAV€€E REACHED END OF SYMTAB ENTRIES._^1_!14 IF (ISYMN .EQ. ISYMX+ISYMP) GO TO 40_^1C *** COMPARE 'JSYM' TO CURRENT SYMTAB ENTRY._^1C THE NEST TWO STATEMENTS RELATE TO THE COMPILER BEING ABLE TO_^1C_!DISTINGUISH BETWEEN +0 AND -0 (RELATED TO PSR 299)_^1_$ASSEM $E400,+ISYMX,$0DFE,$C400,+JSYM(1),$B600,+ISYM,$0102,$1400,_^1_#* +30,$0D01,$C400,+JSYM(2),$BEF8,$0101,$1CF9_^1C *** 'JSYM' = '€€ISYM(ISYMX)'. PERHAPS?_^1_$IF (JSYM(3) .EQ. 0) GO TO 28_^1_$IF (ITYPE(ISYMX) .EQ. 1 .AND. JSYM(3) .EQ. $2424 .OR._^1_#$ ITYPE(ISYMX) .EQ. 2 .AND. JSYM(3) .EQ. $2525) GO TO 29_^1_$GO TO 30_^1_!28 IF (ICLASS(ISYMX) .EQ. 2) GO TO 30_^1C_#'JSYM' = 'ISYM(ISYMX)'. RETURN UNLESS PROCESSING STATEMENT_^1C_$FUNCTION DUMMY ARGUMENTS._^1_!29 IF (ISSFLG .EQ. 0) RETURN_^1_$I=ISYMP+ISYMX_^1C€€ *** GET NEXT SYMBOL IN SYMTAB._^1_!30 ISYMX=ISYMP+ISYMX+ISYMFL_^1_$GO TO 10_^1C *** AT CURRENT END OF SYMTAB. JUMP IF DID NOT FIND A MATCH._^1_!40 IF (I .EQ. 0) GO TO 50_^1C *** SET 'ISYMX' TO MATCHING SYMBOL, GET THAT PAGE IN, RETURN._^1_$ISYMX=I_^1_$ASSIGN 42 TO JUMP_^1_$GO TO 10_^1_!42 RETURN_^1C *** AT CURRENT END OF SYMTAB AND NO MATCH. (IF AT ABSOLUTE END OF_^1C *** SYMTA€B, ERROR 58 AND 'SKIPIT'.) CLEAR NEXT SYMBOL LOC'N AND RTN._^1_!50 IF (ISYMP+ISYMX+ISYMFL .LE. ISYMS) GO TO 60_^1_$CALL WRITE (3,1,3,MSG(1))_^1_$IXLGO=0_^1_$CALL SKIPIT_^1_!60 ISYMD=0_^1_$J=ISYMX+ISYMFL-1_^1_$DO 70 I=ISYMX,J_^1_!70 SYMTAB(I)=0_^1_$END_]_^__PWTSLOC CSY/ 12B P€1_$SUBROUTINE TSALOC(KCELL,N)_^1_#*_2/DECK-ID 12B FORTRAN 3.3B_)SUMMARY-102_^1*_#ROUTINE TO ALLOCATE OR RELEASE TEMPORARY STORAGE CELLS_^1*_#1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_#SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^13_]_^1*_#USED IN PHASE B1_^1._]_^1C_#MASTER LABELED COMMON BLOCK._^1*_] FTN 3.3_^1_$COMMON /A/ I€€FLAGS,LINECT,LINCT1_^1_$COMMON /A/ IR,IK,IP,IA,IL,IM,IXLGO,IOPTO,IOPTV,IOPTC,IOPTD_^1_$COMMON /A/ MCSTRT,MACRNB,MACSEC_^1_$COMMON /A/ IERRS(16),ISRFAD_^1_$COMMON /A/ LGO,ISCRI,ISCRO,IX_^1*_] FTN 3.3_^1_$COMMON /A/ IGLAB(3),IGLAB1,IGLAB2_^1_$COMMON /A/ ICOMT(12),ICOMTS,ICOMX2,ICOMTL,ISUBP,NDPRS,_^1_#$LABX,IBCDTB(48)_^1_$EQUIVALENCE(ICOMB,ICOMT(1)),(ICOMBX,ICOMT(2)),(ICOMDF,_^1_#$IC€€OMT(3)),(ICOMBN,ICOMT(4))_^1_$DIMENSION ICOMB(6),ICOMBX(6),ICOMDF(6),ICOMBN(7)_^1_$COMMON /A/ LOOPTS,LOOPTX,LOOPTB,LOOPT(50)_^1_$EQUIVALENCE(LINDUC,LOOPT(1))_^1_$DIMENSION LINDUC(10)_^1_$EQUIVALENCE (LBEG,LOOPT(2))_^1_$DIMENSION LBEG(10)_^1_$EQUIVALENCE (LINC,LOOPT(3))_^1_$DIMENSION LINC(10)_^1_$EQUIVALENCE (LEND,LOOPT(4))_^1_$DIMENSION LEND(10)_^1_$BYTE(LLABL,LOOPT(5)(14=0)_))_^1_€€$DIMENSION LLABL(10)_^1_$BYTE(LID,LOOPT(5)(15=15) )_^1_$DIMENSION LID(10)_^1_$COMMON /A/ IEQV(255),IEQVS,IEQVN2_^1_$COMMON /A/ ISTAB(150),ISTABS,ISTAB2_^1_$COMMON /A/ IBUFS,ISET(25),LBLANK,KSFCNT,KSNCNT,ISORSC,_^1_#$IHOBIT,ISTNO,ISSFLG,ISUBPN,ITERM,JSORSC,KEQVS_^1C_]_^1C_#SYMBOL TABLE LABELED COMMON BLOCK_^1_$COMMON /A/ ISYMN, ISYMFL,ISYMD,ISYMX,ISYMS,ISYMP,ISYMPC,ISYMPS,_^1_#$ I€€SYMNS, SYMTAB(960)_^1_$INTEGER SYMTAB_^1_$BYTE (IDUM,SYMTAB(1)(15=15)),(KDUMY,SYMTAB(1)(15=15)),_^1_#$(ICLASS,SYMTAB(1)(14=11)),(ITYPE,SYMTAB(1)(10=9))_^1_$DIMENSION IDUM(100),KDUMY(100),ICLASS(100),ITYPE(100)_^1_$BYTE (ISNGL, SYMTAB(1)(8=8)),(KELSIZ,SYMTAB(1)(8=8)),_^1_#$ (ICOM,SYMTAB(1)(7=5)),(IPART,SYMTAB(1)(4=3))_^1_$DIMENSION ISNGL(100),KELSIZ(100),ICOM(100),IPART(100)_^1_$BYT€€E (KRFCNT,SYMTAB(1)(2=2)),(IDIM,SYMTAB(1)(1=0)),_^1_#$ (IREL,SYMTAB(1)(1=1)),(IEXT,SYMTAB(1)(0=0))_^1_$DIMENSION KRFCNT(100),IDIM(100),IREL(100),IEXT(100)_^1_$EQUIVALENCE (IRSA,SYMTAB(2)),(ICOMTX,SYMTAB(2)),(ISNOL,SYMTAB(2))_^1_$DIMENSION IRSA(100), ICOMTX(100),ISNOL(100)_^1_$BYTE (IDATAS,SYMTAB(3)(15=15)),(IREF,SYMTAB(3)(15=15)),_^1_#$ (IEQVX,SYMTAB(3)(14=8)),(ITILF,SYMTAB(3)(14=8€€))_^1_$DIMENSION IDATAS(100),IREF(100),IEQVX(100),ITILF(100)_^1_$BYTE (IPARTR,SYMTAB(3)(7=4)),(INDUCV,SYMTAB(3)(7=7)),(ISFARG,_^1_#$ SYMTAB(3)(6=6)),(IARGNO,SYMTAB(3)(5=0)),(IPARTL,SYMTAB(3)(3=0))_^1_$DIMENSION IPARTR(100),INDUCV(100),ISFARG(100),IARGNO(100),_^1_#$ IPARTL(100)_^1_$EQUIVALENCE (ISYM,SYMTAB(4))_^1_$DIMENSION ISYM(100)_^1._]_^1C_#SPECIFICATION-TABLE INDEX LABELLED COM€€MON BLOCK_^1_$COMMON /A/ ISTABX(96)_^1C_]_^1C_#PHASE 4 LABELED COMMON BLOCK._^1_$COMMON /A/ INDTAB(18),INFTB(18)_^1_#2,NBSS ,NADC ,NCON ,NEND ,NPST ,NSTN ,NJMP ,NRTJ ,NLDA_^1_#3,NLDQ ,NSTA ,NSTQ ,NRAO ,NADD ,NSUB ,NAND ,NDVI ,NADQ_^1_#4,NENA ,NINA ,NENQ ,NINQ ,NLRS ,NLLS ,NQRS ,NQLS ,NARS_^1_#5,NALS ,NAJLGZ,NAJEZ ,NAJLZ ,NAJGEZ,NAJLEZ,NAJGZ ,NQJEZ ,NMUI_^1_€€$COMMON/A/_^1_#1 NFCM ,NFSB ,NFMU ,NFDV ,NFLD ,NFST ,NFAD ,NCAQA_^1_#2,NTCQA ,NTRAQ ,KLDQ ,KSTQ ,NTCAA ,NEOR ,NTCQQ_^1_#3,INFTBL,INFTBN,INFTBX_^1_$DIMENSION KODNAM(18), KFTYPE(6),NLINE(6),NPMTRS(6),KSPTAB(14)_^1_$EQUIVALENCE (INFTB(1),KODNAM(1)),(ISET(11),KSPTAB(1))_^1_$BYTE (KFTYPE,INFTB(3)(15=14)),(NLINE,INFTB(3)(13=13)),_^1_#$ (NPMTRS,INFTB(3)(12=0))_^13_]_^1C_#PHASE 4€€ BLANK COMMON BLOCK._^1_$COMMON//JSYM(3),_^1C ********************************** FTN 3.1 **************************_^1_#1 INBUFF(304),OUTBUF(10),KART(2,3,3),KQ(5),KFCET(5,3),_^1C ********************************** FTN 3.1 ($) **********************_^1_#2 KSUBAT(240),KSFAT(12,2),KLLTB(10,2),LPTYP(10),_^1_#3 INTRAS(304),IMOD(30),NDTYP(30),NBRNS(30),ICBRN(30),_^1_#4 KOP(30),KTRUT(30€€)_^1_$DIMENSION KFALS(30),KFATH(30),KOMPSW(30),KSBPTR(30),KRESW(30)_^1_$EQUIVALENCE (KFALS(1),ISTAB(1)),(KFATH(1),ISTAB(31)),_^1_#1 (KOMPSW(1),ISTAB(61)),(KSBPTR(1),ISTAB(91)),(KRESW(1),ISTAB(121))_^1_$COMMON// LTYP,MBEGIN_^1_#1,IADDIT,INTRAX,IPTR,ISBSCP,JXX,KBEGIN,KBIAS,KBYTX,KENTER,KENTRY_^1_#2,KEXEC,KEXTYP,KFCSW,KFFSAV,KFINDX,KFLAM,KINTYP,KLLTBX,KNTROL_^1_#3,KOBX,KPRNAM,KQSAV,KR€€ETRN,KSFNAM,KTCATX,LEVEL,LIFTX,LOGIF,KFCETX_^1_$DIMENSION NINVS(30),NINENC(30),NPASS(30)_^1_$EQUIVALENCE (KTRUT(1),NINVS(1)),(KFALS(1),NINENC(1))_^1_#1,(KFATH(1),NPASS(1))_^1_$INTEGER OUTBUF_^1*_YBEGIN FTN 3.3_^1_$DIMENSION KTCAT(40,2)_^1*_[END FTN 3.3_^1._]_^1C_'SET INDEX TO 0._^1_$I=0_]_^1C_]_^1C_'IS N = 4_^1_$IF(N.EQ.4) GO TO 1_^1C_]_^1C_'NO, THIS IS A REQUEST FOR ASSIGNMENT._^1€€C_'SEE IF INDEX HAS REACHED TABLE LENGTH._^1_"3 IF(I.EQ.KTCATX) GO TO 2_^1C_]_^1C_'NO, INCREMENT INDEX_^1_$I=I+1_^1C_'SEE IF THIS TEMPORARY CELL IS_^1C_'AVAILABLE AND THE CORRECT TYPE._^1C ********************************** FTN 3.1 **************************_^1_$IF (KTCAT(I,2).NE.(N+2)) GO TO 3_^1C ********************************** FTN 3.1 ($) **********************_^1C_]_^1C_'€€YES, SET AVAILABILITY INDICATOR_^1C_'TO UNAVAILABLE._^1_"4 KTCAT(I,2)=N-1_^1C_]_^1C_'SET RETURN PARAMETER TO_^1C_'PTR OF NEW ASSIGNED TS._^1_$KCELL=KTCAT(I,1)_^1C_'EXIT_^1_$GO TO 5_^1C_]_^1C_'N = 3, THIS IS A REQUEST FOR_^1C_'RELEASE. INCREMENT INDEX._^1C_]_^1_"1 I=I+1_^1C_'SEE IF THIS ENTRY CONTAINS THE_^1C_'TEMPORARY CELL TO BE RELEASED._^1_$IF(KTCAT(I,1).NE.KCELL) GO TO 1_^1C_]€€_^1C_'YES, CHANGE AVAILABILITY INDI-_^1C_'CATOR TO AVAILABLE_^1C ********************************** FTN 3.1 **************************_^1_$KTCAT(I,2) = KTCAT(I,2) + 3_^1C ********************************** FTN 3.1 ($) **********************_^1C_'EXIT_^1_"5 RETURN_^1C_]_^1C_'NO AVAILABLE TS CELL FOUND._^1C_'INCREMENT TO NEXT AVAILABLE ENTRY_^1_"2 KTCATX=KTCATX+1_^1*_YBEGIN FTN 3.3€€_^1_$IF(KTCATX.GT.40) CALL PUNT_^1*_[END FTN 3.3_^1C_]_^1C_'GENERATE NEW SYMBOL TABLE ENTRY_^1_$CALL KSYMGN(KTCAT(KTCATX,1))_^1C_]_^1C_'AS PER TEMPORARY CELL_^1_$ITYPE(ISYMX)=N_^1_$KELSIZ(ISYMX)=N-1_^1C ********************************** FTN 3.1 **************************_^1_$IF (N.EQ.3) KELSIZ(ISYMX) = 1_^1C ********************************** FTN 3.1 ($) **********************_€8^1_$ICLASS(ISYMX)=1_^1_$I=I+1_^1_$GO TO 4_^1_$END_]_^__ 8PWASSEM CSY/ 13B P€1_$SUBROUTINE ASSEM_^1_#*_2/DECK-ID 13B FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^13_]_^1C ASSEM IS USED IN PHASE B1_^1C_]_^1C_#MASTER LABELED COMMON BLOCK._^1*_] FTN 3.3_^1_$COMMON /A/ IFLAGS,LINECT,LINCT1_^1_$COMMON /A/ IR,IK,IP,IA,IL,IM,IXLGO,IOP€€TO,IOPTV,IOPTC,IOPTD_^1_$COMMON /A/ MCSTRT,MACRNB,MACSEC_^1_$COMMON /A/ IERRS(16),ISRFAD_^1_$COMMON /A/ LGO,ISCRI,ISCRO,IX_^1*_] FTN 3.3_^1_$COMMON /A/ IGLAB(3),IGLAB1,IGLAB2_^1_$COMMON /A/ ICOMT(12),ICOMTS,ICOMX2,ICOMTL,ISUBP,NDPRS,_^1_#$LABX,IBCDTB(48)_^1_$EQUIVALENCE(ICOMB,ICOMT(1)),(ICOMBX,ICOMT(2)),(ICOMDF,_^1_#$ICOMT(3)),(ICOMBN,ICOMT(4))_^1_$DIMENSION ICOMB(6),ICOMBX(6),ICO€€MDF(6),ICOMBN(7)_^1_$COMMON /A/ LOOPTS,LOOPTX,LOOPTB,LOOPT(50)_^1_$EQUIVALENCE(LINDUC,LOOPT(1))_^1_$DIMENSION LINDUC(10)_^1_$EQUIVALENCE (LBEG,LOOPT(2))_^1_$DIMENSION LBEG(10)_^1_$EQUIVALENCE (LINC,LOOPT(3))_^1_$DIMENSION LINC(10)_^1_$EQUIVALENCE (LEND,LOOPT(4))_^1_$DIMENSION LEND(10)_^1_$BYTE(LLABL,LOOPT(5)(14=0)_))_^1_$DIMENSION LLABL(10)_^1_$BYTE(LID,LOOPT(5)(15=15) )_^1_$DIME€€NSION LID(10)_^1_$COMMON /A/ IEQV(255),IEQVS,IEQVN2_^1_$COMMON /A/ ISTAB(150),ISTABS,ISTAB2_^1_$COMMON /A/ IBUFS,ISET(25),LBLANK,KSFCNT,KSNCNT,ISORSC,_^1_#$IHOBIT,ISTNO,ISSFLG,ISUBPN,ITERM,JSORSC,KEQVS_^1C_]_^1C_#SYMBOL TABLE LABELED COMMON BLOCK_^1_$COMMON /A/ ISYMN, ISYMFL,ISYMD,ISYMX,ISYMS,ISYMP,ISYMPC,ISYMPS,_^1_#$ ISYMNS, SYMTAB(960)_^1_$INTEGER SYMTAB_^1_$BYTE (IDUM,SYMTAB(1)€€(15=15)),(KDUMY,SYMTAB(1)(15=15)),_^1_#$(ICLASS,SYMTAB(1)(14=11)),(ITYPE,SYMTAB(1)(10=9))_^1_$DIMENSION IDUM(100),KDUMY(100),ICLASS(100),ITYPE(100)_^1_$BYTE (ISNGL, SYMTAB(1)(8=8)),(KELSIZ,SYMTAB(1)(8=8)),_^1_#$ (ICOM,SYMTAB(1)(7=5)),(IPART,SYMTAB(1)(4=3))_^1_$DIMENSION ISNGL(100),KELSIZ(100),ICOM(100),IPART(100)_^1_$BYTE (KRFCNT,SYMTAB(1)(2=2)),(IDIM,SYMTAB(1)(1=0)),_^1_#$ (IREL,S€€YMTAB(1)(1=1)),(IEXT,SYMTAB(1)(0=0))_^1_$DIMENSION KRFCNT(100),IDIM(100),IREL(100),IEXT(100)_^1_$EQUIVALENCE (IRSA,SYMTAB(2)),(ICOMTX,SYMTAB(2)),(ISNOL,SYMTAB(2))_^1_$DIMENSION IRSA(100), ICOMTX(100),ISNOL(100)_^1_$BYTE (IDATAS,SYMTAB(3)(15=15)),(IREF,SYMTAB(3)(15=15)),_^1_#$ (IEQVX,SYMTAB(3)(14=8)),(ITILF,SYMTAB(3)(14=8))_^1_$DIMENSION IDATAS(100),IREF(100),IEQVX(100),ITILF(100)_^€€1_$BYTE (IPARTR,SYMTAB(3)(7=4)),(INDUCV,SYMTAB(3)(7=7)),(ISFARG,_^1_#$ SYMTAB(3)(6=6)),(IARGNO,SYMTAB(3)(5=0)),(IPARTL,SYMTAB(3)(3=0))_^1_$DIMENSION IPARTR(100),INDUCV(100),ISFARG(100),IARGNO(100),_^1_#$ IPARTL(100)_^1_$EQUIVALENCE (ISYM,SYMTAB(4))_^1_$DIMENSION ISYM(100)_^1C_]_^1C_#SPECIFICATION-TABLE INDEX LABELLED COMMON BLOCK_^1_$COMMON /A/ ISTABX(96)_^1C_]_^1C_#PHASE 4 LABELED€€ COMMON BLOCK._^1_$COMMON /A/ INDTAB(18),INFTB(18)_^1_#2,NBSS ,NADC ,NCON ,NEND ,NPST ,NSTN ,NJMP ,NRTJ ,NLDA_^1_#3,NLDQ ,NSTA ,NSTQ ,NRAO ,NADD ,NSUB ,NAND ,NDVI ,NADQ_^1_#4,NENA ,NINA ,NENQ ,NINQ ,NLRS ,NLLS ,NQRS ,NQLS ,NARS_^1_#5,NALS ,NAJLGZ,NAJEZ ,NAJLZ ,NAJGEZ,NAJLEZ,NAJGZ ,NQJEZ ,NMUI_^1_$COMMON/A/_^1_#1 NFCM ,NFSB ,NFMU ,NFDV ,NFLD ,NFST ,NFA€€D ,NCAQA_^1_#2,NTCQA ,NTRAQ ,KLDQ ,KSTQ ,NTCAA ,NEOR ,NTCQQ_^1_#3,INFTBL,INFTBN,INFTBX_^1_$DIMENSION KODNAM(18), KFTYPE(6),NLINE(6),NPMTRS(6),KSPTAB(14)_^1_$EQUIVALENCE (INFTB(1),KODNAM(1)),(ISET(11),KSPTAB(1))_^1_$BYTE (KFTYPE,INFTB(3)(15=14)),(NLINE,INFTB(3)(13=13)),_^1_#$ (NPMTRS,INFTB(3)(12=0))_^1C_]_^1C_#PHASE 4 BLANK COMMON BLOCK._^1_$COMMON//JSYM(3),_^1C ****************€€****************** FTN 3.1 **************************_^1_#1 INBUFF(304),OUTBUF(10),KART(2,3,3),KQ(5),KFCET(5,3),_^1C ********************************** FTN 3.1 ($) **********************_^1_#2 KSUBAT(240),KSFAT(12,2),KLLTB(10,2),LPTYP(10),_^1_#3 INTRAS(304),IMOD(30),NDTYP(30),NBRNS(30),ICBRN(30),_^1_#4 KOP(30),KTRUT(30)_^1_$DIMENSION KFALS(30),KFATH(30),KOMPSW(30),KSBPTR(30),KRES€€W(30)_^1_$EQUIVALENCE (KFALS(1),ISTAB(1)),(KFATH(1),ISTAB(31)),_^1_#1 (KOMPSW(1),ISTAB(61)),(KSBPTR(1),ISTAB(91)),(KRESW(1),ISTAB(121))_^1_$COMMON// LTYP,MBEGIN_^1_#1,IADDIT,INTRAX,IPTR,ISBSCP,JXX,KBEGIN,KBIAS,KBYTX,KENTER,KENTRY_^1_#2,KEXEC,KEXTYP,KFCSW,KFFSAV,KFINDX,KFLAM,KINTYP,KLLTBX,KNTROL_^1_#3,KOBX,KPRNAM,KQSAV,KRETRN,KSFNAM,KTCATX,LEVEL,LIFTX,LOGIF,KFCETX_^1_$DIMENSION NINV€€S(30),NINENC(30),NPASS(30)_^1_$EQUIVALENCE (KTRUT(1),NINVS(1)),(KFALS(1),NINENC(1))_^1_#1,(KFATH(1),NPASS(1))_^1_$INTEGER OUTBUF_^1C_]_^1C_'ROUTINE TO PROCESS ASSEM STATEMENT._^1C_]_^1_$IX = JXX - 4_^1_$IF (INBUFF(IX).LT.0) IX = IX - 1_^1_$LNGTH1 = INBUFF(IX) + 1_^1C_]_^1C_#TEST FOR AND EXIT IF END OF ASSEM STATEMENT_^1C_]_^1C ********************************** 65*1415 ************€€***************_^1C ********************************** 65*1415 ***************************_^1_"2 IF ( (JXX-IX+1) .EQ. LNGTH1) RETURN_^1C ********************************** 65*1415 ***************************_^1C ********************************** 65*1415 ***************************_^1C_]_^1C_#SET LXY TO PARAMETER TYPE NUMBER_^1C_]_^1 100 LXY = INBUFF(JXX)_^1C_]_^1C_#INITIALISE TY€€PE PARAMETER WORD FOR KPCSTK SUBR._^1C_]_^1_$INDTYP = INDTAB(2)_^1C_]_^1C_#BRANCH TO PROCESS PARAMETER TYPES_^1C_]_^1_$GO TO (110,120,130,140,150,160),LXY_^1C_]_^1C_#RECORD INCREMENT AND CONSTANT TYPE IN PARAMETER_^1C_(WORDS FOR KPCSTK SUBROUTINE IF HEX CONST_^1C_]_^1 110 KINC = 0_^1_$KCOMM = NCON_^1_$GO TO 35_^1C_]_^1C_#SET TYPE PARAMETER WORD FOR KPCSTK SUBROUTINE IF_^1C_(15 BIT€€ REL AND DIRECT ADDRESS CONSTANT_^1C_]_^1 140 INDTYP = INDTYP + 8_^1_$GO TO 120_^1C_]_^1C_#SET TYPE PARAMETER WORD FOR KPCSTK IF 15 BIT_^1C_(RELATIVE AND INDIRECT ADDR CONST_^1C_]_^1 130 INDTYP = INDTAB(18)_^1_$GO TO 103_^1C_]_^1C_#SET TYPE PARAMETER WORD FOR KPCSTK SUBROUTINE_^1C_(IF EITHER /_^1C_(16 BIT SELF RELATIVE ADDRESS CONSTANT_^1C_(OR -_^1C_(15 BIT RELATIVE AND DIRECT AD€€DR CONST_^1C_]_^1 150 INDTYP = INDTAB(10)_^1 120 INDTYP = INDTYP + 8193_^1C_]_^1C_#RECORD INCREMENT AND PARAMETER TYPE IN PARAMETER_^1C_(WORDS FOR KPCSTK SUBROUTINE IF ADDR CONST_^1C_]_^1 103 KINC = INBUFF(JXX+2)_^1_$KCOMM = NADC_^1C_]_^1C_#GENERATE OUTPUT ENTRY FOR CONSTANT_^1C_]_^1_!35 CALL KPCSTK (INDTYP,KCOMM,INBUFF(JXX+1),KINC,0)_^1C_]_^1C_#INCREASE POINTER ACCORDING TO THE€ NUMBER OF_^1C_(WORDS FOR CURRENT INBUFF ENTRY_^1C_]_^1_$IF (LXY.NE.1) JXX = JXX + 1_^1_"1 JXX = JXX + 2_^1_$GO TO 2_^1C_#PROCESS PARAMETER TYPE = STATEMENT LABEL BY_^1C_(GENERATING OUTPUT ENTRY FOR LABEL_^1C_]_^1 160 CALL LABKPC (INBUFF(JXX+1))_^1_$GO TO 1_^1_$END_]_^__PWBANAN CSY/ 14B P€1_$SUBROUTINE BANANA_^1_#*_2/DECK-ID 14B FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^13_]_^1C BANANA IS USED IN PHASE B1_^1C_]_^1C_#MASTER LABELED COMMON BLOCK._^1*_] FTN 3.3_^1_$COMMON /A/ IFLAGS,LINECT,LINCT1_^1_$COMMON /A/ IR,IK,IP,IA,IL,IM,IXLGO,I€€OPTO,IOPTV,IOPTC,IOPTD_^1_$COMMON /A/ MCSTRT,MACRNB,MACSEC_^1_$COMMON /A/ IERRS(16),ISRFAD_^1_$COMMON /A/ LGO,ISCRI,ISCRO,IX_^1*_] FTN 3.3_^1_$COMMON /A/ IGLAB(3),IGLAB1,IGLAB2_^1_$COMMON /A/ ICOMT(12),ICOMTS,ICOMX2,ICOMTL,ISUBP,NDPRS,_^1_#$LABX,IBCDTB(48)_^1_$EQUIVALENCE(ICOMB,ICOMT(1)),(ICOMBX,ICOMT(2)),(ICOMDF,_^1_#$ICOMT(3)),(ICOMBN,ICOMT(4))_^1_$DIMENSION ICOMB(6),ICOMBX(6),I€€COMDF(6),ICOMBN(7)_^1_$COMMON /A/ LOOPTS,LOOPTX,LOOPTB,LOOPT(50)_^1_$EQUIVALENCE(LINDUC,LOOPT(1))_^1_$DIMENSION LINDUC(10)_^1_$EQUIVALENCE (LBEG,LOOPT(2))_^1_$DIMENSION LBEG(10)_^1_$EQUIVALENCE (LINC,LOOPT(3))_^1_$DIMENSION LINC(10)_^1_$EQUIVALENCE (LEND,LOOPT(4))_^1_$DIMENSION LEND(10)_^1_$BYTE(LLABL,LOOPT(5)(14=0)_))_^1_$DIMENSION LLABL(10)_^1_$BYTE(LID,LOOPT(5)(15=15) )_^1_$DI€€MENSION LID(10)_^1_$COMMON /A/ IEQV(255),IEQVS,IEQVN2_^1_$COMMON /A/ ISTAB(150),ISTABS,ISTAB2_^1_$COMMON /A/ IBUFS,ISET(25),LBLANK,KSFCNT,KSNCNT,ISORSC,_^1_#$IHOBIT,ISTNO,ISSFLG,ISUBPN,ITERM,JSORSC,KEQVS_^1C_]_^1C_#SYMBOL TABLE LABELED COMMON BLOCK_^1_$COMMON /A/ ISYMN, ISYMFL,ISYMD,ISYMX,ISYMS,ISYMP,ISYMPC,ISYMPS,_^1_#$ ISYMNS, SYMTAB(960)_^1_$INTEGER SYMTAB_^1_$BYTE (IDUM,SYMTAB(€€1)(15=15)),(KDUMY,SYMTAB(1)(15=15)),_^1_#$(ICLASS,SYMTAB(1)(14=11)),(ITYPE,SYMTAB(1)(10=9))_^1_$DIMENSION IDUM(100),KDUMY(100),ICLASS(100),ITYPE(100)_^1_$BYTE (ISNGL, SYMTAB(1)(8=8)),(KELSIZ,SYMTAB(1)(8=8)),_^1_#$ (ICOM,SYMTAB(1)(7=5)),(IPART,SYMTAB(1)(4=3))_^1_$DIMENSION ISNGL(100),KELSIZ(100),ICOM(100),IPART(100)_^1_$BYTE (KRFCNT,SYMTAB(1)(2=2)),(IDIM,SYMTAB(1)(1=0)),_^1_#$ (IREL€€,SYMTAB(1)(1=1)),(IEXT,SYMTAB(1)(0=0))_^1_$DIMENSION KRFCNT(100),IDIM(100),IREL(100),IEXT(100)_^1_$EQUIVALENCE (IRSA,SYMTAB(2)),(ICOMTX,SYMTAB(2)),(ISNOL,SYMTAB(2))_^1_$DIMENSION IRSA(100), ICOMTX(100),ISNOL(100)_^1_$BYTE (IDATAS,SYMTAB(3)(15=15)),(IREF,SYMTAB(3)(15=15)),_^1_#$ (IEQVX,SYMTAB(3)(14=8)),(ITILF,SYMTAB(3)(14=8))_^1_$DIMENSION IDATAS(100),IREF(100),IEQVX(100),ITILF(100)€€_^1_$BYTE (IPARTR,SYMTAB(3)(7=4)),(INDUCV,SYMTAB(3)(7=7)),(ISFARG,_^1_#$ SYMTAB(3)(6=6)),(IARGNO,SYMTAB(3)(5=0)),(IPARTL,SYMTAB(3)(3=0))_^1_$DIMENSION IPARTR(100),INDUCV(100),ISFARG(100),IARGNO(100),_^1_#$ IPARTL(100)_^1_$EQUIVALENCE (ISYM,SYMTAB(4))_^1_$DIMENSION ISYM(100)_^1C_]_^1C_#SPECIFICATION-TABLE INDEX LABELLED COMMON BLOCK_^1_$COMMON /A/ ISTABX(96)_^1C_]_^1C_#PHASE 4 LABEL€€ED COMMON BLOCK._^1_$COMMON /A/ INDTAB(18),INFTB(18)_^1_#2,NBSS ,NADC ,NCON ,NEND ,NPST ,NSTN ,NJMP ,NRTJ ,NLDA_^1_#3,NLDQ ,NSTA ,NSTQ ,NRAO ,NADD ,NSUB ,NAND ,NDVI ,NADQ_^1_#4,NENA ,NINA ,NENQ ,NINQ ,NLRS ,NLLS ,NQRS ,NQLS ,NARS_^1_#5,NALS ,NAJLGZ,NAJEZ ,NAJLZ ,NAJGEZ,NAJLEZ,NAJGZ ,NQJEZ ,NMUI_^1_$COMMON/A/_^1_#1 NFCM ,NFSB ,NFMU ,NFDV ,NFLD ,NFST ,N€€FAD ,NCAQA_^1_#2,NTCQA ,NTRAQ ,KLDQ ,KSTQ ,NTCAA ,NEOR ,NTCQQ_^1_#3,INFTBL,INFTBN,INFTBX_^1_$DIMENSION KODNAM(18), KFTYPE(6),NLINE(6),NPMTRS(6),KSPTAB(14)_^1_$EQUIVALENCE (INFTB(1),KODNAM(1)),(ISET(11),KSPTAB(1))_^1_$BYTE (KFTYPE,INFTB(3)(15=14)),(NLINE,INFTB(3)(13=13)),_^1_#$ (NPMTRS,INFTB(3)(12=0))_^1C_]_^1C_#PHASE 4 BLANK COMMON BLOCK._^1_$COMMON//JSYM(3),_^1C **************€€******************** FTN 3.1 **************************_^1_#1 INBUFF(304),OUTBUF(10),KART(2,3,3),KQ(5),KFCET(5,3),_^1C ********************************** FTN 3.1 ($) **********************_^1_#2 KSUBAT(240),KSFAT(12,2),KLLTB(10,2),LPTYP(10),_^1_#3 INTRAS(304),IMOD(30),NDTYP(30),NBRNS(30),ICBRN(30),_^1_#4 KOP(30),KTRUT(30)_^1_$DIMENSION KFALS(30),KFATH(30),KOMPSW(30),KSBPTR(30),KR€€ESW(30)_^1_$EQUIVALENCE (KFALS(1),ISTAB(1)),(KFATH(1),ISTAB(31)),_^1_#1 (KOMPSW(1),ISTAB(61)),(KSBPTR(1),ISTAB(91)),(KRESW(1),ISTAB(121))_^1_$COMMON// LTYP,MBEGIN_^1_#1,IADDIT,INTRAX,IPTR,ISBSCP,JXX,KBEGIN,KBIAS,KBYTX,KENTER,KENTRY_^1_#2,KEXEC,KEXTYP,KFCSW,KFFSAV,KFINDX,KFLAM,KINTYP,KLLTBX,KNTROL_^1_#3,KOBX,KPRNAM,KQSAV,KRETRN,KSFNAM,KTCATX,LEVEL,LIFTX,LOGIF,KFCETX_^1_$DIMENSION NI€€NVS(30),NINENC(30),NPASS(30)_^1_$EQUIVALENCE (KTRUT(1),NINVS(1)),(KFALS(1),NINENC(1))_^1_#1,(KFATH(1),NPASS(1))_^1_$INTEGER OUTBUF_^1C_]_^1C_'PROCESS END DO STATEMENT_^1C_]_^1C_]_^1_$KLLTBX=KLLTBX-1_^1_$LOOPTX=LOOPTX-LOOPTB_^1_$J=LOOPTX_^1_$LTYP=LPTYP(KLLTBX)_^1_$GO TO (361,363,37,371),LTYP_^1 361 IF (LID(J).EQ.0) GO TO 364_^1C_#GENERATE LDA INDVAR, SUB INCREM_^1_$ASSIGN 3611 TO I€€AD_^1 3610 CALL KPC3PR(INDTAB(5),NLDA,LINDUC(J))_^1_$CALL KPC3PR(INDTAB(5),NSUB,LINC(J))_^1_$GO TO IAD_^1C_#GENERATE STA INDVAR,SUB TRMVAL_^1 3611 CALL KPC3PR(INDTAB(5),NSTA,LINDUC(J))_^1 368 CALL KPC3PR(INDTAB(5),NSUB,LEND(J))_^1_$GO TO 362_^1 364 ISYMX=LINC(J)_^1_$CALL GETSYM_^1_$IF(ICLASS(ISYMX).EQ.2.AND.ISYM(ISYMX).EQ.1) GO TO 365_^1C_#GENERATE LDA INDVAR,ADD INCRE,STA INDVAR€€_^1_$ASSIGN 3641 TO IAD_^1 3640 CALL KPC3PR(INDTAB(5),NLDA,LINDUC(J))_^1_$CALL KPC3PR(INDTAB(5),NADD,LINC(J))_^1_$GO TO IAD_^1 3641 CALL KPC3PR(INDTAB(5),NSTA,LINDUC(J))_^1_$GO TO 366_^1C_#GENERATE LDA INDVAR,ADD INCREM_^1 363 ASSIGN 367 TO IAD_^1_$GO TO 3640_^1C_#GENERATE RAO INDVAR_^1_!37 CALL KPC3PR(INDTAB(5),NRAO,LINDUC(J))_^1C_#GENERATE JMP RTN, ENDLP_^1 367 CALL KPC3PR(IN€€DTAB(5),NJMP,KLLTB(KLLTBX,2))_^1_$CALL LABKPC(KLLTB(KLLTBX,1))_^1_$RETURN_^1C_]_^1C_#GENERATE LDA INDVAR,SUB INCR._^1 371 ASSIGN 367 TO IAD_^1_$GO TO 3610_^1C_#GENERATE RAO INDVAR_^1 365 CALL KPC3PR(INDTAB(5),NRAO,LINDUC(J))_^1C_#GENERATE LDA TRMVAL,SUB INDVAR_^1 366 CALL KPC3PR(INDTAB(5),NLDA,LEND(J))_^1_$CALL KPC3PR(INDTAB(5),NSUB,LINDUC(J))_^1C_#GENERATE AJP,PL RTN_^1 362 €<CALL KPC3PR(INDTAB(5),NAJGEZ,KLLTB(KLLTBX,2))_^1_$END_]_^__ <PWBGNDO CSY/ 15B P€1_$SUBROUTINE BGINDO_^1_#*_2/DECK-ID 15B FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^13_]_^1C BGINDO IS USED IN PHASE B1_^1C_]_^1C_#MASTER LABELED COMMON BLOCK._^1*_] FTN 3.3_^1_$COMMON /A/ IFLAGS,LINECT,LINCT1_^1_$COMMON /A/ IR,IK,IP,IA,IL,IM,IXLGO,I€€OPTO,IOPTV,IOPTC,IOPTD_^1_$COMMON /A/ MCSTRT,MACRNB,MACSEC_^1_$COMMON /A/ IERRS(16),ISRFAD_^1_$COMMON /A/ LGO,ISCRI,ISCRO,IX_^1*_] FTN 3.3_^1_$COMMON /A/ IGLAB(3),IGLAB1,IGLAB2_^1_$COMMON /A/ ICOMT(12),ICOMTS,ICOMX2,ICOMTL,ISUBP,NDPRS,_^1_#$LABX,IBCDTB(48)_^1_$EQUIVALENCE(ICOMB,ICOMT(1)),(ICOMBX,ICOMT(2)),(ICOMDF,_^1_#$ICOMT(3)),(ICOMBN,ICOMT(4))_^1_$DIMENSION ICOMB(6),ICOMBX(6),I€€COMDF(6),ICOMBN(7)_^1_$COMMON /A/ LOOPTS,LOOPTX,LOOPTB,LOOPT(50)_^1_$EQUIVALENCE(LINDUC,LOOPT(1))_^1_$DIMENSION LINDUC(10)_^1_$EQUIVALENCE (LBEG,LOOPT(2))_^1_$DIMENSION LBEG(10)_^1_$EQUIVALENCE (LINC,LOOPT(3))_^1_$DIMENSION LINC(10)_^1_$EQUIVALENCE (LEND,LOOPT(4))_^1_$DIMENSION LEND(10)_^1_$BYTE(LLABL,LOOPT(5)(14=0)_))_^1_$DIMENSION LLABL(10)_^1_$BYTE(LID,LOOPT(5)(15=15) )_^1_$DI€€MENSION LID(10)_^1_$COMMON /A/ IEQV(255),IEQVS,IEQVN2_^1_$COMMON /A/ ISTAB(150),ISTABS,ISTAB2_^1_$COMMON /A/ IBUFS,ISET(25),LBLANK,KSFCNT,KSNCNT,ISORSC,_^1_#$IHOBIT,ISTNO,ISSFLG,ISUBPN,ITERM,JSORSC,KEQVS_^1C_]_^1C_#SYMBOL TABLE LABELED COMMON BLOCK_^1_$COMMON /A/ ISYMN, ISYMFL,ISYMD,ISYMX,ISYMS,ISYMP,ISYMPC,ISYMPS,_^1_#$ ISYMNS, SYMTAB(960)_^1_$INTEGER SYMTAB_^1_$BYTE (IDUM,SYMTAB(€€1)(15=15)),(KDUMY,SYMTAB(1)(15=15)),_^1_#$(ICLASS,SYMTAB(1)(14=11)),(ITYPE,SYMTAB(1)(10=9))_^1_$DIMENSION IDUM(100),KDUMY(100),ICLASS(100),ITYPE(100)_^1_$BYTE (ISNGL, SYMTAB(1)(8=8)),(KELSIZ,SYMTAB(1)(8=8)),_^1_#$ (ICOM,SYMTAB(1)(7=5)),(IPART,SYMTAB(1)(4=3))_^1_$DIMENSION ISNGL(100),KELSIZ(100),ICOM(100),IPART(100)_^1_$BYTE (KRFCNT,SYMTAB(1)(2=2)),(IDIM,SYMTAB(1)(1=0)),_^1_#$ (IREL€€,SYMTAB(1)(1=1)),(IEXT,SYMTAB(1)(0=0))_^1_$DIMENSION KRFCNT(100),IDIM(100),IREL(100),IEXT(100)_^1_$EQUIVALENCE (IRSA,SYMTAB(2)),(ICOMTX,SYMTAB(2)),(ISNOL,SYMTAB(2))_^1_$DIMENSION IRSA(100), ICOMTX(100),ISNOL(100)_^1_$BYTE (IDATAS,SYMTAB(3)(15=15)),(IREF,SYMTAB(3)(15=15)),_^1_#$ (IEQVX,SYMTAB(3)(14=8)),(ITILF,SYMTAB(3)(14=8))_^1_$DIMENSION IDATAS(100),IREF(100),IEQVX(100),ITILF(100)€€_^1_$BYTE (IPARTR,SYMTAB(3)(7=4)),(INDUCV,SYMTAB(3)(7=7)),(ISFARG,_^1_#$ SYMTAB(3)(6=6)),(IARGNO,SYMTAB(3)(5=0)),(IPARTL,SYMTAB(3)(3=0))_^1_$DIMENSION IPARTR(100),INDUCV(100),ISFARG(100),IARGNO(100),_^1_#$ IPARTL(100)_^1_$EQUIVALENCE (ISYM,SYMTAB(4))_^1_$DIMENSION ISYM(100)_^1C_]_^1C_#SPECIFICATION-TABLE INDEX LABELLED COMMON BLOCK_^1_$COMMON /A/ ISTABX(96)_^1C_]_^1C_#PHASE 4 LABEL€€ED COMMON BLOCK._^1_$COMMON /A/ INDTAB(18),INFTB(18)_^1_#2,NBSS ,NADC ,NCON ,NEND ,NPST ,NSTN ,NJMP ,NRTJ ,NLDA_^1_#3,NLDQ ,NSTA ,NSTQ ,NRAO ,NADD ,NSUB ,NAND ,NDVI ,NADQ_^1_#4,NENA ,NINA ,NENQ ,NINQ ,NLRS ,NLLS ,NQRS ,NQLS ,NARS_^1_#5,NALS ,NAJLGZ,NAJEZ ,NAJLZ ,NAJGEZ,NAJLEZ,NAJGZ ,NQJEZ ,NMUI_^1_$COMMON/A/_^1_#1 NFCM ,NFSB ,NFMU ,NFDV ,NFLD ,NFST ,N€€FAD ,NCAQA_^1_#2,NTCQA ,NTRAQ ,KLDQ ,KSTQ ,NTCAA ,NEOR ,NTCQQ_^1_#3,INFTBL,INFTBN,INFTBX_^1_$DIMENSION KODNAM(18), KFTYPE(6),NLINE(6),NPMTRS(6),KSPTAB(14)_^1_$EQUIVALENCE (INFTB(1),KODNAM(1)),(ISET(11),KSPTAB(1))_^1_$BYTE (KFTYPE,INFTB(3)(15=14)),(NLINE,INFTB(3)(13=13)),_^1_#$ (NPMTRS,INFTB(3)(12=0))_^1C_]_^1C_#PHASE 4 BLANK COMMON BLOCK._^1_$COMMON//JSYM(3),_^1C **************€€******************** FTN 3.1 **************************_^1_#1 INBUFF(304),OUTBUF(10),KART(2,3,3),KQ(5),KFCET(5,3),_^1C ********************************** FTN 3.1 ($) **********************_^1_#2 KSUBAT(240),KSFAT(12,2),KLLTB(10,2),LPTYP(10),_^1_#3 INTRAS(304),IMOD(30),NDTYP(30),NBRNS(30),ICBRN(30),_^1_#4 KOP(30),KTRUT(30)_^1_$DIMENSION KFALS(30),KFATH(30),KOMPSW(30),KSBPTR(30),KR€€ESW(30)_^1_$EQUIVALENCE (KFALS(1),ISTAB(1)),(KFATH(1),ISTAB(31)),_^1_#1 (KOMPSW(1),ISTAB(61)),(KSBPTR(1),ISTAB(91)),(KRESW(1),ISTAB(121))_^1_$COMMON// LTYP,MBEGIN_^1_#1,IADDIT,INTRAX,IPTR,ISBSCP,JXX,KBEGIN,KBIAS,KBYTX,KENTER,KENTRY_^1_#2,KEXEC,KEXTYP,KFCSW,KFFSAV,KFINDX,KFLAM,KINTYP,KLLTBX,KNTROL_^1_#3,KOBX,KPRNAM,KQSAV,KRETRN,KSFNAM,KTCATX,LEVEL,LIFTX,LOGIF,KFCETX_^1_$DIMENSION NI€€NVS(30),NINENC(30),NPASS(30)_^1_$EQUIVALENCE (KTRUT(1),NINVS(1)),(KFALS(1),NINENC(1))_^1_#1,(KFATH(1),NPASS(1))_^1_$INTEGER OUTBUF_^1C_]_^1C_]_^1C_#PROCESS BEGIN DO STATEMENT_^1C_]_^1_$IF (LOOPTX+LOOPTB-1.GT.LOOPTS) CALL PUNT_^1_$DO 10 I=1,LOOPTB,1_^1_$LPTX1=LOOPTX+I-1_^1_$JXXX=JXX+I-1_^1_!10 LOOPT(LPTX1)=INBUFF(JXXX)_^1_$J=LOOPTX_^1_$LOOPTX=LOOPTX+LOOPTB_^1_$KSWIT=0_^1_$CALL LABL€€ER(KENDL1)_^1_$KLLTB(KLLTBX,2)=KENDL1_^1_$KLLTBX=KLLTBX+1_^1C_#IS INITIAL VARIABLE OR CONSTANT_^1_$ISYMX=LBEG(J)_^1_$CALL GETSYM_^1_$IF(ICLASS(ISYMX).EQ.1)KSWIT=KSWIT+1_^1_$ISYMX=LEND(J)_^1_$CALL GETSYM_^1_$IF(ICLASS(ISYMX).EQ.1) KSWIT=KSWIT+2_^1C_#INCREMENT_^1_$ISYMX=LINC(J)_^1_$CALL GETSYM_^1_$IF(ICLASS(ISYMX).EQ.1) KSWIT=KSWIT+4_^1_$IF(KSWIT .EQ.0.OR.KSWIT.EQ.4) GO TO 220_^1 22€€3 KTFF=1_^1_$CALL LABLER(KENDLP)_^1C_#PUT AWAY END DO TAG,RETURN TAG_^1_$KLLTB(KLLTBX-1,1)=KENDLP_^1_$GO TO 235_^1 220 KTFF=0_^1C_#GENERATE LDA INVAL_^1 235 CALL KPC3PR(INDTAB(5),NLDA,LBEG(J))_^1_$IF (KTFF) 226,226, 227_^1 227 IF(LID(J).EQ.1) GO TO 228_^1_$ISYMX=LINC(J)_^1_$CALL GETSYM_^1_$IF(ICLASS(ISYMX).EQ.2.AND.ISYM(ISYMX).EQ.1) GO TO 243_^1C_#GENERATE RTN STA INDVAR_^1 2€€28 ASSIGN 229 TO IAD_^1_$GO TO 2260_^1 229 CALL KPC3PR(INDTAB(5),NSTA,LINDUC(J))_^1_$IF(LID(J).EQ.0) GO TO 245_^1C_#GENERATE SUB TRMVAL_^1_$CALL KPC3PR(INDTAB(5),NSUB,LEND(J))_^1_$LTYP=4_^1C_#GENERATE AJP,MI ENDLP_^1 246 CALL KPC3PR(INDTAB(5),NAJLZ,KENDLP)_^1_$GO TO 2263_^1C_#GENERATE STA INDVAR,RTN_^1 226 ASSIGN 2261 TO IAD_^1 2262 CALL KPC3PR(INDTAB(5),NSTA,LINDUC(J))_^1 226€€0 CALL LABKPC(KENDL1)_^1_$GO TO IAD_^1C_#GENERATE STA INDVAR, RTN LDA TRMVAL,SUB INDVAR_^1 243 ASSIGN 2430 TO IAD_^1_$GO TO 2262_^1 2430 CALL KPC3PR(INDTAB(5),NLDA,LEND(J))_^1_$CALL KPC3PR(INDTAB(5),NSUB,LINDUC(J))_^1_$LTYP=3_^1_$GO TO 246_^1C_#GENERATE TCA A, ADD TRMVAL_^1 245 CALL KPC3PR(INDTAB(9),NTCAA,0)_^1_$CALL KPC3PR(INDTAB(5),NADD,LEND(J))_^1_$LTYP=2_^1_$GO TO 246_^1 €62261 LTYP=1_^1 2263 LPTYP(KLLTBX-1)=LTYP_^1_$END_]_^__6PWEND CSY/ 16B P€1_$SUBROUTINE END_^1_#*_2/DECK-ID 16B FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^13_]_^1C END IS USED IN PHASE B1_^1C_]_^1C_#MASTER LABELED COMMON BLOCK._^1*_] FTN 3.3_^1_$COMMON /A/ IFLAGS,LINECT,LINCT1_^1_$COMMON /A/ IR,IK,IP,IA,IL,IM,IXLGO,IOPTO,I€€OPTV,IOPTC,IOPTD_^1_$COMMON /A/ MCSTRT,MACRNB,MACSEC_^1_$COMMON /A/ IERRS(16),ISRFAD_^1_$COMMON /A/ LGO,ISCRI,ISCRO,IX_^1*_] FTN 3.3_^1_$COMMON /A/ IGLAB(3),IGLAB1,IGLAB2_^1_$COMMON /A/ ICOMT(12),ICOMTS,ICOMX2,ICOMTL,ISUBP,NDPRS,_^1_#$LABX,IBCDTB(48)_^1_$EQUIVALENCE(ICOMB,ICOMT(1)),(ICOMBX,ICOMT(2)),(ICOMDF,_^1_#$ICOMT(3)),(ICOMBN,ICOMT(4))_^1_$DIMENSION ICOMB(6),ICOMBX(6),ICOMDF(€€6),ICOMBN(7)_^1_$COMMON /A/ LOOPTS,LOOPTX,LOOPTB,LOOPT(50)_^1_$EQUIVALENCE(LINDUC,LOOPT(1))_^1_$DIMENSION LINDUC(10)_^1_$EQUIVALENCE (LBEG,LOOPT(2))_^1_$DIMENSION LBEG(10)_^1_$EQUIVALENCE (LINC,LOOPT(3))_^1_$DIMENSION LINC(10)_^1_$EQUIVALENCE (LEND,LOOPT(4))_^1_$DIMENSION LEND(10)_^1_$BYTE(LLABL,LOOPT(5)(14=0)_))_^1_$DIMENSION LLABL(10)_^1_$BYTE(LID,LOOPT(5)(15=15) )_^1_$DIMENSIO€€N LID(10)_^1_$COMMON /A/ IEQV(255),IEQVS,IEQVN2_^1_$COMMON /A/ ISTAB(150),ISTABS,ISTAB2_^1_$COMMON /A/ IBUFS,ISET(25),LBLANK,KSFCNT,KSNCNT,ISORSC,_^1_#$IHOBIT,ISTNO,ISSFLG,ISUBPN,ITERM,JSORSC,KEQVS_^1C_]_^1C_#SYMBOL TABLE LABELED COMMON BLOCK_^1_$COMMON /A/ ISYMN, ISYMFL,ISYMD,ISYMX,ISYMS,ISYMP,ISYMPC,ISYMPS,_^1_#$ ISYMNS, SYMTAB(960)_^1_$INTEGER SYMTAB_^1_$BYTE (IDUM,SYMTAB(1)(15=€€15)),(KDUMY,SYMTAB(1)(15=15)),_^1_#$(ICLASS,SYMTAB(1)(14=11)),(ITYPE,SYMTAB(1)(10=9))_^1_$DIMENSION IDUM(100),KDUMY(100),ICLASS(100),ITYPE(100)_^1_$BYTE (ISNGL, SYMTAB(1)(8=8)),(KELSIZ,SYMTAB(1)(8=8)),_^1_#$ (ICOM,SYMTAB(1)(7=5)),(IPART,SYMTAB(1)(4=3))_^1_$DIMENSION ISNGL(100),KELSIZ(100),ICOM(100),IPART(100)_^1_$BYTE (KRFCNT,SYMTAB(1)(2=2)),(IDIM,SYMTAB(1)(1=0)),_^1_#$ (IREL,SYMTA€€B(1)(1=1)),(IEXT,SYMTAB(1)(0=0))_^1_$DIMENSION KRFCNT(100),IDIM(100),IREL(100),IEXT(100)_^1_$EQUIVALENCE (IRSA,SYMTAB(2)),(ICOMTX,SYMTAB(2)),(ISNOL,SYMTAB(2))_^1_$DIMENSION IRSA(100), ICOMTX(100),ISNOL(100)_^1_$BYTE (IDATAS,SYMTAB(3)(15=15)),(IREF,SYMTAB(3)(15=15)),_^1_#$ (IEQVX,SYMTAB(3)(14=8)),(ITILF,SYMTAB(3)(14=8))_^1_$DIMENSION IDATAS(100),IREF(100),IEQVX(100),ITILF(100)_^1_$B€€YTE (IPARTR,SYMTAB(3)(7=4)),(INDUCV,SYMTAB(3)(7=7)),(ISFARG,_^1_#$ SYMTAB(3)(6=6)),(IARGNO,SYMTAB(3)(5=0)),(IPARTL,SYMTAB(3)(3=0))_^1_$DIMENSION IPARTR(100),INDUCV(100),ISFARG(100),IARGNO(100),_^1_#$ IPARTL(100)_^1_$EQUIVALENCE (ISYM,SYMTAB(4))_^1_$DIMENSION ISYM(100)_^1C_]_^1C_#SPECIFICATION-TABLE INDEX LABELLED COMMON BLOCK_^1_$COMMON /A/ ISTABX(96)_^1C_]_^1C_#PHASE 4 LABELED COM€€MON BLOCK._^1_$COMMON /A/ INDTAB(18),INFTB(18)_^1_#2,NBSS ,NADC ,NCON ,NEND ,NPST ,NSTN ,NJMP ,NRTJ ,NLDA_^1_#3,NLDQ ,NSTA ,NSTQ ,NRAO ,NADD ,NSUB ,NAND ,NDVI ,NADQ_^1_#4,NENA ,NINA ,NENQ ,NINQ ,NLRS ,NLLS ,NQRS ,NQLS ,NARS_^1_#5,NALS ,NAJLGZ,NAJEZ ,NAJLZ ,NAJGEZ,NAJLEZ,NAJGZ ,NQJEZ ,NMUI_^1_$COMMON/A/_^1_#1 NFCM ,NFSB ,NFMU ,NFDV ,NFLD ,NFST ,NFAD ,€€NCAQA_^1_#2,NTCQA ,NTRAQ ,KLDQ ,KSTQ ,NTCAA ,NEOR ,NTCQQ_^1_#3,INFTBL,INFTBN,INFTBX_^1C ********************************** FTN 3.1 **************************_^1_$COMMON /A/ NDCM,NDSB,NDMU,NDDV,NDLD,NDST,NDAD_^1C ********************************** FTN 3.1 ($) **********************_^1_$DIMENSION KODNAM(18), KFTYPE(6),NLINE(6),NPMTRS(6),KSPTAB(14)_^1_$EQUIVALENCE (INFTB(1),KODNA€€M(1)),(ISET(11),KSPTAB(1))_^1_$BYTE (KFTYPE,INFTB(3)(15=14)),(NLINE,INFTB(3)(13=13)),_^1_#$ (NPMTRS,INFTB(3)(12=0))_^1C_]_^1C_#PHASE 4 BLANK COMMON BLOCK._^1_$COMMON//JSYM(3),_^1C ********************************** FTN 3.1 **************************_^1_#1 INBUFF(304),OUTBUF(10),KART(2,3,3),KQ(5),KFCET(5,3),_^1C ********************************** FTN 3.1 ($) **********************€€_^1_#2 KSUBAT(240),KSFAT(12,2),KLLTB(10,2),LPTYP(10),_^1_#3 INTRAS(304),IMOD(30),NDTYP(30),NBRNS(30),ICBRN(30),_^1_#4 KOP(30),KTRUT(30)_^1_$DIMENSION KFALS(30),KFATH(30),KOMPSW(30),KSBPTR(30),KRESW(30)_^1_$EQUIVALENCE (KFALS(1),ISTAB(1)),(KFATH(1),ISTAB(31)),_^1_#1 (KOMPSW(1),ISTAB(61)),(KSBPTR(1),ISTAB(91)),(KRESW(1),ISTAB(121))_^1_$COMMON// LTYP,MBEGIN_^1_#1,IADDIT,INTRAX,IPTR,IS€€BSCP,JXX,KBEGIN,KBIAS,KBYTX,KENTER,KENTRY_^1_#2,KEXEC,KEXTYP,KFCSW,KFFSAV,KFINDX,KFLAM,KINTYP,KLLTBX,KNTROL_^1_#3,KOBX,KPRNAM,KQSAV,KRETRN,KSFNAM,KTCATX,LEVEL,LIFTX,LOGIF,KFCETX_^1_$DIMENSION NINVS(30),NINENC(30),NPASS(30)_^1_$EQUIVALENCE (KTRUT(1),NINVS(1)),(KFALS(1),NINENC(1))_^1_#1,(KFATH(1),NPASS(1))_^1_$INTEGER OUTBUF_^1C_]_^1C_]_^1C_'SUBROUTINE TO PROCESS END STATEMENT_^1_$EQ€€UIVALENCE (ISORSC,KFUNVL)_^1C_'IS THIS THE END OF A BLOCK DATA SUBP. OR MAIN ROUTINE_^1_$IF(ISUBP.LE.1) GO TO 8_^1C_]_^1C_8LDQ* FFSAV_^1C_8STQ* FF_^1C_8LDQ* QSAV_^1C_8JMP* (KPRNAM)_^1_$CALL LABKPC (KRETRN)_^1_$CALL INXRST_^1C_'IF THIS WAS AFUNCTION SUBPROGRAM, GENERATE LDA OR FLD_^1C_'OF THE FUNCTION VALUE_^1_$IF(ISUBP.EQ.2) GO TO 58_^1_!85 CALL KPC3PR (INDTAB(7),NJMP,KPRNAM)_^€€1C_]_^1C_'GENERATE ENTRY POINT LABEL_^1_"5 CALL LABKPC (KPRNAM)_^1_$KENTER=KPRNAM_^1_$KEXEC=MBEGIN_^1C_'GENERATE ENTRY CODE_^1_$CALL ENTCOD_^1C_]_^1C_'GENERATE_#END_^1_"8 CALL KPC3PR (INDTAB(9),NEND,0)_^1_$LABX=KPRNAM_^1_$RETURN_^1_!58 ISYMX=KFUNVL_^1_$CALL GETSYM_^1C ********************************** FTN 3.1 **************************_^1_$KCOM = NLDA_^1_$IF (ITYPE(ISYMX).EQ.2) €ÂKCOM = NFLD_^1_$IF (ITYPE(ISYMX).EQ.3) KCOM = NDLD_^1C ********************************** FTN 3.1 ($) **********************_^1_$CALL KPC3PR (INDTAB(5),KCOM,KFUNVL)_^1_$GO TO 85_^1_$END_]_^__ ÂPWENTCD CSY/ 17B P€1_$SUBROUTINE ENTCOD_^1_#*_2/DECK-ID 17B FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^13_]_^1C ENTCOD IS USED IN PHASE B1_^1C_]_^1C_#MASTER LABELED COMMON BLOCK._^1*_] FTN 3.3_^1_$COMMON /A/ IFLAGS,LINECT,LINCT1_^1_$COMMON /A/ IR,IK,IP,IA,IL,IM,IXLGO,I€€OPTO,IOPTV,IOPTC,IOPTD_^1_$COMMON /A/ MCSTRT,MACRNB,MACSEC_^1_$COMMON /A/ IERRS(16),ISRFAD_^1_$COMMON /A/ LGO,ISCRI,ISCRO,IX_^1*_] FTN 3.3_^1_$COMMON /A/ IGLAB(3),IGLAB1,IGLAB2_^1_$COMMON /A/ ICOMT(12),ICOMTS,ICOMX2,ICOMTL,ISUBP,NDPRS,_^1_#$LABX,IBCDTB(48)_^1_$EQUIVALENCE(ICOMB,ICOMT(1)),(ICOMBX,ICOMT(2)),(ICOMDF,_^1_#$ICOMT(3)),(ICOMBN,ICOMT(4))_^1_$DIMENSION ICOMB(6),ICOMBX(6),I€€COMDF(6),ICOMBN(7)_^1_$COMMON /A/ LOOPTS,LOOPTX,LOOPTB,LOOPT(50)_^1_$EQUIVALENCE(LINDUC,LOOPT(1))_^1_$DIMENSION LINDUC(10)_^1_$EQUIVALENCE (LBEG,LOOPT(2))_^1_$DIMENSION LBEG(10)_^1_$EQUIVALENCE (LINC,LOOPT(3))_^1_$DIMENSION LINC(10)_^1_$EQUIVALENCE (LEND,LOOPT(4))_^1_$DIMENSION LEND(10)_^1_$BYTE(LLABL,LOOPT(5)(14=0)_))_^1_$DIMENSION LLABL(10)_^1_$BYTE(LID,LOOPT(5)(15=15) )_^1_$DI€€MENSION LID(10)_^1_$COMMON /A/ IEQV(255),IEQVS,IEQVN2_^1_$COMMON /A/ ISTAB(150),ISTABS,ISTAB2_^1_$COMMON /A/ IBUFS,ISET(25),LBLANK,KSFCNT,KSNCNT,ISORSC,_^1_#$IHOBIT,ISTNO,ISSFLG,ISUBPN,ITERM,JSORSC,KEQVS_^1C_]_^1C_#SYMBOL TABLE LABELED COMMON BLOCK_^1_$COMMON /A/ ISYMN, ISYMFL,ISYMD,ISYMX,ISYMS,ISYMP,ISYMPC,ISYMPS,_^1_#$ ISYMNS, SYMTAB(960)_^1_$INTEGER SYMTAB_^1_$BYTE (IDUM,SYMTAB(€€1)(15=15)),(KDUMY,SYMTAB(1)(15=15)),_^1_#$(ICLASS,SYMTAB(1)(14=11)),(ITYPE,SYMTAB(1)(10=9))_^1_$DIMENSION IDUM(100),KDUMY(100),ICLASS(100),ITYPE(100)_^1_$BYTE (ISNGL, SYMTAB(1)(8=8)),(KELSIZ,SYMTAB(1)(8=8)),_^1_#$ (ICOM,SYMTAB(1)(7=5)),(IPART,SYMTAB(1)(4=3))_^1_$DIMENSION ISNGL(100),KELSIZ(100),ICOM(100),IPART(100)_^1_$BYTE (KRFCNT,SYMTAB(1)(2=2)),(IDIM,SYMTAB(1)(1=0)),_^1_#$ (IREL€€,SYMTAB(1)(1=1)),(IEXT,SYMTAB(1)(0=0))_^1_$DIMENSION KRFCNT(100),IDIM(100),IREL(100),IEXT(100)_^1_$EQUIVALENCE (IRSA,SYMTAB(2)),(ICOMTX,SYMTAB(2)),(ISNOL,SYMTAB(2))_^1_$DIMENSION IRSA(100), ICOMTX(100),ISNOL(100)_^1_$BYTE (IDATAS,SYMTAB(3)(15=15)),(IREF,SYMTAB(3)(15=15)),_^1_#$ (IEQVX,SYMTAB(3)(14=8)),(ITILF,SYMTAB(3)(14=8))_^1_$DIMENSION IDATAS(100),IREF(100),IEQVX(100),ITILF(100)€€_^1_$BYTE (IPARTR,SYMTAB(3)(7=4)),(INDUCV,SYMTAB(3)(7=7)),(ISFARG,_^1_#$ SYMTAB(3)(6=6)),(IARGNO,SYMTAB(3)(5=0)),(IPARTL,SYMTAB(3)(3=0))_^1_$DIMENSION IPARTR(100),INDUCV(100),ISFARG(100),IARGNO(100),_^1_#$ IPARTL(100)_^1_$EQUIVALENCE (ISYM,SYMTAB(4))_^1_$DIMENSION ISYM(100)_^1C_]_^1C_#SPECIFICATION-TABLE INDEX LABELLED COMMON BLOCK_^1_$COMMON /A/ ISTABX(96)_^1C_]_^1C_#PHASE 4 LABEL€€ED COMMON BLOCK._^1_$COMMON /A/ INDTAB(18),INFTB(18)_^1_#2,NBSS ,NADC ,NCON ,NEND ,NPST ,NSTN ,NJMP ,NRTJ ,NLDA_^1_#3,NLDQ ,NSTA ,NSTQ ,NRAO ,NADD ,NSUB ,NAND ,NDVI ,NADQ_^1_#4,NENA ,NINA ,NENQ ,NINQ ,NLRS ,NLLS ,NQRS ,NQLS ,NARS_^1_#5,NALS ,NAJLGZ,NAJEZ ,NAJLZ ,NAJGEZ,NAJLEZ,NAJGZ ,NQJEZ ,NMUI_^1_$COMMON/A/_^1_#1 NFCM ,NFSB ,NFMU ,NFDV ,NFLD ,NFST ,N€€FAD ,NCAQA_^1_#2,NTCQA ,NTRAQ ,KLDQ ,KSTQ ,NTCAA ,NEOR ,NTCQQ_^1_#3,INFTBL,INFTBN,INFTBX_^1_$DIMENSION KODNAM(18), KFTYPE(6),NLINE(6),NPMTRS(6),KSPTAB(14)_^1_$EQUIVALENCE (INFTB(1),KODNAM(1)),(ISET(11),KSPTAB(1))_^1_$BYTE (KFTYPE,INFTB(3)(15=14)),(NLINE,INFTB(3)(13=13)),_^1_#$ (NPMTRS,INFTB(3)(12=0))_^1C_]_^1C_#PHASE 4 BLANK COMMON BLOCK._^1_$COMMON//JSYM(3),_^1C **************€€******************** FTN 3.1 **************************_^1_#1 INBUFF(304),OUTBUF(10),KART(2,3,3),KQ(5),KFCET(5,3),_^1C ********************************** FTN 3.1 ($) **********************_^1_#2 KSUBAT(240),KSFAT(12,2),KLLTB(10,2),LPTYP(10),_^1_#3 INTRAS(304),IMOD(30),NDTYP(30),NBRNS(30),ICBRN(30),_^1_#4 KOP(30),KTRUT(30)_^1_$DIMENSION KFALS(30),KFATH(30),KOMPSW(30),KSBPTR(30),KR€€ESW(30)_^1_$EQUIVALENCE (KFALS(1),ISTAB(1)),(KFATH(1),ISTAB(31)),_^1_#1 (KOMPSW(1),ISTAB(61)),(KSBPTR(1),ISTAB(91)),(KRESW(1),ISTAB(121))_^1_$COMMON// LTYP,MBEGIN_^1_#1,IADDIT,INTRAX,IPTR,ISBSCP,JXX,KBEGIN,KBIAS,KBYTX,KENTER,KENTRY_^1_#2,KEXEC,KEXTYP,KFCSW,KFFSAV,KFINDX,KFLAM,KINTYP,KLLTBX,KNTROL_^1_#3,KOBX,KPRNAM,KQSAV,KRETRN,KSFNAM,KTCATX,LEVEL,LIFTX,LOGIF,KFCETX_^1_$DIMENSION NI€€NVS(30),NINENC(30),NPASS(30)_^1_$EQUIVALENCE (KTRUT(1),NINVS(1)),(KFALS(1),NINENC(1))_^1_#1,(KFATH(1),NPASS(1))_^1_$INTEGER OUTBUF_^1C_]_^1C_]_^1C_'ROUTINE TO GENERATE ENTRY ROUTINE FOR_^1C_'SUBROUTINES, FUNCTIONS, AND FUNCTI0N_^1C_'SUBPROGRAMS._^1C_]_^1C_]_^1C_]_^1C_'GENERATE_!CON_!0_^1C_2STQ* QSAV_^1C_2LDQ* FF_^1C_2STQ_!FFSAV_^1_$CALL KPC3PR(INDTAB(2),NCON,0)_^1_$CALL KPC3PR(IN€€DTAB(5),NSTQ,KQSAV)_^1_$CALL KPC3PR(INDTAB(10),KLDQ,255)_^1_$CALL KPC3PR(INDTAB(5),KSTQ,KFFSAV)_^1*_] FTN 3.3_^1_$IF(IOPTV.EQ.0) GO TO 15_^12_]_^1*_#IF USER HAS REFERENCED SPECIAL VARIABLE 'N9PARS' SAVE THE_^1*_#A REGISTER WHICH CONTAINS NUMBER OF PARAMETERS IN 'N9PARS'_^12_]_^1_$JSYM(1)=$8A1F_^1_$JSYM(2)=$3FA3_^1_$CALL SYMBOL_^1_$IF(ISYMD.EQ.0) GO TO 10_^1_$CALL KPC3PR(INDTAB(5),€€NSTA,ISYMX)_^12_]_^1*_#CHANGE PRESET FOR 'Q8PKUP' TO 'Q9PKUP'_^12_]_^1_!10 JSYM(1)=$9BCB_^1_$JSYM(2)=$7B7F_^1_$CALL SYMBOL_^1_$ISYM(ISYMX)=$9BF2_^1_!15 CONTINUE_^1*_] FTN 3.3_^1C_]_^1C_'INITIALIZE TABLE INDEX TO 1_^1_$I=1_]_^1C_'IS THIS A STATEMENT FUNCTION OR IS_^1C_'THIS A SUBPROGRAM_^1_$IF(KSFCNT.NE.0) GO TO 19_^1C_'IF THERE IS AT LEAST 1 PARAMETER, RTJ TO PARAMETER INITIALIZ._€€^1_$IF(KSUBAT(1).EQ.0) GO TO 22_^1_$ASSIGN 22 TO IAD_^1_$GO TO 30_^1C_'THIS IS A SUBPROGRAM_^1C_'HAS THE LAST PARAMETER BEEN PROCESSED_^1_!22 IF(KSUBAT(I).EQ.0) GO TO 21_^1C_'NO,_^1C_]_^1C_'MOVE SECPNDARY INDEX UP TO NXT-PMTR-POINTER._^1_$IXX=I+1_^1C_'MOVE PRIMARY INDEX UP TO NEXT PARAMETER._^1_$I=IXX+KSUBAT(IXX)_^1C_'INITIALIZE INCREMENT TO 0_^1_$INCREM=0_^1C_'GENERATE_!RTJ PIKUP€€_^1_$CALL KPC3PR(INDTAB(5),NRTJ,KSPTAB(13))_^1C_'MOVE SECONDARY INDEX UP TO NEXT INCREMENT._^1_!23 IXX=IXX+1_^1C_'HAVE ALL INCREMENTS FOR THIS PARAMETER BEEN PROCESSED_^1_$IF(IXX.EQ.I) GO TO 22_^1C_'NO, CALCULATE INCREASE TO OBTAIN NEXT INCREMENT._^1_$INCRES=KSUBAT(IXX)-INCREM_^1_$INCREM=KSUBAT(IXX)_^1C_]_^1_$IF(INCRES.EQ.0) GO TO 299_^1C_'IS THE INCREASE BETWEEN -127 AND +127_^1_$€€IF(IABS(INCRES).LT.128) GO TO 24_^1C_'NO, GENERATE_!ADD INCRES_^1_$KCOM=NADD_^1_$GO TO 29_^1C_'INCREASE IS WITHIN BOUNDS._^1C_'GENERATE_!INA INCRES_^1_!24 KCOM=NINA_^1_!29 CALL KPC3PR(INDTAB(2),KCOM,INCRES)_^1 299 CONTINUE_^1C_]_^1C_'MOVE SECONDARY INDEX TO T.S. FOR THIS INCREMENT._^1_$IXX=IXX+1_^1C_'GENERATE PST (TEMP. STORAGE REF.)_^1_$CALL KPC3PR(INDTAB(5),NPST,KSUBAT(IXX))€€_^1_$GO TO 23_^1C_]_^1C_]_^1C_'THIS IS A STATEMENT FUNCTION_^1C_'IF THERE IS AT LEAST 1 PARAMETER, RTJ TO PARAMETER INITIALIZ._^1_!19 IF(KSFAT(1,1).EQ.0) GO TO 20_^1_$ASSIGN 20 TO IAD_^1_!30 CALL KPC3PR(INDTAB(5),NRTJ,KSPTAB(14))_^1_$CALL KPC3PR(INDTAB(10),NADC,KENTER)_^1_$GO TO IAD_^1C_'HAS THE LAST PARAMETER BEEN PROCESSED._^1_!20 IF(KSFAT(I,1).EQ.0) GO TO 21_^1C_'NO,_^1C_'GENERA€€TE RTJ_!PIKUP_^1_$CALL KPC3PR(INDTAB(5),NRTJ,KSPTAB(13))_^1C_'GENERATE PST (TEMP. STORAGE REF.)_^1_$ITEMP=KSFAT(I,2)_^1_$IF(ITEMP.NE.0) CALL KPC3PR(INDTAB(5),NPST,ITEMP)_^1C_'INCREMENT INDEX_^1_$I=I+1_^1_$GO TO 20_^1C_]_^1C_'GENERATE JMP KEXEC_^1_!21 CALL KPC3PR(INDTAB(5),NJMP,KEXEC)_^1C_'GENERATE_!LABEL FFSAV_^1C_2BSS_!1_^1C_2LABEL QSAV_^1C_2BSS_!1_^1_$CALL LABKPC(KFFSAV)_^1_€f$CALL KPC3PR(INDTAB(2),NBSS,-1)_^1_$CALL LABKPC(KQSAV)_^1_$CALL KPC3PR(INDTAB(2),NBSS,1)_^1_$END_]_^__fPWHELEN CSY/ 18B P€1_$SUBROUTINE HELEN_^1_#*_2/DECK-ID 18B FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^13_]_^1C HELEN IS USED IN PHASE B1_^1C_]_^1C_#MASTER LABELED COMMON BLOCK._^1*_] FTN 3.3_^1_$COMMON /A/ IFLAGS,LINECT,LINCT1_^1_$COMMON /A/ IR,IK,IP,IA,IL,IM,IXLGO,IOP€€TO,IOPTV,IOPTC,IOPTD_^1_$COMMON /A/ MCSTRT,MACRNB,MACSEC_^1_$COMMON /A/ IERRS(16),ISRFAD_^1_$COMMON /A/ LGO,ISCRI,ISCRO,IX_^1*_] FTN 3.3_^1_$COMMON /A/ IGLAB(3),IGLAB1,IGLAB2_^1_$COMMON /A/ ICOMT(12),ICOMTS,ICOMX2,ICOMTL,ISUBP,NDPRS,_^1_#$LABX,IBCDTB(48)_^1_$EQUIVALENCE(ICOMB,ICOMT(1)),(ICOMBX,ICOMT(2)),(ICOMDF,_^1_#$ICOMT(3)),(ICOMBN,ICOMT(4))_^1_$DIMENSION ICOMB(6),ICOMBX(6),ICO€€MDF(6),ICOMBN(7)_^1_$COMMON /A/ LOOPTS,LOOPTX,LOOPTB,LOOPT(50)_^1_$EQUIVALENCE(LINDUC,LOOPT(1))_^1_$DIMENSION LINDUC(10)_^1_$EQUIVALENCE (LBEG,LOOPT(2))_^1_$DIMENSION LBEG(10)_^1_$EQUIVALENCE (LINC,LOOPT(3))_^1_$DIMENSION LINC(10)_^1_$EQUIVALENCE (LEND,LOOPT(4))_^1_$DIMENSION LEND(10)_^1_$BYTE(LLABL,LOOPT(5)(14=0)_))_^1_$DIMENSION LLABL(10)_^1_$BYTE(LID,LOOPT(5)(15=15) )_^1_$DIME€€NSION LID(10)_^1_$COMMON /A/ IEQV(255),IEQVS,IEQVN2_^1_$COMMON /A/ ISTAB(150),ISTABS,ISTAB2_^1_$COMMON /A/ IBUFS,ISET(25),LBLANK,KSFCNT,KSNCNT,ISORSC,_^1_#$IHOBIT,ISTNO,ISSFLG,ISUBPN,ITERM,JSORSC,KEQVS_^1C_]_^1C_#SYMBOL TABLE LABELED COMMON BLOCK_^1_$COMMON /A/ ISYMN, ISYMFL,ISYMD,ISYMX,ISYMS,ISYMP,ISYMPC,ISYMPS,_^1_#$ ISYMNS, SYMTAB(960)_^1_$INTEGER SYMTAB_^1_$BYTE (IDUM,SYMTAB(1)€€(15=15)),(KDUMY,SYMTAB(1)(15=15)),_^1_#$(ICLASS,SYMTAB(1)(14=11)),(ITYPE,SYMTAB(1)(10=9))_^1_$DIMENSION IDUM(100),KDUMY(100),ICLASS(100),ITYPE(100)_^1_$BYTE (ISNGL, SYMTAB(1)(8=8)),(KELSIZ,SYMTAB(1)(8=8)),_^1_#$ (ICOM,SYMTAB(1)(7=5)),(IPART,SYMTAB(1)(4=3))_^1_$DIMENSION ISNGL(100),KELSIZ(100),ICOM(100),IPART(100)_^1_$BYTE (KRFCNT,SYMTAB(1)(2=2)),(IDIM,SYMTAB(1)(1=0)),_^1_#$ (IREL,S€€YMTAB(1)(1=1)),(IEXT,SYMTAB(1)(0=0))_^1_$DIMENSION KRFCNT(100),IDIM(100),IREL(100),IEXT(100)_^1_$EQUIVALENCE (IRSA,SYMTAB(2)),(ICOMTX,SYMTAB(2)),(ISNOL,SYMTAB(2))_^1_$DIMENSION IRSA(100), ICOMTX(100),ISNOL(100)_^1_$BYTE (IDATAS,SYMTAB(3)(15=15)),(IREF,SYMTAB(3)(15=15)),_^1_#$ (IEQVX,SYMTAB(3)(14=8)),(ITILF,SYMTAB(3)(14=8))_^1_$DIMENSION IDATAS(100),IREF(100),IEQVX(100),ITILF(100)_^€€1_$BYTE (IPARTR,SYMTAB(3)(7=4)),(INDUCV,SYMTAB(3)(7=7)),(ISFARG,_^1_#$ SYMTAB(3)(6=6)),(IARGNO,SYMTAB(3)(5=0)),(IPARTL,SYMTAB(3)(3=0))_^1_$DIMENSION IPARTR(100),INDUCV(100),ISFARG(100),IARGNO(100),_^1_#$ IPARTL(100)_^1_$EQUIVALENCE (ISYM,SYMTAB(4))_^1_$DIMENSION ISYM(100)_^1C_]_^1C_#SPECIFICATION-TABLE INDEX LABELLED COMMON BLOCK_^1_$COMMON /A/ ISTABX(96)_^1C_]_^1C_#PHASE 4 LABELED€€ COMMON BLOCK._^1_$COMMON /A/ INDTAB(18),INFTB(18)_^1_#2,NBSS ,NADC ,NCON ,NEND ,NPST ,NSTN ,NJMP ,NRTJ ,NLDA_^1_#3,NLDQ ,NSTA ,NSTQ ,NRAO ,NADD ,NSUB ,NAND ,NDVI ,NADQ_^1_#4,NENA ,NINA ,NENQ ,NINQ ,NLRS ,NLLS ,NQRS ,NQLS ,NARS_^1_#5,NALS ,NAJLGZ,NAJEZ ,NAJLZ ,NAJGEZ,NAJLEZ,NAJGZ ,NQJEZ ,NMUI_^1_$COMMON/A/_^1_#1 NFCM ,NFSB ,NFMU ,NFDV ,NFLD ,NFST ,NFA€€D ,NCAQA_^1_#2,NTCQA ,NTRAQ ,KLDQ ,KSTQ ,NTCAA ,NEOR ,NTCQQ_^1_#3,INFTBL,INFTBN,INFTBX_^1_$DIMENSION KODNAM(18), KFTYPE(6),NLINE(6),NPMTRS(6),KSPTAB(14)_^1_$EQUIVALENCE (INFTB(1),KODNAM(1)),(ISET(11),KSPTAB(1))_^1_$BYTE (KFTYPE,INFTB(3)(15=14)),(NLINE,INFTB(3)(13=13)),_^1_#$ (NPMTRS,INFTB(3)(12=0))_^1C_]_^1C_#PHASE 4 BLANK COMMON BLOCK._^1_$COMMON//JSYM(3),_^1C ****************€€****************** FTN 3.1 **************************_^1_#1 INBUFF(304),OUTBUF(10),KART(2,3,3),KQ(5),KFCET(5,3),_^1C ********************************** FTN 3.1 ($) **********************_^1_#2 KSUBAT(240),KSFAT(12,2),KLLTB(10,2),LPTYP(10),_^1_#3 INTRAS(304),IMOD(30),NDTYP(30),NBRNS(30),ICBRN(30),_^1_#4 KOP(30),KTRUT(30)_^1_$DIMENSION KFALS(30),KFATH(30),KOMPSW(30),KSBPTR(30),KRES€€W(30)_^1_$EQUIVALENCE (KFALS(1),ISTAB(1)),(KFATH(1),ISTAB(31)),_^1_#1 (KOMPSW(1),ISTAB(61)),(KSBPTR(1),ISTAB(91)),(KRESW(1),ISTAB(121))_^1_$COMMON// LTYP,MBEGIN_^1_#1,IADDIT,INTRAX,IPTR,ISBSCP,JXX,KBEGIN,KBIAS,KBYTX,KENTER,KENTRY_^1_#2,KEXEC,KEXTYP,KFCSW,KFFSAV,KFINDX,KFLAM,KINTYP,KLLTBX,KNTROL_^1_#3,KOBX,KPRNAM,KQSAV,KRETRN,KSFNAM,KTCATX,LEVEL,LIFTX,LOGIF,KFCETX_^1_$DIMENSION NINV€€S(30),NINENC(30),NPASS(30)_^1_$EQUIVALENCE (KTRUT(1),NINVS(1)),(KFALS(1),NINENC(1))_^1_#1,(KFATH(1),NPASS(1))_^1_$INTEGER OUTBUF_^1C_]_^1C_]_^1C_'SUBROUTINE TO LOCATE ALL PROGRAMMER-DEFINED_^1C_'VARIABLES, CONSTANTS AND ARRAYS AT THE TOP_^1C_'OF THE ROUTINE, PLUS OTHER MISCELLANEOUS_^1C_'HOUSEKEEPING._^1C_'** HYPERFUNCTIONAL EQUIVALENCE AND_^1C_*LEFTOVER ELEMENT NOMENCLATOR**_^1_$E€€QUIVALENCE (IEQVV(1),IEQV(1)),(IEQINC(1),IEQV(2))_^1_$DIMENSION IEQVV(100),IEQINC(100)_^1C_]_^1C_'INITIALIZE LOOP THROUGH SYMBOL TABLE._^1_$ISYMX=0_^1_$ISYMP=0_^1C_]_^1C_'REFERENCE SYMTAB ENTRY_^1_$GO TO 999_^1C_]_^1C_'SET USE COUNT TO ZERO_^1 888 KRFCNT(ISYMX)=0_^1C_]_^1C_'COMPUTE COMBINED SYMTAB POINTER_^1_$LSYMIX=ISYMX+ISYMP_^1C_]_^1C_'IS THIS ENTRY A VARIABLE_^1_$IF(ICLASS(ISY€€MX).EQ.1) GO TO 10_^1C_]_^1C_'NO, IS THIS A CONSTANT_^1_$IF(ICLASS(ISYMX).EQ.2) GO TO 11_^1C_]_^1C_'NO, IS IREL SET_^1_$IF(IREL(ISYMX).NE.0) IEXT(ISYMX)=1_^1C_]_^1C_]_^1_$IF(ICLASS(ISYMX).EQ.6)_#GO TO 69_^1_$IF(ICLASS(ISYMX).NE.5) GO TO 999_^1_$IF(IEXT(ISYMX).NE.0) GO TO 999_^1C_]_^1C_'LOOKUP ROUTINE IN INTRINSIC FUNCTION TABLE_^1_$INFTBX=1_^1_!68 IF(INFTBX.NE.INFTBN) GO TO 66_^1_!€€69 IEXT(ISYMX)=1_^1_$GO TO 999_^1C_]_^1C_'COMPARE NAMES_^1_!66 KOM1=ISYM(ISYMX)_^1_$KOM2=ISYM(ISYMX+1)_^1_$IF (KOM1 .EQ. KODNAM(INFTBX) .AND._^1_#1 KOM2 .EQ. KODNAM(INFTBX+1)) GO TO 67_^1C_]_^1C_'INCREMENT TO NEXT TABLE ENTRY_^1_$INFTBX=INFTBX+INFTBL_^1_$GO TO 68_^1C_]_^1C_'ARE THE TYPES THE SAME_^1_!67 IF(KFTYPE(INFTBX).NE.ITYPE(ISYMX)) GO TO 69_^1C_]_^1C_'YES, ARE THE NUMBER OF €€PARAMETERS THE SAME_^1_$IF(NPMTRS(INFTBX)+1.NE.IARGNO(ISYMX)) GO TO 69_^1C_]_^1C_'SET ICLASS TO IN-LINE FUNCTION_^1_$ICLASS(ISYMX)=3_^1C_'SET ITILF AS PER INDEX TO FUNCTION_^1_$ITILF(ISYMX)=INFTBX/INFTBL+1_^1_$GO TO 999_^1C_]_^1_!11 CALL LABKPC(LSYMIX)_^1_$CALL KPC3PR(INDTAB(5),NCON,LSYMIX)_^1_$GO TO 999_^1C_]_^1C_]_^1C_]_^1C_'ENTRY IS A VARIABLE._^1C_'IS VARIABLE IN EQUIVALENCE CH€€AIN._^1_!10 INDX3=IEQVX(ISYMX)_^1_$IF(INDX3.NE.0) GO TO 20_^1C_]_^1C_'IS VARIABLE IN COMMON BLOCK_^1_$IF(ICOM(ISYMX).NE.0) GO TO 40_^1C_'NO, COMPUTE ELEMENT/ARRAY SIZE_^1_$CALL ARAYSZ(NWDS)_^1C_'IF WE ARE WORKING WITH DUMMY PARAMETERS, DO NOT OUTPUT_^1C_'LABELS OR BSS PSEUDO CODE._^1_$IF(IDUM(ISYMX).NE.0) GO TO 40_^1C_'GENERATE_#LABEL ARRAY_^1C_4BSS_!ARRAY SIZE_^1_$CALL LABKPC(LSYM€€IX)_^1_$CALL KPC3PR(INDTAB(2),NBSS,NWDS)_^1_!40 CONTINUE_^1_$GO TO 999_^1C_]_^1C_'VARIABLE IN EQUIVALENCE CHAIN_^1C_'HAS EQUIVALENCE CHAIN BEEN PROCESSED. YES-GO TO NEXT ENTRY_^1_!20 IF(IEQINC(INDX3).EQ.1) GO TO 999_^1C_]_^1C_'NO, PROCESS EQUIVALENCE CHAIN_^1C_'SAVE ISYMX,ISYMP_^1_$IXHOLD=ISYMX_^1_$IPHOLD=ISYMP_^1C_]_^1C_'MARK EQUIVALENCE CHAIN PROCESSED, AND INITIALIZE_^1_$IEQINC(€€INDX3)=1_^1C_]_^1_$IEQSIZ=0_^1_$KTOT=0_^1C_]_^1C_'SET UP ISYMX FOR NEXT ELEMENT IN CHAIN_^1_!35 ISYMX=IEQVV(INDX3)_^1_$CALL GETSYM_^1_$CALL ARAYSZ(NWDS)_^1C_'COMPUTE CANDIDATE FOR EXTENDED ARRAY LENGTH_^1_$INCRM=IEQINC(INDX3)-1_^1_$ITSSIZ=NWDS+INCRM_^1C_]_^1C_'TAKE THE LARGEST_^1_$IF(ITSSIZ.GT.IEQSIZ) IEQSIZ=ITSSIZ_^1C_]_^1C_'COMPUTE BSS LENGTH_^1_$LBSS=INCRM-KTOT_^1_$IF(LBSS.EQ.0)€€ GO TO 25_^1C_'IF WE ARE WORKING WITH DUMMY PARAMETERS, DO NOT OUTPUT_^1C_'LABELS OR BSS PSEUDO CODE._^1_$IF(IDUM(ISYMX).NE.0) GO TO 50_^1_$CALL KPC3PR(INDTAB(2),NBSS,LBSS)_^1_!50 CONTINUE_^1_!25 CONTINUE_^1C_]_^1C_'RESET TOTAL CURRENT LENGTH_^1_$KTOT=INCRM_^1C_]_^1C_'IF WE ARE WORKING WITH DUMMY PARAMETERS, DO NOT OUTPUT_^1C_'LABELS OR BSS PSEUDO CODE._^1_$IF(IDUM(ISYMX).NE.0) GO €€TO 45_^1C_'GENERATE LABEL_^1_$CALL LABKPC(IEQVV(INDX3))_^1_!45 CONTINUE_^1C_]_^1C_'UPDATE TO NEXT EQUIVALENCE ELEMENT_^1_$INDX3=INDX3+2_^1C_'WAS THAT THE LAST ONE, NO-CONTINUE PROCESSING._^1_$IF(IEQV(INDX3)+1.NE.0) GO TO 35_^1C_]_^1C_'YES, OUTPUT FINAL BSS_^1_$IF(IDUM(ISYMX).NE.0)GO TO 55_^1_$CALL KPC3PR(INDTAB(2),NBSS,IEQSIZ-KTOT)_^1_!55 CONTINUE_^1C_'RESTORE ISYMX,ISYMP_^1C_]_^1€p_$ISYMX=IXHOLD+IPHOLD_^1_$CALL GETSYM_^1 999 CALL SYMSCN_^1_$IF(ISYMP.EQ.1) RETURN_^1_$GO TO 888_^1_$END_]_^__ pPWXRST CSY/ 19B P€1_$SUBROUTINE INXRST_^1_#*_2/DECK-ID 19B FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^13_]_^1C INXRST IS USED IN PHASE B1_^1C_]_^1C_#MASTER LABELED COMMON BLOCK._^1*_] FTN 3.3_^1_$COMMON /A/ IFLAGS,LINECT,LINCT1_^1_$COMMON /A/ IR,IK,IP,IA,IL,IM,IXLGO,I€€OPTO,IOPTV,IOPTC,IOPTD_^1_$COMMON /A/ MCSTRT,MACRNB,MACSEC_^1_$COMMON /A/ IERRS(16),ISRFAD_^1_$COMMON /A/ LGO,ISCRI,ISCRO,IX_^1*_] FTN 3.3_^1_$COMMON /A/ IGLAB(3),IGLAB1,IGLAB2_^1_$COMMON /A/ ICOMT(12),ICOMTS,ICOMX2,ICOMTL,ISUBP,NDPRS,_^1_#$LABX,IBCDTB(48)_^1_$EQUIVALENCE(ICOMB,ICOMT(1)),(ICOMBX,ICOMT(2)),(ICOMDF,_^1_#$ICOMT(3)),(ICOMBN,ICOMT(4))_^1_$DIMENSION ICOMB(6),ICOMBX(6),I€€COMDF(6),ICOMBN(7)_^1_$COMMON /A/ LOOPTS,LOOPTX,LOOPTB,LOOPT(50)_^1_$EQUIVALENCE(LINDUC,LOOPT(1))_^1_$DIMENSION LINDUC(10)_^1_$EQUIVALENCE (LBEG,LOOPT(2))_^1_$DIMENSION LBEG(10)_^1_$EQUIVALENCE (LINC,LOOPT(3))_^1_$DIMENSION LINC(10)_^1_$EQUIVALENCE (LEND,LOOPT(4))_^1_$DIMENSION LEND(10)_^1_$BYTE(LLABL,LOOPT(5)(14=0)_))_^1_$DIMENSION LLABL(10)_^1_$BYTE(LID,LOOPT(5)(15=15) )_^1_$DI€€MENSION LID(10)_^1_$COMMON /A/ IEQV(255),IEQVS,IEQVN2_^1_$COMMON /A/ ISTAB(150),ISTABS,ISTAB2_^1_$COMMON /A/ IBUFS,ISET(25),LBLANK,KSFCNT,KSNCNT,ISORSC,_^1_#$IHOBIT,ISTNO,ISSFLG,ISUBPN,ITERM,JSORSC,KEQVS_^1C_]_^1C_#SYMBOL TABLE LABELED COMMON BLOCK_^1_$COMMON /A/ ISYMN, ISYMFL,ISYMD,ISYMX,ISYMS,ISYMP,ISYMPC,ISYMPS,_^1_#$ ISYMNS, SYMTAB(960)_^1_$INTEGER SYMTAB_^1_$BYTE (IDUM,SYMTAB(€€1)(15=15)),(KDUMY,SYMTAB(1)(15=15)),_^1_#$(ICLASS,SYMTAB(1)(14=11)),(ITYPE,SYMTAB(1)(10=9))_^1_$DIMENSION IDUM(100),KDUMY(100),ICLASS(100),ITYPE(100)_^1_$BYTE (ISNGL, SYMTAB(1)(8=8)),(KELSIZ,SYMTAB(1)(8=8)),_^1_#$ (ICOM,SYMTAB(1)(7=5)),(IPART,SYMTAB(1)(4=3))_^1_$DIMENSION ISNGL(100),KELSIZ(100),ICOM(100),IPART(100)_^1_$BYTE (KRFCNT,SYMTAB(1)(2=2)),(IDIM,SYMTAB(1)(1=0)),_^1_#$ (IREL€€,SYMTAB(1)(1=1)),(IEXT,SYMTAB(1)(0=0))_^1_$DIMENSION KRFCNT(100),IDIM(100),IREL(100),IEXT(100)_^1_$EQUIVALENCE (IRSA,SYMTAB(2)),(ICOMTX,SYMTAB(2)),(ISNOL,SYMTAB(2))_^1_$DIMENSION IRSA(100), ICOMTX(100),ISNOL(100)_^1_$BYTE (IDATAS,SYMTAB(3)(15=15)),(IREF,SYMTAB(3)(15=15)),_^1_#$ (IEQVX,SYMTAB(3)(14=8)),(ITILF,SYMTAB(3)(14=8))_^1_$DIMENSION IDATAS(100),IREF(100),IEQVX(100),ITILF(100)€€_^1_$BYTE (IPARTR,SYMTAB(3)(7=4)),(INDUCV,SYMTAB(3)(7=7)),(ISFARG,_^1_#$ SYMTAB(3)(6=6)),(IARGNO,SYMTAB(3)(5=0)),(IPARTL,SYMTAB(3)(3=0))_^1_$DIMENSION IPARTR(100),INDUCV(100),ISFARG(100),IARGNO(100),_^1_#$ IPARTL(100)_^1_$EQUIVALENCE (ISYM,SYMTAB(4))_^1_$DIMENSION ISYM(100)_^1C_]_^1C_#SPECIFICATION-TABLE INDEX LABELLED COMMON BLOCK_^1_$COMMON /A/ ISTABX(96)_^1C_]_^1C_#PHASE 4 LABEL€€ED COMMON BLOCK._^1_$COMMON /A/ INDTAB(18),INFTB(18)_^1_#2,NBSS ,NADC ,NCON ,NEND ,NPST ,NSTN ,NJMP ,NRTJ ,NLDA_^1_#3,NLDQ ,NSTA ,NSTQ ,NRAO ,NADD ,NSUB ,NAND ,NDVI ,NADQ_^1_#4,NENA ,NINA ,NENQ ,NINQ ,NLRS ,NLLS ,NQRS ,NQLS ,NARS_^1_#5,NALS ,NAJLGZ,NAJEZ ,NAJLZ ,NAJGEZ,NAJLEZ,NAJGZ ,NQJEZ ,NMUI_^1_$COMMON/A/_^1_#1 NFCM ,NFSB ,NFMU ,NFDV ,NFLD ,NFST ,N€€FAD ,NCAQA_^1_#2,NTCQA ,NTRAQ ,KLDQ ,KSTQ ,NTCAA ,NEOR ,NTCQQ_^1_#3,INFTBL,INFTBN,INFTBX_^1_$DIMENSION KODNAM(18), KFTYPE(6),NLINE(6),NPMTRS(6),KSPTAB(14)_^1_$EQUIVALENCE (INFTB(1),KODNAM(1)),(ISET(11),KSPTAB(1))_^1_$BYTE (KFTYPE,INFTB(3)(15=14)),(NLINE,INFTB(3)(13=13)),_^1_#$ (NPMTRS,INFTB(3)(12=0))_^1C_]_^1C_#PHASE 4 BLANK COMMON BLOCK._^1_$COMMON//JSYM(3),_^1C **************€€******************** FTN 3.1 **************************_^1_#1 INBUFF(304),OUTBUF(10),KART(2,3,3),KQ(5),KFCET(5,3),_^1C ********************************** FTN 3.1 ($) **********************_^1_#2 KSUBAT(240),KSFAT(12,2),KLLTB(10,2),LPTYP(10),_^1_#3 INTRAS(304),IMOD(30),NDTYP(30),NBRNS(30),ICBRN(30),_^1_#4 KOP(30),KTRUT(30)_^1_$DIMENSION KFALS(30),KFATH(30),KOMPSW(30),KSBPTR(30),KR€€ESW(30)_^1_$EQUIVALENCE (KFALS(1),ISTAB(1)),(KFATH(1),ISTAB(31)),_^1_#1 (KOMPSW(1),ISTAB(61)),(KSBPTR(1),ISTAB(91)),(KRESW(1),ISTAB(121))_^1_$COMMON// LTYP,MBEGIN_^1_#1,IADDIT,INTRAX,IPTR,ISBSCP,JXX,KBEGIN,KBIAS,KBYTX,KENTER,KENTRY_^1_#2,KEXEC,KEXTYP,KFCSW,KFFSAV,KFINDX,KFLAM,KINTYP,KLLTBX,KNTROL_^1_#3,KOBX,KPRNAM,KQSAV,KRETRN,KSFNAM,KTCATX,LEVEL,LIFTX,LOGIF,KFCETX_^1_$DIMENSION NI€€NVS(30),NINENC(30),NPASS(30)_^1_$EQUIVALENCE (KTRUT(1),NINVS(1)),(KFALS(1),NINENC(1))_^1_#1,(KFATH(1),NPASS(1))_^1_$INTEGER OUTBUF_^1C_]_^1C_]_^1C_'ROUTINE TO GENERATE CODE TO_^1C_'RESTORE INDEXES Q AND FF_^1C_]_^1C_]_^1C_#* * * * * * * * * * * * *_^1C_]_^1C_]_^1C_'GENERATE_!LDQ_!KFFSAV_^1C_2STQ_!FF_^1C_2LDQ_!QSAV_^1_$CALL KPC3PR( INDTAB(5),KLDQ,KFFSAV)_^1_$CALL KPC3PR(€HINDTAB(10),KSTQ,255)_^1_$CALL KPC3PR(INDTAB(5),NLDQ,KQSAV)_^1_$END_]_^__HPWNOPR CSY/ 20B P€1_$SUBROUTINE NOPROC_^1_#*_2/DECK-ID 20B FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^13_]_^1C NOPROC IS USED IN PHASE B1_^1C_]_^1C_#MASTER LABELED COMMON BLOCK._^1*_] FTN 3.3_^1_$COMMON /A/ IFLAGS,LINECT,LINCT1_^1_$COMMON /A/ IR,IK,IP,IA,IL,IM,IXLGO,I€€OPTO,IOPTV,IOPTC,IOPTD_^1_$COMMON /A/ MCSTRT,MACRNB,MACSEC_^1_$COMMON /A/ IERRS(16),ISRFAD_^1_$COMMON /A/ LGO,ISCRI,ISCRO,IX_^1*_] FTN 3.3_^1_$COMMON /A/ IGLAB(3),IGLAB1,IGLAB2_^1_$COMMON /A/ ICOMT(12),ICOMTS,ICOMX2,ICOMTL,ISUBP,NDPRS,_^1_#$LABX,IBCDTB(48)_^1_$EQUIVALENCE(ICOMB,ICOMT(1)),(ICOMBX,ICOMT(2)),(ICOMDF,_^1_#$ICOMT(3)),(ICOMBN,ICOMT(4))_^1_$DIMENSION ICOMB(6),ICOMBX(6),I€€COMDF(6),ICOMBN(7)_^1_$COMMON /A/ LOOPTS,LOOPTX,LOOPTB,LOOPT(50)_^1_$EQUIVALENCE(LINDUC,LOOPT(1))_^1_$DIMENSION LINDUC(10)_^1_$EQUIVALENCE (LBEG,LOOPT(2))_^1_$DIMENSION LBEG(10)_^1_$EQUIVALENCE (LINC,LOOPT(3))_^1_$DIMENSION LINC(10)_^1_$EQUIVALENCE (LEND,LOOPT(4))_^1_$DIMENSION LEND(10)_^1_$BYTE(LLABL,LOOPT(5)(14=0)_))_^1_$DIMENSION LLABL(10)_^1_$BYTE(LID,LOOPT(5)(15=15) )_^1_$DI€€MENSION LID(10)_^1_$COMMON /A/ IEQV(255),IEQVS,IEQVN2_^1_$COMMON /A/ ISTAB(150),ISTABS,ISTAB2_^1_$COMMON /A/ IBUFS,ISET(25),LBLANK,KSFCNT,KSNCNT,ISORSC,_^1_#$IHOBIT,ISTNO,ISSFLG,ISUBPN,ITERM,JSORSC,KEQVS_^1C_]_^1C_#SYMBOL TABLE LABELED COMMON BLOCK_^1_$COMMON /A/ ISYMN, ISYMFL,ISYMD,ISYMX,ISYMS,ISYMP,ISYMPC,ISYMPS,_^1_#$ ISYMNS, SYMTAB(960)_^1_$INTEGER SYMTAB_^1_$BYTE (IDUM,SYMTAB(€€1)(15=15)),(KDUMY,SYMTAB(1)(15=15)),_^1_#$(ICLASS,SYMTAB(1)(14=11)),(ITYPE,SYMTAB(1)(10=9))_^1_$DIMENSION IDUM(100),KDUMY(100),ICLASS(100),ITYPE(100)_^1_$BYTE (ISNGL, SYMTAB(1)(8=8)),(KELSIZ,SYMTAB(1)(8=8)),_^1_#$ (ICOM,SYMTAB(1)(7=5)),(IPART,SYMTAB(1)(4=3))_^1_$DIMENSION ISNGL(100),KELSIZ(100),ICOM(100),IPART(100)_^1_$BYTE (KRFCNT,SYMTAB(1)(2=2)),(IDIM,SYMTAB(1)(1=0)),_^1_#$ (IREL€€,SYMTAB(1)(1=1)),(IEXT,SYMTAB(1)(0=0))_^1_$DIMENSION KRFCNT(100),IDIM(100),IREL(100),IEXT(100)_^1_$EQUIVALENCE (IRSA,SYMTAB(2)),(ICOMTX,SYMTAB(2)),(ISNOL,SYMTAB(2))_^1_$DIMENSION IRSA(100), ICOMTX(100),ISNOL(100)_^1_$BYTE (IDATAS,SYMTAB(3)(15=15)),(IREF,SYMTAB(3)(15=15)),_^1_#$ (IEQVX,SYMTAB(3)(14=8)),(ITILF,SYMTAB(3)(14=8))_^1_$DIMENSION IDATAS(100),IREF(100),IEQVX(100),ITILF(100)€€_^1_$BYTE (IPARTR,SYMTAB(3)(7=4)),(INDUCV,SYMTAB(3)(7=7)),(ISFARG,_^1_#$ SYMTAB(3)(6=6)),(IARGNO,SYMTAB(3)(5=0)),(IPARTL,SYMTAB(3)(3=0))_^1_$DIMENSION IPARTR(100),INDUCV(100),ISFARG(100),IARGNO(100),_^1_#$ IPARTL(100)_^1_$EQUIVALENCE (ISYM,SYMTAB(4))_^1_$DIMENSION ISYM(100)_^1C_]_^1C_#SPECIFICATION-TABLE INDEX LABELLED COMMON BLOCK_^1_$COMMON /A/ ISTABX(96)_^1C_]_^1C_#PHASE 4 LABEL€€ED COMMON BLOCK._^1_$COMMON /A/ INDTAB(18),INFTB(18)_^1_#2,NBSS ,NADC ,NCON ,NEND ,NPST ,NSTN ,NJMP ,NRTJ ,NLDA_^1_#3,NLDQ ,NSTA ,NSTQ ,NRAO ,NADD ,NSUB ,NAND ,NDVI ,NADQ_^1_#4,NENA ,NINA ,NENQ ,NINQ ,NLRS ,NLLS ,NQRS ,NQLS ,NARS_^1_#5,NALS ,NAJLGZ,NAJEZ ,NAJLZ ,NAJGEZ,NAJLEZ,NAJGZ ,NQJEZ ,NMUI_^1_$COMMON/A/_^1_#1 NFCM ,NFSB ,NFMU ,NFDV ,NFLD ,NFST ,N€€FAD ,NCAQA_^1_#2,NTCQA ,NTRAQ ,KLDQ ,KSTQ ,NTCAA ,NEOR ,NTCQQ_^1_#3,INFTBL,INFTBN,INFTBX_^1_$DIMENSION KODNAM(18), KFTYPE(6),NLINE(6),NPMTRS(6),KSPTAB(14)_^1_$EQUIVALENCE (INFTB(1),KODNAM(1)),(ISET(11),KSPTAB(1))_^1_$BYTE (KFTYPE,INFTB(3)(15=14)),(NLINE,INFTB(3)(13=13)),_^1_#$ (NPMTRS,INFTB(3)(12=0))_^1C_]_^1C_#PHASE 4 BLANK COMMON BLOCK._^1_$COMMON//JSYM(3),_^1C **************€€******************** FTN 3.1 **************************_^1_#1 INBUFF(304),OUTBUF(10),KART(2,3,3),KQ(5),KFCET(5,3),_^1C ********************************** FTN 3.1 ($) **********************_^1_#2 KSUBAT(240),KSFAT(12,2),KLLTB(10,2),LPTYP(10),_^1_#3 INTRAS(304),IMOD(30),NDTYP(30),NBRNS(30),ICBRN(30),_^1_#4 KOP(30),KTRUT(30)_^1_$DIMENSION KFALS(30),KFATH(30),KOMPSW(30),KSBPTR(30),KR€€ESW(30)_^1_$EQUIVALENCE (KFALS(1),ISTAB(1)),(KFATH(1),ISTAB(31)),_^1_#1 (KOMPSW(1),ISTAB(61)),(KSBPTR(1),ISTAB(91)),(KRESW(1),ISTAB(121))_^1_$COMMON// LTYP,MBEGIN_^1_#1,IADDIT,INTRAX,IPTR,ISBSCP,JXX,KBEGIN,KBIAS,KBYTX,KENTER,KENTRY_^1_#2,KEXEC,KEXTYP,KFCSW,KFFSAV,KFINDX,KFLAM,KINTYP,KLLTBX,KNTROL_^1_#3,KOBX,KPRNAM,KQSAV,KRETRN,KSFNAM,KTCATX,LEVEL,LIFTX,LOGIF,KFCETX_^1C*************€€*********************************************4.0/75*1761_^1_$COMMON // KSTYP,KRTNS,IDMM(5),INDX,IMFT_^1C************************************************************* 77*1897_^1_$DIMENSION NINVS(30),NINENC(30),NPASS(30)_^1_$EQUIVALENCE (KTRUT(1),NINVS(1)),(KFALS(1),NINENC(1))_^1_#1,(KFATH(1),NPASS(1))_^1_$INTEGER OUTBUF_^1C_]_^1C_]_^1C_'SPECIAL SUBROUTINE TO COPY OUT RECORD_^1C_'REA€€D IN FOR THOSE STATEMENTS ON WHICH_^1C_'NO PROCESSING IS PERFORMED. STRAIGHTFORWARD,_^1C_'EXCEPT FOR FORMAT STATEMENT WHERE EXACT POS-_^1C_'ITION MUST BE KNOWN AND JUMP AROUND FORMAT_^1C_'DATA MAY NEED TO BE ADDED._^1C_]_^1C_'IS THIS A FORMAT STATEMENT, IF NOT, JUST COPY._^1_$IF(INBUFF(3).NE.17) GO TO 100_^1C_'YES, SET LABEL HOLDER TO 0._^1_$IJAF=0_^1C_'WAS THE LAST GENERATED PSEUD€€O INSTRUCTION AN_^1C_'UNCONDITIONAL JUMP._^1_$IF(KQ(2).EQ.NJMP) GO TO 100_^1C**********************************************************4.0/75*1761_^1C_#THIS CODE CHECKS FOR MULTIPLE JUMPS AROUND CONSECUTIVE_^1C_#FORMAT STATEMENTS PRECEDING AN END CARD AND AFTER A STOP_^1C_#OR STOP N. THE JUMPS WILL OCCUR IF THE STOP OR STOP N IS_^1C_#PART OF A LOGICAL IF STATEMENT._^1_$IF((INDX.EQ.€€9.OR.INDX.EQ.10).AND.IMFT.EQ.0) GO TO 100_^1C**********************************************************4.0/75*1761_^1C_'NO, GENERATE UNCONDITIONAL JUMP AROUND FORMAT_^1_$CALL LABLER(IJAF)_^1_$CALL KPC3PR(INDTAB(5),NJMP,IJAF)_^1C_'OUTPUT FLAG RECORD WHICH INDICATES NEXT RECORD IS A_^1C_'FORMAT OR DATA RECORD._^1 100 KOBX=2_^1_$CALL KOUTPT_^1C_'WRITE OUT INPUT BUFFER VERBATIM._^1_$C€¾ALL WRITE(ISCRO,0,INBUFF(1),INBUFF(1))_^1C_]_^1C_'WAS THERE A JUMP AROUND GENERATED._^1_$IF(INBUFF(3).NE.17.OR.IJAF.EQ.0)RETURN_^1C_'YES, GENERATE LABEL._^1_$CALL LABKPC (IJAF)_^1_$END_]_^__¾PWPHSEB CSY/ 21B P€1_$SUBROUTINE PHASEB_^1_#-_2/DECK-ID 21B FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^13_]_^1C ********************************** FTN 3.1 **************************_^1C_]_^1C_FPHASEB IS USED IN PHASE B_^1C_]_^1C_FMASTER LABELED COMMON BLOCK_^1C_]_^1*_]€€ FTN 3.3_^1_$COMMON /A/ IFLAGS,LINECT,LINCT1_^1_$COMMON /A/ IR,IK,IP,IA,IL,IM,IXLGO,IOPTO,IOPTV,IOPTC,IOPTD_^1_$COMMON /A/ MCSTRT,MACRNB,MACSEC_^1_$COMMON /A/ IERRS(16),ISRFAD_^1_$COMMON /A/ LGO,ISCRI,ISCRO,IX_^1*_] FTN 3.3_^1_$COMMON /A/ IGLAB(3),IGLAB1,IGLAB2_^1_$COMMON /A/ ICOMT(12),ICOMTS,ICOMX2,ICOMTL,ISUBP,NDPRS_^1_$COMMON /A/ LABX,IBCDTB(48)_^1_$COMMON /A/ LOOPTS,LOOPTX,LO€€OPTB,LOOPT(50)_^1_$COMMON /A/ IEQV(255),IEQVS,IEQVN2_^1_$COMMON /A/ ISTAB(150),ISTABS,ISTAB2_^1_$COMMON /A/ IBUFS,ISET(25),LBLANK,KSFCNT,KSNCNT,ISORSC_^1_$COMMON /A/ IHOBIT,ISTNO,ISSFLG,ISUBPN,ITERM,JSORSC,KEQVS_^1C_]_^1_$EQUIVALENCE (ICOMB,ICOMT(1)), (ICOMBX,ICOMT(2))_^1_$EQUIVALENCE (ICOMDF,ICOMT(3)), (ICOMBN,ICOMT(4))_^1_$EQUIVALENCE (LINDUC,LOOPT(1)), (LBEG,LOOPT(2))_^1_$EQUIVA€€LENCE (LINC,LOOPT(3)), (LEND,LOOPT(4))_^1_$EQUIVALENCE (KFALS,ISTAB(1)), (KFATH,ISTAB(31))_^1_$EQUIVALENCE (KOMPSW,ISTAB(61)), (KSBPTR,ISTAB(91))_^1_$EQUIVALENCE (KRESW,ISTAB(121))_^1_$EQUIVALENCE (KSPTAB,ISET(11))_^1C_]_^1_$BYTE (LLABL,LOOPT(5)(14=0))_^1_$BYTE (LID,LOOPT(5)(15=15))_^1C_]_^1_$DIMENSION ICOMB(6), ICOMBX(6), ICOMDF(6), ICOMBN(7)_^1_$DIMENSION LINDUC(10), LBEG(10), LI€€NC(10), LEND(10)_^1_$DIMENSION LLABL(10), LID(10)_^1_$DIMENSION KFALS(30), KFATH(30), KOMPSW(30), KSBPTR(30), KRESW(30)_^1_$DIMENSION KSPTAB(14)_^1C_]_^1_$EQUIVALENCE (NINENC,KFALS(1)), (NPASS,KFATH(1))_^1_$DIMENSION NINENC(30), NPASS(30)_^1C_]_^1C_FSYMBOL TABLE LABELED COMMON BLOC_^1C_]_^1_$COMMON /A/ ISYMN,ISYMFL,ISYMD,ISYMX,ISYMS,ISYMP,ISYMPC,ISYMPS_^1_$COMMON /A/ ISYMNS,SYMTAB(€€960)_^1C_]_^1_$INTEGER SYMTAB_^1C_]_^1_$EQUIVALENCE (IRSA,SYMTAB(2)), (ICOMTX,SYMTAB(2))_^1_$EQUIVALENCE (ISNOL,SYMTAB(2))_^1_$EQUIVALENCE (ISYM,SYMTAB(4))_^1C_]_^1_$BYTE (IDUM,SYMTAB(1)(15=15)), (KDUMY,SYMTAB(1)(15=15))_^1_$BYTE (ICLASS,SYMTAB(1)(14=11)), (ITYPE,SYMTAB(1)(10=9))_^1_$BYTE (ISNGL,SYMTAB(1)(8=8)), (KELSIZ,SYMTAB(1)(8=8))_^1_$BYTE (ICOM,SYMTAB(1)(7=5)), (IPART,SYMTAB€€(1)(4=3))_^1_$BYTE (KRFCNT,SYMTAB(1)(2=2)), (IDIM,SYMTAB(1)(1=0))_^1_$BYTE (IREL,SYMTAB(1)(1=1)), (IEXT,SYMTAB(1)(0=0))_^1_$BYTE (IDATAS,SYMTAB(3)(15=15)), (IREF,SYMTAB(3)(15=15))_^1_$BYTE (IEQVX,SYMTAB(3)(14=8)), (ITILF,SYMTAB(3)(14=8))_^1_$BYTE (IPARTR,SYMTAB(3)(7=4)), (INDUCV,SYMTAB(3)(7=7))_^1C_]_^1_$DIMENSION IRSA(100), ICOMTX(100), ISNOL(100), ISYM(100)_^1_$DIMENSION IDUM(100€€), KDUMY(100), ICLASS(100), ITYPE(100)_^1_$DIMENSION ISNGL(100), KELSIZ(100), ICOM(100), IPART(100)_^1_$DIMENSION KRFCNT(100), IDIM(100), IREL(100), IEXT(100)_^1_$DIMENSION IDATAS(100), IREF(100), IEQVX(100), ITILF(100)_^1_$DIMENSION IPARTR(100), INDUCV(100)_^1C_]_^1C_FSPECIFICATION-TABLE INDEX LABELD_^1C_FCOMMON BLOCK_^1C_]_^1_$COMMON /A/ ISTABX(96)_^1C_]_^1C_FPHASE 4 LABLED COMMO€€N BLOCK_^1C_]_^1_$COMMON /A/ INDTAB(18),INFTB(18)_^1_$COMMON /A/ NBSS,NADC,NCON,NEND,NPST,NSTN,NJMP,NRTJ,NLDA_^1_$COMMON /A/ NLDQ,NSTA,NSTQ,NRAO,NADD,NSUB,NAND,NDVI,NADQ_^1_$COMMON /A/ NENA,NINA,NENQ,NINQ,NLRS,NLLS,NQRS,NQLS,NARS_^1_$COMMON /A/ NALS,NAJLGZ,NAJEZ,NAJLZ,NAJGEZ,NAJLEZ,NAJGZ,NQJEZ,NMUI_^1_$COMMON /A/ NFCM,NFSB,NFMU,NFDV,NFLD,NFST,NFAD,NCAQA_^1_$COMMON /A/ NTCQA,NTRAQ,K€€LDQ,KSTQ,NTCAA,NEOR,NTCQQ_^1_$COMMON /A/ INFTBL,INFTBN,INFTBX_^1_$COMMON /A/ NDCM,NDSB,NDMU,NDDV,NDLD,NDST,NDAD_^1_$COMMON /A/ IDFLOT,IDSTR1,IDSTR2,IRSTR1,IQ8DFT_^1_$COMMON /A/ IEXD2I,IEXD2F,IEXD2D_^1_$COMMON /A/ IDPFLG_^1*_YBEGIN FTN 3.3_^1_$COMMON /A/ NFLOF,NFIXF,NDFLOF,NDFIXF_^1*_[END FTN 3.3_^1C_]_^1_$EQUIVALENCE (KODNAM,INFTB(1))_^1_$BYTE (KFTYPE,INFTB(3)(15=14)), (NLINE,INFTB€€(3)(13=13))_^1_$BYTE (NPMTRS,INFTB(3)(12=0))_^1_$DIMENSION KODNAM(18), KFTYPE(6), NLINE(6), NPMTRS(6)_^1C_]_^1C_FPHASE 4 BLANK COMMON BLOCK_^1C_]_^1_$COMMON // JSYM(3)_^1_$COMMON // INBUFF(304), OUTBUF(10), KART(2,3,3), KQ(5), KFCET(5,3)_^1_$COMMON // KSUBAT(240), KSFAT(12,2), KLLTB(10,2), LPTYP(10)_^1_$COMMON // INTRAS(304), IMOD(30), NDTYP(30), NBRNS(30), ICBRN(30)_^1_$COMMON // €€KOP(30), KTRUT(30)_^1_$COMMON // LTYP,MBEGIN,IADDIT,INTRAX,IPTR,ISBSCP,JXX,KBEGIN,KBIAS_^1_$COMMON // KBYTX,KENTER,KENTRY,KEXEC,KEXTYP,KFCSW,KFFSAV,KFINDX_^1_$COMMON // KFLAM,KINTYP,KLLTBX,KNTROL,KOBX,KPRNAM,KQSAV,KRETRN_^1_$COMMON // KSFNAM,KTCATX,LEVEL,LIFTX,LOGIF,KFCETX_^1_$COMMON // KSTYP,KRTNS,IDMM(5)_^1C**********************************************************4.0/75*1761_^1_€€$COMMON // INDX,IMFT_^1C**********************************************************4.0/75*1761_^1C_]_^1_$INTEGER OUTBUF_^1_$EQUIVALENCE (NINVS,KTRUT(1))_^1_$DIMENSION NINVS(30)_^1C_]_^1C_FPHASEB LOCAL VARS EQUIVALENCED_^1C_FTO BLANK COMMON_^1C_]_^1_$EQUIVALENCE (INFLAG,IDMM(1)), (JXX2,IDMM(2))_^1_$EQUIVALENCE (I,ITY,IDMM(3)), (KXX,IDMM(4)), (LXX,IDMM(5))_^1._]_^1C_#****************€€**************************************_^1C_#*_S*_^1C_#* LIST INFORMATION._@*_^1C_#*_S*_^1C_#******************************************************_^1C_#* PAGENO - CURRENT PAGE NUMBER_5*_^1C_#* LINECT - MAXIMUM LINE COUNT_6*_^1C_#* LINCT1 - CURRENT LINE COUNT_6*_^1C_#******************************************************_^1C_]_^1C_#***********************************************€€*******_^1C_#*_S*_^1C_#* COMPILE TIME OPTION INDICATORS. (0 = NOT SET)_#*_^1C_#*_S*_^1C_#******************************************************_^1C_#* IR_#- RUN ANYWHERE IND_8*_^1C_#* IK_#- ASA IND_A*_^1C_#* IP_#- PUNCH IND_?*_^1C_#* IA_#- ASSEMBLY LIST IND_7*_^1C_#* IL_#- SOURCE LIST IND_9*_^1C_#* IM_#- 1ST LINE/STATEMENT LIST IND_-*_^1C_#* IXLGO - LOAD AND GO IND_9*_^1C_€€#* LGO_"- START SECTOR FOR LOAD AND GO_,*_^1C_#* ISCRI - INPUT SCRATCH UNIT_6*_^1C_#* ISCRO - OUTPUT SCRATCH UNIT_5*_^1C_#* IX_#- CURRENT INDEX (PHASE 5)_1*_^1C_#******************************************************_^1C_#******************************************************_^1C_#*_S*_^1C_#* GENERATED LABELS._@*_^1C_#*_S*_^1C_#***********************************************€€*******_^1C_#* IGLAB - GENERATED LABEL SKELETON_0*_^1C_#* IGLAB1 - GENERATED LABEL COUNTER 1_/*_^1C_#* IGLAB2 - GENERATED LABEL COUNTER 2_/*_^1C_#******************************************************_^1C_]_^1C_#******************************************************_^1C_#*_S*_^1C_#* SYMBOL TABLE AND ASSOCIATED PARAMETERS._**_^1C_#*_S*_^1C_#*************************************€€*****************_^1C_#* SYMTAB - SYMBOL TABLE (7 WORDS PER ENTRY)_(*_^1C_#* ISYMS - MAXIMUM SYMTAB SIZE_5*_^1C_#* ISYMN - CURRENT SYMTAB SIZE_5*_^1C_#* ISYMFL - SYMTAB ENTRY SIZE_7*_^1C_#* ISYMD - SYMBOL PRESENT IND (0=NOT PRESENT)_%*_^1C_#* ISYMX - SYMTAB INDEX_<*_^1C_#* ISYMP - WORD COUNT FOR PAGING (BASE ISYMPS)_$*_^1C_#* ISYMPC - CURRENT ISYMP_;*_^1C_#* ISYMPS - €€PAGE SIZE_?*_^1C_#******************************************************_^1._]_^1C_#******************************************************_^1C_#*_S*_^1C_#* COMMON BLOCK TABLE AND ASSOCIATED PARAMETERS._#*_^1C_#*_S*_^1C_#******************************************************_^1C_#* ICOMT - COMMON BLOCK TABLE_6*_^1C_#* ICOMTS - MAXIMUM ICOMT SIZE_6*_^1C_#* ICOMX2 - ICOMT INDEX_=€€*_^1C_#* ICOMTL - ICOMT ENTRY SIZE_8*_^1C_#* ISUBP - SUBPROGRAM TYPE BEING COMPILED_**_^1C_#* NDPRS - SUBPROGRAM DUMMY PARAMETER COUNT_(*_^1C_#* LABX_!- ISYMX FOR SUBPROGRAM NAME_/*_^1C_#* IBCDTB - ASCII TO FORTRAN CONVERSION TABLE_'*_^1C_#******************************************************_^1C_#******************************************************_^1C_#*_S*_^1C_#* LOOP€€ STRUCTURE TABLE AND ASSOCIATED PARAMETERS._!*_^1C_#*_S*_^1C_#******************************************************_^1C_#* LOOPTS - MAXIMUM LOOPT SIZE_6*_^1C_#* LOOPTX - LOOPT INDEX_=*_^1C_#* LOOPTB - BEGIN DO ENTRY SIZE IN LOOPT_,*_^1C_#* LOOPT - LOOP TABLE_>*_^1C_#******************************************************_^1C_]_^1C_#*********************************************€€*********_^1C_#*_S*_^1C_#* EQUIVALENCE TABLE AND ASSOCIATED PARAMETERS._$*_^1C_#* PHASE 1 TEMPORARY EQUIVALENCE BUFFERS._+*_^1C_#*_S*_^1C_#******************************************************_^1C_#* IEQV_!- EQUIVALENCE TABLE_7*_^1C_#* IEQVS - MAXIMUM IEQV SIZE_7*_^1C_#* IEQVN2 - IEQV ENTRY SIZE_9*_^1C_#******************************************************_^1C_]_^1C_#******€€************************************************_^1C_#*_S*_^1C_#* SPECIFICATOIN TABLE AND ASSOCIATED PARAMETERS._"*_^1C_#*_S*_^1C_#******************************************************_^1C_#* ISTAB - SPECIFICATION TABLE_5*_^1C_#* ISTABS - MAXIMUM ISTAB SIZE_6*_^1C_#* ISTAB2 - CURRENT ISTAB SIZE_6*_^1C_#******************************************************_^1._]_^1C_#********€€**********************************************_^1C_#*_S*_^1C_#* INDICATOR WORDS AND FLAGS._7*_^1C_#*_S*_^1C_#******************************************************_^1C_#* IBUFS - MAXIMUM IBUF1, IBUF2 AND IWORK SIZE_$*_^1C_#* ISET_!- PRESET SYMTAB TABLE_5*_^1C_#* LBLANK - PRESET BLANK BLANK_^1C_#* KSFCNT - STATEMENT FUNCTION COUNT_0*_^1C_#* KSNCNT -_!*** NOT USED ***_4*_^1C€€_#* ISORSC - INPUT CHARACTERS/WORD COUNT_-*_^1C_#* IHOBIT - HIGH ORDER BIT IN WORD_2*_^1C_#* ISTNO - CURRENT STATEMENT NUMBER_0*_^1C_#* ISSFLG - STATEMENT FUNCTION DUMMY PARAMETER COUNT *_^1C_#* ISUBPN - ISYMX FOR SUBPROGRAM NAME_/*_^1C_#* ITERM -_I*_^1C_#* JSORSC - OUTPUT CHARACTERS/WORD COUNT_,*_^1C_#* KEQVS - MAXIMUM KEQV AND MEQV SIZE_.*_^1C_#************************€€******************************_^1._]_^1C_'PHASEB IS THE CODE GENERATION_^1C_%PORTION OF THE FORTRAN COMPILER._^1C_]_^1C_]_^1_$DATA INDTAB(1),INDTAB(2),INDTAB(3)/$4000,$9,$2002/_^1_$DATA INDTAB(4),INDTAB(5),INDTAB(6)/$411,$1,$15/_^1_$DATA INDTAB(7),INDTAB(8),INDTAB(9)/$801,$D,$1C/_^1_$DATA INDTAB(10),INDTAB(11),INDTAB(12)/$5,$2202,$2602/_^1_$DATA INDTAB(13),INDTAB(14),INDTAB(15)/$30€€03,$809,$2016/_^1_$DATA INDTAB(16),INDTAB(17),INDTAB(18)/$2012,$2012,$200E/_^1_$DATA NBSS,NADC,NCON,NEND,NPST,NJMP,NRTJ/1,2,3,4,5,10,11/_^1_$DATA NLDA,NLDQ,NSTA,NSTQ,NRAO,NADD,NSUB/12,19,14,15,16,17,18/_^1_$DATA NAND,NDVI,NADQ,NSTN,NMUI,NEOR,KLDQ/13,20,21,6,22,23,28/_^1_$DATA KSTQ,NENA,NINA,NENQ,NINQ,NLRS,NLLS/29,30,31,32,33,34,35/_^1_$DATA NQRS,NQLS,NARS,NALS,NAJLGZ,NAJEZ/36,37,38€€,39,40,41/_^1_$DATA NAJLZ,NAJGEZ,NAJLEZ,NAJGZ,NQJEZ/42,43,44,45,47/_^1_$DATA NFCM,NFSB,NFMU,NFDV,NFLD,NFST/52,53,54,55,56,58/_^1_$DATA NFAD,NCAQA,NTCQA,NTRAQ,NTCAA,NTCQQ/59,60,61,62,63,64/_^1_$DATA NDCM,NDSB,NDMU,NDDV,NDLD,NDST,NDAD /72,73,74,75,76,78,79/_^1_$DATA IDFLOT,IDSTR1,IDSTR2,IRSTR1,IQ8DFT /131,136,141,161,166/_^1_$DATA IEXD2I,IEXD2F,IEXD2D /171,176,181/_^1*_YBEGIN FTN 3.3€€_^1_$DATA NFLOF,NFIXF/50,51/_^1_$DATA NDFLOF,NDFIXF/70,71/_^1*_[END FTN 3.3_^1C_]_^1C_]_^1_$DATA KSPTAB(1),KSPTAB(2),KSPTAB(3),KSPTAB(4),KSPTAB(5),KSPTAB(6),_^1_#1 KSPTAB(7),KSPTAB(8),KSPTAB(9),KSPTAB(10),KSPTAB(11),KSPTAB(12),_^1_#2 KSPTAB(13),KSPTAB(14) /6,11,16,21,26,31,36,41,46,51,56,61,66,71/_^1C_]_^1C_]_^1C_'CODED NAME - IABS, INT,IN-LIN,FUN,1-PMTR._^1_$DATA KODNAM( 1),KODNAM€€( 2) /$6C83,$AC4C/_^1_$DATA INFTB( 3)/$6001/_^1C_]_^1C_]_^1C_'CODED NAME - AND, INT,IN-LIN,FUN,2-PMTR._^1_$DATA KODNAM( 4),KODNAM( 5) /$3EF8,$E7B6/_^1_$DATA INFTB( 6)/$6002/_^1C_]_^1C_]_^1C_'CODED NAME - OR,INT,IN-LIN,FUN,2-PMTR_^1_$DATA KODNAM( 7),KODNAM( 8) /$92DB,$E7B6/_^1_$DATA INFTB( 9)/$6002/_^1C_]_^1C_]_^1C_'CODED NAME - EOR,INT,IN-LIN,FUN,2-PMTR_^1_$DATA KODNAM(10),KODNAM(1€€1) /$56F1,$E7B6/_^1_$DATA INFTB(12)/$6002/_^1C_]_^1C_]_^1C_'CODED NAME - NOT,INT,IN-LIN,FUN,1-PMTR_^1_$DATA KODNAM(13),KODNAM(14) /$8C6C,$E7B6/_^1_$DATA INFTB(15)/$6001/_^1C_]_^1C_]_^1C_'CODED NAME - ISIGN,INT,IN-LIN,FUN,2-PMTR_^1_$DATA KODNAM(16),KODNAM(17) /$6F48,$62B7/_^1_$DATA INFTB(18)/$6002/_^1C_]_^1C_]_^1_$DATA INFTBL,INFTBN /3,19/_^1._]_^1C_]_^1C_]_^1C_'INITIALIZATION_^1C_]€€_^1C**********************************************************4.0/75*1761_^1_$IMFT=0_^1C**********************************************************4.0/75*1761_^1_$KTOFLG=0_^1_$KRTNS=0_^1_$KFCSW=0_^1_$NDPRS=0_^1_$KSUBAT(1)=0_^1_$KSFAT(1,1)=0_^1_$LOGIF=0_^1_$INTRAS(1)=0_^1_$LIFTX=0_^1_$KLLTBX=1_^1_$INFLAG=1_^1_$LOOPTX=1_^1_$OUTBUF(3)=49_^1C_]_^1C_]_^1C_'CREATE LABELS, KRETRN (LABEL OF€€ THE RETURN OPERATION)_^1_$CALL LABLER(KRETRN)_^1C_]_^1C_'CREATE AND GENERATE LABEL KTOP(LABEL OF THE FIRST CELL_^1C_'OF THE PROGRAM)_^1_$IF(IR.EQ.0) GO TO 31_^1_$CALL LABLER(KTOP)_^1_$CALL LABKPC (KTOP)_^1_!31 CONTINUE_^1C_]_^1C_'CREATE LABEL MBEGIN (LABEL OF THE FIRST EXECUTABLE INST.)_^1C_>IN THE PROGRAM BODY, EXCLUDING ENTRY_^1C_>CODE.)_^1_$CALL LABLER(MBEGIN)_^1C_'IS THIS A MA€€IN ROUTINE OR BLOCK DATA SUBPROGRAM_^1_$KPRNAM=LABX_^1_$IF(LABX.NE.0) GO TO 5_^1_$IF(ISUBP.GT.1) GO TO 3_^1C_'YES, CREATE PROGRAM NAME_^1C_'GENERATE ENTRY POINT LABEL_^1_$CALL LABLER(KPRNAM)_^1C_'GENERATED NAMES ARE..._^1C_'MAIN PROGRAM - Q8QNAM, BLOCK DATA SUBPROGRAM - Q8QBDS_^1_$ISYM(ISYMX)=$9BCC_^1_$IF(ISUBP.EQ.1) GO TO 92_^1_$ISYM(ISYMX+1)=$8A43_^1_$GO TO 5_^1_!92 ISYM(ISYMX+1€€)=$4372_^1_$GO TO 6_^1_"5 CALL LABKPC(KPRNAM)_^1C_]_^1C_'IF THIS IS A MAIN ROUTINE, GENERATE_!JMP MBEGIN_^1_$IF(ISUBP.NE.0)GO TO 4_^1_$CALL KPC3PR (INDTAB(5),NJMP,MBEGIN)_^1_"3 CONTINUE_^1C_]_^1C_'OUTPUT STORAGE CELLS...VARIABLES,CONSTANTS, ETC..._^1_"4 CALL HELEN_^1C_]_^1C_'CREATE LABELS, KQSAV (LABEL OF STORAGE TO SAVE Q-INDEX)_^1C_6KFFSAV (LABEL OF STORAGE TO SAVE FF-INDEX)_^1€€_"7 CALL LABLER(KQSAV)_^1_$CALL LABLER(KFFSAV)_^1_$KTCATX=0_^1C_]_^1C_'SEE IF ALL STATEMENT FUNCTIONS ARE PROCESSED_^1_$IF(KSFCNT.NE.0) GO TO 8_^1C_'YES, GENERATE LABEL MBEGIN_^1_$CALL LABKPC(MBEGIN)_^1C_'IS THIS A RUN-ANYWHERE PROGRAM._^1_$IF(IR.EQ.0) GO TO 6_^1C_]_^1C_'GENERATE CODE TO COMPUTE ENTRY ADDRESS_^1C_]_^1C_'CREATE LABEL, KBIAS_^1_$CALL LABLER(KBIAS)_^1C_'GENERATE_!RTJ*€€_!BIAS_^1C_2ADC,SR KTOP_^1C_2LABEL BIAS_^1C_2BSS_"1_^1C_2LDA*_!BIAS_^1C_2ADD*_!BIAS-1_^1C_2STA*_!BIAS_^1_$CALL KPC3PR (INDTAB(5),NRTJ,KBIAS)_^1_$CALL KPC3PR (INDTAB(8),NADC,KTOP)_^1_$CALL LABKPC (KBIAS)_^1_$CALL KPC3PR (INDTAB(2),NBSS,1)_^1_$CALL KPC3PR (INDTAB(5),NLDA,KBIAS)_^1_$CALL KPCSTK(INDTAB(3),NADD,KBIAS,-1,0)_^1_$CALL KPC3PR (INDTAB(5),NSTA,KBIAS)_^1C_'TURN OFF INITIAL FL€€AG_^1_"6 INFLAG=0_^1C_'READ IN INPUT RECORD_^1_"8 CALL READIR(1,JXX)_^1C_'CALL APPROPRIATE ROUTINE AS PER STATEMENT TYPE_^1C_]_^1_$I=INBUFF(3)-12_^1_"9 INTRX1=1_^1_!91 IF(INTRAS(INTRX1).EQ.0) GO TO 90_^1_$IF(INTRAS(INTRX1+1).GT.0) CALL TSALOC(INTRAS(INTRX1),4)_^1_$INTRX1=INTRX1+2_^1_$GO TO 91_^1_!90 INTRAX=0_^1_$INTRAS(1)=0_^1C ********************************** FTN 3.1 **********€€****************_^1_$IDPFLG = 0_^1C ********************************** FTN 3.1 ($) **********************_^1C**********************************************************4.0/75*1761_^1C FORMAT STATEMENT FOLLOWING A STOP WHICH WAS PART OF LOGICAL IF_^1C REQUIRES A JUMP AROUND FORMAT CODE - LEAVE IMFT SET_^1_$IF(I.EQ.5.AND.IMFT.EQ.1) GO TO 93_^1C**************************************€€************************* 81*2191_^1_$IF (I.NE.5) INDX = 0_^1C*************************************************************** 81*2191_^1_$IMFT=0_^193_"GO TO (10,14,14,16,16,18,19,20,21,22,10,24,25,26,10,28,28,28,28,_^1C**********************************************************4.0/75*1761_^1_#1 32,10,10,10,10,10,10,10,40,41,42,43,44) , I_^1C_]_^1_!10 KSTYP=INBUFF(3)_^1_$IF(INFLAG.N€€E.0) GO TO 7_^1_$IF(LOGIF.EQ.0) GO TO 8_^1_$IF(INBUFF(4).LT.0) GO TO 8_^1_!11 CALL LABKPC (KFALS(1))_^1_$LOGIF=0_^1_$GO TO 8_^1C_]_^1C_#FUNCTION, SUBROUTINE_^1_!14 CALL SUBFUN_^1_$GO TO 10_^1C_]_^1C_#DATA, FORMAT_^1_!16 CALL NOPROC_^1_$GO TO 10_^1C_]_^1C_#ARITHMETIC REPLACEMENT_^1_!18 CALL ARITHR_^1_$GO TO 10_^1C_]_^1C_#STATEMENT FUNCTION_^1C_'SUBROUTINE TO PROCESS THE STATEMENT FU€€NCTION._^1C_'CREATE LABEL KBEGIN_^1_!19 CALL LABLER(KBEGIN)_^1C_'GENERATE_!LABEL KBEGIN_^1_$CALL LABKPC(KBEGIN)_^1C_'ENTER NAME OF FUNCTION INTO KSFNAM_^1_$KSFNAM=INBUFF(JXX)_^1C_]_^1C_%*INITIALIZE KSFAT WITH PARAMETERS*_^1C_'INITIALIZE KXX TO FIRST PARAMETER_^1_$KXX=JXX+1_^1_$LXX=1_^1C_'ARE THERE ANY MORE PARAMETERS_^1 202 IF(INBUFF(KXX)+1.EQ.0) GO TO 201_^1C_]_^1C_'YES, ENTER N€€EXT PARAMETER INFORMATION_^1C_,1. POINTER TO PARAMETER_^1C_,2. ZERO_^1_$KSFAT(LXX,1)=INBUFF(KXX)_^1_$KSFAT(LXX,2)=0_^1_$LXX=LXX+1_^1_$KXX=KXX+1_^1_$GO TO 202_^1C_]_^1C_'NO MORE FORMAL PARAMETERS_^1C_'INCREASE NDPRS BY THE NUMBER OF PARAMETERS._^1 201 NDPRS=NDPRS+LXX-1_^1_$ISYMX=KSFNAM_^1_$CALL GETSYM_^1_$ITY=ITYPE(ISYMX)_^1C_]_^1C_'CLOSE KSFAT, SET NEXT PARAMETER = 0._^1_$KSFAT(LX€€X,1)=0_^1C_]_^1C_'GENERATE CODE FOR RIGHT SIDE OF EQUATION_^1 203 CALL ASUPER(INBUFF(KXX+3))_^1C ********************************** FTN 3.1 **************************_^1C_]_^1C_FTYPE OF STATEMENT FUNCTION_^1C_]_^1_$IF (ITY.EQ.2) GO TO 206_^1_$IF (ITY.EQ.3) GO TO 210_^1C_]_^1C_FTYPE OF SFUNCTION IS INTEGER_^1C_FIS DEFINITION INTEGER_^1C_]_^1_$IF (KEXTYP.EQ.0) GO TO 222_^1C_]_^1€€C_FNO, GENERATE FLOAT-FIX_^1C_]_^1_$CALL KPC3PR(INDTAB(5),NRTJ,KSPTAB(3))_^1_$GO TO 222_^1C_]_^1C_FTYPE OF SFUNCTION IS REAL_^1C_FCHECK TYPE OF DEFINITION_^1C_]_^1*_YBEGIN FTN 3.3_^1 206 IF(KEXTYP.NE.0) GO TO 222_^1*_[END FTN 3.3_^1C_]_^1C_FDEFINITION IS INTEGER_^1C_FGENERATE FIX-FLOAT_^1C_]_^1_$CALL KPC3PR(INDTAB(5),NRTJ,KSPTAB(2))_^1_$GO TO 222_^1*_$8 CARDS DELETED FTN 3.3_^1C_]€€_^1C_FTYPE OF SFUNCTION IS DOUBLE_^1C_FCHECK TYPE OF DEFINITION_^1C_]_^1*_YBEGIN FTN 3.3_^1 210 IF(KEXTYP.NE.0) GO TO 222_^1*_[END FTN 3.3_^1C_]_^1C_FDEFINITION IS INTEGER_^1C_FGENERATE CALL Q8DFLT_^1C_]_^1_$CALL KPC3PR(INDTAB(5),NRTJ,IQ8DFT)_^1_$GO TO 222_^1C_]_^1*_#5 CARDS DELETED FTN 3.3_^1C ********************************** FTN 3.1 ($) **********************_^1C_]_^1C_'GENER€€ATE CODE TO RESTORE Q AND FF._^1 222 CALL INXRST_^1C_]_^1C_'GENERATE JUMP INDIRECT TO ENTRY POINT_^1_$CALL KPC3PR(INDTAB(7),NJMP,KSFNAM)_^1C_]_^1C_'GENERATE ENTRY POINT NAME_^1_$CALL LABKPC(KSFNAM)_^1C_'GENERATE ENTRY CODE_^1_$KENTER=KSFNAM_^1_$KEXEC=KBEGIN_^1_$CALL ENTCOD_^1C_]_^1C_'DECREMENT STATEMENT FUNCTION COUNT._^1_$KSFCNT=KSFCNT-1_^1_$GO TO 10_^1C_]_^1C_#ASSIGN_^1C_]_^1C_'€€LOOK UP ASSIGN VARIABLE IN SYMBOL TABLE_^1_!20 ISYMX=INBUFF(JXX)_^1_$CALL GETSYM_^1C_'SET K AS PER CONDITION OF COMMON FLAG AND R.A. SWITCH_^1_$K=4_]_^1_$IF(IR.NE.0.AND.ICOM(ISYMX).EQ.0) K=K+2_^1_$CALL KPC3PR (INDTAB(K),NLDA,INBUFF(JXX))_^1_$IF(K.EQ.4) GO TO 2_^1_$CALL KPC3PR (INDTAB(5),NADD,KBIAS)_^1_"2 CALL KPC3PR (INDTAB(5),NSTA,INBUFF(JXX+1))_^1_$GO TO 10_^1C_]_^1C_'CALL STATEM€€ENT PROCESSOR_^1C_'DOES THIS CALL HAVE ANY ARGUMENTS_^1_!21 IF(INBUFF(JXX+3).EQ.23) GO TO 101_^1C_'YES, GIVE IT TO ASUPER_^1_$CALL ASUPER(INBUFF(JXX+3))_^1_$GO TO 10_^1C_]_^1C_'GENERATE_!RTJ (ROUTINE)_^1C PRECEDED BY 'ENA 0' -- (NO PARAMETER)_^1 101 IF(IOPTV_'.NE.0) CALL KPC3PR(INDTAB(10),NENA,0)_^1_$CALL KPC3PR(INDTAB(5),NRTJ,INBUFF(JXX+4))_^1_$GO TO 10_^1C_]_^1C_#RETURN_^1C_'G€€ENERATE_!JMP*_!KRETRN_^1_!22 CALL KPC3PR (INDTAB(5),NJMP,KRETRN)_^1C_'INCREMENT RETURN COUNTER_^1_$KRTNS=KRTNS+1_^1_$GO TO 10_^1C_]_^1C_#NORMAL (UNCONDITIONAL) GO TO (DONE IN-LINE)_^1_!24 CALL KPC3PR (INDTAB(5),NJMP,INBUFF(JXX))_^1_$GO TO 10_^1C_]_^1C_#COMPUTED GO TO_^1_!25 CALL CGOTO_^1_$GO TO 10_^1C_]_^1C_#ASSIGNED GO TO_^126_"ISYMX=INBUFF(JXX)_^1_$K=ISYMX_^1_$CALL GETSYM_^1_$IF€€ (IDUM(ISYMX).EQ.0) GO TO 260_^1_$CALL TSALOC(K,1)_^1_$CALL KPC3PR(INDTAB(5),NLDA,INBUFF(JXX))_^1_$CALL KPC3PR(INDTAB(5),NSTA,K)_^1260_!CALL KPC3PR(INDTAB(7),NJMP,K)_^1_$IF (K.NE.INBUFF(JXX)) CALL TSALOC(K,4)_^1_$GO TO 10_^1C_]_^1C_#STOP, STOP N, PAUSE, PAUSE N_^1_!28 INDX=I-7_^1C**********************************************************4.0/75*1761_^1_$IF(LOGIF.GT.0) IMFT=1_^1C****€€******************************************************4.0/75*1761_^1_$CALL KPC3PR (INDTAB(5),NRTJ,KSPTAB(INDX))_^1_$IF(INDX.EQ.10.OR.INDX.EQ.12)_^1_#1CALL KPC3PR (INDTAB(2),NCON,INBUFF(JXX))_^1_$GO TO 10_^1C_#BEGIN DO_^1_!40 CALL BGINDO_^1_$GO TO 10_^1C_]_^1C_#END DO_^1_!41 CALL BANANA_^1_$GO TO 10_^1C_]_^1C_#ARITHMETIC IF_^1_!42 CALL AFIDL (INBUFF(JXX+6))_^1_$IDTI=0_^1_$IF (INBUFF€€(JXX) .EQ. INBUFF(JXX+1)) GO TO 503_^1_$IF (INBUFF(JXX) .EQ. INBUFF(JXX+2)) GO TO 502_^1_$IF (INBUFF(JXX+1) .NE. INBUFF(JXX+2)) IDTI=1_^1_$IDTI=IDTI+1_^1 502 IDTI=IDTI+1_^1 503 IDTI=IDTI+1_^1C_#IS K1,K2, OR K3 THE STATEMENT LABEL OF THE NEXT STATEMENT_^1_$IDTJ=0_^1_$I=ISTNO+1_^1_$ISYMX=INBUFF(JXX)_^1_$CALL GETSYM_^1_$IF (ISNOL(ISYMX) .EQ.I) GO TO 505_^1_$ISYMX=INBUFF(JXX+1)_^1_$€€CALL GETSYM_^1_$IF (ISNOL(ISYMX) .EQ. I) GO TO 504_^1_$ISYMX=INBUFF(JXX+2)_^1_$CALL GETSYM_^1_$IF (ISNOL(ISYMX) .NE. I) IDTJ=1_^1_$IDTJ=IDTJ+1_^1 504 IDTJ=IDTJ+1_^1 505 IDTJ=IDTJ+1_^1_$GO TO (510,512,515,506),IDTI_^1C_#GENERATE AJP,LZ K1, AJP,ZR K2_^1 506 CALL KPC3PR(INDTAB(5),NAJLZ,INBUFF(JXX))_^1_$CALL KPC3PR(INDTAB(5),NAJEZ,INBUFF(JXX+1))_^1 507 IF (IDTJ.NE.3) CALL KPC3PR(IN€€DTAB(5),NJMP,INBUFF(JXX+2))_^1_$GO TO 10_^1 510 IF (IDTJ.EQ.1) GO TO 511_^1C_#GENERATE AJP,LEZ K1_^1_$CALL KPC3PR(INDTAB(5),NAJLEZ,INBUFF(JXX))_^1_$GO TO 507_^1C_#GENERATE AJP,GZ K3_^1 511 CALL KPC3PR(INDTAB(5),NAJGZ,INBUFF(JXX+2))_^1_$GO TO 10_^1 512 IF (IDTJ.EQ.1) GO TO 514_^1C_#GENERATE AJP,LGZ K1_^1_$CALL KPC3PR(INDTAB(5),NAJLGZ,INBUFF(JXX))_^1C_#MAYBE GENERATE JMP K2_^1 51€€3 IF (IDTJ.NE.2) CALL KPC3PR(INDTAB(5),NJMP,INBUFF(JXX+1))_^1_$GO TO 10_^1C_#GENERATE AJP,EZ K2_^1 514 CALL KPC3PR (INDTAB(5),NAJEZ,INBUFF(JXX+1))_^1_$GO TO 10_^1 515 IF (IDTJ.EQ.1) GO TO 516_^1C_#GENERATE AJP,LZ K1_^1_$CALL KPC3PR (INDTAB(5),NAJLZ,INBUFF(JXX))_^1_$GO TO 513_^1C_#GENERATE AJP,GEZ K3_^1 516 CALL KPC3PR (INDTAB(5),NAJGEZ,INBUFF(JXX+2))_^1 550 GO TO 10_^1C_]_^1C_#€€LOGICAL IF_^1_!43 LIFTX=1_^1_$CALL LABLER(KFALS(LIFTX))_^1C_]_^1C_'*READ NEXT STATEMENT INTO REMAINDER_^1C_'OF BUFFER TO DETERMINE ITS TYPE._^1C_]_^1C_'COMPUTE NEXT AVAILABLE LOCATION IN INPUT BUFFER._^1_$IRST2=INBUFF(1)+1_^1C_'READ_^1_$CALL READIR(IRST2,JXX2)_^1C_'CHECK IF STATEMENT TYPE IS_!1. RETURN_^1C_AOR,2. UNCONDITIONAL GO TO_^1_$I=INBUFF(IRST2+2)_^1_$IF(I.EQ.22.OR.I.EQ.24) €€GO TO 401_^1_$LOGIF=1_^1_$CALL LABLER(KTRUT(LIFTX))_^1_$KFATH(LIFTX)=KTRUT(LIFTX)_^1_$NDTYP(LIFTX)=2_^1 402 I=JXX+3_^1_$NBRNS(LIFTX)=2_^1 412 ICBRN(LIFTX)=1_^1C_#CURRENT NODE_^1 413 IF(INBUFF(I).GT.3) GO TO 422_^1C_#LOGICAL_^1_$LIFTX=LIFTX+1_^1_$IF(LIFTX.GE.18) CALL PUNT_^1_$CALL LABLER(KFATH(LIFTX))_^1_$IF(ICBRN(LIFTX-1).NE.NBRNS(LIFTX-1)) GO TO 418_^1_$KTRUT(LIFTX)=KTRUT(LIFTX€€-1)_^1 420 KFALS(LIFTX)=KFALS(LIFTX-1)_^1 421 NDTYP(LIFTX)=INBUFF(I)_^1_$NBRNS(LIFTX)=INBUFF(I+1)_^1_$KOP(LIFTX)=I_^1_$I=I+INBUFF(I+2)+1_^1_$GO TO 412_^1C_]_^1C_'SET TRUTH ADDRESS AS PER THE RETURN OR GO TO._^1 401 IF(I.EQ.22) KTRUT(LIFTX)=KRETRN_^1_$IF(I.EQ.24) KTRUT(LIFTX)=INBUFF(JXX2)_^1C_'SET FALL-THROUGH ADDRESS SAME AS FALSE ADDRESS._^1_$KFATH(LIFTX)=KFALS(LIFTX)_^1_$LOGIF€€=2_^1_$NDTYP(LIFTX)=3_^1_$GO TO 402_^1C_]_^1 418 IF(NDTYP(LIFTX-1).EQ.3) GO TO 419_^1C_#AND_]_^1_$KTRUT(LIFTX)=KFATH(LIFTX-1)_^1_$GO TO 420_^1C_#OR_]_^1 419 KFALS(LIFTX)=KFATH(LIFTX-1)_^1_$KTRUT(LIFTX)=KTRUT(LIFTX-1)_^1_$GO TO 421_^1C_#FINALLY GO TO A RELATIONAL_^1C_]_^1C_]_^1C_'IF THE RELATIONAL OPERATOR IS .LE. OR .GT. REARRANGE TO_^1C_'MAKE -A+B INTO MORE EFFICIENT EXPRESSION €€B-A_^1 422 IF(INBUFF(I).NE.6.AND.INBUFF(I).NE.7) GO TO 4225_^1_$J=INBUFF(I+7)_^1_$INBUFF(I+7)=INBUFF(I+6)_^1_$INBUFF(I+6)=J_^1 4225 CALL AFIDL (INBUFF(I+4))_^1C_]_^1C_]_^1_$IF(ICBRN(LIFTX).NE.NBRNS(LIFTX))GO TO 423_^1C_#IF PREVIOUS NODE IS OR,JUMP TRUE_^1_$J=LIFTX-1_^1 4222 IF(ICBRN(J).NE.NBRNS(J)) GO TO 4221_^1_$J=J-1_^1_$GO TO 4222_^1 4221 IF(KFALS(LIFTX).EQ.KFATH(J)) GO TO 424_€€^1 4220 KADD=KFALS(LIFTX)_^1C_#WHAT TYPE OF RELATIONAL_^1_$GO TO (428,428,425,425,427,426),INBUFF(I)-4_^1 428 KIT=NAJGEZ_^1 429 CALL KPC3PR(INDTAB(5),KIT,KADD)_^1_$IF(LIFTX.EQ.1) GO TO 450_^1_$IF(ICBRN(LIFTX).NE.NBRNS(LIFTX))GO TO 411_^1 4290 LIFTX=LIFTX-1_^1_$IF(LIFTX.LE.1) GO TO 450_^1C_#OUTPUT LABEL_^1_$CALL LABKPC (KFATH(LIFTX))_^1_$IF(ICBRN(LIFTX).EQ.NBRNS(LIFTX)) GO TO 4290€€_^1_$CALL LABLER(KFATH(LIFTX))_^1 411 I=KOP(LIFTX)_^1_$J=ICBRN (LIFTX)+I+2_^1_$I=I+INBUFF(J)+1_^1_$ICBRN(LIFTX)=ICBRN(LIFTX)+1_^1_$GO TO 413_^1 423 IF(NDTYP(LIFTX).EQ.2)GO TO 4220_^1 424 KADD=KTRUT(LIFTX)_^1C_#WHAT TYPE OF RELATIONAL_^1_$GO TO (425,425,428,428,426,427),INBUFF(I)-4_^1 425 KIT=NAJLZ_^1_$GO TO 429_^1 426 KIT=NAJEZ_^1_$GO TO 429_^1 427 KIT=NAJLGZ_^1_$GO TO 429_^1€ 450 IF(LOGIF.EQ.2) GO TO 11_^1_$JXX=JXX2_^1_$I=INBUFF(1)+3_^1_$INBUFF(3) = INBUFF(I)_^1_$INBUFF(4)=INBUFF(I+1)_^1_$I=INBUFF(I)-12_^1_$CALL LABKPC (KFATH(1))_^1_$GO TO 9_^1C_]_^1C_#ASSEM_^1_!44 CALL ASSEM_^1_$GO TO 10_^1C_#END, EXIT PHASE 3 UPON COMPLETION_^1_!32 CALL END_^1_$END_]_^__ PWRDIR CSY/ 22B P€1_$SUBROUTINE READIR(I,J)_^1_#*_2/DECK-ID 22B FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^13_]_^1C READIR IS USED IN PHASE B1_^1C_]_^1C_#MASTER LABELED COMMON BLOCK._^1*_] FTN 3.3_^1_$COMMON /A/ IFLAGS,LINECT,LINCT1_^1_$COMMON /A/ IR,IK,IP,IA,IL,IM,IX€€LGO,IOPTO,IOPTV,IOPTC,IOPTD_^1_$COMMON /A/ MCSTRT,MACRNB,MACSEC_^1_$COMMON /A/ IERRS(16),ISRFAD_^1_$COMMON /A/ LGO,ISCRI,ISCRO,IX_^1*_] FTN 3.3_^1_$COMMON /A/ IGLAB(3),IGLAB1,IGLAB2_^1_$COMMON /A/ ICOMT(12),ICOMTS,ICOMX2,ICOMTL,ISUBP,NDPRS,_^1_#$LABX,IBCDTB(48)_^1_$EQUIVALENCE(ICOMB,ICOMT(1)),(ICOMBX,ICOMT(2)),(ICOMDF,_^1_#$ICOMT(3)),(ICOMBN,ICOMT(4))_^1_$DIMENSION ICOMB(6),ICOMBX€€(6),ICOMDF(6),ICOMBN(7)_^1_$COMMON /A/ LOOPTS,LOOPTX,LOOPTB,LOOPT(50)_^1_$EQUIVALENCE(LINDUC,LOOPT(1))_^1_$DIMENSION LINDUC(10)_^1_$EQUIVALENCE (LBEG,LOOPT(2))_^1_$DIMENSION LBEG(10)_^1_$EQUIVALENCE (LINC,LOOPT(3))_^1_$DIMENSION LINC(10)_^1_$EQUIVALENCE (LEND,LOOPT(4))_^1_$DIMENSION LEND(10)_^1_$BYTE(LLABL,LOOPT(5)(14=0)_))_^1_$DIMENSION LLABL(10)_^1_$BYTE(LID,LOOPT(5)(15=15) )_^€€1_$DIMENSION LID(10)_^1_$COMMON /A/ IEQV(255),IEQVS,IEQVN2_^1_$COMMON /A/ ISTAB(150),ISTABS,ISTAB2_^1_$COMMON /A/ IBUFS,ISET(25),LBLANK,KSFCNT,KSNCNT,ISORSC,_^1_#$IHOBIT,ISTNO,ISSFLG,ISUBPN,ITERM,JSORSC,KEQVS_^1C_]_^1C_#SYMBOL TABLE LABELED COMMON BLOCK_^1_$COMMON /A/ ISYMN, ISYMFL,ISYMD,ISYMX,ISYMS,ISYMP,ISYMPC,ISYMPS,_^1_#$ ISYMNS, SYMTAB(960)_^1_$INTEGER SYMTAB_^1_$BYTE (IDUM,SY€€MTAB(1)(15=15)),(KDUMY,SYMTAB(1)(15=15)),_^1_#$(ICLASS,SYMTAB(1)(14=11)),(ITYPE,SYMTAB(1)(10=9))_^1_$DIMENSION IDUM(100),KDUMY(100),ICLASS(100),ITYPE(100)_^1_$BYTE (ISNGL, SYMTAB(1)(8=8)),(KELSIZ,SYMTAB(1)(8=8)),_^1_#$ (ICOM,SYMTAB(1)(7=5)),(IPART,SYMTAB(1)(4=3))_^1_$DIMENSION ISNGL(100),KELSIZ(100),ICOM(100),IPART(100)_^1_$BYTE (KRFCNT,SYMTAB(1)(2=2)),(IDIM,SYMTAB(1)(1=0)),_^1_#$ €€(IREL,SYMTAB(1)(1=1)),(IEXT,SYMTAB(1)(0=0))_^1_$DIMENSION KRFCNT(100),IDIM(100),IREL(100),IEXT(100)_^1_$EQUIVALENCE (IRSA,SYMTAB(2)),(ICOMTX,SYMTAB(2)),(ISNOL,SYMTAB(2))_^1_$DIMENSION IRSA(100), ICOMTX(100),ISNOL(100)_^1_$BYTE (IDATAS,SYMTAB(3)(15=15)),(IREF,SYMTAB(3)(15=15)),_^1_#$ (IEQVX,SYMTAB(3)(14=8)),(ITILF,SYMTAB(3)(14=8))_^1_$DIMENSION IDATAS(100),IREF(100),IEQVX(100),ITILF€€(100)_^1_$BYTE (IPARTR,SYMTAB(3)(7=4)),(INDUCV,SYMTAB(3)(7=7)),(ISFARG,_^1_#$ SYMTAB(3)(6=6)),(IARGNO,SYMTAB(3)(5=0)),(IPARTL,SYMTAB(3)(3=0))_^1_$DIMENSION IPARTR(100),INDUCV(100),ISFARG(100),IARGNO(100),_^1_#$ IPARTL(100)_^1_$EQUIVALENCE (ISYM,SYMTAB(4))_^1_$DIMENSION ISYM(100)_^1C_]_^1C_#SPECIFICATION-TABLE INDEX LABELLED COMMON BLOCK_^1_$COMMON /A/ ISTABX(96)_^1C_]_^1C_#PHASE 4 €€LABELED COMMON BLOCK._^1_$COMMON /A/ INDTAB(18),INFTB(18)_^1_#2,NBSS ,NADC ,NCON ,NEND ,NPST ,NSTN ,NJMP ,NRTJ ,NLDA_^1_#3,NLDQ ,NSTA ,NSTQ ,NRAO ,NADD ,NSUB ,NAND ,NDVI ,NADQ_^1_#4,NENA ,NINA ,NENQ ,NINQ ,NLRS ,NLLS ,NQRS ,NQLS ,NARS_^1_#5,NALS ,NAJLGZ,NAJEZ ,NAJLZ ,NAJGEZ,NAJLEZ,NAJGZ ,NQJEZ ,NMUI_^1_$COMMON/A/_^1_#1 NFCM ,NFSB ,NFMU ,NFDV ,NFLD ,NFS€€T ,NFAD ,NCAQA_^1_#2,NTCQA ,NTRAQ ,KLDQ ,KSTQ ,NTCAA ,NEOR ,NTCQQ_^1_#3,INFTBL,INFTBN,INFTBX_^1_$DIMENSION KODNAM(18), KFTYPE(6),NLINE(6),NPMTRS(6),KSPTAB(14)_^1_$EQUIVALENCE (INFTB(1),KODNAM(1)),(ISET(11),KSPTAB(1))_^1_$BYTE (KFTYPE,INFTB(3)(15=14)),(NLINE,INFTB(3)(13=13)),_^1_#$ (NPMTRS,INFTB(3)(12=0))_^1C_]_^1C_#PHASE 4 BLANK COMMON BLOCK._^1_$COMMON//JSYM(3),_^1C *********€€************************* FTN 3.1 **************************_^1_#1 INBUFF(304),OUTBUF(10),KART(2,3,3),KQ(5),KFCET(5,3),_^1C ********************************** FTN 3.1 ($) **********************_^1_#2 KSUBAT(240),KSFAT(12,2),KLLTB(10,2),LPTYP(10),_^1_#3 INTRAS(304),IMOD(30),NDTYP(30),NBRNS(30),ICBRN(30),_^1_#4 KOP(30),KTRUT(30)_^1_$DIMENSION KFALS(30),KFATH(30),KOMPSW(30),KSBPTR(3€€0),KRESW(30)_^1_$EQUIVALENCE (KFALS(1),ISTAB(1)),(KFATH(1),ISTAB(31)),_^1_#1 (KOMPSW(1),ISTAB(61)),(KSBPTR(1),ISTAB(91)),(KRESW(1),ISTAB(121))_^1_$COMMON// LTYP,MBEGIN_^1_#1,IADDIT,INTRAX,IPTR,ISBSCP,JXX,KBEGIN,KBIAS,KBYTX,KENTER,KENTRY_^1_#2,KEXEC,KEXTYP,KFCSW,KFFSAV,KFINDX,KFLAM,KINTYP,KLLTBX,KNTROL_^1_#3,KOBX,KPRNAM,KQSAV,KRETRN,KSFNAM,KTCATX,LEVEL,LIFTX,LOGIF,KFCETX_^1_$DIMENSI€€ON NINVS(30),NINENC(30),NPASS(30)_^1_$EQUIVALENCE (KTRUT(1),NINVS(1)),(KFALS(1),NINENC(1))_^1_#1,(KFATH(1),NPASS(1))_^1_$INTEGER OUTBUF_^1C_]_^1C_'SUBROUTINE TO READ ONE RECORD FROM_^1C_'THE INPUT UNIT INTO INBUFF(I). COMPUTES_^1C_'INDEX (J) TO FIRST WORKING CELL OF BUFFER_^1C_'AND GENERATES STATEMENT LABELS._^1_$IF(I.GT.IBUFS) CALL PUNT_^1_$CALL READ(ISCRI,0,IBUFS+1-I,INBUFF(I))_€€^1C_]_^1C_'COMPUTE POINTER TO FIRST WORKING CELL_^1C_'AS PER THE SIGN OF THE STATEMENT NUMBER._^1_"2 J=I+4_^1_$IF(INBUFF(I+1).LT.0) GO TO 4_^1C_]_^1C_'SET ISTNO TO STATEMENT NUMBER OF STATEMENT JUST READ._^1_"5 ISTNO=IABS(INBUFF(I+1))_^1C_'OUTPUT STATEMENT NUMBER CODE (UNLESS A FORMAT)_^1_$IF(INBUFF(I+2).NE.17) CALL KPC3PR(INDTAB(2),NSTN,ISTNO)_^1C_]_^1C_'TEST IF RECORD LENGTH OVER€0FLOWED THE_^1C_'AVAILABLE BUFFER AREA. IF NOT, RETURN_^1_$IF(I+INBUFF(I)-1.LE.IBUFS) RETURN_^1C_]_^1C_'YES, GENERATE DIAGNOSTIC_^1_$CALL PUNT_^1C_]_^1C_]_^1_"4 J=J+1_^1C_'GENERATE THE LABEL OF THIS STATEMENT (UNLESS A FORNAT)_^1_$IF(INBUFF(I+2).NE.17) CALL LABKPC(INBUFF(I+4))_^1_$GO TO 5_^1_$END_]_^__ 0PWSUBFN CSY/ 23B P€1_$SUBROUTINE SUBFUN_^1_#*_2/DECK-ID 23B FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^13_]_^1C SUBFUN IS USED IN PHASE B1_^1C_]_^1C_#MASTER LABELED COMMON BLOCK._^1*_] FTN 3.3_^1_$COMMON /A/ IFLAGS,LINECT,LINCT1_^1_$COMMON /A/ IR,IK,IP,IA,IL,IM,IXLGO,I€€OPTO,IOPTV,IOPTC,IOPTD_^1_$COMMON /A/ MCSTRT,MACRNB,MACSEC_^1_$COMMON /A/ IERRS(16),ISRFAD_^1_$COMMON /A/ LGO,ISCRI,ISCRO,IX_^1*_] FTN 3.3_^1_$COMMON /A/ IGLAB(3),IGLAB1,IGLAB2_^1_$COMMON /A/ ICOMT(12),ICOMTS,ICOMX2,ICOMTL,ISUBP,NDPRS,_^1_#$LABX,IBCDTB(48)_^1_$EQUIVALENCE(ICOMB,ICOMT(1)),(ICOMBX,ICOMT(2)),(ICOMDF,_^1_#$ICOMT(3)),(ICOMBN,ICOMT(4))_^1_$DIMENSION ICOMB(6),ICOMBX(6),I€€COMDF(6),ICOMBN(7)_^1_$COMMON /A/ LOOPTS,LOOPTX,LOOPTB,LOOPT(50)_^1_$EQUIVALENCE(LINDUC,LOOPT(1))_^1_$DIMENSION LINDUC(10)_^1_$EQUIVALENCE (LBEG,LOOPT(2))_^1_$DIMENSION LBEG(10)_^1_$EQUIVALENCE (LINC,LOOPT(3))_^1_$DIMENSION LINC(10)_^1_$EQUIVALENCE (LEND,LOOPT(4))_^1_$DIMENSION LEND(10)_^1_$BYTE(LLABL,LOOPT(5)(14=0)_))_^1_$DIMENSION LLABL(10)_^1_$BYTE(LID,LOOPT(5)(15=15) )_^1_$DI€€MENSION LID(10)_^1_$COMMON /A/ IEQV(255),IEQVS,IEQVN2_^1_$COMMON /A/ ISTAB(150),ISTABS,ISTAB2_^1_$COMMON /A/ IBUFS,ISET(25),LBLANK,KSFCNT,KSNCNT,ISORSC,_^1_#$IHOBIT,ISTNO,ISSFLG,ISUBPN,ITERM,JSORSC,KEQVS_^1C_]_^1C_#SYMBOL TABLE LABELED COMMON BLOCK_^1_$COMMON /A/ ISYMN, ISYMFL,ISYMD,ISYMX,ISYMS,ISYMP,ISYMPC,ISYMPS,_^1_#$ ISYMNS, SYMTAB(960)_^1_$INTEGER SYMTAB_^1_$BYTE (IDUM,SYMTAB(€€1)(15=15)),(KDUMY,SYMTAB(1)(15=15)),_^1_#$(ICLASS,SYMTAB(1)(14=11)),(ITYPE,SYMTAB(1)(10=9))_^1_$DIMENSION IDUM(100),KDUMY(100),ICLASS(100),ITYPE(100)_^1_$BYTE (ISNGL, SYMTAB(1)(8=8)),(KELSIZ,SYMTAB(1)(8=8)),_^1_#$ (ICOM,SYMTAB(1)(7=5)),(IPART,SYMTAB(1)(4=3))_^1_$DIMENSION ISNGL(100),KELSIZ(100),ICOM(100),IPART(100)_^1_$BYTE (KRFCNT,SYMTAB(1)(2=2)),(IDIM,SYMTAB(1)(1=0)),_^1_#$ (IREL€€,SYMTAB(1)(1=1)),(IEXT,SYMTAB(1)(0=0))_^1_$DIMENSION KRFCNT(100),IDIM(100),IREL(100),IEXT(100)_^1_$EQUIVALENCE (IRSA,SYMTAB(2)),(ICOMTX,SYMTAB(2)),(ISNOL,SYMTAB(2))_^1_$DIMENSION IRSA(100), ICOMTX(100),ISNOL(100)_^1_$BYTE (IDATAS,SYMTAB(3)(15=15)),(IREF,SYMTAB(3)(15=15)),_^1_#$ (IEQVX,SYMTAB(3)(14=8)),(ITILF,SYMTAB(3)(14=8))_^1_$DIMENSION IDATAS(100),IREF(100),IEQVX(100),ITILF(100)€€_^1_$BYTE (IPARTR,SYMTAB(3)(7=4)),(INDUCV,SYMTAB(3)(7=7)),(ISFARG,_^1_#$ SYMTAB(3)(6=6)),(IARGNO,SYMTAB(3)(5=0)),(IPARTL,SYMTAB(3)(3=0))_^1_$DIMENSION IPARTR(100),INDUCV(100),ISFARG(100),IARGNO(100),_^1_#$ IPARTL(100)_^1_$EQUIVALENCE (ISYM,SYMTAB(4))_^1_$DIMENSION ISYM(100)_^1C_]_^1C_#SPECIFICATION-TABLE INDEX LABELLED COMMON BLOCK_^1_$COMMON /A/ ISTABX(96)_^1C_]_^1C_#PHASE 4 LABEL€€ED COMMON BLOCK._^1_$COMMON /A/ INDTAB(18),INFTB(18)_^1_#2,NBSS ,NADC ,NCON ,NEND ,NPST ,NSTN ,NJMP ,NRTJ ,NLDA_^1_#3,NLDQ ,NSTA ,NSTQ ,NRAO ,NADD ,NSUB ,NAND ,NDVI ,NADQ_^1_#4,NENA ,NINA ,NENQ ,NINQ ,NLRS ,NLLS ,NQRS ,NQLS ,NARS_^1_#5,NALS ,NAJLGZ,NAJEZ ,NAJLZ ,NAJGEZ,NAJLEZ,NAJGZ ,NQJEZ ,NMUI_^1_$COMMON/A/_^1_#1 NFCM ,NFSB ,NFMU ,NFDV ,NFLD ,NFST ,N€€FAD ,NCAQA_^1_#2,NTCQA ,NTRAQ ,KLDQ ,KSTQ ,NTCAA ,NEOR ,NTCQQ_^1_#3,INFTBL,INFTBN,INFTBX_^1_$DIMENSION KODNAM(18), KFTYPE(6),NLINE(6),NPMTRS(6),KSPTAB(14)_^1_$EQUIVALENCE (INFTB(1),KODNAM(1)),(ISET(11),KSPTAB(1))_^1_$BYTE (KFTYPE,INFTB(3)(15=14)),(NLINE,INFTB(3)(13=13)),_^1_#$ (NPMTRS,INFTB(3)(12=0))_^1C_]_^1C_#PHASE 4 BLANK COMMON BLOCK._^1_$COMMON//JSYM(3),_^1C **************€€******************** FTN 3.1 **************************_^1_#1 INBUFF(304),OUTBUF(10),KART(2,3,3),KQ(5),KFCET(5,3),_^1C ********************************** FTN 3.1 ($) **********************_^1_#2 KSUBAT(240),KSFAT(12,2),KLLTB(10,2),LPTYP(10),_^1_#3 INTRAS(304),IMOD(30),NDTYP(30),NBRNS(30),ICBRN(30),_^1_#4 KOP(30),KTRUT(30)_^1_$DIMENSION KFALS(30),KFATH(30),KOMPSW(30),KSBPTR(30),KR€€ESW(30)_^1_$EQUIVALENCE (KFALS(1),ISTAB(1)),(KFATH(1),ISTAB(31)),_^1_#1 (KOMPSW(1),ISTAB(61)),(KSBPTR(1),ISTAB(91)),(KRESW(1),ISTAB(121))_^1_$COMMON// LTYP,MBEGIN_^1_#1,IADDIT,INTRAX,IPTR,ISBSCP,JXX,KBEGIN,KBIAS,KBYTX,KENTER,KENTRY_^1_#2,KEXEC,KEXTYP,KFCSW,KFFSAV,KFINDX,KFLAM,KINTYP,KLLTBX,KNTROL_^1_#3,KOBX,KPRNAM,KQSAV,KRETRN,KSFNAM,KTCATX,LEVEL,LIFTX,LOGIF,KFCETX_^1_$DIMENSION NI€€NVS(30),NINENC(30),NPASS(30)_^1_$EQUIVALENCE (KTRUT(1),NINVS(1)),(KFALS(1),NINENC(1))_^1_#1,(KFATH(1),NPASS(1))_^1_$INTEGER OUTBUF_^1C_]_^1C_]_^1C_#PROCESS SUBROUTINE OR FUNCTION STATEMENT_^1C_]_^1_$EQUIVALENCE (IEQVV(1),IEQV(1)),(IEQINC(1),IEQV(2))_^1_$DIMENSION IEQVV(100),IEQINC(100)_^1C_]_^1_$EQUIVALENCE (ISORSC,KFUNVL)_^1C_#KPRNAM=SYMTAB PTR TO NAME_^1_$KPRNAM=INBUFF(JXX)_^1C_#€€IF FUNCTION GENERARTE NEW HOLDER FOR NAME_^1_$IF(ISUBP.NE.2)GO TO 2_^1_$ISYMX=KPRNAM_^1_$KFUNVL=KPRNAM_^1_$CALL GETSYM_^1C_#SAVE NAME_^1_$DO 3 I=1,2_^1_$KPRNAM=ISYMX+I-1_^1_"3 NBRNS(I)=ISYM(KPRNAM)_^1C_#GET NEW SYMTAB ENTRY_^1_$CALL LABLER(KPRNAM)_^1_$DO 4 I=1,2_^1_$IADDIT=ISYMX+I-1_^1_"4 ISYM(IADDIT)=NBRNS(I)_^1C_#INITIALIZE PARAMETER TABLE_^1_"2 J=1_]_^1_"1 IF(JXX.EQ.INBUFF(1))GO€Þ TO 10_^1_$JXX=JXX+1_^1_$KSUBAT(J)=INBUFF(JXX)_^1_$ISYMX=INBUFF(JXX)_^1_$CALL GETSYM_^1_$ITEMP=IEQVX(ISYMX)_^1_$IF(ITEMP.NE.0) KSUBAT(J)=IEQVV(ITEMP)_^1_$KSUBAT(J+1)=1_^1_$J=J+2_^1_$GO TO 1_^1_!10 KSUBAT(J)=0_^1_$END_]_^__ÞPWACP CSY/ 24B P€1_$SUBROUTINE ACP(I1)_^1_#*_2/DECK-ID 24B FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^13_]_^1C ********************************** FTN 3.1 **************************_^1C_]_^1C_FACP IS USED IN PHASE B_^1C_]_^1C_FMASTER LABELED COMMON BLOCK_^1C_]_^1*_] €€FTN 3.3_^1_$COMMON /A/ IFLAGS,LINECT,LINCT1_^1_$COMMON /A/ IR,IK,IP,IA,IL,IM,IXLGO,IOPTO,IOPTV,IOPTC,IOPTD_^1_$COMMON /A/ MCSTRT,MACRNB,MACSEC_^1_$COMMON /A/ IERRS(16),ISRFAD_^1_$COMMON /A/ LGO,ISCRI,ISCRO,IX_^1*_] FTN 3.3_^1_$COMMON /A/ IGLAB(3),IGLAB1,IGLAB2_^1_$COMMON /A/ ICOMT(12),ICOMTS,ICOMX2,ICOMTL,ISUBP,NDPRS_^1_$COMMON /A/ LABX,IBCDTB(48)_^1_$COMMON /A/ LOOPTS,LOOPTX,LOOP€€TB,LOOPT(50)_^1_$COMMON /A/ IEQV(255),IEQVS,IEQVN2_^1_$COMMON /A/ ISTAB(150),ISTABS,ISTAB2_^1_$COMMON /A/ IBUFS,ISET(25),LBLANK,KSFCNT,KSNCNT,ISORSC_^1_$COMMON /A/ IHOBIT,ISTNO,ISSFLG,ISUBPN,ITERM,JSORSC,KEQVS_^1C_]_^1_$EQUIVALENCE (ICOMB,ICOMT(1)), (ICOMBX,ICOMT(2))_^1_$EQUIVALENCE (ICOMDF,ICOMT(3)), (ICOMBN,ICOMT(4))_^1_$EQUIVALENCE (LINDUC,LOOPT(1)), (LBEG,LOOPT(2))_^1_$EQUIVALE€€NCE (LINC,LOOPT(3)), (LEND,LOOPT(4))_^1_$EQUIVALENCE (KFALS,ISTAB(1)), (KFATH,ISTAB(31))_^1_$EQUIVALENCE (KOMPSW,ISTAB(61)), (KSBPTR,ISTAB(91))_^1_$EQUIVALENCE (KRESW,ISTAB(121))_^1_$EQUIVALENCE (KSPTAB,ISET(11))_^1C_]_^1_$BYTE (LLABL,LOOPT(5)(14=0))_^1_$BYTE (LID,LOOPT(5)(15=15))_^1C_]_^1_$DIMENSION ICOMB(6), ICOMBX(6), ICOMDF(6), ICOMBN(7)_^1_$DIMENSION LINDUC(10), LBEG(10), LINC€€(10), LEND(10)_^1_$DIMENSION LLABL(10), LID(10)_^1_$DIMENSION KFALS(30), KFATH(30), KOMPSW(30), KSBPTR(30), KRESW(30)_^1_$DIMENSION KSPTAB(14)_^1C_]_^1_$EQUIVALENCE (NINENC,KFALS(1)), (NPASS,KFATH(1))_^1_$DIMENSION NINENC(30), NPASS(30)_^1C_]_^1C_FSYMBOL TABLE LABELED COMMON BLOC_^1C_]_^1_$COMMON /A/ ISYMN,ISYMFL,ISYMD,ISYMX,ISYMS,ISYMP,ISYMPC,ISYMPS_^1_$COMMON /A/ ISYMNS,SYMTAB(96€€0)_^1C_]_^1_$INTEGER SYMTAB_^1C_]_^1_$EQUIVALENCE (IRSA,SYMTAB(2)), (ICOMTX,SYMTAB(2))_^1_$EQUIVALENCE (ISNOL,SYMTAB(2))_^1_$EQUIVALENCE (ISYM,SYMTAB(4))_^1C_]_^1_$BYTE (IDUM,SYMTAB(1)(15=15)), (KDUMY,SYMTAB(1)(15=15))_^1_$BYTE (ICLASS,SYMTAB(1)(14=11)), (ITYPE,SYMTAB(1)(10=9))_^1_$BYTE (ISNGL,SYMTAB(1)(8=8)), (KELSIZ,SYMTAB(1)(8=8))_^1_$BYTE (ICOM,SYMTAB(1)(7=5)), (IPART,SYMTAB(1€€)(4=3))_^1_$BYTE (KRFCNT,SYMTAB(1)(2=2)), (IDIM,SYMTAB(1)(1=0))_^1_$BYTE (IREL,SYMTAB(1)(1=1)), (IEXT,SYMTAB(1)(0=0))_^1_$BYTE (IDATAS,SYMTAB(3)(15=15)), (IREF,SYMTAB(3)(15=15))_^1_$BYTE (IEQVX,SYMTAB(3)(14=8)), (ITILF,SYMTAB(3)(14=8))_^1_$BYTE (IPARTR,SYMTAB(3)(7=4)), (INDUCV,SYMTAB(3)(7=7))_^1_$BYTE (ISFARG,SYMTAB(3)(6=6)), (IARGNO,SYMTAB(3)(5=0))_^1_$BYTE (IPARTL,SYMTAB(3)(3=0))€€_^1C_]_^1_$DIMENSION IRSA(100), ICOMTX(100), ISNOL(100), ISYM(100)_^1_$DIMENSION IDUM(100), KDUMY(100), ICLASS(100), ITYPE(100)_^1_$DIMENSION ISNGL(100), KELSIZ(100), ICOM(100), IPART(100)_^1_$DIMENSION KRFCNT(100), IDIM(100), IREL(100), IEXT(100)_^1_$DIMENSION IDATAS(100), IREF(100), IEQVX(100), ITILF(100)_^1_$DIMENSION IPARTR(100), INDUCV(100), ISFARG(100), IARGNO(100)_^1_$DIMENS€€ION IPARTL(100)_^1C_]_^1C_FSPECIFICATION-TABLE INDEX LABELD_^1C_FCOMMON BLOCK_^1C_]_^1_$COMMON /A/ ISTABX(96)_^1C_]_^1C_FPHASE 4 LABLED COMMON BLOCK_^1C_]_^1_$COMMON /A/ INDTAB(18),INFTB(18)_^1_$COMMON /A/ NBSS,NADC,NCON,NEND,NPST,NSTN,NJMP,NRTJ,NLDA_^1_$COMMON /A/ NLDQ,NSTA,NSTQ,NRAO,NADD,NSUB,NAND,NDVI,NADQ_^1_$COMMON /A/ NENA,NINA,NENQ,NINQ,NLRS,NLLS,NQRS,NQLS,NARS_^1_$COMMON /A€€/ NALS,NAJLGZ,NAJEZ,NAJLZ,NAJGEZ,NAJLEZ,NAJGZ,NQJEZ,NMUI_^1_$COMMON /A/ NFCM,NFSB,NFMU,NFDV,NFLD,NFST,NFAD,NCAQA_^1_$COMMON /A/ NTCQA,NTRAQ,KLDQ,KSTQ,NTCAA,NEOR,NTCQQ_^1_$COMMON /A/ INFTBL,INFTBN,INFTBX_^1_$COMMON /A/ NDCM,NDSB,NDMU,NDDV,NDLD,NDST,NDAD_^1_$COMMON /A/ IDFLOT,IDSTR1,IDSTR2,IRSTR1,IQ8DFT_^1_$COMMON /A/ IEXD2I,IEXD2F,IEXD2D_^1_$COMMON /A/ IDPFLG_^1C_]_^1_$EQUIVALENCE (€€KODNAM,INFTB(1))_^1_$BYTE (KFTYPE,INFTB(3)(15=14)), (NLINE,INFTB(3)(13=13))_^1_$BYTE (NPMTRS,INFTB(3)(12=0))_^1_$DIMENSION KODNAM(18), KFTYPE(6), NLINE(6), NPMTRS(6)_^1C_]_^1C_FPHASE 4 BLANK COMMON BLOCK_^1C_]_^1_$COMMON // JSYM(3)_^1_$COMMON // INBUFF(304), OUTBUF(10), KART(2,3,3), KQ(5), KFCET(5,3)_^1_$COMMON // KSUBAT(240), KSFAT(12,2), KLLTB(10,2), LPTYP(10)_^1_$COMMON // INTRA€€S(304), IMOD(30), NDTYP(30), NBRNS(30), ICBRN(30)_^1_$COMMON // KOP(30), KTRUT(30)_^1_$COMMON // LTYP,MBEGIN,IADDIT,INTRAX,IPTR,ISBSCP,JXX,KBEGIN,KBIAS_^1_$COMMON // KBYTX,KENTER,KENTRY,KEXEC,KEXTYP,KFCSW,KFFSAV,KFINDX_^1_$COMMON // KFLAM,KINTYP,KLLTBX,KNTROL,KOBX,KPRNAM,KQSAV,KRETRN_^1_$COMMON // KSFNAM,KTCATX,LEVEL,LIFTX,LOGIF,KFCETX_^1_$COMMON // KSTYP,KRTNS,IDMM(5)_^1C_]_^1_$IN€€TEGER OUTBUF_^1_$EQUIVALENCE (NINVS,KTRUT(1))_^1_$DIMENSION NINVS(30)_^1C ********************************** FTN 3.1 ($) **********************_^1C_]_^1C_]_^1C_#ARITHMETIC,CALL PROCESSOR_^1C_]_^1C_]_^1C_#I1=PTR TO TREE-_^1_$DIMENSION I1(606)_^1_$I1IX=1_^1_$LEVEL=LIFTX+1_^1_$IF(LEVEL.GE.31) CALL PUNT_^1_$L444=0_^1_"1 KNTROL=1_^1_$CALL INTRAM_^1C_#IS OP A SUBEXPRESSION_^1C_#CHANGE €€FROM COMMENT_^1C_#IF(I1(I1IX).EQ.(-1)) GO TO 1000_^1C_#NO-SET UP TABLE DESCRIBING THIS LEVEL_^1_$NDTYP(LEVEL)=I1(I1IX)_^1_$KOP(LEVEL)=I1IX_^1_$KSBPTR(LEVEL)=0_^1C_#SUBROUTINE OR FUNCTION CALL_^1_$IF(I1(I1IX).LT.18.OR.I1(I1IX).GT.21) GO TO 10_^1_$I1IX=I1IX+1_^1_$KSBPTR(LEVEL)=I1(I1IX)_^1C GENERATE 'ENA' NUMBER OF PARAMETERS IN CALL_^1_$IF(IOPTV_'.NE.0) CALL KPC3PR(INDTAB(10),NENA,I€€1(I1IX+1))_^1_!10 I1IX=I1IX+1_^1_$NINENC(LEVEL)=0_^1_$KOMPSW(LEVEL)=0_^1_$J=0_]_^1C_#NO. BRANCHES_^1_$NBRNS(LEVEL)=I1(I1IX)_^1C_#GET.NO.INVERSES_^1_$K=NBRNS(LEVEL)_^1_$DO 11 L=1,K_^1C_#PTR LOC_^1_$L1=I1IX+L_^1C_#OP_!LOC_^1_$L2=I1(L1)+_!KOP(LEVEL)_^1_$IF (I1(L2).NE.0) J=J+1_^1_!11 CONTINUE_^1_$NINVS(LEVEL)=J_^1_$NPASS(LEVEL)=1_^112_"ICBRN(LEVEL)=1_^1C_#LOOK AT BRANCH_^1 8150 K1=KO€€P(LEVEL)+1_^1C_#K2=NO . OPS PTR_^1_$K2=K1_^1C_#FUNCTION OR SUBROUTINE HAS SYMTAB PTR BEFORE NO.OPS_^1_$L4=0_]_^1C_#*-ARE OPS FLOATING OR FIXED_^1_$L2=KOP(LEVEL)_^1_$IF(NDTYP (LEVEL).GE.18.AND.NDTYP(LEVEL).LT.22)GO TO 8140_^1C_#FIND AN OP WHICH WILL TELL IF EXPRESSION IS FIXED OR FLOATING_^1C_#VARIABLE OR FUNCTION CALL WILL TELL TYPE_^1 812 IF(I1(L2).GT.17) GO TO 814_^1C_#COEFFICIE€€NT OF ** MIGHT_^1_$IF(I1(L2).EQ.15) GO TO 813_^1C_#INTEGER MULTIPLY W/DIVISION_^1_$IF(I1(L2).EQ.14) GO TO 817_^1_$L2=L2+1+I1(L2+2)_^1_$GO TO 812_^1C_#**-FIND COEFFICIENT BRANCH_^1 813 L22=L2+1+I1(L2+2)_^1C_#IF THIS BRANCH IS EXPONENT,NEXT IS COEFF_^1_$IF(I1(L22-1).EQ.0)L22=I1(L2+3)+L2+1_^1_$L2=L22_^1_$GO TO 812_^1C_#WE HAVE FOUND A SYMTAB PTR-CHECK FOR REAL OR INTEGER_^1 8140 K2=K€€2+1_^1 814 ISYMX=I1(L2+1)_^1_$CALL GETSYM_^1C ********************************** FTN 3.1 **************************_^1_$L4 = ITYPE(ISYMX) - 1_^1C ********************************** FTN 3.1 ($) **********************_^1C_#FLOATING PT-IS BRANCH INVERSE_^1C_'SET FIX - FLOAT INDICATOR_^1 817 IMOD(LEVEL)=L4_^1_$IF(L4.EQ.0.OR.NDTYP(LEVEL).NE.13) GO TO 81_^1_$IF(NINVS(LEVEL).EQ.0.AND.€€NPASS(LEVEL).EQ.1) GO TO 93_^1C_#J=POINTER LOCATION IN TREE_^1 815 J=ICBRN(LEVEL)+K2_^1_$J=I1(J)+K1_^1_$IF(I1(J-1).EQ.0) GO TO 82_^1_$NINENC(LEVEL)=NINENC(LEVEL)+1_^1_$IF(NPASS(LEVEL).EQ.1) GO TO 81_^1 816 IF(ICBRN(LEVEL).EQ.NBRNS(LEVEL)) GO TO 93_^1_$ICBRN(LEVEL)=ICBRN(LEVEL)+1_^1_$GO TO 815_^1C_#BRANCH IS NOT INVERSE_^1_!82 IF(NPASS(LEVEL).NE.2) GO TO 816_^1C_#TYPE OF BRANCH_^1€€_!81 J=ICBRN(LEVEL)+K2_^1_$J=I1(J)+K1_^1C_#CALLING SEQUENCE LABEL OR NUMBER_^1_$IF(I1(J).LT.36) GO TO 8100_^1_$KNTROL=7+14*(36-I1(J))_^1_$IPTR=I1(J+1)_^1 8301 KRESW(LEVEL)=0_^1 8300 IF(NDTYP(LEVEL).GT.17.AND.NDTYP(LEVEL).LT.22) GO TO 84_^1C_#IS BRANCH INVERSE_^1_$IF(I1(J-1).EQ.0) GO TO 8302_^1C_#YES_]_^1_$KNTROL=KNTROL+1_^1_$IF(KNTROL.LE.0) KNTROL=KNTROL-2_^1C_#** OR INTEGER * WITH€€ /_^1C_#** OR INTEGER * WITH / AND NOT LAST BRANCG--STORE INTERMED_^18302 IF(NDTYP(LEVEL).EQ.15.OR.(NDTYP(LEVEL).EQ.14.AND.NBRNS(LEVEL)_^1_#1 .NE.ICBRN(LEVEL))) GO TO 84_^1_!89 IF(ICBRN(LEVEL).LT.NBRNS(LEVEL))GO TO 891_^1C_'NO COMPUTATION THIS BRANCH_^1 8900 IF(KRESW(LEVEL).NE.0) GO TO 8902_^1C_'PREVIOUS COMPUTATEON_^1_$IF(KOMPSW(LEVEL).EQ.0) GO TO 8901_^1C_'YES, INVERSE_^1_$IF(IA€€BS(KOMPSW(LEVEL)).EQ.1.OR.NDTYP(LEVEL).EQ.13)GO TO 8903_^1C_'YES - FLOATING OR FIXED_^1_$K=NTCAA_^1C_#FOATING OR F I X ED_^1C ********************************** FTN 3.1 **************************_^1_$IF (IMOD(LEVEL).EQ.1) K = NFCM_^1_$IF (IMOD(LEVEL).EQ.2) K = NDCM_^1*_'7 CARDS DELETED FTN 3.3_^1 8913 CALL KPC3PR(INDTAB(9),K,0)_^1C ********************************** FTN 3.1 ($€€) **********************_^1 8903 CALL INTRAM_^1 893 KNTROL=9_^1C ********************************** FTN 3.1 **************************_^1_$KINTYP = IMOD(LEVEL) + 1_^1C ********************************** FTN 3.1 ($) **********************_^1C_#*,/_]_^1 995 IF(NDTYP(LEVEL).NE.11) KNTROL=10_^1_$CALL INTRAM_^1_$IF(NDTYP(LEVEL).EQ.13.AND.L4.NE.0.AND.NPASS(LEVEL).EQ.1)GO TO 90_^1 88€€5 INTRAX=INTRAX-1_^1_$IF(LEVEL.NE.LIFTX+1) GO TO 8850_^1_$KEXTYP=IMOD(LEVEL)_^1_$IF(NDTYP(LEVEL).LT.18.OR.NDTYP(LEVEL).GE.22) RETURN_^1_$I1IX=KOP(LEVEL)+1_^1_$ISYMX=I1(I1IX)_^1_$CALL GETSYM_^1_$KEXTYP=ITYPE(ISYMX)-1_^1_$RETURN_^1 8901 ISYMX=IPTR_^1_$CALL GETSYM_^1_$ASSIGN 893 T O_!IAD_^1_$IF(I1(J-1).NE.0)GO TO 8912_^1_$IF(NDTYP(LEVEL).EQ.14.AND.(INTRAS(INTRAX)/2)*2.EQ.INTRAS(INTRAX€€))_^1_#1 GO TO 894_^1 8911 K=NLDA_^1_$IF(ITYPE(ISYMX).EQ.2) K=NFLD_^1C ********************************** FTN 3.1 **************************_^1_$IF (ITYPE(ISYMX).EQ.3) K = NDLD_^1C ********************************** FTN 3.1 ($) **********************_^1_$CALL KPCSTK(INDTAB(13),K,IPTR,IADDIT,ISBSCP)_^1_$GO TO IAD_^1C ********************************** FTN 3.1 ******************€€********_^1 894 KINTYP = 4_^1C ********************************** FTN 3.1 ($) **********************_^1_$GO TO 995_^1 8912 ASSIGN 8907 TO IAD_^1_$GO TO 8911_^1 8907 K=NTCAA_^1C ********************************** FTN 3.1 **************************_^1_$IF (IMOD(LEVEL).EQ.1) K = NFCM_^1_$IF (IMOD(LEVEL).EQ.2) K = NDCM_^1 8908 IF (NDTYP(LEVEL).EQ.13) GO TO 893_^1*_'7 CARDS DELETE€€D FTN 3.3_^1 8910 CALL KPC3PR(INDTAB(9),K,0)_^1C ********************************** FTN 3.1 ($) **********************_^1_$GO TO 893_^1C_'COMPUTATION ON THIS BRANCH_^1 8902 L1=KOP(LEVEL+1)-1_^1_$IF(L444.NE.0) L1=J-1_^1_$L444=0_^1_$IF(I1(L1).EQ.0) GO TO 893_^1C_'INVERSE_^1C ********************************** FTN 3.1 **************************_^1_$K = NTCAA_^1_$IF (IMOD(LEVEL).EQ.1€€) K = NFCM_^1_$IF (IMOD(LEVEL).EQ.2) K = NDCM_^1C ********************************** FTN 3.1 ($) **********************_^1_$GO TO 8908_^1 8850 LEVEL=LEVEL-1_^1_$J=KOP(LEVEL+1)_^1_$GO TO 8300_^1 891 IF(NDTYP(LEVEL).NE.13.OR.L4.EQ.0.OR.NINENC(LEVEL).NE.NINVS(LEVEL)_^1_#1.OR.NPASS(LEVEL).EQ.2) GO TO 892_^1_$IF(KOMPSW(LEVEL).NE.0 .OR.KRESW(LEVEL).NE.0) GO TO 8900_^1_$GO TO 92_^1C_#€€INTEHER * WITH /_^1 892 IF(NDTYP(LEVEL).EQ.14.OR.KRESW(LEVEL).EQ.0) GO TO 825_^1_%KOMPSW(LEVEL)=1_^1_$L1=KOP(LEVEL+1)-1_^1_$IF(L444.NE.0) L1=J-1_^1_$L444=0_^1_$IF(I1(L1).NE.0)KOMPSW(LEVEL)=2_^1_$IF(IMOD(LEVEL).NE.0)KOMPSW(LEVEL)=-KOMPSW(LEVEL)_^1_$GO TO 8251_^1C ********************************** FTN 3.1 **************************_^1 90_!IF (L4.EQ.2) GO TO 91_^1_$CALL TSALOC(IPT€€R,2)_^1_$CALL KPC3PR(INDTAB(5),NFST,IPTR)_^1_$GO TO 95_^1 91_!CALL TSALOC(IPTR,3)_^1*_'6 CARDS DELETED FTN 3.3_^1 94_!CALL KPC3PR(INDTAB(5),NDST,IPTR)_^1 95_!KNTROL = 4_^1C ********************************** FTN 3.1 ($) **********************_^1_!92 CALL INTRAM_^1_!93 NPASS(LEVEL)=2_^1_$KOMPSW(LEVEL)=0_^1_$GO TO 12_^1*_'12 CARDS DELETED FTN 3.3_^1C_#NON-PARTIAL OR PARTIAL OP_^1C_)€€OR NO PARAMETER SUBROUTINE OR FUNCTION_^1 8100_!IF(I1(J).LT.22)GO TO 8101_^1_$KNTROL=5_^1_$IPTR=I1(J+1)_^1_$ISBSCP=0_^1_$IADDIT=0_^1C_$IF NO SUBSCRIPT,BRANCH AROUND_^1_$IF(I1(J).LT.25.OR.I1(J).EQ.35) GO TO 8301_^1_$IF(I1(J).EQ.29)GO TO 842_^1_$IF(I1(J).NE.25.AND.I1(J).NE.30)IADDIT=I1(J+2)_^1C_] FTN 3.3_^1_$ISYMX=I1(J+1)_^1_$CALL GETSYM_^1_$IF(ITYPE(ISYMX).EQ.2.OR.ITYPE(ISYMX).EQ.3€€_^1_#*_!.AND._^1_#*_!(INBUFF(3).EQ.18.OR.INBUFF(3).EQ.19.OR.INBUFF(3).EQ.21.OR._^1_#*_"INBUFF(3).EQ.42.OR.INBUFF(3).EQ.43))_^1_#*_!IADDIT=ITYPE(ISYMX)*IADDIT_^1C_] FTN 3.3_^1_$IF(I1(J).EQ.26.OR.I1(J).EQ.31) GO TO 841_^1_$ISBSCP=I1(J+4)_^1_$IF(I1(J).EQ.25.OR.I1(J).EQ.30) ISBSCP=I1(J+3)_^1 841 IF(I1(J).LT.29) GO TO 8301_^1C_#LOOK FOR ** OR SUBROUTINE OR FUNCTION CALL_^1 842 IF (ND€€TYP(LEVEL).GT.17 .AND. NDTYP(LEVEL).LT.22) GO TO 8301_^1_$L444=1_^1_$ASSIGN 8420 TO IAD1_^1_$IF(KOMPSW(LEVEL).NE.0) GO TO 8401_^1 8420 CALL PARTSB(I1(J))_^1_$KRESW(LEVEL)=1_^1_$GO TO 8300_^1C_#SUBEXPRESSION PTR_^1C8101 IF(I1(J).LT.0_!) GO TO 820_^1C_#OTHER_^1C_#PREVIOUS COMPUTATION THIS NODE_^1 8101 IF(KOMPSW(LEVEL).NE.0)GO TO 8400_^1C_#NO_]_^1_!83 KRESW(LEVEL)=1_^1_$I1IX=J_^1_$LE€€VEL=LEVEL+1_^1_$IF(LEVEL.GE.31)CALL PUNT_^1_$GO TO 1_^1C_#TEMP STORAGE_^1 8400 ASSIGN 83 TO IAD1_^1 8401 ASSIGN 8408 TO IAD_^1C ********************************** FTN 3.1 **************************_^1_$K = IMOD(LEVEL) + 1_^1C_]_^1C_FGET ONE, TWO, OR THREE WORD TEMP_^1C_]_^1 8410 CALL TSALOC(IPTR,K)_^1_$IF (K.EQ.1) K = NSTA_^1_$IF (K.EQ.2) K = NFST_^1_$IF (K.EQ.3) K = NDST_^1*_'€€7 CARDS DELETED FTN 3.3_^1 8411 CALL KPC3PR(INDTAB(5),K,IPTR)_^1 8412 GO TO IAD_^1 8408 KNTROL = IABS(KOMPSW(LEVEL)) + 2_^1_$CALL INTRAM_^1_$GO TO IAD1_^1C ********************************** FTN 3.1 ($) **********************_^1C_#** OR SUBROUTINE OR FUNCTION CALL_^1_!84 IF(KRESW(LEVEL)-1) 824,840,824_^1 840 ASSIGN 843 TO IAD_^1_$K=IMOD(LEVEL+1)+1_^1_$IF(L444.NE.0) K=1_^1_$GO TO €€8410_^1 843 KNTROL=3_^1C_#IF BRANCH AN INVERSE-RESET KNTROL_^1_$IF(I1(J-1).NE.0)KNTROL=4_^1C_#INTEGER MULTIPLY WITH DIVIDE_^1 824 IF(NDTYP(LEVEL).EQ.14)GO TO 89_^1 825 CALL INTRAM_^1C ********************************** FTN 3.1 **************************_^1 8251 ICBRN(LEVEL) = ICBRN(LEVEL) + 1_^1_$IF (ICBRN(LEVEL).LE.NBRNS(LEVEL)) GO TO 8150_^1_$IF (NDTYP(LEVEL).EQ.15) GO TO 8€€50_^1C_]_^1C_FTHIS IS A FUNCTION_^1C_]_^1_$IF (NDTYP(LEVEL).LT.18 .OR. NDTYP(LEVEL).GE.20) GO TO 870_^1_$ISYMX = KSBPTR(LEVEL)_^1_$CALL GETSYM_^1_$L4 = ITYPE(ISYMX) - 1_^1C_]_^1C_FIS IT IN-LINE_^1C_]_^1_$IF (ICLASS(ISYMX).NE.3) GO TO 870_^1_$CALL FINK_^1_$KNTROL = 12_^1_$CALL INTRAM_^1_$GO TO 885_^1C_]_^1C_FEXPONENIATION_^1C_]_^1 850 L1 = INTRAX_^1_$IF (INTRAS(INTRAX).EQ.6) INT€€RAX = INTRAX - 2_^1_$ISYMX = INTRAS(INTRAX-3)_^1C_]_^1C_FEXPONENT PTR_^1C_]_^1_$L2 = ISYMX_^1_$CALL GETSYM_^1_$KEXPSW = (3 * ITYPE(ISYMX)) - 2_^1_$INTRAX = L1_^1_$ISYMX = INTRAS(INTRAX-1)_^1C_]_^1C_FCOEFFICIENT PTR_^1C_]_^1_$L22 = 0_^1_$L3 = ISYMX_^1_$CALL GETSYM_^1_$KEXPSW = KEXPSW + ITYPE(ISYMX) - 1_^1_$IF (INTRAS(INTRAX).EQ.6) L22 = INTRAS(INTRAX-2)_^1_$GO TO (861,862,863,864,8€€65,866,867,868,869), KEXPSW_^1C_]_^1C_FINTEGER BY INTEGER_^1C_]_^1 861 KSBPTR(LEVEL) = KSPTAB(8)_^1_$GO TO 870_^1C_]_^1C_FREAL BY INTEGER_^1C_]_^1 862 KSBPTR(LEVEL) = KSPTAB(7)_^1_$GO TO 870_^1C_]_^1C_FDOUBLE BY INTEGER_^1C_]_^1 863 KSBPTR(LEVEL) = IEXD2I_^1_$GO TO 870_^1C_]_^1C_FINTEGER BY REAL_^1C_]_^1 864 CONTINUE_^1C_]_^1C_FREAL BY REAL_^1C_]_^1 865 KSBPTR(LEVEL) = KSPTAB(€€6)_^1_$GO TO 870_^1C_]_^1C_FDOUBLE BY REAL_^1C_]_^1 866 KSBPTR(LEVEL) = IEXD2F_^1_$GO TO 870_^1C_]_^1C_FINTEGER BY DOUBLE_^1C_]_^1 867 CONTINUE_^1C_]_^1C_FREAL BY DOUBLE_^1C_]_^1 868 CONTINUE_^1C_]_^1C_FDOUBLE BY DOUBLE_^1C_]_^1 869 KSBPTR(LEVEL) = IEXD2D_^1C_]_^1C_FGENERATE RTJ INSTRUCTION_^1C_]_^1 870 CALL KPC3PR(INDTAB(5),NRTJ,KSBPTR(LEVEL))_^1_$KNTROL = 11_^1_$CALL INTRAM_€¬^1_$ISYMX = KSBPTR(LEVEL)_^1_$CALL GETSYM_^1*_'1 CARD DELETED FTN 3.3_^1_$GO TO 885_^1C ********************************** FTN 3.1 ($) **********************_^1_$END_]_^__¬PWAFIDL CSY/ 25B P€1_$SUBROUTINE AFIDL(KP)_^1_#*_2/DECK-ID 25B FORTRAN 3.3B_)SUMMARY-102_^1*_]_^1*_#1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_#SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^13_]_^1*_#USED IN PHASE B1_^1._]_^1C_#MASTER LABELED COMMON BLOCK._^1*_] FTN 3.3_^1_$COMMON /A/ IFLAGS,LINECT,LINCT1_^1_$COMMON /A/ IR,IK,IP,IA,IL,IM,IXLGO,I€€OPTO,IOPTV,IOPTC,IOPTD_^1_$COMMON /A/ MCSTRT,MACRNB,MACSEC_^1_$COMMON /A/ IERRS(16),ISRFAD_^1_$COMMON /A/ LGO,ISCRI,ISCRO,IX_^1*_] FTN 3.3_^1_$COMMON /A/ IGLAB(3),IGLAB1,IGLAB2_^1_$COMMON /A/ ICOMT(12),ICOMTS,ICOMX2,ICOMTL,ISUBP,NDPRS,_^1_#$LABX,IBCDTB(48)_^1_$EQUIVALENCE(ICOMB,ICOMT(1)),(ICOMBX,ICOMT(2)),(ICOMDF,_^1_#$ICOMT(3)),(ICOMBN,ICOMT(4))_^1_$DIMENSION ICOMB(6),ICOMBX(6),I€€COMDF(6),ICOMBN(7)_^1_$COMMON /A/ LOOPTS,LOOPTX,LOOPTB,LOOPT(50)_^1_$EQUIVALENCE(LINDUC,LOOPT(1))_^1_$DIMENSION LINDUC(10)_^1_$EQUIVALENCE (LBEG,LOOPT(2))_^1_$DIMENSION LBEG(10)_^1_$EQUIVALENCE (LINC,LOOPT(3))_^1_$DIMENSION LINC(10)_^1_$EQUIVALENCE (LEND,LOOPT(4))_^1_$DIMENSION LEND(10)_^1_$BYTE(LLABL,LOOPT(5)(14=0)_))_^1_$DIMENSION LLABL(10)_^1_$BYTE(LID,LOOPT(5)(15=15) )_^1_$DI€€MENSION LID(10)_^1_$COMMON /A/ IEQV(255),IEQVS,IEQVN2_^1_$COMMON /A/ ISTAB(150),ISTABS,ISTAB2_^1_$COMMON /A/ IBUFS,ISET(25),LBLANK,KSFCNT,KSNCNT,ISORSC,_^1_#$IHOBIT,ISTNO,ISSFLG,ISUBPN,ITERM,JSORSC,KEQVS_^1C_]_^1C_#SYMBOL TABLE LABELED COMMON BLOCK_^1_$COMMON /A/ ISYMN, ISYMFL,ISYMD,ISYMX,ISYMS,ISYMP,ISYMPC,ISYMPS,_^1_#$ ISYMNS, SYMTAB(960)_^1_$INTEGER SYMTAB_^1_$BYTE (IDUM,SYMTAB(€€1)(15=15)),(KDUMY,SYMTAB(1)(15=15)),_^1_#$(ICLASS,SYMTAB(1)(14=11)),(ITYPE,SYMTAB(1)(10=9))_^1_$DIMENSION IDUM(100),KDUMY(100),ICLASS(100),ITYPE(100)_^1_$BYTE (ISNGL, SYMTAB(1)(8=8)),(KELSIZ,SYMTAB(1)(8=8)),_^1_#$ (ICOM,SYMTAB(1)(7=5)),(IPART,SYMTAB(1)(4=3))_^1_$DIMENSION ISNGL(100),KELSIZ(100),ICOM(100),IPART(100)_^1_$BYTE (KRFCNT,SYMTAB(1)(2=2)),(IDIM,SYMTAB(1)(1=0)),_^1_#$ (IREL€€,SYMTAB(1)(1=1)),(IEXT,SYMTAB(1)(0=0))_^1_$DIMENSION KRFCNT(100),IDIM(100),IREL(100),IEXT(100)_^1_$EQUIVALENCE (IRSA,SYMTAB(2)),(ICOMTX,SYMTAB(2)),(ISNOL,SYMTAB(2))_^1_$DIMENSION IRSA(100), ICOMTX(100),ISNOL(100)_^1_$BYTE (IDATAS,SYMTAB(3)(15=15)),(IREF,SYMTAB(3)(15=15)),_^1_#$ (IEQVX,SYMTAB(3)(14=8)),(ITILF,SYMTAB(3)(14=8))_^1_$DIMENSION IDATAS(100),IREF(100),IEQVX(100),ITILF(100)€€_^1_$BYTE (IPARTR,SYMTAB(3)(7=4)),(INDUCV,SYMTAB(3)(7=7)),(ISFARG,_^1_#$ SYMTAB(3)(6=6)),(IARGNO,SYMTAB(3)(5=0)),(IPARTL,SYMTAB(3)(3=0))_^1_$DIMENSION IPARTR(100),INDUCV(100),ISFARG(100),IARGNO(100),_^1_#$ IPARTL(100)_^1_$EQUIVALENCE (ISYM,SYMTAB(4))_^1_$DIMENSION ISYM(100)_^1C_]_^1C_#SPECIFICATION-TABLE INDEX LABELLED COMMON BLOCK_^1_$COMMON /A/ ISTABX(96)_^1._]_^1C_#PHASE 4 LABEL€€ED COMMON BLOCK._^1_$COMMON /A/ INDTAB(18),INFTB(18)_^1_#2,NBSS ,NADC ,NCON ,NEND ,NPST ,NSTN ,NJMP ,NRTJ ,NLDA_^1_#3,NLDQ ,NSTA ,NSTQ ,NRAO ,NADD ,NSUB ,NAND ,NDVI ,NADQ_^1_#4,NENA ,NINA ,NENQ ,NINQ ,NLRS ,NLLS ,NQRS ,NQLS ,NARS_^1_#5,NALS ,NAJLGZ,NAJEZ ,NAJLZ ,NAJGEZ,NAJLEZ,NAJGZ ,NQJEZ ,NMUI_^1_$COMMON/A/_^1_#1 NFCM ,NFSB ,NFMU ,NFDV ,NFLD ,NFST ,N€€FAD ,NCAQA_^1_#2,NTCQA ,NTRAQ ,KLDQ ,KSTQ ,NTCAA ,NEOR ,NTCQQ_^1_#3,INFTBL,INFTBN,INFTBX_^1*_YBEGIN FTN 3.3_^1_$COMMON /A/ NDCM,NDSB,NDMU,NDDV,NDLD,NDST,NDAD_^1*_[END FTN 3.3_^1_$DIMENSION KODNAM(18), KFTYPE(6),NLINE(6),NPMTRS(6),KSPTAB(14)_^1_$EQUIVALENCE (INFTB(1),KODNAM(1)),(ISET(11),KSPTAB(1))_^1_$BYTE (KFTYPE,INFTB(3)(15=14)),(NLINE,INFTB(3)(13=13)),_^1_#$ (NPMTRS,INFTB(3)€€(12=0))_^1C_]_^1C_#PHASE 4 BLANK COMMON BLOCK._^1_$COMMON//JSYM(3),_^1C ********************************** FTN 3.1 **************************_^1_#1 INBUFF(304),OUTBUF(10),KART(2,3,3),KQ(5),KFCET(5,3),_^1C ********************************** FTN 3.1 ($) **********************_^1_#2 KSUBAT(240),KSFAT(12,2),KLLTB(10,2),LPTYP(10),_^1_#3 INTRAS(304),IMOD(30),NDTYP(30),NBRNS(30),ICBRN(3€€0),_^1_#4 KOP(30),KTRUT(30)_^1_$DIMENSION KFALS(30),KFATH(30),KOMPSW(30),KSBPTR(30),KRESW(30)_^1_$EQUIVALENCE (KFALS(1),ISTAB(1)),(KFATH(1),ISTAB(31)),_^1_#1 (KOMPSW(1),ISTAB(61)),(KSBPTR(1),ISTAB(91)),(KRESW(1),ISTAB(121))_^1_$COMMON// LTYP,MBEGIN_^1_#1,IADDIT,INTRAX,IPTR,ISBSCP,JXX,KBEGIN,KBIAS,KBYTX,KENTER,KENTRY_^1_#2,KEXEC,KEXTYP,KFCSW,KFFSAV,KFINDX,KFLAM,KINTYP,KLLTBX,KNTROL_€€^1_#3,KOBX,KPRNAM,KQSAV,KRETRN,KSFNAM,KTCATX,LEVEL,LIFTX,LOGIF,KFCETX_^1_$DIMENSION NINVS(30),NINENC(30),NPASS(30)_^1_$EQUIVALENCE (KTRUT(1),NINVS(1)),(KFALS(1),NINENC(1))_^1_#1,(KFATH(1),NPASS(1))_^1_$INTEGER OUTBUF_^1_$DIMENSION KP(202)_^1._]_^1_$CALL ASUPER(KP)_^1_$IF(KEXTYP.EQ.0) GO TO 1_^13_]_^1*_YBEGIN FTN 3.3_^1*_#GENERATE:_$FLST TEMP_^1*_3LDA_!TEMP_^11_]_^1_$N=KEXTYP+1_^1_€€$CALL TSALOC(IPTR,N)_^1_$IF (KEXTYP.EQ.1) N=NFST_^1_$IF (KEXTYP.EQ.2) N=NDST_^1_$CALL KPC3PR(INDTAB(5),N,IPTR)_^1_$KNTROL=4_^1_$CALL INTRAM_^1_$CALL KPC3PR(INDTAB(5),NLDA,IPTR)_^1*_[END FTN 3.3_^13_]_^1_$RETURN_^1_"1 IF(KP(1).GE.18.AND.KP(1).LT.22) GO TO 31_^1_$K=KP(2)_^1_$DO 3 I=1,K_^1_$L=KP(I+2)+2_^1_$IF(KP(L).EQ.11.AND.KP(L+1).EQ.1)L=L+KP(L+2)+2_^1_$IF(KP(L).EQ.35.AND.KP(L+1).NE€~.KSPTAB(5)) GO TO 33_^1_"3 CONTINUE_^1_!31 CALL KPC3PR(INDTAB(2),NINA,0)_^1_$RETURN_^1_!33 IF(I+1.LT.K) GO TO 3_^1_$END_]_^__ ~PWASPER CSY/ 26B P€1_$SUBROUTINE ASUPER(I)_^1_#*_2/DECK-ID 26B FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^13_]_^1C ASUPER IS USED IN PHASE B1_^1C_]_^1C_#MASTER LABELED COMMON BLOCK._^1*_] FTN 3.3_^1_$COMMON /A/ IFLAGS,LINECT,LINCT1_^1_$COMMON /A/ IR,IK,IP,IA,IL,IM,IXLG€€O,IOPTO,IOPTV,IOPTC,IOPTD_^1_$COMMON /A/ MCSTRT,MACRNB,MACSEC_^1_$COMMON /A/ IERRS(16),ISRFAD_^1_$COMMON /A/ LGO,ISCRI,ISCRO,IX_^1*_] FTN 3.3_^1_$COMMON /A/ IGLAB(3),IGLAB1,IGLAB2_^1_$COMMON /A/ ICOMT(12),ICOMTS,ICOMX2,ICOMTL,ISUBP,NDPRS,_^1_#$LABX,IBCDTB(48)_^1_$EQUIVALENCE(ICOMB,ICOMT(1)),(ICOMBX,ICOMT(2)),(ICOMDF,_^1_#$ICOMT(3)),(ICOMBN,ICOMT(4))_^1_$DIMENSION ICOMB(6),ICOMBX(6€€),ICOMDF(6),ICOMBN(7)_^1_$COMMON /A/ LOOPTS,LOOPTX,LOOPTB,LOOPT(50)_^1_$EQUIVALENCE(LINDUC,LOOPT(1))_^1_$DIMENSION LINDUC(10)_^1_$EQUIVALENCE (LBEG,LOOPT(2))_^1_$DIMENSION LBEG(10)_^1_$EQUIVALENCE (LINC,LOOPT(3))_^1_$DIMENSION LINC(10)_^1_$EQUIVALENCE (LEND,LOOPT(4))_^1_$DIMENSION LEND(10)_^1_$BYTE(LLABL,LOOPT(5)(14=0)_))_^1_$DIMENSION LLABL(10)_^1_$BYTE(LID,LOOPT(5)(15=15) )_^1_€€$DIMENSION LID(10)_^1_$COMMON /A/ IEQV(255),IEQVS,IEQVN2_^1_$COMMON /A/ ISTAB(150),ISTABS,ISTAB2_^1_$COMMON /A/ IBUFS,ISET(25),LBLANK,KSFCNT,KSNCNT,ISORSC,_^1_#$IHOBIT,ISTNO,ISSFLG,ISUBPN,ITERM,JSORSC,KEQVS_^1C_]_^1C_#SYMBOL TABLE LABELED COMMON BLOCK_^1_$COMMON /A/ ISYMN, ISYMFL,ISYMD,ISYMX,ISYMS,ISYMP,ISYMPC,ISYMPS,_^1_#$ ISYMNS, SYMTAB(960)_^1_$INTEGER SYMTAB_^1_$BYTE (IDUM,SYMT€€AB(1)(15=15)),(KDUMY,SYMTAB(1)(15=15)),_^1_#$(ICLASS,SYMTAB(1)(14=11)),(ITYPE,SYMTAB(1)(10=9))_^1_$DIMENSION IDUM(100),KDUMY(100),ICLASS(100),ITYPE(100)_^1_$BYTE (ISNGL, SYMTAB(1)(8=8)),(KELSIZ,SYMTAB(1)(8=8)),_^1_#$ (ICOM,SYMTAB(1)(7=5)),(IPART,SYMTAB(1)(4=3))_^1_$DIMENSION ISNGL(100),KELSIZ(100),ICOM(100),IPART(100)_^1_$BYTE (KRFCNT,SYMTAB(1)(2=2)),(IDIM,SYMTAB(1)(1=0)),_^1_#$ (I€€REL,SYMTAB(1)(1=1)),(IEXT,SYMTAB(1)(0=0))_^1_$DIMENSION KRFCNT(100),IDIM(100),IREL(100),IEXT(100)_^1_$EQUIVALENCE (IRSA,SYMTAB(2)),(ICOMTX,SYMTAB(2)),(ISNOL,SYMTAB(2))_^1_$DIMENSION IRSA(100), ICOMTX(100),ISNOL(100)_^1_$BYTE (IDATAS,SYMTAB(3)(15=15)),(IREF,SYMTAB(3)(15=15)),_^1_#$ (IEQVX,SYMTAB(3)(14=8)),(ITILF,SYMTAB(3)(14=8))_^1_$DIMENSION IDATAS(100),IREF(100),IEQVX(100),ITILF(1€€00)_^1_$BYTE (IPARTR,SYMTAB(3)(7=4)),(INDUCV,SYMTAB(3)(7=7)),(ISFARG,_^1_#$ SYMTAB(3)(6=6)),(IARGNO,SYMTAB(3)(5=0)),(IPARTL,SYMTAB(3)(3=0))_^1_$DIMENSION IPARTR(100),INDUCV(100),ISFARG(100),IARGNO(100),_^1_#$ IPARTL(100)_^1_$EQUIVALENCE (ISYM,SYMTAB(4))_^1_$DIMENSION ISYM(100)_^1C_]_^1C_#SPECIFICATION-TABLE INDEX LABELLED COMMON BLOCK_^1_$COMMON /A/ ISTABX(96)_^1C_]_^1C_#PHASE 4 LA€€BELED COMMON BLOCK._^1_$COMMON /A/ INDTAB(18),INFTB(18)_^1_#2,NBSS ,NADC ,NCON ,NEND ,NPST ,NSTN ,NJMP ,NRTJ ,NLDA_^1_#3,NLDQ ,NSTA ,NSTQ ,NRAO ,NADD ,NSUB ,NAND ,NDVI ,NADQ_^1_#4,NENA ,NINA ,NENQ ,NINQ ,NLRS ,NLLS ,NQRS ,NQLS ,NARS_^1_#5,NALS ,NAJLGZ,NAJEZ ,NAJLZ ,NAJGEZ,NAJLEZ,NAJGZ ,NQJEZ ,NMUI_^1_$COMMON/A/_^1_#1 NFCM ,NFSB ,NFMU ,NFDV ,NFLD ,NFST €€ ,NFAD ,NCAQA_^1_#2,NTCQA ,NTRAQ ,KLDQ ,KSTQ ,NTCAA ,NEOR ,NTCQQ_^1_#3,INFTBL,INFTBN,INFTBX_^1_$DIMENSION KODNAM(18), KFTYPE(6),NLINE(6),NPMTRS(6),KSPTAB(14)_^1_$EQUIVALENCE (INFTB(1),KODNAM(1)),(ISET(11),KSPTAB(1))_^1_$BYTE (KFTYPE,INFTB(3)(15=14)),(NLINE,INFTB(3)(13=13)),_^1_#$ (NPMTRS,INFTB(3)(12=0))_^1C_]_^1C_#PHASE 4 BLANK COMMON BLOCK._^1_$COMMON//JSYM(3),_^1C ***********€€*********************** FTN 3.1 **************************_^1_#1 INBUFF(304),OUTBUF(10),KART(2,3,3),KQ(5),KFCET(5,3),_^1C ********************************** FTN 3.1 ($) **********************_^1_#2 KSUBAT(240),KSFAT(12,2),KLLTB(10,2),LPTYP(10),_^1_#3 INTRAS(304),IMOD(30),NDTYP(30),NBRNS(30),ICBRN(30),_^1_#4 KOP(30),KTRUT(30)_^1_$DIMENSION KFALS(30),KFATH(30),KOMPSW(30),KSBPTR(30)€€,KRESW(30)_^1_$EQUIVALENCE (KFALS(1),ISTAB(1)),(KFATH(1),ISTAB(31)),_^1_#1 (KOMPSW(1),ISTAB(61)),(KSBPTR(1),ISTAB(91)),(KRESW(1),ISTAB(121))_^1_$COMMON// LTYP,MBEGIN_^1_#1,IADDIT,INTRAX,IPTR,ISBSCP,JXX,KBEGIN,KBIAS,KBYTX,KENTER,KENTRY_^1_#2,KEXEC,KEXTYP,KFCSW,KFFSAV,KFINDX,KFLAM,KINTYP,KLLTBX,KNTROL_^1_#3,KOBX,KPRNAM,KQSAV,KRETRN,KSFNAM,KTCATX,LEVEL,LIFTX,LOGIF,KFCETX_^1_$DIMENSION€€ NINVS(30),NINENC(30),NPASS(30)_^1_$EQUIVALENCE (KTRUT(1),NINVS(1)),(KFALS(1),NINENC(1))_^1_#1,(KFATH(1),NPASS(1))_^1_$INTEGER OUTBUF_^1C_]_^1C_]_^1C_#PROCESS ARITHMETIC TREE-MOSTLY DO SUBSCRIPTS,THEN USE ACP FOR REST_^1C_]_^1C_]_^1C_#I= START OF TREE (OPERATOR)_^1C_]_^1_$DIMENSION I(606)_^1C_#MAKE ALL SUBSCRIPTS SIMPLE_^1C_#SAVE TABLE COUNTER SO WE DONT LOSE IT_^1_$ITEMP=LIFTX_^1€€_$LEVEL=LIFTX+1_^1_$IF (LEVEL.GT.30) CALL PUNT_^1_$I1IX=1_^1C_#LEVEL OPERATOR_^1_"6 NDTYP(LEVEL)=I(I1IX)_^1_!50 KOP(LEVEL)=I1IX_^1_$I1IX=I1IX+1_^1_$IF(NDTYP(LEVEL).LT.18.OR.NDTYP(LEVEL).GE.22)GO TO 51_^1_$KSBPTR(LEVEL)=I(I1IX)_^1_$I1IX=I1IX+1_^1C_#NO. BRANCHES_^1_!51 NBRNS(LEVEL)=I(I1IX)_^1C_#CURRENT BRANCH_^1_$ICBRN(LEVEL)=1_^1C_#IX WITH WHICH TO FIND POINTERS_^1_$KOMPSW(LEVEL)=I€€1IX_^1C_#IX FOR CURRENT POINTER_^1_"3 K=KOMPSW(LEVEL)+ICBRN(LEVEL)_^1C_#IX FOR THING POINTED TO_^1_$K=I(K)+KOP(LEVEL)+1_^1C_#SET TABLE IX SO WE WONT GET CLOBBERED BY ACP_^1_$LIFTX=LEVEL_^1_$IF(I(K).GT.24) GO TO 10_^1_$IF(I(K).LT.22) GO TO 20_^1C_#RESET TABLE INDEX TO BICK UP WHERE WE LEFT OFF_^1_"1 LEVEL =LIFTX_^1C_#ARE WE FINISHED WITH THIS BRANCH_^1 111 IF(ICBRN(LEVEL).EQ.NBRNS€€(LEVEL)_")GO TO 2_^1C_#NOT YET_^1_$ICBRN(LEVEL)=ICBRN(LEVEL)+1_^1_$GO TO 3_^12_#LEVEL =LEVEL-1_^1_$IF(LEVEL.EQ.ITEMP)GO TO 4_^1_$GO TO 111_^1C_#WE HAVE FOUND A SUBSCRIPTED VARIABLE-MAYBE_^1_!10 IF(I(K).EQ.29.OR.I(K).GT.33) GO TO 1_^1C_#WE HAVE-IS OP ** OR SUB OR FUNC CALL_^1_$IF(NDTYP(LEVEL).EQ.15)GO TO 11_^1_$IF(NDTYP(LEVEL).GT.17.AND.NDTYP(LEVEL).LT.22)GO TO 12_^1C_#NO_]_^1_!13 C€`ALL SUBPR1(I(K))_^1_$GO TO 1_^1_!12 ISYMX=KSBPTR(LEVEL)_^1_$CALL GETSYM_^1_$IF(ICLASS(ISYMX).EQ.3)GO TO 13_^1_!11 CALL SUBPR2(I(K))_^1_$GO TO 1_^1C_#WE FOUND ANOTHER OPERATOR-START OVER AT NEXT LEVEL_^1_!20 LEVEL=LEVEL+1_^1_$IF (LEVEL.GT.30) CALL PUNT_^1_$I1IX=K_^1_$GO TO 6_^1C_#NOW-GO GENERATE CODE_^1_"4 LIFTX=ITEMP_^1_$CALL ACP(I(1))_^1_$END_]_^__`PWCGOTO CSY/ 27B P€1_$SUBROUTINE CGOTO_^1_#*_2/DECK-ID 27B FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^13_]_^1C CGOTO IS USED IN PHASE B1_^1C_]_^1C_#MASTER LABELED COMMON BLOCK._^1*_] FTN 3.3_^1_$COMMON /A/ IFLAGS,LINECT,LINCT1_^1_$COMMON /A/ IR,IK,IP,IA,IL,IM,IXLGO,IOP€€TO,IOPTV,IOPTC,IOPTD_^1_$COMMON /A/ MCSTRT,MACRNB,MACSEC_^1_$COMMON /A/ IERRS(16),ISRFAD_^1_$COMMON /A/ LGO,ISCRI,ISCRO,IX_^1*_] FTN 3.3_^1_$COMMON /A/ IGLAB(3),IGLAB1,IGLAB2_^1_$COMMON /A/ ICOMT(12),ICOMTS,ICOMX2,ICOMTL,ISUBP,NDPRS,_^1_#$LABX,IBCDTB(48)_^1_$EQUIVALENCE(ICOMB,ICOMT(1)),(ICOMBX,ICOMT(2)),(ICOMDF,_^1_#$ICOMT(3)),(ICOMBN,ICOMT(4))_^1_$DIMENSION ICOMB(6),ICOMBX(6),ICO€€MDF(6),ICOMBN(7)_^1_$COMMON /A/ LOOPTS,LOOPTX,LOOPTB,LOOPT(50)_^1_$EQUIVALENCE(LINDUC,LOOPT(1))_^1_$DIMENSION LINDUC(10)_^1_$EQUIVALENCE (LBEG,LOOPT(2))_^1_$DIMENSION LBEG(10)_^1_$EQUIVALENCE (LINC,LOOPT(3))_^1_$DIMENSION LINC(10)_^1_$EQUIVALENCE (LEND,LOOPT(4))_^1_$DIMENSION LEND(10)_^1_$BYTE(LLABL,LOOPT(5)(14=0)_))_^1_$DIMENSION LLABL(10)_^1_$BYTE(LID,LOOPT(5)(15=15) )_^1_$DIME€€NSION LID(10)_^1_$COMMON /A/ IEQV(255),IEQVS,IEQVN2_^1_$COMMON /A/ ISTAB(150),ISTABS,ISTAB2_^1_$COMMON /A/ IBUFS,ISET(25),LBLANK,KSFCNT,KSNCNT,ISORSC,_^1_#$IHOBIT,ISTNO,ISSFLG,ISUBPN,ITERM,JSORSC,KEQVS_^1C_]_^1C_#SYMBOL TABLE LABELED COMMON BLOCK_^1_$COMMON /A/ ISYMN, ISYMFL,ISYMD,ISYMX,ISYMS,ISYMP,ISYMPC,ISYMPS,_^1_#$ ISYMNS, SYMTAB(960)_^1_$INTEGER SYMTAB_^1_$BYTE (IDUM,SYMTAB(1)€€(15=15)),(KDUMY,SYMTAB(1)(15=15)),_^1_#$(ICLASS,SYMTAB(1)(14=11)),(ITYPE,SYMTAB(1)(10=9))_^1_$DIMENSION IDUM(100),KDUMY(100),ICLASS(100),ITYPE(100)_^1_$BYTE (ISNGL, SYMTAB(1)(8=8)),(KELSIZ,SYMTAB(1)(8=8)),_^1_#$ (ICOM,SYMTAB(1)(7=5)),(IPART,SYMTAB(1)(4=3))_^1_$DIMENSION ISNGL(100),KELSIZ(100),ICOM(100),IPART(100)_^1_$BYTE (KRFCNT,SYMTAB(1)(2=2)),(IDIM,SYMTAB(1)(1=0)),_^1_#$ (IREL,S€€YMTAB(1)(1=1)),(IEXT,SYMTAB(1)(0=0))_^1_$DIMENSION KRFCNT(100),IDIM(100),IREL(100),IEXT(100)_^1_$EQUIVALENCE (IRSA,SYMTAB(2)),(ICOMTX,SYMTAB(2)),(ISNOL,SYMTAB(2))_^1_$DIMENSION IRSA(100), ICOMTX(100),ISNOL(100)_^1_$BYTE (IDATAS,SYMTAB(3)(15=15)),(IREF,SYMTAB(3)(15=15)),_^1_#$ (IEQVX,SYMTAB(3)(14=8)),(ITILF,SYMTAB(3)(14=8))_^1_$DIMENSION IDATAS(100),IREF(100),IEQVX(100),ITILF(100)_^€€1_$BYTE (IPARTR,SYMTAB(3)(7=4)),(INDUCV,SYMTAB(3)(7=7)),(ISFARG,_^1_#$ SYMTAB(3)(6=6)),(IARGNO,SYMTAB(3)(5=0)),(IPARTL,SYMTAB(3)(3=0))_^1_$DIMENSION IPARTR(100),INDUCV(100),ISFARG(100),IARGNO(100),_^1_#$ IPARTL(100)_^1_$EQUIVALENCE (ISYM,SYMTAB(4))_^1_$DIMENSION ISYM(100)_^1C_]_^1C_#SPECIFICATION-TABLE INDEX LABELLED COMMON BLOCK_^1_$COMMON /A/ ISTABX(96)_^1C_]_^1C_#PHASE 4 LABELED€€ COMMON BLOCK._^1_$COMMON /A/ INDTAB(18),INFTB(18)_^1_#2,NBSS ,NADC ,NCON ,NEND ,NPST ,NSTN ,NJMP ,NRTJ ,NLDA_^1_#3,NLDQ ,NSTA ,NSTQ ,NRAO ,NADD ,NSUB ,NAND ,NDVI ,NADQ_^1_#4,NENA ,NINA ,NENQ ,NINQ ,NLRS ,NLLS ,NQRS ,NQLS ,NARS_^1_#5,NALS ,NAJLGZ,NAJEZ ,NAJLZ ,NAJGEZ,NAJLEZ,NAJGZ ,NQJEZ ,NMUI_^1_$COMMON/A/_^1_#1 NFCM ,NFSB ,NFMU ,NFDV ,NFLD ,NFST ,NFA€€D ,NCAQA_^1_#2,NTCQA ,NTRAQ ,KLDQ ,KSTQ ,NTCAA ,NEOR ,NTCQQ_^1_#3,INFTBL,INFTBN,INFTBX_^1_$DIMENSION KODNAM(18), KFTYPE(6),NLINE(6),NPMTRS(6),KSPTAB(14)_^1_$EQUIVALENCE (INFTB(1),KODNAM(1)),(ISET(11),KSPTAB(1))_^1_$BYTE (KFTYPE,INFTB(3)(15=14)),(NLINE,INFTB(3)(13=13)),_^1_#$ (NPMTRS,INFTB(3)(12=0))_^1C_]_^1C_#PHASE 4 BLANK COMMON BLOCK._^1_$COMMON//JSYM(3),_^1C ****************€€****************** FTN 3.1 **************************_^1_#1 INBUFF(304),OUTBUF(10),KART(2,3,3),KQ(5),KFCET(5,3),_^1C ********************************** FTN 3.1 ($) **********************_^1_#2 KSUBAT(240),KSFAT(12,2),KLLTB(10,2),LPTYP(10),_^1_#3 INTRAS(304),IMOD(30),NDTYP(30),NBRNS(30),ICBRN(30),_^1_#4 KOP(30),KTRUT(30)_^1_$DIMENSION KFALS(30),KFATH(30),KOMPSW(30),KSBPTR(30),KRES€€W(30)_^1_$EQUIVALENCE (KFALS(1),ISTAB(1)),(KFATH(1),ISTAB(31)),_^1_#1 (KOMPSW(1),ISTAB(61)),(KSBPTR(1),ISTAB(91)),(KRESW(1),ISTAB(121))_^1_$COMMON// LTYP,MBEGIN_^1_#1,IADDIT,INTRAX,IPTR,ISBSCP,JXX,KBEGIN,KBIAS,KBYTX,KENTER,KENTRY_^1_#2,KEXEC,KEXTYP,KFCSW,KFFSAV,KFINDX,KFLAM,KINTYP,KLLTBX,KNTROL_^1_#3,KOBX,KPRNAM,KQSAV,KRETRN,KSFNAM,KTCATX,LEVEL,LIFTX,LOGIF,KFCETX_^1_#4 ,KSTYP,KRTNS€€_^1_$COMMON // IDMM(5)_^1C *** CGOTO LOCAL VARIABLES EQUIVALENCED TO COMMON ***_^1_$EQUIVALENCE (K,IDMM(3)),(KADTAB,IDMM(4)),(I,IDMM(3))_^1C ************************ 3 CARDS DELETED_+*******_!83*2446_^1_$DIMENSION NINVS(30),NINENC(30),NPASS(30)_^1C **********************************************************_#83*2446_^1_$EQUIVALENCE (KTRUT(1),NINVS(1)),(KFALS(1),NINENC(1))_^1_#1,(K€€FATH(1),NPASS(1))_^1C **********************************************************_#83*2446_^1_$INTEGER OUTBUF_^1C_]_^1C_'SUBROUTINE TO PROCESS COMPUTED GO TO STATEMENT_^1C_]_^1C**** *****************************************************4.0/77*1826_^1C_]_^1C_#CREATE LABELS FOR BEGINNING AF ADCON TABLE AND EXIT POINT_^1C_]_^1_$CALL LABLER (KADTAB)_^1_$CALL LABLER (KEXITL)_^1C_]_^1C_#GE€€NERATE A LABEL FOR A POSITIVE INDEX VALUE OUT OF RANGE_^1C_]_^1_$CALL LABLER(KEXITI)_^1C_]_^1C_#LOCATE BEGINNING OF EXPRESSION TREE (USUALLY INT.VAR) IN_^1C_#THE INPUT BUFFER_^1C_]_^1_$K=JXX_^110_"K=K+1_^1_$IF(INBUFF(K)+1) 10,20,10_^1C_]_^1C_FLOAD THE INDEX INTO BOTH THE_^1C_FA-REG AND Q-REG_^1C_]_^120_"IF(INBUFF(K+3).EQ.11.AND.INBUFF(K+4).EQ.1.AND.INBUFF(K+6).EQ.0_^1_#-.AND.INBUFF€€(K+7).EQ.24) GO TO 30_^1_$CALL ASUPER (INBUFF(K+3))_^1_$GO TO 40_^130_"CALL KPC3PR (INDTAB(5),NLDA,INBUFF(K+8))_^140_"CALL KPC3PR (INDTAB(9),NTRAQ,0)_^1C_]_^1C_FIF THE INDEX IS LESS THAN OR_^1C_FEQUAL ZERO, EXIT_^1C_]_^1_$CALL KPC3PR (INDTAB(5),NAJLEZ,KEXITL)_^1C_]_^1C_]_^1C_FIF THE INDEX IS GREATER THAN_^1C_FTHE NO. OF LABELS, EXIT_^1_$L=K-JXX+1_^1_$IF(L.GT.127) GO TO 50_^1_$L=L*(€€-1)_^1_$CALL KPC3PR (INDTAB(2),NINA,L)_^1_$GO TO 60_^150_"CALL KPC3PR (INDTAB(2),NSUB,L)_^160_"CALL KPC3PR (INDTAB(5),NAJGEZ,KEXITI)_^1C_]_^1C_FADD THE APPROPRIATE SELF-_^1C_FRELATIVE ADCON TO THE INDEX_^1C_FIN Q-REG AND JUMP_^1C_]_^1_$CALL KPCSTK (INDTAB(11),NADQ,KADTAB,-1,0)_^1_$CALL KPC3PR (INDTAB(2),NCON,6911)_^1C_]_^1C_FWRITE ADCON TABLE LABEL,ADCONS,_^1C_FAND THE EXIT LABEL_^€€1C_]_^1_$CALL LABKPC (KADTAB)_^1C***********************************************************_#83*2490_^1C_!SAVE POINTER TO FIRST LABEL OF COMPUTED GO TO_^1_'L = JXX_^1C***********************************************************_#83*2490_^170_"CALL KPC3PR (INDTAB(10),NADC,INBUFF(JXX))_^1_$JXX=JXX+1_^1_$IF (JXX.LT.K) GO TO 70_^1_$CALL LABKPC (KEXITI)_^1_$CALL KPC3PR (INDTAB(5),NJMP,I€FNBUFF(JXX-1))_^1_$CALL LABKPC (KEXITL)_^1C***********************************************************_#83*2490_^1C_"CREATE A JUMP TO FIRST LABEL WHERE INDEX IS LT OR EQ ZERO_^1C_]_^1_%CALL KPC3PR (INDTAB(5),NJMP,INBUFF(L))_^1C_]_^1_$RETURN_^1C**** *****************************************************4.0/77*1826_^1_$END_]_^__FPWFINK CSY/ 28B P€1_$SUBROUTINE FINK_^1_#*_2/DECK-ID 28B FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^13_]_^1C FINK IS USED IN PHASE B1_^1C_]_^1C_#MASTER LABELED COMMON BLOCK._^1*_] FTN 3.3_^1_$COMMON /A/ IFLAGS,LINECT,LINCT1_^1_$COMMON /A/ IR,IK,IP,IA,IL,IM,IXLGO,IOPTO€€,IOPTV,IOPTC,IOPTD_^1_$COMMON /A/ MCSTRT,MACRNB,MACSEC_^1_$COMMON /A/ IERRS(16),ISRFAD_^1_$COMMON /A/ LGO,ISCRI,ISCRO,IX_^1*_] FTN 3.3_^1_$COMMON /A/ IGLAB(3),IGLAB1,IGLAB2_^1_$COMMON /A/ ICOMT(12),ICOMTS,ICOMX2,ICOMTL,ISUBP,NDPRS,_^1_#$LABX,IBCDTB(48)_^1_$EQUIVALENCE(ICOMB,ICOMT(1)),(ICOMBX,ICOMT(2)),(ICOMDF,_^1_#$ICOMT(3)),(ICOMBN,ICOMT(4))_^1_$DIMENSION ICOMB(6),ICOMBX(6),ICOMD€€F(6),ICOMBN(7)_^1_$COMMON /A/ LOOPTS,LOOPTX,LOOPTB,LOOPT(50)_^1_$EQUIVALENCE(LINDUC,LOOPT(1))_^1_$DIMENSION LINDUC(10)_^1_$EQUIVALENCE (LBEG,LOOPT(2))_^1_$DIMENSION LBEG(10)_^1_$EQUIVALENCE (LINC,LOOPT(3))_^1_$DIMENSION LINC(10)_^1_$EQUIVALENCE (LEND,LOOPT(4))_^1_$DIMENSION LEND(10)_^1_$BYTE(LLABL,LOOPT(5)(14=0)_))_^1_$DIMENSION LLABL(10)_^1_$BYTE(LID,LOOPT(5)(15=15) )_^1_$DIMENS€€ION LID(10)_^1_$COMMON /A/ IEQV(255),IEQVS,IEQVN2_^1_$COMMON /A/ ISTAB(150),ISTABS,ISTAB2_^1_$COMMON /A/ IBUFS,ISET(25),LBLANK,KSFCNT,KSNCNT,ISORSC,_^1_#$IHOBIT,ISTNO,ISSFLG,ISUBPN,ITERM,JSORSC,KEQVS_^1C_]_^1C_#SYMBOL TABLE LABELED COMMON BLOCK_^1_$COMMON /A/ ISYMN, ISYMFL,ISYMD,ISYMX,ISYMS,ISYMP,ISYMPC,ISYMPS,_^1_#$ ISYMNS, SYMTAB(960)_^1_$INTEGER SYMTAB_^1_$BYTE (IDUM,SYMTAB(1)(1€€5=15)),(KDUMY,SYMTAB(1)(15=15)),_^1_#$(ICLASS,SYMTAB(1)(14=11)),(ITYPE,SYMTAB(1)(10=9))_^1_$DIMENSION IDUM(100),KDUMY(100),ICLASS(100),ITYPE(100)_^1_$BYTE (ISNGL, SYMTAB(1)(8=8)),(KELSIZ,SYMTAB(1)(8=8)),_^1_#$ (ICOM,SYMTAB(1)(7=5)),(IPART,SYMTAB(1)(4=3))_^1_$DIMENSION ISNGL(100),KELSIZ(100),ICOM(100),IPART(100)_^1_$BYTE (KRFCNT,SYMTAB(1)(2=2)),(IDIM,SYMTAB(1)(1=0)),_^1_#$ (IREL,SYM€€TAB(1)(1=1)),(IEXT,SYMTAB(1)(0=0))_^1_$DIMENSION KRFCNT(100),IDIM(100),IREL(100),IEXT(100)_^1_$EQUIVALENCE (IRSA,SYMTAB(2)),(ICOMTX,SYMTAB(2)),(ISNOL,SYMTAB(2))_^1_$DIMENSION IRSA(100), ICOMTX(100),ISNOL(100)_^1_$BYTE (IDATAS,SYMTAB(3)(15=15)),(IREF,SYMTAB(3)(15=15)),_^1_#$ (IEQVX,SYMTAB(3)(14=8)),(ITILF,SYMTAB(3)(14=8))_^1_$DIMENSION IDATAS(100),IREF(100),IEQVX(100),ITILF(100)_^1_€€$BYTE (IPARTR,SYMTAB(3)(7=4)),(INDUCV,SYMTAB(3)(7=7)),(ISFARG,_^1_#$ SYMTAB(3)(6=6)),(IARGNO,SYMTAB(3)(5=0)),(IPARTL,SYMTAB(3)(3=0))_^1_$DIMENSION IPARTR(100),INDUCV(100),ISFARG(100),IARGNO(100),_^1_#$ IPARTL(100)_^1_$EQUIVALENCE (ISYM,SYMTAB(4))_^1_$DIMENSION ISYM(100)_^1C_]_^1C_#SPECIFICATION-TABLE INDEX LABELLED COMMON BLOCK_^1_$COMMON /A/ ISTABX(96)_^1C_]_^1C_#PHASE 4 LABELED C€€OMMON BLOCK._^1_$COMMON /A/ INDTAB(18),INFTB(18)_^1_#2,NBSS ,NADC ,NCON ,NEND ,NPST ,NSTN ,NJMP ,NRTJ ,NLDA_^1_#3,NLDQ ,NSTA ,NSTQ ,NRAO ,NADD ,NSUB ,NAND ,NDVI ,NADQ_^1_#4,NENA ,NINA ,NENQ ,NINQ ,NLRS ,NLLS ,NQRS ,NQLS ,NARS_^1_#5,NALS ,NAJLGZ,NAJEZ ,NAJLZ ,NAJGEZ,NAJLEZ,NAJGZ ,NQJEZ ,NMUI_^1_$COMMON/A/_^1_#1 NFCM ,NFSB ,NFMU ,NFDV ,NFLD ,NFST ,NFAD €€ ,NCAQA_^1_#2,NTCQA ,NTRAQ ,KLDQ ,KSTQ ,NTCAA ,NEOR ,NTCQQ_^1_#3,INFTBL,INFTBN,INFTBX_^1_$DIMENSION KODNAM(18), KFTYPE(6),NLINE(6),NPMTRS(6),KSPTAB(14)_^1_$EQUIVALENCE (INFTB(1),KODNAM(1)),(ISET(11),KSPTAB(1))_^1_$BYTE (KFTYPE,INFTB(3)(15=14)),(NLINE,INFTB(3)(13=13)),_^1_#$ (NPMTRS,INFTB(3)(12=0))_^1C_]_^1C_#PHASE 4 BLANK COMMON BLOCK._^1_$COMMON//JSYM(3),_^1C ******************€€**************** FTN 3.1 **************************_^1_#1 INBUFF(304),OUTBUF(10),KART(2,3,3),KQ(5),KFCET(5,3),_^1C ********************************** FTN 3.1 ($) **********************_^1_#2 KSUBAT(240),KSFAT(12,2),KLLTB(10,2),LPTYP(10),_^1_#3 INTRAS(304),IMOD(30),NDTYP(30),NBRNS(30),ICBRN(30),_^1_#4 KOP(30),KTRUT(30)_^1_$DIMENSION KFALS(30),KFATH(30),KOMPSW(30),KSBPTR(30),KRESW(€€30)_^1_$EQUIVALENCE (KFALS(1),ISTAB(1)),(KFATH(1),ISTAB(31)),_^1_#1 (KOMPSW(1),ISTAB(61)),(KSBPTR(1),ISTAB(91)),(KRESW(1),ISTAB(121))_^1_$COMMON// LTYP,MBEGIN_^1_#1,IADDIT,INTRAX,IPTR,ISBSCP,JXX,KBEGIN,KBIAS,KBYTX,KENTER,KENTRY_^1_#2,KEXEC,KEXTYP,KFCSW,KFFSAV,KFINDX,KFLAM,KINTYP,KLLTBX,KNTROL_^1_#3,KOBX,KPRNAM,KQSAV,KRETRN,KSFNAM,KTCATX,LEVEL,LIFTX,LOGIF,KFCETX_^1_$DIMENSION NINVS(€€30),NINENC(30),NPASS(30)_^1_$EQUIVALENCE (KTRUT(1),NINVS(1)),(KFALS(1),NINENC(1))_^1_#1,(KFATH(1),NPASS(1))_^1_$INTEGER OUTBUF_^1C_]_^1C_]_^1C_'SUBROUTINE TO GENERATE CODE FOR_^1C_'IN-LINE FUNCTIONS_^1C_]_^1_$DIMENSION FETAB(3,3)_^1_$INTEGER FETAB_^1_$INTEGER FETABX_^1C_]_^1C_'ROUTINE TO MOVE OPERANDS IN CURRENT LEVEL OF INTRAS_^1C_'TABLE TO MORE CONVENIENT FORM IN TABLE FETAB._^1C€€_]_^1C_]_^1C_'SET UP INTRAS INDEX_^1_$INTRX1=INTRAX_^1C_'SET UP FETAB INDEX_^1_$FETABX=1_^1C_]_^1C_'HAS LEVEL BREAK BEEN REACHED, IF SO, EXIT._^1 201 IF(INTRAS(INTRX1).EQ.0) GO TO 9876_^1C_]_^1C_'PICKUP OPERAND POINTER_^1_$INTRX1=INTRX1-1_^1_$FETAB(FETABX,1)=INTRAS(INTRX1)_^1C_'DECREMENT TO NEXT WORD_^1_$INTRX1=INTRX1-1_^1C_]_^1C_'WERE THERE ONLY TWO WORDS IN THIS ELEMENT_^1_$JOAN€€=INTRAS(INTRX1+2)_^1_$JOAN=JOAN-5_^1_$IF(JOAN.LT.0) JOAN=JOAN+11_^1_$IF(JOAN.EQ.0.OR.JOAN.EQ.1) GO TO 101_^1C_]_^1C_'THERE WERE ONLY TWO WORDS IN THIS_^1C_'ELEMENT, SET ADDITIVE AND SUBSCRIPT_^1C_'TO ZERO._^1_$FETAB(FETABX,2)=0_^1_$FETAB(FETABX,3)=0_^1C_]_^1C_'UPDATE TO NEXT FETAB ENTRY_^1 301 FETABX=FETABX+1_^1_$GO TO 201_^1C_]_^1C_'PICKUP ADDITIVE AND SUBSCRIPT POINTERS_^1 101 €€FETAB(FETABX,2)=INTRAS(INTRX1)_^1_$INTRX1=INTRX1-1_^1_$FETAB(FETABX,3)=INTRAS(INTRX1)_^1_$INTRX1=INTRX1-1_^1_$GO TO 301_^1C_]_^1C_]_^1C_]_^1C_'SET INDEX TO FUNCTION_^1 9876 ITILFX=ITILF(ISYMX)_^1_$CALL KPCSTK(INDTAB(13),NLDA,FETAB(1,1),FETAB(1,2),FETAB(1,3))_^1_$GO TO (10,20,30,40,50,60),ITILFX_^1C_]_^1C_]_^1C_'IABS FUNCTION_^1_!10 CALL LABLER(KSKIP)_^1_$CALL KPC3PR(INDTAB(5),NAJGE€€Z,KSKIP)_^1_$CALL KPC3PR(INDTAB(9),NTCAA,0)_^1_$CALL LABKPC(KSKIP)_^1_$RETURN_^1C_]_^1C_]_^1C_'AND FUNCTION_^1_!20 CALL KPCSTK(INDTAB(13),NAND,FETAB(2,1),FETAB(2,2),FETAB(2,3))_^1_$RETURN_^1C_]_^1C_]_^1C_'OR FUNCTION_^1_!30 CALL KPCSTK(INDTAB(13),NLDQ,FETAB(2,1),FETAB(2,2),FETAB(2,3))_^1_$CALL KPC3PR(INDTAB(9),NTCAA,0)_^1_$CALL KPC3PR(INDTAB(9),NTCQQ,0)_^1_$CALL KPC3PR(INDTAB(9),NC€€AQA,0)_^1_$RETURN_^1C_]_^1C_]_^1C_'EOR FUNCTION_^1_!40 CALL KPCSTK(INDTAB(13),NEOR,FETAB(2,1),FETAB(2,2),FETAB(2,3))_^1_$RETURN_^1C_]_^1C_]_^1C_'NOT FUNCTION_^1_!50 CALL KPC3PR(INDTAB(9),NTCAA,0)_^1_$RETURN_^1C_]_^1C_]_^1C_'ISIGN FUNCTION_^1_!60 CALL KPCSTK(INDTAB(13),NMUI,FETAB(2,1),FETAB(2,2),FETAB(2,3))_^1_$CALL KPC3PR(INDTAB(2),NLRS,31)_^1_$CALL KPCSTK(INDTAB(13),NEOR,FETAB(1,1€&),FETAB(1,2),FETAB(1,3))_^1_$END_]_^__&PWTRAM CSY/ 29B P€1_$SUBROUTINE INTRAM_^1_#*_2/DECK-ID 29B FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^13_]_^1C ********************************** FTN 3.1 **************************_^1C_]_^1C_FINTRAM IS USED IN PHASE B_^1C_]_^1C_FMASTER LABELED COMMON BLOCK_^1C_]_^1*_]€€ FTN 3.3_^1_$COMMON /A/ IFLAGS,LINECT,LINCT1_^1_$COMMON /A/ IR,IK,IP,IA,IL,IM,IXLGO,IOPTO,IOPTV,IOPTC,IOPTD_^1_$COMMON /A/ MCSTRT,MACRNB,MACSEC_^1_$COMMON /A/ IERRS(16),ISRFAD_^1_$COMMON /A/ LGO,ISCRI,ISCRO,IX_^1*_] FTN 3.3_^1_$COMMON /A/ IGLAB(3),IGLAB1,IGLAB2_^1_$COMMON /A/ ICOMT(12),ICOMTS,ICOMX2,ICOMTL,ISUBP,NDPRS_^1_$COMMON /A/ LABX,IBCDTB(48)_^1_$COMMON /A/ LOOPTS,LOOPTX,LO€€OPTB,LOOPT(50)_^1_$COMMON /A/ IEQV(255),IEQVS,IEQVN2_^1_$COMMON /A/ ISTAB(150),ISTABS,ISTAB2_^1_$COMMON /A/ IBUFS,ISET(25),LBLANK,KSFCNT,KSNCNT,ISORSC_^1_$COMMON /A/ IHOBIT,ISTNO,ISSFLG,ISUBPN,ITERM,JSORSC,KEQVS_^1C_]_^1_$EQUIVALENCE (ICOMB,ICOMT(1)), (ICOMBX,ICOMT(2))_^1_$EQUIVALENCE (ICOMDF,ICOMT(3)), (ICOMBN,ICOMT(4))_^1_$EQUIVALENCE (LINDUC,LOOPT(1)), (LBEG,LOOPT(2))_^1_$EQUIVA€€LENCE (LINC,LOOPT(3)), (LEND,LOOPT(4))_^1_$EQUIVALENCE (KFALS,ISTAB(1)), (KFATH,ISTAB(31))_^1_$EQUIVALENCE (KOMPSW,ISTAB(61)), (KSBPTR,ISTAB(91))_^1_$EQUIVALENCE (KRESW,ISTAB(121))_^1_$EQUIVALENCE (KSPTAB,ISET(11))_^1C_]_^1_$BYTE (LLABL,LOOPT(5)(14=0))_^1_$BYTE (LID,LOOPT(5)(15=15))_^1C_]_^1_$DIMENSION ICOMB(6), ICOMBX(6), ICOMDF(6), ICOMBN(7)_^1_$DIMENSION LINDUC(10), LBEG(10), LI€€NC(10), LEND(10)_^1_$DIMENSION LLABL(10), LID(10)_^1_$DIMENSION KFALS(30), KFATH(30), KOMPSW(30), KSBPTR(30), KRESW(30)_^1_$DIMENSION KSPTAB(14)_^1C_]_^1_$EQUIVALENCE (NINENC,KFALS(1)), (NPASS,KFATH(1))_^1_$DIMENSION NINENC(30), NPASS(30)_^1C_]_^1C_FSYMBOL TABLE LABELED COMMON BLOC_^1C_]_^1_$COMMON /A/ ISYMN,ISYMFL,ISYMD,ISYMX,ISYMS,ISYMP,ISYMPC,ISYMPS_^1_$COMMON /A/ ISYMNS,SYMTAB(€€960)_^1C_]_^1_$INTEGER SYMTAB_^1C_]_^1_$EQUIVALENCE (IRSA,SYMTAB(2)), (ICOMTX,SYMTAB(2))_^1_$EQUIVALENCE (ISNOL,SYMTAB(2))_^1_$EQUIVALENCE (ISYM,SYMTAB(4))_^1C_]_^1_$BYTE (IDUM,SYMTAB(1)(15=15)), (KDUMY,SYMTAB(1)(15=15))_^1_$BYTE (ICLASS,SYMTAB(1)(14=11)), (ITYPE,SYMTAB(1)(10=9))_^1_$BYTE (ISNGL,SYMTAB(1)(8=8)), (KELSIZ,SYMTAB(1)(8=8))_^1_$BYTE (ICOM,SYMTAB(1)(7=5)), (IPART,SYMTAB€€(1)(4=3))_^1_$BYTE (KRFCNT,SYMTAB(1)(2=2)), (IDIM,SYMTAB(1)(1=0))_^1_$BYTE (IREL,SYMTAB(1)(1=1)), (IEXT,SYMTAB(1)(0=0))_^1_$BYTE (IDATAS,SYMTAB(3)(15=15)), (IREF,SYMTAB(3)(15=15))_^1_$BYTE (IEQVX,SYMTAB(3)(14=8)), (ITILF,SYMTAB(3)(14=8))_^1_$BYTE (IPARTR,SYMTAB(3)(7=4)), (INDUCV,SYMTAB(3)(7=7))_^1_$BYTE (ISFARG,SYMTAB(3)(6=6)), (IARGNO,SYMTAB(3)(5=0))_^1_$BYTE (IPARTL,SYMTAB(3)(3=0€€))_^1C_]_^1_$DIMENSION IRSA(100), ICOMTX(100), ISNOL(100), ISYM(100)_^1_$DIMENSION IDUM(100), KDUMY(100), ICLASS(100), ITYPE(100)_^1_$DIMENSION ISNGL(100), KELSIZ(100), ICOM(100), IPART(100)_^1_$DIMENSION KRFCNT(100), IDIM(100), IREL(100), IEXT(100)_^1_$DIMENSION IDATAS(100), IREF(100), IEQVX(100), ITILF(100)_^1_$DIMENSION IPARTR(100), INDUCV(100), ISFARG(100), IARGNO(100)_^1_$DIME€€NSION IPARTL(100)_^1C_]_^1C_FSPECIFICATION-TABLE INDEX LABELD_^1C_FCOMMON BLOCK_^1C_]_^1_$COMMON /A/ ISTABX(96)_^1C_]_^1C_FPHASE 4 LABLED COMMON BLOCK_^1C_]_^1_$COMMON /A/ INDTAB(18),INFTB(18)_^1_$COMMON /A/ NBSS,NADC,NCON,NEND,NPST,NSTN,NJMP,NRTJ,NLDA_^1_$COMMON /A/ NLDQ,NSTA,NSTQ,NRAO,NADD,NSUB,NAND,NDVI,NADQ_^1_$COMMON /A/ NENA,NINA,NENQ,NINQ,NLRS,NLLS,NQRS,NQLS,NARS_^1_$COMMON €€/A/ NALS,NAJLGZ,NAJEZ,NAJLZ,NAJGEZ,NAJLEZ,NAJGZ,NQJEZ,NMUI_^1_$COMMON /A/ NFCM,NFSB,NFMU,NFDV,NFLD,NFST,NFAD,NCAQA_^1_$COMMON /A/ NTCQA,NTRAQ,KLDQ,KSTQ,NTCAA,NEOR,NTCQQ_^1_$COMMON /A/ INFTBL,INFTBN,INFTBX_^1_$COMMON /A/ NDCM,NDSB,NDMU,NDDV,NDLD,NDST,NDAD_^1_$COMMON /A/ IDFLOT,IDSTR1,IDSTR2,IRSTR1,IQ8DFT_^1_$COMMON /A/ IEXD2I,IEXD2F,IEXD2D_^1_$COMMON /A/ IDPFLG_^1C_]_^1_$EQUIVALENCE€€ (KODNAM,INFTB(1))_^1_$BYTE (KFTYPE,INFTB(3)(15=14)), (NLINE,INFTB(3)(13=13))_^1_$BYTE (NPMTRS,INFTB(3)(12=0))_^1_$DIMENSION KODNAM(18), KFTYPE(6), NLINE(6), NPMTRS(6)_^1C_]_^1C_FPHASE 4 BLANK COMMON BLOCK_^1C_]_^1_$COMMON // JSYM(3)_^1_$COMMON // INBUFF(304), OUTBUF(10), KART(2,3,3), KQ(5), KFCET(5,3)_^1_$COMMON // KSUBAT(240), KSFAT(12,2), KLLTB(10,2), LPTYP(10)_^1_$COMMON // INT€€RAS(304), IMOD(30), NDTYP(30), NBRNS(30), ICBRN(30)_^1_$COMMON // KOP(30), KTRUT(30)_^1_$COMMON // LTYP,MBEGIN,IADDIT,INTRAX,IPTR,ISBSCP,JXX,KBEGIN,KBIAS_^1_$COMMON // KBYTX,KENTER,KENTRY,KEXEC,KEXTYP,KFCSW,KFFSAV,KFINDX_^1_$COMMON // KFLAM,KINTYP,KLLTBX,KNTROL,KOBX,KPRNAM,KQSAV,KRETRN_^1_$COMMON // KSFNAM,KTCATX,LEVEL,LIFTX,LOGIF,KFCETX_^1_$COMMON // KSTYP,KRTNS,IDMM(5)_^1C_]_^1_$€€INTEGER OUTBUF_^1_$EQUIVALENCE (NINVS,KTRUT(1))_^1_$DIMENSION NINVS(30)_^1C ********************************** FTN 3.1 ($) **********************_^1C_]_^1C_]_^1C_'ROUTINE TO CONTROL TEMPORARY STORAGE_^1C_'USED AS INTERMEDIATE RESULTS AND RE-_^1C_'LEASE AND PROCESS SAME UPON COMMAND._^1C_]_^1C_'IS CONTROL SETTING = 2._^1_$IF(KNTROL.NE.2) GO TO 10_^1C_'YES, UPDATE TO NEXT LOWER LEV€€EL_^1_$INTRAX=INTRAX-1_^1_$RETURN_^1C_'IS CONTROL SETTING 1,3,4,5,6,7,OR 8._^1_!10 IF(KNTROL.GT.8)GO TO 19_^1C_'YES INCREMENT INTRAX_^1_$INTRAX=INTRAX+1_^1C_'BRANCH ON CONTROL SWITCH_^1_$IF(INTRAX.GT.IBUFS-4) GO TO 500_^1_$GO TO (101,102,103,104,105,106,107,108),IABS(KNTROL)_^1C_'(2 NOT POSSIBLE)_^1 102 CONTINUE_^1C_'KNTROL=1, UPDATE TO NEXT HIGHER LEVEL_^1 101 INTRAS(INTRAX)=0_€€^1_$RETURN_^1C_'KNTROL=5,OR 6, PLACE SUBSCRIPT AND ADDITIVE IN TABLE._^1C_+OR-5,OR -6_^1 105 CONTINUE_^1 106 INTRAS(INTRAX)=ISBSCP_^1_$INTRAX=INTRAX+1_^1_$INTRAS(INTRAX)=IADDIT_^1_$INTRAX=INTRAX+1_^1C_]_^1C_]_^1C_'KNTROL=-3,-4,3,4,7,OR 8, PLACE OPERAND OR TS PTR IN TABLE._^1 103 CONTINUE_^1 104 CONTINUE_^1 107 CONTINUE_^1 108 INTRAS(INTRAX)=IPTR_^1_$INTRAX=INTRAX+1_^1C_'PLACE€€ ELEMENT DESIGNATOR IN LAST WORD_^1_$INTRAS(INTRAX)=KNTROL_^1_$INTRAS(INTRAX+1)=0_^1_$RETURN_^1C_]_^1 500 CALL PUNT_^1C_#STOP_]_^1C_]_^1C_'INSTRUCTION SWITCH IS 10._^1C_'IS SHIFTING POSSIBLE. IF NOT,SET PROPER COMMAND_^1_!80 IF(K.NE.0) GO TO 100_^1_$KCOM=NDVI_^1C ********************************** FTN 3.1 **************************_^1_$IF (KINTYP.EQ.4) CALL KPCSTK(INDTAB(13),NLD€€Q,IPTR,IADDIT,ISBSCP)_^1_$IF (KINTYP.NE.4) CALL KPC3PR(INDTAB(9),NTRAQ,0)_^1C ********************************** FTN 3.1 ($) **********************_^1C_'OUTPUT INSTRUCTIONS FOR SIGN EXTENSION_^1C_2LRS 16_^1_$CALL KPC3PR(INDTAB(2),NLRS,16)_^1*_YBEGIN FTN 3.3_^1_!50 CALL KPCSTK(INDTAB(13),KCOM,IPPTR,IPADD,IPSBS)_^1*_[END FTN 3.3_^1 195 IF (KINTYP.EQ.4) KINTYP = 1_^1C_]_^1C_'SET €€INSTRUCTION SWITCH TO 0._^1_!19 INSTSW=0_^1C_]_^1C_'BRANCH ON KNTROL 9,10,11, OR 12_^1_!20 GO TO (109,110,111,111),KNTROL-8_^1C_]_^1C_'UPDATE INSTRUCTION SWITCH_^1C ********************************** FTN 3.1 **************************_^1 110 INSTSW = INSTSW + 6_^1C ********************************** FTN 3.1 ($) **********************_^1C_]_^1C_'SET I AS PER ELEMENT DESIGNATOR O€€F CURRENT ELEMENT._^1 109 I=INTRAS(INTRAX)_^1C_'HAS LEVEL BREAK BEEN ENCOUNTERED. IF SO,RETURN._^1_$IF(I.EQ.0) RETURN_^1C_'INDEX AND SET OPERAND OR TS POINTER._^1_$INTRAX=INTRAX-1_^1_$IPPTR=INTRAS(INTRAX)_^1_$INTRAX=INTRAX-1_^1C_]_^1C_'BRANCH ON ELEMENT DESIGNATOR 3 OR 4 - OR - 5 OR 6._^1_$IF(IABS(I).GT.4) GO TO 30_^1C_'DESIGNATOR IS 3 OR 4, SET TS PTR IN RELEASE HOLDER_^1_$IRELES€€=IPPTR_^1C_'SET ADDITIVE AND SUBSCRIPT PARAMETERS TO 0._^1_$IPADD=0_^1_$IPSBS=0_^1C_]_^1C_]_^1C_'RELEASE TEMPORARY STORAGE (UNLESS I IS NEGATIVE...DESIG-_^1C_'NATING SUBEXPRESSION TEMPORARY STORAGE)_^1 320 IF(I.LT.0) GO TO 321_^1_$CALL TSALOC(IRELES,4)_^1 321 CONTINUE_^1C_]_^1C_]_^1C_'BRANCH ON ELEMENT DESIGNATOR 3 OR 5 - OR - 4 OR 6_^1 310 IF(I.EQ.3.OR.I.EQ.5.OR.I.EQ.(-3).OR.I.€€EQ.(-5))GO TO 40_^1C_'ELEMENT DESIGNATOR IS 4 OR 6, UPDATE INSTRUCTION SWITCH_^1C ********************************** FTN 3.1 **************************_^1_$INSTSW = INSTSW + 3_^1C ********************************** FTN 3.1 ($) **********************_^1C_]_^1C_'UPDATE INSTRUCTION SWITCH AS PER KINTYP (FLOATING_^1C_'OR FIXED MODE OF INSTRUCTION GENERATION)_^1_!40 INSTSW=INSTSW+KINT€€YP_^1C ********************************** FTN 3.1 **************************_^1_$IF (KINTYP.EQ.4) INSTSW = INSTSW - 3_^1C ********************************** FTN 3.1 ($) **********************_^1C_]_^1C_'IF THIS IS PASS 1 OF A FLOATING MULTIPLY CHANGE THE_^1C_'DIVIDES TO MULTIPLIES, OTHERWISE . . ._^1C ********************************** FTN 3.1 **************************_^1_$IF €€(INSTSW.EQ.11 .AND. NPASS(LEVEL).EQ.1) GO TO 208_^1_$IF (INSTSW.EQ.12 .AND. NPASS(LEVEL).EQ.1) GO TO 209_^1C_]_^1C_FBRANCH ON INSTRUCTION SWITCH_^1C_FAND SET PROPER COMMAND_^1C_]_^1_$GO TO (201,202,203,204,205,206,207,208,209,210,211,212), INSTSW_^1 201 KCOM = NADD_^1_$GO TO 50_^1 202 KCOM = NFAD_^1_$GO TO 50_^1 203 KCOM = NDAD_^1_$GO TO 50_^1 204 KCOM = NSUB_^1_$GO TO 50_^1 €€205 KCOM = NFSB_^1_$GO TO 50_^1 206 KCOM = NDSB_^1_$GO TO 50_^1 208 KCOM = NFMU_^1_$GO TO 50_^1 209 KCOM = NDMU_^1_$GO TO 50_^1 211 KCOM = NFDV_^1_$GO TO 50_^1 212 KCOM = NDDV_^1_$GO TO 50_^1C ********************************** FTN 3.1 ($) **********************_^1C_]_^1C_]_^1C_'FOR FIXED POINT MULTIPLIES AND DIVIDES DETERMINE_^1C_'IF SHIFTING CAN REPLACE MULTIPLY OR DIVIDE.€€_^1C_]_^1C_'LOOKUP POINTER AND SEE IF CONSTANT._^1C ********************************** FTN 3.1 **************************_^1 207 CONTINUE_^1 210 ISYMX = IPPTR_^1C ********************************** FTN 3.1 ($) **********************_^1_$CALL GETSYM_^1_$IF(ICLASS(ISYMX).NE.2) GO TO 60_^1C_'OPERAND IS A CONSTANT, RUN THROUGH SHIFT CHECK_^1_$ICON=ISYM(ISYMX)_^1_$KK=2_]_^1_$DO 65 K€€=1,14,1_^1_$IF(ICON.EQ.KK) GO TO 70_^1_$KK=KK*2_^1_!65 CONTINUE_^1C_'SET K TO SHOW NO SHIFTING_^1_!60 K=0_]_^1C_]_^1C ********************************** FTN 3.1 **************************_^1C_FBRANCH ON INSTRUCTION SWT 7,10_^1C_]_^1 70_!IF (INSTSW.EQ.10) GO TO 80_^1C_'INSTRUCTION SWITCH IS 7._^1C ********************************** FTN 3.1 ($) **********************_^1C_'IS SHIFT€€ING POSSIBLE. IF NOT,SET PROPER COMMAND_^1_$IF(K.NE.0) GO TO 90_^1_$KCOM=NMUI_^1_$GO TO 50_^1C_'SHIFTING POSSIBLE,_^1C_'GENERATE_!ALS K_^1_!90 KCOM=NALS_^1_$GO TO 300_^1C_'SHIFTING POSSIBLE,_^1C_'GENERATE_!ARS K_^1 100 KCOM=NARS_^1C ********************************** FTN 3.1 **************************_^1_$IF (KINTYP.EQ.4) CALL KPCSTK(INDTAB(13),NLDA,IPTR,IADDIT,ISBSCP)_^1C ***€€******************************* FTN 3.1 ($) **********************_^1 300 CALL KPC3PR(INDTAB(2),KCOM,K)_^1C_'GO TO NEXT ELEMENT_^1_$GO TO 195_^1C_]_^1C_'SET ADDITIVE AND SUBSCRIPT PARAMETERS._^1_!30 IPADD=INTRAS(INTRAX)_^1_$INTRAX=INTRAX-1_^1_$IPSBS=INTRAS(INTRAX)_^1_$INTRAX=INTRAX-1_^1_$GO TO 310_^1C_'KNTROL SETTING = 11 OR 12_^1C_'FOR ADDRESS CONSTANTS, SET INDTYP TO INDTAB ELE€€MENT_^1C_'AS PER RUN-ANYWHERE SWITCH._^1 111 IF(IR.EQ.0) GO TO 400_^1_$INDTYP=INDTAB(18)_^1_$GO TO 401_^1 400 INDTYP=INDTAB(17)_^1C_]_^1C_'SET I AS PER ELEMENT DESIGNATOR OF CURRENT ELEMENT_^1 401 I=INTRAS(INTRAX)_^1C_'HAS LEVEL BREAK BEEN ENCOUNTERED. IF SO, RETURN._^1_$IF(I.EQ.0) RETURN_^1C_'INDEX AND SET OPERAND OR TS POINTER._^1_$INTRAX=INTRAX-1_^1_$IPPTR=INTRAS(INTRAX)_^1C_€€'LOOKUP POINTER AND SET IREF TO INDICATE USE IN_^1C_'CALLING SEQUENCE UNLESS IT IS A CONSTANT AND NOT_^1C_'A SYMBOL TABLE POINTER._^1_$IF(I.EQ.(-7)) GO TO 420_^1_$ISYMX=IPPTR_^1_$CALL GETSYM_^1_$IREF(ISYMX)=1_^1C_]_^1C_'BRANCH ON ELEMENT DESIGNATOR 3 OR 4 - OR - 5 OR 6 - OR 7 OR 8._^1_$IF(I.EQ.7.OR.I.EQ.8) GO TO 407_^1_$IF(I.GT.4.OR.I.LT.(-4)) GO TO 456_^1C_]_^1C_'ADDRESS CONSTANT €€IS TEMP STORAGE REFERENCE_^1C_'SET ADDITIVE TO 0._^1_$IPADD=0_^1C_'GENERATE_!ADC_!OPERAND, ADDITIVE_^1 410 IF(KNTROL.EQ.12) GO TO 1410_^1_$CALL KPCSTK(INDTYP,NADC,IPPTR,IPADD,0)_^1 1410 CONTINUE_^1C_'IF ADDRESS CONSTANT WAS A POINTER TO TEMPORARY_^1C_'LOCATION, RELEASE IT._^1_$IF(I.GT.4.OR.I.LT.(-4)) GO TO 405_^1 406 CALL TSALOC(IPPTR,4)_^1C_]_^1C_'DECREMENT TO NEXT ELEMENT_^1 4€€05 INTRAX=INTRAX-1_^1_$GO TO 401_^1C_'ADDRESS CONSTANT IS TRUE OPERAND_^1C_'SET ADDITIVE AS PER TABLE_^1 456 INTRAX=INTRAX-1_^1_$IPADD=INTRAS(INTRAX)_^1_$INTRAX=INTRAX-1_^1_$GO TO 410_^1C_'ELEMENT IS A CALLING SEQUENCE LABEL_^1C_'GENERATE_!LABEL_!IPPTR_^1C_4BSS_!1_^1 407 IF(KNTROL.EQ.12) GO TO 1407_^1_$CALL LABKPC(IPPTR)_^1_$CALL KPC3PR(INDTAB(2),NBSS,1)_^1 1407 CONTINUE_^1_$GO T€xO 405_^1C_'ELEMENT IS A CALLING SEQUENCE CONSTANT_^1 420 CALL KPC3PR(INDTAB(2),NCON,IPPTR)_^1_$GO TO 405_^1_$END_]_^__ xPWPRTSB CSY/ 30B P€1_$SUBROUTINE PARTSB(N)_^1_#*_2/DECK-ID 30B FORTRAN 3.3B_)SUMMARY-102_^1_#-/DECK-ID 30B FORTRAN 3.2A SUMMARY-REL_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^13_]_^1C PARTSB IS USED IN PHASE B1_^1C_]_^1C_#MASTER LABELED COMMON BLOCK._^1*_] FTN 3.3_^1_$COMMON /A/ IFLAGS,LINECT,L€€INCT1_^1_$COMMON /A/ IR,IK,IP,IA,IL,IM,IXLGO,IOPTO,IOPTV,IOPTC,IOPTD_^1_$COMMON /A/ MCSTRT,MACRNB,MACSEC_^1_$COMMON /A/ IERRS(16),ISRFAD_^1_$COMMON /A/ LGO,ISCRI,ISCRO,IX_^1*_] FTN 3.3_^1_$COMMON /A/ IGLAB(3),IGLAB1,IGLAB2_^1_$COMMON /A/ ICOMT(12),ICOMTS,ICOMX2,ICOMTL,ISUBP,NDPRS,_^1_#$LABX,IBCDTB(48)_^1_$EQUIVALENCE(ICOMB,ICOMT(1)),(ICOMBX,ICOMT(2)),(ICOMDF,_^1_#$ICOMT(3)),(ICOMB€€N,ICOMT(4))_^1_$DIMENSION ICOMB(6),ICOMBX(6),ICOMDF(6),ICOMBN(7)_^1_$COMMON /A/ LOOPTS,LOOPTX,LOOPTB,LOOPT(50)_^1_$EQUIVALENCE(LINDUC,LOOPT(1))_^1_$DIMENSION LINDUC(10)_^1_$EQUIVALENCE (LBEG,LOOPT(2))_^1_$DIMENSION LBEG(10)_^1_$EQUIVALENCE (LINC,LOOPT(3))_^1_$DIMENSION LINC(10)_^1_$EQUIVALENCE (LEND,LOOPT(4))_^1_$DIMENSION LEND(10)_^1_$BYTE(LLABL,LOOPT(5)(14=0)_))_^1_$DIMENSION LL€€ABL(10)_^1_$BYTE(LID,LOOPT(5)(15=15) )_^1_$DIMENSION LID(10)_^1_$COMMON /A/ IEQV(255),IEQVS,IEQVN2_^1_$COMMON /A/ ISTAB(150),ISTABS,ISTAB2_^1_$COMMON /A/ IBUFS,ISET(25),LBLANK,KSFCNT,KSNCNT,ISORSC,_^1_#$IHOBIT,ISTNO,ISSFLG,ISUBPN,ITERM,JSORSC,KEQVS_^1C_]_^1C_#SYMBOL TABLE LABELED COMMON BLOCK_^1_$COMMON /A/ ISYMN, ISYMFL,ISYMD,ISYMX,ISYMS,ISYMP,ISYMPC,ISYMPS,_^1_#$ ISYMNS, SYMTAB(€€960)_^1_$INTEGER SYMTAB_^1_$BYTE (IDUM,SYMTAB(1)(15=15)),(KDUMY,SYMTAB(1)(15=15)),_^1_#$(ICLASS,SYMTAB(1)(14=11)),(ITYPE,SYMTAB(1)(10=9))_^1_$DIMENSION IDUM(100),KDUMY(100),ICLASS(100),ITYPE(100)_^1_$BYTE (ISNGL, SYMTAB(1)(8=8)),(KELSIZ,SYMTAB(1)(8=8)),_^1_#$ (ICOM,SYMTAB(1)(7=5)),(IPART,SYMTAB(1)(4=3))_^1_$DIMENSION ISNGL(100),KELSIZ(100),ICOM(100),IPART(100)_^1_$BYTE (KRFCNT,SYMT€€AB(1)(2=2)),(IDIM,SYMTAB(1)(1=0)),_^1_#$ (IREL,SYMTAB(1)(1=1)),(IEXT,SYMTAB(1)(0=0))_^1_$DIMENSION KRFCNT(100),IDIM(100),IREL(100),IEXT(100)_^1_$EQUIVALENCE (IRSA,SYMTAB(2)),(ICOMTX,SYMTAB(2)),(ISNOL,SYMTAB(2))_^1_$DIMENSION IRSA(100), ICOMTX(100),ISNOL(100)_^1_$BYTE (IDATAS,SYMTAB(3)(15=15)),(IREF,SYMTAB(3)(15=15)),_^1_#$ (IEQVX,SYMTAB(3)(14=8)),(ITILF,SYMTAB(3)(14=8))_^1_$DIMENSI€€ON IDATAS(100),IREF(100),IEQVX(100),ITILF(100)_^1_$BYTE (IPARTR,SYMTAB(3)(7=4)),(INDUCV,SYMTAB(3)(7=7)),(ISFARG,_^1_#$ SYMTAB(3)(6=6)),(IARGNO,SYMTAB(3)(5=0)),(IPARTL,SYMTAB(3)(3=0))_^1_$DIMENSION IPARTR(100),INDUCV(100),ISFARG(100),IARGNO(100),_^1_#$ IPARTL(100)_^1_$EQUIVALENCE (ISYM,SYMTAB(4))_^1_$DIMENSION ISYM(100)_^1C_]_^1C_#SPECIFICATION-TABLE INDEX LABELLED COMMON BLOCK_^1_$€€COMMON /A/ ISTABX(96)_^1C_]_^1C_#PHASE 4 LABELED COMMON BLOCK._^1_$COMMON /A/ INDTAB(18),INFTB(18)_^1_#2,NBSS ,NADC ,NCON ,NEND ,NPST ,NSTN ,NJMP ,NRTJ ,NLDA_^1_#3,NLDQ ,NSTA ,NSTQ ,NRAO ,NADD ,NSUB ,NAND ,NDVI ,NADQ_^1_#4,NENA ,NINA ,NENQ ,NINQ ,NLRS ,NLLS ,NQRS ,NQLS ,NARS_^1_#5,NALS ,NAJLGZ,NAJEZ ,NAJLZ ,NAJGEZ,NAJLEZ,NAJGZ ,NQJEZ ,NMUI_^1_$COMMON/A/_^1_€€#1 NFCM ,NFSB ,NFMU ,NFDV ,NFLD ,NFST ,NFAD ,NCAQA_^1_#2,NTCQA ,NTRAQ ,KLDQ ,KSTQ ,NTCAA ,NEOR ,NTCQQ_^1_#3,INFTBL,INFTBN,INFTBX_^1_$DIMENSION KODNAM(18), KFTYPE(6),NLINE(6),NPMTRS(6),KSPTAB(14)_^1_$EQUIVALENCE (INFTB(1),KODNAM(1)),(ISET(11),KSPTAB(1))_^1_$BYTE (KFTYPE,INFTB(3)(15=14)),(NLINE,INFTB(3)(13=13)),_^1_#$ (NPMTRS,INFTB(3)(12=0))_^1C_]_^1C_#PHASE 4 BLANK COMMON €€BLOCK._^1_$COMMON//JSYM(3),_^1C ********************************** FTN 3.1 **************************_^1_#1 INBUFF(304),OUTBUF(10),KART(2,3,3),KQ(5),KFCET(5,3),_^1C ********************************** FTN 3.1 ($) **********************_^1_#2 KSUBAT(240),KSFAT(12,2),KLLTB(10,2),LPTYP(10),_^1_#3 INTRAS(304),IMOD(30),NDTYP(30),NBRNS(30),ICBRN(30),_^1_#4 KOP(30),KTRUT(30)_^1_$DIMENSIO€€N KFALS(30),KFATH(30),KOMPSW(30),KSBPTR(30),KRESW(30)_^1_$EQUIVALENCE (KFALS(1),ISTAB(1)),(KFATH(1),ISTAB(31)),_^1_#1 (KOMPSW(1),ISTAB(61)),(KSBPTR(1),ISTAB(91)),(KRESW(1),ISTAB(121))_^1_$COMMON// LTYP,MBEGIN_^1_#1,IADDIT,INTRAX,IPTR,ISBSCP,JXX,KBEGIN,KBIAS,KBYTX,KENTER,KENTRY_^1_#2,KEXEC,KEXTYP,KFCSW,KFFSAV,KFINDX,KFLAM,KINTYP,KLLTBX,KNTROL_^1_#3,KOBX,KPRNAM,KQSAV,KRETRN,KSFNAM,KT€€CATX,LEVEL,LIFTX,LOGIF,KFCETX_^1_$DIMENSION NINVS(30),NINENC(30),NPASS(30)_^1_$EQUIVALENCE (KTRUT(1),NINVS(1)),(KFALS(1),NINENC(1))_^1_#1,(KFATH(1),NPASS(1))_^1_$INTEGER OUTBUF_^1C_]_^1C_'SUBROUTINE TO EXTRACT PARTIAL VALUE FROM WORD_^1C_'AND LEAVE RESULT IN ACCUMULATOR._^1C_'PARAMETER IS SYMBOL TABLE POINTER TO PARTIAL._^1C_]_^1C_]_^1_$DIMENSION MASKTB(15),N(5)_^1_$DATA MASKTB(1),€€MASKTB(2),MASKTB(3)/1,3,7/_^1_$DATA MASKTB(4),MASKTB(5),MASKTB(6)/15,31,63/_^1_$DATA MASKTB(7),MASKTB(8),MASKTB(9)/127,255,511/_^1_$DATA MASKTB(10),MASKTB(11),MASKTB(12)/1023,2047,4095/_^1_$DATA MASKTB(13),MASKTB(14),MASKTB(15)/8191,16383,32767/_^1C_]_^1C_]_^1C_'LOOKUP PARTIAL IN SYMBOL TABLE_^1_$ISYMX=N(2)_^1_$KSYMX=N(2)_^1C_'COMPUTE ADDITIVE AND SUBSCRIPT_^1_$KPAD=0_^1_$KPSB=0_^1€€_$IF(N(1).EQ.31) KPAD=N(3)_^1_$IF(N(1).EQ.30) KPSB=N(4)_^1_$IF(N(1).NE.32) GO TO 1_^1_$KPAD=N(3)_^1_$KPSB=N(5)_^1_"1 CONTINUE_^1C_]_^1C_'GENERATE_!LDA_!(OPERAND)_^1_$CALL KPCSTK(INDTAB(13),NLDA,N(2),KPAD,KPSB)_^1C_]_^1C_'IS PARTIAL SIGNED OR UNSIGNED._^1_$ISYMX=KSYMX_^1_$CALL GETSYM_^1_'IF(IPART(ISYMX).EQ.2)GO TO 100_^1C_]_^1C_'PARTIAL IS UNSIGNED_^1C_'GENERATE_!ARS_!(PARTR)_^1_$IS€€HFT=IPARTR(ISYMX)_^1_$KSHFT = IPARTL(ISYMX)_^1_$IF(ISHFT.EQ.0.AND.KSHFT.EQ.15) GO TO 15_^1_$IF(ISHFT.NE.0)CALL KPC3PR(INDTAB(2),NARS,ISHFT)_^1C_'SELECT MASK AND ENTER IN SYMBOL TABLE._^1_$ISHFT=IPARTL(ISYMX)-ISHFT+1_^1_$JSYM(1)=MASKTB(ISHFT)_^1_$JSYM(2)=0_^1_$JSYM(3)=9252_^1_$CALL SYMBOL_^1C ********************************** FTN 3.1 **************************_^1_$IF (ISYMD.EQ.0) €€ CALL STOREB_^1C ********************************** FTN 3.1 ($) **********************_^1C_'GENERATE_!AND_!(MASK)_^1_$CALL KPC3PR(INDTAB(5),NAND,ISYMX+ISYMP)_^1_!15 RETURN_^1C_]_^1C_'PARTIAL IS SIGNED_^1C_'GENERATE_!ALS_!(15-PARTL)_^1 100 ISHFT=15-IPARTL(ISYMX)_^1_$IF(ISHFT.NE.0) CALL KPC3PR(INDTAB(2),NALS,ISHFT)_^1C_'GENERATE_!ARS_!(15-PARTL+PARTR)_^1_$ISHFT=ISHFT+IPARTR(ISYMX)_€4^1_$CALL KPC3PR(INDTAB(2),NARS,ISHFT)_^1_$END_]_^__ 4PWSUB1 CSY/ 31B P€1_$SUBROUTINE SUBPR1(I)_^1_#*_2/DECK-ID 31B FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^13_]_^1C SUBPR1 IS USED IN PHASE B1_^1C_]_^1C_#MASTER LABELED COMMON BLOCK._^1*_] FTN 3.3_^1_$COMMON /A/ IFLAGS,LINECT,LINCT1_^1_$COMMON /A/ IR,IK,IP,IA,IL,IM,IXLG€€O,IOPTO,IOPTV,IOPTC,IOPTD_^1_$COMMON /A/ MCSTRT,MACRNB,MACSEC_^1_$COMMON /A/ IERRS(16),ISRFAD_^1_$COMMON /A/ LGO,ISCRI,ISCRO,IX_^1*_] FTN 3.3_^1_$COMMON /A/ IGLAB(3),IGLAB1,IGLAB2_^1_$COMMON /A/ ICOMT(12),ICOMTS,ICOMX2,ICOMTL,ISUBP,NDPRS,_^1_#$LABX,IBCDTB(48)_^1_$EQUIVALENCE(ICOMB,ICOMT(1)),(ICOMBX,ICOMT(2)),(ICOMDF,_^1_#$ICOMT(3)),(ICOMBN,ICOMT(4))_^1_$DIMENSION ICOMB(6),ICOMBX(6€€),ICOMDF(6),ICOMBN(7)_^1_$COMMON /A/ LOOPTS,LOOPTX,LOOPTB,LOOPT(50)_^1_$EQUIVALENCE(LINDUC,LOOPT(1))_^1_$DIMENSION LINDUC(10)_^1_$EQUIVALENCE (LBEG,LOOPT(2))_^1_$DIMENSION LBEG(10)_^1_$EQUIVALENCE (LINC,LOOPT(3))_^1_$DIMENSION LINC(10)_^1_$EQUIVALENCE (LEND,LOOPT(4))_^1_$DIMENSION LEND(10)_^1_$BYTE(LLABL,LOOPT(5)(14=0)_))_^1_$DIMENSION LLABL(10)_^1_$BYTE(LID,LOOPT(5)(15=15) )_^1_€€$DIMENSION LID(10)_^1_$COMMON /A/ IEQV(255),IEQVS,IEQVN2_^1_$COMMON /A/ ISTAB(150),ISTABS,ISTAB2_^1_$COMMON /A/ IBUFS,ISET(25),LBLANK,KSFCNT,KSNCNT,ISORSC,_^1_#$IHOBIT,ISTNO,ISSFLG,ISUBPN,ITERM,JSORSC,KEQVS_^1C_]_^1C_#SYMBOL TABLE LABELED COMMON BLOCK_^1_$COMMON /A/ ISYMN, ISYMFL,ISYMD,ISYMX,ISYMS,ISYMP,ISYMPC,ISYMPS,_^1_#$ ISYMNS, SYMTAB(960)_^1_$INTEGER SYMTAB_^1_$BYTE (IDUM,SYMT€€AB(1)(15=15)),(KDUMY,SYMTAB(1)(15=15)),_^1_#$(ICLASS,SYMTAB(1)(14=11)),(ITYPE,SYMTAB(1)(10=9))_^1_$DIMENSION IDUM(100),KDUMY(100),ICLASS(100),ITYPE(100)_^1_$BYTE (ISNGL, SYMTAB(1)(8=8)),(KELSIZ,SYMTAB(1)(8=8)),_^1_#$ (ICOM,SYMTAB(1)(7=5)),(IPART,SYMTAB(1)(4=3))_^1_$DIMENSION ISNGL(100),KELSIZ(100),ICOM(100),IPART(100)_^1_$BYTE (KRFCNT,SYMTAB(1)(2=2)),(IDIM,SYMTAB(1)(1=0)),_^1_#$ (I€€REL,SYMTAB(1)(1=1)),(IEXT,SYMTAB(1)(0=0))_^1_$DIMENSION KRFCNT(100),IDIM(100),IREL(100),IEXT(100)_^1_$EQUIVALENCE (IRSA,SYMTAB(2)),(ICOMTX,SYMTAB(2)),(ISNOL,SYMTAB(2))_^1_$DIMENSION IRSA(100), ICOMTX(100),ISNOL(100)_^1_$BYTE (IDATAS,SYMTAB(3)(15=15)),(IREF,SYMTAB(3)(15=15)),_^1_#$ (IEQVX,SYMTAB(3)(14=8)),(ITILF,SYMTAB(3)(14=8))_^1_$DIMENSION IDATAS(100),IREF(100),IEQVX(100),ITILF(1€€00)_^1_$BYTE (IPARTR,SYMTAB(3)(7=4)),(INDUCV,SYMTAB(3)(7=7)),(ISFARG,_^1_#$ SYMTAB(3)(6=6)),(IARGNO,SYMTAB(3)(5=0)),(IPARTL,SYMTAB(3)(3=0))_^1_$DIMENSION IPARTR(100),INDUCV(100),ISFARG(100),IARGNO(100),_^1_#$ IPARTL(100)_^1_$EQUIVALENCE (ISYM,SYMTAB(4))_^1_$DIMENSION ISYM(100)_^1C_]_^1C_#SPECIFICATION-TABLE INDEX LABELLED COMMON BLOCK_^1_$COMMON /A/ ISTABX(96)_^1C_]_^1C_#PHASE 4 LA€€BELED COMMON BLOCK._^1_$COMMON /A/ INDTAB(18),INFTB(18)_^1_#2,NBSS ,NADC ,NCON ,NEND ,NPST ,NSTN ,NJMP ,NRTJ ,NLDA_^1_#3,NLDQ ,NSTA ,NSTQ ,NRAO ,NADD ,NSUB ,NAND ,NDVI ,NADQ_^1_#4,NENA ,NINA ,NENQ ,NINQ ,NLRS ,NLLS ,NQRS ,NQLS ,NARS_^1_#5,NALS ,NAJLGZ,NAJEZ ,NAJLZ ,NAJGEZ,NAJLEZ,NAJGZ ,NQJEZ ,NMUI_^1_$COMMON/A/_^1_#1 NFCM ,NFSB ,NFMU ,NFDV ,NFLD ,NFST €€ ,NFAD ,NCAQA_^1_#2,NTCQA ,NTRAQ ,KLDQ ,KSTQ ,NTCAA ,NEOR ,NTCQQ_^1_#3,INFTBL,INFTBN,INFTBX_^1_$DIMENSION KODNAM(18), KFTYPE(6),NLINE(6),NPMTRS(6),KSPTAB(14)_^1_$EQUIVALENCE (INFTB(1),KODNAM(1)),(ISET(11),KSPTAB(1))_^1_$BYTE (KFTYPE,INFTB(3)(15=14)),(NLINE,INFTB(3)(13=13)),_^1_#$ (NPMTRS,INFTB(3)(12=0))_^1C_]_^1C_#PHASE 4 BLANK COMMON BLOCK._^1_$COMMON//JSYM(3),_^1C ***********€€*********************** FTN 3.1 **************************_^1_#1 INBUFF(304),OUTBUF(10),KART(2,3,3),KQ(5),KFCET(5,3),_^1C ********************************** FTN 3.1 ($) **********************_^1_#2 KSUBAT(240),KSFAT(12,2),KLLTB(10,2),LPTYP(10),_^1_#3 INTRAS(304),IMOD(30),NDTYP(30),NBRNS(30),ICBRN(30),_^1_#4 KOP(30),KTRUT(30)_^1_$DIMENSION KFALS(30),KFATH(30),KOMPSW(30),KSBPTR(30)€€,KRESW(30)_^1_$EQUIVALENCE (KFALS(1),ISTAB(1)),(KFATH(1),ISTAB(31)),_^1_#1 (KOMPSW(1),ISTAB(61)),(KSBPTR(1),ISTAB(91)),(KRESW(1),ISTAB(121))_^1_$COMMON// LTYP,MBEGIN_^1_#1,IADDIT,INTRAX,IPTR,ISBSCP,JXX,KBEGIN,KBIAS,KBYTX,KENTER,KENTRY_^1_#2,KEXEC,KEXTYP,KFCSW,KFFSAV,KFINDX,KFLAM,KINTYP,KLLTBX,KNTROL_^1_#3,KOBX,KPRNAM,KQSAV,KRETRN,KSFNAM,KTCATX,LEVEL,LIFTX,LOGIF,KFCETX_^1_$DIMENSION€€ NINVS(30),NINENC(30),NPASS(30)_^1_$EQUIVALENCE (KTRUT(1),NINVS(1)),(KFALS(1),NINENC(1))_^1_#1,(KFATH(1),NPASS(1))_^1_$INTEGER OUTBUF_^1._]_^1C_]_^1C_#PROCESS A SUBSCRIPT EXPRESSION AND STORE IT_^1C_]_^1_$DIMENSION I(202)_^1_$IF(I(1).EQ.26.OR.I(1).EQ.31)RETURN_^1_$CALL SUBPR3(I(1),I1)_^1_$IF(I1.EQ.0)RETURN_^1C_#SET VARIABLE PORTION OF SUBSCRIPT TO NON-PART_^1_$I(I1+2)=24_^1C_]_^1C_€v'* * * * MASS STORAGE VERSION MUST TAKE INTO ACCOUNT_^1C_'SUBEXPRESSION CONSIDERATIONS WHEN PLACING THIS TEMPORARY_^1C_'STORAGE INTO INTRAS TABLE._/* * * * * * *_^1C_]_^1_$CALL TSALOC(KTS,1)_^1_$I(I1+3)=KTS_^1C_]_^1C_'MAKE ENTRY IN INTRAS_^1_$KNTROL=3_^1_$IPTR=KTS_^1_$CALL INTRAM_^1C_]_^1C_'GENERATE_"STA (TEMP. CELL)_^1_$CALL KPC3PR(INDTAB(5),NSTA,I(I1+3))_^1_$END_]_^__ vPWSUB2 CSY/ 32B P€1_$SUBROUTINE SUBPR2(I)_^1_#*_2/DECK-ID 32B FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^13_]_^1C SUBPR2 IS USED IN PHASE B1_^1C_]_^1C_#MASTER LABELED COMMON BLOCK._^1*_] FTN 3.3_^1_$COMMON /A/ IFLAGS,LINECT,LINCT1_^1_$COMMON /A/ IR,IK,IP,IA,IL,IM,IXLG€€O,IOPTO,IOPTV,IOPTC,IOPTD_^1_$COMMON /A/ MCSTRT,MACRNB,MACSEC_^1_$COMMON /A/ IERRS(16),ISRFAD_^1_$COMMON /A/ LGO,ISCRI,ISCRO,IX_^1*_] FTN 3.3_^1_$COMMON /A/ IGLAB(3),IGLAB1,IGLAB2_^1_$COMMON /A/ ICOMT(12),ICOMTS,ICOMX2,ICOMTL,ISUBP,NDPRS,_^1_#$LABX,IBCDTB(48)_^1_$EQUIVALENCE(ICOMB,ICOMT(1)),(ICOMBX,ICOMT(2)),(ICOMDF,_^1_#$ICOMT(3)),(ICOMBN,ICOMT(4))_^1_$DIMENSION ICOMB(6),ICOMBX(6€€),ICOMDF(6),ICOMBN(7)_^1_$COMMON /A/ LOOPTS,LOOPTX,LOOPTB,LOOPT(50)_^1_$EQUIVALENCE(LINDUC,LOOPT(1))_^1_$DIMENSION LINDUC(10)_^1_$EQUIVALENCE (LBEG,LOOPT(2))_^1_$DIMENSION LBEG(10)_^1_$EQUIVALENCE (LINC,LOOPT(3))_^1_$DIMENSION LINC(10)_^1_$EQUIVALENCE (LEND,LOOPT(4))_^1_$DIMENSION LEND(10)_^1_$BYTE(LLABL,LOOPT(5)(14=0)_))_^1_$DIMENSION LLABL(10)_^1_$BYTE(LID,LOOPT(5)(15=15) )_^1_€€$DIMENSION LID(10)_^1_$COMMON /A/ IEQV(255),IEQVS,IEQVN2_^1_$COMMON /A/ ISTAB(150),ISTABS,ISTAB2_^1_$COMMON /A/ IBUFS,ISET(25),LBLANK,KSFCNT,KSNCNT,ISORSC,_^1_#$IHOBIT,ISTNO,ISSFLG,ISUBPN,ITERM,JSORSC,KEQVS_^1C_]_^1C_#SYMBOL TABLE LABELED COMMON BLOCK_^1_$COMMON /A/ ISYMN, ISYMFL,ISYMD,ISYMX,ISYMS,ISYMP,ISYMPC,ISYMPS,_^1_#$ ISYMNS, SYMTAB(960)_^1_$INTEGER SYMTAB_^1_$BYTE (IDUM,SYMT€€AB(1)(15=15)),(KDUMY,SYMTAB(1)(15=15)),_^1_#$(ICLASS,SYMTAB(1)(14=11)),(ITYPE,SYMTAB(1)(10=9))_^1_$DIMENSION IDUM(100),KDUMY(100),ICLASS(100),ITYPE(100)_^1_$BYTE (ISNGL, SYMTAB(1)(8=8)),(KELSIZ,SYMTAB(1)(8=8)),_^1_#$ (ICOM,SYMTAB(1)(7=5)),(IPART,SYMTAB(1)(4=3))_^1_$DIMENSION ISNGL(100),KELSIZ(100),ICOM(100),IPART(100)_^1_$BYTE (KRFCNT,SYMTAB(1)(2=2)),(IDIM,SYMTAB(1)(1=0)),_^1_#$ (I€€REL,SYMTAB(1)(1=1)),(IEXT,SYMTAB(1)(0=0))_^1_$DIMENSION KRFCNT(100),IDIM(100),IREL(100),IEXT(100)_^1_$EQUIVALENCE (IRSA,SYMTAB(2)),(ICOMTX,SYMTAB(2)),(ISNOL,SYMTAB(2))_^1_$DIMENSION IRSA(100), ICOMTX(100),ISNOL(100)_^1_$BYTE (IDATAS,SYMTAB(3)(15=15)),(IREF,SYMTAB(3)(15=15)),_^1_#$ (IEQVX,SYMTAB(3)(14=8)),(ITILF,SYMTAB(3)(14=8))_^1_$DIMENSION IDATAS(100),IREF(100),IEQVX(100),ITILF(1€€00)_^1_$BYTE (IPARTR,SYMTAB(3)(7=4)),(INDUCV,SYMTAB(3)(7=7)),(ISFARG,_^1_#$ SYMTAB(3)(6=6)),(IARGNO,SYMTAB(3)(5=0)),(IPARTL,SYMTAB(3)(3=0))_^1_$DIMENSION IPARTR(100),INDUCV(100),ISFARG(100),IARGNO(100),_^1_#$ IPARTL(100)_^1_$EQUIVALENCE (ISYM,SYMTAB(4))_^1_$DIMENSION ISYM(100)_^1C_]_^1C_#SPECIFICATION-TABLE INDEX LABELLED COMMON BLOCK_^1_$COMMON /A/ ISTABX(96)_^1C_]_^1C_#PHASE 4 LA€€BELED COMMON BLOCK._^1_$COMMON /A/ INDTAB(18),INFTB(18)_^1_#2,NBSS ,NADC ,NCON ,NEND ,NPST ,NSTN ,NJMP ,NRTJ ,NLDA_^1_#3,NLDQ ,NSTA ,NSTQ ,NRAO ,NADD ,NSUB ,NAND ,NDVI ,NADQ_^1_#4,NENA ,NINA ,NENQ ,NINQ ,NLRS ,NLLS ,NQRS ,NQLS ,NARS_^1_#5,NALS ,NAJLGZ,NAJEZ ,NAJLZ ,NAJGEZ,NAJLEZ,NAJGZ ,NQJEZ ,NMUI_^1_$COMMON/A/_^1_#1 NFCM ,NFSB ,NFMU ,NFDV ,NFLD ,NFST €€ ,NFAD ,NCAQA_^1_#2,NTCQA ,NTRAQ ,KLDQ ,KSTQ ,NTCAA ,NEOR ,NTCQQ_^1_#3,INFTBL,INFTBN,INFTBX_^1_$DIMENSION KODNAM(18), KFTYPE(6),NLINE(6),NPMTRS(6),KSPTAB(14)_^1_$EQUIVALENCE (INFTB(1),KODNAM(1)),(ISET(11),KSPTAB(1))_^1_$BYTE (KFTYPE,INFTB(3)(15=14)),(NLINE,INFTB(3)(13=13)),_^1_#$ (NPMTRS,INFTB(3)(12=0))_^1C_]_^1C_#PHASE 4 BLANK COMMON BLOCK._^1_$COMMON//JSYM(3),_^1C ***********€€*********************** FTN 3.1 **************************_^1_#1 INBUFF(304),OUTBUF(10),KART(2,3,3),KQ(5),KFCET(5,3),_^1C ********************************** FTN 3.1 ($) **********************_^1_#2 KSUBAT(240),KSFAT(12,2),KLLTB(10,2),LPTYP(10),_^1_#3 INTRAS(304),IMOD(30),NDTYP(30),NBRNS(30),ICBRN(30),_^1_#4 KOP(30),KTRUT(30)_^1_$DIMENSION KFALS(30),KFATH(30),KOMPSW(30),KSBPTR(30)€€,KRESW(30)_^1_$EQUIVALENCE (KFALS(1),ISTAB(1)),(KFATH(1),ISTAB(31)),_^1_#1 (KOMPSW(1),ISTAB(61)),(KSBPTR(1),ISTAB(91)),(KRESW(1),ISTAB(121))_^1_$COMMON// LTYP,MBEGIN_^1_#1,IADDIT,INTRAX,IPTR,ISBSCP,JXX,KBEGIN,KBIAS,KBYTX,KENTER,KENTRY_^1_#2,KEXEC,KEXTYP,KFCSW,KFFSAV,KFINDX,KFLAM,KINTYP,KLLTBX,KNTROL_^1_#3,KOBX,KPRNAM,KQSAV,KRETRN,KSFNAM,KTCATX,LEVEL,LIFTX,LOGIF,KFCETX_^1_$DIMENSION€€ NINVS(30),NINENC(30),NPASS(30)_^1_$EQUIVALENCE (KTRUT(1),NINVS(1)),(KFALS(1),NINENC(1))_^1_#1,(KFATH(1),NPASS(1))_^1_$INTEGER OUTBUF_^1._]_^1C_#PROCESS SUBSCRIPT EXPRESSION FOR A CALLING SEQUENCE_^13_]_^1_$DIMENSION I(202)_^13_]_^1C_'SUBEXPRESSION CONSIDERATIONS MUST BE MADE HERE SINCE_^1C_'THE COMPUTATION QUALIFIES AS A USE BUT DOES NOT, UNDER_^1C_'PRESENT LOGIC, CAUSE THE SUBEXP€€RESSION COUNT TO BE DEC-_^1C_'REMENTED._^13_]_^1C_] FTN 3.3_^1_$IREAL=0_^1C_] FTN 3.3_^1_$IF(I(1).EQ.26.OR.I(1).EQ.31)RETURN_^1C_] FTN 3.3_^1_$ISYMX=I(2)_^1_$CALL GETSYM_^1_$IF((ITYPE(ISYMX).EQ.2.OR.ITYPE(ISYMX).EQ.3)_^1_#*_!.AND._^1_#*_!(INBUFF(3).EQ.18.OR.INBUFF(3).EQ.19.OR.INBUFF(3).EQ.21.OR._^1_#*_"INBUFF(3).EQ.42.OR.INBUFF(3).EQ.43))_^1_#*IREAL=ITYPE(ISYMX)-1_^1C_] FTN 3.3€€_^1_$CALL SUBPR3(I(1),I1)_^1_$IF(I1.NE.0) GO TO 10_^1C ************************************************************** 92*3129_^1C_#IF VARIABLE ONLY, SUBSCRIPTED PARTIAL VARIABLE - RETURN_^1_$IF (I(1) .EQ. 30) RETURN_^1C ************************************************************** 92*3129_^1_$I1=1_]_^1_$IF(I(1).EQ.27.OR.I(1).EQ.32) I1=2_^1_$CALL KPC3PR(INDTAB(5),NLDA,I(I1+3))_^1C_€€] FTN 3.3_^1_!10 IF(IREAL.EQ.0) GO TO 11_^1C_#IF DOUBLE PRECISION, GENERATE TRA Q_^1_$IF(IREAL.EQ.2) CALL KPC3PR(INDTAB(9),NTRAQ,0)_^1C_#MULTIPLY INDEX BY TWO USING ALS 1_^1_$CALL KPC3PR(INDTAB(2),NALS,1)_^1C_#IF DOUBLE PRECISION, ADD SAVED INDEX TO MULTIPLY BY THREE_^1_$IF(IREAL.EQ.2) CALL KPC3PR(INDTAB(2),NCON,$834)_^1_!11 J=0_]_^1C_] FTN 3.3_^1_$IF(I1.EQ.2)J=I(3)_^1_$I1=15_^1C€€_#IF NOT RUNANYWHERE, CHANGE INDTAB PTR FOR ADD_^1_$ISYMX=I(2)_^1_$CALL GETSYM_^1_$I11=ITYPE(ISYMX)_^1_$IF(IR.EQ.0.OR.IDUM(ISYMX)+ICOM(ISYMX).NE.0)I1=16_^1C_] FTN 3.3_^1_$IF(IREAL.NE.0) J=(IREAL+1)*J_^1C_] FTN 3.3_^1_$CALL KPCSTK(INDTAB(I1),NADD,I(2) ,J,0)_^1_$IF(I1.EQ.15)CALL KPC3PR(INDTAB(5),NADD,KBIAS)_^1C_#GENERATE LABEL_^1_$CALL LABLER(J)_^1_$ITYPE(ISYMX)=I11_^1_$CALL KPC3PR€8(INDTAB(5),NSTA,J)_^1_$I(1)=36_^1_$I(2)=J_^1_$END_]_^__ 8PWSUB3 CSY/ 33B P€1_$SUBROUTINE SUBPR3(I,I1)_^1_#*_2/DECK-ID 33B FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^13_]_^1C SUBPR3 IS USED IN PHASE B1_^1C_]_^1C_#MASTER LABELED COMMON BLOCK._^1*_] FTN 3.3_^1_$COMMON /A/ IFLAGS,LINECT,LINCT1_^1_$COMMON /A/ IR,IK,IP,IA,IL,IM,I€€XLGO,IOPTO,IOPTV,IOPTC,IOPTD_^1_$COMMON /A/ MCSTRT,MACRNB,MACSEC_^1_$COMMON /A/ IERRS(16),ISRFAD_^1_$COMMON /A/ LGO,ISCRI,ISCRO,IX_^1*_] FTN 3.3_^1_$COMMON /A/ IGLAB(3),IGLAB1,IGLAB2_^1_$COMMON /A/ ICOMT(12),ICOMTS,ICOMX2,ICOMTL,ISUBP,NDPRS,_^1_#$LABX,IBCDTB(48)_^1_$EQUIVALENCE(ICOMB,ICOMT(1)),(ICOMBX,ICOMT(2)),(ICOMDF,_^1_#$ICOMT(3)),(ICOMBN,ICOMT(4))_^1_$DIMENSION ICOMB(6),ICOMB€€X(6),ICOMDF(6),ICOMBN(7)_^1_$COMMON /A/ LOOPTS,LOOPTX,LOOPTB,LOOPT(50)_^1_$EQUIVALENCE(LINDUC,LOOPT(1))_^1_$DIMENSION LINDUC(10)_^1_$EQUIVALENCE (LBEG,LOOPT(2))_^1_$DIMENSION LBEG(10)_^1_$EQUIVALENCE (LINC,LOOPT(3))_^1_$DIMENSION LINC(10)_^1_$EQUIVALENCE (LEND,LOOPT(4))_^1_$DIMENSION LEND(10)_^1_$BYTE(LLABL,LOOPT(5)(14=0)_))_^1_$DIMENSION LLABL(10)_^1_$BYTE(LID,LOOPT(5)(15=15) )_€€^1_$DIMENSION LID(10)_^1_$COMMON /A/ IEQV(255),IEQVS,IEQVN2_^1_$COMMON /A/ ISTAB(150),ISTABS,ISTAB2_^1_$COMMON /A/ IBUFS,ISET(25),LBLANK,KSFCNT,KSNCNT,ISORSC,_^1_#$IHOBIT,ISTNO,ISSFLG,ISUBPN,ITERM,JSORSC,KEQVS_^1C_]_^1C_#SYMBOL TABLE LABELED COMMON BLOCK_^1_$COMMON /A/ ISYMN, ISYMFL,ISYMD,ISYMX,ISYMS,ISYMP,ISYMPC,ISYMPS,_^1_#$ ISYMNS, SYMTAB(960)_^1_$INTEGER SYMTAB_^1_$BYTE (IDUM,S€€YMTAB(1)(15=15)),(KDUMY,SYMTAB(1)(15=15)),_^1_#$(ICLASS,SYMTAB(1)(14=11)),(ITYPE,SYMTAB(1)(10=9))_^1_$DIMENSION IDUM(100),KDUMY(100),ICLASS(100),ITYPE(100)_^1_$BYTE (ISNGL, SYMTAB(1)(8=8)),(KELSIZ,SYMTAB(1)(8=8)),_^1_#$ (ICOM,SYMTAB(1)(7=5)),(IPART,SYMTAB(1)(4=3))_^1_$DIMENSION ISNGL(100),KELSIZ(100),ICOM(100),IPART(100)_^1_$BYTE (KRFCNT,SYMTAB(1)(2=2)),(IDIM,SYMTAB(1)(1=0)),_^1_#$€€ (IREL,SYMTAB(1)(1=1)),(IEXT,SYMTAB(1)(0=0))_^1_$DIMENSION KRFCNT(100),IDIM(100),IREL(100),IEXT(100)_^1_$EQUIVALENCE (IRSA,SYMTAB(2)),(ICOMTX,SYMTAB(2)),(ISNOL,SYMTAB(2))_^1_$DIMENSION IRSA(100), ICOMTX(100),ISNOL(100)_^1_$BYTE (IDATAS,SYMTAB(3)(15=15)),(IREF,SYMTAB(3)(15=15)),_^1_#$ (IEQVX,SYMTAB(3)(14=8)),(ITILF,SYMTAB(3)(14=8))_^1_$DIMENSION IDATAS(100),IREF(100),IEQVX(100),ITIL€€F(100)_^1_$BYTE (IPARTR,SYMTAB(3)(7=4)),(INDUCV,SYMTAB(3)(7=7)),(ISFARG,_^1_#$ SYMTAB(3)(6=6)),(IARGNO,SYMTAB(3)(5=0)),(IPARTL,SYMTAB(3)(3=0))_^1_$DIMENSION IPARTR(100),INDUCV(100),ISFARG(100),IARGNO(100),_^1_#$ IPARTL(100)_^1_$EQUIVALENCE (ISYM,SYMTAB(4))_^1_$DIMENSION ISYM(100)_^1C_]_^1C_#SPECIFICATION-TABLE INDEX LABELLED COMMON BLOCK_^1_$COMMON /A/ ISTABX(96)_^1C_]_^1C_#PHASE 4€€ LABELED COMMON BLOCK._^1_$COMMON /A/ INDTAB(18),INFTB(18)_^1_#2,NBSS ,NADC ,NCON ,NEND ,NPST ,NSTN ,NJMP ,NRTJ ,NLDA_^1_#3,NLDQ ,NSTA ,NSTQ ,NRAO ,NADD ,NSUB ,NAND ,NDVI ,NADQ_^1_#4,NENA ,NINA ,NENQ ,NINQ ,NLRS ,NLLS ,NQRS ,NQLS ,NARS_^1_#5,NALS ,NAJLGZ,NAJEZ ,NAJLZ ,NAJGEZ,NAJLEZ,NAJGZ ,NQJEZ ,NMUI_^1_$COMMON/A/_^1_#1 NFCM ,NFSB ,NFMU ,NFDV ,NFLD ,NF€€ST ,NFAD ,NCAQA_^1_#2,NTCQA ,NTRAQ ,KLDQ ,KSTQ ,NTCAA ,NEOR ,NTCQQ_^1_#3,INFTBL,INFTBN,INFTBX_^1_$DIMENSION KODNAM(18), KFTYPE(6),NLINE(6),NPMTRS(6),KSPTAB(14)_^1_$EQUIVALENCE (INFTB(1),KODNAM(1)),(ISET(11),KSPTAB(1))_^1_$BYTE (KFTYPE,INFTB(3)(15=14)),(NLINE,INFTB(3)(13=13)),_^1_#$ (NPMTRS,INFTB(3)(12=0))_^1C_]_^1C_#PHASE 4 BLANK COMMON BLOCK._^1_$COMMON//JSYM(3),_^1C ********€€************************** FTN 3.1 **************************_^1_#1 INBUFF(304),OUTBUF(10),KART(2,3,3),KQ(5),KFCET(5,3),_^1C ********************************** FTN 3.1 ($) **********************_^1_#2 KSUBAT(240),KSFAT(12,2),KLLTB(10,2),LPTYP(10),_^1_#3 INTRAS(304),IMOD(30),NDTYP(30),NBRNS(30),ICBRN(30),_^1_#4 KOP(30),KTRUT(30)_^1_$DIMENSION KFALS(30),KFATH(30),KOMPSW(30),KSBPTR(€€30),KRESW(30)_^1_$EQUIVALENCE (KFALS(1),ISTAB(1)),(KFATH(1),ISTAB(31)),_^1_#1 (KOMPSW(1),ISTAB(61)),(KSBPTR(1),ISTAB(91)),(KRESW(1),ISTAB(121))_^1_$COMMON// LTYP,MBEGIN_^1_#1,IADDIT,INTRAX,IPTR,ISBSCP,JXX,KBEGIN,KBIAS,KBYTX,KENTER,KENTRY_^1_#2,KEXEC,KEXTYP,KFCSW,KFFSAV,KFINDX,KFLAM,KINTYP,KLLTBX,KNTROL_^1_#3,KOBX,KPRNAM,KQSAV,KRETRN,KSFNAM,KTCATX,LEVEL,LIFTX,LOGIF,KFCETX_^1_$DIMENS€€ION NINVS(30),NINENC(30),NPASS(30)_^1_$EQUIVALENCE (KTRUT(1),NINVS(1)),(KFALS(1),NINENC(1))_^1_#1,(KFATH(1),NPASS(1))_^1_$INTEGER OUTBUF_^1C_]_^1C_]_^1C_#PROCESS SUBSCRIPT EXPRESSION_^1_$DIMENSION I(202)_^1C_#INCREMENT ONLY_^1_$I1=0_]_^1C_#PARTIAL VARIABLE ONLY_^1_$IF((I(1).EQ.25.OR.I(1).EQ.30).AND.I(3).EQ.29)GO TO10_^1C_#PARTIAL VARIABLE WITH INCREMENT_^1_$IF((I(1).EQ.27.OR.I(1)€ú.EQ. 32).AND.I(4).EQ.29) GO TO 20_^1C_#NON-COMPLEX_^1_$IF(I(1).NE.28.AND.I(1).NE.33)RETURN_^1C_#COMPLEX_^1_$CALL ACP(I(4))_^1_$I(1)=I(1)-1_^1_"5 I1=2_]_^1_$RETURN_^1_!20 CALL PARTSB(I(4))_^1_$GO TO 5_^1_!10 CALL PARTSB(I(3))_^1_$I1=1_]_^1_$END_]_^__úPWRITHR CSY/ 34B P€1_$SUBROUTINE ARITHR_^1_#*_2/DECK-ID 34B FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^13_]_^1C ********************************** FTN 3.1 **************************_^1C_]_^1C_FARITHR IS USED IN PHASE B_^1C_]_^1C_FMASTER LABELED COMMON BLOCK_^1C_]_^1*_]€€ FTN 3.3_^1_$COMMON /A/ IFLAGS,LINECT,LINCT1_^1_$COMMON /A/ IR,IK,IP,IA,IL,IM,IXLGO,IOPTO,IOPTV,IOPTC,IOPTD_^1_$COMMON /A/ MCSTRT,MACRNB,MACSEC_^1_$COMMON /A/ IERRS(16),ISRFAD_^1_$COMMON /A/ LGO,ISCRI,ISCRO,IX_^1*_] FTN 3.3_^1_$COMMON /A/ IGLAB(3),IGLAB1,IGLAB2_^1_$COMMON /A/ ICOMT(12),ICOMTS,ICOMX2,ICOMTL,ISUBP,NDPRS_^1_$COMMON /A/ LABX,IBCDTB(48)_^1_$COMMON /A/ LOOPTS,LOOPTX,LO€€OPTB,LOOPT(50)_^1_$COMMON /A/ IEQV(255),IEQVS,IEQVN2_^1_$COMMON /A/ ISTAB(150),ISTABS,ISTAB2_^1_$COMMON /A/ IBUFS,ISET(25),LBLANK,KSFCNT,KSNCNT,ISORSC_^1_$COMMON /A/ IHOBIT,ISTNO,ISSFLG,ISUBPN,ITERM,JSORSC,KEQVS_^1C_]_^1_$EQUIVALENCE (ICOMB,ICOMT(1)), (ICOMBX,ICOMT(2))_^1_$EQUIVALENCE (ICOMDF,ICOMT(3)), (ICOMBN,ICOMT(4))_^1_$EQUIVALENCE (LINDUC,LOOPT(1)), (LBEG,LOOPT(2))_^1_$EQUIVA€€LENCE (LINC,LOOPT(3)), (LEND,LOOPT(4))_^1_$EQUIVALENCE (KFALS,ISTAB(1)), (KFATH,ISTAB(31))_^1_$EQUIVALENCE (KOMPSW,ISTAB(61)), (KSBPTR,ISTAB(91))_^1_$EQUIVALENCE (KRESW,ISTAB(121))_^1_$EQUIVALENCE (KSPTAB,ISET(11))_^1C_]_^1_$BYTE (LLABL,LOOPT(5)(14=0))_^1_$BYTE (LID,LOOPT(5)(15=15))_^1C_]_^1_$DIMENSION ICOMB(6), ICOMBX(6), ICOMDF(6), ICOMBN(7)_^1_$DIMENSION LINDUC(10), LBEG(10), LI€€NC(10), LEND(10)_^1_$DIMENSION LLABL(10), LID(10)_^1_$DIMENSION KFALS(30), KFATH(30), KOMPSW(30), KSBPTR(30), KRESW(30)_^1_$DIMENSION KSPTAB(14)_^1C_]_^1_$EQUIVALENCE (NINENC,KFALS(1)), (NPASS,KFATH(1))_^1_$DIMENSION NINENC(30), NPASS(30)_^1C_]_^1C_FSYMBOL TABLE LABELED COMMON BLOC_^1C_]_^1_$COMMON /A/ ISYMN,ISYMFL,ISYMD,ISYMX,ISYMS,ISYMP,ISYMPC,ISYMPS_^1_$COMMON /A/ ISYMNS,SYMTAB(€€960)_^1C_]_^1_$INTEGER SYMTAB_^1C_]_^1_$EQUIVALENCE (IRSA,SYMTAB(2)), (ICOMTX,SYMTAB(2))_^1_$EQUIVALENCE (ISNOL,SYMTAB(2))_^1_$EQUIVALENCE (ISYM,SYMTAB(4))_^1C_]_^1_$BYTE (IDUM,SYMTAB(1)(15=15)), (KDUMY,SYMTAB(1)(15=15))_^1_$BYTE (ICLASS,SYMTAB(1)(14=11)), (ITYPE,SYMTAB(1)(10=9))_^1_$BYTE (ISNGL,SYMTAB(1)(8=8)), (KELSIZ,SYMTAB(1)(8=8))_^1_$BYTE (ICOM,SYMTAB(1)(7=5)), (IPART,SYMTAB€€(1)(4=3))_^1_$BYTE (KRFCNT,SYMTAB(1)(2=2)), (IDIM,SYMTAB(1)(1=0))_^1_$BYTE (IREL,SYMTAB(1)(1=1)), (IEXT,SYMTAB(1)(0=0))_^1_$BYTE (IDATAS,SYMTAB(3)(15=15)), (IREF,SYMTAB(3)(15=15))_^1_$BYTE (IEQVX,SYMTAB(3)(14=8)), (ITILF,SYMTAB(3)(14=8))_^1_$BYTE (IPARTR,SYMTAB(3)(7=4)), (INDUCV,SYMTAB(3)(7=7))_^1_$BYTE (ISFARG,SYMTAB(3)(6=6)), (IARGNO,SYMTAB(3)(5=0))_^1_$BYTE (IPARTL,SYMTAB(3)(3=0€€))_^1C_]_^1_$DIMENSION IRSA(100), ICOMTX(100), ISNOL(100), ISYM(100)_^1_$DIMENSION IDUM(100), KDUMY(100), ICLASS(100), ITYPE(100)_^1_$DIMENSION ISNGL(100), KELSIZ(100), ICOM(100), IPART(100)_^1_$DIMENSION KRFCNT(100), IDIM(100), IREL(100), IEXT(100)_^1_$DIMENSION IDATAS(100), IREF(100), IEQVX(100), ITILF(100)_^1_$DIMENSION IPARTR(100), INDUCV(100), ISFARG(100), IARGNO(100)_^1_$DIME€€NSION IPARTL(100)_^1C_]_^1C_FSPECIFICATION-TABLE INDEX LABELD_^1C_FCOMMON BLOCK_^1C_]_^1_$COMMON /A/ ISTABX(96)_^1C_]_^1C_FPHASE 4 LABLED COMMON BLOCK_^1C_]_^1_$COMMON /A/ INDTAB(18),INFTB(18)_^1_$COMMON /A/ NBSS,NADC,NCON,NEND,NPST,NSTN,NJMP,NRTJ,NLDA_^1_$COMMON /A/ NLDQ,NSTA,NSTQ,NRAO,NADD,NSUB,NAND,NDVI,NADQ_^1_$COMMON /A/ NENA,NINA,NENQ,NINQ,NLRS,NLLS,NQRS,NQLS,NARS_^1_$COMMON €€/A/ NALS,NAJLGZ,NAJEZ,NAJLZ,NAJGEZ,NAJLEZ,NAJGZ,NQJEZ,NMUI_^1_$COMMON /A/ NFCM,NFSB,NFMU,NFDV,NFLD,NFST,NFAD,NCAQA_^1_$COMMON /A/ NTCQA,NTRAQ,KLDQ,KSTQ,NTCAA,NEOR,NTCQQ_^1_$COMMON /A/ INFTBL,INFTBN,INFTBX_^1_$COMMON /A/ NDCM,NDSB,NDMU,NDDV,NDLD,NDST,NDAD_^1_$COMMON /A/ IDFLOT,IDSTR1,IDSTR2,IRSTR1,IQ8DFT_^1_$COMMON /A/ IEXD2I,IEXD2F,IEXD2D_^1_$COMMON /A/ IDPFLG_^1*_] FTN 3.3_^1_$CO€€MMON /A/ NFLOF,NFIXF,NDFLOF,NDFIXF_^1*_] FTN 3.3_^1C_]_^1_$EQUIVALENCE (KODNAM,INFTB(1))_^1_$BYTE (KFTYPE,INFTB(3)(15=14)), (NLINE,INFTB(3)(13=13))_^1_$BYTE (NPMTRS,INFTB(3)(12=0))_^1_$DIMENSION KODNAM(18), KFTYPE(6), NLINE(6), NPMTRS(6)_^1C_]_^1C_FPHASE 4 BLANK COMMON BLOCK_^1C_]_^1_$COMMON // JSYM(3)_^1_$COMMON // INBUFF(304), OUTBUF(10), KART(2,3,3), KQ(5), KFCET(5,3)_^1_$COMMO€€N // KSUBAT(240), KSFAT(12,2), KLLTB(10,2), LPTYP(10)_^1_$COMMON // INTRAS(304), IMOD(30), NDTYP(30), NBRNS(30), ICBRN(30)_^1_$COMMON // KOP(30), KTRUT(30)_^1_$COMMON // LTYP,MBEGIN,IADDIT,INTRAX,IPTR,ISBSCP,JXX,KBEGIN,KBIAS_^1_$COMMON // KBYTX,KENTER,KENTRY,KEXEC,KEXTYP,KFCSW,KFFSAV,KFINDX_^1_$COMMON // KFLAM,KINTYP,KLLTBX,KNTROL,KOBX,KPRNAM,KQSAV,KRETRN_^1_$COMMON // KSFNAM,KTCAT€€X,LEVEL,LIFTX,LOGIF,KFCETX_^1_$COMMON // KSTYP,KRTNS,IDMM(5)_^1C_]_^1_$INTEGER OUTBUF_^1_$EQUIVALENCE (NINVS,KTRUT(1))_^1_$DIMENSION NINVS(30)_^1C_]_^1C_FARITHR LOCAL VARS EQUIVALENCED_^1C_FTO BLANK COMMON_^1C_]_^1_$EQUIVALENCE (IJ,IDMM(3)), (IJ1,IDMM(4)), (ISSAV,IDMM(5))_^1C ********************************** FTN 3.1 ($) **********************_^1._]_^1C_#ARITHMETIC REPLACEMENT S€€TATEMENT PROCESSOR_^1C_]_^1C_#IS EXPRESSION OF FORM I(J)=I(J)+1 OR 2_^1_$IZ=0_]_^1_$JXX=JXX+1_^1_$IF(INBUFF(JXX+6).LT.24.OR.INBUFF(JXX+6).GT.27) GO TO 10_^1_$ISYMX=INBUFF(JXX+7)_^1_$CALL GETSYM_^1_$IF(ITYPE(ISYMX).NE.1) GO TO 10_^1C_#INTEGER -I=INDEX OF RIGHT HALF OPERATOR_^1_$I=JXX+INBUFF(JXX+6)-13_^1_$IF(INBUFF(JXX+6).EQ.25) I=I+1_^1_$IF(INBUFF(JXX+6).EQ.26) I=I-1_^1_$IF(INBUFF(€€I).NE. 11.OR.INBUFF(I+1).NE.2) GO TO 10_^1C_#+ 2_]_^1_$J=I+INBUFF(I+2)_^1_"4 IF(INBUFF(J).NE.0) GO TO 10_^1_$IF(INBUFF(J+1).NE. INBUFF(JXX+6)) GO TO 2_^1C_'SAME TYPE OF VARIABLE, LOOK AT REST_^1_$K=I-JXX-10_^1_$DO 1 IJ=1,K_^1_$IJ1=J+1+IJ_^1_$IJ2=JXX+6+IJ_^1_$IF(INBUFF(IJ1).NE.INBUFF(IJ2)) GO TO 10_^1_"1 CONTINUE_^1_$IZ=IZ+3_^1_"3 IF(IZ.GT.3) GO TO 9_^1_$J=I+INBUFF(I+3)_^1_$GO €€TO 4_^1C_#LOOK FOR 1 OR 2_^1_"2 IF(INBUFF(J+1).NE.35) GO TO 10_^1_$ISYMX=INBUFF(J+2)_^1_$ISSAV=ISYMX_^1_$CALL GETSYM_^1_$IF(ITYPE(ISYMX).NE.1.OR.(ISYM(ISYMX).NE.1.AND.ISYM(ISYMX).NE.2))_^1_#1GO TO 10_^1_$IZ=IZ+2_^1_$GO TO 3_^1C_#LOOKED AT 2 BRANCHES_^1_"9 IF(IZ.NE.5) GO TO 10_^1C_#THEY WERE WHAT WE WANTED-PROCESS SUBSCRIPT_^1_$IJ1=0_^1_$IJ=0_]_^1_$IF(INBUFF(JXX+6).EQ.24) GO TO€€ 8_^1_$CALL SUBPR1(INBUFF(JXX+6))_^1_$IF(INBUFF(JXX+6).EQ.25) GO TO 7_^1_$IJ=INBUFF(JXX+8)_^1_$IF(INBUFF(JXX+6).EQ.27) IJ1=INBUFF(JXX+10)_^1_"8 CALL KPCSTK(INDTAB(13),NRAO,INBUFF(JXX+7),IJ,IJ1)_^1_$ISYMX=ISSAV_^1_$CALL GETSYM_^1_$IF(ISYM(ISYMX).EQ.2) CALL KPCSTK(INDTAB(13),NRAO,INBUFF(JXX+7),IJ,_^1_#1IJ1)_]_^1_$RETURN_^1_"7 IJ1=INBUFF(JXX+9)_^1_$GO TO 8_^1C_#NOT I(J)=I(J)+1 OR 2_^1€€_!10 IF(INBUFF(JXX+6).NE.24)GO TO 20_^1_$ISYMX=INBUFF(JXX+7)_^1_$CALL GETSYM_^1_$GO TO 30_^1C_#PROCESS LEFT SUBSCRIPT_^1_!20 CALL SUBPR1(INBUFF(JXX+6))_^1C_#PROCESS RIGHT SIDE_^1_!30 I=JXX+INBUFF(JXX)+5_^1_$CALL ASUPER (INBUFF(I))_^1C_#GET LEFT_^1_$ISYMX=INBUFF(JXX+7)_^1_$CALL GETSYM_^1_$IJ=0_]_^1_$IJ1=0_^1C ********************************** FTN 3.1 **************************_^€€1_$IF (INBUFF(JXX+6).EQ.24 .OR. INBUFF(JXX+6).EQ.29) GO TO 100_^1_$IF (INBUFF(JXX+6).EQ.25 .OR. INBUFF(JXX+6).EQ.30) GO TO 50_^1_$IJ = INBUFF(JXX+8)_^1_$IF (INBUFF(JXX+6).EQ.27 .OR. INBUFF(JXX+6).EQ.32)_^1_#-_!IJ1 = INBUFF(JXX+10)_^1_$GO TO 100_^1 50_!IJ1 = INBUFF(JXX+9)_^1C_]_^1C_FSTORE RIGHT SIDE, WHICH HAS BEEN_^1C_FLOADED, INTO LEFT SIDE_^1C_]_^1 100 IF (ITYPE(ISYMX).EQ.2) €€GO TO 130_^1_$IF (ITYPE(ISYMX).EQ.3) GO TO 150_^1C_]_^1C_FINTEGER/PARTIAL ON LEFT_^1C_]_^1_$IF (KEXTYP.EQ.0) GO TO 110_^1C_]_^1C_FREAL OR DOUBLE ON RIGHT_^1C_]_^1*_YBEGIN FTN 3.3_^1_$IF(KEXTYP.EQ.1) N=NFLOF_^1_$IF(KEXTYP.EQ.2) N=NDFLOF_^1_$CALL KPCSTK(INDTAB(13),N,INBUFF(JXX+7),IJ,IJ1)_^1_$GO TO 199_^1*_[END FTN 3.3_^1C_]_^1C_FINTEGER ON RIGHT, TEST FOR_^1C_FPARTIAL ON LEFT_^1C_]€€_^1 110 IF (IPART(ISYMX).EQ.0) GO TO 120_^1C_]_^1C_FPARTIAL ON LEFT_^1C_]_^1_$CALL KPCSTK(INDTAB(13),NLDQ,INBUFF(JXX+7),IJ,IJ1)_^1_$ISYMX = INBUFF(JXX+7)_^1_$CALL GETSYM_^1_$IF (IPARTR(ISYMX).NE.0)_^1_#-_!CALL KPC3PR(INDTAB(2),NQLS,16-IPARTR(ISYMX))_^1_$CALL KPC3PR(INDTAB(2),NLLS,15-IPARTL(ISYMX)+IPARTR(ISYMX))_^1_$IF (IPARTL(ISYMX).NE.15)_^1_#-_!CALL KPC3PR(INDTAB(2),NALS,IPARTL€€(ISYMX)+1)_^1C_]_^1C_FINTEGER ON LEFT_^1C_]_^1 120 CALL KPCSTK(INDTAB(13),NSTA,INBUFF(JXX+7),IJ,IJ1)_^1_$GO TO 199_^1C_]_^1C_FREAL ON LEFT_^1C_]_^1*_YBEGIN FTN 3.3_^1 130 IF(KEXTYP.NE.0) GO TO 140_^1*_[END FTN 3.3_^1C_]_^1C_FINTEGER ON RIGHT_^1C_]_^1*_YBEGIN FTN 3.3_^1_$K=NFIXF_^1_$ASSIGN 140 TO J_^1_$GO TO 200_^1*_[END FTN 3.3_^1C_]_^1*_EREAL OR DOUBLE ON RIGHT_^1C_]_^1 140 IJ=€€2*IJ_^1_$CALL KPCSTK(INDTAB(13),NFST,INBUFF(JXX+7),IJ,IJ1)_^1_$GO TO 199_^1*_#5 CARDS DELETED FTN 3.3_^1C_]_^1C_FDOUBLE ON LEFT_^1C_]_^1*_YBEGIN FTN 3.3_^1 150 IF(KEXTYP.NE.0) GO TO 170_^1*_[END FTN 3.3_^1C_]_^1C_FINTEGER ON RIGHT (Q8DFLT)_^1C_]_^1*_YBEGIN FTN 3.3_^1_$K=NDFIXF_^1_$ASSIGN 170 TO J_^1_$GO TO 200_^1*_[END FTN 3.3_^1*_#12 CARDS DELETED FTN 3.3_^1C_]_^1*_EDOUBLE ON RI€€GHT_^1C_]_^1*_YBEGIN FTN 3.3_^1 170 IJ=3*IJ_^1_$CALL KPCSTK(INDTAB(13),NDST,INBUFF(JXX+7),IJ,IJ1)_^1*_[END FTN 3.3_^1 199 RETURN_^13_]_^1*_YBEGIN FTN 3.3_^1*_#GENERATE : STA_)TEMP_^1*_0FIXF/DFIXF_!TEMP_^11_]_^1 200 CALL TSALOC(IPTR,1)_^1_$CALL KPC3PR(INDTAB(5),NSTA,IPTR)_^1_$KNTROL=4_^1_$CALL INTRAM_^1_$CALL KPC3PR(INDTAB(5),K,IPTR)_^1_$GO TO J_^1*_[END FTN 3.3_^12_]_^1_$END_]_€^__ PWBKDN1 CSY/ 01C P€1_$SUBROUTINE BKDWN_^1_#*_2/DECK-ID 01C FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^13_]_^1C BKDWN IS USED IN PHASE C_^1C NON-IDENTICAL BKDWN USED IN PHASES D,E_^1C_]_^1C_#MASTER LABELED COMMON BLOCK._^1*_] FTN 3.3_^1_$COMMON /A/ IFLAGS,LINECT,LINCT1€€_^1_$COMMON /A/ IR,IK,IP,IA,IL,IM,IXLGO,IOPTO,IOPTV,IOPTC,IOPTD_^1_$COMMON /A/ MCSTRT,MACRNB,MACSEC_^1_$COMMON /A/ IERRS(16),ISRFAD_^1_$COMMON /A/ LGO,ISCRI,ISCRO,IX_^1*_] FTN 3.3_^1_$COMMON /A/ IGLAB(3),IGLAB1,IGLAB2_^1_$COMMON /A/ ICOMT(12),ICOMTS,ICOMX2,ICOMTL,ISUBP,NDPRS,_^1_#$LABX,IBCDTB(48)_^1_$EQUIVALENCE(ICOMB,ICOMT(1)),(ICOMBX,ICOMT(2)),(ICOMDF,_^1_#$ICOMT(3)),(ICOMBN,ICO€€MT(4))_^1_$DIMENSION ICOMB(6),ICOMBX(6),ICOMDF(6),ICOMBN(7)_^1_$COMMON /A/ LOOPTS,LOOPTX,LOOPTB,LOOPT(50)_^1_$EQUIVALENCE(LINDUC,LOOPT(1))_^1_$DIMENSION LINDUC(10)_^1_$EQUIVALENCE (LBEG,LOOPT(2))_^1_$DIMENSION LBEG(10)_^1_$EQUIVALENCE (LINC,LOOPT(3))_^1_$DIMENSION LINC(10)_^1_$EQUIVALENCE (LEND,LOOPT(4))_^1_$DIMENSION LEND(10)_^1_$BYTE(LLABL,LOOPT(5)(14=0)_))_^1_$DIMENSION LLABL(1€€0)_^1_$BYTE(LID,LOOPT(5)(15=15) )_^1_$DIMENSION LID(10)_^1_$COMMON/A/IEQV(255), IEQVS,IEQVN2_^1_$COMMON /A/ ISTAB(150),ISTABS,ISTAB2_^1_$COMMON /A/ IBUFS,ISET(25),LBLANK,KSFCNT,KSNCNT,ISORSC,_^1_#$IHOBIT,ISTNO,ISSFLG,ISUBPN,ITERM,JSORSC,KEQVS_^1C_#SYMBOL TABLE LABELED COMMON BLOCK_^1_$COMMON /A/ ISYMN, ISYMFL,ISYMD,ISYMX,ISYMS,ISYMP,ISYMPC,ISYMPS,_^1_#$ ISYMNS, SYMTAB(2400)_^1_$IN€€TEGER SYMTAB_^1_$BYTE (IDUM,SYMTAB(1)(15=15)),(KDUMY,SYMTAB(1)(15=15)),_^1_#$(ICLASS,SYMTAB(1)(14=11)),(ITYPE,SYMTAB(1)(10=9))_^1_$DIMENSION IDUM(100),KDUMY(100),ICLASS(100),ITYPE(100)_^1_$BYTE (ISNGL, SYMTAB(1)(8=8)),(KELSIZ,SYMTAB(1)(8=8)),_^1_#$ (ICOM,SYMTAB(1)(7=5)),(IPART,SYMTAB(1)(4=3))_^1_$DIMENSION ISNGL(100),KELSIZ(100),ICOM(100),IPART(100)_^1_$BYTE (KRFCNT,SYMTAB(1)(2=2))€€,(IDIM,SYMTAB(1)(1=0)),_^1_#$ (IREL,SYMTAB(1)(1=1)),(IEXT,SYMTAB(1)(0=0))_^1_$DIMENSION KRFCNT(100),IDIM(100),IREL(100),IEXT(100)_^1_$EQUIVALENCE (IRSA,SYMTAB(2)),(ICOMTX,SYMTAB(2)),(ISNOL,SYMTAB(2))_^1_$DIMENSION IRSA(100), ICOMTX(100),ISNOL(100)_^1_$BYTE (IDATAS,SYMTAB(3)(15=15)),(IREF,SYMTAB(3)(15=15)),_^1_#$ (IEQVX,SYMTAB(3)(14=8)),(ITILF,SYMTAB(3)(14=8))_^1_$DIMENSION IDATAS(1€€00),IREF(100),IEQVX(100),ITILF(100)_^1_$BYTE (IPARTR,SYMTAB(3)(7=4)),(INDUCV,SYMTAB(3)(7=7)),(ISFARG,_^1_#$ SYMTAB(3)(6=6)),(IARGNO,SYMTAB(3)(5=0)),(IPARTL,SYMTAB(3)(3=0))_^1_$DIMENSION IPARTR(100),INDUCV(100),ISFARG(100),IARGNO(100),_^1_#$ IPARTL(100)_^1_$EQUIVALENCE (ISYM,SYMTAB(4))_^1_$DIMENSION ISYM(100)_^1C_]_^1C_#PHASE C, D, E LABELED COMMON BLOCK_^1_$EQUIVALENCE (NBLK(1),LOO€€PTS)_^1_$DIMENSION NBLK(446)_^1_$EQUIVALENCE (NPCBF(1),NBLK(1)),(IDVTAB(1),NBLK(58))_^1_$EQUIVALENCE (NSUMDS,NBLK(370))_^1C_#PUNCH BUFFER, ADDRESS HOLDERS, PRINT BUFFER, INDEX HISTORY TABLES_^1_$EQUIVALENCE(NPTBF,NBLK(371)),(IXS1,NBLK(426)),(IXS2,NBLK(436))_^1C_$INDEX REGISTER HOLDERS FOR SUBROUTINE IXOPT_^1_$DIMENSION NPCBF(57),IDVTAB(312),NPTBF(55),IXS1(10),IXS2(10)_^1C_]_^1C_#PH€€ASE C BLANK COMMON BLOCK_^1C_#INPUT BUFFER, OUTPUT BUFFER, OUTPUT RECORD HOLDER_^1_$COMMON//INBUFF(203),NOBUFF(210),NRCD(5)_^1_$COMMON//NFTAB(160),NDSTAB(500)_^1_$COMMON//IV(5),IXS3(10)_^1_$COMMON//NSUMD,NDFL,NADX,NSUMVS,IXC,IXFLAG,IXF,IXQ_^1_$COMMON//IXSX,IUSE,IFIX,NOUTOT,NOWO,NL,NT,NA,NS,ND,NR,NQ,NF_^1_$COMMON//NTYPE,NOWI,NOPC,NOPT,NADD,NXPT_^1_$COMMON//NATYPE,ICT,INCT,NOCT,NSTYP€€E,LRS,NOBW,NBINC,NPC1_^1_$COMMON//NSETX,NRM,NPTBFX,NRC1,NRC2,NW2FL,NW2,NBFL,NXCON_^1_$COMMON//NASCI,ISCOUN,ICOUNT,NOFS,NODS,NDXJ,NX_^1_$COMMON// IHEAD, INOB, INC_^1C_]_^1_$EQUIVALENCE(IND(1),NL)_^1_$DIMENSION IND(14)_^1_$EQUIVALENCE(ICFLG,IV(2)),(ITCOUN,IV(3)),(IDECR,IV(4))_^1_$DO 5 I = 9,14_^1_"5 IND(I) = 0_^1_$IJK=INBUFF(NX)_^1_$IF (IJK .LT. 0) NL=1_^1_$N=$4000_^1_$DO 10 I=2,8_^1€ä_$IND(I)=AND(IJK/N,1)_^1_!10 N = N/2_^1_$NTYPE=AND(IJK/4,63)_^1_$NOWI=AND(IJK,3)+2_^1_$J = NX+1_^1_$K = NOWI+9_^1_$DO 20 I = 11,K_^1_$IND(I) = INBUFF(J)_^1_!20 J = J+1_^1_$IF(NA.NE.0)RETURN_^1_$NXPT=NADD_^1_$NADD=0_^1_$END_]_^__äPWBLDUP CSY/ 02C P€1_$SUBROUTINE BLDUP_^1_#*_2/DECK-ID 02C FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^13_]_^1C BLDUP IS USED IN PHASE C_^1C_#MASTER LABELED COMMON BLOCK._^1*_] FTN 3.3_^1_$COMMON /A/ IFLAGS,LINECT,LINCT1_^1_$COMMON /A/ IR,IK,IP,IA,IL,IM,IXLGO,IOPTO,IOPT€€V,IOPTC,IOPTD_^1_$COMMON /A/ MCSTRT,MACRNB,MACSEC_^1_$COMMON /A/ IERRS(16),ISRFAD_^1_$COMMON /A/ LGO,ISCRI,ISCRO,IX_^1*_] FTN 3.3_^1_$COMMON /A/ IGLAB(3),IGLAB1,IGLAB2_^1_$COMMON /A/ ICOMT(12),ICOMTS,ICOMX2,ICOMTL,ISUBP,NDPRS,_^1_#$LABX,IBCDTB(48)_^1_$EQUIVALENCE(ICOMB,ICOMT(1)),(ICOMBX,ICOMT(2)),(ICOMDF,_^1_#$ICOMT(3)),(ICOMBN,ICOMT(4))_^1_$DIMENSION ICOMB(6),ICOMBX(6),ICOMDF(6),€€ICOMBN(7)_^1_$COMMON /A/ LOOPTS,LOOPTX,LOOPTB,LOOPT(50)_^1_$EQUIVALENCE(LINDUC,LOOPT(1))_^1_$DIMENSION LINDUC(10)_^1_$EQUIVALENCE (LBEG,LOOPT(2))_^1_$DIMENSION LBEG(10)_^1_$EQUIVALENCE (LINC,LOOPT(3))_^1_$DIMENSION LINC(10)_^1_$EQUIVALENCE (LEND,LOOPT(4))_^1_$DIMENSION LEND(10)_^1_$BYTE(LLABL,LOOPT(5)(14=0)_))_^1_$DIMENSION LLABL(10)_^1_$BYTE(LID,LOOPT(5)(15=15) )_^1_$DIMENSION L€€ID(10)_^1_$COMMON/A/IEQV(255), IEQVS,IEQVN2_^1_$COMMON /A/ ISTAB(150),ISTABS,ISTAB2_^1_$COMMON /A/ IBUFS,ISET(25),LBLANK,KSFCNT,KSNCNT,ISORSC,_^1_#$IHOBIT,ISTNO,ISSFLG,ISUBPN,ITERM,JSORSC,KEQVS_^1C_#SYMBOL TABLE LABELED COMMON BLOCK_^1_$COMMON /A/ ISYMN, ISYMFL,ISYMD,ISYMX,ISYMS,ISYMP,ISYMPC,ISYMPS,_^1_#$ ISYMNS, SYMTAB(2400)_^1_$INTEGER SYMTAB_^1_$BYTE (IDUM,SYMTAB(1)(15=15)),(KDU€€MY,SYMTAB(1)(15=15)),_^1_#$(ICLASS,SYMTAB(1)(14=11)),(ITYPE,SYMTAB(1)(10=9))_^1_$DIMENSION IDUM(100),KDUMY(100),ICLASS(100),ITYPE(100)_^1_$BYTE (ISNGL, SYMTAB(1)(8=8)),(KELSIZ,SYMTAB(1)(8=8)),_^1_#$ (ICOM,SYMTAB(1)(7=5)),(IPART,SYMTAB(1)(4=3))_^1_$DIMENSION ISNGL(100),KELSIZ(100),ICOM(100),IPART(100)_^1_$BYTE (KRFCNT,SYMTAB(1)(2=2)),(IDIM,SYMTAB(1)(1=0)),_^1_#$ (IREL,SYMTAB(1)(1=1)€€),(IEXT,SYMTAB(1)(0=0))_^1_$DIMENSION KRFCNT(100),IDIM(100),IREL(100),IEXT(100)_^1_$EQUIVALENCE (IRSA,SYMTAB(2)),(ICOMTX,SYMTAB(2)),(ISNOL,SYMTAB(2))_^1_$DIMENSION IRSA(100), ICOMTX(100),ISNOL(100)_^1_$BYTE (IDATAS,SYMTAB(3)(15=15)),(IREF,SYMTAB(3)(15=15)),_^1_#$ (IEQVX,SYMTAB(3)(14=8)),(ITILF,SYMTAB(3)(14=8))_^1_$DIMENSION IDATAS(100),IREF(100),IEQVX(100),ITILF(100)_^1_$BYTE (IPAR€€TR,SYMTAB(3)(7=4)),(INDUCV,SYMTAB(3)(7=7)),(ISFARG,_^1_#$ SYMTAB(3)(6=6)),(IARGNO,SYMTAB(3)(5=0)),(IPARTL,SYMTAB(3)(3=0))_^1_$DIMENSION IPARTR(100),INDUCV(100),ISFARG(100),IARGNO(100),_^1_#$ IPARTL(100)_^1_$EQUIVALENCE (ISYM,SYMTAB(4))_^1_$DIMENSION ISYM(100)_^1C_]_^1C_#PHASE C, D, E LABELED COMMON BLOCK_^1_$EQUIVALENCE (NBLK(1),LOOPTS)_^1_$DIMENSION NBLK(446)_^1_$EQUIVALENCE (NPCB€€F(1),NBLK(1)),(IDVTAB(1),NBLK(58))_^1_$EQUIVALENCE (NSUMDS,NBLK(370))_^1C_#PUNCH BUFFER, ADDRESS HOLDERS, PRINT BUFFER, INDEX HISTORY TABLES_^1_$EQUIVALENCE(NPTBF,NBLK(371)),(IXS1,NBLK(426)),(IXS2,NBLK(436))_^1C_$INDEX REGISTER HOLDERS FOR SUBROUTINE IXOPT_^1_$DIMENSION NPCBF(57),IDVTAB(312),NPTBF(55),IXS1(10),IXS2(10)_^1C_]_^1C_#PHASE C BLANK COMMON BLOCK_^1C_#INPUT BUFFER, OUTPUT€€ BUFFER, OUTPUT RECORD HOLDER_^1_$COMMON//INBUFF(203),NOBUFF(210),NRCD(5)_^1_$COMMON//NFTAB(160),NDSTAB(500)_^1_$COMMON//IV(5),IXS3(10)_^1_$COMMON//NSUMD,NDFL,NADX,NSUMVS,IXC,IXFLAG,IXF,IXQ_^1_$COMMON//IXSX,IUSE,IFIX,NOUTOT,NOWO,NL,NT,NA,NS,ND,NR,NQ,NF_^1_$COMMON//NTYPE,NOWI,NOPC,NOPT,NADD,NXPT_^1_$COMMON//NATYPE,ICT,INCT,NOCT,NSTYPE,LRS,NOBW,NBINC,NPC1_^1_$COMMON//NSETX,NRM,NPTBFX€€,NRC1,NRC2,NW2FL,NW2,NBFL,NXCON_^1_$COMMON//NASCI,ISCOUN,ICOUNT,NOFS,NODS,NDXJ,NX_^1_$COMMON// IHEAD, INOB, INC_^1C_]_^1_$EQUIVALENCE(IND(1),NL)_^1_$DIMENSION IND(14)_^1_$EQUIVALENCE(ICFLG,IV(2)),(ITCOUN,IV(3)),(IDECR,IV(4))_^1_$NRCD(1)=0_^1_$IF(NL.NE.0)NRCD(1)=$8000_^1_$N=$4000_^1_$DO 10 I=2,8_^1_$NRCD(1)=OR(NRCD(1),IND(I)*N)_^1_!10 N = N/2_^1_$NRCD(1)=OR(NRCD(1),NATYPE*4+NOWO-2)_€F^1_$NRCD(3) = NOPT_^1_$NRCD(4) = NADD_^1_$NRCD(5) = NXPT_^1_$END_]_^__FPWBSS CSY/ 03C P€1_$SUBROUTINE BSS_^1_#*_2/DECK-ID 03C FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^13_]_^1C BSS IS USED IN PHASE C_^1C_]_^1C_#MASTER LABELED COMMON BLOCK._^1*_] FTN 3.3_^1_$COMMON /A/ IFLAGS,LINECT,LINCT1_^1_$COMMON /A/ IR,IK,IP,IA,IL,IM,IXLGO,IOPTO,IO€€PTV,IOPTC,IOPTD_^1_$COMMON /A/ MCSTRT,MACRNB,MACSEC_^1_$COMMON /A/ IERRS(16),ISRFAD_^1_$COMMON /A/ LGO,ISCRI,ISCRO,IX_^1*_] FTN 3.3_^1_$COMMON /A/ IGLAB(3),IGLAB1,IGLAB2_^1_$COMMON /A/ ICOMT(12),ICOMTS,ICOMX2,ICOMTL,ISUBP,NDPRS,_^1_#$LABX,IBCDTB(48)_^1_$EQUIVALENCE(ICOMB,ICOMT(1)),(ICOMBX,ICOMT(2)),(ICOMDF,_^1_#$ICOMT(3)),(ICOMBN,ICOMT(4))_^1_$DIMENSION ICOMB(6),ICOMBX(6),ICOMDF(6€€),ICOMBN(7)_^1_$COMMON /A/ LOOPTS,LOOPTX,LOOPTB,LOOPT(50)_^1_$EQUIVALENCE(LINDUC,LOOPT(1))_^1_$DIMENSION LINDUC(10)_^1_$EQUIVALENCE (LBEG,LOOPT(2))_^1_$DIMENSION LBEG(10)_^1_$EQUIVALENCE (LINC,LOOPT(3))_^1_$DIMENSION LINC(10)_^1_$EQUIVALENCE (LEND,LOOPT(4))_^1_$DIMENSION LEND(10)_^1_$BYTE(LLABL,LOOPT(5)(14=0)_))_^1_$DIMENSION LLABL(10)_^1_$BYTE(LID,LOOPT(5)(15=15) )_^1_$DIMENSION€€ LID(10)_^1_$COMMON/A/IEQV(255), IEQVS,IEQVN2_^1_$COMMON /A/ ISTAB(150),ISTABS,ISTAB2_^1_$COMMON /A/ IBUFS,ISET(25),LBLANK,KSFCNT,KSNCNT,ISORSC,_^1_#$IHOBIT,ISTNO,ISSFLG,ISUBPN,ITERM,JSORSC,KEQVS_^1C_#SYMBOL TABLE LABELED COMMON BLOCK_^1_$COMMON /A/ ISYMN, ISYMFL,ISYMD,ISYMX,ISYMS,ISYMP,ISYMPC,ISYMPS,_^1_#$ ISYMNS, SYMTAB(2400)_^1_$INTEGER SYMTAB_^1_$BYTE (IDUM,SYMTAB(1)(15=15)),(K€€DUMY,SYMTAB(1)(15=15)),_^1_#$(ICLASS,SYMTAB(1)(14=11)),(ITYPE,SYMTAB(1)(10=9))_^1_$DIMENSION IDUM(100),KDUMY(100),ICLASS(100),ITYPE(100)_^1_$BYTE (ISNGL, SYMTAB(1)(8=8)),(KELSIZ,SYMTAB(1)(8=8)),_^1_#$ (ICOM,SYMTAB(1)(7=5)),(IPART,SYMTAB(1)(4=3))_^1_$DIMENSION ISNGL(100),KELSIZ(100),ICOM(100),IPART(100)_^1_$BYTE (KRFCNT,SYMTAB(1)(2=2)),(IDIM,SYMTAB(1)(1=0)),_^1_#$ (IREL,SYMTAB(1)(1=€€1)),(IEXT,SYMTAB(1)(0=0))_^1_$DIMENSION KRFCNT(100),IDIM(100),IREL(100),IEXT(100)_^1_$EQUIVALENCE (IRSA,SYMTAB(2)),(ICOMTX,SYMTAB(2)),(ISNOL,SYMTAB(2))_^1_$DIMENSION IRSA(100), ICOMTX(100),ISNOL(100)_^1_$BYTE (IDATAS,SYMTAB(3)(15=15)),(IREF,SYMTAB(3)(15=15)),_^1_#$ (IEQVX,SYMTAB(3)(14=8)),(ITILF,SYMTAB(3)(14=8))_^1_$DIMENSION IDATAS(100),IREF(100),IEQVX(100),ITILF(100)_^1_$BYTE (IP€€ARTR,SYMTAB(3)(7=4)),(INDUCV,SYMTAB(3)(7=7)),(ISFARG,_^1_#$ SYMTAB(3)(6=6)),(IARGNO,SYMTAB(3)(5=0)),(IPARTL,SYMTAB(3)(3=0))_^1_$DIMENSION IPARTR(100),INDUCV(100),ISFARG(100),IARGNO(100),_^1_#$ IPARTL(100)_^1_$EQUIVALENCE (ISYM,SYMTAB(4))_^1_$DIMENSION ISYM(100)_^1C_]_^1C_#PHASE C, D, E LABELED COMMON BLOCK_^1_$EQUIVALENCE (NBLK(1),LOOPTS)_^1_$DIMENSION NBLK(446)_^1_$EQUIVALENCE (NP€€CBF(1),NBLK(1)),(IDVTAB(1),NBLK(58))_^1_$EQUIVALENCE (NSUMDS,NBLK(370))_^1C_#PUNCH BUFFER, ADDRESS HOLDERS, PRINT BUFFER, INDEX HISTORY TABLES_^1_$EQUIVALENCE(NPTBF,NBLK(371)),(IXS1,NBLK(426)),(IXS2,NBLK(436))_^1C_$INDEX REGISTER HOLDERS FOR SUBROUTINE IXOPT_^1_$DIMENSION NPCBF(57),IDVTAB(312),NPTBF(55),IXS1(10),IXS2(10)_^1C_]_^1C_#PHASE C BLANK COMMON BLOCK_^1C_#INPUT BUFFER, OUTP€€UT BUFFER, OUTPUT RECORD HOLDER_^1_$COMMON//INBUFF(203),NOBUFF(210),NRCD(5)_^1_$COMMON//NFTAB(160),NDSTAB(500)_^1_$COMMON//IV(5),IXS3(10)_^1_$COMMON//NSUMD,NDFL,NADX,NSUMVS,IXC,IXFLAG,IXF,IXQ_^1_$COMMON//IXSX,IUSE,IFIX,NOUTOT,NOWO,NL,NT,NA,NS,ND,NR,NQ,NF_^1_$COMMON//NTYPE,NOWI,NOPC,NOPT,NADD,NXPT_^1_$COMMON//NATYPE,ICT,INCT,NOCT,NSTYPE,LRS,NOBW,NBINC,NPC1_^1_$COMMON//NSETX,NRM,NPTB€€FX,NRC1,NRC2,NW2FL,NW2,NBFL,NXCON_^1_$COMMON//NASCI,ISCOUN,ICOUNT,NOFS,NODS,NDXJ,NX_^1_$COMMON// IHEAD, INOB, INC_^1C_]_^1_$EQUIVALENCE(IND(1),NL)_^1_$DIMENSION IND(14)_^1_$EQUIVALENCE(ICFLG,IV(2)),(ITCOUN,IV(3)),(IDECR,IV(4))_^1C_2IS THIS TAPE BEGINNING OF_^1C_2COMPILER GENERATED CODE_^1_$NATYPE = 40_^1_$NRCD(2) = NOPT_^1_$IF(NOPT+1.EQ.0)GO TO 10_^1_$ICT = NOPT_^1_$ND=1_]_^1_!10 N€.OWO=2_^1_$NR=0_]_^1_$CALL BLDUP_^1_$END_]_^__ .PWCHKWD CSY/ 04C P€1_$SUBROUTINE CHKWD_^1_#*_2/DECK-ID 04C FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^13_]_^1C CHKWD IS USED IN PHASE C_^1C_]_^1C_#MASTER LABELED COMMON BLOCK._^1*_] FTN 3.3_^1_$COMMON /A/ IFLAGS,LINECT,LINCT1_^1_$COMMON /A/ IR,IK,IP,IA,IL,IM,IXLGO,IOPT€€O,IOPTV,IOPTC,IOPTD_^1_$COMMON /A/ MCSTRT,MACRNB,MACSEC_^1_$COMMON /A/ IERRS(16),ISRFAD_^1_$COMMON /A/ LGO,ISCRI,ISCRO,IX_^1*_] FTN 3.3_^1_$COMMON /A/ IGLAB(3),IGLAB1,IGLAB2_^1_$COMMON /A/ ICOMT(12),ICOMTS,ICOMX2,ICOMTL,ISUBP,NDPRS,_^1_#$LABX,IBCDTB(48)_^1_$EQUIVALENCE(ICOMB,ICOMT(1)),(ICOMBX,ICOMT(2)),(ICOMDF,_^1_#$ICOMT(3)),(ICOMBN,ICOMT(4))_^1_$DIMENSION ICOMB(6),ICOMBX(6),ICOM€€DF(6),ICOMBN(7)_^1_$COMMON /A/ LOOPTS,LOOPTX,LOOPTB,LOOPT(50)_^1_$EQUIVALENCE(LINDUC,LOOPT(1))_^1_$DIMENSION LINDUC(10)_^1_$EQUIVALENCE (LBEG,LOOPT(2))_^1_$DIMENSION LBEG(10)_^1_$EQUIVALENCE (LINC,LOOPT(3))_^1_$DIMENSION LINC(10)_^1_$EQUIVALENCE (LEND,LOOPT(4))_^1_$DIMENSION LEND(10)_^1_$BYTE(LLABL,LOOPT(5)(14=0)_))_^1_$DIMENSION LLABL(10)_^1_$BYTE(LID,LOOPT(5)(15=15) )_^1_$DIMEN€€SION LID(10)_^1_$COMMON/A/IEQV(255), IEQVS,IEQVN2_^1_$COMMON /A/ ISTAB(150),ISTABS,ISTAB2_^1_$COMMON /A/ IBUFS,ISET(25),LBLANK,KSFCNT,KSNCNT,ISORSC,_^1_#$IHOBIT,ISTNO,ISSFLG,ISUBPN,ITERM,JSORSC,KEQVS_^1C_#SYMBOL TABLE LABELED COMMON BLOCK_^1_$COMMON /A/ ISYMN, ISYMFL,ISYMD,ISYMX,ISYMS,ISYMP,ISYMPC,ISYMPS,_^1_#$ ISYMNS, SYMTAB(2400)_^1_$INTEGER SYMTAB_^1_$BYTE (IDUM,SYMTAB(1)(15=15)€€),(KDUMY,SYMTAB(1)(15=15)),_^1_#$(ICLASS,SYMTAB(1)(14=11)),(ITYPE,SYMTAB(1)(10=9))_^1_$DIMENSION IDUM(100),KDUMY(100),ICLASS(100),ITYPE(100)_^1_$BYTE (ISNGL, SYMTAB(1)(8=8)),(KELSIZ,SYMTAB(1)(8=8)),_^1_#$ (ICOM,SYMTAB(1)(7=5)),(IPART,SYMTAB(1)(4=3))_^1_$DIMENSION ISNGL(100),KELSIZ(100),ICOM(100),IPART(100)_^1_$BYTE (KRFCNT,SYMTAB(1)(2=2)),(IDIM,SYMTAB(1)(1=0)),_^1_#$ (IREL,SYMTAB(1€€)(1=1)),(IEXT,SYMTAB(1)(0=0))_^1_$DIMENSION KRFCNT(100),IDIM(100),IREL(100),IEXT(100)_^1_$EQUIVALENCE (IRSA,SYMTAB(2)),(ICOMTX,SYMTAB(2)),(ISNOL,SYMTAB(2))_^1_$DIMENSION IRSA(100), ICOMTX(100),ISNOL(100)_^1_$BYTE (IDATAS,SYMTAB(3)(15=15)),(IREF,SYMTAB(3)(15=15)),_^1_#$ (IEQVX,SYMTAB(3)(14=8)),(ITILF,SYMTAB(3)(14=8))_^1_$DIMENSION IDATAS(100),IREF(100),IEQVX(100),ITILF(100)_^1_$BYTE€€ (IPARTR,SYMTAB(3)(7=4)),(INDUCV,SYMTAB(3)(7=7)),(ISFARG,_^1_#$ SYMTAB(3)(6=6)),(IARGNO,SYMTAB(3)(5=0)),(IPARTL,SYMTAB(3)(3=0))_^1_$DIMENSION IPARTR(100),INDUCV(100),ISFARG(100),IARGNO(100),_^1_#$ IPARTL(100)_^1_$EQUIVALENCE (ISYM,SYMTAB(4))_^1_$DIMENSION ISYM(100)_^1C_]_^1C_#PHASE C, D, E LABELED COMMON BLOCK_^1_$EQUIVALENCE (NBLK(1),LOOPTS)_^1_$DIMENSION NBLK(446)_^1_$EQUIVALENCE€€ (NPCBF(1),NBLK(1)),(IDVTAB(1),NBLK(58))_^1_$EQUIVALENCE (NSUMDS,NBLK(370))_^1C_#PUNCH BUFFER, ADDRESS HOLDERS, PRINT BUFFER, INDEX HISTORY TABLES_^1_$EQUIVALENCE(NPTBF,NBLK(371)),(IXS1,NBLK(426)),(IXS2,NBLK(436))_^1C_$INDEX REGISTER HOLDERS FOR SUBROUTINE IXOPT_^1_$DIMENSION NPCBF(57),IDVTAB(312),NPTBF(55),IXS1(10),IXS2(10)_^1C_]_^1C_#PHASE C BLANK COMMON BLOCK_^1C_#INPUT BUFFER, €€OUTPUT BUFFER, OUTPUT RECORD HOLDER_^1_$COMMON//INBUFF(203),NOBUFF(210),NRCD(5)_^1_$COMMON//NFTAB(160),NDSTAB(500)_^1_$COMMON//IV(5),IXS3(10)_^1_$COMMON//NSUMD,NDFL,NADX,NSUMVS,IXC,IXFLAG,IXF,IXQ_^1_$COMMON//IXSX,IUSE,IFIX,NOUTOT,NOWO,NL,NT,NA,NS,ND,NR,NQ,NF_^1_$COMMON//NTYPE,NOWI,NOPC,NOPT,NADD,NXPT_^1_$COMMON//NATYPE,ICT,INCT,NOCT,NSTYPE,LRS,NOBW,NBINC,NPC1_^1_$COMMON//NSETX,NRM,€€NPTBFX,NRC1,NRC2,NW2FL,NW2,NBFL,NXCON_^1_$COMMON//NASCI,ISCOUN,ICOUNT,NOFS,NODS,NDXJ,NX_^1_$COMMON// IHEAD, INOB, INC_^1C_]_^1_$EQUIVALENCE(IND(1),NL)_^1_$DIMENSION IND(14)_^1_$EQUIVALENCE(ICFLG,IV(2)),(ITCOUN,IV(3)),(IDECR,IV(4))_^1_$IXFLAG=0_^1C_#LABEL OR CONSTANT_^1_$IF(NT.EQ.0.AND.NOPC.NE.3)GO TO 10_^1C_#YES-CLEAR ALL IX STORAGES_^1_$IXF=0_^1_$IXQ=0_^1_$DO 1 I=1,10_^1_$IXS2(I)€€=0_^1_$IXS3(I)=0_^1_"1 IXS1(I)=0_^1_$IXSX=1_^1_$RETURN_^1C_#RTJ_]_^1_!10 IF(NOPC.NE.11) GO TO 20_^1C_#YES_]_^1_$IF(IXF.EQ.0) GO TO 11_^1_$ISYMX=IXF_^1_$CALL GETSYM_^1_$IF(ICOM(ISYMX).NE.0)IXF=0_^1_!11 IF(IXQ.EQ.0) GO TO 12_^1_$ISYMX=IXQ_^1_$CALL GETSYM_^1_$IF(ICOM(ISYMX).NE.0)IXQ=0_^1_!12 ASSIGN 13 TO IAD_^1_$J=0_]_^1_$DO 13 I=1,IXSX_^1_$IF(IXS1(I).EQ.0 ) GO TO 14_^1_$ISYMX=IXS1(I)€€_^1_$CALL GETSYM_^1_$IF(ICOM(ISYMX).NE.0) GO TO 18_^1_!13 CONTINUE_^1_!14 IXSX=IXSX-J_^1_$IF(IX.EQ.0)RETURN_^1_$ISYMX=IX_^1_$CALL GETSYM_^1_$IF(ICOM(ISYMX).NE.0) IXFLAG=1_^1_$RETURN_^1C_#ADC_]_^1_!20 IF(NOPC.NE.2) GO TO 30_^1_!23 IF(NA.EQ.1.AND.NADD.NE.0) RETURN_^1C_#NO_]_^1_!22 IF(NOPT.EQ.IXF) IXF=0_^1_$IF(NOPT.EQ.IXQ) IXQ=0_^1_$J=0_]_^1_$ASSIGN 21 TO IAD_^1_$DO 21 I=1,IXSX_^1_$I€€F(IXS1(I).EQ.NOPT) GO TO 18_^1_!21 CONTINUE_^1_$IXSX=IXSX-J_^1_$IF(IX.EQ.NOPT)IXFLAG=1_^1_$RETURN_^1C_#STORE_^1_!30 IF(NOPC.LT.14.OR.NOPC.GE.17) GO TO 40_^1C_#YES-INDEXED_^1_$ISYMX=NOPT_^1_$CALL GETSYM_^1_$IF(IEQVX(ISYMX).NE. 0)GO TO 330_^1_$IF(NS.EQ. 1) GO TO 22_^1_$GO TO 23_^1 330 J=0_]_^1_$ASSIGN 31 TO IAD_^1_$DO_!31 I=1,IXSX_^1_$IF(IXS3(I).EQ.IEQVX(ISYMX)) GO TO 18_^1_!31 CO€€NTINUE_^1_$IXSX=IXSX-J_^1_$I=IEQVX(ISYMX)_^1_$ISYMX=IX_^1_$CALL GETSYM_^1_$IF(IEQVX(ISYMX).EQ.I) IXFLAG=1_^1_$ISYMX=IXQ_^1_$CALL GETSYM_^1_$IF(I.EQ.IEQVX(ISYMX)) IXQ=0_^1_$ISYMX=IXF_^1_$CALL GETSYM_^1_$IF(I.EQ.IEQVX(ISYMX)) IXF=0_^1_$RETURN_^1_!18 J=J+1_^1C_#MOVE TABLE UP INE WORD_^1_$DO 15 K=I,IXSX_^1_$IXS1(K)=IXS1(K+1)_^1_$IXS2(K)=IXS2(K+1)_^1_!15 IXS3(K)=IXS3(K+1)_^1_$K=IXSX-J_^€€1_$IXS1(K)=0_^1_$IXS2(K)=0_^1_$IXS3(K)=0_^1_$GO TO IAD_^1C_#Q DESTROYER_^1C***********************************************************_#83*2487_^1_!40 IF ((NOPC.GE.19.AND.NOPC.LE.22).OR.(NOPC.GE.32.AND.NOPC.LE.37)_^1_#* .OR.NOPC.EQ.62.OR.NOPC.EQ.64) GO TO 45_^1_%RETURN_^1C_$YES_]_^1_!45 IXQ=0_^1C***********************************************************_#83*2487_^1_$IXC=1_^1_$DO €J 41 I=1,IXSX_^1_$IF(IXS1(I).NE.0) IXS2(I)=1_^1_!41 CONTINUE_^1_$END_]_^__ JPWCHOP CSY/ 05C P€1_$SUBROUTINE CHOP_^1_#*_2/DECK-ID 05C FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^13_]_^1C CHOP IS USED IN PHASE C_^1C THIS IS THE 2.0B VERSION._^1C_]_^1C_#MASTER LABELED COMMON BLOCK._^1*_] FTN 3.3_^1_$COMMON /A/ IFLAGS,LINECT,LINCT1_^1_$COMMON /A/ €€IR,IK,IP,IA,IL,IM,IXLGO,IOPTO,IOPTV,IOPTC,IOPTD_^1_$COMMON /A/ MCSTRT,MACRNB,MACSEC_^1_$COMMON /A/ IERRS(16),ISRFAD_^1_$COMMON /A/ LGO,ISCRI,ISCRO,IX_^1*_] FTN 3.3_^1_$COMMON /A/ IGLAB(3),IGLAB1,IGLAB2_^1_$COMMON /A/ ICOMT(12),ICOMTS,ICOMX2,ICOMTL,ISUBP,NDPRS,_^1_#$LABX,IBCDTB(48)_^1_$EQUIVALENCE(ICOMB,ICOMT(1)),(ICOMBX,ICOMT(2)),(ICOMDF,_^1_#$ICOMT(3)),(ICOMBN,ICOMT(4))_^1_$DIMEN€€SION ICOMB(6),ICOMBX(6),ICOMDF(6),ICOMBN(7)_^1_$COMMON /A/ LOOPTS,LOOPTX,LOOPTB,LOOPT(50)_^1_$EQUIVALENCE(LINDUC,LOOPT(1))_^1_$DIMENSION LINDUC(10)_^1_$EQUIVALENCE (LBEG,LOOPT(2))_^1_$DIMENSION LBEG(10)_^1_$EQUIVALENCE (LINC,LOOPT(3))_^1_$DIMENSION LINC(10)_^1_$EQUIVALENCE (LEND,LOOPT(4))_^1_$DIMENSION LEND(10)_^1_$BYTE(LLABL,LOOPT(5)(14=0)_))_^1_$DIMENSION LLABL(10)_^1_$BYTE(LID,€€LOOPT(5)(15=15) )_^1_$DIMENSION LID(10)_^1_$COMMON/A/IEQV(255), IEQVS,IEQVN2_^1_$COMMON /A/ ISTAB(150),ISTABS,ISTAB2_^1_$COMMON /A/ IBUFS,ISET(25),LBLANK,KSFCNT,KSNCNT,ISORSC,_^1_#$IHOBIT,ISTNO,ISSFLG,ISUBPN,ITERM,JSORSC,KEQVS_^1C_#SYMBOL TABLE LABELED COMMON BLOCK_^1_$COMMON /A/ ISYMN, ISYMFL,ISYMD,ISYMX,ISYMS,ISYMP,ISYMPC,ISYMPS,_^1_#$ ISYMNS, SYMTAB(2400)_^1_$INTEGER SYMTAB_^1_€€$BYTE (IDUM,SYMTAB(1)(15=15)),(KDUMY,SYMTAB(1)(15=15)),_^1_#$(ICLASS,SYMTAB(1)(14=11)),(ITYPE,SYMTAB(1)(10=9))_^1_$DIMENSION IDUM(100),KDUMY(100),ICLASS(100),ITYPE(100)_^1_$BYTE (ISNGL, SYMTAB(1)(8=8)),(KELSIZ,SYMTAB(1)(8=8)),_^1_#$ (ICOM,SYMTAB(1)(7=5)),(IPART,SYMTAB(1)(4=3))_^1_$DIMENSION ISNGL(100),KELSIZ(100),ICOM(100),IPART(100)_^1C ********************************** FTN 3.1 €€**************************_^1_$BYTE (IDCONB,SYMTAB(1)(4=4)), (IUNDEF,SYMTAB(1)(3=3))_^1_$DIMENSION IDCONB(100), IUNDEF(100)_^1C ********************************** FTN 3.1 ($) **********************_^1_$BYTE (KRFCNT,SYMTAB(1)(2=2)),(IDIM,SYMTAB(1)(1=0)),_^1_#$ (IREL,SYMTAB(1)(1=1)),(IEXT,SYMTAB(1)(0=0))_^1_$DIMENSION KRFCNT(100),IDIM(100),IREL(100),IEXT(100)_^1_$EQUIVALENCE (IRSA,€€SYMTAB(2)),(ICOMTX,SYMTAB(2)),(ISNOL,SYMTAB(2))_^1_$DIMENSION IRSA(100), ICOMTX(100),ISNOL(100)_^1_$BYTE (IDATAS,SYMTAB(3)(15=15)),(IREF,SYMTAB(3)(15=15)),_^1_#$ (IEQVX,SYMTAB(3)(14=8)),(ITILF,SYMTAB(3)(14=8))_^1_$DIMENSION IDATAS(100),IREF(100),IEQVX(100),ITILF(100)_^1_$BYTE (IPARTR,SYMTAB(3)(7=4)),(INDUCV,SYMTAB(3)(7=7)),(ISFARG,_^1_#$ SYMTAB(3)(6=6)),(IARGNO,SYMTAB(3)(5=0)),(IPA€€RTL,SYMTAB(3)(3=0))_^1_$DIMENSION IPARTR(100),INDUCV(100),ISFARG(100),IARGNO(100),_^1_#$ IPARTL(100)_^1_$EQUIVALENCE (ISYM,SYMTAB(4))_^1_$DIMENSION ISYM(100)_^1C_]_^1C_#PHASE C, D, E LABELED COMMON BLOCK_^1_$EQUIVALENCE (NBLK(1),LOOPTS)_^1_$DIMENSION NBLK(446)_^1_$EQUIVALENCE (NPCBF(1),NBLK(1)),(IDVTAB(1),NBLK(58))_^1_$EQUIVALENCE (NSUMDS,NBLK(370))_^1C_#PUNCH BUFFER, ADDRESS HOLDE€€RS, PRINT BUFFER, INDEX HISTORY TABLES_^1_$EQUIVALENCE(NPTBF,NBLK(371)),(IXS1,NBLK(426)),(IXS2,NBLK(436))_^1C_$INDEX REGISTER HOLDERS FOR SUBROUTINE IXOPT_^1_$DIMENSION NPCBF(57),IDVTAB(312),NPTBF(55),IXS1(10),IXS2(10)_^1C_]_^1C_#PHASE C BLANK COMMON BLOCK_^1C_#INPUT BUFFER, OUTPUT BUFFER, OUTPUT RECORD HOLDER_^1_$COMMON//INBUFF(203),NOBUFF(210),NRCD(5)_^1_$COMMON//NFTAB(160),NDSTA€€B(500)_^1_$COMMON//IV(5),IXS3(10)_^1_$COMMON//NSUMD,NDFL,NADX,NSUMVS,IXC,IXFLAG,IXF,IXQ_^1_$COMMON//IXSX,IUSE,IFIX,NOUTOT,NOWO,NL,NT,NA,NS,ND,NR,NQ,NF_^1_$COMMON//NTYPE,NOWI,NOPC,NOPT,NADD,NXPT_^1_$COMMON//NATYPE,ICT,INCT,NOCT,NSTYPE,LRS,NOBW,NBINC,NPC1_^1_$COMMON//NSETX,NRM,NPTBFX,NRC1,NRC2,NW2FL,NW2,NBFL,NXCON_^1_$COMMON//NASCI,ISCOUN,ICOUNT,NOFS,NODS,NDXJ,NX_^1_$COMMON// IHEAD, €€INOB, INC_^1C_]_^1_$EQUIVALENCE(IND(1),NL)_^1_$DIMENSION IND(14)_^1_$EQUIVALENCE(ICFLG,IV(2)),(ITCOUN,IV(3)),(IDECR,IV(4))_^1C ********************************** FTN 3.2 **************************_^1_$DIMENSION NDVREF(10)_^1_$EQUIVALENCE (NDVREF(1),ISTAB(141))_^1C ********************************** FTN 3.2 ($) **********************_^1C_]_^1C ***********************************€€*************************_!88*2912_^1C_]_^1C_#ERROR MSG FOR NDSTAB OVERFLOW CAUSED BY TOO MANY UNIQUE DUMMY_^1C_#PARAMETER REFERENCES_^1_$DIMENSION MSG(4)_^1_$DATA MSG /' *F, 77 '/_^1C_]_^1C ************************************************************_!88*2912_^1C_#GET SYMTAB ENTRY_^1_$CALL GETSYM_^1C_2ASSUME PROGRAM RELO VARIABLE_^1_$K=1_]_^1C_#IS IT COMMON_^1_$IF(ICLASS(ISYMX).EQ€€.1.AND.ICOM(ISYMX).NE.0) GO TO 10_^1C_#IS IT EXTERNAL_^1_$IF (IEXT(ISYMX).NE.0 .AND. ICLASS(ISYMX) .NE. 1) GO TO 20_^1_$IF(KDUMY(ISYMX) .NE. 0) GO TO 30_^1C_2IS THIS AN INTRINSIC FUNCTION_^1C_2A STATEMENT FUNCTION OR A STATEMENT LABEL_^1_$IF(ICLASS(ISYMX).EQ.3)GO TO 20_^1_$IF(ICLASS(ISYMX).NE.1.AND.ICLASS(ISYMX).NE.2)GO TO 4930_^1_$IV(1)=0_^1C_#STORE COMMAND_^1_$IF(NOPC.EQ.10.OR.N€€OPC.EQ.11.OR.(NOPC.GE.14.AND.NOPC.LT.17).OR._^1_#1 NTYPE.NE.0.OR.ICLASS(ISYMX).EQ.2)IV(1)=1_^1C_#IDENTIFIED VARIABLE_^1_$IF(IRSA(ISYMX).LT.32766)GO TO 490_^1_$IF(IV(1).EQ.1)IRSA(ISYMX)=32766_^1C ********************************** FTN 3.1 **************************_^1 4931 IUNDEF(ISYMX) = 1_^1C ********************************** FTN 3.1 ($) **********************_^1 493 NATYPE=9_€€^1_$RETURN_^1C_#COMMON_^1_!10 NDFL=1_^1C_2IS REFERENCE COUNT GREATER THAN 1_^1C_2YES, SET FLAG FOR COMMON OR DATA_^1_$K=3_]_^1_$J = ICOM(ISYMX)_^1_$IF(ICOMBN(J).EQ.0) K=2_^1C_#IDENTIFIED VARIABLE-IS IT IN RANGE_^1 490 IF(NTYPE.NE.0) RETURN_^1C_2IS THIS COMMON OR DATA_^1_$J=IRSA(ISYMX)+NA*NADD_^1_$IF(K.EQ.1)GO TO 4901_^1_$J=OR(J,$8000)_^1_$GO TO 4903_^1 4901 IF(ICOUNT-J.LT.128)GO T€€O 4921_^1_$IF(IR+ND.NE.0)GO TO 493_^1_$J=AND(J,32767)_^1C_2SEARCH IDVTAB FOR THIS LOC_^1 4903 DO 491 I=1,NADX,2_^1_$IF(IDVTAB(I).EQ.0.AND.IDVTAB(I+1).EQ.0)GO TO 491_^1_$IF(IDVTAB(I).NE.J) GO TO 491_^1_$M = IDVTAB(I+1)_^1C_2IS THIS LOC IN COMMON_^1_$IF (J.GE.0) GO TO 4907_^1C_2YES,DOES COMMON TYPE MATCH SEARCH TYPE_^1_$IF(M .LT. 0 .AND. K .NE. 3 .OR.M .GE. 0.AND. K .NE.2)GO TO 491_^€€1_$IF(M .LT. 0) M = -M_^1 4907 IF(ICOUNT - M .LT. 128) GO TO 492_^1 491 CONTINUE_^1_$IF(NADX .LT. NSUMD) GO TO 4910_^1C_2TABLE IS FULL_^1_$DO 494 I=1,NADX,2_^1C ********************************** FTN 3.2 **************************_^1_$M = IDVTAB(I+1)_^1_$M = IABS(M)_^1_$IF ((ICOUNT - M) .LT. 128) GO TO 494_^1C_]_^1C_FGET REF BIT FOR THIS ENTRY_^1C_]_^1_$N = 1_^1_$GO TO 100_^1C_]€€_^1C_FCHECK REF BIT_^1C_]_^1 4911 M = AND(NDVREF(IWORD),IMASK)_^1_$IF (M.EQ.0) GO TO 495_^1C ********************************** FTN 3.2 ($) **********************_^1 494 CONTINUE_^1_$IF(K .LT. 2) GO TO 493_^1_$GO TO 15_^1 4910 I=NADX_^1_$NADX=NADX+2_^1 495 IDVTAB(I)=J_^1_$IDVTAB(I+1)=ICOUNT+1_^1_$IF(K.EQ.3)IDVTAB(I+1)=-IDVTAB(I+1)_^1_$GO TO 15_^1C ******************************€€**** FTN 3.2 **************************_^1C_]_^1C_FFOUND A REFERENCE IN RANGE_^1C_FSET REF BIT FOR ENTRY IN IDVTAB_^1C_]_^1 492 N = 2_^1_$GO TO 100_^1 496 NDVREF(IWORD) = OR(NDVREF(IWORD),IMASK)_^1C_]_^1C_FFLAG NOPT = IDVTAB REFERENCE_^1C_]_^1_$NRCD(2) = NRCD(2) + 1_^1C ********************************** FTN 3.2 ($) **********************_^1_$NOPT=I+1_^1_$NA = 0_^1_!37 ND = 1_^€€1 4921 NATYPE = 3_^1_$NDFL=1_^1_$RETURN_^1 4930 IF(IRSA(ISYMX).GE.32765.OR.ICOUNT-IRSA(ISYMX).GT.127)GO TO 4931_^1_$GO TO 4921_^1C_+EXTERNAL,IS IT RELATIVE_^1_!20 NDFL=IREL(ISYMX)_^1_$IF (NDFL.NE.0.AND.ICLASS.NE.1) GO TO 493_^1C_2NO, IS THIS THE FIRST ENCOUNTER_^1_$IF(IRSA(ISYMX) .LT. 32767) GO TO 40_^1C_2YES, PUT ICOUNT IN SYMTAB_^1_$IRSA(ISYMX) = ICOUNT+1_^1_$NDFL =1_^1_!15 NR =€€ 1_^1_!16 ND=1_]_^1_$RETURN_^1C_2IS THIS PARAMETER IN THE SYMBOL TABLE_^1_!30 IF (IRSA(ISYMX) .LT. 32766)GO TO 40_^1_$IF(IRSA(ISYMX).EQ.32766)GO TO 35_^1_$IRSA(ISYMX)=32766_^1_$NDPRS=NDPRS-1_^1C_2IS OP CODE ADC_^1_!35 IF(NTYPE .NE. 0) RETURN_^1C_2NO, SET ADDR MOD_^1_$NATYPE = 9_^1_$GO TO 16_^1C_2IS THIS AN ADC_^1_!40 IF (NTYPE .NE. 0) GO TO 50_^1C_2NO, IS SYMTAB ENTRY REACHABLE_^1_€€$IF(ICOUNT-IRSA(ISYMX).LT. 128) GO TO 37_^1C_2NO, SEARCH NDSTAB FOR THIS POINTER_^1_!50 DO 80 I=1,NODS,2_^1_$IF(NOPT .NE. NDSTAB(I))GO TO 80_^1C_2IS OP CODE ADC(DUMMY PARAM IN CALL SEQ)_^1_$IF (NTYPE .EQ. 0) GO TO 60_^1C_2YES CAN I DUMP IT HERE_^1_$IF (NDSTAB(I+1).GT.0) GO TO 80_^1C_2YES, REDUCE RESERVED STORAGES_^1_$NDSTAB(I+1)=ICOUNT_^1_!55 NDPRS=NDPRS-1_^1_$RETURN_^1C_2HAS THIS€€ ENTRY BEEN DUMPED_^1_!60 IF(NDSTAB(I+1) .LE. 0) GO TO 35_^1C_2YES, CAN IT BE REACHED_^1_$IF(ICOUNT - NDSTAB(I+1) .GT. 127) GO TO 80_^1C_2YES STORE TABLE REFERENCE_^1_!70 NOPT = I+1_^1C_2FLAG NOPT = NDSTAB REFERENCE_^1_$NRCD(2) = NRCD(2) + 2_^1_$GO TO 37_^1_!80 CONTINUE_^1C_2THIS ENTRY IS EITHER NOT IN THE_^1C_2TABLE OR IT CANNOT BE REACHED_^1C_2IS THIS A DUMMY PARAM IN A CALL SEQ_€€^1_$IF(NTYPE .EQ. 0) GO TO 90_^1C_2YES DUMP IT HERE_^1C ************************************************************_!88*2912_^1C_#TEST FOR NDSTAB TABLE OVERFLOW_^1_%IF (NODS+2 .GT. 500) GO TO 93_^1C ************************************************************_!88*2912_^1_$NDSTAB(NODS) = NOPT_^1_$NDSTAB(NODS+1)=ICOUNT_^1_$NODS = NODS + 2_^1_$GO TO 55_^1C_2IS THERE ROOM IN THE TABLE€€_^1_!90 IF(NODS+2.GE.NSUMDS-NDPRS*2)GO TO 35_^1C_2YES, ENTER FOR DUMPING AT NEXT JMP_^1C ************************************************************_!88*2912_^1C_]_^1C_#TEST FOR NDSTAB TABLE OVERFLOW_^1_$IF (NODS+2 .LE. 500) GO TO 94_^1C_$OUTPUT ERROR MSG *F, 77 TOO MANY UNIQUE DUMMY PARAMETER_^1C_#REFERENCES_^1C_#ERROR MSG HAS ALREADY BEEN WRITTEN IF IGLAB (1) .EQ. $7FFF_^1 93 €€IF (IGLAB(1) .EQ. $7FFF) RETURN_^1_$CALL WRITE (3,1,4,MSG(1))_^1C_$SET INITIALIZE COMPILER FLAG_^1_$IGLAB(1) = $7FFF_^1_$RETURN_^1C_]_^1_!94 CONTINUE_^1C ************************************************************_!88*2912_^1_$NDSTAB(NODS) = NOPT_^1_$NODS = NODS+2_^1C_2IS THIS OPERAND EXTERNAL_^1_%IF(ICLASS(ISYMX).NE.1.AND.IEXT(ISYMX).EQ.0) GO TO 95_^1C_2YES, DUMP IT HERE_^1_$NDST€€AB(NODS-1)=ICOUNT+1_^1C_2STORE COMMON ADDR IN THIS WORD_^1_$GO TO 15_^1C_2FLAG TO PREVENT ENTRY IN SYMTAB_^1_!95 NDSTAB(NODS-1)=-1_^1_$NOPT=NODS-1_^1_$NRCD(2) = NRCD(2)+2_^1_$GO TO 35_^1C ********************************** FTN 3.2 **************************_^1C_]_^1C_FSET IMASK FOR BIT HANDLING IN_^1C_FTHE NDVREF TABLE_^1C_]_^1 100 IWORD = I/32 + 1_^1_$IBIT = IWORD*16 - (I+1)/2_^€ð1C_]_^1C_FLDQ IBIT_^1C_FLDA 23,Q_^1C_FSTA IMASK_^1C_]_^1_$ASSEM $E400,+IBIT_^1_$ASSEM $C223_^1_$ASSEM $6400,+IMASK_^1C_]_^1_$GO TO (4911,496), N_^1C ********************************** FTN 3.2 ($) **********************_^1_$END_]_^__ ðPWCL12 CSY/ 06C P€1_$SUBROUTINE CL12_^1_#*_2/DECK-ID 06C FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^13_]_^1C CL12 IS USED IN PHASE C_^1C_]_^1C_#MASTER LABELED COMMON BLOCK._^1*_] FTN 3.3_^1_$COMMON /A/ IFLAGS,LINECT,LINCT1_^1_$COMMON /A/ IR,IK,IP,IA,IL,IM,IXLGO,IOPTO,€€IOPTV,IOPTC,IOPTD_^1_$COMMON /A/ MCSTRT,MACRNB,MACSEC_^1_$COMMON /A/ IERRS(16),ISRFAD_^1_$COMMON /A/ LGO,ISCRI,ISCRO,IX_^1*_] FTN 3.3_^1_$COMMON /A/ IGLAB(3),IGLAB1,IGLAB2_^1_$COMMON /A/ ICOMT(12),ICOMTS,ICOMX2,ICOMTL,ISUBP,NDPRS,_^1_#$LABX,IBCDTB(48)_^1_$EQUIVALENCE(ICOMB,ICOMT(1)),(ICOMBX,ICOMT(2)),(ICOMDF,_^1_#$ICOMT(3)),(ICOMBN,ICOMT(4))_^1_$DIMENSION ICOMB(6),ICOMBX(6),ICOMDF€€(6),ICOMBN(7)_^1_$COMMON /A/ LOOPTS,LOOPTX,LOOPTB,LOOPT(50)_^1_$EQUIVALENCE(LINDUC,LOOPT(1))_^1_$DIMENSION LINDUC(10)_^1_$EQUIVALENCE (LBEG,LOOPT(2))_^1_$DIMENSION LBEG(10)_^1_$EQUIVALENCE (LINC,LOOPT(3))_^1_$DIMENSION LINC(10)_^1_$EQUIVALENCE (LEND,LOOPT(4))_^1_$DIMENSION LEND(10)_^1_$BYTE(LLABL,LOOPT(5)(14=0)_))_^1_$DIMENSION LLABL(10)_^1_$BYTE(LID,LOOPT(5)(15=15) )_^1_$DIMENSI€€ON LID(10)_^1_$COMMON/A/IEQV(255), IEQVS,IEQVN2_^1_$COMMON /A/ ISTAB(150),ISTABS,ISTAB2_^1_$COMMON /A/ IBUFS,ISET(25),LBLANK,KSFCNT,KSNCNT,ISORSC,_^1_#$IHOBIT,ISTNO,ISSFLG,ISUBPN,ITERM,JSORSC,KEQVS_^1C_#SYMBOL TABLE LABELED COMMON BLOCK_^1_$COMMON /A/ ISYMN, ISYMFL,ISYMD,ISYMX,ISYMS,ISYMP,ISYMPC,ISYMPS,_^1_#$ ISYMNS, SYMTAB(2400)_^1_$INTEGER SYMTAB_^1_$BYTE (IDUM,SYMTAB(1)(15=15)),€€(KDUMY,SYMTAB(1)(15=15)),_^1_#$(ICLASS,SYMTAB(1)(14=11)),(ITYPE,SYMTAB(1)(10=9))_^1_$DIMENSION IDUM(100),KDUMY(100),ICLASS(100),ITYPE(100)_^1_$BYTE (ISNGL, SYMTAB(1)(8=8)),(KELSIZ,SYMTAB(1)(8=8)),_^1_#$ (ICOM,SYMTAB(1)(7=5)),(IPART,SYMTAB(1)(4=3))_^1_$DIMENSION ISNGL(100),KELSIZ(100),ICOM(100),IPART(100)_^1_$BYTE (KRFCNT,SYMTAB(1)(2=2)),(IDIM,SYMTAB(1)(1=0)),_^1_#$ (IREL,SYMTAB(1)(€€1=1)),(IEXT,SYMTAB(1)(0=0))_^1_$DIMENSION KRFCNT(100),IDIM(100),IREL(100),IEXT(100)_^1_$EQUIVALENCE (IRSA,SYMTAB(2)),(ICOMTX,SYMTAB(2)),(ISNOL,SYMTAB(2))_^1_$DIMENSION IRSA(100), ICOMTX(100),ISNOL(100)_^1_$BYTE (IDATAS,SYMTAB(3)(15=15)),(IREF,SYMTAB(3)(15=15)),_^1_#$ (IEQVX,SYMTAB(3)(14=8)),(ITILF,SYMTAB(3)(14=8))_^1_$DIMENSION IDATAS(100),IREF(100),IEQVX(100),ITILF(100)_^1_$BYTE (€€IPARTR,SYMTAB(3)(7=4)),(INDUCV,SYMTAB(3)(7=7)),(ISFARG,_^1_#$ SYMTAB(3)(6=6)),(IARGNO,SYMTAB(3)(5=0)),(IPARTL,SYMTAB(3)(3=0))_^1_$DIMENSION IPARTR(100),INDUCV(100),ISFARG(100),IARGNO(100),_^1_#$ IPARTL(100)_^1_$EQUIVALENCE (ISYM,SYMTAB(4))_^1_$DIMENSION ISYM(100)_^1C_]_^1C_#PHASE C, D, E LABELED COMMON BLOCK_^1_$EQUIVALENCE (NBLK(1),LOOPTS)_^1_$DIMENSION NBLK(446)_^1_$EQUIVALENCE (€€NPCBF(1),NBLK(1)),(IDVTAB(1),NBLK(58))_^1_$EQUIVALENCE (NSUMDS,NBLK(370))_^1C_#PUNCH BUFFER, ADDRESS HOLDERS, PRINT BUFFER, INDEX HISTORY TABLES_^1_$EQUIVALENCE(NPTBF,NBLK(371)),(IXS1,NBLK(426)),(IXS2,NBLK(436))_^1C_$INDEX REGISTER HOLDERS FOR SUBROUTINE IXOPT_^1_$DIMENSION NPCBF(57),IDVTAB(312),NPTBF(55),IXS1(10),IXS2(10)_^1C_]_^1C_#PHASE C BLANK COMMON BLOCK_^1C_#INPUT BUFFER, OU€€TPUT BUFFER, OUTPUT RECORD HOLDER_^1_$COMMON//INBUFF(203),NOBUFF(210),NRCD(5)_^1_$COMMON//NFTAB(160),NDSTAB(500)_^1_$COMMON//IV(5),IXS3(10)_^1_$COMMON//NSUMD,NDFL,NADX,NSUMVS,IXC,IXFLAG,IXF,IXQ_^1_$COMMON//IXSX,IUSE,IFIX,NOUTOT,NOWO,NL,NT,NA,NS,ND,NR,NQ,NF_^1_$COMMON//NTYPE,NOWI,NOPC,NOPT,NADD,NXPT_^1_$COMMON//NATYPE,ICT,INCT,NOCT,NSTYPE,LRS,NOBW,NBINC,NPC1_^1_$COMMON//NSETX,NRM,NP€€TBFX,NRC1,NRC2,NW2FL,NW2,NBFL,NXCON_^1_$COMMON//NASCI,ISCOUN,ICOUNT,NOFS,NODS,NDXJ,NX_^1_$COMMON// IHEAD, INOB, INC_^1C_]_^1_$EQUIVALENCE(IND(1),NL)_^1_$DIMENSION IND(14)_^1_$EQUIVALENCE(ICFLG,IV(2)),(ITCOUN,IV(3)),(IDECR,IV(4))_^1_$DIMENSION NTAB12(20)_^1_$DATA NTAB12(1),NTAB12(2),NTAB12(3)/4096,20480,$C000/_^1_$DATA NTAB12(4),NTAB12(5),NTAB12(6)/$A000,24576,16384/_^1_$DATA NTAB12€€(7),NTAB12(8),NTAB12(9)/$D000,$8000,$9000/_^1_$DATA NTAB12(10),NTAB12(11),NTAB12(12)/$E000,12288,$F000/_^1_$DATA NTAB12(13),NTAB12(14),NTAB12(15)/8192,0,0/_^1C_KMUI EOR_^1_$DATA NTAB12(13),NTAB12(14),NTAB12(15)/8192,$B000,0/_^1_$DATA NTAB12(16),NTAB12(17),NTAB12(18)/0,0,0/_^1_$DATA NTAB12(19),NTAB12(20)/$E000,16384/_^1C ********************************** FTN 3.0 *****************€€*********_^1C ********************************** FTN 3.0 **************************_^1_%DIMENSION NTRCD(3)_^1C ********************************** FTN 3.0 **************************_^1_!20 NDFL = 0_^1_!50 NRCD(2)=NRCD(2)+NTAB12(NOPC-9)_^1_$NOWO = NOWI_^1C_2SET INDIRECT BIT_^1C_2IS OPERAND ABSOLUTE_^1_$IF(NTYPE.EQ.0.OR.NTYPE.GT.2)GO TO 65_^1C_2YES_^1_$GO TO (55,53),NTYPE_^1C_2TWO W€€ORD CONSTANT ADDRESS MODE_^1_!53 NATYPE = 6_^1C_2SET FLAG FOR POINTER EQUAL ABS OPND_^1_$NRCD(2) = NRCD(2)+ 3_^1C_2FLAG READY FOR OUTPUT_^1_!56 NDFL = 1_^1_$GO TO 75_^1C_2ONE WORD COMMAND_^1_!55 NATYPE = 1_^1_$NOPT = AND (NOPT,255)_^1_$NRCD(2)=NOPT+NRCD(2)_^1_$NOWO = NOWI - 1_^1_$NOPT = NXPT_^1C_#TEST FOR LOAD FF OR STORE FF_^1_$IF(NOPC.LT.24) GO TO 56_^1C_#ONE OF THOSE_^1_$NATYPE=€€NOPC_^1_$GO TO 110_^1C_2IS THIS COMMAND SET ONE WD RELATIVE_^1C_2CHECK OPERAND POINTER_^1_!65 ISYMX = NOPT_^1_$CALL GETSYM_^1_$IF(NTYPE.EQ.4.AND.KDUMY(ISYMX).NE.0)GO TO 73_^1_$IF(ND.NE.1)GO TO 107_^1_$IF(ICOM(ISYMX).EQ.0)GO TO 107_^1C ********************************** FTN 3.0 **************************_^1_%NTRCD(1)=NRCD(1)_^1_%NTRCD(2)=NRCD(2)_^1_%NTRCD(3)=NOWO_^1_%NRCD(1)=$0C1D_€€^1_%NRCD(2)=$C400_^1_%NRCD(3)=NOPT_^1_%NRCD(4)=NADD_^1_%NRCD(5)=NXPT_^1_%ICT=2_^1_%CALL INOUT_^1_%CALL COUNT_^1_%NRCD(1)=$CB8_^1_%NRCD(2)=$6802_^1_%NOWO=2_^1_%CALL INOUT_^1_%CALL COUNT_^1_%NRCD(1)=NTRCD(1)_^1_%NRCD(2)=NTRCD(2)_^1_%NOWO=NTRCD(3)_^1C ********************************** FTN 3.0 **************************_^1C ********************************** FTN 3.0 ****************€€**********_^1_$NATYPE=8_^1_$NDFL=1_^1_$GO TO 105_^1 107 ISYMX=NOPT_^1_$CALL CHOP_^1_!70 IF(NTYPE .EQ. 0) GO TO 72_^1C_22ND WD IS BIASED OR UNBIASED ADDR CONSTANT_^1C_2NATYPE = 5 UNBIASED,NATYPE=6, BIASED_^1_$NR=1_]_^1_$NATYPE = NTYPE_^1_$IF(NTYPE .EQ.4) NATYPE = 6_^1_$GO TO 105_^1_!73 NTYPE=0_^1_$ISYMX=NOPT_^1_$CALL CHOP_^1_$ND=0_]_^1C_+IF NR IS SET OR OPERAND IS ADDR CONST,FORCE €€2 WORD_^1_!72 IF(NR.NE.0)NATYPE=6_^1C_2SET REL BIT IF INDICATED_^1_!75 IF(NATYPE .EQ. 3 .OR. NATYPE .GT. 8) NRCD(2) = NRCD(2) + 2048_^1C_2BUMP TYPE CODE IF INDIRECT_^1_$NATYPE = NATYPE + ND_^1C_2SET PROG INCREMENT TO 2 IF 2 WD_^1 105 IF(NATYPE .GT. 4) ICT =2_^1_$IF(NTYPE.NE.0)ND=0_^1C_2TEST FOR Q DESTROYER_^1 110 NRCD(2)=NRCD(2)+(ND*1024)_^1_$ND=NDFL_^1C_2CONSTRUCT INDICATOR FOR €:OUTPUT RECORD_^1_$CALL BLDUP_^1 130 RETURN_^1_$END_]_^__ :PWCON CSY/ 07C P€1_$SUBROUTINE CON_^1_#*_2/DECK-ID 07C FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^13_]_^1C CON IS USED IN PHASE C_^1C_]_^1C_#MASTER LABELED COMMON BLOCK._^1*_] FTN 3.3_^1_$COMMON /A/ IFLAGS,LINECT,LINCT1_^1_$COMMON /A/ IR,IK,IP,IA,IL,IM,IXLGO,IOPTO,IO€€PTV,IOPTC,IOPTD_^1_$COMMON /A/ MCSTRT,MACRNB,MACSEC_^1_$COMMON /A/ IERRS(16),ISRFAD_^1_$COMMON /A/ LGO,ISCRI,ISCRO,IX_^1*_] FTN 3.3_^1_$COMMON /A/ IGLAB(3),IGLAB1,IGLAB2_^1_$COMMON /A/ ICOMT(12),ICOMTS,ICOMX2,ICOMTL,ISUBP,NDPRS,_^1_#$LABX,IBCDTB(48)_^1_$EQUIVALENCE(ICOMB,ICOMT(1)),(ICOMBX,ICOMT(2)),(ICOMDF,_^1_#$ICOMT(3)),(ICOMBN,ICOMT(4))_^1_$DIMENSION ICOMB(6),ICOMBX(6),ICOMDF(6€€),ICOMBN(7)_^1_$COMMON /A/ LOOPTS,LOOPTX,LOOPTB,LOOPT(50)_^1_$EQUIVALENCE(LINDUC,LOOPT(1))_^1_$DIMENSION LINDUC(10)_^1_$EQUIVALENCE (LBEG,LOOPT(2))_^1_$DIMENSION LBEG(10)_^1_$EQUIVALENCE (LINC,LOOPT(3))_^1_$DIMENSION LINC(10)_^1_$EQUIVALENCE (LEND,LOOPT(4))_^1_$DIMENSION LEND(10)_^1_$BYTE(LLABL,LOOPT(5)(14=0)_))_^1_$DIMENSION LLABL(10)_^1_$BYTE(LID,LOOPT(5)(15=15) )_^1_$DIMENSION€€ LID(10)_^1_$COMMON/A/IEQV(255), IEQVS,IEQVN2_^1_$COMMON /A/ ISTAB(150),ISTABS,ISTAB2_^1_$COMMON /A/ IBUFS,ISET(25),LBLANK,KSFCNT,KSNCNT,ISORSC,_^1_#$IHOBIT,ISTNO,ISSFLG,ISUBPN,ITERM,JSORSC,KEQVS_^1C_#SYMBOL TABLE LABELED COMMON BLOCK_^1_$COMMON /A/ ISYMN, ISYMFL,ISYMD,ISYMX,ISYMS,ISYMP,ISYMPC,ISYMPS,_^1_#$ ISYMNS, SYMTAB(2400)_^1_$INTEGER SYMTAB_^1_$BYTE (IDUM,SYMTAB(1)(15=15)),(K€€DUMY,SYMTAB(1)(15=15)),_^1_#$(ICLASS,SYMTAB(1)(14=11)),(ITYPE,SYMTAB(1)(10=9))_^1_$DIMENSION IDUM(100),KDUMY(100),ICLASS(100),ITYPE(100)_^1_$BYTE (ISNGL, SYMTAB(1)(8=8)),(KELSIZ,SYMTAB(1)(8=8)),_^1_#$ (ICOM,SYMTAB(1)(7=5)),(IPART,SYMTAB(1)(4=3))_^1_$DIMENSION ISNGL(100),KELSIZ(100),ICOM(100),IPART(100)_^1C ********************************** FTN 3.1 **************************_^1_$B€€YTE (IDCONB,SYMTAB(1)(4=4)), (IUNDEF,SYMTAB(1)(3=3))_^1_$DIMENSION IDCONB(100), IUNDEF(100)_^1C ********************************** FTN 3.1 ($) **********************_^1_$BYTE (KRFCNT,SYMTAB(1)(2=2)),(IDIM,SYMTAB(1)(1=0)),_^1_#$ (IREL,SYMTAB(1)(1=1)),(IEXT,SYMTAB(1)(0=0))_^1_$DIMENSION KRFCNT(100),IDIM(100),IREL(100),IEXT(100)_^1_$EQUIVALENCE (IRSA,SYMTAB(2)),(ICOMTX,SYMTAB(2)),(I€€SNOL,SYMTAB(2))_^1_$DIMENSION IRSA(100), ICOMTX(100),ISNOL(100)_^1_$BYTE (IDATAS,SYMTAB(3)(15=15)),(IREF,SYMTAB(3)(15=15)),_^1_#$ (IEQVX,SYMTAB(3)(14=8)),(ITILF,SYMTAB(3)(14=8))_^1_$DIMENSION IDATAS(100),IREF(100),IEQVX(100),ITILF(100)_^1_$BYTE (IPARTR,SYMTAB(3)(7=4)),(INDUCV,SYMTAB(3)(7=7)),(ISFARG,_^1_#$ SYMTAB(3)(6=6)),(IARGNO,SYMTAB(3)(5=0)),(IPARTL,SYMTAB(3)(3=0))_^1_$DIMENSIO€€N IPARTR(100),INDUCV(100),ISFARG(100),IARGNO(100),_^1_#$ IPARTL(100)_^1_$EQUIVALENCE (ISYM,SYMTAB(4))_^1_$DIMENSION ISYM(100)_^1C_]_^1C_#PHASE C, D, E LABELED COMMON BLOCK_^1_$EQUIVALENCE (NBLK(1),LOOPTS)_^1_$DIMENSION NBLK(446)_^1_$EQUIVALENCE (NPCBF(1),NBLK(1)),(IDVTAB(1),NBLK(58))_^1_$EQUIVALENCE (NSUMDS,NBLK(370))_^1C_#PUNCH BUFFER, ADDRESS HOLDERS, PRINT BUFFER, INDEX HISTORY €€TABLES_^1_$EQUIVALENCE(NPTBF,NBLK(371)),(IXS1,NBLK(426)),(IXS2,NBLK(436))_^1C_$INDEX REGISTER HOLDERS FOR SUBROUTINE IXOPT_^1_$DIMENSION NPCBF(57),IDVTAB(312),NPTBF(55),IXS1(10),IXS2(10)_^1C_]_^1C_#PHASE C BLANK COMMON BLOCK_^1C_#INPUT BUFFER, OUTPUT BUFFER, OUTPUT RECORD HOLDER_^1_$COMMON//INBUFF(203),NOBUFF(210),NRCD(5)_^1_$COMMON//NFTAB(160),NDSTAB(500)_^1_$COMMON//IV(5),IXS3(10€€)_^1_$COMMON//NSUMD,NDFL,NADX,NSUMVS,IXC,IXFLAG,IXF,IXQ_^1_$COMMON//IXSX,IUSE,IFIX,NOUTOT,NOWO,NL,NT,NA,NS,ND,NR,NQ,NF_^1_$COMMON//NTYPE,NOWI,NOPC,NOPT,NADD,NXPT_^1_$COMMON//NATYPE,ICT,INCT,NOCT,NSTYPE,LRS,NOBW,NBINC,NPC1_^1_$COMMON//NSETX,NRM,NPTBFX,NRC1,NRC2,NW2FL,NW2,NBFL,NXCON_^1_$COMMON//NASCI,ISCOUN,ICOUNT,NOFS,NODS,NDXJ,NX_^1_$COMMON// IHEAD, INOB, INC_^1C_]_^1C_]_^1_$EQUIVA€€LENCE(IND(1),NL)_^1_$DIMENSION IND(14)_^1_$EQUIVALENCE(ICFLG,IV(2)),(ITCOUN,IV(3)),(IDECR,IV(4))_^1_$ND=1_]_^1_$IF(NTYPE.EQ.2)GO TO 12_^1_$NATYPE = 45 + ITYPE(ISYMX)_^1_$NOWO = 1 + ITYPE (ISYMX)_^1_$NRCD(2) = ISYM(ISYMX)_^1C_2IS THIS A FLOATING PT CONSTANT_^1_$IF (NATYPE .EQ. 46) GO TO 10_^1_$NOPT = ISYM(ISYMX+1)_^1C ********************************** FTN 3.1 *********************€|*****_^1C_FIS THIS A REAL CONSTANT_^1_$IF (NATYPE.EQ.47) GO TO 5_^1C_FNO, DP CONSTANT_^1_$NADD = AND(ISYM(ISYMX-1),$7FFF)_^1_$IF (IDCONB(ISYMX).EQ.1) NADD = OR(NADD,$8000)_^1_"5 ICT = ITYPE(ISYMX)_^1C ********************************** FTN 3.1 ($) **********************_^1_!10 CALL BLDUP_^1_$RETURN_^1_!12 NRCD(2) = NOPT_^1_$NATYPE = 46_^1_$NOWO = 2_^1_$GO TO 10_^1_$END_]_^__|PWCNT1 CSY/ 08C P€1_$SUBROUTINE COUNT_^1_#*_2/DECK-ID 08C FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^13_]_^1C THIS COUNT IS USED IN PHASE C_^1C NON-IDENTICAL COUNT IS USED IN PHASES D,E_^1C_]_^1C_#MASTER LABELED COMMON BLOCK._^1*_] FTN 3.3_^1_$COMMON /A/ IFLAGS,LINEC€€T,LINCT1_^1_$COMMON /A/ IR,IK,IP,IA,IL,IM,IXLGO,IOPTO,IOPTV,IOPTC,IOPTD_^1_$COMMON /A/ MCSTRT,MACRNB,MACSEC_^1_$COMMON /A/ IERRS(16),ISRFAD_^1_$COMMON /A/ LGO,ISCRI,ISCRO,IX_^1*_] FTN 3.3_^1_$COMMON /A/ IGLAB(3),IGLAB1,IGLAB2_^1_$COMMON /A/ ICOMT(12),ICOMTS,ICOMX2,ICOMTL,ISUBP,NDPRS,_^1_#$LABX,IBCDTB(48)_^1_$EQUIVALENCE(ICOMB,ICOMT(1)),(ICOMBX,ICOMT(2)),(ICOMDF,_^1_#$ICOMT(3)),(IC€€OMBN,ICOMT(4))_^1_$DIMENSION ICOMB(6),ICOMBX(6),ICOMDF(6),ICOMBN(7)_^1_$COMMON /A/ LOOPTS,LOOPTX,LOOPTB,LOOPT(50)_^1_$EQUIVALENCE(LINDUC,LOOPT(1))_^1_$DIMENSION LINDUC(10)_^1_$EQUIVALENCE (LBEG,LOOPT(2))_^1_$DIMENSION LBEG(10)_^1_$EQUIVALENCE (LINC,LOOPT(3))_^1_$DIMENSION LINC(10)_^1_$EQUIVALENCE (LEND,LOOPT(4))_^1_$DIMENSION LEND(10)_^1_$BYTE(LLABL,LOOPT(5)(14=0)_))_^1_$DIMENSION €€ LLABL(10)_^1_$BYTE(LID,LOOPT(5)(15=15) )_^1_$DIMENSION LID(10)_^1_$COMMON/A/IEQV(255), IEQVS,IEQVN2_^1_$COMMON /A/ ISTAB(150),ISTABS,ISTAB2_^1_$COMMON /A/ IBUFS,ISET(25),LBLANK,KSFCNT,KSNCNT,ISORSC,_^1_#$IHOBIT,ISTNO,ISSFLG,ISUBPN,ITERM,JSORSC,KEQVS_^1C_#SYMBOL TABLE LABELED COMMON BLOCK_^1_$COMMON /A/ ISYMN, ISYMFL,ISYMD,ISYMX,ISYMS,ISYMP,ISYMPC,ISYMPS,_^1_#$ ISYMNS, SYMTAB(2400€€)_^1_$INTEGER SYMTAB_^1_$BYTE (IDUM,SYMTAB(1)(15=15)),(KDUMY,SYMTAB(1)(15=15)),_^1_#$(ICLASS,SYMTAB(1)(14=11)),(ITYPE,SYMTAB(1)(10=9))_^1_$DIMENSION IDUM(100),KDUMY(100),ICLASS(100),ITYPE(100)_^1_$BYTE (ISNGL, SYMTAB(1)(8=8)),(KELSIZ,SYMTAB(1)(8=8)),_^1_#$ (ICOM,SYMTAB(1)(7=5)),(IPART,SYMTAB(1)(4=3))_^1_$DIMENSION ISNGL(100),KELSIZ(100),ICOM(100),IPART(100)_^1_$BYTE (KRFCNT,SYMTAB(€€1)(2=2)),(IDIM,SYMTAB(1)(1=0)),_^1_#$ (IREL,SYMTAB(1)(1=1)),(IEXT,SYMTAB(1)(0=0))_^1_$DIMENSION KRFCNT(100),IDIM(100),IREL(100),IEXT(100)_^1_$EQUIVALENCE (IRSA,SYMTAB(2)),(ICOMTX,SYMTAB(2)),(ISNOL,SYMTAB(2))_^1_$DIMENSION IRSA(100), ICOMTX(100),ISNOL(100)_^1_$BYTE (IDATAS,SYMTAB(3)(15=15)),(IREF,SYMTAB(3)(15=15)),_^1_#$ (IEQVX,SYMTAB(3)(14=8)),(ITILF,SYMTAB(3)(14=8))_^1_$DIMENSION €€IDATAS(100),IREF(100),IEQVX(100),ITILF(100)_^1_$BYTE (IPARTR,SYMTAB(3)(7=4)),(INDUCV,SYMTAB(3)(7=7)),(ISFARG,_^1_#$ SYMTAB(3)(6=6)),(IARGNO,SYMTAB(3)(5=0)),(IPARTL,SYMTAB(3)(3=0))_^1_$DIMENSION IPARTR(100),INDUCV(100),ISFARG(100),IARGNO(100),_^1_#$ IPARTL(100)_^1_$EQUIVALENCE (ISYM,SYMTAB(4))_^1_$DIMENSION ISYM(100)_^1C_]_^1C_#PHASE C, D, E LABELED COMMON BLOCK_^1_$EQUIVALENCE (NBL€€K(1),LOOPTS)_^1_$DIMENSION NBLK(446)_^1_$EQUIVALENCE (NPCBF(1),NBLK(1)),(IDVTAB(1),NBLK(58))_^1_$EQUIVALENCE (NSUMDS,NBLK(370))_^1C_#PUNCH BUFFER, ADDRESS HOLDERS, PRINT BUFFER, INDEX HISTORY TABLES_^1_$EQUIVALENCE(NPTBF,NBLK(371)),(IXS1,NBLK(426)),(IXS2,NBLK(436))_^1C_$INDEX REGISTER HOLDERS FOR SUBROUTINE IXOPT_^1_$DIMENSION NPCBF(57),IDVTAB(312),NPTBF(55),IXS1(10),IXS2(10)_^1C_]€€_^1C_#PHASE C BLANK COMMON BLOCK_^1C_#INPUT BUFFER, OUTPUT BUFFER, OUTPUT RECORD HOLDER_^1_$COMMON//INBUFF(203),NOBUFF(210),NRCD(5)_^1_$COMMON//NFTAB(160),NDSTAB(500)_^1_$COMMON//IV(5),IXS3(10)_^1_$COMMON//NSUMD,NDFL,NADX,NSUMVS,IXC,IXFLAG,IXF,IXQ_^1_$COMMON//IXSX,IUSE,IFIX,NOUTOT,NOWO,NL,NT,NA,NS,ND,NR,NQ,NF_^1_$COMMON//NTYPE,NOWI,NOPC,NOPT,NADD,NXPT_^1_$COMMON//NATYPE,ICT,INCT,NO€€CT,NSTYPE,LRS,NOBW,NBINC,NPC1_^1_$COMMON//NSETX,NRM,NPTBFX,NRC1,NRC2,NW2FL,NW2,NBFL,NXCON_^1_$COMMON//NASCI,ISCOUN,ICOUNT,NOFS,NODS,NDXJ,NX_^1_$COMMON// IHEAD, INOB, INC_^1C_]_^1_$EQUIVALENCE(IND(1),NL)_^1_$DIMENSION IND(14)_^1_$EQUIVALENCE(ICFLG,IV(2)),(ITCOUN,IV(3)),(IDECR,IV(4))_^1_$ICOUNT = ICOUNT + ICT_^1_$IF (ICOUNT .GE. 0) GO TO 10_^1_$ICOUNT = AND ( ICOUNT, $7FFF) + 1_^1_$I€˜FIX=-1_^1*_YBEGIN FTN 3.3_^1*_#CLEAR PUNCH AND LGO OPTIONS ON CORE OVERFLOW_^1_$IP=0_]_^1_$IXLGO=0_^1_$LGO=0_^1*_[END FTN 3.3_^1_!10 ICT=1_^1_$END_]_^__˜PWDATST CSY/ 09C P€1_$SUBROUTINE DATAST_^1_#*_2/DECK-ID 09C FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^13_]_^1C DATAST IS USED IN PHASE C_^1C_]_^1C_#MASTER LABELED COMMON BLOCK._^1*_] FTN 3.3_^1_$COMMON /A/ IFLAGS,LINECT,LINCT1_^1_$COMMON /A/ IR,IK,IP,IA,IL,IM,IXLGO,IO€€PTO,IOPTV,IOPTC,IOPTD_^1_$COMMON /A/ MCSTRT,MACRNB,MACSEC_^1_$COMMON /A/ IERRS(16),ISRFAD_^1_$COMMON /A/ LGO,ISCRI,ISCRO,IX_^1*_] FTN 3.3_^1_$COMMON /A/ IGLAB(3),IGLAB1,IGLAB2_^1_$COMMON /A/ ICOMT(12),ICOMTS,ICOMX2,ICOMTL,ISUBP,NDPRS,_^1_#$LABX,IBCDTB(48)_^1_$EQUIVALENCE(ICOMB,ICOMT(1)),(ICOMBX,ICOMT(2)),(ICOMDF,_^1_#$ICOMT(3)),(ICOMBN,ICOMT(4))_^1_$DIMENSION ICOMB(6),ICOMBX(6),IC€€OMDF(6),ICOMBN(7)_^1_$COMMON /A/ LOOPTS,LOOPTX,LOOPTB,LOOPT(50)_^1_$EQUIVALENCE(LINDUC,LOOPT(1))_^1_$DIMENSION LINDUC(10)_^1_$EQUIVALENCE (LBEG,LOOPT(2))_^1_$DIMENSION LBEG(10)_^1_$EQUIVALENCE (LINC,LOOPT(3))_^1_$DIMENSION LINC(10)_^1_$EQUIVALENCE (LEND,LOOPT(4))_^1_$DIMENSION LEND(10)_^1_$BYTE(LLABL,LOOPT(5)(14=0)_))_^1_$DIMENSION LLABL(10)_^1_$BYTE(LID,LOOPT(5)(15=15) )_^1_$DIM€€ENSION LID(10)_^1_$COMMON/A/IEQV(255), IEQVS,IEQVN2_^1_$COMMON /A/ ISTAB(150),ISTABS,ISTAB2_^1_$COMMON /A/ IBUFS,ISET(25),LBLANK,KSFCNT,KSNCNT,ISORSC,_^1_#$IHOBIT,ISTNO,ISSFLG,ISUBPN,ITERM,JSORSC,KEQVS_^1C_#SYMBOL TABLE LABELED COMMON BLOCK_^1_$COMMON /A/ ISYMN, ISYMFL,ISYMD,ISYMX,ISYMS,ISYMP,ISYMPC,ISYMPS,_^1_#$ ISYMNS, SYMTAB(2400)_^1_$INTEGER SYMTAB_^1_$BYTE (IDUM,SYMTAB(1)(15=1€€5)),(KDUMY,SYMTAB(1)(15=15)),_^1_#$(ICLASS,SYMTAB(1)(14=11)),(ITYPE,SYMTAB(1)(10=9))_^1_$DIMENSION IDUM(100),KDUMY(100),ICLASS(100),ITYPE(100)_^1_$BYTE (ISNGL, SYMTAB(1)(8=8)),(KELSIZ,SYMTAB(1)(8=8)),_^1_#$ (ICOM,SYMTAB(1)(7=5)),(IPART,SYMTAB(1)(4=3))_^1_$DIMENSION ISNGL(100),KELSIZ(100),ICOM(100),IPART(100)_^1_$BYTE (KRFCNT,SYMTAB(1)(2=2)),(IDIM,SYMTAB(1)(1=0)),_^1_#$ (IREL,SYMTAB€€(1)(1=1)),(IEXT,SYMTAB(1)(0=0))_^1_$DIMENSION KRFCNT(100),IDIM(100),IREL(100),IEXT(100)_^1_$EQUIVALENCE (IRSA,SYMTAB(2)),(ICOMTX,SYMTAB(2)),(ISNOL,SYMTAB(2))_^1_$DIMENSION IRSA(100), ICOMTX(100),ISNOL(100)_^1_$BYTE (IDATAS,SYMTAB(3)(15=15)),(IREF,SYMTAB(3)(15=15)),_^1_#$ (IEQVX,SYMTAB(3)(14=8)),(ITILF,SYMTAB(3)(14=8))_^1_$DIMENSION IDATAS(100),IREF(100),IEQVX(100),ITILF(100)_^1_$BY€€TE (IPARTR,SYMTAB(3)(7=4)),(INDUCV,SYMTAB(3)(7=7)),(ISFARG,_^1_#$ SYMTAB(3)(6=6)),(IARGNO,SYMTAB(3)(5=0)),(IPARTL,SYMTAB(3)(3=0))_^1_$DIMENSION IPARTR(100),INDUCV(100),ISFARG(100),IARGNO(100),_^1_#$ IPARTL(100)_^1_$EQUIVALENCE (ISYM,SYMTAB(4))_^1_$DIMENSION ISYM(100)_^1C_]_^1C_#PHASE C, D, E LABELED COMMON BLOCK_^1_$EQUIVALENCE (NBLK(1),LOOPTS)_^1_$DIMENSION NBLK(446)_^1_$EQUIVALEN€€CE (NPCBF(1),NBLK(1)),(IDVTAB(1),NBLK(58))_^1_$EQUIVALENCE (NSUMDS,NBLK(370))_^1C_#PUNCH BUFFER, ADDRESS HOLDERS, PRINT BUFFER, INDEX HISTORY TABLES_^1_$EQUIVALENCE(NPTBF,NBLK(371)),(IXS1,NBLK(426)),(IXS2,NBLK(436))_^1C_$INDEX REGISTER HOLDERS FOR SUBROUTINE IXOPT_^1_$DIMENSION NPCBF(57),IDVTAB(312),NPTBF(55),IXS1(10),IXS2(10)_^1C_]_^1C_#PHASE C BLANK COMMON BLOCK_^1C_#INPUT BUFFER€€, OUTPUT BUFFER, OUTPUT RECORD HOLDER_^1_$COMMON//INBUFF(203),NOBUFF(210),NRCD(5)_^1_$COMMON//NFTAB(160),NDSTAB(500)_^1_$COMMON//IV(5),IXS3(10)_^1_$COMMON//NSUMD,NDFL,NADX,NSUMVS,IXC,IXFLAG,IXF,IXQ_^1_$COMMON//IXSX,IUSE,IFIX,NOUTOT,NOWO,NL,NT,NA,NS,ND,NR,NQ,NF_^1_$COMMON//NTYPE,NOWI,NOPC,NOPT,NADD,NXPT_^1_$COMMON//NATYPE,ICT,INCT,NOCT,NSTYPE,LRS,NOBW,NBINC,NPC1_^1_$COMMON//NSETX,NR€€M,NPTBFX,NRC1,NRC2,NW2FL,NW2,NBFL,NXCON_^1_$COMMON//NASCI,ISCOUN,ICOUNT,NOFS,NODS,NDXJ,NX_^1_$COMMON// IHEAD, INOB, INC_^1C_]_^1_$EQUIVALENCE(IND(1),NL)_^1_$DIMENSION IND(14)_^1_$EQUIVALENCE(ICFLG,IV(2)),(ITCOUN,IV(3)),(IDECR,IV(4))_^1C_]_^1C_#OUTPUT DATA STRING_^1C_]_^1_$I=0_]_^1_$J=0_]_^1_$INCT=5_^1_"1 ISYMX=INBUFF(INCT)_^1_$CALL GETSYM_^1C_#SET NATYPE TO RELOCATION-DATA OR PROGR€€AM_^1_$NATYPE=50_^1C ********************************** PSR 718 **************************_^1C ********************************** PSR 718 **************************_^1_(IF(ICOM(ISYMX).EQ.1) GO TO 100_^1_(IF(ICOM(ISYMX).EQ.0) NATYPE=52_^1C ********************************** PSR 718 **************************_^1C_#DOES CURRENT RELOC MATCH PREVIOUS RELOC_^1_$IF(NATYPE.NE.I) GO TO 3€€1_^1C_#YES- IS LOC OF THIS =LOC OF LAST+1_^1_$IF(IRSA(ISYMX)+INBUFF(INCT+1).EQ.K+1) GO TO 40_^1C_#NO_]_^1_!31 I=NATYPE_^1_$J=0_]_^1_$NA=0_]_^1C_2BINARY WORD INTO NRCD(2), SYMTAB POINTER_^1C_2INTO NOPT, ADDITIVE INTO NADD_^1_$NRCD(2)=INBUFF(INCT+2)_^1_$NOPT = INBUFF(INCT)_^1_$NADD = INBUFF(INCT+1)_^1_$IF(NADD .NE. 0) NA = 1_^1_$NOWO = 3+NA_^1_!10 ND=1_]_^1_$NOWI=0_^1_$CALL BLDUP_^1_€€$CALL INOUT_^1_$L=3_]_^1_$K_"=IRSA(ISYMX)+INBUFF(INCT+1)_^1C_#FLOATING PT MAYBE_^1_$IF(ITYPE(ISYMX).NE.1) GO TO 20_^1C_#FIXED-MAYBE 2 WORD_^1C ************************************************************_!84*2023_^1_$IF(IK.EQ.0.OR.KELSIZ.EQ.0) GO TO 30_^1C ************************************************************_!84*2023_^1C_]_^1C_#2 WORD_^1_$NRCD(2)=0_^1_$GO TO 21_^1C_#FLOATI€€NG PT_^1_!20 L=4_]_^1_$NRCD(2)=INBUFF(INCT+3)_^1_!21 IF(J.EQ.0) NATYPE=NATYPE+1_^1C ********************************** FTN 3.1 **************************_^1_$M = ITYPE(ISYMX)_^1_!22 NOWO = 2_^1C ********************************** FTN 3.1 ($) **********************_^1C_2FLAG READY FOR OUTPUT_^1_$ND = 1_^1_$CALL BLDUP_^1_$CALL INOUT_^1_$K=K+1_^1C ********************************** €€FTN 3.1 **************************_^1_$IF (M.NE.3) GO TO 30_^1C_]_^1C_FDOUBLE PRECISION VARIABLE BEING_^1C_FINITIALIZED_^1C_]_^1_$L = 5_^1_$NRCD(2) = INBUFF(INCT+4)_^1_$M = 0_^1_$GO TO 22_^1C ********************************** FTN 3.1 ($) **********************_^1_!30 INCT=INCT+L_^1_$IF(INCT.LT.INBUFF(1)) GO TO 1_^1_$RETURN_^1_!40 J=1_]_^1_$NATYPE=NATYPE+1_^1_$NRCD(2)=INBUFF(INC€€T+2)_^1_$NOWO=2_^1_$GO TO 10_^1C ********************************** PSR 718 **************************_^1C DIAG IF USING DATA STMT TO SET UNLABELED COMMON_^1C_]_^1 100_#INBUFF(INCT)=$202A_^1_(INBUFF(INCT+1)=$462C_^1_(INBUFF(INCT+2)=$3835_^1_(CALL WRITE(3,1,3,INBUFF(INCT))_^1_(IGLAB(1)=$7FFF_^1_(RETURN_^1C ********************************** PSR 718 **************************_^1C €T********************************** PSR 718 **************************_^1_$END_]_^__TPWGSYM1 CSY/ 10C P€1_$SUBROUTINE GETSYM_^1_#*_2/DECK-ID 10C FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^13_]_^1C THIS GETSYM IS USED IN PHASES C,D,E_^1C NON-IDENTICAL GETSYM USED IN PHASES A,B_^1C THIS VERSION USES A SYMBOL TABLE OF 2-1/2 PAGES._^1C ASSUMES THAT 'ISYMPS'€€ HAS BEEN SET TO 2400._^1C_]_^1C_#MASTER LABELED COMMON BLOCK._^1*_] FTN 3.3_^1_$COMMON /A/ IFLAGS,LINECT,LINCT1_^1_$COMMON /A/ IR,IK,IP,IA,IL,IM,IXLGO,IOPTO,IOPTV,IOPTC,IOPTD_^1_$COMMON /A/ MCSTRT,MACRNB,MACSEC_^1_$COMMON /A/ IERRS(16),ISRFAD_^1_$COMMON /A/ LGO,ISCRI,ISCRO,IX_^1*_] FTN 3.3_^1_$COMMON /A/ IGLAB(3),IGLAB1,IGLAB2_^1_$COMMON /A/ ICOMT(12),ICOMTS,ICOMX2,ICOMTL,ISUBP,€€NDPRS,_^1_#$LABX,IBCDTB(48)_^1_$EQUIVALENCE(ICOMB,ICOMT(1)),(ICOMBX,ICOMT(2)),(ICOMDF,_^1_#$ICOMT(3)),(ICOMBN,ICOMT(4))_^1_$DIMENSION ICOMB(6),ICOMBX(6),ICOMDF(6),ICOMBN(7)_^1_$COMMON /A/ LOOPTS,LOOPTX,LOOPTB,LOOPT(50)_^1_$EQUIVALENCE(LINDUC,LOOPT(1))_^1_$DIMENSION LINDUC(10)_^1_$EQUIVALENCE (LBEG,LOOPT(2))_^1_$DIMENSION LBEG(10)_^1_$EQUIVALENCE (LINC,LOOPT(3))_^1_$DIMENSION LINC(1€€0)_^1_$EQUIVALENCE (LEND,LOOPT(4))_^1_$DIMENSION LEND(10)_^1_$BYTE(LLABL,LOOPT(5)(14=0)_))_^1_$DIMENSION LLABL(10)_^1_$BYTE(LID,LOOPT(5)(15=15) )_^1_$DIMENSION LID(10)_^1_$COMMON/A/IEQV(255), IEQVS,IEQVN2_^1_$COMMON /A/ ISTAB(150),ISTABS,ISTAB2_^1_$COMMON /A/ IBUFS,ISET(25),LBLANK,KSFCNT,KSNCNT,ISORSC,_^1_#$IHOBIT,ISTNO,ISSFLG,ISUBPN,ITERM,JSORSC,KEQVS_^1C_#SYMBOL TABLE LABELED C€€OMMON BLOCK_^1_$COMMON /A/ ISYMN, ISYMFL,ISYMD,ISYMX,ISYMS,ISYMP,ISYMPC,ISYMPS,_^1_#$ ISYMNS, SYMTAB(2400)_^1_$INTEGER SYMTAB_^1_$BYTE (IDUM,SYMTAB(1)(15=15)),(KDUMY,SYMTAB(1)(15=15)),_^1_#$(ICLASS,SYMTAB(1)(14=11)),(ITYPE,SYMTAB(1)(10=9))_^1_$DIMENSION IDUM(100),KDUMY(100),ICLASS(100),ITYPE(100)_^1_$BYTE (ISNGL, SYMTAB(1)(8=8)),(KELSIZ,SYMTAB(1)(8=8)),_^1_#$ (ICOM,SYMTAB(1)(7=5)),€€(IPART,SYMTAB(1)(4=3))_^1_$DIMENSION ISNGL(100),KELSIZ(100),ICOM(100),IPART(100)_^1_$BYTE (KRFCNT,SYMTAB(1)(2=2)),(IDIM,SYMTAB(1)(1=0)),_^1_#$ (IREL,SYMTAB(1)(1=1)),(IEXT,SYMTAB(1)(0=0))_^1_$DIMENSION KRFCNT(100),IDIM(100),IREL(100),IEXT(100)_^1_$EQUIVALENCE (IRSA,SYMTAB(2)),(ICOMTX,SYMTAB(2)),(ISNOL,SYMTAB(2))_^1_$DIMENSION IRSA(100), ICOMTX(100),ISNOL(100)_^1_$BYTE (IDATAS,SYMTAB€€(3)(15=15)),(IREF,SYMTAB(3)(15=15)),_^1_#$ (IEQVX,SYMTAB(3)(14=8)),(ITILF,SYMTAB(3)(14=8))_^1_$DIMENSION IDATAS(100),IREF(100),IEQVX(100),ITILF(100)_^1_$BYTE (IPARTR,SYMTAB(3)(7=4)),(INDUCV,SYMTAB(3)(7=7)),(ISFARG,_^1_#$ SYMTAB(3)(6=6)),(IARGNO,SYMTAB(3)(5=0)),(IPARTL,SYMTAB(3)(3=0))_^1_$DIMENSION IPARTR(100),INDUCV(100),ISFARG(100),IARGNO(100),_^1_#$ IPARTL(100)_^1_$EQUIVALENCE (I€€SYM,SYMTAB(4))_^1_$DIMENSION ISYM(100)_^1C_]_^1_$ISYMP=(ISYMX/ISYMPS)*ISYMPS_^1_$ISYMX=ISYMX-ISYMP_^1_$IF (ISYMP.EQ.ISYMPC) RETURN_^1_$J=(ISYMPC/ISYMPS)*27+1_^1_$J=J+J/54_^1_$IF (J-(J/11)*11.NE.1) GOTO 10_^1_$CALL WRITE (11,J,960,SYMTAB(1))_^1_$J=J+11_^1_$CALL WRITE (11,J,960,SYMTAB(961))_^1_$J=J+11_^1_$CALL WRITE (11,J,480,SYMTAB(1921))_^1_$GOTO 20_^1_!10 CALL WRITE (11,J,480,SYMT€€AB(1))_^1_$J=J+6_^1_$CALL WRITE (11,J,960,SYMTAB(481))_^1_$J=J+11_^1_$CALL WRITE (11,J,960,SYMTAB(1441))_^1_!20 J=(ISYMP/ISYMPS)*27+1_^1_$J=J+J/54_^1_$IF (J-(J/11)*11.NE.1) GOTO 30_^1_$CALL READ (11,J,960,SYMTAB(1))_^1_$J=J+11_^1_$CALL READ (11,J,960,SYMTAB(961))_^1_$J=J+11_^1_$CALL READ (11,J,480,SYMTAB(1921))_^1_$GOTO 40_^1_!30 CALL READ (11,J,480,SYMTAB(1))_^1_$J=J+6_^1_$CALL RE€lAD (11,J,960,SYMTAB(481))_^1_$J=J+11_^1_$CALL READ (11,J,960,SYMTAB(1441))_^1_!40 ISYMPC=ISYMP_^1_$END_]_^__lPWINOUT CSY/ 11C P€1_$SUBROUTINE INOUT_^1_#*_2/DECK-ID 11C FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^13_]_^1C INOUT IS USED IN PHASE C_^1C_]_^1C_#MASTER LABELED COMMON BLOCK._^1*_] FTN 3.3_^1_$COMMON /A/ IFLAGS,LINECT,LINCT1_^1_$COMMON /A/ IR,IK,IP,IA,IL,IM,IXLGO,IOPT€€O,IOPTV,IOPTC,IOPTD_^1_$COMMON /A/ MCSTRT,MACRNB,MACSEC_^1_$COMMON /A/ IERRS(16),ISRFAD_^1_$COMMON /A/ LGO,ISCRI,ISCRO,IX_^1*_] FTN 3.3_^1_$COMMON /A/ IGLAB(3),IGLAB1,IGLAB2_^1_$COMMON /A/ ICOMT(12),ICOMTS,ICOMX2,ICOMTL,ISUBP,NDPRS,_^1_#$LABX,IBCDTB(48)_^1_$EQUIVALENCE(ICOMB,ICOMT(1)),(ICOMBX,ICOMT(2)),(ICOMDF,_^1_#$ICOMT(3)),(ICOMBN,ICOMT(4))_^1_$DIMENSION ICOMB(6),ICOMBX(6),ICOM€€DF(6),ICOMBN(7)_^1_$COMMON /A/ LOOPTS,LOOPTX,LOOPTB,LOOPT(50)_^1_$EQUIVALENCE(LINDUC,LOOPT(1))_^1_$DIMENSION LINDUC(10)_^1_$EQUIVALENCE (LBEG,LOOPT(2))_^1_$DIMENSION LBEG(10)_^1_$EQUIVALENCE (LINC,LOOPT(3))_^1_$DIMENSION LINC(10)_^1_$EQUIVALENCE (LEND,LOOPT(4))_^1_$DIMENSION LEND(10)_^1_$BYTE(LLABL,LOOPT(5)(14=0)_))_^1_$DIMENSION LLABL(10)_^1_$BYTE(LID,LOOPT(5)(15=15) )_^1_$DIMEN€€SION LID(10)_^1_$COMMON/A/IEQV(255), IEQVS,IEQVN2_^1_$COMMON /A/ ISTAB(150),ISTABS,ISTAB2_^1_$COMMON /A/ IBUFS,ISET(25),LBLANK,KSFCNT,KSNCNT,ISORSC,_^1_#$IHOBIT,ISTNO,ISSFLG,ISUBPN,ITERM,JSORSC,KEQVS_^1C_#SYMBOL TABLE LABELED COMMON BLOCK_^1_$COMMON /A/ ISYMN, ISYMFL,ISYMD,ISYMX,ISYMS,ISYMP,ISYMPC,ISYMPS,_^1_#$ ISYMNS, SYMTAB(2400)_^1_$INTEGER SYMTAB_^1_$BYTE (IDUM,SYMTAB(1)(15=15)€€),(KDUMY,SYMTAB(1)(15=15)),_^1_#$(ICLASS,SYMTAB(1)(14=11)),(ITYPE,SYMTAB(1)(10=9))_^1_$DIMENSION IDUM(100),KDUMY(100),ICLASS(100),ITYPE(100)_^1_$BYTE (ISNGL, SYMTAB(1)(8=8)),(KELSIZ,SYMTAB(1)(8=8)),_^1_#$ (ICOM,SYMTAB(1)(7=5)),(IPART,SYMTAB(1)(4=3))_^1_$DIMENSION ISNGL(100),KELSIZ(100),ICOM(100),IPART(100)_^1_$BYTE (KRFCNT,SYMTAB(1)(2=2)),(IDIM,SYMTAB(1)(1=0)),_^1_#$ (IREL,SYMTAB(1€€)(1=1)),(IEXT,SYMTAB(1)(0=0))_^1_$DIMENSION KRFCNT(100),IDIM(100),IREL(100),IEXT(100)_^1_$EQUIVALENCE (IRSA,SYMTAB(2)),(ICOMTX,SYMTAB(2)),(ISNOL,SYMTAB(2))_^1_$DIMENSION IRSA(100), ICOMTX(100),ISNOL(100)_^1_$BYTE (IDATAS,SYMTAB(3)(15=15)),(IREF,SYMTAB(3)(15=15)),_^1_#$ (IEQVX,SYMTAB(3)(14=8)),(ITILF,SYMTAB(3)(14=8))_^1_$DIMENSION IDATAS(100),IREF(100),IEQVX(100),ITILF(100)_^1_$BYTE€€ (IPARTR,SYMTAB(3)(7=4)),(INDUCV,SYMTAB(3)(7=7)),(ISFARG,_^1_#$ SYMTAB(3)(6=6)),(IARGNO,SYMTAB(3)(5=0)),(IPARTL,SYMTAB(3)(3=0))_^1_$DIMENSION IPARTR(100),INDUCV(100),ISFARG(100),IARGNO(100),_^1_#$ IPARTL(100)_^1_$EQUIVALENCE (ISYM,SYMTAB(4))_^1_$DIMENSION ISYM(100)_^1C_]_^1C_#PHASE C, D, E LABELED COMMON BLOCK_^1_$EQUIVALENCE (NBLK(1),LOOPTS)_^1_$DIMENSION NBLK(446)_^1_$EQUIVALENCE€€ (NPCBF(1),NBLK(1)),(IDVTAB(1),NBLK(58))_^1_$EQUIVALENCE (NSUMDS,NBLK(370))_^1C_#PUNCH BUFFER, ADDRESS HOLDERS, PRINT BUFFER, INDEX HISTORY TABLES_^1_$EQUIVALENCE(NPTBF,NBLK(371)),(IXS1,NBLK(426)),(IXS2,NBLK(436))_^1C_$INDEX REGISTER HOLDERS FOR SUBROUTINE IXOPT_^1_$DIMENSION NPCBF(57),IDVTAB(312),NPTBF(55),IXS1(10),IXS2(10)_^1C_]_^1C_#PHASE C BLANK COMMON BLOCK_^1C_#INPUT BUFFER, €€OUTPUT BUFFER, OUTPUT RECORD HOLDER_^1_$COMMON//INBUFF(203),NOBUFF(210),NRCD(5)_^1_$COMMON//NFTAB(160),NDSTAB(500)_^1_$COMMON//IV(5),IXS3(10)_^1_$COMMON//NSUMD,NDFL,NADX,NSUMVS,IXC,IXFLAG,IXF,IXQ_^1_$COMMON//IXSX,IUSE,IFIX,NOUTOT,NOWO,NL,NT,NA,NS,ND,NR,NQ,NF_^1_$COMMON//NTYPE,NOWI,NOPC,NOPT,NADD,NXPT_^1_$COMMON//NATYPE,ICT,INCT,NOCT,NSTYPE,LRS,NOBW,NBINC,NPC1_^1_$COMMON//NSETX,NRM,€€NPTBFX,NRC1,NRC2,NW2FL,NW2,NBFL,NXCON_^1_$COMMON//NASCI,ISCOUN,ICOUNT,NOFS,NODS,NDXJ,NX_^1_$COMMON// IHEAD, INOB, INC_^1C_]_^1_$EQUIVALENCE(IND(1),NL)_^1_$DIMENSION IND(14)_^1_$EQUIVALENCE(ICFLG,IV(2)),(ITCOUN,IV(3)),(IDECR,IV(4))_^1_$EQUIVALENCE (NBCT,ISCOUN)_^1C_#******************************************************_^1C_#*_S*_^1C_#*_S*_^1C_#*_S*_^1C_#****************************€€**************************_^1C_#* AUTHOR_!-_;24/MAR/67_!*_^1C_#* NAME_#-_G*_^1C_#* PURPOSE -_G*_^1C_#* FUNCTION -_G*_^1C_#* INPUT_"-_G*_^1C_#* REF_$-_G*_^1C_#* OUTPUT_!-_G*_^1C_#* LINKAGE -_G*_^1C_#* ERRORS_!-_G*_^1C_#******************************************************_^1C_2CHECK FOR END OF INPUT BLOCK_^1_$IF(INCT + NOWI .LT. INBUFF(1) .OR. NATYPE .EQ. 60) GO TO 20_^1€€_$CALL REED_^1_$INCT = 1_^1_!20 IF(LRS .EQ. 0) GO TO 40_^1C_2LRS 16 CHECK FOR DIVIDE NEXT_^1_$IF (INCT .NE. 1) GO TO 23_^1C_2CHECK FOR PSEUDO RECORD HEADER_^1_$IF(INBUFF(3) .NE. 49) GO TO 30_^1_$NX = 5_^1_$GO TO 25_^1_!23 NX = INCT + NOWI_^1_!25 CALL BKDWN_^1_$IF (NOPC .NE. 20) GO TO 30_^1C_2THIS IS A DVI IS IT INDEXED_^1_$IF (NS .NE. 0) GO TO 60_^1_!30 LRS = 0_^1_$GO TO 60_^1_!4€€0 DO 50 I = 1,NOWO_^1_$NOBUFF(NOCT) = NRCD(I)_^1_$NOCT = NOCT + 1_^1_!50 NRCD(I) =0_^1_$IF(NATYPE .EQ. 60) GO TO 55_^1_$IF(NOCT .LE. 196) GO TO 60_^1C_2NO. WDS INTO OUTPUT BUFFER_^1_!55 NOCT = NOCT-1_^1_$NOBUFF(1) = NOCT_^1C_2BUMP BUFFER COUNT_^1_$NBCT = NBCT + 1_^1C_2WRITE ON MASS STORAGE_^1_$CALL WRITE (ISCRO,0,NOCT,NOBUFF(1))_^1_$DO 56 I=1,NOCT_^1_!56 NOBUFF(I)=0_^1_$NOCT = 2_^1€_!60 RETURN_^1_$END_]_^__ PWIXOPT CSY/ 12C P€1_$SUBROUTINE IXOPT_^1_#-_2/DECK-ID 12C FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^13_]_^1C IXOPT IS USED IN PHASE C_^1C_]_^1C_#MASTER LABELED COMMON BLOCK._^1*_] FTN 3.3_^1_$COMMON /A/ IFLAGS,LINECT,LINCT1_^1_$COMMON /A/ IR,IK,IP,IA,IL,IM,IXLGO,IOPT€€O,IOPTV,IOPTC,IOPTD_^1_$COMMON /A/ MCSTRT,MACRNB,MACSEC_^1_$COMMON /A/ IERRS(16),ISRFAD_^1_$COMMON /A/ LGO,ISCRI,ISCRO,IX_^1*_] FTN 3.3_^1_$COMMON /A/ IGLAB(3),IGLAB1,IGLAB2_^1_$COMMON /A/ ICOMT(12),ICOMTS,ICOMX2,ICOMTL,ISUBP,NDPRS,_^1_#$LABX,IBCDTB(48)_^1_$EQUIVALENCE(ICOMB,ICOMT(1)),(ICOMBX,ICOMT(2)),(ICOMDF,_^1_#$ICOMT(3)),(ICOMBN,ICOMT(4))_^1_$DIMENSION ICOMB(6),ICOMBX(6),ICOM€€DF(6),ICOMBN(7)_^1_$COMMON /A/ LOOPTS,LOOPTX,LOOPTB,LOOPT(50)_^1_$EQUIVALENCE(LINDUC,LOOPT(1))_^1_$DIMENSION LINDUC(10)_^1_$EQUIVALENCE (LBEG,LOOPT(2))_^1_$DIMENSION LBEG(10)_^1_$EQUIVALENCE (LINC,LOOPT(3))_^1_$DIMENSION LINC(10)_^1_$EQUIVALENCE (LEND,LOOPT(4))_^1_$DIMENSION LEND(10)_^1_$BYTE(LLABL,LOOPT(5)(14=0)_))_^1_$DIMENSION LLABL(10)_^1_$BYTE(LID,LOOPT(5)(15=15) )_^1_$DIMEN€€SION LID(10)_^1_$COMMON/A/IEQV(255), IEQVS,IEQVN2_^1_$COMMON /A/ ISTAB(150),ISTABS,ISTAB2_^1_$COMMON /A/ IBUFS,ISET(25),LBLANK,KSFCNT,KSNCNT,ISORSC,_^1_#$IHOBIT,ISTNO,ISSFLG,ISUBPN,ITERM,JSORSC,KEQVS_^1C_#SYMBOL TABLE LABELED COMMON BLOCK_^1_$COMMON /A/ ISYMN, ISYMFL,ISYMD,ISYMX,ISYMS,ISYMP,ISYMPC,ISYMPS,_^1_#$ ISYMNS, SYMTAB(2400)_^1_$INTEGER SYMTAB_^1_$BYTE (IDUM,SYMTAB(1)(15=15)€€),(KDUMY,SYMTAB(1)(15=15)),_^1_#$(ICLASS,SYMTAB(1)(14=11)),(ITYPE,SYMTAB(1)(10=9))_^1_$DIMENSION IDUM(100),KDUMY(100),ICLASS(100),ITYPE(100)_^1_$BYTE (ISNGL, SYMTAB(1)(8=8)),(KELSIZ,SYMTAB(1)(8=8)),_^1_#$ (ICOM,SYMTAB(1)(7=5)),(IPART,SYMTAB(1)(4=3))_^1_$DIMENSION ISNGL(100),KELSIZ(100),ICOM(100),IPART(100)_^1_$BYTE (KRFCNT,SYMTAB(1)(2=2)),(IDIM,SYMTAB(1)(1=0)),_^1_#$ (IREL,SYMTAB(1€€)(1=1)),(IEXT,SYMTAB(1)(0=0))_^1_$DIMENSION KRFCNT(100),IDIM(100),IREL(100),IEXT(100)_^1_$EQUIVALENCE (IRSA,SYMTAB(2)),(ICOMTX,SYMTAB(2)),(ISNOL,SYMTAB(2))_^1_$DIMENSION IRSA(100), ICOMTX(100),ISNOL(100)_^1_$BYTE (IDATAS,SYMTAB(3)(15=15)),(IREF,SYMTAB(3)(15=15)),_^1_#$ (IEQVX,SYMTAB(3)(14=8)),(ITILF,SYMTAB(3)(14=8))_^1_$DIMENSION IDATAS(100),IREF(100),IEQVX(100),ITILF(100)_^1_$BYTE€€ (IPARTR,SYMTAB(3)(7=4)),(INDUCV,SYMTAB(3)(7=7)),(ISFARG,_^1_#$ SYMTAB(3)(6=6)),(IARGNO,SYMTAB(3)(5=0)),(IPARTL,SYMTAB(3)(3=0))_^1_$DIMENSION IPARTR(100),INDUCV(100),ISFARG(100),IARGNO(100),_^1_#$ IPARTL(100)_^1_$EQUIVALENCE (ISYM,SYMTAB(4))_^1_$DIMENSION ISYM(100)_^1C_]_^1C_#PHASE C, D, E LABELED COMMON BLOCK_^1_$EQUIVALENCE (NBLK(1),LOOPTS)_^1_$DIMENSION NBLK(446)_^1_$EQUIVALENCE€€ (NPCBF(1),NBLK(1)),(IDVTAB(1),NBLK(58))_^1_$EQUIVALENCE (NSUMDS,NBLK(370))_^1C_#PUNCH BUFFER, ADDRESS HOLDERS, PRINT BUFFER, INDEX HISTORY TABLES_^1_$EQUIVALENCE(NPTBF,NBLK(371)),(IXS1,NBLK(426)),(IXS2,NBLK(436))_^1C_$INDEX REGISTER HOLDERS FOR SUBROUTINE IXOPT_^1_$DIMENSION NPCBF(57),IDVTAB(312),NPTBF(55),IXS1(10),IXS2(10)_^1C_]_^1C_#PHASE C BLANK COMMON BLOCK_^1C_#INPUT BUFFER, €€OUTPUT BUFFER, OUTPUT RECORD HOLDER_^1_$COMMON//INBUFF(203),NOBUFF(210),NRCD(5)_^1_$COMMON//NFTAB(160),NDSTAB(500)_^1_$COMMON//IV(5),IXS3(10)_^1_$COMMON//NSUMD,NDFL,NADX,NSUMVS,IXC,IXFLAG,IXF,IXQ_^1_$COMMON//IXSX,IUSE,IFIX,NOUTOT,NOWO,NL,NT,NA,NS,ND,NR,NQ,NF_^1_$COMMON//NTYPE,NOWI,NOPC,NOPT,NADD,NXPT_^1_$COMMON//NATYPE,ICT,INCT,NOCT,NSTYPE,LRS,NOBW,NBINC,NPC1_^1_$COMMON//NSETX,NRM,€€NPTBFX,NRC1,NRC2,NW2FL,NW2,NBFL,NXCON_^1_$COMMON//NASCI,ISCOUN,ICOUNT,NOFS,NODS,NDXJ,NX_^1_$COMMON// IHEAD, INOB, INC_^1C_]_^1C_#INDEX REGISTER OPTIMIZATION_^1_$EQUIVALENCE(IND(1),NL)_^1_$DIMENSION IND(14)_^1_$EQUIVALENCE(ICFLG,IV(2)),(ITCOUN,IV(3)),(IDECR,IV(4))_^1C_]_^1C_]_^1C_#PRIMARY SCAN-EXAMINE SEARCH WORD_^1C_]_^1_$IX=NXPT_^1_$NOPC1=NOPC_^1_$L = INCT_^1C_#INDEXED_^1_$IF(NQ.€€EQ.1)GO TO 30_^1_$IF(NS.EQ.1)GO TO 10_^1C_#NO_]_^1_$CALL CHKWD_^1C_#STA_]_^1_$IF (NOPC.EQ.14) GO TO 11_^1C_#NO_]_^1_!12 NACC=0_^1_!13 IXC=0_^1_$RETURN_^1_!11 IF(NA.EQ.1.AND.NADD.NE.0) GO TO 12_^1C_#NO ADDITIVE-SET ACCUMULATOR_^1_$NACC=NOPT_^1_$GO TO 13_^1C_#INDEXED WORD-DVI_^1_!10 IF(NOPC.EQ.20)GO TO 20_^1C_#NO_]_^1_$IF(IX.EQ.IXQ) GO TO 30_^1_$IF(IX.EQ.IXF) GO TO 40_^1_$CALL CHKWD_€€^1_$IF(IXFLAG.EQ.0) GO TO 50_^1C ************************************************************** 95*3429_^1C_]_^1C_#GO GENERATE CODE TO SET NEW INDEX VALUE INTO Q-REGISTER_^1C_#UPDATE Q-REGISTER INDEX HOLDER_^1C_]_^1_$IXQ = IX_^1C_]_^1C ************************************************************** 95*3429_^1_$GO TO 140_^1C_#INDEXED DVI- SET FF BIT_^1_!20 NRCD(2)=256_^1_$RETURN_^1C€€_#IX IN Q-SET Q BIT_^1_!30 NRCD(2)=512_^1_!31 CALL CHKWD_^1_$GO TO 12_^1C_#IX IN FF-SET FF BIT_^1_!40 NRCD(2)=256_^1_$GO TO 31_^1_!70 IF(IX.NE.NXPT) GO TO 90_^1_$IF(IXC.GT.0) GO TO 56_^1_!60 CALL CHKWD_^1_$IF(IXFLAG.NE.0) GO TO 14_^1_$NACC=0_^1C_#SECONDARY SCAN ON TABLE WORD_^1_!50 INCT=INCT+NOWI_^1_$IF(INBUFF(1).LE.INCT) GO TO 14_^1C_#MORE ROOM IN BUFFER_^1_$NX=INCT_^1_$CALL BKDWN€€_^1_$IF(NT.NE.0) GO TO 14_^1_$IF(NS.NE.1)GO TO 60_^1C_#INDEXED-IS IT DVI_^1_$IF(NOPC.NE.20)GO TO 70_^1_$IF(IX.NE.NXPT) GO TO 14_^1_!56 IXF=IX_^1_$IUSE=1_^1_$INCT = L_^1_$IF(IX.NE.NACC) GO TO 80_^1_!54 CALL QXLD(4)_^1C_#SET FF BIT_^1 540 NRCD(2)=256_^1_$GO TO 55_^1_!80 IF(NOPC1.NE.12) GO TO 81_^1_$CALL QXLD(2)_^1_$GO TO 54_^1_!81 CALL QXLD(1)_^1_$CALL QXLD(3)_^1_$IXQ=0_^1_$GO TO 54€€0_^1_!90 IF(IXF.EQ.NXPT) GO TO 14_^1_$IF(IXQ.NE.NXPT) GO TO 100_^1C_#STQ FF_^1_$INCT = L_^1_$CALL QXLD(3)_^1_$IXF=IXQ_^1_$IUSE=1_^1C_#SEARCH WORD A Q DESTROYER_^1C***********************************************************_#83*2487_^1_!14 IF((NOPC1.GE.19.AND.NOPC1.LE.22).OR.(NOPC1.GE.32.AND.NOPC1.LE.37)_^1_#* .OR.NOPC1.EQ.62.OR.NOPC1.EQ.64) GO TO 140_^1_%IXQ = IX_^1C*************€€**********************************************_#83*2487_^1C_#IX IN A_^1 140 I=5_]_^1_$IF(IX.NE.NACC) I=1_^1C_#INSERT TRAQ OR LDQ_^1_$INCT = L_^1_$CALL QXLD(I)_^1C_#SET Q BIT IN BINARY OP_^1_$NRCD(2)=512_^1_!55 DO 51 I=1,10_^1_$IXS2(I)=0_^1_$IXS3(I)=0_^1_!51 IXS1(I)=0_^1_$IXSX=1_^1_$GO TO 12_^1 100 DO 101 I=1,IXSX_^1_$IF(IXS1(I).EQ.NXPT) GO TO 102_^1 101 CONTINUE_^1_$IXC=1_^1_$I€æXS1(IXSX)=NXPT_^1_$ISYMX=NXPT_^1_$CALL GETSYM_^1_$IXS3(IXSX)=IEQVX(ISYMX)_^1_$DO 103 I=1,IXSX_^1_$IF(IXS1(I).NE.0) IXS2(I)=1_^1 103 CONTINUE_^1_$IXSX=IXSX+1_^1_$GO TO 60_^1 102 IF(IXS2(I).GT.0)GO TO 14_^1_$GO TO 60_^1_$END_]_^__æPWPHSEC CSY/ 13C P€1_$SUBROUTINE PHASEC_^1_#*_2/DECK-ID 13C FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^13_]_^1C PHASEC IS USED IN PHASE C_^1C THIS IS THE 2.0B VERSION._^1C_]_^1C_#MASTER LABELED COMMON BLOCK._^1*_] FTN 3.3_^1_$COMMON /A/ IFLAGS,LINECT,LINCT1_^1_$COMMON €€/A/ IR,IK,IP,IA,IL,IM,IXLGO,IOPTO,IOPTV,IOPTC,IOPTD_^1_$COMMON /A/ MCSTRT,MACRNB,MACSEC_^1_$COMMON /A/ IERRS(16),ISRFAD_^1_$COMMON /A/ LGO,ISCRI,ISCRO,IX_^1*_] FTN 3.3_^1_$COMMON /A/ IGLAB(3),IGLAB1,IGLAB2_^1_$COMMON /A/ ICOMT(12),ICOMTS,ICOMX2,ICOMTL,ISUBP,NDPRS,_^1_#$LABX,IBCDTB(48)_^1_$EQUIVALENCE(ICOMB,ICOMT(1)),(ICOMBX,ICOMT(2)),(ICOMDF,_^1_#$ICOMT(3)),(ICOMBN,ICOMT(4))_^1_$D€€IMENSION ICOMB(6),ICOMBX(6),ICOMDF(6),ICOMBN(7)_^1_$COMMON /A/ LOOPTS,LOOPTX,LOOPTB,LOOPT(50)_^1_$EQUIVALENCE(LINDUC,LOOPT(1))_^1_$DIMENSION LINDUC(10)_^1_$EQUIVALENCE (LBEG,LOOPT(2))_^1_$DIMENSION LBEG(10)_^1_$EQUIVALENCE (LINC,LOOPT(3))_^1_$DIMENSION LINC(10)_^1_$EQUIVALENCE (LEND,LOOPT(4))_^1_$DIMENSION LEND(10)_^1_$BYTE(LLABL,LOOPT(5)(14=0)_))_^1_$DIMENSION LLABL(10)_^1_$BYTE(€€LID,LOOPT(5)(15=15) )_^1_$DIMENSION LID(10)_^1_$COMMON/A/IEQV(255), IEQVS,IEQVN2_^1_$COMMON /A/ ISTAB(150),ISTABS,ISTAB2_^1_$COMMON /A/ IBUFS,ISET(25),LBLANK,KSFCNT,KSNCNT,ISORSC,_^1_#$IHOBIT,ISTNO,ISSFLG,ISUBPN,ITERM,JSORSC,KEQVS_^1C_#SYMBOL TABLE LABELED COMMON BLOCK_^1_$COMMON /A/ ISYMN, ISYMFL,ISYMD,ISYMX,ISYMS,ISYMP,ISYMPC,ISYMPS,_^1_#$ ISYMNS, SYMTAB(2400)_^1_$INTEGER SYMTAB€€_^1_$BYTE (IDUM,SYMTAB(1)(15=15)),(KDUMY,SYMTAB(1)(15=15)),_^1_#$(ICLASS,SYMTAB(1)(14=11)),(ITYPE,SYMTAB(1)(10=9))_^1_$DIMENSION IDUM(100),KDUMY(100),ICLASS(100),ITYPE(100)_^1_$BYTE (ISNGL, SYMTAB(1)(8=8)),(KELSIZ,SYMTAB(1)(8=8)),_^1_#$ (ICOM,SYMTAB(1)(7=5)),(IPART,SYMTAB(1)(4=3))_^1_$DIMENSION ISNGL(100),KELSIZ(100),ICOM(100),IPART(100)_^1C ********************************** FTN €€3.1 **************************_^1_$BYTE (IDCONB,SYMTAB(1)(4=4)), (IUNDEF,SYMTAB(1)(3=3))_^1_$DIMENSION IDCONB(100), IUNDEF(100)_^1C ********************************** FTN 3.1 ($) **********************_^1_$BYTE (KRFCNT,SYMTAB(1)(2=2)),(IDIM,SYMTAB(1)(1=0)),_^1_#$ (IREL,SYMTAB(1)(1=1)),(IEXT,SYMTAB(1)(0=0))_^1_$DIMENSION KRFCNT(100),IDIM(100),IREL(100),IEXT(100)_^1_$EQUIVALENCE (I€€RSA,SYMTAB(2)),(ICOMTX,SYMTAB(2)),(ISNOL,SYMTAB(2))_^1_$DIMENSION IRSA(100), ICOMTX(100),ISNOL(100)_^1_$BYTE (IDATAS,SYMTAB(3)(15=15)),(IREF,SYMTAB(3)(15=15)),_^1_#$ (IEQVX,SYMTAB(3)(14=8)),(ITILF,SYMTAB(3)(14=8))_^1_$DIMENSION IDATAS(100),IREF(100),IEQVX(100),ITILF(100)_^1_$BYTE (IPARTR,SYMTAB(3)(7=4)),(INDUCV,SYMTAB(3)(7=7)),(ISFARG,_^1_#$ SYMTAB(3)(6=6)),(IARGNO,SYMTAB(3)(5=0)),€€(IPARTL,SYMTAB(3)(3=0))_^1_$DIMENSION IPARTR(100),INDUCV(100),ISFARG(100),IARGNO(100),_^1_#$ IPARTL(100)_^1_$EQUIVALENCE (ISYM,SYMTAB(4))_^1_$DIMENSION ISYM(100)_^1C_]_^1C_#PHASE C, D, E LABELED COMMON BLOCK_^1_$EQUIVALENCE (NBLK(1),LOOPTS)_^1_$DIMENSION NBLK(446)_^1_$EQUIVALENCE (NPCBF(1),NBLK(1)),(IDVTAB(1),NBLK(58))_^1_$EQUIVALENCE (NSUMDS,NBLK(370))_^1C_#PUNCH BUFFER, ADDRESS H€€OLDERS, PRINT BUFFER, INDEX HISTORY TABLES_^1_$EQUIVALENCE(NPTBF,NBLK(371)),(IXS1,NBLK(426)),(IXS2,NBLK(436))_^1C_$INDEX REGISTER HOLDERS FOR SUBROUTINE IXOPT_^1_$DIMENSION NPCBF(57),IDVTAB(312),NPTBF(55),IXS1(10),IXS2(10)_^1C_]_^1C_#PHASE C BLANK COMMON BLOCK_^1C_#INPUT BUFFER, OUTPUT BUFFER, OUTPUT RECORD HOLDER_^1_$COMMON//INBUFF(203),NOBUFF(210),NRCD(5)_^1_$COMMON//NFTAB(160),N€€DSTAB(500)_^1_$COMMON//IV(5),IXS3(10)_^1_$COMMON//NSUMD,NDFL,NADX,NSUMVS,IXC,IXFLAG,IXF,IXQ_^1_$COMMON//IXSX,IUSE,IFIX,NOUTOT,NOWO,NL,NT,NA,NS,ND,NR,NQ,NF_^1_$COMMON//NTYPE,NOWI,NOPC,NOPT,NADD,NXPT_^1_$COMMON//NATYPE,ICT,INCT,NOCT,NSTYPE,LRS,NOBW,NBINC,NPC1_^1_$COMMON//NSETX,NRM,NPTBFX,NRC1,NRC2,NW2FL,NW2,NBFL,NXCON_^1_$COMMON//NASCI,ISCOUN,ICOUNT,NOFS,NODS,NDXJ,NX_^1_$COMMON// IHE€€AD, INOB, INC_^1C_]_^1C_]_^1C_#******************************************************_^1C_#*_S*_^1C_#* LIST INFORMATION._@*_^1C_#*_S*_^1C_#******************************************************_^1C_#* PAGENO - CURRENT PAGE NUMBER_5*_^1C_#* LINECT - MAXIMUM LINE COUNT_6*_^1C_#* LINCT1 - CURRENT LINE COUNT_6*_^1C_#******************************************************_^1C_]_^1C_#€€******************************************************_^1C_#*_S*_^1C_#* COMPILE TIME OPTION INDICATORS. (0 = NOT SET)_#*_^1C_#*_S*_^1C_#******************************************************_^1C_#* IR_#- RUN ANYWHERE IND_8*_^1C_#* IK_#- ASA IND_A*_^1C_#* IP_#- PUNCH IND_?*_^1C_#* IA_#- ASSEMBLY LIST IND_7*_^1C_#* IL_#- SOURCE LIST IND_9*_^1C_#* IM_#- 1ST LINE/STATEMENT LIST €€IND_-*_^1C_#* IXLGO - LOAD AND GO IND_9*_^1C_#* LGO_"- START SECTOR FOR LOAD AND GO_,*_^1C_#* ISCRI - INPUT SCRATCH UNIT_6*_^1C_#* ISCRO - OUTPUT SCRATCH UNIT_5*_^1C_#* IX_#- CURRENT INDEX (PHASE 5)_1*_^1C_#******************************************************_^1C_#******************************************************_^1C_#*_S*_^1C_#* GENERATED LABELS._@*_^1C_#*_S*_^1C_#€€******************************************************_^1C_#* IGLAB - GENERATED LABEL SKELETON_0*_^1C_#* IGLAB1 - GENERATED LABEL COUNTER 1_/*_^1C_#* IGLAB2 - GENERATED LABEL COUNTER 2_/*_^1C_#******************************************************_^1C_]_^1C_#******************************************************_^1C_#*_S*_^1C_#* SYMBOL TABLE AND ASSOCIATED PARAMETERS._**_^1C_#€€*_S*_^1C_#******************************************************_^1C_#* SYMTAB - SYMBOL TABLE (7 WORDS PER ENTRY)_(*_^1C_#* ISYMS - MAXIMUM SYMTAB SIZE_5*_^1C_#* ISYMN - CURRENT SYMTAB SIZE_5*_^1C_#* ISYMFL - SYMTAB ENTRY SIZE_7*_^1C_#* ISYMD - SYMBOL PRESENT IND (0=NOT PRESENT)_%*_^1C_#* ISYMX - SYMTAB INDEX_<*_^1C_#* ISYMP - WORD COUNT FOR PAGING (BASE ISYMPS)_$*_^1C_€€#* ISYMPC - CURRENT ISYMP_;*_^1C_#* ISYMPS - PAGE SIZE_?*_^1C_#******************************************************_^1C_]_^1C_#******************************************************_^1C_#*_S*_^1C_#* COMMON BLOCK TABLE AND ASSOCIATED PARAMETERS._#*_^1C_#*_S*_^1C_#******************************************************_^1C_#* ICOMT - COMMON BLOCK TABLE_6*_^1C_#* ICOMTS - MAXIM€€UM ICOMT SIZE_6*_^1C_#* ICOMX2 - ICOMT INDEX_=*_^1C_#* ICOMTL - ICOMT ENTRY SIZE_8*_^1C_#* ISUBP - SUBPROGRAM TYPE BEING COMPILED_**_^1C_#* NDPRS - SUBPROGRAM DUMMY PARAMETER COUNT_(*_^1C_#* LABX_!- ISYMX FOR SUBPROGRAM NAME_/*_^1C_#* IBCDTB - ASCII TO FORTRAN CONVERSION TABLE_'*_^1C_#******************************************************_^1C_#******************************€€************************_^1C_#*_S*_^1C_#* LOOP STRUCTURE TABLE AND ASSOCIATED PARAMETERS._!*_^1C_#*_S*_^1C_#******************************************************_^1C_#* LOOPTS - MAXIMUM LOOPT SIZE_6*_^1C_#* LOOPTX - LOOPT INDEX_=*_^1C_#* LOOPTB - BEGIN DO ENTRY SIZE IN LOOPT_,*_^1C_#* LOOPT - LOOP TABLE_>*_^1C_#******************************************************_^1C_]_^1C€€_#******************************************************_^1C_#*_S*_^1C_#* EQUIVALENCE TABLE AND ASSOCIATED PARAMETERS._$*_^1C_#* PHASE 1 TEMPORARY EQUIVALENCE BUFFERS._+*_^1C_#*_S*_^1C_#******************************************************_^1C_#* IEQV_!- EQUIVALENCE TABLE_7*_^1C_#* IEQVS - MAXIMUM IEQV SIZE_7*_^1C_#* IEQVN2 - IEQV ENTRY SIZE_9*_^1C_#*************************€€*****************************_^1C_]_^1C_#******************************************************_^1C_#*_S*_^1C_#* SPECIFICATOIN TABLE AND ASSOCIATED PARAMETERS._"*_^1C_#*_S*_^1C_#******************************************************_^1C_#* ISTAB - SPECIFICATION TABLE_5*_^1C_#* ISTABS - MAXIMUM ISTAB SIZE_6*_^1C_#* ISTAB2 - CURRENT ISTAB SIZE_6*_^1C_#***************************€€***************************_^1C_]_^1C_#******************************************************_^1C_#*_S*_^1C_#* INDICATOR WORDS AND FLAGS._7*_^1C_#*_S*_^1C_#******************************************************_^1C_#* IBUFS - MAXIMUM IBUF1, IBUF2 AND IWORK SIZE_$*_^1C_#* ISET_!- PRESET SYMTAB TABLE_5*_^1C_#* LBLANK - PRESET BLANK BLANK_^1C_#* KSFCNT - STATEMENT FUNCTION COUNT€€_0*_^1C_#* KSNCNT -_!*** NOT USED ***_4*_^1C_#* ISORSC - INPUT CHARACTERS/WORD COUNT_-*_^1C_#* IHOBIT - HIGH ORDER BIT IN WORD_2*_^1C_#* ISTNO - CURRENT STATEMENT NUMBER_0*_^1C_#* ISSFLG - STATEMENT FUNCTION DUMMY PARAMETER COUNT *_^1C_#* ISUBPN - ISYMX FOR SUBPROGRAM NAME_/*_^1C_#* ITERM -_I*_^1C_#* JSORSC - OUTPUT CHARACTERS/WORD COUNT_,*_^1C_#* KEQVS - MAXIMUM KEQV€€ AND MEQV SIZE_.*_^1C_#******************************************************_^1C_]_^1C_]_^1_$EQUIVALENCE(IND(1),NL)_^1_$DIMENSION IND(14)_^1_$EQUIVALENCE(ICFLG,IV(2)),(ITCOUN,IV(3)),(IDECR,IV(4))_^1C_2ENA,INA,ENQ,INQ,LRS,LLS,QRS,QLS,ARS,ALS_^1_$DIMENSION NTABA(10)_^1C_MENA INA ENQ INQ_^1_$DATA NTABA(1),NTABA(2),NTABA(3),NTABA(4)/2560,2304,3072,3328/_^1C_MLRS LLS QRS QLS_^1_$€€DATA NTABA(5),NTABA(6),NTABA(7),NTABA(8)/3936,4064,3872,4000/_^1C_=ARS ALS_^1_$DATA NTABA(9),NTABA(10)/3904,4032/_^1_$DIMENSION NRGTAB(5)_^1_$DATA NRGTAB(1),NRGTAB(2),NRGTAB(3),NRGTAB(4),NRGTAB(5)/_^1C_#CAQA TCQA TRAQ TCAA TCQQ_^1_#1$8F4,2129,2082,2148,$852/_^1C_]_^1C *** INCREASE ISYMPS AND FORCE A READ OF THE SYMBOL TABLE._^1_$J=(ISYMPC/ISYMPS)*ISYMNS+1_^1_$CALL WRITE (11,J,960,€€SYMTAB(1))_^1_$ISYMPS=2400_^1_$J=1_]_^1_$CALL READ (11,J,960,SYMTAB(1))_^1_$J=J+11_^1_$CALL READ (11,J,960,SYMTAB(961))_^1_$J=J+11_^1_$CALL READ (11,J,480,SYMTAB(1921))_^1_$ISYMPC=0_^1_$IGLAB(1)=ISET(6)_^1_$IGLAB(2)=ISET(7)_^1_$IGLAB(3)=ISET(8)_^1C_2BACKGROUND IRSA IN SYMTAB_^1_$ISYMX = 0_^1_$ISYMP = 0_^1 1_"CALL SYMSCN_^1_$IF (ISYMP .EQ. 1) GO TO 4_^1_$IF (ICOM(ISYMX) .EQ. 0) IRSA€€(ISYMX) = 32767_^1C ********************************** FTN 3.1 **************************_^1_$IUNDEF(ISYMX) = 0_^1C ********************************** FTN 3.1 ($) **********************_^1_$GO TO 1_^1 4_"DO 4000 I = 1, 1148_^1 4000 INBUFF(I) = 0_^1C ********************************** FTN 3.2 **************************_^1_$DO 5 I=1,460_^1C ********************************** FTN €€ 3.2 ($) **********************_^1 5_"NBLK(I) = 0_^1_$IUSE=0_^1_$NOCT = 2_^1_$ICT = 1_^1_$NODS = 1_^1_$NSETX =1_^1_$NOFS = 1_^1_$NADX = 1_^1_$IXSX=1_^1_$NSUMVS=160_^1_$NSUMD =311_^1_$NSUMDS=100_^1_"6 CALL REED_^1_$J = 1_^1_!12 NOWI = INBUFF(1)_^1_$IF(INBUFF (INCT+2) - 17) 20,30,40_^1C_2THIS IS A DATA STRING_^1_!20 CALL DATAST_^1C ********************************** PSR 718 *******€€*******************_^1C ********************************** PSR 718 **************************_^1_(IF(IGLAB(1).EQ.$7FFF) RETURN_^1_(GO TO 6_^1C ********************************** PSR 718 **************************_^1C ********************************** PSR 718 **************************_^1 110 ISYMX=NOPT_^1_$CALL GETSYM_^1C_2BRANCH IF EXTERNAL_^1_%IF(ICLASS(ISYMX).NE.1.AND.IEX€€T(ISYMX).NE.0) GO TO 50_^1_$GO TO (1100,2,333,3,3),NTYPE_^1C ********************************** FTN 3.1 **************************_^1 1100 IUNDEF(ISYMX) = 1_^1C ********************************** FTN 3.1 ($) **********************_^1_$GO TO 11_^1 101 NQ=1_]_^1_$GO TO 11_^1C_#DUMMY ARGUMENT_^1_"2 IF(KDUMY(ISYMX).NE.0) GO TO 22_^1C_#NO-ADC IS SELF-RELATIVE,BIT 15=0_^1 102 NF=1_]€€_^1C_2IS THIS ENTRY IN SYMTAB_^1C_2NO,GO STORE FOR DUMPING IN SYMTAB_^1 210 ISYMX = NOPT_^1_$CALL CHOP_^1_$GO TO 11_^1C_(DUMMY ARGUMENT-IF RUN ANYWHERE,ADC-WILL BE SELF RELATIVE,BIT15_^1C_]_#=1_^1_!22 IF(IR.NE.0) GO TO 25_^1C_#NOT RUN ANYWHERE_^1C_2IS THIS ENTRY IN SYMTAB_^1_%IF(IRSA(ISYMX).LT.32765)GO TO 101_^1C_2NO, DUMP IT IN SYMTAB AT THIS LOCATION_^1 104 CALL LABEL_^1_$GO TO€€ 11_^1 333 IF(ICOM(ISYMX).NE.0)NTYPE=4_^1_"3 IF(KDUMY(ISYMX).EQ.0)GO TO 103_^1C_#DUMMY ARGUMENT-ADC WILL BE STUFFED_^1C_2IS THIS ENTRY IN SYMTAB_^1_$IF(IRSA(ISYMX).GE.32765)GO TO 104_^1C_2YES, DUMP IT IN NDSTAB AT THIS LOCATION_^1_$GO TO 210_^1 103 IF(NTYPE.NE.3)GO TO 210_^1_!25 NQ=1_]_^1_$GO TO 102_^1C_2THIS IS A FORMAT STATEMENT_^1C_#OUTPUT STATEMENT NO._^1_!30 NATYPE=59_^1_$NO€€WO=2_^1_$ND=1_]_^1_$NRCD(2)=-INBUFF(2)_^1_$NOWI=-1_^1_$CALL BLDUP_^1_$CALL INOUT_^1_$INCT=6_^1C_#OUTPUT LABEL_^1_$ISYMX=INBUFF(5)_^1_$CALL GETSYM_^1_$CALL LABEL_^1_$NOPT=INBUFF(1)-5_^1_$CALL BSS_^1_$ICT=1_^1_$CALL INOUT_^1C_#OUTPUT ORG_^1_$NATYPE=52_^1_$NOWO=4_^1_$NADD=0_^1_$NOPT=INBUFF(5)_^1_!31 ND=1_]_^1_$NRCD(2)=INBUFF(INCT)_^1_$CALL BLDUP_^1_$CALL INOUT_^1_$CALL COUNT_^1_$INCT€€=INCT+1_^1_$IF(INCT.GT.INBUFF(1)) GO TO 6_^1C_#OUTPUT CONTINUATION ORG_^1_$NATYPE=53_^1_$NOWO=2_^1_$NQ=1_]_^1_$GO TO 31_^1C_2*** TEST FOR COMPUTE PT HERE_^1 40 CONTINUE_^1C 40 IF(INBUFF(INCT+2).LT.50)GO TO 60_^1C_2THIS IS A DEFINITION POINT_^1C_#CALL DEFPT_#-_^1C_#GO TO 6_^1_!60 INCT = INCT + 4_^1C_2THIS IS A PSEUDO INSTRUCTION_^1C_2BREAK DOWN THE INDICATOR_^1_!70 NX = INCT_^1_$€€CALL BKDWN_^1_$IF( NT .EQ. 0) GO TO 90_^1C_2THIS IS A LABEL RECORD_^1_$CALL CHKWD_^1_$ISYMX_!= INBUFF(INCT+1)_^1_$CALL GETSYM_^1C_2IS IT A STATEMENT LABEL_^1C_2ARE WE PAST 1ST EXECUTEABLE STATEMENT_^1_$IF(ICLASS(ISYMX) .EQ. 7 .OR. NSTYPE .NE. 0) GO TO 75_^1_$CALL LABIN_^1_$GO TO 10_^1_!75 CALL LABEL_^1_$GO TO 10_^1C_2BRANCH ON OP CODE_^1_!90 CALL IXOPT_^1_$NX=INCT_^1_$CALL BKDWN_^1€€_$IF(NOPC.GT.6) GO TO 140_^1C_2SET FIXED WORD FLAG_^1_$NR = 1_^1_$GO TO (100,110,120,200,135,137), NOPC_^1 100 CALL BSS_^1_$GO TO 7_^1 120 CALL CON_^1_$GO TO 7_^1C_2SAVE POINTER_^1C_#PARAMETER STORE ROUTINE_^1 135 K = NOPT_^1_$ISYMX=K_^1_$CALL GETSYM_^1_$N=IRSA(ISYMX)_^1_$I = 1_^1C_2SET UP STORE INTO SYMTAB LOCATION_^1C_2NRCD(2) IS BINARY RELATIVE STORE_^1_$NRCD(2) = 26624_^1 13€€51 NATYPE=9_^1C_#ONE OR TWO WRDS_^1_$IF(ICOUNT-N.GE.128)GO TO 163_^1C_#ONE WORD_^1_$ND=1_]_^1_$NATYPE=3_^1 1630 NOWO=3_^1_$CALL BLDUP_^1_$CALL INOUT_^1_$CALL COUNT_^1C_2IS SEARCH FINISHED_^1 1353 IF(I .GE. NODS) GO TO 10_^1C_2NO,IS THIS LOC TO BE PLUGGED WITH THIS STA_^1_$IF(NDSTAB(I) .EQ. K) GO TO 136_^1_$I=I+2_^1_$GO TO 1353_^1 163 ICT=2_^1_$GO TO 1630_^1C_2YES, SET UP STA INTO €€TABLE LOC_^1 136 NOPT = I+1_^1_$NRCD(2) = 26626_^1_$N=NDSTAB(I+1)_^1_$I = I+2_^1_$GO TO 1351_^1C_2THIS IS A STATEMENT LABEL_^1 137 NATYPE = 59_^1_$NOWO = 2_^1_$NRCD(2) = NOPT_^1_$ND=1_]_^1_$CALL BLDUP_^1_$CALL INOUT_^1_!10 IF (INCT .EQ. 1) GO TO 12_^1_$INCT = INCT + NOWI_^1_$GO TO 70_^1C_2IS THIS THE FIRST EXECUTEABLE COMMAND_^1 140 IF(NSTYPE .NE. 0) GO TO 149_^1 147 NSTYPE = I€€COUNT_^1C_2CHECK PSEUDO CODE_^1 149 IF(NOPC .GT. 29) GO TO 150_^1C_2OP CODE IS CLASS 1 OR 2_^1_$CALL CL12_^1_$IF(NOPC.EQ.10)J=2_^1_$GO TO 7_^1C_2SET FIXED WORD FLAG_^1 150 NR = 1_^1_$IF(NOPC .GT. 33) GO TO 160_^1C_2OP CODE IS CLASS 3_^1 151 NATYPE=11_^1_$NOWO=2_^1C_#READY FOR OUTPUT_^1_$ND=1_]_^1_$CALL BLDUP_^1_$NOPT = AND(NOPT,255)_^1_$NRCD(2)=NTABA(NOPC-29)+NOPT_^1_$GO TO 7_^1€€ 160 IF (NOPC .GT. 39) GO TO 170_^1C_2OP CODE IS SHIFT_^1C_#LRS 16_^1_$IF(NOPC.NE.34.OR.NOPT.NE.16)GO TO 151_^1_$LRS=1_^1_$CALL INOUT_^1_$IF(LRS.NE.1)GO TO 161_^1_$LRS=0_^1_$IUSE=1_^1C_#IS INDEX ALREADY IN FF_^1_$IF(NXPT.EQ.IXF)GO TO 161_^1C_#NO_]_^1C_2PUT LDA INTO OUTPUT BUFFER_^1_$IX=NXPT_^1_$CALL QXLD(2)_^1C_#SET FF TO THIS INDEX_^1_$IXF=NXPT_^1C_2PUT STA- FF INTO OUTPUT BUFFER€€_^1 162 CALL QXLD(4)_^1161_!NOPC=34_^1_$NOWI = 3_^1_$NOPT = 16_^1_$GO TO 151_^1C_2OP CODE IS SKIP_^1 170 IF(NOPC .GT. 47) GO TO 180_^1_$CALL SKIP_^1_$GO TO 8_^1C_2EXTERNAL, IS THIS FIRST ENCOUNTER_^1_!50 IF(IRSA(ISYMX) .EQ. 32767)IRSA(ISYMX) = ICOUNT_^1_!11 NOWO=NOWI-1_^1_$NRCD(2)=NOPT_^1_$NOPT = NADD_^1_$NATYPE = NTYPE + 40_^1_$IF(IRSA(ISYMX).LT.32765)ND=1_^1_"8 CALL BLDUP_^1_"7€€ CALL INOUT_^1_$CALL COUNT_^1_$GO TO (10,91),J_^1_!91 ASSIGN 10 TO IAD1_^1 910 NK=NOWI_^1_$ISYMX=0_^1_$ISYMP=0_^1_!92 DO 93 I=1,14_^1_!93 IND(I)=0_^1_!94 CALL SYMSCN_^1_$IF(ISYMP.EQ.1) GO TO 95_^1_$IF(IRSA(ISYMX).NE.32766) GO TO 94_^1_$CALL LABEL_^1_$ASSIGN 92 TO IAD_^1C_2IS THIS A CONSTANT_^1_$IF (ICLASS (ISYMX) .EQ.2) GO TO 28_^1_$NOPT=KELSIZ(ISYMX)_!+1_^1C *********************€€************* FTN 3.1 **************************_^1_$IF (ITYPE(ISYMX).EQ.3) NOPT = 3_^1C ********************************** FTN 3.1 ($) **********************_^1_!27 CALL BSS_^1 270 CALL INOUT_^1_$CALL COUNT_^1_$GO TO IAD_^1_!28 CALL CON_^1C_2CHECK FOR FLOATING POINT CONSTANT_^1_$GO TO 270_^1C_2ARE THERE DUMMY STORAGES TO BE DUMPED_^1_!95 J1=NODS-1_^1_$DO 96 I=1,J1,2_^1C_2HAS €€THIS ONE BEEN DUMPED_^1_$IF(NDSTAB(I+1).GT.0) GO TO 96_^1C_2NO,DUMP IT BUT NOT INTO SYMTAB_^1_$NDSTAB(I+1) = ICOUNT_^1_$NOPT=1_^1_$ASSIGN 96 TO IAD_^1_!51 NOPT=1_^1_$GO TO 27_^1_!96 CONTINUE_^1_!15 NOWI = NK_^1_$J = 1_^1_$GO TO IAD1_^1C_2INTER REGISTER COMMAND_^1 180 NATYPE = NOPC - 30_^1_$NOPC = NOPC - 59_^1_$NRCD(2) = NRGTAB(NOPC)_^1_$NOWO = NOWI_^1_$ND=1_]_^1_$GO TO 8_^1C_*_^1C_#******************************************************_^1C_]_^1C_#******************************************************_^1C_#*_S*_^1C_#* EQUIVALENCE TABLE AND ASSOCIATED PARAMETERS._$*_^1C_#* PHASE 1 TE€€MPORARY EQUIVALENCE BUFFERS._+*_^1C_#*_S*_^1C_#******************************************************_^1C_#* IEQV_!- EQUIVALENCE TABLE_7*_^1C_#* IEQVS - MAXIMUM IEQV SIZE_7*_^1C_#* IEQVN2 - IEQV ENTRY SIZE_9*_^1C_#******************************************************_^1C_]_^1C_#******************************************************_^1C_#*_S*_^1C_#* SPECIFICATOIN TABLE AND ASS€€OCIATED PARAMETERS._"*_^1C_#*_S*_^1C_#******************************************************_^1C_#* ISTAB - SPECIFICATION TABLE_5*_^1C_#* ISTABS - MAXIMUM ISTAB SIZE_6*_^1C_#* ISTAB2 - CURRENT ISTAB SIZE_6*_^1C_#******************************************************_^1C_]_^1C_#******************************************************_^1C_#*_S*_^1C_#* INDICATOR WORDS AND FLAGS._7*€€_^1C_#*_S*_^1C_#******************************************************_^1C_#* IBUFS - MAXIMUM IBUF1, IBUF2 AND IWORK SIZE_$*_^1C_#* ISET_!- PRESET SYMTAB TABLE_5*_^1C_#* LBLANK - PRESET BLANK BLANK_^1C_#* KSFCNT - STATEMENT FUNCTION COUNT_0*_^1C_#* KSNCNT -_!*** NOT USED ***_4*_^1C_#* ISORSC - INPUT CHARACTERS/WORD COUNT_-*_^1C_#* IHOBIT - HIGH ORDER BIT IN WORD_2*_^1C_#*€€ ISTNO - CURRENT STATEMENT NUMBER_0*_^1C_#* ISSFLG - STATEMENT FUNCTION DUMMY PARAMETER COUNT *_^1C_#* ISUBPN - ISYMX FOR SUBPROGRAM NAME_/*_^1C_#* ITERM -_I*_^1C_#* JSORSC - OUTPUT CHARACTERS/WORD COUNT_,*_^1C_#* KEQVS - MAXIMUM KEQV AND MEQV SIZE_.*_^1C_#******************************************************_^1C_]_^1C_]_^1_$EQUIVALENCE(IND(1),NL)_^1_$DIMENSION IND(14)_^1€€_$EQUIVALENCE(ICFLG,IV(2)),(ITCOUN,IV(3)),(IDECR,IV(4))_^1_$EQUIVALENCE (NBCT,ISCOUN),(I6,IXSX)_^1C_#******************************************************_^1C_#*_S*_^1C_#*_S*_^1C_#*_S*_^1C_#******************************************************_^1C_#* AUTHOR_!-_;24/MAR/67_!*_^1C_#* NAME_#-_G*_^1C_#* PURPOSE -_G*_^1C_#* FUNCTION -_G*_^1C_#* INPUT_"-_G*_^1C_#* REF_$-_G*_^1C_#€€* OUTPUT_!-_G*_^1C_#* LINKAGE -_G*_^1C_#* ERRORS_!-_G*_^1C_#******************************************************_^1C_#SAVE ASCII NAME FOR EPT + TRA_^1_$DIMENSION NAMSV(3)_^1_$EQUIVALENCE (IGLAB(1),NAMSV(1))_^1C *** RETAIN SIZE OF SYMTAB PAGE_^1C_#ISYMPS=ISYMPS/2_^1C_]_^1C *** PHASE D WITH CIRCULAR NOBUFF_^1C *** SET ICOUNT HOLDER (PROGRAM COUNTER)_^1_$ITCOUN = ICOUNT_^1C *** €€SET UP CIRCULAR BUFFER POINTERS_^1C *** NOCT IS POINTER TO NEXT AVAILABLE SPACE (LAST ENTRY +1)_^1_$NOCT=1_^1C *** INOB IS SIZE OF NOBUFF_^1_$INOB=1152_^1C *** IHEAD IS POINTER TO BEGINNING ENTRY IN BUFFER_^1_$IHEAD=1_^1C *** NOUTOT IS POINTER TO LAST ENTRY IN BUFFER_^1_$NOUTOT=0_^1_$CALL BEGINO_^1C *** READ PART OF SCRATCH PAGE INTO INBUFF_^1_!10 CALL READ (ISCRI,0,202,INBUFF(1))_€€^1C *** SET UP SCRATCH PAGE CLEARANCE START INDICATOR_^1_$I6 = 2_^1C *** DECREMENT BUFFER COUNT (SCRATCH SECTION)_^1_$NBCT = NBCT- 1_^1C *** IS THERE ROOM IN CIRCULAR OUTPUT BUFFER?_^1_!15 IF (NOCT .GE. IHEAD + 1144) GO TO 50_^1C *** YES, GET NO. OF WORDS IN INBUFF RECORD._^1_$NOWI = AND(INBUFF(I6),3)_^1C *** CHECK IF BUFFER INDEX TOO HIGH_^1_$IF (NOCT .LE. 30000) GO TO 24_^1_$IH€€EAD=INDEX(IHEAD)_^1_$NOCT=INDEX(NOCT)_^1_$NOUTOT=INDEX(NOUTOT)_^1C *** MOVE ONE INSTRUCTION RECORD TO CIRCULAR BUFFER_^1_!24 J = I6+NOWI+1_^1_$DO 25 I = I6,J_^1_$INC=INDEX(NOCT)_^1_$NOBUFF(INC)=INBUFF(I)_^1_!25 NOCT = NOCT+1_^1_$I6 = J+1_^1C *** MORE RECORDS IN THIS BUFFER?_^1_$IF(I6 .LT. INBUFF(1)) GO TO 15_^1C *** NO, ANY MORE BUFFERS?_^1_$IF(NBCT .GT. 0) GO TO 10_^1_$NBCT = -1_^€€1_!50 NOUTOT=NOCT-1_^1C *** GO PROCESS THE OUTPUT BUFFER_^1_$CALL AMOUT_^1C *** IS THIS AN END RECORD?_^1_$IF (IHEAD .EQ. 0) GO TO 70_^1C *** NO, MOVE THE HEAD OF THE CIRCULAR BUFFER FILL AS NEEDED._^1C *** INCT POINTS TO LOCATION OF TOP_^1_$IHEAD=INCT_^1C *** ANY MORE INPUT?_^1_$IF(NBCT .LT. 0) GO TO 50_^1C *** YES_]_^1_$GO TO 15_^1_!70 CALL FINISH_^1C *** XFR CARD_^1_$NPCBF(1)=€$C050_^1_$DO 603 I=1,3_^1_$NPCBF(I+1)=NAMSV(I)_^1_$IF (ISUBP .NE. 0) NPCBF(I+1)=8224_^1 603 CONTINUE_^1_$NBINC=4_^1_$CALL NPUNCH_^1_$END_]_^__ PWRBDX1 CSY/ 15D P€1_$SUBROUTINE RBDX_^1_#*_2/DECK-ID 15D FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^13_]_^1C THIS RBDX IS USED IN PHASE D_^1C NON-IDENTICAL RBDX USED IN PHASE E_^1C_]_^1C_#MASTER LABELED COMMON BLOCK._^1*_] FTN 3.3_^1_$COMMON /A/ IFLAGS,LINECT,LINCT€€1_^1_$COMMON /A/ IR,IK,IP,IA,IL,IM,IXLGO,IOPTO,IOPTV,IOPTC,IOPTD_^1_$COMMON /A/ MCSTRT,MACRNB,MACSEC_^1_$COMMON /A/ IERRS(16),ISRFAD_^1_$COMMON /A/ LGO,ISCRI,ISCRO,IX_^1*_] FTN 3.3_^1_$COMMON /A/ IGLAB(3),IGLAB1,IGLAB2_^1_$COMMON /A/ ICOMT(12),ICOMTS,ICOMX2,ICOMTL,ISUBP,NDPRS,_^1_#$LABX,IBCDTB(48)_^1_$EQUIVALENCE(ICOMB,ICOMT(1)),(ICOMBX,ICOMT(2)),(ICOMDF,_^1_#$ICOMT(3)),(ICOMBN,IC€€OMT(4))_^1_$DIMENSION ICOMB(6),ICOMBX(6),ICOMDF(6),ICOMBN(7)_^1_$COMMON /A/ LOOPTS,LOOPTX,LOOPTB,LOOPT(50)_^1_$EQUIVALENCE(LINDUC,LOOPT(1))_^1_$DIMENSION LINDUC(10)_^1_$EQUIVALENCE (LBEG,LOOPT(2))_^1_$DIMENSION LBEG(10)_^1_$EQUIVALENCE (LINC,LOOPT(3))_^1_$DIMENSION LINC(10)_^1_$EQUIVALENCE (LEND,LOOPT(4))_^1_$DIMENSION LEND(10)_^1_$BYTE(LLABL,LOOPT(5)(14=0)_))_^1_$DIMENSION LLABL(€€10)_^1_$BYTE(LID,LOOPT(5)(15=15) )_^1_$DIMENSION LID(10)_^1_$COMMON/A/IEQV(255), IEQVS,IEQVN2_^1_$COMMON /A/ ISTAB(150),ISTABS,ISTAB2_^1_$COMMON /A/ IBUFS,ISET(25),LBLANK,KSFCNT,KSNCNT,ISORSC,_^1_#$IHOBIT,ISTNO,ISSFLG,ISUBPN,ITERM,JSORSC,KEQVS_^1C_#SYMBOL TABLE LABELED COMMON BLOCK_^1_$COMMON /A/ ISYMN, ISYMFL,ISYMD,ISYMX,ISYMS,ISYMP,ISYMPC,ISYMPS,_^1_#$ ISYMNS, SYMTAB(2400)_^1_$I€€NTEGER SYMTAB_^1_$BYTE (IDUM,SYMTAB(1)(15=15)),(KDUMY,SYMTAB(1)(15=15)),_^1_#$(ICLASS,SYMTAB(1)(14=11)),(ITYPE,SYMTAB(1)(10=9))_^1_$DIMENSION IDUM(100),KDUMY(100),ICLASS(100),ITYPE(100)_^1_$BYTE (ISNGL, SYMTAB(1)(8=8)),(KELSIZ,SYMTAB(1)(8=8)),_^1_#$ (ICOM,SYMTAB(1)(7=5)),(IPART,SYMTAB(1)(4=3))_^1_$DIMENSION ISNGL(100),KELSIZ(100),ICOM(100),IPART(100)_^1_$BYTE (KRFCNT,SYMTAB(1)(2=2)€€),(IDIM,SYMTAB(1)(1=0)),_^1_#$ (IREL,SYMTAB(1)(1=1)),(IEXT,SYMTAB(1)(0=0))_^1_$DIMENSION KRFCNT(100),IDIM(100),IREL(100),IEXT(100)_^1_$EQUIVALENCE (IRSA,SYMTAB(2)),(ICOMTX,SYMTAB(2)),(ISNOL,SYMTAB(2))_^1_$DIMENSION IRSA(100), ICOMTX(100),ISNOL(100)_^1_$BYTE (IDATAS,SYMTAB(3)(15=15)),(IREF,SYMTAB(3)(15=15)),_^1_#$ (IEQVX,SYMTAB(3)(14=8)),(ITILF,SYMTAB(3)(14=8))_^1_$DIMENSION IDATAS(€€100),IREF(100),IEQVX(100),ITILF(100)_^1_$BYTE (IPARTR,SYMTAB(3)(7=4)),(INDUCV,SYMTAB(3)(7=7)),(ISFARG,_^1_#$ SYMTAB(3)(6=6)),(IARGNO,SYMTAB(3)(5=0)),(IPARTL,SYMTAB(3)(3=0))_^1_$DIMENSION IPARTR(100),INDUCV(100),ISFARG(100),IARGNO(100),_^1_#$ IPARTL(100)_^1_$EQUIVALENCE (ISYM,SYMTAB(4))_^1_$DIMENSION ISYM(100)_^1C_]_^1C_#PHASE C, D, E LABELED COMMON BLOCK_^1_$EQUIVALENCE (NBLK(1),LO€€OPTS)_^1_$DIMENSION NBLK(446)_^1_$EQUIVALENCE (NPCBF(1),NBLK(1)),(IDVTAB(1),NBLK(58))_^1_$EQUIVALENCE (NSUMDS,NBLK(370))_^1C_#PUNCH BUFFER, ADDRESS HOLDERS, PRINT BUFFER, INDEX HISTORY TABLES_^1_$EQUIVALENCE(NPTBF,NBLK(371)),(IXS1,NBLK(426)),(IXS2,NBLK(436))_^1C_$INDEX REGISTER HOLDERS FOR SUBROUTINE IXOPT_^1_$DIMENSION NPCBF(57),IDVTAB(312),NPTBF(55),IXS1(10),IXS2(10)_^1C_]_^1C_]_€€^1C_#PHASE D AND E BLANK COMMON BLOCK BELOW COMPRESSED TABLE_^1_$COMMON // INBUFF(203),NOBUFF(1152),NRCD(5)_^1_$COMMON//NFTAB(160),NDSTAB(500)_^1_$COMMON//IV(5),IXS3(10)_^1_$COMMON//NSUMD,NDFL,NADX,NSUMVS,IXC,IXFLAG,IXF,IXQ_^1_$COMMON//IXSX,IUSE,IFIX,NOUTOT,NOWO,NL,NT,NA,NS,ND,NR,NQ,NF_^1_$COMMON//NTYPE,NOWI,NOPC,NOPT,NADD,NXPT_^1_$COMMON//NATYPE,ICT,INCT,NOCT,NSTYPE,LRS,NOBW,NBINC€€,NPC1_^1_$COMMON//NSETX,NRM,NPTBFX,NRC1,NRC2,NW2FL,NW2,NBFL,NXCON_^1_$COMMON//NASCI,ISCOUN,ICOUNT,NOFS,NODS,NDXJ,NX_^1C *** ADDITIONAL COMMON IS FOR CIRCULAR BUFFER POINTERS_^1_$COMMON // IHEAD,INOB,INC_^1C_]_^1_$EQUIVALENCE(IND(1),NL)_^1_$DIMENSION IND(14)_^1_$EQUIVALENCE(ICFLG,IV(2)),(ITCOUN,IV(3)),(IDECR,IV(4))_^1_$K=NOBW/4_^1_$J=K*4-NOBW_^1_$IF(J.EQ.0)J=3_^1_$J = AND (J,3)_^1_$€ÆK = K*5_^1_$NBINC = (K+5)/5 + NOBW + 2_^1_$L=NRC1_^1_$IF(NBFL .NE. 0) L = 8_^1_!25 IF (J .EQ. 0) GO TO 30_^1_$L = L * 16_^1_$J = J - 1_^1_$GO TO 25_^1_!30 NPCBF(K+2) = NPCBF(K+2) + L_^1_$END_]_^__ÆPWRBPK1 CSY/ 16D P€1_$SUBROUTINE RBPK_^1_#*_2/DECK-ID 16D FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^13_]_^1C THIS RBPK IS USED IN PHASE D_^1C NON-IDENTICAL RBPK USED IN PHASE E_^1C_]_^1C_#MASTER LABELED COMMON BLOCK._^1*_] FTN 3.3_^1_$COMMON /A/ IFLAGS,LINECT,LINCT€€1_^1_$COMMON /A/ IR,IK,IP,IA,IL,IM,IXLGO,IOPTO,IOPTV,IOPTC,IOPTD_^1_$COMMON /A/ MCSTRT,MACRNB,MACSEC_^1_$COMMON /A/ IERRS(16),ISRFAD_^1_$COMMON /A/ LGO,ISCRI,ISCRO,IX_^1*_] FTN 3.3_^1_$COMMON /A/ IGLAB(3),IGLAB1,IGLAB2_^1_$COMMON /A/ ICOMT(12),ICOMTS,ICOMX2,ICOMTL,ISUBP,NDPRS,_^1_#$LABX,IBCDTB(48)_^1_$EQUIVALENCE(ICOMB,ICOMT(1)),(ICOMBX,ICOMT(2)),(ICOMDF,_^1_#$ICOMT(3)),(ICOMBN,IC€€OMT(4))_^1_$DIMENSION ICOMB(6),ICOMBX(6),ICOMDF(6),ICOMBN(7)_^1_$COMMON /A/ LOOPTS,LOOPTX,LOOPTB,LOOPT(50)_^1_$EQUIVALENCE(LINDUC,LOOPT(1))_^1_$DIMENSION LINDUC(10)_^1_$EQUIVALENCE (LBEG,LOOPT(2))_^1_$DIMENSION LBEG(10)_^1_$EQUIVALENCE (LINC,LOOPT(3))_^1_$DIMENSION LINC(10)_^1_$EQUIVALENCE (LEND,LOOPT(4))_^1_$DIMENSION LEND(10)_^1_$BYTE(LLABL,LOOPT(5)(14=0)_))_^1_$DIMENSION LLABL(€€10)_^1_$BYTE(LID,LOOPT(5)(15=15) )_^1_$DIMENSION LID(10)_^1_$COMMON/A/IEQV(255), IEQVS,IEQVN2_^1_$COMMON /A/ ISTAB(150),ISTABS,ISTAB2_^1_$COMMON /A/ IBUFS,ISET(25),LBLANK,KSFCNT,KSNCNT,ISORSC,_^1_#$IHOBIT,ISTNO,ISSFLG,ISUBPN,ITERM,JSORSC,KEQVS_^1C_#SYMBOL TABLE LABELED COMMON BLOCK_^1_$COMMON /A/ ISYMN, ISYMFL,ISYMD,ISYMX,ISYMS,ISYMP,ISYMPC,ISYMPS,_^1_#$ ISYMNS, SYMTAB(2400)_^1_$I€€NTEGER SYMTAB_^1_$BYTE (IDUM,SYMTAB(1)(15=15)),(KDUMY,SYMTAB(1)(15=15)),_^1_#$(ICLASS,SYMTAB(1)(14=11)),(ITYPE,SYMTAB(1)(10=9))_^1_$DIMENSION IDUM(100),KDUMY(100),ICLASS(100),ITYPE(100)_^1_$BYTE (ISNGL, SYMTAB(1)(8=8)),(KELSIZ,SYMTAB(1)(8=8)),_^1_#$ (ICOM,SYMTAB(1)(7=5)),(IPART,SYMTAB(1)(4=3))_^1_$DIMENSION ISNGL(100),KELSIZ(100),ICOM(100),IPART(100)_^1_$BYTE (KRFCNT,SYMTAB(1)(2=2)€€),(IDIM,SYMTAB(1)(1=0)),_^1_#$ (IREL,SYMTAB(1)(1=1)),(IEXT,SYMTAB(1)(0=0))_^1_$DIMENSION KRFCNT(100),IDIM(100),IREL(100),IEXT(100)_^1_$EQUIVALENCE (IRSA,SYMTAB(2)),(ICOMTX,SYMTAB(2)),(ISNOL,SYMTAB(2))_^1_$DIMENSION IRSA(100), ICOMTX(100),ISNOL(100)_^1_$BYTE (IDATAS,SYMTAB(3)(15=15)),(IREF,SYMTAB(3)(15=15)),_^1_#$ (IEQVX,SYMTAB(3)(14=8)),(ITILF,SYMTAB(3)(14=8))_^1_$DIMENSION IDATAS(€€100),IREF(100),IEQVX(100),ITILF(100)_^1_$BYTE (IPARTR,SYMTAB(3)(7=4)),(INDUCV,SYMTAB(3)(7=7)),(ISFARG,_^1_#$ SYMTAB(3)(6=6)),(IARGNO,SYMTAB(3)(5=0)),(IPARTL,SYMTAB(3)(3=0))_^1_$DIMENSION IPARTR(100),INDUCV(100),ISFARG(100),IARGNO(100),_^1_#$ IPARTL(100)_^1_$EQUIVALENCE (ISYM,SYMTAB(4))_^1_$DIMENSION ISYM(100)_^1C_]_^1C_#PHASE C, D, E LABELED COMMON BLOCK_^1_$EQUIVALENCE (NBLK(1),LO€€OPTS)_^1_$DIMENSION NBLK(446)_^1_$EQUIVALENCE (NPCBF(1),NBLK(1)),(IDVTAB(1),NBLK(58))_^1_$EQUIVALENCE (NSUMDS,NBLK(370))_^1C_#PUNCH BUFFER, ADDRESS HOLDERS, PRINT BUFFER, INDEX HISTORY TABLES_^1_$EQUIVALENCE(NPTBF,NBLK(371)),(IXS1,NBLK(426)),(IXS2,NBLK(436))_^1C_$INDEX REGISTER HOLDERS FOR SUBROUTINE IXOPT_^1_$DIMENSION NPCBF(57),IDVTAB(312),NPTBF(55),IXS1(10),IXS2(10)_^1C_]_^1C_]_€€^1C_#PHASE D AND E BLANK COMMON BLOCK BELOW COMPRESSED TABLE_^1_$COMMON // INBUFF(203),NOBUFF(1152),NRCD(5)_^1_$COMMON//NFTAB(160),NDSTAB(500)_^1_$COMMON//IV(5),IXS3(10)_^1_$COMMON//NSUMD,NDFL,NADX,NSUMVS,IXC,IXFLAG,IXF,IXQ_^1_$COMMON//IXSX,IUSE,IFIX,NOUTOT,NOWO,NL,NT,NA,NS,ND,NR,NQ,NF_^1_$COMMON//NTYPE,NOWI,NOPC,NOPT,NADD,NXPT_^1_$COMMON//NATYPE,ICT,INCT,NOCT,NSTYPE,LRS,NOBW,NBINC€€,NPC1_^1_$COMMON//NSETX,NRM,NPTBFX,NRC1,NRC2,NW2FL,NW2,NBFL,NXCON_^1_$COMMON//NASCI,ISCOUN,ICOUNT,NOFS,NODS,NDXJ,NX_^1C *** ADDITIONAL COMMON IS FOR CIRCULAR BUFFER POINTERS_^1_$COMMON // IHEAD,INOB,INC_^1C_]_^1_$EQUIVALENCE(IND(1),NL)_^1_$DIMENSION IND(14)_^1_$EQUIVALENCE(ICFLG,IV(2)),(ITCOUN,IV(3)),(IDECR,IV(4))_^1C_2IS OUTPUT BUFFER EMPTY_^1_$IF(NOBW .NE. 0) GO TO 10_^1_$NOBW = €1_^1_$NPCBF(1) = 16464_^1C_2SET CARD TYPE,RELOCATION AND LOCATION_^1_$NPCBF(2) = NRM* 4096_^1_$NPCBF(3) = ICOUNT_^1_!10 NBFL = 0_^1_$CALL RBDX_^1_$NPCBF(NBINC) = NOPC_^1_$NOBW = NOBW + 1_^1C_2IS THE BUFFER FULL_^1_$IF(NOBW .EQ. 44) CALL UNPUNC_^1_$END_]_^__ PWSYMS3 CSY/ 17D P€1_$SUBROUTINE SYMSCN_^1_#*_2/DECK-ID 17D FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^13_]_^1C THIS SYMSCN IS USED IN PHASES D,E_^1C NON-IDENTICAL SYMSCN IS USED IN PHASES A,B,C_^1C_]_^1C_#MASTER LABELED COMMON BLOCK._^1*_] FTN 3.3_^1_$COMMON /A/ IFLA€€GS,LINECT,LINCT1_^1_$COMMON /A/ IR,IK,IP,IA,IL,IM,IXLGO,IOPTO,IOPTV,IOPTC,IOPTD_^1_$COMMON /A/ MCSTRT,MACRNB,MACSEC_^1_$COMMON /A/ IERRS(16),ISRFAD_^1_$COMMON /A/ LGO,ISCRI,ISCRO,IX_^1*_] FTN 3.3_^1_$COMMON /A/ IGLAB(3),IGLAB1,IGLAB2_^1_$COMMON /A/ ICOMT(12),ICOMTS,ICOMX2,ICOMTL,ISUBP,NDPRS,_^1_#$LABX,IBCDTB(48)_^1_$EQUIVALENCE(ICOMB,ICOMT(1)),(ICOMBX,ICOMT(2)),(ICOMDF,_^1_#$ICOMT€€(3)),(ICOMBN,ICOMT(4))_^1_$DIMENSION ICOMB(6),ICOMBX(6),ICOMDF(6),ICOMBN(7)_^1_$COMMON /A/ LOOPTS,LOOPTX,LOOPTB,LOOPT(50)_^1_$EQUIVALENCE(LINDUC,LOOPT(1))_^1_$DIMENSION LINDUC(10)_^1_$EQUIVALENCE (LBEG,LOOPT(2))_^1_$DIMENSION LBEG(10)_^1_$EQUIVALENCE (LINC,LOOPT(3))_^1_$DIMENSION LINC(10)_^1_$EQUIVALENCE (LEND,LOOPT(4))_^1_$DIMENSION LEND(10)_^1_$BYTE(LLABL,LOOPT(5)(14=0)_))_^1_$DI€€MENSION LLABL(10)_^1_$BYTE(LID,LOOPT(5)(15=15) )_^1_$DIMENSION LID(10)_^1_$COMMON/A/IEQV(255), IEQVS,IEQVN2_^1_$COMMON /A/ ISTAB(150),ISTABS,ISTAB2_^1_$COMMON /A/ IBUFS,ISET(25),LBLANK,KSFCNT,KSNCNT,ISORSC,_^1_#$IHOBIT,ISTNO,ISSFLG,ISUBPN,ITERM,JSORSC,KEQVS_^1C_#SYMBOL TABLE LABELED COMMON BLOCK_^1_$COMMON /A/ ISYMN, ISYMFL,ISYMD,ISYMX,ISYMS,ISYMP,ISYMPC,ISYMPS,_^1_#$ ISYMNS, SYM€€TAB(2400)_^1_$INTEGER SYMTAB_^1_$BYTE (IDUM,SYMTAB(1)(15=15)),(KDUMY,SYMTAB(1)(15=15)),_^1_#$(ICLASS,SYMTAB(1)(14=11)),(ITYPE,SYMTAB(1)(10=9))_^1_$DIMENSION IDUM(100),KDUMY(100),ICLASS(100),ITYPE(100)_^1_$BYTE (ISNGL, SYMTAB(1)(8=8)),(KELSIZ,SYMTAB(1)(8=8)),_^1_#$ (ICOM,SYMTAB(1)(7=5)),(IPART,SYMTAB(1)(4=3))_^1_$DIMENSION ISNGL(100),KELSIZ(100),ICOM(100),IPART(100)_^1_$BYTE (KRFCNT€€,SYMTAB(1)(2=2)),(IDIM,SYMTAB(1)(1=0)),_^1_#$ (IREL,SYMTAB(1)(1=1)),(IEXT,SYMTAB(1)(0=0))_^1_$DIMENSION KRFCNT(100),IDIM(100),IREL(100),IEXT(100)_^1_$EQUIVALENCE (IRSA,SYMTAB(2)),(ICOMTX,SYMTAB(2)),(ISNOL,SYMTAB(2))_^1_$DIMENSION IRSA(100), ICOMTX(100),ISNOL(100)_^1_$BYTE (IDATAS,SYMTAB(3)(15=15)),(IREF,SYMTAB(3)(15=15)),_^1_#$ (IEQVX,SYMTAB(3)(14=8)),(ITILF,SYMTAB(3)(14=8))_^1_$DI€€MENSION IDATAS(100),IREF(100),IEQVX(100),ITILF(100)_^1_$BYTE (IPARTR,SYMTAB(3)(7=4)),(INDUCV,SYMTAB(3)(7=7)),(ISFARG,_^1_#$ SYMTAB(3)(6=6)),(IARGNO,SYMTAB(3)(5=0)),(IPARTL,SYMTAB(3)(3=0))_^1_$DIMENSION IPARTR(100),INDUCV(100),ISFARG(100),IARGNO(100),_^1_#$ IPARTL(100)_^1_$EQUIVALENCE (ISYM,SYMTAB(4))_^1_$DIMENSION ISYM(100)_^1_$IF (ISYMX.NE.0) GOTO 10_^1_$ISYMX=1_^1_$GOTO 20_^1_!10€r ISYMX=ISYMP+ISYMX+ISYMFL_^1_$IF (ISYMX.LT.ISYMN) GOTO 20_^1_$ISYMP=1_^1_$RETURN_^1_!20 CALL GETSYM_^1_$END_]_^__ rPWDEC1 CSY/ 18D P€1_$SUBROUTINE TABDEC_^1_#*_2/DECK-ID 18D FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^13_]_^1C THIS TABDEC IS USED IN PHASE D_^1C NON-IDENTICAL TABDEC USED IN PHASE E_^1C_]_^1C_#MASTER LABELED COMMON BLOCK._^1*_] FTN 3.3_^1_$COMMON /A/ IFLAGS,LINECT,L€€INCT1_^1_$COMMON /A/ IR,IK,IP,IA,IL,IM,IXLGO,IOPTO,IOPTV,IOPTC,IOPTD_^1_$COMMON /A/ MCSTRT,MACRNB,MACSEC_^1_$COMMON /A/ IERRS(16),ISRFAD_^1_$COMMON /A/ LGO,ISCRI,ISCRO,IX_^1*_] FTN 3.3_^1_$COMMON /A/ IGLAB(3),IGLAB1,IGLAB2_^1_$COMMON /A/ ICOMT(12),ICOMTS,ICOMX2,ICOMTL,ISUBP,NDPRS,_^1_#$LABX,IBCDTB(48)_^1_$EQUIVALENCE(ICOMB,ICOMT(1)),(ICOMBX,ICOMT(2)),(ICOMDF,_^1_#$ICOMT(3)),(ICOMB€€N,ICOMT(4))_^1_$DIMENSION ICOMB(6),ICOMBX(6),ICOMDF(6),ICOMBN(7)_^1_$COMMON /A/ LOOPTS,LOOPTX,LOOPTB,LOOPT(50)_^1_$EQUIVALENCE(LINDUC,LOOPT(1))_^1_$DIMENSION LINDUC(10)_^1_$EQUIVALENCE (LBEG,LOOPT(2))_^1_$DIMENSION LBEG(10)_^1_$EQUIVALENCE (LINC,LOOPT(3))_^1_$DIMENSION LINC(10)_^1_$EQUIVALENCE (LEND,LOOPT(4))_^1_$DIMENSION LEND(10)_^1_$BYTE(LLABL,LOOPT(5)(14=0)_))_^1_$DIMENSION LL€€ABL(10)_^1_$BYTE(LID,LOOPT(5)(15=15) )_^1_$DIMENSION LID(10)_^1_$COMMON/A/IEQV(255), IEQVS,IEQVN2_^1_$COMMON /A/ ISTAB(150),ISTABS,ISTAB2_^1_$COMMON /A/ IBUFS,ISET(25),LBLANK,KSFCNT,KSNCNT,ISORSC,_^1_#$IHOBIT,ISTNO,ISSFLG,ISUBPN,ITERM,JSORSC,KEQVS_^1C_]_^1C_#SYMBOL TABLE LABELED COMMON BLOCK_^1_$COMMON /A/ ISYMN, ISYMFL,ISYMD,ISYMX,ISYMS,ISYMP,ISYMPC,ISYMPS,_^1_#$ ISYMNS, SYMTAB(2€€400)_^1_$INTEGER SYMTAB_^1_$BYTE (IDUM,SYMTAB(1)(15=15)),(KDUMY,SYMTAB(1)(15=15)),_^1_#$(ICLASS,SYMTAB(1)(14=11)),(ITYPE,SYMTAB(1)(10=9))_^1_$DIMENSION IDUM(100),KDUMY(100),ICLASS(100),ITYPE(100)_^1_$BYTE (ISNGL, SYMTAB(1)(8=8)),(KELSIZ,SYMTAB(1)(8=8)),_^1_#$ (ICOM,SYMTAB(1)(7=5)),(IPART,SYMTAB(1)(4=3))_^1_$DIMENSION ISNGL(100),KELSIZ(100),ICOM(100),IPART(100)_^1_$BYTE (KRFCNT,SYMT€€AB(1)(2=2)),(IDIM,SYMTAB(1)(1=0)),_^1_#$ (IREL,SYMTAB(1)(1=1)),(IEXT,SYMTAB(1)(0=0))_^1_$DIMENSION KRFCNT(100),IDIM(100),IREL(100),IEXT(100)_^1_$EQUIVALENCE (IRSA,SYMTAB(2)),(ICOMTX,SYMTAB(2)),(ISNOL,SYMTAB(2))_^1_$DIMENSION IRSA(100), ICOMTX(100),ISNOL(100)_^1_$BYTE (IDATAS,SYMTAB(3)(15=15)),(IREF,SYMTAB(3)(15=15)),_^1_#$ (IEQVX,SYMTAB(3)(14=8)),(ITILF,SYMTAB(3)(14=8))_^1_$DIMENSI€€ON IDATAS(100),IREF(100),IEQVX(100),ITILF(100)_^1_$BYTE (IPARTR,SYMTAB(3)(7=4)),(INDUCV,SYMTAB(3)(7=7)),(ISFARG,_^1_#$ SYMTAB(3)(6=6)),(IARGNO,SYMTAB(3)(5=0)),(IPARTL,SYMTAB(3)(3=0))_^1_$DIMENSION IPARTR(100),INDUCV(100),ISFARG(100),IARGNO(100),_^1_#$ IPARTL(100)_^1_$EQUIVALENCE (ISYM,SYMTAB(4))_^1_$DIMENSION ISYM(100)_^1C_]_^1C_#PHASE C, D, E LABELED COMMON BLOCK_^1_$EQUIVALENCE (€€NBLK(1),LOOPTS)_^1_$DIMENSION NBLK(446)_^1_$EQUIVALENCE (NPCBF(1),NBLK(1)),(IDVTAB(1),NBLK(58))_^1_$EQUIVALENCE (NSUMDS,NBLK(370))_^1C_#PUNCH BUFFER, ADDRESS HOLDERS, PRINT BUFFER, INDEX HISTORY TABLES_^1_$EQUIVALENCE(NPTBF,NBLK(371)),(IXS1,NBLK(426)),(IXS2,NBLK(436))_^1C_$INDEX REGISTER HOLDERS FOR SUBROUTINE IXOPT_^1_$DIMENSION NPCBF(57),IDVTAB(312),NPTBF(55),IXS1(10),IXS2(10)_^1€€C_]_^1C_]_^1C_#PHASE D AND E BLANK COMMON BLOCK BELOW COMPRESSED TABLE_^1_$COMMON // INBUFF(203),NOBUFF(1152),NRCD(5)_^1_$COMMON//NFTAB(160),NDSTAB(500)_^1_$COMMON//IV(5),IXS3(10)_^1_$COMMON//NSUMD,NDFL,NADX,NSUMVS,IXC,IXFLAG,IXF,IXQ_^1_$COMMON//IXSX,IUSE,IFIX,NOUTOT,NOWO,NL,NT,NA,NS,ND,NR,NQ,NF_^1_$COMMON//NTYPE,NOWI,NOPC,NOPT,NADD,NXPT_^1_$COMMON//NATYPE,ICT,INCT,NOCT,NSTYPE,LRS,€€NOBW,NBINC,NPC1_^1_$COMMON//NSETX,NRM,NPTBFX,NRC1,NRC2,NW2FL,NW2,NBFL,NXCON_^1_$COMMON//NASCI,ISCOUN,ICOUNT,NOFS,NODS,NDXJ,NX_^1C *** ADDITIONAL COMMON IS FOR CIRCULAR BUFFER POINTERS_^1_$COMMON // IHEAD,INOB,INC_^1C_]_^1_$EQUIVALENCE(IND(1),NL)_^1_$DIMENSION IND(14)_^1_$EQUIVALENCE(ICFLG,IV(2)),(ITCOUN,IV(3)),(IDECR,IV(4))_^1 6276 ISYMX=0_^1_$ISYMP=0_^1 6270 CALL SYMSCN_^1_$IF(ISY€€MP.EQ.1) GO TO 6271_^1_$IF (ICOM(ISYMX).NE.0.AND.ICLASS(ISYMX).EQ.1) GOTO 6270_^1_$IVBL=IRSA(ISYMX)_^1_$IF (IVBL.GT.ICOUNT.AND.IVBL.LT.32765) IRSA(ISYMX)=IVBL-IDECR_^1_$GOTO 6270_^1 6271 DO 6272 I=1,NADX,2_^1_'IVBL=IDVTAB(I)_^1_'IF (IVBL.LT.ITCOUN.AND.IVBL.GT.ICOUNT) IDVTAB(I)=IVBL-IDECR_^1_'IVBL=IDVTAB(I+1)_^1_'IF (IVBL.LT.0) GO TO 6273_^1_'IF (IVBL.GT.ICOUNT) IDVTAB(I+1)=IVBL-IDE€ìCR_^1_'GOTO 6272_^1 6273_!IF (IVBL.LT.(-ICOUNT)) IDVTAB(I+1)=IVBL+IDECR_^1 6272_!CONTINUE_^1_$DO 6274 I=1,NODS,2_^1_'IVBL=NDSTAB(I+1)_^1_'IF (IVBL.GT.ICOUNT) NDSTAB(I+1)=IVBL-IDECR_^1 6274_!CONTINUE_^1_$ITCOUN=ITCOUN-IDECR_^1_$END_]_^__ìPWUNPC1 CSY/ 19D P€1_$SUBROUTINE UNPUNC_^1_#*_2/DECK-ID 19D FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^13_]_^1C THIS UNPUNC IS USED IN PHASE D_^1C NON-IDENTICAL UNPUNC USED IN PHASE E_^1C_]_^1C_#MASTER LABELED COMMON BLOCK._^1*_] FTN 3.3_^1_$COMMON /A/ IFLAGS,LINECT,L€€INCT1_^1_$COMMON /A/ IR,IK,IP,IA,IL,IM,IXLGO,IOPTO,IOPTV,IOPTC,IOPTD_^1_$COMMON /A/ MCSTRT,MACRNB,MACSEC_^1_$COMMON /A/ IERRS(16),ISRFAD_^1_$COMMON /A/ LGO,ISCRI,ISCRO,IX_^1*_] FTN 3.3_^1_$COMMON /A/ IGLAB(3),IGLAB1,IGLAB2_^1_$COMMON /A/ ICOMT(12),ICOMTS,ICOMX2,ICOMTL,ISUBP,NDPRS,_^1_#$LABX,IBCDTB(48)_^1_$EQUIVALENCE(ICOMB,ICOMT(1)),(ICOMBX,ICOMT(2)),(ICOMDF,_^1_#$ICOMT(3)),(ICOMB€€N,ICOMT(4))_^1_$DIMENSION ICOMB(6),ICOMBX(6),ICOMDF(6),ICOMBN(7)_^1_$COMMON /A/ LOOPTS,LOOPTX,LOOPTB,LOOPT(50)_^1_$EQUIVALENCE(LINDUC,LOOPT(1))_^1_$DIMENSION LINDUC(10)_^1_$EQUIVALENCE (LBEG,LOOPT(2))_^1_$DIMENSION LBEG(10)_^1_$EQUIVALENCE (LINC,LOOPT(3))_^1_$DIMENSION LINC(10)_^1_$EQUIVALENCE (LEND,LOOPT(4))_^1_$DIMENSION LEND(10)_^1_$BYTE(LLABL,LOOPT(5)(14=0)_))_^1_$DIMENSION LL€€ABL(10)_^1_$BYTE(LID,LOOPT(5)(15=15) )_^1_$DIMENSION LID(10)_^1_$COMMON/A/IEQV(255), IEQVS,IEQVN2_^1_$COMMON /A/ ISTAB(150),ISTABS,ISTAB2_^1_$COMMON /A/ IBUFS,ISET(25),LBLANK,KSFCNT,KSNCNT,ISORSC,_^1_#$IHOBIT,ISTNO,ISSFLG,ISUBPN,ITERM,JSORSC,KEQVS_^1C_#SYMBOL TABLE LABELED COMMON BLOCK_^1_$COMMON /A/ ISYMN, ISYMFL,ISYMD,ISYMX,ISYMS,ISYMP,ISYMPC,ISYMPS,_^1_#$ ISYMNS, SYMTAB(2400)_^€€1_$INTEGER SYMTAB_^1_$BYTE (IDUM,SYMTAB(1)(15=15)),(KDUMY,SYMTAB(1)(15=15)),_^1_#$(ICLASS,SYMTAB(1)(14=11)),(ITYPE,SYMTAB(1)(10=9))_^1_$DIMENSION IDUM(100),KDUMY(100),ICLASS(100),ITYPE(100)_^1_$BYTE (ISNGL, SYMTAB(1)(8=8)),(KELSIZ,SYMTAB(1)(8=8)),_^1_#$ (ICOM,SYMTAB(1)(7=5)),(IPART,SYMTAB(1)(4=3))_^1_$DIMENSION ISNGL(100),KELSIZ(100),ICOM(100),IPART(100)_^1_$BYTE (KRFCNT,SYMTAB(1)(€€2=2)),(IDIM,SYMTAB(1)(1=0)),_^1_#$ (IREL,SYMTAB(1)(1=1)),(IEXT,SYMTAB(1)(0=0))_^1_$DIMENSION KRFCNT(100),IDIM(100),IREL(100),IEXT(100)_^1_$EQUIVALENCE (IRSA,SYMTAB(2)),(ICOMTX,SYMTAB(2)),(ISNOL,SYMTAB(2))_^1_$DIMENSION IRSA(100), ICOMTX(100),ISNOL(100)_^1_$BYTE (IDATAS,SYMTAB(3)(15=15)),(IREF,SYMTAB(3)(15=15)),_^1_#$ (IEQVX,SYMTAB(3)(14=8)),(ITILF,SYMTAB(3)(14=8))_^1_$DIMENSION IDA€€TAS(100),IREF(100),IEQVX(100),ITILF(100)_^1_$BYTE (IPARTR,SYMTAB(3)(7=4)),(INDUCV,SYMTAB(3)(7=7)),(ISFARG,_^1_#$ SYMTAB(3)(6=6)),(IARGNO,SYMTAB(3)(5=0)),(IPARTL,SYMTAB(3)(3=0))_^1_$DIMENSION IPARTR(100),INDUCV(100),ISFARG(100),IARGNO(100),_^1_#$ IPARTL(100)_^1_$EQUIVALENCE (ISYM,SYMTAB(4))_^1_$DIMENSION ISYM(100)_^1C_]_^1C_#PHASE C, D, E LABELED COMMON BLOCK_^1_$EQUIVALENCE (NBLK(1€€),LOOPTS)_^1_$DIMENSION NBLK(446)_^1_$EQUIVALENCE (NPCBF(1),NBLK(1)),(IDVTAB(1),NBLK(58))_^1_$EQUIVALENCE (NSUMDS,NBLK(370))_^1C_#PUNCH BUFFER, ADDRESS HOLDERS, PRINT BUFFER, INDEX HISTORY TABLES_^1_$EQUIVALENCE(NPTBF,NBLK(371)),(IXS1,NBLK(426)),(IXS2,NBLK(436))_^1C_$INDEX REGISTER HOLDERS FOR SUBROUTINE IXOPT_^1_$DIMENSION NPCBF(57),IDVTAB(312),NPTBF(55),IXS1(10),IXS2(10)_^1C_]_^1€€C_]_^1C_#PHASE D AND E BLANK COMMON BLOCK BELOW COMPRESSED TABLE_^1_$COMMON // INBUFF(203),NOBUFF(1152),NRCD(5)_^1_$COMMON//NFTAB(160),NDSTAB(500)_^1_$COMMON//IV(5),IXS3(10)_^1_$COMMON//NSUMD,NDFL,NADX,NSUMVS,IXC,IXFLAG,IXF,IXQ_^1_$COMMON//IXSX,IUSE,IFIX,NOUTOT,NOWO,NL,NT,NA,NS,ND,NR,NQ,NF_^1_$COMMON//NTYPE,NOWI,NOPC,NOPT,NADD,NXPT_^1_$COMMON//NATYPE,ICT,INCT,NOCT,NSTYPE,LRS,NOBW,N€€BINC,NPC1_^1_$COMMON//NSETX,NRM,NPTBFX,NRC1,NRC2,NW2FL,NW2,NBFL,NXCON_^1_$COMMON//NASCI,ISCOUN,ICOUNT,NOFS,NODS,NDXJ,NX_^1C *** ADDITIONAL COMMON IS FOR CIRCULAR BUFFER POINTERS_^1_$COMMON // IHEAD,INOB,INC_^1C_]_^1_$EQUIVALENCE(IND(1),NL)_^1_$DIMENSION IND(14)_^1_$EQUIVALENCE(ICFLG,IV(2)),(ITCOUN,IV(3)),(IDECR,IV(4))_^1_$IF(NOBW .EQ. 0) RETURN_^1_$NOBW = NOBW - 1_^1_$NBFL = 1_^1_$€4CALL RBDX_^1_$CALL NPUNCH_^1_$NOBW = 0_^1_$END_]_^__4PWAMOT2 CSY/ 01E P€1_$SUBROUTINE AMOUT_^1_#*_2/DECK-ID 01E FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^13_]_^1C THIS AMOUT IS USED IN PHASE E_^1C NON-IDENTICAL AMOUT USED IN PHASE D_^1C *** THIS ROUTINE IS FORTE AND THE UNCOMPRESSED SYMBOL TABLE_^1C_]_^1C_#MASTER LABELE€€D COMMON BLOCK._^1*_] FTN 3.3_^1_$COMMON /A/ IFLAGS,LINECT,LINCT1_^1_$COMMON /A/ IR,IK,IP,IA,IL,IM,IXLGO,IOPTO,IOPTV,IOPTC,IOPTD_^1_$COMMON /A/ MCSTRT,MACRNB,MACSEC_^1_$COMMON /A/ IERRS(16),ISRFAD_^1_$COMMON /A/ LGO,ISCRI,ISCRO,IX_^1*_] FTN 3.3_^1_$COMMON /A/ IGLAB(3),IGLAB1,IGLAB2_^1_$COMMON /A/ ICOMT(12),ICOMTS,ICOMX2,ICOMTL,ISUBP,NDPRS,_^1_#$LABX,IBCDTB(48)_^1_$EQUIVALENCE(ICO€€MB,ICOMT(1)),(ICOMBX,ICOMT(2)),(ICOMDF,_^1_#$ICOMT(3)),(ICOMBN,ICOMT(4))_^1_$DIMENSION ICOMB(6),ICOMBX(6),ICOMDF(6),ICOMBN(7)_^1_$COMMON /A/ LOOPTS,LOOPTX,LOOPTB,LOOPT(50)_^1_$EQUIVALENCE(LINDUC,LOOPT(1))_^1_$DIMENSION LINDUC(10)_^1_$EQUIVALENCE (LBEG,LOOPT(2))_^1_$DIMENSION LBEG(10)_^1_$EQUIVALENCE (LINC,LOOPT(3))_^1_$DIMENSION LINC(10)_^1_$EQUIVALENCE (LEND,LOOPT(4))_^1_$DIMENSIO€€N LEND(10)_^1_$BYTE(LLABL,LOOPT(5)(14=0)_))_^1_$DIMENSION LLABL(10)_^1_$BYTE(LID,LOOPT(5)(15=15) )_^1_$DIMENSION LID(10)_^1_$COMMON/A/IEQV(255), IEQVS,IEQVN2_^1_$COMMON /A/ ISTAB(150),ISTABS,ISTAB2_^1_$COMMON /A/ IBUFS,ISET(25),LBLANK,KSFCNT,KSNCNT,ISORSC,_^1_#$IHOBIT,ISTNO,ISSFLG,ISUBPN,ITERM,JSORSC,KEQVS_^1C_#SYMBOL TABLE LABELED COMMON BLOCK_^1_$COMMON /A/ ISYMN, ISYMFL,ISYMD,€€ISYMX,ISYMS,ISYMP,ISYMPC,ISYMPS,_^1_#$ ISYMNS, SYMTAB(2400)_^1_$INTEGER SYMTAB_^1_$BYTE (IDUM,SYMTAB(1)(15=15)),(KDUMY,SYMTAB(1)(15=15)),_^1_#$(ICLASS,SYMTAB(1)(14=11)),(ITYPE,SYMTAB(1)(10=9))_^1_$DIMENSION IDUM(100),KDUMY(100),ICLASS(100),ITYPE(100)_^1_$BYTE (ISNGL, SYMTAB(1)(8=8)),(KELSIZ,SYMTAB(1)(8=8)),_^1_#$ (ICOM,SYMTAB(1)(7=5)),(IPART,SYMTAB(1)(4=3))_^1_$DIMENSION ISNGL(100)€€,KELSIZ(100),ICOM(100),IPART(100)_^1_$BYTE (KRFCNT,SYMTAB(1)(2=2)),(IDIM,SYMTAB(1)(1=0)),_^1_#$ (IREL,SYMTAB(1)(1=1)),(IEXT,SYMTAB(1)(0=0))_^1_$DIMENSION KRFCNT(100),IDIM(100),IREL(100),IEXT(100)_^1_$EQUIVALENCE (IRSA,SYMTAB(2)),(ICOMTX,SYMTAB(2)),(ISNOL,SYMTAB(2))_^1_$DIMENSION IRSA(100), ICOMTX(100),ISNOL(100)_^1_$BYTE (IDATAS,SYMTAB(3)(15=15)),(IREF,SYMTAB(3)(15=15)),_^1_#$ (IEQ€€VX,SYMTAB(3)(14=8)),(ITILF,SYMTAB(3)(14=8))_^1_$DIMENSION IDATAS(100),IREF(100),IEQVX(100),ITILF(100)_^1_$BYTE (IPARTR,SYMTAB(3)(7=4)),(INDUCV,SYMTAB(3)(7=7)),(ISFARG,_^1_#$ SYMTAB(3)(6=6)),(IARGNO,SYMTAB(3)(5=0)),(IPARTL,SYMTAB(3)(3=0))_^1_$DIMENSION IPARTR(100),INDUCV(100),ISFARG(100),IARGNO(100),_^1_#$ IPARTL(100)_^1_$EQUIVALENCE (ISYM,SYMTAB(4))_^1_$DIMENSION ISYM(100)_^1C_]_^1€€C_#PHASE C, D, E LABELED COMMON BLOCK_^1_$EQUIVALENCE (NBLK(1),LOOPTS)_^1_$DIMENSION NBLK(446)_^1_$EQUIVALENCE (NPCBF(1),NBLK(1)),(IDVTAB(1),NBLK(58))_^1_$EQUIVALENCE (NSUMDS,NBLK(370))_^1C_#PUNCH BUFFER, ADDRESS HOLDERS, PRINT BUFFER, INDEX HISTORY TABLES_^1_$EQUIVALENCE(NPTBF,NBLK(371)),(IXS1,NBLK(426)),(IXS2,NBLK(436))_^1C_$INDEX REGISTER HOLDERS FOR SUBROUTINE IXOPT_^1_$DIMENSI€€ON NPCBF(57),IDVTAB(312),NPTBF(55),IXS1(10),IXS2(10)_^1C_]_^1C_#PHASE D AND E BLANK COMMON BLOCK BELOW COMPRESSED TABLE_^1_$COMMON // INBUFF(203),NOBUFF(1152),NRCD(5)_^1_$COMMON//NFTAB(160),NDSTAB(500)_^1_$COMMON//IV(5),IXS3(10)_^1_$COMMON//NSUMD,NDFL,NADX,NSUMVS,IXC,IXFLAG,IXF,IXQ_^1_$COMMON//IXSX,IUSE,IFIX,NOUTOT,NOWO,NL,NT,NA,NS,ND,NR,NQ,NF_^1_$COMMON//NTYPE,NOWI,NOPC,NOPT,NADD,€€NXPT_^1_$COMMON//NATYPE,ICT,INCT,NOCT,NSTYPE,LRS,NOBW,NBINC,NPC1_^1_$COMMON//NSETX,NRM,NPTBFX,NRC1,NRC2,NW2FL,NW2,NBFL,NXCON_^1_$COMMON//NASCI,ISCOUN,ICOUNT,NOFS,NODS,NDXJ,NX_^1C *** ADDITIONAL COMMON IS FOR CIRCULAR BUFFER POINTERS_^1_$COMMON // IHEAD,INOB,INC_^1_$EQUIVALENCE (IND(1),NL)_^1_$DIMENSION IND(14)_^1_$EQUIVALENCE (ICFLG,IV(2)),(ITCOUN,IV(3)),(IDECR,IV(4))_^1_$EQUIVALEN€€CE (NBCT,ISCOUN),(I6,IXSX)_^1C_#SAVE ASCII NAME FOR EPT + TRA_^1_$DIMENSION NAMSV(3)_^1_$EQUIVALENCE (IGLAB(1),NAMSV(1))_^1_$DIMENSION MESF(2)_^1_$DATA MESF(1),MESF(2)/$202A,$5544/_^1_$DATA NPASS/0/_^1C_#******************************************************_^1C_2SET PROGRAM COUNTER TO START OF THIS BLOCK_^1C *** INCT IS POINTER TO CIR BUF THAT ALWAYS INCREASES_^1C *** ACTUAL INDEX€€ IS COMPUTED FROM INCT MODULO INOB_^1_!50 INCT=IHEAD_^1_$ICOUNT=IXS1(1)_^1_$NOWI = 0_^1_!60 INCT = INCT + NOWI_^1C_2IS THIS BLOCK FINISHED_^1_$IF (INCT .LT. NOUTOT) GO TO 65_^1_!62 IXS1(1)=ICOUNT_^1_$RETURN_^1_!65 NX=INCT_^1_$IQF=0_^1_$CALL BKDWN_^1C_#MAXIMIZE RELATIVE ADDRESSING_^1C_#IS THIS RECORD TO BE OUTPUT_^1_$IF(NL.NE.0)GO TO 60_^1C_#YES-IS IT READY TO BE OUTPUT_^1_$IF(ND.NE€€.0) GO TO 67_^1C_#NO-END RECORD ENCOUNTERED THIS BUFFER_^1_$IF(IFIX.LT.0) GO TO 67_^1C_#NO-TOP OF BUFFER_^1_$IF (INCT.NE.IHEAD) GO TO 62_^1_$ICFLG=0_^1C_#YES- ONE WORD CANDIDATE_^1 6200 IF (ICOUNT .GT. NPASS) NPASS=ICOUNT_^1_$IF(ND+NR+NL .EQ. 0) CALL ADMAX_^1_$IF (INCT.NE.IHEAD) GO TO 621_^1_$IF ((IFIX .GT. ICOUNT .OR. AND(NOBUFF(INC),$8C00) .NE.0)_^1_#1 .AND. NPASS .GT. ICOUNT+127€€) GO TO 6201_^1 621 INCT=INCT+NOWI_^1_$IF(INCT.LT.NOUTOT)GO TO 623_^1C_#BOTTOM OF BUFFER_^1 6201 INCT=IHEAD_^1C_#ANY CHANGES_^1_$ICOUNT = IXS1(1)_^1 625 NX=INCT_^1_$CALL BKDWN_^1_$IF(NL.NE.0) GO TO 60_^1C_#IF SKIP,DONT LOOK AT REFERENCE_^1_$IF(NTYPE.GE.12.AND.NTYPE.LT.20)GO TO 6251_^1C_#IF CONDITIONAL JUMP,CHANGE TO REGULAR JUMP_^1_$IF(NTYPE.GE.20.AND.NTYPE.LT.28)GO TO 6258_^1C_#€€ADC_]_^1_$IF(NTYPE.GE.41.AND.NTYPE.LT.46)GO TO 6256_^1 6259 I=AND(NOPC,255)_^1C_#MAYBE NDSTAB REFERENCE_^1_$IF(I.EQ.2)GO TO 6254_^1C_#SYMTAB REFERENCE_^1_$ISYMX=NOPT_^1 6257 CALL GETSYM_^1_$I=IRSA(ISYMX)_^1 6255 IF(I.GE.32766)GO TO 70_^1C_#DEFINED_^1_$IF(I-ICOUNT.LT.256)GO TO 6253_^1C_#FLAG AS FUTURE_^1_$IQF=1_^1_$GO TO 70_^1 6254 I=NDSTAB(NOPT)_^1_$GO TO 6255_^1C_#ADC_]_^1 6256 IS€€YMX=NOPC_^1_$GO TO 6257_^1C_#SKIP AT TOP OF BUFF(R-SET NEXT COMMAND FIXED_^1 6251 INC=INDEX(INCT+3)_^1_$NOBUFF(INC) = OR (NOBUFF(INC),1024)_^1_$GO TO 6252_^1C_#FIX BUFFER TO AT LEAST THIS REFERENCE_^1 6253 IF(I.GT.IFIX)IFIX=I_^1C_#FORCE COMMAND OUT_^1 6252 NOUTOT = 0_^1_$GO TO 67_^1 6258 NTYPE=9-6*NF_^1_$ASSIGN 6259 TO IAD_^1_$GO TO 1160_^1C_#BUMP ICOUNT_^1C ***********************€€*********** FTN 3.1 **************************_^1 623 IF (NL+NT.NE.0 .OR. (NTYPE.GE.35 .AND. NTYPE.LT.40)_^1_#-_!.OR. NTYPE.GT.48) GO TO 6230_^1C ********************************** FTN 3.1 ($) **********************_^1_$IF(NTYPE.EQ.40)ICT=NOPC_^1_$IF(NTYPE.EQ.47.OR.(NTYPE.GE.5.AND._^1_#1 NTYPE.LT.11).OR.(NTYPE.GE.20.AND.NTYPE.LT.28.AND.NF.EQ.0))ICT=2_^1C ***********************€€*********** FTN 3.1 **************************_^1_$IF (NTYPE.EQ.48) ICT = 3_^1C ********************************** FTN 3.1 ($) **********************_^1_$CALL COUNT_^1_$IF(IFIX.LT.0)GO TO 6201_^1 6230 NX=INCT_^1_$CALL BKDWN_^1_$GO TO 6200_^1C_2IS THIS A LABEL_^1_!67 IF(NT.NE.1) GO TO 70_^1_$CALL LABOUT(0)_^1_$GO TO 60_^1C_2SET WORD TWO AND PROGRAM RELOCATION_^1_!70 NW2 = 0_^1_$N€€W2FL = 0_^1_$NRC1= 0_^1_$NRM = 1_^1_$NS1=AND(NOPC/4096,15)_^1_$NS2 = NOPC/256_^1_$NS2 = AND(NS2,15)_^1_$NS3= AND(NOPC,255)_^1C_2IS THIS CLASS ONE OR TWO COMMAND_^1_$IF(NTYPE.GE.50.AND.NTYPE.LT.54)GO TO 400_^1_$IF(JORG.EQ.1)CALL UNPUNC_^1_$JORG=0_^1_$IF(NTYPE - 11) 100,200,72_^1_!72 IF(NTYPE-20)300,101,73_^1_!73 IF(NTYPE-29)101,350,74_^1_!74 IF(NTYPE-49) 350,400,75_^1_!75 IF (NTYPE €€- 59) 400,500,600_^1C_#CONDITIONAL JUMP,CHANGE TO UNCONDITIONAL_^1 101 NTYPE=9-6*NF_^1_$ASSIGN 100 TO IAD_^1_$GO TO 1160_^1 100 NATYPE = NS1_^1C_2IS TYPE ONE WORD NON RELATIVE_^1_$IF(NTYPE .GT. 2) GO TO 110_^1_$NXCON = AND(NOPC,255)_^1C_2NOPC .AND. 255 INTO PRINT IMAGE HERE_^1 105 CALL NP2OUT_^1_$INC = INDEX(INCT)_^1_$NOBUFF(INC)=OR(NOBUFF(INC ),$8000)_^1C ***_]_^1_$GO TO 60_^1C€€_2GET ADDRESS FROM SYMTAB_^1C_2TAKE FLAG OUT OF BINARY WORD_^1 110 NOPC = NOPC-NS3_^1_$NS3 = NS3+1_^1_$GO TO (1150,1110,1120,1130),NS3_^1C_2PICK UP REFERENCE FROM VARIABLE TABLE_^1 1110 J = IDVTAB(NOPT)- ICOUNT_^1_$IF(IDVTAB(NOPT).LT.0)J=-IDVTAB(NOPT)-ICOUNT_^1_$NXCON=IDVTAB(NOPT)_^1_%IF(IFIX.LT.NXCON) IFIX=NXCON_^1_$IF(NXCON.LT.0)NXCON=-NXCON_^1C_2IS THIS A ONE WORD REFERENCE_^1_€€$IF(NTYPE .LT. 5) GO TO 113_^1C_2NO - TWO WORD_^1_$NW2 = J_^1 1115 NW2FL = 1_^1_$GO TO 161_^1C_2PICK UP FROM DUMMY PARAMETER TABLE_^1C_2GET LABEL FOR PRINT OUT_^1 1120 ISYMX = NDSTAB(NOPT-1)_^1_$CALL GETSYM_^1C ********************************** PSR 614 **************************_^1C ********************************** PSR 614 **************************_^1_%NASCI=ISYMX_^1C *******€€*************************** PSR 614 **************************_^1C ********************************** PSR 614 **************************_^1_%J=NDSTAB(NOPT)_^1_%IF(IFIX.LT.J) IFIX=J_^1_%J=J-ICOUNT_^1_$J = NDSTAB(NOPT) - ICOUNT_^1C_#ONE OR TWO WRDS_^1_$IF(NTYPE.LT.5)GO TO 113_^1C_#TWO_]_^1_$NW2=J-1_^1_$GO TO 1115_^1C_2ABSOLUTE OPERAND HERE_^1 1130 NW2 = NOPT_^1_$NXCON = ICOUNT+1_^1€€_$GO TO 1115_^1 1150 ISYMX = NOPT_^1_$CALL GETSYM_^1_$NASCI = ISYMX_^1C_2IS THERE A STORAGE LOCATION HERE_^1_$IF (IQF.NE.0) GO TO 1151_^1_$IF(IRSA(ISYMX) .LT.32766.OR.(IEXT(ISYMX).NE.0.AND.ICLASS(ISYMX)_^1_#1 .NE. 1)) GO TO 112_^1_$CALL WRITE (3,1,2,MESF)_^1_$GO TO 1154_^1C_#CAN WE MAKE THIS FUTURE RELATIVE TO PREVOUS_^1 1151 IF(IFIX.GT.ICOUNT.OR.IFIX.LT.0.OR.NTYPE.NE.9)GO TO 1157€€_^1C_#SO FAR WE CAN_^1_$DO 1158 I=1,NOFS,4_^1_$IF(NOPT.EQ.NFTAB(I).AND.NADD.EQ.NFTAB(I+1).AND.(IABS(NFTAB(I+2))_^1_#1 .EQ.7.OR.IABS(NFTAB(I+2)).EQ.44))GO TO 1159_^1C_#WE HAVENT FOUND ONE YET_^1 1158 CONTINUE_^1C_#WE DIDNT FIND ONE-PUT ENTRY IN FUTURE TABLE_^1_$GO TO 1157_^1 1159 J=NFTAB(I+3)-ICOUNT_^1_$IF(J.LT.(-127))GO TO 1158_^1C_#MAKE FUTURE RELATIVE TO PREVIOUS_^1_$NTYPE=4_^1_$€€NOPC=NOPC+1024_^1_$IFIX=ICOUNT_^1_$IDECR=1_^1_$IQF=0_^1_$CALL TABDEC_^1_$GO TO 113_^1C_2PUT THIS RECORD IN FUTURE TABLE_^1 1157 ASSIGN 1152 TO IAD1_^1 1155 IF (NOFS.LT.NSUMVS) GO TO IAD1_^1_$J=NOPC_^1_$NOPC=NFTAB(1)_^1_$ISYMX=NOPC_^1_$CALL GETSYM_^1_$IF(IRSA(ISYMX).GT.IFIX) IFIX=IRSA(ISYMX)_^1_$NRC3 = NRC1_^1_$CALL LABOUT(1)_^1_%NRC1 = NRC3_^1_$NOPC=J_^1_$GO TO IAD1_^1 1152 NFTAB(N€€OFS)=NOPT_^1_$NFTAB(NOFS+1) = NADD_^1_$ASSIGN 1156 TO IAD_^1 1160 IF(NTYPE.NE.9.OR.IR.NE.0)GO TO IAD_^1_$NTYPE=7_^1C_#UNSET RELATIVE,SET INDIRECT_^1_$NOPC=NOPC-1024_^1_$GO TO IAD_^1 1156 NFTAB(NOFS+2)=-NTYPE_^1_$IQF=0_^1_$NFTAB(NOFS+3) = ICOUNT + 1_^1_$NOFS = NOFS + 4_^1 1154 NOPT=0_^1C_2IS TYPE ONE WORD RELATIVE_^1 112 IF(NTYPE .GT. 4) GO TO 120_^1_$J = IRSA(ISYMX) - ICOUNT + NA€€ * NADD_^1 113 J =AND(J,255)_^1C ********************************** PSR 708 **************************_^1C ********************************** PSR 708 **************************_^1_(IF(J.EQ.0) J=$00FF_^1C ********************************** PSR 708 **************************_^1C ********************************** PSR 708 **************************_^1_$NOPC = OR(NOPC,J)_^1_$GO T€€O 105_^1C_2THIS IS A TWO WORD COMMAND_^1 120 NW2FL = 1_^1_$NRC2 = 1_^1_$IF(NOPT .NE. 0) GO TO 130_^1_$NW2 = 0_^1_$IF(NTYPE.GE.9)GO TO 161_^1_$GO TO 105_^1C_#IS ADDRESS EXTERNAL_^1 130 NW2=IRSA(ISYMX)+NA*NADD_^1_$IF(NTYPE.NE.5.OR.ICOM(ISYMX).NE.0)NW2=AND(NW2,32767)_^1_$IF (IEXT(ISYMX).NE.0.AND.ICLASS(ISYMX).NE.1) GO TO 170_^1C_2IS THIS ADDRESS BIASED_^1_$IF(NTYPE .EQ. 5) NRC2 = 0€€_^1C_2IS TYPE NON RELATIVE_^1_$IF(NTYPE .GT. 8) GO TO 160_^1C_2IS OPERAND IN COMMON_^1_$IF(ICOM(ISYMX) .EQ. 0 .OR. ICLASS(ISYMX) .NE. 1) GO TO 150_^1C_2IS ADDRESS EXTERNAL_^1C_2IS OPERAND IN UNLABELLED COMMON_^1_$NRC2=3_^1_$I = ICOM(ISYMX)_^1_$IF(ICOMBN(I) .EQ. 0) NRC2 = 2_^1C_2IS THIS ADDRESS INDIRECT_^1C ********************************** FTN 3.0 **************************_^1C *€€********************************* FTN 3.0 **************************_^1 150 GO TO 105_^1C ********************************** FTN 3.0 **************************_^1C ********************************** FTN 3.0 **************************_^1C_2ADDRESS IS RELATIVE_^1 160 NW2=IRSA(ISYMX)+NA*NADD-ICOUNT-1_^1 161 NRC2=0_^1_$GO TO 105_^1 170 IF(NTYPE.EQ.10)GO TO 160_^1C_2GO TO 160 IF €€THIS IS A RELATIVE_^1C_2REFERENCE TO A NON RELATIVE EXTERNAL_^1_$NW2=IRSA(ISYMX)_^1_$IRSA(ISYMX) = ICOUNT + 1_^1_$IF (IREL(ISYMX).NE.0.AND.ICLASS(ISYMX).NE.1) GO TO 180_^1C_2NON RELATIVE_^1_$NRC2 = 1_^1_$IF (NW2 .NE. ICOUNT+1) GO TO 105_^1C_2THIS IS FIRST REFERENCE_^1_$NW2=32767_^1_$GO TO 161_^1C_2THIS IS ARELATIVE EXTERNAL_^1 180 IF(NW2.NE.32767)GO TO 105_^1_$GO TO 161_^1 200 I€€F(NS2 .GT. 14) GO TO 210_^1C_2THIS IS ENA,INA,ENQ OR INQ_^1_$NATYPE = NS2 + 7_^1_$NXCON = NS3_^1_$IF(NS3.GT.127)NXCON=OR(NXCON,$FF00)_^1C ***_]_^1_$GO TO 105_^1C_2SKIP COMMAND_^1 300 NATYPE = NS3/16+28_^1_$NXCON = AND(NS3,15)_^1_$IF(NOPT.EQ.0) GO TO 105_^1_$ISYMX=NOPT_^1_$CALL GETSYM_^1_$NXCON=IRSA(ISYMX)-ICOUNT-1_^1_$NOPC=NOPC+NXCON_^1_$IF(IFIX.GE.0.AND.IFIX.LT.IRSA(ISYMX)) IFIX=€€IRSA (ISYMX)_^1_$GO TO 105_^1C_2SHIFT COMMAND_^1 210 NATYPE = NS3/32 + 20_^1_$NXCON = AND(NS3,31)_^1_$GO TO 105_^1 350 IF(NTYPE.GE.38)GO TO 3520_^1_$NATYPE=NS3/16+34_^1_$NXCON = AND(NS3,7)_^1_$IF(NXCON .EQ. 4) GO TO 3505_^1_$NXCON= 27_^1_$GO TO 105_^1 3505 NXCON = 11_^1_$GO TO 105_^1C_2THIS IS A SPECIAL STORE_^1 3520 IF(NTYPE .GT. 40) GO TO 351_^1C_2BSS_^1_$NATYPE=43_^1_$NXCON = €€NOPC_^1_$CALL UNPUNC_^1_$CALL SETPRT_^1_$ICT=NOPC_^1_$CALL COUNT_^1_$GO TO 60_^1C_2SET PROGRAM RELOCATABLE_^1 351 IF(NTYPE.GT.45)GO TO 375_^1_$ISYMX = NOPC_^1_$CALL GETSYM_^1_$NASCI = ISYMX_^1C_2SAVE FOR PRINTOUT_^1_$NATYPE = 44_^1_$NADD=NOPT_^1C_2CHECK FOR EXTERNAL_^1_$IF (IEXT(ISYMX).NE.0.AND.ICLASS(ISYMX).NE.1) GO TO 3540_^1C_#LOCATION GIVEN FOR SYMBOL_^1C_#FUTURE OR PSEUDO FU€€TURE_^1_$IF(IQF.NE.0)GO TO 352_^1_$IF (IRSA(ISYMX).GE.32765) GO TO 3522_^1_$IF (NTYPE .GT. 41) GO TO 354_^1_$NOPC=_%IRSA(ISYMX)+NOPT*NA-ICOUNT_^1_$GO TO 105_^1 3540 NOPC = IRSA(ISYMX)_^1_$IRSA(ISYMX) = ICOUNT_^1_$NRC1 = 1_^1C_2IS THIS FIRST ENCOUNTER_^1_$IF(ICOUNT .NE. NOPC) GO TO 105_^1C_2YES_^1_$NRC1 = 0_^1_$NOPC = 32767_^1_$GO TO 105_^1C_#NO LOCATION YET-SET FUTURE TABLE_^1C_2CH€€ECK SIZE OF FUTURE TABLE_^1 352 ASSIGN 355 TO IAD1_^1_$GO TO 1155_^1 355 NFTAB(NOFS)=NOPC_^1_$NFTAB(NOFS+1)=NOPT_^1_$NFTAB(NOFS+2) = NTYPE_^1_$NFTAB(NOFS+3)=ICOUNT_^1_$NOFS=NOFS+4_^1 353 NOPC=0_^1_$IQF=0_^1_$GO TO 105_^1 3522 CALL WRITE (3,1,2,MESF)_^1_$GO TO 353_^1C_2CODE HERE IS BASED ON NF AND NQ_^1C_(NQ=0,NF=0 TO BE STUFFED IF DUMMY ARG_^1C_3LOC OF REFERENCED OPND IF NOT DU€€MMY ARG_^1C_(NQ=0,NF=1 15-BIT RELATIVE,BIT 15 = 0_^1C_(NQ=1,NF=1 15-BIT RELATIVE,BIT 15 = 1_^1C_(NQ=1,NF=0 LOC OF REFERENCED OPND,BIT 15=1_^1 354 IF(NQ+NF.NE.0) GO TO 356_^1_$IF(KDUMY(ISYMX).NE.0) GO TO 353_^1C_2THIS IS LOC OF OPND,DIRECT OR INDIRECT_^1 356 IF(NF.EQ.1) GO TO 358_^1_$NOPC=IRSA(ISYMX)+NA*NOPT_^1_$NOPC=AND(NOPC,32767)_^1_$NOPC=NOPC+NQ*$8000_^1C*****_]_^1C_2IS LOC€€ ABSOLUTE_^1_$IF(NTYPE.EQ.45)GO TO 105_^1_$NRC1=1_^1_$I=ICOM(ISYMX)_^1_$IF(I.EQ.0)GO TO 105_^1_$NRC1=2_^1_$IF(ICOMBN(I).NE.0)NRC1=3_^1_$GO TO 105_^1C_#CALCULATE ADDRESS-15 BIT RELATIVE_^1 358 J=$8000_^1_$K= IRSA(ISYMX)+NOPT*NA_^1_$IF(K.GT.16383 ) K=OR(K,J)_^1_$NOPC=ICOUNT_^1_$IF(NOPC.GT.16383 ) NOPC=OR(NOPC,J)_^1_$NOPC=K-NOPC_^12_]_^1*_] FTN 3.3_^1*_#COMPUTE 16 BIT RELATIVE FOR F€€LOT/DFLOT. 15 BIT OTHERWISE_^11_]_^1_$IF(NQ.EQ.0) GO TO 105_^1*_] FTN 3.3_^12_]_^1_$NOPC= AND(NOPC,32767)_^1_$NOPC=NOPC+NQ*$8000_^1C ****_]_^1_$GO TO 105_^1C_2THIS IS A CONSTANT RECORD_^1 375 NATYPE=45_^1C ********************************** FTN 3.1 **************************_^1C_]_^1C_FNTYPE = 46, INTEGER CONSTANT_^1C_FNTYPE = 47, REAL CONSTANT_^1C_FNTYPE = 48, DP CONSTANT_^1€€C_]_^1_$M = 3 * (48 - NTYPE)_^1_$NXCON = NOPC_^1_$GO TO 390_^1 380 NXCON = NOPT_^1_$NOPC = NOPT_^1_$GO TO 390_^1 385 NXCON = NXPT_^1_$NOPC = NXPT_^1 390 M = M + 1_^1_$CALL NP2OUT_^1_$INC = INDEX(INCT)_^1_$NOBUFF(INC) = OR(NOBUFF(INC),$8000)_^1_$GO TO (380,385,60,380,60,60,60), M_^1C ********************************** FTN 3.1 ($) **********************_^1C_2THIS IS AN ORG RECORD€€_^1C_2SAVE THE PROGRAM COUNTER_^1 400 J = ICOUNT_^1_$JORG=1_^1_$NRM = 1_^1_$K = NOPC_^1C_2IS IT A CONTINUATION ORG_^1_$IF(NTYPE .EQ. 51 .OR. NTYPE .EQ. 53) GO TO 450_^1C_2NO EMPTY THE PUNCH BUFFER_^1_$CALL UNPUNC_^1C_2SET UP ORG PRINTOUT_^1_$ISYMX = NOPT_^1_$CALL GETSYM_^1_$NOPC = IRSA(ISYMX) + NADD* NA_^1_$NOPC=AND(NOPC,32767)_^1_$NASCI = ISYMX_^1_$ICOUNT = NOPC_^1_$NATYPE=42_^1_€€$CALL SETPRT_^1C_2SET UP BINARY OUTPUT_^1_$NOPC = K_^1 410 NRC1 = 0_^1C_2IS THIS A DATA ORG_^1_$IF(NTYPE.LT.52)NRM=3_^1C_2SET UP CON PRINTOUT_^1_$NATYPE=45_^1_$NXCON = NOPC_^1_$CALL NP2OUT_^1C_2SAVE ORG COUNTER_^1_$NDXJ = ICOUNT_^1_$ICOUNT = J_^1_$GO TO 60_^1C_2PICK UP ORG COUNTER_^1 450 ICOUNT = NDXJ_^1_$GO TO 410_^1C_2THIS IS A STATEMENT LABEL_^1 500 CALL CONV (NOPC,NPTBF(NSET€€X))_^1_$GO TO 60_^1 600 CALL UNPUNC_^1_$NATYPE=46_^1_$J = ICOUNT_^1_$ICOUNT = 0_^1_$NOPC = 0_^1_$CALL SETPRT_^1_$ICOUNT = J_^1C_$IF BLOCK DATA,DONT PUT OUT ENTRY_^1_$IF(ISUBP.EQ.1)GO TO 6010_^1C_#ENT CARD_^1_$NPCBF(1)=$8050_^1C ***_]_^1_$DO 601 I=1,3_^1 601 NPCBF(I+1)=NAMSV(I)_^1_$ISYMX=-LABX_^1_$CALL GETSYM_^1_$NPCBF(5)=IRSA(ISYMX)_^1_$NBINC=5_^1_$CALL NPUNCH_^1 6010 IHEAD=0_^1€_$END_]_^__ PWMAX2 CSY/ 02E P€1_%SUBROUTINE ADMAX_^1_#*_2/DECK-ID 02E FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^13_]_^1C THIS ADMAX IS USED IN PHASE E_^1C NON-IDENTICAL ADMAX USED IN PHASE D_^1C*****PHASE E COMMON ALL INCLUSIVE TO END POINT_^1C_]_^1C_#MASTER LABELED COMMON BLOCK€€._^1*_] FTN 3.3_^1_$COMMON /A/ IFLAGS,LINECT,LINCT1_^1_$COMMON /A/ IR,IK,IP,IA,IL,IM,IXLGO,IOPTO,IOPTV,IOPTC,IOPTD_^1_$COMMON /A/ MCSTRT,MACRNB,MACSEC_^1_$COMMON /A/ IERRS(16),ISRFAD_^1_$COMMON /A/ LGO,ISCRI,ISCRO,IX_^1*_] FTN 3.3_^1_$COMMON /A/ IGLAB(3),IGLAB1,IGLAB2_^1_$COMMON /A/ ICOMT(12),ICOMTS,ICOMX2,ICOMTL,ISUBP,NDPRS,_^1_#$LABX,IBCDTB(48)_^1_$EQUIVALENCE(ICOMB,ICOMT(1)),(€€ICOMBX,ICOMT(2)),(ICOMDF,_^1_#$ICOMT(3)),(ICOMBN,ICOMT(4))_^1_$DIMENSION ICOMB(6),ICOMBX(6),ICOMDF(6),ICOMBN(7)_^1_$COMMON /A/ LOOPTS,LOOPTX,LOOPTB,LOOPT(50)_^1_$EQUIVALENCE(LINDUC,LOOPT(1))_^1_$DIMENSION LINDUC(10)_^1_$EQUIVALENCE (LBEG,LOOPT(2))_^1_$DIMENSION LBEG(10)_^1_$EQUIVALENCE (LINC,LOOPT(3))_^1_$DIMENSION LINC(10)_^1_$EQUIVALENCE (LEND,LOOPT(4))_^1_$DIMENSION LEND(10)_^1_€€$BYTE(LLABL,LOOPT(5)(14=0)_))_^1_$DIMENSION LLABL(10)_^1_$BYTE(LID,LOOPT(5)(15=15) )_^1_$DIMENSION LID(10)_^1_$COMMON/A/IEQV(255), IEQVS,IEQVN2_^1_$COMMON /A/ ISTAB(150),ISTABS,ISTAB2_^1_$COMMON /A/ IBUFS,ISET(25),LBLANK,KSFCNT,KSNCNT,ISORSC,_^1_#$IHOBIT,ISTNO,ISSFLG,ISUBPN,ITERM,JSORSC,KEQVS_^1C_#SYMBOL TABLE LABELED COMMON BLOCK_^1_$COMMON /A/ ISYMN, ISYMFL,ISYMD,ISYMX,ISYMS,IS€€YMP,ISYMPC,ISYMPS,_^1_#$ ISYMNS, SYMTAB(2400)_^1_$INTEGER SYMTAB_^1_$BYTE (IDUM,SYMTAB(1)(15=15)),(KDUMY,SYMTAB(1)(15=15)),_^1_#$(ICLASS,SYMTAB(1)(14=11)),(ITYPE,SYMTAB(1)(10=9))_^1_$DIMENSION IDUM(100),KDUMY(100),ICLASS(100),ITYPE(100)_^1_$BYTE (ISNGL, SYMTAB(1)(8=8)),(KELSIZ,SYMTAB(1)(8=8)),_^1_#$ (ICOM,SYMTAB(1)(7=5)),(IPART,SYMTAB(1)(4=3))_^1_$DIMENSION ISNGL(100),KELSIZ(100),I€€COM(100),IPART(100)_^1_$BYTE (KRFCNT,SYMTAB(1)(2=2)),(IDIM,SYMTAB(1)(1=0)),_^1_#$ (IREL,SYMTAB(1)(1=1)),(IEXT,SYMTAB(1)(0=0))_^1_$DIMENSION KRFCNT(100),IDIM(100),IREL(100),IEXT(100)_^1_$EQUIVALENCE (IRSA,SYMTAB(2)),(ICOMTX,SYMTAB(2)),(ISNOL,SYMTAB(2))_^1_$DIMENSION IRSA(100), ICOMTX(100),ISNOL(100)_^1_$BYTE (IDATAS,SYMTAB(3)(15=15)),(IREF,SYMTAB(3)(15=15)),_^1_#$ (IEQVX,SYMTAB(3)(1€€4=8)),(ITILF,SYMTAB(3)(14=8))_^1_$DIMENSION IDATAS(100),IREF(100),IEQVX(100),ITILF(100)_^1_$BYTE (IPARTR,SYMTAB(3)(7=4)),(INDUCV,SYMTAB(3)(7=7)),(ISFARG,_^1_#$ SYMTAB(3)(6=6)),(IARGNO,SYMTAB(3)(5=0)),(IPARTL,SYMTAB(3)(3=0))_^1_$DIMENSION IPARTR(100),INDUCV(100),ISFARG(100),IARGNO(100),_^1_#$ IPARTL(100)_^1_$EQUIVALENCE (ISYM,SYMTAB(4))_^1_$DIMENSION ISYM(100)_^1C_]_^1C_#PHASE C, D,€€ E LABELED COMMON BLOCK_^1_$EQUIVALENCE (NBLK(1),LOOPTS)_^1_$DIMENSION NBLK(446)_^1_$EQUIVALENCE (NPCBF(1),NBLK(1)),(IDVTAB(1),NBLK(58))_^1_$EQUIVALENCE (NSUMDS,NBLK(370))_^1C_#PUNCH BUFFER, ADDRESS HOLDERS, PRINT BUFFER, INDEX HISTORY TABLES_^1_$EQUIVALENCE(NPTBF,NBLK(371)),(IXS1,NBLK(426)),(IXS2,NBLK(436))_^1C_$INDEX REGISTER HOLDERS FOR SUBROUTINE IXOPT_^1_$DIMENSION NPCBF(57),I€€DVTAB(312),NPTBF(55),IXS1(10),IXS2(10)_^1C_]_^1C_#PHASE D AND E BLANK COMMON BLOCK BELOW COMPRESSED TABLE_^1_$COMMON // INBUFF(203),NOBUFF(1152),NRCD(5)_^1_$COMMON//NFTAB(160),NDSTAB(500)_^1_$COMMON//IV(5),IXS3(10)_^1_$COMMON//NSUMD,NDFL,NADX,NSUMVS,IXC,IXFLAG,IXF,IXQ_^1_$COMMON//IXSX,IUSE,IFIX,NOUTOT,NOWO,NL,NT,NA,NS,ND,NR,NQ,NF_^1_$COMMON//NTYPE,NOWI,NOPC,NOPT,NADD,NXPT_^1_$COMMO€€N//NATYPE,ICT,INCT,NOCT,NSTYPE,LRS,NOBW,NBINC,NPC1_^1_$COMMON//NSETX,NRM,NPTBFX,NRC1,NRC2,NW2FL,NW2,NBFL,NXCON_^1_$COMMON//NASCI,ISCOUN,ICOUNT,NOFS,NODS,NDXJ,NX_^1C *** ADDITIONAL COMMON IS FOR CIRCULAR BUFFER POINTERS_^1_$COMMON // IHEAD,INOB,INC_^1C_]_^1C_#MAXIMIZE RELATIVE ADDRESSING_^1_$EQUIVALENCE(IND(1),NL)_^1_$DIMENSION IND(14)_^1_$EQUIVALENCE(ICFLG,IV(2)),(ITCOUN,IV(3)),(ID€€ECR,IV(4))_^1_$INC=INDEX(INCT)_^1_$INC1=INDEX(INCT+1)_^1_$INCM1=INDEX(INCT-1)_^1_$INCM2=INDEX(INCT-2)_^1_$INCM3=INDEX(INCT-3)_^1_$INCM4=INDEX(INCT-4)_^1_$INCM5=INDEX(INCT-5)_^1_$INCM6=INDEX(INCT-6)_^1C_#ONE WORD CANDIDATE_^1C_#CHECK FOR NSTAB REF_^1 622 I=AND(NOPC,255)_^1_$IF(NTYPE.EQ.40.AND.NOPC.EQ.(-1))GO TO 6210_^1_$IF(I.EQ.2)GO TO 6281_^1C_#SYMTAB REFERENCE_^1_$ISYMX=NOPT_^1_€€$CALL GETSYM_^1_$I=IRSA(ISYMX)+NA*NADD_^1C_#IS BUFFER FIXED TO HERE_^1 6282 IF(ICOUNT.GT.IFIX.OR.IFIX.EQ.0)GO TO 626_^1C_#YES-IS BUFFER FIXED BEYOND REFERENCE_^1_$IF (I.LE.IFIX) NOBUFF(INC)=OR(NOBUFF(INC),2048)_^1_$GO TO 621_^1C_#ONE WORD CANDIDATE W/NDSTAB REFERENCE_^1 6281 I=NDSTAB(NOPT)_^1_$GO TO 6282_^1C_#SHOULD WE KEEP II SAVER_^1 6210 IF(IUSE.NE.0)GO TO 6211_^1C_$NO_]_^1_$IDE€€CR=1_^1_$GO TO 6267_^1C_#CHANGE II SAVER BSS TO ORDINARY BSS 1_^1 6211 NOPC=1_^1_$NOBUFF(INC)=OR(NOBUFF(INC),1024)_^1_$NOBUFF(INC1)=1_^1_$GO TO 621_^1C_#CHECK FOR SPECIAL LDA I, STA I_^1 626 IF(NTYPE.NE.28) GO TO 6260_^1_$IF(IUSE.EQ.0) GO TO 6265_^1 6263 I=-252_^1_$NOBUFF(INC)=AND(NOBUFF(INC),I)_^1C_#SET ND AND NTYPE=1_^1_$NOBUFF(INC) = OR (NOBUFF(INC),$0804)_^1_$NTYPE=1_^1_$GO T€€O 621_^1 6265 IF(INCT+2.GE.NOUTOT)GO TO 621_^1_$NL=0_]_^1_$I=INCT+2_^1 6266 IDECR=2_^1_$I=INDEX(I)_^1_$NOBUFF(I)=OR(NOBUFF(I),$8000)_^1_$NTYPE=AND(NOBUFF(I),252)/4_^1_$IF(NTYPE.GT.8)IDECR=3_^1_$IF(NL.NE.0)ICOUNT=ICOUNT-IDECR+1_^1 6267 NOBUFF(INC) = OR (NOBUFF(INC),$8000)_^1C ***_]_^1_$NL=1_]_^1_$GO TO 627_^1 6260 IF(NTYPE.NE.29)GO TO 6269_^1_$IF (IUSE .NE. 0 .OR. INCT .EQ. IHEAD) €€GO TO 6263_^1_$NL=1_]_^1_$I=INCT-3_^1_$GO TO 6266_^1C_#DISTANCE TO REFERENCE_^1 6269 I=I-ICOUNT-1_^1_$IF(I.GE.127.OR.I.LT.(-126))GO TO 621_^1_$IDECR=1_^1C_#CONDITIONAL JUMP_^1_$IF(NTYPE.LT.20.OR.NTYPE.GE.28) GO TO 6275_^1C_#YES- ARE WE AT TOP OF BUFFER_^1_$IF (INCT.EQ.IHEAD.OR.(INCT.EQ.IHEAD+3.AND.(NTYPE.EQ.24.OR._^1_#1NTYPE.EQ.25))) GO TO 628_^1C_#NO-IS JUMP ALREADY 1 WORD_^1_$IF€€(NF.EQ.0) I=I-1_^1C_#CAN WE ELIMINATE JUMP_^1_$IF((I.GT.0.AND.I.LT.15).OR.(I.EQ.15.AND.NTYPE.NE.24))GO TO 629_^1C_#NO- MAKE IT ONE WORD_^1_$IF(NF.NE.0) GO TO 621_^1_$NF=1_]_^1_$NOBUFF(INC) = OR (NOBUFF(INC),256)_^1_$NOBUFF(INCM2)=NOBUFF(INCM2)-1_^1_$IF (NTYPE.EQ.25) NOBUFF(INCM5)=NOBUFF(INCM5)-1_^1C_#MODIFY TABLES BASED ON CHANGES_^1 627 ICFLG=1_^1_$CALL TABDEC_^1 621 RETURN_^1€€C_#MAKE 1 WORD RELATIVE_^1 6275 NOBUFF(INC)=NOBUFF(INC)-24_^1_$NOBUFF(INC)=OR(NOBUFF(INC),1024)_^1_$NTYPE=NTYPE-6_^1_$GO TO 627_^1C_#CONDITIONAL JUMP AT TOP OF BUFFER_^1 628 I=-252_^1_$NOBUFF(INC)=AND(NOBUFF(INC),I)_^1C_#NTYPE=9 OR 3 DEPENDINF ON NF AND NR=SET_^1_$I=36-24*NF+1024_^1_$NOBUFF(INC)=OR(NOBUFF(INC),I)_^1_$GO TO 621_^1C_#ELIMINATE CONDITIONAL JUMP_^1 629 IDECR=2_^1_$IF€€(NF.NE.0)IDECR=1_^1_$J=NTYPE-19_^1_$GO TO (6290,6291,6292,6293, 6294,6295,6296,6297),J_^1C_#AJLG- CHANGE SAZ TO SAN_^1 6290 NOBUFF(INCM2)=272_^1 6298 NOBUFF(INCM3)=OR(NOBUFF(INCM3),2048)_^1_$NOBUFF(INCM1)=NOPT_^1_$GO TO 6267_^1C_#AJEZ_]_^1 6291 NOBUFF(INCM2)=256_^1_$GO TO 6298_^1C_#AJLEZ_^1 6294 NOBUFF(INCM5)=256_^1_$NOBUFF(INCM6) = OR (NOBUFF(INCM6),2048)_^1_$NOBUFF(INCM4)=NOPT_€^1C_#AJLZ_]_^1 6292 NOBUFF(INCM2)=304_^1_$GO TO 6298_^1C_#AJGZ_]_^1 6295 NOBUFF(INCM5)=257_^1_$NOBUFF(INCM6)=OR(NOBUFF(INCM6),2048)_^1C_#AJGEZ_^1 6293 NOBUFF(INCM2)=288_^1_$GO TO 6298_^1C_#QJEZ_]_^1 6296 CONTINUE_^1 6297 NOBUFF(INCM2)=320_^1_$GO TO 6298_^1_$END_]_^__ PWGINO2 CSY/ 03E P€1_$SUBROUTINE BEGINO_^1_#*_2/DECK-ID 03E FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^13_]_^1C THIS IS THE 2.0B VERSION._^1C THIS BEGINO IS USED IN PHASE E_^1C NON-IDENTICAL BEGINO IS USED IN PHASE D_^1C*****PHASE E COMMON ALL INCLUSIVE TO END POINT_^1€€C_]_^1C_#MASTER LABELED COMMON BLOCK._^1*_] FTN 3.3_^1_$COMMON /A/ IFLAGS,LINECT,LINCT1_^1_$COMMON /A/ IR,IK,IP,IA,IL,IM,IXLGO,IOPTO,IOPTV,IOPTC,IOPTD_^1_$COMMON /A/ MCSTRT,MACRNB,MACSEC_^1_$COMMON /A/ IERRS(16),ISRFAD_^1_$COMMON /A/ LGO,ISCRI,ISCRO,IX_^1*_] FTN 3.3_^1_$COMMON /A/ IGLAB(3),IGLAB1,IGLAB2_^1_$COMMON /A/ ICOMT(12),ICOMTS,ICOMX2,ICOMTL,ISUBP,NDPRS,_^1_#$LABX,IBCDTB(4€€8)_^1_$EQUIVALENCE(ICOMB,ICOMT(1)),(ICOMBX,ICOMT(2)),(ICOMDF,_^1_#$ICOMT(3)),(ICOMBN,ICOMT(4))_^1_$DIMENSION ICOMB(6),ICOMBX(6),ICOMDF(6),ICOMBN(7)_^1_$COMMON /A/ LOOPTS,LOOPTX,LOOPTB,LOOPT(50)_^1_$EQUIVALENCE(LINDUC,LOOPT(1))_^1_$DIMENSION LINDUC(10)_^1_$EQUIVALENCE (LBEG,LOOPT(2))_^1_$DIMENSION LBEG(10)_^1_$EQUIVALENCE (LINC,LOOPT(3))_^1_$DIMENSION LINC(10)_^1_$EQUIVALENCE (LEND,€€LOOPT(4))_^1_$DIMENSION LEND(10)_^1_$BYTE(LLABL,LOOPT(5)(14=0)_))_^1_$DIMENSION LLABL(10)_^1_$BYTE(LID,LOOPT(5)(15=15) )_^1_$DIMENSION LID(10)_^1_$COMMON/A/IEQV(255), IEQVS,IEQVN2_^1_$COMMON /A/ ISTAB(150),ISTABS,ISTAB2_^1_$COMMON /A/ IBUFS,ISET(25),LBLANK,KSFCNT,KSNCNT,ISORSC,_^1_#$IHOBIT,ISTNO,ISSFLG,ISUBPN,ITERM,JSORSC,KEQVS_^1C_#SYMBOL TABLE LABELED COMMON BLOCK_^1_$COMMON /A€€/ ISYMN, ISYMFL,ISYMD,ISYMX,ISYMS,ISYMP,ISYMPC,ISYMPS,_^1_#$ ISYMNS, SYMTAB(2400)_^1_$INTEGER SYMTAB_^1_$BYTE (IDUM,SYMTAB(1)(15=15)),(KDUMY,SYMTAB(1)(15=15)),_^1_#$(ICLASS,SYMTAB(1)(14=11)),(ITYPE,SYMTAB(1)(10=9))_^1_$DIMENSION IDUM(100),KDUMY(100),ICLASS(100),ITYPE(100)_^1_$BYTE (ISNGL, SYMTAB(1)(8=8)),(KELSIZ,SYMTAB(1)(8=8)),_^1_#$ (ICOM,SYMTAB(1)(7=5)),(IPART,SYMTAB(1)(4=3))_^1€€_$DIMENSION ISNGL(100),KELSIZ(100),ICOM(100),IPART(100)_^1_$BYTE (KRFCNT,SYMTAB(1)(2=2)),(IDIM,SYMTAB(1)(1=0)),_^1_#$ (IREL,SYMTAB(1)(1=1)),(IEXT,SYMTAB(1)(0=0))_^1_$DIMENSION KRFCNT(100),IDIM(100),IREL(100),IEXT(100)_^1_$EQUIVALENCE (IRSA,SYMTAB(2)),(ICOMTX,SYMTAB(2)),(ISNOL,SYMTAB(2))_^1_$DIMENSION IRSA(100), ICOMTX(100),ISNOL(100)_^1_$BYTE (IDATAS,SYMTAB(3)(15=15)),(IREF,SYMTAB(€€3)(15=15)),_^1_#$ (IEQVX,SYMTAB(3)(14=8)),(ITILF,SYMTAB(3)(14=8))_^1_$DIMENSION IDATAS(100),IREF(100),IEQVX(100),ITILF(100)_^1_$BYTE (IPARTR,SYMTAB(3)(7=4)),(INDUCV,SYMTAB(3)(7=7)),(ISFARG,_^1_#$ SYMTAB(3)(6=6)),(IARGNO,SYMTAB(3)(5=0)),(IPARTL,SYMTAB(3)(3=0))_^1_$DIMENSION IPARTR(100),INDUCV(100),ISFARG(100),IARGNO(100),_^1_#$ IPARTL(100)_^1_$EQUIVALENCE (ISYM,SYMTAB(4))_^1_$DIMENS€€ION ISYM(100)_^1C_]_^1C_#PHASE C, D, E LABELED COMMON BLOCK_^1_$EQUIVALENCE (NBLK(1),LOOPTS)_^1_$DIMENSION NBLK(446)_^1_$EQUIVALENCE (NPCBF(1),NBLK(1)),(IDVTAB(1),NBLK(58))_^1_$EQUIVALENCE (NSUMDS,NBLK(370))_^1C_#PUNCH BUFFER, ADDRESS HOLDERS, PRINT BUFFER, INDEX HISTORY TABLES_^1_$EQUIVALENCE(NPTBF,NBLK(371)),(IXS1,NBLK(426)),(IXS2,NBLK(436))_^1C_$INDEX REGISTER HOLDERS FOR SUBROU€€TINE IXOPT_^1_$DIMENSION NPCBF(57),IDVTAB(312),NPTBF(55),IXS1(10),IXS2(10)_^1C_]_^1C_]_^1C_#PHASE D AND E BLANK COMMON BLOCK BELOW COMPRESSED TABLE_^1_$COMMON // INBUFF(203),NOBUFF(1152),NRCD(5)_^1_$COMMON//NFTAB(160),NDSTAB(500)_^1_$COMMON//IV(5),IXS3(10)_^1_$COMMON//NSUMD,NDFL,NADX,NSUMVS,IXC,IXFLAG,IXF,IXQ_^1_$COMMON//IXSX,IUSE,IFIX,NOUTOT,NOWO,NL,NT,NA,NS,ND,NR,NQ,NF_^1_$COMMON€€//NTYPE,NOWI,NOPC,NOPT,NADD,NXPT_^1_$COMMON//NATYPE,ICT,INCT,NOCT,NSTYPE,LRS,NOBW,NBINC,NPC1_^1_$COMMON//NSETX,NRM,NPTBFX,NRC1,NRC2,NW2FL,NW2,NBFL,NXCON_^1_$COMMON//NASCI,ISCOUN,ICOUNT,NOFS,NODS,NDXJ,NX_^1C *** ADDITIONAL COMMON IS FOR CIRCULAR BUFFER POINTERS_^1_$COMMON // IHEAD,INOB,INC_^1C_]_^1_$DIMENSION NAMSV(3)_^1_$EQUIVALENCE (IGLAB(1),NAMSV(1))_^1_$DIMENSION MSG(6),MSG2(5)€€,MSG3(5)_^1C_SC O M M O N_^1_$DATA MSG(1),MSG(2),MSG(3),MSG(4),MSG(5),MSG(6)/12,24,22,22,24,23/_^1C_QB L A N K_^1_$DATA MSG2(1),MSG2(2),MSG2(3),MSG2(4),MSG2(5)/11,21,10,23,20/_^1C_QL A B L E_^1_$DATA MSG3(1),MSG3(2),MSG3(3),MSG3(4),MSG3(5)/21,10,11,14,21/_^1C*********_]_^1_$IXS1(1)=0_^1_$ICOUNT=0_^1_$ITEMP = IA_^1_$IA = IL+IA+IM_^1C_2OUTPUT NAME CARD_^1_$DO 15 I=1,55_^€€1_!15 NPTBF (I) = IBCDTB(47)_^1C_2CONVERT NAME TO ASCI_^1C_2SET CARD TYPE_^1_$NPCBF(1)=8272_^1C_2SET COMMON AND DATA DIMENSIONS IN NAME CARD_^1_$J=1_]_^1_!25 IF(J.GE.ICOMX2)GO TO 47_^1_$K=2_]_^1_$IF(ICOMBN(J).NE.0)K=3_^1_$NPCBF(K)=ICOMBX(J)_^1_$J=J+ICOMTL_^1_$GO TO 25_^1_!47 NPTBFX=NSETX+1_^1_$IF(NPCBF(3).EQ.0.AND.NPCBF(2).EQ.0) GO TO 485_^1C_#PRINT COMMON AND LENGTH_^1_$DO 48 I=1,€€6_^1_$J=MSG(I)_^1_$NPTBF(NPTBFX)=IBCDTB(J+1)_^1_!48 NPTBFX=NPTBFX+1_^1C_#PRINT COMMON LENGTHS_^1_$CALL NWRITE_^1_$NPTBFX= NPTBFX+1_^1_$IF(NPCBF(3).EQ.0) GO TO 480_^1_$DO 481 I=1,5_^1_$J=MSG3(I)_^1_$NPTBF(NPTBFX)=IBCDTB(J+1)_^1 481 NPTBFX=NPTBFX+1_^1_$NPTBFX=NPTBFX+2_^1_$NPTBF(NPTBFX-1)=IBCDTB(37)_^1_$CALL IHCON(NPCBF(3))_^1_$NPTBFX=NPTBFX+2_^1C_#********BEGIN********** FTN 3.2 ***€€******************************_^1C_$CONVERT HEX CONSTANT TO ASCII_^1_%NPTBF(NPTBFX-1) = $28_^1_%CALL CONV(NPCBF(3),NPTBF(NPTBFX))_^1_%NPTBFX = NPTBFX + 10_^1_%NPTBF(NPTBFX-4) = $29_^1C_#*********************** FTN 3.2 ******END************************_^1_$IF(NPCBF(2).EQ.0)GO TO 483_^1 480 IF(NPCBF(2).EQ.0)GO TO 485_^1_$DO 482 I=1,5_^1_$J=MSG2(I)_^1_$NPTBF(NPTBFX)=IBCDTB(J+1)_^1 4€€82 NPTBFX=NPTBFX+1_^1_$NPTBFX=NPTBFX+2_^1_$NPTBF(NPTBFX-1)=IBCDTB(37)_^1_$CALL IHCON(NPCBF(2))_^1C_#********BEGIN********** FTN 3.2 *********************************_^1C_$CONVERT HEX CONSTANT TO ASCII_^1_%NPTBFX = NPTBFX + 2_^1_%NPTBF(NPTBFX-1) = $28_^1_%CALL CONV(NPCBF(2),NPTBF(NPTBFX))_^1_%NPTBF(NPTBFX+6) = $29_^1_%NPTBFX = NPTBFX + 7_^1C_#*********************** FTN 3.2 ******E€€ND************************_^1C_#PRINT COMMON LENGTHS AND BLANK LINE_^1 483 CALL NWRITE_^1_$CALL NWRITE_^1 485 IA = ITEMP_^1_$ISYMX = LABX_^1_$CALL GETSYM_^1_$NATYPE = 41_^1C_#CONVERT NAME TO ASCII,PUT IN NAME CARD + SAVE FOR EPT+TRA_^1_$CALL IACON_^1_$NPTBFX=NPTBFX-6_^1_$DO 49I=1,3_^1_$L=2*I-2+NPTBFX_^1_$K=2*I+NPTBFX-1_^1_$NPCBF(I+4)=OR(NPTBF(K),NPTBF(L)*256)_^1_$NPTBF(L)=$20_^1_€€$NPTBF(K)=$20_^149_"NAMSV(I)=NPCBF(I+4)_^1_$NASCI = ISYMX_^1_$LABX = -LABX_^1_$NOPC = 0_^1_$NA=0_]_^1_$NTYPE=15_^1C_2GO PRINT THE NAME CARD_^1_$CALL SETPRT_^1C ********************************** FTN 3.0 **************************_^1C ********************************** FTN 3.0 **************************_^1C THIS CODING READS THE INFORMATION STORED BY SAVEID AND STORES IT INTO_^1C_€€!THE OUTPUT PUNCH BUFFER_^1_$DO 490 I=8,10_^1_$NPCBF(I)=$2020_^1 490 CONTINUE_^1_$ILGO = LGO + 1_^1_$CALL READ (12,ILGO,47,NPCBF(11))_^1_$DO 4905 I=11,34_^1_$K=AND(NPCBF(I),255)+1_^1_$L=AND(NPCBF(I),$7F00)/$100+1_^1_$NPCBF(I)=IBCDTB(L)*$100+IBCDTB(K)_^1 4905 CONTINUE_^1_$NBINC = 34_^1C ********************************** FTN 3.0 **************************_^1C *********************€z************* FTN 3.0 **************************_^1_$CALL NPUNCH_^1C_#PRINT COMMON VARIABLES_^1_$ISYMX=0_^1_$ISYMP=0_^1 491 CALL SYMSCN_^1_$IF(ISYMP.EQ.1) GO TO 50_^1_$IF(ICOM(ISYMX).EQ.0) GO TO 491_^1_$NATYPE=47_^1_$J=ICOM(ISYMX)_^1_$IF(ICOMBN(J).NE.0)NATYPE=48_^1_$NASCI=ISYMX_^1_$NOPC=IRSA(ISYMX)_^1_$NRC1=NATYPE-45_^1_$CALL SETPRT_^1_$GO TO 491_^1_!50 RETURN_^1_$END_]_^__zPWBKDN3 CSY/ 04E P€1_$SUBROUTINE BKDWN_^1_#*_2/DECK-ID 04E FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^13_]_^1C THIS BKDWN IS USED IN PHASE E_^1C NON-IDENTICAL BKDWN USED IN PHASES C AND D_^1C*****PHASE E COMMON ALL INCLUSIVE TO END POINT_^1C_]_^1C_#MASTER LABELED COMMO€€N BLOCK._^1*_] FTN 3.3_^1_$COMMON /A/ IFLAGS,LINECT,LINCT1_^1_$COMMON /A/ IR,IK,IP,IA,IL,IM,IXLGO,IOPTO,IOPTV,IOPTC,IOPTD_^1_$COMMON /A/ MCSTRT,MACRNB,MACSEC_^1_$COMMON /A/ IERRS(16),ISRFAD_^1_$COMMON /A/ LGO,ISCRI,ISCRO,IX_^1*_] FTN 3.3_^1_$COMMON /A/ IGLAB(3),IGLAB1,IGLAB2_^1_$COMMON /A/ ICOMT(12),ICOMTS,ICOMX2,ICOMTL,ISUBP,NDPRS,_^1_#$LABX,IBCDTB(48)_^1_$EQUIVALENCE(ICOMB,ICOM€€T(1)),(ICOMBX,ICOMT(2)),(ICOMDF,_^1_#$ICOMT(3)),(ICOMBN,ICOMT(4))_^1_$DIMENSION ICOMB(6),ICOMBX(6),ICOMDF(6),ICOMBN(7)_^1_$COMMON /A/ LOOPTS,LOOPTX,LOOPTB,LOOPT(50)_^1_$EQUIVALENCE(LINDUC,LOOPT(1))_^1_$DIMENSION LINDUC(10)_^1_$EQUIVALENCE (LBEG,LOOPT(2))_^1_$DIMENSION LBEG(10)_^1_$EQUIVALENCE (LINC,LOOPT(3))_^1_$DIMENSION LINC(10)_^1_$EQUIVALENCE (LEND,LOOPT(4))_^1_$DIMENSION LEND(€€10)_^1_$BYTE(LLABL,LOOPT(5)(14=0)_))_^1_$DIMENSION LLABL(10)_^1_$BYTE(LID,LOOPT(5)(15=15) )_^1_$DIMENSION LID(10)_^1_$COMMON/A/IEQV(255), IEQVS,IEQVN2_^1_$COMMON /A/ ISTAB(150),ISTABS,ISTAB2_^1_$COMMON /A/ IBUFS,ISET(25),LBLANK,KSFCNT,KSNCNT,ISORSC,_^1_#$IHOBIT,ISTNO,ISSFLG,ISUBPN,ITERM,JSORSC,KEQVS_^1C_#SYMBOL TABLE LABELED COMMON BLOCK_^1_$COMMON /A/ ISYMN, ISYMFL,ISYMD,ISYMX,I€€SYMS,ISYMP,ISYMPC,ISYMPS,_^1_#$ ISYMNS, SYMTAB(2400)_^1_$INTEGER SYMTAB_^1_$BYTE (IDUM,SYMTAB(1)(15=15)),(KDUMY,SYMTAB(1)(15=15)),_^1_#$(ICLASS,SYMTAB(1)(14=11)),(ITYPE,SYMTAB(1)(10=9))_^1_$DIMENSION IDUM(100),KDUMY(100),ICLASS(100),ITYPE(100)_^1_$BYTE (ISNGL, SYMTAB(1)(8=8)),(KELSIZ,SYMTAB(1)(8=8)),_^1_#$ (ICOM,SYMTAB(1)(7=5)),(IPART,SYMTAB(1)(4=3))_^1_$DIMENSION ISNGL(100),KELSIZ€€(100),ICOM(100),IPART(100)_^1_$BYTE (KRFCNT,SYMTAB(1)(2=2)),(IDIM,SYMTAB(1)(1=0)),_^1_#$ (IREL,SYMTAB(1)(1=1)),(IEXT,SYMTAB(1)(0=0))_^1_$DIMENSION KRFCNT(100),IDIM(100),IREL(100),IEXT(100)_^1_$EQUIVALENCE (IRSA,SYMTAB(2)),(ICOMTX,SYMTAB(2)),(ISNOL,SYMTAB(2))_^1_$DIMENSION IRSA(100), ICOMTX(100),ISNOL(100)_^1_$BYTE (IDATAS,SYMTAB(3)(15=15)),(IREF,SYMTAB(3)(15=15)),_^1_#$ (IEQVX,SYMT€€AB(3)(14=8)),(ITILF,SYMTAB(3)(14=8))_^1_$DIMENSION IDATAS(100),IREF(100),IEQVX(100),ITILF(100)_^1_$BYTE (IPARTR,SYMTAB(3)(7=4)),(INDUCV,SYMTAB(3)(7=7)),(ISFARG,_^1_#$ SYMTAB(3)(6=6)),(IARGNO,SYMTAB(3)(5=0)),(IPARTL,SYMTAB(3)(3=0))_^1_$DIMENSION IPARTR(100),INDUCV(100),ISFARG(100),IARGNO(100),_^1_#$ IPARTL(100)_^1_$EQUIVALENCE (ISYM,SYMTAB(4))_^1_$DIMENSION ISYM(100)_^1C_]_^1C_#PHAS€€E C, D, E LABELED COMMON BLOCK_^1_$EQUIVALENCE (NBLK(1),LOOPTS)_^1_$DIMENSION NBLK(446)_^1_$EQUIVALENCE (NPCBF(1),NBLK(1)),(IDVTAB(1),NBLK(58))_^1_$EQUIVALENCE (NSUMDS,NBLK(370))_^1C_#PUNCH BUFFER, ADDRESS HOLDERS, PRINT BUFFER, INDEX HISTORY TABLES_^1_$EQUIVALENCE(NPTBF,NBLK(371)),(IXS1,NBLK(426)),(IXS2,NBLK(436))_^1C_$INDEX REGISTER HOLDERS FOR SUBROUTINE IXOPT_^1_$DIMENSION NPCB€€F(57),IDVTAB(312),NPTBF(55),IXS1(10),IXS2(10)_^1C_]_^1C_#PHASE D AND E BLANK COMMON BLOCK BELOW COMPRESSED TABLE_^1_$COMMON // INBUFF(203),NOBUFF(1152),NRCD(5)_^1_$COMMON//NFTAB(160),NDSTAB(500)_^1_$COMMON//IV(5),IXS3(10)_^1_$COMMON//NSUMD,NDFL,NADX,NSUMVS,IXC,IXFLAG,IXF,IXQ_^1_$COMMON//IXSX,IUSE,IFIX,NOUTOT,NOWO,NL,NT,NA,NS,ND,NR,NQ,NF_^1_$COMMON//NTYPE,NOWI,NOPC,NOPT,NADD,NXPT_^1€€_$COMMON//NATYPE,ICT,INCT,NOCT,NSTYPE,LRS,NOBW,NBINC,NPC1_^1_$COMMON//NSETX,NRM,NPTBFX,NRC1,NRC2,NW2FL,NW2,NBFL,NXCON_^1_$COMMON//NASCI,ISCOUN,ICOUNT,NOFS,NODS,NDXJ,NX_^1C *** ADDITIONAL COMMON IS FOR CIRCULAR BUFFER POINTERS_^1_$COMMON // IHEAD,INOB,INC_^1_$DIMENSION IND(14)_^1_$EQUIVALENCE(IND(1),NL)_^1_$EQUIVALENCE(ICFLG,IV(2)),(ITCOUN,IV(3)),(IDECR,IV(4))_^1_$IND(1)=0_^1_$DO 5 €bI=9,14_^1_"5_!IND(I)=0_^1_$INC=INDEX(NX)_^1_$IJK=NOBUFF(INC)_^1_$IF (IJK.LT.0) NL=1_^1_$N=$4000_^1_$DO 10 I=2,8_^1_'IND(I)=AND(IJK/N,1)_^1_!10_!N=N/2_^1_$NTYPE=AND(IJK/4,63)_^1_$NOWI=AND(IJK,3)+2_^1_$J=NX+1_^1_$K=NOWI+9_^1_$DO 20 I=11,K_^1_'INC=INDEX(J)_^1_'IND(I)=NOBUFF(INC)_^1_!20_!J=J+1_^1_$IF (NA.NE.0) RETURN_^1_$NXPT=NADD_^1_$NADD=0_^1_$END_]_^__ bPWCNT3 CSY/ 05E P€1_$SUBROUTINE COUNT_^1_#*_2/DECK-ID 05E FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^13_]_^1C THIS COUNT IS USED IN PHASE E_^1C NON-IDENTICAL COUNT USED IN PHASES C AND D_^1C*****PHASE E COMMON ALL INCLUSIVE TO END POINT_^1C_]_^1C_#MASTER LABELED COMMO€€N BLOCK._^1*_] FTN 3.3_^1_$COMMON /A/ IFLAGS,LINECT,LINCT1_^1_$COMMON /A/ IR,IK,IP,IA,IL,IM,IXLGO,IOPTO,IOPTV,IOPTC,IOPTD_^1_$COMMON /A/ MCSTRT,MACRNB,MACSEC_^1_$COMMON /A/ IERRS(16),ISRFAD_^1_$COMMON /A/ LGO,ISCRI,ISCRO,IX_^1*_] FTN 3.3_^1_$COMMON /A/ IGLAB(3),IGLAB1,IGLAB2_^1_$COMMON /A/ ICOMT(12),ICOMTS,ICOMX2,ICOMTL,ISUBP,NDPRS,_^1_#$LABX,IBCDTB(48)_^1_$EQUIVALENCE(ICOMB,ICOM€€T(1)),(ICOMBX,ICOMT(2)),(ICOMDF,_^1_#$ICOMT(3)),(ICOMBN,ICOMT(4))_^1_$DIMENSION ICOMB(6),ICOMBX(6),ICOMDF(6),ICOMBN(7)_^1_$COMMON /A/ LOOPTS,LOOPTX,LOOPTB,LOOPT(50)_^1_$EQUIVALENCE(LINDUC,LOOPT(1))_^1_$DIMENSION LINDUC(10)_^1_$EQUIVALENCE (LBEG,LOOPT(2))_^1_$DIMENSION LBEG(10)_^1_$EQUIVALENCE (LINC,LOOPT(3))_^1_$DIMENSION LINC(10)_^1_$EQUIVALENCE (LEND,LOOPT(4))_^1_$DIMENSION LEND(€€10)_^1_$BYTE(LLABL,LOOPT(5)(14=0)_))_^1_$DIMENSION LLABL(10)_^1_$BYTE(LID,LOOPT(5)(15=15) )_^1_$DIMENSION LID(10)_^1_$COMMON/A/IEQV(255), IEQVS,IEQVN2_^1_$COMMON /A/ ISTAB(150),ISTABS,ISTAB2_^1_$COMMON /A/ IBUFS,ISET(25),LBLANK,KSFCNT,KSNCNT,ISORSC,_^1_#$IHOBIT,ISTNO,ISSFLG,ISUBPN,ITERM,JSORSC,KEQVS_^1C_#SYMBOL TABLE LABELED COMMON BLOCK_^1_$COMMON /A/ ISYMN, ISYMFL,ISYMD,ISYMX,I€€SYMS,ISYMP,ISYMPC,ISYMPS,_^1_#$ ISYMNS, SYMTAB(2400)_^1_$INTEGER SYMTAB_^1_$BYTE (IDUM,SYMTAB(1)(15=15)),(KDUMY,SYMTAB(1)(15=15)),_^1_#$(ICLASS,SYMTAB(1)(14=11)),(ITYPE,SYMTAB(1)(10=9))_^1_$DIMENSION IDUM(100),KDUMY(100),ICLASS(100),ITYPE(100)_^1_$BYTE (ISNGL, SYMTAB(1)(8=8)),(KELSIZ,SYMTAB(1)(8=8)),_^1_#$ (ICOM,SYMTAB(1)(7=5)),(IPART,SYMTAB(1)(4=3))_^1_$DIMENSION ISNGL(100),KELSIZ€€(100),ICOM(100),IPART(100)_^1_$BYTE (KRFCNT,SYMTAB(1)(2=2)),(IDIM,SYMTAB(1)(1=0)),_^1_#$ (IREL,SYMTAB(1)(1=1)),(IEXT,SYMTAB(1)(0=0))_^1_$DIMENSION KRFCNT(100),IDIM(100),IREL(100),IEXT(100)_^1_$EQUIVALENCE (IRSA,SYMTAB(2)),(ICOMTX,SYMTAB(2)),(ISNOL,SYMTAB(2))_^1_$DIMENSION IRSA(100), ICOMTX(100),ISNOL(100)_^1_$BYTE (IDATAS,SYMTAB(3)(15=15)),(IREF,SYMTAB(3)(15=15)),_^1_#$ (IEQVX,SYMT€€AB(3)(14=8)),(ITILF,SYMTAB(3)(14=8))_^1_$DIMENSION IDATAS(100),IREF(100),IEQVX(100),ITILF(100)_^1_$BYTE (IPARTR,SYMTAB(3)(7=4)),(INDUCV,SYMTAB(3)(7=7)),(ISFARG,_^1_#$ SYMTAB(3)(6=6)),(IARGNO,SYMTAB(3)(5=0)),(IPARTL,SYMTAB(3)(3=0))_^1_$DIMENSION IPARTR(100),INDUCV(100),ISFARG(100),IARGNO(100),_^1_#$ IPARTL(100)_^1_$EQUIVALENCE (ISYM,SYMTAB(4))_^1_$DIMENSION ISYM(100)_^1C_]_^1C_#PHAS€€E C, D, E LABELED COMMON BLOCK_^1_$EQUIVALENCE (NBLK(1),LOOPTS)_^1_$DIMENSION NBLK(446)_^1_$EQUIVALENCE (NPCBF(1),NBLK(1)),(IDVTAB(1),NBLK(58))_^1_$EQUIVALENCE (NSUMDS,NBLK(370))_^1C_#PUNCH BUFFER, ADDRESS HOLDERS, PRINT BUFFER, INDEX HISTORY TABLES_^1_$EQUIVALENCE(NPTBF,NBLK(371)),(IXS1,NBLK(426)),(IXS2,NBLK(436))_^1C_$INDEX REGISTER HOLDERS FOR SUBROUTINE IXOPT_^1_$DIMENSION NPCB€€F(57),IDVTAB(312),NPTBF(55),IXS1(10),IXS2(10)_^1C_]_^1C_#PHASE D AND E BLANK COMMON BLOCK BELOW COMPRESSED TABLE_^1_$COMMON // INBUFF(203),NOBUFF(1152),NRCD(5)_^1_$COMMON//NFTAB(160),NDSTAB(500)_^1_$COMMON//IV(5),IXS3(10)_^1_$COMMON//NSUMD,NDFL,NADX,NSUMVS,IXC,IXFLAG,IXF,IXQ_^1_$COMMON//IXSX,IUSE,IFIX,NOUTOT,NOWO,NL,NT,NA,NS,ND,NR,NQ,NF_^1_$COMMON//NTYPE,NOWI,NOPC,NOPT,NADD,NXPT_^1€€_$COMMON//NATYPE,ICT,INCT,NOCT,NSTYPE,LRS,NOBW,NBINC,NPC1_^1_$COMMON//NSETX,NRM,NPTBFX,NRC1,NRC2,NW2FL,NW2,NBFL,NXCON_^1_$COMMON//NASCI,ISCOUN,ICOUNT,NOFS,NODS,NDXJ,NX_^1C *** ADDITIONAL COMMON IS FOR CIRCULAR BUFFER POINTERS_^1_$COMMON // IHEAD,INOB,INC_^1C_]_^1_$EQUIVALENCE(IND(1),NL)_^1_$DIMENSION IND(14)_^1_$EQUIVALENCE(ICFLG,IV(2)),(ITCOUN,IV(3)),(IDECR,IV(4))_^1_$ICOUNT = ICO€zUNT + ICT_^1_$IF( ICOUNT. GE. 0) GO TO 10_^1_$ICOUNT = AND ( ICOUNT, $7FFF) + 1_^1_$IFIX = -1_^110_"ICT = 1_^1_$END_]_^__ zPWFIN2 CSY/ 06E P€1_$SUBROUTINE FINISH_^1_#*_2/DECK-ID 06E FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^13_]_^1C THIS FINISH IS USED IN PHASE E_^1C NON-IDENTICAL FINISH IS USED IN PHASE D_^1C*****PHASE E COMMON ALL INCLUSIVE TO END POINT_^1C_]_^1C_#MASTER LABELED COMMON€€ BLOCK._^1*_] FTN 3.3_^1_$COMMON /A/ IFLAGS,LINECT,LINCT1_^1_$COMMON /A/ IR,IK,IP,IA,IL,IM,IXLGO,IOPTO,IOPTV,IOPTC,IOPTD_^1_$COMMON /A/ MCSTRT,MACRNB,MACSEC_^1_$COMMON /A/ IERRS(16),ISRFAD_^1_$COMMON /A/ LGO,ISCRI,ISCRO,IX_^1*_] FTN 3.3_^1_$COMMON /A/ IGLAB(3),IGLAB1,IGLAB2_^1_$COMMON /A/ ICOMT(12),ICOMTS,ICOMX2,ICOMTL,ISUBP,NDPRS,_^1_#$LABX,IBCDTB(48)_^1_$EQUIVALENCE(ICOMB,ICOMT€€(1)),(ICOMBX,ICOMT(2)),(ICOMDF,_^1_#$ICOMT(3)),(ICOMBN,ICOMT(4))_^1_$DIMENSION ICOMB(6),ICOMBX(6),ICOMDF(6),ICOMBN(7)_^1_$COMMON /A/ LOOPTS,LOOPTX,LOOPTB,LOOPT(50)_^1_$EQUIVALENCE(LINDUC,LOOPT(1))_^1_$DIMENSION LINDUC(10)_^1_$EQUIVALENCE (LBEG,LOOPT(2))_^1_$DIMENSION LBEG(10)_^1_$EQUIVALENCE (LINC,LOOPT(3))_^1_$DIMENSION LINC(10)_^1_$EQUIVALENCE (LEND,LOOPT(4))_^1_$DIMENSION LEND(1€€0)_^1_$BYTE(LLABL,LOOPT(5)(14=0)_))_^1_$DIMENSION LLABL(10)_^1_$BYTE(LID,LOOPT(5)(15=15) )_^1_$DIMENSION LID(10)_^1_$COMMON/A/IEQV(255), IEQVS,IEQVN2_^1_$COMMON /A/ ISTAB(150),ISTABS,ISTAB2_^1_$COMMON /A/ IBUFS,ISET(25),LBLANK,KSFCNT,KSNCNT,ISORSC,_^1_#$IHOBIT,ISTNO,ISSFLG,ISUBPN,ITERM,JSORSC,KEQVS_^1C_#SYMBOL TABLE LABELED COMMON BLOCK_^1_$COMMON /A/ ISYMN, ISYMFL,ISYMD,ISYMX,IS€€YMS,ISYMP,ISYMPC,ISYMPS,_^1_#$ ISYMNS, SYMTAB(2400)_^1_$INTEGER SYMTAB_^1_$BYTE (IDUM,SYMTAB(1)(15=15)),(KDUMY,SYMTAB(1)(15=15)),_^1_#$(ICLASS,SYMTAB(1)(14=11)),(ITYPE,SYMTAB(1)(10=9))_^1_$DIMENSION IDUM(100),KDUMY(100),ICLASS(100),ITYPE(100)_^1_$BYTE (ISNGL, SYMTAB(1)(8=8)),(KELSIZ,SYMTAB(1)(8=8)),_^1_#$ (ICOM,SYMTAB(1)(7=5)),(IPART,SYMTAB(1)(4=3))_^1_$DIMENSION ISNGL(100),KELSIZ(€€100),ICOM(100),IPART(100)_^1C ********************************** FTN 3.1 **************************_^1_$BYTE (IDCONB,SYMTAB(1)(4=4)), (IUNDEF,SYMTAB(1)(3=3))_^1_$DIMENSION IDCONB(100), IUNDEF(100)_^1C ********************************** FTN 3.1 ($) **********************_^1_$BYTE (KRFCNT,SYMTAB(1)(2=2)),(IDIM,SYMTAB(1)(1=0)),_^1_#$ (IREL,SYMTAB(1)(1=1)),(IEXT,SYMTAB(1)(0=0))_^1_$€€DIMENSION KRFCNT(100),IDIM(100),IREL(100),IEXT(100)_^1_$EQUIVALENCE (IRSA,SYMTAB(2)),(ICOMTX,SYMTAB(2)),(ISNOL,SYMTAB(2))_^1_$DIMENSION IRSA(100), ICOMTX(100),ISNOL(100)_^1_$BYTE (IDATAS,SYMTAB(3)(15=15)),(IREF,SYMTAB(3)(15=15)),_^1_#$ (IEQVX,SYMTAB(3)(14=8)),(ITILF,SYMTAB(3)(14=8))_^1_$DIMENSION IDATAS(100),IREF(100),IEQVX(100),ITILF(100)_^1_$BYTE (IPARTR,SYMTAB(3)(7=4)),(INDUCV,S€€YMTAB(3)(7=7)),(ISFARG,_^1_#$ SYMTAB(3)(6=6)),(IARGNO,SYMTAB(3)(5=0)),(IPARTL,SYMTAB(3)(3=0))_^1_$DIMENSION IPARTR(100),INDUCV(100),ISFARG(100),IARGNO(100),_^1_#$ IPARTL(100)_^1_$EQUIVALENCE (ISYM,SYMTAB(4))_^1_$DIMENSION ISYM(100)_^1C_]_^1C_#PHASE C, D, E LABELED COMMON BLOCK_^1_$EQUIVALENCE (NBLK(1),LOOPTS)_^1_$DIMENSION NBLK(446)_^1_$EQUIVALENCE (NPCBF(1),NBLK(1)),(IDVTAB(1),NBL€€K(58))_^1_$EQUIVALENCE (NSUMDS,NBLK(370))_^1C_#PUNCH BUFFER, ADDRESS HOLDERS, PRINT BUFFER, INDEX HISTORY TABLES_^1_$EQUIVALENCE(NPTBF,NBLK(371)),(IXS1,NBLK(426)),(IXS2,NBLK(436))_^1C_$INDEX REGISTER HOLDERS FOR SUBROUTINE IXOPT_^1_$DIMENSION NPCBF(57),IDVTAB(312),NPTBF(55),IXS1(10),IXS2(10)_^1C_]_^1C_#PHASE D AND E BLANK COMMON BLOCK BELOW COMPRESSED TABLE_^1_$COMMON // INBUFF(203€€),NOBUFF(1152),NRCD(5)_^1_$COMMON//NFTAB(160),NDSTAB(500)_^1_$COMMON//IV(5),IXS3(10)_^1_$COMMON//NSUMD,NDFL,NADX,NSUMVS,IXC,IXFLAG,IXF,IXQ_^1_$COMMON//IXSX,IUSE,IFIX,NOUTOT,NOWO,NL,NT,NA,NS,ND,NR,NQ,NF_^1_$COMMON//NTYPE,NOWI,NOPC,NOPT,NADD,NXPT_^1_$COMMON//NATYPE,ICT,INCT,NOCT,NSTYPE,LRS,NOBW,NBINC,NPC1_^1_$COMMON//NSETX,NRM,NPTBFX,NRC1,NRC2,NW2FL,NW2,NBFL,NXCON_^1_$COMMON//NASCI,I€€SCOUN,ICOUNT,NOFS,NODS,NDXJ,NX_^1C *** ADDITIONAL COMMON IS FOR CIRCULAR BUFFER POINTERS_^1_$COMMON // IHEAD,INOB,INC_^1C_]_^1C_#OUTPUT GARBAGE AT END OF LISTING-UNDEFINED SYMBOLS,UNREFERENCED_^1C_#LABELS, PROGRAM LENGTH_^1_$EQUIVALENCE(IND(1),NL)_^1_$DIMENSION IND(14)_^1_$EQUIVALENCE(ICFLG,IV(2)),(ITCOUN,IV(3)),(IDECR,IV(4))_^1_$DIMENSION MSG(14),MSG1(14)_^1_$DIMENSION_!MSG2(9)_^€€1_$DATA MSG1(1),MSG1(2),MSG1(3),MSG1(4)/$55,$4E,$44,$45/_^1_$DATA MSG1(5),MSG1(6),MSG1(7),MSG1(8)/$46,$49,$4E,$45/_^1_$DATA MSG1(9),MSG1(10),MSG1(11),MSG1(12)/$44,$20,$53,$59/_^1_$DATA MSG1(13),MSG1(14)/$4D,$53/_^1_$DATA MSG(1),MSG(2),MSG(3),MSG(4),MSG(5)/$50,$52,$4F,$47,$52/_^1_$DATA MSG(6),MSG(7),MSG(8),MSG(9),MSG(10)/$41,$4D,$20,$4C,$45/_^1_$DATA MSG(11),MSG(12),MSG(13),MSG(14)/€€$4E,$47,$54,$48/_^1_$DATA MSG2(1),MSG2(2),MSG2(3),MSG2(4),MSG2(5)/$45,$58,$54,$45,$52/_^1_$DATA MSG2(6),MSG2(7),MSG2(8),MSG2(9)/$4E,$41,$4C,$53/_^1*_810 CARDS DELETED_6FTN 3.3_^1_$ITEMP=IA_^1_$IA=IL+IA+IM_^1C_#BLANK LINE_^1_$CALL NWRITE_^1_$NPTBFX=NPTBFX+1_^1_$DO 100 I=1,14_^1_$NPTBF(NPTBFX)=MSG(I)_^1 100 NPTBFX=NPTBFX+1_^1_$NPTBF(NPTBFX+1)=IBCDTB(37)_^1_$NPTBFX=NPTBFX+2_^1_$CALL€€ IHCON(ICOUNT)_^1C_#********BEGIN********** FTN 3.2 *********************************_^1C_$CONVERT HEX CONSTANT TO ASCII_^1_%NPTBFX = NPTBFX + 2_^1_%NPTBF(NPTBFX-1) = $28_^1_%CALL CONV(ICOUNT,NPTBF(NPTBFX))_^1_%NPTBF(NPTBFX+6) = $29_^1_%NPTBFX = NPTBFX + 7_^1C_#*********************** FTN 3.2 ******END************************_^1_$CALL NWRITE_^1C_#BLANK LINE_^1_$CALL NWRITE_^1*_819€€ CARDS DELETED_6FTN 3.3_^1 485 ISYMX=0_^1_$ISYMP=0_^1C_#EXT CARD_^1_$NBINC=1_^1_$NPCBF(1)=$A050_^1_$J=0_]_^1C_#PRINT EXTERNALS_^1_$NPTBFX=NPTBFX+1_^1 486 CALL SYMSCN_^1_$IF(ISYMP.EQ.1)GO TO 489_^1_$IF(IEXT(ISYMX).EQ.0.OR.IRSA(ISYMX).EQ.32767_#)GO TO 486_^1_$IF (ICLASS(ISYMX) .EQ. 1) GO TO 486_^1_$IF(J.NE.0) GO TO 488_^1_$J=1_]_^1_$DO 487 I=1,9_^1_$NPTBF(NPTBFX)=MSG2(I)_^1 487€€ NPTBFX=NPTBFX+1_^1 460 CALL NWRITE_^1_$NPTBFX=NPTBFX+1_^1_$K=NPTBFX_^1 488 CALL IACON_^1_$IF(NPTBFX.LT.K+46)GO TO 461_^1_$CALL NWRITE_^1_$K=NPTBFX+1_^1 461 NPTBFX=NPTBFX+1_^1C_#CONVERT NAME TO ASCII_^1_$CALL IACON_^1_$NPTBFX=NPTBFX-6_^1_$DO 500 I=1,3_^1_$L2=NBINC+I_^1_$L1=2*I-2+NPTBFX_^1_$L3=2*I+NPTBFX-1_^1_$NPCBF(L2)=OR(NPTBF(L3),NPTBF(L1)*256)_^1_$NPTBF(L1)=$20_^1 500 NPTBF(€€L3)=$20_^1 501 NBINC=NBINC+4_^1_$NPCBF(NBINC)=IRSA(ISYMX)_^1_$IF(IREL(ISYMX).NE.0)NPCBF(NBINC-3)=OR(NPCBF(NBINC-3),$8000)_^1_$IF(NBINC.NE.57) GO TO 486_^1_$CALL NPUNCH_^1_$NBINC=1_^1_$NPCBF(1)=$A050_^1_$GO TO 486_^1 489 IF (J.NE.0.AND.K.NE.NPTBFX) CALL NWRITE_^1_$IF (NBINC.NE.1) CALL NPUNCH_^1_$CALL NWRITE_^1_$NPTBFX=NPTBFX+1_^1C_#UNDEFINED VARIABLES_^1_$ISYMX=0_^1_$ISYMP=0_^1_"2€€ CALL SYMSCN_^1_$IF (ISYMP.EQ.1) GO TO 6_^1C ********************************** FTN 3.1 **************************_^1_$IF (IUNDEF(ISYMX).EQ.0 .OR. IRSA(ISYMX).NE.32767) GO TO 2_^1C ********************************** FTN 3.1 ($) **********************_^1C_#MOVE IN HEADING_^1_$DO 4 I=1,14_^1_$NPTBF(NPTBFX)=MSG1(I)_^1_"4 NPTBFX=NPTBFX+1_^1_$CALL NWRITE_^1_$NPTBFX=NPTBFX+1_^1_$J=NP€€TBFX_^1_"5 CALL IACON_^1C_#UPDATE IMAGE COUNT FOR NEXT SYMBOL_^1_$NPTBFX=NPTBFX+1_^1C_#IF LINE IS FULL-WRITE IT_^1_$IF (NPTBFX.LT.J+46) GO TO 20_^1C_#IT IS SO WE WILL_^1_$CALL NWRITE_^1_$NPTBFX=NPTBFX+1_^1C_#SAVE START OF BUFFER_^1_$J=NPTBFX_^1_!20 CALL SYMSCN_^1_$IF (ISYMP.EQ.1) GO TO 21_^1C ********************************** FTN 3.1 **************************_^1_$IF (IUNDEF(ISY€ÆMX).EQ.0 .OR. IRSA(ISYMX).NE.32767) GO TO 20_^1C ********************************** FTN 3.1 ($) **********************_^1_$GO TO 5_^1_!21 IF (NPTBFX.GT.J) CALL NWRITE_^1_"6 IA=ITEMP_^1_$END_]_^__ ÆPWIACN2 CSY/ 07E P€1_$SUBROUTINE IACON_^1_#*_2/DECK-ID 07E FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^13_]_^1C THIS IACON IS USED IN PHASE E_^1C NON-IDENTICAL IACON USED IN PHASE D_^1C*****PHASE E COMMON ALL INCLUSIVE TO END POINT_^1C_]_^1C_#MASTER LABELED COMMON BLOCK€€._^1*_] FTN 3.3_^1_$COMMON /A/ IFLAGS,LINECT,LINCT1_^1_$COMMON /A/ IR,IK,IP,IA,IL,IM,IXLGO,IOPTO,IOPTV,IOPTC,IOPTD_^1_$COMMON /A/ MCSTRT,MACRNB,MACSEC_^1_$COMMON /A/ IERRS(16),ISRFAD_^1_$COMMON /A/ LGO,ISCRI,ISCRO,IX_^1*_] FTN 3.3_^1_$COMMON /A/ IGLAB(3),IGLAB1,IGLAB2_^1_$COMMON /A/ ICOMT(12),ICOMTS,ICOMX2,ICOMTL,ISUBP,NDPRS,_^1_#$LABX,IBCDTB(48)_^1_$EQUIVALENCE(ICOMB,ICOMT(1)),(€€ICOMBX,ICOMT(2)),(ICOMDF,_^1_#$ICOMT(3)),(ICOMBN,ICOMT(4))_^1_$DIMENSION ICOMB(6),ICOMBX(6),ICOMDF(6),ICOMBN(7)_^1_$COMMON /A/ LOOPTS,LOOPTX,LOOPTB,LOOPT(50)_^1_$EQUIVALENCE(LINDUC,LOOPT(1))_^1_$DIMENSION LINDUC(10)_^1_$EQUIVALENCE (LBEG,LOOPT(2))_^1_$DIMENSION LBEG(10)_^1_$EQUIVALENCE (LINC,LOOPT(3))_^1_$DIMENSION LINC(10)_^1_$EQUIVALENCE (LEND,LOOPT(4))_^1_$DIMENSION LEND(10)_^1_€€$BYTE(LLABL,LOOPT(5)(14=0)_))_^1_$DIMENSION LLABL(10)_^1_$BYTE(LID,LOOPT(5)(15=15) )_^1_$DIMENSION LID(10)_^1_$COMMON/A/IEQV(255), IEQVS,IEQVN2_^1_$COMMON /A/ ISTAB(150),ISTABS,ISTAB2_^1_$COMMON /A/ IBUFS,ISET(25),LBLANK,KSFCNT,KSNCNT,ISORSC,_^1_#$IHOBIT,ISTNO,ISSFLG,ISUBPN,ITERM,JSORSC,KEQVS_^1C_#SYMBOL TABLE LABELED COMMON BLOCK_^1_$COMMON /A/ ISYMN, ISYMFL,ISYMD,ISYMX,ISYMS,IS€€YMP,ISYMPC,ISYMPS,_^1_#$ ISYMNS, SYMTAB(2400)_^1_$INTEGER SYMTAB_^1_$BYTE (IDUM,SYMTAB(1)(15=15)),(KDUMY,SYMTAB(1)(15=15)),_^1_#$(ICLASS,SYMTAB(1)(14=11)),(ITYPE,SYMTAB(1)(10=9))_^1_$DIMENSION IDUM(100),KDUMY(100),ICLASS(100),ITYPE(100)_^1_$BYTE (ISNGL, SYMTAB(1)(8=8)),(KELSIZ,SYMTAB(1)(8=8)),_^1_#$ (ICOM,SYMTAB(1)(7=5)),(IPART,SYMTAB(1)(4=3))_^1_$DIMENSION ISNGL(100),KELSIZ(100),I€€COM(100),IPART(100)_^1_$BYTE (KRFCNT,SYMTAB(1)(2=2)),(IDIM,SYMTAB(1)(1=0)),_^1_#$ (IREL,SYMTAB(1)(1=1)),(IEXT,SYMTAB(1)(0=0))_^1_$DIMENSION KRFCNT(100),IDIM(100),IREL(100),IEXT(100)_^1_$EQUIVALENCE (IRSA,SYMTAB(2)),(ICOMTX,SYMTAB(2)),(ISNOL,SYMTAB(2))_^1_$DIMENSION IRSA(100), ICOMTX(100),ISNOL(100)_^1_$BYTE (IDATAS,SYMTAB(3)(15=15)),(IREF,SYMTAB(3)(15=15)),_^1_#$ (IEQVX,SYMTAB(3)(1€€4=8)),(ITILF,SYMTAB(3)(14=8))_^1_$DIMENSION IDATAS(100),IREF(100),IEQVX(100),ITILF(100)_^1_$BYTE (IPARTR,SYMTAB(3)(7=4)),(INDUCV,SYMTAB(3)(7=7)),(ISFARG,_^1_#$ SYMTAB(3)(6=6)),(IARGNO,SYMTAB(3)(5=0)),(IPARTL,SYMTAB(3)(3=0))_^1_$DIMENSION IPARTR(100),INDUCV(100),ISFARG(100),IARGNO(100),_^1_#$ IPARTL(100)_^1_$EQUIVALENCE (ISYM,SYMTAB(4))_^1_$DIMENSION ISYM(100)_^1C_]_^1C_#PHASE C, D,€€ E LABELED COMMON BLOCK_^1_$EQUIVALENCE (NBLK(1),LOOPTS)_^1_$DIMENSION NBLK(446)_^1_$EQUIVALENCE (NPCBF(1),NBLK(1)),(IDVTAB(1),NBLK(58))_^1_$EQUIVALENCE (NSUMDS,NBLK(370))_^1C_#PUNCH BUFFER, ADDRESS HOLDERS, PRINT BUFFER, INDEX HISTORY TABLES_^1_$EQUIVALENCE(NPTBF,NBLK(371)),(IXS1,NBLK(426)),(IXS2,NBLK(436))_^1C_$INDEX REGISTER HOLDERS FOR SUBROUTINE IXOPT_^1_$DIMENSION NPCBF(57),I€€DVTAB(312),NPTBF(55),IXS1(10),IXS2(10)_^1C_]_^1C_#PHASE D AND E BLANK COMMON BLOCK BELOW COMPRESSED TABLE_^1_$COMMON // INBUFF(203),NOBUFF(1152),NRCD(5)_^1_$COMMON//NFTAB(160),NDSTAB(500)_^1_$COMMON//IV(5),IXS3(10)_^1_$COMMON//NSUMD,NDFL,NADX,NSUMVS,IXC,IXFLAG,IXF,IXQ_^1_$COMMON//IXSX,IUSE,IFIX,NOUTOT,NOWO,NL,NT,NA,NS,ND,NR,NQ,NF_^1_$COMMON//NTYPE,NOWI,NOPC,NOPT,NADD,NXPT_^1_$COMMO€€N//NATYPE,ICT,INCT,NOCT,NSTYPE,LRS,NOBW,NBINC,NPC1_^1_$COMMON//NSETX,NRM,NPTBFX,NRC1,NRC2,NW2FL,NW2,NBFL,NXCON_^1_$COMMON//NASCI,ISCOUN,ICOUNT,NOFS,NODS,NDXJ,NX_^1C *** ADDITIONAL COMMON IS FOR CIRCULAR BUFFER POINTERS_^1_$COMMON // IHEAD,INOB,INC_^1C_]_^1C_#CONVERT SYMTAB ENTRY NAME TO ASCII + PUT IN PRINT BUFFER_^1C_#ISYMX=ENTRY TO CONVERT_^1C_#PRINT BUFFER IS NPTBF_^1C_#PRINT BU€€FFER INDEX IS NPTBFX_^1C_]_^1_$DIMENSION ICONF(4),ITEMP(3)_^1_$DATA IADD/0/_^1_$DATA ICONF(1),ICONF(2),ICONF(3),ICONF(4)/1521,39,1,0/_^1_$EQUIVALENCE_!(ICONF(4),ITEMP(1)),(ITEMP(3),KTEMP)_^1_$DO 1 I=1,2_^1_$K=ISYMX+I-1_^1_$ITEMP(1)=0_^1_$ITEMP(2)=0_^1_$KTEMP=ISYM(K)_^1_$IF (KTEMP.GE.0) GO TO 4_^1_$KTEMP=ISYM(K)-30420_^1_$IADD=20_^1C_]_^1 4_"DO 2J=1,3_^1_$ITEMP(J)=(KTEMP-ITEMP(1)*IC€²ONF(1)-ITEMP(2)*ICONF(2))/ICONF(J)_^1_$K=ITEMP(J)+IADD_^1_$IF(K.EQ.38)K=46_^1_$NPTBF(NPTBFX)_)= IBCDTB(K+1)_^1_$NPTBFX=NPTBFX+1_^12_#IADD=0_^11_#CONTINUE_^1_$RETURN_^1_$END_]_^__²PWIHCN2 CSY/ 08E P€1_$SUBROUTINE IHCON(I1)_^1_#*_2/DECK-ID 08E FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^13_]_^1C THIS IHCON IS USED IN PHASE E_^1C NON-IDENTICAL IHCON USED IN PHASE D_^1C*****PHASE E COMMON ALL INCLUSIVE TO END POINT_^1C_]_^1C_#MASTER LABELED COMMON B€€LOCK._^1*_] FTN 3.3_^1_$COMMON /A/ IFLAGS,LINECT,LINCT1_^1_$COMMON /A/ IR,IK,IP,IA,IL,IM,IXLGO,IOPTO,IOPTV,IOPTC,IOPTD_^1_$COMMON /A/ MCSTRT,MACRNB,MACSEC_^1_$COMMON /A/ IERRS(16),ISRFAD_^1_$COMMON /A/ LGO,ISCRI,ISCRO,IX_^1*_] FTN 3.3_^1_$COMMON /A/ IGLAB(3),IGLAB1,IGLAB2_^1_$COMMON /A/ ICOMT(12),ICOMTS,ICOMX2,ICOMTL,ISUBP,NDPRS,_^1_#$LABX,IBCDTB(48)_^1_$EQUIVALENCE(ICOMB,ICOMT(1€€)),(ICOMBX,ICOMT(2)),(ICOMDF,_^1_#$ICOMT(3)),(ICOMBN,ICOMT(4))_^1_$DIMENSION ICOMB(6),ICOMBX(6),ICOMDF(6),ICOMBN(7)_^1_$COMMON /A/ LOOPTS,LOOPTX,LOOPTB,LOOPT(50)_^1_$EQUIVALENCE(LINDUC,LOOPT(1))_^1_$DIMENSION LINDUC(10)_^1_$EQUIVALENCE (LBEG,LOOPT(2))_^1_$DIMENSION LBEG(10)_^1_$EQUIVALENCE (LINC,LOOPT(3))_^1_$DIMENSION LINC(10)_^1_$EQUIVALENCE (LEND,LOOPT(4))_^1_$DIMENSION LEND(10)€€_^1_$BYTE(LLABL,LOOPT(5)(14=0)_))_^1_$DIMENSION LLABL(10)_^1_$BYTE(LID,LOOPT(5)(15=15) )_^1_$DIMENSION LID(10)_^1_$COMMON/A/IEQV(255), IEQVS,IEQVN2_^1_$COMMON /A/ ISTAB(150),ISTABS,ISTAB2_^1_$COMMON /A/ IBUFS,ISET(25),LBLANK,KSFCNT,KSNCNT,ISORSC,_^1_#$IHOBIT,ISTNO,ISSFLG,ISUBPN,ITERM,JSORSC,KEQVS_^1C_#SYMBOL TABLE LABELED COMMON BLOCK_^1_$COMMON /A/ ISYMN, ISYMFL,ISYMD,ISYMX,ISYM€€S,ISYMP,ISYMPC,ISYMPS,_^1_#$ ISYMNS, SYMTAB(2400)_^1_$INTEGER SYMTAB_^1_$BYTE (IDUM,SYMTAB(1)(15=15)),(KDUMY,SYMTAB(1)(15=15)),_^1_#$(ICLASS,SYMTAB(1)(14=11)),(ITYPE,SYMTAB(1)(10=9))_^1_$DIMENSION IDUM(100),KDUMY(100),ICLASS(100),ITYPE(100)_^1_$BYTE (ISNGL, SYMTAB(1)(8=8)),(KELSIZ,SYMTAB(1)(8=8)),_^1_#$ (ICOM,SYMTAB(1)(7=5)),(IPART,SYMTAB(1)(4=3))_^1_$DIMENSION ISNGL(100),KELSIZ(10€€0),ICOM(100),IPART(100)_^1_$BYTE (KRFCNT,SYMTAB(1)(2=2)),(IDIM,SYMTAB(1)(1=0)),_^1_#$ (IREL,SYMTAB(1)(1=1)),(IEXT,SYMTAB(1)(0=0))_^1_$DIMENSION KRFCNT(100),IDIM(100),IREL(100),IEXT(100)_^1_$EQUIVALENCE (IRSA,SYMTAB(2)),(ICOMTX,SYMTAB(2)),(ISNOL,SYMTAB(2))_^1_$DIMENSION IRSA(100), ICOMTX(100),ISNOL(100)_^1_$BYTE (IDATAS,SYMTAB(3)(15=15)),(IREF,SYMTAB(3)(15=15)),_^1_#$ (IEQVX,SYMTAB(€€3)(14=8)),(ITILF,SYMTAB(3)(14=8))_^1_$DIMENSION IDATAS(100),IREF(100),IEQVX(100),ITILF(100)_^1_$BYTE (IPARTR,SYMTAB(3)(7=4)),(INDUCV,SYMTAB(3)(7=7)),(ISFARG,_^1_#$ SYMTAB(3)(6=6)),(IARGNO,SYMTAB(3)(5=0)),(IPARTL,SYMTAB(3)(3=0))_^1_$DIMENSION IPARTR(100),INDUCV(100),ISFARG(100),IARGNO(100),_^1_#$ IPARTL(100)_^1_$EQUIVALENCE (ISYM,SYMTAB(4))_^1_$DIMENSION ISYM(100)_^1C_]_^1C_#PHASE C€€, D, E LABELED COMMON BLOCK_^1_$EQUIVALENCE (NBLK(1),LOOPTS)_^1_$DIMENSION NBLK(446)_^1_$EQUIVALENCE (NPCBF(1),NBLK(1)),(IDVTAB(1),NBLK(58))_^1_$EQUIVALENCE (NSUMDS,NBLK(370))_^1C_#PUNCH BUFFER, ADDRESS HOLDERS, PRINT BUFFER, INDEX HISTORY TABLES_^1_$EQUIVALENCE(NPTBF,NBLK(371)),(IXS1,NBLK(426)),(IXS2,NBLK(436))_^1C_$INDEX REGISTER HOLDERS FOR SUBROUTINE IXOPT_^1_$DIMENSION NPCBF(5€€7),IDVTAB(312),NPTBF(55),IXS1(10),IXS2(10)_^1C_]_^1C_#PHASE D AND E BLANK COMMON BLOCK BELOW COMPRESSED TABLE_^1_$COMMON // INBUFF(203),NOBUFF(1152),NRCD(5)_^1_$COMMON//NFTAB(160),NDSTAB(500)_^1_$COMMON//IV(5),IXS3(10)_^1_$COMMON//NSUMD,NDFL,NADX,NSUMVS,IXC,IXFLAG,IXF,IXQ_^1_$COMMON//IXSX,IUSE,IFIX,NOUTOT,NOWO,NL,NT,NA,NS,ND,NR,NQ,NF_^1_$COMMON//NTYPE,NOWI,NOPC,NOPT,NADD,NXPT_^1_$C€€OMMON//NATYPE,ICT,INCT,NOCT,NSTYPE,LRS,NOBW,NBINC,NPC1_^1_$COMMON//NSETX,NRM,NPTBFX,NRC1,NRC2,NW2FL,NW2,NBFL,NXCON_^1_$COMMON//NASCI,ISCOUN,ICOUNT,NOFS,NODS,NDXJ,NX_^1C *** ADDITIONAL COMMON IS FOR CIRCULAR BUFFER POINTERS_^1_$COMMON // IHEAD,INOB,INC_^1C_]_^1C_]_^1C_#CONVERT NO. IN IHCON TO HEX_^1_$EQUIVALENCE(IND(1),NL)_^1_$DIMENSION IND(14)_^1_$EQUIVALENCE(ICFLG,IV(2)),(ITCOUN,I€–V(3)),(IDECR,IV(4))_^1_$K=4096_^1_$DO 1 I=1,4_^1_$J=I1/K_^1_$J=AND(J,15)_^1_$NPTBF(NPTBFX)=IBCDTB(J+1)_^1_$K=K/16_^1_"1 NPTBFX=NPTBFX+1_^1_$END_]_^__ –PWDEX2 CSY/ 09E P€1_$FUNCTION INDEX(INX)_^1_#*_2/DECK-ID 09E FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^13_]_^1C THIS INDEX IS USED IN PHASE E_^1C NON-IDENTICAL INDEX USED IN PHASE D_^1C*****PHASE E COMMON ALL INCLUSIVE TO END POINT_^1C_]_^1C_#MASTER LABELED COMMON BL€€OCK._^1*_] FTN 3.3_^1_$COMMON /A/ IFLAGS,LINECT,LINCT1_^1_$COMMON /A/ IR,IK,IP,IA,IL,IM,IXLGO,IOPTO,IOPTV,IOPTC,IOPTD_^1_$COMMON /A/ MCSTRT,MACRNB,MACSEC_^1_$COMMON /A/ IERRS(16),ISRFAD_^1_$COMMON /A/ LGO,ISCRI,ISCRO,IX_^1*_] FTN 3.3_^1_$COMMON /A/ IGLAB(3),IGLAB1,IGLAB2_^1_$COMMON /A/ ICOMT(12),ICOMTS,ICOMX2,ICOMTL,ISUBP,NDPRS,_^1_#$LABX,IBCDTB(48)_^1_$EQUIVALENCE(ICOMB,ICOMT(1)€€),(ICOMBX,ICOMT(2)),(ICOMDF,_^1_#$ICOMT(3)),(ICOMBN,ICOMT(4))_^1_$DIMENSION ICOMB(6),ICOMBX(6),ICOMDF(6),ICOMBN(7)_^1_$COMMON /A/ LOOPTS,LOOPTX,LOOPTB,LOOPT(50)_^1_$EQUIVALENCE(LINDUC,LOOPT(1))_^1_$DIMENSION LINDUC(10)_^1_$EQUIVALENCE (LBEG,LOOPT(2))_^1_$DIMENSION LBEG(10)_^1_$EQUIVALENCE (LINC,LOOPT(3))_^1_$DIMENSION LINC(10)_^1_$EQUIVALENCE (LEND,LOOPT(4))_^1_$DIMENSION LEND(10)_€€^1_$BYTE(LLABL,LOOPT(5)(14=0)_))_^1_$DIMENSION LLABL(10)_^1_$BYTE(LID,LOOPT(5)(15=15) )_^1_$DIMENSION LID(10)_^1_$COMMON/A/IEQV(255), IEQVS,IEQVN2_^1_$COMMON /A/ ISTAB(150),ISTABS,ISTAB2_^1_$COMMON /A/ IBUFS,ISET(25),LBLANK,KSFCNT,KSNCNT,ISORSC,_^1_#$IHOBIT,ISTNO,ISSFLG,ISUBPN,ITERM,JSORSC,KEQVS_^1C_#SYMBOL TABLE LABELED COMMON BLOCK_^1_$COMMON /A/ ISYMN, ISYMFL,ISYMD,ISYMX,ISYMS€€,ISYMP,ISYMPC,ISYMPS,_^1_#$ ISYMNS, SYMTAB(2400)_^1_$INTEGER SYMTAB_^1_$BYTE (IDUM,SYMTAB(1)(15=15)),(KDUMY,SYMTAB(1)(15=15)),_^1_#$(ICLASS,SYMTAB(1)(14=11)),(ITYPE,SYMTAB(1)(10=9))_^1_$DIMENSION IDUM(100),KDUMY(100),ICLASS(100),ITYPE(100)_^1_$BYTE (ISNGL, SYMTAB(1)(8=8)),(KELSIZ,SYMTAB(1)(8=8)),_^1_#$ (ICOM,SYMTAB(1)(7=5)),(IPART,SYMTAB(1)(4=3))_^1_$DIMENSION ISNGL(100),KELSIZ(100€€),ICOM(100),IPART(100)_^1_$BYTE (KRFCNT,SYMTAB(1)(2=2)),(IDIM,SYMTAB(1)(1=0)),_^1_#$ (IREL,SYMTAB(1)(1=1)),(IEXT,SYMTAB(1)(0=0))_^1_$DIMENSION KRFCNT(100),IDIM(100),IREL(100),IEXT(100)_^1_$EQUIVALENCE (IRSA,SYMTAB(2)),(ICOMTX,SYMTAB(2)),(ISNOL,SYMTAB(2))_^1_$DIMENSION IRSA(100), ICOMTX(100),ISNOL(100)_^1_$BYTE (IDATAS,SYMTAB(3)(15=15)),(IREF,SYMTAB(3)(15=15)),_^1_#$ (IEQVX,SYMTAB(3€€)(14=8)),(ITILF,SYMTAB(3)(14=8))_^1_$DIMENSION IDATAS(100),IREF(100),IEQVX(100),ITILF(100)_^1_$BYTE (IPARTR,SYMTAB(3)(7=4)),(INDUCV,SYMTAB(3)(7=7)),(ISFARG,_^1_#$ SYMTAB(3)(6=6)),(IARGNO,SYMTAB(3)(5=0)),(IPARTL,SYMTAB(3)(3=0))_^1_$DIMENSION IPARTR(100),INDUCV(100),ISFARG(100),IARGNO(100),_^1_#$ IPARTL(100)_^1_$EQUIVALENCE (ISYM,SYMTAB(4))_^1_$DIMENSION ISYM(100)_^1C_]_^1C_#PHASE C,€€ D, E LABELED COMMON BLOCK_^1_$EQUIVALENCE (NBLK(1),LOOPTS)_^1_$DIMENSION NBLK(446)_^1_$EQUIVALENCE (NPCBF(1),NBLK(1)),(IDVTAB(1),NBLK(58))_^1_$EQUIVALENCE (NSUMDS,NBLK(370))_^1C_#PUNCH BUFFER, ADDRESS HOLDERS, PRINT BUFFER, INDEX HISTORY TABLES_^1_$EQUIVALENCE(NPTBF,NBLK(371)),(IXS1,NBLK(426)),(IXS2,NBLK(436))_^1C_$INDEX REGISTER HOLDERS FOR SUBROUTINE IXOPT_^1_$DIMENSION NPCBF(57€€),IDVTAB(312),NPTBF(55),IXS1(10),IXS2(10)_^1C_]_^1C_#PHASE D AND E BLANK COMMON BLOCK BELOW COMPRESSED TABLE_^1_$COMMON // INBUFF(203),NOBUFF(1152),NRCD(5)_^1_$COMMON//NFTAB(160),NDSTAB(500)_^1_$COMMON//IV(5),IXS3(10)_^1_$COMMON//NSUMD,NDFL,NADX,NSUMVS,IXC,IXFLAG,IXF,IXQ_^1_$COMMON//IXSX,IUSE,IFIX,NOUTOT,NOWO,NL,NT,NA,NS,ND,NR,NQ,NF_^1_$COMMON//NTYPE,NOWI,NOPC,NOPT,NADD,NXPT_^1_$CO€€MMON//NATYPE,ICT,INCT,NOCT,NSTYPE,LRS,NOBW,NBINC,NPC1_^1_$COMMON//NSETX,NRM,NPTBFX,NRC1,NRC2,NW2FL,NW2,NBFL,NXCON_^1_$COMMON//NASCI,ISCOUN,ICOUNT,NOFS,NODS,NDXJ,NX_^1C *** ADDITIONAL COMMON IS FOR CIRCULAR BUFFER POINTERS_^1_$COMMON // IHEAD,INOB,INC_^1_$EQUIVALENCE (IND(1),NL)_^1_$DIMENSION IND(14)_^1_$EQUIVALENCE (ICFLG,IV(2)),(ITCOUN,IV(3)),(IDECR,IV(4))_^1_$EQUIVALENCE (NBCT,IS€nCOUN),(I6,IXSX)_^1C_]_^1_$INDEX=INX-(INX/INOB)*INOB_^1_$IF (INDEX .EQ. 0) INDEX=INOB_^1_$RETURN_^1_$END_]_^__nPWLABT2 CSY/ 10E P€1_$SUBROUTINE LABOUT(LPAR)_^1_#*_2/DECK-ID 10E FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^13_]_^1C THIS LABOUT IS USED IN PHASE E_^1C NON-IDENTICAL LABOUT USED IN PHASE D_^1C*****PHASE E COMMON ALL INCLUSIVE TO END POINT_^1C_]_^1C_#MASTER LABELED COM€€MON BLOCK._^1*_] FTN 3.3_^1_$COMMON /A/ IFLAGS,LINECT,LINCT1_^1_$COMMON /A/ IR,IK,IP,IA,IL,IM,IXLGO,IOPTO,IOPTV,IOPTC,IOPTD_^1_$COMMON /A/ MCSTRT,MACRNB,MACSEC_^1_$COMMON /A/ IERRS(16),ISRFAD_^1_$COMMON /A/ LGO,ISCRI,ISCRO,IX_^1*_] FTN 3.3_^1_$COMMON /A/ IGLAB(3),IGLAB1,IGLAB2_^1_$COMMON /A/ ICOMT(12),ICOMTS,ICOMX2,ICOMTL,ISUBP,NDPRS,_^1_#$LABX,IBCDTB(48)_^1_$EQUIVALENCE(ICOMB,IC€€OMT(1)),(ICOMBX,ICOMT(2)),(ICOMDF,_^1_#$ICOMT(3)),(ICOMBN,ICOMT(4))_^1_$DIMENSION ICOMB(6),ICOMBX(6),ICOMDF(6),ICOMBN(7)_^1_$COMMON /A/ LOOPTS,LOOPTX,LOOPTB,LOOPT(50)_^1_$EQUIVALENCE(LINDUC,LOOPT(1))_^1_$DIMENSION LINDUC(10)_^1_$EQUIVALENCE (LBEG,LOOPT(2))_^1_$DIMENSION LBEG(10)_^1_$EQUIVALENCE (LINC,LOOPT(3))_^1_$DIMENSION LINC(10)_^1_$EQUIVALENCE (LEND,LOOPT(4))_^1_$DIMENSION LEN€€D(10)_^1_$BYTE(LLABL,LOOPT(5)(14=0)_))_^1_$DIMENSION LLABL(10)_^1_$BYTE(LID,LOOPT(5)(15=15) )_^1_$DIMENSION LID(10)_^1_$COMMON/A/IEQV(255), IEQVS,IEQVN2_^1_$COMMON /A/ ISTAB(150),ISTABS,ISTAB2_^1_$COMMON /A/ IBUFS,ISET(25),LBLANK,KSFCNT,KSNCNT,ISORSC,_^1_#$IHOBIT,ISTNO,ISSFLG,ISUBPN,ITERM,JSORSC,KEQVS_^1C_#SYMBOL TABLE LABELED COMMON BLOCK_^1_$COMMON /A/ ISYMN, ISYMFL,ISYMD,ISYMX€€,ISYMS,ISYMP,ISYMPC,ISYMPS,_^1_#$ ISYMNS, SYMTAB(2400)_^1_$INTEGER SYMTAB_^1_$BYTE (IDUM,SYMTAB(1)(15=15)),(KDUMY,SYMTAB(1)(15=15)),_^1_#$(ICLASS,SYMTAB(1)(14=11)),(ITYPE,SYMTAB(1)(10=9))_^1_$DIMENSION IDUM(100),KDUMY(100),ICLASS(100),ITYPE(100)_^1_$BYTE (ISNGL, SYMTAB(1)(8=8)),(KELSIZ,SYMTAB(1)(8=8)),_^1_#$ (ICOM,SYMTAB(1)(7=5)),(IPART,SYMTAB(1)(4=3))_^1_$DIMENSION ISNGL(100),KELS€€IZ(100),ICOM(100),IPART(100)_^1_$BYTE (KRFCNT,SYMTAB(1)(2=2)),(IDIM,SYMTAB(1)(1=0)),_^1_#$ (IREL,SYMTAB(1)(1=1)),(IEXT,SYMTAB(1)(0=0))_^1_$DIMENSION KRFCNT(100),IDIM(100),IREL(100),IEXT(100)_^1_$EQUIVALENCE (IRSA,SYMTAB(2)),(ICOMTX,SYMTAB(2)),(ISNOL,SYMTAB(2))_^1_$DIMENSION IRSA(100), ICOMTX(100),ISNOL(100)_^1_$BYTE (IDATAS,SYMTAB(3)(15=15)),(IREF,SYMTAB(3)(15=15)),_^1_#$ (IEQVX,SY€€MTAB(3)(14=8)),(ITILF,SYMTAB(3)(14=8))_^1_$DIMENSION IDATAS(100),IREF(100),IEQVX(100),ITILF(100)_^1_$BYTE (IPARTR,SYMTAB(3)(7=4)),(INDUCV,SYMTAB(3)(7=7)),(ISFARG,_^1_#$ SYMTAB(3)(6=6)),(IARGNO,SYMTAB(3)(5=0)),(IPARTL,SYMTAB(3)(3=0))_^1_$DIMENSION IPARTR(100),INDUCV(100),ISFARG(100),IARGNO(100),_^1_#$ IPARTL(100)_^1_$EQUIVALENCE (ISYM,SYMTAB(4))_^1_$DIMENSION ISYM(100)_^1C_]_^1C_#PH€€ASE C, D, E LABELED COMMON BLOCK_^1_$EQUIVALENCE (NBLK(1),LOOPTS)_^1_$DIMENSION NBLK(446)_^1_$EQUIVALENCE (NPCBF(1),NBLK(1)),(IDVTAB(1),NBLK(58))_^1_$EQUIVALENCE (NSUMDS,NBLK(370))_^1C_#PUNCH BUFFER, ADDRESS HOLDERS, PRINT BUFFER, INDEX HISTORY TABLES_^1_$EQUIVALENCE(NPTBF,NBLK(371)),(IXS1,NBLK(426)),(IXS2,NBLK(436))_^1C_$INDEX REGISTER HOLDERS FOR SUBROUTINE IXOPT_^1_$DIMENSION NP€€CBF(57),IDVTAB(312),NPTBF(55),IXS1(10),IXS2(10)_^1C_]_^1C_#PHASE D AND E BLANK COMMON BLOCK BELOW COMPRESSED TABLE_^1_$COMMON // INBUFF(203),NOBUFF(1152),NRCD(5)_^1_$COMMON//NFTAB(160),NDSTAB(500)_^1_$COMMON//IV(5),IXS3(10)_^1_$COMMON//NSUMD,NDFL,NADX,NSUMVS,IXC,IXFLAG,IXF,IXQ_^1_$COMMON//IXSX,IUSE,IFIX,NOUTOT,NOWO,NL,NT,NA,NS,ND,NR,NQ,NF_^1_$COMMON//NTYPE,NOWI,NOPC,NOPT,NADD,NXPT_€€^1_$COMMON//NATYPE,ICT,INCT,NOCT,NSTYPE,LRS,NOBW,NBINC,NPC1_^1_$COMMON//NSETX,NRM,NPTBFX,NRC1,NRC2,NW2FL,NW2,NBFL,NXCON_^1_$COMMON//NASCI,ISCOUN,ICOUNT,NOFS,NODS,NDXJ,NX_^1C *** ADDITIONAL COMMON IS FOR CIRCULAR BUFFER POINTERS_^1_$COMMON // IHEAD,INOB,INC_^1C_]_^1_$EQUIVALENCE(IND(1),NL)_^1_$DIMENSION IND(14)_^1_$EQUIVALENCE(ICFLG,IV(2)),(ITCOUN,IV(3)),(IDECR,IV(4))_^1_$M = ICOUNT€€_^1_$IV(1)=NOPC_^1_$ISYMX = NOPC_^1_$CALL GETSYM_^1_$I = 1_^1_$NRM = 1_^1_!10 IF (I .EQ. NOFS) GO TO 50_^1_$IF(IV(1).EQ.NFTAB(I))GO TO 20_^1_$I = I+4_^1_$GO TO 10_^1C_2SET LOCATION TO BE PLUGGED_^1_!20 ICOUNT = NFTAB(I+3)_^1C_2ASSUME PROGRAM RGLOCATABEL_^1_$NRC1 = 1_^1_$NOPC = IRSA(ISYMX) + NFTAB(I+1)_^1C_2IS PLUGGED WORD RELATIVE_^1_$IF(NFTAB(I+2).LT.0)NFTAB(I+2)=-NFTAB(I+2)_^1_$I€€F(NFTAB (I+2) .GE. 9) GO TO 40_^1C_2IS PLUGGED WORD INDIRECT_^1_$IF(NFTAB(I+2) .EQ. 8) NOPC = OR(NOPC,$8000)_^1C_2IS PLUGGED WORD AN UNBIASED ADC_^1_$IF(NFTAB(I+2).EQ.5)NRC1=0_^1C_2EMPTY PUNCH BUFFER_^1_!25_#CALL UNPUNC_^1_)CALL RBPK_^1_)CALL UNPUNC_^1C_2BUMP FUTURE TABLE_^1_$IF(I+4 .EQ. NOFS) GO TO 35_^1_$K = NOFS - 5_^1_$DO 30 J = I,K_^1_!30 NFTAB(J) = NFTAB (J+4)_^1_!35 NOFS = €€NOFS - 4_^1_$NFTAB(NOFS) = 0_^1_$NFTAB(NOFS + 1) = 0_^1_$NFTAB(NOFS + 2) = 0_^1_$NFTAB(NOFS + 3) = 0_^1_$GO TO 10_^1_!40 IF(NFTAB(I+2).GT.41) GO TO 45_^1_$NOPC = IRSA(ISYMX) - ICOUNT + NFTAB(I+1)_^1_!42 NRC1 = 0_^1_$GO TO 25_^1C_2CALCULATE ADDRESS IN 15-BIT ARITHMETIC_^1_!45 J = $8000_^1_$IF(NFTAB(I+2).EQ.44)GO TO 25_^1_$IF(NFTAB(I+2).EQ.45)GO TO 42_^1_$K=NOPC_^1_$IF(K.GT.16383) K=€€OR(K,J)_^1_$NOPC = ICOUNT_^1_$IF(NOPC.GT.16383) NOPC=OR(NOPC,J)_^1_$NOPC = K-NOPC_^1_$NOPC = AND(NOPC,32767)_^1_$IF(NFTAB(I+2).EQ.43.OR.NFTAB(I+2)_".EQ.42.AND.KDUMY(ISYMX)_^1_#1 .NE.0)NOPC=OR(NOPC,J)_^1_$GO TO 42_^1_!50 ICOUNT = M_^1_$IF(LPAR.NE.0) RETURN_^1C_2IS THERE MORE THAN ONE LABEL_^1_!60 IF(NPTBF(NSETX + 24) .EQ. $20) GO TO 70_^1C_2YES_^1_$CALL NWRITE_^1_!70 NPTBFX = NSETX€€+24_^1_$IF(ICLASS(ISYMX).EQ.2) GO TO 71_^1_$CALL IACON_^1_$RETURN_^1C_#CONVERT CONSTANT TO HEX_^1_!71 CALL IHCON(ISYM(ISYMX))_^1_$J=$24_^1C ********************************** FTN 3.1 **************************_^1_$IF (ITYPE(ISYMX).NE.1) J = J + 1_^1_$IF (ITYPE(ISYMX).NE.3) GO TO 72_^1_$NPTBF(NPTBFX) = IBCDTB(J+1)_^1_$NPTBFX = NPTBFX + 1_^1_!72 NPTBF(NPTBFX) = IBCDTB(J+1)_^1C ***€R******************************* FTN 3.1 ($) **********************_^1_$END_]_^__ RPWNP2T2 CSY/ 11E P€1_$SUBROUTINE NP2OUT_^1_#*_2/DECK-ID 11E FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^13_]_^1C THIS NP2OUT IS USED IN PHASE E_^1C NON-IDENTICAL NP2OUT USED IN PHASE D_^1C*****PHASE E COMMON ALL INCLUSIVE TO END POINT_^1C_]_^1C_#MASTER LABELED COMMON BL€€OCK._^1*_] FTN 3.3_^1_$COMMON /A/ IFLAGS,LINECT,LINCT1_^1_$COMMON /A/ IR,IK,IP,IA,IL,IM,IXLGO,IOPTO,IOPTV,IOPTC,IOPTD_^1_$COMMON /A/ MCSTRT,MACRNB,MACSEC_^1_$COMMON /A/ IERRS(16),ISRFAD_^1_$COMMON /A/ LGO,ISCRI,ISCRO,IX_^1*_] FTN 3.3_^1_$COMMON /A/ IGLAB(3),IGLAB1,IGLAB2_^1_$COMMON /A/ ICOMT(12),ICOMTS,ICOMX2,ICOMTL,ISUBP,NDPRS,_^1_#$LABX,IBCDTB(48)_^1_$EQUIVALENCE(ICOMB,ICOMT(1)€€),(ICOMBX,ICOMT(2)),(ICOMDF,_^1_#$ICOMT(3)),(ICOMBN,ICOMT(4))_^1_$DIMENSION ICOMB(6),ICOMBX(6),ICOMDF(6),ICOMBN(7)_^1_$COMMON /A/ LOOPTS,LOOPTX,LOOPTB,LOOPT(50)_^1_$EQUIVALENCE(LINDUC,LOOPT(1))_^1_$DIMENSION LINDUC(10)_^1_$EQUIVALENCE (LBEG,LOOPT(2))_^1_$DIMENSION LBEG(10)_^1_$EQUIVALENCE (LINC,LOOPT(3))_^1_$DIMENSION LINC(10)_^1_$EQUIVALENCE (LEND,LOOPT(4))_^1_$DIMENSION LEND(10)_€€^1_$BYTE(LLABL,LOOPT(5)(14=0)_))_^1_$DIMENSION LLABL(10)_^1_$BYTE(LID,LOOPT(5)(15=15) )_^1_$DIMENSION LID(10)_^1_$COMMON/A/IEQV(255), IEQVS,IEQVN2_^1_$COMMON /A/ ISTAB(150),ISTABS,ISTAB2_^1_$COMMON /A/ IBUFS,ISET(25),LBLANK,KSFCNT,KSNCNT,ISORSC,_^1_#$IHOBIT,ISTNO,ISSFLG,ISUBPN,ITERM,JSORSC,KEQVS_^1C_#SYMBOL TABLE LABELED COMMON BLOCK_^1_$COMMON /A/ ISYMN, ISYMFL,ISYMD,ISYMX,ISYMS€€,ISYMP,ISYMPC,ISYMPS,_^1_#$ ISYMNS, SYMTAB(2400)_^1_$INTEGER SYMTAB_^1_$BYTE (IDUM,SYMTAB(1)(15=15)),(KDUMY,SYMTAB(1)(15=15)),_^1_#$(ICLASS,SYMTAB(1)(14=11)),(ITYPE,SYMTAB(1)(10=9))_^1_$DIMENSION IDUM(100),KDUMY(100),ICLASS(100),ITYPE(100)_^1_$BYTE (ISNGL, SYMTAB(1)(8=8)),(KELSIZ,SYMTAB(1)(8=8)),_^1_#$ (ICOM,SYMTAB(1)(7=5)),(IPART,SYMTAB(1)(4=3))_^1_$DIMENSION ISNGL(100),KELSIZ(100€€),ICOM(100),IPART(100)_^1_$BYTE (KRFCNT,SYMTAB(1)(2=2)),(IDIM,SYMTAB(1)(1=0)),_^1_#$ (IREL,SYMTAB(1)(1=1)),(IEXT,SYMTAB(1)(0=0))_^1_$DIMENSION KRFCNT(100),IDIM(100),IREL(100),IEXT(100)_^1_$EQUIVALENCE (IRSA,SYMTAB(2)),(ICOMTX,SYMTAB(2)),(ISNOL,SYMTAB(2))_^1_$DIMENSION IRSA(100), ICOMTX(100),ISNOL(100)_^1_$BYTE (IDATAS,SYMTAB(3)(15=15)),(IREF,SYMTAB(3)(15=15)),_^1_#$ (IEQVX,SYMTAB(3€€)(14=8)),(ITILF,SYMTAB(3)(14=8))_^1_$DIMENSION IDATAS(100),IREF(100),IEQVX(100),ITILF(100)_^1_$BYTE (IPARTR,SYMTAB(3)(7=4)),(INDUCV,SYMTAB(3)(7=7)),(ISFARG,_^1_#$ SYMTAB(3)(6=6)),(IARGNO,SYMTAB(3)(5=0)),(IPARTL,SYMTAB(3)(3=0))_^1_$DIMENSION IPARTR(100),INDUCV(100),ISFARG(100),IARGNO(100),_^1_#$ IPARTL(100)_^1_$EQUIVALENCE (ISYM,SYMTAB(4))_^1_$DIMENSION ISYM(100)_^1C_]_^1C_#PHASE C,€€ D, E LABELED COMMON BLOCK_^1_$EQUIVALENCE (NBLK(1),LOOPTS)_^1_$DIMENSION NBLK(446)_^1_$EQUIVALENCE (NPCBF(1),NBLK(1)),(IDVTAB(1),NBLK(58))_^1_$EQUIVALENCE (NSUMDS,NBLK(370))_^1C_#PUNCH BUFFER, ADDRESS HOLDERS, PRINT BUFFER, INDEX HISTORY TABLES_^1_$EQUIVALENCE(NPTBF,NBLK(371)),(IXS1,NBLK(426)),(IXS2,NBLK(436))_^1C_$INDEX REGISTER HOLDERS FOR SUBROUTINE IXOPT_^1_$DIMENSION NPCBF(57€€),IDVTAB(312),NPTBF(55),IXS1(10),IXS2(10)_^1C_]_^1C_#PHASE D AND E BLANK COMMON BLOCK BELOW COMPRESSED TABLE_^1_$COMMON // INBUFF(203),NOBUFF(1152),NRCD(5)_^1_$COMMON//NFTAB(160),NDSTAB(500)_^1_$COMMON//IV(5),IXS3(10)_^1_$COMMON//NSUMD,NDFL,NADX,NSUMVS,IXC,IXFLAG,IXF,IXQ_^1_$COMMON//IXSX,IUSE,IFIX,NOUTOT,NOWO,NL,NT,NA,NS,ND,NR,NQ,NF_^1_$COMMON//NTYPE,NOWI,NOPC,NOPT,NADD,NXPT_^1_$CO€€MMON//NATYPE,ICT,INCT,NOCT,NSTYPE,LRS,NOBW,NBINC,NPC1_^1_$COMMON//NSETX,NRM,NPTBFX,NRC1,NRC2,NW2FL,NW2,NBFL,NXCON_^1_$COMMON//NASCI,ISCOUN,ICOUNT,NOFS,NODS,NDXJ,NX_^1C *** ADDITIONAL COMMON IS FOR CIRCULAR BUFFER POINTERS_^1_$COMMON // IHEAD,INOB,INC_^1C_]_^1_$EQUIVALENCE(IND(1),NL)_^1_$DIMENSION IND(14)_^1_$EQUIVALENCE(ICFLG,IV(2)),(ITCOUN,IV(3)),(IDECR,IV(4))_^1_$DIMENSION MESF(5€€)_^1C_,CORE OVFL_^1_$DATA MESF(1),MESF(2),MESF(3),MESF(4)/$2043,$4F52,$4520,$4F56/_^1_$DATA MESF(5)/$464C/_^1C_2PRINT,PUNCH AND COUNT_^1C_2EITHER ONE OR TWO WORD OUTPUT_^1_"5 CALL RBPK_^1_$CALL SETPRT_^1_$I=IFIX_^1_$CALL COUNT_^1_$IF(IFIX.NE.-1.OR.IFIX.EQ.I)GO TO 22_^1C_#CALL ERROR_^1_$CALL WRITE(3,1,5,MESF)_^1_!22 IF (NW2FL .LE. 0) GO TO 10_^1_$NOPC = NW2_^1_$NRC1 = NRC2_^1_$NW2F€6L = -NW2FL_^1_$GO TO 5_^1_!10 NW2FL = 0_^1_$END_]_^__ 6PWNPUN2 CSY/ 12E P€1_$SUBROUTINE_"NPUNCH_^1_#*_2/DECK-ID 12E FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^13_]_^1C THIS NPUNCH IS USED IN PHASE E_^1C NON-IDENTICAL NPUNCH USED IN PHASE D_^1C*****PHASE E COMMON ALL INCLUSIVE TO END POINT_^1C_]_^1C_#MASTER LABELED COMMON B€€LOCK._^1*_] FTN 3.3_^1_$COMMON /A/ IFLAGS,LINECT,LINCT1_^1_$COMMON /A/ IR,IK,IP,IA,IL,IM,IXLGO,IOPTO,IOPTV,IOPTC,IOPTD_^1_$COMMON /A/ MCSTRT,MACRNB,MACSEC_^1_$COMMON /A/ IERRS(16),ISRFAD_^1_$COMMON /A/ LGO,ISCRI,ISCRO,IX_^1*_] FTN 3.3_^1_$COMMON /A/ IGLAB(3),IGLAB1,IGLAB2_^1_$COMMON /A/ ICOMT(12),ICOMTS,ICOMX2,ICOMTL,ISUBP,NDPRS,_^1_#$LABX,IBCDTB(48)_^1_$EQUIVALENCE(ICOMB,ICOMT(1€€)),(ICOMBX,ICOMT(2)),(ICOMDF,_^1_#$ICOMT(3)),(ICOMBN,ICOMT(4))_^1_$DIMENSION ICOMB(6),ICOMBX(6),ICOMDF(6),ICOMBN(7)_^1_$COMMON /A/ LOOPTS,LOOPTX,LOOPTB,LOOPT(50)_^1_$EQUIVALENCE(LINDUC,LOOPT(1))_^1_$DIMENSION LINDUC(10)_^1_$EQUIVALENCE (LBEG,LOOPT(2))_^1_$DIMENSION LBEG(10)_^1_$EQUIVALENCE (LINC,LOOPT(3))_^1_$DIMENSION LINC(10)_^1_$EQUIVALENCE (LEND,LOOPT(4))_^1_$DIMENSION LEND(10)€€_^1_$BYTE(LLABL,LOOPT(5)(14=0)_))_^1_$DIMENSION LLABL(10)_^1_$BYTE(LID,LOOPT(5)(15=15) )_^1_$DIMENSION LID(10)_^1_$COMMON/A/IEQV(255), IEQVS,IEQVN2_^1_$COMMON /A/ ISTAB(150),ISTABS,ISTAB2_^1_$COMMON /A/ IBUFS,ISET(25),LBLANK,KSFCNT,KSNCNT,ISORSC,_^1_#$IHOBIT,ISTNO,ISSFLG,ISUBPN,ITERM,JSORSC,KEQVS_^1C_#SYMBOL TABLE LABELED COMMON BLOCK_^1_$COMMON /A/ ISYMN, ISYMFL,ISYMD,ISYMX,ISYM€€S,ISYMP,ISYMPC,ISYMPS,_^1_#$ ISYMNS, SYMTAB(2400)_^1_$INTEGER SYMTAB_^1_$BYTE (IDUM,SYMTAB(1)(15=15)),(KDUMY,SYMTAB(1)(15=15)),_^1_#$(ICLASS,SYMTAB(1)(14=11)),(ITYPE,SYMTAB(1)(10=9))_^1_$DIMENSION IDUM(100),KDUMY(100),ICLASS(100),ITYPE(100)_^1_$BYTE (ISNGL, SYMTAB(1)(8=8)),(KELSIZ,SYMTAB(1)(8=8)),_^1_#$ (ICOM,SYMTAB(1)(7=5)),(IPART,SYMTAB(1)(4=3))_^1_$DIMENSION ISNGL(100),KELSIZ(10€€0),ICOM(100),IPART(100)_^1_$BYTE (KRFCNT,SYMTAB(1)(2=2)),(IDIM,SYMTAB(1)(1=0)),_^1_#$ (IREL,SYMTAB(1)(1=1)),(IEXT,SYMTAB(1)(0=0))_^1_$DIMENSION KRFCNT(100),IDIM(100),IREL(100),IEXT(100)_^1_$EQUIVALENCE (IRSA,SYMTAB(2)),(ICOMTX,SYMTAB(2)),(ISNOL,SYMTAB(2))_^1_$DIMENSION IRSA(100), ICOMTX(100),ISNOL(100)_^1_$BYTE (IDATAS,SYMTAB(3)(15=15)),(IREF,SYMTAB(3)(15=15)),_^1_#$ (IEQVX,SYMTAB(€€3)(14=8)),(ITILF,SYMTAB(3)(14=8))_^1_$DIMENSION IDATAS(100),IREF(100),IEQVX(100),ITILF(100)_^1_$BYTE (IPARTR,SYMTAB(3)(7=4)),(INDUCV,SYMTAB(3)(7=7)),(ISFARG,_^1_#$ SYMTAB(3)(6=6)),(IARGNO,SYMTAB(3)(5=0)),(IPARTL,SYMTAB(3)(3=0))_^1_$DIMENSION IPARTR(100),INDUCV(100),ISFARG(100),IARGNO(100),_^1_#$ IPARTL(100)_^1_$EQUIVALENCE (ISYM,SYMTAB(4))_^1_$DIMENSION ISYM(100)_^1C_]_^1C_#PHASE C€€, D, E LABELED COMMON BLOCK_^1_$EQUIVALENCE (NBLK(1),LOOPTS)_^1_$DIMENSION NBLK(446)_^1_$EQUIVALENCE (NPCBF(1),NBLK(1)),(IDVTAB(1),NBLK(58))_^1_$EQUIVALENCE (NSUMDS,NBLK(370))_^1C_#PUNCH BUFFER, ADDRESS HOLDERS, PRINT BUFFER, INDEX HISTORY TABLES_^1_$EQUIVALENCE(NPTBF,NBLK(371)),(IXS1,NBLK(426)),(IXS2,NBLK(436))_^1C_$INDEX REGISTER HOLDERS FOR SUBROUTINE IXOPT_^1_$DIMENSION NPCBF(5€€7),IDVTAB(312),NPTBF(55),IXS1(10),IXS2(10)_^1C_]_^1C_#PHASE D AND E BLANK COMMON BLOCK BELOW COMPRESSED TABLE_^1_$COMMON // INBUFF(203),NOBUFF(1152),NRCD(5)_^1_$COMMON//NFTAB(160),NDSTAB(500)_^1_$COMMON//IV(5),IXS3(10)_^1_$COMMON//NSUMD,NDFL,NADX,NSUMVS,IXC,IXFLAG,IXF,IXQ_^1_$COMMON//IXSX,IUSE,IFIX,NOUTOT,NOWO,NL,NT,NA,NS,ND,NR,NQ,NF_^1_$COMMON//NTYPE,NOWI,NOPC,NOPT,NADD,NXPT_^1_$C€€OMMON//NATYPE,ICT,INCT,NOCT,NSTYPE,LRS,NOBW,NBINC,NPC1_^1_$COMMON//NSETX,NRM,NPTBFX,NRC1,NRC2,NW2FL,NW2,NBFL,NXCON_^1_$COMMON//NASCI,ISCOUN,ICOUNT,NOFS,NODS,NDXJ,NX_^1C *** ADDITIONAL COMMON IS FOR CIRCULAR BUFFER POINTERS_^1_$COMMON // IHEAD,INOB,INC_^1C_]_^1_$EQUIVALENCE(IND(1),NL)_^1_$DIMENSION IND(14)_^1_$EQUIVALENCE(ICFLG,IV(2)),(ITCOUN,IV(3)),(IDECR,IV(4))_^1C LOCAL VARIABLES€€0_^1C 'STSIZE' IS NUMBER OF DISC SECTORS ALLOCATED TO SYMBOL TABLE. THIS IS_^1C_!SET IN 'IOPR'._^1C ********************************** FTN 3.0 **************************_^1C ********************************** FTN 3.0 **************************_^1_$DIMENSION IEOL(10)_^1_$INTEGER STSIZE_^1_$DATA IEOL(1),IEOL(2),IEOL(3),IEOL(4)/$2A54,$2000,$FFFF,$FFFF/_^1_%DATA IEOL(5),IEOL(6),IEOL€€(7),IEOL(8)/$FFFF,$FFFF,$FFFF,$FFFF/_^1_%DATA IEOL(9),IEOL(10)/$FFFF,$FFFF/_^1C ************************************************************_!89*2985_^1C STSIZE IS 160 FOR MSFTN 3.2B VERSION_^1_%DATA NBLOCS/0/,STSIZE/160/_^1C ************************************************************_!89*2985_^1C ********************************** FTN 3.0 **************************_^1_$DATA NQSA€€VE/0/_^1C ********************************** PSR 739 **************************_^1C ********************************** PSR 739 **************************_^1_%BYTE (ITBYTE,NQSAVE(13=11))_^1C ********************************** PSR 739 **************************_^1C_]_^1C IF NEITHER "P" NOR "X" OPTION ON, RETURN._^1_$IF (IP+IXLGO.EQ.0) RETURN_^1C ***_]_^1C *_!PHASE ONE_^1C ***_]_^€€1C_]_^1C WRITE BLOCK ON SCRATCH OUTPUT, PUTTING LOGICAL RECORD LENGTH IN_^1C_!WORD 1 OF PHYSICAL RECORD. LOGICAL RECORD LENGTH IS IN 'NBINC'_^1C_!AND EQUIVALENCE (NPCBF(0),IBCDTB(48)). INCREMENT COUNT OF BLOCKS_^1C_!WRITTEN FOR LOAD--GO FILE; IF COUNT EXCEEDS SYMBOL TABLE SIZE,_^1C_!REDUCE PACKING OF SCRATCH FILE BY FORCING 96-WORD RECORDS._^1_$I = IBCDTB(48)_^1_$IBCDTB(48) = NBI€€NC+1_^1_$NBLOCS = NBLOCS+1_^1_$IF (NBLOCS.LT.STSIZE) GO TO 002_^1_'J = IBCDTB(47)_^1_'IBCDTB(47) = 96_^1_'CALL WRITE (ISCRO,0,96,IBCDTB(47))_^1_'IBCDTB(47) = J_^1_'GO TO 003_^1 002 CALL WRITE (ISCRO,0,IBCDTB(48),IBCDTB(48))_^1 003 IBCDTB(48) = I_^1C SKIP IF "XFR" BLOCK._^1 005 IF (NPCBF(1).EQ.$C050) GO TO 020_^1C ZERO OUT PUNCH BUFFER AND RETURN._^1_$DO 010 I=1,57_^1 010_"NPC€€BF(I) = 0_^1_$RETURN_^1C ***_]_^1C *_!PHASE TWO_^1C ***_]_^1C_]_^1C AFTER "XFR" BLOCK, COPY SCRATCH FILE ONTO LOAD--GO FILE. USE BLANK_^1C_!RECORD LENGTH WILL BE IN WORD 1 OF EACH PHYSICAL RECORD._^1C FORCE OUTPUT BUFFER EMPTY._^1 020 CALL WRITE (ISCRO,-1,0,0)_^1C RESET INDEX (IN 'IOPR') OF SCRATCH FILE._^1_$CALL RESET (ISCRO,0)_^1C COPY "NAM" BLOCK, INSERTING PROGRAM LENGTH IN W€€ORD 4._^1_$CALL READ (ISCRO,0,58,INBUFF(1))_^1_$INBUFF(5) = ICOUNT_^1C SET BUFFER INDEX._^1_$I = 1_^1C LOAD BUFFER FROM SCRATCH FILE. STOP LOADING WHEN BUFFER FULL OR WHEN_^1C_!"XFR" CARD READ._^1 030 I = I+INBUFF(I)_^1 031 CALL READ (ISCRO,0,58,INBUFF(I))_^1_$IF (INBUFF(I).LE.60.AND.INBUFF(I+1).EQ.$C050 .OR._^1_#*_"INBUFF(I).GT.60.AND.INBUFF(I+2).EQ.$C050) GO TO 080_^1_$IF (I+€€INBUFF(I).LE.1992) GO TO 030_^1C BUFFER FULL, TRANSFER TO LG FILE AND/OR PUNCH DEVICE._^1_$ASSIGN 070 TO ILOC_^1 032 K = 1_^1 035_"IF (IXLGO.NE.0) IF (INBUFF(K)-60) 040,045,045_^1 050_"IF_!(IP.NE.0)_!IF (INBUFF(K)-60) 055,060,060_^1_'GO TO 065_^1 040_"CALL WRITE (12,LGO,INBUFF(K)-1,INBUFF(K+1))_^1_'LGO = LGO+1_^1_'GO TO 050_^1 045_"CALL WRITE (12,LGO,INBUFF(K+1)-1,INBUFF(K+2))€€_^1_'LGO = LGO+1_^1_'GO TO 050_^1 055_"CALL WRITE (2,0,INBUFF(K)-1,INBUFF(K+1))_^1_'GO TO 065_^1 060_"CALL WRITE (2,0,INBUFF(K+1)-1,INBUFF(K+2))_^1 065_"K = K+INBUFF(K)_^1_'IF (K.LE.I) GO TO 035_^1_$GO TO ILOC_^1C BUFFER EMPTIED, REFILL IT._^1 070 I = 1_^1_$GO TO 031_^1C "XFR" BLOCK READ. WRITE CURRENT BUFFER CONTENTS AND "EOL" BLOCK._^1 080 ASSIGN 090 TO ILOC_^1_$GO TO 032_^1C€€ ***_]_^1C *_!PHASE THREE_^1C ***_]_^1C_]_^1C WRITE "EOL" BLOCK ON LG FILE WHETHER OR NOT "X" OPTION IS ON._^1 090 CALL WRITE (12,LGO,2,IEOL)_^1_$IF (IP.EQ.0) GO TO 120_^1C IF STANDARD BINARY OUTPUT DEVICE IS A PAPER TAPE PUNCH, WRITE 40_^1C_!WORDS OF ZEROS AS A TRAILER. USE A 'WRITE' REQUEST TO PUNCH THE_^1C_!TRAILER BECAUSE 'WRITE' IN 'IOPR' WRITES FORMAT RECORDS WITH_^1C_!HEA€€DER AND TRAILER WORDS._^1C ********************************** FTN 3.0 **************************_^1_$ASSEM $54F4,$4600,$08FA,$FFFF,$4800,NQSAVE_^1C ********************************** FTN 3.0 **************************_^1C ********************************** PSR 739 **************************_^1_%IF(ITBYTE.NE.4) GO TO 110_^1C ********************************** PSR 739 ***********€€***************_^1_'DO 100 I=1,40_^1 100_$INBUFF(I) = 0_^1C ********************************** FTN 3.0 **************************_^1_$ASSEM $54F4,$4400,$0,$0,$08FA,$28,+INBUFF,$C8FB,$0101,$18FD_^1_$GO TO 120_^1C NOT PAPER TAPE - OUTPUT *T AND EOF AND BACKSPACE OVER BOTH_^1C_#** BEGIN ************** 1641*72 *********************************_^1C_#JUMP IF NOT MAGTAPE_^1C_]_^1 110€€ IF (ITBYTE.NE.1) GO TO 120_^1_$CALL WRITE(2,0,10,IEOL)_^1C_#*********************** 1641*72 *********** END *****************_^1C************************************************************3.1*79*1946_^1_$ASSEM $54F4,$5C01,$0,$0,$18FA,$2110,$C8FC,$0101,$18FD_^1C************************************************************3.1*79*1946_^1C ********************************** FTN 3.0 €**************************_^1C ********************************** FTN 3.0 **************************_^1C_]_^1C SET 'NTYPE' IN BLANK COMMON BACK TO 60, STATEMENT TYPE OF "XFR"_^1C_!BLOCK, SIGNALLING 'PHASE6' TO RETURN. RETURN TO 'AMOUNT'._^1 120 NTYPE = 60_^1_$END_]_^__PWNRIT2 CSY/ 13E P€1_$SUBROUTINE NWRITE_^1_#*_2/DECK-ID 13E FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^13_]_^1C THIS NWRITE IS USED IN PHASE E_^1C NON-IDENTICAL NWRITE USED IN PHASE D_^1C*****PHASE E COMMON ALL INCLUSIVE TO END POINT_^1C_]_^1C_#MASTER LABELED COMMON BL€€OCK._^1*_] FTN 3.3_^1_$COMMON /A/ IFLAGS,LINECT,LINCT1_^1_$COMMON /A/ IR,IK,IP,IA,IL,IM,IXLGO,IOPTO,IOPTV,IOPTC,IOPTD_^1_$COMMON /A/ MCSTRT,MACRNB,MACSEC_^1_$COMMON /A/ IERRS(16),ISRFAD_^1_$COMMON /A/ LGO,ISCRI,ISCRO,IX_^1*_] FTN 3.3_^1_$COMMON /A/ IGLAB(3),IGLAB1,IGLAB2_^1_$COMMON /A/ ICOMT(12),ICOMTS,ICOMX2,ICOMTL,ISUBP,NDPRS,_^1_#$LABX,IBCDTB(48)_^1_$EQUIVALENCE(ICOMB,ICOMT(1)€€),(ICOMBX,ICOMT(2)),(ICOMDF,_^1_#$ICOMT(3)),(ICOMBN,ICOMT(4))_^1_$DIMENSION ICOMB(6),ICOMBX(6),ICOMDF(6),ICOMBN(7)_^1_$COMMON /A/ LOOPTS,LOOPTX,LOOPTB,LOOPT(50)_^1_$EQUIVALENCE(LINDUC,LOOPT(1))_^1_$DIMENSION LINDUC(10)_^1_$EQUIVALENCE (LBEG,LOOPT(2))_^1_$DIMENSION LBEG(10)_^1_$EQUIVALENCE (LINC,LOOPT(3))_^1_$DIMENSION LINC(10)_^1_$EQUIVALENCE (LEND,LOOPT(4))_^1_$DIMENSION LEND(10)_€€^1_$BYTE(LLABL,LOOPT(5)(14=0)_))_^1_$DIMENSION LLABL(10)_^1_$BYTE(LID,LOOPT(5)(15=15) )_^1_$DIMENSION LID(10)_^1_$COMMON/A/IEQV(255), IEQVS,IEQVN2_^1_$COMMON /A/ ISTAB(150),ISTABS,ISTAB2_^1_$COMMON /A/ IBUFS,ISET(25),LBLANK,KSFCNT,KSNCNT,ISORSC,_^1_#$IHOBIT,ISTNO,ISSFLG,ISUBPN,ITERM,JSORSC,KEQVS_^1C_#SYMBOL TABLE LABELED COMMON BLOCK_^1_$COMMON /A/ ISYMN, ISYMFL,ISYMD,ISYMX,ISYMS€€,ISYMP,ISYMPC,ISYMPS,_^1_#$ ISYMNS, SYMTAB(2400)_^1_$INTEGER SYMTAB_^1_$BYTE (IDUM,SYMTAB(1)(15=15)),(KDUMY,SYMTAB(1)(15=15)),_^1_#$(ICLASS,SYMTAB(1)(14=11)),(ITYPE,SYMTAB(1)(10=9))_^1_$DIMENSION IDUM(100),KDUMY(100),ICLASS(100),ITYPE(100)_^1_$BYTE (ISNGL, SYMTAB(1)(8=8)),(KELSIZ,SYMTAB(1)(8=8)),_^1_#$ (ICOM,SYMTAB(1)(7=5)),(IPART,SYMTAB(1)(4=3))_^1_$DIMENSION ISNGL(100),KELSIZ(100€€),ICOM(100),IPART(100)_^1_$BYTE (KRFCNT,SYMTAB(1)(2=2)),(IDIM,SYMTAB(1)(1=0)),_^1_#$ (IREL,SYMTAB(1)(1=1)),(IEXT,SYMTAB(1)(0=0))_^1_$DIMENSION KRFCNT(100),IDIM(100),IREL(100),IEXT(100)_^1_$EQUIVALENCE (IRSA,SYMTAB(2)),(ICOMTX,SYMTAB(2)),(ISNOL,SYMTAB(2))_^1_$DIMENSION IRSA(100), ICOMTX(100),ISNOL(100)_^1_$BYTE (IDATAS,SYMTAB(3)(15=15)),(IREF,SYMTAB(3)(15=15)),_^1_#$ (IEQVX,SYMTAB(3€€)(14=8)),(ITILF,SYMTAB(3)(14=8))_^1_$DIMENSION IDATAS(100),IREF(100),IEQVX(100),ITILF(100)_^1_$BYTE (IPARTR,SYMTAB(3)(7=4)),(INDUCV,SYMTAB(3)(7=7)),(ISFARG,_^1_#$ SYMTAB(3)(6=6)),(IARGNO,SYMTAB(3)(5=0)),(IPARTL,SYMTAB(3)(3=0))_^1_$DIMENSION IPARTR(100),INDUCV(100),ISFARG(100),IARGNO(100),_^1_#$ IPARTL(100)_^1_$EQUIVALENCE (ISYM,SYMTAB(4))_^1_$DIMENSION ISYM(100)_^1C_]_^1C_#PHASE C,€€ D, E LABELED COMMON BLOCK_^1_$EQUIVALENCE (NBLK(1),LOOPTS)_^1_$DIMENSION NBLK(446)_^1_$EQUIVALENCE (NPCBF(1),NBLK(1)),(IDVTAB(1),NBLK(58))_^1_$EQUIVALENCE (NSUMDS,NBLK(370))_^1C_#PUNCH BUFFER, ADDRESS HOLDERS, PRINT BUFFER, INDEX HISTORY TABLES_^1_$EQUIVALENCE(NPTBF,NBLK(371)),(IXS1,NBLK(426)),(IXS2,NBLK(436))_^1C_$INDEX REGISTER HOLDERS FOR SUBROUTINE IXOPT_^1_$DIMENSION NPCBF(57€€),IDVTAB(312),NPTBF(55),IXS1(10),IXS2(10)_^1C_]_^1C_#PHASE D AND E BLANK COMMON BLOCK BELOW COMPRESSED TABLE_^1_$COMMON // INBUFF(203),NOBUFF(1152),NRCD(5)_^1_$COMMON//NFTAB(160),NDSTAB(500)_^1_$COMMON//IV(5),IXS3(10)_^1_$COMMON//NSUMD,NDFL,NADX,NSUMVS,IXC,IXFLAG,IXF,IXQ_^1_$COMMON//IXSX,IUSE,IFIX,NOUTOT,NOWO,NL,NT,NA,NS,ND,NR,NQ,NF_^1_$COMMON//NTYPE,NOWI,NOPC,NOPT,NADD,NXPT_^1_$CO€€MMON//NATYPE,ICT,INCT,NOCT,NSTYPE,LRS,NOBW,NBINC,NPC1_^1_$COMMON//NSETX,NRM,NPTBFX,NRC1,NRC2,NW2FL,NW2,NBFL,NXCON_^1_$COMMON//NASCI,ISCOUN,ICOUNT,NOFS,NODS,NDXJ,NX_^1C *** ADDITIONAL COMMON IS FOR CIRCULAR BUFFER POINTERS_^1_$COMMON // IHEAD,INOB,INC_^1C_]_^1C_]_^1_$EQUIVALENCE(IND(1),NL)_^1_$DIMENSION IND(14)_^1_$EQUIVALENCE(ICFLG,IV(2)),(ITCOUN,IV(3)),(IDECR,IV(4))_^1_$IF(IA.NE.0€R)GO TO 1_^1_$IF(IM.EQ.0 .OR. (NPTBF(6) .EQ. IBCDTB(47) .AND._^1_#1NPTBF(2) .EQ. IBCDTB(47))) GO TO 4_^1*_#ASSURE MINIMUM 3 WORD WRITE IN CASE OF MAG TAPE LIST_^1_"1 IF(NPTBFX.LT.5) NPTBFX=5_^1_$CALL PACK(NPTBF(1),NPTBFX)_^1_$CALL WRITE (3,1,(NPTBFX+1)/2,NPTBF(1))_^1_"4 DO 140 I=1,55_^1 140 NPTBF(I)=IBCDTB(47)_^1_$NPTBFX=1_^1_$END_]_^__RPWPHS62 CSY/ 14E P€1_$SUBROUTINE PHASE6_^1_#*_2/DECK-ID 14E FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^13_]_^1C THIS PHASE6 IS USED IN PHASE E_^1C NON-IDENTICAL PHASE6 USED IN PHASE D_^1C_]_^1C_#MASTER LABELED COMMON BLOCK._^1*_] FTN 3.3_^1_$COMMON /A/ IFLAGS,LINECT,L€€INCT1_^1_$COMMON /A/ IR,IK,IP,IA,IL,IM,IXLGO,IOPTO,IOPTV,IOPTC,IOPTD_^1_$COMMON /A/ MCSTRT,MACRNB,MACSEC_^1_$COMMON /A/ IERRS(16),ISRFAD_^1_$COMMON /A/ LGO,ISCRI,ISCRO,IX_^1*_] FTN 3.3_^1_$COMMON /A/ IGLAB(3),IGLAB1,IGLAB2_^1_$COMMON /A/ ICOMT(12),ICOMTS,ICOMX2,ICOMTL,ISUBP,NDPRS,_^1_#$LABX,IBCDTB(48)_^1_$EQUIVALENCE(ICOMB,ICOMT(1)),(ICOMBX,ICOMT(2)),(ICOMDF,_^1_#$ICOMT(3)),(ICOMB€€N,ICOMT(4))_^1_$DIMENSION ICOMB(6),ICOMBX(6),ICOMDF(6),ICOMBN(7)_^1_$COMMON /A/ LOOPTS,LOOPTX,LOOPTB,LOOPT(50)_^1_$EQUIVALENCE(LINDUC,LOOPT(1))_^1_$DIMENSION LINDUC(10)_^1_$EQUIVALENCE (LBEG,LOOPT(2))_^1_$DIMENSION LBEG(10)_^1_$EQUIVALENCE (LINC,LOOPT(3))_^1_$DIMENSION LINC(10)_^1_$EQUIVALENCE (LEND,LOOPT(4))_^1_$DIMENSION LEND(10)_^1_$BYTE(LLABL,LOOPT(5)(14=0)_))_^1_$DIMENSION LL€€ABL(10)_^1_$BYTE(LID,LOOPT(5)(15=15) )_^1_$DIMENSION LID(10)_^1_$COMMON/A/IEQV(255), IEQVS,IEQVN2_^1_$COMMON /A/ ISTAB(150),ISTABS,ISTAB2_^1_$COMMON /A/ IBUFS,ISET(25),LBLANK,KSFCNT,KSNCNT,ISORSC,_^1_#$IHOBIT,ISTNO,ISSFLG,ISUBPN,ITERM,JSORSC,KEQVS_^1C_#SYMBOL TABLE LABELED COMMON BLOCK_^1_$COMMON /A/ ISYMN, ISYMFL,ISYMD,ISYMX,ISYMS,ISYMP,ISYMPC,ISYMPS,_^1_#$ ISYMNS, SYMTAB(2400)_^€€1_$INTEGER SYMTAB_^1_$BYTE (IDUM,SYMTAB(1)(15=15)),(KDUMY,SYMTAB(1)(15=15)),_^1_#$(ICLASS,SYMTAB(1)(14=11)),(ITYPE,SYMTAB(1)(10=9))_^1_$DIMENSION IDUM(100),KDUMY(100),ICLASS(100),ITYPE(100)_^1_$BYTE (ISNGL, SYMTAB(1)(8=8)),(KELSIZ,SYMTAB(1)(8=8)),_^1_#$ (ICOM,SYMTAB(1)(7=5)),(IPART,SYMTAB(1)(4=3))_^1_$DIMENSION ISNGL(100),KELSIZ(100),ICOM(100),IPART(100)_^1_$BYTE (KRFCNT,SYMTAB(1)(€€2=2)),(IDIM,SYMTAB(1)(1=0)),_^1_#$ (IREL,SYMTAB(1)(1=1)),(IEXT,SYMTAB(1)(0=0))_^1_$DIMENSION KRFCNT(100),IDIM(100),IREL(100),IEXT(100)_^1_$EQUIVALENCE (IRSA,SYMTAB(2)),(ICOMTX,SYMTAB(2)),(ISNOL,SYMTAB(2))_^1_$DIMENSION IRSA(100), ICOMTX(100),ISNOL(100)_^1_$BYTE (IDATAS,SYMTAB(3)(15=15)),(IREF,SYMTAB(3)(15=15)),_^1_#$ (IEQVX,SYMTAB(3)(14=8)),(ITILF,SYMTAB(3)(14=8))_^1_$DIMENSION IDA€€TAS(100),IREF(100),IEQVX(100),ITILF(100)_^1_$BYTE (IPARTR,SYMTAB(3)(7=4)),(INDUCV,SYMTAB(3)(7=7)),(ISFARG,_^1_#$ SYMTAB(3)(6=6)),(IARGNO,SYMTAB(3)(5=0)),(IPARTL,SYMTAB(3)(3=0))_^1_$DIMENSION IPARTR(100),INDUCV(100),ISFARG(100),IARGNO(100),_^1_#$ IPARTL(100)_^1_$EQUIVALENCE (ISYM,SYMTAB(4))_^1_$DIMENSION ISYM(100)_^1C_]_^1C_#PHASE C, D, E LABELED COMMON BLOCK_^1_$EQUIVALENCE (NBLK(1€€),LOOPTS)_^1_$DIMENSION NBLK(446)_^1_$EQUIVALENCE (NPCBF(1),NBLK(1)),(IDVTAB(1),NBLK(58))_^1_$EQUIVALENCE (NSUMDS,NBLK(370))_^1C_#PUNCH BUFFER, ADDRESS HOLDERS, PRINT BUFFER, INDEX HISTORY TABLES_^1_$EQUIVALENCE(NPTBF,NBLK(371)),(IXS1,NBLK(426)),(IXS2,NBLK(436))_^1C_$INDEX REGISTER HOLDERS FOR SUBROUTINE IXOPT_^1_$DIMENSION NPCBF(57),IDVTAB(312),NPTBF(55),IXS1(10),IXS2(10)_^1C_]_^1€€C_]_^1C_#PHASE D AND E BLANK COMMON BLOCK BELOW COMPRESSED TABLE_^1_$COMMON // INBUFF(203),NOBUFF(1152),NRCD(5)_^1_$COMMON//NFTAB(160),NDSTAB(500)_^1_$COMMON//IV(5),IXS3(10)_^1_$COMMON//NSUMD,NDFL,NADX,NSUMVS,IXC,IXFLAG,IXF,IXQ_^1_$COMMON//IXSX,IUSE,IFIX,NOUTOT,NOWO,NL,NT,NA,NS,ND,NR,NQ,NF_^1_$COMMON//NTYPE,NOWI,NOPC,NOPT,NADD,NXPT_^1_$COMMON//NATYPE,ICT,INCT,NOCT,NSTYPE,LRS,NOBW,N€€BINC,NPC1_^1_$COMMON//NSETX,NRM,NPTBFX,NRC1,NRC2,NW2FL,NW2,NBFL,NXCON_^1_$COMMON//NASCI,ISCOUN,ICOUNT,NOFS,NODS,NDXJ,NX_^1C *** ADDITIONAL COMMON IS FOR CIRCULAR BUFFER POINTERS_^1_$COMMON // IHEAD,INOB,INC_^1_$EQUIVALENCE (IND(1),NL)_^1_$DIMENSION IND(14)_^1_$EQUIVALENCE (ICFLG,IV(2)),(ITCOUN,IV(3)),(IDECR,IV(4))_^1_$EQUIVALENCE (NBCT,ISCOUN),(I6,IXSX)_^1C_#SAVE ASCII NAME FOR EPT€€ + TRA_^1_$DIMENSION NAMSV(3)_^1_$EQUIVALENCE (IGLAB(1),NAMSV(1))_^1C_]_^1C *** RETAIN SIZE OF SYMTAB PAGE_^1C_#ISYMPS=ISYMPS/2_^1C *** PHASE D WITH CIRCULAR NOBUFF_^1C *** SET ICOUNT HOLDER (PROGRAM COUNTER)_^1_$ITCOUN=ICOUNT_^1C *** SET UP CIRCULAR BUFFER POINTERS_^1C *** NOCT IS POINTER TO NEXT AVAILABLE SPACE (LAST ENTRY +1)_^1_$NOCT=1_^1C *** INOB IS SIZE OF NOBUFF_^1_$INOB=11€€52_^1C *** IHEAD IS POINTER TO BEGINNING ENTRY IN BUFFER_^1_$IHEAD=1_^1C *** NOUTOT IS POINTER TO LAST ENTRY IN BUFFER_^1_$NOUTOT=0_^1_$CALL BEGINO_^1C *** READ PART OF SCRATCH PAGE INTO INBUFF_^1_!10 CALL READ (ISCRI,0,202,INBUFF(1))_^1C *** SET UP SCRATCH PAGE CLEARANCE START INDICATOR_^1_$I6=2_]_^1C *** DECREMENT BUFFER COUNT (SCRATCH SECTION)_^1_$NBCT=NBCT-1_^1C *** IS THERE RO€€OM IN CIRCULAR OUTPUT BUFFER?_^1_!15 IF (NOCT .GE. IHEAD + 1144) GO TO 50_^1C *** YES, GET NO OF WORDS IN INBUFF RECORD_^1_$NOWI=AND (INBUFF(I6),3)_^1C *** CHECK IF BUFFER INDEX TOO HIGH_^1_$IF (NOCT .LE. 30000) GO TO 24_^1_$IHEAD=INDEX(IHEAD)_^1_$NOCT=INDEX(NOCT)_^1_$NOUTOT=INDEX(NOUTOT)_^1C *** MOVE ONE INSTRUCTION RECORD TO CIRCULAR BUFFER_^1_!24 J=I6 + NOWI + 1_^1_$DO 25 I=I6€€,J_^1_$INC = INDEX (NOCT)_^1_$NOBUFF(INC)=INBUFF(I)_^1_!25 NOCT=NOCT+1_^1_$I6=J+1_^1C *** MORE RECORDS IN THIS BUFFER?_^1_$IF (I6 .LT. INBUFF(1)) GO TO 15_^1C *** NO, ANY MORE BUFFERS?_^1_$IF (NBCT .GT. 0) GO TO 10_^1_$NBCT=-1_^1_!50 NOUTOT=NOCT-1_^1C *** GO PROCESS THE OUTPUT BUFFER_^1_$CALL AMOUT_^1C *** IS THIS AN END RECORD?_^1_$IF (IHEAD .EQ. 0) GO TO 70_^1C *** NO, MOVE THE€p HEAD OF THE CIRCULAR BUFFER FILL AS NEEDED_^1C *** INCT POINTS TO LOCATION OF TOP_^1_$IHEAD=INCT_^1C *** ANY MORE INPUT?_^1_$IF (NBCT .LT. 0) GO TO 50_^1C *** YES_]_^1_$GO TO 15_^1_!70 CALL FINISH_^1C_#XFR CARD_^1_$NPCBF(1)=$C050_^1_$DO 603 I=1,3_^1_$NPCBF(I+1)=NAMSV(I)_^1_$IF(ISUBP.NE.0)NPCBF(I+1)=8224_^1 603 CONTINUE_^1_$NBINC=4_^1_$CALL NPUNCH_^1_$END_]_^__ pPWRBDX2 CSY/ 15E P€1_$SUBROUTINE RBDX_^1_#*_2/DECK-ID 15E FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^13_]_^1C THIS RBDX IS USED IN PHASE E_^1C NON-IDENTICAL RBDX USED IN PHASE D_^1C*****PHASE E COMMON ALL INCLUSIVE TO END POINT_^1C_]_^1C_#MASTER LABELED COMMON BLOCK.€€_^1*_] FTN 3.3_^1_$COMMON /A/ IFLAGS,LINECT,LINCT1_^1_$COMMON /A/ IR,IK,IP,IA,IL,IM,IXLGO,IOPTO,IOPTV,IOPTC,IOPTD_^1_$COMMON /A/ MCSTRT,MACRNB,MACSEC_^1_$COMMON /A/ IERRS(16),ISRFAD_^1_$COMMON /A/ LGO,ISCRI,ISCRO,IX_^1*_] FTN 3.3_^1_$COMMON /A/ IGLAB(3),IGLAB1,IGLAB2_^1_$COMMON /A/ ICOMT(12),ICOMTS,ICOMX2,ICOMTL,ISUBP,NDPRS,_^1_#$LABX,IBCDTB(48)_^1_$EQUIVALENCE(ICOMB,ICOMT(1)),(I€€COMBX,ICOMT(2)),(ICOMDF,_^1_#$ICOMT(3)),(ICOMBN,ICOMT(4))_^1_$DIMENSION ICOMB(6),ICOMBX(6),ICOMDF(6),ICOMBN(7)_^1_$COMMON /A/ LOOPTS,LOOPTX,LOOPTB,LOOPT(50)_^1_$EQUIVALENCE(LINDUC,LOOPT(1))_^1_$DIMENSION LINDUC(10)_^1_$EQUIVALENCE (LBEG,LOOPT(2))_^1_$DIMENSION LBEG(10)_^1_$EQUIVALENCE (LINC,LOOPT(3))_^1_$DIMENSION LINC(10)_^1_$EQUIVALENCE (LEND,LOOPT(4))_^1_$DIMENSION LEND(10)_^1_$€€BYTE(LLABL,LOOPT(5)(14=0)_))_^1_$DIMENSION LLABL(10)_^1_$BYTE(LID,LOOPT(5)(15=15) )_^1_$DIMENSION LID(10)_^1_$COMMON/A/IEQV(255), IEQVS,IEQVN2_^1_$COMMON /A/ ISTAB(150),ISTABS,ISTAB2_^1_$COMMON /A/ IBUFS,ISET(25),LBLANK,KSFCNT,KSNCNT,ISORSC,_^1_#$IHOBIT,ISTNO,ISSFLG,ISUBPN,ITERM,JSORSC,KEQVS_^1C_#SYMBOL TABLE LABELED COMMON BLOCK_^1_$COMMON /A/ ISYMN, ISYMFL,ISYMD,ISYMX,ISYMS,ISY€€MP,ISYMPC,ISYMPS,_^1_#$ ISYMNS, SYMTAB(2400)_^1_$INTEGER SYMTAB_^1_$BYTE (IDUM,SYMTAB(1)(15=15)),(KDUMY,SYMTAB(1)(15=15)),_^1_#$(ICLASS,SYMTAB(1)(14=11)),(ITYPE,SYMTAB(1)(10=9))_^1_$DIMENSION IDUM(100),KDUMY(100),ICLASS(100),ITYPE(100)_^1_$BYTE (ISNGL, SYMTAB(1)(8=8)),(KELSIZ,SYMTAB(1)(8=8)),_^1_#$ (ICOM,SYMTAB(1)(7=5)),(IPART,SYMTAB(1)(4=3))_^1_$DIMENSION ISNGL(100),KELSIZ(100),IC€€OM(100),IPART(100)_^1_$BYTE (KRFCNT,SYMTAB(1)(2=2)),(IDIM,SYMTAB(1)(1=0)),_^1_#$ (IREL,SYMTAB(1)(1=1)),(IEXT,SYMTAB(1)(0=0))_^1_$DIMENSION KRFCNT(100),IDIM(100),IREL(100),IEXT(100)_^1_$EQUIVALENCE (IRSA,SYMTAB(2)),(ICOMTX,SYMTAB(2)),(ISNOL,SYMTAB(2))_^1_$DIMENSION IRSA(100), ICOMTX(100),ISNOL(100)_^1_$BYTE (IDATAS,SYMTAB(3)(15=15)),(IREF,SYMTAB(3)(15=15)),_^1_#$ (IEQVX,SYMTAB(3)(14€€=8)),(ITILF,SYMTAB(3)(14=8))_^1_$DIMENSION IDATAS(100),IREF(100),IEQVX(100),ITILF(100)_^1_$BYTE (IPARTR,SYMTAB(3)(7=4)),(INDUCV,SYMTAB(3)(7=7)),(ISFARG,_^1_#$ SYMTAB(3)(6=6)),(IARGNO,SYMTAB(3)(5=0)),(IPARTL,SYMTAB(3)(3=0))_^1_$DIMENSION IPARTR(100),INDUCV(100),ISFARG(100),IARGNO(100),_^1_#$ IPARTL(100)_^1_$EQUIVALENCE (ISYM,SYMTAB(4))_^1_$DIMENSION ISYM(100)_^1C_]_^1C_#PHASE C, D, €€E LABELED COMMON BLOCK_^1_$EQUIVALENCE (NBLK(1),LOOPTS)_^1_$DIMENSION NBLK(446)_^1_$EQUIVALENCE (NPCBF(1),NBLK(1)),(IDVTAB(1),NBLK(58))_^1_$EQUIVALENCE (NSUMDS,NBLK(370))_^1C_#PUNCH BUFFER, ADDRESS HOLDERS, PRINT BUFFER, INDEX HISTORY TABLES_^1_$EQUIVALENCE(NPTBF,NBLK(371)),(IXS1,NBLK(426)),(IXS2,NBLK(436))_^1C_$INDEX REGISTER HOLDERS FOR SUBROUTINE IXOPT_^1_$DIMENSION NPCBF(57),ID€€VTAB(312),NPTBF(55),IXS1(10),IXS2(10)_^1C_]_^1C_#PHASE D AND E BLANK COMMON BLOCK BELOW COMPRESSED TABLE_^1_$COMMON // INBUFF(203),NOBUFF(1152),NRCD(5)_^1_$COMMON//NFTAB(160),NDSTAB(500)_^1_$COMMON//IV(5),IXS3(10)_^1_$COMMON//NSUMD,NDFL,NADX,NSUMVS,IXC,IXFLAG,IXF,IXQ_^1_$COMMON//IXSX,IUSE,IFIX,NOUTOT,NOWO,NL,NT,NA,NS,ND,NR,NQ,NF_^1_$COMMON//NTYPE,NOWI,NOPC,NOPT,NADD,NXPT_^1_$COMMON€€//NATYPE,ICT,INCT,NOCT,NSTYPE,LRS,NOBW,NBINC,NPC1_^1_$COMMON//NSETX,NRM,NPTBFX,NRC1,NRC2,NW2FL,NW2,NBFL,NXCON_^1_$COMMON//NASCI,ISCOUN,ICOUNT,NOFS,NODS,NDXJ,NX_^1C *** ADDITIONAL COMMON IS FOR CIRCULAR BUFFER POINTERS_^1_$COMMON // IHEAD,INOB,INC_^1C_]_^1_$EQUIVALENCE(IND(1),NL)_^1_$DIMENSION IND(14)_^1_$EQUIVALENCE(ICFLG,IV(2)),(ITCOUN,IV(3)),(IDECR,IV(4))_^1_$J = NOBW_^1_$K=J/4_^€ú1_$J=K*4-J_^1_$IF(J.EQ.0)J=3_^1_$J = AND (J,3)_^1_$K = K*5_^1_$NBINC = (K+5)/5 + NOBW + 2_^1_$L=NRC1_^1_$IF(NBFL .NE. 0) L = 8_^1_!25 IF (J .EQ. 0) GO TO 30_^1_$L = L * 16_^1_$J = J - 1_^1_$GO TO 25_^1_!30 NPCBF(K+2) = NPCBF(K+2) + L_^1_$END_]_^__ úPWRBPK2 CSY/ 16E P€1_$SUBROUTINE RBPK_^1_#*_2/DECK-ID 16E FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^13_]_^1C THIS RBPK IS USED IN PHASE E_^1C NON-IDENTICAL RBPK USED IN PHASE D_^1C*****PHASE E COMMON ALL INCLUSIVE TO END POINT_^1C_]_^1C_#MASTER LABELED COMMON BLOCK.€€_^1*_] FTN 3.3_^1_$COMMON /A/ IFLAGS,LINECT,LINCT1_^1_$COMMON /A/ IR,IK,IP,IA,IL,IM,IXLGO,IOPTO,IOPTV,IOPTC,IOPTD_^1_$COMMON /A/ MCSTRT,MACRNB,MACSEC_^1_$COMMON /A/ IERRS(16),ISRFAD_^1_$COMMON /A/ LGO,ISCRI,ISCRO,IX_^1*_] FTN 3.3_^1_$COMMON /A/ IGLAB(3),IGLAB1,IGLAB2_^1_$COMMON /A/ ICOMT(12),ICOMTS,ICOMX2,ICOMTL,ISUBP,NDPRS,_^1_#$LABX,IBCDTB(48)_^1_$EQUIVALENCE(ICOMB,ICOMT(1)),(I€€COMBX,ICOMT(2)),(ICOMDF,_^1_#$ICOMT(3)),(ICOMBN,ICOMT(4))_^1_$DIMENSION ICOMB(6),ICOMBX(6),ICOMDF(6),ICOMBN(7)_^1_$COMMON /A/ LOOPTS,LOOPTX,LOOPTB,LOOPT(50)_^1_$EQUIVALENCE(LINDUC,LOOPT(1))_^1_$DIMENSION LINDUC(10)_^1_$EQUIVALENCE (LBEG,LOOPT(2))_^1_$DIMENSION LBEG(10)_^1_$EQUIVALENCE (LINC,LOOPT(3))_^1_$DIMENSION LINC(10)_^1_$EQUIVALENCE (LEND,LOOPT(4))_^1_$DIMENSION LEND(10)_^1_$€€BYTE(LLABL,LOOPT(5)(14=0)_))_^1_$DIMENSION LLABL(10)_^1_$BYTE(LID,LOOPT(5)(15=15) )_^1_$DIMENSION LID(10)_^1_$COMMON/A/IEQV(255), IEQVS,IEQVN2_^1_$COMMON /A/ ISTAB(150),ISTABS,ISTAB2_^1_$COMMON /A/ IBUFS,ISET(25),LBLANK,KSFCNT,KSNCNT,ISORSC,_^1_#$IHOBIT,ISTNO,ISSFLG,ISUBPN,ITERM,JSORSC,KEQVS_^1C_#SYMBOL TABLE LABELED COMMON BLOCK_^1_$COMMON /A/ ISYMN, ISYMFL,ISYMD,ISYMX,ISYMS,ISY€€MP,ISYMPC,ISYMPS,_^1_#$ ISYMNS, SYMTAB(2400)_^1_$INTEGER SYMTAB_^1_$BYTE (IDUM,SYMTAB(1)(15=15)),(KDUMY,SYMTAB(1)(15=15)),_^1_#$(ICLASS,SYMTAB(1)(14=11)),(ITYPE,SYMTAB(1)(10=9))_^1_$DIMENSION IDUM(100),KDUMY(100),ICLASS(100),ITYPE(100)_^1_$BYTE (ISNGL, SYMTAB(1)(8=8)),(KELSIZ,SYMTAB(1)(8=8)),_^1_#$ (ICOM,SYMTAB(1)(7=5)),(IPART,SYMTAB(1)(4=3))_^1_$DIMENSION ISNGL(100),KELSIZ(100),IC€€OM(100),IPART(100)_^1_$BYTE (KRFCNT,SYMTAB(1)(2=2)),(IDIM,SYMTAB(1)(1=0)),_^1_#$ (IREL,SYMTAB(1)(1=1)),(IEXT,SYMTAB(1)(0=0))_^1_$DIMENSION KRFCNT(100),IDIM(100),IREL(100),IEXT(100)_^1_$EQUIVALENCE (IRSA,SYMTAB(2)),(ICOMTX,SYMTAB(2)),(ISNOL,SYMTAB(2))_^1_$DIMENSION IRSA(100), ICOMTX(100),ISNOL(100)_^1_$BYTE (IDATAS,SYMTAB(3)(15=15)),(IREF,SYMTAB(3)(15=15)),_^1_#$ (IEQVX,SYMTAB(3)(14€€=8)),(ITILF,SYMTAB(3)(14=8))_^1_$DIMENSION IDATAS(100),IREF(100),IEQVX(100),ITILF(100)_^1_$BYTE (IPARTR,SYMTAB(3)(7=4)),(INDUCV,SYMTAB(3)(7=7)),(ISFARG,_^1_#$ SYMTAB(3)(6=6)),(IARGNO,SYMTAB(3)(5=0)),(IPARTL,SYMTAB(3)(3=0))_^1_$DIMENSION IPARTR(100),INDUCV(100),ISFARG(100),IARGNO(100),_^1_#$ IPARTL(100)_^1_$EQUIVALENCE (ISYM,SYMTAB(4))_^1_$DIMENSION ISYM(100)_^1C_]_^1C_#PHASE C, D, €€E LABELED COMMON BLOCK_^1_$EQUIVALENCE (NBLK(1),LOOPTS)_^1_$DIMENSION NBLK(446)_^1_$EQUIVALENCE (NPCBF(1),NBLK(1)),(IDVTAB(1),NBLK(58))_^1_$EQUIVALENCE (NSUMDS,NBLK(370))_^1C_#PUNCH BUFFER, ADDRESS HOLDERS, PRINT BUFFER, INDEX HISTORY TABLES_^1_$EQUIVALENCE(NPTBF,NBLK(371)),(IXS1,NBLK(426)),(IXS2,NBLK(436))_^1C_$INDEX REGISTER HOLDERS FOR SUBROUTINE IXOPT_^1_$DIMENSION NPCBF(57),ID€€VTAB(312),NPTBF(55),IXS1(10),IXS2(10)_^1C_]_^1C_#PHASE D AND E BLANK COMMON BLOCK BELOW COMPRESSED TABLE_^1_$COMMON // INBUFF(203),NOBUFF(1152),NRCD(5)_^1_$COMMON//NFTAB(160),NDSTAB(500)_^1_$COMMON//IV(5),IXS3(10)_^1_$COMMON//NSUMD,NDFL,NADX,NSUMVS,IXC,IXFLAG,IXF,IXQ_^1_$COMMON//IXSX,IUSE,IFIX,NOUTOT,NOWO,NL,NT,NA,NS,ND,NR,NQ,NF_^1_$COMMON//NTYPE,NOWI,NOPC,NOPT,NADD,NXPT_^1_$COMMON€€//NATYPE,ICT,INCT,NOCT,NSTYPE,LRS,NOBW,NBINC,NPC1_^1_$COMMON//NSETX,NRM,NPTBFX,NRC1,NRC2,NW2FL,NW2,NBFL,NXCON_^1_$COMMON//NASCI,ISCOUN,ICOUNT,NOFS,NODS,NDXJ,NX_^1C *** ADDITIONAL COMMON IS FOR CIRCULAR BUFFER POINTERS_^1_$COMMON // IHEAD,INOB,INC_^1C_]_^1_$EQUIVALENCE(IND(1),NL)_^1_$DIMENSION IND(14)_^1_$EQUIVALENCE(ICFLG,IV(2)),(ITCOUN,IV(3)),(IDECR,IV(4))_^1C_2IS OUTPUT BUFFER EM€.PTY_^1_$IF(NOBW .NE. 0) GO TO 10_^1_$NOBW = 1_^1_$NPCBF(1) = 16464_^1C_2SET CARD TYPE,RELOCATION AND LOCATION_^1_$NPCBF(2) = NRM* 4096_^1_$NPCBF(3) = ICOUNT_^1_!10 NBFL = 0_^1_$CALL RBDX_^1_$NPCBF(NBINC) = NOPC_^1_$NOBW = NOBW + 1_^1C_2IS THE BUFFER FULL_^1_$IF(NOBW .EQ. 44) CALL UNPUNC_^1_$END_]_^__ .PWSPRT CSY/ 17E P€1_$SUBROUTINE SETPRT_^1_#*_2/DECK-ID 17E FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^13_]_^1C SETPRT IS USED IN PHASE E_^1C*****PHASE E COMMON ALL INCLUSIVE TO END POINT_^1C_]_^1C_#MASTER LABELED COMMON BLOCK._^1*_] FTN 3.3_^1_$COMMON /A/ IFLAGS,LINEC€€T,LINCT1_^1_$COMMON /A/ IR,IK,IP,IA,IL,IM,IXLGO,IOPTO,IOPTV,IOPTC,IOPTD_^1_$COMMON /A/ MCSTRT,MACRNB,MACSEC_^1_$COMMON /A/ IERRS(16),ISRFAD_^1_$COMMON /A/ LGO,ISCRI,ISCRO,IX_^1*_] FTN 3.3_^1_$COMMON /A/ IGLAB(3),IGLAB1,IGLAB2_^1_$COMMON /A/ ICOMT(12),ICOMTS,ICOMX2,ICOMTL,ISUBP,NDPRS,_^1_#$LABX,IBCDTB(48)_^1_$EQUIVALENCE(ICOMB,ICOMT(1)),(ICOMBX,ICOMT(2)),(ICOMDF,_^1_#$ICOMT(3)),(IC€€OMBN,ICOMT(4))_^1_$DIMENSION ICOMB(6),ICOMBX(6),ICOMDF(6),ICOMBN(7)_^1_$COMMON /A/ LOOPTS,LOOPTX,LOOPTB,LOOPT(50)_^1_$EQUIVALENCE(LINDUC,LOOPT(1))_^1_$DIMENSION LINDUC(10)_^1_$EQUIVALENCE (LBEG,LOOPT(2))_^1_$DIMENSION LBEG(10)_^1_$EQUIVALENCE (LINC,LOOPT(3))_^1_$DIMENSION LINC(10)_^1_$EQUIVALENCE (LEND,LOOPT(4))_^1_$DIMENSION LEND(10)_^1_$BYTE(LLABL,LOOPT(5)(14=0)_))_^1_$DIMENSION €€ LLABL(10)_^1_$BYTE(LID,LOOPT(5)(15=15) )_^1_$DIMENSION LID(10)_^1_$COMMON/A/IEQV(255), IEQVS,IEQVN2_^1_$COMMON /A/ ISTAB(150),ISTABS,ISTAB2_^1_$COMMON /A/ IBUFS,ISET(25),LBLANK,KSFCNT,KSNCNT,ISORSC,_^1_#$IHOBIT,ISTNO,ISSFLG,ISUBPN,ITERM,JSORSC,KEQVS_^1C_#SYMBOL TABLE LABELED COMMON BLOCK_^1_$COMMON /A/ ISYMN, ISYMFL,ISYMD,ISYMX,ISYMS,ISYMP,ISYMPC,ISYMPS,_^1_#$ ISYMNS, SYMTAB(2400€€)_^1_$INTEGER SYMTAB_^1_$BYTE (IDUM,SYMTAB(1)(15=15)),(KDUMY,SYMTAB(1)(15=15)),_^1_#$(ICLASS,SYMTAB(1)(14=11)),(ITYPE,SYMTAB(1)(10=9))_^1_$DIMENSION IDUM(100),KDUMY(100),ICLASS(100),ITYPE(100)_^1_$BYTE (ISNGL, SYMTAB(1)(8=8)),(KELSIZ,SYMTAB(1)(8=8)),_^1_#$ (ICOM,SYMTAB(1)(7=5)),(IPART,SYMTAB(1)(4=3))_^1_$DIMENSION ISNGL(100),KELSIZ(100),ICOM(100),IPART(100)_^1_$BYTE (KRFCNT,SYMTAB(€€1)(2=2)),(IDIM,SYMTAB(1)(1=0)),_^1_#$ (IREL,SYMTAB(1)(1=1)),(IEXT,SYMTAB(1)(0=0))_^1_$DIMENSION KRFCNT(100),IDIM(100),IREL(100),IEXT(100)_^1_$EQUIVALENCE (IRSA,SYMTAB(2)),(ICOMTX,SYMTAB(2)),(ISNOL,SYMTAB(2))_^1_$DIMENSION IRSA(100), ICOMTX(100),ISNOL(100)_^1_$BYTE (IDATAS,SYMTAB(3)(15=15)),(IREF,SYMTAB(3)(15=15)),_^1_#$ (IEQVX,SYMTAB(3)(14=8)),(ITILF,SYMTAB(3)(14=8))_^1_$DIMENSION €€IDATAS(100),IREF(100),IEQVX(100),ITILF(100)_^1_$BYTE (IPARTR,SYMTAB(3)(7=4)),(INDUCV,SYMTAB(3)(7=7)),(ISFARG,_^1_#$ SYMTAB(3)(6=6)),(IARGNO,SYMTAB(3)(5=0)),(IPARTL,SYMTAB(3)(3=0))_^1_$DIMENSION IPARTR(100),INDUCV(100),ISFARG(100),IARGNO(100),_^1_#$ IPARTL(100)_^1_$EQUIVALENCE (ISYM,SYMTAB(4))_^1_$DIMENSION ISYM(100)_^1C_]_^1C_#PHASE C, D, E LABELED COMMON BLOCK_^1_$EQUIVALENCE (NBL€€K(1),LOOPTS)_^1_$DIMENSION NBLK(446)_^1_$EQUIVALENCE (NPCBF(1),NBLK(1)),(IDVTAB(1),NBLK(58))_^1_$EQUIVALENCE (NSUMDS,NBLK(370))_^1C_#PUNCH BUFFER, ADDRESS HOLDERS, PRINT BUFFER, INDEX HISTORY TABLES_^1_$EQUIVALENCE(NPTBF,NBLK(371)),(IXS1,NBLK(426)),(IXS2,NBLK(436))_^1C_$INDEX REGISTER HOLDERS FOR SUBROUTINE IXOPT_^1_$DIMENSION NPCBF(57),IDVTAB(312),NPTBF(55),IXS1(10),IXS2(10)_^1C_]€€_^1C_#PHASE D AND E BLANK COMMON BLOCK BELOW COMPRESSED TABLE_^1_$COMMON // INBUFF(203),NOBUFF(1152),NRCD(5)_^1_$COMMON//NFTAB(160),NDSTAB(500)_^1_$COMMON//IV(5),IXS3(10)_^1_$COMMON//NSUMD,NDFL,NADX,NSUMVS,IXC,IXFLAG,IXF,IXQ_^1_$COMMON//IXSX,IUSE,IFIX,NOUTOT,NOWO,NL,NT,NA,NS,ND,NR,NQ,NF_^1_$COMMON//NTYPE,NOWI,NOPC,NOPT,NADD,NXPT_^1_$COMMON//NATYPE,ICT,INCT,NOCT,NSTYPE,LRS,NOBW,NBIN€€C,NPC1_^1_$COMMON//NSETX,NRM,NPTBFX,NRC1,NRC2,NW2FL,NW2,NBFL,NXCON_^1_$COMMON//NASCI,ISCOUN,ICOUNT,NOFS,NODS,NDXJ,NX_^1C *** ADDITIONAL COMMON IS FOR CIRCULAR BUFFER POINTERS_^1_$COMMON // IHEAD,INOB,INC_^1C_]_^1_$EQUIVALENCE(IND(1),NL)_^1_$DIMENSION IND(14)_^1_$EQUIVALENCE(ICFLG,IV(2)),(ITCOUN,IV(3)),(IDECR,IV(4))_^1C_#OPCODE TABLE_^1C_#OPCODE TABLE- THE OPCODES ARE CODED 5 BITS P€€ER LETTER,0-25=A-Z,_^1C_2WITH 1ST LETTER IN BITS 4-0, 2ND IN 9-5,_^1C_23RD IN 14-10_^1_$DIMENSION NOPTAB(49),NTERM(11),NRLTAB(4)_^1C_GJMP_!MUI DVI_^1_$DATA NOPTAB(1),NOPTAB(2),NOPTAB(3)/15753,8844,8867/_^1C_GSTQ_!RTJ STA_^1_$DATA NOPTAB(4),NOPTAB(5),NOPTAB(6)/17010,9841,626/_^1C_G0 ADD SUB_^1_$DATA NOPTAB(7),NOPTAB(8),NOPTAB(9)/0,3168,1682/_^1C_JAND EOR_!LDA_^1_$DATA NOPTAB(10)€€,NOPTAB(11),NOPTAB(12)/3488,17860,107/_^1C_JRAO_!LDQ_!ADQ_^1_$DATA NOPTAB(13),NOPTAB(14),NOPTAB(15)/14353,16491,16480/_^1C_JINA ENA_^1_$DATA NOPTAB(16),NOPTAB(17),NOPTAB(18)/424,420,0/_^1C_JENQ_!INQ_!QRS_^1_$DATA NOPTAB(19),NOPTAB(20),NOPTAB(21)/16804,16808,18992/_^1C_JARS_!LRS_^1_$DATA NOPTAB(22),NOPTAB(23),NOPTAB(24)/18976,18987,0/_^1C_JQLS_!ALS_!LLS_^1_$DATA NOPTAB(25),NOPTAB(26€€),NOPTAB(27)/18800,18784,18795/_^1C_JSAZ_!SAN_!SAP_^1_$DATA NOPTAB(28),NOPTAB(29),NOPTAB(30)/25618,13330,15378/_^1C_JSAM_!SQZ_!SQN_^1_$DATA NOPTAB(31),NOPTAB(32),NOPTAB(33)/12306,26130,13842/_^1C_JSQP_!SQM_!TRA_^1_$DATA NOPTAB(34),NOPTAB(35),NOPTAB(36)/15890,12818,563/_^1C_JAAQ_#TCQ_^1_$DATA NOPTAB(37),NOPTAB(38),NOPTAB(39)/16384,0,16467/_^1C_JTCA NAM QRG_^1_$DATA NOPTAB(40),NOPTA€€B(41),NOPTAB(42)/83,12301,6702/_^1C_JBSS_"ADC CON_^1*_] FTN 3.3_^1_$DATA (NOPTAB(I),I=43,45)/19009,2144,12941/_^1*_] FTN 3.3_^1C_KEND COM_!DAT_^1_$DATA NOPTAB(46),NOPTAB(47),NOPTAB(48)/3492,$31C2,$4C03/_^1C_5CAQ_^1_$DATA NOPTAB(49)/$4002/_^1_$DATA NTERM(1),NTERM(2),NTERM(3),NTERM(4)/$2D,$2D,$2A,$2A/_^1_$DATA NTERM(5),NTERM(6),NTERM(7),N TERM(8)/$20,$20,$2B,$2B/_^1_$DATA NTERM(9€€),NTERM(10),NTERM(11)/$20,$20,$2C/_^1_$DATA NRLTAB(1),NRLTAB(2),NRLTAB(3),NRLTAB(4)/$20,$50,$43,$44/_^1_$IJX=0_^1_$NPTBFX=NSETX+9_^1_$CALL IHCON(ICOUNT)_^1_$NPTBFX=NSETX+15_^1_$CALL IHCON(NOPC)_^1C_2INSERT RELOCATION_^1_!50 NPTBF(NSETX+20) = NRLTAB(NRC1+1)_^1C_2INSERT OP CODE_^1_$IF (NW2FL .LT. 0) GO TO 51_^1_$DO 54 I=1,3_^1_$J=NOPTAB(NATYPE)_^1_$IF(I.EQ.2)J=J/32_^1_$IF(I.EQ.3)J=J/€€1024_^1_$J=AND(J,31)_^1_$K=NSETX+31+I_^1_!54 NPTBF(K)=IBCDTB(J+11)_^1C_#PUT IN OPCODE TERMINATOR_^1_$IF(NTYPE.LT.9)NPTBF(NSETX+35)=NTERM(NTYPE)_^1C_2SET UP ADDRESS FIELD_^1_!51 NPTBFX=NSETX+38_^1_$IF(NASCI.EQ.0.AND.NXCON.EQ.0)GO TO 65_^1_$IF(NTYPE.GT.10) GO TO 55_^1_$IJX= AND( NOPC,1024)_^1_$IF(NTYPE.EQ.7)IJX=0_^1_$IF(IJX.EQ.0)GO TO 55_^1_$NPTBF(NPTBFX)=IBCDTB(42)_^1_$NPTBFX=NPTBF€€X+1_^1_!55 IF(NASCI.EQ.0) GO TO 60_^1_$ISYMX = NASCI_^1C_#CONSTANT_^1_$IF(ICLASS(ISYMX).EQ.2)GO TO 52_^1_$CALL IACON_^1_$GO TO 90_^1_!52 CALL IHCON(ISYM(ISYMX))_^1_$J=$24_^1C ********************************** FTN 3.1 **************************_^1_$IF (ITYPE(ISYMX).NE.1) J = J + 1_^1_$NPTBF(NPTBFX) = IBCDTB(J+1)_^1_$IF (ITYPE(ISYMX).NE.3) GO TO 56_^1_$NPTBFX = NPTBFX + 1_^1_$NPT€€BF(NPTBFX) = IBCDTB(J+1)_^1C ********************************** FTN 3.1 ($) **********************_^1_!56 IF(IJX.EQ.0) GO TO 130_^1_$NPTBFX=NPTBFX+1_^1_$J=43_]_^1_$GO TO 131_^1_!60 IF(NTYPE.LT.30.OR.NTYPE.GE.35)GO TO 65_^1C_2THIS IS AN INTER REGISTER COMMAND_^1_$J=NXCON_^1_$GO TO 131_^1_!70 NPTBF(NPTBFX) = IBCDTB(37)_^1_$NPTBFX = NPTBFX+1_^1_$CALL IHCON(NXCON)_^1_$GO TO 90_^1C_2IS€€ THIS A CONSTANT RECORD_^1_!65 IF(NW2FL .LT.0) GO TO 130_^1_$IF(NATYPE.LT.16)GO TO 70_^1_$CALL CONV(NXCON,NPTBF(NPTBFX))_^1_$NPTBFX = NPTBFX+6_^1C_2IS RECORD CLASS 1 OR 2_^1_!90 IF(NATYPE .LT. 16)GO TO 92_^1C_2IS THIS AN ORG RECORD_^1_$IF(NATYPE.NE.42.AND.NATYPE.NE.44)GO TO 56_^1C_2IS THERE AN ADDITIVE_^1_!92 IF(NA.EQ.0.OR.NADD.EQ.0)GO TO 100_^1_$IF (NADD .LT. 0) GO TO 95_^1_$NPTB€€F(NPTBFX) = NTERM(7)_^1_$NPTBFX = NPTBFX+1_^1_!95 CALL CONV(NADD,NPTBF(NPTBFX))_^1_$NPTBFX= NPTBFX+6_^1C_2INSERT INDEX IF PRESENT_^1 100 IF(IJX.EQ.0.OR.NTYPE.EQ.7)GO TO 101_^1_$NPTBF(NPTBFX)=IBCDTB(43)_^1_$NPTBFX=NPTBFX+1_^1 101 J=AND(NOPC,768)_^1_$IF(NATYPE.GE.16)GO TO 130_^1_$IF(J .EQ. 0) GO TO 130_^1_$NPTBF(NPTBFX) = NTERM(11)_^1_$NPTBFX = NPTBFX+1_^1C_#I_]_^1_$IF(J.EQ.256)J=€Š19_^1_$IF(J.EQ.512)J=27_^1_$IF(J.EQ.768)J=12_^1 131 NPTBF(NPTBFX)=IBCDTB(J)_^1 130 CALL NWRITE_^1_$NASCI = 0_^1_$NXCON = 0_^1_$END_]_^__ŠPWDEC2 CSY/ 18E P€1_$SUBROUTINE TABDEC_^1_#*_2/DECK-ID 18E FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^13_]_^1C THIS TABDEC IS USED IN PHASE E_^1C NON-IDENTICAL TABDEC USED IN PHASE D_^1C*****PHASE E COMMON ALL INCLUSIVE TO END POINT_^1C_]_^1C_#MASTER LABELED COMMON BL€€OCK._^1*_] FTN 3.3_^1_$COMMON /A/ IFLAGS,LINECT,LINCT1_^1_$COMMON /A/ IR,IK,IP,IA,IL,IM,IXLGO,IOPTO,IOPTV,IOPTC,IOPTD_^1_$COMMON /A/ MCSTRT,MACRNB,MACSEC_^1_$COMMON /A/ IERRS(16),ISRFAD_^1_$COMMON /A/ LGO,ISCRI,ISCRO,IX_^1*_] FTN 3.3_^1_$COMMON /A/ IGLAB(3),IGLAB1,IGLAB2_^1_$COMMON /A/ ICOMT(12),ICOMTS,ICOMX2,ICOMTL,ISUBP,NDPRS,_^1_#$LABX,IBCDTB(48)_^1_$EQUIVALENCE(ICOMB,ICOMT(1)€€),(ICOMBX,ICOMT(2)),(ICOMDF,_^1_#$ICOMT(3)),(ICOMBN,ICOMT(4))_^1_$DIMENSION ICOMB(6),ICOMBX(6),ICOMDF(6),ICOMBN(7)_^1_$COMMON /A/ LOOPTS,LOOPTX,LOOPTB,LOOPT(50)_^1_$EQUIVALENCE(LINDUC,LOOPT(1))_^1_$DIMENSION LINDUC(10)_^1_$EQUIVALENCE (LBEG,LOOPT(2))_^1_$DIMENSION LBEG(10)_^1_$EQUIVALENCE (LINC,LOOPT(3))_^1_$DIMENSION LINC(10)_^1_$EQUIVALENCE (LEND,LOOPT(4))_^1_$DIMENSION LEND(10)_€€^1_$BYTE(LLABL,LOOPT(5)(14=0)_))_^1_$DIMENSION LLABL(10)_^1_$BYTE(LID,LOOPT(5)(15=15) )_^1_$DIMENSION LID(10)_^1_$COMMON/A/IEQV(255), IEQVS,IEQVN2_^1_$COMMON /A/ ISTAB(150),ISTABS,ISTAB2_^1_$COMMON /A/ IBUFS,ISET(25),LBLANK,KSFCNT,KSNCNT,ISORSC,_^1_#$IHOBIT,ISTNO,ISSFLG,ISUBPN,ITERM,JSORSC,KEQVS_^1C_#SYMBOL TABLE LABELED COMMON BLOCK_^1_$COMMON /A/ ISYMN, ISYMFL,ISYMD,ISYMX,ISYMS€€,ISYMP,ISYMPC,ISYMPS,_^1_#$ ISYMNS, SYMTAB(2400)_^1_$INTEGER SYMTAB_^1_$BYTE (IDUM,SYMTAB(1)(15=15)),(KDUMY,SYMTAB(1)(15=15)),_^1_#$(ICLASS,SYMTAB(1)(14=11)),(ITYPE,SYMTAB(1)(10=9))_^1_$DIMENSION IDUM(100),KDUMY(100),ICLASS(100),ITYPE(100)_^1_$BYTE (ISNGL, SYMTAB(1)(8=8)),(KELSIZ,SYMTAB(1)(8=8)),_^1_#$ (ICOM,SYMTAB(1)(7=5)),(IPART,SYMTAB(1)(4=3))_^1_$DIMENSION ISNGL(100),KELSIZ(100€€),ICOM(100),IPART(100)_^1_$BYTE (KRFCNT,SYMTAB(1)(2=2)),(IDIM,SYMTAB(1)(1=0)),_^1_#$ (IREL,SYMTAB(1)(1=1)),(IEXT,SYMTAB(1)(0=0))_^1_$DIMENSION KRFCNT(100),IDIM(100),IREL(100),IEXT(100)_^1_$EQUIVALENCE (IRSA,SYMTAB(2)),(ICOMTX,SYMTAB(2)),(ISNOL,SYMTAB(2))_^1_$DIMENSION IRSA(100), ICOMTX(100),ISNOL(100)_^1_$BYTE (IDATAS,SYMTAB(3)(15=15)),(IREF,SYMTAB(3)(15=15)),_^1_#$ (IEQVX,SYMTAB(3€€)(14=8)),(ITILF,SYMTAB(3)(14=8))_^1_$DIMENSION IDATAS(100),IREF(100),IEQVX(100),ITILF(100)_^1_$BYTE (IPARTR,SYMTAB(3)(7=4)),(INDUCV,SYMTAB(3)(7=7)),(ISFARG,_^1_#$ SYMTAB(3)(6=6)),(IARGNO,SYMTAB(3)(5=0)),(IPARTL,SYMTAB(3)(3=0))_^1_$DIMENSION IPARTR(100),INDUCV(100),ISFARG(100),IARGNO(100),_^1_#$ IPARTL(100)_^1_$EQUIVALENCE (ISYM,SYMTAB(4))_^1_$DIMENSION ISYM(100)_^1C_]_^1C_#PHASE C,€€ D, E LABELED COMMON BLOCK_^1_$EQUIVALENCE (NBLK(1),LOOPTS)_^1_$DIMENSION NBLK(446)_^1_$EQUIVALENCE (NPCBF(1),NBLK(1)),(IDVTAB(1),NBLK(58))_^1_$EQUIVALENCE (NSUMDS,NBLK(370))_^1C_#PUNCH BUFFER, ADDRESS HOLDERS, PRINT BUFFER, INDEX HISTORY TABLES_^1_$EQUIVALENCE(NPTBF,NBLK(371)),(IXS1,NBLK(426)),(IXS2,NBLK(436))_^1C_$INDEX REGISTER HOLDERS FOR SUBROUTINE IXOPT_^1_$DIMENSION NPCBF(57€€),IDVTAB(312),NPTBF(55),IXS1(10),IXS2(10)_^1C_]_^1C_#PHASE D AND E BLANK COMMON BLOCK BELOW COMPRESSED TABLE_^1_$COMMON // INBUFF(203),NOBUFF(1152),NRCD(5)_^1_$COMMON//NFTAB(160),NDSTAB(500)_^1_$COMMON//IV(5),IXS3(10)_^1_$COMMON//NSUMD,NDFL,NADX,NSUMVS,IXC,IXFLAG,IXF,IXQ_^1_$COMMON//IXSX,IUSE,IFIX,NOUTOT,NOWO,NL,NT,NA,NS,ND,NR,NQ,NF_^1_$COMMON//NTYPE,NOWI,NOPC,NOPT,NADD,NXPT_^1_$CO€€MMON//NATYPE,ICT,INCT,NOCT,NSTYPE,LRS,NOBW,NBINC,NPC1_^1_$COMMON//NSETX,NRM,NPTBFX,NRC1,NRC2,NW2FL,NW2,NBFL,NXCON_^1_$COMMON//NASCI,ISCOUN,ICOUNT,NOFS,NODS,NDXJ,NX_^1C *** ADDITIONAL COMMON IS FOR CIRCULAR BUFFER POINTERS_^1_$COMMON // IHEAD,INOB,INC_^1C_]_^1_$EQUIVALENCE(IND(1),NL)_^1_$DIMENSION IND(14)_^1_$EQUIVALENCE(ICFLG,IV(2)),(ITCOUN,IV(3)),(IDECR,IV(4))_^1 6276 ISYMX=0_^1_$€€ISYMP=0_^1 6270 CALL SYMSCN_^1_$IF(ISYMP.EQ.1) GO TO 6271_^1_$IF(ICLASS(ISYMX).EQ.1.AND.ICOM(ISYMX).NE.0) GO TO 6270_^1_$IF(IRSA(ISYMX).LT.32765.AND.IRSA(ISYMX).GT.ICOUNT) IRSA(ISYMX)=_^1_#1 IRSA(ISYMX)-IDECR_^1_$GO TO 6270_^1 6271 DO 6272 I=1,NADX,2_^1_$IF(IDVTAB(I).GT.ICOUNT.AND.IDVTAB(I).LT.ITCOUN)_^1_#1 IDVTAB(I)=IDVTAB(I)-IDECR_^1_$IF(IDVTAB(I+1).LT.0)GO TO 6273_^1_$IF(IDVTA€B(I+1).GT.ICOUNT)IDVTAB(I+1)=IDVTAB(I+1)-IDECR_^1_$GO TO 6272_^1 6273 IF(IDVTAB(I+1).LT.(-ICOUNT)) IDVTAB(I+1)=IDVTAB(I+1)+IDECR_^1 6272 CONTINUE_^1_$DO 6274 I=1,NODS ,2_^1_$IF(NDSTAB(I+1).GT.ICOUNT)NDSTAB(I+1)=NDSTAB(I+1)-IDECR_^1 6274 CONTINUE_^1_$ITCOUN=ITCOUN-IDECR_^1_$END_]_^__ PWUNPC2 CSY/ 19E P€1_$SUBROUTINE UNPUNC_^1_#*_2/DECK-ID 19E FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^13_]_^1C THIS UNPUNC IS USED IN PHASE E_^1C NON-IDENTICAL UNPUNC USED IN PHASE D_^1C*****PHASE E COMMON ALL INCLUSIVE TO END POINT_^1C_]_^1C_#MASTER LABELED COMMON BL€€OCK._^1*_] FTN 3.3_^1_$COMMON /A/ IFLAGS,LINECT,LINCT1_^1_$COMMON /A/ IR,IK,IP,IA,IL,IM,IXLGO,IOPTO,IOPTV,IOPTC,IOPTD_^1_$COMMON /A/ MCSTRT,MACRNB,MACSEC_^1_$COMMON /A/ IERRS(16),ISRFAD_^1_$COMMON /A/ LGO,ISCRI,ISCRO,IX_^1*_] FTN 3.3_^1_$COMMON /A/ IGLAB(3),IGLAB1,IGLAB2_^1_$COMMON /A/ ICOMT(12),ICOMTS,ICOMX2,ICOMTL,ISUBP,NDPRS,_^1_#$LABX,IBCDTB(48)_^1_$EQUIVALENCE(ICOMB,ICOMT(1)€€),(ICOMBX,ICOMT(2)),(ICOMDF,_^1_#$ICOMT(3)),(ICOMBN,ICOMT(4))_^1_$DIMENSION ICOMB(6),ICOMBX(6),ICOMDF(6),ICOMBN(7)_^1_$COMMON /A/ LOOPTS,LOOPTX,LOOPTB,LOOPT(50)_^1_$EQUIVALENCE(LINDUC,LOOPT(1))_^1_$DIMENSION LINDUC(10)_^1_$EQUIVALENCE (LBEG,LOOPT(2))_^1_$DIMENSION LBEG(10)_^1_$EQUIVALENCE (LINC,LOOPT(3))_^1_$DIMENSION LINC(10)_^1_$EQUIVALENCE (LEND,LOOPT(4))_^1_$DIMENSION LEND(10)_€€^1_$BYTE(LLABL,LOOPT(5)(14=0)_))_^1_$DIMENSION LLABL(10)_^1_$BYTE(LID,LOOPT(5)(15=15) )_^1_$DIMENSION LID(10)_^1_$COMMON/A/IEQV(255), IEQVS,IEQVN2_^1_$COMMON /A/ ISTAB(150),ISTABS,ISTAB2_^1_$COMMON /A/ IBUFS,ISET(25),LBLANK,KSFCNT,KSNCNT,ISORSC,_^1_#$IHOBIT,ISTNO,ISSFLG,ISUBPN,ITERM,JSORSC,KEQVS_^1C_#SYMBOL TABLE LABELED COMMON BLOCK_^1_$COMMON /A/ ISYMN, ISYMFL,ISYMD,ISYMX,ISYMS€€,ISYMP,ISYMPC,ISYMPS,_^1_#$ ISYMNS, SYMTAB(2400)_^1_$INTEGER SYMTAB_^1_$BYTE (IDUM,SYMTAB(1)(15=15)),(KDUMY,SYMTAB(1)(15=15)),_^1_#$(ICLASS,SYMTAB(1)(14=11)),(ITYPE,SYMTAB(1)(10=9))_^1_$DIMENSION IDUM(100),KDUMY(100),ICLASS(100),ITYPE(100)_^1_$BYTE (ISNGL, SYMTAB(1)(8=8)),(KELSIZ,SYMTAB(1)(8=8)),_^1_#$ (ICOM,SYMTAB(1)(7=5)),(IPART,SYMTAB(1)(4=3))_^1_$DIMENSION ISNGL(100),KELSIZ(100€€),ICOM(100),IPART(100)_^1_$BYTE (KRFCNT,SYMTAB(1)(2=2)),(IDIM,SYMTAB(1)(1=0)),_^1_#$ (IREL,SYMTAB(1)(1=1)),(IEXT,SYMTAB(1)(0=0))_^1_$DIMENSION KRFCNT(100),IDIM(100),IREL(100),IEXT(100)_^1_$EQUIVALENCE (IRSA,SYMTAB(2)),(ICOMTX,SYMTAB(2)),(ISNOL,SYMTAB(2))_^1_$DIMENSION IRSA(100), ICOMTX(100),ISNOL(100)_^1_$BYTE (IDATAS,SYMTAB(3)(15=15)),(IREF,SYMTAB(3)(15=15)),_^1_#$ (IEQVX,SYMTAB(3€€)(14=8)),(ITILF,SYMTAB(3)(14=8))_^1_$DIMENSION IDATAS(100),IREF(100),IEQVX(100),ITILF(100)_^1_$BYTE (IPARTR,SYMTAB(3)(7=4)),(INDUCV,SYMTAB(3)(7=7)),(ISFARG,_^1_#$ SYMTAB(3)(6=6)),(IARGNO,SYMTAB(3)(5=0)),(IPARTL,SYMTAB(3)(3=0))_^1_$DIMENSION IPARTR(100),INDUCV(100),ISFARG(100),IARGNO(100),_^1_#$ IPARTL(100)_^1_$EQUIVALENCE (ISYM,SYMTAB(4))_^1_$DIMENSION ISYM(100)_^1C_]_^1C_#PHASE C,€€ D, E LABELED COMMON BLOCK_^1_$EQUIVALENCE (NBLK(1),LOOPTS)_^1_$DIMENSION NBLK(446)_^1_$EQUIVALENCE (NPCBF(1),NBLK(1)),(IDVTAB(1),NBLK(58))_^1_$EQUIVALENCE (NSUMDS,NBLK(370))_^1C_#PUNCH BUFFER, ADDRESS HOLDERS, PRINT BUFFER, INDEX HISTORY TABLES_^1_$EQUIVALENCE(NPTBF,NBLK(371)),(IXS1,NBLK(426)),(IXS2,NBLK(436))_^1C_$INDEX REGISTER HOLDERS FOR SUBROUTINE IXOPT_^1_$DIMENSION NPCBF(57€€),IDVTAB(312),NPTBF(55),IXS1(10),IXS2(10)_^1C_]_^1C_#PHASE D AND E BLANK COMMON BLOCK BELOW COMPRESSED TABLE_^1_$COMMON // INBUFF(203),NOBUFF(1152),NRCD(5)_^1_$COMMON//NFTAB(160),NDSTAB(500)_^1_$COMMON//IV(5),IXS3(10)_^1_$COMMON//NSUMD,NDFL,NADX,NSUMVS,IXC,IXFLAG,IXF,IXQ_^1_$COMMON//IXSX,IUSE,IFIX,NOUTOT,NOWO,NL,NT,NA,NS,ND,NR,NQ,NF_^1_$COMMON//NTYPE,NOWI,NOPC,NOPT,NADD,NXPT_^1_$CO€€MMON//NATYPE,ICT,INCT,NOCT,NSTYPE,LRS,NOBW,NBINC,NPC1_^1_$COMMON//NSETX,NRM,NPTBFX,NRC1,NRC2,NW2FL,NW2,NBFL,NXCON_^1_$COMMON//NASCI,ISCOUN,ICOUNT,NOFS,NODS,NDXJ,NX_^1C *** ADDITIONAL COMMON IS FOR CIRCULAR BUFFER POINTERS_^1_$COMMON // IHEAD,INOB,INC_^1C_]_^1_$EQUIVALENCE(IND(1),NL)_^1_$DIMENSION IND(14)_^1_$EQUIVALENCE(ICFLG,IV(2)),(ITCOUN,IV(3)),(IDECR,IV(4))_^1_$IF(NOBW .EQ. 0) €`RETURN_^1_$NOBW = NOBW - 1_^1_$NBFL = 1_^1_$CALL RBDX_^1_$CALL NPUNCH_^1_$NOBW = 0_^1_$END_]_^__`PMON CSY/ P1 MON_]_^__ PWFTNB CSY/ 01F P€1_%NAM FTN33B_'DECK-ID 01F FORTRAN 3.3B_)SUMMARY-102_^1*_8COPYRIGHT CONTROL DATA CORPORATION 1973_^1*_8DECK-ID 01F FORTRAN 3.3B_^1*_8FTN IS USED IN PHASES A,B,C,D,E_^1*_8FTN IS ALSO THE DRIVER FOR THE COMPILER_^1*_8ADDITIONAL RETURN (FROM 'GOC') ALLOWED_^1_%ENT FTN_^1_%ENT EXITF_^1_%ENT PAGCHK_^1_%ENT ASCOPT_^1_%ENT PRGNAM_^1_%ENT PAGNBR_^1_%ENT DATE_^1_%ENT TIME_^1_%SPC€€ 2_^1_%EQU NBPHAS(5)_KFTN 3.3_^1_%SPC 2_^1FTN_"LDQ* PHASE_(GET PHASE COUNT_^1_%LDA* CALL+1_^1_%SAZ FTNY_)BYPASS ERROR CHECK ON INITIAL ENTRY_^1_%RTJ* CHKERR_'CHECK FOR ERRORS DURING A PREVIOUS_^1*_8PASS. IF YES CALL FORTER_^1FTNY_!LDA* COMNSZ,Q_$SET GTFILE W1 TO LENGTH OF_^1_%STA* WD1_)FTN +1 +SIZE OF LABELLED COMN_^1_%ADD =XFTN-1_"SET GTFILE START ADR BY ADDING_^1_%STA* S_+RE€€LOCATION TO 1ST WORD NR._^1_%CLR A_)CLEAR_^1_%STA* GET+7_(SET W2 WORD TO ZERO_177*1895_^1_%STA* SEC_)SECTOR ADDRESSES_^1_%STA* SEC+1_'IN 'GTFILE' REQUEST._^1GET_"GTFILE 0,NAME-GET-1,,,,,,,1 READ FILE 'FORTA1'_'**FTN 3.0**_^1_%EQU THR(GET+3)_^1_%EQU WD1(GET+5)_^1_%EQU S(GET+6)_^1_%BSS SEC(2)_^1_%LDA* THR_^1_%SAZ 1_^1_%JMP* *-2_^1_%LDA* S_^1_%ADD* DELTA,Q_^1_%STA* CALL+1_^1CALL€€_!RTJ+ 0_^1_%JMP* RESET_^1_%JMP* NORM_^1_%JMP* SKIPIT_^1_%LDA* EXITFL_'RETURN HERE FROM ERROR MODULE_^1_%SAZ CONTXX_'SKIP IF NO PREVIOUS EXIT REQUEST_^1TRUEXT LDA IL_+PICK UP 'IL'_^1_%SAZ OUT_^1_%RTJ* PGEJT_^1TSTHD4 LDA* EJTHD_^1_%SAZ OUT_^1_%JMP* TSTHD4_^1OUT_"JMP- ($EA)_(EXIT FTN_^1_%SPC 2_^1CONTXX LDA* SAVNAM_'RESTORE NAME OF PREVIOUSLY_^1_%STA* NAME+2_'CALLED MODULE_^1_%JM€€P* FTN_^1_%SPC 2_^1EXITF NOP 0_^1_%RTJ* CHKERR_'ARE THERE ANY ERRORS_^1_%SAN TAG00A_'YES_^1_%JMP* TRUEXT_'NO, SO GO LEAVE_^1TAG00A RAO* EXITFL_'FLAG THE EXIT REQUEST AND_^1_%JMP* FTNY_)THE CALL THE ERROR MODULE_^1_%SPC 2_^1EXITFL NUM 0_^1SKIPIT LDA* NAME+2_^1_%ADD- X0100_^1_%STA* NAME+2_^1_%LDA* PHASE_^1_%INA -2_^1_%JMP* NORM1_^1NORM_!LDA* PHASE_^1_%INA -1_^1NORM1 STA* PHA€€SE_^1_%SAM RESET_^1_%LDA* NAME+2_^1_%ADD- X0100_^1_%STA* NAME+2_^1_%JMP* FTN_^1_%SPC 5_^1RESET ENA 1_^1_%AND PAGNBR+2_^1_%SAZ RESET1_^1_%RTJ* PGEJT_^1RESET1 ENA NBPHAS_'RESET PHASE NUMBER_^1_%STA* PHASE_^1_%LDA =AA1_^1_%STA* NAME+2_^1_%LDA =XLFTNP1+17_^1_%STA* COMNSZ+NBPHAS_^1_%LDA =XPALC-17_^1_%STA* DELTA+NBPHAS_^1_%ENA -2_^1_%AND* (AFLGS)_^1_%INA 2_^1_%STA* (AFLGS)_^1€€_%JMP* FTN_^1_%SPC 3_^1PGEJT ADC 0_^1TSTHD1 LDA* EJTHD_^1_%SAZ TAG001_^1_%JMP* TSTHD1_^1_%SPC 1_^1TAG001 RTJ- ($F4)_^1_%NUM $4C01_^1_%ADC 0_^1EJTHD ADC 0_^1_%NUM $18FB_^1_%ADC 3_^1_%ADC EJTCOD_^1_%JMP* (PGEJT)_^1_%SPC 2_^1EJTCOD ALF 3,:F_^1_%EJT_]_^1*_8THIS ROUTINE WILL BE CALLED(FORTER)_^1*_8IF ANY ERROR WAS REGISTERED DURING_^1*_8THE LAST MODULE OPERATION_^1_%SPC 2€€_^1CHKERR ADC 0_^1_%LDA+ REGERR_'GET FIRST WORD OF ERRORS RECORD_^1_%AND- 3_,GET BIT 0_^1_%SAN TAG003_^1_%JMP* (CHKERR)_$NO ERRORS,CONTINUE ON_^1TAG003 LDA* NAME+2_^1_%STA* SAVNAM_'SAVE CURRENT MODULE NAME_^1_%LDA =AER_)SET NAME TO 'FORTER'_^1_%STA* NAME+2_^1_%ENQ -1_+FORTER WILL RUN AS PHASE '-1'_^1_%JMP* (CHKERR)_^1_%EJT_]_^1_%BZS SAVNAM_^1PHASE ADC NBPHAS_^1AFLGS ADC IF€€LAGS_^1_%SPC 3_SFTN 3.3_^1_%EQU PALC(1673)_JFTN 3.3_^1_%EQU PBLC(1783)_JFTN 3.3_^1_%EQU PCLC(3017)_JFTN 3.3_^1_%EQU PDLC(3017)_JFTN 3.3_^1_%EQU PFLC(3017)_^1_%EQU PRLC(3017)_^1_%SPC 3_SFTN 3.3_^1_%ADC PRLC+LFTNP1_!THIS IS COMNSZ-1 FOR FORTER_^1COMNSZ ADC PFLC+LFTNP1_!PHASE 0 = FORTF1_6FTN 3.3_^1_%ADC PDLC+LFTNP1_!PHASE 1 = FORTE1_6FTN 3.3_^1_%ADC PDLC+LFTNP1_!PHASE 2 = €€FORTD1_^1_%ADC PCLC+LFTNP1_!PHASE 3 = FORTC1_^1_%ADC PALC+LFTNP1_!PHASE 4 = FORTB1_^1_%ADC LFTNP1_'PHASE 5 = FORTA1_^1_%SPC 3_SFTN 3.3_^1_%ADC 0_,THIS IS DELTA-1 FOR FORTER_^1DELTA ADC 0_,PHASE 0 = FORTF1_6FTN 3.3_^1_%ADC 0_,PHASE 1 = FORTE1_6FTN 3.3_^1_%ADC 0_,PHASE 2 = FORTD1_^1_%ADC 0_,PHASE 3 = FORTC1_^1_%ADC PBLC-PALC_#PHASE 4 = FORTB1_^1_%ADC PALC_)PHASE 5 = FORTA€€1_^1_%SPC 3_SFTN 3.3_^1NAME_!ALF 3,FTN3A1_^1_%EJT_]_^1*_$EJECT A PAGE AND WRITE PAGE HEADER IF END OF PAGE_^1PAGCHK NUM 0_^1_%ENA 1_^1_%AND* IFLAGS_'CHECK IF LIST DEVICE ACCEPTS CARRIAGE CONTROL_^1_%SAZ PAGXIT_'SKIP IF IT DOESNT TO EXIT_^1_%LDA* LINCTR_'PICK UP LINE COUNTER_^1_%INA -1_+DECREMENT LINE COUNTER_^1_%SAM NEWPAG_'SKIP IF END OF PAGE_^1_%STA* LINCTR_'RESTORE LINE C€€OUNTER_^1PAGXIT JMP* (PAGCHK)_$RETURN TO CALLER_^1_%SPC 3_^1NEWPAG LDA* PAGLEN_^1_%INA -3_+DECREMENT BY 3 TO ALLOW FOR HEADER_^1_%STA* LINCTR_'RESET LINE COUNTER_^1*_]_^1*_$INCREMENT PAGE NUMBER_^1*_]_^1_%ENQ 2_^1PAGNM0 LDA* PAGNBR,Q_$PICK UP PAGE NUMBER DIGIT_^1_%INA -$20_)CHECK FOR AND SKIP IF DIGIT.NE.SPACE_^1_%SAN PAGNM1_^1_%INA $10_*MAKE SPACE AN ASCII ZERO_^1PAGNM1 INA €€ -$19_)CHECK FOR AND SKIP IF DIGIT.LT.9_^1_%SAM PAGNM3_^1_%ENA $30_^1_%STA* PAGNBR,Q_$STORE ZERO IN THIS DIGIT_^1_%SQN PAGNM2_'SKIP IF ALL DIGITS NOT COMPLETED_^1_%JMP* NEWPG1_'GO TO OUTPUT PAGE HEADER_^1PAGNM2 INQ -1_+SET Q FOR NEXT DIGIT_^1_%JMP* PAGNM0_'GO DO NEXT DIGIT_^1PAGNM3 INA $3A_*ADD 1 TO DIGIT_^1_%STA* PAGNBR,Q_^1*_]_^1*_$OUTPUT HEADER_^1*_]_^1NEWPG1 LDA* PAGREQ+3_€€$PICK UP THREAD OF FWRITE REQUEST_^1_%SAZ PAGREQ_'SKIP IF REQUEST COMPLETED_^1_%JMP* NEWPG1_'WAIT FOR PREVIOUS REQUEST TO COMPLETE_^1PAGREQ FWRITE $FB,,HEADER,HEADLN,A,0,1,I,,1_^1_%JMP* (PAGCHK)_$RETURN TO CALLER_^1_%EJT_]_^1HEADER ALF +,:F FTN 3.3B (OPT = +_^1ASCOPT NUM $4C_*L_^1_%NUM $50_*P_^1_%NUM $58_*X_^1_%NUM $43_*C_^1_%NUM $29_*)_^1_%NUM $20_^1_%NUM $20_^1_%NUM $2€€0_^1_%NUM $20_^1_%NUM $20_^1_%NUM $20_^1_%ALF 4,_^1PRGNAM ALF 3,_^1_%ALF 4,_^1_%ALF 2,PAGE_^1_%NUM $20_^1PAGNBR NUM $20_^1_%NUM $20_^1_%NUM $20_^1_%ALF 3,_^1_%NUM $20_^1_%ALF 3,DATE:_^1DATE_!ALF +,MM/DD/YY+_^1_%ALF 2,_^1_%ALF 3,TIME:_^1TIME_!ALF 2,_^1_%ALF 2,:R:L:R:L_^1HEADLN EQU HEADLN(*-HEADER)_^1_%EQU IFLAGS(*)_^1_%EQU PAGLEN(IFLAGS+1)_^1_%EQU LINCTR(PAGLE€tN+1)_^1_%EQU IL(IFLAGS+7)_^1_%EQU REGERR(IFLAGS+17)_^1_%EQU LFTNP1(*-FTN+1)_^1_%EQU X0100($2B)_^1_%END FTN_^__ tPWGOA CSY/ 02F P€1_%NAM GOA_*DECK-ID 02F FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^1_%SPC 3_^1*_$PROGRAM BASE .._^1* THIS IS THE 2.0B VERSION._^1* DEFINITION OF 'IFLAGS' BIT 4 ADDED._^1* GOA IS USED IN PHASE A_^1_%ENT GOA,SKIPIT_^1_%EXT IOPR,LOCLIZ,LOCLZ2,PHASEA,€€WRITE,OPANAL_^1_%EXT READ,EXIT,WAIT,CRDBF,CBAV_7**FTN 3.0**_^1* MASTER LABELLED COMMON BLOCK..._^1_%DAT IFLAGS_NFTN 3.3_^1_%DAT LINECT_NFTN 3.3_^1_%DAT LINCT1_NFTN 3.3_^1_%DAT IR_RFTN 3.3_^1_%DAT IK_RFTN 3.3_^1_%DAT IP_RFTN 3.3_^1_%DAT IA_RFTN 3.3_^1_%DAT IL_RFTN 3.3_^1_%DAT IM_RFTN 3.3_^1_%DAT IXLGO_OFTN 3.3_^1_%DAT IOPTO_OFTN 3.3_^1_%DAT IOPTV_OFTN 3.3_^1_%DAT IOPTC€€_OFTN 3.3_^1_%DAT IOPTD_OFTN 3.3_^1_%DAT MCSTRT_NFTN 3.3_^1_%DAT MACRNB_NFTN 3.3_^1_%DAT MACSEC_NFTN 3.3_^1_%DAT IERRS(16)_KFTN 3.3_^1_%DAT ISRFAD_NFTN 3.3_^1_%DAT LGO_QFTN 3.3_^1_%DAT ISCRI_OFTN 3.3_^1_%DAT ISCRO_OFTN 3.3_^1_%DAT IX_RFTN 3.3_^1_%DAT B(1673-38)_JFTN 3.3_^1* PHASE A BLANK COMMON BLOCK..._^1_%COM D($4D4-70),IPHAT(4),IHEAD(7),ISRS(41)_^1_%COM LENSAV,IOSPR€€T(17)_^1* COMMUNICATION-REGION CONSTANTS..._^1_%EQU X1($03),XFFFE($13)_^1*_]_^1* BIT ASSIGNMENTS IN 'IFLAGS'..._^1*_!BIT 0 - LIST DEVICE ACCEPTS CARRIAGE CONTROL_^1*_!BIT 1 - THIS IS A STACKED COMPILATION_^1*_!BIT 2 - THE PHASE A LOCAL FILES ARE INTACT_^1*_!BIT 3 - THERE HAS BEEN A FATAL ERROR IN PHASE A_^1*_!BIT 4 - 'IOSPR' IS CALLING 'ARITH'_^1*_]_^1GOA_"NOP_]_^1_%LDA- $E4_'INIT€€IALIZE LOAD AND GO_^1_%STA+ LGO_)SECTOR NUMBER_^1_%RTJ+ IOPR_%INITIALIZE I/O PACKAGE_^1_%ENA 2_)TEST FOR STACKED COMPILATION_^1IFAD_!AND+ IFLAGS_^1_%SAZ STATUS_^1_%JMP* STACK_^1STATUS RTJ- ($F4)_$GET DEVICE TYPE OF STANDARD_^1_%NUM $4600,$8FB,0 LIST DEVICE_7**FTN 3.0**_^1_%LLS 5 MOVE CLASS TYPE INTO A-REG_789*2741_^1_%AND- 5_#$0007 SAVE CLASS TYPE OF EQUIPMENT IN A-REG_!89*2€€741_^1_%TRA Q_S89*2741_^1_%ENA 0_.IF_B89*2741_^1_%INQ -4_)PAPER TAPE CLASS_889*2741_^1_%SQZ NOCC1_*OR_B89*2741_^1_%INQ -2_)TTY CLASS_?89*2741_^1_%SQZ NOCC1_%SET BIT 0 OF 'IFLAGS' TO 0, ELSE_(89*2741_^1_%ENA 1_*SET TO 1 INDICATING THAT DEVICE_)89*2741_^1NOCC1 STA* (IFAD+1)_"ACCEPTS CARRIAGE CONTROL_089*2741_^1CLOC_!RTJ+ LOCLIZ_#GENERATE PHASE A LOCAL FILES_^1NEWOPT RTJ+ OPAN€€AL_'REQUEST OPTIONS_3**FTN 3.0**_^1SPALOF ENA 4_)SET 'PHASE A LOCALS OK' FLAG_^1_%ADD* (IFAD+1)_^1_%STA* (IFAD+1)_^1_%JMP* CALLA_^1STACK LDA+ CBAV_)ENSURE CRDBF IS FILLED_,**FTN 3.0**_^1_%SAZ 1_O**FTN 3.0**_^1_%JMP* STACK_K**FTN 3.0**_^1_%LDA+ CRDBF_(CHECK IF NEW OPTIONS_.**FTN 3.0**_^1_%SUB =A O_L**FTN 3.0**_^1_%SAN NONEW_K**FTN 3.0**_^1_%ENQ 1_O**FTN 3.0**_^1_%LDA+ CRDBF,Q_€€I**FTN 3.0**_^1_%SUB =APT_L**FTN 3.0**_^1_%SAN NONEW_K**FTN 3.0**_^1_%RTJ* (NEWOPT+1)_F**FTN 3.0**_^1NONEW RTJ+ READ_)READ FIRST LINE OF NEXT_+**FTN 3.0**_^1_%ADC X1_*PROGRAM INTO INTERMEDIATE_^1_%ADC X1_*LINE BUFFER USED BY 'GNST'_^1_%ADC N41_^1ISRSAD ADC ISRS_^1_%LDA* (ISRSAD)_!COMPARE LINE TO ' MON'_^1_%SUB =A M_^1_%SAN ILLMON_'TRY ILLEGAL MON_^1_%LDA+ ISRS+1_^1_%SUB =€€AON_^1_%SAN ILLMON_'TRY ILLEGAL MON_^1_%RTJ+ EXIT_%IF 'MON' CARD, RETURN TO O.S._^1ILLMON LDA* (ISRSAD)_^1_%SUB =AMO_)ASCII MO_^1_%SAN TSTLOC_'IF COLUMN 1,2 MON_^1_%LDA+ ISRS+1_^1_%SUB =AN_^1_%SAN TSTLOC_^1_%RTJ+ EXIT_)EXIT_^1TSTLOC ENA 4_)TEST 'PHASE A LOCAL FILES OK'_^1_%AND* (IFAD+1)_#...REBUILD FILES ONLY IF_^1_%SAN CLOC2_'THEY'VE BEEN DESTROYED_^1_%RTJ* (CLOC+1)_^1_%JMP€€* SPALOF_^1CLOC2 RTJ+ LOCLZ2_#IF SO, JUST RELOAD 'SIZES' TBL._^1CALLA RTJ+ PHASEA_#EXECUTE PHASE 'A'_^1RETURN RAO* GOA_'NORMAL RETURN TO 'FTN'_^1_%RTJ WAIT_)HANG TILL LAST OUTPUT DONE_^1_%ENA -8_(CLEAR 'FATAL' FLAG_^1_%AND* (IFAD+1)_^1_%STA* (IFAD+1)_^1_%RTJ+ WRITE_$OUTPUT LAST WRITE BUFFER_^1OUTAD ADC ISCRO,XFFFE_^1_%NUM 0,0_^1_%JMP* (GOA)_(RETURN TO FTN_^1SKIPIT NOP 0_)AB€6NORMAL_^1_%JMP* RETURN+1_^1N41_"NUM 41_^1_%END_]_^__ 6PWCONV1 CSY/ 03F P€1_%NAM CONV_)DECK-ID 03F FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^1_%SPC 3_^1* CONV IS USED IN PHASE A_^1* NON-IDENTICAL CONV USED IN PHASE E_^1* SUBROUTINE CONV (IX1,IX2)...THIS IS FOR PHASE A_^1*__"?_"@_"[_"\_"]_"^_"_ _^1_%NUM $3E,$3F,$40,$5B,$5C,$5D,$5E,$5F_^1*_#*********************** FTN 3.2 ******END************************_^1_%END_]_^__¤PWDXP9 CSY/ 05F P€1_%NAM DXP9_)DECK-ID 05F FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^1_%SPC 3_^1*_8DXP9 IS USED IN PHASES A1,A2,A3,A4,A5_^1*_]_^1*_8BEGIN_4***** FTN 3.1 *****_^1*_*CREATE A FLT. PT. NO. FROM AN INTEGER COEFFICIENT_"89*2968_^1*_*(4 WORDS IN P+FF.) AND€€ DECIMAL EXPONENT IN P1._^1*_]_^1*_*OUTPUT IS FLOATING POINT NUMBER IN P, P+1, AND P+2._^1*_*ERROR INDICATOR IN P1 (0=NO ERROR, 1=ERROR)_)89*2968_^1*_]_^1*_*ROUTINE SHOULD NOT BE ENTERED WITH A ZERO FRACTION_^1_%ENT DXP9_^1_%ENT Q8DXPT_^1_%ENT Q8DXP2_^1_%EXT DFLOT_^1_%EQU ONEBIT($23)_^1_%EQU LPMSK(2)_^1_%EQU ZROBIT($33)_^1_%EQU NZERO($12)_^1*_]_^1* PHASE A BLANK COMMON (NOT€€ IN RUN-TIME VERSION)_^1_%COM EBC1(7),JFLOT_^1*_]_^1*_]_^1GETP_!NOP 0_,GET ADDRESS OF PARAMETER_^1_%LDA* (DXP9)_^1_%STQ* QSTEMP_'SAVE Q-REGISTER_3**FTN 3.0**_^1_%LDQ- $F6_*UPPER BANK--NO RELATIVE ALLOWED_"**FTN 3.0**_^1_%SQM KLG65K-*-1_F**FTN 3.0**_^1_%SAP KLG65K-*-1_F**FTN 3.0**_^1_%ADD* DXP9_L**FTN 3.0**_^1_%AND- LPMSK+15_$$7FFF_=**FTN 3.0**_^1KLG65K LDQ* QSTEMP_'RESTORE Q RE€€G._4**FTN 3.0**_^1_%RAO* DXP9_)SET ADDRESS OF NEXT PARAMETER OR RETURN ADDR._^1_%JMP* (GETP)_'RETURN TO CALLING PROGRAM_^1QSTEMP NUM 0_-TEMPORARY STORAGE FOR Q REG._%**FTN 3.0**_^1DXP61 NUM $B9D4_(DFMPY_^1DXP62 NUM $BAD4_(DFDIV_^1QSAVE NUM 0_S89*2968_^1DXP9_!NOP 0_,ENTRY POINT_^1_%LDA- $FF_^1_%STA* TEMPI_(SAVE CONTENTS OF I REG. IN TEMP. STORAGE_^1_%STQ* QSAVE_(SAVE CONTENTS€€ OF Q-REG_089*2968_^1_%RTJ* GETP_)GET PARAMETER 1 ADDRESS_^1_%STA DXP30_(ADDR. OF PARAM. 1_^1_%STA DXP31_(ADDR. OF PARAM. 1_^1_%STA- $FF_*ADDR. OF PARAM. 1_^1_%RTJ* GETP_)GET PARAMETER 2 ADDRESS-ADDR. OF DECIMAL EXP._^1_%STA* DXP90+1_^1DXP90 LDA+ 0_,OBTAIN DECIMAL EXPONENT_^1_%STA* TEMP_)TEMP = C(PARAM. 2)= EXPONENT_^1_%ENQ 0_^1_%STQ ADD+1_(ADD+1 = 0_^1_%STQ* (DXP90+1)_#C(PARA€€M. 2) = 0_^1_%LDQ* DXP61_(Q REG. = $B9D4 MULTIPLY IF POSITIVE_^1_%SAP DXP92-*-1_#IS EXPONENT POSITIVE_^1_%TCA A_,NO_^1_%STA* TEMP_)TEMP = - TEMP (EXPONENT)_^1_%LDQ* DXP62_(Q REG. = $BAD4 DIVIDE IF NEGATIVE_^1DXP92 STQ DXP79_(DXP79 = LOAD,MUL OR DIV,STORE,END._^1_%INA -40_^1_%SAP DXP59-*-1_#IS (ABS(EXPONENT)) .LT. 40_^1_%JMP* DXP99_(YES--EXPONENT .LT. 40_^1DXP59 ENA 0_,ABS(€€EXPONENT .GE. 40)_^1_%RAO* (DXP90+1)_#EXPONENT TOO BIG--OVERFLOW**PARAM. 2 = 1_^1_%STA (DXP30)_%PARAM 1 = 0_*IWORK(2)=0_^1_%STA- 1,I_*PARAM 1 + 1 = 0_%IWORK(3)=0_^1_%STA- 2,I_*PARAM 1 + 2 = 0_%IWORK(4)=0_^1_%TRQ A_,A MLTPY MEANS POS EXP ($89D4)_)89*2968_^1_%EOR* DXP62_(A DIV_!MEANS NEG EXP ($BAD4)_)89*2968_^1_%SAZ DXP60_(SKIP IF UNDERFLOW_589*2968_^1_%LDA- LPMSK+15_$NO EXP. POSI€€TIVE--EXP. OVERFLOW_^1_%STA (DXP30)_%PARAM 1 = $7FFF_%IWORK(2)=$7FFF_^1_%ENA -0_^1_%STA- 1,I_*PARAM 1 +1 = $FFFF_"IWORK(3)=$FFFF_^1_%STA- 2,I_*PARAM 1 +2 = $FFFF_"IWORK(4)=$FFFF_^1DXP60 LDA* TEMPI_^1_%STA- $FF_*RESTORE I REGISTER_^1_%JMP* (DXP9)_'RETURN TO CALLING PROGRAM_^1DXP99 LDQ* TEMP_)EXPONENT .LT. 40_^1_%LRS 3_^1_%STA* TEMP+2_'EXPONENT-40 RT SHIFTED 3_^1_%SQN DXP93-*-€€1_#IS EXPONENENT 7 OR LESS_^1_%LLS 3_,RESTORE EXPONENT IN Q_^1_%TRQ A_^1_%MUI- LPMSK+2_%EXPONENT INDEX*3_^1_%TRA Q_,Q = EXPON TABLE INDEX_^1_%RTJ DXP27_(SET TEMP+3,TEMP+4,AND TEMP+5 WITH TABLE VALUE_^1_%JMP* DXP89_^1DXP93 TRQ A_,EXPONENT .GT. 7_^1_%MUI- LPMSK+2_%EXPONENT INDEX*3_^1_%TCA Q_,Q = -EXPON TABLE INDEX_^1_%RTJ DXP27_^1_%ENQ 0_^1_%LDA* TEMP+2_'EXPON-40 SHIFTED RT €€3_^1_%LLS 3_,RESTORE EXPONENT IN Q_^1_%SQZ DXP89-*-1_#IS EXPONENT 8,16,24, OR 32_^1_%TRQ A_,NO_^1_%MUI- LPMSK+2_%EXPON INDEX*3_^1_%TRA Q_,Q = EXPON TABLE INDEX_^1_%ADQ DCON_)PICK UP PROPER ENTRY INTO 1.0*10**N TABLE_^1_%STQ* DXP21+3_%AND STORE ADDRESS TO BE LOADED BY DFLOT_^1DXP21 RTJ DFLOT_^1_%NUM $B9D4_^1_%NUM 0_,LOAD C(ADDRESS) FROM ECON TABLE_^1_%ADC TEMP+3_'MPY_!TEM€€P+3_^1_%ADC TEMP+3_'STA_!TEMP+3_^1DXP89 ENQ -48_^1_%STQ* TEMP+1_'TEMP1=-48=SHIFCT_^1_%LDQ* (DXP30)_%WORK(2) - PARAMETER 1_^1_%LDA- 1,I_*WORK(3) - PARAMETER 1 +1_^1_%ALS 4_^1_%LLS 4_^1_%STQ* (DXP30)_%WORK(2) - PARAMETER 1*PACKED*_^1_%LDQ- 1,I_*WORK(3) - PARAMETER 1+1_^1_%LDA- 2,I_*WORK(4) - PARAMETER 1+2_^1_%ALS 4_^1_%LLS 8_^1_%STQ- 1,I_*WORK(3) - PARAMETER 1+1 *PACKED_^1_%LD€€Q- 2,I_*WORK(4) - PARAMETER 1+2_^1_%LDA- 3,I_*WORK(5) - PARAMETER 1+3_^1_%ALS 4_^1_%LLS 12_^1_%STQ- 2,I_*W(4) - PARAMETER 1 +2 *PACKED_^1_%LDQ* (DXP30)_%WORK(2)_^1_%LDA- 1,I_*WORK(3)_^1_%SQN DXP71-*-1_^1_%SAN DXP71-*-1_^1_%LDA- 2,I_*WORK(4)_^1_%SAN DXP71-*-1_^1_%JMP* DXP60_(RESULT IS ZERO - EXIT_^1*_8NORMALIZE FRACTION_^1DXP71 SQM TMSKP1_'SKIP TO RELATIVE ADDRESS_^1_%LDA- 1,€€I_*WORK(3)_^1_%LLS 1_^1_%STQ* (DXP30)_%WORK(2) MSB_^1_%LDQ- 1,I_*WORK(3)_^1_%LDA- 2,I_*WORK(4)_^1_%LLS 1_^1_%AND- ZROBIT_'$FFFE_^1_%STQ- 1,I_3ISB_^1_%STA- 2,I_3LSB_^1_%RAO* TEMP+1_'SHIFCT = SHIFCT + 1_^1_%LDQ* (DXP30)_%WORK(2)_^1_%JMP* DXP71_(LOOP UNTIL NORMALIZED_^1TMSKP1 SQM DXP70_(ADDED FOR RELATIVE SKIP ONLY_^1_%BSS TEMPI_^1_%BSS TEMP(8)_^1DXP70 LDQ* TEMP+1_'SHIFT COUNT_€€^1_%INQ 39_+Q=SHIFCT+39_^1_%SQZ DXP74-*-1_#IS ROUNDING NECESSARY Q=0 NO_^1_%SQM DXP40-*-1_#IS ROUNDING NECESSARY Q=- YES ROUND_^1DXP68 INQ -39_*Q=+ NO ROUNDING NECESSARY_^1_%TCQ A_^1_%ADD- ONEBIT+7_$$80 - NO. IS FORMED MSB,ISB,LSB,EXP-THEN SHIFT_^1_%ADD- 2,I_^1_%STA- 2,I_*WORK(4)_^1_%JMP* DXP78_^1DXP40 TCQ Q_^1_%STQ* ADD+1_^1_%LDA- 2,I_*WORK(4)_^1SHIFT ALS 7_,OBTAIN BIT 4€€0_^1_%SAM DXP75-*-1_#IS FORTYITH BIT SET_^1DXP74 LDA- 2,I_*NO-DO NOT ROUND WORK(4)_^1_%AND- LPMSK+25_$RETAIN ONLY 39 BITS $FE00_^1_%JMP* DXP77_(NO ROUNDING_^1DXP75 LDA- 2,I_*YES-ROUND WORK(4)_^1_%ARS 9_,RIGHT JUSTIFY LSB IN A REGISTER_^1_%AND- LPMSK+7_%$007F_^1_%INA 1_,ROUND IF BIT 40 IS SET_^1_%ENQ 0_^1_%LLS 9_,Q=OVERFLOW FROM ROUNDING_^1_%STA- 2,I_*WORK(4)_^1_%SQZ DXPJM€€P-*-1_"NO WORD OVERFLOW IS POSSIBLE_^1_%LDA- 1,I_*WORK(3)_^1_%EOR- NZERO_($FFFF_^1_%SAZ DXP76-*-1_#ARE ALL BITS OF ISB SET_^1_%ADQ- 1,I_*NO ALL BITS OF ISB ARE NOT SET (FFFE+1=0)_^1_%SQN DXP175-*-1_"ISB=$FFFE_^1_%ENQ -0_+$FFFF_^1DXP175 STQ- 1,I_*ISB_^1_%LDA- 2,I_*LSB_^1DXPJMP JMP* DXP77_(NO OVERFLOW INTO MSB POSSIBLE_^1DXP76 STA- 1,I_*YES-ALL BITS OF ISB SET, THEREFORE IWORK(3€€)=0_^1_%ADQ* (DXP30)_%ADD ONE TO MSB FOR OVERFLOW OF ISB_^1_%LDA- 2,I_*LSB_^1_%SQM DXP77-*-1_#Q=-, NO OVERFLOW OF MSB_^1_%SQN DXP176-*-1_"Q=0, OVERFLOW OF MSB_^1_%ENQ -0_+$FFFF_^1_%JMP* DXP177_^1DXP176 ENA 1_,ADD ONE TO EXPONENT_^1_%LDQ- ONEBIT+15_#$8000_^1DXP177 STQ* (DXP30)_%MSB_^1DXP77 ADD =N$A7_(2**39_^1*_*ADD IN EXPONENT FOR TRUNCATED PORTION OF INPUT_^1ADD_"ADD =N0_^1_€€%STA- 2,I_^1DXP78 LDQ- 2,I_*IWORK(4)_^1_%LDA* (DXP30)_%IWORK(2)_^1_%LLS 7_^1_%STQ* TEMP+6_'MSB_^1_%LDQ- 1,I_*IWORK(3)_^1_%LDA- 2,I_*IWORK(4)_^1_%LLS 7_^1_%STQ* TEMP+7_'LSB_^1_%LDQ* (DXP30)_%IWORK(2)_^1_%LDA- 1,I_*IWORK(3)_^1_%LLS 7_^1_%STQ- 1,I_***ISB - IWORK(3)**_^1_%LDQ* TEMP+6_^1_%STQ* (DXP30)_%**MSB - IWORK(2)**_^1_%LDA* TEMP+7_^1_%STA- 2,I_***LSB - IWORK(4)**_^1_%ENA 0_^1€€_%STA- $C8_*CLEAR DFLOT ERROR FLAG_^1_%RTJ* (DXP21+1)_#CALL DFLOT_^1DXP79 NUM $B9D4_(LOAD,MUL OR DIV,STORE,END_^1DXP30 NUM 0_,ADC PARAM 1 ADDRESS_!LOAD WORK(2),WK(3),WK(4)_^1_%ADC TEMP+3_'DFMUL OR DFDIV BY TEMP+3,TEMP+4,TEMP+5_^1DXP31 NUM 0_,ADC PARAM 1 ADDRESS_!STORE WORK(2),WK(3),WK(4_^1_%LDA- $C8_*OVERFLOW/UNDERFLOW/DIVIDE CHECK INDICATOR_^1* TEST FOR REAL CONSTANT (NOT I€€N RUN-TIME VERSION)_^1*_#IF ($C8 .EQ. 0) GO TO RLCN_^1_%SAZ RLCN_)NO ERRORS -- CHECK FOR REAL CONSTANT_^1C8ER1 JMP DXP59_(EXPONENT OVERFLOW/UNDERFLOW_^1*_#IF (JFLOT.EQ.2) GO TO RLCN1_^1*_#GO TO EXIT_^1RLCN_!LDA JFLOT_^1_%INA -2_^1_%SAZ RLCN1_^1EXIT_!JMP DXP60_'EXIT FROM ROUTINE_^1* CHECK FOR ROUNDING_^1*_#IF (WORK(4).LT.0) GO TO RLCN2_^1RLCN1 LDA- 2,I_*WORK(4)_^1_%SAM RLCN€€2_^1_%JMP* EXIT_^1* ROUND LSB REAL CONSTANT_^1*_#IF (WORK(3) .EQ.$FFFF) GO TO RLCN4_^1RLCN2 LDA- 1,I_*WORK(3)_^1_%EOR- NZERO_($FFFF_^1_%SAZ RLCN4_^1*_#IF (WORK(3) .EQ.-1) WORK(3 = WORK(3) + 1_^1_%ENQ 1_^1_%ADQ- 1,I_*($FFFE+1=0)_^1*_#IF (WORK(3) .NE. -1) GO TO RLCN3_^1_%SQN RLCN3_(DOES WORK(3) = $FFFE_^1_%ENQ -0_+YES ENTER Q WITH $FFFF_^1RLCN3 STQ- 1,I_*NO, WORK(3)_^1*_#GO TO €€EXIT_^1_%JMP* EXIT_^1*_#WORK(3) = 0_^1RLCN4 STA- 1,I_*YES, ALL BITS OF WORK(3) SET- WORK(3) = 0_^1* ROUND MSB OF REAL CONSTANT_^1* WORD1 OF 2 WORD REAL CONSTANT IS SEEEEEEEEFFFFFFF_^1*_/S = SIGN E = EXPONENT F = FRACTION_^1*_#IF (WORK(2)+1 .LT.0) GO TO C8ER1_^1_%ENQ 0_^1_%LDA* (DXP31)_%WORK(2)_^1_%INA 1_^1_%SAP RLCN5_(DID EXPONENT OVERFLOW_^1_%JMP* C8ER1_(YES EXPONENT OVERFLOW €€ERROR_^1RLCN5 LLS 9_,NO EXPONENT OVERFLOW_^1* SEE IF MOST SIGNIFICANT BIT NEEDS TO BE NORMALIZED_^1_%SAM RLCN6_(LEFT MOST FRACTION BIT NORMAL_^1_%EOR LPMSK+31_$NO (NORMALIZE BIT) $8000_^1RLCN6 LLS 16_+SHIFT EXPONENT INTO A REGISTER_^1_%SUB- LPMSK+40_$$80_^1_%SAN RLCN7_(IS EXPONENT = $80_^1_%INA 1_,YES_^1RLCN7 ADD- LPMSK+40_$NO, ADD BACK $ 80 IN EITHER CASE_^1_%LLS 7_,SHIF€€T FRACTION BACK INTO A REGISTER_^1_%STA* (DXP31)_%STORE ROUNDED WORD INTO WORK(2)_^1*_#GO TO EXIT_^1_%JMP* EXIT_^1DXP27 NOP 0_,Q POINTS TO CENTER OF TABLE_^1_%ADQ* DCON_)ADD INDEX_^1_%LDA- 2,Q_^1_%STA* TEMP+5_'OBTAIN DOUBLE PRECISION FLOATING POINT_^1_%LDA- 1,Q_*EXPONENT IN STANDARD FORM AND STORE_^1_%STA* TEMP+4_'IN TEMP+3, TEMP+4,AND TEMP+5_^1_%LDA* (DXPTB+1),Q_^1_%STA* TEMP+3_€€^1_%JMP* (DXP27)_%RETURN TO CALLING PROGRAM_^1DCON_!ADC DXPTB_^1* BACKWARDS_$1D32_-1D24_^1_%NUM $75CE,$E2D6,$D416,$6869,$E10D,$E766_^1*_01D16_-1D8_^1_%NUM $5B47,$0DE4,$DF82,$4DDF,$5E10,$0000_^1*_01D0_^1DXPTB NUM $40C0,$0000,$0000_^1*_01D1_.1D2_.1D3_^1DXPT2 NUM $4250,$0000,$0000,$43E4,$0000,$0000,$457D,$0000,$0000_^1*_01D4_.1D5_.1D6_^1_%NUM $474E,$2000,$0000,$48E1,$A800,$00€Š00,$4A7A,$1200,$0000_^1*_01D7_^1_%NUM $4C4C,$4B40,$0000_^1_%EQU Q8DXPT(DXPTB),Q8DXP2(DXPT2)_^1*_8END_6***** FTN 3.1 *****_^1_%END_]_^__ ŠPWDFLOT CSY/ 06F P€1_%NAM DFLOT_(DECK-ID 06F FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^1_%SPC 3_^1*_8DFLOT IS USED IN PHASES A1,A2,A3,A4,A5_^1*_]_^1*_8BEGIN_4***** FTN 3.1 *****_^1* THIS IS A COMPRESSED VERSION OF THE OBJECT LIBRARY_^1* 'DFLOT' ROUTINE. ONLY THOSE F€€UNCTIONS REQUIRED_^1* BY THE COMPILER...FLDD,FMPY,FDIV,FSTO,FEND...ARE RETAINED._^1_%ENT DFLOT_+ENTRY POINT TO FLOATING_^1*_;POINT PKG._^1*_$LIST OF FLOATING POINT OPERATION CODES._^1*_$0_"XXX_-(NOT USED)_^1*_$1_"XXX_*(NOT USED)_^1*_$2_"XXX_*(NOT USED)_^1*_$3_"XXX_*(NOT USED)_^1*_$4_"FEND_,END OF CALLING SEQUENCE_^1*_$5_1(NOT USED)_^1*_$6_1(NOT USED)_^1*_$7_1(NOT USED)_^1*_$8_1(NO€€T USED)_^1*_$9_"DFMPY_(MULTIPLY_^1*_$A_"DFDIV_(DIVIDE_^1*_$B_"DFLDD_(LOAD_^1*_$C_"XXX_*(NOT USED)_^1*_$D_"DFLST_(STORE_^1*_$E_1(NOT USED)_^1*_$F_1(NOT USED)_^1*_]_^1*_$G, THE PSUEDO ACCUMULATOR IS BROKEN UP INTO_^1*_$C, CI, D, AND DELTA_^1*_]_^1_%EJT_]_^1_%EXT AVOLA_(***REMOVE FOREGROUND***_^1_%EXT AVOLR_(***REMOVE FOREGROUND***_^1_%EQU G(3),SIGN(6),ERRORS(7)_^1_%EQU F(8),A(11)€€,AI(12)_^1_%EQU B(13),BETA(14),C(15)_^1_%EQU CI(16),D(17),DELTA(18)_^1_%EQU SHIFCT(19),P(20),RELADR(21)_^1_%EQU OPCNT(22),INDEX(23),OPCODE(24)_^1_%EQU TEMPQ(25),TEMGP2(26)_@90*3018_^1_%EQU T1(27),T2(28),T3(29),MULDIV(30)_590*3018_^1***_"EQU AVOLA($BB),AVOLR($BA)_!PUT INTO PROGRAM FOR FOREGROUND_^1_%EQU LPMSK(2),NZERO($12),ZERO($22),ONEBIT($23),ZROBIT($33)_^1_%EJT_]_^1FLIT_!€€LDA- ERRORS,I_L90*3018_^1_%STA- $C8_^1_%LDA- G,I_*STORE RESULT_^1_%STA- $C5_^1_%LDA- G+1,I_(INTO LOW CORE_^1_%STA- $C6_^1_%LDA- G+2,I_(FLOATING ACCUMULATORS_^1_%STA- $C7_^1_%LDA- P,I_*GET RETURN ADDRESS_^1_%STA* DFLOT_O90*3018_^1_%RTJ AVOLR_(***REMOVE FOREGROUND***_^1***_"RTJ- (AVOLR)_%***UTILIZE FOREGROUND***_^1***_"EIN 0_,***UTILIZE FOREGROUND***_^1_%JMP* (DFLOT)_%RETURN TO USE€€R_890*3018_^1DFLOT 0_"0_^1***_"IIN 0_,***UTILIZE FOREGROUND***_^1_%RTJ AVOLA_(***REMOVE FOREGROUND***_^1***_"RTJ- (AVOLA)_%***UTILIZE FOREGROUND***_^1***_"NUM 32_+***UTILIZE FOREGROUND***_^1*_8(Q-REG SAVED BY AVOLA)_090*3018_^1*_]_^1_%LDA- $C8_*INITIALIZE ERROR WITH CURRENT_^1_%STA- ERRORS,I_$CONTENTS OF LOW CORE CELL $C8._^1_%LDA- ZERO_)CLEAR_^1_%STA- MULDIV,I_$MULTIPLY/DIVIDE€€ FLAG_^1***_"EIN 0_,***UTILIZE FOREGROUND***_^1_%LDA* DFLOT_+SAVE RETURN ADDRESS_^1STOREP STA- P,I_*INTERPRETIVE LIST_^1INTERP CLR A_^1_%STA- OPCNT,I_^1*_81 CARD DELETED_890*3018_^1_%LDQ- P,I_*GET OPCODE FROM VOLATILE STORAGE AND_^1_%LDA- (ZERO),Q_$PLACE IN A REGISTER_^1_%STA- OPCODE,I_^1_%RAO- P,I_*IF OPCNT GE. 3 GO TO INTERP_^1_%JMP* DECODE_^1*_FGET NEXT OPERATION CODE_^1NXTOPC€€ LDA- OPCNT,I_4IF OPCNT .GE. 3 GO TO INTERP_^1_%INA -3_^1_%SAM A1-*-1_^1_%JMP* INTERP_^1A1_#INA 3+1_!OTHERWISE INCREMENT OPCNT_^1_%STA- OPCNT,I_^1_%EJT_]_^1*_FDECODE NEXT OPCODE_^1DECODE LDA- OPCODE,I_^1_%CLR Q_^1_%LLS 4_^1_%STA- OPCODE,I_^1*_FEXECUTE NEXT OPERATION_^1EXECUT JMP* FLINS,Q_^1FLINS NOP 0_,0 - ILLEGAL_^1_%NOP 0_,1 - ILLEGAL_^1_%NOP 0_,2 - ILLEGAL_^1_%NOP 0_,3€€ - ILLEGAL_^1_%JMP* FEND1_(4 - FEND_^1_%NOP 0_,5 - ILLEGAL_^1_%NOP 0_,6 - ILLEGAL_^1_%NOP 0_,7 - ILLEGAL_^1_%NOP 0_,8 - ILLEGAL_^1_%JMP* FMPYA_(9 - FMPY_^1_%JMP* FDIVA_(A - FDIV_^1_%JMP* DFLDD_(B - DFLDD_^1_%NOP 0_,C - ILLEGAL_^1_%JMP* DFLST_(D - DFLST_^1_%NOP 0_,E - ILLEGAL_^1_%NOP 0_,F - ILLEGAL_^1FDIVA JMP DFDIV_^1FMPYA JMP DFMPY_^1FEND1 JMP FEND_^1_%EJT_]_^1*_FFLOA€€TING LOAD_^1DFLDD RTJ OPERND_^1_%LDA- 3,Q_^1_%STA- G+2,I_^1_%LDA- 2,Q_^1_%STA- G+1,I_^1_%LDA- 1,Q_^1_%INA 0_/ELIMINATE MINUS ZERO_^1_%STA- G,I_*OPERAND TO G_^1*_*LOAD OPERAND INTO G._^1*_*UNPACK OPERAND INTO C, CI, D, AND DELTA._^1*_*SAVE SIGN IN SIGN._^1_%ENQ 1_^1_%SAP A3-*-1_^1_%ENQ -1_^1A3_#STQ- SIGN,I_^1*_*UNPACK FROM G INTO C, CI, D, AND DELTA_^1_%LDQ- G+2,I_^1_%STQ- TEM€€GP2,I_$G+2_^1_%LDQ- G+1,I_^1_%STQ- TEMPQ,I_%G+1_^1_%SAP STEP2B-*-1_^1_%TCA A_,COMPLEMENT G_^1_%TCQ Q_S90*3018_^1_%STQ- TEMPQ,I_%COMPLEMENT G+1_890*3018_^1_%LDQ- TEMGP2,I_^1_%TCQ Q_^1_%STQ- TEMGP2,I_$COMPLEMENT G+2_^1*_83 CARDS DELETED_790*3018_^1STEP2B STA- C,I_^1_%SAN A4-*-1_^1_%JMP* ARG0_^1A4_#ALS 1_^1_%EOR- ONEBIT+15_#$8000_^1_%ARS 8_^1_%INA 0_^1_%STA- DELTA,I_^1_%LDA- C€€,I_^1_%LDQ- TEMPQ,I_^1_%LLS 8_^1_%AND- LPMSK+15_$$7FFF_^1_%STA- C,I_^1_%LDA- TEMGP2,I_^1_%LDQ- TEMPQ,I_^1_%LLS 23_^1_%AND- LPMSK+15_$$7FFF_^1_%STA- CI,I_^1_%LLS 15_^1_%AND* H7FC0_^1_%STA- D,I_^1_%JMP* NXTOPC_^1H7FC0 NUM $7FC0_^1ARG0_!CLR A_,ARGUMENT IS ZERO._^1_%STA- C,I_^1_%STA- CI,I_^1_%STA- D,I_^1_%STA- DELTA,I_^1_%ENA 1_^1_%STA- SIGN,I_^1_%JMP* NXTOPC_^1_%EJT_]_^1*_FFLOA€€TING STORE_^1DFLST RTJ* FLTSTO_^1_%RTJ* OPERND_'GET ADDRESS OF OPERAND_^1_%LDA- G,I_^1_%STA- 1,Q_^1_%LDA- G+1,I_^1_%STA- 2,Q_^1_%LDA- G+2,I_^1_%STA- 3,Q_^1ANXT_!JMP NXTOPC_^1FEND_!RTJ* FLTSTO_'REPACK ACCUMULATOR BEFORE_^1_%JMP FLIT_$EXIT, AFTER RESTORING Q AND I_^1FLTSTO 0_"0_^1***_"IIN 0_,***UTILIZE FOREGROUND***_^1_%LDQ- C,I_^1*_*IF C IS ZERO, THEN ACCUMULATOR IS ZERO_^1_%SQN€€ FLST1-*-1_^1_%STQ- G,I_^1_%STQ- G+1,I_^1_%STQ- G+2,I_^1_%JMP* FLSTA_^1FLST1 LDA- CI,I_^1_%ALS 1_^1_%LLS 1_^1_%AND- LPMSK+25_$$FE00_^1_%STA- G+1,I_^1_%LDA- DELTA,I_^1_%AND- LPMSK+8_%$00FF_^1_%EOR- ONEBIT+7_$$0080_^1_%ADD- G+1,I_^1_%LLS 7_^1_%STA- G,I_^1_%STQ- G+1,I_^1_%LDQ- CI,I_^1_%LDA- D,I_^1_%ALS 1_^1_%LLS 9_^1_%STQ- G+2,I_^1_%LDQ- SIGN,I_^1_%SQP FLSTA-*-1_^1_%LDA- G,I_^€€1_%TCA A_^1_%STA- G,I_*IF SIGN IS NEG._^1_%LDA- G+1,I_(COMPLEMENT G._^1_%TCA A_^1_%STA- G+1,I_^1_%LDA- G+2,I_^1_%TCA A_^1_%STA- G+2,I_^1FLSTA NOP 0_,*** REMOVE FOREGROUND***_^1***_"EIN 0_,***UTILIZE FOREGROUND***_^1_%JMP* (FLTSTO) EXIT FROM REPACK OF ACCUMULATOR_^1_%EJT_]_^1*_]_^1ALZERO NUM 0_^1*_FGET ADDRESS OF NEXT OPERAND_^1****** *** GET ADDRESS OF NEXT OPERAND_^1*_*15€€ BIT ADDRESSING ARTIHMETIC IS BEING USED._^1*_*REFER TO E006, APENDIX ON 15 BIT ARITHMETIC_^1OPERND 0_"0_^1***_"IIN 0_,***UTILIZE FOREGROUND***_^1_%LDQ- P,I_^1_%LDA* (ALZERO),Q_^1_%STA- F,I_-SAVE ADDRESS IN F_^1_%LDQ- F,I_^1_%INQ -1_^1KL65K RAO- P,I_M**FTN 3.0**_^1***_"EIN 0_,***UTILIZE FOREGROUND***_^1_%JMP* (OPERND)_(RETURN EFFECTIVE ADR -1 IN Q_^1CARRY 0_"0_^1*_8THIS ROUTI€€NE ASSUMES THAT A SUM IS CONTAINED_^1*_8WITHIN THE QA REGISTER. A CHECK IS MADE FOR A_^1*_8CARRY IN THE A AND Q REGISTERS AND THE CARRY_^1*_8BITS ARE ADDED._^1_%SAP SKP-*-1_%CHECK FOR CARRY IN A REGISTER_^1_%INQ 1_,YES - ADD IN CARRY BIT_^1_%AND- LPMSK+15_$MASK OFF CARRY BIT IN A REGISTER_^1_%SQP SKP-*-1_%CHECK FOR CARRY IN Q REGISTER_^1_%RAO- G,I_*YES - ADD IN CARRY BIT_^1_%LLS€€ 16_+EXCHANGE A AND Q REGISTERS_^1_%AND- LPMSK+15_$MASK OFF CARRY BIT IN Q REGISTER_^1_%LLS 16_+RESTORE Q AND A REGISTERS_^1SKP_"JMP* (CARRY)_%NO - RETURN WITH Q AND A REGISTER IN PROPER_^1*_=FORMAT_^1_%EJT_]_^1*_*FLOATING POINT MULTIPLY OF F*G_^1*_]_^1DFMPY RTJ* OPERND_^1_%RTJ FLTSET_*STEPS 1,2,3 AND 4 OF MPY OR DIV_^1*_*IF F IS NEG., CHANGE SIGN._^1_%SAZ JMPOUT-*-1_^1_%SAP €€FLT1-*-1_^1_%SET A_^1_%EOR- SIGN,I_^1_%STA- SIGN,I_^1*_]_^1*_*STEP 5.A._^1FLT1_!LDA- C,I_^1_%SAN NOZERO-*-1_^1JMPOUT JMP ARG0_^1NOZERO MUI- A,I_^1_%LLS 1_^1_%ARS 1_^1_%AND- LPMSK+15_$$7FFF_^1_%STA- TEMGP2,I_$CA(LSB)_^1_%STQ- G,I_*CA(MSB)_^1_%LDA- D,I_^1_%MUI- A,I_^1_%LLS 1_^1_%SAP 1_,ROUND_^1_%INQ 1_^1_%STQ- TEMPQ,I_%DA(MSB) ROUNDED_^1_%LDA- CI,I_^1_%MUI- AI,I_^1_%LLS 1_^1€€_%SAP 1_^1_%INQ 1_,ROUND_^1_%STQ- F,I_*CI*AI(MSB) ROUNDED_^1_%LDA- CI,I_^1_%MUI- A,I_^1_%LLS 1_^1_%ARS 1_^1_%AND- LPMSK+15_$$7FFF_^1_%STA- F+1,I_(CI*A (LSB)_^1_%STQ- G+1,I_(CI*A (MSB)_^1_%LDA- TEMPQ,I_%DA (MSB)_^1_%ADD- F,I_*CIAI (MSB)_^1_%RTJ* CARRY_(FORMAT QA REGISTERS_^1_%STA- F+2,I_(CIAI(MSB)+DA(MSB) IN_^1_%STQ- G+1,I_(CIA'(MSB)_^1_%LDA- C,I_^1_%MUI- B,I_^1_%LLS 1_^1_%SAP €€ 1_^1_%INQ 1_,ROUND_^1_%TRQ A_,CB(MSB)_^1_%LDQ- G+1,I_(CIA'(MSB)_^1_%ADD- F+2,I_(DA+CIAI+CB_^1_%RTJ* CARRY_(DA+CIAI+CB IN A + CIA'' IN Q_^1_%ADD- F+1,I_(CI*A (LSB)_^1_%RTJ* CARRY_(DA+CIAI+CB(MSB)+CIA(LSB) INA + CIA'''(MSB)IN Q_^1_%STQ- G+1,I_(CIA''' (MSB)_^1_%STA- G+2,I_(DA+CIAI+CB(MSB) + CIA(LSB)_^1_%LDA- C,I_^1_%MUI- AI,I_^1_%LLS 1_^1_%ARS 1_^1_%AND- LPMSK+15_$$7FFF_!CA*I IN €€QA REGISTERS_^1_%ADD- G+2,I_^1_%RTJ* CARRY_^1_%STA- G+2,I_(LSB OF PRODUCT_^1*_8DA+CIAI+CB + CIA(LSB) + CAI(LSB)_^1_%TRQ A_,CAI' (MSB)_^1_%ADD- G+1,I_(CIA'''(MSB)_^1_%SAP SKP1-*-1_$IS THERE A CARRY_^1_%RAO- G,I_*ADD IN CARRY BIT-YES_^1_%AND- LPMSK+15_$CAI'+CIA'''_^1SKP1_!ADD- TEMGP2,I_$CAI'+CIA'''+CA(LSB)_^1_%SAP SKP2-*-1_^1_%RAO- G,I_*MSB OF PRODUCT_^1_%AND- LPMSK+15_^1SKP2_!STA€€- G+1,I_(ISB OF PRODUCT_^1SHIFTA LDA- G+2,I_(THIS LOGIC SQUEEZES OUT_^1_%ALS 1_,THE CARRY SLOTS IN_^1_%LDQ- G+1,I_(CELLS G+1 AND G+2_^1_%LLS 1_^1_%STA- G+2,I_^1_%STQ- G+1,I_^1_%EJT_]_^1NRMLIZ ENQ 0_^1_%STQ- SHIFCT,I_^1_%LDA- G+2,I_^1_%STA- F+2,I_^1_%LDA- G+1,I_^1_%STA- F+1,I_^1_%LDQ- G,I_^1STEP6 LDA- F+1,I_^1_%LLS 1_^1_%STQ- F,I_*(MSB)_^1_%LDQ- F+1,I_^1_%LDA- F+2,I_^1_%LLS 1_€€^1_%AND- ZROBIT_'$FFFE_^1_%STQ- F+1,I_((ISB)_^1_%STA- F+2,I_((LSB)_^1_%LDQ- F,I_^1_%SQM STEP6A-*-1_^1_%RAO- SHIFCT,I_^1_%JMP* STEP6_^1H7F80 NUM $7F80_^1STEP6A LDA- F+1,I_^1_%LLS 31_^1_%ARS 1_^1_%AND- LPMSK+15_$$7FFF_^1_%STA- G+1,I_(ISB_!0,15_^1_%TRQ A_^1_%AND- LPMSK+15_$$7FFF_^1_%STA- G,I_*MSB_!0,15_^1_%LDQ- F+1,I_^1_%LDA- F+2,I_^1_%LRS 3_^1_%AND- LPMSK+15_$$7FFF_^1_%STA- G+€€2,I_(LSB_!0,9_^1_%LDQ- G+1,I_^1_%INA $20_*ROUND TO 39 BITS_^1_%SAM 1_^1_%JMP* STEP6B_^1_%INQ 1_,CARRY INTO ISB_^1_%AND- LPMSK+15_$$7FFF_^1_%SQP STEP6B-*-1_^1_%RAO- G,I_*CARRY INTO MSB_^1_%LLS 16_^1_%AND- LPMSK+15_$$7FFF MASK OFF TOP BIT ISB_^1_%LLS 16_^1_%STQ- G+1,I_(SAVE ISB_^1_%STA- G+2,I_(SAVE LSB_^1_%LDA- G,I_^1_%SAP STP6_)CHECK FOR CARRY IN ISB_^1_%RAO- DELTA,I_%SHIFT €€RIGHT BY ONE_^1_%ALS 15_+NORMALIZE FOR ROUNDING OF 7FFF,7FFF,7F_!COEF._^1_%STA- G,I_^1_%LDQ- G+1,I_(RESTORE ISB_^1STP6_!LDA- G+2,I_(RESTORE LSB_^1STEP6B AND H7FC0_^1_%STQ- CI,I_)SAVE ISB IN C_^1_%STA- D,I_*SAVE LSB IN D_^1_%LDA- G,I_^1_%STA- C,I_*SAVE MSB IN C_^1_%LDA- DELTA,I_^1_%ADD- BETA,I_^1COMBIN SUB- SHIFCT,I_^1_%STA- DELTA,I_^1_%TRA Q_^1_%LDA- MULDIV,I_$MULTIPLY/DIVIDE FL€€AG_290*2937_^1_%SUB- ONEBIT_'$0001_A90*2937_^1_%SAZ DIV_Q90*2937_^1_%TRQ A_S90*2937_^1_%ARS 7_^1_%INA 0_^1_%SAZ NRMXIT_'SKIP IF NO ERROR_690*2937_^1_%JMP OVFUNF_^1*_FUNDERFLOW IF Q=-,A=0._^1NRMXIT JMP NXTOPC_'GO GET NEXT OPCODE_490*2937_^1DIV_"LDA- C,I_*PLACE_!C, CI, D, AND DELTA INTO_^1_%STA- A,I_2A, AI, B AND BETA_^1_%LDA- CI,I_^1_%STA- AI,I_^1_%LDA- D,I_^1_%STA- B,I_^1_%€€LDA- DELTA,I_^1_%STA- BETA,I_^1_%LDA- T1,I_)RESTORE C, CI, D, AND DELTA_^1_%STA- C,I_^1_%LDA- T2,I_^1_%STA- CI,I_^1_%LDA- T3,I_^1_%STA- D,I_^1_%LDA- ONEBIT_'$0001_^1_%STA- DELTA,I_%SET DELTA TO 1 FOR MULTIPLY_^1_%LDA- ZERO_)CLEAR_^1_%STA- MULDIV,I_$MULTIPLY/DIVIDE FLAG_^1_%JMP FLT1_^1_%EJT_]_^1*_]_^1DFDIV RTJ OPERND_'GET NEXT OPERAND ADDRESS_^1_%RTJ* FLTSET_'STEPS 1, 2, 3, AND 4€€ OF MPY OR DIV. AND NORMAL_^1*_8SET A,AI,B,BETA,F,F+1,F+2_^1_%SAN A6-*-1_^1_%JMP DIVZER_'IF F IS ZERO, GO TO DIVZER_^1A6_#SAP FLT2-*-1_^1_%SET A_^1_%EOR- SIGN,I_^1_%STA- SIGN,I_^1FLT2_!LDA- A,I_^1_%SUB- ONEBIT+14_#$4000_^1_%SAZ PLUS1-*-1_#IS FIRST WORD OF DENOMINATOR A + OR - 1_^1_%JMP* FLT3_)NO_^1PLUS1 LDA- F+1,I_(YES_^1_%SAZ PLUS12-*-1_^1_%JMP* FLT3_^1PLUS12 LDA- F+2,I_^1_€€%SAZ PLUS13-*-1_^1_%JMP* FLT3_^1PLUS13 LDA- BETA,I_^1_%SUB- ONEBIT_^1_%SAZ EXPO1-*-1_^1_%JMP* FLT3_^1EXPO1 JMP NXTOPC_'DENOMINATOR IS A +1.0--GET NEXT OPCODE_^1FLT3_!LDA- ONEBIT+13_#$2000_^1_%STA- SHIFCT,I_$TEMP STORAGE--MSB_^1_%LDA- BETA,I_^1_%TCA A_^1_%INA 1_^1_%STA- BETA,I_^1_%LDA- A,I_^1_%SAN FD2-*-1_%IF A .EQ 0_!GO TO ARG0_^1_%JMP ARG0_^1FD2_"LDA- AI,I_^1_%INA 0_^1_%M€€UI- AI,I_)-AI*AI IN QA REG_^1_%DVI- A,I_*(AI*AI)/A IN A REG. Q REG. CONTAINS REMAINDER_^1*_8NO ROUNDING IS REQUIRED ON LSB_^1_%SAM FD3-*-1_^1_%TCA A_,POS. A REG._^1_%ADD- B,I_*B-(AI*AI)/A_^1_%JMP* NORM_^1FD3_"AND- LPMSK+15_$NEG. A REG._#$7FFF_^1_%SUB- B,I_*(-B+(AI*AI)/A - $8000)_^1_%SAP FD4-*-1_^1_%ADD- ONEBIT+15_#NEG. A REG. $8000_^1_%TCA A_,B-(AI*AI)/A_^1_%JMP* NORM_^1FD4€€_"LDQ- AI,I_)POS. A REG._^1_%INQ -1_^1_%STQ- AI,I_)AI=AI-1_^1_%SAZ NORM-*-1_$A REG. = 0_^1_%TCA A_,A .NE. 0 B-(AI*AI)/A_^1NORM_!LDQ- AI,I_^1*_8FORM AI**2**-15 + (B-(AI*AI)/A)*2**-30_^1_%SAP STEP5E-*-1_"IF LOWER ACCUM IS NEGATIVE_^1_%INQ -1_+DECREMENT UPPER BY 1_^1_%ADD- ONEBIT+15_#$8000 - AND INCREMENT LOWER BY 1 TO PUT END_^1_%STA- TEMPQ,I_%AROUND BORROW INTO PROPER POSITION€€_^1_%SQP STEP5E-*-1_^1_%LDA- LPMSK+13_$DECREMENT MSB BY 1_#$1FFF_^1_%STA- SHIFCT,I_$TEMP STORAGE_^1_%LDQ- LPMSK+15_$$7FFF_^1_%LDA- TEMPQ,I_%Q-A CONTAINS AI*2**-15+(B-AI*AI/A)*2**-30_^1STEP5E ALS 1_^1_%LRS 1_^1_%DVI- A,I_^1_%INQ 0_^1_%STA- TEMPQ,I_%1/A(AI*2**-15+(B-AI*AI/A)*2**-30_)ISB_^1_%CLR A_^1_%LRS 1_^1_%DVI- A,I_^1_%LDQ- TEMPQ,I_PISB_^1_%ALS 1_^1_%LRS 2_^1_%ARS 1_^1_%€€AND- LPMSK+15_$$7FFF_^1_%STA- TEMGP2,I_OLSB_^1_%TRQ A_^1_%AND =N$3FFF_^1_%STA- TEMPQ,I_PISB_^1_%SAZ TST1-*-1_$IS ISB ZERO_^1_%JMP* CPROC_(NO_^1TST1_!LDA- TEMGP2,I_$YES_!LSB_^1_%SAZ DONE-*-1_$IS LSB ZERO_^1CPROC LDQ- SHIFCT,I_$NO_GMSB_^1_%LDA- TEMPQ,I_PISB_^1_%TCA A_^1_%INQ -1_^1_%STQ- SHIFCT,I_^1_%ADD- ONEBIT+15_#$8000_^1_%STA- TEMPQ,I_^1_%LDQ- TEMGP2,I_^1_%SQZ DONE-*-1_$IS €€LSB ZERO_^1_%INA -1_^1*_*Q REGISTER CONTAINS MSB_^1_%STA- TEMPQ,I_PISB_^1_%LDA- TEMGP2,I_^1_%TCA A_^1_%ADD- ONEBIT+15_#$8000_^1_%STA- TEMGP2,I_OLSB_^1DONE_!LDQ- SHIFCT,I_^1_%LDA- TEMPQ,I_%Q REG CONTAINS MSB_7ISB_^1_%ALS 1_^1_%LRS 1_^1_%DVI- A,I_^1_%STA- G,I_*MSB RESULT_^1_%LDA- TEMGP2,I_OLSB_^1_%ALS 1_^1_%LRS 1_^1_%DVI- A,I_^1_%STA- G+1,I_(ISB RESULT_^1_%CLR A_^1_%LRS 1_^1_€€%DVI- A,I_^1_%STA- G+2,I_(LSB RESULT_^1_%LDA- C,I_^1_%STA- T1,I_^1_%LDA- CI,I_^1_%STA- T2,I_^1_%LDA- D,I_^1_%STA- T3,I_^1_%LDA- ONEBIT_'$0001_^1_%STA- MULDIV,I_$MULTIPLY/DIVIDE FLAG_^1_%JMP SHIFTA_'SQUEEZE OUT CARRY SLOTS IN G+1 AND G+2_^1*_*END OF FDIV_^1_%EJT_]_^1FLTSET 0_"0_^1***_"IIN 0_,***UTILIZE FOREGROUND***_^1_%LDA- 3,Q_^1_%STA- F+2,I_^1_%STA- TEMGP2,I_$F+2_^1_%LDA- 2,Q_^€€1_%STA- F+1,I_^1_%LDA- 1,Q_^1_%STA- F,I_^1_%LDQ- F+1,I_^1_%STQ- TEMPQ,I_%F+1_^1_%SAP STEP2A-*-1_^1_%TCQ Q_S90*3018_^1_%STQ- TEMPQ,I_%COMPLEMENT F+1_890*3018_^1_%LDQ- TEMGP2,I_^1_%TCQ Q_^1_%STQ- TEMGP2,I_$COMPLEMENT F+2_^1*_83 CARDS DELETED_790*3018_^1_%TCA A_^1STEP2A STA- A,I_^1*_*IF F IS ZERO, GO TO ARGFO (SET BETA,A,B=0)_^1_%SAN A9-*-1_^1_%JMP* ARGF0_^1A9_#ALS 1_^1_%EOR- ON€€EBIT+15_#$8000_^1_%ARS 8_^1_%INA 0_^1ARGF0 STA- BETA,I_^1_%LDA- A,I_^1_%LDQ- TEMPQ,I_%F+1_^1_%LLS 8_^1_%AND- LPMSK+15_$$7FFF_^1_%STA- A,I_^1_%LDA- TEMGP2,I_$F+2_^1_%LDQ- TEMPQ,I_%F+1_^1_%LLS 23_^1_%AND- LPMSK+15_$$7FFF_^1_%STA- AI,I_^1_%LLS 15_^1_%AND* RSLTB_($7FC0_^1_%STA- B,I_^1_%LDA- F,I_^1***_"EIN 0_,***UTILIZE FOREGROUND***_^1_%JMP* (FLTSET)_^1_%EJT_]_^1*_$DIVIDE CHECK €€WHEN DIVIDE BY ZERO_^1DIVZER ENQ 1_^1_%JMP* SETERR_^1OVFUNF TRQ A_:OVERFLOW OR UNDERFLOW_^1*_*OVERFLOW_^1_%ENQ 0_^1_%SAP SETERR-*-1_^1*_*UNDERFLOW_^1_%ENQ 2_^1SETERR LDA- ERRORS,I_^1_%AND* ERASE,Q_^1_%ADD* SETBIT,Q_^1_%STA- ERRORS,I_^1_%LDA* RSLTA,Q_4SET F.P. ACCUMULATOR_^1_%STA- C,I_^1_%LDA* RSLTAI,Q_^1_%STA- CI,I_^1_%LDA* RSLTB,Q_^1_%STA- D,I_^1_%LDA* RSLTEX,Q_^1_%STA- DELTA€D,I_^1NXTOP3 JMP NXTOPC_^1*_*OVERFLOW, UNDERFLOW_^1RSLTB NUM $7FC0,$7FC0,$0000_^1RSLTAI NUM $7FFF,$7FFF,$0000_^1RSLTA NUM $7FFF,$7FFF,$0000_C90*3017_^1*_8EXPONENTS_^1RSLTEX NUM $7F,$7F,-$7F_^1ERASE NUM $7FFF,$BFFF,$DFFF_^1SETBIT NUM $8000,$4000,$2000_^1H807F NUM $807F_^1*_8END_6***** FTN 3.1 *****_^1_%END_]_^__ DPWGSYM2 CSY/ 07F P€1_%NAM GETSYM_'DECK-ID 07F FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^1_%SPC 3_^1* GETSYM IS USED IN PHASES A,B_^1* GETSYM USED IN PHASE B_^1* NON-IDENTICAL GETSYM IS USED IN PHASES C,D,E_^1* GET SYMBOL ROUTINE. ENTERED WITH 'ISYMX' BEING_^1* ABS€€OLUTE POINTER TO SYMBOL TABLE ENTRY. BRINGS IN_^1* PAGE CONTAINING THAT SYMBOL (IF NECESSARY) AND MAKES_^1* 'ISYM' RELATIVE TO THE CURRENT PAGE._^1* IF 'ISYMX' IS NEGATIVE AT ENTRY, OPERATES IN_^1* 'READ-ONLY' MODE...DOES NOT SAVE CURRENT PAGE BEFORE_^1* READING IN NEW ONE._^1_%ENT GETSYM_^1_%EXT WRITE,READ_^1* MASTER LABELLED COMMON BLOCK_^1_%DAT ETC1(43)_LFTN 3.3_^1_%DAT ICO€€MT(12+3)_IFTN 3.3_^1_%DAT ETC2(3)_MFTN 3.3_^1_%DAT IBCDTB(48)_JFTN 3.3_^1_%DAT LOOPT(3+50),IEQV(255+2),ISTAB(150+2)_^1_%DAT ETC3(1+25+11)_^1* SYMBOL TABLE LABELLED COMMON BLOCK_^1_%DAT ISYMN,ISYMFL,ISYMD,ISYMX,ISYMS,ISYMP_^1_%DAT ISYMPC,ISYMPS,ISYMNS,SYMTAB(960)_^1* SUBROUTINE GETSYM_^1GETSYM NOP_]_^1_%STQ* QSAV_^1* IFIRST=0_]_^1_%ENQ 0_^1_%STQ* IFIRST_^1* IF (ISYMX.GE.0) GO€€ TO 10_^1XAD_"LDA+ ISYMX_^1_%SAP S10_^1* ISYMX=-ISYMX_^1_%TCA A_^1_%STA* (XAD+1)_^1* IFIRST='NONZERO'_^1_%STA* IFIRST_^1* 10 ISYMP=(ISYMX/ISYMPS)*ISYMPS_^1S10_"DVI+ ISYMPS_^1_%EQU PSAD(S10)_^1_%MUI* (PSAD+1)_^1_%TRA Q_^1PAD_"STQ+ ISYMP_^1* ISYMX=ISYMX-ISYMP_^1_%TCQ Q_^1_%ADQ* (XAD+1)_^1_%STQ* (XAD+1)_^1* IF (ISYMP.EQ.ISYMPC) RETURN_^1PCAD_!SUB+ ISYMPC_^1_%SAZ RETURN_^1* IF (I€€FIRST.NE.0) GO TO 20_^1A_$LDA* IFIRST_^1_%SAN S20_^1* K=ISYMPS+96 (ISTABX IS PART OF SYMTAB PAGE IN A,B)_^1_%LDA* (PSAD+1)_^1_%INA 96_^1_%STA* K_^1* J=(ISYMPC/ISYMPS)*ISYMNS+1_^1* CALL WRITE (11,J,K,SYMTAB)_^1_%LDA* (PCAD+1)_^1_%LDQ =XWRITE_^1_%RTJ* IO_^1* 20 J=(ISYMP/ISYMPS)*ISYMNS+1_^1* ISYMPC=ISYMP_^1* CALL READ (11,J,K,SYMTAB)_^1S20_"LDA* (PAD+1)_^1_%STA* (PCAD+1)_^1_%LDQ €,=XREAD_^1_%RTJ* IO_^1* RETURN_]_^1RETURN LDQ* QSAV_^1_%JMP* (GETSYM)_^1*_]_^1IO_#NOP_]_^1_%STQ* CALL+1_^1_%ENQ 0_^1_%DVI* (PSAD+1)_^1_%MUI+ ISYMNS_^1_%INA 1_^1_%STA* J_^1CALL_!RTJ+ 0_^1_%ADC N11,J,K,SYMTAB_^1_%JMP* (IO)_^1*_]_^1_%BSS QSAV,IFIRST,K_^1_%EQU J(IFIRST)_^1N11_"NUM 11_^1_%END_]_^__ ,PWIOPRA CSY/ 08F P€1_%NAM IOPRBA_(DECK-ID 08F FORTRAN 3.3B_)SUMMARY-102_^1*_$FORTRAN COMPILER I/O PROCESSOR_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^1_%SPC 3_^1*_$USED IN PHASE A (ALL OVERLAYS)_^1_%SPC 5_^1* THIS SUB-VERSION IS FOR PHASE A ONLY._^1*_!INCLUDES UNIT RECORD BUFFERING_4IOPRB1_^€€1*_+OPTIMUM ALLOCATION_^1*_+OVERLAY ALLOCATION_^1*_+NO SCRATCH READING_^1* THE FOLLOWING REQUESTS ARE PROCESSED..._^1* CALL IOPR_,INITIALIZATION_^1* CALL READ (U,M,L,A)_!INPUT_^1* CALL WRITE (U,M,L,A) OUTPUT_^1* CALL EXIT_,RETURN TO O.S._^1* WHERE..._]_^1*_!U IS ADR OF LOGICAL UNIT NR_^1*_!M IS ADR OF MODE (IF U.LT.11)_^1*_'ADR OF RECORD NR (IF U.GE.11)_^1*_!L IS ADR OF LENGTH€€ (IGNORED IF U = 9 OR 10)_^1*_!A IS ADR OF USER'S AREA_^1* LOGICAL UNIT NUMBERS FOR 'IOPR'..._^1*_"0 IS SYMBOL REFERENCE FILE_^1*_"1 IS STANDARD INPUT DEVICE_^1*_"2 IS STANDARD BINARY OUTPUT DEVICE_^1*_"3 IS STANDARD LIST DEVICE_^1*_"4 IS STANDARD COMMENT DEVICE_^1*_"9 IS DISC SCRATCH FILE 1_^1*_!10 IS DISC SCRATCH FILE 2_^1*_!11 IS SYMBOL TABLE_^1*_!12 IS LOAD-AND-GO FILE_^1*_!13-€€17 ARE OVERLAYS 1-5 IN VERSION 2.0B_^1*_!18 IS MACRO LIBRARY FILE_^1_%ENT OPTC,LOADC_^1_%EXT COA,COKLG_G**FTN 3.0**_^1_%EXT MAXSEC_L77*1879_^1_%EXT PAGCHK_NFTN 3.3_^1_%EXT EXITF_OFTN 3.3_^1_%EXT DIAG_PFTN 3.3_^1_%ENT CRDBF,CBAV_F**FTN 3.0**_^1*_]_^1_%ENT IOPR,READ,WRITE,EXIT_^1_%ENT WAIT_^1_%DAT IFLAGS_NFTN 3.3_^1_%DAT LINECT_NFTN 3.3_^1_%DAT LINCT1_NFTN 3.3_^1_%DAT IR€€_RFTN 3.3_^1_%DAT IK_RFTN 3.3_^1_%DAT IP_RFTN 3.3_^1_%DAT IA_RFTN 3.3_^1_%DAT IL_RFTN 3.3_^1_%DAT IM_RFTN 3.3_^1_%DAT IXLGO_OFTN 3.3_^1_%DAT IOPTO_OFTN 3.3_^1_%DAT IOPTV_OFTN 3.3_^1_%DAT IOPTC_OFTN 3.3_^1_%DAT IOPTD_OFTN 3.3_^1_%DAT STRTMC_NFTN 3.3_^1_%DAT NBRMAC_NFTN 3.3_^1_%DAT MACSEC_NFTN 3.3_^1_%DAT IERRS(16)_KFTN 3.3_^1_%DAT SREFAD_NFTN 3.3_^1_%DAT LGO_QFTN 3.3€€_^1_%DAT ISCRI_OFTN 3.3_^1_%DAT ISCRO_OFTN 3.3_^1_%DAT IX_RFTN 3.3_^1_%EQU X2($24),X3($04),XFF($0A)_^1*_]_^1******************************************************_^1* 'READ' AND 'WRITE' ENTRIES_8*_^1******************************************************_^1*_]_^1READ_!NOP 0_^1_%STQ* QSAV_^1_%LDA =N$08FD_"INPUT COMMENT DEVICE CODE_^1_%STA* DC+3_^1_%LDA =N$4801_%'FREAD' REQUEST€€ CODE_.**FTN 3.0**_^1_%LDQ* READ_%GET LINK._^1_%JMP* IOPROC_^1_%SPC 2_^1WRITE NOP 0_^1_%STQ* QSAV_^1_%LDA =N$08FC_"OUTPUT COMMENT DEVICE CODE_^1_%STA* DC+3_^1_%LDA =N$4C01_%'FWRITE' REQUEST CODE_-**FTN 3.0**_^1_%LDQ* WRITE_$GET LINK._^1_%SPC 2_^1IOPROC STQ* LINK_%SAVE LINK._^1_%STA* REQ+1_$SET REQUEST TYPE._^1_%LDA- I_)SAVE $FF._^1_%STA* ISAV_^1_%LDQ* (LINK)_#GET LOGICAL UNIT€€ NUMBER._^1_%RAO* LINK_^1_%STQ* REQ+4_^1_%LDQ* (REQ+4)_^1_%STQ- I_)SAVE._^1_%LDA* (LINK)_#GET SECTOR ADDRESS OR MODE._^1_%RAO* LINK_^1_%STA* RECAD_^1_%LDA* (LINK)_#GET RECORD LENGTH._^1_%RAO* LINK_^1_%STA* REQ+5_^1_%LDA* (REQ+5)_^1_%STA* REQ+5_^1_%LDA* (LINK)_#GET USER'S AREA ADDRESS._^1_%STA* REQ+6_^1_%SQN TAG001_'TEST FOR UNIT 0_^1_%JMP SYMTRA_^1TAG001 INQ -2_+TEST LOGICAL UNI€€T N9 FOR STD.IN_^1_%SQP 1_^1_%JMP* BUFIN_'YES_^1_%INQ -1_(TEST FOR STD OUTPUT_^1_%SQN 2_^1_%JMP BUFOUT_%YES_^1_%INQ -6_(TEST FOR MASS STORAGE_^1_%SQM 1_^1_%JMP* MS_^1_%LDQ* (RECAD)_"GET MODE AND DEVICE CODE..._^1_%LDA* DC-1,I_%COMBINE AND STORE._^1_%ALS 4_^1_%LRS 4_^1_%STA* REQ+4_^1_%LDA =N$1802_"IF NOT M.S. REQ, SET 1ST WORD_^1_%STA* REQ+7_'AFTER PARAMS TO 'JMP *+2'._^1_%€€JMP* REQ_^1_%SPC 2_^1MS_#INQ -2_(M.S. CALL, TEST FOR SCRATCH._^1_%SQP 2_^1_%JMP SWRITE_#PHASE A CANNOT READ SCRATCH_^1_%LDA =N$08B3_"NO- SYMTAB, LGO, OR OV. UNIT =_^1_%STA* REQ+4_'SCRATCH DISC, MORE SIGNIF._^1_%ENA 0_+PART OF SECTOR NR =0,_^1_%STA* REQ+7_'STARTING SECTOR NR = BASE_^1_%LDA* SN,Q_(FOR THAT FILE_^1MS1_"ADD* (RECAD)_$+ RECORD NUMBER_^1_%STA* REQ+8_^1_%SPC 2_^1R€€EQ_"RTJ- ($F4)_$I/O REQUEST..._^1_%NUM 0_+REQUEST CODE_^1_%ADC 0_+COMPLETION ADDRESS_^1THREAD ADC 0_+REQUEST THREAD_^1UNIT_!NUM 0_+LOGICAL UNIT NR_^1_%NUM 0_+LENGTH_^1_%ADC 0_+STARTING ADDRESS_^1_%NUM 0_+MSP OF SECTOR NR, OR JMP *+2_^1_%NUM 0_+LSP OF SECTOR NR_^1_%LDA* THREAD_#HANG ON THREAD TILL I/O DONE._^1_%SAZ 1_^1_%JMP* *-2_^1_%SPC 2_^1REQDON RAO* LINK_%RESTORE REGIS€€TERS_^1_%LDQ* QSAV_(AND RETURN._^1_%LDA* ISAV_^1_%STA- I_^1_%JMP* (LINK)_^1_%SPC 1_^1* LINK_!- ADDRESS OF PARAMETERS, RETURN ADDRESS._^1* QSAV_!- (Q) AT CALL._^1* ISAV_!- (I) AT CALL._^1* RECAD - ADDRESS OF MODE OR RECORD NUMBER, IN CALL._^1* SN_#- RELATIVE SECTOR NR OF SYMBOL TABLE._^1* +1_"- RELATIVE SECTOR NR OF LOAD-GO FILE, -1._^1* +2..6 - RELATIVE SECTOR NRS OF OVERLAYS 1€€..5._^1* DC_#- 'UNIT NR' VALUES FOR STANDARD I/O UNITS._^1_%SPC 1_^1_%BSS LINK,QSAV,ISAV,RECAD_^1_%BZS SN(8)_^1DC_#NUM $08F9,$08FA,$08FB,0_^1_%SPC 1_^1*_]_^1******************************************************_^1* INPUT BUFFERING ROUTINE_;*_^1******************************************************_^1*_]_^1BUFIN LDQ CBAV_)WAIT TILL BUFFER ID AVAILABLE_^1_%SQZ 1_+BY HANGING €€ON THREAD OF_^1_%JMP* BUFIN_'REQUEST THAT LOADS IT._^1BI0_"LDQ* REQ+5_$PERFORM TRANSFER...GET LENGTH_^1_%INQ -1_^1BI1_"LDA CRDBF,Q_%FROM REQUEST ,MOVE_^1_%STA* (REQ+6),Q_"DATA FROM BUFFER TO_^1_%INQ -1_*USER'S AREA UNTIL COUNT IS_^1_%SQM 1_+EXHAUSTED._^1_%JMP* BI1_^1*_] FTN 3.3_^1*_$CHECK INPUT BUFFER FOR A COMMENT CARD_4FTN 3.3_^1*_] FTN 3.3_^1_%LDA CRDBF_(GET FIRST WORD RE€€AD_3FTN 3.3_^1_%AND- $1A_*GET FIRST CHARACTER_3FTN 3.3_^1_%ARS 8_SFTN 3.3_^1_%INA -$24_)IS IT A '$'_;FTN 3.3_^1_%SAZ BIT7_)YES_CFTN 3.3_^1_%INA -6_+IS IT AN '*'_:FTN 3.3_^1_%SAZ BIT7_)YES_CFTN 3.3_^1_%INA -$19_)IS IT A 'C'_;FTN 3.3_^1_%SAN 1_,NO_DFTN 3.3_^1BIT7_!JMP* BI7_*COMMENT FOUND, IGNORE LINE_,FTN 3.3_^1_%CLR A_^1_%STA LABLFG_^1BI2_"LDA CRDBF_^1_%EOR BLANKS_^1_%SAZ€€ 1_^1_%JMP* BI20_)COLMS 1,2 NOT BLANK_^1_%LDA CRDBF+1_^1_%EOR BLANKS_^1_%SAZ 1_^1_%JMP* BI20_)COLMS 3,4 NOT BLANK_^1_%LDA CRDBF+2_^1_%AND =N$FF00_^1_%EOR =N$2000_^1_%SAZ 1_^1_%JMP* BI20_)COLM 5 NOT BLANK_^1BI21_!STA- I_^1_%ENA 7_+WITH OR WITHOUT INTERNAL_^1_%STA* RECAD_'BLANKS, IN COLS. 7-72._^1BI3_"LDQ* RECAD_$TEST FOR THIS WITH SAME_^1_%INQ 1_+ALGORITHM THAT 'GNST'_^1_%€€QRS 1_+USES..._^1_%LDA CRDBF-1,Q_^1_%LDQ* RECAD_^1_%QLS 15_^1_%SQP 1_^1_%ARS 8_^1_%AND- XFF_^1_%INA -$7F_'GET CHARACTERS FROM INPUT..._^1_%SAP BI5_(IGNORE IF BLANK, ELSE COMPARE_^1_%INA $7F-$20_$TO SUCCESSIVE CHARACTERS OF_^1_%SAZ BI4_)'END'._^1_%SUB* IENDBF,I_^1_%SAZ BI35_^1_%JMP* BI6_*NOT END BUT MAYBE MON_^1BI35_!RAO- I_+CHARACTER, NOT 'END' CARD..._^1BI4_"LDA* RECAD_'€€ELSE SCAN THRU COL 72. IF AT_^1_%INA -72_)END OF SCAN, INDEX TO 'END'_^1_%SAP BI5_)IS NOT POINTING JUST BEYOND_^1_%RAO* RECAD_''D', STATEMENT WASN'T 'END'._^1_%JMP* BI3_'PAPER TAPE AND TTY INPUT MAY_^1BI5_"LDQ- I_^1_%INQ -3_^1_%SQN 1_^1_%JMP* BI22_^1BI6_"LDA CRDBF_(NOT END_^1_%SUB =N$4D4F_%CHECK MON COLM 1_^1_%SAN 1_^1_%JMP* BI9_*MON IN WRONG FORM_^1_%LDA CRDBF_(MAY BE COR€€RECT MON_^1_%SUB* MON_)FIXED FORMAT OF 'MON' CARD_^1_%SAN BI7_)MAKES SIMPLE CHECK POSSIBLE._^1_%LDA CRDBF+1_^1_%SUB* MON+1_^1_%SAZ BI9_^1BI7_"LDA* BLANKS_#BLANK OUT CARD BUFFER_^1_%ENQ 40_*(IN CASE INPUT IS FROM PAPER_^1BI8_"STA CRDBF-1,Q_#TAPE OR TTY WHICH GIVE_^1_%INQ -1_*SHORT RECORDS)_^1_%SQZ 1_+AND START RELOADING IT._^1_%JMP* BI8_^1_%RTJ* LOADC_^1BI9_"JMP* REQDON_#RETU€€RN TO CALLER._^1BI20_!LDA CRDBF+2_%GET CHARS 5,6_^1_%AND =N$00FF_^1_%INA -$20_^1_%SAZ PTFLG_(IF BLANK SKIP_^1_%LDA CRDBF+2_^1_%AND =N$FF00_^1_%INA $20_*PUT BACK_^1_%STA CRDBF+2_^1PTFLG ENA 1_,SET FLAG_^1_%STA* LABLFG_^1_%ENA 0_^1_%JMP* BI21_^1BI22_!LDA* LABLFG_^1_%INA -1_^1_%SAZ 1_^1_%JMP* BI9_*END CARD OK_^1_%RTJ* ENDIAG_'DIAG FOR LABLED END CARD_^1_%JMP* BI9_^1ENDIAG€€ NOP 0_^1_%LDA LBRX_*SET LINE BUFF REQ INDX_^1_%STA- I_^1_%LDA LBAV,I_'CHECK FIR BUFFER AVAILABLE_^1_%SAZ 1_^1_%JMP* *-3_*HANG TIL L AVAILABLE_^1_%ENA 4_^1_%STA LBLEN,I_%4 TO LENGTH_^1_%ENQ 3_^1_%LDA* DIAGWD,Q_$FILLIN_^1_%STA LB,B_)DIAG MESSAGE_^1_%INQ -1_+UNTIL_^1_%SQM 1_,DINE_^1_%JMP* *-5_^1_%RTJ DLB,I_(START OUTPUTING MESSAGE_^1_%LDA NLBRX,I_%STEP BFR REQ INDEX_^1_%€€STA LBRX_)FOR NEXT REQUEST_^1_%JMP* (ENDIAG)_^1IENDBF NUM $25,$2E,$24,$26,$29,$2C,$25_*ENDFILE_^1DGWDAD ADC DIAGWD_^1DIAGWD ALF 4, *N, 12_^1LABLFG NUM 0_^1BLANKS ALF 1,_^1MON_"ALF 2, MON_^1_%SPC 2_^1LOADC NOP_]_^1_%RTJ- ($F4)_^1_%NUM $4801,0_I**FTN 3.0**_^1CBAV_!ADC 0,$18F9,41,CRDBF_^1TAGFS2 LDA* CBAV_)HANG ON THE THREAD_-*4.0/77*1877_^1_%SAZ TAGFS1_G*4.0/77*1877_^1_%J€€MP* TAGFS2_G*4.0/77*1877_^1TAGFS1 LDQ* CBAV+1_'GET V-FIELD_4*4.0/77*1877_^1_%SQP TAGFS3_(NO ERROR_7*4.0/77*1877_^1_%JMP EXIT1_(ERROR,ABORT_4*4.0/77*1877_^1TAGFS3 JMP* (LOADC)_%GO PROCESS THE CARD_^1WAIT_!NOP 0_^1_%LDA* LBAV_*CHECK STATUS OF BOTH_^1_%ADD DLB2+4_(BUFFERS, WAIT TILL_^1_%SAZ 1_-BOTH THREADS ARE_^1_%JMP* *-4_+ZERO BEFORE CONTINUING_^1_%JMP* (WAIT)_'RETURN TO CALLER_€€^1OPTFOR ALF 2, OPT_'OPT FORMAT_8**FTN 3.0**_^1OPTC_!LDA* CRDBF_(GET COLUMNS 1 AND 2_,*4.0/77*1877_^1_%SUB* OPTFOR_'COMPARE TO . O._3**FTN 3.0**_^1_%SAZ 2_^1_%JMP COKLG_(NOT OPT CARD -- ASSUME OPTIONS LPX **FTN 3.0**_^1_%LDA* CRDBF+1_%GET COLMS 3+4_^1_%SUB* OPTFOR+1_$COMPARE TO .PT._3**FTN 3.0**_^1_%SAZ 2_^1_%JMP COKLG_(NOT OPT CARD_6**FTN 3.0**_^1_%JMP COA_*GO TO STD INP DEV€€ICE FOR OPTIONS_^1_%EJT_]_^1CRDBF ALF 28,_^1_%ALF 19,_^1_%EJT_]_^1*_]_^1******************************************************_^1* OUTPUT BUFFERING ROUTINE_:*_^1******************************************************_^1*_]_^1BUFOUT LDA* LBRX_%SET LINE BFR REQ INDEX_^1_%STA- I_^1_%RTJ PAGCHK_'BUMP LINE CTR AND CHK FOR END OF PAGE FTN 3.3_^1_%LDA* LBAV,I_#HANG ON CURRENT BFR-AVBL€€ THD_^1_%SAZ 1_^1_%JMP* *-2_^1BO1_"LDQ+ REQ+5_$MOVE MSG LENGTH_^1_%STQ* LBLEN,I_$TO CURRENT BFR REQ_^1_%INQ -1_(MOVE MSG_^1BO2_"LDA (REQ+6),Q_#FROM USERS AREA_3**FTN 3.0**_^1_%STA* LB,B_(TO CURRENT BFR_^1_%INQ -1_^1_%SQM 1_^1_%JMP* BO2_^1_%RTJ* DLB,I_$START DUMPING CURRENT BFR_^1_%LDA* NLBRX,I_"STEP BFR REQ INDEX TO VALUE_^1_%STA* LBRX_(FOR NEXT BFR IN CHAIN_^1*_83 CARDS DELET€€ED_7FTN 3.3_^1BO3_"JMP+ REQDON_^1*_815 CARDS DELETED_6FTN 3.3_^1_%SPC 2_^1LBRX_!NUM 0_)LINE BUFFER INDEX_^1DLB_"NOP 0_)1ST DUMP-BFR SUBROUTINE_^1_%RTJ- ($F4)_^1_%NUM $4C01,0_I**FTN 3.0**_^1LBAV_!NUM 0,$18FB_"1ST BFR-AVBL FLAG_^1LBLEN NUM 0_)1ST MSG-LENGTH WORD_^1_%ADC LB_(ADR OF 1ST BFR_^1_%JMP* (DLB)_^1LB_#BSS LB(47)_#1ST LINE BFR_^1NLBRX ADC *-DLB+1_"INDEX OF NEXT BFR €€REQ_^1_%SPC 2_^1DLB2_!NOP 0_)2ND DUMP-BFR REQ_^1_%RTJ- ($F4)_^1_%ADC $4C01,0,0,$18FB,0,LB2_;**FTN 3.0**_^1_%JMP* (DLB2)_^1LB2_"BSS LB2(47)_^1_%ADC 0_)CHAIN LOOPS BACK TO 1ST REQ_^1_%EJT_]_^1*_]_^1******************************************************_^1* SCRATCH FILE PROCESSING_;*_^1******************************************************_^1*_]_^1* SA_#- START ADR FOR SCRATCH XF€€R_^1* NWR_"- NR OF WDS YET TO BE MOVED, THIS CALL._^1* SECT_!- TOTAL NR OF SCRATCH SECTORS NOW ON DISC._^1* REM_"- NR OF WORDS MOVED SO FAR, THIS CALL._^1* WPT_"- WRITE POINTER, TO CURRENT BUFFER._^1* PGSIZS - SCRATCH 'PAGE' SIZE IN SECTORS._^1* PGSIZW - SCRATCH 'PAGE' SIZE IN WORDS._^1* NOTE- THIS VERSION HAS BEEN MOOIFIED TO WRITE 3-_^1* PAGE BLOCKS ON THE OUTPUT FILE._^1_%SPC 1€€_^1_%BSS SA,NWR,SECT,REM,WPT_^1_%EQU PGSIZS(2),PGSIZW(PGSIZS*96)_^1WDSPPG ADC PGSIZW_^1WPPM1 ADC PGSIZW-1_^1_%SPC 2_^1SWRITE LDA (RECAD)_"TEST FOR 'M' PARAM .LT.0- THIS_^1_%SAP W1_*REQUESTS EMPTYING OUTPUT BFR._^1_%RTJ* DUMPW1_^1F2_#LDA* WB1AV_'WAIT TILL BUFFER IS EMPTY,_^1_%SAZ 1_^1_%JMP* F2_^1W0_#JMP+ REQDON_%THEN RETURN._^1W1_#LDA REQ+6_$GET USER'S AREA ADDRESS._^1_%ST€€A* SA_^1_%LDQ* WPT_'WRITE POINTER_^1_%LDA* (SA)_%GET RECORD LENGTH (FROM 1ST_^1_%INA -1_*WORD OF RECORD) AND PUT IN_^1_%STA* NWR_)WORD COUNTER._^1_%LDA* WPPM1_$COMPUTE REMAINING WORDS IN_^1_%SUB* WPT_)WRITE BUFFER._^1S2_#STQ- I_^1_%STA* REM_'SAVE NR OF WORDS REMAINING IN_^1_%TRA Q_+BUFFER AND COMPARE TO REMAIN-_^1_%SUB* NWR_)DER OF WORDS IN RECORD._^1_%SAM 1_)RECORD OVERLAPS PAG€€ES_^1_%LDQ* NWR_'RECORD DOES NOT OVERLAP_^1W2_#LDA* (SA),Q_#MOVE WORD FROM USER'S AREA_^1_%STA* WBUF1,B_$TO CURRENT BUFFER._^1_%RAO* WPT_'BUMP WRITE POINTER..._^1S4_#INQ -1_*AND DECREMENT COUNT._^1_%SQM 1_)IS COUNT EXHAUSTED_^1_%JMP* W2_^1_%LDA* WDSPPG_^1W3_#SUB* WPT_'IS WRITE BUFFER EMPTY_^1_%SAZ W4_^1_%JMP* (W0+1)_%NO, RETURN._^1W4_#RTJ* DUMPW1_#INITIATE DUMPING OF_^1W6_#LDQ* €€WB1AV_'WRITE BUFFER. HANG ON_^1W7_#SQZ 1_+THREAD TILL EMPTY._^1_%JMP* W6_^1_%ENA 0_)CLEAR WRITE POINTER._^1_%STA* WPT_^1MSCA_!RAO* REM_'INCREMENT STARTING ADDRESS BY_^1_%LDA* SA_*NUMBER OF WORDS PROCESSED SO_^1_%ADD* REM_)FAR._^1_%STA* SA_^1_%LDQ* CTR_'BUMP FILE INDEX_^1_%SQM M1_*BY 2,2,8,2,2,8,..._^1_%ENA 2_+ON SUCCESSIVE PASSES,_^1_%INQ -1_*THUS WRITING_^1_%JMP* M2_*SIX-SEC€€TOR SCRATCH PAGES_^1M1_#ENA 8_+FROM A TWO-SECTOR_^1_%ENQ 1_+PACK AREA._^1M2_#STQ* CTR_^1_%ADD* CSN2_^1_%STA* CSN2_^1S13_"SUB* SECT_%TEST FOR OVERFLOW OF SCRATCH._^1_%SAM S14_^1_%JMP ABORT_^1CTR_"NUM 1_^1S14_"LDA* NWR_'DECREMENT NR OF WDS REMAINING_^1_%SUB* REM_)BY NR OF WDS PROCESSED_^1_%STA* NWR_)SO FAR._^1_%INA 1_)TRANSFER COMPLETE IF NWR = REM._^1_%SAN 1_^1_%JMP* (W0+1)_^€€1_%LDA* WPPM1_$ELSE LOAD REMAINDER AND POINTER_^1_%ENQ 0_+AND CONTINUE._^1_%JMP* S2_^1_%SPC 1_^1_%SPC 2_^1*_]_^1******************************************************_^1* MASS STORAGE BUFFER IN/OUT ROUTINES_/*_^1******************************************************_^1*_]_^1* CSN2_!- CURRENT SECTOR NUMBER FOR FILE 2._^1DUMPW1 NOP 0_^1_%RTJ- ($F4)_^1_%NUM $4C01_K**FTN 3.0**_^1_€€%ADC 0_^1WB1AV ADC 0_^1_%NUM $08B3_^1_%ADC PGSIZW_^1_%ADC WBUF1_^1_%NUM 0_^1CSN2_!NUM 0_^1_%JMP* (DUMPW1)_^1_%EJT_]_^1*_]_^1*_$BUFFER WRITES TO SYMBOL REFERENCE FILE_^1*_]_^1SYMTRA LDA* SYMFLG_^1_%SAM TAG3_^1_%JMP* SYMEXT_'EXIT IF SYMREF.FILE FULL_^1TAG3_!LDA REQ+6_^1_%STA* SYMAD_^1_%LDA REQ+5_^1_%TCA A_^1_%INA 0_^1_%STA- I_^1_%LDQ* SYMIND_^1SY2_"LDA- I_^1_%SAM SY3_^1€€_%STQ* SYMIND_^1SYMEXT JMP REQDON_^1SY3_"SQM TAG4_^1_%RTJ* SYMDMP_^1TAG4_!LDA* (SYMAD)_^1_%STA SYMBUF+96,Q_^1_%RAO- I_^1_%RAO* SYMAD_^1_%INQ 1_^1_%JMP* SY2_^1SYMIND NUM -96_^1SYMAD NUM 0_^1SYMDMP ADC 0_^1_%RTJ- ($F4)_(DUMP ONE SECTOR ONTO THE_^1_%NUM $4C01_(SYMBOLIC REFERENCE FILE_^1_%ADC 0_^1SYMTHR ADC 0_^1_%NUM $08B3_^1_%ADC 96_^1_%ADC SYMBUF_^1_%ADC 0_^1SYMSEC ADC€€ 0_^1TAG6_!LDA* SYMTHR_^1_%SAZ TAG5_^1_%JMP* TAG6_^1TAG5_!RAO* SYMSEC_^1_%RAO* SYMFLG_^1_%LDA* SYMFLG_^1_%SAM SYMOK_^1_%RTJ DIAG_)DIAGNOSTIC BECAUSE THE SYMBOLIC_^1_%ADC SYMDG_(REFERENCE TABLE IS FILLED_^1_%RAO* SYMFLG_^1_%JMP* SYMEXT_^1SYMOK ENQ -96_^1_%JMP* (SYMDMP)_^1SYMFLG NUM -160_^1SYMDG ADC $3000+110_#DON'T PRINT MON-FATAL ERROR NO.111_^1_%EJT_]_^1*****************€€*************************************_^1* 'IOPR' ENTRY_F*_^1******************************************************_^1*_]_^1IOPR_!NOP 0_^1_%LDA* IOPR_^1_%INA -1_^1_%STA LINK_^1_%RTJ DYNDSK_#DYNAMICALLY ALLOCATE DISC_^1_%ENA 0_)CLEAR WRITE POINTER_^1_%STA WPT_^1_%RTJ LOADC_$START LOADING CARD BFR_^1_%JMP REQDON_#RETURN TO 'GO' ROUTINE._^1SCRLUF NUM 0_,SCRATCH/LIBRARY DIFFERE€€NT FLAG_'PSR 1180_^1_%SPC 2_^1DYNDSK NOP 0_^1_%LDA- $B3_*ARE SCRATCH_:PSR 1180_^1_%SUB- $C2_*AND LIBRARY UNITS DIFFERENT_*PSR 1180_^1_%STA* SCRLUF_'SCRLUF EQ 0 SAME, SCRLUF NE 0 DIFFER PSR 1180_^1_%LDA MAXSEC_'LARGEST SCRATCH SECTOR_.77*1879_^1_%LDQ* SCRLUF_'IF UNITS ARE DIFFERENT_/PSR 1180_^1_%SQN STASEC_'SET SECT TO MAXSEC_3PSR 1180_^1_%SUB- $C1_'SUBTRACT S.N. OF SCRATCH ARE€€A._^1*_81 CARD REMOVED FOR PSR 90*2673_(90*2190_^1STASEC STA SECT_)SAVE TOTAL SCRATCH SIZE_.PSR 1180_^1_%LDA- $E4_'ADDRESS OF LOAD/GO AREA PLUS 1_^1_%ADD =N162_(1 CYLINDER + 2 SECTORS_^1_%STA SN_^1_%SQN ROUND_(SKIP COMPUTATION OF SCRATCH SIZE_$PSR 1180_^1_%ADD- $C1_'ROUND OVERLAY LOCATION UP TO_^1*_8START OF A CYLINDER, TO (PSR 90*2673) 90*2190_^1ROUND INA -2_P81*2970**_^1_%€€TRA Q_+MINIMIZE NUMBER OF SEEKS BY_^1_%LRS 16_*ASSURING THAT ALL OVERLAY_^1_%DVI =N160_'PAGES FALL WITHIN A CYLINDER._^1_%SQN 3_-***PSR 68 * 1503 BEGIN ***_^1_%LDA SN_,***PSR 68 * 1503 END_!***_^1_%JMP* LEAVE_^1_%TCQ A_^1_%ADD =N160_^1_%ADD SN_^1*_5ALLOCATE SCRATCH FOR LOCALS..._^1*_$SECTOR 000 NOT USED, SECTOR 001 USED BY SAVE-ID ROUTINE_!84*2541_^1LEAVE STA SN+2_)FORTA1€€ AT CYL 1 SEC 000_/84*2541_^1_%INA 38_R84*2541_^1_%STA SN+3_)FORTA2 AT CYL 1 SEC 040_/FTN 3.0_^1_%INA 60_RFTN 3.0_^1_%STA SN+4_)FORTA3 AT CYL 1 SEC 100_/FTN 3.0_^1_%INA 60_RFTN 3.0_^1_%STA SN+5_)FORTA4 AT CYL 2 SEC 000_^1_%INA 80_R84*2541_^1_%STA SN+6_)FORTA5 AT CYL 2 SEC 080_/84*2541_^1_%INA 80_R84*2541_^1_%STA SN_+SYMTAB AT CYL 3 SEC 000_/84*2541_^1_%ADD =N160_P84*2541_€€^1_%STA SYMSEC_'SYMBOL REF FILE AT CYL 4 SEC 000_%FTN 3.3_^1_%STA SREFAD_^1_%ADD =N160_(ALLOCATE 1 CYL FOR SYMBOL REF. FILE_"FTN 3.3_^1_%STA SN+7_)MACRO LIBRARY AT CYL 5 SEC 000_(FTN 3.3_^1_%ADD =N160_)ALLOCATE 1 CYL FOR MACROS_-FTN 3.3_^1*_$STA CSN1_)SCRATCH 1 - UNUSED IN PHASE A_)84*2541_^1_%INA 3*PGSIZS_L84*2541_^1_%STA CSN2_)SCRATCH 2 AT CYL 6 SEC 006_,FTN 3.3_^1_%LDQ N€€BRMAC_^1_%LDA SN+7_^1_%SQN TAG7_^1_%STA STRTMC_^1_%JMP* (DYNDSK)_^1TAG7_!EOR STRTMC_^1_%SAN TAG8_)SKIP IF NOT THE SAME_^1_%JMP* (DYNDSK)_^1_%EJT_]_^1*_]_^1*_$MOVE EXISTING MACROS UP TO NEW STRTMC ADDRESS_^1*_]_^1_%SPC 1_^1TAG8_!LDA STRTMC_^1_%LDQ MACSEC_'GET NUMBER OF SECTORS_^1_%INQ -1_+OF THE OLD MACRO LIBRARY_^1_%AAQ A_^1_%STA* SECRD_^1_%LDA SN+7_^1_%STA STRTMC_^1_%A€€AQ A_^1_%STA* SECWR_^1TRANSF RTJ- ($F4)_(READ ONE SECTOR_^1_%NUM $4800_^1_%ADC 0_^1TH1_"ADC 0_^1_%NUM $08B3_^1_%NUM 96_^1_%ADC SYMBUF_^1_%ADC 0_^1SECRD ADC 0_^1TAG10 LDA* TH1_^1_%SAZ TAG9_^1_%JMP* TAG10_^1TAG9_!RTJ- ($F4)_(WRITE IT ON A NEW AREA_^1_%NUM $4C00_^1_%ADC 0_^1TH2_"ADC 0_^1_%NUM $08B3_^1_%NUM 96_^1_%ADC SYMBUF_^1_%ADC 0_^1SECWR NUM 0_^1TAG13 LDA* TH€€2_^1_%SAZ TAG12_^1_%JMP* TAG13_^1TAG12 SQN TAG11_(IS TRANSFER OVER_^1_%JMP* (DYNDSK)_^1TAG11 INQ -1_+UPDATE_^1_%LDA* SECRD_(SECTOR_^1_%INA -1_+ADDRESSES_^1_%STA* SECRD_^1_%LDA* SECWR_^1_%INA -1_+THEN_^1_%STA* SECWR_(GO_^1_%JMP* TRANSF_'ON_^1_%EJT_]_^1_%SPC 1_^1* WBUF1 - OUTPUT BUFFER, OVERLAYING 'IOPR'._^1_%SPC 1_^1_%ORG IOPR_^1_%BSS WBUF1(PGSIZW)_^1_%BZS SYMBUF(96)_^1_€€%SPC 2_^1EXIT1 FWRITE $FC,EXIT,NEATO,6,,,,I,,1_:81*2174_^1_%JMP- ($EA)_H*4.0/77*1877_^1ABORT FWRITE $FC,,SO,1,A,0,1,I,,1_:**FTN 3.0**_^1*_]_^1******************************************************_^1* 'EXIT' ENTRY_F*_^1******************************************************_^1*_]_^1EXIT_!NOP 0_^1_%RTJ EXITF_PFTN 3.3_^1SO_#ALF 1,SO_^1NEATO ALF 6,INPUT ERROR_GFTN 3.3_^1_%END_]_€^__ PWPACK CSY/ 09F P€1_%NAM PACK_)DECK-ID 09F FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^1_%SPC 3_^1* PACK IS USED IN PHASES A,D,E_^1* INPUT IS ADDRESS AND LENGTH OF A STRING HAVING ONE_^1* CHARACTER PER WORD. STRING IS PACKED LEFT TO TWO_^1* CHARACTERS PER WORD._^1_%E€€NT PACK_^1* SUBROUTINE PACK (IX1,IX2)_^1PACK_!NOP_]_^1_%STQ* QSAV_^1_%LDA- I_^1_%STA* ISAV_^1_%LDA* (PACK)_^1_%RAO* PACK_^1_%INA -1_^1_%STA* IX1AD_^1_%LDA* (PACK)_^1_%RAO* PACK_^1_%STA* IX2AD_^1* NR=(IX2+1)/2_^1_%LDA+ 0_^1_%EQU IX2AD(*-1)_^1_%INA 1_^1_%ARS 1_^1_%STA* NR_^1* J=1_]_^1_%ENQ 1_^1* DO 10 K=1,NR_^1_%STQ- I_^1* IX1(K)=IX1(J)*256+IX1(J+1)_^1LOOP_!LDA+ 0,Q_^1_%EQU IX€N1AD(*-1)_^1_%ALS 8_^1_%INQ 1_^1_%ADD* (IX1AD),Q_^1_%STA* (IX1AD),I_^1* J=J+2_]_^1_%INQ 1_)ALREADY BUMPED BY 1_^1* 10 CONTINUE_^1_%RAO- I_^1_%LDA- I_^1_%SUB* NR_^1_%SAM BACK_^1_%SAZ BACK_^1* RETURN_]_^1_%LDQ* ISAV_^1_%STQ- I_^1_%LDQ* QSAV_^1_%JMP* (PACK)_^1BACK_!JMP* LOOP_^1*_]_^1_%BSS QSAV,ISAV_^1_%EQU NR(IX2AD)_^1_%END_]_^__NPWQ8P CSY/ 10F P€1_%NAM Q8PRMS_'DECK-ID 10F FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^1_%SPC 3_^1* Q8PRMS IS USED IN PHASES A,B,C,D,E,OBJECT LIBRARY_^1*_8Q8PRMS IS A SUBROUTINE TO PICKUP_^1*_8AND COMPUTE PARAMETERS TO A FORTRAN_^1*_8GENERATED SUBROUTINE, FUNCTION €€SUB-_^1*_8PROGRAM OR STATEMENT FUNCTION._^1_%ENT_!Q8PREP,Q8PKUP_^1_%EQU_!ENTAD($DC)_^1_%EQU_!PAD($DD)_^1Q8PREP NUM_!0_)ENTRY POINT_^1*_8Q8PREP IS THE INITIALIZATION ENTRY_^1*_8OF Q8PRMS. THE CALL TO THIS ENTRY POINT_^1*_8OCCURS ONCE FOR EACH PROCESSING OF A_^1*_8PARAMETER LIST. THE ADDRESS OF THE_^1*_8ENTRY POINT IS PASSED AS A PARAMETER_^1*_8WHERE IT IS PICKED UP AND STORED AWAY€€_^1*_8FOR LATER USE._^1_%LDA* (Q8PREP)_$LOAD PARAMETER(WHICH IS THE SELF-RELATIVE_^1*_8ADDRESS OF THE ENTRY POINT OF THE_^1*_8CALLING ROUTINE._^1_%ADD* Q8PREP_'COMPUTE ADDRESS_^1_%STQ* QSV4_L**FTN 3.0**_^1_%LDQ- $F6_M**FTN 3.0**_^1_%SQM 1_O**FTN 3.0**_^1_%AND* MASKSB_^1_%STA- ENTAD_^1_%RAO* Q8PREP_'COMPUTE RETURN ADDRESS_^1_%LDQ* QSV4_L**FTN 3.0**_^1_%JMP* (Q8PREP)_$EXIT_^1QSV4_€€!NUM 0_O**FTN 3.0**_^1MASKSB NUM_!$7FFF_^1Q8PKUP NUM 0_,ENTRY POINT_^1*_8Q8PKUP IS ENTERED ONCE FOR EACH_^1*_8CONSECUTIVE PARAMETER. THE ADDRESS_^1*_8OF THE PARAMETER IS COMPUTED AND_^1*_8PASSED BACK THROUGH THE ACCUMULATOR_^1*_8AND THE RETURN ADDRESS IS INCREMENTED_^1*_8BY 1._^1_%LDA- (ENTAD)_%PICKUP PARAMETER_^1_%STA- PAD_^1_%LDA- (PAD)_^1_%STQ* QSV4_L**FTN 3.0**_^1_%LDQ- $F€ª6_M**FTN 3.0**_^1_%SQM 3_O**FTN 3.0**_^1_%SAP_!2_^1_%ADD- (ENTAD)_^1_%AND* MASKSB_^1_%RAO- (ENTAD)_^1_%LDQ* QSV4_L**FTN 3.0**_^1_%JMP* (Q8PKUP)_$RETURN_^1_%END_]_^__ ªPWSTORE CSY/ 11F P€1_%NAM STORE_(DECK-ID 11F FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^1_%SPC 3_^1*_8STORE IS USED IN PHASES A1,A2,A3,A4,A5_^1_%ENT STORE_^1_%EXT WRITE_^1* MASTER LABELLED COMMON_^1_%DAT ETC(12)_^1_%DAT IOPTC_^1_%DAT ETC1(30)_^1_%DAT ICOMT(12+3)€€_IFTN 3.3_^1_%DAT ETC2(3)_MFTN 3.3_^1_%DAT IBCDTB(48)_JFTN 3.3_^1_%DAT LOOPT(3+50),IEQV(255+2),ISTAB(150+2)_^1_%DAT ETC3(1+25+11)_^1* SYMBOL TABLE LABELLED COMMON_^1_%DAT ISYMN,ISYMFL,ISYMD,ISYMX,ISYMS,ISYMP_^1_%DAT ISYMPC,ISYMPS,ISYMNS,SYMTAB(960)_^1_%EQU ITYPE(SYMTAB),ISYM(SYMTAB+3)_^1* PHASE A BLANK COMMON_^1_%COM JSYM(3)_^1*_8BEGIN_4***** FTN 3.1 *****_^1_%COM EBC1,JMO€€DE_^1*_8END_6***** FTN 3.1 *****_^1* COMMUNICATION AREA CONSTANTS_^1*_8BEGIN_4***** FTN 3.1 *****_^1_%EQU X0200($2C),X0400($2D),X1000($2F),X8000($32),X7FFF($42)_^1*_8END_6***** FTN 3.1 *****_^1* SUBROUTINE STORE_^1STORE NOP_]_^1_%STQ* QSAV_^1_%LDA+ ISYMX_^1_%EQU ISYMXX(*-1)_^1_%ADD+ ISYMP_^1_%STA* NREF_^1_%RTJ WRITE_^1_%ADC $22,$22,3,NREF_^1NOS_"LDQ* (ISYMXX)_^1_%ENA 0_RPSR 7€€24_^1_%STA* (F+1),Q_LPSR 724_^1_%STA+ ITYPE,Q_LPSR 724_^1_%STA+ ITYPE+1,Q_JPSR 724_^1_%EQU AITYP1(*-1)_^1* ISYM(ISYMX)=JSYM(1)...ISYM(ISYMX+1)=JSYM(2)_^1_%LDA+ JSYM_^1_%STA+ ISYM-1,Q_^1_%LDA+ JSYM+1_^1_%STA+ ISYM,Q_^1*_8POSSIBLE DELETE 38-45_^1*_#********BEGIN********** FTN 3.2 *********************************_^1*_%IF MODIFYING A PRESET DO NOT INCREMENT ISYMN_^1*_#IF(ISYMX+ISYMN.€€LT.ISYMN) GOTO DPCHK_^1_%TRQ A_,A = ISYMX_^1_%ADD+ ISYMP_^1_%SUB* (C+1)_(SUBTRACT ISYMN_^1_%SAM DPCHK_(SKIP IF A PRESET DO NOT INCREMENT ISYMN_^1*_#*********************** FTN 3.2 ******END************************_^1* ISYMN = ISYMN+ISYMFL_^1C_$LDA+ ISYMN_^1_%ADD+ ISYMFL_^1_%STA* (C+1)_^1*_8BEGIN_4***** FTN 3.1 *****_^1* DOUBLE PRECISION CONSTANT IF JMODE = 6_^1* IF (JMODE.NE.6) G€€O TO D_^1DPCHK LDA+ JMODE_^1_%INA -6_^1_%SAZ 1_^1_%JMP* D_^1* SAVE HI ORDER BIT OF JSYM(3) IN HI ORDER BIT OF IPART - SYMTAB,WORD1_^1B_$LDA- X8000_(LOAD MASK FOR HI ORDER BIT_^1_%AND* (D+1)_(AND WITH JSYM(3)_^1_%ALS 5_,LEFT SHIFT BIT TO THAT OF IPART_^1_%STA* (F+1),Q_%STORE INTO SYMTAB WORD1(ISYMX)_^1* SAVE LOWER 15 BITS OF JSYM(3) IN SYMTAB WORD3(ISYMX)_^1_%LDA- X7FFF_^1_%AND*€€ (D+1)_(AND WITH JSYM(3)_^1_%STA* (AITYP1),Q_"STORE IN SYMTAB WORD 3(ISYMX)_^1* ITYPE(ISYMX) = 3_^1_%LDA* E+1_^1_%AND* (F+1),Q_^1_%ADD =N$0600_^1_%STA* (F+1),Q_^1* GO TO K_]_^1_%JMP* K_^1*_8END_6***** FTN 3.1 *****_^1* IF (JSYM(3).NE.$2424) GO TO G_^1D_$LDA+ JSYM+2_^1_%EOR =N$2424_^1_%SAN G_^1* ITYPE(ISYMX) = 1_^1E_$LDA =N$F9FF_^1F_$AND+ ITYPE-1,Q_^1_%ADD- X0200_^1_%STA* (F+1),€xQ_^1* GO TO K_]_^1_%JMP* K_^1* IF (JSYM(3).EQ.$2525) GO TO J_^1G_$LDA* (D+1)_^1_%EOR =N$2525_^1_%SAZ J_^1* RETURN_]_^1H_$LDQ* QSAV_^1_%JMP* (STORE)_^1* ITYPE(ISYMX) = 2_^1J_$LDA* E+1_^1_%AND* (F+1),Q_^1_%ADD- X0400_^1_%STA* (F+1),Q_^1* ICLASS(ISYMX) = 2_^1K_$LDA =N$87FF_^1_%AND* (F+1),Q_^1_%ADD- X1000_^1_%STA* (F+1),Q_^1_%JMP* H_^1_%BSS QSAV_^1_%BZS NREF_^1_%END_]_^__ xPWLA1 CSY/ 12F P€1_%NAM LOCLA1_'DECK-ID 12F FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^1_%SPC 3_^1*_$PROGRAM BASE .._^1* THIS IS THE 2.0B VERSION._^1* LOCLA1 IS USED IN PHASE A1_^1_%ENT LOCLIZ,LOCLZ2,LOCAL_^1_%EXT WRITE,READ,ENDLOC_^1_%EQU X0($02),X1($03),X3($04)€€,X6($44),X7($05)_^1_%EQU XFFF0($16),LOADPT($F7),X4($25)_^1_%ENT MARKER_J**FTN 3.2**_^1_%SPC 1_^1_%EQU NRLOCS(5)_^1_%EQU NRLEVS(2)_^1_%SPC 1_^1*----------------------------------------------------*_^1* INITIALIZATION ENTRY...COPY LOCAL FILES FROM_%*_^1* LIBRARY TO SCRATCH FILES, RECORDING THEIR SIZES._!*_^1*----------------------------------------------------*_^1_%SPC 1_^1LOC€€LIZ NOP_]_^1_%LDA* MARKAD_#GET REL ADR OF 1ST WD OF FILE_^1_%SUB- LOADPT_%TO BE READ...A(LAST WD)_^1_%STA* LEVELX_#-A(FIRST-1) W1 HOLDER_/**FTN 3.2**_^1_%SPC 1_^1_%ENQ NRLOCS_#INIT PART NR TO NR OF LAST LOC_^1*_7FILE TO BE USED, SO LAST FILE_^1*_7READ CAN STAY IN CORE._^1_%SPC 1_^1LOOP_!LDA* NAME+2_#STORE PART NR IN LAST DIGIT OF_^1_%AND- XFFF0_'PROTO FILE NAME_^1_%AAQ A_^1_%S€€TA* NAME+2_^1_%SPC 1_^1_%TRQ A_)GET SCRATCH FILE NR FROM PART_^1_%INA 12_*NR_^1_%STA* FILENR_^1_%SPC 1_^1_%ENA 0_)CLEAR SECT ADRS IN 'GTFILE' REQ_^1_%STA* LOCATN_^1_%STA* LOCATN+1_^1_%STA* GETIT+7_%SET W2 WORD TO ZERO_177*1895_^1_%INQ -1_#WHEN Q EQUALS 1 FILE A IS TO BE READ_$**FTN 3.2**_^1_%SQZ FILEA_K**FTN 3.2**_^1_%INQ 1_#RESTORE Q_A**FTN 3.2**_^1_%JMP* GETIT_K**FTN 3.2*€€*_^1FILEA INQ 1_"RESTORE Q_B**FTN 3.2**_^1_%LDA* LEVELX_"SET W1 FOR FILE A_5**FTN 3.2**_^1_%STA* GETIT+5_^1_%ENA 0_'CLEAR LEVEL INDEX IN 'LOCAL'_^1_%STA* LEVELX_^1_%SPC 1_^1GETIT GTFILE 0,NAME-GETIT-1,MARKER,,,,,,1_2**FTN 3.0**_^1_%BSS LOCATN(2) READ IN A PART FROM THE LIBE_^1_%JMP* *+4_M**FTN 3.0**_^1NAME_!ALF 3,FTN3A0_$LIBRARY NAME OF LOCAL FILE_^1_%LDA* GETIT+3_^1_%SAZ €€1_^1_%JMP* *-2_^1_%SPC 1_^1_%LDA* (MARKAD)_!GET SIZE OF THIS PART..._^1_%SUB* MARKAD_%A(TOP+1) - A(BOTTOM)_^1_%STA* LENGTH_^1_%STA* SIZES-1,Q SAVE SIZE FOR 'LOCAL'_^1_%SPC 1_^1_%RTJ WRITE_$WRITE PART ON ITS SCRATCH FILE_^1_%ADC FILENR,X0,LENGTH,MARKER_^1MARKAD EQU MARKAD(*-1)_^1_%SPC 1_^1_%INQ -1_(LOOP ON NR OF LOC FILES IN THIS_^1_%SQZ 1_+PHASE ('NRLOCS')_^1_%JMP* LOOP_^1€€_%SPC 1_^1_%JMP* (LOCLIZ)_^1_%SPC 3_^1_%BSS SIZES(NRLOCS),LEVELX_^1_%BSS QSAV(NRLEVS),ISAV(NRLEVS),ENTNR(NRLEVS+1)_^1_%BSS FILSAV(NRLEVS),ADRSV1(NRLEVS)_^1_%BSS ADRSV2(NRLEVS),FLGSAV(NRLEVS)_^1_%BSS FILENR,LENGTH_^1_%ORG ENTNR_^1_%NUM 1_^1_%ORG*_^1_%SPC 3_^1*----------------------------------------------------*_^1* REINITIALIZATION ENTRY...REGENERATE 'SIZES' TABLE *_^1* €€BY READING FIRST WORD OF EACH FILE BACK FROM DISC. *_^1*----------------------------------------------------*_^1_%SPC 1_^1LOCLZ2 NOP_]_^1_%ENA 1_^1_%STA* LENGTH_^1_%ENQ NRLOCS_^1LOC2A TRQ A_^1_%INA 12_^1_%STA* FILENR_^1_%RTJ* READIT_^1_%LDA* MARKER_^1_%SUB* MARKAD_^1_%STA* SIZES-1,Q_^1_%INQ -1_^1_%SQZ 1_^1_%JMP* LOC2A_^1_%STQ* LEVELX_^1_%JMP* (LOCLZ2)_^1_%SPC 3_^1*--------€€--------------------------------------------*_^1* PROGRAM FETCH ENTRY._>*_^1* RTJ LOCAL ... ADC RETURN-ADDRESS ..._.*_^1* NUM PART-NUMBER,ENTRY-NUMBER,FLAG_1*_^1*_S*_^1* SAVES CALLER'S FILE NUMBER AND RETURN ADDRESS, AND *_^1* (Q,I). FETCHES SPECIFIED FILE AND CALLS SPECIFIED *_^1* ENTRY POINT IN ITS TRANSFER VECTOR. AT RETURN,_"*_^1* IF FLAG.EQ.0, RETURNS TO CALLER...IF FLAG.GT.€€0,_"*_^1* READS CALLER BACK IN AND RESTORES HIS IMMEDIATE_"*_^1* RETURN ADDRESS BEFORE RETURNING TO HIM..._)*_^1* IF FLAG.LT.0, GOES BACK CALL CHAIN ONE MORE LEVEL *_^1* TO FIND CALLER'S ULTIMATE RETURN ADDRESS._)*_^1*----------------------------------------------------*_^1_%SPC 1_^1LOCAL NOP_]_^1_%TRQ A_)HOLD (Q)_^1_%LDQ* LEVELX_#BUMP LEVEL INDEX AND CHECK FOR_^1_%INQ 1_^1_%S€€TQ* LEVELX_^1_%SPC 1_^1_%STA* QSAV-1,Q_!SAVE (Q), (I) IN PROPER LEVEL_^1_%LDA- I_+OF THEIR SAVE AREAS._^1_%STA* ISAV-1,Q_^1_%SPC 1_^1_%LDA* FILENR_#SAVE CURRENT FILE NR_^1_%STA* FILSAV-1,Q_!AND RTN ADR IN PROPER LEVELS_^1_%SPC 1_^1_%LDA* (LOCAL)_$OF THEIR TABLES_^1_%STA* FILENR_^1_%LDA* (FILENR)_^1_%STA* ADRSV1-1,Q_^1_%SPC 1_^1_%RAO* LOCAL_^1_%LDA* (LOCAL)_"GET FILE NR AND STOR€€E IN 'READ'_^1_%INA 12_*CALLING SEQUENCE_^1_%STA* FILENR_^1_%SPC 1_^1_%RAO* LOCAL_$GET ENTRY NR FROM CALL_^1_%LDA* (LOCAL)_$AND SAVE IN ITS TABLE_^1_%STA* ENTNR,Q_^1_%SPC 1_^1_%RAO* LOCAL_$GET FLAG FROM CALL AND SAVE IN_^1_%LDA* (LOCAL)_$APPROPRIATE LEVEL OF FLAG TBL_^1_%STA* FLGSAV-1,Q_^1_%SAZ GETSIZ_^1_%SPC 1_^1_%LDA* ENTNR-1,Q GET CALLER'S ENTRY NR AND FROM_^1_%STA- I_+THA€€T AND XFER VECTOR, HIS ENT_^1_%LDA* ENTRYS-1,I_!POINT. FROM THAT GET HIS_^1_%STA- I_+RETURN ADR AND SAVE THAT IN_^1_%LDA- (X0),I_%SECOND ADR-SAVE AREA._^1_%STA* ADRSV2-1,Q_^1_%LDA* FLGSAV-1,Q_^1_%SPC 1_^1_%SAP GETSIZ_^1_%LDA* ADRSV2-1,Q_^1_%INA -3_^1_%STA- I_^1_%LDA- (X0),I_^1_%STA* ADRSV2-1,Q_^1GETSIZ LDQ* FILENR_#GET SIZE OF THIS LOCAL FILE_^1_%LDA* SIZES-13,Q_!FROM PROPER LE€€VEL OF SIZE TBL_^1_%STA* LENGTH_%AND PUT IN 'READ' CALLING SEQ_^1_%SPC 1_^1_%RTJ* READIT_#READ FROM SCRATCH INTO OVERLAY_^1_%SPC 1_^1_%LDQ* LEVELX_^1_%LDQ* ENTNR,Q_"GET ADR OF REQ'D ENTRY FROM_^1_%LDA* ENTRYS-1,Q_!XFER-VEC PART OF FILE_^1_%STA* *+2_)THAT WAS JUST READ IN_^1_%SPC 1_^1CALLIT RTJ+ 0_)*** CALL REQUESTED PROGRAM ***_^1_%SPC 1_^1_%LDQ* LEVELX_#GET CALLER'S FLAG FROM €€FLAG TBL_^1FLAG_!LDA* FLGSAV-1,Q_!AND TEST FOR 0. IF NOT, SKIP_^1_%SAZ GETRTN_^1LOAD_!LDA* FILSAV-1,Q GET NR OF CALLER'S FILE FROM_^1_%STA* FILENR_%PROPER LEVEL OF FILE-SAVE TBL_^1_%TRA Q_)GET SIZE OF THAT FILE FROM_^1_%LDA* SIZES-13,Q_!SIZE TBL_^1_%STA* LENGTH_^1_%SPC 1_^1_%RTJ* READIT_#READ CALLER BACK IN_^1_%SPC 1_^1_%LDQ* LEVELX_#GET RTN ADR FROM PROPER LEVEL_^1GETRTN LDA*€€ ADRSV1-1,Q_^1_%STA* LOCAL_^1_%SPC 1_^1_%LDA* FLGSAV-1,Q_^1_%SAZ RESTOR_^1_%LDA* ENTNR-1,Q GET ADR OF ENTRY POINT IN_^1_%STA- I_+PGM THAT WAS CALLED WHEN THAT_^1_%LDA* ENTRYS-1,I_!FILE WAS READ. GET CALLER'S_^1_%STA- I_+RETURN ADR FROM SECOND SAVE_^1_%LDA* ADRSV2-1,Q_!TABLE AND RESTORE CALLER'S_^1_%STA- (X0),I_%RETURN._^1_%SPC 1_^1RESTOR LDA* ISAV-1,Q_^1_%STA- I_^1_%LDA* QSAV-€€1,Q_!GET (Q)_^1_%INQ -1_(DROP LEVEL INDEX_^1_%STQ* LEVELX_^1_%TRA Q_)RESTORE (Q)_^1_%JMP* (LOCAL)_"RETURN TO CALLER_^1_%SPC 1_^1READIT NOP_]_^1_%RTJ+ READ_%READ A LOCAL FROM ITS SCRATCH_^1_%ADC FILENR,X0,LENGTH,MARKER AREA INTO CORE_^1_%JMP* (READIT)_#STARTING AT 'MARKER'._^1_%SPC 3_^1*----------------------------------------------------*_^1* THE FOLLOWING AREA IS SPECIFIC TO€ EACH LOCAL FILE. *_^1* THE OVERLAY AREA BEGINS HERE._5*_^1*----------------------------------------------------*_^1_%SPC 1_^1MARKER ADC ENDLOC_#ADR OF 1ST WD AFTER THIS FILE_^1_%LST_]_^1ENTRYS ADC PHASEA_=FORTA1_^1_%BZS (8),(7),(1),(1)_^1_%EXT PHASEA_^1_%END_]_^__PWDA1 CSY/ 13F P€1_%NAM DUMYA1_'DECK-ID 13F FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^1CALL_!MAC SB,P1,P2,P3_^1_%LOC X_^1'X'_"NOP_]_^1_%RTJ'.' 'SB'_^1_%ADC 'X','P1','P2','P3'_^1_%SPC 2_^1_%EMC_]_^1GET_"MAC SB_^1_%NOP_]_^1_%RTJ+ 'SB'_^1_%JMP* (*-3)_^1_%NUM 0,0_€€^1_%SPC 2_^1_%EMC_]_^1_%SPC 2_^1* THIS IS THE 2.0B VERSION._^1* DUMYA1 IS USED IN PHASE A1._^1_%ENT BYEQPR,CHECKF,COMNPR,DATAPR_^1_%ENT DIMPR,EXRLPR,PEQVS,SUBPPR,TYPEPR_^1_%ENT ASEMPR,ASGNPR,BDOPR,CPLOOP,ERBPR,PUNT_^1_%ENT ARITH_^1_%ENT IOSPR_^1_%EXT LOCAL_^1_%SPC 2_^1BYEQPR CALL* (LOCAD),2,01,0_^1CHECKF CALL* (LOCAD),2,02,0_^1COMNPR CALL* (LOCAD),2,03,0_^1DATAPR CALL* (LO€€CAD),2,04,0_^1DIMPR CALL* (LOCAD),2,05,0_^1EXRLPR CALL* (LOCAD),2,06,0_^1PEQVS CALL* (LOCAD),2,07,0_^1SUBPPR CALL* (LOCAD),2,08,0_^1TYPEPR CALL* (LOCAD),2,09,0_^1ASEMPR CALL* (LOCAD),3,01,0_^1ASGNPR CALL* (LOCAD),3,02,0_^1BDOPR CALL* (LOCAD),3,03,0_^1CPLOOP CALL* (LOCAD),3,04,0_^1ERBPR CALL* (LOCAD),3,05,0_^1PUNT_!CALL* (LOCAD),3,07,0_^1ARITH CALL* (LOCAD),4,01,0_^1IOSPR CALL€2* (LOCAD),5,01,0_^1LOCAD ADC LOCAL_^1_%END_]_^__2PWGETC1 CSY/ 14F P€1_%NAM GETC_)DECK-ID 14F FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^1_%SPC 3_^1*_$PROGRAM BASE .._^1* THIS IS THE 2.0B VERSION._^1* GETC IS USED IN PHASES A1-5_^1* EXTRACTS ONE CHARACTER FROM 'ISORS(ISORSX)' AND_^1* STORES IT IN 'JCHAR', RIGHT JUST€€IFIED, LEADING ZERO._^1* IGNORES BLANKS (INTERNAL CODE 46) IF 'JBLANK'.NE.0._^1* UPDATES 'ISORSX' TO POINT TO NEXT CHARACTER._^1* IF BIT 4 OF 'IFLAGS' =1, READS FROM 'IBUF2(IBUF2X)'._^1_%ENT GETC_^1* MASTER LABELLED COMMON BLOCK_^1_%DAT IFLAGS_^1* PHASE A BLANK COMMON BLOCK_^1_%COM ETC1(8),JCHAR,ETC2(4),JBLANK,ETC3(3)_^1_%COM ISORS(208),ISORSX_^1_%COM ETC4(18),IBUF2X,IBUF2(304€€)_^1_%EQU XFF($0A)_!CONSTANT $00FF_^1_%EQU X0010($27) CONSTANT $0010_^1GETC_!NOP_]_^1_%STQ* QSAV_^1WHICH LDA+ IFLAGS_^1_%AND- X0010_^1_%SAN XAD2_^1XAD_"LDQ+ ISORSX_#GET 'ISORS' INDEX_^1_%LRS 1_)DIVIDE BY 2 (CHARACTERS/WORD)_^1_%SAP 1_)IF REMAINDER NONZERO_^1_%INQ 1_+INCREASE QUOTIENT_^1_%LDQ+ ISORS-1,Q GET WORD_^1_%SAP 1_)IF REMAINDER NONZERO,_^1_%QRS 8_+SELECT LEFT CHARA€€CTER_^1_%TRQ A_)MASK OFF_^1_%AND- XFF_)RIGHT CHARACTER OF RESULT_^1CAD_"STA+ JCHAR_'AND STORE_^1_%RAO* (XAD+1)_"BUMP 'ISORSX'_^1_%JMP* TEST_^1XAD2_!LDQ+ IBUF2X_^1_%LRS 1_^1_%SAP 1_^1_%INQ 1_^1_%LDQ+ IBUF2-1,Q_^1_%SAP 1_^1_%QRS 8_^1_%TRQ A_^1_%AND- XFF_^1_%STA* (CAD+1)_^1_%RAO* (XAD2+1)_^1TEST_!INA -46_'IF 'JCHAR' IS A BLANK_^1_%SAN OUT_^1_%LDA+ JBLANK_%AND 'JBLANK' IS ZERO€d_^1_%SAN OUT_^1_%JMP* WHICH_'TRY AGAIN_^1OUT_"LDQ* QSAV_^1_%JMP* (GETC)_^1_%BSS QSAV_^1_%END_]_^__dPWIGTCF CSY/ 15F P€1_%NAM IGETCF_'DECK-ID 15F FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^1_%SPC 3_^1* IGETCF IS USED IN PHASE A_^1* FUNCTION IGETCF(IMAGE,ICOLMN)_^1_%ENT IGETCF_^1_%EQU X0001($23),X00FF($0A)_^1IGETCF NOP_]_^1_%STQ* QSAV_^1_%LDA* (IGETCF)_^1_%INA -1_€€^1_%STA* IMAGE_^1_%RAO* IGETCF_^1_%LDA* (IGETCF)_^1_%STA* ICOLMN_^1* ITEMP1 = (ICOLMN+1)/2_^1_%LDQ+ 0_^1_%EQU ICOLMN(*-1)_^1_%INQ 1_^1_%QRS 1_^1* IF (AND(ICOLMN,1).NE.0) GOTO 11_^1_%LDA* (ICOLMN)_^1_%AND- X0001_^1_%SAN ALPHA_^1* IGETCF = AND(IMAGE(ITEMP1),$FF)_^1_%LDA+ 0,Q_^1_%EQU IMAGE(*-1)_^1_%JMP* BETA-1_^1* 11 IGETCF = AND(IMAGE(ITEMP1)/256,$FF)_^1ALPHA LDA* (IMAGE),Q_^1_€t%ARS 8_^1_%AND- X00FF_^1* RETURN_]_^1BETA_!LDQ* QSAV_^1_%RAO* IGETCF_^1_%JMP* (IGETCF)_^1_%BSS QSAV_^1_%END_]_^__ tPWOPT CSY/ 16F P€1_%NAM OPTION_'DECK-ID 16F FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^1_%SPC 3_^1* OPTIONS IS USED IN PHASE A_^1_%ENT OPANAL_^1_%EXT OPTC,LOADC_^1_%EXT CRDBF_K**FTN 3.0**_^1_%EXT ASCOPT_NFTN 3.3_^1_%ENT COA,COKLG_G**FTN 3.0**_^1_%DAT IFLAGS_NF€€TN 3.3_^1_%DAT LINECT_NFTN 3.3_^1_%DAT LINCT1_NFTN 3.3_^1_%DAT IR_RFTN 3.3_^1_%DAT IK_RFTN 3.3_^1_%DAT IP_RFTN 3.3_^1_%DAT IA_RFTN 3.3_^1_%DAT IL_RFTN 3.3_^1_%DAT IM_RFTN 3.3_^1_%DAT IXLGO_OFTN 3.3_^1_%DAT IOPTO_OFTN 3.3_^1_%DAT IOPTV_OFTN 3.3_^1_%DAT IOPTC_OFTN 3.3_^1_%DAT IOPTD_OFTN 3.3_^1_%DAT MCSTRT_NFTN 3.3_^1_%DAT MACRNB_NFTN 3.3_^1_%DAT MACSEC_NFTN 3.3_^1_%DA€€T IERRS(16)_KFTN 3.3_^1_%DAT ISRFAD_NFTN 3.3_^1_%COM JSYM(3),JTERM_^1OPANAL NOP_]_^1_%ENA 0_^1_%STA OPTFLG_NFTN 3.3_^1_%STA GOTOPT_NFTN 3.3_^1_%ENQ NBROPT-1_$CLEAR OLD OPTIONS_5FTN 3.3_^1CLEAR STA+ IR,Q_L**FTN 3.0**_^1_%INQ -1_N**FTN 3.0**_^1_%SQM 1_O**FTN 3.0**_^1_%JMP* CLEAR_K**FTN 3.0**_^1_%ENA -0_^1_%ENQ 39_^1_%STA* (JTRMAD),Q_^1_%INQ -1_^1_%SQM 1_^1_%JMP* *-3_^1_€€%JMP OPTC_)JUMP TO FIND OPT CARD IN CRDBF(IOPRBA)_^1COA_"ENA 7_^1_%STA* OPTFLG_'SET OPTIONS FLAG NON-ZERO_^1_%LDA- I_SFTN 3.3_^1_%STA* SVI_QFTN 3.3_^1_%ENQ NBROPT-1_LFTN 3.3_^1_%ENA $20_QFTN 3.3_^1CLEAR2 STA ASCOPT,Q_LFTN 3.3_^1AOPTAD EQU AOPTAD(*-1)_IFTN 3.3_^1_%INQ -1_RFTN 3.3_^1_%SQM 1_SFTN 3.3_^1_%JMP* CLEAR2_NFTN 3.3_^1_%LDA* JTRMAD_J**FTN 3.0**_^1_%INA -2_N**FTN 3.0*€€*_^1_%STA* ADJTRM_J**FTN 3.0**_^1_%ENQ 39_N**FTN 3.0**_^1RTN_"LDA+ CRDBF,Q_I**FTN 3.0**_^1_%STA* (ADJTRM),Q_F**FTN 3.0**_^1_%INQ -1_N**FTN 3.0**_^1_%TRQ A_O**FTN 3.0**_^1_%INA -2_N**FTN 3.0**_^1_%SAM CONT_L**FTN 3.0**_^1_%JMP* RTN_M**FTN 3.0**_^1CONT_!JMP* CO2_M**FTN 3.0**_^1_%SPC 2_SFTN 3.3_^1SVI_"NUM 0_SFTN 3.3_^1_%SPC 2_SFTN 3.3_^1CO_#FWRITE $FC,0,MESSG,4,A,0,0,I,0,1_5**€€FTN 3.0**_^1_%LDA* CO+3_^1_%SAZ 1_^1_%JMP* *-2_^1CO1_"FREAD $FD,0,JTERM,39,A,0,0,I,0,1_5**FTN 3.0**_^1_%EQU JTRMAD(*-1)_^1_%LDA* CO1+3_^1_%SAZ 1_^1_%JMP* *-2_^1CO2_"ENA -1_^1_%STA+ JSYM_^1_%EQU JSYMAD(*-1)_^1_%ENA 0_SFTN 3.3_^1_%STA- I_SFTN 3.3_^1LOOP_!RAO* (JSYMAD)_^1_%LDQ* (JSYMAD)_^1_%ENA 0_^1_%LRS 1_^1_%LDQ* (JTRMAD),Q_^1_%SAZ 1_^1_%QLS 8_^1_%QRS 8_^1_%STQ+ JSYM+1_^1€€_%EQU JSP1AD(*-1)_^1_%SQP LOOP0_OFTN 3.3_^1_%ENA $29_QFTN 3.3_^1_%STA* (AOPTAD),I_"TERMINATE OPTION HEADER WITH A ')'_#FTN 3.3_^1_%JMP* OUT_^1LOOP0 ENQ NBROPT-1_LFTN 3.3_^1LOOP1 LDA* R,Q_^1_%STA* (AOPTAD),I_JFTN 3.3_^1_%SUB* (JSP1AD)_^1_%SAZ 3_^1_%SQZ EXLOOP_^1_%INQ -1_^1_%JMP* LOOP1_^1_%RAO+ IR,Q_^1_%RAO- I_SFTN 3.3_^1_%RAO* GOTOPT_J**FTN 3.0**_^1EXLOOP JMP* LOOP_^1OUT_"L€€DA* OPTFLG_^1_%SAN QSS_Q83*2160_^1_%JMP* RETN_)RETURN IF NO OPT CARD USED_^1QSS_"STQ* QSAVE_(SAVE Q-REG_<83*2160_^1_%LDA =N$2020_%ENTER A WITH BLANKS_383*2160_^1_%ENQ 39_R83*2160_^1BLNKLP STA+ CRDBF,Q_%INITIALISE CRDBF FOR SHORT_,83*2160_^1_%INQ -1_+READ FROM TTY_983*2160_^1_%SQM QSR_Q83*2160_^1_%JMP* BLNKLP_N83*2160_^1QSR_"RTJ- ($F4)_O83*2160_^1_%NUM $4600,$08F9,0 STATUS INP€€UT DEVICE FOR CLASS CODE_#83*2160_^1_%LDA =N$3800_%TTY IF CLASS CODE = 6_183*2160_^1_%LAQ A_S83*2160_^1_%SUB =N$3000_M83*2160_^1_%SAZ TTYINP_N83*2160_^1_%RTJ LOADC_(REFILLCARDBUFFER FOR FTN_^1TTYINP LDQ* QSAVE_(RESTORE Q-REG_983*2160_^1_%LDA* GOTOPT_J**FTN 3.0**_^1_%SAN RETN_L**FTN 3.0**_^1_%CLR A_O**FTN 3.0**_^1_%STA* OPTFLG_J**FTN 3.0**_^1_%JMP* CO_N**FTN 3.0**_^1RETN_!LDA€€* SVI_QFTN 3.3_^1_%STA- I_SFTN 3.3_^1EXIT_!JMP (OPANAL)_$RETURN TO CALLER_6FTN 3.3_^1COKLG RAO IP_+SET STANDARD OPTIONS (LPXC)_+FTN 3.3_^1_%RAO IL_N**FTN 3.0**_^1_%RAO IXLGO_K**FTN 3.0**_^1_%RAO IOPTC_^1_%JMP* EXIT_PFTN 3.3_^1GOTOPT NUM 0_O**FTN 3.0**_^1ADJTRM NUM 0_O**FTN 3.0**_^1OPTFLG NUM 0_^1QSAVE NUM 0_S83*2160_^1MESSG ALF 4,OPTIONS_^1R_$NUM $52_^1_%NUM $4B_^1_%€ÌNUM $50_^1_%NUM $41_^1_%NUM $4C_^1_%NUM $4D_^1_%NUM $58_^1_%NUM $4F_*O_EFTN 3.3_^1_%NUM $56_*V_EFTN 3.3_^1_%NUM $43_*C_EFTN 3.3_^1_%NUM $44_*D_EFTN 3.3_^1_%EQU NBROPT(*-R)_IFTN 3.3_^1_%END_]_^__ÌPWELOC CSY/ 17F Pb1_%NAM ENDLOC_'DECK-ID 17F FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^1_%SPC 3_^1* ENDLOC IS USED IN ALL PHASES_^1_%ENT ENDLOC_%OF A LOCAL FILE SO THAT THE_^1_%EQU ENDLOC(*)_"FILE SIZE CAN BE COMPUTED._^1_%END_]_^__ bPWLA2 CSY/ 18F P€1_%NAM LOCLA2_'DECK-ID 18F FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^1_%SPC 3_^1*_$PROGRAM BASE .._^1* THIS IS THE 2.0B VERSION._^1* LOCLA2 IS USED IN PHASE A2_^1_%ENT LOCLIZ,LOCLZ2,LOCAL_^1_%EXT WRITE,READ,ENDLOC_^1_%EQU X0($02),X1($03),X3($04)€€,X6($44),X7($05)_^1_%EQU XFFF0($16),LOADPT($F7),X4($25)_^1_%ENT MARKER_J**FTN 3.2**_^1_%SPC 1_^1_%EQU NRLOCS(5)_^1_%EQU NRLEVS(2)_^1_%SPC 1_^1*----------------------------------------------------*_^1* INITIALIZATION ENTRY...COPY LOCAL FILES FROM_%*_^1* LIBRARY TO SCRATCH FILES, RECORDING THEIR SIZES._!*_^1*----------------------------------------------------*_^1_%SPC 1_^1LOC€€LIZ NOP_]_^1_%LDA* MARKAD_#GET REL ADR OF 1ST WD OF FILE_^1_%SUB- LOADPT_%TO BE READ...A(LAST WD)_^1_%STA* LEVELX_#-A(FIRST-1) W1 HOLDER_/**FTN 3.2**_^1_%SPC 1_^1_%ENQ NRLOCS_#INIT PART NR TO NR OF LAST LOC_^1*_7FILE TO BE USED, SO LAST FILE_^1*_7READ CAN STAY IN CORE._^1_%SPC 1_^1LOOP_!LDA* NAME+2_#STORE PART NR IN LAST DIGIT OF_^1_%AND- XFFF0_'PROTO FILE NAME_^1_%AAQ A_^1_%S€€TA* NAME+2_^1_%SPC 1_^1_%TRQ A_)GET SCRATCH FILE NR FROM PART_^1_%INA 12_*NR_^1_%STA* FILENR_^1_%SPC 1_^1_%ENA 0_)CLEAR SECT ADRS IN 'GTFILE' REQ_^1_%STA* LOCATN_^1_%STA* LOCATN+1_^1_%STA* GETIT+7_%SET W2 WORD TO ZERO_177*1895_^1_%INQ -1_#WHEN Q EQUALS 1 FILE A IS TO BE READ_$**FTN 3.2**_^1_%SQZ FILEA_K**FTN 3.2**_^1_%INQ 1_#RESTORE Q_A**FTN 3.2**_^1_%JMP* GETIT_K**FTN 3.2*€€*_^1FILEA INQ 1_"RESTORE Q_B**FTN 3.2**_^1_%LDA* LEVELX_"SET W1 FOR FILE A_5**FTN 3.2**_^1_%STA* GETIT+5_^1_%ENA 0_'CLEAR LEVEL INDEX IN 'LOCAL'_^1_%STA* LEVELX_^1_%SPC 1_^1GETIT GTFILE 0,NAME-GETIT-1,MARKER,,,,,,1_2**FTN 3.0**_^1_%BSS LOCATN(2) READ IN A PART FROM THE LIBE_^1_%JMP* *+4_M**FTN 3.0**_^1NAME_!ALF 3,FTN3A0_$LIBRARY NAME OF LOCAL FILE_^1_%LDA* GETIT+3_^1_%SAZ €€1_^1_%JMP* *-2_^1_%SPC 1_^1_%LDA* (MARKAD)_!GET SIZE OF THIS PART..._^1_%SUB* MARKAD_%A(TOP+1) - A(BOTTOM)_^1_%STA* LENGTH_^1_%STA* SIZES-1,Q SAVE SIZE FOR 'LOCAL'_^1_%SPC 1_^1_%RTJ WRITE_$WRITE PART ON ITS SCRATCH FILE_^1_%ADC FILENR,X0,LENGTH,MARKER_^1MARKAD EQU MARKAD(*-1)_^1_%SPC 1_^1_%INQ -1_(LOOP ON NR OF LOC FILES IN THIS_^1_%SQZ 1_+PHASE ('NRLOCS')_^1_%JMP* LOOP_^1€€_%SPC 1_^1_%JMP* (LOCLIZ)_^1_%SPC 3_^1_%BSS SIZES(NRLOCS),LEVELX_^1_%BSS QSAV(NRLEVS),ISAV(NRLEVS),ENTNR(NRLEVS+1)_^1_%BSS FILSAV(NRLEVS),ADRSV1(NRLEVS)_^1_%BSS ADRSV2(NRLEVS),FLGSAV(NRLEVS)_^1_%BSS FILENR,LENGTH_^1_%ORG ENTNR_^1_%NUM 1_^1_%ORG*_^1_%SPC 3_^1*----------------------------------------------------*_^1* REINITIALIZATION ENTRY...REGENERATE 'SIZES' TABLE *_^1* €€BY READING FIRST WORD OF EACH FILE BACK FROM DISC. *_^1*----------------------------------------------------*_^1_%SPC 1_^1LOCLZ2 NOP_]_^1_%ENA 1_^1_%STA* LENGTH_^1_%ENQ NRLOCS_^1LOC2A TRQ A_^1_%INA 12_^1_%STA* FILENR_^1_%RTJ* READIT_^1_%LDA* MARKER_^1_%SUB* MARKAD_^1_%STA* SIZES-1,Q_^1_%INQ -1_^1_%SQZ 1_^1_%JMP* LOC2A_^1_%STQ* LEVELX_^1_%JMP* (LOCLZ2)_^1_%SPC 3_^1*--------€€--------------------------------------------*_^1* PROGRAM FETCH ENTRY._>*_^1* RTJ LOCAL ... ADC RETURN-ADDRESS ..._.*_^1* NUM PART-NUMBER,ENTRY-NUMBER,FLAG_1*_^1*_S*_^1* SAVES CALLER'S FILE NUMBER AND RETURN ADDRESS, AND *_^1* (Q,I). FETCHES SPECIFIED FILE AND CALLS SPECIFIED *_^1* ENTRY POINT IN ITS TRANSFER VECTOR. AT RETURN,_"*_^1* IF FLAG.EQ.0, RETURNS TO CALLER...IF FLAG.GT.€€0,_"*_^1* READS CALLER BACK IN AND RESTORES HIS IMMEDIATE_"*_^1* RETURN ADDRESS BEFORE RETURNING TO HIM..._)*_^1* IF FLAG.LT.0, GOES BACK CALL CHAIN ONE MORE LEVEL *_^1* TO FIND CALLER'S ULTIMATE RETURN ADDRESS._)*_^1*----------------------------------------------------*_^1_%SPC 1_^1LOCAL NOP_]_^1_%TRQ A_)HOLD (Q)_^1_%LDQ* LEVELX_#BUMP LEVEL INDEX AND CHECK FOR_^1_%INQ 1_^1_%S€€TQ* LEVELX_^1_%SPC 1_^1_%STA* QSAV-1,Q_!SAVE (Q), (I) IN PROPER LEVEL_^1_%LDA- I_+OF THEIR SAVE AREAS._^1_%STA* ISAV-1,Q_^1_%SPC 1_^1_%LDA* FILENR_#SAVE CURRENT FILE NR_^1_%STA* FILSAV-1,Q_!AND RTN ADR IN PROPER LEVELS_^1_%SPC 1_^1_%LDA* (LOCAL)_$OF THEIR TABLES_^1_%STA* FILENR_^1_%LDA* (FILENR)_^1_%STA* ADRSV1-1,Q_^1_%SPC 1_^1_%RAO* LOCAL_^1_%LDA* (LOCAL)_"GET FILE NR AND STOR€€E IN 'READ'_^1_%INA 12_*CALLING SEQUENCE_^1_%STA* FILENR_^1_%SPC 1_^1_%RAO* LOCAL_$GET ENTRY NR FROM CALL_^1_%LDA* (LOCAL)_$AND SAVE IN ITS TABLE_^1_%STA* ENTNR,Q_^1_%SPC 1_^1_%RAO* LOCAL_$GET FLAG FROM CALL AND SAVE IN_^1_%LDA* (LOCAL)_$APPROPRIATE LEVEL OF FLAG TBL_^1_%STA* FLGSAV-1,Q_^1_%SAZ GETSIZ_^1_%SPC 1_^1_%LDA* ENTNR-1,Q GET CALLER'S ENTRY NR AND FROM_^1_%STA- I_+THA€€T AND XFER VECTOR, HIS ENT_^1_%LDA* ENTRYS-1,I_!POINT. FROM THAT GET HIS_^1_%STA- I_+RETURN ADR AND SAVE THAT IN_^1_%LDA- (X0),I_%SECOND ADR-SAVE AREA._^1_%STA* ADRSV2-1,Q_^1_%LDA* FLGSAV-1,Q_^1_%SAP GETSIZ_^1_%LDA* ADRSV2-1,Q_^1_%INA -3_^1_%STA- I_^1_%LDA- (X0),I_^1_%STA* ADRSV2-1,Q_^1_%SPC 1_^1GETSIZ LDQ* FILENR_#GET SIZE OF THIS LOCAL FILE_^1_%LDA* SIZES-13,Q_!FROM PROPER LE€€VEL OF SIZE TBL_^1_%STA* LENGTH_%AND PUT IN 'READ' CALLING SEQ_^1_%SPC 1_^1_%RTJ* READIT_#READ FROM SCRATCH INTO OVERLAY_^1_%SPC 1_^1_%LDQ* LEVELX_^1_%LDQ* ENTNR,Q_"GET ADR OF REQ'D ENTRY FROM_^1_%LDA* ENTRYS-1,Q_!XFER-VEC PART OF FILE_^1_%STA* *+2_)THAT WAS JUST READ IN_^1_%SPC 1_^1CALLIT RTJ+ 0_)*** CALL REQUESTED PROGRAM ***_^1_%SPC 1_^1_%LDQ* LEVELX_#GET CALLER'S FLAG FROM €€FLAG TBL_^1FLAG_!LDA* FLGSAV-1,Q_!AND TEST FOR 0. IF NOT, SKIP_^1_%SAZ GETRTN_^1LOAD_!LDA* FILSAV-1,Q GET NR OF CALLER'S FILE FROM_^1_%STA* FILENR_%PROPER LEVEL OF FILE-SAVE TBL_^1_%TRA Q_)GET SIZE OF THAT FILE FROM_^1_%LDA* SIZES-13,Q_!SIZE TBL_^1_%STA* LENGTH_^1_%SPC 1_^1_%RTJ* READIT_#READ CALLER BACK IN_^1_%SPC 1_^1_%LDQ* LEVELX_#GET RTN ADR FROM PROPER LEVEL_^1GETRTN LDA*€€ ADRSV1-1,Q_^1_%STA* LOCAL_^1_%SPC 1_^1_%LDA* FLGSAV-1,Q_^1_%SAZ RESTOR_^1_%LDA* ENTNR-1,Q GET ADR OF ENTRY POINT IN_^1_%STA- I_+PGM THAT WAS CALLED WHEN THAT_^1_%LDA* ENTRYS-1,I_!FILE WAS READ. GET CALLER'S_^1_%STA- I_+RETURN ADR FROM SECOND SAVE_^1_%LDA* ADRSV2-1,Q_!TABLE AND RESTORE CALLER'S_^1_%STA- (X0),I_%RETURN._^1_%SPC 1_^1RESTOR LDA* ISAV-1,Q_^1_%STA- I_^1_%LDA* QSAV-€€1,Q_!GET (Q)_^1_%INQ -1_(DROP LEVEL INDEX_^1_%STQ* LEVELX_^1_%TRA Q_)RESTORE (Q)_^1_%JMP* (LOCAL)_"RETURN TO CALLER_^1_%SPC 1_^1READIT NOP_]_^1_%RTJ+ READ_%READ A LOCAL FROM ITS SCRATCH_^1_%ADC FILENR,X0,LENGTH,MARKER AREA INTO CORE_^1_%JMP* (READIT)_#STARTING AT 'MARKER'._^1_%SPC 3_^1*----------------------------------------------------*_^1* THE FOLLOWING AREA IS SPECIFIC TO€€ EACH LOCAL FILE. *_^1* THE OVERLAY AREA BEGINS HERE._5*_^1*----------------------------------------------------*_^1_%SPC 1_^1MARKER ADC ENDLOC_#ADR OF 1ST WD AFTER THIS FILE_^1_%LST_]_^1ENTRYS ADC BYEQPR,CHECKF,COMNPR,DATAPR_^1_%EXT BYEQPR,CHECKF,COMNPR,DATAPR_^1_%ADC DIMPR,EXRLPR,PEQVS,SUBPPR,TYPEPR_^1_%EXT DIMPR,EXRLPR,PEQVS,SUBPPR,TYPEPR_^1_%BZS (7),(1),(1)_^1_%END_]_^__€PWDA2 CSY/ 19F P€1_%NAM DUMYA2_'DECK-ID 19F FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^1CALL_!MAC SB,P1,P2,P3_^1_%LOC X_^1'X'_"NOP_]_^1_%RTJ'.' 'SB'_^1_%ADC 'X','P1','P2','P3'_^1_%SPC 2_^1_%EMC_]_^1GET_"MAC SB_^1_%NOP_]_^1_%RTJ+ 'SB'_^1_%JMP* (*-3)_^1_%NUM 0,0_€€^1_%SPC 2_^1_%EMC_]_^1_%SPC 2_^1* THIS IS THE 2.0B VERSION._^1* DUMYA2 IS USED IN PHASE A2_^1_%EXT BYEQPR,CHECKF,COMNPR,DATAPR_^1_%EXT DIMPR,EXRLPR,PEQVS,SUBPPR,TYPEPR_^1_%ENT ASEMPR,ASGNPR,BDOPR,CPLOOP,ERBPR,PUNT_^1_%ENT ARITH_^1_%ENT IOSPR_^1_%EXT LOCAL_^1_%SPC 2_^1_%GET BYEQPR_^1_%GET CHECKF_^1_%GET COMNPR_^1_%GET DATAPR_^1_%GET DIMPR_^1_%GET EXRLPR_^1_%GET PEQVS€2_^1_%GET SUBPPR_^1_%GET TYPEPR_^1ASEMPR CALL* (LOCAD),3,01,0_^1ASGNPR CALL* (LOCAD),3,02,0_^1BDOPR CALL* (LOCAD),3,03,0_^1CPLOOP CALL* (LOCAD),3,04,0_^1ERBPR CALL* (LOCAD),3,05,0_^1PUNT_!CALL* (LOCAD),3,07,0_^1ARITH CALL* (LOCAD),4,01,0_^1IOSPR CALL* (LOCAD),5,01,0_^1LOCAD ADC LOCAL_^1_%END_]_^__ 2PWLA3 CSY/ 20F P€1_%NAM LOCLA3_'DECK-ID 20F FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^1_%SPC 3_^1*_$PROGRAM BASE .._^1* THIS IS THE 2.0B VERSION._^1* LOCLA3 IS USED IN PHASE A3_^1_%ENT LOCLIZ,LOCLZ2,LOCAL_^1_%EXT WRITE,READ,ENDLOC_^1_%EQU X0($02),X1($03),X3($04)€€,X6($44),X7($05)_^1_%EQU XFFF0($16),LOADPT($F7),X4($25)_^1_%ENT MARKER_J**FTN 3.2**_^1_%SPC 1_^1_%EQU NRLOCS(5)_^1_%EQU NRLEVS(2)_^1_%SPC 1_^1*----------------------------------------------------*_^1* INITIALIZATION ENTRY...COPY LOCAL FILES FROM_%*_^1* LIBRARY TO SCRATCH FILES, RECORDING THEIR SIZES._!*_^1*----------------------------------------------------*_^1_%SPC 1_^1LOC€€LIZ NOP_]_^1_%LDA* MARKAD_#GET REL ADR OF 1ST WD OF FILE_^1_%SUB- LOADPT_%TO BE READ...A(LAST WD)_^1_%STA* LEVELX_#-A(FIRST-1) W1 HOLDER_/**FTN 3.2**_^1_%SPC 1_^1_%ENQ NRLOCS_#INIT PART NR TO NR OF LAST LOC_^1*_7FILE TO BE USED, SO LAST FILE_^1*_7READ CAN STAY IN CORE._^1_%SPC 1_^1LOOP_!LDA* NAME+2_#STORE PART NR IN LAST DIGIT OF_^1_%AND- XFFF0_'PROTO FILE NAME_^1_%AAQ A_^1_%S€€TA* NAME+2_^1_%SPC 1_^1_%TRQ A_)GET SCRATCH FILE NR FROM PART_^1_%INA 12_*NR_^1_%STA* FILENR_^1_%SPC 1_^1_%ENA 0_)CLEAR SECT ADRS IN 'GTFILE' REQ_^1_%STA* LOCATN_^1_%STA* LOCATN+1_^1_%STA* GETIT+7_%SET W2 WORD TO ZERO_177*1895_^1_%INQ -1_#WHEN Q EQUALS 1 FILE A IS TO BE READ_$**FTN 3.2**_^1_%SQZ FILEA_K**FTN 3.2**_^1_%INQ 1_#RESTORE Q_A**FTN 3.2**_^1_%JMP* GETIT_K**FTN 3.2*€€*_^1FILEA INQ 1_"RESTORE Q_B**FTN 3.2**_^1_%LDA* LEVELX_"SET W1 FOR FILE A_5**FTN 3.2**_^1_%STA* GETIT+5_^1_%ENA 0_'CLEAR LEVEL INDEX IN 'LOCAL'_^1_%STA* LEVELX_^1_%SPC 1_^1GETIT GTFILE 0,NAME-GETIT-1,MARKER,,,,,,1_2**FTN 3.0**_^1_%BSS LOCATN(2) READ IN A PART FROM THE LIBE_^1_%JMP* *+4_M**FTN 3.0**_^1NAME_!ALF 3,FTN3A0_$LIBRARY NAME OF LOCAL FILE_^1_%LDA* GETIT+3_^1_%SAZ €€1_^1_%JMP* *-2_^1_%SPC 1_^1_%LDA* (MARKAD)_!GET SIZE OF THIS PART..._^1_%SUB* MARKAD_%A(TOP+1) - A(BOTTOM)_^1_%STA* LENGTH_^1_%STA* SIZES-1,Q SAVE SIZE FOR 'LOCAL'_^1_%SPC 1_^1_%RTJ WRITE_$WRITE PART ON ITS SCRATCH FILE_^1_%ADC FILENR,X0,LENGTH,MARKER_^1MARKAD EQU MARKAD(*-1)_^1_%SPC 1_^1_%INQ -1_(LOOP ON NR OF LOC FILES IN THIS_^1_%SQZ 1_+PHASE ('NRLOCS')_^1_%JMP* LOOP_^1€€_%SPC 1_^1_%JMP* (LOCLIZ)_^1_%SPC 3_^1_%BSS SIZES(NRLOCS),LEVELX_^1_%BSS QSAV(NRLEVS),ISAV(NRLEVS),ENTNR(NRLEVS+1)_^1_%BSS FILSAV(NRLEVS),ADRSV1(NRLEVS)_^1_%BSS ADRSV2(NRLEVS),FLGSAV(NRLEVS)_^1_%BSS FILENR,LENGTH_^1_%ORG ENTNR_^1_%NUM 1_^1_%ORG*_^1_%SPC 3_^1*----------------------------------------------------*_^1* REINITIALIZATION ENTRY...REGENERATE 'SIZES' TABLE *_^1* €€BY READING FIRST WORD OF EACH FILE BACK FROM DISC. *_^1*----------------------------------------------------*_^1_%SPC 1_^1LOCLZ2 NOP_]_^1_%ENA 1_^1_%STA* LENGTH_^1_%ENQ NRLOCS_^1LOC2A TRQ A_^1_%INA 12_^1_%STA* FILENR_^1_%RTJ* READIT_^1_%LDA* MARKER_^1_%SUB* MARKAD_^1_%STA* SIZES-1,Q_^1_%INQ -1_^1_%SQZ 1_^1_%JMP* LOC2A_^1_%STQ* LEVELX_^1_%JMP* (LOCLZ2)_^1_%SPC 3_^1*--------€€--------------------------------------------*_^1* PROGRAM FETCH ENTRY._>*_^1* RTJ LOCAL ... ADC RETURN-ADDRESS ..._.*_^1* NUM PART-NUMBER,ENTRY-NUMBER,FLAG_1*_^1*_S*_^1* SAVES CALLER'S FILE NUMBER AND RETURN ADDRESS, AND *_^1* (Q,I). FETCHES SPECIFIED FILE AND CALLS SPECIFIED *_^1* ENTRY POINT IN ITS TRANSFER VECTOR. AT RETURN,_"*_^1* IF FLAG.EQ.0, RETURNS TO CALLER...IF FLAG.GT.€€0,_"*_^1* READS CALLER BACK IN AND RESTORES HIS IMMEDIATE_"*_^1* RETURN ADDRESS BEFORE RETURNING TO HIM..._)*_^1* IF FLAG.LT.0, GOES BACK CALL CHAIN ONE MORE LEVEL *_^1* TO FIND CALLER'S ULTIMATE RETURN ADDRESS._)*_^1*----------------------------------------------------*_^1_%SPC 1_^1LOCAL NOP_]_^1_%TRQ A_)HOLD (Q)_^1_%LDQ* LEVELX_#BUMP LEVEL INDEX AND CHECK FOR_^1_%INQ 1_^1_%S€€TQ* LEVELX_^1_%SPC 1_^1_%STA* QSAV-1,Q_!SAVE (Q), (I) IN PROPER LEVEL_^1_%LDA- I_+OF THEIR SAVE AREAS._^1_%STA* ISAV-1,Q_^1_%SPC 1_^1_%LDA* FILENR_#SAVE CURRENT FILE NR_^1_%STA* FILSAV-1,Q_!AND RTN ADR IN PROPER LEVELS_^1_%SPC 1_^1_%LDA* (LOCAL)_$OF THEIR TABLES_^1_%STA* FILENR_^1_%LDA* (FILENR)_^1_%STA* ADRSV1-1,Q_^1_%SPC 1_^1_%RAO* LOCAL_^1_%LDA* (LOCAL)_"GET FILE NR AND STOR€€E IN 'READ'_^1_%INA 12_*CALLING SEQUENCE_^1_%STA* FILENR_^1_%SPC 1_^1_%RAO* LOCAL_$GET ENTRY NR FROM CALL_^1_%LDA* (LOCAL)_$AND SAVE IN ITS TABLE_^1_%STA* ENTNR,Q_^1_%SPC 1_^1_%RAO* LOCAL_$GET FLAG FROM CALL AND SAVE IN_^1_%LDA* (LOCAL)_$APPROPRIATE LEVEL OF FLAG TBL_^1_%STA* FLGSAV-1,Q_^1_%SAZ GETSIZ_^1_%SPC 1_^1_%LDA* ENTNR-1,Q GET CALLER'S ENTRY NR AND FROM_^1_%STA- I_+THA€€T AND XFER VECTOR, HIS ENT_^1_%LDA* ENTRYS-1,I_!POINT. FROM THAT GET HIS_^1_%STA- I_+RETURN ADR AND SAVE THAT IN_^1_%LDA- (X0),I_%SECOND ADR-SAVE AREA._^1_%STA* ADRSV2-1,Q_^1_%LDA* FLGSAV-1,Q_^1_%SAP GETSIZ_^1_%LDA* ADRSV2-1,Q_^1_%INA -3_^1_%STA- I_^1_%LDA- (X0),I_^1_%STA* ADRSV2-1,Q_^1_%SPC 1_^1GETSIZ LDQ* FILENR_#GET SIZE OF THIS LOCAL FILE_^1_%LDA* SIZES-13,Q_!FROM PROPER LE€€VEL OF SIZE TBL_^1_%STA* LENGTH_%AND PUT IN 'READ' CALLING SEQ_^1_%SPC 1_^1_%RTJ* READIT_#READ FROM SCRATCH INTO OVERLAY_^1_%SPC 1_^1_%LDQ* LEVELX_^1_%LDQ* ENTNR,Q_"GET ADR OF REQ'D ENTRY FROM_^1_%LDA* ENTRYS-1,Q_!XFER-VEC PART OF FILE_^1_%STA* *+2_)THAT WAS JUST READ IN_^1_%SPC 1_^1CALLIT RTJ+ 0_)*** CALL REQUESTED PROGRAM ***_^1_%SPC 1_^1_%LDQ* LEVELX_#GET CALLER'S FLAG FROM €€FLAG TBL_^1FLAG_!LDA* FLGSAV-1,Q_!AND TEST FOR 0. IF NOT, SKIP_^1_%SAZ GETRTN_^1LOAD_!LDA* FILSAV-1,Q GET NR OF CALLER'S FILE FROM_^1_%STA* FILENR_%PROPER LEVEL OF FILE-SAVE TBL_^1_%TRA Q_)GET SIZE OF THAT FILE FROM_^1_%LDA* SIZES-13,Q_!SIZE TBL_^1_%STA* LENGTH_^1_%SPC 1_^1_%RTJ* READIT_#READ CALLER BACK IN_^1_%SPC 1_^1_%LDQ* LEVELX_#GET RTN ADR FROM PROPER LEVEL_^1GETRTN LDA*€€ ADRSV1-1,Q_^1_%STA* LOCAL_^1_%SPC 1_^1_%LDA* FLGSAV-1,Q_^1_%SAZ RESTOR_^1_%LDA* ENTNR-1,Q GET ADR OF ENTRY POINT IN_^1_%STA- I_+PGM THAT WAS CALLED WHEN THAT_^1_%LDA* ENTRYS-1,I_!FILE WAS READ. GET CALLER'S_^1_%STA- I_+RETURN ADR FROM SECOND SAVE_^1_%LDA* ADRSV2-1,Q_!TABLE AND RESTORE CALLER'S_^1_%STA- (X0),I_%RETURN._^1_%SPC 1_^1RESTOR LDA* ISAV-1,Q_^1_%STA- I_^1_%LDA* QSAV-€€1,Q_!GET (Q)_^1_%INQ -1_(DROP LEVEL INDEX_^1_%STQ* LEVELX_^1_%TRA Q_)RESTORE (Q)_^1_%JMP* (LOCAL)_"RETURN TO CALLER_^1_%SPC 1_^1READIT NOP_]_^1_%RTJ+ READ_%READ A LOCAL FROM ITS SCRATCH_^1_%ADC FILENR,X0,LENGTH,MARKER AREA INTO CORE_^1_%JMP* (READIT)_#STARTING AT 'MARKER'._^1_%SPC 3_^1*----------------------------------------------------*_^1* THE FOLLOWING AREA IS SPECIFIC TO€` EACH LOCAL FILE. *_^1* THE OVERLAY AREA BEGINS HERE._5*_^1*----------------------------------------------------*_^1_%SPC 1_^1MARKER ADC ENDLOC_#ADR OF 1ST WD AFTER THIS FILE_^1_%LST_]_^1ENTRYS ADC ASEMPR,ASGNPR,BDOPR,CPLOOP,ERBPR_^1_%EXT ASEMPR,ASGNPR,BDOPR,CPLOOP,ERBPR_^1_%ADC MODMXR,PUNT_^1_%EXT MODMXR,PUNT_^1_%BZS (9),(1),(1)_^1_%END_]_^__`PWDA3 CSY/ 21F P€1_%NAM DUMYA3_'DECK-ID 21F FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^1*_8DUMYA3 IS USED IN PHASE A3_^1CALL_!MAC SB,P1,P2,P3_^1_%LOC X_^1'X'_"NOP_]_^1_%RTJ'.' 'SB'_^1_%ADC 'X','P1','P2','P3'_^1_%SPC 2_^1_%EMC_]_^1GET_"MAC SB_^1_%NOP_]_^1_%RTJ+ '€€SB'_^1_%JMP* (*-3)_^1_%NUM 0,0_^1_%SPC 2_^1_%EMC_]_^1_%SPC 2_^1_%ENT BYEQPR_^1_%EXT CHECKF_^1_%ENT COMNPR_^1*_8BEGIN_4***** FTN 3.1 *****_^1_%ENT DATAPR_^1*_8END_6***** FTN 3.1 *****_^1_%ENT DIMPR,EXRLPR,PEQVS,SUBPPR,TYPEPR_^1_%EXT ASEMPR,ASGNPR,BDOPR,CPLOOP,ERBPR,PUNT_^1_%ENT ARITH_^1_%ENT IOSPR_^1_%EXT LOCAL_^1_%SPC 2_^1BYEQPR CALL* (LOCAD),2,01,0_^1_%GET CHECKF_^1C€€OMNPR CALL* (LOCAD),2,03,0_^1*_8BEGIN_4***** FTN 3.1 *****_^1DATAPR CALL* (LOCAD),2,04,0_^1*_8END_6***** FTN 3.1 *****_^1DIMPR CALL* (LOCAD),2,05,0_^1EXRLPR CALL* (LOCAD),2,06,0_^1PEQVS CALL* (LOCAD),2,07,0_^1SUBPPR CALL* (LOCAD),2,08,0_^1TYPEPR CALL* (LOCAD),2,09,0_^1_%GET ASEMPR_^1_%GET ASGNPR_^1_%GET BDOPR_^1_%GET CPLOOP_^1_%GET ERBPR_^1_%GET PUNT_^1ARITH CALL* (LOCAD),€F4,01,0_^1IOSPR CALL* (LOCAD),5,01,0_^1LOCAD ADC LOCAL_^1_%END_]_^__FPWLA4 CSY/ 22F P€1_%NAM LOCLA4_'DECK-ID 22F FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^1_%SPC 3_^1*_$PROGRAM BASE .._^1* THIS IS THE 2.0B VERSION._^1* LOCLA4 IS USED IN PHASE A4_^1_%ENT LOCLIZ,LOCLZ2,LOCAL_^1_%EXT WRITE,READ,ENDLOC_^1_%EQU X0($02),X1($03),X3($04)€€,X6($44),X7($05)_^1_%EQU XFFF0($16),LOADPT($F7),X4($25)_^1_%ENT MARKER_J**FTN 3.2**_^1_%SPC 1_^1_%EQU NRLOCS(5)_^1_%EQU NRLEVS(2)_^1_%SPC 1_^1*----------------------------------------------------*_^1* INITIALIZATION ENTRY...COPY LOCAL FILES FROM_%*_^1* LIBRARY TO SCRATCH FILES, RECORDING THEIR SIZES._!*_^1*----------------------------------------------------*_^1_%SPC 1_^1LOC€€LIZ NOP_]_^1_%LDA* MARKAD_#GET REL ADR OF 1ST WD OF FILE_^1_%SUB- LOADPT_%TO BE READ...A(LAST WD)_^1_%STA* LEVELX_#-A(FIRST-1) W1 HOLDER_/**FTN 3.2**_^1_%SPC 1_^1_%ENQ NRLOCS_#INIT PART NR TO NR OF LAST LOC_^1*_7FILE TO BE USED, SO LAST FILE_^1*_7READ CAN STAY IN CORE._^1_%SPC 1_^1LOOP_!LDA* NAME+2_#STORE PART NR IN LAST DIGIT OF_^1_%AND- XFFF0_'PROTO FILE NAME_^1_%AAQ A_^1_%S€€TA* NAME+2_^1_%SPC 1_^1_%TRQ A_)GET SCRATCH FILE NR FROM PART_^1_%INA 12_*NR_^1_%STA* FILENR_^1_%SPC 1_^1_%ENA 0_)CLEAR SECT ADRS IN 'GTFILE' REQ_^1_%STA* LOCATN_^1_%STA* LOCATN+1_^1_%STA* GETIT+7_%SET W2 WORD TO ZERO_177*1895_^1_%INQ -1_#WHEN Q EQUALS 1 FILE A IS TO BE READ_$**FTN 3.2**_^1_%SQZ FILEA_K**FTN 3.2**_^1_%INQ 1_#RESTORE Q_A**FTN 3.2**_^1_%JMP* GETIT_K**FTN 3.2*€€*_^1FILEA INQ 1_"RESTORE Q_B**FTN 3.2**_^1_%LDA* LEVELX_"SET W1 FOR FILE A_5**FTN 3.2**_^1_%STA* GETIT+5_^1_%ENA 0_'CLEAR LEVEL INDEX IN 'LOCAL'_^1_%STA* LEVELX_^1_%SPC 1_^1GETIT GTFILE 0,NAME-GETIT-1,MARKER,,,,,,1_2**FTN 3.0**_^1_%BSS LOCATN(2) READ IN A PART FROM THE LIBE_^1_%JMP* *+4_M**FTN 3.0**_^1NAME_!ALF 3,FTN3A0_$LIBRARY NAME OF LOCAL FILE_^1_%LDA* GETIT+3_^1_%SAZ €€1_^1_%JMP* *-2_^1_%SPC 1_^1_%LDA* (MARKAD)_!GET SIZE OF THIS PART..._^1_%SUB* MARKAD_%A(TOP+1) - A(BOTTOM)_^1_%STA* LENGTH_^1_%STA* SIZES-1,Q SAVE SIZE FOR 'LOCAL'_^1_%SPC 1_^1_%RTJ WRITE_$WRITE PART ON ITS SCRATCH FILE_^1_%ADC FILENR,X0,LENGTH,MARKER_^1MARKAD EQU MARKAD(*-1)_^1_%SPC 1_^1_%INQ -1_(LOOP ON NR OF LOC FILES IN THIS_^1_%SQZ 1_+PHASE ('NRLOCS')_^1_%JMP* LOOP_^1€€_%SPC 1_^1_%JMP* (LOCLIZ)_^1_%SPC 3_^1_%BSS SIZES(NRLOCS),LEVELX_^1_%BSS QSAV(NRLEVS),ISAV(NRLEVS),ENTNR(NRLEVS+1)_^1_%BSS FILSAV(NRLEVS),ADRSV1(NRLEVS)_^1_%BSS ADRSV2(NRLEVS),FLGSAV(NRLEVS)_^1_%BSS FILENR,LENGTH_^1_%ORG ENTNR_^1_%NUM 1_^1_%ORG*_^1_%SPC 3_^1*----------------------------------------------------*_^1* REINITIALIZATION ENTRY...REGENERATE 'SIZES' TABLE *_^1* €€BY READING FIRST WORD OF EACH FILE BACK FROM DISC. *_^1*----------------------------------------------------*_^1_%SPC 1_^1LOCLZ2 NOP_]_^1_%ENA 1_^1_%STA* LENGTH_^1_%ENQ NRLOCS_^1LOC2A TRQ A_^1_%INA 12_^1_%STA* FILENR_^1_%RTJ* READIT_^1_%LDA* MARKER_^1_%SUB* MARKAD_^1_%STA* SIZES-1,Q_^1_%INQ -1_^1_%SQZ 1_^1_%JMP* LOC2A_^1_%STQ* LEVELX_^1_%JMP* (LOCLZ2)_^1_%SPC 3_^1*--------€€--------------------------------------------*_^1* PROGRAM FETCH ENTRY._>*_^1* RTJ LOCAL ... ADC RETURN-ADDRESS ..._.*_^1* NUM PART-NUMBER,ENTRY-NUMBER,FLAG_1*_^1*_S*_^1* SAVES CALLER'S FILE NUMBER AND RETURN ADDRESS, AND *_^1* (Q,I). FETCHES SPECIFIED FILE AND CALLS SPECIFIED *_^1* ENTRY POINT IN ITS TRANSFER VECTOR. AT RETURN,_"*_^1* IF FLAG.EQ.0, RETURNS TO CALLER...IF FLAG.GT.€€0,_"*_^1* READS CALLER BACK IN AND RESTORES HIS IMMEDIATE_"*_^1* RETURN ADDRESS BEFORE RETURNING TO HIM..._)*_^1* IF FLAG.LT.0, GOES BACK CALL CHAIN ONE MORE LEVEL *_^1* TO FIND CALLER'S ULTIMATE RETURN ADDRESS._)*_^1*----------------------------------------------------*_^1_%SPC 1_^1LOCAL NOP_]_^1_%TRQ A_)HOLD (Q)_^1_%LDQ* LEVELX_#BUMP LEVEL INDEX AND CHECK FOR_^1_%INQ 1_^1_%S€€TQ* LEVELX_^1_%SPC 1_^1_%STA* QSAV-1,Q_!SAVE (Q), (I) IN PROPER LEVEL_^1_%LDA- I_+OF THEIR SAVE AREAS._^1_%STA* ISAV-1,Q_^1_%SPC 1_^1_%LDA* FILENR_#SAVE CURRENT FILE NR_^1_%STA* FILSAV-1,Q_!AND RTN ADR IN PROPER LEVELS_^1_%SPC 1_^1_%LDA* (LOCAL)_$OF THEIR TABLES_^1_%STA* FILENR_^1_%LDA* (FILENR)_^1_%STA* ADRSV1-1,Q_^1_%SPC 1_^1_%RAO* LOCAL_^1_%LDA* (LOCAL)_"GET FILE NR AND STOR€€E IN 'READ'_^1_%INA 12_*CALLING SEQUENCE_^1_%STA* FILENR_^1_%SPC 1_^1_%RAO* LOCAL_$GET ENTRY NR FROM CALL_^1_%LDA* (LOCAL)_$AND SAVE IN ITS TABLE_^1_%STA* ENTNR,Q_^1_%SPC 1_^1_%RAO* LOCAL_$GET FLAG FROM CALL AND SAVE IN_^1_%LDA* (LOCAL)_$APPROPRIATE LEVEL OF FLAG TBL_^1_%STA* FLGSAV-1,Q_^1_%SAZ GETSIZ_^1_%SPC 1_^1_%LDA* ENTNR-1,Q GET CALLER'S ENTRY NR AND FROM_^1_%STA- I_+THA€€T AND XFER VECTOR, HIS ENT_^1_%LDA* ENTRYS-1,I_!POINT. FROM THAT GET HIS_^1_%STA- I_+RETURN ADR AND SAVE THAT IN_^1_%LDA- (X0),I_%SECOND ADR-SAVE AREA._^1_%STA* ADRSV2-1,Q_^1_%LDA* FLGSAV-1,Q_^1_%SAP GETSIZ_^1_%LDA* ADRSV2-1,Q_^1_%INA -3_^1_%STA- I_^1_%LDA- (X0),I_^1_%STA* ADRSV2-1,Q_^1_%SPC 1_^1GETSIZ LDQ* FILENR_#GET SIZE OF THIS LOCAL FILE_^1_%LDA* SIZES-13,Q_!FROM PROPER LE€€VEL OF SIZE TBL_^1_%STA* LENGTH_%AND PUT IN 'READ' CALLING SEQ_^1_%SPC 1_^1_%RTJ* READIT_#READ FROM SCRATCH INTO OVERLAY_^1_%SPC 1_^1_%LDQ* LEVELX_^1_%LDQ* ENTNR,Q_"GET ADR OF REQ'D ENTRY FROM_^1_%LDA* ENTRYS-1,Q_!XFER-VEC PART OF FILE_^1_%STA* *+2_)THAT WAS JUST READ IN_^1_%SPC 1_^1CALLIT RTJ+ 0_)*** CALL REQUESTED PROGRAM ***_^1_%SPC 1_^1_%LDQ* LEVELX_#GET CALLER'S FLAG FROM €€FLAG TBL_^1FLAG_!LDA* FLGSAV-1,Q_!AND TEST FOR 0. IF NOT, SKIP_^1_%SAZ GETRTN_^1LOAD_!LDA* FILSAV-1,Q GET NR OF CALLER'S FILE FROM_^1_%STA* FILENR_%PROPER LEVEL OF FILE-SAVE TBL_^1_%TRA Q_)GET SIZE OF THAT FILE FROM_^1_%LDA* SIZES-13,Q_!SIZE TBL_^1_%STA* LENGTH_^1_%SPC 1_^1_%RTJ* READIT_#READ CALLER BACK IN_^1_%SPC 1_^1_%LDQ* LEVELX_#GET RTN ADR FROM PROPER LEVEL_^1GETRTN LDA*€€ ADRSV1-1,Q_^1_%STA* LOCAL_^1_%SPC 1_^1_%LDA* FLGSAV-1,Q_^1_%SAZ RESTOR_^1_%LDA* ENTNR-1,Q GET ADR OF ENTRY POINT IN_^1_%STA- I_+PGM THAT WAS CALLED WHEN THAT_^1_%LDA* ENTRYS-1,I_!FILE WAS READ. GET CALLER'S_^1_%STA- I_+RETURN ADR FROM SECOND SAVE_^1_%LDA* ADRSV2-1,Q_!TABLE AND RESTORE CALLER'S_^1_%STA- (X0),I_%RETURN._^1_%SPC 1_^1RESTOR LDA* ISAV-1,Q_^1_%STA- I_^1_%LDA* QSAV-€€1,Q_!GET (Q)_^1_%INQ -1_(DROP LEVEL INDEX_^1_%STQ* LEVELX_^1_%TRA Q_)RESTORE (Q)_^1_%JMP* (LOCAL)_"RETURN TO CALLER_^1_%SPC 1_^1READIT NOP_]_^1_%RTJ+ READ_%READ A LOCAL FROM ITS SCRATCH_^1_%ADC FILENR,X0,LENGTH,MARKER AREA INTO CORE_^1_%JMP* (READIT)_#STARTING AT 'MARKER'._^1_%SPC 3_^1*----------------------------------------------------*_^1* THE FOLLOWING AREA IS SPECIFIC TO€ EACH LOCAL FILE. *_^1* THE OVERLAY AREA BEGINS HERE._5*_^1*----------------------------------------------------*_^1_%SPC 1_^1MARKER ADC ENDLOC_#ADR OF 1ST WD AFTER THIS FILE_^1_%LST_]_^1ENTRYS ADC ARITH_^1_%EXT ARITH_^1_%BZS (9),(7),(1)_^1_%END_]_^__PWDA4 CSY/ 23F P€1_%NAM DUMYA4_'DECK-ID 23F FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^1CALL_!MAC SB,P1,P2,P3_^1_%LOC X_^1'X'_"NOP_]_^1_%RTJ'.' 'SB'_^1_%ADC 'X','P1','P2','P3'_^1_%SPC 2_^1_%EMC_]_^1GET_"MAC SB_^1_%NOP_]_^1_%RTJ+ 'SB'_^1_%JMP* (*-3)_^1_%NUM 0,0_€€^1_%SPC 2_^1_%EMC_]_^1_%SPC 2_^1* THIS IS THE 2.0B VERSION._^1* DUMYA4 IS USED IN PHASE A4_^1_%ENT BYEQPR,CHECKF,COMNPR,DATAPR_^1_%ENT DIMPR,EXRLPR,PEQVS,SUBPPR,TYPEPR_^1_%ENT ASEMPR,ASGNPR,CPLOOP,ERBPR,PUNT_^1_%EXT ARITH_^1_%ENT BDOPR,IOSPR_^1_%EXT LOCAL_^1_%SPC 2_^1BYEQPR CALL* (LOCAD),2,01,0_^1CHECKF CALL* (LOCAD),2,02,0_^1COMNPR CALL* (LOCAD),2,03,0_^1DATAPR CALL* (LOC€€AD),2,04,0_^1DIMPR CALL* (LOCAD),2,05,0_^1EXRLPR CALL* (LOCAD),2,06,0_^1PEQVS CALL* (LOCAD),2,07,0_^1SUBPPR CALL* (LOCAD),2,08,0_^1TYPEPR CALL* (LOCAD),2,09,0_^1ASEMPR CALL* (LOCAD),3,01,0_^1ASGNPR CALL* (LOCAD),3,02,0_^1BDOPR CALL* (LOCAD),3,03,0_^1CPLOOP CALL* (LOCAD),3,04,0_^1ERBPR CALL* (LOCAD),3,05,0_^1PUNT_!CALL* (LOCAD),3,07,0_^1_%GET ARITH_^1IOSPR CALL* (LOCAD),5,01,0€"_^1LOCAD ADC LOCAL_^1_%END_]_^__"PWLA5 CSY/ 24F P€1_%NAM LOCLA5_'DECK-ID 24F FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^1_%SPC 3_^1*_$PROGRAM BASE .._^1* THIS IS THE 2.0B VERSION._^1* LOCLA5 IS USED IN PHASE A5_^1_%ENT LOCLIZ,LOCLZ2,LOCAL_^1_%EXT WRITE,READ,ENDLOC_^1_%EQU X0($02),X1($03),X3($04)€€,X6($44),X7($05)_^1_%EQU XFFF0($16),LOADPT($F7),X4($25)_^1_%ENT MARKER_J**FTN 3.2**_^1_%SPC 1_^1_%EQU NRLOCS(5)_^1_%EQU NRLEVS(2)_^1_%SPC 1_^1*----------------------------------------------------*_^1* INITIALIZATION ENTRY...COPY LOCAL FILES FROM_%*_^1* LIBRARY TO SCRATCH FILES, RECORDING THEIR SIZES._!*_^1*----------------------------------------------------*_^1_%SPC 1_^1LOC€€LIZ NOP_]_^1_%LDA* MARKAD_#GET REL ADR OF 1ST WD OF FILE_^1_%SUB- LOADPT_%TO BE READ...A(LAST WD)_^1_%STA* LEVELX_#-A(FIRST-1) W1 HOLDER_/**FTN 3.2**_^1_%SPC 1_^1_%ENQ NRLOCS_#INIT PART NR TO NR OF LAST LOC_^1*_7FILE TO BE USED, SO LAST FILE_^1*_7READ CAN STAY IN CORE._^1_%SPC 1_^1LOOP_!LDA* NAME+2_#STORE PART NR IN LAST DIGIT OF_^1_%AND- XFFF0_'PROTO FILE NAME_^1_%AAQ A_^1_%S€€TA* NAME+2_^1_%SPC 1_^1_%TRQ A_)GET SCRATCH FILE NR FROM PART_^1_%INA 12_*NR_^1_%STA* FILENR_^1_%SPC 1_^1_%ENA 0_)CLEAR SECT ADRS IN 'GTFILE' REQ_^1_%STA* LOCATN_^1_%STA* LOCATN+1_^1_%STA* GETIT+7_%SET W2 WORD TO ZERO_177*1895_^1_%INQ -1_#WHEN Q EQUALS 1 FILE A IS TO BE READ_$**FTN 3.2**_^1_%SQZ FILEA_K**FTN 3.2**_^1_%INQ 1_#RESTORE Q_A**FTN 3.2**_^1_%JMP* GETIT_K**FTN 3.2*€€*_^1FILEA INQ 1_"RESTORE Q_B**FTN 3.2**_^1_%LDA* LEVELX_"SET W1 FOR FILE A_5**FTN 3.2**_^1_%STA* GETIT+5_^1_%ENA 0_'CLEAR LEVEL INDEX IN 'LOCAL'_^1_%STA* LEVELX_^1_%SPC 1_^1GETIT GTFILE 0,NAME-GETIT-1,MARKER,,,,,,1_2**FTN 3.0**_^1_%BSS LOCATN(2) READ IN A PART FROM THE LIBE_^1_%JMP* *+4_M**FTN 3.0**_^1NAME_!ALF 3,FTN3A0_$LIBRARY NAME OF LOCAL FILE_^1_%LDA* GETIT+3_^1_%SAZ €€1_^1_%JMP* *-2_^1_%SPC 1_^1_%LDA* (MARKAD)_!GET SIZE OF THIS PART..._^1_%SUB* MARKAD_%A(TOP+1) - A(BOTTOM)_^1_%STA* LENGTH_^1_%STA* SIZES-1,Q SAVE SIZE FOR 'LOCAL'_^1_%SPC 1_^1_%RTJ WRITE_$WRITE PART ON ITS SCRATCH FILE_^1_%ADC FILENR,X0,LENGTH,MARKER_^1MARKAD EQU MARKAD(*-1)_^1_%SPC 1_^1_%INQ -1_(LOOP ON NR OF LOC FILES IN THIS_^1_%SQZ 1_+PHASE ('NRLOCS')_^1_%JMP* LOOP_^1€€_%SPC 1_^1_%JMP* (LOCLIZ)_^1_%SPC 3_^1_%BSS SIZES(NRLOCS),LEVELX_^1_%BSS QSAV(NRLEVS),ISAV(NRLEVS),ENTNR(NRLEVS+1)_^1_%BSS FILSAV(NRLEVS),ADRSV1(NRLEVS)_^1_%BSS ADRSV2(NRLEVS),FLGSAV(NRLEVS)_^1_%BSS FILENR,LENGTH_^1_%ORG ENTNR_^1_%NUM 1_^1_%ORG*_^1_%SPC 3_^1*----------------------------------------------------*_^1* REINITIALIZATION ENTRY...REGENERATE 'SIZES' TABLE *_^1* €€BY READING FIRST WORD OF EACH FILE BACK FROM DISC. *_^1*----------------------------------------------------*_^1_%SPC 1_^1LOCLZ2 NOP_]_^1_%ENA 1_^1_%STA* LENGTH_^1_%ENQ NRLOCS_^1LOC2A TRQ A_^1_%INA 12_^1_%STA* FILENR_^1_%RTJ* READIT_^1_%LDA* MARKER_^1_%SUB* MARKAD_^1_%STA* SIZES-1,Q_^1_%INQ -1_^1_%SQZ 1_^1_%JMP* LOC2A_^1_%STQ* LEVELX_^1_%JMP* (LOCLZ2)_^1_%SPC 3_^1*--------€€--------------------------------------------*_^1* PROGRAM FETCH ENTRY._>*_^1* RTJ LOCAL ... ADC RETURN-ADDRESS ..._.*_^1* NUM PART-NUMBER,ENTRY-NUMBER,FLAG_1*_^1*_S*_^1* SAVES CALLER'S FILE NUMBER AND RETURN ADDRESS, AND *_^1* (Q,I). FETCHES SPECIFIED FILE AND CALLS SPECIFIED *_^1* ENTRY POINT IN ITS TRANSFER VECTOR. AT RETURN,_"*_^1* IF FLAG.EQ.0, RETURNS TO CALLER...IF FLAG.GT.€€0,_"*_^1* READS CALLER BACK IN AND RESTORES HIS IMMEDIATE_"*_^1* RETURN ADDRESS BEFORE RETURNING TO HIM..._)*_^1* IF FLAG.LT.0, GOES BACK CALL CHAIN ONE MORE LEVEL *_^1* TO FIND CALLER'S ULTIMATE RETURN ADDRESS._)*_^1*----------------------------------------------------*_^1_%SPC 1_^1LOCAL NOP_]_^1_%TRQ A_)HOLD (Q)_^1_%LDQ* LEVELX_#BUMP LEVEL INDEX AND CHECK FOR_^1_%INQ 1_^1_%S€€TQ* LEVELX_^1_%SPC 1_^1_%STA* QSAV-1,Q_!SAVE (Q), (I) IN PROPER LEVEL_^1_%LDA- I_+OF THEIR SAVE AREAS._^1_%STA* ISAV-1,Q_^1_%SPC 1_^1_%LDA* FILENR_#SAVE CURRENT FILE NR_^1_%STA* FILSAV-1,Q_!AND RTN ADR IN PROPER LEVELS_^1_%SPC 1_^1_%LDA* (LOCAL)_$OF THEIR TABLES_^1_%STA* FILENR_^1_%LDA* (FILENR)_^1_%STA* ADRSV1-1,Q_^1_%SPC 1_^1_%RAO* LOCAL_^1_%LDA* (LOCAL)_"GET FILE NR AND STOR€€E IN 'READ'_^1_%INA 12_*CALLING SEQUENCE_^1_%STA* FILENR_^1_%SPC 1_^1_%RAO* LOCAL_$GET ENTRY NR FROM CALL_^1_%LDA* (LOCAL)_$AND SAVE IN ITS TABLE_^1_%STA* ENTNR,Q_^1_%SPC 1_^1_%RAO* LOCAL_$GET FLAG FROM CALL AND SAVE IN_^1_%LDA* (LOCAL)_$APPROPRIATE LEVEL OF FLAG TBL_^1_%STA* FLGSAV-1,Q_^1_%SAZ GETSIZ_^1_%SPC 1_^1_%LDA* ENTNR-1,Q GET CALLER'S ENTRY NR AND FROM_^1_%STA- I_+THA€€T AND XFER VECTOR, HIS ENT_^1_%LDA* ENTRYS-1,I_!POINT. FROM THAT GET HIS_^1_%STA- I_+RETURN ADR AND SAVE THAT IN_^1_%LDA- (X0),I_%SECOND ADR-SAVE AREA._^1_%STA* ADRSV2-1,Q_^1_%LDA* FLGSAV-1,Q_^1_%SAP GETSIZ_^1_%LDA* ADRSV2-1,Q_^1_%INA -3_^1_%STA- I_^1_%LDA- (X0),I_^1_%STA* ADRSV2-1,Q_^1_%SPC 1_^1GETSIZ LDQ* FILENR_#GET SIZE OF THIS LOCAL FILE_^1_%LDA* SIZES-13,Q_!FROM PROPER LE€€VEL OF SIZE TBL_^1_%STA* LENGTH_%AND PUT IN 'READ' CALLING SEQ_^1_%SPC 1_^1_%RTJ* READIT_#READ FROM SCRATCH INTO OVERLAY_^1_%SPC 1_^1_%LDQ* LEVELX_^1_%LDQ* ENTNR,Q_"GET ADR OF REQ'D ENTRY FROM_^1_%LDA* ENTRYS-1,Q_!XFER-VEC PART OF FILE_^1_%STA* *+2_)THAT WAS JUST READ IN_^1_%SPC 1_^1CALLIT RTJ+ 0_)*** CALL REQUESTED PROGRAM ***_^1_%SPC 1_^1_%LDQ* LEVELX_#GET CALLER'S FLAG FROM €€FLAG TBL_^1FLAG_!LDA* FLGSAV-1,Q_!AND TEST FOR 0. IF NOT, SKIP_^1_%SAZ GETRTN_^1LOAD_!LDA* FILSAV-1,Q GET NR OF CALLER'S FILE FROM_^1_%STA* FILENR_%PROPER LEVEL OF FILE-SAVE TBL_^1_%TRA Q_)GET SIZE OF THAT FILE FROM_^1_%LDA* SIZES-13,Q_!SIZE TBL_^1_%STA* LENGTH_^1_%SPC 1_^1_%RTJ* READIT_#READ CALLER BACK IN_^1_%SPC 1_^1_%LDQ* LEVELX_#GET RTN ADR FROM PROPER LEVEL_^1GETRTN LDA*€€ ADRSV1-1,Q_^1_%STA* LOCAL_^1_%SPC 1_^1_%LDA* FLGSAV-1,Q_^1_%SAZ RESTOR_^1_%LDA* ENTNR-1,Q GET ADR OF ENTRY POINT IN_^1_%STA- I_+PGM THAT WAS CALLED WHEN THAT_^1_%LDA* ENTRYS-1,I_!FILE WAS READ. GET CALLER'S_^1_%STA- I_+RETURN ADR FROM SECOND SAVE_^1_%LDA* ADRSV2-1,Q_!TABLE AND RESTORE CALLER'S_^1_%STA- (X0),I_%RETURN._^1_%SPC 1_^1RESTOR LDA* ISAV-1,Q_^1_%STA- I_^1_%LDA* QSAV-€€1,Q_!GET (Q)_^1_%INQ -1_(DROP LEVEL INDEX_^1_%STQ* LEVELX_^1_%TRA Q_)RESTORE (Q)_^1_%JMP* (LOCAL)_"RETURN TO CALLER_^1_%SPC 1_^1READIT NOP_]_^1_%RTJ+ READ_%READ A LOCAL FROM ITS SCRATCH_^1_%ADC FILENR,X0,LENGTH,MARKER AREA INTO CORE_^1_%JMP* (READIT)_#STARTING AT 'MARKER'._^1_%SPC 3_^1*----------------------------------------------------*_^1* THE FOLLOWING AREA IS SPECIFIC TO€ EACH LOCAL FILE. *_^1* THE OVERLAY AREA BEGINS HERE._5*_^1*----------------------------------------------------*_^1_%SPC 1_^1MARKER ADC ENDLOC_#ADR OF 1ST WD AFTER THIS FILE_^1_%LST_]_^1ENTRYS ADC IOSPR_^1_%EXT IOSPR_^1_%BZS (9),(7),(1)_^1_%END_]_^__PWDA5 CSY/ 25F P€1_%NAM DUMYA5_'DECK-ID 25F FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^1CALL_!MAC SB,P1,P2,P3_^1_%LOC X_^1'X'_"NOP_]_^1_%RTJ'.' 'SB'_^1_%ADC 'X','P1','P2','P3'_^1_%SPC 2_^1_%EMC_]_^1GET_"MAC SB_^1_%NOP_]_^1_%RTJ+ 'SB'_^1_%JMP* (*-3)_^1_%NUM 0,0_€€^1_%SPC 2_^1_%EMC_]_^1_%SPC 2_^1* THIS IS THE 2.0B VERSION._^1* DUMYA5 IS USED IN PHASE A5_^1_%ENT BYEQPR,CHECKF,COMNPR,DATAPR_^1_%ENT DIMPR,EXRLPR,PEQVS,SUBPPR,TYPEPR_^1_%ENT ASEMPR,ASGNPR_^1_%EXT BDOPR_^1_%ENT CPLOOP,ERBPR,PUNT_^1_%ENT ARITH_^1_%EXT IOSPR_^1_%EXT LOCAL_^1_%SPC 2_^1BYEQPR CALL* (LOCAD),2,01,0_^1CHECKF CALL* (LOCAD),2,02,0_^1COMNPR CALL* (LOCAD),2,03,0_^€€1DATAPR CALL* (LOCAD),2,04,0_^1DIMPR CALL* (LOCAD),2,05,0_^1EXRLPR CALL* (LOCAD),2,06,0_^1PEQVS CALL* (LOCAD),2,07,0_^1SUBPPR CALL* (LOCAD),2,08,0_^1TYPEPR CALL* (LOCAD),2,09,0_^1ASEMPR CALL* (LOCAD),3,01,0_^1ASGNPR CALL* (LOCAD),3,02,0_^1_%GET BDOPR_^1CPLOOP CALL* (LOCAD),3,04,0_^1ERBPR CALL* (LOCAD),3,05,0_^1PUNT_!CALL* (LOCAD),3,07,0_^1ARITH CALL* (LOCAD),4,01,0_^1_%GET IO€&SPR_^1LOCAD ADC LOCAL_^1_%END_]_^__ &PWGOB CSY/ 26F P€1_%NAM GOB_*DECK-ID 26F FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^1_%SPC 3_^1*_8GOB IS USED IN PHASE B_^1_%ENT GOB,SKIPIT_^1_%EXT PHASEB,IOPR,WRITE_^1_%DAT IFLAGS_NFTN 3.3_^1_%DAT LINECT_NFTN 3.3_^1_%DAT LINCT1_NFTN 3.3_^1_%DAT IR_RFTN 3.3_^1€€_%DAT IK_RFTN 3.3_^1_%DAT IP_RFTN 3.3_^1_%DAT IA_RFTN 3.3_^1_%DAT IL_RFTN 3.3_^1_%DAT IM_RFTN 3.3_^1_%DAT IXLGO_OFTN 3.3_^1_%DAT IOPTO_OFTN 3.3_^1_%DAT IOPTV_OFTN 3.3_^1_%DAT IOPTC_OFTN 3.3_^1_%DAT IOPTD_OFTN 3.3_^1_%DAT MCSTRT_NFTN 3.3_^1_%DAT MACRNB_NFTN 3.3_^1_%DAT MACSEC_NFTN 3.3_^1_%DAT IERRS(16)_KFTN 3.3_^1_%DAT ISRFAD_NFTN 3.3_^1_%DAT LGO_QFTN 3.3_^1_%DAT IS€€CRI_OFTN 3.3_^1_%DAT ISCRO_OFTN 3.3_^1_%DAT IX_RFTN 3.3_^1_%DAT B(1783-38)_JFTN 3.3_^1_%COM D($0495)_E*4.0/75*1761_^1* ********************************** FTN 3.1 ($) **********************_^1GOB_"NOP 0_^1_%ENA -4_(CLEAR THE 'PHASE A FILES_^1IFAD_!AND+ IFLAGS_%INTACT' FLAG._^1_%STA* (*-1)_^1_%LDQ* (INAD)_#SCRATCH IN (ISCRI)_^1_%LDA* (OUTAD)_"SCRATCH OUT (ISCRO)_^1_%STA* (INAD€V)_#OUT BECOMES IN_^1_%STQ* (OUTAD)_"IN BECOMES OUT_^1_%RTJ+ IOPR_%INITIALIZE IOPR_^1_%RTJ+ PHASEB_#EXECUTE PHASE B_^1RETURN RAO* GOB_'NORMAL RETURN TO 'FTN'_^1_%RTJ+ WRITE_$OUTPUT LAST WRITE BUFFER_^1OUTAD ADC ISCRO,XFFFE_^1SKIPIT NOP 0_)ABNORMAL RETURN_^1_%JMP* RETURN+1_^1_%JMP* (GOB)_^1INAD_!ADC ISCRI_^1_%EQU XFFFE($13)_^1_%END_]_^__VPWIOPRB CSY/ 27F P€1_%NAM IOPRBB_'DECK-ID 27F FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^1_%SPC 3_^1*_$PROGRAM BASE .._^1* THIS IS THE 2.0B VERSION._^1* NO LOCALS IN 2.0B. SCRATCH 'PAGE' SIZE NOW 6 SECTORS. DIFFERENT_^1* DISC ALLOCATION._^1* IOPRBB IS USED IN PHASE €€B_^1*_]_^1* FORTRAN I/O PROCESSOR - VERSION 2.0B, BUFFERED_^1*_!THIS SUB-VERSION IS FOR PHASE B ONLY._^1*_!INCLUDES OPTIMUM ALLOCATION_^1*_+OVERLAY ALLOCATION_^1* THE FOLLOWING REQUESTS ARE PROCESSED..._^1* CALL IOPR_,INITIALIZATION_^1* CALL READ (U,M,L,A)_!INPUT_^1* CALL WRITE (U,M,L,A) OUTPUT_^1* CALL EXIT_,RETURN TO O.S._^1* WHERE..._]_^1*_!U IS ADR OF LOGICAL UNIT NR_^1*_!€€M IS ADR OF MODE (IF U .LT. 11)_^1*_'ADR OF RECORD NR (IF U .GE. 11)_^1*_!L IS ADR OF LENGTH (IGNORED IF U = 9 OR 10)_^1*_!A IS ADR OF USER'S AREA_^1* LOGICAL UNIT NUMBERS FOR 'IOPR'..._^1*_"1 IS STANDARD INPUT DEVICE_^1*_"2 IS STANDARD BINARY OUTPUT DEVICE_^1*_"3 IS STANDARD LIST DEVICE_^1*_"4 IS STANDARD COMMENT DEVICE_^1*_"9 IS DISC SCRATCH FILE 1_^1*_!10 IS DISC SCRATCH FILE 2_€€^1*_!11 IS SYMBOL TABLE_^1*_!12 IS LOAD-AND-GO FILE_^1*_]_^1_%ENT IOPR,READ,WRITE,EXIT_^1_%EXT MAXSEC_L77*1879_^1_%EXT PAGCHK_NFTN 3.3_^1_%DAT IFLAGS_NFTN 3.3_^1_%DAT LINECT_NFTN 3.3_^1_%DAT LINCT1_NFTN 3.3_^1_%DAT A(32)_OFTN 3.3_^1_%DAT ISCRI_OFTN 3.3_^1_%EQU X3($04)_^1*_]_^1******************************************************_^1* 'READ' AND 'WRITE' ENTRIES_8*_^1*******€€***********************************************_^1*_]_^1READ_!NOP 0_^1_%STQ* QSAV_^1_%LDA =N$08FD_"INPUT COMMENT DEVICE CODE_^1_%STA* DC+3_^1_%LDA =N$4801_%'FREAD' REQUEST CODE_.**FTN 3.0**_^1_%LDQ* READ_%GET LINK._^1_%JMP* IOPROC_^1_%SPC 2_^1WRITE NOP 0_^1_%STQ* QSAV_^1_%LDA =N$08FC_"OUTPUT COMMENT DEVICE CODE_^1_%STA* DC+3_^1_%LDA =N$4C01_%'FWRITE' REQUEST CODE_-**FTN 3.0€€**_^1_%LDQ* WRITE_$GET LINK._^1_%SPC 2_^1IOPROC STQ* LINK_%SAVE LINK._^1_%STA* REQ+1_$SET REQUEST TYPE._^1_%LDA- I_)SAVE $FF._^1_%STA* ISAV_^1_%LDQ* (LINK)_#GET LOGICAL UNIT NUMBER._^1_%RAO* LINK_^1_%STQ* REQ+4_^1_%LDQ* (REQ+4)_^1_%STQ- I_)SAVE._^1_%LDA* (LINK)_#GET SECTOR ADDRESS OR MODE._^1_%RAO* LINK_^1_%STA* RECAD_^1_%LDA* (LINK)_#GET RECORD LENGTH._^1_%RAO* LINK_^1_%STA* REQ+€€5_^1_%LDA* (REQ+5)_^1_%STA* REQ+5_^1_%LDA* (LINK)_#GET USER'S AREA ADDRESS._^1_%STA* REQ+6_^1_%INQ -9_(TEST L.U. NR FOR MASS STORAGE._^1_%SQM 1_^1_%JMP* MS_^1_%LDQ* (RECAD)_"GET MODE AND DEVICE CODE,_^1_%LDA* DC-1,I_%COMBINE AND STORE._^1_%ALS 4_^1_%LRS 4_^1_%STA* REQ+4_^1_%LDA =N$1802_"IF NOT M.S. REQ, SET 1ST WORD_^1_%STA* REQ+7_'AFTER PARAMS TO 'JMP *+2'._^1_%JMP* REQ0_PFTN€€ 3.3_^1_%SPC 2_^1MS_#INQ -2_(M.S. CALL- TEST FOR SCRATCH._^1_%SQP DIRECT_^1_%JMP* SCRTCH_^1DIRECT LDA =N$08B3_"NO- SYMTAB, LGO, OR OV. UNIT =_^1_%STA* REQ+4_'SCRATCH DISC, MORE SIGNIF._^1_%ENA 0_+PART OF SECTOR NR =0,_^1_%STA* REQ+7_'STARTING SECTOR NR = BASE_^1_%LDA* SN,Q_(FOR THAT FILE_^1MS1_"ADD* (RECAD)_$+ RECORD NUMBER_^1_%STA* REQ+8_^1_%SPC 2_^1REQ0_!LDA* UNIT_)PICK UP€€ LU OF OUTPUT UNIT_-FTN 3.3_^1_%AND- X0FFF_OFTN 3.3_^1_%EOR* DC+2_)CHECK FOR AND SKIP IF NOT STD LIST_#FTN 3.3_^1_%SAN REQ_QFTN 3.3_^1_%RTJ PAGCHK_'BUMP LINE CTR AND CHK FOR END OF PAGE FTN 3.3_^1REQ_"RTJ- ($F4)_$I/O REQUEST..._^1_%NUM 0_+REQUEST CODE_^1_%ADC 0_+COMPLETION ADDRESS_^1THREAD ADC 0_+REQUEST THREAD_^1UNIT_!NUM 0_+LOGICAL UNIT NR_^1_%NUM 0_+LENGTH_^1_%ADC 0_+ST€€ARTING ADDRESS_^1_%NUM 0_+MSP OF SECTOR NR, OR JMP *+2_^1_%NUM 0_+LSP OF SECTOR NR_^1_%LDA* THREAD_#HANG ON THREAD TILL I/O DONE._^1_%SAZ 1_^1_%JMP* *-2_^1_%SPC 2_^1*_85 CARDS DELETED_7FTN 3.3_^1REQDON RAO* LINK_%RESTORE REGISTERS_^1_%LDQ* QSAV_(AND RETURN._^1_%LDA* ISAV_^1_%STA- I_^1_%JMP* (LINK)_^1_%SPC 1_^1* LINK_!- ADDRESS OF PARAMETERS, RETURN ADDRESS._^1* QSAV_!- (Q) AT €€CALL._^1* ISAV_!- (I) AT CALL._^1* RECAD - ADDRESS OF MODE OR RECORD NUMBER, IN CALL._^1* SN_#- RELATIVE SECTOR NR OF SYMBOL TABLE._^1* +1_"- RELATIVE SECTOR NR OF LOAD-GO FILE, -1._^1* DC_#- 'UNIT NR' VALUES FOR STANDARD I/O UNITS._^1_%SPC 1_^1_%BSS LINK,QSAV,ISAV,RECAD_^1_%BZS SN(2)_^1DC_#NUM $08F9,$08FA,$08FB,0_^1_%SPC 1_^1_%EQU X0FFF($0E)_^1*_819 CARDS DELETED_6FTN 3.3_€€^1_%EJT_]_^1*_]_^1******************************************************_^1* SCRATCH FILE PROCESSING_;*_^1******************************************************_^1*_]_^1SCRTCH INQ 2_)SCRATCH I/O CALL. SAVE FILE_^1_%STQ* SCRSW_'NUMBER._^1_%LDA* REQ+1_$SET FLAG FROM REQUEST CODE..._^1_%ALS 5_++ FOR READ, - FOR WRITE._^1_%STA* SFLG_^1_%SAP 1_)JUMP IF WRITE._^1_%JMP* SWRITE_^1SREAD€€ LDA* REQ+6_$GET USER'S AREA ADDRESS._^1_%STA* SA_^1_%LDQ* RPT_'READ POINTER (TO CURRENT BFR)_^1S1_#LDA+ RBUF1,Q_"GET RECORD LENGTH (FROM FIRST_^1_%INA -1_*WORD OF RECORD) AND PUT IN_^1_%STA* NWR_)WORD COUNTER._^1_%LDA* WPPM1_$COMPUTE REMAINING WORDS IN THIS_^1_%SUB* RPT_)READ BUFFER AND SET INDEX._^1S2_#STQ- I_^1_%STA* REM_'SAVE NR OF WORDS REMAINING IN_^1_%TRA Q_+BUFFER AND CO€€MPARE TO REMAIN-_^1_%SUB* NWR_)DER OF WORDS IN RECORD._^1_%SAM 1_)RECORD OVERLAPS PAGES_^1_%LDQ* NWR_'RECORD DOES NOT OVERLAP_^1S3_#LDA* SFLG_^1_%SAP 1_^1_%JMP* W2_(JUMP IF WRITING._^1_%LDA* (S1+1),B_!MOVE WORD FROM READ_^1_%STA* (SA),Q_%BUFFER TO USER'S AREA._^1_%RAO* RPT_'BUMP READ POINTER_^1S4_#INQ -1_*AND DECREMENT COUNT._^1_%SQM 1_)IS COUNT EXHAUSTED_^1_%JMP* S3_*NO._^1_%L€€DA* WDSPPG_^1_%LDQ* SFLG_^1_%SQM W3_(SKIP IF WRITING._^1_%SUB* RPT_'IS READ BUFFER EMPTY_^1S5_#SAZ S6_*YES, CONTINUE FROM OTHER._^1_%JMP* REQDON_%NO, RETURN._^1W3_#SUB* WPT_'IS WRITE BUFFER EMPTY_^1_%SAZ S8_^1_%JMP* REQDON_%NO, RETURN._^1S8_#JMP* W4_*YES, CONTINUE TO OTHER._^1S6_#RTJ* LOADR1_#INITIATE LOADING OF JUST-EMPTY_^1S10_"LDQ* RB1AV_'BUFFER. WAIT TILL AVAILABLE._^1S11_"€€SQZ 1_^1_%JMP* S10_^1_%ENA 0_)CLEAR READ POINTER._^1_%STA* RPT_^1MSCA_!RAO* REM_'INCREMENT STARTING ADDRESS BY_^1_%LDA* SA_*NUMBER OF WORDS PROCESSED SO_^1_%ADD* REM_)FAR._^1_%STA* SA_^1_%LDQ* SCRSW_$STEP CURRENT SECTOR NUMBER OF_^1_%LDA* CSN1,Q_%SCRATCH FILE BEING USED, BY_^1_%INA PGSIZS*2_#TWICE THE SCRATCH PAGE SIZE._^1_%STA* CSN1,Q_^1S13_"SUB* SECT_%TEST FOR OVERFLOW OF SCRA€€TCH._^1_%SAM S14_^1_%JMP ABORT_^1S14_"LDA* NWR_'DECREMENT NR OF WDS REMAINING_^1_%SUB* REM_)BY NR OF WDS PROCESSED_^1_%STA* NWR_)SO FAR._^1_%INA 1_)TRANSFER COMPLETE IF NWR = REM._^1_%SAN 1_^1_%JMP* REQDON_^1_%LDA* WPPM1_$ELSE LOAD REMAINDER AND POINTER_^1_%ENQ 0_+AND CONTINUE._^1_%JMP* S2_^1_%SPC 2_^1* SCRSW - SCRATCH FILE SWITCH- 0 FOR FILE 1, 1 FOR 2._^1* SFLG_!- TYPE OF €€CALL- + FOR READ, - FOR WRITE._^1* SA_#- START ADR FOR SCRATCH XFR_^1* RPT_"- READ POINTER, TO CURRENT BUFFER_^1* NWR_"- NR OF WDS YET TO BE MOVED, THIS CALL._^1* SECT_!- TOTAL NR OF SCRATCH SECTORS NOW ON DISC._^1* PGSIZS - SCRATCH 'PAGE' SIZE IN SECTORS._^1* PGSIZW - SCRATCH 'PAGE' SIZE IN WORDS._^1* REM_"- NR OF WORDS MOVED SO FAR, THIS CALL._^1* CSN1_!- CURRENT SECTOR NUMBER FO€€R FILE 1._^1* CSN2_!- CURRENT SECTOR NUMBER FOR FILE 2._^1_%SPC 1_^1_%BSS SCRSW,SFLG,SA,RPT,NWR,SECT_^1_%EQU PGSIZS(6),PGSIZW(PGSIZS*96)_^1WDSPPG ADC PGSIZW_^1WPPM1 ADC PGSIZW-1_^1_%BSS REM,CSN1,CSN2_^1_%SPC 2_^1SWRITE LDA* (RECAD)_"TEST FOR 'M' .LT. 0...THIS_^1_%SAP W1_*REQUESTS EMPTYING OUTPUT BFR._^1_%RTJ* DUMPW1_^1F2_#LDA* WB1AV_'WAIT TILL BUFFER AVAILABLE,_^1_%SAZ 1_€€^1_%JMP* F2_^1_%JMP REQDON_%THEN RETURN._^1W1_#LDA REQ+6_$GET USER'S AREA ADDRESS._^1_%STA* SA_^1_%LDQ* WPT_'WRITE POINTER_^1_%LDA+ REQ+5_'GET RECORD LENGTH FROM_^1_%INA_!-1_+REQUEST AND PU T IN_.PSR_^1_%STA* NWR_)WORD COUNTER._^1_%LDA* WPPM1_$COMPUTE REMAINING WORDS IN_^1_%SUB* WPT_)WRITE BUFFER._^1_%JMP* S2_^1W2_#LDA* (SA),Q_#MOVE WORD FROM USER'S AREA_^1_%STA* WBUF1,B_$TO CUR€€RENT BUFFER._^1_%RAO* WPT_'BUMP WRITE POINTER..._^1_%JMP* S4_^1W4_#RTJ* DUMPW1_#INITIATE DUMPING OF_^1W6_#LDQ* WB1AV_'OUTPUT BUFFER AND WAIT_^1W7_#SQZ 1_+TILL AVAILABLE._^1_%JMP* W6_^1_%ENA 0_)CLEAR WRITE POINTER._^1_%STA* WPT_^1_%JMP* MSCA_%PROCEED._^1_%SPC 2_^1* WPT_"- WRITE POINTER, TO CURRENT BUFFER._^1_%SPC 1_^1_%BSS WPT_^1_%SPC 2_^1*_]_^1********************************€€**********************_^1* MASS STORAGE BUFFER IN/OUT ROUTINES_/*_^1******************************************************_^1*_]_^1LOADR1 NOP 0_^1_%RTJ* LD1_'GET CURRENT SECTOR NR_^1L1_#STA* L2_^1_%RTJ- ($F4)_$'FREAD' REQUEST..._^1_%NUM $4801_K**FTN 3.0**_^1_%ADC 0_^1RB1AV ADC 0_)THREAD = BUFFER-AVAILABLE FLAG_^1_%NUM $08B3_$UNIT= SCRATCH DISC_^1_%ADC PGSIZW_#LENGTH= WORDS P€€ER SCRATCH PAGE_^1_%ADC RBUF1_$ADDRESS= READ BUFFER 1_^1_%NUM 0_^1_%BSS L2_(SECTOR- TO BE PLUGGED_^1_%JMP* (LOADR1)_!WHEN REQ THREADED, RETURN._^1_%SPC 1_^1DUMPW1 NOP 0_^1_%RTJ* LD1_^1D1_#STA* D2_^1_%RTJ- ($F4)_^1_%NUM $4C01_K**FTN 3.0**_^1_%ADC 0_^1WB1AV ADC 0_^1_%NUM $08B3_^1_%ADC PGSIZW_^1_%ADC WBUF1_^1_%NUM 0_^1_%BSS D2_^1_%JMP* (DUMPW1)_^1_%SPC 1_^1LD1_"NOP 0_^€€1_%LDQ* SCRSW_$SET SECTOR NUMBER OF REQUEST_^1_%LDA* CSN1,Q_%TO CURRENT SECTOR NUMBER_^1LD2_"JMP* (LD1)_^1_%SPC 2_^1*_]_^1******************************************************_^1* 'IOPR' ENTRY_F*_^1******************************************************_^1*_]_^1IOPR_!NOP 0_^1_%LDA* IOPR_^1_%INA -1_^1_%STA LINK_^1_%RTJ DYNDSK_#DYNAMICALLY ALLOCATE DISC._^1_%LDA ISCRI_$SET 'SCR€€ATCH SWITCH' TO_^1_%INA -9_*'SCRATCH INPUT' FILE._^1_%STA SCRSW_^1_%RTJ LOADR1_#START LOADING RBUF1 AND RBUF2._^1_%INA PGSIZS*2_^1_%STA CSN1,Q_^1_%SUB SECT_^1_%SAM 2_^1_%JMP ABORT_^1_%ENA 0_)CLEAR READ AND WRITE POINTERS._^1_%STA RPT_^1_%STA WPT_^1I5_#LDA RB1AV_$WAIT TILL RBUF1 IS AVAILABLE._^1_%SAZ 1_^1_%JMP* I5_^1_%JMP REQDON_#RETURN TO 'GO' ROUTINE._^1_%SPC 2_^1* €€WBUF1 - OUTPUT BUFFER, OVERLAYING 'IOPR'._^1_%SPC 1_^1_%ORG IOPR_^1_%BSS WBUF1(PGSIZW)_^1SCRLUF NUM 0_,SCRATCH/LIBRARY DIFFERENT FLAG_'PSR 1180_^1_%SPC 2_^1DYNDSK NOP 0_^1_%LDA- $B3_*ARE SCRATCH_:PSR 1180_^1_%SUB- $C2_*AND LIBRARY UNITS DIFFERENT_*PSR 1180_^1_%STA* SCRLUF_'SCRLUF EQ 0 SAME, SCRLUF NE 0 DIFFER PSR 1180_^1_%LDA MAXSEC_'LARGEST SCRATCH SECTOR_.77*1879_^1_%LDQ*€€ SCRLUF_'IF UNITS ARE DIFFERENT_/PSR 1180_^1_%SQN STASEC_'SET SECT TO MAXSEC_3PSR 1180_^1_%SUB- $C1_'SUBTRACT S.N. OF SCRATCH AREA._^1*_81 CARD REMOVED FOR PSR 90*2673_(90*2190_^1STASEC STA SECT_)SAVE TOTAL SCRATCH SIZE_.PSR 1180_^1_%LDA- $E4_'ADDRESS OF LOAD/GO AREA PLUS 1_^1_%ADD =N162_(1 CYLINDER + 2 SECTORS_^1_%STA SN_^1_%SQN ROUND_(SKIP COMPUTATION OF SCRATCH SIZE_$PSR 11€€80_^1_%ADD- $C1_'ROUND OVERLAY LOCATION UP TO_^1*_8START OF A CYLINDER, TO (PSR 90*2673) 90*2190_^1ROUND INA -2_P81*2970**_^1_%TRA Q_+MINIMIZE NUMBER OF SEEKS BY_^1_%LRS 16_*ASSURING THAT ALL OVERLAY_^1_%DVI =N160_'PAGES FALL WITHIN A CYLINDER._^1_%SQN 3_-***PSR 68 * 1503 BEGIN ***_^1_%LDA SN_,***PSR 68 * 1503 END_!***_^1_%JMP* LEAVE_^1_%TCQ A_^1_%ADD =N160_^1_%ADD SN_^1€€LEAVE ADD =N318_(NO LOCALS IN PHASE B_284*2541_^1_%STA SN_+SYMTAB AT CYL 3 SEC 000_/84*2541_^1_%ADD =N480_(ONE CYL FOR REF. FILE, 1 FOR MACROS_"FTN 3.3_^1_%STA CSN1_)SCRATCH AT CYL 6 SEC 000_.84*2541_^1_%INA PGSIZS_'INTERLEAVE SCRATCH PAGES_.84*2541_^1_%STA CSN2_)SCRATCH 2 AT CYL 6 SEC 006_,84*2541_^1_%JMP* (DYNDSK)_!RETURN TO 'IOPR'._^1_%SPC 2_^1* RBUF1 - READ BUFFER, OVER€HLAYING 'DYNDSK'._^1_%SPC 1_^1_%ORG DYNDSK_^1_%BSS RBUF1(PGSIZW)_^1_%SPC 2_^1ABORT FWRITE $FC,,SO,1,A,0,1,I,,1_:**FTN 3.0**_^1*_]_^1******************************************************_^1* 'EXIT' ENTRY_F*_^1******************************************************_^1*_]_^1EXIT_!NOP 0_^1_%EXIT_^1SO_#ALF 1,SO_^1_%END_]_^__ HPWGOC CSY/ 28F P€1_%NAM GOC_*DECK-ID 28F FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^1_%SPC 3_^1*_$PROGRAM BASE .._^1* THIS IS THE 2.0B VERSION_^1* DIFFERENT RETURN TO 'FTN' IF A,M OPTION ON._^1* PHASE C ASSEMBLY ROUTINES_^1* GOC IS USED IN PHASE C_^1_%ENT GOC_^1_%€€EXT PHASEC,IOPR,WRITE_^1_%DAT IFLAGS_NFTN 3.3_^1_%DAT LINECT_NFTN 3.3_^1_%DAT LINCT1_NFTN 3.3_^1_%DAT IR_RFTN 3.3_^1_%DAT IK_RFTN 3.3_^1_%DAT IP_RFTN 3.3_^1_%DAT IA_RFTN 3.3_^1_%DAT IL_RFTN 3.3_^1_%DAT IM_RFTN 3.3_^1_%DAT IXLGO_OFTN 3.3_^1_%DAT IOPTO_OFTN 3.3_^1_%DAT IOPTV_OFTN 3.3_^1_%DAT IOPTC_OFTN 3.3_^1_%DAT IOPTD_OFTN 3.3_^1_%DAT MCSTRT_NFTN 3.3_^1_%DAT MACRNB€€_NFTN 3.3_^1_%DAT MACSEC_NFTN 3.3_^1_%DAT IERRS(16)_KFTN 3.3_^1_%DAT ISRFAD_NFTN 3.3_^1_%DAT LGO_QFTN 3.3_^1_%DAT ISCRI_OFTN 3.3_^1_%DAT ISCRO_OFTN 3.3_^1_%DAT IX_RFTN 3.3_^1_%DAT B(3017-38)_JFTN 3.3_^1_%COM D($047C)_^1GOC_"NOP 0_^1_%LDQ* (INAD)_#SCRATCH IN (ISCRI)_^1_%LDA* (OUTAD)_"SCRATCH OUT (ISCRO)_^1_%STA* (INAD)_#OUT BECOMES IN_^1_%STQ* (OUTAD)_"IN BECOMES OUT_^1_%R€€TJ+ IOPR_%INITIALIZE IOPR_^1_%RTJ+ PHASEC_#EXECUTE PHASE C_^1_%LDA+ B+1_PPSR 718_^1_%SUB =N$7FFF_LPSR 718_^1_%SAN 1_RPSR 718_^1_%JMP* INAD+2_MPSR 718_^1_%LDA+ IA_^1_%SAN PHE_^1_%LDA+ IM_^1_%SAZ RETURN_^1PHE_"RAO* GOC_^1RETURN RAO* GOC_'NORMAL RETURN TO 'FTN'_^1_%RTJ+ WRITE_$OUTPUT LAST WRITE BUFFER_^1OUTAD ADC ISCRO,XFFFE_^1INAD_!ADC ISCRI,0_^1_%JMP* (GOC)_^1_%EQU XFFFE($13€)_^1_%END_]_^__ PWIOPRC CSY/ 29F P€1_%NAM IOPRBC_'DECK-ID 29F FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^1_%SPC 3_^1*_$PROGRAM BASE .._^1* THIS IS THE 2.0B VERSION._^1* SCRATCH 'PAGE' SIZE NOW 6 SECTORS - PHASE C USES 18-SECTOR BUFFER._^1* DIFFERENT DISC ALLOCATION._^1* IOPRBC IS USE€€D IN PHASE C_^1*_]_^1* FORTRAN I/O PROCESSOR - VERSION 2.0B, BUFFERED_^1*_!THIS SUB-VERSION IS FOR PHASE C ONLY._^1*_!INCLUDES OPTIMUM ALLOCATION_^1*_+OVERLAY ALLOCATION_^1* THE FOLLOWING REQUESTS ARE PROCESSED..._^1* CALL IOPR_,INITIALIZATION_^1* CALL READ (U,M,L,A)_!INPUT_^1* CALL WRITE (U,M,L,A) OUTPUT_^1* CALL EXIT_,RETURN TO O.S._^1* WHERE..._]_^1*_!U IS ADR OF LOGICAL UN€€IT NR_^1*_!M IS ADR OF MODE (IF U .LT. 11)_^1*_'ADR OF RECORD NR (IF U .GE. 11)_^1*_!L IS ADR OF LENGTH (IGNORED IF U = 9 OR 10)_^1*_!A IS ADR OF USER'S AREA_^1* LOGICAL UNIT NUMBERS FOR 'IOPR'..._^1*_"1 IS STANDARD INPUT DEVICE_^1*_"2 IS STANDARD BINARY OUTPUT DEVICE_^1*_"3 IS STANDARD LIST DEVICE_^1*_"4 IS STANDARD COMMENT DEVICE_^1*_"9 IS DISC SCRATCH FILE 1_^1*_!10 IS DISC SCRA€€TCH FILE 2_^1*_!11 IS SYMBOL TABLE_^1*_!12 IS LOAD-AND-GO FILE_^1*_]_^1_%ENT IOPR,READ,WRITE,EXIT_^1_%EXT MAXSEC_L77*1879_^1_%EXT PAGCHK_NFTN 3.3_^1_%DAT IFLAGS_NFTN 3.3_^1_%DAT LINECT_NFTN 3.3_^1_%DAT LINCT1_NFTN 3.3_^1_%DAT A(32)_OFTN 3.3_^1_%DAT ISCRI_OFTN 3.3_^1*_]_^1******************************************************_^1* 'READ' AND 'WRITE' ENTRIES_8*_^1*************€€*****************************************_^1*_]_^1READ_!NOP 0_^1_%STQ* QSAV_^1_%LDA =N$08FD_"INPUT COMMENT DEVICE CODE_^1_%STA* DC+3_^1_%LDA =N$4801_%'FREAD' REQUEST CODE_.**FTN 3.0**_^1_%LDQ* READ_%GET LINK._^1_%JMP* IOPROC_^1_%SPC 2_^1WRITE NOP 0_^1_%STQ* QSAV_^1_%LDA =N$08FC_"OUTPUT COMMENT DEVICE CODE_^1_%STA* DC+3_^1_%LDA =N$4C01_%'FWRITE' REQUEST CODE_-**FTN 3.0**_^1_€€%LDQ* WRITE_$GET LINK._^1_%SPC 2_^1IOPROC STQ* LINK_%SAVE LINK._^1_%STA* REQ+1_$SET REQUEST TYPE._^1_%LDA- I_)SAVE $FF._^1_%STA* ISAV_^1_%LDQ* (LINK)_#GET LOGICAL UNIT NUMBER._^1_%RAO* LINK_^1_%STQ* REQ+4_^1_%LDQ* (REQ+4)_^1_%STQ- I_)SAVE._^1_%LDA* (LINK)_#GET SECTOR ADDRESS OR MODE._^1_%RAO* LINK_^1_%STA* RECAD_^1_%LDA* (LINK)_#GET RECORD LENGTH._^1_%RAO* LINK_^1_%STA* REQ+5_^1_%€€LDA* (REQ+5)_^1_%STA* REQ+5_^1_%LDA* (LINK)_#GET USER'S AREA ADDRESS._^1_%STA* REQ+6_^1_%INQ -9_(TEST L.U. NR FOR MASS STORAGE._^1_%SQM 1_^1_%JMP* MS_^1_%LDQ* (RECAD)_"GET MODE AND DEVICE CODE,_^1_%LDA* DC-1,I_%COMBINE AND STORE._^1_%ALS 4_^1_%LRS 4_^1_%STA* REQ+4_^1_%LDA =N$1802_"IF NOT M.S. REQ, SET 1ST WORD_^1_%STA* REQ+7_'AFTER PARAMS TO 'JMP *+2'._^1_%JMP* REQ0_PFTN 3.3_^€€1_%SPC 2_^1MS_#INQ -2_(M.S. CALL- TEST FOR SCRATCH._^1_%SQP DIRECT_^1_%JMP* SCRTCH_^1DIRECT LDA =N$08B3_"NO- SYMTAB, LGO, OR OV. UNIT =_^1_%STA* REQ+4_'SCRATCH DISC, MORE SIGNIF._^1_%ENA 0_+PART OF SECTOR NR =0,_^1_%STA* REQ+7_'STARTING SECTOR NR = BASE_^1_%LDA* SN,Q_(FOR THAT FILE_^1MS1_"ADD* (RECAD)_$+ RECORD NUMBER_^1_%STA* REQ+8_^1REQ0_!LDA* UNIT_)PICK UP LU OF OUTPUT UNI€€T_-FTN 3.3_^1_%AND- X0FFF_OFTN 3.3_^1_%EOR* DC+2_)CHECK FOR AND SKIP IF NOT STD LIST_#FTN 3.3_^1_%SAN REQ_QFTN 3.3_^1_%RTJ PAGCHK_'BUMP LINE CTR AND CHK FOR END OF PAGE FTN 3.3_^1_%SPC 2_^1REQ_"RTJ- ($F4)_$I/O REQUEST..._^1_%NUM 0_+REQUEST CODE_^1_%ADC 0_+COMPLETION ADDRESS_^1THREAD ADC 0_+REQUEST THREAD_^1UNIT_!NUM 0_+LOGICAL UNIT NR_^1_%NUM 0_+LENGTH_^1_%ADC 0_+STARTING€€ ADDRESS_^1_%NUM 0_+MSP OF SECTOR NR, OR JMP *+2_^1_%NUM 0_+LSP OF SECTOR NR_^1_%LDA* THREAD_#HANG ON THREAD TILL I/O DONE._^1_%SAZ 1_^1_%JMP* *-2_^1_%SPC 2_^1*_85 CARDS DELETED_7FTN 3.3_^1REQDON RAO* LINK_%RESTORE REGISTERS_^1_%LDQ* QSAV_(AND RETURN._^1_%LDA* ISAV_^1_%STA- I_^1_%JMP* (LINK)_^1_%SPC 1_^1* LINK_!- ADDRESS OF PARAMETERS, RETURN ADDRESS._^1* QSAV_!- (Q) AT CALL._€€^1* ISAV_!- (I) AT CALL._^1* RECAD - ADDRESS OF MODE OR RECORD NUMBER, IN CALL._^1* SN_#- RELATIVE SECTOR NR OF SYMBOL TABLE._^1* +1_"- RELATIVE SECTOR NR OF LOAD-GO FILE, -1._^1* DC_#- 'UNIT NR' VALUES FOR STANDARD I/O UNITS._^1_%SPC 1_^1_%BSS LINK,QSAV,ISAV,RECAD_^1_%BZS SN(2)_^1DC_#NUM $08F9,$08FA,$08FB,0_^1_%SPC 1_^1_%EQU X0FFF($0E)_^1*_820 CARDS DELETED_6FTN 3.3_^1_%EJ€€T_]_^1*_]_^1******************************************************_^1* SCRATCH FILE PROCESSING_;*_^1******************************************************_^1*_]_^1SCRTCH INQ 2_)SCRATCH I/O CALL. SAVE FILE_^1_%STQ* SCRSW_'NUMBER._^1_%LDA* REQ+1_$SET FLAG FROM REQUEST CODE..._^1_%ALS 5_++ FOR READ, - FOR WRITE._^1_%STA* SFLG_^1_%SAP 1_)JUMP IF WRITE._^1_%JMP* SWRITE_^1SREAD LDA*€€ REQ+6_$GET USER'S AREA ADDRESS._^1_%STA* SA_^1_%LDQ* RPT_'READ POINTER (TO CURRENT BFR)_^1S1_#LDA+ RBUF1,Q_"GET RECORD LENGTH (FROM FIRST_^1_%INA -1_*WORD OF RECORD) AND PUT IN_^1_%STA* NWR_)WORD COUNTER._^1_%LDA* WPPM1_$COMPUTE REMAINING WORDS IN THIS_^1_%SUB* RPT_)READ BUFFER AND SET INDEX._^1S2_#STQ- I_^1_%STA* REM_'SAVE NR OF WORDS REMAINING IN_^1_%TRA Q_+BUFFER AND COMPARE €€TO REMAIN-_^1_%SUB* NWR_)DER OF WORDS IN RECORD._^1_%SAM 1_)RECORD OVERLAPS PAGES_^1_%LDQ* NWR_'RECORD DOES NOT OVERLAP_^1S3_#LDA* SFLG_^1_%SAP 1_^1_%JMP* W2_(JUMP IF WRITING._^1_%LDA* (S1+1),B_!MOVE WORD FROM READ_^1_%STA* (SA),Q_%BUFFER TO USER'S AREA._^1_%RAO* RPT_'BUMP READ POINTER_^1S4_#INQ -1_*AND DECREMENT COUNT._^1_%SQM 1_)IS COUNT EXHAUSTED_^1_%JMP* S3_*NO._^1_%LDA* WD€€SPPG_^1_%LDQ* SFLG_^1_%SQM W3_(SKIP IF WRITING._^1_%SUB* RPT_'IS READ BUFFER EMPTY_^1S5_#SAZ S6_*YES, CONTINUE FROM OTHER._^1_%JMP* REQDON_%NO, RETURN._^1W3_#SUB* WPT_'IS WRITE BUFFER EMPTY_^1_%SAZ S8_^1_%JMP* REQDON_%NO, RETURN._^1S8_#JMP* W4_*YES, CONTINUE TO OTHER._^1S6_#RTJ* LOADR1_#INITIATE LOADING OF JUST-EMPTY_^1S10_"LDQ* RB1AV_'BUFFER. WAIT TILL AVAILABLE._^1S11_"SQZ 1€€_^1_%JMP* S10_^1_%ENA 0_)CLEAR READ POINTER._^1_%STA* RPT_^1MSCA_!RAO* REM_'INCREMENT STARTING ADDRESS BY_^1_%LDA* SA_*NUMBER OF WORDS PROCESSED SO_^1_%ADD* REM_)FAR._^1_%STA* SA_^1S14_"LDA* NWR_'DECREMENT NR OF WDS REMAINING_^1_%SUB* REM_)BY NR OF WDS PROCESSED_^1_%STA* NWR_)SO FAR._^1_%INA 1_)TRANSFER COMPLETE IF NWR = REM._^1_%SAN 1_^1_%JMP* REQDON_^1_%LDA* WPPM1_$ELSE LOAD R€€EMAINDER AND POINTER_^1_%ENQ 0_+AND CONTINUE._^1_%JMP* S2_^1_%SPC 2_^1* SCRSW - SCRATCH FILE SWITCH- 0 FOR FILE 1, 1 FOR 2._^1* SFLG_!- TYPE OF CALL- + FOR READ, - FOR WRITE._^1* SA_#- START ADR FOR SCRATCH XFR_^1* RPT_"- READ POINTER, TO CURRENT BUFFER_^1* NWR_"- NR OF WDS YET TO BE MOVED, THIS CALL._^1* SECT_!- TOTAL NR OF SCRATCH SECTORS NOW ON DISC._^1* PGSIZS - SCRATCH 'PAG€€E' SIZE IN SECTORS._^1* PGSIZW - SCRATCH 'PAGE' SIZE IN WORDS._^1* NOTE- THIS VERSION HAS BEEN MODIFIED TO USE SIX-_^1* SECTOR SCRATCH PAGES WITH AN 18-SECTOR PACK AREA._^1* REM_"- NR OF WORDS MOVED SO FAR, THIS CALL._^1* CSN1_!- CURRENT SECTOR NUMBER FOR FILE 1._^1* CSN2_!- CURRENT SECTOR NUMBER FOR FILE 2._^1_%SPC 1_^1_%BSS SCRSW,SFLG,SA,RPT,NWR,SECT_^1_%EQU PGSIZS(18),PGSIZW(€€PGSIZS*96)_^1WDSPPG ADC PGSIZW_^1WPPM1 ADC PGSIZW-1_^1_%BSS REM,CSN1,CSN2_^1_%SPC 2_^1SWRITE LDA* (RECAD)_"TEST FOR 'M' .LT. 0...THIS_^1_%SAP W1_*REQUESTS EMPTYING OUTPUT BFR._^1_%RTJ* DUMPW1_^1F2_#LDA* WB1AV_'WAIT TILL BUFFER AVAILABLE,_^1_%SAZ 1_^1_%JMP* F2_^1_%JMP* REQDON_%THEN RETURN._^1W1_#LDA REQ+6_$GET USER'S AREA ADDRESS._^1_%STA* SA_^1_%LDQ* WPT_'WRITE POINTER_^1_%€€LDA* (SA)_%GET RECORD LENGTH (FROM 1ST_^1_%INA -1_*WORD OF RECORD) AND PUT IN_^1_%STA* NWR_)WORD COUNTER._^1_%LDA* WPPM1_$COMPUTE REMAINING WORDS IN_^1_%SUB* WPT_)WRITE BUFFER._^1_%JMP* S2_^1W2_#LDA* (SA),Q_#MOVE WORD FROM USER'S AREA_^1_%STA* WBUF1,B_$TO CURRENT BUFFER._^1_%RAO* WPT_'BUMP WRITE POINTER..._^1_%JMP* S4_^1W4_#RTJ* DUMPW1_#INITIATE DUMPING OF_^1W6_#LDQ* WB1AV_'OUTPUT€€ BUFFER AND WAIT_^1W7_#SQZ 1_+TILL AVAILABLE._^1_%JMP* W6_^1_%ENA 0_)CLEAR WRITE POINTER._^1_%STA* WPT_^1_%JMP* MSCA_%PROCEED._^1_%SPC 2_^1* WPT_"- WRITE POINTER, TO CURRENT BUFFER._^1_%SPC 1_^1_%BSS WPT_^1_%SPC 2_^1*_]_^1******************************************************_^1* MASS STORAGE BUFFER IN/OUT ROUTINES_/*_^1******************************************************_^€€1*_]_^1LOADR1 NOP_]_^1_%ENA 2_)SET 3-COUNTER_^1_%STA- I_+(3 PAGES / PACK AREA)_^1_%RTJ* LD1_'SET SCRATCH_^1_%STA* L5_*INDEX (EITHER FILE)_^1L1_#RTJ- ($F4)_K**FTN 3.0**_^1_%NUM $2000_K**FTN 3.0**_^1_%ADC LRQ_M**FTN 3.0**_^1_%LDA* L5_(BUMP REQUEST_^1_%INA 2*PGSIZS/3_!SECTOR NR_^1_%STA* L5_^1_%STA* CSN1,Q_^1_%SUB* SECT_%CHECK FOR OVERFLOW_^1_%SAM L2_^1_%JMP ABORT_^1L2_#LDA- I_)B€€UMP 3-COUNTER_^1_%INA -1_*AND_^1_%SAM L3_*SKIP IF DONE_^1_%STA- I_+ELSE SAVE IT_^1_%LDA* L4_(BUMP_^1_%ADD* WPPO3_'REQUEST_^1_%STA* L4_*CORE ADDR_^1_%JMP* L1_(READ NEXT PAGE_^1L3_#LDA =XRBUF1_"DONE, RESTORE_^1_%STA* L4_*PACK-AREA ADDR_^1_%JMP* (LOADR1)_#AND RETURN_^1LRQ_"NUM $4801_(LOAD REQUEST...PARAMETER LIST_$**FTN 3.0**_^1_%ADC 0_+OF AN 'FREAD' REQUEST_^1RB1AV ADC 0_^1_%N€€UM $08B3_^1WPPO3 ADC PGSIZW/3_^1L4_#ADC RBUF1_^1_%NUM 0_^1_%BSS L5_^1_%SPC 1_^1DUMPW1 NOP_]_^1_%ENA 2_^1_%STA- I_^1_%RTJ* LD1_^1_%STA* D5_^1D1_#RTJ- ($F4)_K**FTN 3.0**_^1_%NUM $2000_K**FTN 3.0**_^1_%ADC DRQ_M**FTN 3.0**_^1_%LDA* D5_^1_%INA 2*PGSIZS/3_^1_%STA* D5_^1_%STA* CSN1,Q_^1_%SUB* SECT_^1_%SAM D2_^1_%JMP ABORT_^1D2_#LDA- I_^1_%INA -1_^1_%SAM D3_^1_%STA- I_^1_%L€€DA* D4_^1_%ADD* WPPO3_^1_%STA* D4_^1_%JMP* D1_^1D3_#LDA =XWBUF1_^1_%STA* D4_^1_%JMP* (DUMPW1)_^1DRQ_"NUM $4C01_(DUMP REQUEST...PARAMETER LIST_$**FTN 3.0**_^1_%ADC 0_+OF AN 'FWRITE' REQUEST_^1WB1AV ADC 0_^1_%NUM $08B3_^1_%ADC PGSIZW/3_^1D4_#ADC WBUF1_^1_%NUM 0_^1_%BSS D5_^1_%SPC 1_^1LD1_"NOP 0_^1_%LDQ* SCRSW_$SET SECTOR NUMBER OF REQUEST_^1_%LDA* CSN1,Q_%TO CURRENT SECTO€€R NUMBER_^1LD2_"JMP* (LD1)_^1_%SPC 2_^1*_]_^1******************************************************_^1* 'IOPR' ENTRY_F*_^1******************************************************_^1*_]_^1IOPR_!NOP 0_^1_%LDA* IOPR_^1_%INA -1_^1_%STA LINK_^1_%RTJ DYNDSK_#DYNAMICALLY ALLOCATE DISC._^1_%LDA ISCRI_$SET 'SCRATCH SWITCH' TO_^1_%INA -9_*'SCRATCH INPUT' FILE._^1_%STA SCRSW_^1_%RTJ LO€€ADR1_#START LOADING RBUF1 AND RBUF2._^1_%ENA 0_)CLEAR READ AND WRITE POINTERS._^1_%STA RPT_^1_%STA WPT_^1I5_#LDA RB1AV_$WAIT TILL RBUF1 IS AVAILABLE._^1_%SAZ 1_^1_%JMP* I5_^1_%JMP REQDON_#RETURN TO 'GO' ROUTINE._^1_%SPC 2_^1* WBUF1 - OUTPUT BUFFER, OVERLAYING 'IOPR'._^1_%SPC 1_^1_%ORG IOPR_^1_%BSS WBUF1(PGSIZW)_^1SCRLUF NUM 0_,SCRATCH/LIBRARY DIFFERENT FLAG_'PSR 1180_^1_€€%SPC 2_^1DYNDSK NOP 0_^1_%LDA- $B3_*ARE SCRATCH_:PSR 1180_^1_%SUB- $C2_*AND LIBRARY UNITS DIFFERENT_*PSR 1180_^1_%STA* SCRLUF_'SCRLUF EQ 0 SAME, SCRLUF NE 0 DIFFER PSR 1180_^1_%LDA MAXSEC_'LARGEST SCRATCH SECTOR_.77*1879_^1_%LDQ* SCRLUF_'IF UNITS ARE DIFFERENT_/PSR 1180_^1_%SQN STASEC_'SET SECT TO MAXSEC_3PSR 1180_^1_%SUB- $C1_'SUBTRACT S.N. OF SCRATCH AREA._^1*_81 CARD REMOVE€€D FOR PSR 90*2673_(90*2190_^1STASEC STA SECT_)SAVE TOTAL SCRATCH SIZE_.PSR 1180_^1_%LDA- $E4_'ADDRESS OF LOAD/GO AREA PLUS 1_^1_%ADD =N162_(1 CYLINDER + 2 SECTORS_^1_%STA SN_^1_%SQN ROUND_(SKIP COMPUTATION OF SCRATCH SIZE_$PSR 1180_^1_%ADD- $C1_'ROUND OVERLAY LOCATION UP TO_^1*_8START OF A CYLINDER, TO (PSR 90*2673) 90*2190_^1ROUND INA -2_P81*2970**_^1_%TRA Q_+MINIMIZE NUMB€€ER OF SEEKS BY_^1_%LRS 16_*ASSURING THAT ALL OVERLAY_^1_%DVI =N160_'PAGES FALL WITHIN A CYLINDER._^1_%SQN 3_-***PSR 68 * 1503 BEGIN ***_^1_%LDA SN_,***PSR 68 * 1503 END_!***_^1_%JMP* LEAVE_^1_%TCQ A_^1_%ADD =N160_^1_%ADD SN_^1LEAVE ADD =N318_(NO LOCALS IN PHASE C_284*2541_^1_%STA SN_+SYMTAB AT CYL 3 SEC 000_/84*2541_^1_%ADD =N480_(ONE CYL FOR REF FILE, ONE FOR MACROS_!FT€€N 3.3_^1_%STA CSN1_)SCRATCH 1 AT CYL 6 SEC 000_,FTN 3.3_^1_%INA PGSIZS/3_$INTERLEAVE 1/3 - SIZE SCRATCH PAGES_"84*2541_^1_%STA CSN2_)SCRATCH 2 AT CYL 6 SEC 006_,FTN 3.3_^1_%JMP* (DYNDSK)_!RETURN TO 'IOPR'._^1_%SPC 2_^1* RBUF1 - READ BUFFER, OVERLAYING 'DYNDSK'._^1_%SPC 1_^1_%ORG DYNDSK_^1_%BSS RBUF1(PGSIZW)_^1_%SPC 2_^1ABORT FWRITE $FC,,SO,1,A,0,1,I,,1_:**FTN 3.0**_^1*_]_^€À1******************************************************_^1* 'EXIT' ENTRY_F*_^1******************************************************_^1*_]_^1EXIT_!NOP 0_^1_%EXIT_^1SO_#ALF 1,SO_^1_%END_]_^__ÀPWGOOD CSY/ 30F P€1_%NAM GOOD_)DECK-ID 30F FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^1_%SPC 3_^1*_$PROGRAM BASE .._^1* THIS IS THE 2.0B VERSION._^1* CALL TO 'LOCLIZ' DELETED. SIZE OF LABELLED COMMON INCREASED AND_^1* SIZE OF BLANK COMMON DECREASED._^1* PHASE D ASS€€EMBLY ROUTINES_^1* GOOD IS USED IN PHASE D_^1_%ENT GOD_^1_%EXT PHASE6,IOPR_^1_%DAT IFLAGS_NFTN 3.3_^1_%DAT LINECT_NFTN 3.3_^1_%DAT LINCT1_NFTN 3.3_^1_%DAT IR_RFTN 3.3_^1_%DAT IK_RFTN 3.3_^1_%DAT IP_RFTN 3.3_^1_%DAT IA_RFTN 3.3_^1_%DAT IL_RFTN 3.3_^1_%DAT IM_RFTN 3.3_^1_%DAT IXLGO_OFTN 3.3_^1_%DAT IOPTO_OFTN 3.3_^1_%DAT IOPTV_OFTN 3.3_^1_%DAT IOPTC_OFTN 3.3_^1_%DAT I€€OPTD_OFTN 3.3_^1_%DAT MCSTRT_NFTN 3.3_^1_%DAT MACRNB_NFTN 3.3_^1_%DAT MACSEC_NFTN 3.3_^1_%DAT IERRS(16)_KFTN 3.3_^1_%DAT ISRFAD_NFTN 3.3_^1_%DAT LGO_QFTN 3.3_^1_%DAT ISCRI_OFTN 3.3_^1_%DAT ISCRO_OFTN 3.3_^1_%DAT IX_RFTN 3.3_^1_%DAT B(3017-38)_JFTN 3.3_^1_%COM D($082A)_^1GOD_"NOP 0_^1_%LDQ* (INAD)_#SCRATCH IN (ISCRI)_^1_%LDA* (OUTAD)_"SCRATCH OUT (ISCRO)_^1_%STA* (INAD)_€€#OUT BECOMES IN_^1_%STQ* (OUTAD)_"IN BECOMES OUT_^1_%RTJ+ IOPR_%INITIALIZE IOPR_^1_%RTJ+ PHASE6_^1_%LDA+ LGO_'RESTORE LOAD AND GO SECT NR_^1_%STA- $E4_^1_%RTJ- ($F4)_$CHECK FOR MAG TAPE LIST_^1_%NUM $4600,$8FB,0_D**FTN 3.0**_^1_%TRQ A_^1_%AND =N$3800_LPSR 744_^1_%EOR =N$0800_LPSR 744_^1_%SAN NOTPE_^1MT_#RTJ- ($F4)_$END OF FILE ON LIST TAPE_^1_%NUM $5C00,0,0,$8FB,$2100_!EOF AN€ND BACKSPACE_(**FTN 3.0**_^1_%LDA* MT+3_^1_%SAZ 1_^1_%JMP* *-2_^1NOTPE LDA+ IOPTC_(CHECK FOR CROSS REFERENCE REQUEST_$FTN 3.3_^1_%SAZ EXIT_)SKIP IF NONE TO EXIT_2FTN 3.3_^1_%RAO* GOD_*RETURN +3 FOR FORTF1_2FTN 3.3_^1_%RAO* GOD_QFTN 3.3_^1EXIT_!JMP* (GOD)_(RETURN TO FTN_9FTN 3.3_^1INAD_!ADC ISCRI_^1OUTAD ADC ISCRO_^1_%END_]_^__ NPWIOPRD CSY/ 31F P€1_%NAM IOPRBD_'DECK-ID 31F FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^1_%SPC 3_^1*_$PROGRAM BASE .._^1* THIS IS THE 2.0B VERSION._^1* NO LOCALS IN 2.0B. SCRATCH 'PAGE' SIZE NOW 6 SECTORS. DIFFERENT_^1* DISC ALLOCATION._^1* IOPRB0 IS USED IN PHASES€€ D,E_^1* IOPRBD USED IN PHASE E_^1*_]_^1* FORTRAN I/O PROCESSOR - VERSION 2.0B, BUFFERED_^1*_!THIS SUB-VERSION IS FOR PHASE D ONLY._^1*_!INCLUDES 'RESET' FUNCTION_9IOPRB6_^1*_+OPTIMUM ALLOCATION_^1*_+OVERLAY ALLOCATION_^1* THE FOLLOWING REQUESTS ARE PROCESSED..._^1* CALL IOPR_,INITIALIZATION_^1* CALL READ (U,M,L,A)_!INPUT_^1* CALL WRITE (U,M,L,A) OUTPUT_^1* CALL RESET (U,V)_$€€LOGICAL REWIND OF SCRATCH_^1* CALL EXIT_,RETURN TO O.S._^1* WHERE..._]_^1*_!U IS ADR OF LOGICAL UNIT NR_^1*_!M IS ADR OF MODE (IF U .LT. 11)_^1*_'ADR OF RECORD NR (IF U .GE. 11)_^1*_!L IS ADR OF LENGTH (IGNORED IF U = 9 OR 10)_^1*_!A IS ADR OF USER'S AREA_^1*_!V IS 1 IF RESETTING INPUT FILE FOR OUTPUT_)IOPRB6_^1*_'0 IF RESETTING OUTPUT FILE FOR INPUT_)IOPRB6_^1* LOGICAL UNIT NUMBE€€RS FOR 'IOPR'..._^1*_"1 IS STANDARD INPUT DEVICE_^1*_"2 IS STANDARD BINARY OUTPUT DEVICE_^1*_"3 IS STANDARD LIST DEVICE_^1*_"4 IS STANDARD COMMENT DEVICE_^1*_"9 IS DISC SCRATCH FILE 1_^1*_!10 IS DISC SCRATCH FILE 2_^1*_!11 IS SYMBOL TABLE_^1*_!12 IS LOAD-AND-GO FILE_^1*_]_^1_%ENT IOPR,READ,WRITE,RESET,EXIT_0IOPRB6_^1_%EXT PAGCHK_NFTN 3.3_^1_%EXT MAXSEC_L77*1879_^1_%DAT IFLAGS_N€€FTN 3.3_^1_%DAT LINECT_NFTN 3.3_^1_%DAT LINCT1_NFTN 3.3_^1_%DAT A(32)_OFTN 3.3_^1_%DAT ISCRI_OFTN 3.3_^1*_UIOPRB6_^1****************************************************** IOPRB6_^1* 'RESET' ENTRY_E* IOPRB6_^1****************************************************** IOPRB6_^1*_UIOPRB6_^1RESET NOP 0_IIOPRB6_^1_%STQ* QSAV_FIOPRB6_^1_%LDA- I_IIOPRB6_^1_%STA* ISAV_FIOPRB6_^1_%LDA* RE€€SET_EIOPRB6_^1_%STA* LINK_^1_%LDQ* (RESET)_"GET LOGICAL UNIT NUMBER._'IOPRB6_^1_%STQ* RESET_EIOPRB6_^1_%LDQ* (RESET)_CIOPRB6_^1_%INQ -9_(TEST FOR 9 OR 10._.IOPRB6_^1_%STQ SCRSW_EIOPRB6_^1_%LDA SN1,Q_$RESET FILE- RESTORE SECTOR_^1RS2_"STA+ CSN1,Q_%NUMBER TO ORIGIN OF FILE_$IOPRB6_^1_%RAO* LINK_FIOPRB6_^1_%LDA* (LINK)_%GET IN/OUT FLAG._-IOPRB6_^1_%STA* RESET_EIOPRB6_^1_%LDA* (RESE€€T)_CIOPRB6_^1_%SAZ RESETI_#TEST FOR IN/OUT CALL._*IOPRB6_^1RESETO ENA 0_)RESET EITHER FILE FOR OUTPUT-_^1_%STA WPT_)CLEAR WRITE POINTER._^1_%JMP* REQDON_DIOPRB6_^1RESETI RTJ LOADR1_#RESETTING FOR INPUT-_^1_%INA PGSIZS*2_#BEGIN LOADING BOTH BUFFERS._!IOPRB6_^1_%STA* (RS2+1),Q_AIOPRB6_^1RESETP ENA 0_)WHEN RESETTING EITHER FILE,_#IOPRB6_^1_%STA RPT_)RESET READ POINTER._^1_%LDA €€ RB1AV_$WAIT UNTIL RBUF1 HAS BEEN_%IOPRB6_^1_%SAZ 1_+FILLED, THEN RETURN._)IOPRB6_^1_%JMP* *-3_GIOPRB6_^1_%JMP* REQDON_DIOPRB6_^1_%SPC 2_IIOPRB6_^1*_]_^1******************************************************_^1* 'READ' AND 'WRITE' ENTRIES_8*_^1******************************************************_^1*_]_^1READ_!NOP 0_^1_%STQ* QSAV_^1_%LDA =N$08FD_"INPUT COMMENT DEVICE CODE_^1_%€€STA* DC+3_^1_%LDA =N$4801_%'FREAD' REQUEST CODE_.**FTN 3.0**_^1_%LDQ* READ_%GET LINK._^1_%JMP* IOPROC_^1_%SPC 2_^1WRITE NOP 0_^1_%STQ* QSAV_^1_%LDA =N$08FC_"OUTPUT COMMENT DEVICE CODE_^1_%STA* DC+3_^1_%LDA =N$4C01_%'FWRITE' REQUEST CODE_-**FTN 3.0**_^1_%LDQ* WRITE_$GET LINK._^1_%SPC 2_^1IOPROC STQ* LINK_%SAVE LINK._^1_%STA* REQ+1_$SET REQUEST TYPE._^1_%LDA- I_)SAVE $FF._^1_%€€STA* ISAV_^1_%LDQ* (LINK)_#GET LOGICAL UNIT NUMBER._^1_%RAO* LINK_^1_%STQ* REQ+4_^1_%LDQ* (REQ+4)_^1_%STQ- I_)SAVE._^1_%LDA* (LINK)_#GET SECTOR ADDRESS OR MODE._^1_%RAO* LINK_^1_%STA* RECAD_^1_%LDA* (LINK)_#GET RECORD LENGTH._^1_%RAO* LINK_^1_%STA* REQ+5_^1_%LDA* (REQ+5)_^1_%STA* REQ+5_^1_%LDA* (LINK)_#GET USER'S AREA ADDRESS._^1_%STA* REQ+6_^1_%INQ -9_(TEST L.U. NR FOR MASS STORA€€GE._^1_%SQM 1_^1_%JMP* MS_^1_%LDQ* (RECAD)_"GET MODE AND DEVICE CODE,_^1_%LDA* DC-1,I_%COMBINE AND STORE._^1_%ALS 4_^1_%LRS 4_^1_%STA* REQ+4_^1_%LDA =N$1802_"IF NOT M.S. REQ, SET 1ST WORD_^1_%STA* REQ+7_'AFTER PARAMS TO 'JMP *+2'._^1_%JMP* REQ0_PFTN 3.3_^1_%SPC 2_^1MS_#INQ -2_(M.S. CALL- TEST FOR SCRATCH._^1_%SQP DIRECT_^1_%JMP* SCRTCH_^1DIRECT LDA =N$08B3_"NO- SYMTAB, LGO,€€ OR OV. UNIT =_^1_%STA* REQ+4_'SCRATCH DISC, MORE SIGNIF._^1_%ENA 0_+PART OF SECTOR NR =0,_^1_%STA* REQ+7_'STARTING SECTOR NR = BASE_^1_%LDA* SN,Q_(FOR THAT FILE_^1MS1_"ADD* (RECAD)_$+ RECORD NUMBER_^1_%STA* REQ+8_^1_%SPC 2_^1REQ0_!LDA* UNIT_)PICK UP LU OF OUTPUT UNIT_-FTN 3.3_^1_%AND- X0FFF_OFTN 3.3_^1_%EOR* DC+2_)CHECK FOR AND SKIP IF NOT STD LIST_#FTN 3.3_^1_%SAN REQ_QFTN 3.€€3_^1_%RTJ PAGCHK_'BUMP LINE CTR AND CHK FOR END OF PAGE FTN 3.3_^1REQ_"RTJ- ($F4)_$I/O REQUEST..._^1_%NUM 0_+REQUEST CODE_^1_%ADC 0_+COMPLETION ADDRESS_^1THREAD ADC 0_+REQUEST THREAD_^1UNIT_!NUM 0_+LOGICAL UNIT NR_^1_%NUM 0_+LENGTH_^1_%ADC 0_+STARTING ADDRESS_^1_%NUM 0_+MSP OF SECTOR NR, OR JMP *+2_^1_%NUM 0_+LSP OF SECTOR NR_^1_%LDA* THREAD_#HANG ON THREAD TILL I/O DONE.€€_^1_%SAZ 1_^1_%JMP* *-2_^1_%SPC 2_^1*_85 CARDS DELETED_7FTN 3.3_^1REQDON RAO* LINK_%RESTORE REGISTERS_^1_%LDQ* QSAV_(AND RETURN._^1_%LDA* ISAV_^1_%STA- I_^1_%JMP* (LINK)_^1_%SPC 1_^1* LINK_!- ADDRESS OF PARAMETERS, RETURN ADDRESS._^1* QSAV_!- (Q) AT CALL._^1* ISAV_!- (I) AT CALL._^1* RECAD - ADDRESS OF MODE OR RECORD NUMBER, IN CALL._^1* SN_#- RELATIVE SECTOR NR OF SYMBOL TABLE€€._^1* +1_"- RELATIVE SECTOR NR OF LOAD-GO FILE, -1._^1* DC_#- 'UNIT NR' VALUES FOR STANDARD I/O UNITS._^1_%SPC 1_^1_%BSS LINK,QSAV,ISAV,RECAD_^1_%BZS SN(2)_^1DC_#NUM $08F9,$08FA,$08FB,0_^1_%EQU X0FFF($0E)_^1*_821 CARDS DELETED_6FTN 3.3_^1_%EJT_]_^1*_]_^1******************************************************_^1* SCRATCH FILE PROCESSING_;*_^1************************************€€******************_^1*_]_^1SCRTCH INQ 2_)SCRATCH I/O CALL. SAVE FILE_^1_%STQ* SCRSW_'NUMBER._^1_%LDA* REQ+1_$SET FLAG FROM REQUEST CODE..._^1_%ALS 5_++ FOR READ, - FOR WRITE._^1_%STA* SFLG_^1_%SAP 1_)JUMP IF WRITE._^1_%JMP* SWRITE_^1SREAD LDA* REQ+6_$GET USER'S AREA ADDRESS._^1_%STA* SA_^1_%LDQ* RPT_'READ POINTER (TO CURRENT BFR)_^1S1_#LDA+ RBUF1,Q_"GET RECORD LENGTH (FROM FIR€€ST_^1_%INA -1_*WORD OF RECORD) AND PUT IN_^1_%STA* NWR_)WORD COUNTER._^1_%LDA* WPPM1_$COMPUTE REMAINING WORDS IN THIS_^1_%SUB* RPT_)READ BUFFER AND SET INDEX._^1S2_#STQ- I_^1_%STA* REM_'SAVE NR OF WORDS REMAINING IN_^1_%TRA Q_+BUFFER AND COMPARE TO REMAIN-_^1_%SUB* NWR_)DER OF WORDS IN RECORD._^1_%SAM 1_)RECORD OVERLAPS PAGES_^1_%LDQ* NWR_'RECORD DOES NOT OVERLAP_^1S3_#LDA* SFLG€€_^1_%SAP 1_^1_%JMP* W2_(JUMP IF WRITING._^1_%LDA* (S1+1),B_!MOVE WORD FROM READ_^1_%STA* (SA),Q_%BUFFER TO USER'S AREA._^1_%RAO* RPT_'BUMP READ POINTER_^1S4_#INQ -1_*AND DECREMENT COUNT._^1_%SQM 1_)IS COUNT EXHAUSTED_^1_%JMP* S3_*NO._^1_%LDA* WDSPPG_^1_%LDQ* SFLG_^1_%SQM W3_(SKIP IF WRITING._^1_%SUB* RPT_'IS READ BUFFER EMPTY_^1S5_#SAZ S6_*YES, CONTINUE FROM OTHER._^1_%JMP* RE€€QDON_%NO, RETURN._^1W3_#SUB* WPT_'IS WRITE BUFFER EMPTY_^1_%SAZ S8_^1_%JMP* REQDON_%NO, RETURN._^1S8_#JMP* W4_*YES, CONTINUE TO OTHER._^1S6_#RTJ* LOADR1_#INITIATE LOADING OF JUST-EMPTY_^1S10_"LDQ* RB1AV_'BUFFER. WAIT TILL AVAILABLE._^1S11_"SQZ 1_^1_%JMP* S10_^1_%ENA 0_)CLEAR READ POINTER._^1_%STA* RPT_^1MSCA_!RAO* REM_'INCREMENT STARTING ADDRESS BY_^1_%LDA* SA_*NUMBER OF WORDS €€PROCESSED SO_^1_%ADD* REM_)FAR._^1_%STA* SA_^1_%LDQ* SCRSW_$STEP CURRENT SECTOR NUMBER OF_^1_%LDA* CSN1,Q_%SCRATCH FILE BEING USED, BY_^1_%INA PGSIZS*2_#TWICE THE SCRATCH PAGE SIZE._^1_%STA* CSN1,Q_^1S13_"SUB* SECT_%TEST FOR OVERFLOW OF SCRATCH._^1_%SAM S14_^1_%JMP ABORT_^1S14_"LDA* NWR_'DECREMENT NR OF WDS REMAINING_^1_%SUB* REM_)BY NR OF WDS PROCESSED_^1_%STA* NWR_)SO FAR._^1_€€%INA 1_)TRANSFER COMPLETE IF NWR = REM._^1_%SAN 1_^1_%JMP* REQDON_^1_%LDA* WPPM1_$ELSE LOAD REMAINDER AND POINTER_^1_%ENQ 0_+AND CONTINUE._^1_%JMP* S2_^1_%SPC 2_^1* SCRSW - SCRATCH FILE SWITCH- 0 FOR FILE 1, 1 FOR 2._^1* SFLG_!- TYPE OF CALL- + FOR READ, - FOR WRITE._^1* SA_#- START ADR FOR SCRATCH XFR_^1* RPT_"- READ POINTER, TO CURRENT BUFFER_^1* NWR_"- NR OF WDS YET TO BE M€€OVED, THIS CALL._^1* SECT_!- TOTAL NR OF SCRATCH SECTORS NOW ON DISC._^1* PGSIZS - SCRATCH 'PAGE' SIZE IN SECTORS._^1* PGSIZW - SCRATCH 'PAGE' SIZE IN WORDS._^1* REM_"- NR OF WORDS MOVED SO FAR, THIS CALL._^1* CSN1_!- CURRENT SECTOR NUMBER FOR FILE 1._^1* CSN2_!- CURRENT SECTOR NUMBER FOR FILE 2._^1_%SPC 1_^1_%BSS SCRSW,SFLG,SA,RPT,NWR,SECT_^1_%EQU PGSIZS(6),PGSIZW(PGSIZS*96)_^1€€WDSPPG ADC PGSIZW_^1WPPM1 ADC PGSIZW-1_^1_%BSS REM,CSN1,CSN2_^1_%SPC 2_^1SWRITE LDA* (RECAD)_"TEST FOR 'M' .LT. 0...THIS_^1_%SAP W1_*REQUESTS EMPTYING OUTPUT BFR._^1_%RTJ* DUMPW1_^1F2_#LDA* WB1AV_'WAIT TILL BUFFER AVAILABLE,_^1_%SAZ 1_^1_%JMP* F2_^1_%JMP* REQDON_%THEN RETURN._^1W1_#LDA REQ+6_$GET USER'S AREA ADDRESS._^1_%STA* SA_^1_%LDQ* WPT_'WRITE POINTER_^1_%LDA* (SA)_%GE€€T RECORD LENGTH (FROM 1ST_^1_%INA -1_*WORD OF RECORD) AND PUT IN_^1_%STA* NWR_)WORD COUNTER._^1_%LDA* WPPM1_$COMPUTE REMAINING WORDS IN_^1_%SUB* WPT_)WRITE BUFFER._^1_%JMP* S2_^1W2_#LDA* (SA),Q_#MOVE WORD FROM USER'S AREA_^1_%STA* WBUF1,B_$TO CURRENT BUFFER._^1_%RAO* WPT_'BUMP WRITE POINTER..._^1_%JMP* S4_^1W4_#RTJ* DUMPW1_#INITIATE DUMPING OF_^1W6_#LDQ* WB1AV_'OUTPUT BUFFER AND W€€AIT_^1W7_#SQZ 1_+TILL AVAILABLE._^1_%JMP* W6_^1_%ENA 0_)CLEAR WRITE POINTER._^1_%STA* WPT_^1_%JMP* MSCA_%PROCEED._^1_%SPC 2_^1* WPT_"- WRITE POINTER, TO CURRENT BUFFER._^1_%SPC 1_^1_%BSS WPT_^1_%SPC 2_^1*_]_^1******************************************************_^1* MASS STORAGE BUFFER IN/OUT ROUTINES_/*_^1******************************************************_^1*_]_^1LOADR1€€ NOP 0_^1_%RTJ* LD1_'GET CURRENT SECTOR NR_^1L1_#STA* L2_^1_%RTJ- ($F4)_$'FREAD' REQUEST..._^1_%NUM $4801_K**FTN 3.0**_^1_%ADC 0_^1RB1AV ADC 0_)THREAD = BUFFER-AVAILABLE FLAG_^1_%NUM $08B3_$UNIT= SCRATCH DISC_^1_%ADC PGSIZW_#LENGTH= WORDS PER SCRATCH PAGE_^1_%ADC RBUF1_$ADDRESS= READ BUFFER 1_^1_%NUM 0_^1_%BSS L2_(SECTOR- TO BE PLUGGED_^1_%JMP* (LOADR1)_!WHEN REQ THREADED€€, RETURN._^1_%SPC 1_^1DUMPW1 NOP 0_^1_%RTJ* LD1_^1D1_#STA* D2_^1_%RTJ- ($F4)_^1_%NUM $4C01_K**FTN 3.0**_^1_%ADC 0_^1WB1AV ADC 0_^1_%NUM $08B3_^1_%ADC PGSIZW_^1_%ADC WBUF1_^1_%NUM 0_^1_%BSS D2_^1_%JMP* (DUMPW1)_^1_%SPC 1_^1LD1_"NOP 0_^1_%LDQ* SCRSW_$SET SECTOR NUMBER OF REQUEST_^1_%LDA* CSN1,Q_%TO CURRENT SECTOR NUMBER_^1LD2_"JMP* (LD1)_^1_%SPC 2_^1*SN1 - INITIAL LOCAT€€ION OF SCRATCH FILE 1_^1_%BSS SN1(1)_^1*_]_^1******************************************************_^1* 'IOPR' ENTRY_F*_^1******************************************************_^1*_]_^1IOPR_!NOP 0_^1_%LDA* IOPR_^1_%INA -1_^1_%STA LINK_^1_%RTJ DYNDSK_#DYNAMICALLY ALLOCATE DISC._^1_%LDA ISCRI_$SET 'SCRATCH SWITCH' TO_^1_%INA -9_*'SCRATCH INPUT' FILE._^1_%STA SCRSW_^1_%RTJ LO€€ADR1_#START LOADING RBUF1 AND RBUF2._^1I1_#INA PGSIZS*2_^1_%STA CSN1,Q_^1_%ENA 0_)CLEAR READ AND WRITE POINTERS._^1_%STA RPT_^1_%STA WPT_^1I5_#LDA RB1AV_$WAIT TILL RBUF1 IS AVAILABLE._^1_%SAZ 1_^1_%JMP* I5_^1_%JMP REQDON_#RETURN TO 'GO' ROUTINE._^1_%SPC 2_^1* WBUF1 - OUTPUT BUFFER, OVERLAYING 'IOPR'._^1_%SPC 1_^1_%ORG IOPR_^1_%BSS WBUF1(PGSIZW)_^1SCRLUF NUM 0_,SCRATCH/€€LIBRARY DIFFERENT FLAG_'PSR 1180_^1_%SPC 2_^1DYNDSK NOP 0_^1_%LDA- $B3_*ARE SCRATCH_:PSR 1180_^1_%SUB- $C2_*AND LIBRARY UNITS DIFFERENT_*PSR 1180_^1_%STA* SCRLUF_'SCRLUF EQ 0 SAME, SCRLUF NE 0 DIFFER PSR 1180_^1_%LDA MAXSEC_'LARGEST SCRATCH SECTOR_.77*1879_^1_%LDQ* SCRLUF_'IF UNITS ARE DIFFERENT_/PSR 1180_^1_%SQN STASEC_'SET SECT TO MAXSEC_3PSR 1180_^1_%SUB- $C1_'SUBTRACT S.N.€€ OF SCRATCH AREA._^1*_81 CARD REMOVED FOR PSR 90*2673_(90*2190_^1STASEC STA SECT_)SAVE TOTAL SCRATCH SIZE_.PSR 1180_^1_%LDA- $E4_'ADDRESS OF LOAD/GO AREA PLUS 1_^1_%ADD =N162_(1 CYLINDER + 2 SECTORS_^1_%STA SN_^1_%SQN ROUND_(SKIP COMPUTATION OF SCRATCH SIZE_$PSR 1180_^1_%ADD- $C1_'ROUND OVERLAY LOCATION UP TO_^1*_8START OF A CYLINDER, TO (PSR 90*2673) 90*2190_^1ROUND INA -2_€€P81*2970**_^1_%TRA Q_+MINIMIZE NUMBER OF SEEKS BY_^1_%LRS 16_*ASSURING THAT ALL OVERLAY_^1_%DVI =N160_'PAGES FALL WITHIN A CYLINDER._^1_%SQN 3_-***PSR 68 * 1503 BEGIN ***_^1_%LDA SN_,***PSR 68 * 1503 END_!***_^1_%JMP* LEAVE_^1_%TCQ A_^1_%ADD =N160_^1_%ADD SN_^1LEAVE ADD =N318_(NO LOCALS IN PHASE D/E_084*2541_^1_%STA SN_+SYMTAB AT CYL 3 SEC 000_/84*2541_^1_%ADD =N480_(ON€€E CYL FOR REF FILE, ONE FOR MACROS_!FTN 3.3_^1_%STA CSN1_)SCRATCH 1 AT CYL 6 SEC 000_,FTN 3.3_^1_%STA SN1_Q84*2541_^1_%INA PGSIZS_'INTERLEAVE SCRATCH PAGES_.84*2541_^1_%STA CSN2_)SCRATCH 2 AT CYL 6 SEC 006_,FTN 3.3_^1_%JMP* (DYNDSK)_!RETURN TO 'IOPR'._^1_%SPC 2_^1* RBUF1 - INPUT BUFFER, OVERLAYING 'DYNDSK'._^1_%SPC 1_^1_%ORG DYNDSK_^1_%BSS RBUF1(PGSIZW)_^1_%SPC 2_^1ABORT €ðFWRITE $FC,,SO,1,A,0,1,I,,1_:**FTN 3.0**_^1*_]_^1******************************************************_^1* 'EXIT' ENTRY_F*_^1******************************************************_^1*_]_^1EXIT_!NOP 0_^1_%EXIT_^1SO_#ALF 1,SO_^1_%END_]_^__ðPWGOE CSY/ 32F P€1_%NAM GOE_*DECK-ID 32F FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^1_%SPC 3_^1*_$PROGRAM BASE .._^1* THIS IS THE 2.0B VERSION._^1* CALL TO 'LOCLIZ' DELETED. SIZE OF LABELLED COMMON INCREASED AND_^1* SIZE OF BLANK COMMON DECREASED._^1* PHASE E ASSE€€MBLY ROUTINES_^1* GOE IS USED IN PHASE E_^1_%ENT GOE_^1_%EXT PHASE6,IOPR_^1_%DAT IFLAGS_NFTN 3.3_^1_%DAT LINECT_NFTN 3.3_^1_%DAT LINCT1_NFTN 3.3_^1_%DAT IR_RFTN 3.3_^1_%DAT IK_RFTN 3.3_^1_%DAT IP_RFTN 3.3_^1_%DAT IA_RFTN 3.3_^1_%DAT IL_RFTN 3.3_^1_%DAT IM_RFTN 3.3_^1_%DAT IXLGO_OFTN 3.3_^1_%DAT IOPTO_OFTN 3.3_^1_%DAT IOPTV_OFTN 3.3_^1_%DAT IOPTC_OFTN 3.3_^1_%DAT IOP€€TD_OFTN 3.3_^1_%DAT MCSTRT_NFTN 3.3_^1_%DAT MACRNB_NFTN 3.3_^1_%DAT MACSEC_NFTN 3.3_^1_%DAT IERRS(16)_KFTN 3.3_^1_%DAT ISRFAD_NFTN 3.3_^1_%DAT LGO_QFTN 3.3_^1_%DAT ISCRI_OFTN 3.3_^1_%DAT ISCRO_OFTN 3.3_^1_%DAT IX_RFTN 3.3_^1_%DAT B(3017-38)_JFTN 3.3_^1_%COM D($082A)_^1GOE_"NOP 0_^1_%LDQ* (INAD)_#SCRATCH IN (ISCRI)_^1_%LDA* (OUTAD)_"SCRATCH OUT (ISCRO)_^1_%STA* (INAD)_#O€€UT BECOMES IN_^1_%STQ* (OUTAD)_"IN BECOMES OUT_^1_%RTJ+ IOPR_%INITIALIZE IOPR_^1_%RTJ+ PHASE6_^1_%LDA+ LGO_'RESTORE LOAD AND GO SECT NR_^1_%STA- $E4_^1_%RTJ- ($F4)_$CHECK FOR MAG TAPE LIST_^1_%NUM $4600,$8FB,0_D**FTN 3.0**_^1_%TRQ A_^1_%AND =N$3800_LPSR 744_^1_%EOR =N$0800_LPSR 744_^1_%SAN NOTPE_^1MT_#RTJ- ($F4)_$END OF FILE ON LIST TAPE_^1_%NUM $5C00,0,0,$8FB,$2100_!EOF AND € BACKSPACE_(**FTN 3.0**_^1_%LDA* MT+3_^1_%SAZ 1_^1_%JMP* *-2_^1NOTPE LDA+ IOPTC_(CHECK FOR CROSS REFERENCE REQUEST_$FTN 3.3_^1_%SAZ EXIT_)SKIP IF NONE TO EXIT_2FTN 3.3_^1_%RAO* GOE_QFTN 3.3_^1EXIT_!JMP* (GOE)_(RETURN TO FTN_9FTN 3.3_^1INAD_!ADC ISCRI_^1OUTAD ADC ISCRO_^1_%END_]_^__ PWCONV2 CSY/ 33F P€1_%NAM CONV_)DECK-ID 33F FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^1_%SPC 3_^1* THIS CONV IS USED IN PHASE E_^1* NON-IDENTICAL CONV IS USED IN PHASE A_^1* SUBROUTINE CONV (IX1,IX2)...THIS IS FOR PHASE E_^1_%ENT CONV_^1_%EQU N10($46)_^1CONV_!NOP_€€]_^1_%LDA* (CONV)_^1_%STA* IX1_^1_%RAO* CONV_^1_%LDA* (CONV)_^1_%STA* IX2_^1_%STQ* QSAV_^1_%LDA- I_^1_%STA* ISAV_^1* DO 2 I=1,6_^1_%ENQ 5_^1* 2 IX2(I) = IBCDTB(47)_^1_%ENA $20_^1ALPHA STA+ 0,Q_^1_%EQU IX2(*-1)_^1_%INQ -1_^1_%SQM 1_^1_%JMP* ALPHA_^1* I = IX1_]_^1_%LDA+ 0_^1_%EQU IX1(*-1)_^1_%SAP BETA_^1_%TCA A_^1BETA_!STA* I2_^1* J = 6_]_^1_%ENQ 5_^1_%STQ- I_^1* DO 10 K=1,€€6_^1_%STQ* K_^1* L = I/10_]_^1GAMMA CLR Q_^1_%DVI- N10_^1_%STA* L_^1* IX2(J) = -10*L+I+IBCDTB(1)_^1_%MUI- N10_^1_%TCA A_^1_%ADD* I2_^1_%INA $30_^1_%STA* (IX2),I_^1* J = J-1_]_^1_%LDA- I_^1_%INA -1_^1_%STA- I_^1* IF (L.EQ.0) GOTO 15_^1_%LDA* L_^1_%SAZ DELTA_^1* 10 I=L_]_^1_%STA* I2_^1* CONTINUE_]_^1_%LDQ* K_^1_%INQ -1_^1_%SQM DELTA_^1_%STQ* K_^1_%JMP* GAMMA_^1* RETURN_]_^1DE€°LTA LDA* (IX1)_^1_%SAP EPSILN_^1_%ENA $2D_^1_%STA* (IX2),I_^1EPSILN LDQ* QSAV_^1_%LDA* ISAV_^1_%STA- I_^1_%RAO* CONV_^1_%JMP* (CONV)_^1_%BSS QSAV,ISAV,I2,K,L_^1_%END_]_^__ °PWSTORB CSY/ 34F P€1_%NAM STOREB_'DECK-ID 34F FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^1_%SPC 3_^1*_8STOREB IS USED IN PHASE B_^1* ********************************** FTN 3.1 **************************_^1_%ENT STOREB_^1* ********************************** FTN 3.1 €€($) **********************_^1* MASTER LABELLED COMMON_^1_%DAT ETC1(43)_LFTN 3.3_^1_%DAT ICOMT(12+3)_IFTN 3.3_^1_%DAT ETC2(3)_MFTN 3.3_^1_%DAT IBCDTB(48)_JFTN 3.3_^1_%DAT LOOPT(3+50),IEQV(255+2),ISTAB(150+2)_^1_%DAT ETC3(1+25+11)_^1* SYMBOL TABLE LABELLED COMMON_^1_%DAT ISYMN,ISYMFL,ISYMD,ISYMX,ISYMS,ISYMP_^1_%DAT ISYMPC,ISYMPS,ISYMNS,SYMTAB(960)_^1_%EQU ITYPE(SYMTAB),ISYM(€€SYMTAB+3)_^1* PHASE B BLANK COMMON_^1_%COM JSYM(3)_^1* COMMUNICATION AREA CONSTANTS_^1_%EQU X0200($2C),X0400($2D),X1000($2F)_^1* ********************************** FTN 3.1 **************************_^1* SUBROUTINE STOREB_^1STOREB NOP_]_^1* ********************************** FTN 3.1 ($) **********************_^1_%STQ* QSAV_^1_%LDQ+ ISYMX_^1_%ENA 0_RPSR 724_^1_%STA* (F+1),Q_LPSR€€ 724_^1_%STA+ ITYPE,Q_LPSR 724_^1_%STA+ ITYPE+1,Q_JPSR 724_^1* ISYM(ISYMX)=JSYM(1)...ISYM(ISYMX+1)=JSYM(2)_^1_%LDA+ JSYM_^1_%STA+ ISYM-1,Q_^1_%LDA+ JSYM+1_^1_%STA+ ISYM,Q_^1* ISYMN = ISYMN+ISYMFL_^1C_$LDA+ ISYMN_^1_%ADD+ ISYMFL_^1_%STA* (C+1)_^1* IF (JSYM(3).NE.$2424) GO TO G_^1D_$LDA+ JSYM+2_^1_%EOR =N$2424_^1_%SAN G_^1* ITYPE(ISYMX) = 1_^1E_$LDA =N$F9FF_^1F_$AND+ ITYPE-1,Q_^1_€€%ADD- X0200_^1_%STA* (F+1),Q_^1* GO TO K_]_^1_%JMP* K_^1* IF (JSYM(3).EQ.$2525) GO TO J_^1G_$LDA* (D+1)_^1_%EOR =N$2525_^1_%SAZ J_^1* RETURN_]_^1H_$LDQ* QSAV_^1* ********************************** FTN 3.1 **************************_^1_%JMP* (STOREB)_^1* ********************************** FTN 3.1 ($) **********************_^1* ITYPE(ISYMX) = 2_^1J_$LDA* E+1_^1_%AND* (F+1),Q_^1_%€œADD- X0400_^1_%STA* (F+1),Q_^1* ICLASS(ISYMX) = 2_^1K_$LDA =N$87FF_^1_%AND* (F+1),Q_^1_%ADD- X1000_^1_%STA* (F+1),Q_^1_%JMP* H_^1_%BSS QSAV_^1_%END_]_^__ œPWDUMVL CSY/ 35F P€1_%NAM DUMVOL_'DECK-ID 35F FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^1_%SPC 3_^1*_8DUMVOL IS USED IN PHASES A1,A2,A3,A4,A5_^1*_]_^1*_8BEGIN_4***** FTN 3.1 *****_^1*_$THIS ROUTINE IS DESIGNED TO ALLOW SIMULATED VOLATILE STORAGE_^1*_$ALLOCATION (TEMP€€ORARY DATA STORAGE) USED BY SUBPROGRAM DFLOT_^1*_$WHEN RUNNING IN BACKGROUND MODE._^1*_]_^1_%ENT AVOLA_^1_%ENT AVOLR_^1AVOLA 0_"0_,SIMULATED VOLATILE STORAGE ALLOCATION ROUTINE_^1_%STQ* (BUFADD)_$SAVE Q REGISTER IN SIMULATED VOLATILE STORAGE_^1_%LDQ* BUFADD_'BEGINNING LOCATION OF SIM. VOLATILE STORAGE_^1_%STA- 1,Q_*SAVE A REGISTER IN SIMULATED VOLATILE STORAGE_^1_%LDA- I_^1_%STA€€- 2,Q_*SAVE I REGISTER IN SIMULATED VOLATILE STORAGE_^1_%STQ- I_,PLACE VOLATILE STORAGE ADDRESS IN I REGISTER_^1_%JMP* (AVOLA)_%RETURN TO CALLING PROGRAM_^1AVOLR 0_"0_,SIMULATED VOLATILE STORAGE ALLOCATION ROUTINE_^1_%LDQ- I_,BEGINNING LOCATION OF SIM. VOLATILE STORAGE_^1_%LDA- 2,Q_^1_%STA- I_,RESTORE THE I REGISTER_^1_%LDA- 1,Q_*RESTORE THE A REGISTER_^1_%LDQ- (ZERO),Q_$RESTORE T€¨HE Q REGISTER_^1_%JMP* (AVOLR)_%RETURN TO CALLING PROGRAM_^1_%EQU ZERO($22)_^1BUFADD ADC BUF_^1BUF_"BZS BUF(31)_M90*3018_^1*_8END_6***** FTN 3.1 *****_^1_%END_]_^__ ¨PHEADER CSY/ 36F P€1_%NAM HEADER_'DECK-ID 36F FORTRAN 3.3B_)SUMMARY-102_^1*_$STORE PROGRAM NAME, DATE AND TIME IN PAGE HEADER_^1*_$MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT, CONTROL DATA CORPORATION - 1975_^1_%SPC 5_^1_%ENT VALNAM_^1_%EXT PRGNAM_^1_%EXT PAGNBR_^1_%EXT DATE_^1_%EXT TIME_^1_%EQU EXTCOR($E9)_^1_%EQU ZERO($22)_^1€€_%EQU TEN($46)_^1_%SPC 3_^1VALNAM NOP 0_^1_%STQ* QSAVE_(SAVE Q REG_^1_%LDA- I_^1_%STA* ISAVE_(SAVE I REGISTER_^1_%LDA* (VALNAM)_$PICK UP ADDRESS OF NAME_^1_%STA* NAMADR_^1_%RAO* VALNAM_'BUMP RETURN ADDRESS_^1_%ENQ 2_^1VAL001 LDA* (NAMADR),Q_"PICK UP 2 CHARACTERS OF NAME_^1_%STA+ PRGNAM,Q_$SAVE IN HEADER_^1_%INQ -1_^1_%SQM VAL002_'SKIP IF ALL OF NAME TRANSFERRED_^1_%JMP* VAL00€€1_'GO GET NEXT 2 CHARACTERS_^1VAL002 LDQ- EXTCOR_^1_%LDQ- 12,Q_)ADDRESS OF DATE/TIME INFO TABLE_^1_%LDA- 1,Q_*MONTH_^1_%STA DATE_)STORE IN HEADER_^1AMON_!EQU AMON(*-1)_^1_%ENA 1_^1_%STA- I_^1_%LDA- 2,Q_*DAY_^1_%STQ* TEMP_^1_%LDQ =A//_^1_%LLS 8_^1_%STQ* (AMON),I_$STORE IN HEADER_^1_%RAO- I_^1_%STA* (AMON),I_$STORE IN HEADER_^1_%RAO- I_^1_%LDQ* TEMP_^1_%LDA- (ZERO),Q_$YEAR_^1_%S€€TA* (AMON),I_$STORE IN HEADER_^1_%LDA- 10,Q_)HOURS, MIN SEC_^1_%RTJ* DECASC_'CONVERT MIN TO ASCII_^1_%STQ* TEMP_^1_%RTJ* DECASC_'CONVERT HOURS TO ASCII_^1_%TRQ A_^1_%STA TIME_)STORE IN HEADER_^1ATIME EQU ATIME(*-1)_^1_%ENQ 1_^1_%LDA* TEMP_^1_%STA* (ATIME),Q_^1*_$CLEAR THE PAGE NUMBER IN HEADING_^1_%ENQ 2_^1_%ENA $20_^1PGLOOP STA PAGNBR,Q_^1_%INQ -1_^1_%SQM 1_^1_%JMP* PGLO€dOP_^1_%LDA* ISAVE_^1_%STA- I_,RESTORE I REGISTER_^1_%JMP* (VALNAM)_$RETURN TO CALLER_^1_%SPC 3_^1QSAVE NUM 0_^1ISAVE NUM 0_^1NAMADR NUM 0_^1TEMP_!NUM 0_^1TEMP1 NUM 0_^1_%SPC 3_^1DECASC NOP 0_^1_%CLR Q_^1_%DVI- TEN_^1_%STQ* TEMP1_^1_%CLR Q_^1_%DVI- TEN_^1_%QLS 8_^1_%ADQ* TEMP1_^1_%ADQ =A00_^1_%JMP* (DECASC)_$RETURN_^1_%SPC 3_^1_%END_]_^__ dPDIAGRG CSY/ 37F P€1_%NAM DIAGRG_'DECK-ID 37F FORTRAN 3.3B_)SUMMARY-102_^1*_$REGISTER THE OCCURANCE OF AN ERROR_^1*_$MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT, CONTROL DATA CORPORATION - 1975_^1_%SPC 5_^1_%ENT DIAGRG_^1_%SPC 2_^1_%DAT IFLAGS_^1_%DAT LINECT_^1_%DAT LINCT1_^1_%DAT FILL1(14)_KFTN 3.3_^1_%DAT IERRS(16)_^1_%SPC 2€€_^1_%EQU ZERO($22)_^1_%EQU H000F($6)_^1_%EQU H00FF($A)_^1_%EQU ONEBIT($23)_^1_%EQU ZROBIT($33)_^1_%SPC 3_^1DIAGRG ADC 0_^1_%STQ* SVQ_^1_%LDA- I_^1_%STA* SVI_^1_%LDQ* (DIAGRG)_$GET THE ADDRESS OF THE CODE_^1_%LDA- (ZERO),Q_$GET THE CODE_^1_%AND- H00FF_^1_%TRA Q_^1_%LRS 4_,Q NOW CONTAINS THE INDEX FOR THE WORD_^1_%ARS 12_^1_%AND- H000F_(A NOW CONTAINS THE INDEX OF THE BIT_^€€1_%STA- I_^1_%LDA* (REGRAD),Q_^1_%AND- ZROBIT,I_$MAKE SURE BIT IS CLEAR_^1_%EOR- ONEBIT,I_$SET ERROR BIT_^1_%STA* (REGRAD),Q_^1_%LDA* (REGRAD)_^1_%AND- ZROBIT_'MAKE SURE BIT IS CLEAR_^1_%EOR- ONEBIT_'SET 'AN ERROR OCCURRED' BIT_^1_%STA* (REGRAD)_^1_%RAO* DIAGRG_^1_%LDA* SVI_^1_%STA- I_^1_%LDQ* SVQ_^1_%JMP* (DIAGRG)_^1_%SPC 1_^1REGRAD ADC IERRS_^1_%BZS SVQ_^1_%BZS SVI_^1_%END_]_€^__ PGOF CSY/ 38F P€1_%NAM GOF_*DECK-ID 38F FORTRAN 3.3B_)SUMMARY-102_^1*_$MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT, CONTROL DATA CORPORATION - 1975_^1_%SPC 3_^1_%ENT_"GOF_^1_%EXT_"ENDLOC_^1_%EXT_"PHASEF,IOPR_^1_%DAT IFLAGS_^1_%DAT LINECT_^1_%DAT LINCT1_^1_%DAT REST(3017-3)_^1GOF_"NOP_"0_^1_%RTJ_"IOPR_^1_%ENA_"0_^1_%STA_"LINCT1_€<^1_%RTJ_"PHASEF_^1_%RAO*_!GOF_^1_%JMP*_!(GOF)_^1_%END_]_^__ <PGETSYR CSY/ 39F P€1_%NAM GETSYR_'DECK-ID 39F FORTRAN 3.3B_)SUMMARY-102_^1*_$MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT, CONTROL DATA CORPORATION - 1975_^1_%SPC 3_^1_%ENT_"GETSYR_^1_%DAT MISC1(33)_KFTN 3.3_^1_%DAT ISRFAD_^1_%DAT MISC2(4)_^1_%DAT IGLAB(5)_^1_%DAT ICOMT(18)_^1_%DAT IBCDTB(48)_^1_%DAT_"KURSEC_^1_%COM_"IREFBF(3840)€,IVEC(3400)_^1GETSYR NOP_"0_^1_%LDA+_!KURSEC_^1_%EQU_"KURS(*-1)_^1_%SAN_"3_^1_%LDA+ ISRFAD_^1_%STA*_!(KURS)_^1_%STA*_!SECT_^1_%RTJ-_!($F4)_^1_%NUM $4801,0_^1THR_"NUM_"0,$8B3,3840_^1_%ADC_"IREFBF,0_^1SECT_!NUM_"0_^1_%LDA*_!THR_^1_%SAZ_"1_^1_%JMP*_!*-2_^1_%JMP*_!(GETSYR)_^1_%END_]_^__PTITLE CSY/ 40F P€1_%NAM TITLE_(DECK-ID 40F FORTRAN 3.3B_)SUMMARY-102_^1*_$MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT, CONTROL DATA CORPORATION - 1975_^1_%SPC 3_^1*_]_^1_%ENT TITLE,WRTYP_^1*_]_^1_%EXT WRITE_^1_%EXT LWRITE_^1_%DAT IFLAGS,LINECT,LINCT1_^1_%DAT FILL1(14)_KFTN 3.3_^1*_]_^1TITLE NOP 0_^1_%STQ* SVQ_^1_%LDQ* (TITLE)€€_^1_%LDQ- ($22),Q_^1_%RAO* TITLE_^1_%SQN NOTFST_^1_%RTJ+ WRITE_^1_%ADC 4,3_^1_%ADC NT0_^1_%ADC T0_^1_%JMP* RETURN_^1*_]_^1NOTFST LDA+ LINCT1_^1_%EQU LINCT(*-1)_^1_%INA -12_^1_%SAP 1_^1_%STA* (LINCT)_^1_%RTJ* LF_^1_%RTJ* LF_^1_%INQ -1_^1_%QLS 2_^1_%RTJ* PRNT_^1_%RTJ* PRNT_^1_%RTJ* LF_^1_%RTJ* PRNT_^1_%RTJ* LF_^1*_]_^1RETURN LDQ* SVQ_^1_%JMP* (TITLE)_^1*_]_^1*_]_^1LF_#NOP 0€€_^1_%RTJ+ WRITE_^1_%ADC 4,3,4_^1_%ADC LFBF_^1_%JMP* (LF)_^1*_]_^1PRNT_!NOP 0_^1_%LDA* TAD,Q_^1_%STA* MESAD_^1_%LDA* TNB,Q_^1_%STA* NBWRD_^1_%RTJ+ WRITE_^1_%ADC 4,3_^1_%ADC NBWRD_^1MESAD ADC 0_^1_%INQ 1_^1_%JMP* (PRNT)_^1*_]_^1NBWRD NUM 0_^1SVQ_"NUM 0_^1LFBF_!ALF 3,_^1*_]_^1*_]_^1WRTYP NOP 0_^1_%STQ* SVQ_^1_%LDQ* (WRTYP)_^1_%LDQ- ($22),Q_^1_%LDA* TYPAD-1,Q_^1_%STA* MAD€€_^1_%RTJ+ LWRITE_^1MAD_"NUM 0_^1_%ADC ELEVEN_^1_%ADC 22_^1_%LDQ* SVQ_^1_%RAO* WRTYP_^1_%JMP* (WRTYP)_^1*_]_^1ELEVEN NUM 11_^1*_]_^1*_]_^1TAD_"ADC T1,T1A,T1B,0_^1_%ADC T2,T2A,T2B,0_^1_%ADC T3,T3A,T3B,0_^1_%ADC T4,T4A,T4B_^1*_]_^1NT0_"ADC T1-T0_^1*_]_^1TNB_"ADC T1A-T1,T1B-T1A,T2-T1B,0_^1_%ADC T2A-T2,T2B-T2A,T3-T2B,0_^1_%ADC T3A-T3,T3B-T3A,T4-T3B,0_^1_%ADC T4A-T4,T4B-T4A,€€T5-T4B_^1*_]_^1TYPAD ADC P1,P2,P3,P4,P5,P6,P7,P7A,P8,P9,P10,P10A,P11_^1*_]_^1*_]_^1T0_#ALF +, ***** L I S T_!O F_!S Y M B O L S *****+_^1*_]_^1T1_#ALF +, CONSTANTS :+_^1T1A_"ALF +, ---------+_^1T1B_"ALF +,_!VALUE_,ADDRESS +_^1_%ALF +, REFERENCED BY STATEMENT NB : +_^1*_]_^1T2_#ALF +, VARIABLES :+_^1T2A_"ALF +, ---------+_^1T2B_"ALF +,_!NAME_"TYPE_$ADDRESS +_^1_%ALF +€€, REFERENCED BY STATEMENT NB : +_^1*_]_^1T3_#ALF +, EXTERNALS :+_^1T3A_"ALF +, ---------+_^1T3B_"ALF +,_!NAME_"TYPE_$ADDRESS +_^1_%ALF +, REFERENCED BY STATEMENT NB : +_^1*_]_^1T4_#ALF +, LABELED STATEMENTS : +_^1T4A_"ALF +, ------------------ +_^1T4B_"ALF +,_!LABEL_,ADDRESS +_^1_%ALF +, REFERENCED BY STATEMENT NB : +_^1*_]_^1_%EQU T5(*)_^1*_]_^1*_]_^1P1_#ALF 11, B Y T €€E_^1P2_#ALF 11, S I G N . B Y T E_^1P3_#ALF 11, I N T R . F N ._^1P4_#ALF 11, S T A T . F N ._^1P5_#ALF 11,_^1P6_#ALF 11, I N T E G E R_^1P7_#ALF 11, R E A L_^1P7A_"ALF 11, D B L E . P R E C ._^1P8_#ALF 11, F U N C T I O N_^1P9_#ALF 11, I N T E G E R . F N ._^1P10_"ALF 11, R E A L . F N ._^1P10A_!ALF 11, D B L . P R C . F N ._^1P11_"ALF 11, S U B R O U T I N E_^1*_]_^1*€_]_^1_%END_]_^__ PIFOVPF CSY/ 41F P€1_%NAM IFOVPF_'DECK-ID 41F FORTRAN 3.3B_)SUMMARY-102_^1*_$MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT, CONTROL DATA CORPORATION - 1975_^1_%SPC 3_^1_%ENT_"IFOVPF_^1_%SPC_"2_^1* THIS FTN CALLABLE INTEGER FUNCTION IS AN OVERFLOW-PROOF TEST ON_^1* THE RELATIVE MAGNITUDE OF IT'S TWO PARAMETERS._^1_%SPC_"1_^1* EX: USE_€€"IF(IFOVPF(I,J))1,2,3_$INSTEAD OF_^1*_,IF(I-J)1,2,3_^1*_$OR_#IF(IFOVPF(I,J).GT.0) ...ETC..._!INSTEAD OF_^1*_,IF(I.GT.J)...ETC..._^1_%SPC_"3_^1IFOVPF NOP_"0_^1_%LDA*_!(IFOVPF)_^1_%STA*_!A_^1_%RAO*_!IFOVPF_^1_%LDA*_!(IFOVPF)_^1_%STA*_!B_^1_%RAO*_!IFOVPF_^1_%ENA_"-1_^1_%STA*_!C_^1_%LDA*_!(A)_^1_%SOV_"0_^1_%SUB*_!(B)_^1_%SAM_"OVTST_^1_%RAO*_!C_^1_%SAZ_"OVTST_^1_%RAO*_!C_^1OVTST LDA*_!€NC_^1_%SNO_"EXIT_^1_%TCA_"A_^1EXIT_!JMP*_!(IFOVPF)_^1_%BSS_"A,B,C_^1_%END_]_^__NPERRMSG CSY/ 42F P€1_%NAM ERRMSG_'DECK-ID 42F FORTRAN 3.3B_)SUMMARY-102_^1*_$MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT, CONTROL DATA CORPORATION - 1975_^1_%SPC 3_^1_%ENT_"ERRMSG_^1_%EXT_"ENDLOC_^1_%SPC_"2_^1* THIS IS THE ERROR MESSAGES DUMP MODULE OF FTN 2.0B_^1* ERROR CODE 1 TO 257 ARE FLAGGED BY SETTING THE CORRECT_^1* BIT IN REGE€€RR VECTOR IN FTN TO 1._^1* THIS MODULE IS CALLED AFTER ANY OTHER MODULE IF THE_^1* ERROR CODE 0 IS SET,THEN DUMPS ALL ERROR MESSAGES_^1* SELECTED AND RESET ALL OF THEM TO ZERO._^1* AT LAST CONTROL IS RETURNED TO FTN TO CALL THE_^1* FOLLOWING MODULE NORMALLY._^1* THIS MODULE RUNS AS PHASE -1._^1_%SPC_"2_^1_%DAT IFLAGS_^1_%DAT LINECT_^1_%DAT LINCT1_^1_%DAT FILL1(14)_KFTN 3.3_^1_%€€DAT IERRS(16)_^1_%DAT REST(3017-33)_GFTN 3.3_^1_%EXT_"WRITE_^1ERRMSG NOP_"0_^1_%LDA+ IFLAGS_HR.D.R. MOD._^1_%AND- $3_+$0001 MASK_6R.D.R. MOD._^1_%SAZ NOTLP-*-1_#IF ZERO, NO CARRIAGE CONTROL_#R.D.R. MOD._^1_%ENA 60_+TAKES CARRIAGE CONTROL_*R.D.R. MOD._^1_%JMP* STOLMS_HR.D.R. MOD._^1NOTLP ENA 35_LR.D.R. MOD._^1STOLMS STA* LNLIM1_HR.D.R. MOD._^1_%INA 1_MR.D.R. MOD._^1_%STA* LN€€LIM2_GR.D.R. MOD._^1_%INA -5_LR.D.R. MOD._^1_%STA* LNLIM3_HR.D.R. MOD._^1_%INA 1_MR.D.R. MOD._^1_%STA* LNLIM4_HR.D.R. MOD._^1_%ENA_"0_^1LIN1_!STA+_!LINCT1_^1_%STA*_!KURMES_^1LOOP_!LDA*_!KURMES_^1_%SUB*_!LAST_^1_%SAM_"1_^1_%JMP*_!DONE_^1_%LDA*_!KURMES_^1_%TRA_"Q_^1_%QRS_"4_^1_%AND-_!6_^1_%STA-_!I_^1_%LDA+ IERRS,Q_^1_%AND-_!$23,I_^1_%SAN_"1_^1_%JMP*_!LOOPEX_^1_%LDQ*_!KURMES_^1_%LDA€€_"MAD+1,Q_ER.D.R. MOD._^1_%SUB_"MAD,Q_GR.D.R. MOD._^1_%STA-_!I_^1_%LDA_"MAD,Q_GR.D.R. MOD._^1_%LDQ-_!I_^1_%SAZ_"1_^1_%RTJ*_!OUTPUT_^1LOOPEX RAO*_!KURMES_^1_%JMP*_!LOOP_^1_%BSS_"KURMES,NBWRD_^1LAST_!ADC_"E0-MAD_LU.M.MOD_^1*_YR.D.R. MOD._^1MESAD NUM 0_,MESSAGE ADDRESS_1R.D.R. MOD._^1LNLIM1 NUM 0_,60 OR 35_8R.D.R. MOD._^1LNLIM2 NUM 0_,61 OR 36_8R.D.R. MOD._^1LNLIM3 NUM 0_,56 OR 3€€1_8R.D.R. MOD._^1LNLIM4 NUM 0_,57 OR 32_8R.D.R. MOD._^1*_YR.D.R. MOD._^1*_YR.D.R. MOD._^1OUTPUT NOP 0_MR.D.R. MOD._^1_%STA* MESAD_(SAVE MESSAGE ADDRESS_,R.D.R. MOD._^1_%STQ* WRDCNT_'SAVE TOTAL WORD COUNT_+R.D.R. MOD._^1_%CLR A_,CLEAR_;R.D.R. MOD._^1_%STA* OUTFLG_*THE_:R.D.R. MOD._^1_%STA* FINFLG_-FLAGS._4R.D.R. MOD._^1*_YR.D.R. MOD._^1OUTLP TRQ A_,ONLY ONE LINE_3R.D.R. MOD._^1€€_%SUB* LNLIM2_*TO OUTPUT._3R.D.R. MOD._^1_%SAM FINISH-*-1_"YES_=R.D.R. MOD._^1_%LDA* LNLIM1_'NO, OUTPUT MAX_2R.D.R. MOD._^1_%JMP* WRIT_,LINE WIDTH._2R.D.R. MOD._^1*_YR.D.R. MOD._^1FINISH RAO* FINFLG_'DONE, SET OUTPUT FINISHED FLAG. R.D.R. MOD._^1_%ADD* LNLIM2_'RESTORE WORD COUNT_.R.D.R. MOD._^1*_YR.D.R. MOD._^1WRIT_!STA* NBWRD_(SAVE NUMBER OF WORDS TO OUTPUT_!R.D.R. MOD._^1_%TRA €€ Q_MR.D.R. MOD._^1_%INQ -1_LR.D.R. MOD._^1MOVLOP LDA* (MESAD),Q_#TRANSFER_8R.D.R. MOD._^1_%STA* BUF,Q_+MESSAGE_6R.D.R. MOD._^1_%INQ -1_1TO_8R.D.R. MOD._^1_%SQM TSTFLG-*-1_,PRINT_2R.D.R. MOD._^1_%JMP* MOVLOP_3BUFFER._-R.D.R. MOD._^1*_YR.D.R. MOD._^1TSTFLG LDA* OUTFLG_'IS THIS THE 1ST LINE_,R.D.R. MOD._^1_%SAN NOTFST-*-1_"NO_>R.D.R. MOD._^1_%LDA =XBUF_(YES, OUTPUT MESSAGE_-R.D.R€€. MOD._^1_%JMP* STOBFA_HR.D.R. MOD._^1*_YR.D.R. MOD._^1NOTFST LDA* NBWRD_(NOT 1ST_9R.D.R. MOD._^1_%INA 4_/LINE, SO_5R.D.R. MOD._^1_%STA* NBWRD_.OUTPUT_4R.D.R. MOD._^1_%LDA =XMESG_0BLANKS AT_.R.D.R. MOD._^1STOBFA STA* OUTBUF_3BEGINNING._*R.D.R. MOD._^1_%LDA* KURMES_HR.D.R. MOD._^1_%SAN TOWRIT_HR.D.R. MOD._^1_%RTJ* LF_LR.D.R. MOD._^1_%RTJ* LF_LR.D.R. MOD._^1*_YR.D.R. MOD._^1TOWRIT€€ RTJ WRITE_(OUTPUT_:R.D.R. MOD._^1_%ADC 4,3,NBWRD_'THE_:R.D.R. MOD._^1OUTBUF ADC 0_2LINE._5R.D.R. MOD._^1*_YR.D.R. MOD._^1_%LDA* FINFLG_'ARE WE DONE_5R.D.R. MOD._^1_%SAZ MOMES_(NO_>R.D.R. MOD._^1_%LDA* KURMES_HR.D.R. MOD._^1_%SAN RTRN_JR.D.R. MOD._^1_%RTJ* LF_LR.D.R. MOD._^1RTRN_!RTJ* LF_LR.D.R. MOD._^1_%JMP* (OUTPUT)_$YES, RETURN TO CALLER_+R.D.R. MOD._^1*_YR.D.R. MOD._^1MOME€€S LDQ* MESAD_(GET MESSAGE ADDRESS_-R.D.R. MOD._^1_%LDA* OUTFLG_'JUST FINISHED 1ST LINE_*R.D.R. MOD._^1_%SAZ FSTOUT-*-1_"YES_=R.D.R. MOD._^1_%ADQ* LNLIM3_'NO, SO_:R.D.R. MOD._^1_%LDA* WRDCNT_*INCREMENT BY_1R.D.R. MOD._^1_%SUB* LNLIM3_-31 OR 56._1R.D.R. MOD._^1_%JMP* STOVAL_HR.D.R. MOD._^1*_YR.D.R. MOD._^1FSTOUT ADQ* LNLIM1_'YES, SO_9R.D.R. MOD._^1_%LDA* WRDCNT_*INCREMENT BY_1R.D.R€€. MOD._^1_%SUB* LNLIM1_-35 OR 60._1R.D.R. MOD._^1STOVAL STQ* MESAD_(SAVE THE_8R.D.R. MOD._^1_%STA* WRDCNT_*VALUES._6R.D.R. MOD._^1_%RAO* OUTFLG_'SET THE LINE OUTPUT FLAG_(R.D.R. MOD._^1*_YR.D.R. MOD._^1_%SUB* LNLIM4_'IS THIS THE LAST LINE_+R.D.R. MOD._^1_%SAM FINI-*-1_$YES_=R.D.R. MOD._^1_%LDA* LNLIM3_'NO, OUTPUT MAX_2R.D.R. MOD._^1_%JMP* WRIT_,LINE WIDTH._2R.D.R. MOD._^1*_YR.D.R.€€ MOD._^1FINI_!RAO* FINFLG_'LAST, SO SET FLAG_/R.D.R. MOD._^1_%ADD* LNLIM4_'RESTORE WORD COUNT_.R.D.R. MOD._^1_%JMP* WRIT_,AND OUTPUT LINE._-R.D.R. MOD._^1*_YR.D.R. MOD._^1*_YR.D.R. MOD._^1_%BSS WRDCNT,OUTFLG,FINFLG_:R.D.R. MOD._^1*_YR.D.R. MOD._^1*_YR.D.R. MOD._^1DONE_!ENQ_"15_^1_%ENA_"0_^1DON_"STA IERRS,Q_^1_%SQZ_"2_^1_%INQ_"-1_^1_%JMP*_!DON_^1_%LDA_"ERRMSG_FR.D.R. MOD._^1_%INA_€€"3_^1_%STA_"ERRMSG_FR.D.R. MOD._^1_%JMP_"(ERRMSG)_DR.D.R. MOD._^1*_YR.D.R. MOD._^1*_YR.D.R. MOD._^1LF_#NOP 0_MR.D.R. MOD._^1_%RTJ WRITE_IR.D.R. MOD._^1_%ADC 4,3,4_^1_%ADC MESG_JR.D.R. MOD._^1_%JMP* (LF)_JR.D.R. MOD._^1*_YR.D.R. MOD._^1*_YR.D.R. MOD._^1MESG_!NUM $2020,$2020,$2020,$2020_7R.D.R. MOD._^1_%BSS BUF(60)_GR.D.R. MOD._^1*_YR.D.R. MOD._^1MAD_"ADC_"E0,E1,E2,E3,E4,E5,E6,€€E7,E8,E9_5U.M.MOD_^1_%ADC_"E10,E11,E12,E13,E14,E15,E16,E17,E18,E19_^1_%ADC_"E20,E21,E22,E23,E24,E25,E26,E27,E28,E29_^1_%ADC_"E30,E31,E32,E33,E34,E35,E36,E37,E38,E39_^1_%ADC_"E40,E41,E42,E43,E44,E45,E46,E47,E48,E49_^1_%ADC_"E50,E51,E52,E53,E54,E55,E56,E57,E58,E59_^1_%ADC_"E60,E61,E62,E63,E64,E65,E66,E67,E68,E69_^1_%ADC_"E70,E71,E72,E73,E74,E75,E76,E77,E78,E79_^1_%ADC_"E80,E81,E82,E8€€3,E84,E85,E86,E87,E88,E89_^1_%ADC_"E90,E91,E92,E93,E94,E95,E96,E97,E98,E99_^1_%ADC_"E100,E101,E102,E103,E104,E105,E106,E107,E108,E109,E110_^1_%ADC_"E111,E112,E113,E114,E115,E116,E117,E118,E119,E120_^1_%ADC_"E152_^1_%BZS_"(30)_^1_%ADC_"E152,E153_^1E0_#ALF_!/,***** D I A G N O S T I C S_"R E P O R T *****/_^1E1_#ALF_!*,_"1 : FIELD IS NOT RECOGNIZABLE. (ILLEGAL CHARAC*_^1_%ALF_!*,TE€€RS IN FIELD SUCH AS 8 IN OCTAL FIELD.)*_^1E2_#ALF_!*,_"2 : MINIMUM RANGE LIMIT OF A CONSTANT IS EXCEE*_^1_%ALF_!*,DED.*_^1E3_#ALF_!*,_"3 : MORE THAN SIX CHARACTERS IN A NAME.*_^1E4_#ALF_!*,_"4 : MAXIMUM RANGE LIMIT OF A CONSTANT IS EXCEE*_^1_%ALF_!*,DED.*_^1E5_#ALF_!*,_"5 : EXPONENT IS MISSING IN A CONSTANT.*_^1E6_#ALF_!*,_"6 : SUBSCRIPTED VARIABLE WAS NOT PREVIOUSLY DI*_^1_%ALF_!*€€,MENSIONED.*_^1E7_#ALF_!*,_"7 : EXPRESSION IN AN IF STATEMENT DOES NOT HAV*_^1_%ALF_!*,E INITIAL PARENTHESIS.*_^1E8_#ALF_!*,_"8 : INCORRECT FORMAT STATEMENT.*_^1E9_#ALF_!*,_"9 : ILLEGAL USE OF THE .NOT. OPERATOR.*_^1E10_"ALF_!*,_!10 : ILLEGAL OPERATOR OR OPERAND.*_^1E11_"ALF_!*,_!11 : SUBPROGRAM REFERENCE IS ILLEGAL.*_^1E12_"ALF_!*,_!12 : LABELED END CARD IS ILLEGAL.*_^1E13_"ALF_!*€€,_!13 : NUMBER OF ARGUMENTS DIFFERS IN REFERENCES *_^1_%ALF_!*,TO THE SAME SUBPROGRAM.*_^1E14_"ALF_!*,_!14 : IMPLIED DO IN DATA STATEMENT EITHER CONTAI*_^1_%ALF_!*,NS WRONG NUMBER OF SUBSCRIPTS OR SUBSCRIPT IS OUT *_^1_%ALF_!*,OF RANGE.*_^1E15_"ALF_!*,_!15 : EXPRESSION HAS AN ILLEGAL TERMINATION.*_^1E16_"ALF_!*,_!16 : UNMATCHED PARENTHESES IN AN EXPRESSION.*_^1E17_"ALF_!*,_!17 : RE€€LATIONAL OPERATOR IS MISSING.*_^1E18_"ALF_!*,_!18 : RELATIONAL OPERATOR USED ILLEGALLY.*_^1E19_"ALF_!*,_!19 : ASTERISK IS ASSUMED.*_^1E20_"ALF_!+,_!20 : ONLY ONE ** IS ALLOWED PER PARENTHESES LEV+_^1_%ALF_!*,EL.*_^1E21_"ALF_!*,_!21 : A VARIABLE IS USED AS A SUBPROGRAM NAME OR*_^1_%ALF_!*, A SUBPROGRAM NAME IS USED AS A VARIABLE.*_^1E22_"ALF_!*,_!22 : SUBPROGRAM NAME DOES NOT APPEAR€€ IN AN EXTE*_^1_%ALF_!*,RNAL STATEMENT.*_^1E23_"ALF_!*,_!23 : ONE OR MORE DO LOOPS TERMINATE ON AN UNDEF*_^1_%ALF_!*,INED STATEMENT LABEL.*_^1E24_"ALF_!*,_!24 : ILLEGAL SUBSCRIPT.*_^1E25_"ALF_!*,_!25 : SYNTAX ERROR IN THIS STATEMENT.*_^1E26_"ALF_!*,_!26 : THIS ARRAY PREVIOUSLY DIMENSIONED IN DIMEN*_^1_%ALF_!*,SION, COMMON, OR TYPE STATEMENT, OR PREVIOUSLY DEF*_^1_%ALF_!*,INED IN AN€€ EXTERNAL *_^1_%ALF_!*,STATEMENT. THE PREVIOUS DIMENSIONING OR DEFINING *_^1_%ALF_!*,IS RETAINED AND THE NEW IGNORED.*_^1E27_"ALF_!*,_!27 : THIS FIELD MUST BE A VARIABLE OR ARRAY NAM*_^1_%ALF_!*,E IF PROCESSING A COMMON, DATA, EQUIVALENCE, BYTE,*_^1_%ALF_!*, OR SIGNED BYTE STATEMENT; AN ARRAY NAME IF *_^1_%ALF_!*,PROCESSING A DIMENSION STATEMENT; OR AN ARRAY, *_^1_%ALF_!*,VARIABLE€€, OR FUNCTION NAME IF PROCESSING A TYPE *_^1_%ALF_!*,STATEMENT.*_^1E28_"ALF_!*,_!28 : LOGICAL IF STATEMENT CONTAINS ANOTHER LOGI*_^1_%ALF_!*,CAL IF, DO, DATA, OR FORMAT STATEMENT.*_^1E29_"ALF_!*,_!29 : NAME MUST BE THE NAME OF AN ARRAY.*_^1E30_"ALF_!*,_!30 : MUST BE FIRST STATEMENT OF PROGRAM UNIT.*_^1E31_"ALF_!*,_!31 :*_^1E32_"ALF_!*,_!32 : A MISSING COMMA IN THIS STATEMENT IS ASS€€UM*_^1_%ALF_!*,ED.*_^1E33_"ALF_!*,_!33 :*_^1E34_"ALF_!*,_!34 : ILLEGAL CHARACTER IN THIS STATEMENT WILL B*_^1_%ALF_!*,E CHANGED TO A BLANK.*_^1E35_"ALF_!*,_!35 : THIS LINE, WHICH BEGINS A STATEMENT, HAS O*_^1_%ALF_!*,THER THAN ZERO OR BLANK IN COLUMN 6; BLANK IS ASSU*_^1_%ALF_!*,MED.*_^1E36_"ALF_!*,_!36 : TOO MANY LABELED COMMON BLOCKS DECLARED; C*_^1_%ALF_!*,ONTINUATION OF THE LAS€€T DECLARED BLOCK IS ASSUMED.*_^1E37_"ALF_!*,_!37 : THE NAME IN THIS COMMON STATEMENT IS EITHE*_^1_%ALF_!*,R A FORMAL ARGUMENT OR DEFINED IN A PREVIOUS COMMO*_^1_%ALF_!*,N STATEMENT._!THE *_^1_%ALF_!*,NAME IS IGNORED.*_^1E38_"ALF_!*,_!38 : NAME SPECIFIED AS TWO DIFFERENT TYPES. TH*_^1_%ALF_!*,IS SPECIFICATION IS IGNORED.*_^1E39_"ALF_!*,_!39 : THIS BYTE TYPED AS OTHER THAN AN INTEG€€ER, *_^1_%ALF_!*,OR IT IS A FORMAL ARGUMENT. THE BYTE SPECIFICATIO*_^1_%ALF_!*,N IS IGNORED.*_^1E40_"ALF_!*,_!40 : THIS BYTE PREVIOUSLY SPECIFIED AS A DIFFER*_^1_%ALF_!*,ENT BYTE. THE PREVIOUS SPECIFICATION IS RETAINED A*_^1_%ALF_!*,ND THIS ONE IGNORED.*_^1E41_"ALF_!*,_!41 : THE BIT SPECIFIED IS NOT WITHIN BOUNDS OF *_^1_%ALF_!*,THE 1700 WORD SIZE.*_^1E42_"ALF_!*,_!42 : LEAST SIGN€€IFICANT BIT IN THIS SPECIFICATIO*_^1_%ALF_!*,N IS GREATER THAN THE MOST SIGNIFICANT BIT.*_^1E43_"ALF_!*,_!43 : NAME MUST BE AN EXTERNAL FUNCTION OR SUBRO*_^1_%ALF_!*,UTINE NAME.*_^1E44_"ALF_!*,_!44 : FIELD MUST BE A NON-ZERO POSITIVE INTEGER *_^1_%ALF_!*,CONSTANT.*_^1E45_"ALF_!*,_!45 : ARRAY HAS MORE THAN THREE DIMENSIONS.*_^1E46_"ALF_!*,_!46 : DATA STATEMENT CONTAINS TOO MANY CONS€€TANTS*_^1_%ALF_!*, FOR THE SPACE PROVIDED.*_^1E47_"ALF_!*,_!47 : STATEMENT HAS MORE THAN FIVE CONTINUATION *_^1_%ALF_!*,CARDS; EXCESS CARDS ARE IGNORED.*_^1E48_"ALF_!*,_!48 : AN INSUFFICIENT NUMBER OF CONSTANTS IS PRO*_^1_%ALF_!*,VIDED IN THIS DATA STATEMENT.*_^1E49_"ALF_!*,_!49 :*_^1E50_"ALF_!*,_!50 : CONSTANT IS NOT SAME TYPE AS CORRESPONDING*_^1_%ALF_!*, DATA CELL.*_^1E51_"ALF_!€€*,_!51 : STATEMENT REDEFINES DO LOOP PARAMETER.*_^1E52_"ALF_!*,_!52 : STATEMENT TYPE IS UNRECOGNIZABLE; OR IT FO*_^1_%ALF_!*,LLOWS AN EXECUTABLE STATEMENT.*_^1E53_"ALF_!*,_!53 :*_^1E54_"ALF_!*,_!54 : STATEMENT LABEL IS MEANINGLESS; LABEL IS I*_^1_%ALF_!*,GNORED.*_^1E55_"ALF_!*,_!55 : STATEMENT LABEL PREVIOUSLY DEFINED; CURREN*_^1_%ALF_!*,T LABEL IS IGNORED.*_^1E56_"ALF_!*,_!56 : A €€PROGRAM NAME WAS EXPECTED IN THIS FIELD.*_^1E57_"ALF_!*,_!57 : TOO MANY DIMENSIONS CAUSED TABLE OVERFLOW.*_^1E58_"ALF_!*,_!58 : SYMBOL TABLE OVERFLOWED; COMPILATION TERMI*_^1_%ALF_!*,NATES.*_^1E59_"ALF_!*,_!59 : STATEMENT LABEL MAY NOT BE ZERO.*_^1E60_"ALF_!*,_!60 : NO APPARENT EXIT FROM THIS PROGRAM.*_^1E61_"ALF_!*,_!61 : UNCLOSED DO-IMPLIED LIST.*_^1E62_"ALF_!*,_!62 : UNFORMATTED€€ WRITE MUST HAVE A LIST.*_^1E63_"ALF_!*,_!63 : NAME MUST BE AN INTEGER VARIABLE OR INTEGE*_^1_%ALF_!*,R CONSTANT.*_^1E64_"ALF_!*,_!64 : NAME NOT IMPLICITLY AN INTEGER VARIABLE.*_^1E65_"ALF_!*,_!65 : A RETURN STATEMENT MAY APPEAR ONLY IN A SU*_^1_%ALF_!*,BROUTINE OR FUNCTION DEFINITION. A STOP STATEMENT*_^1_%ALF_!*, IS ASSUMED.*_^1E66_"ALF_!*,_!66 : SUPERFLUOUS INFORMATION IN THIS €€STATEMENT *_^1_%ALF_!*,IS IGNORED.*_^1E67_"ALF_!*,_!67 : THIS FIELD ON STOP CARD MUST HAVE AN OCTAL*_^1_%ALF_!*, NUMBER NOT GREATER THAN 77777. STOP IS ASSUMED.*_^1E68_"ALF_!*,_!68 : FIELD MUST BE A POSITIVE INTEGER.*_^1E69_"ALF_!*,_!69 : FIELD MUST BE AN INTEGER VARIABLE.*_^1E70_"ALF_!*,_!70 : FIELD MUST BE A STATEMENT LABEL.*_^1E71_"ALF_!*,_!71 : THIS FORM OF ASSEM STATEMENT ARG€€UMENT CAN'*_^1_%ALF_!*,T REFERENCE ELEMENTS IN COMMON, EXTERNAL NAMES OR *_^1_%ALF_!*,SUBPROGRAM ARGUMENTS.*_^1E72_"ALF_!*,_!72 : THIS TYPE OF STATEMENT MAY NOT TERMINATE A*_^1_%ALF_!*, DO LOOP.*_^1E73_"ALF_!*,_!73 : THIS STATEMENT TERMINATES A DO LOOP WHICH *_^1_%ALF_!*,IS NOT THE LAST DO ENCOUNTERED.*_^1E74_"ALF_!*,_!74 : THIS 'GO TO' JUMPS TO ITSELF.*_^1E75_"ALF_!*,_!75 : A PROG€€RAM CONSISTING OF ONLY AN END CARD I*_^1_%ALF_!*,S ILLEGAL.*_^1E76_"ALF_!*,_!76 :*_^1E77_"ALF_!*,_!77 :*_^1E78_"ALF_!*,_!78 : LABEL IN A DO STATEMENT MUST REFERENCE A S*_^1_%ALF_!*,TATEMENT FOLLOWING IT.*_^1E79_"ALF_!*,_!79 : MAXIMUM ALLOWABLE NUMBER OF NESTED DO'S EX*_^1_%ALF_!*,CEEDED. THE DO LOOP MAY BE IMPLIED IN A DO LIST.*_^1E80_"ALF_!*,_!80 : OVERFLOW OF TABLE OF SUBROUTINE€€ PARAMETERS*_^1_%ALF_!*,. CAUSED BY LARGE NUMBER OF DECLARED PARAMETERS AN*_^1_%ALF_!*,D UNIQUE REFERENCES *_^1_%ALF_!*,TO THEM.*_^1E81_"ALF_!*,_!81 : THIS FORMAL ARGUMENT WAS PREVIOUSLY SPECIF*_^1_%ALF_!*,IED AS ANOTHER FORMAL ARGUMENT OR THE SUBPROGRAM N*_^1_%ALF_!*,AME.*_^1E82_"ALF_!*,_!82 : TOO MANY FORMAL ARGUMENTS CAUSED A COMPILE*_^1_%ALF_!*,R TABLE OVERFLOW.*_^1E83_"ALF_!*,€€_!83 : THE ABOVE NAME IS NOT A VARIABLE OR ARRAY *_^1_%ALF_!*,ELEMENT.*_^1E84_"ALF_!*,_!84 : TWO ELEMENTS OF THE SAME ARRAY OR COMMON B*_^1_%ALF_!*,LOCK ARE ASSIGNED TO THE SAME STORAGE UNIT.*_^1E85_"ALF_!*,_!85 : BLANK COMMON AND FORMAL ARGUMENTS MAY NOT *_^1_%ALF_!*,BE INITIALIZED WITH DATA STATEMENTS.*_^1E86_"ALF_!*,_!86 :*_^1E87_"ALF_!*,_!87 : AN ARRAY ELEMENT IN A BYTE, SIGNED€€ BYTE, D*_^1_%ALF_!*,ATA, OR EQUIVALENCE STATEMENT EITHER HAS WRONG NUM*_^1_%ALF_!*,BER OF SUBSCRIPTS OR A SUBSCRIPT IS *_^1_%ALF_!*,OUT OF RANGE.*_^1E88_"ALF_!*,_!88 : TOO MANY EQUIVALENCE NAMES CAUSED A COMPIL*_^1_%ALF_!*,ER TABLE OVERFLOW.*_^1E89_"ALF_!*,_!89 : AT LEAST TWO ELEMENTS MUST APPEAR IN AN EQ*_^1_%ALF_!*,UIVALENCE STATEMENT.*_^1E90_"ALF_!*,_!90 :*_^1E91_"ALF_!*,_!91 :€€ DATA STATEMENT FIELD IS NOT AN INTEGER, RE*_^1_%ALF_!*,AL, DOUBLE PRECISION OR LITERAL CONSTANT.*_^1E92_"ALF_!*,_!92 : MISSING TERMINATING ASTERISK OR QUOTE IN A*_^1_%ALF_!*, LITERAL STRING AS APPROPRIATE.*_^1E93_"ALF_!*,_!93 :*_^1E94_"ALF_!*,_!94 :*_^1E95_"ALF_!*,_!95 :*_^1E96_"ALF_!*,_!96 :*_^1E97_"ALF_!*,_!97 :*_^1E98_"ALF_!*,_!98 :*_^1E99_"ALF_!*,_!99 :*_^1E100_!ALF_!*, 100 :€€ CATASTROPHIC TABLE OVERFLOW; COMPILATION I*_^1_%ALF_!*,S ABANDONED. COMPILER IS LIMITED TO 300 WORDS OF G*_^1_%ALF_!*,ENERATED CODE PER SOURCE STATEMENT. IF THE OFFENDI*_^1_%ALF_!*,NG STATEMENT IS ARITHMETIC OR A LOGICAL IF, *_^1_%ALF_!*,THE STATEMENT SHOULD BE BROKEN INTO TWO OR MORE ST*_^1_%ALF_!*,STATEMENTS AND THE PROGRAM RECOMPILED.*_^1E101_!ALF_!*, 101 : TWO PROGRAM, FUNCTI€€ON, SUBROUTINE, OR BLOC*_^1_%ALF_!*,K DATA STATEMENTS IN IN ONE PROGRAM UNIT; THE SECO*_^1_%ALF_!*,ND IS IGNORED.*_^1E102_!ALF_!*, 102 :*_^1E103_!ALF_!*, 103 : RELATIVE ADDRESS ARGUMENT IN ASSEM STATEME*_^1_%ALF_!*,NT REQUIRES PRECEDING CONTROL INDICATOR ARGUMENT (*_^1_%ALF_!+,*).+_^1_%ALF_!+,(*).+_^1E104_!ALF_!*, 104 :*_^1E105_!ALF_!*, 105 :*_^1E106_!ALF_!*, 106 :*_^1E107_!AL€€F_!*, 107 :*_^1E108_!ALF_!*, 108 :*_^1E109_!ALF_!*, 109 :*_^1E110_!ALF_!*, 110 : SYMBOL REFERENCE TABLE OVERFLOW. SUBSEQUEN*_^1_%ALF_!*,T REFERENCES WILL NOT BE LISTED BY 'C' OPTION PROC*_^1_%ALF_!*,ESSOR.*_^1E111_!ALF_!*, 111 : THE INDEX USED IN THIS SUBSCRIPTED VARIABL*_^1_%ALF_!*,E IS IN CONFLICT WITH THE DIMENSION DECLARATION.*_^1E112_!ALF_!*, 112*_^1E113_!ALF_!*, 113 : €€MAXIMUM NUMBER OF MACROS EXCEEDED. THIS *_^1_%ALF_!*,MACRO DEFINITION IS IGNORED.*_^1E114_!ALF_!*, 114 : THIS MACRO WAS PREVIOUSLY DEFINED; THE NEW*_^1_%ALF_!*, DEFINITION IS IGNORED.*_^1E115_!ALF_!*, 115 : CALL TO AN UNDEFINED MACRO.*_^1E116_!ALF_!*, 116 : NESTED MACROS ARE ILLEGAL.*_^1E117_!ALF_!*, 117 :*_^1E118_!ALF_!*, 118 :*_^1E119_!ALF_!*, 119 :*_^1E120_!ALF_!*, 120 :*€Â_^1********** THOSE ERROR CODES ARE NOT DEFINED (121 TO 151)_^1E152_!ALF_!*, 152 : ARITHMETIC TABLE OVERFLOW.*_^1** THIS FIXES THE MAXIMUM NUMBER OF ERROR CODES._^1_%EQU_"E153(*)_^1_%END_]_^__ ÂPMON1 CSY/ P1 MON_]_^__ PPHASEF CSY/ 01G P€1_$SUBROUTINE PHASEF_^1_#*_2/DECK-ID 01G FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^13_]_^1*_] FTN 3.3_^1_$COMMON /A/ IFLAGS,LINECT,LINCT1_^1_$COMMON /A/ IR,IK,IP,IA,IL,IM,IXLGO,IOPTO,IOPTV,IOPTC,IOPTD_^1_$COMMON /A/ MCSTRT,MACRNB,MACSEC_^1_$COMMON /€€A/ IERRS(16),ISRFAD_^1_$COMMON /A/ LGO,ISCRI,ISCRO,IX_^1_$COMMON /A/ IGLAB(5),ICOMT(18),IBCDTB(48)_^1*_] FTN 3.3_^1_$EQUIVALENCE (ICOMBN,ICOMT(4))_^1_$DIMENSION ICOMBN(7)_^1_$COMMON /A/ KURSEC,NEXT,IPNT(4),NBEACH(4),IBUF(10)_^1_$COMMON /A/ INDOUT,LIGNE(136),IREST(342)_^1_$COMMON /A/ ISYMN,ISYMFL,ISYMD,ISYMX,ISYMS,ISYMP,ISYMPC,ISYMPS_^1_$COMMON /A/ ISYMNS,SYMTAB(2400)_^1_$INTEGER S€€YMTAB_^1_$COMMON IRBUF(3840),IVEC(3400)_^1_$BYTE(IDUM,SYMTAB(1)(15=15)),(KDUMY,SYMTAB(1)(15=15)),_^1_#+(ICLASS,SYMTAB(1)(14=11)),(ITYPE,SYMTAB(1)(10=9))_^1_$DIMENSION IDUM(1),KDUMY(1),ICLASS(1),ITYPE(1)_^1_$BYTE (ISNGL,SYMTAB(1)(8=8)),(KELSIZ,SYMTAB(1)(8=8)),_^1_#+(ICOM,SYMTAB(1)(7=5)),(IPART,SYMTAB(1)(4=3))_^1_$DIMENSION ISNGL(1),KELSIZ(1),ICOM(1),IPART(1)_^1_$BYTE (KRFCNT,SYMTAB(€€1)(2=2)),(IDIM,SYMTAB(1)(1=0)),_^1_#+(IREL,SYMTAB(1)(1=1)),(IEXT,SYMTAB(1)(0=0))_^1_$DIMENSION KRFCNT(1),IDIM(1),IREL(1),IEXT(1)_^1_$EQUIVALENCE (IRSA,SYMTAB(2)),(ICOMTX,SYMTAB(2)),(ISNOL,SYMTAB(2))_^1_$DIMENSION IRSA(1),ICOMTX(1),ISNOL(1)_^1_$BYTE (IDATAS,SYMTAB(3)(15=15)),(IREF,SYMTAB(3)(15=15)),_^1_#+(IEQVX,SYMTAB(3)(14=8)),(ITILF,SYMTAB(3)(14=8))_^1_$DIMENSION IDATAS(1),IREF(1)€€,IEQVX(1),ITILF(1)_^1_$BYTE (IPARTR,SYMTAB(3)(7=4)),(INDUCV,SYMTAB(3)(7=7)),(ISFARG,_^1_#+SYMTAB(3)(6=6)),(IARGNO,SYMTAB(3)(5=0)),(IPARTL,SYMTAB(3)(3=0))_^1_$DIMENSION IPARTR(1),INDUCV(1),ISFARG(1),IARGNO(1),_^1_#+IPARTL(1)_^1_$EQUIVALENCE(ISYM,SYMTAB(4))_^1_$DIMENSION ISYM(1)_^1C_]_^1C FIRST GET SURE THAT CURENT PAGE OF SYMTAB IS COPIED ON DISK FILE._^1C_]_^1_$J=(ISYMPC/ISYMPS)*2€€7+1_^1_$J=J+J/54_^1_$IF(J-(J/11)*11.NE.1)GO TO 4_^1_$CALL WRITE(11,J,960,SYMTAB(1))_^1_$J=J+11_^1_$CALL WRITE(11,J,960,SYMTAB(961))_^1_$J=J+11_^1_$CALL WRITE(11,J,480,SYMTAB(1921))_^1_$GO TO 5_^1_"4 CALL WRITE(11,J,480,SYMTAB(1))_^1_$J=J+6_^1_$CALL WRITE(11,J,960,SYMTAB(481))_^1_$J=J+11_^1_$CALL WRITE(11,J,960,SYMTAB(1441))_^1_"5 KURSEC=0_^1_$NEXT=1_^1_$INDOUT=2_^1_$ISYMPS=2400_^1_€€$ISYMX=0_^1_$DO 2 I=1,4_^1_$LIGNE(I)=$20_^1_$IPNT(I)=0_^1_$NBEACH(I)=0_^1_"2 CONTINUE_^1_$CALL TITLE(0)_^1_"1 CALL SYMSCN_^1_$IF(ISYMP.EQ.1)GO TO 100_^1_$ICL=ICLASS(ISYMX)+1_^1_$IRS=IRSA(ISYMX)_^1_$GO TO (1,20,10,20,20,30,30,40,40,40),ICL_^1_!10 IF(IRS.EQ.$7FFF)GO TO 1_^1_$NX=1_]_^1_$GO TO 50_^1_!20 CALL ACON(ISYM(ISYMX),IBUF)_^1_$NX=2_]_^1_$IF(ICL.NE.2)GO TO 50_^1_$IF(IBUF.EQ.$2E.€€OR.IBUF.EQ.$30.OR.(IRS.EQ.$7FFF.AND.IDUM(ISYMX)_^1_#+.EQ.0))GO TO 1_^1_$GO TO 50_^1_!30 IF(IRS.EQ.$7FFF)GO TO 1_^1_$NX=3_]_^1_$GO TO 50_^1_!40 CALL ACON(ISYM(ISYMX),IBUF)_^1_$IF(IBUF.EQ.$2E)GO TO 1_^1_$NX=4_]_^1_!50 GO TO(60,70,70,80),NX_^1C_]_^1C IF CONSTANT,SORT WITH REGARDS TO ITS VALUE._^1C_]_^1_!60 IBUF(1)=ISYM(ISYMX)_^1_!61 IBUF(2)=0_^1_$GO TO 90_^1C_]_^1C IF VARIABLE,ALPHA€€BETICAL SORT,BUT REPLACE CODE 38 (BLANK) BY 0_^1C SO THAT THE ORDER IS CORRECT._^1C_]_^1_!70 IBUF(1)=IREPAK(ISYM(ISYMX))_^1_$IBUF(2)=IREPAK(ISYM(ISYMX+1))_^1_$GO TO 90_^1C_]_^1C IF LABEL,NUMERICAL SORT._^1C_]_^1_!80 IF(IBUF(1).LT.$40) GO TO 81_^1_$IBUF(1)=$7FFF_^1_$GO TO 61_^1_!81 M=0_]_^1_$DO 82 I=1,6_^1_$IF(IBUF(I).EQ.$20) GO TO 83_^1_$M=M*10+IBUF(I)-$30_^1_!82 CONTINUE_^1_!83 €€IBUF(1)=M_^1_$GO TO 61_^1_!90 CALL SORT(IPNT(NX),IBUF)_^1_$GO TO 1_^1 100 ISYMX=0_^1_$DO 200 I=1,4_^1_$K=IPNT(I)_^1 101 IF(K.EQ.0)GO TO 200_^1_$ISYMX=ISYMX+1_^1_$SYMTAB(ISYMX)=IRBUF(K+3)_^1_$K=IRBUF(K)_^1_$NBEACH(I)=NBEACH(I)+1_^1_$GO TO 101_^1 200 CONTINUE_^1_$L=0_]_^1_$DO 201 I=1,4_^1 201 L=L+NBEACH(I)_^1_$DO 300 I=1,ISYMX_^1_$IVEC(I)=SYMTAB(I)_^1 300 CONTINUE_^1_$ISYMPC=-1_€€^1_$L=1_]_^1_$DO 2000 I=1,4_^1_$IF(NBEACH(I).EQ.0)GO TO 2000_^1_$CALL TITLE(I)_^1_$LM=L+NBEACH(I)-1_^1_$DO 1999 K=L,LM_^1_$ISYMX=IVEC(K)_^1_$CALL GETSYM_^1_$ICL=ICLASS(ISYMX)_^1_$ITP=ITYPE(ISYMX)_^1_$IPT=IPART(ISYMX)_^1_$IRS=IRSA(ISYMX)_^1_$ICO=ICOM(ISYMX)_^1_$GO TO (1100,1200,1300,1400),I_^1C_]_^1C LIST OF CONSTANTS._^1C_]_^1 1100 CALL HCON(ISYM(ISYMX),IBUF)_^1_$IF(ITP.EQ.2)GO TO €€1110_^1_$IBUF(5)=$20_^1_$IBUF(6)=$20_^1_$IBUF(7)=$28_^1_$CALL LWRITE(IBUF,7,0)_^1_$ITP=ISYM(ISYMX)_^1_$IF(ITP.GE.0)GO TO 1106_^1_$CALL LWRITE($2D,1,0)_^1_$ITP=-ITP_^1 1106 CALL CONV(ITP,IBUF)_^1_$IBUF(7)=$29_^1_$CALL LWRITE(IBUF,7,1)_^1 1101 INDOUT=INDOUT+1_^1_$DO 1103 J=INDOUT,22_^1_$LIGNE(J)=$20_^1 1103 CONTINUE_^1_$INDOUT=22_^1_$CALL HCON(IRS,IBUF)_^1_$DO 1104 J=5,9_^1_$IBUF(J)=€€$20_^1 1104 CONTINUE_^1_$IF(ICO.EQ.0)GO TO 1105_^1_$IBUF(6)=$43_^1_$IF(ICOMBN(ICO).NE.0)IBUF(6)=$44_^1 1105 CALL LWRITE(IBUF,9,0)_^1_$GO TO 1500_^1C_]_^1C FLOAT CONSTANT._^1C_]_^1 1110 IBUF(5)=$20_^1_$IBUF(6)=$20_^1_$CALL HCON(ISYM(ISYMX+1),IBUF(7))_^1_$CALL LWRITE(IBUF,10,0)_^1_$GO TO 1101_^1C_]_^1C LIST OF VARIABLES._^1C_]_^1 1200 CALL ACON(ISYM(ISYMX),IBUF)_^1_$IBUF(7)=$20_^1_$I€€BUF(8)=$20_^1_$CALL LWRITE(IBUF,8,0)_^1_$IF(ICL.GT.1)GO TO 1250_^1_$ICL=IPT_^1C_]_^1C IF SOME OF THESE DAYS PHASE B,C, OR D/E DO NOT DESTROY ANYMORE_^1C IPART IN SYMTAB , REMOVE THE NEXT STATEMENT TO HAVE BYTES AND_^1C SIGNED BYTES RECOGNIZED AND SIGNALED IN THE LIST._^1C_]_^1_$ICL=0_^1_$IF(ICL.GT.0)GOT O 1250_^1_$ICL=ITP+5_^1 1250 CALL WRTYP(ICL)_^1_$GO TO 1101_^1C_]_^1C LIST O€€F EXTERNALS_^1C_]_^1 1300 CALL ACON(ISYM(ISYMX),IBUF)_^1_$IBUF(7)=$20_^1_$IBUF(8)=$20_^1_$CALL LWRITE(IBUF,8,0)_^1_$IF(ICL.EQ.5)GO TO 1301_^1_$ICL=13_^1_$GO TO 1250_^1 1301 ICL=ITP+9_^1_$GO TO 1250_^1C_]_^1C LIST OF LABELED STATEMENTS._^1C_]_^1 1400 CALL ACON(ISYM(ISYMX),IBUF)_^1_$CALL LWRITE(IBUF,6,0)_^1_$GO TO 1101_^1C_]_^1C LIST OF STAT.REF._^1C_]_^1 1500 ICOMA=1_^1 1501 M=MATCH€(ISYMX+ISYMP)_^1_$IF(M.NE.0)GO TO 1502_^1_$CALL LWRITE(0,-1,0)_^1_$GO TO 1999_^1 1502 IF(ICOMA.NE.0)GO TO 1503_^1_$CALL LWRITE($2C,1,0)_^1 1503 CALL CONV(M,IBUF)_^1_$CALL LWRITE(IBUF,6,1)_^1_$ICOMA=0_^1_$GO TO 1501_^1 1999 CONTINUE_^1_$L=LM+1_^1 2000 CONTINUE_^1_$END_]_^__ PGETSYM CSY/ 02G P€1_$SUBROUTINE GETSYM_^1_#*_2/DECK-ID 02G FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^13_]_^1C THIS ROUTINE IS USED IN PHASEF_^1*_] FTN 3.3_^1_$COMMON /A/ IFLAGS,LINECT,LINCT1_^1_$COMMON /A/ IR,IK,IP,IA,IL,IM,IXLGO,IOPTO,IOPTV,IOPTC,IOPTD_^1_$COMMON /€€A/ MCSTRT,MACRNB,MACSEC_^1_$COMMON /A/ IERRS(16),ISRFAD_^1_$COMMON /A/ LGO,ISCRI,ISCRO,IX_^1_$COMMON /A/ IGLAB(5),ICOMT(18),IBCDTB(48)_^1*_] FTN 3.3_^1_$EQUIVALENCE (ICOMBN,ICOMT(4))_^1_$DIMENSION ICOMBN(7)_^1_$COMMON /A/ KURSEC,NEXT,IPNT(4),NBEACH(4),IBUF(10)_^1_$COMMON /A/ INDOUT,LIGNE(136),IREST(342)_^1_$COMMON /A/ ISYMN,ISYMFL,ISYMD,ISYMX,ISYMS,ISYMP,ISYMPC,ISYMPS_^1_$COMMON /€€A/ ISYMNS,SYMTAB(2400)_^1_$INTEGER SYMTAB_^1_$COMMON IRBUF(3840),IVEC(3400)_^1_$BYTE(IDUM,SYMTAB(1)(15=15)),(KDUMY,SYMTAB(1)(15=15)),_^1_#+(ICLASS,SYMTAB(1)(14=11)),(ITYPE,SYMTAB(1)(10=9))_^1_$DIMENSION IDUM(1),KDUMY(1),ICLASS(1),ITYPE(1)_^1_$BYTE (ISNGL,SYMTAB(1)(8=8)),(KELSIZ,SYMTAB(1)(8=8)),_^1_#+(ICOM,SYMTAB(1)(7=5)),(IPART,SYMTAB(1)(4=3))_^1_$DIMENSION ISNGL(1),KELSIZ(1),ICOM(€€1),IPART(1)_^1_$BYTE (KRFCNT,SYMTAB(1)(2=2)),(IDIM,SYMTAB(1)(1=0)),_^1_#+(IREL,SYMTAB(1)(1=1)),(IEXT,SYMTAB(1)(0=0))_^1_$DIMENSION KRFCNT(1),IDIM(1),IREL(1),IEXT(1)_^1_$EQUIVALENCE (IRSA,SYMTAB(2)),(ICOMTX,SYMTAB(2)),(ISNOL,SYMTAB(2))_^1_$DIMENSION IRSA(1),ICOMTX(1),ISNOL(1)_^1_$BYTE (IDATAS,SYMTAB(3)(15=15)),(IREF,SYMTAB(3)(15=15)),_^1_#+(IEQVX,SYMTAB(3)(14=8)),(ITILF,SYMTAB(3)(14€€=8))_^1_$DIMENSION IDATAS(1),IREF(1),IEQVX(1),ITILF(1)_^1_$BYTE (IPARTR,SYMTAB(3)(7=4)),(INDUCV,SYMTAB(3)(7=7)),(ISFARG,_^1_#+SYMTAB(3)(6=6)),(IARGNO,SYMTAB(3)(5=0)),(IPARTL,SYMTAB(3)(3=0))_^1_$DIMENSION IPARTR(1),INDUCV(1),ISFARG(1),IARGNO(1),_^1_#+IPARTL(1)_^1_$EQUIVALENCE(ISYM,SYMTAB(4))_^1_$DIMENSION ISYM(1)_^1_$ISYMP=(ISYMX/ISYMPS)* ISYMPS_^1_$ISYMX=ISYMX-ISYMP_^1_$IF(ISYMP.EQ€€.ISYMPC)RETURN_^1_$J=(ISYMP/ISYMPS)*27+1_^1_$J=J+J/54_^1_$IF(J-(J/11)*11.NE.1)GO TO 30_^1_$CALL READ(11,J,960,SYMTAB(1))_^1_$J=J+11_^1_$CALL READ(11,J,960,SYMTAB(961))_^1_$J=J+11_^1_$CALL READ(11,J,480,SYMTAB(1921))_^1_$GO TO 40_^1_!30 CALL READ(11,J,480,SYMTAB(1))_^1_$J=J+6_^1_$CALL READ(11,J,960,SYMTAB(481))_^1_$J=J+11_^1_$CALL READ(11,J,960,SYMTAB(1441))_^1_!40 ISYMPC=ISYMP_^1_$€RETURN_^1_$END_]_^__PACON CSY/ 03G P€1_$SUBROUTINE ACON(N1,N2)_^1_#*_2/DECK-ID 03G FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^13_]_^1C THIS IS THE F VERSION OF IACON ROUTINE._^1C STORES INTO N2 ASCII CHARACTERS FOUND IN N1(1) AND N1(2) IN_^1C INTERNAL FTN FORMAT._^1*_] FTN 3.3_^1_$COMMO€€N /A/ IFLAGS,LINECT,LINCT1_^1_$COMMON /A/ IR,IK,IP,IA,IL,IM,IXLGO,IOPTO,IOPTV,IOPTC,IOPTD_^1_$COMMON /A/ MCSTRT,MACRNB,MACSEC_^1_$COMMON /A/ IERRS(16),ISRFAD_^1_$COMMON /A/ LGO,ISCRI,ISCRO,IX_^1_$COMMON /A/ IGLAB(5),ICOMT(18),IBCDTB(48)_^1*_] FTN 3.3_^1_$EQUIVALENCE (ICOMBN,ICOMT(4))_^1_$DIMENSION ICOMBN(7)_^1_$COMMON /A/ KURSEC,NEXT,IPNT(4),NBEACH(4),IBUF(10)_^1_$COMMON /A/ INDOU€€T,LIGNE(136),IREST(342)_^1_$COMMON /A/ ISYMN,ISYMFL,ISYMD,ISYMX,ISYMS,ISYMP,ISYMPC,ISYMPS_^1_$COMMON /A/ ISYMNS,SYMTAB(2400)_^1_$INTEGER SYMTAB_^1_$DIMENSION N1(1),N2(1),ICONF(4),ITEMP(3)_^1_$DATA IADD/0/_^1_$DATA ICONF(1),ICONF(2),ICONF(3),ICONF(4)/1521,39,1,0/_^1_$EQUIVALENCE (ICONF(4),ITEMP(1)),(ITEMP(3),KTEMP)_^1_$KOUT=1_^1_$DO 1 I=1,2_^1_$ITEMP(1)=0_^1_$ITEMP(2)=0_^1_$KTEMP=N1€(I)_^1_$IF(KTEMP.GE.0)GO TO 4_^1_$KTEMP=KTEMP-30420_^1_$IADD=20_^1_"4 DO 2 J=1,3_^1_$ITEMP(J)=(KTEMP-ITEMP(1)*ICONF(1)-ITEMP(2)*ICONF(2))/ICONF(J)_^1_$K=ITEMP(J)+IADD_^1_$IF(K.EQ.38)K=46_^1_$N2(KOUT)=IBCDTB(K+1)_^1_$KOUT=KOUT+1_^1_"2 IADD=0_^1_"1 CONTINUE_^1_$RETURN_^1_$END_]_^__PHCON CSY/ 04G P€1_$SUBROUTINE HCON(N1,N2)_^1_#*_2/DECK-ID 04G FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^13_]_^1C THIS IS THE F VERSION OF IHCON ROUTINE._^1*_] FTN 3.3_^1_$COMMON /A/ IFLAGS,LINECT,LINCT1_^1_$COMMON /A/ IR,IK,IP,IA,IL,IM,IXLGO,IOPTO,IOPTV,IOPTC,IOPTD€€_^1_$COMMON /A/ MCSTRT,MACRNB,MACSEC_^1_$COMMON /A/ IERRS(16),ISRFAD_^1_$COMMON /A/ LGO,ISCRI,ISCRO,IX_^1_$COMMON /A/ IGLAB(5),ICOMT(18),IBCDTB(48)_^1*_] FTN 3.3_^1_$EQUIVALENCE (ICOMBN,ICOMT(4))_^1_$DIMENSION ICOMBN(7)_^1_$COMMON /A/ KURSEC,NEXT,IPNT(4),NBEACH(4),IBUF(10)_^1_$COMMON /A/ INDOUT,LIGNE(136),IREST(342)_^1_$COMMON /A/ ISYMN,ISYMFL,ISYMD,ISYMX,ISYMS,ISYMP,ISYMPC,ISYMPS€Þ_^1_$COMMON /A/ ISYMNS,SYMTAB(2400)_^1_$INTEGER SYMTAB_^1_$DIMENSION N2(1)_^1_$K=4096_^1_$KOUT=1_^1_$DO 1 I=1,4_^1_$J=AND(N1/K,$F)+1_^1_$N2(KOUT)=IBCDTB(J)_^1_$K=K/16_^1_$KOUT=KOUT+1_^1_"1 CONTINUE_^1_$RETURN_^1_$END_]_^__ÞPLWRITE CSY/ 05G P€1_$SUBROUTINE LWRITE(N,NBC,MODE)_^1_#*_2/DECK-ID 05G FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^13_]_^1C SORES NBC CHARACTERS INTO THE OUTPUT BUFFER_^1C MODE =1 SUPPRESS HEADING BLANKS_^1C_$=0 DONT_^1C NBC = NUMBER OF CHARACTERS CONTAINED IN N_^1C_(€€IF NBC=-1 , TERMINATE THE LINE_^1*_] FTN 3.3_^1_$COMMON /A/ IFLAGS,LINECT,LINCT1_^1_$COMMON /A/ IR,IK,IP,IA,IL,IM,IXLGO,IOPTO,IOPTV,IOPTC,IOPTD_^1_$COMMON /A/ MCSTRT,MACRNB,MACSEC_^1_$COMMON /A/ IERRS(16),ISRFAD_^1_$COMMON /A/ LGO,ISCRI,ISCRO,IX_^1_$COMMON /A/ IGLAB(5),ICOMT(18),IBCDTB(48)_^1*_] FTN 3.3_^1_$EQUIVALENCE (ICOMBN,ICOMT(4))_^1_$DIMENSION ICOMBN(7)_^1_$COMMON /A/ KURS€€EC,NEXT,IPNT(4),NBEACH(4),IBUF(10)_^1_$COMMON /A/ INDOUT,LIGNE(136),IREST(342)_^1_$COMMON /A/ ISYMN,ISYMFL,ISYMD,ISYMX,ISYMS,ISYMP,ISYMPC,ISYMPS_^1_$COMMON /A/ ISYMNS,SYMTAB(2400)_^1_$INTEGER SYMTAB_^1_$DIMENSION N(1)_^1_$NBL=0_^1_$IF(NBC)13,100,1_^1_"1 IF(MODE.EQ.0)GO TO 10_^1_$DO 2 I=1,NBC_^1_$IF(N(I).NE.$20)GO TO 10_^1_$NBL=NBL+1_^1_"2 CONTINUE_^1 100 RETURN_^1_!10 NB=NBC-NBL_^€€1_$NBL=NBL+1_^1_$IF (AND(IFLAGS,1).NE.0) GO TO 20_^1_$IF (NB.LT.72-INDOUT) GO TO 15_^1_$GO TO 21_^1_!20 IF(NB.LT.130-INDOUT) GO TO 15_^1_!21 NB=31_^1_$ASSIGN 15 TO JUMP_^1_!11 INDOUT=INDOUT+1_^1_$LIGNE(INDOUT)=$20_^1_$CALL PACK(LIGNE,INDOUT)_^1_$CALL WRITE(3,1,INDOUT/2,LIGNE)_^1_$DO 12 I=1,NB_^1_$LIGNE(I)=$20_^1_!12 CONTINUE_^1_$INDOUT=NB_^1_$GO TO JUMP_^1_!13 NB=2_]_^1_$ASSIGN 100€Š TO JUMP_^1_$GO TO 11_^1_!15 DO 16 I=NBL,NBC_^1_$INDOUT=INDOUT+1_^1_$LIGNE(INDOUT)=AND(N(I),$FF)_^1_!16 CONTINUE_^1_$RETURN_^1_$END_]_^__ ŠPMATCH CSY/ 06G P€1_$FUNCTION MATCH(KURS)_^1_#*_2/DECK-ID 06G FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^13_]_^1*_] FTN 3.3_^1_$COMMON /A/ IFLAGS,LINECT,LINCT1_^1_$COMMON /A/ IR,IK,IP,IA,IL,IM,IXLGO,IOPTO,IOPTV,IOPTC,IOPTD_^1_$COMMON /A/ MCSTRT,MACRNB,MACSEC_^1_$COMMO€€N /A/ IERRS(16),ISRFAD_^1_$COMMON /A/ LGO,ISCRI,ISCRO,IX_^1_$COMMON /A/ IGLAB(5),ICOMT(18),IBCDTB(48)_^1*_] FTN 3.3_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^13_]_^1_$EQUIVALENCE (ICOMBN,ICOMT(4))_^1_$DIMENSION ICOMBN(7)_^1_$COMMON /A/ KURSEC,NEXT,IPNT(4),NBEACH(4),IBUF(10)_^€€1_$COMMON /A/ INDOUT,LIGNE(136),IREST(342)_^1_$COMMON /A/ ISYMN,ISYMFL,ISYMD,ISYMX,ISYMS,ISYMP,ISYMPC,ISYMPS_^1_$COMMON /A/ ISYMNS,SYMTAB(2400)_^1_$INTEGER SYMTAB_^1_$COMMON IRBUF(3840),IVEC(3400)_^1_$DATA KURST/$7FFF/_^1_$IF(KURST.NE.$7FFF)GO TO 3_^1_$KURST=1_^1_"1 KURSEC=0_^1_$NBCH=0_^1_"2 CALL GETSYR_^1_$K=0_]_^1_"3 K=K+1_^1_$IF(K.LE.3840) GO TO 10_^1_$KURSEC=KURSEC+40_^1_$NBCH=€6NBCH+1_^1_$IF(NBCH.EQ.4) GO TO 14_^1_$GO TO 2_^1_!10 IF(IRBUF(K).GT.0)GO TO 12_^1_$KURST=-IRBUF(K)_^1_$IF(KURST.NE.$7FFF)GO TO 3_^1_!11 MATCH=0_^1_$IF(NBCH.GT.1)RETURN_^1_$K=0_]_^1_$KURST=1_^1_$RETURN_^1_!12 IF(IRBUF(K).NE.KURS )GO TO 3_^1_$MATCH=KURST_^1_$RETURN_^1_!14 KURST=$7FFF_^1_$GO TO 11_^1_$END_]_^__6PSORT CSY/ 07G P€1_$SUBROUTINE SORT(IPT,N)_^1_#*_2/DECK-ID 07G FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^13_]_^1_$COMMON IRBUF(3840),IVEC(3400)_^1_$DIMENSION IV(1),N(2)_^1_$EQUIVALENCE (IV(1),IRBUF(1))_^1*_] FTN 3.3_^1_$COMMON /A/ IFLAGS,LINECT,LINCT1_^1_$COMMON /A/€€ IR,IK,IP,IA,IL,IM,IXLGO,IOPTO,IOPTV,IOPTC,IOPTD_^1_$COMMON /A/ MCSTRT,MACRNB,MACSEC_^1_$COMMON /A/ IERRS(16),ISRFAD_^1_$COMMON /A/ LGO,ISCRI,ISCRO,IX_^1_$COMMON /A/ IGLAB(5),ICOMT(18),IBCDTB(48)_^1*_] FTN 3.3_^1_$COMMON /A/ KURSEC,NEXT,IPNT(4),NBEACH(4),IBUF(10)_^1_$COMMON /A/ INDOUT,LIGNE(136),IREST(342)_^1_$COMMON /A/ ISYMN,ISYMFL,ISYMD,ISYMX,ISYMS,ISYMP,ISYMPC,ISYMPS_^1_$COMMO€€N /A/ ISYMNS,SYMTAB(2400)_^1_$INTEGER SYMTAB_^1_$IV(NEXT)=0_^1_$IV(NEXT+1)=N(1)_^1_$IV(NEXT+2)=N(2)_^1_$IV(NEXT+3)=ISYMX+ISYMP_^1_$IF(IPT.NE.0)GO TO 1_^1_$IPT=NEXT_^1_$GO TO 100_^1_"1 K1=0_]_^1_$K2=IPT_^1_"2 IF(IFOVPF(N(1),IV(K2+1)))5,4,10_^1_"4 IF(IFOVPF(N(2),IV(K2+2)))5,5,10_^1_"5 IF(K1.NE.0)GO TO 7_^1_$IV(NEXT)=IPT_^1_$IPT=NEXT_^1 100 NEXT=NEXT+4_^1_$RETURN_^1_"7 IV(NEXT)=K2_^1€j_"8 IV(K1)=NEXT_^1_$GO TO 100_^1_!10 K1=K2_^1_$K2=IV(K2)_^1_$IF(K2.NE.0)GO TO 2_^1_$GO TO 8_^1_$END_]_^__ jPIREPAK CSY/ 08G P€1_$FUNCTION IREPAK(N)_^1_#*_2/DECK-ID 08G FORTRAN 3.3B_)SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3B_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^13_]_^1C_]_^1C THIS FUNCTION DECODES AND REENCODES N CONTAINING THREE CHAR._^1C IN INTERNAL FTN CODE SUCH THAT BLANK IS CODE 0 AND ALL OTHER_^1C CHAR. ARE ONE HIGHER €€FOR PROPER ALPHABETIC SORT._^1C_]_^1_$DIMENSION ICONF(4),ITEMP(3),K(3)_^1_$DATA ICONF(1),ICONF(2),ICONF(3),ICONF(4)/1521,39,1,0/_^1_$DATA IADD/1/_^1_$EQUIVALENCE (ICONF(4),ITEMP(1)),(ITEMP(3),KTEMP)_^1_$ITEMP(1)=0_^1_$ITEMP(2)=0_^1_$KTEMP=N_^1_$IREPAK=0_^1_$IF(KTEMP.GE.0)GO TO 4_^1_$KTEMP=KTEMP-30420_^1_$IADD=21_^1_"4 DO 2 J=1,3_^1_$ITEMP(J)=(KTEMP-ITEMP(1)*ICONF(1)-ITEMP(2)*ICONF(€ 2))/ICONF(J)_^1_$K=ITEMP(J)+IADD_^1_$IF(K.EQ.39)K=0_^1_$IREPAK=IREPAK+K*ICONF(J)_^1_$IADD=1_^1_"2 CONTINUE_^1_$IREPAK=IREPAK-$7FFF_^1_$RETURN_^1_$END_]_^1_]_^__ PFORTR CSY/ A01 P€1_%NAM FORTR_(DECK-ID A01 FTN 3.3 RUNTIME_%SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3_^1*_$SMALL COMPUTER DEVELOPMENT DIVISION, LA JOLLA CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1973_^1_%SPC 2_^1*_]_^1_%ENT READ_)BINARY READ_^1_%ENT WRITE_(BINARY WRITE_^1_%ENT FREAD_(FORMAT READ_^1_%ENT FWRITE_'FORMAT WRITE_^1_%ENT SCHEDL_^1_%ENT TIMER_^1_%ENT DISPAT€€_^1_%ENT DISP_^1_%ENT LINK_^1_%ENT ICLOCK_^1_%ENT INPINS_^1_%ENT OUTINS_^1_%ENT RELESE_^1_%ENT ICONCT_^1_%ENT OCONCT_^1_%EQU AMONI($F4)_^1_%EQU ADISP($EA)_^1_%EQU AVOLA($BB)_^1_%EQU AVOLR($BA)_^1_%EQU NZERO($12)_^1_%EQU ZERO($22)_^1_%EQU ONE($23)_^1_%EQU TWO($24)_^1_%EQU LPMSK(2)_^1_%EQU ONEBIT($23)_^1_%EQU ZROBIT($33)_E**MSOS4.0**_^1_%EQU TIME($E8)_^1_%EQU ASN€€API($49)_^1_%EQU VA(1)_^1_%EQU VR(3)_^1_%EQU VPTR(4)_^1_%EQU TEMP(5)_^1_%EQU N(6)_^1_%EXT PARABS_J**MSOS4.1**_^1_%EXT PARTBL_J**MSOS4.1**_^1*_]_^1*_]_^1READ_!0_"0_)***BINARY READ ENTRY_^1_%IIN 0_^1_%RTJ* INITL_(INITIALIZE IO-CALL_^1_%ADC READ_)LOC OF PARAMETERS_^1_%NUM $200_)REQ CODE FOR READ_^1WRITE 0_"0_)***BINARY WRITE_^1_%IIN 0_^1_%RTJ* INITL_(INITIALIZE IO-CALL_^1_€€%ADC WRITE_(LOC OF PARAMETERS_^1_%NUM $400_)REQ CODE FOR WRITE_^1FREAD 0_"0_)***FORMAT READ_^1_%IIN 0_^1_%RTJ* INITL_(INITIALIZE IO-CALL_^1_%ADC FREAD_(LOC OF PARAMETERS_^1_%NUM $800_)REQ CODE FOR F-READ_^1FWRITE 0_"0_)***FORMAT WRITE_^1_%IIN 0_^1_%RTJ* INITL_(INITIALIZE IO-CALL_^1_%ADC FWRITE_'LOC OF PARAMETERS_^1_%NUM $C00_)REQ CODE FOR F-WRITE_^1SCHEDL 0_"0_)***SCHEDULE€€R REQUEST CALL_^1_%IIN 0_^1_%RTJ INITL1_'PICK UP ARGUMENTS OF CALL_^1_%ADC SCHEDL_^1_%NUM $1200_(REQUEST CODE_^1TIMER 0_"0_)***TIMER REQUEST CALL_^1_%IIN 0_^1_%RTJ INITL1_'PICK UP ARGUMENTS OF CALL_^1_%ADC TIMER_^1_%NUM $1000_(REQUEST CODE_^1DISPAT 0_"0_)***DISPATCHER REQUEST CALL_^1_%JMP- (ADISP)_^1_%EQU DISP(DISPAT)_^1LINK_!0_"0_)***GET PARAMETER PASSED BY A_^1_%IIN 0_€€^1_%TRQ A_.SCHEDULER REQUEST_^1_%RAO* LINK_^1_%EIN 0_^1_%JMP* (LINK)_^1ICLOCK 0_"0_)***GET VALUE OF CORE CLOCK_^1_%IIN 0_^1_%LDA- TIME_^1_%RAO* ICLOCK_^1_%EIN 0_^1_%JMP* (ICLOCK)_^1INPINS 0_"0_)***INPUT THRU A-REG REQUEST_^1_%IIN 0_^1_%RTJ INITL2_^1_%ADC INPINS_'=LOC OF PARAMETERS_^1_%ADC INP_*=REQUEST_^1OUTINS 0_"0_)***OUTPUT THRU A-REG REQUEST_^1_%IIN 0_^1_%RTJ INITL2_^€€1_%ADC OUTINS_'=LOC OF PARAMETERS_^1_%ADC OUT_*=REQUEST_^1RELESE 0_"0_)***RELEASE MEMORY_^1_%IIN 0_^1_%LDA* RELESE_'IS CALLER FROM ALLOCATABLE CORE?_!**MSOS4.1**_^1PART_!LDQ =XPARTBL_$PARTITION CORE TBL_0**MSOS4.1**_^1_%INQ 1_,NO PARTITIONS IF XPARTBL = $7FFF_!**MSOS4.1**_^1_%SQM NOPART_J**MSOS4.1**_^1_%SUB* (PART+1)_H**MSOS4.1**_^1_%TRA Q_O**MSOS4.1**_^1NOPART LDA* (RELESE)€€_$GET PROGRAM FWA_3**MSOS4.1**_^1_%SQP REL1_)CALLER FROM PART CORE_,**MSOS4.1**_^1_%SAP REL0_)CALLER FROM ALLOC CORE_,**MSOS4.1**_^1_%ADD* RELESE_'ABSOLITIZE RELATIVE ADDRESS_'**MSOS4.1**_^1_%AND- LPMSK+15_$$7FFF_=**MSOS4.1**_^1REL0_!LDQ* RELESE_'GET CALLER'S ADDRESS_.**MSOS4.1**_^1_%INQ -2_N**MSOS4.1**_^1_%STA- 1,Q_*ABS PGM FWA_7**MSOS4.1**_^1_%LDA* RC_+RELEASE ALLOCATABLE_/**€€MSOS4.1**_^1RCON_!STA- (ZERO),Q_H**MSOS4.1**_^1_%STQ* CALL1+2_I**MSOS4.1**_^1CALL1 RTJ- (AMONI)_%RELEASE MEMORY_4**MSOS4.1**_^1_%ADC $2000_(INDIRECT REQUEST_2**MSOS4.1**_^1_%ADC 0_O**MSOS4.1**_^1_%JMP- (ADISP)_I**MSOS4.1**_^1REL1_!LDQ* RELESE_'GET CALLER'S ADDRESS_.**MSOS4.1**_^1_%INQ -2_N**MSOS4.1**_^1_%INA -2_+RELEASE 2 WORDS OF PARTITION HEADER *MSOS4.1**_^1_%STA- 1,Q_*ABS €€PGM FWA_7**MSOS4.1**_^1_%LDA* RC+1_)RELEASE PART_6**MSOS4.1**_^1_%JMP* RCON_)CONTINUE_:**MSOS4.1**_^1RC_#NUM $1801_(RELEASE ALLOCATABLE_/**MSOS4.1**_^1_%NUM $5801_(RELEASE PARTITION REQUEST CODE_#**MSOS4.1**_^1INITL 0_"0_^1_%RTJ- (AVOLA)_%RESERVE VOLATILE STORE_^1_%ADC N_^1_%LDQ* (INITL)_^1_%RAO* INITL_^1_%LDA* (INITL)_%GET REQUEST CODE_^1_%STA- VPTR,I_^1_%LDQ- (ZERO),Q_^1_%STQ€€- VR,I_)LOC OF PARAMETERS_^1_%INQ 5_,LOC FOR GENERATED CALL_^1_%TRQ A_O**MSOS4.1**_^1GOABS RTJ PARABS_'COMPUTE ABSOLUTE ADDRESS_***MSOS4.1**_^1_%EIN 0_O**MSOS4.1**_^1_%TRA Q_,=LOC FOR GENERATED CALL_^1_%ENA 0_^1_%RTJ* GET_*GET 1ST ARGUMENT(LU)_^1_%STA- 3,Q_^1_%ENA -0_^1_%RTJ* GET_*=2ND ARGU(FWA OF BUFFER)_^1_%STA- 5,Q_^1_%ENA -0_^1_%RTJ* GET_*=3RD ARGU(LENGTH)_^1_%STA- TEM€€P,I_^1*_8THREE CARDS DELETED_^1_%ENA 0_^1_%STA- 2,Q_*ZERO THREAD_^1_%RTJ* GETCF_(PICK UP COMPLETION ADDRESS AND FLAG_^1_%STA- (ZERO),Q_^1_%SAP NXT-*-1_%TEST IF ASSIGNED BUFFER_^1_%LDA- 5,Q_,ADDRESS, YES---_^1_%LLS 16_-GET BUFFER FWA_^1_%LDQ- (ZERO),Q_^1_%LLS 16_^1_%STA- 5,Q_^1_%LDA- (ZERO),Q_^1NXT_"ALS 6_,TEST COMPLETION ADDRESS TO_^1_%SAP NXT1-*-1_'BE CORE RESIDENT_^1_%JMP* €€NXT3_^1NXT1_!ALS 1_,TEST COMPLETION ADDRESS TO_^1_%SAM NXT2-*-1_'BE DRUM RESIDENT_^1_%LDA- 1,Q_*NO, ASSIGNED TO STATEMENT_^1_%LLS 16_-LABEL_^1_%LDQ- (ZERO),Q_^1_%LLS 16_^1_%STA- 1,Q_^1_%JMP* NXT3_^1NXT2_!LDA- NZERO+15_$YES, GET HIGH ORDER BIT_^1_%EOR- 1,Q_*OR TO COMPLETION LOC_^1_%STA- 1,Q_^1NXT3_!LDA- (ZERO),Q_^1_%AND- LPMSK+8_%MASK OUT FLAG_^1_%ADD- VPTR,I_'ADD REQ CODE FOR I€€O-CALLS_^1_%EOR- ONEBIT+14_#OR IN D BIT FOR PART CORE REQUEST **MSOS4.0**_^1_%STA- (ZERO),Q_^1_%LDA- TEMP,I_'GET MESSAGE LENGTH_^1_%LLS 16_^1_%LDQ- (ZERO),Q_^1_%LLS 16_^1_%STA- 4,Q_^1_%RAO- TEMP,I_^1_%LDA- TEMP,I_'=MASS MEMORY LOC(BIT30-15)_^1_%LLS 16_^1_%LDQ- (ZERO),Q_^1_%LLS 16_^1_%STA- 6,Q_^1_%RAO- TEMP,I_^1_%LDA- TEMP,I_'=MASS MEMORY LOC(BIT14-0)_^1_%LLS 16_^1_%LDQ- (ZERO€€),Q_^1_%LLS 16_^1_%STA- 7,Q_^1NXT4_!TRQ A_,GET LOC OF PARAMETER LIST_^1_%IIN 0_,INHIBIT INTERRUPTS 5/20/69_^1_%STA* CALL2+2_I**MSOS4.0**_^1CALL2 RTJ- (AMONI)_%CALL MONITOR_^1_%ADC $2000_(INDIRECT REQUEST_2**MSOS4.0**_^1_%ADC 0_,=INDIR PARAMETER ADDR_^1_%IIN 0_^1_%TRQ A_^1_%STA- VA,I_^1_%LDQ- VR,I_)COMPUTE RETURN ADDR_^1_%INQ 1_^1_%STQ* XIT_^1_%RTJ- (AVOLR)_%RETURN VOLATILE€€ STORAGE_^1_%EIN 0_^1_%JMP* (XIT)_(RETURN TO USER_^1_%BSS XIT(1)_^1N941_!NUM $941_^1GET_"0_"0_,GET NEW PARAMETER_^1_%IIN 0_^1_%STQ* SAVE1_(SAVE Q-REG_^1_%LDQ- VR,I_)LOC OF PARAMETER ADDR_^1_%RAO- VR,I_^1_%STA* SAVE2_(SAVE A-REG_^1_%TRQ A_O**MSOS4.1**_^1_%RTJ* (GOABS+1)_#COMPUTE ABSOLUTE ADDRESS_***MSOS4.1**_^1_%LDQ* SAVE2_(FLAG=ADDR/PARAMETER_^1_%SQM 2_,=NEG, GET ADDRESS_^1_%€€TRA Q_,=PLUS, GET PARAMETER_^1_%LDA- (ZERO),Q_^1_%LDQ* SAVE1_(RESTORE Q-REG_^1_%EIN 0_^1_%JMP* (GET)_^1GETCF ADC 0_^1_%IIN 0_^1_%STQ* SAVEQ_(SAVE Q_^1_%LDA- VR,I_)GET ADDRESS OF FLAG WORD_^1_%INA 1_^1_%RTJ* (GOABS+1)_#ABSOLUTIZE THE ADDRESS_^1_%TRA Q_^1_%LDA- (ZERO),Q_$GET FLAG WORD AND SAVE_^1_%STA* SAVEA_^1_%ALS 6_,TEST FOR EXTERNAL COMPLETION ADDRESS_^1_%SAP NOTEXT_'SKI€€P IF NOT EXTERNAL (CODE = 2)_!SS_^1_%LDQ- VR,I_^1_%LDA- (ZERO),Q_$GET COMPLETION ADDRESS_^1STORIT LDQ* SAVEQ_(AND_^1_%STA- 1,Q_*STORE INTO REQUEST_^1_%LDA* SAVEA_(PUT FLAG WORD IN A FOR RETURN_^1_%RAO- VR,I_)UPDATE PARAMETER ADDRESS_^1_%RAO- VR,I_^1_%EIN 0_^1_%JMP* (GETCF)_%RETURN_^1NOTEXT LDA- VR,I_)GET COMPLETION ADDRESS AND_^1_%RTJ* (GOABS+1)_#ABSOLUTIZE_^1_%JMP* STORIT_^1SAVEA€€ NUM 0_^1SAVEQ NUM 0_^1INITL1 0_"0_^1_%RTJ- (AVOLA)_%GET VOLATILE STORAGE_^1_%ADC N_^1_%LDQ* (INITL1)_$=LOC OF ARGUMENTS OF CALL_^1_%RAO* INITL1_^1_%LDA* (INITL1)_$GET REQUEST CODE_^1_%STA- VPTR,I_^1_%LDQ- (ZERO),Q_^1_%STQ- VR,I_^1_%INQ 3_^1_%TRQ A_O**MSOS4.1**_^1_%RTJ* (GOABS+1)_#COMPUTE ABSOLUTE ADDRESS_***MSOS4.1**_^1_%EIN 0_O**MSOS4.1**_^1_%TRA Q_^1_%RTJ* GETCF_(PICK U€€P COMPLETION ADDRESS AND FLAG_"85*2576_^1_%STA- TEMP,I_^1_%AND- LPMSK+8_%REMOVE FLAG=TYPE OF RETURN_^1_%ADD- VPTR,I_'ADD REQUEST CODE TO PARAM_^1_%STA- (ZERO),Q_^1_%LDA- TEMP,I_^1_%ALS 6_,TEST COMPLETION ADDRESS TO_^1_%SAP NEXT1-*-1_%BE CORE RESIDENT_^1_%JMP* NEXT3_^1NEXT1 ALS 1_,TEST COMPLETION ADDRESS TO_^1_%SAM NEXT2-*-1_%BE DRUM RESIDENT_^1_%LDA- 1,Q_*NO, ASSIGNED TO STATE€€MENT_^1_%LLS 16_-LABEL_^1_%LDQ- (ZERO),Q_^1_%LLS 16_^1_%STA- 1,Q_^1_%JMP* NEXT3_^1NEXT2 LDA- NZERO+15_$YES, SET BIT15 OF THE_^1_%EOR- 1,Q_,COMPLETION ADDR_^1_%STA- 1,Q_^1_%JMP* NEXT3A_'NO D BIT IF DIRECTORY CALL_(**MSOS4.0**_^1NEXT3 LDA- 1,Q_*IS COMPLETION IN UPPER BANK_'**MSOS4.0**_^1_%SAP NEXT3A_*NO, OKAY_7**MSOS4.0**_^1_%LDA- (ZERO),Q_(YES, MODIFY REQUEST TO A PART 1 **MSOS€€4.0**_^1_%AND- ZROBIT+14_/REQUEST_0**MSOS4.0**_^1_%EOR- ONEBIT+14_#SET D BIT_9**MSOS4.0**_^1_%STA- (ZERO),Q_H**MSOS4.0**_^1NEXT3A ENA 0_O**MSOS4.0**_^1_%RTJ* GET_*GET 3RD ARGUMENT_^1_%STA- 2,Q_^1_%LLS 16_^1_%JMP* NXT4+1_^1_%BSS SAVE1(1)_^1_%BSS SAVE2(1)_^1INITL2 0_"0_^1_%STQ* QSAVE_^1_%LDQ* (INITL2)_^1_%RAO* INITL2_^1_%LDA* (INITL2)_$GET REQUEST_^1_%LDQ- (ZERO),Q_$=ADDR OF PARA€€METER_^1_%STQ* SAVE2_^1_%STA* XIT2_^1_%TRQ A_O**MSOS4.1**_^1_%RTJ PARABS_'COMPUTE ABSOLUTE ADDRESS_***MSOS4.1**_^1_%TRA Q_^1_%STQ* SAVE1_^1_%LDA- (ZERO),Q_$GET 1ST ARGU(SELECT CODE)_^1_%JMP* (XIT2)_^1_%BSS XIT2(1)_^1INP_"TRA Q_,Q-REG=SELECT CODE_^1_%INP REJECT-*_$INPUT TO A-REG_^1OK_#LDQ* SAVE1_^1_%STA- 1,Q_*SAVE INPUT VALUE_^1_%ENA 0_,=ERROR CODE(INPUT OK)_^1_%JMP* STORE_^1€€OUT_"LDQ- 1,Q_*GET OUTPUT VALUE_^1_%LLS 16_+SWITCH QA-REG_^1_%OUT REJECT-*_$OUTPUT A-REG VALUE_^1_%JMP* OK_^1STORE STA- 2,Q_*STORE ERROR CODE_^1_%RAO* SAVE2_^1_%LDQ* QSAVE_^1_%EIN 0_^1_%JMP* (SAVE2)_%RETURN TO USER_^1REJECT JMP* INTRNL_'=INTERNAL REJECT_^1_%ENA 2_,=EXTERNAL REJECT_^1_%LDQ* SAVE1_^1_%JMP* STORE_^1INTRNL ENA 1_^1_%JMP* REJECT+2_^1_%BZS QSAVE(1)_^1ICONCT 0_"0_)€^***INPUT CONNECT_^1_%IIN 0_^1_%RTJ* C1750_^1_%RTJ* INITL2_^1_%ADC ICONCT_^1_%ADC INP_^1OCONCT 0_"0_)***OUTPUT CONNECT_^1_%IIN 0_^1_%RTJ* C1750_^1_%RTJ* INITL2_^1_%ADC OCONCT_^1_%ADC OUT_^1C1750 0_"0_)***CONNECT ROUTINE_^1_%STQ* QSAVE_^1_%LDQ* CODE_^1_%INP REJ-*_^1_%JMP* (C1750)_^1REJ_"NOP_]_^1_%JMP* (C1750)_^1CODE_!NUM $0400_^1_%END_]_^__ ^PQ8PRMR CSY/ B01 P€1_%NAM Q8PRMR_'DECK-ID B01 FTN 3.3 RUNTIME_%SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3_^1*_$SMALL COMPUTER DEVELOPMENT DIVISION, LA JOLLA CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1973_^1_%SPC 2_^1*_]_^1_%ENT Q8PREP_^1_%ENT Q8PKUP_^1_%ENT Q9PKUP_NFTN 3.3_^1*_]_^1_%EQU LPMSK(2),NZERO($12),ZERO($22),ONEBIT($23),ZROBIT($33)_^1_%EQU ENTAD($DC)_^1_%EQU PAD(€€$DD)_^1_%EXT PARABS_J**MSOS4.1**_^1_%BSS QSAVE(1)_H**MSOS4.1**_^1*_]_^1*_]_^1*_]_^1*_]_^1Q8PREP NUM 0_-ENTRY POINT_^1*_9Q8PREP IS THE INITIALIZATION ENTRY_^1*_9OF PARAMS. THE CALL TO THIS ENTRY POINT_^1*_9OCCURS ONCE FOR EACH PROCESSING OF A_^1*_9PARAMETER LIST. THE ADDRESS OF THE_^1*_9ENTRY POINT IS PASSED AS A PARAMETER_^1*_9WHERE IT IS PICKED UP AND STORED AWAY_^1*_9FOR LATER€€ USE._^1*_]_^1_%IIN 0_^1*_8IN ADDITION, THE A REGISTER IS STORED FTN 3.3_^1*_8IN 'NPRMS' FOR POSSIBLE USE BY Q9PKUP. FTN 3.3_^1_%STA* NPRMS_OFTN 3.3_^1_%STQ* QSAVE_(SAVE Q-REG_8**MSOS4.1**_^1_%LDQ* Q8PREP_J**MSOS4.1**_^1_%LDA* (Q8PREP)_%LOAD PARAMETER(WHICH IS THE SELF-REL-_^1*_9ATIVE ADDRESS OF THE ENTRY POINT OF_^1*_9THE CALLING ROUTINE._^1_%ADD* Q8PREP_(COMPUTE ADDRESS_^1_%SQM€€ NOMSK_(NEED 16 BIT ADDRESS_/**MSOS4.1**_^1_%AND- LPMSK+15_^1NOMSK STA- ENTAD_K**MSOS4.1**_^1_%LDQ* QSAVE_(RESTORE Q-REG_5**MSOS4.1**_^1_%RAO* Q8PREP_(COMPUTE RETURN ADDRESS_^1_%EIN 0_^1_%JMP* (Q8PREP)_%EXIT_^1*_]_^1NPRMS NUM 0_SFTN 3.3_^1*_]_^1*_]_^1*_]_^1Q8PKUP NUM 0_-ENTRY POINT_^1*_9Q8PKUP IS ENTERED ONCE FOR EACH_^1*_9CONSECUTIVE PARAMETER. THE ADDRESS_^1*_9OF THE PARAM€€ETER IS COMPUTED AND_^1*_9PASSED BACK THROUGH THE ACCUMULATOR_^1*_9AND THE RETURN ADDRESS IS INCREMENTED_^1*_9BY 1._^1*_]_^1_%IIN 0_^1_%LDA- (ENTAD)_'PICKUP PARAMETER_^1_%STA- PAD_^1_%RTJ PARABS_'COMPUTE ABSOLUTE PARAMETER ADDRESS **MSOS4.1**_^1_%RAO- (ENTAD)_^1_%EIN 0_^1_%JMP* (Q8PKUP)_%RETURN_^1_%SPC 3_SFTN 3.3_^1Q9PKUP NUM 0_,ENTRY POINT_;FTN 3.3_^1*_8Q9PKUP OPERATES IN THE€€ SAME WAY AS_"FTN 3.3_^1*_8Q8PKUP EXCEPT THAT (ENTAD) WILL ONLY_!FTN 3.3_^1*_8BE INCREMENTED NPRMS TIMES NO MATTER_!FTN 3.3_^1*_8HOW MANY TIMES Q9PKUP IS CALLED._%FTN 3.3_^1_%IIN 0_^1_%STQ* QSAVE_OFTN 3.3_^1_%LDA- (ENTAD)_%PICKUP PARAMETER_6FTN 3.3_^1_%STA- PAD_QFTN 3.3_^1_%RTJ PARABS_'COMPUTE ABSOLUTE PARAMETER ADDRESS_#FTN 3.3_^1_%TRA Q_,SAVE ADDRESS_:FTN 3.3_^1_%LDA* NPRMS_O€FTN 3.3_^1_%SAZ Q9PKP2_'SKIP IF ALL PARAMETERS PICKED UP_%FTN 3.3_^1_%INA -1_+DECREMENT PARAMETER COUNT_-FTN 3.3_^1_%STA* NPRMS_OFTN 3.3_^1_%RAO- (ENTAD)_MFTN 3.3_^1Q9PKP2 TRQ A_SFTN 3.3_^1_%LDQ* QSAVE_OFTN 3.3_^1_%EIN 0_SFTN 3.3_^1_%JMP* (Q9PKUP)_$RETURN_@FTN 3.3_^1_(END_^__PPARABR CSY/ B02 P€1_%NAM PARABR_'DECK-ID B02 FTN 3.3 RUNTIME_%SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3_^1*_$SMALL COMPUTER DEVELOPMENT DIVISION, LA JOLLA CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1973_^1_%SPC 2_^1*_$ABSOLUTIZE A PARAMETER ADDRESS_^1*_]_^1*_$INPUT_#- A-REG CONTAINS ADDRESS OF PARAMETER LIST_^1*_]_^1*_$OUTPUT_"- A-REG CONTAINS ABSOLUTE PARAMETER ADDRESS_^1*_/€€- UPON EXIT INTERRUPTS ARE INHIBITED_^1*_]_^1_%EXT END0V4_N81*2178_^1_%ENT PARABS_^1_%EQU LPMSK(2)_^1_%BSS QSAVE_(SAVE Q-REG_^1_%BSS BACK_)SAVE USER'S PARAMETER LIST ADDRESS_^1*_]_^1PARABS NUM 0_,ENTRY POINT_^1_%IIN_]_^1_%STQ* QSAVE_(SAVE Q-REG_^1_%STA* BACK_)SAVE USER'S PARAMETER LIST ADDRESS_^1_%SUB =XEND0V4_$LAST ADDRESS IN PART 0_081*2178_^1_%INA -1_R81*2178_^1_%TRA Q_€*,SAVE RESULTS IN Q-REG_^1NOPART LDA* (BACK)_'LOAD PARAMETER ADDRESS IN A-REG_^1_%SQP ABS_*RETURN - USER IN PART 1_^1_%SAP ABS_*RETURN - PARAM ADDRESS IS ABSOLUTE_^1_%ADD* BACK_)ABSOLUTIZE PARAMETER ADDRESS_^1_%AND- LPMSK+15_$$7FFF_^1ABS_"LDQ* QSAVE_(RESTORE Q-REG_^1_%JMP* (PARABS)_^1_%END_]_^__ *PQ8F2IR CSY/ B03 P€1_%NAM Q8F2IR_'DECK-ID B03 FTN 3.3 RUNTIME_%SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^1_%SPC 2_^1*_9--- EXPONENTIATION--_^1_%ENT Q8QF2I_(FLOATING TO INTEGER_^1_%ENT Q8QI2F_(INTEGER TO INTEGER_^1_%ENT Q8QF2F_(FLOATING TO FLOATING_^1_%ENT E4SAVE_'SAVE LOC $E4_9€€PSR 836_^1*_]_^1_%EQU LPMSK(2)_^1_%EQU ZERO($22)_^1_%EQU TWO($24)_LFTN 3.3_^1*_]_^1_%EQU RETAD($D5)_^1_%EQU QSAVE($D6)_^1_%EQU FLOFLG($DC)_"FLOATING/FIXED FLAG_^1_%EQU FRESLT($DD)_"INTERMEDIATE RESULTS (FLOATING)_^1_%EQU SIGN($DF)_$SIGN OF EXPONENT_^1_%EQU COEFF($E1)_#ADDRESS OF COEFFICIENT_^1_%EQU EXPO($E2)_$ADDRESS OR VALUE OF EXPONENT_^1_%EQU MLTPR($E3)_#HOLDS POWERS €€OF COEFFICIENT_^1_%EQU IRESLT($E5)_"INTERMEDIATE RESULTS (FIXED)_^1*_]_^1_%EXT HFLOT_OFTN 3.3_^1_%EXT* IFALT_OFTN 3.3_^1_%EXT ALOG_^1_%EXT EXP_^1_%EXT PARABS_J**MSOS4.1**_^1*_]_^1*_]_^1Q8QI2F NUM 0_-ENTRY POINT, INTEGER TO INTEGER_^1_%IIN 0_^1_%LDA* Q8QI2F_(SAVE WORD MARK_^1_%EIN 0_^1_%STQ- QSAVE_^1_%ENQ 1_^1_%JMP* PARAMS_^1Q8QF2I NUM 0_-ENTRY POINT, FLOATING TO INTEGER_^€€1_%IIN 0_^1_%LDA* Q8QF2I_(SAVE WORD MARK_^1_%EIN 0_^1_%STQ- QSAVE_^1_%ENQ -1_^1_%JMP* PARAMS_^1_%EJT_]_^1Q8QF2F NUM 0_-ENTRY POINT, FLOATING TO FLOATING_^1_%IIN 0_^1_%LDA* Q8QF2F_(SAVE WORD MARK_^1_%EIN 0_^1_%STQ- QSAVE_^1_$ENQ 0_^1_%SPC 3_^1*_9PARAMETER PICKUP ROUTINE_^1*_]_^1PARAMS STA- RETAD_(SAVE RETURN ADDRESS_^1GOABS RTJ PARABS_'PICKUP ABSOLUTE ADDRESS OF_(**MSOS4.1*€€*_^1_%EIN 0_O**MSOS4.1**_^1_%STA- COEFF_(COEFFICIENT_7**MSOS4.1**_^1_%RAO- RETAD_(BUMP RETURN ADDRESS_^1_%LDA- RETAD_^1_%RTJ* (GOABS+1)_#PICKUP ABSOLUTE ADDRESS OF EXPONENT *MSOS4.1**_^1_%EIN 0_O**MSOS4.1**_^1_%STA- EXPO_^1_%RAO- RETAD_(BUMP RETURN ADDRESS_^1_%LDA- $E4_*SAVE LOC $E4_9PSR 836_^1_%STA* E4SAVE_MPSR 836_^1_%STQ- FLOFLG_(SET FLOFLG_^1_%SQZ RET-*-1_'IF EXPONENTIATION €€IS TO BE PERFORMED_^1_%LDA- (EXPO)_(HERE, SET SIGN AND ABSOLUTE VALUE OF_^1_%STA- SIGN_*EXPONENT._^1_%SAP STABS-*-1_^1_%TCA A_^1STABS STA- EXPO_^1_%SQP CLHOVF-*-1_#PROCESS I2I_^1L_$JMP* CFOVF_)PROCESS F2I_^1RET_"JMP* LOGEX_)PROCESS F2F_^1_%SPC 2_^1E4SAVE NUM 0_RPSR 836_^1_%EJT_]_^1_%SPC 3_^1CLHOVF SOV 0_-CLEAR HARDWARE OVERFLOW (THAT_^1*_9GENERATED BY FIXED PT. OVERFLO)_^1_€€%LDA- (COEFF)_'PLACE COEFFICIENT IN MULTIPLIER_^1_%STA- MLTPR_^1_%ENA 1_-INITIALIZE CUMULATIVE RESULT_^1_%STA- IRESLT_^1*_]_^1*_9TEST BIT ZERO OF THE EXPONENT_^1TSTBT0 LDQ- EXPO_*AND RESET EXPONENT RIGHT SHIFTED_^1_%LRS 1_^1_%STQ- EXPO_^1_%SAP TST4ZR-*-1_^1*_9BIT WAS ON,_^1*_9SELECT FLOATING OR FIXED AND_^1*_9UPDATE CUMULATIVE RESULTS._^1_%LDA- FLOFLG_^1_%SAP FIXUP-*-1_^1FLOTAD€€ RTJ HFLOT_OFTN 3.3_^1_%NUM $B9D4_^1_%ADC FRESLT_^1_%ADC MLTPR_^1_%ADC FRESLT_^1_%JMP* TST4ZR_^1*_]_^1FIXUP LDA- IRESLT_(FIXED (IRESLT=IRESLT*MLTPR)_^1_%MUI- MLTPR_^1_%STA- IRESLT_^1*_]_^1*_9TEST EXPONENT TO SEE IF ALL_^1*_9SIGNIFICANT BITS HAVE BEEN_^1TST4ZR LDA- EXPO_*SHIFTED OUT._^1_%SAN UPMULT-*-1_^1_%JMP* CHKSIN_^1*_9NO, UPDATE MULTIPLIER BY_^1*_9SQUARING AS PER FLOFLG €€SELECTION._^1UPMULT LDA- FLOFLG_^1_%SAP SQUARE-*-1_^1_%RTJ* (FLOTAD+1)_#SQUARE FLOATING MULTIPLIER_^1_%NUM $B9D4_)(MLTPR=MLTPR*MLTPR)_^1_%ADC MLTPR_^1_%ADC MLTPR_^1_%ADC MLTPR_^1_%JMP* TSTBT0_^1*_]_^1SQUARE LDA- MLTPR_)SQUARE FIXED MULTIPLIER_^1_%MUI- MLTPR_^1_%STA- MLTPR_^1_%JMP* TSTBT0_^1*_]_^1*_9THIS IS THE FLOATING TO FIXED CASE._^1CFOVF RTJ IFALT_(CLEAR FLOATING POINT O€€VERFLOW_)FTN 3.3_^1_%ADC ZERO_PFTN 3.3_^1_%LDQ- COEFF_^1_%LDA- (ZERO),Q_H**MSOS4.0**_^1_%STA- FRESLT_J**MSOS4.0**_^1_%LDA- 1,Q_M**MSOS4.0**_^1_%STA- FRESLT+1_H**MSOS4.0**_^1_%RTJ* (FLOTAD+1)_#PLACE COEFFICIENT IN MULTIPLIER_^1_%NUM $BD5B_(AND INITIALIZE CUMULATIVE RESULT._^1_%ADC FRESLT_'(MLTPR=COEFF) (FRESLT=1.0)_'**MSOS4.0**_^1ADMLTP ADC MLTPR_^1_%ADC FLT1-*_^1_%NUM $5D40_€€^1_%ADC FRESLT_^1*_]_^1_%JMP* TSTBT0_^1*_]_^1*_]_^1*_]_^1LOGEX ENQ 1_-TRANSFER VALUE OF COEFFICIENT_^1_%LDA- (COEFF)_'TO INTERNAL WORKING CELL,_^1_%STA- FRESLT_^1_%LDQ- (COEFF),Q_^1_%STQ- FRESLT+1_^1_%SAN LOGNAT-*-1_#IF COEFFICIENT IS 0 MAKE RESULT_^1_%SQN LOGNAT-*-1_#0 TO AVOID FAULT IN NATURAL LOG_^1*_9ROUTINE_^1SETZ_!RTJ* (FLOTAD+1)_^1_%NUM $5B40_^1_%ADC FLT0-*_^1_%JMP* E€€XITFR_(EXIT_^1*_]_^1*_]_^1LOGNAT RTJ ALOG_*TAKE NATURAL LOG OF COEFFICIENT_^1_%ADC FRESLT_^1_%LDQ- EXPO_L**MSOS4.0**_^1_%LDA- (ZERO),Q_H**MSOS4.0**_^1_%STA- MLTPR_^1_%LDA- 1,Q_M**MSOS4.0**_^1_%STA- MLTPR+1_^1_%RTJ* (FLOTAD+1)_#MULTIPLY BY EXPONENT_^1_%NUM $9D40_^1_%ADC MLTPR_^1_%ADC MLTPR_^1_%RTJ EXP_+RAISE E TO COMPUTED EXPONENT_^1_%ADC MLTPR_^1*_]_^1_%JMP* EXITFR_(EXIT_^1*€€_]_^1*_9CHECK SIGN OF EXPONENT FOR NEGATIVE_^1*_9IN WHICH CASE RESULT MUST BE INVERTED_^1CHKSIN LDA- SIGN_^1_%LDQ- FLOFLG_^1_%SAM SQPF-*-1_^1_%JMP* NOINV_^1SQPF_!SQP FIXINV-*-1_^1_%RTJ* (FLOTAD+1)_#INVERT FLOATING RESULT_^1_%NUM $5B5A_^1_%ADC FLT1-*_^1_%ADC FRESLT_^1_%NUM $4000_^1_%RTJ IFALT_(CHECK FOR UNDERFLOW_3FTN 3.3_^1_%ADC TWO_QFTN 3.3_^1_%INA -2_RFTN 3.3_^1_%SAN RT€€JF_)SKIP IF UNDERFLOW_^1_%JMP* EXITFR_(EXIT_^1RTJF_!JMP* SETZ_*YES, SET RESULT TO 0_^1*_]_^1FIXINV SNO LDRES-*-1_$WAS THERE OVERFLOW IN THE DENOMINATOR_^1_%ENA 0_-YES, SET TO 0._^1_%JMP* EXITIR_(EXIT_^1LDRES ENA 1_-NO, INVERT RESULT_^1_%ENQ 0_^1_%DVI- IRESLT_^1TIOVF SOV STMAX-*-1_$IF OVERFLOW, SET TO MAXIMUM POSITIVE_^1_%JMP* EXITIR_(EXIT_^1STMAX LDA- LPMSK+15_$$7FFF_!VALUE€€_^1_%JMP* EXITIR_(EXIT_^1*_]_^1*_]_^1NOINV SQP INTRES_^1_%RTJ IFALT_(CHECK FOR OVERFLOW_^1_%ADC ZERO_PFTN 3.3_^1_%INA -2_RFTN 3.3_^1_%SAN RTJF1-*-1_$FLOATING POINT OPERATION_^1_%JMP* EXITIR_(EXIT_^1RTJF1 RTJ* (FLOTAD+1)_#YES, LOAD THE LARGEST POSSIBLE_^1_%NUM $5B40_^1_%ADC MAXPFV-*_^1_%JMP* EXITIR_(EXIT_^1*_]_^1INTRES LDA- IRESLT_(LOAD RESULT AND CHECK FOR INTEGER_^1_%JMP*€€ TIOVF_)OVERFLOW._^1*_]_^1*_9EXIT WITH FLOATING RESULT, NON-REENT. CASE_^1EXITFR LDQ* E4SAVE_'RESTORE LOC $E4_6PSR 836_^1_%STQ- $E4_PPSR 836_^1EXITIR LDQ- QSAVE_(EXIT WITH FIXED RESULT_^1_%JMP- (RETAD)_%RETURN TO CALLER_^1*_]_^1*_]_^1*_9CONSTANTS_^1*_]_^1FLT1_!NUM $40C0_)FLOATING CONSTANT 1.0_^1FLT0_!NUM 0,0_+FLOATING CONSTANT 0.0_^1MAXPFV NUM $7FFF,$FFFF_"MAXIMUM POSITIVE FLOAT€ING VALUE_^1_%END_]_^__ PABSR CSY/ B04 P€1_%NAM ABSR_)DECK-ID B04 FTN 3.3 RUNTIME_%SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^1_%SPC 2_^1*_9ABS - ABSOLUTE VALUE FUNCTION -_^1*_9ROUTINE TO COMPUTE THE ABSOLUTE_^1*_9VALUE OF A FLOATING POINT VALUE_^1*_9AND LEAVE THE RESULT IN THE PSEUDO_^1*_9ACCUMULATOR_^1€€_%ENT Q8AB_^1_%ENT ABS_^1_%EXT PARABS_J**MSOS4.1**_^1*_]_^1_%EXT HFLOT_OFTN 3.3_^1*_]_^1_%EQU LPMSK(2),NZERO($12),ZERO($22),ONEBIT($23),ZROBIT($33)_^1_%EQU FLACC($C5)_^1_%EQU RETADD($D5)_^1_%EQU TEMP($D6)_^1_%EQU QS($E2)_%SAVED Q-REGISTER_683*2447_^1*_]_^1ABS_"EQU ABS(*)_^1Q8AB_!NUM 0_-ENTRY POINT_^1_%IIN 0_^1_%STQ- QS_+SAVE Q-REGISTER_583*2447_^1_%LDA* Q8AB_)PICKUP ABS€€OLUTE PARAMETER ADDRESS **MSOS4.1**_^1_%STA- RETADD_^1_%RTJ PARABS_J**MSOS4.1**_^1_%EIN 0_O**MSOS4.1**_^1_%TRA Q_Q83*2447_^1_%LDA- 1,Q_M**MSOS4.0**_^1_%STA- TEMP+1_^1_%LDA- (ZERO),Q_H**MSOS4.0**_^1_%STA- TEMP_^1_%RAO- RETADD_'COMPUTE RETURN ADDRESS_^1FL_#RTJ HFLOT_OFTN 3.3_^1_%NUM $BD40_(LOAD, SOTRE_;FTN 3.3_^1_%ADC TEMP_^1_%ADC FLACC_OFTN 3.3_^1_%LDA- FLACC_^1_%SAP 2_^1_%€„RTJ* (FL+1)_(VALUE IS NEGATIVE, COMPLIMENT._^1_%NUM $7400_^1_%LDQ- QS_+RESTORE Q-REGISTER_483*2447_^1_%JMP- (RETADD)_^1_%END_]_^__ „PSQRTFR CSY/ B05 P€1_%NAM SQRTFR_'DECK-ID B05 FTN 3.3 RUNTIME_%SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^1_%SPC 2_^1*_]_^1*_]_^1*_*S Q U A R E_!R O O T_!A L G O R I T H M_^1*_-SEE--- MATHEMATICAL METHODS FOR DIGITAL COMPUTERS_^1*_8RALSTON AND WILF, 1960 WILEY (PGS 33-4)_^1*_]_^1*_€€-THE SQUARE ROOT (Y) OF A NUMBER (X) AFTER BEING REDUCED_^1*_-IN THE RANGE (.25,1) WILL BE DONE IN TWO STEPS:_^1*_11. PADE APPROXIMATION_^1*_12. ONE NEWTON-RAPHSON ITERATION_^1*_-THIS WILL GUARANTEE (PG 34 OF REFERENCE) THAT THE_^1*_-ERROR WILL BE LESS THAN 5*10**-8_^1*_]_^1*_********** PADE APPROXIMATION *********************_^1*_]_^1*_+Y1 = 25/7 - ( (5000/343)(X+15/49)/((X+235/49€€)(X+15/49)_^1*_W-400/2401) )_^1*_]_^1*_********** NEWTON-RAPHSON APPROXIMATION ***********_^1*_]_^1*_+Y2 = 1/2( Y1 + X/Y1 )_^1_%SPC 3_^1_%ENT SQRT_)ENTRY POINT FOR SQUARE ROOT FUNCTION_^1_%EXT PARABS_J**MSOS4.1**_^1_%EXT HFLOT_OFTN 3.3_^1_%SPC 3_^1_%EQU ZERO(2)_%LOCATION OF ZERO_^1_%EQU LPMSK(2)_$LOGICAL PRODUCT MASK TABLE_^1_%EQU ZROMSK($13)_!ZERO MASK TABLE_^1_%EQU ONEBIT€€($23)_!ONE BIT TABLE_^1_%EQU ZROBIT($33)_!ZERO BIT TABLE_^1_%SPC 3_^1_%EQU C($C5)_'PSEUDO ACCUMULATOR-MOST SIGNIFICANT HALF_^1_%EQU D($C6)_'PSEUDO ACCUMULATOR-LEAST SIGNIFICANT HALF_^1_%EQU Y1($D8)_%FIRST APPROXIMATION_^1_%EQU SQRRET($DA)_!SQUARE ROOT RETURN ADDRESS_^1_%EQU SQRFLG($DB)_!FLAG - NEGATIVE IF ARGUMENT NEGATIVE_^1_%EQU SQREXP($DC)_!EXPONENT/2 OF ARGUMENT_^1_%E€€QU TEMP($DD)_#TEMPORARY_^1_%EQU ARG($DF)_$ARGUMENT X_^1_%EQU QSAVE($E2)_"SAVED Q-REGISTER_^1_%EJT_]_^1SQRT_!000 000_^1SQT1V4 IIN 0_O**MSOS4.0**_^1_%STQ- QSAVE_(SAVE Q-REGISTER_^1_%LDA* SQRT_)NORMALIZE ADDRESS_1**MSOS4.1**_^1_%RTJ PARABS_J**MSOS4.1''_^1*_]_^1SQRT10 RAO* SQRT_)INCREMENT RETURN_^1_%TRA Q_^1_%EIN 0_^1_%LDA* SQRT_)SAVE RETURN ADDRESS IN FTN AREA_^1_%STA- SQRRET_€€^1_%LDA- (ZERO),Q_$GET ARGUMENT (X)_^1_%LDQ- 1,Q_^1_%STA- SQRFLG_'IF NEGATIVE, SET FLAG AND COMPLEMENT ARGUMENT_^1_%SAP SQRT20_^1_%TCA A_^1_%TCQ Q_^1*_]_^1SQRT20 STA- C_,SAVE ARGUMENT_^1_%STQ- D_^1_%SAN SQRT30_^1_%JMP* SQRRTN_'ARGUMENT ZERO, EXIT_^1*_]_^1SQRT30 ARS 7_,GET EXPONENT AND REMOVE BIAS_^1_%SUB- ONEBIT+7_^1_%ENQ 1_^1_%LAQ Q_^1_%ARS 1_,DIVIDE EXPONENT BY TWO_^1_%SQ€€Z SQRT40_'EXPONENT EVEN- REDUCE ARGUMENT TO 1/2 TO 1_^1_%INA 1_,EXPONENT ODD - REDUCE ARGUMENT TO 1/4 TO 1/2_^1_%LDQ- ZROBIT+8_^1SQRT40 ADQ- ONEBIT+14_^1_%STA- SQREXP_'SAVE EXPONENT/2_^1_%LDA- C_^1_%AND- LPMSK+7_^1_%AAQ A_,ARGUMENT NOW IN PROPER RANGE (1/4 TO 1)_^1_%STA- C_^1*_]_^1FLTCAL RTJ HFLOT_OFTN 3.3_^1_%NUM $BDED_^1_%ADC C_^1_%ADC ARG_*ARG = FLOATING POINT ACCUMULATOR€€ (C,D)_^1_%ADC C1_^1_%ADC TEMP_)TEMP = ARG + 15/49_^1_%NUM $BE98_^1_%ADC ARG_^1_%ADC C2_^1_%ADC TEMP_)Y1 = (ARG + 235/49) * TEMP - 400/2401_^1_%ADC C3_^1_%NUM $DB9A_^1_%ADC Y1_^1_%ADC TEMP_^1_%ADC C4_+Y1 = (TEMP * (-5000/343) / Y1) + 25/7_^1_%ADC Y1_^1_%NUM $EDBA_^1_%ADC C5_^1_%ADC Y1_^1_%ADC ARG_^1_%ADC Y1_^1_%NUM $E9D4_(Y2 = (ARG / Y1 + Y1) * 1/2_^1_%ADC Y1€€_^1_%ADC ONEHLF_^1_%ADC C_^1*_]_^1_%LDA- C_,COMBINE WITH EXPONENT/2_^1_%LDQ- SQREXP_^1_%SQP SQRT50_^1_%INQ -1_+ALLOW FOR PROPER ADD FOR NEGATIVE EXPONENT_^1SQRT50 QLS 7_^1_%AAQ A_^1_%LDQ- SQRFLG_^1_%SQP SQRT60_^1_%LDQ- D_^1_%TCQ Q_,ARGUMENT WAS NEGATIVE, COMPLEMENT ANSWER_^1_%TCA A_^1_%STQ- D_^1SQRT60 STA- C_^1*_]_^1SQRRTN RTJ* (FLTCAL+1)_"PUT IN FLOATING POINT ACCUMULATOR€4_^1_%NUM $B400_^1_%ADC C_^1*_]_^1_%LDQ- QSAVE_(RESTORE Q AND RETURN_^1_%JMP- (SQRRET)_^1_%SPC 2_^1ONEHLF NUM $4040,$0000_!.5_^1C1_#NUM $3F4E,$5E0A_!15/49_^1C2_#NUM $41CC,$BC15_!235/49_^1C3_#NUM $3ED5,$4C3E_!400/2401_=PSR 902_^1C4_#NUM $BD8B,$61C5_!-5000/343_^1C5_#NUM $4172,$4924_!25/7_^1_%END_]_^__4PSIGNR CSY/ B06 P€1_%NAM SIGNR_(DECK-ID B06 FTN 3.3 RUNTIME_%SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^1_%SPC 2_^1_%ENT Q8SG_^1_%ENT SIGN_^1_%EXT PARABS_J**MSOS4.1**_^1_%EXT HFLOT_OFTN 3.3_^1_%EQU TEMP($D5)_^1_%EQU RETADD($D7)_^1Q8SG_!NOP_]_^1_%IIN 0_^1_%LDA* SIGN_^1_%EIN €€0_^1_%STA- RETADD_^1_%STQ- QS_'SAVE Q AND I_^1_%LDA- $FF_^1_%STA- FF_^1_%ENA 0_^1_%STA- $FF_^1S0_#LDA- RETADD_^1_%RTJ PARABS_J**MSOS4.1**_^1_%EIN 0_O**MSOS4.1**_^1S1_#STA- A1,I_$PARAMETER ADDRESSES_^1_%RAO- RETADD_^1_%LDA- $FF_^1_%SAN 2_^1_%RAO- $FF_^1_%JMP* S0_^1_%LDQ- A1_N**MSOS4.0**_^1_%LDA- (ZERO),Q_H**MSOS4.0**_^1_%STA- TEMP_^1_%LDA- 1,Q_M**MSOS4.0**_^1_%STA- TEMP+1_^1_%RT€€J* (S3+1)_"FLOATING LOAD_^1_%NUM $B400_^1_%ADC TEMP_^1_%LDA- (A1)_^1_%LDQ- (A2)_^1_%INA 0_^1_%INQ 0_(ELIMINATE -0_^1_%SQP S2-*-1_^1_%SAP S3-*-1_"CHANGE SIGN OF A1_^1_%JMP* S4_'BOTH NEGATIVE_^1S2_#SAM S3-*-1_^1_%JMP* S4_'BOTH POSITIVE_^1S3_#RTJ HFLOT_OFTN 3.3_^1_%NUM $7400_#COMPLEMENT_^1S4_#LDQ- QS_'RESTORE Q AND I_^1_%LDA- FF_^1_%STA- $FF_^1_%JMP- (RETADD)_$RETURN_^1_%EQU €‚ A1($D8),A2($D9),FF($E1),QS($E2)_^1_%EQU SIGN(Q8SG)_^1_%EQU LPMSK(2),NZERO($12),ZERO($22),ONEBIT($23),ZROBIT($33)_^1_%END_]_^__ ‚PFXFLTR CSY/ B07 P€1_%NAM FXFLTR_'DECK-ID B07 FTN 3.3 RUNTIME_%SUMMARY-102_^1*_$FIX TO FLOAT / FLOAT TO FIX CONVERSION FUNCTION_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT, CONTROL DATA CORPORATION - 1973_^1_%SPC 5_^1_%ENT Q8QFIX_NFTN 3.3_^1_%ENT Q8FX_PFTN 3.3_^1_%ENT Q8QFLT_NFTN 3.3_^1_%ENT Q8FLOT_NFTN 3.3_^1_%ENT IFIX_€€PFTN 3.3_^1_%ENT FLOAT_OFTN 3.3_^1_%ENT DFIX_PFTN 3.3_^1_%ENT Q8DFLT_NFTN 3.3_^1_%ENT DFLT_PFTN 3.3_^1_%SPC 2_SFTN 3.3_^1_%EXT HFLOT_^1_%EXT* PARABS_NFTN 3.3_^1_%SPC 2_SFTN 3.3_^1_%EQU QS($E2)_MFTN 3.3_^1_%EQU CELL1($DA)_JFTN 3.3_^1_%EQU CELL2($DB)_JFTN 3.3_^1_%EQU RETURN($DC)_IFTN 3.3_^1_%EQU ZERO($22)_KFTN 3.3_^1_%EJT_VFTN 3.3_^1*_] FTN 3.3_^1*_$FIX VALUE IN FLOATING€€ POINT ACCUMULATOR_2FTN 3.3_^1*_] FTN 3.3_^1Q8QFIX NOP 0_SFTN 3.3_^1_%IIN 0_^1_%STQ- QS_+SAVE Q REGISTER_7FTN 3.3_^1_%EIN 0_^1_%LDA* Q8QFIX_NFTN 3.3_^1_%STA- RETURN_NFTN 3.3_^1_%JMP* FIX_*GO TO FIX ACCUMULATOR_1FTN 3.3_^1_%SPC 2_SFTN 3.3_^1*_] FTN 3.3_^1*_$FIX VALUE AT PARAMETER ADDRESS_;FTN 3.3_^1*_] FTN 3.3_^1IFIX_!EQU IFIX(*)_MFTN 3.3_^1DFIX_!EQU DFIX(*)_MFTN 3.3_^1Q8FX€€_!NOP 0_SFTN 3.3_^1_%IIN 0_^1_%EIN 0_^1_%LDA* Q8FX_)PICK UP ADDRESS OF PARAMETER_*FTN 3.3_^1_%STA- RETURN_NFTN 3.3_^1_%STQ- QS_+SAVE Q REGISTER_7FTN 3.3_^1_%RTJ PARABS_'ABSOLUTIZE PARAMETER ADDRESS_*FTN 3.3_^1_%RAO- RETURN_'BUMP RETURN ADDRESS_3FTN 3.3_^1_%TRA Q_,ADDRESS OF PARAMETER TO Q_-FTN 3.3_^1_%LDA- (ZERO),Q_LFTN 3.3_^1_%STA- CELL1_OFTN 3.3_^1_%LDA- 1,Q_QFTN 3.3_^1_%STA€€- CELL2_(MOVE PARAMETER TO CELL 2_.FTN 3.3_^1_%RTJ HFLOT_(LOAD CELL1,CELL2 INTO FP ACCUMULATOR_!FTN 3.3_^1FLOTAD EQU FLOTAD(*-1)_IFTN 3.3_^1_%NUM $B400_OFTN 3.3_^1_%ADC CELL1_OFTN 3.3_^1_%SPC 2_SFTN 3.3_^1FIX_"RTJ* (FLOTAD)_$FLOAT TO FIX CONVERSION_/FTN 3.3_^1_%NUM $1400_OFTN 3.3_^1_%ADC CELL1_OFTN 3.3_^1_%LDA- CELL1_(RETURN RESULT IN ACCUMULATOR_*FTN 3.3_^1_%LDQ- QS_RFTN 3.€€3_^1_%JMP- (RETURN)_$RETURN TO CALLER_6FTN 3.3_^1_%EJT_VFTN 3.3_^1*_] FTN 3.3_^1*_$CONVERT A REG TO FLOATING POINT. RETURN RESULT IN FP ACCUMFTN 3.3_^1*_] FTN 3.3_^1Q8DFLT EQU Q8DFLT(*)_KFTN 3.3_^1Q8QFLT NOP 0_SFTN 3.3_^1_%IIN 0_^1_%STA- CELL1_(SAVE VALUE TO BE FLOATED_.FTN 3.3_^1_%EIN 0_^1_%LDA* Q8QFLT_NFTN 3.3_^1_%STA- RETURN_'SAVE RETURN ADDRESS_3FTN 3.3_^1_%STQ- QS_+SAVE €€Q REGISTER_7FTN 3.3_^1_%JMP* FLT_QFTN 3.3_^1_%SPC 2_SFTN 3.3_^1*_] FTN 3.3_^1*_$CONVERT VALUE AT PARAMETER ADDRESS TO FLOATING POINT_$FTN 3.3_^1*_] FTN 3.3_^1FLOAT EQU FLOAT(*)_LFTN 3.3_^1DFLT_!EQU DFLT(*)_MFTN 3.3_^1Q8FLOT NOP 0_SFTN 3.3_^1_%IIN 0_^1_%EIN 0_^1_%LDA* Q8FLOT_NFTN 3.3_^1_%STA- RETURN_NFTN 3.3_^1_%STQ- QS_+SAVE Q REGISTER_7FTN 3.3_^1_%RTJ PARABS_^1_%TRA Q_S€:FTN 3.3_^1_%LDA- (ZERO),Q_$PICK UP PARAMETER_5FTN 3.3_^1_%STA- CELL1_OFTN 3.3_^1_%RAO- RETURN_'BUMP RETURN ADDRESS_3FTN 3.3_^1_%SPC 2_SFTN 3.3_^1FLT_"RTJ* (FLOTAD)_$FLOAT CELL1_;FTN 3.3_^1_%NUM $2400_OFTN 3.3_^1_%ADC CELL1_OFTN 3.3_^1_%LDQ- QS_RFTN 3.3_^1_%JMP- (RETURN)_$RETURN TO CALLER_6FTN 3.3_^1_%END_]_^__:PEXPR CSY/ B08 P€1_%NAM EXPR_)DECK-ID B08 FTN 3.3 RUNTIME_%SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^1_%SPC 2_^1_%ENT EXP_^1_%EXT PARABS_J**MSOS4.1**_^1_%EXT HFLOT_OFTN 3.3_^1_%EXT* SFALT_OFTN 3.3_^1_%EQU C($C5),D($C6)_!PSEUDO ACCUMULATOR_^1_%EQU Y($D8),RETEXP($DA),FLAG($DB)€€,N($DC)_^1_%EQU MK4000($31)_IFTN 3.3_^1_%EQU MK7FFF($11)_IFTN 3.3_^1_%EQU MK007F($09)_IFTN 3.3_^1_%EQU QS($E1)_^1_%EQU LPMSK(2),NZERO($12),ZERO($22),ONEBIT($23),ZROBIT($33)_^1EXP_"NUM 0_^1EXP1V4 IIN 0_+INHIBIT FOR PROPER OPERATION_'**MSOS4.0**_^1_%STQ- QS_'SAVE Q_^1_%EIN 0_^1_%LDA* EXP_M**MSOS4.1**_^1_%STA- RETEXP_^1_%RTJ PARABS_'NORMALIZE ADDRESS_1**MSOS4.1''_^1_%EIN 0_O€€**MSOS4.1''_^1_%TRA Q_O**MSOS4.0**_^1_%LDA- (ZERO),Q_H**MSOS4.0**_^1_%STA- C_^1_%LDA- 1,Q_M**MSOS4.0**_^1_%STA- D_^1_%RAO- RETEXP_^1_%RTJ* (EXPN4+1)_#CALL FLOT_^1_%NUM $BD40_(LOAD, SOTRE_;FTN 3.3_^1_%ADC C_^1_%ADC C_SFTN 3.3_^1_%LDA- C_^1_%ENQ 0_^1_%SAP EXP1-*-1_^1_%RTJ* (EXPN4+1)_$COMPLEMENT_^1_%NUM $7D40_OFTN 3.3_^1_%ADC C_SFTN 3.3_^1_%ENQ 1_^1_%LDA- C_^1EXP1_!STQ- FLAG_€€^1_%SAN EXP2-*-1_^1_%RTJ* (EXPN4+1)_$ARGUMENT IS ZERO_^1_%NUM $5B40_^1_%ADC COEXP-*_3LDA 1.0_^1_%JMP* EXP7_*GO TO EXIT_^1LN2OV2 NUM $3FD8_^1MAXEXP NUM $43D8,$0799_'88.02968_^1EXP2_!SUB* LN2OV2_^1_%SAM EXP25-*-1_$LESS THAN LN2/2_^1_%SAN EXP3-*-1_#GREATER THAN LN2/2_^1_%LDA- D_-FIRST PART IS EQUAL_^1_%SUB* LN2OV2-1_%SECOND PART_^1_%SAM EXP25-*-1_$LESS_^1_%SAN EXP3-*-1_%GREAT€€ER_^1EXP25 ENA 0_-EQUAL_^1_%STA- N_^1_%JMP* EXP5_^1EXP3_!LDA- C_^1_%SUB* MAXEXP_(MAX. VALUE PERMISSIBLE_^1_%SAM 3_(O.K._^1_%SAN EXP35-*-1_#TOO BIG_^1_%LDA- D_^1_%SUB* MAXEXP+1_%SECOND PART OF MAX._^1_%SAM EXP4-*-1_"O.K._^1_%SAZ EXP4-*-1_^1EXP35 LDA- FLAG_$SET PROPER ERROR FLAG_^1_%LDQ- ONEBIT+14_#$4000_^1_%ENQ $22_QFTN 3.3_^1_%SAZ EXP36_OFTN 3.3_^1_%INQ 2_SFTN 3.3_^1EXP36€€ STQ* EXP37_OFTN 3.3_^1_%RTJ SFALT_(SET APPROPRIATE FAULT CONDITION_'FTN 3.3_^1EXP37 NUM 0_SFTN 3.3_^1_%ENA -0_^1_%STA- D_^1_%LDA- MK7FFF_NFTN 3.3_^1_%JMP* EXP55_^1EXP4_!RTJ* (EXPN4+1)_^1_%NUM $5A5D_^1_%ADC LN2EXP-*_%FDV LN2_^1_%ADC Y_-STA Y_^1_%NUM $5E5D_^1_%ADC C1EXP-*_((U/LN2)+1/2_^1_%ADC C_-STA C_^1_%NUM $4000_^1_%LDA* MK7F80_^1_%AND- C_-KEEP EXPONENT_^1_%SUB- MK400€€0_'REMOVE BASE._:FTN 3.3_^1_%ARS 7_-RIGHT JUSTIFIED_^1_%TRA Q_^1_%LDA- C_^1_%LDQ* MK7F80,Q_^1_%LAQ A_^1_%STA- C_$KEEP ONLY INTEGRAL PART_^1_%TCQ Q_^1_%AND- MK007F_NFTN 3.3_^1_%QLS 9_^1EXPN2 SQM EXPN3-*-1_^1_%LLS 1_^1_%JMP* EXPN2_^1MK7F80 NUM $7F80_^1_%NUM $7FC0_^1_%NUM $7FE0_^1_%NUM $7FF0_^1_%NUM $7FF8_^1_%NUM $7FFC_^1MK7FFE NUM $7FFE_^1_%NUM $7FFF_^1EXPN3 STA- N_.€€INTEGRAL PART IN FIX NOTATION_^1_%ENA 0_^1_%STA- D_^1EXPN4 RTJ HFLOT_OFTN 3.3_^1_%NUM $B7E5_^1_%ADC C_9LDA C_^1_%ADC Y_^1_%NUM $9400_^1_%ADC LN2EXP-*_^1EXP5_!RTJ* (EXPN4+1)_^1_%NUM $D59E_^1_%ADC Y_^1_%ADC C5EXP-*_'Y*C5_^1_%ADC C4EXP-*_'Y*C5+C4_^1_%NUM $595E_^1_%ADC Y_^1_%ADC C3EXP-*_'((Y*C5+C4)*Y+C3_^1_%NUM $595E_^1_%ADC Y_^1_%ADC C2EXP-*_'((Y*C5+C4)*Y+C3)*Y+C2_^1€€_%NUM $595E_^1_%ADC Y_^1_%ADC C1EXP-*_1+C1_^1_%NUM $595E_^1_%ADC Y_^1_%ADC COEXP-*_,+CO_^1_%NUM $595E_^1_%ADC Y_^1_%ADC COEXP-*_^1_%NUM $5D40_^1_#ADC C_$(((((Y*C5+C4)*Y+C3)*Y+C2)*Y+C1)*Y+_^1*_BCO)*Y+CO_^1_%LDA- C_^1_%ADD- N_-ADD INTEGRAL PART_^1EXP55 STA- C_^1_%RTJ* (EXPN4+1)_#CALL FLOT_^1_%NUM $B400_^1_%ADC C_9LDA C_^1_%LDA- FLAG_^1_%SAZ EXP7-*-1_^1EXP6_!RTJ* (EXPN4€€+1)_$ARG. WAS NEGATIVE_^1_%NUM $D5B5_^1_%ADC Y_^1_%ADC COEXP-*_'LDA 1.0_^1_%NUM $A400_^1_%ADC Y_-FDV Y_^1EXP7_!LDQ- QS_'RESTORE Q_^1_%JMP- (RETEXP) JMP* (EXP)_^1C1EXP NUM $4040,0_'0.5_^1C2EXP NUM $3ED5,$5556_"0.166666---6_^1C3EXP NUM $3DD5,$5556_"0.0416----7_^1C4EXP NUM $3CC4,$4444_"0.008333---3_^1C5EXP NUM $3B5B,$05B0_'.0013888889_^1COEXP NUM $40C0,0_%1.0_?**MSOS€F4.0**_^1LN2EXP NUM $4058,$B90C_!.69314718_9**MSOS4.0**_^1_%END_]_^__ FPALOGR CSY/ B09 P€1_%NAM ALOGR_(DECK-ID B09 FTN 3.3 RUNTIME_%SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALFIORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^1_%SPC 2_^1_%ENT ALOG_^1_%EXT PARABS_J**MSOS4.1**_^1_%EXT HFLOT_OFTN 3.3_^1_%EXT* SFALT_OFTN 3.3_^1_%EQU C($C5),D($C6)_!PSEUDO ACCUMULATOR_^1_%EQU_#LNRET($D8),X($D9),X2($DB),€€N($DD)_^1_%EQU QS($E1)_^1_%EQU LPMSK(2),NZERO($12),ZERO($22),ONEBIT($23),ZROBIT($33)_^1_%EQU MK7FFF($11),MK007F($9),MK4000($31),MKFFFF($12)_%FTN 3.3_^1_%EQU MK0080($2A),MKFF80($19)_=FTN 3.3_^1ALOG_!NUM 0_^1ALG1V4 IIN 0_,INHIBIT FOR PROPER OPERATION_%**MSOS4.0**_^1_%STQ- QS_'SAVE Q_^1_%EIN 0_^1_%LDA* ALOG_)**NORMALIZE PARAMETER ADDRESS**_"**MSOS4.1**_^1_%STA- LNRET_^1_%RTJ P€€ARABS_J**MSOS4.1**_^1_%EIN 0_O**MSOS4.1**_^1_%RAO- LNRET_^1_%TRA Q_O**MSOS4.0**_^1_%LDA- (ZERO),Q_H**MSOS4.0**_^1_%STA- C_^1_%LDA- 1,Q_M**MSOS4.0**_^1_%STA- D_^1_%RTJ* (LNU7+1)_^1_%NUM $BD40_OFTN 3.3_^1_%ADC C_^1_%ADC C_SFTN 3.3_^1_%LDA- C_^1_%SAM 1_^1_%JMP* LNU2_^1REQ_"RTJ SFALT_(SET FAULT_=FTN 3.3_^1_%ADC ZERO_PFTN 3.3_^1_%LDA- MK7FFF_'ANSWER_@FTN 3.3_^1_%STA- C_/IS MADE_€€^1_%ENA -0_^1_%JMP* LNU27_%GO TO EXIT_^1LNU2_!SAN 1_^1_%JMP* REQ_#ARG IS ZERO_^1_%LDA- C_^1_%SUB =N$40C0_^1_%SAN LNU25-*-1_^1_%LDA- D_^1_%SAN LNU25-*-1_^1_%ENA 0_^1_%STA- C_^1LNU27 STA- D_^1_%JMP* LNURET_(GO TO EXIT_^1LNU25 LDA- MKFF80_'KEEP EXPONENT_9FTN 3.3_^1_%AND- C_^1_%SUB- MK4000_'REMOVE BASE_;FTN 3.3_^1_%SAN LNU3-*-1_^1_%STA-_"N+1_(= 0, N,N+1 =0_^1_%JMP* LNU65_^1LNU€€3_!ENQ 0_^1_%SAP LNU4-*-1_^1_%LDQ- MKFFFF_'EXP. WAS LESS THAN ZERO_/FTN 3.3_^1_%TCA A_-COMPLEMENT DIFFERENCE_^1_%SUB- MK0080_'-1. SHOULD HAVE BEEN 3F80_-FTN 3.3_^1LNU4_!STQ-_"N+1_(STORE SIGN OF EXP._^1_%LDQ- MK4000_'BASE FOR NEW EXPONENT._0FTN 3.3_^1LNU45 ADQ- MK0080_NFTN 3.3_^1_%ARS 1_-SHIFT OLD EXP._^1_%STA-_"N_^1_%AND- MKFF80_NFTN 3.3_^1_%SAZ LNU5-*-1_^1_%LDA-_"N_*SHIFT NO€€T COMPLETED_^1_%JMP* LNU45_^1LNU5_!LDA-_"N_*SHIFTED EXP._^1_%AAQ A_-ADD BASE_^1LNU6_!LDQ-_"N+1_^1_%SQP 1_^1_%TCA A_#COMPLEMENT FOR NEG. EXP._^1LNU65 STA-_"N_*N,N+1 IS NOW IN FLOATING_^1_%LDA- C_^1_%AND- MK007F_'REMOVE EXPONENT._6FTN 3.3_^1_%ADD- MK4000_NFTN 3.3_^1_%STA- C_"C,D IS NOW M_^1LNU7_!RTJ HFLOT_OFTN 3.3_^1_%NUM_#$BD5E_^1_%ADC C_^1_%ADC X_)X=M_,STA X_^1_%ADC SQ2OV2-€€*_2FAD_^1_%NUM_#$5DB5_^1_%ADC X2_(X2=M+SQ2O2_$STA X2_^1_%ADC X_9LDA X_^1_%NUM_#$85AD_^1_%ADC SQ2OV2-*_'M-SQ2OV2_!FSB_^1_%ADC X2_8FDV X2_^1_%ADC X_9STA X_^1_%NUM_#$9D59_^1_%ADC X_9FMU X_^1_%ADC X2_8STA X2_^1_%ADC C2LNU-*_(C2*X2_$FMU C2_^1_%NUM_#$E595_^1_%ADC C1LNU-*_-+C1_!FAD C1_^1_%ADC X2_$(C2*X2+C1)*X2_$FMU X2_^1_%NUM_#$E59D_^1_%ADC COLNU-*_$+CO_*FAD CO_^1_%ADC X_9FMU €€X_^1_%ADC X_$PARTIAL ANSWER_$STA X_^1_%NUM_#$B589_^1_%ADC N_9LDA N_^1_%ADC HALF-*_4FSB 1/2_^1_%ADC LN2-*_5FMU LN(2)_^1_%NUM_#$5ED4_^1_%ADC X_9FAD X_^1_%ADC_#C_*STA C_^1LNURET RTJ*_"(LNU7+1)_$CALL FLOT_^1_%NUM_#$B400_^1_%ADC_#C_*LDA C_^1_%LDQ- QS_'RESTORE Q_^1_%JMP-_"(LNRET)_!****_!JMP* (ALOG)_^1SQ2OV2 NUM $405A,$8279_^1LN2_"NUM $4058,$B90C_"LN(2)_^1HALF_!NUM $4040,0_^1COLNU€x NUM $4140,$0001_!2.0000008_^1C1LNU NUM $4055,$4E3C_$0.66645003_^1C2LNU NUM $3F6A,$2B00_$0.41471862_^1_%END_]_^__ xPTANHR CSY/ B10 P€1_%NAM TANHR_(DECK-ID B10 FTN 3.3 RUNTIME_%SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^1_%SPC 2_^1_%ENT TANH_^1_%EXT EXP_^1_%EXT HFLOT_OFTN 3.3_^1_%EXT PARABS_J**MSOS4.1**_^1_%SPC 2_^1_%EQU RETURN($D5)_^1_%SPC 2_^1TANH_!NOP_]_^1TNH1V4 IIN 0_,INHIBIT FOR PRO€€PER OPERATION_%**MSOS4.0**_^1_%EIN 0_,OF PROTECT PROCESSOR._^1_%LDA* TANH_)**NORMALIZE PARAMETER ADDRESS_$**MSOS4.1**_^1_%STA- RETURN_^1_%RAO- RETURN_^1_%RTJ PARABS_J**MSOS4.1**_^1_%EIN 0_O**MSOS4.1**_^1T0_#STQ- QS_'SAVE Q_^1_%TRA Q_^1_%LDA- (ZERO),Q_^1_%SAN T2-*-1_^1_%RTJ* (T9+1)_"FLOATING LOAD_^1_%NUM $5B54_#TANH(0) = 0_^1_%ADC X1+1-*_^1_%JMP* T8_^1T2_#STA- SIGN_^1_%INQ 1€€_^1_%LDA- (ZERO),Q_^1_%STA- X+1_^1_%LDA- SIGN_^1_%SAP T3-*-1_^1_%TCA A_^1T3_#SUB* TEN_%FLOATING POINT 10.0_^1_%SAM T4-*-1_^1_%RTJ* (T9+1)_"TANH(10.)= 1.0_^1_%NUM $5B54_^1_%ADC X1-*_^1_%LDQ- SIGN_^1_%SQP 2_^1_%RTJ* (T9+1)_"TANH(-10.) = -1.0_^1_%NUM $7400_^1_%JMP* T8_^1T4_#LDA- SIGN_^1_%STA- X_^1_%SAP 1_^1_%TCA A_^1_%SUB =N$3F40_!0.25 DECIMAL_^1_%SAP 1_^1_%JMP* T10_%USE SE€€RIES_^1_%LDA- SIGN_^1_%SAP T7-*-1_^1_%SUB- ONEBIT+7_$$0080 INCREMENT EXPONENT GIVES 2*X._^1_%JMP* T7+1_^1TEN_"NUM $4250_^1T7_#ADD- ONEBIT+7_$$0080_^1_%STA- X_^1_%RTJ EXP_%EXP(2*X)_^1_%ADC X_(ABSOLUTE ADDRESS_^1_%RTJ* (T9+1)_^1_%NUM $D400_^1_%ADC X_^1T9_#RTJ HFLOT_OFTN 3.3_^1_%NUM $B5E5_#T1 = EXP(2*X) + 1.0_^1_%ADC X,X1-*_^1_%NUM $D5B5_#TANH = 1.0 - 2.0/T1_^1_%ADC T1,X2-€€*_^1_%NUM $A5E5_^1_%ADC T1,X1-*_^1_%NUM $4000_^1T8_#LDQ- QS_'RESTORE Q_^1_%JMP- (RETURN)_^1T10_"RTJ* (T9+1)_^1_%NUM $BD9D_^1_%ADC X,SUM,X,XS_^1_%NUM $4000_^1_%ENA 0_^1T11_"STA- J_^1_%RTJ* (T9+1)_"P = P*XS_^1_%NUM $B9DF_^1_%ADC XS,P,P,J_^1_%NUM $5956_^1_%ADC A-*_^1_%NUM $ED40_^1_%ADC SUM,SUM_^1_%LDA- J_^1_%INA -3_RFTN 3.3_^1_%SAZ 2_^1_%INA 4_SFTN 3.3_^1_%JMP* T11_^1_€€%JMP* T8_^1X1_#NUM $40C0_K**MSOS4.0**_^1_%NUM $0000_K**MSOS4.0**_^1_%NUM $0000_K**MSOS4.0**_^1X2_#NUM $BEBF_K**MSOS4.0**_^1_%NUM $FFFF_K**MSOS4.0**_^1A_$NUM $C0AA,$AABB_!-.33333227 X**3_^1_%NUM $3EC4,$4965_$.13337246_"X**5_^1_%NUM $C212,$A8FC_!-.053388615 X**7_^1_%NUM $3D68,$F92C_$.025628253_!X**9_^1_%EQU QS($E2),T1($D8),XS($DA),X($DD),SIGN($DF)_^1_%EQU J(SIGN),SUM(T1),€RP(X)_^1_%EQU LPMSK(2),NZERO($12),ZERO($22),ONEBIT($23),ZROBIT($33)_^1_%END_]_^__ RPSNCSR CSY/ B11 P€1_%NAM SNCSR_(DECK-ID B11 FTN 3.3 RUNTIME_%SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^1_%SPC 2_^1_%ENT SIN_^1_%ENT COS_^1_%EXT PARABS_J**MSOS4.1**_^1_%EXT HFLOT_OFTN 3.3_^1_%EXT* SFALT_OFTN 3.3_^1_%EQU C($C5),D($C6)_!PSEUDO ACCUMULATOR_^1_%EQU_#FLAG($D8),RETA€€DD($D9),X($DA),X2($DC)_^1_%EQU ZERO($22)_G**MSOS4.0**_^1_%EQU QS($E2)_^1COS_"NUM 0_%COS(U) ENTRY_^1COS1V4 IIN 0_,INHIBIT FOR PROPER OPERATION_%**MSOS4.0**_^1_%STQ- QS_'SAVE Q_^1_%EIN 0_^1_%LDA* COS_***NORMALIZE PARAMATER ADDRESS**_"**MSOS4.1**_^1_%STA- RETADD_^1_%RAO- RETADD_^1GOABS RTJ PARABS_J**MSOS4.1**_^1_%EIN 0_O**MSOS4.1**_^1_%TRA Q_O**MSOS4.0**_^1_%LDA- (ZERO),Q_H**M€€SOS4.0**_^1_%STA- C_^1_%LDA- 1,Q_M**MSOS4.0**_^1_%STA- D_^1COS6_!RTJ* (SIN9+1)_%CALL FLOT_^1_%NUM $B5E5_^1_%ADC C_^1_%ADC PIOV2-*_'ARG+PI/2_"FAD_^1_%NUM $D400_^1_%ADC C_*STA C_^1_%JMP* SIN1_^1MKFFFF NUM $FFFF_^1_%NUM $FFFE_^1_%NUM $FFFC_^1_%NUM $FFF8_^1_%NUM $FFF0_^1_%NUM $FFE0_^1_%NUM $FFC0_^1MKFF80 NUM $FF80_^1_%NUM $FF00_^1_%NUM $FE00_^1_%NUM $FC00_^1_%NUM $F800€€_^1_%NUM $F000_^1_%NUM $E000_^1_%NUM $C000_^1_%NUM $8000_^1MK7FFF NUM $7FFF_^1SIN_"NUM 0_%SIN(U) ENTRY_^1SIN1V4 IIN 0_,IHIBIT FOR PROPER OPERATION_'**MSOS4.0**_^1_%STQ- QS_'SAVE Q_^1_%EIN 0_^1_%LDA* SIN_***NORMALIZE PARAMETER ADDRESS**_"**MSOS4.1**_^1_%STA- RETADD_^1_%RAO- RETADD_^1_%RTJ* (GOABS+1)_G**MSOS4.1**_^1_%EIN 0_O**MSOS4.1**_^1_%TRA Q_O**MSOS4.0**_^1_%LDA- (ZERO)€€,Q_H**MSOS4.0**_^1_%STA- C_^1_%LDA- 1,Q_M**MSOS4.0**_^1_%STA- D_^1_%RTJ* (SIN9+1)_^1_%NUM $BD40_OFTN 3.3_^1_%ADC C_^1_%ADC C_SFTN 3.3_^1*_"COMMON TO BOTH_^1SIN1_!LDA- C_^1_%ENQ 0_^1_%SAP SIN2-*-1_!ARG IS POS._^1_%RTJ* (SIN9+1)_#COMPLEMENT_^1_%NUM $7D40_OFTN 3.3_^1_%ADC C_SFTN 3.3_^1_%ENQ 1_^1_%LDA- C_^1SIN2_!SAN SIN3-*-1_^1SIN2A STA- C_SFTN 3.3_^1SIN2B STA- D_SFTN 3.3_^1€€_%JMP* SIN19_^1SIN3_!STQ-_"FLAG_^1_%SUB*_"TWOPI_^1_%SAM SIN4-*-1 LESS_^1_%SAN SIN5-*-1 GREATER_^1_%LDA- D_^1_%SUB*_"TWOPI+1_^1_%SAM SIN4-*-1_!LESS_^1_%SAN SIN5-*-1_!GREATER_^1_%JMP* SIN2A_(EQUAL_AFTN 3.3_^1MAXVAL NUM $4B40_#2**21_^1SIN4_!JMP* SIN12_^1SIN5_!LDA- C_^1_%SUB* MAXVAL_(MAX. PERMISSIBLE_^1SIN8_!SAM SIN9-*-1_%O.K._^1_%RTJ SFALT_(SET OVERFLOW FAULT_4FTN 3.3_^1_%ADC€€ ZERO_PFTN 3.3_^1_%LDA* MK7FFF_^1_%STA- C_^1_%ENA -0_^1_%JMP* SIN2B_OFTN 3.3_^1SIN9_!RTJ HFLOT_OFTN 3.3_^1_%NUM_#$D5A5_^1_%ADC X_#X=ARG_/STA X_^1_%ADC TWOPI-*_+X/2PI_!FDV 2*PI_^1_%NUM_#$D400_^1_%ADC_#C_*STA C_^1_%LDA- C_^1_%AND* MKFF80_(KEEP EXPONENT_^1_%SUB* MK4000_(REMOVE BASE_^1_%ARS 7_*RIGHT JUSTIFIED_^1_%TCA A,Q_^1_%INA 7_^1_%SAP SIN10-*-1_#= OR LESS THAN 7_^1_%INQ 7€€_^1_%LDA- D_^1_%AND* MK7FFF,Q_%GET MASK ACCORDING TO EXP._^1_%JMP* SIN11_^1SIN10 LDA- C_-LESS OR =_^1_%AND* MKFF80,Q_^1_%STA- C_^1_%ENA 0_^1SIN11 STA- D_-C,D INTEGRAL PART OF DIVISION_^1_%RTJ* (SIN9+1)_'CALL FLOT_^1_%NUM_#$B759_^1_%ADC_#C_*LDA C_^1_%ADC TWOPI-*_3FMU 2*PI_^1*_"7 = COMPLEMENT PSEUDO ACCUMULATOR_^1_%NUM $5ED4_^1_%ADC X_9FAD X_^1_%ADC C_*STA C_^1SIN12 LDA- C_€€)(C,D) LESS OR = 2*PI_^1_%SUB* PI_^1_%SAM SIN14-*-1 LESS THAN PI_^1_%SAN SIN13-*-1 GREATER_^1_%LDA- D_^1_%SUB* PI+1_^1_%SAM SIN14-*-1 LESS_^1_%SAN 1_'GREATER_^1_%JMP* SIN2A_(EQUAL_AFTN 3.3_^1SIN13 RTJ* (SIN9+1)_%CALL FLOT_^1_%NUM_#$585D_^1_%ADC PI-*_,X-PI_$FSB PI_^1_%ADC_#C_*STA C_^1MK4000 NUM $4000_^1_%ENA 1_^1_%EOR- FLAG_*CHANGE TO_^1_%STA- FLAG_,OPPOSITE VALUE_^1SIN14 L€€DA- C_^1_%SUB* PIOV2_^1_%SAM SIN145-*-1_!LESS_^1_%SAN SIN15-*-1_#GREATER_^1_%LDA- D_^1_%AND- $13_*($FFFE)_=47*835_^1_%SUB* PIOV2+1_^1SIN145 SAM SIN16-*-1_#LESS_^1_%SAN SIN15-*-1_#GREATER_^1_%LDA* COSIN_(EQUAL_^1_%STA- C_^1_%ENA 0_^1_%STA- D_^1_%JMP* SIN17_#GO TEST FLAG_^1SIN15 RTJ* (SIN9+1)_%CALL FLOT_^1_%NUM $B57E_OFTN 3.3_^1_%ADC C_SFTN 3.3_^1*_)COMPLEMENT PSEUDO ACCUMUL€€ATOR_^1_%ADC PI-*_)PI-(C,D)_#FAD PI_^1_%NUM $4000_OFTN 3.3_^1SIN16 RTJ* (SIN9+1)_(CALL FLOT_^1_%NUM_#$D9D5_^1_%ADC X_9STA X_^1_%ADC X_9FMU X_^1_%ADC X2_*X2=X*X_'STA X2_^1_%NUM_#$9E59_^1_%ADC C4SIN-*_%C4*X2_'FMU C4_^1_%ADC C3SIN-*_'+C3_(FAD C3_^1_%ADC X2_#(C4*X2+C3)*X2_%FMU X2_^1_%NUM_#$5E59_^1_%ADC C2SIN-*_)+C2_%FAD C2_^1_%ADC X2_"((C4*X2+C3)X2+C2)X2 FMU_^1_%NUM_#$5E59_€€^1_%ADC C1SIN-*_'((C4*X2+C3)X2+C2)X2+C1_^1_%ADC X2_((((C4*X2+C3)X2+C2)X2+C1)X2_^1_%NUM_#$5E59_^1_%ADC COSIN-*_3FAD CO_^1_%ADC X_9FMU X_^1_%NUM_#$D400_^1_%ADC_#C_*STA C_^1SIN17 LDA-_"FLAG_^1_%SAZ SIN19-*-1_^1_%RTJ* (SIN9+1)_"COMPLEMENT_^1_%NUM $7D40_OFTN 3.3_^1_%ADC C_SFTN 3.3_^1SIN19 RTJ* (SIN9+1)_^1_%NUM $B400_^1_%ADC C_^1_%LDQ- QS_'RESTORE Q_^1_%JMP-_"(RETADD)_(RETURN € TO CALLER_^1PIOV2 NUM $40E4,$87ED_^1PI_#NUM $4164,$87ED_^1TWOPI NUM $41E4,$87ED_^1COSIN NUM $40C0,0_'1.0_^1C1SIN NUM $C12A,$AAB1_!-0.16666647_^1C2SIN NUM $3CC4,$4353_"8.3328836E-3_^1C3SIN NUM $C618,$31CA_!-0.19799327E-3_^1C4SIN NUM $36D6,$C360_"0.5857445 E-6_^1_%END_]_^__ PATANR CSY/ B12 P€1_%NAM ATANR_(DECK-ID B12 FTN 3.3 RUNTIME_%SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^1_%SPC 2_^1_%ENT ATAN_^1_%EXT PARABS_^1_%EXT HFLOT_OFTN 3.3_^1_%EQU C($C5),D($C6)_!PSEUDO ACCUMULATOR_^1_%EQU SIGN($C7)_^1_%EQU_#ARCFLG($D8),ARCRET($D9),X($DA)_^1_%EQU X2($€€DC),AF($DE),BF($E0)_9**MSOS4.0**_^1_%EQU QS($E2)_^1_%EQU LPMSK(2),NZERO($12),ZERO($22),ONEBIT($23),ZROBIT($33)_^1ATAN_!NUM 0_^1ATN1V4 IIN 0_,INHIBIT FOR PROPER OPERATION_%**MSOS4.0**_^1_%STQ- QS_'SAVE Q_^1_%EIN 0_^1_%LDA* ATAN_)**NORMALIZE PARAMETER ADDRESS*_#**MSOS4.1**_^1_%STA- ARCRET_^1_%RAO- ARCRET_^1_%RTJ PARABS_J**MSOS4.1**_^1_%EIN 0_O**MSOS4.1**_^1_%RAO* ATAN_^1_%TRA €€Q_O**MSOS4.0**_^1_%LDA- (ZERO),Q_H**MSOS4.0**_^1_%STA- C_^1_%LDA- 1,Q_M**MSOS4.0**_^1_%STA- D_^1_%LDA* ATAN_'****_^1_%STA-_"ARCRET_'****_^1_%RTJ* (ARCT6+1)_^1_%NUM $BD40_OFTN 3.3_^1_%ADC C_^1_%ADC C_SFTN 3.3_^1_%LDA- C_^1_%SAP ARCT1-*-1_^1_%RTJ* (ARCT6+1) CALL FLOT_^1_%NUM $7D40_OFTN 3.3_^1_%ADC C_SFTN 3.3_^1_%ENQ 1_^1_%JMP* ARCT2_^1ARCT1 ENQ 0_^1_%SAN ARCT2-*-1_^1_%STQ- €€C_-ARG. = 0_^1_%STQ- D_)ANSWER =0_^1_%JMP* ARCT10_^1PIOV2 NUM 0,0_^1_%NUM $40E4,$87ED_^1ARCT2 STQ-_"ARCFLG_^1_(LDA- C_^1_%SUB =N$3C51_!DECIMAL 0.005_^1_%SAP 1_^1_%JMP* ART8_PFTN 3.3_^1_%ENQ 0_'TO SELECT 1.0 AND 0_^1_%LDA- C_^1_%SUB* ONE_#40C0_^1_%SAM ARCT4-*-1 LESS THAN ONE_^1_%SAN ARCT3-*-1_^1_%LDA- D_^1_%SAZ ARCT4-*-1_"= TO ONE_^1ARCT3 RTJ* (ARCT6+1)_^1_%NUM $BD5B_^1€€_%ADC C_^1_%ADC X_%STORE PSEUDO ACCUMULATOR_^1_%ADC ONE-*_5LDA 1.0_^1_%NUM $5A40_^1_%ADC X_(1/X_-FDV X_^1_%ENQ 2_)SELECT -1.0 AND PI/2_^1ARCT4 LDA* ONE,Q_^1_%STA-_"BF_^1_%LDA* ONE+1,Q_^1_%STA-_"BF+1_$SET 1 OR -1_^1_%LDA-_"ARCFLG_^1_%AAQ A_^1_%STA-_"ARCFLG_^1_%LDA* PIOV2,Q_^1_%STA-_"AF_^1_%LDA* PIOV2+1,Q_^1_%STA-_"AF+1_'0 OR PI/2_^1ARCT5 RTJ* (ARCT6+1)_#FLOT ROUTINE_^1_%NUM€€ $D585_OFTN 3.3_^1_%ADC X_SFTN 3.3_^1_%ADC TANPI8-*_LFTN 3.3_^1_%NUM $D400_OFTN 3.3_^1_%ADC C_SFTN 3.3_^1_%ENQ 1_SFTN 3.3_^1_%LDA- C_^1_%SAZ 1_SFTN 3.3_^1_%SAP 1_^1_%ENQ 0_-LESS OR = TAN(PI/8)_^1_%STQ-_"X2_)SAVE INDEX_^1ARCT6 RTJ HFLOT_OFTN 3.3_^1_%NUM $F5B6_^1_%ADC X2_*INDEX_^1_%ADC PI16-*_"LDA PI16,IND_^1_%NUM $59ED_^1_%ADC BF_8FMU_^1_%ADC AF_8FAD_^1_%ADC AF_8ST€€A_^1_%NUM $F5B6_^1_%ADC X2_*INDEX_^1_%ADC TAN16-*_!LDA TAN16,IND_^1_%NUM $5D95_^1_%ADC BF_8LDA_^1_%ADC X_9FMU_^1_%NUM $E5DB_^1_%ADC ONE-*_5FAD 1.0_^1_%ADC X2_8STA_^1_%ADC X_9LDA_^1_%NUM $8AD9_^1_%ADC BF_8FAD_^1_%ADC X2_8FDV X2_^1_%ADC X_9STA X_^1_%ADC X_9FMU X_^1_%NUM $D59E_^1_%ADC X2_8STA X2_^1_%ADC C2-*_6FMU C2_^1_%ADC C1-*_6FAD C1_^1_%NUM $595E_^1_%ADC X2 (€€C2*X2+C1)*X2_)FMU X2_^1_%ADC CO-*_"(C2*X2+C1)*X2+CO_!FAD CO_^1_%NUM $59D4_^1_%ADC X_9FMU X_^1_%ADC C_*STA C_^1_%LDA-_"ARCFLG_^1_%INA -2_^1_%SAM ART7-*-1_^1_%STA-_"ARCFLG_^1_%RTJ* (ARCT6+1) CALL FLOT_^1_%NUM $7D40_^1_%ADC C_^1ART7_!RTJ* (ARCT6+1) CALL FLOT_^1_%NUM $BED4_^1_'ADC C_)LDA C_^1_%ADC AF_8FAD_^1_%ADC_#C_*STA C_^1ART8_!LDA-_"ARCFLG_KFTN 3.3_^1_%SAZ ARCEND-*-1_^€€1_%RTJ* (ARCT6+1) CALL FLOT_^1_%NUM $7D40_^1_%ADC C_^1ARCT10 RTJ* (ARCT6+1)_^1_%NUM $B400_^1_%ADC C_1LDA C_^1ARCEND LDQ- QS_^1_%JMP- (ARCRET)_^1ONE_"NUM $40C0,0_^1_%NUM $BF3F,$FFFF_^1TANPI8 NUM $3F6A,$09E6_$TAN(PI/8)_^1PI16_!NUM $3EE4,$87ED_(PI/16 =S_^1_%NUM $404B,$65F2_%3*(PI/16)=T_^1TAN16 NUM $3EE5,$D7D8_%TAN(S)_^1_%NUM $4055,$86E0_%TAN(T)_^1CO_#NUM $407F,$FFF8_%.999€X99900_^1C1_#NUM $C0AA,$B7C6_'-.33313333_^1C2_#NUM $3EE1,$47AE_(.19000000_^1_%END_]_^__XPD1781R CSY/ B13 P€1_%NAM D1781R_'DECK-ID B13 FTN 3.3 RUNTIME_%SUMMARY-102_^1*_$NON-REENTRANT HARDWARE FLOATING POINT UNIT DRIVER_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^1_%SPC 5_^1_%ENT HFLOT_(ENTRY FOR SINGLE PRECISION CALLS_^1_%ENT HDFLOT_'ENTRY FOR DOUBLE PRECISION CALLS_^1_%ENT IFALT€€_(ENTRY TO TEST AND RESET FAULT CONDITIONS_^1_%ENT SFALT_)ENTRY TO FORCE SET FAULT CONDITION_^1_%SPC 2_^1_%EXT E17811_'EQUIPMENT CODE FOR HARDWARE FLOATING POINT_^1_%EXT* PARABS_'PARAMETER ABSOLUTIZATION ROUTINE_^1_%SPC 2_^1_%EQU ERRORS($C8)_^1_%EQU TEMP($C9)_^1_%EQU QSAVE($CA)_^1_%EQU ZERO($22)_^1_%EQU H4000($31)_^1_%EJT_]_^1HDFLOT NUM 0_,ENTRY FOR DOUBLE PRECISION CALLS€€_^1_%IIN 0_^1_%LDA* HDFLOT_^1_%EIN 0_^1_%ENQ 1_^1_%JMP* FLT001_^1HFLOT NUM 0_,ENTRY FOR SINGLE PRECISION CALLS_^1_%IIN 0_^1_%LDA* HFLOT_^1_%EIN 0_^1_%CLR Q_^1FLT001 ADQ* EQ1781_'ADD IN 1781-1 EQUIPMENT CODE_^1_%OUT REJ-*_(COLD START COMMAND TO 1781-1_^1LOOP_!INP REJ1-*_'READ PCR STATUS_^1_%TRA Q_,RETURN ADDRESS TO Q_^1_%JMP- (ZERO),Q_$RETURN TO CALLER_^1_%SPC 2_^1EQ1781€€ ADC E17811_^1_%SPC 2_^1REJ_"NUM $18FF_(HANG_^1REJ1_!NUM $18FF_(HANG_^1_%JMP* LOOP_^1_%EJT_]_^1*_$TEST AND RESET FLOATING POINT FAULT CONDITION_^1_%SPC 3_^1IFALT NOP 0_^1_%IIN 0_^1_%STQ- QSAVE_(SAVE USER'S Q REGISTER_^1_%LDA* IFALT_(PICK UP ADDRESS OF PARAMETER_^1_%RTJ* GETBIT_'GET REQUESTED ERROR BIT(S)_^1_%RTJ* GTSTAT_'GET CURRENT 1781-1 STATUS_^1_%LDQ- ERRORS_'PICK UP ERR€€OR BIT(S)_^1_%LAQ Q_,FAULTS (IF ANY) TO Q_^1_%EAQ A_,CLEAR FAULT BITS IN A_^1_%STA- ERRORS_'SAVE AS NEW STATUS_^1_%ENA 1_^1_%SQN IFALT1_'SKIP IF FAULT BIT SET_^1_%INA 1_,RETURN 2 FOR NO ERROR_^1IFALT1 STA- TEMP_)SAVE RETURN VALUE_^1_%RTJ* PTSTAT_'PUT NEW STATUS IN 1781-1_^1_%LDA- TEMP_)RETURN VALUE TO A_^1_%LDQ- QSAVE_(RESTORE USER'S Q REGISTER_^1_%RAO* IFALT_(BUMP RETURN ADDR€€ESS_^1_%EIN 0_^1_%JMP* (IFALT)_%RETURN TO CALLER_^1_%EJT_]_^1*_]_^1*_$GET CURRENT 1781-1 STATUS IN A_^1*_]_^1_%SPC 2_^1GTSTAT NUM 0_^1_%LDQ* EQ1781_'1781 EQUIP CODE TO Q_^1_%INQ -3_+SET Q FOR FSR READ_^1_%INP REJ-*_(READ FSR STATUS_^1_%JMP* (GTSTAT)_$RETURN TO CALLER_^1_%SPC 3_^1*_]_^1*_$SET 1781 STATUS TO VALUE IN 'ERRORS'_^1*_]_^1_%SPC 2_^1PTSTAT NUM 0_^1_%LDQ* EQ1781_^1_€€%INQ -3_+SET Q FOR FSR_^1_%LDA- ERRORS_'NEW FSR VALUE TO A_^1_%OUT REJ-*_(RELOAD FSR_^1_%JMP* (PTSTAT)_$RETURN TO CALLER_^1_%EJT_]_^1*_]_^1*_$GET THE ERROR BIT REFERRED TO BY USER AND STORE IN ERRORS_^1*_]_^1_%SPC 2_^1GETBIT NUM 0_^1_%RTJ PARABS_'ABSOLUTIZE PARAMETER ADDRESS_^1_%TRA Q_^1_%LDQ- (ZERO),Q_$GET USER PARAMETER_^1_%TRQ A_^1_%INA -3_+TEST FOR 'ALL ERRORS' REQUEST_€€^1_%SAZ GTBIT2_'SKIP IF IT IS_^1_%TCQ Q_,COMPLEMENT Q FOR NEGATIVE INDEXING_^1_%LDA- H4000,Q_^1GTBIT1 STA- ERRORS_'SAVE BIT(S) IN 'ERRORS'_^1_%JMP* (GETBIT)_$RETURN TO CALLER_^1GTBIT2 LDA* H7000_^1_%JMP* GTBIT1_^1_%SPC 2_^1H7000 NUM $7000_^1_%EJT_]_^1*_$FORCE SET FLOATING POINT FAULT CONDITION_^1_%SPC 3_^1SFALT NOP 0_^1_%IIN 0_^1_%STQ- QSAVE_(SAVE USER'S Q REGISTER_^1_%LDA€€* SFALT_(PICK UP ADDRESS OF PARAMETER_^1_%RTJ* GETBIT_'GET REQUESTED ERROR BIT(S)_^1_%RTJ* GTSTAT_'GET CURRENT 1781-1 STATUS_^1_%LDQ- ERRORS_'REQUESTED BIT(S) TO Q_^1_%TCQ Q_,FORM MASK IN Q_^1_%LAQ A_,STRIP OFF OLD ERRORS (IF ANY)_^1_%TCQ Q_^1_%EAQ A_,SET NEW ERRORS_^1_%STA- ERRORS_^1_%RTJ* PTSTAT_'PUT NEW STATUS IN 1781-1_^1_%LDQ- QSAVE_(RESTORE USER'S Q REGISTER_^1_%RAO* SFAL€RT_(BUMP RETURN ADDRESS_^1_%EIN 0_^1_%JMP* (SFALT)_%RETURN TO CALLER_^1_%END_]_^__RPFLOTR CSY/ B14 P€1_%NAM FLOTR_(DECK-ID B14 FTN 3.3 RUNTIME_%SUMMARY-102_^1*_$NON-REENTRANT SINGLE PRECISION FLOATING POINT PACKAGE_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^1_%SPC 5_^1_%ENT FLOT_)ENTRY FOR OLD STYLE FLOATING POINT_^1_%ENT HFLOT_(ENTRY FOR NEW STYLE FLOATING POINT_^1_%SPC €€2_^1_%EXT* OPERND_^1_%EXT* NXTOP_(ROUTINE TO GET NEXT OPCODE BYTE_^1_%EXT* SPECOP_'ROUTINE TO PROCESS 'SPEC' OP CODE_^1_%EXT* FLOFOP_'ROUTINE TO PROCESS 'FLOF' OP CODE_^1_%EXT* FIXFOP_'ROUTINE TO PROCESS 'FIXF' OP CODE_^1_%EXT* FPEROR_^1_%SPC 2_^1_%EQU ZERO($22)_KFTN 3.3_^1_%EQU ONEBIT($23)_IFTN 3.3_^1_%EQU ZROBIT($33)_IFTN 3.3_^1_%EQU H0003($04)_JFTN 3.3_^1_%EQU H007F($09)_^1€€_%EQU H00FF($0A)_^1_%EQU H7FFF($11)_JFTN 3.3_^1_%EQU HFFF8($15)_JFTN 3.3_^1_%EQU HE000($1F)_^1_%EQU H0080($2A)_JFTN 3.3_^1_%EQU H0100($2B)_JFTN 3.3_^1_%EQU H4000($31)_JFTN 3.3_^1_%EQU H8000($32)_JFTN 3.3_^1_%EJT_]_^1*_]_^1*_$FORTRAN SCRATCH EQUIVALENCE STATEMENTS_^1*_]_^1_%SPC 2_^1_%EQU G($C5)_'PSEUDO ACCUMULATOR_^1_%EQU STATUS($C8)_!STATUS FLAG WORD_^1_%EQU P($C9)_'PSE€€UDO PROGRAM COUNTER_^1_%EQU INDEX($CA)_"INDEX REGISTER_^1_%EQU OPCODE($CB)_!CURRENT OPCODE WORD_^1_%EQU OPCNT($CC)_"OPERAND BYTE COUNTER_^1_%EQU C($CD)_^1_%EQU D($CE)_^1_%EQU DELTA($CF)_^1_%EQU A($D0)_^1_%EQU B($D1)_^1_%EQU BETA($D2)_^1_%EQU F($D3)_^1*_]_^1*_$EQUIVALENCES FOR DOUBLY USED WORDS_^1*_]_^1_%EQU SHIFCT($D3)_!NORMALIZATION SHIFT COUNTER_^1*_] FTN 3.3_^1*_$EQU€€ATES FOR AND USAGE OF STATUS WORD BITS_0FTN 3.3_^1*_] FTN 3.3_^1_%EQU MODE(15)_$15 - 1 = FTN 3.3 TYPE CALLING SEQUENCE FTN 3.3_^1*_814 - 1 = OVERFLOW FAULT_/FTN 3.3_^1*_813 - 1 = DIVIDE FAULT_1FTN 3.3_^1*_812 - 1 = UNDERFLOW FAULT_.FTN 3.3_^1_%EQU SIGN(11)_$11 - 1 = UNPACKED ACCUMULATOR IS NEGATIVE_^1_%EQU MULDIV(10)_"10 - 1 = INSTRUCTION IS DIVIDE (DBL PREC)_^1_%EQU RELADR(9)€€_#09 - 1 = RELATIVE ADDRESSING MODE_$FTN 3.3_^1*_808 -_BFTN 3.3_^1_%EQU DOUBLE(7)_#07 - 1 = DOUBLE PRECISION MODE_(FTN 3.3_^1*_806 -_BFTN 3.3_^1*_805 -_BFTN 3.3_^1*_804 -_BFTN 3.3_^1*_803 -_BFTN 3.3_^1*_802 -_BFTN 3.3_^1_%EQU UNPCKD(1)_#01 - 1 = ACCUMULATOR IS UNPACKED_%FTN 3.3_^1_%EQU IDXINH(0)_#00 - 1 = INDEXING IS INHIBITED_(FTN 3.3_^1_%EJT_]_^1*_$LIST OF FLOATING POINT OPERA€€TION CODES._^1*_$0_"SPEC_)FIRST BYTE OF TWO BYTE OP CODE_^1*_$1_"FLOF_)FLOAT TO FIXED CONVERSION OF ACCUMULATOR_^1*_$2_"FIXF_)FIXED TO FLOAT CONVERSION OF INTEGER OPERAND_^1*_$3_"STRI_)STORE INDEX_^1*_$4_"FEND_)END OF CALLING SEQUENCE_^1*_$5_"CHMD_)CHANGE MODE REL/ABS_^1*_$6_"NIDX_)NO INDEX_^1*_$7_"FCOM_)COMPLEMENT_^1*_$8_"FSUB_)SUBTRACT_^1*_$9_"FMPY_)MULTIPLY_^1*_$A_"FDIV_)DIVIDE_€€^1*_$B_"FLDD_)LOAD_^1*_$C_"ADDI_)ADD TO INDEX_^1*_$D_"FLST_)STORE_^1*_$E_"FADD_)ADD_^1*_$F_"INDX_)INDEX_^1_%EJT_]_^1FLOT_!NUM 0_,ENTRY FOR OLD STYLE FLOATING POINT_^1_%IIN 0_^1_%LDA* FLOT_^1_%ENQ 0_^1_%JMP* FLOT00_^1HFLOT NUM 0_,ENTRY FOR NEW STYLE FLOATING POINT_^1_%IIN 0_^1_%LDA* HFLOT_^1_%ENQ 1_^1FLOT00 STA- P_,SAVE ADDRESS OF CALLING SEQUENCE_^1_%EIN 0_^1_%LDA- STATUS_^€€1_%ALS 1_^1_%AND- HE000_(SAVE ONLY FAULT BITS_^1_%LRS 1_^1_%STA- STATUS_^1_%ENA 0_^1_%STA- INDEX_^1_%ENA 3_^1_%STA- OPCNT_^1NXTOPC RTJ NXTOP_(GET NEXT OPCODE BYTE IN Q_^1EXECUT JMP* FLINS,Q_^1_%EJT_]_^1FLINS JMP* SPEC_)0=FIRST BYTE OF TWO BYTE OP CODE (JUMPS)_^1_%JMP* FLOF_)1=CONVERT ACCUMULATOR TO INTEGER FORMAT_^1_%JMP* FIXF_)2=CONVERT INTEGER TO FLOATING POINT FORMAT_^1_%J€€MP* STRI_)3=STORE INDEX REGISTER_^1_%JMP* FEND_)4=END OF CALLING SEQUENCE_^1_%JMP* CHMD_)5=CHANGE ADDRESS MODE (RELATIVE/ABSOLUTE)_^1_%JMP* NIDX_)6=CLEAR INDEX REGISTER_^1_%JMP* FCOM_)7=COMPLEMENT FLOATING ACCUMULATOR_^1_%JMP* FSUBA_(8=FLOATING SUBTRACT_^1_%JMP* FMPYA_(9=FLOATING MULTIPLY_^1_%JMP* FDIVA_(A=FLOATING DIVIDE_^1_%JMP* FLDD_)B=LOAD FLOATING POINT ACCUMULATOR_^1_%JMP* AD€€DI_)C=ADD TO INDEX REGISTER_^1_%JMP* FLST_)D=STORE FLOATING ACCUMULATOR_^1_%JMP* FADDA_(E=FLOATING ADD_^1_%JMP* INDX_)F=LOAD INDEX REGISTER_^1FSUBA JMP FSUB_^1FMPYA JMP FMPY_^1FDIVA JMP FDIV_^1FADDA JMP FADD_^1_%SPC 2_^1SPEC_!RTJ SPECOP_''SPEC' PROCESSED BY COMNFP_^1_%SQP SPEC1_(SKIP IF NOT 'FEND' RETURN_^1_%JMP* FEND_^1SPEC1 JMP* NXTOPC_^1_%SPC 2_^1FLOF_!RTJ* REPACK_'€€REPACK ACCUMULATOR BEFORE CALLING FLOFOP_^1_%RTJ FLOFOP_'CONVERT ACCUMULATOR TO FIXED POINT_^1_%JMP* NXTOPC_^1_%SPC 2_^1FIXF_!RTJ FIXFOP_''FIXF' PROCESSED BY COMNFP_^1_%JMP* NXTOPC_^1_%EJT_]_^1*_]_^1*_$REVERSE RELATIVE/ABSOLUTE ADDRESSING SWITCH_^1*_]_^1CHMD_!LDA- STATUS_^1_%EOR- ONEBIT+RELADR_^1_%STA- STATUS_^1_%JMP* NXTOPC_^1*_] FTN 3.3_^1*_$CLEAR INDEX REGISTER_EFTN 3.3_^1*_€€] FTN 3.3_^1NIDX_!ENA 0_SFTN 3.3_^1_%JMP* INDX1_OFTN 3.3_^1*_] FTN 3.3_^1*_$LOAD INDEX REGISTER_FFTN 3.3_^1*_] FTN 3.3_^1INDX_!LDA- STATUS_NFTN 3.3_^1_%EOR- ONEBIT+IDXINH INHIBIT INDEXING_6FTN 3.3_^1_%STA- STATUS_NFTN 3.3_^1_%RTJ OPERND_'GET OPERAND ADDRESS-1 IN Q_,FTN 3.3_^1_%LDA- 1,Q_*PICK UP NEW INDEX VALUE_/FTN 3.3_^1INDX1 STA- INDEX_(SAVE_^1_%JMP* NXTOPC_'GO GET NEXT OPC€€ODE_4FTN 3.3_^1*_]_^1*_$ADD OPERAND TO INDEX REGISTER_^1*_]_^1ADDI_!LDA- STATUS_^1_%EOR- ONEBIT+IDXINH INHIBIT INDEXING_^1_%STA- STATUS_^1_%RTJ OPERND_(GET OPERAND ADDRESS - 1 IN Q_^1_%LDA- 1,Q_*PICK UP OPERAND_^1_%ADD- INDEX_(ADD IT TO INDEX REGISTER_^1_%STA- INDEX_(STORE NEW INDEX_^1_%JMP* NXTOPC_'GO TO NEXT OP CODE_^1*_]_^1*_$STORE THE INDEX REGISTER_^1*_]_^1STRI_!LDA- STATUS_^1€€_%EOR- ONEBIT+IDXINH INHIBIT INDEXING_^1_%STA- STATUS_^1_%RTJ OPERND_'GET OPERAND ADDRESS-1 IN Q_^1_%LDA- INDEX_(PICK UP INDEX REGISTER_^1_%STA- 1,Q_*STORE INDEX REGISTER_^1_%JMP* NXTOPC_'GO GET NEXT INSTRUCTION_^1_%EJT_]_^1*_]_^1*_$END OF CALLING SEQUENCE_^1*_]_^1FEND_!RTJ* REPACK_'REPACK ACCUMULATOR IF UNPACKED_^1_%LDA- G_,PICK UP MS WORD OF ACCUMULATOR_^1_%ARS 15_+FILL A REG W€€ITH SIGN BIT_^1_%STA- G+2_*MAKE RESULT CORRECT FOR DOUBLE PRECISION_^1_%JMP- (P)_*RETURN TO USER_^1_%SPC 2_^1*_]_^1*_$COMPLEMENT FLOATING ACCUMULATOR_^1*_]_^1FCOM_!LDA- STATUS_^1_%AND- ONEBIT+UNPCKD GET ACCUMULATOR UNPACKED FLAG_^1_%SAN FCOM01_'SKIP IF ACCUMULATOR UNPACKED_^1_%LDA- G_^1_%TCA A_,COMPLEMENT_^1_%STA- G_^1_%LDA- G+1_-PACKED_^1_%TCA A_^1_%STA- G+1_0ACCUMULATOR_^1_%J€€MP* NXTOPC_'GO TO NEXT OPERATION_^1_%SPC 2_^1FCOM01 LDA- STATUS_^1_%EOR- ONEBIT+SIGN_!REVERSE SIGN OF UNPACKED ACCUMULATOR_^1_%STA- STATUS_^1_%JMP* NXTOPC_^1_%EJT_]_^1*_]_^1*_$STORE FLOATING POINT ACCUMULATOR_^1*_]_^1FLST_!RTJ* REPACK_'REPACK ACCUMULATOR IF UNPACKED_^1_%RTJ OPERND_'GET OPERAND ADDRESS -1 IN Q_^1_%LDA- G_^1_%STA- 1,Q_^1_%LDA- G+1_^1_%STA- 2,Q_^1_%JMP* NXTOPC_'GO G€€ET NEXT OP CODE_^1_%SPC 1_^1*_]_^1*_$REPACK THE ACCUMULATOR IF IT IS UNPACKED_^1*_]_^1REPACK NOP 0_^1_%IIN 0_^1_%LDA- STATUS_^1_%AND- ONEBIT+UNPCKD GET ACCUMULATOR UNPACKED FLAG_^1_%SAN PACK_)SKIP IF ACCUMULATOR IS UNPACKED_^1_%EIN 0_^1_%JMP* (REPACK)_$RETURN TO CALLER_^1_%SPC 1_^1PACK_!EOR- STATUS_'RESET ACCUMULATOR UNPACKED FLAG_^1_%STA- STATUS_^1_%LDQ- C_^1_%SQN PACK1_(SK€€IP IF ACCUMULATOR NOT ZERO_^1_%STQ- G_,SET PACKED ACCUMULATOR TO ZERO_^1_%STQ- G+1_^1_%EIN 0_^1_%JMP* (REPACK)_$RETURN TO CALLER_^1PACK1 LDA- D_^1_%ALS 1_^1_%LLS 1_^1_%STA- G+1_^1_%LDA- DELTA_^1_%AND- H00FF_^1_%EOR- H0080_^1_%ADD- G+1_^1_%LLS 7_^1_%STA- G_^1_%STQ- G+1_^1_%LDQ- STATUS_^1_%QLS 15-SIGN_%SHIFT SIGN TO BIT 15_^1_%SQP PACK2_^1_%TCA A_,IF SIGN NEGATIVE, COMPLEMENT€€ ACCUMULATOR_^1_%STA- G_^1_%LDA- G+1_^1_%TCA A_^1_%STA- G+1_^1PACK2 EIN 0_^1_%JMP* (REPACK)_$RETURN TO CALLER_^1_%EJT_]_^1*_]_^1*_$LOAD FLOATING ACCUMULATOR_^1*_]_^1FLDD_!RTJ OPERND_(GET OPERAND ADDRESS - 1 IN Q_^1_%LDA- 2,Q_^1_%STA- G+1_^1_%LDA- 1,Q_^1_%INA 0_,ELIMINATE MINUS ZERO_^1_%STA- G_^1_%LDA- STATUS_^1_%AND- ZROBIT+UNPCKD CLEAR ACCUMULATOR UNPACKED FLAG_^1_%STA- STATUS€€_^1_%JMP NXTOPC_'GO TO NEXT OPERATION CODE_^1*_]_^1*_$UNPACK THE ACCUMULATOR IF IT IS PACKED_^1*_]_^1UNPACK NOP 0_^1_%IIN 0_^1_%LDA- STATUS_^1_%AND- ONEBIT+UNPCKD GET ACCUMULATOR UNPACKED FLAG_^1_%SAZ UPACK_(SKIP IF PACKED TO UNPACK_^1_%EIN 0_^1_%JMP* (UNPACK)_$RETURN, IT'S NOT PACKED_^1_%SPC 1_^1UPACK LDA- STATUS_^1_%EOR- ONEBIT+UNPCKD SET ACCUMULATOR UNPACKED FLAG_^1_%AND-€€ ZROBIT+SIGN_!CLEAR SIGN BIT_^1_%LDQ- G_,PICK UP ACCUMULATOR MSB_^1_%SQP UPACK0_'SKIP IF ACCUMULATOR POSITIVE_^1_%EOR- ONEBIT+SIGN_!SET SIGN MINUS_^1UPACK0 STA- STATUS_^1_%TRQ A_^1_%SAN UPACK1_'SKIP IF ACCUMULATOR NOT ZERO_^1_%RTJ* ARGZRO_'ACCUMULATOR IS ZERO_^1_%EIN 0_^1_%JMP* (UNPACK)_^1UPACK1 LDQ- G+1_^1_%SAP UPACK2_^1_%TCA A_^1_%TCQ Q_^1UPACK2 STA- C_^1_%ALS 1_,STRIP OF€€F SIGN BIT_^1_%EOR- H8000_(UNBIAS EXPONENT_^1_%ARS 8_,SIGN EXTEND_^1_%INA 0_,CHANGE -0 TO +0_^1_%STA- DELTA_(STORE EXPONENT_^1_%LDA- C_^1_%AND- H007F_(STRIP OFF EXPONENT_^1_%LLS 8_,FORM MS 15 BITS_^1_%STA- C_^1_%CLR A_^1_%LLS 15_+FORM LS 8 BITS_^1_%STA- D_^1_%EIN 0_^1_%JMP* (UNPACK)_^1_%EJT_]_^1ARGZRO NUM 0_^1_%IIN 0_^1_%CLR A_^1_%STA- C_^1_%STA- D_^1_%STA- DELTA_^1_%JMP* €€(ARGZRO)_$RETURN TO CALLER_^1_%SPC 3_^1ARG0_!RTJ* ARGZRO_^1_%EIN 0_^1_%JMP NXTOPC_^1_%EJT_]_^1*_*FLOATING POINT MULTIPLY OF F*G_^1*_]_^1FMPY_!RTJ* UNPACK_'UNPACK ACCUMULATOR IF IT'S PACKED_^1_%RTJ OPERND_'GET OPERAND ADDRESS-1 IN Q_^1_%RTJ* FLTSET_'STEPS 1,2,3 AND 4 OF MPY OR DIV_^1*_*IF F IS NEG., CHANGE SIGN._^1_%SAZ JMPOUT_^1_%SAP FLT1_^1_%LDA- STATUS_^1_%EOR- ONEBIT+SIGN_€€!REVERSE SIGN BIT_^1_%STA- STATUS_^1*_]_^1*_*STEP 5.A._^1FLT1_!LDA- C_^1_%SAN NOZERO_^1JMPOUT JMP* ARG0_)ACCUMULATOR IS ZERO_^1NOZERO MUI- A_^1_%LLS 1_^1_%ARS 1_^1_%AND- H7FFF_^1_%STA- F+1_#C*A(LSB)_^1_%STQ- G_#C*A(MSB)_^1_%LDA- C_^1_%MUI- B_^1_%LLS 1_^1_%STQ- F_#C*B(MSB)_^1*_FSTEP 5C_^1_%LDA- A_^1_%MUI- D_^1_%LLS 1_^1_%TRQ A_^1_%LDQ- G_^1_%ADD- F_^1_%RTJ* TSTBOR_^1_%ADD- F+1€€_^1_%RTJ* TSTBOR_^1*_$ROUND AND TRUNCATE TO 23 BITS._^1ROUND ALS 1_^1_%LLS 16_^1_%STA- G_^1*_FSTEP 5E_^1NORMAL ENA 0_,NORMALIZE G AND G+1 ACCUM_^1_%STA- SHIFCT_5COMBINE EXPONENTS BETA AND DELTA_^1_%LDA- G_^1STEP6 LLS 1_^1_%SAM STEP6A_^1_%RAO- SHIFCT_^1_%JMP* STEP6_^1STEP6A LLS 15_^1_%STQ- C_:MOST SIGNIFICANT BITS_^1_%ARS 1_^1_%AND- H7FFF_^1_%STA- D_^1*_*LEAST SIGNIFICANT B€€ITS IN D_^1_%LDA- DELTA_^1_%ADD- BETA_^1COMBIN SUB- SHIFCT_^1_%STA- DELTA_^1_%TRA Q_^1_%ARS 7_^1_%INA 0_^1_%SAZ COMB1_^1_%JMP* OVFUNF_^1COMB1 LDA- D_^1_%INA 64_^1_%SAM COMB2_^1_%AND* H7F80_^1_%STA- D_^1_%JMP* FMPXIT_^1COMB2 ENA 0_^1_%STA- D_^1_%LDA- C_^1_%INA 1_^1_%SAM COMB3_^1_%STA- C_^1_%JMP* FMPXIT_^1COMB3 LDA- H4000_^1_%STA- C_^1_%RAO- DELTA_^1_%LDA- DELTA_^1_%SUB- €€H0100_^1_%SAN FMPXIT_^1_%ENQ 0_^1_%JMP* OVFUNF_5OVERFLOW IF Q=+,A=0._^1*_FUNDERFLOW IF Q=-,A=0._^1FMPXIT JMP NXTOPC_^1TSTBOR 0_"0_^1_%IIN 0_^1_%SAP TSTB_)IF A IS NEG. CARRY INTO G_^1_%AND- H7FFF_^1_%INQ 1_^1_%SQP TSTB_)IF Q IS NEQ. END AROUND_^1_%ADQ- H7FFF_^1_%INA 1_^1_%EIN 0_^1TSTB_!JMP* (TSTBOR)_^1_%EJT_]_^1*_]_^1*_$UNPACK OPERAND INTO A,B, AND BETA_^1*_]_^1FLTSET 0_"0_€€^1_%IIN 0_^1_%LDA- 2,Q_^1_%STA- F+1_^1_%LDA- 1,Q_^1_%STA- F_^1_%LDQ- F+1_^1_%SAP STEP2A_^1_%TCA A_^1_%TCQ Q_^1STEP2A STA- A_^1*_*IF F IS ZERO, GO TO ARGFO (SET BETA,A,B=0)_^1_%SAZ ARGF0_^1_%ALS 1_^1_%EOR- H8000_OFTN 3.3_^1_%ARS 8_^1_%INA 0_^1ARGF0 STA- BETA_^1_%LDA- A_^1_%LLS 8_^1_%AND- H7FFF_OFTN 3.3_^1_%STA- A_^1_%LLS 15_^1_%AND* H7F80_^1_%STA- B_^1_%LDA- F_^1_%EIN 0_€€^1_%JMP* (FLTSET)_^1_%SPC 2_^1H7F80 NUM $7F80_^1_%EJT_]_^1FDIV_!RTJ UNPACK_'UNPACK ACCUMULATOR IF IT'S PACKED_^1_%RTJ OPERND_'GET OPERAND ADDRESS-1 IN Q_^1_%RTJ* FLTSET_5STEPS 1,2,3 AND 4 OF MPY OR DIV._^1*_FAND NORMALIZE_^1_%SAN A6_^1*_*IF F IS ZERO, GO TO DIVZER_^1_%JMP* DIVZER_^1A6_#SAP FLT2_^1_%LDA- STATUS_^1_%EOR- ONEBIT+SIGN_!REVERSE SIGN BIT_^1_%STA- STATUS_^1FLT2_!LD€€Q- C_/SHIFT C,D TO 14 BITS AND 9 BITS_^1_%LDA- D_/TO GUARANTEE DIVISION WITH NO_^1_%ALS 1_:OVERFLOW_^1_%LRS 1_^1_%ARS 1_^1_%STQ- C_^1_%AND- H7FFF_^1_%STA- D_^1_%LDA- BETA_^1_%TCA A_^1_%INA 1_/-BETA + 1=BETA_^1_%STA- BETA_^1_%LDA- C_/FORM -C*B_^1*_*IF C.E.0, GO TO ARGO._^1_%SAN FD2_^1_%JMP ARG0_)ACCUMULATOR IS ZERO_^1FD2_"TCA A_^1_%INA 0_^1_%MUI- B_/-C*B_^1_%DVI- A_/-C*B/A_€€^1_%INQ 0_^1_%LLS 16_^1_%TCA A_:(REMAINDER MUST BE NEGATIVE)_^1_%ALS 1_:IF 2*R.GE.C,DECREMENT RESULT_^1_%SUB- A_/BY 1_^1_%SAM A7_^1_%INQ -1_^1A7_#TRQ A_5ROUNDED_^1_%ADD- D_/D-(C*B/A)_^1*_;FORM C+ ABOVE*2**-15_^1_%LDQ- C_^1_%SAP STEP5E_^1_%INQ -1_9IF LOWER ACC IS NEG, DECREMENT_^1_%ADD- H8000_(UPPER BY 1 AND INCREMENT_^1*_FLOWER BY_^1*_F1 TO PUT THE END AROUND_^1*_FBORROW I€€NTO_^1*_FPROPER POSITION._^1STEP5E ALS 1_^1_%LRS 1_^1_%DVI- A_^1_%INQ 0_^1_%STA- G_^1_%CLR A_^1_%LRS 1_^1_%DVI- A_^1_%INQ 0_^1_%LLS 16_^1*_8ROUND REMAINDER IN A IF A._^1*_8GE. 1/2, ROUND Q UP BY 1._^1_%ALS 1_^1_%SUB- A_^1_%SAM A8_^1_%INQ 1_^1A8_#TRQ A_^1_%LDQ- G_/ROUND,TRUNCATE AND_^1_%JMP ROUND_(NORMALIZE THE RESULTS_7+_^1_%EJT_]_^1*_]_^1*_$DETERMINE TYPE OF ERROR AND €€SET Q REGISTER_^1*_]_^1*_$DIVIDE CHECK WHEN DIVIDE BY ZERO_^1DIVZER ENQ 1_^1_%JMP* SETERR_^1OVFUNF TRQ A_:OVERFLOW OR UNDERFLOW_^1*_*OVERFLOW_^1_%ENQ 0_^1_%SAP SETERR_^1*_*UNDERFLOW_^1_%ENQ 2_^1SETERR RTJ FPEROR_'SET ERROR FLAG IN STATUS_^1_%LDA* RSLTEX,Q_^1_%STA- DELTA_^1_%LDA* RSLTA,Q_^1_%STA- C_^1_%LDA* RSLTB,Q_^1_%STA- D_^1NXTOP3 JMP NXTOPC_^1_%SPC 2_^1RSLTEX NUM $007F€€,$007F,$FF80_^1RSLTA NUM $7FFF,$7FFF,$0000_^1RSLTB NUM $7F80,$7F80,$0000_^1_%EJT_]_^1*_*FLOATING POINT SUBTRACT G-F_^1FSUB_!RTJ UNPACK_'UNPACK ACCUMULATOR IF IT'S PACKED_^1_%RTJ OPERND_'GET OPERAND ADDRESS-1 IN Q_^1_%LDA- 1,Q_^1_%LDQ- 2,Q_^1_%TCA A_,CHANGE THE SIGN BDFORE_^1_%TCQ Q_,ENTERING YHE ADD ROUNTINE_^1_%JMP* FADD2_^1_%EJT_]_^1*_*FLOATING POINT ADD G+F, RESULT IN G.€€_^1FADD_!RTJ UNPACK_'UNPACK ACCUMULATOR IF IT'S PACKED_^1_%RTJ OPERND_'GET OPERAND ADDRESS-1 IN Q_^1_%LDA- 1,Q_^1_%LDQ- 2,Q_^1FADD2 STQ- F+1_^1_%STA- F_^1_%SAP A10_^1_%TCA A_^1A10_"ALS 1_^1_%SAN 1_^1_%JMP* NXTOP3_$ADD 0, THUS JMP OUT_^1_%EOR- H8000_OFTN 3.3_^1_%ARS 8_^1_%INA 0_,EXTRACT BETA_^1_%STA- BETA_^1_%LDA- F_^1_%LDQ- F+1_^1_%AND =N$807F_^1_%SAP A11_^1_%ADD H7F80_€€^1A11_"LLS 8_5STORE A AND B_^1_%STA- A_,A=0, 15MSB_^1_%STQ- B_,B=8 LSB, 8 SIGN BITS_^1_%LDA- D_^1_%ALS 1_/REMOVE BIT 15 OF A REG_^1_%STA- D_^1_%LDQ- STATUS_^1_%QLS 15-SIGN_%SIGN TO BIT 15_^1_%SQP FADD21_^1_%TCA A_,COMPLEMENT C AND D IF_^1_%STA- D_,SIGN IF NEQATIVE_^1_%LDA- C_^1_%TCA A_^1_%STA- C_^1FADD21 LDA- C_(IF ACC IS ZERO( USE SECOND_^1_%SAN FA22_,VALUE AS ANSWER_^1_%LD€€A- BETA_^1_%STA- DELTA_^1_%LDA- B_^1_%LDQ- A_^1_%JMP* STOCD_^1FA22_!LDA- DELTA_^1_%SUB- BETA_^1*_]_^1*_*IF F.GE.G, GO TO ADD STEP 3 (ADDS3)._^1_%SAP ADDS3_+OTHERWISE_^1*_;EXCHANGE EXPONENTS_^1_%LDA- DELTA_^1_%LDQ- BETA_^1_%STA- BETA_^1_%STQ- DELTA_^1_%LDA- A_^1_%LDQ- C_^1_%STA- C_^1_%STQ- A_^1_%LDA- A+1_^1_%LDQ- C+1_^1_%STA- C+1_^1_%STQ- A+1_^1*_*C AND D ARE NOW THE LARGER NUMBER_€€^1*_*A AND B ARE NOW THE SAMLLER NUMBER_^1_%LDA- DELTA_^1_%SUB- BETA_^1ADDS3 TRA Q_^1_%ADD* LRSINS_^1_%IIN 0_^1_%STA* LRS_^1_%INQ -29_^1*_*IF SHIFT .GE. 29,_^1_%SQM AS30_^1_%EIN 0_^1*_*LEAVE THE LARGER NUMBER IN ACCUMULATOR AND GO ON_^1_%LDA- D_^1_%LDQ- C_^1_%JMP* STOCD_^1_%SPC 2_^1LRSINS LRS 0_^1_%SPC 2_^1*_*STEP 3_^1AS30_!LDQ- C_^1_%LDA- D_^1_%LRS 8_^1_%LLS 6_^1_%ARS €€1_^1_%AND- H7FFF_OFTN 3.3_^1_%STA- D_,D=0,10LSB,5 SIGN BITS_^1_%TRQ A_^1_%AND- H7FFF_OFTN 3.3_^1_%STA- C_,C=0SS,13MSB_^1_%LDQ- A_^1_%LDA- B_^1_%LRS 8_^1_%LLS 6_^1_%EJT_]_^1*_*STEP 4._^1*_*SHIFT SMALLER NUMBER RIGHT (ABS.(BETA-DELTA)),_^1*_*AND SET THE SIGN OF MSB TO POSITIVE_^1*_*SHIFT LSB RIGHT 1, AND SET THE SIGN OF LSB POSITIVE._^1*_*CLEAR THE CARRY TO BIT 15 AND ADD 1 TO MSB€€_^1*_*POSITION THE SMALLER NUMBER_^1*_]_^1LRS_"LRS 0_^1_%EIN 0_^1_%ARS 1_^1_%AND- H7FFF_OFTN 3.3_^1_%STA- B_^1_%TRQ A_^1_%AND- H7FFF_OFTN 3.3_^1_%STA- A_^1_%CLR Q_:STEP 5_^1_%LDA- D_^1_%ADD- B_^1_%SAP AS6_8IF A.L.0, CARRY OCCURRED_^1_%AND- H7FFF_^1*_*STEP 6._^1_%ENQ 1_^1AS6_"ADQ- A_^1_%ADQ- C_^1_%SQP AS61_^1*_*SUBTRACT END AROUND CARRY INCREASE LSB BY 1_^1_%ADQ- H7FFF_OFTN €€3.3_^1_%INA 1_^1_%SAP AS61_^1_%INQ 1_^1_%AND- H7FFF_^1AS61_!ALS 1_^1_%STA- D_^1_%STQ- C_^1*_*IF RESULT IS MINUS ZERO, GO TO ARG0_^1*_*MINUS ZERO IS Q=7FFF, A= FFFE._^1_%ADQ- H8000_^1_%SQN AS62_^1_%INA 1_^1_%SAN AS62_^1_%JMP ARG0_)ACCUMULATOR IS ZERO_^1_%EJT_]_^1*_*STEP 7._^1*_*SAVE SIGNS AND OVERFLOW V IN BITS 1 AND 0_^1*_*IF S .E. V, THEN V IS SIGN EXTENSION_^1*_*IF S.NE.V€€, THEN RESULT OVERFLOWED INTO V._^1AS62_!LLS 3_^1_%AND- H0003_^1_%TRA Q_^1_%LDA- D_^1_%JMP* *+1,Q_^1*_]_^1*_*SV_^1*_*00_9S=V, SHIFT LEFT 2_^1_%JMP* SHFT2_^1*_*01_9S NOT = V, NO SHIFT_^1_%JMP* SHFT1_^1*_*10_9S NOT = V, NO SHIFT_^1_%JMP* SHFT1_^1*_*11_9S=V, SHIFT LEFT 2_^1_%JMP* SHFT2_6S=V, SHIFT LEFT 2_^1SHFT2 LDQ- C_^1_%LLS 2_^1_%JMP* STOCD_^1SHFT1 RAO- DELTA_+INCREMENT THE EX€€PONENT_^1_%LDQ- C_^1_%LLS 1_^1*_*SAVE THE SIGN AND MAGNITUDE OF THE RESULTS._^1STOCD STQ- C_^1_%SQP ADDS7A_^1_%TRA Q_,SAVE A IN Q_^1_%LDA- STATUS_^1_%AND- ZROBIT+SIGN_^1_%EOR- ONEBIT+SIGN_!SET SIGN BIT FOR NEGATIVE_^1_%STA- STATUS_^1_%TRQ A_,RESTORE A_^1_%LDQ- C_,RESTORE C_^1_%TCQ Q_^1_%TCA A_^1_%AND- HFFF8_^1_%JMP* ADDS7_^1ADDS7A TRA Q_,SAVE A IN Q_^1_%LDA- STATUS_^1_%AND-€ô ZROBIT+SIGN_!CLEAR SIGN BIT_^1_%STA- STATUS_^1_%TRQ A_,RESTORE A_^1_%LDQ- C_^1ADDS7 SAN ADDS7B_^1_%SQN ADDS7B_^1_%JMP ARG0_)ACCUMULATOR IS ZERO_^1ADDS7B STQ- G_^1_%STA- G+1_^1_%TRA Q_^1_%ENA 0_^1_%STA- BETA_^1_%JMP NORMAL_^1_%END_]_^__ôPCOMFPR CSY/ B15 P€1_%NAM COMFPR_'DECK-ID B15 FTN 3.3 RUNTIME_%SUMMARY-102_^1*_$COMMON SUBROUTINES FOR FLOTN/DFLOTN_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT, CONTROL DATA CORPORATION, 1975_^1_%SPC 5_^1_%ENT IFALT_^1_%ENT SFALT_^1_%ENT OPERND_^1_%ENT NXTOP_^1_%ENT FPEROR_^1_%ENT SPECOP_^1_%ENT FLOFOP_^1_%ENT FIXFOP_€€^1_%EXT PARABS_^1_%SPC 2_^1************************************************************************_^1*_$FOLLOWING EQU'S MUST MATCH CORRESPONDING EQU'S IN FLOTN/DFLOTN_^1*******************************************************************$****_^1_%EQU STATUS($C8)_^1_%EQU P($C9)_^1_%EQU INDEX($CA)_^1_%EQU OPCODE($CB)_^1_%EQU OPCNT($CC)_^1_%EQU G($C5)_'1ST WORD OF PACKED ACCUM€€ULATOR_^1_%EQU C($CD)_'FIRST WORD OF UNPACKED ACCUMULATOR_^1************************************************************************_^1*_] FTN 3.3_^1*_$EQUATES FOR AND USAGE OF STATUS WORD BITS_0FTN 3.3_^1*_] FTN 3.3_^1_%EQU MODE(15)_$15 - 1 = FTN 3.3 TYPE CALLING SEQUENCE FTN 3.3_^1*_814 - 1 = OVERFLOW FAULT_/FTN 3.3_^1*_813 - 1 = DIVIDE FAULT_1FTN 3.3_^1*_812 - 1 = UNDERFLOW €€FAULT_.FTN 3.3_^1_%EQU SIGN(11)_$11 - 1 = UNPACKED ACCUMULATOR IS NEGATIVE_^1_%EQU MULDIV(10)_"10 - 1 = INSTRUCTION IS DIVIDE (DBL PREC)_^1_%EQU RELADR(9)_#09 - 1 = RELATIVE ADDRESSING MODE_$FTN 3.3_^1*_808 -_BFTN 3.3_^1_%EQU DOUBLE(7)_#07 - 1 = DOUBLE PRECISION MODE_(FTN 3.3_^1*_806 -_BFTN 3.3_^1*_805 -_BFTN 3.3_^1*_804 -_BFTN 3.3_^1*_803 -_BFTN 3.3_^1*_802 -_BFTN 3.3_^1_%EQU €€ UNPCKD(1)_#01 - 1 = ACCUMULATOR IS UNPACKED_%FTN 3.3_^1_%EQU IDXINH(0)_#00 - 1 = INDEXING IS INHIBITED_(FTN 3.3_^1_%EJT_]_^1*_]_^1*_$LOCORE EQU'S_^1*_]_^1_%EQU ZERO($22)_^1_%EQU ONEBIT($23)_^1_%EQU ZROBIT($33)_^1_%EQU ERASE($41)_^1_%EQU SETBIT($31)_^1_%EQU H7FFF($11)_^1_%EQU H8000($32)_^1_%EJT_]_^1*_]_^1*_$UNPACK NEXT OPCODE BYTE, RETURN WITH IT IN Q_^1*_]_^1_%SPC 3_^1NXT€€OP NUM 0_^1_%IIN 0_^1_%LDA- OPCNT_(PICK UP OPERAND BYTE COUNTER_^1_%INA -3_+TEST FOR END OF WORD_^1_%SAP NXTOP2_'IT IS, GO GET NEXT WORD_^1_%RAO- OPCNT_(BUMP OPERAND BYTE COUNTER_^1_%LDA- OPCODE_^1NXTOP1 CLR Q_^1_%LLS 4_,SHIFT NEXT BYTE INTO Q_^1_%STA- OPCODE_^1_%EIN 0_^1_%JMP* (NXTOP)_%RETURN TO CALLER_^1_%SPC 3_^1NXTOP2 STA- OPCNT_(ZERO TO OPCNT_^1_%LDA- (P)_*GET NEXT OP€€CODE WORD_^1_%STA- OPCODE_^1_%RAO- P_,BUMP P COUNTER_^1_%JMP* NXTOP1_'GO UNPACK OPCODE_^1_%EJT_]_^1*_]_^1*_$GET ADDRESS OF NEXT OPERAND - 1 IN Q_^1*_]_^1_%SPC 2_^1OPERND NOP 0_^1_%IIN 0_^1_%LDQ- P_^1_%LDQ- (ZERO),Q_$PICK UP OPERAND ADDRESS_^1_%LDA- STATUS_^1_%AND- ONEBIT+RELADR GET RELATIVE ADDRESSING FLAG_^1_%SAZ OPRND2_'SKIP IF ADDRESS ABSOLUTE_^1_%LDA- STATUS_'CHECK MODE BIT€€_^1_%SAM OPRND1_'SKIP IF 16 BIT RELATIVE_^1_%QLS 1_,CHANGE 15 BIT RELATIVE TO 16 BIT RELATIVE_^1_%QRS 1_^1OPRND1 ADQ- P_,FORM ABSOLUTE ADDRESS_^1OPRND2 LDA- STATUS_^1_%AND- ONEBIT+IDXINH GET INDEX INHIBITED FLAG_^1_%SAZ OPRND3_'SKIP IF NOT INHIBITED TO ADD INDEX_^1_%EOR- STATUS_'CLEAR IDXINH BIT_^1_%STA- STATUS_^1_%JMP* OPRND4_^1OPRND3 LDA- STATUS_^1_%SAP OPRND5_'SKIP IF FTN 3€€.2_^1_%LDA- INDEX_^1_%ALS 1_,MULTIPLY INDEX BY TWO_^1_%AAQ Q_,ADD INDEX TO ADDRESS_^1OPRND4 INQ -1_+OPERAND ADDRESS - 1 TO Q_^1_%RAO- P_,BUMP PROGRAM COUNTER_^1_%EIN 0_^1_%JMP* (OPERND)_$RETURN TO CALLER WITH ADDRESS - 1 IN Q_^1OPRND5 ADQ- INDEX_(ADD BIASED INDEX TO ADDRESS_^1_%JMP* OPRND4_^1_%EJT_]_^1*_]_^1*_$EXECUTE INSTRUCTION FROM SECOND SET_^1*_]_^1_%SPC 1_^1SPECOP NOP 0€€_^1_%IIN 0_^1_%RTJ* NXTOP_(GET NEXT OPCODE BYTE IN Q_^1_%IIN 0_^1_%JMP* INSTAB,Q_$EXECUTE INSTRUCTION_^1_%SPC 2_^1INSTAB JMP* FEND_)00_^1_%JMP* CACS_)01_^1_%JMP* BRAM_)02_^1_%JMP* BRAZ_)03_^1_%JMP* BRAN_)04_^1_%JMP* BRAP_)05_^1_%JMP* BRIM_)06_^1_%JMP* BRIZ_)07_^1_%JMP* BRIN_)08_^1_%JMP* BRIP_)09_^1_%JMP* FEND_)0A_^1_%JMP* FEND_)0B_^1_%JMP* FEND_)0C_^1_%JMP* FEND_)0D_^1_%JMP* FEN€€D_)0E_^1_%JMP* FEND_)0F_^1_%SPC 2_^1NXTOPC CLR Q_,NORMAL RETURN_^1_%EIN 0_^1_%JMP* (SPECOP)_^1FEND_!SET Q_,SET Q MINUS TO INDICATE 'FEND'_^1_%EIN 0_^1_%JMP* (SPECOP)_^1_%EJT_]_^1CACS_!LDA- STATUS_^1_%EOR- ONEBIT+IDXINH INHIBIT INDEXING_^1_%STA- STATUS_^1_%RTJ* OPERND_'GET JUMP ADDRESS - 1_^1_%IIN 0_^1_%INQ 1_^1_%IIN 0_^1_%STQ- P_,JUMP ADDRESS TO P REGISTER_^1_%ENA 3_^1_%ST€€A- OPCNT_(RESET OP BYTE COUNTER_^1_%JMP* NXTOPC_'GO TO NEXT OP CODE_^1_%SPC 2_^1NOJUMP RAO- P_,BUMP P COUNTER OVER ADDRESS_^1_%JMP NXTOPC_'EXECUTE NEXT INSTRUCTION_^1_%SPC 2_^1BRAM_!RTJ* GETSGN_'GET SIGN OF ACCUMULATOR IN A_^1_%SAP BRAM1_^1_%JMP* CACS_^1BRAM1 JMP* NOJUMP_^1_%SPC 2_^1BRAP_!RTJ* GETSGN_'GET SIGN OF ACCUMULATOR IN A_^1_%SAM BRAP1_^1_%JMP* CACS_^1BRAP1 JMP* NOJ€€UMP_^1_%SPC 2_^1GETSGN NOP 0_^1_%LDA- STATUS_^1_%AND- ONEBIT+UNPCKD GET ACCUMULATOR UNPACKED FLAG_^1_%SAZ GETS1_(SKIP IF ACCUMULATOR PACKED_^1_%LDA- STATUS_^1_%ALS 15-SIGN_%SIGN TO BIT 15 OF A_^1_%JMP* (GETSGN)_^1GETS1 LDA- G_^1_%JMP* (GETSGN)_^1_%SPC 2_^1BRAZ_!RTJ* GETACC_^1_%SAN BRAZ1_^1_%JMP* CACS_^1BRAZ1 JMP* NOJUMP_^1_%SPC 2_^1BRAN_!RTJ* GETACC_^1_%SAZ BRAN1_^1_%JMP*€€ CACS_^1BRAN1 JMP* NOJUMP_^1_%EJT_]_^1GETACC NOP 0_^1_%LDA- STATUS_^1_%EOR- ONEBIT+IDXINH INHIBIT INDEXING_^1_%SAZ GETA1_(SKIP IF ACCUMULATOR PACKED_^1_%LDA- C_^1_%JMP* (GETACC)_^1GETA1 LDA- G_^1_%JMP* (GETACC)_^1_%SPC 2_^1BRIM_!LDA- INDEX_^1_%SAP BRIM1_^1_%JMP* CACS_^1BRIM1 JMP* NOJUMP_^1_%SPC 2_^1BRIP_!LDA- INDEX_^1_%SAM BRIP1_^1_%JMP* CACS_^1BRIP1 JMP* NOJUMP_^1_%SPC €€2_^1BRIZ_!LDA- INDEX_^1_%SAN BRIZ1_^1_%JMP* CACS_^1BRIZ1 JMP* NOJUMP_^1_%SPC 2_^1BRIN_!LDA- INDEX_^1_%SAZ BRIN1_^1_%JMP* CACS_^1BRIN1 JMP* NOJUMP_^1_%EJT_]_^1FPEROR NOP 0_^1_%IIN 0_^1_%TCQ Q_,COMPLEMENT Q FOR NEGATIVE INDEXING_^1_%LDA- STATUS_^1_%AND- ERASE,Q_^1_%EOR- SETBIT,Q_^1_%STA- STATUS_^1_%TCQ Q_^1_%EIN 0_^1_%JMP* (FPEROR)_$RETURN TO CALLER_^1_%EJT_]_^1*_]_^1*_$CON€€VERT ACCUMULATOR TO FIXED POINT AND STORE_^1*_]_^1FLOFOP NOP 0_^1_%IIN 0_^1_%LDA- G_^1_%LDQ- G+1_^1_%SAP FX1_^1_%TCA A_,COMPLEMENT IF NEGATIVE_^1_%TCQ Q_^1FX1_"STQ- G+1_^1_%ENQ 0_^1_%LLS 2_,SIGN OF EXPONENT TO Q_^1_%SQN FX2_*SKIP IF ACCUMULATOR.GT.ZERO_^1_%ENA 0_^1_%JMP* FX4_^1FX2_"ENQ 0_^1_%LLS 3_^1_%SQZ FX3_^1_%LDA- H7FFF_(ACCUM.GT.2**16-1, MAXVALUE TO A_^1_%JMP* FX3A€€_^1FX3_"LDQ* LLS_*CONSTRUCT A SHIFT_^1_%LLS 4_^1_%STQ* SHIFT_^1_%ENQ 0_,LOW ORDER BITS COME FROM WORD 2_^1_%LLS 7_^1_%LDA- G+1_^1_%LRS 7_^1SHIFT LLS 0_,COUNT FROM EXPONENT LOW 4 BITS_^1_%TRQ A_,ANSWER TO A_^1FX3A_!LDQ- G_^1_%SQP FX4_^1_%TCA A_,COMPLEMENT IF NEGATIVE_^1FX4_"INA 0_^1_%STA- G_^1_%LDA- STATUS_^1_%EOR- ONEBIT+IDXINH INHIBIT INDEXING_^1_%STA- STATUS_^1_%RTJ OP€€ERND_'GET ADDRESS TO STORE INTO_^1_%IIN 0_^1_%ADQ- INDEX_^1_%IIN 0_^1_%LDA- G_^1_%STA- 1,Q_*STORE RESULT_^1_%EIN 0_^1_%JMP* (FLOFOP)_^1_%SPC 3_^1LLS_"NUM $00FE_^1_%EJT_]_^1*_]_^1*_$CONVERT INTEGER OPERAND TO FLOATING POINT_^1*_$AND SET IN PSEUDO ACCUMULATOR_^1*_]_^1FIXFOP NOP 0_^1_%IIN 0_^1_%LDA- STATUS_^1_%EOR- ONEBIT+IDXINH INHIBIT INDEXING_^1_%STA- STATUS_^1_%RTJ OPERND_€€^1_%IIN 0_^1_%ADQ- INDEX_^1_%LDA- 1,Q_*OPERAND TO A_^1_%STA- G+1_*SAVE FOR LATER SIGN CHECK_^1_%SAP FL1_^1_%TCA A_,COMPLEMENT OPERAND IF NEGATIVE_^1FL1_"SAN FL2_*SKIP IF OPERAND NOT ZERO_^1_%CLR Q_^1_%JMP* FLX_*EXIT WITH ZERO VALUE_^1FL2_"LDQ =N$008F_%EXPONENT FOR 15 BIT INPUT_^1FL3_"ALS 1_^1_%SAM FL4_*SKIP IF BIT 15 SET_^1_%INQ -1_+DECREASE EXPONENT BY 1_^1_%JMP* FL3_*TRY€€ AGAIN_^1FL4_"LLS 7_,MOST SIGNIFICANT 7 BITS TO Q_^1_%STQ- G_^1_%LDQ- G+1_^1_%SQM FL5_*SKIP IF ORIGINAL OPERAND NEGATIVE_^1_%LDQ- G_^1_%JMP* FLX_^1FL5_"TCA A_,COMPLEMENT IF ORIGINAL OPERAND NEGATIVE_^1_%LDQ- G_^1_%TCQ Q_^1FLX_"STQ- G_^1_%STA- G+1_^1_%QRS 15_^1_%STQ- G+2_*SET 3RD WORD TO ALL SIGN BITS_^1_%LDA- STATUS_^1_%AND- ZROBIT+UNPCKD CLEAR ACCUMULATOR UNPACKED FLAG_^1_%ST€€A- STATUS_^1_%EIN 0_^1_%JMP* (FIXFOP)_^1_%EJT_]_^1*_$TEST AND RESET FLOATING POINT FAULT CONDITION_^1_%SPC 2_^1IFALT NOP 0_^1_%IIN 0_^1_%STQ* QSAVE_^1_%LDA* IFALT_(PICK UP ADDRESS OF PARAMETER_^1_%RTJ* GETBIT_'GET REQUESTED ERROR BITS_^1_%LDA- STATUS_^1_%LAQ Q_^1_%EAQ A_^1_%STA- STATUS_^1_%ENA 1_^1_%SQN IFALT1_^1_%INA 1_^1IFALT1 LDQ* QSAVE_^1_%RAO* IFALT_^1_%EIN 0_^1_%JM€€P* (IFALT)_^1_%SPC 2_^1GETBIT NOP 0_^1_%RTJ PARABS_'ABSOLUTIZE PARAMETER ADDRESS_^1_%TRA Q_^1_%LDQ- (ZERO),Q_$GET USER PARAMETER_^1_%TRQ A_^1_%INA -3_+TEST FOR ALL ERRORS REQUEST_^1_%SAZ GTBIT2_'SKIP IF IT IS_^1_%TCQ Q_,COMPLEMENT Q FOR NEGATIVE INDEXING_^1_%LDQ- ONEBIT+14,Q_^1_%JMP* (GETBIT)_^1GTBIT2 LDQ* H7000_^1_%JMP* (GETBIT)_^1_%SPC 2_^1SFALT NOP 0_^1_%STQ* QSAVE_^1€Ô_%LDA* SFALT_^1_%RTJ* GETBIT_^1_%LDA- STATUS_^1_%TCQ Q_^1_%LAQ A_^1_%TCQ Q_^1_%EAQ A_^1_%STA- STATUS_^1_%LDQ* QSAVE_^1_%RAO* SFALT_^1_%JMP* (SFALT)_^1_%SPC 2_^1H7000 NUM $7000_^1QSAVE NUM 0_^1_%END_]_^__ÔPQ8QIOR CSY/ C01 P€1_%NAM Q8QIOR_'DECK-ID C01 FTN 3.3 RUNTIME_%SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3_^1*_$SMALL COMPUTER DEVELOPMENT DIVISION, LA JOLLA CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1973_^1_%SPC 2_^1_%ENT Q8QINI_^1_%ENT Q8QX_^1_%ENT Q8QY_L**MSOS4.1**_^1_%ENT Q8QZ_L**MSOS4.1**_^1_%ENT Q8QEND_^1_%ENT Q8QGET_^1_%ENT SETBFR_^1_%ENT IOERR_^1_%ENT IRWERR_^1€€_%ENT ARGU0_^1_%EXT FORMTR_^1_%EXT BINARY_J**MSOS4.1**_^1_%EXT PARABS_J**MSOS4.1**_^1_%EQU LPMSK(2)_^1_%EQU NZERO($12)_^1_%EQU ZERO($22)_^1_%EQU ONEBIT($23)_^1_%EQU AVOLA($BB)_^1_%EQU AVOLR($BA)_^1_%EQU ARGU1($D8)_^1_%EQU ARGU2($D9)_^1_%EQU ADISP($EA)_^1_%EQU PRLVL($EF)_^1_%EQU AMONI($F4)_^1_%EQU LUFLG(-5)_^1_%EQU VR(1)_^1_%EQU VI(2)_^1_%EQU ICODE(3)_^1_%EQU LST€€(4)_^1_%EQU VMAX(5)_^1_%EQU DEFLAG(6)_^1_%EQU FORTFG(7)_^1_%EQU ERRFLG(8)_^1_%EQU SVARG2(16)_F**FTN 3.1**_^1_%EQU IBX(13)_^1_%EQU JBX(14)_^1_%EQU LIST(25)_^1_%EQU MV(26)_^1_%EQU TEMP(30)_^1*_$ORGANIZATION OF USERS BUFFER_^1*_(1 LWA OF BUFFER_^1*_(2 RC FOR READ/WRITE_!*CALLING SEQUENCE TO MONITOR_^1*_(3 COMPLETION ADDRESS *_^1*_(4 THREAD_-*_^1*_(5 LU_1*_^1*_(6 MESSAGE LEN€€GTH_$*_^1*_(7 FWA OF MESSAGE_$*_^1*_(8 UNUSED_^1*_(9 UNUSED_^1*_'10 Q-REG OF USER_%*SCRATCH AREA_^1*_'11 RETURN TO USER_$*_^1*_'12 I-REG OF USER_%*_^1*_'13 READ/WRITE FLAG_#*_^1*_'14 LIST ADDRESS_'*_^1*_'15 VARIABLES/LIST_$*_^1*_'16 ENCODE/DECODE FLAG *_^1*_'17 FORMAT FLAG_(*_^1*_'18 ERROR FLAG_)*_^1*_'19 FWA OF IO BUFFER_^1*_]_^1*_$SETBFR_!ENTRY FOR SAVING BUFFER ADDRESS_^1*_]_^1€€SETBFR 0_"0_)***SET FORTRAN BUFFER ADDRESS_^1_%IIN 0_^1_%STQ* QS+1_)SAVE USER'S Q REG_565*1429_^1_%LDQ* SETBFR_'=ADDRESS OF 1ST PARAMETER_^1_%TRQ A_O**MSOS4.1**_^1GOABS RTJ PARABS_'GET ABS STRING ADDRESS OF BUFFER_!**MSOS4.1**_^1NEXT_!STA- ARGU1_^1_%INA 9_^1_%STA ARGU0_(SAVE IN PERMANENT LOCATION_(**MSOS4.1**_^1_%INQ 1_^1_%TRQ A_O**MSOS4.1**_^1_%RTJ* (GOABS+1)_#GET ABS ADDR€€ESS OF BUFFER LENGTH_!**MSOS4.1**_^1NEXT1 INQ 1_^1_%STQ* SETBFR_'SAVE RETURN ADDRESS_^1_%TRA Q_^1_%LDA- (ZERO),Q_$=BUFFER LENGTH_^1_%ADD- ARGU1_^1_%INA -1_^1_%STA- (ARGU1)_%=LWA OF BUFFER_^1QS_#LDQ =N$0_)RESTORE USER'S Q REG_265*1429_^1_%EIN 0_^1_%JMP* (SETBFR)_$RETURN_^1*_]_^1*_$Q8QINI_!FIRST CALL SETUP BY FORTRAN - INITIALIZE IO PARAMETERS_^1*_]_^1*_*FORMAT ONLY - DEFLAG=-0€€ (RWFLAG)_^1*_*LIST FORMAT - DEFLAG= 1 (RWFLAG)_^1*_*ENCODE/DECODE DEFLAG=-1 (RWFLAG)_^1*_]_^1Q8QINI 0_"0_)***INITIALIZE IO PARAMETERS_^1_%IIN 0_^1_%STQ* (ARGU0)_%SAVE USERS Q-REG_^1_%LDQ* ARGU0_(=SCRATCH AREA_^1_%LDA- I_^1_%STA- VI,Q_)SAVE USERS I-REG_^1_%LDA* Q8QINI_'=RETURN ADDRESS_^1_%EIN 0_^1_%STA- VR,Q_^1_%STQ- I_,I-REG=LOC OF SCRATCH AREA_^1_%INQ -9_^1_%STQ- ARGU1_^1_%ENA€€ 0_^1_%STA- DEFLAG,I_^1_%STA- ERRFLG,I_^1_%RTJ* NORML_(GET 1ST PARAMETER_^1_%STA- FORTFG,I_$=FORTRAN FORMAT FLAG_^1_%ALS 4_,TEST FOR NO LIST_^1_%SAM NEXT2-*-1_^1_%ENQ -0_+YES, SET FLAG_^1_%STQ- DEFLAG,I_^1NEXT2 ALS 2_^1_%ARS 16_+(READ=0/WRITE=-0)_^1_%STA- ICODE,I_%=ICODE FOR ENCODE/DECODE_^1_%RAO- VR,I_^1_%RTJ* NORML_(GET 3RD PARAMETER_^1_%LDQ- FORTFG,I_^1_%QLS 2_,TEST IF A€€DDRESS OF LU_^1_%SQM NEXT3-*-1_^1_%TRA Q_,YES, GET ACTUAL LU_^1_%LDA- (ZERO),Q_^1NEXT3 TRA Q_,TEST IF LU IS LESS THAN 5_^1_%INQ -5_^1_%SQP NEXT31-*-1_^1_%LDA* LUCONV+4,Q_"CONVERT UNIT 1-4 VIA TABLE_^1NEXT31 ENQ 4_^1_%AND- LPMSK+12_^1_%STA- (ARGU1),Q_#SAVE LU IN CALLING SEQUENCE_^1_%LDA- FORTFG,I_$GET FORTRAN FORMAT FLAG_^1_%ALS 1_^1_%SAM ASCII-*-1_#TEST IF ASCII/BINARY REQ€€UEST_!$$$$MOD$$$$_^1_%LDA- ONEBIT+15_#SET BINARY REQUEST_,$$$$MOD$$$$_^1_%STA- DEFLAG,I_D$$$$MOD$$$$_^1_%JMP* NEXT32_^1ASCII LDA- ONEBIT+12_#SET ASCII REQUEST IN LU_^1_%EOR- (ARGU1),Q_^1_%STA- (ARGU1),Q_^1NEXT32 LDQ- FORTFG,I_G**MSOS 4.1**_^1_%QLS 7_N**MSOS 4.1**_^1_%SQM MASMEM-*-1_E**MSOS 4.1**_^1_%JMP* FTEST_(TEST IF FORMAT REQUEST_+**MSOS 4.1**_^1MASMEM RTJ* NORML_(GET 4TH PA€€RAMETER, WHICH IS_%**MSOS 4.1**_^1_%TRA Q_,SECTOR ADDRESS_3**MSOS 4.1**_^1_%LDA- (ZERO),Q_G**MSOS 4.1**_^1_%ENQ 8_N**MSOS 4.1**_^1_%STA- (ARGU1),Q_#STORE IN LSB OF BUFFER WD 8_%**MSOS 4.1**_^1_%ENQ 7_N**MSOS 4.1**_^1_%CLR A_,SET MSB OF CALL TO ZERO_***MSOS 4.1**_^1_%STA- (ARGU1),Q_#STORE IN WORD 7 OF CALL_***MSOS 4.1**_^1FTEST LDQ- FORTFG,I_$CHECK FORMAT FLAG TO SEE IF RQST *€€*MSOS 4.1**_^1_%QLS 1_,IS ALSO FORMATTED_0**MSOS 4.1**_^1_%SQM FRMT-*-1_G**MSOS 4.1**_^1_%CLR A_N**MSOS 4.1**_^1_%JMP* NEXT4_(REQUEST IS NOT FORMATED IF Q +_"**MSOS 4.1**_^1FRMT_!RTJ* NORML_(FORMATTED - GET PARAMETER_(**MSOS 4.1**_^1_%LDQ- FORTFG,I_G**MSOS 4.1**_^1_%QLS 3_N**MSOS 4.1**_^1_%SQM NEXT4_J**MSOS 4.1**_^1_%TRA Q_N**MSOS 4.1**_^1_%LDA- (ZERO),Q_G**MSOS 4.1**_^1NEXT4€€ STA- ARGU2_(FORMAT ADDRESS OR 0 IF NO FORMAT **MSOS 4.1**_^1_%LDA- (ARGU1)_%=LWA OF BUFFER_^1_%SUB- ARGU1_(=FWA OF BUFFER_^1_%INA -17_*(LWA - FWA + 1) = LENGTH OF BUFFER_#92*3157_^1_%ENQ 5_^1_%STA- (ARGU1),Q_#SET WORDS OF INPUT=LENGTH OF BUFFER_^1_%INQ 1_^1_%LDA- ARGU1_^1_%INA 18_+=FWA OF MESSAGE BUFFER_^1_%STA- (ARGU1),Q_#SAVE IN CALLING SEQUENCE_^1*_]_^1XL_#TRA Q_)BLANK O€€UT ENCODE/DECODE BUFFER_^1_%LDA =N$2020_^1_%STA- (ZERO),Q_^1_%INQ 1_^1_%TRQ A_^1_%LDQ- (ARGU1)_"REACHED END OF BUFFER_^1_%TCQ Q_^1_%AAQ Q_^1_%SQP 1_^1_%JMP* XL_(NO_^1_%LDA- DEFLAG,I_^1_%SAZ GTLST-*-1_#LIST FORMAT TEST_1**MSOS 4.1**_^1_%LDA- FORTFG,I_G**MSOS 4.1**_^1_%ALS 1_N**MSOS 4.1**_^1_%SAP GTLST-*-1_#TEST FOR BINARY WHICH WILL LIST_!**MSOS 4.1**_^1_%LDA- DEFLAG,I_$NOT€€ BINARY--NO LIST NEEDED_'**MSOS 4.1**_^1_%SAM NEXT5-*-1_#SKIP IF NO LIST_2**MSOS 4.1**_^1GTLST LDQ- VR,I_)RETURN TO GET FIRST LIST ADDRESS **MSOS 4.1**_^1_%JMP- (ZERO),Q_G**MSOS 4.1**_^1NEXT5 ENQ 0_,SET VARIABLES/LIST=0_^1_%JMP* NEXT8_^1NORML 0_"0_)***NORMALIZE USERS PARAMETER ADDRESS_^1_%IIN 0_^1_%LDA- VR,I_L**MSOS4.1**_^1_%RTJ* (GOABS+1)_#COMPUTE ABSOLUTE ADDRESS_***MSOS4.€€1**_^1NEXT6 RAO- VR,I_^1_%EIN 0_^1_%JMP* (NORML)_^1LUCONV NUM $08F9,$08FA,$08FB,$08FC_5$$$$MOD$$$$_^1*_]_^1*_$Q8QX_#SECOND CALL SETUP BY FORTRAN - PASS CURRENT LIST ADDRESS_^1*_]_^1*_$THE FOLLOWING ENTRY MUST BE SAVED BY THE SCHEDULER WHEN A FORTRAN_^1*_$PROGRAM MAKES A MONITOR REQUEST OR AN INTERRUPT OCCURS_^1*_]_^1ARGU0 NUM 0_^1*_]_^1*_]_^1Q8QZ_!NOP 0_,ENTRY POINT FOR DOUBL€€E PRECISION_!**MSOS4.1**_^1_%IIN 0_,NUM BINARY_8**MSOS4.1**_^1_%ENA 2_,PREPARE FLAG FOR BINARY. FOR_%**MSOS4.1**_^1_%STA- ARGU2_(DOUBLE PRECISION = 2 FOR THREE_#**MSOS4.1**_^1_%LDA* Q8QZ_)WORD VARIABLE_5**MSOS4.1**_^1_%STA* Q8QX_)MOVE EETURN ADDRESS INTO Q8QX_$**MSOS4.1**_^1_%JMP* Q8QX+2_^1*_]_^1Q8QY_!NOP 0_-ENTRY POINT FOR REAL NUM BINARY_!**MSOS 4.1**_^1_%IIN 0_,CONVERSION._6*€€*MSOS 4.1**_^1_%ENA 1_,PREPARE FLAG FOR BINARY. FOR REAL **MSOS 4.1**_^1_%STA- ARGU2_(= 1 FOR TWO WD RE1L VARIABLE_$**MSOS 4.1**_^1_%LDA* Q8QY_)MOVE RETURN ADDRESS INTO Q8QX_#**MSOS 4.1**_^1_%STA* Q8QX_K**MSOS 4.1**_^1_%JMP* Q8QX+2_I**MSOS 4.1**_^1*_]_^1Q8QX_!0_"0_)***INITIALIZE FORMATTING_^1_%IIN 0_^1_%TRQ A_^1_%ENQ ERRFLG_^1_%LDQ* (ARGU0),Q_^1_%SQP OK-*-1_^1_%LDQ* Q8QX_^1_%I€€NQ 1_^1_%STQ* Q8QX_^1_%TRA Q_^1_%EIN 0_^1_%JMP* (Q8QX)_^1OK_#LDQ* Q8QX_)SAVE RETURN ADDRESS_^1_%EIN 0_^1_%STQ- VR,I_)SAVE RETURN ADDRESS_^1_%RTJ* NORML_(GET LIST PARAMETERS_^1_%LDQ- DEFLAG,I_$TEST IF FORMAT PROCESSING_^1_%SQZ NEXT7-*-1_%WAS INITIALIZED_^1_%ADQ- LPMSK+15_$TEST IF BINARY READ/WRITE_$$$$$MOD$$$$_^1_%INQ 0_K$$$$MOD$$$$_^1_%SQZ NEXT7-*-1_C$$$$MOD$$$$_^1_%IIN 0_S€€63*1375_^1_%JMP GETOUT_'YES, CONTINUE PROCESSING_%$$$$MOD$$$$_^1NEXT7 LDQ- LPMSK+15_$SET VARIABLES/LIST=MAX. NUMBER_^1NEXT8 STQ- VMAX,I_^1_%STA- LST,I_(SAVE LIST PARAMETER ADDRESS_^1_%RAO- DEFLAG,I_$SET FLAG=FORMAT PROCESSING INITIALIZED_^1_%LDA- ICODE,I_%TEST IF READ/WRITE REQUEST_^1_%SAM FORMAT-*-1_^1_%LDQ- ARGU1_(READ REQUEST - GET INPUT RECORD_^1_%JMP* RWREQ_^1FORMAT IIN 0€€_)***FORMAT PROCESSING_^1_%RTJ- (AVOLA)_%RESERVE VOLATILE STORAGE_^1_%NUM 31_^1_%EIN 0_^1_%LDQ- VI,I_^1_%LDA- VR,Q_)=RETURN ADDRESS_^1_%STA- VR,I_^1_%LDA- ICODE,Q_%=ICODE(INPUT=0/OUTPUT=-0)_^1_%STA- ICODE,I_^1_%LDA- DEFLAG,Q_$=ENCODE/DECODE OR READ/WRITE FLAG_^1_%STA- DEFLAG,I_^1_%LDA- VMAX,Q_'=MAX. NUMBER OF PARAMETERS/LIST_^1_%STA- MV,I_^1_%LDA- LST,Q_(=CURRENT PARAMETER ADDRES€€S IN LIST_^1_%STA- LIST,I_^1_%LDA- ARGU1_(SET ADDRESS OF USERS SCRATCH AREA=FWA OF_^1_%INA 18_-BUFFER_^1_%STA- ARGU1_^1_%LDA- DEFLAG,I_$TEST IF BINARY/ASCII REQUEST_*82*2219_^1_%SAP FORM_P82*2219_^1_%RTJ BINARY_'BINARY REQUEST_882*2219_^1_%LDQ- ONEBIT+15_K82*2219_^1_%STQ- DEFLAG,I_L82*2219_^1_%JMP* NEXT9_O82*2219_^1FORM_!RTJ FORMTR_#***PROCESS FORMAT_^1NEXT9 LDQ- ARGU1_(RESET €€ARGU1 BACK TO FWA OF SCRATCH AREA_^1_%INQ -9_^1_%STA- ERRFLG,Q_$SAVE ERROR FLAG IN SCRATCH_^1_%INQ -9_^1_%STQ- ARGU1_^1_%LDA- ICODE,I_%TEST IF WRITE REQUEST_^1_%SAM NEXT10-*-1_^1_%IIN 0_^1_%LDA- VR,I_)RETURN ADDRESS IN VOLATILE_^1_%STA* XIT_*SAVE RETURN ADDRESS_^1_%JMP* RELSE_^1NEXT10 LDA- JBX,I_(REQUEST=WRITE - SET UP WORD COUNT FOR OUTPUT_^1_%INA -1_^1_%ADD- IBX,I_^1_%SAN W€€RDCNT_N86*2748_^1_%ENA 1_,INSURE MINIMUM WORD COUNT_-86*2748_^1WRDCNT STA- 5,Q_*SAVE WORD COUNT IN CALLING SEQUENCE_"86*2748_^1RWREQ ENA 0_)***BUILDING CALLING SEQUENCE_^1_%STA- 3,Q_*SET THREAD=0_^1_%LDA* ARTRN_^1_%STA- 2,Q_*=COMPLETION ADDRESS_^1_%LDA- ICODE,I_^1_%AND* WCODE_(=WRITE REQUEST_^1_%SAN NEXT11-*-1_^1_%LDA* RCODE_(=READ REQUEST_^1NEXT11 ARS 4_^1_%EOR- PRLVL_(SET RE€€QUEST PRIORITY=CURRENT PRIORITY_^1_%ALS 4_^1_%EOR- PRLVL_(SET COMPLETION PRIORITY=CURRENT PRIORITY_^1_%STA- 1,Q_*=REQUEST CODE_^1_%TRQ A_^1_%INA 1_,=ADDRESS OF CALLING SEQUENCE_^1_%IIN 0_^1_%STA* CALL_^1_%LDA- ICODE,I_%TEST FOR INPUT/OUTPUT_^1_%SAP CONTUE-*-1_"=INPUT - BYPASS VOLATILE RELEASE_^1_%INQ 9_,Q-REG=SCRATCH AREA_^1_%LDA- VR,I_)RETURN ADDRESS IN VOLATILE_^1_%STA- VR,€€Q_)SAVE IN SCRATCH_^1_%JMP* RELSE_(RELEASE VOLATILE STORAGE_^1*_!SAVE ADDRESS OF FORMAT TEMPORARILY IN WORD 13 OF USERS_!**MSOS4.0**_^1*_*BUFFER_J**MSOS4.0**_^1CONTUE ENQ SVARG2_J**MSOS4.0**_^1_%LDA- ARGU2_K**MSOS4.0**_^1_%STA- (ARGU1),Q_G**MSOS4.0**_^1_%EIN 0_^1_%RTJ- (AMONI)_"***CALL MONITOR_^1_%NUM $2000_(INDIRECT REQUEST_2**MSOS4.0**_^1CALL_!ADC 0_^1_%JMP- (ADISP)_%MAKE A D€€ISPATCHER CALL_^1RETURN INA -1_+=LOC OF CALLING SEQUENCE_^1_%STA- ARGU1_(RESTORE ADDRESS OF SCRATCH AREA_^1_%TRA Q_^1_%LDA- SVARG2,Q_H**MSOS4.0**_^1_%STA- ARGU2_K**MSOS4.0**_^1_%INQ 9_^1_%STQ ARGU0_(RESTORE_?86*2748_^1_%ENQ SVARG2_J**MSOS4.0**_^1_%CLR A_O**MSOS4.0**_^1_%STA- (ARGU1),Q_G**MSOS4.0**_^1_%LDQ ARGU0_O82*2219_^1_%LDA- ICODE,Q_^1_%SAP NEXT12-*-1_"TEST IF REQUEST=R€€EAD_^1_%IIN 0_,NO - EXIT FROM PROCESSOR_^1_%LDA- VR,Q_)RETURN ADDRESS IN SCRATCH_^1_%STA* XIT_^1_%JMP* EXIT_^1NEXT12 STQ- I_,I-REG=SCRATCH_^1_%JMP* FORMAT_'PROCESS INPUT_^1RELSE RTJ- (AVOLR)_"***RELEASE VOLATILE STORAGE_^1_%LDQ- ARGU1_^1_%INQ 9_^1_%STQ ARGU0_^1_%LDA- ICODE,Q_^1_%SAP EXIT-*-1_^1_%JMP* CONTUE_^1EXIT_!LDA- VI,Q_^1_%STA- I_^1_%LDQ- (ZERO),Q_^1_%EIN 0_^1_%JMP* (XI€€T)_^1_%BZS XIT(1)_^1*_]_^1*_$Q8QEND_!LAST CALL SETUP BY FORTRAN - TERMINATE FORMAT PROCESSING_^1*_]_^1Q8QEND 0_"0_)***TERMINATE FORMAT PROCESSING_^1_%IIN 0_^1_%TRQ A_^1_%ENQ ERRFLG_^1_%LDQ (ARGU0),Q_^1_%SQP OK1-*-1_^1_%TRA Q_^1_%EIN 0_^1_%JMP* (Q8QEND)_^1OK1_"LDQ* Q8QEND_^1*_81 CARD DELETED_881*2106_^1_%STQ- VR,I_)SAVE RETURN_^1_%ENA 1_^1_%STA- MV,I_)SET MV=1(LAST VARIABLE€€ IN LIST)_^1GETOUT LDQ- LIST,I_'=PARAMETER TO BE PROCESSED_^1_%STA- LIST,I_'=NEXT PARAMETER_^1_%LDA- TEMP,I_'=RETURN TO FORMTR_^1_%STA* Q8QGET_^1_%EIN 0_^1_%JMP* (Q8QGET)_^1Q8QGET 0_"0_)***GET PARAMETER ADDRESS_^1_%IIN 0_^1_%LDQ* Q8QGET_'=RETURN ADDRESS TO FORMTR_^1_%STQ- TEMP,I_^1_%LDA- DEFLAG,I_^1BINMSK EOR =N$8001_%MASK AFTER BINARY STARTED_(**MSOS 4.1**_^1_%SAZ PASS-*-1_$-3€€2767 + 1._6**MSOS 4.1**_^1_%EOR* BINMSK+1_G**MSOS 4.1**_^1PASS_!SAM NEXT13-*-1_E**MSOS 4.1**_^1_%LDQ- VR,I_)NO, RETURN FOR NEXT PARAMETER IN LIST_^1_%EIN 0_^1_%JMP- (ZERO),Q_^1NEXT13 LDQ- LIST,I_'ENCODE/DECODE CALL(UPDATE LIST ADDRESS)_^1_%RAO- LIST,I_^1_%LDA- TEMP,I_^1_%STA* Q8QGET_^1_%EIN 0_^1_%JMP* (Q8QGET)_^1ARTRN ADC RETURN_^1WCODE NUM $4C00_(D BIT SET AND WRITE CODE_**€€*MSOS4.0**_^1RCODE NUM $4800_(D BIT SET AND READ CODE_+**MSOS4.0**_^1IOERR 0_"0_)***RETURN ERROR FLAG_^1_%IIN 0_^1_%TRQ A_^1_%ENQ ERRFLG_^1_%LDQ (ARGU0),Q_^1_%LLS 16_^1_%RAO* IOERR_^1_%EIN 0_^1_%JMP* (IOERR)_^1IRWERR NUM 0_,RW ERROR SUBROUTINE_^1_%IIN 0_^1_%TRQ A_,SAVE Q_^1_%ENQ LUFLG_^1_%LDQ (ARGU0),Q_#PICK UP LU IN REQUEST_^1_%LLS 16_+EXCHANGE A AND Q_^1_%RAO* IRW€DERR_(BUMP RETURN_^1_%EIN 0_^1_%JMP* (IRWERR)_%RETURN_^1_%END_]_^__ DPBINARR CSY/ C02 P€1_%NAM BINARR_'DECK-ID C02 FTN 3.3 RUNTIME_%SUMMARY-102_^1*_$REENTRANT UNFORMATTED BINARY I/O REQUEST PROCESSOR_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3_^1*_$SMALL COMPUTER DEVELOPMENT DIVISION, LA JOLLA CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1973_^1_%SPC 2_^1_%SPC 2_^1_(ENT_!BINARY_^1_(EXT_!Q8QGET_^1_(EXT_!INITAL_^1_(EXT_!RSTORE_^1_(EQU_!ZERO($22)_^1_(EQU_!LPMSK(€€2)_^1_(EQU_!ONEBIT($23)_^1_(EQU_!MV(26)_^1_(EQU_!IBX(13)_^1_(EQU_!JBX(14)_^1_(EQU_!LIST(25)_^1_(EQU_!ERRFLG(8)_^1_(EQU_!ICODE(3)_^1_(EQU_!ARGU1($D8)_^1_%EQU_!ARGU2($D9)_^1_%SPC_!5_^1BINARY_!NOP_!0_^1_(IIN_!0_^1_(RTJ_!INITAL_^1_(CLR_!A_^1_(STA- IBX,I_^1_(STA- JBX,I_^1_(LDA- ICODE,I_^1_(SAM_!BWRIT-*-1_^1_(JMP* BREAD_^1BWRIT_"RTJ* ERRTST_'GET ADDRESS OF PARAMETER_^1_(LDQ- LIST,I€€_'GET PARAMETER_^1_(LDA- (ZERO),Q_$GET SETBFR DISPLACEMENT_^1_(LDQ- IBX,I_(GET SETBFR DISPLACEMENT_^1_(RAO- IBX,I_(INCREASE BUFFER DISPLACEMENT_^1_(STA- (ARGU1),Q_#STORE PARAMETER IN BUFFER_^1_%LDA- ARGU2_'ARGU2 = 0 INTEGER ONE WORD MOVE_^1_%INA -1_*ARGU2 = 1 REAL_"TWO WORD MOVE_^1_%SAM NEXT_(ARGU2 = 2 DP_"THREE WORD MOVE_^1_%STA- ARGU2_(MOVE ANOTHER WORD_^1_%RAO LIST,I_^€€1_%JMP* BWRIT_^1NEXT_#CLR_!A_^1_%STA- ARGU2_%CLAER FLAG FOR NEST LIST ELEMENT_^1_(RTJ+ Q8QGET_'NO, GET NEXT VARIABLE ADDRESS_^1_(LDA- MV,I_)IF NO MORE VARIABLES Q8QEND SETS MV > 1_^1_(INA_!-1_^1_(INA_!0_^1_(SAN_!LOOPCT_'TEST IF ANY MORE VAIRABLES_^1_(JMP* RETURN_'NO, RETURN TO Q8QIO_^1LOOPCT_!JMP* BWRIT_(YES, MOVE VARIABLE_^1_%SPC_!2_^1BREAD_"RTJ* ERRTST_'GET BUFFER DISPLACEM€€ENT_^1_(LDQ- IBX,I_(INCREASE_^1_(RAO- IBX,I_(INCREASE BUFFER DISPLAXENT_^1_(LDA- (ARGU1),Q_#GET QUANTITY_^1_(LDQ- LIST,I_'GET ADDRESS OF VARIABLE_^1_(STA- (ZERO),Q_$PUT QUANTITY IN VARIABLE_^1_%LDA- ARGU2_(ARGU2 = 0 ONE WORD VARIABLE_^1_%INA -1_+ARGU2 = 1 TWO WORD VARIABLE_^1_%SAM NEXT1_(ARGU2 = 2 THREE WORD VARIABLE_^1_%STA- ARGU2_(MOVE ANOTHER WORD_^1_%RAO LIST,I_^1_%JMP*€€ BREAD_^1NEXT1_"CLR_!A_^1_%STA- ARGU2_%CLAER FLAG FOR NEST LIST ELEMENT_^1_(RTJ+ Q8QGET_'YES, GET NEXT LIST ADDRESS_^1_(LDA- MV,I_)TEST IF FINISHED_^1_(INA_!-1_^1_(INA_!0_^1_%SAZ RETURN_'END OF LIST VARIABLES_192*3158_^1_%JMP* BREAD_(TRANSFER INTO NEXT VARIABLE_+92*3158_^1RETURN RAO- IBX,I_^1_$JMP+ RSTORE_$*******FINISHED******_^1ERRTST_!NOP_!0_^1_(IIN_!0_^1_(LDQ- ARGU1_^1_%€€INQ -13_*POINT TO ADDRESS OF BUFFER SIZE_'92*3158_^1_(LDA- (ZERO),Q_$GET NUMBER OF WORDS IN BUFFER_^1_(SUB- IBX,I_(SUBTRACT DISPLACEMTN ALREADY USED IN BUFFER_^1_(SAP_!OK-*-1_'NO ERROR IF WORDS REMAINING_^1_(LDQ- ARGU1_(**ERROR - TURN ON SIGN BIT IN ERRFLG IN B_^1_(INQ_!-1_^1_(LDA- (ZERO),Q_^1_(AND- LPMSK+15_^1_(EOR- ONEBIT+15_^1_(STA- (ZERO),Q_^1_(EIN_!0_^1_(JMP* RETURN_^€*1OK_%EIN_!0_^1_(JMP* (ERRTST)_^1_(END_^__*PQ8QGTR CSY/ C03 P`1_%NAM Q8QGTR_'DECK-ID C03 FTN 3.3 RUNTIME_%SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3_^1*_$SMALL COMPUTER DEVELOPMENT DIVISION, LA JOLLA CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1973_^1_%SPC 2_^1_%ENT Q8QGET_^1_%EQU LIST(25)_^1Q8QGET 0_"0_^1_%IIN 0_^1_%LDQ- LIST,I_^1_%RAO- LIST,I_^1_%EIN 0_^1_%JMP* (Q8QGET)_^1_%END_]_^__`PIOCODR CSY/ D01 P€1_%NAM IOCODR_'DECK-ID D01 FTN 3.3 RUNTIME_%SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3_^1*_$SMALL COMPUTER DEVELOPMENT DIVISION, LA JOLLA CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1973_^1_%SPC 2_^1*_+CALLING SEQUENCE_^1*_*RTJ ENCODE/DECODE_^1*_*ADC (BUFFER-*)_^1*_*ADC (FORMAT-*)_^1*_*ADC (NUMBER-*)_^1*_*ADC (LIST-*)_^1*_*FORMAT ADC ALPHA_^1*_0ALPHA AL€€F N,(----)_^1*_]_^1_%ENT ENCODE_^1_%ENT DECODE_^1_%EXT FORMTR_^1_%EQU LPMSK(2)_^1_%EQU ZERO($22)_^1_%EQU AVOLA($BB)_^1_%EQU AVOLR($BA)_^1_%EQU ARGU1($D8)_^1_%EQU ARGU2($D9)_^1_%EQU VR(1)_^1_%EQU ICODE(3)_^1_%EQU DEFLAG(6)_^1_%EQU LIST(25)_^1_%EQU MV(26)_^1_%EXT PARABS_J**MSOS4.1**_^1ENCODE 0_"0_)***SET UP CALLING SEQUENCE_^1_%IIN 0_,FOR FORMATTING DATA_^1_%RTJ- (AV€€OLA)_^1_%NUM 31_^1_%LDQ* ENCODE_'RESERVE VOLATILE(SCRATCH)_^1_%EIN 0_^1_%STQ- VR,I_)=RETURN ADDRESS_^1_%ENA -0_^1NEXT_!STA- ICODE,I_^1_%ENA -1_^1_%STA- DEFLAG,I_^1_%RTJ* NORML_^1_%STA- ARGU1_(=BUFFER ADDRESS_^1_%RTJ* NORML_^1_%TRA Q_^1_%LDA- (ZERO),Q_^1_%STA- ARGU2_(=FORMAT ADDRESS_^1_%RTJ* NORML_^1_%TRA Q_^1_%LDA- (ZERO),Q_^1_%STA- MV,I_)==NUMBER OF VARIABLES/LIST_^1_%RTJ* N€€ORML_^1_%STA- LIST,I_'=ADDRESS OF LIST_^1_%RTJ FORMTR_'FORMAT DATA_^1_%IIN 0_^1_%STA* XIT+1_^1_%LDA- VR,I_^1_%STA* XIT_^1_%RTJ- (AVOLR)_%RETURN VOLATILE_^1_%LDA* XIT+1_^1_%EIN 0_^1_%JMP* (XIT)_(RETURN TO USER_^1_%BSS XIT(2)_^1DECODE 0_"0_)***SET UP CALLING SEQUENCE TO_^1_%IIN 0_,INTERPERT DATA_^1_%RTJ- (AVOLA)_^1_%NUM 31_^1_%LDQ* DECODE_^1_%EIN 0_^1_%STQ- VR,I_)=RETURN ADDRE€ÜSS_^1_%ENA 0_^1_%JMP* NEXT_^1NORML 0_"0_)***NORMALIZE FORTRAN ADDRESS-_^1_%IIN 0_,ES_^1_%LDA- VR,I_L**MSOS4.1**_^1_%RAO- VR,I_^1_%RTJ PARABS_'COMPUTE ADDRESS_3**MSOS4.1**_^1NXT_"EIN 0_^1_%JMP* (NORML)_^1_%END_]_^__ ÜPINITLR CSY/ D02 P€1_%NAM INITLR_'DECK-ID D02 FTN 3.3 RUNTIME_%SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3_^1*_$SMALL COMPUTER DEVELOPMENT DIVISION, LA JOLLA CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1973_^1_%SPC 2_^1*_$INITIALIZE VOLATILE STORAGE, SAVE RETURN ADD-_^1*_'RESSES, AND PICK UP PARAMETERS_^1*_*CALLING SEQUENCE_^1*_*SUBR 0_"0_^1*_0IIN 0_^1*_0RTJ INITAL_^1*_*I-REGI€€STER POINTS TO PREVIOUS VOLATILE_^1*_*BLOCK_^1*_]_^1_%ENT INITAL_^1_%EQU VR1(1)_^1_%EQU VI(2)_^1_%EQU VP1(3)_^1_%EQU VP2(4)_^1_%EQU ONE(VR1)_^1_%EQU ZERO($22)_^1_%EQU AVOLA($BB)_^1_%EQU VOLATL($F0)_^1_%EQU ARGU1($D8)_^1_%EQU ARGU2($D9)_^1INITAL 0_"0_(***SET ASIDE VOLATILE FOR_^1_%RTJ- (AVOLA)_%EACH SUBROUTINE CALLED_^1_%NUM 5_^1_%LDQ* INITAL_^1_%INQ -4_^1_%LDQ- (ZERO),€Q_$GET THE RETURN ADDRESS_^1_%STQ- VR1,I_*FROM CALLING SUBROUTINE_^1_%LDQ- VI,I_)=LOC OF SCRATCH AREA_^1_%LDA- ARGU1_^1_%STA- VP1,I_(SAVE THE ARGUMENTS OF THE_^1_%LDA- ARGU2_*CALLING SUBROUTINE_^1_%STA- VP2,I_^1_%STQ- I_^1_%EIN 0_^1_%JMP* (INITAL)_^1_%END_]_^__PRSTORR CSY/ D03 P€1_%NAM RSTORR_'DECK-ID D03 FTN 3.3 RUNTIME_%SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3_^1*_$SMALL COMPUTER DEVELOPMENT DIVISION, LA JOLLA CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1973_^1_%SPC 2_^1*_$RESTORE VOLATILE STORAGE AND PARAMETERS_^1*_*CALLING SEQUENCE_^1*_0JMP RSTORE_^1*_*SAVES A-REGISTER_^1*_*Q,I ON ENTRY ARE NOT USED_^1*_*RSTORE RETURNS TO THE U€€SER WHICH CALLED_^1*_*A SUBROUTINE WHICH CALLED INITAL_^1*_]_^1_%ENT RSTORE_^1_%EQU VOLATL($F0)_^1_%EQU AVOLR($BA)_^1_%EQU VP1(3)_^1_%EQU VP2(4)_^1_%EQU ARGU1($D8)_^1_%EQU ARGU2($D9)_^1RSTORE IIN 0_(***RSTORE VOLATILE_^1_%STA* TEMP_)SAVE A-REG_^1_%LDA- VOLATL_^1_%INA -5_^1_%STA- I_,=LOC OF VOLATILE_^1_%LDA- VP1,I_^1_%STA- ARGU1_^1_%LDA- VP2,I_^1_%STA- ARGU2_^1_%RTJ- (AVOLR€‚)_^1_%STA* XIT_*=RETURN ADDRESS_^1_%LDA* TEMP_)RESTORE A-REG_^1_%EIN 0_^1_%JMP* (XIT)_^1XIT_"NUM 0_^1TEMP_!NUM 0_^1_%END_]_^__ ‚PGETCHR CSY/ D04 P€1_%NAM GETCHR_'DECK-ID D04 FTN 3.3 RUNTIME_%SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3_^1*_$SMALL COMPUTER DEVELOPMENT DIVISION, LA JOLLA CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1973_^1_%SPC 2_^1*_$GET NEXT CHARACTER IN STRING_^1_%ENT IGETCH_^1_%ENT GETCH_^1_%EXT INITAL_^1_%EXT RSTORE_^1_%EXT EWRITE_^1_%EQU ARGU1($D8)_^1_%EQU ARGU2($D9)_^1_%EQU ARG€€U3($DA)_^1_%EQU ARGU4($DB)_^1_%EQU DEFLAG(6)_^1_%EQU MAXCH(28)_^1IGETCH 0_"0_)***PICK UP NEXT CHARACTER IN_^1_%IIN 0_,BUFFER_^1_%RTJ INITAL_^1_%LDQ- DEFLAG,I_^1_%SQM BYPASS-*-1_^1_%LDA- MAXCH,I_%YES, REDUCE CHARACTER COUNT(TOTAL)_^1_%INA -1_^1_%STA- MAXCH,I_^1_%SAP BYPASS-*-1_"TEST IF 80 CHARACTERS INTERPERTED_^1_%RTJ EWRITE_'YES, ERROR_^1GETCH 0_"0_)***PICK UP CHARACTER €dIN FORMAT_^1_%IIN 0_^1_%RTJ INITAL_^1BYPASS LDQ- (ARGU4)_%=CHARACTER COUNT(ORDINAL TO CHARACTER/WORD)_^1_%LDA- (ARGU3)_%=WORD CONTAINING NEXT_^1_%AND* MSK-1,Q_(CHARACTER_^1_%INQ -2_^1_%SQZ OUT-*-1_^1_%ALS 8_,SHIFT TO LOWER HALF OF WORD_^1OUT_"JMP RSTORE_^1MSK_"NUM $FF00_(THESE MASKS MUST BE IN CON_^1_%NUM $FF_,SECUTIVE LOC.(INDEXED)_^1_%END_]_^__dPIPACKR CSY/ D05 P€1_%NAM IPACKR_'DECK-ID D05 FTN 3.3 RUNTIME_%SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3_^1*_$SMALL COMPUTER DEVELOPMENT DIVISION, LA JOLLA CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1973_^1_%SPC 2_^1*_$PACK CHARACTER INTO A STRING_^1_%ENT IPACK_^1_%EXT INITAL_^1_%EXT EWRITE_^1_%EXT RSTORE_^1_%EXT CHCNT_^1_%EQU MSK($1A)_$=$FF00_^1_%EQU ZERO($22)_^1_%EQU €€ I8($26)_^1_%EQU ARGU1($D8)_^1_%EQU ARGU3($DA)_^1_%EQU ARGU4($DB)_^1_%EQU ICODE(3)_L92*3122_^1_%EQU IB(5)_^1_%EQU DEFLAG(6)_^1_%EQU IBX(13)_^1_%EQU JBX(14)_^1_%EQU MAXCH(28)_^1IPACK 0_"0_)***STORE CHARACTER INTO THE_^1_%IIN 0_,BUFFER_^1_%RTJ INITAL_^1_%LDA- DEFLAG,I_$TEST IF ENCODE/DECODE CALL_^1_%ALS 15_^1_%SAP NXT-*-1_^1_%LDA- ICODE,I_%IS TRANSFER FROM BUFFER_/92*31€€22_^1_%INA -1_+INTO FORMAT STATEMENT_192*3122_^1_%SAZ NOCHK_(YES SKIP BUFFER LENGTH CHECK_)92*3122_^1_%ENQ -18_*NO(READ/WRITE)-CHECK IF BUFFER SIZE EXCEEDED_^1_%LDA- (ARGU1),Q_#LWA OF BUFFER_^1_%SUB- ARGU3_(=CURRENT ADDRESS TO BE PACKED_^1_%SAP NXT-*-1_^1P1_#RTJ EWRITE_^1NXT_"LDQ- DEFLAG,I_$TEST IF READ/WRITE REQUEST_^1_%QLS 15_^1_%LDA- MAXCH,I_^1_%INA -1_+REDUCE CHARACTER €€COUNT_^1_%STA- MAXCH,I_^1_%SAM CHECK-*-1_#IF CHARACTER COUNT LT ZERO(=FULL LINE)_^1NOCHK JMP* NXT4_)AND READ/WRITE RQST-INSERT / IN RECRD 92*3122_^1CHECK SQM NXT1-*-1_^1_%RTJ* (P1+1)_'OTHERWISE---ERROR_^1NXT1_!LDA- (ARGU4)_^1_%INA -2_+=ORDINAL TO CHARACTER/WORD_^1_%SAZ NXT2-*-1_$TEST WHICH 1/2 OF WORD CHARACTER IS_^1_%ENA 13_+UPPER 1/2 (INSERT CARRIAGE RETURN)_^1_%ALS 8_^1€€_%STA- (ARGU3)_%STORE IN BUFFER_^1_%RAO- (ARGU4)_%UPDATE ORDINAL_^1_%JMP* NXT3_^1NXT2_!LDA- (ARGU3)_%PACK IN LOWER 1/2 OF WORD IN BUFFER_^1_%AND- MSK_^1_%INA 13_+ADD IN CARRIAGE RETURN_^1_%STA- (ARGU3)_^1_%RAO- ARGU3_^1_%LDQ- ARGU4_^1_%ENA 1_^1_%STA- (ZERO),Q_^1_%INQ -1_^1_%RAO- (ZERO),Q_^1NXT3_!LDA CHCNT_(RESET CHARACTER COUNT(TOTAL/LINE)_^1_%STA- MAXCH,I_^1NXT4_!LDA- (ARGU4)_€€%TEST IF CHARACTER COUNT=2_^1_%INA -2_^1_%SAZ NXT5-*-1_^1_%LDA- (ARGU3)_%SAVE CONTENTS OF LOWER HALF OF WORD_"91*2908_^1_%AND- MSK-16_'$00FF_A91*2908_^1_%STA- ARGU1_(TEMPORARY HOLDER_691*2908_^1_%LDA- IB,I_)NO, SHIFT CHARACTER INTO_^1_%ALS 8_.UPPER HALF OF WORD_^1_%ADD- ARGU1_(COMBINE WITH LOWER HALF_/91*2908_^1_%JMP* XIT_^1NXT5_!LDA- (ARGU3)_%YES, MASK CHARACTER INTO_^1_%AND- M€RSK_^1_%ADD- IB,I_^1XIT_"STA- (ARGU3)_%SAVE IN BUFFER_^1_%JMP RSTORE_^1_%END_]_^__RPUPDATR CSY/ D06 P€1_%NAM UPDATR_'DECK-ID D06 FTN 3.3 RUNTIME_%SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3_^1*_$SMALL COMPUTER DEVELOPMENT DIVISION, LA JOLLA CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1973_^1_%SPC 2_^1*_$UPDATE BUFFER/FORMAT COUNTERS_^1_%ENT UPDATE_^1_%EXT INITAL_^1_%EXT RSTORE_^1_%EQU ARGU3($DA)_^1_%EQU ARGU4($DB)_^1UPDATE 0_"0_)***UPDATE WORD AND CHARACTE€üR_^1_%IIN 0_.COUNT_^1_%RTJ INITAL_^1_%LDA- (ARGU4)_%TEST CHARACTER COUNT=1_^1_%INA -1_^1_%SAZ NXT-*-1_^1_%RAO- (ARGU3)_%NO, WORD COUNT=COUNT+1_^1NXT_"ENA 3_^1_%SUB- (ARGU4)_%SET CHARACTER COUNT=3-CNT_^1_%STA- (ARGU4)_^1_%JMP RSTORE_^1_%END_]_^__ üPDECPLR CSY/ D07 P€1_%NAM DECPLR_'DECK-ID D07 FTN 3.3 RUNTIME_%SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3_^1*_$SMALL COMPUTER DEVELOPMENT DIVISION, LA JOLLA CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1973_^1_%SPC 2_^1*_$DETERMINE THE NUMBER OF CHARACTERS BEHIND THE_^1*_$DECIMAL POINT_^1_%ENT DECPL_^1_%EXT INITAL_^1_%EXT GETCH_^1_%EXT UPDATE_^1_%EXT INTGR_^1_%EXT RSTORE_^1€€_%EQU ARGU1($D8)_^1_%EQU ARGU2($D9)_^1_%EQU ARGU3($DA)_^1_%EQU ARGU4($DB)_^1_%EQU NXTFLD($E0)_^1_%EQU IB(5)_^1_%EQU IFIELD(7)_^1_%EQU JFIELD(8)_^1_%EQU IX(11)_^1_%EQU JX(12)_^1DECPL 0_"0_)***NO. OF DECIMAL PLACES SPEC_^1_%IIN 0_,IFIED IN THE FORMAT_^1_%RTJ INITAL_^1_%LDA- IFIELD,I_^1_%STA- NXTFLD_^1_%LDA- ARGU3_^1_%STA- ARGU1_^1_%ADD- IX,I_^1_%STA- ARGU3_(=FORMAT+WORD €€COUNT_^1_%ENA 0_^1_%STA- IB,I_^1_%ENA JX_^1_%ADD- I_^1_%STA- ARGU4_(=CHARACTER CNT_^1_%RTJ GETCH_^1_%INA -$2E_)TEST IF CHARACTER=PERIOD_^1_%SAN NXT-*-1_^1_%ENA IX_+YES, UPDATE FORMAT COUNT_^1_%ADD- I_^1_%STA- ARGU3_^1_%INA 1_^1_%STA ARGU4_^1_%RTJ UPDATE_^1_%LDA- ARGU1_^1_%STA- ARGU3_(=ADDRESS OF FORMAT_^1_%RTJ INTGR_(COMPUTE INTEGER VALUE_^1NXT_"LDA- IB,I_)=NO. OF PLACES €lBEYOND THE_^1_%STA- JFIELD,I_'DECIMAL POINT_^1_%LDA- NXTFLD_^1_%STA IFIELD,I_^1_%JMP RSTORE_^1_%END_]_^__ lPINTGRR CSY/ D08 P€1_%NAM INTGRR_'DECK-ID D08 FTN 3.3 RUNTIME_%SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3_^1*_$SMALL COMPUTER DEVELOPMENT DIVISION, LA JOLLA CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1973_^1_%SPC 2_^1*_$DETERMINE FIELD WIDTH AS SPECIFIED BY FORMAT_^1*_$AND CONVERT INTEGER VALUE_^1_%ENT INTGR_^1_%EXT INITAL_^1_%EXT GETCH_^1_%EXT UPDATE_^1_%EXT RSTORE_^1_%EQ€€U ARGU1($D8)_^1_%EQU ARGU3($DA)_^1_%EQU ARGU4($DB)_^1_%EQU MSK(6)_'=$F_^1_%EQU I10($46)_$=10_^1_%EQU IB(5)_^1_%EQU IFIELD(7)_^1_%EQU IX(11)_^1_%EQU JX(12)_^1_%EQU IR1(15)_^1INTGR 0_"0_)***CONVERT INTEGER VALUES IN_^1_%IIN 0_,FORMAT_^1_%RTJ INITAL_^1_%LDA- ARGU3_(RESTORE ARGUMENT VALUE_^1_%STA- ARGU1_*FROM ARGU3 TO ARGU1_^1_%ENA 0_^1_%STA- IB,I_^1LOOP_!LDA- ARGU1_^1_%A€€DD- IX,I_^1_%STA- ARGU3_(=ADDRESS OF WORD IN FORMAT_^1_%ENA JX_^1_%ADD- I_^1_%STA- ARGU4_(=CHARACTER IN FORMAT_^1_%RTJ GETCH_(GET CHARACTER_^1_%TRA Q_,SAVE CHARACTER IN Q-REG_^1_%INA -$20_^1_%SAN NXT-*-1_^1_%JMP* ENDLP_(IGNORE BLANKS IN FORMAT_^1NXT_"TRQ A_^1_%INA -$30_^1_%SAP NXT1-*-1_^1_%JMP* OUT_*=NON-NUMERIC CHARACTER - TERMINATE_^1NXT1_!TCQ A_^1_%INA $39_^1_%SAP NXT€h2-*-1_^1_%JMP* OUT_*TERMINATE_^1NXT2_!TRQ A_^1_%AND- MSK_*MASK 4-BITS OF ASCII NUMBER_^1_%STA- IR1,I_^1_%LDA- IB,I_)COMPUTE INTEGER NUMBER_^1_%MUI- I10_^1_%ADD- IR1,I_^1_%STA- IB,I_^1ENDLP ENA IX_+UPDATE FORMAT COUNTS_^1_%ADD- I_^1_%STA- ARGU3_^1_%INA 1_^1_%STA- ARGU4_^1_%RTJ UPDATE_'UPDATE CHARACTER COUNT_^1_%JMP* LOOP_^1OUT_"JMP RSTORE_^1_%END_]_^__ hPSPACER CSY/ D09 P€1_%NAM SPACER_'DECK-ID D09 FTN 3.3 RUNTIME_%SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3_^1*_$SMALL COMPUTER DEVELOPMENT DIVISION, LA JOLLA CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1973_^1_%SPC 2_^1*_$INSERT BLANKS INTO BUFFER_^1_%ENT SPACEX_^1_%EXT INITAL_^1_%EXT IGETCH_^1_%EXT UPDATE_^1_%EXT IPACK_^1_%EXT RSTORE_^1_%EQU ZERO($22)_^1_%EQU ARGU1($D8)_€€^1_%EQU ARGU2($D9)_^1_%EQU ARGU3($DA)_^1_%EQU ARGU4($DB)_^1_%EQU IB(5)_^1_%EQU IX(11)_^1_%EQU JX(12)_^1_%EQU IBX(13)_^1_%EQU JBX(14)_^1SPACEX 0_"0_)***INSERT BLANKS_^1_%IIN 0_^1_%RTJ INITAL_^1_%ENA $20_^1_%STA- IB,I_^1_%LDA- ARGU3_^1_%STA- ARGU1_^1_%ADD- IBX,I_^1_%STA- ARGU3_^1_%ENA JBX_*PACK BLANK INTO BUFFER_^1_%ADD- I_^1_%STA- ARGU4_^1_%RTJ IPACK_^1_%ENA IBX_^1_%AD€tD- I_^1_%STA- ARGU3_^1_%INA 1_^1_%STA- ARGU4_^1_%RTJ UPDATE_'UPDATE BUFFER COUNTERS_^1_%JMP RSTORE_^1_%END_]_^__ tPHOLR CSY/ D10 P€1_%NAM HOLR_)DECK-ID D10 FTN 3.3 RUNTIME_%SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3_^1*_$SMALL COMPUTER DEVELOPMENT DIVISION, LA JOLLA CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1973_^1_%SPC 2_^1*_$REENTRANT ENCODE/DECODE TO PACK HOLLERITH CHARACTERS_"FTN*3.2_^1*_$INTO A BUFFER. MODIFIED FOR FORTRAN 3.2 TO HANDLE H_"FTN*3.2_^1*_$FORMAT, OR ALTERNATE QUOTE O€€R ASTERISK H FORMAT PRODUCEDFTN*3.2_^1*_$INFORMATION._KFTN*3.2_^1*_]_^1_%ENT HOLRTH_^1_%ENT QUOTE_MFTN*3.2_^1_%EXT INITAL_^1_%EXT IGETCH_^1_%EXT GETCH_^1_%EXT UPDATE_^1_%EXT IPACK_^1_%EXT RSTORE_^1_%EXT CHCNT_^1_%EQU ZERO($22)_^1_%EQU ARGU1($D8)_^1_%EQU ARGU2($D9)_^1_%EQU ARGU3($DA)_^1_%EQU ARGU4($DB)_^1_%EQU ICODE(3)_^1_%EQU IB(5)_^1_%EQU NUMBR(9)_^1_%EQU IX(11)_€€^1_%EQU JX(12)_^1_%EQU IBX(13)_^1_%EQU JBX(14)_^1_%EQU MAXCH(28)_^1_%EQU QAFLAG($D3)_GFTN*3.2_^1HOLRTH 0_"0_)***PACK HOLLERITH CHARACTERS_^1_%IIN 0_^1_%RTJ INITAL_^1_%LDA- ARGU3_^1_%STA- ARGU1_^1_%LDA- ARGU4_^1_%STA- ARGU2_^1_%RAO- NUMBR,I_^1LOOP_!LDA- NUMBR,I_%=TOTAL NUMBER CHARACTERS_^1_%INA -1_^1_%SAN NXT-*-1_^1_%JMP RSTORE_LFTN*3.2_^1NXT_"STA- NUMBR,I_^1_%LDA- ARGU2_^€€1_%ADD- IX,I_^1_%STA- ARGU3_^1_%ENA JX_^1_%ADD- I_^1_%STA- ARGU4_(GET CHARACTER FROM INPUT_^1_%LDA- ICODE,I_^1_%SAM BYPASS-*-1_^1_%RTJ IGETCH_)BUFFER_^1_%JMP* CONTUE_^1BYPASS RTJ GETCH_^1CONTUE STA- IB,I_^1_%ENA IX_^1_%ADD- I_^1_%STA- ARGU3_^1_%INA 1_^1_%STA- ARGU4_^1_%RTJ UPDATE_'UPDATE BUFFER COUNTS_^1_%LDA- IB,I_^1_%INA -$31_)TEST CHARACTER=$31_^1_%SAN NXT1-*-1_^1_%LDA-€€ MAXCH,I_%YES, TEST IF 1ST CHARACTER_^1_%SUB CHCNT_*IN BUFFER_^1_%SAN NXT1-*-1_^1_%ENA 12_+YES, CHANGE TO TOP-OF-FORM_^1_%STA- IB,I_^1_%JMP* PACK_^1NXT1_!LDA- IB,I_)TEST CHARCACTER=$30_^1_%INA -$30_^1_%SAN PACK-*-1_^1_%LDA- MAXCH,I_%YES, TEST 1ST CHARACTER IN_^1_%SUB CHCNT_*BUFFER_^1_%SAN PACK-*-1_^1_%ENA 13_+YES, CHANGE TO CARRIAGE RETURN_^1_%STA- IB,I_^1PACK_!LDA- ARGU1_^€€1_%ADD- IBX,I_^1_%STA- ARGU3_^1_%ENA JBX_^1_%ADD- I_^1_%STA- ARGU4_^1_%RTJ IPACK_(PACK CHARACTER INTO OUTPUT_^1_%ENA IBX_^1_%ADD- I_^1_%STA- ARGU3_^1_%INA 1_^1_%STA- ARGU4_^1_%RTJ UPDATE_^1_%JMP* LOOP_^1QUOTE NOP 0_,PACK HOLLERITH CHAR. INTO A BUFFER_!FTN*3.2_^1_%IIN 0_QFTN*3.2_^1_%RTJ INITAL_LFTN*3.2_^1_%LDA- ARGU3_MFTN*3.2_^1_%STA- ARGU1_MFTN*3.2_^1_%LDA- ARGU4_MFTN*3.2_€€^1_%STA- ARGU2_MFTN*3.2_^1LOOP1 LDA- ARGU2_MFTN*3.2_^1_%ADD- IX,I_NFTN*3.2_^1_%STA- ARGU3_MFTN*3.2_^1_%ENA JX_PFTN*3.2_^1_%ADD- I_QFTN*3.2_^1_%STA- ARGU4_MFTN*3.2_^1_%LDA- ICODE,I_%READ/DECODE (ICODE=+)_/FTN*3.2_^1_%SAM WRTENC_'WRITE/ENCODE(ICODE=-)_/FTN*3.2_^1_%RTJ IGETCH_'GET NEXT CHAR FROM INPUT BUFFER_$FTN*3.2_^1_%JMP* SAVE_NFTN*3.2_^1WRTENC RTJ GETCH_(GET NEXT CHAR FROM F€€ORMAT BUFFER_#FTN*3.2_^1SAVE_!STA- IB,I_)IB CONTAINS NEXT CHARACTER_*FTN*3.2_^1_%ENA IX_PFTN*3.2_^1_%ADD- I_QFTN*3.2_^1_%STA- ARGU3_MFTN*3.2_^1_%INA 1_QFTN*3.2_^1_%STA- ARGU4_MFTN*3.2_^1_%RTJ UPDATE_'UPDATE FORMAT BUFFER COUNTS_)FTN*3.2_^1_%LDA- QAFLAG_LFTN*3.2_^1_%INA -1_PFTN*3.2_^1_%SAN ASTER_(IS QAFLAG = 1_7FTN*3.2_^1_%LDA- IB,I_)YES-APOSTROPHE_6FTN*3.2_^1_%INA -$27_NFTN*3€€.2_^1_%SAN CONTIN_'IS NEXT CHARACTER AN APOSTROPHE_$FTN*3.2_^1_%JMP* OUT_*YES-RETURN TO CALLING PROGRAM_'FTN*3.2_^1*_8AND CONTINUE FORMAT SCAN_,FTN*3.2_^1ASTER LDA- IB,I_)NO-ASTERISK_9FTN*3.2_^1_%INA -$2A_NFTN*3.2_^1_%SAN CONTIN_'IS NEXT CHARACTER AN ASTERISK_'FTN*3.2_^1_%JMP* OUT_*YES-RETURN TO CALLING PROGRAM_'FTN*3.2_^1*_8AND CONTINUE FORMAT SCAN_,FTN*3.2_^1*_]FTN*3.2_^1*_8N€€OT SECOND ASTERISK OR SECOND QUOTE FTN*3.2_^1*_8PACK CHARACTER INTO BUFFER_*FTN*3.2_^1*_]FTN*3.2_^1CONTIN LDA- IB,I_)OBTAIN NEXT CHARACTER_/FTN*3.2_^1_%INA -$31_)IS CHARACTER AN ASCII 1_-FTN*3.2_^1_%SAN NOTONE_LFTN*3.2_^1_%LDA- MAXCH,I_%YES, TEST IF FIRST CHARACTER_(FTN*3.2_^1_%SUB CHCNT_(IN BUFFER_;FTN*3.2_^1_%SAN NOTONE_LFTN*3.2_^1_%ENA 12_+YES, FIRST CHARACTER IN BUFFER IS€€ 1 FTN*3.2_^1_%STA- IB,I_)CHANGE TO TOP OF FORM_/FTN*3.2_^1_%JMP* PACKER_LFTN*3.2_^1NOTONE LDA- IB,I_NFTN*3.2_^1_%INA -$30_)IS CHARACTER AN ASCII 0_-FTN*3.2_^1_%SAN PACKER_LFTN*3.2_^1_%LDA- MAXCH,I_%YES, TEST IF FIRST CHARACTER_(FTN*3.2_^1_%SUB CHCNT_(IN BUFFER_;FTN*3.2_^1_%SAN PACKER_LFTN*3.2_^1_%ENA 13_+YES, FIRST CHARACTER IN BUFFER IS 0 FTN*3.2_^1_%STA- IB,I_)CHANGE TO C€€ARRIAGE RETURN_+FTN*3.2_^1PACKER LDA- ARGU1_(FORMAT ADDR/WRITE OR BUF ADDR/READ_!FTN*3.2_^1_%ADD- IBX,I_MFTN*3.2_^1_%STA- ARGU3_MFTN*3.2_^1_%ENA JBX_*CURRENT CHARACTER ADDRESS_+FTN*3.2_^1_%ADD- I_,FWA OF COMMON_7FTN*3.2_^1_%STA- ARGU4_MFTN*3.2_^1_%RTJ IPACK_(PACK CHARACTER INTO BUFFER_*FTN*3.2_^1_%ENA IBX_*CURRENT WORD IN BUFFER_.FTN*3.2_^1_%ADD- I_QFTN*3.2_^1_%STA- ARGU3_MFTN*3€ž.2_^1_%INA 1_QFTN*3.2_^1_%STA- ARGU4_MFTN*3.2_^1_%RTJ UPDATE_'UPDATE BUFFER COUNTS (IX,JX)_(FTN*3.2_^1_%JMP* LOOP1_MFTN*3.2_^1OUT_"JMP RSTORE_^1_%END_]_^__žPDCHXR CSY/ D11 P€1_%NAM DCHXR_(DECK-ID D11 FTN 3.3 RUNTIME_%SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3_^1*_$SMALL COMPUTER DEVELOPMENT DIVISION, LA JOLLA CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1973_^1_%SPC 2_^1*_$CONVERT DECIMAL TO HECIDECIMAL_^1_%ENT DCHX_^1_%EXT INITAL_^1_%EXT IGETCH_^1_%EXT UPDATE_^1_%EXT EWRITE_^1_%EXT RSTORE_^1_%EQU MSK(6)_'=$F_^1_%EQU LPMSK(€€2)_^1_%EQU I10($46)_$=10_^1_%EQU ARGU1($D8)_^1_%EQU ARGU2($D9)_^1_%EQU ARGU3($DA)_^1_%EQU ARGU4($DB)_^1_%EQU ICOUNT($D9)_^1_%EQU IA(4)_^1_%EQU IB(5)_^1_%EQU IFIELD(7)_^1_%EQU JFIELD(8)_^1_%EQU IBX(13)_^1_%EQU JBX(14)_^1_%EQU IR1(15)_^1_%EQU IR2(16)_^1_%EQU IR3(17)_^1_%EQU IR7(21)_^1DCHX_!0_"0_)***CONVERT INTEGER_^1_%IIN 0_^1_%RTJ INITAL_^1_%LDA- ARGU3_^1_%STA- ARG€€U1_^1_%ENA 0_^1_%STA- IR1,I_^1_%STA- IR2,I_^1_%STA- IR3,I_^1_%STA- IR7,I_^1_%STA- IA,I_^1_%ENA 1_^1_%STA- ICOUNT_^1LOOP_!LDA- IFIELD,I_$=FIELD WIDTH OF CONVERTED_^1_%SUB- ICOUNT_)NUMBER_^1_%SAP NXT-*-1_^1_%JMP* OUT_^1NXT_"LDA- IBX,I_^1_%ADD- ARGU1_^1_%STA- ARGU3_^1_%ENA JBX_^1_%ADD- I_^1_%STA- ARGU4_^1_%RTJ IGETCH_'GET NEXT INTEGER IN BUFFER_^1_%STA- IB,I_^1_%ENA IBX_^1_%ADD-€€ I_^1_%STA- ARGU3_^1_%INA 1_^1_%STA- ARGU4_^1_%RTJ UPDATE_^1_%LDA- IR2,I_(CONVERSION STARTED YET_^1_%SAN N-*-1_(YES, CONVERT EMBEDDED BLANKS TO ZERO_^1_%LDA- IB,I_)NO, CHARACTER A BLANK ( )._^1_%INA -$20_^1_%SAZ F-*-1_(YES_^1_%INA -$B_*NO, CHARACTER A PLUS (+)._^1_%SAZ F-*-1_(YES_^1_%INA -5_+NO, CHARACTER A ZERO (0)._^1* CONVERT LEADING ZEROS. A SIDE EFFECT IS TO INCREM€€ENT IR2,_^1* IR2 IS THE CONVERTED INTEGER COUNTER._^1* IR2 IS USED AFTER THE SECOND CALL TO DCHX FROM FLOTIN._^1_%SAZ NXT2-*-1_%YES_^1_%INA 3_,NO, CHARACTER A MINUS (-)._^1_%SAN NXT2-*-1_$NO_^1_%RAO- IR7,I_(YES, INCREMENT INDEX_^1F_$JMP* ENDLP_^1N_$LDA- IB,I_)INTERPRET IMBEDDED BLANK AS ZERO (0)._^1_%INA -$20_^1_%SAZ ZRO-*-1_"SKIP IF A BLANK_^1_%SUB* DF_($00DF_^1_%SAN NXT2-*€€-1_!SKIP IF NOT A CARRIAGE RETURN_^1_%JMP* OUT_'STOP CONVERTING CHARACTERS_^1DF_#NUM $00DF_^1ZRO_"ENA $30_'REPLACE BLANK_%WITH ZERO_^1_%STA- IB,I_%CONVERT BLANK AS INPUT $30_^1NXT2_!LDA- IB,I_)TEST IF IB=DECIMAL_^1_%INA -$2E_^1_%SAN NXT3-*-1_!SKIP IF NOT DECIMAL POINT_^1_%LDA- IFIELD,I_$YES, COMPUTE JFIELD_^1_%SUB- ICOUNT_^1_%STA- JFIELD,I_^1_%JMP* OUT_^1NXT3_!LDA- IB,I_)TEST I€€F IB=NUMERIC_^1_%INA -$30_^1_%SAP NXT4-*-1_!SKIP IF .GE. $30_^1P1_#RTJ EWRITE_'NO, ERROR_^1NXT4_!ENA $39_^1_%SUB- IB,I_^1_%SAP NXT5-*-1_!SKIP IF .LE. $39_^1_%RTJ* (P1+1)_#NO, ERROR_^1NXT5_!LDA- IB,I_^1_%AND- MSK_*MASK 4-BITS OF ASCII NUMBR_^1_%STA- IB,I_^1_%RAO- IR2,I_(=COUNT OF DIGITS CONVERTED_^1_%ENA 11_^1_%SUB- IR2,I_(TEST COUNT GREATER THAN 5_^1_%SAP NXT6-*-1_^1_%RTJ* (€€P1+1)_'YES, ERROR_^1NXT6_!LDA- IR1,I_^1_%MUI- I10_^1_%LLS 1_^1_%ALS 15_^1_%ADD- IB,I_^1_%SAP OK-*-1_^1_%INQ 1_^1_%AND- LPMSK+15_^1OK_#STA- IR1,I_^1_%STQ- IR3,I_^1_%LDA- IA,I_^1_%MUI- I10_^1_%LLS 1_^1_%ALS 15_^1_%ADD- IR3,I_^1_%STA- IA,I_^1_%SAM ER-*-1_^1_%SQZ ENDLP-*-1_^1ER_#RTJ* (P1+1)_'YES, ERROR_^1ENDLP RAO- ICOUNT_^1_%JMP* LOOP_^1OUT_"LDQ- IA,I_^1_%LDA- IR1,I_^1_%ALS €¸1_^1_%LRS 1_^1_%STQ- IA,I_^1_%LDQ- IR7,I_^1NXT7_!SQZ NXT9-*-1_^1NXT8_!TCA A_,COMPLEMENT NUMBER_^1_%LDQ- IA,I_^1_%TCQ Q_^1_%STQ- IA,I_^1NXT9_!STA- IB,I_^1_%JMP RSTORE_^1_%END_]_^__¸PHXASCR CSY/ D12 P€1_%NAM HXASCR_'DECK-ID D12 FTN 3.3 RUNTIME_%SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3_^1*_$SMALL COMPUTER DEVELOPMENT DIVISION, LA JOLLA CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1973_^1_%SPC 2_^1*_$CONVERT HEXIDECMAL TO ASCII CODE_^1_%ENT HXASC_^1_%EXT INITAL_^1_%EXT IPACK_^1_%EXT UPDATE_^1_%EXT RSTORE_^1_%EXT EWRITE_J**MSOS4.0**_^1_%EQU MSK(6)_'=$F€€_^1_%EQU ZERO($22)_^1_%EQU ARGU1($D8)_^1_%EQU ARGU2($D9)_^1_%EQU ARGU3($DA)_^1_%EQU ARGU4($DB)_^1_%EQU ICOUNT($DC)_^1_%EQU JCOUNT($DD)_^1_%EQU IB(5)_^1_%EQU IFIELD(7)_^1_%EQU IBX(13)_^1_%EQU JBX(14)_^1_%EQU IR1(15)_^1_%EQU IR(15)_^1HXASC 0_"0_)***HEX TO ASCII CONVERSION_^1_%IIN 0_^1_%RTJ INITAL_^1_%LDA- ARGU3_^1_%STA- ARGU1_^1_%ENA 0_^1_%STA- ICOUNT_^1LOOP1 LDA- I€€B,I_^1_%ALS 4_,SHIFT HIGH ORDER BITS_^1_%STA- IB,I_^1_%AND- MSK_*MASK BITS 0-3_^1_%TCA Q_^1_%INQ 9_,TEST BYTE GT 9_^1_%SQP NXT-*-1_^1_%INA 7_,YES, ADD 7_^1NXT_"INA $30_*ADD ASCII ZERO TO INTEGER_^1_%LDQ- ICOUNT_^1_%STA- IR,B_)SAVE IN TEMP_^1_%RAO- ICOUNT_^1_%ENA 4_^1_%SUB- ICOUNT_^1_%SAZ NXTA_L**MSOS4.0**_^1_%JMP* LOOP1_^1NXTA_!ENQ -4_+CHECK FOR LEADING ZEROES_***MSOS4.0**€€_^1AGN_"LDA- IR+4,B_J**MSOS4.0**_^1_%INA -$30_L**MSOS4.0**_^1_%SAN NXT1_L**MSOS4.0**_^1_%LDA- ICOUNT_J**MSOS4.0**_^1_%INA -1_N**MSOS4.0**_^1_%STA- ICOUNT_J**MSOS4.0**_^1_%INQ 1_O**MSOS4.0**_^1_%SQP NXT1_M**MSOS4.0**_^1_%JMP* AGN_M**MSOS4.0**_^1NXT1_!LDA- IFIELD,I_$SET TOTAL FIELD WIDTH IN TEMP_^1_%STA- JCOUNT_^1_%TCA Q_O**MSOS4.0**_^1_%SUB- ICOUNT_J**MSOS4.0**_^1_%SAP OK1_M**€€MSOS4.0**_^1_%SET A_O**MSOS4.0**_^1_%ENA $2A_*ERROR -- FIELD WIDTH TOO SMALL_#**MSOS4.0**_^1_%STA- IB,I_,PUT AN * IN LEADING POSITION_"**MSOS4.0**_^1_%STA- IR,I_)SET FLAG TO CALL EWRITE_+**MSOS4.0**_^1_%JMP* NXT3_L**MSOS4.0**_^1OK1_"ENA 4_O**MSOS4.0**_^1_%STA- ICOUNT_J**MSOS4.0**_^1_%ENA $20_*SET IB INITIALLY TO BLANK_^1_%STA- IB,I_^1LOOP2 LDA- JCOUNT_'TEST IF FIELD WIDTH=0_^1€€_%SAN NXT2-*-1_^1_%LDA- IR,I_L**MSOS4.0**_^1_%SAP OK2_M**MSOS4.0**_^1_%RTJ EWRITE_J**MSOS4.0**_^1OK2_"JMP* OUT_M**MSOS4.0**_^1NXT2_!TCA A_,NO, COMPLIMENT FIELD WIDTH_^1_%TRA Q_^1_%ADD- ICOUNT_'ADD NUMBER OF HEX DIGITS_^1_%SAM NXT3-*-1_$TEST IF FIELD WIDTH GT NUMBER OF HEX DIGITS_^1_%LDA- IR+4,B_'NO, PACK HEX DIGITS INTO BUFFER_^1_%STA- IB,I_^1NXT3_!TCQ Q_^1_%INQ -1_+DECREAS€2E FIELD WIDTH BY 1_^1_%STQ- JCOUNT_^1_%LDA- IBX,I_^1_%ADD- ARGU1_^1_%STA- ARGU3_^1_%ENA JBX_^1_%ADD- I_^1_%STA- ARGU4_^1_%RTJ IPACK_(PACK CHARACTER INTO BUFFER_^1_%ENA IBX_^1_%ADD- I_^1_%STA- ARGU3_^1_%INA 1_^1_%STA- ARGU4_^1_%RTJ UPDATE_^1_%RAO- ICOUNT_^1_%JMP* LOOP2_^1OUT_"JMP RSTORE_^1_%END_]_^__2PAFMTOR CSY/ D13 P€1_%NAM AFMTOR_'DECK-ID D13 FTN 3.3 RUNTIME_%SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3_^1*_$SMALL COMPUTER DEVELOPMENT DIVISION, LA JOLLA CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1973_^1_%SPC 2_^1*_$CONVERT BY (A)FORMAT FOR OUTPUT_^1_%ENT AFRMOT_^1_%EXT INITAL_^1_%EXT GETCH_^1_%EXT IPACK_^1_%EXT UPDATE_^1_%EXT RSTORE_^1_%EQU MSK($A)_%=$FF_^1_%EQU ZE€€RO($22)_^1_%EQU ARGU1($D8)_^1_%EQU ARGU2($D9)_^1_%EQU ARGU3($DA)_^1_%EQU ARGU4($DB)_^1_%EQU ICOUNT($DC)_^1_%EQU JCOUNT($23)_G47*804_^1_%EQU IA(4)_^1_%EQU IB(5)_^1_%EQU IFIELD(7)_^1_%EQU IBX(13)_^1_%EQU JBX(14)_^1AFRMOT 0_"0_)***(A)FORMAT FOR OUTPUT_^1_%IIN 0_^1_%RTJ INITAL_^1_%LDA- ARGU3_^1_%STA- ARGU1_^1_%LDA- IB,I_^1_%STA- IA,I_^1_%ENA 1_^1_%STA- ICOUNT_^1LOOP_!LDA-€€ IFIELD,I_^1_%SUB- ICOUNT_^1_%SAP NXT-*-1_^1_%JMP* OUT_^1NXT_"ENA IA_^1_%ADD- I_^1_%STA- ARGU3_^1_%ENA -JCOUNT_K47*804_^1_%AND- MSK_^1_%STA- ARGU4_^1_%RTJ GETCH_(GET CHARACTER_^1_%STA- IB,I_^1_%LDA- ARGU1_^1_%ADD- IBX,I_^1_%STA- ARGU3_^1_%ENA JBX_^1_%ADD- I_^1_%STA- ARGU4_^1_%RTJ IPACK_(PACK CHARACTER INTO BUFFER_^1_%ENA IBX_^1_%ADD- I_^1_%STA- ARGU3_^1_%INA 1_^1_%STA- ARGU€P4_^1_%RTJ UPDATE_^1_%RAO- ICOUNT_^1_%JMP* LOOP_^1OUT_"JMP RSTORE_^1_%END_]_^__PPRFMTOR CSY/ D14 P€1_%NAM RFMTOR_'DECK-ID D14 FTN 3.3 RUNTIME_%SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3_^1*_$SMALL COMPUTER DEVELOPMENT DIVISION, LA JOLLA CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1973_^1_%SPC 2_^1*_$CONVERT BY (R)FORMAT FOR OUTPUT_^1_%ENT RFRMOT_^1_%EXT INITAL_^1_%EXT IPACK_^1_%EXT UPDATE_^1_%EXT RSTORE_^1_%EQU ZERO($22)_^1_%EQU MSK($A)_%=$FF_>**MSOS€€4.0**_^1_%EQU IB(5)_K**MSOS4.0**_^1_%EQU ARGU1($D8)_^1_%EQU ARGU2($D9)_^1_%EQU ARGU3($DA)_^1_%EQU ARGU4($DB)_^1_%EQU IBX(13)_^1_%EQU JBX(14)_^1RFRMOT 0_"0_)***(R)FORMAT FOR OUTPUT_^1_%IIN 0_S91*2908_^1_%RTJ INITAL_N91*2908_^1_%LDA- IB,I_L**MSOS4.0**_^1_%AND- MSK_M**MSOS4.0**_^1_%STA- IB,I_L**MSOS4.0**_^1*_82 CARDS DELETED_791*2908_^1_%LDA- ARGU3_^1_%STA- ARGU1_^1_%ADD- IBX€è,I_^1_%STA- ARGU3_^1_%ENA JBX_^1_%ADD- I_^1_%STA- ARGU4_^1_%RTJ IPACK_(PACK CHARACTER INTO BUFFER_^1_%ENA IBX_^1_%ADD- I_^1_%STA- ARGU3_^1_%INA 1_^1_%STA- ARGU4_^1_%RTJ UPDATE_'UPDATE BUFFER COUNTS_^1_%JMP RSTORE_^1_%END_]_^__èPAFMTIR CSY/ D15 P€1_%NAM AFMTIR_'DECK-ID D15 FTN 3.3 RUNTIME_%SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3_^1*_$SMALL COMPUTER DEVELOPMENT DIVISION, LA JOLLA CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1973_^1_%SPC 2_^1*_$CONVERT BY (A)FORMAT FOR INPUT_^1_%ENT AFRMIN_^1_%EXT INITAL_^1_%EXT IGETCH_^1_%EXT UPDATE_^1_%EXT RSTORE_^1_%EQU ZERO($22)_^1_%EQU ARGU1($D8)_^1_%EQU A€€RGU2($D9)_^1_%EQU ARGU3($DA)_^1_%EQU ARGU4($DB)_^1_%EQU IA(4)_^1_%EQU IB(5)_^1_%EQU IFIELD(7)_^1_%EQU IBX(13)_^1_%EQU JBX(14)_^1AFRMIN 0_"0_)***(A)FORMAT FOR INPUT_^1_%IIN 0_^1_%RTJ INITAL_^1_%LDA- ARGU3_^1_%STA- ARGU1_^1_%ADD- IBX,I_^1_%STA- ARGU3_^1_%ENA JBX_^1_%ADD- I_^1_%STA- ARGU4_^1P1_#RTJ IGETCH_'GET CHARACTER_^1_%STA- IB,I_^1_%ENA IBX_^1_%ADD- I_^1_%STA- ARGU3_^€€1_%INA 1_^1_%STA- ARGU4_^1P2_#RTJ UPDATE_'UPDATE CHARACTER COUNT_^1_%ENA $20_^1_%STA- IA,I_)SET IA=BLANK_^1_%LDA- IFIELD,I_^1_%INA -1_+IFIELD=1, PACK 1 CHARACTER_^1_%SAZ NEXT-*-1_'PER WORD WITH BLANK FILL_^1_%LDA- ARGU1_(NO, GET NEXT CHARACTER_^1_%ADD- IBX,I_^1_%STA- ARGU3_^1_%ENA JBX_^1_%ADD- I_^1_%STA- ARGU4_^1_%RTJ* (P1+1)_^1_%STA- IA,I_^1_%ENA IBX_^1_%ADD- I_^1_%STA- ARG€ÆU3_^1_%INA 1_^1_%STA- ARGU4_^1_%RTJ* (P2+1)_'UPDATE COUNTS_^1NEXT_!LDA- IB,I_)LEFT JUSTIFY AND ADD BLANK_^1_%ALS 8_.OR NEXT CHARACTER FILL_^1_%ADD- IA,I_^1_%STA- IB,I_^1_%JMP RSTORE_^1_%END_]_^__ÆPRFMTIR CSY/ D16 P€1_%NAM RFMTIR_'DECK-ID D16 FTN 3.3 RUNTIME_%SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3_^1*_$SMALL COMPUTER DEVELOPMENT DIVISION, LA JOLLA CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1973_^1_%SPC 2_^1*_$CONVERT BY (R)FORMAT FOR INPUT_^1_%ENT RFRMIN_^1_%EXT INITAL_^1_%EXT IGETCH_^1_%EXT UPDATE_^1_%EXT RSTORE_^1_%EQU ARGU1($D8)_^1_%EQU ARGU2($D9)_^1_%EQU €€ARGU3($DA)_^1_%EQU ARGU4($DB)_^1_%EQU IB(5)_^1_%EQU IBX(13)_^1_%EQU JBX(14)_^1RFRMIN 0_"0_)***(R)FORMAT FOR INPUT_^1_%IIN 0_^1_%RTJ INITAL_^1_%LDA- ARGU3_^1_%STA- ARGU1_^1_%ADD- IBX,I_^1_%STA- ARGU3_^1_%ENA JBX_^1_%ADD- I_^1_%STA- ARGU4_^1_%RTJ IGETCH_'GET CHARACTER_^1_%STA- IB,I_^1_%ENA IBX_^1_%ADD- I_^1_%STA- ARGU3_^1_%INA 1_^1_%STA- ARGU4_^1_%RTJ UPDATE_'UPDATE COUNTS€_^1_%JMP RSTORE_^1_%END_]_^__PASCHXR CSY/ D17 P€1_%NAM ASCHXR_'DECK-ID D17 FTN 3.3 RUNTIME_%SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3_^1*_$SMALL COMPUTER DEVELOPMENT DIVISION, LA JOLLA CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1973_^1_%SPC 2_^1*_$CONVERT FROM ASCII TO HEXIDECIMAL_^1_%ENT ASCHX_^1_%EXT INITAL_^1_%EXT IGETCH_^1_%EXT UPDATE_^1_%EXT RSTORE_^1_%EXT EWRITE_MPSR 1249_^1_%EQU MSK(6)_'=$F_€€^1_%EQU ZERO($22)_^1_%EQU ARGU1($D8)_^1_%EQU ARGU2($D9)_^1_%EQU ARGU3($DA)_^1_%EQU ARGU4($DB)_^1_%EQU ICOUNT($DC)_^1_%EQU IA(4)_^1_%EQU IB(5)_^1_%EQU IFIELD(7)_^1_%EQU IBX(13)_^1_%EQU JBX(14)_^1_%EQU IR1(15)_^1ASCHX 0_"0_)***ASCII TO HEX CONVERSION_^1_%IIN 0_^1_%RTJ INITAL_^1_%LDA- ARGU3_^1_%STA- ARGU1_^1_%ENA 0_^1_%STA- IB,I_^1_%ENA 1_^1_%STA- ICOUNT_^1LOOP_!LDA- €€IFIELD,I_^1_%SUB- ICOUNT_^1_%SAP NXT-*-1_^1_%JMP* OUT_^1NXT_"LDA- ARGU1_^1_%ADD- IBX,I_^1_%STA- ARGU3_^1_%ENA JBX_^1_%ADD- I_^1_%STA- ARGU4_^1_%RTJ IGETCH_'GET CHARACTER_^1_%STA- IA,I_^1_%ENA IBX_^1_%ADD- I_^1_%STA- ARGU3_^1_%INA 1_^1_%STA- ARGU4_^1_%RTJ UPDATE_^1_%LDA- IA,I_^1_%INA -$20_)TEST IF CHARACTER=BLANK_^1_%SAN NXT1-*-1_^1_%JMP* NEXT_^1NXT1_!LDA- IA,I_)NO, CONVERT €€CHARACTER_^1_%AND- MSK_^1_%STA- IR1,I_^1_%LDA- IA,I_OPSR 1249_^1_%INA -$30_OPSR 1249_^1_%SAM ERR_*SKIP CHAR NON-NUMERIC_0PSR 1249_^1_%INA -10_PPSR 1249_^1_%SAM NXT2_)SKIP CHAR 0-9_8PSR 1249_^1_%INA -7_QPSR 1249_^1_%SAM ERR_*SKIP CHAR NON-NUMERIC_0PSR 1249_^1_%INA -6_QPSR 1249_^1_%SAM 2_,SKIP CHAR A-F_8PSR 1249_^1ERR_"RTJ EWRITE_'ERROR--NOT A HEX DIGIT_/PSR 1249_^1_%LDA- IR€â1,I_(YES, ADD 9_^1_%INA 9_^1_%STA- IR1,I_^1NXT2_!LDA- IB,I_^1_%ALS 4_,SHIFT HEX NUMBER BY 4_^1_%EOR- IR1,I_(ADD LEAST SIGNIFICANT BITS_+PSR 806_^1_%STA- IB,I_^1NEXT_!RAO- ICOUNT_^1_%JMP* LOOP_^1OUT_"JMP RSTORE_^1_%END_]_^__âPHXDCR CSY/ D18 P€1_%NAM HXDCR_(DECK-ID D18 FTN 3.3 RUNTIME_%SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3_^1*_$SMALL COMPUTER DEVELOPMENT DIVISION, LA JOLLA CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1973_^1_%SPC 2_^1*_$CONVERT HEXIDECIMAL TO DECIMAL VARIABLE_^1_%ENT HXDC_^1_%EXT INITAL_^1_%EXT IPACK_^1_%EXT UPDATE_^1_%EXT RSTORE_^1_%EQU ZERO($22)_^1_%EQU I10($46)_$=10_^1€€_%EQU ARGU1($D8)_^1_%EQU ARGU2($D9)_^1_%EQU ARGU3($DA)_^1_%EQU ARGU4($DB)_^1_%EQU ICOUNT($D9)_^1_%EQU IA(4)_^1_%EQU IB(5)_^1_%EQU IFIELD(7)_^1_%EQU JFIELD(8)_^1_%EQU IBX(13)_^1_%EQU JBX(14)_^1_%EQU IR(15)_^1_%EQU IR7(21)_^1_%EQU IR8(22)_^1HXDC_!0_"0_)***HEX TO DECIMAL CONVERSION_^1_%IIN 0_^1_%RTJ INITAL_^1_%LDA- ARGU3_^1_%STA- ARGU1_^1_%ENA 0_^1_%STA- IR7,I_(INITIA€€LIZE TEMP LOC._^1_%STA- IR8,I_^1_%LDA- IB,I_^1_%LDQ- IA,I_^1_%SQP LOOP-*-1_$TEST IF INTEGER NEGATIVE_^1_%TCQ Q_,YES, COMPLIMENT NUMBER_^1_%TCA A_^1_%STA- IB,I_^1_%ENA $2D_*SET IR7=MINUS SIGN_^1_%STA- IR7,I_^1_%LDA- IB,I_^1LOOP_!DVI- I10_^1_%INQ $30_*ADD $30 TO REMAINDER_^1_%STA- IB,I_)SAVE RESULTANT_^1_%TRQ A_^1_%LDQ- IR8,I_^1_%STA- IR,B_)SAVE IN TEMPORARY_^1_%RAO- IR8,I_^1_%€€LDA- IB,I_^1_%SAZ NXT-*-1_%IB=0, TERMINATE CONVERSION_^1_%ENQ 0_^1_%JMP* LOOP_^1NXT_"LDA- JFIELD,I_^1_%SAN NXT1-*-1_$TEST JFIELD=0_^1_%JMP* NEXT2_^1NXT1_!SUB- IR8,I_(TEST IF JFIELD IS LE IR8(NO. OF DIGITS/_^1_%SAM CONTUE-*-1_$INTEGER VALUE)_^1_%SAZ CONTUE-*-1_^1_%JMP* NEXT2_(NO, INSERT PERIOD LATER_^1CONTUE ENA $2E_*SET, IB=PERIOD_^1_%STA- IB,I_^1_%RAO- IR8,I_^1_%LDA- JFIELD,€€I_^1_%INA 1_,SET UP LOOP TO INSERT A_^1_%STA- ICOUNT_)DECIMAL POINT WITHIN THE_^1LOOP1 LDA- IR8,I_*STRING OF INTEGER VALUES_^1_%SUB- ICOUNT_^1_%SAM ENDLP-*-1_^1_%LDQ- ICOUNT_^1_%LDA- IR-1,B_^1_%LDQ- IB,I_^1_%STA- IB,I_^1_%TRQ A_^1_%LDQ- ICOUNT_^1_%STA- IR-1,B_'INSERT PERIOD INTO_^1_%RAO- ICOUNT_)CHARACTER STRING_^1_%JMP* LOOP1_^1ENDLP ENA 0_^1_%STA- JFIELD,I_^1NEXT2 ENA $20€€_^1_%STA- IB,I_)SET IB=BLANK_^1_%LDA- JFIELD,I_^1_%SAZ NXT2-*-1_^1_%LDQ- IR7,I_^1_%SQZ NXT2-*-1_^1_%RAO- JFIELD,I_^1NXT2_!ENA 1_^1_%STA- ICOUNT_'SET UP LOOP TO PACK VALUE_^1LOOP2 LDA- IFIELD,I_'INTO BUFFER_^1_%SUB- ICOUNT_'=I(CURRENT VALUE OF COUNT_^1_%SAP NXT3-*-1_'WITHIN FIELD)_^1_%JMP* OUT_^1NXT3_!LDA- JFIELD,I_$TEST JFIELD=0_^1_%SAN NXT4-*-1_^1_%JMP* NEXT4_^1NXT4_!SUB- IF€€IELD,I_$NO, TEST IF JFIELD=-IFIELD_^1_%ADD- ICOUNT_)+ICOUNT_^1_%SAZ NXT5-*-1_^1_%JMP* NEXT4_^1NXT5_!LDA- IR7,I_(WAS NUMBER NEGATIVE_^1_%SAZ NXT6-*-1_^1_%LDA- JFIELD,I_$YES, REDUCE JFIELD_^1_%INA -1_^1_%STA- JFIELD,I_^1NEXT3 LDA- IR7,I_(AND SET IB=$2D(MINUS SIGN)_^1_%STA- IB,I_^1_%ENA 0_^1_%STA- IR7,I_(CLEAR FLAG_^1_%JMP* NEXT5_^1NXT6_!ENA 0_,NUMBER IS LESS THAN 1_^1_%STA- JFI€€ELD,I_^1_%ENA $2E_*SET IB=PERIOD_^1_%STA- IB,I_^1_%ENA $30_*SET ICONST=ZERO_^1_%STA- IR7,I_^1_%JMP* NEXT5_^1NEXT4 LDQ- IR7,I_^1_%LDA- IR8,I_(TEST IF INTEGER COUNT+1=_^1_%SUB- IFIELD,I_'IFIELD-I+1_^1_%ADD- ICOUNT_^1_%SAN NXT7-*-1_^1_%SQZ ON-*-1_^1_%JMP* NEXT3_(YES, GO INSERT SIGN_^1NXT7_!INQ -$30_^1_%SQN ON-*-1_^1_%JMP* NEXT3_^1ON_#LDA- IR8,I_(TEST IF CHARACTER COUNT IS_^1_%S€€UB- IFIELD,I_'LT CURRENT FIELD COUNT_^1_%TRA Q_^1_%ADD- ICOUNT_^1_%INA -1_^1_%SAP TEST-*-1_^1_%JMP* NEXT5_^1TEST_!SQM NXT8-*-1_^1_%SQN ERR-*-1_^1ERRFLD LDA- IR7,I_^1_%SAZ NXT8-*-1_^1ERR_"ENA $2A_^1_%STA- IB,I_^1_%LDA- IFIELD,I_$RESET CHARACTER COUNT=_^1_%INA -1_-IFIELD-1_^1_%STA- IR8,I_^1_%JMP* NEXT5_^1NXT8_!LDQ- IR8,I_(=CHARACTER COUNT_^1_%LDA- IR-1,B_'GET CONVERTED INTEGER€PS_^1_%STA- IB,I_^1_%INQ -1_^1_%STQ- IR8,I_^1NEXT5 LDA- ARGU1_(PACK CHARACTER INTO BUFFER_^1_%ADD- IBX,I_^1_%STA- ARGU3_^1_%ENA JBX_^1_%ADD- I_^1_%STA- ARGU4_^1_%RTJ IPACK_^1_%ENA IBX_^1_%ADD- I_^1_%STA- ARGU3_^1_%INA 1_^1_%STA- ARGU4_^1_%RTJ UPDATE_'UPDATE COUNTERS_^1_%RAO- ICOUNT_^1_%JMP* LOOP2_^1OUT_"JMP RSTORE_^1_%END_]_^__PPFLOTIR CSY/ D19 P€1_%NAM FLOTIR_'DECK-ID D19 FTN 3.3 RUNTIME_%SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^1_%SPC 2_^1*_$FLOATING POINT CONVERSION FOR INPUT WITH_^1*_$(F)FORMAT_^1_%ENT FLOTIN_^1_%EXT INITAL_^1_%EXT DCHX_^1_%EXT Q8QFL_^1_%EXT HFLOT_OFTN 3.3_^1_%EXT Q8QFI_^1_%EXT€€ RSTORE_^1_%EXT E4SAVE_N64*1405_^1_%EQU ZERO($22)_^1_%EQU ARGU3($DA)_^1_%EQU ARGU4($DB)_^1_%EQU R($DC)_^1_%EQU A($DE)_^1_%EQU ARGU1($E0)_^1_%EQU SCALE($E1)_^1_%EQU SWITCH($E3)_^1_%EQU NXFLD($E4)_^1_%EQU NXTFLD($E5)_^1_%EQU IA(4)_^1_%EQU IB(5)_^1_%EQU IFIELD(7)_^1_%EQU JFIELD(8)_^1_%EQU IR2(16)_^1FLOTIN 0_"0_)***INPUT (F)FORMAT_^1_%IIN 0_^1_%RTJ INITAL_^1_%LDA- AR€€GU3_^1_%STA- ARGU1_^1_%LDA- IFIELD,I_^1_%STA- NXTFLD_^1_%LDA- NXFLD_O64*1405_^1_%STA E4SAVE_N64*1405_^1_%LDA- JFIELD,I_^1_%STA- NXFLD_^1_%ENA -0_^1_%STA- JFIELD,I_^1P1_#RTJ DCHX_^1P2_#RTJ Q8QFL_^1_%LDA- JFIELD,I_^1_%SAP STP10-*-1_^1_%JMP* STP20_^1STP10 STA- IFIELD,I_^1_%LDQ- A_^1_%LDA- A+1_^1_%STQ- SWITCH_^1_%SQP STP12-*-1_^1_%TCQ Q_^1_%TCA A_^1STP12 STQ- R_^1_%STA- R+1_^€€1_%LDA- ARGU1_^1_%STA- ARGU3_^1_%RTJ* (P1+1)_^1_%RTJ* (P2+1)_^1* Q8QFI CALCULATES SCALE = 10**JFIELD. MAKE JFIELD = NUMBER OF_^1* COMVERTED DIGITS TO THE RIGHT OF THE DECIMAL, LEADING ZEROS INCLUDED._^1_%LDA- IR2,I_^1_%STA- JFIELD,I_^1P3_#RTJ Q8QFI_^1P4_#RTJ HFLOT_OFTN 3.3_^1_%NUM $BAED_^1_%ADC A_^1_%ADC SCALE_^1_%ADC R_^1_%ADC A_^1_%NUM $4000_^1_%LDA- SWITCH_^1_%SAP STP2€€0-*-1_^1_%RTJ* (P4+1)_^1_%NUM $B7D4_^1_%ADC A_^1_%ADC A_^1STP20 LDQ- JFIELD,I_^1_%LDA- NXFLD_^1_%STA- JFIELD,I_^1_%SQP STP30-*-1_^1_%RTJ* (P3+1)_^1_%RTJ* (P4+1)_^1_%NUM $BAD4_^1_%ADC A_^1_%ADC SCALE_^1_%ADC A_^1STP30 LDA- NXTFLD_^1_%STA- IFIELD,I_^1_%LDA E4SAVE_N64*1405_^1_%STA- NXFLD_O64*1405_^1_%LDA- A_^1_%LDQ- A+1_^1_%STA- IA,I_^1_%STQ- IB,I_^1_%JMP RSTORE_^1_%END_]_€^__ PFOUTR CSY/ D20 P€1_%NAM FOUTR_(DECK-ID D20 FTN 3.3 RUNTIME_%SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^1_%SPC 2_^1*_$FLOATING POINT OUTPUT CONVERSION UNDER AN_^1*_$(F)FORMAT_^1_%ENT FOUT_^1_%EXT INITAL_^1_%EXT Q8QFI_^1_%EXT HFLOT_OFTN 3.3_^1_%EXT Q8QFX_^1_%EXT HXDC_^1_%EXT €€IPACK_^1_%EXT UPDATE_^1_%EXT Q8QFL_^1_%EXT RSTORE_^1_%EXT E4SAVE_N64*1405_^1_%EQU TEMP($C5)_KFTN 3.3_^1_%EQU ZERO($22)_^1_%EQU ARGU3($DA)_^1_%EQU ARGU4($DB)_^1_%EQU A2($DC)_^1_%EQU A1($DE)_^1_%EQU ARGU1($E0)_^1_%EQU SCALE($E1)_^1_%EQU ICOUNT($E3)_^1_%EQU NUFLD($E4)_^1_%EQU NXTFLD($E5)_^1_%EQU IA(4)_^1_%EQU IB(5)_^1_%EQU IFIELD(7)_^1_%EQU JFIELD(8)_^1_%EQU IBX(13€€)_^1_%EQU JBX(14)_^1_%EQU IR7(21)_^1_%EQU ASTRK($2A)_IPSR 809_^1FOUT_!0_"0_)***FLOATING POINT OUTPUT_^1_%IIN 0_^1_%RTJ INITAL_^1_%LDA- ARGU3_^1_%STA- ARGU1_^1_%LDA- NUFLD_O64*1405_^1_%STA E4SAVE_N64*1405_^1_%LDA- JFIELD,I_^1_%STA- NUFLD_^1_%LDA- IA,I_^1_%LDQ- IB,I_^1_%SAP NXT-*-1_^1_%TCQ Q_^1_%TCA A_^1NXT_"STQ- A2+1_^1_%STA- A2_^1P1_#RTJ Q8QFI_^1P2_#RTJ HFLOT_OFTN 3.3_^1€€_%NUM $BAED_^1_%ADC FLOTK1_^1_%ADC SCALE_^1_%ADC A2_^1_%ADC A2_^1_%NUM $8D40_^1_%ADC FLOTK2_^1_%ADC TEMP_PFTN 3.3_^1_%LDA- TEMP_PFTN 3.3_^1_%SAM NXT1-*-1_^1_%JMP* OVRFLW_'ERROR - NUMBER .GT. 99,999.9_)PSR 809_^1NXT1_!LDA- IA,I_^1_%SAP NXT2-*-1_^1_%RTJ* (P2+1)_^1_%NUM $B7D4_^1_%ADC A2_^1_%ADC A2_^1NXT2_!RTJ Q8QFX_^1_%ENA 0_^1_%STA- JFIELD,I_^1_%LDA- IFIELD,I_^1_%STA- €€NXTFLD_^1_%SUB- NUFLD_^1_%INA -1_^1_%STA- IFIELD,I_^1_%LDA- ARGU1_^1_%STA- ARGU3_^1P4_#RTJ HXDC_^1_%ENA $2E_^1_%STA- IB,I_^1_%LDA- ARGU1_^1_%ADD- IBX,I_^1_%STA- ARGU3_^1_%ENA JBX_^1_%ADD- I_^1_%STA- ARGU4_^1_%RTJ IPACK_^1_%ENA IBX_^1_%ADD- I_^1_%STA- ARGU3_^1_%INA 1_^1_%STA- ARGU4_^1_%RTJ UPDATE_^1_%ENA 1_^1_%STA- IFIELD,I_^1_%STA- ICOUNT_^1_%LDA- A2_^1_%SAP LOOP-*-1_^1_%€€TCA A_^1_%STA- A2_^1LOOP_!LDA- NUFLD_^1_%SUB- ICOUNT_^1_%SAP P5-*-1_^1_%JMP* OUT_^1P5_#RTJ Q8QFX_^1_%RTJ Q8QFL_^1_%RTJ* (P2+1)_^1_%NUM $B89D_^1_%ADC A2_^1_%ADC A1_^1_%ADC FLOT10_^1_%ADC A2_^1_%NUM $4000_^1_%RTJ* (P5+1)_^1_%LDA- ARGU1_^1_%STA- ARGU3_^1_%RTJ* (P4+1)_^1_%RAO- ICOUNT_^1_%JMP* LOOP_^1OUT_"LDA- NXTFLD_^1_%STA- IFIELD,I_^1_%LDA- NUFLD_^1_%STA- JFIELD,I_^1_%LDA €€E4SAVE_N64*1405_^1_%STA- NUFLD_O64*1405_^1_%LDA- JFIELD,I_L64*1405_^1_%JMP RSTORE_^1FLOT10 NUM $4250,$0_^1FLOTK1 NUM $4040,$0_^1FLOTK2 NUM $4A49,$3E00_G71*1626_^1* ROUTINE TO FILL BUFFER WITH ASTERISKS IF NUMBER .GT. 99,999.9 PSR 809_^1OVRFLW LDA- IFIELD,I_$MOVE FIELD WIDTH TO TEMPORARY_(PSR 809_^1_%STA- ICOUNT_'STORAGE FOR USE AS LOOP COUNTER_%PSR 809_^1FILL_!ENA ASTRK_(* TO €€A REGISTER_6PSR 809_^1_%STA- IB,I_)STORE IN IB_:PSR 809_^1_%LDA- ARGU1_(PICK UP BUFFER ADDRESS_/PSR 809_^1_%ADD- IBX,I_(INCREMENT BY CURRENT WORD ORDINAL_#PSR 809_^1_%STA- ARGU3_(STORE IN ARGU3_7PSR 809_^1_%ENA JBX_PPSR 809_^1_%ADD- I_,ARGU4 GETS CURRENT BUFFER CHARACTER_!PSR 809_^1_%STA- ARGU4_(ADDRESS_>PSR 809_^1_%RTJ IPACK_(PACK ASTERISK INTO BUFFER_,PSR 809_^1_%ENA IBX_PPSR €€809_^1_%ADD- I_RPSR 809_^1_%STA- ARGU3_NPSR 809_^1_%INA 1_RPSR 809_^1_%STA- ARGU4_NPSR 809_^1_%RTJ UPDATE_'UPDATE WORD + CHARACTER COUNT_(PSR 809_^1_%LDA- ICOUNT_MPSR 809_^1_%INA -1_QPSR 809_^1_%SAZ FULL_)CHECK IF ALL OF FIELD SET_,PSR 809_^1_%STA- ICOUNT_MPSR 809_^1_%JMP* FILL_)NO - REPEAT PROCESS_2PSR 809_^1FULL_!JMP* OUT_*YES - EXIT BACK TO FOUT CALLER_'PSR 809_^1_%END_]_^__€PEOUTR CSY/ D21 P€1_%NAM EOUTR_(DECK-ID D21 FTN 3.3 RUNTIME_%SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^1_%SPC 2_^1*_$FLOATING POINT OUTPUT WITH (E)FORMAT_^1_%ENT EOUT_^1_%EXT INITAL_^1_%EXT Q8QFI_^1_%EXT HFLOT_OFTN 3.3_^1_%EXT IPACK_^1_%EXT UPDATE_^1_%EXT Q8QFX_^1_%EXT EWR€€ITE_^1_%EXT Q8QFL_^1_%EXT HXDC_^1_%EXT RSTORE_^1_%EXT E4SAVE_N64*1405_^1_%EQU ZERO($22)_^1_%EQU ARGU0($D8)_^1_%EQU ARGU3($DA)_^1_%EQU ARGU4($DB)_^1_%EQU R($DC)_^1_%EQU RX($DE)_^1_%EQU ARGU1($E0)_^1_%EQU SCALE($E1)_^1_%EQU JCOUNT($E1)_^1_%EQU SWITCH($E2)_^1_%EQU ICOUNT($E3)_^1_%EQU NUFLD($E4)_^1_%EQU NXTFLD($E5)_^1_%EQU IA(4)_^1_%EQU IB(5)_^1_%EQU IFIELD(7)_^1_%E€€QU JFIELD(8)_^1_%EQU IBX(13)_^1_%EQU JBX(14)_^1_%EQU IR6(20)_^1EOUT_!0_"0_)***FLOATING POINT CONVERSION_^1_%IIN 0_^1_%RTJ INITAL_^1_%LDA- ARGU3_^1_%STA- ARGU1_^1_%STA- ARGU0_^1_%LDA- NUFLD_O64*1405_^1_%STA E4SAVE_N64*1405_^1_%LDA- JFIELD,I_^1_%STA- NUFLD_^1_%LDA- IFIELD,I_^1_%STA- NXTFLD_^1_%LDA- IA,I_^1_%STA- R_^1_%LDA- IB,I_^1_%STA- R+1_^1_%ENA 0_^1_%STA- IA,I_^1_%STA- IC€€OUNT_^1_%ENA $20_^1_%STA- IB,I_^1_%ENA -1_^1_%STA- SWITCH_^1STP10 LDA- SWITCH_^1_%SAP STP30-*-1_^1_%LDA- IFIELD,I_^1_%TRA Q_^1_%SUB- JFIELD,I_^1_%INA -6_^1_%SAM STP20-*-1_^1_%SAZ STP40-*-1_^1_%INQ -1_^1_%STQ- IFIELD,I_^1_%JMP* PACK_^1STP20 ENA $2A_^1_%STA- IB,I_^1_%INQ -6_^1_%STQ- JFIELD,I_^1_%ENA 0_^1_%JMP* STP50_^1STP30 SAZ STP60-*-1_^1_%JMP* STP80_^1STP40 LDQ- R_€€^1_%SQP STP50-*-1_^1_%TCQ Q_^1_%STQ- R_^1_%LDQ- R+1_^1_%TCQ Q_^1_%STQ- R+1_^1_%ENQ $2D_^1_%STQ- IB,I_^1STP50 STA- SWITCH_^1_%JMP* PACK_^1STP60 ENA $2E_^1_%STA- IB,I_^1_%ENA 1_^1_%STA- SWITCH_^1PACK_!LDA- IBX,I_^1_%ADD- ARGU1_^1_%STA- ARGU3_^1_%ENA JBX_^1_%ADD- I_^1_%STA- ARGU4_^1_%RTJ IPACK_^1_%ENA IBX_^1_%ADD- I_^1_%STA- ARGU3_^1_%INA 1_^1_%STA- ARGU4_^1_%RTJ UPDATE_^€€1_%JMP* STP10_^1STP80 RTJ Q8QFX_^1_%LDA- IB,I_^1_%SAZ STP90-*-1_^1_%RAO- ICOUNT_^1_%JMP* STP100_^1STP90 LDA- R_^1_%SAN LOOP1-*-1_^1_%JMP* STP130_^1LOOP1 RTJ HFLOT_OFTN 3.3_^1_%NUM $B9D4_^1_%ADC R_^1_%ADC FLOT10_^1_%ADC R_^1_%RTJ* (STP80+1)_^1_%LDA- IB,I_^1_%SAZ ENDLP-*-1_^1_%JMP* STP120_^1ENDLP LDA- ICOUNT_^1_%INA -1_^1_%STA- ICOUNT_^1_%INA 99_^1_%SAM P4-*-1_^1_%JMP€€* LOOP1_^1P4_#RTJ EWRITE_^1STP100 LDQ- IA,I_^1_%LDA- IB,I_^1_%LLS 1_^1_%ALS 15_^1_%TCA A_^1_%INA 9_^1_%SAM LOOP2-*-1_^1_%SQN LOOP2-*-1_^1_%JMP* STP120_^1LOOP2 RTJ* (LOOP1+1)_^1_%NUM $BAD4_^1_%ADC R_^1_%ADC FLOT10_^1_%ADC R_^1_%RTJ* (STP80+1)_^1_%RAO- ICOUNT_^1_%ENA 99_^1_%SUB- ICOUNT_^1_%SAM STP110-*-1_^1_%JMP* STP100_^1STP110 RTJ* (P4+1)_^1STP120 RTJ Q8QFI_^1_%RTJ* €€(LOOP1+1)_^1_%NUM $BAED_^1_%ADC FLOTK1_^1_%ADC SCALE_^1_%ADC R_^1_%ADC R_^1_%NUM $4000_^1_%RTJ* (STP80+1)_^1_%ENA 9_^1_%SUB- IB,I_^1_%SAP STP130-*-1_^1_%ENA 2_^1_%RAO- ICOUNT_^1_%JMP* STP132_^1STP130 ENA 1_^1STP132 STA- IFIELD,I_^1_%ENA 1_^1_%STA- JCOUNT_^1_%ENA 0_^1_%STA- JFIELD,I_^1LOOP3 LDA- NUFLD_^1_%SUB- JCOUNT_^1_%SAP NXT5-*-1_^1_%JMP* OUT_^1NXT5_!RTJ Q8QFL_^1_€€%RTJ* (LOOP1+1)_^1_%NUM $B89D_^1_%ADC R_^1_%ADC RX_^1_%ADC FLOT10_^1_%ADC R_^1_%NUM $4000_^1_%LDQ- ARGU1_^1_%STQ- ARGU3_^1_%STQ- ARGU0_^1P7_#RTJ HXDC_^1_%RTJ Q8QFX_^1_%LDA- IFIELD,I_^1_%INA -1_^1_%SAZ STP140-*-1_^1_%STA- IFIELD,I_^1STP140 RAO- JCOUNT_^1_%JMP* LOOP3_^1OUT_"ENA $45_^1_%STA- IB,I_^1_%STA- SWITCH_^1STP150 LDA- ARGU1_^1_%STA- ARGU0_^1_%ADD- IBX,I_^1_%STA- ARG€€U3_^1_%ENA JBX_^1_%ADD- I_^1_%STA- ARGU4_^1_%RTJ IPACK_^1_%ENA IBX_^1_%ADD- I_^1_%STA- ARGU3_^1_%INA 1_^1_%STA- ARGU4_^1_%RTJ UPDATE_^1_%LDA- ICOUNT_^1_%LDQ- SWITCH_^1_%SQZ NXT6-*-1_^1_%ENQ $2B_*ASCII PLUS (PLUS EXPONENT)_(**FTN 3.1**_^1_%SAP STP170-*-1_^1_%TCA A_^1_%STA- ICOUNT_^1_%ENQ $2D_^1STP170 STQ- IB,I_^1_%ENA 0_^1_%STA- SWITCH_^1_%JMP* STP150_^1NXT6_!INA -10_^1_€€%SAP NXT7-*-1_^1_%ENA 0_^1_%STA- IB,I_^1_%LDA- ARGU1_^1_%STA- ARGU3_^1_%STA- ARGU0_^1_%RTJ* (P7+1)_^1_%JMP* STP180_^1NXT7_!ENA 2_^1_%STA- IFIELD,I_^1STP180 LDA- ICOUNT_^1_%STA- IB,I_^1_%LDA- ARGU1_^1_%STA- ARGU3_^1_%STA- ARGU0_^1_%RTJ* (P7+1)_^1_%LDA- NUFLD_^1_%STA- JFIELD,I_^1_%LDA E4SAVE_N64*1405_^1_%STA- NUFLD_O64*1405_^1_%LDA- NXTFLD_^1_%STA- IFIELD,I_^1_%JMP RSTORE_^1FLOT€F10 NUM 16976_^1_%NUM 0_^1FLOTK1 NUM 16448_^1_%NUM 0_^1_%END_]_^__ FPEWRITR CSY/ D22 P€1_%NAM EWRITR_'DECK-ID D22 FTN 3.3 RUNTIME_%SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3_^1*_$SMALL COMPUTER DEVELOPMENT DIVISION, LA JOLLA CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1973_^1_%SPC 2_^1*_$ERROR RETURN_^1_%ENT EWRITE_^1_%EQU AVOLR($BA)_^1_%EQU VR(1)_^1_%EQU DEFLAG(6)_^1_%EQU VR1(32)_^1EWRITE 0_"0_)***ERROR DETECTED --- RETURN_^1_%IIN 0_^1_%L€üDA- DEFLAG,I_$DETERMINE IF ENCODE/DECODE OR READ/WRITE CALL_^1_%SAM NXT-*-1_^1_%LDA- VR1,I_(READ/WRITE CALL - MODIFY RETURN SO CONTROL_^1_%JMP* NXT1_^1NXT_"RTJ- (AVOLR)_^1NXT1_!STA* XIT_^1_%ENA -1_^1_%EIN 0_^1_%JMP* (XIT)_^1XIT_"NUM 0_^1_%END_]_^__üPINTI1R CSY/ D23 P€1_%NAM INTI1R_'DECK-ID D23 FTN 3.3 RUNTIME_%SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3_^1*_$SMALL COMPUTER DEVELOPMENT DIVISION, LA JOLLA CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1973_^1_%SPC 2_^1_%ENT INITL1_^1_%ENT RESTRE_^1_%EQU VR(1)_^1_%EQU LPMSK(2)_^1_%EQU ZERO($22)_^1_%EQU AVOLR($BA)_^1_%EQU AVOLA($BB)_^1_%EQU ARGU1($D8)_^1_%EQU VOLATL($F0)_€€^1_%EQU LIST(25)_^1_%EXT PARABS_J**MSOS4.1**_^1INITL1 0_"0_)***RESERVE VOLATILE STORAGE_^1_%RTJ- (AVOLA)_^1_%NUM 29_^1_%LDQ* INITL1_'GET RETURN ADDRESS_^1_%INQ -4_+GET CALLING ADDRESS_^1_%LDQ- (ZERO),Q_^1_%STQ- VR,I_^1_%RTJ* NORML_^1_%STA- ARGU1_^1_%RTJ* NORML_^1_%STA- LIST,I_^1_%EIN 0_^1_%JMP* (INITL1)_^1RESTRE IIN 0_)***RETURN VOLATILE STORAGE_^1_%STA* TEMP_^1_%LDA- VR,I_^1€_%STA* XIT_^1_%RTJ- (AVOLR)_^1_%LDA* TEMP_^1_%EIN 0_^1_%JMP* (XIT)_(RETURN TO USERS PROGRAM_^1TEMP_!NUM 0_^1XIT_"NUM 0_^1NORML 0_"0_^1_%LDA- VR,I_)***NORMALIZE ADDRESS***_+**MSOS4.1**_^1_%RAO- VR,I_^1_%RTJ PARABS_J**MSOS4.1**_^1OUT_"JMP* (NORML)_^1_%END_]_^__PFORMTR CSY/ D24 P€1_%NAM FORMTR_'DECK-ID D24 FTN 3.3 RUNTIME_%SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3_^1*_$SMALL COMPUTER DEVELOPMENT DIVISION, LA JOLLA CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1973_^1_%SPC 2_^1*_$FORMAT INPUT/OUTPUT FROM/INTO A BUFFER_^1*_*MAIN PROGRAM FOR FORMATTED I/O_^1*_*CALLING SEQUENCE --- RTJ FORMTR_^1*_*PROGRAM EXPECTS ARGU1 TO CONTAIN THE_^1*_*€€BUFFER ADDRESS-1 AND ARGU2 TO CONTAIN_^1*_*THE FORMAT ADDRESS-1._^1*_*THESE ADDRESSES ARE SAVED THROUGHOUT_^1*_*THE ENTIRE EXECUTION OF ENCODE/DECODE._^1*_]_^1_%ENT FORMTR_^1_%ENT CHCNT_^1_%EXT Q8QGET_^1_%EXT INITAL_^1_%EXT GETCH_^1_%EXT UPDATE_^1_%EXT INTGR_^1_%EXT DECPL_^1_%EXT DCHX_^1_%EXT ASCHX_^1_%EXT AFRMIN_^1_%EXT RFRMIN_^1_%EXT FLOTIN_^1_%EXT HOLRTH_^1_%EXT Q€€UOTE_MFTN*3.2_^1_%EXT SPACEX_^1_%EXT HXDC_^1_%EXT HXASC_^1_%EXT AFRMOT_^1_%EXT RFRMOT_^1_%EXT FOUT_^1_%EXT EOUT_^1_%EXT DOUT_L**FTN 3.1**_^1_%EXT IPACK_^1_%EXT EWRITE_^1_%EXT RSTORE_^1_%EQU ZERO($22)_^1_%EQU ICODE(3)_^1_%EQU IA(4)_^1_%EQU IB(5)_^1_%EQU DEFLAG(6)_^1_%EQU IFIELD(7)_^1_%EQU JFIELD(8)_^1_%EQU NUMBR(9)_^1_%EQU ITERAT(10)_^1_%EQU IX(11)_^1_%EQU JX(1€€2)_^1_%EQU IBX(13)_^1_%EQU JBX(14)_^1_%EQU IR(15)_^1_%EQU ISTART(23)_^1_%EQU JSTART(24)_^1_%EQU LIST(25)_^1_%EQU MV(26)_^1_%EQU LPAREN(27)_^1_%EQU MAXCH(28)_^1_%EQU ICH(29)_^1_%EQU ARGU1($D8)_^1_%EQU ARGU2($D9)_^1_%EQU ARGU3($DA)_^1_%EQU ARGU4($DB)_^1_%EQU NXTFLD($E0)_^1_%EQU IC($D2)_I**FTN 3.1**_^1_%EQU QAFLAG($D3)_GFTN*3.2_^1I80_"NUM 80_^1CHCNT NUM 156_^1FORMT€€R 0_"0_)***CONTROL PROGRAM_^1_%IIN 0_^1_%RTJ INITAL_^1_%LDA* CHCNT_^1_%LDQ- ICODE,I_%TEST IF REQUEST=READ_^1_%SQM STP1-*-1_^1_%LDA* I80_*YES, SET MAX RECORD=80 CHARACTERS_^1STP1_!STA- MAXCH,I_^1_%ENA 0_^1_%STA- LPAREN,I_$=PAREN COUNTER_^1_%STA- IX,I_)=WORD COUNT IN FORMAT_^1_%STA- IBX,I_(=WORD COUNT IN BUFFER_^1_%ENA 1_^1_%STA- JX,I_)=CHARACTER COUNT IN FORMAT_^1_%STA- JBX,I_(€€=CHARACTER COUNT IN BUFFER_^1STP10 ENA 1_^1_%STA- IB,I_)=CURRENT CHARACTER_^1STP20 LDA- ARGU2_(=ADDRESS OF FORMAT_^1_%ADD- IX,I_)ADD WORD COUNT_^1_%STA- ARGU3_^1_%ENA JX_^1_%ADD- I_,=ADDRESS OF CHARACTER_^1_%STA- ARGU4_*COUNT_^1_%RTJ GETCH_^1_%STA- ICH,I_(=CURRENT CONTROL CHARACTER_^1_%TRA Q_.FROM FORMAT_^1_%INA -$20_)TEST ICH=BLANK_^1_%SAN STP22-*-1_^1_%JMP STP320_'YES, I€€GNORE BLANKS_^1STP22 TRQ A_^1_%INA -$30_)TEST ICH=NON-NUMERIC VALUE_^1_%SAM STP30-*-1_^1_%ENA $39_^1_%SUB- ICH,I_^1_%SAP STP24-*-1_^1_%JMP* STP100_'ICH GT $39(NON-NUMERIC)_^1STP24 JMP STP330_^1STP30 TRQ A_^1_%INA -$28_)TEST ICH=LEFT PAREN_^1_%SAN STP40-*-1_^1_%JMP STP300_'YES, UPDATE PAREN COUNTER_^1STP40 TRQ A_^1_%INA -$29_)TEST ICH=RIGHT PAREN_^1_%SAN STP50-*-1_^€€1_%JMP STP308_'YES, REDUCE PAREN COUNTER_^1STP50 TRQ A_^1_%INA -$2F_)TEST ICH=SLASH_^1_%SAN STP60-*-1_^1_%JMP STP340_'YES, INSERT CARRIAGE RETRN_^1STP60 TRQ A_^1_%INA -$2C_)TEST ICH=COMMA_^1_%SAN STP100-*-1_^1_%JMP STP350_'YES, UPDATE FORMAT COUNTS_^1STP100 LDA- IB,I_^1_%STA- NUMBR,I_%=ITERATION/FORMAT CONTROL_^1_%ENA IX_-CHARACTER_^1_%ADD- I_^1_%STA- ARGU3_^1_%INA 1_^€€1_%STA- ARGU4_^1P1_#RTJ UPDATE_'UPDATE IX,JX_^1_%TRQ A_^1_%INA -$48_)TEST ICH=(H)_^1_%SAN ST1010_LFTN*3.2_^1_%JMP STP180_'YES, HOLLERITH DATA FOLLOWING H_$FTN*3.2_^1ST1010 TRQ A_QFTN*3.2_^1_%INA -$27_)TEST ICH = (')_6FTN*3.2_^1_%SAN ST1020_LFTN*3.2_^1_%ENA 1_QFTN*3.2_^1_%STA- QAFLAG_'QAFLAG = 1_:FTN*3.2_^1_%JMP STP180_'YES, HOLLERITH DATA FOLLOWING QUOTE FTN*3.2_^1ST1020€€ TRQ A_QFTN*3.2_^1_%INA -$2A_)TEST ICH = (*)_6FTN*3.2_^1_%SAN STP101_LFTN*3.2_^1_%ENA 0_QFTN*3.2_^1_%STA- QAFLAG_'QAFLAG = 0_:FTN*3.2_^1_%JMP* STP180_LFTN*3.2_^1STP101 TRQ A_^1_%INA -$58_)TEST ICH=(X)_^1_%SAZ STP102-*-1_"YES, IGNORE FIELD WIDTH_^1_%LDA- ARGU2_(NO, CONVERT FIELD WIDTH IN_^1_%STA- ARGU3_*FORMAT SPECIFICATION_^1_%RTJ INTGR_^1_%LDA- IB,I_^1_%STA- IFIELD,I_$=FIE€€LD WIDTH_^1_%LDA- ARGU2_^1_%STA- ARGU3_(CHECK FOR FIELD SPEC BE-_^1_%RTJ DECPL_*YOND THE DECIMAL PLACE_^1STP102 LDA- ICODE,I_%TEST FOR ENCODE/DECODE REQ_^1_%SAP STP104-*-1_^1_%JMP STP200_'ENCODE REQUEST_^1STP104 RAO- NUMBR,I_^1LOOP1 LDA- NUMBR,I_%DECODE REQUEST_^1_%INA -1_^1_%SAN STP106-*-1_"TEST NUMBR=0_^1_%JMP* STP10_(YES, GET NEXT FORMAT SPEC_^1STP106 STA- NUMBR,I_^1_%LDA-€€ ICH,I_(TEST ICH=(X)_^1_%INA -$58_^1_%SAN STP110-*-1_^1_%ENA IBX_^1_%ADD- I_^1_%STA- ARGU3_^1_%INA 1_^1_%STA- ARGU4_^1_%RTJ* (P1+1)_'YES, IGNORE CHARACTER IN_^1_%JMP* LOOP1_*BUFFER_^1STP110 LDA- MV,I_^1_%SAN STP111-*-1_^1_%JMP STP400_^1STP111 LDA- ICH,I_^1_%INA -$49_)TEST ICH=(I)_^1_%SAZ CONTUE-*-1_^1_%JMP* STP115_^1CONTUE ENA -0_^1_%STA- JFIELD,I_^1_%LDA- ARGU1_^1_%STA- A€€RGU3_(YES, CONVERT NO. IN BUFFER_^1_%RTJ DCHX_+AS A DECIMAL INTEGER_^1_%LDA- JFIELD,I_^1_%SAP STP113-*-1_^1_%LDQ- IA,I_^1_%LDA- IB,I_^1_%SQP STP112-*-1_^1_%TCA A_^1_%TCQ Q_^1STP112 SQN STP113-*-1_^1_%SAP STP114-*-1_^1STP113 RTJ EWRITE_^1STP114 JMP* STP150_^1STP115 LDA- ICH,I_(TEST IF ICH=($)_^1_%INA -$24_)TEST ICH=($)_^1_%SAN ST1155_LFTN*3.2_^1_%LDA- ARGU1_^1_%STA- ARGU3_€€(YES, CONVERT NO. IN BUFFER_^1_%RTJ ASCHX_*AS A HEXIDECIMAL NUMBER_^1_%JMP* STP150_^1ST1155 LDA- ICH,I_MFTN*3.2_^1_%INA -$5A_)TEST ICH=(Z) ON READ OR DECODE_%FTN*3.2_^1_%SAN STP116_LFTN*3.2_^1_%LDA- ARGU1_MFTN*3.2_^1_%STA- ARGU3_(YES, CONVERT NO. IN BUFFER_*FTN*3.2_^1_%RTJ ASCHX_(AS A HEXIDECIMAL INTEGER_,FTN*3.2_^1_%JMP* STP150_LFTN*3.2_^1STP116 LDA- ICH,I_(TEST IF ICH=(A)_^1_€€%INA -$41_^1_%SAN STP120-*-1_^1_%ENA 2_,YES, CK FIELD WIDTH GT 2_^1_%SUB- IFIELD,I_^1_%SAP STP118-*-1_^1P2_#RTJ EWRITE_'YES, ERROR_^1STP118 LDA- ARGU1_^1_%STA- ARGU3_(PICK UP ALPHA-NUMERIC_^1_%RTJ AFRMIN_)CHARACTERS IN BUFFER_^1_%JMP* STP150_^1STP120 LDA- ICH,I_(TEST ICH=(R)_^1_%INA -$52_^1_%SAN STP130-*-1_^1_%ENA 1_,YES, CK FIELD WIDTH=1_^1_%SUB- IFIELD,I_^1_%SAP STP122-€€*-1_^1_%RTJ* (P2+1)_'NO, ERROR_^1STP122 LDA- ARGU1_^1_%STA- ARGU3_^1_%RTJ RFRMIN_'PICK UP ALPH-NUMERIC_^1_%JMP* STP150_)CHARACTERS WITH R-FORMAT_^1STP130 LDA- ICH,I_(TEST ICH=(F)_^1_%INA -$46_^1_%SAZ STP132-*-1_^1_%RTJ* (P2+1)_'NO, FORMAT ERROR_^1STP132 LDA- ARGU1_^1_%STA- ARGU3_(YES, CONVERT NUMBER IN_^1_%RTJ FLOTIN_)BUFFER AS FLOATING POINT_^1P2X_"RTJ Q8QGET_'GET ADDRESS OF €€VARIABLE IN Q-REG_^1_%LDA- IA,I_)SAVE UPPER HALF OF FLOATING POINT_^1_%STA- (ZERO),Q_'NUMBER IN VARIABLE LIST_^1_%INQ 1_^1_%LDA- DEFLAG,I_$SAVE LOWER HALF OF FLOATING POINT NO._^1_%SAP STP152-*-1_"TEST IF ENCODE/DECODE_^1STP150 RTJ* (P2X+1)_%YES, GET ADDRESS FOR IB_^1STP152 LDA- IB,I_^1_%STA- (ZERO),Q_^1STP160 LDA- MV,I_)=NO OF VARIABLES TO BE_^1_%INA -1_-CONVERTED--TERMINATE_^1€€_%STA- MV,I_^1_%JMP* LOOP1_^1STP180 LDA- ICODE,I_^1_%SAP STP182-*-1_^1_%LDA- ARGU1_(ENCODE(FORMAT TO BUFFER)_^1_%LDQ- ARGU2_^1_%JMP* STP190_^1STP182 INA 1_,(ICODE = 1) TRANSFER FROM_-93*3122_^1_%STA- ICODE,I_%BUFFER TO FORMAT FLAG_193*3122_^1_%LDA- IX,I_)SWITCH FORMAT AND BUFFER_.93*3122_^1_%LDQ- IBX,I_*COUNTERS_^1_%STA- IBX,I_^1_%STQ- IX,I_^1_%LDA- JX,I_^1_%LDQ- JBX,I_^1_%STA- J€€BX,I_^1_%STQ- JX,I_^1_%LDA- ARGU2_(DECODE(BUFFER TO FORMAT)_^1_%LDQ- ARGU1_^1STP190 STA- ARGU3_^1_%STQ- ARGU4_^1_%LDA- ICH,I_(TEST ICH = (H)_6FTN*3.2_^1_%INA -$48_NFTN*3.2_^1_%SAN ST1900_LFTN*3.2_^1_%RTJ HOLRTH_'PROCESS HOLLERITH CHARACTERS_(FTN*3.2_^1_%JMP* ST1910_LFTN*3.2_^1ST1900 RTJ QUOTE_(PROCESS HOLLERITH CHARACTERS_(FTN*3.2_^1ST1910 LDA- ICODE,I_KFTN*3.2_^1_%SAP STP192-€€*-1_^1_%JMP STP10_^1STP192 INA -1_+RESTORE ICODE FLAG_493*3122_^1_%STA- ICODE,I_%ICODE =0_>93*3122_^1_%LDA- IX,I_)RESWITCH COUNTERS_593*3122_^1_%LDQ- IBX,I_^1_%STA- IBX,I_^1_%STQ- IX,I_^1_%LDA- JX,I_^1_%LDQ- JBX,I_^1_%STA- JBX,I_^1_%STQ- JX,I_^1_%JMP STP10_^1STP200 RAO- NUMBR,I_%ENCODE REQUEST_^1LOOP2 LDA- NUMBR,I_^1_%INA -1_^1_%SAN STP202-*-1_^1_%JMP STP10_(NUMBR=0 GET NU F€€ORMAT SPEC_^1STP202 STA- NUMBR,I_^1_%LDA- ICH,I_(TEST ICH=(X)_^1_%INA -$58_^1_%SAN STP210-*-1_^1_%LDA- ARGU1_^1_%STA- ARGU3_(YES, INSERT N-SPACES INTO_^1_%RTJ SPACEX_^1_%JMP* LOOP2_^1STP210 LDA- MV,I_^1_%SAN STP212-*-1_^1_%JMP STP400_^1STP212 RTJ* (P2X+1)_^1_%LDA- (ZERO),Q_^1_%STA- IB,I_^1_%INQ 1_,=ADDRESS OF LOWER HALF OF_^1_%STQ- IA,I_+FLOATING POINT NUMBER_^1_%LDA- ICH,I_(€€TEST ICH=(I)_^1_%INA -$49_^1_%SAN STP220-*-1_^1_%LDA- ARGU1_^1_%STA- ARGU3_(YES, CONVERT VARIABLE TO A_^1_%LDA- JFIELD,I_^1_%STA- NXTFLD_^1_%ENQ 0_^1_%LDA- IB,I_^1_%SAP STP214-*-1_^1_%TCQ Q_^1STP214 STQ- IA,I_^1_%RTJ HXDC_+DECIMAL INTEGER_^1_%LDA- NXTFLD_^1_%STA- JFIELD,I_^1_%JMP* STP260_^1STP220 LDA- ICH,I_(TEST ICH=($)_^1_%INA -$24_^1_%SAN STP225_N81*2090_^1_%LDA- ARGU1_^€€1_%STA- ARGU3_(YES, CONVERT VARIABLE AS A_^1_%RTJ HXASC_*HEXIDECIMAL INTEGER_^1_%JMP* STP260_^1STP225 LDA- ICH,I_(TEST ICH=(Z) ON WRITE OR ENCODE_'FTN*3.2_^1_%INA -$5A_NFTN*3.2_^1_%SAN STP230_LFTN*3.2_^1_%LDA- ARGU1_MFTN*3.2_^1_%STA- ARGU3_(YES, CONVERT VARIABLE AS A_*FTN*3.2_^1_%RTJ HXASC_(HEXIDECIMAL INTEGER_1FTN*3.2_^1_%JMP* STP260_LFTN*3.2_^1STP230 LDA- ICH,I_(TEST ICH=(A)_€€^1_%INA -$41_^1_%SAN STP240-*-1_^1_%ENA 2_,YES, TEST IF FIELD WIDTH_^1_%SUB- IFIELD,I_'GT 2_^1_%SAP STP232-*-1_^1P3_#RTJ EWRITE_^1STP232 LDA- ARGU1_^1_%STA- ARGU3_(STORE ALPHA-NUMERIC CHARA-_^1_%RTJ AFRMOT_)CTERS INTO BUFFER_^1_%JMP* STP260_^1STP240 LDA- ICH,I_(TEST ICH=(R)_^1_%INA -$52_^1_%SAN STP250-*-1_^1_%ENA 1_,YES, TEST IF FIELD WIDTH=1_^1_%SUB- IFIELD,I_^1_%SAP STP€€242-*-1_^1_%RTJ* (P3+1)_^1STP242 LDA- ARGU1_^1_%STA- ARGU3_(STORE WITH R-FORMAT CHARA-_^1_%RTJ RFRMOT_)CTERS INTO BUFFER_^1_%JMP* STP260_^1STP250 LDQ- IA,I_)FLOATING POINT NUMBER_^1_%LDA- IB,I_)SHIFT UPPER HALF TO IA_^1_%STA- IA,I_)SAVE LOWER HALF IN IB_^1_%LDA- DEFLAG,I_^1_%SAP STP251-*-1_"TEST IF ENCODE/DECODE CALL_^1_%RTJ Q8QGET_'YES, UPDATE LIST ADDRESS_^1STP251 LDA- (ZERO),€€Q_^1_%STA- IB,I_^1_%LDA- 1,Q_*PICK UP THIRD WORD_0**FTN 3.1**_^1*_8OF FLOATING POINT NUMBER_***FTN 3.1**_^1_%STA- IC_+AND STORE IN IC_3**FTN 3.1**_^1_%LDA- ICH,I_(TEST ICH=(F)_^1_%INA -$46_^1_%SAN STP252-*-1_^1_%LDA- ARGU1_^1_%STA- ARGU3_(CONVERT FLOATING POINT_^1_%RTJ FOUT_+NUMBER AS FIXED POINT_^1_%JMP* STP260_^1STP252 LDA- ICH,I_(TEST ICH=(E)_^1_%INA -$45_^1_%SAN STP254-*-1€€_F**FTN 3.1**_^1_%LDA- ARGU1_K**FTN 3.1**_^1_%STA- ARGU3_(CONVERT FLOATING POINT_,**FTN 3.1**_^1_%RTJ EOUT_+NUMBER AS EXPONENT OF 10_(**FTN 3.1**_^1_%JMP* STP260_J**FTN 3.1**_^1STP254 LDA- DEFLAG,I_H**FTN 3.1**_^1_%SAP STP255-*-1_"TEST IF ENCODE/DECODE CALL_(**FTN 3.1**_^1_%RTJ Q8QGET_'YES, UPDATE LIST ADDRESS_***FTN 3.1**_^1STP255 LDA- ICH,I_(TEST ICH=(D)_6**FTN 3.1**_^1_%INA €€-$44_L**FTN 3.1**_^1_%SAZ STP256-*-1_F**FTN 3.1**_^1_%RTJ* (P3+1)_'NO, FORMAT ERROR_2**FTN 3.1**_^1STP256 LDA- ARGU1_K**FTN 3.1**_^1_%STA- ARGU3_(CONVERT DOUBLE PRECISION FLOATING **FTN 3.1**_^1_%RTJ DOUT_)POINT NUMBER AS EXPONENT OF 10_#**FTN 3.1**_^1STP260 LDA- MV,I_)=NO OF VARIABLES TO BE_^1_%INA -1_-CONVERTED--TERMINATE_^1_%STA- MV,I_^1_%JMP* LOOP2_^1STP300 LDA- IB,I_)=ITER€€ATION COUNT FOR PARA-_^1_%STA- ITERAT,I_'THESIZED FORMAT_^1_%RAO- LPAREN,I_^1_%ENA 2_,THERE CAN BE NO MORE THAN_^1_%SUB- LPAREN,I_'ONE LEVEL OF ()-FORMAT_^1_%SAP STP302-*-1_^1_%RTJ* (P3+1)_'YES, ERROR_^1STP302 ENA IX_^1_%ADD- I_^1_%STA- ARGU3_^1_%INA 1_^1_%STA- ARGU4_^1_%RTJ UPDATE_'UPDATE FORMAT COUNTS_^1_%LDA- IX,I_)=ORDINAL TO THE START OF_^1_%STA- ISTART,I_'THE ()-FORMAT_^€€1_%LDA- JX,I_^1_%STA- JSTART,I_^1_%JMP STP10_^1STP308 LDA- ITERAT,I_$RIGHT PAREN ENCOUNTERED---_^1_%INA -1_-TEST IF FORMAT WITHIN ()_^1_%SAZ STP312-*-1_$IS TO BE REPEATED_^1STP310 STA- ITERAT,I_^1STP311 LDA- ISTART,I_$REPEAT PARENTHESIZED EXPRESSION_^1_%STA- IX,I_^1_%LDA- JSTART,I_^1_%STA- JX,I_^1_%JMP STP10_^1STP312 LDA- LPAREN,I_^1_%INA -1_^1_%SAN STP314-*-1_"TEST PAREN COU€€NT=1_^1_%LDA- MV,I_^1_%SAZ STP313-*-1_^1_%LDA- $E_+SET FLAG FOR END OF FORMAT_*69*1569_^1_%STA- ICH,I_M69*1569_^1_%JMP* STP340_'CONTINUE ON NEW RECORD_.69*1569_^1STP313 JMP* STP400_^1STP314 STA- LPAREN,I_$NO, CONTINUE SCANNING_^1_%JMP* STP350_)FORMAT_^1STP320 ENA IX_+UPDATE FORMAT COUNTERS_^1_%ADD- I_^1_%STA- ARGU3_^1_%INA 1_^1_%STA- ARGU4_^1P4_#RTJ UPDATE_^1_%JMP STP20_^1STP3€€30 LDA- ARGU2_(CONVERT A DECIMAL INTEGER_^1_%STA- ARGU3_*NUMBER_^1_%RTJ INTGR_^1_%JMP STP20_^1STP340 LDA- ICODE,I_%A SLASH WAS ENCOUNTERED IN THE FORMAT_^1_%SAM STP342-*-1_$INSERT A CARRAGE RETURN IN THE_^1_%JMP* STP350_)OUTPUT BUFFER_^1STP342 ENA 13_^1_%STA- IB,I_^1_%LDA CHCNT_^1_%INA 1_^1_%STA- MAXCH,I_^1_%LDA- ARGU1_(COMPUTE BUFFER ADDRESS_^1_%ADD- IBX,I_^1_%STA- ARGU3_^1_€€%ENA JBX_^1_%ADD- I_^1_%STA- ARGU4_^1P5_#RTJ IPACK_(PACK CHARACTER INTO BUFFER_^1_%ENA IBX_*UPDATE BUFFER COUNTERS_^1_%ADD- I_^1_%STA- ARGU3_^1_%INA 1_^1_%STA- ARGU4_^1_%RTJ* (P4+1)_^1STP350 ENA IX_+UPDATE FORMAT COUNTS_^1_%ADD- I_^1_%STA- ARGU3_^1_%INA 1_^1_%STA- ARGU4_^1_%RTJ* (P4+1)_^1_%LDA- ICH,I_M69*1569_^1_%SUB- $E_P69*1569_^1_%SAN STP355_'SKIP NOT END OF FORMAT_.69*15€\69_^1_%JMP* STP311_L69*1569_^1STP355 JMP STP10_M69*1569_^1STP400 JMP RSTORE_^1_%END_]_^__ \PQ8QFIR CSY/ D25 P€1_%NAM Q8QFIR_'DECK-ID D25 FTN 3.3 RUNTIME_%SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^1_%SPC 2_^1*_$RAISE 10**N, WHERE N=NUMBER OF PLACES BEYOND THE_^1_%ENT Q8QFI_^1_%EXT HFLOT_OFTN 3.3_^1_%EQU SCALE($E1)_^1_%EQU NUFLD($E4)_^1_%EQU JFIELD(8)_^1_%EXT INITAL_€€^1_%EXT RSTORE_^1Q8QFI 0_"0_)***RAISE 10**N_^1_%IIN 0_^1_%RTJ INITAL_^1_%LDA* FLOT1_^1_%STA- SCALE_^1_%ENA 0_^1_%STA- SCALE+1_^1LOOP_!LDA- JFIELD,I_^1_%INA -1_^1_%SAP NEXT-*-1_^1_%LDA- NUFLD_^1_%STA- JFIELD,I_^1_%JMP RSTORE_^1NEXT_!STA- JFIELD,I_^1_%RTJ HFLOT_OFTN 3.3_^1_%NUM $B9D4_^1_%ADC SCALE_^1_%ADC FLOT10_^1_%ADC SCALE_^1_%JMP* LOOP_^1FLOT10 NUM $4250,$0_^1FLOT1 € NUM $40C0_^1_%END_]_^__ PQ8QFLR CSY/ D26 P€1_%NAM Q8QFLR_'DECK-ID D26 FTN 3.3 RUNTIME_%SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3_^1*_$SMALL COMPUTER DEVELOPMENT DIVISION, LA JOLLA CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1973_^1_%SPC 2_^1*_$CONVERT 2 WORD INTEGER VALUE TO A FLOATING POINT NUMBER_^1_%ENT Q8QFL_^1_%EXT INITAL_^1_%EXT RSTORE_^1_%EQU LPMSK(3)_^1_%EQU IA(4)_^1_%EQU IB(5)_^1_%EQU €€A1($DE)_^1Q8QFL 0_"0_)***CONVERT FIXED TO FLOATING_^1_%IIN 0_^1_%RTJ INITAL_^1_%LDA- IA,I_^1_%LDQ- IB,I_^1_%SAP FLT1-*-1_^1_%TCA A_^1_%TCQ Q_^1_%STQ- IB,I_^1FLT1_!SAN FLT2-*-1_^1_%SQN FLT2-*-1_^1_%STA- A1+1_)5/18/69_^1_%JMP* RTRN_^1FLT2_!CLR Q_^1_%STQ- A1_^1_%SAN FLT3-*-1_^1_%ENQ 16_^1_%STQ- A1_^1_%LDQ- IB,I_^1_%JMP* FLT4_^1FLT3_!TRA Q_^1_%LDA- IB,I_^1FLT4_!SQM FLT5-*-€>1_^1_%LLS 1_^1_%RAO- A1_^1_%JMP* FLT4_^1FLT5_!LRS 9_^1_%STA- A1+1_^1_%LDA- LPMSK+6_^1_%LAQ Q_^1_%LDA- A1_^1_%INA -9_^1_%TCA A_^1_%ADD =N$97_^1_%ALS 7_^1_%EAQ Q_^1RTRN_!LDA- IA,I_)5/18/69_^1_%SAP FLT8-*-1_^1_%TCQ Q_^1_%LDA- A1+1_^1_%TCA A_^1_%STA- A1+1_)5/18/69_^1FLT8_!STQ- A1_^1_%JMP RSTORE_^1_%END_]_^__ >PQ8QFXR CSY/ D27 P€1_%NAM Q8QFXR_'DECK-ID D27 FTN 3.3 RUNTIME_%SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3_^1*_$SMALL COMPUTER DEVELOPMENT DIVISION, LA JOLLA CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1973_^1_%SPC 2_^1_%ENT Q8QFX_^1_%EXT INITAL_^1_%EXT RSTORE_^1_%EQU MSK(6)_L71*1626_^1_%EQU IA(4)_^1_%EQU IB(5)_^1_%EQU LLS(9)_^1_%EQU A2($DC)_^1Q8QFX 0_"0_)***CONVERT FLOA€€TING TO FIXED_^1_%IIN 0_^1_%RTJ INITAL_^1_%LDA- A2_^1_%SAP FIX-*-1_^1_%TCA A_^1_%LDQ- A2+1_^1_%TCQ Q_^1_%STQ- A2+1_^1FIX_"ENQ 0_^1_%LLS 2_^1_%SQN FIX1-*-1_^1_%ENA 0_^1_%JMP* OUT_^1FIX1_!ENQ 0_^1_%LLS 2_^1_%SQZ FIX2-*-1_^1_%LDA- A2_^1_%LDQ- A2+1_^1_%STQ- IB,I_^1_%JMP* RTRN_^1FIX2_!LDQ- LLS_^1_%IIN 0_^1_%SAP FIX3-*-1_^1_%LLS 5_^1_%INQ -1_^1_%STQ* SHIFT1_^1_%ENQ 0_^1_€v%LLS 7_^1_%LDA- A2+1_^1_%LRS 6_^1_%EIN 0_^1SHIFT1 LLS 0_^1_%JMP* OUT_^1FIX3_!LLS 5_^1_%STQ* SHIFT2_^1_%ENQ 0_^1_%LLS 7_^1_%LDA- A2+1_^1_%LRS 7_^1_%EIN 0_^1SHIFT2 LLS 0_^1_%ENA 0_^1OUT_"STQ- IB,I_^1_%AND- MSK_*REMOVE ALL EXTRANEOUS BITS_^1_%LDQ- A2_^1_%SQP RTRN-*-1_^1_%TCA A_^1_%LDQ- IB,I_^1_%TCQ Q_^1_%STQ- IB,I_^1RTRN_!STA- IA,I_^1_%JMP RSTORE_^1_%END_]_^__vPHEXAR CSY/ D28 P€1_%NAM HEXAR_(DECK-ID D28 FTN 3.3 RUNTIME_%SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3_^1*_$SMALL COMPUTER DEVELOPMENT DIVISION, LA JOLLA CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1973_^1_%SPC 2_^1*_$CONVERT A VARIABLE INTO ASCII CODE_^1_%ENT HEXASC_^1_%EXT INITL1_^1_%EXT HXASC_^1_%EXT RESTRE_^1_%EXT CHCNT_^1_%EQU ZERO($22)_^1_%EQU ARGU1($D8)_^1_%EQU €€ARGU3($DA)_^1_%EQU IB(5)_^1_%EQU DEFLAG(6)_^1_%EQU IFIELD(7)_^1_%EQU IBX(13)_^1_%EQU JBX(14)_^1_%EQU LIST(25)_^1_%EQU MAXCH(28)_^1HEXASC 0_"0_)***CONVERT HEX TO ASCII_^1_%IIN 0_^1_%RTJ INITL1_^1HEXAS1 ENA -1_N**MSOS4.0**_^1_%STA- DEFLAG,I_^1_%LDA CHCNT_^1_%STA- MAXCH,I_^1_%ENA 4_^1_%STA- IFIELD,I_$SET FIELD WIDTH=4_^1_%ENA 1_^1_%STA- IBX,I_(INITIALIZE BUFFER COUNTS_^1_€è%STA- JBX,I_^1_%LDA- (ARGU1)_%PLACE HEX VARIABLE IN IB_^1_%STA- IB,I_^1_%LDA- LIST,I_'SET BUFFER ADDRESS IN_^1_%INA -1_-ARGU3_^1_%STA- ARGU3_^1_%RTJ HXASC_(CONVERT AND PACK CHARACTER_^1_%JMP RESTRE_^1I150_!NUM 150_^1_%END_]_^__ èPHEXDR CSY/ D29 P€1_%NAM HEXDR_(DECK-ID D29 FTN 3.3 RUNTIME_%SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3_^1*_$SMALL COMPUTER DEVELOPMENT DIVISION, LA JOLLA CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1973_^1_%SPC 2_^1*_$CONVERT A VARIABLE TO DECIMAL FORMAT_^1_%ENT HEXDEC_^1_%EXT INITL1_^1_%EXT HXDC_^1_%EXT CHCNT_^1_%EXT RESTRE_^1_%EQU ZERO($22)_^1_%EQU ARGU1($D8)_^1_%EQU €€ ARGU3($DA)_^1_%EQU IA(4)_^1_%EQU IB(5)_^1_%EQU DEFLAG(6)_^1_%EQU IFIELD(7)_^1_%EQU JFIELD(8)_^1_%EQU IBX(13)_^1_%EQU JBX(14)_^1_%EQU LIST(25)_^1_%EQU MAXCH(28)_^1HEXDEC 0_"0_)***FORMAT A DECIMAL INTEGER_^1_%IIN 0_^1_%RTJ INITL1_^1HEXDX1 ENA -1_N**MSOS4.0**_^1_%STA- DEFLAG,I_^1_%LDA CHCNT_^1_%STA- MAXCH,I_^1_%ENA 0_^1_%STA- JFIELD,I_$PLACES BEYOND DECIMAL PT=0_^1_%ENA€Z 6_^1_%STA- IFIELD,I_$FIELD WIDTH=6_^1_%ENA 1_^1_%STA- IBX,I_(INITIALIZE BUFFER COUNTS_^1_%STA- JBX,I_^1_%LDA- (ARGU1)_^1_%STA- IB,I_)SET IB=HEX INTEGER_^1_%LDQ- LIST,I_^1_%INQ -1_^1_%STQ- ARGU3_(=ADDRESS OF BUFFER_^1_%ENQ 0_^1_%SAP NXT-*-1_^1_%TCQ Q_^1NXT_"STQ- IA,I_^1_%RTJ HXDC_)CONVERT AND PACK CHARACTER_^1_%JMP RESTRE_^1_%END_]_^__ ZPASCIIR CSY/ D30 P€1_%NAM ASCIIR_'DECK-ID D30 FTN 3.3 RUNTIME_%SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3_^1*_$SMALL COMPUTER DEVELOPMENT DIVISION, LA JOLLA CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1973_^1_%SPC 2_^1*_$CONVERT A VARIABLE FROM ASCII TO HEX_^1_%ENT ASCII_^1_%EXT INITL1_^1_%EXT ASCHX_^1_%EXT RESTRE_^1_%EQU ZERO($22)_^1_%EQU ARGU1($D8)_^1_%EQU ARGU3($DA)_^1€€_%EQU IB(5)_^1_%EQU DEFLAG(6)_^1_%EQU IFIELD(7)_^1_%EQU IBX(13)_^1_%EQU JBX(14)_^1_%EQU LIST(25)_^1ASCII 0_"0_)***CONVERT FROM ASCII TO HEX_^1_%IIN 0_^1_%RTJ INITL1_^1ASCII1 ENQ -1_N**MSOS4.0**_^1_%STQ- DEFLAG,I_^1_%ENA 4_^1_%STA- IFIELD,I_$FIELD WIDTH=4_^1_%ENA 1_^1_%STA- IBX,I_(INITIALIZE BUFFER COUNTS_^1_%STA- JBX,I_^1_%LDA- ARGU1_^1_%INA -1_^1_%STA- ARGU3_^1_%RTJ €ˆASCHX_(CONVERT FROM ASCII TO HEX_^1_%LDQ- LIST,I_^1_%LDA- IB,I_^1_%STA- (ZERO),Q_$STORE CONVERTED INTEGER_^1_%JMP RESTRE_^1_%END_]_^__ ˆPDECHXR CSY/ D31 P€1_%NAM DECHXR_'DECK-ID D31 FTN 3.3 RUNTIME_%SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3_^1*_$SMALL COMPUTER DEVELOPMENT DIVISION, LA JOLLA CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1973_^1_%SPC 2_^1*_$CONVERT DECIMAL INTEGER TO HEX_^1_%ENT DECHEX_^1_%EXT INITL1_^1_%EXT DCHX_^1_%EXT RESTRE_^1_%EQU ZERO($22)_^1_%EQU ARGU1($D8)_^1_%EQU ARGU3($DA)_^1_%EQU €€ IA(4)_^1_%EQU IB(5)_^1_%EQU DEFLAG(6)_^1_%EQU IFIELD(7)_^1_%EQU JFIELD(8)_^1_%EQU IBX(13)_^1_%EQU JBX(14)_^1_%EQU LIST(25)_^1DECHEX 0_"0_)***DECIMAL INTEGER CONVERSION_^1_%IIN 0_^1_%RTJ INITL1_^1DECHX1 ENA -1_N**MSOS4.0**_^1_%STA- DEFLAG,I_^1_%ENA 6_^1_%STA- IFIELD,I_$FIELD WIDTH=6_^1_%ENA 0_^1_%STA- JFIELD,I_$PLACES BEYOND DECIMAL PT=0_^1_%ENA 1_^1_%STA- IBX,I_(INITI€bALIZE BUFFER COUNTS_^1_%STA- JBX,I_^1_%LDA- ARGU1_^1_%INA -1_^1_%STA- ARGU3_^1_%RTJ DCHX_)CONVERT DECIMAL CHARACTERS_^1_%LDA- IB,I_^1_%LDQ- IA,I_^1_%SQP NXT-*-1_^1_%TCA A_^1_%TCQ Q_^1NXT_"SQN NXT1-*-1_^1_%SAP NXT2-*-1_^1NXT1_!ENA -1_^1_%JMP* OUT_^1NXT2_!LDQ- LIST,I_^1_%LDA- IB,I_^1_%STA- (ZERO),Q_$STORE VARIABLE_^1OUT_"JMP RESTRE_^1_%END_]_^__bPAFORMR CSY/ D32 P€1_%NAM AFORMR_'DECK-ID D32 FTN 3.3 RUNTIME_%SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3_^1*_$SMALL COMPUTER DEVELOPMENT DIVISION, LA JOLLA CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1973_^1_%SPC 2_^1*_$CONVERT A SINGLE VARIABLE WITH (A)FORMAT_^1_%ENT AFORM_^1_%EXT INITL1_^1_%EXT AFRMIN_^1_%EXT RESTRE_^1_%EQU ZERO($22)_^1_%EQU ARGU1($D8)_^1_%EQU ICOUNT($€€D9)_^1_%EQU ARGU3($DA)_^1_%EQU IB(5)_^1_%EQU DEFLAG(6)_^1_%EQU IFIELD(7)_^1_%EQU JFIELD(8)_^1_%EQU IBX(13)_^1_%EQU JBX(14)_^1_%EQU LIST(25)_^1AFORM 0_"0_)***(A)FORMATTED VARIABLE_^1_%IIN 0_^1_%RTJ INITL1_^1AFORM1 ENA -1_N**MSOS4.0**_^1_%STA- DEFLAG,I_^1_%ENA 1_,INITIALIZE THE BUFFER CNTS_^1_%STA- IFIELD,I_^1_%STA- IBX,I_^1_%STA- JBX,I_^1_%STA- ICOUNT_^1LOOP_!LDA- ARGU1€6_^1_%INA -1_^1_%STA- ARGU3_^1_%RTJ AFRMIN_'MASK CHARACTER OUT OF WORD_^1_%LDQ- ICOUNT_^1_%INQ -1_^1_%ADQ- LIST,I_^1_%LDA- IB,I_^1_%STA- (ZERO),Q_$SAVE VARIABLE_^1_%ENA 2_,=2 CHARACTERS/WORD_^1_%SUB- ICOUNT_^1_%SAZ OUT-*-1_^1_%RAO- ICOUNT_^1_%JMP* LOOP_)GET NEXT CHARACTER_^1OUT_"JMP RESTRE_^1_%END_]_^__ 6PRFORMR CSY/ D33 P€1_%NAM RFORMR_'DECK-ID D33 FTN 3.3 RUNTIME_%SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3_^1*_$SMALL COMPUTER DEVELOPMENT DIVISION, LA JOLLA CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1973_^1_%SPC 2_^1*_$CONVERT A SINGLE VARIABLE WITH (R)FORMAT_^1_%ENT RFORM_^1_%EXT INITL1_^1_%EXT RFRMIN_^1_%EXT RESTRE_^1_%EQU ZERO($22)_^1_%EQU ARGU1($D8)_^1_%EQU ICOUNT($€€D9)_^1_%EQU ARGU3($DA)_^1_%EQU IB(5)_^1_%EQU DEFLAG(6)_^1_%EQU IFIELD(7)_^1_%EQU IBX(13)_^1_%EQU JBX(14)_^1_%EQU LIST(25)_^1RFORM 0_"0_)***(R)FORMATTED VARIABLE_^1_%IIN 0_^1_%RTJ INITL1_^1RFORM1 ENA -1_N**MSOS4.0**_^1_%STA- DEFLAG,I_^1_%ENA 1_^1_%STA- IFIELD,I_$INITIALIZE BUFFER COUNTS_^1_%STA- IBX,I_^1_%STA- JBX,I_^1_%STA- ICOUNT_^1LOOP_!LDA- ARGU1_^1_%INA -1_^1_%STA-€ ARGU3_^1_%RTJ RFRMIN_'MASK CHARACTER_^1_%LDQ- ICOUNT_^1_%INQ -1_^1_%ADQ- LIST,I_^1_%LDA- IB,I_^1_%STA- (ZERO),Q_$SAVE CHARACTER_^1_%ENA 2_,=2 CHARACTERS/WORD_^1_%SUB- ICOUNT_^1_%SAZ OUT-*-1_^1_%RAO- ICOUNT_^1_%JMP* LOOP_)GET 2ND CHARACTER_^1OUT_"JMP RESTRE_^1_%END_]_^__PFLOTGR CSY/ D34 P€1_%NAM FLOTGR_'DECK-ID D34 FTN 3.3 RUNTIME_%SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3_^1*_$SMALL COMPUTER DEVELOPMENT DIVISION, LA JOLLA CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1973_^1_%SPC 2_^1*_$CONVERT A FLOATING POINT NUMBER TO AN (E)FORM_^1_%ENT FLOATG_^1_%EXT INITL1_^1_%EXT EOUT_^1_%EXT RESTRE_^1_%EXT CHCNT_^1_%EQU ZERO($22)_^1_%EQU ARGU1($D8€€)_^1_%EQU ARGU3($DA)_^1_%EQU IA(4)_^1_%EQU IB(5)_^1_%EQU DEFLAG(6)_^1_%EQU IFIELD(7)_^1_%EQU JFIELD(8)_^1_%EQU IBX(13)_^1_%EQU JBX(14)_^1_%EQU LIST(25)_^1_%EQU MAXCH(28)_^1FLOATG 0_"0_)***FLOATING POINT CONVERSION_^1_%IIN 0_^1_%RTJ INITL1_'FORMAT OF NUMBER=_^1FLOTG1 ENA -1_N**MSOS4.0**_^1_%STA- DEFLAG,I_^1_%LDA CHCNT_^1_%STA- MAXCH,I_^1_%ENA 12_/S.XXXXXXESXX(S=SIGN)_€h^1_%STA- IFIELD,I_$FIELD WIDTH=12_^1_%ENA 6_^1_%STA- JFIELD,I_$NUMBER OF SIGNIFICANT PL=6_^1_%ENA 1_^1_%STA- IBX,I_^1_%STA- JBX,I_^1_%LDA- (ARGU1)_^1_%STA- IA,I_^1_%RAO- ARGU1_^1_%LDA- (ARGU1)_^1_%STA- IB,I_)IA,IB=FLOATING PT NUMBER_^1_%LDA- LIST,I_^1_%INA -1_^1_%STA- ARGU3_(=ADDRESS OF BUFFER_^1_%RTJ EOUT_)CONVERT AND PACK_^1_%JMP RESTRE_^1_%END_]_^__ hPSGDBLR CSY/ E01 P€1_%NAM SGDBLR_'DECK-ID E01 FTN 3.3 RUNTIME_%SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN RUNTIME VERSION 3.3_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^1_%SPC 5_^1_%ENT SNGL_^1_%ENT DBLE_^1_%ENT Q8SNGL_^1_%ENT Q8DBLE_^1_%SPC 3_^1_%EXT HFLOT_^1_%EXT* PARABS_^1_%SPC 2_^1QSAVE EQU QSAVE($D5)_^1RETURN EQU RETURN($€€D6)_^1TEMP_!EQU TEMP($D7)_^1ZERO_!EQU ZERO($22)_^1_%SPC 3_^1*_$CONVERTS A SINGLE PRECISION ARGUMENT TO DOUBLE PRECISION_^1*_$AND A DOUBLE PRECISION ARGUMENT TO SINGLE PRECISION FORM_^1*_$SINCE THE SINGLE PRECISION ACCUMULATOR IS ALWAYS IN DOUBLE_^1*_$PRECISION FORM, THIS PROGRAM CONSISTS OF A SINGLE PRECISION_^1*_$FLOATING LOAD ONLY._^1_%SPC 3_^1SNGL_!EQU SNGL(*)_^1DBLE_!EQU €€DBLE(*)_^1Q8SNGL EQU Q8SNGL(*)_^1Q8DBLE NOP 0_^1_%IIN 0_^1_%EIN 0_^1_%LDA* SNGL_)PICK UP ADDRESS OF PARAMETER ADDRESS_^1_%STQ- QSAVE_(SAVE CALLER'S Q_^1_%STA- RETURN_'SAVE RETURN ADDRESS_^1_%RAO- RETURN_'BUMP RETURN ADDRESS_^1_%RTJ PARABS_'ABSOLUTIZE PARAMETER ADDRESS_^1_%TRA Q_,PARAMETER ADDRESS TO Q_^1_%LDA- (ZERO),Q_^1_%STA- TEMP_^1_%LDA- 1,Q_^1_%STA- TEMP+1_^1_%RTJ HFLOT€r_^1_%NUM $B400_^1_%ADC TEMP_^1_%LDQ- QSAVE_(RESTORE CALLER'S Q_^1_%JMP- (RETURN)_$RETURN TO CALLER_^1_%END_]_^__rPQ8D2IR CSY/ E02 P€1_%NAM Q8D2IR_'DECK-ID E02 FTN 3.3 RUNTIME_%SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^1_%SPC 2_^1*_$REENTRANT/NOT RUN ANYWHERE_!EXPONTIATION OPERATOR_^1*_$NO SPEC AVAILABLE_^1_%ENT Q8QD2I_'DOUBLE PRECISION FLOATING TO INTEGER_'-1_^1_%ENT Q8QD2F_'D.P. FLOATING T€€O SINGLE PRECISION FLOATING +1_^1_%ENT Q8QD2D_'D.P. FLOATING TO D.P. FLOATING_.0_^1_%EXT PARABS_J**MSOS4.1**_^1*_]_^1_%EQU DFLOFG($E5)_^1_%EQU DFRSLT($DB)_^1_%EQU SIGN($E1)_^1_%EQU COEFF($E2)_^1_%EQU EXPO($D7)_^1_%EQU MLTPR($DE)_^1_%EQU CZERO($22)_^1_%EQU LPMSK(2)_^1_%EQU MASKSB($11)_IFTN 3.3_^1_%EQU THREE($04)_JFTN 3.3_^1_%EQU TWO($24)_LFTN 3.3_^1*_]_^1_%EXT HDFLOT_€€NFTN 3.3_^1_%EXT* IFALT_OFTN 3.3_^1_%EXT DEXP_^1_%EXT DLOG_^1*_]_^1*_]_^1Q8QD2I NUM 0_,ENTRY POINT, D.P. FLOATING TO INTEGER_^1QDI1V4 IIN 0_,INHIBIT FOR PROPER OPERATION_^1_%STQ* QSAVE_(SAVE Q REGISTER_^1_%EIN 0_^1_%LDA* Q8QD2I_'SAVE WORD MARK_^1_%ENQ -1_^1_%JMP* PARAMS_^1*_]_^1*_]_^1Q8QD2D NUM 0_,ENTRY POINT, D.P. FLOATING TO D.P. FLOATING_^1QDD1V4 IIN 0_,INHIBIT FOR PROPE€€R OPERATION_^1_%STQ* QSAVE_(SAVE Q REGISTER_^1_%EIN 0_^1_%LDA* Q8QD2D_'SAVE WORD MARK_^1_%ENQ 0_^1_%JMP* PARAMS_^1*_]_^1*_]_^1Q8QD2F NUM 0_,ENTRY POINT, D.P. FLOATING TO S.P. FLOATING_^1QDF1V4 IIN 0_,INHIBIT FOR PROPER OPERATION_^1_%STQ* QSAVE_^1_%EIN 0_^1_%LDA* Q8QD2F_^1_%ENQ 1_^1*_]_^1*_8PARAMETER PICKUP ROUTINE_^1*_]_^1PARAMS STA* RETADD_'CALLING SEQUENCE ADDRESS_^1GOABS €€RTJ PARABS_'OBTAIN ABSOLUTE COEFFICIENT_'**MSOS4.1**_^1_%EIN 0_,ADDRESS_;**MSOS4.1**_^1_%STA- COEFF_(ADDRESS OF COEFFICIENT_^1_%RAO* RETADD_^1_%LDA* RETADD_'OBTAIN ABSOLUTE EXPONENT_***MSOS4.1**_^1_%RTJ* (GOABS+1)_#ADDRESS_;**MSOS4.1**_^1_%EIN 0_O**MSOS4.1**_^1_%STA- EXPO_)ADDRESS OF EXPONENT_^1_%RAO* RETADD_'COMPUTE RETURN ADDRESS_^1_%STQ- DFLOFG_'SET FLAG_^1_%SQP DRET_)IS EXP€€ONENT FLOATING POINT_^1*_8NO - EXPONENT IS INTEGER_^1_%LDA- (EXPO)_'OBTAIN EXPONENT AND STORE_^1_%STA- SIGN_)IN SIGN_^1_%SAP STABS_^1_%TCA A_,EXPO = - EXPO_^1STABS STA- EXPO_)ABSOLUTE VALUE OF EXPONENT_^1_%JMP* CDFOVF_'GO TO (D**I) LOGIC_^1DRET_!JMP* DLOGEX_'YES EXPONENT IS S.P. OR D.P. FLOATING POINT_^1*_]_^1*_]_^1QSAVE NUM 0_^1RETADD NUM 0_^1*_]_^1*_]_^1*_8THIS LOGIC IS DES€€IGNED TO PERFORM THE DOUBLE_^1*_8PRECISION TO INTEGER EXPONENTIATION (D**I)_^1*_]_^1*_]_^1CDFOVF RTJ IFALT_(CLEAR ALL ERRORS_6FTN 3.3_^1_%ADC THREE_OFTN 3.3_^1_%LDQ- COEFF_OFTN 3.3_^1_%LDA- (CZERO),Q_^1_%STA- DFRSLT_^1_%LDA- 1,Q_^1_%STA- DFRSLT+1_^1_%LDA- 2,Q_^1_%STA- DFRSLT+2_^1DFLTAD RTJ HDFLOT_'PLACE COEFFICIENT IN MULTIPLIER_'FTN 3.3_^1_%NUM $BD5B_4AND INITIALIZE CUMULATIVE€€ RESULT_^1_%ADC DFRSLT_'LDA DFRSLT_^1_%ADC MLTPR_(STA MLTPR_!MLTPR=COEFF_^1_%ADC DFLT1-*_%LDA 1.0D0_^1_%NUM $5D40_(STA DFRSLT DFRSLT=1.0D0_^1_%ADC DFRSLT_^1_%JMP* TSTBT0_^1*_]_^1*_]_^1*_]_^1*_]_^1DLOGEX LDQ- COEFF_(TRANSFER_^1_%LDA- 1,Q_*VALUE OF_^1_%STA- DFRSLT+1_$COEFFICIENT_^1_%LDA- 2,Q_*TO_^1_%STA- DFRSLT+2_$INTERNAL_^1_%LDA- (CZERO),Q_#WORKING_^1_%STA- DFRSLT_'CELLS._^1_€€%SAN LOGNAT_'IF COEFFICIENT IS NONZERO GO TO NAT. LOG._^1SETZRO RTJ* (DFLTAD+1)_"IF COEFFICIENT IS ZERO MAKE RESULT ZERO TO_^1_%NUM $5B40_(AVOID FAULT IN NATURAL LOG ROUTINE._^1_%ADC DFLT0-*_%LDA 0.0D0_^1_%JMP* NOVER_(STA C5, C6, AND C7 - EXIT_^1*_]_^1*_]_^1LOGNAT RTJ DLOG_)TAKE NATURAL LOG OF COEFF - DLOG(COEFF)_^1_%ADC DFRSLT_^1*_]_^1*_8RESULT IN C5,C6, AND C7 THE_^1*_8DOUBL€€E PRECISION FLOATING POINT ACCUMULATOR_^1*_]_^1_%LDQ- EXPO_)TRANSFER_^1_%LDA- (CZERO),Q_#VALUE OF_^1_%STA- DFRSLT_^1_%LDA- 1,Q_*TO_^1_%STA- DFRSLT+1_^1_%LDA- 2,Q_*WORKING_^1_%STA- DFRSLT+2_^1_%LDA- DFLOFG_^1_%SAZ DPEXPO_'IS IT A DOUBLE PRECISION EXPONENT_^1_%ENA 0_,NO - SINGLE PRECISION EXPONENT_^1_%STA- DFRSLT+2_^1DPEXPO RTJ* (DFLTAD+1)_"MULTIPLY BY D.P. OR S.P. EXPONENT CALL D€€FLOT_^1_%NUM $9D40_(FMPY,KG47V4/FLIST,MLTPR_/FTN 3.3_^1_%ADC DFRSLT_^1_%ADC MLTPR_(MLTPR=EXPON*DLOG(COEFF)_^1_%RTJ DEXP_)RAISE E TO COMPUTED EXPONENT_^1_%ADC MLTPR_(DEXP(EXPON*DLOG(COEFF))_^1*_]_^1*_8RESULT IN FLOATING ACCUMULATOR C5,C6, AND C7._^1*_]_^1_%JMP* NOVER_(EXIT_^1*_]_^1*_]_^1TSTBT0 LDQ- EXPO_)TEST BIT ZERO OF THE EXPONENT_^1_%LRS 1_,AND RESET EXPONENT RIGHT SHIFTED€€_^1_%STQ- EXPO_^1_%SAP TST4ZR_^1*_]_^1*_8BIT WAS ON UPDATE_^1*_8CUMULATIVE RESULTS_^1*_]_^1_%RTJ* (DFLTAD+1)_"CALL DFLOT_^1_%NUM $B9D4_^1_%ADC DFRSLT_^1_%ADC MLTPR_^1_%ADC DFRSLT_'DFRSLT=DFRSLT*MLTPR_^1*_]_^1*_]_^1TST4ZR LDA- EXPO_)TEST EXPONENT TO SEE IF ALL SIGNIFICANT_^1_%SAN UPMULT_'BITS HAVE BEEN SHIFTED OUT_^1_%JMP* CHKSIN_^1*_]_^1*_]_^1UPMULT RTJ* (DFLTAD+1)_"SQUARE FL€€OATING MULTIPLIER_%CALL DFLOT_^1_%NUM $B9D4_^1_%ADC MLTPR_^1_%ADC MLTPR_^1_%ADC MLTPR_(MLTPR = MLTPR * MLTPR_^1_%JMP* TSTBT0_^1*_]_^1*_8CHECK SIGN OF EXPONENT FOR NEGATIVE IN WHICH_^1*_8CASE THE RESULT MUST BE INVERTED._^1*_]_^1*_]_^1CHKSIN LDA- SIGN_)INVERT DP FLOATING RESULT_'CALL DFLOT_^1_%SAM MSIGN_^1_%JMP* EXDPFR_^1MSIGN RTJ* (DFLTAD+1)_"INVERT DP FLOATING RESULT_'CALL D€€FLOT_^1_%NUM $5B5A_^1_%ADC DFLT1-*_%LDA 1.0D0_^1_%ADC DFRSLT_'DIV DFRSLT_%1.0D0/DFRSLT_^1_%NUM $4000_^1_%RTJ IFALT_(CHECK FOR_=FTN 3.3_^1_%ADC TWO_*UNDERFLOW_=FTN 3.3_^1_%INA -2_+IN THE_@FTN 3.3_^1_%SAM SETZ_)FLOATING POINT OPERATION_^1_%JMP* EXDPFR_'EXIT_^1SETZ_!JMP* SETZRO_'YES, SET RESULT TO ZERO_^1*_]_^1*_]_^1*_8EXIT WITH D.P. FLOATING RESULT IN_^1*_8LOW CORE CELLS C5,C€€6, AND C7._^1*_]_^1*_]_^1EXDPFR RTJ IFALT_(CHECK FOR OVERFLOW_4FTN 3.3_^1_%ADC CZERO_OFTN 3.3_^1_%INA -2_RFTN 3.3_^1_%SAN OVER_^1_%JMP* NOVER_^1OVER_!RTJ* (DFLTAD+1)_"OVERFLOW OCCURRED_^1_%NUM $5B40_(STORE MAXIMUM NUMBER IN C5,C6, AND C7._^1_%ADC MAXPFV-*_^1NOVER LDQ* QSAVE_^1_%JMP* (RETADD)_$RETURN TO CALLING PROGRAM_^1DFLT1 NUM $40C0_(DOUBLE PRECISION FLOATING CONSTANT 1€ .0D0_^1DFLT0 NUM $0000_(DOUBLE PRECISION FLOATING CONSTANT 0.0D0_^1_%NUM $0000_^1_%NUM $0000_^1MAXPFV NUM $7FFF_^1_%NUM $FFFF_^1_%NUM $FFFF_^1_%END_]_^__ PDABSR CSY/ E03 P€1_%NAM DABSR_(DECK-ID E03 FTN 3.3 RUNTIME_%SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^1_%SPC 2_^1*_]_^1*_8DABS - ABSOLUTE VALUE FUNCTION -_^1*_8ROUTINE TO COMPUTE THE ABSOLUTE VALUE_^1*_8OF A DOUBLE PRECISION FLOATING POINT_^1*_8VALUE AND LEAVE THE RESULT IN THE_^€€1*_8PSEUDO ACCUMULATOR (CELLS C5, C6, AND C7)_^1*_]_^1_%ENT Q8DAB_^1_%ENT DABS_^1_%EXT PARABS_J**MSOS4.1**_^1*_]_^1_%EQU DFLACC($C5)_^1_%EQU QS($E2)_^1_%EQU LPMSK(2)_^1_%EQU ZERO($22)_^1_%EQU RETURN($D5)_^1*_]_^1_%EXT HDFLOT_NFTN 3.3_^1*_]_^1Q8DAB NUM 0_,ENTRY POINT_^1QDABV4 IIN 0_,INHIBIT FOR PROPER OPERATION_^1_%STQ- QS_+SAVE Q REGISTER_^1_%EIN 0_^1_%LDA* Q8DAB_(**NO€€RMALIZE ADDRESS**_-**MSOS4.1**_^1_%STA- RETURN_^1_%RAO- RETURN_^1_%RTJ PARABS_J**MSOS4.1**_^1_%EIN 0_O**MSOS4.1**_^1KLG65K TRA Q_,ADDRESS OF PARAMETER_^1_%LDA- (ZERO),Q_$TRANSFER_^1_%STA- DFLACC_^1_%LDA- 1,Q_*VALUES_^1_%STA- DFLACC+1_^1_%LDA- 2,Q_*PROTECTED_^1_%STA- DFLACC+2_^1DFL_"RTJ HDFLOT_NFTN 3.3_^1_%NUM $BD40_OFTN 3.3_^1_%ADC DFLACC_^1_%ADC DFLACC_NFTN 3.3_^1_%LDA- DFL€ÖACC_^1_%SAP EXIT_PFTN 3.3_^1_%RTJ* (DFL+1)_%VALUE IS NEGATIVE, LOAD AND COMPLEMENT_^1_%NUM $7400_^1EXIT_!LDQ- QS_+RESTORE Q REGISTER_4FTN 3.3_^1_%JMP- (RETURN)_$RETURN TO CALLER_^1_%EQU DABS(Q8DAB)_^1_%END_]_^__ÖPDSQRTR CSY/ E04 P€1_%NAM DSQRTR_'DECK-ID E04 FTN 3.3 RUNTIME_%SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^1_%SPC 2_^1_%EXT HDFLOT_NFTN 3.3_^1_%EQU C($C5),D($C6),E($C7)_"PSEUDO ACCUMULATOR OF DFLOT_^1_%EQU Y1($D8)_0USES $D8,$D9,AND $DA_^1_%EQU SQRFLG($DB)_,NEGATIVE IF ARGUMENT NE€€GATIVE_^1_%EQU TEMP($DC)_.USES $DC,DD,AND DE TEMPORARY STORAGE_^1_%EQU ARG($DF)_/ARGUMENT X DF,E0,E1_^1_%EQU QSAVE($E2)_^1_%EQU ZERO(2)_0LOCATION OF ZERO_^1_%EQU LPMASK(2)_.LOGICAL PRODUCT MASK TABLE_^1_%EQU ZROMSK($13)_,ZERO MASK TABLE_^1_%EQU ONEBIT($23)_,ONE BIT TABLE_^1_%EQU ZROBIT($33)_,ZERO BIT TABLE_^1_%EQU SQRRET($C9)_!RETURN ADDRESS_^1_%EQU SQREXP($CA)_!EXPONENT/€€2_^1_%ENT DSQRT_SDBL_^1_%EXT PARABS_J**MSOS4.1**_^1DSQRT NUM 0_WDBL_^1DSQ1V4 IIN 0_^1_%STQ- QSAVE_^1_%LDA* DSQRT_K**MSOS4.1**_^1_%RTJ PARABS_J**MSOS4.1**_^1SQRT10 RAO* DSQRT_SDBL_^1_%TRA Q_^1_%EIN 0_^1_%LDA* DSQRT_SDBL_^1_%STA- SQRRET_'SAVE RETURN ADDRESS IN VOLATILE_^1_%LDA- (ZERO),Q_$GET ARGUMENT (X)_^1_%STA- SQRFLG_'IF NEGATIVE SET FLAG AND COMPLEMENT ARGUMENT_^1_%SAP S€€QRT11_^1_%TCA A_^1_%STA- C_^1_%LDA- 1,Q_^1_%LDQ- 2,Q_^1_%TCA A_^1_%TCQ Q_^1_%JMP* SQRT12_^1SQRT11 STA- C_^1_%LDA- 1,Q_^1_%LDQ- 2,Q_^1SQRT12 STA- D_^1_%STQ- E_^1_%LDA- C_^1_%SAN SQRT30_^1_%JMP* RTN_^1SQRT30 ARS 7_,GET EXPONENT AND REMOVE EXPONENT_^1_%SUB- ONEBIT+7_^1_%ENQ 1_^1_%LAQ Q_^1_%ARS 1_,DIVIDE EXPONENT BY 2_^1_%SQZ SQRT40_'EXPONENT EVEN-REDUCE ARGUMENT 1/2 TO 1_^1_%€€INA 1_,EXPONENT ODD REDUCE ARGUMENT 1/4 T/ 1/2_^1_%LDQ- ZROBIT+8_^1SQRT40 ADQ- ONEBIT+14_^1_%STA- SQREXP_'SAVE EXPONENT/2_^1_%LDA- C_^1_%AND- LPMASK+7_^1_%AAQ A_^1_%STA- C_,SAVE ARGUMENT IN RANGE 1/4 TO 1._^1FLTCAL RTJ HDFLOT_NFTN 3.3_^1_%NUM $BDED_^1_%ADC C_^1_%ADC ARG_*ARG = FLOATING POINT ACCUMULATOR (C,D,E)_^1_%ADC C1_^1_%ADC TEMP_)TEMP = ARG + 15/49_^1_%NUM $BE98_^1_%€€ADC ARG_^1_%ADC C2_^1_%ADC TEMP_)Y1 = (ARG + 235/49)*TEMP-400/240/_^1_%ADC C3_^1_%NUM $DB9A_^1_%ADC Y1_^1_%ADC TEMP_^1_%ADC C4_+Y1 =(TEMP*(-5000/343)/Y1) + 25/7_^1_%ADC Y1_^1_%NUM $ED40_^1_%ADC C5_^1_%ADC Y1_^1*_*THE PADE APPROXIMATION IS NOW COMPLETE WITH THE RESULT IN_^1*_)THE FLOATING POINT ACCUMULATOR._^1ITRCAL RTJ* (FLTCAL+1)_"PERFORM NEWTON RAPHSON CALCULATION_^1_€€%NUM $BAE9_^1_%ADC ARG_*LDA_GDBL_^1_%ADC Y1_+DVI_GDBL_^1_%ADC Y1_+ADD Y1_^1_%ADC ONEHLF_'MULTIPLY BY 1/2_^1_%NUM $D400_SDBL_^1_%ADC TEMP_)STA Y2_DDBL_^1_%LDA- TEMP_^1_%SUB- Y1_VDBL_^1_%INA 0_WDBL_^1_%SAN AGAIN_SDBL_^1_%LDA- TEMP+1_^1_%SUB- Y1+1_TDBL_^1_%INA 0_WDBL_^1_%SAN AGAIN_SDBL_^1_%LDA- TEMP+2_^1_%SUB- Y1+2_TDBL_^1_%INA 0_WDBL_^1_%ARS 2_WDBL_^1_%SAZ ITR1_TDBL_^1A€€GAIN RTJ* (FLTCAL+1)_NDBL_^1_%NUM $BD40_^1_%ADC TEMP_)LOAD ACCUMULATOR WITH Y2_^1_%ADC Y1_+STORE IN Y1_^1_%JMP* ITRCAL_'REPEAT CALCULATION_^1ITR1_!LDA- TEMP_)COMBINE WITH EXPONENT / 2_^1_%LDQ- SQREXP_^1_%SQP SQRT50_^1_%INQ -1_+ALLOW FOR PROPER ADD FOR NEGATIVE EXPONENT_^1SQRT50 QLS 7_^1_%AAQ A_^1_%LDQ- SQRFLG_^1_%SQP SQRT60_^1_%LDQ- TEMP+1_^1_%TCQ Q_,ARGUMENT WAS NEGATIVE€€ COMPLEMENT ANSWER_^1_%TCA A_^1_%STQ- TEMP+1_^1_%LDQ- TEMP+2_^1_%TCQ Q_^1_%STQ- TEMP+2_^1SQRT60 STA- TEMP_^1_%RTJ* (FLTCAL+1)_"PUT IN FLOATING POINT ACCUMULATOR_^1_%NUM $B400_^1_%ADC TEMP_^1RTN_"LDQ- QSAVE_(RESTORE Q AND RETURN_^1_%JMP- (SQRRET)_^1ONEHLF NUM $4040_(1/2 = .500000000000_^1_%NUM 0_^1_%NUM 0_^1C1_#NUM $3F4E_(15/49 = .306122448980_^1_%NUM $5E0A_^1_%NUM $72F1_^€,1C2_#NUM $41CC_(235/49 = 4.79591836735_^1_%NUM $BC14_^1_%NUM $E5E1_^1C3_#NUM $3ED5_(400/2401 = .166597251145_^1_%NUM $4C3C_^1_%NUM $228B_^1C4_#NUM $BD8B_(-5000/343 = 1495772594752_^1_%NUM $61C5_^1_%NUM $C8C4_^1C5_#NUM $4172_(25/7 = 3.57142857143_^1_%NUM $4924_^1_%NUM $924A_^1_%END_]_^__ ,PDSIGNR CSY/ E05 P€1_%NAM DSIGNR_'DECK-ID E05 FTN 3.3 RUNTIME_%SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^1_%SPC 2_^1*_$REENTRANT/NOT RUNANYWHERE_#INTRINSIC FUNCTION DSIGN_^1*_$NO SPEC AVAILABLE_^1_%ENT Q8DSG_^1_%ENT DSIGN_^1_%EXT PARABS_J**MSOS4.1**_^1*_]_^1_%EXT HDFLOT_NFTN 3.€€3_^1_%EQU TEMP($C5)_^1_%EQU A1($D8),A2($D9),FF($E1),QS($E2)_^1_%EQU RET($DA)_^1_%EQU LPMSK(2),ZERO($22)_^1*_]_^1Q8DSG NOP 0_^1QSDSV4 IIN 0_,INHIBIT FOR PROPER OPERATION_^1_%STQ- QS_+SAVE Q AND I REGISTERS_^1_%LDA- $FF_^1_%STA- FF_^1_%ENA 0_^1_%STA- $FF_^1_%LDA* DSIGN_^1_%STA- RET_^1DS0_"LDA- RET_^1_%RAO- RET_^1_%RTJ PARABS_J**MSOS4.1**_^1_%EIN 0_O**MSOS4.1**_^1DS1_"STA- A€€1,I_)PARAMETER ADDRESSES_^1_%LDA- $FF_^1_%SAN 2_^1_%RAO- $FF_^1_%JMP* DS0_^1_%LDQ- A1_+ARGUMENT 1 ADDRESS_^1_%LDA- (ZERO),Q_$STORE_^1_%STA- TEMP_^1_%LDA- 1,Q_*OF_^1_%STA- TEMP+1_^1_%LDA- 2,Q_*IN FORTRAN_^1_%STA- TEMP+2_^1_%RTJ* (DS3+1)_%CALL DFLOT_^1_%NUM $B400_(DOUBLE FLOATING LOAD ARGUMENT 1_^1_%ADC TEMP_^1_%LDA- (A1)_^1_%LDQ- (A2)_^1_%INA 0_^1_%INQ 0_,ELIMINATE -0_^1_%SQP €:DS2_^1_%SAP DS3_*CHANGE SIGN OF ARGUMENT 1 IF_^1_%JMP* DS4_*BOTH ARGUMENTS ARE NEGATIVE_^1DS2_"SAM DS3_^1_%JMP* DS4_*BOTH POSITIVE_^1DS3_"RTJ HDFLOT_NFTN 3.3_^1_%NUM $7400_(COMPLEMENT_DBL_^1DCS1V4 IIN 0_^1_%STQ- QS_'SAVE Q_^1_%EIN 0_^1_%LDA* DCOS_)OBTAIN ABSOLUTE PARAMETER_)**MSOS4.1**_^1_%STA- RETADD_^1GOABS RTJ PARABS_'ADDR€€ESS_;**MSOS4.1**_^1_%EIN 0_O**MSOS4.1**_^1_%TRA Q_O**MSOS4.0**_^1_%LDA- (ZERO),Q_H**MSOS4.0**_^1_%STA- C_^1_%LDA- 1,Q_M**MSOS4.0**_^1_%STA- D_^1_%LDA- 2,Q_UDBL_^1_%STA- E_^1COS6_!RTJ* (SIN9+1)_%CALL FLOT_^1_%NUM $BD40_OFTN 3.3_^1_%ADC C_^1_%ADC C_SFTN 3.3_^1_%LDA- C_WDBL_^1_%SAN AD90-*-1_$CHECK FOR 0_?DBL_^1_%STA- D_WDBL_^1_%STA- E_WDBL_^1_%LDA COSIN_SDBL_^1_%STA- C_WDBL_^1_€€%RTJ* (SIN9+1)_LFTN 3.3_^1_%NUM $B400_OFTN 3.3_^1_%ADC C_SFTN 3.3_^1_%JMP SIN19_SDBL_^1AD90_!RTJ* (SIN9+1)_$CALL DFLOT_@DBL_^1_%NUM $B5E5_OFTN 3.3_^1_%ADC C_WDBL_^1_%ADC PIOV2-*_'ARG+PI/2_"FAD_^1_%NUM $D400_OFTN 3.3_^1_%ADC C_SFTN 3.3_^1_%JMP* SIN1_^1MKFFFF NUM $FFFF_^1_%NUM $FFFE_^1_%NUM $FFFC_^1_%NUM $FFF8_^1_%NUM $FFF0_^1_%NUM $FFE0_^1_%NUM $FFC0_^1MKFF80 NUM $FF€€80_^1_%NUM $FF00_^1_%NUM $FE00_^1_%NUM $FC00_^1_%NUM $F800_^1_%NUM $F000_^1_%NUM $E000_^1_%NUM $C000_^1_%NUM $8000_^1MK7FFF NUM $7FFF_^1DSIN_!NUM 0_,SIN(U) ENTRY_>DBL_^1DSN1V4 IIN 0_^1_%STQ- QS_'SAVE Q_^1_%EIN 0_^1_%LDA* DSIN_L**MSOS4.1**_^1_%STA- RETADD_^1_%RTJ* (GOABS+1)_G**MSOS4.1**_^1_%EIN 0_O**MSOS4.1**_^1_%TRA Q_O**MSOS4.0**_^1_%LDA- (ZERO),Q_H**MSOS4.0**_^1_%ST€€A- C_^1_%LDA- 1,Q_M**MSOS4.0**_^1_%STA- D_^1_%LDA- 2,Q_UDBL_^1_%STA- E_^1_%RTJ* (SIN9+1)_^1_%NUM $BD40_OFTN 3.3_^1_%ADC C_^1_%ADC C_SFTN 3.3_^1*_"COMMON TO BOTH_^1SIN1_!LDA- C_^1_%ENQ 0_^1_%SAP SIN2-*-1_!ARG IS POS._^1_%RTJ* (SIN9+1)_#COMPLEMENT_^1_%NUM $7D40_OFTN 3.3_^1_%ADC C_WDBL_^1_%ENQ 1_^1_%LDA- C_^1SIN2_!SAN SIN3-*-1_^1_%STA- C_^1_%STA- D_^1_%STA- E_WDBL_^1_%JMP SI€€N19_SDBL_^1SIN3_!STQ-_"FLAG_^1_%SUB TWOPI_SDBL_^1_%SAM SIN4-*-1 LESS_^1_%SAN SIN5-*-1 GREATER_^1_%LDA- D_^1_%SUB TWOPI+1_QDBL_^1_%SAM SIN4-*-1_!LESS_^1_%SAN SIN5-*-1_!GREATER_^1_%LDA- E_WDBL_^1_%SUB TWOPI+2_QDBL_^1_%SAM SIN4-*-1_PDBL_^1_%SAN SIN5-*-1_PDBL_^1_%JMP* SIN2+1_$EQUAL_^1MAXVAL NUM $4B40_#2**21_^1SIN4_!JMP* SIN12_^1SIN5_!LDA- C_^1_%SUB* MAXVAL_(MAX. PERMISSIBLE€€_^1SIN8_!SAM SIN9-*-1_%O.K._^1_%RTJ SFALT_(SET FAULT_=FTN 3.3_^1_%ADC 0_SFTN 3.3_^1_%LDA* MK7FFF_^1_%STA- C_^1_%ENA -0_^1_%JMP* SIN2+2_^1SIN9_!RTJ HDFLOT_NFTN 3.3_^1_%NUM $BD5A_SDBL_^1_%ADC C_WDBL_^1_%ADC X_#X=ARG_/STA X_^1_%ADC TWOPI-*_+X/2PI_!FDV 2*PI_^1_%NUM $5D40_OFTN 3.3_^1_%ADC C_SFTN 3.3_^1_%LDA- C_^1_%AND* MKFF80_(KEEP EXPONENT_^1_%SUB- MK4000_'REMOVE BASE_?DBL_^€€1_%ARS 7_*RIGHT JUSTIFIED_^1_%TCA A,Q_^1_%INA 7_^1_%SAP SIN10-*-1_#= OR LESS THAN 7_^1_%INQ 7_^1_%LDA- D_^1_%AND* MK7FFF,Q_%GET MASK ACCORDING TO EXP._^1_%JMP* SIN11_^1SIN10 LDA- C_-LESS OR =_^1_%AND* MKFF80,Q_^1_%STA- C_^1_%ENA 0_^1SIN11 STA- D_-C,D INTEGRAL PART OF DIVISION_^1_%ENA 0_WDBL_^1_%STA- E_WDBL_^1_%RTJ* (SIN9+1)_'CALL FLOT_^1_%NUM_#$B759_^1_%ADC_#C_*LDA C_^1_%€€ADC TWOPI-*_3FMU 2*PI_^1*_"7 = COMPLEMENT PSEUDO ACCUMULATOR_^1_%NUM $5ED4_OFTN 3.3_^1_%ADC X_9FAD X_^1_%ADC C_SFTN 3.3_^1_%ADC X_SFTN 3.3_^1SIN12 LDA- C_)(C,D) LESS OR = 2*PI_^1_%SUB* PI_^1_%SAM J14-*-1_%LESS THAN PI_>DBL_^1_%SAN SIN13-*-1 GREATER_^1_%LDA- D_^1_%SUB* PI+1_^1_%SAM SIN14-*-1 LESS_^1_%SAN SIN13-*-1_#GREATER_CDBL_^1_%LDA- E_WDBL_^1_%SUB* PI+2_TDBL_^1J14_"SA€€M SIN14-*-1_#LESS_FDBL_^1_%SAN SIN13-*-1_#GREATER_CDBL_^1_%JMP* SIN2+1_!EQUAL_^1SIN13 RTJ* (SIN9+1)_%CALL FLOT_^1_%NUM $B585_OFTN 3.3_^1_%ADC C_WDBL_^1_%ADC PI-*_,X-PI_$FSB PI_^1_%NUM $D400_OFTN 3.3_^1_%ADC C_SFTN 3.3_^1_%ENA 1_^1_%EOR- FLAG_*CHANGE TO_^1_%STA- FLAG_,OPPOSITE VALUE_^1SIN14 LDA- C_^1_%SUB* PIOV2_^1_%SAM SIN145-*-1_!LESS_^1_%SAZ SIN14A_NFTN 3.3_^1_%JMP* S€€IN15_(GREATER_?FTN 3.3_^1SIN14A LDA- D_SFTN 3.3_^1_%SUB* PIOV2+1_^1SIN145 SAM J16-*-1_^1_%SAN SIN15-*-1_#GREATER_^1_%LDA- E_^1_%AND- $13_*($FFFE)_CDBL_^1_%SUB* PIOV2+2_QDBL_^1J16_"SAM SIN16-*-1_^1_%SAN SIN15-*-1_#GREATER_CDBL_^1_%LDA* COSIN_(EQUAL_^1_%STA- C_^1_%ENA 0_^1_%STA- D_^1_%STA- E_WDBL_^1_%RTJ* (SIN9+1)_LFTN 3.3_^1_%NUM $B400_OFTN 3.3_^1_%ADC C_SFTN 3.3_^1_%JMP* SIN€€17_#GO TEST FLAG_^1SIN15 RTJ* (SIN9+1)_%CALL FLOT_^1_%NUM $B57E_SDBL_^1_%ADC C_WDBL_^1*_)COMPLEMENT PSEUDO ACCUMULATOR_^1_%ADC PI-*_)PI-(C,D)_#FAD PI_^1_%NUM $4000_SDBL_^1SIN16 RTJ* (SIN9+1)_(CALL FLOT_^1_%NUM $B666_SDBL_^1_%ADC C_WDBL_^1_%NUM_#$D9D5_^1_%ADC X_9STA X_^1_%ADC X_9FMU X_^1_%ADC X2_*X2=X*X_'STA X2_^1_%NUM_#$9E59_^1_%ADC C8SIN-*_%C8*X2_EDBL_^1_%ADC C7SIN-*€€_%+C7_GDBL_^1_%ADC X2_+*X2_GDBL_^1_%NUM $5E59_SDBL_^1_%ADC C6SIN-*_%+C6_GDBL_^1_%ADC X2_+*X2_GDBL_^1_%NUM $5E59_SDBL_^1_%ADC C5SIN-*_%+C5_GDBL_^1_%ADC X2_+*X2_GDBL_^1_%NUM $5E59_SDBL_^1_%ADC C4SIN-*_%+C4_GDBL_^1_%ADC X2_+*X2_GDBL_^1_%NUM $5E59_SDBL_^1_%ADC C3SIN-*_%+C3_GDBL_^1_%ADC X2_+*X2_GDBL_^1_%NUM $5E59_SDBL_^1_%ADC C2SIN-*_%+C2_GDBL_^1_%ADC X2_+*X2_GDBL_^1_%NU€€M $5E59_SDBL_^1_%ADC C1SIN-*_%+C1_GDBL_^1_%ADC X2_+*X2_GDBL_^1_%NUM $5E59_SDBL_^1_%ADC COSIN-*_%+C0_GDBL_^1_%ADC X_,*X_HDBL_^1_%NUM $4000_SDBL_^1SIN17 LDA-_"FLAG_^1_%SAZ SIN19-*-1_^1_%RTJ* (SIN9+1)_"COMPLEMENT_^1_%NUM $7400_OFTN 3.3_^1SIN19 LDQ- QS_VDBL_^1_%RAO- RETADD_^1_%JMP-_"(RETADD)_(RETURN TO CALLER_^1PIOV2 NUM $40E4,$87ED,$5112_GDBL_^1PI_#NUM $4164,$87ED,$5112_€x^1TWOPI NUM $41E4,$87ED,$5111_GDBL_^1COSIN NUM $40C0,0,0_ODBL_^1C1SIN NUM $C12A,$AAAA,$AAAB_GDBL_^1C2SIN NUM $3CC4,$4444,$4444_GDBL_^1C3SIN NUM $C617,$F97F,$97F8_GDBL_^1C4SIN NUM $36DC,$778E,$955B_GDBL_^1C5SIN NUM $CC94,$66EA,$602A_GDBL_^1C6SIN NUM $2FD8,$4918,$4EA2_GDBL_^1C7SIN NUM $D414,$6030,$6330_GDBL_^1C8SIN NUM $27E5,$4B1D,$C0C3_GDBL_^1_%END_]_^__ xPDATANR CSY/ E12 P€1_%NAM DATANR_'DECK-ID E12 FTN 3.3 RUNTIME_%SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^1_%SPC 2_^1*_$REENTRANT/NOT RUNANYWHERE_#EXTERNAL FUNCTION ATAN_^1*_$PROGRAM BASE_^1_%ENT DATAN_RDBL_^1_%EXT PARABS_J**MSOS4.1**_^1_%EXT HDFLOT_NFTN 3.3_^1_%EQU C($C5),D($C6€€),E($C7)_"PSEUDO ACCUMULATOR_-DBL_^1_%EQU_#ARCFLG($D8),ARCRET($D9),X($DA)_^1_%EQU X2($D5),AF($DD),BF($E0)_ADBL_^1_%EQU QS($E3)_QDBL_^1_%EQU LPMSK(2),NZERO($12),ZERO($22),ONEBIT($23),ZROBIT($33)_^1DATAN NUM 0_WDBL_^1DAT1V4 IIN 0_WDBL_^1_%STQ- QS_'SAVE Q_^1_%EIN 0_^1_%LDA* DATAN_K**MSOS4.1**_^1_%STA- ARCRET_^1_%RAO- ARCRET_^1_%RTJ PARABS_J**MSOS4.1**_^1_%EIN 0_O**MSOS4.1**_^€€1_%TRA Q_O**MSOS4.0**_^1_%LDA- (ZERO),Q_H**MSOS4.0**_^1_%STA- C_^1_%LDA- 1,Q_M**MSOS4.0**_^1_%STA- D_^1_%LDA- 2,Q_UDBL_^1_%STA- E_^1_%RTJ* (ARCT6+1)_^1_%NUM $BD40_OFTN 3.3_^1_%ADC C_^1_%ADC C_SFTN 3.3_^1_%LDA- C_^1_%SAP ARCT1-*-1_^1_%RTJ* (ARCT6+1) CALL FLOT_^1_%NUM $7D40_OFTN 3.3_^1_%ADC C_WDBL_^1_%ENQ 1_^1_%JMP* ARCT2_^1ARCT1 ENQ 0_^1_%SAN ARCT2-*-1_^1_%STQ- C_-ARG. = €€0_^1_%STQ- D_)ANSWER =0_^1_%STQ- E_WDBL_^1_%RTJ* (ARCT6+1)_KFTN 3.3_^1_%NUM $B400_OFTN 3.3_^1_%ADC C_SFTN 3.3_^1_%JMP ARCEND_RDBL_^1PIOV2 NUM 0,0,0_SDBL_^1_%NUM $40E4,$87ED,$5111_GDBL_^1ARCT2 STQ-_"ARCFLG_^1_(LDA- C_^1_%SUB =N$39E8_%DECIMAL .0002_=DBL_^1_%SAP 1_^1_%JMP* ARCK_TDBL_^1_%ENQ 0_'TO SELECT 1.0 AND 0_^1_%LDA- C_^1_%SUB* ONE_#40C0_^1_%SAP ARCT2A_NFTN 3.3_^1_%JMP€€* ARCT4_(LESS THAN ONE_9FTN 3.3_^1ARCT2A SAN ARCT3_OFTN 3.3_^1_%SAN ARCT3-*-1_^1_%LDA- D_^1_%SAN ARCT3-*-1_ODBL_^1_%LDA- E_WDBL_^1_%SAZ ARCT4-*-1_"= TO ONE_^1ARCT3 RTJ* (ARCT6+1)_^1_%NUM $BD5B_^1_%ADC C_^1_%ADC X_%STORE PSEUDO ACCUMULATOR_^1_%ADC ONE-*_5LDA 1.0_^1_%NUM $5AD4_OFTN 3.3_^1_%ADC X_(1/X_-FDV X_^1_%ADC C_SFTN 3.3_^1_%ADC X_SFTN 3.3_^1_%ENQ 3_WDBL_^1ARCT4 L€€DA* ONE,Q_^1_%STA-_"BF_^1_%LDA* ONE+1,Q_^1_%STA-_"BF+1_$SET 1 OR -1_^1_%LDA* ONE+2,Q_QDBL_^1_%STA- BF+2_TDBL_^1_%LDA-_"ARCFLG_^1_%AAQ A_^1_%STA-_"ARCFLG_^1_%LDA* PIOV2,Q_^1_%STA-_"AF_^1_%LDA* PIOV2+1,Q_^1_%STA-_"AF+1_'0 OR PI/2_^1_%LDA* PIOV2+2,Q_ODBL_^1_%STA- AF+2_TDBL_^1ARCT5 RTJ* (ARCT6+1)_#FLOT ROUTINE_^1_%NUM $BD58_SDBL_^1_%ADC C_WDBL_^1_%ADC X_9STA X_^1_%ADC TANPI8-*_2F€€SB_^1_%NUM $5D40_OFTN 3.3_^1_%ADC C_SFTN 3.3_^1_%ENQ 1_SFTN 3.3_^1_%LDA- C_^1_%SAZ ARC55_SDBL_^1_%SAP ARC56_(GREATER THAN TAN(PI/8)_4DBL_^1ARC55 ENQ 0_,LESS OR = TO TAN(PI/8)_4DBL_^1ARC56 STQ- X2_VDBL_^1ARCT6 RTJ HDFLOT_NFTN 3.3_^1_%NUM $F5B6_^1_%ADC X2_*INDEX_^1_%ADC PI16-*_"LDA PI16,IND_^1_%NUM $59ED_^1_%ADC BF_8FMU_^1_%ADC AF_8FAD_^1_%ADC AF_8STA_^1_%NUM $F5B6_€€^1_%ADC X2_*INDEX_^1_%ADC TAN16-*_!LDA TAN16,IND_^1_%NUM $5D95_^1_%ADC BF_8LDA_^1_%ADC X_9FMU_^1_%NUM $E5DB_^1_%ADC ONE-*_5FAD 1.0_^1_%ADC X2_8STA_^1_%ADC X_9LDA_^1_%NUM $8AD9_^1_%ADC BF_8FAD_^1_%ADC X2_8FDV X2_^1_%ADC X_9STA X_^1_%ADC X_9FMU X_^1_%NUM $D59E_^1_%ADC X2_8STA X2_^1_%ADC C8-*_)X2*C8_EDBL_^1_%ADC C7-*_)+C7_GDBL_^1_%NUM $595E_SDBL_^1_%ADC X2_+*X2_GDB€€L_^1_%ADC C6-*_)+C6_GDBL_^1_%NUM $595E_SDBL_^1_%ADC X2_+*X2_GDBL_^1_%ADC C5-*_)+C5_GDBL_^1_%NUM $595E_SDBL_^1_%ADC X2_+*X2_GDBL_^1_%ADC C4-*_)+C4_GDBL_^1_%NUM $595E_SDBL_^1_%ADC X2_+*X2_GDBL_^1_%ADC C3-*_)+C3_GDBL_^1_%NUM $595E_SDBL_^1_%ADC X2_+*X2_GDBL_^1_%ADC C2-*_)+C2_GDBL_^1_%NUM $595E_SDBL_^1_%ADC X2_+*X2_GDBL_^1_%ADC C1-*_)+C1_GDBL_^1_%NUM $595E_SDBL_^1_%ADC €€ X2_+*X2_GDBL_^1_%ADC C0-*_)+C0_GDBL_^1_%NUM $5940_SDBL_^1_%ADC X_,*X_HDBL_^1_%LDA-_"ARCFLG_^1_%INA -3_VDBL_^1_%SAM ART7-*-1_^1_%STA-_"ARCFLG_^1_%RTJ* (ARCT6+1) CALL FLOT_^1_%NUM $7400_OFTN 3.3_^1ART7_!RTJ* (ARCT6+1) CALL FLOT_^1_%NUM $ED40_OFTN 3.3_^1_%ADC AF_+FAD_CFTN 3.3_^1_%ADC C_,LDA C_@FTN 3.3_^1ARCK_!LDA- ARCFLG_RDBL_^1_%SAZ ARCEND-*-1_^1_%RTJ* (ARCT6+1) CALL FLO€€T_^1_%NUM $B740_SDBL_^1_%ADC C_WDBL_^1ARCEND LDQ- QS_VDBL_^1_%JMP- (ARCRET)_^1ONE_"NUM $40C0,0,0_*+1.0_@DBL_^1_%NUM $BF3F,$FFFF,$FFFF_!-1.0_@DBL_^1TANPI8 NUM $3F6A,$09E6,$67F4_GDBL_^1PI16_!NUM $3EE4,$87ED,$5111_"PI/16=S_PSR 764_^1_%STQ- $E4_-$E4_?PSR 764_^1_%LDQ* QSAVE_(RESTORE Q_FTN 3.3_^1SQRT4 STQ-_"SQEXP_^1_%TRA Q_^1_%LDA- C_^1_%AND- MK007F_'LOWER 7 BITS_6**FTN 3.0**_^1_%AAQ A_^1_%STA- C_-(C,D) IS NOW NEW ARGUMENT_^1_%RTJ* (SQRTLP+5)_JFTN 3.3_^1_%NUM_#$BD5E_^1_%ADC C_+LDA PS.ACC._^1_%ADC_#X_*STA€€ X_^1_%ADC C1-*_(FAD C1_^1_%NUM_#$5DB5_^1_%ADC_#YO_!C1+X_!STA YO_^1_%ADC_#X_*LDA X_^1_%NUM_#$E595_^1_%ADC C2-*_!C2+X FAD C2_^1_%ADC_#YO_)FMU YO_^1_%NUM_#$85DB_^1_%ADC C3-*_(FSB_^1_%ADC_#Y1 Y1=(C1+X)(X+C2)-C3_^1_%ADC_#YO_)LDA YO_^1_%NUM_#$595A_^1_%ADC C4-*_(FMU_^1_%ADC_#Y1_)FDV Y1_^1_%NUM $5E5D_(CHANGE MODE,ADD,CH MODE,STORE_)FTN 3.3_^1_%ADC C5-*_PFTN 3.3_^1_%ADC YO_RFTN 3.€€3_^1_%NUM $4000_OFTN 3.3_^1SQRTLP LDA- YO_^1_%STA* SAV1_^1_%LDA- YO+1_^1_%STA* SAV1+1_^1_%RTJ HFLOT_OFTN 3.3_^1_%NUM_#$DBAE_^1_%ADC_#YO_)STA YO_^1_%ADC_#X_^1_%ADC_#YO_)FDV YO_^1_%ADC_#YO_)FAD YO_^1_%NUM_#$595D_^1_%ADC C6-*_(FMU 1/2_^1_%ADC C_+STA C_#C=.5(YO+X/YO)_^1_%NUM $4000_OFTN 3.3_^1_%LDA- C_^1_%SUB-_"YO_^1_%SAN KLUGE-*-1_^1_%LDA- D_^1_%SUB-_"YO+1_^1_%ARS 2_-REMOVE LAST€€ TWO BITS_^1_%SAZ DONE-*-1_^1_%JMP* SQRTLP_^1_%BSS SAV1(2)_^1KLUGE LDA- C_^1_%SUB* SAV1_^1_%SAZ 1_^1_%JMP* SQRTLP_^1_%LDA- D_^1_%SUB* SAV1+1_^1_%SAZ 1_^1_%JMP* SQRTLP_^1DONE_!LDA- C_^1_%LDQ- SQEXP_^1_%SQP SQ1-*-1_^1_%INQ -1_(MAKES ADD TO 7F FOR -SQEXP_^1SQ1_"QLS 7_(POSITIVE, ADD TO 80_^1_%AAQ A_^1_%STA- C_^1_%RTJ* (SQRTLP+5)_"CALL FLOT_^1_%NUM $B400_^1_%ADC C_+LDA C_^1_%L€jDA-_"SQFLG_^1_%SAZ 2_^1_%RTJ* (SQRTLP+5)_"COMPLEMENT_^1_%NUM $7400_^1SQRETN LDQ- QS_'RESTORE Q_^1_%JMP- (SQRET) EXIT_^1C1_#NUM $3F4E,$5E0B_"15/49_^1C2_#NUM $41CC,$BC15_"235/49_^1C3_#NUM $3ED5,$4C3E_!400/2401_=PSR 902_^1C4_#NUM $BD8B,$61C5_"-5000/343_^1C5_#NUM $4172,$4925_"25/7_^1C6_#NUM $4040_(1/2_?**FTN 3.0**_^1_%NUM $0000_K**FTN 3.0**_^1_%END_]_^__ jPSIGN CSY/ G05 P€1_%NAM SIGN_)DECK-ID G05 FTN 3.3 RUNTIME_%SUMMARY-102_^1*_$1700 FORTRAN RUNTIME VERSION 3.3_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^1_%SPC 5_^1_%ENT Q8SG_^1_%ENT SIGN_^1_%EXT* PARABS_NFTN 3.3_^1_%EXT HFLOT_OFTN 3.3_^1_%SPC 3_SFTN 3.3_^1_%EQU A1($D8)_MFTN 3.3_^1_%EQU A2($D9)_MFTN 3.3_^1_%EQU FF($E1)_MFTN 3.3_€€^1_%EQU QS($E2)_MFTN 3.3_^1_%SPC 3_SFTN 3.3_^1SIGN_!EQU SIGN(*)_MFTN 3.3_^1Q8SG_!NOP_]_^1_%STQ- QS_'SAVE Q AND I_^1_%LDA- $FF_^1_%STA- FF_^1_%ENA 0_^1_%STA- $FF_^1S0_#LDA* SIGN_PFTN 3.3_^1_%RTJ PARABS_NFTN 3.3_^1_%STA- A1,I_^1_%RAO* SIGN_^1_%LDA- $FF_^1_%SAN 2_^1_%RAO- $FF_^1_%JMP* S0_^1_%LDA- A1_N**FTN 3.0**_^1_%STA* PARAD_K**FTN 3.0**_^1_%RTJ* (S3+1)_"FLOATING LOAD_^1_%NUM €j $B400_^1PARAD ADC 0_O**FTN 3.0**_^1_%LDA- (A1)_^1_%LDQ- (A2)_^1_%INA 0_^1_%INQ 0_(ELIMINATE -0_^1_%SQP S2-*-1_^1_%SAP S3-*-1_"CHANGE SIGN OF A1_^1_%JMP* S4_'BOTH NEGATIVE_^1S2_#SAM S3-*-1_^1_%JMP* S4_'BOTH POSITIVE_^1S3_#RTJ HFLOT_OFTN 3.3_^1_%NUM $7400_#COMPLEMENT_^1S4_#LDQ- QS_'RESTORE Q AND I_^1_%LDA- FF_^1_%STA- $FF_^1_%JMP* (SIGN)_^1_%END_]_^__ jPFIXFLT CSY/ G06 P€1_%NAM FIXFLT_'DECK-ID G06 FTN 3.3 RUNTIME_%SUMMARY-102_^1*_$FIX TO FLOAT / FLOAT TO FIX CONVERSION FUNCTION_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT, CONTROL DATA CORPORATION - 1973_^1_%SPC 5_^1_%ENT Q8QFIX_NFTN 3.3_^1_%ENT Q8FX_PFTN 3.3_^1_%ENT Q8QFLT_NFTN 3.3_^1_%ENT Q8FLOT_NFTN 3.3_^1_%ENT IFIX_€€PFTN 3.3_^1_%ENT FLOAT_OFTN 3.3_^1_%ENT DFIX_PFTN 3.3_^1_%ENT Q8DFLT_NFTN 3.3_^1_%ENT DFLT_PFTN 3.3_^1_%SPC 2_SFTN 3.3_^1_%EXT HFLOT_^1_%EXT* PARABS_NFTN 3.3_^1_%SPC 2_SFTN 3.3_^1_%EQU QS($E2)_MFTN 3.3_^1_%EQU CELL1($DA)_JFTN 3.3_^1_%EQU CELL2($DB)_JFTN 3.3_^1_%EQU RETURN($DC)_IFTN 3.3_^1_%EQU ZERO($22)_KFTN 3.3_^1_%EJT_VFTN 3.3_^1*_] FTN 3.3_^1*_$FIX VALUE IN FLOATING€€ POINT ACCUMULATOR_2FTN 3.3_^1*_] FTN 3.3_^1Q8QFIX NOP 0_SFTN 3.3_^1_%STQ- QS_+SAVE Q REGISTER_7FTN 3.3_^1_%LDA* Q8QFIX_NFTN 3.3_^1_%STA- RETURN_NFTN 3.3_^1_%JMP* FIX_*GO TO FIX ACCUMULATOR_1FTN 3.3_^1_%SPC 2_SFTN 3.3_^1*_] FTN 3.3_^1*_$FIX VALUE AT PARAMETER ADDRESS_;FTN 3.3_^1*_] FTN 3.3_^1IFIX_!EQU IFIX(*)_MFTN 3.3_^1DFIX_!EQU DFIX(*)_MFTN 3.3_^1Q8FX_!NOP 0_SFTN 3.3_^1_%€€LDA* Q8FX_)PICK UP ADDRESS OF PARAMETER_*FTN 3.3_^1_%STA- RETURN_NFTN 3.3_^1_%STQ- QS_+SAVE Q REGISTER_7FTN 3.3_^1_%RTJ PARABS_'ABSOLUTIZE PARAMETER ADDRESS_*FTN 3.3_^1_%RAO- RETURN_'BUMP RETURN ADDRESS_3FTN 3.3_^1_%TRA Q_,ADDRESS OF PARAMETER TO Q_-FTN 3.3_^1_%LDA- (ZERO),Q_LFTN 3.3_^1_%STA- CELL1_OFTN 3.3_^1_%LDA- 1,Q_QFTN 3.3_^1_%STA- CELL2_(MOVE PARAMETER TO CELL 2_.FTN 3.3_^€€1_%RTJ HFLOT_(LOAD CELL1,CELL2 INTO FP ACCUMULATOR_!FTN 3.3_^1FLOTAD EQU FLOTAD(*-1)_IFTN 3.3_^1_%NUM $B400_OFTN 3.3_^1_%ADC CELL1_OFTN 3.3_^1_%SPC 2_SFTN 3.3_^1FIX_"RTJ* (FLOTAD)_$FLOAT TO FIX CONVERSION_/FTN 3.3_^1_%NUM $1400_OFTN 3.3_^1_%ADC CELL1_OFTN 3.3_^1_%LDA- CELL1_(RETURN RESULT IN ACCUMULATOR_*FTN 3.3_^1_%LDQ- QS_RFTN 3.3_^1_%JMP- (RETURN)_$RETURN TO CALLER_6FTN 3€€.3_^1_%EJT_VFTN 3.3_^1*_] FTN 3.3_^1*_$CONVERT A REG TO FLOATING POINT. RETURN RESULT IN FP ACCUMFTN 3.3_^1*_] FTN 3.3_^1Q8DFLT EQU Q8DFLT(*)_KFTN 3.3_^1Q8QFLT NOP 0_SFTN 3.3_^1_%STA- CELL1_(SAVE VALUE TO BE FLOATED_.FTN 3.3_^1_%LDA* Q8QFLT_NFTN 3.3_^1_%STA- RETURN_'SAVE RETURN ADDRESS_3FTN 3.3_^1_%STQ- QS_+SAVE Q REGISTER_7FTN 3.3_^1_%JMP* FLT_QFTN 3.3_^1_%SPC 2_SFTN 3.3_^1*_€€] FTN 3.3_^1*_$CONVERT VALUE AT PARAMETER ADDRESS TO FLOATING POINT_$FTN 3.3_^1*_] FTN 3.3_^1FLOAT EQU FLOAT(*)_LFTN 3.3_^1DFLT_!EQU DFLT(*)_MFTN 3.3_^1Q8FLOT NOP 0_SFTN 3.3_^1_%LDA* Q8FLOT_NFTN 3.3_^1_%STA- RETURN_NFTN 3.3_^1_%STQ- QS_+SAVE Q REGISTER_7FTN 3.3_^1_%RTJ PARABS_^1_%TRA Q_SFTN 3.3_^1_%LDA- (ZERO),Q_$PICK UP PARAMETER_5FTN 3.3_^1_%STA- CELL1_OFTN 3.3_^1_%RAO- R€âETURN_'BUMP RETURN ADDRESS_3FTN 3.3_^1_%SPC 2_SFTN 3.3_^1FLT_"RTJ* (FLOTAD)_$FLOAT CELL1_;FTN 3.3_^1_%NUM $2400_OFTN 3.3_^1_%ADC CELL1_OFTN 3.3_^1_%LDQ- QS_RFTN 3.3_^1_%JMP- (RETURN)_$RETURN TO CALLER_6FTN 3.3_^1_%END_]_^__âPEXP CSY/ G07 P€1_%NAM EXP_*DECK-ID G07 FTN 3.3 RUNTIME_%SUMMARY-102_^1*_$1700 FORTRAN RUNTIME VERSION 3.3_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^1_%SPC 5_^1_%ENT EXP_^1_%EXT* PARABS_NFTN 3.3_^1_%EXT HFLOT_OFTN 3.3_^1_%EXT* SFALT_OFTN 3.3_^1_%EQU C($C5),D($C6)_!PSEUDO ACCUMULATOR_^1_%EQU Y($D8),RETEXP($DA),FLAG($DB),N($DC)_^1€€_%EQU MK4000($31)_IFTN 3.3_^1_%EQU MK7FFF($11)_IFTN 3.3_^1_%EQU MK007F($09)_IFTN 3.3_^1_%SPC 3_SFTN 3.3_^1EXP_"NUM 0_^1_%EQU QS($E1)_^1_%STQ- QS_'SAVE Q_^1_%LDA* EXP_*ADDRESS OF PARAMETER ADDRESS_*FTN 3.3_^1_%RTJ PARABS_NFTN 3.3_^1_%STA* PARAD_^1_%RAO* EXP_^1_%LDA* EXP_(****_^1_%STA- RETEXP_(SAVE RETURN EXIT ****_^1_%RTJ* (EXPN4+1)_#CALL FLOT_^1_%NUM $BD40_(LOAD,STORE_PSR 522_^1_%SUB* PIOV2+1_^1SIN145 SAM SIN16-*-1_#LESS_^1_%SAN SIN15-*-1_#GREATER_^1_%LDA* COSIN_(EQUAL_^1_%STA- C_^1_%ENA 0_^1_%STA- D_^1_%JMP* SIN17_#GO TEST FLAG_^1SIN15 RTJ* (SIN9+1)_%CALL FLOT_^1_%NUM $B57E_OFTN 3.3_^1_%ADC C_SFTN 3.3_^1*_)COMPLEMENT PSEUDO ACCUMULATOR_^1_%ADC PI-*_)PI-(C,D)_#FAD PI_^1_%NUM $4000_OFTN 3.3_^1SIN16 RTJ* (SIN9+1)€€_(CALL FLOT_^1_%NUM_#$D9D5_^1_%ADC X_9STA X_^1_%ADC X_9FMU X_^1_%ADC X2_*X2=X*X_'STA X2_^1_%NUM_#$9E59_^1_%ADC C4SIN-*_%C4*X2_'FMU C4_^1_%ADC C3SIN-*_'+C3_(FAD C3_^1_%ADC X2_#(C4*X2+C3)*X2_%FMU X2_^1_%NUM_#$5E59_^1_%ADC C2SIN-*_)+C2_%FAD C2_^1_%ADC X2_"((C4*X2+C3)X2+C2)X2 FMU_^1_%NUM_#$5E59_^1_%ADC C1SIN-*_'((C4*X2+C3)X2+C2)X2+C1_^1_%ADC X2_((((C4*X2+C3)X2+C2)X2+C1)X2_^1€€_%NUM_#$5E59_^1_%ADC COSIN-*_3FAD CO_^1_%ADC X_9FMU X_^1_%NUM_#$D400_^1_%ADC_#C_*STA C_^1SIN17 LDA-_"FLAG_^1_%SAZ SIN19-*-1_^1_%RTJ* (SIN9+1)_"COMPLEMENT_^1_%NUM $7D40_OFTN 3.3_^1_%ADC C_SFTN 3.3_^1SIN19 RTJ* (SIN9+1)_^1_%NUM $B400_^1_%ADC C_^1_%LDQ- QS_'RESTORE Q_^1_%JMP-_"(RETADD)_(RETURN TO CALLER_^1PIOV2 NUM $40E4,$87ED_^1PI_#NUM $4164,$87ED_^1TWOPI NUM $41E4,$87E€ÌD_^1COSIN NUM $40C0,0_'1.0_^1C1SIN NUM $C12A,$AAB1_!-0.16666647_^1C2SIN NUM $3CC4,$4353_"8.3328836E-3_^1C3SIN NUM $C618,$31CA_!-0.19799327E-3_^1C4SIN NUM $36D6,$C360_"0.5857445 E-6_^1_%END_]_^__ÌPATAN CSY/ G11 P€1_%NAM ATAN_)DECK-ID G11 FTN 3.3 RUNTIME_%SUMMARY-102_^1*_$1700 FORTRAN RUNTIME VERSION 3.3_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^1_%SPC 5_^1_%ENT ATAN_^1_%EXT* PARABS_NFTN 3.3_^1_%EXT HFLOT_OFTN 3.3_^1_%EQU C($C5),D($C6)_!PSEUDO ACCUMULATOR_^1_%EQU_#ARCFLG($D8),ARCRET($D9),X($DA)_^1_%EQU X2($DC),AF($DE),BF($€€E0)_9**FTN 3.0**_^1_%BSS QSAVE(1)_^1ATAN_!NUM 0_^1_%STQ* QSAVE_)SAVE Q_^1_%LDA* ATAN_)ADDRESS OF PARAMETER ADDRESS_*FTN 3.3_^1_%RTJ PARABS_NFTN 3.3_^1_%STA* PARAD_^1_%RAO* ATAN_^1_%LDA* ATAN_'****_^1_%STA-_"ARCRET_'****_^1_%RTJ* (ARCT6+1)_^1_%NUM $BD40_(LOAD,STORE_+14,Q_^1_%JMP* (GETBIT)_^1GTBIT2 LDQ* H7000_^1_%JMP* (GETBIT)_^1_%SPC 2_^1SFALT NOP 0_^1_%STQ* QSAVE_^1_%LDA* SFALT_^1_%RTJ* GETBIT_^1_%LDA- STATUS_^1_%TCQ Q_^1_%LAQ A_^1_%TCQ Q_^1_%EAQ A_^1_%STA- STATUS_^1_%LDQ* QSAVE_^1_%RAO* SFALT_^1_%JMP* (SFALT)_^1_%SPC 2_^1H7000 NUM $7000_^1QSAVE NUM 0_^1_%END_]_^__>PMON CSY/ P1 MON_]_^__ PQ8IFRM CSY/ H01 P€1_$SUBROUTINE Q8IFRM(IENTY,IRW,ILIST)_^1_#1_2/DECK-ID HO1 FTN 3.3 RUNTIME_%SUMMARY-102_^1C_$1700 MASS STORAGE FORTRAN VERSION 3.3_^1C_$SMALL COMPUTER DEVELOPMENT DIVISION, LA JOLLA CALIFORNIA_^1C_$COPYRIGHT CONTROL DATA CORPORATION 1973_^1_$IF(IENTY.EQ.1)GOTO 3_^1C_#GROUP REPEAT_^1_$IRG =0_^1C_#FIELD REPEAT_^1_$IRF=0_^1C_#PARENTHESIS COUNT_^1_$IBCT=0_^1C_]_^1C_#GROUP REPOSITION SW€ÊITCH_^1C_]_^1_$ISWR = 0_^1_$IANYL =0_^1_$CALL Q8FS(IRW,IFW,IND,ITYPE,IRF,IRG,IBCT,ISWR,ILIST,IANYL)_^1_$RETURN_^1_"3 CALL Q8TRAN(IRW,IFW,IND,ITYPE,IRF,IRG,IBCT,ISWR,ILIST,IANYL)_^1_$RETURN_^1_$END_]_^__ÊPQ8FS CSY/ H02 P€1_$SUBROUTINE Q8FS(IRW,IFW,IND,ITYPE,IRF,IRG,IBCT,ISWR,ILIST,IANYL)_^1_#1_2/DECK-ID HO2 FTN 3.3 RUNTIME_%SUMMARY-102_^1C_$1700 MASS STORAGE FORTRAN VERSION 3.3_^1C_$SMALL COMPUTER DEVELOPMENT DIVISION, LA JOLLA CALIFORNIA_^1C_$COPYRIGHT CONTROL DATA CORPORATION 1973_^1C_]_^1C_#FORMAT SCANNER_^1C_]_^1C_]_^1C_#TABLE OF LEGAL FORTRAN CONTROL CHARACTERS_^1C***************************€€***********************************FTN 3.1**_^1C**************************************************************FTN*3.2**_^1C_#+ )(,/.XH0123456789AREF$ID'*Z_^1C**************************************************************FTN*3.2**_^1C**************************************************************FTN 3.1**_^1C_]_^1C**************************************************************FTN 3.1*€€*_^1C**************************************************************FTN*3.2**_^1_$DIMENSION L(29)_^1_$INTEGER QAFLAG_^1C**************************************************************FTN*3.2**_^1C**************************************************************FTN 3.1**_^1_$DATA L(1),L(2),L(3),L(4),L(5),L(6),L(7),L(8),L(9),L(10),_^1_#*L(11),L(12),L(13),L(14),L(15),L(16),L(17),L(18),L(1€€9),L(20),_^1_#*L(21),L(22),L(23),L(24),L(25) /43,32,41,40,44,47,46,88,72,_^1_#*48,49,50,51,52,53,54,55,56,57,65,82,69,70,36,73 /_^1C**************************************************************FTN 3.1**_^1C**************************************************************FTN*3.2**_^1_$DATA L(26),L(27),L(28),L(29)/ 68,39,42,90/_^1C*****************************************************€€*********FTN*3.2**_^1C**************************************************************FTN 3.1**_^1C ********************************** 64*1343 ***************************_^1C ********************************** 64*1343 ***************************_^1_$DATA ISFLG/0/_^1_$IF(IRF.NE.$7FFF) GO TO 222_^1_$ISFLG=0_^1_$RETURN_^1 222 CONTINUE_^1C ********************************** 64*1343 ****€€***********************_^1C ********************************** 64*1343 ***************************_^1_$IRF=IRF-1_^1_$IF(IRF.GT.0) GOTO 1_^1_$IF(ISWR.NE.2) GOTO 2_^1_$CALL Q8SKIP_^1_$ISWR =0_^1_$GOTO 2_^1_"1 IFW = IFW1_^1_$IND = IND1_^1_$IFSEP =1_^1C_#NORMAL EXIT_^1_$RETURN_^1_"2 IFW =0_^1_$IF(ISFLG.EQ.1) CALL Q8SKIP_^1_$ISFLG =0_^1_$ITYPE = 0_^1_$IND =0_^1_$IXH =0_^1_"3 ISW1=0_^€€1_$ISW2=0_^1_$IFW1 =0_^1_$IND1 =0_^1C_]_^1C_#GET NEXT CHARACTER FROM FORMAT STATEMENT_^1C_]_^1_"7 I4 =0_^1_$I5 =0_^1_$CALL Q8FGET (LCHAR,I4,I5 )_^1C_]_^1C_#JUMP TO TYPE ADDR_^1C_]_^1_$K = 0_^1C**************************************************************FTN 3.1**_^1C**************************************************************FTN*3.2**_^1_$DO 8 I=1,29_^1C************************€€**************************************FTN*3.2**_^1C**************************************************************FTN 3.1**_^1_$K = K+1_^1C**************************************************************FTN 3.1**_^1_$IF(LCHAR.EQ.L(K))GOTO (7,7,9,10,11,12,13,14,15,22,22,22,22,22,22,_^1C**************************************************************FTN*3.2**_^1_#*22,22,22,22,24,26,27,28,€€29,30,31,1000,2000,29) , K_^1C**************************************************************FTN*3.2**_^1C**************************************************************FTN 3.1**_^1_"8 CONTINUE_^1C_]_^1C_#IVALID CHAR IN CONTROL FIELD OF FORMAT STATEMENT_^1C_]_^1_$CALL Q8FERM (1)_^1_$STOP_]_^1_$RETURN_^1C_#)_]_^1_"9 IRG=IRG-1_^1_$IBCT = IBCT -1_^1_$IF(IRG.GT.0) GO TO 4_^1_$IF(IBCT.GT.€€0) GOTO 113_^1C_]_^1C_#STATEMENT FULLY PROCESSED EXIT_^1C_]_^1_$ISWR =1_^1_$ISWR2=1_^1_$IBCT =0_^1C ********************************** PSR 529 **************************_^1C ********************************** PSR 529 **************************_^1_$IF(ILIST.NE.0.AND.IANYL.EQ.0) GO TO 200_^1C ********************************** PSR 529 **************************_^1C_]_^1C_#REPOSITI€€ON FORMAT SCAN TO BEGINNING OF GROUP_^1C_]_^1_"4 I3=0_]_^1_$I4=0_]_^1_$I5=2_]_^1_$CALL Q8FGET (I3,I4,I5)_^1_$IF(ITYPE.EQ.0.AND.IBCT.GT.0) GOTO 2_^1_$GOTO 1_^1C ********************************** PSR 529 **************************_^1 200 CALL Q8FERM(13)_^1_$STOP_]_^1_$RETURN_^1C ********************************** PSR 529 **************************_^1C ***************************€€******* PSR 529 **************************_^1C_#(_]_^1_!10 IF(ISWR.EQ.0) GOTO 103_^1_$ISWR = 2_^1 103 IBCT = IBCT +1_^1_$IF(IRG.GT.0) GO TO 5_^1_$IF(ISWR2.EQ.1.AND.ISWR.NE.0) GO TO 107_^1_$IRG = IFW1_^1_$IRG2=IFW1_^1_$GOTO 5_^1 107 IRG = IRG2_^1_$ISWR2 = 0_^1C_]_^1C_#SAVE GROUP POSITION_^1C_]_^1_"5 I3=0_]_^1_$I4=2_]_^1_$I5=0_]_^1_$CALL Q8FGET (I3,I4,I5)_^1_$ITYPE =0_^1_$IF(ILIS€€T.NE.0) GOTO 1_^1_$GOTO 2_^1C_#,_]_^1_!11 IF(ISW2.EQ.777) GOTO 115_^1_$ISW2=777_^1_$IF(IFSEP.EQ.1) GOTO 2_^1 113 IF(ITYPE.NE.0) GOTO 1_^1_$GOTO 2_^1C_]_^1C_#ERROR - EXTRA , IN FORMAT STATEMENT_^1C_]_^1 115 CALL Q8FERM (1)_^1_$STOP_]_^1_$RETURN_^1C_#/_]_^1_!12 IF(ITYPE.GT.0) GOTO 125_^1_$CALL Q8SKIP_^1_$ISW2=0_^1_$GOTO 2_^1 125 ISFLG =1_^1_$GOTO 1_^1C_#._]_^1_!13 ISW1 =1_^1_$GOT€€O 7_^1C_#X_]_^1_!14 IXH=2_^1_$GOTO 16_^1C_#H_]_^1_!15 IXH=1_^1_!16 ITYPE =0_^1_$IFSEP =0_^1_$IF(IRW.NE.0) GOTO 19_^1C_]_^1C_#INPUT_^1C_]_^1_!17 IF(IXH.EQ.1) GOTO 175_^1C_]_^1C_#BYPASS INPUT CHARACTERS ON X_^1C_]_^1_$CALL Q8RWBU (LCHAR)_^1_$GOTO 18_^1 175 CALL Q8RWBU (LCHAR)_^1_$CALL Q8FPUT (LCHAR)_^1_!18 IFW1 =IFW1 -1_^1_$IF(IFW1.GT.0) GOTO 17_^1_$GOTO 3_^1C_]_^1C_#OUTPUT FOR€€ X AND H_^1C_]_^1_!19 IF(IXH.EQ.2) GOTO 21_^1_$I4=0_]_^1_$I5=0_]_^1_$CALL Q8FGET (LCHAR,I4,I5)_^1_!20 CALL Q8RWBU (LCHAR)_^1_$IFW1= IFW1 -1_^1_$IF(IFW1.GT.0) GOTO 19_^1_$GOTO 3_^1_!21 LCHAR =32_^1_$GOTO 20_^1C_]_^1C_#DECIMAL DIGIT_^1C_]_^1_!22 IF(ISW1.EQ.1) GOTO 23_^1_$IFW1 = IFW1*10 + LCHAR - 48_^1_$GOTO 7_^1_!23 IND1 = IND1*10 + LCHAR - 48_^1_$GOTO 7_^1C_]_^1C_#TYPE A_^1C_]_€€^1_!24 ITYPE =1_^1_!25 IRF = IFW1_^1_$IFW1 =0_^1_$IFSEP =0_^1_$IXH = 0_^1_$IANYL =1_^1_$GOTO 7_^1C_]_^1C_#TYPE R_^1C_]_^1_!26 ITYPE =2_^1_$GOTO 25_^1C_]_^1C_#TYPE E_^1C_]_^1_!27 ITYPE =3_^1_$GOTO 25_^1C_]_^1C_#TYPE F_^1C_]_^1_!28 ITYPE =4_^1_$GOTO 25_^1C_]_^1C_#TYPE $_^1C_]_^1_!29 ITYPE =5_^1_$GOTO 25_^1C_]_^1C_#TYPE I_^1C_]_^1_!30 ITYPE =6_^1_$GOTO 25_^1C***************€€***********************************************FTN 3.1**_^1C_]_^1C_#TYPE D_^1C_]_^1_!31 ITYPE = 7_^1_$GO TO 25_^1C**************************************************************FTN 3.1**_^1C**************************************************************FTN*3.2**_^1C_]_^1C_#APOSTROPHE ENCOUNTERED IN FORMAT STATEMENT_^1C_]_^1 1000 QAFLAG = 1_^1_$IF (IRW.EQ.0) GO TO 3000_^1_$GO TO 4000_€€^1C_]_^1C_#ASTERISK ENCOUNTERED IN FORMAT STATEMENT_^1C_]_^1 2000 QAFLAG = 0_^1_$IF (IRW.EQ.1) GO TO 4000_^1C_]_^1C_#INPUT/READ_^1C_#GET NEXT CHARACTER FROM INPUT BUFFER_^1C_]_^1 3000 CALL Q8RWBU(LCHAR)_^1_$IF (QAFLAG.EQ.1.AND.LCHAR.EQ.39) GO TO 3_^1_$IF (QAFLAG.EQ.0.AND.LCHAR.EQ.42) GO TO 3_^1C_]_^1C_#PLACE NEXT CHARACTER IN FORMAT STATEMENT OUTPUT BUFFER_^1C_]_^1_$CALL Q8FPUT(LCH€€AR)_^1_$GO TO 3000_^1C_]_^1C_#OUTPUT/WRITE_^1C_#GET NEXT CHARACTER FROM FORMAT STATEMENT BUFFER_^1C_]_^1 4000 CALL Q8FGET(LCHAR,0,0)_^1_$IF (QAFLAG.EQ.1.AND.LCHAR.EQ.39) GO TO 3_^1_$IF (QAFLAG.EQ.0.AND.LCHAR.EQ.42) GO TO 3_^1C_]_^1C_#PLACE NEXT CHARACTER IN OUTPUT BUFFER_^1C_]_^1_$CALL Q8RWBU(LCHAR)_^1_$GO TO 4000_^1C**************************************************************FTN€*3.2**_^1_$END_]_^__PQ8TRAN CSY/ H03 P€1_$SUBROUTINE Q8TRAN(IRW,IFW,IND,ITYPE,IRF,IRG,IBCT,ISWR,ILIST,IANYL)_^1_#1_2/DECK-ID HO3 FTN 3.3 RUNTIME_%SUMMARY-102_^1C_$1700 MASS STORAGE FORTRAN VERSION 3.3_0SUMMARY-102_^1C_$SMALL COMPUTER DEVELOPMENT DIVISION, LA JOLLA CALIFORNIA_^1C_$COPYRIGHT CONTROL DATA CORPORATION 1973_^1C BEGIN COMMON BLOCK 0_^1C**************************************************************FTN 3.1**_^€€1_$DIMENSION ITEMP(2), IRN(2), IWORK(6), IMAN(20), IDIG(20)_^1_$DIMENSION ITEST(8)_^1_$INTEGER DPFLAG_^1C**************************************************************FTN 3.1**_^1_$DIMENSION NT(5)_^1_$DATA NT(1),NT(2),NT(3),NT(4),NT(5) /_^1_#*10000,1000,100,10,1 /_^1_$DIMENSION NH(4)_^1_$DATA NH(1),NH(2),NH(3),NH(4) /_^1_#*4096,256,16,1 /_^1C*******************************€€*******************************FTN 3.1**_^1_$DIMENSION M(3)_^1_$DIMENSION N(6)_^1C**************************************************************FTN 3.1**_^1C_]_^1C_#LIST ELEMENT CONVERSION AND TRANSMISSION ROUTINE_^1C_]_^1C_]_^1C_#CALL FORMAT SCANNER_^1C_]_^1 151 IF(ITYPE.NE.0) GOTO 152_^1_$CALL Q8FS(IRW,IFW,IND,ITYPE,IRF,IRG,IBCT,ISWR,ILIST,IANYL)_^1_$GOTO 151_^1 152 DO 1 I=1€€, 20_^1_"1 IDIG(I)=0_^1_$DPFLAG = 0_^1 125 IF(IRW.EQ.1)GOTO 32_^1C_]_^1C_#INPUT CONVERSIONS_^1C**************************************************************FTN 3.1**_^1C_+A R E F $ I_!D_^1_$GO TO (2,2,16,16,12,9,100), ITYPE_^1C_]_^1C_#SET DOUBLE PRECISION FLAG - GO TO E FORMAT LOGIC_^1C_]_^1 100 DPFLAG = 1_^1_$INEFLG = 0_^1_$GO TO 16_^1C**************************************€€************************FTN 3.1**_^1C_]_^1C_#NORMAL EXIT_^1C_]_^1 150 CALL Q8FS(IRW,IFW,IND,ITYPE,IRF,IRG,IBCT,ISWR,ILIST,IANYL)_^1_$RETURN_^1C_]_^1C_#A AND R INPUT CONVERSIONS_^1C_]_^1_"2 IWORD =0_^1_$IF(IFW.LT.2)GOTO 6_^1_"3 CALL Q8RWBU_!(ICHAR)_^1_$IF(IFW.GT.2)GOTO 4_^1_$IWORD = IWORD * 256_^1_$IWORD = OR(IWORD,ICHAR)_^1_"4 IFW = IFW-1_^1_$IF(IFW.NE.0) GOTO 3_^1_"5 K1=0_]_^1_$€€CALL Q8MOVE (IWORD,K1)_^1_$GOTO 150_^1C_]_^1C_#PARTIAL WORD_^1C_]_^1_"6 CALL Q8RWBU (ICHAR )_^1_$IF(ITYPE.EQ.2)GOTO 7_^1C_#TYPE A, MERGE IN BLANK_^1_$IWORD = ICHAR * 256_^1_$IWORD = OR(IWORD,32)_^1_$GOTO 5_^1_"7 IWORD = AND (255, ICHAR)_^1_$GOTO 5_^1C_]_^1C_#INPUT I CONVERSION_^1C_]_^1_"9 ISUM= 0_^1_$MSIGN =-1_^1_!95 CALL Q8RWBU(ICHAR)_^1_$IF(ICHAR.EQ.32) GOTO 955_^1_$IF(ICHAR€€.EQ.43) GOTO 9557_^1_$IF(ICHAR.NE.45) GOTO 96_^1_$IF(MSIGN.GT.-1) GOTO 11_^1_$MSIGN =1_^1 955 IFW=IFW-1_^1_$IF(IFW.GT.0) GOTO 95_^1_$GOTO 105_^1 9557 IF(MSIGN.GT.-1) GOTO 11_^1_$MSIGN =0_^1_$GOTO 955_^1_!96 IF (ICHAR.LT.48.OR.ICHAR.GT.57) GOTO 115_^1 965 ISUM =(ISUM*10) + (ICHAR - 48)_^1C_#NUMBER SPILLED OVER TO SIGN BIT_^1_$IF (ISUM.LT.0 ) GOTO 117_^1_$IFW = IFW-1_^1_$IF(IFW.LT€€.1) GOTO 105_^1_$CALL Q8RWBU (ICHAR)_^1_$GOTO 96_^1 105 K1=0_]_^1_$IF(MSIGN.NE.1) GOTO 107_^1_$ISUM = -ISUM_^1 107 CALL Q8MOVE (ISUM,K1)_^1_$GOTO 150_^1C_#BAD CHARACTER IN I CONVERSION_^1_!11 CALL Q8FERM ( 2 )_^1_$STOP_]_^1_$RETURN_^1 115 IF (ICHAR.NE.32) GOTO 11_^1_$ICHAR = 48_^1_$GOTO 965_^1C_#INPUT NUMBER TOO LARGE_^1 117 CALL Q8FERM (3)_^1_$STOP_]_^1_$RETURN_^1C_]_^1C_#€€$ CONVERSION IN_^1C_]_^1_!12 ISUM= 0_^1_$ICNT =0_^1_$K=IFW_^1_$DO 123 I=1, K_^1_$CALL Q8RWBU(ICHAR)_^1_$IF(ICHAR.NE.32) GOTO 126_^1_$IFW = IFW-1_^1 123 CONTINUE_^1_$GOTO 135_^1 126 ICSAV = ICHAR_^1 129 ICNT = ICNT+1_^1_$IF(ICHAR.LT.48.OR.ICHAR.GT.57)GOTO 14_^1_!13 ISUM= (ISUM*16)+(ICHAR-48)_^1_$IFW = IFW-1_^1_$IF(IFW.LT.1) GOTO 135_^1_$CALL Q8RWBU(ICHAR)_^1_$GOTO 129_^1 135 IF€€((ICSAV.EQ.70).AND.(ISUM.EQ.0).AND.(ICNT.EQ.4) ) GOTO 137_^1 136 K1 = 0_^1_$IF(ICNT.GT.4) GOTO 117_^1_$CALL Q8MOVE(ISUM,K1)_^1_$GOTO 150_^1 137 ISUM = $FFFF_^1_$GOTO_!136_^1_!14 IF(ICHAR.LT.65.OR.ICHAR.GT.70) GOTO 145_^1_$ICHAR =ICHAR-7_^1_$GOTO 13_^1 145 IF(ICHAR.NE.32) GOTO 15_^1_$ICHAR = 48_^1_$GOTO 13_^1C_#BAD CHARACTER IN INPUT CONVERSION_^1_!15 CALL Q8FERM (2)_^1_$STOP_€€]_^1_$RETURN_^1C_]_^1C_#E AND F AND D INPUT CONVERSIONS_7**FTN 3.1**_^1C_]_^1C_#OVER-RIDE ND INDICATOR FROM FORMAT STATEMENT (RE-COUNT ND)_^1_!16 IRND= 0_^1_$IPTL= 0_^1_$ISUM= 0_^1_$MSIGN = 0_^1_$IESGN =0_^1_$IDP = 0_^1_$IXD=0_^1C**************************************************************FTN 3.1**_^1_$DO 163 I=1,6_^1C*************************************************************€€*FTN 3.1**_^1 163 IWORK(I) =0_^1 165 CALL Q8RWBU (ICHAR)_^1C_#BLANK_^1_$IF(ICHAR.NE.32)GOTO 17_^1 167 IFW = IFW-1_^1_$IF (IFW.EQ.0) GOTO 307_^1_$GOTO 165_^1C_#MINUS_^1_!17 IF(ICHAR.NE.45) GOTO 175_^1_$MSIGN =1_^1_$GOTO 167_^1 175 IF(ICHAR.EQ.43) GOTO 167_^1_$GOTO 21_^1_!18 IFW = IFW -1_^1_$IF(IFW.EQ.0)GOTO 31_^1_$CALL Q8RWBU (ICHAR)_^1_$GOTO 21_^1C****************************€€**********************************FTN 3.1**_^1_!19 IND = IND + IRND_^1_$IF (DPFLAG .NE. 1) GO TO 20_^1_$IWORK(5) = (IWORK(5)*10) + ICHAR -48_^1_$ISUM = AND(IWORK(5)/4096,$F)_^1_$IWORK(5) = AND(4095,IWORK(5))_^1_$IWORK(4) = (IWORK(4)*10) + ISUM_^1_$ISUM = AND(IWORK(4)/4096,$F)_^1_$IWORK(4)=AND(4095,IWORK(4))_^1_!20 IF(DPFLAG .EQ. 0) ISUM = ICHAR - 48_^1_$IWORK(3)=(IWORK(3)*10) + IS€€UM_^1_$ISUM = AND(IWORK(3)/4096,$F)_^1_$IWORK(3) = AND(4095,IWORK(3))_^1_$IWORK(2)=(IWORK(2)*10) + ISUM_^1_$K=AND(IWORK(2),$F000)_^1C_#IF SINGLE PRECISION CARRY 24 BITS_^1C_#IF DOUBLE PRECISION - CARRY 40 BITS_3**FTN 3.1**_^1C****************************************************************FTN 3.1_^1_$IF (DPFLAG .EQ. 1) K=AND(IWORK(2),$FFF0)_^1C*************************************€€***************************FTN 3.1_^1_$IF (K .NE. 0) GO TO 195_^1_$GO TO 18_^1C**************************************************************FTN 3.1**_^1 195 IFW=IFW-1_^1_$IF(IFW.EQ.0) GOTO 31_^1_$CALL Q8RWBU (ICHAR)_^1C**************************************************************FTN 3.1**_^1_$IF(ICHAR.EQ.43.OR.ICHAR.EQ.45.OR.ICHAR.EQ.69.OR.ICHAR.EQ.68) GO_^1_#1 TO 23_^1C*******€€*******************************************************FTN 3.1**_^1_$IF(ICHAR.EQ.46) GOTO 197_^1C **************************************************************_^1C_#ILLEGAL CHARACTER IF NOT A BLANK OR DIGIT_^1_$IF (ICHAR.NE.32.AND.(ICHAR.LT.48.OR.ICHAR.GT.57)) GO TO 11_^1C **************************************************************_^1_$IF(IDP.NE.0) GOTO 195_^1_$IXD = IXD+1_^1_$€€GOTO 195_^1 197 IDP=1_^1_$GOTO 195_^1C_#PLUS_]_^1_!21 IF (ICHAR.LT.48.OR.ICHAR.GT.57 ) GOTO 215_^1C_#DECIMAL DIGIT_^1_$GOTO 19_^1 215 IF (ICHAR.NE.32) GOTO 22_^1_$ICHAR =48_^1_$GOTO 19_^1C_#DECIMAL POINT_^1_!22 IF(ICHAR.NE.46) GOTO 23_^1_$IND = 0_^1_$IRND= 1_^1_$IDP =1_^1_$GOTO 18_^1C_]_^1C_#E OR D TYPE_^1C_]_^1C**************************************************************FTN€€ 3.1**_^1_!23 IF(ICHAR.NE.69.AND.ICHAR.NE.68) GO TO 26_^1C_#IF D FORMAT AND DATA CONTAINS AN E IN THE FIELD SET INEFLG = 69_^1_$IF (ICHAR .EQ. 69 .AND. DPFLAG .EQ. 1) INEFLG = 69_^1C**************************************************************FTN 3.1**_^1_!24 IFW = IFW-1_^1_$IF(IFW.EQ.0) GOTO 31_^1_!25 CALL Q8RWBU (ICHAR)_^1C_#BLANK_^1_$IF(ICHAR.EQ.32) GOTO 24_^1C_#MINUS_^1_!26 I€€F(ICHAR.NE.45) GOTO 27_^1_$IESGN =1_^1_$GOTO 30_^1C_#PLUS_]_^1_!27 IF(ICHAR.EQ.43) GOTO 30_^1C_#DECIMAL DIGIT_^1_!28 IF (ICHAR.LT.48.OR.ICHAR.GT.57 ) GOTO 305_^1_!29 IPTL= (IPTL*10) + (ICHAR -48)_^1_$IF(IPTL.GT.99) GOTO 117_^1_!30 IFW = IFW -1_^1_$IF(IFW.EQ.0)GOTO 31_^1_$CALL Q8RWBU(ICHAR )_^1_$GOTO 28_^1 305 IF (ICHAR.NE.32 ) GOTO 11_^1_$ICHAR = 48_^1_$GOTO 29_^1C***************€€***********************************************FTN 3.1**_^1 307 IWORK(6) = 0_^1_$IF (DPFLAG .EQ. 0) GO TO 318_^1_$GO TO 330_^1C**************************************************************FTN 3.1**_^1C_]_^1C_#IESGN = EXPONENT SIGN_!MSIGN = MANTISSA SIGN ISUM = EXPONENT_^1C_#IPTL = MANTISSA_"ALL POSITIVE INTEGERS_^1C_]_^1C_#WORK AREA CONTAINS_!W1 IS NOT USED. W2 CONTAINS POSIT€€IVE_^1C_%MANTISSA HO 12 BITS_!MANTISSA LO 12 BITS_"EXPONENT SIGNED._^1C**************************************************************FTN 3.1**_^1C_#IWORK(1) - NOT USED_^1C_#IWORK(2) - HI ORDER 4 BITS-DP OR HI ORDER 12 BITS SP_^1C_#IWORK(3) - ISB 12 DP OR LO ORDER BITS SP._^1C_#IWORK(4) - ISB 12 DP_^1C_#IWORK(5) - LO ORDER 12 BITS DP_^1C_#IWORK(6) - EXPONENT_^1C*********************€€*****************************************FTN 3.1**_^1_!31 IF(IESGN.EQ.0) GOTO 315_^1_$IPTL =-IPTL_^1C_]_^1C_#STORE EXPONENT_^1C_]_^1C**************************************************************FTN 3.1**_^1 315 IWORK(6) = IPTL - IND + IXD_^1C**************************************************************FTN 3.1**_^1C_]_^1C_#EXP9 - MANTISSA 2 WORDS 12 BITS ALWAYS + , DECIMAL EXPO€€NENT +OR-_^1C_]_^1_$ITEST(1)=IND_^1_$ITEST(2)=IPTL_^1_$ITEST(3)=IWORK(1)_^1_$ITEST(4)=IWORK(2)_^1_$ITEST(5)=IWORK(3)_^1_$ITEST(6) = IWORK(6)_^1C**************************************************************FTN 3.1**_^1C *************************************************************_^1C_%IF NOT DOUBLE PRECISION GO TO SINGLE PRECISION LOGIC_^1_%IF(DPFLAG.NE. 1) GO TO 318_^1C_#CLEAR DO€€UBLE PRECISION FLAG_^1_%DPFLAG = 0_^1C *************************************************************_^1_$ITEST(6)=IWORK(4)_^1_$ITEST(7)=IWORK(5)_^1_$ITEST(8)=IWORK(6)_^1C *************************************************************_^1C_$ZERO COEFFICIENT IS ZERO CONSTANT_^1 330 IWORK(1) = IWORK(2)+IWORK(3)+IWORK(4)+IWORK(5)_^1_%IF (IWORK(1) .EQ.0) GO TO 320_^1_%CALL Q8DXP9 (IWORK(€€2),IWORK(6))_^1C_]_^1C *************************************************************_^1_$IF(IWORK(6) .NE. 0) GO TO 117_^1C_#IF DATA BEING INPUT UNDER A D FORMAT CONTAINS AN E IN THE DATA_^1C_#FIELD, CLEAR THE THIRD WORD OF THE DOUBLE PRECISION_"**FTN 3.1**_^1C_#FLOATING POINT NUMBER._@**FTN 3.1**_^1_$IF (INEFLG .EQ. 69) IWORK(4) = 0_^1_$IF(MSIGN .EQ. 0) GO TO 320_^1_$IWORK(2) = -I€€WORK(2)_^1_$IWORK(3) = -IWORK(3)_^1_$IWORK(4) = -IWORK(4)_^1 320 K1=0_]_^1_$CALL Q8MOVE (IWORK(2),K1)_^1_$K1=1_]_^1_$CALL Q8MOVE(IWORK(3),K1)_^1_$K1=2_]_^1_$CALL Q8MOVE(IWORK(4),K1)_^1_$GO TO 150_^1C *************************************************************_^1C_$ZERO COEFFICIENT IS ZERO CONSTANT_^1 318 IWORK(1) = IWORK(2) + IWORK(3)_^1_%IF (IWORK(1) .EQ. 0) GO TO 319_^1_%CALL€€ Q8EXP9 (IWORK (2),IWORK(6))_^1C_]_^1C *************************************************************_^1_$IF(IWORK(6) .NE. 0) GO TO 117_^1C**************************************************************FTN 3.1**_^1_$IF(MSIGN.EQ.0)GOTO 319_^1_$IWORK(2) = - IWORK(2)_^1_$IWORK(3) = - IWORK(3)_^1 319 K1=0_]_^1_$CALL Q8MOVE (IWORK(2),K1 )_^1_$K1=1_]_^1_$CALL Q8MOVE (IWORK(3),K1 )_^1_$GO €€TO 150_^1C***********************************************************************_^1C_]_^1C_#OUTPUT CONVERSIONS COME HERE_^1C**************************************************************FTN 3.1**_^1C_,A R E F $ I_"D_^1_!32 GO TO (33,33,40,41,84,76,1033) , ITYPE_^1 1033 DPFLAG = 1_^1_$GO TO 40_^1C**************************************************************FTN 3.1**_^1C_#A AN€€D R OUTPUT CONVERSIONS_^1_!33 IWORD =0_^1_$K1=0_]_^1_$CALL Q8MOVE (IWORD,K1 )_^1_$IF(IFW.LT.2)GOTO 36_^1_!34 IF(IFW.GT.2)GOTO 35_^1_$K1 = IWORD_^1_$ICHAR = IWORD /256_^1_$ICHAR = AND(ICHAR,255)_^1_$CALL Q8RWBU (ICHAR )_^1_$ICHAR = AND(K1,255)_^1_$CALL Q8RWBU (ICHAR )_^1_$GOTO 150_^1C_#INSERT BLANKS IN OUTPUT FIELD FOR FW.GT.2_^1_!35 ICHAR = 32_^1_$CALL Q8RWBU (ICHAR )_^1_$IFW =€€ IFW- 1_^1_$GOTO 34_^1_!36 IF (ITYPE .EQ. 2 ) GOTO 38_^1C_#A,1 CHARACTER OUT_^1_$ICHAR = IWORD /256_^1_$ICHAR = AND (ICHAR,255)_^1_!37 CALL Q8RWBU (ICHAR )_^1_$GOTO 150_^1C_#R,1 CHARACTER OUT_^1_!38 ICHAR = AND (IWORD,255)_^1_$GOTO 37_^1C_]_^1C_#E, D, AND F OUTPUT CONVERSIONS_8**FTN 3.1**_^1C_]_^1C_#E OUT. IY = EXTRA CHARACTERS NEEDED. S0. ESXX (7 EXTRA)_^1_!40 IY=6_]_^1_$GOTO€€ 42_^1C_#F OUT. S . (2 EXTRA)_^1_!41 IY=1_]_^1_!42 M(1)=0_^1_$M(2)=0_^1C**************************************************************FTN 3.1**_^1_$M(3) = 0_^1_$DO 43 I=1,6_^1C**************************************************************FTN 3.1**_^1_!43 N(I)= 0_^1_$ISF = 0_^1C_#SET EXPONENT AND MANTISSA SIGNS TO PLUS_^1_$MSIGN =43_^1_$IESGN =43_^1C_#GET REAL NUMBER FROM CORE_^€€1_$K1=0_]_^1_$CALL Q8MOVE (M(1),K1 )_^1_$K1=1_]_^1_$CALL Q8MOVE (M(2), K1 )_^1C**************************************************************FTN 3.1**_^1_$IF (DPFLAG .EQ. 0) GO TO 44_^1_$K1=2_]_^1_$CALL Q8MOVE(M(3),K1)_^1_$N(4) = M(3)_^1_!44 N(2) = M(1)_^1C**************************************************************FTN 3.1**_^1_$N(3) = M(2)_^1_$IT = AND (M(1) , $8000 )_^1_$IF(I€€T.EQ.0) GOTO 445_^1_$MSIGN =45_^1_$IY = IY+1_^1_$N(2) = -N(2)_^1_$N(3) = -N(3)_^1C**************************************************************FTN 3.1**_^1_$IF (DPFLAG .EQ. 1) N(4) = -N(4)_^1C**************************************************************FTN 3.1**_^1C_]_^1C_#CONVERT REAL NUMBER TO INTERMEDIATE FORM_^1C_#EXP10- IN-REAL NUMBER IN WD1 AND WD2 , OUT-+MANTISSA IN 2 AND €€3_^1C_#+ OR - DECIMAL EXPONENT IN 4_^1C_]_^1C_[**FTN 3.1**_^1C_#CONVERT DOUBLE PRECISION NUMBER TO INTERMEDIATE FORM_!**FTN 3.1**_^1C_#DXP10 - INPUT-DOUBLE PRECISION NUMBER IN WD1, WD2, AND **FTN 3.1**_^1C_'WD3- OUTPUT-MANTISSA IN WD2,WD3,WD4,AND WD5_(**FTN 3.1**_^1C_3+ OR - DECIMAL EXPONENT IN WD6_)**FTN 3.1**_^1C_[**FTN 3.1**_^1C***************************************************€€***********FTN 3.1**_^1 445 IF(DPFLAG - 1)447,446,447_^1 446 CALL Q8DXP1(N(1))_^1_$GO TO 448_^1 447 CALL Q8EXP1(N(1))_^1C_[**FTN 3.1**_^1C_#CHANGE LOCATION OF EXPONENT_;**FTN 3.1**_^1C_[**FTN 3.1**_^1_$N(6) = N(4)_^1 448 IT=AND(N(6),256)_^1C**************************************************************FTN 3.1**_^1_$IF ( IT .EQ. 0) GOTO 45_^1_$IESGN =45_^1_$N(6) = -N(6)_^1C_]_^1€€C_#CONVERT MANTISSA INTO DECIMAL DIGITS IN IMAN,_^1C_#CHARACTER COUNT TO IC1_^1C_]_^1_!45 K1=N(2)_^1_$K2=N(3)_^1_$IC1=0_^1C**************************************************************FTN 3.1**_^1_$IF (DPFLAG .EQ. 0) GO TO 451_^1_$KTHREE = N(4)_^1_$KFOUR = N(5)_^1 1451 KTHREE = KTHREE * 10_^1_$KFOUR = KFOUR * 10_^1_$K4OVER = KFOUR_^1_$KFOUR = AND(KFOUR,4095)_^1_$K4OVER = AND(K4OVE€€R/4096,15)_^1_$KTHREE = KTHREE + K4OVER_^1_$K3OVER = AND(KTHREE/4096,15)_^1_$KTHREE = AND(KTHREE,4095)_^1_$K1 = K1 * 10_^1_$K2 = K2 * 10 + K3OVER_^1_$GO TO 1452_^1C**************************************************************FTN 3.1**_^1 451 K1 = K1*10_^1_$K2= K2*10_^1C_[**FTN 3.1**_^1C_#THIS LOGIC(TEST) HANDLES THE 2 BIT INACCURACY PROBLEM IN Q8EXP1._^1C_[**FTN 3.1**_^1_$IF(IC1 €€.EQ. 0 .AND. N(5) .NE. 0) K2=K2+AND((N(5)*10)/4096,15)_^1C_]_^1C**************************************************************FTN 3.1**_^1 1452 K4=K2_^1C**************************************************************FTN 3.1**_^1_$K2 = AND(K2,4095)_^1_$K4 = AND(K4/4096,15)_^1_$K1 = K1+K4_^1_$K3 = K1/4096_^1_$K1=AND(K1,4095)_^1_$IC1 = IC1+1_^1_$IMAN(IC1) = AND (K3,15)_^1C*************€€*************************************************FTN 3.1**_^1_$IF (DPFLAG) 1453,1454,1453_^1 1453 IF (IC1 .LT. 20) GO TO 1451_^1_$GO TO 425_^1 1454 IF (IC1 .LT. 20) GO TO 451_^1C**************************************************************FTN 3.1**_^1C ********************************** PSR 458 **************************_^1C ********************************** PSR 458 ***********€€***************_^1 425 K5=IND+1_^1 453 IF(IMAN(1).NE.0) GO TO 4532_^1_$DO 4531 I=1,19_^1 4531 IMAN(I)=IMAN(I+1)_^1_$IF(IESGN.EQ.45) GO TO 4533_^1C**************************************************************FTN 3.1**_^1_$N(6) = N(6) - 1_^1_$IF(N(6) .GT. -1) GO TO 4532_^1C**************************************************************FTN 3.1**_^1_$IESGN=45_^1C*********************€€*****************************************FTN 3.1**_^1_$N(6) = -N(6)_^1C**************************************************************FTN 3.1**_^1_$GO TO 4532_^1C**************************************************************FTN 3.1**_^1 4533 N(6) = N(6) + 1_^1C**************************************************************FTN 3.1**_^1 4532 IF(ITYPE.NE.4) GO TO 4538_^1C***************€€***********************************************FTN 3.1**_^1_$IF (IESGN .EQ. 45) K5 = K5 - N(6)_^1_$IF (IESGN .EQ. 43) K5 = K5 + N(6)_^1C**************************************************************FTN 3.1**_^1_$IC1=K5-1_^1 4538 IF(K5.GT.20) GO TO 455_^1C ********************************** PSR 458 **************************_^1C ********************************** PSR 458 *********€€*****************_^1C ********************************** PSR 769 **************************_^1C ********************************** PSR 769 **************************_^1_$IF(K5.LE.0) GO TO 455_^1C ********************************** PSR 769 **************************_^1C ********************************** PSR 769 **************************_^1_$IMAN(K5)=IMAN(K5)+5_^1_$IF(IMAN(K5).€€LT.10) GOTO 455_^1_$IC=K5-1_^1_$IF(K5.EQ.1) GO TO 1000_^1_$DO 454 I=1,IC_^1_$K5=K5-1_^1_$IMAN(K5) = IMAN(K5)+1_^1_$IF(IMAN(K5).LT.10) GOTO 455_^1_$IMAN(K5) =0_^1_$IF(K5.EQ.1) GO TO 1000_^1 454 CONTINUE_^1_$GO TO 455_^1 1000 IDIG(1)=1_^1_$IF(IESGN.EQ.43) GOTO 4534_^1C**************************************************************FTN 3.1**_^1_$N(6) = N(6) - 1_^1_$IF(N(6) .GT. -1) GO €€TO 4536_^1C**************************************************************FTN 3.1**_^1_$IESGN =43_^1C**************************************************************FTN 3.1**_^1_$N(6) = -N(6)_^1C**************************************************************FTN 3.1**_^1_$GOTO 4536_^1C**************************************************************FTN 3.1**_^1 4534 N(6) = N(6) + 1_^1C****€€**********************************************************FTN 3.1**_^1 4536 DO 4535 K=1, 19_^1 4535 IDIG(K+1) = IMAN(K)_^1_$DO 4537 K=1, 20_^1 4537 IMAN(K) = IDIG(K) +48_^1_$GOTO 459_^1 455 DO 456 I=1,20_^1 456 IMAN(I) = IMAN(I) +48_^1 459 ICNT =1_^1C**************************************************************FTN 3.1**_^1C_#TAKE E/D OR F CONVERSION LEG_:**FTN 3.1**_^1_$IF (I€€TYPE .EQ. 3 .OR. ITYPE .EQ. 7) GO TO 61_^1C**************************************************************FTN 3.1**_^1C_]_^1C_#F LEG OUT_^1C_]_^1_$K=IFW-(IND+IY)_^1C**************************************************************FTN 3.1**_^1_$IF (IESGN .EQ. 43) K = K - N(6)_^1C**************************************************************FTN 3.1**_^1_$IF(K.LT.0) GOTO 59_^1_$IF(K.EQ.0€€) GOTO 47_^1C_]_^1C_#PUT OUT LEADING BLANKS_^1C_]_^1_$DO 46 I=1, K_^1_$CALL Q8RWBU (32)_^1_!46 IFW = IFW-1_^1_!47 IF(MSIGN.EQ.43) GOTO 48_^1C_#PUT OUT SIGN OF NUMBER_^1_$CALL Q8RWBU (MSIGN)_^1_$IFW=IFW -1_^1C_]_^1C_#NUMBER OF INTEGER PLACES IN FIELD_^1C_]_^1C**************************************************************FTN 3.1**_^1_!48 ISF = N(6)_^1C******************************€€********************************FTN 3.1**_^1_$IF(IESGN.NE.45) GOTO 505_^1C**************************************************************FTN 3.1**_^1_$ISF = - N(6)_^1C**************************************************************FTN 3.1**_^1 505 IF(ISF.LT.1)GOTO 53_^1_$CALL Q8RWBU (IMAN(ICNT))_^1_!51 ICNT =ICNT +1_^1_$ISF = ISF -1_^1 510 IFW = IFW -1_^1_$GOTO 505_^1_!53 CALL Q8R€€WBU (46)_^1C_#DECIMAL POINT_^1_$IFW =IFW-1_^1_!54 IF(ISF.EQ.0)GOTO 55_^1_$IF(IFW.GT.0)GOTO 540_^1_$GOTO 150_^1 540 CALL Q8RWBU (48)_^1C_#PUT OUT LEADING 0'S_^1_$IFW =IFW-1_^1_$ISF = ISF +1_^1_$GOTO 54_^1_!55 IF(IFW.GT.0) GOTO 56_^1_$GOTO 150_^1C_#PUT OUT DIGITS OF FRACTION_^1_!56 CALL Q8RWBU (IMAN(ICNT))_^1_$IC1 = IC1 -1_^1_$ICNT= ICNT +1_^1_!57 IFW = IFW -1_^1_$GOTO 55_^1C_#FIE€€LD TOO NARROW FOR NUMBER, OUTPUT *'S_^1_!59 IF(IFW.GT.0)GOTO 60_^1_$GOTO 150_^1_!60 CALL Q8RWBU (42)_^1_$IFW = IFW -1_^1_$GOTO 59_^1C_]_^1C_#E AND D OUT._J**FTN 3.1**_^1C_]_^1_!61 IF((IFW -IND -IY).LT.0)GOTO 59_^1_$K= IFW -IND -IY_^1_$IF(K.EQ.0) GOTO 614_^1C_]_^1C_#PUT OUT LEADING BLANKS_^1C_]_^1_$DO 613 I=1,K_^1_$CALL Q8RWBU (32)_^1 613 IFW = IFW -1_^1 614 IF(MSIGN.EQ.43) GOTO€€ 615_^1_$CALL Q8RWBU (MSIGN)_^1_$IFW = IFW-1_^1 615 CALL Q8RWBU (48)_^1_$CALL Q8RWBU (46)_^1C_#OUTPUT +0. OR -0._^1_$IFW = IFW-2_^1_!62 IF(IND.EQ.0) GOTO 65_^1_$CALL Q8RWBU (IMAN(ICNT))_^1_$ICNT = ICNT +1_^1_$IND = IND -1_^1_$GOTO 62_^1C**************************************************************FTN 3.1**_^1C_#PUT OUT EXPONENT CHARACTERS E OR D_4**FTN 3.1**_^1_!65 IF (DPFLAG €€- 1) 1166,1165,1166_^1C_#D_]_^1 1165 CALL Q8RWBU(68)_^1_$DPFLAG = 0_^1_$GO TO 1167_^1C_#E_]_^1 1166 CALL Q8RWBU(69)_^1 1167 CONTINUE_^1C**************************************************************FTN 3.1**_^1_$CALL Q8RWBU (IESGN)_^1C**************************************************************FTN 3.1**_^1_$J1 = N(6)_^1C************************************************************€€**FTN 3.1**_^1_$ASSIGN 66 TO IAD_^1_$GOTO 72_^1C_#CONVERT EXPONENT, PUT CHARACTERS IN IDIG TABLE,CHAR COUNT TO IC_^1_!66 IF(IC.GT.2) GOTO 59_^1_$IC=IC+1_^1_$GOTO (67,69,70),IC_^1_!67 DO 68 I=1,2_^1_!68 CALL Q8RWBU (48)_^1_$GOTO 150_^1_!69 CALL Q8RWBU (48)_^1_$CALL Q8RWBU (IDIG(1))_^1_$GOTO 150_^1_!70 CALL Q8RWBU (IDIG(1))_^1_$CALL Q8RWBU (IDIG(2))_^1_$GOTO 150_^1C_#PUT OUT INTEG€€ER CHARACTERS INTO IDIG TABLE, STORED BACKWARDS._^1C_#POSITIVE INTEGER TO BE CONVERTED IN J1_^1C_#CHARACTER COUNT IN IC_^1_!72 K1=J1_^1_$K3=J1_^1_$K2=0_]_^1_$K4=0_]_^1_$IC=0_]_^1_$K=0_]_^1_$DO 74 I=1, 5_^1_$K=K+1_^1_$K1 = K3_^1_$K1=K1/NT(K)_^1_$IF(K1.EQ.0) GOTO 75_^1_$K2=1_]_^1_!73 IC = IC+1_^1_$IDIG(IC) = K1+48_^1_$K4 = K1*NT(I)_^1_$K1 = K3 - K4_^1_$K3 = K1_^1_!74 CONTINUE_^1_$GO€€TO IAD_^1_!75 IF(K2.EQ.0) GOTO 74_^1_$GOTO 73_^1C_]_^1C_#I CONVERSION COMES HERE_^1C_]_^1_!76 MSIGN =43_^1_$IY =0_^1_$K1=0_]_^1_$CALL Q8MOVE (J1, K1 )_^1_$ASSIGN 78 TO IAD_^1_$IT = AND (J1,$8000)_^1_$IF ( IT .EQ. 0) GOTO 77_^1_$J1= - J1_^1_$MSIGN =45_^1_$IY=1_]_^1_$GOTO 72_^1_!77 IY=0_]_^1_$GOTO 72_^1_!78 IF(IC.NE.0) GOTO 785_^1_$IC=1_]_^1_$IDIG(1) =48_^1 785 IBC=IFW-IC-IY_^1€€_$IF(IBC.LT.0)GOTO 83_^1_$IF(IBC.EQ.0)GOTO 80_^1_$DO 79 I=1,IBC_^1_!79 CALL Q8RWBU (32 )_^1C_#PUT OUT LEADING BLANKS_^1_!80 IF(MSIGN.EQ.43)GOTO 81_^1C_#PUT OUT MINUS_^1_$CALL Q8RWBU (45 )_^1_!81 DO 82 I=1, IC_^1_!82 CALL Q8RWBU (IDIG(I))_^1_$GOTO 150_^1C_#PUT OUT *'S INTO FW_^1_!83 DO 835 I=1,IFW_^1 835 CALL Q8RWBU (42)_^1_$GOTO 150_^1C_]_^1C_#$ OUT COMES HERE_^1C_]_^1C_#BLAN€€KS TO FW GREATER THAN 4_^1C_]_^1_!84 K1=0_]_^1_$CALL Q8MOVE (J1, K1)_^1_$K1=J1_^1_$K3 = J1_^1_$K2=0_]_^1_$K4=0_]_^1_$K5=0_]_^1_$IC=0_]_^1_$IF(K3.NE.0) GOTO 86_^1_$K3=AND(K1,1)_^1_$IF(K3.NE.0) GOTO 94_^1_$IBC = IFW-4_^1C ********************************** PSR 761 **************************_^1C ********************************** PSR 761 **************************_^1_$LCNT = IFW_^1_€€$IF (IBC.LE.0) GO TO 948_^1C ********************************** PSR 761 **************************_^1 949 CALL Q8RWBU(32)_^1_$IBC = IBC-1_^1_$IF(IBC.GT.0) GO TO 949_^1C ********************************** PSR 761 **************************_^1_$LCNT = 4_^1 948 DO 85 I=1, LCNT_^1C ********************************** PSR 761 **************************_^1C **************************€€******** PSR 761 **************************_^1_!85 CALL Q8RWBU (48 )_^1_$GOTO 150_^1_!86 DO 88 I=1,4_^1_$IC=IC+1_^1_$K1=AND(K1/NH(IC),15)_^1_$IDIG(IC) = K1+48_^1_$IF(IDIG(IC).LT.58) GOTO 87_^1_$IDIG(IC) = IDIG(IC) +7_^1_!87 K1=AND(K3,NH(IC)-1)_^1_!88 K3=K1_^1_$IC=0_]_^1_$DO 90 I=1,4_^1_$IF(IDIG(I).EQ.48) GOTO 91_^1_!89 IC = IC+1_^1_$IMAN(IC)=IDIG(I)_^1_!90 CONTINUE_^1_$GOTO 92_^1€€_!91 IF(IC.NE.0) GOTO 89_^1_$GOTO 90_^1_!92 IBC = IFW-IC_^1_$IF (IBC.LT.0) GOTO 83_^1_$IF(IBC.EQ.0) GOTO 935_^1_!93 CALL Q8RWBU (32)_^1_$IBC = IBC-1_^1_$IF(IBC.GT.0) GOTO 93_^1 935 DO 937 I=1,IC_^1 937 CALL Q8RWBU (IMAN(I) )_^1_$GOTO 150_^1_!94 IF(IFW.LT.4) GOTO 83_^1_$IBC = IFW-4_^1_$IF(IBC.NE.0) GO TO 946_^1 947 I = 4_^1 945 CALL Q8RWBU(70)_^1_$I=I-1_^1_$IF(I.GT.0) GOTO 945_^€t1_$GOTO 150_^1 946 CALL Q8RWBU(32)_^1_$IBC = IBC-1_^1_$IF(IBC.GT.0) GO TO 946_^1_$GO TO 947_^1_$END_]_^1 MON_]_^__ tPMON1 CSY/ P1 MON_]_^__ PQ8QINI CSY/ H04 P€1_%NAM Q8QINI_'DECK-ID H04 FTN 3.3 RUNTIME_%SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3_^1*_$SMALL COMPUTER DEVELOPMENT DIVISION, LA JOLLA CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1973_^1_%SPC 2_^1*_]_^1_(ENT_%Q8QINI_^1_(ENT_%Q8UNIT_.UNIT_^1_(ENT_%Q8SKIP_.SKIP_^1*_]_^1_(EXT_%Q8ERRM_.ERRMSG_^1_(EXT_%Q8INTB_.INTBUF_^1_(EXT_%Q8EREM_.EREMSG_^1_(EXT_%Q8QT0M_"IN Q€€8QT1M_^1_(EXT_%Q8CMP0_.CMPL0_^1_(EXT_%Q8MAGT_.MAGT_^1_(EXT_%Q8QEND_^1_(EXT_%Q8IFRM_.IFRMAT_^1_(EXT_%Q8IGP_/IGP_^1_(EXT_%Q8CMP1_.CMPL1_^1_(EXT_%Q8QUN2_^1_(EXT_%Q8DFIN_^1*_]_^1* INITIALIZE ROUTINE_^1*_]_^1* CALLING SEQUENCE 1_^1*_!RTJ Q8QINI_^1*_!FLAG WORD_^1*_!I/O REQUEST NUMBER_^1*_!UNIT NUMBER, OR ADR OF UNIT NR_^1*_!ADR OF FORMAT, OR ADR OF ADR OF FORMAT_^1*_]_^1*_]_^1* BIT 15_]_€€^1* BIT 14 SET FORMAT_$NOT SET NO FORMAT_^1* BIT 13 SET UNIT_'NOT SET ADR OF UNIT_^1* BIT 12 SET FORMAT ADR NOT SET ADR OF FORMAT ADR_^1* BIT 11 SET LIST_'NOT SET NO LIST_^1* BIT 10 SET READ_'NOT SET NOT READ_^1* BIT 9 SET WRITE_%NOT SET NOT WRITE_^1*_]_^1Q8QINI_!NOP_%0_^1_(STQ*_$T+1_^1_(LDA-_$$FF_^1_(STA*_$T+2_^1* READ 1ST WORD_^1_(LDA*_$(Q8QINI)_^1_(STA*_$FLG_%FLAGWORD_^1€€* READ 2ND WORD_^1_(RAO*_$Q8QINI_^1_(LDA*_$(Q8QINI)_^1_(STA*_$NR_'RQST NR_^1* READ 3RD WORD_^1AUNIT_"RAO*_$Q8QINI_"PICK UP UNIT NR_^1_(LDA*_$(Q8QINI)_^1_(STA*_$TEMP_^1_(LDQ*_$FLG_%CHECK FOR INDIRECT ADDRE_^1_(QLS_%2_^1_%SQM_'NOTIND-*-1 NOT INDIRECT ADDRESS OF U_^1_%STQ* QSTEMP_J**FTN 3.0**_^1_%LDQ- $F6_*CHECK IF IN UPPER BANK_,**FTN 3.0**_^1_%SQM KLG65K_'IF SO, NO RELATIVE ALLOWED€€_(**FTN 3.0**_^1_(SAP_%3_(SKIP IF NOT RELATIVE_^1_(ADD*_$Q8QINI_"RELATIVE_^1_(AND*_$SVNF_^1_(STA*_$TEMP_^1KLG65K LDQ* QSTEMP_J**FTN 3.0**_^1_(LDA*_$(TEMP)_"INDIRECT_^1NOTIND_!STA*_$UNIT_^1_(QLS_%5_^1_(STQ*_$TEMP_^1_(SQM_%INTER_#SKIP IF DISK I/O_^1_(TRA_%Q_(IF UNIT LESS THAN 5,_^1_(INQ_%-5_'RETRIEVE THE DEVICE CODE_^1_(SQP_%3_(FROM THE COMMUNICATION_^1_(INQ_%4_(REGION AND STORE IN U€€NIT_^1_(LDA-_$$F9,Q_^1_(STA*_$UNIT_^1*_]_^1*_'INITIALIZE ERROR MESSAGE ROUTINE_^1*_]_^1INTER_"TRA_%Q_)UNIT_^1_(LDA*_$NR_'I/O REQUEST NUMBER_^1_(RTJ+_$Q8ERRM_.ERRMSG_^1*_]_^1* MAKE STATUS REQUEST_^1_(LDA*_$UNIT_^1_(LDQ*_$TEMP_^1_(SQP_%3_)SKIP IF NOT MASS STORAGE_^1_(RTJ+_$Q8DFIN_#INITIALIZE DISK OR DRUM_^1_(STA*_$UNIT_^1_(STA*_$UR_^1_%RTJ* STATUS_^1_(STQ*_$SFLAG_^1_(TRQ_%A_^1*_]_^1*€€ CHECK FOR MAG TAPE_^1*_]_^1_%AND =N$3800_%GET TYPE CODE_8PSR 743_^1_%SUB =N$800_'CHECK FOR MAG TAPE_3PSR 743_^1_(SAN_%REG-*-1_!NOT MAGNETIC TAPE_^1_(LDQ*_$FLG_%FLAG_^1_(LDA*_$UNIT_$UNIT_^1_(RTJ+_$Q8MAGT_"TEST USE OF MAG TAPE_^1* TEST LEGALITY OF USE OF UNIT_^1* R=1 READ, BIT 1_^1* R=2 WRITE, BIT 2_^1* R=3 READ OR WRITE_^1* FLAG WORD_^1* BIT 9 SET, WRITE_^1* BIT 10 SET, READ_^1RE€€G_$LDA*_$SFLAG_^1_(AND*_$TYPER_^1_(STA*_$SSFLG_^1_(AND*_$RORW_^1_(EOR*_$RORW_^1_(SAN_%1_^1_(JMP*_$OK_^1_(LDA*_$FLG_^1_(AND*_$B9_^1_(SAZ_%TSTB10-*-1_^1_(STA*_$TEMP_^1_(EOR*_$SSFLG_^1_(SUB*_$NUM1_^1_(SAZ_%OK-*-1_^1_(JMP*_$ER_^1TSTB10_!LDA*_$FLG_^1_(AND*_$B10_^1_(EOR*_$SSFLG_^1_(SUB*_$NUM2_^1_(SAZ_%OK-*-1_^1_(JMP*_$ER_^1OK_%JMP*_$INITA_^1* INCORRECT USE OF UNIT_^1* TYPE ERROR MSG AND €€EXIT_^1ER_%ENA_%4_^1_(RTJ+_$Q8EREM_.EREMSG_^1_(RTJ-_$($F4)_#EXIT REQUEST_^1_(NUM_%$0A00_^1_(BSS_%SFLAG_^1NUM1_#NUM_%$0204_#BIT 2 AND BIT 9_^1NUM2_#NUM_%$0402_#BIT 1 AND BIT 10_^1RORW_#NUM_%$0006_^1_(BSS_%NR_^1_(BSS_%UNIT_^1_(BSS_%FLG_^1B9_%NUM_%$0200_^1TYPEM_"NUM_%$07F0_^1TYPE9_"NUM_%$0090_^1TYPER_"NUM_%$000E_^1_(BZS_%SSFLG_^1_(BZS_%T(3)_^1_(EQU_%TEMP(T)_^1QSTEMP NUM 0_O**FTN 3.0*€€*_^1STATUS NOP 0_^1_(RTJ-_$($F4)_^1_(NUM_%$0600_^1UR_%SLS_%0_^1_(SLS_%0_^1_%JMP* (STATUS)_^1SVNF_#NUM_%$7FFF_^1*_]_^1* INITIALIZE ERROR ROUTINE_^1* SET N = 0 AND PASS I/O RQST NR_^1* AND UNIT NR TO ERMSG ROUTINE_^1*_]_^1INITA_"NOP_%0_^1* PASS FLAG AND UNIT_^1_(LDA*_$FLG_^1_(LDQ*_$UNIT_^1_(RTJ+_$Q8CMP0_.CMPL0_^1* INITIALIZE WRITE READ BUFFER_^1INITB_"LDA*_$FLG_^1_(RTJ+_$Q8INTB_.INT€€BUF_^1_(EQU_%FORM(*)_^1_(LDA*_$FLG_%CHECK FOR LIST_^1_(AND*_$B11_%NOT 0 FOR LIST_^1_(STA*_$LONL_$0 FOR NO LIST_^1_(LDA*_$FLG_1IS THERE A FORMAT STMENT_^1_(AND*_$B14_^1_(SAN_'1_^1_)JMP*_$INITC_^1* READ 4TH WORD_^1RED4_#RAO*_$Q8QINI_^1_(LDA*_$(Q8QINI)_^1_$STQ* QSTEMP_K**FTN 3.0**_^1_$LDQ- $F6_+UPPER BANK NO RELATIVE ALLOWED_#**FTN 3.0**_^1_%SQM KL65K_K**FTN 3.0**_^1_%SAP KL65K_K**F€€TN 3.0**_^1_%ADD Q8QINI_J**FTN 3.0**_^1_(AND*_$SVNF_^1KL65K LDQ* QSTEMP_J**FTN 3.0**_^1_(STA*_$FSAD_^1RED4A_"LDA*_$FLG_^1_(AND*_$B12_^1_(SAN_%CALFRM-*-1_^1_(JMP*_$INDIR_^1*_]_^1* CALL IFRMAT FOR INITIALIZATION_^1* X AND H FIELDS ARE PROCESSED BY IFRMAT_^1*_]_^1CALFRM_!LDA*_$FLG_^1_(ARS_%9_^1_(AND_%=N1_^1_(STA*_$ROW_%0 FOR READ/1 FOR WRITE_^1_(LDA*_$FSAD_^1_(RTJ+_$Q8IGP_#INITIALIZ€€E FGETC/FPUTC_^1_(RTJ+_$Q8IFRM_.IFRMAT_^1ENTRY_"ADC_%ZERO_$ADDRESS OF Q8QINI ENT SW_^1_(ADC_%ROW_%ADDRESS OF R/W SWITCH_^1_(ADC_%LONL_$ADDRESS OF LIST/NO LIST S_^1_(JMP*_$INITC_^1INDIR_"LDA*_$(FSAD)_^1_%STQ* QSTEMP_J**FTN 3.0**_^1_%LDQ- $F6_*UPPER BANK NO RELATIVE ALLOWED_#**FTN 3.0**_^1_%SQM KG65K_K**FTN 3.0**_^1_%SAP KG65K_K**FTN 3.0**_^1_(ADD_%Q8QINI_^1_(AND*_$SVNF_^1KG65K LD€€Q* QSTEMP_J**FTN 3.0**_^1_(STA*_$FSAD_^1INDIRA_!JMP*_$CALFRM_^1FSAD_#NUM_%0_(FORMAT STATEMENT ADDRESS_^1ZERO_#NUM_%0_3ZERO_^1ROW_$NUM_%0_(0 FR READ/1 FOR WRITE_^1LONL_#NUM_%0_$0 FOR LIST/NOT 0 FOR NO LIST_^1B11_$NUM_%$0800_^1B10_$NUM_%$0400_^1B12_$NUM_%$1000_^1B13_$NUM_%$2000_^1B14_$NUM_%$4000_^1B15_$NUM_%$8000_^1*_]_^1* PASS FLAG TO TRANSMISSION ROUTINES_^1INITC_"LDA*_$FLG_^1_(RTJ€€+_$Q8QT0M_^1*_]_^1*_$CHECK STATUS FOR EOF IF READ REQUEST_^1*_*IF EOF, TURN ON BIT 12 IN UNIT TABLE_^1*_]_^1*_84 CARDS DELETED_^1_(LDA*_$FLG_IPSR 743_^1_(AND*_$B9_2IS THIS A WRITE_(PSR 743_^1_(SAN_%NOTMAG_.YES NO EOF CHECK_'PSR 743_^1_%RTJ* STATUS_*CHECK MAGT STATUS_^1_%AND* B11_-BIT 11 FOR EOF_^1_%SAZ 1_/NOT EOF-CONTINUE_^1_%JMP* EOF_-EOF_^1*_]_^1* FOR READ (U) AND READ (U,F) TER€€MINATE INPUT_^1NOTMAG_!LDA*_$LONL_^1_(SAZ_%NOLIST-*-1_^1_(JMP*_$OUT_^1NOLIST_!LDA*_$FLG_^1_(AND*_$B10_^1_(SAZ_%WRI-*-1_^1_(RTJ+_$Q8QEND_^1OUT_$LDA*_$T+2_^1_(STA-_$$FF_^1_(LDQ*_$T+1_^1_(RAO_%Q8QINI_^1_(JMP_%(Q8QINI)_^1*_'CHECK FOR FORMAT. NO FORMAT IS ERROR._^1* FOR WRITE (U,F) TERMINATE OUTPUT WITH Q8QEND_^1WRI_$LDA*_$FLG_^1_(AND*_$B14_%TEST FOR FORMAT_^1_(SAN_%2_+FORMAT_^1_(ENA_%€€11_'ERROR MESSAGE 11_^1_(JMP*_$ER+1_!NO FORMAT/ILLEGAL I/O_^1_(JMP*_$OUT-2_^1EOF_"LDA* B12_-EOF BIT_^1_%LDQ* UNIT_^1_%RTJ+ Q8QUN2_*STORE IN UNIT TABLE_^1_%JMP* OUT_^1*_]_^1* NEXT RECORD FOR FORMATTED I/O. FS CALLS SKIP WHEN A_^1* SLASH OCCURS IN THE FORMAT STATEMENT_^1*_]_^1*_]_^1SKIP_#NOP_%0_^1_(STQ*_$T+1_%SAVE Q_^1_(ENA_%0_^1_(RTJ+_$Q8CMP1_.CMPL1_^1_(LDQ*_$T+1_%RESTORE Q_^1_(JMP*€8_$(SKIP)_^1_(EQU_%Q8UNIT(UNIT),Q8SKIP(SKIP)_^1_(END_^__ 8PQ8QEND CSY/ H05 P€1_%NAM Q8QEND_'DECK-ID H05 FTN 3.3 RUNTIME_%SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3_^1*_$SMALL COMPUTER DEVELOPMENT DIVISION, LA JOLLA CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1973_^1_%SPC 2_^1* TERMINATE PRESENT I/O REQUEST_^1*_]_^1_(ENT_%Q8QEND_^1*_]_^1_(EXT_%Q8CMP1_.CMPL1_^1_(EXT_%Q8QUN1_^1_(EXT_%Q8QUN2_^1_(EXT_%Q8UNIT_.UNIT_^1_(EXT_%Q8DFAD_^1_%EXT Q€€8FS_P64*1343_^1* TERMINATE I/O_^1Q8QEND_!NOP_%0_^1_(LDQ+_$Q8UNIT_.UNIT_^1_(LDA*_$JMPIN_^1_(STA+_$Q8DFAD_#RESET DF ADDR_^1_(RTJ+_$Q8QUN1_"GET UNIT STATUS_^1_(AND_!=N$1000_%BIT 12 FOR END OF FILE_^1_(SAZ_!1_,NO EOF_^1_(JMP* (Q8QEND)_$EOF-IGNORE REQUEST_^1_(ENA_%1_^1_(RTJ+_$Q8CMP1_"FORMATTED CMPL1_^1* FLAG RETURNED FROM CMPL1_^1_(LDQ*_$(Q8QEND+2)_^1COMPL_"RTJ+_$Q8QUN2_^1*_$CLEAR ISF€fLG IN Q8FS_F64*1343_^1_%RTJ+ Q8FS_P64*1343_^1_%ADC JMPIN_O64*1343_^1_%ADC JMPIN_O64*1343_^1_%ADC JMPIN_O64*1343_^1_%ADC JMPIN_O64*1343_^1_%ADC IRF_Q64*1343_^1_%ADC JMPIN_O64*1343_^1_%ADC JMPIN_O64*1343_^1_%ADC JMPIN_O64*1343_^1_%ADC JMPIN_O64*1343_^1_%ADC JMPIN_O64*1343_^1_(JMP*_$(Q8QEND)_^1JMPIN_"JMP*_$*+2_^1IRF_"NUM $7FFF_O64*1343_^1_(END_^__ fPQ8CMP CSY/ H06 P€1_%NAM Q8CMP_(DECK-ID H06 FTN 3.3 RUNTIME_%SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3_^1*_$SMALL COMPUTER DEVELOPMENT DIVISION, LA JOLLA CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1973_^1_%SPC 2_^1*_'CMPL0/CMPL1_^1*_'CMPL0 INITIALIZES AN I/O REQUEST_^1*_'CMPL1 IMPLEMENTS AN I/O REQUEST_^1*_]_^1_(ENT_%Q8CMP0_.CMPL0_^1_(ENT_%Q8CMP1_.CMPL1_^1_(ENT_%Q8DFAD_^1_(EN€€T_%Q8QENS_^1_(ENT_%RECEND_^1*_]_^1_(EXT_%Q8EREM_.EREMSG_^1_(EXT_%Q8BEGB_.BEGBUF_^1_(EXT_%Q8LOCB_.LOCBUF_^1_(EXT_%Q8CLRB_.CLRBUF_^1_(EXT_%Q8RINT_.RINTBF_^1_(EXT_%Q8EOTT_^1_(EXT_%WRFLG_^1*_]_^1Q8DFAD_!JMP*_$CMPL0_^1_(SLS_%0_^1* CHECK UNIT RECORD TYPE_^1*_'ENTER WITH FLAG IN A, UNIT IN Q_^1CMPL0_"NOP_%0_^1_(STA*_$FLAG_^1_(STQ_%UNIT1_^1_(STQ*_$UNIT2_^1_(LDA*_$Q8DFAD_^1_(STA+_$CHEK-2_"€€SET UP SECTOR ADDR IF DISK_^1_(SUB_%=N$1802_^1_(SAN_%2_3SKIP IF DISK ADDR_^1_(STA_%Q8QENS_0IF NOT DISK CLEAR_^1_(LDA*_$Q8DFAD+1_^1_(STA+_$CHEK-1_^1_(CLR_%A_^1_(STA_%COUNT_^1_(STA_%TFLG_^1_%STA WRFLG_(CLEAR I/O FLAG IN Q8RWBU_^1*_]_^1* MAKE STATUS REQUEST_^1* SAVE EQUIPMENT TYPE_^1*_]_^1_(RTJ-_$($F4)_^1_(NUM_%$0600_^1UNIT2_"SLS_%0_^1_(SLS_%0_^1_(TRQ_%A_^1_%AND* EQPMSK_'EQUIPMENT CL€€ASS MASK $3800_^1_%ARS 11_^1_%STA* ECLASS_'EQUIPMENT CLASS_^1*_]_^1_(LDA*_$FLAG_$CHECK FO R FORMAT_^1_(AND*_$B14_^1_%SAZ T00001_^1_(LDA*_$UNIT2_#FORMAT_^1_(EOR*_$B12_^1_(STA_%UNIT1_/ASCII BIT ON IN UNIT_"PSR 743_^1T00001 LDA* FLAG_)CHECK READ OR WRITE_^1CK_%AND*_$B10_^1_(SAN_%RED-*-1_^1_(LDA*_$FWRITE_"WRITE_^1_%STA RQST_N68*1553_^1_(JMP*_$(CMPL0)_^1RED_$LDA*_$FREAD_#READ_^1_(JM€€P*_$CK+3_^1FREAD NUM $4801_K**FTN 3.0**_^1FWRITE NUM $4C01_K**FTN 3.0**_^1EQPMSK NUM $3800_(EQUIPMENT CLASS MASK_^1B10_$NUM_%$0400_^1B12_$NUM_%$1000_^1_(EQU_%B9A10(UNIT2-1)_^1_(BZS_%FLAG_^1ECLASS NUM 0_,SAVE FOR TYPE_8PSR 743_^1B14_$NUM_%$4000_^1*_]_^1* ENTRY FROM RWBUF, Q8QEND, AND FORMATTER_^1*_]_^1CMPL1_"NOP_%0_^1_(STA*_$ENDFLG_"Q8QEND INDICATOR_^1_(TRA_%Q_^1_(RTJ+_$Q8BEGB_€€.BEGBUF_^1_(STA_%LOC1_0BEG LOC OF BUFFER_^1* COMPUTE NR OF WORDS_^1_(RTJ+_$Q8LOCB_.LOCBUF_^1_(SUB_%LOC1_^1_(INA_%1_^1_(STA_%NR1_%NO OF WORDS IN BUFFER_^1_(TRA_%Q_^1_%LDA* ECLASS_MPSR 743_^1_%INA -1_+CHECK FOR MAG TAPE_^1_(SAN_%NOTMAG-*-1 NO_^1_(INQ_%-9_'YES. CHECK TRANSGER LENGT_^1_%SQP 2_RPSR 743_^1_(ENA_%9_(L. T. 9 WORDS IS ERROR_^1_(STA*_$NR1_^1_(RTJ_%Q8EOTT_"CHECK END OF MAG €€TAPE_^1NOTMAG LDA* ECLASS_'IS THIS A TTY_^1_%INA -6_^1_%SAZ TTY_^1_%JMP* NOTYPE_'NO TTY_^1TTY_"LDA* ENDFLG_^1_(SAZ_%TYPE-*-1 CALL FROM WRBUF OR BINBUF_^1_(LDA*_$FLAG_$CALL FROM Q8QEND_^1_(AND*_$B10_%TEST FOR READ_^1_(SAZ_%1_^1_(JMP*_$EXIT_^1TYPE_#RTJ*_$RORW_^1EXIT_#NOP_%0_^1*_]_^1*_'EXIT/RETURN WITH COMPOSITE I/O STATUS IN A_^1*_,FOR Q8QEND_^1*_]_^1_(LDA*_$ENDFLG_"NONZERO FOR Q8€€QEND_^1_(SAZ_%RETURN-*-1_^1_(LDA*_$FLAG_^1_(AND*_$B9A10_#BITS 9-10 FOR W/R_^1_(LDQ*_$TFLG_$I/O ERROR BITS 15,14,13_^1_(SQP_%RETURN-*-1 NO I/O ERROR_^1_(ARS_%3_(COMPENSATE_^1_(LLS_%3_(SHIFT ERROR BITS INTO A_^1RETURN_!JMP*_$(CMPL1)_^1*_]_^1*_'NON-TELETYPE I/O MEDIA_^1NOTYPE_!RAO*_$COUNT_#INCREASE PHYS REC COUNT_^1_(LDA*_$FLAG_$IS TJIS FORMAT I/O_^1_(AND*_$B14_^1_%SAZ 1_^1_%JMP* FOR€€M+1_^1*_]_^1* BINARY LOG REC ARE COMPPOSED OF 86 WORD PHYS REC_^1* WORD1 IS CONTROL WORD WITH LAST PHYS REC CONTROL WOR_^1* D = NUMBER OF PHYS REC IN LOG REC_^1*_]_^1_(LDA*_$LOC1_^1_(INA_%-1_^1_(STA*_$LOC1_$DECREASE LOC OF BUFFER_^1_(ENA_%86_^1_(LDQ*_$FLAG_^1_(QLS_%7_^1_(SQP_%1_)SKIP IF NOT DISK_^1_(ENA_%96_^1_(EQU_%FORM(*)_^1_(STA*_$NR1_^1KLUGA_#LDA*_#ENDFLG_^1_(SAZ_%1_^1_(JMP*_$E€€ND_1CALL FROM Q8QEND_^1WRBUF_"CLR_%A_^1_(LDQ*_$FLAG_$FORMAT_^1_(QLS_%1_^1_(SQM_%WRBUFA_.YES_^1_(STA*_$(LOC1)_^1_(LDQ*_$FLAG_0IS THIS A_^1_(QLS_%5_3IS THIS A READ REQUEST_^1_(SQM_%WRBUFA_.YES SKIP END OF RECORD TEST_^1_(QLS_%2_3NO IS IT A DISK REQUEST_^1_(SQP_%WRBUFA_.NO_^1_(LDA*_$RECEND_.CHECK FOR PAST END OF RECORD_^1_(INA_%-1_^1_(SUB*_$CHEK-1_^1_(SAP_%WRBUFA_^1_(JMP*_$KLUGE_^1WRB€€UFA_!RTJ*_$RORW_0I/O_^1_(JMP*_$EXIT_^1END_$LDA*_$FLAG_$IS THIS A READ_^1_(AND*_$B10_^1_(SAN_%1_(YES_^1_(JMP*_$WEND_$NO_^1REND_#LDA*_$FLAG_0CHECK FOR_^1_(ALS_%7_3MASS MEMEOY_^1_(SAP_%1_3NO_^1_(JMP*_$EXIT_0YES SKIP READ TO END_^1_(LDA*_$(LOC1)_.CHECK LOGICAL RECORD END_^1_(SAZ_%1_^1_(JMP*_$EXIT_$END OF LOGICAL RECORD_^1_(RTJ*_$RORW_$NOT END-CONTINUE READ_^1_(JMP*_$REND_^1WEND_#LDA*_$€€COUNT_^1_(LDQ*_$FLAG_$FORMAT_^1_(QLS_%1_^1_(SQM_%WENDA_^1_(STA*_$(LOC1)_^1_(LDQ*_$FLAG_0IS THIS A_^1_(QLS_%7_3DISK REQUEST_^1_(SQP_%WENDA_^1* 2 CARDS DELETED *** REMOVED TEST FOR MASS STORAGE I/O_^1_(LDA*_$RECEND_.CHECK FOR WRITE_^1_(INA_%-1_2BEYOND END OF REXORD_^1_%SUB*_$CHEK-1_^1_(SAP_%WENDA_/O K_^1_(JMP*_$KLUGE_/TOO_^1WENDA_"RTJ*_$RORW_^1_(JMP*_$EXIT_^1_(BZS_%TFLG_^1*_81 CARD €€DELETED_^1_(BZS_%ENDFLG_^1_(BZS_%Q8QENS_"HOLDS ENDING SECTOR ADDR FOR DISK_^1RECEND_!BZS_%RECEND_.ENDSEC+1 FOR RECORD_^1RORW_#NOP_%0_^1_(LDA*_$FLAG_^1_(AND*_$B10_^1_(SAN_%1_^1_(JMP*_$WRITE_^1READ_#RTJ+_$Q8CLRB_.CLRBUF_^1_(RTJ+_$Q8RINT_.RINTBF_^1_(ENA_%96_'ALL FORMAT READS ARE_^1_(STA*_$NR1_%SHORT TRANSFERS_^1_(RTJ*_$RQST1_^1_(JMP*_$(RORW)_^1WRITE_"RTJ*_$RQST1_^1_(RTJ*_$(READ+1) CL€€EAR BUFFER_^1_(RTJ*_$(READ+3) REINITIALIZE BUFFER_^1_(JMP*_$(RORW)_^1* OUTPUT BUFFER ON DEVICE_^1RQST1_"NOP_%0_^1*_82 CARDS DELETED_368$1553_^1_(RTJ-_$($F4)_^1RQST_#SLS_%0_^1COMP1 ADC 0_,COMPLETION ADDRESS_268*1553_^1THRD_!ADC 0_,THREAD WORD_968*1553_^1UNIT1_"SLS_%0_^1NR1_$SLS_%0_^1LOC1_#SLS_%0_^1_(SAZ_%1_)WILL CONTAIN SECTOR ADDR IF DISK_^1_(SLS_%0_^1CHEK_!LDA* THRD_N68*1553_^€€1_%SAZ OUTLOP_L68*1553_^1_(JMP*_$CHEK_^1OUTLOP LDQ* UNIT1_(TEST FOR ERROR_470*1606_^1_%SQP NOEROR_J70*1606_^1_%STQ* TFLG_)SAVE ERROR FLAG_370*1606_^1NOEROR LDA* Q8QENS_'ENDING SECTOR NUMBER FOR DISK_$70*1606_^1_(SAN_%1_(SKIP IF DISK I/O_^1_(JMP*_$(RQST1)_!NOT DISK - EXIT_^1_(LDA*_$CHEK-1_^1_(INA_%1_(BUMP FOR NEXT READ OR WRITE_^1_(SAP_%3_^1_(AND_%=N$7FFF_^1_(RAO*_$CHEK-2_"BUMP HI€hGH ORDER ADDR_^1_(STA*_$CHEK-1_^1_(SUB*_$Q8QENS_^1_(SAZ_%1_(OK IF ZERO_^1_(SAP_%1_(SKIP IF OUT OF RANGE_^1_(JMP*_$(RQST1)_^1KLUGE_"ENA_%19_^1_(RTJ+_$Q8EREM_^1_(JMP*_$EX19_^1*_]_^1*_]_^1*_83 CARDS DELETED_368*1553_^1EX19_#RTJ-_$($F4)_$EXIT REQUEST_^1_(NUM_%$0A00_^1*_]_^1*_81 CARD DELETED_468*1553_^1_(BZS_%COUNT_^1_(EQU_%Q8CMP0(CMPL0),Q8CMP1(CMPL1)_^1_(END_^__hPQ8RWBU CSY/ H07 P€1_%NAM Q8RWBU_'DECK-ID H07 FTN 3.3 RUNTIME_%SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3_^1*_$SMALL COMPUTER DEVELOPMENT DIVISION, LA JOLLA CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1973_^1_%SPC 2_^1_(ENT_%Q8BINB_.BINBUF_^1_(ENT_%Q8LOCB_.LOCBUF_^1_(ENT_%Q8RWBU_.RWBUF_^1_(ENT_%Q8INTB_.INTBUF_^1_(ENT_%Q8BEGB_.BEGBUF_^1_(ENT_%Q8CLRB_.CLRBUF_^1_(ENT_%Q8RINT_.RINTB€€F_^1_(ENT_%Q8IBUF_.IBUF_^1_(ENT_%WRFLG_GPSR 501_^1*_]_^1_(EXT_%Q8CMP1_.CMPL1_^1_(EXT_%Q8EREM_.EREMSG_^1*_]_^1*_]_^1* INITIALIZATION_^1* CALLING SEQUENCE_^1* RTJ INTBUF_^1* FLAG WORD IN A REGISTER_^1* INITIALIZATION-_^1*_'1. CLEAR COUNTERS AND SET UP BUFFER SIZE_^1*_'2. BACKGROUND BUFFER_^1*_'3. IF READ, INPUT 1ST PHYSICAL RECORD_^1*_]_^1INTBUF_!NOP_%0_^1_(STA*_$FLAGW_#FLAG WORD_^1_€€(CLR_%A_^1_(STA*_$DISKFL_#CLEAR DISK FLAG_^1_(STA*_$SAVQ_$CLEAR BUFFER INCREMENT_^1_(STA*_$II_'CLEAR WORD COUNTER_^1_(STA*_$CC_'CLEAR CHARACTER COUNTER_^1_(STA*_$RWF_%CLEAR RWBUF WRITE FLAG_^1_(LDA_%=XBUFFER+1_^1_(STA*_$LOC_%LOCATION OF BUFFER WRD 1_^1_(LDA*_$FLAGW_^1_(ALS_%7_^1_(SAP_%3_)SKIP IF NOT DISK_^1_(ENA_%96_(96 MAX FOR DISK_^1_(STA*_$DISKFL_#SET DISK FLAG_^1_(JMP*_$*+2_^1_€€(ENA_%86_'NOMINAL 86 WORD BUFFER_^1_(LDQ*_$FLAGW_#CHECK FORMAT REQUEST_^1_(QLS_%1_^1_%SQP INTBF1_'NO FORMAT_^1_%ENA 68_^1INTBF1 STA* LNGTH_^1_(RTJ*_$CLRBUF_"BACKGROUND BUFFER_^1_%LDA* FLAGW_^1_)AND*_$B10_^1_(SAZ_%OUT-*-1_!NO, EXIT._^1_(LDA*_$LNGTH_#YES, INITIALIZE COUNTER_^1_(STA*_$II_'FOR INPUT OF 1ST RECORD_^1_(CLR_%A_^1_(RTJ+_$Q8CMP1_"INPUT 1ST PHYSICAL RECORD_^1OUT_$NOP_%0_^1€€_(JMP*_$(INTBUF)_^1*_]_^1*_]_^1_(BZS_%T1_^1*_]_^1*_]_^1*_]_^1* RETURN LOC OF INPUT FIELD_^1* IN A REGISTER_^1*_]_^1LOCBUF_!NOP_%0_^1_(LDA*_$II_^1_(LDQ*_$CC_^1_(ADD*_$LOC_^1_(JMP*_$(LOCBUF)_^1*_]_^1* RETURN WITH BUFFER STARTING LOCATION IN A_^1*_]_^1BEGBUF_!NOP_%0_^1_(LDA*_$LOC_^1_(JMP*_$(BEGBUF)_^1*_]_^1* CLEAR BUFFER AREA OR, IF FORMAT, BACKGROUND WITH BLK_^1*_]_^1CLRBUF_!NOP_%0_^€€1_(ENQ_%-96_^1_(LDA*_$FLAGW_#CHECK FOR FORMAT_^1_(ALS_%1_(BIT 14 ON FOR FORMAT_^1_(SAP_%S-*-2_#NO FORMAT_^1_(LDA_%=N$2020_!FORMAT. BACKGROUNT W/BLNK_^1_(JMP*_$*+2_^1_(CLR_%A_(BACKGROUND WITH ZEROS_^1S_'STA_%BUFFER+96,Q_^1_(INQ_%1_^1_(SQZ_%1_^1_(JMP*_$S_^1_(JMP*_$(CLRBUF)_^1*_]_^1* REINITIALIZE BUFFER_^1*_]_^1RINTBF_!NOP_%0_^1_(CLR_%A_(CLEAR_^1_(STA*_$II_'WORD COUNTER_^1_(STA*_$SAVQ€€_$BUFFER POINTER_^1_(STA*_$CC_'CHARACTER COUNTER_^1_(JMP*_$(RINTBF)_^1* COMMON STORAGE_^1_(BZS_%ADR_^1B9_%NUM_%$0200_^1B10_$NUM_%$0400_^1_(BZS_%FLAGW_^1_(BZS_%LOC_^1_(BZS_%LNGTH_^1_(BZS_%SAVQ_^1_(BZS_%II_^1_(BZS_%DISKFL_^1SVNFFF_!NUM_%$7FFF_^1_(BZS_%CC_'CHARACTER COUNTER_^1_(BZS_%T2(3)_^1_(BZS_%AIBUF_^1_(BZS_%WRFLG_GPSR 501_^1*_]_^1*_]_^1*_'RWBUF_#READ AND WRITE FORMATTED DATA_^1*_€€1CALLING SEQUENCE_^1*_1CALL RWBUF(CHAR)_^1*_;CHAR IS THE LOCATION OF_^1*_;THE CHARACTER TO STUFF_^1*_;OR THE ADDRESS OF THE_^1*_;CHARACTER TO BE READ._^1*_1WHEN A PHYSICAL RECORD IS EXHAUST-_^1*_1ED, A NEW BUFFER IS INPUT OR OUTPT_^1*_]_^1*_]_^1*_]_^1* ENTRY FROM CONVERSIONS_^1*_]_^1* B10 SET, READ_^1* B9 SET, WRITE_^1*_]_^1RWBUF_"NOP_%0_^1_(STQ*_$T2+1_^1_(LDA-_$$FF_^1_(STA*_$T2+2€€_^1_(LDA*_$(RWBUF)_!ADDRESS OF CHARACTER_^1SADR_#STA*_$AIBUF_#STORE ABSOLUTE ADR OF CHR_^1_(LDA*_$FLAGW_^1_(AND*_$B10_^1_(SAN_%READ-*-1_^1_(JMP*_$WRITE_#WRITE_^1*_]_^1*_'READ A CHARACTER FROM BUFFER_^1*_]_^1READ_#LDQ*_$CC_'CHARACTER COUNTER_^1_(LRS_%1_(BUFFER INCREMENT IN Q_^1_(STQ*_$II_'WORD COUNTER_^1_(SAM_%3_(A - MEANS RIGHT CHAR_^1_)LDA*_$BUFFER+1,Q A+MEANS LEFT CHAR_^1_(ARS_%8€€_(RIGHT ADJUST_^1_(JMP*_$*+2_^1_)LDA*_$BUFFER+1,Q_^1CONST_"AND_%=N$FF_#STRIP ALL BUT RT 8 BITS_^1_(TRA_%Q_(IF CHAR IS $FF,SET TO_^1_(SUB*_$CONST+1_!BLANK. THE I/O DRIVER_^1_(SAN_%1_(INPUTS $FF WHEN TERMINA-_^1_(ENQ_$$20_'TION OCCURS ON A HALFWORD_^1_(STQ*_$(AIBUF)_!STORE CHARACTER IN ADR_^1BUMP_#RAO*_$CC_'BUMP CHARACTER COUNTER_^1_$LDA_!=N136_^1_%SUB* CC_^1_%SAP 1_RPSR 672_^1_(JM€€P*_$OV_'TOO MANY CHAR_^1RWX_$RAO*_$RWBUF_^1_(LDA*_$T2+2_$RESTORE REGISTERS_^1_(STA-_$I_^1_(LDQ*_$T2+1_^1_(JMP*_$(RWBUF)_^1*_]_^1* MORE THAN 120 CHARACTERS INPUT IS FATAL ERROR 12_^1* DITTO OUTPUT RESULTS IN TRUCATED WRITE_^1*_]_^1OV_%LDA*_$FLAGW_^1_(AND*_$B9_^1_(SAZ_%2_^1_(STA*_$RWF_%SET WRITE OVERFLOW FLAG_^1_(JMP*_$RWX_^1_(ENA_%12_'ERROR MSG 12_^1_(RTJ+_$Q8EREM_.EREMSG_^1_(RTJ-_€€$($F4)_^1_(NUM_%$0A00_#TERMINATE_^1_(BZS_%RWF_^1*_]_^1*_'WRITE - STUFF A CHARACTER INTO BUFFER_^1*_]_^1WRITE_"EQU_%WRITE(*)_^1_(LDA*_$RWF_%120 CHAR EXCEEDED_^1_(SAZ_%1_(NO_^1_(JMP*_$RWX_%YES - IGNORE CHARACTER_^1_(LDQ*_$CC_'CHARACTER COUNTER_^1_(LRS_%1_(BUFFER INCREMENT IN Q_^1_(STQ*_$II_'WORD COUNTER_^1_(SAM_%RIGHT-*-1 A - MEANS RIGHT CHAR_^1_(TRQ_%A_^1_%INA -69_*TRUNCATE AT 68 W€€ORDS_^1_%SAM WRITE1_'PLACE CHARACTER IN BUFFER_^1_%ENQ 68_+ADJUST WORD COUNT TO 68_^1_%STQ* II_^1_%JMP* BUMP_^1WRITE1 LDA* BUFFER+1,Q_"A+ MEANS LEFT CHAR_^1_(AND*_$CONST+1_!STRIP OFF LEFT 8 BITS_^1_)STA*_$BUFFER+1,Q STORE BACK IN BUFFER_^1_(LDA*_$(AIBUF)_!PICK UP CHAR FROM ADR_^1_(ALS_%8_(LEFT ADJUST_^1_)EOR*_$BUFFER+1,Q OR IN RIGHT CHAR_^1_)STA*_$BUFFER+1,Q STORE BACK IN BUFFER_€€^1_(JMP*_$BUMP_^1RIGHT_#LDA*_$BUFFER+1,Q_^1_(AND_%=N$FF00_!STRIP OFF RIGHT 8 BITS_^1_(EOR*_$(AIBUF)_!OR IN RIGHT CHAR_^1_(JMP*_$RIGHT-2_^1*_]_^1* BINARY INPUT/OUTPUT_^1*_]_^1BINBUF_!NOP_%0_^1_(LDQ*_$SAVQ_^1_(STA*_$ADR_^1IOCHK LDA* WRFLG_(IF WRFLG ZERO DO NOT I/O THE BUFFER_^1_%SAZ SKIPIO_^1_%CLR A_^1_%STA* WRFLG_^1_%RTJ+ Q8CMP1_'I/O PHYSICAL RECORD_^1SKIPIO LDA* (ADR)_^1_%LDQ* S€€AVQ_^1_(LDA*_$FLAGW_^1_(AND*_$B10_^1_(SAN_%BREAD-*-1_^1BWRITE_!LDA*_$(ADR)_#ELEMENT INTO BUFFER_^1_(STA*_$(LOC),Q_^1_(JMP*_$EXIT_^1BREAD_"LDA*_$(LOC),Q_!BUFFER WORD INTO ELEMENT_^1_(STA*_$(ADR)_^1EXIT_#RAO*_$II_'BUMP WORD COUNTER_^1_(RAO*_$SAVQ_$BUMP POINTER_^1_(LDA*_$DISKFL_^1_(SAZ_%2_(SKIP IF NOT DISK_^1_(ENA_%95_^1_(JMP*_$*+2_^1_%ENA 85_QPSR 554_^1*_#CHECK FOR BUFFER FULL_^1_(S€rUB*_$SAVQ_^1_%SAN BINRTN_'SKIP BUFFER NOT FULL_^1_%ENA 1_,BUFFER FULL SET FLAG TO DO I/O_^1_%STA* WRFLG_^1BINRTN JMP* (BINBUF)_^1_%BZS_%BUFFER(97)_DPSR 932_^1_(EQU_%IBUF(BUFFER)_^1_(EQU_%Q8BINB(BINBUF)_%BINBUF_^1_(EQU_%Q8LOCB(LOCBUF)_%LOCBUF_^1_(EQU_%Q8RWBU(RWBUF),Q8INTB(INTBUF)_^1_(EQU_%Q8BEGB(BEGBUF),Q8CLRB(CLRBUF)_^1_(EQU_%Q8RINT(RINTBF),Q8IBUF(IBUF)_^1_(END_^__ rPQ8ERRM CSY/ H08 P€1_%NAM Q8ERRM_'DECK-ID H08 FTN 3.3 RUNTIME_%SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3_^1*_$SMALL COMPUTER DEVELOPMENT DIVISION, LA JOLLA CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1973_^1_%SPC 2_^1_(ENT_%Q8ERRM_.ERRMSG_^1_(ENT_%Q8FERM_.FERMSG_^1_(ENT_%Q8EREM_.EREMSG_^1*_]_^1_(EXT_%Q8LOCF_.LOCFRM_^1_(EXT_%Q8LOCB_.RWBUF_^1*_]_^1* ENTER FROM Q8QINI_^1*_"THE FIR€€ST NUMBER IS EXAMINED AS A FLAG WORD_^1*_"I/O RQST NR IN A REGISTER_^1*_"UNIT NR IN Q REGISTER_^1*_]_^1ERRMSG_!NOP_%0_^1_(STQ*_$TEMP_^1*_]_^1* CONVERT NUMBERS FROM BINARY TO ASCII_^1* ASSUME I/O RQST NUMBER AND UNIT IS POSITIVE_^1*_!AND LESS THAN 32768 BASE 10_^1*_]_^1_(RTJ*_$CNVT_^1_(STA*_$N_^1_(STQ*_$N+1_^1_(LDA-_$$FF_^1_(STA*_$N+2_^1_(LDA*_$TEMP_^1_(RTJ*_$CNVT_^1_(STA*_$UNIT_^1_€€(STQ*_$UNIT+1_^1_(LDA-_$$FF_^1_(STA*_$UNIT+2_^1_(JMP*_$(ERRMSG)_^1*_]_^1* CONVERT BINARY NUMBER TO ASCII CODE_^1* RETURN ASCII CODE IN A,Q, AND I_^1* DOES NOT PRESERVE REGISTERS_^1*_]_^1CNVT_#NOP_%0_^1_(STA*_$BINARY_^1_(LDA*_$SP_^1_(STA*_$TEMP3_^1_(ENQ_%1_^1_(STQ*_$RORL_^1_(ENQ_%-5_^1_(STQ-_$$FF_^1_(CLR_%Q_^1_(STQ*_$COUNT_^1_(STQ*_$CNTR_^1REPEET_!LDA*_$BINARY_^1_(CLR_%Q_^1_(DVI*_$T€€ENS+5,I_^1_(STA*_$COUNT_^1_(STQ*_$BINARY_^1_(RAO-_$$FF_^1STORE_"LDQ*_$RORL_^1_(SQZ_%1_^1_(JMP*_$SRIGHT_^1SLEFT_"RAO*_$RORL_^1_(LDA*_$COUNT_^1_(ADD*_$LTHRE_^1_(ALS_%8_^1_(STA*_$TEMP3_^1_(JMP*_$REPEET_^1*_]_^1SRIGHT_!CLR_%Q_^1_(STQ*_$RORL_^1_(LDQ*_$CNTR_^1_(LDA*_$COUNT_^1_(ADD*_$LTHRE_^1_(ADD*_$TEMP3_^1_(STA*_$TEMP1,Q_^1_(RAO*_$CNTR_^1_(LDA-_$$FF_^1_(INA_%0_^1_(SAZ_%1_^1_(JMP*_$REPEE€€T_^1_(LDA*_$TEMP1+2_^1_(STA-_$$FF_^1_(LDA*_$TEMP1_^1_(LDQ*_$TEMP1+1_^1_(JMP*_$(CNVT)_^1LTHRE_"NUM_%$0030_^1_(BSS_%TEMP3_^1SP_%NUM_%$2000_^1_(BSS_%BINARY_^1_(BSS_%CNTR_^1_(BSS_%COUNT_^1_(BSS_%RORL_^1TENS_#NUM_%10000,1000,100,10,1_^1_(BSS_%TEMP(2)_^1_(BSS_%TEMP1(3)_^1*_]_^1*_]_^1* ENTER FROM CONVERSION ROUTINES_^1*_]_^1FERMSG_!NOP_%0_^1_(SET_%A_^1_(STA*_$ENTER_^1_(LDA*_$(FERMSG) LOC€€ OF NR_^1_%STQ* TEMP2+1_%SAVEQ_^1_%LDQ- $F6_*HIGHEST UNPROTECTED LOC + 1_^1_%INQ -1_+CHECK IF IN UPPER BANK_^1_%SQM POS_*IF SO, NO RELATIVE ALLOWED_^1_(SAP_%POS-*-1_^1_(ADD*_$FERMSG_^1_%AND- $11_*$7FFF_^1POS_$STA*_$LOC_^1_%LDQ* TEMP2+1_%RESTORE Q_^1_(RAO*_$FERMSG_^1_(LDA*_$(LOC)_^1_(STA*_$NUM_^1_(JMP*_$COMMON_^1EREMSG_!NOP_%0_^1_(STA*_$NUM_^1_(CLR_%A_^1_(STA*_$ENTER_^1COMMON_!STQ€€*_$TEMP2+1_^1_(LDA-_$$FF_^1_(STA*_$TEMP2+2_^1_(LDQ*_$NUM_^1_(JMP*_$EM-1,Q_"TO PROPER ERROR MESSAGE_^1MSG1_#ALF_%6,I/O REQUEST_^1_(BZS_%N(3)_^1_(BSS_%UNIT(3)_^1NUM_$ALF_%3,_^1EM_%JMP*_$ETYP1_#1_^1_(JMP*_$ETYP2_#2_^1_(JMP*_$ETYP2_#3_^1_(JMP*_$ETYP3_#4_^1_(JMP*_$ETYP3_#5_^1_(JMP*_$ETYP3_#6_^1_(JMP*_$ETYP3_#7_^1_(JMP*_$ETYP3_#8_^1_(JMP*_$ETYP3_#9_^1_(JMP*_$ETYP3_#10_^1_(JMP*_$ETYP3_#11€€_^1_(JMP*_$ETYP1_#12_^1_(JMP*_$ETYP1_#13_^1_(JMP*_$ETYP3_$14_^1_(JMP*_$ETYP3_$15_^1_(JMP*_$ETYP3_$16_^1_(JMP*_$ETYP3_$17_^1_(JMP*_$ETYP3_$18_^1_(JMP*_$ETYP3_#19_^1*_]_^1* TYPE 1 ERROR MESSAGE_^1*_]_^1* N_]_^1* I/O RQST N_^1* FFFF_]_^1*_]_^1ETYP1_"RTJ*_$TM0_%TYPE NUMBER_^1_(RTJ*_$TM1_%TYPE MSG1_^1_(RTJ*_$TFORM_#TYPE FORMAT_^1_(JMP*_$EXIT_^1*_]_^1* TYPE 2 ERROR MESSAGE_^1*_]_^1* N_]€€_^1* I/O RQST N_^1* FFFF_]_^1* GGGG_]_^1*_]_^1ETYP2_"RTJ*_$TM0_^1_(RTJ*_$TM1_%TYPE MSG1_^1_(RTJ*_$TFORM_#TYPE FORMAT_^1_(RTJ*_$TIFLD_#TYPE INPUTFLD_^1_(JMP*_$EXIT_^1*_]_^1* TYPE 3 ERROR MESSAGE_^1*_]_^1* N_]_^1* I/O RQST N_^1* UNIT NUMBER_^1*_]_^1ETYP3_"RTJ*_$TM0_^1_(RTJ*_$TM1_^1_(RTJ*_$TM2_^1_(JMP*_$EXIT_^1*_]_^1*_;CARRIAGE RETURN_^1*_;LINE FEED_^1*_;TYPE ERROR NUMBER_^1TM0_$NOP€€_%0_^1_(LDA*_$NUM_^1_(RTJ_%CNVT_^1_(STA*_$NUM_^1_(STQ*_$NUM+1_^1_(LDA-_$$FF_^1_(STA*_$NUM+2_^1_(ENA_%3_^1_(STA*_$NR_^1_(LDA_%=XNUM_^1_(STA*_$LOC_^1_(RTJ*_$RQST_^1*_81 CARD DELETED_468*1554_^1_(JMP*_$(TM0)_^1*_]_^1*_;TYPE_^1*_;CARIAGE RETURN, LINE FEED_^1*_;MSG1_^1TM1_$NOP_%0_(TYPE MSG1_^1_(LDA_%=XMSG1_^1_(STA*_$LOC_^1_(ENA_%9_^1_(STA*_$NR_^1_(RTJ*_$RQST_^1*_81 CARD DELETED_468*1554€€_^1_(JMP*_$(TM1)_^1*_]_^1*_]_^1*_;TYPE_^1*_:CARRIAGE RETURN_^1*_;LINE FEED_^1*_;UNIT NUMBER_^1TM2_$NOP_%0_(TYPE UNIT_^1_(LDA_%=XUNIT_^1_(STA*_$LOC_^1_(ENA_%3_^1_(STA*_$NR_^1_(RTJ*_$RQST_^1*_81 CARD DELETED_468*1554_^1_(JMP*_$(TM2)_^1*_]_^1*_;TYPE_^1*_;CARRIAGE RETURN, LINE FEED_^1*_;FORMAT_^1TFORM_"NOP_%0_(TYPE CHARACTER COUNTER_^1_(RTJ+_$Q8LOCF_.LOCFRM_^1* RETURNS CHARACTER COUNTE€€R IN FORMAT STATEMENT_^1_(STA*_$NUM_^1_(RTJ*_$TM0_^1_(JMP*_$(TFORM)_^1*_81 CARD DELETED_468*1554_^1*_]_^1*_;TYPE_^1*_;CARRIAGE RETURN, LINE FEED_^1*_;INPUT FIELD TO CR_^1TIFLD_"NOP_%0_(TYPE INPUT FIELD CC_^1_(RTJ+_$Q8LOCB_.LOCBUF_^1_(STQ*_$NUM_%CHARACTER COUNTER IN INP_^1_(RTJ*_$TM0_%FIELD_^1_(JMP*_$(TIFLD)_^1_(BSS_%ENTER_^1_(BSS_%TEMP2(3)_^1*_]_^1*_]_^1RQST_#NOP_%0_^1*_82 CARDS DE€€LETED_368*1554_^1_(RTJ-_$($F4)_^1REQ_"NUM $4C00_(FORMAT WRITE_6**FTN 3.0**_^1_%ADC 0_,COMPLETION ADDRESS_268*1554_^1THRD_!NUM 0_,THREAD_>68*1554_^1LU_#NUM $18FB_(STD PRINT DEVICE_2**FTN 3.0**_^1NR_%NOP_%0_3NR OF WORDS_^1LOC_$SLS_%0_3STARTING ADR_^1THDLOP LDA* THRD_N68*1554_^1_%SAZ OUTLOP_L68*1554_^1_%JMP* THDLOP_L68*1554_^1OUTLOP JMP* (RQST)_L68*1554_^1*_]_^1*_]_^1*_]_^1*_]_^1€Ä*_]_^1EXIT_#LDA*_$TEMP2+2_^1_(STA-_$$FF_^1_(LDQ*_$TEMP2+1_^1_(LDA*_$ENTER_^1_(SAZ_%2_^1_(JMP_%(FERMSG)_^1_(JMP_%(EREMSG)_^1_(EQU_%Q8FERM(FERMSG),Q8ERRM(ERRMSG)_^1_(EQU_%Q8EREM(EREMSG)_^1_(END_^__ ÄPQ8DFIO CSY/ H09 P€1_%NAM Q8DFIO_'DECK-ID H09 FTN 3.3 RUNTIME_%SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3_^1*_$SMALL COMPUTER DEVELOPMENT DIVISION, LA JOLLA CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1973_^1_%SPC 2_^1_(ENT_%Q8DFNF_^1_(ENT_%Q8DFIN_^1_(EXT_%Q8ERRM_^1_(EXT_%Q8EREM_^1_(EXT_%Q8QINI_^1_(EXT_%Q8DFAD_^1_(EXT_%Q8QENS_^1_(EXT_%RECEND_^1* OPEN ROUTINE_^1*_]_^1* CALLING SE€€QUENCE_^1*_!RTJ Q8DFNF_^1*_!I/O REQUEST NUMBER_^1*_!ADDRESS OF FILE NUMBER_^1*_!ADDRESS OF NUMBER OF SECTORS PER RECORD_^1*_!ADDRESS OF NUMBER OF RECORDS PER FILE_^1*_!ADDRESS OF DISK LOGICAL UNIT NUMBER_^1*_!ADDRESS OF STARTING SECTOR NUMBER_^1*_]_^1*_!TWO DISK CAPABILITY_HPSR 385_^1*_] PSR 385_^1Q8DFNF_!NOP_%0_^1_(STQ*_$SAVEQ_^1_(LDA-_$$FF_^1_(STA*_$SAVEQ+1_^1_(LDA*_$(Q8DFNF) G€€ET I/O REQUEST NUMBER_^1_(STA*_$SECT_^1_(RAO*_$Q8DFNF_^1_(RTJ*_$GETP_%GET FILE NUMBER_^1_%RTJ* ER2CHK_^1_(STA*_$FILE_^1_(TRA_%Q_^1_(LDA*_$SECT_^1_(RTJ+_$Q8ERRM_"INITIALIZE ERROR MESSAGE_^1_(LDQ*_$START_^1_(SQN_%NTFT_%SKIP IF NOT FIRST TIME_^1_(CLR_%A_^1_(RTJ-_$($F4)_^1_(NUM_%$1600_$GET AVAILABLE CORE (CORE)_^1_(INA_%-1_^1_(INQ_%1_)ADJUST TO AVAIL LOC_^1_(STA*_$HIGH_0HIGH LIMIT_^1_€€(STQ*_$AVSP_0LOW LIMIT_^1_(STQ*_$START_$START OF TABLE_^1NTFT_#TRQ_%A_^1_(SUB*_$AVSP_^1_(SAZ_%ENTER_^1_(LDA*_$FILE_%FILE NUMBER FROM CALL_^1_(SUB*_$(STZR+1),Q FILE NUMBER FROM TABLE_^1_(INQ_%5_^1_(SAZ_%1_^1_(JMP*_$NTFT_^1_(ENA_%14_(IF SAME IS ERROR TYPE 1_^1_(JMP*_$EREX_^1ENTER_"LDA*_$FILE_^1STZR_#STA+_$0,Q_'STORE FILE IN FILE TABLE_^1_(INQ_%1_^1_(RTJ*_$GETP_$GET SECTORS PER RECORD€€_^1_%RTJ* ER2CHK_^1_(STA*_$SECT_^1_(STA*_$(STZR+1),Q_!TO TABLE_^1_(INQ_%1_^1_(STQ*_$FILE_%SAVE Q_^1_(RTJ*_$GETP_'GET RECORDS PER FILE_^1_%RTJ* ER2CHK_^1_(MUI*_$SECT_^1_(SQN_%2_(ERROR IF GT 32K_^1_(SAZ_%1_)ERROR IF ZERO_^1_(SAP_%1_^1_(JMP*_$ERR3_$ERROR - SECTOR ADDR TOO BIG_^1_(LDQ*_$FILE_^1_(STA*_$SECT_%TOTAL NUMBER OF SECTORES RESERVED_^1_(RTJ*_$GETP_%GET LOGICAL UNIT NBR_^1_%RTJ*€€ ER2CHK_^1_(STA*_$(STZR+1),Q STORE IN TABLE_^1_(STA*_$LUN_^1_(RTJ-_$($F4)_$STATUS_^1_(NUM_%$0600_^1LUN_$SLS_%0_^1_(SLS_%0_^1_%TRQ A_RPSR 1082_^1_%AND- $10_PPSR 1082_^1_%ARS 11_QPSR 1082_^1_%INA -2_QPSR 1082_^1_%SAZ 2_,SKIP IF MASS STORAGE DEVICE_*PSR 1082_^1ERR18_"ENA_%18_(NOT DISK OR DRUM UNIT_^1_(JMP*_$EREX_^1_(RTJ*_$GETP_%GET X PARAMETER - STARTING SECTOR_^1_%SAZ_%KLUG1_(SK€€IP IF NONE SPECIFIED_*PSR 385_^1_%STA*_$CPAR_JPSR 385_^1_%LDA_%=XCPAR_'SET POINTER TO SPECIFIED ADDRESS PSR 385_^1_%JMP* KLUG3_NPSR 385_^1KLUG1 LDA*_$LUN_+FIND LOGICAL UNIT NUMBER_(PSR 385_^1_%SUB- $C2_*LIBRARY DISK_9PSR 1053_^1_%SAZ_%KLUG2_(SKIP IF DISK1_3PSR 385_^1_%LDA_%=XXPAR2_%SET POINTER TO DISK2_,PSR 385_^1_%JMP*_$KLUG3_IPSR 385_^1KLUG2 LDA_%=XXPAR1_%SET POINTER TO DISK1_,P€€SR 385_^1KLUG3 STA*_$XPTR_)ADDRESS OF STARTING SECTOR ADDR. PSR 385_^1_%LDA*_$(XPTR)_'STARTING SECTOR ADDRESS_)PSR 385_^1_(LDQ*_$FILE_%GET INDEX NBR_^1_(INQ_%1_^1_(STA*_!(STZR+1),Q_"TO TABLE_^1_(INQ_%1_^1_(ADD*_$SECT_^1_(SAM_%ERR3_$SKIP IF TOO LARGE_^1_%STA*_$(XPTR)_'NEW AVAILABLE SECTOR ADDRESS_#PSR 385_^1_(STA*_$(STZR+1),Q SAVE ENDING SECTOR_^1_(INQ_%1_^1_(LDA*_$HIGH_^1_(STQ*_$€€AVSP_^1_(RTJ-_$($F4)_^1_(NUM_%$1600_$RESERVE CORE FOR TABLE_^1_(LDQ*_$SAVEQ_^1_(LDA*_$SAVEQ+1_^1_(STA-_$$FF_^1_(JMP*_$(Q8DFNF)_!EXIT_^1ERR3_#ENA_%16_^1_(JMP*_$EREX_^1SAVEQ_"NUM_%0,0_^1START_"NUM_%0_^1HIGH_#NUM_%0_^1AVSP_#NUM_%0_^1FILE_#NUM_%0_^1SECT_#NUM_%0_^1XPAR1 NUM_%1_,DISK1 NEXT AVAIL SECTOR ADDRESS PSR 385_^1XPAR2 NUM_%1_,DISK2 NEXT AVAIL SECTOR ADDRESS PSR 385_^1XPTR_!NU€€M_%0_,APPROPRIATE XPAR_0PSR 385_^1CPAR_!NUM_%0_,ACTUAL ADDRESS PROVIDED_)PSR 385_^1TEMP_#NUM_%0_^1ENDSEC_!NUM_%0_^1GETP_#NOP_%0_)GET_^1_(LDA*_$(Q8DFNF)_^1_%STQ* Q65K_P64*1389_^1_%LDQ- $F6_*CHECK IF IN UPPER BANK_064*1389_^1_%SQM DLBL_)IF SO, NO RELATIVE ALLOWED_,64*1389_^1_(SAP_%DLBL-*-1_^1_(ADD*_$Q8DFNF_^1_%AND- $11_*$7FFF_A64*1389_^1DLBL_#STA*_$TEMP_^1_%LDQ* Q65K_P64*1389_^1_(LD€€A*_$(TEMP)_^1_(RAO*_$Q8DFNF_^1_(SAM_%ERR2_^1_(JMP*_$(GETP)_^1ERR2_#ENA_%15_'BAD PARAMETER_^1_(JMP*_$EREX_^1ER2CHK NOP 0_^1_%SAN NOERR_^1_%JMP* ERR2_^1NOERR JMP* (ER2CHK)_^1* INITIALIZATION FOR I/O_^1*_]_^1* CALLING SEQUENCE_^1*_!RTJ Q8DFIN_^1*_%A CONTAINS FILE NUMBER_!Q CONTAINS FLAG WORD SHIFTED 7 LEFT_^1*_]_^1Q8DFIN_!NOP_%0_^1_(STQ*_$SAVEQ_^1_(STA*_$FILE_^1_(LDQ*_$START_^1_(SQ€€Z_%EREX-1_#ERROR IF NO FILES DEFINED_^1LOOP1_"LDA*_$FILE_^1_(SUB*_!(STZR+1),Q_!FIND FILE IN TABLE_^1_(SAZ_%FND1_^1_(INQ_%5_^1_(TRQ_%A_^1_(SUB*_$AVSP_^1_(SAZ_%1_)SKIP IF NOT_!IN TABLE_^1_(JMP*_$LOOP1_^1_(ENA_%17_'ERROR IF NOT_^1EREX_#RTJ+_$Q8EREM_^1_(RTJ-_$($F4)_$EXIT_^1_(NUM_%$0A00_^1FND1_#LDA-_$2,Q_'GET UNIT NBR_^1_(STA*_$FILE_^1_(LDA-_$3,Q_'GET SECTOR STARTING ADDRESS_^1_(STA*_$S€€ECT_%SAVE STARTING SECTOR_^1_(LDA-_$1,Q_%GET SECTORS PER RECORD_^1_(STA*_$SAVEQ+1_^1_(LDA-_$4,Q_%GET ENDING SECTOR_^1_(STA*_$ENDSEC_^1_(STA+_$Q8QENS_^1_(LDQ*_$SAVEQ_^1_(QLS_%1_^1_(RAO+_$Q8QINI_^1_(LDA*_$(*-1)_^1_(STA*_$TEMP_^1_(LDA*_$(TEMP)_#RECORD NUMBER_^1_(STA*_$SAVEQ_^1_(SQM_%IN1_'SKIP IF NUMBER_^1_%STQ* Q65K_P64*1389_^1_%LDQ- $F6_*CHECK IF IN UPPER BANK_064*1389_^1_%SQM KG65K€€_(IF SO, NO RELATIVE ALLOWED_,64*1389_^1_(SAP_%3_)SKIP IF NOT RELATIVE_^1_(ADD*_$TEMP_^1_%AND- $11_*$7FFF_A64*1389_^1_(STA*_$SAVEQ_^1KG65K LDQ* Q65K_P64*1389_^1_(LDA*_$(SAVEQ)_^1IN1_$SAN_%1_^1_(JMP*_$ERR19_/ERROR IF ZERO_^1_(INA_%-1_^1_(MUI_%SAVEQ+1_"FORM SECTOR NUMBER_^1_(ADD*_$SECT_%SECTOR NUMBER_^1_(CLR_%Q_^1ST1_$STQ+_$Q8DFAD_"MOVE SECTOR ADDR OT CALLING SEQ_^1_(ENQ_%1_^1_(STA*€,_$(ST1+1),Q_^1_(SUB*_$ENDSEC_#CHECK OUT OF RANGE_^1_(ADD*_$SAVEQ+1_^1_(SAZ_%1_^1_(SAP_%ERR19_^1_(LDA*_$SAVEQ+1_-COMPUTE END OF RECORD_^1_(ADD*_$(ST1+1),Q_^1_(STA_%RECEND_^1_(LDA*_$FILE_^1_(JMP*_$(Q8DFIN) EXIT_^1ERR19_"ENA_%19_^1_(JMP*_$EREX_$ERROR IF OUT OF RANGE_^1Q65K_!NUM 0_S64*1389_^1_(END_^__,PQ8QX CSY/ H10 P€1_%NAM QBQX_)DECK-ID H10 FTN 3.3 RUNTIME_%SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3_^1*_$SMALL COMPUTER DEVELOPMENT DIVISION, LA JOLLA CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1973_^1_%SPC 2_^1_(ENT_%Q8QT0M_"INITIALIZATION ENTRY_^1_(ENT_%Q8QTRM_"TRANSMISSION ENTRY_^1_(ENT_%Q8QX_^1_(ENT_%Q8MOVE_.MOVE_^1_%ENT Q8QY_L**FTN 3.1**_^1_%ENT Q8QZ_L**FTN 3.1**_^1*€€_]_^1_(EXT_%Q8IFRM_.IFRMAT_^1_(EXT_%Q8BINB_.BINBUF_^1_(EXT_%Q8QUN1_^1_(EXT_%Q8UNIT_.UNIT_^1*_]_^1*_]_^1*_'INITIALIZE ENTRY ENTERED FROM Q8QINI_^1*_]_^1Q8QT0M_!NOP_%0_^1_(STA*_$FLAG_^1_(ARS_%9_^1_(AND*_$ONE_^1_(STA*_$ROW_%0 FOR READ/1 FOR WRITE_^1_(JMP*_$(Q8QT0M)_^1*_]_^1*_'TRANSMISSION ENTRY ENTERED FROM COMPILED PRO_^1*_]_^1*_]_^1* PASS ONE ELEMENT_^1*_]_^1*_[**FTN 3.1**_^1*_[**FT€€N 3.1**_^1*_*DOUBLE PRECISION TRANSMISSION ENTRY ENTERED_$**FTN 3.1**_^1*_*VIA A CALL GENERATED BY THE COMPILER._+**FTN 3.1**_^1*_[**FTN 3.1**_^1Q8QZ_!NOP 0_O**FTN 3.1**_^1_%ENA 3_O**FTN 3.1**_^1_%STA* FLOTFG_J**FTN 3.1**_^1_%LDA* Q8QZ_L**FTN 3.1**_^1_%STA* Q8QTRM_J**FTN 3.1**_^1_%JMP* Q8QTRM+1_H**FTN 3.1**_^1Q8QY_!NOP 0_^1_%ENA 2_^1_%STA* FLOTFG_^1_%LDA* Q8QY_^1_%STA* Q8QTRM_^€€1_%JMP* Q8QTRM+1_^1FLOTFG NUM 1_^1Q8QTRM_!NOP_%0_^1_%EQU Q8QX(Q8QTRM)_^1_(LDA-_$$FF_^1_(STA*_$T+2_^1_(STQ*_$T+1_^1_(LDQ+_$Q8UNIT_.UNIT_^1_(LDA*_$ROW_1IS WRITE REQ_+PSR 743_^1_(SAN_%MAKREL_.YES NO EOF CHECK_'PSR 743_^1_(RTJ+_$Q8QUN1_^1_(AND_%=N$1000_!CHECK EOF_^1_(SAZ_%1_(NO EOF_^1_(JMP*_$EXITX_#IGNORE REQUEST IF EOF_^1MAKREL_!LDA*_$(Q8QTRM)_DPSR 743_^1_%LDQ- $F6_*CHECK IF IN UPPE€€R BANK_,**FTN 3.0**_^1_%SQM KLG65K_'IF SO, NO RELATIVE ALLOWED_(**FTN 3.0**_^1_%SAP 2_^1_(ADD*_$Q8QTRM_^1_(AND*_$SVNF_^1KLG65K RTJ* RQST_^1EXITX_"RAO*_$Q8QTRM_^1_%ENA 1_^1_%STA* FLOTFG_^1_(LDA*_$T+2_^1_(STA-_$$FF_^1_(LDQ*_$T+1_^1_(JMP*_$(Q8QTRM)_^1*_'IMPLEMENT I/O REQUEST_^1*_]_^1*_]_^1RQST_#NOP_%0_^1_(TRA_%Q_^1_(STA*_$ADR_%LOCATION OF ELEMENT_^1_(LDA*_$FLAG_$CHECK FOR FORMAT_^1€€_(ALS_%1_^1_(SAP_%RQST1-*-1 NO FORMAT_^1_(LDA*_$FLAG_^1_(AND_%=N$0800_!BIT 11_^1_(STA*_$LONL_^1_(RTJ+_$Q8IFRM_"FORMAT_#IFRMAT_^1ENTRY_"ADC_%ONE_%ADDRESS OF ENTRY SWITCH_^1_(ADC_%ROW_%ADDRESS OF R/W SWITCH_^1_(ADC_%LONL_!0 FOR NO LIST/1 FOR LIST_^1_(JMP*_$(RQST)_^1RQST1 LDA* ADR_^1_%RTJ+ Q8BINB_^1_%LDA* FLOTFG_^1_%INA -1_^1_%SAZ 3_^1_%STA* FLOTFG_^1_%RAO* ADR_^1_%JMP* RQST1_^1_(J€€MP*_$(RQST)_^1*_]_^1*_'STORAGE AND CONSTANTS_^1*_]_^1SVNF_#NUM_%$7FFF_^1ADR_$NUM_%0_(ADDRESS OF LIST ELEMENT_^1ONE_$NUM_%1 CONSTANT AND ENTRY SWITCH FROM TR_^1ROW_$NUM_%0 0 FOR READ/ 1 FOR WRITE_^1LONL_#NUM_%0_%0 FOR NO LIST/1 FOR LIZT_^1_(BZS_%T(3)_^1_(EQU_%FLAG(T)_^1*_]_^1* RTJ MOVE_]_^1* ADC VALUE_^1* ADC SWITCH_^1*_]_^1* FOR READ, VALUE IS MOVED TO LIST ELEMENT + SWITCH_^1* FOR€€ WRITE, LIST ELEMENT + SWITCH IS MOVED TO VALUE_^1*_]_^1*_]_^1MOVE_#NOP_%0_^1_(LDA*_$(MOVE)_"ADDRESS OF VALUE_^1_(STA*_$ADS_^1_(RAO*_$MOVE_^1_(LDA*_$(MOVE)_"ADDRESS OF SWITHC_^1_(STA*_$*+2_^1_(LDA+_$0_(SWITCH_^1_(ADD*_$ADR_%+ADDRESS OF LIST ELEMENT_^1_(STA*_$ADS+1_^1_(RAO*_$MOVE_$RETURN SET_^1_(LDA*_$FLAG_^1_(AND_%=N$200_"TEST FOR WRITE_^1_(SAZ_%READ-*-1_^1* WRITE_]_^1_(LDA*_$(ADS+€¢1)_!FROM LIST_^1_(STA*_$(ADS)_^1_(JMP*_$EXIT_^1READ_#LDA*_$(ADS)_^1_(STA*_$(ADS+1)_!TO LIST_^1EXIT_#JMP*_$(MOVE)_^1_(BZS_%ADS(2)_^1_(EQU_%Q8MOVE(MOVE)_^1_(END_^__¢PQ8QUNI CSY/ H11 P€1_%NAM Q8QUNI_'DECK-ID H11 FTN 3.3 RUNTIME_%SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3_^1*_$SMALL COMPUTER DEVELOPMENT DIVISION, LA JOLLA CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1973_^1_%SPC 2_^1_(ENT_%Q8QUN1_^1_(ENT_%Q8QUN2_^1_(ENT_%Q8QUN3_^1_(EXT_%Q8EREM_.EREMSG_^1*_]_^1*_]_^1_%EQU NUMLU(99)_#NUMBER OF LU'S(MAX)_^1_%EQU LUINC(NUMLU+1)_F65*1419_^1*_]_^1€€*_]_^1*_]_^1* RETURN STATUS ON UNIT_^1*_]_^1Q8QUN1_!NOP_%0_^1_(RTJ*_$CHECK_#CHECK LEGALITY OF UNIT_^1_%LDA* UTBL-1,Q_$STATUS INTO A_^1_(JMP*_$(Q8QUN1)_^1*_]_^1* STATUS IS LOGICALLY ORRED IN_^1*_]_^1Q8QUN2_!NOP_%0_^1_(RTJ*_$CHECK_#CHECK LEGALITY OF UNIT_^1_(STA*_$AREG_$CURRENT STATUS SAVED_^1_(LDA-_$I_(SAVE I_^1_(STA*_$FF_^1_(STQ-_$I_(TABLE INDEX_^1_(LDQ*_$UTBL-1,I COMPOSITE STATUS€€_^1_(LDA*_$AREG_^1_(LAQ_%Q_(SAVE SAME BITS_^1_(EOR*_$UTBL-1,I SAVE DIFFERENT BITS_^1_(AAQ_%A_(SUM IS INCLUSIVE OR_^1_(STA*_$UTBL-1,I UPDATE UNIT TABLE_^1_(LDA*_$FF_'RESTORE I_^1_(STA-_$I_^1_(JMP*_$(Q8QUN2)_^1*_]_^1* STORE STATUS_^1*_]_^1Q8QUN3_!NOP_%0_^1_(RTJ*_$CHECK_#CHECK LEGALITY OF UNIT_^1_(STA*_$UTBL-1,Q STATUS INTO TABLE_^1_(JMP*_$(Q8QUN3)_^1*_]_^1* TABLE OVERFLOW_^1*_]_^1€€EROR_#ENA_%8_^1_(RTJ+_$Q8EREM_.ERRMSG_^1_(RTJ-_$($F4)_^1_(NUM_%$0A00_#EXIT REQUEST_^1CHECK_"NOP_%0_(TEST FOR UNIT LEGAL_^1_(SQZ_%CHK1-*-1 ZERO ILLEGAL_^1_(SQM_%CHK1-*-1 MINUS ILLEGAL_^1_%INQ -LUINC_'MORE THAN MAX LU_665*1419_^1_(SQM_%1_^1CHK1_#JMP*_$EROR_$MSG 8 AND TERMINATE_^1_%INQ LUINC_(RESTORE UNIT VALUE_465*1419_^1_(JMP*_$(CHECK)_^1_(BZS_%AREG_^1_(BZS_%FF_^1_%BZS UTBL(NUM€LU)_I65*1419_^1_(END_^__PQ8FGET CSY/ H12 P€1_%NAM Q8FGET_'DECK-ID H12 FTN 3.3 RUNTIME_%SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3_^1*_$SMALL COMPUTER DEVELOPMENT DIVISION, LA JOLLA CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1973_^1_%SPC 2_^1*_$FGETC FETCHES A CHARACTER FROM THE FORMAT STATE-_^1*_$MENT. FPUTC STUFFS A CHARACTER INTO THE FORMAT_^1*_$STATEMENT. CHARACTERS ARE RIGHT ADJUSTED._^1*_]_^1_(EN€€T_%Q8FGET_.FGETC_^1_(ENT_%Q8FPUT_.FPUTC_^1*_]_^1_(ENT_%Q8LOCF_.LOCFRM_^1_(ENT_%Q8IGP_/IGP_^1*_$FGETC/FETCH A CHARACTER_^1*_*CALL FGETC(ADR,SAVE,REP)_^1*_9WHERE_^1*_9ADR IS THE ADDRESS OF THE_^1*_9CHARACTER TO BE STORED._^1*_9SAVE IS AN INDICATOR -_^1*_90 MEANS IGNORE_^1*_92 MEANS SAVE THE CURRENT_^1*_9CHARACTER COUNT-1 IN GR._^1*_9REP IS AN INDICATOR -_^1*_90 MEANS IGNORE_^1_]_^1*_€€9COUNT TO GR._^1*_9SAVE AND REP ARE USED TO_^1*_9REPEAT FIELDS AND GROUPS_^1*_9IN THE FORMAT STATEMENT._^1*_]_^1*_$IGP ACCEPTS THE FORMAT STATEMENT ADDRESS FROM_^1*_$Q8QINI AND CLEARS THE CHARACTER COUNTER._^1*_]_^1*_]_^1* LOCFRM/GIVE FORMAT STATEMENT POINTER_^1*_*CALLED FROM FERMSG_^1*_]_^1LOCFRM NOP 0_^1_%LDA* CC_,CHARACTER COUNTER_^1_%JMP* (LOCFRM)_^1IGP_"NOP 0_^1_%STA* FSA_+€€FORMAT STATEMENT ADDRESS_^1_%CLR A_^1_%STA* CC_,CLEAR CHARACTER COUNTER_^1_%JMP* (IGP)_^1*_]_^1*_$FGETC/FETCH CHARACTER FROM FORMAT STATEMENT_^1*_]_^1FGETC NOP 0_^1_%RTJ* SAVR_*SAVE REGISTERS_^1_%LDA* (FGETC)_^1_%LDQ- $F6_*CHECK IF IN UPPER BANK_,**FTN 3.0**_^1_%SQM KLG65K_'IF SO, NO RELATIVE ALLOWED_(**FTN 3.0**_^1_%SAP 1_^1_%RTJ* RELA_*RELATIVE ADDRESS_^1KLG65K STA* ADR_*STO€€RE CHARACTER ADDRESS_+**FTN 3.0**_^1_%RAO* FGETC_^1_%LDA* (FGETC)_'SAVE FLAG ADDRESS_^1_%SQM KG65K_K**FTN 3.0**_^1_%SAP 1_^1_%RTJ* RELA_*RELATIVE ADDRESS_^1KG65K STA* *+2_M**FTN 3.0**_^1_%LDA+ 0_-SAVE FLAG_^1_%SAZ 1_-0-IGNORE_^1_%JMP* SAVCC_)SAVE CHAR COUNT +1 (REPEAT)_^1_%RAO* FGETC_^1_%LDA* (FGETC)_'REPEAT FLAG_^1_%SQM KL65K_K**FTN 3.0**_^1_%SAP 1_^1_%RTJ* RELA_*RELATIVE AD€€DRESS_^1KL65K STA* *+2_M**FTN 3.0**_^1_%LDA+ 0_-REPEAT FLAG_^1_%SAZ 1_^1_%JMP* REPCC_)REPEAT AT CHAR COUNT +1_^1_%LDQ* CC_,CHARACTER COUNT_^1_%LRS 1_-Q=WORD INCREMENT_^1_%SAZ LEFT-*-1_%LEFT CHAR_^1_%LDA* (FSA),Q_^1CFF_"AND =N$FF_)SAVE RT 8 BITS_^1_%JMP* LEFT+2_^1LEFT_!LDA* (FSA),Q_^1_%ARS 8_-RT ADJUST_^1_%STA* (ADR)_^1_%RAO* CC_,BUMP CC_^1EXIT_!RAO* FGETC_^1_%RTJ* RESR_*RESTO€€RE REGISTERS_^1_%JMP* (FGETC)_^1*_]_^1*_$SAVCC/SAVE CHAR COUNT +1_^1*_*IN FR OR GR_^1*_]_^1SAVCC LDQ* CC_^1_(INQ_%-1_^1_%STQ* GR_,GROUP REPEAT_^1_%RAO* FGETC_^1_%JMP* EXIT_^1*_]_^1*_$REPCC/RESTORE CC TO FR OR GR_^1*_]_^1REPCC LDQ* GR_+GROUP REPEAT_^1_%STQ* CC_^1_%JMP* EXIT_^1*_]_^1*_$FPUTC/STUFF CHAR IN FORMAT STATEMENT_^1*_]_^1FPUTC NOP 0_^1_%RTJ* SAVR_*SAVE REGISTERS_^1_%LDA*€€ (FPUTC)_^1_%LDQ- $F6_*CHECK IF IN UPPER BANK_,**FTN 3.0**_^1_%SQM KK65K_(IF SO, NO RELATIVE ALLOWED_(**FTN 3.0**_^1_%SAP 2_^1_%ADD* FPUTC_^1_%AND* SVNFFF_(RELATIVE ADDRESS_^1KK65K STA* ADR_M**FTN 3.0**_^1_%LDQ* CC_,CHAR COUNT_^1_%LRS 1_-WORD INCREMENT_^1_%SAP PLEFT-*-1_$LEFT ADJUST_^1_%LDA* (ADR)_)RIGHT ADJUSTED CHAR_^1_%STA* CHAR_^1_%LDA* (FSA),Q_^1_%AND =N$FF00_'MASK OFF R€€IGHT 8 BITS_^1_%JMP* PUT_^1PLEFT LDA* (ADR)_^1_%ALS 8_-LEFT ADJUST_^1_%STA* CHAR_^1_%LDA* (FSA),Q_^1_%AND* CFF+1_)MASK OFF LEFT 8 BITS_^1PUT_"EOR* CHAR_*OR IN CHARACTER_^1_%STA* (FSA),Q_'STUFF BACK IN FS_^1_%RTJ* RESR_*RESTORE REGISTERS_^1_(RAO*_$CC_$BUMP CHAR COUNTER_^1_%RTJ* RESR_*RESTORE REGISTERS_^1_%RAO* FPUTC_^1_%JMP* (FPUTC)_^1*_]_^1*_$RELA/COMPUTE PARAMETER ADDRESS RELATI€€VE TO_^1*_*ITS ADDRESS (FOR RUN ANYWHERE FORTRAN)_^1*_]_^1RELA_!NOP 0_^1_%ADD* FGETC_^1_%AND* SVNFFF_^1_%JMP* (RELA)_^1*_]_^1*_$SAVE REGISTERS_^1*_]_^1SAVR_!NOP 0_^1_%STA* SAVA_^1_%STQ* SAVQ_^1_%JMP* (SAVR)_^1*_]_^1*_$RESTORE REGISTERS_^1*_]_^1RESR_!NOP 0_^1_%LDA* SAVA_^1_%LDQ* SAVQ_^1_%JMP* (RESR)_^1*_]_^1* STORAGE_]_^1*_]_^1FSA_"NUM 0_-FORMAT STATEMENT ADDRESS_^1CC_#NUM 0_-C€HARACTER COUNTER_^1ADR_"NUM 0_-ADDRESS FROM CALL SEQ_^1GR_#NUM 0_-GROUP REPEAT_^1CHAR_!NUM 0_-PUT CHARACTER_^1SAVA_!NUM 0_-A REGISTER_^1SAVQ_!NUM 0_-Q REGISTER_^1SVNFFF NUM $7FFF_^1_(EQU_%Q8FGET(FGETC),Q8FPUT(FPUTC)_^1_(EQU_%Q8IGP(IGP),Q8LOCF(LOCFRM)_^1_%END_]_^__PQ8MAGT CSY/ H13 P€1_%NAM Q8MAGT_'DECK-ID H13 FTN 3.3 RUNTIME_%SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3_^1*_$SMALL COMPUTER DEVELOPMENT DIVISION, LA JOLLA CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1973_^1_%SPC 2_^1*_]_^1*_'TEST LEGAL USE OF MAGNETIC TAPE UNIT_^1*_]_^1_(ENT_%Q8MAGT_.MAGT_^1_(ENT_%Q8EOTT_^1_(EXT_%Q8EREM_.EREMSG_^1_(EXT_%Q8QUN2_^1_(EXT_%Q8COMI_.COMIN_^1_(EXT_%Q€€8QWND_^1_%EXT Q8QUN1_MPSR 527_^1*_]_^1* DENSITY BITS 0,1,2,3_^1* P1 BITS 15-12_^1*_]_^1* P=0 DO NOTHING_^1*_]_^1* DENSITY = 2, 556 BPI_^1*_]_^1* A REGISTER_^1* BIT 15 SET, WRITE ENABLE RING PRESENT_^1* BIT 14 SET, 800 BPI DENSITY_^1* BIT 13 SET, 556 BPI DENSITY_^1* BIT 12 SET, BUSY_^1* BIT 11 SET, FILE MARK SENSED_^1* BIT 10 SET, LOAD POINT SENSED_^1* BIT 9 SET, END OF TAPE SENSED€€_^1* BIT 8 SET, PARITY ERROR_^1* BIT 7 SET, UNIT PROTECTED_^1* BIT 3 SET, READ/WRITE MAY PROCEED_^1* BIT 1 SET, BUSY_^1* BIT 0 SET, READY_^1*_]_^1MAGT_#NOP_%0_^1_(STQ*_$FLG_%FLAG WORD_^1_(STA*_$MU1_^1_(STA*_$MU2_^1_%STA* MU3_M**FTN 3.0**_^1* CHECK REQUEST TYPE AND SET IN UNIT TABLE_^1_(TRQ_%A_(FLAGWORD_^1_(AND_%=N$4000_!BIT 14 ON FOR FROMAT_^1_(LDQ*_$MU1_%UNIT_^1_(RTJ+_$Q8QUN2_"€€STATUS WILL REFLECT RQ TP_^1_(LDA*_$TPEFLG_"IS THIS THE 1ST MT REQUES_^1_%SUB* MU2_*OR DIFFERENT LU_^1_%INA 0_^1_%SAN MAGT1_(YES_^1_%JMP* FLETST_MPSR 527_^1MAGT1_"RTJ-_$($F4)_#DO NOTHING MT REQUEST_^1_%NUM $5C00_(THIS REQUEST CAUSES UPDATE OF_^1COMP_!ADC 0_,PHYSTAB STATUS WORD_^1THRD_!ADC 0_^1MU1_"NUM 0_^1COMND NUM 0_^1WAIT_!LDA* THRD_)HANG ON THREAD UNTIL_^1_%SAZ CNTNU_(I€€/O COMPLETE_^1_%JMP* WAIT_^1CNTNU LDA* MU2_^1_(STA*_$TPEFLG_"SET 1ST MT R/Q FLAG_^1_(CLR_%A_^1_(STA*_$FNSH_^1_(RTJ-_$($F4)_#OBTAIN STATUS_^1_(ADC_%$0600_^1MU2_$NUM_%0,0_^1_(STA*_$STAFLG_"SAVE HARDWARE STATUS_^1_(LDA*_$FLG_%CHECK FOR WRITE_^1_(AND*_$B9_'BIT 9_^1_(SAZ_%EOFTST-*-1 NO WRITE_^1*_]_^1*_'TEST FOR WRITE ENABLE_^1*_]_^1_(LDA*_$STAFLG_"HARWARE STATUS_^1_(SAM_%EOFTST-*-1 BIT€€ 15 FOR WRITE ENABLE_^1_(ENA_%7_(NO WRITE ENABLE_^1ERR_$RTJ+_$Q8EREM_.ERRMSG_^1* CONTINUE. MT DRIVER WILL CATCH ERROR_^1*_]_^1*_'CHECK FOR END OF FILE_^1*_]_^1EOFTST_!LDA*_$FLG_IPSR 743_^1_(AND*_$B9_2IS THIS WRITE REQ_%PSR 743_^1_(SAN_%RETRN_/YES NO EOF CHECK_'PSR 743_^1_(LDA*_$STAFLG_.HARDWARE STSTUS_(PSR 743_^1_(AND_%=N$800_"BIT 11 FOR END OF FILE_^1_(SAZ_%1_(NO EOF_^1_(JMP*_$ER_€€'EOF-NO OP LEGAL EXCEPT EF_^1RETRN_"JMP*_$(MAGT)_FPSR 743_^1*_] PSR 743_^1* CHECK FOR END OF FILE WHEN IT IS NOT THE FIRST MAG TAPE REQUEST PSR743_^1*_] PSR 743_^1FLETST_!LDA*_$FLG_IPSR 743_^1_(AND*_$B9_JPSR 743_^1_(SAZ_%1_KPSR 743_^1_(JMP*_$RETRN_GPSR 743_^1_(LDQ*_$MU1_IPSR 743_^1_%RTJ+ Q8QUN1_MPSR 743_^1_%AND =N$1000_LPSR 743_^1_(JMP*_$RETRN-2_EPSR 743_^1*_]_^1*_'END OF TAPE TES€€T_^1*_]_^1Q8EOTT_!NOP_^1_%ADC $54F4_NPSR 743_^1_%ADC $0600_K**FTN 3.0**_^1MU3_"NUM 0,0_M**FTN 3.0**_^1_(AND*_$B9_'BIT 9 FOR END OF TAPE_^1_(SAZ_%XEOT_%NOT END OF TAPE_^1_(ENA_%10_'ERROR MSG 10 - EOT_^1_(RTJ*_$(ERR+1)_^1_(RTJ+_$Q8QWND_^1_%NUM 0_^1_(ADC_%MU2_^1_(RTJ+_$Q8COMI_"TYPE IN CR TO CONTINUE_^1XEOT_#JMP*_$(Q8EOTT)_^1ER_%ENA_%5_(ONLY EOF CHECK IS LEGAL_^1_(RTJ*_$(ERR+1)_^1*€¨_8EXIT_^1_(RTJ-_$($F4)_^1_(NUM_%$0A00_^1*_]_^1*_]_^1_(BZS_%FNSH_^1_(BZS_%STAFLG_"FROM STATUS RQST_^1_(BZS_%TPEFLG,FLG_^1B9_%NUM_%$200_^1_(EQU_%Q8MAGT(MAGT)_^1_(END_^__ ¨PTAPCON CSY/ H14 P€1_%NAM TAPCON_'DECK-ID H14 FTN 3.3 RUNTIME_%SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3_^1*_$SMALL COMPUTER DEVELOPMENT DIVISION, LA JOLLA CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1973_^1_%SPC 2_^1_%ENT Q8QBCK_!BACKSPACE_^1_%ENT Q8QFLE_!WRITE EOF_^1_%ENT Q8QWND_!REWIND_^1_%ENT EOF_$CHECK FOR EOF_^1_%EXT Q8ERRM_'ERROR MSG INITIALIZATION ROUTINE_^1_(EXT_%€€Q8EREM_.EREMSG_^1_(EXT_%Q8CMP0_.CMPL0_^1_(EXT_%Q8CMP1_.CMPL1_^1_%EXT Q8QUN1_^1_%EXT Q8QUN2_^1_%EXT Q8QUN3_^1_(EXT_%Q8IBUF_.IBUF_^1_%EQU MK7FFF($11)_E**FTN 3.0**_^1SAVE_!NOP 0_-SAVE REGISTERS_^1_%STQ* T+1_-Q_^1_%LDA- I_^1_%STA* T+2_+I_^1_%LDQ* SAVE_^1_%INQ -3_^1_%LDA* EOFLG_^1_%SAZ NOTEOF_'SKIP IF NOT EOF CHECK_^1_%INQ -1_+PICK UP CALLER'S_^1_%LDA* (UNIT+1),Q_"RETURN ADDRESS€€_^1_%STA* RETURN_^1_%ENA 0_,CLEAR EOFLG_^1_%STA* EOFLG_^1_%JMP* UNITNM_^1NOTEOF LDA* (UNIT+1),Q_"ORIGINAL RETURN ADDRESS_^1_%STA* RETURN_^1_%LDQ* (RETURN)_$GET I/O STATEMENT NUMBER_^1_%STQ* FLAG_)TEMP STORAGE_^1_%RAO* RETURN_'GET NEXT PARAMETER - LOGICAL UNIT_^1UNITNM LDA* (RETURN)_$ADDRESS OF UNIT NUM._^1_%LDQ- $F6_*CHECK IF IN UPPER BANK_,**FTN 3.0**_^1_%SQM KLG65K_'IF SO, NO R€€ELATIVE ALLOWED_(**FTN 3.0**_^1_%SAP 2_O**FTN 3.0**_^1_%ADD* RETURN_^1_%AND- MK7FFF_J**FTN 3.0**_^1KLG65K TRA Q_O**FTN 3.0**_^1_%LDA* (UNIT+1),Q ADD. OF UNIT_^1_%TRA Q_,LOGICAL UNIT NUMBER TO Q_,68*1547_^1_%INA -5_+CHECK FOR F3RTRAN L1_068*1547_^1_%SAP NOTFTN_'NOT FORTRAN LU_668*1547_^1_%LDA- $F8,Q_(PICK UP ACTUAL LU_368*1547_^1_%JMP* SETLU_M68*1547_^1NOTFTN TRQ A_,RESTORE O€€RIGINAL LU_168*1547_^1SETLU STA* LU_P68*1547_^1_%STA* UNIT_^1_%TRA Q_,LOGICAL UNIT IN Q-REG_^1_%LDA* FLAG_)I/O STATEMENT NUMBER TO A-REG_^1_%RTJ+ Q8ERRM_'INITIALIZE ERROR MSG_^1_%LDQ* UNIT_^1_%RTJ+ Q8QUN1_'CHECK LEGALITY OF UNIT_^1*_83 CARDS DELETED_^1_%RTJ* STATUS_^1_%JMP* (SAVE)_^1RETURN NUM 0_^1FLAG_!NUM 0_^1T_$NUM 0,0,0_^1RQST_!NOP 0_^1_%STA* COMND_#OPERATION_^1*_82 CARDS€€ DELETED_368*1555_^1_%RTJ- ($F4)_^1_%NUM $5C00_(TAPE REQUEST_6**FTN 3.0**_^1*_82 CARDS DELETED_368*1555_^1COMP_!ADC 0_,COMPLETION ADDRESS_268*1555_^1THRD ADC 0_-THREAD_>68*1555_^1LU_#NUM 0_)LOG. UNIT NUMBER_^1COMND NUM 0_$OPERATION CODE STUFFED HERE_^1WAIT_!LDA* THRD_N68*1555_^1_%SAZ OUTLOP_L68*1555_^1_%JMP* WAIT_'WAIT FOR COMPLETION OF REQUEST_^1OUTLOP STQ* FLAG_N68*1555_^€€1_%ENA 0_^1_%STA- I_*LENGHT_^1_%LDA* STFLG_%SECOND WORD OF UNIT TABLE_^1_%ARS 3_^1_%LDQ* FLAG_'FROM COMPLETION_^1_%LLS 3_^1_%JMP* (RQST)_^1*_92 CARDS DELETED_268*1555_^1FATAL RTJ- ($F4)_^1_%NUM $A00_+EXIT REQUEST_^1*_81 CARD DELETED_468*1555_^1EXIT_!LDQ* UNIT_^1_%RTJ+ Q8QUN2_"STORE UNIT FLAG_^1EXIT2 LDA* T_(RESET A_^1EXIT3 LDQ* T+2_'RESET I_^1_%STQ- I_^1_%LDQ* T+1_'RESET Q_^€€1_%RAO* RETURN_^1_%JMP* (RETURN)_^1STATUS NOP 0_^1_%RTJ- ($F4)_^1_%NUM $600_'STATUS REQUEST_^1UNIT_!NUM 0,0_^1_%STA* STAFLG_(SAVE HARDWARE STATUS_^1*_87 CARDS DELETED_368*1548_^1OK_#LDQ* UNIT_^1_%RTJ+ Q8QUN1_#GET FLAG WORD IN UNIT TABLE_^1_%STA* STFLG_^1_%JMP* (STATUS)_^1_%BZS STAFLG_(HARDWARE STATUS_^1STFLG NUM 0_^1Q8QFLE NOP 0_)WRITE EOF ROUTINE_^1_%RTJ SAVE_^1_%RTJ* WEOF€€_^1_(LDQ*_$UNIT_HPSR 743_^1_(RTJ+_$Q8QUN1_FPSR 743_^1_(AND_%=N$EFFF_EPSR 743_^1_(RTJ+_$Q8QUN3_FPRS 743_^1_%JMP* EXIT_^1WEOF_!NOP 0_^1_%LDA* MK2000_#WRITE EOF_^1_%RTJ* RQST_^1_%JMP* (WEOF)_^1EOF_"NOP 0_)DETECT EOF ROUTINE_^1_%RAO* EOFLG_(SET FLAG FOR EOF CHECK_^1_%RTJ SAVE_^1_%LDA* STFLG_^1_%AND* MK1000_(BIT 12 FOR EOF_^1_%SAZ NOEOF-*-1_^1_%ENA 1_^1_%STA* T_/SAVE EOF INDICATOR_€€^1_%LDA* STFLG_+CLEAR EOF BIT IN UNIT TABLE_^1_%AND =N$EFFF_^1_(JMP*_$EXIT4_#STARE IN UNIT TABLE_^1NOEOF ENA 2_*NO EOF_^1_%JMP* EXIT3_^1EOFLG NUM 0_^1Q8QWND NOP 0_-REWIND ROUTINE_^1_%RTJ SAVE_^1_%LDA =N$3000_'REWIND_^1_%RTJ* RQST_^1_%AND =N$DFFF_^1_%ADD* MK2000_#REWIND INDICATOR_^1_%JMP* EXIT_^1Q8QBCK NOP 0_-BACKSPACE ROUTINE_^1_%RTJ SAVE_^1_%LDA* STAFLG_(HARDWARE STATUS€€_^1_(AND*_$MK0400_"CHECK FOR LOAD POINT_^1_%SAZ 1_-SKIP IF NOT LOAD POINT_^1_%JMP* EM9_'SET BACKSPACE FLAG_^1Q8QBK1 LDA* MK1000_%1-BACKSPACE_^1_%RTJ* RQST_^1_%STA* STFLG_'FLAG UNIT TABLE_^1_%AND =N$F7FF_^1_%ADD* MK0800_'BACKSPACE FLAG_^1_%JMP* EXIT_^1EM9_"ENA 9_-BACKSPACE AT LOAD POINT_^1_%RTJ Q8EREM_'ERROR MESSAGE_768*1548_^1_%JMP* FATAL_(TERMINATE PROGRAM_368*1548_^1*_84 CARD€ÈS DELETED_^1*_81 CARD DELETED_^1MK1000 NUM $1000_^1MK0800 NUM $0800_^1MK0400 NUM $0400_^1MK2000 NUM $2000_^1EXIT4_"LDQ*_$UNIT_^1_%RTJ+ Q8QUN3_(STORE INDICATORS IN TABLE_^1_%JMP* EXIT_^1_%END_]_^__ÈPIOCK CSY/ H15 P€1_%NAM IOCK_)DECK-ID H15 FTN 3.3 RUNTIME_%SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3_^1*_$SMALL COMPUTER DEVELOPMENT DIVISION, LA JOLLA CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1973_^1_%SPC 2_^1* TRANSMISSION CHECK_^1*_]_^1_(ENT_%IOCK_^1*_]_^1_(EXT_%Q8QUN1_^1_(EXT_%Q8QUN3_^1*_]_^1* CALLING SEQUENCE_^1* RTJ IOCK_^1* ADR UNIT_^1*_]_^1* ASSUME I IS NOT DESTR€€OYED_^1*_]_^1* ERROR, A REGISTER CONTAINS 2_^1* NO ERROR A REGISTER CONTAINS I_^1*_]_^1IOCK_#NOP_%0_^1_(STQ*_$TEMP_^1_(LDA*_$(IOCK)_^1_%LDQ- $F6_*CHECK IF IN UPPER BANK_,**FTN 3.0**_^1_%SQM KLG65K_'IF SO, NO RELATIVE ALLOWED_(**FTN 3.0**_^1_(SAP_%2_^1_(ADD*_$IOCK_^1_%AND- SVNF_L**FTN 3.0**_^1KLG65K STA* ADR_M**FTN 3.0**_^1*_]_^1* CHECK UNIT TABLE_^1*_]_^1_(LDQ*_$(ADR)_^1_(RTJ+_$€HQ8QUN1_^1_(STA*_$STAT_$SAVE STATUS FLAG_^1_(AND*_$B2_^1_(SAZ_%NOER-*-1_^1_(LDA*_$STAT_^1_(EOR*_$B2_'TURN OFF I/O ERROR BIT_^1_(RTJ+_$Q8QUN3_^1_(ENA_%1_^1_(JMP*_$*+2_^1NOER_#ENA_%2_^1_(RAO*_$IOCK_^1_(LDQ*_$TEMP_^1_(JMP*_$(IOCK)_^1B2_%NUM_%$0004_^1_(BZS_%ADR_^1_(BZS_%STAT_^1_(BSS_%TEMP_^1_%EQU SVNF($11)_G**FTN 3.0**_^1_(END_^__HPPSSTOP CSY/ H16 P€1_%NAM PSSTOP_'DECK-ID H16 FTN 3.3 RUNTIME_%SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3_^1*_$SMALL COMPUTER DEVELOPMENT DIVISION, LA JOLLA CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1973_^1_%SPC 2_^1*_'PAUSE/STOP REQUEST HANDLER_^1*_,CALLING SEQUENCES_^1*_11.RTJ Q8PSE_"PAUSE_^1*_12.RTJ Q8PSEN_!PAUSE N_^1*_3NUM N_^1*_13.RTJ Q8STP_"STOP_^1*_14.RTJ Q8STPN_!STOP N€€_^1*_3NUM N_^1*_]_^1_(ENT_%Q8PSE_^1_(ENT_%Q8PSEN_^1_(ENT_%Q8STP_^1_(ENT_%Q8STPN_^1_(ENT_%Q8COMI_.COMIN_^1_(EXT_%Q8PAND_.PANDS_^1Q8PSE_"NOP_%0_(PAUSE_^1_(STQ*_$QSAV_$SAVE Q_^1_(ENA_%-0_'NEGATIVE FOR NO DIGIT CNV_^1_(RTJ*_$PAUSE_#TO PAUSE_^1_(JMP*_$(Q8PSE)_^1Q8PSEN_!NOP_%0_(PAUSE N_^1_(STQ*_$QSAV_$SAVE Q_^1_(LDA*_$(Q8PSEN) N_^1_(RTJ*_$PAUSE_#TO PAUSE_^1_(RAO*_$Q8PSEN_^1_(JMP*_$(Q8PS€€EN)_^1PAUSE_"NOP_%0_^1_(LDQ-_$I_(SAVE I_^1_(STQ*_$ISAV_^1_(LDQ_%=XPAU_#ADDRESS OF PAUSE IN ASCII_^1PANDS_"RTJ+_$Q8PAND_"OUTPUT_#PANDS_^1_(RTJ*_$COMIN_#INPUT FROM COMMENTS IN_^1_(LDQ*_$ISAV_$RESTORE I,Q_^1_(STQ-_$I_^1_(LDQ*_$QSAV_^1_(JMP*_$(PAUSE)_!PAUSE COMPLETE_^1Q8STP_"NOP_%0_(STOP_^1_(ENA_%-0_'NEGATIVE FOR NO DIGIT CNV_^1STOP_#LDQ_%=XSTP_#ADDRESS OF STOP IN ASCII_^1_(RTJ*_$(PAND€€S+1) OUTPUT_^1EXIT_#RTJ-_$($F4)_#CALL EXIT_^1_(NUM_%$0A00_^1Q8STPN_!NOP_%0_(STOP N_^1_(LDA*_$(Q8STPN) N_^1_(JMP*_$STOP_^1COMIN_"NOP_%0_(INPUT ON COMMENTS IN DEVI_^1_(RTJ-_$($F4)_#CALL INPUT_^1_%ADC_!$4800,0_J68*1556_^1ZERO_#ADC_%0,$18FD,1,T_^1THDLOP LDA* ZERO_N68*1556_^1_%SAZ OUTLOP_L68*1556_^1_%JMP* THDLOP_L68*1556_^1OUTLOP JMP* (COMIN)_K68*1556_^1T_$NUM 0_Q68*1556_^1SVNF_#NUM_€d%$7FFF_^1STP_$ALF_%3,STOP_^1PAU_$ALF_%3,PAUSE_^1_(BSS_%ISAV,QSAV_^1_(EQU_%Q8COMI(COMIN)_^1_(END_^__ dPQ8PAND CSY/ H17 P€1_%NAM Q8PAND_'DECK-ID H17 FTN 3.3 RUNTIME_%SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3_^1*_$SMALL COMPUTER DEVELOPMENT DIVISION, LA JOLLA CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1973_^1_%SPC 2_^1_(ENT_%Q8PAND_.PANDS_^1* ENTER ROUTINE WITH BINARY NUMBER IN A REGISTER_^1*_]_^1* TYPE PAUSE OR STOP_^1* IF A NEGATIVE THERE IS NO N, POSITIVE_^1* TYPE FIVE OCTAL €€DIGITS ON PAUSE AND STOP STATEMENTS_^1* OUTPUT OCTAL DIGITS ON STD COMMENT DEVICE_^1* ROUTINE CONVERTS BINARY NUMBER TO ASCII CODE_^1* LOCATION OF BUFFER IS PASSED TO EMSG IN A REGISTER_^1* LEADING ZEROS ARE PRINTED_^1*_]_^1PANDS_"NOP_%0_^1_(STA*_$T_(SAVE REGISTERS_^1_(STQ*_$PIKUP+1_!ADDRESS OF PAUSE OR STOP_^1_(ENQ_%2_^1PIKUP_"LDA+_$0,Q_^1_%STA* BUF2,Q_^1_(INQ_%-1_^1_(SQM_%1_^1_(€€JMP*_$PIKUP_^1_(CLR_%A_^1_(STA*_$CNTR_^1_(STA-_$$FF_^1_(STA*_$TEMP_^1*_81 CARD DELETED_468*1557_^1_(ENQ_%-5_^1STRT_#LDA*_$SHFT+5,Q CONVERT BITS 3 AT A TIME_^1_(STA*_$PLACE_^1_(LDA*_$T_^1_(SAP_%1_(CHECK FOR N_^1_(JMP*_$NON_%NO N_^1_(AND*_$MSKS+5,Q_^1PLACE_"NOP_%0_^1_(STA*_$TEMP_^1_(LDA*_$CNTR_^1_(SAN_%ODD-*-1_^1_(ENA_%1_^1_(STA*_$CNTR_^1_(LDA*_$TEMP_^1_(ADD*_$BTHRE_#LHS TO ASCII_^1€€_(STA*_$BUF,I_^1_(JMP*_$OUT_^1ODD_$CLR_%A_^1_(STA*_$CNTR_^1_(LDA*_$TEMP_^1_(ADD*_$LTHRE_#RHS TO ASCII_^1_(ADD*_$BUF,I_^1_(STA*_$BUF,I_^1_(RAO-_$$FF_^1OUT_$INQ_%1_^1_(SQZ_%1_^1_(JMP*_$STRT_^1_(LDA*_$SP_^1_(ADD*_$BUF,I_^1_(STA*_$BUF,I_^1WRITE_"RTJ-_$($F4)_^1_%ADC $4C00,0,0$18FD,9,BUF1_^1THDLOP LDA* WRITE+3_K68*1557_^1_%SAZ OUTLOP_L68*1557_^1_%JMP* THDLOP_L68*1557_^1OUTLOP RTJ- ($F4€€)_^1_%ADC $4C00,0_^1THREAD NUM 0_^1_%ADC $18FB_(PRINT STOP OR PAUSE ON_^1LENGTH NUM 9_,STD. LIST OUTPUT DEVICE_^1_%ADC BUF1_^1TRDLP1 LDA* THREAD_'HANG ON THREAD_^1_%SAZ PRTOUT_^1_%JMP* TRDLP1_^1PRTOUT JMP* (PANDS)_^1NON_$LDA_%=A_'BLANK OUT BUF_^1_(STA*_$BUF_^1_(STA*_$BUF+1_^1_(STA*_$BUF+2_^1_(JMP*_$WRITE_^1BUF1_!NUM $2020_^1_%BSS BUF2(3)_^1_%BSS BUF(3)_^1_%NUM $2020,$2020€R_^1_%BSS CNTR,T(3),TEMP_^1MSKS_#NUM_%$7000_^1_(NUM_%$0E00_^1_(NUM_%$01C0_^1_(NUM_%$0038_^1_(NUM_%$0007_^1SHFT_#NUM_%$0F44_#ARS4_^1_(NUM_%$0F49_#ARS 9_^1_(NUM_%$0FC2_#ALS 2_^1_(NUM_%$0F43_#ARS 3_^1_(NUM_%$0FC8_#ALS8_^1BTHRE_"NUM_%$3000_^1LTHRE_"NUM_%$0030_^1SP_%NUM_%$0020_^1*_84 CARDS DELETED_-68*1557_^1_(EQU_%Q8PAND(PANDS)_^1_(END_^__ RPQ8EXP1 CSY/ H18 P€1_%NAM Q8EXP1_'DECK-ID H18 FTN 3.3 RUNTIME_%SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3_^1*_$SMALL COMPUTER DEVELOPMENT DIVISION, LA JOLLA CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1973_^1_%SPC 2_^1*_#USING EXPONENT OF FLOATING PT.NO.,CREATE EQUIVALENT POWER OF 10_^1*_#NUMBER IN P+1,P+2_^1*_#OUTPUT IS OCTAL FRACTION IN LOWER 12 BITS OF P+1,P+2_^1*_#DECIMAL E€€XPONENT IN +3,SIGN OF EXPONENT IN P+4_^1_%EXT HFLOT_OFTN 3.3_^1_%EXT PARABS_NFTN 3.3_^1_$EXT Q8EXPT,Q8EXP2_^1_$ENT Q8EXP1_^1Q8EXP1 NOP_^1_%LDA* EXP10_OFTN 3.3_^1_%RTJ PARABS_NFTN 3.3_^1_%STA- I_SFTN 3.3_^1_$RAO* EXP10 RETURN ADDRESS_^1_$INA 1_^1_%STA* EXP21+1_!LOC. OF NUMBER_^1_%LDA- 1,I_^1_$SAZ EX121-*-1_!FULL ZERO_^1EXPO6 ALS 1_^1_$SAP_!EXP12-*-1_!POS. IF NUM. GREATER T€€HAN 1/2_^1_$LDQ* EXPPL_^1_$STQ* EXP20_^1_$LDQ* EXPPL+1_^1_$JMP* EXP14_^1EX121 STA- 3,I_^1_$JMP* EX122_^1EXP12 LDQ* EXPMI_"MINUS EXPONENT_^1_$STQ* EXP20_^1_$LDQ* EXPMI+1_^1EXP14 STQ* EXP21_^1_$EOR =N$8000_$CHANGE SIGN OF EXP._^1_$ARS 8 RIGHT JUSTIFY EXPON_^1*_'LOG BASE 10 OF 2 = 2688_"NUM. IS SHIFTED AHEAD OF TIME_^1_%MUI =N$4D10_#2(LOG BASE 10 OF 2)_^1_%INQ 0_^1_$ST€€Q- 3,I_)STORE FIRST ESTIMATE IN P+3_^1EXP20 NOP 0 TCQ Q FOR NEG EXPONENT_^1_$INQ_!0_^1_$LRS 3_%TO SEE IF EXP. IS GREATER THAN 7_^1_$SQN EXP26-*-1_!BIG PART OF NORMALIZING CONSTANT_^1_$LLS 3_*NO BIG PART,PUT SMALL IN TEMP_^1_$QLS 1_^1_$RTJ* EXP27_^1_$JMP* EXP28_^1EXP26 QLS 1_#GREATER THAN 7_^1_$TCQ Q_#TO GO BACKWARD IN TABLE_^1_$RTJ* EXP27_^1_$ENQ 0_^1_$LLS 3_^1_$SQZ EXP€€28-*-1 NO BIG PART OF NORMALIZING CONSTANT_^1_$QLS 1_^1_$ADQ* ECON_^1_$STQ* EXP29_^1************************************ FTN 3.1 **************************_^1_%RTJ* (EXP28+1)_#CALL FLOT_^1_%NUM $B9D4_^1EXP29 NUM 0_,B LDA EXPTB,Q_^1_%ADC TEMP_)9 FMU TEMP_^1_%ADC TEMP_)D STA TEMP_^1EXP28 RTJ HFLOT_PFTN 3.3_^1EXP21 NUM $B9D8_^1_%NUM 0_,LDA NUM_^1_%ADC TEMP_)FDV OR FMU PO€€WER OF 10_^1_%ADC TEMP_)STA RESULT_^1ECON_!ADC Q8EXPT_'FSB 1.0_^1_%NUM $D400_^1_%ADC TEMP2_(STA TEST RESULT_^1EXP24 LDA* TEMP2_^1_%SAM EXP25_(IF NEG. NUM. IS LESS THAN 1.0_^1_%RAO- 3,I_*EST. WAS TOO SMALL, INCREASE AND DIVIDE BY 10_^1_%RTJ* (EXP28+1)_#CALL FLOT_^1_%NUM $BAD8_^1_%ADC TEMP_)LDA TEMP_^1_%ADC Q8EXP2_'FDV 10.0_^1_%ADC TEMP_)STA RESULT_^1_%ADC Q8EXPT_'FSB 1.€€0_^1_%NUM $D400_^1_%ADC TEMP2_(STA TEST RESULT_^1_%JMP* EXP24_^1EXP25 LDA* TEMP_^1************************************ FTN 3.1 ($) **********************_^1_$ENQ 0_^1_$LLS 9_+SHIFT EXP. IN Q_^1EXP30 ADQ =N$FF80_^1_$INQ 0_^1_$STQ* EXP29_#TEMPORARY_^1_$ARS 9_^1_$AND =N$007F ONLY LOWER 7 BITS ARE SIGNIFICANT_^1_$LDQ* TEMP+1_^1_$LLS 24_^1EXP31 STQ- 1,I MOST SIGNIFICANT PART OF€€ OCTAL FRACTION_^1_$STA- 2,I LEAST SIG PART_^1_$LDA* EXP29_$BINARY EXPONENT_^1_%SAP EXP32-*-1_^1_$RAO* EXP29_$NOT 0,SHIFT FRACTION_^1_$LDQ- 1,I MODT SIGNIFICANT PART OF FRACTION_^1_$LDA- 2,I LEAST SIGNIFICANT PART OF FRACTION_^1_$LRS 1_^1_$JMP* EXP31_^1EXP32 LDA- 2,I_^1_%LRS 3 FORM TWO 12 BIT WORDS_^1_%STQ- 1,I_*MOST SIGNIFICANT PART_-**FTN 3.1**_^1_%LLS 12_N**FTN 3.1**_^1_%A€€RS 4_O**FTN 3.1**_^1_%AND =N$0C00_%TWO BITS_:**FTN 3.1**_^1_%STA- 4,I_*TWO BITS POSSIBLY_1**FTN 3.1**_^1_%TRQ A_O**FTN 3.1**_^1_%AND- $E_+$0FFF_=**FTN 3.1**_^1EX122 STA- 2,I LEAST SIGNIFICANT HALF_^1_$JMP* (EXP10) EXIT_^1EXP27 NOP_"0_^1_$ADQ*_!ECON_"PUT NORMALIZING CONSTANT-BIG PART_^1_%STA* TEMP_'SAVE TEMP._^1_%LDA- 1,Q_^1_%STA* TEMP+1_^1_%LDA* TEMP_'RESTORE_^1_%LDQ* (ZERO),€jQ_^1_$STQ* TEMP_^1_$JMP*_!(EXP27)_^1************************************ FTN 3.1 **************************_^1EXPMI TCQ Q_^1_%NUM $B9D8_(NEG. EXPONENT_^1EXPPL NOP_]_^1_%NUM $BAD8_(POS. EXPONENT_^1ZERO_!NUM 0_^1_%BSS TEMP(2)_^1_%BSS TEMP2(2)_^1_%EQU EXP10(Q8EXP1)_^1************************************ FTN 3.1 ($) **********************_^1_$END_]_^__ jPQ8EXP9 CSY/ H19 P€1_%NAM Q8EXP9_'DECK-ID H19 FTN 3.3 RUNTIME_%SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3_^1*_$SMALL COMPUTER DEVELOPMENT DIVISION, LA JOLLA CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1973_^1_%SPC 2_^1*CREATE A FLOATING PT. NO. FROM AN ABSOLUTE 2 WORD INTEGER_^1* COEFFICIENT (STARTING AT P,P+1) AND SIGNED DECIMAL INTEGER_^1* EXPONENT (IN P1)_^1*OUTPUT IS IN P,P+€€1,ERROR INDICATOR IN P1(0= NO ERROR)_^1*_I( 1 = ERROR)_^1* ROUTINE SHOULD NOT BE ENTERED WITH 0 COEFFICIENT_^1_$ENT Q8EXP9,Q8EXPT,Q8EXP2_^1_%EXT HFLOT_OFTN 3.3_^1_%EXT PARABS_NFTN 3.3_^1_%EXT IFALT_OFTN 3.3_^1_%EQU THREE($04)_JFTN 3.3_^1GETP NOP 0_"GET ADDRESS OF PARAMETER_^1_%STQ* QSTEMP_'SAVE CALLER'S Q_7FTN 3.3_^1_%LDA* EXP9_PFTN 3.3_^1_%RTJ PARABS_NFTN 3.3_^1_%RAO* EXP9€€_PFTN 3.3_^1_%LDQ* QSTEMP_NFTN 3.3_^1_$JMP*_!(GETP)_^1QSTEMP NUM 0_O**FTN 3.0**_^1QSAVE NUM 0_^1EXP61 NUM $B9D4_$FMU_^1EXP62 NUM $BAD4_$DVI_^1Q8EXP9 NOP_]_^1_$LDA- $FF_^1_%STA TEMPI_^1_%STQ* QSAVE_(SAVE CONTENTS OF Q-REG_^1_$RTJ* GETP_^1_$STA* EXP30_^1_$STA* EXP31_^1_$STA- $FF_%LOC OF 2 WORD FRACTION_^1_$RTJ* GETP_"DECIMAL EXPONENT_^1_$STA* EXP90+1_^1EXP90 LDA+_]_^1_$STA* TEM€€P_^1_$ENQ 0_^1_$STQ* ADD+1_^1_$STQ* (EXP90+1)_^1_$LDQ* EXP61_^1_$SAP EXP92-*-1_^1_$TCA A_^1_$STA* TEMP_^1_$LDQ* EXP62_^1EXP92 STQ* EXP79_^1_$INA -40_^1_%SAP EXP59_^1_%JMP* EXP99_(EXPONENT IS_^1EXP59 ENA 0_^1_$RAO* (EXP90+1) TOO BIG-OVERFLOW_^1_$STA* (EXP30)_^1_$STA- 1,I_^1_%TRQ A_,A MULTIPLY MEANS POS EXP ($B9D4)_^1_%EOR* EXP62_(DIV MEANS NEG EXP ($BAD4)_^1_%SAZ EXP60_(SKI€€P IF UNDERFLOW_^1_$LDA* TEMP_^1_$SAM EXP60-*-1_^1_%LDA- $11_*$7FFF LARGEST NUMBER_266*1437_^1_$STA* (EXP30)_^1_$ENA_!-0_^1_$STA- 1,I_^1EXP60 LDA* TEMPI_^1_$STA- $FF_^1_%LDQ* QSAVE_(RESTORE Q-REG_^1_$JMP* (EXP9)_^1EXP99 LDQ* TEMP_^1_$LRS_!3_^1_$SQN EXP93-*-1_^1_$LLS_!3_^1_$QLS_!1_^1_$RTJ* EXP27_^1_$JMP* EXP89_^1EXP93 QLS_!1_^1_$TCQ_!Q_^1_$RTJ* EXP27_^1_$ENQ_!0_^1_$LLS_!3_^1_€€$SQZ_!EXP89-*-1_^1_$QLS_!1_^1_$ADQ* ECON_^1_$STQ* EXP21+3_^1EXP21 RTJ HFLOT_(LDA EXPTB,Q_:FTN 3.3_^1_$NUM $B9D4_$FMU TEMP+3_^1_$NUM 0_)STA TEMP+3_^1_$ADC TEMP+3_^1_$ADC TEMP+3_^1EXP89 ENQ -28_^1_$STQ* TEMP+1_^1_$LDA- 1,I_^1_$ALS 4_^1_$LDQ* (EXP30)_!NORMALIZE FRACTION_^1_$SAN EXP71-*-1_^1_$SQN EXP71-*-1_^1_$JMP* EXP60_'ZERO_^1EXP71 SQM EXP70-*-1_^1_$LLS 1_^1_$RAO* T€€EMP+1_^1_$JMP* EXP71_^1EXP70 STQ* (EXP30)_^1_$STA- 1,I_^1_$LDQ* TEMP+1_^1_$INQ_!23_^1_#SQZ EXP74-*-1_^1_$SQM EXP40-*-1 ROUNDING NECESSART_^1EXP68 INQ -23_^1_$TCQ_!A_^1_$ADD =N$80_!NO IS FORMED MSH,LSH,EXP -THEN SHIFTED_^1_$ADD- 1,I_^1_$LDQ* (EXP30)_^1_$JMP* EXP78_^1EXP40 TCQ Q_^1_$STQ* ADD+1_^1SHIFT ALS 7_^1_%SAM EXP75-*-1_G**FTN 3.1**_^1EXP74 LDQ* (EXP30)_^1_$LDA- 1,I_^€€1_$AND =N$FE00_^1_$JMP* EXP77_^1EXP75 LDA- 1,I_M**FTN 3.1**_^1_$ARS 9_^1_$AND =N$7F_^1_$INA 1_^1_$ENQ 0_^1_$LLS 9_^1_$ADQ* (EXP30)_^1_%SQM EXP77_(Q = - NO OVERFLOW OF MSB_.66*1437_^1_%SQN EXP76_(Q = 0 MSB OVERFLOWED_266*1437_^1_%ENQ -0_+$FFFF_A66*1437_^1_%JMP* EXP77_O66*1437_^1EXP76 ENA 1_,ADD ONE TO THE EXPONENT_/66*1437_^1_%LDQ =N$8000_M66*1437_^1EXP77 ADD =N$97_^1*_€€%ADD IN EXPONENT FOR TRUNCATED PORTON OF INPUT_^1ADD_!ADD =N0_^1EXP78 LLS_!23_^1_$STQ* (EXP30)_^1_$STA- 1,I_^1_%RTJ IFALT_(CLEAR ALL FP ERRORS_3FTN 3.3_^1_%ADC THREE_OFTN 3.3_^1_$RTJ* (EXP21+1)_^1EXP79 NUM $B9D4_^1EXP30 NUM 0_'FMU OR FDV TEMP_^1_$ADC TEMP+3_!STA NUM_^1EXP31 NUM 0_^1_%RTJ IFALT_(CHECK FOR ANY FP ERROR_0FTN 3.3_^1_%ADC THREE_OFTN 3.3_^1_%INA -2_RFTN 3.3_^1_€€%SAZ EXP32_(SKIP IF NO ERRORS_5FTN 3.3_^1_$JMP* EXP59_^1_$BSS TEMPI,TEMP(5)_^1EXP32 JMP* EXP60_^1EXP27 NOP 0_^1_$ADQ* ECON_^1_%STA* TEMP+3_^1_%LDA- 1,Q_^1_%STA* TEMP+4_^1_%LDA* TEMP+3_$RESTORE A REG._^1_$LDQ* (EXPTB+1),Q_^1_$STQ* TEMP+3_^1_$JMP* (EXP27)_^1ECON ADC EXPTB_^1* BACKWARDS_!1D32_'1D24_'1D16_'1D8_^1_$NUM $75CE,$E2D7,$6869,$E10E,$5B47,$0DE5,$4DDF,$5E10_^1*_,1_^1EXPTB N€ÚUM $40C0,0_^1*_,10_#1D2_#1D3_$1D4_'1D5_^1EXPT2 NUM $4250,0,$43E4,0,$457D,0,$474E,$2000,$48E1,$A800_^1*_)1D6_)1D7_^1_$NUM $4A7A,$1200,$4C4C,$4B40_^1_$EQU Q8EXPT(EXPTB),Q8EXP2(EXPT2)_^1_$EQU EXP9(Q8EXP9)_^1_$END_]_^__ÚPQ8QGTX CSY/ H20 P€1_%NAM Q8QGTX_'DECK-ID H20 FTN 3.3 RUNTIME_%SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3_^1*_$SMALL COMPUTER DEVELOPMENT DIVISION, LA JOLLA CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1973_^1_%SPC 2_^1_%ENT Q8QGET_^1_%ENT SETBFR_MPSR 1072_^1_%EQU LIST(25)_^1Q8QGET 0_"0_^1_%LDQ- LIST,I_^1_%RAO- LIST,I_^1_%JMP* (Q8QGET)_^1SETBFR NUM 0_RPSR 1072_^1_%RAO* SETBFR€N_MPSR 1072_^1_%RAO* SETBFR_MPSR 1072_^1_%JMP* (SETBFR)_KPSR 1072_^1_%END_]_^__NPQ8QIO CSY/ H21 P€1_%NAM Q8QIO_(DECK-ID H21 FTN 3.3 RUNTIME_%SUMMARY-102_^1*_*1700 MASS STORAGE FORTRAN VERSION 3.3_^1*_$SMALL COMPUTER DEVELOPMENT DIVISION, LA JOLLA CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1973_^1_%SPC 2_^1_%ENT Q8QINI_^1_%ENT Q8QX_^1_%ENT Q8QEND_^1_%ENT Q8QGET_^1_%ENT SETBFR_^1_%ENT IOERR_^1_%EXT* FORMTR_^1_%EXT* COMMON_^1_%EXT* ISAVE_^1_%EXT* BINARY_F$$$$MOD$$€€$$_^1_%EQU LPMSK(2)_^1_%EQU ONEBIT($23)_^1_%EQU NZERO($12)_^1_%EQU ZERO($22)_^1_%EQU ADISP($EA)_^1_%EQU PRLVL($EF)_^1_%EQU AMONI($F4)_^1_%EQU VR(1)_^1_%EQU VI(2)_^1_%EQU ICODE(3)_^1_%EQU IBX(13)_^1_%EQU JBX(14)_^1_%EQU LIST(25)_^1_%EQU MV(26)_^1_%EQU BUFFER(29)_^1_%EQU FORMAT(30)_^1_%EQU DEFLAG(35)_^1_%EQU TEMP(36)_^1*_$ORGANIZATION OF USERS BUFFER_^1*_(1 LWA OF B€€UFFER_^1*_(2 RC FOR READ/WRITE_!*CALLING SEQUENCE TO MONITOR_^1*_(3 COMPLETION ADDRESS *_^1*_(4 THREAD_-*_^1*_(5 LU_1*_^1*_(6 MESSAGE LENGTH_$*_^1*_(7 FWA OF MESSAGE_$*_^1*_(8-18 UNUSED_^1*_'19 FWA OF IO BUFFER_^1*_]_^1*_$SETBFR_!ENTRY FOR SAVING BUFFER ADDRESS_^1*_]_^1SETBFR 0_"0_)***SET FORTRAN BUFFER ADDRESS_^1_%RTJ* GETNTY_'COMPUTE ADDRESS OF COMMON FOR_^1_%ADC COMMON_)RUN-AN€€YWHERE CODE_^1GETNTY 0_"0_)***COMMON ENTRY FOR RUN-ANYWHERE CODE_^1_%STQ COMMON_'SAVE USERS Q-REG_^1_%LDQ- I_^1_%STQ ISAVE_(SAVE USERS I-REG_^1_%LDQ* GETNTY_'=ADDRESS OF ORDINAL TO FWA OF PROGRAM_^1_%LDA- $F6_*NO RELATIVE ALLOWED IN UPPER BANK **MSOS4.0**_^1_%SAM K1G65K_J**MSOS4.0**_^1_%LDA- (ZERO),Q_$GET ORDINAL_^1_%AAQ A_^1_%AND- LPMSK+15_^1_%JMP* *+3_M**MSOS4.0**_^1K1G65K L€€DA- (ZERO),Q_$GET ORDINAL_7**MSOS4.0**_^1_%AAQ A_O**MSOS4.0**_^1_%STA- I_,=FWA OF COMMON_^1_%STA* ARGU2_^1_%INQ -2_^1_%LDQ- (ZERO),Q_$=RETURN ADDRESS TO SETBFR_^1_%LDA- $F6_*NO RELATIVE ALLOWED IN UPPER BANK **MSOS4.0**_^1_%SAM K2G65K_J**MSOS4.0**_^1_%LDA- (ZERO),Q_$=FWA OF USERS BUFFER_^1_%SAP NEXT-*-1_$TEST IF ADDRESS NORMALIZED_^1_%AAQ A_,NO, NORMALIZE ADDRESS_^1_%AND- LPM€€SK+15_^1_%JMP* NEXT_L**MSOS4.0**_^1K2G65K LDA- (ZERO),Q_H**MSOS4.0**_^1NEXT_!STA* ARGU1_(SAVE IN PERMANENT LOC._^1_%INQ 1_^1_%LDA- $F6_*NO RELATIVE ALLOWED IN UPPER BANK **MSOS4.0**_^1_%SAM K3G65K_J**MSOS4.0**_^1_%LDA- (ZERO),Q_$=ADDRESS OF BUFFER LENGTH_^1_%SAP NEXT1-*-1_#TEST IF ADDRESS NORMALIZED_^1_%AAQ A_^1_%AND- LPMSK+15_^1_%JMP* NEXT1_K**MSOS4.0**_^1K3G65K LDA- (ZERO),Q€€_H**MSOS4.0**_^1NEXT1 INQ 1_^1_%STQ* SETBFR_'SAVE RETURN ADDRESS_^1_%TRA Q_^1_%LDA- (ZERO),Q_$=BUFFER LENGTH_^1_%ADD* ARGU1_^1_%INA -1_^1_%STA* (ARGU1)_%=LWA OF BUFFER_^1_%LDQ ISAVE_)RESTORE I_^1_%STQ- I_^1_%LDQ COMMON_%RESTORE Q_^1_%JMP* (SETBFR)_$RETURN_^1*_]_^1*_$Q8QINI_!FIRST CALL SETUP BY FORTRAN - INITIALIZE IO PARAMETERS_^1*_]_^1*_*FORMAT ONLY - DEFLAG=-0 (RWFLAG)_^1*_€€*LIST FORMAT - DEFLAG= 1 (RWFLAG)_^1*_*ENCODE/DECODE DEFLAG=-1 (RWFLAG)_^1*_]_^1Q8QINI 0_"0_)***INITIALIZE IO PARAMETERS_^1_%STQ* (ARGU2)_%SAVE USERS Q-REG_^1_%LDQ* ARGU2_(=LOC OF COMMON_^1_%LDA- I_^1_%STA- VI,Q_)SAVE USERS I-REG_^1_%STQ- I_,I-REG=LOC OF SCRATCH AREA_^1_%LDA* Q8QINI_'=RETURN ADDRESS_^1_%STA- VR,Q_^1_%ENA 0_^1_%STA- DEFLAG,I_$INITIALIZE READ/WRITE-ENCODE/DECODE FLA€€G_^1_%RTJ* NORML_(GET 1ST PARAMETER_^1_%STA- TEMP,I_'=FORTRAN FORMAT FLAG_^1_%ALS 4_,TEST FOR NO LIST_^1_%SAM NEXT2-*-1_^1_%ENQ -0_+YES, SET FLAG_^1_%STQ- DEFLAG,I_^1NEXT2 ALS 2_^1_%ARS 16_+(READ=0/WRITE=-0)_^1_%STA- ICODE,I_%=ICODE FOR ENCODE/DECODE_^1_%RAO- VR,I_^1_%RTJ* NORML_(GET 3RD PARAMETER_^1_%LDQ- TEMP,I_^1_%QLS 2_,TEST IF ADDRESS OF LU_^1_%SQM NEXT3-*-1_^1_%TRA Q€€_,YES, GET ACTUAL LU_^1_%LDA- (ZERO),Q_^1NEXT3 TRA Q_,TEST IF LU IS LESS THAN 5_^1_%INQ -5_^1_%SQP NEXT31-*-1_^1_%LDA* LUCONV+4,Q_"CONVERT UNIT 1-4 VIA TABLE_^1NEXT31 ENQ 4_^1_%AND- LPMSK+12_^1_%STA* (ARGU1),Q_#SAVE LU IN CALLING SEQUENCE_^1_%LDA- TEMP,I_'GET FORTRAN FORMAT FLAG_'$$$$MOD$$$$_^1_%ALS 1_K$$$$MOD$$$$_^1_%SAM ASCII-*-1_#TEST IF ASCII/BINARY REQUEST_!$$$$MOD$$$$_€€^1_%LDA- ONEBIT+15_#SET BINARY REQUEST_,$$$$MOD$$$$_^1_%STA- DEFLAG,I_D$$$$MOD$$$$_^1_%JMP* NEXT32_^1ASCII LDA- ONEBIT+12_#SET ASCII MODE IN LU_^1_%EOR* (ARGU1),Q_^1_%STA* (ARGU1),Q_^1NEXT32 RTJ* NORML_(GET 4TH PARAMETER_^1_%LDQ- TEMP,I_^1_%QLS 3_,TEST IF ADDRESS OF ADDRESS OF FORMAT_^1_%SQM NEXT4-*-1_^1_%TRA Q_,YES, GET ADDRESS OF FORMAT_^1_%LDA- (ZERO),Q_^1NEXT4 STA- FORMAT,€€I_$=FORMAT LOCATION_^1_%LDA* (ARGU1)_%=LWA OF BUFFER_^1_%SUB* ARGU1_(=FWA OF BUFFER_^1_%INA -17_*(LWA - FWA + 1) = LENGTH OF BUFFER_#92*3157_^1_%ENQ 5_^1_%STA* (ARGU1),Q_#SET WORDS OF INPUT=LENGTH OF BUFFER_^1_%INQ 1_^1_%LDA* ARGU1_^1_%INA 18_+=FWA OF MESSAGE BUFFER_^1_%STA* (ARGU1),Q_#SAVE IN CALLING SEQUENCE_^1_%STA- BUFFER,I_^1*_]_^1XL_#TRA Q_)BLANK OUT ENCODE/DECODE BUFFER€€_^1_%LDA =N$2020_^1_%STA- (ZERO),Q_^1_%INQ 1_^1_%TRQ A_^1_%LDQ* (ARGU1)_"REACHED END OF BUFFER_^1_%TCQ Q_^1_%AAQ Q_^1_%SQP 1_^1_%JMP* XL_(NO_^1_%ENA 0_^1_%STA* A_^1_%LDA- DEFLAG,I_^1_%SAM NEXT5-*-1_#TEST IF FORMAT ONLY_^1_%LDQ- VR,I_)NO, RETURN TO GET LIST_^1_%JMP- (ZERO),Q_^1NEXT5 ENQ 0_,SET VARIABLES/LIST=0_^1_%JMP* NEXT8_^1NORML 0_"0_)***NORMALIZE USERS PARAMETER ADDR€€ESS_^1_%LDQ- VR,I_^1_%LDA- $F6_*NO RELATIVE ALLOWED IN UPPER BANK **MSOS4.0**_^1_%SAM K4G65K_J**MSOS4.0**_^1_%LDA- (ZERO),Q_^1_%SAP NEXT6-*-1_^1_%AAQ A_^1_%AND- LPMSK+15_^1_%JMP* NEXT6_K**MSOS4.0**_^1K4G65K LDA- (ZERO),Q_H**MSOS4.0**_^1NEXT6 RAO- VR,I_^1_%JMP* (NORML)_^1ARGU1 NUM 0_,=BUFFER ADDRESS_^1ARGU2 NUM 0_,=LOC OF COMMON_^1LUCONV NUM $08F9,$08FA,$08FB,$08FC_5$$$$MO€€D$$$$_^1*_]_^1*_$Q8QX_#SECOND CALL SETUP BY FORTRAN - PASS CURRENT LIST ADDRESS_^1*_]_^1Q8QX_!0_"0_)***INITIALIZE FORMATTING_^1_%LDA* A_,TEST FOR ERRORS_^1_%SAP OK-*-1_^1_%RAO* Q8QX_)YES, UPDATE RETURN ADDRESS_^1_%JMP* (Q8QX)_'RETURN_^1OK_#LDQ* Q8QX_^1_%STQ- VR,I_)SAVE RETURN ADDRESS_^1_%RTJ* NORML_(GET LIST PARAMETERS_^1_%LDQ- DEFLAG,I_$TEST IF FORMAT PROCESSING_^1_%SQZ NEXT7-*-€€1_%WAS INITIALIZED_^1_%ADQ- LPMSK+15_$TEST IF BINARY READ/WRITE_$$$$$MOD$$$$_^1_%INQ 0_K$$$$MOD$$$$_^1_%SQZ NEXT7-*-1_C$$$$MOD$$$$_^1_%JMP* GETOUT_'YES, CONTINUE PROCESSING_^1NEXT7 LDQ- LPMSK+15_$SET VARIABLES/LIST=MAX. NUMBER_^1NEXT8 STQ- MV,I_^1_%STA- LIST,I_'SAVE LIST PARAMETER ADDRESS_^1_%RAO- DEFLAG,I_$SET FLAG=PROCESSING INITIALIZED_^1_%LDA- ICODE,I_%TEST IF READ/WRITE RE€€QUEST_^1_%SAM FORM-*-1_^1_%LDQ* ARGU1_(READ REQUEST - GET INPUT RECORD_^1_%JMP* RWREQ_^1FORM_!LDA- DEFLAG,I_D$$$$MOD$$$$_^1_%SAP FORM1-*-1_#TEST IF BINARY/ASCII REQUEST_!$$$$MOD$$$$_^1_%RTJ BINARY_#***BINARY REQUEST_0$$$$MOD$$$$_^1_%LDA- ONEBIT+15_C$$$$MOD$$$$_^1_%STA- DEFLAG,I_D$$$$MOD$$$$_^1_%JMP* NEXT9_G$$$$MOD$$$$_^1FORM1 RTJ FORMTR_#***PROCESS FORMAT_0$$$$MOD$$$$_^1_%STA*€€ A_,SAVE ERROR FLAG_^1NEXT9 LDQ* ARGU1_(SET Q-REG=FWA OF BUFFER AREA_^1_%LDA- ICODE,I_%TEST IF WRITE REQUEST_^1_%SAM NEXT10-*-1_^1_%JMP* EXIT_)READ REQUEST - IO COMPLETE_^1NEXT10 LDA- JBX,I_(REQUEST=WRITE - SET UP WORD COUNT FOR OUTPUT_^1_%INA -1_^1_%ADD- IBX,I_^1_%SAN WRDCNT_N86*2748_^1_%ENA 1_,INSURE MINIMUM WORD COUNT_-86*2748_^1WRDCNT STA- 5,Q_*SAVE WORD COUNT IN CALLING S€€EQUENCE_"86*2748_^1RWREQ ENA 0_)***BUILDING CALLING SEQUENCE_^1_%STA- 3,Q_*SET THREAD=0_^1_%RTJ* HERE_)ABSOLUTIZE RETURN ADDRESS_^1HERE_!0_"0_^1_%LDA* HERE_^1_%INA RETURN-HERE_^1_%STA- 2,Q_*=COMPLETION ADDRESS_^1_%LDA- ICODE,I_^1_%AND* WCODE_(=WRITE REQUEST_^1_%SAN NEXT11-*-1_^1_%LDA* RCODE_(=READ REQUEST_^1NEXT11 EOR- PRLVL_(SET COMPLETION PRIORITY=CURRENT PRIORITY_^1_%STA- 1,€€Q_*=REQUEST CODE_^1_%TRQ A_^1_%INA 1_,=ADDRESS OF CALLING SEQUENCE_^1_%STA* CALL_^1_%RTJ- (AMONI)_"***CALL MONITOR_^1_%NUM $2000_(INDIRECT REQUEST_2**MSOS4.0**_^1CALL_!ADC 0_^1_%JMP- (ADISP)_%MAKE A DISPATCHER CALL_^1RETURN SQP NOERRS-*-1_"TEST FOR ERRORS IN READ/WRITE_^1_%ENA -1_+YES, SET ERROR FLAG_^1_%LDQ* ARGU2_^1_%STQ- I_,=SCRATCH AREA IN USERS PROGRAM_^1_%STA* A_,SAVE E€€RROR FLAG_^1_%JMP* EXIT_^1NOERRS LDQ* ARGU2_(RESTORE ADDRESS OF SCRATCH AREA_^1_%STQ- I_,SAVE IN I-REGISTER_^1_%LDA- ICODE,I_^1_%SAM EXIT-*-1_$TEST IF REQUEST=WRITE_^1_%JMP* FORM_)PROCESS INPUT_^1EXIT_!LDQ- VR,I_)=RETURN ADDRESS_^1_%STQ* XIT_^1_%LDA- VI,I_^1_%LDQ- (I)_*RESTORE USERS Q-REG_^1_%STA- I_,RESTORE USERS I-REG_^1_%JMP* (XIT)_^1XIT_"NUM 0_^1A_$NUM 0_^1*_]_^1*_$Q8QEND_!L€€AST CALL SETUP BY FORTRAN - TERMINATE FORMAT PROCESSING_^1*_]_^1Q8QEND 0_"0_)***TERMINATE FORMAT PROCESSING_^1_%LDA* A_^1_%SAP OK1-*-1_^1_%JMP* (Q8QEND)_$RETURN IF ERRORS_^1OK1_"LDQ* Q8QEND_^1_%STQ- VR,I_)SAVE RETURN_^1_%ENA 1_^1_%STA- MV,I_)SET MV=1(LAST VARIABLE IN LIST)_^1GETOUT LDQ- LIST,I_'=PARAMETER TO BE PROCESSED_^1_%STA- LIST,I_'=NEXT PARAMETER_^1_%LDA- TEMP,I_'=RETURN T€€O FORMTR_^1_%STA* Q8QGET_^1_%JMP* (Q8QGET)_^1Q8QGET 0_"0_)***GET PARAMETER ADDRESS_^1_%LDQ* Q8QGET_'=RETURN ADDRESS TO FORMTR_^1_%STQ- TEMP,I_^1_%LDA- DEFLAG,I_^1_%SAM NEXT12-*-1_"TEST IF ENCODE/DECODE CALL_^1_%LDQ- VR,I_)NO, RETURN FOR NEXT PARAMETER IN LIST_^1_%JMP- (ZERO),Q_^1NEXT12 LDQ- LIST,I_'ENCODE/DECODE CALL(UPDATE LIST ADDRESS)_^1_%RAO- LIST,I_^1_%JMP* (Q8QGET)_^1*_]_^1*€0_$IOERR_!ENTRY TO RETURN ERROR FLAG FOR READ/WRITE STATEMENT_^1*_]_^1IOERR 0_"0_)***RETURN ERROR FLAG TO USER_^1_%RAO* IOERR_(ALLOW FTN USER ACCESS TO A-REG AFTER_^1_%LDA* A_^1_%JMP* (IOERR)_(READ/WRITE STATEMENT PROCESSING_^1WCODE NUM $4C00_L**MSOS4.0**_^1RCODE NUM $4800_K**MSOS4.0**_^1_%END_]_^__ 0PIOCODE CSY/ J01 P€1_%NAM IOCODE_'DECK-ID J01 FTN 3.3 RUNTIME_%SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3_^1*_$SMALL COMPUTER DEVELOPMENT DIVISION, LA JOLLA CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1973_^1_%SPC 2_^1*_+CALLING SEQUENCE_^1*_*RTJ ENCODE/DECODE_^1*_*ADC (BUFFER-*)_^1*_*ADC (FORMAT-*)_^1*_*ADC (NUMBER-*)_^1*_*ADC (LIST-*)_^1*_*FORMAT ADC ALPHA_^1*_0ALPHA AL€€F N,(----)_^1*_]_^1*_$GETNTY - SUBROUTINE TO COMPUTE THE FIRST WORD ADDRESS OF COMMON_^1*_]_^1_%ENT ENCODE_^1_%ENT DECODE_^1_%EXT* FORMTR_^1_%EXT* COMMON_^1_%EXT* ISAVE_^1_%EQU LPMSK(2)_^1_%EQU ZERO($22)_^1_%EQU VR(1)_^1_%EQU VI(2)_^1_%EQU ICODE(3)_^1_%EQU LIST(25)_^1_%EQU MV(26)_^1_%EQU BUFFER(29)_^1_%EQU FORMAT(30)_^1_%EQU ARGU1(31)_^1_%EQU ARGU2(32)_^1_%EQU ARGU3(€€33)_^1_%EQU ARGU4(34)_^1_%EQU DEFLAG(35)_^1_%NUM 0_,=ICODE(MEANS DECODE REQUEST)_^1DECODE 0_"0_)***DECODE ASCII INFORMATION FROM BUFFER_^1_%RTJ* GETNTY_'COMPUTE CURRENT ADDRESS FOR RUN-ANYWHERE CODE_^1_%ADC COMMON_'=POINTER TO START OF PROGRAM_^1_%NUM -0_+=ICODE(MEANS ENCODE REQUEST)_^1ENCODE 0_"0_)***ENCODE HEXIDECIMAL INFORMATION INTO BUFFER_^1_%RTJ* GETNTY_'COMPUTE CURRENT €€ADDRESS FOR RUN-ANYWHERE CODE_^1_%ADC COMMON_'=POINTER TO START OF PROGRAM_^1GETNTY 0_"0_)***GENERAL ENTRY FOR RUN-ANYWHERE CODE_^1_%STQ COMMON_'SAVE USERS Q-REG_^1_%LDQ- I_^1_%STQ ISAVE_(SAVE USERS I-REG_^1_%LDQ* GETNTY_^1_%LDA- (ZERO),Q_$=POINTER OF START OF PROGRAM_^1_%AAQ A_,NORMALIZE ADDRESS_^1_%STA- I_,=FWA OF COMMON_^1_%INQ -3_^1_%LDA- (ZERO),Q_$=ICODE_^1_%STA- ICODE,I_€€^1_%INQ 1_^1_%LDA- (ZERO),Q_$=RETURN TO USERS PROGRAM_^1_%STA- VR,I_^1_%ENA -1_^1_%STA- DEFLAG,I_^1_%RTJ* NORML_^1_%STA- BUFFER,I_$=BUFFER ADDRESS_^1_%RTJ* NORML_^1_%TRA Q_^1_%LDA- (ZERO),Q_^1_%STA- FORMAT,I_$=FORMAT ADDRESS_^1_%RTJ* NORML_^1_%TRA Q_^1_%LDA- (ZERO),Q_^1_%STA- MV,I_)==NUMBER OF VARIABLES/LIST_^1_%RTJ* NORML_^1_%STA- LIST,I_'=ADDRESS OF LIST_^1_%RTJ FORMTR_'FORM€€AT DATA_^1_%STA* XIT+1_^1_%LDA- VR,I_^1_%STA* XIT_^1_%LDA- VI,I_)RESTORE USERS I-REG_^1_%LDQ- (I)_*RESTORE USERS Q-REG_^1_%STA- I_^1_%LDA* XIT+1_^1_%JMP* (XIT)_(RETURN TO USER_^1_%BSS XIT(2)_^1NORML 0_"0_)***NORMALIZE FORTRAN ADDRESS-_^1_%LDQ- VR,I_^1_%RAO- VR,I_^1_%LDA- $F6_*NO RELATIVE ALLOWED IN UPPER BANK **MSOS4.0**_^1_%SAM KG65K_K**MSOS4.0**_^1_%LDA- (ZERO),Q_^1_%SAP NXT€†-*-1_^1_%AAQ A_^1_%AND- LPMSK+15_^1NXT_"JMP* (NORML)_^1KG65K LDA- (ZERO),Q_H**MSOS4.0**_^1_%JMP* (NORML)_I**MSOS4.0**_^1_%END_]_^__ †PPSUEDO CSY/ J02 P41_%NAM PSUEDO_'DECK-ID J02 FTN 3.3 RUNTIME_%SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3_^1*_$SMALL COMPUTER DEVELOPMENT DIVISION, LA JOLLA CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1973_^1_%SPC 2_^1_%ENT COMMON_^1_%ENT ISAVE_^1_%BZS COMMON(37)_^1_%EQU ISAVE(COMMON+2)_^1_%END_]_^__4PIGETCH CSY/ J03 P€1_%NAM IGETCH_'DECK-ID J03 FTN 3.3 RUNTIME_%SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3_^1*_$SMALL COMPUTER DEVELOPMENT DIVISION, LA JOLLA CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1973_^1_%SPC 2_^1*_$GET NEXT CHARACTER IN STRING_^1_%ENT IGETCH_^1_%ENT GETCH_^1_%EXT* EWRITE_^1_%EQU ZERO($22)_^1_%EQU ICODE(3)_^1_%EQU ARGU3(33)_^1_%EQU ARGU4(34)_^1_%EQU €€DEFLAG(35)_^1_%EQU MAXCH(28)_^1IGETCH 0_"0_)***PICK UP NEXT CHARACTER IN_^1_%LDQ- DEFLAG,I_$TEST IF READ/WRITE REQUEST_^1_%SQM BYPASS-*-1_^1_%LDA- MAXCH,I_%YES, REDUCE CHARACTER COUNT(TOTAL)_^1_%INA -1_^1_%STA- MAXCH,I_^1_%SAP BYPASS-*-1_"TEST IF 80 CHARACTERS INTERPERTED_^1_%RTJ EWRITE_'YES, ERROR_^1GETCH 0_"0_)***ENTRY FOR FORMAT SCAN_^1_%LDQ* GETCH_^1_%STQ* IGETCH_^1BYPASS€@ LDQ- ARGU3,I_^1_%LDA- (ZERO),Q_$=WORD CONTAINING NEXT CHARACTER_^1_%LDQ- ARGU4,I_^1_%LDQ- (ZERO),Q_$=CHARACTER COUNT_^1_%AND* MSK-1,Q_^1_%INQ -2_^1_%SQZ OUT-*-1_^1_%ALS 8_,SHIFT TO LOWER HALF OF WRD_^1OUT_"JMP* (IGETCH)_^1MSK_"NUM $FF00_(THESE MASKS MUST BE IN CON_^1_%NUM $FF_,SECUTIVE LOC.(INDEXED)_^1_%END_]_^__@PIPACK CSY/ J04 P€1_%NAM IPACK_(DECK-ID J04 FTN 3.3 RUNTIME_%SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3_^1*_$SMALL COMPUTER DEVELOPMENT DIVISION, LA JOLLA CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1973_^1_%SPC 2_^1*_$PACK CHARACTER INTO A STRING_^1_%ENT IPACK_^1_%EXT* EWRITE_^1_%EXT* CHCNT_^1_%EQU ZERO($22)_^1_%EQU MSK($1A)_$=$FF00_^1_%EQU ICODE(3)_^1_%EQU IB(5)_^1_%EQU €€ IBX(13)_^1_%EQU JBX(14)_^1_%EQU MAXCH(28)_^1_%EQU BUFFER(29)_^1_%EQU ARGU3(33)_^1_%EQU ARGU4(34)_^1_%EQU DEFLAG(35)_^1IPACK 0_"0_)***STORE CHARACTER INTO THE_^1_%LDA- DEFLAG,I_$TEST IF ENCODE/DECODE CALL_^1_%ALS 15_^1_%SAP NXT-*-1_^1_%LDA- ICODE,I_%IS TRANSFER FROM BUFFER_^1_%INA -1_+INTO FORMAT STATEMENT_^1_%SAZ NOCHK_(YES SKIP BUFFER LENGTH CHECK_^1_%LDQ- BUFFER,I_$N€€O(READ/WRITE)-CHECK IF BUFFER SIZE EXCEEDED_^1_%INQ -18_^1_%LDA- (ZERO),Q_$LWA OF BUFFER_^1_%SUB- ARGU3,I_%=CURRENT ADDRESS TO BE PACKED_^1_%SAP NXT-*-1_^1P1_#RTJ EWRITE_^1NXT_"LDQ- DEFLAG,I_$TEST IF READ/WRITE REQUEST_^1_%QLS 15_^1_%LDA- MAXCH,I_^1_%INA -1_+REDUCE CHARACTER COUNT_^1_%STA- MAXCH,I_^1_%SAM CHECK-*-1_#IF CHARACTER COUNT LT ZERO(=FULL LINE)_^1NOCHK JMP* NXT4_)A€€ND READ/WRITE REQUEST-INSERT / IN RECORD_^1CHECK SQM NXT1-*-1_^1_%RTJ EWRITE_^1NXT1_!LDQ- ARGU4,I_^1_%LDA- (ZERO),Q_^1_%INA -2_+=ORDINAL TO CHARACTER/WORD_^1_%SAZ NXT2-*-1_$TEST WHICH 1/2 OF WORD CHARACTER IS_^1_%ENA 13_+UPPER 1/2 (INSERT CARRIAGE RETURN)_^1_%ALS 8_^1_%RAO- (ZERO),Q_$=UPDATE ORDINAL_^1_%LDQ- ARGU3,I_^1_%STA- (ZERO),Q_$STORE IN BUFFER_^1_%JMP* NXT3_^1NXT2_!LD€€Q- ARGU3,I_%PACK IN LOWER 1/2 OF WORD IN BUFFER_^1_%LDA- (ZERO),Q_^1_%AND- MSK_^1_%INA 13_+ADD IN CARRIAGE RETURN_^1_%STA- (ZERO),Q_^1_%RAO- (ZERO),Q_^1_%LDQ- ARGU4,I_^1_%ENA 1_^1_%STA- (ZERO),Q_^1_%INQ -1_^1_%RAO- (ZERO),Q_^1NXT3_!LDA CHCNT_(RESET CHARACTER COUNT(TOTAL/LINE)_^1_%STA- MAXCH,I_^1NXT4_!LDQ- ARGU4,I_%TEST IF CHATACTER COUNT=2_^1_%LDA- (ZERO),Q_^1_%LDQ- ARGU3,I_^1_€h%INA -2_^1_%SAZ NXT5-*-1_^1_%LDA- IB,I_)NO, SHIFT CHARACTER INTO_^1_%ALS 8_.UPPER HALF OF WORD_^1_%STA* TEMP_^1_%LDA- (ZERO),Q_^1_%AND- MSK-16_'$00FF_^1_%ADD* TEMP_)COMBINE WITH LOWER HALF_^1_%JMP* XIT_^1NXT5_!LDA- (ZERO),Q_$MASK CHARACTER IN LOWER U/I OF WORD_^1_%AND- MSK_^1_%ADD- IB,I_^1XIT_"STA- (ZERO),Q_^1_%JMP* (IPACK)_^1_%BZS TEMP(1)_^1_%END_]_^__ hPUPDATN CSY/ J05 P€1_%NAM UPDATN_'DECK-ID J05 FTN 3.3 RUNTIME_%SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3_^1*_$SMALL COMPUTER DEVELOPMENT DIVISION, LA JOLLA CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1973_^1_%SPC 2_^1*_$UPDATE BUFFER/FORMAT COUNTERS_^1_%ENT UPDATE_^1_%EQU ZERO($22)_^1_%EQU ARGU3(33)_^1_%EQU ARGU4(34)_^1UPDATE 0_"0_)***UPDATE WORD AND CHARACTER_^1_%LDQ- ARGU€à4,I_%SET CHARACTER COUNT=3-CNT_^1_%ENA 3_^1_%SUB- (ZERO),Q_^1_%STA- (ZERO),Q_^1_%INA -1_^1_%SAN XIT-*-1_%TEST CHARACTER COUNT=1_^1_%LDQ- ARGU3,I_^1_%RAO- (ZERO),Q_$YES, UPDATE WORD COUNT_^1XIT_"JMP* (UPDATE)_^1_%END_]_^__àPDECPL CSY/ J06 P€1_%NAM DECPL_(DECK-ID J06 FTN 3.3 RUNTIME_%SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3_^1*_$SMALL COMPUTER DEVELOPMENT DIVISION, LA JOLLA CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1973_^1_%SPC 2_^1*_$DETERMINE THE NUMBER OF CHARACTERS BEHIND THE_^1*_$DECIMAL POINT_^1_%ENT DECPL_^1_%EXT* GETCH_^1_%EXT* UPDATE_^1_%EXT* INTGR_^1_%EQU NXTFLD($E0)_^1_%EQU IB(5)€€_^1_%EQU IFIELD(7)_^1_%EQU JFIELD(8)_^1_%EQU IX(11)_^1_%EQU JX(12)_^1_%EQU ARGU1(31)_^1_%EQU ARGU3(33)_^1_%EQU ARGU4(34)_^1DECPL 0_"0_)***NO. OF DECIMAL PLACES SPEC_^1_%LDA- IFIELD,I_^1_%STA- NXTFLD_^1_%LDA- ARGU1,I_^1_%ADD- IX,I_^1_%STA- ARGU3,I_%=FORMAT+WORD COUNT_^1_%ENA 0_^1_%STA- IB,I_^1_%ENA JX_^1_%ADD- I_^1_%STA- ARGU4,I_%=CHARACTER CNT_^1_%RTJ GETCH_(GET FORMAT C€dHARACTER_^1_%INA -$2E_)TEST IF CHARACTER=PERIOD_^1_%SAN NXT-*-1_^1_%ENA IX_+YES, UPDATE FORMAT COUNT_^1_%ADD- I_^1_%STA- ARGU3,I_^1_%INA 1_^1_%STA- ARGU4,I_^1_%RTJ UPDATE_^1_%RTJ INTGR_(COMPUTE INTEGER VALUE_^1NXT_"LDA- IB,I_)=NO. OF PLACES BEYOND THE_^1_%STA- JFIELD,I_'DECIMAL POINT_^1_%LDA- NXTFLD_^1_%STA- IFIELD,I_^1_%JMP* (DECPL)_^1_%END_]_^__ dPINTGR CSY/ J07 P€1_%NAM INTGR_(DECK-ID J07 FTN 3.3 RUNTIME_%SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3_^1*_$SMALL COMPUTER DEVELOPMENT DIVISION, LA JOLLA CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1973_^1_%SPC 2_^1*_$DETERMINE FIELD WIDTH AS SPECIFIED BY FORMAT_^1*_$AND CONVERT INTEGER VALUE_^1_%ENT INTGR_^1_%EXT* GETCH_^1_%EXT* UPDATE_^1_%EQU MSK(6)_'=$F_^1_%EQU I10($46)_€€$=10_^1_%EQU IB(5)_^1_%EQU IX(11)_^1_%EQU JX(12)_^1_%EQU IR1(15)_^1_%EQU ARGU1(31)_^1_%EQU ARGU3(33)_^1_%EQU ARGU4(34)_^1INTGR 0_"0_)***CONVERT INTEGER VALUES IN_^1_%ENA 0_^1_%STA- IB,I_^1LOOP_!LDA- ARGU1,I_%=ADDRESS OF FORMAT_^1_%ADD- IX,I_^1_%STA- ARGU3,I_%=CURRENT WORD TO PROCESS IN FORMAT_^1_%ENA JX_^1_%ADD- I_^1_%STA- ARGU4,I_%=CHARACTER IN FORMAT_^1_%RTJ GETCH_(GET€€ FORMAT CHARACTER_^1_%TRA Q_,SAVE CHARACTER IN Q-REG_^1_%INA -$20_^1_%SAN NXT-*-1_^1_%JMP* ENDLP_(IGNORE BLANKS IN FORMAT_^1NXT_"TRQ A_^1_%INA -$30_)TEST IF CHARACTER IS NON-_^1_%SAP NXT1-*-1_^1_%JMP* (INTGR)_%=NON-NUMERIC CHARACTER - TERMINATE_^1NXT1_!TCQ A_^1_%INA $39_^1_%SAP NXT2-*-1_^1_%JMP* (INTGR)_%TERMINATE_^1NXT2_!TRQ A_^1_%AND- MSK_*MASK 4-BITS OF ASCII NUMBER_^1€_%STA- IR1,I_^1_%LDA- IB,I_)COMPUTE INTEGER NUMBER_^1_%MUI- I10_^1_%ADD- IR1,I_^1_%STA- IB,I_)IB=IR1+IB*10_^1ENDLP ENA IX_+UPDATE FORMAT COUNTS_^1_%ADD- I_^1_%STA- ARGU3,I_^1_%INA 1_^1_%STA- ARGU4,I_^1_%RTJ UPDATE_'UPDATE CHARACTER COUNT_^1_%JMP* LOOP_^1_%END_]_^__ PSPACEN CSY/ J08 P€1_%NAM SPACEN_'DECK-ID J08 FTN 3.3 RUNTIME_%SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3_^1*_$SMALL COMPUTER DEVELOPMENT DIVISION, LA JOLLA CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1973_^1_%SPC 2_^1*_$INSERT BLANKS INTO BUFFER_^1_%ENT SPACEX_^1_%EXT* IGETCH_^1_%EXT* UPDATE_^1_%EXT* IPACK_^1_%EQU ZERO($22)_^1_%EQU IB(5)_^1_%EQU IX(11)_^1_%EQU JX(12)_^1_%E€€QU IBX(13)_^1_%EQU JBX(14)_^1_%EQU ARGU1(31)_^1_%EQU ARGU3(33)_^1_%EQU ARGU4(34)_^1SPACEX 0_"0_)***INSERT BLANKS_^1_%ENA $20_^1_%STA- IB,I_^1_%LDA- ARGU1,I_^1_%ADD- IBX,I_^1_%STA- ARGU3,I_^1_%ENA JBX_*PACK BLANK INTO BUFFER_^1_%ADD- I_^1_%STA- ARGU4,I_^1_%RTJ IPACK_^1_%ENA IBX_^1_%ADD- I_^1_%STA- ARGU3,I_^1_%INA 1_^1_%STA- ARGU4,I_^1_%RTJ UPDATE_'UPDATE BUFFER COUNTERS_^€1_%JMP* (SPACEX)_^1_%END_]_^__PHOLRTH CSY/ J09 P€1_%NAM HOLRTH_'DECK-ID J09 FTN 3.3 RUNTIME_%SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3_^1*_$SMALL COMPUTER DEVELOPMENT DIVISION, LA JOLLA CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1973_^1_%SPC 2_^1*_$NON-REENTRANT ENCODE/DECODE TO PACK HOLLERITH CHARACTERSFTN*3.2_^1*_$INTO A BUFFER. MODIFIED FOR FORTRAN 3.2 TO HANDLE H_"FTN*3.2_^1*_$FORMAT, OR ALTERNATE QUO€€TE OR ASTERISK H FORMAT PRODUCEDFTN*3.2_^1*_$INFORMATION._KFTN*3.2_^1*_]FTN*3.2_^1_%ENT HOLRTH_^1_%ENT QUOTE_MFTN*3.2_^1_%EXT* IGETCH_^1_%EXT* GETCH_^1_%EXT* UPDATE_^1_%EXT* IPACK_^1_%EXT* CHCNT_^1_%EQU ZERO($22)_^1_%EQU ICODE(3)_^1_%EQU IB(5)_^1_%EQU NUMBR(9)_^1_%EQU IX(11)_^1_%EQU JX(12)_^1_%EQU IBX(13)_^1_%EQU JBX(14)_^1_%EQU MAXCH(28)_^1_%EQU ARGU1(31)_^1_%EQU ARGU€€2(32)_^1_%EQU ARGU3(33)_^1_%EQU ARGU4(34)_^1_%EQU QAFLAG($D3)_GFTN*3.2_^1HOLRTH 0_"0_)***PACK HOLLERITH CHARACTERS_^1_%RAO- NUMBR,I_^1LOOP_!LDA- NUMBR,I_%=TOTAL NUMBER CHARACTERS_^1_%INA -1_^1_%SAN NXT-*-1_^1OUT_"JMP* (HOLRTH)_^1NXT_"STA- NUMBR,I_^1_%LDA- ARGU2,I_^1_%ADD- IX,I_^1_%STA- ARGU3,I_^1_%ENA JX_^1_%ADD- I_^1_%STA- ARGU4,I_%GET CHARACTER FROM INPUT_^1_%LDA- ICODE,I_^€€1_%SAM PICKUP-*-1_^1_%RTJ IGETCH_)BUFFER_^1_%JMP* SAVE_^1PICKUP RTJ GETCH_^1SAVE_!STA- IB,I_^1_%ENA IX_^1_%ADD- I_^1_%STA- ARGU3,I_^1_%INA 1_^1_%STA- ARGU4,I_^1_%RTJ UPDATE_'UPDATE BUFFER COUNTS_^1_%LDA- IB,I_^1_%INA -$31_)TEST CHARACTER=$31_^1_%SAN NXT1-*-1_^1_%LDA- MAXCH,I_%YES, TEST IF 1ST CHARACTER_^1_%SUB CHCNT_*IN BUFFER_^1_%SAN NXT1-*-1_^1_%ENA 12_+YES, CHANGE TO €€TOP-OF-FORM_^1_%STA- IB,I_^1_%JMP* PACK_^1NXT1_!LDA- IB,I_)TEST CHARCACTER=$30_^1_%INA -$30_^1_%SAN PACK-*-1_^1_%LDA- MAXCH,I_%YES, TEST 1ST CHARACTER IN_^1_%SUB CHCNT_*BUFFER_^1_%SAN PACK-*-1_^1_%ENA 13_+YES, CHANGE TO CARRIAGE RETURN_^1_%STA- IB,I_^1PACK_!LDA- ARGU1,I_^1_%ADD- IBX,I_^1_%STA- ARGU3,I_^1_%ENA JBX_^1_%ADD- I_^1_%STA- ARGU4,I_^1_%RTJ IPACK_(PACK CHARACTER INTO€€ OUTPUT_^1_%ENA IBX_^1_%ADD- I_^1_%STA- ARGU3,I_^1_%INA 1_^1_%STA- ARGU4,I_^1_%RTJ UPDATE_^1_%JMP* LOOP_^1QUOTE NOP 0_,NON-REENTRANT ENCODE/DECODE ROUTINE FTN*3.2_^1*_8DESIGNED TO PROCESS QUOTE OR_(FTN*3.2_^1*_8ASTERISK GENERATED HOLLERITH_(FTN*3.2_^1*_8INFORMATION IN FORMAT STATEMENTS_#FTN*3.2_^1LOOP1 LDA- ARGU2,I_KFTN*3.2_^1_%ADD- IX,I_NFTN*3.2_^1_%STA- ARGU3,I_KFTN*3.2_^1€€_%ENA JX_PFTN*3.2_^1_%ADD- I_QFTN*3.2_^1_%STA- ARGU4,I_KFTN*3.2_^1_%LDA- ICODE,I_%READ/DECODE(ICODE=+)_0FTN*3.2_^1_%SAM WRTENC_'WRITE/ENCODE(ICODE=-)_/FTN*3.2_^1_%RTJ IGETCH_'GET NEXT CHARACTER FROM INPUT BUFFER FTN*3.2_^1_%JMP* SAVE1_MFTN*3.2_^1WRTENC RTJ GETCH_(GET NEXT CHARACTER FROM FORMAT BUFFERFTN*3.2_^1SAVE1 STA- IB,I_)IB CONTAINS NEXT CHARACTER_*FTN*3.2_^1_%ENA IX_PFT€€N*3.2_^1_%ADD- I_QFTN*3.2_^1_%STA- ARGU3,I_KFTN*3.2_^1_%INA 1_QFTN*3.2_^1_%STA- ARGU4,I_KFTN*3.2_^1_%RTJ UPDATE_'UPDATE FORMAT BUFFER COUNTS_)FTN*3.2_^1_%LDA- QAFLAG_LFTN*3.2_^1_%INA -1_PFTN*3.2_^1_%SAN ASTER_(IS QAFLAG = 1_7FTN*3.2_^1_%LDA- IB,I_)YES, APOSTROPHE_5FTN*3.2_^1_%INA -$27_NFTN*3.2_^1_%SAN CONTIN_'IS NEXT CHARACTER AN APOSTROPHE_$FTN*3.2_^1_%JMP* (QUOTE)_%YES, RET€€URN TO CALLING PROGRAM_%FTN*3.2_^1*_8AND CONTINUE FORMAT SCAN_,FTN*3.2_^1ASTER LDA- IB,I_)NO, ASTERISK_8FTN*3.2_^1_%INA -$2A_NFTN*3.2_^1_%SAN CONTIN_'IS NEXT CHARACTER AN ASTERISK_'FTN*3.2_^1_%JMP* (QUOTE)_%YES, RETURN TO CALLING PROGRAM_%FTN*3.2_^1*_8AND CONTINUE FORMAT SCAN_,FTN*3.2_^1*_]FTN*3.2_^1*_8NOT SECOND ASTERISK OR SECOND QUOTE FTN*3.2_^1*_8PACK CHARACTER INTO BUFFER_€€*FTN*3.2_^1*_]FTN*3.2_^1CONTIN LDA- IB,I_)OBTAIN NEXT CHARACTER_/FTN*3.2_^1_%INA -$31_)IS CHARACTER AN ASCII 1_-FTN*3.2_^1_%SAN NOTONE_LFTN*3.2_^1_%LDA- MAXCH,I_%YES, TEST IF FIRST CHARACTER_(FTN*3.2_^1_%SUB CHCNT_(IN BUFFER_;FTN*3.2_^1_%SAN NOTONE_LFTN*3.2_^1_%ENA 12_+YES, FIRST CHARACTER IN BUFFER IS 1 FTN*3.2_^1_%STA- IB,I_)CHANGE TO TOP OF FORM_/FTN*3.2_^1_%JMP* PACKER_LF€€TN*3.2_^1NOTONE LDA- IB,I_NFTN*3.2_^1_%INA -$30_)IS CHARACTER AN ASCII 0_-FTN*3.2_^1_%SAN PACKER_LFTN*3.2_^1_%LDA- MAXCH,I_%YES, TEST IF FIRST CHARACTER_(FTN*3.2_^1_%SUB CHCNT_(IN BUFFER_;FTN*3.2_^1_%SAN PACKER_LFTN*3.2_^1_%ENA 13_+YES, FIRST CHARACTER IN BUFFER IS 0 FTN*3.2_^1_%STA- IB,I_)CHANGE TO CARRIAGE RETURN_+FTN*3.2_^1PACKER LDA- ARGU1,I_%FORMAT ADDR/WRITE OR BUF ADDR€€/READ_!FTN*3.2_^1_%ADD- IBX,I_MFTN*3.2_^1_%STA- ARGU3,I_KFTN*3.2_^1_%ENA JBX_*CURRENT CHARACTER ADDRESS_+FTN*3.2_^1_%ADD- I_,FWA OF COMMON_7FTN*3.2_^1_%STA- ARGU4,I_KFTN*3.2_^1_%RTJ IPACK_(PACK CHARACTER INTO BUFFER_*FTN*3.2_^1_%ENA IBX_*CURRENT WORD IN BUFFER_.FTN*3.2_^1_%ADD- I_QFTN*3.2_^1_%STA- ARGU3,I_KFTN*3.2_^1_%INA 1_QFTN*3.2_^1_%STA- ARGU4,I_KFTN*3.2_^1_%RTJ UPDATE_'UP€JDATE BUFFER COUNTS (IX,JX)_(FTN*3.2_^1_%JMP* LOOP1_MFTN*3.2_^1_%END_]_^__ JPDCHX CSY/ J10 P€1_%NAM DCHX_)DECK-ID J10 FTN 3.3 RUNTIME_%SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3_^1*_$SMALL COMPUTER DEVELOPMENT DIVISION, LA JOLLA CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1973_^1_%SPC 2_^1*_$CONVERT DECIMAL TO HECIDECIMAL_^1_%ENT DCHX_^1_%EXT* IGETCH_^1_%EXT* UPDATE_^1_%EXT* EWRITE_^1_%EQU LPMSK(2)_^1_%EQU MSK(6)_'=$F_^1_%EQU I10($46)_$=10_^1_%EQU€€ ICOUNT($E2)_^1_%EQU IA(4)_^1_%EQU IB(5)_^1_%EQU IFIELD(7)_^1_%EQU JFIELD(8)_^1_%EQU IBX(13)_^1_%EQU JBX(14)_^1_%EQU IR1(15)_^1_%EQU IR2(16)_^1_%EQU IR3(17)_^1_%EQU IR7(21)_^1_%EQU ARGU1(31)_^1_%EQU ARGU3(33)_^1_%EQU ARGU4(34)_^1DCHX_!0_"0_)***CONVERT INTEGER_^1_%ENA 0_^1_%STA- IA,I_^1_%STA- IR1,I_^1_%STA- IR2,I_^1_%STA- IR3,I_^1_%STA- IR7,I_^1_%ENA 1_^1_%STA- ICOUN€€T_^1LOOP_!LDA- IFIELD,I_$=FIELD WIDTH OF CONVERTED_^1_%SUB- ICOUNT_)NUMBER_^1_%SAP NXT-*-1_^1_%JMP* OUT_^1NXT_"LDA- IBX,I_^1_%ADD- ARGU1,I_^1_%STA- ARGU3,I_^1_%ENA JBX_^1_%ADD- I_^1_%STA- ARGU4,I_^1_%RTJ IGETCH_'GET NEXT INTEGER IN BUFFER_^1_%STA- IB,I_^1_%ENA IBX_^1_%ADD- I_^1_%STA- ARGU3,I_^1_%INA 1_^1_%STA- ARGU4,I_^1_%RTJ UPDATE_^1_%LDA- IR2,I_(CONVERSION STARTED YET_^1_%€€SAN N-*-1_(YES, CONVERT EMBEDDED BLANKS TO ZERO_^1_%LDA- IB,I_)NO, CHARACTER A BLANK ( )._^1_%INA -$20_^1_%SAZ F-*-1_(YES_^1_%INA -$B_*NO, CHARACTER A PLUS (+)._^1_%SAZ F-*-1_(YES_^1_%INA -5_+NO, CHARACTER A ZERO (0)._^1* CONVERT LEADING ZEROS. A SIDE EFFECT IS TO INCREMENT IR2,_^1* IR2 IS THE CONVERTED INTEGER COUNTER._^1* IR2 IS USED AFTER THE SECOND CALL TO DCHX FROM F€€LOTIN._^1_%SAZ NXT2-*-1_%YES_^1_%INA 3_,NO, CHARACTER A MINUS (-)._^1_%SAN NXT2-*-1_$NO_^1_%RAO- IR7,I_(YES, INCREMENT INDEX_^1F_$JMP* ENDLP_^1N_$LDA- IB,I_)INTERPRET IMBEDDED BLANK AS ZERO (0)._^1_%INA -$20_^1_%SAZ ZRO-*-1_^1_%SUB* DF_($00DF_^1_%SAN NXT2-*-1_^1_%JMP* OUT_'STOP CONVERTING CHARACTERS_^1DF_#NUM $00DF_^1ZRO_"ENA $30_'REPLACE BLANK_%WITH ZERO_^1_%STA- IB,I_%CO€€NVERT BLANK AS INPUT $30_^1NXT2_!LDA- IB,I_)TEST IF IB=NUMERIC_^1_%INA -$2E_^1_%SAN NXT3-*-1_^1_%LDA- IFIELD,I_$YES, COMPUTE JFIELD_^1_%SUB- ICOUNT_^1_%STA- JFIELD,I_^1_%JMP* OUT_^1NXT3_!LDA- IB,I_)TEST IF IB=NUMERIC_^1_%INA -$30_^1_%SAP NXT4-*-1_^1P1_#RTJ EWRITE_'NO, ERROR_^1NXT4_!ENA $39_^1_%SUB- IB,I_^1_%SAP NXT5-*-1_^1_%RTJ EWRITE_^1NXT5_!LDA- IB,I_^1_%AND- MSK_*MASK 4-€€BITS OF ASCII NUMBR_^1_%STA- IB,I_^1_%RAO- IR2,I_(=COUNT OF DIGITS CONVERTED_^1_%ENA 11_^1_%SUB- IR2,I_(TEST COUNT GREATER THAN 5_^1_%SAP NXT6-*-1_^1_%RTJ EWRITE_'YES, ERROR_^1NXT6_!LDA- IR1,I_^1_%MUI- I10_^1_%LLS 1_^1_%ALS 15_^1_%ADD- IB,I_^1_%SAP OK-*-1_^1_%INQ 1_^1_%AND- LPMSK+15_^1OK_#STA- IR1,I_^1_%STQ- IR3,I_^1_%LDA- IA,I_^1_%MUI- I10_^1_%LLS 1_^1_%ALS 15_^1_%ADD- IR€83,I_^1_%STA- IA,I_^1_%SAM ER-*-1_^1_%SQZ ENDLP-*-1_^1ER_#RTJ EWRITE_^1ENDLP RAO- ICOUNT_^1_%JMP* LOOP_^1OUT_"LDQ- IA,I_^1_%LDA- IR1,I_^1_%ALS 1_^1_%LRS 1_^1_%STQ- IA,I_^1_%LDQ- IR7,I_^1NXT7_!SQZ NXT9-*-1_^1NXT8_!TCA A_^1_%LDQ- IA,I_^1_%TCQ Q_^1_%STQ- IA,I_^1NXT9_!STA- IB,I_^1_%JMP* (DCHX)_^1_%END_]_^__8PHXASC CSY/ J11 P€1_%NAM HXASC_(DECK-ID J11 FTN 3.3 RUNTIME_%SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3_^1*_$SMALL COMPUTER DEVELOPMENT DIVISION, LA JOLLA CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1973_^1_%SPC 2_^1*_$CONVERT HEXIDECMAL TO ASCII CODE_^1_%ENT HXASC_^1_%EXT* IPACK_^1_%EXT* UPDATE_^1_%EXT* EWRITE_J**MSOS4.0**_^1_%EQU MSK(6)_'=$F_^1_%EQU ZERO($22)_^1_%EQU ICOU€€NT($DC)_^1_%EQU JCOUNT($DD)_^1_%EQU IB(5)_^1_%EQU IFIELD(7)_^1_%EQU IBX(13)_^1_%EQU JBX(14)_^1_%EQU IR1(15)_^1_%EQU IR(15)_^1_%EQU ARGU1(31)_^1_%EQU ARGU3(33)_^1_%EQU ARGU4(34)_^1HXASC 0_"0_)***HEX TO ASCII CONVERSION_^1_%ENA 0_^1_%STA- ICOUNT_^1LOOP1 LDA- IB,I_^1_%ALS 4_,SHIFT HIGH ORDER BITS_^1_%STA- IB,I_^1_%AND- MSK_*MASK BITS 0-3_^1_%TCA Q_^1_%INQ 9_,TEST BYTE €€GT 9_^1_%SQP NXT-*-1_^1_%INA 7_,YES, ADD 7_^1NXT_"INA $30_*ADD ASCII ZERO TO INTEGER_^1_%LDQ- ICOUNT_^1_%STA- IR,B_)SAVE IN TEMP_^1_%RAO- ICOUNT_^1_%ENA 4_^1_%SUB- ICOUNT_^1_%SAZ NXTA_L**MSOS4.0**_^1_%JMP* LOOP1_^1NXTA_!ENQ -4_+CHECK FOR LEADING ZEROES_***MSOS4.0**_^1AGN_"LDA- IR+4,B_J**MSOS4.0**_^1_%INA -$30_L**MSOS4.0**_^1_%SAN NXT1_L**MSOS4.0**_^1_%LDA- ICOUNT_J**MSOS4.0€€**_^1_%INA -1_N**MSOS4.0**_^1_%STA- ICOUNT_J**MSOS4.0**_^1_%INQ 1_O**MSOS4.0**_^1_%SQP NXT1_L**MSOS4.0**_^1_%JMP* AGN_M**MSOS4.0**_^1NXT1_!LDA- IFIELD,I_$SET TOTAL FIELD WIDTH IN TEMP_^1_%STA- JCOUNT_^1_%TCA Q_O**MSOS4.0**_^1_%SUB- ICOUNT_J**MSOS4.0**_^1_%SAP OK1_M**MSOS4.0**_^1_%ENA $2A_*ERROR- FIELD WIDTH TOO SMALL_%**MSOS4.0**_^1_%STA- IB,I_,PUT AN * IN LEADING POSITION_"*€€*MSOS4.0**_^1_%SET A_O**MSOS4.0**_^1_%STA- IR,I_)SET FLAG TO CALL EWRITE_+**MSOS4.0**_^1_%JMP* NXT3_L**MSOS4.0**_^1OK1_"ENA 4_O**MSOS4.0**_^1_%STA- ICOUNT_J**MSOS4.0**_^1_%ENA $20_*SET IB INITIALLY TO BLANK_^1_%STA- IB,I_^1LOOP2 LDA- JCOUNT_'TEST IF FIELD WIDTH=0_^1_%SAN NXT2-*-1_^1OUT_"LDA- IR,I_L**MSOS4.0**_^1_%SAP OK2_M**MSOS4.0**_^1_%RTJ EWRITE_J**MSOS4.0**_^1OK2_"JMP* (€€HXASC)_I**MSOS4.0**_^1NXT2_!TCA A_,NO, COMPLIMENT FIELD WIDTH_^1_%TRA Q_^1_%ADD- ICOUNT_'ADD NUMBER OF HEX DIGITS_^1_%SAM NXT3-*-1_$TEST IF FIELD WIDTH GT NUMBER OF HEX DIGITS_^1_%LDA- IR+4,B_'NO, PACK HEX DIGITS INTO BUFFER_^1_%STA- IB,I_^1NXT3_!TCQ Q_^1_%INQ -1_+DECREASE FIELD WIDTH BY 1_^1_%STQ- JCOUNT_^1_%LDA- IBX,I_^1_%ADD- ARGU1,I_^1_%STA- ARGU3,I_^1_%ENA JBX_^1_%ADD- I€¾_^1_%STA- ARGU4,I_^1_%RTJ IPACK_(PACK CHARACTER INTO BUFFER_^1_%ENA IBX_^1_%ADD- I_^1_%STA- ARGU3,I_^1_%INA 1_^1_%STA- ARGU4,I_^1_%RTJ UPDATE_^1_%RAO- ICOUNT_^1_%JMP* LOOP2_^1_%END_]_^__¾PAFRMOT CSY/ J12 P€1_%NAM AFRMOT_'DECK-ID J12 FTN 3.3 RUNTIME_%SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3_^1*_$SMALL COMPUTER DEVELOPMENT DIVISION, LA JOLLA CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1973_^1_%SPC 2_^1*_$CONVERT BY (A)FORMAT FOR OUTPUT_^1_%ENT AFRMOT_^1_%EXT* GETCH_^1_%EXT* IPACK_^1_%EXT* UPDATE_^1_%EQU MSK($A)_%=$FF_^1_%EQU ZERO($22)_^1_%EQU ICOUNT($DC)_^1_€€%EQU JCOUNT($23)_G47*805_^1_%EQU IA(4)_^1_%EQU IB(5)_^1_%EQU IFIELD(7)_^1_%EQU IBX(13)_^1_%EQU JBX(14)_^1_%EQU ARGU1(31)_^1_%EQU ARGU3(33)_^1_%EQU ARGU4(34)_^1AFRMOT 0_"0_)***(A)FORMAT FOR OUTPUT_^1_%LDA- IB,I_^1_%STA- IA,I_^1_%ENA 1_^1_%STA- ICOUNT_^1LOOP_!LDA- IFIELD,I_^1_%SUB- ICOUNT_^1_%SAP NXT-*-1_^1OUT_"JMP* (AFRMOT)_^1NXT_"ENA IA_^1_%ADD- I_^1_%STA- ARGU3,I_^1_%E€dNA -JCOUNT_K47*805_^1_%AND- MSK_^1_%STA- ARGU4,I_^1_%RTJ GETCH_(GET CHARACTER_^1_%STA- IB,I_^1_%LDA- ARGU1,I_^1_%ADD- IBX,I_^1_%STA- ARGU3,I_^1_%ENA JBX_^1_%ADD- I_^1_%STA- ARGU4,I_^1_%RTJ IPACK_(PACK CHARACTER INTO BUFFER_^1_%ENA IBX_^1_%ADD- I_^1_%STA- ARGU3,I_^1_%INA 1_^1_%STA- ARGU4,I_^1_%RTJ UPDATE_^1_%RAO- ICOUNT_^1_%JMP* LOOP_^1_%END_]_^__ dPRFRMOT CSY/ J13 P€1_%NAM RFRMOT_'DECK-ID J13 FTN 3.3 RUNTIME_%SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3_^1*_$SMALL COMPUTER DEVELOPMENT DIVISION, LA JOLLA CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1973_^1_%SPC 2_^1*_$CONVERT BY (R)FORMAT FOR OUTPUT_^1_%ENT RFRMOT_^1_%EXT* IPACK_^1_%EXT* UPDATE_^1_%EQU ZERO($22)_^1_%EQU MSK($A)_%=$FF_>**MSOS4.0**_^1_%EQU IB(5)_K**MSOS4.0*€€*_^1_%EQU IBX(13)_^1_%EQU JBX(14)_^1_%EQU ARGU1(31)_^1_%EQU ARGU3(33)_^1_%EQU ARGU4(34)_^1RFRMOT 0_"0_)***(R)FORMAT FOR OUTPUT_^1_%LDA- IB,I_L**MSOS4.0**_^1_%AND- MSK_M**MSOS4.0**_^1_%STA- IB,I_L**MSOS4.0**_^1_%LDA- ARGU1,I_^1_%ADD- IBX,I_^1_%STA- ARGU3,I_^1_%ENA JBX_^1_%ADD- I_^1_%STA- ARGU4,I_^1_%RTJ IPACK_(PACK CHARACTER INTO BUFFER_^1_%ENA IBX_^1_%ADD- I_^1_%STA- ARGU3,€dI_^1_%INA 1_^1_%STA- ARGU4,I_^1_%RTJ UPDATE_'UPDATE BUFFER COUNTS_^1_%JMP* (RFRMOT)_^1_%END_]_^__ dPAFRMIN CSY/ J14 P€1_%NAM AFRMIN_'DECK-ID J14 FTN 3.3 RUNTIME_%SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3_^1*_$SMALL COMPUTER DEVELOPMENT DIVISION, LA JOLLA CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1973_^1_%SPC 2_^1*_$CONVERT BY (A)FORMAT FOR INPUT_^1_%ENT AFRMIN_^1_%EXT* IGETCH_^1_%EXT* UPDATE_^1_%EQU ZERO($22)_^1_%EQU IA(4)_^1_%EQU IB(5)_^1_%EQU IFIELD(7)_^1_%EQU IBX(€€13)_^1_%EQU JBX(14)_^1_%EQU ARGU1(31)_^1_%EQU ARGU3(33)_^1_%EQU ARGU4(34)_^1AFRMIN 0_"0_)***(A)FORMAT FOR INPUT_^1_%LDA- ARGU1,I_^1_%ADD- IBX,I_^1_%STA- ARGU3,I_^1_%ENA JBX_^1_%ADD- I_^1_%STA- ARGU4,I_^1P1_#RTJ IGETCH_'GET CHARACTER_^1_%STA- IB,I_^1_%ENA IBX_^1_%ADD- I_^1_%STA- ARGU3,I_^1_%INA 1_^1_%STA- ARGU4,I_^1P2_#RTJ UPDATE_'UPDATE CHARACTER COUNT_^1_%ENA $20_^1_%STA€€- IA,I_)SET IA=BLANK_^1_%LDA- IFIELD,I_^1_%INA -1_+IFIELD=1, PACK 1 CHARACTER_^1_%SAN CONTUE-*-1_$PER WORD WITH BLANK FILL_^1_%JMP* NEXT_^1CONTUE LDA- ARGU1,I_%NO, GET NEXT CHARACTER_^1_%ADD- IBX,I_^1_%STA- ARGU3,I_^1_%ENA JBX_^1_%ADD- I_^1_%STA- ARGU4,I_^1_%RTJ IGETCH_^1_%STA- IA,I_^1_%ENA IBX_^1_%ADD- I_^1_%STA- ARGU3,I_^1_%INA 1_^1_%STA- ARGU4,I_^1_%RTJ UPDATE_^1NEXT_!LDA€‚- IB,I_)LEFT JUSTIFY AND ADD BLANK_^1_%ALS 8_.OR NEXT CHARACTER FILL_^1_%ADD- IA,I_^1_%STA- IB,I_^1_%JMP* (AFRMIN)_^1_%END_]_^__ ‚PRFRMIN CSY/ J15 P€1_%NAM RFRMIN_'DECK-ID J15 FTN 3.3 RUNTIME_%SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3_^1*_$SMALL COMPUTER DEVELOPMENT DIVISION, LA JOLLA CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1973_^1_%SPC 2_^1*_$CONVERT BY (R)FORMAT FOR INPUT_^1_%ENT RFRMIN_^1_%EXT* IGETCH_^1_%EXT* UPDATE_^1_%EQU IB(5)_^1_%EQU IBX(13)_^1_%EQU JBX(14)_^1_%EQU ARGU1(31)_^1_%EQU ARGU€J3(33)_^1_%EQU ARGU4(34)_^1RFRMIN 0_"0_)***(R)FORMAT FOR INPUT_^1_%LDA- ARGU1,I_^1_%ADD- IBX,I_^1_%STA- ARGU3,I_^1_%ENA JBX_^1_%ADD- I_^1_%STA- ARGU4,I_^1_%RTJ IGETCH_'GET CHARACTER_^1_%STA- IB,I_^1_%ENA IBX_^1_%ADD- I_^1_%STA- ARGU3,I_^1_%INA 1_^1_%STA- ARGU4,I_^1_%RTJ UPDATE_'UPDATE COUNTS_^1_%JMP* (RFRMIN)_^1_%END_]_^__ JPASCHX CSY/ J16 P€1_%NAM ASCHX_(DECK-ID J16 FTN 3.3 RUNTIME_%SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3_^1*_$SMALL COMPUTER DEVELOPMENT DIVISION, LA JOLLA CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1973_^1_%SPC 2_^1*_$CONVERT FROM ASCII TO HEXIDECIMAL_^1_%ENT ASCHX_^1_%EXT* IGETCH_^1_%EXT* UPDATE_^1_%EXT* EWRITE_MPSR 1249_^1_%EQU MSK(6)_'=$F_^1_%EQU ZERO($22)_^1_%EQU ICOUN€€T($DC)_^1_%EQU IA(4)_^1_%EQU IB(5)_^1_%EQU IFIELD(7)_^1_%EQU IBX(13)_^1_%EQU JBX(14)_^1_%EQU IR1(15)_^1_%EQU ARGU1(31)_^1_%EQU ARGU3(33)_^1_%EQU ARGU4(34)_^1ASCHX 0_"0_)***ASCII TO HEX CONVERSION_^1_%ENA 0_^1_%STA- IB,I_^1_%ENA 1_^1_%STA- ICOUNT_^1LOOP_!LDA- IFIELD,I_^1_%SUB- ICOUNT_^1_%SAP NXT-*-1_^1OUT_"JMP* (ASCHX)_^1NXT_"LDA- ARGU1,I_^1_%ADD- IBX,I_^1_%STA- ARGU3,I€€_^1_%ENA JBX_^1_%ADD- I_^1_%STA- ARGU4,I_^1_%RTJ IGETCH_'GET CHARACTER_^1_%STA- IA,I_^1_%ENA IBX_^1_%ADD- I_^1_%STA- ARGU3,I_^1_%INA 1_^1_%STA- ARGU4,I_^1_%RTJ UPDATE_^1_%LDA- IA,I_^1_%INA -$20_)TEST IF CHARACTER=BLANK_^1_%SAN NXT1-*-1_^1_%JMP* NEXT_^1NXT1_!LDA- IA,I_)NO, CONVERT CHARACTER_^1_%AND- MSK_^1_%STA- IR1,I_^1_%LDA- IA,I_OPSR 1249_^1_%INA -$30_OPSR 1249_^1_%SAM E€€RR_*SKIP CHAR NON-NUMERIC_0PSR 1249_^1_%INA -10_PPSR 1249_^1_%SAM NXT2_)SKIP CHAR 0-9_8PSR 1249_^1_%INA -7_QPSR 1249_^1_%SAM ERR_*SKIP CHAR NON-NUMERIC_0PSR 1249_^1_%INA -6_QPSR 1249_^1_%SAM 2_,SKIP CHAR A-F_8PSR 1249_^1ERR_"RTJ EWRITE_'ERROR--NOT A HEX DIGIT_/PSR 1249_^1_%LDA- IR1,I_(YES, ADD 9_^1_%INA 9_^1_%STA- IR1,I_^1NXT2_!LDA- IB,I_^1_%ALS 4_,SHIFT HEX NUMBER BY 4_^1€p_%EOR- IR1,I_(ADD LEAST SIGNIFICANT BITS_+PSR 807_^1_%STA- IB,I_^1NEXT_!RAO- ICOUNT_^1_%JMP* LOOP_^1_%END_]_^__ pPHXDC CSY/ J17 P€1_%NAM HXDC_)DECK-ID J17 FTN 3.3 RUNTIME_%SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3_^1*_$SMALL COMPUTER DEVELOPMENT DIVISION, LA JOLLA CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1973_^1_%SPC 2_^1*_$CONVERT HEXIDECIMAL TO DECIMAL VARIABLE_^1_%ENT HXDC_^1_%EXT* IPACK_^1_%EXT* UPDATE_^1_%EQU ZERO($22)_^1_%EQU I10($46)_$=10_^1_%EQU ICOUNT($D9)_^1_%EQU IA(4)€€_^1_%EQU IB(5)_^1_%EQU IFIELD(7)_^1_%EQU JFIELD(8)_^1_%EQU IBX(13)_^1_%EQU JBX(14)_^1_%EQU IR(15)_^1_%EQU IR7(21)_^1_%EQU IR8(22)_^1_%EQU ARGU1(31)_^1_%EQU ARGU3(33)_^1_%EQU ARGU4(34)_^1HXDC_!0_"0_)***HEX TO DECIMAL CONVERSION_^1_%ENA 0_^1_%STA- IR7,I_(NO, SET IR7=0_^1_%STA- IR8,I_^1_%LDA- IB,I_^1_%LDQ- IA,I_^1_%SQP LOOP-*-1_$TEST IF INTEGER NEGATIVE_^1_%TCQ Q_,YES, C€€OMPLIMENT NUMBER_^1_%TCA A_^1_%STA- IB,I_^1_%ENA $2D_*SET IR7=MINUS SIGN_^1_%STA- IR7,I_^1_%LDA- IB,I_^1LOOP_!DVI- I10_^1_%INQ $30_*ADD $30 TO REMAINDER_^1_%STA- IB,I_)SAVE RESULTANT_^1_%TRQ A_^1_%LDQ- IR8,I_^1_%STA- IR,B_)SAVE IN TEMPORARY_^1_%RAO- IR8,I_^1_%LDA- IB,I_^1_%SAZ NXT-*-1_%IB=0, TERMINATE CONVERSION_^1_%ENQ 0_^1_%JMP* LOOP_^1NXT_"LDA- JFIELD,I_^1_%SAN NXT1-*-1_$€€TEST JFIELD=0_^1_%JMP* NEXT2_^1NXT1_!SUB- IR8,I_(TEST IF JFIELD IS LE IR8(NO. OF DIGITS/_^1_%SAM CONTUE-*-1_$INTEGER VALUE)_^1_%SAZ CONTUE-*-1_^1_%JMP* NEXT2_^1CONTUE ENA $2E_*SET IB=PERIOD_^1_%STA- IB,I_^1_%RAO- IR8,I_^1_%LDA- JFIELD,I_^1_%INA 1_,SET UP LOOP TO INSERT A_^1_%STA- ICOUNT_)DECIMAL POINT WITHIN THE_^1LOOP1 LDA- IR8,I_*STRING OF INTEGER VALUES_^1_%SUB- ICOUNT_^1_%€€SAM ENDLP-*-1_^1_%LDQ- ICOUNT_^1_%LDA- IR-1,B_^1_%LDQ- IB,I_^1_%STA- IB,I_^1_%TRQ A_^1_%LDQ- ICOUNT_^1_%STA- IR-1,B_'INSERT PERIOD INTO_^1_%RAO- ICOUNT_)CHARACTER STRING_^1_%JMP* LOOP1_^1ENDLP ENA 0_^1_%STA- JFIELD,I_^1NEXT2 ENA $20_^1_%STA- IB,I_)SET IB=BLANK_^1_%LDA- JFIELD,I_^1_%SAZ NXT2-*-1_^1_%LDQ- IR7,I_^1_%SQZ NXT2-*-1_^1_%RAO- JFIELD,I_^1NXT2_!ENA 1_^1_%STA- ICOUNT€€_'SET UP LOOP TO PACK VALUE_^1LOOP2 LDA- IFIELD,I_'INTO BUFFER_^1_%SUB- ICOUNT_'=I(CURRENT VALUE OF COUNT_^1_%SAP NXT3-*-1_'WITHIN FIELD)_^1_%JMP* (HXDC)_^1NXT3_!LDA- JFIELD,I_$TEST JFIELD=0_^1_%SAN NXT4-*-1_^1_%JMP* NEXT4_^1NXT4_!SUB- IFIELD,I_$NO, TEST IF JFIELD=-IFIELD_^1_%ADD- ICOUNT_)+ICOUNT_^1_%SAZ NXT5-*-1_^1_%JMP* NEXT4_^1NXT5_!LDA- IR7,I_(WAS NUMBER NEGATIVE_^1_%SAZ N€€XT6-*-1_^1_%LDA- JFIELD,I_$YES, REDUCE JFIELD_^1_%INA -1_^1_%STA- JFIELD,I_^1NEXT3 LDA- IR7,I_(AND SET IB=$2D(MINUS SIGN)_^1_%STA- IB,I_^1_%ENA 0_^1_%STA- IR7,I_(CLEAR FLAG_^1_%JMP* NEXT5_^1NXT6_!ENA 0_,NUMBER IS LESS THAN 1_^1_%STA- JFIELD,I_^1_%ENA $2E_*SET IB=PERIOD_^1_%STA- IB,I_^1_%ENA $30_*SET ICONST=ZERO_^1_%STA- IR7,I_^1_%JMP* NEXT5_^1NEXT4 LDQ- IR7,I_^1_%LDA- IR8,I_€€(TEST IF INTEGER COUNT+1=_^1_%SUB- IFIELD,I_'IFIELD-I+1_^1_%ADD- ICOUNT_^1_%SAN NXT7-*-1_^1_%SQZ ON-*-1_^1_%JMP* NEXT3_(YES, GO INSERT SIGN_^1NXT7_!INQ -$30_^1_%SQN ON-*-1_^1_%JMP* NEXT3_^1ON_#LDA- IR8,I_(TEST IF CHARACTER COUNT IS_^1_%SUB- IFIELD,I_'LT CURRENT FIELD COUNT_^1_%TRA Q_^1_%ADD- ICOUNT_^1_%INA -1_^1_%SAP TEST-*-1_^1_%JMP* NEXT5_^1TEST_!SQM NXT8-*-1_^1_%SQN ERR€€-*-1_^1ERRFLD LDA- IR7,I_^1_%SAZ NXT8-*-1_^1ERR_"ENA $2A_^1_%STA- IB,I_^1_%LDA- IFIELD,I_$RESET CHARACTER COUNT=_^1_%INA -1_-IFIELD-1_^1_%STA- IR8,I_^1_%JMP* NEXT5_^1NXT8_!LDQ- IR8,I_(=CHARACTER COUNT_^1_%LDA- IR-1,B_'GET CONVERTED INTEGERS_^1_%STA- IB,I_^1_%INQ -1_^1_%STQ- IR8,I_^1NEXT5 LDA- ARGU1,I_%PACK CHARACTER INTO BUFFER_^1_%ADD- IBX,I_^1_%STA- ARGU3,I_^1_%ENA JBX_^1_%A€¸DD- I_^1_%STA- ARGU4,I_^1_%RTJ IPACK_^1_%ENA IBX_^1_%ADD- I_^1_%STA- ARGU3,I_^1_%INA 1_^1_%STA- ARGU4,I_^1_%RTJ UPDATE_'UPDATE COUNTERS_^1_%RAO- ICOUNT_^1_%JMP* LOOP2_^1_%END_]_^__¸PFLOTIN CSY/ J18 P€1_%NAM FLOTIN_'DECK-ID J18 FTN 3.3 RUNTIME_%SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^1_%SPC 2_^1*_$FLOATING POINT CONVERSION FOR INPUT WITH_^1*_$(F)FORMAT_^1_%ENT FLOTIN_^1_%EXT* DCHX_^1_%EXT* Q8QFL_^1_%EXT HFLOT_OFTN 3.3_^1_%EXT* Q8QFI_^1_%EQU A($D8)_^1_%EQU€€ R($DA)_^1_%EQU SCALE($DC)_^1_%EQU SWITCH($E1)_^1_%EQU NXFLD($E4)_^1_%EQU NXTFLD($E5)_^1_%EQU IA(4)_^1_%EQU IB(5)_^1_%EQU IFIELD(7)_^1_%EQU JFIELD(8)_^1_%EQU IR2(16)_^1FLOTIN 0_"0_)***INPUT (F)FORMAT_^1_%LDA- IFIELD,I_^1_%STA- NXTFLD_^1_%LDA- NXFLD_O64*1405_^1_%STA* E4SAVE_N64*1405_^1_%LDA- JFIELD,I_^1_%STA- NXFLD_^1_%ENA -0_^1_%STA- JFIELD,I_^1P1_#RTJ DCHX_^1_%RTJ Q8Q€€FL_^1_%LDA- JFIELD,I_^1_%SAP STP10-*-1_^1_%JMP* STP20_^1STP10 STA- IFIELD,I_^1_%LDQ- A_^1_%LDA- A+1_^1_%STQ- SWITCH_^1_%SQP STP12-*-1_^1_%TCQ Q_^1_%TCA A_^1STP12 STQ- R_^1_%STA- R+1_^1_%RTJ DCHX_^1_%RTJ Q8QFL_^1* Q8QFI CALCULATES SCALE = 10**JFIELD. MAKE JFIELD = NUMBER OF_^1* COMVERTED DIGITS TO THE RIGHT OF THE DECIMAL, LEADING ZEROS INCLUDED._^1_%LDA- IR2,I_^1_%STA- JFI€€ELD,I_^1_%RTJ Q8QFI_^1_%RTJ HFLOT_OFTN 3.3_^1_%NUM $BAED_^1_%ADC A_^1_%ADC SCALE_^1_%ADC R_^1_%ADC A_^1_%NUM $4000_^1_%LDA- SWITCH_^1_%SAP STP20-*-1_^1_%RTJ HFLOT_OFTN 3.3_^1_%NUM $B7D4_^1_%ADC A_^1_%ADC A_^1STP20 LDQ- JFIELD,I_^1_%LDA- NXFLD_^1_%STA- JFIELD,I_^1_%SQP STP30-*-1_^1_%RTJ Q8QFI_^1_%RTJ HFLOT_OFTN 3.3_^1_%NUM $BAD4_^1_%ADC A_^1_%ADC SCALE_^1_%ADC A€Æ_^1STP30 LDA- NXTFLD_^1_%STA- IFIELD,I_^1_%LDA* E4SAVE_N64*1405_^1_%STA- NXFLD_O64*1405_^1_%LDA- A_^1_%LDQ- A+1_^1_%STA- IA,I_^1_%STQ- IB,I_^1_%JMP* (FLOTIN)_^1E4SAVE NUM 0_S64*1405_^1_%END_]_^__ ÆPFOUT CSY/ J19 P€1_%NAM FOUT_)DECK-ID J19 FTN 3.3 RUNTIME_%SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^1_%SPC 2_^1*_$FLOATING POINT OUTPUT CONVERSION UNDER AN_^1*_$(F)FORMAT_^1_%ENT FOUT_^1_%EXT* Q8QFI_^1_%EXT HFLOT_OFTN 3.3_^1_%EXT* Q8QFX_^1_%EXT* HXDC_^1_%EXT* IPACK_^1_%EXT* UP€€DATE_^1_%EXT* Q8QFL_^1_%EQU TEMP($C5)_KFTN 3.3_^1_%EQU A1($D8)_^1_%EQU A2($DA)_^1_%EQU SCALE($DC)_^1_%EQU ICOUNT($E1)_^1_%EQU NUFLD($E4)_^1_%EQU NXTFLD($E5)_^1_%EQU IA(4)_^1_%EQU IB(5)_^1_%EQU IFIELD(7)_^1_%EQU JFIELD(8)_^1_%EQU IBX(13)_^1_%EQU JBX(14)_^1_%EQU BUFFER(29)_IPSR 808_^1_%EQU ARGU1(31)_^1_%EQU ARGU3(33)_^1_%EQU ARGU4(34)_^1_%EQU ASTRK($2A)_IPSR 808_^1E€€4SAVE NUM 0_S64*1405_^1FOUT_!0_"0_)***FLOATING POINT OUTPUT_^1_%LDA- NUFLD_O64*1405_^1_%STA* E4SAVE_N64*1405_^1_%LDA- JFIELD,I_^1_%STA- NUFLD_^1_%LDA- IA,I_^1_%LDQ- IB,I_^1_%SAP NXT-*-1_^1_%TCQ Q_^1_%TCA A_^1NXT_"STQ- A2+1_^1_%STA- A2_^1_%RTJ Q8QFI_^1_%RTJ HFLOT_OFTN 3.3_^1_%NUM $5B5A_^1_%ADC FLOTK1-*_^1_%ADC SCALE_^1_%NUM $ED58_^1_%ADC A2_^1_%ADC A2_^1_%ADC FLOTK2-*_^€€1_%NUM $5D40_OFTN 3.3_^1_%ADC TEMP_PFTN 3.3_^1_%LDA- TEMP_PFTN 3.3_^1_%SAM NXT1-*-1_^1_%JMP* OVRFLW_'ERROR - NUMBER .GT. 99,999.9_)PSR 808_^1NXT1_!LDA- IA,I_^1_%SAP STP20-*-1_^1_%RTJ HFLOT_OFTN 3.3_^1_%NUM $B7D4_^1_%ADC A2_^1_%ADC A2_^1STP20 RTJ Q8QFX_^1_%ENA 0_^1_%STA- JFIELD,I_^1_%LDA- IFIELD,I_^1_%STA- NXTFLD_^1_%SUB- NUFLD_^1_%INA -1_^1_%STA- IFIELD,I_^1P5_#RTJ HXD€€C_^1_%ENA $2E_^1_%STA- IB,I_^1_%LDA- ARGU1,I_^1_%ADD- IBX,I_^1_%STA- ARGU3,I_^1_%ENA JBX_^1_%ADD- I_^1_%STA- ARGU4,I_^1_%RTJ IPACK_^1_%ENA IBX_^1_%ADD- I_^1_%STA- ARGU3,I_^1_%INA 1_^1_%STA- ARGU4,I_^1_%RTJ UPDATE_^1_%ENA 1_^1_%STA- IA,I_^1_%STA- IFIELD,I_^1_%STA- ICOUNT_^1_%LDA- A2_^1_%SAP LOOP-*-1_^1_%TCA A_^1_%STA- A2_^1LOOP_!LDA- NUFLD_^1_%SUB- ICOUNT_^1_%SAP NXT2-*-1€€_^1_%JMP* OUT_^1NXT2_!RTJ Q8QFX_^1_%RTJ Q8QFL_^1_%RTJ HFLOT_OFTN 3.3_^1_%NUM $B859_^1_%ADC A2_^1_%ADC A1_^1_%ADC FLOT10-*_^1_%NUM $5D40_^1_%ADC A2_^1_%RTJ Q8QFX_^1_%RTJ HXDC_^1_%RAO- ICOUNT_^1_%JMP* LOOP_^1OUT_"LDA- NXTFLD_^1_%STA- IFIELD,I_^1_%LDA- NUFLD_^1_%STA- JFIELD,I_^1_%LDA* E4SAVE_N64*1405_^1_%STA- NUFLD_O64*1405_^1_%LDA- JFIELD,I_L64*1405_^1_%JMP (FOUT)_^1* ROU€€TINE TO FILL BUFFER WITH ASTERISKS IF NUMBER .GT. 99,999.9 PSR 808_^1OVRFLW LDA- IFIELD,I_$MOVE FIELD WIDTH TO TEMPORARY_(PSR 808_^1_%STA* CTR_*STORAGE FOR USE AS LOOP COUNTER_%PSR 808_^1FILL_!ENA ASTRK_(* TO A REGISTER_6PSR 808_^1_%STA- IB,I_)STORE IN IB_:PSR 808_^1_%LDA- BUFFER,I_$PICK UP BUFFER ADDRESS_/PSR 808_^1_%ADD- IBX,I_(INCREMENT BY CURRENT WORD ORDINAL_#PSR 808_^1_%STA-€€ ARGU3,I_%STORE IN ARGU3_7PSR 808_^1_%ENA JBX_PPSR 808_^1_%ADD- I_,ARGU4 GETS CURRENT BUFFER CHARACTER_!PSR 808_^1_%STA- ARGU4,I_%ADDRESS_>PSR 808_^1_%RTJ IPACK_(PACK ASTERISK INTO BUFFER_,PSR 808_^1_%ENA IBX_PPSR 808_^1_%ADD- I_RPSR 808_^1_%STA- ARGU3,I_LPSR 808_^1_%INA 1_RPSR 808_^1_%STA- ARGU4,I_LPSR 808_^1_%RTJ UPDATE_'UPDATE WORD + CHARACTER COUNT_(PSR 808_^1_%LDA* CTR_PP€@SR 808_^1_%INA -1_QPSR 808_^1_%SAZ FULL_)CHECK IF ALL OF FIELD SET_,PSR 808_^1_%STA* CTR_PPSR 808_^1_%JMP* FILL_)NO - REPEAT PROCESS_2PSR 808_^1FULL_!JMP* OUT_*YES - EXIT BACK TO FOUT CALLER_'PSR 808_^1CTR_"ADC 0_RPSR 808_^1FLOT10 NUM $4250,$0_^1FLOTK1 NUM $4040,$0_^1FLOTK2 NUM $4A49,$3E00_G71*1626_^1_%END_]_^__ @PEOUT CSY/ J20 P€1_%NAM EOUT_)DECK-ID J20 FTN 3.3 RUNTIME_%SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^1_%SPC 2_^1*_$FLOATING POINT OUTPUT WITH (E)FORMAT_^1_%ENT EOUT_^1_%EXT* Q8QFI_^1_%EXT HFLOT_OFTN 3.3_^1_%EXT* IPACK_^1_%EXT* UPDATE_^1_%EXT* Q8QFX_^1_%EXT* EWRITE_^1_%EXT* Q8QF€€L_^1_%EXT* HXDC_^1_%EQU RX($D8)_^1_%EQU R($DA)_^1_%EQU TEMP($DC)_^1_%EQU SCALE($DC)_^1_%EQU ICOUNT($E1)_^1_%EQU IFLAG($E2)_^1_%EQU JCOUNT($E3)_^1_%EQU SWITCH($E3)_^1_%EQU NUFLD($E4)_^1_%EQU NXTFLD($E5)_^1_%EQU IA(4)_^1_%EQU IB(5)_^1_%EQU IFIELD(7)_^1_%EQU JFIELD(8)_^1_%EQU IBX(13)_^1_%EQU JBX(14)_^1_%EQU ARGU1(31)_^1_%EQU ARGU3(33)_^1_%EQU ARGU4(34)_^1E4SAVE NUM €€ 0_S64*1405_^1EOUT_!0_"0_)***FLOATING POINT CONVERSION_^1_%LDA- NUFLD_O64*1405_^1_%STA* E4SAVE_N64*1405_^1_%LDA- JFIELD,I_^1_%STA- NUFLD_^1_%RTJ Q8QFI_^1_%LDA- IFIELD,I_^1_%STA- NXTFLD_^1_%LDA- IA,I_^1_%STA- R_^1_%LDA- IB,I_^1_%STA- R+1_^1_%ENA 0_^1_%STA- IA,I_^1_%STA- ICOUNT_^1_%ENA $20_^1_%STA- IB,I_^1_%STA- IFLAG_^1_%ENA -1_^1_%STA- SWITCH_^1STP10 LDA- SWITCH_^1_%SAP STP30€€-*-1_^1_%LDA- IFIELD,I_^1_%TRA Q_^1_%SUB- JFIELD,I_^1_%INA -6_^1_%SAM STP20-*-1_^1_%SAZ STP40-*-1_^1_%INQ -1_^1_%STQ- IFIELD,I_^1_%JMP* PACK_^1STP20 ENA $2A_^1_%STA- IB,I_^1_%INQ -6_^1_%STQ- JFIELD,I_^1_%ENA 0_^1_%JMP* STP50_^1STP30 SAZ STP60-*-1_^1_%JMP* STP80_^1STP40 LDQ- R_^1_%SQP STP50-*-1_^1_%TCQ Q_^1_%STQ- R_^1_%LDQ- R+1_^1_%TCQ Q_^1_%STQ- R+1_^1_%ENQ $2D_^1_%€€STQ- IB,I_^1STP50 STA- SWITCH_^1_%JMP* PACK_^1STP60 ENA $2E_^1_%STA- IB,I_^1_%ENA 1_^1_%STA- SWITCH_^1PACK_!LDA- IBX,I_^1_%ADD- ARGU1,I_^1_%STA- ARGU3,I_^1_%ENA JBX_^1_%ADD- I_^1_%STA- ARGU4,I_^1_%RTJ IPACK_^1_%ENA IBX_^1_%ADD- I_^1_%STA- ARGU3,I_^1_%INA 1_^1_%STA- ARGU4,I_^1_%RTJ UPDATE_^1_%JMP* STP10_^1STP80 RTJ Q8QFX_^1_%LDA- IB,I_^1_%SAZ STP90-*-1_^1_%RAO- ICOUNT_^1€€_%JMP* STP100_^1STP90 LDA- R_^1_%SAN LOOP1-*-1_^1_%JMP* STP130_^1LOOP1 RTJ HFLOT_OFTN 3.3_^1_%NUM $B595_^1_%ADC R_^1_%ADC FLOT10-*_^1_%NUM $D400_^1_%ADC R_^1_%RTJ Q8QFX_^1_%LDA- IB,I_^1_%SAZ ENDLP-*-1_^1_%ENA $2D_^1_%STA- IFLAG_^1_%JMP* STP120_^1ENDLP LDA- ICOUNT_^1_%INA -1_^1_%STA- ICOUNT_^1_%INA 99_^1_%SAM P4-*-1_^1_%JMP* LOOP1_^1P4_#RTJ EWRITE_^1STP100 LDQ- IA,I€€_^1_%LDA- IB,I_^1_%LLS 1_^1_%ALS 15_^1_%TCA A_^1_%INA 9_^1_%SAM LOOP2-*-1_^1_%SQN LOOP2-*-1_^1_%JMP* STP120_^1LOOP2 RTJ HFLOT_OFTN 3.3_^1_%NUM $B5A5_^1_%ADC R_^1_%ADC FLOT10-*_^1_%NUM $D400_^1_%ADC R_^1_%RTJ Q8QFX_^1_%RAO- ICOUNT_^1_%ENA 99_^1_%SUB- ICOUNT_^1_%SAM STP110-*-1_^1_%JMP* STP100_^1STP110 RTJ EWRITE_^1STP120 RTJ HFLOT_OFTN 3.3_^1_%NUM $5B5A_^1_%ADC FL€€OTK1-*_^1_%ADC SCALE_^1_%NUM $ED40_^1_%ADC R_^1_%ADC R_^1_%RTJ Q8QFX_^1_%ENA 9_^1_%SUB- IB,I_^1_%SAP STP130-*-1_^1_%ENA 2_^1_%RAO- ICOUNT_^1_%JMP* STP132_^1STP130 ENA 1_^1STP132 STA- IFIELD,I_^1_%LDA- JFIELD,I_^1_%STA- TEMP_^1_%ENA 0_^1_%STA- JFIELD,I_^1LOOP3 LDA- TEMP_^1_%SUB- JCOUNT_^1_%SAP NXT5-*-1_^1_%JMP* OUT_^1NXT5_!RTJ Q8QFL_^1_%RTJ HFLOT_OFTN 3.3_^1_%NUM $B85€€9_^1_%ADC R_^1_%ADC RX_^1_%ADC FLOT10-*_^1_%NUM $5D40_^1_%ADC R_^1P7_#RTJ HXDC_^1_%RTJ Q8QFX_^1_%LDA- IFIELD,I_^1_%INA -1_^1_%SAZ STP140-*-1_^1_%STA- IFIELD,I_^1STP140 RAO- JCOUNT_^1_%JMP* LOOP3_^1OUT_"ENA $45_^1_%STA- IB,I_^1STP150 LDA- ARGU1,I_^1_%ADD- IBX,I_^1_%STA- ARGU3,I_^1_%ENA JBX_^1_%ADD- I_^1_%STA- ARGU4,I_^1_%RTJ IPACK_^1_%ENA IBX_^1_%ADD- I_^1_%STA- ARGU3,I€€_^1_%INA 1_^1_%STA- ARGU4,I_^1_%RTJ UPDATE_^1_%LDA- IFLAG_^1_%SAZ NXT6-*-1_^1_%STA- IB,I_^1_%EOR =N$20_(IS IB A BLANK_,*THIS*_!**FTN 3.1**_^1_%SAN MINUS-*-1_#YES_6*LOGIC* **FTN 3.1**_^1_%ENA $2B_*SET IB TO AN ASCII PLUS_!*SETS UP***FTN 3.1**_^1_%STA- IB,I_C*A PLUS* **FTN 3.1**_^1MINUS ENA 0_F*EXPONENT**FTN 3.1**_^1_%STA- IFLAG_^1_%LDA- ICOUNT_^1_%SAP STP170-*-1_^1_%TCA A€€_^1_%STA- ICOUNT_^1STP170 JMP* STP150_^1NXT6_!ENA 9_^1_%SUB- ICOUNT_^1_%SAM NXT7-*-1_^1_%ENA 0_^1_%STA- IB,I_^1_%RTJ HXDC_^1_%JMP* STP180_^1NXT7_!ENA 2_^1_%STA- IFIELD,I_^1STP180 LDA- ICOUNT_^1_%STA- IB,I_^1_%RTJ HXDC_^1_%LDA- NUFLD_^1_%STA- JFIELD,I_^1_%LDA E4SAVE_N64*1405_^1_%STA- NUFLD_O64*1405_^1_%LDA- NXTFLD_^1_%STA- IFIELD,I_^1_%JMP (EOUT)_^1FLOT10 NUM 16976_^1_%NUM €0 0_^1FLOTK1 NUM 16448_^1_%NUM 0_^1_%END_]_^__ 0PEWRITE CSY/ J21 P€1_%NAM EWRITE_'DECK-ID J21 FTN 3.3 RUNTIME_%SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3_^1*_$SMALL COMPUTER DEVELOPMENT DIVISION, LA JOLLA CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1973_^1_%SPC 2_^1*_$ERROR RETURN_^1_%ENT EWRITE_^1_%EXT* FORMTR_^1_%EQU ZERO($22)_^1_%EQU VR(1)_^1_%EQU VI(2)_^1_%EQU DEFLAG(35)_^1EWRITE 0_"0_)*'*ERROR DETECTED --- RETURN_^1€ø_%LDA- DEFLAG,I_^1_%SAM NXT-*-1_^1_%LDA FORMTR_^1_%STA* XIT_J*4.0/78*1917_^1_%JMP* NXT2_I*4.0/78*1917_^1NXT_"LDA- VR,I_^1NXT1_!STA* XIT_^1_%LDA- VI,I_^1_%LDQ- (I)_^1_%STA- I_^1NXT2_!ENA -1_K*4.0/78*1917_^1_%JMP* (XIT)_^1XIT_"NUM 0_^1_%END_]_^__øPINITL1 CSY/ J22 P€1_%NAM INITL1_'DECK-ID J22 FTN 3.3 RUNTIME_%SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3_^1*_$SMALL COMPUTER DEVELOPMENT DIVISION, LA JOLLA CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1973_^1_%SPC 2_^1_%ENT INITL1_^1_%ENT RESTRE_^1_%EXT* COMMON_^1_%EXT* ISAVE_^1_%EQU LPMSK(2)_^1_%EQU ZERO($22)_^1_%EQU VR(1)_^1_%EQU VI(2)_^1_%EQU LIST(25)_^1_%EQU ARGU1(31€€)_^1INITL1 0_"0_)***RESERVE VOLATILE STORAGE_^1_%RTJ* GETNTY_^1_%ADC COMMON_^1GETNTY 0_"0_)***GENERAL ENTRY FOR RUN-ANYWHERE CODE_^1_%STQ COMMON_'SAVE USERS Q-REG_^1_%LDQ- I_^1_%STQ ISAVE_(SAVE USERS I-REG_^1_%LDQ* GETNTY_^1_%LDA- (ZERO),Q_$NORMALIZE FWA OF COMMON_^1_%AAQ A_^1_%STA- I_,=LOC OF COMMON_^1_%INQ -2_^1_%LDQ- (ZERO),Q_^1_%INQ -3_^1_%LDA- (ZERO),Q_^1_%STA- VR,I_)=RE€€TURN TO USERS PROGRAM_^1_%RTJ* NORML_^1_%STA- ARGU1,I_^1_%RTJ* NORML_^1_%STA- LIST,I_^1_%JMP* (INITL1)_^1RESTRE STA* TEMP_%***RESTORE USERS REGISTERS_^1_%LDA- VR,I_^1_%STA* XIT_^1_%LDA- VI,I_)RESTORE USERS I-REG_^1_%LDQ- (I)_*RESTORE USERS Q-REG_^1_%STA- I_^1_%LDA* TEMP_^1_%JMP* (XIT)_(RETURN TO USERS PROGRAM_^1TEMP_!NUM 0_^1XIT_"NUM 0_^1NORML 0_"0_^1_%LDQ- VR,I_^1_%RAO- VR,I_^1€ú_%LDA- $F6_*NO RELATIVE ALLOWED IN UPPER BANK **MSOS4.0**_^1_%SAM KG65K_K**MSOS4.0**_^1_%LDA- (ZERO),Q_^1_%SAP OUT-*-1_^1_%AAQ A_^1_%AND- LPMSK+15_^1OUT_"JMP* (NORML)_^1KG65K LDA- (ZERO),Q_H**MSOS4.0**_^1_%JMP* (NORML)_I**MSOS4.0**_^1_%END_]_^__úPFORMTN CSY/ J23 P€1_%NAM FORMTN_'DECK-ID J23 FTN 3.3 RUNTIME_%SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3_^1*_$SMALL COMPUTER DEVELOPMENT DIVISION, LA JOLLA CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1973_^1_%SPC 2_^1*_$FORMAT INPUT/OUTPUT FROM/INTO A BUFFER_^1*_*MAIN PROGRAM FOR FORMATTED I/O_^1*_*CALLING SEQUENCE --- RTJ FORMTR_^1*_*PROGRAM EXPECTS ARGU1 TO CONTAIN THE_^1*_*€€BUFFER ADDRESS-1 AND ARGU2 TO CONTAIN_^1*_*THE FORMAT ADDRESS-1._^1*_*THESE ADDRESSES ARE SAVED THROUGHOUT_^1*_*THE ENTIRE EXECUTION OF ENCODE/DECODE._^1*_]_^1_%ENT FORMTR_^1_%ENT CHCNT_^1_%EXT* Q8QGET_^1_%EXT* GETCH_^1_%EXT* UPDATE_^1_%EXT* INTGR_^1_%EXT* DECPL_^1_%EXT* DCHX_^1_%EXT* ASCHX_^1_%EXT* AFRMIN_^1_%EXT* RFRMIN_^1_%EXT* FLOTIN_^1_%EXT* HOLRTH_^1_%EXT* QUOTE_MFTN*3.2_^1€€_%EXT* SPACEX_^1_%EXT* HXDC_^1_%EXT* HXASC_^1_%EXT* AFRMOT_^1_%EXT* RFRMOT_^1_%EXT* FOUT_^1_%EXT* EOUT_^1_%EXT* DOUT_L**FTN 3.1**_^1_%EXT* IPACK_^1_%EXT* EWRITE_^1_%EQU ZERO($22)_^1_%EQU ICODE(3)_^1_%EQU IA(4)_^1_%EQU IB(5)_^1_%EQU ICH(6)_^1_%EQU IFIELD(7)_^1_%EQU JFIELD(8)_^1_%EQU NUMBR(9)_^1_%EQU ITERAT(10)_^1_%EQU IX(11)_^1_%EQU JX(12)_^1_%EQU IBX(13)_^1_%EQU JBX(14€€)_^1_%EQU IR(15)_^1_%EQU ISTART(23)_^1_%EQU JSTART(24)_^1_%EQU LIST(25)_^1_%EQU MV(26)_^1_%EQU LPAREN(27)_^1_%EQU MAXCH(28)_^1_%EQU BUFFER(29)_^1_%EQU FORMAT(30)_^1_%EQU ARGU1(31)_^1_%EQU ARGU2(32)_^1_%EQU ARGU3(33)_^1_%EQU ARGU4(34)_^1_%EQU DEFLAG(35)_^1_%EQU NXTFLD($E0)_^1_%EQU IC($D2)_I**FTN 3.1**_^1_%EQU QAFLAG($D3)_GFTN*3.2_^1I80_"NUM 80_^1CHCNT NUM 156_^1F€€ORMTR 0_"0_)***CONTROL PROGRAM_^1_%LDA* CHCNT_^1_%LDQ- ICODE,I_%TEST IF REQUEST=READ_^1_%SQM STP1-*-1_^1_%LDA* I80_*YES, SET MAX RECORD=80 CHARACTERS_^1STP1_!STA- MAXCH,I_^1_%ENA 0_^1_%STA- LPAREN,I_$=PAREN COUNTER_^1_%STA- IX,I_)=WORD COUNT IN FORMAT_^1_%STA- IBX,I_(=WORD COUNT IN BUFFER_^1_%ENA 1_^1_%STA- JX,I_)=CHARACTER COUNT IN FORMAT_^1_%STA- JBX,I_(=CHARACTER COUNT IN BUF€€FER_^1STP10 ENA 1_^1_%STA- IB,I_)=CURRENT CHARACTER_^1STP20 LDA- FORMAT,I_$=ADDRESS OF FORMAT_^1_%ADD- IX,I_)ADD WORD COUNT_^1_%STA- ARGU3,I_^1_%ENA JX_^1_%ADD- I_,=ADDRESS OF CHARACTER_^1_%STA- ARGU4,I_(COUNT_^1_%RTJ GETCH_(GET CHARACTER IN FORMAT_^1_%STA- ICH,I_(=CURRENT CONTROL CHARACTER_^1_%TRA Q_.FROM FORMAT_^1_%INA -$20_)TEST ICH=BLANK_^1_%SAN STP22-*-1_^1_%JMP STP32€€0_'YES, IGNORE BLANKS_^1STP22 TRQ A_^1_%INA -$30_)TEST ICH=NON-NUMERIC VALUE_^1_%SAM STP30-*-1_^1_%ENA $39_^1_%SUB- ICH,I_^1_%SAP STP24-*-1_^1_%JMP* STP100_'ICH GT $39(NON-NUMERIC)_^1STP24 JMP STP330_^1STP30 TRQ A_^1_%INA -$28_)TEST ICH=LEFT PAREN_^1_%SAN STP40-*-1_^1_%JMP STP300_'YES, UPDATE PAREN COUNTER_^1STP40 TRQ A_^1_%INA -$29_)TEST ICH=RIGHT PAREN_^1_%SAN ST€€P50-*-1_^1_%JMP STP308_^1STP50 TRQ A_^1_%INA -$2F_)TEST ICH=SLASH_^1_%SAN STP60-*-1_^1_%JMP STP340_'YES, INSERT CARRIAGE RETRN_^1STP60 TRQ A_^1_%INA -$2C_)TEST ICH=COMMA_^1_%SAN STP100-*-1_^1_%JMP STP350_'YES, UPDATE FORMAT COUNTS_^1STP100 LDA- IB,I_^1_%STA- NUMBR,I_%=ITERATION/FORMAT CONTROL_^1_%ENA IX_-CHARACTER_^1_%ADD- I_^1_%STA- ARGU3,I_^1_%INA 1_^1_%STA- ARGU4,I_€€^1P1_#RTJ UPDATE_'UPDATE IX,JX_^1_%LDA- ICH,I_^1_%INA -$48_)TEST ICH=(H)_^1_%SAN ST1010_LFTN*3.2_^1_%JMP STP180_'YES, HOLLERITH DATA FOLLOWING H_$FTN*3.2_^1ST1010 LDA- ICH,I_MFTN*3.2_^1_%INA -$27_)TEST ICH = (')_6FTN*3.2_^1_%SAN ST1020_LFTN*3.2_^1_%ENA 1_QFTN*3.2_^1_%STA- QAFLAG_'QAFLAG = 1_:FTN*3.2_^1_%JMP STP180_'YES, HOLLERITH DATA FOLLOWING QUOTE FTN*3.2_^1ST1020 LDA- €€ICH,I_MFTN*3.2_^1_%INA -$2A_)TEST ICH = (*)_6FTN*3.2_^1_%SAN STP101_LFTN*3.2_^1_%ENA 0_QFTN*3.2_^1_%STA- QAFLAG_'QAFLAG = 0_:FTN*3.2_^1_%JMP* STP180_'YES, HOLLERITH DATA FOLLOWING ASTERISFTN*3.2_^1STP101 LDA- ICH,I_^1_%INA -$58_)TEST ICH=(X)_^1_%SAZ STP102-*-1_"YES, IGNORE FIELD WIDTH_^1_%LDA- FORMAT,I_$NO, CONVERT FIELD WIDTH IN_^1_%STA- ARGU1,I_(FORMAT SPECIFICATION_^1_%RTJ €€ INTGR_^1_%LDA- IB,I_^1_%STA- IFIELD,I_$=FIELD WIDTH_^1_%LDA- FORMAT,I_^1_%STA- ARGU1,I_%CHECK FOR FIELD SPEC BE-_^1_%RTJ DECPL_*YOND THE DECIMAL PLACE_^1STP102 LDA- ICODE,I_%TEST FOR ENCODE/DECODE REQ_^1_%SAP STP104-*-1_^1_%JMP STP200_'ENCODE REQUEST_^1STP104 RAO- NUMBR,I_^1LOOP1 LDA- NUMBR,I_%DECODE REQUEST_^1_%INA -1_^1_%SAN STP106-*-1_"TEST NUMBR=0_^1_%JMP* STP10_(YES, GE€€T NEXT FORMAT SPEC_^1STP106 STA- NUMBR,I_^1_%LDA- ICH,I_(TEST ICH=(X)_^1_%INA -$58_^1_%SAN STP110-*-1_^1_%ENA IBX_^1_%ADD- I_^1_%STA- ARGU3,I_^1_%INA 1_^1_%STA- ARGU4,I_^1_%RTJ UPDATE_^1_%JMP* LOOP1_*BUFFER_^1STP110 LDA- MV,I_)TEST IF PARAMETERS IN LIST_^1_%SAN STP111-*-1_$HAVE BEEN PROCESSED_^1_%JMP STP400_'YES, TERMINATE_^1STP111 LDA- ICH,I_^1_%INA -$49_)TEST ICH=(I)_^1_%€€SAZ CONTUE-*-1_^1_%JMP* STP115_^1CONTUE ENA -0_^1_%STA- JFIELD,I_^1_%LDA- BUFFER,I_^1_%STA- ARGU1,I_%YES, CONVERT NO. IN BUFFER_^1_%RTJ DCHX_+AS A DECIMAL INTEGER_^1_%LDA- JFIELD,I_^1_%SAP STP113-*-1_^1_%LDQ- IA,I_^1_%LDA- IB,I_^1OK_#SQP STP112-*-1_^1_%TCA A_^1_%TCQ Q_^1STP112 SQN STP113-*-1_^1_%SAP STP114-*-1_^1STP113 RTJ EWRITE_^1STP114 JMP* STP150_^1STP115 LDA- ICH,I_^€€1_%INA -$24_)TEST ICH=($)_^1_%SAN ST1155_LFTN*3.2_^1_%LDA- BUFFER,I_^1_%STA- ARGU1,I_%YES, CONVERT NO. IN BUFFER_^1_%RTJ ASCHX_*AS A HEXIDECIMAL NUMBER_^1_%JMP* STP150_^1ST1155 LDA- ICH,I_MFTN*3.2_^1_%INA -$5A_)TEST ICH=(Z) ON READ OR DECODE_%FTN*3.2_^1_%SAN STP116_LFTN*3.2_^1_%LDA- BUFFER,I_JFTN*3.2_^1_%STA- ARGU1,I_%YES, CONVERT NO. IN BUFFER_*FTN*3.2_^1_%RTJ ASCHX_(AS A HE€€XIDECIMAL_4FTN*3.2_^1_%JMP* STP150_LFTN*3.2_^1STP116 LDA- ICH,I_(TEST ICH=(A)_^1_%INA -$41_^1_%SAN STP120-*-1_^1_%ENA 2_,YES, CK FIELD WIDTH GT 2_^1_%SUB- IFIELD,I_^1_%SAP STP118-*-1_^1P2_#RTJ EWRITE_'YES, ERROR_^1STP118 LDA- BUFFER,I_^1_%STA- ARGU1,I_%PICK UP ALPHA-NUMERIC_^1_%RTJ AFRMIN_)CHARACTERS IN BUFFER_^1_%JMP* STP150_^1STP120 LDA- ICH,I_(TEST ICH=(R)_^1_%INA -$52_^1€€_%SAN STP130-*-1_^1_%ENA 1_,YES, CK FIELD WIDTH=1_^1_%SUB- IFIELD,I_^1_%SAP STP122-*-1_^1_%RTJ EWRITE_^1STP122 LDA- BUFFER,I_^1_%STA- ARGU1,I_^1_%RTJ RFRMIN_'PICK UP ALPH-NUMERIC_^1_%JMP* STP150_)CHARACTERS WITH R-FORMAT_^1STP130 LDA- ICH,I_(TEST ICH=(F)_^1_%INA -$46_^1_%SAZ STP132-*-1_^1_%RTJ EWRITE_^1STP132 LDA- BUFFER,I_^1_%STA- ARGU1,I_%YES, CONVERT NUMBER IN_^1_%RTJ F€€LOTIN_)BUFFER AS FLOATING POINT_^1P2X_"RTJ Q8QGET_'GET ADDRESS OF VARIABLE IN Q-REG_^1_%LDA- IA,I_)SAVE UPPER HALF OF FLOATING POINT_^1_%STA- (ZERO),Q_'NUMBER IN VARIABLE LIST_^1_%INQ 1_^1_%LDA- DEFLAG,I_$SAVE LOWER HALF OF FLOATING POINT NO._^1_%SAP STP152-*-1_"TEST IF ENCODE/DECODE_^1STP150 RTJ Q8QGET_'YES, GET ADDRESS FOR IB_^1STP152 LDA- IB,I_^1_%STA- (ZERO),Q_^1STP160 LDA-€€ MV,I_)=NO OF VARIABLES TO BE_^1_%INA -1_-CONVERTED--TERMINATE_^1_%STA- MV,I_^1_%JMP* LOOP1_^1STP180 LDA- ICODE,I_^1_%SAP STP182-*-1_^1_%LDA- BUFFER,I_$ENCODE(FORMAT TO BUFFER)_^1_%LDQ- FORMAT,I_^1_%JMP* STP190_^1STP182 INA 1_,(ICODE = 1) TRANSFER FROM_^1_%STA- ICODE,I_%BUFFER TO FORMAT FLAG_^1_%LDA- IX,I_)SWITCH FORMAT AND BUFFER_^1_%LDQ- IBX,I_*COUNTERS_^1_%STA- IBX,I_^1_%STQ-€€ IX,I_^1_%LDA- JX,I_^1_%LDQ- JBX,I_^1_%STA- JBX,I_^1_%STQ- JX,I_^1_%LDA- FORMAT,I_$DECODE(BUFFER TO FORMAT)_^1_%LDQ- BUFFER,I_^1STP190 STA- ARGU1,I_^1_%STQ- ARGU2,I_^1_%LDA- ICH,I_MFTN*3.2_^1_%INA -$48_NFTN*3.2_^1_%SAN ST1900_LFTN*3.2_^1_%RTJ HOLRTH_'PROCESS HOLLERITH CHARACTERS_(FTN*3.2_^1_%JMP* ST1910_LFTN*3.2_^1ST1900 RTJ QUOTE_(PROCESS HOLLERITH CHARACTERS_(FTN*3.2_^1ST1910€€ LDA- ICODE,I_KFTN*3.2_^1_%SAP STP192-*-1_^1_%JMP STP10_^1STP192 INA -1_+RESTORE ICODE FLAG_^1_%STA- ICODE,I_%ICODE =0_^1_%LDA- IX,I_)RESWITCH COUNTERS_^1_%LDQ- IBX,I_^1_%STA- IBX,I_^1_%STQ- IX,I_^1_%LDA- JX,I_^1_%LDQ- JBX,I_^1_%STA- JBX,I_^1_%STQ- JX,I_^1_%JMP STP10_^1STP200 RAO- NUMBR,I_%ENCODE REQUEST_^1LOOP2 LDA- NUMBR,I_^1_%INA -1_^1_%SAN STP202-*-1_^1_%JMP STP10_(NUMB€€R=0 GET NU FORMAT SPEC_^1STP202 STA- NUMBR,I_^1_%LDA- ICH,I_(TEST ICH=(X)_^1_%INA -$58_^1_%SAN STP210-*-1_^1_%LDA- BUFFER,I_^1_%STA- ARGU1,I_%YES, INSERT N-SPACES INTO_^1_%RTJ SPACEX_)BUFFER_^1_%JMP* LOOP2_^1STP210 LDA- MV,I_)TEST IF PARAMETERS IN LIST_^1_%SAN STP212-*-1_$HAVE BEEN PROCESSED_^1_%JMP STP400_'YES, TERMINATE_^1STP212 RTJ Q8QGET_^1_%LDA- (ZERO),Q_^1_%STA- IB,I_^1€€_%INQ 1_,=ADDRESS OF LOWER HALF OF_^1_%STQ- IA,I_+FLOATING POINT NUMBER_^1_%LDA- ICH,I_(TEST ICH=(I)_^1_%INA -$49_^1_%SAN STP220-*-1_^1_%LDA- BUFFER,I_^1_%STA- ARGU1,I_%YES, CONVERT VARIABLE TO A_^1_%LDA- JFIELD,I_^1_%STA- NXTFLD_^1_%ENQ 0_.DECIMAL INTEGER_^1_%LDA- IB,I_^1_%SAP STP214-*-1_^1_%TCQ Q_^1STP214 STQ- IA,I_^1_%RTJ HXDC_^1_%LDA- NXTFLD_^1_%STA- JFIELD,I_^1_%JMP* ST€€P260_^1STP220 LDA- ICH,I_(TEST ICH=($)_^1_%INA -$24_^1_%SAN STP225_LFTN*3.2_^1_%LDA- BUFFER,I_^1_%STA- ARGU1,I_%YES, CONVERT VARIABLE AS A_^1_%RTJ HXASC_*HEXIDECIMAL INTEGER_^1_%JMP* STP260_^1STP225 LDA- ICH,I_(TEST ICH=(Z) ON WRITE OR ENCODE_$FTN*3.2_^1_%INA -$5A_^1_%SAN STP230_LFTN*3.2_^1_%LDA- BUFFER,I_JFTN*3.2_^1_%STA- ARGU1,I_%YES CONVERT VARIABLE AS A_+FTN*3.2_^1_%RTJ H€€XASC_(HEXIDECIMAL INTEGER_1FTN*3.2_^1_%JMP* STP260_LFTN*3.2_^1STP230 LDA- ICH,I_(TEST ICH=(A)_^1_%INA -$41_^1_%SAN STP240-*-1_^1_%ENA 2_,YES, TEST IF FIELD WIDTH_^1_%SUB- IFIELD,I_'GT 2_^1_%SAP STP232-*-1_^1_%RTJ EWRITE_^1STP232 LDA- BUFFER,I_^1_%STA- ARGU1,I_%STORE ALPHA-NUMERIC CHARA-_^1_%RTJ AFRMOT_)CTERS INTO BUFFER_^1_%JMP* STP260_^1STP240 LDA- ICH,I_(TEST ICH=(R)_^1_%IN€€A -$52_^1_%SAN STP250-*-1_^1_%ENA 1_,YES, TEST IF FIELD WIDTH=1_^1_%SUB- IFIELD,I_^1_%SAP STP242-*-1_^1P3_#RTJ EWRITE_'NO, ERROR_^1STP242 LDA- BUFFER,I_^1_%STA- ARGU1,I_%STORE WITH R-FORMAT CHARA-_^1_%RTJ RFRMOT_)CTERS INTO BUFFER_^1_%JMP* STP260_^1STP250 LDQ- IA,I_)FLOATING POINT NUMBER_^1_%LDA- IB,I_)SHIFT UPPER HALF TO IA_^1_%STA- IA,I_)SAVE LOWER HALF IN IB_^1_%LDA- DEFLA€€G,I_^1_%SAP STP251-*-1_"TEST IF ENCODE/DECODE CALL_^1_%RTJ Q8QGET_'YES, UPDATE LIST ADDRESS_^1STP251 LDA- (ZERO),Q_^1_%STA- IB,I_^1_%LDA- 1,Q_*PICK UP THIRD WORD_0**FTN 3.1**_^1*_8FLOATING POINT NUMBER_-**FTN 3.1**_^1_%STA- IC_+AND STORE IN IC_3**FTN 3.1**_^1_%LDA- ICH,I_(TEST ICH=(F)_^1_%INA -$46_^1_%SAN STP252-*-1_^1_%LDA- BUFFER,I_^1_%STA- ARGU1,I_%CONVERT FLOATING POINT_^1_€€%RTJ FOUT_+NUMBER AS FIXED POINT_^1_%JMP* STP260_^1STP252 LDA- ICH,I_(TEST ICH=(E)_^1_%INA -$45_^1_%SAN STP254-*-1_F**FTN 3.1**_^1_%LDA- BUFFER,I_$CONVERT FLOATING POINT_,**FTN 3.1**_^1_%STA- ARGU1,I_I**FTN 3.1**_^1_%RTJ EOUT_+NUMBER AS EXPONENT OF 10_(**FTN 3.1**_^1_%JMP* STP260_J**FTN 3.1**_^1STP254 LDA- DEFLAG,I_H**FTN 3.1**_^1_%SAP STP255-*-1_"TEST IF ENCODE/DECODE CALL_(*€€*FTN 3.1**_^1_%RTJ Q8QGET_'YES, UPDATE LIST ADDRESS_***FTN 3.1**_^1STP255 LDA- ICH,I_(TEST ICH=(D)_6**FTN 3.1**_^1_%INA -$44_L**FTN 3.1**_^1_%SAZ STP256-*-1_F**FTN 3.1**_^1_%RTJ EWRITE_'NO, FORMAT ERROR_2**FTN 3.1**_^1STP256 LDA- BUFFER,I_H**FTN 3.1**_^1_%STA- ARGU1,I_%CONVERT DOUBLE PRECISION FLOATING **FTN 3.1**_^1_%RTJ DOUT_)POINT NUMBER AS EXPONENT OF 10._"**FTN 3.1**_^1S€€TP260 LDA- MV,I_)=NO OF VARIABLES TO BE_^1_%INA -1_-CONVERTED--TERMINATE_^1_%STA- MV,I_^1_%JMP* LOOP2_^1STP300 LDA- IB,I_)=ITERATION COUNT FOR PARA-_^1_%STA- ITERAT,I_'THESIZED FORMAT_^1_%RAO- LPAREN,I_^1_%ENA 2_,THERE CAN BE NO MORE THAN_^1_%SUB- LPAREN,I_'ONE LEVEL OF ()-FORMAT_^1_%SAP STP302-*-1_^1_%RTJ EWRITE_^1STP302 ENA IX_^1_%ADD- I_^1_%STA- ARGU3,I_^1_%INA 1_^1_%STA- €€ARGU4,I_^1_%RTJ UPDATE_'UPDATE FORMAT COUNTS_^1_%LDA- IX,I_)=ORDINAL TO THE START OF_^1_%STA- ISTART,I_'THE ()-FORMAT_^1_%LDA- JX,I_^1_%STA- JSTART,I_^1_%JMP STP10_^1STP308 LDA- ITERAT,I_$RIGHT PAREN ENCOUNTERED---_^1_%INA -1_-TEST IF FORMAT WITHIN ()_^1_%SAZ STP312-*-1_$IS TO BE REPEATED_^1STP310 STA- ITERAT,I_^1STP311 LDA- ISTART,I_$REPEAT PARENTHESIZED EXPRESSION_^1_%STA- IX€€,I_^1_%LDA- JSTART,I_^1_%STA- JX,I_^1_%JMP STP10_^1STP312 LDA- LPAREN,I_^1_%INA -1_^1_%SAN STP314-*-1_"TEST PAREN COUNT=1_^1_%LDA- MV,I_)TEST IF ALL VARIABLES IN LIST_^1_%SAZ STP313-*-1_$HAS BEEN PROCESSED_^1_%LDA- $E_+SET FLAG FOR END OF FORMAT_*69*1569_^1_%STA- ICH,I_M69*1569_^1_%JMP* STP340_'CONTINUE ON NEW RECORD_.69*1569_^1STP313 JMP* STP400_^1STP314 STA- LPAREN,I_$NO, CON€€TINUE SCANNING_^1_%JMP* STP350_)FORMAT_^1STP320 ENA IX_+UPDATE FORMAT COUNTERS_^1_%ADD- I_^1_%STA- ARGU3,I_^1_%INA 1_^1_%STA- ARGU4,I_^1P4_#RTJ UPDATE_^1_%JMP STP20_^1STP330 LDA- FORMAT,I_$CONVERT A DECIMAL INTEGER_^1_%STA- ARGU1,I_(NUMBER_^1_%RTJ INTGR_^1_%JMP STP20_^1STP340 LDA- ICODE,I_%A SLASH WAS ENCOUNTERED IN THE FORMAT_^1_%SAM STP342-*-1_$INSERT A CARRAGE RETURN IN T€€HE_^1_%JMP* STP350_)OUTPUT BUFFER_^1STP342 ENA 13_^1_%STA- IB,I_^1_%LDA CHCNT_^1_%INA 1_^1_%STA- MAXCH,I_^1_%LDA- BUFFER,I_$COMPUTE BUFFER ADDRESS_^1_%ADD- IBX,I_^1_%STA- ARGU3,I_^1_%ENA JBX_^1_%ADD- I_^1_%STA- ARGU4,I_^1P5_#RTJ IPACK_(PACK CHARACTER INTO BUFFER_^1_%ENA IBX_*UPDATE BUFFER COUNTERS_^1_%ADD- I_^1_%STA- ARGU3,I_^1_%INA 1_^1_%STA- ARGU4,I_^1_%RTJ UPDATE_^1STP35€ 0 ENA IX_+UPDATE FORMAT COUNTS_^1_%ADD- I_^1_%STA- ARGU3,I_^1_%INA 1_^1_%STA- ARGU4,I_^1_%RTJ UPDATE_^1_%LDA- ICH,I_M69*1569_^1_%SUB- $E_P69*1569_^1_%SAN STP355_'SKIP NOT END OF FORMAT_.69*1569_^1_%JMP* STP311_L69*1569_^1STP355 JMP STP10_M69*1569_^1STP400 JMP (FORMTR)_^1_%END_]_^__ PQ8QFI CSY/ J24 P€1_%NAM Q8QFI_(DECK-ID J24 FTN 3.3 RUNTIME_%SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^1_%SPC 2_^1*_$RAISE 10**N, WHERE N=NUMBER OF PLACES BEYOND THE DECIMAL POINT_^1_%ENT Q8QFI_^1_%EXT HFLOT_OFTN 3.3_^1_%EQU SCALE($DC)_^1_%EQU ICOUNT($E3)_^1_%EQU JFIELD(8)_^1€pQ8QFI 0_"0_)***RAISE 10**N_^1_%LDA* FLOT1_^1_%STA- SCALE_^1_%ENA 0_^1_%STA- SCALE+1_^1_%STA- ICOUNT_^1LOOP_!LDA- ICOUNT_^1_%SUB- JFIELD,I_^1_%SAN NEXT-*-1_^1_%JMP* (Q8QFI)_^1NEXT_!RTJ HFLOT_OFTN 3.3_^1_%NUM $B595_^1_%ADC SCALE_^1_%ADC FLOT10-*_^1_%NUM $D400_^1_%ADC SCALE_^1_%RAO- ICOUNT_^1_%JMP* LOOP_^1FLOT10 NUM $4250,$0_^1FLOT1 NUM $40C0_^1_%END_]_^__ pPQ8QFL CSY/ J25 P€1_%NAM Q8QFL_(DECK-ID J25 FTN 3.3 RUNTIME_%SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3_^1*_$SMALL COMPUTER DEVELOPMENT DIVISION, LA JOLLA CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1973_^1_%SPC 2_^1*_$CONVERT 2 WORD INTEGER VALUE TO A FLOATING POINT NUMBER_^1*_$THE INTEGER MAY NOT EXCEED ABS(99,999)_^1_%ENT Q8QFL_^1_%EQU LPMSK(3)_^1_%EQU IA(4)_^1_%EQU IB(5€€)_^1_%EQU A1($D8)_^1Q8QFL 0_"0_)***CONVERT FIXED TO FLOATING_^1_%LDA- IA,I_^1_%LDQ- IB,I_^1_%SAP FLT1-*-1_^1_%TCA A_^1_%TCQ Q_^1_%STQ- IB,I_^1FLT1_!SAN FLT2-*-1_^1_%SQN FLT2-*-1_^1_%STA- A1+1_)5/18/69_^1_%JMP* RTRN_^1FLT2_!CLR Q_^1_%STQ- A1_^1_%SAN FLT3-*-1_^1_%ENQ 16_^1_%STQ- A1_^1_%LDQ- IB,I_^1_%JMP* FLT4_^1FLT3_!TRA Q_^1_%LDA- IB,I_^1FLT4_!SQM FLT5-*-1_^1_%LLS 1_^1_€.%RAO- A1_^1_%JMP* FLT4_^1FLT5_!LRS 9_^1_%STA- A1+1_^1_%LDA- LPMSK+6_^1_%LAQ Q_^1_%LDA- A1_^1_%INA -9_^1_%TCA A_^1_%ADD =N$97_^1_%ALS 7_^1_%EAQ Q_^1RTRN_!LDA- IA,I_)5/18/69_^1_%SAP FLT8-*-1_^1_%TCQ Q_^1_%LDA- A1+1_^1_%TCA A_^1_%STA- A1+1_)5/18/69_^1FLT8_!STQ- A1_^1_%JMP* (Q8QFL)_^1_%END_]_^__.PQ8QFX CSY/ J26 P€1_%NAM Q8QFX_(DECK-ID J26 FTN 3.3 RUNTIME_%SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3_^1*_$SMALL COMPUTER DEVELOPMENT DIVISION, LA JOLLA CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1973_^1_%SPC 2_^1_%ENT Q8QFX_^1_%EQU MSK(6)_L71*1626_^1_%EQU IA(4)_^1_%EQU IB(5)_^1_%EQU LLS(9)_^1_%EQU A2($DA)_^1Q8QFX 0_"0_)***CONVERT FLOATING TO FIXED_^1_%LDA- A2_^1_%SAP€€ FIX-*-1_^1_%TCA A_^1_%LDQ- A2+1_^1_%TCQ Q_^1_%STQ- A2+1_^1FIX_"ENQ 0_^1_%LLS 2_^1_%SQN FIX1-*-1_^1_%ENA 0_^1_%JMP* OUT_^1FIX1_!ENQ 0_^1_%LLS 2_^1_%SQZ FIX2-*-1_^1_%LDA- A2_^1_%LDQ- A2+1_^1_%STQ- IB,I_^1_%JMP* RTRN_^1FIX2_!LDQ- LLS_^1_%SAP FIX3-*-1_^1_%LLS 5_^1_%INQ -1_^1_%STQ* SHIFT1_^1_%ENQ 0_^1_%LLS 7_^1_%LDA- A2+1_^1_%LRS 6_^1SHIFT1 LLS 0_^1_%JMP* OUT_^1FIX3_!L€LS 5_^1_%STQ* SHIFT2_^1_%ENQ 0_^1_%LLS 7_^1_%LDA- A2+1_^1_%LRS 7_^1SHIFT2 LLS 0_^1_%ENA 0_^1OUT_"STQ- IB,I_^1_%AND- MSK_*MASK OUT ALL EXTRANEOUS BITS_^1_%LDQ- A2_^1_%SQP RTRN-*-1_^1_%TCA A_^1_%LDQ- IB,I_^1_%TCQ Q_^1_%STQ- IB,I_^1RTRN_!STA- IA,I_^1_%JMP* (Q8QFX)_^1_%END_]_^__PHEXASC CSY/ J27 P€1_%NAM HEXASC_'DECK-ID J27 FTN 3.3 RUNTIME_%SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3_^1*_$SMALL COMPUTER DEVELOPMENT DIVISION, LA JOLLA CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1973_^1_%SPC 2_^1*_$CONVERT A VARIABLE INTO ASCII CODE_^1_%ENT HEXASC_^1_%EXT* INITL1_^1_%EXT* HXASC_^1_%EXT* RESTRE_^1_%EXT* CHCNT_^1_%EQU ZERO($22)_^1_%EQU IB(5)_^1_%EQU IFIE€€LD(7)_^1_%EQU IBX(13)_^1_%EQU JBX(14)_^1_%EQU LIST(25)_^1_%EQU MAXCH(28)_^1_%EQU ARGU1(31)_^1_%EQU DEFLAG(35)_^1HEXASC 0_"0_)***CONVERT HEX TO ASCII_^1_%RTJ INITL1_^1_%ENA -1_^1_%STA- DEFLAG,I_^1_%LDA CHCNT_^1_%STA- MAXCH,I_^1_%ENA 4_^1_%STA- IFIELD,I_$SET FIELD WIDTH=4_^1_%ENA 1_^1_%STA- IBX,I_(INITIALIZE BUFFER COUNTS_^1_%STA- JBX,I_^1_%LDQ- ARGU1,I_^1_%LDA- (ZERO),Q_$€ºPLACE HEX VARIABLE IN IB_^1_%STA- IB,I_^1_%LDA- LIST,I_'SET BUFFER ADDRESS IN_^1_%INA -1_-ARGU3_^1_%STA- ARGU1,I_^1_%RTJ HXASC_(CONVERT AND PACK CHARACTER_^1_%JMP RESTRE_^1_%END_]_^__ºPHEXDEC CSY/ J28 P€1_%NAM HEXDEC_'DECK-ID J28 FTN 3.3 RUNTIME_%SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3_^1*_$SMALL COMPUTER DEVELOPMENT DIVISION, LA JOLLA CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1973_^1_%SPC 2_^1*_$CONVERT A VARIABLE TO DECIMAL FORMAT_^1_%ENT HEXDEC_^1_%EXT* INITL1_^1_%EXT* HXDC_^1_%EXT* RESTRE_^1_%EXT* CHCNT_^1_%EQU ZERO($22)_^1_%EQU IA(4)_^1_%EQU IB(€€5)_^1_%EQU IFIELD(7)_^1_%EQU JFIELD(8)_^1_%EQU IBX(13)_^1_%EQU JBX(14)_^1_%EQU LIST(25)_^1_%EQU MAXCH(28)_^1_%EQU ARGU1(31)_^1_%EQU DEFLAG(35)_^1HEXDEC 0_"0_)***FORMAT A DECIMAL INTEGER_^1_%RTJ INITL1_^1_%ENA -1_^1_%STA- DEFLAG,I_^1_%LDA CHCNT_^1_%STA- MAXCH,I_^1_%ENA 0_^1_%STA- JFIELD,I_$PLACES BEYOND DECIMAL PT=0_^1_%ENA 6_^1_%STA- IFIELD,I_$FIELD WIDTH=6_^1_%ENA 1_€>^1_%STA- IBX,I_(INITIALIZE BUFFER COUNTS_^1_%STA- JBX,I_^1_%LDQ- ARGU1,I_^1_%LDA- (ZERO),Q_^1_%STA- IB,I_)SET IB=HEX INTEGER_^1_%ENQ 0_^1_%SAP NXT-*-1_^1_%TCQ Q_^1NXT_"STQ- IA,I_^1_%LDA- LIST,I_^1_%INA -1_^1_%STA- ARGU1,I_%=ADDRESS OF BUFFER_^1_%RTJ HXDC_)CONVERT AND PACK CHARACTER_^1_%JMP RESTRE_^1_%END_]_^__ >PASCII CSY/ J29 P€1_%NAM ASC11_(DECK-ID J29 FTN 3.3 RUNTIME_%SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3_^1*_$SMALL COMPUTER DEVELOPMENT DIVISION, LA JOLLA CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1973_^1_%SPC 2_^1*_$CONVERT A VARIABLE FROM ASCII TO HEX_^1_%ENT ASCII_^1_%EXT* INITL1_^1_%EXT* ASCHX_^1_%EXT* RESTRE_^1_%EQU ZERO($22)_^1_%EQU IB(5)_^1_%EQU IFIELD(7)_^1_%EQU €€IBX(13)_^1_%EQU JBX(14)_^1_%EQU LIST(25)_^1_%EQU ARGU1(31)_^1_%EQU DEFLAG(35)_^1ASCII 0_"0_)***CONVERT FROM ASCII TO HEX_^1_%RTJ INITL1_^1_%ENA -1_^1_%STA- DEFLAG,I_^1_%ENA 4_^1_%STA- IFIELD,I_$FIELD WIDTH=4_^1_%ENA 1_^1_%STA- IBX,I_(INITIALIZE BUFFER COUNTS_^1_%STA- JBX,I_^1_%LDA- ARGU1,I_^1_%INA -1_^1_%STA- ARGU1,I_^1_%RTJ ASCHX_(CONVERT FROM ASCII TO HEX_^1_%LDQ- LIST€Z,I_^1_%LDA- IB,I_^1_%STA- (ZERO),Q_$STORE CONVERTED INTEGER_^1_%JMP RESTRE_^1_%END_]_^__ ZPDECHEX CSY/ J30 P€1_%NAM DECHEX_'DECK-ID J30 FTN 3.3 RUNTIME_%SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3_^1*_$SMALL COMPUTER DEVELOPMENT DIVISION, LA JOLLA CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1973_^1_%SPC 2_^1*_$CONVERT DECIMAL INTEGER TO HEX_^1_%ENT DECHEX_^1_%EXT* INITL1_^1_%EXT* DCHX_^1_%EXT* RESTRE_^1_%EQU ZERO($22)_^1_%EQU IA(4)_^1_%EQU IB(5)_^1_%EQU IFIELD(7)€€_^1_%EQU JFIELD(8)_^1_%EQU IBX(13)_^1_%EQU JBX(14)_^1_%EQU LIST(25)_^1_%EQU ARGU1(31)_^1_%EQU DEFLAG(35)_^1DECHEX 0_"0_)***DECIMAL INTEGER CONVERSION_^1_%RTJ INITL1_^1_%ENA -1_^1_%STA- DEFLAG,I_^1_%ENA 6_^1_%STA- IFIELD,I_$FIELD WIDTH=6_^1_%ENA 0_^1_%STA- JFIELD,I_$PLACES BEYOND DECIMAL PT=0_^1_%ENA 1_^1_%STA- IBX,I_(INITIALIZE BUFFER COUNTS_^1_%STA- JBX,I_^1_%LDA- ARGU1€,I_^1_%INA -1_^1_%STA- ARGU1,I_^1_%RTJ DCHX_^1_%LDA- IB,I_^1_%LDQ- IA,I_^1_%SQP NXT-*-1_^1_%TCQ Q_^1_%TCA A_^1NXT_"SQN NXT1-*-1_^1_%SAP NXT2-*-1_^1NXT1_!ENA -0_^1_%JMP* OUT_^1NXT2_!LDQ- LIST,I_^1_%LDA- IB,I_^1_%STA- (ZERO),Q_$STORE VARIABLE_^1OUT_"JMP RESTRE_^1_%END_]_^__ PAFORM CSY/ J31 P€1_%NAM AFORM_(DECK-ID J31 FTN 3.3 RUNTIME_%SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3_^1*_$SMALL COMPUTER DEVELOPMENT DIVISION, LA JOLLA CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1973_^1_%SPC 2_^1*_$CONVERT A SINGLE VARIABLE WITH (A)FORMAT_^1_%ENT AFORM_^1_%EXT* INITL1_^1_%EXT* AFRMIN_^1_%EXT* RESTRE_^1_%EQU ZERO($22)_^1_%EQU ICOUNT($D9)_^1_%EQU IB(5)_^1€€_%EQU IFIELD(7)_^1_%EQU JFIELD(8)_^1_%EQU IBX(13)_^1_%EQU JBX(14)_^1_%EQU LIST(25)_^1_%EQU ARGU1(31)_^1_%EQU DEFLAG(35)_^1AFORM 0_"0_)***(A)FORMATTED VARIABLE_^1_%RTJ INITL1_^1_%ENA -1_^1_%STA- DEFLAG,I_^1_%ENA 1_,INITIALIZE THE BUFFER CNTS_^1_%STA- IFIELD,I_^1_%STA- IBX,I_^1_%STA- JBX,I_^1_%STA- ICOUNT_^1_%LDA- ARGU1,I_^1_%INA -1_^1_%STA- ARGU1,I_^1LOOP_!RTJ AFRMIN_'M€ASK CHARACTER OUT OF WORD_^1_%LDQ- ICOUNT_^1_%INQ -1_^1_%ADQ- LIST,I_^1_%LDA- IB,I_^1_%STA- (ZERO),Q_$SAVE VARIABLE_^1_%ENA 2_,=2 CHARACTERS/WORD_^1_%SUB- ICOUNT_^1_%SAZ OUT-*-1_^1_%RAO- ICOUNT_^1_%JMP* LOOP_)GET NEXT CHARACTER_^1OUT_"JMP RESTRE_^1_%END_]_^__ PRFORM CSY/ J32 P€1_%NAM RFORM_(DECK-ID J32 FTN 3.3 RUNTIME_%SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3_^1*_$SMALL COMPUTER DEVELOPMENT DIVISION, LA JOLLA CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1973_^1_%SPC 2_^1*_$CONVERT A SINGLE VARIABLE WITH (R)FORMAT_^1_%ENT RFORM_^1_%EXT* INITL1_^1_%EXT* RFRMIN_^1_%EXT* RESTRE_^1_%EQU ZERO($22)_^1_%EQU ICOUNT($D9)_^1_%EQU IB(5)_^1€€_%EQU IFIELD(7)_^1_%EQU IBX(13)_^1_%EQU JBX(14)_^1_%EQU LIST(25)_^1_%EQU ARGU1(31)_^1_%EQU DEFLAG(35)_^1RFORM 0_"0_)***(R)FORMATTED VARIABLE_^1_%RTJ INITL1_^1_%ENA -1_^1_%STA- DEFLAG,I_^1_%ENA 1_^1_%STA- IFIELD,I_$INITIALIZE BUFFER COUNTS_^1_%STA- IBX,I_^1_%STA- JBX,I_^1_%STA- ICOUNT_^1_%LDA- ARGU1,I_^1_%INA -1_^1_%STA- ARGU1,I_^1LOOP_!RTJ RFRMIN_'MASK CHARACTER_^1_%LDQ€æ- ICOUNT_^1_%INQ -1_^1_%ADQ- LIST,I_^1_%LDA- IB,I_^1_%STA- (ZERO),Q_$SAVE CHARACTER_^1_%ENA 2_,=2 CHARACTERS/WORD_^1_%SUB- ICOUNT_^1_%SAZ OUT-*-1_^1_%RAO- ICOUNT_^1_%JMP* LOOP_)GET 2ND CHARACTER_^1OUT_"JMP RESTRE_^1_%END_]_^__æPFLOATG CSY/ J33 P€1_%NAM FLOATG_'DECK-ID J33 FTN 3.3 RUNTIME_%SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN VERSION 3.3_^1*_$SMALL COMPUTER DEVELOPMENT DIVISION, LA JOLLA CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1973_^1_%SPC 2_^1*_$CONVERT A FLOATING POINT NUMBER TO AN (E)FORM_^1_%ENT FLOATG_^1_%EXT* INITL1_^1_%EXT* EOUT_^1_%EXT* RESTRE_^1_%EXT* CHCNT_^1_%EQU ZERO($22)_^1_%EQU IA(4)_^1_€€%EQU IB(5)_^1_%EQU IFIELD(7)_^1_%EQU JFIELD(8)_^1_%EQU IBX(13)_^1_%EQU JBX(14)_^1_%EQU LIST(25)_^1_%EQU MAXCH(28)_^1_%EQU ARGU1(31)_^1_%EQU DEFLAG(35)_^1FLOATG 0_"0_)***FLOATING POINT CONVERSION_^1_%RTJ INITL1_'FORMAT OF NUMBER=_^1_%ENA -1_^1_%STA- DEFLAG,I_^1_%LDA CHCNT_^1_%STA- MAXCH,I_^1_%ENA 12_/S.XXXXXXESXX(S=SIGN)_^1_%STA- IFIELD,I_$FIELD WIDTH=12_^1_%ENA 6_^1_%€HSTA- JFIELD,I_$NUMBER OF SIGNIFICANT PL=6_^1_%ENA 1_^1_%STA- IBX,I_^1_%STA- JBX,I_^1_%LDQ- ARGU1,I_^1_%LDA- (ZERO),Q_^1_%STA- IA,I_^1_%INQ 1_^1_%LDA- (ZERO),Q_^1_%STA- IB,I_)IA,IB=FLOATING PT NUMBER_^1_%LDA- LIST,I_^1_%INA -1_^1_%STA- ARGU1,I_%=ADDRESS OF BUFFER_^1_%RTJ EOUT_)CONVERT AND PACK_^1_%JMP RESTRE_^1_%END_]_^__ HPQ8QD2I CSY/ K01 P€1_%NAM Q8QD2I_'DECK-ID K01 FTN 3.3 RUNTIME_%SUMMARY-102_^1*_$1700 FORTRAN RUNTIME VERSION 3.3_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^1_%SPC 5_^1*_$NON-REENTRANT_$---EXPONENTIATION---_^1*_]_^1_%ENT Q8QD2I_'DOUBLE PRECISION FLOATING TO INTEGER_'-1_^1_%ENT Q8QD2F_'D.P. FLOATING TO SINGLE PRECISION FLOATING +1_^1_%€€ENT Q8QD2D_'D.P. FLOATING TO D.P. FLOATING_.0_^1*_]_^1_%EQU DFLOFG($E5)_^1_%EQU DFRSLT($DB)_^1_%EQU SIGN($E1)_^1_%EQU COEFF($E2)_^1_%EQU EXPO($D7)_^1_%EQU MLTPR($DE)_^1_%EQU DFLACC($C5)_^1_%EQU CZERO($22)_^1_%EQU MASKSB($11)_!7FFF_^1_%EQU THREE($04)_JFTN 3.3_^1*_]_^1_%EXT* IFALT_OFTN 3.3_^1_%EXT HDFLOT_NFTN 3.3_^1_%EXT DEXP_^1_%EXT DLOG_^1*_]_^1*_]_^1Q8QD2I NUM 0_,EN€€TRY POINT, D.P. FLOATING TO INTEGER_^1_%STQ* QSAVE_(SAVE Q REGISTER_^1_%LDA* Q8QD2I_'SAVE WORD MARK_^1_%ENQ -1_^1_%JMP* PARAMS_^1*_]_^1*_]_^1Q8QD2D NUM 0_,ENTRY POINT, D.P. FLOATING TO D.P. FLOATING_^1_%STQ* QSAVE_(SAVE Q REGISTER_^1_%LDA* Q8QD2D_'SAVE WORD MARK_^1_%ENQ 0_^1_%JMP* PARAMS_^1*_]_^1*_]_^1Q8QD2F NUM 0_,ENTRY POINT, D.P. FLOATING TO S.P. FLOATING_^1_%STQ* QSAVE_^1_%€€LDA* Q8QD2F_^1_%ENQ 1_^1*_]_^1*_8PARAMETER PICKUP ROUTINE_^1*_]_^1PARAMS STA* RETADD_'CALLING SEQUENCE ADDRESS_^1_%LDA* (RETADD)_$OBTAIN ADDRESS OF COEFFICIENT_^1_%STQ- DFLOFG_'SET FLAG_^1_%LDQ- $F6_*CHECK IF IN UPPER BANK_^1_%SQM KLG65K_'IF SO, NO RELATIVE ALLOWED_^1_%SAP KLG65K_^1_%ADD* RETADD_^1_%AND- MASKSB_NFTN 3.3_^1KLG65K STA- COEFF_(ADDRESS OF COEFFICIENT_^1_%RAO* RETADD€€_^1_%LDA* (RETADD)_$OBTAIN ADDRESS OF EXPONENT_^1_%SQM KL65K_^1_%SAP KL65K_^1_%ADD* RETADD_^1_%AND- MASKSB_5$7FFF_3FTN 3.3_^1KL65K STA- EXPO_)ADDRESS OF EXPONENT_^1_%RAO* RETADD_'COMPUTE RETURN ADDRESS_^1_%LDQ- DFLOFG_^1_%SQP DRET_)IS EXPONENT FLOATING POINT_^1*_8NO - EXPONENT IS INTEGER_^1_%LDA- (EXPO)_'OBTAIN EXPONENT AND STORE_^1_%STA- SIGN_)IN SIGN_^1_%SAP STABS_^1_%TCA A€€_,EXPO = - EXPO_^1STABS STA- EXPO_)ABSOLUTE VALUE OF EXPONENT_^1_%JMP* CDFOVF_'GO TO (D**I) LOGIC_^1DRET_!JMP* DLOGEX_'YES EXPONENT IS S.P. OR D.P. FLOATING POINT_^1*_]_^1*_]_^1QSAVE NUM 0_^1RETADD NUM 0_^1*_]_^1*_]_^1*_8THIS LOGIC IS DESIGNED TO PERFORM THE DOUBLE_^1*_8PRECISION TO INTEGER EXPONENTIATION (D**I)_^1*_]_^1*_]_^1CDFOVF RTJ IFALT_)CLEAR ALL ERRORS_6FTN 3.3_^1_%ADC €€ THREE_OFTN 3.3_^1_%LDQ- COEFF_(TRANSFER_^1_%LDA- (CZERO),Q_#COEFF_^1_%STA- MLTPR_(TO_^1_%LDA- 1,Q_*INTERNAL_^1_%STA- MLTPR+1_%WORKING_^1_%LDA- 2,Q_*CELLS_^1_%STA- MLTPR+2_^1DFLTAD RTJ HDFLOT_NFTN 3.3_^1_%NUM $BD40_OFTN 3.3_^1_%ADC DFLT1_(LDA 1.0D0_^1_%ADC DFRSLT_'STA DFRSLT_(DFRSLT=1.0D0_^1_%JMP* TSTBT0_^1*_]_^1*_]_^1*_]_^1*_]_^1DLOGEX LDQ- COEFF_(TRANSFER_^1_%LDA- 1,Q_*VALUE €€OF_^1_%STA- DFRSLT+1_$COEFFICIENT_^1_%LDA- 2,Q_*TO_^1_%STA- DFRSLT+2_$INTERNAL_^1_%LDA- (CZERO),Q_#WORKING_^1_%STA- DFRSLT_'CELLS._^1_%SAN LOGNAT_'IF COEFFICIENT IS NONZERO GO TO NAT. LOG._^1SETZRO RTJ* (DFLTAD+1)_"IF COEFFICIENT IS ZERO MAKE RESULT ZERO TO_^1_%NUM $B400_(AVOID FAULT IN NATURAL LOG ROUTINE._^1_%ADC DFLT0_(LDA 0.0D0_^1_%JMP* EXDPFR_'EXIT_BFTN 3.3_^1*_]_^1*_]_^1LO€€GNAT RTJ DLOG_)TAKE NATURAL LOG OF COEFF - DLOG(COEFF)_^1_%ADC DFRSLT_^1*_]_^1*_8RESULT IS IN THE_6FTN 3.3_^1*_8DOUBLE PRECISION FLOATING POINT ACCUMULATOR_^1*_]_^1_%LDQ- EXPO_)TRANSFER_^1_%LDA- (CZERO),Q_#VALUE OF_^1_%STA- MLTPR_(EXPONENT_^1_%LDA- 1,Q_*TO_^1_%STA- MLTPR+1_%INTERNAL_^1_%LDA- 2,Q_*WORKING_^1_%STA- MLTPR+2_%CELLS._^1_%LDA- DFLOFG_^1_%SAZ DPEXPO_'IS IT A DOUBLE PRE€€CISION EXPONENT_^1_%ENA 0_,NO - SINGLE PRECISION EXPONENT_^1_%STA- MLTPR+2_%STORE ZERO IN THIRD WORD_^1DPEXPO RTJ* (DFLTAD+1)_"MULTIPLY BY D.P. OR S.P. EXPONENT CALL DFLOT_^1_%NUM $9D40_(FMPY,MLTPR/FLST,MLTPR_1FTN 3.3_^1_%ADC MLTPR_OFTN 3.3_^1_%ADC MLTPR_OFTN 3.3_^1_%RTJ DEXP_)RAISE E TO COMPUTED EXPONENT_^1_%ADC MLTPR_(DEXP(EXPON*DLOG(COEFF))_^1*_]_^1*_8RESULT IS IN THE FLO€€ATING ACCUMULATOR FTN 3.3_^1*_]_^1_%JMP* EXDPFR_'EXIT_^1*_]_^1*_]_^1TSTBT0 LDQ- EXPO_)TEST BIT ZERO OF THE EXPONENT_^1_%LRS 1_,AND RESET EXPONENT RIGHT SHIFTED_^1_%STQ- EXPO_^1_%SAP TST4ZR_^1*_]_^1*_8BIT WAS ON UPDATE_^1*_8CUMULATIVE RESULTS_^1*_]_^1_%RTJ* (DFLTAD+1)_"CALL DFLOT_^1_%NUM $B9D4_^1_%ADC DFRSLT_^1_%ADC MLTPR_^1_%ADC DFRSLT_'DFRSLT=DFRSLT*MLTPR_^1*_]_^1*_]_^1TST4€€ZR LDA- EXPO_)TEST EXPONENT TO SEE IF ALL SIGNIFICANT_^1_%SAN UPMULT_'BITS HAVE BEEN SHIFTED OUT_^1_%JMP* CHKSIN_^1*_]_^1*_]_^1UPMULT RTJ* (DFLTAD+1)_"SQUARE FLOATING MULTIPLIER_%CALL DFLOT_^1_%NUM $B9D4_^1_%ADC MLTPR_^1_%ADC MLTPR_^1_%ADC MLTPR_(MLTPR = MLTPR * MLTPR_^1_%JMP* TSTBT0_^1*_]_^1*_8CHECK SIGN OF EXPONENT FOR NEGATIVE IN WHICH_^1*_8CASE THE RESULT MUST BE INVERTED.€€_^1*_]_^1*_]_^1CHKSIN LDA- SIGN_)INVERT DP FLOATING RESULT_'CALL DFLOT_^1_%SAM MSIGN_^1_%JMP* EXDPFR_^1MSIGN RTJ* (DFLTAD+1)_^1_%NUM $BA40_^1_%ADC DFLT1_(LDA 1.0D0_^1_%ADC DFRSLT_'DIV DFRSLT_^1*_]_^1*_]_^1*_8EXIT WITH D.P. FLOATING RESULT IN_^1*_8LOW CORE CELLS C5,C6, AND C7._^1*_]_^1*_]_^1EXDPFR LDQ* QSAVE_(RESTORE Q REGISTER_^1_%JMP* (RETADD)_$RETURN TO CALLING PROGRAM_^1DFL€¢T1 NUM $40C0_(DOUBLE PRECISION FLOATING CONSTANT 1.0D0_^1DFLT0 NUM $0000_(DOUBLE PRECISION FLOATING CONSTANT 0.0D0_^1_%NUM $0000_^1_%NUM $0000_^1_%END_]_^__¢PSGLDBL CSY/ K03 P€1_%NAM SGLDBL_'DECK-ID K03 FTN 3.3 RUNTIME_%SUMMARY-102_^1*_$1700 MASS STORAGE FORTRAN RUNTIME VERSION 3.3_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^1_%SPC 5_^1_%ENT SNGL_^1_%ENT DBLE_^1_%ENT Q8SNGL_^1_%ENT Q8DBLE_^1_%SPC 3_^1_%EXT HFLOT_^1_%EXT* PARABS_^1_%SPC 3_^1*_$CONVERTS A SINGLE PRECISION ARGUMENT TO DO€€UBLE PRECISION_^1*_$AND A DOUBLE PRECISION ARGUMENT TO SINGLE PRECISION FORM_^1*_$SINCE THE SINGLE PRECISION ACCUMULATOR IS ALWAYS IN DOUBLE_^1*_$PRECISION FORM, THIS PROGRAM CONSISTS OF A SINGLE PRECISION_^1*_$FLOATING LOAD ONLY._^1_%SPC 3_^1SNGL_!EQU SNGL(*)_^1DBLE_!EQU DBLE(*)_^1Q8SNGL EQU Q8SNGL(*)_^1Q8DBLE NOP 0_^1_%STQ* QSV4_)SAVE USER'S Q REGISTER_^1_%LDA* Q8DBLE_'ADDRE€SS OF PARAMETER ADDRESS_^1_%RAO* Q8DBLE_'BUMP RETURN ADDRESS_^1_%RTJ PARABS_'ABSOLUTIZE PARAMETER ADDRESS_^1_%STA* PARADD_^1_%RTJ HFLOT_^1_%NUM $B400_^1PARADD ADC 0_^1_%LDQ* QSV4_^1_%JMP* (Q8DBLE)_$RETURN TO CALLER_^1_%SPC 3_^1QSV4_!NUM 0_^1_%END_]_^__PDABS CSY/ K04 P€1_%NAM DABS_)DECK-ID K04 FTN 3.3 RUNTIME_%SUMMARY-102_^1*_$1700 FORTRAN RUNTIME VERSION 3.3_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^1_%SPC 5_^1*_8DABS - ABSOLUTE VALUE FUNCTION -_^1*_8ROUTINE TO COMPUTE THE ABSOLUTE_^1*_8VALUE OF A DOUBLE PRECISION FLOATING_^1*_8POINT VALUE AND LEAVE THE RESULT IN THE_^1*_8PSEUDO A€€CCUMULATOR._^1*_]_^1_%ENT DABS_^1_%ENT Q8DAB_^1*_]_^1_%EXT* PARABS_NFTN 3.3_^1_%EXT HDFLOT_NFTN 3.3_^1*_]_^1_%EQU DFLACC($C5)_^1_%EQU MASKSB($11)_E**FTN 3.0**_^1*_]_^1Q8DAB NOP 0_,ENTRY POINT_^1_%STQ* QSV4_L**FTN 3.0**_^1_%LDA* Q8DAB_OFTN 3.3_^1_%RTJ PARABS_NFTN 3.3_^1_%STA* DABSPM_NFTN 3.3_^1_%RAO* Q8DAB_(COMPUTE RETURN ADDRESS_^1DFL_"RTJ HDFLOT_NFTN 3.3_^1_%NUM $BD40_(L€NOAD,STORE_DBL_^1_%STQ- QS_'SAVE Q_^1_%LDA* DCOS_PFTN 3.3_^1_%RTJ PARABS_NFTN 3.3_^1_%STA* PARAD_OFTN 3.3_^1_%RAO* DCOS_TDBL_^1_%LDA* DCOS_TDBL_^1_%STA- RETADD_$RETURN ADD._^1COS6_!RTJ* (SIN9+1)_%CALL FLOT_^1_%NUM $BD40_OFTN 3.3_^1PARAD €€ ADC 0_SFTN 3.3_^1_%ADC C_SFTN 3.3_^1_%LDA- C_WDBL_^1_%SAN AD90-*-1_$CHECK FOR 0_?DBL_^1_%STA- D_WDBL_^1_%STA- E_WDBL_^1_%LDA COSIN_SDBL_^1_%STA- C_WDBL_^1_%RTJ* (SIN9+1)_LFTN 3.3_^1_%NUM $B400_OFTN 3.3_^1_%ADC C_SFTN 3.3_^1_%JMP SIN19_SDBL_^1AD90_!RTJ* (SIN9+1)_$CALL DFLOT_@DBL_^1_%NUM $B5E5_OFTN 3.3_^1_%ADC C_SFTN 3.3_^1_%ADC PIOV2-*_MFTN 3.3_^1_%NUM $D400_OFTN 3.3_^1_€€%ADC C_SFTN 3.3_^1_%JMP* SIN1_^1MKFFFF NUM $FFFF_^1_%NUM $FFFE_^1_%NUM $FFFC_^1_%NUM $FFF8_^1_%NUM $FFF0_^1_%NUM $FFE0_^1_%NUM $FFC0_^1MKFF80 NUM $FF80_^1_%NUM $FF00_^1_%NUM $FE00_^1_%NUM $FC00_^1_%NUM $F800_^1_%NUM $F000_^1_%NUM $E000_^1_%NUM $C000_^1_%NUM $8000_^1MK7FFF NUM $7FFF_^1DSIN_!NUM 0_,SIN(U) ENTRY_>DBL_^1_%STQ- QS_'SAVE Q_^1_%LDA* DSIN_PFTN 3.3_^1_%RT€€J PARABS_^1_%STA* PARADD_NFTN 3.3_^1_%RAO* DSIN_TDBL_^1_%LDA* DSIN_TDBL_^1_%STA- RETADD_$RETURN ADD._^1_%RTJ* (SIN9+1)_^1_%NUM $BD40_OFTN 3.3_^1PARADD ADC 0_SFTN 3.3_^1_%ADC C_SFTN 3.3_^1*_"COMMON TO BOTH_^1SIN1_!LDA- C_^1_%ENQ 0_^1_%SAP SIN2-*-1_!ARG IS POS._^1_%RTJ* (SIN9+1)_#COMPLEMENT_^1_%NUM $7D40_OFTN 3.3_^1_%ADC C_SFTN 3.3_^1_%ENQ 1_^1_%LDA- C_^1SIN2_!SAN SIN3-*-1_€€^1_%STA- C_^1_%STA- D_^1_%STA- E_WDBL_^1_%RTJ* (SIN9+1)_^1_%NUM $B400_^1_%ADC C_^1_%JMP SIN19_SDBL_^1SIN3_!STQ-_"FLAG_^1_%SUB TWOPI_SDBL_^1_%SAM SIN4-*-1 LESS_^1_%SAN SIN5-*-1 GREATER_^1_%LDA- D_^1_%SUB TWOPI+1_QDBL_^1_%SAM SIN4-*-1_!LESS_^1_%SAN SIN5-*-1_!GREATER_^1_%LDA- E_WDBL_^1_%SUB TWOPI+2_QDBL_^1_%SAM SIN4-*-1_PDBL_^1_%SAN SIN5-*-1_PDBL_^1_%JMP* SIN2+1_$EQUAL_^€€1MAXVAL NUM $4B40_#2**21_^1SIN4_!JMP* SIN12_^1SIN5_!LDA- C_^1_%SUB* MAXVAL_(MAX. PERMISSIBLE_^1SIN8_!SAM SIN9-*-1_%O.K._^1_%RTJ SFALT_)SET FAULT_=FTN 3.3_^1_%ADC ZERO_PFTN 3.3_^1_%LDA* MK7FFF_^1_%STA- C_^1_%ENA -0_^1_%JMP* SIN2+2_^1SIN9_!RTJ HDFLOT_NFTN 3.3_^1_%NUM $BD5A_SDBL_^1_%ADC C_WDBL_^1_%ADC X_#X=ARG_/STA X_^1_%ADC TWOPI-*_+X/2PI_!FDV 2*PI_^1_%NUM $5D40_OFTN 3.3_^1€€_%ADC C_^1_%LDA- C_^1_%AND* MKFF80_(KEEP EXPONENT_^1_%SUB- MK4000_'REMOVE BASE_?DBL_^1_%ARS 7_*RIGHT JUSTIFIED_^1_%TCA A,Q_^1_%INA 7_^1_%SAP SIN10-*-1_#= OR LESS THAN 7_^1_%INQ 7_^1_%LDA- D_^1_%AND* MK7FFF,Q_%GET MASK ACCORDING TO EXP._^1_%JMP* SIN11_^1SIN10 LDA- C_-LESS OR =_^1_%AND* MKFF80,Q_^1_%STA- C_^1_%ENA 0_^1SIN11 STA- D_-C,D INTEGRAL PART OF DIVISION_^1_%ENA 0_W€€DBL_^1_%STA- E_WDBL_^1_%RTJ* (SIN9+1)_'CALL FLOT_^1_%NUM_#$B759_^1_%ADC_#C_*LDA C_^1_%ADC TWOPI-*_3FMU 2*PI_^1*_"7 = COMPLEMENT PSEUDO ACCUMULATOR_^1_%NUM $5ED4_OFTN 3.3_^1_%ADC X_SFTN 3.3_^1_%ADC C_SFTN 3.3_^1SIN12 LDA- C_)(C,D) LESS OR = 2*PI_^1_%SUB* PI_^1_%SAM J14-*-1_%LESS THAN PI_>DBL_^1_%SAN SIN13-*-1 GREATER_^1_%LDA- D_^1_%SUB* PI+1_^1_%SAM SIN14-*-1 LESS_^1_%SAN €€SIN13-*-1_#GREATER_CDBL_^1_%LDA- E_WDBL_^1_%SUB* PI+2_TDBL_^1J14_"SAM SIN14-*-1_#LESS_FDBL_^1_%SAN SIN13-*-1_#GREATER_CDBL_^1_%JMP* SIN2+1_!EQUAL_^1SIN13 RTJ* (SIN9+1)_%CALL FLOT_^1_%NUM $B585_OFTN 3.3_^1_%ADC C_SFTN 3.3_^1_%ADC PI-*_)X-PI FSB PI_9FTN 3.3_^1_%NUM $D400_OFTN 3.3_^1_%ADC C_SFTN 3.3_^1_%ENA 1_^1_%EOR- FLAG_*CHANGE TO_^1_%STA- FLAG_,OPPOSITE VALUE_^1SIN14 L€€DA- C_^1_%SUB* PIOV2_^1_%SAM SIN145-*-1_!LESS_^1_%SAZ SIN14A_^1_%JMP* SIN15_(GREATER_^1SIN14A LDA- D_^1_%SUB* PIOV2+1_^1SIN145 SAM J16-*-1_^1_%SAN SIN15-*-1_#GREATER_^1_%LDA- E_^1_%AND- $13_*($FFFE)_CDBL_^1_%SUB* PIOV2+2_QDBL_^1J16_"SAP 1_^1_%JMP* SIN16_^1_%SAN SIN15-*-1_#GREATER_CDBL_^1_%LDA* COSIN_(EQUAL_^1_%STA- C_^1_%ENA 0_^1_%STA- D_^1_%STA- E_WDBL_^1_%RTJ* (SIN9+1)_LFT€€N 3.3_^1_%NUM $B400_OFTN 3.3_^1_%ADC C_SFTN 3.3_^1_%JMP* SIN17_#GO TEST FLAG_^1SIN15 RTJ* (SIN9+1)_%CALL FLOT_^1_%NUM $B57E_SDBL_^1_%ADC C_WDBL_^1*_)COMPLEMENT PSEUDO ACCUMULATOR_^1_%ADC PI-*_)PI-(C,D)_#FAD PI_^1_%NUM $5D40_^1_%ADC C_^1SIN16 RTJ* (SIN9+1)_(CALL FLOT_^1_%NUM $B666_SDBL_^1_%ADC C_WDBL_^1_%NUM_#$D9D5_^1_%ADC X_9STA X_^1_%ADC X_9FMU X_^1_%ADC X2_*X2=X*X_€€'STA X2_^1_%NUM_#$9E59_^1_%ADC C8SIN-*_%C8*X2_EDBL_^1_%ADC C7SIN-*_%+C7_GDBL_^1_%ADC X2_+*X2_GDBL_^1_%NUM $5E59_SDBL_^1_%ADC C6SIN-*_%+C6_GDBL_^1_%ADC X2_+*X2_GDBL_^1_%NUM $5E59_SDBL_^1_%ADC C5SIN-*_%+C5_GDBL_^1_%ADC X2_+*X2_GDBL_^1_%NUM $5E59_SDBL_^1_%ADC C4SIN-*_%+C4_GDBL_^1_%ADC X2_+*X2_GDBL_^1_%NUM $5E59_SDBL_^1_%ADC C3SIN-*_%+C3_GDBL_^1_%ADC X2_+*X2_GDBL_^1_%NUM€€ $5E59_SDBL_^1_%ADC C2SIN-*_%+C2_GDBL_^1_%ADC X2_+*X2_GDBL_^1_%NUM $5E59_SDBL_^1_%ADC C1SIN-*_%+C1_GDBL_^1_%ADC X2_+*X2_GDBL_^1_%NUM $5E59_SDBL_^1_%ADC COSIN-*_%+C0_GDBL_^1_%ADC X_,*X_HDBL_^1_%NUM $4000_SDBL_^1SIN17 LDA-_"FLAG_^1_%SAZ SIN19-*-1_^1_%RTJ* (SIN9+1)_"COMPLEMENT_^1_%NUM $7400_OFTN 3.3_^1SIN19 LDQ- QS_VDBL_^1_%JMP-_"(RETADD)_(RETURN TO CALLER_^1PIOV2 NUM €€$40E4,$87ED,$5112_GDBL_^1PI_#NUM $4164,$87ED,$5112_GDBL_^1TWOPI NUM $41E4,$87ED,$5111_GDBL_^1COSIN NUM $40C0,0,0_ODBL_^1C1SIN NUM $C12A,$AAAA,$AAAB_GDBL_^1C2SIN NUM $3CC4,$4444,$4444_GDBL_^1C3SIN NUM $C617,$F97F,$97F8_GDBL_^1C4SIN NUM $36DC,$778E,$955B_GDBL_^1C5SIN NUM $CC94,$66EA,$602A_GDBL_^1C6SIN NUM $2FD8,$4918,$4EA2_GDBL_^1C7SIN NUM $D414,$6030,$6330_GDBL_^1€0C8SIN NUM $27E5,$4B1D,$C0C3_GDBL_^1_%END_]_^__0PDATAN CSY/ K11 P€1_%NAM DATAN_(DECK-ID K11 FTN 3.3 RUNTIME_%SUMMARY-102_^1*_$1700 FORTRAN RUNTIME VERSION 3.3_^1*_$SMALL COMPUTER SYSTEMS DIVISION, LA JOLLA, CALIFORNIA_^1*_$COPYRIGHT CONTROL DATA CORPORATION 1975_^1_%SPC 5_^1_%ENT DATAN_RDBL_^1_%EXT* PARABS_NFTN 3.3_^1_%EXT HDFLOT_NFTN 3.3_^1_%EQU C($C5),D($C6),E($C7)_"PSEUDO ACCUMULATOR_-DBL_^1_%EQU_#ARCFLG($D8),ARCRET($D9),X($DA)_^1_%EQU €€X2($D5),AF($DD),BF($E0)_ADBL_^1_%EQU QS($E3)_QDBL_^1DATAN NUM 0_^1_%STQ- QS_VDBL_^1_%LDA* DATAN_OFTN 3.3_^1_%RTJ PARABS_NFTN 3.3_^1_%STA* PARAD_OFTN 3.3_^1_%RAO* DATAN_SDBL_^1_%LDA* DATAN_SDBL_^1_%STA-_"ARCRET_'****_^1_%RTJ* (ARCT6+1)_^1_%NUM $BD40_OFTN 3.3_^1PARAD ADC 0_SFTN 3.3_^1_%ADC C_SFTN 3.3_^1_%LDA- C_^1_%SAP ARCT1-*-1_^1_%RTJ* (ARCT6+1) CALL FLOT_^1_%NUM $7D40_OF€€TN 3.3_^1_%ADC C_^1_%ENQ 1_^1_%JMP* ARCT2_^1MK007F NUM $007F_^1MK7FFF NUM $7FFF_^1ARCT1 ENQ 0_^1_%SAN ARCT2-*-1_^1_%STQ- C_-ARG. = 0_^1_%STQ- D_)ANSWER =0_^1_%STQ- E_WDBL_^1_%RTJ* (ARCT6+1)_KFTN 3.3_^1_%NUM $B400_OFTN 3.3_^1_%ADC C_SFTN 3.3_^1_%JMP ARCEND_RDBL_^1PIOV2 NUM 0,0,0_SDBL_^1_%NUM $40E4,$87ED,$5111_GDBL_^1ARCT2 STQ-_"ARCFLG_^1_(LDA- C_^1_%SUB =N$39E8_%DECIM€€AL .0002_=DBL_^1_%SAP 1_^1_%JMP* ARCK_TDBL_^1_%ENQ 0_'TO SELECT 1.0 AND 0_^1_%LDA- C_^1_%SUB* ONE_#40C0_^1_%SAP ARCT2A_^1_%JMP* ARCT4_(LESS THAN ONE_^1ARCT2A SAN ARCT3_^1_%SAN ARCT3-*-1_^1_%LDA- D_^1_%SAN ARCT3-*-1_ODBL_^1_%LDA- E_WDBL_^1_%SAZ ARCT4-*-1_"= TO ONE_^1ARCT3 RTJ* (ARCT6+1)_^1_%NUM $BD5B_^1_%ADC C_^1_%ADC X_%STORE PSEUDO ACCUMULATOR_^1_%ADC ONE-*_5LDA 1.0_^1€€_%NUM $5AD4_OFTN 3.3_^1_%ADC X_SFTN 3.3_^1_%ADC C_SFTN 3.3_^1_%ADC X_(1/X_-FDV X_^1_%ENQ 3_WDBL_^1ARCT4 LDA* ONE,Q_^1_%STA-_"BF_^1_%LDA* ONE+1,Q_^1_%STA-_"BF+1_$SET 1 OR -1_^1_%LDA* ONE+2,Q_QDBL_^1_%STA- BF+2_TDBL_^1_%LDA-_"ARCFLG_^1_%AAQ A_^1_%STA-_"ARCFLG_^1_%LDA* PIOV2,Q_^1_%STA-_"AF_^1_%LDA* PIOV2+1,Q_^1_%STA-_"AF+1_'0 OR PI/2_^1_%LDA* PIOV2+2,Q_ODBL_^1_%STA- AF+2_TDBL_^€€1ARCT5 RTJ* (ARCT6+1)_#FLOT ROUTINE_^1_%NUM $BD58_^1_%ADC C_^1_%ADC X_9STA X_^1_%ADC TANPI8-*_2FSB_^1_%NUM $5D40_OFTN 3.3_^1_%ADC C_SFTN 3.3_^1_%ENQ 1_,GT.TAN(PI/8)_^1_%LDA- C_^1_%SAZ ARC55_SDBL_^1_%SAP ARC56_(GREATER THAN TAN(PI/8)_4DBL_^1ARC55 ENQ 0_,LESS OR = TO TAN(PI/8)_4DBL_^1ARC56 STQ- X2_VDBL_^1ARCT6 RTJ HDFLOT_NFTN 3.3_^1_%NUM $F5B6_^1_%ADC X2_*INDEX_^1_%A€€DC PI16-*_"LDA PI16,IND_^1_%NUM $59ED_^1_%ADC BF_8FMU_^1_%ADC AF_8FAD_^1_%ADC AF_8STA_^1_%NUM $F5B6_^1_%ADC X2_*INDEX_^1_%ADC TAN16-*_!LDA TAN16,IND_^1_%NUM $5D95_^1_%ADC BF_8LDA_^1_%ADC X_9FMU_^1_%NUM $E5DB_^1_%ADC ONE-*_5FAD 1.0_^1_%ADC X2_8STA_^1_%ADC X_9LDA_^1_%NUM $8AD9_^1_%ADC BF_8FAD_^1_%ADC X2_8FDV X2_^1_%ADC X_9STA X_^1_%ADC X_9FMU X_^1_%NUM $D59E_^1_%€€ADC X2_8STA X2_^1_%ADC C8-*_)X2*C8_EDBL_^1_%ADC C7-*_)+C7_GDBL_^1_%NUM $595E_SDBL_^1_%ADC X2_+*X2_GDBL_^1_%ADC C6-*_)+C6_GDBL_^1_%NUM $595E_SDBL_^1_%ADC X2_+*X2_GDBL_^1_%ADC C5-*_)+C5_GDBL_^1_%NUM $595E_SDBL_^1_%ADC X2_+*X2_GDBL_^1_%ADC C4-*_)+C4_GDBL_^1_%NUM $595E_SDBL_^1_%ADC X2_+*X2_GDBL_^1_%ADC C3-*_)+C3_GDBL_^1_%NUM $595E_SDBL_^1_%ADC X2_+*X2_GDBL_^1_%ADC C2-€€*_)+C2_GDBL_^1_%NUM $595E_SDBL_^1_%ADC X2_+*X2_GDBL_^1_%ADC C1-*_)+C1_GDBL_^1_%NUM $595E_SDBL_^1_%ADC X2_+*X2_GDBL_^1_%ADC C0-*_)+C0_GDBL_^1_%NUM $5940_SDBL_^1_%ADC X_,*X_HDBL_^1_%LDA-_"ARCFLG_^1_%INA -3_^1_%SAM ART7-*-1_^1_%STA-_"ARCFLG_^1_%RTJ* (ARCT6+1) CALL FLOT_^1_%NUM $7400_OFTN 3.3_^1ART7_!RTJ* (ARCT6+1) CALL FLOT_^1_%NUM $ED40_OFTN 3.3_^1_%ADC AF_RFTN 3.3_^1_%€€ADC C_SFTN 3.3_^1ARCK_!LDA- ARCFLG_RDBL_^1_%SAZ ARCEND-*-1_^1_%RTJ* (ARCT6+1) CALL FLOT_^1_%NUM $B740_^1_%ADC C_^1ARCEND LDQ- QS_VDBL_^1_%JMP- (ARCRET)_^1ONE_"NUM $40C0,0,0_*+1.0_@DBL_^1_%NUM $BF3F,$FFFF,$FFFF_!-1.0_@DBL_^1PI16_!NUM $3EE4,$87ED,$5111_"PI/16=S_