C PROGRAM TO WRITE AN ASCII MAG TAPE TO BE READ BY EXPERT 2000 CAD SYSTEM. C FILED--30-NOV-84, G. BEVER. C C COMPILE AS FOLLOWS: C C .FORTRA CADWRT C C LINK AS FOLLOWS: C C .LINK CADWRT 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(134) 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 *MS:=FILE.FOR C WHERE 'MS:' SPECIFIES MAGTAPE TO OUTPUT (MT: FOR 800 BPI TAPE). C 'FILE.FOR' SPECIFIES INPUT SOURCE FILE. C C GET INPUT SOURCE FILE NAME FROM SYSTEM CONSOLE (1ST TIME). 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(1)).NE.0) STOP 'BAD IN FETCH' C GET CHANNEL NUMBER. ICHAN=IGETC() IF(ICHAN.LT.0) STOP 'NO CHANNEL' C PERFORM NON FILE STRUCTURED LOOKUP OF DEVICE. I=LOOKUP(ICHAN,ISPEC(1)) IF(I.LT.0) GO TO 50 GO TO 13 C C GET INPUT SOURCE FILE NAME FROM SYSTEM CONSOLE. 12 IF(ICSI(ISPEC,EXT,,JSWI,1).NE.0) GO TO 12 C ASSIGN DISC FILE FOR SOURCE INPUT. 13 CALL IASIGN(2,ISPEC(16),ISPEC(17),0,0) C 'REWIND' FILE. 11 IBLK=0 C L=1 C CLEAR OUT BUFFER. 20 DO 25 I=1,256 25 IBUF(I)="020040 C READ RECORD FROM INPUT FILE. 29 READ(2,101,END=9998)(KBUF(I),I=1,134) 101 FORMAT(134A1) C C ELIMINATE TRAILING BLANKS. LAST=134 DO 30 I=1,134 IF(KBUF(135-I).NE.' ') GO TO 34 LAST=LAST-1 30 CONTINUE C TERMINATE STRING WITH . 34 LAST=LAST+1 KBUF(LAST)="15 C XFER CHARACTERS TO OUTPUT BUFFER. DO 35 I=1,LAST JBUF(L)=KBUF(I) IF(L.LT.512) GO TO 35 ! IF BUFFER NOT FULL, JUMP. C WRITE TAPE RECORD K=IWRITW(256,IBUF,IBLK,ICHAN) IBLK=IBLK+1 C CLEAR OUTPUT BUFFER. L=0 DO 36 K=1,256 36 IBUF(K)="020040 35 L=L+1 GO TO 29 C************ 50 WRITE(7,100)I,J 100 FORMAT(1X,2I7) STOP 'BAD LOOKUP' 104 FORMAT(I5) 9998 IF(L.LT.512) K=IWRITW(256,IBUF,IBLK,ICHAN) ! WRITE PARTIAL BLOCK. CALL CLOSE(2) C WRITE EOF ON MT. CALL ISPFNW("377,ICHAN) TYPE 103 103 FORMAT(' NEXT FILE (Y/N->1/0):') ACCEPT 104,N IF(N.EQ.1) GO TO 12 STOP 'XFER OK' END