C ******************************************************* C * * C * THIS SOFTWARE WAS DEVELOPED WITH SUPPORT * C * FROM THE NATIONAL INSTITUTES OF HEALTH: * C * NIH CA06927 * C * NIH CA22780 * C * * C * DIRECT INQUIRIES TO: * C * COMPUTER CENTER * C * THE INSTITUTE FOR CANCER RESEARCH * C * 7701 BURHOLME AVENUE * C * PHILADELPHIA, PENNSYLVANIA 19111 * C * * C * NO WARRANTY OR REPRESENTATION, EXPRESS OR * C * IMPLIED, IS MADE WITH RESPECT TO THE * C * CORRECTNESS, COMPLETENESS, OR USEFULNESS * C * OF THIS SOFTWARE, NOR THAT USE OF THIS * C * SOFTWARE MIGHT NOT INFRINGE PRIVATELY * C * OWNED RIGHTS. * C * * C * NO LIABILITY IS ASSUMED WITH RESPECT TO * C * THE USE OF, OR FOR DAMAGES RESULTING FROM * C * THE USE OF THIS SOFTWARE * C * * C ******************************************************* C * * C * THIS SOFTWARE WAS DESIGNED FOR USE ON A * C * PDP-11/70 OPERATING UNDER IAS V3.0 USING * C * THE FORTRAN-IV PLUS COMPILER. * C * * C ******************************************************* C C TRACE -- MAKE STRUCTURED SYMBOL FILE FOR FDT. C C THIS PROGRAM READS THE COMPLETE FORTRAN IV PLUS LISTINGS AND THE C ASSOCIATED MAP FILE AND PRODUCES AN FDT SYMBOL FILE. THE COMMAND C LINE SUPPLIED IS: C FDT [,]=/ C C .FDT = TREE STRUCTURED RANDOM ACCESS SYMBOL FILE C .STL=LIST OF ALL ADDRESSABLE SYMBOLS C .LST= FORTRAN IV PLUS LISTINGS (WITH /LI:3 SWITCH) C .MAP = TASK BUILDER MAP FILE C C EXAMPLE: C FDT TEST,TEST=TEST,SUBS1,SUBS2/TEST C READS TEST.LST, SUBS1.LST, SUBS2.LST AND TEST.MAP AND PRODUCES C TEST.FDT AND TEST.STL. C C EDIT HISTORY: C ICR001 04-JUL-79 ROBERT K. STODOLA ORIGINAL VERSION C ICR002 28-NOV-79 " " " ADD OVERLAY SUPPORT C ICR003 12-NOV-80 " " " ADD SUPPORT FOR IAS C V3.1 CONTINUE/DEBUG. C ICR004 14-NOV-80 " " " ADD SUPPORT FOR C VIRTUAL ARRAYS. C ICR005 19-JAN-82 WILLIAM F. CAEL ADD RSX SY DEFAULT. C IMPLICIT INTEGER*2 (A - Z) PARAMETER LINK=16 PARAMETER DIREP=4,DIRVAR=5,DIRARY=6,DIRLAB=7,DIRROT=6,DIROBN=8 PARAMETER FARG = 1, FREG = 2, FVIRT = 4 INTEGER INITAB(16),TABL(16),NAME(3),PNAME(5),PSECT(3),DIMS(3) INTEGER ROTTAB(16),RNAME(3),DIMZ(3) BYTE FILENM(40),BUF(80),TERM,BTABL(32),TYPE,FLAG EQUIVALENCE (PNAME,INITAB),(ROTDIR,INITAB(DIRROT)) EQUIVALENCE (EPDIR,ROTTAB(DIREP)),(VARDIR,ROTTAB(DIRVAR)) EQUIVALENCE (ARYDIR,ROTTAB(DIRARY)),(OVBN,ROTTAB(DIROBN)) EQUIVALENCE (LABDIR,ROTTAB(DIRLAB)),(RNAME,ROTTAB) EQUIVALENCE (NAME,BTABL,TABL),(ADDR,TABL(4)),(TYPE,BTABL(9)) EQUIVALENCE (FLAG,BTABL(10)),(LENGTH,TABL(6)),(DIM1,DIMS,TABL(7)) EQUIVALENCE (DIM2,DIMS(2)),(DIM3,DIMS(3)) EQUIVALENCE (DIMZ1,DIMZ,TABL(10)),(DIMZ2,DIMZ(2)) EQUIVALENCE (DIMZ3,DIMZ(3)),(PSECT,TABL(13)) BYTE LIN COMMON /LINE/NLIN,LIN(132) COMMON /FLTYPE/FLTYPE DOUBLE PRECISION RTIT INTEGER*4 RLIN,ASTYPE,DLIN(2) INTEGER NAMTIT(3) EQUIVALENCE (RLIN,DLIN,LIN),(RTIT,LIN(17)),(NAMTIT,LIN(25)) C INTEGER PSB(3),ROUT(3) INTEGER PSS(3,50),PSNUM(50),PSADR(50) C C INITIALIZE C FLTYPE=0 NXBL=2 IIP=1 INP=0 CALL GFILE(BUF,IIP,INP,FILENM,'.FDT',TERM) OPEN (UNIT=1,NAME=FILENM,TYPE='NEW',ACCESS='DIRECT', 1 RECORDSIZE=LINK/2) LIST=0 IF(TERM.EQ.1H=)GO TO 100 CALL GFILE(BUF,IIP,INP,FILENM,'.STL',TERM) LIST=1 OPEN (UNIT=4,NAME=FILENM) IF(TERM.NE.1H=)STOP 'INVALID COMMAND LINE' 100 CONTINUE LSROT=1 LSROTW=DIRROT WRITE(1'1)INITAB C C GET NEXT LIST FILE C 110 CONTINUE IF(TERM.EQ.1H/)GO TO 650 CALL GFILE(BUF,IIP,INP,FILENM,'.LST',TERM) IER=0 OPEN (UNIT=2,NAME=FILENM,TYPE='OLD',READONLY,SHARED,ERR=120, 1 RECORDSIZE = 64) GO TO 140 120 CONTINUE TYPE 130 130 FORMAT('0FILE DOES NOT EXIST -- REENTER LIST FILE NAME.') CALL FLUSHC IIP=1 INP=0 GO TO 110 C C SET UP FOR NEXT ROUTINE C 140 CONTINUE ICTYPE=0 C C INITIALIZE THE ROUTINE TABLE C DO 150 I=1,LINK ROTTAB(I)=0 150 CONTINUE RNAME(1)=2H.M RNAME(2)=2HAI RNAME(3)=2HN. C C INITIALIZE LINKS TO OTHER TABLES C LSEP=NXBL LSEPW=DIREP LSVAR=NXBL LSVARW=DIRVAR LSARY=NXBL LSARYW=DIRARY LSLAB=NXBL LSLABW=DIRLAB C C GET NEXT .TITLE OR PROGRAM PAGE C 160 CONTINUE CALL GETLIN(IER) IF(IER.LT.0)GO TO 620 IF(RLIN.EQ.4HPROG)GO TO 260 IF(RTIT.NE.8H.TITLE )GO TO 160 ICTYPE=1 DO 170 I=1,3 RNAME(I)=NAMTIT(I) 170 CONTINUE CALL LINKBL(NXBL,LSROT,LSROTW) WRITE(1'LSROT)ROTTAB 180 CONTINUE CALL GETLIN(IER) IF(IER.LT.0)GO TO 620 IF(RTIT.EQ.8H.END )GO TO 250 IF(LIN(49).NE.1H;)GO TO 180 190 CONTINUE DO 200 I=1,16 TABL(I)=0 200 CONTINUE LIN(50)=1H@ DO 210 I=51,53 IF(LIN(I).NE.1H0)GO TO 220 LIN(I)=1H@ 210 CONTINUE I=54 220 CONTINUE DECODE(NLIN,230,LIN)NAME 230 FORMAT(X,3A2) PSECT(1)=2H$C PSECT(2)=2HOD PSECT(3)=2HE1 CALL GETLIN(IER) IF(IER.LT.0)GO TO 620 IF(RTIT.EQ.8H.END )GO TO 250 IF(LIN(49).EQ.1H;)GO TO 190 IF(LIN(1).EQ.1H )GO TO 180 DECODE(NLIN,240,LIN,ERR=180)ADDR 240 FORMAT(O6) CALL LINKBL(NXBL,LSLAB,LSLABW) WRITE(1'LSLAB)TABL GO TO 180 C C GET NEXT PROGRAM PAGE C 250 CONTINUE CALL GETLIN(IER) IF(IER.LT.0)GO TO 620 IF(RLIN.NE.4HPROG)GO TO 250 260 CONTINUE CALL SKIP(1) C C LINK IT INTO THE LIST C IF(ICTYPE.NE.0)GO TO 270 CALL LINKBL(NXBL,LSROT,LSROTW) WRITE(1'LSROT)ROTTAB C C READ IN PSECT DATA C 270 CONTINUE NPSECS=0 280 CONTINUE CALL GETLIN(IER) IF(IER.LT.0)GO TO 620 IF(LIN(1).NE.1H )GO TO 300 NPSECS=NPSECS+1 DECODE(NLIN,290,LIN,ERR=630)PSNUM(NPSECS),(PSS(J,NPSECS),J=1,3) 290 FORMAT(I3,5X,3A2,2X,O6) GO TO 280 300 CONTINUE IF(NPSECS.LE.0)GO TO 630 C C GET ENTRY POINTS, VARIABLES, AND ARRAYS (IF ANY) C LCODE=0 LNUM=5 IF (RLIN.NE.4HSTAT) GO TO 320 C SKIP STATEMENT FUNCTION DEFINITION 310 CONTINUE CALL GETLIN(IER) IF (IER.LT.0) GO TO 620 IF (LIN(1).EQ.1H ) GO TO 310 320 CONTINUE IF(RLIN.NE.4HENTR)GO TO 480 330 CONTINUE CALL SKIP(1) 340 CONTINUE CALL GETLIN(IER) IF(IER.LT.0)GO TO 620 IF(LIN(1).NE.1H )GO TO 480 LP=1 DO 470 I=1,LNUM C *** IMPOSSIBLE TO DEAL WITH VIRTUAL ARGUMENTS UNTIL THEY FIX LIST FORMAT IF (LIN(LP+17).EQ.1H*) GO TO 340 C *** IF(LP.GT.NLIN.OR.LIN(LP+1).EQ.1H )GO TO 340 CALL INITTB(TABL,LIN(LP+1),LIN(LP+8)) C *** VIRTUAL ARRAY OFFSETS ARE NOT IN SAME PLACE KOFF = LP+15 IF (LCODE.EQ.3) KOFF = KOFF-1 C *** DECODE(NLIN,350,LIN,ERR=630)ADDR 350 FORMAT(X,O6) IF(LCODE.NE.0.OR.ADDR.NE.0.OR.ICTYPE.NE.0)GO TO 370 READ(1'LSROT)ROTTAB DO 360 J=1,3 RNAME(J)=TABL(J) 360 CONTINUE WRITE(1'LSROT)ROTTAB 370 CONTINUE C *** THIS SECTION WILL REQUIRE CHANGES IF THEY FIX VIRTUAL ARGUMENT LISTING IF (LCODE.NE.3) GO TO 375 FLAG = FLAG.OR.FVIRT PSECT(1) = '$V' PSECT(2) = 'IR' PSECT(3) = 'T ' GO TO 420 375 CONTINUE IF(LIN(LP+22).EQ.1H*)FLAG=FLAG.OR.FARG.OR.FREG IF(LIN(LP+14).LT.1H0.OR.LIN(LP+14).GT.1H9)GO TO 420 DECODE(NLIN,380,LIN,ERR=630)PS 380 FORMAT(X,I2) DO 390 PSN=1,NPSECS IF(PSNUM(PSN).EQ.PS)GO TO 400 390 CONTINUE GO TO 630 400 CONTINUE DO 410 J=1,3 PSECT(J)=PSS(J,PSN) 410 CONTINUE FLAG=FLAG.AND..NOT.FREG 420 CONTINUE GO TO (430,440,450,450),LCODE+1 430 CONTINUE CALL LINKBL(NXBL,LSEP,LSEPW) GO TO 460 440 CONTINUE CALL LINKBL(NXBL,LSVAR,LSVARW) GO TO 460 450 CONTINUE CALL LINKBL(NXBL,LSARY,LSARYW) CALL GETDIM(LIN(32),DIMS,DIMZ,tabl) 460 CONTINUE WRITE(1'NXBL-1)TABL LP=LP+24 470 CONTINUE GO TO 340 480 CONTINUE LCODE=LCODE+1 GO TO (490,500,510,520),LCODE 490 CONTINUE IF(RLIN.EQ.4HVARI)GO TO 330 GO TO 480 500 CONTINUE LNUM=1 IF(RLIN.EQ.4HARRA)GO TO 330 GO TO 480 510 CONTINUE LNUM=1 IF (RLIN.EQ.4HVIRT) GO TO 330 GO TO 480 520 CONTINUE C C GET LABEL DATA C IF(RLIN.NE.4HLABE)GO TO 140 CALL SKIP(1) 530 CONTINUE CALL GETLIN(IER) IF(IER.LT.0)GO TO 620 IF(LIN(1).NE.1H )GO TO 620 LP=1 DO 610 I=1,5 IF(LP.GT.NLIN.OR.LIN(LP+1).EQ.1H )GO TO 600 DO 540 J=LP+1,LP+6 IF(LIN(J).EQ.1H')GO TO 600 540 CONTINUE IF(LIN(LP+9).EQ.1H )GO TO 600 DO 550 J=1,16 TABL(J)=0 550 CONTINUE DECODE(NLIN,560,LIN,ERR=630)NAME,PS,ADDR 560 FORMAT(X,3A2,1X,I2,1X,O6) DO 570 PSN=1,NPSECS IF(PSNUM(PSN).EQ.PS)GO TO 580 570 CONTINUE GO TO 630 580 CONTINUE DO 590 J=1,3 PSECT(J)=PSS(J,PSN) 590 CONTINUE CALL LINKBL(NXBL,LSLAB,LSLABW) WRITE(1'LSLAB)TABL 600 CONTINUE LP=LP+24 610 CONTINUE GO TO 530 C C FINISH ROUTINE BLOCK AND GO BACK FOR NEW ROUTINE IF NO EOF C 620 CONTINUE IF(IER)110,140,140 C C ERROR IN LIST FILE C 630 CONTINUE TYPE 640 640 FORMAT(/' CORRUPT LIST FORMAT') STOP C C GET MAP FILE NAME C 650 CONTINUE FOVBN=0 READ(1'1)INITAB CALL GFILE(BUF,IIP,INP,FILENM,'.MAP',TERM) FLTYPE=1 OPEN (UNIT=2,NAME=FILENM,TYPE='OLD',READONLY,SHARED, 1 RECORDSIZE = 256) C C SEARCH FOR ---- C 660 CONTINUE CALL GETLIN(IER) IF(IER.LT.0)GO TO 800 IF(RLIN.EQ.4H----)GO TO 680 IF(DLIN(1).NE.4HDISK.OR.DLIN(2).NE.4H BLK)GO TO 660 DECODE(NLIN,670,LIN)KOVBN 670 FORMAT(17X,O6) IF(FOVBN.EQ.0)FOVBN=KOVBN GO TO 660 C C GET EACH PSECT AND SCAN TABLES TO RELOCATE ADDRESSES C 680 CONTINUE PSB(1)=-1 690 CONTINUE CALL GETLIN(IER) IF(IER.LT.0)GO TO 800 IF(RLIN.EQ.4H*** )GO TO 660 IF(LIN(1).EQ.1H )GO TO 710 IF(LIN(7).NE.1H:)GO TO 690 DECODE(NLIN,700,LIN)PSB 700 FORMAT(3A2) GO TO 690 710 CONTINUE DECODE(NLIN,720,LIN)BADR,ROUT 720 FORMAT(30X,O6,15X,3A2) NEXT=ROTDIR GO TO 740 730 CONTINUE NEXT=ROTTAB(LINK) 740 CONTINUE IF(NEXT.EQ.0)GO TO 690 READ(1'NEXT)ROTTAB DO 750 I=1,3 IF(RNAME(I).NE.ROUT(I))GO TO 730 750 CONTINUE OVBN=KOVBN-FOVBN WRITE(1'NEXT)ROTTAB DO 790 DH=DIREP,DIRLAB LC=ROTTAB(DH) GO TO 770 760 CONTINUE LC=TABL(LINK) 770 CONTINUE IF(LC.EQ.0)GO TO 790 READ(1'LC)TABL IF((FLAG.AND.FREG).NE.0)GO TO 760 DO 780 I=1,3 IF(PSECT(I).NE.PSB(I))GO TO 760 780 CONTINUE ADDR=ADDR+BADR WRITE(1'LC)TABL GO TO 760 790 CONTINUE GO TO 690 C C PRODUCE LIST FOR USER C 800 CONTINUE IF(LIST.EQ.0)GO TO 1020 READ(1'1)INITAB NEXT=ROTDIR GO TO 820 810 CONTINUE NEXT=ROTTAB(LINK) 820 CONTINUE IF(NEXT.EQ.0)GO TO 1020 READ(1'NEXT)ROTTAB WRITE(4,830)RNAME 830 FORMAT('1MODULE NAME: '3A2,/) IF(KOVBN.GT.FOVBN)WRITE(4,840)OVBN 840 FORMAT(' SEGMENT CODE: 'O6,/) DO 1010 DH=DIREP,DIRLAB LC=ROTTAB(DH) IF(LC.EQ.0)GO TO 1010 GO TO (850,870,890,910),DH+1-DIREP 850 CONTINUE WRITE(4,860) 860 FORMAT(/'0ENTRY POINTS:'/' NAME ADDRESS TYPE') GO TO 940 870 CONTINUE WRITE(4,880) 880 FORMAT(/'0VARIABLES:'/' NAME ADDRESS TYPE') GO TO 940 890 CONTINUE WRITE(4,900) 900 FORMAT(/'0ARRAYS:'/' NAME ADDRESS TYPE DIMENSIONS') GO TO 940 910 CONTINUE WRITE(4,920) 920 FORMAT(/'0LABELS:'/' NAME ADDRESS') GO TO 940 930 CONTINUE LC=TABL(LINK) IF(LC.EQ.0)GO TO 1010 940 CONTINUE READ(1'LC)TABL LOTZ=1H VOTZ = 1H IF((FLAG.AND.FARG).NE.0)LOTZ=1H* IF ((FLAG.AND.FVIRT).NE.0) VOTZ = 1HV GO TO (950,950,970,1000),DH+1-DIREP 950 CONTINUE WRITE(4,960)NAME,ADDR,VOTZ,LOTZ,ASTYPE(TYPE,LENGTH) 960 FORMAT(1X,3A2,1X,O6,2A1,1X,A4,2X,3(:,I6':'I6)) GO TO 930 970 CONTINUE DO 980 NDIM=1,2 IF(DIMS(NDIM+1).EQ.0)GO TO 990 980 CONTINUE NDIM=3 990 CONTINUE WRITE(4,960)NAME,ADDR,VOTZ,LOTZ,ASTYPE(TYPE,LENGTH), 1 ((DIMZ(J),DIMS(J)+DIMZ(J)-1),J=1,NDIM) GO TO 930 1000 CONTINUE WRITE(4,960)NAME,ADDR,VOTZ,LOTZ GO TO 930 1010 CONTINUE GO TO 810 1020 CONTINUE CLOSE (UNIT=1) END SUBROUTINE GFILE(BUF,IP,NP,FILE,IEXT,TERM) BYTE BUF(80),FILE(40),IEXT(4),TERM,PRMPT(7) DATA PRMPT/"15,"12,'F','D','T','>',' '/ NEXT=0 LP=1 100 CONTINUE TERM=0 IF(IP.LE.NP)GO TO 120 IF(LP.NE.1)GO TO 130 IP=1 CALL GTLIN(BUF,NP,3,PRMPT,7) IF(NP)110,100,120 110 CONTINUE CLOSE (UNIT=3) GO TO 100 120 CONTINUE TERM=BUF(IP) IP=IP+1 IF(TERM.EQ.1H.)NEXT=1 IF(TERM.EQ.1H )GO TO 100 IF(TERM.EQ.1H=.OR.TERM.EQ.1H/.OR.TERM.EQ.1H,)GO TO 130 FILE(LP)=TERM LP=LP+1 IF(LP.LE.35)GO TO 100 130 CONTINUE IF(NEXT.NE.0)GO TO 150 DO 140 I=1,4 FILE(LP)=IEXT(I) LP=LP+1 140 CONTINUE 150 CONTINUE FILE(LP)=0 C C ADD SY DEFAULT FOR RSX-11M (SUGGESTED BY JERRY B. TAYLOR BOEING COMPANY) IF (LP.GT.37) RETURN DO 160 I = 1,LP IF (FILE(I).EQ.':') RETURN 160 CONTINUE DO 170 I = LP,1,-1 FILE(I+3) = FILE(I) 170 CONTINUE FILE(1) = 'S' FILE(2) = 'Y' FILE(3) = ':' RETURN END SUBROUTINE GETDIM(DMARY,DIMS,DIMZ,tabl) C C GET DIMENSIONS C INTEGER DIMS(3),DIMZ(3),tabl(16) BYTE DMARY(1),TERM,byte1(2) data iclear/'7'O/ IP=1 c type 9000,(dmary(kk),kk=1,5) 9000 format(5a1) c type 1228,(tabl(kk),KK=1,16) 1228 format(' ',16O8) DO 100 I=1,3 DIMS(I)=0 DIMZ(I)=1 100 CONTINUE ippp=ip+10 DO 130 ID=1,3 IDEF=1 110 CONTINUE CALL GDIM(DMARY(ippp),IPPP,IVAL,IDEF,TERM) IF(TERM.NE.1H:)GO TO 120 DIMZ(ID)=IVAL IDEF=IVAL GO TO 110 120 CONTINUE DIMS(ID)=IVAL+1-DIMZ(ID) IF(DIMS(ID).LE.0)DIMS(ID)=1 IF(TERM.EQ.1H))GO TO 1222 130 CONTINUE 1222 byte1(1)=tabl(5).and.iclear 122 if(byte1(1).ne.5) goto 140 c calculate length of character string itmp=1 do 131 i=1,3 if(dims(i).eq.0) goto 132 itmp=itmp*dims(i) 131 continue 132 continue decode(5,133,dmary(1)) iezis 133 format(i5) c type *,iezis iezis=(iezis*2)/itmp tabl(6)=iezis c type *,iezis 140 CONTINUE c type 1228,(tabl(kk),kk=1,16) RETURN END SUBROUTINE GDIM(BUF,IP,IVAL,IDEF,TERM) BYTE BUF(1),TERM IVAL=IDEF LP=1 100 CONTINUE TERM=BUF(LP) LP=LP+1 IF(TERM.NE.1H:.AND.TERM.NE.1H).AND.TERM.NE.1H,)GO TO 100 IP=IP+LP-1 IF(BUF(1).EQ.1H*)GO TO 120 DECODE(LP-2,110,BUF)IVAL 110 FORMAT(I6) 120 CONTINUE RETURN END SUBROUTINE SKIP(N) DO 100 I=1,N CALL GETLIN(IER) IF(IER.LT.0)GO TO 110 100 CONTINUE 110 CONTINUE RETURN END SUBROUTINE LINKBL(NXBL,LS,LSW) IMPLICIT INTEGER*2 (A - Z) PARAMETER LINK=16 INTEGER TABL(16) READ(1'LS)TABL TABL(LSW)=NXBL WRITE(1'LS)TABL LS=NXBL LSW=LINK NXBL=NXBL+1 RETURN END INTEGER*4 FUNCTION ASTYPE(TYP,LEN) IMPLICIT INTEGER*2 (A - Z) INTEGER*4 OBUF BYTE T,BUF(4),LENS(9),TYP EQUIVALENCE (BUF,OBUF) COMMON /TYPES/T(5) DATA T/1H?,1HL,1HI,1HR,1HC/ DATA LENS/1H0,1H1,1H2,1H3,1H4,1H5,1H6,1H7,1H8/ DATA OBUF/' * '/ BUF(1)=T(TYP+1) BUF(3)=LENS(LEN+1) ASTYPE=OBUF IF(OBUF.EQ.4H?*0 )ASTYPE=4H RETURN END SUBROUTINE INITTB(TABL,NMB,TYB) IMPLICIT INTEGER*2 (A - Z) BYTE NMB(6),TYB(3) INTEGER TABL(16) BYTE T COMMON /TYPES/T(5) DO 100 I=1,16 TABL(I)=0 100 CONTINUE DECODE(6,110,NMB)TABL(1),TABL(2),TABL(3) if(tyb(2).ne.'H')goto 111 tabl(5)=5 tabl(6)=1 goto 131 111 continue 110 FORMAT(3A2) DO 120 I=0,4 IF(TYB(1).EQ.T(I+1))TABL(5)=I 120 CONTINUE DECODE(3,130,TYB)TABL(6) 130 FORMAT(2X,I1) 131 continue RETURN END SUBROUTINE GETLIN(IER) BYTE LIN,IC COMMON /LINE/NLIN,LIN(132) NSKIP=1 100 CONTINUE NLIN=0 NCHR=0 DO 110 I=1,132 LIN(I)=1H 110 CONTINUE 120 CONTINUE CALL GETCH(IC,IER) IF(IER.LT.0)RETURN IF(IC.EQ."14)NSKIP=3 IF(IC.EQ."11)GO TO 130 IF(IC.EQ."15)GO TO 140 IF(IC.LT."40.OR.IC.GE."177)GO TO 120 IF(IC.NE.1H )NCHR=NCHR+1 NLIN=NLIN+1 IF(NLIN.GT.132)STOP 'LINE TOO LONG' LIN(NLIN)=IC GO TO 120 130 CONTINUE NLIN=(NLIN/8+1)*8 GO TO 120 140 CONTINUE IF(NCHR.EQ.0)GO TO 100 NSKIP=NSKIP-1 IF(NSKIP.GT.0)GO TO 100 D TYPE 150,(LIN(J),J=1,NLIN) D150 FORMAT(1X,132A1) RETURN END SUBROUTINE GETCH(IC,IER) IMPLICIT INTEGER*2 (A-Z) BYTE IC COMMON/FLTYPE/FLTYPE BYTE INPT(256) DATA NINPT/0/, IPNT/0/ 100 CONTINUE IPNT=IPNT+1 IF(IPNT.LE.NINPT)GO TO 110 IPNT=0 C*FOR* READ(2,10,END=100)NINPT,INPT C*FOR* 10 FORMAT(Q,128A1,128A1) C**ICR** CALL GET(2,INPT,256,NINPT) IF (NINPT.LT.0) GO TO 120 C**ICR** IF(FLTYPE.NE.0)GO TO 100 NINPT=NINPT+1 INPT(NINPT)="15 GO TO 100 110 CONTINUE IC=INPT(IPNT) IER=0 GO TO 130 120 CONTINUE NINPT=0 CLOSE(UNIT=2) IER=-1 130 CONTINUE RETURN END