hwrf-baseline-20120103-1354/ungrib/src/ngl/w3/w3fi76.f

   1       SUBROUTINE W3FI76(PVAL,KEXP,KMANT,KBITS)
   2 C$$$  SUBPROGRAM DOCUMENTATION BLOCK
   3 C                .      .    .                                       .
   4 C SUBPROGRAM:  W3FI76        CONVERT TO IBM370 FLOATING POINT
   5 C   PRGMMR: REJONES          ORG: NMC421      DATE:92-11-16
   6 C
   7 C ABSTRACT: CONVERTS FLOATING POINT NUMBER FROM MACHINE
   8 C   REPRESENTATION TO GRIB REPRESENTATION (IBM370 32 BIT F.P.).
   9 C
  10 C PROGRAM HISTORY LOG:
  11 C   85-09-15  JOHN HENNESSY  ECMWF
  12 C   92-09-23  JONES R. E.    CHANGE NAME, ADD DOC BLOCK
  13 C   93-10-27  JONES,R. E.    CHANGE TO AGREE WITH HENNESSY CHANGES
  14 C   95-10-31  IREDELL        REMOVED SAVES AND PRINTS
  15 C   98-03-10  B. VUONG       REMOVE THE CDIR$ INTEGER=64 DIRECTIVE
  16 C
  17 C USAGE:    CALL W3FI76 (FVAL, KEXP, KMANT, NBITS)
  18 C   INPUT ARGUMENT LIST:
  19 C     PVAL     - FLOATING POINT NUMBER TO BE CONVERTED
  20 C     KBITS    - NUMBER OF BITS IN COMPUTER WORD (32 OR 64)
  21 C
  22 C   OUTPUT ARGUMENT LIST:
  23 C     KEXP     -  8 BIT SIGNED EXPONENT
  24 C     KMANT    - 24 BIT  MANTISSA  (FRACTION)
  25 C
  26 C REMARKS: SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT.
  27 C
  28 C ATTRIBUTES:
  29 C   LANGUAGE: IBM370 VS FORTRAN 77, CRAY CFT77 FORTRAN
  30 C   MACHINE:  HDS 9000, CRAY Y-MP8/864< CRAY Y-MP EL2/256
  31 C
  32 C$$$
  33 C
  34 C********************************************************************
  35 C*
  36 C*    NAME      : CONFP3
  37 C*
  38 C*    FUNCTION  : CONVERT FLOATING POINT NUMBER FROM MACHINE
  39 C*                REPRESENTATION TO GRIB REPRESENTATION.
  40 C*
  41 C*    INPUT     : PVAL  - FLOATING POINT NUMBER TO BE CONVERTED.
  42 C*    KBITS     : KBITS - NUMBER OF BITS IN COMPUTER WORD
  43 C*
  44 C*    OUTPUT    : KEXP  - 8 BIT SIGNED EXPONENT
  45 C*                KMANT - 24 BIT MANTISSA
  46 C*                PVAL  - UNCHANGED.
  47 C*
  48 C*    JOHN HENNESSY , ECMWF   18.06.91
  49 C*
  50 C********************************************************************
  51 C
  52 C
  53 C     IMPLICIT NONE
  54 C
  55       INTEGER IEXP
  56       INTEGER ISIGN
  57 C
  58       INTEGER KBITS
  59       INTEGER KEXP
  60       INTEGER KMANT
  61 C
  62       REAL PVAL
  63       REAL ZEPS
  64       REAL ZREF
  65 C
  66 C     TEST FOR FLOATING POINT ZERO
  67 C
  68       IF (PVAL.EQ.0.0) THEN
  69         KEXP  = 0
  70         KMANT = 0
  71         GO TO 900
  72       ENDIF
  73 C
  74 C     SET ZEPS TO 1.0E-12 FOR 64 BIT COMPUTERS (CRAY)
  75 C     SET ZEPS TO 1.0E-8  FOR 32 BIT COMPUTERS
  76 C
  77       IF (KBITS.EQ.32) THEN
  78         ZEPS = 1.0E-8
  79       ELSE
  80         ZEPS = 1.0E-12
  81       ENDIF
  82       ZREF = PVAL
  83 C
  84 C     SIGN OF VALUE
  85 C
  86       ISIGN = 0
  87       IF (ZREF.LT.0.0) THEN
  88         ISIGN =   128
  89         ZREF    = - ZREF
  90       ENDIF
  91 C
  92 C     EXPONENT
  93 C
  94       IEXP = INT(ALOG(ZREF)*(1.0/ALOG(16.0))+64.0+1.0+ZEPS)
  95 C
  96       IF (IEXP.LT.0  ) IEXP = 0
  97       IF (IEXP.GT.127) IEXP = 127
  98 C
  99 C     MANTISSA
 100 C
 101 C     CLOSEST NUMBER IN GRIB FORMAT TO ORIGINAL NUMBER
 102 C     (EQUAL TO, GREATER THAN OR LESS THAN ORIGINAL NUMBER).
 103 C
 104       KMANT = NINT (ZREF/16.0**(IEXP-70))
 105 C
 106 C     CHECK THAT MANTISSA VALUE DOES NOT EXCEED 24 BITS
 107 C     16777215 = 2**24 - 1
 108 C
 109       IF (KMANT.GT.16777215) THEN
 110          IEXP  = IEXP + 1
 111 C
 112 C     CLOSEST NUMBER IN GRIB FORMAT TO ORIGINAL NUMBER
 113 C     (EQUAL TO, GREATER THAN OR LESS THAN ORIGINAL NUMBER).
 114 C
 115          KMANT = NINT (ZREF/16.0**(IEXP-70))
 116 C
 117 C        CHECK MANTISSA VALUE DOES NOT EXCEED 24 BITS AGAIN
 118 C
 119          IF (KMANT.GT.16777215) THEN
 120            PRINT *,'BAD MANTISSA VALUE FOR PVAL = ',PVAL
 121          ENDIF
 122       ENDIF
 123 C
 124 C     ADD SIGN BIT TO EXPONENT.
 125 C
 126       KEXP = IEXP + ISIGN
 127 C
 128   900 CONTINUE
 129 C
 130       RETURN
 131       END