!-----------------------------------------------------------------------
! Support file for IEEE/EEEI/VAX arithmetics
! Should use Fortran 2003 IEEE_ARITHMETIC module at some point!
!-----------------------------------------------------------------------
subroutine gag_notanum4(notanum)
  !---------------------------------------------------------------------
  ! @ public-generic gag_notanum
  ! Return the value of NaN (R*4 version)]
  !  An IEEE signaling NaN is represented by any bit pattern
  !    between X'7F80 0001' and X'7FBF FFFF', or
  !    between X'FF80 0001' and X'FFBF FFFF'.
  !  An IEEE quiet NaN is represented by any bit pattern
  !    between X'7FC0 0000' and X'7FFF FFFF', or
  !    between X'FFC0 0000' and X'FFFF FFFF'.
  !---------------------------------------------------------------------
  real(kind=4), intent(out) :: notanum  ! NaN value
  ! Local
  real(kind=4) :: nan
#if defined(EEEI)
  data nan /Z'7FA00000'/
#endif
#if defined(IEEE)
  data nan /Z'FFC00000'/
#endif
#if defined(VAX)
  data nan /-1e38/               ! Not supported by VAX, so arbitrary
#endif
  notanum=nan
end subroutine gag_notanum4
!
subroutine gag_notanum8(notanum)
  !---------------------------------------------------------------------
  ! @ public-generic gag_notanum
  ! Return the value of NaN (R*8 version)
  !  An IEEE signaling NaN is represented by any bit pattern
  !    between X'7FF00000 00000001' and X'7FF7FFFF FFFFFFFF', or
  !    between X'FFF00000 00000001' and X'FFF7FFFF FFFFFFFF'.
  !  An IEEE quiet NaN is represented by any bit pattern
  !    between X'7FF80000 00000000' and X'7FFFFFFF FFFFFFFF', or
  !    between X'FFF80000 00000000' and X'FFFFFFFF FFFFFFFF'.
  !---------------------------------------------------------------------
  real(kind=8), intent(out) :: notanum  ! NaN value
  ! Local
  real(kind=8) :: nan
#if defined(EEEI)
  data nan /Z'7FA00000'/         ! Unknown !?
#endif
#if defined(IEEE)
  data nan /Z'7FF8000000000000'/
#endif
#if defined(VAX)
  data nan /-1d38/               ! Not supported by VAX, so arbitrary
#endif
  notanum=nan
end subroutine gag_notanum8
!
function gag_isreal (anum)
  !---------------------------------------------------------------------
  ! @ no-interface (because of argument type mismatch)
  ! Return 0 if the number is a Real number,
  ! 1 if +Inf, 2 if -Inf, 3 if NaN
  ! An IEEE positive infinity is represented by the bit pattern X'7F80 0000'.
  ! An IEEE negative infinity is represented by the bit pattern X'FF80 0000'.
  !---------------------------------------------------------------------
  integer(kind=4) :: gag_isreal           ! intent(out)
  integer(kind=4), intent(in) :: anum     ! Place Holder for Real(4) number
  ! Local
  integer(kind=4) :: pinf,minf,nan,expo
  ! Datas.
#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 function gag_isreal
!
function gag_isdble (anum)
  !---------------------------------------------------------------------
  ! @ no-interface (because of argument type mismatch)
  ! Return 0 if the number is a Dble number,
  ! 1 if +Inf, 2 if -Inf, 3 if NaN
  ! An IEEE positive infinity is represented by the bit pattern X'7FF00000 00000000'.
  ! An IEEE negative infinity is represented by the bit pattern X'FFF00000 00000000'.
  !---------------------------------------------------------------------
  integer(kind=4) :: gag_isdble           ! intent(out)
  integer(kind=4), intent(in) :: anum(2)  ! Place holder for Real*8 number
  ! Local
  integer(kind=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
  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 function gag_isdble
!
subroutine gag_infini4(anum,string,ndg)
  use gsys_interfaces, except_this=>gag_infini4
  !---------------------------------------------------------------------
  ! @ public-generic gag_infini
  ! Format Invalid Numbers (single precision version)
  !---------------------------------------------------------------------
  real(kind=4),     intent(in)  :: anum    ! Number
  character(len=*), intent(out) :: string  ! Representation
  integer(kind=4),  intent(out) :: ndg     ! Length of string
  ! Local
  integer(kind=4) :: i
  integer(kind=4), parameter :: lc(0:3) = (/ 0,4,4,3 /)
  character(len=4), parameter :: chain(0:3) = (/ '    ','+Inf','-Inf','NaN ' /)
  !
  i = gag_isreal(anum)
  string = chain(i)
  ndg = lc(i)
end subroutine gag_infini4
!
subroutine gag_infini8(anum,string,ndg)
  use gsys_interfaces, except_this=>gag_infini8
  !---------------------------------------------------------------------
  ! @ public-generic gag_infini
  ! Format Invalid Numbers (double precision version)
  !---------------------------------------------------------------------
  real(kind=8),     intent(in)  :: anum    ! Number
  character(len=*), intent(out) :: string  ! Representation
  integer(kind=4),  intent(out) :: ndg     ! Length of string
  ! Local
  integer(kind=4) :: i
  integer(kind=4), parameter :: lc(0:3) = (/ 0,4,4,3 /)
  character(len=4), parameter :: chain(0:3) = (/ '    ','+Inf','-Inf','NaN ' /)
  !
  i = gag_isdble(anum)
  string = chain(i)
  ndg = lc(i)
end subroutine gag_infini8
