1!Program to test EXPONENT and FRACTION intrinsic function. 2 3program test_exponent_fraction 4 real x 5 integer*4 i 6 real*8 y 7 integer*8 j 8 equivalence (x, i), (y, j) 9 10 x = 3. 11 call test_4(x) 12 13 x = 0. 14 call test_4(x) 15 16 i = o'00000000001' 17 call test_4(x) 18 19 i = o'00010000000' 20 call test_4(x) 21 22 i = o'17700000000' 23 call test_4(x) 24 25 i = o'00004000001' 26 call test_4(x) 27 28 i = o'17737777777' 29 call test_4(x) 30 31 i = o'10000000000' 32 call test_4(x) 33 34 i = o'0000010000' 35 call test_4(x) 36 37 y = 0.5 38 call test_8(y) 39 40 y = 0. 41 call test_8(y) 42 43 j = o'00000000001' 44 call test_8(y) 45 46 y = 0.2938735877D-38 47 call test_8(y) 48 49 y = -1.469369D-39 50 call test_8(y) 51 52 y = z'7fe00000' 53 call test_8(y) 54 55 y = -5.739719D+42 56 call test_8(y) 57end 58 59subroutine test_4(x) 60real*4 x,y 61integer z 62y = fraction (x) 63z = exponent(x) 64if (z .gt. 0) then 65 y = (y * 2.) * (2. ** (z - 1)) 66else 67 y = (y / 2.) * (2. ** (z + 1)) 68end if 69if (abs (x - y) .gt. spacing (max (abs (x), abs (y)))) call abort() 70end 71 72subroutine test_8(x) 73real*8 x, y 74integer z 75y = fraction (x) 76z = exponent(x) 77if (z .gt. 0) then 78 y = (y * 2._8) * (2._8 ** (z - 1)) 79else 80 y = (y / 2._8) * (2._8 ** (z + 1)) 81end if 82if (abs (x - y) .gt. spacing (max (abs (x), abs(y)))) call abort() 83end 84 85