module nan
  !---------------------------------------------------------------------
  ! Return the value of NaN
  ! Single Precision
  !---------------------------------------------------------------------
  real(4) :: s_nan
  integer(4) :: j_nan
  equivalence (j_nan,s_nan)
  real(4) :: s_pinf
  integer(4) :: j_pinf
  equivalence (j_pinf,s_pinf)
  real(4) :: s_minf
  integer(4) :: j_minf
  equivalence (j_minf,s_minf)
  !
  ! Double Precision constant
  real(8) :: d_nan
  integer(4) :: i_nan(2)
  equivalence (i_nan,d_nan)
  real(8) :: d_pinf
  integer(4) :: i_pinf(2)
  equivalence (i_pinf,d_pinf)
  real(8) :: d_minf
  integer(4) :: i_minf(2)
  equivalence (i_minf,d_minf)
#if defined(EEEI)
  ! Working
  data j_nan /z'7FA00000'/
  data j_pinf /z'7F800000'/
  data j_minf /z'FF800000'/
  ! Not checked yet...
  data i_nan /z'7FF40000',0/
  data i_pinf /z'7FF00000',0/
  data i_minf /z'FFF00000',0/
#endif
#if defined(IEEE)
  ! Working
  data j_nan /z'FFC00000'/
  data j_pinf /z'7F800000'/
  data j_minf /z'FF800000'/
  data i_nan /0,z'7FF40000'/
  data i_pinf /0,z'7FF00000'/
  data i_minf /0,z'FFF00000'/
#endif
#if defined(VAX)
  data s_nan /-1e38/           ! Not supported by VAX, so arbitrary
  data d_nan /-1d38/           ! Not supported by VAX, so arbitrary
  data d_pinf /1d38/
  data d_minf /-1d38/
#endif
end module   nan
!<FF>
function gag_isreal (anum)
  !---------------------------------------------------------------------
  ! Return 0 if the number is a Real number,
  ! 1 if +Inf, 2 if -Inf, 3 if NaN
  !---------------------------------------------------------------------
  integer*4 :: gag_isreal           !
  integer*4 :: anum                 !
  ! Local
  integer*4 :: pinf,minf,nan,expo
  ! Data
#if defined(EEEI)
  data nan /z'7FA00000'/
#endif
#if defined(IEEE)
  data nan /z'FFC00000'/
#endif
  data pinf /z'7F800000'/
  data minf /z'FF800000'/
  !
  gag_isreal = 0
  if (anum.eq.pinf) then
    gag_isreal = 1
  elseif (anum.eq.minf) then
    gag_isreal = 2
  else
    expo = iand(anum,nan)
    if (expo.eq.nan) then
      gag_isreal = 3
    else
      gag_isreal = 0
    endif
  endif
end
!<FF>
function gag_isdble (anum)
  !---------------------------------------------------------------------
  ! Return 0 if the number is a Dble number,
  ! 1 if +Inf, 2 if -Inf, 3 if NaN
  !---------------------------------------------------------------------
  integer*4 :: gag_isdble           !
  integer*4 :: anum(2)              !
  ! Local
  integer*4 :: pinf(2),minf(2),nan,expo,imant
  !
  ! Note: Fortran-95 norm says a BOZ constant is an INTEGER*8,
  ! and only valid in a data statement for an integer, but
  ! INTEGER*8 is not supported by every compiler/system...
#if defined(EEEI)
  ! HP-Like TO BE TESTED
  data nan /z'7FF00000'/       ! not 7FF4000, at least on IEEE
  data imant /1/
  data pinf /z'7FF00000',0/
  data minf /z'FFF00000',0/
#endif
#if defined(IEEE)
  ! Intel-Like FULLY FUNCTIONAL (like PCs)
  data nan /z'7FF00000'/       ! not 7FF4000 ...
  data imant /2/
  data pinf /0,z'7FF00000'/
  data minf /0,z'FFF00000'/
#endif
  !
  if (anum(1).eq.pinf(1).and.anum(2).eq.pinf(2)) then
    gag_isdble = 1
  elseif (anum(1).eq.minf(1).and.anum(2).eq.minf(2)) then
    gag_isdble = 2
  else
    expo = iand(anum(imant),nan)
    !!         write(6,'(1x,Z8.8,1x,Z8.8)') expo,nan
    if (expo.eq.nan) then
      gag_isdble = 3
    else
      gag_isdble = 0
    endif
  endif
end
!
program test
  use nan
  ! Global
  integer :: gag_isreal,gag_isdble
  ! Local
  real(4) :: a,c
  real(8) :: b
  integer :: ia,ib(2)
  equivalence (a,ia),(b,ib)
  ! REAL
  c = 0.
  a = 1./c
  print *,"Should be +Inf   1   +Inf"
  print *,a,gag_isreal(a),s_pinf
  print '(Z8.8)',ia
  !
  a = -1./c
  print *,"Should be -Inf   2   -Inf"
  print *,a,gag_isreal(a),s_minf
  print '(Z8.8)',ia
  !
  c = -1
  a = sqrt(c)
  print *,"Should be Nan 3 Nan "
  print *,a,gag_isreal(a),s_nan
  print '(Z8.8)',ia
  !
  ! Now DBLE
  c = 0.
  b = 1./c
  print *,"Should be +Inf   1   +Inf"
  print *,b,gag_isdble(b),d_pinf
  print '(Z8.8,Z8.8)',ib
  !
  b = -1./c
  print *,"Should be -Inf   2   -Inf"
  print *,b,gag_isdble(b),d_minf
  print '(Z8.8,Z8.8)',ib
  !
  c = -1
  b = sqrt(c)
  print *,"Should be Nan 3 Nan "
  print *,b,gag_isdble(b),d_nan
  print '(Z8.8,Z8.8)',ib
  !
end program test
