gcc/testsuite/gfortran.dg/specifics_1.f90

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