C       FCOPY.FOR
C
C       Program to do a physical-block copy of the console floppy disk.
C       Floppy data can be read/written from/to a file in the users
C       directory.  The user must have the PHYSICAL_IO privilege.
C
C                                                       7/82  S. Kaberline
C


        IMPLICIT INTEGER (A-Z)

        LOGICAL*1    FUNCT, BELL

        CHARACTER*1  REPLY
        CHARACTER*3  TYPE
        CHARACTER*12 FLOPPY_NAME
        CHARACTER*80 DISK_FILE

        BYTE DISK_BUFFER(128)                   ! Buffer for one floppy block

        DIMENSION IOSB(2)

        EXTERNAL IO$_READPBLK, IO$_WRITEPBLK

        DATA FLOPPY_NAME / '_CSA1:' /
        DATA BELL        / 7 /


C
C       Solicit run parameters from user
C

        CALL LIB$ERASE_PAGE(1,1)

        READ_P_SECT  = %LOC(IO$_READPBLK)
        WRITE_P_SECT = %LOC(IO$_WRITEPBLK)

        TYPE 10
10      FORMAT (' Read or write floppy [R/W]: ',$)
        READ (-4,20,END=120,ERR=120) REPLY
20      FORMAT (A)

        IF (REPLY .EQ. 'W'  .OR. REPLY .EQ. 'w') THEN
                                                        FUNCT = .TRUE.
                                                 ELSE
                                                        FUNCT = .FALSE.
        ENDIF

        IF (FUNCT) THEN 
                                TYPE 30
30                              FORMAT ('  Input ',$)
                      ELSE      
                                TYPE 40
40                              FORMAT (' Output ',$)
        ENDIF


        TYPE 50
50      FORMAT ('+disk file:           ',$)
        READ (-4,20,END=120,ERR=120) DISK_FILE

C
C       Open the users disk file
C

        IF (FUNCT) THEN
                                TYPE = 'OLD'
                      ELSE
                                TYPE = 'NEW'
        ENDIF

        OPEN (UNIT=1,NAME=DISK_FILE,TYPE=TYPE,RECL=128,
     *          FORM='FORMATTED',RECORDTYPE='FIXED',DISPOSE='KEEP',
     *          INITIALSIZE=501,CARRIAGECONTROL='NONE',ERR=2999)


        IF (FUNCT)    THEN
                 TYPE 60
60               FORMAT (/,' Remove the console floppy,',
     *               ' insert blank floppy.',//,
     *               ' Type <return> when ready. ',$)
                 READ (-4,20,END=120,ERR=120) REPLY
                 TYPE 70
70               FORMAT (/,' Are you SURE the console floppy',
     *               ' is removed? ',$)
                 READ (-4,20,END=120,ERR=120) REPLY
                 IF (.NOT.(REPLY.EQ.'Y'.OR.REPLY.EQ.'y')) CALL EXIT
             ELSE
                 TYPE 80
80               FORMAT (/,' Type <return> when ready. ',$)
                     READ (-4,20,END=120,ERR=120) REPLY
        ENDIF

        TYPE 90
90      FORMAT (//, ' Copying an entire floppy requires approximately',
     *              ' 6 minutes!',/,
     *              ' Please be patient!',//)


C
C       Assign a channel to the floppy.
C

        STATUS = SYS$ASSIGN(FLOPPY_NAME, FLOPPY_CHAN, ,,)
        IF (.NOT. STATUS) GO TO 999

C
C       Read/write the floppy sectors, copy the sector to/from a disk file
C

        START_SECTOR = 1
        END_SECTOR   = 26 * 77

        DO SECTOR = START_SECTOR, END_SECTOR
        TRACK     = (SECTOR-1) / 26
        SECT      = SECTOR - (TRACK * 26)
        DISK_ADDRESS = TRACK*65536 + SECT               ! (for Physical QIO)

        IF (FUNCT) THEN
                READ (1,100,ERR=1999,END=3999) DISK_BUFFER
100             FORMAT (128A1)
                STATUS = SYS$QIOW (%VAL(1),%VAL(FLOPPY_CHAN),
     *              %VAL(WRITE_P_SECT),IOSB,,,
     *              DISK_BUFFER,%VAL(128),%VAL(DISK_ADDRESS),,,)
                IF (.NOT.  STATUS) GO TO  999
                IF (.NOT. IOSB(1)) TYPE 5000,IOSB
            ELSE
                STATUS = SYS$QIOW (%VAL(1),%VAL(FLOPPY_CHAN),
     *              %VAL(READ_P_SECT),IOSB,,,
     *              DISK_BUFFER,%VAL(128),%VAL(DISK_ADDRESS),,,)
                IF (.NOT.  STATUS) GO TO  999
                IF (.NOT. IOSB(1)) TYPE 5000,IOSB
                WRITE (1,100,ERR=1999) DISK_BUFFER
        ENDIF                      
        ENDDO

        TYPE 110, BELL, BELL
110     FORMAT (/,' Done!!', 2A1)

120     CLOSE (UNIT=1)
        CALL EXIT


C
C       Error routines
C

999     TYPE 1000, STATUS
1000    FORMAT (/,' **** Fatal directive error ****   ', Z8)
        CLOSE (UNIT=1)
        CALL EXIT (STATUS)

1999    TYPE 2000
2000    FORMAT (/,' **** Fatal file open or I/O error ****')
        GO TO 120

2999    TYPE 3000
3000    FORMAT (/,' **** Fatal - unable to open disk file ****')
        GO TO 120

3999    DIGITS = LOG10(FLOAT(SECTOR)) + 1
        TYPE 4000, SECTOR
4000    FORMAT (/, ' **** Premature EOF on input disk file ****',/,
     *             ' **** Only ',I<DIGITS>,' out of normal 2002'
     *             ' sectors copied ****')
        GO TO 120

4999    TYPE 5000, IOSB
5000    FORMAT (/,' **** I/O error on floppy disk: IOSB = ',2Z8,' ****')
        GO TO 120

        END
