gcc/testsuite/gfortran.fortran-torture/execute/specifics.f90

   1 ! Program to test intrinsic functions as actual arguments
   2 subroutine test_r(fn, val, res)
   3   real fn
   4   real val, res
   5
   6   if (diff(fn(val), res)) call abort
   7 contains
   8 function diff(a, b)
   9   real a, b
  10   logical diff
  11   diff = (abs(a - b) .gt. 0.00001)
  12 end function
  13 end subroutine
  14
  15 subroutine test_d(fn, val, res)
  16   double precision fn
  17   double precision val, res
  18
  19   if (diff(fn(val), res)) call abort
  20 contains
  21 function diff(a, b)
  22   double precision a, b
  23   logical diff
  24   diff = (abs(a - b) .gt. 0.00001d0)
  25 end function
  26 end subroutine
  27
  28 subroutine test_r2(fn, val1, val2, res)
  29   real fn
  30   real val1, val2, res
  31
  32   if (diff(fn(val1, val2), res)) call abort
  33 contains
  34 function diff(a, b)
  35   real a, b
  36   logical diff
  37   diff = (abs(a - b) .gt. 0.00001)
  38 end function
  39 end subroutine
  40
  41 subroutine test_d2(fn, val1, val2, res)
  42   double precision fn
  43   double precision val1, val2, res
  44
  45   if (diff(fn(val1, val2), res)) call abort
  46 contains
  47 function diff(a, b)
  48   double precision a, b
  49   logical diff
  50   diff = (abs(a - b) .gt. 0.00001d0)
  51 end function
  52 end subroutine
  53
  54 subroutine test_dprod(fn)
  55   if (abs (fn (2.0, 3.0) - 6d0) .gt. 0.00001) call abort
  56 end subroutine
  57
  58 program specifics
  59   intrinsic abs
  60   intrinsic aint
  61   intrinsic anint
  62   intrinsic acos
  63   intrinsic asin
  64   intrinsic atan
  65   intrinsic cos
  66   intrinsic sin
  67   intrinsic tan
  68   intrinsic cosh
  69   intrinsic sinh
  70   intrinsic tanh
  71   intrinsic alog
  72   intrinsic exp
  73   intrinsic sign
  74   intrinsic amod
  75
  76   intrinsic dabs
  77   intrinsic dint
  78   intrinsic dnint
  79   intrinsic dacos
  80   intrinsic dasin
  81   intrinsic datan
  82   intrinsic dcos
  83   intrinsic dsin
  84   intrinsic dtan
  85   intrinsic dcosh
  86   intrinsic dsinh
  87   intrinsic dtanh
  88   intrinsic dlog
  89   intrinsic dexp
  90   intrinsic dsign
  91   intrinsic dmod
  92
  93   intrinsic dprod
  94
  95   !TODO: Also test complex variants
  96
  97   call test_r (abs, -1.0, abs(-1.0))
  98   call test_r (aint, 1.7, 1.0)
  99   call test_r (anint, 1.7, 2.0)
 100   call test_r (acos, 0.5, acos(0.5))
 101   call test_r (asin, 0.5, asin(0.5))
 102   call test_r (atan, 0.5, atan(0.5))
 103   call test_r (cos, 1.0, cos(1.0))
 104   call test_r (sin, 1.0, sin(1.0))
 105   call test_r (tan, 1.0, tan(1.0))
 106   call test_r (cosh, 1.0, cosh(1.0))
 107   call test_r (sinh, 1.0, sinh(1.0))
 108   call test_r (tanh, 1.0, tanh(1.0))
 109   call test_r (alog, 2.0, alog(2.0))
 110   call test_r (exp, 1.0, exp(1.0))
 111   call test_r2 (sign, 1.0, -2.0, sign(1.0, -2.0))
 112   call test_r2 (amod, 3.5, 2.0, amod(3.5, 2.0))
 113
 114   call test_d (dabs, -1d0, abs(-1d0))
 115   call test_d (dint, 1.7d0, 1d0)
 116   call test_d (dnint, 1.7d0, 2d0)
 117   call test_d (dacos, 0.5d0, dacos(0.5d0))
 118   call test_d (dasin, 0.5d0, dasin(0.5d0))
 119   call test_d (datan, 0.5d0, datan(0.5d0))
 120   call test_d (dcos, 1d0, dcos(1d0))
 121   call test_d (dsin, 1d0, dsin(1d0))
 122   call test_d (dtan, 1d0, dtan(1d0))
 123   call test_d (dcosh, 1d0, dcosh(1d0))
 124   call test_d (dsinh, 1d0, dsinh(1d0))
 125   call test_d (dtanh, 1d0, dtanh(1d0))
 126   call test_d (dlog, 2d0, dlog(2d0))
 127   call test_d (dexp, 1d0, dexp(1d0))
 128   call test_d2 (dsign, 1d0, -2d0, sign(1d0, -2d0))
 129   call test_d2 (dmod, 3.5d0, 2d0, dmod(3.5d0, 2d0))
 130
 131   call test_dprod(dprod)
 132 end program
 133