#!/bin/sh # This is a shell archive (produced by GNU sharutils 4.2). # To extract the files from this archive, save it to some FILE, remove # everything before the `!/bin/sh' line above, then type `sh FILE'. # # Made on 1996-07-23 09:10 EDT by . # Source directory was `/home/wcr/final_pack'. # # Existing files will *not* be overwritten unless `-c' is specified. # This format requires very little intelligence at unshar time. # "if test", "echo", "mkdir", and "sed" may be needed. # # This shar contains: # length mode name # ------ ---------- ------------------------------------------ # 35663 -rw-r--r-- daen1.f # 61038 -rw-r--r-- daen2.f # 43631 -rw-r--r-- daeq2.f # 55644 -rw-r--r-- daeq3.f # 54013 -rw-r--r-- daesq1.f # 48895 -rw-r--r-- daeul3.f # echo=echo if mkdir _sh02128; then $echo 'x -' 'creating lock directory' else $echo 'failed to create lock directory' exit 1 fi # ============= daen1.f ============== if test -f 'daen1.f' && test "$first_param" != -c; then $echo 'x -' SKIPPING 'daen1.f' '(file already exists)' else $echo 'x -' extracting 'daen1.f' '(text)' sed 's/^X//' << 'SHAR_EOF' > 'daen1.f' && XC234567==1=========2=========3=========4=========5=========6=========7= XC X SUBROUTINE DAEN1( FF,DFF,SOLOUT,KU,KW,U,UP,W,T,TOUT, X & RDATA,IDATA,ATOL,RTOL, X & RWORK,LRW,IWORK,LIW,IER ) XC X EXTERNAL FF,DFF,SOLOUT XC X INTEGER KU,KW,LRW,LIW,IER X INTEGER IDATA(10),IWORK(LIW) X DOUBLE PRECISION U(*),UP(*),W(*),T,TOUT X DOUBLE PRECISION ATOL,RTOL,RDATA(10),RWORK(LRW) XC XC234567--1---------2---------3---------4---------5---------6---------7- XC Written by W. Rheinboldt December 2, 1995 XC Last revised May 25, 1996 XC234567--1---------2---------3---------4---------5---------6---------7- XC XC DAE solver for Nonlinear, index 1 problems XC XC F(u,u',w,t) = 0, u' = du/dt XC XC with explicitly given algebraic variable, subject to the XC consistent initial condition XC XC u(T0) = U0, u'(T0) = UP0, w(T0) = W0, F(U0,UP0,W0,T0) = 0 XC XC The dimensions are: XC XC dim U = KU, dim W = KW, XC dim(rge F) = KU + KW, KU > 0, but KW may be zero. XC XC It is assumed that XC XC rank ( D_up F(U,UP,W,T) D_w F(U,UP,W,T) ) = KU + KW XC XC for all ((U,UP,W,T)) satisfying F((U,UP,W,T)) = 0. XC XC The Dormand-Prince Runge Kutta method of order 5 is used. XC XC For the algorithm see XC XC W. C. Rheinboldt, Solving Algebraically Explicit DAEs XC with the MANPAK - Manifold - Algorithms XC Inst. for Comp. Math. and Appl., Univ. of Pittsburgh, XC Tech. Reportt. TR-ICMA-96-199, July 1996 XC J. Comp. and Math. Applic. submitted XC XC Link with a driver, MANPAK, and MANAUX XC XC We use the notation XC XC NALG = equivalent number of algebraic equations: NALG = KU+KW XC NVAR = dimension of the ambient space: NVAR = KU+NALG+1 XC MDIM = dimension of the manifold: MDIM = NVAR-NALG = KU+1 XC XC Variables in the calling sequence: XC ---------------------------------- XC FF EXT Subroutine for evaluating F, see below. XC DFF EXT Subroutine for evaluating the Jacobian of F, XC see below. XC SOLOUT EXT Subroutine for intermediate output, see below. XC KU I IN Dimension of U XC KW I IN Dimension of W XC U D IN Initial vector U XC D OUT Final vector U XC UP D IN Initial vector UP XC D OUT Final vector UP XC W D IN Initial vector W XC D OUT Final vector W XC T D IN Initial time XC D OUT Final time XC TOUT D IN Desired stopping time XC RDATA D IN Data array of dimension 10 XC RDATA(1) = H Suggested step XC Default H = 1.0D3*RTOL(1) XC RDATA(2) = HMIN Requested minimal step XC Default HMIN = 1.0D1*EPMACH XC RDATA(3) = HMAX Requested maximal step XC Default HMAX = ABS(TOUT-T) XC RDATA(4) - RDATA(10) not used XC IDATA I IN Data array of dimension 10 XC IDATA(1) = NMAX Requested maximal number of steps XC Default NMAX = 10,000 XC IDATA(2) = JPOL Interpolation indicator XC JPOL = 0 No interpolation XC JPOL = 1 Interpolate XC Default JPOL = 0 XC IDATA(3) - IDATA(10) not used XC ATOL D IN Absolute error tolerance XC RTOL D IN Relative error tolerance XC RWORK D WK Work array of dimension LRW. XC LRW I IN Dimension of RWORK at least equal to XC NVAR*(3*NVAR + 5) + MDIM*(2*NVAR + 14). XC IWORK I WK Work array of dimension LIW. XC LIW I IN Dimension of IWORK at least equal to 2*NVAR. XC IER I OUT Error indicator: XC IER = 1 -- successful computation interrupted XC by SOLOUT, XC IER = 0 -- no error, computation was successful, XC IER = -1 -- error encountered and printed out. XC XC External Subroutine XC -------------------- XC The user should supply subroutines for the computation of the XC function F, its Jacobian DF, and the printout of intermediate XC results. In the case KW = 0, a dummy array W should be provided XC to match the following general calling sequences of these XC routines. XC XC 1. Subroutine for calculating F XC ---------------------------- XC XC SUBROUTINE FF( U,UP,W,T,FV,IER ) XC XC INTEGER IER XC DOUBLE PRECISION U(*),UP(*),W(*),T,FV(*) XC XC Variables in the calling sequence: XC ---------------------------------- XC U D IN Array of dimension KU, the current vector U XC UP D IN Array of dimension KU, the current vector UP XC W D IN Array of dimension KW, the current vector W XC T D IN Current time XC FV D OUT The computed vector FV = F(U,UP,W,T) XC IER I OUT Error indicator: XC ier = 0 -- no error XC ier =-1 -- error in FF XC XC 2. Subroutine for calculating the Jacobian DF XC ------------------------------------------ XC XC SUBROUTINE DFF( U,UP,W,T,DFV,LDF,IER ) XC XC INTEGER LDF,IER XC DOUBLE PRECISION U(*),UP(*),W(*),T,DFV(LDF,*) XC XC Variables in the calling sequence: XC ---------------------------------- XC U D IN Array of dimension KU, the current vector U XC UP D IN Array of dimension KU, the current vector UP XC W D IN Array of dimension KW, the current vector W XC T D IN Current time XC DFV D OUT Array of dimension LDF x NVAR for the XC Jacobian of F. Let Fk denote the k-th XC component of F. Then the k-th row of DFV XC should contain the vector of the NVAR XC partial derivatives of Fk in the order XC XC ( d/dU Fk , d/dUP Fk, d/dW Fk, d/dT Fk ) XC XC LDF I IN Row dimension of DFV, LDF .GE. NVAR XC IER I OUT Error indicator: XC ier= 0 -- no error. XC ier=-1 -- error in DFF. XC XC 3. Subroutine for intermediate output. XC ----------------------------------- XC XC SUBROUTINE SOLOUT( TASK,JPOL,NPT,U,UP,W,T,TLAST,TNEXT ) XC XC DOUBLE PRECISION U(*),UP(*),W(*),T,TLAST,TNEXT XC CHARACTER*6 TASK XC XC Variables in the calling sequence: XC ---------------------------------- XC TASK C IN Task identifier XC TASK = 'START' Print starting point and header, XC if desired XC TASK = 'FINAL' Print final point XC TASK = 'PRNT' New computed point for printout XC TASK = 'INTP' Interpolated point is given XC OUT TASK = 'INTP' Request interpolation at time XC T in the interval between XC TLAST and TNEXT. XC TASK = 'PRNT' Continue with the integration XC TASK = 'STOP' Requests the integration to stop XC JPOL I IN Interpolation indicator XC JPOL = 0 No interpolation XC JPOL = 1 Interpolate XC Default JPOL = 0 XC NPT I IN Current point counter XC U D IN Array of dimension KU, the current vector U XC UP D IN Array of dimension KU, the current vector UP XC W D IN Array of dimension KW, the current vector W XC T D IN Current time XC TLAST D IN Previous time XC TNEXT D OUT Next time XC XC 4. Subroutine for error-output units XC ---------------------------------- XC XC SUBROUTINE ERROUT(KL, LOUT) XC XC INTEGER KL, LOUT(*) XC XC Function to supply KL output-unit numbers for use by XC by the message routine MSGPRT XC XC Variables in the calling sequence XC --------------------------------- XC KL I OUT Number of different output units to be used XC by MSGPRT. For KL <= 0 and KL > 5 all printout XC by MSGPRT is suppressed. XC LOUT I OUT Array of dimension KL, 1 <= KL<= 5, for the XC KL output-units to be used by MSGPRT. XC XC234567--1---------2---------3---------4---------5---------6---------7- XC XC.....Subroutines called: XC X EXTERNAL DRVN1,MSGPRT XC XC.....Functions called XC X DOUBLE PRECISION ABS,SQRT XC XC.....Parameters XC X INTEGER NMXDEF X PARAMETER( NMXDEF = 10000 ) X DOUBLE PRECISION ONE, ZER X PARAMETER( ONE=1.0D0, ZER= 0.D0 ) X CHARACTER*(*) LNAME X PARAMETER( LNAME = 'DAEN1') XC XC.....Local variables XC X INTEGER I,J,LREN,LIEN X DOUBLE PRECISION ATOLA(1),RTOLA(1) X CHARACTER*6 CHAR,TASK XC XC.....Variables saved between calls XC X INTEGER NCALL,LXC,LUBXC,LDFMAT,LAUGMT,LDPHI,LXN,LUBXN X INTEGER LY,LYP,LXINT,LUINT,LW0,LW1,LW2,LW3,LW4,LW5,LW6 X INTEGER LWKMAT,LWRK1,LWRK2,LJAUGM,LIWRK X SAVE NCALL,LXC,LUBXC,LDFMAT,LAUGMT,LDPHI,LXN,LUBXN, X & LY,LYP,LXINT,LUINT,LW0,LW1,LW2,LW3,LW4,LW5,LW6, X & LWKMAT,LWRK1,LWRK2,LJAUGM,LIWRK XC XC.....Common block for machine constant XC X DOUBLE PRECISION EPMACH,SAFMIN X COMMON /MACH/EPMACH,SAFMIN XC XC.....Common block for data XC X INTEGER NMAX,JPOL X DOUBLE PRECISION POSNEG,H,HMIN,HMAX X COMMON /DATN1/H,HMIN,HMAX,POSNEG,NMAX,JPOL XC XC.....Common block for the statistics variables XC X INTEGER NSTEP,NACCPT,NREJCT,NDER,NFF,NDFF X COMMON /STAN1/NSTEP,NACCPT,NREJCT,NDER,NFF,NDFF XC XC.....Common block for dimensions XC X INTEGER NU,NALG,NVAR,MDIM,NU2P1,NVARM1 X COMMON /DIMN1/NU,NALG,NVAR,MDIM,NU2P1,NVARM1 XC X DATA NCALL/0/ XC XC.......................Executable statements......................... XC XC.....At first call check dimensions, set pointers into work XC.....arrays and check for insufficient storage. XC.....(These are data that depend only on the problem XC.....but not on a specific trajectory) XC X IF(NCALL .EQ. 0) THEN X NCALL = 1 X NU = KU X NALG = KU + KW X NVAR = KU + NALG + 1 X MDIM = KU + 1 X NU2P1 = MDIM + KU X NVARM1 = NVAR - 1 XC XC........Set machine constant XC X CALL DMACH( EPMACH,SAFMIN ) XC XC........Check data and set defaults XC X IER = -1 X IF(NVAR .LT. 2) THEN X CALL MSGPRT(LNAME,'The ambient space must be at '// X & 'least two-dimensional') X RETURN X ENDIF X IF(MDIM .LT. 1)THEN X CALL MSGPRT(LNAME,'The manifold must be at least '// X & 'one-dimensional') X RETURN X ENDIF XC XC........Set pointers into RWORK XC X LXC = 1 X LUBXC = LXC + NVAR X LDFMAT = LUBXC + NVAR*MDIM X LAUGMT = LDFMAT + NALG*NVAR X LDPHI = LAUGMT + NVAR*NVAR XC X LXN = LDPHI + NVAR*MDIM X LUBXN = LXN + NVAR XC X LY = LUBXN + NVAR*MDIM X LYP = LY + MDIM X LXINT = LYP + MDIM X LUINT = LXINT + NVAR XC X LW0 = LUINT + 5*MDIM X LW1 = LW0 + MDIM X LW2 = LW1 + MDIM X LW3 = LW2 + MDIM X LW4 = LW3 + MDIM X LW5 = LW4 + MDIM X LW6 = LW5 + MDIM XC X LWKMAT = LW6 + MDIM X LWRK1 = LWKMAT + NVAR*NVAR X LWRK2 = LWRK1 + NVAR X LREN = LWRK2 + NVAR - 1 XC XC........Check for sufficient RWORK XC X IF(LREN .GT. LRW) THEN X WRITE (CHAR,10) LREN X 10 FORMAT(I5) X CALL MSGPRT(LNAME, X & 'RWORK must have at least dimension '//CHAR) X RETURN X ENDIF XC XC........Set pointers into IWORK XC X LJAUGM = 1 X LIWRK = LJAUGM + NVAR X LIEN = LIWRK + NVAR - 1 XC XC........Check for sufficient IWORK XC X IF(LIEN .GT. LIW) THEN X WRITE (CHAR,10) LIEN X CALL MSGPRT(LNAME, X & 'IWORK must have at least dimension '//CHAR) X RETURN X ENDIF X ENDIF XC XC.....Now set the data that depend on the specific trajectory XC X POSNEG = ONE X IF (TOUT .LT. T) POSNEG = -POSNEG X HMIN = RDATA(2) X IF (HMIN .LE. ZER) HMIN = SQRT(EPMACH) X HMAX = RDATA(3) X IF (HMAX .EQ. ZER) HMAX = ABS(TOUT - T) X IF (HMAX .LT. ZER) HMAX = -HMAX X H = RDATA(1) X IF( POSNEG*H .LT. ZER ) H = -H X IF (H .EQ. ZER) H = POSNEG*SQRT(DBLE(MDIM)) X ATOLA(1) = ATOL X RTOLA(1) = RTOL XC X NMAX = IDATA(1) X IF (NMAX .LE. 0 ) NMAX = NMXDEF X JPOL = IDATA(2) X IF (JPOL .NE. 1) JPOL = 0 XC XC.....Initialize counters XC X NSTEP = 0 X NACCPT = 0 X NREJCT = 0 X NDER = 0 X NFF = 0 X NDFF = 0 XC XC.....Copy the given vectors T,U,V,W into XC XC X J = KU X DO 20 I = 1, KU X J = J + 1 X RWORK(I) = U(I) X RWORK(J) = UP(I) X 20 CONTINUE X J = KU + KU X IF (KW .GT. 0) THEN X DO 30 I = 1, KW X J = J + 1 X RWORK(J) = W(I) X 30 CONTINUE X ENDIF X RWORK(NVAR) = T XC XC.....Call the Runge-Kutta driver XC X CALL DRVN1( FF,DFF,SOLOUT,TOUT,ATOLA,RTOLA,RWORK(LXC), X & RWORK(LUBXC),NVAR,RWORK(LDFMAT),NALG, X & RWORK(LAUGMT),NVAR,IWORK(LJAUGM), X & RWORK(LDPHI),NVAR,RWORK(LXN),RWORK(LUBXN), X & RWORK(LY),RWORK(LYP),RWORK(LXINT), X & RWORK(LUINT),RWORK(LW0),RWORK(LW1),RWORK(LW2), X & RWORK(LW3),RWORK(LW4),RWORK(LW5),RWORK(LW6), X & RWORK(LWKMAT),NVAR,IWORK(LIWRK),RWORK(LWRK1), X & RWORK(LWRK2),IER ) XC XC.....Test for error condition and then return XC X IF (IER .NE. 0) CALL MSGPRT(LNAME, X & 'Error return from the RK-step driver') XC XC.....Restore U,UP,W,T XC X J = KU X DO 40 I = 1, KU X J = J + 1 X U(I) = RWORK(I) X UP(I) = RWORK(J) X 40 CONTINUE X J = KU + KU X IF (KW .GT. 0) THEN X DO 50 I = 1, KW X J = J + 1 X W(I) = RWORK(J) X 50 CONTINUE X ENDIF X T = RWORK(NVAR) XC XC.....Print last computed point XC X TASK = 'FINAL' X CALL SOLOUT(TASK,JPOL,NACCPT,U,UP,W,T,T,T) XC X RETURN XC XC.....End of DAEN1 XC X END XC XC234567==1=========2=========3=========4=========5=========6=========7= XC X SUBROUTINE DRVN1( FF,DFF,SOLOUT,TOUT,ATOLA,RTOLA, X & XC,UBXC,LDU,DFMAT,LDF,AUGMT,LDA,JAUGM, X & DPHI,LDP,XN,UBXN,Y,YP,XINT,UINT, X & W0,W1,W2,W3,W4,W5,W6, X & WRKMAT,LDW,IWRK,WRK1,WRK2,IER ) XC X EXTERNAL FF,DFF,SOLOUT XC X INTEGER LDA,LDF,LDP,LDU,LDW,IER,JAUGM(*),IWRK(*) XC X DOUBLE PRECISION TOUT,ATOLA(*),RTOLA(*) X DOUBLE PRECISION XC(*),UBXC(LDU,*),DFMAT(LDF,*),AUGMT(LDA,*) X DOUBLE PRECISION DPHI(LDP,*),XN(*),UBXN(LDU,*) X DOUBLE PRECISION Y(*),YP(*),XINT(*),UINT(5,*) X DOUBLE PRECISION W0(*),W1(*),W2(*),W3(*),W4(*),W5(*),W6(*) X DOUBLE PRECISION WRKMAT(LDW,*),WRK1(*),WRK2(*) XC XC234567--1---------2---------3---------4---------5---------6---------7- XC XC This is the driver for the RK step routine DOPSTN. The XC integration continues until either NMAX steps have been XC taken or until T = TOUT has been reached. XC XC A new local system is constructed at each step. XC XC Variables in the calling sequence: XC ---------------------------------- XC FF EXT subroutine for evaluating F XC DFF EXT subroutine for evaluating the Jacobian of F XC SOLOUT EXT subroutine for intermediate output XC TOUT D IN Desired stopping time XC ATOLA D IN Absolute error tolerance XC RTOLA D IN Relative error tolerance XC XC D IN Array of dimension NVAR, the specified current XC point, (U, UP, W, T) XC OUT The last computed point (U, UP, W, T) XC UBXC D WK Array of dimension LDU x MDIM, the XC basis matrix at XC XC LDU I IN Leading dimension of UBSXC, LDU >= NVAR XC DFMAT D WK Array of dimension LDF x NVAR,the Jacobian XC DF(XC) and its decomposition XC LDF I IN Leading dimension of DFMAT, LDF >= NALG XC AUGMT D WK Array of dimension LDF x NVAR, the XC augmented matrix at XC and its decomposition. XC LDF I IN Leading dimension of BMAXC, LDB >= NVAR XC JAUGM I WK Array of dimension of dimension NVAR, the XC pivot array used in the decomposition of BMAXC XC XN D WK Array of dimension NVAR, intermediate point XC UBXN D WK Array of dimension LDU x MDIM for the XC basis matrix at XN XC XPRT D WK Array of dimension NVAR for printouts XC Y D WK Array of dimension MDIM for a point XC in local coordinates on the manifold XC YP D WK Array of dimension MDIM for the XC derivative in local coordinates XC UINT D WK Array of dimension 5*MDIM for use in interpolation XC W0-W6 D WK Seven work arrays of dimension MDIM XC WRKMAT D WK Work array of dimension LDW x NVAR XC LDW I IN Leading dimension of WRKMAT, LDW >= NVAR XC IWRK I Wk Work array of dimension NVAR XC WRK1 D WK Work array of dimension NVAR XC WRK2 D WK Work array of dimension NVAR XC IER I OUT Error indicator XC IER = 1 computation successful XC but interrupted by SOLOUT XC IER = 0 no error, computation was successful XC IER = -1 other error encountered and printed out XC XC234567--1---------2---------3---------4---------5---------6---------7- XC XC.....Subroutines called: XC X EXTERNAL DGPHI,DOPSTN,DYN1,GNBAS,INTN1,MSGPRT,ORIENT XC XC.....Parameters XC X INTEGER ITOL X DOUBLE PRECISION TFACT,ZER,HALF X PARAMETER( ITOL=0, TFACT=1.01D0, ZER=0.0D0, HALF=0.5D0 ) X CHARACTER*(*) LNAME X PARAMETER( LNAME = 'DRVN1' ) XC XC.....Local Variables XC X INTEGER I,J X DOUBLE PRECISION T,TLAST,TLOC,TNEXT,TPR X CHARACTER*6 TASK, MODE X CHARACTER*5 CHAR1,CHAR2 X LOGICAL LAST XC XC.....Common block for machine data XC X DOUBLE PRECISION EPMACH,SAFMIN X COMMON /MACH/EPMACH,SAFMIN XC XC.....Common block for data XC X INTEGER NMAX,JPOL X DOUBLE PRECISION H,HMIN,HMAX,POSNEG X COMMON /DATN1/H,HMIN,HMAX,POSNEG,NMAX,JPOL XC XC.....Common block for statistics variables XC X INTEGER NSTEP,NACCPT,NREJCT,NDER,NFF,NDFF X COMMON /STAN1/NSTEP,NACCPT,NREJCT,NDER,NFF,NDFF XC XC.....Common block for dimensions XC X INTEGER NU,NALG,NVAR,MDIM,NU2P1,NVARM1 X COMMON /DIMN1/NU,NALG,NVAR,MDIM,NU2P1,NVARM1 XC XC.......................Executable statements......................... XC XC.....Get the Jacobian at the starting point XC XC X T = XC(NVAR) X CALL DFF( XC(1),XC(MDIM),XC(NU2P1),T,DFMAT,LDF,IER ) X NDFF = NDFF + 1 X IF( IER .NE. 0 )THEN X CALL MSGPRT(LNAME,' Error in Jacobian evaluation') X IER = -1 X RETURN X ENDIF XC XC.....Place a copy of the Jacobian into AUGMT and copy XC into XN XC X DO 20 J = 1,NVAR X XN(J) = XC(J) X DO 10 I = 1,NALG X AUGMT(I,J) = DFMAT(I,J) X 10 CONTINUE X 20 CONTINUE XC XC.....Compute the basis matrix UBXC XC X CALL GNBAS( NVAR,MDIM,UBXC,LDU,DFMAT,LDF, X & WRK1,WRK2,IWRK,SAFMIN,IER ) X IF( IER .NE. 0 ) THEN X CALL MSGPRT( LNAME,'The basis construction failed '// X & 'at the starting point' ) X IER = -1 X RETURN X ENDIF XC XC.....Write out starting point XC X TASK = 'START' X CALL SOLOUT(TASK,JPOL,NACCPT,XC(1),XC(MDIM),XC(NU2P1),T,T,T) X IF( TASK .EQ. 'STOP' )THEN X CALL MSGPRT (LNAME,'Interruption by SOLOUT, '// X & 'computation terminated') X IER = 0 X RETURN X ENDIF XC XC.....Loop point for accepted steps XC X 100 CONTINUE XC XC.....Check if we are close to the terminal value of T XC X MODE = 'INIT' X LAST = .FALSE. X IF( (T + TFACT*H - TOUT)*POSNEG .GT. ZER ) THEN X H = TOUT - T X LAST = .TRUE. X ENDIF XC XC.....Save the current time XC X TLAST = T XC XC.....We always start with the local coordinate Y = 0 XC X DO 110 I = 1, MDIM X Y(I) = ZER X 110 CONTINUE X TLOC = ZER XC XC.....Evaluate DPHI XC X TASK = 'FACTOR' X CALL DGPHI( TASK,NVAR,MDIM,DPHI,LDP,AUGMT,LDA, X & UBXC,LDU,JAUGM,IER ) X IF( IER .NE. 0 ) THEN X CALL MSGPRT( LNAME,'Error in computing the derivative '// X & 'of the local parametrization') X IER = -1 X RETURN X ENDIF XC XC.....Call the derivative routine XC X TASK = 'STEP' X 150 CONTINUE XC X CALL DYN1( MODE,FF,DFF,Y,YP,XN,DFMAT,LDF,DPHI,LDP, X & XC,UBXC,LDU,AUGMT,LDA,JAUGM, X & WRKMAT,LDW,IWRK,WRK1,IER ) X NDER = NDER + 1 X IF( IER .NE. 0 )THEN X IF( IER .GT. 0 .AND. TASK .EQ. 'EVAL' )THEN X TASK = 'REDUCE' X H = HALF*H X ELSE X CALL MSGPRT (LNAME, X & 'Error in calculating the local direction') X IER = -1 X RETURN X ENDIF X ENDIF XC XC.....Call the step routine XC X CALL DOPSTN( TASK,MDIM,TLOC,Y,YP,H,HMIN,HMAX,NMAX, X & ATOLA,RTOLA,ITOL,W0,W1,W2,W3,W4,W5,W6, X & JPOL,UINT,NSTEP,NACCPT,NREJCT ) X IF( TASK .EQ. 'EVAL' )THEN X MODE = 'NEXT' X GOTO 150 X ELSEIF( TASK .EQ. 'DONE' )THEN X GOTO 200 X ELSEIF( TASK .EQ. 'STPCNT' )THEN X WRITE (CHAR1,160) NSTEP X WRITE (CHAR2,160) NMAX X 160 FORMAT(I5) X CALL MSGPRT (LNAME,'Step count '//CHAR1//' exceeds' X & //' given maximum NMAX= '//CHAR2) X IER = -2 X ELSEIF( TASK .EQ. 'MINSTP' )THEN X CALL MSGPRT( LNAME,' Step fell below HMIN' ) X IER = -3 X ELSE X CALL MSGPRT( LNAME,'Error return from the RK routine' ) X IER = -1 X ENDIF X RETURN XC XC.....Establish a new local coordinate system at XN XC X 200 CONTINUE XC XC.....Write out the solution XC X TASK = 'PRNT' X TNEXT = XN(NVAR) X TPR = TNEXT X CALL SOLOUT( TASK,JPOL,NACCPT,XN(1),XN(MDIM),XN(NU2P1), X & TPR,TLAST,TNEXT) XC X 220 CONTINUE X IF( TASK .EQ. 'PRNT' )THEN X GOTO 300 X ELSEIF( TASK .EQ. 'STOP' )THEN X CALL MSGPRT( LNAME,'Interruption by SOLOUT, '// X & 'computation terminated' ) X IER = 0 X RETURN X ELSEIF( TASK .EQ. 'INTP' )THEN XC XC........Interpolation is requested XC X CALL INTN1( FF,TPR,TLAST,TNEXT,XINT,UINT,XC, X & UBXC,LDU,AUGMT,LDA,JAUGM,WRK1,WRK2,IER ) X NDER = NDER + 1 X IF( IER .NE. 0 )THEN X CALL MSGPRT (LNAME,'Error in interpolation -- proceed') X GOTO 300 X ELSE XC XC...........Write out the interpolated solution XC X CALL SOLOUT( TASK,JPOL,NACCPT,XINT(1),XINT(MDIM), X & XINT(NU2P1),TPR,TLAST,TNEXT ) X GOTO 220 X ENDIF X ELSE X CALL MSGPRT( LNAME,'Unknown value of TASK returned '// X & 'by SOLOUT -- proceed' ) X ENDIF XC XC.....Check for another step XC X 300 CONTINUE XC XC.....Copy XN into XC XC X DO 310 J = 1,NVAR X XC(J) = XN(J) X 310 CONTINUE X T = XC(NVAR) XC XC.....If this was the last step return XC X IF( LAST ) THEN X IER = 0 X RETURN X ENDIF XC XC.....Another step is desired. Copy the Jacobian into AUGMT XC.....and establish a new local coordinate system XC X DO 330 J = 1,NVAR X DO 320 I = 1,NALG X AUGMT(I,J) = DFMAT(I,J) X 320 CONTINUE X 330 CONTINUE XC XC.....Compute the basis matrix UBXN XC X CALL GNBAS( NVAR,MDIM,UBXN,LDU,DFMAT,LDF, X & WRK1,WRK2,IWRK,SAFMIN,IER ) X IF( IER .NE. 0 )THEN X CALL MSGPRT(LNAME,'The basis construction at the '// X & 'new point XN failed') X IER = -1 X RETURN X ENDIF XC XC.....With the old basis as reference adjust the XC.....orientation of the new basis XC X CALL ORIENT( NVARM1,NU,UBXC,LDU,UBXN,LDU, X & WRKMAT,LDW,IWRK,IER ) XC X IF( IER .NE. 0 )THEN X CALL MSGPRT(LNAME, X & 'Error in the reorientation of the new basis') X IER = -1 X RETURN X ENDIF XC XC.....Move basis from UBXN to UBXC XC X DO 350 J = 1,MDIM X DO 340 I = 1,NVAR X UBXC(I,J) = UBXN(I,J) X 340 CONTINUE X 350 CONTINUE XC XC.....Go back to the loop point for accepted steps XC X GOTO 100 XC XC.....End of DRVN1 XC X END XC XC234567==1=========2=========3=========4=========5=========6=========7= XC X SUBROUTINE DYN1( MODE,FF,DFF,Y,YP,XN,DFMAT,LDF,DPHI,LDP, X & XC,UBXC,LDU,AUGMT,LDA,JAUGM, X & WRKMAT,LDW,IWRK,WRK,IER ) XC X EXTERNAL FF,DFF XC X CHARACTER*6 MODE X INTEGER LDA,LDF,LDP,LDU,LDW,IER,JAUGM(*),IWRK(*) X DOUBLE PRECISION Y(*),YP(*),XN(*),DFMAT(LDF,*),DPHI(LDP,*) X DOUBLE PRECISION XC(*),UBXC(LDU,*),AUGMT(LDA,*) X DOUBLE PRECISION WRKMAT(LDW,*),WRK(*) XC XC234567--1---------2---------3---------4---------5---------6---------7- XC XC Routine for evaluating YP = Y' for the local ODE XC XC DPHI_1(Y)Y' = PHI_2(Y) XC XC where XC XC X = phi(Y) = (PHI_1(Y),PHI_2(Y),PHI_3(Y)) XC XC is the local parametrization. XC XC Variables in the calling sequence: XC --------------------------------- XC MODE C IN Mode indicator XC MODE = 'INIT' initialize the local parametrization XC MODE = 'NEXT' use the existing parametrization XC FF EXT Subroutine for evaluating F, see DAEN1 XC DFF EXT Subroutine for evaluating DF, see DAEN1 XC Y D IN Array of dimension MDIM, the specified local point XC YP D OUT Array of dimension MDIM, the computed derivative XC XN D OUT Array of dimension NVAR, the global point XC corresponding to Y XC DFMAT D OUT Array of dimension LDF x NVAR, the Jacobian at XN XC LDF I IN Leading dimension of DFXN, LDF >= NALG XC DPHI D OUT Array of dimension LDP x MDIM, the derivative of XC the local parametrization at XN XC LDP I IN The leading dimension of DPHI, LDP >= NVAR XC XC D IN Array of dimension NVAR, the center point of XC the local coordinate system XC UBXC D IN Array of dimension LDU x MDIM, the XC basis matrix at XC XC LDU I IN Leading dimension of UBSXC, LDU >= NVAR XC AUGMT D IN Array of dimension LDF x NVAR, the LU-decomposed XC augmented matrix at XC XC LDB I IN Leading dimension of BMAXC, LDB >= NVAR XC JAUGM I IN Array of dimension of dimension NVAR, the XC pivot array used in the decomposition of AUGMT XC WRKMAT D WK Work array of dimension LDW x NVAR XC LDW I IN Leading dimension of WRKMAT, LDW >= NVAR XC IWRK I WK Work array of dimension NVAR XC WRK D WK Work array of dimension NVAR XC IER I OUT Error indicator XC IER = 1 correctable error-- steplength too large -- XC no printout from MSGPRT XC IER = 0 no error XC IER = -1 fatal error, printout from MSGPRT XC XC234567--1---------2---------3---------4---------5---------6---------7- XC XC.....Subroutines called XC X EXTERNAL DGPHI,GPHI,LUS1,LUF,MSGPRT XC XC.....Local variables XC X INTEGER I,ISTEP,J X CHARACTER*6 TASK XC XC.....Parameters XC X CHARACTER*(*) LNAME X PARAMETER( LNAME = 'DYN1' ) X DOUBLE PRECISION ONE, ZER X PARAMETER( ONE=1.0D0, ZER=0.0D0 ) XC XC.....Common block for machine constant XC X DOUBLE PRECISION EPMACH,SAFMIN X COMMON /MACH/EPMACH,SAFMIN XC XC.....Common block for the statistics variables XC X INTEGER NSTEP,NACCPT,NREJCT,NDER,NFF,NDFF X COMMON /STAN1/NSTEP,NACCPT,NREJCT,NDER,NFF,NDFF XC XC.....Common block for dimensions XC X INTEGER NU,NALG,NVAR,MDIM,NU2P1,NVARM1 X COMMON /DIMN1/NU,NALG,NVAR,MDIM,NU2P1,NVARM1 XC XC.......................Executable statements......................... XC X IF( MODE .EQ. 'NEXT' )THEN XC XC........Determine the global point with the local coordinate Y XC X TASK = 'START' X 20 CONTINUE X CALL GPHI( TASK,NVAR,MDIM,Y,XN,WRK,XC,UBXC,LDU, X & AUGMT,LDA,JAUGM,EPMACH,ISTEP ) X IF( TASK .EQ. 'EVAL' )THEN X CALL FF( XN(1),XN(MDIM),XN(NU2P1),XN(NVAR),WRK,IER ) X NFF = NFF + 1 X IF( IER .NE. 0 )THEN X CALL MSGPRT(LNAME,'Error in evaluating the function F') X IER = -1 X RETURN X ENDIF X GOTO 20 X ELSEIF( TASK .EQ. 'DONE' )THEN X GOTO 30 X ELSEIF( TASK .EQ. 'DIVERG' .OR. TASK .EQ. 'STPCNT' )THEN X IER = 1 X ELSE X CALL MSGPRT( LNAME, X & 'Error in computing the local parametrization' ) X IER = -1 X ENDIF X RETURN XC XC........Get Jacobian of F at the new point XC X 30 CONTINUE X CALL DFF( XN(1),XN(MDIM),XN(NU2P1),XN(NVAR),DFMAT,LDF,IER ) X NDFF = NDFF + 1 X IF( IER .NE. 0 )THEN X CALL MSGPRT(LNAME, X & 'Error in evaluating the Jacobian DFF') X IER = -1 X RETURN X ENDIF XC XC........Evaluate DPHI XC X DO 50 J = 1,NVAR X DO 40 I = 1,NALG X WRKMAT(I,J) = DFMAT(I,J) X 40 CONTINUE X 50 CONTINUE X TASK = 'FACTOR' X CALL DGPHI( TASK,NVAR,MDIM,DPHI,LDP,WRKMAT,LDW, X & UBXC,LDU,IWRK,IER ) X IF( IER .NE. 0 )THEN X CALL MSGPRT( LNAME,'Error in computing the derivative '// X & 'of the local parametrization' ) X IER = -1 X RETURN X ENDIF XC X ENDIF XC XC.....Set up and solve the reduced system XC X DO 120 J = 1,MDIM X YP(J) = XN(NU+J) X DO 110 I = 1,NU X WRKMAT(I,J) = DPHI(I,J) X 110 CONTINUE X WRKMAT(MDIM,J) = ZER X 120 CONTINUE X WRKMAT(MDIM,MDIM) = ONE X YP(MDIM) = ONE XC XC.....Solve WRKMAT * S = YP for S and stored in YP XC X CALL LUF( MDIM,WRKMAT,LDW,IWRK,IER ) X IF( IER .NE. 0 )THEN X CALL MSGPRT(LNAME,'The reduced matrix is singular' ) X IER = -1 X RETURN X ENDIF X CALL LUS1( MDIM,WRKMAT,LDW,IWRK,YP,IER ) X YP(MDIM) = ONE XC XC.....Successful return XC X IER = 0 X RETURN XC XC.....End of DYN1 XC X END XC XC234567==1=========2=========3=========4=========5=========6=========7= XC X SUBROUTINE INTN1( FF,TPR,TLAST,TNEXT,XINT,UINT,XC,UBXC,LDU, X & AUGMT,LDA,JAUGM,WRK1,WRK2,IER ) XC X EXTERNAL FF XC X INTEGER LDA,LDU,IER,JAUGM(*) X DOUBLE PRECISION TPR,TLAST,TNEXT X DOUBLE PRECISION XINT(*),UINT(5,*) X DOUBLE PRECISION XC(*),UBXC(LDU,*),AUGMT(LDA,*) X DOUBLE PRECISION WRK1(*),WRK2(*) XC XC234567--1---------2---------3---------4---------5---------6---------7- XC XC Routine for interpolating between computed points when XC intermediate output is desired. XC XC Variables in the calling sequence: XC ---------------------------------- XC FF EXT Subroutine for evaluating F, see DAEN1 XC TPR D IN The time where output is desired. TPR must XC be between TLAST and TNEXT XC TLAST D IN The last time XC TNEXT D IN The next time XC XINT D OUT Array of dimension NVAR, interpolated point in XC global coordinates XC UINT D IN Interpolation array of dimension 5 * MDIM computed XC by DOPSTN for the step from TLAST to TNEXT XC XC D IN Array of dimension NVAR, the center point XC of the local coordinate system XC UBXC D IN Array of dimension LDU x MDIM, the basis XC matrix at XC XC LDU I IN Leading dimension of UBXC, LDU >= NVAR XC AUGMT D IN Array of dimension LDA x NVAR, the LU-decomposed XC augmented matrix at XC XC LDA I IN Leading dimension of AUGMT, LDA >= NVAR XC JAUGM I IN Array of dimension of dimension NVAR, the XC pivot array used in the decomposition of AUGMT XC WRK1 I WK Work array of dimension NVAR XC WRK2 I WK Work array of dimension NVAR XC IER I OUT Error indicator XC IER = 0 No error XC IER = -1 TPR was not between TLAST and TNEXT XC IER = -2 Projection onto the manifold failed XC XC234567--1---------2---------3---------4---------5---------6---------7- XC XC.....Subroutines called XC X EXTERNAL GPHI,MSGPRT XC XC.....Local variables XC X INTEGER I,ISTEP X DOUBLE PRECISION HT, ONE, ZER, S X CHARACTER*6 TASK X CHARACTER*(*) LNAME X PARAMETER( LNAME = 'INTN1' ) XC X PARAMETER( ONE=1.0D0, ZER=0.0D0 ) XC XC.....Common block for machine constant XC X DOUBLE PRECISION EPMACH,SAFMIN X COMMON /MACH/EPMACH,SAFMIN XC XC.....Common block for the statistics variables XC X INTEGER NSTEP,NACCPT,NREJCT,NDER,NFF,NDFF X COMMON /STAN1/NSTEP,NACCPT,NREJCT,NDER,NFF,NDFF XC XC.....Common block for dimensions XC X INTEGER NU,NALG,NVAR,MDIM,NU2P1,NVARM1 X COMMON /DIMN1/NU,NALG,NVAR,MDIM,NU2P1,NVARM1 XC XC.......................Executable statements......................... XC XC.....Get effective step and check for TINT between TLAST and TNEXT XC X HT = TNEXT - TLAST X S = (TPR - TLAST)/HT X IF( (S .LT. ZER) .OR. (S .GT. ONE) ) THEN X CALL MSGPRT (LNAME,'Interpolation requested outside '// X & 'last integration interval') X IER = -1 X RETURN X ENDIF XC XC.....Evaluate the interpolation polynomial at S to get YINT XC X DO 10 I = 1,MDIM X WRK1(I) = UINT(1,I) + HT*S*(UINT(2,I) + S*(UINT(3,I) X & + S*(UINT(4,I) + S*UINT(5,I)))) X 10 CONTINUE X WRK1(MDIM) = HT*S XC XC.....Get desired point on the manifold corresponding to YINT XC X TASK = 'START' X 20 CONTINUE X CALL GPHI( TASK,NVAR,MDIM,WRK1,XINT,WRK2,XC,UBXC,LDU, X & AUGMT,LDA,JAUGM,EPMACH,ISTEP) X IF( TASK .EQ. 'EVAL' )THEN X CALL FF( XINT(1),XINT(MDIM),XINT(NU2P1),XINT(NVAR),WRK2,IER ) X NFF = NFF + 1 X IF( IER .NE. 0 )THEN X CALL MSGPRT(LNAME, X & 'Error in the evaluation of the function F') X IER = -2 X RETURN X ENDIF X GOTO 20 X ELSEIF( TASK .EQ. 'DONE' )THEN X IER = 0 X ELSE X CALL MSGPRT (LNAME,'Error in computing '// X & 'the local parametrization') X IER = -2 X ENDIF X RETURN XC XC.....End of INTN1 XC X END XC XC234567==1=========2=========3=========4=========5=========6=========7= XC X SUBROUTINE WSTN1( LOUT ) XC X INTEGER LOUT XC XC234567--1---------2---------3---------4---------5---------6---------7- XC XC Output routine for some run statistics of DAEN1 XC XC Variable in the calling sequence: XC ---------------------------------- XC LOUT I IN Output unit number XC XC234567--1---------2---------3---------4---------5---------6---------7- XC XC.....Common block for the statistics variables XC X INTEGER NSTEP,NACCPT,NREJCT,NDER,NFF,NDFF X COMMON /STAN1/NSTEP,NACCPT,NREJCT,NDER,NFF,NDFF XC XC.......................Executable statements......................... XC X WRITE(LOUT,10)NSTEP,NACCPT,NREJCT X 10 FORMAT(1X/' Number of steps: '/ X & ' Total= ',I6,' Accepted= ',I6,' Rejected= ',I6) XC X WRITE(LOUT,20) NDER X 20 FORMAT(' Local ODE evaluations = ',I6) XC X WRITE(LOUT,30) NFF,NDFF X 30 FORMAT(' Function calls:'/' F = ',I6,' DF = ',I6) XC X RETURN XC XC.....End of WSTN1 XC X END XC XC234567==1=========2=========3=========4=========5=========6=========7= SHAR_EOF : || $echo 'restore of' 'daen1.f' 'failed' fi # ============= daen2.f ============== if test -f 'daen2.f' && test "$first_param" != -c; then $echo 'x -' SKIPPING 'daen2.f' '(file already exists)' else $echo 'x -' extracting 'daen2.f' '(text)' sed 's/^X//' << 'SHAR_EOF' > 'daen2.f' && XC234567==1=========2=========3=========4=========5=========6=========7= XC X SUBROUTINE DAEN2( GF,DPGF,DWGF,FF,DFF,SOLOUT, X & KU,KW,KD,U,UP,W,T,TOUT,RDATA,IDATA, X & ATOL,RTOL,RWORK,LRW,IWORK,LIW,IER) XC X EXTERNAL GF,DPGF,DWGF,FF,DFF,SOLOUT XC X INTEGER KU,KW,KD,LRW,LIW,IER,IDATA(10),IWORK(LIW) X DOUBLE PRECISION U(*),T,UP(*),W(*),TOUT X DOUBLE PRECISION ATOL,RTOL,RDATA(10),RWORK(LRW) XC XC234567--1---------2---------3---------4---------5---------6---------7- XC Written by W. Rheinboldt, April 1996 XC Last revised June 22, 1996 XC234567--1---------2---------3---------4---------5---------6---------7- XC XC DAE solver for Nonlinear index-2 problems XC XC G(u,u',w,t) = 0 XC F(u,t) = 0 XC XC subject to the consistent initial conditions XC XC u(t0) = u0, u'(t0) = p0, w(t0) = w0, XC G(u0,p0,t0,w0) = 0, F(u0,t0) = 0 XC XC Here dim u = KU, dim w = KW, dim rge G = KD, and XC dim rge F = KA = KU + KW - KD. XC XC We assume that rank DF(u,t) = KA and XC XC ( DPG(u,up,w,t) DWG(u,up,w,t) ) XC rank ( ) = KU + KW = KD + KA XC ( DF(u,t) 0 ) XC XC for (u,up,w,t) satisfying G(u,p,w,t) = 0, and F(u,t) = 0. XC XC The Dormand-Prince Runge Kutta method of order 5 is used. XC XC For the algorithm see XC XC W. C. Rheinboldt, Solving Algebraically Explicit DAEs XC with the MANPAK - Manifold - Algorithms XC Inst. for Comp. Math. and Appl., Univ. of Pittsburgh, XC Tech. Reportt. TR-ICMA-96-199, July 1996 XC J. Comp. and Math. Applic. submitted XC XC Link with a driver, MANPAK (Vers 2), and MANAUX (Vers 4) XC XC Variables in the calling sequence: XC ---------------------------------- XC GF EXT Subroutine for evaluating G, see below XC DPGF EXT Subroutine for evaluating the partial derivative XC of G with respect to P, see below XC DWGF EXT Subroutine for evaluating the partial derivative XC of G with respect to W, see below XC FF EXT Subroutine for evaluating F, see below XC DFF EXT Subroutine for evaluating the Jacobian of F, XC see below. XC SOLOUT EXT Subroutine for intermediate output, see below XC KU I IN Dimension of U XC KW I IN Dimension of W XC KD I IN Number of differential equations XC U D Array of dimension KU XC IN Starting vector U XC OUT Final vector for U XC UP D Array of dimension KU XC IN Starting direction XC OUT Final direction XC W D Array of dimension KW XC IN Starting vector W XC OUT Final vector for W XC T D IN Initial time XC D OUT Final time XC TOUT D IN Desired stopping time XC RDATA D IN Data array of dimension 10 XC RDATA(1) = H Suggested step XC Default H = 1.0D3*RTOL(1) XC RDATA(2) = HMIN Requested minimal step XC Default HMIN = 1.0D1*EPMACH XC RDATA(3) = HMAX Requested maximal step XC Default HMAX = ABS(TOUT-T) XC RDATA(4) - RDATA(10) not used XC IDATA I IN Data array of dimension 10 XC IDATA(1) = NMAX Requested maximal number of steps XC Default NMAX = 10,000 XC IDATA(2) = JPOL Interpolation indicator XC JPOL = 0 No interpolation XC JPOL = 1 Interpolate XC Default JPOL = 0 XC IDATA(3) = JNEWT Iteration method indicator XC JNEWT = 0 Use chord Newton process XC with one matrix evaluation XC for each RK step XC JNEWT = 1 Use chord Newton process XC with one matrix evaluation XC for each stage of each XC RK step XC Default JNEWT = 0 XC IDATA(4) - IDATA(10) not used XC ATOL D IN Absolute error tolerance XC RTOL D IN Relative error tolerance XC RWORK D WK Work array of dimension LRW. XC LRW I IN Dimension of RWORK at least equal to XC KD*(KD+2*KU+18) + KU*(3*KU+16) + KW*(KW-9) + 26 XC IWORK I WK Work array of dimension LIW. XC LIW I IN Dimension of IWORK at least equal to XC KU + 2*KD + 3 XC IER I OUT Error indicator: XC IER = 1 successful computation interrupted by SOLOUT XC IER = 0 no error, computation was successful, XC IER = -1 error encountered and printed out. XC XC External Subroutines XC -------------------- XC The user is expected to supply subroutines for the computation of XC the coefficient functions A, G, F, and the Jacobian of F, as well XC as, one for the printout of intermediate results. Their calling XC sequences are as follows: XC XC 1. Subroutine for G XC ---------------- XC XC SUBROUTINE GF( U,UP,W,T,VG,IER ) XC XC INTEGER IER XC DOUBLE PRECISION U(*),UP(*),W(*),T,VG(*) XC XC GFCT calculates the KD-dimensional vector VG = G(U,UP,W,T) XC XC Variables in the calling sequence: XC ---------------------------------- XC U D IN Array of dimension KU, the current point. XC UP D IN Array of dimension KU, the current derivative of U XC W D IN Array of dimension KU, the current W XC T D IN Current time XC VG D OUT Array of dimension KD, the vector G(U,UP,W,T) XC IER I OUT Error indicator: XC IER = 0 no error. XC IER = -1 error in GF XC XC 2. Subroutine for evaluating DPG XC ----------------------------- XC XC SUBROUTINE DPGF( U,UP,W,T,A,LDA,KA,GA,LDG,IER ) XC XC INTEGER IER XC DOUBLE PRECISION U(*),UP(*),W(*),T,A(LDA,*) XC XC Let DPG = DpG(U,UP,W,T) denote the KU x KU partial derivative XC of G with respect to P, and A a given KU x KA matrix XC stored in the LDA x KA array A. The routine returns the XC the product DPG*A in the LDG x MDIM array GA. XC XC Variables in the calling sequence: XC ---------------------------------- XC U D IN Array of dimension KU, the current point. XC UP D IN Array of dimension KU, the current derivative of U XC W D IN Array of dimension KU, the current W XC T D IN Current time XC A D IN Array of dimension LDA x K, the given matrix XC LDA I IN Leading dimension of A, LDA >= NVAR XC KA I IN Number of columns of A, KA >= MDIM XC GA D OUT Array of dimension KU x KA, the product DpG*A XC LDG I IN Leading dimension of GA, LDG >= MDIM XC IER I OUT Error indicator: XC ier = 0 no error. XC ier = -1 error in DPGF XC XC 3. Subroutine for evaluating DWG XC ----------------------------- XC XC SUBROUTINE DWGF( U,UP,W,T,A,LDA,IER ) XC XC INTEGER IER XC DOUBLE PRECISION U(*),UP(*),W(*),T,A(LDA,*) XC XC DWGF evaluates the KD x KW dimensional partial derivative XC of G with respect to W and stores it in the LDA x KW XC dimensional array with LDA >= KD XC XC Variables in the calling sequence: XC ---------------------------------- XC U D IN Array of dimension KU, the current point. XC UP D IN Array of dimension KU, the current derivative of U XC W D IN Array of dimension KU, the current W XC T D IN Current time XC A D OUT Array of dimension KD x KW, the derivative DWG XC LDA D IN Leading dimension of the array A, LDA >= KD XC IER I OUT Error indicator: XC ier = 0 no error. XC ier = -1 error in DWGF. XC XC 4. Subroutine for evaluating F XC --------------------------- XC XC SUBROUTINE FF( U,T,V,IER ) XC XC INTEGER IER XC DOUBLE PRECISION U(*),T,V(*) XC XC FF evaluates the KA = KU + KW - KD dimensional vector XC F(U,T) and stores it in the array V X XC Variables in the calling sequence: XC ---------------------------------- XC U D IN Array of dimension KU, the current point. XC T D IN Current time XC V D OUT Array of dimension KA containing V = F(U,T) XC IER I OUT Error indicator: XC IER = 0 no error. XC IER = -1 error in FF XC XC 5. Subroutine for evaluating the Jacobian DF XC ----------------------------------------- XC XC SUBROUTINE DFF( U,T,A,LDA,IER ) XC XC INTEGER LDF,IER XC DOUBLE PRECISION U(*),T,A(LDA,*) XC XC DFF evaluates the Jacobian of F at (U,T) and stores it the XC LDA x (KU+1) dimensional array A where LDA >= KA = KU+KW-KD X XC Variables in the calling sequence: XC ---------------------------------- XC U D IN Array of dimension KU, the current point. XC T D IN Current time XC A D OUT Array of dimension KA x (KU+1) for the Jacobian XC of F at U,T. Let Fk denote the k-th component XC of F. Then the k-th row of DF should contain XC the vector of the KU+1 partial derivatives XC XC ( d/dU(1) Fk , .... , d/dU(KU) Fk, d/dT Fk ) XC XC LDA I IN Leading dimension of A, LDA >= KA XC IER I OUT Error indicator: XC ier = 0 no error. XC ier = -1 error in DFF. XC XC 6. Subroutine for intermediate output. XC ----------------------------------- XC XC SUBROUTINE SOLOUT( TASK,JPOL,NPT,U,UP,W,T,TLAST,TNEXT ) XC XC DOUBLE PRECISION U(*),UP(*),W(*),T,TLAST,TNEXT XC CHARACTER*6 TASK XC XC Variables in the calling sequence: XC ---------------------------------- XC TASK C IN Task identifier XC TASK = 'START' Print starting point and header XC if desired XC TASK = 'FINAL' Print final point XC TASK = 'PRNT' New computed point for printout XC TASK = 'INTP' Interpolated point is given XC OUT TASK = 'INTP' Request interpolation at time XC T in the interval between XC TLAST and TNEXT. XC TASK = 'PRNT' Continue with the integration XC TASK = 'STOP' Requests the integration to stop XC JPOL I IN Interpolation indicator XC JPOL = 0 No interpolation XC JPOL = 1 Interpolate XC Default JPOL = 0 XC NPT I IN Current point counter XC U D IN Array of dimension KU, the current vector U XC UP D IN Array of dimension KU, the current derivative XC of U XC W D IN Array of dimension KW, the current vector W XC T D IN Current time XC TLAST D IN Previous time XC TNEXT D OUT Next time XC XC 7. Subroutine for error-output units XC ---------------------------------- XC XC SUBROUTINE ERROUT(KL, LOUT) XC XC INTEGER KL, LOUT(*) XC XC Function to supply KL output-unit numbers for use by XC by the message routine MSGPRT XC XC Variables in the calling sequence XC --------------------------------- XC KL I OUT Number of different output units to be used XC by MSGPRT. For KL <= 0 and KL > 5 all printout XC by MSGPRT is suppressed. XC LOUT I OUT Array of dimension KL, 1 <= KL<= 5, for the XC KL output-units to be used by MSGPRT. XC XC234567--1---------2---------3---------4---------5---------6---------7- XC XC.....Subroutines called: XC X EXTERNAL DRVN2,MSGPRT XC XC.....Functions called XC X DOUBLE PRECISION ABS,SQRT XC XC.....Parameters XC X INTEGER NMXDEF X PARAMETER( NMXDEF = 10000 ) X DOUBLE PRECISION ZER, ONE X PARAMETER( ZER=0.0D0, ONE=1.0D0 ) X CHARACTER*(*) LNAME X PARAMETER( LNAME = 'DAEN2' ) XC XC.....Local Variables XC X INTEGER I,K,LREN,LIEN X DOUBLE PRECISION ATOLA(1),RTOLA(1) X CHARACTER*6 CHAR,TASK XC XC.....Variables saved between calls XC X INTEGER NCALL,LXC,LUP,LW,LY,LYP,LUBXC,LDFMAT,LAUGMT X INTEGER LXN,LUBXN,LDPHI,LMAIT,LXINT,LUPINT,LWINT,LUINT X INTEGER LW0,LW1,LW2,LW3,LW4,LW5,LW6,LWKMAT,LWRK1,LWRK2 X INTEGER LWRK3,LJAUGM,LJMAIT,LIWRK X SAVE NCALL,LXC,LUP,LW,LY,LYP,LUBXC,LDFMAT,LAUGMT, X & LXN,LUBXN,LDPHI,LMAIT,LXINT,LUPINT,LWINT,LUINT, X & LW0,LW1,LW2,LW3,LW4,LW5,LW6,LWKMAT,LWRK1,LWRK2, X & LWRK3,LJAUGM,LJMAIT,LIWRK XC XC.....Common block for machine constants XC X DOUBLE PRECISION EPMACH,SAFMIN X COMMON /MACH/EPMACH,SAFMIN XC XC.....Common block for data XC X INTEGER NMAX,JPOL,JNEWT X DOUBLE PRECISION H,HMIN,HMAX,POSNEG X COMMON /DATN2/H,HMIN,HMAX,POSNEG,NMAX,JPOL,JNEWT XC XC.....Common block for the statistics variables XC X INTEGER NSTEP,NACCPT,NREJCT,NDER,NGF,NDPGF,NDWGF,NFF,NDFF X COMMON /STAN2/NSTEP,NACCPT,NREJCT,NDER,NGF,NDPGF,NDWGF,NFF,NDFF XC XC.....Common block for dimensions XC X INTEGER NU,NW,NDIF,NEQ,NALG,NVAR,MDIM,MDIMM1,MDIMP1 X COMMON /DIMN2/NU,NW,NDIF,NEQ,NALG,NVAR,MDIM,MDIMM1,MDIMP1 XC X DATA NCALL/0/ XC XC.......................Executable statements......................... XC XC.....At first call check dimensions, set pointers into work XC.....arrays and check for insufficient storage. XC.....(These are data that depend only on the problem XC.....but not on a specific trajectory) XC X IF(NCALL .EQ. 0) THEN X NCALL = 1 X NU = KU X NW = KW X NDIF = KD + 1 X NEQ = KU + KW + 1 X NALG = NEQ - NDIF X NVAR = KU + 1 X MDIM = NVAR - NALG X MDIMM1 = MDIM - 1 X MDIMP1 = MDIM + 1 XC XC........Set machine constant XC X CALL DMACH( EPMACH,SAFMIN ) XC XC........Check data and set defaults XC X IER = -1 X IF( NVAR .LT. 2 ) THEN X CALL MSGPRT( LNAME,'The ambient space must be at '// X & 'least two-dimensional' ) X RETURN X ENDIF X IF( MDIM .LT. 1 )THEN X CALL MSGPRT( LNAME,'The manifold must be at least '// X & 'one-dimensional' ) X RETURN X ENDIF XC XC Set pointers into RWORK XC X LXC = 1 X LUP = LXC + NVAR X LW = LUP + NU XC X LY = LW + NW X LYP = LY + MDIM XC X LUBXC = LYP + MDIM X LDFMAT = LUBXC + NVAR*MDIM X LAUGMT = LDFMAT + NALG*NVAR XC X LXN = LAUGMT + NVAR*NVAR X LUBXN = LXN + NVAR XC X LDPHI = LUBXN + NVAR*MDIM X LMAIT = LDPHI + NVAR*MDIM XC X LXINT = LMAIT + NDIF*NDIF X LUPINT = LXINT + NVAR X LWINT = LUPINT + NU X LUINT = LWINT + NW XC X LW0 = LUINT + 5*MDIM X LW1 = LW0 + MDIM X LW2 = LW1 + MDIM X LW3 = LW2 + MDIM X LW4 = LW3 + MDIM X LW5 = LW4 + MDIM X LW6 = LW5 + MDIM XC X LWKMAT = LW6 + MDIM X LWRK1 = LWKMAT + NEQ*NEQ X LWRK2 = LWRK1 + NEQ X LWRK3 = LWRK2 + NEQ X LREN = LWRK3 + NEQ - 1 XC XC........Check for sufficient RWORK XC X IF(LREN .GT. LRW) THEN X WRITE (CHAR,10) LREN X 10 FORMAT(I5) X CALL MSGPRT( LNAME, X & 'RWORK must have at least dimension '//CHAR ) X RETURN X ENDIF XC XC........Set pointers into IWORK XC X LJAUGM = 1 X LJMAIT = LJAUGM + NVAR X LIWRK = LJMAIT + NDIF X LIEN = LIWRK + NDIF - 1 XC XC........Check for sufficient IWORK XC X IF(LIEN .GT. LIW) THEN X WRITE (CHAR,10) LIEN X CALL MSGPRT( LNAME, X & 'IWORK must have at least dimension '//CHAR ) X RETURN X ENDIF X ENDIF XC XC.....Now set the data that depend on the specific trajectory XC X POSNEG = ONE X IF (TOUT .LT. T) POSNEG = -POSNEG X HMIN = RDATA(2) X IF (HMIN .LE. ZER) HMIN = SQRT(EPMACH) X HMAX = RDATA(3) X IF (HMAX .EQ. ZER) HMAX = ABS(TOUT - T) X IF (HMAX .LT. ZER) HMAX = -HMAX X H = RDATA(1) X IF( POSNEG*H .LT. ZER ) H = -H X IF (H .EQ. ZER) H = POSNEG*SQRT(DBLE(MDIM)) XC X ATOLA(1) = ATOL X RTOLA(1) = RTOL XC X NMAX = IDATA(1) X IF (NMAX .LE. 0 ) NMAX = NMXDEF X JPOL = IDATA(2) X IF (JPOL .NE. 1) JPOL = 0 X JNEWT = IDATA(3) X IF (JNEWT .NE. 1) JNEWT = 0 XC XC.....Initialize counters XC X NSTEP = 0 X NACCPT = 0 X NREJCT = 0 X NDER = 0 X NGF = 0 X NDPGF = 0 X NDWGF = 0 X NFF = 0 X NDFF = 0 XC XC.....Copy the given U,W,T into XC XC X K = NVAR X RWORK(K) = T X DO 20 I = 1, NU X K = K + 1 X RWORK(I) = U(I) X RWORK(K) = UP(I) X 20 CONTINUE X IF( NW .GT. 0 )THEN X DO 30 I = 1, NW X K = K + 1 X RWORK(K) = W(I) X 30 CONTINUE X ENDIF XC XC.....Call the Runge-Kutta driver XC X CALL DRVN2( GF,DPGF,DWGF,FF,DFF,SOLOUT,TOUT,ATOLA,RTOLA, X & RWORK(LXC),RWORK(LUP),RWORK(LW),RWORK(LY), X & RWORK(LYP),RWORK(LUBXC),NVAR,RWORK(LDFMAT),NALG, X & RWORK(LDPHI),NVAR,RWORK(LXN),RWORK(LUBXN), X & RWORK(LAUGMT),NVAR,IWORK(LJAUGM),RWORK(LMAIT),NDIF, X & IWORK(LJMAIT),RWORK(LXINT),RWORK(LUPINT), X & RWORK(LWINT),RWORK(LUINT),RWORK(LW0),RWORK(LW1), X & RWORK(LW2),RWORK(LW3),RWORK(LW4),RWORK(LW5), X & RWORK(LW6),RWORK(LWKMAT),NEQ,RWORK(LWRK1), X & RWORK(LWRK2),RWORK(LWRK3),IWORK(LIWRK),IER ) XC XC.....Test for error condition and then return XC X IF( IER .NE. 0 )CALL MSGPRT( LNAME, X & 'Error return from the RK-step driver' ) XC XC.....Restore U,UP,W,T XC X K = NVAR X T = RWORK(K) X DO 40 I = 1, NU X K = K + 1 X U(I) = RWORK(I) X UP(I) = RWORK(K) X 40 CONTINUE X IF( NW .GT. 0 )THEN X DO 50 I = 1, NW X K = K + 1 X W(I) = RWORK(K) X 50 CONTINUE X ENDIF XC XC.....Print final point XC X TASK = 'FINAL' X CALL SOLOUT( TASK,JPOL,NACCPT,U,UP,W,T,T,T ) XC X RETURN XC XC.....End of DAEN2 XC X END XC XC234567==1=========2=========3=========4=========5=========6=========7= XC X SUBROUTINE DRVN2( GF,DPGF,DWGF,FF,DFF,SOLOUT, X & TOUT,ATOLA,RTOLA,XC,UP,W,Y,YP, X & UBXC,LDU,DFMAT,LDF,DPHI,LDP,XN, X & UBXN,AUGMT,LDA,JAUGM,MAIT,LDM,JMAIT, X & XINT,UPINT,WINT,UINT, X & W0,W1,W2,W3,W4,W5,W6,WRKMAT,LDW, X & WRK1,WRK2,WRK3,IWRK,IER ) XC X EXTERNAL GF,DPGF,DWGF,FF,DFF,SOLOUT XC X INTEGER LDA,LDF,LDM,LDP,LDU,LDW,IER X INTEGER JMAIT(*),JAUGM(*),IWRK(*) XC X DOUBLE PRECISION TOUT,ATOLA(*),RTOLA(*) X DOUBLE PRECISION XC(*),UP(*),W(*),Y(*),YP(*) X DOUBLE PRECISION UBXC(LDU,*),DFMAT(LDF,*),DPHI(LDP,*) X DOUBLE PRECISION XN(*),UBXN(LDU,*),AUGMT(LDA,*),MAIT(LDM,*) X DOUBLE PRECISION XINT(*),UPINT(*),WINT(*),UINT(5,*) X DOUBLE PRECISION W0(*),W1(*),W2(*),W3(*),W4(*),W5(*),W6(*) X DOUBLE PRECISION WRKMAT(LDW,*),WRK1(*),WRK2(*),WRK3(*) XC XC234567--1---------2---------3---------4---------5---------6---------7- XC XC This is a driver for the RK step routine DOPSTN. The XC integration continues until either NMAX steps have been XC taken or until T = TOUT has been reached. XC XC A new local system is constructed at each step. XC XC Variables in the calling sequence: XC ---------------------------------- XC GF EXT Subroutine for evaluating G XC DPGF EXT Subroutine for evaluating the partial derivative XC DpG of G with respect to P XC DWGF EXT Subroutine for evaluating the partial derivative XC DpG of G with respect to W XC FF EXT Subroutine for evaluating F XC DFF EXT Subroutine for evaluating the Jacobian of F XC SOLOUT EXT Subroutine for intermediate output XC TOUT D IN Desired stopping time XC ATOLA D IN Array of dimension 1, the absolute error tolerance XC RTOL D IN Array of dimension 1, the relative error tolerance XC XC D Array of dimension NVAR XC IN the given point XC = (U, T) XC OUT the last point XC = (U, T) XC UP D array of dimension NU XC IN the given derivative of u in global coordinates XC OUT the last derivative of u in global coordinates XC W D Array of dimension NW XC IN the given vector of algebraic variables XC OUT the last vector of algebraic variables XC Y D WK Array of dimension MDIM, the vector (U,T) XC in local coordinates XC YP D WK Array of dimension MDIM, derivative of the XC point in local coordinates XC UBXC D WK Array of dimension LDU x MDIM for the XC basis matrix at XC XC LDU I IN Leading dimension of UBXC, LDU >= NVAR XC DFMAT D WK Array of dimension LDF x NVAR for the Jacobian XC and its decomposition XC LDF I IN Leading dimension of DFMAT, LDF >= NALG XC AUGMT D WK Array of dimension LDA x NVAR for the XC augmented matrix at XC and its decomposition. XC LDA I IN Leading dimension of AUGMT, LDA >= NVAR XC JAUGM I WK Array of dimension of dimension NVAR for the XC pivot array used in the decomposition of AUGMT XC XN D WK Array of dimension NVAR, intermediate point XC UBXN D WK Array of dimension LDU x MDIM for the XC basis matrix at XN XC DPHI D WK Array of dimension NVAR x MDIM, the current XC derivative of the local parametrization XC LDP I IN leading dimension of DPHI, LDP >= NVAR XC MAIT D WK Array of dimension LDM x NDIF, for the XC iteration matrix and its factorization XC LDA I IN Leading dimension of MAIT, LDM >= NDIF XC JMAIT I WK Array of dimension NDIF, the pivot array of XC the LU factorization of MAIT XC XINT D WK Array of dimension NVAR for interpolation XC UPINT D WK Array of dimension NU for interpolation XC WINT D WK Array of dimension NW for interpolation XC UINT D WK Array of dimension 5*MDIM for use in interpolation XC W0-W6 D WK Seven work arrays of dimension MDIM XC WRKMAT D WK Work array of dimension LDW x NEQ XC LDW I IN Leading dimension of WRKMAT, LDW >= NEQ XC WRK1 D WK XC - WRK3 D WK Three work arrays of dimension NEQ XC IWRK I Wk Work array of dimension NEQ XC IER I OUT Error indicator XC IER = 1 computation successful XC but interrupted by SOLOUT XC IER = 0 no error, computation was successful XC IER = -1 other error encountered and printed out XC XC234567--1---------2---------3---------4---------5---------6---------7- XC XC.....Subroutines called: XC X EXTERNAL DGPHI,DOPSTN,GNBAS,INTN2,MSGPRT,ORIENT,DYN2 XC XC.....Parameters XC X INTEGER ITOL X DOUBLE PRECISION TFACT,ZER,HALF X PARAMETER( ITOL=0, TFACT=1.01D0, ZER=0.0D0, HALF=0.5D0 ) X CHARACTER*(*) LNAME X PARAMETER( LNAME = 'DRVN2' ) XC XC.....Local Variables XC X INTEGER I,J X DOUBLE PRECISION T,TLOC,TLOCL,TNEXT,TPR,TLAST X CHARACTER*6 TASK,MODE X CHARACTER*5 CHAR1, CHAR2 X CHARACTER*12 CHAR3 X LOGICAL LAST,ICFLAG XC XC.....Common block for machine constants XC X DOUBLE PRECISION EPMACH,SAFMIN X COMMON /MACH/EPMACH,SAFMIN XC XC.....Common block for data XC X INTEGER NMAX,JPOL,JNEWT X DOUBLE PRECISION H,HMIN,HMAX,POSNEG X COMMON /DATN2/H,HMIN,HMAX,POSNEG,NMAX,JPOL,JNEWT XC XC.....Common block for the statistics variables XC X INTEGER NSTEP,NACCPT,NREJCT,NDER,NGF,NDPGF,NDWGF,NFF,NDFF X COMMON /STAN2/NSTEP,NACCPT,NREJCT,NDER,NGF,NDPGF,NDWGF,NFF,NDFF XC XC.....Common block for dimensions XC X INTEGER NU,NW,NDIF,NEQ,NALG,NVAR,MDIM,MDIMM1,MDIMP1 X COMMON /DIMN2/NU,NW,NDIF,NEQ,NALG,NVAR,MDIM,MDIMM1,MDIMP1 XC XC.......................Executable statements......................... XC XC.....Get the Jacobian at the starting point XC XC X T = XC(NVAR) X CALL DFF( XC,T,DFMAT,LDF,IER ) X NDFF = NDFF + 1 X IF( IER .NE. 0 )THEN X CALL MSGPRT( LNAME,'Error in Jacobian evaluation' ) X IER = -1 X RETURN X ENDIF XC XC.....Copy XC into XN and place a copy of the Jacobian into AUGMT XC X DO 20 J = 1,NVAR X XN(J) = XC(J) X DO 10 I = 1,NALG X AUGMT(I,J) = DFMAT(I,J) X 10 CONTINUE X 20 CONTINUE XC XC.....Establish a local coordinate basis in UBXC XC X CALL GNBAS( NVAR,MDIM,UBXC,LDU,DFMAT,LDF, X & WRK1,WRK2,IWRK,SAFMIN,IER ) X IF( IER .NE. 0 ) THEN X CALL MSGPRT( LNAME,'The basis construction failed '// X & 'at the starting point' ) X IER = -1 X RETURN X ENDIF XC XC.....Write out starting point XC X TASK = 'START' X CALL SOLOUT( TASK,JPOL,NACCPT,XC,UP,W,T,T,T ) X IF ( TASK .EQ. 'STOP' ) THEN X CALL MSGPRT ( LNAME,'Interruption by SOLOUT, '// X & 'computation terminated' ) X IER = 0 X RETURN X ENDIF XC XC.....Loop point for accepted steps XC X 100 CONTINUE XC XC.....Check if we are close to the terminal value of T XC X MODE = 'INIT' X LAST = .FALSE. X IF( (T + TFACT*H - TOUT)*POSNEG .GT. ZER ) THEN X H = TOUT - T X LAST = .TRUE. X TLOCL = H X ENDIF XC XC.....Save the current time XC X TLAST = T XC XC.....We always start with the local coordinate Y = 0 XC.....which corresponds to XC XC X DO 120 I = 1, MDIM X Y(I) = ZER X 120 CONTINUE X TLOC = ZER XC XC.....Evaluate DPHI XC X TASK = 'FACTOR' X CALL DGPHI( TASK,NVAR,MDIM,DPHI,LDP,AUGMT,LDA, X & UBXC,LDU,JAUGM,IER ) X IF( IER .NE. 0 ) THEN X CALL MSGPRT( LNAME,'Error in computing the derivative '// X & 'of the local parametrization') X IER = -1 X RETURN X ENDIF XC XC.....Call the derivative routine XC X TASK = 'STEP' X 150 CONTINUE XC X CALL DYN2( MODE,GF,DPGF,DWGF,FF,DFF,Y,YP,UP,W, X & DPHI,LDP,XC,UBXC,LDU,AUGMT,LDA,JAUGM, X & XN,DFMAT,LDF,MAIT,LDM,JMAIT,WRKMAT,LDW, X & WRK1,WRK2,WRK3,IWRK,IER ) X NDER = NDER + 1 X IF ( IER .NE. 0 ) THEN X IF ( IER .GT. 0 .AND. TASK .EQ. 'EVAL' ) THEN X TASK = 'REDUCE' X H = HALF*H X ELSE X CALL MSGPRT( LNAME, X & ' Error return in evaluating the local ODE' ) X IER = -1 X RETURN X ENDIF X ENDIF XC XC.....Call the step routine XC X CALL DOPSTN( TASK,MDIM,TLOC,Y,YP,H,HMIN,HMAX,NMAX, X & ATOLA,RTOLA,ITOL,W0,W1,W2,W3,W4,W5,W6, X & JPOL,UINT,NSTEP,NACCPT,NREJCT ) X IF( TASK .EQ. 'EVAL' ) THEN X MODE = 'NEXT' X GOTO 150 X ELSEIF( TASK .EQ. 'DONE' ) THEN X GOTO 200 X ELSEIF( TASK .EQ. 'STPCNT' ) THEN X WRITE( CHAR1,180 ) NSTEP X WRITE( CHAR2,180 ) NMAX X 180 FORMAT(I5) X CALL MSGPRT( LNAME,'Step count '//CHAR1//' exceeds' X & //' given maximum NMAX= '//CHAR2 ) X IER = -2 X RETURN X ELSEIF ( TASK .EQ. 'MINSTP' ) THEN X WRITE( CHAR3,190 ) HMIN X 190 FORMAT(G12.4) X CALL MSGPRT( LNAME,'Step fell below HMIN ='//CHAR3 ) X IER = -3 X RETURN X ELSE X CALL MSGPRT( LNAME,'Error return from the RK-routine' ) X IER = -1 X RETURN X ENDIF XC X 200 CONTINUE X IF( LAST .AND. (TLOC .NE. TLOCL) )LAST = .FALSE. XC X TASK = 'PRNT' X TNEXT = XN(NVAR) X TPR = TNEXT X ICFLAG = .TRUE. X CALL SOLOUT( TASK,JPOL,NACCPT,XN,UP,W,TPR,TLAST,TNEXT ) XC X 220 CONTINUE X IF (TASK .EQ. 'PRNT') THEN X GOTO 300 X ELSEIF (TASK .EQ. 'STOP') THEN X CALL MSGPRT (LNAME,'Interruption by SOLOUT, '// X & 'computation terminated') X IER = 0 X RETURN X ELSEIF (TASK .EQ. 'INTP') THEN XC XC........Interpolation is requested XC........If this is the first time, copy the current UP and W XC X IF( ICFLAG )THEN X DO 230 I = 1, NU X UPINT(I) = UP(I) X 230 CONTINUE X DO 240 I = 1, NW X WINT(I) = W(I) X 240 CONTINUE X ICFLAG = .FALSE. X ENDIF X CALL INTN2( GF,DPGF,DWGF,FF,DFF,TPR,TLAST,TNEXT,UINT, X & XINT,UPINT,WINT,YP,XC,UBXC,LDU, X & AUGMT,LDA,JAUGM,DPHI,LDP,MAIT,LDM, X & JMAIT,WRKMAT,LDW,WRK1,WRK2,WRK3,IWRK,IER ) X NDER = NDER + 1 X IF (IER .NE. 0) THEN X CALL MSGPRT (LNAME,'Error in interpolation -- proceed') X GOTO 300 X ENDIF XC XC........Write out the interpolated solution XC X CALL SOLOUT( TASK,JPOL,NACCPT,XINT,UPINT,WINT, X & TPR,TLAST,TNEXT ) X GOTO 220 X ELSE XC X CALL MSGPRT (LNAME, X & 'SOLOUT returns unknown value of TASK -- proceed') X ENDIF XC XC.....Check for further action XC X 300 CONTINUE XC XC.....Copy XN into XC XC X DO 310 J = 1,NVAR X XC(J) = XN(J) X 310 CONTINUE X T = XC(NVAR) XC XC.....If this was the last step return XC X IF( LAST ) THEN X IER = 0 X RETURN X ENDIF XC XC.....Another step is desired. Copy the Jacobian into AUGMT XC.....and establish a new local coordinate system XC X DO 330 J = 1,NVAR X DO 320 I = 1,NALG X AUGMT(I,J) = DFMAT(I,J) X 320 CONTINUE X 330 CONTINUE XC XC.....Compute the basis matrix UBXC XC X CALL GNBAS( NVAR,MDIM,UBXN,LDU,DFMAT,LDF, X & WRK1,WRK2,IWRK,SAFMIN,IER ) X IF(IER .NE. 0) THEN X CALL MSGPRT(LNAME,'The basis construction at the '// X & 'new point failed') X IER = -1 X RETURN X ENDIF XC XC.....With the old basis as reference adjust the XC.....orientation of the new basis XC X CALL ORIENT( NU,MDIMM1,UBXC,LDU,UBXN,LDU, X & WRKMAT,LDW,IWRK,IER ) X IF(IER .NE. 0) THEN X CALL MSGPRT(LNAME,'Error in reorienting the new basis') X IER = -1 X RETURN X ENDIF XC XC.....Move basis from UBXN to UBXC XC X DO 350 J = 1,MDIM X DO 340 I = 1,NVAR X UBXC(I,J) = UBXN(I,J) X 340 CONTINUE X 350 CONTINUE XC XC.....Go back to the loop point for accepted steps XC X GOTO 100 XC XC.....End of DRVN2 XC X END XC XC234567==1=========2=========3=========4=========5=========6=========7= XC X SUBROUTINE DYN2( MODE,GF,DPGF,DWGF,FF,DFF,Y,YP,UP,W, X & DPHI,LDP,XC,UBXC,LDU,AUGMT,LDA,JAUGM, X & XN,DFMAT,LDF,MAIT,LDM,JMAIT,WRKMAT,LDW, X & WRK1,WRK2,WRK3,IWRK,IER ) XC X EXTERNAL GF,DPGF,DWGF,FF,DFF X CHARACTER*6 MODE XC X INTEGER IER,LDA,LDF,LDM,LDP,LDU,LDW X INTEGER JAUGM(*),JMAIT(*),IWRK(*) XC X DOUBLE PRECISION Y(*),YP(*),UP(*),W(*),XC(*),XN(*) X DOUBLE PRECISION UBXC(LDU,*),AUGMT(LDA,*),DFMAT(LDF,*) X DOUBLE PRECISION DPHI(LDP,*),MAIT(LDM,*),WRKMAT(LDW,*) X DOUBLE PRECISION WRK1(*),WRK2(*),WRK3(*) XC XC234567--1---------2---------3---------4---------5---------6---------7- XC XC Subroutine for evaluating y', w as solution of the implicit XC local ODE XC XC G( phi(y), Dphi(y)y', w , t) = 0 XC XC for given y, t. Here x = phi(y) is the local parametrization. XC A chord Newton method is used with the Jacobian at the previous XC point as iteration matrix XC XC This routine uses DOPSTN. XC XC Variables in the calling sequence: XC ---------------------------------- XC MODE C IN Point indicator XC MODE = 'INIT', the global point is in XN = XC XC MODE = 'NEXT', compute the next global point XN XC and retain a copy of the Jacobian XC at XN in DFMAT XC GF EXT Subroutine for evaluating G XC DPGF EXT Subroutine for evaluating the partial derivative XC DpG of G with respect to P XC DWGF EXT Subroutine for evaluating the partial derivative XC DpG of G with respect to W XC FF EXT Subroutine for evaluating F XC DFF EXT Subroutine for evaluating the Jacobian of F XC Y D IN array of dimension MDIM, the vector (U,T) XC in local coordinates XC YP D OUT array of dimension MDIM, derivative of the XC point in local coordinates XC UP D array of dimension NU XC IN the last derivative of u in global coordinates XC OUT the current derivative of u in global coordinates XC W D array of dimension NW XC IN the last vector of algebraic variables XC OUT the current vector of algebraic variables XC DPHI D OUT Array of dimension NVAR x MDIM, the current XC derivative of the local parametrization XC LDP I IN leading dimension of DPHI, LDP >= NVAR XC XC D IN Array of dimension NVAR, the center point of XC the local cordinate system in global coordinates XC UBXC D IN Array of dimension LDU x MDIM for the basis matrix XC basis matrix at XC XC LDU I IN Leading dimension of UBXC and UBXN, LDU >= NVAR XC AUGMT D IN Array of dimension LDA x NVAR for the XC augmented matrix at XC and its decomposition. XC LDA I IN Leading dimension of AUGMT, LDA >= NVAR XC JAUGM I IN Array of dimension NALG for the pivot array of XC the LQ factorization of DF(XC) XC XN D Array of dimension NVAR XC IN XN = XC XC OUT the next point in global coordinates XC DFMAT D OUT Array of dimension LDF x NVAR, for MODE = 'NEXT' XC retains a copy of the Jacobian at X XC LDF I IN Leading dimension of DFMAT, LDF >= NALG XC MAIT D IN Array of dimension LDM x NDIF, for the XC iteration matrix and its factorization XC LDM I IN Leading dimension of MAIT, LDM >= NDIF XC JMAIT I IN Array of dimension NDIF, the pivot array of XC the LU factorization of MAIT XC WRKMAT D WK Work array of dimension LDW x NEQ XC LDW I IN Leading dimension of WRKMAT, LDW >= NEQ XC WRK1 XC - WRK3 D WK Three work arrays of dimension NEQ XC IWRK I WK Work array of dimension NEQ XC IER I OUT error indicator XC IER = 1 correctable error -- steplength too XC large -- no printout from MSGPRT XC IER = 0 no error XC IER = -1 fatal error, printout from MSGPRT XC XC234567--1---------2---------3---------4---------5---------6---------7- XC XC.....Subroutines called: XC X EXTERNAL EVXN2,MATN2,MSGPRT,NWTN2 XC XC.....Parameters XC X CHARACTER*(*) LNAME X PARAMETER( LNAME = 'DYN2') XC XC.....Local variables XC X INTEGER ICOPY X CHARACTER*6 TASK XC XC.....Common block for data XC X INTEGER NMAX,JPOL,JNEWT X DOUBLE PRECISION H,HMIN,HMAX,POSNEG X COMMON /DATN2/H,HMIN,HMAX,POSNEG,NMAX,JPOL,JNEWT XC XC.......................Executable statements......................... XC XC.....If we are not at the first point, determine the global XC.....point XN with the local coordinate Y and DPHI XC X IF( MODE .EQ. 'NEXT' )THEN XC X ICOPY = 1 X CALL EVXN2( FF,DFF,Y,XN,WRK1,DPHI,LDP,XC,UBXC,LDU, X & AUGMT,LDA,JAUGM,WRKMAT,LDW,IWRK, X & DFMAT,LDF,ICOPY,IER ) X IF( IER .NE. 0 )THEN X IF( IER .GT. 0 )THEN X IER = 1 X RETURN X ELSE X CALL MSGPRT(LNAME, X & 'Error in computing the next point') X IER = -1 X RETURN X ENDIF X ENDIF X ENDIF XC XC.....At the first point or for JNEWT = 1 set up and factor XC.....the iteration matrix XC X IF( MODE .EQ. 'INIT' .OR. JNEWT .EQ. 1 )THEN XC X CALL MATN2( DPGF,DWGF,XN,UP,W,DPHI,LDP, X & MAIT,LDM,JMAIT,IER ) X IF( IER .NE. 0 )THEN X CALL MSGPRT( LNAME, X & 'Error in computing the iteration matrix' ) X IER = -1 X RETURN X ENDIF XC X ENDIF XC XC.....Solve the nonlinear system XC X TASK = 'NEWYP' X IF( MODE .EQ. 'NEXT' )TASK = 'OLDYP' X CALL NWTN2( TASK,GF,XN,UP,W,YP,DPHI,LDP,MAIT,LDM, X & JMAIT,WRK1,WRK2,WRK3,IER) XC X IF( IER .NE. 0 )THEN X IF( IER .GT. 0 )THEN X IER = 1 X ELSE X CALL MSGPRT( LNAME, X & 'Error return from the iterative solver' ) X IER = -1 X ENDIF X ELSE X IER = 0 X ENDIF XC X RETURN XC XC.....End of DYN2 XC X END XC XC234567==1=========2=========3=========4=========5=========6=========7= XC X SUBROUTINE INTN2( GF,DPGF,DWGF,FF,DFF,TPR,TLAST,TNEXT,UINT, X & XINT,UPINT,WINT,YP,XC,UBXC,LDU, X & AUGMT,LDA,JAUGM,DPHI,LDP,MAIT,LDM,JMAIT, X & WRKMAT,LDW,WRK1,WRK2,WRK3,IWRK,IER ) XC X EXTERNAL GF,DPGF,DWGF,FF,DFF XC X INTEGER LDA,LDM,LDP,LDU,LDW,IER,JMAIT(*),JAUGM(*),IWRK(*) X DOUBLE PRECISION TLAST,TNEXT,UINT(5,*) X DOUBLE PRECISION XINT(*),UPINT(*),WINT(*),TPR,YP(*) X DOUBLE PRECISION XC(*),UBXC(LDU,*),AUGMT(LDA,*) X DOUBLE PRECISION DPHI(LDP,*),MAIT(LDM,*) X DOUBLE PRECISION WRKMAT(LDW,*),WRK1(*),WRK2(*),WRK3(*) XC XC234567--1---------2---------3---------4---------5---------6---------7- XC XC Routine for interpolating between computed points when XC intermediate output is desired. XC XC Variables in the calling sequence: XC ---------------------------------- XC GF EXT Subroutine for evaluating G XC FF EXT Subroutine for evaluating F XC TPR D IN The time where interpolation is requested XC TLAST D IN The last time XC TNEXT D IN The next time XC UINT D IN Interpolation array of dimension 5 * MDIM computed XC by DOPSTN for the step from TLAST to TNEXT XC XINT D IN Array of dimension NVAR, the current (U,T) XC where T = TPR is the desired interpolation time XC UPINT D Array of dimension NU XC IN The last derivative of U in global coordinates XC OUT The interpolated global derivative XC WINT D Array of dimension NW XC IN The last vector of algebraic variables XC OUT The interpolated vector of algebraic variables XC YP D OUT Array of dimension MDIM, local direction at XC the interpolated point XC XC D IN Array of dimension NVAR, center point of the XC local parametrization XC UBXC D IN Array of dimension LDU x MDIM for the basis XC matrix at XC XC LDU I IN Leading dimension of UBXC, LDU >= NVAR XC AUGMT D WK Array of dimension LDA x NVAR for the XC augmented matrix at XC and its decomposition. XC LDA I IN Leading dimension of AUGMT, LDA >= NVAR XC JAUGM I WK Array of dimension of dimension NVAR for the XC pivot array used in the decomposition of AUGMT XC DPHI D OUT Array of dimension NVAR x MDIM, the current XC derivative of the local parametrization XC LDP I IN leading dimension of DPHI, LDP >= NVAR XC MAIT D IN Array of dimension LDM x NDIF, the LU-factored XC iteration matrix at XC XC LDA I IN Leading dimension of MAIT, LDA >= NDIF XC JMAIT I IN Array of dimension NDIF, the pivot array of XC the LU factorization of MAIT XC WRKMAT D WK Work array of dimension NVAR x NVAR XC LDW I IN Leading dimension of WRKMAT, LDW >= NVAR XC WRK1 XC -WRK3 D WK Three work arrays of dimension NVAR XC IWRK I WK Work array of dimension NVAR XC IER I OUT Error indicator XC IER = 0 No error XC IER = -1 TPR was not between TLAST and TNEXT XC IER = -2 Projection onto the manifold failed XC IER = -3 Solution of the nonlinear equ. failed XC XC234567--1---------2---------3---------4---------5---------6---------7- XC XC.....Subroutines called XC X EXTERNAL MATN2,EVXN2,MSGPRT,NWTN2 XC XC.....Local variables XC X INTEGER I,ICOPY X DOUBLE PRECISION DUM(1,1),HT, ONE, ZER, S X CHARACTER*6 TASK X CHARACTER*(*) LNAME X PARAMETER( LNAME = 'INTN2' ) XC X PARAMETER( ONE=1.0D0, ZER=0.0D0 ) XC XC.....Common block for data XC X INTEGER NMAX,JPOL,JNEWT X DOUBLE PRECISION H,HMIN,HMAX,POSNEG X COMMON /DATN2/H,HMIN,HMAX,POSNEG,NMAX,JPOL,JNEWT XC XC.....Common block for dimensions XC X INTEGER NU,NW,NDIF,NEQ,NALG,NVAR,MDIM,MDIMM1,MDIMP1 X COMMON /DIMN2/NU,NW,NDIF,NEQ,NALG,NVAR,MDIM,MDIMM1,MDIMP1 XC XC.......................Executable statements......................... XC XC.....Get effective step and check for TINT between TLAST and TNEXT XC X HT = TNEXT - TLAST X S = (TPR - TLAST)/HT X IF( (S .LT. ZER) .OR. (S .GT. ONE) ) THEN X CALL MSGPRT ( LNAME,'Interpolation requested outside '// X & 'the last integration interval') X IER = -1 X RETURN X ENDIF XC XC.....Evaluate the interpolation polynomial at S to get YINT XC X DO 10 I = 1,MDIM X WRK1(I) = UINT(1,I) + HT*S*(UINT(2,I) + S*(UINT(3,I) X & + S*(UINT(4,I) + S*UINT(5,I)))) X 10 CONTINUE X WRK1(MDIM) = HT*S XC XC.....Get desired point on the manifold corresponding to WRK1 XC X ICOPY = 0 X CALL EVXN2( FF,DFF,WRK1,XINT,WRK2,DPHI,LDP,XC, X & UBXC,LDU,AUGMT,LDA,JAUGM,WRKMAT,LDW, X & IWRK,DUM,1,ICOPY,IER ) X IF( IER .NE. 0 ) THEN X CALL MSGPRT( LNAME, X & 'Error in evaluating the global interpolation point') X IER = -1 X RETURN X ENDIF XC X IF( JNEWT .EQ. 0 )THEN XC X TASK = 'OLDYP' X CALL NWTN2( TASK,GF,XINT,UPINT,WINT,YP,DPHI,LDP, X & MAIT,LDM,JMAIT,WRK1,WRK2,WRK3,IER) XC X ELSE XC XC........Set up and factor the iteration matrix XC X CALL MATN2( DPGF,DWGF,XINT,UPINT,WINT,DPHI,LDP, X & WRKMAT,LDW,IWRK,IER ) X IF( IER .NE. 0 ) THEN X CALL MSGPRT( LNAME, X & 'Error in computing the iteration matrix' ) X IER = -1 X RETURN X ENDIF XC X TASK = 'NEWYP' X CALL NWTN2( TASK,GF,XINT,UPINT,WINT,YP,DPHI,LDP, X & WRKMAT,LDW,IWRK,WRK1,WRK2,WRK3,IER) XC X ENDIF XC X IF( IER .NE. 0 )THEN X CALL MSGPRT( LNAME,'Error return from the iterative solver' ) X IER = -3 X RETURN X ENDIF XC X IER = 0 XC X RETURN XC XC.....End of INTN2 XC X END XC XC234567==1=========2=========3=========4=========5=========6=========7= XC X SUBROUTINE MATN2( DPGF,DWGF,X,UP,W,DPHI,LDP,MAIT,LDM,JMAIT,IER ) XC X EXTERNAL DPGF,DWGF XC X INTEGER IER,LDM,LDP,JMAIT(*) XC X DOUBLE PRECISION X(*),UP(*),W(*) X DOUBLE PRECISION DPHI(LDP,*),MAIT(LDM,*) XC XC234567--1---------2---------3---------4---------5---------6---------7- XC XC Subroutine for evaluating the iteration matrix XC XC ( (DpG*DPHI) DwG ) XC ( (0 1) 0 ) XC XC for the chord Newton process for a given point (U, UP, W, T) XC where X = (U, T) XC XC Variables in the calling sequence: XC ---------------------------------- XC DPGF EXT Subroutine for evaluating the partial derivative XC DpG of G with respect to P XC DWGF EXT Subroutine for evaluating the partial derivative XC DpG of G with respect to W XC X D IN Array of dimension MDIM, the global vector (U,T) XC UP D Array of dimension NU, the global vector U' XC W D Array of dimension NW, the algebraic vector XC DPHI D IN Array of dimension NVAR x MDIM, the derivative XC of the local parametrization XC LDP I IN leading dimension of DPHI, LDP >= NVAR XC MAIT D OUT Array of dimension LDM x NDIF, for the LU factored XC iteration matrix XC LDM I IN Leading dimension of MAIT, LDM >= NDIF XC JMAIT I IN Array of dimension NDIF, the pivot array of XC the LU factorization of MAIT XC IER I OUT error indicator XC IER = 0 no error XC IER = -1 fatal error, printout from MSGPRT XC XC234567--1---------2---------3---------4---------5---------6---------7- XC XC.....Subroutines called: XC X EXTERNAL LUF,MSGPRT XC XC.....Parameters XC X DOUBLE PRECISION ZER, ONE X PARAMETER( ZER=0.0D0, ONE=1.0D0 ) X CHARACTER*(*) LNAME X PARAMETER( LNAME = 'MATN2') XC XC.....Local variables XC X INTEGER J X DOUBLE PRECISION T XC XC.....Common block for the statistics variables XC X INTEGER NSTEP,NACCPT,NREJCT,NDER,NGF,NDPGF,NDWGF,NFF,NDFF X COMMON /STAN2/NSTEP,NACCPT,NREJCT,NDER,NGF,NDPGF,NDWGF,NFF,NDFF XC XC.....Common block for dimensions XC X INTEGER NU,NW,NDIF,NEQ,NALG,NVAR,MDIM,MDIMM1,MDIMP1 X COMMON /DIMN2/NU,NW,NDIF,NEQ,NALG,NVAR,MDIM,MDIMM1,MDIMP1 XC XC.......................Executable statements......................... XC X T = X(NVAR) XC XC.....Multiply DpG*DPHI and store in MAIT XC X CALL DPGF( X,UP,W,T,DPHI,NVAR,MDIM,MAIT,LDM,IER ) X NDPGF = NDPGF +1 X IF( IER .NE. 0 )THEN X CALL MSGPRT( LNAME, X & 'Error in differentiating F with respect to UP' ) X IER = -1 X RETURN X ENDIF XC XC.....Store DwG in the remaining columns of MAIT XC X CALL DWGF( X,UP,W,T,MAIT(1,MDIMP1),NDIF,IER ) X NDWGF = NDWGF +1 X IF( IER .NE. 0 )THEN X CALL MSGPRT( LNAME, X & 'Error in differentiating F with respect to W' ) X IER = -1 X RETURN X ENDIF XC XC.....Add last row to MAIT XC X DO 50 J = 1, NDIF X MAIT(NDIF,J) = ZER X 50 CONTINUE X MAIT(NDIF,MDIM) = ONE XC XC.....Factor the iteration matrix XC X CALL LUF( NDIF,MAIT,LDM,JMAIT,IER ) X IF( IER .NE. 0 )THEN X CALL MSGPRT( LNAME, X & ' LU-decomposition of the iteration matrix failed' ) X IER = -1 X RETURN X ENDIF XC X IER = 0 XC X RETURN XC XC.....End of MATN2 XC X END XC XC234567==1=========2=========3=========4=========5=========6=========7= XC X SUBROUTINE EVXN2( FF,DFF,Y,X,FX,DPHI,LDP,XC,UBXC,LDU, X & AUGMT,LDA,JAUGM,WRKMAT,LDW,IWRK, X & DFMAT,LDF,ICOPY,IER ) XC X EXTERNAL FF,DFF XC X INTEGER IER,ICOPY,IWRK(*),JAUGM(*),LDA,LDF,LDP,LDU,LDW XC X DOUBLE PRECISION Y(*),X(*),FX(*),XC(*),DPHI(LDP,*),UBXC(LDU,*) X DOUBLE PRECISION AUGMT(LDA,*),WRKMAT(LDW,*),DFMAT(LDF,*) XC XC234567--1---------2---------3---------4---------5---------6---------7- XC XC For a given local point Y in the local parametrization defined XC at XC with the basis UBXC, the subroutine evaluates the XC corresponding global point X on the manifold and the derivative XC Dphi(Y) of the local parametrization. XC XC Variables in the calling sequence: XC ---------------------------------- XC FF EXT Subroutine for evaluating F XC DFF EXT Subroutine for evaluating the Jacobian of F XC Y D IN Array of dimension MDIM, the local vector XC X D OUT Array of dimension NVAR, the corresponding XC global vector (U, T) XC FX D OUT The function value at X XC DPHI D OUT Array of dimension NVAR x MDIM, the computed XC derivative of the local parametrization XC LDP I IN leading dimension of DPHI, LDP >= NVAR XC XC D IN Array of dimension NVAR, the center point of XC the local cordinate system in global coordinates XC UBXC D IN Array of dimension LDU x MDIM for the basis matrix XC basis matrix at XC XC LDU I IN Leading dimension of UBXC and UBXN, LDU >= NVAR XC AUGMT D IN Array of dimension LDA x NVAR for the XC augmented matrix at XC and its decomposition. XC LDA I IN Leading dimension of AUGMT, LDA >= NVAR XC JAUGM I IN Array of dimension NALG for the pivot array of XC the LQ factorization of DF(XC) XC WRKMAT D WK Work array of dimension LDW x NVAR XC LDW I IN Leading dimension of WRKMAT, LDW >= NALG XC IWRK I WK Work array of dimension NALG XC DFMAT D OUT Array of dimension LDF x NVAR, which for ICOPY = 1 XC will retain a copy of the Jacobian at X XC For ICOPY = 0 the array is not referenced XC LDF I IN Leading dimension of DFMAT, LDF >= NALG XC ICOPY I IN Copy indicator XC ICOPY = 0 the array DFMAT is not referenced XC ICOPY = 1 a copy of the Jacobian at X is XC returned in DFMAT XC IER I OUT error indicator XC IER = 1 correctable error -- ||Y|| is too XC large for convergence of phi. XC -- no printout from MSGPRT XC IER = 0 no error XC IER = -1 fatal error, printout from MSGPRT XC XC234567--1---------2---------3---------4---------5---------6---------7- XC XC.....Subroutines called: XC X EXTERNAL GPHI,DGPHI,MSGPRT XC XC.....Parameters XC X CHARACTER*(*) LNAME X PARAMETER( LNAME = 'EVXN2') XC XC.....Local variables XC X INTEGER I,ISTEP,J X DOUBLE PRECISION T X CHARACTER*6 TASK XC XC.....Common block for machine constants XC X DOUBLE PRECISION EPMACH,SAFMIN X COMMON /MACH/EPMACH,SAFMIN XC XC.....Common block for the statistics variables XC X INTEGER NSTEP,NACCPT,NREJCT,NDER,NGF,NDPGF,NDWGF,NFF,NDFF X COMMON /STAN2/NSTEP,NACCPT,NREJCT,NDER,NGF,NDPGF,NDWGF,NFF,NDFF XC XC.....Common block for dimensions XC X INTEGER NU,NW,NDIF,NEQ,NALG,NVAR,MDIM,MDIMM1,MDIMP1 X COMMON /DIMN2/NU,NW,NDIF,NEQ,NALG,NVAR,MDIM,MDIMM1,MDIMP1 XC XC.......................Executable statements......................... XC XC.....Get desired point on the manifold corresponding to Y XC X TASK = 'START' X 10 CONTINUE X CALL GPHI( TASK,NVAR,MDIM,Y,X,FX,XC,UBXC,LDU, X & AUGMT,LDA,JAUGM,EPMACH,ISTEP ) X IF( TASK .EQ. 'EVAL' )THEN X CALL FF( X,X(NVAR),FX,IER ) X NFF = NFF + 1 X IF(IER .NE. 0)THEN X CALL MSGPRT( LNAME,'Error in evaluating the function F' ) X IER = -1 X RETURN X ENDIF X GOTO 10 X ELSEIF (TASK .EQ. 'DONE') THEN X GOTO 20 X ELSEIF( TASK .EQ. 'DIVERG' .OR. TASK .EQ. 'STPCNT' )THEN X IER = 1 X RETURN X ELSE X CALL MSGPRT (LNAME, X & 'Error in computing the local parametrization' ) X IER = -1 X RETURN X ENDIF XC X 20 CONTINUE XC XC.....Get Jacobian of F at the new point and store in WRKMAT XC X T = X(NVAR) X CALL DFF( X,T,WRKMAT,LDW,IER ) X NDFF = NDFF + 1 X IF( IER .NE. 0 ) THEN X CALL MSGPRT( LNAME,'Error in evaluating the Jacobian' ) X IER = -1 X RETURN X ENDIF XC XC.....If desired, retain a copy of the Jacobian in DFMAT XC X IF( ICOPY .NE. 0 )THEN X DO 40 J = 1,NVAR X DO 30 I = 1,NALG X DFMAT(I,J) = WRKMAT(I,J) X 30 CONTINUE X 40 CONTINUE X ENDIF XC XC.....Compute DPHI XC X TASK = 'FACTOR' X CALL DGPHI( TASK,NVAR,MDIM,DPHI,LDP,WRKMAT,LDW, X & UBXC,LDU,IWRK,IER ) X IF( IER .NE. 0 ) THEN X CALL MSGPRT( LNAME,'Error in computing the derivative '// X & 'of the local parametrization' ) X IER = -2 X RETURN X ENDIF XC X IER = 0 X RETURN XC XC.....End of EVXN2 XC X END XC XC234567==1=========2=========3=========4=========5=========6=========7= XC X SUBROUTINE NWTN2( TASK,GF,X,UP,W,YP,DPHI,LDP,MAIT,LDM,JMAIT, X & WRK1,WRK2,WRK3,IER) XC X EXTERNAL GF XC X CHARACTER*6 TASK X INTEGER LDM,LDP,JMAIT(*) X DOUBLE PRECISION X(*),UP(*),W(*),YP(*) X DOUBLE PRECISION DPHI(LDP,*),MAIT(LDM,*) X DOUBLE PRECISION WRK1(*),WRK2(*),WRK3(*) XC XC234567--1---------2---------3---------4---------5---------6---------7- XC XC For specified Y and hence known X = (U,T) = PHI(Y), use a chord XC Newton process with the given iteration matrix MAIT to determine XC the solution (YP, W) of the nonlinear system XC XC H( YP,W ) = G( U, DPHI(Y)YP, W , T) = 0, . XC XC Variables in the calling sequence XC --------------------------------- XC TASK C IN Task indicator XC TASK = 'NEWYP' determine a new starting YP XC TASK = 'OLDYP' use the previous YP as starting point XC GF EXT Subroutine for evaluating G XC X D IN Array of dimension NVAR, the current (U,T) XC UP D Array of dimension NU XC IN The last derivative of U in global coordinates XC OUT The current derivative of U in global coordinates XC W D Array of dimension NW XC IN The last vector of algebraic variables XC OUT The current vector of algebraic variables XC YP D OUT Array of dimension MDIM, derivative of the XC point in local coordinates XC DPHI D OUT Array of dimension NVAR x MDIM, the current XC derivative of the local parametrization XC LDP I IN leading dimension of DPHI, LDP >= NVAR XC MAIT D IN Array of dimension LDM x NDIF, the LU-factored XC iteration matrix XC LDA I IN Leading dimension of MAIT, LDM >= NDIF XC JMAIT I IN Array of dimension NDIF, the pivot array of XC the LU factorization of MAIT XC WRK1 XC - WRK3 D WK Three work arrays of dimension NDIF XC IER I OUT error indicator XC IER = 1 either divergence detected or XC stepcount exceeded. This may be a XC correctable error, no MSGPRT printout XC IER = 0 no error XC IER = -1 fatal error, printout from MSGPRT XC XC234567--1---------2---------3---------4---------5---------6---------7- XC XC.....External subroutines XC X EXTERNAL LUS1 XC XC.....Function calls XC X DOUBLE PRECISION DDIST2 XC XC.....Parameters XC X INTEGER MAXSTP X DOUBLE PRECISION FAC, FACLOW X PARAMETER( FAC=1.0D1, FACLOW=1.05D0, MAXSTP=100 ) X DOUBLE PRECISION ZER, ONE, SIXTN X PARAMETER( ZER=0.0D0, ONE=1.0D0, SIXTN=1.6D1 ) X CHARACTER*(*) LNAME X PARAMETER( LNAME = 'NWTN2') XC XC.....Local variables XC X INTEGER I,IER,ISTEP,J X DOUBLE PRECISION SUM,T,TMP XC XC.....Common block for machine constants XC X DOUBLE PRECISION EPMACH,SAFMIN X COMMON /MACH/EPMACH,SAFMIN XC XC.....Common block for the statistics variables XC X INTEGER NSTEP,NACCPT,NREJCT,NDER,NGF,NDPGF,NDWGF,NFF,NDFF X COMMON /STAN2/NSTEP,NACCPT,NREJCT,NDER,NGF,NDPGF,NDWGF,NFF,NDFF XC XC.....Common block for dimensions XC X INTEGER NU,NW,NDIF,NEQ,NALG,NVAR,MDIM,MDIMM1,MDIMP1 X COMMON /DIMN2/NU,NW,NDIF,NEQ,NALG,NVAR,MDIM,MDIMM1,MDIMP1 XC XC.....Variables saved between calls XC X DOUBLE PRECISION NCALL,HNRM,HNRML,ABSERR,RELERR,REL16, X & STEP,STEPL,TOL,TOL16,TOLD16 X SAVE NCALL,HNRM,HNRML,ABSERR,RELERR,REL16, X & STEP,STEPL,TOL,TOL16,TOLD16 XC X DATA HNRM/1.0D5/, STEP/1.0D5/, STEPL/1.0D5/ XC X DATA NCALL/0/ XC XC.......................Executable statements......................... XC XC.....Set error constants when this is the first call XC X IF( NCALL . EQ. 0 )THEN X RELERR = SQRT(EPMACH) X ABSERR = RELERR/SIXTN X REL16 = RELERR*SIXTN X NCALL = 1 X ENDIF XC XC.....If needed, determine a starting YP and store in WRK1 XC X ISTEP = 0 X IF( TASK .EQ. 'NEWYP' )THEN X DO 20 J = 1,MDIM X SUM = ZER X DO 10 I = 1,NU X SUM = SUM + DPHI(I,J)*UP(I) X 10 CONTINUE X WRK1(J) = SUM X 20 CONTINUE X DO 30 I = 1,NU X WRK3(I) = UP(I) X 30 CONTINUE X ELSE X DO 40 I = 1,MDIM X WRK1(I) = YP(I) X 40 CONTINUE X DO 60 I = 1,NU X SUM = ZER X DO 50 J = 1,MDIM X SUM = SUM + DPHI(I,J)*WRK1(J) X 50 CONTINUE X WRK3(I) = SUM X 60 CONTINUE X ENDIF X WRK1(MDIM) = ONE XC XC.....Complete the starting vector in WRK1 XC X DO 70 J = 1, NW X WRK1(MDIM+J) = W(J) X 70 CONTINUE X T = X(NVAR) XC XC.....Determine current error constants XC X TMP = DDIST2( NDIF,WRK1,1,WRK1,1,1 ) X TOL = RELERR*TMP + ABSERR X TOL16 = TOL*SIXTN X TOLD16 = TOL/SIXTN XC XC.....Iteration point XC X 100 CONTINUE XC XC.....Evaluate the function and store in WRK2 XC X CALL GF( X,WRK3,WRK1(MDIMP1),T,WRK2,IER ) X NGF = NGF + 1 X IF( IER .NE. 0 )THEN X CALL MSGPRT( LNAME,'Error in evaluating G' ) X IER = -1 X RETURN X ENDIF X WRK2(NDIF) = ZER XC XC.....Compute the function norm XC X HNRML = HNRM X HNRM = DDIST2( NDIF,WRK2,1,WRK2,1,1 ) XC XC.....Test for convergence XC X IF( ISTEP .EQ. 0 )THEN X IF( HNRM .LE. ABSERR ) GOTO 200 X ELSE XC XC........Strong acceptance test XC X IF( HNRM .LE. RELERR .AND. STEP .LE. TOL )GOTO 200 XC XC........Weak acceptance tests XC X IF( HNRM .LE. ABSERR .OR. STEP .LE. TOLD16 )GOTO 200 X IF( ISTEP .GE. 2 ) THEN X IF( (HNRM+HNRML) .LE. RELERR X & .AND. STEP.LE.TOL16 )GOTO 200 X IF( HNRM .LE. REL16 X & .AND. (STEP+STEPL).LE.TOL )GOTO 200 X ENDIF XC XC........Divergence test XC X IF( ISTEP .EQ. 1 ) THEN X IF( HNRM .GT. (FAC*HNRML+RELERR) )GOTO 300 X ELSEIF( ISTEP .EQ. 2 )THEN X IF( STEP .GT. (FAC*STEPL+RELERR) )GOTO 300 X IF( HNRM .GT. (FACLOW*HNRML+RELERR) )GOTO 300 X ELSE X IF( STEP .GT. (FACLOW*STEPL+RELERR) )GOTO 300 X IF( HNRM .GT. (FACLOW*HNRML+RELERR) )GOTO 300 X ENDIF X ENDIF XC XC.....Check for maximum number of steps XC X IF( ISTEP .GT. MAXSTP )GOTO 350 XC XC.....Solve the chord Newton equation XC X CALL LUS1( NDIF,MAIT,LDM,JMAIT,WRK2,IER ) X IF( IER .NE. 0 )THEN X CALL MSGPRT( LNAME, X & 'Error in solving for the iteration step' ) X IER = -1 X RETURN X ENDIF XC XC.....Form the next iterate XC X STEPL = STEP X STEP = DDIST2(NDIF,WRK2,1,WRK2,1,1) X DO 130 I = 1,NDIF X WRK1(I) = WRK1(I) - WRK2(I) X 130 CONTINUE X WRK1(MDIM) = ONE XC XC.....Multiply DPHI times YP and store the current global XC.....direction UP in WRK3 XC X DO 150 I = 1,NU X SUM = ZER X DO 140 J = 1,MDIM X SUM = SUM + DPHI(I,J)*WRK1(J) X 140 CONTINUE X WRK3(I) = SUM X 150 CONTINUE XC XC.....Increment step counter and return to iteration point XC X ISTEP = ISTEP + 1 X GOTO 100 XC XC.....Common returns XC X 200 CONTINUE XC XC.....Successful return, set YP, UP, and W XC X DO 210 J = 1,MDIM X YP(J) = WRK1(J) X 210 CONTINUE X YP(MDIM) = ONE X DO 220 J = 1, NU X UP(J) = WRK3(J) X 220 CONTINUE X DO 230 J = 1, NW X W(J) = WRK1(MDIM+J) X 230 CONTINUE XC X IER = 0 X RETURN XC X 300 CONTINUE XC XC.....Divergence detected. Since this is expected to be XC.....correctable by a smaller steplength, no message is XC.....printed here XC X IER = 1 X RETURN XC X 350 CONTINUE XC XC.....Maximal stepcount exceeded.Since this is expected to be XC.....correctable by a smaller steplength, no message is XC.....printed here XC X IER = 2 X RETURN XC XC.....End of NWTN2 XC X END XC XC234567==1=========2=========3=========4=========5=========6=========7= XC X SUBROUTINE WSTN2( LOUT ) XC X INTEGER LOUT XC XC234567--1---------2---------3---------4---------5---------6---------7- XC XC Routine for printing some run statistics for DAEN2 XC XC Variable in the calling sequence: XC ---------------------------------- XC LOUT I IN Output unit number XC XC234567--1---------2---------3---------4---------5---------6---------7- XC XC.....Common block for the statistics variables XC X INTEGER NSTEP,NACCPT,NREJCT,NDER,NGF,NDPGF,NDWGF,NFF,NDFF X COMMON /STAN2/NSTEP,NACCPT,NREJCT,NDER,NGF,NDPGF,NDWGF,NFF,NDFF XC XC.......................Executable statements......................... XC X WRITE(LOUT,10)NSTEP,NACCPT,NREJCT X 10 FORMAT(1X/' Number of steps: '/ X & ' Total= ',I6,' Accepted= ',I6,' Rejected= ',I6) XC X WRITE(LOUT,20) NDER X 20 FORMAT(' Local ODE evaluations = ',I6) XC X WRITE(LOUT,30) NGF,NDPGF,NDWGF,NFF,NDFF X 30 FORMAT(' Function calls:'/ X & ' G = ',I6,' DPG = ',I6,' DWG = ',I6, X & ' F = ',I6,' DF = ',I6) XC X RETURN XC XC.....End of WSTN2 XC X END XC XC234567==1=========2=========3=========4=========5=========6=========7= SHAR_EOF : || $echo 'restore of' 'daen2.f' 'failed' fi # ============= daeq2.f ============== if test -f 'daeq2.f' && test "$first_param" != -c; then $echo 'x -' SKIPPING 'daeq2.f' '(file already exists)' else $echo 'x -' extracting 'daeq2.f' '(text)' sed 's/^X//' << 'SHAR_EOF' > 'daeq2.f' && XC234567==1=========2=========3=========4=========5=========6=========7= XC X SUBROUTINE DAEQ2( AMAT,BMAT,GF,FF,DFF,SOLOUT, X & KU,KW,KD,U,T,TOUT, X & RDATA,IDATA,ATOL,RTOL, X & RWORK,LRW,IWORK,LIW,IER) XC X EXTERNAL AMAT,BMAT,GF,FF,DFF,SOLOUT XC X INTEGER KU,KW,KD,LRW,LIW,IER X INTEGER IDATA(10),IWORK(LIW) X DOUBLE PRECISION U(*),T,TOUT X DOUBLE PRECISION ATOL,RTOL,RDATA(10),RWORK(LRW) XC XC234567--1---------2---------3---------4---------5---------6---------7- XC Originally written by W. Rheinboldt, July 1993 XC Last revised May 25, 1996 XC234567--1---------2---------3---------4---------5---------6---------7- XC XC DAE solver for Quasi-Linear, index-2 problems XC XC A(U,T)U' + B(U,T)W = G(U,T) XC F(U,T) = 0 XC XC subject to the partial initial condition XC XC U(T0) = u0, such that F(U0,T0) = 0 XC XC The routine determines the remaining initial conditions XC XC U'(T0) = UP0, W(T0) = W0, XC A(U0,T0)UP0 + B(U0,T0)W0 = G(U0,T0) XC XC The dimensions are: XC XC dim U = KU, dim W = KW, XC dim rge G = KD, XC dim rge F = KA = KU + KW - KD. XC XC It is assumed that XC XC rank DF(U,T) = KA and XC XC ( A(U,T) B(U,T) ) XC rank ( ) = KU + KW XC ( D_uF(U,T) 0 ) XC XC for (U,T) satisfying F(U,T) = 0. XC XC The Dormand-Prince Runge Kutta method of order 5 is used. XC XC For the algorithm see XC XC W. C. Rheinboldt, Solving Algebraically Explicit DAEs XC with the MANPAK - Manifold - Algorithms XC Inst. for Comp. Math. and Appl., Univ. of Pittsburgh, XC Tech. Reportt. TR-ICMA-96-199, July 1996 XC J. Comp. and Math. Applic. submitted XC XC Link with a driver, MANPAK and MANAUX XC XC Variables in the calling sequence: XC ---------------------------------- XC AMAT EXT Subroutine for evaluating A, see below XC BMAT EXT Subroutine for evaluating B, see below XC GF EXT Subroutine for evaluating G, see below XC FF EXT Subroutine for evaluating F, see below XC DFF EXT Subroutine for evaluating the Jacobian of F, XC see below. XC SOLOUT EXT Subroutine for intermediate output, see below XC KU I IN Dimension of U XC KW I IN Dimension of W XC KD I IN Number of differential equations XC U D Array of dimension KU XC IN The starting vector U XC OUT The final vector U XC T D IN Initial time XC D OUT Final time XC TOUT D IN Desired stopping time XC RDATA D IN Data array of dimension 10 XC RDATA(1) = H Suggested step XC Default H = 1.0D3*RTOL(1) XC RDATA(2) = HMIN Requested minimal step XC Default HMIN = 1.0D1*EPMACH XC RDATA(3) = HMAX Requested maximal step XC Default HMAX = ABS(TOUT-T) XC RDATA(4) - RDATA(10) not used XC IDATA I IN Data array of dimension 10 XC IDATA(1) = NMAX Requested maximal number of steps XC Default NMAX = 10,000 XC IDATA(2) = JPOL Interpolation indicator XC JPOL = 0 No interpolation XC JPOL = 1 Interpolate XC Default JPOL = 0 XC IDATA(3) - IDATA(10) not used XC ATOL D IN Absolute error tolerance XC RTOL D IN Relative error tolerance XC RWORK D WK Work array of dimension LRW. XC LRW I IN Dimension of RWORK at least equal to XC KU*(3*KU + 15) + KD*(2*KU+17) + KW*(KW - 11) + 26 XC IWORK I WK Work array of dimension LIW. XC LIW I IN Dimension of IWORK at least equal to XC 2*KU + KW + 2 XC IER I OUT Error indicator: XC IER = 1 successful computation interrupted by SOLOUT XC IER = 0 no error, computation was successful, XC IER = -1 error encountered and printed out. XC XC External Subroutines XC -------------------- XC The user is expected to supply subroutines for the computation of XC the coefficient functions A, G, F, and the Jacobian of F, as well XC as, one for the printout of intermediate results. Their calling XC sequences are as follows: XC XC 1. Subroutine for the matrix A XC --------------------------- XC XC SUBROUTINE AMAT( U,T,C,LDC,KC,AC,LDA,IER ) XC XC INTEGER IER,KC,LDC,LDA XC DOUBLE PRECISION U(*),T,C(LDC,*),AC(LDA,*) XC XC AMAT calculates the KD x KC product A(U,T)*C of the coefficient XC matrix A(U,T) and the given LDC x KC matrix C XC XC Variables in the calling sequence: XC ---------------------------------- XC U D IN Array of dimension KU, the current point. XC T D IN Current time XC C D IN Array of dimension KU x KC, the given matrix XC LDC I IN Leading dimension of the matrix C, LDC >= KU XC KC I IN Number of columns of the matrix C XC AC D OUT Array of dimension KD x KC, the product matrix XC LDA I IN Leading dimension of AC, LDA >= KD XC IER I OUT Error indicator: XC IER = 0 no error. XC IER = -1 error in AMAT XC XC 2. Subroutine for the matrix B XC --------------------------- XC XC SUBROUTINE BMAT( U,T,B,LDB,IER ) XC XC INTEGER LDB,IER XC DOUBLE PRECISION U(*),T,B(LDB,*) XC XC BMAT evaluates the LDB x KW matrix B(X) XC XC Variables in the calling sequence: XC ---------------------------------- XC U D IN Array of dimension KU, the current point. XC T D IN Current time XC B D OUT Array of dimension KD x KW XC containing the computed matrix B(U,T) XC LDB D OUT Leading dimension of B, LDB >= KD XC IER I OUT Error indicator: XC ier = 0 no error. XC ier = -1 error in BMAT. XC XC 3. Subroutine for evaluating G XC --------------------------- XC XC SUBROUTINE GF( U,T,V,IER ) XC XC INTEGER IER XC DOUBLE PRECISION U(*),T,V(*) XC XC Variables in the calling sequence: XC ---------------------------------- XC U D IN Array of dimension KU, the current point. XC T D IN Current time XC V D OUT Array of dimension KD XC containing the vector G(U,T). XC IER I OUT Error indicator: XC ier = 0 no error. XC ier = -1 error in GF. XC XC 4. Subroutine for evaluating F XC --------------------------- XC XC SUBROUTINE FF( U,T,V,IER ) XC XC INTEGER IER XC DOUBLE PRECISION U(*),T,V(*) XC XC Variables in the calling sequence: XC ---------------------------------- XC U D IN Array of dimension KU, the current point. XC T D IN Current time XC V D OUT Array of dimension KA = KU + KW - KD XC containing V = F(X,T) XC IER I OUT Error indicator: XC IER = 0 no error. XC IER = -1 error in FF. XC XC 5. Subroutine for evaluating the Jacobian of F XC -------------------------------------------- XC XC SUBROUTINE DFF( U,T,DF,LDF,IER ) XC XC INTEGER LDF,IER XC DOUBLE PRECISION U(*),T,DF(LDF,*) XC XC Variables in the calling sequence: XC ---------------------------------- XC U D IN Array of dimension KU, the current point. XC T D IN Current time XC DF D OUT Array of dimension KA x (KU+1) for the Jacobian XC of F at U,T, where KA = KU + KW - KD. XC Let Fk denote the k-th component of F. Then XC the k-th row of DF should contain the vector XC of the KU+1 partial derivatives XC XC ( d/dX(1) Fk , .... , d/dX(KU) Fk, d/dT Fk ) XC XC LDF I IN Leading dimension of DFV, LDF >= KA XC IER I OUT Error indicator: XC ier = 0 no error. XC ier = -1 error in DFF. XC XC 6. Subroutine for intermediate output. XC ----------------------------------- XC XC SUBROUTINE SOLOUT( TASK,JPOL,NPT,U,UP,W,T,TLAST,TNEXT ) XC XC DOUBLE PRECISION U(*),W(*),T,TLAST,TNEXT XC CHARACTER*6 TASK XC XC Variables in the calling sequence: XC ---------------------------------- XC TASK C IN Task identifier XC TASK = 'START' Print starting point and header XC if desired XC TASK = 'FINAL' Print final point XC TASK = 'PRNT' New computed point for printout XC TASK = 'INTP' Interpolated point is given XC OUT TASK = 'INTP' Request interpolation at time XC T in the interval between XC TLAST and TNEXT. XC TASK = 'PRNT' Continue with the integration XC TASK = 'STOP' Requests the integration to stop XC JPOL I IN Interpolation indicator XC JPOL = 0 No interpolation XC JPOL = 1 Interpolate XC Default JPOL = 0 XC NPT I IN Current point counter XC U D IN Array of dimension KU, the current vector U XC UP D IN Array of dimension KU, the current vector UP XC W D IN Array of dimension KW, the current vector W XC T D IN Current time XC TLAST D IN Previous time XC TNEXT D OUT Next time XC XC 7. Subroutine for error-output units XC ---------------------------------- XC XC SUBROUTINE ERROUT(KL, LOUT) XC XC INTEGER KL, LOUT(*) XC XC Function to supply KL output-unit numbers for use by XC by the message routine MSGPRT XC XC Variables in the calling sequence XC --------------------------------- XC KL I OUT Number of different output units to be used XC by MSGPRT. For KL <= 0 and KL > 5 all printout XC by MSGPRT is suppressed. XC LOUT I OUT Array of dimension KL, 1 <= KL<= 5, for the XC KL output-units to be used by MSGPRT. XC XC234567--1---------2---------3---------4---------5---------6---------7- XC XC.....Subroutines called: XC X EXTERNAL DRVQ2,MSGPRT XC XC.....Functions called XC X DOUBLE PRECISION ABS,SQRT XC XC.....Parameters XC X INTEGER NMXDEF X PARAMETER( NMXDEF = 10000 ) X DOUBLE PRECISION ZER,ONE X PARAMETER( ZER=0.0D0, ONE=1.0D0 ) X CHARACTER*(*) LNAME X PARAMETER( LNAME = 'DAEQ2' ) XC XC.....Local Variables XC X INTEGER I,LREN,LIEN X DOUBLE PRECISION ATOLA(1),RTOLA(1) X CHARACTER*6 CHAR,TASK XC XC.....Variables saved between calls XC X INTEGER NCALL,LXC,LUP,LW,LY,LYP X INTEGER LDPHI,LUBXC,LDFMAT,LAUGMT,LXN,LUBXN X INTEGER LXINT,LYPINT,LUPINT,LWINT,LUINT X INTEGER LW0,LW1,LW2,LW3,LW4,LW5,LW6 X INTEGER LWKMAT,LWRK1,LWRK2,LJAUGM,LIWRK X SAVE NCALL,LXC,LUP,LW,LY,LYP,LDPHI,LUBXC,LDFMAT,LAUGMT, X & LXN,LUBXN,LXINT,LYPINT,LUPINT,LWINT,LUINT, X & LW0,LW1,LW2,LW3,LW4,LW5,LW6,LWKMAT,LWRK1,LWRK2, X & LJAUGM,LIWRK XC XC.....Common block for machine constants XC X DOUBLE PRECISION EPMACH,SAFMIN X COMMON /MACH/EPMACH,SAFMIN XC XC.....Common block for data XC X INTEGER NMAX,JPOL X DOUBLE PRECISION H,HMIN,HMAX,POSNEG X COMMON /DATQ2/H,HMIN,HMAX,POSNEG,NMAX,JPOL XC XC.....Common block for the statistics variables XC X INTEGER NSTEP,NACCPT,NREJCT,NDER,NMA,NMB,NGF,NFF,NDFF X COMMON /STAQ2/NSTEP,NACCPT,NREJCT,NDER,NMA,NMB,NGF,NFF,NDFF XC XC.....Common block for dimensions XC X INTEGER NU,NW,NDIF,NEQ,NALG,NVAR,MDIM,MDIMM1,MDIMP1 X COMMON /DIMQ2/NU,NW,NDIF,NEQ,NALG,NVAR,MDIM,MDIMM1,MDIMP1 XC X DATA NCALL/0/ XC XC.......................Executable statements......................... XC XC.....At first call check dimensions, set pointers into work XC.....arrays and check for insufficient storage. XC.....(These are data that depend only on the problem XC.....but not on a specific trajectory) XC X IF(NCALL .EQ. 0) THEN X NCALL = 1 X NU = KU X NW = KW X NDIF = KD + 1 X NEQ = KU + KW + 1 X NALG = NEQ - NDIF X NVAR = KU + 1 X MDIM = NVAR - NALG X MDIMM1 = MDIM - 1 X MDIMP1 = MDIM + 1 XC XC........Set machine constant XC X CALL DMACH( EPMACH,SAFMIN ) XC XC........Check data and set defaults XC X IER = -1 X IF( NVAR .LT. 2 ) THEN X CALL MSGPRT(LNAME,'The ambient space must be at '// X & 'least two-dimensional') X RETURN X ENDIF X IF( MDIM .LT. 1 )THEN X CALL MSGPRT(LNAME,'The manifold must be at least '// X & 'one-dimensional') X RETURN X ENDIF XC XC Set pointers into RWORK XC X LXC = 1 X LUP = LXC + NVAR X LW = LUP + NU XC X LY = LW + NW X LYP = LY + MDIM XC X LDPHI = LYP + MDIM X LUBXC = LDPHI + NVAR*MDIM X LDFMAT = LUBXC + NVAR*MDIM X LAUGMT = LDFMAT + NALG*NVAR XC X LXN = LAUGMT + NVAR*NVAR X LUBXN = LXN + NVAR XC X LXINT = LUBXN + NVAR*MDIM X LYPINT = LXINT + NVAR X LUPINT = LYPINT + MDIM X LWINT = LUPINT + NU XC X LUINT = LWINT + NW X LW0 = LUINT + 5*MDIM X LW1 = LW0 + MDIM X LW2 = LW1 + MDIM X LW3 = LW2 + MDIM X LW4 = LW3 + MDIM X LW5 = LW4 + MDIM X LW6 = LW5 + MDIM XC X LWKMAT = LW6 + MDIM X LWRK1 = LWKMAT + NEQ*NEQ X LWRK2 = LWRK1 + NEQ X LREN = LWRK2 + NEQ - 1 XC XC........Check for sufficient RWORK XC X IF(LREN .GT. LRW) THEN X WRITE (CHAR,10) LREN X 10 FORMAT(I5) X CALL MSGPRT(LNAME, X & 'RWORK must have at least dimension '//CHAR) X RETURN X ENDIF XC XC........Set pointers into IWORK XC X LJAUGM = 1 X LIWRK = LJAUGM + NVAR X LIEN = LIWRK + NEQ - 1 XC XC........Check for sufficient IWORK XC X IF(LIEN .GT. LIW) THEN X WRITE (CHAR,10) LIEN X CALL MSGPRT(LNAME, X & 'IWORK must have at least dimension '//CHAR) X RETURN X ENDIF X ENDIF XC XC.....Set the data that depend on the specific trajectory XC X POSNEG = ONE X IF (TOUT .LT. T) POSNEG = -POSNEG X HMIN = RDATA(2) X IF (HMIN .LE. ZER) HMIN = SQRT(EPMACH) X HMAX = RDATA(3) X IF (HMAX .EQ. ZER) HMAX = ABS(TOUT - T) X IF (HMAX .LT. ZER) HMAX = -HMAX X H = RDATA(1) X IF( POSNEG*H .LT. ZER ) H = -H X IF (H .EQ. ZER) H = POSNEG*SQRT(DBLE(MDIM)) XC X ATOLA(1) = ATOL X RTOLA(1) = RTOL XC X NMAX = IDATA(1) X IF (NMAX .LE. 0 ) NMAX = NMXDEF X JPOL = IDATA(2) X IF (JPOL .NE. 1) JPOL = 0 XC XC.....Initialize the counters XC X NSTEP = 0 X NACCPT = 0 X NREJCT = 0 X NDER = 0 X NMA = 0 X NGF = 0 X NFF = 0 X NDFF = 0 XC XC.....Copy the specified vector (U, T) into XC XC X DO 20 I = 1, NU X RWORK(I) = U(I) X 20 CONTINUE X RWORK(NVAR) = T XC XC.....Call the Runge-Kutta driver XC X CALL DRVQ2( AMAT,BMAT,GF,FF,DFF,SOLOUT,TOUT,ATOLA,RTOLA, X & RWORK(LXC),RWORK(LUP),RWORK(LW),RWORK(LY), X & RWORK(LYP),RWORK(LDPHI),NVAR,RWORK(LUBXC),NVAR, X & RWORK(LDFMAT),NALG,RWORK(LAUGMT),NVAR,IWORK(LJAUGM), X & RWORK(LXN),RWORK(LUBXN),RWORK(LXINT),RWORK(LYPINT), X & RWORK(LUPINT),RWORK(LWINT),RWORK(LUINT),RWORK(LW0), X & RWORK(LW1),RWORK(LW2),RWORK(LW3),RWORK(LW4), X & RWORK(LW5),RWORK(LW6),RWORK(LWKMAT),NEQ, X & RWORK(LWRK1),RWORK(LWRK2),IWORK(LIWRK),IER ) XC XC.....Test for error condition and then return XC X IF( IER .NE. 0 )CALL MSGPRT( LNAME, X & 'Error return from the RK-step driver') XC XC.....Restore (U, T) XC X DO 30 I = 1, NU X U(I) = RWORK(I) X 30 CONTINUE X T = RWORK(NVAR) XC XC.....Print final point XC X TASK = 'FINAL' X CALL SOLOUT( TASK,JPOL,NACCPT,U,RWORK(LUP),RWORK(LW),T,T,T ) XC X RETURN XC XC.....End of DAEQ2 XC X END XC XC234567==1=========2=========3=========4=========5=========6=========7= XC X SUBROUTINE DRVQ2( AMAT,BMAT,GF,FF,DFF,SOLOUT,TOUT,ATOLA,RTOLA, X & XC,UP,W,Y,YP,DPHI,LDP,UBXC,LDU,DFMAT,LDF, X & AUGMT,LDA,JAUGM,XN,UBXN,XINT,YPINT, X & UPINT,WINT,UINT,W0,W1,W2,W3,W4,W5,W6, X & WRKMAT,LDW,WRK1,WRK2,IWRK,IER ) XC X EXTERNAL AMAT,BMAT,GF,FF,DFF,SOLOUT XC X INTEGER LDA,LDF,LDP,LDU,LDW,JAUGM(*),IWRK(*),IER XC X DOUBLE PRECISION TOUT,ATOLA(*),RTOLA(*) X DOUBLE PRECISION XC(*),UP(*),W(*),Y(*),YP(*),DPHI(LDP,*) X DOUBLE PRECISION UBXC(LDU,*),DFMAT(LDF,*),AUGMT(LDA,*) X DOUBLE PRECISION XN(*),UBXN(LDU,*) X DOUBLE PRECISION XINT(*),YPINT(*),UPINT(*),WINT(*),UINT(5,*) X DOUBLE PRECISION W0(*),W1(*),W2(*),W3(*),W4(*),W5(*),W6(*) X DOUBLE PRECISION WRKMAT(LDW,*),WRK1(*),WRK2(*) XC XC234567--1---------2---------3---------4---------5---------6---------7- XC XC This is the driver for the RK step routine DOPSTN. The XC integration continues until either NMAX steps have been XC taken or until T = TOUT has been reached. XC XC A new local system is constructed at each step. XC XC Variables in the calling sequence: XC ---------------------------------- XC AMAT EXT Subroutine for evaluating A XC BMAT EXT Subroutine for evaluating B XC GF EXT Subroutine for evaluating G XC FF EXT Subroutine for evaluating F XC DFF EXT Subroutine for evaluating the Jacobian of F XC SOLOUT EXT Subroutine for intermediate output XC TOUT D IN Desired stopping time XC ATOLA D IN Array of dimension 1, the absolute error tolerance XC RTOLA D IN Array of dimension 1, the relative error tolerance XC XC D WK Array of dimension NVAR, the current XC point, XC = (U, UP, W, T) XC UP D WK Array of dimension KU, the direction vector UP XC W D WK Array of dimension KW, the vector W XC Y D WK Array of dimension MDIM for a point XC in local coordinates on the manifold XC YP D WK Array of dimension MDIM for the XC derivative in local coordinates XC DPHI D WK Array of dimension LDP x MDIM, the derivative XC of the local parametrization XC LDP I IN Leading dimension of DPHI, LDP >= NVAR XC UBXC D WK Array of dimension LDU x MDIM for the XC basis matrix at XC XC LDU I IN Leading dimension of UBXC, LDU >= NVAR XC DFMAT D WK Array of dimension LDF x NVAR for the Jacobian XC DF(XC) and its decomposition XC LDF I IN Leading dimension of DFMAT, LDF >= NALG XC AUGMT D WK Array of dimension LDA x NVAR for the XC augmented matrix at XC and its decomposition. XC LDA I IN Leading dimension of AUGMT, LDA >= NVAR XC JAUGM I WK Array of dimension of dimension NVAR for the XC pivot array used in the decomposition of AUGMT XC XN D WK Array of dimension NVAR, intermediate point XC UBXN D WK Array of dimension LDU x MDIM for the XC basis matrix at XN XC XINT D WK Array of dimension NVAR, interpolated point X XC YPINT D WK Array of dimension MDIM, interpolated local direction XC UPINT D WK Array of dimension NU, interpolated global direction XC WINT D WK Array of dimension NW, interpolated vector W XC UINT D WK Array of dimension 5*MDIM for use in interpolation XC W0-W6 D WK Seven work arrays of dimension MDIM XC WRKMAT D WK Work array of dimension LDW x NDIF XC LDW I IN Leading dimension of WRKMAT, LDW >= NDIF XC WRK1 D WK Work array of dimension NVAR XC WRK2 D WK Work array of dimension NVAR XC IWRK I Wk Work array of dimension NVAR XC IER I OUT Error indicator XC IER = 1 computation successful XC but interrupted by SOLOUT XC IER = 0 no error, computation was successful XC IER = -1 other error encountered and printed out XC XC234567--1---------2---------3---------4---------5---------6---------7- XC XC.....Subroutines called: XC X EXTERNAL DGPHI,DOPSTN,GNBAS,INTQ2,MSGPRT,ORIENT,DYQ2 XC XC.....Parameters XC X INTEGER ITOL X DOUBLE PRECISION TFACT,ZER,HALF X PARAMETER( ITOL=0, TFACT=1.01D0, ZER=0.0D0, HALF=0.5D0 ) X CHARACTER*(*) LNAME X PARAMETER( LNAME = 'DRVQ2' ) XC XC.....Local Variables XC X INTEGER I,J X DOUBLE PRECISION T,TLOC,TLOCL,TNEXT,TPR,TLAST X CHARACTER*6 TASK, MODE X CHARACTER*5 CHAR1, CHAR2 X LOGICAL LAST XC XC.....Common block for machine constants XC X DOUBLE PRECISION EPMACH,SAFMIN X COMMON /MACH/EPMACH,SAFMIN XC XC.....Common block for data XC X INTEGER NMAX,JPOL X DOUBLE PRECISION H,HMIN,HMAX,POSNEG X COMMON /DATQ2/H,HMIN,HMAX,POSNEG,NMAX,JPOL XC XC.....Common block for the statistics variables XC X INTEGER NSTEP,NACCPT,NREJCT,NDER,NMA,NMB,NGF,NFF,NDFF X COMMON /STAQ2/NSTEP,NACCPT,NREJCT,NDER,NMA,NMB,NGF,NFF,NDFF XC XC.....Common block for dimensions XC X INTEGER NU,NW,NDIF,NEQ,NALG,NVAR,MDIM,MDIMM1,MDIMP1 X COMMON /DIMQ2/NU,NW,NDIF,NEQ,NALG,NVAR,MDIM,MDIMM1,MDIMP1 XC XC.......................Executable statements......................... XC XC.....Get the Jacobian at the starting point XC XC X T = XC(NVAR) X CALL DFF( XC,T,DFMAT,LDF,IER ) X NDFF = NDFF + 1 X IF(IER .NE. 0)THEN X CALL MSGPRT( LNAME,'Error in Jacobian evaluation' ) X IER = -1 X RETURN X ENDIF XC XC.....Place a copy of the Jacobian into AUGMT XC X DO 20 J = 1,NVAR X DO 10 I = 1,NALG X AUGMT(I,J) = DFMAT(I,J) X 10 CONTINUE X 20 CONTINUE XC XC.....Establish a local coordinate basis in UBXC XC X CALL GNBAS( NVAR,MDIM,UBXC,LDU,DFMAT,LDF, X & WRK1,WRK2,IWRK,SAFMIN,IER ) X IF( IER .NE. 0 ) THEN X IER = -1 X CALL MSGPRT( LNAME,'The basis construction failed '// X & 'at the starting point' ) X RETURN X ENDIF XC XC.....Evaluate DPHI XC X TASK = 'FACTOR' X CALL DGPHI( TASK,NVAR,MDIM,DPHI,LDP,AUGMT,LDA, X & UBXC,LDU,JAUGM,IER ) X IF( IER .NE. 0 ) THEN X CALL MSGPRT( LNAME,'Error in computing the derivative '// X & 'of the local parametrization '// X & 'at the starting point' ) X IER = -1 X RETURN X ENDIF XC XC.....Setup and solve the reduced, linear system for determining XC.....DPHI together with the (local and global) direction vectors XC.....YP, UP and the vector W XC X MODE = 'INIT' X CALL DYQ2( MODE,AMAT,BMAT,GF,FF,DFF,Y,XC,YP,UP,W, X & DPHI,LDP,XC,UBXC,LDU,AUGMT,LDA,JAUGM, X & DFMAT,LDF,WRKMAT,LDW,WRK1,IWRK,IER ) X NDER = NDER + 1 X IF( IER .NE. 0 )THEN X CALL MSGPRT( LNAME,'Error in the evaluation '// X & 'of the directions at the starting point' ) X IER = -1 X RETURN X ENDIF XC XC.....Write out the starting point XC X TASK = 'START' X CALL SOLOUT( TASK,JPOL,NACCPT,XC,UP,W,T,T,T ) X IF( TASK .EQ. 'STOP')THEN X CALL MSGPRT ( LNAME,'Interruption by SOLOUT, '// X & 'computation terminated' ) X IER = 0 X RETURN X ENDIF XC XC.....Loop point for accepted steps XC X 100 CONTINUE XC XC.....Check if we are close to the terminal value of T XC X LAST = .FALSE. X IF( (T + TFACT*H - TOUT)*POSNEG .GT. ZER )THEN X H = TOUT - T X LAST = .TRUE. X TLOCL = H X ENDIF XC XC.....Save the current time XC X TLAST = T XC XC.....We always start with the local coordinate Y = 0 XC.....which corresponds to XC XC X DO 110 I = 1, MDIM X Y(I) = ZER X 110 CONTINUE X TLOC = ZER XC XC.....Call the derivative routine XC X TASK = 'STEP' X 150 CONTINUE XC X IF( MODE .NE. 'INIT' )THEN XC XC........Setup and solve the reduced linear system XC X CALL DYQ2( MODE,AMAT,BMAT,GF,FF,DFF,Y,XN,YP,UP,W, X & DPHI,LDP,XC,UBXC,LDU,AUGMT,LDA,JAUGM, X & DFMAT,LDF,WRKMAT,LDW,WRK1,IWRK,IER ) X NDER = NDER + 1 X IF( IER .NE. 0 )THEN X IF( IER .GT. 0 .AND. TASK .EQ. 'EVAL' )THEN X TASK = 'REDUCE' X H = HALF*H X ELSE X CALL MSGPRT( LNAME, X & 'Error in the evaluation of the new directions' ) X IER = -1 X RETURN X ENDIF X ENDIF X ENDIF XC XC.....Call the step routine XC X CALL DOPSTN( TASK,MDIM,TLOC,Y,YP,H,HMIN,HMAX,NMAX, X & ATOLA,RTOLA,ITOL,W0,W1,W2,W3,W4,W5,W6, X & JPOL,UINT,NSTEP,NACCPT,NREJCT ) X IF( TASK .EQ. 'EVAL' ) THEN X MODE = 'NEXT' X GOTO 150 X ELSEIF( TASK .EQ. 'DONE' )THEN X GOTO 200 X ELSEIF( TASK .EQ. 'STPCNT' )THEN X WRITE( CHAR1,190 )NSTEP X WRITE( CHAR2,190 )NMAX X 190 FORMAT(I5) X CALL MSGPRT( LNAME,'Step count '//CHAR1//' exceeds '// X & 'given maximum NMAX= '//CHAR2 ) X IER = -2 X ELSEIF( TASK .EQ. 'MINSTP' )THEN X CALL MSGPRT( LNAME,' Step fell below HMIN' ) X IER = -3 X ELSE X CALL MSGPRT( LNAME,'Error return from the RK routine' ) X IER = -1 X ENDIF X RETURN XC X 200 CONTINUE X IF( LAST .AND. (TLOC .NE. TLOCL) )LAST = .FALSE. XC XC.....Write out the solution XC X TASK = 'PRNT' X TNEXT = XN(NVAR) X TPR = TNEXT X CALL SOLOUT( TASK,JPOL,NACCPT,XN,UP,W,TPR,TLAST,TNEXT ) XC X 220 CONTINUE X IF (TASK .EQ. 'PRNT') THEN X GOTO 300 X ELSEIF (TASK .EQ. 'STOP') THEN X CALL MSGPRT (LNAME,'Interruption by SOLOUT, '// X & 'computation terminated') X IER = 0 X RETURN X ELSEIF (TASK .EQ. 'INTP') THEN XC XC........Interpolation is requested XC X CALL INTQ2( AMAT,BMAT,GF,FF,DFF,TPR,TLAST,TNEXT, X & XINT,YPINT,UPINT,WINT,UINT, X & XC,UBXC,LDU,AUGMT,LDA,JAUGM,DPHI,LDP, X & WRKMAT,LDW,WRK1,WRK2,IWRK,IER ) X NDER = NDER + 1 X IF (IER .NE. 0) THEN X CALL MSGPRT (LNAME,'Error in interpolation -- proceed') X GOTO 300 X ELSE XC XC...........Write out the interpolated solution XC X CALL SOLOUT( TASK,JPOL,NACCPT,XINT,UPINT,WINT, X & TPR,TLAST,TNEXT ) X GOTO 220 X ENDIF X ELSE X CALL MSGPRT (LNAME, X & 'SOLOUT returns unknown value of TASK -- proceed') X ENDIF XC XC.....Check for another step XC X 300 CONTINUE XC XC.....Copy XN into XC XC X DO 310 J = 1,NVAR X XC(J) = XN(J) X 310 CONTINUE X T = XC(NVAR) XC XC.....If this was the last step return XC X IF( LAST ) THEN X IER = 0 X RETURN X ENDIF XC XC.....Another step is desired. Copy the Jacobian into AUGMT XC.....and establish a new local coordinate system XC X DO 330 J = 1,NVAR X DO 320 I = 1,NALG X AUGMT(I,J) = DFMAT(I,J) X 320 CONTINUE X 330 CONTINUE XC XC.....Compute the basis matrix UBXC XC X CALL GNBAS( NVAR,MDIM,UBXN,LDU,DFMAT,LDF, X & WRK1,WRK2,IWRK,SAFMIN,IER ) X IF(IER .NE. 0) THEN X CALL MSGPRT(LNAME,'The basis construction at the '// X & 'new point XN failed') X IER = -1 X RETURN X ENDIF XC XC.....With the old basis as reference adjust the XC.....orientation of the new basis XC X CALL ORIENT( NU,MDIMM1,UBXC,LDU,UBXN,LDU, X & WRKMAT,LDW,IWRK,IER ) X IF(IER .NE. 0) THEN X CALL MSGPRT(LNAME,'Error in reorienting the new basis') X IER = -1 X RETURN X ENDIF XC XC.....Move basis from UBXN to UBXC XC X DO 350 J = 1,MDIM X DO 340 I = 1,NVAR X UBXC(I,J) = UBXN(I,J) X 340 CONTINUE X 350 CONTINUE XC XC.....Evaluate new DPHI XC X TASK = 'FACTOR' X CALL DGPHI( TASK,NVAR,MDIM,DPHI,LDP,AUGMT,LDA, X & UBXC,LDU,JAUGM,IER ) X IF( IER .NE. 0 ) THEN X CALL MSGPRT( LNAME,'Error in computing the derivative '// X & 'of the local parametrization' ) X IER = -1 X RETURN X ENDIF XC XC.....Compute the local and global directions and the algebraic vector XC X MODE = 'INIT' X CALL DYQ2( MODE,AMAT,BMAT,GF,FF,DFF,Y,XC,YP,UP,W, X & DPHI,LDP,XC,UBXC,LDU,AUGMT,LDA,JAUGM, X & DFMAT,LDF,WRKMAT,LDW,WRK1,IWRK,IER ) X NDER = NDER + 1 X IF( IER .NE. 0 )THEN X CALL MSGPRT( LNAME, X & 'Error in computing the local and global directions' ) X IER = -1 X RETURN X ENDIF XC XC.....Go back to the loop point for accepted steps XC X GOTO 100 XC XC.....End of DRVQ2 XC X END XC XC234567==1=========2=========3=========4=========5=========6=========7= XC X SUBROUTINE DYQ2( MODE,AMAT,BMAT,GF,FF,DFF,Y,X,YP,UP,W, X & DPHI,LDP,XC,UBXC,LDU,AUGMT,LDA,JAUGM, X & DFMAT,LDF,WRKMAT,LDW,WRK,IWRK,IER ) XC X CHARACTER*6 MODE X EXTERNAL AMAT,BMAT,GF,FF,DFF XC X INTEGER IER,LDA,LDF,LDP,LDU,LDW,IWRK(*),JAUGM(*) XC X DOUBLE PRECISION Y(*),X(*),YP(*),UP(*),W(*) X DOUBLE PRECISION DPHI(LDP,*),XC(*),UBXC(LDU,*),AUGMT(LDA,*) X DOUBLE PRECISION DFMAT(LDF,*),WRKMAT(LDW,*),WRK(*) XC XC234567--1---------2---------3---------4---------5---------6---------7- XC XC Subroutine for determining a global point X corresponding to a XC specified local point Y and for computing at this point the XC local and global direction vectors YP and UP as well as the XC algebraic vector W as solution of the square linear system XC of order ND = MDIM + NW XC XC ( (A(phi(Y)) 0)*dphi(Y) B(phi(Y)) ) ( YP ) = ( G(phi(Y)) ) XC ( ( 0 1) 0 ) ( W ) ( 1 ) XC XC where X = phi(Y) is the local coordinate transformation and XC UP = dphi(Y) XC XC Variables in the calling sequence: XC ---------------------------------- XC MODE C IN Point indicator XC MODE = 'INIT', the global point is available in X XC MODE = 'NEXT', compute the next point and store XC also a copy of the Jacobian XC MODE = 'INTPT', compute interpolation point XC Otherwise, compute the next point and don't XC retain a copy of the Jacobian XC AMAT EXT Subroutine for evaluating A XC BMAT EXT Subroutine for evaluating B XC GF EXT Subroutine for evaluating G XC FF EXT Subroutine for evaluating F, see below XC DFF EXT Subroutine for evaluating the Jacobian of F, XC see below. XC Y D IN Array of dimension MDIM, the specified local point XC X D Array of dimension NVAR XC IN For MODE = 'INIT', the specified global point XC OUT The computed global point corresponding to Y XC YP D OUT Array of dimension MDIM, the local direction XC UP D OUT Array of dimension NU, the global direction XC W D OUT Array of dimension NW, the vector W XC DPHI D IN Array of dimension LDP x MDIM, the derivative XC of the local parametrization XC LDP I IN Leading dimension of DPHI, LDP >= NVAR XC XC D IN Array of dimension NVAR, the center point of XC the current local coordinate system XC Not referenced when MODE = 'INIT' XC UBXC D IN Array of dimension LDU x MDIM, the basis XC matrix at XC XC Not referenced when MODE = 'INIT' XC LDU I IN Leading dimension of UBXC, LDU >= NVAR XC Not referenced when MODE = 'INIT' XC AUGMT D OUT Array of dimension LDA x NVAR for the XC augmented matrix at XC and its decomposition. XC Not referenced when MODE = 'INIT' XC LDA I IN Leading dimension of AUGMT, LDA >= NVAR XC Not referenced when MODE = 'INIT' XC JAUGM I OUT Array of dimension of dimension NVAR for the XC pivot array used in the decomposition of AUGMT XC Not referenced when MODE = 'INIT' XC DFMAT D OUT Array of dimension LDF x NVAR, for MODE = 'NEXT' XC retains a copy of the Jacobian at X XC LDF I IN Leading dimension of DFMAT, LDF >= NALG XC WRKMAT D WK Work array of dimension LDW x NDIF XC LDW I IN Leading dimension of WRKMAT, LDW >= NDIF XC WRK D WK Work array of dimension NDIF XC IWRK I WK Work array of dimension NDIF XC IER I OUT error indicator XC IER = 0 no error XC IER = 1 correctable error -- steplength too XC large -- no printout from MSGPRT XC IER = -1 fatal error, printout from MSGPRT XC XC234567--1---------2---------3---------4---------5---------6---------7- XC XC.....Subroutines called: XC X EXTERNAL DGPHI,GPHI,LUF,LUS1 XC XC.....Parameters XC X DOUBLE PRECISION ONE, ZER X PARAMETER( ONE=1.0D0, ZER=0.0D0 ) X CHARACTER*(*) LNAME X PARAMETER( LNAME = 'DYQ2') XC XC.....Local Variables XC X INTEGER I,J,ISTEP X DOUBLE PRECISION SUM,T X CHARACTER*6 TASK XC XC.....Common block for machine constants XC X DOUBLE PRECISION EPMACH,SAFMIN X COMMON /MACH/EPMACH,SAFMIN XC XC.....Common block for the statistics variables XC X INTEGER NSTEP,NACCPT,NREJCT,NDER,NMA,NMB,NGF,NFF,NDFF X COMMON /STAQ2/NSTEP,NACCPT,NREJCT,NDER,NMA,NMB,NGF,NFF,NDFF XC XC.....Common block for dimensions XC X INTEGER NU,NW,NDIF,NEQ,NALG,NVAR,MDIM,MDIMM1,MDIMP1 X COMMON /DIMQ2/NU,NW,NDIF,NEQ,NALG,NVAR,MDIM,MDIMM1,MDIMP1 XC XC.......................Executable statements......................... XC XC.....If we are at a new point, go directly to the solver XC X IF( MODE .NE. 'INIT' )THEN XC XC........Determine the global point with the local coordinate Y XC X TASK = 'START' X 10 CONTINUE X CALL GPHI( TASK,NVAR,MDIM,Y,X,WRK,XC,UBXC,LDU, X & AUGMT,LDA,JAUGM,EPMACH,ISTEP ) X IF (TASK .EQ. 'EVAL') THEN X CALL FF( X,X(NVAR),WRK,IER ) X NFF = NFF + 1 X IF( IER .NE. 0 )THEN X CALL MSGPRT(LNAME,'Error in evaluating the function F') X IER = -1 X RETURN X ENDIF X GOTO 10 X ELSEIF (TASK .EQ. 'DONE') THEN X GOTO 20 X ELSEIF (TASK .EQ. 'DIVERG' .OR. TASK .EQ. 'STPCNT') THEN X IER = 1 X ELSE X CALL MSGPRT( LNAME, X & 'Error in computing the local parametrization' ) X IER = -1 X ENDIF X RETURN XC XC........Get Jacobian of F at the new point XC X 20 CONTINUE X CALL DFF( X,X(NVAR),WRKMAT,LDW,IER ) X NDFF = NDFF + 1 X IF( IER .NE. 0 ) THEN X CALL MSGPRT(LNAME, X & 'Error in evaluating the Jacobian') X IER = -1 X RETURN X ENDIF XC XC........For MODE = 'NEXT', retain a copy of the Jacobian in DFMAT XC X IF( MODE .EQ. 'NEXT' )THEN X DO 40 J = 1,NVAR X DO 30 I = 1,NALG X DFMAT(I,J) = WRKMAT(I,J) X 30 CONTINUE X 40 CONTINUE X ENDIF XC XC........Evaluate DPHI XC X TASK = 'FACTOR' X CALL DGPHI( TASK,NVAR,MDIM,DPHI,LDP,WRKMAT,LDW, X & UBXC,LDU,IWRK,IER ) X IF( IER .NE. 0 ) THEN X CALL MSGPRT( LNAME,'Error in computing the derivative '// X & 'of the local parametrization' ) X IER = -1 X RETURN X ENDIF X ENDIF XC XC.....Set up and solve the reduced linear system XC.....Multiply A by the first MDIMM1 columns of DPHI and XC.....store in the first MDIMM1 columns of WRKMAT XC X T = X(NVAR) X CALL AMAT( X,T,DPHI,LDP,MDIM,WRKMAT,LDW,IER ) X NMA = NMA +1 X IF( IER .NE. 0 )THEN X CALL MSGPRT( LNAME, X & 'Error in evaluating the coefficient matrix A ') X IER = -1 X RETURN X ENDIF XC XC.....Evaluate B and store in the last NW columns of WRKMAT XC X CALL BMAT( X,T,WRKMAT(1,MDIMP1),LDW,IER ) X NMB = NMB + 1 X IF(IER .NE. 0)THEN X CALL MSGPRT( LNAME, X & 'Error in evaluating the coefficient matrix B ') X IER = -1 X RETURN X ENDIF XC XC.....Set the last row of WRKMAT XC X DO 110 J = 1,NDIF X WRKMAT(NDIF,J) = ZER X 110 CONTINUE X WRKMAT(NDIF,MDIM) = ONE XC XC.....Evaluate the right side in WRK XC X CALL GF( X,T,WRK,IER ) X NGF = NGF +1 X IF(IER .NE. 0)THEN X CALL MSGPRT( LNAME,'Error in evaluating the right side G' ) X IER = -1 X RETURN X ENDIF X WRK(NDIF) = ONE XC XC.....Solve WRKMAT * S = WRK for S and store in WRK XC X CALL LUF( NDIF,WRKMAT,LDW,IWRK,IER ) X IF (IER .NE. 0) THEN X CALL MSGPRT(LNAME,'The reduced matrix is singular' ) X IER = -1 X RETURN X ENDIF X CALL LUS1( NDIF,WRKMAT,LDW,IWRK,WRK,IER ) XC XC.....Setup the output vectors YP, W, and UP XC X DO 120 J = 1, MDIM X YP(J) = WRK(J) X 120 CONTINUE X DO 130 J = 1, NW X W(J) = WRK(MDIM+J) X 130 CONTINUE X DO 150 I = 1, NU X SUM = ZER X DO 140 J = 1, MDIM X SUM = SUM + DPHI(I,J)*YP(J) X 140 CONTINUE X UP(I) = SUM X 150 CONTINUE XC XC.....Successful return XC X IER = 0 X RETURN XC XC.....End of DYQ2 XC X END XC XC234567==1=========2=========3=========4=========5=========6=========7= XC X SUBROUTINE INTQ2( AMAT,BMAT,GF,FF,DFF,TPR,TLAST,TNEXT, X & XINT,YPINT,UPINT,WINT,UINT, X & XC,UBXC,LDU,AUGMT,LDA,JAUGM,DPHI,LDP, X & WRKMAT,LDW,WRK1,WRK2,IWRK,IER ) XC X EXTERNAL AMAT,BMAT,GF,FF,DFF XC X INTEGER IER,LDA,LDP,LDU,LDW,JAUGM(*),IWRK(*) X DOUBLE PRECISION TPR,TLAST,TNEXT X DOUBLE PRECISION XINT(*),YPINT(*),UPINT(*),WINT(*),UINT(5,*) X DOUBLE PRECISION XC(*),UBXC(LDU,*),AUGMT(LDA,*),DPHI(LDP,*) X DOUBLE PRECISION WRKMAT(LDW,*),WRK1(*),WRK2(*) XC XC234567--1---------2---------3---------4---------5---------6---------7- XC XC Routine for interpolating between computed points when XC intermediate output is desired. XC XC Variables in the calling sequence: XC ---------------------------------- XC AMAT EXT Subroutine for evaluating A, see below XC BMAT EXT Subroutine for evaluating B, see below XC GF EXT Subroutine for evaluating G, see below XC FF EXT Subroutine for evaluating F, see below XC DFF EXT Subroutine for evaluating the Jacobian of F, XC see below. XC TPR D IN The time where output is desired. TPR must XC be between TLAST and TNEXT XC TLAST D IN The last time XC TNEXT D IN The next time XC XINT D OUT Array of dimension NVAR, the interpolated XC point (U,TPR) XC YPINT D OUT Array of dimension MDIM, the direction in XC local coordinates at the interpolated point XC UPINT D OUT Array of dimension NU, the direction in XC global coordinates at the interpolated point XC WINT D OUT The vector of algebraic variables at the XC interpolated point XC UINT D IN Interpolation array of dimension 5 * MDIM computed XC by DOPSTN for the step from TLAST to TNEXT XC XC D IN Array of dimension NVAR, the center point of XC the current local coordinate system XC UBXC D IN Array of dimension LDU x MDIM, the basis XC matrix at XC XC LDU I IN Leading dimension of UBXC, LDU >= NVAR XC AUGMT D WK Array of dimension LDA x NVAR for the XC augmented matrix at XC and its decomposition. XC LDA I IN Leading dimension of AUGMT, LDA >= NVAR XC JAUGM I WK Array of dimension of dimension NVAR for the XC pivot array used in the decomposition of AUGMT XC DPHI D OUT Array of dimension NVAR x MDIM, the current XC derivative of the local parametrization XC LDP I IN leading dimension of DPHI, LDP >= NVAR XC WRKMAT D WK Work array of dimension LDW x NDIF XC LDW I IN Leading dimension of WRKMAT, LDW >= NDIF XC WRK1 I WK Work array of dimension NDIF XC WRK2 I WK Work array of dimension NDIF XC IWRK I WK Work array of dimension NDIF XC IER I OUT Error indicator XC IER = 0 No error XC IER = -1 TPR was not between TLAST and TNEXT XC IER = -2 Computation of the directions failed XC at the interpolated point XC XC234567--1---------2---------3---------4---------5---------6---------7- XC XC.....Subroutines called: XC X EXTERNAL DYQ2 XC XC.....Parameters XC X CHARACTER*(*) LNAME X PARAMETER( LNAME = 'INTQ2' ) X DOUBLE PRECISION ONE, ZER X PARAMETER( ONE=1.0D0, ZER=0.0D0 ) XC XC.....Local variables XC X INTEGER I X DOUBLE PRECISION DUM(1,1), HT, S X CHARACTER*6 MODE XC XC.....Common block for dimensions XC X INTEGER NU,NW,NDIF,NEQ,NALG,NVAR,MDIM,MDIMM1,MDIMP1 X COMMON /DIMQ2/NU,NW,NDIF,NEQ,NALG,NVAR,MDIM,MDIMM1,MDIMP1 XC XC.......................Executable statements......................... XC XC.....Get effective step and check for TINT between TLAST and TNEXT XC X HT = TNEXT - TLAST X S = (TPR - TLAST)/HT X IF( (S .LT. ZER) .OR. (S .GT. ONE) ) THEN X CALL MSGPRT (LNAME,'Interpolation requested outside '// X & 'the last integration interval') X IER = -1 X RETURN X ENDIF XC XC.....Evaluate the interpolation polynomial at S to get Y XC X DO 10 I = 1,MDIM X WRK1(I) = UINT(1,I) + HT*S*(UINT(2,I) + S*(UINT(3,I) X & + S*(UINT(4,I) + S*UINT(5,I)))) X 10 CONTINUE X WRK1(MDIM) = HT*S XC XC.....Get desired point on the manifold corresponding to WRK1 XC X MODE = 'INTPT' X CALL DYQ2( MODE,AMAT,BMAT,GF,FF,DFF,WRK1,XINT,YPINT, X & UPINT,WINT,DPHI,LDP,XC,UBXC,LDU,AUGMT,LDA, X & JAUGM,DUM,1,WRKMAT,LDW,WRK2,IWRK,IER ) X IF( IER .NE. 0 )THEN X CALL MSGPRT( LNAME, X & 'Error in evaluating the directions during interpolation' ) X IER = -2 X ENDIF XC X RETURN XC XC.....End of INTQ2 XC X END XC XC234567==1=========2=========3=========4=========5=========6=========7= XC X SUBROUTINE WSTQ2( LOUT ) XC X INTEGER LOUT XC XC234567--1---------2---------3---------4---------5---------6---------7- XC XC Routine for printing some run statistics for DAEQ2 XC XC Variable in the calling sequence: XC ---------------------------------- XC LOUT I IN Output unit number XC XC234567--1---------2---------3---------4---------5---------6---------7- XC XC.....Common block for the statistics variables XC X INTEGER NSTEP,NACCPT,NREJCT,NDER,NMA,NMB,NGF,NFF,NDFF X COMMON /STAQ2/NSTEP,NACCPT,NREJCT,NDER,NMA,NMB,NGF,NFF,NDFF XC XC.......................Executable statements......................... XC X WRITE(LOUT,10)NSTEP,NACCPT,NREJCT X 10 FORMAT(1X/' Number of steps: '/ X & ' Total= ',I6,' Accepted= ',I6,' Rejected= ',I6) XC X WRITE(LOUT,20) NDER X 20 FORMAT(' Local ODE evaluations = ',I6) XC X WRITE(LOUT,30) NMA,NMB,NGF,NFF,NDFF X 30 FORMAT(' Function calls:'/ X & ' A = ',I6,' B = ',I6,' F = ',I6, X & ' DF = ',I6,' D2F = ',I6) XC X RETURN XC XC.....End of WSTQ2 XC X END XC XC234567==1=========2=========3=========4=========5=========6=========7= SHAR_EOF : || $echo 'restore of' 'daeq2.f' 'failed' fi # ============= daeq3.f ============== if test -f 'daeq3.f' && test "$first_param" != -c; then $echo 'x -' SKIPPING 'daeq3.f' '(file already exists)' else $echo 'x -' extracting 'daeq3.f' '(text)' sed 's/^X//' << 'SHAR_EOF' > 'daeq3.f' && XC234567==1=========2=========3=========4=========5=========6=========7= XC X SUBROUTINE DAEQ3( AMAT,BMAT,GF,FF,DFF,D2FF,SOLOUT,KU,KW,KD, X & U,UP,W,T,TOUT,RDATA,IDATA,ATOL,RTOL, X & RWORK,LRW,IWORK,LIW,IER ) XC X EXTERNAL AMAT,BMAT,GF,FF,DFF,D2FF,SOLOUT XC X INTEGER KU,KW,KD,LRW,LIW,IER,IDATA(10),IWORK(LIW) X DOUBLE PRECISION U(*),UP(*),W(*),T,TOUT X DOUBLE PRECISION ATOL,RTOL,RDATA(10),RWORK(LRW) XC XC234567--1---------2---------3---------4---------5---------6---------7- XC Originally written by W. Rheinboldt, July 1994 XC Last revised June, 1996 XC234567--1---------2---------3---------4---------5---------6---------7- XC XC DAE solver for Second-order, Quasi-Linear, index-3 problems XC XC A(U,U',T)U" + B(U,U',T)W = G(U,U',T) XC F(U,T) = 0 XC XC subject to the partial initial condition XC XC U(T0) = U0, U'(T0) = UP0, such that F(U0,T0) = 0 XC XC The routine determines the remaining initial conditions XC XC U"(T0) = UPP0, W(T0) = W0, XC XC such that XC XC A(U0,UP0,T0)UPP0 + B(U0,UP0,T0)W0 = G(U0,UP0,T0) XC XC The dimensions are dim U = KU, dim W = KW, dim rge G = KD, and XC dim rge F = KA = KU + KW - KD. XC XC It is assumed that XC XC rank DF(U,T) = KA and XC XC ( A(U,P,T) B(U,P,T) ) XC rank ( ) = KU + KW XC ( D_uF(U,P,T) 0 ) XC XC for all (U,P,T) under consideration satisfying F(U,T) = 0. XC XC The Dormand-Prince Runge Kutta method of order 5 is used. XC XC For the algorithm see XC XC W. C. Rheinboldt, Solving Algebraically Explicit DAEs XC with the MANPAK - Manifold - Algorithms XC Inst. for Comp. Math. and Appl., Univ. of Pittsburgh, XC Tech. Reportt. TR-ICMA-96-199, July 1996 XC J. Comp. and Math. Applic. submitted XC XC Link with a driver, MANPAK and MANAUX XC XC Variables in the calling sequence: XC ---------------------------------- XC AMAT EXT Subroutine for evaluating A, see below XC BMAT EXT Subroutine for evaluating B, see below XC GF EXT Subroutine for evaluating G, see below XC FF EXT Subroutine for evaluating F, see below XC DFF EXT Subroutine for evaluating the Jacobian of F, XC see below. XC D2FF EXT Subroutine for evaluating the second derivative XC of F, see below. XC SOLOUT EXT Subroutine for intermediate output, see below XC KU I IN Dimension of U XC KW I IN Dimension of W XC KD I IN Number of differential equations XC U D IN Array of dimension KU, starting vector U XC D OUT Final vector for U XC UP D IN Array of dimension KU, starting vector UP XC D OUT Final vector for UP XC W D IN Array of dimension KW, starting vector W XC D OUT Final vector for W XC T D IN Initial time XC D OUT Final time XC TOUT D IN Desired stopping time XC RDATA D IN Data array of dimension 10 XC RDATA(1) = H Suggested step XC Default H = 1.0D3*RTOL(1) XC RDATA(2) = HMIN Requested minimal step XC Default HMIN = 1.0D1*EPMACH XC RDATA(3) = HMAX Requested maximal step XC Default HMAX = ABS(TOUT-T) XC RDATA(4) - RDATA(10) not used XC IDATA I IN Data array of dimension 10 XC IDATA(1) = NMAX Requested maximal number of steps XC Default NMAX = 10,000 XC IDATA(2) = JPOL Interpolation indicator XC JPOL = 0 No interpolation XC JPOL = 1 Interpolate XC Default JPOL = 0 XC IDATA(3) - IDATA(10) not used XC ATOL D IN Absolute error tolerance XC RTOL D IN Relative error tolerance XC RWORK D WK Work array of dimension LRW. XC LRW I IN Dimension of RWORK at least equal to XC KU*(4*KU+19)+KD*(KD+4*KU+34)-KW*(2*KU+28)+43 XC IWORK I WK Work array of dimension LIW. XC LIW I IN Dimension of IWORK at least equal to XC 2*KU + 2 XC IER I OUT Error indicator: XC IER = 1 successful computation interrupted by SOLOUT XC IER = 0 no error, computation was successful, XC IER = -1 error encountered and printed out. XC XC External Subroutines XC -------------------- XC The user is expected to supply subroutines for the computation of XC the coefficient functions A, G, F, the first and second derivative XC of F, as well as, one for the printout of intermediate results. XC Their calling sequences are as follows: XC XC 1. Subroutine for the matrix A XC --------------------------- XC XC SUBROUTINE AMAT(U,UP,T,C,LDC,KA,AC,LDA,IER) XC XC INTEGER IER,KA,LDC,LDA XC DOUBLE PRECISION U(*),T,C(LDC,*),AC(LDA,*) XC XC AMAT calculates the KD x KA product A(U,T)*C of the coefficient XC matrix A(U,T) and the given LDC x KA matrix C XC XC Variables in the calling sequence: XC ---------------------------------- XC U D IN Array of dimension KU, the current point XC UP D IN Array of dimension KU, the current direction XC T D IN Current time XC C D IN Array of dimension KU x KA, the given matrix XC LDC I IN Leading dimension of the matrix C, LDC >= KU XC KA I IN Number of columns of the matrix C XC AC D OUT Array of dimension KD x KA, the product matrix XC LDA I IN Leading dimension of AC, LDA >= KD XC IER I OUT Error indicator: XC IER = 0 no error. XC IER = -1 error in AMAT XC XC 2. Subroutine for the matrix B XC --------------------------- XC XC SUBROUTINE BMAT(U,UP,T,B,LDB,IER) XC XC INTEGER LDB,IER XC DOUBLE PRECISION U(*),UP(*),T,B(LDB,*) XC XC BMAT evaluates the LDB x KW matrix B(U,UP,T) XC XC Variables in the calling sequence: XC ---------------------------------- XC U D IN Array of dimension KU, the current point. XC UP D IN Array of dimension KU, the current direction XC T D IN Current time XC B D OUT Array of dimension KD x KW XC containing the computed matrix B(U,UP,T) XC LDB D OUT Leading dimension of B, LDB >= KD XC IER I OUT Error indicator: XC ier = 0 no error. XC ier = -1 error in BMAT. XC XC 3. Subroutine for evaluating G XC --------------------------- XC XC SUBROUTINE GF(U,UP,T,V,IER) XC XC INTEGER IER XC DOUBLE PRECISION U(*),UP(*),T,V(*) XC XC Variables in the calling sequence: XC ---------------------------------- XC U D IN Array of dimension KU, the current point. XC UP D IN Array of dimension KU, the current direction XC T D IN Current time XC V D OUT Array of dimension KD XC containing the vector G(U,UP,T). XC IER I OUT Error indicator: XC ier = 0 no error. XC ier = -1 error in GF. XC XC 4. Subroutine for evaluating F XC --------------------------- XC XC SUBROUTINE FF(U,T,V,IER) XC XC INTEGER IER XC DOUBLE PRECISION U(*),T,V(*) XC XC Variables in the calling sequence: XC ---------------------------------- XC U D IN Array of dimension KU, the current point. XC T D IN Current time XC V D OUT Array of dimension KA = KU + KW - KD XC containing V = F(U,T) XC IER I OUT Error indicator: XC IER = 0 no error. XC IER = -1 error in FF. XC XC 5. Subroutine for evaluating the Jacobian of F XC -------------------------------------------- XC XC SUBROUTINE DFF(U,T,DF,LDF,IER) XC XC INTEGER LDF,IER XC DOUBLE PRECISION U(*),T,DF(LDF,*) XC XC Variables in the calling sequence: XC ---------------------------------- XC U D IN Array of dimension KU, the current point. XC UP D IN Array of dimension KU, the current direction XC T D IN Current time XC DF D OUT Array of dimension KA x (KU+1) for the Jacobian XC of F at U,UP,T, where KA = KU + KW - KD. XC Let Fk denote the k-th component of F. Then XC the k-th row of DF should contain the vector XC of the KU+1 partial derivatives XC XC ( d/du(1) Fk , .... , d/du(KA) Fk, d/dt Fk ) XC XC LDF I IN Leading dimension of DFV, LDF >= KA XC IER I OUT Error indicator: XC ier = 0 no error. XC ier = -1 error in DFF. XC XC 6. Subroutine for second derivative terms of F XC ------------------------------------------- XC XC SUBROUTINE D2FF(U,T,V,D2FV,IER) XC XC INTEGER IER XC DOUBLE PRECISION U(*),T,V(*),D2FV(*) XC XC To compute the KA dimensional vector D2F(U,T)(V,V) XC with a given NVAR vector V XC XC Variables in the calling sequence: XC ---------------------------------- XC U D IN Array of dimension KU, the current point. XC UP D IN Array of dimension KU, the current direction XC T D IN Current time XC V D IN Array of dimension NVAR, the given vector. XC D2FV D OUT Array of dimension NALG, the output vector XC D2FV = D2F(U,T)(V,V). XC IER I OUT Error indicator: XC IER = 0 no error. XC IER =-1 error in D2FF. XC XC 7. Subroutine for intermediate output. XC ----------------------------------- XC XC SUBROUTINE SOLOUT(TASK,NPT,U,UP,W,T,TLAST,TNEXT) XC XC DOUBLE PRECISION U(*),UP(*),UPP(*),W(*),T,TLAST,TNEXT XC CHARACTER*6 TASK XC XC Variables in the calling sequence: XC ---------------------------------- XC TASK C IN Task identifier XC TASK = 'START' Print starting point and header XC if desired XC TASK = 'FINAL' Print final point XC TASK = 'PRNT' New computed point for printout XC TASK = 'INTP' Interpolated point is given XC OUT TASK = 'INTP' Request interpolation at time XC T in the interval between XC TLAST and TNEXT. XC TASK = 'PRNT' Continue with the integration XC TASK = 'STOP' Requests the integration to stop XC NPT I IN Current point counter XC U D IN Array of dimension KU, the current point. XC UP D IN Array of dimension KU, the current direction XC UPP D IN Array of dimension KU, the current second deriv. XC W D IN Array of dimension KW, the current vector W XC T D IN Current time XC TLAST D IN Previous time XC TNEXT D OUT Next time XC XC 8. Subroutine for error-output units XC ---------------------------------- XC XC SUBROUTINE ERROUT(KL, LOUT) XC XC INTEGER KL, LOUT(*) XC XC Function to supply KL output-unit numbers for use by XC by the message routine MSGPRT XC XC Variables in the calling sequence XC --------------------------------- XC KL I OUT Number of different output units to be used XC by MSGPRT. For KL <= 0 and KL > 5 all printout XC by MSGPRT is suppressed. XC LOUT I OUT Array of dimension KL, 1 <= KL<= 5, for the XC KL output-units to be used by MSGPRT. XC XC234567--1---------2---------3---------4---------5---------6---------7- XC XC.....Subroutines called: XC X EXTERNAL DRVQ3,MSGPRT XC XC.....Functions called XC X DOUBLE PRECISION ABS,SQRT XC XC.....Parameters XC X INTEGER NMXDEF X PARAMETER( NMXDEF = 10000 ) X DOUBLE PRECISION ZER,ONE X PARAMETER( ZER=0.0D0, ONE=1.0D0 ) X CHARACTER*(*) LNAME X PARAMETER( LNAME = 'DAEQ3' ) XC XC.....Local Variables XC X INTEGER I,K,LREN,LIEN,NWRK X DOUBLE PRECISION ATOLA(1),RTOLA(1) X CHARACTER*6 CHAR,TASK XC XC.....Variables saved between calls XC X INTEGER NCALL,LXC,LDXC,LW,LY,LYP,LUBXC,LDFXC,LAUGMT,LXN,LDXN X INTEGER LUBXN,LDFXN,LDPHI,LD2PHI,LXINT,LDXINT,LWINT,LUINT X INTEGER LUBXIN,LW0,LW1,LW2,LW3,LW4,LW5,LW6,LWKMAT X INTEGER LWRK1,LWRK2,LJPAUG,LIWRK X SAVE NCALL,LXC,LDXC,LW,LY,LYP,LUBXC,LDFXC,LAUGMT,LXN,LDXN, X & LUBXN,LDFXN,LDPHI,LD2PHI,LXINT,LDXINT,LWINT,LUINT, X & LUBXIN,LW0,LW1,LW2,LW3,LW4,LW5,LW6,LWKMAT, X & LWRK1,LWRK2,LJPAUG,LIWRK XC XC.....Common block for machine constants XC X DOUBLE PRECISION EPMACH,SAFMIN X COMMON /MACH/EPMACH,SAFMIN XC XC.....Common block for data XC X INTEGER NMAX,JPOL X DOUBLE PRECISION H,HMIN,HMAX,POSNEG X COMMON /DATQ3/H,HMIN,HMAX,POSNEG,NMAX,JPOL XC XC.....Common block for the statistics variables XC X INTEGER NSTEP,NACCPT,NREJCT,NDER,NMA,NMB,NGF,NFF,NDFF,ND2FF X COMMON /STAQ3/NSTEP,NACCPT,NREJCT,NDER,NMA,NMB,NGF,NFF,NDFF,ND2FF XC XC.....Common block for dimensions XC X INTEGER NU,NW,NDIF,NVAR,NALG,MDIM,MDIM2,MDIMM1,MDIMP1 X COMMON /DIMQ3/NU,NW,NDIF,NVAR,NALG,MDIM,MDIM2,MDIMM1,MDIMP1 XC X DATA NCALL/0/ XC XC.......................Executable statements......................... XC XC.....At first call check dimensions, set pointers into work XC.....arrays and check for insufficient storage. XC.....(These are data that depend only on the problem XC.....but not on a specific trajectory) XC X IF(NCALL .EQ. 0) THEN X NCALL = 1 X NU = KU X NW = KW X NDIF = KD + 1 X NVAR = KU + 1 X NALG = KU + KW - KD X MDIM = NVAR - NALG X MDIM2 = MDIM + MDIM X MDIMM1 = MDIM - 1 X MDIMP1 = MDIM + 1 X NWRK = KU + KD + 1 XC XC........Set machine constant XC X CALL DMACH( EPMACH,SAFMIN ) XC XC........Check data and set defaults XC X IER = -1 X IF( NVAR .LT. 2 ) THEN X CALL MSGPRT(LNAME,'The ambient space must be at '// X & 'least two-dimensional') X RETURN X ENDIF X IF( MDIM .LT. 1 )THEN X CALL MSGPRT(LNAME,'The manifold must be at least '// X & 'one-dimensional') X RETURN X ENDIF XC XC Set pointers into RWORK XC X LXC = 1 X LDXC = LXC + NVAR X LW = LDXC + NVAR X LY = LW + NW X LYP = LY + MDIM2 XC X LUBXC = LYP + MDIM2 X LDFXC = LUBXC + NVAR*MDIM X LAUGMT = LDFXC + NALG*NVAR XC X LXN = LAUGMT + NVAR*NVAR X LDXN = LXN + NVAR X LUBXN = LDXN + NVAR X LDFXN = LUBXN + NVAR*MDIM XC X LDPHI = LDFXN + NALG*NVAR X LD2PHI = LDPHI + NVAR*MDIM X LXINT = LD2PHI + NVAR XC X LDXINT = LXINT + NVAR X LWINT = LDXINT + NVAR X LUINT = LWINT + NW X LUBXIN = LUINT + 5*MDIM2 XC X LW0 = LUBXIN + NVAR*MDIM X LW1 = LW0 + MDIM2 X LW2 = LW1 + MDIM2 X LW3 = LW2 + MDIM2 X LW4 = LW3 + MDIM2 X LW5 = LW4 + MDIM2 X LW6 = LW5 + MDIM2 XC X LWKMAT = LW6 + MDIM2 X LWRK1 = LWKMAT + NWRK*NWRK X LWRK2 = LWRK1 + NWRK X LREN = LWRK2 + NWRK - 1 XC XC........Check for sufficient RWORK XC X IF(LREN .GT. LRW) THEN X WRITE (CHAR,10) LREN X 10 FORMAT(I5) X CALL MSGPRT(LNAME, X & 'RWORK must have at least dimension '//CHAR) X RETURN X ENDIF XC XC........Set pointers into IWORK XC X LJPAUG = 1 X LIWRK = LJPAUG + NVAR X LIEN = LIWRK + NVAR - 1 XC XC........Check for sufficient IWORK XC X IF(LIEN .GT. LIW) THEN X WRITE (CHAR,10) LIEN X CALL MSGPRT(LNAME, X & 'IWORK must have at least dimension '//CHAR) X RETURN X ENDIF X ENDIF XC XC.....Now set the data that depend on the specific trajectory XC X POSNEG = ONE X IF( TOUT .LT. T )POSNEG = -POSNEG X HMIN = RDATA(2) X IF( HMIN .LE. ZER )HMIN = SQRT(EPMACH) X HMAX = RDATA(3) X IF( HMAX .EQ. ZER )HMAX = ABS(TOUT - T) X IF( HMAX .LT. ZER ) HMAX = -HMAX X H = RDATA(1) X IF( POSNEG*H .LT. ZER ) H = -H X IF( H .EQ. ZER ) H = POSNEG*SQRT(DBLE(MDIM)) XC X ATOLA(1) = ATOL X RTOLA(1) = RTOL XC X NMAX = IDATA(1) X IF (NMAX .LE. 0 ) NMAX = NMXDEF X JPOL = IDATA(2) X IF (JPOL .NE. 1) JPOL = 0 XC XC.....Initialize counters XC X NSTEP = 0 X NACCPT = 0 X NREJCT = 0 X NDER = 0 X NMA = 0 X NGF = 0 X NFF = 0 X NDFF = 0 X ND2FF = 0 XC XC.....Copy the given vectors T,U,W into XC XC X K = NVAR X RWORK(K) = T X DO 20 I = 1, NU X K = K + 1 X RWORK(I) = U(I) X RWORK(K) = UP(I) X 20 CONTINUE X K = K + 1 X RWORK(K) = ONE XC XC.....Call the Runge-Kutta driver XC X CALL DRVQ3( AMAT,BMAT,GF,FF,DFF,D2FF,SOLOUT,TOUT,ATOLA,RTOLA, X & RWORK(LXC),RWORK(LDXC),RWORK(LW),RWORK(LY), X & RWORK(LYP),RWORK(LUBXC),NVAR,RWORK(LDFXC),NALG, X & RWORK(LAUGMT),NVAR,IWORK(LJPAUG),RWORK(LXN), X & RWORK(LDXN),RWORK(LUBXN),RWORK(LDFXN), X & RWORK(LDPHI),NVAR,RWORK(LD2PHI), X & RWORK(LXINT),RWORK(LDXINT),RWORK(LWINT), X & RWORK(LUINT),RWORK(LW0),RWORK(LW1), X & RWORK(LW2),RWORK(LW3),RWORK(LW4),RWORK(LW5), X & RWORK(LW6),RWORK(LWKMAT),NVAR,RWORK(LWRK1), X & RWORK(LWRK2),IWORK(LIWRK),IER ) XC XC.....Test for error condition and then return XC X IF (IER .NE. 0) CALL MSGPRT(LNAME, X & ' Error return from the RK-step driver') XC XC.....Restore U,UP,W,T XC X K = NVAR X T = RWORK(K) X DO 30 I = 1, NU X K = K + 1 X U(I) = RWORK(I) X UP(I) = RWORK(K) X 30 CONTINUE X K = K + 1 X IF( NW .GT. 0 )THEN X DO 40 I = 1, NW X K = K + 1 X W(I) = RWORK(K) X 40 CONTINUE X ENDIF XC XC.....Print final point XC X TASK = 'FINAL' X CALL SOLOUT( TASK,JPOL,NACCPT,U,UP,W,T,T,T ) XC X RETURN XC XC.....End of DAEQ3 XC X END XC XC234567==1=========2=========3=========4=========5=========6=========7= XC X SUBROUTINE DRVQ3( AMAT,BMAT,GF,FF,DFF,D2FF,SOLOUT, X & TOUT,ATOLA,RTOLA,XC,DXC,W,Y,YP, X & UBXC,LDU,DFXC,LDF,AUGMT,LDA,JPAUG, X & XN,DXN,UBXN,DFXN,DPHI,LDP,D2PHI, X & XINT,DXINT,WINT,UINT, X & W0,W1,W2,W3,W4,W5,W6, X & WRKMAT,LDW,WRK1,WRK2,IWRK,IER ) XC X EXTERNAL AMAT,BMAT,GF,FF,DFF,D2FF,SOLOUT XC X INTEGER LDA,LDF,LDP,LDU,LDW,IER X INTEGER JPAUG(*),IWRK(*) XC X DOUBLE PRECISION TOUT,ATOLA(*),RTOLA(*) X DOUBLE PRECISION XC(*),DXC(*),W(*),Y(*),YP(*) X DOUBLE PRECISION UBXC(LDU,*),DFXC(LDF,*),AUGMT(LDA,*) X DOUBLE PRECISION XN(*),DXN(*),UBXN(LDU,*),DFXN(LDF,*) X DOUBLE PRECISION DPHI(LDP,*),D2PHI(*) X DOUBLE PRECISION XINT(*),DXINT(*),WINT(*) X DOUBLE PRECISION UINT(5,*) X DOUBLE PRECISION W0(*),W1(*),W2(*),W3(*),W4(*),W5(*),W6(*) X DOUBLE PRECISION WRKMAT(LDW,*),WRK1(*),WRK2(*) XC XC234567--1---------2---------3---------4---------5---------6---------7- XC XC This is the driver for the RK step routine DOPSTN. The XC integration continues until either NMAX steps have been XC taken or until T = TOUT has been reached. XC XC A new local system is constructed at each step. XC XC Variables in the calling sequence: XC ---------------------------------- XC AMAT EXT Subroutine for evaluating A XC BMAT EXT Subroutine for evaluating B XC GF EXT Subroutine for evaluating G XC FF EXT Subroutine for evaluating F XC DFF EXT Subroutine for evaluating the Jacobian of F XC D2FF EXT Subroutine for evaluating the second XC derivative of F XC SOLOUT EXT Subroutine for intermediate output XC TOUT D IN Desired stopping time XC ATOLA D IN Array of dimension 1, the absolute error tolerance XC RTOLA D IN Array of dimension 1, the relative error tolerance XC XC D WK Array of dimension NVAR, the current XC point, XC = (U, T) XC DXC D array of dimension NU XC IN the current derivative in global coordinates XC OUT the last computed global derivative (UP, 1) XC W D array of dimension NW XC IN the last vector of algebraic variables XC OUT the current vector of algebraic variables XC Y D IN array of dimension MDIM, the vector (U,T) XC in local coordinates XC YP D OUT array of dimension MDIM, derivative of the XC point in local coordinates XC UBXC D WK Array of dimension LDU x MDIM for the XC basis matrix at XC XC LDU I IN Leading dimension of UBSXC, LDU >= NVAR XC DFXC D WK Array of dimension LDF x NVAR for the Jacobian XC DF(XC) and its decomposition XC LDF I IN Leading dimension of DFXC, LDF >= NALG XC AUGMT D WK Array of dimension LDF x NVAR for factored the XC augmented matrix at XC XC LDF I IN Leading dimension of AUGMT, LDB >= NVAR XC JPAUG I WK Array of dimension of dimension NVAR for the XC pivot array used in the decomposition of AUGMT XC XN D WK Array of dimension NVAR, intermediate point XC UBXN D WK Array of dimension LDU x MDIM for the XC basis matrix at XN XC DFXN D WK Array of dimension LDF x NVAR for the Jacobian XC DF(XN) and its decomposition XC DPHI D OUT Array of dimension NVAR x MDIM, the current XC derivative of the local parametrization XC LDP I IN leading dimension of DPHI, LDP >= NVAR XC XINT D WK Array of dimension NVAR for interpolation XC DXINT D WK Array of dimension NVAR for interpolation XC WINT D WK Array of dimension NW for interpolation XC UINT D WK Array of dimension 5*MDIM for use in interpolation XC UBXINT D WK Work array of dimension LDU x MDIM for the XC basis matrix at XINT XC W0-W6 D WK Seven work arrays of dimension MDIM XC WRKMAT D WK Work array of dimension LDW x MDIM XC LDW I IN Leading dimension of WRKMAT, LDW >= MDIM XC WRK1 XC -WRK2 D WK Two work arrays of dimension NVAR XC IWRK I Wk Work array of dimension NVAR XC IER I OUT Error indicator XC IER = 1 computation successful XC but interrupted by SOLOUT XC IER = 0 no error, computation was successful XC IER = -1 other error encountered and printed out XC XC234567--1---------2---------3---------4---------5---------6---------7- XC XC.....Subroutines called: XC X EXTERNAL AUGM,DOPSTN,DYQ3,GNBAS,INTQ3,MSGPRT,ORIENT XC XC.....Parameters XC X INTEGER ITOL X DOUBLE PRECISION TFACT,ZER,HALF X PARAMETER( ITOL=0, TFACT=1.01D0, ZER=0.0D0, HALF=0.5D0 ) X CHARACTER*(*) LNAME X PARAMETER( LNAME = 'DRVQ3' ) XC XC.....Local Variables XC X INTEGER I,J X DOUBLE PRECISION DPNRM,T,TLOC,TLOCL,TNEXT,TPR,TLAST X CHARACTER*6 TASK,MODE X CHARACTER*5 CHAR1, CHAR2 X LOGICAL LAST,ICFLAG XC XC.....Common block for machine constants XC X DOUBLE PRECISION EPMACH,SAFMIN X COMMON /MACH/EPMACH,SAFMIN XC XC.....Common block for data XC X INTEGER NMAX,JPOL X DOUBLE PRECISION H,HMIN,HMAX,POSNEG X COMMON /DATQ3/H,HMIN,HMAX,POSNEG,NMAX,JPOL XC XC.....Common block for the statistics variables XC X INTEGER NSTEP,NACCPT,NREJCT,NDER,NMA,NMB,NGF,NFF,NDFF,ND2FF X COMMON /STAQ3/NSTEP,NACCPT,NREJCT,NDER,NMA,NMB,NGF,NFF,NDFF,ND2FF XC XC.....Common block for dimensions XC X INTEGER NU,NW,NDIF,NVAR,NALG,MDIM,MDIM2,MDIMM1,MDIMP1 X COMMON /DIMQ3/NU,NW,NDIF,NVAR,NALG,MDIM,MDIM2,MDIMM1,MDIMP1 XC XC.......................Executable statements......................... XC XC.....Get the Jacobian at the starting point XC XC X T = XC(NVAR) X CALL DFF( XC,T,DFXC,LDF,IER ) X NDFF = NDFF + 1 X IF(IER .NE. 0)THEN X CALL MSGPRT(LNAME,'Error in evaluating the Jacobian') X IER = -1 X RETURN X ENDIF XC XC.....Copy XC, DXC into XN, DXN and DFXC into AUGMT XC X DO 20 J = 1,NVAR X XN(J) = XC(J) X DXN(J) = DXC(J) X DO 10 I = 1,NALG X AUGMT(I,J) = DFXC(I,J) X 10 CONTINUE X 20 CONTINUE XC XC.....Establish a local coordinate basis in UBXC XC X CALL GNBAS( NVAR,MDIM,UBXC,LDU,DFXC,LDF, X & WRK1,WRK2,IWRK,SAFMIN,IER ) X IF(IER .NE. 0) THEN X CALL MSGPRT(LNAME, X & 'Basis construction failed at the starting point') X IER = -1 X RETURN X ENDIF XC XC.....Establish the full data structure at XC XC X CALL AUGM(NVAR,MDIM,AUGMT,LDA,UBXC,LDU,JPAUG,IER) X IF (IER .NE. 0) THEN X CALL MSGPRT(LNAME,'Numerically singular augmented matrix') X IER = -1 X RETURN X ENDIF XC XC.....Setup and solve the reduced, linear system and determine W XC X MODE = 'INIT' X CALL DYQ3( MODE,AMAT,BMAT,GF,FF,DFF,D2FF, X & Y,YP,W,DPHI,LDP,D2PHI,DPNRM, X & XC,DXC,UBXC,LDU,AUGMT,LDA,JPAUG, X & XN,DXN,DFXN,LDF,WRKMAT,LDW,IWRK,WRK1,IER ) X IF(IER .NE. 0) THEN X CALL MSGPRT(LNAME, X & 'Computation of starting vector W failed') X IER = -1 X RETURN X ENDIF XC XC.....Write out starting point XC X T = XC(NVAR) X TASK = 'START' X CALL SOLOUT( TASK,JPOL,NACCPT,XC,DXC,W,T,T,T ) X IF (TASK .EQ. 'STOP') THEN X CALL MSGPRT (LNAME,'Interruption by SOLOUT, '// X & 'computation terminated') X IER = 0 X RETURN X ENDIF XC XC.....Loop point for accepted steps XC X 100 CONTINUE XC XC.....Check if we are close to the terminal value of T XC X LAST = .FALSE. X IF ((T + TFACT*H - TOUT)*POSNEG .GT. ZER) THEN X H = TOUT - T X LAST = .TRUE. X TLOCL = H X ENDIF XC XC.....Save the current time XC X TLAST = T X TLOC = ZER X MODE = 'INIT' XC XC.....Call the derivative routine XC X TASK = 'STEP' X 150 CONTINUE X CALL DYQ3( MODE,AMAT,BMAT,GF,FF,DFF,D2FF,Y,YP,W, X & DPHI,LDP,D2PHI,DPNRM,XC,DXC,UBXC,LDU, X & AUGMT,LDA,JPAUG,XN,DXN,DFXN,LDF,WRKMAT,LDW, X & IWRK,WRK1,IER ) X NDER = NDER + 1 X IF (IER .NE. 0) THEN X IF (IER .GT. 0 .AND. TASK .EQ. 'EVAL') THEN X TASK = 'REDUCE' X H = HALF*H X ELSE X CALL MSGPRT (LNAME, X & 'Error in evaluating the local ODE') X IER = -1 X RETURN X ENDIF X ENDIF XC XC.....Call the step routine XC X CALL DOPSTN( TASK,MDIM2,TLOC,Y,YP,H,HMIN,HMAX,NMAX, X & ATOLA,RTOLA,ITOL,W0,W1,W2,W3,W4,W5,W6, X & JPOL,UINT,NSTEP,NACCPT,NREJCT ) X IF (TASK .EQ. 'EVAL') THEN X MODE = 'NEXT' X GOTO 150 X ELSEIF (TASK .EQ. 'DONE') THEN X GOTO 200 X ELSEIF (TASK .EQ. 'STPCNT') THEN X WRITE (CHAR1,160) NSTEP X WRITE (CHAR2,160) NMAX X 160 FORMAT(I5) X CALL MSGPRT (LNAME,'Step count '//CHAR1//' exceeds ' X & //'given maximum NMAX= '//CHAR2) X IER = -2 X RETURN X ELSEIF ( TASK .EQ. 'MINSTP' ) THEN X CALL MSGPRT (LNAME,'Step fell below HMIN') X IER = -3 X RETURN X ELSE X CALL MSGPRT (LNAME,'Error return from the RK-routine') X IER = -1 X RETURN X ENDIF XC X 200 CONTINUE X IF( LAST .AND. (TLOC .NE. TLOCL) )LAST = .FALSE. XC X TASK = 'PRNT' X TNEXT = XN(NVAR) X TPR = TNEXT X ICFLAG = .TRUE. X CALL SOLOUT( TASK,JPOL,NACCPT,XN,DXN,W,TPR,TLAST,TNEXT ) XC X 220 CONTINUE X IF( TASK .EQ. 'PRNT' )THEN X GOTO 300 X ELSEIF( TASK .EQ. 'STOP' )THEN X CALL MSGPRT (LNAME,'Interruption by SOLOUT, '// X & 'computation terminated') X IER = 1 X RETURN X ELSEIF( TASK .EQ. 'INTP' )THEN XC XC........Interpolation is requested XC........If this is the first time, copy the current DX and W XC X IF( ICFLAG )THEN X DO 230 I = 1, NVAR X DXINT(I) = DXN(I) X 230 CONTINUE X DO 240 I = 1, NW X WINT(I) = W(I) X 240 CONTINUE X ICFLAG = .FALSE. X ENDIF X CALL INTQ3( AMAT,BMAT,GF,FF,DFF,D2FF,TLAST,TNEXT,TPR, X & UINT,XINT,DXINT,WINT,DPHI,LDP,D2PHI, X & XC,DXC,UBXC,LDU,AUGMT,LDA,JPAUG,DFXC,LDF, X & WRKMAT,LDW,WRK1,WRK2,IWRK,IER ) X NDER = NDER + 1 X IF (IER .NE. 0) THEN X CALL MSGPRT (LNAME,'Error in interpolation -- proceed') X GOTO 300 X ENDIF XC XC........Write out the interpolated solution XC X CALL SOLOUT( TASK,JPOL,NACCPT,XINT,DXINT,WINT, X & TPR,TLAST,TNEXT ) X GOTO 220 X ELSE XC X CALL MSGPRT (LNAME, X & 'SOLOUT returns unknown value of TASK -- proceed') X ENDIF XC XC.....Check for further action XC X 300 CONTINUE XC XC.....Copy XN, DXN and the Jacobian XC X DO 320 J = 1,NVAR X XC(J) = XN(J) X DXC(J) = DXN(J) X DO 310 I = 1,NALG X AUGMT(I,J) = DFXN(I,J) X 310 CONTINUE X 320 CONTINUE X T = XC(NVAR) XC XC.....If this was the last step return XC X IF( LAST ) THEN X IER = 0 X RETURN X ENDIF XC XC.....Compute the basis matrix UBXC XC X CALL GNBAS( NVAR,MDIM,UBXN,LDU,DFXN,LDF, X & WRK1,WRK2,IWRK,SAFMIN,IER ) X IF(IER .NE. 0) THEN X CALL MSGPRT(LNAME, X & 'Basis construction failed at the new point') X IER = -1 X RETURN X ENDIF XC XC.....With the old basis as reference adjust the XC.....orientation of the new basis XC X CALL ORIENT( NU,MDIMM1,UBXC,LDU,UBXN,LDU, X & WRKMAT,LDW,IWRK,IER ) X IF( IER .NE. 0 ) THEN X CALL MSGPRT(LNAME,'Error in reorienting the new basis') X IER = -1 X RETURN X ENDIF XC XC.....Move basis from UBXN to UBXC XC X DO 340 J = 1,MDIM X DO 330 I = 1,NVAR X UBXC(I,J) = UBXN(I,J) X 330 CONTINUE X 340 CONTINUE XC XC.....Establish the full data structure at XC XC X CALL AUGM(NVAR,MDIM,AUGMT,LDA,UBXC,LDU,JPAUG,IER) X IF( IER .NE. 0 )THEN X CALL MSGPRT(LNAME,'Numerically singular augmented matrix') X IER = -1 X RETURN X ENDIF XC XC.....Return to the loop point XC X GOTO 100 XC XC.....End of DRVQ3 XC X END XC XC234567==1=========2=========3=========4=========5=========6=========7= XC X SUBROUTINE DYQ3( MODE,AMAT,BMAT,GF,FF,DFF,D2FF, X & Y,YP,W,DPHI,LDP,D2PHI,DPNRM, X & XC,DXC,UBXC,LDU,AUGMT,LDA,JPAUG, X & XN,DXN,DFXN,LDF,WRKMAT,LDW,IWRK,WRK,IER ) XC X EXTERNAL AMAT,BMAT,GF,FF,DFF,D2FF X CHARACTER*6 MODE XC X INTEGER IER,LDA,LDF,LDP,LDU,LDW X INTEGER JPAUG(*),IWRK(*) XC X DOUBLE PRECISION Y(*),YP(*),W(*) X DOUBLE PRECISION DPHI(LDP,*),D2PHI(*),DPNRM X DOUBLE PRECISION XC(*),DXC(*),UBXC(LDU,*),AUGMT(LDA,*) X DOUBLE PRECISION XN(*),DXN(*),DFXN(LDF,*) X DOUBLE PRECISION WRKMAT(LDW,*),WRK(*) XC XC234567--1---------2---------3---------4---------5---------6---------7- XC XC For given y = (y1,y2,t) the routine evaluates y' = (y1', y2') XC = (y2, z) and w by as solution of the reduced linear system XC XC ( (A*dphi 0) B ) ( z ) = ( G - A*d2phi ) XC ( ( 0 1) 0 ) ( w ) ( 1 ) XC XC where phi denotes the local parametrization and the arguments of XC the functions A, B, and G are (phi(y1),dphi(y1)). XC XC This routine runs with DOPSTN. XC XC Variables in the calling sequence: XC ---------------------------------- XC MODE C IN Point indicator XC MODE = 'INIT', the global point is XN = XC XC MODE = 'NEXT', compute the next global point XN XC AMAT EXT Subroutine for evaluating A XC BMAT EXT Subroutine for evaluating B XC GF EXT Subroutine for evaluating G XC FF EXT Subroutine for evaluating F XC DFF EXT Subroutine for evaluating the Jacobian of F, XC D2FF EXT Subroutine for evaluating the second derivative XC derivative of F, XC Y D IN array of dimension 2*MDIM, vector Y = (U,V) XC in local coordinates XC YP D OUT array of dimension 2*MDIM, derivative of the XC point in local coordinates XC W D OUT Array of dimension NW, the computed vector W XC DPHI D OUT Array of dimension NVAR x MDIM, the current XC derivative of the local parametrization XC LDP I IN leading dimension of DPHI, LDP >= NVAR XC D2PHI D OUT Array of dimension NVAR, second derivative term XC DPNRM D OUT Maximum norm of D2PHI XC XC D IN Array of dimension NVAR, the center point of XC the local cordinate system in global coord. XC DXC D IN Array of dimension NVAR, the direction at XC XC UBXC D IN Array of dimension LDU x MDIM for the basis matrix XC basis matrix at XC XC LDU I IN Leading dimension of UBXC and UBXN, LDU >= NVAR XC AUGMT D IN Array of dimension LDA x NVAR, the LU decomposed XC augmented matrix at XC XC LDA I IN Leading dimension of AUGMT, LDA >= NVAR XC JPAUG I IN Array of dimension NVAR for the pivot array of XC AUGMT at XC XC XN D OUT Array of dimension NVAR, the next point in XC global coordinates XC DXN D IN Array of dimension NVAR, the direction at XN XC DFXN D OUT Array of dimension LDF x NVAR for the XC Jacobian at XN XC LDF I IN Leading dimension of DFXN, LDF >= NALG XC WRKMAT D WK Work array of dimension LDW x NVAR XC LDW I IN Leading dimension of WRKMAT, LDW >= NVAR XC IWRK I WK Work array of dimension NVAR XC WRK I Wk Work array of dimension NVAR XC IER I OUT error indicator XC IER = 1 correctable error -- steplength too XC large -- no printout from MSGPRT XC IER = 0 no error XC IER = -1 fatal error, printout from MSGPRT XC XC234567--1---------2---------3---------4---------5---------6---------7-C XC.....Subroutines called: XC X EXTERNAL DGPHI,EVXQ3,LUS1,SLVQ3 XC XC.....Parameters XC X DOUBLE PRECISION ZER,ONE X PARAMETER( ZER=0.0D0, ONE=1.0D0 ) X CHARACTER*(*) LNAME X PARAMETER( LNAME = 'DYQ3') XC XC.....Local variables XC X INTEGER I,J X DOUBLE PRECISION DUM(1,1),SUM X CHARACTER*6 TASK X LOGICAL YFLAG XC XC.....Common block for the statistics variables XC X INTEGER NSTEP,NACCPT,NREJCT,NDER,NMA,NMB,NGF,NFF,NDFF,ND2FF X COMMON /STAQ3/NSTEP,NACCPT,NREJCT,NDER,NMA,NMB,NGF,NFF,NDFF,ND2FF XC XC.....Common block for dimensions XC X INTEGER NU,NW,NDIF,NVAR,NALG,MDIM,MDIM2,MDIMM1,MDIMP1 X COMMON /DIMQ3/NU,NW,NDIF,NVAR,NALG,MDIM,MDIM2,MDIMM1,MDIMP1 XC XC.......................Executable statements......................... XC X YFLAG = MODE.EQ.'INIT' XC X IF( YFLAG )THEN XC XC........Compute Dphi XC X TASK = 'EVAL' X CALL DGPHI( TASK,NVAR,MDIM,DPHI,LDP,AUGMT,LDA, X & UBXC,LDU,JPAUG,IER ) X IF( IER .NE. 0 ) THEN X CALL MSGPRT(LNAME,'Error in the computation of DPHI') X IER = -1 X RETURN X ENDIF XC XC........Evaluate D2F(X)(DX,DX) XC X CALL D2FF( XC,XC(NVAR),DXC,D2PHI,IER ) X ND2FF = ND2FF + 1 X IF (IER .NE. 0) THEN X CALL MSGPRT(LNAME, X & 'Error in evaluating the second derivative of F') X IER = -1 X RETURN X ENDIF XC XC........Evaluate D2PHI XC X TASK = 'EVAL' X CALL D2GPHI( TASK,NVAR,MDIM,D2PHI,DPNRM,AUGMT,LDA, X & DUM,1,JPAUG,IER ) X IF( IER .NE. 0 )THEN X CALL MSGPRT(LNAME, X & 'Error in evaluating the second derivative '// X & 'of the local parametrization') X IER = -1 X RETURN X ENDIF XC XC........Evaluate the local vector Y XC X DO 20 I = 1,MDIM X SUM = ZER X DO 10 J =1,NVAR X SUM = SUM + UBXC(J,I)*DXC(J) X 10 CONTINUE X Y(I) = ZER X Y(MDIM+I) = SUM X 20 CONTINUE X Y(MDIM2) = ONE XC XC........Set up and solve the linear system XC X CALL SLVQ3( AMAT,BMAT,GF,XC,DXC,Y,YP,W,DPHI,LDP,D2PHI, X & DPNRM,WRKMAT,LDW,IWRK,WRK,IER ) XC X ELSE XC XC........Get the new point XN on the manifold with local coord Y XC X CALL EVXQ3( FF,DFF,Y,XN,DXN,WRK,DPHI,LDP,D2PHI,DPNRM, X & XC,DXC,UBXC,LDU,AUGMT,LDA,JPAUG, X & WRKMAT,LDW,IWRK,DFXN,LDF,IER ) X IF( IER .NE. 0 ) THEN X IF( IER .GT. 0 ) THEN X IER = 1 X ELSE X CALL MSGPRT( LNAME, X & 'Error in computing the new point' ) X IER = -1 X ENDIF X RETURN X ENDIF XC XC........Setup and solve the reduced linear system XC X CALL SLVQ3( AMAT,BMAT,GF,XN,DXN,Y,YP,W,DPHI,LDP,D2PHI, X & DPNRM,WRKMAT,LDW,IWRK,WRK,IER ) XC X ENDIF XC X IF( IER .NE. 0 )THEN X IF( IER .GT. 0 )THEN X IER = 1 X ELSE X CALL MSGPRT( LNAME, X & 'Error in solving the reduced linear system' ) X IER = -1 X ENDIF X ELSE X IER = 0 X ENDIF XC X RETURN XC XC.....End of DYQ3 XC X END XC XC234567==1=========2=========3=========4=========5=========6=========7= XC X SUBROUTINE INTQ3( AMAT,BMAT,GF,FF,DFF,D2FF,TLAST,TNEXT,TPR, X & UINT,XINT,DXINT,WINT,DPHI,LDP,D2PHI, X & XC,DXC,UBXC,LDU,AUGMT,LDA,JPAUG,DFMAT,LDF, X & WRKMAT,LDW,WRK1,WRK2,IWRK,IER ) XC X EXTERNAL AMAT,BMAT,GF,FF,DFF,D2FF XC X INTEGER IER,IWRK(*),JPAUG(*),LDA,LDF,LDP,LDU,LDW X DOUBLE PRECISION TLAST,TNEXT,TPR,UINT(5,*) X DOUBLE PRECISION XINT(*),DXINT(*),WINT(*),DPHI(LDP,*),D2PHI(*) X DOUBLE PRECISION XC(*),DXC(*),UBXC(LDU,*),AUGMT(LDA,*) X DOUBLE PRECISION DFMAT(LDF,*) X DOUBLE PRECISION WRKMAT(LDW,*),WRK1(*),WRK2(*) XC XC234567--1---------2---------3---------4---------5---------6---------7- XC XC Routine for interpolating between computed points when XC intermediate output is desired. XC XC Variables in the calling sequence: XC ---------------------------------- XC AMAT EXT Subroutine for evaluating A XC BMAT EXT Subroutine for evaluating B XC GF EXT Subroutine for evaluating G XC FF EXT Subroutine for evaluating F XC DFF EXT Subroutine for evaluating the Jacobian of F XC D2FF EXT Subroutine for evaluating the second derivative of F XC TLAST D IN The last time XC TNEXT D IN The next time XC TPR D IN The time where output is desired. TPR must XC be between TLAST and TNEXT XC UINT D IN Interpolation array of dimension 5 * MDIM computed XC by DOPSTN for the step from TLAST to TNEXT XC XINT D OUT Array of dimension NVAR, interpolated global point XC DXINT D OUT Array of dimension NVAR, interpolated direction XC WINT D OUT Array of dimension NVAR, interpolated W XC DPHI D OUT Array of dimension NVAR x MDIM, the computed XC derivative of the local parametrization XC LDP I IN Leading dimension of DPHI, LDP >= NVAR XC D2PHI D OUT Array of dimension NVAR, second derivative XC term of PHI at XINT XC XC D IN Array of dimension NVAR, the center point of XC the local cordinate system in global coordinates XC DXC D IN Array of dimension NVAR, the global direction at XC XC UBXC D IN Array of dimension LDU x MDIM for the basis matrix XC basis matrix at XC XC LDU I IN Leading dimension of UBXC, LDU >= NVAR XC AUGMT D IN Array of dimension LDA x NVAR for the XC augmented matrix at XC and its decomposition XC LDA I IN Leading dimension of AUGMT, LDA >= NVAR XC JPAUG I IN Array of dimension NALG for the pivot array of XC the LQ factorization of AUGMT XC DFMAT D WK Work array of dimension LDF x NVAR for the XC Jacobian at XINT XC LDF I IN Leading dimension of DFMAT, LDU >= NALG XC WRKMAT D WK Work array of dimension LDW x NVAR XC LDW I IN Leading dimension of WRKMAT, LDW >= NALG XC IWRK I WK Work array of dimension NVAR XC WRK1 XC -WRK2 D WK Two work array of dimension NVAR XC IER I OUT Error indicator XC IER = 0 No error XC IER = -1 TPR was not between TLAST and TNEXT XC IER = -2 Projection onto the manifold failed XC XC234567--1---------2---------3---------4---------5---------6---------7- XC XC.....Subroutines called: XC X EXTERNAL EVXQ3,SLVQ3,MSGPRT XC XC.....Local variables XC X INTEGER I X DOUBLE PRECISION DPNRM,HT,S X CHARACTER*(*) LNAME X PARAMETER( LNAME = 'INTQ3' ) XC XC.....Parameters XC X DOUBLE PRECISION ONE, ZER X PARAMETER( ONE=1.0D0, ZER=0.0D0 ) XC XC.....Common block for dimensions XC X INTEGER NU,NW,NDIF,NVAR,NALG,MDIM,MDIM2,MDIMM1,MDIMP1 X COMMON /DIMQ3/NU,NW,NDIF,NVAR,NALG,MDIM,MDIM2,MDIMM1,MDIMP1 XC XC.......................Executable statements......................... XC XC.....Get effective step and check for TPR between TLAST and TNEXT XC X HT = TNEXT - TLAST X S = (TPR - TLAST)/HT X IF( (S .LT. ZER) .OR. (S .GT. ONE) ) THEN X CALL MSGPRT (LNAME,'Interpolation requested outside '// X & 'last integration interval') X IER = -1 X RETURN X ENDIF XC XC.....Evaluate the interpolation polynomial at S to get YINT XC X DO 10 I = 1,MDIM2 X WRK1(I) = UINT(1,I) + HT*S*(UINT(2,I) + S*(UINT(3,I) X & + S*(UINT(4,I) + S*UINT(5,I)))) X 10 CONTINUE X WRK1(MDIM) = HT*S X WRK1(MDIM2) = ONE XC X CALL EVXQ3( FF,DFF,WRK1,XINT,DXINT,WRK2,DPHI,LDP, X & D2PHI,DPNRM,XC,DXC,UBXC,LDU,AUGMT,LDA, X & JPAUG,WRKMAT,LDW,IWRK,DFMAT,LDF,IER ) X IF( IER .NE. 0 ) THEN X CALL MSGPRT( LNAME, X & 'Error in evaluating the interpolated point' ) X IER = -1 X RETURN X ENDIF X TPR = XINT(NVAR) XC XC.....Setup and solve the reduced linear system XC X CALL SLVQ3( AMAT,BMAT,GF,XINT,DXINT,WRK1,WRK1,WINT,DPHI,LDP, X & D2PHI,DPNRM,WRKMAT,LDW,IWRK,WRK2,IER ) X IF( IER .NE. 0 )THEN X CALL MSGPRT( LNAME, X & 'Error in solving the reduced linear system' ) X IER = -1 X RETURN X ENDIF XC X IER = 0 XC X RETURN XC XC.....End of INTQ3 XC X END XC XC234567==1=========2=========3=========4=========5=========6=========7= XC X SUBROUTINE EVXQ3( FF,DFF,Y,X,DX,FX,DPHI,LDP,D2PHI,DPNRM, X & XC,DXC,UBXC,LDU,AUGMT,LDA,JPAUG, X & WRKMAT,LDW,IWRK,DFMAT,LDF,IER ) XC X EXTERNAL FF,DFF XC X INTEGER IER,IWRK(*),JPAUG(*),LDA,LDF,LDP,LDU,LDW XC X DOUBLE PRECISION Y(*),X(*),DX(*),FX(*),DPHI(LDP,*),D2PHI(*),DPNRM X DOUBLE PRECISION XC(*),DXC(*),UBXC(LDU,*),AUGMT(LDA,*) X DOUBLE PRECISION WRKMAT(LDW,*),DFMAT(LDF,*) XC XC234567--1---------2---------3---------4---------5---------6---------7- XC XC For a given local point Y in the local coordinate system defined XC at XC with the basis UBXC, the subroutine evaluates the XC corresponding global point X and the derivative Dphi(Y) of the XC local parametrization. XC XC Variables in the calling sequence: XC ---------------------------------- XC FF EXT Subroutine for evaluating F XC DFF EXT Subroutine for evaluating the Jacobian of F XC Y D IN Array of dimension MDIM2, the local vector XC X D OUT Array of dimension NVAR, the corresponding XC global vector (U, T) XC DX D OUT Array of dimension NVAR, the global direction at X XC FX D OUT The function value at X XC DPHI D OUT Array of dimension NVAR x MDIM, the computed XC derivative of the local parametrization XC LDP I IN leading dimension of DPHI, LDP >= NVAR XC D2PHI D OUT Array of dimension NVAR, the second derivative term XC DPNRM D OUT The maximum norm of D2PHI XC XC D IN Array of dimension NVAR, the center point of XC the local cordinate system in global coordinates XC DXC D IN Array of dimension NVAR, the global direction at XC XC UBXC D IN Array of dimension LDU x MDIM for the basis matrix XC basis matrix at XC XC LDU I IN Leading dimension of UBXC and UBXN, LDU >= NVAR XC AUGMT D IN Array of dimension LDA x NVAR for the XC augmented matrix at XC and its decomposition XC LDA I IN Leading dimension of AUGMT, LDA >= NVAR XC JPAUG I IN Array of dimension NALG for the pivot array of XC the LQ factorization of AUGMT XC WRKMAT D WK Work array of dimension LDW x NVAR XC LDW I IN Leading dimension of WRKMAT, LDW >= NALG XC IWRK I WK Work array of dimension NALG XC DFMAT D OUT Array of dimension LDF x NVAR, for a copy of XC the Jacobian at X XC LDF I IN Leading dimension of DFMAT, LDF >= NALG XC IER I OUT error indicator XC IER = 1 correctable error -- ||Y|| is too XC large for convergence of phi. XC -- no printout from MSGPRT XC IER = 0 no error XC IER = -1 fatal error, printout from MSGPRT XC XC234567--1---------2---------3---------4---------5---------6---------7- XC XC.....Subroutines called: XC X EXTERNAL GPHI,DGPHI,D2GPHI,MSGPRT XC XC.....Parameters XC X DOUBLE PRECISION ONE,ZER X PARAMETER( ONE=1.0D0, ZER=0.0D0 ) X CHARACTER*(*) LNAME X PARAMETER( LNAME = 'EVXQ3') XC XC.....Local variables XC X INTEGER I,ISTEP,J X DOUBLE PRECISION DIR,DUM(1,1),SUM X CHARACTER*6 TASK XC XC.....Common block for machine constant XC X DOUBLE PRECISION EPMACH,SAFMIN X COMMON /MACH/EPMACH,SAFMIN XC XC.....Common block for the statistics variables XC X INTEGER NSTEP,NACCPT,NREJCT,NDER,NMA,NMB,NGF,NFF,NDFF,ND2FF X COMMON /STAQ3/NSTEP,NACCPT,NREJCT,NDER,NMA,NMB,NGF,NFF,NDFF,ND2FF XC XC.....Common block for dimensions XC X INTEGER NU,NW,NDIF,NVAR,NALG,MDIM,MDIM2,MDIMM1,MDIMP1 X COMMON /DIMQ3/NU,NW,NDIF,NVAR,NALG,MDIM,MDIM2,MDIMM1,MDIMP1 XC XC.......................Executable statements......................... XC X TASK = 'START' XC X 10 CONTINUE X CALL GPHI( TASK,NVAR,MDIM,Y,X,FX,XC,UBXC,LDU, X & AUGMT,LDA,JPAUG,EPMACH,ISTEP ) X IF( TASK .EQ. 'EVAL' )THEN X CALL FF( X,X(NVAR),FX,IER ) X NFF = NFF + 1 X IF( IER .NE. 0 )THEN X CALL MSGPRT( LNAME,'Error in evaluating the function F' ) X IER = -1 X RETURN X ENDIF X GOTO 10 X ELSEIF( TASK .EQ. 'DONE' )THEN X GOTO 20 X ELSEIF( TASK .EQ. 'DIVERG' .OR. TASK .EQ. 'STPCNT' )THEN X IER = 1 X RETURN X ELSE X CALL MSGPRT( LNAME, X & 'Error in computing the local parametrization' ) X IER = -1 X RETURN X ENDIF XC X 20 CONTINUE XC XC.....Get Jacobian of F at X and store in WRKMAT XC X CALL DFF( X,X(NVAR),WRKMAT,LDW,IER ) X NDFF = NDFF + 1 X IF( IER .NE. 0 )THEN X CALL MSGPRT( LNAME,'Error in evaluating the Jacobian' ) X IER = -1 X RETURN X ENDIF XC XC.....If desired, retain a copy of the Jacobian in DFMAT XC X DO 40 J = 1,NVAR X DO 30 I = 1,NALG X DFMAT(I,J) = WRKMAT(I,J) X 30 CONTINUE X 40 CONTINUE XC XC.....Compute DPHI XC X TASK = 'FACTOR' X CALL DGPHI( TASK,NVAR,MDIM,DPHI,LDP,WRKMAT,LDW, X & UBXC,LDU,IWRK,IER ) X IF( IER .NE. 0 ) THEN X CALL MSGPRT( LNAME,'Error in computing the derivative '// X & 'of the local parametrization' ) X IER = -2 X RETURN X ENDIF XC XC.....Compute DX XC X Y(MDIM2) = ONE X DIR = ZER X DO 60 I = 1,NVAR X SUM = ZER X DO 50 J = 1,MDIM X SUM = SUM + DPHI(I,J)*Y(MDIM+J) X 50 CONTINUE X DX(I) = SUM X IF( I .LT. NVAR )DIR = DIR + SUM*DXC(I) X 60 CONTINUE XC XC.....Align DX with DXC XC X IF( DIR .LT. ZER )THEN X DO 90 I = 1,NU X DX(I) = -DX(I) X 90 CONTINUE X ENDIF X DX(NVAR) = ONE XC XC.....Evaluate D2F(X)(DX,DX) XC X CALL D2FF( X,X(NVAR),DX,D2PHI,IER ) X ND2FF = ND2FF + 1 X IF (IER .NE. 0) THEN X CALL MSGPRT(LNAME, X & 'Error in evaluating the second derivative of F') X IER = -1 X RETURN X ENDIF XC XC.....Compute D2PHI XC X TASK = 'EVAL' X CALL D2GPHI( TASK,NVAR,MDIM,D2PHI,DPNRM,WRKMAT,LDW, X & DUM,1,IWRK,IER ) X IF(IER .NE. 0)THEN X CALL MSGPRT(LNAME, X & 'Error in evaluating the second derivative '// X & 'of the local parametrization') X IER = -1 X RETURN X ENDIF XC X IER = 0 X RETURN XC XC.....End of EVXQ3 XC X END XC XC234567==1=========2=========3=========4=========5=========6=========7= XC X SUBROUTINE SLVQ3( AMAT,BMAT,GF,X,DX,Y,YP,W,DPHI,LDP,D2PHI, X & DPNRM,WRKMAT,LDW,IWRK,WRK,IER ) XC X EXTERNAL AMAT,BMAT,D2FF,GF XC X INTEGER IER,LDP,LDW,IWRK(*) XC X DOUBLE PRECISION X(*),DX(*),Y(*),YP(*),W(*) X DOUBLE PRECISION DPHI(LDP,*),D2PHI(*),DPNRM X DOUBLE PRECISION WRKMAT(LDW,*),WRK(*) XC XC234567--1---------2---------3---------4---------5---------6---------7- XC XC Subroutine for setting up and solving the NDIF x NDIF dimensional XC linear system (NDIF = MDIM + NW) XC XC ( ( A 0 )*dphi B ) ( y') ( G - A*d2phi ) XC ( ( 0 1 ) 0 ) ( w ) = ( 1 ) XC XC where x = phi(y) is the local coordinate transformation and GRED XC the value of G reduced by a secind derivative term. XC XC Variables in the calling sequence: XC ---------------------------------- XC AMAT EXT Subroutine for evaluating A XC BMAT EXT Subroutine for evaluating B XC GF EXT Subroutine for evaluating G XC X D IN Array of dimension NVAR, the global point XC DX D IN Array of dimension NVAR, the global direction XC Y D IN Array of dimension MDIM2, the local point XC YP D OUT Array of dimension MDIM, the computed XC derivative in local coordinates XC UP D OUT Array of dimension NU, the computed XC derivative in global coordinates XC W D OUT Array of dimension NW, the computed vector W XC DPHI D IN Array of dimension LDP x MDIM, the derivative XC of the local parametrization XC LDP I IN Leading dimension of DPHI, LDP >= NVAR XC D2PHI D IN Array of dimension NVAR, second derivative term XC DPNRM D IN Maximum norm of D2PHI XC WRKMAT D WK Work array of dimension LDW x NDIF XC LDW I IN Leading dimension of WRKMAT, LDW >= NDIF XC WRK D WK Work arrays of dimension NDIF XC IWRK I WK Work array of dimension NDIF XC IER I OUT error indicator XC IER = 0 no error XC IER = -1 fatal error, printout from MSGPRT XC XC234567--1---------2---------3---------4---------5---------6---------7-C XC.....Subroutines called: XC X EXTERNAL LUF,LUS1,MSGPRT XC XC.....Parameters XC X DOUBLE PRECISION ONE, ZER X PARAMETER( ONE=1.0D0, ZER=0.0D0 ) X CHARACTER*(*) LNAME X PARAMETER( LNAME = 'SLVQH2') XC XC.....Local Variables XC X INTEGER I,J X DOUBLE PRECISION T XC XC.....Common block for the statistics variables XC X INTEGER NSTEP,NACCPT,NREJCT,NDER,NMA,NMB,NGF,NFF,NDFF,ND2FF X COMMON /STAQ3/NSTEP,NACCPT,NREJCT,NDER,NMA,NMB,NGF,NFF,NDFF,ND2FF XC XC.....Common block for dimensions XC X INTEGER NU,NW,NDIF,NVAR,NALG,MDIM,MDIM2,MDIMM1,MDIMP1 X COMMON /DIMQ3/NU,NW,NDIF,NVAR,NALG,MDIM,MDIM2,MDIMM1,MDIMP1 XC XC.......................Executable statements......................... XC X T = X(NVAR) XC XC.....Evaluate the right side G in WRK XC X CALL GF( X,DX,T,WRK,IER) X NGF = NGF +1 X IF(IER .NE. 0)THEN X CALL MSGPRT(LNAME,'Error in evaluating the right side G') X IER = -1 X RETURN X ENDIF X WRK(NDIF) = ZER XC XC.....Multiply A times the second derivative term is not zero, XC.....and form the right side XC X IF( DPNRM .NE. 0 )THEN X CALL AMAT( X,DX,T,D2PHI,NVAR,1,WRKMAT,LDW,IER ) X NMA = NMA +1 X IF( IER .NE. 0 )THEN X CALL MSGPRT(LNAME, X & 'Error in evaluating the coefficient matrix A') X IER = -1 X RETURN X ENDIF X DO 10 I = 1,NDIF X WRK(I) = WRK(I) - WRKMAT(I,1) X 10 CONTINUE X ENDIF X WRK(NDIF) = ZER XC XC.....Multiply A by DPHI and store in the XC.....first MDIM columns of WRKMAT XC X CALL AMAT(X,DX,T,DPHI,LDP,MDIM,WRKMAT,LDW,IER) X NMA = NMA +1 X IF( IER .NE. 0 )THEN X CALL MSGPRT( LNAME, X & 'Error in evaluating the coefficient matrix A ') X IER = -1 X RETURN X ENDIF XC XC.....Evaluate B and store in last NW columns of WRKMAT XC X CALL BMAT(X,DX,T,WRKMAT(1,MDIMP1),LDW,IER) X NMB = NMB + 1 X IF(IER .NE. 0)THEN X CALL MSGPRT( LNAME, X & 'Error in evaluating the coefficient matrix B ') X IER = -1 X RETURN X ENDIF XC XC.....Set the last row of WRKMAT XC X DO 20 J = 1, NDIF X WRKMAT(NDIF,J) = ZER X 20 CONTINUE X WRKMAT(NDIF,MDIM) = ONE XC XC.....Solve WRKMAT * S = WRK for S and store in WRK1 XC X CALL LUF(NDIF,WRKMAT,LDW,IWRK,IER) X IF (IER .NE. 0) THEN X CALL MSGPRT(LNAME,'The augmented matrix is singular' ) X IER = -1 X RETURN X ENDIF X CALL LUS1(NDIF,WRKMAT,LDW,IWRK,WRK,IER) XC XC.....Form the output vectors YP, W XC X I = MDIM X DO 30 J = 1, MDIM X I = I + 1 X YP(J) = Y(I) X YP(I) = WRK(J) X 30 CONTINUE X YP(MDIM) = ONE X YP(MDIM2) = ZER X DO 40 J = 1, NW X W(J) = WRK(MDIM+J) X 40 CONTINUE XC XC.....Successful return XC X IER = 0 X RETURN XC XC.....End of SLVQ3 XC X END XC XC234567==1=========2=========3=========4=========5=========6=========7= XC X SUBROUTINE WSTQ3( LOUT ) XC X INTEGER LOUT XC XC234567--1---------2---------3---------4---------5---------6---------7- XC XC Routine for printing some run statistics for DAEQ3 XC XC Variable in the calling sequence: XC ---------------------------------- XC LOUT I IN Output unit number XC XC234567--1---------2---------3---------4---------5---------6---------7- XC XC.....Common block for the statistics variables XC X INTEGER NSTEP,NACCPT,NREJCT,NDER,NMA,NMB,NGF,NFF,NDFF,ND2FF X COMMON /STAQ3/NSTEP,NACCPT,NREJCT,NDER,NMA,NMB,NGF,NFF,NDFF,ND2FF XC XC.......................Executable statements......................... XC X WRITE(LOUT,10)NSTEP,NACCPT,NREJCT X 10 FORMAT(1X/' Number of steps: '/ X & ' Total= ',I6,' Accepted= ',I6,' Rejected= ',I6) XC X WRITE(LOUT,20) NDER X 20 FORMAT(' Local ODE evaluations = ',I6) XC X WRITE(LOUT,30) NMA,NMB,NGF,NFF,NDFF,ND2FF X 30 FORMAT(' Function calls:'/ X & ' A = ',I6,' B = ',I6,' G = ',I6/ X & ' F = ',I6,' DF = ',I6,' D2F = ',I6) XC X RETURN XC XC.....End of WSTQ3 XC X END XC XC234567==1=========2=========3=========4=========5=========6=========7= SHAR_EOF : || $echo 'restore of' 'daeq3.f' 'failed' fi # ============= daesq1.f ============== if test -f 'daesq1.f' && test "$first_param" != -c; then $echo 'x -' SKIPPING 'daesq1.f' '(file already exists)' else $echo 'x -' extracting 'daesq1.f' '(text)' sed 's/^X//' << 'SHAR_EOF' > 'daesq1.f' && XC234567==1=========2=========3=========4=========5=========6=========7= XC X SUBROUTINE DAESQ1( AMAT,GF,FF,DFF,SOLOUT,KU,KA,U,RDATA, X & IDATA,ATOL,RTOL,RWORK,LRW,IWORK,LIW,IER ) XC X EXTERNAL AMAT,GF,FF,DFF,SOLOUT XC X INTEGER KU,KA,LRW,LIW,IER,IDATA(10),IWORK(LIW) X DOUBLE PRECISION U(*),ATOL,RTOL,RDATA(10),RWORK(LRW) XC XC234567--1---------2---------3---------4---------5---------6---------7- XC XC DAE solver for Quasi-linear, autonomous, index-1 problems XC XC A(u)u' = G(u), XC F(u) = 0, XC XC u(0) = u0, F(u0) = 0 XC XC with optional facility for handling Singular (impasse) points, XC XC Here dim U = KU, dim rge F = KA < KU, and rank DF(U) = KA XC XC The subroutines incorporates the scaling procedure for approaching XC and passing impasse points developed in XC XC P. Rabier and W. Rheinboldt, On Impasse Points of Quasilinear XC Differential Algebraic Equations XC J. Math. Anal. and Appl. 181, 1994, 429-454 XC XC P. Rabier and W. Rheinboldt, On the Computation of Impasse XC Points of Quasilinear Differential Algebraic Equations XC Math. of Comput. 62, 1994, 133-154 XC XC Link with a driver, MANPAK and MANAUX XC XC We use the notation XC XC NVAR = dimension of the ambient space: NVAR = KU XC NALG = number of algebraic equations: NALG = KD XC MDIM = dimension of the manifold: MDIM = NVAR - NALG XC XC Variables in the calling sequence: XC ---------------------------------- XC AMAT EXT Subroutine for evaluating A, see below. XC GF EXT Subroutine for evaluating G, see below. XC FF EXT Subroutine for evaluating F, see below. XC DFF EXT Subroutine for evaluating the Jacobian of F, XC see below. XC SOLOUT EXT Subroutine for intermediate output, see below. XC KU I IN Dimension of U XC KA I IN Number of algebraic equations XC U D IN Starting point. XC D OUT Final point XC RDATA D IN Data array of dimension 10 XC RDATA(1) = H Suggested step XC Default H = 1.0D3*RTOL(1) XC RDATA(2) = HMIN Requested minimal step XC Default HMIN = 1.0D1*EPMACH XC RDATA(3) = HMAX Requested maximal step XC Default HMAX = ABS(TOUT-T) XC RDATA(4) = XTARG Target value of the variable XC ITARG = IDATA(3). Not used when XC ITARG = 0 XC RDATA(5) - RDATA(10) not used XC IDATA I IN Data array of dimension 10 XC IDATA(1) = NMAX Requested maximal number of steps XC Default NMAX = 10,000 XC IDATA(3) = ITARG Index of the target variable or 0 XC Default ITARG = 0 XC IDATA(4) = IMPAS Indicator for use of impasse routine XC IMPAS = 0 When minimal step is encountered XC then return XC = 1 When minimal step encountered XC proceed with impasse routine XC IDATA(2), IDATA(5) - IDATA(10) not used XC ATOL D IN Absolute error tolerance XC RTOL D IN Relative error tolerance XC RWORK D WK Work array of dimension LRW. XC LRW I IN Dimension of RWORK at least equal to XC LRW = LRW0 = KU*(3*KU+15) - 9*KA if IMPAS = 0 XC LRW = LRW0 + 3*KD + (KD+2)^2 if IMPAS = 1 XC where KD = KU-KA XC IWORK I WK Work array of dimension LIW. XC LIW I IN Dimension of IWORK at least equal to 3*KU. XC IER I OUT Error indicator: XC IER = 1 successful computation interrupted by SOLOUT XC IER = 0 no error, computation was successful, XC IER = -1 error encountered and printed out. XC XC External Subroutines XC -------------------- XC The user is expected to supply subroutines for the computation of XC the coefficient functions A, G, F, and the Jacobian of F, as well XC as, for the printout of intermediate results. Their calling XC sequences are as follows: XC XC 1. Subroutine for the matrix A(U) XC ------------------------------ XC XC SUBROUTINE AMAT(U,UP,V,IER) XC XC INTEGER IER XC DOUBLE PRECISION U(*),UP(*),V(*) XC XC AMAT calculates the NALG-dimensional vector V= A(U)*UP XC This subroutine is not called when MID = IDATA(3) = 1. XC In that case, provide only a dummy routine. XC XC Variables in the calling sequence: XC ---------------------------------- XC U D IN Array of dimension KU, the current point. XC UP D IN Array of dimension KU, given vector. XC V D OUT Array of dimension KU, the product A(U)*UP. XC IER I OUT Error indicator: XC IER = 0 no error. XC IER = -1 error in AMAT XC XC 2. Subroutine for evaluating G XC --------------------------- XC XC SUBROUTINE GF(U,V,IER) XC XC INTEGER IER XC DOUBLE PRECISION U(*),V(*) XC XC To compute the KD dimensional vector GV = G(U) XC XC Variables in the calling sequence: XC ---------------------------------- XC U D IN Array of dimension KU, the current point. XC V D OUT Array of dimension KU containing G(U). XC IER I OUT Error indicator: XC ier = 0 no error. XC ier = -1 error in GF. XC XC 3. Subroutine for evaluating F XC --------------------------- XC XC SUBROUTINE FF(U,FV,IER) XC XC INTEGER IER XC DOUBLE PRECISION U(*),T,FV(*) XC XC To compute the KA dimensional vector FV = F(U) XC XC Variables in the calling sequence: XC ---------------------------------- XC U D IN Array of dimension KU, the current point. XC V D OUT Array of dimension KA, containing V = F(U). XC IER I OUT Error indicator: XC IER = 0 no error. XC IER = -1 error in FF. XC XC 4. Subroutine for evaluating the Jacobian of F XC ------------------------------------------- XC XC SUBROUTINE DFF(U,T,DFV,LDF,IER) XC XC INTEGER LDF,IER XC DOUBLE PRECISION U(*),T,DFV(LDF,*) XC XC To compute the KA x NVAR array DFV = DF(U) XC XC Variables in the calling sequence: XC ---------------------------------- XC U D IN Array of dimension KU, the current point. XC DF D OUT Array of dimension KA by KU for the Jacobian XC of F at U. Let Fk denote the k-th component XC of F. Then the k-th row of DFV should contain XC the vector ( d/dU Fk ) of the KU partial XC derivatives of Fk XC LDF I IN Leading dimension of DFV, LDF >= KA XC IER I OUT Error indicator: XC ier = 0 no error. XC ier = -1 error in DFF. XC XC 5. Subroutine for intermediate output. XC ----------------------------------- XC XC SUBROUTINE SOLOUT(TASK,NSTEP,U,GAMMA,IRTRN) XC XC INTEGER NSTEP,IRTRN XC DOUBLE PRECISION U(*) XC XC Variables in the calling sequence: XC ---------------------------------- XC TASK C IN Task identifier XC TASK = 'START' Print starting point and header, XC if desired XC TASK = 'FINAL' Print final point XC TASK = 'PRNT' New computed point for printout XC OUT TASK = 'STOP' Requests the integration to stop XC NSTEP I IN Current point counter XC U D IN Array of dimension KU, the current point XC GAMMA D IN Indicator of the scale. (see the references) XC |GAMMA| = 1 if no scaling is done XC GAMMA tends to zero near the singular point XC IRTRN I OUT Return indicator: XC IRTRN = 0 code will continue. XC IRTRN = 1 code is to stop. XC XC 6. Subroutine for error-output units XC ---------------------------------- XC XC SUBROUTINE ERROUT(KL, LOUT) XC XC INTEGER KL, LOUT(*) XC XC Function to supply KL output-unit numbers for use by XC by the message routine MSGPRT XC XC Variables in the calling sequence XC --------------------------------- XC KL I OUT Number of different output units to be used XC by MSGPRT. For KL <= 0 and KL > 5 all printout XC by MSGPRT is suppressed. XC LOUT I OUT Array of dimension KL, 1 <= KL<= 5, for the XC KL output-units to be used by MSGPRT. XC XC234567--1---------2---------3---------4---------5---------6---------7- XC Originally written by W. Rheinboldt, April 1992 XC Last revised March 14, 1996 XC234567--1---------2---------3---------4---------5---------6---------7- XC XC.....Subroutines called: XC X EXTERNAL MSGPRT,DRVSQ1 XC XC.....Functions called XC X DOUBLE PRECISION SQRT XC XC.....Parameters XC X INTEGER NMXDEF X PARAMETER( NMXDEF = 10000 ) X DOUBLE PRECISION SINGH X PARAMETER( SINGH=1.0D-3 ) X DOUBLE PRECISION ZER,HALF,ONE,HUND X PARAMETER( ZER=0.0D0,HALF=0.5D0,ONE=1.0D0,HUND=1.0D2 ) X CHARACTER*(*) LNAME X PARAMETER( LNAME = 'DAESQ1' ) XC XC.....Local Variables XC X INTEGER I,LREN,LIEN X DOUBLE PRECISION AVH,ATOLA(1),RTOLA(1) X CHARACTER*6 CHAR,TASK XC XC.....Variables saved between calls XC X INTEGER NCALL,LXC,LUBXC,LDFXC,LTAUXC,LXN,LUBXN,LDFXN X INTEGER LTAUXN,LY,LYP,LW0,LW1,LW2,LW3,LW4,LW5,LW6 X INTEGER LWKMAT,LWRK1,LWRK2,LC1,LC2,LBA,LAUGM,LDA X INTEGER LJPXC,LJPXN,LIWRK X SAVE NCALL,LXC,LUBXC,LDFXC,LTAUXC,LXN,LUBXN,LDFXN, X & LTAUXN,LY,LYP,LW0,LW1,LW2,LW3,LW4,LW5,LW6, X & LWKMAT,LWRK1,LWRK2,LC1,LC2,LBA,LAUGM,LDA, X & LJPXC,LJPXN,LIWRK XC XC.....Common block for the statistics variables XC X INTEGER NSTEP,NACCPT,NREJCT,NDER,NMA,NGF,NFF,NDFF X COMMON /STASQ1/NSTEP,NACCPT,NREJCT,NDER,NMA,NGF,NFF,NDFF XC XC.....Common block for machine constants XC X DOUBLE PRECISION EPMACH,SAFMIN X COMMON /MACH/EPMACH,SAFMIN XC XC.....Common block for data XC X INTEGER NMAX,IMPAS,ITARG X DOUBLE PRECISION H,HMIN,SHMIN,HMAX,POSNEG,UTARG,GAMMA X COMMON /DATSQ1/H,HMIN,SHMIN,HMAX,POSNEG,UTARG,GAMMA, X & NMAX,IMPAS,ITARG XC XC.....Common block for dimensions XC X INTEGER NVAR,MDIM,MDIP1,NALG,NAUG X COMMON /DIMSQ1/NVAR,MDIM,MDIP1,NALG,NAUG XC X DATA NCALL/0/ XC XC.......................Executable statements......................... XC XC.....At first call check dimensions, set pointers into work XC.....arrays and check for insufficient storage. XC.....(These are data that depend only on the problem XC.....but not on a specific trajectory) XC X IF(NCALL .EQ. 0) THEN X NCALL = 1 X NVAR = KU X NALG = KA X MDIM = NVAR - NALG X MDIP1 = MDIM + 1 X NAUG = MDIM + 2 X IF( MDIM .EQ. 1 )NAUG = MDIP1 X IMPAS = 0 X IF( IDATA(4) .NE. 0 )IMPAS = 1 XC XC........Set machine constant XC X CALL DMACH( EPMACH,SAFMIN ) XC XC........Check data and set defaults XC X IER = -1 X IF( NVAR .LT. 2 ) THEN X CALL MSGPRT(LNAME,'The ambient space must be at '// X & 'least two-dimensional') X RETURN X ENDIF X IF( MDIM .LT. 1 )THEN X CALL MSGPRT(LNAME,'The manifold must be at least '// X & 'one-dimensional') X RETURN X ENDIF XC XC........Set pointers into RWORK XC X LXC = 1 X LUBXC = LXC + NVAR X LDFXC = LUBXC + NVAR*MDIM X LTAUXC = LDFXC + NALG*NVAR XC X LXN = LTAUXC + NVAR X LUBXN = LXN + NVAR X LDFXN = LUBXN + NVAR*MDIM X LTAUXN = LDFXN + NALG*NVAR XC X LY = LTAUXN + NVAR X LYP = LY + MDIM XC X LW0 = LYP + MDIM X LW1 = LW0 + MDIM X LW2 = LW1 + MDIM X LW3 = LW2 + MDIM X LW4 = LW3 + MDIM X LW5 = LW4 + MDIM X LW6 = LW5 + MDIM XC X LWKMAT = LW6 + MDIM X LWRK1 = LWKMAT + NVAR*NVAR X LWRK2 = LWRK1 + NVAR XC X IF( IMPAS .EQ. 0 )THEN X LREN = LWRK2 + NVAR - 1 X LC1 = LREN X LC2 = LREN X LBA = LREN X LAUGM = LREN X LDA = 1 X ELSE X LC1 = LWRK2 + NVAR X LC2 = LC1 + MDIM X LBA = LC2 + MDIM X LAUGM = LBA + MDIM X LDA = NAUG X LREN = LAUGM + NAUG*NAUG - 1 X ENDIF XC XC........Check for sufficient RWORK XC X IF(LREN .GT. LRW) THEN X WRITE (CHAR,10) LREN X 10 FORMAT(I5) X CALL MSGPRT(LNAME, X & 'RWORK must have at least dimension '//CHAR) X RETURN X ENDIF XC XC........Set pointers into IWORK XC X LJPXC = 1 X LJPXN = LJPXC + NVAR X LIWRK = LJPXN + NVAR X LIEN = LIWRK + NVAR - 1 XC XC........Check for sufficient IWORK XC X IF(LIEN .GT. LIW) THEN X WRITE (CHAR,10) LIEN X CALL MSGPRT(LNAME, X & 'IWORK must have at least dimension '//CHAR) X RETURN X ENDIF X ENDIF XC XC.....Now set the data that depend on the specific trajectory XC X NMAX = IDATA(1) X IF (NMAX .LE. 0 ) NMAX = NMXDEF X ITARG = IDATA(3) X IF (ITARG.LE.0 .OR. ITARG.GT.NVAR) ITARG = 0 XC X H = RDATA(1) X POSNEG = ONE X IF (H .LT. ZER) POSNEG = -POSNEG X IF (H .EQ. ZER) H = SQRT(EPMACH) X UTARG = RDATA(4) X HMIN = RDATA(2) X IF (HMIN .LE. ZER) HMIN = HUND*EPMACH X HMAX = RDATA(3) X IF (HMAX .EQ. ZER)THEN X IF( ITARG .NE. 0 ) THEN X HMAX = UTARG - U(ITARG) X ELSE X HMAX = ONE X ENDIF X ENDIF X IF (HMAX .LT. ZER) HMAX = -HMAX X SHMIN = SINGH X AVH = HALF*(HMAX+HMIN) X IF( SHMIN .GT. AVH )SHMIN = AVH X IF( SHMIN .LT. HMIN )SHMIN = HMIN XC X ATOLA(1) = ATOL X RTOLA(1) = RTOL XC XC.....Initialize counters XC X NSTEP = 0 X NACCPT = 0 X NREJCT = 0 X NDER = 0 X NMA = 0 X NGF = 0 X NFF = 0 X NDFF = 0 XC XC.....Copy the initial point XC X DO 20 I = 1, NVAR X RWORK(I) = U(I) X 20 CONTINUE XC XC.....Call the Runge-Kutta driver XC X CALL DRVSQ1( AMAT,GF,FF,DFF,SOLOUT,ATOLA,RTOLA,RWORK(LXC), X & RWORK(LUBXC),NVAR,RWORK(LDFXC),NALG,RWORK(LTAUXC), X & IWORK(LJPXC),RWORK(LXN),RWORK(LUBXN),RWORK(LDFXN), X & RWORK(LTAUXN),IWORK(LJPXN),RWORK(LY),RWORK(LYP), X & RWORK(LW0),RWORK(LW1),RWORK(LW2),RWORK(LW3), X & RWORK(LW4),RWORK(LW5),RWORK(LW6),RWORK(LWKMAT), X & NVAR,IWORK(LIWRK),RWORK(LWRK1),RWORK(LWRK2), X & RWORK(LC1),RWORK(LC2),RWORK(LBA), X & RWORK(LAUGM),LDA,IER ) XC XC.....Test for error condition and then return XC X IF (IER .NE. 0) CALL MSGPRT(LNAME, X & 'Error return from the RK driver') XC XC.....Reset the point XC X DO 30 I = 1, NVAR X U(I) = RWORK(I) X 30 CONTINUE XC XC.....Print out final point XC X TASK = 'FINAL' X CALL SOLOUT(TASK,NACCPT,U,POSNEG) X X RETURN XC XC.....End of DAESQ1 XC X END XC XC234567==1=========2=========3=========4=========5=========6=========7= XC X SUBROUTINE DRVSQ1( AMAT,GF,FF,DFF,SOLOUT,ATOLA,RTOLA, X & XC,UBXC,LDU,DFXC,LDF,TAUXC,JPXC, X & XN,UBXN,DFXN,TAUXN,JPXN,Y,YP, X & W0,W1,W2,W3,W4,W5,W6,WRKMAT,LDW, X & IWRK,WRK1,WRK2,C1,C2,BA,AUGMT,LDA,IER ) XC X EXTERNAL AMAT,GF,FF,DFF,SOLOUT XC X INTEGER LDA,LDF,LDU,LDW,JPXC(*),JPXN(*),IWRK(*),IER XC X DOUBLE PRECISION ATOLA(*),RTOLA(*),XC(*),DFXC(LDF,*) X DOUBLE PRECISION UBXC(LDU,*),TAUXC(*),XN(*),DFXN(LDF,*) X DOUBLE PRECISION UBXN(LDU,*),TAUXN(*),Y(*),YP(*) X DOUBLE PRECISION W0(*),W1(*),W2(*),W3(*),W4(*),W5(*),W6(*) X DOUBLE PRECISION WRKMAT(LDW,*),WRK1(*),WRK2(*) X DOUBLE PRECISION C1(*),C2(*),BA(*),AUGMT(LDA,*) XC XC234567--1---------2---------3---------4---------5---------6---------7- XC XC This is a driver for the RK step routine DOPSTA. It continues XC the integration until either NMAX steps have been taken or until XC X(ITARG) = XTARG has been passed. A new local system is XC constructed at each step. XC XC Variables in the calling sequence: XC ---------------------------------- XC AMAT EXT Subroutine for evaluating M XC GF EXT Subroutine for evaluating G XC FF EXT Subroutine for evaluating F XC DFF EXT Subroutine for evaluating the Jacobian of F XC SOLOUT EXT Subroutine for intermediate output XC XC D IN Initial point XC OUT Final point XC ATOLA D IN Array of dimension 1, the absolute error tolerance XC RTOL D IN Array of dimension 1, the relative error tolerance XC DFXC D WK Array of dimension LDF x NVAR for DF(XC) XC LDF I IN Leading dimension of DFXC, LDF >= NALG XC UBXC D OUT Array of dimension LDU x MDIM for the basis matrix XC at XC XC LDU I IN Leading dimension of UBXC, LDB >= NVAR XC BMAXC D WK Array of dimension LDB x MDIM for the augmented XC matrix at XC and its decomposition XC LDB I IN Leading dimension of BMAXC, LDB >= NVAR XC JPXC I IN Pivot array for the LU-factorization of BMAXC XC XN D WK Intermediate point XC DFXN D WK Array of dimension LDF x NVAR for DF(XN) XC UBXN D OUT Array of dimension LDU x MDIM for the basis matrix XC at XN XC BMAXN D WK Array of dimension LDB x MDIM for the augmented XC matrix at XN and its decomposition XC JPXN I IN pivot array for the LU-factorization at XN XC Y D WK Array of dimension MDIM for a point in local XC coordinates on the manifold XC YP D WK Array of dimension MDIM for the direction in XC local coordinates at Y XC W0-W6 D WK Sevenwork arrays of dimension MDIM XC WRKMAT D WK Work array of dimension LDW X MDIM XC LDW I IN Leading dimension of WRKMAT, LDW >= MDIM XC IWRK I Wk Work array of dimension NVAR XC WRK1 D WK Work array of dimension NVAR XC WRK2 D WK Work array of dimension NVAR XC WRK3 D WK Work array of dimension NVAR XC IER I OUT error indicator XC IER = 1 computation successful XC but interrupted by SOLOUT XC IER = 0 no error, computation was successful XC IER = -1 other error encountered and printed out XC XC234567--1---------2---------3---------4---------5---------6---------7- XC XC.....Subroutines called: XC X EXTERNAL COBAS,DOPSTA,DYSQ1,MSGPRT,DYSIN,SNAUG XC XC.....Functions called XC X DOUBLE PRECISION ABS,SIGN XC XC.....Parameters XC X INTEGER ITOL X DOUBLE PRECISION GAMTOL,ZER, ONE X PARAMETER( ITOL=0, GAMTOL=0.5D0, ZER=0.0D0, ONE=1.0D0 ) X CHARACTER*(*) LNAME X PARAMETER( LNAME = 'DRVSQ1' ) XC XC.....Local Variables XC X INTEGER I,IRTRN,J X DOUBLE PRECISION GAMOLD X CHARACTER*6 TASK X CHARACTER*5 CHAR1, CHAR2 X LOGICAL LAST,SCAL XC XC.....Common block for the statistics variables XC X INTEGER NSTEP,NACCPT,NREJCT,NDER,NMA,NGF,NFF,NDFF X COMMON /STASQ1/NSTEP,NACCPT,NREJCT,NDER,NMA,NGF,NFF,NDFF XC XC.....Common block for machine constants XC X DOUBLE PRECISION EPMACH,SAFMIN X COMMON /MACH/EPMACH,SAFMIN XC XC.....Common block for data XC X INTEGER NMAX,IMPAS,ITARG X DOUBLE PRECISION H,HMIN,SHMIN,HMAX,POSNEG,XTARG,GAMMA X COMMON /DATSQ1/H,HMIN,SHMIN,HMAX,POSNEG,XTARG,GAMMA, X & NMAX,IMPAS,ITARG XC XC.....Common block for dimensions XC X INTEGER NVAR,MDIM,MDIP1,NALG,NAUG X COMMON /DIMSQ1/NVAR,MDIM,MDIP1,NALG,NAUG XC XC.......................Executable statements......................... XC XC.....It is assumed that XC is not near an impasse point XC X SCAL = .FALSE. X GAMMA = POSNEG XC XC.....Write out starting point XC X TASK = 'START' X CALL SOLOUT(TASK,NACCPT,XC,GAMMA,IRTRN) X IF( TASK .EQ. 'STOP' )THEN X CALL MSGPRT (LNAME,'Interruption by SOLOUT, '// X & 'computation terminated') X IER = 0 X RETURN X ENDIF XC XC.....Get the Jacobian at XC and retain in DFXC XC X CALL DFF( XC,DFXC,LDF,IER ) X NDFF = NDFF + 1 X IF(IER .NE. 0)THEN X CALL MSGPRT(LNAME,'Error in Jacobian evaluation') X IER = -1 X RETURN X ENDIF XC XC.....Establish a local coordinate basis in UBXC XC X CALL COBAS(NVAR,NALG,DFXC,LDF,TAUXC,JPXC,UBXC,LDU, X & WRK1,SAFMIN,IER) X IF( IER .NE. 0 ) THEN X IER = -1 X CALL MSGPRT(LNAME, X & 'Basis construction failed at the starting point') X RETURN X ENDIF XC XC.....Loop point for accepted steps XC X 100 CONTINUE X LAST = .FALSE. X GAMOLD = GAMMA X IF( IMPAS .EQ. 1 )THEN X IF( (.NOT.SCAL) .AND. (ABS(H) .LE. SHMIN) )THEN X CALL MSGPRT (LNAME,'Switch to singular solver') X SCAL = .TRUE. X IF(GAMMA .LT. ZER) H = -H X ENDIF X ENDIF XC X IF( SCAL )THEN XC XC........We are near an impasse point: Calculate augmentation XC........vectors at XC XC X CALL SNAUG(AMAT,GF,C1,C2,BA,XC,UBXC,LDU, X & AUGMT,LDA,WRKMAT,LDW,IER) X IF (IER .NE. 0) THEN X CALL MSGPRT (LNAME,'The scaling-augmentation failed') X IER = -1 X RETURN X ENDIF X ENDIF XC XC.....We always start with the local coordinate Y = 0 XC X DO 110 I = 1, MDIM X Y(I) = ZER X 110 CONTINUE XC XC.....Call the derivative routine XC X TASK = 'STEP' X 150 CONTINUE X IF( SCAL )THEN X CALL DYSIN( AMAT,GF,FF,DFF,Y,YP,XC,DFXC,LDF, X & UBXC,LDU,TAUXC,JPXC,XN,DFXN,UBXN,TAUXN, X & JPXN,WRKMAT,LDW,IWRK,WRK1,WRK2, X & C1,C2,BA,AUGMT,LDA,IER ) X ELSE X CALL DYSQ1( AMAT,GF,FF,DFF,Y,YP,XC,DFXC,LDF, X & UBXC,LDU,TAUXC,JPXC,XN,DFXN,UBXN,TAUXN, X & JPXN,WRKMAT,LDW,IWRK,WRK1,WRK2,IER ) X ENDIF X NDER = NDER + 1 X IF (IER .NE. 0) THEN X IF (IER .GT. 0 .AND. TASK .EQ. 'EVAL') THEN X TASK = 'REDUCE' X ELSE X CALL MSGPRT (LNAME, X & 'Error in evaluating the local ODE') X IER = -1 X RETURN X ENDIF X ENDIF XC XC.....Call the step routine XC X CALL DOPSTA( TASK,MDIM,Y,YP,H,HMIN,HMAX,NMAX,ATOLA,RTOLA,ITOL, X & W0,W1,W2,W3,W4,W5,W6,NSTEP,NACCPT,NREJCT ) X IF (TASK .EQ. 'EVAL') THEN X GOTO 150 X ELSEIF (TASK .EQ. 'DONE') THEN X GOTO 200 X ELSEIF (TASK .EQ. 'STPCNT') THEN X WRITE (CHAR1,160) NSTEP X WRITE (CHAR2,160) NMAX X 160 FORMAT(I5) X CALL MSGPRT (LNAME,'Step count '//CHAR1//' exceeds '// X & 'given maximum NMAX= '//CHAR2) X IER = -2 X RETURN X ELSEIF ( TASK .EQ. 'MINSTP' ) THEN X CALL MSGPRT (LNAME,' Step fell below HMIN') X IER = -3 X RETURN X ELSE X CALL MSGPRT (LNAME,'Error in the Runge Kutta step') X IER = -1 X RETURN X ENDIF XC X 200 CONTINUE XC XC.....Test for target XC X IF(ITARG .NE. 0) THEN X IF( (XN(ITARG) .GE. XTARG .AND. XTARG .GE. XC(ITARG)) X & .OR. (XC(ITARG) .GE. XTARG .AND. XTARG .GE. XN(ITARG)) ) X & LAST = .TRUE. X ENDIF XC XC.....Write out the solution XC X TASK = 'PRNT' X CALL SOLOUT(TASK,NACCPT,XN,GAMMA,IRTRN) X IF( TASK .EQ. 'STOP' )THEN X CALL MSGPRT (LNAME,'Interruption by SOLOUT, '// X & 'computation terminated') X IER = 0 X RETURN X ENDIF XC XC.....Interchange XC and XN XC X DO 230 I = 1,NVAR X XC(I) = XN(I) X TAUXC(I) = TAUXN(I) X JPXC(I) = JPXN(I) X DO 210 J = 1,MDIM X UBXC(I,J) = UBXN(I,J) X 210 CONTINUE X DO 220 J = 1,NALG X DFXC(J,I) = DFXN(J,I) X 220 CONTINUE X 230 CONTINUE XC XC.....Tests while in singular solver XC X IF ( SCAL )THEN X IF( SIGN(ONE,GAMOLD) .NE. SIGN(ONE,GAMMA) ) THEN XC XC...........A singular point has been passed XC X CALL MSGPRT(LNAME,'Singular point detected ') X ENDIF X IF( ABS(GAMMA) .GE. GAMTOL )THEN XC XC...........We can go back to the regular solver XC X SCAL = .FALSE. X CALL MSGPRT (LNAME,'Switch to regular solver') X IF(GAMMA .LT. ZER) THEN X H = -H X GAMMA = -ONE X ELSE X GAMMA = ONE X ENDIF X ENDIF X ENDIF XC XC.....Normal exit XC X IF (.NOT. LAST) GOTO 100 X IER = 0 X RETURN XC XC.....End of DRVSQ1 XC X END XC XC234567==1=========2=========3=========4=========5=========6=========7= XC X SUBROUTINE DYSQ1( AMAT,GF,FF,DFF,Y,YP,XC,DFXC,LDF, X & UBXC,LDU,TAUXC,JPXC,XN,DFXN,UBXN,TAUXN, X & JPXN,WRKMAT,LDW,IWRK,WRK1,WRK2,IER ) XC X EXTERNAL AMAT,GF,FF,DFF XC X INTEGER IER,LDF,LDU,LDW X INTEGER JPXC(*),JPXN(*),IWRK(*) XC X DOUBLE PRECISION Y(*),YP(*),XC(*),XN(*),TAUXC(*),TAUXN(*) X DOUBLE PRECISION DFXC(LDF,*),UBXC(LDU,*) X DOUBLE PRECISION DFXN(LDF,*),UBXN(LDU,*) X DOUBLE PRECISION WRKMAT(LDW,*),WRK1(*),WRK2(*) XC XC234567--1---------2---------3---------4---------5---------6---------7- XC XC Subroutine for evaluating yp = y' for the local ODE XC XC A(phi(y))*dphi(y)y' = G(phi(y)) XC XC where x = phi(y) is the local coordinate transformation. XC XC Variables in the calling sequence: XC ---------------------------------- XC AMAT EXT Subroutine for evaluating A XC GF EXT Subroutine for evaluating G XC FF EXT Subroutine for evaluating F XC DFF EXT Subroutine for evaluating the Jacobian of F, XC Y D IN array of dimension MDIM, vector Y = (U,V) XC in local coordinates XC YP D OUT array of dimension MDIM, derivative of the XC point in local coordinates XC XC D IN Array of dimension NVAR, the center point of XC the local cordinate system in global coord. XC DFXC D IN Array of dimension NALG x NVAR for the XC Jacobian at XC XC LDF I IN Leading dimension of DFXC and DFXN XC UBXC D IN Array of dimension LDU x MDIM for the basis matrix XC basis matrix at XC XC LDU I IN Leading dimension of UBXC and UBXN, LDU >= NVAR XC TAUXC D IN Array of dimension NALG containing the XC scalar factors of the elementary reflectors of XC the LQ factrorization of DF(XC) XC JPXC I IN Array of dimension NALG for the pivot array of XC the LQ factorization of DF(XC) XC XN D OUT Array of dimension NVAR, the next point in XC global coordinates XC DFXN D OUT Array of dimension NALG x NVAR for the XC Jacobian at XN XC TAUXN D IN Array of dimension NALG containing the XC scalar factors of the elementary reflectors of XC the LQ factrorization of DF(XN) XC JPXN I IN Array of dimension NALG for the pivot array of XC the LQ factorization of DF(XN) XC WRKMAT D WK Work array of dimension LDW x MDIM XC LDW I IN Leading dimension of WRKMAT, LDW >= MDIM XC WRK1 I Wk Work array of dimension NVAR XC WRK2 D WK Work array of dimension NVAR XC IER I OUT error indicator XC IER = 1 correctable error -- steplength too XC large -- no printout from MSGPRT XC IER = 0 no error XC IER = -1 fatal error, printout from MSGPRT XC XC234567--1---------2---------3---------4---------5---------6---------7-C XC.....Subroutines called: XC X EXTERNAL TPHI XC XC.....Local variables XC X INTEGER I,ISTEP,J X DOUBLE PRECISION SUM X CHARACTER*6 TASK X LOGICAL YFLAG XC XC.....Parameters XC X DOUBLE PRECISION ZER X PARAMETER( ZER=0.0D0 ) X CHARACTER*(*) LNAME X PARAMETER( LNAME = 'DYSQ1') XC XC.....Common block for the statistics variables XC X INTEGER NSTEP,NACCPT,NREJCT,NDER,NMA,NGF,NFF,NDFF X COMMON /STASQ1/NSTEP,NACCPT,NREJCT,NDER,NMA,NGF,NFF,NDFF XC XC.....Common block for machine constant XC X DOUBLE PRECISION EPMACH,SAFMIN X COMMON /MACH/EPMACH,SAFMIN XC XC.....Common block for dimensions XC X INTEGER NVAR,MDIM,MDIP1,NALG,NAUG X COMMON /DIMSQ1/NVAR,MDIM,MDIP1,NALG,NAUG XC XC.......................Executable statements......................... XC XC.....Special case when Y is zero XC X YFLAG = .FALSE. X DO 10 I = 1,MDIM X IF (Y(I) .NE. ZER) GOTO 20 X 10 CONTINUE X YFLAG = .TRUE. XC X 20 CONTINUE X IF(YFLAG) THEN XC XC........Compute the product A(XC)*UBXC and store in WRKMAT XC X DO 30 J = 1,MDIM X IWRK(J) = 0 X CALL AMAT(XC,UBXC(1,J),WRKMAT(1,J),IER) X NMA = NMA +1 X IF(IER .NE. 0)THEN X CALL MSGPRT(LNAME, X & 'Error in evaluating the coefficient matrix A') X IER = -1 X RETURN X ENDIF X 30 CONTINUE XC XC........Evaluate G(XC) and store in YP XC X CALL GF( XC,YP,IER ) X NGF = NGF +1 X IF(IER .NE. 0)THEN X CALL MSGPRT(LNAME, X & 'Error in evaluating the function G') X IER = -1 X RETURN X ENDIF XC XC........Solve WRKMAT * YP = GF for YP XC X CALL LUF( MDIM,WRKMAT,LDW,IWRK,IER ) X CALL LUS1( MDIM,WRKMAT,LDW,IWRK,YP,IER ) X IF (IER .NE. 0) THEN X CALL MSGPRT(LNAME, X & 'Singular reduced matrix at the current point') X IER = -1 X RETURN X ENDIF XC X ELSE XC XC........Y is not zero: Get XN on manifold with local coord Y XC X TASK = 'START' X 100 CONTINUE X CALL TPHI( TASK,NVAR,MDIM,Y,XN,WRK1,XC,DFXC,LDF, X & TAUXC,JPXC,UBXC,LDU,WRK2,EPMACH,ISTEP ) X IF (TASK .EQ. 'EVAL') THEN X CALL FF( XN,WRK1,IER ) X NFF = NFF + 1 X IF(IER .NE. 0)THEN X CALL MSGPRT(LNAME, X & 'Error in evaluating the function F') X IER = -1 X RETURN X ENDIF X GOTO 100 X ELSEIF (TASK .EQ. 'DONE') THEN X GOTO 110 X ELSEIF (TASK .EQ. 'DIVERG' .OR. TASK .EQ. 'STPCNT') THEN X IER = 1 X RETURN X ELSE X CALL MSGPRT (LNAME, X & 'Error in computing the local parametrization' ) X IER = -1 X RETURN X ENDIF XC XC........Get Jacobian of F at XN and store in DFXN XC X 110 CONTINUE X CALL DFF( XN,DFXN,LDF,IER ) X NDFF = NDFF + 1 X IF(IER .NE. 0) THEN X CALL MSGPRT(LNAME,'Error in evaluating the Jacobian' ) X IER = -1 X RETURN X ENDIF XC XC........Establish a local coordinate basis in UBXN XC X CALL COBAS( NVAR,NALG,DFXN,LDF,TAUXN,JPXN, X & UBXN,LDU,WRK1,SAFMIN,IER ) X IF( IER .NE. 0 ) THEN X IER = -1 X CALL MSGPRT(LNAME,' The basis construction at the'// X & ' new point XN failed') X RETURN X ENDIF XC XC........Match the orientations of the two bases XC X CALL ORIENT(NVAR,MDIM,UBXC,LDU,UBXN,LDU, X & WRKMAT,LDW,IWRK,IER) XC XC........Compute the product A(X)*UBXN and store in WRKMAT XC X DO 120 J = 1,MDIM X CALL AMAT(XN,UBXN(1,J),WRKMAT(1,J),IER) X NMA = NMA + 1 X IF(IER .NE. 0) THEN X IER = -1 X CALL MSGPRT(LNAME, X & 'Error in evaluating the coefficient matrix A') X RETURN X ENDIF X 120 CONTINUE XC XC........Evaluate GF at XN and store in YP XC X CALL GF(XN,YP,IER) X NGF = NGF + 1 X IF(IER .NE. 0) THEN X IER = -1 X CALL MSGPRT(LNAME,'Error in evaluating the function G') X RETURN X ENDIF XC XC........Solve WRKMAT * YP = GF for YP XC X CALL LUF( MDIM,WRKMAT,LDW,IWRK,IER ) X CALL LUS1( MDIM,WRKMAT,LDW,IWRK,YP,IER ) X IF (IER .NE. 0) THEN X CALL MSGPRT(LNAME, X & 'Singular reduced matrix at the new point') X IER = -1 X RETURN X ENDIF XC XC........Multiply YP by UBXC^T*UBXN XC X DO 140 I = 1,NVAR X SUM = ZER X DO 130 J = 1,MDIM X SUM = SUM + UBXN(I,J)*YP(J) X 130 CONTINUE X WRK1(I) = SUM X 140 CONTINUE X DO 160 J = 1,MDIM X SUM = ZER X DO 150 I=1,NVAR X SUM = SUM + UBXC(I,J)*WRK1(I) X 150 CONTINUE X YP(J) = SUM X 160 CONTINUE X ENDIF XC XC.....Successful return XC X IER = 0 X RETURN XC XC.....End of DYSQ1 XC X END XC XC234567==1=========2=========3=========4=========5=========6=========7= XC X SUBROUTINE DYSIN( AMAT,GF,FF,DFF,Y,YP,XC,DFXC,LDF, X & UBXC,LDU,TAUXC,JPXC,XN,DFXN,UBXN,TAUXN, X & JPXN,WRKMAT,LDW,IWRK,WRK1,WRK2, X & C1,C2,BA,AUGMT,LDA,IER ) XC X EXTERNAL AMAT,GF,FF,DFF XC X INTEGER IER,LDA,LDF,LDU,LDW X INTEGER JPXC(*),JPXN(*),IWRK(*) XC X DOUBLE PRECISION Y(*),YP(*),XC(*),XN(*),TAUXC(*),TAUXN(*) X DOUBLE PRECISION DFXC(LDF,*),UBXC(LDU,*) X DOUBLE PRECISION DFXN(LDF,*),UBXN(LDU,*) X DOUBLE PRECISION WRKMAT(LDW,*),WRK1(*),WRK2(*) X DOUBLE PRECISION C1(*),C2(*),BA(*),AUGMT(LDA,*) XC XC234567--1---------2---------3---------4---------5---------6---------7- XC XC Subroutine for evaluating yp = y' for the reduced system XC XC B(y)y' + G(phi(y)) = 0; B(y) = A(phi(y))*dphi(y) XC XC near impasse points. Here x = phi(y) is the local parametrization XC XC In the case MDIM = 1 the subroutine determines the solution of XC the augmented system XC XC (B(u) gfx)(yp ) (0) XC (c1T 0 )(gamma) = (1) XC XC while for MDIM > 1 the doubly-augmented systems XC XC ( B(u) gfx ba)(v1 v2) (0 0) XC ( c1T 0 0 )(g11 g21) = (1 0) XC ( c2T 0 0 )(g12,g22) (0 1) XC XC is solved and we have XC XC yp = mu*(g22*v1 - g12*v2), gamma = mu*(g11*g22 - g21*g12) XC XC where the factor mu is chosen such that XC XC cT yp = 1 , ||c|| = 1 XC XC and c is the vector g22*c1 - g12*c2 normalized to length one. XC XC Variables in the calling sequence: XC ---------------------------------- XC AMAT EXT Subroutine for evaluating A XC GF EXT Subroutine for evaluating G XC DFF EXT Subroutine for evaluating the Jacobian of F, XC Y D IN Array of dimension MDIM, the current point in XC local coordinates XC YP D OUT Array of dimension MDIM for the derivative at Y in XC local coordinates XC XC D IN Array of dimension NVAR, the center point of XC the local cordinate system in global coord. XC DFXC D IN Array of dimension NALG x NVAR for the XC Jacobian at XC XC LDF I IN Leading dimension of DFXC and DFXN XC UBXC D IN Array of dimension LDU x MDIM for the basis matrix XC basis matrix at XC XC LDU I IN Leading dimension of UBXC and UBXN, LDU >= NVAR XC TAUXC D IN Array of dimension NALG containing the XC scalar factors of the elementary reflectors of XC the LQ factrorization of DF(XC) XC JPXC I IN Array of dimension NALG for the pivot array of XC the LQ factorization of DF(XC) XC XN D OUT Array of dimension NVAR, the next point in XC global coordinates XC DFXN D OUT Array of dimension NALG x NVAR for the XC Jacobian at XN XC TAUXN D OUT Array of dimension NALG containing the XC scalar factors of the elementary reflectors of XC the LQ factrorization of DF(XN) XC JPXN I IN Array of dimension NALG for the pivot array of XC the LQ factorization of DF(XN) XC C1 D IN Array of dimension MDIM, augmentation vector XC computed by SNAUG XC C2 D IN Array of dimension MDIM, augmentation vector XC computed by SNAUG XC BA D IN Array of dimension MDIM, augmentation vector XC computed by SNAUG XC AUGMT D WRK Array of dimension (MDIM+1) x MDIM, work array XC for the augmentation matrix XC LDA D IN Leading dimension of AUGMT, LDA >= MDIM+1 XC IWRK I WRK Work array of dimension MDIM+1 XC WRK1 D WRK Work array of dimension MDIM XC WRK2 D WRK Work array of dimension MDIM XC IER I OUT Error indicator XC IER = 1 correctable error -- steplength too XC large for the size of the domain XC of the local parametrization. XC No printout from MSGPRT XC IER = 0 No error XC IER = -1 Fatal error in function evaluation XC XC234567--1---------2---------3---------4---------5---------6---------7- XC XC.....Subroutines called: XC X EXTERNAL TPHI XC XC.....Functions called XC X DOUBLE PRECISION DDIST2 XC XC.....Parameters XC X CHARACTER*(*) LNAME X PARAMETER( LNAME = 'DYSIN' ) X DOUBLE PRECISION ZER,ONE X PARAMETER( ZER=0.0D0, ONE = 1.0D0 ) XC XC.....Local variables XC X INTEGER I,ISTEP,J,K X DOUBLE PRECISION ACU,DET,FACT,SUM,TMP X DOUBLE PRECISION G11,G12,G21,G22,PROD1,PROD2 X CHARACTER*6 TASK X LOGICAL YFLAG XC XC.....Common block for the statistics variables XC X INTEGER NSTEP,NACCPT,NREJCT,NDER,NMA,NGF,NFF,NDFF X COMMON /STASQ1/NSTEP,NACCPT,NREJCT,NDER,NMA,NGF,NFF,NDFF XC XC.....Common block for machine constants XC X DOUBLE PRECISION EPMACH,SAFMIN X COMMON /MACH/EPMACH,SAFMIN XC XC.....Common block for data XC X INTEGER NMAX,IMPAS,ITARG X DOUBLE PRECISION H,HMIN,SHMIN,HMAX,POSNEG,XTARG,GAMMA X COMMON /DATSQ1/H,HMIN,SHMIN,HMAX,POSNEG,XTARG,GAMMA, X & NMAX,IMPAS,ITARG XC XC.....Common block for dimensions XC X INTEGER NVAR,MDIM,MDIP1,NALG,NAUG X COMMON /DIMSQ1/NVAR,MDIM,MDIP1,NALG,NAUG XC XC.......................Executable statements......................... XC XC.....Special case when Y is zero XC X YFLAG = .FALSE. X DO 10 I = 1,MDIM X IF (Y(I) .NE. ZER) GOTO 20 X 10 CONTINUE X YFLAG = .TRUE. XC X 20 CONTINUE X IF(YFLAG) THEN XC XC........We have Y = 0 XC........Check for MDIM = 1 when we have a 2 x 2 matrix XC X IF (MDIM .EQ. 1) THEN XC XC...........Set A(1,1)= A(XC)*UBXC, A(1,2) = G(XC), and XC...........A(2,1) = 1.0, A(2,2) = 0 XC X CALL AMAT(XC,UBXC(1,1),WRK1,IER) X NMA = NMA +1 X IF(IER .NE. 0)THEN X CALL MSGPRT(LNAME, X & 'Error in evaluating the coefficient matrix A') X IER = -1 X RETURN X ENDIF X ACU = WRK1(1) X CALL GF( XC,WRK1,IER ) X NGF = NGF +1 X IF(IER .NE. 0)THEN X CALL MSGPRT(LNAME,'Error in evaluating the function G') X IER = -1 X RETURN X ENDIF X DET = WRK1(1) X IF (DET .EQ. ZER) THEN X CALL MSGPRT(LNAME,'Singular augmented matrix') X IER = -1 X RETURN X ENDIF XC XC...........Solve the 2 by 2 system XC X YP(1) = C1(1) X GAMMA = - ACU*YP(1)/DET X IER = 0 X RETURN X ELSE XC XC...........MDIM > 1. Multiply A(XC) by UBXC and store in AUGMT XC X DO 30 J = 1, MDIM X CALL AMAT(XC,UBXC(1,J),AUGMT(1,J),IER) X NMA = NMA + 1 X IF(IER .NE. 0)THEN X CALL MSGPRT(LNAME, X & 'Error in evaluating the coefficient matrix A') X IER = -1 X RETURN X ENDIF X 30 CONTINUE X ENDIF XC X ELSE XC XC........Y is not zero: Get XN on manifold with local coord Y XC X TASK = 'START' X 100 CONTINUE X CALL TPHI( TASK,NVAR,MDIM,Y,XN,WRK1,XC,DFXC,LDF, X & TAUXC,JPXC,UBXC,LDU,WRK2,EPMACH,ISTEP ) X IF (TASK .EQ. 'EVAL') THEN X CALL FF( XN,WRK1,IER ) X NFF = NFF + 1 X IF(IER .NE. 0)THEN X CALL MSGPRT(LNAME,'Error in evaluating the function F') X IER = -1 X RETURN X ENDIF X GOTO 100 X ELSEIF (TASK .EQ. 'DONE') THEN X GOTO 110 X ELSEIF (TASK .EQ. 'DIVERG' .OR. TASK .EQ. 'STPCNT') THEN X IER = 1 X RETURN X ELSE X CALL MSGPRT (LNAME, X & 'Evaluation of the new global point failed') X IER = -1 X RETURN X ENDIF XC XC........Get Jacobian of F at XN and store in DFXN XC X 110 CONTINUE X CALL DFF( XN,DFXN,LDF,IER ) X NDFF = NDFF + 1 X IF(IER .NE. 0) THEN X CALL MSGPRT(LNAME,'Error in evaluating the Jacobian' ) X IER = -1 X RETURN X ENDIF XC XC........Establish a local coordinate basis in UBXN XC X CALL COBAS(NVAR,NALG,DFXN,LDF,TAUXN,JPXN, X & UBXN,LDU,WRK1,SAFMIN,IER) X IF( IER .NE. 0 ) THEN X IER = -1 X CALL MSGPRT(LNAME, X & 'Basis construction failed at the new point') X RETURN X ENDIF XC XC........Match the orientations of the two bases XC X CALL ORIENT(NVAR,MDIM,UBXC,LDU,UBXN,LDU, X & WRKMAT,LDW,IWRK,IER) X IF( IER .NE. 0 ) THEN X CALL MSGPRT(LNAME,'Error in reorienting the new basis') X IER = -1 X RETURN X ENDIF XC XC........Compute UBXN^T*UBXC in WRKMAT and factor XC X DO 150 J = 1,MDIM X DO 140 I = 1,MDIM X SUM = ZER X DO 130 K = 1,NVAR X SUM = SUM + UBXN(K,I)*UBXC(K,J) X 130 CONTINUE X WRKMAT(I,J) = SUM X 140 CONTINUE X 150 CONTINUE X CALL LUF(MDIM,WRKMAT,LDW,IWRK,IER) X IF(IER .NE. 0) THEN X CALL MSGPRT(LNAME,'The product UBXN^T*UBXC of '// X & 'the basis matrices is singular') X IER = -1 X RETURN X ENDIF XC XC........Multiply A(XN) by the columns of DPHI and store in AUGMT XC X DO 190 J = 1,MDIM X DO 160 I = 1,MDIM X WRK1(I) = ZER X 160 CONTINUE X WRK1(J) = ONE X CALL LUS1(MDIM,WRKMAT,LDW,IWRK,WRK1,IER) X DO 180 K = 1,NVAR X SUM = ZER X DO 170 I = 1,MDIM X SUM = SUM + UBXN(K,I)*WRK1(I) X 170 CONTINUE X WRK2(K) = SUM X 180 CONTINUE X CALL AMAT(XN,WRK2,AUGMT(1,J),IER) X NMA = NMA + 1 X IF(IER .NE. 0) THEN X IER = -1 X CALL MSGPRT(LNAME, X & 'Error in evaluating the coefficient matrix A') X RETURN X ENDIF X 190 CONTINUE X ENDIF XC XC.....Complete the augmented matrix XC.....Evaluate G(XN) and store the negative in column MDIP1 of AUGMT XC X CALL GF( XN,WRK1,IER ) X NGF = NGF + 1 X IF(IER .NE. 0)THEN X CALL MSGPRT(LNAME,'Error in evaluating the function G') X IER = -1 X RETURN X ENDIF X DO 200 I = 1, MDIM X AUGMT(I,MDIP1) = -WRK1(I) X 200 CONTINUE XC XC.....Insert the augmenting vectors into the matrix XC X DO 210 I = 1,MDIM X AUGMT(MDIP1,I) = C1(I) X AUGMT(NAUG,I) = C2(I) X AUGMT(I,NAUG) = BA(I) X 210 CONTINUE X AUGMT(MDIP1,MDIP1) = ZER X AUGMT(MDIP1,NAUG) = ZER X AUGMT(NAUG,MDIP1) = ZER X AUGMT(NAUG,NAUG) = ZER XC XC.....Decompose the augmented matrix XC X CALL LUF( NAUG,AUGMT,LDA,IWRK,IER ) X IF (IER .NE. 0) THEN X CALL MSGPRT(LNAME,'Numerically singular augmented matrix') X IER = -1 X RETURN X ENDIF XC XC.....Determine the sign of the determinant XC X FACT = ONE X DO 220 I = 1,NAUG X IF (IWRK(I) .NE. I) FACT = -FACT X IF(AUGMT(I,I) .LT. 0) FACT = -FACT X 220 CONTINUE XC XC.....Set-up right sides XC X DO 230 I = 1, NAUG X WRK1(I) = ZER X WRK2(I) = ZER X 230 CONTINUE X WRK1(MDIP1) = ONE X WRK2(NAUG) = ONE XC XC.....Solve the systems XC X CALL LUS1( NAUG,AUGMT,LDA,IWRK,WRK1,IER ) X G11 = WRK1(MDIP1) X G12 = FACT*WRK1(NAUG) X CALL LUS1( NAUG,AUGMT,LDA,IWRK,WRK2,IER ) X G21 = WRK2(MDIP1) X G22 = FACT*WRK2(NAUG) XC X PROD1 = G12*G12 + G22*G22 X IF (PROD1 .GT. EPMACH) THEN X DO 240 I = 1,MDIM X YP(I) = G22*C1(I) - G12*C2(I) X 240 CONTINUE X TMP = DDIST2(MDIM,YP,1,YP,1,1)/PROD1 X GAMMA = TMP*(G22*G11 - G12*G21) X DO 250 I = 1, MDIM X YP(I) = TMP*(G22*WRK1(I) - G12*WRK2(I)) X 250 CONTINUE X ELSE X GAMMA = ZER X PROD2 = G11*G11 + G21*G21 X IF( PROD2 .LE. EPMACH )THEN X CALL MSGPRT(LNAME,'Failure in computing the combined '// X & 'solution of the augmented system') X IER = -1 X RETURN X ELSE X DO 260 I = 1,MDIM X YP(I) = G21*C1(I) - G11*C2(I) X 260 CONTINUE X TMP = DDIST2(MDIM,YP,1,YP,1,1)/PROD2 X DO 270 I = 1, MDIM X YP(I) = TMP*(G21*WRK1(I) - G11*WRK2(I)) X 270 CONTINUE X ENDIF X ENDIF XC X IER = 0 X RETURN XC XC.....End of DYSIN XC X END XC XC234567==1=========2=========3=========4=========5=========6=========7= XC X SUBROUTINE SNAUG(AMAT,GF,C1,C2,BA,XC,UBXC,LDU, X & AUGMT,LDA,WRKMAT,LDW,IER) XC X EXTERNAL AMAT, GF X INTEGER LDU,LDA,LDW,IER X DOUBLE PRECISION C1(*),C2(*),BA(*),XC(*),UBXC(LDU,*) X DOUBLE PRECISION AUGMT(LDA,*),WRKMAT(LDW,*) XC XC234567--1---------2---------3---------4---------5---------6---------7- XC XC At the point XC of the manifold the basis matrix UBXC is assumed XC to be available. The routine evaluates the MDIM by MDIM matrix XC AU = A(XC)*UBXC and computes the singular value decomposition XC XC Q^T * ( (AU)^T ) * P = (S) XC ( G(XC)^T ) (0) XC XC Here Q and P are orthogonal matrices and S is diagonal. XC The MDIM-st row of P is returned as augmentation vector BA. Let XC XC Q e^{MDIM+1} = (a1 ) , Q e^MDIM = (a2 ) XC (omeg1 ) (omeg2 ) XC XC If |omeg1| .ne. 1 then a1 is normalized to length 1 and returned XC as augmentation vector C1, else there is an error return stating XC that an equilibrium point has been reached. XC If (omeg1)^2 + (omeg2)^2 .ne. 1 then a2 is normalized and returned XC as augmentation vector C2, else we repeat the procedure with XC XC Q e^{MDIM-k} = (a* ) XC (omeg* ) XC XC for k = 1,2,...,MDIM-1 until XC XC omeg* .ne. 1 and (omeg1)^2 + (omeg*)^2 .ne. 1. XC XC If no such vector can be found an error return occurs. XC XC Variables in the calling sequence XC --------------------------------- XC AMAT EXT Subroutine for evaluating A XC GF EXT Subroutine for evaluating G XC C1 D OUT Array of dimension MDIM, augmentation vector XC C2 D OUT Array of dimension MDIM, augmentation vector XC BA D OUT Array of dimension MDIM, augmentation vector XC XC D IN Array of dimension NVAR, the current point XC UBXC D IN Array of dimension NVAR x MDIM, basis matrix at XC XC LDU I IN Leading dimension of UBXC, LDU >= NVAR XC AUGMT D WRK Array of dimension (MDIM+1) x MDIM, work array XC for the augmentation matrix XC LDA D IN Leading dimension of AUGMT, LDA >= MDIM+1 XC WRKMAT D WRK Work array of dimension (MDIM+1) x (MDIM+1) XC LDW D IN Leading dimension of WRKMAT, LDW >= MDIM+1 XC IER I OUT Error indicator XC IER = 0 no error, computation was successful, XC IER = -1 error encountered and printed out. XC XC234567--1---------2---------3---------4---------5---------6---------7- XC XC.....Subroutines called: XC X EXTERNAL BIDIA, MSGPRT, SVD XC XC.....Functions called XC X DOUBLE PRECISION DDIST2 XC XC.....Parameters XC X CHARACTER*(*) LNAME X PARAMETER( LNAME = 'SNAUG' ) X DOUBLE PRECISION ZER,ONE,TWO X PARAMETER( ZER=0.0D0, ONE = 1.0D0, TWO=2.0D0 ) XC XC.....Local variables XC X INTEGER I,J,JOB X DOUBLE PRECISION OMEG1,OMEG2,EPS,TMP,WNRM XC XC.....Common block for the statistics variables XC X INTEGER NSTEP,NACCPT,NREJCT,NDER,NMA,NGF,NFF,NDFF X COMMON /STASQ1/NSTEP,NACCPT,NREJCT,NDER,NMA,NGF,NFF,NDFF XC XC.....Common block for machine constants XC X DOUBLE PRECISION EPMACH,SAFMIN X COMMON /MACH/EPMACH,SAFMIN XC XC.....Common block for dimensions XC X INTEGER NVAR,MDIM,MDIP1,NALG,NAUG X COMMON /DIMSQ1/NVAR,MDIM,MDIP1,NALG,NAUG XC XC.......................Executable statements......................... XC XC.....Multiply AMAT by UBXC XC X IF (MDIM .EQ. 1) THEN XC XC........Only one augmentation is needed XC X CALL AMAT(XC,UBXC(1,1),BA,IER) X NMA = NMA + 1 X IF(IER .NE. 0)THEN X CALL MSGPRT(LNAME, X & 'Error in evaluating the coefficient matrix A') X IER = -1 X RETURN X ENDIF X C1(1) = ONE X IF (BA(1) .LT. ZER) C1(1) = -ONE X IER = 0 X RETURN X ENDIF XC XC.....MDIM > 1, two augmentation needed. We store the transpose XC.....of the product A*UBXC in AUGMT XC X DO 20 J = 1,MDIM X CALL AMAT(XC,UBXC(1,J),BA,IER) X NMA = NMA + 1 X IF(IER .NE. 0)THEN X CALL MSGPRT(LNAME, X & 'Error in evaluating the coefficient matrix A') X IER = -1 X RETURN X ENDIF X DO 10 I = 1,MDIM X AUGMT(J,I) = BA(I) X 10 CONTINUE X 20 CONTINUE XC XC.....Add -G(XC) as the next row XC X CALL GF( XC,BA,IER ) X NGF = NGF + 1 X IF (IER .NE. 0)THEN X CALL MSGPRT(LNAME,'Error in evaluating the function G') X IER = -1 X RETURN X ENDIF X DO 30 I = 1,MDIM X AUGMT(MDIP1,I) = -BA(I) X 30 CONTINUE XC XC.....Compute the singular value decomposition of the matrix XC X JOB = 1 X CALL BIDIA( MDIP1,MDIM,AUGMT,LDA,C1,C2, X & WRKMAT,LDW,BA,SAFMIN,JOB,IER ) X IF( IER .NE. 0 )THEN X CALL MSGPRT(LNAME,'Error in bidiagonalizing '// X & 'the augmented matrix' ) X IER = -1 X RETURN X ENDIF X CALL SVD( MDIP1,MDIM,C1,C2,AUGMT,LDA,WRKMAT,LDW, X & EPMACH,SAFMIN,JOB,IER ) X IF(IER .NE. 0) THEN X CALL MSGPRT(LNAME,'Error in the SVD decomposition '// X & 'during augmentation' ) X IER = -1 X RETURN X ENDIF X EPS = TWO*EPMACH*C1(1) XC XC.....Check for more than two numerically zero singular values XC X J = 0 X DO 40 I = MDIM,1,-1 X IF (C1(I) .LT. EPS) J = J + 1 X 40 CONTINUE X IF (J .GT. 2) THEN X CALL MSGPRT(LNAME,'More than two numerically '// X & 'zero singular values') X IER = -1 X RETURN X ENDIF XC XC.....Store the last right-singular vector in BA and the first XC.....MDIM components of the last left singular vector in C1 XC X DO 50 I = 1, MDIM X BA(I) = AUGMT(I,MDIM) X C1(I) = WRKMAT(I,MDIP1) X 50 CONTINUE XC XC.....Normalize C1 XC X WNRM = DDIST2(MDIM,C1,1,C1,1,1) X IF (WNRM .EQ. 0) THEN X CALL MSGPRT(LNAME,'No augmentation vector C1 found') X IER = -1 X RETURN X ENDIF X TMP = ONE/WNRM X DO 60 I = 1,MDIM X C1(I) = TMP*C1(I) X 60 CONTINUE X TMP = WRKMAT(MDIP1,MDIP1) X OMEG1 = TMP*TMP XC XC.....For the augmentation vector C2 loop through the left singular XC.....vectors corresponding to increasingly larger singular values XC X DO 80 J = MDIM,1,-1 X WNRM = DDIST2(MDIM,WRKMAT(1,J),1,WRKMAT(1,J),1,1) X IF (WNRM .NE. 0) THEN X TMP = WRKMAT(MDIP1,J) X OMEG2 = TMP*TMP X IF (OMEG1 + OMEG2 .NE. ONE) THEN X TMP = ONE/WNRM X DO 70 I = 1,MDIM X C2(I) = TMP*WRKMAT(I,J) X 70 CONTINUE X IER = 0 X RETURN X ENDIF X ENDIF X 80 CONTINUE XC XC.....Fall through the loop if no suitable vector C2 was found XC X CALL MSGPRT(LNAME,'No suitable augmentation vector C2 found') X IER = -1 X RETURN XC XC.....End of SNAUG XC X END XC XC234567==1=========2=========3=========4=========5=========6=========7= XC X SUBROUTINE WSTSQ1( LOUT ) XC X INTEGER LOUT XC XC234567--1---------2---------3---------4---------5---------6---------7- XC XC Routine for printing some run statistics for DAESQ1 XC XC Variable in the calling sequence: XC ---------------------------------- XC LOUT I IN Output unit number XC XC234567--1---------2---------3---------4---------5---------6---------7- XC XC.....Common block for the statistics variables XC X INTEGER NSTEP,NACCPT,NREJCT,NDER,NMA,NGF,NFF,NDFF X COMMON /STASQ1/NSTEP,NACCPT,NREJCT,NDER,NMA,NGF,NFF,NDFF XC XC.......................Executable statements......................... XC X WRITE(LOUT,10)NSTEP,NACCPT,NREJCT X 10 FORMAT(1X/' Number of steps: '/ X & ' Total= ',I6,' Accepted= ',I6,' Rejected= ',I6) XC X WRITE(LOUT,20) NDER X 20 FORMAT(' Local ODE evaluations = ',I6) XC X WRITE(LOUT,30) NMA,NGF,NFF,NDFF X 30 FORMAT(' Function calls:'/ X & ' A = ',I6,' G = ',I6,' F = ',I6,' DF = ',I6) XC X RETURN XC XC.....End of WSTSQ1 XC X END XC XC234567==1=========2=========3=========4=========5=========6=========7= SHAR_EOF : || $echo 'restore of' 'daesq1.f' 'failed' fi # ============= daeul3.f ============== if test -f 'daeul3.f' && test "$first_param" != -c; then $echo 'x -' SKIPPING 'daeul3.f' '(file already exists)' else $echo 'x -' extracting 'daeul3.f' '(text)' sed 's/^X//' << 'SHAR_EOF' > 'daeul3.f' && XC234567==1=========2=========3=========4=========5=========6=========7= XC X SUBROUTINE DAEUL3( MMAT,GF,FF,DFF,D2FF,SOLOUT,KU,KA, X & U,UP,T,TOUT,RDATA,IDATA,ATOL,RTOL, X & RWORK,LRW,IWORK,LIW,IER ) XC X EXTERNAL MMAT,GF,FF,DFF,D2FF,SOLOUT XC X INTEGER KU,KA,LRW,LIW,IER X INTEGER IDATA(10),IWORK(LIW) XC X DOUBLE PRECISION U(*),UP(*),T,TOUT X DOUBLE PRECISION ATOL,RTOL,RDATA(10),RWORK(LRW) XC XC234567--1---------2---------3---------4---------5---------6---------7- XC Originally written by W. Rheinboldt, June 7, 1993 XC Last revision February 23, 1996 XC234567--1---------2---------3---------4---------5---------6---------7- XC XC DAe solver for the EUler Lagrange problem of index 3 XC XC M(u,t)u" + D_uF(u,t)^T w = G(u,u',t) XC F(u,t) = 0 XC XC subject to the consistent initial conditions XC XC u(t0) = u0, u'(t0) = up0, F(u0,t0) = 0 XC XC where D_uF(u,t)^T is the transpose of the derivative F with XC respect to u. XC XC Here dim u = KU, dim w = KA, dim rge M = dim rge G = KU, XC dim rge F = KA, and rank D_uF(u,t) = KA. XC XC It is assumed that rank D_xF(x,t) = KA and XC XC v^T M(u,t) v .ne. 0, for all v in ker D_uF(u,t) XC XC for all (u,t) under consideration such that F(u,t) = 0. XC XC The algorithm developed in XC XC P. Rabier and W. Rheinboldt, XC Numerical Solution of Euler-Lagrange Equations for XC Constrained Mechanical Systems XC SIAM J. Num. Anal. 32, 1995, 318-329 XC XC is used and the reduced system is solved by the Dormand-Prince XC Runge Kutta method of order 5. XC XC This routine assumes that the second derivative of F is XC available explicitly and uses this to compute the second XC fundamental tensor. XC XC Link with a driver, MANPAK and MANAUX XC XC We use the notation XC XC NVAR = dimension of the ambient space: NVAR = KU+1 XC NALG = number of algebraic equations: NALG = KA XC MDIM = dimension of the manifold: MDIM = NVAR-NALG XC = KU-KA+1 XC XC Variables in the calling sequence: XC ---------------------------------- XC MMAT EXT Subroutine for evaluating M, see below. XC GF EXT Subroutine for evaluating G, see below. XC FF EXT Subroutine for evaluating F, see below. XC DFF EXT Subroutine for evaluating the Jacobian of F, XC see below. XC D2FF EXT Subroutine for evaluating the second derivative XC of F, see below. XC SOLOUT EXT Subroutine for intermediate output, see below. XC KU I IN Dimension of U. XC KA I IN Number of algebraic equations. XC U D IN Array of dimension KU, the starting point XC D OUT The final point XC UP D IN Array of dimension KU, the starting direction XC OUT The final direction XC T D IN Initial time XC D OUT Final time XC TOUT D IN Desired stopping time XC RDATA D IN Data array of dimension 10 XC RDATA(1) = H Suggested step XC Default H = 1.0D3*RTOL(1) XC RDATA(2) = HMIN Requested minimal step XC Default HMIN = 1.0D1*EPMACH XC RDATA(3) = HMAX Requested maximal step XC Default HMAX = ABS(TOUT-T) XC IDATA I IN Data array of dimension 10 XC IDATA(1) = NMAX Requested maximal number of steps XC Default NMAX = 10,000 XC IDATA(2) = JPOL Interpolation indicator XC JPOL = 0 No interpolation XC JPOL = 1 Interpolate XC Default JPOL = 0 XC IDATA(3) = MID Indicator for the KD x KU mass XC matrix M(X): XC MID = 0 M is given by MMAT XC MID = 1 M = (I, 0) where I is XC the KD x KD identity XC Default MID = 0 XC ATOL D IN Absolute error tolerance XC RTOL D IN Relative error tolerance XC RWORK D WK Work array of dimension LRW. XC LRW I IN Dimension of RWORK at least equal to XC KU*(4*KU+48) - 28*KA + 44 XC IWORK I WK Work array of dimension LIW. XC LIW I IN Dimension of IWORK at least equal to 2*KU+2. XC IER I OUT Error indicator: XC IER = 1 -- successful computation interrupted XC by SOLOUT, XC IER = 0 -- no error, computation was successful, XC IER = -1 -- error encountered and printed out. XC XC External Subroutines XC -------------------- XC The user should supply subroutines for the computation of the XC coefficient functions M, G, F, and the first and second XC derivative of F, as well as, for the printout of intermediate XC results. The required calling sequences are as follows: XC XC 1. Subroutine for the mass matrix M(X) XC ----------------------------------- XC XC SUBROUTINE MMAT(U,T,V,MV,IER) XC XC INTEGER IER XC DOUBLE PRECISION U(*),T,V(*),MV(*) XC XC MMAT calculates the KA-dimensional product vector MV = M(U,T)*V XC This subroutine is not called when MID = IDATA(4) = 1. XC In that case, provide only a dummy routine. XC XC Variables in the calling sequence: XC ---------------------------------- XC U D IN Array of dimension KU, the current point. XC T D IN Current time XC V D IN Array of dimension KU, given vector. XC MV D OUT Array of dimension KU, the product M(U,T)*V. XC IER I OUT Error indicator: XC IER = 0 no error. XC IER = -1 error in MMAT XC XC 2. Subroutine for evaluating G XC --------------------------- XC XC SUBROUTINE GF(U,UP,T,GV,IER) XC XC INTEGER IER XC DOUBLE PRECISION U(*),UP(*),T,GV(*) XC XC To compute the KD dimensional vector GV = G(U, YP, T) XC XC Variables in the calling sequence: XC ---------------------------------- XC U D IN Array of dimension KU, the current point. XC UP D IN Array of dimension KU, the current direction XC T D IN Current time XC GV D OUT Array of dimension KU, the vector G(U,UP,T). XC IER I OUT Error indicator: XC IER = 0 no error. XC IER =-1 error in GF. XC XC 3. Subroutine for evaluating F XC --------------------------- XC XC SUBROUTINE FF(U,T,FV,IER) XC XC INTEGER IER XC DOUBLE PRECISION U(*), T, FV(*) XC XC To compute the KA dimensional vector FV = F(U, T) XC XC Variables in the calling sequence: XC ---------------------------------- XC U D IN Array of dimension KU, the current point. XC T T IN Current time XC FV D OUT The computed vector FV = F(U,T). XC IER I OUT Error indicator: XC IER = 0 no error. XC IER =-1 error in FF. XC XC 4. Subroutine for evaluating the Jacobian DF XC ----------------------------------------- XC XC SUBROUTINE DFF(U,T,DFV,LDF,IER) XC XC INTEGER LDF,IER XC DOUBLE PRECISION U(*),T,DFV(LDF,*) XC XC To compute the KA x NVAR array DFV = DF(U, T) XC XC Variables in the calling sequence: XC ---------------------------------- XC U D IN Array of dimension KU, the current point. XC T T IN Current time XC DFV D OUT Array of dimension KA x NVAR for the XC Jacobian of F. Let Fk denote the k-th XC component of F. Then the k-th row of DFV XC should contain the vector XC XC ( d/dU(1) Fk , .... , d/dU(KU) Fk, d/dT Fk ) XC XC of the NVAR partial derivatives of Fk XC LDF I IN Leading dimension of DFV, LDF >= KA XC IER I OUT Error indicator: XC IER = 0 no error. XC IER =-1 error in DFF. XC XC XC 5. Subroutine for second derivative terms of F XC ------------------------------------------- XC XC SUBROUTINE D2FF(U,T,V,D2FV,IER) XC XC INTEGER IER XC DOUBLE PRECISION U(*),V(*),D2FV(*) XC XC To compute the KA dimensional vector D2F(U,T)(V,V) XC with a given NVAR vector V XC XC Variables in the calling sequence: XC ---------------------------------- XC U D IN Array of dimension KU, the current point. XC T T IN The current time XC V D IN Array of dimension NVAR, the direction vector. XC D2FV D OUT Array of dimension NALG, the output vector XC D2FV = D2F(U)(V,V). XC IER I OUT Error indicator: XC IER = 0 no error. XC IER =-1 error in D2FF. XC XC 6. Subroutine for intermediate output XC ---------------------------------- XC XC SUBROUTINE SOLOUT(TASK,JPOL,NPT,U,UP,T,TLAST,TNEXT) XC XC CHARACTER*6 TASK XC INTEGER NPT,JPOL XC DOUBLE PRECISION U(*),T,UP(*),TLAST,TNEXT XC XC SOLOUT writes the solution at given points XC XC Variables in the calling sequence: XC ---------------------------------- XC TASK C IN Task identifier XC TASK = 'START' Print starting point and header XC if desired XC TASK = 'FINAL' Print final point XC TASK = 'PRNT' New computed point for printout XC TASK = 'INTP' Interpolated point is given XC OUT TASK = 'INTP' Request interpolation at time XC TINT in the interval between XC TLAST and T. XC TASK = 'PRNT' Continue with the integration XC TASK = 'STOP' Requests the integration to stop XC NPT I IN Current point counter XC U D IN Current vector U XC UP D IN Current vector UP XC T D IN Current time XC TLAST D IN The previous time XC TINT D OUT Time where interpolation is requested. XC XC 7. Subroutine for error-output units XC ---------------------------------- XC XC SUBROUTINE ERROUT(KL, LOUT) XC XC INTEGER KL, LOUT(*) XC XC Function to supply KL output-unit numbers for use by XC by the message routine MSGPRT XC XC Variables in the calling sequence XC --------------------------------- XC KL I OUT Number of different output units to be used XC by MSGPRT. For KL <= 0 and KL > 5 all printout XC by MSGPRT is suppressed. XC LOUT I OUT Array of dimension KL, 1 <= KL<= 5, for the XC KL output-units to be used by MSGPRT. XC XC234567--1---------2---------3---------4---------5---------6---------7- XC XC.....Subroutines called: XC X EXTERNAL DRVEUL,MSGPRT XC XC.....Functions called XC X DOUBLE PRECISION ABS,SQRT XC XC.....Parameters XC X INTEGER NMXDEF X PARAMETER( NMXDEF = 10000 ) X DOUBLE PRECISION ONE, ZER X PARAMETER( ONE=1.0D0, ZER= 0.D0 ) X CHARACTER*(*) LNAME X PARAMETER( LNAME = 'DAEUL3') XC XC.....Local variables XC X INTEGER I,K,LIEN,LREN X DOUBLE PRECISION ATOLA(1),RTOLA(1) X CHARACTER*6 CHAR,TASK XC XC.....Variables saved between calls XC X INTEGER NCALL,LXC,LDXC,LUBXC,LDFXC,LAUGMT,LXN,LDXN,LUBXN,LDFXN X INTEGER LXPR,LDXPR,LY,LYP,LUIN,LW0,LW1,LW2,LW3,LW4,LW5,LW6 X INTEGER LWKMAT,LWRK1,LWRK2,LWRK3,LJPAUG,LIWRK X SAVE NCALL,LXC,LDXC,LUBXC,LDFXC,LAUGMT,LXN,LDXN,LUBXN,LDFXN, X & LXPR,LDXPR,LY,LYP,LUIN,LW0,LW1,LW2,LW3,LW4,LW5,LW6, X & LWKMAT,LWRK1,LWRK2,LWRK3,LJPAUG,LIWRK XC XC.....Common block for machine constants XC X DOUBLE PRECISION EPMACH,SAFMIN X COMMON /MACH/EPMACH,SAFMIN XC XC.....Common block for data XC X INTEGER NMAX,JPOL,MID X DOUBLE PRECISION H,HMIN,HMAX,POSNEG X COMMON /DATEUL/H,HMIN,HMAX,POSNEG,NMAX,JPOL,MID XC XC.....Common block for the statistics variables XC X INTEGER NSTEP,NACCPT,NREJCT,NDER,NMAT,NGF,NFF,NDFF,ND2FF X COMMON /STAEUL/NSTEP,NACCPT,NREJCT,NDER,NMAT,NGF,NFF,NDFF,ND2FF XC XC.....Common block for dimensions XC X INTEGER NVAR,NALG,MDIM,MDIM2,NVAR2 X COMMON /DIMEUL/NVAR,NALG,MDIM,MDIM2,NVAR2 XC X DATA NCALL/0/ XC XC.......................Executable statements......................... XC XC.....At first call check dimensions, set pointers into work XC.....arrays and check for insufficient storage. XC.....(These are data that depend only on the problem XC.....but not on a specific trajectory) XC X IF(NCALL .EQ. 0) THEN X NCALL = 1 X NVAR = KU + 1 X NALG = KA X MDIM = NVAR - NALG X MDIM2 = MDIM + MDIM X NVAR2 = NVAR + NVAR XC XC........Set machine constant XC X CALL DMACH( EPMACH,SAFMIN ) XC XC........Check data and set defaults XC X IER = -1 X IF( NVAR .LT. 2 ) THEN X CALL MSGPRT(LNAME,'The ambient space must be at '// X & 'least two-dimensional') X RETURN X ENDIF X IF( MDIM .LT. 1 )THEN X CALL MSGPRT(LNAME,'The manifold must be at least '// X & 'one-dimensional') X RETURN X ENDIF XC XC Set pointers into RWORK XC X LXC = 1 X LDXC = LXC + NVAR X LY = LDXC + NVAR X LYP = LY + MDIM2 X LUBXC = LYP + MDIM2 X LDFXC = LUBXC + NVAR*MDIM X LAUGMT = LDFXC + NALG*NVAR XC X LXN = LAUGMT + NVAR*NVAR X LDXN = LXN + NVAR X LUBXN = LDXN + NVAR X LDFXN = LUBXN + NVAR*MDIM XC X LXPR = LDFXN + NALG*NVAR X LDXPR = LXPR + NVAR X LUIN = LDXPR + NVAR XC X LW0 = LUIN + 5*MDIM2 X LW1 = LW0 + MDIM2 X LW2 = LW1 + MDIM2 X LW3 = LW2 + MDIM2 X LW4 = LW3 + MDIM2 X LW5 = LW4 + MDIM2 X LW6 = LW5 + MDIM2 XC X LWKMAT = LW6 + MDIM2 X LWRK1 = LWKMAT + NVAR*NVAR X LWRK2 = LWRK1 + NVAR2 X LWRK3 = LWRK2 + NVAR2 X LREN = LWRK3 + NVAR2 - 1 XC XC........Check for sufficient RWORK XC X IF(LREN .GT. LRW) THEN X WRITE (CHAR,10) LREN X 10 FORMAT(I5) X CALL MSGPRT(LNAME, X & 'RWORK must have at least dimension '//CHAR) X RETURN X ENDIF XC XC........Set pointers into IWORK XC X LJPAUG = 1 X LIWRK = LJPAUG + NVAR X LIEN = LIWRK + NVAR - 1 XC XC........Check for sufficient IWORK XC X IF(LIEN .GT. LIW) THEN X WRITE (CHAR,10) LIEN X CALL MSGPRT(LNAME, X & 'IWORK must have at least dimension '//CHAR) X RETURN X ENDIF X ENDIF XC XC.....Now set the data that depend on the specific trajectory XC X POSNEG = ONE X IF (TOUT .LT. T) POSNEG = -POSNEG X HMIN = RDATA(2) X IF (HMIN .LE. ZER) HMIN = SQRT(EPMACH) X HMAX = RDATA(3) X IF (HMAX .EQ. ZER) HMAX = ABS(TOUT - T) X IF (HMAX .LT. ZER) HMAX = -HMAX X H = RDATA(1) X IF( POSNEG*H .LT. ZER ) H = -H X IF (H .EQ. ZER) H = POSNEG*SQRT(DBLE(MDIM)) XC X ATOLA(1) = ATOL X RTOLA(1) = RTOL XC X NMAX = IDATA(1) X IF (NMAX .LE. 0 ) NMAX = NMXDEF X JPOL = IDATA(2) X IF (JPOL .NE. 1) JPOL = 0 X MID = IDATA(3) X IF( (MID .LT. 0) .OR. (MID .GT. 1) ) MID = 0 XC XC.....Initialize counters XC X NSTEP = 0 X NACCPT = 0 X NREJCT = 0 X NMAT = 0 X NGF = 0 X NFF = 0 X NDFF = 0 X ND2FF = 0 XC XC.....Copy the initial point XC X K = NVAR X RWORK(K) = T X DO 20 I = 1, KU X K = K + 1 X RWORK(I) = U(I) X RWORK(K) = UP(I) X 20 CONTINUE X RWORK(NVAR) = T X RWORK(K + 1) = ONE XC XC.....Call the Runge-Kutta driver XC X CALL DRVEUL( MMAT,GF,FF,DFF,D2FF,SOLOUT,TOUT,ATOLA,RTOLA, X & RWORK(LXC),RWORK(LDXC),RWORK(LY),RWORK(LYP), X & RWORK(LUBXC),NVAR,RWORK(LDFXC),NALG, X & RWORK(LAUGMT),NVAR,IWORK(LJPAUG),RWORK(LXN), X & RWORK(LDXN),RWORK(LUBXN),RWORK(LDFXN),RWORK(LXPR), X & RWORK(LDXPR),RWORK(LUIN),RWORK(LW0),RWORK(LW1), X & RWORK(LW2),RWORK(LW3),RWORK(LW4),RWORK(LW5), X & RWORK(LW6),RWORK(LWKMAT),NVAR,IWORK(LIWRK), X & RWORK(LWRK1),RWORK(LWRK2),RWORK(LWRK3),IER) XC XC.....Test for error condition and then return XC X IF (IER .NE. 0) CALL MSGPRT(LNAME, X & 'Error return from the RK-step driver') XC XC.....Reset the point XC X K = NVAR X T = RWORK(K) X DO 30 I = 1, KU X K = K + 1 X U(I) = RWORK(I) X UP(I) = RWORK(K) X 30 CONTINUE XC XC.....Print final point XC X TASK = 'FINAL' X CALL SOLOUT(TASK,JPOL,NACCPT,U,UP,T,T,T) XC X RETURN XC XC.....End of DAEUL3 XC X END XC XC234567==1=========2=========3=========4=========5=========6=========7= XC X SUBROUTINE DRVEUL( MMAT,GF,FF,DFF,D2FF,SOLOUT, X & TOUT,ATOLA,RTOLA,XC,DXC,Y,YP, X & UBXC,LDU,DFXC,LDF,AUGMT,LDA,JPAUG, X & XN,DXN,UBXN,DFXN,XPRT,DXPRT,UINT, X & W0,W1,W2,W3,W4,W5,W6,WRKMAT,LDW, X & IWRK,WRK1,WRK2,WRK3,IER ) XC X EXTERNAL MMAT,GF,FF,DFF,D2FF,SOLOUT XC X INTEGER LDA,LDF,LDU,LDW,JPAUG(*),IWRK(*),IER XC X DOUBLE PRECISION TOUT,ATOLA(*),RTOLA(*) X DOUBLE PRECISION XC(*),DXC(*),Y(*),YP(*) X DOUBLE PRECISION UBXC(LDU,*),DFXC(LDF,*),AUGMT(LDA,*) X DOUBLE PRECISION XN(*),DXN(*),UBXN(LDU,*),DFXN(LDF,*) X DOUBLE PRECISION XPRT(*),DXPRT(*),UINT(5,*) X DOUBLE PRECISION W0(*),W1(*),W2(*),W3(*),W4(*),W5(*),W6(*) X DOUBLE PRECISION WRKMAT(LDW,*),WRK1(*),WRK2(*),WRK3(*) XC XC234567--1---------2---------3---------4---------5---------6---------7- XC XC This is a driver for the RK step routine DOPSTN. It continues XC the integration until either NMAX steps have been taken or XC until T = TOUT has been reached. XC XC A new local system is constructed at each step. XC XC Variables in the calling sequence: XC ---------------------------------- XC MMAT EXT Subroutine for evaluating M XC GF EXT Subroutine for evaluating G XC FF EXT Subroutine for evaluating F XC DFF EXT Subroutine for evaluating the Jacobian of F XC D2FF EXT Subroutine for evaluating the second derivative of F XC SOLOUT EXT Subroutine for intermediate output XC TOUT D IN Desired stopping time XC ATOLA D IN Array of dimension 1, the absolute error tolerance XC RTOLA D IN Array of dimension 1, the relative error tolerance XC XC D IN Initial point (U,T) XC OUT Final point (U,T) XC DXC D IN Initial direction (UP,1) XC OUT Final direction (UP,1) XC Y D WK Array of dimension MDIM2 for a point in local XC coordinates on the manifold XC YP D WK Array of dimension MDIM2 for the direction in XC local coordinates at Y XC UBXC D OUT Array of dimension LDU x MDIM for the basis matrix XC at XC XC LDU I IN Leading dimension of UBXC, LDU >= NVAR XC DFXC D WK Array of dimension LDF x NVAR for DF(XC) XC LDF I IN Leading dimension of DFXC, LDF >= NALG XC AUGMT D WK Array of dimension LDA x MDIM for the augmented XC matrix at XC and its decomposition XC LDA I IN Leading dimension of AUGMT, LDA >= NVAR XC JPAUG I IN Pivot array for the LU-factorization of AUGMT XC XN D WK Intermediate point XC DXN D WK Intermediate direction XC UBXN D OUT Array of dimension LDU x MDIM for the basis matrix XC at XN XC DFXN D WK Array of dimension LDF x NVAR for DF(XN) XC XPRT D WK Array of dimension NVAR, point to be printed XC DXPRT D WK Array of dimension NVAR, direction to be printed XC UINT D WK Array of dimension 5*MDIM for use in interpolation XC W0-W6 D WK Seven work arrays of dimension MDIM2 XC WRKMAT D WK Work array of dimension LDW X MDIM XC LDW I IN Leading dimension of WRKMAT, LDW >= MDIM XC IWRK I Wk Work array of dimension NVAR XC WRK1 D WK Work array of dimension NVAR XC WRK2 D WK Work array of dimension NVAR XC WRK3 D WK Work array of dimension NVAR XC IER I OUT error indicator XC IER = 1 computation successful XC but interrupted by SOLOUT XC IER = 0 no error, computation was successful XC IER = -1 other error encountered and printed out XC XC234567--1---------2---------3---------4---------5---------6---------7- XC XC.....Subroutines called: XC X EXTERNAL AUGM,DYEUL,DOPSTN,GNBAS,INTEUL,MSGPRT,ORIENT XC XC.....Local Variables XC X INTEGER I,J X DOUBLE PRECISION SUM,T,TLAST,TLOC,TLOCL,TMP,TNEXT,TPRT X CHARACTER*6 TASK,POINT X CHARACTER*5 CHAR1, CHAR2 X LOGICAL ICFLAG,LAST XC XC.....Parameters XC X INTEGER ITOL X DOUBLE PRECISION TFACT,ZER,ONE X PARAMETER( ITOL=0, TFACT=1.01D0, ZER=0.0D0, ONE=1.0D0 ) X CHARACTER*(*) LNAME X PARAMETER( LNAME = 'DRVEUL' ) XC XC.....Common block for machine constants XC X DOUBLE PRECISION EPMACH,SAFMIN X COMMON /MACH/EPMACH,SAFMIN XC XC.....Common block for data XC X INTEGER NMAX,JPOL,MID X DOUBLE PRECISION H,HMIN,HMAX,POSNEG X COMMON /DATEUL/H,HMIN,HMAX,POSNEG,NMAX,JPOL,MID XC XC.....Common block for the statistics variables XC X INTEGER NSTEP,NACCPT,NREJCT,NDER,NMAT,NGF,NFF,NDFF,ND2FF X COMMON /STAEUL/NSTEP,NACCPT,NREJCT,NDER,NMAT,NGF,NFF,NDFF,ND2FF XC XC.....Common block for dimensions XC X INTEGER NVAR,NALG,MDIM,MDIM2,NVAR2 X COMMON /DIMEUL/NVAR,NALG,MDIM,MDIM2,NVAR2 XC XC.......................Executable statements......................... XC XC.....Get the Jacobian at XC and retain in DFXC XC X T = XC(NVAR) X CALL DFF( XC,T,DFXC,LDF,IER ) X NDFF = NDFF + 1 X IF(IER .NE. 0)THEN X CALL MSGPRT(LNAME,'Error in evaluating the Jacobian') X IER = -1 X RETURN X ENDIF XC XC.....Copy XC into XN and copy the Jacobian into AUGMT XC X DO 30 J = 1,NVAR X XN(J) = XC(J) X DXN(J) = DXC(J) X DO 20 I = 1,NALG X AUGMT(I,J) = DFXC(I,J) X 20 CONTINUE X 30 CONTINUE XC XC.....Compute the basis matrix UBXC XC X CALL GNBAS( NVAR,MDIM,UBXC,LDU,DFXC,LDF, X & WRK1,WRK2,IWRK,SAFMIN,IER ) X IF(IER .NE. 0) THEN X CALL MSGPRT( LNAME,'Basis construction failed '// X & 'at the starting point' ) X IER = -1 X RETURN X ENDIF XC XC.....Use AUGM to establish the full data structure at XC XC X CALL AUGM(NVAR,MDIM,AUGMT,LDA,UBXC,LDU,JPAUG,IER) X IF (IER .NE. 0) THEN X CALL MSGPRT(LNAME,'Numerically singular augmented matrix') X IER = -1 X RETURN X ENDIF XC XC.....Write out starting point XC X TASK = 'START' X CALL SOLOUT(TASK,JPOL,NACCPT,XC,DXC,T,T,T) X IF (TASK .EQ. 'STOP') THEN X CALL MSGPRT (LNAME,'Interruption by SOLOUT, '// X & 'computation terminated') X IER = 0 X RETURN X ENDIF XC XC.....Loop point for accepted steps XC X 100 CONTINUE XC XC.....Check if we are close to the terminal value of T XC X POINT = 'NEWPT' X LAST = .FALSE. X IF ( POSNEG*(T + TFACT*H - TOUT) .GT. ZER ) THEN X H = TOUT - T X LAST = .TRUE. X TLOCL = H X ENDIF XC XC.....Save the current time XC X TLAST = T XC XC.....We always start with the local coordinate Y = 0 XC.....and the projected DXC XC X DO 120 I = 1,MDIM X SUM = ZER X DO 110 J =1,NVAR X SUM = SUM + UBXC(J,I)*DXC(J) X 110 CONTINUE X Y(I) = ZER X Y(MDIM+I) = SUM X 120 CONTINUE X Y(MDIM2) = ONE X TLOC = ZER XC XC.....Call the derivative routine XC X TASK = 'STEP' X 150 CONTINUE X CALL DYEUL( POINT,MMAT,GF,FF,DFF,D2FF,Y,YP, X & XC,DXC,UBXC,LDU,AUGMT,LDA,JPAUG, X & XN,DXN,DFXN,LDF,UBXN,WRKMAT,LDW,IWRK, X & WRK1,WRK2,WRK3,IER ) X NDER = NDER + 1 X IF (IER .NE. 0) THEN X IF (IER .GT. 0 .AND. TASK .EQ. 'EVAL') THEN X TASK = 'REDUCE' X ELSE X CALL MSGPRT (LNAME, X & 'Error in evaluating the local ODE') X IER = -1 X RETURN X ENDIF X ENDIF XC XC.....Call the step routine XC X CALL DOPSTN(TASK,MDIM2,TLOC,Y,YP,H,HMIN,HMAX,NMAX, X & ATOLA,RTOLA,ITOL,W0,W1,W2,W3,W4,W5,W6, X & JPOL,UINT,NSTEP,NACCPT,NREJCT) X IF (TASK .EQ. 'EVAL') THEN X POINT = 'NXTPT' X GOTO 150 X ELSEIF (TASK .EQ. 'DONE') THEN X GOTO 200 X ELSEIF (TASK .EQ. 'STPCNT') THEN X WRITE (CHAR1,160) NSTEP X WRITE (CHAR2,160) NMAX X 160 FORMAT(I5) X CALL MSGPRT (LNAME,'Step count '//CHAR1//' exceeds ' X & //'given maximum NMAX= '//CHAR2) X IER = -2 X RETURN X ELSEIF ( TASK .EQ. 'MINSTP' ) THEN X CALL MSGPRT (LNAME,'Step fell below HMIN') X IER = -3 X RETURN X ELSE X CALL MSGPRT (LNAME,'Error return from the RK-routine') X IER = -1 X RETURN X ENDIF XC X 200 CONTINUE X IF( LAST .AND. (TLOC .NE. TLOCL) )LAST = .FALSE. XC X TASK = 'PRNT' X TNEXT = XN(NVAR) X TPRT = TNEXT X ICFLAG = .TRUE. X CALL SOLOUT(TASK,JPOL,NACCPT,XN,DXN,TPRT,TLAST,TNEXT) XC X 220 CONTINUE X IF (TASK .EQ. 'PRNT') THEN X GOTO 300 X ELSEIF (TASK .EQ. 'STOP') THEN X CALL MSGPRT (LNAME,'Interruption by SOLOUT, '// X & 'computation terminated') X IER = 0 X RETURN X ELSEIF (TASK .EQ. 'INTP') THEN XC XC........Interpolation is requested XC........If this is the first time, copy the current point XC X IF( ICFLAG )THEN X DO 230 I = 1,NVAR X XPRT(I) = XN(I) X DXPRT(I) = DXN(I) X 230 CONTINUE X ICFLAG = .FALSE. X ENDIF X CALL INTEUL( FF,DFF,TLAST,TNEXT,TPRT,UINT,XPRT,DXPRT, X & XC,DXC,UBXC,LDU,AUGMT,LDA,JPAUG, X & WRKMAT,LDW,WRK1,WRK2,WRK3,IWRK,IER ) X IF (IER .NE. 0) THEN X CALL MSGPRT (LNAME,'Error in interpolation -- proceed') X GOTO 300 X ENDIF XC XC........Write out the interpolated solution XC X CALL SOLOUT(TASK,JPOL,NACCPT,XPRT,DXPRT,TPRT,TLAST,TNEXT) X GOTO 220 X ELSE X CALL MSGPRT (LNAME, X & 'SOLOUT returns unknown value of TASK -- proceed') X ENDIF XC XC.....Check for further action XC X 300 CONTINUE XC XC.....Copy XN, DXN into XC, DXC XC X DO 310 I = 1,NVAR X XC(I) = XN(I) X DXC(I) = DXN(I) X 310 CONTINUE X T = XC(NVAR) XC XC.....If this was the last step return XC X IF( LAST ) THEN X IER = 0 X RETURN X ENDIF XC XC.....Store DFXN into AUGMT and DFXC XC X DO 330 J = 1,NVAR X DO 320 I = 1,NALG X TMP = DFXN(I,J) X DFXC(I,J) = TMP X AUGMT(I,J) = TMP X 320 CONTINUE X 330 CONTINUE XC XC.....Establish the full data structure at XN in AUGMT XC X CALL AUGM(NVAR,MDIM,AUGMT,LDA,UBXN,LDU,JPAUG,IER) X IF (IER .NE. 0) THEN X CALL MSGPRT(LNAME,'Numerically singular augmented matrix') X IER = -1 X RETURN X ENDIF XC XC.....Move basis from UBXN to UBXC XC X DO 350 J = 1,MDIM X DO 340 I = 1,NVAR X UBXC(I,J) = UBXN(I,J) X 340 CONTINUE X 350 CONTINUE XC XC.....Normal exit XC X IF (.NOT. LAST) GOTO 100 X IER = 0 XC X RETURN XC XC.....End of DRVEUL XC X END XC XC234567==1=========2=========3=========4=========5=========6=========7= XC X SUBROUTINE DYEUL( POINT,MMAT,GF,FF,DFF,D2FF,Y,YP, X & XC,DXC,UBXC,LDU,AUGMT,LDA,JPAUG, X & XN,DXN,DFXN,LDF,UBXN,WRKMAT,LDW,IWRK, X & WRK1,WRK2,WRK3,IER ) XC X EXTERNAL MMAT,GF,FF,DFF,D2FF X CHARACTER*6 POINT XC X INTEGER IER,LDA,LDF,LDU,LDW X INTEGER JPAUG(*),IWRK(*) XC X DOUBLE PRECISION Y(*),YP(*),XC(*),DXC(*),XN(*),DXN(*) X DOUBLE PRECISION UBXC(LDU,*),AUGMT(LDA,*) X DOUBLE PRECISION DFXN(LDF,*),UBXN(LDU,*) X DOUBLE PRECISION WRKMAT(LDW,*),WRK1(*),WRK2(*),WRK3(*) XC XC234567--1---------2---------3---------4---------5---------6---------7-C XC Subroutine for evaluating, for given y = (u,v), the right side XC of the second order local ODE XC XC yp = (v, k(u,v)) XC XC Variables in the calling sequence: XC ---------------------------------- XC POINT C IN Point indicator XC POINT = 'NEWPT', the global point is XN = XC XC POINT = 'NXTPT', compute the next global point XN XC MMAT EXT Subroutine for evaluating M XC GF EXT Subroutine for evaluating G XC FF EXT Subroutine for evaluating F XC DFF EXT Subroutine for evaluating the Jacobian of F, XC D2FF EXT Subroutine for evaluating the second XC derivative of F XC Y D IN array of dimension 2*MDIM, vector Y = (U,V) XC in local coordinates XC YP D OUT array of dimension 2*MDIM, derivative of the XC point in local coordinates XC XC D IN Array of dimension NVAR, the center point of XC the local cordinate system in global coord. XC DXC D IN Array of dimension NVAR, the direction at XC XC UBXC D IN Array of dimension LDU x MDIM for the basis matrix XC basis matrix at XC XC LDU I IN Leading dimension of UBXC and UBXN, LDU >= NVAR XC AUGMT D IN Array of dimension LDA x NVAR, the LU decomposed XC augmented matrix at XC XC LDA I IN Leading dimension of AUGMT, LDA >= NVAR XC JPAUG I IN Array of dimension NVAR for the pivot array of XC AUGMT at XC XC XN D OUT Array of dimension NVAR, the next point in XC global coordinates XC DXN D IN Array of dimension NVAR, the direction at XN XC DFXN D OUT Array of dimension LDF x NVAR for the XC Jacobian at XN XC LDF I IN Leading dimension of DFXN, LDF >= NALG XC UBXN D IN Array of dimension LDU x MDIM for the basis matrix XC basis matrix at XN XC WRKMAT D WK Work array of dimension LDW x MDIM XC LDW I IN Leading dimension of WRKMAT, LDW >= MDIM XC WRK1 I Wk Work array of dimension NVAR XC WRK2 D WK Work array of dimension NVAR XC WRK3 D WK Work array of dimension NVAR XC IER I OUT error indicator XC IER = 1 correctable error -- steplength too XC large -- no printout from MSGPRT XC IER = 0 no error XC IER = -1 fatal error, printout from MSGPRT XC XC234567--1---------2---------3---------4---------5---------6---------7-C XC.....Subroutines called: XC X EXTERNAL EVXEUL,LUF,LUS1,MSGPRT,TSFT XC XC.....Local variables XC X INTEGER I,ICOPY,J,K X DOUBLE PRECISION DUM(1,1),FTMX,SUM,TMP X CHARACTER*6 TASK X LOGICAL YFLAG XC XC.....Parameters XC X DOUBLE PRECISION ZER, ONE X PARAMETER( ZER=0.0D0, ONE=1.0D0 ) X CHARACTER*6 LNAME X PARAMETER( LNAME = 'DYEUL') XC XC.....Common block for machine constant XC X DOUBLE PRECISION EPMACH,SAFMIN X COMMON /MACH/EPMACH,SAFMIN XC XC.....Common block for data XC X INTEGER NMAX,JPOL,MID X DOUBLE PRECISION H,HMIN,HMAX,POSNEG X COMMON /DATEUL/H,HMIN,HMAX,POSNEG,NMAX,JPOL,MID XC XC.....Common block for the statistics variables XC X INTEGER NSTEP,NACCPT,NREJCT,NDER,NMAT,NGF,NFF,NDFF,ND2FF X COMMON /STAEUL/NSTEP,NACCPT,NREJCT,NDER,NMAT,NGF,NFF,NDFF,ND2FF XC XC.....Common block for dimensions XC X INTEGER NVAR,NALG,MDIM,MDIM2,NVAR2 X COMMON /DIMEUL/NVAR,NALG,MDIM,MDIM2,NVAR2 XC XC.......................Executable statements......................... XC X YFLAG = POINT.EQ.'NEWPT' XC X IF( YFLAG )THEN XC XC........Evaluate the fundamental tensor XC X CALL D2FF( XC,XC(NVAR),DXC,WRK1,IER ) X ND2FF = ND2FF + 1 X IF (IER .NE. 0) THEN X CALL MSGPRT(LNAME, X & 'Error in evaluating the second derivative of F') X IER = -1 X RETURN X ENDIF XC XC........Use D2GPHI to obtain the tensor component XC X TASK = 'EVAL' X CALL D2GPHI( TASK,NVAR,MDIM,WRK1,FTMX,AUGMT,LDA, X & DUM,1,JPAUG,IER ) X IF(IER .NE. 0)THEN X CALL MSGPRT(LNAME, X & 'Error in evaluating the second fundaental tensor') X IER = -1 X RETURN X ENDIF XC X ELSE XC XC........We are not at the first point, determine XN XC X ICOPY = 1 X CALL EVXEUL( FF,DFF,Y,XN,DXN,WRK1,XC,DXC,UBXC,LDU, X & AUGMT,LDA,JPAUG,WRKMAT,LDW,IWRK, X & DFXN,LDF,ICOPY,WRK2,IER ) X IF( IER .NE. 0 ) THEN X IF( IER .GT. 0 ) THEN X IER = 1 X ELSE X CALL MSGPRT( LNAME,' Error return from EVXEUL' ) X IER = -1 X ENDIF X RETURN X ENDIF XC XC........Copy the Jacobian at XN into WRKMAT XC X DO 20 J = 1,NVAR X DO 10 I = 1,NALG X WRKMAT(I,J) = DFXN(I,J) X 10 CONTINUE X 20 CONTINUE XC XC........Construct the basis UBXN XC X CALL GNBAS(NVAR,MDIM,UBXN,LDU,WRKMAT,LDW, X & WRK1,WRK2,IWRK,SAFMIN,IER) X IF(IER .NE. 0) THEN X CALL MSGPRT(LNAME, X & 'Basis construction failed at the new point') X IER = -1 X RETURN X ENDIF XC XC........Copy the Jacobian at XN again into WRKMAT and compute UBXN XC X DO 40 J = 1,NVAR X DO 30 I = 1,NALG X WRKMAT(I,J) = DFXN(I,J) X 30 CONTINUE X 40 CONTINUE XC XC........Evaluate the fundamental tensor XC X CALL D2FF( XN,XN(NVAR),DXN,WRK1,IER ) X ND2FF = ND2FF + 1 X IF (IER .NE. 0) THEN X CALL MSGPRT(LNAME, X & 'Error in evaluating the second derivative of F') X IER = -1 X RETURN X ENDIF X TASK = 'FACTOR' X CALL D2GPHI( TASK,NVAR,MDIM,WRK1,FTMX,WRKMAT,LDW, X & UBXN,LDU,IWRK,IER ) X IF(IER .NE. 0)THEN X CALL MSGPRT(LNAME, X & 'Error in evaluating the second fundamental tensor') X IER = -1 X RETURN X ENDIF XC X ENDIF XC XC.....Evaluate G into WRK3 XC X CALL GF( XN,DXN,XN(NVAR),WRK3,IER ) X NGF = NGF + 1 X IF (IER .NE. 0) THEN X CALL MSGPRT(LNAME,'Error in evaluating the function G') X IER = -1 X RETURN X ENDIF X WRK3(NVAR) = ZER XC XC.....Evaluate WRK3 - M(XN)*WRK1 XC X IF (FTMX .NE. 0) THEN X IF (MID .EQ. 0) THEN X IF( YFLAG )THEN X CALL MMAT (XC,XC(NVAR),WRK1,WRK2,IER) X ELSE X CALL MMAT (XN,XN(NVAR),WRK1,WRK2,IER) X ENDIF X NMAT = NMAT + 1 X IF(IER .NE. 0)THEN X CALL MSGPRT(LNAME,'Error in evaluating the mass matrix') X IER = -1 X RETURN X ENDIF X WRK2(NVAR) = ZER X DO 110 I = 1,NVAR X WRK3(I) = WRK3(I) - WRK2(I) X 110 CONTINUE X ELSE X DO 120 I = 1,NVAR X WRK3(I) = WRK3(I) - WRK1(I) X 120 CONTINUE X ENDIF X ENDIF XC XC.....Evaluate YP(1:mdim) = U^T*WRK3 XC X DO 140 J = 1,MDIM X SUM = ZER X DO 130 I = 1,NVAR X IF ( YFLAG ) THEN X TMP = UBXC(I,J) X ELSE X TMP = UBXN(I,J) X ENDIF X SUM = SUM + TMP*WRK3(I) X 130 CONTINUE X YP(J) = SUM X 140 CONTINUE XC XC.....If the mass matrix is not the identity then evaluate XC.....the "localized" mass matrix U^T M U XC X IF (MID .EQ. 0) THEN X DO 180 K = 1,MDIM X IF ( YFLAG ) THEN X CALL MMAT (XC,XC(NVAR),UBXC(1,K),WRK3,IER) X ELSE X CALL MMAT (XN,XN(NVAR),UBXN(1,K),WRK3,IER) X ENDIF X NMAT = NMAT + 1 X IF(IER .NE. 0)THEN X CALL MSGPRT(LNAME,'Error in evaluating the mass matrix') X IER = -1 X RETURN X ENDIF X WRK3(NVAR) = ZER X IF( K .EQ. MDIM )WRK3(NVAR) = ONE X DO 170 J = 1,MDIM X SUM = ZER X DO 160 I = 1,NVAR X IF ( YFLAG ) THEN X SUM = SUM + UBXC(I,J)*WRK3(I) X ELSE X SUM = SUM + UBXN(I,J)*WRK3(I) X ENDIF X 160 CONTINUE X WRKMAT(J,K) = SUM X 170 CONTINUE X 180 CONTINUE XC XC........Solve the system with the localized mass matrix and XC........YP(1:MDIM) as right hand vector XC X CALL LUF( MDIM,WRKMAT,LDW,IWRK,IER ) X CALL LUS1( MDIM,WRKMAT,LDW,IWRK,YP,IER ) X IF (IER .NE. 0) THEN X CALL MSGPRT(LNAME,'Singular local mass matrix') X IER = -1 X RETURN X ENDIF X ENDIF XC XC.....Compute the corresponding tangent vector and add to the XC.....fundamental tensor XC X DO 200 I = 1,NVAR X SUM = ZER X DO 190 J = 1,MDIM X IF ( YFLAG ) THEN X SUM = SUM + UBXC(I,J)*YP(J) X ELSE X SUM = SUM + UBXN(I,J)*YP(J) X ENDIF X 190 CONTINUE X IF (FTMX .NE. 0) THEN X WRK3(I) = WRK1(I) + SUM X ELSE X WRK3(I) = SUM X ENDIF X 200 CONTINUE XC XC.....Localize the result again and prepare the final YP XC X DO 220 J = 1,MDIM X YP(J) = Y(MDIM+J) X SUM = ZER X DO 210 I = 1,NVAR X SUM = SUM + UBXC(I,J)*WRK3(I) X 210 CONTINUE X YP(MDIM+J) = SUM X 220 CONTINUE X YP(MDIM2) = ZER XC X IER = 0 X RETURN XC XC.....End of DYEUL XC X END XC XC234567==1=========2=========3=========4=========5=========6=======7= XC X SUBROUTINE INTEUL( FF,DFF,TLAST,TNEXT,TINT,UINT,XINT,DXINT, X & XC,DXC,UBXC,LDU,AUGMT,LDA,JPAUG, X & WRKMAT,LDW,WRK1,WRK2,WRK3,IWRK,IER ) XC X EXTERNAL FF,DFF XC X INTEGER LDA,LDU,LDW,IER,IWRK(*),JPAUG(*) X DOUBLE PRECISION TLAST,TNEXT,TINT,UINT(5,*) X DOUBLE PRECISION XINT(*),DXINT(*),XC(*),DXC(*) X DOUBLE PRECISION UBXC(LDU,*),AUGMT(LDA,*) X DOUBLE PRECISION WRKMAT(LDW,*),WRK1(*),WRK2(*),WRK3(*) XC XC234567--1---------2---------3---------4---------5---------6---------7- XC XC Routine for interpolating between computed points when XC intermediate output is desired. XC XC Variables in the calling sequence: XC ---------------------------------- XC FF EXT Subroutine for evaluating the function F XC DFF EXT Subroutine for evaluating the Jacobian of F XC TLAST D IN The last time XC TNEXT D IN The next time XC TINT D IN The time where output is desired. TOUT must XC be between TLAST and TNEXT XC UINT D IN Interpolation array of dimension 5 * MDIM computed XC by DOPSTN for the step from TLAST to TNEXT XC XINT D OUT Array of dimension NVAR, interpolated global point XC DXINT D OUT Array of dimension NVAR, interpolated XC global direction at XINT XC XC D IN Array of dimension NVAR, center point of the XC local coordinate system XC DXC D IN Array of dimension NVAR, global direction at XC X XC UBXC D IN Array of dimension LDU x MDIM for the basis XC matrix at XC XC LDU I IN Leading dimension of UBXC, LDU >= NVAR XC AUGMT D WK Array of dimension LDF x NVAR for the XC augmented matrix at XC and its decomposition. XC LDA I IN Leading dimension of AUGMT, LDA >= NVAR XC JPAUG I WK Array of dimension of dimension NVAR for the XC pivot array used in the decomposition of AUGMT XC WRKMAT D WK Work array of dimension LDW x NVAR XC LDW I IN Leading dimension of WRKMAT, LDW >= NALG XC WRK1 XC -WRK3 D WK Three work arrays of dimension NVAR XC IWRK I WK Work array of dimension NALG XC IER I OUT Error indicator XC IER = 0 No error XC IER = -1 TINT was not between TLAST and TNEXT XC IER = -2 Projection onto the manifold failed XC XC234567--1---------2---------3---------4---------5---------6---------7- XC XC.....Subroutines called XC X EXTERNAL EVXEUL,MSGPRT XC XC.....Local variables XC X INTEGER I,ICOPY X DOUBLE PRECISION DUM(1,1), HT, ONE, ZER, S X CHARACTER*6 LNAME X PARAMETER( LNAME = 'INTEUL' ) XC X PARAMETER( ONE=1.0D0, ZER=0.0D0 ) XC XC.....Common block for dimensions XC X INTEGER NVAR,NALG,MDIM,MDIM2,NVAR2 X COMMON /DIMEUL/NVAR,NALG,MDIM,MDIM2,NVAR2 XC XC.......................Executable statements......................... XC XC.....Get effective step and check for TINT between TLAST and TNEXT XC X HT = TNEXT - TLAST X S = (TINT - TLAST)/HT X IF( (S .LT. ZER) .OR. (S .GT. ONE) ) THEN X CALL MSGPRT (LNAME,' Interpolation requested outside'// X & ' last integration interval') X IER = -1 X RETURN X ENDIF XC XC.....Evaluate the interpolation polynomial at S to get YINT XC X DO 10 I = 1,MDIM2 X WRK1(I) = UINT(1,I) + HT*S*(UINT(2,I) + S*(UINT(3,I) X & + S*(UINT(4,I) + S*UINT(5,I)))) X 10 CONTINUE X WRK1(MDIM) = HT*S X WRK1(MDIM2) = ONE XC X ICOPY = 0 X CALL EVXEUL( FF,DFF,WRK1,XINT,DXINT,WRK2, X & XC,DXC,UBXC,LDU,AUGMT,LDA,JPAUG, X & WRKMAT,LDW,IWRK,DUM,1,ICOPY,WRK3,IER ) X IF( IER .NE. 0 ) THEN X CALL MSGPRT( LNAME,' Error return from EVXEUL' ) X IER = -1 X RETURN X ENDIF X TINT = XINT(NVAR) XC X IER = 0 X RETURN XC XC.....End of INTEUL XC X END XC XC234567==1=========2=========3=========4=========5=========6=========7= XC X SUBROUTINE EVXEUL( FF,DFF,Y,X,DX,FX,XC,DXC,UBXC,LDU, X & AUGMT,LDA,JPAUG,WRKMAT,LDW,IWRK, X & DFMAT,LDF,ICOPY,WRK,IER ) XC X EXTERNAL FF,DFF XC X INTEGER IER,ICOPY,LDA,LDF,LDU,LDW X INTEGER IWRK(*),JPAUG(*) XC X DOUBLE PRECISION Y(*),X(*),DX(*),FX(*) X DOUBLE PRECISION XC(*),DXC(*),UBXC(LDU,*),AUGMT(LDA,*) X DOUBLE PRECISION WRKMAT(LDW,*),DFMAT(LDF,*),WRK(*) XC XC234567--1---------2---------3---------4---------5---------6---------7- XC XC For a given local point Y in the local coordinate system defined XC at XC with the basis UBXC, the subroutine evaluates the XC corresponding global point X and the derivative Dphi(Y) of the XC local parametrization. XC XC Variables in the calling sequence: XC ---------------------------------- XC FF EXT Subroutine for evaluating F XC DFF EXT Subroutine for evaluating the Jacobian of F XC Y D IN Array of dimension MDIM2, the local vector XC X D OUT Array of dimension NVAR, the corresponding XC global vector (U, T) XC DX D OUT Array of dimension NVAR, the global direction at X XC FX D OUT The function value at X XC XC D IN Array of dimension NVAR, the center point of XC the local cordinate system in global coordinates XC DXC D IN Array of dimension NVAR, the global direction at XC XC UBXC D IN Array of dimension LDU x MDIM for the basis matrix XC basis matrix at XC XC LDU I IN Leading dimension of UBXC and UBXN, LDU >= NVAR XC AUGMT D IN Array of dimension LDA x NVAR for the XC augmented matrix at XC and its decomposition XC LDA I IN Leading dimension of AUGMT, LDA >= NVAR XC JPAUG I IN Array of dimension NALG for the pivot array of XC the LQ factorization of DF(XC) XC WRKMAT D WK Work array of dimension LDW x NVAR XC LDW I IN Leading dimension of WRKMAT, LDW >= NALG XC IWRK I WK Work array of dimension NALG XC DFMAT D OUT Array of dimension LDF x NVAR, which for ICOPY = 1 XC will retain a copy of the Jacobian at X XC For ICOPY = 0 the array is not referenced XC LDF I IN Leading dimension of DFMAT, LDF >= NALG XC ICOPY I IN Copy indicator XC ICOPY = 0 the array DFMAT is not referenced XC ICOPY = 1 a copy of the Jacobian at X is XC returned in DFMAT XC WRK D WK Work array of dimension NVAR XC IER I OUT error indicator XC IER = 1 correctable error -- ||Y|| is too XC large for convergence of phi. XC -- no printout from MSGPRT XC IER = 0 no error XC IER = -1 fatal error, printout from MSGPRT XC XC234567--1---------2---------3---------4---------5---------6---------7- XC XC.....Subroutines called: XC X EXTERNAL GPHI,DGPHI,MSGPRT XC XC.....Parameters XC X DOUBLE PRECISION ONE,ZER X PARAMETER( ONE=1.0D0, ZER=0.0D0 ) X CHARACTER*(*) LNAME X PARAMETER( LNAME = 'EVXEUL') XC XC.....Local variables XC X INTEGER I,ISTEP,J,K X DOUBLE PRECISION DIR,DYK X CHARACTER*6 TASK XC XC.....Common block for machine constant XC X DOUBLE PRECISION EPMACH,SAFMIN X COMMON /MACH/EPMACH,SAFMIN XC XC.....Common block for the statistics variables XC X INTEGER NSTEP,NACCPT,NREJCT,NDER,NMAT,NGF,NFF,NDFF,ND2FF X COMMON /STAEUL/NSTEP,NACCPT,NREJCT,NDER,NMAT,NGF,NFF,NDFF,ND2FF XC XC.....Common block for dimensions XC X INTEGER NVAR,NALG,MDIM,MDIM2,NVAR2 X COMMON /DIMEUL/NVAR,NALG,MDIM,MDIM2,NVAR2 XC XC.......................Executable statements......................... XC X TASK = 'START' XC X 10 CONTINUE X CALL GPHI( TASK,NVAR,MDIM,Y,X,FX,XC,UBXC,LDU, X & AUGMT,LDA,JPAUG,EPMACH,ISTEP ) X IF( TASK .EQ. 'EVAL' )THEN X CALL FF( X,X(NVAR),FX,IER ) X NFF = NFF + 1 X IF( IER .NE. 0 )THEN X CALL MSGPRT( LNAME,'Error in evaluating the function F' ) X IER = -1 X RETURN X ENDIF X GOTO 10 X ELSEIF( TASK .EQ. 'DONE' )THEN X GOTO 20 X ELSEIF( TASK .EQ. 'DIVERG' .OR. TASK .EQ. 'STPCNT' )THEN X IER = 1 X RETURN X ELSE X CALL MSGPRT( LNAME, X & ' Error in computing the local parametrization' ) X IER = -1 X RETURN X ENDIF XC X 20 CONTINUE XC XC.....Get Jacobian of F at X and store in WRKMAT XC X CALL DFF( X,X(NVAR),WRKMAT,LDW,IER ) X NDFF = NDFF + 1 X IF( IER .NE. 0 )THEN X CALL MSGPRT( LNAME,' Error in evaluating the Jacobian' ) X IER = -1 X RETURN X ENDIF XC XC.....If desired, retain a copy of the Jacobian in DFMAT XC X IF( ICOPY .NE. 0 )THEN X DO 40 J = 1,NVAR X DO 30 I = 1,NALG X DFMAT(I,J) = WRKMAT(I,J) X 30 CONTINUE X 40 CONTINUE X ENDIF XC XC.....Compute DX XC X CALL AUGM(NVAR,MDIM,WRKMAT,LDW,UBXC,LDU,IWRK,IER) X IF (IER .NE. 0) THEN X CALL MSGPRT(LNAME,'Numerically singular augmented matrix') X IER = -1 X RETURN X ENDIF XC X Y(MDIM2) = ONE X DO 70 K = 1, MDIM X DYK = Y(MDIM+K) X DO 50 I = 1,NVAR X WRK(I) = ZER X IF( K .EQ. 1 )DX(I) = ZER X 50 CONTINUE X WRK(NALG+K) = ONE X CALL LUS1( NVAR,WRKMAT,LDW,IWRK,WRK,IER ) X DO 60 I = 1,NVAR X DX(I) = DX(I) + WRK(I)*DYK X 60 CONTINUE X 70 CONTINUE X DIR = ZER X DO 80 I = 1,NVAR X DIR = DIR + DX(I)*DXC(I) X 80 CONTINUE XC XC.....Align DX with DXC XC X IF( DIR .LT. ZER )THEN X DO 90 I = 1,NVAR X DX(I) = -DX(I) X 90 CONTINUE X ENDIF XC X IER = 0 X RETURN XC XC.....End of EVXEUL XC X END XC XC234567==1=========2=========3=========4=========5=========6=========7= XC X SUBROUTINE WSTEUL( LOUT ) XC X INTEGER LOUT XC XC234567--1---------2---------3---------4---------5---------6---------7- XC XC Routine for printing some run statistics for DAEUL3 XC XC Variable in the calling sequence: XC ---------------------------------- XC LOUT I IN Output unit number XC XC234567--1---------2---------3---------4---------5---------6---------7- XC XC.....Common block for the statistics variables XC X INTEGER NSTEP,NACCPT,NREJCT,NDER,NMAT,NGF,NFF,NDFF,ND2FF X COMMON /STAEUL/NSTEP,NACCPT,NREJCT,NDER,NMAT,NGF,NFF,NDFF,ND2FF XC XC.......................Executable statements......................... XC X WRITE(LOUT,10)NSTEP,NACCPT,NREJCT X 10 FORMAT(1X/' Number of steps: '/ X & ' Total= ',I6,' Accepted= ',I6,' Rejected= ',I6) XC X WRITE(LOUT,20) NDER X 20 FORMAT(' Local ODE evaluations = ',I6) XC X WRITE(LOUT,30) NMAT,NGF,NFF,NDFF,ND2FF X 30 FORMAT(' Function calls:'/ X & ' M = ',I6,' G = ',I6,' F = ',I6/ X & ' DF = ',I6,' D2F = ',I6) XC X RETURN XC XC.....End of WSTEUL XC X END XC XC234567==1=========2=========3=========4=========5=========6=========7= SHAR_EOF : || $echo 'restore of' 'daeul3.f' 'failed' fi rm -fr _sh02128 exit 0