gcc/testsuite/g77.f-torture/execute/intrinsic-unix-erf.f

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