! interval.f90 Example of Using Rounding Control
!
! Uses: fpcontrl, fpprecis, fpround, fpstatus attached below
!
! Compile this program using:
! df /optimize:0 interval.f90
! Note: it must be compiled without any optimizations.
!
PROGRAM interval
USE DFLIB
! Dummy arguments for statement functions
!
REAL numerator, denominator
REAL q, r, s, t, u, v
! Variables
!
REAL a, b, c, d, e, f
REAL numerhi, numerlo, denomhi, denomlo
REAL expr, exprhi, exprlo
DATA a /1.1/, b /1.7/, c /1.3/, d /1.5/, e /1.87/, f /1.95/
! Statement functions
!
numerator( q, r, s, t ) = q * r + s * t
denominator( u, v ) = u + v
! Set rounding Precision
!
CALL fpprecis( FPCW$24 )
! Compute default (round to nearest) expression
!
expr = numerator( a, b, c, d ) / denominator( e, f )
! Compute low terms (round down)
!
CALL fpround( FPCW$DOWN )
numerlo = numerator( a, b, c, d )
denomlo = denominator( e, f )
! Compute high terms (round up)
!
CALL fpround( FPCW$UP )
numerhi = numerator( a, b, c, d )
denomhi = denominator( e, f )
! Compute high expression (still round up)
!
exprhi = numerhi / denomlo
! Compute low expression (round down)
!
CALL fpround( FPCW$DOWN )
exprlo = numerlo / denomhi
! Return to default rounding (nearest)
!
CALL fpround( FPCW$NEAR )
! Report results
!
WRITE (*,'(1x,a,f12.7)') ' Expression = ', expr
WRITE (*,'(1x,a,z8)') ' Low Result Hex = ', exprlo
WRITE (*,'(1x,a,z8)') ' Default Hex = ', expr
WRITE (*,'(1x,a,z8)') ' High Result Hex = ', exprhi
END
! fpcontrl.f90 - Describe the contents of the floating point
! control word. Interpret each sub field of
! the word individually.
!
! Input: control - Two byte control word from GETCONTROLFPQQ
!
SUBROUTINE fpcontrl( control )
USE DFLIB
! Input argument
!
INTEGER(2) control ! Two byte control word
! Local variables
!
INTEGER(2) tcontrol ! Two byte temporary control word
! Interpret the exception trap field
! Retain only the exception bits
!
tcontrol = IAND( control, FPCW$MCW_EM )
! Test each exception and print only the ones that are set
!
IF( tcontrol .NE. 0 ) THEN
IF( IAND( tcontrol, FPCW$INVALID ) .NE. 0 ) THEN
WRITE (*,*) ' FPCONTRL: Invalid operation trap disabled'
ELSE
WRITE (*,*) ' FPCONTRL: Invalid operation trap enabled'
ENDIF
IF( IAND( tcontrol, FPCW$DENORMAL ) .NE. 0 ) THEN
WRITE (*,*)' : Denormalized operand trap disabled'
ELSE
WRITE (*,*)' : Denormalized operand trap enabled'
ENDIF
IF( IAND( tcontrol, FPCW$ZERODIVIDE ) .NE. 0 ) THEN
WRITE (*,*) ' : Zero divide trap disabled'
ELSE
WRITE (*,*) ' : Zero divide trap enabled'
ENDIF
IF( IAND( tcontrol, FPCW$OVERFLOW ) .NE. 0 ) THEN
WRITE (*,*) ' : Overflow trap disabled'
ELSE
WRITE (*,*) ' : Overflow trap enabled'
ENDIF
IF( IAND( tcontrol, FPCW$UNDERFLOW ) .NE. 0 ) THEN
WRITE (*,*) ' : Underflow trap disabled'
ELSE
WRITE (*,*) ' : Underflow trap enabled'
ENDIF
IF( IAND( tcontrol, FPCW$INEXACT ) .NE. 0 ) THEN
WRITE (*,*) ' : Inexact (precision) trap disabled'
ELSE
WRITE (*,*) ' : Inexact (precision) trap enabled'
ENDIF
ELSE
WRITE (*,*) ' FPCONTRL: All exception traps enabled'
ENDIF
! Interpret the precision control field
! Retain only the precision bits
!
tcontrol = IAND( control, FPCW$MCW_PC )
! Test precision and print the one that is set
!
SELECT CASE ( tcontrol )
CASE( FPCW$24 )
WRITE(*,*) ' : 24 bit precision enabled'
CASE( FPCW$53 )
WRITE(*,*) ' : 53 bit precision enabled'
CASE( FPCW$64 )
WRITE(*,*) ' : 64 bit precision enabled'
CASE DEFAULT
WRITE(*,*) ' : Invalid precision control'
END SELECT
! Interpret the rounding control field
! Retain only the rounding bits
!
tcontrol = IAND( control, FPCW$MCW_RC )
! Test rounding and print the one that is set
!
SELECT CASE ( tcontrol )
CASE( FPCW$NEAR )
WRITE(*,*) ' : Round to nearest (or even) enabled'
CASE( FPCW$DOWN )
WRITE(*,*) ' : Round down (to -INF) enabled'
CASE( FPCW$UP )
WRITE(*,*) ' : Round up (to +INF) enabled'
CASE( FPCW$CHOP )
WRITE(*,*) ' : Chop (truncate to 0) enabled'
CASE DEFAULT
WRITE(*,*) ' : Invalid round control'
END SELECT
END
! fpprecis.f90 - Set the contents of the floating point control
! word. Set the precision sub field of the word.
!
! Input: precis - Precision sub field desired in control word
!
!
SUBROUTINE fpprecis( precis )
!
USE DFLIB
! Input argument
!
INTEGER(2) precis ! Two byte precision constant
! Local variables
!
INTEGER(2) tcontrol ! Two byte temporary control word
INTEGER(2) tprecis ! Two byte temporary precision constant
! Check for valid input precision constant
! Retain only precision bits
! Set to 64 precision bits if invalid input
!
tprecis = IAND( precis, FPCW$MCW_PC )
SELECT CASE ( tprecis )
CASE( FPCW$24, FPCW$53, FPCW$64 )
CONTINUE
CASE DEFAULT
tprecis = FPCW$64
END SELECT
! Get the current control word, clear precision bits, set new bits
!
CALL GETCONTROLFPQQ( tcontrol )
tcontrol = IOR( IAND( tcontrol, NOT( FPCW$MCW_PC ) ), tprecis )
! Set the new control word
CALL SETCONTROLFPQQ( tcontrol )
END
! fpround.f90 - Set the contents of the floating point control
! word. Set the rounding sub field of the word.
! Input: round - Rounding sub field desired in control word
!
!
SUBROUTINE fpround( round )
USE DFLIB
! Input argument
!
INTEGER(2) round ! Two byte rounding constant
! Local variables
!
INTEGER(2) control ! Two byte control word
INTEGER(2) tround ! Two byte temporary rounding constant
! Retain only rounding bits
!
tround = IAND( round, FPCW$MCW_RC )
! Get the current control word, clear rounding bits, set new bits
!
CALL GETCONTROLFPQQ( control )
control = IOR( IAND( control, NOT( FPCW$MCW_RC ) ), tround )
! Set the new control word
!
CALL SETCONTROLFPQQ( control )
END
! fpstatus.f90 - Describe the contents of the floating point
! status word. Interpret only the low six
! exception bits.
!
! Input: status - Two byte status word from GETSTATUSFPQQ
!
SUBROUTINE fpstatus( status )
USE DFLIB
! Input argument
!
INTEGER(2) status ! Two byte status word
! Local variable
!
INTEGER(2) tstatus ! Two byte temporary status word
! Retain only exception bits
!
tstatus = IAND( status, FPSW$MSW_EM )
! Test each exception and print only the one(s) that are set
!
IF( tstatus .EQ. 0 ) THEN
WRITE (*,*) ' FPSTATUS: No exceptions'
ENDIF
IF( tstatus .NE. 0 ) THEN
IF( IAND( tstatus, FPSW$INVALID ) .NE. 0 ) THEN
WRITE (*,*) ' FPSTATUS: Invalid operation exception'
ENDIF
IF( IAND( tstatus, FPSW$DENORMAL ) .NE. 0 ) THEN
WRITE (*,*) ' FPSTATUS: Denormalize operand exception'
ENDIF
IF( IAND( tstatus, FPSW$ZERODIVIDE ) .NE. 0 ) THEN
WRITE (*,*) ' FPSTATUS: Zero divide exception'
ENDIF
IF( IAND( tstatus, FPSW$OVERFLOW ) .NE. 0 ) THEN
WRITE (*,*) ' FPSTATUS: Overflow exception'
ENDIF
IF( IAND( tstatus, FPSW$UNDERFLOW ) .NE. 0 ) THEN
WRITE (*,*) ' FPSTATUS: Underflow exception'
ENDIF
IF( IAND( tstatus, FPSW$INEXACT ) .NE. 0 ) THEN
WRITE (*,*) ' FPSTATUS: Inexact (precision) exception'
ENDIF
ENDIF
END