! Program to test intrinsic functions as actual arguments ! ! Copied from gfortran.fortran-torture/execute/specifics.f90 ! Please keep them in sync ! ! It is run here with -ff2c option ! ! { dg-do run } ! { dg-options "-ff2c" } ! Program to test intrinsic functions as actual arguments subroutine test_c(fn, val, res) complex fn complex val, res if (diff(fn(val),res)) call abort contains function diff(a,b) complex a,b logical diff diff = (abs(a - b) .gt. 0.00001) end function end subroutine subroutine test_z(fn, val, res) double complex fn double complex val, res if (diff(fn(val),res)) call abort contains function diff(a,b) double complex a,b logical diff diff = (abs(a - b) .gt. 0.00001) end function end subroutine subroutine test_cabs(fn, val, res) real fn, res complex val if (diff(fn(val),res)) call abort contains function diff(a,b) real a,b logical diff diff = (abs(a - b) .gt. 0.00001) end function end subroutine subroutine test_cdabs(fn, val, res) double precision fn, res double complex val if (diff(fn(val),res)) call abort contains function diff(a,b) double precision a,b logical diff diff = (abs(a - b) .gt. 0.00001) end function end subroutine subroutine test_r(fn, val, res) real fn real val, res if (diff(fn(val), res)) call abort contains function diff(a, b) real a, b logical diff diff = (abs(a - b) .gt. 0.00001) end function end subroutine subroutine test_d(fn, val, res) double precision fn double precision val, res if (diff(fn(val), res)) call abort contains function diff(a, b) double precision a, b logical diff diff = (abs(a - b) .gt. 0.00001d0) end function end subroutine subroutine test_r2(fn, val1, val2, res) real fn real val1, val2, res if (diff(fn(val1, val2), res)) call abort contains function diff(a, b) real a, b logical diff diff = (abs(a - b) .gt. 0.00001) end function end subroutine subroutine test_d2(fn, val1, val2, res) double precision fn double precision val1, val2, res if (diff(fn(val1, val2), res)) call abort contains function diff(a, b) double precision a, b logical diff diff = (abs(a - b) .gt. 0.00001d0) end function end subroutine subroutine test_dprod(fn) double precision fn if (abs (fn (2.0, 3.0) - 6d0) .gt. 0.00001) call abort end subroutine subroutine test_nint(fn,val,res) integer fn, res real val if (res .ne. fn(val)) call abort end subroutine subroutine test_idnint(fn,val,res) integer fn, res double precision val if (res .ne. fn(val)) call abort end subroutine subroutine test_idim(fn,val1,val2,res) integer fn, res, val1, val2 if (res .ne. fn(val1,val2)) call abort end subroutine subroutine test_iabs(fn,val,res) integer fn, res, val if (res .ne. fn(val)) call abort end subroutine subroutine test_len(fn,val,res) integer fn, res character(len=*) val if (res .ne. fn(val)) call abort end subroutine subroutine test_index(fn,val1,val2,res) integer fn, res character(len=*) val1, val2 if (fn(val1,val2) .ne. res) call abort end subroutine program specifics intrinsic abs intrinsic aint intrinsic anint intrinsic acos intrinsic acosh intrinsic asin intrinsic asinh intrinsic atan intrinsic atanh intrinsic cos intrinsic sin intrinsic tan intrinsic cosh intrinsic sinh intrinsic tanh intrinsic alog intrinsic alog10 intrinsic exp intrinsic sign intrinsic isign intrinsic amod intrinsic dabs intrinsic dint intrinsic dnint intrinsic dacos intrinsic dacosh intrinsic dasin intrinsic dasinh intrinsic datan intrinsic datanh intrinsic dcos intrinsic dsin intrinsic dtan intrinsic dcosh intrinsic dsinh intrinsic dtanh intrinsic dlog intrinsic dlog10 intrinsic dexp intrinsic dsign intrinsic dmod intrinsic conjg intrinsic ccos intrinsic cexp intrinsic clog intrinsic csin intrinsic csqrt intrinsic dconjg intrinsic cdcos intrinsic cdexp intrinsic cdlog intrinsic cdsin intrinsic cdsqrt intrinsic zcos intrinsic zexp intrinsic zlog intrinsic zsin intrinsic zsqrt intrinsic cabs intrinsic cdabs intrinsic zabs intrinsic dprod intrinsic nint intrinsic idnint intrinsic dim intrinsic ddim intrinsic idim intrinsic iabs intrinsic mod intrinsic len intrinsic index intrinsic aimag intrinsic dimag call test_r (abs, -1.0, abs(-1.0)) call test_r (aint, 1.7, aint(1.7)) call test_r (anint, 1.7, anint(1.7)) call test_r (acos, 0.5, acos(0.5)) call test_r (acosh, 1.5, acosh(1.5)) call test_r (asin, 0.5, asin(0.5)) call test_r (asinh, 0.5, asinh(0.5)) call test_r (atan, 0.5, atan(0.5)) call test_r (atanh, 0.5, atanh(0.5)) call test_r (cos, 1.0, cos(1.0)) call test_r (sin, 1.0, sin(1.0)) call test_r (tan, 1.0, tan(1.0)) call test_r (cosh, 1.0, cosh(1.0)) call test_r (sinh, 1.0, sinh(1.0)) call test_r (tanh, 1.0, tanh(1.0)) call test_r (alog, 2.0, alog(2.0)) call test_r (alog10, 2.0, alog10(2.0)) call test_r (exp, 1.0, exp(1.0)) call test_r2 (sign, 1.0, -2.0, sign(1.0, -2.0)) call test_r2 (amod, 3.5, 2.0, amod(3.5, 2.0)) call test_d (dabs, -1d0, abs(-1d0)) call test_d (dint, 1.7d0, 1d0) call test_d (dnint, 1.7d0, 2d0) call test_d (dacos, 0.5d0, dacos(0.5d0)) call test_d (dacosh, 1.5d0, dacosh(1.5d0)) call test_d (dasin, 0.5d0, dasin(0.5d0)) call test_d (dasinh, 0.5d0, dasinh(0.5d0)) call test_d (datan, 0.5d0, datan(0.5d0)) call test_d (datanh, 0.5d0, datanh(0.5d0)) call test_d (dcos, 1d0, dcos(1d0)) call test_d (dsin, 1d0, dsin(1d0)) call test_d (dtan, 1d0, dtan(1d0)) call test_d (dcosh, 1d0, dcosh(1d0)) call test_d (dsinh, 1d0, dsinh(1d0)) call test_d (dtanh, 1d0, dtanh(1d0)) call test_d (dlog, 2d0, dlog(2d0)) call test_d (dlog10, 2d0, dlog10(2d0)) call test_d (dexp, 1d0, dexp(1d0)) call test_d2 (dsign, 1d0, -2d0, sign(1d0, -2d0)) call test_d2 (dmod, 3.5d0, 2d0, dmod(3.5d0, 2d0)) call test_dprod (dprod) call test_c (conjg, (1.2,-4.), conjg((1.2,-4.))) call test_c (ccos, (1.2,-4.), ccos((1.2,-4.))) call test_c (cexp, (1.2,-4.), cexp((1.2,-4.))) call test_c (clog, (1.2,-4.), clog((1.2,-4.))) call test_c (csin, (1.2,-4.), csin((1.2,-4.))) call test_c (csqrt, (1.2,-4.), csqrt((1.2,-4.))) call test_z (dconjg, (1.2d0,-4.d0), dconjg((1.2d0,-4.d0))) call test_z (cdcos, (1.2d0,-4.d0), cdcos((1.2d0,-4.d0))) call test_z (zcos, (1.2d0,-4.d0), zcos((1.2d0,-4.d0))) call test_z (cdexp, (1.2d0,-4.d0), cdexp((1.2d0,-4.d0))) call test_z (zexp, (1.2d0,-4.d0), zexp((1.2d0,-4.d0))) call test_z (cdlog, (1.2d0,-4.d0), cdlog((1.2d0,-4.d0))) call test_z (zlog, (1.2d0,-4.d0), zlog((1.2d0,-4.d0))) call test_z (cdsin, (1.2d0,-4.d0), cdsin((1.2d0,-4.d0))) call test_z (zsin, (1.2d0,-4.d0), zsin((1.2d0,-4.d0))) call test_z (cdsqrt, (1.2d0,-4.d0), cdsqrt((1.2d0,-4.d0))) call test_z (zsqrt, (1.2d0,-4.d0), zsqrt((1.2d0,-4.d0))) call test_cabs (cabs, (1.2,-4.), cabs((1.2,-4.))) call test_cdabs (cdabs, (1.2d0,-4.d0), cdabs((1.2d0,-4.d0))) call test_cdabs (zabs, (1.2d0,-4.d0), zabs((1.2d0,-4.d0))) call test_cabs (aimag, (1.2,-4.), aimag((1.2,-4.))) call test_cdabs (dimag, (1.2d0,-4.d0), dimag((1.2d0,-4.d0))) call test_nint (nint, -1.2, nint(-1.2)) call test_idnint (idnint, -1.2d0, idnint(-1.2d0)) call test_idim (isign, -42, 17, isign(-42, 17)) call test_idim (idim, -42, 17, idim(-42,17)) call test_idim (idim, 42, 17, idim(42,17)) call test_r2 (dim, 1.2, -4., dim(1.2, -4.)) call test_d2 (ddim, 1.2d0, -4.d0, ddim(1.2d0, -4.d0)) call test_iabs (iabs, -7, iabs(-7)) call test_idim (mod, 5, 2, mod(5,2)) call test_len (len, "foobar", len("foobar")) call test_index (index, "foobarfoobar", "bar", index("foobarfoobar","bar")) end program