MINICERN/packlib/zebra/fq/fzocxfd.inc

   1 *
   2 * $Id$
   3 *
   4 * $Log$
   5 * Revision 1.1.1.1  1996/03/06 10:47:10  mclareni
   6 * Zebra
   7 *
   8 *
   9 *   cv double-pr. F from CRAY -> IEEE
  10 *
  11 * fzocxfd.inc
  12 *
  13 #if defined(CERNLIB_QMCRY)
  14 C--      Cray single-pr. to IEEE double, ignoring 2nd word
  15 C-                   for the moment (loss of 5 bits)
  16       DO 449  JL=1,NWDODB,2
  17       ITHA = MS(JMS+1)
  18       IF (ITHA.EQ.0)               GO TO 442
  19       JSIGN = SHIFTR (MASK(1).AND.ITHA, 32)
  20       JEXP  = SHIFTR (SHIFTL(ITHA,1), 49)
  21       JEXP  = JEXP - 40000B + 1022
  22       IF (JEXP.LE.0)               GO TO 441
  23       IF (JEXP.GE.2047)            GO TO 433
  24       JMANT = MASK(128-20) .AND. SHIFTR (ITHA,27)
  25       ITHB  = SHIFTL (ITHA, 5) .AND. 37777777777B
  26       ITHA  = JSIGN .OR. SHIFTL(JEXP,20) .OR. JMANT
  27       GO TO 447
  28
  29 C--      overflow
  30   433 IFOCON(1) = 4
  31       IFOCON(2) = JMS
  32       IFOCON(3) = ITHA
  33       IF (JSIGN.EQ.0)    THEN
  34           ITHA = IOVPCD
  35         ELSE
  36           ITHA = IOVNCD
  37         ENDIF
  38       GO TO 442
  39
  40   441 ITHA = 0
  41   442 ITHB = 0
  42   447 MT(JMT+1) = ITHA
  43       MT(JMT+2) = ITHB
  44       JMT = JMT + 2
  45   449 JMS = JMS + 2
  46 #endif
  47 *   cv double-pr. F from ND -> IEEE
  48 *
  49 * fzocxfd.inc
  50 *
  51 #if defined(CERNLIB_QMND3)
  52 C--      NORD double-precision to IEEE double
  53       DO 449  JL=1,NWDODB,2
  54       ITHA = MS(JMS+1)
  55       IF (ITHA.EQ.0)               GO TO 442
  56       ITHB  = MS(JMS+2)
  57       JSIGN = ISHFT (ITHA,-31)
  58       JEXP  = ISHFT (ISHFT(ITHA,1), -23)
  59       IF (JEXP.EQ.0)               GO TO 441
  60       IF (JEXP.EQ.511)             GO TO 433
  61       JMANT = ISHFT (ISHFT(ITHA,10), -12)
  62       ITHB  = ISHFT (ITHA,30) .OR. ISHFT (ITHB,-2)
  63       ITHA  = ISHFT(JSIGN,31) .OR. ISHFT(JEXP+766,20) .OR. JMANT
  64       GO TO 447
  65
  66 C--      overflow / NaN
  67   433 IFOCON(1) = 4
  68       IFOCON(2) = JMS
  69       IFOCON(3) = ITHA
  70       IF (ITHA.NE.IBADMS)  THEN
  71           IF (JSIGN.EQ.0)    THEN
  72               ITHA = IOVPCD
  73             ELSE
  74               ITHA = IOVNCD
  75             ENDIF
  76         ELSE
  77           ITHA = IBADCD
  78         ENDIF
  79       GO TO 442
  80
  81   441 ITHA = 0
  82   442 ITHB = 0
  83   447 MT(JMT+1) = ITHA
  84       MT(JMT+2) = ITHB
  85       JMT = JMT + 2
  86   449 JMS = JMS + 2
  87 *    --------------  sequences for input   ---------------------
  88 #endif
  89 *   cv double-pr. F from VAX -> IEEE
  90 *
  91 * fzocxfd.inc
  92 *
  93 #if defined(CERNLIB_QMVAX)
  94 C--      VAX double-precision to IEEE double
  95       DO 449  JL=1,NWDODB,2
  96       ITHA = MS(JMS+1)
  97       IF (ITHA.EQ.0)               GO TO 442
  98       ITHB  = MS(JMS+2)
  99       JSIGN = ITHA .AND. MSKB16
 100       JEXP  = JIBITS (ITHA,7,8)
 101       IF (JEXP.EQ.0)               GO TO 431
 102       IF (JEXP.EQ.255)             GO TO 433
 103       JMANT = JISHFT (JIBITS(ITHA, 0, 7), 13) .OR. JIBITS(ITHA,19,13)
 104       ITHB  = JISHFT (JIBITS(ITHA,16, 3), 29) .OR.
 105      +        JISHFT (JIBITS(ITHB, 0,16), 13) .OR.
 106      +                JIBITS(ITHB,19,13)
 107       ITHA  = JISHFT(JSIGN,16) .OR. JISHFT(JEXP+894,20) .OR. JMANT
 108       GO TO 447
 109
 110 C--      zero / NaN
 111   431 IF (JSIGN.EQ.0)              GO TO 441
 112       ITHB = IBADCD
 113       GO TO 436
 114
 115 C--      overflow
 116   433 IF (JSIGN.EQ.0)    THEN
 117           ITHB = IOVPCD
 118         ELSE
 119           ITHB = IOVNCD
 120         ENDIF
 121   436 IFOCON(1) = 4
 122       IFOCON(2) = JMS
 123       IFOCON(3) = ITHA
 124       ITHA = ITHB
 125       GO TO 442
 126
 127   441 ITHA = 0
 128   442 ITHB = 0
 129   447 MT(JMT+1) = ITHA
 130       MT(JMT+2) = ITHB
 131       JMT = JMT + 2
 132   449 JMS = JMS + 2
 133 #endif