PROGRAM zrsdqi
************************************************************************
*     (IEEE 754 signed zero test)
*     Check whether IEEE 754 signed zero is properly supported.
*     (25-May-2001)
************************************************************************
*
      INTEGER is(1), id(2), iq(4), top
*
      REAL S
      DOUBLE PRECISION D
      REAL*16 Q
*
      EQUIVALENCE (s,is(1))
      EQUIVALENCE (d,id(1))
      EQUIVALENCE (q,iq(1))
*
      CHARACTER*30  esign, eunsgn
*
      PRINT *,' '
*
*************************************************************************
*
      PRINT *,' '
      PRINT *,'Zero handling in single-precision IEEE 754 arithmetic:'
*
      top = 1
*
      s = 0.0E+00
      PRINT *,'+zero is ',eunsgn(is(top))
*
      s = -0.0E+00
      PRINT *,'-zero is ',esign(is(top))
*
      s = 0.0E+00 - 0.0E+00
      PRINT *,'0 - 0 is ',eunsgn(is(top))
*
      s = (-0.0E+00) - 0.0E+00
      PRINT *,'(-0) - (+0)',esign(is(top))
*
      s = 0.0E+00
      s = s * 1.0E+00
      PRINT *,'(+1)*(0) is ',eunsgn(is(top))
*
      s = 0.0E+00
      s = s * (-1.0E+00)
      PRINT *,'(-1)*(0) is ',esign(is(top))
*
************************************************************************
*
      PRINT *,' '
      PRINT *,'Zero handling in double-precision IEEE 754 arithmetic:'
*
      d = 1.0D+00
      IF (id(1) .EQ. 0) THEN
           top = 2
      ELSE
           top = 1
      END IF
*
      d = 0.0D+00
      PRINT *,'+zero is ',eunsgn(id(top))
*
      d = -0.0D+00
      PRINT *,'-zero is ',esign(id(top))
*
      d = 0.0D+00 - 0.0D+00
      PRINT *,'0 - 0 is ',eunsgn(id(top))
*
      d = (-0.0D+00) - 0.0D+00
      PRINT *,'(-0) - (+0)',esign(id(top))
*
      d = 0.0D+00
      d = d * 1.0D+00
      PRINT *,'(+1)*(0) is ',eunsgn(id(top))
*
      d = 0.0D+00
      d = d * (-1.0D+00)
      PRINT *,'(-1)*(0) is ',esign(id(top))
*
************************************************************************
*
      PRINT *,' '
      PRINT *,
     X    'Zero handling in quadruple-precision IEEE 754 arithmetic:'
*
      q = 1.0Q+00
      IF (id(1) .EQ. 0) THEN
           top = 4
      ELSE
           top = 1
      END IF
*
      q = 0.0Q+00
      PRINT *,'+zero is ',eunsgn(iq(top))
*
      q = -0.0Q+00
      PRINT *,'-zero is ',esign(iq(top))
*
      q = 0.0Q+00 - 0.0Q+00
      PRINT *,'0 - 0 is ',eunsgn(iq(top))
*
      q = (-0.0Q+00) - 0.0Q+00
      PRINT *,'(-0) - (+0)',esign(iq(top))
*
      q = 0.0Q+00
      q = q * 1.0Q+00
      PRINT *,'(+1)*(0) is ',eunsgn(iq(top))
*
      q = 0.0Q+00
      q = q * (-1.0Q+00)
      PRINT *,'(-1)*(0) is ',esign(iq(top))
*
      END

      CHARACTER*30 FUNCTION esign(n)
      INTEGER n,nb,top
      INTEGER*1 b(4)
      equivalence (nb,b(1))
      nb = 1
      IF (b(1) .eq. 1) THEN
          top = 4
      ELSE
          top = 1
      ENDIF
      nb = n
      IF (b(top) .eq. z'80') THEN
          esign = '  signed		(CORRECT)'
      ELSE
          esign = 'unsigned		(WRONG)'
      END IF
      END

      CHARACTER*30 FUNCTION eunsgn(n)
      INTEGER n,nb,top
      INTEGER*1 b(4)
      equivalence (nb,b(1))
      nb = 1
      IF (b(1) .eq. 1) THEN
          top = 4
      ELSE
          top = 1
      ENDIF
      nb = n
      IF (b(top) .eq. z'00') THEN
          eunsgn = 'unsigned		(CORRECT)'
      ELSE
          eunsgn = '  signed		(WRONG)'
      END IF
      END