       SUBROUTINE PACK8B(KOUTUN,INRAST,KDMRAS,IFRSTQ,
     1                    ILASTQ,NBUFS,NO8BIT,IRETN)
C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    PACK8B      TO PACK THE GIVEN RESTER INTO BEDIENT'S
C   PRGMMR: KRISHNA KUMAR     ORG: W/NP12    DATE: 1999-07-01
C
C ABSTRACT: TO PACK THE GIVEN RASTER IN BEDIENT'S 6-BIT FAX CODE. BUT
C   EXTENED INTO 8-BIT RIGHT ADJUSTED BYTES.  THE LEFT-MOST TWO BYTES
C   ARE REDUNDANT.  AFTER REPACKING INTO 8-BIT RIGHT ADJUSTED PACKED
C   DATA, USERS HAVE TO INVOKE SUBR CP8TO6 WHICH COMPRESSES 8-BIT TO
C   6-BIT PACKED DATA.
C
C PROGRAM HISTORY LOG:
C   87-10-29  DAVE SHIMOMURA   ORIGINAL AUTHOR
C   95-05-16  LUKE LIN         MODIFY AND BRING IT INOT FORTRAN 77
C                              AND ADD DOCBLOCK
C 1999-07-01  KRISHNA KUMAR    CONVERTED THIS CODE FROM CRAY TO  
C                              IBM RS/6000
C
C USAGE:    CALL PACK8B(KOUTUN,INRAST,KDMRAS,IFRSTQ,ILASTQ,NBUFS,IRETN)
C   INPUT ARGUMENT LIST:
C     KOUTUN   - DSRN OF UNIT FOR WRITING THE RESULTS TO
C     INRAST   - ONE UNPACKED SCANLINE OR "RASTER"
C     KDMRAS   - DIMENSION OF THE UNPACKED SCANLINE
C     IFRSTQ   - THE CALLER MUST SET IFRSTQ=1 ON FIRST CALL IN ORDER TO
C              - INITIALIZE.  THIS SUBR PACK8B WILL RESET IFRSTQ TO ZERO
C              - AFTER INITIALIZATION, SO BE SURE TO USE A VARIABLE NAME
C              - FOR THIS ARGUMENT; DO NOT PUT A '1' IN THE CALL SEQ.
C     ILASTQ   - THE CALLER MUST SET ILASTQ=1 AT THE END OF THE MAP IN
C              - ORDER TO WRITE END-OF-MAP BYTE OUT.
C     NBUFS    - WILL COUNT THE NUMBER OF 512-BYTE BUFFERS WHICH WERE
C              - WRITTEN OUT ONTO UNIT=KOUTUN
C
C   OUTPUT ARGUMENT LIST:      (INCLUDING WORK ARRAYS)
C     NO8BIT   - A COUNT OF 8-BIT UNCOMPRESS PACKED DATA FOR FAX CUT
C              - INDICATING HOW MANY RECORDS AND DI-BYTES TO BE SKIP
C     IRETN    - = 0  FOR NORMAL RETURN FROM PROCESSING ONE SCANLINE
C              - = 1  AFTER WRITING END-OF-MAP BYTE IN LAST BUFFER
C              - = 2  IF ERROR DURING A WRITE TO UNIT=KOUTUN
C
C   OUTPUT FILES:  (DELETE IF NO OUTPUT FILES IN SUBPROGRAM)
C     KOUTUN   - CONTAINS 8-BIT PACKED RIGHT ADJUSTED DATA.
C
C REMARKS:
C     *NOTE: FOR VECTOR CONTOUR GRAPHICS
C
C ATTRIBUTES:
C   LANGUAGE: F90
C   MACHINE:  IBM
C
C$$$
       INTEGER      INRAST(KDMRAS)
       INTEGER      INRAST4(2*KDMRAS)
C
       INTEGER      KOUTUN
       INTEGER      IOUTBF(180)
       CHARACTER*1  LOUTBF(1440)
       EQUIVALENCE  (IOUTBF(1),LOUTBF(1))
C
       CHARACTER*1  LINEWK(1048)
C      ... MAX SCANLINE IN BEDIENT'S FAX SYSTEM IS 4192 BITS
C      ...   =1048 DIBYTES (WHERE A 'DIBYTE' = 4 BITS).
C      ... IF WE HAD 1048 "AS-IS" DIBYTES ENCODED IN EXTENDED
C      ...   6-BIT FAX CODE, THEN WE NEED 1048 BYTES.
C
       INTEGER      IACC,MQ
       INTEGER      KURO
C
       INTEGER    IDIBYT
       INTEGER    I4DIBY
       INTEGER    MSKLO4
C
       INTEGER    I4CX
C
       INTEGER    N4DIBS
       INTEGER    I4BORW
C
       INTEGER    KDIBLK
       INTEGER    KASIS
       INTEGER    KBKRUN
       INTEGER    IBORW
       INTEGER    NDIBS
       INTEGER    MXRUNC
       INTEGER    NDIGM2
C
       CHARACTER*1  CEOM
       CHARACTER*1  CEOS
C
       SAVE
C
C      DATA       CEOS  / Z'30' /
C      ... (110000)BINARY IS END-OF-SCANLINE
C      DATA       CEOM  / Z'33' /
C      ... (110011)BINARY IS END-OF-MAP
C
C
       DATA     KURO    / Z'FFFFFFFF' /
       DATA     MSKLO4  / Z'0000000F' /
       DATA     KDIBLK  / Z'000F' /
       DATA     KASIS   / Z'00000020' /
C
       DATA     KBKRUN  / Z'0010' /
       DATA     MXRUNC  /  1048 /
C      ... WHERE 1048 DIBYTES= 4192 PIXELS
C
       DATA     MAXWRK  / 1048 /
C
       DATA     MAXOUT  / 1440 /
       DATA     MAXINR  / 131 /
C      ... WHERE 131 32-BIT INTEGERS = 4192 BITS.
C
C      . . .   S T A R T   . . .
C
       IRETN = 0
       CEOM = CHAR(51)
       CEOS = CHAR(48)
C
       IF  (IFRSTQ .EQ. 1) THEN
C      ... INITIALIZE FOR A NEW MAP
           DO  122  I = 1,6
               IOUTBF(I) = 0
  122      CONTINUE
C
           LOU = 48
           NO8BIT = 48
           NBUFS = 0
           IFRSTQ = 0
           NSCANS = 0
       ENDIF
C
       IF (ILASTQ .EQ. 1) THEN
C        ...THIS IS END OF MAP ...
           LINEWK(1) = CEOM
           IBY = 1
           GO TO 600
C        ... TO PUT THE END-OF-MAP BYTE INTO OUTPUT BUFFER
C        ...   AND THEN CLEANUP.
C
       ENDIF
C      ... INITIALIZE FOR A NEW SCAN LINE
C
       CALL GBYTES(INRAST,INRAST4,0,32,0,2*KDMRAS)
C      UNPACK INTEGER*8 TO INTEGER*4 FOR INPUT RASTER LINE
       NSCANS = NSCANS + 1
       IBY = 0
C      ... WHERE IBY IS INDEX TO LINEWK ARRAY,
C      ...   SO IT SHUD BE INITIALIZED EVERY SCAN LINE
       NWDS = 2*KDMRAS
       IF(NWDS .GT. MAXINR) NWDS = MAXINR
C      ... HOW MANY TRAILING ZERO WORDS AT RIGHT END OF LINE?
       NWDM2 = NWDS
       DO  144 I = 1,NWDS
         IREV = NWDS + 1 - I
         IF(INRAST4(IREV) .NE. 0) GO TO 320
C        ... OTHERWISE, FOUND A TRAILING ZERO WORD
         NWDM2 = NWDM2 - 1
  144  CONTINUE
C
C      ... IF IT FALLS THRU BOTTOM OF THIS DO_LOOP,
C      ...   THEN THIS SCAN LINE IS ALL ZERO ...
       LINEWK(1) = CEOS
       IBY = 1
       GO TO 600
C
  320  CONTINUE
C      ... COMES HERE WITH NWDM2= LENGTH OF SCANLINE (IN I*4 WDS)
C      ...   TO ENCODE, IGNORING TRAILING ZERO WORDS.
C
       IRUNCT = 0
       ITT = 3
C      ... TYPE OF DIBYTE INITIALIZED TO "COMMAND"
C ...  REPLACING   DO  499  IWD = 1,NWDM2 ...
       IWD = 0
  330  CONTINUE
       IWD = IWD + 1
       IF(IWD .GT. NWDM2) GO TO 500
C
         ITTPRE = ITT
         MQ = INRAST4(IWD)
C
         IF(MQ .NE. 0) GO TO 350
C        ... OTHERWISE, WE HAVE A RUN OF ZEROS (8 DIBYTES LONG).
         ITT = 00
         IF(ITTPRE .NE. 1) GO TO 340
C        ... PREVIOUS TYPE=01, SO STOP RUNNING BLACKS BEFORE
C        ...   STARTING RUN OF WHITE.
         LCKPT = 340
         ASSIGN 340 TO KRETRN
         GO TO 700
C
  340    CONTINUE
C        ... START NEW RUN OF WHITES
         IRUNCT = IRUNCT + 8
         GO TO 499
C
  350    CONTINUE
         IF (MQ .NE. KURO) GO TO 400
C        ... OTHERWISE, THIS IS A RUN OF BLACKS (8 DIBYTES LONG)
         ITT = 01
         IF(ITTPRE .NE. 0) GO TO 370
C
C        ... PREVIOUS TYPE=00, SO SHUT OFF RUNNING WHITES BEFORE
C        ...   STARTING NEW RUN OF BLACKS
         LCKPT = 370
         ASSIGN 370 TO KRETRN
         GO TO 700
C
  370    CONTINUE
C        ... START NEW RUN OF BLACKS
         IRUNCT = IRUNCT + 8
         GO TO 499
C
  400    CONTINUE
C        ... COMES HERE IF WE HAVE TO EXAMINE EACH DIBYTE OF
C        ...   32-BIT WORD
         DO  488 IDIB = 1,8
           ITTPRE = ITT
C ...      ... IRITSH = 32 - 4*IDIB
C ...      ... ILEFSH = -IRITSH
C ...      ... IACC = ISHFT(MQ,ILEFSH)
C ...      ... REPLACING ABOVE SHIFT TO AVOID EXTERNAL CALL ...
           GO TO (411,412,413,414,415,416,417,418),IDIB
  411      IACC = ISHFT(MQ,-28)
           GO TO 420
  412      IACC = ISHFT(MQ,-24)
           GO TO 420
  413      IACC = ISHFT(MQ,-20)
           GO TO 420
  414      IACC = ISHFT(MQ,-16)
           GO TO 420
  415      IACC = ISHFT(MQ,-12)
           GO TO 420
  416      IACC = ISHFT(MQ,-8)
           GO TO 420
  417      IACC = ISHFT(MQ,-4)
           GO TO 420
  418      IACC = MQ
           GO TO 420
  420      CONTINUE
C
C
           IACC = IAND(IACC,MSKLO4)
           IDIBYT = IACC
C
           IF(IDIBYT .NE. 0) GO TO 440
C          ... OTHERWISE, THIS IS A RUN OF 1-DIBYTE OF ZEROS
           ITT = 00
           IF(ITTPRE .NE. 1) GO TO 430
C
C          ... PREVIOUS TYPE WAS RUNNING BLACKS, SO CLOSE THAT OFF
           LCKPT = 430
           ASSIGN 430 TO KRETRN
           GO TO 700
C
  430      CONTINUE
C          ... START NEW RUN OF WHITES
           IRUNCT = IRUNCT + 1
           GO TO 488
C
  440      CONTINUE
           IF(IDIBYT .NE. KDIBLK) GO TO 470
C          ... OTHERWISE, THIS IS RUN OF 1-DIBYTE OF BLACK
           ITT = 01
           IF(ITTPRE .NE. 0) GO TO 460
C          ... PREVIOUS TYPE=00, SO CLOSE RUN OF WHITES FIRST
           LCKPT = 460
           ASSIGN 460 TO KRETRN
           GO TO 700
C
  460      CONTINUE
C          ... START NEW RUN OF BLACKS
           IRUNCT = IRUNCT + 1
           GO TO 488
C
  470      CONTINUE
C          ... CURRENT TYPE IS "AS-IS"
           ITT = 2
           IF(IRUNCT .LE. 0) GO TO 475
C          ... OTHERWISE, AN ACTIVE RUNNER PRECEDES THIS "AS-IS"
C          ...   SO STOP THE RUNNER
           LCKPT = 475
           ASSIGN 475 TO KRETRN
           GO TO 700
C
  475      CONTINUE
           I4DIBY = IDIBYT
           I4CX = IOR(KASIS,I4DIBY)
           IBY = IBY + 1
           LINEWK(IBY) = CHAR(I4CX)
C
  488    CONTINUE
C
  499  CONTINUE
       GO TO 330
C      ... WHICH USED TO BE BOTTOM OF DO 499 OUTER LOOP ...
  500  CONTINUE
C
C      ... NOW ONE SCAN LINE HAS BEEN CODED INTO LINEWK
C      ... WHEN IT FALLS THRU DO 499 LOOP, WE HAVE REACHED THE
C      ...   END OF THE GIVEN SCAN_LINE.
C      ... IF STILL RUNNING BLACKS AT END, THEN CLOSE IT DOWN;
C      ...   (IGNORE RUNNING WHITES AT END OF SCAN LINE).
       IF(ITT .NE. 1) GO TO 511
C        ... OTHERWISE, STILL RUNNING BLACKS
         ITTPRE = ITT
         LCKPT = 510
         ASSIGN 510 TO KRETRN
         GO TO 700
  510    CONTINUE
  511  CONTINUE
C      ... ADD END-OF-SCANLINE
       IBY = IBY + 1
       LINEWK(IBY) = CEOS
       GO TO 600
C
  600  CONTINUE
C      ... COMES HERE TO MOVE ONE CODED SCANLINE INTO OUTPUT BUFFER
C      ... CHECKOUT PRINT TO DUMP THE ONE PACKED SCANLINE ...
C
       NO8BIT=NO8BIT+IBY
       IF((LOU + IBY) .GT. MAXOUT) GO TO 620
C      ... ELSE THIS SCANLINE WON'T FILL THE BUFFER
       DO  616  I = 1,IBY
         LOU = LOU + 1
         LOUTBF(LOU) = LINEWK(I)
  616  CONTINUE
       GO TO 630
C
  620  CONTINUE
C      ... THIS SCANLINE WILL OVERFLOW THE OUTPUT BUFFER
C      ...   SO TEST EACH BYTE
       DO  628  II = 1,IBY
         IF((LOU+1) .LE. MAXOUT) GO TO 625
C          ... OTHERWISE, OUTPUT BUFFER IS FULL ALREADY, SO WRITE IT
           WRITE(KOUTUN,ERR=900) IOUTBF
C 623      FORMAT(180A8)
C
           NBUFS = NBUFS + 1
           LOU = 0
  625    CONTINUE
C
         LOU = LOU + 1
         LOUTBF(LOU) = LINEWK(II)
  628  CONTINUE
       GO TO 630
C
  630  CONTINUE
C      ... ONE SCANLINE IN LINEWK HAS BEEN MOVED TO LOUTBF
       IBY = 0
       IF(ILASTQ .EQ. 0) GO TO 999
C      ... OTHERWISE, END-OF-MAP WAS PUT INTO LOUTBF,
C      ...   SO CLEAN UP.
       IF(LOU .GE. MAXOUT) GO TO 634
C      ... OTHERWISE, ZERO OUT REMAINING BYTES OF LOUTBF
         I4CX = 0
         M1 = LOU+1
         DO  633  L = M1,MAXOUT
           LOUTBF(L) = CHAR(I4CX)
  633    CONTINUE
  634  CONTINUE
C
       WRITE(KOUTUN,ERR=900) IOUTBF
C
       WRITE(6,635)
  635  FORMAT(1H ,'PAKRAS:CLEANED UP BUFFER AT END-OF-MAP')
       NBUFS = NBUFS + 1
       IFRSTQ = 1
       IRETN = 1
       GO TO 999
C
C
C
  700  CONTINUE
C      ... COMES HERE TO SHUT OFF A RUN
C      ... ITTPRE CONTAINS TYPE OF RUN
C      ... IRUNCT CONTAINS COUNT OF DIBYTES
C
       NDIBS = IRUNCT
       IF(NDIBS .LE. 0) GO TO 777
       IF(NDIBS .GT. MXRUNC) NDIBS = MXRUNC
       IBORW = 0
       IF(ITTPRE .NE. 0) IBORW = KBKRUN
       NDIGM2 = 1
       IF(NDIBS .LT. 16) GO TO 750
       NDIGM2 = 2
       IF(NDIBS .LT. 256) GO TO 750
C      ... OTHERWISE, NDIBS IS .GE. 256, SO ...
       NDIGM2 = 3
  750  CONTINUE
       N4DIBS = NDIBS
       I4BORW = IBORW
       DO  755 IHEX = 1,NDIGM2
         I4CX = IAND(N4DIBS,MSKLO4)
         I4CX = IOR(I4BORW,I4CX)
         IBY = IBY + 1
         LINEWK(IBY) = CHAR(I4CX)
         N4DIBS = ISHFT(N4DIBS,-4)
  755  CONTINUE
C
  777  CONTINUE
C
       IRUNCT = 0
       GO TO KRETRN,(340,370,430,460,475,510)
C
C
  900  CONTINUE
C      ... COMES HERE IF ERR DURING WRITE
       print *, ' write abend in subr pack8b'
       IRETN = 2
C      GO TO 999
C
  999  CONTINUE
       RETURN
       END
