FTN4,L,C
      PROGRAM MI2AB() 
     $,  92070-16276  REV. 2001  790907 
C     NAME:   MI2AB 
C     SOURCE: 92070-18276 
C     RELOC:  92070-16276 
C     PGMR:   B.C.
C 
C 
C  **************************************************************** 
C  * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979.  ALL RIGHTS      * 
C  * RESERVED.  NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED,       * 
C  * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT * 
C  * THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY.        * 
C  **************************************************************** 
C 
C 
      INTEGER ADCB(144),CDCB(144) 
      INTEGER IBUF(128),OBUF(128),IP(10)
      INTEGER TRECS 
C 
C     THIS PROGRAM COPIES AN SYSTEM FILE ( MEMORY IMAGE TYPE 1) 
C     TO A ABSOLUTE BINARY (TYPE 7) FILE. 
C 
C     OPERATION:
C       RU,MI2AB,INPUT:SC:CR,OUTPUT:SC:CR 
C 
C     THE INPUT FILE MUST HAVE BEEN PREVIOUSLY CREATED. 
C     THE OUTPUT FILE IS CREATED BY 'MI2AB' IF IT IS
C     NOT FOUND.
C 
C 
      CALL GETST(IBUF,-80,IB) 
      LOG=LOGLU(ISES) 
C 
C     IF NO FILES WERE INPUT, READ NAMES FROM TERMINAL
C 
      IF (IB.EQ.0) GOTO 500 
100   IX=1
      ITIME=0 
      IOPT =0 
      ISIZE=200 
C 
C     OPEN THE INPUT FILE (OPENF ALLOWS DEVICES OR FILES) 
C 
      CALL NAMR(OBUF,IBUF,IB,IX)
      CALL OPENF(ADCB,IERR,OBUF(1),0,OBUF(5),OBUF(6)) 
      IF (IERR.LT.0) GOTO 700 
C 
C     CHECK FOR FILE TYPE 1 OR TYPE 0 FOR DEVICE
      IF (IERR.GT.1) GOTO 690 
C 
C     GET AN OUTPUT FILE OR AN LU 
      CALL NAMR(OBUF,IBUF,IB,IX)
C 
      IF (OBUF(1) .EQ. 0) GO TO 500 
      IF (OBUF(4) .EQ. 1) IOPT=110B 
      CALL OPENF(CDCB,IERR,OBUF(1),IOPT,OBUF(5),OBUF(6))
      IF (IERR .NE. -6) GO TO 200 
C 
C     IF OUTPUT IS AN LU , BYPASS  CREAT
C 
      IF(OBUF(4) .EQ. 1)GO TO 210 
      CALL CREAT (CDCB,IERR,OBUF(1),ISIZE,7,OBUF(5),OBUF(6))
  200 IF (IERR .LT. 0) GO TO 800
C 
C     ABSOLUTE LOAD ADDRESS 
210   LODAD=0 
C 
C     COPY THE FILE 
C 
400   IF (IFBRK(ISES).LT.0) GOTO 850
      CALL READF(ADCB,IERR,IBUF,128,LEN)
      IF(IERR .EQ. -12)GOTO 900 
      IF (IERR.LT.0) GOTO 700 
C 
      IF (LEN.EQ.0) GOTO 400
C 
C     LEN = -1 INDICATES END OF FILE
C 
      IF(ITIME .NE. 0)GO TO 405 
      MXREC=( IBUF(1) + 2)/128 + 2
      IF(MXREC .GT. 256)MXREC=256 
C 
405   ITIME=ITIME + 1 
C 
      I2=1
C 
      DO 420 J=1,2
C 
      OBUF(1)=64*256
      OBUF(2)=LODAD 
C 
      ICKSM=0 
C 
      DO 410 I=1,64 
      OBUF(I+2)=IBUF(I2)
      ICKSM=ICKSM+IBUF(I2)
410   I2=I2+1 
C 
      OBUF(67)=LODAD+ICKSM
C 
      LODAD=LODAD+64
C 
      CALL WRITF(CDCB,IERR,OBUF,67) 
      IF (IERR.LT.0) GOTO 800 
C 
      IF(ITIME .EQ. MXREC)GO TO 900 
C 
420   CONTINUE
C 
      GO TO 400 
C 
C     BREAK FLAG SET,  PRINT MESSAGE AND ABORT
C 
850   WRITE(LOG,860)
860   FORMAT("  BREAK FLAG SET")
      GOTO 900
C 
C     INPUT FILE NAMES FROM TERMINAL
C 
500   WRITE(LOG,520)
520   FORMAT("  THIS PROGRAM COPIES AN MEMORY IMAGE (TYPE 1)"/
     C"  FILE TO A ABSOLUTE BINARY (TYPE 7) FILE.") 
550   WRITE (LOG,570) 
570   FORMAT(/"  PLEASE ENTER THE INPUT FILE AND OUTPUT FILE NAMES."/ 
     C"  FORMAT:  INPUT:SC:CR, OUTPUT:SC:CR" / " -")
      CALL REIO(1,LOG+400B,IBUF,-80)
      CALL ABREG(IA,IB) 
      IF(IB.EQ.0)GOTO 900 
      GOTO 100
C 
690   IERR=-16
700   WRITE (LOG,710) IERR
710   FORMAT( "  INPUT FILE ERROR " I7) 
      IF (IERR .EQ. -6)GOTO 550 
      IF (IERR .EQ. -7)GOTO 550 
      IF (IERR .EQ. -32)GOTO 550
      GO TO 900 
C 
C     PRINT FMP ERROR MESSAGE 
C 
800   WRITE (LOG,810) IERR
810   FORMAT("  OUTPUT FILE ERROR " I7) 
      IF (IERR .EQ. -6)GOTO 550 
      IF (IERR .EQ. -7)GOTO 550 
      IF (IERR .EQ. -32)GOTO 550
C 
C     CLOSE INPUT AND OUTPUT FILES
C 
900   CALL CLOSE (CDCB) 
      CALL CLOSE (ADCB) 
      END 
                                                                                                                                                                                        