Vectronix 2/VECTRONIX2.iso/FILES_01/P_FOTRAN.LZH/68881/CSDEMO.FOR

Text File | 1987-12-31 | 5KB | 188 lines

      PROGRAM csdemo

*     Demonstration of get/set FPCR/FPSR procedures supplied with
*     Prospero Fortran for GEM - MC68881 Floating-Point Coprocessor
*     Library.

*     This program is intended to be linked with the libraries
*     FIRST8.BIN and F77LIB8.BIN as per the supplied notes.

*     Author: A.T.Cook, 27 June 1988

      INCLUDE 'csr8'

      write (*,*) 'Pro Fortran CSDEMO Demonstration Program'
      write (*,*) '========================================'
      write (*,*)
      call FPCR_demo
      write (*,*)
      call FPSR_demo
      END
!
!
      LOGICAL FUNCTION ovfl ()      !Return FPSR_overflow setting

      INCLUDE 'csr8'
      INTEGER*4 fpsr, overflow_flag

      call getsr8 (fpsr)
      overflow_flag = fpsr .AND. FPSR_overflow
      ovfl = overflow_flag .NE. 0
      END
!
!
      LOGICAL FUNCTION dz ()        !Return FPSR_divide_by_zero setting

      INCLUDE 'csr8'
      INTEGER*4 fpsr, divzero_flag

      call getsr8 (fpsr)
      divzero_flag = fpsr .AND. FPSR_divide_by_zero
      dz = divzero_flag .NE. 0
      END
!
!
      SUBROUTINE clear_ovfl      !Clear FPSR_overflow

      INCLUDE 'csr8'
      INTEGER*4 fpsr, overflow_mask

      call getsr8 (fpsr)
      overflow_mask = .NOT. FPSR_overflow
      call setsr8 (fpsr .AND. overflow_mask)
      END
!
!
      SUBROUTINE clear_dz        !Clear FPSR_divide_by_zero

      INCLUDE 'csr8'
      INTEGER*4 fpsr, divzero_mask

      call getsr8 (fpsr)
      divzero_mask = .NOT. FPSR_divide_by_zero
      call setsr8 (fpsr .AND. divzero_mask)
      END
!
!
      SUBROUTINE show_FPCR (title)       !Show current FPCR mode
!                                         control byte
      CHARACTER*(*) title

      INCLUDE 'csr8'
      INTEGER FPCR_RND, FPCR_PREC

      PARAMETER (FPCR_RND  = $30,    !To mask off rounding mode field
     1           FPCR_PREC = $C0)    !To mask off rounding precision

      INTEGER*4 fpcr, rounding, precision

      write (*,*) title
      call getcr8 (fpcr)
      write (*,100) 'FPCR Rounding Mode: '

      rounding = fpcr .AND. FPCR_RND
      IF (rounding .EQ. FPCR_to_nearest) THEN
         write (*,100) 'to nearest'
         ELSE IF (rounding .EQ. FPCR_toward_zero) THEN
         write (*,100) 'toward zero'
         ELSE IF (rounding .EQ. FPCR_toward_minus_infinity) THEN
         write (*,100) 'toward minus infinity'
         ELSE IF (rounding .EQ. FPCR_toward_plus_infinity) THEN
         write (*,100) 'toward plus infinity'
      ENDIF

      write (*,100) ', Rounding precision: '

      precision = fpcr .AND. FPCR_PREC
      IF (precision .EQ. FPCR_extended) THEN
         write (*,101) 'extended'
         ELSE IF (precision .EQ. FPCR_extended) THEN
         write (*,101) 'extended'
         ELSE IF (precision .EQ. FPCR_single) THEN
         write (*,101) 'single'
         ELSE IF (precision .EQ. FPCR_double) THEN
         write (*,101) 'double'
         ELSE
         write (*,101) 'undefined !!!'
      ENDIF

  100 FORMAT(1X,A,\)
  101 FORMAT(1X,A)
      END
!
!
      SUBROUTINE show_FPSR (title)       !Show current FPSR
!                                         accrued exceptions
      CHARACTER*(*) title
      INTEGER*4 fpsr
      LOGICAL ovfl, dz

      INCLUDE 'csr8'

      write (*,*) title
      call getsr8 (fpsr)
      write (*,*) 'FPSR accrued exceptions: ',
     1            'OVFL=',ovfl(), ', DZ=',dz()

      END

      SUBROUTINE FPCR_demo

      INCLUDE 'csr8'

      write (*,*) 'Accessing the FPCR'
      write (*,*) '=================='
      write (*,*)

      call show_FPCR ('Initial FPCR settings:-')

!     Now set the FPCR to other values and display them

      call setcr8 (FPCR_toward_minus_infinity + FPCR_double)
      call show_FPCR ('Should be toward minus infinity and double:-')

!     Now set the FPCR back to normal

      call setcr8 (0)
      call show_FPCR ('Should be to nearest and extended:-')

      END
!
!
      SUBROUTINE FPSR_demo

      INCLUDE 'csr8'

      REAL large_real, x, y, z
      PARAMETER (large_real = 1.0E+30)

      write (*,*) 'Accessing the FPSR'
      write (*,*) '=================='
      write (*,*)

      call show_FPSR ('Initial FPSR settings:-')

!     Now cause an overflow condition and detect it

      x = large_real
      y = large_real
      z = x * y
      call show_FPSR ('Should show overflow:-')

!     Now cause a divide by zero and detect it, showing that the
!     previous overflow condition is still set because the status
!     is accrued}

      y = 0.0
      z = x / y
      call show_FPSR ('Should show overflow and divide by zero:-')

!     Now set the FPSR back to normal

      call setsr8 (0) !clear the accrued status bits
      call show_FPSR ('Should have no status set:-')

      END