1 c f90-intrinsic-numeric.f
3 c Test Fortran 90 intrinsic numeric functions - Section 13.10.2 and 13.13
4 c David Billinghurst <David.Billinghurst@riotinto.com>
7 c * g77 does not fully comply with F90. Noncompliances noted in comments.
8 c * Section 13.12: Specific names for intrinsic functions tested in
18 c ABS - Section 13.13.1
23 call c_i
(ABS
(-7),7,'ABS(integer)')
24 call c_i2
(ABS
(j
),ja
,'ABS(integer*2)')
25 call c_i1
(ABS
(k
),ka
,'ABS(integer*1)')
26 call c_r
(ABS
(-7.),7.,'ABS(real)')
27 call c_d
(ABS
(-7.d0
),7.d0
,'ABS(double)')
28 call c_r
(ABS
((3.,-4.)),5.0,'ABS(complex)')
29 call c_d
(ABS
((3.d0
,-4.d0
)),5.0d0
,'ABS(double complex)')
31 c AIMAG - Section 13.13.6
32 call c_r
(AIMAG
((2.,-7.)),-7.,'AIMAG(complex)')
33 c g77: AIMAG(double complex) does not comply with F90
34 c call c_d(AIMAG((2.d0,-7.d0)),-7.d0,'AIMAG(double complex)')
36 c AINT - Section 13.13.7
37 call c_r
(AINT
(2.783),2.0,'AINT(real) 1')
38 call c_r
(AINT
(-2.783),-2.0,'AINT(real) 2')
39 call c_d
(AINT
(2.783d0
),2.0d0
,'AINT(double precision) 1')
40 call c_d
(AINT
(-2.783d0
),-2.0d0
,'AINT(double precision) 2')
41 c Note: g77 does not support optional argument KIND
43 c ANINT - Section 13.13.10
44 call c_r
(ANINT
(2.783),3.0,'ANINT(real) 1')
45 call c_r
(ANINT
(-2.783),-3.0,'ANINT(real) 2')
46 call c_d
(ANINT
(2.783d0
),3.0d0
,'ANINT(double precision) 1')
47 call c_d
(ANINT
(-2.783d0
),-3.0d0
,'ANINT(double precision) 2')
48 c Note: g77 does not support optional argument KIND
50 c CEILING - Section 13.13.18
53 c CMPLX - Section 13.13.20
58 call c_c
(CMPLX
(1),(1.,0.),'CMPLX(integer)')
59 call c_c
(CMPLX
(1,2),(1.,2.),'CMPLX(integer, integer)')
60 call c_c
(CMPLX
(j
),(1.,0.),'CMPLX(integer*2)')
61 call c_c
(CMPLX
(j
,ja
),(1.,2.),'CMPLX(integer*2, integer*2)')
62 call c_c
(CMPLX
(k
),(1.,0.),'CMPLX(integer*1)')
63 call c_c
(CMPLX
(k
,ka
),(1.,2.),'CMPLX(integer*1, integer*1)')
64 call c_c
(CMPLX
(1.),(1.,0.),'CMPLX(real)')
65 call c_c
(CMPLX
(1.d0
),(1.,0.),'CMPLX(double)')
66 call c_c
(CMPLX
(1.d0
,2.d0
),(1.,2.),'CMPLX(double,double)')
67 call c_c
(CMPLX
(1.,2.),(1.,2.),'CMPLX(complex)')
68 call c_c
(CMPLX
(1.d0
,2.d0
),(1.,2.),'CMPLX(double complex)')
69 c NOTE: g77 does not support optional argument KIND
71 c CONJG - Section 13.13.21
72 call c_c
(CONJG
((2.,-7.)),(2.,7.),'CONJG(complex)')
73 call c_z
(CONJG
((2.d0
,-7.d0
)),(2.d0
,7.d0
),'CONJG(double complex)')
75 c DBLE - Section 13.13.27
78 call c_d
(DBLE
(5),5.0d0
,'DBLE(integer)')
79 call c_d
(DBLE
(j
),5.0d0
,'DBLE(integer*2)')
80 call c_d
(DBLE
(k
),5.0d0
,'DBLE(integer*1)')
81 call c_d
(DBLE
(5.),5.0d0
,'DBLE(real)')
82 call c_d
(DBLE
(5.0d0
),5.0d0
,'DBLE(double)')
83 call c_d
(DBLE
((5.0,0.5)),5.0d0
,'DBLE(complex)')
84 call c_d
(DBLE
((5.0d0
,0.5d0
)),5.0d0
,'DBLE(double complex)')
86 c DIM - Section 13.13.29
93 call c_i
(DIM
(-8,-3),0,'DIM(integer)')
94 call c_i2
(DIM
(j
,j2
),ja
,'DIM(integer*2)')
95 call c_i1
(DIM
(k
,k2
),ka
,'DIM(integer*1)')
96 call c_r
(DIM
(-8.,-3.),0.,'DIM(real,real)')
97 call c_d
(DIM
(-8.d0
,-3.d0
),0.d0
,'DIM(double,double)')
99 c DPROD - Section 13.13.31
100 call c_d
(DPROD
(-8.,-3.),24.d0
,'DPROD(real,real)')
102 c FLOOR - Section 13.13.36
105 c INT - Section 13.13.47
108 call c_i
(INT
(5),5,'INT(integer)')
109 call c_i
(INT
(j
),5,'INT(integer*2)')
110 call c_i
(INT
(k
),5,'INT(integer*1)')
111 call c_i
(INT
(5.01),5,'INT(real)')
112 call c_i
(INT
(5.01d0
),5,'INT(double)')
113 c Note: Does not accept optional second argument KIND
115 c MAX - Section 13.13.63
122 call c_i
(MAX
(1,2,3),3,'MAX(integer,integer,integer)')
123 call c_i2
(MAX
(j
,j2
),ja
,'MAX(integer*2,integer*2)')
124 call c_i1
(MAX
(k
,k2
),ka
,'MAX(integer*1,integer*1)')
125 call c_r
(MAX
(1.,2.,3.),3.,'MAX(real,real,real)')
126 call c_d
(MAX
(1.d0
,2.d0
,3.d0
),3.d0
,'MAX(double,double,double)')
128 c MIN - Section 13.13.68
135 call c_i
(MIN
(1,2,3),1,'MIN(integer,integer,integer)')
136 call c_i2
(MIN
(j
,j2
),ja
,'MIN(integer*2,integer*2)')
137 call c_i1
(MIN
(k
,k2
),ka
,'MIN(integer*1,integer*1)')
138 call c_r
(MIN
(1.,2.,3.),1.,'MIN(real,real,real)')
139 call c_d
(MIN
(1.d0
,2.d0
,3.d0
),1.d0
,'MIN(double,double,double)')
141 c MOD - Section 13.13.72
142 call c_i
(MOD
(8,5),3,'MOD(integer,integer) 1')
143 call c_i
(MOD
(-8,5),-3,'MOD(integer,integer) 2')
144 call c_i
(MOD
(8,-5),3,'MOD(integer,integer) 3')
145 call c_i
(MOD
(-8,-5),-3,'MOD(integer,integer) 4')
149 call c_i2
(MOD
(j
,j2
),ja
,'MOD(integer*2,integer*2) 1')
150 call c_i2
(MOD
(-j
,j2
),-ja
,'MOD(integer*2,integer*2) 2')
151 call c_i2
(MOD
(j
,-j2
),ja
,'MOD(integer*2,integer*2) 3')
152 call c_i2
(MOD
(-j
,-j2
),-ja
,'MOD(integer*2,integer*2) 4')
156 call c_i1
(MOD
(k
,k2
),ka
,'MOD(integer*1,integer*1) 1')
157 call c_i1
(MOD
(-k
,k2
),-ka
,'MOD(integer*1,integer*1) 2')
158 call c_i1
(MOD
(k
,-k2
),ka
,'MOD(integer*1,integer*1) 3')
159 call c_i1
(MOD
(-k
,-k2
),-ka
,'MOD(integer*1,integer*1) 4')
160 call c_r
(MOD
(8.,5.),3.,'MOD(real,real) 1')
161 call c_r
(MOD
(-8.,5.),-3.,'MOD(real,real) 2')
162 call c_r
(MOD
(8.,-5.),3.,'MOD(real,real) 3')
163 call c_r
(MOD
(-8.,-5.),-3.,'MOD(real,real) 4')
164 call c_d
(MOD
(8.d0
,5.d0
),3.d0
,'MOD(double,double) 1')
165 call c_d
(MOD
(-8.d0
,5.d0
),-3.d0
,'MOD(double,double) 2')
166 call c_d
(MOD
(8.d0
,-5.d0
),3.d0
,'MOD(double,double) 3')
167 call c_d
(MOD
(-8.d0
,-5.d0
),-3.d0
,'MOD(double,double) 4')
169 c MODULO - Section 13.13.73
172 c NINT - Section 13.13.76
173 call c_i
(NINT
(2.783),3,'NINT(real)')
174 call c_i
(NINT
(2.783d0
),3,'NINT(double)')
175 c Optional second argument KIND not implemented
177 c REAL - Section 13.13.86
180 call c_r
(REAL(-2),-2.0,'REAL(integer)')
181 call c_r
(REAL(j
),-2.0,'REAL(integer*2)')
182 call c_r
(REAL(k
),-2.0,'REAL(integer*1)')
183 call c_r
(REAL(-2.0),-2.0,'REAL(real)')
184 call c_r
(REAL(-2.0d0
),-2.0,'REAL(double)')
185 call c_r
(REAL((-2.,9.)),-2.0,'REAL(complex)')
186 c REAL(double complex) not implemented
187 c call c_r(REAL((-2.d0,9.d0)),-2.0,'REAL(double complex)')
189 c SIGN - Section 13.13.96
196 call c_i
(SIGN
(-3,2),3,'SIGN(integer)')
197 call c_i2
(SIGN
(j
,j2
),ja
,'SIGN(integer*2)')
198 call c_i1
(SIGN
(k
,k2
),ka
,'SIGN(integer*1)')
199 call c_r
(SIGN
(-3.0,2.),3.,'SIGN(real,real)')
200 call c_d
(SIGN
(-3.d0
,2.d0
),3.d0
,'SIGN(double,double)')
202 if ( fail
) call abort
()
205 subroutine failure
(label
)
206 c Report failure and set flag
210 write(6,'(a,a,a)') 'Test ',label
,' FAILED'
214 subroutine c_i
(i
,j
,label
)
215 c Check if INTEGER i equals j, and fail otherwise
220 write(6,*) 'Got ',i
,' expected ', j
224 subroutine c_i2
(i
,j
,label
)
225 c Check if INTEGER*2 i equals j, and fail otherwise
230 write(6,*) 'Got ',i
,' expected ', j
234 subroutine c_i1
(i
,j
,label
)
235 c Check if INTEGER*1 i equals j, and fail otherwise
240 write(6,*) 'Got ',i
,' expected ', j
244 subroutine c_r
(a
,b
,label
)
245 c Check if REAL a equals b, and fail otherwise
248 if ( abs
(a
-b
) .gt
. 1.0e-5 ) then
250 write(6,*) 'Got ',a
,' expected ', b
254 subroutine c_d
(a
,b
,label
)
255 c Check if DOUBLE PRECISION a equals b, and fail otherwise
256 double precision a
, b
258 if ( abs
(a
-b
) .gt
. 1.0d
-5 ) then
260 write(6,*) 'Got ',a
,' expected ', b
264 subroutine c_c
(a
,b
,label
)
265 c Check if COMPLEX a equals b, and fail otherwise
268 if ( abs
(a
-b
) .gt
. 1.0e-5 ) then
270 write(6,*) 'Got ',a
,' expected ', b
274 subroutine c_z
(a
,b
,label
)
275 c Check if COMPLEX a equals b, and fail otherwise
278 if ( abs
(a
-b
) .gt
. 1.0d
-5 ) then
280 write(6,*) 'Got ',a
,' expected ', b