Mercurial > octave-nkf
view libcruft/odessa/odessa_stesa.f @ 5103:e2ed74b9bfa0 after-gnuplot-split
[project @ 2004-12-28 02:43:01 by jwe]
author | jwe |
---|---|
date | Tue, 28 Dec 2004 02:43:01 +0000 |
parents | 258c1d15ad78 |
children |
line wrap: on
line source
SUBROUTINE ODESSA_STESA (NEQ, Y, NROW, NCOL, YH, WM, IWM, EWT, 1 SAVF, ACOR, PAR, NRS, F, JAC, DF, PJAC, PDF, SOLVE) IMPLICIT DOUBLE PRECISION (A-H,O-Z) EXTERNAL F, JAC, DF, PJAC, PDF, SOLVE DIMENSION NEQ(*), Y(NROW,*), YH(NROW,NCOL,*), WM(*), IWM(*), 1 EWT(NROW,*), SAVF(*), ACOR(NROW,*), PAR(*), NRS(*) PARAMETER (ONE=1.0D0,ZERO=0.0D0) COMMON /ODE001/ ROWND, ROWNS(173), 1 TESCO(3,12), RDUM1, EL0, H, RDUM2(4), TN, RDUM3, 2 IOWND1(14), IOWNS(4), 3 IALTH, LMAX, IDUM1, IERPJ, IERSL, JCUR, IDUM2, KFLAG, L, IDUM3, 4 MITER, IDUM4(4), N, NQ, IDUM5, NFE, IDUM6(2) COMMON /ODE002/ DUPS, DSMS, DDNS, 1 IOWND2(3), IDUM7, NSV, IDUM8(2), IDF, IDUM9, JOPT, KFLAGS C----------------------------------------------------------------------- C ODESSA_STESA IS CALLED BY ODESSA_STODE TO PERFORM AN EXPLICIT C CALCULATION FOR THE FIRST-ORDER SENSITIVITY COEFFICIENTS DY(I)/DP(J), C I = 1,N; J = 1,NPAR. C C IN ADDITION TO THE VARIABLES DESCRIBED PREVIOUSLY, COMMUNICATION C WITH ODESSA_STESA USES THE FOLLOWING.. C Y = AN NROW (=N) BY NCOL (=NSV) REAL ARRAY CONTAINING THE C CORRECTED DEPENDENT VARIABLES ON OUTPUT.. C Y(I,1) , I = 1,N = STATE VARIABLES (INPUT); C Y(I,J) , I = 1,N , J = 2,NSV , C = SENSITIVITY COEFFICIENTS, DY(I)/DP(J). C YH = AN N BY NSV BY LMAX REAL ARRAY CONTAINING THE PREDICTED C DEPENDENT VARIABLES AND THEIR APPROXIMATE SCALED DERIVATIVES. C SAVF = A REAL ARRAY OF LENGTH N USED TO STORE FIRST DERIVATIVES C OF DEPENDENT VARIABLES IF MITER = 2 OR 5. C PAR = A REAL ARRAY OF LENGTH NPAR CONTAINING THE EQUATION C PARAMETERS OF INTEREST. C NRS = AN INTEGER ARRAY OF LENGTH NPAR + 1 CONTAINING THE NUMBER C OF REPEATED STEPS (KFLAGS .LT. 0) DUE TO THE SENSITIVITY C CALCULATIONS.. C NRS(1) = TOTAL NUMBER OF REPEATED STEPS C NRS(I) , I = 2,NPAR = NUMBER OF REPEATED STEPS DUE C TO PARAMETER I. C NSV = NUMBER OF SOLUTION VECTORS = NPAR + 1. C KFLAGS = LOCAL ERROR TEST FLAG, = 0 IF TEST PASSES, .LT. 0 IF TEST C FAILS, AND STEP NEEDS TO BE REPEATED. ERROR TEST IS APPLIED C TO EACH SOLUTION VECTOR INDEPENDENTLY. C DUPS, DSMS, DDNS = REAL SCALARS USED FOR COMPUTING RHUP, RHSM, RHDN, C ON RETURN TO ODESSA_STODE (IALTH .EQ. 1). C THIS ROUTINE ALSO USES THE COMMON VARIABLES EL0, H, TN, IALTH, LMAX, C IERPJ, IERSL, JCUR, KFLAG, L, MITER, N, NQ, NFE, AND JOPT. C----------------------------------------------------------------------- DUPS = ZERO DSMS = ZERO DDNS = ZERO HL0 = H*EL0 EL0I = ONE/EL0 TI2 = ONE/TESCO(2,NQ) TI3 = ONE/TESCO(3,NQ) C IF MITER = 2 OR 5 (OR IDF = 0), SUPPLY DERIVATIVES AT CORRECTED C Y(*,1) VALUES FOR NUMERICAL DIFFERENTIATION IN PJAC AND/OR PDF. IF (MITER .EQ. 2 .OR. MITER .EQ. 5 .OR. IDF .EQ. 0) GO TO 10 GO TO 15 10 CALL F (NEQ, TN, Y, PAR, SAVF) NFE = NFE + 1 C IF JCUR = 0, UPDATE THE JACOBIAN MATRIX. C IF MITER = 5, LOAD CORRECTED Y(*,1) VALUES INTO Y(*,2). 15 IF (JCUR .EQ. 1) GO TO 30 IF (MITER .NE. 5) GO TO 25 DO 20 I = 1,N 20 Y(I,2) = Y(I,1) 25 CALL PJAC (NEQ, Y, Y(1,2), N, WM, IWM, EWT, SAVF, ACOR(1,2), 1 PAR, F, JAC, JOPT) IF (IERPJ .NE. 0) RETURN C----------------------------------------------------------------------- C THIS IS A LOOPING POINT FOR THE SENSITIVITY CALCULATIONS. C----------------------------------------------------------------------- C FOR EACH PARAMETER PAR(*), A SENSITIVITY SOLUTION VECTOR IS COMPUTED C USING THE SAME STEP SIZE (H) AND ORDER (NQ) AS IN ODESSA_STODE. C A LOCAL ERROR TEST IS APPLIED INDEPENDENTLY TO EACH SOLUTION VECTOR. C----------------------------------------------------------------------- 30 DO 100 J = 2,NSV JPAR = J - 1 C EVALUATE INHOMOGENEITY TERM, TEMPORARILY LOAD INTO Y(*,JPAR+1). ------ CALL PDF(NEQ, Y, WM, SAVF, ACOR(1,J), Y(1,J), PAR, 1 F, DF, JPAR) C----------------------------------------------------------------------- C LOAD RHS OF SENSITIVITY SOLUTION (CORRECTOR) EQUATION.. C C RHS = DY/DP - EL(1)*H*D(DY/DP)/DT + EL(1)*H*DF/DP C C----------------------------------------------------------------------- DO 40 I = 1,N 40 Y(I,J) = YH(I,J,1) - EL0*YH(I,J,2) + HL0*Y(I,J) C----------------------------------------------------------------------- C SOLVE CORRECTOR EQUATION: THE SOLUTIONS ARE LOCATED IN Y(*,JPAR+1). C THE EXPLICIT FORMULA IS.. C C (I - EL(1)*H*JAC) * DY/DP(CORRECTED) = RHS C C----------------------------------------------------------------------- CALL SOLVE (WM, IWM, Y(1,J), DUM) IF (IERSL .NE. 0) RETURN C ESTIMATE LOCAL TRUNCATION ERROR. ------------------------------------- DO 50 I = 1,N 50 ACOR(I,J) = (Y(I,J) - YH(I,J,1))*EL0I ERR = ODESSA_VNORM(N, ACOR(1,J), EWT(1,J))*TI2 IF (ERR .GT. ONE) GO TO 200 C----------------------------------------------------------------------- C LOCAL ERROR TEST PASSED. SET KFLAGS TO 0 TO INDICATE THIS. C IF IALTH = 1, COMPUTE DSMS, DDNS, AND DUPS (IF L .LT. LMAX). C----------------------------------------------------------------------- KFLAGS = 0 IF (IALTH .GT. 1) GO TO 100 IF (L .EQ. LMAX) GO TO 70 DO 60 I= 1,N 60 Y(I,J) = ACOR(I,J) - YH(I,J,LMAX) DUPS = DMAX1(DUPS,ODESSA_VNORM(N,Y(1,J),EWT(1,J))*TI3) 70 DSMS = DMAX1(DSMS,ERR) 100 CONTINUE RETURN C----------------------------------------------------------------------- C THIS SECTION IS REACHED IF THE ERROR TOLERANCE FOR SENSITIVITY C SOLUTION VECTOR JPAR HAS BEEN VIOLATED. KFLAGS IS MADE NEGATIVE TO C INDICATE THIS. IF KFLAGS = -1, SET KFLAG EQUAL TO ZERO SO THAT KFLAG C IS SET TO -1 ON RETURN TO ODESSA_STODE BEFORE REPEATING THE STEP. C INCREMENT NRS(1) (= TOTAL NUMBER OF REPEATED STEPS DUE TO ALL C SENSITIVITY SOLUTION VECTORS) BY ONE. C INCREMENT NRS(JPAR+1) (= TOTAL NUMBER OF REPEATED STEPS DUE TO C SOLUTION VECTOR JPAR+1) BY ONE. C LOAD DSMS FOR RH CALCULATION IN ODESSA_STODE. C----------------------------------------------------------------------- 200 KFLAGS = KFLAGS - 1 IF (KFLAGS .EQ. -1) KFLAG = 0 NRS(1) = NRS(1) + 1 NRS(J) = NRS(J) + 1 DSMS = ERR RETURN C-------------------- END OF SUBROUTINE ODESSA_STESA ---------------------- END