mirror of
https://git.planet-casio.com/Lephenixnoir/OpenLibm.git
synced 2025-01-01 06:23:39 +01:00
86 lines
2.7 KiB
Fortran
86 lines
2.7 KiB
Fortran
*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
|