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