FTN4,L,C
      PROGRAM AB2MI() 
     $,92071-16241 REV.2041 800729
C     NAME:   AB2MI 
C     SOURCE: 92071-18241 
C     RELOC:  92071-16241 
C     PGMR:   WWL,HLC,BC
C 
C 
C  **************************************************************** 
C  * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1980.  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) 
      INTEGER TRECS 
C 
C     THIS PROGRAM COPIES AN ABSOLUTE BINARY FILE 
C     TO A MEMORY IMAGE (TYPE 1) FILE.  ONLY THOSE LOCATIONS
C     SPECIFIED IN THE ABSOLUTE FILE ARE MODIFIED 
C     IN THE MEMORY IMAGE FILE. 
C 
C     OPERATION:
C       RU,AB2MI,INPUT:SC:CR,OUTPUT:SC:CR::SIZE 
C 
C     THE INPUT FILE MUST HAVE BEEN PREVIOUSLY CREATED. 
C     THE OUTPUT FILE IS CREATED BY 'AB2MI' IF IT IS
C     NOT FOUND.  THE DEFAULT SIZE IS 256 BLOCKS (32K WORDS). 
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
      IREC=0
      MXREC=0 
      IOPT=0
C 
C     OPEN THE INPUT FILE (OPENF ALLOWS DEVICES OR FILES) 
C 
      CALL NAMR(OBUF,IBUF,IB,IX)
      ITYP=IAND(OBUF(4),3)
      IF(ITYP .EQ. 1)IOPT=110B
      CALL OPENF(ADCB,IERR,OBUF(1),IOPT,OBUF(5),OBUF(6))
      IF (IERR.LT.0) GOTO 800 
C 
C     CHECK INPUT FILE FOR TYPE 7 OR TYPE 0 AN LU 
      IF( (IERR .NE. 7) .AND. ( IERR .NE. 0) )GOTO 690
C 
C     OPEN OUTPUT FILE
C 
      CALL NAMR(OBUF,IBUF,IB,IX)
      IF (OBUF(1) .EQ. 0) GO TO 500 
      CALL OPEN(CDCB,IERR,OBUF(1),0,OBUF(5),OBUF(6))
      IF (IERR .NE. -6) GO TO 200 
      ISIZE=OBUF(8) 
      IF(ISIZE.EQ.0) ISIZE=256
      CALL CREAT (CDCB,IERR,OBUF(1),ISIZE,1,OBUF(5),OBUF(6))
      IF(IERR .LT. 0)GOTO 800 
      GO TO 400 
C 
  200 IF (IERR .LT. 0) GO TO 800
C 
C     CHECK FOR OUTPUT FOR TYPE 1 ONLY
      IF(IERR .NE. 1)GOTO 790 
C 
C     COPY THE FILE 
C 
400   IF (IFBRK(ISES).LT.0) GOTO 850
      CALL READF(ADCB,IERR,IBUF,128,LEN)
      IF (IERR.LT.0) GOTO 800 
C 
      IF (LEN.EQ.0) GOTO 400
C 
C     LEN = -1 INDICATES END OF FILE
C 
      IF (LEN.LT.0) GOTO 600
      IX=IBUF(1)/256
      IA=IBUF(2)
C 
C     IC CONTAINS A RUNNING CHECKSUM OF THE DATA
C 
      IC=IA 
      DO 410,I=1,IX 
      ID=IBUF(I+2)
      IC=IC+ID
C 
C     COMPUTE THE BLOCK AND OFFSET WITHIN THE BLOCK 
C 
      IBLOK=IA/128
      IOFST=IA-IBLOK*128+1
      IBLOK=IBLOK+1 
C 
      IF (IREC.EQ.IBLOK)GOTO 409
      IF (IREC.EQ.0)GOTO 402
C 
C     SOME OTHER BLOCK IS IN MEMORY.  POST TO DISC. 
C 
      CALL WRITF(CDCB,IERR,OBUF,128,IREC) 
      IF (IERR.LT.0) GOTO 700 
      IF (IREC .GT. MXREC) MXREC=IREC 
C 
C     READ IN THE BLOCK CONTAINING THE WORD.
C 
402   CALL READF(CDCB,IERR,OBUF,128,IJUNK,IBLOK)
      IF (IERR.LT.0) GOTO 800 
      IREC=IBLOK
409   OBUF(IOFST)=ID
      IA=IA+1 
410   CONTINUE
C 
C     MAKE SURE CHECKSUM AGREES 
C 
      IF (IC.EQ.IBUF(LEN)) GOTO 400 
      WRITE(LOG,440)
440   FORMAT("  CHECKSUM ERROR")
      GOTO 900
C 
C 
C 
C 
C     END OF FILE, POST FINAL BLOCK TO THE DISC 
C 
600   IF(IREC.EQ.0) GOTO 900
      CALL WRITF(CDCB,IERR,OBUF,128,IREC) 
      IF (IERR.LT.0) GOTO 800 
      IF (IREC .GT. MXREC) MXREC=IREC 
      GO TO 900 
C 
C 
C     BREAK FLAG SET,  PRINT MESSAGE AND ABORT
C 
850   WRITE(LOG,860)
860   FORMAT("  BREAK FLAG SET")
      GOTO 900
C 
C 
C     INPUT FILE NAMES FROM TERMINAL
C 
C 
C 
500   WRITE(LOG,520)
520   FORMAT("  THIS PROGRAM COPIES AN ABSOLUTE BINARY (TYPE 7)"/ 
     C"  FILE TO A MEMORY IMAGE (TYPE 1) FILE.")
550   WRITE (LOG,570) 
570   FORMAT(/"  PLEASE ENTER THE INPUT FILE AND OUTPUT FILE NAMES."/ 
     C"  FORMAT:  INPUT:SC:CR, OUTPUT:SC:CR::SIZE"/"  _") 
      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)GO TO 550 
      IF(IERR .EQ. -7)GO TO 550 
      IF(IERR .EQ. -32)GO TO 550
      GO TO 900 
C 
C 
C 
C     PRINT FMP ERROR MESSAGE 
C 
790   IERR=-16
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 
C     CLOSE INPUT AND OUTPUT FILES
C 
900   WRITE (LOG,905) MXREC 
905   FORMAT ("  HIGHEST BLOCK WRITTEN:"I4/)
      CALL CLOSE (CDCB) 
      CALL CLOSE (ADCB) 
      END 
                                    