share/odepack/fortran/diprepi.f

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