q9ie32.f

Go to the documentation of this file.

C> @file
C> @brief Convert IBM370 F.P. to IEEE F.P.
C> @author Ralph Jones @date 1990-06-04
 
C> Convert ibm370 32 bit floating point numbers to ieee
C> 32 bit task 754 floating point numbers.
C>
C> Program history log:
C> - Ralph Jones 1990-06-04 Change to sun fortran 1.3
C> - Ralph Jones 1990-07-14 Change ishft to lshift or lrshft
C> - Ralph Jones 1991-03-09 Change to silicongraphics fortran
C> - Ralph Jones 1992-07-20 Change to ibm aix xl fortran
C> - Ralph Jones 1995-11-15 Add save statement
C> - Stephen Gilbert 1998-11-15 Specified 4-byte integers for IBM SP
C>
C> @param[in] A REAL*4 Array of ibm370 32 bit floating point numbers.
C> @param[out] N Number of points to convert.
C> @param[out] B REAL*4 Array of ieee 32 bit floating point numbers.
C> @param[out] ISTAT Number of point greater than 10e+38, numbers are set to
c> ieee infinity, one is added to istat. Numbers less than
c> e-38 are set to zero, one is  not added to istat.
C>
C> @note See ieee task 754 standard floating point arithmetic
C> for more information about IEEE F.P.
C>
C> @author Ralph Jones @date 1990-06-04
      SUBROUTINE q9ie32(A,B,N,ISTAT)
C
       INTEGER(4)      A(*)
       INTEGER(4)      B(*)
       INTEGER(4)      SIGN
       INTEGER(4) INFIN,MASKFR,MASKSN,MASK21,MASK22,MASK23
       INTEGER(4) ITEMP,ISIGN,IEEEXP,K,LTEMP
C
       SAVE
C
       DATA  infin /z'7F800000'/
       DATA  maskfr/z'007FFFFF'/
       DATA  masksn/z'7FFFFFFF'/
       DATA  mask21/z'00200000'/
       DATA  mask22/z'00400000'/
       DATA  mask23/z'00800000'/
       DATA  sign  /z'80000000'/
C
           IF (n.LT.1) THEN
             istat = -1
             RETURN
           ENDIF
C
           istat = 0
C
         DO 40 i = 1,n
           isign = 0
           itemp = a(i)
C
C          TEST SIGN BIT
C
           IF (itemp.EQ.0) GO TO 30
C
           IF (itemp.LT.0) THEN
C
             isign = sign
C
C            SET SIGN BIT TO ZERO
C
             itemp = iand(itemp,masksn)
C
           END IF
C
C
C          CONVERT IBM EXPONENT TO IEEE EXPONENT
C
           ieeexp = (ishft(itemp,-24_4) - 64_4) * 4 + 126
C
           k = 0
C
C          TEST BIT 23, 22, 21
C          ADD UP NUMBER OF ZERO BITS IN FRONT OF IBM370 FRACTION
C
           IF (iand(itemp,mask23).NE.0) GO TO 10
           k = k + 1
           IF (iand(itemp,mask22).NE.0) GO TO 10
           k = k + 1
           IF (iand(itemp,mask21).NE.0) GO TO 10
           k = k + 1
C
 10      CONTINUE
C
C          SUBTRACT ZERO BITS FROM EXPONENT
C
           ieeexp = ieeexp - k
C
C          TEST FOR OVERFLOW
C
           IF (ieeexp.GT.254) GO TO 20
C
C          TEST FOR UNDERFLOW
C
           IF (ieeexp.LT.1) GO TO 30
C
C          SHIFT IEEE EXPONENT TO BITS 1 TO 8
C
           ltemp = ishft(ieeexp,23_4)
C
C          SHIFT IBM370 FRACTION LEFT K BIT, AND OUT BITS 0 - 8
C          OR TOGETHER THE EXPONENT AND THE FRACTION
C          OR IN SIGN BIT
C
           b(i)  = ior(ior(iand(ishft(itemp,k),maskfr),ltemp),isign)
C
           GO TO 40
C
 20      CONTINUE
C
C          OVERFLOW , SET TO IEEE INFINITY, ADD 1 TO OVERFLOW COUNTER
C
           istat  = istat + 1
           b(i)   = ior(infin,isign)
           GO TO 40
C
 30      CONTINUE
C
C          UNDERFLOW , SET TO ZERO
C
           b(i)   =  0
C
 40      CONTINUE
C
         RETURN
       END