*DECK DPREPJ
SUBROUTINE DPREPJ (NEQ, Y, YH, NYH, EWT, FTEM, SAVF, WM, IWM,
1 F, JAC)
C***BEGIN PROLOGUE DPREPJ
C***SUBSIDIARY
C***PURPOSE Compute and process Newton iteration matrix.
C***TYPE DOUBLE PRECISION (SPREPJ-S, DPREPJ-D)
C***AUTHOR Hindmarsh, Alan C., (LLNL)
C***DESCRIPTION
C
C DPREPJ is called by DSTODE to compute and process the matrix
C P = I - h*el(1)*J , where J is an approximation to the Jacobian.
C Here J is computed by the user-supplied routine JAC if
C MITER = 1 or 4, or by finite differencing if MITER = 2, 3, or 5.
C If MITER = 3, a diagonal approximation to J is used.
C J is stored in WM and replaced by P. If MITER .ne. 3, P is then
C subjected to LU decomposition in preparation for later solution
C of linear systems with P as coefficient matrix. This is done
C by DGEFA if MITER = 1 or 2, and by DGBFA if MITER = 4 or 5.
C
C In addition to variables described in DSTODE and DLSODE prologues,
C communication with DPREPJ uses the following:
C Y = array containing predicted values on entry.
C FTEM = work array of length N (ACOR in DSTODE).
C SAVF = array containing f evaluated at predicted y.
C WM = real work space for matrices. On output it contains the
C inverse diagonal matrix if MITER = 3 and the LU decomposition
C of P if MITER is 1, 2 , 4, or 5.
C Storage of matrix elements starts at WM(3).
C WM also contains the following matrix-related data:
C WM(1) = SQRT(UROUND), used in numerical Jacobian increments.
C WM(2) = H*EL0, saved for later use if MITER = 3.
C IWM = integer work space containing pivot information, starting at
C IWM(21), if MITER is 1, 2, 4, or 5. IWM also contains band
C parameters ML = IWM(1) and MU = IWM(2) if MITER is 4 or 5.
C EL0 = EL(1) (input).
C IERPJ = output error flag, = 0 if no trouble, .gt. 0 if
C P matrix found to be singular.
C JCUR = output flag = 1 to indicate that the Jacobian matrix
C (or approximation) is now current.
C This routine also uses the COMMON variables EL0, H, TN, UROUND,
C MITER, N, NFE, and NJE.
C
C***SEE ALSO DLSODE
C***ROUTINES CALLED DGBFA, DGEFA, DVNORM
C***COMMON BLOCKS DLS001
C***REVISION HISTORY (YYMMDD)
C 791129 DATE WRITTEN
C 890501 Modified prologue to SLATEC/LDOC format. (FNF)
C 890504 Minor cosmetic changes. (FNF)
C 930809 Renamed to allow single/double precision versions. (ACH)
C 010418 Reduced size of Common block /DLS001/. (ACH)
C 031105 Restored 'own' variables to Common block /DLS001/, to
C enable interrupt/restart feature. (ACH)
C***END PROLOGUE DPREPJ
C**End
EXTERNAL F, JAC
INTEGER NEQ, NYH, IWM
DOUBLE PRECISION Y, YH, EWT, FTEM, SAVF, WM
DIMENSION NEQ(*), Y(*), YH(NYH,*), EWT(*), FTEM(*), SAVF(*),
1 WM(*), IWM(*)
INTEGER IOWND, IOWNS,
1 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L,
2 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER,
3 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU
DOUBLE PRECISION ROWNS,
1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND
COMMON /DLS001/ ROWNS(209),
1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND,
2 IOWND(6), IOWNS(6),
3 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L,
4 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER,
5 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU
INTEGER I, I1, I2, IER, II, J, J1, JJ, LENP,
1 MBA, MBAND, MEB1, MEBAND, ML, ML3, MU, NP1
DOUBLE PRECISION CON, DI, FAC, HL0, R, R0, SRUR, YI, YJ, YJJ,
1 DVNORM
C
C***FIRST EXECUTABLE STATEMENT DPREPJ
NJE = NJE + 1
IERPJ = 0
JCUR = 1
HL0 = H*EL0
GO TO (100, 200, 300, 400, 500), MITER
C If MITER = 1, call JAC and multiply by scalar. -----------------------
100 LENP = N*N
DO 110 I = 1,LENP
110 WM(I+2) = 0.0D0
CALL JAC (NEQ, TN, Y, 0, 0, WM(3), N)
CON = -HL0
DO 120 I = 1,LENP
120 WM(I+2) = WM(I+2)*CON
GO TO 240
C If MITER = 2, make N calls to F to approximate J. --------------------
200 FAC = DVNORM (N, SAVF, EWT)
R0 = 1000.0D0*ABS(H)*UROUND*N*FAC
IF (R0 .EQ. 0.0D0) R0 = 1.0D0
SRUR = WM(1)
J1 = 2
DO 230 J = 1,N
YJ = Y(J)
R = MAX(SRUR*ABS(YJ),R0/EWT(J))
Y(J) = Y(J) + R
FAC = -HL0/R
CALL F (NEQ, TN, Y, FTEM)
DO 220 I = 1,N
220 WM(I+J1) = (FTEM(I) - SAVF(I))*FAC
Y(J) = YJ
J1 = J1 + N
230 CONTINUE
NFE = NFE + N
C Add identity matrix. -------------------------------------------------
240 J = 3
NP1 = N + 1
DO 250 I = 1,N
WM(J) = WM(J) + 1.0D0
250 J = J + NP1
C Do LU decomposition on P. --------------------------------------------
CALL DGEFA (WM(3), N, N, IWM(21), IER)
IF (IER .NE. 0) IERPJ = 1
RETURN
C If MITER = 3, construct a diagonal approximation to J and P. ---------
300 WM(2) = HL0
R = EL0*0.1D0
DO 310 I = 1,N
310 Y(I) = Y(I) + R*(H*SAVF(I) - YH(I,2))
CALL F (NEQ, TN, Y, WM(3))
NFE = NFE + 1
DO 320 I = 1,N
R0 = H*SAVF(I) - YH(I,2)
DI = 0.1D0*R0 - H*(WM(I+2) - SAVF(I))
WM(I+2) = 1.0D0
IF (ABS(R0) .LT. UROUND/EWT(I)) GO TO 320
IF (ABS(DI) .EQ. 0.0D0) GO TO 330
WM(I+2) = 0.1D0*R0/DI
320 CONTINUE
RETURN
330 IERPJ = 1
RETURN
C If MITER = 4, call JAC and multiply by scalar. -----------------------
400 ML = IWM(1)
MU = IWM(2)
ML3 = ML + 3
MBAND = ML + MU + 1
MEBAND = MBAND + ML
LENP = MEBAND*N
DO 410 I = 1,LENP
410 WM(I+2) = 0.0D0
CALL JAC (NEQ, TN, Y, ML, MU, WM(ML3), MEBAND)
CON = -HL0
DO 420 I = 1,LENP
420 WM(I+2) = WM(I+2)*CON
GO TO 570
C If MITER = 5, make MBAND calls to F to approximate J. ----------------
500 ML = IWM(1)
MU = IWM(2)
MBAND = ML + MU + 1
MBA = MIN(MBAND,N)
MEBAND = MBAND + ML
MEB1 = MEBAND - 1
SRUR = WM(1)
FAC = DVNORM (N, SAVF, EWT)
R0 = 1000.0D0*ABS(H)*UROUND*N*FAC
IF (R0 .EQ. 0.0D0) R0 = 1.0D0
DO 560 J = 1,MBA
DO 530 I = J,N,MBAND
YI = Y(I)
R = MAX(SRUR*ABS(YI),R0/EWT(I))
530 Y(I) = Y(I) + R
CALL F (NEQ, TN, Y, FTEM)
DO 550 JJ = J,N,MBAND
Y(JJ) = YH(JJ,1)
YJJ = Y(JJ)
R = MAX(SRUR*ABS(YJJ),R0/EWT(JJ))
FAC = -HL0/R
I1 = MAX(JJ-MU,1)
I2 = MIN(JJ+ML,N)
II = JJ*MEB1 - ML + 2
DO 540 I = I1,I2
540 WM(II+I) = (FTEM(I) - SAVF(I))*FAC
550 CONTINUE
560 CONTINUE
NFE = NFE + MBA
C Add identity matrix. -------------------------------------------------
570 II = MBAND + 2
DO 580 I = 1,N
WM(II) = WM(II) + 1.0D0
580 II = II + MEBAND
C Do LU decomposition of P. --------------------------------------------
CALL DGBFA (WM(3), MEBAND, N, ML, MU, IWM(21), IER)
IF (IER .NE. 0) IERPJ = 1
RETURN
C----------------------- END OF SUBROUTINE DPREPJ ----------------------
END