C** COPYDV - COPY DISK IN IMAGE FORMAT C PROGRAM COPYDV C INTEGER IPRM(6),LUNI(6),LUNO(6),IPR(6) BYTE BUF(12288) BYTE IOSB(4),DEV1(8),DEV2(8) LOGICAL*1 YN,ABO C C.. FORCE BUFFER TO END OF TASK IMAGE CCCCC COMMON /$$$$$$/ BUF ! F4P WON'T ALLOW IT C DATA IORLB/"1000/,IOWLB/"400/,ISFGMC/"2560/ DATA MAXBLK/24/ ! MAX BLOCKS PER READ C C.. INITIALIZE PROGRAM CALL GETADR (IPR,BUF) BUF(1)="12 ! CHECK IF TERMINAL IS CRT BUF(2)=0 ! RETURNED AS 1 IF TRUE IPR(2)=2 ! ONLY CHECK FOR CRT CALL WTQIO (ISFGMC,5,5,,IOSB,IPR,IDS) IF(IDS.NE.1)STOP'Get terminal char directive error' IF(IOSB(1).NE.1)STOP'Get terminal char I/O error' IF(BUF(2).EQ.0) GOTO 1 C C.. CLEAR SCREEN IF CRT CALL HOME CALL EPAGE C C.. GET INPUT DEVICE SPEC 1 TYPE 2000 2000 FORMAT('$Input device? ') READ(5,1000,END=900)ICHR,DEV1 1000 FORMAT(Q,8A1) CALL PARSDV(DEV1,ICHR,IDEV,IUNIT) CALL ASNLUN(1,IDEV,IUNIT,IDS) IF(IDS .NE. 1)STOP 'Invalid input device spec' C C.. GET OUTPUT DEVICE SPEC TYPE 2010 2010 FORMAT('$Output device? ') READ(5,1000,END=900)ICHR,DEV2 CALL PARSDV(DEV2,ICHR,IDEV,IUNIT) CALL ASNLUN(2,IDEV,IUNIT,IDS) IF(IDS .NE. 1)STOP 'Invalid output device spec' C C.. SET UP PARAMETER BLOCK CALL GETADR(IPRM,BUF) ! ADDRESS OF I/O BUFFER IPRM(3)=0 ! MUST BE ZERO IPRM(4)=0 ! HIGH ORDER BLOCK NUMBER ZERO C C.. CHECK ON DEVICES - MUST BE ALIKE CALL GETLUN(1,LUNI,IDS) CALL GETLUN(2,LUNO,IDS) C C.. VALIDATE DEVICES HERE - MUST BE MOUNTABLE ETC. IF(IAND(LUNI(2),"100000).NE. 0) GOTO 30 IF(IAND(LUNO(2),"100000).NE. 0) GOTO 30 STOP 'Driver not loaded' 30 IF(LUNI(5).NE.LUNO(5)) STOP 'Devices not of like size' WRITE(5,1100) LUNI(1),IAND(LUNI(2),7),LUNO(1),IAND(LUNO(2),7) 1 ,LUNI(5),MAXBLK 1100 FORMAT(' Copying from ',A2,O1,': to ',A2,O1,': ',I6,' Blocks'/ 1 ' Blocking factor: ',I3) CALL YENO ('Confirm ',YN) IF(.NOT.YN) GOTO 1 C C.. DO THE COPY HERE... 'MAXBLK' BLOCKS AT A TIME IBLK=LUNI(5)-1 DO 100 I=0,IBLK,MAXBLK IPRM(2)=MIN0(MAXBLK,IBLK-I)*512 IPRM(5)=I ! SET UP BLOCK NUMBER TO USE C C.. ISSUE INPUT REQUEST CALL WTQIO(IORLB,1,1,,IOSB,IPRM,IDS) IF(IDS.NE.1) STOP 'Input directive error' IF(IOSB(1).NE.1) TYPE 1200,IOSB,IPRM 1200 FORMAT(/' Read Error: ',4O4,6O7) C C.. AND WRITE IT OUT CALL WTQIO(IOWLB,2,1,,IOSB,IPRM,IDS) IF(IDS.NE.1)STOP 'Output directive error' IF(IOSB(1).NE.1) TYPE 1300,IOSB,IPRM 1300 FORMAT(/' Write Error:',4O4,6O7) D CALL TYPE ('*') D CALL CRLF 100 CONTINUE C C.. ALL DONE HERE 900 STOP END C** PARSDV - PARSE DEVICE SPEC INTO NAME AND UNIT C SUBROUTINE PARSDV(SPEC,LEN,NAME,IUNIT) C C.. GIVEN A DEVICE SPECIFICATION 'SPC' DDNN: AND ITS LENGTH 'LEN' C RETURN AN 'A2' NAME AND A BINARY UNIT NUMBER C BYTE SPEC(8),NAME(2) C NAME(1)=SPEC(1) ! FIRST CHARACTER OF DEVICE NAME NAME(2)=SPEC(2) ! SECOND IUNIT=0 ! ASSUME UNIT 0 DO 10 I=3,LEN ! LOOP THRU ALL OF LINE IF(SPEC(I).EQ.':') RETURN ! DONE ON FINDING COLON IUNIT=IUNIT*8+(SPEC(I)-"60) ! UPDATE UNIT NUMBER (OCTAL) 10 CONTINUE ! LOOP FOR MORE RETURN ! RETURN TO USER END