share/odepack/fortran/diprep.f

   1 *DECK DIPREP
   2       SUBROUTINE DIPREP (NEQ, Y, RWORK, IA, JA, IPFLAG, F, JAC)
   3       EXTERNAL F, JAC
   4       INTEGER NEQ, IA, JA, IPFLAG
   5       DOUBLE PRECISION Y, RWORK
   6       DIMENSION NEQ(*), Y(*), RWORK(*), IA(*), JA(*)
   7       INTEGER IOWND, IOWNS,
   8      1   ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L,
   9      2   LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER,
  10      3   MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU
  11       INTEGER IPLOST, IESP, ISTATC, IYS, IBA, IBIAN, IBJAN, IBJGP,
  12      1   IPIAN, IPJAN, IPJGP, IPIGP, IPR, IPC, IPIC, IPISP, IPRSP, IPA,
  13      2   LENYH, LENYHM, LENWK, LREQ, LRAT, LREST, LWMIN, MOSS, MSBJ,
  14      3   NSLJ, NGP, NLU, NNZ, NSP, NZL, NZU
  15       DOUBLE PRECISION ROWNS,
  16      1   CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND
  17       DOUBLE PRECISION RLSS
  18       COMMON /DLS001/ ROWNS(209),
  19      1   CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND,
  20      2   IOWND(6), IOWNS(6),
  21      3   ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L,
  22      4   LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER,
  23      5   MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU
  24       COMMON /DLSS01/ RLSS(6),
  25      1   IPLOST, IESP, ISTATC, IYS, IBA, IBIAN, IBJAN, IBJGP,
  26      2   IPIAN, IPJAN, IPJGP, IPIGP, IPR, IPC, IPIC, IPISP, IPRSP, IPA,
  27      3   LENYH, LENYHM, LENWK, LREQ, LRAT, LREST, LWMIN, MOSS, MSBJ,
  28      4   NSLJ, NGP, NLU, NNZ, NSP, NZL, NZU
  29       INTEGER I, IMAX, LEWTN, LYHD, LYHN
  30 C-----------------------------------------------------------------------
  31 C This routine serves as an interface between the driver and
  32 C Subroutine DPREP.  It is called only if MITER is 1 or 2.
  33 C Tasks performed here are:
  34 C  * call DPREP,
  35 C  * reset the required WM segment length LENWK,
  36 C  * move YH back to its final location (following WM in RWORK),
  37 C  * reset pointers for YH, SAVF, EWT, and ACOR, and
  38 C  * move EWT to its new position if ISTATE = 1.
  39 C IPFLAG is an output error indication flag.  IPFLAG = 0 if there was
  40 C no trouble, and IPFLAG is the value of the DPREP error flag IPPER
  41 C if there was trouble in Subroutine DPREP.
  42 C-----------------------------------------------------------------------
  43       IPFLAG = 0
  44 C Call DPREP to do matrix preprocessing operations. --------------------
  45       CALL DPREP (NEQ, Y, RWORK(LYH), RWORK(LSAVF), RWORK(LEWT),
  46      1   RWORK(LACOR), IA, JA, RWORK(LWM), RWORK(LWM), IPFLAG, F, JAC)
  47       LENWK = MAX(LREQ,LWMIN)
  48       IF (IPFLAG .LT. 0) RETURN
  49 C If DPREP was successful, move YH to end of required space for WM. ----
  50       LYHN = LWM + LENWK
  51       IF (LYHN .GT. LYH) RETURN
  52       LYHD = LYH - LYHN
  53       IF (LYHD .EQ. 0) GO TO 20
  54       IMAX = LYHN - 1 + LENYHM
  55       DO 10 I = LYHN,IMAX
  56  10     RWORK(I) = RWORK(I+LYHD)
  57       LYH = LYHN
  58 C Reset pointers for SAVF, EWT, and ACOR. ------------------------------
  59  20   LSAVF = LYH + LENYH
  60       LEWTN = LSAVF + N
  61       LACOR = LEWTN + N
  62       IF (ISTATC .EQ. 3) GO TO 40
  63 C If ISTATE = 1, move EWT (left) to its new position. ------------------
  64       IF (LEWTN .GT. LEWT) RETURN
  65       DO 30 I = 1,N
  66  30     RWORK(I+LEWTN-1) = RWORK(I+LEWT-1)
  67  40   LEWT = LEWTN
  68       RETURN
  69 C----------------------- End of Subroutine DIPREP ----------------------
  70       END