PROGRAM zrsdqb ************************************************************************ * (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 *,'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 BYTE 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 BYTE 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