MINICERN/packlib/kernlib/kerngen/tcgens/vaxgs/ie3fos.F

   1 *
   2 * $Id$
   3 *
   4 * $Log$
   5 * Revision 1.1.1.1  1996/02/15 17:50:23  mclareni
   6 * Kernlib
   7 *
   8 *
   9       SUBROUTINE IE3FOS (MS,MT,NWDO,JBAD)
  10 C
  11 C CERN PROGLIB# M220    IE3FOS          .VERSION KERNVAX  2.20  861204
  12
  13 C-    Convert single precision for output with copy
  14 C-    from source in native to target in IEEE data format
  15
  16       DIMENSION    MS(99), MT(99)
  17
  18       DOUBLE PRECISION   THDB
  19       DIMENSION    THIS(2)
  20       EQUIVALENCE  (THDB,THIS)
  21       EQUIVALENCE  (ITHA,THA,THIS(1)), (ITHB,THB,THIS(2))
  22
  23       PARAMETER    (MSKB16 = '00008000'X)
  24       PARAMETER    (IBADCS = '7F80FE00'X)
  25       PARAMETER    (IBADCD = '7FF01FC0'X)
  26       PARAMETER    (IOVPCS = '7F800000'X)
  27       PARAMETER    (IOVPCD = '7FF00000'X)
  28       PARAMETER    (IOVNCS = 'FF800000'X)
  29       PARAMETER    (IOVNCD = 'FFF00000'X)
  30
  31
  32       JBAD = 0
  33       JMS  = 0
  34       JMT  = 0
  35
  36   301 DO 349  JL=1,NWDO
  37       ITHA = MS(JMS+1)
  38       IF (ITHA.EQ.0)         GO TO 347
  39       JSIGN = ITHA .AND. MSKB16
  40       JEXP  = JIBITS (ITHA,7,8)
  41       IF (JEXP.LE.2)         GO TO 331
  42       IF (JEXP.EQ.255)       GO TO 333
  43       JMANT = JISHFT(JIBITS(ITHA,0,7), 16) .OR. JIBITS(ITHA,16,16)
  44       ITHA  = JISHFT(JSIGN,16) .OR. JISHFT(JEXP-2,23) .OR. JMANT
  45       GO TO 347
  46
  47 C--      zero / NaN
  48   331 IF (JSIGN.EQ.0)        GO TO 341
  49       IF (JEXP.NE.0)         GO TO 341
  50       ITHB = IBADCS
  51       GO TO 336
  52
  53 C--      overflow
  54   333 IF (JSIGN.EQ.0)    THEN
  55           ITHB = IOVPCS
  56         ELSE
  57           ITHB = IOVNCS
  58         ENDIF
  59   336 JBAD = JL
  60       ITHA = ITHB
  61       GO TO 347
  62
  63   341 ITHA = 0
  64   347 MT(JMT+1) = ITHA
  65       JMT = JMT + 1
  66   349 JMS = JMS + 1
  67
  68       RETURN
  69       END