relibc_openlibm/slatec/dstway.f

*DECK DSTWAY
      SUBROUTINE DSTWAY (U, V, YHP, INOUT, STOWA)
C***BEGIN PROLOGUE  DSTWAY
C***SUBSIDIARY
C***PURPOSE  Subsidiary to DBVSUP
C***LIBRARY   SLATEC
C***TYPE      DOUBLE PRECISION (STWAY-S, DSTWAY-D)
C***AUTHOR  Watts, H. A., (SNLA)
C***DESCRIPTION
C
C  This subroutine stores (recalls) integration data in the event
C  that a restart is needed (the homogeneous solution vectors become
C  too dependent to continue).
C
C***SEE ALSO  DBVSUP
C***ROUTINES CALLED  DSTOR1
C***COMMON BLOCKS    DML15T, DML18J, DML8SZ
C***REVISION HISTORY  (YYMMDD)
C   750601  DATE WRITTEN
C   890831  Modified array declarations.  (WRB)
C   890921  Realigned order of variables in certain COMMON blocks.
C           (WRB)
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900328  Added TYPE section.  (WRB)
C   910722  Updated AUTHOR section.  (ALS)
C***END PROLOGUE  DSTWAY
C
      INTEGER ICOCO, IGOFX, INDPVT, INFO, INHOMO, INOUT, INTEG, ISTKOP,
     1     IVP, J, K, KNSWOT, KO, KOP, KS, KSJ, LOTJP, MNSWOT, MXNON,
     2     NCOMP, NDISK, NEQ, NEQIVP, NFC, NFCC, NIC, NOPG, NPS, NSWOT,
     3     NTAPE, NTP, NUMORT, NXPTS
      DOUBLE PRECISION AE, C, PWCND, PX, RE, STOWA(*), TND, TOL, U(*),
     1     V(*), X, XBEG, XEND, XOP, XOT, XSAV, YHP(*)
C
      COMMON /DML8SZ/ C,XSAV,IGOFX,INHOMO,IVP,NCOMP,NFC
      COMMON /DML15T/ PX,PWCND,TND,X,XBEG,XEND,XOT,XOP,INFO(15),ISTKOP,
     1                KNSWOT,KOP,LOTJP,MNSWOT,NSWOT
      COMMON /DML18J/ AE,RE,TOL,NXPTS,NIC,NOPG,MXNON,NDISK,NTAPE,NEQ,
     1                INDPVT,INTEG,NPS,NTP,NEQIVP,NUMORT,NFCC,
     2                ICOCO
C
C***FIRST EXECUTABLE STATEMENT  DSTWAY
      IF (INOUT .EQ. 1) GO TO 30
C
C        SAVE IN STOWA ARRAY AND ISTKOP
C
         KS = NFC*NCOMP
         CALL DSTOR1(STOWA,U,STOWA(KS+1),V,1,0,0)
         KS = KS + NCOMP
         IF (NEQIVP .LT. 1) GO TO 20
         DO 10 J = 1, NEQIVP
            KSJ = KS + J
            STOWA(KSJ) = YHP(KSJ)
   10    CONTINUE
   20    CONTINUE
         KS = KS + NEQIVP
         STOWA(KS+1) = X
         ISTKOP = KOP
         IF (XOP .EQ. X) ISTKOP = KOP + 1
      GO TO 80
   30 CONTINUE
C
C        RECALL FROM STOWA ARRAY AND ISTKOP
C
         KS = NFC*NCOMP
         CALL DSTOR1(YHP,STOWA,YHP(KS+1),STOWA(KS+1),1,0,0)
         KS = KS + NCOMP
         IF (NEQIVP .LT. 1) GO TO 50
         DO 40 J = 1, NEQIVP
            KSJ = KS + J
            YHP(KSJ) = STOWA(KSJ)
   40    CONTINUE
   50    CONTINUE
         KS = KS + NEQIVP
         X = STOWA(KS+1)
         INFO(1) = 0
         KO = KOP - ISTKOP
         KOP = ISTKOP
         IF (NDISK .EQ. 0 .OR. KO .EQ. 0) GO TO 70
            DO 60 K = 1, KO
               BACKSPACE NTAPE
   60       CONTINUE
   70    CONTINUE
   80 CONTINUE
      RETURN
      END