1c  intrinsic-unix-erf.f
2c
3c Test Bessel function intrinsics.
4c These functions are only available if provided by system
5c
6c     David Billinghurst <David.Billinghurst@riotinto.com>
7c
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
16c     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
23c     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)
34c     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)
43c     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)
53c     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
61