C C C C PROGRAM TO COPY MAGTAPE TO DISK C DATA FILE: XXXXXXX.D C POINTER FILE: XXXXXXX.P C C 26-MAY-78 C C PARAMETER IOBUF=4096,IMBUF=8192 INCLUDE 'FUNCTION.FTN' INTEGER*2 LUNMM,IDS,MMBUF(IOBUF),MMIOSB(2),MMEF,MMPARM(6) INTEGER*2 MEOF BYTE MBUF(IMBUF),IFILE(80),IFIPT(16),IFIDT(16) EQUIVALENCE (MBUF,MMBUF) INTEGER*4 IRDCNT,IEOFCT C C WRITE OUT THE FLYER PRINT 9999 9999 FORMAT(' THIS PROGRAM COPIES A MAGTAPE TO A DISK',/, 1 ' MOUNT A MAGTAPE AND I WILL DO THE REST (PLS TAKE OUT',/, 2 ' THE WRITE RING)') 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 IF(IAND(TEONL,MMIOSB(2)).NE.0) GOTO 9100 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='UNKNOWN', 1 ACCESS='SEQUENTIAL',FORM='UNFORMATTED',DISPOSE='SAVE') IUNPTF=1 OPEN(UNIT=IUNDT,NAME=IFIDT,TYPE='UNKNOWN',RECORDSIZE=128 1,ACCESS='SEQUENTIAL',FORM='UNFORMATTED',DISPOSE='SAVE') IUNDTF=1 C C FILES ARE NOW OPEN MAGTAPE READY O BOY LET'S GO! C IRDCNT=0 IEOFCT=0 105 CONTINUE C C C READ DATA CALL GETADR(MMPARM(1),MMBUF(1)) MMPARM(2)=IOBUF CALL WTQIO(IORLB,LUNMM,MMEF,,MMIOSB,MMPARM,IDS) IF(MMIOSB(1).EQ.IEDNR)GOTO 9200 IF(IDS.NE.ISSUC) GOTO 9000 ITRACE=ITRACE+1 C C END OF FILE? IF(MMIOSB(1).NE.IEEOF) GOTO 150 C C WE GOT END OF FILE C MEOF=MEOF-1 IEOFCT=IEOFCT+1 WRITE(IUNPT)MEOF IF(MEOF.LT.-1) GOTO 200 GOTO 105 C C DID WE GET ANY ERRORS? C IF SO GOTO 9000 AND DIE! C 150 IF(MMIOSB(1).NE.ISSUC) GOTO 9000 IRDCNT=IRDCNT+1 MEOF=MMIOSB(2) WRITE(IUNPT)MEOF MEOF=0 DO 160I=1,MMIOSB(2),512 160 CALL DMPDK(IUNDT,MBUF(I)) C C READ ANOTHER C GOTO 105 200 CONTINUE PRINT 202,IRDCNT,IEOFCT 202 FORMAT(' NUMBER OF RECORDS READ: ',I7,/, 1 ' NUMBER OF END OF FILES: ',I7) CALL WTQIO(IORWD,LUNMM,MMEF,,MMIOSB,MMPARM,IDS) IF(IDS.NE.ISSUC)PRINT 204 204 FORMAT(' TAPE ERROR ON REWIND... ABORTING') C C ALL DONE AS WE RECEIVED TWO END OF FILES C MEOF=-2 IF(IUNPTF.EQ.1)WRITE(IUNPT)MEOF 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 NOT AT CORRECT DENSITY OR TAPE NOT GOOD') 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 DMPDK(IUNIT,IBUF) BYTE IBUF(512) WRITE(IUNIT)IBUF RETURN END