C PROGRAM TO READ AN ASCII MAGTAPE FROM THE EXPERT 2000 CAD SYSTEM. C FILED--30-NOV-84, G. BEVER. C C COMPILE AS FOLLOWS: C C .FORTRA CADRED C C LINK AS FOLLOWS: C C .LINK CADRED C INTEGER*2 ICLID(5),IPRMID(4),IPRMNM(15),IDATE(4),IENG(4), C MINDEC,MAXDEC,IREFP(4),IREFCT,IORDER INTEGER*2 ISPEC(39),JSWI(4,1),IBUF(256),LU(2) BYTE JBUF(512),KBUF(512) REAL*4 RMINEU,RMAXEU REAL*4 EXT(2) EQUIVALENCE (IBUF(1),JBUF(1)) DATA EXT/6RLSTLST,6RLSTDAT/ DATA JSWI/'M',3*0/ DATA LU/2HLP,2H: / C C CALL COMMAND STRING INTERPRETER TO GET DEVICE NAMES. C *CALFIL.LST=MT: C WHERE 'CALFIL.LST' SPECIFIES OUTPUT LIST FILE. C 'MT:' SPECIFIES MAG TAPE TO READ. (MS: FOR 1600 BPI). C C GET INPUT AND OUTPUT FILE NAMES FOR 1ST TIME (LOADS INPUT HANDLER TOO). 5 IF(ICSI(ISPEC,EXT,,JSWI,1).NE.0) GO TO 5 C SET SYSTEM TO IGNORE FORTRAN RUN TIME ERROR # 5. CALL SETERR(5,255) C FETCH INPUT DEVICE HANDLER INTO MEMORY. IF(IFETCH(ISPEC(16)).NE.0) STOP 'BAD IN FETCH' C GET CHANNEL NUMBER. ICHAN=IGETC() IF(ICHAN.LT.0) STOP 'NO CHANNEL' C PERFORM LOOKUP OF FILE. I=LOOKUP(ICHAN,ISPEC(16)) IF(I.LT.0) GO TO 50 GO TO 13 C C GET INPUT AND OUTPUT FILE NAMES. 12 IF(ICSI(ISPEC,EXT,,JSWI,1).NE.0) GO TO 12 C ASSIGN DISC FILE FOR LIST OUTPUT. 13 IFRST=0 ! SET FLAG THAT THIS IS 1ST TIME. CALL IASIGN(2,ISPEC(1),ISPEC(2),ISPEC(5),8) C 'REWIND' FILE. 11 IBLK=0 C L=1 C CLEAR INPUT BUFFER. 20 DO 25 I=1,256 25 IBUF(I)=0 C READ TAPE RECORD I=IREADW(256,IBUF,IBLK,ICHAN) IBLK=IBLK+1 C EOF CHECK IF(I.EQ.-1) GO TO 9998 IF(I.LT.-1) STOP 'ERROR ON READ' C XFER DATA CHARACTER BY CHARACTER TO 'KBUF', AND WRITE KBUF TO LU 2 AFTER C EACH CHARACTER (EOL INDICATOR) IS ENCOUNTERED. C DO 30 I=1,512 C IF(JBUF(I).EQ."15) GO TO 33 KBUF(L)=JBUF(I) GO TO 30 C C ELIMINATE TRAILING BLANKS. 33 LAST=L-1 IF(L.EQ.1) GO TO 34 DO 27 M=1,LAST IF(KBUF(LAST+1-M).NE.' ') GO TO 28 L=L-1 27 CONTINUE C 28 IF(IFRST.EQ.0) GO TO 32 ! IF VERY 1ST TIME, GO TO 32. WRITE(2,101)(KBUF(M),M=1,L-1) 101 FORMAT(' ',134A1) GO TO 29 32 WRITE(2,105)(KBUF(M),M=1,L-1) ! SUPRESS LEADING LINEFEED. 105 FORMAT('+',134A1) GO TO 29 34 WRITE(2,101) ! OUTPUT BLANK LINE. 29 IFRST=1 ! NO LONGER VERY 1ST TIME THRU. L=0 DO 31 M=1,512 ! INIT KBUF TO SPACES. 31 KBUF(M)=' ' C 30 L=L+1 C GO TO 20 C************ 50 WRITE(7,100)I,J 100 FORMAT(1X,2I7) STOP 'BAD LOOKUP' 9998 TYPE 103 103 FORMAT(' NEXT FILE (Y/N->1/0):') ACCEPT 104,N 104 FORMAT(I5) CALL CLOSE(2) IF(N.EQ.1) GO TO 12 STOP 'XFER OK' END