C C C THIS PROGRAM TAKES A FILE FROM THE DISK AND C PUTS THE DATA BACK ONTO THE MAGTAPE. C TWO FILES ARE USED: C XXXXXX.D -DATA C XXXXXX.P -POINTER C C C C 26-MAY-78 C PARAMETER IOBUF=4096,IMBUF=8192 INCLUDE 'FUNCTION.FTN' INTEGER*2 LUNMM,IDS,MMBUF(IOBUF),MMIOSB(2),MMEF,MMPARM(6) INTEGER*2 ICNT BYTE MBUF(IMBUF),IFILE(80),IFIPT(16),IFIDT(16) EQUIVALENCE (MBUF,MMBUF) C C C PUT OUT FLYER C PRINT 9999 9999 FORMAT(' THIS PROGRAM TAKES THE DISK FILE AND PUTS',/ 1 ,' IT BACK ONTO MAGTAPE.......') C MAGTAPE INITIALIZATION CRAP C 3 TYPE 4 4 FORMAT(' MOUNT TAPE PLS,(HIT C WHEN READY): ',$) ACCEPT 103,NCHR,(IFILE(NCHR),I=1,NCHR) IF(IFILE(1).NE.'C')GOTO3 LUNMM=1 ITRACE=1 MMEF=1 MEOF=0 MMIOSB(1)=0 MMIOSB(2)=0 DO 1I=1,6 1 MMPARM(I)=0 PRINT 6 6 FORMAT(' ENTER 1600 OR 800 FOR TAPE DENSITY( IS 800): ',$) ACCEPT 7,ITRACE 7 FORMAT(I6) IF(ITRACE.EQ.1600)MMPARM(1)=MMPARM(1)+I1600 ITRACE=3 C C ASSIGN THE MAGTAPE C CALL ASNLUN(LUNMM,'MM',0,IDS) IF(IDS.NE.ISSUC)GOTO 9000 ITRACE=ITRACE+1 C C DO ATTACH C CALL WTQIO(IOATT,LUNMM,MMEF,,MMIOSB,MMPARM,IDS) IF (IDS.NE.ISSUC) GOTO 9000 ITRACE=ITRACE+1 C C CLEAR MAGTAPE STATUS THEN SENSE IT C IF TAPE IS NOT READY THEN ABORT C IF TAPE IS NOT AT BOT THE REWIND IT C CALL WTQIO(IOSTC,LUNMM,MMEF,,MMIOSB,MMPARM,IDS) IF(IDS.NE.ISSUC) GOTO 9000 ITRACE=ITRACE+1 CALL WTQIO(IOSEC,LUNMM,MMEF,,MMIOSB,MMPARM,IDS) IF (IDS.NE.ISSUC)GOTO 9000 ITRACE=ITRACE+1 C C TAPE ONLINE? IF(IAND(TEONL,MMIOSB(2)).NE.0) GOTO 9100 C C TAPE WRITE LOCKED? IF(IAND(TEWLK,MMIOSB(2)).NE.0) GOTO 9200 C C REWIND THE TAPE IF(IAND(TERWD,MMIOSB(2)).EQ.0)PRINT 10 ITRACE=ITRACE+1 10 FORMAT(' REWINDING THE TAPE .. ') CALL WTQIO(IORWD,LUNMM,MMEF,,MMIOSB,MMPARM,IDS) IF(IDS.NE.ISSUC)GOTO 9000 C C C MAGTAPE OK SO ON-WARDS C C C 100 ITRACE=100 C C SET UP THE FILES.. XXXXXX.P FOR POINTER FILE C XXXXXX.D FOR DATA FILE C IUNPT=2 IUNDT=3 101 TYPE 102 102 FORMAT(' ENTER FILNAM (NO EXT. OR ACCT. NUM. ALLOWED): ',$) ACCEPT 103,NCHR,(IFILE(I),I=1,NCHR) 103 FORMAT(Q,80A1) IF((NCHR.LT.1).OR.(NCHR.GT.9)) GOTO 101 DO 104I=1,NCHR+1 IF(I.GT.NCHR)IFILE(I)='.' IFIPT(I)=IFILE(I) 104 IFIDT(I)=IFILE(I) IFIPT(NCHR+2)='P' IFIDT(NCHR+2)='D' IFIPT(NCHR+3)="000 IFIDT(NCHR+3)="000 C C OPEN POINTER AND DATA FILES C OPEN(UNIT=IUNPT,NAME=IFIPT,TYPE='OLD', 1 ACCESS='SEQUENTIAL',FORM='UNFORMATTED',DISPOSE='SAVE') IUNPTF=1 OPEN(UNIT=IUNDT,NAME=IFIDT,TYPE='OLD', 1 ACCESS='SEQUENTIAL',FORM='UNFORMATTED',DISPOSE='SAVE') IUNDTF=1 C C FILES ARE NOW OPEN MAGTAPE READY O BOY LET'S GO! C 105 CONTINUE C C READ IN THE POINTER C POSTIVE MEANS DATA C -1 IS SINGLE END OF FILE C -2 IS END OF TAPE C READ(IUNPT) ICNT IF(ICNT.GT.0)GOTO 150 C C WRITE EOF CALL WTQIO(IOEOF,LUNMM,MMEF,,MMIOSB,MMPARM,IDS) IF(IDS.NE.ISSUC)GOTO 9000 ITRACE=ITRACE+1 IF(ICNT.EQ.-1) GOTO 105 IF(ICNT.EQ.0) PRINT 120 120 FORMAT(' ILLEGAL BYTE COUNT IE. ZERO -- ABORT!') CALL WTQIO(IOEOF,LUNMM,MMEF,,MMIOSB,MMPARM,IDS) IF(IDS.NE.ISSUC)GOTO 9000 ITRACE=3000 CALL WTQIO(IORWD,LUNMM,MMEF,,MMIOSB,MMPARM,IDS) IF(IDS.NE.ISSUC)GOTO 9000 GOTO 200 150 DO 160 I=1,ICNT,512 160 CALL DMPMM(IUNDT,MBUF(I)) CALL GETADR(MMPARM(1),MMBUF(1)) IF (IAND(ICNT,1).EQ.0) GOTO 170 PRINT 165,ICNT 165 FORMAT(' BYTE COUNT IS ODD . INCREMENTING IT (IT WAS : ',I6,')') ICNT=ICNT+1 MMBUF(ICNT)="000 170 MMPARM(2)=ICNT CALL WTQIO(IOWLB,LUNMM,MMEF,,MMIOSB,MMPARM,IDS) IF((IDS.NE.ISSUC).OR.(MMIOSB(1).NE.ISSUC)) GOTO 9000 ITRACE=ITRACE+1 GOTO 105 200 CONTINUE C C ALL DONE AS WE RECEIVED TWO END OF FILES C IF(IUNPTF.EQ.1)CLOSE(UNIT=IUNPT,DISPOSE='SAVE') IF(IUNDTF.EQ.1)CLOSE(UNIT=IUNDT,DISPOSE='SAVE') CALL EXIT C C ERROR HANDLING C 9000 PRINT 9010,ITRACE,IDS,(MMIOSB(I),I=1,2) 9010 FORMAT(' ITRACE= ',I6,/,' IDS= ',O6,/,' IOSBS = ',2O6) PRINT 9020,(MMPARM(I),I=1,6) 9020 FORMAT(' MMPARM VALUES: ',6(/,O6)) GOTO 200 9100 PRINT 9110 9110 FORMAT(' TAPE OFFLINE --- FIX, THEN TRY RUN AGAIN') GOTO 200 9200 PRINT 9210 9210 FORMAT(' TAPE WRITE LOCKED ---- FIX, THEN TRY RUN AGAIN') GOTO 200 END C C BLOCK DATA C BLOCK DATA INCLUDE 'FUNCTION.FTN' DATA IOATT,IODET/"001400,"002000/ DATA IORLB,IOWLB/"001000,"000400/ DATA IOEOF,IORWD/"003000,"002400/ DATA IOSEC,IOSTC/"002520,"002500/ DATA ISSUC,ISPND/1,0/ DATA TERWD,TEONL/"020000,"000400/ DATA TEWLK/"002000/ DATA IEEOF,I1600,IEDNR/"366,"4000,"375/ END SUBROUTINE DMPMM(IUNIT,IBUF) BYTE IBUF(512) READ(IUNIT)IBUF RETURN END