specifics_1.f90

来自「用于进行gcc测试」· F90 代码 · 共 319 行

! 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