gcc/testsuite/gfortran.dg/g77/intrinsic-unix-erf.f

   1 c { dg-do run }
   2 c  intrinsic-unix-erf.f
   3 c
   4 c Test Bessel function intrinsics.
   5 c These functions are only available if provided by system
   6 c
   7 c     David Billinghurst <David.Billinghurst@riotinto.com>
   8 c
   9       real x, a
  10       double precision dx, da
  11       logical fail
  12       common /flags/ fail
  13       fail = .false.
  14
  15       x = 0.6
  16       dx = x
  17 c     ERF  - error function
  18       a = 0.6038561
  19       da = a
  20       call c_r(ERF(x),a,'ERF(real)')
  21       call c_d(ERF(dx),da,'ERF(double)')
  22       call c_d(DERF(dx),da,'DERF(double)')
  23
  24 c     ERFC  - complementary error function
  25       a = 1.0 - a
  26       da = a
  27       call c_r(ERFC(x),a,'ERFC(real)')
  28       call c_d(ERFC(dx),da,'ERFC(double)')
  29       call c_d(DERFC(dx),da,'DERFC(double)')
  30
  31       if ( fail ) call abort()
  32       end
  33
  34       subroutine failure(label)
  35 c     Report failure and set flag
  36       character*(*) label
  37       logical fail
  38       common /flags/ fail
  39       write(6,'(a,a,a)') 'Test ',label,' FAILED'
  40       fail = .true.
  41       end
  42
  43       subroutine c_r(a,b,label)
  44 c     Check if REAL a equals b, and fail otherwise
  45       real a, b
  46       character*(*) label
  47       if ( abs(a-b) .gt. 1.0e-5 ) then
  48          call failure(label)
  49          write(6,*) 'Got ',a,' expected ', b
  50       end if
  51       end
  52
  53       subroutine c_d(a,b,label)
  54 c     Check if DOUBLE PRECISION a equals b, and fail otherwise
  55       double precision a, b
  56       character*(*) label
  57       if ( abs(a-b) .gt. 1.0d-5 ) then
  58          call failure(label)
  59          write(6,*) 'Got ',a,' expected ', b
  60       end if
  61       end