      SUBROUTINE BF2I64B(IEEEF,BF,NF)
C
C     * JUL 07/03 - A.IRWIN,F.MAJAESS (REVISED FOR F90 AND LINUX PLATFORMS)
C     * APR 15/92 - J. STACEY -
C     *
C     * CONVERT FLOATING POINT, IEEE 64-BIT TO IBM 32-BIT.  THIS ROUTINE
C     * ASSUMES THAT BOTH "BF" AND "IEEEF" ARE 32-BITS IN NATIVE MODE.
C
      IMPLICIT INTEGER (A-Z)
      INTEGER  BF(1),IEEEF(1)
      INTEGER  IZERO
      DIMENSION ZERO(1)
      EQUIVALENCE (ZERO,IZERO)
      LOGICAL  ERROR
      DATA     ZERO/0.0E0/
C-------------------------------------------------------------------
      MBSE0 = 0
      MBSE31 = 31
      MASK1   = IBSET(MBSE0,MBSE31)         !1 BIT MASK FOR SIGN BIT.
      MASK2   = IBITS(-1,0,7)       !7 BIT MASK FOR IBM EXPONENT.
      MASK3   = IBITS(-1,0,20)      !20 BIT MASK FOR IEEE MANTISSA.
      MASK4   = IBITS(-1,0,4)       !4 BIT MASK FOR FIRST HEX DIGIT.
      MASK5   = IBITS(-1,0,11)      !11 BIT MASK FOR IEEE EXPONENT.
      MBSE0 = 0
      MBSE20 = 20
      IMPLIED = IBSET(MBSE0,MBSE20) !IMPLIED ON BIT IN IEEE MANTISSA.
      J       = 1
      DO 100 I=1,2*NF-1,2
        IF (IEEEF(I).NE.0 .OR. IEEEF(I+1).NE.0) THEN
CBUG        IBMEXP = IAND(ISHFT(IEEEF(I),-20),MASK5) - 1023
CBUG        IMOVE  = MOD(IBMEXP,4)
CBUG        IBMEXP = IBMEXP/4 + 64 + 1
C!!!        IBMEXP = IAND(ISHFT(IEEEF(I),-52),MASK5) - 1023 + 1
            MSHFM20 = -20
            IBMEXP = IAND(ISHFT(IEEEF(I),MSHFM20),MASK5) - 1023 + 1
            IMOVE  = MOD(IBMEXP,4)
            IF (IMOVE .LE. 0) THEN
            IMOVE  = IMOVE + 4
            IBMEXP = IBMEXP/4 + 64
            ELSE
            IBMEXP = IBMEXP/4 + 64 + 1
            ENDIF
            MSHF24 = 24
            BF(J) = IOR(IOR(IOR(
     1        IAND(IEEEF(I),MASK1),
     2        ISHFT(IAND(IBMEXP,MASK2),MSHF24)
     3                         ),
     4        ISHFT(IAND(IEEEF(I),MASK3)+IMPLIED,IMOVE-1)
     5                     ),
     6        ISHFT(IEEEF(I+1),-32+IMOVE-1)
     7                 )
        ELSE
            BF(J) = IZERO
        END IF
        J = J + 1
  100 CONTINUE
 
C     * HANDLE 0.0, UNDERFLOW AND OVERFLOW :
C     *
C     * IF THE EXPONENT FIELD GOES NEGATIVE THEN THE IEEE NUMBER WAS
C     * EITHER 0.0 OR TOO SMALL TO REPRESENT IN IBM, IN EITHER CASE
C     * SET THE IBM RESULT TO 0.0.
C     *
C     * IF THE EXPONENT FIELD OVERFLOWS, CALL ABORT.

      ERROR = .FALSE.
      J     = 1
      DO 20 I=1,2*NF-1,2
CBUG      IBMEXP = IAND(ISHFT(IEEEF(I),-20),MASK5) - 1023
CBUG      IBMEXP = IBMEXP/4 + 64 + 1
C!!!      IBMEXP = IAND(ISHFT(IEEEF(I),-52),MASK5) - 1023 + 1
          MSHFM20 = -20
          IBMEXP = IAND(ISHFT(IEEEF(I),MSHFM20),MASK5) - 1023 + 1
          IMOVE  = MOD(IBMEXP,4)
          IF (IMOVE .LE. 0) THEN
            IMOVE  = IMOVE + 4
            IBMEXP = IBMEXP/4 + 64
          ELSE
            IBMEXP = IBMEXP/4 + 64 + 1
          ENDIF
          IF (IBMEXP .LT. 0) THEN
            BF(J) = IZERO
          ELSE IF (IBMEXP .GT. MASK2) THEN
            ERROR = .TRUE.
          END IF
          J = J + 1
20    CONTINUE
 
      IF (.NOT. ERROR) RETURN
      WRITE(6,6100)
 6100 FORMAT('0 *ERROR* BF2I64B: IEEE EXPONENT OUT OF RANGE FOR IBM.')
      CALL ABORT
      END
