OSDN Git Service

PR fortran/18791
[pf3gnuchains/gcc-fork.git] / gcc / testsuite / gfortran.fortran-torture / execute / specifics.f90
1 ! Program to test intrinsic functions as actual arguments
2 subroutine test_c(fn, val, res)
3   complex fn
4   complex val, res
5
6   if (diff(fn(val),res)) call abort
7 contains
8 function diff(a,b)
9   complex a,b
10   logical diff
11   diff = (abs(a - b) .gt. 0.00001)
12 end function
13 end subroutine 
14
15 subroutine test_z(fn, val, res)
16   double complex fn
17   double complex val, res
18
19   if (diff(fn(val),res)) call abort
20 contains
21 function diff(a,b)
22   double complex a,b
23   logical diff
24   diff = (abs(a - b) .gt. 0.00001)
25 end function
26 end subroutine 
27
28 subroutine test_cabs(fn, val, res)
29   real fn, res
30   complex val
31
32   if (diff(fn(val),res)) call abort
33 contains
34 function diff(a,b)
35   real a,b
36   logical diff
37   diff = (abs(a - b) .gt. 0.00001)
38 end function
39 end subroutine 
40
41 subroutine test_cdabs(fn, val, res)
42   double precision fn, res
43   double complex val
44
45   if (diff(fn(val),res)) call abort
46 contains
47 function diff(a,b)
48   double precision a,b
49   logical diff
50   diff = (abs(a - b) .gt. 0.00001)
51 end function
52 end subroutine 
53
54 subroutine test_r(fn, val, res)
55   real fn
56   real val, res
57
58   if (diff(fn(val), res)) call abort
59 contains
60 function diff(a, b)
61   real a, b
62   logical diff
63   diff = (abs(a - b) .gt. 0.00001)
64 end function
65 end subroutine
66
67 subroutine test_d(fn, val, res)
68   double precision fn
69   double precision val, res
70
71   if (diff(fn(val), res)) call abort
72 contains
73 function diff(a, b)
74   double precision a, b
75   logical diff
76   diff = (abs(a - b) .gt. 0.00001d0)
77 end function
78 end subroutine
79
80 subroutine test_r2(fn, val1, val2, res)
81   real fn
82   real val1, val2, res
83
84   if (diff(fn(val1, val2), res)) call abort
85 contains
86 function diff(a, b)
87   real a, b
88   logical diff
89   diff = (abs(a - b) .gt. 0.00001)
90 end function
91 end subroutine
92
93 subroutine test_d2(fn, val1, val2, res)
94   double precision fn
95   double precision val1, val2, res
96
97   if (diff(fn(val1, val2), res)) call abort
98 contains
99 function diff(a, b)
100   double precision a, b
101   logical diff
102   diff = (abs(a - b) .gt. 0.00001d0)
103 end function
104 end subroutine
105
106 subroutine test_dprod(fn)
107   double precision fn
108   if (abs (fn (2.0, 3.0) - 6d0) .gt. 0.00001) call abort
109 end subroutine
110
111 program specifics
112   intrinsic abs
113   intrinsic aint
114   intrinsic anint
115   intrinsic acos
116   intrinsic asin
117   intrinsic atan
118   intrinsic cos
119   intrinsic sin
120   intrinsic tan
121   intrinsic cosh
122   intrinsic sinh
123   intrinsic tanh
124   intrinsic alog
125   intrinsic exp
126   intrinsic sign
127   intrinsic amod
128
129   intrinsic dabs
130   intrinsic dint
131   intrinsic dnint
132   intrinsic dacos
133   intrinsic dasin
134   intrinsic datan
135   intrinsic dcos
136   intrinsic dsin
137   intrinsic dtan
138   intrinsic dcosh
139   intrinsic dsinh
140   intrinsic dtanh
141   intrinsic dlog
142   intrinsic dexp
143   intrinsic dsign
144   intrinsic dmod
145
146   intrinsic conjg
147   intrinsic ccos
148   intrinsic cexp
149   intrinsic clog
150   intrinsic csin
151   intrinsic csqrt
152
153   intrinsic dconjg
154   intrinsic cdcos
155   intrinsic cdexp
156   intrinsic cdlog
157   intrinsic cdsin
158   intrinsic cdsqrt
159
160   intrinsic cabs
161   intrinsic cdabs
162
163   intrinsic dprod
164
165   call test_r (abs, -1.0, abs(-1.0))
166   call test_r (aint, 1.7, 1.0)
167   call test_r (anint, 1.7, 2.0)
168   call test_r (acos, 0.5, acos(0.5))
169   call test_r (asin, 0.5, asin(0.5))
170   call test_r (atan, 0.5, atan(0.5))
171   call test_r (cos, 1.0, cos(1.0))
172   call test_r (sin, 1.0, sin(1.0))
173   call test_r (tan, 1.0, tan(1.0))
174   call test_r (cosh, 1.0, cosh(1.0))
175   call test_r (sinh, 1.0, sinh(1.0))
176   call test_r (tanh, 1.0, tanh(1.0))
177   call test_r (alog, 2.0, alog(2.0))
178   call test_r (exp, 1.0, exp(1.0))
179   call test_r2 (sign, 1.0, -2.0, sign(1.0, -2.0))
180   call test_r2 (amod, 3.5, 2.0, amod(3.5, 2.0))
181   
182   call test_d (dabs, -1d0, abs(-1d0))
183   call test_d (dint, 1.7d0, 1d0)
184   call test_d (dnint, 1.7d0, 2d0)
185   call test_d (dacos, 0.5d0, dacos(0.5d0))
186   call test_d (dasin, 0.5d0, dasin(0.5d0))
187   call test_d (datan, 0.5d0, datan(0.5d0))
188   call test_d (dcos, 1d0, dcos(1d0))
189   call test_d (dsin, 1d0, dsin(1d0))
190   call test_d (dtan, 1d0, dtan(1d0))
191   call test_d (dcosh, 1d0, dcosh(1d0))
192   call test_d (dsinh, 1d0, dsinh(1d0))
193   call test_d (dtanh, 1d0, dtanh(1d0))
194   call test_d (dlog, 2d0, dlog(2d0))
195   call test_d (dexp, 1d0, dexp(1d0))
196   call test_d2 (dsign, 1d0, -2d0, sign(1d0, -2d0))
197   call test_d2 (dmod, 3.5d0, 2d0, dmod(3.5d0, 2d0))
198
199   call test_dprod (dprod)
200
201   call test_c (conjg, (1.2,-4.), conjg((1.2,-4.)))
202   call test_c (ccos, (1.2,-4.), ccos((1.2,-4.)))
203   call test_c (cexp, (1.2,-4.), cexp((1.2,-4.)))
204   call test_c (clog, (1.2,-4.), clog((1.2,-4.)))
205   call test_c (csin, (1.2,-4.), csin((1.2,-4.)))
206   call test_c (csqrt, (1.2,-4.), csqrt((1.2,-4.)))
207
208   call test_z (dconjg, (1.2d0,-4.d0), dconjg((1.2d0,-4.d0)))
209   call test_z (cdcos, (1.2d0,-4.d0), cdcos((1.2d0,-4.d0)))
210   call test_z (cdexp, (1.2d0,-4.d0), cdexp((1.2d0,-4.d0)))
211   call test_z (cdlog, (1.2d0,-4.d0), cdlog((1.2d0,-4.d0)))
212   call test_z (cdsin, (1.2d0,-4.d0), cdsin((1.2d0,-4.d0)))
213   call test_z (cdsqrt, (1.2d0,-4.d0), cdsqrt((1.2d0,-4.d0)))
214
215   call test_cabs (cabs, (1.2,-4.), cabs((1.2,-4.)))
216   call test_cdabs (cdabs, (1.2d0,-4.d0), cdabs((1.2d0,-4.d0)))
217
218 end program
219