*
* $Id$
*
* $Log$
* Revision 1.1  1996/02/15 17:52:29  mclareni
* Initial revision
*
*
#include "sys/CERNLIB_machine.h"
#include "pilot.h"
      PROGRAM TEST

C--       converted values = IEEE
      INTEGER*8     IOVPCD, IOVNCD, IBADCD, IONECD, IZERCD
      PARAMETER    (IOVPCD = '7FF0000000000000'X)
      PARAMETER    (IOVNCD = 'FFF0000000000000'X)
      PARAMETER    (IBADCD = '7FF01FC000000000'X)
      PARAMETER    (IONECD = '3FF0000000000000'X)
      PARAMETER    (IZERCD = '8000000000000000'X)

C--       machine values = native
      INTEGER*8     IOVPMD, IOVNMD, IBADMD
      PARAMETER    (IOVPMD = '7FF7FFFFFFFFFFFF'X)
      PARAMETER    (IOVNMD = 'FFF7FFFFFFFFFFFF'X)
      PARAMETER    (IBADMD = '80007FFFFFFFFFFF'X)

      INTEGER*8     MSKSIG, MSK32R
      PARAMETER    (MSKSIG = 'FFFFFFFFFFFFFFF0'X)
      PARAMETER    (MSK32R = '00000000FFFFFFFF'X)

      PARAMETER    (NEL = 328)
      PARAMETER    (NED = 2*NEL)

      REAL*8        ORG(NEL), ORGPR(NEL)
      INTEGER*8    IORG(NEL)
      EQUIVALENCE (IORG,ORG)

      REAL*8        TONEW(NEL), FRNEW(NEL)
      INTEGER*8    ITONEW(NEL),IFRNEW(NEL)
      EQUIVALENCE (ITONEW,TONEW)
      EQUIVALENCE (IFRNEW,FRNEW)

      CHARACTER    CBADTO(NEL)*5,  CBADFR(NEL)*5,  CNOTE(NEL)*20

      CHARACTER    CHPG*1
      CHARACTER    CHDATE*8, CHTIME*8
      DIMENSION    MDATE(2), MTIME(2)
      EQUIVALENCE (CHDATE,MDATE), (CHTIME,MTIME)

      INTEGER*4    NEXP(NEL)
      REAL*8       VAL, VALU, FACT
      DIMENSION    MTRANA(NED), MTRANB(NED)

      INTEGER*8    MSPEC(5), MIEEE(5)

C--                Test top of range
      DATA  MSPEC(1)   / '7FBFFFFFFFFFFFFF'X /
      DATA  MSPEC(2)   / '7FCFFFFFFFFFFFFF'X /
      DATA  MSPEC(3)   / '7FDFFFFFFFFFFFFF'X /
      DATA  MSPEC(4)   / '7FEFFFFFFFFFFFFF'X /
C--                Special cases
      DATA  MSPEC(5)   / 'C000000000000000'X /

C--                Test top of range
      DATA  MIEEE(1)   / '7FE7777777777777'X /
      DATA  MIEEE(2)   / '7FE0000077777777'X /
C--                Test bottom of range
      DATA  MIEEE(3)   / '0010000100000000'X /
      DATA  MIEEE(4)   / '0001000000000000'X /
      DATA  MIEEE(5)   / '8000000000000000'X /


#if defined(CERNLIB_QMCV64)
      OPEN (6,FILE='tie3d_64.lis',STATUS='UNKNOWN')
 9001 FORMAT ('1Program TIEEED 64-bit executing'/1X)
#endif
#if defined(CERNLIB_QMCV32)
      OPEN (6,FILE='tie3d_32.lis',STATUS='UNKNOWN')
 9001 FORMAT ('1Program TIEEED 32-bit executing'/1X)
#endif

      ITER = 0
   12 WRITE (6,9001)

      DO  13  J=1,NEL
      CBADTO(J) = ' '
      CBADFR(J) = ' '
   13 CNOTE(J)  = ' '
      JWHICH = 0

      FACT = 2.**60
      VAL  = 17.123456789012D0
      VAL  = VAL * FACT

      DO 14 I=1,NEL
      FACT = 1.0D0 + FLOAT(I) * 0.00001D0
      VALU = VAL * FACT
      IF (ITER.EQ.0)  THEN
          ORG(I)=  VALU
        ELSE
          ORG(I)= -VALU
        ENDIF
      VAL = VAL/2.
   14 CONTINUE

C--                Special values

      CNOTE(32) = '-> high CVX range'
      IORG(32) = MSPEC(1)
      IORG(33) = MSPEC(2)
      IORG(34) = MSPEC(3)
      IORG(35) = MSPEC(4)
      CBADTO(32)(4:4) = '!'
      CBADTO(33)(4:4) = '!'
      CBADTO(34)(4:4) = '!'
      CBADTO(35)(4:4) = '!'

      CNOTE(71) = '-> exact 1.0'
       ORG(71) = 1.0D0
       ORG(72) = 1.0D0
      CBADTO(71)(4:4) = '!'
      CBADTO(72)(4:4) = '!'

      CNOTE(97) = '-> NaN'
      IORG(97) = IBADMD
      CBADTO(97)(4:4) = '!'

      CNOTE(144) = '-> +ve overflow'
      IORG(144) = IOVPMD
      CBADTO(144)(4:4) = '!'

      CNOTE(184) = '-> -ve overflow'
      IORG(184) = IOVNMD
      CBADTO(184)(4:4) = '!'

      CNOTE(161) = '-> test zero'
      IORG(161) = 0
      IORG(162) = 0
      CBADTO(161)(4:4) = '!'

#if defined(CERNLIB_QMCV64)
      CALL UCOPY (ORG,ORGPR,NEL)
#endif
#if defined(CERNLIB_QMCV32)
      CALL UCOPY (ORG,ORGPR,NED)
#endif

C----              'Writing'

      NDN  = 0
      NUSE = 0
   42 NUSE = NUSE + 1
      IF (NUSE.EQ.11)  NUSE = 41
      NWDS = MIN (NEL-NDN,NUSE)
      CBADTO(NDN+1)(1:1) = '.'

      CALL VZERO (MTRANA,NED)
#if defined(CERNLIB_QMCV64)
      CALL UCOCOP (IORG(NDN+1),MTRANA,NWDS,1,1,2)
#endif
#if defined(CERNLIB_QMCV32)
      CALL UCOPY  (IORG(NDN+1),MTRANA,2*NWDS)
#endif
      MTRANB(2*NWDS+1) = 77
      CALL IE3FOD (MTRANA,MTRANB,NWDS,JBAD)
      IF (JBAD.LT.0 .OR. JBAD.GT.NWDS)      GO TO 82
      IF (JBAD.NE.0)  CBADTO(NDN+JBAD)(3:3) = 't'
      IF (MTRANB(2*NWDS+1).NE.77)   GO TO 91

#if defined(CERNLIB_QMCV64)
      JTAK = 1
      JPUT = NDN + 1
      DO 44  J=1,NWDS
      ITONEW(JPUT) = ISHFT (MTRANB(JTAK),32) .OR. MTRANB(JTAK+1)
      JTAK = JTAK + 2
   44 JPUT = JPUT + 1
#endif
#if defined(CERNLIB_QMCV32)
      CALL UCOPY (MTRANB,ITONEW(NDN+1),2*NWDS)
#endif

      NDN = NDN + NWDS
      IF (NDN.LT.NEL)              GO TO 42

C--                Special values

      CNOTE(51) = '<- +ve overflow'
      CNOTE(52) = '<- -ve overflow'
      ITONEW(51)  = IOVPCD
      ITONEW(52)  = IOVNCD
      CBADTO(51)(4:4) = ':'
      CBADTO(52)(4:4) = ':'

      CNOTE(61) = '<- NaN'
      ITONEW(61)  = IBADCD
      CBADTO(61)(4:4) = ':'

      CNOTE(72) = '<- exact 1.0'
      ITONEW(72) = IONECD
      CBADTO(72)(4:4) = ':'

      CNOTE(81) = '<- high IEEE range'
      ITONEW(81)  = MIEEE(1)
      ITONEW(82)  = MIEEE(2)
      CBADTO(81)(4:4) = ':'
      CBADTO(82)(4:4) = ':'

      CNOTE(85) = '<- low IEEE range'
      ITONEW(85)  = MIEEE(3)
      ITONEW(86)  = MIEEE(4)
      CBADTO(85)(4:4) = ':'
      CBADTO(86)(4:4) = ':'

      CNOTE(162) = '<- test -0.0'
      ITONEW(162) = IZERCD
      CBADTO(162)(4:4) = ':'

C----              'reading'

      NDN  = 0
      NUSE = 0
   52 NUSE = NUSE + 1
      IF (NUSE.EQ.11)  NUSE = 41
      NWDS = MIN (NEL-NDN,NUSE)

      CALL VZERO (MTRANA,NED)
#if defined(CERNLIB_QMCV64)
      JTAK = NDN + 1
      JPUT = 0
      DO 54  J=1,NWDS
      MTRANA(JPUT+1) = ISHFT (ITONEW(JTAK),-32)
      MTRANA(JPUT+2) =        ITONEW(JTAK) .AND. MSK32R
      JTAK = JTAK + 1
   54 JPUT = JPUT + 2
#endif
#if defined(CERNLIB_QMCV32)
      CALL UCOPY  (ITONEW(NDN+1),MTRANA,2*NWDS)
#endif
      MTRANB(2*NWDS+1) = 77
      CALL IE3TOD (MTRANA,MTRANB,NWDS,JBAD)
      IF (JBAD.LT.0 .OR. JBAD.GT.NWDS)      GO TO 84
      IF (JBAD.NE.0)  CBADFR(NDN+JBAD)(2:2) = 'f'
      IF (MTRANB(2*NWDS+1).NE.77)   GO TO 92

#if defined(CERNLIB_QMCV64)
      CALL UCOCOP (MTRANB,IFRNEW(NDN+1),NWDS,1,2,1)
#endif
#if defined(CERNLIB_QMCV32)
      CALL UCOPY  (MTRANB,IFRNEW(NDN+1),2*NWDS)
#endif

      NDN = NDN + NWDS
      IF (NDN.LT.NEL)              GO TO 52

C----              Compare and print

      DO 69 I=1,NEL

      IF ((IFRNEW(I).AND.MSKSIG) .NE. (IORG(I).AND.MSKSIG))
     +               CBADFR(I)(4:4) = 'N'

#if defined(CERNLIB_QMCV64)
      NEXP(I) = JBYT (IORG(I),53,11) - 1024
#endif
#if defined(CERNLIB_QMCV32)
      NEXP(I) = JBYT (IORG(I),21,11) - 1024
#endif
   69 CONTINUE

      CHPG = ' '
      IE = 0
   71 N  = MIN (NEL-IE,50)
      IA = IE + 1
      IE = IE + N

      WRITE (6,9071) CHPG
      CHPG = '1'

      WRITE (6,9074)
     +     (I,CBADTO(I),ORGPR(I),NEXP(I),
     +     IORG(I),IFRNEW(I),ITONEW(I),
     +                 CBADFR(I), CNOTE(I),
     +      I=IA,IE)
      IF (IE.LT.NEL)         GO TO 71

 9071 FORMAT (A,'    bad ',13X,
     F'exp',10X,'original',10X,'frnew',13X,'tonew',7X,'flags')
 9074 FORMAT (/I4,A,D11.4,I5,3Z18.16,1X,A,1X,A)

      CALL KERNGT (6)
      CALL DATIMH (MDATE, MTIME)
      WRITE (6,9079) CHDATE,CHTIME
 9079 FORMAT (10X,'Today : ',A,2X,A)

      IF (ITER.NE.0)      STOP
      ITER = 7
      GO TO 12

   84 JWHICH = 1
   83 JWHICH = JWHICH + 1
   82 JWHICH = JWHICH + 1
   81 JWHICH = JWHICH + 1
      WRITE (6,9081) JWHICH
 9081 FORMAT (' Faulty JBAD from',I2)
      STOP

   91 WRITE (6,9091)  NDN,NWDS
 9091 FORMAT (1X/' IE3FOD overshoots for NDN/NWDS =',2I5)
      STOP

   92 WRITE (6,9092)  NDN,NWDS
 9092 FORMAT (1X/' IE3TOD overshoots for NDN/NWDS =',2I5)
      STOP
      END
