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
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
|
c { dg-do run }
c f90-intrinsic-mathematical.f
c
c Test Fortran 90 intrinsic mathematical functions - Section 13.10.3 and
c 13.13
c David Billinghurst <David.Billinghurst@riotinto.com>
c
c Notes:
c * g77 does not fully comply with F90. Noncompliances noted in comments.
c * Section 13.12: Specific names for intrinsic functions tested in
c intrinsic77.f
logical fail
common /flags/ fail
fail = .false.
c ACOS - Section 13.13.3
call c_r(ACOS(0.54030231),1.0,'ACOS(real)')
call c_d(ACOS(0.54030231d0),1.d0,'ACOS(double)')
c ASIN - Section 13.13.12
call c_r(ASIN(0.84147098),1.0,'ASIN(real)')
call c_d(ASIN(0.84147098d0),1.d0,'ASIN(double)')
c ATAN - Section 13.13.14
call c_r(ATAN(1.5574077),1.0,'ATAN(real)')
call c_d(ATAN(1.5574077d0),1.d0,'ATAN(double)')
c ATAN2 - Section 13.13.15
call c_r(ATAN2(1.5574077,1.),1.0,'ATAN2(real)')
call c_d(ATAN2(1.5574077d0,1.d0),1.d0,'ATAN2(double)')
c COS - Section 13.13.22
call c_r(COS(1.0),0.54030231,'COS(real)')
call c_d(COS(1.d0),0.54030231d0,'COS(double)')
call c_c(COS((1.,0.)),(0.54030231,0.),'COS(complex)')
call c_z(COS((1.d0,0.d0)),(0.54030231d0,0.d0),
$ 'COS(complex(kind=8))')
c COSH - Section 13.13.23
call c_r(COSH(1.0),1.5430806,'COSH(real)')
call c_d(COSH(1.d0),1.5430806d0,'COSH(double)')
c EXP - Section 13.13.34
call c_r(EXP(1.0),2.7182818,'EXP(real)')
call c_d(EXP(1.d0),2.7182818d0,'EXP(double)')
call c_c(EXP((1.,0.)),(2.7182818,0.),'EXP(complex)')
call c_z(EXP((1.d0,0.d0)),(2.7182818d0,0.d0),
$ 'EXP(complex(kind=8))')
c LOG - Section 13.13.59
call c_r(LOG(10.0),2.3025851,'LOG(real)')
call c_d(LOG(10.d0),2.3025851d0,'LOG(double)')
call c_c(LOG((10.,0.)),(2.3025851,0.),'LOG(complex)')
call c_z(LOG((10.d0,0.)),(2.3025851d0,0.d0),
$ 'LOG(complex(kind=8))')
c LOG10 - Section 13.13.60
call c_r(LOG10(10.0),1.0,'LOG10(real)')
call c_d(LOG10(10.d0),1.d0,'LOG10(double)')
c SIN - Section 13.13.97
call c_r(SIN(1.0),0.84147098,'SIN(real)')
call c_d(SIN(1.d0),0.84147098d0,'SIN(double)')
call c_c(SIN((1.,0.)),(0.84147098,0.),'SIN(complex)')
call c_z(SIN((1.d0,0.d0)),(0.84147098d0,0.d0),
$ 'SIN(complex(kind=8))')
c SINH - Section 13.13.98
call c_r(SINH(1.0),1.175201,'SINH(real)')
call c_d(SINH(1.d0),1.175201d0,'SINH(double)')
c SQRT - Section 13.13.102
call c_r(SQRT(4.0),2.0,'SQRT(real)')
call c_d(SQRT(4.d0),2.d0,'SQRT(double)')
call c_c(SQRT((4.,0.)),(2.,0.),'SQRT(complex)')
call c_z(SQRT((4.d0,0.)),(2.d0,0.),
$ 'SQRT(complex(kind=8))')
c TAN - Section 13.13.105
call c_r(TAN(1.0),1.5574077,'TAN(real)')
call c_d(TAN(1.d0),1.5574077d0,'TAN(double)')
c TANH - Section 13.13.106
call c_r(TANH(1.0),0.76159416,'TANH(real)')
call c_d(TANH(1.d0),0.76159416d0,'TANH(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
subroutine c_c(a,b,label)
c Check if COMPLEX a equals b, and fail otherwise
complex 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_z(a,b,label)
c Check if COMPLEX a equals b, and fail otherwise
complex(kind=8) 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
|
