! P01ABF Example Program Text ! Mark 23 Release. NAG Copyright 2011. MODULE p01abfe_mod ! P01ABF Example Program Module: ! Parameters and User-defined Routines ! .. Use Statements .. USE nag_library, ONLY : nag_wp ! .. Implicit None Statement .. IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nout = 6 CONTAINS SUBROUTINE mysqrt(x,y,ifail) ! Simple routine to compute square root ! .. Use Statements .. USE nag_library, ONLY : p01abf ! .. Implicit None Statement .. IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: nrec = 1 CHARACTER (6), PARAMETER :: srname = 'MYSQRT' ! .. Scalar Arguments .. REAL (KIND=nag_wp), INTENT (IN) :: x REAL (KIND=nag_wp), INTENT (OUT) :: y INTEGER, INTENT (INOUT) :: ifail ! .. Local Scalars .. INTEGER :: ierror ! .. Local Arrays .. CHARACTER (51) :: rec(nrec) ! .. Intrinsic Functions .. INTRINSIC sqrt ! .. Executable Statements .. IF (x>=0.0_nag_wp) THEN y = sqrt(x) ifail = 0 ELSE ierror = 1 WRITE (rec,99999) '** Attempt to take the square root of ', x FLUSH (nout) ifail = p01abf(ifail,ierror,srname,nrec,rec) END IF RETURN 99999 FORMAT (1X,A,1P,E12.5) END SUBROUTINE mysqrt END MODULE p01abfe_mod PROGRAM p01abfe ! P01ABF Example Main Program ! .. Use Statements .. USE nag_library, ONLY : nag_wp USE p01abfe_mod, ONLY : mysqrt, nout ! .. Implicit None Statement .. IMPLICIT NONE ! .. Local Scalars .. REAL (KIND=nag_wp) :: y INTEGER :: ifail ! .. Executable Statements .. WRITE (nout,*) 'P01ABF Example Program Results' WRITE (nout,*) WRITE (nout,*) & 'Soft failure, silent exit - message output from the main program' ifail = 1 CALL mysqrt(-1.0_nag_wp,y,ifail) ! Must test IFAIL on exit if it is not 0 on entry IF (ifail==0) THEN WRITE (nout,99999) y ELSE WRITE (nout,*) & 'Attempt to take the square root of a negative number' END IF WRITE (nout,*) WRITE (nout,*) 'Soft failure, noisy exit' ifail = -1 CALL mysqrt(-2.0_nag_wp,y,ifail) ! Must test IFAIL on exit, but now no need to display a failure message IF (ifail==0) THEN WRITE (nout,99999) y END IF WRITE (nout,*) WRITE (nout,*) 'Hard failure, noisy exit' ifail = 0 CALL mysqrt(-3.0_nag_wp,y,ifail) WRITE (nout,99999) y 99999 FORMAT (1X,F10.4) END PROGRAM p01abfe