3 c Test Fortran 77 intrinsic functions (ANSI X3.9-1978 Section 15.10)
7 c * generic functions with each argument type
8 c * specific functions by passing as subroutine argument
9 c where permiited by Section 13.12 of Fortran 90 standard
17 call nearest_whole_number
22 call positive_difference
23 call double_precision_product
24 call choosing_largest_value
25 call choosing_smallest_value
26 call length_of_character_array
27 call index_of_substring
29 call complex_conjugate
32 call natural_logarithm
41 call hyperbolic_cosine
42 call hyperbolic_tangent
43 call lexically_greater_than_or_equal
44 call lexically_greater_than
45 call lexically_less_than_or_equal
46 call lexically_less_than
48 if ( fail
) call abort
()
51 subroutine failure
(label
)
52 c Report failure and set flag
56 write(6,'(a,a,a)') 'Test ',label
,' FAILED'
60 subroutine c_i
(i
,j
,label
)
61 c Check if INTEGER i equals j, and fail otherwise
66 write(6,*) 'Got ',i
,' expected ', j
70 subroutine c_r
(a
,b
,label
)
71 c Check if REAL a equals b, and fail otherwise
74 if ( abs
(a
-b
) .gt
. 1.0e-5 ) then
76 write(6,*) 'Got ',a
,' expected ', b
80 subroutine c_d
(a
,b
,label
)
81 c Check if DOUBLE PRECISION a equals b, and fail otherwise
84 if ( abs
(a
-b
) .gt
. 1.0d
-5 ) then
86 write(6,*) 'Got ',a
,' expected ', b
90 subroutine c_c
(a
,b
,label
)
91 c Check if COMPLEX a equals b, and fail otherwise
94 if ( abs
(a
-b
) .gt
. 1.0e-5 ) then
96 write(6,*) 'Got ',a
,' expected ', b
100 subroutine c_l
(a
,b
,label
)
101 c Check if LOGICAL a equals b, and fail otherwise
104 if ( a
.neqv
. b
) then
106 write(6,*) 'Got ',a
,' expected ', b
110 subroutine c_ch
(a
,b
,label
)
111 c Check if CHARACTER a equals b, and fail otherwise
116 write(6,*) 'Got ',a
,' expected ', b
120 subroutine p_i_i
(f
,x
,i
,label
)
121 c Check if INTEGER f(x) equals i for INTEGER x
124 call c_i
(f
(x
),i
,label
)
127 subroutine p_i_ii
(f
,x1
,x2
,i
,label
)
128 c Check if INTEGER f(x1,x2) equals i for INTEGER x
131 call c_i
(f
(x1
,x2
),i
,label
)
134 subroutine p_i_r
(f
,x
,i
,label
)
135 c Check if INTEGER f(x) equals i for REAL x
139 call c_i
(f
(x
),i
,label
)
142 subroutine p_i_d
(f
,x
,i
,label
)
143 c Check if INTEGER f(x) equals i for DOUBLE PRECISION x
147 call c_i
(f
(x
),i
,label
)
150 subroutine p_i_ch
(f
,x
,a
,label
)
151 c Check if INTEGER f(x) equals a for CHARACTER x
155 call c_i
(f
(x
),a
,label
)
158 subroutine p_i_chch
(f
,x1
,x2
,a
,label
)
159 c Check if INTEGER f(x1,x2) equals a for CHARACTER x1 and x2
163 call c_i
(f
(x1
,x2
),a
,label
)
166 subroutine p_r_r
(f
,x
,a
,label
)
167 c Check if REAL f(x) equals a for REAL x
170 call c_r
(f
(x
),a
,label
)
173 subroutine p_r_rr
(f
,x1
,x2
,a
,label
)
174 c Check if REAL f(x1,x2) equals a for REAL x1, x2
177 call c_r
(f
(x1
,x2
),a
,label
)
180 subroutine p_d_d
(f
,x
,a
,label
)
181 c Check if DOUBLE PRECISION f(x) equals a for DOUBLE PRECISION x
182 double precision f
,x
,a
184 call c_d
(f
(x
),a
,label
)
187 subroutine p_d_rr
(f
,x1
,x2
,a
,label
)
188 c Check if DOUBLE PRECISION f(x1,x2) equals a for real x1,x2
192 call c_d
(f
(x1
,x2
),a
,label
)
195 subroutine p_d_dd
(f
,x1
,x2
,a
,label
)
196 c Check if DOUBLE PRECISION f(x1,x2) equals a for DOUBLE PRECISION x1,x2
197 double precision f
,x1
,x2
,a
199 call c_d
(f
(x1
,x2
),a
,label
)
202 subroutine p_c_c
(f
,x
,a
,label
)
203 c Check if COMPLEX f(x) equals a for COMPLEX x
206 call c_c
(f
(x
),a
,label
)
209 subroutine p_r_c
(f
,x
,a
,label
)
210 c Check if REAL f(x) equals a for COMPLEX x
214 call c_r
(f
(x
),a
,label
)
217 subroutine type_conversion
220 c conversion to integer
221 call c_i
(INT
(5),5,'INT(integer)')
222 call c_i
(INT
(5.01),5,'INT(real)')
223 call c_i
(INT
(5.01d0
),5,'INT(double)')
224 call c_i
(INT
((5.01,-3.0)),5,'INT(complex)')
225 call c_i
(IFIX
(5.01),5,'IFIX(real)')
226 call c_i
(IDINT
(5.01d0
),5,'IDINT(double)')
228 call c_r
(REAL(-2),-2.0,'REAL(integer)')
229 call c_r
(REAL(-2.0),-2.0,'REAL(real)')
230 call c_r
(REAL(-2.0d0
),-2.0,'REAL(double)')
231 call c_r
(REAL((-2.,9.)),-2.0,'REAL(complex)')
232 call c_r
(FLOAT
(-2),-2.0,'FLOAT(int)')
233 call c_r
(SNGL
(-2.0d0
),-2.0,'SNGL(double)')
234 c conversion to double
235 call c_d
(DBLE
(5),5.0d0
,'DBLE(integer)')
236 call c_d
(DBLE
(5.),5.0d0
,'DBLE(real)')
237 call c_d
(DBLE
(5.0d0
),5.0d0
,'DBLE(double)')
238 call c_d
(DBLE
((5.0,0.5)),5.0d0
,'DBLE(complex)')
239 c conversion to complex
240 call c_c
(CMPLX
(1),(1.,0.),'CMPLX(integer)')
241 call c_c
(CMPLX
(1,2),(1.,2.),'CMPLX(integer, integer)')
242 call c_c
(CMPLX
(1.),(1.,0.),'CMPLX(real)')
243 call c_c
(CMPLX
(1.,2.),(1.,2.),'CMPLX(real,real)')
244 call c_c
(CMPLX
(1.d0
),(1.,0.),'CMPLX(double)')
245 call c_c
(CMPLX
(1.d0
,2.d0
),(1.,2.),'CMPLX(double,double)')
246 call c_c
(CMPLX
(1.,2.),(1.,2.),'CMPLX(complex)')
247 c character conversion
250 call c_i
(ICHAR
(c
),i
,'ICHAR')
251 call c_ch
(CHAR
(i
),c
,'CHAR')
254 subroutine truncation
256 call c_r
(AINT
(9.2),9.0,'AINT(real)')
257 call c_d
(AINT
(9.2d0
),9.0d0
,'AINT(double)')
258 call c_d
(DINT
(9.2d0
),9.0d0
,'DINT(double)')
259 call p_r_r
(AINT
,9.2,9.0,'AINT')
260 call p_d_d
(DINT
,9.2d0
,9.0d0
,'DINT')
263 subroutine nearest_whole_number
264 intrinsic anint
, dnint
265 call c_r
(ANINT
(9.2),9.0,'ANINT(real)')
266 call c_d
(ANINT
(9.2d0
),9.0d0
,'ANINT(double)')
267 call c_d
(DNINT
(9.2d0
),9.0d0
,'DNINT(double)')
268 call p_r_r
(ANINT
,9.2,9.0,'ANINT')
269 call p_d_d
(DNINT
,9.2d0
,9.0d0
,'DNINT')
272 subroutine nearest_integer
273 intrinsic nint
, idnint
274 call c_i
(NINT
(9.2),9,'NINT(real)')
275 call c_i
(NINT
(9.2d0
),9,'NINT(double)')
276 call c_i
(IDNINT
(9.2d0
),9,'IDNINT(double)')
277 call p_i_r
(NINT
,9.2,9,'NINT')
278 call p_i_d
(IDNINT
,9.2d0
,9,'IDNINT')
281 subroutine absolute_value
282 intrinsic iabs
, abs
, dabs
, cabs
283 call c_i
(ABS
(-7),7,'ABS(integer)')
284 call c_r
(ABS
(-7.),7.,'ABS(real)')
285 call c_d
(ABS
(-7.d0
),7.d0
,'ABS(double)')
286 call c_r
(ABS
((3.,-4.)),5.0,'ABS(complex)')
287 call c_i
(IABS
(-7),7,'IABS(integer)')
288 call c_d
( DABS
(-7.d0
),7.d0
,'DABS(double)')
289 call c_r
( CABS
((3.,-4.)),5.0,'CABS(complex)')
290 call p_i_i
(IABS
,-7,7,'IABS')
291 call p_r_r
(ABS
,-7.,7.,'ABS')
292 call p_d_d
(DABS
,-7.0d0
,7.0d0
,'DABS')
293 call p_r_c
(CABS
,(3.,-4.), 5.0,'CABS')
296 subroutine remaindering
297 intrinsic mod
, amod
, dmod
298 call c_i
( MOD
(8,3),2,'MOD(integer,integer)')
299 call c_r
( MOD
(8.,3.),2.,'MOD(real,real)')
300 call c_d
( MOD
(8.d0
,3.d0
),2.d0
,'MOD(double,double)')
301 call c_r
( AMOD
(8.,3.),2.,'AMOD(real,real)')
302 call c_d
( DMOD
(8.d0
,3.d0
),2.d0
,'DMOD(double,double)')
303 call p_i_ii
(MOD
,8,3,2,'MOD')
304 call p_r_rr
(AMOD
,8.,3.,2.,'AMOD')
305 call p_d_dd
(DMOD
,8.d0
,3.d0
,2.d0
,'DMOD')
308 subroutine transfer_of_sign
309 intrinsic isign
,sign
,dsign
310 call c_i
(SIGN
(8,-3),-8,'SIGN(integer)')
311 call c_r
(SIGN
(8.,-3.),-8.,'SIGN(real,real)')
312 call c_d
(SIGN
(8.d0
,-3.d0
),-8.d0
,'SIGN(double,double)')
313 call c_i
(ISIGN
(8,-3),-8,'ISIGN(integer)')
314 call c_d
(DSIGN
(8.d0
,-3.d0
),-8.d0
,'DSIGN(double,double)')
315 call p_i_ii
(ISIGN
,8,-3,-8,'ISIGN')
316 call p_r_rr
(SIGN
,8.,-3.,-8.,'SIGN')
317 call p_d_dd
(DSIGN
,8.d0
,-3.d0
,-8.d0
,'DSIGN')
320 subroutine positive_difference
321 intrinsic idim
, dim
, ddim
322 call c_i
(DIM
(-8,-3),0,'DIM(integer)')
323 call c_r
(DIM
(-8.,-3.),0.,'DIM(real,real)')
324 call c_d
(DIM
(-8.d0
,-3.d0
),0.d0
,'DIM(double,double)')
325 call c_i
(IDIM
(-8,-3),0,'IDIM(integer)')
326 call c_d
(DDIM
(-8.d0
,-3.d0
),0.d0
,'DDIM(double,double)')
327 call p_i_ii
(IDIM
,-8,-3,0,'IDIM')
328 call p_r_rr
(DIM
,-8.,-3.,0.,'DIM')
329 call p_d_dd
(DDIM
,-8.d0
,-3.d0
,0.d0
,'DDIM')
332 subroutine double_precision_product
334 call c_d
(DPROD
(-8.,-3.),24.d0
,'DPROD(real,real)')
335 call p_d_rr
(DPROD
,-8.,-3.,24.d0
,'DPROD')
338 subroutine choosing_largest_value
339 call c_i
(MAX
(1,2,3),3,'MAX(integer,integer,integer)')
340 call c_r
(MAX
(1.,2.,3.),3.,'MAX(real,real,real)')
341 call c_d
(MAX
(1.d0
,2.d0
,3.d0
),3.d0
,'MAX(double,double,double)')
342 call c_i
(MAX0
(1,2,3),3,'MAX0(integer,integer,integer)')
343 call c_r
(AMAX1
(1.,2.,3.),3.,'MAX(real,real,real)')
344 call c_d
(DMAX1
(1.d0
,2.d0
,3.d0
),3.d0
,'DMAX1(double,double,double)')
345 call c_r
(AMAX0
(1,2,3),3.,'AMAX0(integer,integer,integer)')
346 call c_i
(MAX1
(1.,2.,3.),3,'MAX1(real,real,real)')
349 subroutine choosing_smallest_value
350 call c_i
(MIN
(1,2,3),1,'MIN(integer,integer,integer)')
351 call c_r
(MIN
(1.,2.,3.),1.,'MIN(real,real,real)')
352 call c_d
(MIN
(1.d0
,2.d0
,3.d0
),1.d0
,'MIN(double,double,double)')
353 call c_i
(MIN0
(1,2,3),1,'MIN0(integer,integer,integer)')
354 call c_r
(AMIN1
(1.,2.,3.),1.,'MIN(real,real,real)')
355 call c_d
(DMIN1
(1.d0
,2.d0
,3.d0
),1.d0
,'DMIN1(double,double,double)')
356 call c_r
(AMIN0
(1,2,3),1.,'AMIN0(integer,integer,integer)')
357 call c_i
(MIN1
(1.,2.,3.),1,'MIN1(real,real,real)')
360 subroutine length_of_character_array
362 call c_i
(LEN
('ABCDEF'),6,'LEN 1')
363 call p_i_ch
(LEN
,'ABCDEF',6,'LEN 2')
366 subroutine index_of_substring
368 call c_i
(INDEX
('ABCDEF','C'),3,'INDEX 1')
369 call p_i_chch
(INDEX
,'ABCDEF','C',3,'INDEX 2')
372 subroutine imaginary_part
374 call c_r
(AIMAG
((2.,-7.)),-7.,'AIMAG(complex)')
375 call p_r_c
(AIMAG
,(2.,-7.),-7.,'AIMAG(complex)')
378 subroutine complex_conjugate
380 call c_c
(CONJG
((2.,-7.)),(2.,7.),'CONJG(complex)')
381 call p_c_c
(CONJG
,(2.,-7.),(2.,7.),'CONJG')
384 subroutine square_root
385 intrinsic sqrt
, dsqrt
, csqrt
389 call c_r
(SQRT
(x
),a
,'SQRT(real)')
390 call c_d
(SQRT
(1.d0*x
),1.d0*a
,'SQRT(double)')
391 call c_c
(SQRT
((1.,0.)*x
),(1.,0.)*a
,'SQRT(complex)')
392 call c_d
(DSQRT
(1.d0*x
),1.d0*a
,'DSQRT(double)')
393 call c_c
(CSQRT
((1.,0.)*x
),(1.,0.)*a
,'CSQRT(complex)')
394 call p_r_r
(SQRT
,x
,a
,'SQRT')
395 call p_d_d
(DSQRT
,1.d0*x
,1.d0*a
,'DSQRT')
396 call p_c_c
(CSQRT
,(1.,0.)*x
,(1.,0.)*a
,'CSQRT')
399 subroutine exponential
400 intrinsic exp
, dexp
, cexp
404 call c_r
(EXP
(x
),a
,'EXP(real)')
405 call c_d
(EXP
(1.d0*x
),1.d0*a
,'EXP(double)')
406 call c_c
(EXP
((1.,0.)*x
),(1.,0.)*a
,'EXP(complex)')
407 call c_d
(DEXP
(1.d0*x
),1.d0*a
,'DEXP(double)')
408 call c_c
(CEXP
((1.,0.)*x
),(1.,0.)*a
,'CEXP(complex)')
409 call p_r_r
(EXP
,x
,a
,'EXP')
410 call p_d_d
(DEXP
,1.d0*x
,1.d0*a
,'DEXP')
411 call p_c_c
(CEXP
,(1.,0.)*x
,(1.,0.)*a
,'CEXP')
414 subroutine natural_logarithm
415 intrinsic alog
, dlog
, clog
419 call c_r
(LOG
(x
),a
,'LOG(real)')
420 call c_d
(LOG
(1.d0*x
),1.d0*a
,'LOG(double)')
421 call c_c
(LOG
((1.,0.)*x
),(1.,0.)*a
,'LOG(complex)')
422 call c_r
(ALOG
(x
),a
,'ALOG(real)')
423 call c_d
(DLOG
(1.d0*x
),1.d0*a
,'DLOG(double)')
424 call c_c
(CLOG
((1.,0.)*x
),(1.,0.)*a
,'CLOG(complex)')
425 call p_r_r
(ALOG
,x
,a
,'LOG')
426 call p_d_d
(DLOG
,1.d0*x
,1.d0*a
,'DLOG')
427 call p_c_c
(CLOG
,(1.,0.)*x
,(1.,0.)*a
,'CLOG')
430 subroutine common_logarithm
431 intrinsic alog10
, dlog10
435 call c_r
(LOG10
(x
),a
,'LOG10(real)')
436 call c_d
(LOG10
(1.d0*x
),1.d0*a
,'LOG10(double)')
437 call c_r
(ALOG10
(x
),a
,'ALOG10(real)')
438 call c_d
(DLOG10
(1.d0*x
),1.d0*a
,'DLOG10(double)')
439 call p_r_r
(ALOG10
,x
,a
,'ALOG10')
440 call p_d_d
(DLOG10
,1.d0*x
,1.d0*a
,'DLOG10')
444 intrinsic sin
, dsin
, csin
448 call c_r
(SIN
(x
),a
,'SIN(real)')
449 call c_d
(SIN
(1.d0*x
),1.d0*a
,'SIN(double)')
450 call c_c
(SIN
((1.,0.)*x
),(1.,0.)*a
,'SIN(complex)')
451 call c_d
(DSIN
(1.d0*x
),1.d0*a
,'DSIN(double)')
452 call c_c
(CSIN
((1.,0.)*x
),(1.,0.)*a
,'CSIN(complex)')
453 call p_r_r
(SIN
,x
,a
,'SIN')
454 call p_d_d
(DSIN
,1.d0*x
,1.d0*a
,'DSIN')
455 call p_c_c
(CSIN
,(1.,0.)*x
,(1.,0.)*a
,'CSIN')
459 intrinsic cos
, dcos
, ccos
463 call c_r
(COS
(x
),a
,'COS(real)')
464 call c_d
(COS
(1.d0*x
),1.d0*a
,'COS(double)')
465 call c_c
(COS
((1.,0.)*x
),(1.,0.)*a
,'COS(complex)')
466 call c_r
(COS
(x
),a
,'COS(real)')
467 call c_d
(DCOS
(1.d0*x
),1.d0*a
,'DCOS(double)')
468 call c_c
(CCOS
((1.,0.)*x
),(1.,0.)*a
,'CCOS(complex)')
469 call p_r_r
(COS
,x
,a
,'COS')
470 call p_d_d
(DCOS
,1.d0*x
,1.d0*a
,'DCOS')
471 call p_c_c
(CCOS
,(1.,0.)*x
, (1.,0.)*a
,'CCOS')
479 call c_r
(TAN
(x
),a
,'TAN(real)')
480 call c_d
(TAN
(1.d0*x
),1.d0*a
,'TAN(double)')
481 call c_d
(DTAN
(1.d0*x
),1.d0*a
,'DTAN(double)')
482 call p_r_r
(TAN
,x
,a
,'TAN')
483 call p_d_d
(DTAN
,1.d0*x
,1.d0*a
,'DTAN')
487 intrinsic asin
, dasin
491 call c_r
(ASIN
(x
),a
,'ASIN(real)')
492 call c_d
(ASIN
(1.d0*x
),1.d0*a
,'ASIN(double)')
493 call c_d
(DASIN
(1.d0*x
),1.d0*a
,'DASIN(double)')
494 call p_r_r
(ASIN
,x
,a
,'ASIN')
495 call p_d_d
(DASIN
,1.d0*x
,1.d0*a
,'DASIN')
499 intrinsic acos
, dacos
503 call c_r
(ACOS
(x
),a
,'ACOS(real)')
504 call c_d
(ACOS
(1.d0*x
),1.d0*a
,'ACOS(double)')
505 call c_d
(DACOS
(1.d0*x
),1.d0*a
,'DACOS(double)')
506 call p_r_r
(ACOS
,x
,a
,'ACOS')
507 call p_d_d
(DACOS
,1.d0*x
,1.d0*a
,'DACOS')
510 subroutine arctangent
511 intrinsic atan
, atan2
, datan
, datan2
516 call c_r
(ATAN
(x1
),a
,'ATAN(real)')
517 call c_d
(ATAN
(1.d0*x1
),1.d0*a
,'ATAN(double)')
518 call c_d
(DATAN
(1.d0*x1
),1.d0*a
,'DATAN(double)')
519 call c_r
(ATAN2
(x1
,x2
),a
,'ATAN2(real)')
520 call c_d
(ATAN2
(1.d0*x1
,1.d0*x2
),1.d0*a
,'ATAN2(double)')
521 call c_d
(DATAN2
(1.d0*x1
,1.d0*x2
),1.0d0*a
,'DATAN2(double)')
522 call p_r_r
(ATAN
,x1
,a
,'ATAN')
523 call p_d_d
(DATAN
,1.d0*x1
,1.d0*a
,'DATAN')
524 call p_r_rr
(ATAN2
,x1
,x2
,a
,'ATAN2')
525 call p_d_dd
(DATAN2
,1.d0*x1
,1.d0*x2
,1.d0*a
,'DATAN2')
528 subroutine hyperbolic_sine
529 intrinsic sinh
, dsinh
533 call c_r
(SINH
(x
),a
,'SINH(real)')
534 call c_d
(SINH
(1.d0*x
),1.d0*a
,'SINH(double)')
535 call c_d
(DSINH
(1.d0*x
),1.d0*a
,'DSINH(double)')
536 call p_r_r
(SINH
,x
,a
,'SINH')
537 call p_d_d
(DSINH
,1.d0*x
,1.d0*a
,'DSINH')
540 subroutine hyperbolic_cosine
541 intrinsic cosh
, dcosh
545 call c_r
(COSH
(x
),a
,'COSH(real)')
546 call c_d
(COSH
(1.d0*x
),1.d0*a
,'COSH(double)')
547 call c_d
(DCOSH
(1.d0*x
),1.d0*a
,'DCOSH(double)')
548 call p_r_r
(COSH
,x
,a
,'COSH')
549 call p_d_d
(DCOSH
,1.d0*x
,1.d0*a
,'DCOSH')
552 subroutine hyperbolic_tangent
553 intrinsic tanh
, dtanh
557 call c_r
(TANH
(x
),a
,'TANH(real)')
558 call c_d
(TANH
(1.d0*x
),1.d0*a
,'TANH(double)')
559 call c_d
(DTANH
(1.d0*x
),1.d0*a
,'DTANH(double)')
560 call p_r_r
(TANH
,x
,a
,'TANH')
561 call p_d_d
(DTANH
,1.d0*x
,1.d0*a
,'DTANH')
564 subroutine lexically_greater_than_or_equal
565 call c_l
(LGE
('A','B'),.FALSE
.,'LGE(character,character) 1')
566 call c_l
(LGE
('B','A'),.TRUE
.,'LGE(character,character) 2')
567 call c_l
(LGE
('A','A'),.TRUE
.,'LGE(character,character) 3')
570 subroutine lexically_greater_than
571 call c_l
(LGT
('A','B'),.FALSE
.,'LGT(character,character) 1')
572 call c_l
(LGT
('B','A'),.TRUE
.,'LGT(character,character) 2')
573 call c_l
(LGT
('A','A'),.FALSE
.,'LGT(character,character) 3')
576 subroutine lexically_less_than_or_equal
577 call c_l
(LLE
('A','B'),.TRUE
.,'LLE(character,character) 1')
578 call c_l
(LLE
('B','A'),.FALSE
.,'LLE(character,character) 2')
579 call c_l
(LLE
('A','A'),.TRUE
.,'LLE(character,character) 3')
582 subroutine lexically_less_than
583 call c_l
(LLT
('A','B'),.TRUE
.,'LLT(character,character) 1')
584 call c_l
(LLT
('B','A'),.FALSE
.,'LLT(character,character) 2')
585 call c_l
(LLT
('A','A'),.FALSE
.,'LLT(character,character) 3')