257 lines
8.7 KiB
Fortran
Executable file
257 lines
8.7 KiB
Fortran
Executable file
c DOUBLE PRECISION FUNCTION D1MACH (IDUM)
|
|
c INTEGER IDUM
|
|
cC-----------------------------------------------------------------------
|
|
cC THIS ROUTINE COMPUTES THE UNIT ROUNDOFF OF THE MACHINE IN DOUBLE
|
|
cC PRECISION. THIS IS DEFINED AS THE SMALLEST POSITIVE MACHINE NUMBER
|
|
cC U SUCH THAT 1.0D0 + U .NE. 1.0D0 (IN DOUBLE PRECISION).
|
|
cC-----------------------------------------------------------------------
|
|
c DOUBLE PRECISION U, COMP
|
|
c U = 1.0D0
|
|
c 10 U = U*0.5D0
|
|
c COMP = 1.0D0 + U
|
|
c IF (COMP .NE. 1.0D0) GO TO 10
|
|
c D1MACH = U*2.0D0
|
|
c RETURN
|
|
cC----------------------- END OF FUNCTION D1MACH ------------------------
|
|
c END
|
|
|
|
*DECK XERRWD
|
|
SUBROUTINE XERRWD (MSG, NMES, NERR, LEVEL, NI, I1, I2, NR, R1, R2)
|
|
C***BEGIN PROLOGUE XERRWD
|
|
C***SUBSIDIARY
|
|
C***PURPOSE Write error message with values.
|
|
C***LIBRARY MATHLIB
|
|
C***CATEGORY R3C
|
|
C***TYPE DOUBLE PRECISION (XERRWV-S, XERRWD-D)
|
|
C***AUTHOR Hindmarsh, Alan C., (LLNL)
|
|
C***DESCRIPTION
|
|
C
|
|
C Subroutines XERRWD, XSETF, XSETUN, and the function routine IXSAV,
|
|
C as given here, constitute a simplified version of the SLATEC error
|
|
C handling package.
|
|
C
|
|
C All arguments are input arguments.
|
|
C
|
|
C MSG = The message (character array).
|
|
C NMES = The length of MSG (number of characters).
|
|
C NERR = The error number (not used).
|
|
C LEVEL = The error level..
|
|
C 0 or 1 means recoverable (control returns to caller).
|
|
C 2 means fatal (run is aborted--see note below).
|
|
C NI = Number of integers (0, 1, or 2) to be printed with message.
|
|
C I1,I2 = Integers to be printed, depending on NI.
|
|
C NR = Number of reals (0, 1, or 2) to be printed with message.
|
|
C R1,R2 = Reals to be printed, depending on NR.
|
|
C
|
|
C Note.. this routine is machine-dependent and specialized for use
|
|
C in limited context, in the following ways..
|
|
C 1. The argument MSG is assumed to be of type CHARACTER, and
|
|
C the message is printed with a format of (1X,A).
|
|
C 2. The message is assumed to take only one line.
|
|
C Multi-line messages are generated by repeated calls.
|
|
C 3. If LEVEL = 2, control passes to the statement STOP
|
|
C to abort the run. This statement may be machine-dependent.
|
|
C 4. R1 and R2 are assumed to be in double precision and are printed
|
|
C in D21.13 format.
|
|
C
|
|
C***ROUTINES CALLED IXSAV
|
|
C***REVISION HISTORY (YYMMDD)
|
|
C 920831 DATE WRITTEN
|
|
C 921118 Replaced MFLGSV/LUNSAV by IXSAV. (ACH)
|
|
C 930329 Modified prologue to SLATEC format. (FNF)
|
|
C 930407 Changed MSG from CHARACTER*1 array to variable. (FNF)
|
|
C 930922 Minor cosmetic change. (FNF)
|
|
C***END PROLOGUE XERRWD
|
|
C
|
|
C*Internal Notes:
|
|
C
|
|
C For a different default logical unit number, IXSAV (or a subsidiary
|
|
C routine that it calls) will need to be modified.
|
|
C For a different run-abort command, change the statement following
|
|
C statement 100 at the end.
|
|
C-----------------------------------------------------------------------
|
|
C Subroutines called by XERRWD.. None
|
|
C Function routine called by XERRWD.. IXSAV
|
|
C-----------------------------------------------------------------------
|
|
C**End
|
|
C
|
|
C Declare arguments.
|
|
C
|
|
DOUBLE PRECISION R1, R2
|
|
INTEGER NMES, NERR, LEVEL, NI, I1, I2, NR
|
|
CHARACTER*(*) MSG
|
|
C
|
|
C Declare local variables.
|
|
C
|
|
INTEGER LUNIT, IXSAV, MESFLG
|
|
C
|
|
C Get logical unit number and message print flag.
|
|
C
|
|
C***FIRST EXECUTABLE STATEMENT XERRWD
|
|
LUNIT = IXSAV (1, 0, .FALSE.)
|
|
MESFLG = IXSAV (2, 0, .FALSE.)
|
|
IF (MESFLG .EQ. 0) GO TO 100
|
|
C
|
|
C Write the message.
|
|
C
|
|
WRITE (LUNIT,10) MSG
|
|
10 FORMAT(1X,A)
|
|
IF (NI .EQ. 1) WRITE (LUNIT, 20) I1
|
|
20 FORMAT(6X,'In above message, I1 =',I10)
|
|
IF (NI .EQ. 2) WRITE (LUNIT, 30) I1,I2
|
|
30 FORMAT(6X,'In above message, I1 =',I10,3X,'I2 =',I10)
|
|
IF (NR .EQ. 1) WRITE (LUNIT, 40) R1
|
|
40 FORMAT(6X,'In above message, R1 =',D21.13)
|
|
IF (NR .EQ. 2) WRITE (LUNIT, 50) R1,R2
|
|
50 FORMAT(6X,'In above, R1 =',D21.13,3X,'R2 =',D21.13)
|
|
C
|
|
C Abort the run if LEVEL = 2.
|
|
C
|
|
100 IF (LEVEL .NE. 2) RETURN
|
|
STOP
|
|
C----------------------- End of Subroutine XERRWD ----------------------
|
|
END
|
|
*DECK XSETF
|
|
SUBROUTINE XSETF (MFLAG)
|
|
C***BEGIN PROLOGUE XSETF
|
|
C***PURPOSE Reset the error print control flag.
|
|
C***LIBRARY MATHLIB
|
|
C***CATEGORY R3A
|
|
C***TYPE ALL (XSETF-A)
|
|
C***KEYWORDS ERROR CONTROL
|
|
C***AUTHOR Hindmarsh, Alan C., (LLNL)
|
|
C***DESCRIPTION
|
|
C
|
|
C XSETF sets the error print control flag to MFLAG:
|
|
C MFLAG=1 means print all messages (the default).
|
|
C MFLAG=0 means no printing.
|
|
C
|
|
C***SEE ALSO XERMSG, XERRWD, XERRWV
|
|
C***REFERENCES (NONE)
|
|
C***ROUTINES CALLED IXSAV
|
|
C***REVISION HISTORY (YYMMDD)
|
|
C 921118 DATE WRITTEN
|
|
C 930329 Added SLATEC format prologue. (FNF)
|
|
C 930407 Corrected SEE ALSO section. (FNF)
|
|
C 930922 Made user-callable, and other cosmetic changes. (FNF)
|
|
C***END PROLOGUE XSETF
|
|
C
|
|
C Subroutines called by XSETF.. None
|
|
C Function routine called by XSETF.. IXSAV
|
|
C-----------------------------------------------------------------------
|
|
C**End
|
|
INTEGER MFLAG, JUNK, IXSAV
|
|
C
|
|
C***FIRST EXECUTABLE STATEMENT XSETF
|
|
IF (MFLAG .EQ. 0 .OR. MFLAG .EQ. 1) JUNK = IXSAV (2,MFLAG,.TRUE.)
|
|
RETURN
|
|
C----------------------- End of Subroutine XSETF -----------------------
|
|
END
|
|
*DECK XSETUN
|
|
SUBROUTINE XSETUN (LUN)
|
|
C***BEGIN PROLOGUE XSETUN
|
|
C***PURPOSE Reset the logical unit number for error messages.
|
|
C***LIBRARY MATHLIB
|
|
C***CATEGORY R3B
|
|
C***TYPE ALL (XSETUN-A)
|
|
C***KEYWORDS ERROR CONTROL
|
|
C***DESCRIPTION
|
|
C
|
|
C XSETUN sets the logical unit number for error messages to LUN.
|
|
C
|
|
C***AUTHOR Hindmarsh, Alan C., (LLNL)
|
|
C***SEE ALSO XERMSG, XERRWD, XERRWV
|
|
C***REFERENCES (NONE)
|
|
C***ROUTINES CALLED IXSAV
|
|
C***REVISION HISTORY (YYMMDD)
|
|
C 921118 DATE WRITTEN
|
|
C 930329 Added SLATEC format prologue. (FNF)
|
|
C 930407 Corrected SEE ALSO section. (FNF)
|
|
C 930922 Made user-callable, and other cosmetic changes. (FNF)
|
|
C***END PROLOGUE XSETUN
|
|
C
|
|
C Subroutines called by XSETUN.. None
|
|
C Function routine called by XSETUN.. IXSAV
|
|
C-----------------------------------------------------------------------
|
|
C**End
|
|
INTEGER LUN, JUNK, IXSAV
|
|
C
|
|
C***FIRST EXECUTABLE STATEMENT XSETUN
|
|
IF (LUN .GT. 0) JUNK = IXSAV (1,LUN,.TRUE.)
|
|
RETURN
|
|
C----------------------- End of Subroutine XSETUN ----------------------
|
|
END
|
|
*DECK IXSAV
|
|
INTEGER FUNCTION IXSAV (IPAR, IVALUE, ISET)
|
|
C***BEGIN PROLOGUE IXSAV
|
|
C***SUBSIDIARY
|
|
C***PURPOSE Save and recall error message control parameters.
|
|
C***LIBRARY MATHLIB
|
|
C***CATEGORY R3C
|
|
C***TYPE ALL (IXSAV-A)
|
|
C***AUTHOR Hindmarsh, Alan C., (LLNL)
|
|
C***DESCRIPTION
|
|
C
|
|
C IXSAV saves and recalls one of two error message parameters:
|
|
C LUNIT, the logical unit number to which messages are printed, and
|
|
C MESFLG, the message print flag.
|
|
C This is a modification of the SLATEC library routine J4SAVE.
|
|
C
|
|
C Saved local variables..
|
|
C LUNIT = Logical unit number for messages.
|
|
C LUNDEF = Default logical unit number, data-loaded to 6 below
|
|
C (may be machine-dependent).
|
|
C MESFLG = Print control flag..
|
|
C 1 means print all messages (the default).
|
|
C 0 means no printing.
|
|
C
|
|
C On input..
|
|
C IPAR = Parameter indicator (1 for LUNIT, 2 for MESFLG).
|
|
C IVALUE = The value to be set for the parameter, if ISET = .TRUE.
|
|
C ISET = Logical flag to indicate whether to read or write.
|
|
C If ISET = .TRUE., the parameter will be given
|
|
C the value IVALUE. If ISET = .FALSE., the parameter
|
|
C will be unchanged, and IVALUE is a dummy argument.
|
|
C
|
|
C On return..
|
|
C IXSAV = The (old) value of the parameter.
|
|
C
|
|
C***SEE ALSO XERMSG, XERRWD, XERRWV
|
|
C***ROUTINES CALLED NONE
|
|
C***REVISION HISTORY (YYMMDD)
|
|
C 921118 DATE WRITTEN
|
|
C 930329 Modified prologue to SLATEC format. (FNF)
|
|
C 941025 Minor modification re default unit number. (ACH)
|
|
C***END PROLOGUE IXSAV
|
|
C
|
|
C**End
|
|
LOGICAL ISET
|
|
INTEGER IPAR, IVALUE
|
|
C-----------------------------------------------------------------------
|
|
INTEGER LUNIT, LUNDEF, MESFLG
|
|
C-----------------------------------------------------------------------
|
|
C The following Fortran-77 declaration is to cause the values of the
|
|
C listed (local) variables to be saved between calls to this routine.
|
|
C-----------------------------------------------------------------------
|
|
c SAVE LUNIT, LUNDEF, MESFLG
|
|
c dgg mod 2/2007
|
|
lunit = -1
|
|
lundef = 6
|
|
mesflg = 1
|
|
c DATA LUNIT/-1/, LUNDEF/6/, MESFLG/1/
|
|
C
|
|
C***FIRST EXECUTABLE STATEMENT IXSAV
|
|
IF (IPAR .EQ. 1) THEN
|
|
IF (LUNIT .EQ. -1) LUNIT = LUNDEF
|
|
IXSAV = LUNIT
|
|
IF (ISET) LUNIT = IVALUE
|
|
ENDIF
|
|
C
|
|
IF (IPAR .EQ. 2) THEN
|
|
IXSAV = MESFLG
|
|
IF (ISET) MESFLG = IVALUE
|
|
ENDIF
|
|
C
|
|
RETURN
|
|
C----------------------- End of Function IXSAV -------------------------
|
|
END
|