| ! Program to test intrinsic functions as actual arguments |
| 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 |
| |
| program specifics |
| intrinsic abs |
| intrinsic aint |
| intrinsic anint |
| intrinsic acos |
| intrinsic asin |
| intrinsic atan |
| intrinsic cos |
| intrinsic sin |
| intrinsic tan |
| intrinsic cosh |
| intrinsic sinh |
| intrinsic tanh |
| intrinsic alog |
| intrinsic exp |
| intrinsic sign |
| intrinsic amod |
| |
| intrinsic dabs |
| intrinsic dint |
| intrinsic dnint |
| intrinsic dacos |
| intrinsic dasin |
| intrinsic datan |
| intrinsic dcos |
| intrinsic dsin |
| intrinsic dtan |
| intrinsic dcosh |
| intrinsic dsinh |
| intrinsic dtanh |
| intrinsic dlog |
| intrinsic dexp |
| intrinsic dsign |
| intrinsic dmod |
| |
| intrinsic dprod |
| |
| !TODO: Also test complex variants |
| |
| call test_r (abs, -1.0, abs(-1.0)) |
| call test_r (aint, 1.7, 1.0) |
| call test_r (anint, 1.7, 2.0) |
| call test_r (acos, 0.5, acos(0.5)) |
| call test_r (asin, 0.5, asin(0.5)) |
| call test_r (atan, 0.5, atan(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 (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 (dasin, 0.5d0, dasin(0.5d0)) |
| call test_d (datan, 0.5d0, datan(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 (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) |
| end program |
| |
