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

   1 ! Program to test intrinsic functions as actual arguments
   2 !
   3 ! Please keep the content of this file in sync with gfortran.dg/specifics_1.f90
   4 subroutine test_c(fn, val, res)
   5   complex fn
   6   complex val, res
   7
   8   if (diff(fn(val),res)) STOP 1
   9 contains
  10 function diff(a,b)
  11   complex a,b
  12   logical diff
  13   diff = (abs(a - b) .gt. 0.00001)
  14 end function
  15 end subroutine
  16
  17 subroutine test_z(fn, val, res)
  18   double complex fn
  19   double complex val, res
  20
  21   if (diff(fn(val),res)) STOP 2
  22 contains
  23 function diff(a,b)
  24   double complex a,b
  25   logical diff
  26   diff = (abs(a - b) .gt. 0.00001)
  27 end function
  28 end subroutine
  29
  30 subroutine test_cabs(fn, val, res)
  31   real fn, res
  32   complex val
  33
  34   if (diff(fn(val),res)) STOP 3
  35 contains
  36 function diff(a,b)
  37   real a,b
  38   logical diff
  39   diff = (abs(a - b) .gt. 0.00001)
  40 end function
  41 end subroutine
  42
  43 subroutine test_cdabs(fn, val, res)
  44   double precision fn, res
  45   double complex val
  46
  47   if (diff(fn(val),res)) STOP 4
  48 contains
  49 function diff(a,b)
  50   double precision a,b
  51   logical diff
  52   diff = (abs(a - b) .gt. 0.00001)
  53 end function
  54 end subroutine
  55
  56 subroutine test_r(fn, val, res)
  57   real fn
  58   real val, res
  59
  60   if (diff(fn(val), res)) STOP 5
  61 contains
  62 function diff(a, b)
  63   real a, b
  64   logical diff
  65   diff = (abs(a - b) .gt. 0.00001)
  66 end function
  67 end subroutine
  68
  69 subroutine test_d(fn, val, res)
  70   double precision fn
  71   double precision val, res
  72
  73   if (diff(fn(val), res)) STOP 6
  74 contains
  75 function diff(a, b)
  76   double precision a, b
  77   logical diff
  78   diff = (abs(a - b) .gt. 0.00001d0)
  79 end function
  80 end subroutine
  81
  82 subroutine test_r2(fn, val1, val2, res)
  83   real fn
  84   real val1, val2, res
  85
  86   if (diff(fn(val1, val2), res)) STOP 7
  87 contains
  88 function diff(a, b)
  89   real a, b
  90   logical diff
  91   diff = (abs(a - b) .gt. 0.00001)
  92 end function
  93 end subroutine
  94
  95 subroutine test_d2(fn, val1, val2, res)
  96   double precision fn
  97   double precision val1, val2, res
  98
  99   if (diff(fn(val1, val2), res)) STOP 8
 100 contains
 101 function diff(a, b)
 102   double precision a, b
 103   logical diff
 104   diff = (abs(a - b) .gt. 0.00001d0)
 105 end function
 106 end subroutine
 107
 108 subroutine test_dprod(fn)
 109   double precision fn
 110   if (abs (fn (2.0, 3.0) - 6d0) .gt. 0.00001) STOP 9
 111 end subroutine
 112
 113 subroutine test_nint(fn,val,res)
 114   integer fn, res
 115   real val
 116   if (res .ne. fn(val)) STOP 10
 117 end subroutine
 118
 119 subroutine test_idnint(fn,val,res)
 120   integer fn, res
 121   double precision val
 122   if (res .ne. fn(val)) STOP 11
 123 end subroutine
 124
 125 subroutine test_idim(fn,val1,val2,res)
 126   integer fn, res, val1, val2
 127   if (res .ne. fn(val1,val2)) STOP 12
 128 end subroutine
 129
 130 subroutine test_iabs(fn,val,res)
 131   integer fn, res, val
 132   if (res .ne. fn(val)) STOP 13
 133 end subroutine
 134
 135 subroutine test_len(fn,val,res)
 136   integer fn, res
 137   character(len=*) val
 138   if (res .ne. fn(val)) STOP 14
 139 end subroutine
 140
 141 subroutine test_index(fn,val1,val2,res)
 142   integer fn, res
 143   character(len=*) val1, val2
 144   if (fn(val1,val2) .ne. res) STOP 15
 145 end subroutine
 146
 147 program specifics
 148   intrinsic abs
 149   intrinsic aint
 150   intrinsic anint
 151   intrinsic acos
 152   intrinsic acosh
 153   intrinsic asin
 154   intrinsic asinh
 155   intrinsic atan
 156   intrinsic atanh
 157   intrinsic cos
 158   intrinsic sin
 159   intrinsic tan
 160   intrinsic cosh
 161   intrinsic sinh
 162   intrinsic tanh
 163   intrinsic alog
 164   intrinsic alog10
 165   intrinsic exp
 166   intrinsic sign
 167   intrinsic isign
 168   intrinsic amod
 169
 170   intrinsic dabs
 171   intrinsic dint
 172   intrinsic dnint
 173   intrinsic dacos
 174   intrinsic dacosh
 175   intrinsic dasin
 176   intrinsic dasinh
 177   intrinsic datan
 178   intrinsic datanh
 179   intrinsic dcos
 180   intrinsic dsin
 181   intrinsic dtan
 182   intrinsic dcosh
 183   intrinsic dsinh
 184   intrinsic dtanh
 185   intrinsic dlog
 186   intrinsic dlog10
 187   intrinsic dexp
 188   intrinsic dsign
 189   intrinsic dmod
 190
 191   intrinsic conjg
 192   intrinsic ccos
 193   intrinsic cexp
 194   intrinsic clog
 195   intrinsic csin
 196   intrinsic csqrt
 197
 198   intrinsic dconjg
 199   intrinsic cdcos
 200   intrinsic cdexp
 201   intrinsic cdlog
 202   intrinsic cdsin
 203   intrinsic cdsqrt
 204   intrinsic zcos
 205   intrinsic zexp
 206   intrinsic zlog
 207   intrinsic zsin
 208   intrinsic zsqrt
 209
 210   intrinsic cabs
 211   intrinsic cdabs
 212   intrinsic zabs
 213
 214   intrinsic dprod
 215
 216   intrinsic nint
 217   intrinsic idnint
 218   intrinsic dim
 219   intrinsic ddim
 220   intrinsic idim
 221   intrinsic iabs
 222   intrinsic mod
 223   intrinsic len
 224   intrinsic index
 225
 226   intrinsic aimag
 227   intrinsic dimag
 228
 229   call test_r (abs, -1.0, abs(-1.0))
 230   call test_r (aint, 1.7, aint(1.7))
 231   call test_r (anint, 1.7, anint(1.7))
 232   call test_r (acos, 0.5, acos(0.5))
 233   call test_r (acosh, 1.5, acosh(1.5))
 234   call test_r (asin, 0.5, asin(0.5))
 235   call test_r (asinh, 0.5, asinh(0.5))
 236   call test_r (atan, 0.5, atan(0.5))
 237   call test_r (atanh, 0.5, atanh(0.5))
 238   call test_r (cos, 1.0, cos(1.0))
 239   call test_r (sin, 1.0, sin(1.0))
 240   call test_r (tan, 1.0, tan(1.0))
 241   call test_r (cosh, 1.0, cosh(1.0))
 242   call test_r (sinh, 1.0, sinh(1.0))
 243   call test_r (tanh, 1.0, tanh(1.0))
 244   call test_r (alog, 2.0, alog(2.0))
 245   call test_r (alog10, 2.0, alog10(2.0))
 246   call test_r (exp, 1.0, exp(1.0))
 247   call test_r2 (sign, 1.0, -2.0, sign(1.0, -2.0))
 248   call test_r2 (amod, 3.5, 2.0, amod(3.5, 2.0))
 249
 250   call test_d (dabs, -1d0, abs(-1d0))
 251   call test_d (dint, 1.7d0, 1d0)
 252   call test_d (dnint, 1.7d0, 2d0)
 253   call test_d (dacos, 0.5d0, dacos(0.5d0))
 254   call test_d (dacosh, 1.5d0, dacosh(1.5d0))
 255   call test_d (dasin, 0.5d0, dasin(0.5d0))
 256   call test_d (dasinh, 0.5d0, dasinh(0.5d0))
 257   call test_d (datan, 0.5d0, datan(0.5d0))
 258   call test_d (datanh, 0.5d0, datanh(0.5d0))
 259   call test_d (dcos, 1d0, dcos(1d0))
 260   call test_d (dsin, 1d0, dsin(1d0))
 261   call test_d (dtan, 1d0, dtan(1d0))
 262   call test_d (dcosh, 1d0, dcosh(1d0))
 263   call test_d (dsinh, 1d0, dsinh(1d0))
 264   call test_d (dtanh, 1d0, dtanh(1d0))
 265   call test_d (dlog, 2d0, dlog(2d0))
 266   call test_d (dlog10, 2d0, dlog10(2d0))
 267   call test_d (dexp, 1d0, dexp(1d0))
 268   call test_d2 (dsign, 1d0, -2d0, sign(1d0, -2d0))
 269   call test_d2 (dmod, 3.5d0, 2d0, dmod(3.5d0, 2d0))
 270
 271   call test_dprod (dprod)
 272
 273   call test_c (conjg, (1.2,-4.), conjg((1.2,-4.)))
 274   call test_c (ccos, (1.2,-4.), ccos((1.2,-4.)))
 275   call test_c (cexp, (1.2,-4.), cexp((1.2,-4.)))
 276   call test_c (clog, (1.2,-4.), clog((1.2,-4.)))
 277   call test_c (csin, (1.2,-4.), csin((1.2,-4.)))
 278   call test_c (csqrt, (1.2,-4.), csqrt((1.2,-4.)))
 279
 280   call test_z (dconjg, (1.2d0,-4.d0), dconjg((1.2d0,-4.d0)))
 281   call test_z (cdcos, (1.2d0,-4.d0), cdcos((1.2d0,-4.d0)))
 282   call test_z (zcos, (1.2d0,-4.d0), zcos((1.2d0,-4.d0)))
 283   call test_z (cdexp, (1.2d0,-4.d0), cdexp((1.2d0,-4.d0)))
 284   call test_z (zexp, (1.2d0,-4.d0), zexp((1.2d0,-4.d0)))
 285   call test_z (cdlog, (1.2d0,-4.d0), cdlog((1.2d0,-4.d0)))
 286   call test_z (zlog, (1.2d0,-4.d0), zlog((1.2d0,-4.d0)))
 287   call test_z (cdsin, (1.2d0,-4.d0), cdsin((1.2d0,-4.d0)))
 288   call test_z (zsin, (1.2d0,-4.d0), zsin((1.2d0,-4.d0)))
 289   call test_z (cdsqrt, (1.2d0,-4.d0), cdsqrt((1.2d0,-4.d0)))
 290   call test_z (zsqrt, (1.2d0,-4.d0), zsqrt((1.2d0,-4.d0)))
 291
 292   call test_cabs (cabs, (1.2,-4.), cabs((1.2,-4.)))
 293   call test_cdabs (cdabs, (1.2d0,-4.d0), cdabs((1.2d0,-4.d0)))
 294   call test_cdabs (zabs, (1.2d0,-4.d0), zabs((1.2d0,-4.d0)))
 295   call test_cabs (aimag, (1.2,-4.), aimag((1.2,-4.)))
 296   call test_cdabs (dimag, (1.2d0,-4.d0), dimag((1.2d0,-4.d0)))
 297
 298   call test_nint (nint, -1.2, nint(-1.2))
 299   call test_idnint (idnint, -1.2d0, idnint(-1.2d0))
 300   call test_idim (isign, -42, 17, isign(-42, 17))
 301   call test_idim (idim, -42, 17, idim(-42,17))
 302   call test_idim (idim, 42, 17, idim(42,17))
 303   call test_r2 (dim, 1.2, -4., dim(1.2, -4.))
 304   call test_d2 (ddim, 1.2d0, -4.d0, ddim(1.2d0, -4.d0))
 305   call test_iabs (iabs, -7, iabs(-7))
 306   call test_idim (mod, 5, 2, mod(5,2))
 307   call test_len (len, "foobar", len("foobar"))
 308   call test_index (index, "foobarfoobar", "bar", index("foobarfoobar","bar"))
 309
 310 end program
 311