Program x07aafe

!     X07AAF Example Program Text

!     Mark 30.1 Release. NAG Copyright 2024.

!     .. Use Statements ..
      Use nag_library, Only: nag_wp, x02alf, x07aaf, x07abf, x07baf, x07bbf,   &
                             x07caf, x07cbf
!     .. Implicit None Statement ..
      Implicit None
!     .. Parameters ..
      Integer, Parameter               :: nout = 6
!     .. Local Scalars ..
      Real (Kind=nag_wp)               :: huge, neginf, qnan, x, y, zero
!     .. Local Arrays ..
      Integer                          :: exmode(3), newexmode(3)
!     .. Executable Statements ..
      Write (nout,*) 'X07AAF Example Program Results'
      Write (nout,*)

!     Turn exception halting mode off for the three common exceptions
!     overflow, division-by-zero, and invalid operation
      Write (nout,*) 'Turn exception halting off ...'
      exmode = (/0,0,0/)
      Call x07cbf(exmode)

!     Check that exception halting mode for the three common exceptions
!     was really turned off
      Call x07caf(newexmode)
      Write (nout,99999) 'Exception halting mode is now: ', newexmode

!     Look at some ordinary numbers
      x = 1.0_nag_wp
      Call diagnose('one',x)
      x = -2.0_nag_wp
      Call diagnose('-two',x)
      zero = 0.0_nag_wp
      Call diagnose('zero',zero)

!     Generate an infinity and a NaN and look at their properties
      Call x07baf(-1,neginf)
      Call diagnose('-Infinity',neginf)
      Call x07bbf(1,qnan)
      Call diagnose('Quiet NaN',qnan)

!     Do some operations which purposely raise exceptions
      huge = x02alf()
      Write (nout,*)
      Write (nout,*) 'Try to cause overflow - no trap should occur:'
      x = huge
      y = x*x
      If (y>huge) Then
        Write (nout,99998) 'y = huge() * huge() > huge() '
      Else
        Write (nout,99998) 'y = huge() * huge() = ', y
      End If

      Write (nout,*)
      Write (nout,*) 'Try to cause NaN - no trap should occur:'
      y = zero/zero
      If (x07abf(y)) Then
        Write (nout,99998) 'y = 0.0 / 0.0 = NaN'
      Else
        Write (nout,99998) 'y = 0.0 / 0.0 = ', y
      End If

      Write (nout,*)
      Write (nout,*) 'Try to cause division by zero - no trap should occur:'
      x = 1.0_nag_wp
      y = x/zero
      If (y>huge) Then
        Write (nout,99998) 'y = 1.0 / 0.0 > huge()'
      Else
        Write (nout,99998) 'y = 1.0 / 0.0 = ', y
      End If

99999 Format (1X,A,3I3)
99998 Format (1X,A,1P,E12.4)

    Contains

      Subroutine diagnose(c,x)

!       .. Implicit None Statement ..
        Implicit None
!       .. Scalar Arguments ..
        Real (Kind=nag_wp), Intent (In) :: x
        Character (*), Intent (In)     :: c
!       .. Executable Statements ..
        Write (nout,*)
        If (c=='-Infinity') Then
          Write (nout,99999) c
        Else
          Write (nout,99998) c, x
        End If

        If (x07aaf(x)) Then
          Write (nout,*) '"' // c // '" is finite'
        Else
          Write (nout,*) '"' // c // '" is not finite'
        End If
        If (x07abf(x)) Then
          Write (nout,*) '"' // c // '" is NaN'
        Else
          Write (nout,*) '"' // c // '" is not NaN'
        End If

        If (x<0.0_nag_wp) Then
          Write (nout,*) '"' // c // '" compares less than zero.'
        Else
          Write (nout,*) '"' // c // '" does not compare less than zero.'
        End If
        If (x==0.0_nag_wp) Then
          Write (nout,*) '"' // c // '" compares equal to zero.'
        Else
          Write (nout,*) '"' // c // '" does not compare equal to zero.'
        End If
        If (x>0.0_nag_wp) Then
          Write (nout,*) '"' // c // '" compares greater than zero.'
        Else
          Write (nout,*) '"' // c // '" does not compare greater than zero.'
        End If

        Return

99999   Format (1X,'Diagnosis of value "',A,'"')
99998   Format (1X,'Diagnosis of value "',A,'" which prints as ',1P,E12.4)

      End Subroutine diagnose

    End Program x07aafe