1! PR 14396 2! These we failing on targets which do not provide the c99 complex math 3! functions. 4! Extracted from intrinsic77.f in the g77 testsuite. 5 logical fail 6 common /flags/ fail 7 fail = .false. 8 call square_root 9 if (fail) STOP 1 10 end 11 subroutine square_root 12 intrinsic sqrt, dsqrt, csqrt 13 real x, a 14 x = 4.0 15 a = 2.0 16 call c_r(SQRT(x),a,'SQRT(real)') 17 call c_d(SQRT(1.d0*x),1.d0*a,'SQRT(double)') 18 call c_c(SQRT((1.,0.)*x),(1.,0.)*a,'SQRT(complex)') 19 call c_d(DSQRT(1.d0*x),1.d0*a,'DSQRT(double)') 20 call c_c(CSQRT((1.,0.)*x),(1.,0.)*a,'CSQRT(complex)') 21 call p_r_r(SQRT,x,a,'SQRT') 22 call p_d_d(DSQRT,1.d0*x,1.d0*a,'DSQRT') 23 call p_c_c(CSQRT,(1.,0.)*x,(1.,0.)*a ,'CSQRT') 24 end 25 subroutine failure(label) 26! Report failure and set flag 27 character*(*) label 28 logical fail 29 common /flags/ fail 30 write(6,'(a,a,a)') 'Test ',label,' FAILED' 31 fail = .true. 32 end 33 subroutine c_r(a,b,label) 34! Check if REAL a equals b, and fail otherwise 35 real a, b 36 character*(*) label 37 if ( abs(a-b) .gt. 1.0e-5 ) then 38 call failure(label) 39 write(6,*) 'Got ',a,' expected ', b 40 end if 41 end 42 subroutine c_d(a,b,label) 43! Check if DOUBLE PRECISION a equals b, and fail otherwise 44 double precision a, b 45 character*(*) label 46 if ( abs(a-b) .gt. 1.0d-5 ) then 47 call failure(label) 48 write(6,*) 'Got ',a,' expected ', b 49 end if 50 end 51 52 subroutine c_c(a,b,label) 53! Check if COMPLEX a equals b, and fail otherwise 54 complex a, b 55 character*(*) label 56 if ( abs(a-b) .gt. 1.0e-5 ) then 57 call failure(label) 58 write(6,*) 'Got ',a,' expected ', b 59 end if 60 end 61 subroutine p_r_r(f,x,a,label) 62! Check if REAL f(x) equals a for REAL x 63 real f,x,a 64 character*(*) label 65 call c_r(f(x),a,label) 66 end 67 subroutine p_d_d(f,x,a,label) 68! Check if DOUBLE PRECISION f(x) equals a for DOUBLE PRECISION x 69 double precision f,x,a 70 character*(*) label 71 call c_d(f(x),a,label) 72 end 73 subroutine p_c_c(f,x,a,label) 74! Check if COMPLEX f(x) equals a for COMPLEX x 75 complex f,x,a 76 character*(*) label 77 call c_c(f(x),a,label) 78 end 79