Skip to content

Commit 9696a00

Browse files
perazzperazz
committed
ieeeck: use ieee_arithmetic 
1 parent a541801 commit 9696a00

File tree

2 files changed

+18
-138
lines changed

2 files changed

+18
-138
lines changed

‎fypp/src/la_lapack_aux.fypp

Lines changed: 12 additions & 72 deletions
Original file line numberDiff line numberDiff line change
@@ -2,6 +2,7 @@
22
module la_lapack_aux
33
use la_constants
44
use la_blas
5+
use ieee_arithmetic, only: ieee_support_nan, ieee_support_inf
56
implicit none(type,external)
67
private
78

@@ -249,87 +250,26 @@ module la_lapack_aux
249250
!> IEEECK: is called from the ILAENV to verify that Infinity and
250251
!> possibly NaN arithmetic is safe (i.e. will not trap).
251252

252-
pure integer(ilp) function la_ieeeck( ispec, zero, one )
253+
pure integer(ilp) function la_ieeeck(ispec,zero,one)
253254
! -- lapack auxiliary routine --
254255
! -- lapack is a software package provided by univ. of tennessee, --
255256
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
256-
! Scalar Arguments
257-
integer(ilp), intent(in) :: ispec
258-
real(sp), intent(in) :: one, zero
257+
! Scalar Arguments
258+
integer(ilp),intent(in) :: ispec
259+
real(sp),intent(in) :: one,zero
259260
! =====================================================================
260-
! Local Scalars
261-
real(sp) :: nan1, nan2, nan3, nan4, nan5, nan6, neginf, negzro, newzro, posinf
262-
! Executable Statements
261+
! Executable Statements
263262
la_ieeeck = 1
264-
posinf = one / zero
265-
if( posinf<=one ) then
266-
la_ieeeck = 0
267-
return
268-
end if
269-
neginf = -one / zero
270-
if( neginf>=zero ) then
271-
la_ieeeck = 0
272-
return
273-
end if
274-
negzro = one / ( neginf+one )
275-
if( negzro/=zero ) then
276-
la_ieeeck = 0
277-
return
278-
end if
279-
neginf = one / negzro
280-
if( neginf>=zero ) then
281-
la_ieeeck = 0
282-
return
283-
end if
284-
newzro = negzro + zero
285-
if( newzro/=zero ) then
286-
la_ieeeck = 0
287-
return
288-
end if
289-
posinf = one / newzro
290-
if( posinf<=one ) then
291-
la_ieeeck = 0
292-
return
293-
end if
294-
neginf = neginf*posinf
295-
if( neginf>=zero ) then
296-
la_ieeeck = 0
297-
return
298-
end if
299-
posinf = posinf*posinf
300-
if( posinf<=one ) then
263+
264+
! Test support for infinity values
265+
if (.not.ieee_support_inf(one)) then
301266
la_ieeeck = 0
302267
return
303268
end if
269+
304270
! return if we were only asked to check infinity arithmetic
305-
if( ispec==0 )return
306-
nan1 = posinf + neginf
307-
nan2 = posinf / neginf
308-
nan3 = posinf / posinf
309-
nan4 = posinf*zero
310-
nan5 = neginf*negzro
311-
nan6 = nan5*zero
312-
if( nan1==nan1 ) then
313-
la_ieeeck = 0
314-
return
315-
end if
316-
if( nan2==nan2 ) then
317-
la_ieeeck = 0
318-
return
319-
end if
320-
if( nan3==nan3 ) then
321-
la_ieeeck = 0
322-
return
323-
end if
324-
if( nan4==nan4 ) then
325-
la_ieeeck = 0
326-
return
327-
end if
328-
if( nan5==nan5 ) then
329-
la_ieeeck = 0
330-
return
331-
end if
332-
if( nan6==nan6 ) then
271+
if (ispec == 0) return
272+
if (.not.ieee_support_nan(one)) then
333273
la_ieeeck = 0
334274
return
335275
end if

‎src/la_lapack_aux.f90

Lines changed: 6 additions & 66 deletions
Original file line numberDiff line numberDiff line change
@@ -1,6 +1,7 @@
11
module la_lapack_aux
22
use la_constants
33
use la_blas
4+
use ieee_arithmetic, only: ieee_support_inf, ieee_support_nan
45
implicit none(type,external)
56
private
67

@@ -239,79 +240,18 @@ pure integer(ilp) function la_ieeeck(ispec,zero,one)
239240
integer(ilp),intent(in) :: ispec
240241
real(sp),intent(in) :: one,zero
241242
! =====================================================================
242-
! Local Scalars
243-
real(sp) :: nan1,nan2,nan3,nan4,nan5,nan6,neginf,negzro,newzro,posinf
244243
! Executable Statements
245244
la_ieeeck = 1
246-
posinf = one/zero
247-
if (posinf <= one) then
248-
la_ieeeck = 0
249-
return
250-
end if
251-
neginf = -one/zero
252-
if (neginf >= zero) then
253-
la_ieeeck = 0
254-
return
255-
end if
256-
negzro = one/(neginf + one)
257-
if (negzro /= zero) then
258-
la_ieeeck = 0
259-
return
260-
end if
261-
neginf = one/negzro
262-
if (neginf >= zero) then
263-
la_ieeeck = 0
264-
return
265-
end if
266-
newzro = negzro + zero
267-
if (newzro /= zero) then
268-
la_ieeeck = 0
269-
return
270-
end if
271-
posinf = one/newzro
272-
if (posinf <= one) then
273-
la_ieeeck = 0
274-
return
275-
end if
276-
neginf = neginf*posinf
277-
if (neginf >= zero) then
278-
la_ieeeck = 0
279-
return
280-
end if
281-
posinf = posinf*posinf
282-
if (posinf <= one) then
245+
246+
! Test support for infinity values
247+
if (.not.ieee_support_inf(one)) then
283248
la_ieeeck = 0
284249
return
285250
end if
251+
286252
! return if we were only asked to check infinity arithmetic
287253
if (ispec == 0) return
288-
nan1 = posinf + neginf
289-
nan2 = posinf/neginf
290-
nan3 = posinf/posinf
291-
nan4 = posinf*zero
292-
nan5 = neginf*negzro
293-
nan6 = nan5*zero
294-
if (nan1 == nan1) then
295-
la_ieeeck = 0
296-
return
297-
end if
298-
if (nan2 == nan2) then
299-
la_ieeeck = 0
300-
return
301-
end if
302-
if (nan3 == nan3) then
303-
la_ieeeck = 0
304-
return
305-
end if
306-
if (nan4 == nan4) then
307-
la_ieeeck = 0
308-
return
309-
end if
310-
if (nan5 == nan5) then
311-
la_ieeeck = 0
312-
return
313-
end if
314-
if (nan6 == nan6) then
254+
if (.not.ieee_support_nan(one)) then
315255
la_ieeeck = 0
316256
return
317257
end if

0 commit comments

Comments
 (0)