C ALGORITHM 690, COLLECTED ALGORITHMS FROM ACM. C THIS WORK PUBLISHED IN TRANSACTIONS ON MATHEMATICAL SOFTWARE, C VOL. 17, NO. 2, PP. 178-206. JUNE, 1991. c c file containg example programs and PDECHEB software. c c This file contains c example problem 1 c example problem 2 c example problem 3 c example problem 4 c example problem 5 c dassl time integration routine c pdecheb spatial discretisation routine c interface to AND the linpack full and banded routines c c C C0 COLLOCATION PARAMETERS PARAMETER ( IBK = 21, NEL = IBK-1 , NPDE = 1, NV = 1, 1 NPOLY = 2, NPTS = NEL*NPOLY+1, NXI = 1, 2 NEQ = NPTS * NPDE + NV, 3 NWKRES= (NPOLY+1) * (5*NXI + 3*NPOLY+NEL+5+7*NPDE) + 4 NPDE * 8 + 3 + NV + NXI, C DDASSL TIME INTEGRATION PARAMETERS 5 MAXORD = 5, LRW = 40 + (MAXORD+4) * NEQ + NEQ**2, 6 LIW = 20 + NEQ ) C INTEGER IWORK(LIW), INFO(15), IBAND, M, ITIME, I, IDID, IRESWK, 1 IDEV, ITRACE DOUBLE PRECISION XBK(IBK), X(NPTS), Y(NEQ), YDOT(NEQ), 1 WKRES(NWKRES), RWORK(LRW), XI(1), T, TOUT, RTOL, ATOL, 2 ENORM, GERR, VERROR, CTIME, TOL EXTERNAL PDECHB, DGEJAC COMMON /SDEV2/ ITRACE, IDEV COMMON /PROB1/ TOL TOL = 0.1D-5/50.D0 C N.B. CPU TIMER COMMENTED OUT FOR PORTABILITY C CALL TIMER( CTIME, 1) M = 0 T = TOL IDEV = 4 ITRACE = 1 WRITE(IDEV,9)NPOLY, NEL 9 FORMAT(' TEST PROBLEM 1'/' ***********'/' POLY OF DEGREE =',I4, 1 ' NO OF ELEMENTS = ',I4) XI(1) = 1.0D0 DO 10 I = 1,IBK 10 XBK(I) = (I-1.0D0)/(IBK-1.0D0) C INITIALISE THE P.D.E. WORKSPACE ITIME = 1 CALL INICHB(NEQ, NPDE, NPTS, X, Y, WKRES, NWKRES, M, T, IBAND, 1 ITIME, XBK, IBK, NEL, NPOLY, NV, NXI, XI, IDEV) IF(ITIME .EQ. -1)THEN WRITE(IDEV, 15) 15 FORMAT(' INITCC ROUTINE RETURNED ITIME = -1 - RUN HALTED ') GOTO 100 END IF C SETUP DASSL PARAMETERS RTOL = TOL ATOL = TOL DO 20 I = 1,11 20 INFO(I) = 0 C C BANDED MATRIX OPTION WHEN INFO(6) = 1 IF(INFO(6) .EQ. 1)THEN IWORK(1) = IBAND IWORK(2) = IBAND END IF 30 TOUT = T * 10.0D0 IF(TOUT .GE. 2.D0)TOUT =2.0D0 CALL DDASSL( PDECHB, NEQ, T, Y, YDOT, TOUT, INFO, RTOL, ATOL, 1 IDID, RWORK, LRW, IWORK, LIW, WKRES, IRESWK, DGEJAC) IF( IDID .LT. 0 )THEN C DASSL FAILED TO FINISH INTEGRATION. WRITE(IDEV,40)T,IDID 40 FORMAT(' AT TIME T = ',D11.3,' DASSL RETURNED IDID =',I3) GOTO 100 ELSE C DASSL INTEGRATED TO T = TOUT C CALL TO POST PROCESSING HERE E.G. SPACE INTERPOLATION. ITRACE = 1 CALL ERROR( Y, NPDE, NPTS, X, M, ENORM, GERR, T, RTOL, ATOL, 1 ITRACE, WKRES, NWKRES) ITRACE = 0 VERROR = Y(NEQ) - T WRITE(IDEV,50)Y(NEQ),VERROR 50 FORMAT(' MOVING BOUNDARY IS AT ',D12.4,' WITH ERROR=',D12.4) IF(TOUT .LT. 1.99D0 ) GOTO 30 END IF 100 CONTINUE C CALL TIMER(CTIME, 2) WRITE(IDEV,110)IWORK(11),IWORK(12),IWORK(13), CTIME 110 FORMAT(' NSTEPS =',I5,' NRESID =',I5,' JAC = ',I4,' CPU=',D11.3) STOP END C********************************************************************** C EXAMPLE PROBLEM 1 C SOLUTION OF MOVING BOUNDARY PROBLEM BY CO-ORDINATE TRANSFORMATION. C******************************************************************** C THIS PROBLEM IS THE ONE PHASE STEFAN PROBLEM (HOFFMAN (1977) ) SEE C FURZELAND R.M. A COMPARATIVE STUDY OF NUMERICAL METHODS FOR MOVING C BOUNDARY PROBLEMS. J.I.M.A. (1977) ,26, PP 411 - 429. C THE PROBLEM HAS MELTING DUE TO HEAT INPUT AT THE FIXED C BOUNDARY . THE P.D.E. IS DEFINED BY THE EQUATIONS C U = U 0 < Y < S(T) , 0.1 < T < 1 C T YY C U = - EXP(T) , Y = 0 C Y . C U = 0 AND S(T) = - U ON THE MOVING BOUNDARY Y = S(T). C Y C AND THE INITIAL SOLUTION VALUES AT T = 0.1 ARE GIVEN BY THE ANALYTIC C SOLUTION C U = EXP(T-Y) - 1 , S(T) = T. C THE PROBLEM IS REWRITTEN BY USING THE CO-ORDINATE TRANSFORMATION C GIVEN BY X(T) = Y / S(T) . THE EQUATIONS THEN READ C . C S * S * U - S * S * X * U = U , X IN (0,1). C T X XX C WITH THE NEUMANN TYPE BOUNDARY CONDITIONS C . C U = - EXP(T) AT X=0 AND U = - S(T) * S(T) AT X = 1 C X X C AND THE O.D.E. COUPLING POINT EQUATION AT X = 1 WHICH IMPLICITLY C DEFINES S(T) IS GIVEN BY C U(1,T) = 0 C THE EXACT SOLUTION IS NOW DEFINED BY C U(X,T) = EXP((T - X*S(T)) , S(T) = T C C WE SHALL NOW DETAIL THE ROUTINES NEEDED TO DESCRIBE THIS PROBLEM. C PROBLEM DESCRIPTION ROUTINES C ****************************** C EXACT SOLUTION SUBROUTINE EXACT( TIME, NPDE, NPTS, X, U) C ROUTINE FOR P.D.E. EXACT VALUES (IF KNOWN) INTEGER NPDE, NPTS DOUBLE PRECISION X(NPTS), U(NPDE,NPTS), TIME DO 10 I = 1,NPTS 10 U(1,I) = DEXP( TIME * (1 - X(I))) - 1.0D0 RETURN END SUBROUTINE UVINIT( NPDE, NPTS, X, U, NV, V) C ROUTINE FOR O.D.E. AND P.D.E. INITIAL VALUES. INTEGER NPDE, NPTS, NV DOUBLE PRECISION X(NPTS), U(NPDE,NPTS), TIME, V(NV) COMMON /PROB1/ TOL TIME= TOL V(1)= TOL CALL EXACT(TIME,NPDE,NPTS,X,U) RETURN END C SUBROUTINE SPDEFN(T, X, NPTL, NPDE, U, DUDX, UDOT, UTDX, Q, R, 1 NV, V, VDOT, IRES) C PROBLEM INTERFACE FOR THE MOVING BOUNDARY PROBLEM. INTEGER NPTL, NPDE, NV, I, IRES DOUBLE PRECISION X(NPTL), U(NPDE,NPTL), DUDX(NPDE,NPTL), T, 1 V(1), VDOT(1), Q(NPDE,NPTL) ,R(NPDE,NPTL), 2 UDOT(NPDE,NPTL), UTDX(NPDE,NPTL) DO 10 I = 1,NPTL R(1,I) = DUDX(1,I) Q(1,I) = V(1)*V(1)*UDOT(1,I) -X(I)*VDOT(1)*DUDX(1,I) * V(1) 10 CONTINUE RETURN END SUBROUTINE SBNDR( T, BETA, GAMMA, U, UX, UDOT, UTDX, NPDE, 1 LEFT, NV, V, VDOT, IRES) C THIS SUBROUTINE PROVIDES THE LEFT AND RIGHT BOUNDARY VALUES C FOR THE MOVING BOUNDARY PROBLEM IN THE FORM. C BETA(I) * DU/DX(I) = GAMMA(I) C WHERE I = 1,NPDE AND GAMMA IS A FUNCTION OF U,X AND T C INTEGER NPDE, NV, IRES LOGICAL LEFT DOUBLE PRECISION BETA(NPDE), GAMMA(NPDE), U(NPDE), UX(NPDE) - ,T, V(1), VDOT(1), UDOT(NPDE), UTDX(NPDE) BETA(1) = 1.0D0 IF(LEFT)THEN GAMMA(1) = -V(1)*DEXP(T) ELSE GAMMA(1) = -V(1)*VDOT(1) END IF RETURN END C SUBROUTINE SODEFN(T, NV, V, VDOT, NPDE, NXI, XI, UI, UXI, RI, 1 UTI, UTXI, VRES, IRES) C ROUTINE TO PROVIDE RESIDUAL OF COUPLED ODE SYSTEM FOR THE C MOVING BOUNDARY PROBLEM. C NOTE HOW IRES CAN BE RESET TO COPE WIH ILLEGAL VALUES OF THE C MOVING BOUNDARY POSITION V(1). INTEGER NPDE, NXI, NV, IRES DOUBLE PRECISION T, XI(NXI), UI(NPDE,NXI), UXI(NPDE,NXI), 1 RI(NPDE,NXI), UTI(NPDE,NXI), UTXI(NPDE,NXI), VRES(NV), 2 V(NV), VDOT(NV) VRES(1) = UI(1,1) IF(V(1) .LT. 0.0D0)IRES = -1 RETURN END C C0 COLLOCATION PARAMETERS PARAMETER ( IBK = 2, NEL = IBK-1 , NPDE = 1, NV = 0, 1 NPOLY = 10, NPTS = NEL*NPOLY+1, NXI = 0, 2 NEQ = NPTS * NPDE + NV, C C NWKRES= 2*(NPOLY+1)*(NPOLY+NEL+2) + 2 + NV + 3 NWKRES= (NPOLY+1) * (5*NXI + 3*NPOLY+NEL+5+7*NPDE) + 4 NPDE * 8 + 3 + NV + NXI, C C NPDE * (7 * (NPOLY+1+NXI) + 8), C DDASSL TIME INTEGRATION PARAMETERS 5 MAXORD = 5, LRW = 40 + (MAXORD+4) * NEQ + NEQ**2, 6 LIW = 20 + NEQ ) C INTEGER IWORK(LIW), INFO(15), IBAND, M, ITIME, I, IDID, IRESWK, 1 IDEV, ITRACE DOUBLE PRECISION XBK(IBK), X(NPTS), Y(NEQ), YDOT(NEQ), 1 WKRES(NWKRES), RWORK(LRW), XI(1), T, TOUT, RTOL, ATOL, 2 ENORM, GERR, CTIME EXTERNAL PDECHB, DGEJAC COMMON /SDEV2/ ITRACE, IDEV C CPU TIMER COMMENTED OUT FOR PORTABILITY C CALL TIMER(CTIME ,1) M = 2 T = 0.0D0 IDEV = 4 ITRACE = 1 WRITE(IDEV,9)NPOLY, NEL 9 FORMAT(' TEST PROBLEM 1'/' ***********'/' POLY OF DEGREE =',I4, 1 ' NO OF ELEMENTS = ',I4) DO 10 I = 1,IBK 10 XBK(I) = (I-1.0D0) / (IBK - 1.0D0) C INITIALISE THE P.D.E. WORKSPACE ITIME = 1 CALL INICHB(NEQ, NPDE, NPTS, X, Y, WKRES, NWKRES, M, T, IBAND, 1 ITIME, XBK, IBK, NEL, NPOLY, NV, NXI, XI, IDEV) IF(ITIME .EQ. -1)THEN WRITE(IDEV, 15) 15 FORMAT(' INITCC ROUTINE RETURNED ITIME = -1 - RUN HALTED ') GOTO 100 END IF C SETUP DASSL PARAMETERS RTOL = 1.0D-8 ATOL = 1.0D-8 DO 20 I = 1,11 20 INFO(I) = 0 C INFO(11)= 1 C BANDED MATRIX OPTION WHEN INFO(6) = 1 IF(INFO(6) .EQ. 1)THEN IWORK(1) = IBAND IWORK(2) = IBAND END IF 30 TOUT = T + 0.1D0 CALL DDASSL( PDECHB, NEQ, T, Y, YDOT, TOUT, INFO, RTOL, ATOL, 1 IDID, RWORK, LRW, IWORK, LIW, WKRES, IRESWK, DGEJAC) IF( IDID .LT. 0 )THEN C DASSL FAILED TO FINISH INTEGRATION. WRITE(IDEV,40)T,IDID 40 FORMAT(' AT TIME T = ',D11.3,' DASSL RETURNED IDID =',I3) GOTO 100 ELSE C DASSL INTEGRATED TO T = TOUT C CALL TO POST PROCESSING HERE E.G. SPACE INTERPOLATION. CALL ERROR( Y, NPDE, NPTS, X, M, ENORM, GERR, T, RTOL, ATOL, 1 ITRACE, WKRES, NWKRES) IF(TOUT .LT. 0.99D0 ) GOTO 30 END IF 100 CONTINUE C CALL TIMER(CTIME, 2) WRITE(IDEV,110)IWORK(11),IWORK(12),IWORK(13), CTIME 110 FORMAT(' NSTEPS =',I5,' NRESID =',I5,' JAC = ',I4,' CPU=',D11.3) STOP END C EXAMPLE PROBLEM TWO C ******************** C THIS PROBLEM IS DEFINED BY C -2 2 2 C U U = X ( X U U ) + 5 U + 4 X U U , X IN (0,1) C T X X X C C THE LEFT BOUNDARY CONDITION AT X = 0 (LEFT = .TRUE. ) IS GIVEN BY C U (0,T) = 0.0 C X C THE RIGHT BOUNDARY CONDITION IS (LEFT = .FALSE.) C U( 1,T) = EXP ( -T ) C C THE INITIAL CONDITION IS GIVEN BY THE EXACT SOLUTION ; C U( X, T ) = EXP ( 1 - X*X - T ) , X IN ( 0,1) C 2 C********************************************************************** SUBROUTINE UVINIT( NPDE, NPTS, X, U, NV,V) C ROUTINE FOR P.D.E. INITIAL VALUES. INTEGER NPDE, NPTS, NV DOUBLE PRECISION X(NPTS), U(NPDE,NPTS), V(1), T T = 0.0D0 C V(1) IS A DUMMY VARIABLE AS THERE ARE NO COUPLED O.D.E.S CALL EXACT( T, NPDE, NPTS, X, U ) RETURN END C SUBROUTINE SPDEFN( T, X, NPTL, NPDE, U, DUDX, UDOT, UTDX, Q, R, 1 NV, V, VDOT, IRES) C ROUTINE TO DESCRIBE THE BODY OF THE P.D.E. C THE P.D.E. IS WRITEN AS -M M C Q(X,T,U, U , U , U ) = X (X R(X,T,U,U , U , U )) C X T TX X T TX X C THE FUNCTIONS Q AND R MUST BE DEFINED IN THIS ROUTINE. C DEFINITIONS FOR THE MODEL PROBLEM ARE GIVEN C NOTE NV = 0 : THERE IS NO O.D.E PART. INTEGER NPDE, NPTL, I, J, NV, IRES DOUBLE PRECISION T, X(NPTL), U(NPDE,NPTL), DUDX(NPDE,NPTL), 1 UDOT(NPDE,NPTL), Q(NPDE,NPTL), R(NPDE,NPTL), V, VDOT, 2 UTDX(NPDE,NPTL) DO 10 I = 1,NPTL R(1,I) = U(1,I) * DUDX(1,I) Q(1,I) = U(1,I) * UDOT(1,I) - 5.0D0 * U(1,I)**2 1 - 4.0D0 * U(1,I)*DUDX(1,I)*X(I) 10 CONTINUE RETURN END C SUBROUTINE SBNDR( T, BETA, GAMMA, U, UX, UDOT, UTDX, NPDE, LEFT, 1 NV, V, VDOT, IRES) C BOUNDARY CONDITIONS ROUTINE INTEGER NPDE, NV, IRES DOUBLE PRECISION T, BETA(NPDE), GAMMA(NPDE), U(NPDE), C2, 1 UX(NPDE), V, VDOT, UDOT(NPDE), UTDX(NPDE) LOGICAL LEFT IF(LEFT) THEN BETA (1) = 1.0D0 GAMMA(1) = 0.0D0 ELSE C BETA (1) = 0.0D0 C GAMMA(1) = U(1) - DEXP( -T ) BETA (1) = 1.0D0 GAMMA(1) = - 2.D0 *U(1)**2 END IF RETURN END C C DUMMY O.D.E. ROUTINE AS NV IS ZERO SUBROUTINE SODEFN RETURN END C EXACT SOLUTION SUBROUTINE EXACT( TIME, NPDE, NPTS, X, U) C ROUTINE FOR P.D.E. EXACT VALUES (IF KNOWN) INTEGER NPDE, NPTS, I DOUBLE PRECISION X(NPTS), U(NPDE,NPTS), TIME DO 10 I = 1,NPTS 10 U(1,I) = DEXP( 1.0D0 - X(I)**2 - TIME) RETURN END c problem 3 C C0 COLLOCATION PARAMETERS PARAMETER ( IBK = 3, NEL = IBK-1 , NPDE = 1, NV = 0, 1 NPOLY = 6, NPTS = NEL*NPOLY+1, NXI = 0, 2 NEQ = NPTS * NPDE + NV, 3 NWKRES= (NPOLY+1) * (5*NXI + 3*NPOLY+NEL+5+7*NPDE) + 4 NPDE * 8 + 3 + NV + NXI, C 3 NWKRES= 2*(NPOLY+1)*(NPOLY+NEL+2) + 2 + NV + C 4 NPDE * (7 * (NPOLY+1+NXI) + 8), C DDASSL TIME INTEGRATION PARAMETERS 5 MAXORD = 5, LRW = 40 + (MAXORD+4) * NEQ + NEQ**2, 6 LIW = 20 + NEQ ) C INTEGER IWORK(LIW), INFO(15), IBAND, M, ITIME, I, IDID, IRESWK, 1 IDEV, ITRACE, IDERIV, IFL, ITYPE DOUBLE PRECISION XBK(IBK), X(NPTS), Y(NEQ), YDOT(NEQ), Z(NPTS), 1 WKRES(NWKRES), RWORK(LRW), XI(1), T, TOUT, RTOL, ATOL, 2 ENORM, GERR, CTIME, DYDX(NEQ), DYCALC(NPDE,NPTS,2) EXTERNAL PDECHB, DGEJAC COMMON /SDEV2/ ITRACE, IDEV COMMON /PROB3/IDERIV C CPU TIMER COMMENTED OUT FOR PORTABILITY. C CALL TIMER ( CTIME, 1) M = 0 T = 0.0D0 IDEV = 4 ITRACE = 1 WRITE(IDEV,9)NPOLY, NEL 9 FORMAT(' TEST PROBLEM 3'/' ***********'/' POLY OF DEGREE =',I4, 1 ' NO OF ELEMENTS = ',I4) DO 10 I = 1,IBK 10 XBK(I) = -1.0D0 + 2.0D0 * (I-1.0D0)/(IBK -1.0D0) C INITIALISE THE P.D.E. WORKSPACE ITIME = 1 CALL INICHB(NEQ, NPDE, NPTS, X, Y, WKRES, NWKRES, M, T, IBAND, 1 ITIME, XBK, IBK, NEL, NPOLY, NV, NXI, XI, IDEV) IF(ITIME .EQ. -1)THEN WRITE(IDEV, 15) 15 FORMAT(' INITCC ROUTINE RETURNED ITIME = -1 - RUN HALTED ') GOTO 100 END IF C SETUP DASSL PARAMETERS RTOL = 1.0D-5 ATOL = 1.0D-5 DO 20 I = 1,11 20 INFO(I) = 0 C INFO(11)= 1 C BANDED MATRIX OPTION WHEN INFO(6) = 1 IF(INFO(6) .EQ. 1)THEN IWORK(1) = IBAND IWORK(2) = IBAND END IF T = 0.0D0 30 TOUT = T + 0.1D0 CALL DDASSL( PDECHB, NEQ, T, Y, YDOT, TOUT, INFO, RTOL, ATOL, 1 IDID, RWORK, LRW, IWORK, LIW, WKRES, IRESWK, DGEJAC) IF( IDID .LT. 0 )THEN C DASSL FAILED TO FINISH INTEGRATION. WRITE(IDEV,40)T,IDID 40 FORMAT(' AT TIME T = ',D11.3,' DASSL RETURNED IDID =',I3) GOTO 100 ELSE C DASSL INTEGRATED TO T = TOUT C CALL TO POST PROCESSING HERE E.G. SPACE INTERPOLATION. IDERIV = 0 CALL ERROR( Y, NPDE, NPTS, X, M, ENORM, GERR, T, RTOL, ATOL, 1 ITRACE, WKRES, NWKRES) IFL = 0 ITYPE = 2 DO 45 I = 1,NPTS 45 Z(I) = X(I) CALL INTERC(Z,DYCALC,NPTS,Y,NEQ,NPDE,IFL,ITYPE,WKRES,NWKRES) IDERIV = 1 CALL EXACT(T, NPDE, NPTS, X, DYDX) DO 50 I = 1,NPTS GERRDX = ABS( DYDX(I) - DYCALC(1,I,2)) WRITE(IDEV,49)X(I),DYDX(I),DYCALC(1,I,2),GERRDX 49 FORMAT(' X =',D11.3,' TRUE = ',D11.3,' CALC= ',D11.3,' ERR=', 1 D11.3) 50 CONTINUE IF(TOUT .LT. 0.99D0 ) GOTO 30 END IF 100 CONTINUE C CALL TIMER(CTIME, 2) WRITE(IDEV,110)IWORK(11),IWORK(12),IWORK(13), CTIME 110 FORMAT(' NSTEPS =',I5,' NRESID =',I5,' JAC = ',I4,' CPU=',D11.3) STOP END C EXAMPLE PROBLEM THREE C ********************* C THIS PROBLEM IS DEFINED BY C -1 C U = ( C U ) - C * EXP(-2U) + EXP(-U) , X IN (-1,0) C T 1 X X 1 C AND C -1 C U = ( C U ) - C * EXP(-2U) + EXP(-U) , X IN (0,1) C T 2 X X 2 C WHERE C C = 0.1 AND C = 1.0 C 1 2 C C THE LEFT BOUNDARY CONDITION AT X =-1 (LEFT = .TRUE. ) IS GIVEN BY C U(-1,T) = LOG ( - C + T + P) C 1 C THE RIGHT BOUNDARY CONDITION IS (LEFT = .FALSE.) C U( 1,T) + (C + T + P ) U = LOG ( - C + T + P) + 1.0D0 C X C C THE INITIAL CONDITION IS GIVEN BY THE EXACT SOLUTION ; C U( X, T ) = LOG ( C X + T + P ) , X IN ( -1, 0) C 1 C U( X, T ) = LOG ( C X + T + P ) , X IN ( 0, 1) C 2 C********************************************************************** SUBROUTINE UVINIT( NPDE, NPTS, X, U, NV,V) C ROUTINE FOR P.D.E. INITIAL VALUES. INTEGER NPDE, NPTS, NV DOUBLE PRECISION X(NPTS), U(NPDE,NPTS), V(1), T T = 0.0D0 C V(1) IS A DUMMY VARIABLE AS THERE ARE NO COUPLED O.D.E.S CALL EXACT( T, NPDE, NPTS, X, U ) RETURN END C SUBROUTINE SPDEFN( T, X, NPTL, NPDE, U, DUDX, UDOT, UTDX, Q, R, 1 NV, V, VDOT, IRES) C ROUTINE TO DESCRIBE THE BODY OF THE P.D.E. C THE P.D.E. IS WRITEN AS -M M C Q(X,T,U, U , U , U ) = X (X R(X,T,U,U , U , U )) C X T TX X T TX X C THE FUNCTIONS Q AND R MUST BE DEFINED IN THIS ROUTINE. C DEFINITIONS FOR THE MODEL PROBLEM ARE GIVEN C NOTE NV = 0 : THERE IS NO O.D.E PART. INTEGER NPDE, NPTL, I, J, NV, IRES DOUBLE PRECISION T, X(NPTL), U(NPDE,NPTL), DUDX(NPDE,NPTL), 1 UDOT(NPDE,NPTL), Q(NPDE,NPTL), R(NPDE,NPTL), V, VDOT, 2 UTDX(NPDE,NPTL), C IF(X(1) .LT. 0.0D0 .AND. X(NPTL) .LE. 0.0D0)THEN C ELEMENT TO LEFT OF THE INTERFACE AT 0.0 C = 0.1D0 ELSE C = 1.0D0 END IF DO 10 I = 1,NPTL R(1,I) = DUDX(1,I) /C Q(1,I) = UDOT(1,I) - DEXP(-U(1,I))- DEXP(-2.0D0*U(1,I))* C 10 CONTINUE RETURN END C SUBROUTINE SBNDR( T, BETA, GAMMA, U, UX, UDOT, UTDX, NPDE, LEFT, 1 NV, V, VDOT, IRES) C BOUNDARY CONDITIONS ROUTINE INTEGER NPDE, NV, IRES DOUBLE PRECISION T, BETA(NPDE), GAMMA(NPDE), U(NPDE), C2, 1 UX(NPDE), V, VDOT, UDOT(NPDE), UTDX(NPDE) LOGICAL LEFT IF(LEFT) THEN BETA (1) = 0.0D0 GAMMA(1) = U(1) - DLOG( -0.1 + T + 1.0D0) ELSE C2 = 1.0D0 BETA (1) = C2 * ( C2 + T + 1.0D0) GAMMA(1) = U(1) - DLOG( C2 + T + 1.0D0) + 1.0D0 END IF RETURN END C C DUMMY O.D.E. ROUTINE AS NV IS ZERO SUBROUTINE SODEFN RETURN END C EXACT SOLUTION SUBROUTINE EXACT( TIME, NPDE, NPTS, X, U) C ROUTINE FOR P.D.E. EXACT VALUES (IF KNOWN) INTEGER NPDE, NPTS, I, IDERIV DOUBLE PRECISION X(NPTS), U(NPDE,NPTS), TIME, C COMMON /PROB3/ IDERIV IF(IDERIV .EQ. 0)THEN DO 10 I = 1,NPTS C = 1.0D0 IF(X(I) .LT. 0.0D0)C = 0.1D0 10 U(1,I) = DLOG( TIME + 1.0D0 + C * X(I)) ELSE DO 20 I = 1,NPTS C = 1.0D0 IF(X(I) .LT. 0.0D0)C = 0.1D0 U(1,I) = C / ( TIME + 1.0D0 + C * X(I)) IF(X(I) .EQ. 0.0D0) U(1,I) = 0.55D0 / ( TIME + 1.0D0 ) 20 CONTINUE END IF RETURN END c problem 4 C *********************************************************** C BP PROBLEM - VAPOUR EVAPORATION OVER POOL C REGION OF INTEGRATION CONSISTS OF 2 AREAS A VISCOUS SUB-LAYER AND C A TURBULENT REGION, (THE DIVISION OCCURS AT X=0.508D-03). C THE PDE IS DIFFERENT IN EACH REGION. C *********************************************************** C C0 COLLOCATION PARAMETERS PARAMETER ( IBK = 8, NEL = IBK-1 , NPDE = 1, NV = 3, 1 NPOLY = 03, NPTS = NEL*NPOLY+1, NXI = NPTS, 2 NEQ = NPTS * NPDE + NV, 3 NWKRES= (NPOLY+1) * (5*NXI + 3*NPOLY+NEL+5+7*NPDE) + 4 NPDE * 8 + 3 + NV + NXI, C DDASSL TIME INTEGRATION PARAMETERS 5 MAXORD = 5, LRW = 40 + (MAXORD+4) * NEQ + NEQ**2, 6 LIW = 20 + NEQ ) C INTEGER IWORK(LIW), INFO(15), IBAND, M, ITIME, I, IDID, 1 IDEV, ITRACE, GRNPTS, IFL, NOUT, KTIME, ITYPE DOUBLE PRECISION XBK(IBK), X(NPTS), Y(NEQ), YDOT(NEQ), TINC(11), 1 WKRES(NWKRES), RWORK(LRW), XI(NXI), T, TOUT, RTOL, ATOL, 2 U0,VM,DTX1,DTX2,DM1,DM2,K,SCM,PE,MW,RHO,RT,Q3 3 ,TEND,W Q1,Q2,TEMP, XOUT(100), UOUT(100,1), CPU, XBAR REAL GRX(800), GRY(800), GRZ(800) EXTERNAL PDECHB, DGEJAC C C COMMON BLOCKS TO PASS ACROSS PROBLEM DEPENDENT CONSTANTS. COMMON /C0/ PE,MW,RHO,RT,W COMMON /PDES/ U0,VM,DTX1,DTX2,DM1,DM2,K COMMON /SDEV2/ ITRACE, IDEV C IBM CALL TO SWITCH OFF UNDERFLOW COMMENTED OUT C CALL ERRSET(208, 256, -1, -1, 0) C CPU TIMER COMMENTED OUT FOR PORTABILITY C CALL TIMER (CPU, 1) PE = 0.39005D+4 MW = 0.92142D+2 RHO = 0.3767D+1 RT = 0.8317D+4*0.29815D+3 U0 = 0.3164D+0 VM = 0.147D-04 DTX1 = 0.0D+0 SCM = 1.7D+0 DM1 = VM/SCM K = 0.41D+0 DM2 = 0.0D+0 DTX2 = U0*K W = 0.25D0 GRNPTS = 1 WRITE(IDEV,9)NPOLY, NEL 9 FORMAT(' TEST PROBLEM 4'/' ***********'/' POLY OF DEGREE =',I4, 1 ' NO OF ELEMENTS = ',I4) RTOL = 0.1D-4 ATOL = 0.1D-4 ITRACE = 0 IDEV = 4 WRITE(IDEV,104)RTOL, ATOL, ITRACE, IDEV 104 FORMAT(//' RTOL=',D12.3,' ATOL=',D12.3,' ITRACE AND IDEV=',2I4) C WRITE(4,55)ATOL, RTOL, NPTS 55 FORMAT(//' SOLUTION TO B.P. POOL EVAPORATION PROBLEM USING 1 DASSL INTEGRATOR WITH FULL MATRIX ROUTINES '/ 2 ' ATOL = ',D11.3,' RTOL = ',D11.3,' NPTS = ',I5/) NOUT = 20 XOUT(1) = 0.0D0 XOUT(2) = 0.127D-3 XOUT(3) = 0.254D-3 XOUT(4) = 0.381D-3 XOUT(5) = 0.508D-3 XOUT(6) = 0.635D-3 XOUT(7) = 0.762D-3 XOUT(8) = 0.889D-3 XOUT(9) = 0.1D-2 XOUT(10)= 0.3D-2 XOUT(11)= 0.5D-2 XOUT(12)= 0.75D-2 XOUT(13)= 0.1D-1 XOUT(14)= 0.3D-1 XOUT(15)= 0.5D-1 XOUT(16)= 0.75D-1 XOUT(17)= 0.1D0 XOUT(18)= 0.15D0 XOUT(19)= 0.2D0 XOUT(20)= 0.22D0 XBAR = XOUT(5) DO 1000 I = 1,NOUT TEMP = DLOG10( 1.0D0 + XOUT(I)/XBAR *2.0D0) WRITE(IDEV,999)I,XOUT(I),TEMP 999 FORMAT(' I=',I3,' XOUT=',D13.5,' LOG10=',D13.5) 1000 CONTINUE C C TEMPORARY VALUES OF XI FOR FIRST CALL TO INICHB DO 291 I = 1,NPTS 291 XI(I) =(I-1.0D0) /(NPTS-1.0D0) C XBK(1) = 0.0D0 XBK(2) = XBAR* 0.5D0 XBK(3) = XBAR XBK(4) = XBAR * 1.5D0 XBK(5) = XBAR * 2.0D0 XBK(6) = XBAR*11.0 XBK(7) = XBAR * 121 XBK(8) = 1.0D0 ITIME = 1 C INITIALISE THE P.D.E. WORKSPACE CALL INICHB(NEQ, NPDE, NPTS, X, Y, WKRES, NWKRES, M, T, IBAND, 1 ITIME, XBK, IBK, NEL, NPOLY, NV, NXI, XI, IDEV) DO 292 I = 1,NPTS C FINAL VALUES OF XI 292 XI(I) = X(I) CALL INICHB(NEQ, NPDE, NPTS, X, Y, WKRES, NWKRES, M, T, IBAND, 1 ITIME, XBK, IBK, NEL, NPOLY, NV, NXI, XI, IDEV) IF(ITIME .EQ. -1)THEN WRITE(IDEV, 15) 15 FORMAT(' INITCC ROUTINE RETURNED ITIME = -1 - RUN HALTED ') GOTO 900 ELSE WRITE(IDEV,16)(Y(I), I = 1,NPTS) 16 FORMAT(' INITIAL VALUES ARE =',5D11.3) END IF C SETUP DASSL PARAMETERS DO 20 I = 1,11 20 INFO(I) = 0 C INFO(11)= 1 C BANDED MATRIX OPTION WHEN INFO(6) = 1 IF(INFO(6) .EQ. 1)THEN IWORK(1) = IBAND IWORK(2) = IBAND END IF T = 0.0D0 TINC(1) = 0.0001D0 TINC(2) = 0.0010 TINC(3) = 0.01D0 TINC(4) = 0.050D0 TINC(5) = 0.1D0 TINC(6) = 0.15D0 TINC(7) = 0.25D0 TINC(8) = 0.50D0 TINC(9) = 0.65D0 TINC(10)= 0.80D0 TINC(11)= 1.00D0 TEND = 1.0D0 KTIME = 1 ITYPE = 1 CALL INTERC(XOUT,UOUT,NOUT,Y,NEQ,NPDE,IFL,ITYPE,WKRES,NWKRES) WRITE (IDEV,82) T, (UOUT(I,1),I=1,NOUT,3) GRNPTS = 0 DO 800 I = 1,NOUT GRNPTS = GRNPTS + 1 GRX(GRNPTS) = T GRZ(GRNPTS) = UOUT(I,1)/UOUT(1,1) GRY(GRNPTS) = DLOG10( 1.D0+XOUT(I)/XBAR * 2.0D0) IF(ITRACE .GE.0)WRITE(IDEV,899)GRY(GRNPTS),GRZ(GRNPTS) 800 CONTINUE WRITE(IDEV,81)(XOUT(I), I = 1,NOUT,2) 81 FORMAT (/' T/X', 4X,9D11.3) C TIME LOOP: 100 TOUT = TINC(KTIME) CALL DDASSL( PDECHB, NEQ, T, Y, YDOT, TOUT, INFO, RTOL, ATOL, 1 IDID, RWORK, LRW, IWORK, LIW, WKRES, NWKRES, DGEJAC) C DASSL FAILED TO FINISH INTEGRATION. WRITE(IDEV,40)T,IDID 40 FORMAT(' AT TIME T = ',D11.3,' DASSL RETURNED IDID =',I3) IF( IDID .LT. 0 )GOTO 900 C DASSL INTEGRATED TO T = TOUT C CALL TO POST PROCESSING HERE E.G. SPACE INTERPOLATION. CALL INTERC(XOUT,UOUT,NOUT,Y,NEQ,NPDE,IFL,ITYPE,WKRES,NWKRES) 82 FORMAT(1X,F3.1,' U ',9D11.3/) WRITE (IDEV,82) TOUT, (UOUT(I,1),I=1,NOUT,3) WRITE (6,82) TOUT, (UOUT(I,1),I=1,NOUT,3) C C COMPARE RATE OF EVAPORATION Q1 AT SURFACE OF POOL WITH QUANTITY OF C VAPOUR Q2 WHICH PASSES ABOVE END OF POOL Q1 = Y(NEQ-2) Q2 = Y(NEQ-1) Q3 = Y(NEQ) WRITE(IDEV,83) Q1,Q2,Q3 83 FORMAT(' Q1 , Q2 AND Q3 ARE ',3D13.5) C C PUT INTERPOLATED RESULTS IN ARRAY. C I =(KTIME/2) * 2 IF (I .EQ. KTIME)GOTO 91 DO 90 I = 1,NOUT GRNPTS = GRNPTS + 1 GRX(GRNPTS) = TOUT GRZ(GRNPTS) = UOUT(I,1)/UOUT(1,1) GRY(GRNPTS) = DLOG10( 1.D0+XOUT(I)/XBAR * 2.0D0) IF(ITRACE .GE.0)WRITE(IDEV,899)GRY(GRNPTS),GRZ(GRNPTS) 899 FORMAT(' X AND Y VALUES ARE ',2E12.4) 90 CONTINUE 91 KTIME = KTIME + 1 C C CHECK IF INTEGRATION WAS SUCCESSFUL AND WHETHER FURTHER TIME C STEPS NEEDED IF(TOUT.LT.TEND.AND.(IDID.EQ.2 .OR. IDID .EQ. 3)) GO TO 100 WRITE(IDEV,2112)Q1,Q2,DABS(Q3) 2112 FORMAT(' RATE OF EVAPORATION AT SURFACE OF POOL Q1 = ',D14.7,/ - ' QUANTITY OF VAPOUR ABOVE END OF POOL Q2 = ',D14.7,/ - ' ABSOLUTE DIFFERENCE Q3 = ',D11.4,/ - '********************************************************',/) 80 CONTINUE C CALL TIMER(CPU,2) 900 WRITE(IDEV,110)IWORK(11),IWORK(12),IWORK(13), CPU 110 FORMAT(' NSTEPS =',I5,' NRESID =',I5,' JAC = ',I4,' CPU=',D11.3) STOP END C EXAMPLE PROBLEM FOUR C ********************* C THIS PROBLEM IS DEFINED BY C C C X U = ( C U ) , X IN (0 , XBAR) C 1 T 2 X X C AND C C (C LOG(X) +C ) U = ( C X U ) , X IN (XBAR , 1) C 3 4 T 5 X X C C WHERE -6 C C = 6810.0 C = 8.65 10 C =0.7717 C = 9.313 C = 0.1297 C 1 2 3 4 5 C C THE LEFT BOUNDARY CONDITION AT X =-1 (LEFT = .TRUE. ) IS GIVEN BY C U(0,T) = 0.038475 C C THE RIGHT BOUNDARY CONDITION IS (LEFT = .FALSE.) C U (1,T) = 0 C X C C THE INITIAL CONDITION IS GIVEN BY C U(X,0) = 0 C C THE ALGEBRAIC VARIABLES Q (T) , Q (T) AND Q (T) ARE DEFINED BY C 1 2 3 C C . -7 C Q = -7.983 10 U (0 , T) C 1 X C C -2 1 C Q = 9.4175 10 I P(X) U(X,T) DX C 2 0 C C WHERE P(X) = C X FOR X IN (0, XBAR) C 1 C C P(X) = C LOG(X) + C FOR X IN (XBAR, 1) C 3 4 C AND THE VALUES OF THE CONSTANTS ARE GIVEN ABOVE. C C Q (T) = Q (T) - Q (T) C 3 2 1 C C********************************************************************** SUBROUTINE UVINIT( NPDE, NPTS, X, U, NV,V) C ROUTINE FOR P.D.E. INITIAL VALUES. INTEGER NPDE, NPTS, NV, I DOUBLE PRECISION X(NPTS), U(NPDE,NPTS),PE,MW,RHO,RT,W,V(3) COMMON/C0/PE,MW,RHO,RT,W DO 10 I= 2,NPTS 10 U(1,I) = 0.0D+0 U(1,1) = (PE*MW)/(RHO*RT) V(1) = 0.0D0 V(2) = 0.0D0 V(3) = 0.0D0 RETURN END C SUBROUTINE SPDEFN( T, X, NPTL, NPDE, U, DUDX, UDOT, UTDX, Q, R, 1 NV, V, VDOT, IRES) C********************************************************************** C ROUTINE TO DESCRIBE THE BODY OF THE P.D.E. C THE P.D.E. IS WRITEN AS -M M C Q(X,T,U, U , U , U ) = X (X R(X,T,U,U , U , U )) C X T TX X T TX X C THE FUNCTIONS Q AND R MUST BE DEFINED IN THIS ROUTINE. C********************************************************************** INTEGER NPDE, NPTL, I, NV, IRES DOUBLE PRECISION T, X(NPTL), U(NPDE,NPTL), DUDX(NPDE,NPTL), 1 DM2, UDOT(NPDE,NPTL), Q(NPDE,NPTL), R(NPDE,NPTL), V(3), 2 K, UTDX(NPDE,NPTL), U0, VM, DTX1, DTX2, DM1, VDOT(3) COMMON /PDES/ U0,VM,DTX1,DTX2,DM1,DM2,K DO 100 I = 1,NPTL IF(X(1) .LT. 0.506D-3 .AND. X(NPTL) .LT. 0.600D-3)THEN C ELEMENT TO LEFT OF THE INTERFACE AT 0.508D-3 Q(1,I) = (X(I)*U0**2)/VM * UDOT(1,I) R(1,I) = (DTX1 + DM1)*DUDX(1,I) ELSE Q(1,I) = ((U0/K)*DLOG(U0*X(I)/VM) + 5.1*U0) * UDOT(1,I) R(1,I) = ((DTX2*X(I)) + DM2)*DUDX(1,I) ENDIF 100 CONTINUE RETURN END C SUBROUTINE SBNDR( T, BETA, GAMMA, U, UX, UDOT, UTDX, NPDE, LEFT, 1 NV, V, VDOT, IRES) C BOUNDARY CONDITIONS ROUTINE INTEGER NPDE, NV, IRES DOUBLE PRECISION T, BETA(NPDE), GAMMA(NPDE), U(NPDE), PE,MW,RHO, 1 UX(NPDE), V(3), VDOT(3), UDOT(NPDE), UTDX(NPDE), RT, W LOGICAL LEFT COMMON/C0/PE,MW,RHO,RT,W IF(LEFT) THEN GAMMA(1) = U(1)- (PE*MW)/(RHO*RT) BETA(1) = 0.0D+0 ELSE GAMMA(1) = 0.0D0 BETA(1) = 1.0D0 END IF RETURN END SUBROUTINE SODEFN(T, NV, V, VDOT, NPDE, NXI, X, Y, UXI, RI, 1 UTI, UTXI, VRES, IRES) C ROUTINE FOR AUXILIARY O.D.E.S (IF ANY) IN MASTER EQN. FORM (4.3) INTEGER NPDE, NXI, NV, IRES, NPTL, L, J, I DOUBLE PRECISION T, X(NXI), Y(NXI), UXI(NPDE,NXI), 1 RI(NPDE,NXI), UTI(NPDE,NXI), UTXI(NPDE,NXI), VRES(NV), 2 V(3), VDOT(3), PE,MW,RHO,RT,W,U0,VM,DTX1,DTX2,DM2,K 3 ,DM1, Q2, H, CCRULE COMMON /C0/ PE,MW,RHO,RT,W COMMON /PDES/ U0,VM,DTX1,DTX2,DM1,DM2,K COMMON /SCHSZ5/ NPTL COMMON /SCHSZ6/ CCRULE(50) C VRES(1) = VDOT(1) + W*RHO*DM1*UXI(1,1) Q2 = 0.0D0 DO 3 I = 1,2 J = (NPTL-1) * (I-1) + 1 L = (NPTL-1) * I + 1 H = ( X(L) - X(J)) * 0.5D0 DO 3 II = 1,NPTL IK = J + II - 1 C CLENSHAW - CURTIS QUADRATURE UP TO INTERFACE POINT. Q2 = Q2 + (W*RHO*U0**2)/VM * X(IK) * Y(IK) * CCRULE(II) * H 3 CONTINUE C C CLENSHAW - CURTIS QUADRATURE BEYOND THE INTERFACE POINT. DO 5 I = 3,7 J = (NPTL-1) * (I-1) + 1 L = (NPTL-1) * I + 1 H = ( X(L) - X(J)) * 0.5D0 DO 5 II = 1, NPTL IK = J + II - 1 Q2=Q2 + H* ((U0/K)*DLOG(U0*X(IK)/VM)+5.1*U0) * Y(IK)*CCRULE(II) 1 * W * RHO 5 CONTINUE VRES(2) = V(2) - Q2 VRES(3) = V(3) - (V(2)-V(1)) RETURN END c problem 5 C *********************************************************** C FOURTH ORDER P.D.E. PROBLEM WRITTEN AS ELLIPTIC-PARABOLIC SYSTEM. C C U = K U + UU - U U C XXT XXXX XXX X XX C C *********************************************************** C C C0 COLLOCATION PARAMETERS PARAMETER ( IBK = 21, NEL = IBK-1 , NPDE = 2, NV = 0, 1 NPOLY = 02, NPTS = NEL*NPOLY+1, NXI = 0, 2 NEQ = NPTS * NPDE + NV, 3 NWKRES= (NPOLY+1) * (5*NXI + 3*NPOLY+NEL+5+7*NPDE) + 4 NPDE * 8 + 3 + NV + NXI, C DDASSL TIME INTEGRATION PARAMETERS 5 MAXORD = 5, LRW = 40 + (MAXORD+4) * NEQ + NEQ**2, 6 LIW = 20 + NEQ ) C INTEGER IWORK(LIW), INFO(15), IBAND, M, ITIME, I, IDID, 1 IDEV, ITRACE, GRNPTS, IFL, NOUT, KTIME, ITYPE, NP DOUBLE PRECISION XBK(IBK), X(NPTS), Y(NEQ), YDOT(NEQ), TINC(15), 1 WKRES(NWKRES), RWORK(LRW), XI, T, TOUT, RTOL, ATOL, 3 TEND, K, XOUT(6), UOUT(2,6) EXTERNAL PDECHB, DGEJAC C C COMMON BLOCKS TO PASS ACROSS PROBLEM DEPENDENT CONSTANTS. COMMON /PDES/ K COMMON /SDEV2/ ITRACE, IDEV DATA XOUT(1)/-1.0D+0/, XOUT(2)/-0.6D+0/, XOUT(3)/-0.2D+0/, * XOUT(4)/0.2D+0/, XOUT(5)/0.6D+0/, XOUT(6)/1.0D+0/ WRITE(IDEV,9)NPOLY, NEL 9 FORMAT(' TEST PROBLEM 4'/' ***********'/' POLY OF DEGREE =',I4, 1 ' NO OF ELEMENTS = ',I4) RTOL = 0.1D-4 ATOL = 0.1D-4 ITRACE = 0 IDEV = 4 WRITE(IDEV,104)RTOL, ATOL, ITRACE, IDEV 104 FORMAT(//' RTOL=',D12.3,' ATOL=',D12.3,' ITRACE AND IDEV=',2I4) C WRITE(4,55)ATOL, RTOL, NPTS 55 FORMAT(//' SOLUTION TO FOURTH ORDER P.D.E. PROBLEM USING 1 DASSL INTEGRATOR WITH BANDED MATRIX ROUTINES '/ 2 ' ATOL = ',D11.3,' RTOL = ',D11.3,' NPTS = ',I5/) C C EQUALLY SPACED BREAKPOINTS. C DO 105 I = 1,IBK XBK(I) = -1.0D0 + (I -1.0D0)* 2.D0 / (IBK-1.D0) 105 CONTINUE K = 1.00D0 ITIME = 1 T = 0.0D0 C INITIALISE THE P.D.E. WORKSPACE CALL INICHB(NEQ, NPDE, NPTS, X, Y, WKRES, NWKRES, M, T, IBAND, 1 ITIME, XBK, IBK, NEL, NPOLY, NV, NXI, XI, IDEV) IF(ITIME .EQ. -1)THEN WRITE(IDEV, 15) 15 FORMAT(' INICHB ROUTINE RETURNED ITIME = -1 - RUN HALTED ') GOTO 900 END IF C SETUP DASSL PARAMETERS DO 20 I = 1,11 20 INFO(I) = 0 INFO(6)= 1 INFO(9)= 1 INFO(7)= 1 IWORK(3)= 4 C BANDED MATRIX OPTION WHEN INFO(6) = 1 IF(INFO(6) .EQ. 1)THEN IWORK(1) = IBAND IWORK(2) = IBAND END IF T = 0.0D0 TINC(1) = 0.0001D0 RWORK(2)= TINC(1) * 0.1D0 TINC(2) = 0.0010 TINC(3) = 0.01D0 TINC(4) = 0.1D0 TINC(5) = 1.0D0 TINC(6) = 1.00D1 TINC(7) = 2.00D1 TINC(8) = 4.00D1 TINC(9 )= 6.00D1 TINC(10)= 8.00D1 TINC(11)= 1.00D2 TINC(12)= 1.00D3 TEND = 1.0D3 KTIME = 1 WRITE(IDEV,83)(XOUT(I),I = 1,6) C TIME LOOP: 100 TOUT = TINC(KTIME) IF(KTIME.GT.1)RWORK(2) = 0.05D0 *(TOUT- TINC(KTIME-1)) IF(KTIME .EQ.12)THEN INFO(4) = 1 RWORK(1) = TEND END IF C CALL DDASSL( PDECHB, NEQ, T, Y, YDOT, TOUT, INFO, RTOL, ATOL, 1 IDID, RWORK, LRW, IWORK, LIW, WKRES, NWKRES, DGEJAC) C DASSL FAILED TO FINISH INTEGRATION. WRITE(IDEV,40)T,IDID,Y(1),Y(2),Y(NEQ-1), Y(NEQ) 40 FORMAT(' AT TIME T = ',D11.3,' DASSL RETURNED IDID =',I3/ 1 ' LEFT SOL=',2D11.3,' RIGHT SOL=',2D11.3) IF( IDID .LT. 0 )GOTO 900 C DASSL INTEGRATED TO T = TOUT C CALL TO POST PROCESSING HERE E.G. SPACE INTERPOLATION. ITYPE = 1 NP = 6 CALL INTERC( XOUT, UOUT, NP, Y, NEQ, NPDE, IFLAG, 1 ITYPE, WKRES, NWKRES) WRITE(IDEV,82)(UOUT(1,I),I = 1,6) WRITE(IDEV,84)(UOUT(2,I),I = 1,6) 83 FORMAT(1X,'X',9D11.3/) 82 FORMAT(1X,'U',9D11.3/) 84 FORMAT(1X,'V',9D11.3/) C 91 KTIME = KTIME + 1 C C CHECK IF INTEGRATION WAS SUCCESSFUL AND WHETHER FURTHER TIME C STEPS NEEDED IF(TOUT.LT.TEND.AND.(IDID.EQ.2 .OR. IDID .EQ. 3)) GO TO 100 80 CONTINUE 900 WRITE(IDEV,110)IWORK(11),IWORK(12),IWORK(13) 110 FORMAT(' NSTEPS =',I5,' NRESID =',I5,' JAC = ',I4) STOP END C EXAMPLE PROBLEM FIVE C ********************* C THIS PROBLEM IS DEFINED BY C C V = U C XX C AND C C V = ( K V ) + U V - U V , X IN (-1 , 1) C T X X X X C WHERE C K = 0.15 C C THE LEFT BOUNDARY CONDITION AT X =-1 (LEFT = .TRUE. ) ARE GIVEN BY C C U = 1 U = 0.0 C X C THE RIGHT BOUNDARY CONDITION ARE (LEFT = .FALSE.) C C U = -1 U = 0.0D0 C X C THE INITIAL CONDITION IS GIVEN BY C C U(X,0) = -SIN ( PI /2 X ) C********************************************************************** SUBROUTINE UVINIT( NPDE, NPTS, X, U, NV,V) C ROUTINE FOR P.D.E. INITIAL VALUES. PARAMETER (PIBY2 = 1.5707963D0) INTEGER NPDE, NPTS, NV, I DOUBLE PRECISION X(NPTS), U(NPDE,NPTS),V DO 10 I= 1,NPTS U(1,I) = -SIN( PIBY2 * X(I) ) 10 U(2,I) = - PIBY2**2 * U(1,I) RETURN END C SUBROUTINE SPDEFN( T, X, NPTL, NPDE, U, DUDX, UDOT, UTDX, Q, R, 1 NV, V, VDOT, IRES) C********************************************************************** C ROUTINE TO DESCRIBE THE BODY OF THE P.D.E. C THE P.D.E. IS WRITEN AS -M M C Q(X,T,U, U , U , U ) = X (X R(X,T,U,U , U , U )) C X T TX X T TX X C THE FUNCTIONS Q AND R MUST BE DEFINED IN THIS ROUTINE. C********************************************************************** INTEGER NPDE, NPTL, I, NV, IRES DOUBLE PRECISION T, X(NPTL), U(NPDE,NPTL), DUDX(NPDE,NPTL), 1 UDOT(NPDE,NPTL), Q(NPDE,NPTL), R(NPDE,NPTL), V, 2 K, UTDX(NPDE,NPTL), VDOT COMMON /PDES/ K DO 100 I = 1,NPTL Q(1,I) = U(2,I) R(1,I) = DUDX(1,I) Q(2,I) = UDOT(2,I) - U(1,I)*DUDX(2,I) + DUDX(1,I)*U(2,I) R(2,I) = K*DUDX(2,I) 100 CONTINUE RETURN END C SUBROUTINE SBNDR( T, BETA, GAMMA, U, UX, UDOT, UTDX, NPDE, LEFT, 1 NV, V, VDOT, IRES) C BOUNDARY CONDITIONS ROUTINE INTEGER NPDE, NV, IRES DOUBLE PRECISION T, BETA(NPDE), GAMMA(NPDE), U(NPDE), 1 UX(NPDE), V, VDOT, UDOT(NPDE), UTDX(NPDE) LOGICAL LEFT IF(LEFT) THEN GAMMA(1) = 0.0D0 BETA(1) = 1.0D+0 GAMMA(2) = U(1) - 1.0D0 BETA(2) = 0.0D+0 ELSE GAMMA(1) = 0.0D0 BETA(1) = 1.0D+0 GAMMA(2) = U(1) + 1.0D0 BETA(2) = 0.0D+0 END IF RETURN END SUBROUTINE SODEFN(T, NV, V, VDOT, NPDE, NXI, X, Y, UXI, RI, 1 UTI, UTXI, VRES, IRES) C ROUTINE FOR AUXILIARY O.D.E.S (IF ANY) IN MASTER EQN. FORM (4.3) INTEGER NPDE, NXI, NV, IRES, NPTL, L, J, I DOUBLE PRECISION T, X(NXI), Y(NXI), UXI(NPDE,NXI), 1 RI(NPDE,NXI), UTI(NPDE,NXI), UTXI(NPDE,NXI), VRES(NV), 2 V, VDOT C DUMMY ROUTINE AS THERE ARE NO O.D.E.S RETURN END c c main body of the software follows................ c SUBROUTINE DDASSL (RES,NEQ,T,Y,YPRIME,TOUT, * INFO,RTOL,ATOL,IDID, * RWORK,LRW,IWORK,LIW,RPAR,IPAR, * JAC) C C***BEGIN PROLOGUE DDASSL C***DATE WRITTEN 830315 (YYMMDD) C***REVISION DATE 830315 (YYMMDD) C***CATEGORY NO. D2A2 C***KEYWORDS DIFFERENTIAL/ALGEBRAIC,BACKWARD DIFFERENTIATION FORMULAS C IMPLICIT DIFFERENTIAL SYSTEMS C***AUTHOR PETZOLD,LINDA R. C APPLIED MATHEMATICS DIVISION 8331 C SANDIA NATIONAL LABORATORIES C LIVERMORE, CA. 94550 C***PURPOSE DIFFERENTIAL/ALGEBRAIC SYSTEM SOLVER C***DESCRIPTION C --------------------------------------------------------------------- C C this code solves a system of differential/ C algebraic equations of the form C g(t,y,yprime) = 0. C C subroutine ddassl uses the backward C differentiation formulas of orders one C through five to solve a system of the above C form for y and yprime. values for y C and yprime at the initial time must C be given as input. these values must C be consistent, (that is. if t,y,yprime C are the given initial values, they must C satisfy g(t,y,yprime) = 0.) C the subroutine solves the system from t to tout. it is C easy to continue the solution to get results C at additional tout. this is the interval C mode of operation. intermediate results can C also be obtained easily by using the intermediate- C output capability. C C C ------------description of arguments to ddassl----------------------- C ------------(an overview)-------------------------------------------- C C the parameters are C C res -- this is a subroutine which you provide C to define the differential/algebraic C system C C neq -- this is the number of equations C to be solved C C t -- this is the current value of the C independent variable. C C tout -- this is a point at which a solution C is desired. C C info(*) -- the basic task of the code is C to solve the system from t to C tout and return an answer at tout. C info(*) is an integer array which is C used to communicate exactly how you C want this task to be carried out. C C y(*) -- this array contains the solution C components at t C C yprime(*) -- this array contains the derivatives C of the solution components at t C C rtol,atol -- these quantities represent C absolute and relative error C tolerances which you provide to indicate C how accurately you wish the solution C to be computed. you may choose them C to be both scalars or else both C vectors. C C idid -- this scalar quantity is an indicator reporting C what the code did. you must monitor this C integer variable to decide what action to C take next. C C rwork(*),lrw -- rwork(*) is a real work array of C length lrw which provides the code C with needed storage space. C C iwork(*),liw -- iwork(*) is an integer work array C of length liw which provides the code C with needed storage space. C C rpar,ipar -- these are real and integer parameter C arrays which you can use for C communication between your calling C program and the res subroutine C (and the jac subroutine) C C jac -- this is the name of a subroutine which you C may choose to provide for defining C a matrix of partial derivatives C described below. C C quantities which are used as input items are C neq,t,y(*),yprime(*),tout,info(*), C rtol,atol,rwork(1),rwork(2),rwork(3),lrw,iwork(1), C iwork(2),iwork(3),and liw. C C quantities which may be altered by the code are C t,y(*),yprime(*),info(1),rtol,atol, C idid,rwork(*) and iwork(*) C C ----------input-what to do on the first call to ddassl--------------- C C C the first call of the code is defined to be the start of each new C problem. read through the descriptions of all the following items, C provide sufficient storage space for designated arrays, set C appropriate variables for the initialization of the problem, and C give information about how you want the problem to be solved. C C C res -- provide a subroutine of the form C subroutine res(t,y,yprime,delta,ires,rpar,ipar) C to define the system of differential/algebraic C equations which is to be solved. for the given values C of t,y and yprime, the subroutine should C return the residual of the differential/algebraic C system C delta = g(t,y,yprime) C (delta(*) is a vector of length neq which is C output for res.) C C subroutine res must not alter t,y or yprime. C you must declare the name res in an external C statement in your program that calls ddassl. C you must dimension y,yprime and delta in res. C C ires is an integer flag which is always equal to C zero on input. subroutine res should alter ires C only if it encounters an illegal value of y or C a stop condition. set ires = -1 if an input value C is illegal, and ddassl will try to solve the problem C without getting ires = -1. if ires = -2, ddassl C will return control to the calling program C with idid = -11. C C rpar and ipar are real and integer parameter arrays which C you can use for communication between your calling program C and subroutine res. they are not altered by ddassl. if you C do not need rpar or ipar, ignore these parameters by treat- C ing them as dummy arguments. if you do choose to use them, C dimension them in your calling program and in res as arrays C of appropriate length. C C neq -- set it to the number of differential equations. C (neq .ge. 1) C C t -- set it to the initial point of the integration. C t must be defined as a variable. C C y(*) -- set this vector to the initial values of the neq solution C components at the initial point. you must dimension y of C length at least neq in your calling program. C C yprime(*) -- set this vector to the initial values of C the neq first derivatives of the solution C components at the initial point. you C must dimension yprime at least neq C in your calling program. if you do not C know initial values of some of the solution C components, see the explanation of info(11). C C tout - set it to the first point at which a solution C is desired. you can not take tout = t. C integration either forward in t (tout .gt. t) or C backward in t (tout .lt. t) is permitted. C C the code advances the solution from t to tout using C step sizes which are automatically selected so as to C achieve the desired accuracy. if you wish, the code will C return with the solution and its derivative at C intermediate steps (intermediate-output mode) so that C you can monitor them, but you still must provide tout in C accord with the basic aim of the code. C C the first step taken by the code is a critical one C because it must reflect how fast the solution changes near C the initial point. the code automatically selects an C initial step size which is practically always suitable for C the problem. by using the fact that the code will not step C past tout in the first step, you could, if necessary, C restrict the length of the initial step size. C C for some problems it may not be permissable to integrate C past a point tstop because a discontinuity occurs there C or the solution or its derivative is not defined beyond C tstop. when you have declared a tstop point (see info(4) C and rwork(1)), you have told the code not to integrate C past tstop. in this case any tout beyond tstop is invalid C input. C C info(*) - use the info array to give the code more details about C how you want your problem solved. this array should be C dimensioned of length 15, though ddassl uses C only the first nine entries. you must respond to all of C the following items which are arranged as questions. the C simplest use of the code corresponds to answering all C questions as yes ,i.e. setting all entries of info to 0. C C info(1) - this parameter enables the code to initialize C itself. you must set it to indicate the start of every C new problem. C C **** is this the first call for this problem ... C yes - set info(1) = 0 C no - not applicable here. C see below for continuation calls. **** C C info(2) - how much accuracy you want of your solution C is specified by the error tolerances rtol and atol. C the simplest use is to take them both to be scalars. C to obtain more flexibility, they can both be vectors. C the code must be told your choice. C C **** are both error tolerances rtol, atol scalars ... C yes - set info(2) = 0 C and input scalars for both rtol and atol C no - set info(2) = 1 C and input arrays for both rtol and atol **** C C info(3) - the code integrates from t in the direction C of tout by steps. if you wish, it will return the C computed solution and derivative at the next C intermediate step (the intermediate-output mode) or C tout, whichever comes first. this is a good way to C proceed if you want to see the behavior of the solution. C if you must have solutions at a great many specific C tout points, this code will compute them efficiently. C C **** do you want the solution only at C tout (and not at the next intermediate step) ... C yes - set info(3) = 0 C no - set info(3) = 1 **** C C info(4) - to handle solutions at a great many specific C values tout efficiently, this code may integrate past C tout and interpolate to obtain the result at tout. C sometimes it is not possible to integrate beyond some C point tstop because the equation changes there or it is C not defined past tstop. then you must tell the code C not to go past. C C **** can the integration be carried out without any C restrictions on the independent variable t ... C yes - set info(4)=0 C no - set info(4)=1 C and define the stopping point tstop by C setting rwork(1)=tstop **** C C info(5) - to solve differential/algebraic problems it is C necessary to use a matrix of partial derivatives of the C system of differential equations. if you do not C provide a subroutine to evaluate it analytically (see C description of the item jac in the call list), it will C be approximated by numerical differencing in this code. C although it is less trouble for you to have the code C compute partial derivatives by numerical differencing, C the solution will be more reliable if you provide the C derivatives via jac. sometimes numerical differencing C is cheaper than evaluating derivatives in jac and C sometimes it is not - this depends on your problem. C C **** do you want the code to evaluate the partial C derivatives automatically by numerical differences .. C yes - set info(5)=0 C no - set info(5)=1 C and provide subroutine jac for evaluating the C matrix of partial derivatives **** C C info(6) - ddassl will perform much better if the matrix of C partial derivatives, dg/dy + cj*dg/dyprime, C (here cj is a scalar determined by ddassl) C is banded and the code is told this. in this C case, the storage needed will be greatly reduced, C numerical differencing will be performed much cheaper, C and a number of important algorithms will execute much C faster. the differential equation is said to have C half-bandwidths ml (lower) and mu (upper) if equation i C involves only unknowns y(j) with C i-ml .le. j .le. i+mu C for all i=1,2,...,neq. thus, ml and mu are the widths C of the lower and upper parts of the band, respectively, C with the main diagonal being excluded. if you do not C indicate that the equation has a banded matrix of partial C derivatives C the code works with a full matrix of neq**2 elements C (stored in the conventional way). computations with C banded matrices cost less time and storage than with C full matrices if 2*ml+mu .lt. neq. if you tell the C code that the matrix of partial derivatives has a banded C structure and you want to provide subroutine jac to C compute the partial derivatives, then you must be careful C to store the elements of the matrix in the special form C indicated in the description of jac. C C **** do you want to solve the problem using a full C (dense) matrix (and not a special banded C structure) ... C yes - set info(6)=0 C no - set info(6)=1 C and provide the lower (ml) and upper (mu) C bandwidths by setting C iwork(1)=ml C iwork(2)=mu **** C C C info(7) -- you can specify a maximum (absolute value of) C stepsize, so that the code C will avoid passing over very C large regions. C C **** do you want the code to decide C on its own maximum stepsize? C yes - set info(7)=0 C no - set info(7)=1 C and define hmax by setting C rwork(2)=hmax **** C C info(8) -- differential/algebraic problems C may occaisionally suffer from C severe scaling difficulties on the C first step. if you know a great deal C about the scaling of your problem, you can C help to alleviate this problem by C specifying an initial stepsize ho. C C **** do you want the code to define C its own initial stepsize? C yes - set info(8)=0 C no - set info(8)=1 C and define ho by setting C rwork(3)=ho **** C C info(9) -- if storage is a severe problem, C you can save some locations by C restricting the maximum order maxord. C the default value is 5. for each C order decrease below 5, the code C requires neq fewer locations, however C it is likely to be slower. in any C case, you must have 1 .le. maxord .le. 5 C **** do you want the maximum order to C default to 5? C yes - set info(9)=0 C no - set info(9)=1 C and define maxord by setting C iwork(3)=maxord **** C C info(10) --if you know that the solutions to your equations wil C always be nonnegative, it may help to set this C parameter. however, it is probably best to C try the code without using this option first, C and only to use this option if that doesn't C work very well. C **** do you want the code to solve the problem without C invoking any special nonnegativity constraints? C yes - set info(10)=0 C no - set info(10)=1 C C info(11) --ddassl normally requires the initial t, C y, and yprime to be consistent. that is, C you must have g(t,y,yprime) = 0 at the initial C time. if you do not know the initial C derivative precisely, you can let ddassl try C to compute it. C **** are the initial t, y, yprime consistent? C yes - set info(11) = 0 C no - set info(11) = 1, C and set yprime to an initial approximation C to yprime. (if you have no idea what C yprime should be, set it to zero. note C that the initial y should be such C that there must exist a yprime so that C g(t,y,yprime) = 0.) C C rtol, atol -- you must assign relative (rtol) and absolute (atol C error tolerances to tell the code how accurately you wan C the solution to be computed. they must be defined as C variables because the code may change them. you have two C choices -- C both rtol and atol are scalars. (info(2)=0) C both rtol and atol are vectors. (info(2)=1) C in either case all components must be non-negative. C C the tolerances are used by the code in a local error tes C at each step which requires roughly that C abs(local error) .le. rtol*abs(y)+atol C for each vector component. C (more specifically, a root-mean-square norm is used to C measure the size of vectors, and the error test uses the C magnitude of the solution at the beginning of the step.) C C the true (global) error is the difference between the tr C solution of the initial value problem and the computed C approximation. practically all present day codes. C including this one, control the local error at each step C and do not even attempt to control the global error C directly. C usually, but not always, the true accuracy of C the computed y is comparable to the error tolerances. th C code will usually, but not always, deliver a more accura C solution if you reduce the tolerances and integrate agai C by comparing two such solutions you can get a fairly C reliable idea of the true error in the solution at the C bigger tolerances. C C setting atol=0. results in a pure relative error test on C that component. setting rtol=0. results in a pure absolu C error test on that component. a mixed test with non-zero C rtol and atol corresponds roughly to a relative error C test when the solution component is much bigger than ato C and to an absolute error test when the solution componen C is smaller than the threshold atol. C C the code will not attempt to compute a solution at an C accuracy unreasonable for the machine being used. it wil C advise you if you ask for too much accuracy and inform C you as to the maximum accuracy it believes possible. C C rwork(*) -- dimension this real work array of length lrw in your C calling program. C C lrw -- set it to the declared length of the rwork array. C you must have C lrw .ge. 40+(maxord+4)*neq+neq**2 C for the full (dense) jacobian case (when info(6)=0), or C lrw .ge. 40+(maxord+4)*neq+(2*ml+mu+1)*neq C for the banded user-defined jacobian case C (when info(5)=1 and info(6)=1), or C lrw .ge. 40+(maxord+4)*neq+(2*ml+mu+1)*neq C +2*(neq/(ml+mu+1)+1) C for the banded finite-difference-generated jacobian case C (when info(5)=0 and info(6)=1) C C iwork(*) -- dimension this integer work array of length liw in C your calling program. C C liw -- set it to the declared length of the iwork array. C you must have liw .ge. 20+neq C C rpar, ipar -- these are parameter arrays, of real and integer C type, respectively. you can use them for communication C between your program that calls ddassl and the C res subroutine (and the jac subroutine). they are not C altered by ddassl. if you do not need rpar or ipar, igno C these parameters by treating them as dummy arguments. if C you do choose to use them, dimension them in your callin C program and in res (and in jac) as arrays of appropriate C length. C C jac -- if you have set info(5)=0, you can ignore this parameter C by treating it as a dummy argument. otherwise, you must C provide a subroutine of the form C jac(t,y,yprime,pd,cj,rpar,ipar) C to define the matrix of partial derivatives C pd=dg/dy+cj*dg/dyprime C cj is a scalar which is input to jac. C for the given values of t,y,yprime, the C subroutine must evaluate the non-zero partial C derivatives for each equation and each solution C compowent, and store these values in the C matrix pd. the elements of pd are set to zero C before each call to jac so only non-zero elements C need to be defined. C C subroutine jac must not alter t,y,(*),yprime(*),or cj. C you must declare the name jac in an C external statement in your program that calls C ddassl. you must dimension y, yprime and pd C in jac. C C the way you must store the elements into the pd matrix C depends on the structure of the matrix which you C indicated by info(6). C *** info(6)=0 -- full (dense) matrix *** C when you evaluate the (non-zero) partial derivative C of equation i with respect to variable j, you must C store it in pd according to C pd(i,j) = * dg(i)/dy(j)+cj*dg(i)/dyprime(j)* C *** info(6)=1 -- banded jacobian with ml lower and mu C upper diagonal bands (refer to info(6) description o C ml and mu) *** C when you evaluate the (non-zero) partial derivative C of equation i with respect to variable j, you must C store it in pd according to C irow = i - j + ml + mu + 1 C pd(irow,j) = *dg(i)/dy(j)+cj*dg(i)/dyprime(j)* C rpar and ipar are real and integer parameter arrays whic C you can use for communication between your calling C program and your jacobian subroutine jac. they are not C altered by ddassl. if you do not need rpar or ipar, igno C these parameters by treating them as dummy arguments. if C you do choose to use them, dimension them in your callin C program and in jac as arrays of appropriate length. C C C C optionally replaceable norm routine: C ddassl uses a weighted norm ddanrm to measure the size C of vectors such as the estimated error in each step. C a function subprogram C double precision function ddanrm(neq,v,wt,rpar,ipar) C dimension v(neq),wt(neq) C is used to define this norm. here, v is the vector C whose norm is to be computed, and wt is a vector of C weights. a ddanrm routine has been included with ddassl C which computes the weighted root-mean-square norm C given by C ddanrm=sqrt((1/neq)*sum(v(i)/wt(i))**2) C this norm is suitable for most problems. in some C special cases, it may be more convenient and/or C efficient to define your own norm by writing a function C subprogram to be called instead of ddanrm. this should C however, be attempted only after careful thought and C consideration. C C C------output-after any return from ddassl---- C C the principal aim of the code is to return a computed solution at C tout, although it is also possible to obtain intermediate results C along the way. to find out whether the code achieved its goal C or if the integration process was interrupted before the task was C completed, you must check the idid parameter. C C C t -- the solution was successfully advanced to the C output value of t. C C y(*) -- contains the computed solution approximation at t. C C yprime(*) -- contains the computed derivative C approximation at t C C idid -- reports what the code did C C *** task completed *** C reported by positive values of idid C C idid = 1 -- a step was successfully taken in the C intermediate-output mode. the code has not C yet reached tout. C C idid = 2 -- the integration to tout was successfully C completed (t=tout) by stepping exactly to tout. C C idid = 3 -- the integration to tout was successfully C completed (t=tout) by stepping past tout. C y(*) is obtained by interpolation. C yprime(*) is obtained by interpolation. C C *** task interrupted *** C reported by negative values of idid C C idid = -1 -- a large amount of work has been expended. C (about 500 steps) C C idid = -2 -- the error tolerances are too stringent. C C idid = -3 -- the local error test cannot be satisfied C because you specified a zero component in atol C and the corresponding computed solution C component is zero. thus, a pure relative error C test is impossible for this component. C C idid = -6 -- ddassl had repeated error test C failures on the last attempted step. C C idid = -7 -- the corrector could not converge. C C idid = -8 -- the matrix of partial derivatives C is singular. C C idid = -9 -- the corrector could not converge. C there were repeated error test failures C in this step. C C idid =-10 -- the corrector could not converge C because ires was equal to minus one. C C idid =-11 -- ires equal to -2 was encountered C and control is being returned to the C calling program. C C idid =-12 -- ddassl failed to compute the initial C yprime. C C C C idid = -13,..,-32 -- not applicable for this code C C *** task terminated *** C reported by the value of idid=-33 C C idid = -33 -- the code has encountered trouble from which C it cannot recover. a message is printed C explaining the trouble and control is returned C to the calling program. for example, this occurs C when invalid input is detected. C C rtol, atol -- these quantities remain unchanged except when C idid = -2. in this case, the error tolerances have been C increased by the code to values which are estimated to b C appropriate for continuing the integration. however, the C reported solution at t was obtained using the input valu C of rtol and atol. C C rwork, iwork -- contain information which is usually of no C interest to the user but necessary for subsequent calls. C however, you may find use for C C rwork(3)--which contains the step size h to be C attempted on the next step. C C rwork(4)--which contains the current value of the C independent variable, i.e. the farthest point C integration has reached. this will be different C from t only when interpolation has been C performed (idid=3). C C rwork(7)--which contains the stepsize used C on the last successful step. C C iwork(7)--which contains the order of the method to C be attempted on the next step. C C iwork(8)--which contains the order of the method used C on the last step. C C iwork(11)--which contains the number of steps taken so f C C iwork(12)--which contains the number of calls to res C so far. C C iwork(13)--which contains the number of evaluations of C the matrix of partial derivatives needed so far C C iwork(14)--which contains the total number C of error test failures so far. C C iwork(15)--which contains the total number C of convergence test failures so far. C (includes singular iteration matrix C failures.) C C C C input -- what to do to continue the integration C (calls after the first) ** C C this code is organized so that subsequent calls to continue the C integration involve little (if any) additional effort on your C part. you must monitor the idid parameter in order to determine C what to do next. C C recalling that the principal task of the code is to integrate C from t to tout (the interval mode), usually all you will need C to do is specify a new tout upon reaching the current tout. C C do not alter any quantity not specifically permitted below, C in particular do not alter neq,t,y(*),yprime(*),rwork(*),iwork(*) C or the differential equation in subroutine res. any such C alteration constitutes a new problem and must be treated as such, C i.e. you must start afresh. C C you cannot change from vector to scalar error control or vice C versa (info(2)) but you can change the size of the entries of C rtol, atol. increasing a tolerance makes the equation easier C to integrate. decreasing a tolerance will make the equation C harder to integrate and should generally be avoided. C C you can switch from the intermediate-output mode to the C interval mode (info(3)) or vice versa at any time. C C if it has been necessary to prevent the integration from going C past a point tstop (info(4), rwork(1)), keep in mind that the C code will not integrate to any tout beyound the currently C specified tstop. once tstop has been reached you must change C the value of tstop or set info(4)=0. you may change info(4) C or tstop at any time but you must supply the value of tstop in C rwork(1) whenever you set info(4)=1. C C do not change info(5), info(6), iwork(1), or iwork(2) C unless you are going to restart the code. C C *** following a completed task *** C if C idid = 1, call the code again to continue the integration C another step in the direction of tout. C C idid = 2 or 3, define a new tout and call the code again. C tout must be different from t. you cannot change C the direction of integration without restarting. C C *** following an interrupted task *** C to show the code that you realize the task was C interrupted and that you want to continue, you C must take appropriate action and set info(1) = 1 C if C idid = -1, the code has taken about 500 steps. C if you want to continue, set info(1) = 1 and C call the code again. an additional 500 steps C will be allowed. C C C idid = -2, the error tolerances rtol, atol have been C increased to values the code estimates appropriate C for continuing. you may want to change them C yourself. if you are sure you want to continue C with relaxed error tolerances, set info(1)=1 and C call the code again. C C idid = -3, a solution component is zero and you set the C corresponding component of atol to zero. if you C are sure you want to continue, you must first C alter the error criterion to use positive values C for those components of atol corresponding to zero C solution components, then set info(1)=1 and call C the code again. C C idid = -4,-5 --- cannot occur with this code C C idid = -6, repeated error test failures occurred on the C last attempted step in ddassl. a singularity in the C solution may be present. if you are absolutely C certain you want to continue, you should restart C the integration.(provide initial values of y and C yprime which are consistent) C C idid = -7, repeated convergence test failures occurred C on the last attempted step in ddassl. an inaccurate o C illconditioned jacobian may be the problem. if you C are absolutely certain you want to continue, you C should restart the integration. C C idid = -8, the matrix of partial derivatives is singular. C some of your equations may be redundant. C ddassl cannot solve the problem as stated. C it is possible that the redundant equations C could be removed, and then ddassl could C solve the problem. it is also possible C that a solution to your problem either C does not exist or is not unique. C C idid = -9, ddassl had multiple convergence test C failures, preceeded by multiple error C test failures, on the last attempted step. C it is possible that your problem C is ill-posed, and cannot be solved C using this code. or, there may be a C discontinuity or a singularity in the C solution. if you are absolutely certain C you want to continue, you should restart C the integration. C C idid =-10, ddassl had multiple convergence test failures C because ires was equal to minus one. C if you are absolutely certain you want C to continue, you should restart the C integration. C C idid =-11, ires=-2 was encountered, and control is being C returned to the calling program. C C idid =-12, ddassl failed to compute the initial yprime. C this could happen because the initial C approximation to yprime was not very good, or C if a yprime consistent with the initial y C does not exist. the problem could also be caused C by an inaccurate or singular iteration matrix. C C C C idid = -13,..,-32 --- cannot occur with this code C C *** following a terminated task *** C if idid= -33, you cannot continue the solution of this C problem. an attempt to do so will result in your C run being terminated. C C --------------------------------------------------------------------- C C***REFERENCES A DESCRIPTION OF DASSL: A DIFFERENTIAL/ALGEBRAIC C SYSTEM SOLVER, L. R. PETZOLD, SAND82-8637, C SANDIA NATIONAL LABORATORIES, SEPTEMBER 1982. C***ROUTINES CALLED DDASTP,DDAINI,DDANRM,DDAWTS,DDATRP,XERRWV,D1MACH C***COMMON BLOCKS DDA001 C***END PROLOGUE DDASSL C C IMPLICIT REAL*8 (A-H,O-Z) LOGICAL DONE EXTERNAL RES,JAC DIMENSION Y(1),YPRIME(1) DIMENSION INFO(15) DIMENSION RWORK(1),IWORK(1) DIMENSION RTOL(1),ATOL(1) DIMENSION RPAR(1),IPAR(1) COMMON/SDEV2/ ITRACE, IDEV COMMON /SDDTR/ TERKP1, TERK, TERKM1, TERKM2 COMMON/DDA001/NPD,NTEMP, * LML,LMU,LMXORD,LMTYPE, * LNST,LNRE,LNJE,LETF,LCTF,LIPVT DATA LTSTOP,LHMAX,LH,LTN, * LCJ,LCJOLD,LHOLD,LS,LROUND, * LALPHA,LBETA,LGAMMA, * LPSI,LSIGMA,LDELTA * /1,2,3,4, * 5,6,7,8,9, * 11,17,23, * 29,35,41/ IF(INFO(1).NE.0)GO TO 100 C C----------------------------------------------------------------------- C this block is executed for the initial call only. C it contains checking of inputs and initializations. C----------------------------------------------------------------------- C C first check info array to make sure all elements of info C are either zero or one. DO 10 I=2,11 IF(INFO(I).NE.0.AND.INFO(I).NE.1)GO TO 701 10 CONTINUE C IF(NEQ.LE.0)GO TO 702 C C set pointers into iwork LML=1 LMU=2 LMXORD=3 LMTYPE=4 LJCALC=5 LPHASE=6 LK=7 LKOLD=8 LNS=9 LNSTL=10 LNST=11 LNRE=12 LNJE=13 LETF=14 LCTF=15 LIPVT=21 LIWM=1 C C check and compute maximum order MXORD=5 IF(INFO(9).EQ.0)GO TO 20 MXORD=IWORK(LMXORD) IF(MXORD.LT.1.OR.MXORD.GT.5)GO TO 703 20 IWORK(LMXORD)=MXORD C C compute mtype,lenpd,lenrw.check ml and mu. IF(INFO(6).NE.0)GO TO 40 LENPD=NEQ**2 LENRW=40+(IWORK(LMXORD)+4)*NEQ+LENPD IF(INFO(5).NE.0)GO TO 30 IWORK(LMTYPE)=2 GO TO 60 30 IWORK(LMTYPE)=1 GO TO 60 40 IF(IWORK(LML).LT.0.OR.IWORK(LML).GE.NEQ)GO TO 717 IF(IWORK(LMU).LT.0.OR.IWORK(LMU).GE.NEQ)GO TO 718 LENPD=(2*IWORK(LML)+IWORK(LMU)+1)*NEQ IF(INFO(5).NE.0)GO TO 50 IWORK(LMTYPE)=5 MBAND=IWORK(LML)+IWORK(LMU)+1 MSAVE=(NEQ/MBAND)+1 LENRW=40+(IWORK(LMXORD)+4)*NEQ+LENPD+2*MSAVE GO TO 60 50 IWORK(LMTYPE)=4 LENRW=40+(IWORK(LMXORD)+4)*NEQ+LENPD C C check lengths of rwork and iwork 60 LENIW=20+NEQ IF(LRW.LT.LENRW)GO TO 704 IF(LIW.LT.LENIW)GO TO 705 C C check to see that tout is different from t IF(TOUT .EQ. T)GO TO 719 C C check hmax IF(INFO(7).EQ.0)GO TO 70 HMAX=RWORK(LHMAX) IF(HMAX.LE.0.0D0)GO TO 710 70 CONTINUE C C initialize counters IWORK(LNST)=0 IWORK(LNRE)=0 IWORK(LNJE)=0 C IWORK(LNSTL)=0 IDID=1 GO TO 200 C C----------------------------------------------------------------------- C this block is for continuation calls C only. here we check info(1),and if the C last step was interrupted we check whether C appropriate action was taken. C----------------------------------------------------------------------- C 100 CONTINUE IF(INFO(1).EQ.1)GO TO 110 IF(INFO(1).NE.-1)GO TO 701 C if we are here, the last step was interrupted C by an error condition from ddastp,and C appropriate action was not taken. this C is a fatal error. CALL XERRWV( *49HDASSL-- THE LAST STEP TERMINATED WITH A NEGATIVE, *49,201,0,0,0,0,0,0.0D0,0.0D0) CALL XERRWV( *47HDASSL-- VALUE (=I1) OF IDID AND NO APPROPRIATE, *47,202,0,1,IDID,0,0,0.0D0,0.0D0) CALL XERRWV( *41HDASSL-- ACTION WAS TAKEN. RUN TERMINATED, *41,203,1,0,0,0,0,0.0D0,0.0D0) RETURN 110 CONTINUE IWORK(LNSTL)=IWORK(LNST) C C----------------------------------------------------------------------- C this block is executed on all calls. C the error tolerance parameters are C checked, and the work array pointers C are set. C----------------------------------------------------------------------- C 200 CONTINUE C check rtol,atol NZFLG=0 RTOLI=RTOL(1) ATOLI=ATOL(1) DO 210 I=1,NEQ IF(INFO(2).EQ.1)RTOLI=RTOL(I) IF(INFO(2).EQ.1)ATOLI=ATOL(I) IF(RTOLI.GT.0.0D0.OR.ATOLI.GT.0.0D0)NZFLG=1 IF(RTOLI.LT.0.0D0)GO TO 706 IF(ATOLI.LT.0.0D0)GO TO 707 210 CONTINUE IF(NZFLG.EQ.0)GO TO 708 C C set up rwork storage.iwork storage is fixed C in data statement. LE=LDELTA+NEQ LWT=LE+NEQ LPHI=LWT+NEQ LPD=LPHI+(IWORK(LMXORD)+1)*NEQ LWM=LPD NPD=1 NTEMP=NPD+LENPD IF(INFO(1).EQ.1)GO TO 400 C C----------------------------------------------------------------------- C this block is executed on the initial call C only. set the initial step size, and C the error weight vector, and phi. C compute initial yprime, if necessary. C----------------------------------------------------------------------- C 300 CONTINUE TN=T IDID=1 C C set error weight vector wt CALL DDAWTS(NEQ,INFO(2),RTOL,ATOL,Y,RWORK(LWT),RPAR,IPAR) DO 305 I = 1,NEQ IF(RWORK(LWT+I-1).LE.0.0D0) GO TO 713 305 CONTINUE C C compute unit roundoff and hmin UROUND = D1MACH(4) RWORK(LROUND) = UROUND HMIN = 4.0D0*UROUND*DMAX1(DABS(T),DABS(TOUT)) C C check initial interval to see that it is long enough TDIST = DABS(TOUT - T) IF(TDIST .LT. HMIN) GO TO 714 C C check ho, if this was input IF (INFO(8) .EQ. 0) GO TO 310 HO = RWORK(LH) IF ((TOUT - T)*HO .LT. 0.0D0) GO TO 711 IF (HO .EQ. 0.0D0) GO TO 712 GO TO 320 310 CONTINUE C C compute initial stepsize, to be used by either C ddastp or ddaini, depending on info(11) HO = 0.001D0*TDIST YPNORM = DDANRM(NEQ,YPRIME,RWORK(LWT),RPAR,IPAR) IF (YPNORM .GT. 0.5D0/HO) HO = 0.5D0/YPNORM HO = DSIGN(HO,TOUT-T) C adjust ho if necessary to meet hmax bound 320 IF (INFO(7) .EQ. 0) GO TO 330 RH = DABS(HO)/HMAX IF (RH .GT. 1.0D0) HO = HO/RH C compute tstop, if applicable 330 IF (INFO(4) .EQ. 0) GO TO 340 TSTOP = RWORK(LTSTOP) IF ((TSTOP - T)*HO .LT. 0.0D0) GO TO 715 IF ((T + HO - TSTOP)*HO .GT. 0.0D0) HO = TSTOP - T IF ((TSTOP - TOUT)*HO .LT. 0.0D0) GO TO 709 C C compute initial derivative, if applicable 340 IF (INFO(11) .EQ. 0) GO TO 350 CALL DDAINI(T,Y,YPRIME,NEQ, * RES,JAC,HO,RWORK(LWT),IDID,RPAR,IPAR, * RWORK(LPHI),RWORK(LDELTA),RWORK(LE), * RWORK(LWM),IWORK(LIWM),HMIN,RWORK(LROUND),INFO(10)) IF(ITRACE .GE. 1)WRITE(IDEV,349)IDID 349 FORMAT(' IDID FROM INIT SOLVER IS ',I3) IF (IDID .LT. 0) GO TO 390 C C load h with ho. store h in rwork(lh) 350 H = HO RWORK(LH) = H C C load y and h*yprime into phi(*,1) and phi(*,2) 360 ITEMP = LPHI + NEQ DO 370 I = 1,NEQ RWORK(LPHI + I - 1) = Y(I) 370 RWORK(ITEMP + I - 1) = H*YPRIME(I) C 390 GO TO 500 C C------------------------------------------------------- C this block is for continuation calls only. its C purpose is to check stop conditions before C taking a step. C adjust h if necessary to meet hmax bound C------------------------------------------------------- C 400 CONTINUE DONE = .FALSE. TN=RWORK(LTN) H=RWORK(LH) IF(INFO(7) .EQ. 0) GO TO 410 RH = DABS(H)/HMAX IF(RH .GT. 1.0D0) H = H/RH 410 CONTINUE IF(T .EQ. TOUT) GO TO 719 IF((T - TOUT)*H .GT. 0.0D0) GO TO 711 IF(INFO(4) .EQ. 1) GO TO 430 IF(INFO(3) .EQ. 1) GO TO 420 IF((TN-TOUT)*H.LT.0.0D0)GO TO 490 CALL DDATRP(TN,TOUT,Y,YPRIME,NEQ,IWORK(LKOLD), * RWORK(LPHI),RWORK(LPSI)) T=TOUT IDID = 3 DONE = .TRUE. GO TO 490 420 IF((TN-T)*H .LE. 0.0D0) GO TO 490 IF((TN - TOUT)*H .GT. 0.0D0) GO TO 425 CALL DDATRP(TN,TN,Y,YPRIME,NEQ,IWORK(LKOLD), * RWORK(LPHI),RWORK(LPSI)) T = TN IDID = 1 DONE = .TRUE. GO TO 490 425 CONTINUE CALL DDATRP(TN,TOUT,Y,YPRIME,NEQ,IWORK(LKOLD), * RWORK(LPHI),RWORK(LPSI)) T = TOUT IDID = 3 DONE = .TRUE. GO TO 490 430 IF(INFO(3) .EQ. 1) GO TO 440 TSTOP=RWORK(LTSTOP) IF((TN-TSTOP)*H.GT.0.0D0) GO TO 715 IF((TSTOP-TOUT)*H.LT.0.0D0)GO TO 709 IF((TN-TOUT)*H.LT.0.0D0)GO TO 450 CALL DDATRP(TN,TOUT,Y,YPRIME,NEQ,IWORK(LKOLD), * RWORK(LPHI),RWORK(LPSI)) T=TOUT IDID = 3 DONE = .TRUE. GO TO 490 440 TSTOP = RWORK(LTSTOP) IF((TN-TSTOP)*H .GT. 0.0D0) GO TO 715 IF((TSTOP-TOUT)*H .LT. 0.0D0) GO TO 709 IF((TN-T)*H .LE. 0.0D0) GO TO 450 IF((TN - TOUT)*H .GT. 0.0D0) GO TO 445 CALL DDATRP(TN,TN,Y,YPRIME,NEQ,IWORK(LKOLD), * RWORK(LPHI),RWORK(LPSI)) T = TN IDID = 1 DONE = .TRUE. GO TO 490 445 CONTINUE CALL DDATRP(TN,TOUT,Y,YPRIME,NEQ,IWORK(LKOLD), * RWORK(LPHI),RWORK(LPSI)) T = TOUT IDID = 3 DONE = .TRUE. GO TO 490 450 CONTINUE C check whether we are with in roundoff of tstop IF(DABS(TN-TSTOP).GT.100.0D0*UROUND* * (DABS(TN)+DABS(H)))GO TO 460 IDID=2 T=TSTOP DONE = .TRUE. GO TO 490 460 TNEXT=TN+H*(1.0D0+4.0D0*UROUND) IF((TNEXT-TSTOP)*H.LE.0.0D0)GO TO 490 H=(TSTOP-TN)*(1.0D0-4.0D0*UROUND) RWORK(LH)=H C 490 IF (DONE) GO TO 590 C C------------------------------------------------------- C the next block contains the call to the C one-step integrator ddastp. C this is a looping point for the integration C steps. C check for too many steps. C update wt. C check for too much accuracy requested. C compute minimum stepsize. C------------------------------------------------------- C 500 CONTINUE C check for failure to compute initial yprime IF (IDID .EQ. -12) GO TO 527 C C check for too many steps IF((IWORK(LNST)-IWORK(LNSTL)).LT.500) * GO TO 510 IDID=-1 GO TO 527 C C update wt 510 CALL DDAWTS(NEQ,INFO(2),RTOL,ATOL,RWORK(LPHI), * RWORK(LWT),RPAR,IPAR) DO 520 I=1,NEQ IF(RWORK(I+LWT-1).GT.0.0D0)GO TO 520 IDID=-3 GO TO 527 520 CONTINUE C C test for too much accuracy requested. R=DDANRM(NEQ,RWORK(LPHI),RWORK(LWT),RPAR,IPAR)* * 100.0D0*UROUND C IF(ITRACE.GE.1 .AND. R.GT.1.0D0)WRITE(IDEV,521)RTOL(1),ATOL(1),R, C * UROUND C521 FORMAT(' TOLS ',2D11.3,' MUST BE MULT BY R=',D11.3,' UR =',D11.3) IF(R.LE.1.0D0 )GO TO 525 C multiply rtol and atol by r and return IF(INFO(2).EQ.1)GO TO 523 RTOL(1)=R*RTOL(1) ATOL(1)=R*ATOL(1) IDID=-2 GO TO 527 523 DO 524 I=1,NEQ RTOL(I)=R*RTOL(I) 524 ATOL(I)=R*ATOL(I) IDID=-2 GO TO 527 525 CONTINUE C C compute minimum stepsize HMIN=4.0D0*UROUND*DMAX1(DABS(TN),DABS(TOUT)) C CALL DDASTP(TN,Y,YPRIME,NEQ, * RES,JAC,H,RWORK(LWT),INFO(1),IDID,RPAR,IPAR, * RWORK(LPHI),RWORK(LDELTA),RWORK(LE), * RWORK(LWM),IWORK(LIWM), * RWORK(LALPHA),RWORK(LBETA),RWORK(LGAMMA), * RWORK(LPSI),RWORK(LSIGMA), * RWORK(LCJ),RWORK(LCJOLD),RWORK(LHOLD), * RWORK(LS),HMIN,RWORK(LROUND), * IWORK(LPHASE),IWORK(LJCALC),IWORK(LK), * IWORK(LKOLD),IWORK(LNS),INFO(10)) 527 IF(IDID.LT.0)GO TO 600 C C------------------------------------------------------ C this block handles the case of a successful C return from ddastp (idid=1) test for C stop conditions. C-------------------------------------------------------- C IF(ITRACE .GE. 1)WRITE(IDEV,528)TN,H, IWORK(LKOLD) C IF(ITRACE .GE. 1)WRITE(IDEV,5281)TERKP1, TERK, TERKM1, TERKM2 528 FORMAT(' AT T= ',D11.3,' H=',D11.3,' ORDER=',I3) 5281 FORMAT(' ERRORS FOR DESCENDING ORDERS ARE ',4D11.3) C CALL DASMON(NEQ, TN, H, Y, YPRIME, IWORK(LKOLD)) IF(INFO(4).NE.0)GO TO 540 IF(INFO(3).NE.0)GO TO 530 IF((TN-TOUT)*H.LT.0.0D0)GO TO 500 CALL DDATRP(TN,TOUT,Y,YPRIME,NEQ, * IWORK(LKOLD),RWORK(LPHI),RWORK(LPSI)) IDID=3 T=TOUT GO TO 580 530 IF((TN-TOUT)*H.GE.0.0D0)GO TO 535 T=TN IDID=1 GO TO 580 535 CALL DDATRP(TN,TOUT,Y,YPRIME,NEQ, * IWORK(LKOLD),RWORK(LPHI),RWORK(LPSI)) IDID=3 T=TOUT GO TO 580 540 IF(INFO(3).NE.0)GO TO 550 IF((TN-TOUT)*H.LT.0.0D0)GO TO 542 CALL DDATRP(TN,TOUT,Y,YPRIME,NEQ, * IWORK(LKOLD),RWORK(LPHI),RWORK(LPSI)) T=TOUT IDID=3 GO TO 580 542 IF(DABS(TN-TSTOP).LE.100.0D0*UROUND* * (DABS(TN)+DABS(H)))GO TO 545 TNEXT=TN+H*(1.0D0+4.0D0*UROUND) IF((TNEXT-TSTOP)*H.LE.0.0D0)GO TO 500 H=(TSTOP-TN)*(1.0D0-4.0D0*UROUND) GO TO 500 545 IDID=2 T=TSTOP GO TO 580 550 IF((TN-TOUT)*H.GE.0.0D0)GO TO 555 IF(DABS(TN-TSTOP).LE.100.0D0*UROUND*(DABS(TN)+DABS(H)))GO TO 552 T=TN IDID=1 GO TO 580 552 IDID=2 T=TSTOP GO TO 580 555 CALL DDATRP(TN,TOUT,Y,YPRIME,NEQ, * IWORK(LKOLD),RWORK(LPHI),RWORK(LPSI)) T=TOUT IDID=3 580 CONTINUE C C-------------------------------------------------------- C all successful returns from ddassl are made from C this block. C-------------------------------------------------------- C 590 CONTINUE RWORK(LTN)=TN RWORK(LH)=H RETURN C C----------------------------------------------------------------------- C this block handles all unsuccessful C returns other than for illegal input. C----------------------------------------------------------------------- C 600 CONTINUE ITEMP=-IDID GO TO (610,620,630,690,690,640,650,660,670,675, * 680,685), ITEMP C C the maximum number of steps was taken before C reaching tout 610 CALL XERRWV( *38HDASSL-- AT CURRENT T (=R1) 500 STEPS, *38,610,0,0,0,0,1,TN,0.0D0) CALL XERRWV(48HDASSL-- TAKEN ON THIS CALL BEFORE REACHING TOUT, *48,611,0,0,0,0,0,0.0D0,0.0D0) GO TO 690 C C too much accuracy for machine precision 620 CALL XERRWV( *47HDASSL-- AT T (=R1) TOO MUCH ACCURACY REQUESTED, *47,620,0,0,0,0,1,TN,0.0D0) CALL XERRWV( *48HDASSL-- FOR PRECISION OF MACHINE. RTOL AND ATOL, *48,621,0,0,0,0,0,0.0D0,0.0D0) CALL XERRWV( *45HDASSL-- WERE INCREASED TO APPROPRIATE VALUES, *45,622,0,0,0,0,0,0.0D0,0.0D0) C GO TO 690 C wt(i) .le. 0.0d0 for some i (not at start of problem) 630 CALL XERRWV( *38HDASSL-- AT T (=R1) SOME ELEMENT OF WT, *38,630,0,0,0,0,1,TN,0.0D0) CALL XERRWV(28HDASSL-- HAS BECOME .LE. 0.0, *28,631,0,0,0,0,0,0.0D0,0.0D0) GO TO 690 C C error test failed repeatedly or with h=hmin 640 CALL XERRWV( *44HDASSL-- AT T (=R1) AND STEPSIZE H (=R2) THE, *44,640,0,0,0,0,2,TN,H) CALL XERRWV( *57HDASSL-- ERROR TEST FAILED REPEATEDLY OR WITH ABS(H)=HMIN, *57,641,0,0,0,0,0,0.0D0,0.0D0) GO TO 690 C C corrector convergence failed repeatedly or with h=hmin 650 CALL XERRWV( *44HDASSL-- AT T (=R1) AND STEPSIZE H (=R2) THE, *44,650,0,0,0,0,2,TN,H) CALL XERRWV( *48HDASSL-- CORRECTOR FAILED TO CONVERGE REPEATEDLY, *48,651,0,0,0,0,0,0.0D0,0.0D0) CALL XERRWV( *28HDASSL-- OR WITH ABS(H)=HMIN, *28,652,0,0,0,0,0,0.0D0,0.0D0) GO TO 690 C C the iteration matrix is singular 660 CALL XERRWV( *44HDASSL-- AT T (=R1) AND STEPSIZE H (=R2) THE, *44,660,0,0,0,0,2,TN,H) CALL XERRWV( *37HDASSL-- ITERATION MATRIX IS SINGULAR, *37,661,0,0,0,0,0,0.0D0,0.0D0) GO TO 690 C C corrector failure preceeded by error test failures. 670 CALL XERRWV( *44HDASSL-- AT T (=R1) AND STEPSIZE H (=R2) THE, *44,670,0,0,0,0,2,TN,H) CALL XERRWV( *49HDASSL-- CORRECTOR COULD NOT CONVERGE. ALSO, THE, *49,671,0,0,0,0,0,0.0D0,0.0D0) CALL XERRWV( *38HDASSL-- ERROR TEST FAILED REPEATEDLY., *38,672,0,0,0,0,0,0.0D0,0.0D0) GO TO 690 C C corrector failure because ires = -1 675 CALL XERRWV( *44HDASSL-- AT T (=R1) AND STEPSIZE H (=R2) THE, *44,675,0,0,0,0,2,TN,H) CALL XERRWV( *45HDASSL-- CORRECTOR COULD NOT CONVERGE BECAUSE, *455,676,0,0,0,0,0,0.0D0,0.0D0) CALL XERRWV( *36HDASSL-- IRES WAS EQUAL TO MINUS ONE, *36,677,0,0,0,0,0,0.0D0,0.0D0) GO TO 690 C C failure because ires = -2 680 CALL XERRWV( *40HDASSL-- AT T (=R1) AND STEPSIZE H (=R2), *40,680,0,0,0,0,2,TN,H) CALL XERRWV( *36HDASSL-- IRES WAS EQUAL TO MINUS TWO, *36,681,0,0,0,0,0,0.0D0,0.0D0) GO TO 690 C C failed to compute initial yprime 685 CALL XERRWV( *44HDASSL-- AT T (=R1) AND STEPSIZE H (=R2) THE, *44,685,0,0,0,0,2,TN,HO) CALL XERRWV( *45HDASSL-- INITIAL YPRIME COULD NOT BE COMPUTED, *45,686,0,0,0,0,0,0.0D0,0.0D0) GO TO 690 690 CONTINUE INFO(1)=-1 T=TN RWORK(LTN)=TN RWORK(LH)=H RETURN C----------------------------------------------------------------------- C this block handles all error returns due C to illegal input, as detected before calling C ddastp. first the error message routine is C called. if this happens twice in C succession, execution is terminated C C----------------------------------------------------------------------- 701 CALL XERRWV( *55HDASSL-- SOME ELEMENT OF INFO VECTOR IS NOT ZERO OR ONE, *55,1,0,0,0,0,0,0.0D0,0.0D0) GO TO 750 702 CALL XERRWV(25HDASSL-- NEQ (=I1) .LE. 0, *25,2,0,1,NEQ,0,0,0.0D0,0.0D0) GO TO 750 703 CALL XERRWV(34HDASSL-- MAXORD (=I1) NOT IN RANGE, *34,3,0,1,MXORD,0,0,0.0D0,0.0D0) GO TO 750 704 CALL XERRWV( *60HDASSL-- RWORK LENGTH NEEDED, LENRW (=I1), EXCEEDS LRW (=I2), *60,4,0,2,LENRW,LRW,0,0.0D0,0.0D0) GO TO 750 705 CALL XERRWV( *60HDASSL-- IWORK LENGTH NEEDED, LENIW (=I1), EXCEEDS LIW (=I2), *60,5,0,2,LENIW,LIW,0,0.0D0,0.0D0) GO TO 750 706 CALL XERRWV( *39HDASSL-- SOME ELEMENT OF RTOL IS .LT. 0, *39,6,0,0,0,0,0,0.0D0,0.0D0) GO TO 750 707 CALL XERRWV( *39HDASSL-- SOME ELEMENT OF ATOL IS .LT. 0, *39,7,0,0,0,0,0,0.0D0,0.0D0) GO TO 750 708 CALL XERRWV( *47HDASSL-- ALL ELEMENTS OF RTOL AND ATOL ARE ZERO, *47,8,0,0,0,0,0,0.0D0,0.0D0) GO TO 750 709 CALL XERRWV( *54HDASSL-- INFO(4) = 1 AND TSTOP (=R1) BEHIND TOUT (=R2), *54,9,0,0,0,0,2,TSTOP,TOUT) GO TO 750 710 CALL XERRWV(28HDASSL-- HMAX (=R1) .LT. 0.0, *28,10,0,0,0,0,1,HMAX,0.0D0) GO TO 750 711 CALL XERRWV(34HDASSL-- TOUT (=R1) BEHIND T (=R2), *34,11,0,0,0,0,2,TOUT,T) GO TO 750 712 CALL XERRWV(29HDASSL-- INFO(8)=1 AND H0=0.0, *29,12,0,0,0,0,0,0.0D0,0.0D0) GO TO 750 713 CALL XERRWV(39HDASSL-- SOME ELEMENT OF WT IS .LE. 0.0, *39,13,0,0,0,0,0,0.0D0,0.0D0) GO TO 750 714 CALL XERRWV( *61HDASSL-- TOUT (=R1) TOO CLOSE TO T (=R2) TO START INTEGRATION, *61,14,0,0,0,0,2,TOUT,T) GO TO 750 715 CALL XERRWV( *49HDASSL-- INFO(4)=1 AND TSTOP (=R1) BEHIND T (=R2), *49,15,0,0,0,0,2,TSTOP,T) GO TO 750 717 CALL XERRWV( *52HDASSL-- ML (=I1) ILLEGAL. EITHER .LT. 0 OR .GT. NEQ, *52,17,0,1,IWORK(LML),0,0,0.0D0,0.0D0) GO TO 750 718 CALL XERRWV( *52HDASSL-- MU (=I1) ILLEGAL. EITHER .LT. 0 OR .GT. NEQ, *52,18,0,1,IWORK(LMU),0,0,0.0D0,0.0D0) GO TO 750 719 CALL XERRWV( *39HDASSL-- TOUT (=R1) IS EQUAL TO T (=R2), *39,19,0,0,0,0,2,TOUT,T) GO TO 750 750 IF(INFO(1).EQ.-1) GO TO 760 INFO(1)=-1 IDID=-33 RETURN 760 CALL XERRWV( *46HDASSL-- REPEATED OCCURRENCES OF ILLEGAL INPUT, *46,801,0,0,0,0,0,0.0D0,0.0D0) 770 CALL XERRWV( *47HDASSL-- RUN TERMINATED. APPARENT INFINITE LOOP, *47,802,1,0,0,0,0,0.0D0,0.0D0) RETURN C-----------end of subroutine ddassl------------------------------------ END SUBROUTINE DDAWTS(NEQ,IWT,RTOL,ATOL,Y,WT,RPAR,IPAR) C C***BEGIN PROLOGUE DDAWTS C***REFER TO DDASSL C***ROUTINES CALLED (NONE) C***DATE WRITTEN 830315 (YYMMDD) C***REVISION DATE 830315 (YYMMDD) C***END PROLOGUE DDAWTS C----------------------------------------------------------------------- C this subroutine sets the error weight vector C wt according to wt(i)=rtol(i)*abs(y(i))+atol(i), C i=1,-,n. C rtol and atol are scalars if iwt = 0, C and vectors if iwt = 1. C----------------------------------------------------------------------- C IMPLICIT REAL*8 (A-H,O-Z) DIMENSION RTOL(1),ATOL(1),Y(1),WT(1) DIMENSION RPAR(1),IPAR(1) RTOLI=RTOL(1) ATOLI=ATOL(1) DO 20 I=1,NEQ IF (IWT .EQ.0) GO TO 10 RTOLI=RTOL(I) ATOLI=ATOL(I) 10 WT(I)=RTOLI*DABS(Y(I))+ATOLI 20 CONTINUE RETURN C-----------end of subroutine ddawts------------------------------------ END SUBROUTINE DDASTP(X,Y,YPRIME,NEQ, * RES,JAC,H,WT,JSTART,IDID,RPAR,IPAR, * PHI,DELTA,E,WM,IWM, * ALPHA,BETA,GAMMA,PSI,SIGMA, * CJ,CJOLD,HOLD,S,HMIN,UROUND, * IPHASE,JCALC,K,KOLD,NS,NONNEG) C C***BEGIN PROLOGUE DDASTP C***REFER TO DDASSL C***ROUTINES CALLED DDANRM,DDAJAC,DDASLV,DDATRP C***COMMON BLOCKS DDA001 C***DATE WRITTEN 830315 (YYMMDD) C***REVISION DATE 830315 (YYMMDD) C***END PROLOGUE DDASTP C C C----------------------------------------------------------------------- C dastep solves a system of differential/ C algebraic equations of the form C g(x,y,yprime) = 0, for one step (normally C from x to x+h). C C the methods used are modified divided C difference,fixed leading coefficient C forms of backward differentiation C formulas. the code adjusts the stepsize C and order to control the local error per C step. C C C the parameters represent C x -- independent variable C y -- solution vector at x C yprime -- derivative of solution vector C after successful step C neq -- number of equations to be integrated C res -- external user-supplied subroutine C to evaluate the residual. the call is C call res(x,y,yprime,delta,ires,rpar,ipar) C x,y,yprime are input. delta is output. C on input, ires=0. res should alter ires only C if it encounters an illegal value of y or a C stop condition. set ires=-1 if an input value C of y is illegal, and dastep will try to solve C the problem without getting ires = -1. if C ires=-2, dastep returns control to the calling C program with idid = -11. C jac -- external user-supplied routine to evaluate C the iteration matrix (this is optional) C the call is of the form C call jac(x,y,yprime,pd,cj,rpar,ipar) C pd is the matrix of partial derivatives, C pd=dg/dy+cj*dg/dyprime C h -- appropriate step size for next step. C normally determined by the code C wt -- vector of weights for error criterion. C jstart -- integer variable set 0 for C first step, 1 otherwise. C idid -- completion code with the following meanings% C idid= 1 -- the step was completed successfully C idid=-6 -- the error test failed repeatedly C idid=-7 -- the corrector could not converge C idid=-8 -- the iteration matrix is singular C idid=-9 -- the corrector could not converge. C there were repeated error test C failures on this step. C idid=-10-- the corrector could not converge C because ires was equal to minus one C idid=-11-- ires equal to -2 was encountered, C and control is being returned to C the calling program C rpar,ipar -- real and integer parameter arrays that C are used for communication between the C calling program and external user routines C they are not altered by dastep C phi -- array of divided differences used by C dastep. the length is neq*(k+1),where C k is the maximum order C delta,e -- work vectors for dastep of length neq C wm,iwm -- real and integer arrays storing C matrix information such as the matrix C of partial derivatives,permutation C vector,and various other information. C C the other parameters are information C which is needed internally by dastep to C continue from step to step. C C----------------------------------------------------------------------- C C C IMPLICIT REAL*8(A-H,O-Z) LOGICAL CONVGD DIMENSION Y(1),YPRIME(1),WT(1) DIMENSION PHI(NEQ,1),DELTA(1),E(1) DIMENSION WM(1),IWM(1) DIMENSION PSI(1),ALPHA(1),BETA(1),GAMMA(1),SIGMA(1) DIMENSION RPAR(1),IPAR(1) EXTERNAL RES,JAC COMMON /SDEV2/ ITRACE, IDEV COMMON /SDDTR/ TERKP1, TERK, TERKM1, TERKM2 COMMON/DDA001/NPD,NTEMP, * LML,LMU,LMXORD,LMTYPE, * LNST,LNRE,LNJE,LETF,LCTF,LIPVT COMMON /ERRCNT/ IEFAIL DATA MAXIT/4/ DATA XRATE/0.25D0/ C C C C C C----------------------------------------------------------------------- C block 1. C initialize. on the first call,set C the order to 1 and initialize C other variables. C----------------------------------------------------------------------- C C initializations for all calls IDID=1 XOLD=X NCF=0 NSF=0 NEF=0 IF(JSTART .NE. 0) GO TO 120 C C if this is the first step,perform C other initializations IWM(LETF) = 0 IWM(LCTF) = 0 K=1 KOLD=0 HOLD=0.0D0 JSTART=1 PSI(1)=H CJOLD = 1.0D0/H CJ = CJOLD S = 100.D0 JCALC = -1 DELNRM=1.0D0 IPHASE = 0 NS=0 120 CONTINUE C C C C C C----------------------------------------------------------------------- C block 2 C compute coefficients of formulas for C this step. C----------------------------------------------------------------------- 200 CONTINUE KP1=K+1 KP2=K+2 KM1=K-1 XOLD=X IF(H.NE.HOLD.OR.K .NE. KOLD) NS = 0 NS=MIN0(NS+1,KOLD+2) NSP1=NS+1 IF(KP1 .LT. NS)GO TO 230 C BETA(1)=1.0D0 ALPHA(1)=1.0D0 TEMP1=H GAMMA(1)=0.0D0 SIGMA(1)=1.0D0 DO 210 I=2,KP1 TEMP2=PSI(I-1) PSI(I-1)=TEMP1 BETA(I)=BETA(I-1)*PSI(I-1)/TEMP2 TEMP1=TEMP2+H ALPHA(I)=H/TEMP1 SIGMA(I)=DFLOAT(I-1)*SIGMA(I-1)*ALPHA(I) GAMMA(I)=GAMMA(I-1)+ALPHA(I-1)/H 210 CONTINUE PSI(KP1)=TEMP1 230 CONTINUE C C compute alphas, alpha0 ALPHAS = 0.0D0 ALPHA0 = 0.0D0 DO 240 I = 1,K ALPHAS = ALPHAS - 1.0D0/DFLOAT(I) ALPHA0 = ALPHA0 - ALPHA(I) 240 CONTINUE C C compute leading coefficient cj CJLAST = CJ CJ = -ALPHAS/H C C compute variable stepsize error coefficient ck CK = DABS(ALPHA(KP1) + ALPHAS - ALPHA0) CK = DMAX1(CK,ALPHA(KP1)) C C decide whether new jacobian is needed TEMP1 = (1.0D0 - XRATE)/(1.0D0 + XRATE) TEMP2 = 1.0D0/TEMP1 IF (CJ/CJOLD .LT. TEMP1 .OR. CJ/CJOLD .GT. TEMP2) JCALC = -1 IF (CJ .NE. CJLAST) S = 100.D0 C C change phi to phi star IF(KP1 .LT. NSP1) GO TO 280 DO 270 J=NSP1,KP1 DO 260 I=1,NEQ 260 PHI(I,J)=BETA(J)*PHI(I,J) 270 CONTINUE 280 CONTINUE C C update time X=X+H C C C C C C----------------------------------------------------------------------- C block 3 C predict the solution and derivative, C and solve the corrector equation C----------------------------------------------------------------------- C C first,predict the solution and derivative 300 CONTINUE DO 310 I=1,NEQ Y(I)=PHI(I,1) 310 YPRIME(I)=0.0D0 DO 330 J=2,KP1 DO 320 I=1,NEQ Y(I)=Y(I)+PHI(I,J) 320 YPRIME(I)=YPRIME(I)+GAMMA(J)*PHI(I,J) 330 CONTINUE PNORM = DDANRM (NEQ,Y,WT,RPAR,IPAR) C C C C solve the corrector equation using a C modified newton scheme. CONVGD= .TRUE. M=0 IWM(LNRE)=IWM(LNRE)+1 IRES = 0 CALL RES(X,Y,YPRIME,DELTA,IRES,RPAR,IPAR) IF (IRES .LT. 0) GO TO 380 C C C if indicated,reevaluate the C iteration matrix pd = dg/dy + cj*dg/dyprime C (where g(x,y,yprime)=0). set C jcalc to 0 as an indicator that C this has been done. IF(JCALC .NE. -1)GO TO 340 IWM(LNJE)=IWM(LNJE)+1 JCALC=0 CALL DDAJAC(NEQ,X,Y,YPRIME,DELTA,CJ,H, * IER,WT,E,WM,IWM,RES,IRES,UROUND,JAC,RPAR,IPAR) IF(ITRACE .GE. 1)WRITE(IDEV,331) 331 FORMAT(' JAC EVAL') CJOLD=CJ S = 100.D0 IF (IRES .LT. 0) GO TO 380 IF(IER .NE. 0)GO TO 380 NSF=0 C C C initialize the error accumulation vector e. 340 CONTINUE DO 345 I=1,NEQ 345 E(I)=0.0D0 C S = 100.E0 C C C corrector loop. 350 CONTINUE C C multiply residual by temp1 to accelerate convergence TEMP1 = 2.0D0/(1.0D0 + CJ/CJOLD) DO 355 I = 1,NEQ 355 DELTA(I) = DELTA(I) * TEMP1 C C compute a new iterate (back-substitution). C store the correction in delta. CALL DDASLV(NEQ,DELTA,WM,IWM) C C update y,e,and yprime DO 360 I=1,NEQ Y(I)=Y(I)-DELTA(I) E(I)=E(I)-DELTA(I) 360 YPRIME(I)=YPRIME(I)-CJ*DELTA(I) C C test for convergence of the iteration DELNRM=DDANRM(NEQ,DELTA,WT,RPAR,IPAR) IF (DELNRM .LE. 100.D0*UROUND*PNORM) GO TO 375 IF (M .GT. 0) GO TO 365 OLDNRM = DELNRM GO TO 367 365 RATE = (DELNRM/OLDNRM)**(1.0D0/DFLOAT(M)) IF (RATE .GT. 0.90D0) GO TO 370 S = RATE/(1.0D0 - RATE) 367 IF (S*DELNRM .LE. 0.33D0) GO TO 375 C C the corrector has not yet converged. C update m and test whether the C maximum number of iterations have C been tried. M=M+1 IF(M.GE.MAXIT)GO TO 370 C C evaluate the residual C and go back to do another iteration IWM(LNRE)=IWM(LNRE)+1 IRES = 0 CALL RES(X,Y,YPRIME,DELTA,IRES, * RPAR,IPAR) IF (IRES .LT. 0) GO TO 380 GO TO 350 C C C the corrector failed to converge in maxit C iterations. if the iteration matrix C is not current,re-do the step with C a new iteration matrix. 370 CONTINUE IF(ITRACE .GE. 1)WRITE(IDEV,371) 371 FORMAT(' CONVERGENCE FAILURE 1') IF(JCALC.EQ.0)GO TO 380 JCALC=-1 GO TO 300 C C C the iteration has converged. if nonnegativity of solution is C required, set the solution nonnegative, if the perturbation C to do it is small enough. if the change is too large, then C consider the corrector iteration to have failed. 375 IF(NONNEG .EQ. 0) GO TO 390 DO 377 I = 1,NEQ 377 DELTA(I) = DMIN1(Y(I),0.0D0) DELNRM = DDANRM(NEQ,DELTA,WT,RPAR,IPAR) IF(DELNRM .GT. 0.33D0) GO TO 380 DO 378 I = 1,NEQ 378 E(I) = E(I) - DELTA(I) GO TO 390 C C C exits from block 3 C no convergence with current iteration C matrix,or singular iteration matrix 380 CONVGD= .FALSE. IF(ITRACE .GE. 1)WRITE(IDEV,381) 381 FORMAT(' CONVERGENCE FAILURE 2') 390 JCALC = 1 IF(.NOT.CONVGD)GO TO 600 C C C C C C----------------------------------------------------------------------- C block 4 C estimate the errors at orders k,k-1,k-2 C as if constant stepsize was used. estimate C the local error at order k and test C whether the current step is successful. C----------------------------------------------------------------------- C C estimate errors at orders k,k-1,k-2 ENORM = DDANRM(NEQ,E,WT,RPAR,IPAR) ERK = SIGMA(K+1)*ENORM TERK = FLOAT(K+1)*ERK EST = ERK KNEW=K IF(K .EQ. 1)GO TO 430 DO 405 I = 1,NEQ 405 DELTA(I) = PHI(I,KP1) + E(I) ERKM1=SIGMA(K)*DDANRM(NEQ,DELTA,WT,RPAR,IPAR) TERKM1 = FLOAT(K)*ERKM1 IF(K .GT. 2)GO TO 410 IF(TERKM1 .LE. 0.5*TERK)GO TO 420 GO TO 430 410 CONTINUE DO 415 I = 1,NEQ 415 DELTA(I) = PHI(I,K) + DELTA(I) ERKM2=SIGMA(K-1)*DDANRM(NEQ,DELTA,WT,RPAR,IPAR) TERKM2 = FLOAT(K-1)*ERKM2 IF(DMAX1(TERKM1,TERKM2).GT.TERK)GO TO 430 C lower the order 420 CONTINUE KNEW=K-1 EST = ERKM1 C C C calculate the local error for the current step C to see if the step was successful 430 CONTINUE ERR = CK * ENORM IF(ITRACE .GE. 1)WRITE(IDEV,431)ERR 431 FORMAT(' SCALED LOCAL ERROR IS ',D12.3) IF(ERR .GT. 1.0D0)GO TO 600 C C C C C C----------------------------------------------------------------------- C block 5 C the step is successful. determine C the best order and stepsize for C the next step. update the differences C for the next step. C----------------------------------------------------------------------- IDID=1 IWM(LNST)=IWM(LNST)+1 KDIFF=K-KOLD KOLD=K HOLD=H C C C estimate the error at order k+1 unless% C already decided to lower order, or C already using maximum order, or C stepsize not constant, or C order raised in previous step IF(KNEW.EQ.KM1.OR.K.EQ.IWM(LMXORD))IPHASE=1 IF(IPHASE .EQ. 0)GO TO 545 IF(KNEW.EQ.KM1)GO TO 540 IF(K.EQ.IWM(LMXORD)) GO TO 550 IF(KP1.GE.NS.OR.KDIFF.EQ.1)GO TO 550 DO 510 I=1,NEQ 510 DELTA(I)=E(I)-PHI(I,KP2) ERKP1 = (1.0D0/DFLOAT(K+2))*DDANRM(NEQ,DELTA,WT,RPAR,IPAR) TERKP1 = FLOAT(K+2)*ERKP1 IF(K.GT.1)GO TO 520 IF(TERKP1.GE.0.5D0*TERK)GO TO 550 GO TO 530 520 IF(TERKM1.LE.DMIN1(TERK,TERKP1))GO TO 540 IF(TERKP1.GE.TERK.OR.K.EQ.IWM(LMXORD))GO TO 550 TEMP2=K+1 R= (2.0D0*ERK +0.0001D0)**(-1.0D0/TEMP2) 1 / (2.0D0*ERKP1+0.0001D0)**(-1.0D0/(TEMP2+1.D0)) IF(R .GE. 0.9D0)GOTO 550 C C raise order 530 K=KP1 IF(ITRACE .GE. 1)WRITE(IDEV,531) 531 FORMAT(' ORDER RAISE CONSIDERED') EST = ERKP1 GO TO 550 C C lower order 540 K=KM1 EST = ERKM1 GO TO 550 C C if iphase = 0, increase order by one and multiply stepsize by C factor two 545 K = KP1 IF(ITRACE .GE. 1)WRITE(IDEV,546) 546 FORMAT(' ORDER RAISE WITH IPHASE =0') HNEW = H*2.0D0 H = HNEW GO TO 575 C C C determine the appropriate stepsize for C the next step. 550 HNEW=H TEMP2=K+1 R=(2.0D0*EST+0.0001D0)**(-1.0D0/TEMP2) IF(R .LT. 2.0D0) GO TO 555 HNEW = 2.0D0*H GO TO 560 555 IF(R .GT. 1.0D0) GO TO 560 R = DMAX1(0.5D0,DMIN1(0.9D0,R)) HNEW = H*R 560 H=HNEW C C C update differences for next step 575 CONTINUE IF(KOLD.EQ.IWM(LMXORD))GO TO 585 DO 580 I=1,NEQ 580 PHI(I,KP2)=E(I) 585 CONTINUE DO 590 I=1,NEQ 590 PHI(I,KP1)=PHI(I,KP1)+E(I) DO 595 J1=2,KP1 J=KP1-J1+1 DO 595 I=1,NEQ 595 PHI(I,J)=PHI(I,J)+PHI(I,J+1) RETURN C C C C C C----------------------------------------------------------------------- C block 6 C the step is unsuccessful. restore x,psi,phi C determine appropriate stepsize for C continuing the integration, or exit with C an error flag if there have been many C failures. C----------------------------------------------------------------------- 600 IPHASE = 1 C C restore x,phi,psi X=XOLD IF(KP1.LT.NSP1)GO TO 630 DO 620 J=NSP1,KP1 TEMP1=1.0D0/BETA(J) DO 610 I=1,NEQ 610 PHI(I,J)=TEMP1*PHI(I,J) 620 CONTINUE 630 CONTINUE DO 640 I=2,KP1 640 PSI(I-1)=PSI(I)-H C C C test whether failure is due to corrector iteration C or error test IF(CONVGD)GO TO 660 IWM(LCTF)=IWM(LCTF)+1 C C C the newton iteration failed to converge with C a current iteration matrix. determine the cause C of the failure and take appropriate action. IF(IER.EQ.0)GO TO 650 C C the iteration matrix is singular. reduce C the stepsize by a factor of 4. if C this happens three times in a row on C the same step, return with an error flag NSF=NSF+1 R = 0.25D0 H=H*R IF (NSF .LT. 3 .AND. DABS(H) .GE. HMIN) GO TO 690 IDID=-8 GO TO 675 C C C the newton iteration failed to converge for a reason C other than a singular iteration matrix. if ires = -2, then C return. otherwise, reduce the stepsize and try again, unless C too many failures have occured. 650 CONTINUE IF (IRES .GT. -2) GO TO 655 IDID = -11 GO TO 675 655 NCF = NCF + 1 R = 0.25D0 H = H*R IF (NCF .LT. 10 .AND. DABS(H) .GE. HMIN) GO TO 690 IDID = -7 IF (IRES .LT. 0) IDID = -10 IF (NEF .GE. 3) IDID = -9 GO TO 675 C C C the newton scheme converged,and the cause C of the failure was the error estimate C exceeding the tolerance. 660 NEF=NEF+1 IEFAIL = IEFAIL + 1 IF(ITRACE .GE.1)WRITE(IDEV,661) 661 FORMAT(' ERROR TEST FAILED') IWM(LETF)=IWM(LETF)+1 IF (NEF .GT. 1) GO TO 665 C C on first error test failure, keep current order or lower C order by one. compute new stepsize based on differences C of the solution. K = KNEW TEMP2 = K + 1 R = 0.90D0*(2.0D0*EST+0.0001D0)**(-1.0D0/TEMP2) R = DMAX1(0.25D0,DMIN1(0.9D0,R)) H = H*R IF (DABS(H) .GE. HMIN) GO TO 690 IDID = -6 GO TO 675 C C on second error test failure, use the current order or C decrease order by one. reduce the stepsize by a factor of C one quarter. 665 IF (NEF .GT. 2) GO TO 670 K = KNEW H = 0.25D0*H IF (DABS(H) .GE. HMIN) GO TO 690 IDID = -6 GO TO 675 C C on third and subsequent error test failures, set the order to C one and reduce the stepsize by a factor of one quarter 670 K = 1 H = 0.25D0*H IF (DABS(H) .GE. HMIN) GO TO 690 IDID = -6 GO TO 675 C C C C C for all crashes, restore y to its last value, C interpolate to find yprime at last x, and return 675 CONTINUE CALL DDATRP(X,X,Y,YPRIME,NEQ,K,PHI,PSI) RETURN C C C go back and try this step again 690 GO TO 200 C C------end of subroutine dastep------ END SUBROUTINE DDASLV(NEQ,DELTA,WM,IWM) C C***BEGIN PROLOGUE DDASLV C***REFER TO DDASSL C***ROUTINES CALLED DGESL,DGBSL C***COMMON BLOCKS DDA001 C***DATE WRITTEN 830315 (YYMMDD) C***REVISION DATE 830315 (YYMMDD) C***END PROLOGUE DDASLV C----------------------------------------------------------------------- C this routine manages the solution of the linear C system arising in the newton iteration. C matrices and real temporary storage and C real information are stored in the array wm. C integer matrix information is stored in C the array iwm. C for a dense matrix, the linpack routine C dgesl is called. C for a banded matrix,the linpack routine C dgbsl is called. C----------------------------------------------------------------------- C IMPLICIT REAL*8 (A-H,O-Z) DIMENSION DELTA(1),WM(1),IWM(1) COMMON/DDA001/NPD,NTEMP,LML,LMU, * LMXORD,LMTYPE, * LNST,LNRE,LNJE,LETF,LCTF,LIPVT COMMON /PSTATS/ ID(3), IS IS = IS + 1 C MTYPE=IWM(LMTYPE) GO TO(100,100,300,400,400),MTYPE C C dense matrix 100 CALL DGESL(WM(NPD),NEQ,NEQ,IWM(LIPVT),DELTA,0) RETURN C C dummy section for mtype=3 300 CONTINUE RETURN C C banded matrix 400 MEBAND=2*IWM(LML)+IWM(LMU)+1 CALL DGBSL(WM(NPD),MEBAND,NEQ,IWM(LML), * IWM(LMU),IWM(LIPVT),DELTA,0) RETURN C------end of subroutine ddaslv------ END SUBROUTINE DDAJAC(NEQ,X,Y,YPRIME,DELTA,CJ,H, * IER,WT,E,WM,IWM,RES,IRES,UROUND,JAC,RPAR,IPAR) C C***BEGIN PROLOGUE DDAJAC C***REFER TO DDASSL C***ROUTINES CALLED DGEFA,DGBFA C***COMMON BLOCKS DDA001 C***DATE WRITTEN 830315 (YYMMDD) C***REVISION DATE 830315 (YYMMDD) C***END PROLOGUE DDAJAC C----------------------------------------------------------------------- C this routine computes the iteration matrix C pd=dg/dy+cj*dg/dyprime (where g(x,y,yprime)=0). C here pd is computed by the user-supplied C routine jac if iwm(mtype) is 1 or 4, and C it is computed by numerical finite differencing C if iwm(mtype)is 2 or 5 C the parameters have the following meanings. C y = array containing predicted values C yprime = array containing predicted derivatives C delta = residual evaluated at (x,y,yprime) C (used only if iwm(mtype)=2 or 5) C cj = scalar parameter defining iteration matrix C h = current stepsize in integration C ier = variable which is .ne. 0 C if iteration matrix is singular, C and 0 otherwise. C wt = vector of weights for computing norms C e = work space (temporary) of length neq C wm = real work space for matrices. on C output it contains the lu decomposition C of the iteration matrix. C iwm = integer work space containing C matrix information C res = name of the external user-supplied routine C to evaluate the residual function g(x,y,yprime) C ires = flag which is equal to zero if no illegal values C in res, and less than zero otherwise. (if ires C is less than zero, the matrix was not completed) C in this case (if ires .lt. 0), then ier = 0. C uround = the unit roundoff error of the machine being used. C jac = name of the external user-supplied routine C to evaluate the iteration matrix (this routine C is only used if iwm(mtype) is 1 or 4) C----------------------------------------------------------------------- C IMPLICIT REAL*8(A-H,O-Z) EXTERNAL RES,JAC DIMENSION Y(1),YPRIME(1),DELTA(1),WT(1),E(1) DIMENSION WM(1),IWM(1),RPAR(1),IPAR(1) COMMON/DDA001/NPD,NTEMP, * LML,LMU,LMXORD,LMTYPE, * LNST,LNRE,LNJE,LETF,LCTF,LIPVT C IER = 0 NPDM1=NPD-1 MTYPE=IWM(LMTYPE) GO TO (100,200,300,400,500),MTYPE C C C dense user-supplied matrix 100 LENPD=NEQ*NEQ DO 110 I=1,LENPD 110 WM(NPDM1+I)=0.0D0 CALL JAC(X,Y,YPRIME,WM(NPD),CJ,RPAR,IPAR) GO TO 230 C C C dense finite-difference-generated matrix 200 IRES=0 NROW=NPDM1 SQUR = DSQRT(UROUND) DO 210 I=1,NEQ DEL=SQUR*DMAX1(DABS(Y(I)),DABS(H*YPRIME(I)), * DABS(WT(I))) DEL=DSIGN(DEL,H*YPRIME(I)) DEL=(Y(I)+DEL)-Y(I) YSAVE=Y(I) YPSAVE=YPRIME(I) Y(I)=Y(I)+DEL YPRIME(I)=YPRIME(I)+CJ*DEL CALL RES(X,Y,YPRIME,E,IRES,RPAR,IPAR) IF (IRES .LT. 0) RETURN DELINV=1.0D0/DEL DO 220 L=1,NEQ 220 WM(NROW+L)=(E(L)-DELTA(L))*DELINV NROW=NROW+NEQ Y(I)=YSAVE YPRIME(I)=YPSAVE 210 CONTINUE C C C do dense-matrix lu decomposition on pd 230 CALL DGEFA(WM(NPD),NEQ,NEQ,IWM(LIPVT),IER) RETURN C C C dummy section for iwm(mtype)=3 300 RETURN C C C banded user-supplied matrix 400 LENPD=(2*IWM(LML)+IWM(LMU)+1)*NEQ DO 410 I=1,LENPD 410 WM(NPDM1+I)=0.0D0 CALL JAC(X,Y,YPRIME,WM(NPD),CJ,RPAR,IPAR) MEBAND=2*IWM(LML)+IWM(LMU)+1 GO TO 550 C C C banded finite-difference-generated matrix 500 MBAND=IWM(LML)+IWM(LMU)+1 MBA=MIN0(MBAND,NEQ) MEBAND=MBAND+IWM(LML) MEB1=MEBAND-1 MSAVE=(NEQ/MBAND)+1 ISAVE=NTEMP-1 IPSAVE=ISAVE+MSAVE IRES=0 SQUR=DSQRT(UROUND) DO 540 J=1,MBA DO 510 N=J,NEQ,MBAND K= (N-J)/MBAND + 1 WM(ISAVE+K)=Y(N) WM(IPSAVE+K)=YPRIME(N) DEL=SQUR*DMAX1(DABS(Y(N)),DABS(H*YPRIME(N)), * DABS(WT(N))) DEL=DSIGN(DEL,H*YPRIME(N)) DEL=(Y(N)+DEL)-Y(N) Y(N)=Y(N)+DEL 510 YPRIME(N)=YPRIME(N)+CJ*DEL CALL RES(X,Y,YPRIME,E,IRES,RPAR,IPAR) IF (IRES .LT. 0) RETURN DO 530 N=J,NEQ,MBAND K= (N-J)/MBAND + 1 Y(N)=WM(ISAVE+K) YPRIME(N)=WM(IPSAVE+K) DEL=SQUR*DMAX1(DABS(Y(N)),DABS(H*YPRIME(N)), * DABS(WT(N))) DEL=DSIGN(DEL,H*YPRIME(N)) DEL=(Y(N)+DEL)-Y(N) DELINV=1.0D0/DEL I1=MAX0(1,(N-IWM(LMU))) I2=MIN0(NEQ,(N+IWM(LML))) II=N*MEB1-IWM(LML)+NPDM1 DO 520 I=I1,I2 520 WM(II+I)=(E(I)-DELTA(I))*DELINV 530 CONTINUE 540 CONTINUE C C C do lu decomposition of banded pd 550 CALL DGBFA(WM(NPD),MEBAND,NEQ, * IWM(LML),IWM(LMU),IWM(LIPVT),IER) RETURN C------end of subroutine ddajac------ END SUBROUTINE DDATRP(X,XOUT,YOUT,YPOUT,NEQ,KOLD,PHI,PSI) C C***BEGIN PROLOGUE DDATRP C***REFER TO DDASSL C***ROUTINES CALLED (NONE) C***DATE WRITTEN 830315 (YYMMDD) C***REVISION DATE 830315 (YYMMDD) C***END PROLOGUE DDATRP C C----------------------------------------------------------------------- C the methods in subroutine dastep use polynomials C to approximate the solution. ddatrp approximates the C solution and its derivative at time xout by evaluating C one of these polynomials,and its derivative,there. C information defining this polynomial is passed from C dastep, so ddatrp cannot be used alone. C C the parameters are% C x the current time in the integration. C xout the time at which the solution is desired C yout the interpolated approximation to y at xout C (this is output) C ypout the interpolated approximation to yprime at xout C (this is output) C neq number of equations C kold order used on last successful step C phi array of scaled divided differences of y C psi array of past stepsize history C----------------------------------------------------------------------- C IMPLICIT REAL*8 (A-H,O-Z) DIMENSION YOUT(1),YPOUT(1) DIMENSION PHI(NEQ,1),PSI(1) KOLDP1=KOLD+1 TEMP1=XOUT-X DO 10 I=1,NEQ YOUT(I)=PHI(I,1) 10 YPOUT(I)=0.0D0 C=1.0D0 D=0.0D0 GAMMA=TEMP1/PSI(1) DO 30 J=2,KOLDP1 D=D*GAMMA+C/PSI(J-1) C=C*GAMMA GAMMA=(TEMP1+PSI(J-1))/PSI(J) DO 20 I=1,NEQ YOUT(I)=YOUT(I)+C*PHI(I,J) 20 YPOUT(I)=YPOUT(I)+D*PHI(I,J) 30 CONTINUE RETURN C C------end of subroutine ddatrp------ END SUBROUTINE DDAINI(X,Y,YPRIME,NEQ, * RES,JAC,H,WT,IDID,RPAR,IPAR, * PHI,DELTA,E,WM,IWM, * HMIN,UROUND,NONNEG) C C***BEGIN PROLOGUE DDAINI C***REFER TO DDASSL C***ROUTINES CALLED DDANRM,DDAJAC,DDASLV C***COMMON BLOCKS DDA001 C***DATE WRITTEN 830315 (YYMMDD) C***REVISION DATE 830315 (YYMMDD) C***END PROLOGUE DDAINI C C------------------------------------------------------- C ddaini takes one step of size h or smaller C with the backward euler method, to C find yprime at the initial time x. a modified C damped newton iteration is used to C solve the corrector iteration. C C the initial guess yprime is used in the C prediction, and in forming the iteration C matrix, but is not involved in the C error test. this may have trouble C converging if the initial guess is no C good, or if g(xy,yprime) depends C nonlinearly on yprime. C C the parameters represent: C x -- independent variable C y -- solution vector at x C yprime -- derivative of solution vector C neq -- number of equations C h -- stepsize. imder may use a stepsize C smaller than h. C wt -- vector of weights for error C criterion C idid -- completion code with the following meanings C idid= 1 -- yprime was found successfully C idid=-12 -- ddaini failed to find yprime C rpar,ipar -- real and integer parameter arrays C that are not altered by ddaini C phi -- work space for ddaini C delta,e -- work space for ddaini C wm,iwm -- real and integer arrays storing C matrix information C C----------------------------------------------------------------- C C C IMPLICIT REAL*8 (A-H,O-Z) LOGICAL CONVGD DIMENSION Y(1),YPRIME(1),WT(1) DIMENSION PHI(NEQ,1),DELTA(1),E(1) DIMENSION WM(1),IWM(1) DIMENSION RPAR(1),IPAR(1) EXTERNAL RES,JAC COMMON/SDEV2/ ITRACE, IDEV COMMON/DDA001/NPD,NTEMP, * LML,LMU,LMXORD,LMTYPE, * LNST,LNRE,LNJE,LETF,LCTF,LIPVT C DATA MAXIT/12/,MJAC/8/ DATA DAMP/0.75D0/ C C C C--------------------------------------------------- C block 1. C initializations. C--------------------------------------------------- C IDID=1 NEF=0 NCF=0 NSF=0 YNORM=DDANRM(NEQ,Y,WT,RPAR,IPAR) C C save y and yprime in phi DO 100 I=1,NEQ PHI(I,1)=Y(I) 100 PHI(I,2)=YPRIME(I) C C C C---------------------------------------------------- C block 2. C do one backward euler step. C---------------------------------------------------- C C set up for start of corrector iteration 200 CJ=1.0D0/H XNEW=X+H C C predict solution and derivative C DO 250 I=1,NEQ 250 Y(I)=Y(I)+H*YPRIME(I) C JCALC=-1 M=0 CONVGD=.TRUE. C C C corrector loop. 300 IWM(LNRE)=IWM(LNRE)+1 IRES=0 C CALL RES(XNEW,Y,YPRIME,DELTA,IRES,RPAR,IPAR) IF (IRES.LT.0) GO TO 430 C C C evaluate the iteration matrix IF (JCALC.NE.-1) GO TO 310 IWM(LNJE)=IWM(LNJE)+1 JCALC=0 CALL DDAJAC(NEQ,XNEW,Y,YPRIME,DELTA,CJ,H, * IER,WT,E,WM,IWM,RES,IRES, * UROUND,JAC,RPAR,IPAR) IF(ITRACE .GE. 1)WRITE(IDEV,301) 301 FORMAT(' JAC EVAL IN DDAINI ') C S=1000000.D0 IF (IRES.LT.0) GO TO 430 IF (IER.NE.0) GO TO 430 NSF=0 C C C C C multiply residual by damping factor 310 CONTINUE DO 320 I=1,NEQ 320 DELTA(I)=DELTA(I)*DAMP C C C compute a new iterate (back substitution) C store the correction in delta C CALL DDASLV(NEQ,DELTA,WM,IWM) C C C update y and yprime C DO 330 I=1,NEQ Y(I)=Y(I)-DELTA(I) 330 YPRIME(I)=YPRIME(I)-CJ*DELTA(I) C C C test for convergence of the iteration. C DELNRM=DDANRM(NEQ,DELTA,WT,RPAR,IPAR) IF (DELNRM.LE.100.D0*UROUND*YNORM) * GO TO 400 C IF (M.GT.0) GO TO 340 OLDNRM=DELNRM GO TO 350 C 340 RATE=(DELNRM/OLDNRM)**(1.0D0/DFLOAT(M)) IF (RATE.GT.0.90D0) GO TO 430 S=RATE/(1.0D0-RATE) IF(ITRACE .GE. 2)WRITE(IDEV,341)RATE, DELNRM, S 341 FORMAT(' RATE= ',D11.3,' DELNRM=',D11.3,' S = ',D11.3) C 350 IF (S*DELNRM .LE. 0.33D0) GO TO 400 C C C the corrector has not yet converged. update C m and and test whether the maximum C number of iterations have been tried. C every mjac iterations, get a new C iteration matrix. C M=M+1 IF (M.GE.MAXIT) GO TO 430 C IF ((M/MJAC)*MJAC.EQ.M) JCALC=-1 C GO TO 300 C C C C the iteration has converged. C check nonnegativity constraints 400 IF (NONNEG.EQ.0) GO TO 450 DO 410 I=1,NEQ 410 DELTA(I)=DMIN1(Y(I),0.0D0) C DELNRM=DDANRM(NEQ,DELTA,WT,RPAR,IPAR) IF (DELNRM.GT.0.33D0) GO TO 430 C DO 420 I=1,NEQ Y(I)=Y(I)-DELTA(I) 420 YPRIME(I)=YPRIME(I)-CJ*DELTA(I) GO TO 450 C C C exits from corrector loop. 430 CONVGD=.FALSE. 450 IF (.NOT.CONVGD) GO TO 600 C C C C----------------------------------------------------- C block 3. C the corrector iteration converged. C do error test. C----------------------------------------------------- C C DO 510 I=1,NEQ E(I)=Y(I)-PHI(I,1) 510 CONTINUE C ERR=DDANRM(NEQ,E,WT,RPAR,IPAR) C IF (ERR.LE.1.0D0) RETURN IF(ITRACE .GE. 1)WRITE(IDEV,511)ERR 511 FORMAT(' SCALED LOCAL ERROR IN INITIAL STEP IS',D11.3) DO 512 I = 1,NEQ 512 YPRIME(I) = 0.0D0 RETURN C C-------------------------------------------------------- C block 4. C the backward euler step failed. restore y C and yprime to their original values. C reduce stepsize and try again, if C possible. C--------------------------------------------------------- C C 600 CONTINUE DO 610 I=1,NEQ Y(I)=PHI(I,1) 610 YPRIME(I)=PHI(I,2) C IF (CONVGD) GO TO 640 IF (IER.EQ.0) GO TO 620 NSF=NSF+1 H=H*0.25D0 IF (NSF.LT.3.AND.DABS(H).GE.HMIN) GO TO 690 IDID=-12 RETURN 620 IF (IRES.GT.-2) GO TO 630 IDID=-12 RETURN 630 NCF=NCF+1 H=H*0.25D0 IF (NCF.LT.10.AND.DABS(H).GE.HMIN) GO TO 690 IDID=-12 RETURN C 640 NEF=NEF+1 R=0.90D0/(2.0D0*ERR+0.0001D0) R=DMAX1(0.1D0,DMIN1(0.5D0,R)) H=H*R IF (DABS(H).GE.HMIN.AND.NEF.LT.10) GO TO 690 IDID=-12 RETURN 690 GO TO 200 C C-------------end of subroutine ddaini---------------------- END DOUBLE PRECISION FUNCTION DDANRM(NEQ,V,WT,RPAR,IPAR) C C***BEGIN PROLOGUE DDANRM C***REFER TO DDASSL C***ROUTINES CALLED (NONE) C***DATE WRITTEN 830315 (YYMMDD) C***REVISION DATE 830315 (YYMMDD) C***END PROLOGUE DDANRM C----------------------------------------------------------------------- C this function routine computes the weighted C root-mean-square norm of the vector of length C neq contained in the array v,with weights C contained in the array wt of length neq. C ddanrm=sqrt((1/neq)*sum(v(i)/wt(i))**2) C----------------------------------------------------------------------- C IMPLICIT REAL*8(A-H,O-Z) DIMENSION V(NEQ),WT(NEQ) DIMENSION RPAR(1),IPAR(1) DDANRM = 0.0D0 VMAX = 0.0D0 DO 10 I = 1,NEQ 10 IF(DABS(V(I)/WT(I)) .GT. VMAX) VMAX = DABS(V(I)/WT(I)) IF(VMAX .LE. 0.0D0) GO TO 30 SUM = 0.0D0 DO 20 I = 1,NEQ 20 SUM = SUM + ((V(I)/WT(I))/VMAX)**2 C DDANRM = VMAX*DSQRT(SUM) DDANRM = VMAX*DSQRT(SUM/DFLOAT(NEQ)) 30 CONTINUE RETURN C------end of function ddanrm------ END SUBROUTINE XERRWV (MSG, NMES, NERR, IERT, NI, I1, I2, NR, R1, R2) INTEGER MSG, NMES, NERR, IERT, NI, I1, I2, NR, 1 I, LUN, LUNIT, MESFLG, NWDS DOUBLE PRECISION R1, R2 DIMENSION MSG(NMES) C----------------------------------------------------------------------- C subroutine xerrwv, as given here, constitutes C a simplified version of the slatec error handling package. C written by a. c. hindmarsh at lll. version of january 23, 1980. C modified by l. r. petzold, april 1982. C this version is in single precision. C C all arguments are input arguments. C C msg = the message (hollerith litteral or integer array). C nmes = the length of msg (number of characters). C nerr = the error number (not used). C iert = the error type.. C 1 means recoverable (control returns to caller). C 2 means fatal (run is aborted--see note below). C ni = number of integers (0, 1, or 2) to be printed with message. C i1,i2 = integers to be printed, depending on ni. C nr = number of reals (0, 1, or 2) to be printed with message. C r1,r2 = reals to be printed, depending on ni. C C note.. this routine is machine-dependent and specialized for use C in limited context, in the following ways.. C 1. the number of hollerith characters stored per word, denoted C by ncpw below, is set in a data statement below. C 2. the value of nmes is assumed to be at most 60. C (multi-line messages are generated by repeated calls.) C 3. if iert = 2, control passes to the statement stop C to abort the run. this statement may be machine-dependent. C 4. r1 and r2 are assumed to be in real and are printed C in d21.13 format. C 5. the data statement below contains default values of C mesflg = print control flag.. C 1 means print all messages (the default). C 0 means no printing. C lunit = logical unit number for messages. C the default is 3 (machine-dependent). C to change lunit, change the data statement C below. C----------------------------------------------------------------------- C the following are instructions for installing this routine C in different machine environments. C C to change the default output unit, change the data statement C below. C C for a different number of characters per word, change the C data statement setting ncpw below. C alternatives for various computers are shown in comment C cards. C C for a different run-abort command, change the statement following C statement 100 at the end. C----------------------------------------------------------------------- C the following value of ncpw is valid for the cdc-6600 and C cdc-7600 computers. C data ncpw/10/ C the following is valid for the cray-1 computer. C data ncpw/8/ C the following is valid for the burroughs 6700 and 7800 computers. C data ncpw/6/ C the following is valid for the pdp-10 computer. C data ncpw/5/ C the following is valid for the vax computer with 4 bytes per integer, C and for the ibm-360, ibm-303x, and ibm-43xx computers. C data ncpw/4/ C the following is valid for the pdp-11, or vax with 2-byte integers. C data ncpw/2/ C---------------------------------------------------------------------- DIMENSION NFORM(13) DATA NFORM(1)/1H(/,NFORM(2)/1H1/,NFORM(3)/1HX/,NFORM(4)/1H,/, 1 NFORM(7)/1HA/,NFORM(10)/1H,/,NFORM(11)/1HA/,NFORM(13)/1H)/ DATA NCPW/4/ DATA MESFLG/1/,LUNIT/4/ C IF (MESFLG .EQ. 0) GO TO 100 C get logical unit number. --------------------------------------------- LUN = LUNIT C get number of words in message. -------------------------------------- NCH = MIN0(NMES,60) NWDS = NCH/NCPW CALL S88FMT(2,NWDS,NFORM(5)) CALL S88FMT(2,NCPW,NFORM(8)) NREM = NCH - NWDS*NCPW IF (NREM .GT. 0) NWDS = NWDS + 1 IF (NREM .LT. 1) NREM = 1 CALL S88FMT(1,NREM,NFORM(12)) WRITE(LUN,NFORM) (MSG(I),I=1,NWDS) IF (NI .EQ. 1) WRITE (LUN, 20) I1 20 FORMAT(6X,23HIN ABOVE MESSAGE, I1 =,I10) IF (NI .EQ. 2) WRITE (LUN, 30) I1,I2 30 FORMAT(6X,23HIN ABOVE MESSAGE, I1 =,I10,3X,4HI2 =,I10) IF (NR .EQ. 1) WRITE (LUN, 40) R1 40 FORMAT(6X,23HIN ABOVE MESSAGE, R1 =,D21.13) IF (NR .EQ. 2) WRITE (LUN, 50) R1,R2 50 FORMAT(6X,15HIN ABOVE, R1 =,D21.13,3X,4HR2 =,D21.13) C abort the run if iert = 2. ------------------------------------------- 100 IF (IERT .NE. 2) RETURN STOP C----------------------- end of subroutine xerrwv ---------------------- END SUBROUTINE S88FMT(N,IVALUE,IFMT) C***begin prologue s88fmt C***refer to xerror C abstract C s88fmt replaces ifmt(1), ... ,ifmt(n) with the C characters corresponding to the n least significant C digits of ivalue. C C taken from the bell laboratories port library error handler C latest revision --- 7 june 1978 C C***references C jones r.e., *slatec common mathematical library error handling C package*, sand78-1189, sandia laboratories, 1978. C***routines called (none) C***end prologue s88fmt C DIMENSION IFMT(N),IDIGIT(10) DATA IDIGIT(1),IDIGIT(2),IDIGIT(3),IDIGIT(4),IDIGIT(5), 1 IDIGIT(6),IDIGIT(7),IDIGIT(8),IDIGIT(9),IDIGIT(10) 2 /1H0,1H1,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9/ C***first executable statement s88fmt NT = N IT = IVALUE 10 IF (NT .EQ. 0) RETURN INDEX = MOD(IT,10) IFMT(NT) = IDIGIT(INDEX+1) IT = IT/10 NT = NT - 1 GO TO 10 END DOUBLE PRECISION FUNCTION D1MACH(IDUM) INTEGER IDUM DOUBLE PRECISION U,COMP U = 1.0D0 10 U = U * 0.5D0 COMP = 1.0D0 + U IF(COMP .NE. 1.0D0) GOTO 10 D1MACH = U * 2.0D0 RETURN END C ----- NEW VERSION -------------------- C PDECHEB DISCRETISATION MODULE C **************************** C THIS MODULE DISCRETISES MIXED SYSTEMS OF PARTIAL DIFFERENTIAL C EQUATIONS IN ONE SPACE VARIABLE AND ORDINARY DIFFERENTIAL EQUATIONS. C THIS IS THE MARK 1 VERSION OF PDECHEB 10TH AUGUST 1987 AS WRITTEN BY C DR MARTIN BERZINS C DEPARTMENT OF COMPUTER STUDIES C THE UNIVERSITY C LEEDS LS2 9JT C ALL RIGHTS RETAINED. C ( DOCUMENTATION MODIFIED ON 25/2/90 ) C THE CLASS OF EQUATIONS THAT CAN BE HANDLED IS GIVEN BY C C . C Q (X,T, U, U , U , U , V , V ) C I - - X -T - XT - - C C -M M . C = X (X R (X,T, U, U , U , U , V, V )) C I - -X - XT -T - - X C WHERE C U = ( U , ... , U ) TRANSPOSE AND I = 1,... , NPDE. C - 1 NPDE C C THE P.D.E. FLUX FUNCTION R(.......) IS ASSUMED TO BE CONTINUOUS C W.R.T. THE SPACE VARIABLE R BUT THE FUNCTION Q(.... ) IS C ALLOWED TO BE ONLY PIECEWISE CONTINUOUS PROVIDED THAT THE C DISCONTINUITIES ARE PLACED AT SPATIAL MESH POINTS. C THE OTHER VECTORS ARE DEFINED IN THE SAME WAY AS U EXCEPT THAT C . - C V = ( V , ... , V ) TRANSPOSE AND V IS SIMILARLY DEFD. C - 1 NV - C C . C WHERE V AND V ARE THE SOLUTION OF A COUPLED SYSTEM OF C - - ORDINARY DIFFERENTIAL EQUATIONS OF C DIMENSION NV. C IN THE CASE WHEN NV > 0 THIS SYSTEM OF DIFFERENTIAL EQUATIONS IS C ASSUMED TO HAVE THE FORM. C . C FV ( V, V , XI, UI, UI , RI , UI , UI , ) = 0 C -- - - - - - X - - T - XT C C . C WHERE ALL THE VECTORS APART FROM V AND V ARE OF LENGTH NPDE*NXI. C - - C AND CONTAIN THE VALUES OF THE P.D.E. VARIABLES U , U , R, U ,U C X T XT C AT THE SPATIAL O.D.E. /P.D.E. COUPLING POINTS DEINED BY C THE VECTOR XI(NXI) . C C THE SPATIAL MESH IS BOUNDED BY A AND B A < X < B. C THE BOUNDARY CONDITIONS HAVE THE FORM C . . C B (T) R(X,T, U, U , V, V ) = G (T, U , U , V, V) AT X = A C A - - -X - - -A - -X - - C AND C . . C B (T) R(X,T, U, U , V, V ) = G (T, U , U , V, V) AT X = B. C B - - -X - - -B - -X - - C C WHERE NOT ALL OF THE FUNCTIONS B AND G ARE SET TO ZERO. C C THE INITIAL CONDITIONS ARE GIVEN BY C U (X, 0) = K (X) AND V(O) = K C - -1 - -2 0 C THE DISCRETISATION METHOD USED BY THIS MODULE IS BASED ON A C - C COLLOCATION METHOD AND EVALUATES THE P.D.E. FUNCTIONS INBETWEEN C THE USER SUPPLIED MESH POINTS . ANY DISCONTINUITIES IN THE P.D.E. C DEFINING FUNCTION Q MUST THEREFORE BE AT THE USER SUPPLIED C BREAK POINTS . C REFERENCES C ---------- C BERZINS M. AND DEW P.M. C CHEBYSHEV POLYNOMIAL SOFTWARE FOR ELLIPTIC PARABOLIC P.D.ES C ACM TRANS. ON MATH. SOFT. 1990 PP XX - YY. C C BERZINS M. AND DEW P.M. C A NOTE ON C0 CHEBYSHEV METHODS FOR PARABOLIC EQUATIONS. C IMA JOURNAL OF NUMERICAL ANALYSIS (1987) 7, 15-37. C C BERZINS M. AND DEW P.M. DEPT OF COMPUTER STUDIES C THE UNIVERSITY , LEEDS , LS2 9JT ,REPORT NO 180 . C C---------------------------------------------------------------------- C C HOW TO USE THIS MODULE C ********************** C (1) DECIDE ON THE FORM OF THE SPATIAL DISCRETISATION METHOD TO BE C USED. THIS MODULE ALLOWS YOU TO DEFINE A SET OF (NEL + 1) SPATIAL C BREAKPOINTS , XBK(I) I = 1,NEL+1 . THESE BREAKPOINTS IN TURN C DEFINE NEL SPATIAL ELEMENTS. I.E. C XBK(I) =< ELEMENT I =< XBK(I+1). C IN THE CASE WHEN THE FUNCTION Q(.....) IN THE P.D.E. DEFINITION C HAS DISCONTINIUITIES YOU MUST PLACE A BREAKPOINT AT EACH C DISCONTINUITY. C PDECHEB WILL APPROXIMATE THE SOLUTION TO THE P.D.E. IN THE SPACE C DIMENSION BY USING A PIECEWISE CHEBYSHEV POLYNOMIAL BETWEEN EACH C PAIR OF BREAKPOINTS. THE DEGREE OF THIS POLYNOMIAL IS SPECIFIED C BY THE VARIABLE NPOLY WHICH MUST BE GREATER THAN OR C EQUAL TO 1. WHEN IT IS 1 THE SPATIAL MESH CONSISTS ONLY OF THE C BREAKPOINTS AND A LINEAR POLYNOMIAL IS USED TO APPROXIMATE THE C SOLUTION BETWEEN THESE POINTS. C THE ONLY PRE-SET UPPER LIMIT TO THE DEGREE OF POLYNOMIAL THAT C CAN BE USED IS A SOME WHAT ARBITRARY LIMIT OF 50. C C C (2) SET NPDE = NUMBER OF P.D.E.S TO BE SOLVED , MUST BE >= 0 . C SET NEL = NUMBER OF SPATIAL ELEMENTS TO BE USED , MUST BE >= 0. C DEFINE AN ARRAY OF BREAKPOINTS IN THE DOUBLE PRECISION ARRAY C XBK(IBK) WHERE IBK = NEL + 1 AND C XBK(I) < XBK(I+1) , I = 1,NEL C SET NPOLY TO THE DEGREE OF THE POLYNOMIALIN EACH ELEMENT , > 1 . C NOTES ON THE CHOICE OF NPOLY AND XBK(IBK) C ----------------------------------------- C IT SHOULD BE NOTED THAT THE PDECHEB SOFTWARE HAS NO MEANS OF C ESTIMATING OR CONTROLLING THE SPATIAL DISCRETISATION ERROR. C THE ERROR INCURRED WILL DEPEND ON THE NUMBER AND POSITION C OF THE BREAK POINTS AND ON THE DEGREE OF POLYNOMIAL USED. C THE GENERAL ADVICE IS USE AS FEW BREAK POINTS AS POSSIBLE C AND AS HIGH A DEGREE OF POLYNOMIAL AS SEEMS SENSIBLE FOR C THE PROBLEM AT HAND. THE APPROPRIATENESS OF A GIVEN DEGREE C OF POLYNOMIAL CAN BE JUDGED BY THE FACT THAT THE HIGHER C DEGREE COEFFICIENTS OF THE POLYNOMIAL EXPANSION SHOULD BE C SMALL IN COMPARISON WITH THE LOWER POLYNOMIAL DEGREE. C IT SHOULD ALSO BE NOTED THAT THE LOCAL TIME ERROR TOLERANCES C ( THE PARAMETERS RTOL AND ATOL - SEE SECTION 5 BELOW) C PASSED TO THE DASSL CODE SHOULD BE AN ORDER OF MAGNITUDE C SMALLER THAN THE EXPECTED SPATIAL ERROR. INEVITABLY THESE C AREAS OF UNCERTAINTY MEAN THAT SOME EXPERIMENTATION WITH C A GIVEN PROBLEM IS NECESSARY BEFORE AN CONFIDENCE CAN BE C PLACED IN THE NUMERICAL RESULTS. C C C SET M FOR SPACE CO-ORDINATE TYPE C = 0 FOR CARTESIAN, = 1 FOR CYLINDRICAL, = 2 FOR SPHERICAL C SET NV = NUMBER OF O.D.E.S COUPLED TO THE P.D.E.S C SET NXI = NUMBER OF SPACE POINTS WHERE THE O.D.E.S ARE COUPLED C SET XI(NXI) TO THE VALUES OF THE COUPLING POINTS C FOR USE BY THE ROUTINE PDECHB WHICH DEFINES THE O.D.E. SYSTEM C BEING SOLVED BY THE INTEGRATOR. C SET NPTS = NEL * NPTL-1 , THIS IS THE TOTAL NUMBER OF SPATIAL C DISCRETISATION POINTS USED BY THIS MODULE. C DECLARE A DOUBLE PRECISION ARRAY X, OF DIMENSION NPTS ; X(NPTS) C AND PUT X(1) = XBK(1) = A AND X(NPTS) = XBK(NEL+1) = B C WHERE A AND B ARE THE LEFT AND RIGHT EDGES OF THE SPTAIAL MESH. C THIS ARRAY WILL BE USED TO RETURN TO YOU THE SPATIAL MESH POINTS C USED BY THIS SPATIAL DISCRETISATION MODULE. C DECLARE A DOUBLE PRECISION ARRAY OF LENGTH NEQN WHERE C NEQN = NPDE * NPTS + NV C THAT IS USED TO HOLD THE SOLUTION VECTOR . NEQN IS THE NUMBER OF C ORDINARY DIFFERENTIAL EQUATIONS THAT MUST BE PASSED ACROSS TO C THE DASSL PACKAGE . THE SOLUTION TO THIS SYSTEM OF ORDINARY C DIFFFERENTIAL EQUATIONS THAT IS GENERATED BY DISCRETISING THE C CLASS OF P.D.E.S DEFINED ABOVE IS ORDERED IN ,SAY, U(NEQN) AS C FOLLOWS. C U(I) , I = (J-1) * NPDE + K , K = 1,...,NPDE , J = 1 ,.. ,NPTS C CONTAINS THE SOLUTION FOR P.D.E. K AT MESH POINT X(J). C U(L) , L = NPDE*NPTS + L1 , L1 = 1,..., NV C CONTAINS THE COUPLED O.D.E. COMPONENT V(L1) C DEFINE A DOUBLE PRECISION WORKSPACE OF LENGTH IWK WHERE C IWK = NPTL*(3*NPTL + 2 + 7*NPDE + NEL) +NXI*(5*NPDE+1) + NV + 2 C THIS IS THE WORKSPACE THAT MUST BE PASSED ACROSS TO THE DASSL C ROUTINE AS THE WORKSPACE FOR THE O.D.E. RESIDUAL DEFINING ROUTINE C PDECHB. C C C C (3) PROVIDE A SET OF ROUTINES WHICH DESCRIBE THE PRECISE FORM OF THE C P.D.E. TO BE SOLVED. FOUR ROUTINES MUST BE PROVIDED AND THE NAMES C OF THESE ROUTINES ARE FIXED. THESE ROUTINES ARE: C C SPDEFN : FORMS THE FUNCTIONS Q AND R IN THE P.D.E. DESCRIBED C ABOVE. THIS ROUTINE FORMS THE VALUES OF THE FUNCTIONS C Q AND R OVER SEVERAL MESHPOINTS SIMULTANEOUSLY. C IN FACT AT THE X(NPTL) POINTS IN ONE ELEMENT AT A TIME. C THE MESH POINTS USED ARE INTERNALLY C GENERATED BY THE DISCRETISATION ROUTINE AND ARE C BETWEEN THE USER DEFINED BREAKPOINTS. C SBNDR : FORMS THE FUNCTIONS B AND G ASSOCIATED WITH THE C BOUNDARY CONDITIONS FOR THE P.D.E. ABOVE. C UVINIT : SUPPLIES THE INITIAL VALUES OF THE P.D.E. PART AND ALSO C SUPPLIES THE INITIAL VALUES OF THE O.D.E. PART. C SODEFN : SUPPLIES THE ODE RESIDUAL AS DEFINED BY THE FUNCTION C FV ABOVE. C NOTE: THE P.D.E. SOLUTION VALUES AT THE COUPLING POINTS C PASSED INTO SODEFN ARE DEFINED BY POLYNOMIAL INTERPOLATION C ON THE VALUES AT THE P.D.E. SPATIAL MESH POINTS. C C N.B. EXAMPLES OF THESE ROUTINES FOR THREE PROBLEMS ARE PROVIDED C IN THE EXAMPLE PROBLEMS SECTION BELOW. C C C (4) CALL THE INITIALISATION ROUTINE INICHB, USING THE FORM C C CALL INICHB(NEQN,NPDE,NPTS,X,U,WK,IWK,M,TS,IBAND,ITIME,XBK, C * IBK,NEL,NPOLY,NV,NXI,XI,IDEV) C*********************************************************************** C ROUTINE FOR INITIALISATION OF CHEBYSHEV GENERALIZED COLLOCATION METHOD C C PARAMETER LIST C ---------------- C NEQN: EMPTY ON ENTRY, ON EXIT IT CONTAINS THE NUMBER OF C O.D.E.S GENERATED BY THE DISCRETISED FORM OF THE C P.D.E. , GIVEN BY NPDE*NEL*(NPTL-1) + NPDE + NV. C C NPDE NUMBER OF PARABOLIC P.D.E.S IN ONE SPACE DIMENSION C C NPTS NUMBER OF SPATIAL GRID POINTS USED IN M.O.L. SOLUTION. C NOTE THIS SHOULD BE EQUAL TO (NPTL-1)*NEL + 1 C C X(NPTS) EMPTY ARRAY ON ENTRY . ON EXIT THIS ARRAY C CONTAINS THE MESH USED IN SEMI-DISCRETISATION C C M =0,1,2 IF CARTESIAN CYLINDRICAL OR SPHERICAL POLARS. C C U(NEQN) SOLUTION VECTOR EMPTY ON ENTRY CONTAINS INITIAL C VALUES ON EXIT. THIS ARRAY IS ORDERED AS FOLLOWS. C U(1) - U(NPDE*NPTS) P.D.E. SOLUTION COMPONENTS. C U(NPDE*NPTS+1) - U(NEQN) O.D.E. COMPONENTS THAT ARE C COUPLED TO THE P.D.E. C C WK(IWK) REAL WORKSPACE USED TO PASS FOUR MATRICES AND VARIOUS C USEFUL VECTORS TO THE O.D.E.FUNCTION CALL ROUTINE C RESID SEE BELOW FOR A DETAILED DESCRIPTION. C C TS STARTING LEVEL OF TIME INTEGRATION. C C XBK(IBK) REAL ARRAY OF BREAK POINTS IBK = NEL +1 WHERE C NEL IS THE NUMBER OF SPATIAL ELEMENTS. C XBK(1) = XLEFT C XBK(I) =< XBK(I+1) I = 1,...,NEL . C XBK(IBK) = XRIGHT. C NEL THE NUMBER OF SPATIAL ELEMENTS , >= 1 C C NPOLY THE DEGREE OF THE APPROXIMATING POLYNOMIAL USED C BETWEEN EACH PAIR OF BREAKPOINTS . C ITIME THIS MUST BE SET = 1 ON THE CALL OF THIS MODULE C PRIOR TO THE DASSL PACKAGE BEING CALLED. C ONCE DASSL HAS RETURNED THIS ROUTINE MAY BE CALLED C WITH ITIME = 2 TO RECOVER THE SPATIAL MESH USED C (THIS IS PLACED IN THE ARRAY X(NPTS) ). C C NV THE NUMBER OF AUXILARY O.D.E.S THAT ARE COUPLED TO C THE P.D.E. C NXI THE NUMBER OF COUPLING POINTS AT WHICH P.D.E. VALUES C ARE USED TO DEFINE THE O.D.E.S C C XI(NXI) A VECTOR SPECIFYING THE POSITION OF THESE POINTS. C NOTE THAT THESE POINTS MUST BE DISTINCT FROM THE C BREAK - POINTS . C C IDEV NUMBER OF OUTPUT CHANNEL ON WHICH ERROR MESSAGES TO C DO WITH THE COLLOCATION DISCRETISATION WILL APPEAR. C C C C (5) SET TS AND TOUT FOR START AND END INTEGRATION TIMES C SET INFO, WORK ARRAYS AS REQUIRED FOR TIME INTEGRATION C AND CALL THE DASSLD ROUTINE AS FOLLOWS C CALL DDASSL (PDECHB, NEQ, T, Y, YDOT, TOUT, INFO, RTOL, ATOL, C * , IDID, RWORK, LRW, IWORK, LIW, WKRES, IRESWK, DGEJAC) C C DASSL CODE SOLVES A SYSTEM OF DIFFERENTIAL/ALGEBRAIC EQUATIONS OF C THE FORM G(T,Y,YDOT) = 0. C C VALUES FOR Y AND YPRIME AT THE INITIAL TIME MUST BE GIVEN AS INPUT C THESE VALUES MUST BE CONSISTENT, (THAT IS. IF T,Y,YDOT ARE THE GIVEN C INITIAL VALUES, THEY MUST SATISFY G(T,Y,YDOT) = 0.) C THE SUBROUTINE SOLVES THE SYSTEM FROM T TO TOUT. IT IS EASY TO C CONTINUE THE SOLUTION TO GET RESULTS AT ADDITIONAL TOUT. THIS IS THE C INTERVAL MODE OF OPERATION. INTERMEDIATE RESULTS CAN ALSO BE C OBTAINED EASILY BY USING THE INTERMEDIATE-OUTPUT CAPABILITY. C C ------------AN OVERVIEW OF ARGUMENTS TO DASSL----------------------- C THE PARAMETERS ARE C C PDECHB -- THIS IS A SUBROUTINE PROVIDED BY PDECHEB TO DEFINE THE C DIFFERENTIAL/ALGEBRAIC SYSTEM C C NEQ -- THE NUMBER OF DIFFERENTIAL/ALGEBRAIC EQUATIONS TO BE SOLVED C C T -- THIS IS THE CURRENT VALUE OF THE INDEPENDENT VARIABLE. C C TOUT -- THIS IS A POINT AT WHICH A SOLUTION IS DESIRED. C C INFO(*) -- THE BASIC TASK OF THE CODE IS TO SOLVE THE System C FROM T TO TOUT AND RETURN AN ANSWER AT TOUT. INFO(*) IS C INTEGER ARRAY WHICH IS USED TO COMMUNICATE EXACTLY HOW C YOU WANT THIS TASK TO BE CARRIED OUT. C C Y(*) -- THIS ARRAY CONTAINS THE SOLUTION COMPONENTS AT T C C YDOT(*) -- THIS ARRAY CONTAINS THE DERIVATIVES OF Y(*) AT T C C RTOL,ATOL -- THESE QUANTITIES REPRESENT ABSOLUTE AND Relative error C TOLERANCES WHICH YOU PROVIDE TO INDICATE HOW ACCURATELY C YOU WISH THE SOLUTION TO BE COMPUTED. YOu may choose C THEM TO BE BOTH SCALARS OR ELSE BOTH VECtors. C C IDID -- THIS SCALAR QUANTITY IS AN INDICATOR REPORTING WHAT THE CODE C YOU MUST MONITOR THIS INTEGER VARIABLE TO DECIDE WHAT ACTION C TO TAKE NEXT. C C RWORK(*),LRW -- RWORK(*) IS A REAL WORK ARRAY OF Length lrw which C PROVIDES THE CODE WITH NEEDED STORAGE SPACE. C C IWORK(*),LIW -- IWORK(*) IS AN INTEGER WORK ARRAY OF LENGTH LIW C WHICH PROVIDES THE CODE WITH NEEDED storage space. C C WKRES,IRESWK -- THESE ARE REAL AND INTEGER PARAMETER ARRAYS WHICH C ARE USED TO COMMUNICATE INFORMATION FROM THE C INITIALISATION ROUTINE INICHB TO THE SPATIAL C DISCRETISATION SUBROUTINE PDECHB. C C DGEJAC -- THIS IS THE NAME OF A DUMMY SUBROUTINE WHICH IS PROVIDED C BY THE PDECHEB SOFTWARE. IT MUST BE DECLARED AS EXTERNAL C IN THE CALLING PROGRAM. C C QUANTITIES WHICH ARE USED AS INPUT ITEMS ARE C NEQ, T Y(*), YDOT(*), TOUT, INFO(*), RTOL, ATOL , RWORK(1), C RWORK(2), RWORK(3), LRW, IWORK(1), IWORK(2),IWORK(3),AND LIW. C C QUANTITIES WHICH MAY BE ALTERED BY THE CODE ARE C T, Y(*), YDOT(*), INFO(1), RTOL, ATOL, IDID, RWORK(*) AND IWORK(*) C C (6) POST PROCESS THE SOLUTION. C C THE SOLUTION VECTOR RETURNED BY DASSL CAN BE USED FOR POST- C PROCESSING IN A NUMBER OF WAYS. C C SPATIAL INTERPOLATION C --------------------- C THE VECTOR Y(T) RETURNED BY DASSL CONSISTS ONLY OF SOLUTION C VALUES AT THE MESH POINTS DEFINED BY INICHB. THE FOLLOWING C INTERPOLATION ROUTINE ENABLES SOLUTION VALUES AT OTHER POINTS C TO BE OBTAINED. C C SUBROUTINE INTERC(XP,UP,NP,U,NEQ,NPDE,IFLAG,ITYPE,WK,IWK) C******************************************************************** C C SPACE INTERPOLATION ROUTINE FOR POST-PROCESSING OF SOLUTION C PRODUCED BY DASSL. C THIS ROUTINES PROVIDES VALUES OF THE SOLUTION AND POSSIBLY THE C FIRST DERIV IN SPACE AND THE FLUX ON THE MESH XP(NP). C C PARAMETERS C -------------- C NPDE ON ENTRY MUST CONTAIN NO OF PARABOLIC EQUATIONS C NPTS ON ENTRY MUST CONTAIN THE NUMBER OF SPATIAL C MESH POINTS USED IN TIME INTEGRATION. C NP ON ENTRY MUST CONTAIN THE NUMBER OF SPATIAL C INTERPOLATION POINTS C XP(NP) ARRAY WHICH ON ENTRY C CONTAINS THE SPATIAL INTERPOLATION POINTS C WE ASSUME THAT C XP(I) < XP(I+1) , I = 1,...,NP-1 C UP(NPDE,NP,ITYPE) EMPTY ARRAY FOR THE INTERPOLATED VALUES AT C THE CURRENT TIME LEVEL. THE VALUES OF THIS C ARRAY ON EXIT DEPEND ON THE PARAMETER ITYPE. C U(NPDE,NPTS) THE CURRENT SOLUTION VECTOR COMPUTED BY THE ODE C TIME INTEGRATOR MUST BE SUPPLIED IN THIS VECTOR. C IFLAG ERROR FLAG = 0 ON SUCCESSFUL RETURN C = 1 IF EXTRAPOLATION TRIED. C = 2 IF WORKSPACE NOT INITIAL C ISED ON ENTRY BY INICHB. C = 3 ILLEGAL VALUE OF ITYPE. C ITYPE = 1 ONLY THE SOLUTION IS OUTPUT IN THE ARRAY UP C UP(J,K,1) HOLDS U(XP(K),T) FOR PDE J C 2 AS FOR 1 BUT THE FIRST DERIV IS ALSO OUTPUT. C UP(J,K,2) HOLDS D/DX U(XP(K),T). C C WK(IWK) THE WORKSPACE USED BY THE CHEBYSHEV METHOD. THIS C MUST BE THE WORKSPACE INITIALISED BY INICHB. C C C !*********************************************************! C ! IN THE CASE WHEN THE EXACT SOLUTION IS NOT KNOWN IT MAY ! C ! STILL BE NECESSARY TO SUPPLY A DUMMY ROUTINE EXACT TO ! C ! SATISFY LOADER REQUIREMENTS (SEE THE NEXT SECTION FOR A ! C ! DESCRIPTION OF EXACT. ! C !*********************************************************! C C ESTIMATING THE ERROR WHEN THE EXACT SOLUTION IS KNOWN. C ------------------------------------------------------ C THIS CAN BE DONE BY THE FOLLOWING CALL C C CALL ERROR(U,NPDE,NPTS,X,M,ENORM,GERR,T,RELERR,ABSERR, C * ITRACE,RWK,IWK) C C********************************************************************** C THE FOLLOWING ROUTINE COMPUTES THE ERROR ENORM IN THE NUMERICAL C SOLUTION BY USING A COMBINATION OF THE L2 FUNCTION AND VECTOR C NORMS. GERR IS THE MAXIMUM ERROR AT THE GRID POINTS C THE EXACT SOLUTION IS ASSUMED TO BE GIVEN BY THE USER PROVIDED C SUBROUTINE EXACT(T,NPDE, NP, XP, US) C DOUBLE PRECISION US(NPDE, NP),XP(NP),T C WHERE US(J,I) ON EXIT CONTAINS THE SOLUTION AT TIME T C FOR NPDE J AT THE MESH POINT XP(I) C C PARAMETER LIST C -------------- C U(NEQN) SOLUTION VECTOR COMPUTED BY DASSL AT TIME T . ON C ENTRY THIS ARRAY IS ASSUMED TO BE ORDERED AS FOLLOWS C U(1) - U(NPDE*NPTS) P.D.E. SOLUTION COMPONENTS. C U(NPDE*NPTS+1) - U(NEQN) O.D.E. COMPONENTS THAT ARE C COUPLED TO THE P.D.E. C C NPDE NUMBER OF PARABOLIC P.D.E.S IN ONE SPACE DIMENSION C C NPTS NUMBER OF SPATIAL GRID POINTS USED IN M.O.L. SOLUTION. C NOTE THIS SHOULD BE EQUAL TO (NPTL-1)*NEL + 1 C C X(NPTS) ON ENTRY THIS ARRAY MUST C CONTAIN THE MESH USED IN SEMI-DISCRETISATION C C M =0,1,2 IF CARTESIAN CYLINDRICAL OR SPHERICAL POLARS. C C ENORM L2 ERROR NORM ESTIMATED BY USING TRAPEZOIDAL RULE C WITH 100 EVENLY SPACED POINTS IS OUTPUT IN ENORM C C GERR MAXIMUM GRID ERROR OVER THE ARRAY OF SPATIAL GRID C POINTS X(NPTS) IS OUTPUT IN GERR C C T CURRENT TIME LEVEL OF TIME INTEGRATION ( INPUT). C C RELERR RELATIVE ERROR TOLERANCE SUPPLIED TO DASSL (RTOL IN C THE CALL TO THAT ROUTINE) (INPUT) C C ABSERR ABSOLUTE ERROR TOLERANCE SUPPLIED TO DASSL (ATOL IN C THE CALL TO THAT ROUTINE). (INPUT) C C ITRACE INTEGER TRACE LEVEL SET TO ZERO FOR NO TRACE SET =1 C FOR TRACE INFORMATION. (INPUT) C C RWK(IWK) REAL WORKSPACE INITIALISED BT INICHB AND PASSED TO C THE D.A.E.FUNCTION CALL ROUTINE RESID C SEE BELOW FOR A DETAILED DESCRIPTION.(INPUT) C********************************************************************** C EXAMPLE PROBLEM ONE C SOLUTION OF MOVING BOUNDARY PROBLEM BY CO-ORDINATE TRANSFORMATION. C******************************************************************** C THIS PROBLEM IS THE ONE PHASE STEFAN PROBLEM (HOFFMAN (1977) ) SEE C FURZELAND R.M. A COMPARATIVE STUDY OF NUMERICAL METHODS FOR MOVING C BOUNDARY PROBLEMS. J.I.M.A. (1977) ,26, PP 411 - 429. C THE PROBLEM HAS MELTING DUE TO HEAT INPUT AT THE FIXED C BOUNDARY . THE P.D.E. IS DEFINED BY THE EQUATIONS C U = U 0 < Y < S(T) , 0.1 < T < 1 C T YY C U = - EXP(T) , Y = 0 C Y . C U = 0 AND S(T) = - U ON THE MOVING BOUNDARY Y = S(T). C Y C AND THE INITIAL SOLUTION VALUES AT T = 0.1 ARE GIVEN BY THE ANALYTIC C SOLUTION C U = EXP(T-Y) - 1 , S(T) = T. C THE PROBLEM IS REWRITTEN BY USING THE CO-ORDINATE TRANSFORMATION C GIVEN BY X(T) = Y / S(T) . THE EQUATIONS THEN READ C . C S * S * U - S * S * X * U = U , X IN (0,1). C T X XX C WITH THE NEUMANN TYPE BOUNDARY CONDITIONS C . C U = - EXP(T) AT X=0 AND U = - S(T) * S(T) AT X = 1 C X X C AND THE O.D.E. COUPLING POINT EQUATION AT X = 1 WHICH IMPLICITLY C DEFINES S(T) IS GIVEN BY C U(1,T) = 0 C THE EXACT SOLUTION IS NOW DEFINED BY C U(X,T) = EXP((T - X*S(T)) , S(T) = T C C WE SHALL NOW DETAIL THE ROUTINES NEEDED TO DESCRIBE THIS PROBLEM. C PROBLEM DESCRIPTION ROUTINES C ****************************** C EXACT SOLUTION C SUBROUTINE EXACT( TIME, NPDE, NPTS, X, U) C ROUTINE FOR P.D.E. EXACT VALUES (IF KNOWN) C INTEGER NPDE, NPTS C DOUBLE PRECISION X(NPTS), U(NPDE,NPTS), TIME, P C P=DSQRT(2.0D0)*0.5D0 C DO 10 I = 1,NPTS C10 U(1,I) = DEXP( TIME * (1 - X(I))) - 1.0D0 C RETURN C END C SUBROUTINE UVINIT( NPDE, NPTS, X, U, NV, V) C ROUTINE FOR P.D.E. INITIAL VALUES. C INTEGER NPDE, NPTS, NV C DOUBLE PRECISION X(NPTS), U(NPDE,NPTS), TIME, V(NV) C TIME=0.1D0 C V(1)=0.1D0 C CALL EXACT(TIME,NPDE,NPTS,X,U) C RETURN C END C C SUBROUTINE SPDEFN(T, X, NPTL, NPDE, U, DUDX, UDOT, UTDX, Q, R, C 1 NV, V, VDOT, IRES) C PROBLEM INTERFACE FOR THE MOVING BOUNDARY PROBLEM. C INTEGER NPTL, NPDE, NV, I, IRES C DOUBLE PRECISION X(NPTL), U(NPDE,NPTL), DUDX(NPDE,NPTL), T, C 1 V(1), VDOT(1), F(NPDE,NPTL), Q(NPDE,NPTL) ,R(NPDE,NPTL), C 2 UDOT(NPDE,NPTL), UTDX(NPDE,NPTL) C DO 10 I = 1,NPTL C R(1,I) = DUDX(1,I) C Q(1,I) = V(1)*V(1)*UDOT(1,I) -X(I)*VD(I)*DUDX(1,I) * V(1) C10 CONTINUE C RETURN C END C SUBROUTINE SBNDR( T, BETA, GAMMA, U, UX, UDOT, UTDX, NPDE, C 1 LEFT, NV, V, VDOT, IRES) C THIS SUBROUTINE PROVIDES THE LEFT AND RIGHT BOUNDARY VALUES C FOR THE MOVING BOUNDARY PROBLEM IN THE FORM. C BETA(I) * DU/DX(I) = GAMMA(I) C WHERE I = 1,NPDE AND GAMMA IS A FUNCTION OF U,X AND T C C INTEGER NPDE, NV, IRES C LOGICAL LEFT C DOUBLE PRECISION BETA(NPDE), GAMMA(NPDE), U(NPDE), UX(NPDE) C - ,T, V(1), VDOT(1), UDOT(NPDE), UTDX(NPDE) C BETA(1) = 1.0D0 C IF(LEFT)THEN C GAMMA(1) = -V(1)*DEXP(T) C ELSE C GAMMA(1) = -V(1)*VD(1) C END IF C RETURN C END C C SUBROUTINE SODEFN(T, NV, V, VDOT, NPDE, NXI, XI, UI, UXI, RI, C 1 UTI, UTXI, VRES, IRES) C ROUTINE TO PROVIDE RESIDUAL OF COUPLED ODE SYSTEM FOR THE C MOVING BOUNDARY PROBLEM. C NOTE HOW IRES CAN BE RESET TO COPE WIH ILLEGAL VALUES OF THE C MOVING BOUNDARY POSITION V(1). C INTEGER NPDE, NXI, NV, IRES C DOUBLE PRECISION T, XI(NXI), UI(NPDE,NXI), UXI(NPDE,NXI), C 1 RI(NPDE,NXI), UTI(NPDE,NXI), UTXI(NPDE,NXI), VRES(NV), C 2 V(NV), VDOT(NV), TEM C VRES(1) = UI(1,1) C TEM = 1.0D0 C IF(IRES .EQ. -1)TEM = 0.0D0 C IF(V(1) .LT. 0.0D0)IRES = -1 C VRES(1) = TEM * UI(1,1) C RETURN C END C C EXAMPLE PROGRAM ONE .................... C C C0 COLLOCATION PARAMETERS C PARAMETER ( IBK = 21, NEL = IBK-1 , NPDE = 1, NV = 1, C 1 NPOLY = 2, NPTS = NEL*NPOLY+1, NXI = 1, C 2 NEQ = NPTS * NPDE + NV, C 3 NWKRES= (NPOLY+1) * (5*NXI + 3*NPOLY+NEL+5+7*NPDE) + C 4 NPDE * 8 + 3 + NV + NXI, C DDASSL TIME INTEGRATION PARAMETERS C 5 MAXORD = 5, LRW = 40 + (MAXORD+4) * NEQ + NEQ**2, C 6 LIW = 20 + NEQ ) C C INTEGER IWORK(LIW), INFO(15), IBAND, M, ITIME, I, IDID, IRESWK, C 1 IDEV, ITRACE C DOUBLE PRECISION XBK(IBK), X(NPTS), Y(NEQ), YDOT(NEQ), C 1 WKRES(NWKRES), RWORK(LRW), XI(1), T, TOUT, RTOL, ATOL, C 2 ENORM, GERR, VERROR, CTIME, TOL C EXTERNAL PDECHB, DGEJAC C COMMON /SDEV2/ ITRACE, IDEV C COMMON /PROB1/ TOL C TOL = 0.1D-5/50.D0 C M = 0 C T = TOL C IDEV = 4 C ITRACE = 1 C WRITE(IDEV,9)NPOLY, NEL C9 FORMAT(' TEST PROBLEM 1'/' ***********'/' POLY OF DEGREE =',I4, C 1 ' NO OF ELEMENTS = ',I4) C XI(1) = 1.0D0 C DO 10 I = 1,IBK C10 XBK(I) = (I-1.0D0)/(IBK-1.0D0) C INITIALISE THE P.D.E. WORKSPACE C ITIME = 1 C CALL INICHB(NEQ, NPDE, NPTS, X, Y, WKRES, NWKRES, M, T, IBAND, C 1 ITIME, XBK, IBK, NEL, NPOLY, NV, NXI, XI, IDEV) C IF(ITIME .EQ. -1)THEN C WRITE(IDEV, 15) C15 FORMAT(' INICHB ROUTINE RETURNED ITIME = -1 - RUN HALTED ') C GOTO 100 C END IF C SETUP DASSL PARAMETERS C RTOL = TOL C ATOL = TOL C DO 20 I = 1,11 C20 INFO(I) = 0 C BANDED MATRIX OPTION WHEN INFO(6) = 1 C IF(INFO(6) .EQ. 1)THEN C IWORK(1) = IBAND C IWORK(2) = IBAND C END IF C30 TOUT = T * 10.0D0 C IF(TOUT .GE. 2.D0)TOUT =2.0D0 C CALL DDASSL( PDECHB, NEQ, T, Y, YDOT, TOUT, INFO, RTOL, ATOL, C 1 IDID, RWORK, LRW, IWORK, LIW, WKRES, IRESWK, DGEJAC) C IF( IDID .LT. 0 )THEN C DASSL FAILED TO FINISH INTEGRATION. C WRITE(IDEV,40)T,IDID C40 FORMAT(' AT TIME T = ',D11.3,' DASSL RETURNED IDID =',I3) C GOTO 100 C ELSE C DASSL INTEGRATED TO T = TOUT C CALL TO POST PROCESSING HERE E.G. SPACE INTERPOLATION. C ITRACE = 1 C CALL ERROR( Y, NPDE, NPTS, X, M, ENORM, GERR, T, RTOL, ATOL, C 1 ITRACE, WKRES, NWKRES) C ITRACE = 0 C VERROR = Y(NEQ) - T C WRITE(IDEV,50)Y(NEQ),VERROR C50 FORMAT(' MOVING BOUNDARY IS AT ',D12.4,' WITH ERROR=',D12.4) C IF(TOUT .LT. 1.99D0 ) GOTO 30 C END IF C100 CONTINUE C WRITE(IDEV,110)IWORK(11),IWORK(12),IWORK(13) C110 FORMAT(' NSTEPS =',I5,' NRESID =',I5,' JAC = ',I4) C STOP C END C C C C EXAMPLE PROBLEM TWO C ******************** C THIS PROBLEM IS DEFINED BY C -2 2 2 C U U = X ( X U U ) + 5 U + 4 X U U , X IN (0,1) C T X X X C C THE LEFT BOUNDARY CONDITION AT X = 0 (LEFT = .TRUE. ) IS GIVEN BY C U (0,T) = 0.0 C X C THE RIGHT BOUNDARY CONDITION IS (LEFT = .FALSE.) C U( 1,T) = EXP ( -T ) C C THE INITIAL CONDITION IS GIVEN BY THE EXACT SOLUTION ; C U( X, T ) = EXP ( 1 - X*X - T ) , X IN ( 0,1) C 2 C********************************************************************** C C C0 COLLOCATION PARAMETERS C PARAMETER ( IBK = 2, NEL = IBK-1 , NPDE = 1, NV = 0, C 1 NPOLY = 10, NPTS = NEL*NPOLY+1, NXI = 0, C 2 NEQ = NPTS * NPDE + NV, C C NWKRES= 2*(NPOLY+1)*(NPOLY+NEL+2) + 2 + NV + C 3 NWKRES= (NPOLY+1) * (5*NXI + 3*NPOLY+NEL+5+7*NPDE) + C 4 NPDE * 8 + 3 + NV + NXI, C C NPDE * (7 * (NPOLY+1+NXI) + 8), C DDASSL TIME INTEGRATION PARAMETERS C 5 MAXORD = 5, LRW = 40 + (MAXORD+4) * NEQ + NEQ**2, C 6 LIW = 20 + NEQ ) C C INTEGER IWORK(LIW), INFO(15), IBAND, M, ITIME, I, IDID, IRESWK, C 1 IDEV, ITRACE C DOUBLE PRECISION XBK(IBK), X(NPTS), Y(NEQ), YDOT(NEQ), C 1 WKRES(NWKRES), RWORK(LRW), XI(1), T, TOUT, RTOL, ATOL, C 2 ENORM, GERR, CTIME C EXTERNAL PDECHB, DGEJAC C COMMON /SDEV2/ ITRACE, IDEV C M = 2 C T = 0.0D0 C IDEV = 4 C ITRACE = 1 C WRITE(IDEV,9)NPOLY, NEL C9 FORMAT(' TEST PROBLEM 1'/' ***********'/' POLY OF DEGREE =',I4, C 1 ' NO OF ELEMENTS = ',I4) C DO 10 I = 1,IBK C10 XBK(I) = (I-1.0D0) / (IBK - 1.0D0) C INITIALISE THE P.D.E. WORKSPACE C ITIME = 1 C CALL INICHB(NEQ, NPDE, NPTS, X, Y, WKRES, NWKRES, M, T, IBAND, C 1 ITIME, XBK, IBK, NEL, NPOLY, NV, NXI, XI, IDEV) C IF(ITIME .EQ. -1)THEN C WRITE(IDEV, 15) C15 FORMAT(' INICHB ROUTINE RETURNED ITIME = -1 - RUN HALTED ') C GOTO 100 C END IF C SETUP DASSL PARAMETERS C RTOL = 1.0D-8 C ATOL = 1.0D-8 C DO 20 I = 1,11 C20 INFO(I) = 0 C INFO(11)= 1 C BANDED MATRIX OPTION WHEN INFO(6) = 1 C IF(INFO(6) .EQ. 1)THEN C IWORK(1) = IBAND C IWORK(2) = IBAND C END IF C30 TOUT = T + 0.1D0 C CALL DDASSL( PDECHB, NEQ, T, Y, YDOT, TOUT, INFO, RTOL, ATOL, C 1 IDID, RWORK, LRW, IWORK, LIW, WKRES, IRESWK, DGEJAC) C IF( IDID .LT. 0 )THEN C DASSL FAILED TO FINISH INTEGRATION. C WRITE(IDEV,40)T,IDID C40 FORMAT(' AT TIME T = ',D11.3,' DASSL RETURNED IDID =',I3) C GOTO 100 C ELSE C DASSL INTEGRATED TO T = TOUT C CALL TO POST PROCESSING HERE E.G. SPACE INTERPOLATION. C CALL ERROR( Y, NPDE, NPTS, X, M, ENORM, GERR, T, RTOL, ATOL, C 1 ITRACE, WKRES, NWKRES) C IF(TOUT .LT. 0.99D0 ) GOTO 30 C END IF C100 CONTINUE C WRITE(IDEV,110)IWORK(11),IWORK(12),IWORK(13) C110 FORMAT(' NSTEPS =',I5,' NRESID =',I5,' JAC = ',I4) C STOP C END C SUBROUTINE UVINIT( NPDE, NPTS, X, U, NV,V) C ROUTINE FOR P.D.E. INITIAL VALUES. C INTEGER NPDE, NPTS, NV C DOUBLE PRECISION X(NPTS), U(NPDE,NPTS), V(1), T C T = 0.0D0 C V(1) IS A DUMMY VARIABLE AS THERE ARE NO COUPLED O.D.E.S C CALL EXACT( T, NPDE, NPTS, X, U ) C RETURN C END C C SUBROUTINE SPDEFN( T, X, NPTL, NPDE, U, DUDX, UDOT, UTDX, Q, R, C 1 NV, V, VDOT, IRES) C ROUTINE TO DESCRIBE THE BODY OF THE P.D.E. C THE P.D.E. IS WRITEN AS -M M C Q(X,T,U, U , U , U ) = X (X R(X,T,U,U , U , U )) C X T TX X T TX X C THE FUNCTIONS Q AND R MUST BE DEFINED IN THIS ROUTINE. C DEFINITIONS FOR THE MODEL PROBLEM ARE GIVEN C NOTE NV = 0 : THERE IS NO O.D.E PART. C INTEGER NPDE, NPTL, I, J, NV, IRES C DOUBLE PRECISION T, X(NPTL), U(NPDE,NPTL), DUDX(NPDE,NPTL), C 1 UDOT(NPDE,NPTL), Q(NPDE,NPTL), R(NPDE,NPTL), V, VDOT, C 2 UTDX(NPDE,NPTL) C DO 10 I = 1,NPTL C R(1,I) = U(1,I) * DUDX(1,I) C Q(1,I) = U(1,I) * UDOT(1,I) - 5.0D0 * U(1,I)**2 C 1 - 4.0D0 * U(1,I)*DUDX(1,I)*X(I) C10 CONTINUE C RETURN C END C C SUBROUTINE SBNDR( T, BETA, GAMMA, U, UX, UDOT, UTDX, NPDE, LEFT, C 1 NV, V, VDOT, IRES) C BOUNDARY CONDITIONS ROUTINE C INTEGER NPDE, NV, IRES C DOUBLE PRECISION T, BETA(NPDE), GAMMA(NPDE), U(NPDE), C2, C 1 UX(NPDE), V, VDOT, UDOT(NPDE), UTDX(NPDE) C LOGICAL LEFT C IF(LEFT) THEN C BETA (1) = 1.0D0 C GAMMA(1) = 0.0D0 C ELSE C BETA (1) = 0.0D0 C GAMMA(1) = U(1) - DEXP( -T ) C BETA (1) = 1.0D0 C GAMMA(1) = - 2.D0 *U(1)**2 C END IF C RETURN C END C C DUMMY O.D.E. ROUTINE AS NV IS ZERO C SUBROUTINE SODEFN C RETURN C END C EXACT SOLUTION C SUBROUTINE EXACT( TIME, NPDE, NPTS, X, U) C ROUTINE FOR P.D.E. EXACT VALUES (IF KNOWN) C INTEGER NPDE, NPTS, I C DOUBLE PRECISION X(NPTS), U(NPDE,NPTS), TIME C DO 10 I = 1,NPTS C10 U(1,I) = DEXP( 1.0D0 - X(I)**2 - TIME) C RETURN C END C C EXAMPLE PROBLEM 3 C ********************* C THIS PROBLEM IS DEFINED BY C -1 C U = ( C U ) - C * EXP(-2U) + EXP(-U) , X IN (-1,0) C T 1 X X 1 C AND C -1 C U = ( C U ) - C * EXP(-2U) + EXP(-U) , X IN (0,1) C T 2 X X 2 C WHERE C C = 0.1 AND C = 1.0 C 1 2 C C THE LEFT BOUNDARY CONDITION AT X =-1 (LEFT = .TRUE. ) IS GIVEN BY C U(-1,T) = LOG ( - C + T + P) C 1 C THE RIGHT BOUNDARY CONDITION IS (LEFT = .FALSE.) C U( 1,T) + (C + T + P ) U = LOG ( - C + T + P) + 1.0D0 C X C C THE INITIAL CONDITION IS GIVEN BY THE EXACT SOLUTION ; C U( X, T ) = LOG ( C X + T + P ) , X IN ( -1, 0) C 1 C U( X, T ) = LOG ( C X + T + P ) , X IN ( 0, 1) C 2 C********************************************************************** C SUBROUTINE UVINIT( NPDE, NPTS, X, U, NV,V) C ROUTINE FOR P.D.E. INITIAL VALUES. C INTEGER NPDE, NPTS, NV C DOUBLE PRECISION X(NPTS), U(NPDE,NPTS), V(1), T C T = 0.0D0 C V(1) IS A DUMMY VARIABLE AS THERE ARE NO COUPLED O.D.E.S C CALL EXACT( T, NPDE, NPTS, X, U ) C RETURN C END C C SUBROUTINE SPDEFN( T, X, NPTL, NPDE, U, DUDX, UDOT, UTDX, Q, R, C 1 NV, V, VDOT, IRES) C ROUTINE TO DESCRIBE THE BODY OF THE P.D.E. C THE P.D.E. IS WRITEN AS -M M C Q(X,T,U, U , U , U ) = X (X R(X,T,U,U , U , U )) C X T TX X T TX X C THE FUNCTIONS Q AND R MUST BE DEFINED IN THIS ROUTINE. C DEFINITIONS FOR THE MODEL PROBLEM ARE GIVEN C NOTE NV = 0 : THERE IS NO O.D.E PART. C INTEGER NPDE, NPTL, I, J, NV, IRES C DOUBLE PRECISION T, X(NPTL), U(NPDE,NPTL), DUDX(NPDE,NPTL), C 1 UDOT(NPDE,NPTL), Q(NPDE,NPTL), R(NPDE,NPTL), V, VDOT, C 2 UTDX(NPDE,NPTL), C C IF(X(1) .LT. 0.0D0 .AND. X(NPTL) .LE. 0.0D0)THEN C ELEMENT TO LEFT OF THE INTERFACE AT 0.0 C C = 0.1D0 C ELSE C C = 1.0D0 C END IF C DO 10 I = 1,NPTL C R(1,I) = DUDX(1,I) /C C Q(1,I) = UDOT(1,I) - DEXP(-U(1,I))- DEXP(-2.0D0*U(1,I))* C C10 CONTINUE C RETURN C END C C SUBROUTINE SBNDR( T, BETA, GAMMA, U, UX, UDOT, UTDX, NPDE, LEFT, C 1 NV, V, VDOT, IRES) C BOUNDARY CONDITIONS ROUTINE C INTEGER NPDE, NV, IRES C DOUBLE PRECISION T, BETA(NPDE), GAMMA(NPDE), U(NPDE), C2, C 1 UX(NPDE), V, VDOT, UDOT(NPDE), UTDX(NPDE) C LOGICAL LEFT C IF(LEFT) THEN C BETA (1) = 0.0D0 C GAMMA(1) = U(1) - DLOG( -0.1 + T + 1.0D0) C ELSE C C2 = 1.0D0 C BETA (1) = C2 * ( C2 + T + 1.0D0) C GAMMA(1) = U(1) - DLOG( C2 + T + 1.0D0) + 1.0D0 C END IF C RETURN C END C C DUMMY O.D.E. ROUTINE AS NV IS ZERO C SUBROUTINE SODEFN C RETURN C END C EXACT SOLUTION C SUBROUTINE EXACT( TIME, NPDE, NPTS, X, U) C ROUTINE FOR P.D.E. EXACT VALUES (IF KNOWN) C INTEGER NPDE, NPTS, I, IDERIV C DOUBLE PRECISION X(NPTS), U(NPDE,NPTS), TIME, C C COMMON /PROB3/ IDERIV C IF(IDERIV .EQ. 0)THEN C DO 10 I = 1,NPTS C C = 1.0D0 C IF(X(I) .LT. 0.0D0)C = 0.1D0 C10 U(1,I) = DLOG( TIME + 1.0D0 + C * X(I)) C ELSE C DO 20 I = 1,NPTS C C = 1.0D0 C IF(X(I) .LT. 0.0D0)C = 0.1D0 C U(1,I) = C / ( TIME + 1.0D0 + C * X(I)) C IF(X(I) .EQ. 0.0D0) U(1,I) = 0.55D0 / ( TIME + 1.0D0 ) C20 CONTINUE C END IF C RETURN C END C C C OTHER EXAMPLE PROBLEMS C ********************** C C EXAMPLE PROGRAMS ARE PROVIDED FOR THE POOL EVAPORATION PROBLEM C DESCRIBED IN THE PAPER THAT ACCOMPANIES THIS CODE AND FOR THE C C FOURTH ORDER P.D.E. PROBLEM WRITTEN AS ELLIPTIC-PARABOLIC SYSTEM. C C U = K U + UU - U U C XXT XXXX XXX X XX C C----------------------------------------------------------------------- C C SOFTWARE STRUCTURE C ****************** C C THE SUBROUTINES IN THIS MODULE CAN BE BROKEN DOWN INTO THREE C PARTS. C C 1) INITIALISATION ROUTINES 2) DEFINITION OF D.A.E.S C C ---------- ------------ C ! INICHB ! ! PDECHB ! C ---------- ------------ C ! ! ! ! C ---------- ---------------- ! ---------- C ! CSET ! ! DRES OR CRES ! ! ! CHINTR ! C ---------- ---------------- ! ---------- C ! ! ! ! C ---------- ---------- --------- ---------- C ! UVINIT ! ! SPDEFN ! ! SBNDR ! ! SODEFN ! C ---------- ---------- --------- ---------- C C THE FOUR BOTTOM LEVEL ROUTINES ARE THE USER DEFINED PROBLEM C DEFINITION ROUTINES. C C 3) POST PROCESSING (SPACE INTERPOLATION ). C C ---------- C ! INTERC ! THIS ROUTINE CAN BE CALLED BY THE USER. C ---------- C ! C ---------- C ! INTRCH ! SYSTEM INTERPOLATION ROUTINE ONLY. C ---------- C C 4) ERROR MESSAGE HANDLER C ALL THE ABOVE ROUTINES MAY CALL A GENERAL ERROR MESSAGE C HANDLING ROUTINE CALLED C ---------- C ! SCHERR ! C ---------- C C 5) OPTIONAL ERROR CALCULATION ROUTINE FOR ANALYTIC SOLUTION C PROBLEMS IN THIS CASE THE USER MAY CALL AN ERROR CALCULATION C ROUTINE CALLED ERROR WHICH IN TURN CALLS A USER DEFINED C ROUTINE TO SUPPLY THE ANALYTIC SOLUTION (MUST BE NAMED EXACT) C ---------- C ! ERROR ! C ---------- C ! C ---------- C ! EXACT ! C ---------- C---------------------------------------------------------------------- C C INTERFACES TO THE INDIVIDUAL ROUTINES NOW FOLLOW IN THE FOLLOWING C ORDER C (1) INICHB C (2) CSET C (3) PDECHB C (4) CHINTR C (5) INTERC C (6) INTRCH C (7) SCHERR C (8) ERROR C THE LAST ROUTINE IS A P.D.E. UTILITY TO EVALUATE THE P.D.E. C ERROR NORMS AND GRID ERRORS FOR PROBLEMS WITH ANALYTIC SOL. C C C*********************************************************************** SUBROUTINE INICHB(NEQN,NPDE,NPTS,X,U,WK,IWK,M,TS,IBAND,ITIME,XBK, * IBK,NEL,NPOLY,NV,NXI,XI,IDEV) C*********************************************************************** C ROUTINE FOR INITIALISATION OF CHEBYSHEV GENERALIZED COLLOCATION METHOD C C PARAMETER LIST C ---------------- C NEQN: EMPTY ON ENTRY, ON EXIT IT CONTAINS THE NUMBER OF C O.D.E.S GENERATED BY THE DISCRETISED FORM OF THE C P.D.E. , GIVEN BY NPDE*NEL*(NPTL-1) + NPDE + NV. C C NPDE NUMBER OF PARABOLIC P.D.E.S IN ONE SPACE DIMENSION C C NPTS NUMBER OF SPATIAL GRID POINTS USED IN M.O.L. SOLUTION. C NOTE THIS SHOULD BE EQUAL TO (NPTL-1)*NEL + 1 C C X(NPTS) EMPTY ARRAY ON ENTRY . ON EXIT THIS ARRAY C CONTAINS THE MESH USED IN SEMI-DISCRETISATION C C M =0,1,2 IF CARTESIAN CYLINDRICAL OR SPHERICAL POLARS. C C U(NEQN) SOLUTION VECTOR EMPTY ON ENTRY CONTAINS INITIAL C VALUES ON EXIT. THIS ARRAY IS ORDERED AS FOLLOWS. C U(1) - U(NPDE*NPTS) P.D.E. SOLUTION COMPONENTS. C U(NPDE*NPTS+1) - U(NEQN) O.D.E. COMPONENTS THAT ARE C COUPLED TO THE P.D.E. C C WK(IWK) REAL WORKSPACE USED TO PASS FOUR MATRICES AND VARIOUS C USEFUL VECTORS TO THE O.D.E.FUNCTION CALL ROUTINE C RESID SEE BELOW FOR A DETAILED DESCRIPTION. C C TS STARTING LEVEL OF TIME INTEGRATION. C C XBK(IBK) REAL ARRAY OF BREAK POINTS IBK = NEL +1 WHERE C NEL IS THE NUMBER OF SPATIAL ELEMENTS. C XBK(1) = XLEFT C XBK(I) =< XBK(I+1) I = 1,...,NEL . C XBK(IBK) = XRIGHT. C NEL THE NUMBER OF SPATIAL ELEMENTS , >= 1 C C NPOLY THE DEGREE OF THE APPROXIMATING POLYNOMIAL USED C BETWEEN EACH PAIR OF BREAKPOINTS . C ITIME THIS MUST BE SET = 1 ON THE CALL OF THIS MODULE C PRIOR TO THE DASSL PACKAGE BEING CALLED. C ONCE DASSL HAS RETURNED THIS ROUTINE MAY BE CALLED C WITH ITIME = 2 TO RECOVER THE SPATIAL MESH USED C (THIS IS PLACED IN THE ARRAY X(NPTS) ). C C NV THE NUMBER OF AUXILARY O.D.E.S THAT ARE COUPLED TO C THE P.D.E. C NXI THE NUMBER OF COUPLING POINTS AT WHICH P.D.E. VALUES C ARE USED TO DEFINE THE O.D.E.S C C XI(NXI) A VECTOR SPECIFYING THE POSITION OF THESE POINTS. C NOTE THAT THESE POINTS MUST BE DISTINCT FROM THE C BREAK - POINTS . C C IDEV NUMBER OF OUTPUT CHANNEL ON WHICH ERROR MESSAGES TO C DO WITH THE COLLOCATION DISCRETISATION WILL APPEAR. C C--------------------------------------------------------------------- C EIGHT IMPORTANT PARAMETERS ARE PASSED ACROSS FROM HERE IN C COMMON /SCHSZ1/ NNEL, NNPTL, NNPDE, NNPTS, MM, NNV, NNXI, NVST C C NNEL = NEL C C NNPTL = NPTL = NPOLY + 1 C C NNPDE = NPDE THE NUMBER OF P.D.E.S C C NNPTS = NPTS THE TOTAL NUMBER OF MESHPOINTS = NEL*(NPTL-1) + 1 C C MM = M = 0,1,2 CARTESIAN, CYLINDRICAL OR SPHERICAL POLAR C CO-ORDINATES IN USE. C NNV = NV NUMBER OF AUXILLARY ODES C C NNXI= NXI THE NUMBER OF COUPLING POINTS C C NVST THE STARTING POINT OF THE ODE COMPONENTS IN THE C SOLUTION VECTOR. C---------------------------------------------------------------------- C C DETAILED DESCRIPTION OF WORKSPACE C ----------------------------------- C THE WORKSPACE WK(IWK) IS USED TO PASS ARRAYS AND VECTORS TO C THE ROUTINES RESID AND CHINTR. C C SIZE : IWK MUST BE >= 2*NPTL*(NPTL+NEL+1) + 2 + NV + C NPDE*(7 * (NPTL + NXI) + 8) C C STRUCTURE NAME IN CODE PURPOSE IN CODE IS TO HOLD C ********* C WK(1) - WK(I2-1) OMEGA MATRIX OMEGA FOR MAPPING TO COEFFS C WK(I2) - WK(I3-1) DU MATRIX DU FOR FORMING DUDX C WK(I3) - WK(I4-1) DUTEM TEMPORARY WORK AREA C WK(I4) - WK(I7-1) XC CHEBYSHEV POINTS IN (-1,1) C WK(I7) - WK(I8-1) BETA BETA (NPDE,4) ARRAY FOR B.C.S C WK(I8) - WK(I9-1) GAMMA GAMMA(NPDE,4) ARRAY FOR B.C.S. C WK(I9) - WK(I10-1) DUDX DUDX(NPDE,NPTL) !WORKSPACES C WK(I10)- WK(I11-1) RT R(3*NPDE,NPTS) !USED INSIDE C WK(I11)- WK(I12-1) QT Q(3*NPDE,NPTS) !ROUTINE CRES C WK(I12)- WK(I13-1) CCR COEFFS OF CLENSHAW CURTIS RULE OF C DEGREE NPTL-1. C ---------------------THE FOLLOWING PARTS OF THE WORKSPACE ARE USED C IN SEMI-DISCRETISING MIXED O.D.E./P.D.E. C PROBLEMS. C WK(I13)- WK(I14-1) UI ARRAY UI(NPDE,NXI) USED TO HOLD THE C PDE COMPONENTS AT THE COUPLING PTS . C WK(I14)- WK(I15-1) UXI SPACE DERIVS CORRESS TO ARRAY UI. C WK(I15)- WK(I16-1) RI FLUX CORRESS TO UI ARRAY C WK(I16)- WK(I17-1) UTI TIME DERIV CORRESS TO UI ARRAY. C WK(I17)- WK(I18-1) UTXI SPACE DERIV OF ARRAY UTI. C WK(I18)- WK(I19-1) XI COUPLING POINTS TO LINK PDE TO ODE. C WK(I19)- WK(I20) VDUM ARRAY OF ZEROES. C C --------------------THE FOLLOWING TWO PARTS OF WK HOLD THE MESH C POINT INFORMATION USED IN SEMI-DISCRETISATION. C WK(I5) - WK(I6-1) XBK(IBK) BREAKPOINTS USED BY THE CODE C WK(I6) - WK(I13) X(NPTS) SPATIAL MESH POINTS USED BY THE CODE C C THE ARRAYS BETA AND GAMMA ARE USED IN THE FORMATION OF THE C BOUNDARY CONDITIONS. THE ARRAYS DUDX R AND Q HOLD THE TEMPORARY C VARIABLES NEEDED IN THE CONSTRUCTION OF THE RESIDUAL OF THE O.D.E. C SYSTEM. C NOTE ; THE MESH POINTS AND BREAK POINTS ARE STORED AT THE END OF THE C ***** WORKSPACE WK SO THAT THE BREAK POINTS MAY BE INCREASED OR C DECREASED BY A MESH MODIFICATION ROUTINE. IN SUCH CASES THE C MESH POINTS MUST BE RECOMPUTED AS THEY ARE THE CHEBYSHEV C POINTS IN (-1,1) MAPPED ONTO THE INTERVAL. THE CODE TO DO C THIS IS GIVEN BY C DO 10 I = 1, NEL C H1 = XBK(I+1) - XBK(I) C H2 = XBK(I=1) + XBK(I) C DO 10 J = 1, NPTL C IJ = (I-1)*(NPTL -1) + J C 10 X(IJ) = (XC(J)) * H1 + H2) * 0.5D0 C WHERE THE VALUES OF XBK AND XC MUST BE EXTRACTED FROM THE C WORKSPACE AND THE NEW VALUES OF X PUT IN THE WORKSPACE. C C THE PARAMETERS I2,...,I20 ARE DEFINED BELOW. C C********************************************************************** C .. Scalar Arguments .. DOUBLE PRECISION TS INTEGER IBAND, IBK, IDEV, ITIME, IWK, M, NEL, NEQN, * NPDE, NPOLY, NPTS, NV, NXI C .. Array Arguments .. DOUBLE PRECISION U(1), WK(IWK), X(NPTS), XBK(IBK), XI(1) C .. Scalars in Common .. DOUBLE PRECISION TO, TWOU INTEGER I10, I10A, I10B, I11, I11A, I11B, I12, I13, I14, * I15, I16, I17, I18, I19, I2, I3, I4, I5, I6, I7, * I8, I9, ILOC, INDEV, JTIMES, K1, K2, K3, K4, MM, * NNEL, NNNPTL, NNPDE, NNPTL, NNPTS, NNV, NNXI, * NVST CHARACTER*6 PDCODE C .. Local Scalars .. DOUBLE PRECISION TEMP, TEMP2 INTEGER I, I20, IBKM1, IT, IV, J, NPTL, NSQ CHARACTER*240 ERRMSG C .. External Subroutines .. EXTERNAL CSET, SCHERR C .. Intrinsic Functions .. INTRINSIC DABS, DMAX1 C .. Common blocks .. COMMON /DISCHK/PDCODE COMMON /SCHSZ/I2, I3, I4, I5, I6, I7, I8, I9, I10, * I10A, I10B, I11, I11A, I11B, I12, I13, I14, I15, * I16, I17, I18, I19 COMMON /SCHSZ1/NNEL, NNPTL, NNPDE, NNPTS, MM, NNV, * NNXI, NVST COMMON /SCHSZ2/INDEV COMMON /SCHSZ3/TWOU COMMON /SCHSZ4/TO, K1, K2, K3, K4, JTIMES, ILOC COMMON /SCHSZ5/NNNPTL C .. Save statement .. SAVE /SCHSZ1/, /SCHSZ/, /DISCHK/, /SCHSZ2/, /SCHSZ3/, * /SCHSZ4/, /SCHSZ5/ C .. Executable Statements .. INDEV = IDEV IF (ITIME.LT.1 .OR. ITIME.GT.2) THEN ERRMSG = *' INICHB DETECTED THAT THE SUPPLIED VALUE OF ITIME (VALUE = * I1 ) IS NOT IN THE RANGE ONE TO TWO ' CALL SCHERR(ERRMSG,1,1,ITIME,0,0,0.0D0,0.0D0) ITIME = -1 RETURN END IF IF (ITIME.EQ.2 .AND. PDCODE.EQ.'C0CHEB') GO TO 140 PDCODE = 'C0CHEB' TO = TS ILOC = -1 MM = M NNPDE = NPDE NPTL = NPOLY + 1 IF (NPOLY.LT.2 .OR. NPOLY.GT.49) THEN ERRMSG = *' INICHB ROUTINE DETECTED THAT THE SUPPLIED VALUE OF NPOLY * WAS (= I1 ) WHICH IS LESS THAN TWO OR GREATER THAN 49' CALL SCHERR(ERRMSG,1,1,NPOLY,0,0,0.0D0,0.0D0) ITIME = -1 END IF NNPTS = (NPTL-1)*NEL + 1 IF (NPTS.NE.NNPTS) THEN ERRMSG = *' INCORRECT VALUE OF NPTS (=I1) SUPPLIED IN CALL TO * INICHB. THE VALUE SHOULD BE (=I2)' CALL SCHERR(ERRMSG,1,2,NPTS,NNPTS,0,0.0D0,0.0D0) ITIME = -1 END IF NNEL = NEL NNPTL = NPTL NNV = NV NNXI = NXI NVST = NPDE*NPTS + 1 NEQN = NPDE*NPTS + NV IF (NV.GT.0) THEN IBAND = NEQN - 1 ELSE IBAND = (NPTL)*NPDE - 1 END IF IF (IBK.NE.(NEL+1)) THEN ERRMSG = *' INCORRECT VALUE OF IBK (=I1) SUPPLIED IN CALL TO * INICHB. THE VALUE SHOULD BE (=I2) PLUS 1' CALL SCHERR(ERRMSG,1,2,IBK,NEL,0,0.0D0,0.0D0) ITIME = -1 END IF X(1) = XBK(1) X(NPTS) = XBK(IBK) ITIME = 1 IF (X(NPTS).LE.X(1)) THEN ERRMSG = *' INICHB ROUTINE FOUND THAT THE LAST BREAK-POINT (=R1) HA *S BEEN PLACED BEFORE THE FIRST BREAK-POINT (= R2)' CALL SCHERR(ERRMSG,1,0,0,0,2,X(NPTS),X(1)) ITIME = -1 RETURN END IF IF (NEL.LT.1) THEN ERRMSG = *' INICHB ROUTINE - HAS DETECTED THAT THE SUPPLIED * VALUE OF NEL ( = I1 ) WHICH IS ILLEGAL ' CALL SCHERR(ERRMSG,1,1,NEL,0,0,0.0D0,0.0D0) ITIME = -1 RETURN END IF I = NEL*(NPTL-1) + 1 IF (I.NE.NPTS) THEN ERRMSG = *' INIT FOR C0 COLLOC- VALUES OF NEL AND NPTL FORM A MESH OF *(=I1) POINTS BUT NPTS IS SET TO ( =I2)' CALL SCHERR(ERRMSG,1,2,I,NPTS,0,0.0D0,0.0D0) ITIME = -1 RETURN END IF DO 20 I = 2, IBK IF (XBK(I).LE.XBK(I-1)) THEN ERRMSG = *' INICHB - BREAKPOINT NO (=I1) HAS VALUE (=R1) WHICH IS * SMALLER THAN OR EQUAL TO BREAKPOINT NO I1-1 WITH VAL *UE (=R2)' CALL SCHERR(ERRMSG,1,1,I,0,2,XBK(I),XBK(I-1)) ITIME = -1 RETURN END IF 20 CONTINUE C C CALCULATE ROUGH ESTIMATE OF UNIT ROUND-OFF ERROR FOR CHECKING C TWOU = 0.1D0 40 TEMP = 1.0D0 + TWOU IF (1.0D0.EQ.TEMP) THEN TWOU = TWOU*2.0D0 ELSE TWOU = TWOU*0.5D0 GO TO 40 END IF C C CHECK IF THE BREAK-POINTS MATCH THE COUPLING POINTS. C IF (IBK.GT.2 .AND. NXI.GT.0) THEN IBKM1 = IBK - 1 DO 80 I = 2, IBKM1 DO 60 J = 1, NXI TEMP = DABS(XI(J)-XBK(I)) TEMP2 = TWOU/DMAX1(TEMP,1.0D0) IF (TEMP.LT.TEMP2) THEN C COUPLING POINT IS TOO CLOSE TO BREAK-POINT ERRMSG = *' INICHB ROUTINE HAS FOUND THAT COUPLING POINT (= *I1) HAS VALUE (=R1) WHICH IS VERY CLOSE TO BREAK-PO *INT (=I2) WITH VALUE (=R2)' CALL SCHERR(ERRMSG,1,2,J,I,2,XI(J),XBK(I)) END IF 60 CONTINUE 80 CONTINUE END IF * C C FORM INTEGER CONSTANTS FOR WKSPACE MANIPULATION C NSQ = NPTL*NPTL IT = NPDE*NXI I2 = NSQ + 1 I3 = I2 + NSQ I4 = I3 + NSQ I7 = I4 + NPTL I8 = I7 + NPDE*4 I9 = I8 + NPDE*4 I10 = I9 + NPDE*NPTL I11 = I10 + NPDE*NPTL*3 I12 = I11 + NPDE*NPTL*3 I13 = I12 + NPTL I14 = I13 + IT I15 = I14 + IT I16 = I15 + IT I17 = I16 + IT I18 = I17 + IT I19 = I18 + NXI I5 = I19 + NV I6 = I5 + NEL + 1 I20 = I6 + NEL*(NPTL-1) + 1 I10A = I10 + NPDE*NPTL I10B = I10A + NPDE*NPTL I11A = I11 + NPDE*NPTL I11B = I11A + NPDE*NPTL K1 = 1 K2 = K1 + NEQN K3 = K2 + NEQN K4 = K3 + NEQN IF (I20.GT.IWK) THEN ERRMSG = *' INICHB-ROUTINE WORKSPACE OF SIZE (=I1) IS LESS THAN REQ *UIRED SIZE (=I2)' CALL SCHERR(ERRMSG,1,2,IWK,I20,0,0.0D0,0.0D0) ITIME = -1 RETURN END IF IV = NPDE*NPTS IF (NV.GT.0) THEN IV = NVST C COPY ACROSS THE COUPLING POINTS DO 100 I = 1, NXI WK(I18+I-1) = XI(I) 100 CONTINUE DO 120 I = 2, NXI IF (XI(I).LE.XI(I-1)) THEN ERRMSG = *' INICHB WARNING THE ODE/PDE COUPLING POINTS COUPLING * POINTS ARE NOT IN STRICTLY INCREASING ORDER' CALL SCHERR(ERRMSG,1,0,0,0,0,0.0D0,0.0D0) END IF 120 CONTINUE END IF C CALL CSET(NPDE,NPTS,U,WK(I6),WK,WK(I2),WK(I5),NEL,NPTL,WK(I4), * WK(I12),XBK,IBK,WK(I3),U(IV),NV) C 140 DO 160 I = 1, NPTS X(I) = WK(I6+I-1) 160 CONTINUE NNNPTL = NPTL RETURN END SUBROUTINE CSET(NPDE,NPTS,U,X,OMEGA,DU,XBK,NEL,NPTL,XC,CCR,XBH, * IBK,DUTEM,V,NV) C*********************************************************************** C FORTRAN FUNCTIONS USED: SIN COS . C*********************************************************************** C .. Scalar Arguments .. INTEGER IBK, NEL, NPDE, NPTL, NPTS, NV C .. Array Arguments .. DOUBLE PRECISIONCCR(NPTL), DU(NPTL,NPTL), DUTEM(NPTL,NPTL), * OMEGA(NPTL,NPTL), U(NPDE,NPTS), V(1), X(NPTS), * XBH(IBK), XBK(IBK), XC(NPTL) C .. Arrays in Common .. DOUBLE PRECISIONCCRULE(50) C .. Local Scalars .. DOUBLE PRECISIONH1, H2, PI, SINT, SUM, TEMP INTEGER I, IJ, ITEM, J, K, NM1, NT, NTP1 C .. External Subroutines .. EXTERNAL UVINIT C .. Intrinsic Functions .. INTRINSIC DBLE, DCOS, DSIN C .. Common blocks .. COMMON /SCHSZ6/CCRULE C .. Save statement .. SAVE /SCHSZ6/ C .. Executable Statements .. C C FORM CONSTANTS FOR WKSPACE INITIALISATION C NM1 = NPTL - 1 PI = 3.1415926535897930D0 C C FORMATION OF GRID AND INITIAL VALUES OF U C DO 40 I = 1, NEL H1 = XBH(I+1) - XBH(I) H2 = XBH(I+1) + XBH(I) XBK(I) = XBH(I) DO 20 J = 1, NPTL IJ = (I-1)*NM1 + J IF (I.EQ.1) XC(J) = DCOS(PI*DBLE(J-NPTL)/NM1) X(IJ) = (XC(J)*H1+H2)*0.5D0 IF (J.EQ.1) X(IJ) = XBH(I) IF (J.EQ.NPTL) X(IJ) = XBH(I+1) 20 CONTINUE 40 CONTINUE XBK(IBK) = XBH(IBK) XC(1) = -1.0D0 XC(NPTL) = 1.0D0 C C FORM THE MATRIX OMEGA C DO 80 J = 1, NPTL DO 60 I = 1, NPTL OMEGA(I,J) = 2.D0*DCOS(PI*(I-1)*(NPTL-J)/NM1)/NM1 60 CONTINUE 80 CONTINUE C C MODIFY EDGES OF OMEGA AND FORM EDGES OF INTERMEDIATE DU MATRIX C ITEM = 1 DO 100 I = 1, NPTL OMEGA(I,1) = OMEGA(I,1)*0.5D0 OMEGA(1,I) = OMEGA(1,I)*0.5D0 OMEGA(NPTL,I) = OMEGA(NPTL,I)*0.5D0 OMEGA(I,NPTL) = OMEGA(I,NPTL)*0.5D0 DUTEM(I,1) = 0.0D0 DUTEM(1,I) = -DBLE((I-1)**2*ITEM) DUTEM(NPTL,I) = DBLE((I-1)**2) ITEM = -ITEM 100 CONTINUE C C FINISH FORMING REST OF INTERMEDIATE DU MATRIX THAT IS HELD IN DUTEM. C IF (NPTL.GT.2) THEN DO 140 I = 2, NM1 TEMP = PI*(I-NPTL)/NM1 SINT = DSIN(TEMP) DO 120 J = 2, NM1 DUTEM(I,J) = DSIN(TEMP*(J-1))/SINT*(J-1) 120 CONTINUE DUTEM(I,NPTL) = 0.0D0 140 CONTINUE END IF C C FORM FULL DU BY MATRIX MULTIPLICATION C DO 200 I = 1, NPTL DO 180 J = 1, NPTL DU(I,J) = 0.0D0 DO 160 K = 1, NPTL DU(I,J) = DU(I,J) + DUTEM(I,K)*OMEGA(K,J) 160 CONTINUE 180 CONTINUE 200 CONTINUE C C CALCULATE THE COEFFS OF THE CLENSHAW CURTIS RULE C NT = NM1/2 IF ((2*NT).NE.NM1) NT = (NM1-1)/2 NTP1 = NT + 1 SUM = 0.0D0 DO 240 I = 1, NPTL TEMP = 0.5D0 CCR(I) = 0.0D0 DO 220 K = 1, NTP1 IF (K.EQ.NTP1 .AND. ((2*NT).EQ.NM1)) TEMP = 0.5D0 CCR(I) = CCR(I) + DCOS(2.0D0*(I-1)*(K-1)*PI/NM1) * *TEMP/(4.0D0*(K-1)**2-1.0D0) TEMP = 1.0D0 220 CONTINUE IF (I.EQ.1 .OR. I.EQ.NPTL) TEMP = 0.5D0 CCR(I) = CCR(I)*(-4.0D0)*TEMP/NM1 SUM = SUM + CCR(I) 240 CONTINUE DO 260 I = 1, NPTL CCRULE(I) = CCR(I) 260 CONTINUE DO 280 I = 2, NM1 CCR(I) = CCR(I)/CCR(1) 280 CONTINUE C FIND THE INITIAL VALUES OF THE O.D.E. AND P.D.E. COMPONENTS. CALL UVINIT(NPDE,NPTS,X,U,NV,V) RETURN C C-----------END OF CSET ROUTINE--------------------------------------- C END SUBROUTINE PDECHB(T,U,UDOT,RESD,IRES,WK,IWK) C*********************************************************************** C C THIS IS THE CHEBYSHEV GLOBAL ELEMENT ROUTINE TO EVALUATE THE C RESIDUAL OF THE IMPLICIT SET OF O.D.E.'S DEFINED BY C C RESIDUAL = A(U,T)*DU/DT - F(U,T) C C PARAMETER LIST C---------------- C T CURRENT TIME INTEGRATION LEVEL , > 0.0 C U(N) CURRENT SOLUTION VECTOR C RESD(N) VECTOR WHICH WILL CONTAIN THE RESIDUAL ON EXIT C UDOT(N) CURRENT ESTIMATE OF DU/DT C WK(1) REAL WORKSPACE - DEFINED IN INICHB C IWK(1) INTEGER WORKSPACE - NOT USED HERE. C IRES INDICATOR FOR DASSL FROM RESIDUAL ROUTINE. C ON EXIT = -1 THEN ILLEGAL SOLUTION VALUES HAVE BEEN C FOUND . C =-2 DASSL SHOULD HALT THE INTEGRATION. C C ONLY RESD(N) IS ALTERED ON EXIT : IT CONTAINS THE CURRENT RESIDUAL C*********************************************************************** C .. Scalar Arguments .. DOUBLE PRECISION T INTEGER IRES C .. Array Arguments .. DOUBLE PRECISION RESD(1), U(1), UDOT(1), WK(1) INTEGER IWK(1) C .. Scalars in Common .. INTEGER I10, I10A, I10B, I11, I11A, I11B, I12, I13, I14, * I15, I16, I17, I18, I19, I2, I3, I4, I5, I6, I7, * I8, I9, M, NEL, NPDE, NPTL, NPTS, NV, NVST, NXI CHARACTER*6 PDCODE C .. Local Scalars .. INTEGER I, IBK, IFL, IR, ITYPE, IV, J, N CHARACTER*240 ERRMSG C .. External Subroutines .. EXTERNAL CHINTR, CRES, DRES, SCHERR, SODEFN C .. Common blocks .. COMMON /DISCHK/PDCODE COMMON /SCHSZ/I2, I3, I4, I5, I6, I7, I8, I9, I10, * I10A, I10B, I11, I11A, I11B, I12, I13, I14, I15, * I16, I17, I18, I19 COMMON /SCHSZ1/NEL, NPTL, NPDE, NPTS, M, NV, NXI, NVST C .. Save statement .. SAVE /SCHSZ1/, /SCHSZ/, /DISCHK/ C .. Executable Statements .. C IF (PDCODE.NE.'C0CHEB') THEN ERRMSG = *' C0CHEB-RES ROUTINE ERROR-THE SETUP ROUTINE INICHB WAS NOT *CALLED BEFORE DASSL WAS ENTERED' CALL SCHERR(ERRMSG,1,0,0,0,0,0.0D0,0.0D0) IRES = -2 RETURN END IF C IR = 1 IRES = 1 N = NPDE*NPTS + NV DO 20 J = 1, N RESD(J) = 0.0D0 20 CONTINUE IBK = NEL + 1 IV = NPTS*NPDE IF (NV.GT.0) THEN IV = NVST C GENERATE THE SOLUTION VALUES SPACE DERIVS AND FLUXES AT THE C COUPLING POINTS ITYPE = 3 IFL = 0 CALL CHINTR(NXI,WK(I18),WK(I13),ITYPE,U,NPTS,NPDE,NEL,NPTL,WK, * WK(I10),WK(I5),IBK,IFL,NV,U(IV),UDOT(IV),WK(I11),T, * IR) IF (IR.NE.1 .OR. IFL.EQ.1) GO TO 60 C GENERATE TIME DERIV VALUES AND THEIR SPACE DERIVS AT THE C COUPLING POINTS. ITYPE = 2 CALL CHINTR(NXI,WK(I18),WK(I16),ITYPE,UDOT,NPTS,NPDE,NEL,NPTL, * WK,WK(I10),WK(I5),IBK,IFL,NV,U(IV),UDOT(IV),WK(I11) * ,T,IR) IF (IR.NE.1 .OR. IFL.EQ.1) GO TO 60 C CALL THE ROUTINE TO DEFINE THE AUXILLARY ODE RESIDUAL. CALL SODEFN(T,NV,U(IV),UDOT(IV),NPDE,NXI,WK(I18),WK(I13), * WK(I14),WK(I15),WK(I16),WK(I17),RESD(IV),IRES) IF (IRES.NE.1) GO TO 60 END IF C CALL THE CO COLLOCATION DISCRETISATION ROUTINE IR = 1 IF (NPTL.GT.2) THEN C GENERAL POLYNOMIAL VERSION. CALL CRES(NPDE,NPTS,T,U,RESD,UDOT,M,WK(I6),WK,WK(I2),WK(I5), * WK(I7),WK(I8),WK(I9),WK(I10),WK(I11),NEL,NPTL,WK(I4), * WK(I12),IRES,WK(I10A),WK(I11A),WK(I11B),WK(I10B),NV, * U(IV),UDOT(IV),WK(I19)) ELSE C LINEAR BASIS FUNCTION VERSION. CALL DRES(NPDE,NPTS,T,U,RESD,UDOT,M,WK(I6),WK,WK(I2),WK(I5), * WK(I7),WK(I8),WK(I9),WK(I10),WK(I11),NEL,NPTL,WK(I4), * WK(I12),IRES,WK(I10A),WK(I11A),WK(I11B),WK(I10B),NV, * U(IV),UDOT(IV),WK(I19)) END IF DO 40 I = 1, N RESD(I) = -RESD(I) 40 CONTINUE IF (IRES.NE.1) THEN IR = IRES GO TO 60 END IF RETURN 60 IRES = IR IF (IR.EQ.-2) THEN ERRMSG = *' ROUTINE PDECHB AT TIME T (=R1). THE VALUE OF IRES * HAS BEEN SET TO -2 TO TERMINATE INTEGRATION.' CALL SCHERR(ERRMSG,1,0,0,0,1,T,0.0D0) ELSE IF (IR.NE.-1) THEN ERRMSG = *' ROUTINE PDECHB AT TIME T (=R1). THE * VALUE OF IRES HAS BEEN SET TO AN ILLEGAL VALUE (=I1). *PDECHB HAS RESET IRES TO -1 AND INTEGRATION CONTINUES.' CALL SCHERR(ERRMSG,1,0,0,0,1,T,0.0D0) IRES = -1 END IF RETURN C C---------------------------END OF PDECHB----------------------------- C END SUBROUTINE CRES(NPDE,NPTS,T,U,RES,UDOT,M,X,OMEGA,DU,XBK,BETA, * GAMMA,DUDX,R,Q,NEL,NPTL,XC,CCR,IRES,RT,QT,UDT, * UTDX,NV,V,VDOT,VDUM) C********************************************************************** C CHEBYSHEV C0 COLLOCATION SPATIAL DISCRETISATION ROUTINE C FOR POLYNOMIALS OF DEGREE 2 AND ABOVE. C********************************************************************** C .. Scalar Arguments .. DOUBLE PRECISIONT INTEGER IRES, M, NEL, NPDE, NPTL, NPTS, NV C .. Array Arguments .. DOUBLE PRECISIONBETA(NPDE,4), CCR(NPTL), DU(NPTL,NPTL), * DUDX(NPDE,NPTL), GAMMA(NPDE,4), OMEGA(NPTL,NPTL), * Q(NPDE,NPTL), QT(NPDE,NPTL), R(NPDE,NPTL), * RES(NPDE,NPTS), RT(NPDE,NPTL), U(NPDE,NPTS), * UDOT(NPDE,NPTS), UDT(NPDE,NPTL), UTDX(NPDE,NPTL), * V(1), VDOT(1), VDUM(1), X(NPTS), XBK(1), XC(NPTL) C .. Scalars in Common .. DOUBLE PRECISIONTWOU C .. Local Scalars .. DOUBLE PRECISIONH, MP1, SAVEL, SAVER, SFIRST INTEGER I, II, IJ, IK, IV, J, JJ, JK, K, KJ, NM1 C .. Local Arrays .. INTEGER IZ(3) C .. External Subroutines .. EXTERNAL SBNDR, SPDEFN C .. Intrinsic Functions .. INTRINSIC MAX0, MIN0 C .. Common blocks .. COMMON /SCHSZ3/TWOU C .. Save statement .. SAVE /SCHSZ3/ C .. Executable Statements .. NM1 = NPTL - 1 IV = MAX0(1,NV) MP1 = 1.0D0 DO 260 I = 1, NEL JJ = (I-1)*NM1 IJ = JJ + 1 H = 2.0D0/(XBK(I+1)-XBK(I)) DO 20 IK = 1, 3 IZ(IK) = 1 20 CONTINUE C *************************************************************** C MAIN LOOP OVER ALL THE SPATIAL ELEMENTS START BY C FORMING THE SPACE DERIVS OF U AND UDOT IN DUDX AND UTDX C RESPECTIVELY. C ************************************************************** DO 80 K = 1, NPDE DO 60 II = 1, NPTL DUDX(K,II) = 0.0D0 UTDX(K,II) = 0.0D0 DO 40 J = 1, NPTL UTDX(K,II) = UTDX(K,II) + DU(II,J)*UDOT(K,JJ+J)*H DUDX(K,II) = DUDX(K,II) + DU(II,J)*U(K,JJ+J)*H 40 CONTINUE 60 CONTINUE 80 CONTINUE C --------------------------------------------------------------- C EVALUATE THE FUNCTIONS Q AND R IN THIS ELEMENT C -------------------------------------------------------------- CALL SPDEFN(T,X(IJ),NPTL,NPDE,U(1,IJ),DUDX,UDOT(1,IJ),UTDX,Q,R, * IV,V,VDOT,IZ(1)) IF (M.GT.0) THEN C MODIFY Q FUNCTION IF POLAR CO-ORDINATES KJ = 1 IF (X(IJ).LE.TWOU) THEN MP1 = 1.0D0 + M KJ = 2 DO 100 K = 1, NPDE C R(K,1) = 0.0D0 Q(K,1) = Q(K,1)/(M+1) 100 CONTINUE END IF DO 140 J = KJ, NPTL DO 120 K = 1, NPDE Q(K,J) = Q(K,J) - R(K,J)*M/X(JJ+J) 120 CONTINUE 140 CONTINUE END IF C ************************************************************** C FORM THE FUNCTIONS BETA AND GAMMA IN THE BOUNDARY CONDITIONS C ************************************************************** IF (I.EQ.1) THEN C LEFT HAND BOUNDARY CONDITIONS CALL SBNDR(T,BETA(1,1),GAMMA(1,1),U(1,1),DUDX,UDOT(1,1), * UTDX,NPDE,.TRUE.,IV,V,VDOT,IZ(2)) IF (IZ(2).NE.1) IRES = IZ(2) END IF IF (I.EQ.NEL) THEN C RIGHT HAND BOUNDARY CONDITIONS CALL SBNDR(T,BETA(1,2),GAMMA(1,2),U(1,NPTS),DUDX(1,NPTL), * UDOT(1,NPTS),UTDX(1,NPTL),NPDE,.FALSE.,IV,V,VDOT, * IZ(3)) IF (IZ(3).NE.1) IRES = IZ(3) END IF C --------------------------------------------------------------- C SET UP SAVEL AND SAVER FOR THE BOUNDARY AND INTERFACE C CONDITIONS AND FORM DRDX BY OVERWRITING DUDX C -------------------------------------------------------------- KJ = MAX0(2,I) JK = MIN0(NEL,I+1) + 1 SAVEL = 1.0D0/(XBK(KJ)+XBK(I+1)-XBK(KJ-1)-XBK(I)) SAVER = 1.0D0/(XBK(JK)+XBK(I+1)-XBK(JK-1)-XBK(I)) IF (I.EQ.1) SFIRST = SAVEL DO 200 K = 1, NPDE DO 180 II = 1, NPTL DUDX(K,II) = 0.0D0 DO 160 J = 1, NPTL DUDX(K,II) = DUDX(K,II) + DU(II,J)*R(K,J) 160 CONTINUE 180 CONTINUE 200 CONTINUE C --------------------------------------------------------------- C FORM THE RESIDUAL AND THE INTERFACE CONDITIONS C -------------------------------------------------------------- DO 240 J = 1, NPDE DO 220 K = 2, NM1 C COLLOCATION AT INTERIOR POINT RES(J,JJ+K) = Q(J,K) - DUDX(J,K)*H 220 CONTINUE JK = IJ + NM1 RES(J,IJ) = RES(J,IJ) + ((Q(J,1)/H-DUDX(J,1)-R(J,1)/CCR(1)) * *2.0)*SAVEL RES(J,JK) = ((Q(J,NPTL)/H-DUDX(J,NPTL)+R(J,NPTL)/CCR(1)) * *2.0)*SAVER 240 CONTINUE C TEST TO SEE IF ILLEGAL SOLUTION VALUES HAVE BEEN FOUND. IF (IZ(1).NE.1) THEN IRES = IZ(1) GO TO 300 END IF 260 CONTINUE C C PROCESS THE BOUNDARY CONDITIONS DO 280 J = 1, NPDE C L.H.--BOUNDARY CONDITION IS PROCESSED RES(J,1) = MP1*(RES(J,1)*BETA(J,1)*2.0D0+GAMMA(J,1) * *4.0D0/CCR(1)*SFIRST) C R.H.---BOUNDARY CONDITION IS PROCESSED RES(J,NPTS) = RES(J,NPTS)*BETA(J,2)*2.0D0 - GAMMA(J,2) * *4.0D0/CCR(1)*SAVER 280 CONTINUE 300 CONTINUE RETURN C-------END OF CRES---------------------------------------------------- C END SUBROUTINE DRES(NPDE,NPTS,T,U,RES,UDOT,M,X,OMEGA,DU,XBK,BETA, * GAMMA,DUDX,R,Q,NEL,NPTL,XC,CCR,IRES,RT,QT,UDT, * UTDX,NV,V,VDOT,VDUM) C********************************************************************** C CHEBYSHEV C0 COLLOCATION ROUTINE C THIS VERSION FOR USE WITH LINEAR BASIS FUNCTIONS ONLY C********************************************************************** C C .. Scalar Arguments .. DOUBLE PRECISIONT INTEGER IRES, M, NEL, NPDE, NPTL, NPTS, NV C .. Array Arguments .. DOUBLE PRECISIONBETA(NPDE,4), CCR(NPTL), DU(NPTL,NPTL), * DUDX(NPDE,NPTL), GAMMA(NPDE,4), OMEGA(NPTL,NPTL), * Q(NPDE,NPTL), QT(NPDE,NPTL), R(NPDE,NPTL), * RES(NPDE,NPTS), RT(NPDE,NPTL), U(NPDE,NPTS), * UDOT(NPDE,NPTS), UDT(NPDE,NPTL), UTDX(NPDE,NPTL), * V(1), VDOT(1), VDUM(1), X(NPTS), XBK(1), XC(NPTL) C .. Scalars in Common .. DOUBLE PRECISIONTWOU C .. Local Scalars .. DOUBLE PRECISIONH, MP1, SAVEL, SAVER, SFIRST, TEM INTEGER I, II, IJ, IK, IV, J, JJ, JK, K, KJ, NM1 C .. Local Arrays .. INTEGER IZ(3) C .. External Subroutines .. EXTERNAL SBNDR, SPDEFN C .. Intrinsic Functions .. INTRINSIC MAX0, MIN0 C .. Common blocks .. COMMON /SCHSZ3/TWOU C .. Save statement .. SAVE /SCHSZ3/ C .. Executable Statements .. NM1 = NPTL - 1 IV = MAX0(1,NV) MP1 = 1.0D0 DO 220 I = 1, NEL JJ = (I-1)*NM1 IJ = JJ + 1 H = 2.0D0/(XBK(I+1)-XBK(I)) DO 20 IK = 1, 3 IZ(IK) = 1 20 CONTINUE C *************************************************************** C MAIN LOOP OVER ALL THE SPATIAL ELEMENTS START BY FORMING THE C SPACE DERIVS OF U AND UDOT IN DUDX AND UTDX RESPECTIVELY. C ************************************************************** DO 80 K = 1, NPDE DO 60 II = 1, NPTL DUDX(K,II) = 0.0D0 UTDX(K,II) = 0.0D0 DO 40 J = 1, NPTL UTDX(K,II) = UTDX(K,II) + DU(II,J)*UDOT(K,JJ+J)*H DUDX(K,II) = DUDX(K,II) + DU(II,J)*U(K,JJ+J)*H 40 CONTINUE 60 CONTINUE 80 CONTINUE C IF (I.EQ.1) THEN C SAVE THE VALUES NEEDED FOR LEFT BOUNDARY CONDITIONS DO 100 J = 1, NPDE BETA(J,3) = DUDX(J,1) BETA(J,4) = UTDX(J,1) 100 CONTINUE END IF IF (I.EQ.NEL) THEN C SAVE THE VALUES NEEDED FOR RIGHT BOUNDARY CONDITIONS DO 120 J = 1, NPDE GAMMA(J,3) = DUDX(J,NPTL) GAMMA(J,4) = UTDX(J,NPTL) 120 CONTINUE END IF C --------------------------------------------------------------- C EVALUATE THE FUNCTIONS Q AND R IN THIS ELEMENT C -------------------------------------------------------------- CALL SPDEFN(T,X(IJ),NPTL,NPDE,U(1,IJ),DUDX,UDOT(1,IJ),UTDX,Q,R, * IV,V,VDOT,IZ(1)) IF (M.GT.0) THEN C MODIFY Q FUNCTION IF POLAR CO-ORDINATES KJ = 1 IF (X(IJ).LE.TWOU) THEN MP1 = 1.0D0 + M KJ = 2 DO 140 K = 1, NPDE C R(K,1) = 0.0D0 Q(K,1) = Q(K,1)/(M+1) 140 CONTINUE END IF DO 180 J = KJ, NPTL DO 160 K = 1, NPDE Q(K,J) = Q(K,J) - R(K,J)*M/X(JJ+J) 160 CONTINUE 180 CONTINUE END IF C --------------------------------------------------------------- C SET UP SAVEL AND SAVER FOR BOUNDARY AND INTERFACE CONDITIONS C -------------------------------------------------------------- KJ = MAX0(2,I) JK = MIN0(NEL,I+1) + 1 SAVEL = 1.0D0/(XBK(KJ)+XBK(I+1)-XBK(KJ-1)-XBK(I)) SAVER = 1.0D0/(XBK(JK)+XBK(I+1)-XBK(JK-1)-XBK(I)) IF (I.EQ.1) SFIRST = SAVEL C --------------------------------------------------------------- C FORM THE RESIDUAL AND THE INTERFACE CONDITIONS C -------------------------------------------------------------- DO 200 J = 1, NPDE JK = IJ + NM1 TEM = R(J,1) + R(J,NPTL) RES(J,IJ) = RES(J,IJ) + (Q(J,1)*2.0/H-TEM)*SAVEL RES(J,JK) = (Q(J,NPTL)*2.0/H+TEM)*SAVER 200 CONTINUE C TEST TO SEE IF ILLEGAL SOLUTION VALUES HAVE BEEN FOUND. IF (IZ(1).NE.1) THEN IRES = IZ(1) GO TO 280 END IF 220 CONTINUE C********************************************************************** C EVALUATE THE FUNCTIONS BETA AND GAMMA AT THE BOUNDARY CONDITIONS C********************************************************************** C CALL SBNDR(T,BETA(1,1),GAMMA(1,1),U(1,1),BETA(1,3),UDOT(1,1), * BETA(1,4),NPDE,.TRUE.,IV,V,VDOT,IZ(2)) CALL SBNDR(T,BETA(1,2),GAMMA(1,2),U(1,NPTS),GAMMA(1,3),UDOT(1, * NPTS),GAMMA(1,4),NPDE,.FALSE.,IV,V,VDOT,IZ(3)) C C PROCESS THE BOUNDARY CONDITIONS DO 240 J = 1, NPDE C L.H.--BOUNDARY CONDITION IS PROCESSED RES(J,1) = MP1*(RES(J,1)*BETA(J,1)*2.0D0+GAMMA(J,1) * *4.0D0/CCR(1)*SFIRST) C R.H.---BOUNDARY CONDITION IS PROCESSED RES(J,NPTS) = RES(J,NPTS)*BETA(J,2)*2.0D0 - GAMMA(J,2) * *4.0D0/CCR(1)*SAVER 240 CONTINUE DO 260 IK = 2, 3 IF (IZ(IK).NE.1) IRES = IZ(IK) 260 CONTINUE 280 CONTINUE RETURN C-------END OF DRES---------------------------------------------------- C END C*********************************************************************** C SUBROUTINE CHINTR(NP,XP,UP,ITYPE,U,NPTS,NPDE,NEL,NPTL,OMEGA,COEFF, * XBK,IBK,IFLAG,NV,V,VDOT,RT,T,IR) C C*********************************************************************** C PARAMETER LIST C ************** C XP(NP) THE MESH POINTS AT WHICH INTERPOLATED VALUES C ARE REQUIRED. THESE POINTS SUCH BE IN C INCREASING ORDER. C UP(NPDE,NP,ITYPE) ARRAY THAT HOLDS THE VALUES FOUND BY C INTERPOLATION. C IF ITYPE >= 1 UP(J,K,1) HOLDS THE SOLUTION VALUE AT MESH C POINT XP(K) FOR JTH PDE C IF ITYPE >= 2 UP(J,K,2) HOLDS THE SPACE DERIV OF THE SOLUTION C AT POINT XP(K) FOR JTH PDE. C IF ITYPE >= 3 UP(J,K,3) HOLDS THE FLUX R(..) AT THE POINT C XP(K) FOR THE JTH PDE. C C U(NPDE,NPTS) ORIGINAL SOLUTION VECTOR FROM THE ODE CODE. C C NPTS THE NUMBER OF MESH POINTS USED IN COMPUTING U. C NPDE THE NUMBER OF PDES IN THE PROBLEM. C NEL THE NUMBER OF SPATIAL ELEMENTS IN THE MESH. C NPTL THE NUMBER OF MESH POINTS PER ELEMENT. C THEREFORE NPTS = NEL*(NPTL-1) + 1 C OMEGA MATRIX USED IN MAPPING FROM THE SOLUTION ON A C SPATIAL INTERVAL TO ITS CHEBYSHEV COEFFS. C COEFFS WORKSPACE USED TO HOLD THESE COEFFS. C XBK(IBK) ARRAY USED TO HOLD THE BREAKPOINTS BETWEEN THE C SPATIAL ELEMENTS. C IFLAG ERROR FLAG SET TO 0 UNLESS EXTRAPOLATION IS C TRIED AND THEN SET TO 1. C NV THE SIZE OF THE ADDITIONAL ODE SYSTEM THAT IS C COUPLED TO THE PDE SYSTEM. C V(NV) COUPLED ODE VARIABLES C VDOT(NV) AND THEIR TIME DERIVS. C T THE CURRENT VALUE OF THE TIME VARIABLE. C NOTE --- THESE LAST FOUR VARIABLES ARE ONLY USED IF ITYPE = 3 C **** OTHERWISE DUMMY VARIABLES MAY BE PASSED ACROSS. C IR ; IRES PARAM TO TEST FOR ILLEGAL VALUES C THE METHOD USED IS DECOMPOSITION OF THE SOLUTION C PER ELEMENT INTO CHEBYSHEV COEFFICIENTS. THIS IS DONE BY C MATRIX MULTIPLICATION USING THE OMEGA MATRIX . F.F.T. C COULD ALSO BE USED. INTERPOLATION IS USED TO PROVIDE THOSE C SOLUTION VALUES IN THE ELEMENT (USING CLENSHAWS ALGORITHM). C C*********************************************************************** C .. Scalar Arguments .. DOUBLE PRECISION T INTEGER IBK, IFLAG, IR, ITYPE, NEL, NP, NPDE, NPTL, * NPTS, NV C .. Array Arguments .. DOUBLE PRECISION COEFF(NPDE,NPTL,2), OMEGA(NPTL,NPTL), * RT(NPDE,NPTL,3), U(NPDE,NPTS), UP(NPDE,NP,*), * V(1), VDOT(1), XBK(IBK), XP(NP) C .. Scalars in Common .. DOUBLE PRECISION TWOU C .. Local Scalars .. DOUBLE PRECISION AL, BR, BR1, BR2, TEM, TEM1 INTEGER I, II, IONE, IP, IP1, IX, IY, IZ, J, K, NM1 CHARACTER*240 ERRMSG C .. Local Arrays .. DOUBLE PRECISION XCON(2) C .. External Subroutines .. EXTERNAL SCHERR, SPDEFN C .. Intrinsic Functions .. INTRINSIC MIN0 C .. Common blocks .. COMMON /SCHSZ3/TWOU C .. Save statement .. SAVE /SCHSZ3/ C .. Executable Statements .. C C TREAT EACH ELEMENT SEPARATELY C TEM = 1.0D0 + TWOU TEM1 = 1.0D0 - TWOU IONE = 1 IP = 0 NM1 = NPTL - 1 IZ = 0 DO 280 I = 1, NEL IP1 = I + 1 IF (XBK(I).GT.(XBK(I+1)*TEM1-TWOU)) THEN ERRMSG = *' INTERC ROUTINE BREAKPOINT NUMBER (=I1) WITH VAL *UE (=R1) IS TOO CLOSE OR LARGER THAN BREAKPOINT NO (=I2) WI *TH VALUE (=R2). INCORRECT CALL TO INTERC ASSUMED OR WORKSPAC *E CORRUPTED' CALL SCHERR(ERRMSG,1,2,I,IP1,2,XBK(I),XBK(IP1)) GO TO 300 END IF 20 IP = IP + 1 IF (IP.EQ.(NP+1)) GO TO 300 IF (XP(IP).LT.(XBK(I)*TEM1-TWOU)) GO TO 20 IF (XP(IP).GT.(XBK(I+1)*TEM+TWOU)) GO TO 260 IF (XP(IP).GT.(XBK(I+1)*TEM1-TWOU)) THEN IF (I.LT.NEL .AND. ITYPE.GE.2) IZ = 1 C IZ = 1 MEANS THAT WEIGHTED AVERAGE MUST BE USED FOR C DERIVATIVE VALUES THAT ARE REQUESTED AT XBK(I+1) END IF C *************************************************************** C PROCESS A SEQUENCE OF XP(J) VALUES IN ELEMENT I C IX = START OF CORRECT PART OF SOLUTION VECTOR U C FORM THE CHEBYSHEV COEFFS IN THE ARRAY COEFF. C ************************************************************** IX = NM1*(I-1) DO 80 K = 1, NPDE DO 60 J = 1, NPTL COEFF(K,J,1) = 0.0D0 DO 40 II = 1, NPTL COEFF(K,J,1) = COEFF(K,J,1) + OMEGA(J,II)*U(K,IX+II) 40 CONTINUE 60 CONTINUE 80 CONTINUE C FORM THE CHEBYSHEV COEFFS OF THE SPACE DERIV. IF (ITYPE.GE.2) THEN DO 120 K = 1, NPDE COEFF(K,NPTL,2) = 0.0D0 COEFF(K,NPTL-1,2) = 2.0D0*NM1*COEFF(K,NPTL,1) DO 100 J = 2, NM1 COEFF(K,NPTL-J,2) = COEFF(K,NPTL-J+2,2) + COEFF(K, * NPTL-J+1,1)*2*(NPTL-J) 100 CONTINUE COEFF(K,1,2) = COEFF(K,1,2)*0.5D0 120 CONTINUE END IF XCON(1) = 2.0D0/(XBK(I+1)-XBK(I)) XCON(2) = -0.5D0*XCON(1)*(XBK(I+1)+XBK(I)) IY = MIN0(2,ITYPE) 140 DO 200 II = 1, IY DO 180 K = 1, NPDE BR1 = 0.0D0 BR2 = 0.0D0 C COEFF(K,NPTL) IS THE NPTL-TH COEFF OF SOLUTION OF PDE AL = (XP(IP)*XCON(1)+XCON(2))*2.0D0 BR = COEFF(K,NPTL,II) DO 160 J = 1, NM1 BR2 = COEFF(K,NPTL-J,II) + AL*BR - BR1 BR1 = BR BR = BR2 160 CONTINUE IF (II.EQ.1) THEN UP(K,IP,II) = BR - BR1*AL*0.5D0 ELSE IF (IZ.LT.2) THEN UP(K,IP,II) = (BR-BR1*AL*0.5)*XCON(1) ELSE UP(K,IP,II) = 1.D0/(XBK(I+1)-XBK(I-1))*(UP(K,IP,II) * *(XBK(I)-XBK(I-1))+(BR-BR1*AL*0.5) * *XCON(1)*(XBK(I+1)-XBK(I))) END IF 180 CONTINUE 200 CONTINUE C IF REQUIRED FORM THE FLUX AT THE INTERPLOATED POINTS (UNLESS C DERIV IS BEING FORMED BY WEIGHTED AVERAGE IN WHICH CASE WAIT C UNTIL THE FORMATION IS COMPLETE. IF (ITYPE.GE.3 .AND. IZ.NE.1) THEN C ZERO WORKSPACES USED IN THE FLUX CALL. DO 240 J = 1, 3 DO 220 K = 1, NPDE RT(K,1,J) = 0.0D0 220 CONTINUE 240 CONTINUE IR = 1 C FORM THE FLUX AT THE INTERPOLATED POINTS. CALL SPDEFN(T,XP(IP),IONE,NPDE,UP(1,IP,1),UP(1,IP,2),RT(1,1, * 1),RT(1,1,2),RT(1,1,3),UP(1,IP,3),NV,V,VDOT,IR) IF (IR.NE.1) THEN ERRMSG = *' ROUTINE SPDEFN SET IRES (=I1) WHEN CALLED FROM THE *INTERPOLATION ROUTINE TO CALCULATE FLUX VALUES' CALL SCHERR(ERRMSG,1,1,IR,0,0,0.0D0,0.0D0) GO TO 300 END IF END IF IF (IP.EQ.NP) GO TO 280 IP = IP + 1 IF (IZ.EQ.1) THEN IZ = 2 GO TO 260 C TO CALCULATE THE OTHER ELEMENTS CONTRIBUTION TO DERIV. END IF IF (IZ.EQ.2) IZ = 0 IF (XP(IP).LT.(XBK(I+1)*TEM1-TWOU)) THEN C PROCESS ANOTHER POINT IN THIS ELEMENT GO TO 140 ELSE IF (XP(IP).LT.(XBK(I+1)*TEM+TWOU)) THEN IF ((I+1).LT.NEL .AND. ITYPE.GE.2) IZ = 1 C IZ = 1 MEANS THAT WEIGHTED AVERAGE MUST BE USED FOR C DERIVATIVE VALUES THAT ARE REQUESTED AT XBK(I+1) GO TO 140 END IF 260 IP = IP - 2 280 CONTINUE RETURN 300 IFLAG = 1 RETURN C---------END OF CHINTR-------------------------------------------- C END SUBROUTINE INTERC(XP,UP,NP,U,NEQ,NPDE,IFLAG,ITYPE,WK,IWK) C******************************************************************** C C SPACE INTERPOLATION ROUTINE FOR POST-PROCESSING OF SOLUTION C PRODUCED BY DASSL. C THIS ROUTINES PROVIDES VALUES OF THE SOLUTION AND POSSIBLY THE C FIRST DERIV IN SPACE AND THE FLUX ON THE MESH XP(NP). C C PARAMETERS C -------------- C NPDE ON ENTRY MUST CONTAIN NO OF PARABOLIC EQUATIONS C NPTS ON ENTRY MUST CONTAIN THE NUMBER OF SPATIAL C MESH POINTS USED IN TIME INTEGRATION. C NP ON ENTRY MUST CONTAIN THE NUMBER OF SPATIAL C INTERPOLATION POINTS C XP(NP) ARRAY WHICH ON ENTRY C CONTAINS THE SPATIAL INTERPOLATION POINTS C WE ASSUME THAT C XP(I) < XP(I+1) , I = 1,...,NP-1 C UP(NPDE,NP,ITYPE) EMPTY ARRAY FOR THE INTERPOLATED VALUES AT C THE CURRENT TIME LEVEL. THE VALUES OF THIS C ARRAY ON EXIT DEPEND ON THE PARAMETER ITYPE. C U(NPDE,NPTS) THE CURRENT SOLUTION VECTOR COMPUTED BY THE ODE C TIME INTEGRATOR MUST BE SUPPLIED IN THIS VECTOR. C IFLAG ERROR FLAG = 0 ON SUCCESSFUL RETURN C = 1 IF EXTRAPOLATION TRIED. C = 2 IF WORKSPACE NOT INITIAL C ISED ON ENTRY BY INICHB. C = 3 ILLEGAL VALUE OF ITYPE. C ITYPE = 1 ONLY THE SOLUTION IS OUTPUT IN THE ARRAY UP C UP(J,K,1) HOLDS U(XP(K),T) FOR PDE J C 2 AS FOR 1 BUT THE FIRST DERIV IS ALSO OUTPUT. C UP(J,K,2) HOLDS D/DX U(XP(K),T). C C WK(IWK) THE WORKSPACE USED BY THE CHEBYSHEV METHOD. THIS C MUST BE THE WORKSPACE INITIALISED BY INICHB. C********************************************************************** C .. Scalar Arguments .. INTEGER IFLAG, ITYPE, IWK, NEQ, NP, NPDE C .. Array Arguments .. DOUBLE PRECISION U(NEQ), UP(NPDE,NP,ITYPE), WK(IWK), XP(NP) C .. Scalars in Common .. DOUBLE PRECISION TWOU INTEGER I10, I11, I19, I5, I9, MM, NEL, NNPDE, NNPTS, * NPTL, NV, NVST, NXI CHARACTER*6 PDCODE C .. Arrays in Common .. INTEGER IA(3), IB(3), IC(2), ID(9) C .. Local Scalars .. DOUBLE PRECISION TEMP INTEGER I, IBK, J, K, NPTS CHARACTER*240 ERRMSG C .. External Subroutines .. EXTERNAL INTRCH, SCHERR C .. Intrinsic Functions .. INTRINSIC DABS C .. Common blocks .. COMMON /DISCHK/PDCODE COMMON /SCHSZ/IA, I5, IB, I9, I10, IC, I11, ID, I19 COMMON /SCHSZ1/NEL, NPTL, NNPDE, NNPTS, MM, NV, NXI, * NVST COMMON /SCHSZ3/TWOU C .. Save statement .. SAVE /SCHSZ1/, /SCHSZ/, /DISCHK/, /SCHSZ3/ C .. Executable Statements .. IF (PDCODE.NE.'C0CHEB') THEN IFLAG = 1 GO TO 80 END IF IFLAG = 0 IBK = NEL + 1 IF (ITYPE.NE.1 .AND. ITYPE.NE.2) THEN ERRMSG = *' ILLEGAL VALUE OF ITYPE IN CALL TO SUBROUTINE INTERC * THE VALUE IS (=I1), BUT SHOULD BE 1 OR 2 ' CALL SCHERR(ERRMSG,1,1,ITYPE,0,0,0.0D0,0.0D0) IFLAG = 3 GO TO 80 END IF C C TEST THE INTERPOLATION POINTS XP(NP) TO ENSURE THAT THEY ARE IN C INCREASING ORDER AND THAT IF ITYPE = 2 (DERIVATIVES REQUIRED) THE C POINTS DO NOT CONFLICT WITH THE BREAK-POINTS. C DO 20 I = 2, NP TEMP = XP(I) - XP(I-1) IF (TEMP.LE.TWOU) THEN ERRMSG = *' INTERC ROUTINE CALLED WITH INTERP.POINTS NOT IN STRIC *TLY INCREASING ORDER I.E. COMPONENT NO (=I1) WITH VAL *UE (=R1) IS GREATER THAN COMPONENT( =I2) WITH VAL *UE (=R2).' CALL SCHERR(ERRMSG,1,2,J,I,2,XP(J),XP(I)) END IF 20 CONTINUE IF (ITYPE.GE.2 .AND. IBK.GT.2) THEN DO 60 I = 1, NP DO 40 J = 2, NEL TEMP = DABS(XP(I)-WK(I5-1+J)) IF (TEMP.LE.TWOU) THEN K = I5 + J - 1 ERRMSG = *' INTERC ROUTINE CALLED WITH ITYPE = 2 AND INTE *RP. POINTS EQUAL TO BREAK-POINTS I.E. COMPONEN *T NO (=I1) WITH VALUE (=R1) IS CLOSE * TO BREAK POINT(=I2) WITH VALUE (=R2).' CALL SCHERR(ERRMSG,1,2,I,J,2,XP(I),WK(K)) END IF 40 CONTINUE 60 CONTINUE END IF C C CALL THE INTERPOLATION ROUTINE. C NPTS = NNPTS CALL INTRCH(NP,XP,UP,ITYPE,U,NPTS,NPDE,NEL,NPTL,WK,WK(I10),WK(I5), * IBK,IFLAG) 80 CONTINUE RETURN END C*********************************************************************** C SUBROUTINE INTRCH(NP,XP,UP,ITYPE,U,NPTS,NPDE,NEL,NPTL,OMEGA,COEFF, * XBK,IBK,IFLAG) C C*********************************************************************** C PARAMETER LIST C ************** C XP(NP) THE MESH POINTS AT WHICH INTERPOLATED VALUES C ARE REQUIRED. THESE POINTS SUCH BE IN C INCREASING ORDER. C UP(NPDE,NP,ITYPE) ARRAY THAT HOLDS THE VALUES FOUND BY C INTERPOLATION. C IF ITYPE >= 1 UP(J,K,1) HOLDS THE SOLUTION VALUE AT MESH C POINT XP(K) FOR JTH PDE C IF ITYPE >= 2 UP(J,K,2) HOLDS THE SPACE DERIV OF THE SOLUTION C AT POINT XP(K) FOR JTH PDE. C C U(1..NEQN) ORIGINAL SOLUTION VECTOR FROM THE ODE CODE. C C NPTS THE NUMBER OF MESH POINTS USED IN COMPUTING U. C NPDE THE NUMBER OF PDES IN THE PROBLEM. C NEL THE NUMBER OF SPATIAL ELEMENTS IN THE MESH. C NPTL THE NUMBER OF MESH POINTS PER ELEMENT. C THEREFORE NPTS = NEL*(NPTL-1) + 1 C OMEGA MATRIX USED IN MAPPING FROM THE SOLUTION ON A C SPATIAL INTERVAL TO ITS CHEBYSHEV COEFFS. C COEFFS WORKSPACE USED TO HOLD THESE COEFFS. C XBK(IBK) ARRAY USED TO HOLD THE BREAKPOINTS BETWEEN THE C SPATIAL ELEMENTS. C IFLAG ERROR FLAG SET TO 0 UNLESS EXTRAPOLATION IS C TRIED AND THEN SET TO 1. C C THE METHOD USED IS DECOMPOSITION OF THE SOLUTION C PER ELEMENT INTO CHEBYSHEV COEFFICIENTS. THIS IS DONE BY C MATRIX MULTIPLICATION USING THE OMEGA MATRIX . F.F.T. C COULD ALSO BE USED. INTERPOLATION IS USED TO PROVIDE THOSE C SOLUTION VALUES IN THE ELEMENT (USING CLENSHAWS ALGORITHM). C C*********************************************************************** C .. Scalar Arguments .. INTEGER IBK, IFLAG, ITYPE, NEL, NP, NPDE, NPTL, NPTS C .. Array Arguments .. DOUBLE PRECISION COEFF(NPDE,NPTL,2), OMEGA(NPTL,NPTL), * U(NPDE,NPTS), UP(NPDE,NP,1), XBK(IBK), XP(NP) C .. Scalars in Common .. DOUBLE PRECISION TWOU C .. Local Scalars .. DOUBLE PRECISION AL, BR, BR1, BR2, CU, TEM, TEM1 INTEGER I, II, IP, IP1, IX, IY, IZ, J, K, NM1 CHARACTER*240 ERRMSG C .. Local Arrays .. DOUBLE PRECISION XCON(2) C .. External Subroutines .. EXTERNAL SCHERR C .. Intrinsic Functions .. INTRINSIC MIN0 C .. Common blocks .. COMMON /SCHSZ3/TWOU C .. Save statement .. SAVE /SCHSZ3/ C .. Executable Statements .. C C TREAT EACH ELEMENT SEPARATELY C CU = TWOU TEM1 = 1 - CU TEM = 1 + CU IP = 0 NM1 = NPTL - 1 IZ = 0 DO 240 I = 1, NEL IP1 = I + 1 IF (XBK(I).GT.(XBK(I+1)*TEM1-CU)) THEN ERRMSG = *' INTERC ROUTINE BREAKPOINT NUMBER (=I1) WITH VAL *UE (=R1) IS TOO CLOSE OR LARGER THAN BREAKPOINT NO (=I2) WI *TH VALUE (=R2). INCORRECT CALL TO INTERC ASSUMED OR WORKSPAC *E CORRUPTED' CALL SCHERR(ERRMSG,1,2,I,IP1,2,XBK(I),XBK(IP1)) GO TO 260 END IF 20 IP = IP + 1 IF (IP.EQ.(NP+1)) GO TO 260 IF (XP(IP).LT.(XBK(I)*TEM1-CU)) GO TO 20 IF (XP(IP).GT.(XBK(I+1)*TEM+CU)) THEN IP = IP - 1 GOTO 240 END IF IF (XP(IP).GE.(XBK(I+1)*TEM1-CU)) THEN IF (I.LT.NEL .AND. ITYPE.GE.2) IZ = 1 C IZ = 1 MEANS THAT WEIGHTED AVERAGE MUST BE USED FOR C DERIVATIVE VALUES THAT ARE REQUESTED AT XBK(I+1) END IF C *************************************************************** C PROCESS A SEQUENCE OF XP(J) VALUES IN ELEMENT I C IX = START OF CORRECT PART OF SOLUTION VECTOR U C FORM THE CHEBYSHEV COEFFS IN THE ARRAY COEFF. C *************************************************************** IX = NM1*(I-1) DO 80 K = 1, NPDE DO 60 J = 1, NPTL COEFF(K,J,1) = 0.0D0 DO 40 II = 1, NPTL COEFF(K,J,1) = COEFF(K,J,1) + OMEGA(J,II)*U(K,IX+II) 40 CONTINUE 60 CONTINUE 80 CONTINUE C FORM THE CHEBYSHEV COEFFS OF THE SPACE DERIV. IF (ITYPE.GE.2) THEN DO 120 K = 1, NPDE COEFF(K,NPTL,2) = 0.0D0 COEFF(K,NPTL-1,2) = 2.0D0*NM1*COEFF(K,NPTL,1) DO 100 J = 2, NM1 COEFF(K,NPTL-J,2) = COEFF(K,NPTL-J+2,2) + COEFF(K, * NPTL-J+1,1)*2*(NPTL-J) 100 CONTINUE COEFF(K,1,2) = COEFF(K,1,2)*0.5D0 120 CONTINUE END IF XCON(1) = 2.0D0/(XBK(I+1)-XBK(I)) XCON(2) = -0.5D0*XCON(1)*(XBK(I+1)+XBK(I)) IY = MIN0(2,ITYPE) 140 DO 200 II = 1, IY DO 180 K = 1, NPDE BR1 = 0.0D0 BR2 = 0.0D0 C COEFF(K,NPTL) IS THE NPTL-TH COEFF OF SOLUTION OF PDE K AL = (XP(IP)*XCON(1)+XCON(2))*2.0D0 BR = COEFF(K,NPTL,II) DO 160 J = 1, NM1 BR2 = COEFF(K,NPTL-J,II) + AL*BR - BR1 BR1 = BR BR = BR2 160 CONTINUE IF (II.EQ.1) THEN UP(K,IP,II) = BR - BR1*AL*0.5D0 ELSE IF (IZ.LT.2) THEN UP(K,IP,II) = (BR-BR1*AL*0.5)*XCON(1) ELSE UP(K,IP,II) = 1.D0/(XBK(I+1)-XBK(I-1))*(UP(K,IP,II) * *(XBK(I)-XBK(I-1))+(BR-BR1*AL*0.5) * *XCON(1)*(XBK(I+1)-XBK(I))) END IF 180 CONTINUE 200 CONTINUE IF (IP.EQ.NP) GO TO 240 IP = IP + 1 IF (IZ.EQ.1) THEN IZ = 2 GO TO 220 C TO CALCULATE THE OTHER ELEMENTS CONTRIBUTION TO DERIV. END IF IF (IZ.EQ.2) IZ = 0 IF (XP(IP).LE.(XBK(I+1)*TEM1-CU)) THEN GO TO 140 ELSE IF (XP(IP).LE.(XBK(I+1)*TEM+CU)) THEN IF (I.LT.NEL .AND. ITYPE.GE.2) IZ = 1 C IZ = 1 MEANS THAT WEIGHTED AVERAGE MUST BE USED FOR C DERIVATIVE VALUES THAT ARE REQUESTED AT XBK(I+1) GO TO 140 END IF 220 IP = IP - 2 240 CONTINUE RETURN 260 IFLAG = 1 RETURN C---------END OF INTRCH------------------------------------------- C END SUBROUTINE SCHERR(MSG,IERT,NI,I1,I2,NR,R1,R2) C----------------------------------------------------------------------- C ERROR HANDLING ROUTINE FOR THE DASSL INTEGRATION PACKAGE. THIS C ROUTINE IS A FORTRAN77 IMPROVED VERSION OF THE ROUTINE USED IN LSODI C AND MAKES USE OF CHARACTER HANDLING FACILITIES. C----------------------------------------------------------------------- C .. Scalar Arguments .. DOUBLE PRECISION R1, R2 INTEGER I1, I2, IERT, NI, NR CHARACTER*(*) MSG C .. Scalars in Common .. INTEGER NERR C .. Local Scalars .. INTEGER I, IL, IT, J, K, KP1, LWORD CHARACTER*(240) MSG1 C .. Local Arrays .. CHARACTER*(60) MSGOUT(5) C .. Intrinsic Functions .. INTRINSIC LEN, MIN0 C .. Common blocks .. COMMON /SCHSZ2/NERR C .. Save statement .. SAVE /SCHSZ2/ C .. Executable Statements .. C----------------------------------------------------------------------- C C ALL ARGUMENTS ARE INPUT ARGUMENTS. C C MSG = THE MESSAGE IN CHARACTER FORMAT C IERT = THE ERROR TYPE.. C 1 MEANS RECOVERABLE (CONTROL RETURNS TO CALLER). C 2 MEANS FATAL (RUN IS ABORTED--SEE NOTE BELOW). C NI = NUMBER OF INTEGERS (0, 1, OR 2) TO BE PRINTED WITH MESSAGE. C I1,I2 = INTEGERS TO BE PRINTED, DEPENDING ON NI. C NR = NUMBER OF REALS (0, 1, OR 2) TO BE PRINTED WITH MESSAGE. C R1,R2 = REALS TO BE PRINTED, DEPENDING ON NR. C----------------------------------------------------------------------- IL = LEN(MSG) C C SET MSG1 BLANK AND GET RID OF UNNECESSARY SPACES IN ERROR MESSAGE C J = 1 IT = MIN0(IL,240) DO 20 I = 1, 10 MSG1(J:) = ' ' J = J + 24 20 CONTINUE K = 0 J = 0 DO 40 I = 1, IT IF (MSG(I:I).EQ.' ') THEN K = K + 1 IF (K.GT.2) GO TO 40 ELSE K = 0 END IF J = J + 1 MSG1(J:J) = MSG(I:I) 40 CONTINUE IL = J C C FORMAT THE MESSAGE NOW STORED IN MSG1 C I = 1 LWORD = 60 J = 0 60 J = J + 1 IF (J.GT.1) LWORD = 51 K = I + LWORD - 1 KP1 = K + 1 80 IF (MSG1(K:K).NE.' ' .AND. MSG1(KP1:KP1).NE.' ') THEN K = K - 1 IF (K.EQ.I) THEN K = I + LWORD - 1 GO TO 100 END IF GO TO 80 END IF 100 IF (J.EQ.1) THEN MSGOUT(J) = MSG1(I:K) ELSE MSGOUT(J) = ' '//MSG1(I:K) END IF I = K + 1 IF (K.LT.IL .AND. J.LT.5) GO TO 60 C C OUTPUT THE ERROR MESSAGE C WRITE (NERR,FMT=99999) (MSGOUT(I),I=1,J) C C PRINT THE INTEGERS AND REALS IN THE ERROR MESSAGE (IF ANY) C IF (NI.EQ.1) WRITE (NERR,FMT=99998) I1 IF (NI.EQ.2) WRITE (NERR,FMT=99997) I1, I2 IF (NR.EQ.1) WRITE (NERR,FMT=99996) R1 IF (NR.EQ.2) WRITE (NERR,FMT=99995) R1, R2 C ABORT THE RUN IF IERT = 2. ------------------------------------------- IF (IERT.NE.2) RETURN STOP C----------------------- END OF SUBROUTINE SCHERR ---------------------- 99999 FORMAT (1X,A60) 99998 FORMAT (9X,' IN ABOVE MESSAGE I1 =',I10) 99997 FORMAT (9X,' IN ABOVE MESSAGE I1 =',I10,' I2 =',I10) 99996 FORMAT (9X,' IN ABOVE MESSAGE R1 =',D21.13) 99995 FORMAT (9X,'IN ABOVE, R1 =',D21.13,3X,'R2 =',D21.13) END C********************************************************************** C SUBROUTINE ERROR(U,NPDE,NPTS,X,M,ENORM,GERR,T,RELERR,ABSERR, * ITRACE,RWK,IWK) C C********************************************************************** C THE FOLLOWING ROUTINE COMPUTES THE ERROR ENORM IN THE NUMERICAL C SOLUTION BY USING A COMBINATION OF THE L2 FUNCTION AND VECTOR C NORMS. GERR IS THE MAXIMUM ERROR AT THE GRID POINTS C THE EXACT SOLUTION IS ASSUMED TO BE GIVEN BY THE USER PROVIDED C SUBROUTINE EXACT(T,NPDE, NP, XP, US) C DOUBLE PRECISION US(NPDE, NP),XP(NP),T C WHERE US(J,I) ON EXIT CONTAINS THE SOLUTION AT TIME T C FOR NPDE J AT THE MESH POINT XP(I) C C PARAMETER LIST C -------------- C U(NEQN) SOLUTION VECTOR COMPUTED BY DASSL AT TIME T . ON C ENTRY THIS ARRAY IS ASSUMED TO BE ORDERED AS FOLLOWS C U(1) - U(NPDE*NPTS) P.D.E. SOLUTION COMPONENTS. C U(NPDE*NPTS+1) - U(NEQN) O.D.E. COMPONENTS THAT ARE C COUPLED TO THE P.D.E. C C NPDE NUMBER OF PARABOLIC P.D.E.S IN ONE SPACE DIMENSION C C NPTS NUMBER OF SPATIAL GRID POINTS USED IN M.O.L. SOLUTION. C NOTE THIS SHOULD BE EQUAL TO (NPTL-1)*NEL + 1 C C X(NPTS) ON ENTRY THIS ARRAY MUST C CONTAIN THE MESH USED IN SEMI-DISCRETISATION C C M =0,1,2 IF CARTESIAN CYLINDRICAL OR SPHERICAL POLARS. C C ENORM L2 ERROR NORM ESTIMATED BY USING TRAPEZOIDAL RULE C WITH 100 EVENLY SPACED POINTS IS OUTPUT IN ENORM C C GERR MAXIMUM GRID ERROR OVER THE ARRAY OF SPATIAL GRID C POINTS X(NPTS) IS OUTPUT IN GERR C C T CURRENT TIME LEVEL OF TIME INTEGRATION ( INPUT). C C RELERR RELATIVE ERROR TOLERANCE SUPPLIED TO DASSL (RTOL IN C THE CALL TO THAT ROUTINE) (INPUT) C C ABSERR ABSOLUTE ERROR TOLERANCE SUPPLIED TO DASSL (ATOL IN C THE CALL TO THAT ROUTINE). (INPUT) C C ITRACE INTEGER TRACE LEVEL SET TO ZERO FOR NO TRACE SET =1 C FOR TRACE INFORMATION. (INPUT) C C RWK(IWK) REAL WORKSPACE INITIALISED BT INICHB AND PASSED TO C THE D.A.E.FUNCTION CALL ROUTINE RESID C SEE BELOW FOR A DETAILED DESCRIPTION.(INPUT) C C*********************************************************************** C .. Scalar Arguments .. DOUBLE PRECISION ABSERR, ENORM, GERR, RELERR, T INTEGER ITRACE, IWK, M, NPDE, NPTS C .. Array Arguments .. DOUBLE PRECISION RWK(IWK), U(NPDE,NPTS), X(NPTS) C .. Scalars in Common .. INTEGER IDEV C .. Local Scalars .. DOUBLE PRECISION EABS, EPS, ER, EREL, HH, WS INTEGER I, IFLAG, IN, IONE, JI, NEQ, NP C .. Local Arrays .. DOUBLE PRECISION ERR(5), UN(5), US(404), WX(5), XP(201) C .. External Subroutines .. EXTERNAL EXACT, INTERC C .. Intrinsic Functions .. INTRINSIC DABS, DMAX1, DSQRT C .. Common blocks .. COMMON /SCHSZ2/IDEV C .. Save statement .. SAVE /SCHSZ2/ C .. Executable Statements .. IONE = 1 C C SET UP L2 NORM WEIGHTS AND ESTIMATE NORM USING NP POINTS C EPS = DMAX1(RELERR,ABSERR) IF (EPS.LE.0.0) RETURN EREL = RELERR/EPS EABS = ABSERR/EPS DO 40 IN = 1, NPDE WX(IN) = 0.0D0 DO 20 I = 1, NPTS EPS = DABS(U(IN,I)) IF (WX(IN).LT.EPS) WX(IN) = EPS 20 CONTINUE WX(IN) = WX(IN)*EREL + EABS 40 CONTINUE NP = 201 HH = (X(NPTS)-X(1))/(NP-1) DO 60 IN = 1, NPDE ERR(IN) = 0.0D0 60 CONTINUE WS = 1.0D0 DO 80 I = 1, NP XP(I) = X(1) + (I-1)*HH 80 CONTINUE NEQ = NPTS*NPDE CALL INTERC(XP,US,NP,U,NEQ,NPDE,IFLAG,IONE,RWK,IWK) JI = 1 DO 120 I = 1, NP CALL EXACT(T,NPDE,IONE,XP(I),UN) IF (M.NE.0) WS = XP(I)**M DO 100 IN = 1, NPDE ER = DABS(US(JI)-UN(IN)) ERR(IN) = ERR(IN) + WS*ER**2 JI = JI + 1 100 CONTINUE 120 CONTINUE ENORM = 0.0D0 DO 140 IN = 1, NPDE ENORM = ENORM + ERR(IN)/WX(IN)**2 140 CONTINUE ENORM = DSQRT(ENORM*HH) C C COMPUTE THE MAXIMUM ERROR AT THE GRID POINTS C IF (ITRACE.GE.1) WRITE (IDEV,FMT=99999) GERR = 0.0D0 DO 180 I = 1, NPTS CALL EXACT(T,NPDE,IONE,X(I),UN) DO 160 IN = 1, NPDE ER = DABS(U(IN,I)-UN(IN)) IF (ITRACE.GE.1) WRITE (IDEV,FMT=99998) X(I), U(IN,I), * UN(IN), ER IF (GERR.LT.ER) GERR = ER 160 CONTINUE 180 CONTINUE IF (ITRACE.GT.0) WRITE (IDEV,FMT=99997) ENORM, GERR RETURN C 99999 FORMAT (6X,' MESH',6X,'NUM SOL',10X,'SOL',7X,'ERROR') 99998 FORMAT (4(2X,D11.3)) 99997 FORMAT (' ENORM=',D11.3,' GERR=',D11.3) END SUBROUTINE DGEFA(A,LDA,N,IPVT,INFO) INTEGER LDA,N,IPVT(1),INFO DOUBLE PRECISION A(LDA,1) C C DGEFA FACTORS A DOUBLE PRECISION MATRIX BY GAUSSIAN ELIMINATION. C C DGEFA IS USUALLY CALLED BY DGECO, BUT IT CAN BE CALLED C DIRECTLY WITH A SAVING IN TIME IF RCOND IS NOT NEEDED. C (TIME FOR DGECO) = (1 + 9/N)*(TIME FOR DGEFA) . C C ON ENTRY C C A DOUBLE PRECISION(LDA, N) C THE MATRIX TO BE FACTORED. C C LDA INTEGER C THE LEADING DIMENSION OF THE ARRAY A . C C N INTEGER C THE ORDER OF THE MATRIX A . C C ON RETURN C C A AN UPPER TRIANGULAR MATRIX AND THE MULTIPLIERS C WHICH WERE USED TO OBTAIN IT. C THE FACTORIZATION CAN BE WRITTEN A = L*U WHERE C L IS A PRODUCT OF PERMUTATION AND UNIT LOWER C TRIANGULAR MATRICES AND U IS UPPER TRIANGULAR. C C IPVT INTEGER(N) C AN INTEGER VECTOR OF PIVOT INDICES. C C INFO INTEGER C = 0 NORMAL VALUE. C = K IF U(K,K) .EQ. 0.0 . THIS IS NOT AN ERROR C CONDITION FOR THIS SUBROUTINE, BUT IT DOES C INDICATE THAT DGESL OR DGEDI WILL DIVIDE BY ZERO C IF CALLED. USE RCOND IN DGECO FOR A RELIABLE C INDICATION OF SINGULARITY. C C LINPACK. THIS VERSION DATED 08/14/78 . C CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB. C C SUBROUTINES AND FUNCTIONS C C BLAS DAXPY,DSCAL,IDAMAX C C INTERNAL VARIABLES C DOUBLE PRECISION T INTEGER IDAMAX,J,K,KP1,L,NM1 C C C GAUSSIAN ELIMINATION WITH PARTIAL PIVOTING C INFO = 0 NM1 = N - 1 IF (NM1 .LT. 1) GO TO 70 DO 60 K = 1, NM1 KP1 = K + 1 C C FIND L = PIVOT INDEX C L = IDAMAX(N-K+1,A(K,K),1) + K - 1 IPVT(K) = L C C ZERO PIVOT IMPLIES THIS COLUMN ALREADY TRIANGULARIZED C IF (A(L,K) .EQ. 0.0D0) GO TO 40 C C INTERCHANGE IF NECESSARY C IF (L .EQ. K) GO TO 10 T = A(L,K) A(L,K) = A(K,K) A(K,K) = T 10 CONTINUE C C COMPUTE MULTIPLIERS C T = -1.0D0/A(K,K) CALL DSCAL(N-K,T,A(K+1,K),1) C C ROW ELIMINATION WITH COLUMN INDEXING C DO 30 J = KP1, N T = A(L,J) IF (L .EQ. K) GO TO 20 A(L,J) = A(K,J) A(K,J) = T 20 CONTINUE CALL DAXPY(N-K,T,A(K+1,K),1,A(K+1,J),1) 30 CONTINUE GO TO 50 40 CONTINUE INFO = K 50 CONTINUE 60 CONTINUE 70 CONTINUE IPVT(N) = N IF (A(N,N) .EQ. 0.0D0) INFO = N RETURN END SUBROUTINE DGESL(A,LDA,N,IPVT,B,JOB) INTEGER LDA,N,IPVT(1),JOB DOUBLE PRECISION A(LDA,1),B(1) C C DGESL SOLVES THE DOUBLE PRECISION SYSTEM C A * X = B OR TRANS(A) * X = B C USING THE FACTORS COMPUTED BY DGECO OR DGEFA. C C ON ENTRY C C A DOUBLE PRECISION(LDA, N) C THE OUTPUT FROM DGECO OR DGEFA. C C LDA INTEGER C THE LEADING DIMENSION OF THE ARRAY A . C C N INTEGER C THE ORDER OF THE MATRIX A . C C IPVT INTEGER(N) C THE PIVOT VECTOR FROM DGECO OR DGEFA. C C B DOUBLE PRECISION(N) C THE RIGHT HAND SIDE VECTOR. C C JOB INTEGER C = 0 TO SOLVE A*X = B , C = NONZERO TO SOLVE TRANS(A)*X = B WHERE C TRANS(A) IS THE TRANSPOSE. C C ON RETURN C C B THE SOLUTION VECTOR X . C C ERROR CONDITION C C A DIVISION BY ZERO WILL OCCUR IF THE INPUT FACTOR CONTAINS A C ZERO ON THE DIAGONAL. TECHNICALLY THIS INDICATES SINGULARITY C BUT IT IS OFTEN CAUSED BY IMPROPER ARGUMENTS OR IMPROPER C SETTING OF LDA . IT WILL NOT OCCUR IF THE SUBROUTINES ARE C CALLED CORRECTLY AND IF DGECO HAS SET RCOND .GT. 0.0 C OR DGEFA HAS SET INFO .EQ. 0 . C C TO COMPUTE INVERSE(A) * C WHERE C IS A MATRIX C WITH P COLUMNS C CALL DGECO(A,LDA,N,IPVT,RCOND,Z) C IF (RCOND IS TOO SMALL) GO TO ... C DO 10 J = 1, P C CALL DGESL(A,LDA,N,IPVT,C(1,J),0) C 10 CONTINUE C C LINPACK. THIS VERSION DATED 08/14/78 . C CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB. C C SUBROUTINES AND FUNCTIONS C C BLAS DAXPY,DDOT C C INTERNAL VARIABLES C DOUBLE PRECISION DDOT,T INTEGER K,KB,L,NM1 C NM1 = N - 1 IF (JOB .NE. 0) GO TO 50 C C JOB = 0 , SOLVE A * X = B C FIRST SOLVE L*Y = B C IF (NM1 .LT. 1) GO TO 30 DO 20 K = 1, NM1 L = IPVT(K) T = B(L) IF (L .EQ. K) GO TO 10 B(L) = B(K) B(K) = T 10 CONTINUE CALL DAXPY(N-K,T,A(K+1,K),1,B(K+1),1) 20 CONTINUE 30 CONTINUE C C NOW SOLVE U*X = Y C DO 40 KB = 1, N K = N + 1 - KB B(K) = B(K)/A(K,K) T = -B(K) CALL DAXPY(K-1,T,A(1,K),1,B(1),1) 40 CONTINUE GO TO 100 50 CONTINUE C C JOB = NONZERO, SOLVE TRANS(A) * X = B C FIRST SOLVE TRANS(U)*Y = B C DO 60 K = 1, N T = DDOT(K-1,A(1,K),1,B(1),1) B(K) = (B(K) - T)/A(K,K) 60 CONTINUE C C NOW SOLVE TRANS(L)*X = Y C IF (NM1 .LT. 1) GO TO 90 DO 80 KB = 1, NM1 K = N - KB B(K) = B(K) + DDOT(N-K,A(K+1,K),1,B(K+1),1) L = IPVT(K) IF (L .EQ. K) GO TO 70 T = B(L) B(L) = B(K) B(K) = T 70 CONTINUE 80 CONTINUE 90 CONTINUE 100 CONTINUE RETURN END SUBROUTINE DGBFA(ABD,LDA,N,ML,MU,IPVT,INFO) INTEGER LDA,N,ML,MU,IPVT(1),INFO DOUBLE PRECISION ABD(LDA,1) C C DGBFA FACTORS A DOUBLE PRECISION BAND MATRIX BY ELIMINATION. C C DGBFA IS USUALLY CALLED BY DGBCO, BUT IT CAN BE CALLED C DIRECTLY WITH A SAVING IN TIME IF RCOND IS NOT NEEDED. C C ON ENTRY C C ABD DOUBLE PRECISION(LDA, N) C CONTAINS THE MATRIX IN BAND STORAGE. THE COLUMNS C OF THE MATRIX ARE STORED IN THE COLUMNS OF ABD AND C THE DIAGONALS OF THE MATRIX ARE STORED IN ROWS C ML+1 THROUGH 2*ML+MU+1 OF ABD . C SEE THE COMMENTS BELOW FOR DETAILS. C C LDA INTEGER C THE LEADING DIMENSION OF THE ARRAY ABD . C LDA MUST BE .GE. 2*ML + MU + 1 . C C N INTEGER C THE ORDER OF THE ORIGINAL MATRIX. C C ML INTEGER C NUMBER OF DIAGONALS BELOW THE MAIN DIAGONAL. C 0 .LE. ML .LT. N . C C MU INTEGER C NUMBER OF DIAGONALS ABOVE THE MAIN DIAGONAL. C 0 .LE. MU .LT. N . C MORE EFFICIENT IF ML .LE. MU . C ON RETURN C C ABD AN UPPER TRIANGULAR MATRIX IN BAND STORAGE AND C THE MULTIPLIERS WHICH WERE USED TO OBTAIN IT. C THE FACTORIZATION CAN BE WRITTEN A = L*U WHERE C L IS A PRODUCT OF PERMUTATION AND UNIT LOWER C TRIANGULAR MATRICES AND U IS UPPER TRIANGULAR. C C IPVT INTEGER(N) C AN INTEGER VECTOR OF PIVOT INDICES. C C INFO INTEGER C = 0 NORMAL VALUE. C = K IF U(K,K) .EQ. 0.0 . THIS IS NOT AN ERROR C CONDITION FOR THIS SUBROUTINE, BUT IT DOES C INDICATE THAT DGBSL WILL DIVIDE BY ZERO IF C CALLED. USE RCOND IN DGBCO FOR A RELIABLE C INDICATION OF SINGULARITY. C C BAND STORAGE C C IF A IS A BAND MATRIX, THE FOLLOWING PROGRAM SEGMENT C WILL SET UP THE INPUT. C C ML = (BAND WIDTH BELOW THE DIAGONAL) C MU = (BAND WIDTH ABOVE THE DIAGONAL) C M = ML + MU + 1 C DO 20 J = 1, N C I1 = MAX0(1, J-MU) C I2 = MIN0(N, J+ML) C DO 10 I = I1, I2 C K = I - J + M C ABD(K,J) = A(I,J) C 10 CONTINUE C 20 CONTINUE C C THIS USES ROWS ML+1 THROUGH 2*ML+MU+1 OF ABD . C IN ADDITION, THE FIRST ML ROWS IN ABD ARE USED FOR C ELEMENTS GENERATED DURING THE TRIANGULARIZATION. C THE TOTAL NUMBER OF ROWS NEEDED IN ABD IS 2*ML+MU+1 . C THE ML+MU BY ML+MU UPPER LEFT TRIANGLE AND THE C ML BY ML LOWER RIGHT TRIANGLE ARE NOT REFERENCED. C C LINPACK. THIS VERSION DATED 08/14/78 . C CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB. C C SUBROUTINES AND FUNCTIONS C C BLAS DAXPY,DSCAL,IDAMAX C FORTRAN MAX0,MIN0 C C INTERNAL VARIABLES C DOUBLE PRECISION T INTEGER I,IDAMAX,I0,J,JU,JZ,J0,J1,K,KP1,L,LM,M,MM,NM1 C C M = ML + MU + 1 INFO = 0 C C ZERO INITIAL FILL-IN COLUMNS C J0 = MU + 2 J1 = MIN0(N,M) - 1 IF (J1 .LT. J0) GO TO 30 DO 20 JZ = J0, J1 I0 = M + 1 - JZ DO 10 I = I0, ML ABD(I,JZ) = 0.0D0 10 CONTINUE 20 CONTINUE 30 CONTINUE JZ = J1 JU = 0 C C GAUSSIAN ELIMINATION WITH PARTIAL PIVOTING C NM1 = N - 1 IF (NM1 .LT. 1) GO TO 130 DO 120 K = 1, NM1 KP1 = K + 1 C C ZERO NEXT FILL-IN COLUMN C JZ = JZ + 1 IF (JZ .GT. N) GO TO 50 IF (ML .LT. 1) GO TO 50 DO 40 I = 1, ML ABD(I,JZ) = 0.0D0 40 CONTINUE 50 CONTINUE C C FIND L = PIVOT INDEX C LM = MIN0(ML,N-K) L = IDAMAX(LM+1,ABD(M,K),1) + M - 1 IPVT(K) = L + K - M C C ZERO PIVOT IMPLIES THIS COLUMN ALREADY TRIANGULARIZED C IF (ABD(L,K) .EQ. 0.0D0) GO TO 100 C C INTERCHANGE IF NECESSARY C IF (L .EQ. M) GO TO 60 T = ABD(L,K) ABD(L,K) = ABD(M,K) ABD(M,K) = T 60 CONTINUE C C COMPUTE MULTIPLIERS C T = -1.0D0/ABD(M,K) CALL DSCAL(LM,T,ABD(M+1,K),1) C C ROW ELIMINATION WITH COLUMN INDEXING C JU = MIN0(MAX0(JU,MU+IPVT(K)),N) MM = M IF (JU .LT. KP1) GO TO 90 DO 80 J = KP1, JU L = L - 1 MM = MM - 1 T = ABD(L,J) IF (L .EQ. MM) GO TO 70 ABD(L,J) = ABD(MM,J) ABD(MM,J) = T 70 CONTINUE CALL DAXPY(LM,T,ABD(M+1,K),1,ABD(MM+1,J),1) 80 CONTINUE 90 CONTINUE GO TO 110 100 CONTINUE INFO = K 110 CONTINUE 120 CONTINUE 130 CONTINUE IPVT(N) = N IF (ABD(M,N) .EQ. 0.0D0) INFO = N RETURN END SUBROUTINE DGBSL(ABD,LDA,N,ML,MU,IPVT,B,JOB) INTEGER LDA,N,ML,MU,IPVT(1),JOB DOUBLE PRECISION ABD(LDA,1),B(1) C C DGBSL SOLVES THE DOUBLE PRECISION BAND SYSTEM C A * X = B OR TRANS(A) * X = B C USING THE FACTORS COMPUTED BY DGBCO OR DGBFA. C C ON ENTRY C C ABD DOUBLE PRECISION(LDA, N) C THE OUTPUT FROM DGBCO OR DGBFA. C C LDA INTEGER C THE LEADING DIMENSION OF THE ARRAY ABD . C C N INTEGER C THE ORDER OF THE ORIGINAL MATRIX. C C ML INTEGER C NUMBER OF DIAGONALS BELOW THE MAIN DIAGONAL. C C MU INTEGER C NUMBER OF DIAGONALS ABOVE THE MAIN DIAGONAL. C C IPVT INTEGER(N) C THE PIVOT VECTOR FROM DGBCO OR DGBFA. C C B DOUBLE PRECISION(N) C THE RIGHT HAND SIDE VECTOR. C C JOB INTEGER C = 0 TO SOLVE A*X = B , C = NONZERO TO SOLVE TRANS(A)*X = B , WHERE C TRANS(A) IS THE TRANSPOSE. C C ON RETURN C C B THE SOLUTION VECTOR X . C C ERROR CONDITION C C A DIVISION BY ZERO WILL OCCUR IF THE INPUT FACTOR CONTAINS A C ZERO ON THE DIAGONAL. TECHNICALLY THIS INDICATES SINGULARITY C BUT IT IS OFTEN CAUSED BY IMPROPER ARGUMENTS OR IMPROPER C SETTING OF LDA . IT WILL NOT OCCUR IF THE SUBROUTINES ARE C CALLED CORRECTLY AND IF DGBCO HAS SET RCOND .GT. 0.0 C OR DGBFA HAS SET INFO .EQ. 0 . C C TO COMPUTE INVERSE(A) * C WHERE C IS A MATRIX C WITH P COLUMNS C CALL DGBCO(ABD,LDA,N,ML,MU,IPVT,RCOND,Z) C IF (RCOND IS TOO SMALL) GO TO ... C DO 10 J = 1, P C CALL DGBSL(ABD,LDA,N,ML,MU,IPVT,C(1,J),0) C 10 CONTINUE C C LINPACK. THIS VERSION DATED 08/14/78 . C CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB. C C SUBROUTINES AND FUNCTIONS C C BLAS DAXPY,DDOT C FORTRAN MIN0 C C INTERNAL VARIABLES C DOUBLE PRECISION DDOT,T INTEGER K,KB,L,LA,LB,LM,M,NM1 C M = MU + ML + 1 NM1 = N - 1 IF (JOB .NE. 0) GO TO 50 C C JOB = 0 , SOLVE A * X = B C FIRST SOLVE L*Y = B C IF (ML .EQ. 0) GO TO 30 IF (NM1 .LT. 1) GO TO 30 DO 20 K = 1, NM1 LM = MIN0(ML,N-K) L = IPVT(K) T = B(L) IF (L .EQ. K) GO TO 10 B(L) = B(K) B(K) = T 10 CONTINUE CALL DAXPY(LM,T,ABD(M+1,K),1,B(K+1),1) 20 CONTINUE 30 CONTINUE C C NOW SOLVE U*X = Y C DO 40 KB = 1, N K = N + 1 - KB B(K) = B(K)/ABD(M,K) LM = MIN0(K,M) - 1 LA = M - LM LB = K - LM T = -B(K) CALL DAXPY(LM,T,ABD(LA,K),1,B(LB),1) 40 CONTINUE GO TO 100 50 CONTINUE C C JOB = NONZERO, SOLVE TRANS(A) * X = B C FIRST SOLVE TRANS(U)*Y = B C DO 60 K = 1, N LM = MIN0(K,M) - 1 LA = M - LM LB = K - LM T = DDOT(LM,ABD(LA,K),1,B(LB),1) B(K) = (B(K) - T)/ABD(M,K) 60 CONTINUE C C NOW SOLVE TRANS(L)*X = Y C IF (ML .EQ. 0) GO TO 90 IF (NM1 .LT. 1) GO TO 90 DO 80 KB = 1, NM1 K = N - KB LM = MIN0(ML,N-K) B(K) = B(K) + DDOT(LM,ABD(M+1,K),1,B(K+1),1) L = IPVT(K) IF (L .EQ. K) GO TO 70 T = B(L) B(L) = B(K) B(K) = T 70 CONTINUE 80 CONTINUE 90 CONTINUE 100 CONTINUE RETURN END SUBROUTINE DAXPY(N,DA,DX,INCX,DY,INCY) C C CONSTANT TIMES A VECTOR PLUS A VECTOR. C USES UNROLLED LOOPS FOR INCREMENTS EQUAL TO ONE. C JACK DONGARRA, LINPACK, 3/11/78. C DOUBLE PRECISION DX(1),DY(1),DA INTEGER I,INCX,INCY,IX,IY,M,MP1,N C IF(N.LE.0)RETURN IF (DA .EQ. 0.0D0) RETURN IF(INCX.EQ.1.AND.INCY.EQ.1)GO TO 20 C C CODE FOR UNEQUAL INCREMENTS OR EQUAL INCREMENTS C NOT EQUAL TO 1 C IX = 1 IY = 1 IF(INCX.LT.0)IX = (-N+1)*INCX + 1 IF(INCY.LT.0)IY = (-N+1)*INCY + 1 DO 10 I = 1,N DY(IY) = DY(IY) + DA*DX(IX) IX = IX + INCX IY = IY + INCY 10 CONTINUE RETURN C C CODE FOR BOTH INCREMENTS EQUAL TO 1 C C C CLEAN-UP LOOP C 20 M = MOD(N,4) IF( M .EQ. 0 ) GO TO 40 DO 30 I = 1,M DY(I) = DY(I) + DA*DX(I) 30 CONTINUE IF( N .LT. 4 ) RETURN 40 MP1 = M + 1 DO 50 I = MP1,N,4 DY(I) = DY(I) + DA*DX(I) DY(I + 1) = DY(I + 1) + DA*DX(I + 1) DY(I + 2) = DY(I + 2) + DA*DX(I + 2) DY(I + 3) = DY(I + 3) + DA*DX(I + 3) 50 CONTINUE RETURN END SUBROUTINE DSCAL(N,DA,DX,INCX) C C SCALES A VECTOR BY A CONSTANT. C USES UNROLLED LOOPS FOR INCREMENT EQUAL TO ONE. C JACK DONGARRA, LINPACK, 3/11/78. C DOUBLE PRECISION DA,DX(1) INTEGER I,INCX,M,MP1,N,NINCX C IF(N.LE.0)RETURN IF(INCX.EQ.1)GO TO 20 C C CODE FOR INCREMENT NOT EQUAL TO 1 C NINCX = N*INCX DO 10 I = 1,NINCX,INCX DX(I) = DA*DX(I) 10 CONTINUE RETURN C C CODE FOR INCREMENT EQUAL TO 1 C C C CLEAN-UP LOOP C 20 M = MOD(N,5) IF( M .EQ. 0 ) GO TO 40 DO 30 I = 1,M DX(I) = DA*DX(I) 30 CONTINUE IF( N .LT. 5 ) RETURN 40 MP1 = M + 1 DO 50 I = MP1,N,5 DX(I) = DA*DX(I) DX(I + 1) = DA*DX(I + 1) DX(I + 2) = DA*DX(I + 2) DX(I + 3) = DA*DX(I + 3) DX(I + 4) = DA*DX(I + 4) 50 CONTINUE RETURN END DOUBLE PRECISION FUNCTION DDOT(N,DX,INCX,DY,INCY) C C FORMS THE DOT PRODUCT OF TWO VECTORS. C USES UNROLLED LOOPS FOR INCREMENTS EQUAL TO ONE. C JACK DONGARRA, LINPACK, 3/11/78. C DOUBLE PRECISION DX(1),DY(1),DTEMP INTEGER I,INCX,INCY,IX,IY,M,MP1,N C DDOT = 0.0D0 DTEMP = 0.0D0 IF(N.LE.0)RETURN IF(INCX.EQ.1.AND.INCY.EQ.1)GO TO 20 C C CODE FOR UNEQUAL INCREMENTS OR EQUAL INCREMENTS C NOT EQUAL TO 1 C IX = 1 IY = 1 IF(INCX.LT.0)IX = (-N+1)*INCX + 1 IF(INCY.LT.0)IY = (-N+1)*INCY + 1 DO 10 I = 1,N DTEMP = DTEMP + DX(IX)*DY(IY) IX = IX + INCX IY = IY + INCY 10 CONTINUE DDOT = DTEMP RETURN C C CODE FOR BOTH INCREMENTS EQUAL TO 1 C C C CLEAN-UP LOOP C 20 M = MOD(N,5) IF( M .EQ. 0 ) GO TO 40 DO 30 I = 1,M DTEMP = DTEMP + DX(I)*DY(I) 30 CONTINUE IF( N .LT. 5 ) GO TO 60 40 MP1 = M + 1 DO 50 I = MP1,N,5 DTEMP = DTEMP + DX(I)*DY(I) + DX(I + 1)*DY(I + 1) + * DX(I + 2)*DY(I + 2) + DX(I + 3)*DY(I + 3) + DX(I + 4)*DY(I + 4) 50 CONTINUE 60 DDOT = DTEMP RETURN END INTEGER FUNCTION IDAMAX(N,DX,INCX) C C FINDS THE INDEX OF ELEMENT HAVING MAX. ABSOLUTE VALUE. C JACK DONGARRA, LINPACK, 3/11/78. C DOUBLE PRECISION DX(1),DMAX INTEGER I,INCX,IX,N C IDAMAX = 0 IF( N .LT. 1 ) RETURN IDAMAX = 1 IF(N.EQ.1)RETURN IF(INCX.EQ.1)GO TO 20 C C CODE FOR INCREMENT NOT EQUAL TO 1 C IX = 1 DMAX = DABS(DX(1)) IX = IX + INCX DO 10 I = 2,N IF(DABS(DX(IX)).LE.DMAX) GO TO 5 IDAMAX = I DMAX = DABS(DX(IX)) 5 IX = IX + INCX 10 CONTINUE RETURN C C CODE FOR INCREMENT EQUAL TO 1 C 20 DMAX = DABS(DX(1)) DO 30 I = 2,N IF(DABS(DX(I)).LE.DMAX) GO TO 30 IDAMAX = I DMAX = DABS(DX(I)) 30 CONTINUE RETURN END TEST PROBLEM 1 *********** POLY OF DEGREE = 2 NO OF ELEMENTS = 20 JAC EVAL SCALED LOCAL ERROR IS 0.267D-02 ORDER RAISE WITH IPHASE =0 AT T= 0.202D-07 H= 0.360D-09 ORDER= 1 SCALED LOCAL ERROR IS 0.118D-01 AT T= 0.205D-07 H= 0.720D-09 ORDER= 2 JAC EVAL SCALED LOCAL ERROR IS 0.215D-02 AT T= 0.213D-07 H= 0.144D-08 ORDER= 1 JAC EVAL SCALED LOCAL ERROR IS 0.221D-04 AT T= 0.227D-07 H= 0.288D-08 ORDER= 1 JAC EVAL SCALED LOCAL ERROR IS 0.272D-08 AT T= 0.256D-07 H= 0.576D-08 ORDER= 1 JAC EVAL SCALED LOCAL ERROR IS 0.372D-09 AT T= 0.313D-07 H= 0.115D-07 ORDER= 1 JAC EVAL SCALED LOCAL ERROR IS 0.149D-08 AT T= 0.429D-07 H= 0.230D-07 ORDER= 1 JAC EVAL SCALED LOCAL ERROR IS 0.597D-08 AT T= 0.659D-07 H= 0.461D-07 ORDER= 1 JAC EVAL SCALED LOCAL ERROR IS 0.239D-07 AT T= 0.112D-06 H= 0.922D-07 ORDER= 1 JAC EVAL SCALED LOCAL ERROR IS 0.956D-07 AT T= 0.204D-06 H= 0.184D-06 ORDER= 1 MESH NUM SOL SOL ERROR 0.000D+00 0.200D-06 0.200D-06 0.535D-10 0.250D-01 0.195D-06 0.195D-06 0.522D-10 0.500D-01 0.190D-06 0.190D-06 0.509D-10 0.750D-01 0.185D-06 0.185D-06 0.495D-10 0.100D+00 0.180D-06 0.180D-06 0.482D-10 0.125D+00 0.175D-06 0.175D-06 0.469D-10 0.150D+00 0.170D-06 0.170D-06 0.455D-10 0.175D+00 0.165D-06 0.165D-06 0.442D-10 0.200D+00 0.160D-06 0.160D-06 0.428D-10 0.225D+00 0.155D-06 0.155D-06 0.415D-10 0.250D+00 0.150D-06 0.150D-06 0.402D-10 0.275D+00 0.145D-06 0.145D-06 0.388D-10 0.300D+00 0.140D-06 0.140D-06 0.375D-10 0.325D+00 0.135D-06 0.135D-06 0.361D-10 0.350D+00 0.130D-06 0.130D-06 0.348D-10 0.375D+00 0.125D-06 0.125D-06 0.335D-10 0.400D+00 0.120D-06 0.120D-06 0.321D-10 0.425D+00 0.115D-06 0.115D-06 0.308D-10 0.450D+00 0.110D-06 0.110D-06 0.295D-10 0.475D+00 0.105D-06 0.105D-06 0.281D-10 0.500D+00 0.100D-06 0.100D-06 0.268D-10 0.525D+00 0.950D-07 0.950D-07 0.254D-10 0.550D+00 0.900D-07 0.900D-07 0.241D-10 0.575D+00 0.850D-07 0.850D-07 0.228D-10 0.600D+00 0.800D-07 0.800D-07 0.214D-10 0.625D+00 0.750D-07 0.750D-07 0.201D-10 0.650D+00 0.700D-07 0.700D-07 0.187D-10 0.675D+00 0.650D-07 0.650D-07 0.174D-10 0.700D+00 0.600D-07 0.600D-07 0.161D-10 0.725D+00 0.550D-07 0.550D-07 0.147D-10 0.750D+00 0.500D-07 0.500D-07 0.134D-10 0.775D+00 0.450D-07 0.450D-07 0.120D-10 0.800D+00 0.400D-07 0.400D-07 0.107D-10 0.825D+00 0.350D-07 0.350D-07 0.937D-11 0.850D+00 0.300D-07 0.300D-07 0.803D-11 0.875D+00 0.250D-07 0.250D-07 0.669D-11 0.900D+00 0.200D-07 0.200D-07 0.535D-11 0.925D+00 0.150D-07 0.150D-07 0.402D-11 0.950D+00 0.100D-07 0.100D-07 0.268D-11 0.975D+00 0.500D-08 0.500D-08 0.134D-11 0.100D+01 0.339D-22 0.000D+00 0.339D-22 ENORM= 0.310D-10 GERR= 0.535D-10 MOVING BOUNDARY IS AT 0.1999D-06 WITH ERROR= -0.5355D-10 MESH NUM SOL SOL ERROR 0.000D+00 0.200D-05 0.200D-05 0.533D-10 0.250D-01 0.195D-05 0.195D-05 0.520D-10 0.500D-01 0.190D-05 0.190D-05 0.506D-10 0.750D-01 0.185D-05 0.185D-05 0.493D-10 0.100D+00 0.180D-05 0.180D-05 0.480D-10 0.125D+00 0.175D-05 0.175D-05 0.467D-10 0.150D+00 0.170D-05 0.170D-05 0.453D-10 0.175D+00 0.165D-05 0.165D-05 0.440D-10 0.200D+00 0.160D-05 0.160D-05 0.427D-10 0.225D+00 0.155D-05 0.155D-05 0.414D-10 0.250D+00 0.150D-05 0.150D-05 0.400D-10 0.275D+00 0.145D-05 0.145D-05 0.387D-10 0.300D+00 0.140D-05 0.140D-05 0.374D-10 0.325D+00 0.135D-05 0.135D-05 0.360D-10 0.350D+00 0.130D-05 0.130D-05 0.347D-10 0.375D+00 0.125D-05 0.125D-05 0.334D-10 0.400D+00 0.120D-05 0.120D-05 0.320D-10 0.425D+00 0.115D-05 0.115D-05 0.307D-10 0.450D+00 0.110D-05 0.110D-05 0.294D-10 0.475D+00 0.105D-05 0.105D-05 0.280D-10 0.500D+00 0.100D-05 0.100D-05 0.267D-10 0.525D+00 0.950D-06 0.950D-06 0.254D-10 0.550D+00 0.900D-06 0.900D-06 0.240D-10 0.575D+00 0.850D-06 0.850D-06 0.227D-10 0.600D+00 0.800D-06 0.800D-06 0.214D-10 0.625D+00 0.750D-06 0.750D-06 0.200D-10 0.650D+00 0.700D-06 0.700D-06 0.187D-10 0.675D+00 0.650D-06 0.650D-06 0.174D-10 0.700D+00 0.600D-06 0.600D-06 0.160D-10 0.725D+00 0.550D-06 0.550D-06 0.147D-10 0.750D+00 0.500D-06 0.500D-06 0.134D-10 0.775D+00 0.450D-06 0.450D-06 0.120D-10 0.800D+00 0.400D-06 0.400D-06 0.107D-10 0.825D+00 0.350D-06 0.350D-06 0.936D-11 0.850D+00 0.300D-06 0.300D-06 0.803D-11 0.875D+00 0.250D-06 0.250D-06 0.669D-11 0.900D+00 0.200D-06 0.200D-06 0.535D-11 0.925D+00 0.150D-06 0.150D-06 0.401D-11 0.950D+00 0.100D-06 0.100D-06 0.268D-11 0.975D+00 0.500D-07 0.500D-07 0.134D-11 0.100D+01 0.330D-21 0.000D+00 0.330D-21 ENORM= 0.309D-10 GERR= 0.533D-10 MOVING BOUNDARY IS AT 0.2000D-05 WITH ERROR= -0.5355D-10 MESH NUM SOL SOL ERROR 0.000D+00 0.200D-04 0.200D-04 0.388D-10 0.250D-01 0.195D-04 0.195D-04 0.382D-10 0.500D-01 0.190D-04 0.190D-04 0.375D-10 0.750D-01 0.185D-04 0.185D-04 0.369D-10 0.100D+00 0.180D-04 0.180D-04 0.362D-10 0.125D+00 0.175D-04 0.175D-04 0.355D-10 0.150D+00 0.170D-04 0.170D-04 0.348D-10 0.175D+00 0.165D-04 0.165D-04 0.341D-10 0.200D+00 0.160D-04 0.160D-04 0.334D-10 0.225D+00 0.155D-04 0.155D-04 0.326D-10 0.250D+00 0.150D-04 0.150D-04 0.318D-10 0.275D+00 0.145D-04 0.145D-04 0.310D-10 0.300D+00 0.140D-04 0.140D-04 0.302D-10 0.325D+00 0.135D-04 0.135D-04 0.294D-10 0.350D+00 0.130D-04 0.130D-04 0.286D-10 0.375D+00 0.125D-04 0.125D-04 0.277D-10 0.400D+00 0.120D-04 0.120D-04 0.268D-10 0.425D+00 0.115D-04 0.115D-04 0.259D-10 0.450D+00 0.110D-04 0.110D-04 0.250D-10 0.475D+00 0.105D-04 0.105D-04 0.240D-10 0.500D+00 0.100D-04 0.100D-04 0.231D-10 0.525D+00 0.950D-05 0.950D-05 0.221D-10 0.550D+00 0.900D-05 0.900D-05 0.211D-10 0.575D+00 0.850D-05 0.850D-05 0.201D-10 0.600D+00 0.800D-05 0.800D-05 0.191D-10 0.625D+00 0.750D-05 0.750D-05 0.180D-10 0.650D+00 0.700D-05 0.700D-05 0.169D-10 0.675D+00 0.650D-05 0.650D-05 0.158D-10 0.700D+00 0.600D-05 0.600D-05 0.147D-10 0.725D+00 0.550D-05 0.550D-05 0.136D-10 0.750D+00 0.500D-05 0.500D-05 0.125D-10 0.775D+00 0.450D-05 0.450D-05 0.113D-10 0.800D+00 0.400D-05 0.400D-05 0.101D-10 0.825D+00 0.350D-05 0.350D-05 0.892D-11 0.850D+00 0.300D-05 0.300D-05 0.770D-11 0.875D+00 0.250D-05 0.250D-05 0.646D-11 0.900D+00 0.200D-05 0.200D-05 0.521D-11 0.925D+00 0.150D-05 0.150D-05 0.393D-11 0.950D+00 0.100D-05 0.100D-05 0.264D-11 0.975D+00 0.500D-06 0.500D-06 0.133D-11 0.100D+01 0.301D-20 0.000D+00 0.301D-20 ENORM= 0.246D-10 GERR= 0.388D-10 MOVING BOUNDARY IS AT 0.2000D-04 WITH ERROR= -0.5354D-10 MESH NUM SOL SOL ERROR 0.000D+00 0.200D-03 0.200D-03 0.945D-09 0.250D-01 0.195D-03 0.195D-03 0.897D-09 0.500D-01 0.190D-03 0.190D-03 0.850D-09 0.750D-01 0.185D-03 0.185D-03 0.805D-09 0.100D+00 0.180D-03 0.180D-03 0.761D-09 0.125D+00 0.175D-03 0.175D-03 0.718D-09 0.150D+00 0.170D-03 0.170D-03 0.676D-09 0.175D+00 0.165D-03 0.165D-03 0.636D-09 0.200D+00 0.160D-03 0.160D-03 0.596D-09 0.225D+00 0.155D-03 0.155D-03 0.559D-09 0.250D+00 0.150D-03 0.150D-03 0.522D-09 0.275D+00 0.145D-03 0.145D-03 0.486D-09 0.300D+00 0.140D-03 0.140D-03 0.452D-09 0.325D+00 0.135D-03 0.135D-03 0.419D-09 0.350D+00 0.130D-03 0.130D-03 0.387D-09 0.375D+00 0.125D-03 0.125D-03 0.357D-09 0.400D+00 0.120D-03 0.120D-03 0.328D-09 0.425D+00 0.115D-03 0.115D-03 0.300D-09 0.450D+00 0.110D-03 0.110D-03 0.273D-09 0.475D+00 0.105D-03 0.105D-03 0.247D-09 0.500D+00 0.100D-03 0.100D-03 0.223D-09 0.525D+00 0.950D-04 0.950D-04 0.200D-09 0.550D+00 0.900D-04 0.900D-04 0.178D-09 0.575D+00 0.850D-04 0.850D-04 0.158D-09 0.600D+00 0.800D-04 0.800D-04 0.139D-09 0.625D+00 0.750D-04 0.750D-04 0.121D-09 0.650D+00 0.700D-04 0.700D-04 0.104D-09 0.675D+00 0.650D-04 0.650D-04 0.884D-10 0.700D+00 0.600D-04 0.600D-04 0.741D-10 0.725D+00 0.550D-04 0.550D-04 0.610D-10 0.750D+00 0.500D-04 0.500D-04 0.493D-10 0.775D+00 0.450D-04 0.450D-04 0.387D-10 0.800D+00 0.400D-04 0.400D-04 0.294D-10 0.825D+00 0.350D-04 0.350D-04 0.214D-10 0.850D+00 0.300D-04 0.300D-04 0.146D-10 0.875D+00 0.250D-04 0.250D-04 0.905D-11 0.900D+00 0.200D-04 0.200D-04 0.475D-11 0.925D+00 0.150D-04 0.150D-04 0.169D-11 0.950D+00 0.100D-04 0.100D-04 0.121D-12 0.975D+00 0.500D-05 0.500D-05 0.684D-12 0.100D+01 0.339D-19 0.000D+00 0.339D-19 ENORM= 0.419D-09 GERR= 0.945D-09 MOVING BOUNDARY IS AT 0.2000D-03 WITH ERROR= -0.5308D-10 MESH NUM SOL SOL ERROR 0.000D+00 0.200D-02 0.200D-02 0.666D-10 0.250D-01 0.195D-02 0.195D-02 0.660D-10 0.500D-01 0.190D-02 0.190D-02 0.654D-10 0.750D-01 0.185D-02 0.185D-02 0.646D-10 0.100D+00 0.180D-02 0.180D-02 0.638D-10 0.125D+00 0.175D-02 0.175D-02 0.629D-10 0.150D+00 0.170D-02 0.170D-02 0.619D-10 0.175D+00 0.165D-02 0.165D-02 0.609D-10 0.200D+00 0.160D-02 0.160D-02 0.598D-10 0.225D+00 0.155D-02 0.155D-02 0.586D-10 0.250D+00 0.150D-02 0.150D-02 0.574D-10 0.275D+00 0.145D-02 0.145D-02 0.561D-10 0.300D+00 0.140D-02 0.140D-02 0.547D-10 0.325D+00 0.135D-02 0.135D-02 0.533D-10 0.350D+00 0.130D-02 0.130D-02 0.518D-10 0.375D+00 0.125D-02 0.125D-02 0.502D-10 0.400D+00 0.120D-02 0.120D-02 0.486D-10 0.425D+00 0.115D-02 0.115D-02 0.470D-10 0.450D+00 0.110D-02 0.110D-02 0.453D-10 0.475D+00 0.105D-02 0.105D-02 0.436D-10 0.500D+00 0.100D-02 0.100D-02 0.418D-10 0.525D+00 0.950D-03 0.950D-03 0.400D-10 0.550D+00 0.900D-03 0.900D-03 0.381D-10 0.575D+00 0.850D-03 0.850D-03 0.362D-10 0.600D+00 0.800D-03 0.800D-03 0.342D-10 0.625D+00 0.750D-03 0.750D-03 0.323D-10 0.650D+00 0.700D-03 0.700D-03 0.303D-10 0.675D+00 0.650D-03 0.650D-03 0.282D-10 0.700D+00 0.600D-03 0.600D-03 0.261D-10 0.725D+00 0.550D-03 0.550D-03 0.241D-10 0.750D+00 0.500D-03 0.500D-03 0.219D-10 0.775D+00 0.450D-03 0.450D-03 0.198D-10 0.800D+00 0.400D-03 0.400D-03 0.177D-10 0.825D+00 0.350D-03 0.350D-03 0.155D-10 0.850D+00 0.300D-03 0.300D-03 0.133D-10 0.875D+00 0.250D-03 0.250D-03 0.111D-10 0.900D+00 0.200D-03 0.200D-03 0.889D-11 0.925D+00 0.150D-03 0.150D-03 0.668D-11 0.950D+00 0.100D-03 0.100D-03 0.446D-11 0.975D+00 0.500D-04 0.500D-04 0.223D-11 0.100D+01 0.344D-18 0.000D+00 0.344D-18 ENORM= 0.438D-10 GERR= 0.666D-10 MOVING BOUNDARY IS AT 0.2000D-02 WITH ERROR= -0.8957D-10 MESH NUM SOL SOL ERROR 0.000D+00 0.202D-01 0.202D-01 0.192D-08 0.250D-01 0.197D-01 0.197D-01 0.187D-08 0.500D-01 0.192D-01 0.192D-01 0.182D-08 0.750D-01 0.187D-01 0.187D-01 0.177D-08 0.100D+00 0.182D-01 0.182D-01 0.172D-08 0.125D+00 0.177D-01 0.177D-01 0.168D-08 0.150D+00 0.171D-01 0.171D-01 0.163D-08 0.175D+00 0.166D-01 0.166D-01 0.158D-08 0.200D+00 0.161D-01 0.161D-01 0.153D-08 0.225D+00 0.156D-01 0.156D-01 0.149D-08 0.250D+00 0.151D-01 0.151D-01 0.144D-08 0.275D+00 0.146D-01 0.146D-01 0.139D-08 0.300D+00 0.141D-01 0.141D-01 0.134D-08 0.325D+00 0.136D-01 0.136D-01 0.129D-08 0.350D+00 0.131D-01 0.131D-01 0.125D-08 0.375D+00 0.126D-01 0.126D-01 0.120D-08 0.400D+00 0.121D-01 0.121D-01 0.115D-08 0.425D+00 0.116D-01 0.116D-01 0.110D-08 0.450D+00 0.111D-01 0.111D-01 0.106D-08 0.475D+00 0.106D-01 0.106D-01 0.101D-08 0.500D+00 0.101D-01 0.101D-01 0.961D-09 0.525D+00 0.955D-02 0.955D-02 0.913D-09 0.550D+00 0.904D-02 0.904D-02 0.865D-09 0.575D+00 0.854D-02 0.854D-02 0.817D-09 0.600D+00 0.803D-02 0.803D-02 0.769D-09 0.625D+00 0.753D-02 0.753D-02 0.721D-09 0.650D+00 0.702D-02 0.702D-02 0.673D-09 0.675D+00 0.652D-02 0.652D-02 0.625D-09 0.700D+00 0.602D-02 0.602D-02 0.577D-09 0.725D+00 0.552D-02 0.552D-02 0.529D-09 0.750D+00 0.501D-02 0.501D-02 0.481D-09 0.775D+00 0.451D-02 0.451D-02 0.433D-09 0.800D+00 0.401D-02 0.401D-02 0.385D-09 0.825D+00 0.351D-02 0.351D-02 0.337D-09 0.850D+00 0.300D-02 0.300D-02 0.289D-09 0.875D+00 0.250D-02 0.250D-02 0.241D-09 0.900D+00 0.200D-02 0.200D-02 0.192D-09 0.925D+00 0.150D-02 0.150D-02 0.144D-09 0.950D+00 0.100D-02 0.100D-02 0.962D-10 0.975D+00 0.500D-03 0.500D-03 0.481D-10 0.100D+01 0.386D-17 0.000D+00 0.386D-17 ENORM= 0.109D-08 GERR= 0.192D-08 MOVING BOUNDARY IS AT 0.2000D-01 WITH ERROR= -0.1994D-08 MESH NUM SOL SOL ERROR 0.000D+00 0.221D+00 0.221D+00 0.274D-08 0.250D-01 0.215D+00 0.215D+00 0.262D-08 0.500D-01 0.209D+00 0.209D+00 0.257D-08 0.750D-01 0.203D+00 0.203D+00 0.246D-08 0.100D+00 0.197D+00 0.197D+00 0.241D-08 0.125D+00 0.191D+00 0.191D+00 0.230D-08 0.150D+00 0.185D+00 0.185D+00 0.225D-08 0.175D+00 0.179D+00 0.179D+00 0.215D-08 0.200D+00 0.174D+00 0.174D+00 0.209D-08 0.225D+00 0.168D+00 0.168D+00 0.199D-08 0.250D+00 0.162D+00 0.162D+00 0.193D-08 0.275D+00 0.156D+00 0.156D+00 0.184D-08 0.300D+00 0.150D+00 0.150D+00 0.178D-08 0.325D+00 0.145D+00 0.145D+00 0.170D-08 0.350D+00 0.139D+00 0.139D+00 0.164D-08 0.375D+00 0.133D+00 0.133D+00 0.156D-08 0.400D+00 0.127D+00 0.127D+00 0.149D-08 0.425D+00 0.122D+00 0.122D+00 0.142D-08 0.450D+00 0.116D+00 0.116D+00 0.135D-08 0.475D+00 0.111D+00 0.111D+00 0.128D-08 0.500D+00 0.105D+00 0.105D+00 0.121D-08 0.525D+00 0.997D-01 0.997D-01 0.115D-08 0.550D+00 0.942D-01 0.942D-01 0.108D-08 0.575D+00 0.887D-01 0.887D-01 0.102D-08 0.600D+00 0.833D-01 0.833D-01 0.952D-09 0.625D+00 0.779D-01 0.779D-01 0.895D-09 0.650D+00 0.725D-01 0.725D-01 0.826D-09 0.675D+00 0.672D-01 0.672D-01 0.773D-09 0.700D+00 0.618D-01 0.618D-01 0.702D-09 0.725D+00 0.565D-01 0.565D-01 0.654D-09 0.750D+00 0.513D-01 0.513D-01 0.581D-09 0.775D+00 0.460D-01 0.460D-01 0.537D-09 0.800D+00 0.408D-01 0.408D-01 0.463D-09 0.825D+00 0.356D-01 0.356D-01 0.422D-09 0.850D+00 0.305D-01 0.305D-01 0.346D-09 0.875D+00 0.253D-01 0.253D-01 0.308D-09 0.900D+00 0.202D-01 0.202D-01 0.230D-09 0.925D+00 0.151D-01 0.151D-01 0.195D-09 0.950D+00 0.101D-01 0.101D-01 0.115D-09 0.975D+00 0.501D-02 0.501D-02 0.825D-10 0.100D+01 0.343D-16 0.000D+00 0.343D-16 ENORM= 0.533D-08 GERR= 0.274D-08 MOVING BOUNDARY IS AT 0.2000D+00 WITH ERROR= -0.3416D-08 MESH NUM SOL SOL ERROR 0.000D+00 0.639D+01 0.639D+01 0.190D-05 0.250D-01 0.603D+01 0.603D+01 0.205D-07 0.500D-01 0.569D+01 0.569D+01 0.162D-05 0.750D-01 0.536D+01 0.536D+01 0.907D-07 0.100D+00 0.505D+01 0.505D+01 0.138D-05 0.125D+00 0.475D+01 0.475D+01 0.149D-06 0.150D+00 0.447D+01 0.447D+01 0.117D-05 0.175D+00 0.421D+01 0.421D+01 0.196D-06 0.200D+00 0.395D+01 0.395D+01 0.987D-06 0.225D+00 0.371D+01 0.371D+01 0.234D-06 0.250D+00 0.348D+01 0.348D+01 0.830D-06 0.275D+00 0.326D+01 0.326D+01 0.263D-06 0.300D+00 0.306D+01 0.306D+01 0.695D-06 0.325D+00 0.286D+01 0.286D+01 0.285D-06 0.350D+00 0.267D+01 0.267D+01 0.578D-06 0.375D+00 0.249D+01 0.249D+01 0.300D-06 0.400D+00 0.232D+01 0.232D+01 0.477D-06 0.425D+00 0.216D+01 0.216D+01 0.310D-06 0.450D+00 0.200D+01 0.200D+01 0.390D-06 0.475D+00 0.186D+01 0.186D+01 0.316D-06 0.500D+00 0.172D+01 0.172D+01 0.316D-06 0.525D+00 0.159D+01 0.159D+01 0.318D-06 0.550D+00 0.146D+01 0.146D+01 0.253D-06 0.575D+00 0.134D+01 0.134D+01 0.317D-06 0.600D+00 0.123D+01 0.123D+01 0.199D-06 0.625D+00 0.112D+01 0.112D+01 0.313D-06 0.650D+00 0.101D+01 0.101D+01 0.153D-06 0.675D+00 0.916D+00 0.916D+00 0.308D-06 0.700D+00 0.822D+00 0.822D+00 0.115D-06 0.725D+00 0.733D+00 0.733D+00 0.302D-06 0.750D+00 0.649D+00 0.649D+00 0.835D-07 0.775D+00 0.568D+00 0.568D+00 0.295D-06 0.800D+00 0.492D+00 0.492D+00 0.577D-07 0.825D+00 0.419D+00 0.419D+00 0.287D-06 0.850D+00 0.350D+00 0.350D+00 0.370D-07 0.875D+00 0.284D+00 0.284D+00 0.279D-06 0.900D+00 0.221D+00 0.221D+00 0.208D-07 0.925D+00 0.162D+00 0.162D+00 0.272D-06 0.950D+00 0.105D+00 0.105D+00 0.862D-08 0.975D+00 0.513D-01 0.513D-01 0.264D-06 0.100D+01 0.333D-15 0.000D+00 0.333D-15 ENORM= 0.284D-05 GERR= 0.190D-05 MOVING BOUNDARY IS AT 0.2000D+01 WITH ERROR= 0.1550D-06 NSTEPS = 81 NRESID = 188 JAC = 35 CPU= 0.000D+00 TEST PROBLEM 1 *********** POLY OF DEGREE = 10 NO OF ELEMENTS = 1 JAC EVAL SCALED LOCAL ERROR IS 0.325D+04 ERROR TEST FAILED JAC EVAL SCALED LOCAL ERROR IS 0.325D+03 ERROR TEST FAILED JAC EVAL SCALED LOCAL ERROR IS 0.239D+02 ERROR TEST FAILED JAC EVAL SCALED LOCAL ERROR IS 0.156D+01 ERROR TEST FAILED JAC EVAL SCALED LOCAL ERROR IS 0.988D-01 AT T= 0.391D-06 H= 0.781D-06 ORDER= 1 JAC EVAL SCALED LOCAL ERROR IS 0.246D-04 AT T= 0.117D-05 H= 0.156D-05 ORDER= 1 JAC EVAL SCALED LOCAL ERROR IS 0.985D-04 AT T= 0.273D-05 H= 0.313D-05 ORDER= 1 JAC EVAL SCALED LOCAL ERROR IS 0.395D-03 AT T= 0.586D-05 H= 0.625D-05 ORDER= 1 JAC EVAL SCALED LOCAL ERROR IS 0.159D-02 AT T= 0.121D-04 H= 0.125D-04 ORDER= 1 JAC EVAL SCALED LOCAL ERROR IS 0.641D-02 AT T= 0.246D-04 H= 0.250D-04 ORDER= 1 JAC EVAL SCALED LOCAL ERROR IS 0.261D-01 AT T= 0.496D-04 H= 0.500D-04 ORDER= 1 JAC EVAL SCALED LOCAL ERROR IS 0.106D+00 AT T= 0.996D-04 H= 0.100D-03 ORDER= 1 JAC EVAL SCALED LOCAL ERROR IS 0.431D+00 AT T= 0.200D-03 H= 0.100D-03 ORDER= 1 SCALED LOCAL ERROR IS 0.325D+00 AT T= 0.300D-03 H= 0.100D-03 ORDER= 1 SCALED LOCAL ERROR IS 0.326D+00 ORDER RAISE CONSIDERED AT T= 0.400D-03 H= 0.200D-03 ORDER= 1 SCALED LOCAL ERROR IS 0.283D+00 AT T= 0.600D-03 H= 0.200D-03 ORDER= 2 SCALED LOCAL ERROR IS 0.163D+00 AT T= 0.800D-03 H= 0.200D-03 ORDER= 2 SCALED LOCAL ERROR IS 0.370D-01 AT T= 0.100D-02 H= 0.400D-03 ORDER= 2 JAC EVAL SCALED LOCAL ERROR IS 0.808D-01 AT T= 0.140D-02 H= 0.400D-03 ORDER= 2 SCALED LOCAL ERROR IS 0.587D-02 AT T= 0.180D-02 H= 0.800D-03 ORDER= 2 JAC EVAL SCALED LOCAL ERROR IS 0.313D-01 AT T= 0.260D-02 H= 0.160D-02 ORDER= 2 JAC EVAL SCALED LOCAL ERROR IS 0.137D+00 AT T= 0.420D-02 H= 0.160D-02 ORDER= 2 SCALED LOCAL ERROR IS 0.759D-01 AT T= 0.580D-02 H= 0.160D-02 ORDER= 2 SCALED LOCAL ERROR IS 0.816D-01 AT T= 0.740D-02 H= 0.160D-02 ORDER= 2 SCALED LOCAL ERROR IS 0.832D-01 ORDER RAISE CONSIDERED AT T= 0.900D-02 H= 0.320D-02 ORDER= 2 SCALED LOCAL ERROR IS 0.111D+00 AT T= 0.122D-01 H= 0.320D-02 ORDER= 3 SCALED LOCAL ERROR IS 0.822D-01 AT T= 0.154D-01 H= 0.320D-02 ORDER= 3 SCALED LOCAL ERROR IS 0.223D-01 AT T= 0.186D-01 H= 0.640D-02 ORDER= 3 JAC EVAL SCALED LOCAL ERROR IS 0.237D+00 AT T= 0.250D-01 H= 0.640D-02 ORDER= 3 SCALED LOCAL ERROR IS 0.472D-01 AT T= 0.314D-01 H= 0.640D-02 ORDER= 3 SCALED LOCAL ERROR IS 0.642D-01 AT T= 0.378D-01 H= 0.640D-02 ORDER= 3 SCALED LOCAL ERROR IS 0.320D-01 AT T= 0.442D-01 H= 0.640D-02 ORDER= 3 SCALED LOCAL ERROR IS 0.247D-01 AT T= 0.506D-01 H= 0.128D-01 ORDER= 3 JAC EVAL SCALED LOCAL ERROR IS 0.501D+00 AT T= 0.634D-01 H= 0.115D-01 ORDER= 3 SCALED LOCAL ERROR IS 0.154D+00 AT T= 0.749D-01 H= 0.115D-01 ORDER= 3 SCALED LOCAL ERROR IS 0.316D+00 AT T= 0.864D-01 H= 0.115D-01 ORDER= 3 SCALED LOCAL ERROR IS 0.293D+00 AT T= 0.980D-01 H= 0.115D-01 ORDER= 3 SCALED LOCAL ERROR IS 0.284D+00 AT T= 0.109D+00 H= 0.115D-01 ORDER= 3 MESH NUM SOL SOL ERROR 0.000D+00 0.246D+01 0.246D+01 0.105D-06 0.245D-01 0.246D+01 0.246D+01 0.105D-06 0.955D-01 0.244D+01 0.244D+01 0.761D-07 0.206D+00 0.236D+01 0.236D+01 0.755D-07 0.345D+00 0.218D+01 0.218D+01 0.116D-06 0.500D+00 0.192D+01 0.192D+01 0.175D-07 0.655D+00 0.160D+01 0.160D+01 0.117D-06 0.794D+00 0.131D+01 0.131D+01 0.588D-08 0.905D+00 0.109D+01 0.109D+01 0.670D-07 0.976D+00 0.950D+00 0.950D+00 0.280D-07 0.100D+01 0.905D+00 0.905D+00 0.203D-07 ENORM= 0.106D-07 GERR= 0.117D-06 SCALED LOCAL ERROR IS 0.279D+00 ORDER RAISE CONSIDERED AT T= 0.121D+00 H= 0.230D-01 ORDER= 3 SCALED LOCAL ERROR IS 0.287D+00 AT T= 0.144D+00 H= 0.230D-01 ORDER= 4 SCALED LOCAL ERROR IS 0.351D+00 AT T= 0.167D+00 H= 0.230D-01 ORDER= 4 SCALED LOCAL ERROR IS 0.177D+00 AT T= 0.190D+00 H= 0.230D-01 ORDER= 4 SCALED LOCAL ERROR IS 0.189D+00 AT T= 0.213D+00 H= 0.230D-01 ORDER= 4 MESH NUM SOL SOL ERROR 0.000D+00 0.223D+01 0.223D+01 0.111D-06 0.245D-01 0.222D+01 0.222D+01 0.111D-06 0.955D-01 0.221D+01 0.221D+01 0.847D-07 0.206D+00 0.213D+01 0.213D+01 0.836D-07 0.345D+00 0.198D+01 0.198D+01 0.119D-06 0.500D+00 0.173D+01 0.173D+01 0.281D-07 0.655D+00 0.145D+01 0.145D+01 0.116D-06 0.794D+00 0.118D+01 0.118D+01 0.287D-08 0.905D+00 0.982D+00 0.982D+00 0.674D-07 0.976D+00 0.859D+00 0.859D+00 0.313D-07 0.100D+01 0.819D+00 0.819D+00 0.240D-07 ENORM= 0.116D-07 GERR= 0.119D-06 SCALED LOCAL ERROR IS 0.108D+00 AT T= 0.236D+00 H= 0.230D-01 ORDER= 4 SCALED LOCAL ERROR IS 0.403D-01 AT T= 0.259D+00 H= 0.230D-01 ORDER= 4 SCALED LOCAL ERROR IS 0.410D-01 ORDER RAISE CONSIDERED AT T= 0.282D+00 H= 0.461D-01 ORDER= 4 JAC EVAL SCALED LOCAL ERROR IS 0.168D+01 ERROR TEST FAILED SCALED LOCAL ERROR IS 0.248D+00 AT T= 0.313D+00 H= 0.311D-01 ORDER= 5 MESH NUM SOL SOL ERROR 0.000D+00 0.201D+01 0.201D+01 0.104D-06 0.245D-01 0.201D+01 0.201D+01 0.104D-06 0.955D-01 0.200D+01 0.200D+01 0.802D-07 0.206D+00 0.193D+01 0.193D+01 0.790D-07 0.345D+00 0.179D+01 0.179D+01 0.111D-06 0.500D+00 0.157D+01 0.157D+01 0.281D-07 0.655D+00 0.131D+01 0.131D+01 0.107D-06 0.794D+00 0.107D+01 0.107D+01 0.443D-08 0.905D+00 0.889D+00 0.889D+00 0.625D-07 0.976D+00 0.778D+00 0.778D+00 0.296D-07 0.100D+01 0.741D+00 0.741D+00 0.229D-07 ENORM= 0.116D-07 GERR= 0.111D-06 SCALED LOCAL ERROR IS 0.478D-01 AT T= 0.344D+00 H= 0.311D-01 ORDER= 5 SCALED LOCAL ERROR IS 0.706D-02 AT T= 0.375D+00 H= 0.621D-01 ORDER= 5 SCALED LOCAL ERROR IS 0.170D+01 ERROR TEST FAILED SCALED LOCAL ERROR IS 0.248D+00 AT T= 0.417D+00 H= 0.412D-01 ORDER= 5 MESH NUM SOL SOL ERROR 0.000D+00 0.182D+01 0.182D+01 0.914D-07 0.245D-01 0.182D+01 0.182D+01 0.913D-07 0.955D-01 0.181D+01 0.181D+01 0.697D-07 0.206D+00 0.175D+01 0.175D+01 0.687D-07 0.345D+00 0.162D+01 0.162D+01 0.978D-07 0.500D+00 0.142D+01 0.142D+01 0.232D-07 0.655D+00 0.119D+01 0.119D+01 0.953D-07 0.794D+00 0.970D+00 0.970D+00 0.245D-08 0.905D+00 0.804D+00 0.804D+00 0.553D-07 0.976D+00 0.704D+00 0.704D+00 0.257D-07 0.100D+01 0.670D+00 0.670D+00 0.197D-07 ENORM= 0.109D-07 GERR= 0.978D-07 SCALED LOCAL ERROR IS 0.856D-02 AT T= 0.458D+00 H= 0.412D-01 ORDER= 5 SCALED LOCAL ERROR IS 0.816D-01 AT T= 0.499D+00 H= 0.412D-01 ORDER= 5 SCALED LOCAL ERROR IS 0.167D-01 AT T= 0.540D+00 H= 0.412D-01 ORDER= 5 MESH NUM SOL SOL ERROR 0.000D+00 0.165D+01 0.165D+01 0.847D-07 0.245D-01 0.165D+01 0.165D+01 0.846D-07 0.955D-01 0.163D+01 0.163D+01 0.650D-07 0.206D+00 0.158D+01 0.158D+01 0.641D-07 0.345D+00 0.146D+01 0.146D+01 0.902D-07 0.500D+00 0.128D+01 0.128D+01 0.225D-07 0.655D+00 0.107D+01 0.107D+01 0.875D-07 0.794D+00 0.878D+00 0.878D+00 0.327D-08 0.905D+00 0.728D+00 0.728D+00 0.509D-07 0.976D+00 0.637D+00 0.637D+00 0.240D-07 0.100D+01 0.607D+00 0.607D+00 0.185D-07 ENORM= 0.107D-07 GERR= 0.902D-07 SCALED LOCAL ERROR IS 0.294D-01 AT T= 0.582D+00 H= 0.412D-01 ORDER= 5 SCALED LOCAL ERROR IS 0.529D-01 AT T= 0.623D+00 H= 0.412D-01 ORDER= 5 MESH NUM SOL SOL ERROR 0.000D+00 0.149D+01 0.149D+01 0.755D-07 0.245D-01 0.149D+01 0.149D+01 0.754D-07 0.955D-01 0.148D+01 0.148D+01 0.577D-07 0.206D+00 0.143D+01 0.143D+01 0.569D-07 0.345D+00 0.132D+01 0.132D+01 0.807D-07 0.500D+00 0.116D+01 0.116D+01 0.195D-07 0.655D+00 0.972D+00 0.972D+00 0.785D-07 0.794D+00 0.794D+00 0.794D+00 0.237D-08 0.905D+00 0.658D+00 0.658D+00 0.456D-07 0.976D+00 0.576D+00 0.576D+00 0.213D-07 0.100D+01 0.549D+00 0.549D+00 0.164D-07 ENORM= 0.102D-07 GERR= 0.807D-07 SCALED LOCAL ERROR IS 0.591D-01 AT T= 0.664D+00 H= 0.412D-01 ORDER= 5 SCALED LOCAL ERROR IS 0.455D-01 AT T= 0.705D+00 H= 0.412D-01 ORDER= 5 MESH NUM SOL SOL ERROR 0.000D+00 0.135D+01 0.135D+01 0.658D-07 0.245D-01 0.135D+01 0.135D+01 0.657D-07 0.955D-01 0.134D+01 0.134D+01 0.497D-07 0.206D+00 0.129D+01 0.129D+01 0.491D-07 0.345D+00 0.120D+01 0.120D+01 0.707D-07 0.500D+00 0.105D+01 0.105D+01 0.157D-07 0.655D+00 0.880D+00 0.880D+00 0.694D-07 0.794D+00 0.719D+00 0.719D+00 0.798D-09 0.905D+00 0.596D+00 0.596D+00 0.401D-07 0.976D+00 0.521D+00 0.521D+00 0.183D-07 0.100D+01 0.497D+00 0.497D+00 0.139D-07 ENORM= 0.947D-08 GERR= 0.707D-07 SCALED LOCAL ERROR IS 0.338D-01 AT T= 0.746D+00 H= 0.412D-01 ORDER= 5 SCALED LOCAL ERROR IS 0.372D-01 AT T= 0.788D+00 H= 0.412D-01 ORDER= 5 SCALED LOCAL ERROR IS 0.473D-01 AT T= 0.829D+00 H= 0.412D-01 ORDER= 5 MESH NUM SOL SOL ERROR 0.000D+00 0.122D+01 0.122D+01 0.560D-07 0.245D-01 0.122D+01 0.122D+01 0.559D-07 0.955D-01 0.121D+01 0.121D+01 0.415D-07 0.206D+00 0.117D+01 0.117D+01 0.410D-07 0.345D+00 0.108D+01 0.108D+01 0.608D-07 0.500D+00 0.951D+00 0.951D+00 0.114D-07 0.655D+00 0.796D+00 0.796D+00 0.605D-07 0.794D+00 0.650D+00 0.650D+00 0.117D-08 0.905D+00 0.539D+00 0.539D+00 0.347D-07 0.976D+00 0.472D+00 0.472D+00 0.152D-07 0.100D+01 0.449D+00 0.449D+00 0.112D-07 ENORM= 0.859D-08 GERR= 0.608D-07 SCALED LOCAL ERROR IS 0.482D-01 AT T= 0.870D+00 H= 0.412D-01 ORDER= 5 SCALED LOCAL ERROR IS 0.378D-01 AT T= 0.911D+00 H= 0.412D-01 ORDER= 5 MESH NUM SOL SOL ERROR 0.000D+00 0.111D+01 0.111D+01 0.445D-07 0.245D-01 0.110D+01 0.110D+01 0.445D-07 0.955D-01 0.110D+01 0.110D+01 0.314D-07 0.206D+00 0.106D+01 0.106D+01 0.313D-07 0.345D+00 0.981D+00 0.981D+00 0.497D-07 0.500D+00 0.861D+00 0.861D+00 0.559D-08 0.655D+00 0.720D+00 0.720D+00 0.507D-07 0.794D+00 0.588D+00 0.588D+00 0.431D-08 0.905D+00 0.488D+00 0.488D+00 0.287D-07 0.976D+00 0.427D+00 0.427D+00 0.114D-07 0.100D+01 0.407D+00 0.407D+00 0.794D-08 ENORM= 0.739D-08 GERR= 0.507D-07 SCALED LOCAL ERROR IS 0.295D-01 AT T= 0.953D+00 H= 0.412D-01 ORDER= 5 SCALED LOCAL ERROR IS 0.348D-01 AT T= 0.994D+00 H= 0.412D-01 ORDER= 5 SCALED LOCAL ERROR IS 0.473D-01 AT T= 0.104D+01 H= 0.412D-01 ORDER= 5 MESH NUM SOL SOL ERROR 0.000D+00 0.100D+01 0.100D+01 0.342D-07 0.245D-01 0.999D+00 0.999D+00 0.342D-07 0.955D-01 0.991D+00 0.991D+00 0.224D-07 0.206D+00 0.958D+00 0.958D+00 0.222D-07 0.345D+00 0.887D+00 0.887D+00 0.393D-07 0.500D+00 0.779D+00 0.779D+00 0.187D-09 0.655D+00 0.652D+00 0.652D+00 0.418D-07 0.794D+00 0.532D+00 0.532D+00 0.723D-08 0.905D+00 0.441D+00 0.441D+00 0.232D-07 0.976D+00 0.386D+00 0.386D+00 0.785D-08 0.100D+01 0.368D+00 0.368D+00 0.486D-08 ENORM= 0.621D-08 GERR= 0.418D-07 NSTEPS = 61 NRESID = 130 JAC = 19 CPU= 0.000D+00 TEST PROBLEM 3 *********** POLY OF DEGREE = 6 NO OF ELEMENTS = 2 JAC EVAL SCALED LOCAL ERROR IS 0.411D+01 ERROR TEST FAILED JAC EVAL SCALED LOCAL ERROR IS 0.616D+00 AT T= 0.314D-04 H= 0.283D-04 ORDER= 1 SCALED LOCAL ERROR IS 0.261D-03 AT T= 0.597D-04 H= 0.565D-04 ORDER= 1 JAC EVAL SCALED LOCAL ERROR IS 0.192D-03 AT T= 0.116D-03 H= 0.113D-03 ORDER= 1 JAC EVAL SCALED LOCAL ERROR IS 0.701D-03 AT T= 0.229D-03 H= 0.226D-03 ORDER= 1 JAC EVAL SCALED LOCAL ERROR IS 0.266D-02 AT T= 0.455D-03 H= 0.452D-03 ORDER= 1 JAC EVAL SCALED LOCAL ERROR IS 0.107D-01 AT T= 0.908D-03 H= 0.904D-03 ORDER= 1 JAC EVAL SCALED LOCAL ERROR IS 0.423D-01 AT T= 0.181D-02 H= 0.181D-02 ORDER= 1 JAC EVAL SCALED LOCAL ERROR IS 0.167D+00 AT T= 0.362D-02 H= 0.181D-02 ORDER= 1 SCALED LOCAL ERROR IS 0.132D+00 AT T= 0.543D-02 H= 0.181D-02 ORDER= 1 SCALED LOCAL ERROR IS 0.132D+00 ORDER RAISE CONSIDERED AT T= 0.724D-02 H= 0.362D-02 ORDER= 1 SCALED LOCAL ERROR IS 0.965D-01 AT T= 0.109D-01 H= 0.362D-02 ORDER= 2 SCALED LOCAL ERROR IS 0.584D-01 AT T= 0.145D-01 H= 0.723D-02 ORDER= 2 JAC EVAL SCALED LOCAL ERROR IS 0.853D-01 AT T= 0.217D-01 H= 0.723D-02 ORDER= 2 SCALED LOCAL ERROR IS 0.216D-01 AT T= 0.289D-01 H= 0.145D-01 ORDER= 2 JAC EVAL SCALED LOCAL ERROR IS 0.160D+00 AT T= 0.434D-01 H= 0.145D-01 ORDER= 2 SCALED LOCAL ERROR IS 0.136D+00 AT T= 0.579D-01 H= 0.145D-01 ORDER= 2 SCALED LOCAL ERROR IS 0.148D+00 AT T= 0.724D-01 H= 0.145D-01 ORDER= 2 SCALED LOCAL ERROR IS 0.146D+00 ORDER RAISE CONSIDERED AT T= 0.868D-01 H= 0.289D-01 ORDER= 2 SCALED LOCAL ERROR IS 0.122D+00 AT T= 0.116D+00 H= 0.289D-01 ORDER= 3 MESH NUM SOL SOL ERROR -0.100D+01 -0.698D-07 -0.139D-15 0.698D-07 -0.933D+00 0.668D-02 0.668D-02 0.396D-06 -0.750D+00 0.247D-01 0.247D-01 0.144D-05 -0.500D+00 0.488D-01 0.488D-01 0.236D-05 -0.250D+00 0.723D-01 0.723D-01 0.279D-05 -0.670D-01 0.892D-01 0.892D-01 0.285D-05 0.000D+00 0.953D-01 0.953D-01 0.282D-05 0.670D-01 0.154D+00 0.154D+00 0.310D-05 0.250D+00 0.300D+00 0.300D+00 0.126D-05 0.500D+00 0.470D+00 0.470D+00 0.733D-06 0.750D+00 0.615D+00 0.615D+00 0.105D-05 0.933D+00 0.710D+00 0.710D+00 0.186D-05 0.100D+01 0.742D+00 0.742D+00 0.153D-05 ENORM= 0.170D-05 GERR= 0.310D-05 INTERC ROUTINE CALLED WITH ITYPE = 2 AND INTERP. POINTS EQUAL TO BREAK-POINTS I.E. COMPONENT NO (=I1) WITH VALUE (=R1) IS CLOSE TO BREAK POINT(=I2) WITH VALUE (=R2). IN ABOVE MESSAGE I1 = 7 I2 = 2 IN ABOVE, R1 = 0.0000000000000D+00 R2 = 0.0000000000000D+0 X = -0.100D+01 TRUE = 0.100D+00 CALC= 0.100D+00 ERR= 0.730D-05 X = -0.933D+00 TRUE = 0.993D-01 CALC= 0.993D-01 ERR= 0.661D-05 X = -0.750D+00 TRUE = 0.976D-01 CALC= 0.976D-01 ERR= 0.481D-05 X = -0.500D+00 TRUE = 0.952D-01 CALC= 0.952D-01 ERR= 0.264D-05 X = -0.250D+00 TRUE = 0.930D-01 CALC= 0.930D-01 ERR= 0.856D-06 X = -0.670D-01 TRUE = 0.915D-01 CALC= 0.915D-01 ERR= 0.216D-06 X = 0.000D+00 TRUE = 0.500D+00 CALC= 0.500D+00 ERR= 0.198D-04 X = 0.670D-01 TRUE = 0.857D+00 CALC= 0.857D+00 ERR= 0.221D-04 X = 0.250D+00 TRUE = 0.741D+00 CALC= 0.741D+00 ERR= 0.342D-04 X = 0.500D+00 TRUE = 0.625D+00 CALC= 0.625D+00 ERR= 0.161D-04 X = 0.750D+00 TRUE = 0.541D+00 CALC= 0.541D+00 ERR= 0.197D-04 X = 0.933D+00 TRUE = 0.492D+00 CALC= 0.492D+00 ERR= 0.141D-04 X = 0.100D+01 TRUE = 0.476D+00 CALC= 0.476D+00 ERR= 0.164D-04 SCALED LOCAL ERROR IS 0.658D-01 AT T= 0.145D+00 H= 0.289D-01 ORDER= 3 SCALED LOCAL ERROR IS 0.760D-01 AT T= 0.174D+00 H= 0.289D-01 ORDER= 3 SCALED LOCAL ERROR IS 0.672D-01 AT T= 0.203D+00 H= 0.289D-01 ORDER= 3 MESH NUM SOL SOL ERROR -0.100D+01 0.953D-01 0.953D-01 0.129D-06 -0.933D+00 0.101D+00 0.101D+00 0.547D-07 -0.750D+00 0.118D+00 0.118D+00 0.410D-06 -0.500D+00 0.140D+00 0.140D+00 0.664D-06 -0.250D+00 0.161D+00 0.161D+00 0.760D-06 -0.670D-01 0.177D+00 0.177D+00 0.768D-06 0.000D+00 0.182D+00 0.182D+00 0.761D-06 0.670D-01 0.237D+00 0.237D+00 0.182D-06 0.250D+00 0.372D+00 0.372D+00 0.101D-06 0.500D+00 0.531D+00 0.531D+00 0.423D-06 0.750D+00 0.668D+00 0.668D+00 0.558D-06 0.933D+00 0.758D+00 0.758D+00 0.112D-05 0.100D+01 0.788D+00 0.788D+00 0.906D-06 ENORM= 0.591D-06 GERR= 0.112D-05 INTERC ROUTINE CALLED WITH ITYPE = 2 AND INTERP. POINTS EQUAL TO BREAK-POINTS I.E. COMPONENT NO (=I1) WITH VALUE (=R1) IS CLOSE TO BREAK POINT(=I2) WITH VALUE (=R2). IN ABOVE MESSAGE I1 = 7 I2 = 2 IN ABOVE, R1 = 0.0000000000000D+00 R2 = 0.0000000000000D+0 X = -0.100D+01 TRUE = 0.909D-01 CALC= 0.909D-01 ERR= 0.300D-05 X = -0.933D+00 TRUE = 0.904D-01 CALC= 0.904D-01 ERR= 0.249D-05 X = -0.750D+00 TRUE = 0.889D-01 CALC= 0.889D-01 ERR= 0.147D-05 X = -0.500D+00 TRUE = 0.870D-01 CALC= 0.870D-01 ERR= 0.645D-06 X = -0.250D+00 TRUE = 0.851D-01 CALC= 0.851D-01 ERR= 0.167D-06 X = -0.670D-01 TRUE = 0.838D-01 CALC= 0.838D-01 ERR= 0.672D-07 X = 0.000D+00 TRUE = 0.458D+00 CALC= 0.458D+00 ERR= 0.967D-05 X = 0.670D-01 TRUE = 0.789D+00 CALC= 0.789D+00 ERR= 0.206D-04 X = 0.250D+00 TRUE = 0.690D+00 CALC= 0.690D+00 ERR= 0.157D-04 X = 0.500D+00 TRUE = 0.588D+00 CALC= 0.588D+00 ERR= 0.119D-04 X = 0.750D+00 TRUE = 0.513D+00 CALC= 0.513D+00 ERR= 0.131D-04 X = 0.933D+00 TRUE = 0.469D+00 CALC= 0.469D+00 ERR= 0.911D-05 X = 0.100D+01 TRUE = 0.455D+00 CALC= 0.455D+00 ERR= 0.107D-04 SCALED LOCAL ERROR IS 0.508D-01 ORDER RAISE CONSIDERED AT T= 0.232D+00 H= 0.579D-01 ORDER= 3 JAC EVAL SCALED LOCAL ERROR IS 0.252D+00 AT T= 0.289D+00 H= 0.579D-01 ORDER= 4 SCALED LOCAL ERROR IS 0.816D-01 AT T= 0.347D+00 H= 0.579D-01 ORDER= 4 MESH NUM SOL SOL ERROR -0.100D+01 0.182D+00 0.182D+00 0.215D-07 -0.933D+00 0.188D+00 0.188D+00 0.100D-06 -0.750D+00 0.203D+00 0.203D+00 0.339D-06 -0.500D+00 0.223D+00 0.223D+00 0.557D-06 -0.250D+00 0.243D+00 0.243D+00 0.684D-06 -0.670D-01 0.257D+00 0.257D+00 0.717D-06 0.000D+00 0.262D+00 0.262D+00 0.717D-06 0.670D-01 0.313D+00 0.313D+00 0.954D-06 0.250D+00 0.438D+00 0.438D+00 0.448D-06 0.500D+00 0.588D+00 0.588D+00 0.259D-06 0.750D+00 0.718D+00 0.718D+00 0.396D-06 0.933D+00 0.803D+00 0.803D+00 0.716D-06 0.100D+01 0.833D+00 0.833D+00 0.565D-06 ENORM= 0.488D-06 GERR= 0.954D-06 INTERC ROUTINE CALLED WITH ITYPE = 2 AND INTERP. POINTS EQUAL TO BREAK-POINTS I.E. COMPONENT NO (=I1) WITH VALUE (=R1) IS CLOSE TO BREAK POINT(=I2) WITH VALUE (=R2). IN ABOVE MESSAGE I1 = 7 I2 = 2 IN ABOVE, R1 = 0.0000000000000D+00 R2 = 0.0000000000000D+0 X = -0.100D+01 TRUE = 0.833D-01 CALC= 0.833D-01 ERR= 0.203D-05 X = -0.933D+00 TRUE = 0.829D-01 CALC= 0.829D-01 ERR= 0.163D-05 X = -0.750D+00 TRUE = 0.816D-01 CALC= 0.816D-01 ERR= 0.107D-05 X = -0.500D+00 TRUE = 0.800D-01 CALC= 0.800D-01 ERR= 0.693D-06 X = -0.250D+00 TRUE = 0.784D-01 CALC= 0.784D-01 ERR= 0.320D-06 X = -0.670D-01 TRUE = 0.773D-01 CALC= 0.773D-01 ERR= 0.456D-07 X = 0.000D+00 TRUE = 0.423D+00 CALC= 0.423D+00 ERR= 0.702D-05 X = 0.670D-01 TRUE = 0.732D+00 CALC= 0.732D+00 ERR= 0.108D-04 X = 0.250D+00 TRUE = 0.645D+00 CALC= 0.645D+00 ERR= 0.132D-04 X = 0.500D+00 TRUE = 0.556D+00 CALC= 0.556D+00 ERR= 0.694D-05 X = 0.750D+00 TRUE = 0.488D+00 CALC= 0.488D+00 ERR= 0.840D-05 X = 0.933D+00 TRUE = 0.448D+00 CALC= 0.448D+00 ERR= 0.628D-05 X = 0.100D+01 TRUE = 0.435D+00 CALC= 0.435D+00 ERR= 0.709D-05 SCALED LOCAL ERROR IS 0.132D+00 AT T= 0.405D+00 H= 0.579D-01 ORDER= 4 MESH NUM SOL SOL ERROR -0.100D+01 0.262D+00 0.262D+00 0.791D-07 -0.933D+00 0.268D+00 0.268D+00 0.203D-06 -0.750D+00 0.281D+00 0.281D+00 0.512D-06 -0.500D+00 0.300D+00 0.300D+00 0.834D-06 -0.250D+00 0.318D+00 0.318D+00 0.104D-05 -0.670D-01 0.332D+00 0.332D+00 0.111D-05 0.000D+00 0.336D+00 0.336D+00 0.112D-05 0.670D-01 0.383D+00 0.383D+00 0.140D-05 0.250D+00 0.501D+00 0.501D+00 0.122D-05 0.500D+00 0.642D+00 0.642D+00 0.613D-06 0.750D+00 0.765D+00 0.765D+00 0.180D-06 0.933D+00 0.847D+00 0.847D+00 0.178D-06 0.100D+01 0.875D+00 0.875D+00 0.798D-07 ENORM= 0.648D-06 GERR= 0.140D-05 INTERC ROUTINE CALLED WITH ITYPE = 2 AND INTERP. POINTS EQUAL TO BREAK-POINTS I.E. COMPONENT NO (=I1) WITH VALUE (=R1) IS CLOSE TO BREAK POINT(=I2) WITH VALUE (=R2). IN ABOVE MESSAGE I1 = 7 I2 = 2 IN ABOVE, R1 = 0.0000000000000D+00 R2 = 0.0000000000000D+0 X = -0.100D+01 TRUE = 0.769D-01 CALC= 0.769D-01 ERR= 0.187D-05 X = -0.933D+00 TRUE = 0.765D-01 CALC= 0.765D-01 ERR= 0.182D-05 X = -0.750D+00 TRUE = 0.755D-01 CALC= 0.755D-01 ERR= 0.153D-05 X = -0.500D+00 TRUE = 0.741D-01 CALC= 0.741D-01 ERR= 0.104D-05 X = -0.250D+00 TRUE = 0.727D-01 CALC= 0.727D-01 ERR= 0.577D-06 X = -0.670D-01 TRUE = 0.718D-01 CALC= 0.718D-01 ERR= 0.258D-06 X = 0.000D+00 TRUE = 0.393D+00 CALC= 0.393D+00 ERR= 0.363D-05 X = 0.670D-01 TRUE = 0.682D+00 CALC= 0.682D+00 ERR= 0.866D-05 X = 0.250D+00 TRUE = 0.606D+00 CALC= 0.606D+00 ERR= 0.859D-05 X = 0.500D+00 TRUE = 0.526D+00 CALC= 0.526D+00 ERR= 0.350D-05 X = 0.750D+00 TRUE = 0.465D+00 CALC= 0.465D+00 ERR= 0.693D-05 X = 0.933D+00 TRUE = 0.429D+00 CALC= 0.429D+00 ERR= 0.404D-05 X = 0.100D+01 TRUE = 0.417D+00 CALC= 0.417D+00 ERR= 0.476D-05 SCALED LOCAL ERROR IS 0.510D-01 AT T= 0.463D+00 H= 0.579D-01 ORDER= 4 SCALED LOCAL ERROR IS 0.370D-01 AT T= 0.521D+00 H= 0.579D-01 ORDER= 4 MESH NUM SOL SOL ERROR -0.100D+01 0.336D+00 0.336D+00 0.101D-06 -0.933D+00 0.341D+00 0.341D+00 0.178D-06 -0.750D+00 0.354D+00 0.354D+00 0.360D-06 -0.500D+00 0.372D+00 0.372D+00 0.542D-06 -0.250D+00 0.389D+00 0.389D+00 0.657D-06 -0.670D-01 0.401D+00 0.401D+00 0.702D-06 0.000D+00 0.405D+00 0.405D+00 0.712D-06 0.670D-01 0.449D+00 0.449D+00 0.907D-06 0.250D+00 0.560D+00 0.560D+00 0.887D-06 0.500D+00 0.693D+00 0.693D+00 0.735D-06 0.750D+00 0.811D+00 0.811D+00 0.649D-06 0.933D+00 0.889D+00 0.889D+00 0.485D-06 0.100D+01 0.916D+00 0.916D+00 0.573D-06 ENORM= 0.492D-06 GERR= 0.907D-06 INTERC ROUTINE CALLED WITH ITYPE = 2 AND INTERP. POINTS EQUAL TO BREAK-POINTS I.E. COMPONENT NO (=I1) WITH VALUE (=R1) IS CLOSE TO BREAK POINT(=I2) WITH VALUE (=R2). IN ABOVE MESSAGE I1 = 7 I2 = 2 IN ABOVE, R1 = 0.0000000000000D+00 R2 = 0.0000000000000D+0 X = -0.100D+01 TRUE = 0.714D-01 CALC= 0.714D-01 ERR= 0.118D-05 X = -0.933D+00 TRUE = 0.711D-01 CALC= 0.711D-01 ERR= 0.111D-05 X = -0.750D+00 TRUE = 0.702D-01 CALC= 0.702D-01 ERR= 0.878D-06 X = -0.500D+00 TRUE = 0.690D-01 CALC= 0.690D-01 ERR= 0.587D-06 X = -0.250D+00 TRUE = 0.678D-01 CALC= 0.678D-01 ERR= 0.336D-06 X = -0.670D-01 TRUE = 0.670D-01 CALC= 0.670D-01 ERR= 0.167D-06 X = 0.000D+00 TRUE = 0.367D+00 CALC= 0.367D+00 ERR= 0.240D-05 X = 0.670D-01 TRUE = 0.638D+00 CALC= 0.638D+00 ERR= 0.614D-05 X = 0.250D+00 TRUE = 0.571D+00 CALC= 0.571D+00 ERR= 0.503D-05 X = 0.500D+00 TRUE = 0.500D+00 CALC= 0.500D+00 ERR= 0.350D-05 X = 0.750D+00 TRUE = 0.444D+00 CALC= 0.444D+00 ERR= 0.420D-05 X = 0.933D+00 TRUE = 0.411D+00 CALC= 0.411D+00 ERR= 0.315D-05 X = 0.100D+01 TRUE = 0.400D+00 CALC= 0.400D+00 ERR= 0.308D-05 SCALED LOCAL ERROR IS 0.333D-01 ORDER RAISE CONSIDERED AT T= 0.579D+00 H= 0.116D+00 ORDER= 4 JAC EVAL SCALED LOCAL ERROR IS 0.146D+00 AT T= 0.695D+00 H= 0.116D+00 ORDER= 5 MESH NUM SOL SOL ERROR -0.100D+01 0.405D+00 0.405D+00 0.384D-07 -0.933D+00 0.410D+00 0.410D+00 0.288D-07 -0.750D+00 0.422D+00 0.422D+00 0.193D-06 -0.500D+00 0.438D+00 0.438D+00 0.369D-06 -0.250D+00 0.454D+00 0.454D+00 0.489D-06 -0.670D-01 0.466D+00 0.466D+00 0.542D-06 0.000D+00 0.470D+00 0.470D+00 0.554D-06 0.670D-01 0.511D+00 0.511D+00 0.738D-06 0.250D+00 0.615D+00 0.615D+00 0.797D-06 0.500D+00 0.742D+00 0.742D+00 0.748D-06 0.750D+00 0.854D+00 0.854D+00 0.767D-06 0.933D+00 0.929D+00 0.929D+00 0.709D-06 0.100D+01 0.956D+00 0.956D+00 0.784D-06 ENORM= 0.439D-06 GERR= 0.797D-06 INTERC ROUTINE CALLED WITH ITYPE = 2 AND INTERP. POINTS EQUAL TO BREAK-POINTS I.E. COMPONENT NO (=I1) WITH VALUE (=R1) IS CLOSE TO BREAK POINT(=I2) WITH VALUE (=R2). IN ABOVE MESSAGE I1 = 7 I2 = 2 IN ABOVE, R1 = 0.0000000000000D+00 R2 = 0.0000000000000D+0 X = -0.100D+01 TRUE = 0.667D-01 CALC= 0.667D-01 ERR= 0.103D-05 X = -0.933D+00 TRUE = 0.664D-01 CALC= 0.664D-01 ERR= 0.976D-06 X = -0.750D+00 TRUE = 0.656D-01 CALC= 0.656D-01 ERR= 0.817D-06 X = -0.500D+00 TRUE = 0.645D-01 CALC= 0.645D-01 ERR= 0.591D-06 X = -0.250D+00 TRUE = 0.635D-01 CALC= 0.635D-01 ERR= 0.370D-06 X = -0.670D-01 TRUE = 0.628D-01 CALC= 0.628D-01 ERR= 0.212D-06 X = 0.000D+00 TRUE = 0.344D+00 CALC= 0.344D+00 ERR= 0.122D-05 X = 0.670D-01 TRUE = 0.600D+00 CALC= 0.600D+00 ERR= 0.487D-05 X = 0.250D+00 TRUE = 0.541D+00 CALC= 0.541D+00 ERR= 0.326D-05 X = 0.500D+00 TRUE = 0.476D+00 CALC= 0.476D+00 ERR= 0.272D-05 X = 0.750D+00 TRUE = 0.426D+00 CALC= 0.426D+00 ERR= 0.262D-05 X = 0.933D+00 TRUE = 0.395D+00 CALC= 0.395D+00 ERR= 0.248D-05 X = 0.100D+01 TRUE = 0.385D+00 CALC= 0.385D+00 ERR= 0.205D-05 SCALED LOCAL ERROR IS 0.197D+00 AT T= 0.810D+00 H= 0.116D+00 ORDER= 5 MESH NUM SOL SOL ERROR -0.100D+01 0.470D+00 0.470D+00 0.287D-07 -0.933D+00 0.474D+00 0.474D+00 0.838D-07 -0.750D+00 0.486D+00 0.486D+00 0.164D-06 -0.500D+00 0.501D+00 0.501D+00 0.159D-06 -0.250D+00 0.516D+00 0.516D+00 0.862D-07 -0.670D-01 0.527D+00 0.527D+00 0.170D-07 0.000D+00 0.531D+00 0.531D+00 0.876D-08 0.670D-01 0.569D+00 0.569D+00 0.326D-06 0.250D+00 0.668D+00 0.668D+00 0.778D-06 0.500D+00 0.788D+00 0.788D+00 0.837D-06 0.750D+00 0.896D+00 0.896D+00 0.638D-06 0.933D+00 0.968D+00 0.968D+00 0.489D-06 0.100D+01 0.993D+00 0.993D+00 0.534D-06 ENORM= 0.349D-06 GERR= 0.837D-06 INTERC ROUTINE CALLED WITH ITYPE = 2 AND INTERP. POINTS EQUAL TO BREAK-POINTS I.E. COMPONENT NO (=I1) WITH VALUE (=R1) IS CLOSE TO BREAK POINT(=I2) WITH VALUE (=R2). IN ABOVE MESSAGE I1 = 7 I2 = 2 IN ABOVE, R1 = 0.0000000000000D+00 R2 = 0.0000000000000D+0 X = -0.100D+01 TRUE = 0.625D-01 CALC= 0.625D-01 ERR= 0.944D-06 X = -0.933D+00 TRUE = 0.622D-01 CALC= 0.622D-01 ERR= 0.706D-06 X = -0.750D+00 TRUE = 0.615D-01 CALC= 0.615D-01 ERR= 0.205D-06 X = -0.500D+00 TRUE = 0.606D-01 CALC= 0.606D-01 ERR= 0.195D-06 X = -0.250D+00 TRUE = 0.597D-01 CALC= 0.597D-01 ERR= 0.360D-06 X = -0.670D-01 TRUE = 0.591D-01 CALC= 0.591D-01 ERR= 0.386D-06 X = 0.000D+00 TRUE = 0.324D+00 CALC= 0.324D+00 ERR= 0.639D-06 X = 0.670D-01 TRUE = 0.566D+00 CALC= 0.566D+00 ERR= 0.624D-05 X = 0.250D+00 TRUE = 0.513D+00 CALC= 0.513D+00 ERR= 0.836D-06 X = 0.500D+00 TRUE = 0.455D+00 CALC= 0.455D+00 ERR= 0.141D-05 X = 0.750D+00 TRUE = 0.408D+00 CALC= 0.408D+00 ERR= 0.274D-05 X = 0.933D+00 TRUE = 0.380D+00 CALC= 0.380D+00 ERR= 0.152D-05 X = 0.100D+01 TRUE = 0.370D+00 CALC= 0.370D+00 ERR= 0.151D-05 MESH NUM SOL SOL ERROR -0.100D+01 0.531D+00 0.531D+00 0.143D-06 -0.933D+00 0.535D+00 0.535D+00 0.328D-06 -0.750D+00 0.545D+00 0.545D+00 0.730D-06 -0.500D+00 0.560D+00 0.560D+00 0.106D-05 -0.250D+00 0.574D+00 0.574D+00 0.120D-05 -0.670D-01 0.584D+00 0.584D+00 0.119D-05 0.000D+00 0.588D+00 0.588D+00 0.117D-05 0.670D-01 0.624D+00 0.624D+00 0.854D-06 0.250D+00 0.718D+00 0.718D+00 0.101D-06 0.500D+00 0.833D+00 0.833D+00 0.445D-06 0.750D+00 0.936D+00 0.936D+00 0.442D-06 0.933D+00 0.101D+01 0.101D+01 0.322D-06 0.100D+01 0.103D+01 0.103D+01 0.353D-06 ENORM= 0.536D-06 GERR= 0.120D-05 INTERC ROUTINE CALLED WITH ITYPE = 2 AND INTERP. POINTS EQUAL TO BREAK-POINTS I.E. COMPONENT NO (=I1) WITH VALUE (=R1) IS CLOSE TO BREAK POINT(=I2) WITH VALUE (=R2). IN ABOVE MESSAGE I1 = 7 I2 = 2 IN ABOVE, R1 = 0.0000000000000D+00 R2 = 0.0000000000000D+0 X = -0.100D+01 TRUE = 0.588D-01 CALC= 0.588D-01 ERR= 0.292D-05 X = -0.933D+00 TRUE = 0.586D-01 CALC= 0.586D-01 ERR= 0.261D-05 X = -0.750D+00 TRUE = 0.580D-01 CALC= 0.580D-01 ERR= 0.181D-05 X = -0.500D+00 TRUE = 0.571D-01 CALC= 0.571D-01 ERR= 0.896D-06 X = -0.250D+00 TRUE = 0.563D-01 CALC= 0.563D-01 ERR= 0.187D-06 X = -0.670D-01 TRUE = 0.558D-01 CALC= 0.558D-01 ERR= 0.225D-06 X = 0.000D+00 TRUE = 0.306D+00 CALC= 0.306D+00 ERR= 0.914D-06 X = 0.670D-01 TRUE = 0.536D+00 CALC= 0.536D+00 ERR= 0.626D-05 X = 0.250D+00 TRUE = 0.488D+00 CALC= 0.488D+00 ERR= 0.192D-05 X = 0.500D+00 TRUE = 0.435D+00 CALC= 0.435D+00 ERR= 0.230D-05 X = 0.750D+00 TRUE = 0.392D+00 CALC= 0.392D+00 ERR= 0.196D-05 X = 0.933D+00 TRUE = 0.366D+00 CALC= 0.366D+00 ERR= 0.106D-05 X = 0.100D+01 TRUE = 0.357D+00 CALC= 0.357D+00 ERR= 0.112D-05 SCALED LOCAL ERROR IS 0.211D+00 AT T= 0.926D+00 H= 0.116D+00 ORDER= 5 MESH NUM SOL SOL ERROR -0.100D+01 0.588D+00 0.588D+00 0.276D-06 -0.933D+00 0.592D+00 0.592D+00 0.454D-06 -0.750D+00 0.602D+00 0.602D+00 0.909D-06 -0.500D+00 0.615D+00 0.615D+00 0.141D-05 -0.250D+00 0.629D+00 0.629D+00 0.173D-05 -0.670D-01 0.638D+00 0.638D+00 0.184D-05 0.000D+00 0.642D+00 0.642D+00 0.186D-05 0.670D-01 0.677D+00 0.677D+00 0.184D-05 0.250D+00 0.765D+00 0.765D+00 0.145D-05 0.500D+00 0.875D+00 0.875D+00 0.542D-06 0.750D+00 0.975D+00 0.975D+00 0.106D-06 0.933D+00 0.104D+01 0.104D+01 0.261D-06 0.100D+01 0.106D+01 0.106D+01 0.305D-06 ENORM= 0.832D-06 GERR= 0.186D-05 INTERC ROUTINE CALLED WITH ITYPE = 2 AND INTERP. POINTS EQUAL TO BREAK-POINTS I.E. COMPONENT NO (=I1) WITH VALUE (=R1) IS CLOSE TO BREAK POINT(=I2) WITH VALUE (=R2). IN ABOVE MESSAGE I1 = 7 I2 = 2 IN ABOVE, R1 = 0.0000000000000D+00 R2 = 0.0000000000000D+0 X = -0.100D+01 TRUE = 0.556D-01 CALC= 0.556D-01 ERR= 0.269D-05 X = -0.933D+00 TRUE = 0.553D-01 CALC= 0.553D-01 ERR= 0.263D-05 X = -0.750D+00 TRUE = 0.548D-01 CALC= 0.548D-01 ERR= 0.231D-05 X = -0.500D+00 TRUE = 0.541D-01 CALC= 0.541D-01 ERR= 0.167D-05 X = -0.250D+00 TRUE = 0.533D-01 CALC= 0.533D-01 ERR= 0.897D-06 X = -0.670D-01 TRUE = 0.528D-01 CALC= 0.528D-01 ERR= 0.317D-06 X = 0.000D+00 TRUE = 0.289D+00 CALC= 0.289D+00 ERR= 0.135D-05 X = 0.670D-01 TRUE = 0.508D+00 CALC= 0.508D+00 ERR= 0.201D-05 X = 0.250D+00 TRUE = 0.465D+00 CALC= 0.465D+00 ERR= 0.207D-05 X = 0.500D+00 TRUE = 0.417D+00 CALC= 0.417D+00 ERR= 0.452D-05 X = 0.750D+00 TRUE = 0.377D+00 CALC= 0.377D+00 ERR= 0.569D-06 X = 0.933D+00 TRUE = 0.353D+00 CALC= 0.353D+00 ERR= 0.138D-05 X = 0.100D+01 TRUE = 0.345D+00 CALC= 0.345D+00 ERR= 0.800D-06 SCALED LOCAL ERROR IS 0.124D+00 AT T= 0.104D+01 H= 0.116D+00 ORDER= 5 MESH NUM SOL SOL ERROR -0.100D+01 0.642D+00 0.642D+00 0.274D-06 -0.933D+00 0.645D+00 0.645D+00 0.413D-06 -0.750D+00 0.655D+00 0.655D+00 0.739D-06 -0.500D+00 0.668D+00 0.668D+00 0.108D-05 -0.250D+00 0.681D+00 0.681D+00 0.131D-05 -0.670D-01 0.690D+00 0.690D+00 0.142D-05 0.000D+00 0.693D+00 0.693D+00 0.144D-05 0.670D-01 0.726D+00 0.726D+00 0.158D-05 0.250D+00 0.811D+00 0.811D+00 0.173D-05 0.500D+00 0.916D+00 0.916D+00 0.130D-05 0.750D+00 0.101D+01 0.101D+01 0.615D-06 0.933D+00 0.108D+01 0.108D+01 0.351D-06 0.100D+01 0.110D+01 0.110D+01 0.314D-06 ENORM= 0.784D-06 GERR= 0.173D-05 INTERC ROUTINE CALLED WITH ITYPE = 2 AND INTERP. POINTS EQUAL TO BREAK-POINTS I.E. COMPONENT NO (=I1) WITH VALUE (=R1) IS CLOSE TO BREAK POINT(=I2) WITH VALUE (=R2). IN ABOVE MESSAGE I1 = 7 I2 = 2 IN ABOVE, R1 = 0.0000000000000D+00 R2 = 0.0000000000000D+0 X = -0.100D+01 TRUE = 0.526D-01 CALC= 0.526D-01 ERR= 0.217D-05 X = -0.933D+00 TRUE = 0.524D-01 CALC= 0.524D-01 ERR= 0.199D-05 X = -0.750D+00 TRUE = 0.519D-01 CALC= 0.519D-01 ERR= 0.159D-05 X = -0.500D+00 TRUE = 0.513D-01 CALC= 0.513D-01 ERR= 0.114D-05 X = -0.250D+00 TRUE = 0.506D-01 CALC= 0.506D-01 ERR= 0.727D-06 X = -0.670D-01 TRUE = 0.502D-01 CALC= 0.502D-01 ERR= 0.415D-06 X = 0.000D+00 TRUE = 0.275D+00 CALC= 0.275D+00 ERR= 0.221D-05 X = 0.670D-01 TRUE = 0.484D+00 CALC= 0.484D+00 ERR= 0.985D-06 X = 0.250D+00 TRUE = 0.444D+00 CALC= 0.444D+00 ERR= 0.452D-06 X = 0.500D+00 TRUE = 0.400D+00 CALC= 0.400D+00 ERR= 0.347D-05 X = 0.750D+00 TRUE = 0.364D+00 CALC= 0.364D+00 ERR= 0.154D-05 X = 0.933D+00 TRUE = 0.341D+00 CALC= 0.341D+00 ERR= 0.134D-05 X = 0.100D+01 TRUE = 0.333D+00 CALC= 0.333D+00 ERR= 0.793D-06 NSTEPS = 33 NRESID = 65 JAC = 12 CPU= 0.000D+00 RTOL= 0.100D-04 ATOL= 0.100D-04 ITRACE AND IDEV= 0 4 SOLUTION TO B.P. POOL EVAPORATION PROBLEM USING DASSL INTEGRATOR ATOL = 0.100D-04 RTOL = 0.100D-04 NPTS = 22 I= 1 XOUT= 0.00000D+00 LOG10= 0.00000D+00 I= 2 XOUT= 0.12700D-03 LOG10= 0.17609D+00 I= 3 XOUT= 0.25400D-03 LOG10= 0.30103D+00 I= 4 XOUT= 0.38100D-03 LOG10= 0.39794D+00 I= 5 XOUT= 0.50800D-03 LOG10= 0.47712D+00 I= 6 XOUT= 0.63500D-03 LOG10= 0.54407D+00 I= 7 XOUT= 0.76200D-03 LOG10= 0.60206D+00 I= 8 XOUT= 0.88900D-03 LOG10= 0.65321D+00 I= 9 XOUT= 0.10000D-02 LOG10= 0.69346D+00 I= 10 XOUT= 0.30000D-02 LOG10= 0.11076D+01 I= 11 XOUT= 0.50000D-02 LOG10= 0.13157D+01 I= 12 XOUT= 0.75000D-02 LOG10= 0.14847D+01 I= 13 XOUT= 0.10000D-01 LOG10= 0.16061D+01 I= 14 XOUT= 0.30000D-01 LOG10= 0.20759D+01 I= 15 XOUT= 0.50000D-01 LOG10= 0.22963D+01 I= 16 XOUT= 0.75000D-01 LOG10= 0.24717D+01 I= 17 XOUT= 0.10000D+00 LOG10= 0.25963D+01 I= 18 XOUT= 0.15000D+00 LOG10= 0.27720D+01 I= 19 XOUT= 0.20000D+00 LOG10= 0.28967D+01 I= 20 XOUT= 0.22000D+00 LOG10= 0.29381D+01 INICHB ROUTINE HAS FOUND THAT COUPLING POINT (=I1) HAS VALUE (=R1) WHICH IS VERY CLOSE TO BREAK-POINT (=I2) WITH VALUE (=R2) IN ABOVE MESSAGE I1 = 4 I2 = 2 IN ABOVE, R1 = 0.2540000000000D-03 R2 = 0.2540000000000D-0 INICHB ROUTINE HAS FOUND THAT COUPLING POINT (=I1) HAS VALUE (=R1) WHICH IS VERY CLOSE TO BREAK-POINT (=I2) WITH VALUE (=R2) IN ABOVE MESSAGE I1 = 7 I2 = 3 IN ABOVE, R1 = 0.5080000000000D-03 R2 = 0.5080000000000D-0 INICHB ROUTINE HAS FOUND THAT COUPLING POINT (=I1) HAS VALUE (=R1) WHICH IS VERY CLOSE TO BREAK-POINT (=I2) WITH VALUE (=R2) IN ABOVE MESSAGE I1 = 10 I2 = 4 IN ABOVE, R1 = 0.7620000000000D-03 R2 = 0.7620000000000D-0 INICHB ROUTINE HAS FOUND THAT COUPLING POINT (=I1) HAS VALUE (=R1) WHICH IS VERY CLOSE TO BREAK-POINT (=I2) WITH VALUE (=R2) IN ABOVE MESSAGE I1 = 13 I2 = 5 IN ABOVE, R1 = 0.1016000000000D-02 R2 = 0.1016000000000D-0 INICHB ROUTINE HAS FOUND THAT COUPLING POINT (=I1) HAS VALUE (=R1) WHICH IS VERY CLOSE TO BREAK-POINT (=I2) WITH VALUE (=R2) IN ABOVE MESSAGE I1 = 16 I2 = 6 IN ABOVE, R1 = 0.5588000000000D-02 R2 = 0.5588000000000D-0 INICHB ROUTINE HAS FOUND THAT COUPLING POINT (=I1) HAS VALUE (=R1) WHICH IS VERY CLOSE TO BREAK-POINT (=I2) WITH VALUE (=R2) IN ABOVE MESSAGE I1 = 19 I2 = 7 IN ABOVE, R1 = 0.6146800000000D-01 R2 = 0.6146800000000D-0 INITIAL VALUES ARE = 0.385D-01 0.000D+00 0.000D+00 0.000D+00 0.000 INITIAL VALUES ARE = 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000 INITIAL VALUES ARE = 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000 INITIAL VALUES ARE = 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000 INITIAL VALUES ARE = 0.000D+00 0.000D+00 0.0 U 0.385D-01 0.000D+00 0.000D+00 0.000D+00 0.000D+00 0.000D X AND Y VALUES ARE 0.0000E+00 0.1000E+01 X AND Y VALUES ARE 0.1761E+00 -0.1667E+00 X AND Y VALUES ARE 0.3010E+00 0.0000E+00 X AND Y VALUES ARE 0.3979E+00 0.0000E+00 X AND Y VALUES ARE 0.4771E+00 0.0000E+00 X AND Y VALUES ARE 0.5441E+00 0.0000E+00 X AND Y VALUES ARE 0.6021E+00 0.0000E+00 X AND Y VALUES ARE 0.6532E+00 0.0000E+00 X AND Y VALUES ARE 0.6935E+00 0.0000E+00 X AND Y VALUES ARE 0.1108E+01 0.0000E+00 X AND Y VALUES ARE 0.1316E+01 0.0000E+00 X AND Y VALUES ARE 0.1485E+01 0.0000E+00 X AND Y VALUES ARE 0.1606E+01 0.0000E+00 X AND Y VALUES ARE 0.2076E+01 0.0000E+00 X AND Y VALUES ARE 0.2296E+01 0.0000E+00 X AND Y VALUES ARE 0.2472E+01 0.0000E+00 X AND Y VALUES ARE 0.2596E+01 0.0000E+00 X AND Y VALUES ARE 0.2772E+01 0.0000E+00 X AND Y VALUES ARE 0.2897E+01 0.0000E+00 X AND Y VALUES ARE 0.2938E+01 0.0000E+00 T/X 0.000D+00 0.254D-03 0.508D-03 0.762D-03 0.100D-02 0.500D T/X 0.200D+00 AT TIME T = 0.100D-03 DASSL RETURNED IDID = 3 0.0 U 0.385D-01 -0.379D-04 0.201D-07 -0.111D-10 0.497D-14 0.313D Q1 , Q2 AND Q3 ARE 0.61252D-06 0.51090D-06 -0.10161D-06 X AND Y VALUES ARE 0.0000E+00 0.1000E+01 X AND Y VALUES ARE 0.1761E+00 0.2723E-01 X AND Y VALUES ARE 0.3010E+00 0.7576E-02 X AND Y VALUES ARE 0.3979E+00 -0.9850E-03 X AND Y VALUES ARE 0.4771E+00 0.4300E-04 X AND Y VALUES ARE 0.5441E+00 -0.2942E-05 X AND Y VALUES ARE 0.6021E+00 0.5224E-06 X AND Y VALUES ARE 0.6532E+00 -0.1793E-07 X AND Y VALUES ARE 0.6935E+00 0.6562E-08 X AND Y VALUES ARE 0.1108E+01 -0.2882E-09 X AND Y VALUES ARE 0.1316E+01 0.8455E-10 X AND Y VALUES ARE 0.1485E+01 0.1823E-12 X AND Y VALUES ARE 0.1606E+01 0.1292E-12 X AND Y VALUES ARE 0.2076E+01 -0.4027E-13 X AND Y VALUES ARE 0.2296E+01 0.6115E-14 X AND Y VALUES ARE 0.2472E+01 0.8134E-18 X AND Y VALUES ARE 0.2596E+01 0.6765E-18 X AND Y VALUES ARE 0.2772E+01 0.4403E-18 X AND Y VALUES ARE 0.2897E+01 0.2504E-18 X AND Y VALUES ARE 0.2938E+01 0.1865E-18 AT TIME T = 0.100D-02 DASSL RETURNED IDID = 3 0.0 U 0.385D-01 -0.123D-03 0.286D-06 -0.132D-08 0.287D-11 0.106D Q1 , Q2 AND Q3 ARE 0.25518D-05 0.23813D-05 -0.17044D-06 AT TIME T = 0.100D-01 DASSL RETURNED IDID = 3 0.0 U 0.385D-01 0.777D-02 0.561D-03 -0.308D-04 0.526D-06 0.189D Q1 , Q2 AND Q3 ARE 0.10948D-04 0.10852D-04 -0.95811D-07 X AND Y VALUES ARE 0.0000E+00 0.1000E+01 X AND Y VALUES ARE 0.1761E+00 0.7058E+00 X AND Y VALUES ARE 0.3010E+00 0.4291E+00 X AND Y VALUES ARE 0.3979E+00 0.2018E+00 X AND Y VALUES ARE 0.4771E+00 0.3737E-01 X AND Y VALUES ARE 0.5441E+00 0.2322E-01 X AND Y VALUES ARE 0.6021E+00 0.1458E-01 X AND Y VALUES ARE 0.6532E+00 0.9107E-02 X AND Y VALUES ARE 0.6935E+00 0.5998E-02 X AND Y VALUES ARE 0.1108E+01 -0.8013E-03 X AND Y VALUES ARE 0.1316E+01 0.1979E-03 X AND Y VALUES ARE 0.1485E+01 0.1926E-04 X AND Y VALUES ARE 0.1606E+01 0.1367E-04 X AND Y VALUES ARE 0.2076E+01 -0.4229E-05 X AND Y VALUES ARE 0.2296E+01 0.6220E-06 X AND Y VALUES ARE 0.2472E+01 0.4902E-08 X AND Y VALUES ARE 0.2596E+01 0.4077E-08 X AND Y VALUES ARE 0.2772E+01 0.2654E-08 X AND Y VALUES ARE 0.2897E+01 0.1509E-08 X AND Y VALUES ARE 0.2938E+01 0.1124E-08 AT TIME T = 0.500D-01 DASSL RETURNED IDID = 3 0.1 U 0.385D-01 0.137D-01 0.416D-02 0.286D-03 0.219D-04 0.606D Q1 , Q2 AND Q3 ARE 0.34233D-04 0.34161D-04 -0.71581D-07 AT TIME T = 0.100D+00 DASSL RETURNED IDID = 3 0.1 U 0.385D-01 0.151D-01 0.584D-02 0.119D-02 0.167D-03 0.693D Q1 , Q2 AND Q3 ARE 0.59954D-04 0.59886D-04 -0.67327D-07 X AND Y VALUES ARE 0.0000E+00 0.1000E+01 X AND Y VALUES ARE 0.1761E+00 0.7969E+00 X AND Y VALUES ARE 0.3010E+00 0.5941E+00 X AND Y VALUES ARE 0.3979E+00 0.3925E+00 X AND Y VALUES ARE 0.4771E+00 0.1932E+00 X AND Y VALUES ARE 0.5441E+00 0.1702E+00 X AND Y VALUES ARE 0.6021E+00 0.1519E+00 X AND Y VALUES ARE 0.6532E+00 0.1368E+00 X AND Y VALUES ARE 0.6935E+00 0.1255E+00 X AND Y VALUES ARE 0.1108E+01 0.3105E-01 X AND Y VALUES ARE 0.1316E+01 0.1120E-01 X AND Y VALUES ARE 0.1485E+01 0.6007E-02 X AND Y VALUES ARE 0.1606E+01 0.4327E-02 X AND Y VALUES ARE 0.2076E+01 -0.1208E-02 X AND Y VALUES ARE 0.2296E+01 0.1078E-03 X AND Y VALUES ARE 0.2472E+01 0.1802E-04 X AND Y VALUES ARE 0.2596E+01 0.1499E-04 X AND Y VALUES ARE 0.2772E+01 0.9763E-05 X AND Y VALUES ARE 0.2897E+01 0.5562E-05 X AND Y VALUES ARE 0.2938E+01 0.4147E-05 AT TIME T = 0.150D+00 DASSL RETURNED IDID = 3 0.1 U 0.385D-01 0.158D-01 0.678D-02 0.191D-02 0.404D-03 0.246D Q1 , Q2 AND Q3 ARE 0.84571D-04 0.84506D-04 -0.65201D-07 AT TIME T = 0.250D+00 DASSL RETURNED IDID = 3 0.3 U 0.385D-01 0.167D-01 0.794D-02 0.299D-02 0.914D-03 0.776D Q1 , Q2 AND Q3 ARE 0.13206D-03 0.13199D-03 -0.62684D-07 X AND Y VALUES ARE 0.0000E+00 0.1000E+01 X AND Y VALUES ARE 0.1761E+00 0.8110E+00 X AND Y VALUES ARE 0.3010E+00 0.6220E+00 X AND Y VALUES ARE 0.3979E+00 0.4335E+00 X AND Y VALUES ARE 0.4771E+00 0.2459E+00 X AND Y VALUES ARE 0.5441E+00 0.2240E+00 X AND Y VALUES ARE 0.6021E+00 0.2064E+00 X AND Y VALUES ARE 0.6532E+00 0.1916E+00 X AND Y VALUES ARE 0.6935E+00 0.1804E+00 X AND Y VALUES ARE 0.1108E+01 0.7780E-01 X AND Y VALUES ARE 0.1316E+01 0.4570E-01 X AND Y VALUES ARE 0.1485E+01 0.3197E-01 X AND Y VALUES ARE 0.1606E+01 0.2376E-01 X AND Y VALUES ARE 0.2076E+01 -0.4934E-02 X AND Y VALUES ARE 0.2296E+01 -0.8292E-04 X AND Y VALUES ARE 0.2472E+01 0.2016E-03 X AND Y VALUES ARE 0.2596E+01 0.1679E-03 X AND Y VALUES ARE 0.2772E+01 0.1096E-03 X AND Y VALUES ARE 0.2897E+01 0.6266E-04 X AND Y VALUES ARE 0.2938E+01 0.4685E-04 AT TIME T = 0.500D+00 DASSL RETURNED IDID = 3 0.5 U 0.385D-01 0.179D-01 0.959D-02 0.470D-02 0.194D-02 0.176D Q1 , Q2 AND Q3 ARE 0.24505D-03 0.24499D-03 -0.59215D-07 AT TIME T = 0.650D+00 DASSL RETURNED IDID = 3 0.6 U 0.385D-01 0.183D-01 0.102D-01 0.537D-02 0.241D-02 0.223D Q1 , Q2 AND Q3 ARE 0.31036D-03 0.31030D-03 -0.57922D-07 X AND Y VALUES ARE 0.0000E+00 0.1000E+01 X AND Y VALUES ARE 0.1761E+00 0.8253E+00 X AND Y VALUES ARE 0.3010E+00 0.6507E+00 X AND Y VALUES ARE 0.3979E+00 0.4763E+00 X AND Y VALUES ARE 0.4771E+00 0.3022E+00 X AND Y VALUES ARE 0.5441E+00 0.2818E+00 X AND Y VALUES ARE 0.6021E+00 0.2653E+00 X AND Y VALUES ARE 0.6532E+00 0.2513E+00 X AND Y VALUES ARE 0.6935E+00 0.2407E+00 X AND Y VALUES ARE 0.1108E+01 0.1395E+00 X AND Y VALUES ARE 0.1316E+01 0.1020E+00 X AND Y VALUES ARE 0.1485E+01 0.7928E-01 X AND Y VALUES ARE 0.1606E+01 0.6268E-01 X AND Y VALUES ARE 0.2076E+01 -0.1871E-02 X AND Y VALUES ARE 0.2296E+01 -0.1470E-03 X AND Y VALUES ARE 0.2472E+01 0.5789E-03 X AND Y VALUES ARE 0.2596E+01 0.4834E-03 X AND Y VALUES ARE 0.2772E+01 0.3181E-03 X AND Y VALUES ARE 0.2897E+01 0.1846E-03 X AND Y VALUES ARE 0.2938E+01 0.1395E-03 AT TIME T = 0.800D+00 DASSL RETURNED IDID = 3 0.8 U 0.385D-01 0.187D-01 0.107D-01 0.588D-02 0.280D-02 0.299D Q1 , Q2 AND Q3 ARE 0.37441D-03 0.37435D-03 -0.56940D-07 AT TIME T = 0.100D+01 DASSL RETURNED IDID = 3 1.0 U 0.385D-01 0.190D-01 0.112D-01 0.641D-02 0.324D-02 0.478D Q1 , Q2 AND Q3 ARE 0.45833D-03 0.45828D-03 -0.55941D-07 X AND Y VALUES ARE 0.0000E+00 0.1000E+01 X AND Y VALUES ARE 0.1761E+00 0.8313E+00 X AND Y VALUES ARE 0.3010E+00 0.6627E+00 X AND Y VALUES ARE 0.3979E+00 0.4941E+00 X AND Y VALUES ARE 0.4771E+00 0.3257E+00 X AND Y VALUES ARE 0.5441E+00 0.3060E+00 X AND Y VALUES ARE 0.6021E+00 0.2900E+00 X AND Y VALUES ARE 0.6532E+00 0.2765E+00 X AND Y VALUES ARE 0.6935E+00 0.2662E+00 X AND Y VALUES ARE 0.1108E+01 0.1666E+00 X AND Y VALUES ARE 0.1316E+01 0.1281E+00 X AND Y VALUES ARE 0.1485E+01 0.1032E+00 X AND Y VALUES ARE 0.1606E+01 0.8423E-01 X AND Y VALUES ARE 0.2076E+01 0.6509E-02 X AND Y VALUES ARE 0.2296E+01 0.2203E-02 X AND Y VALUES ARE 0.2472E+01 0.1242E-02 X AND Y VALUES ARE 0.2596E+01 0.1038E-02 X AND Y VALUES ARE 0.2772E+01 0.6846E-03 X AND Y VALUES ARE 0.2897E+01 0.3989E-03 X AND Y VALUES ARE 0.2938E+01 0.3023E-03 RATE OF EVAPORATION AT SURFACE OF POOL Q1 = 0.4583313D-03 QUANTITY OF VAPOUR ABOVE END OF POOL Q2 = 0.4582754D-03 ABSOLUTE DIFFERENCE Q3 = 0.5594D-07 ******************************************************** CNSTEPS = 93 NRESID = 186 JAC = 19 CPU= 0.000D+00 RTOL= 0.100D-04 ATOL= 0.100D-04 ITRACE AND IDEV= 0 4 SOLUTION TO FOURTH ORDER P.D.E. PROBLEM USING DASSL INTEGRATOR ATOL = 0.100D-04 RTOL = 0.100D-04 NPTS = 41 X -0.100D+01 -0.600D+00 -0.200D+00 0.200D+00 0.600D+00 0.100D+01 AT TIME T = 0.100D-03 DASSL RETURNED IDID = 3 LEFT SOL= 0.100D+01 -0.248D+01 RIGHT SOL= -0.100D+01 0.248D+01 U 0.100D+01 0.809D+00 0.309D+00 -0.309D+00 -0.809D+00 -0.100D+01 V -0.248D+01 -0.200D+01 -0.762D+00 0.762D+00 0.200D+01 0.248D+01 AT TIME T = 0.100D-02 DASSL RETURNED IDID = 3 LEFT SOL= 0.100D+01 -0.255D+01 RIGHT SOL= -0.100D+01 0.255D+01 U 0.100D+01 0.809D+00 0.309D+00 -0.309D+00 -0.809D+00 -0.100D+01 V -0.255D+01 -0.199D+01 -0.761D+00 0.761D+00 0.199D+01 0.255D+01 AT TIME T = 0.100D-01 DASSL RETURNED IDID = 3 LEFT SOL= 0.100D+01 -0.272D+01 RIGHT SOL= -0.100D+01 0.272D+01 U 0.100D+01 0.805D+00 0.307D+00 -0.307D+00 -0.805D+00 -0.100D+01 V -0.272D+01 -0.195D+01 -0.744D+00 0.744D+00 0.195D+01 0.272D+01 AT TIME T = 0.100D+00 DASSL RETURNED IDID = 3 LEFT SOL= 0.100D+01 -0.303D+01 RIGHT SOL= -0.100D+01 0.303D+01 U 0.100D+01 0.793D+00 0.297D+00 -0.297D+00 -0.793D+00 -0.100D+01 V -0.303D+01 -0.180D+01 -0.625D+00 0.625D+00 0.180D+01 0.303D+01 AT TIME T = 0.100D+01 DASSL RETURNED IDID = 3 LEFT SOL= 0.100D+01 -0.310D+01 RIGHT SOL= -0.100D+01 0.310D+01 U 0.100D+01 0.790D+00 0.295D+00 -0.295D+00 -0.790D+00 -0.100D+01 V -0.310D+01 -0.177D+01 -0.586D+00 0.586D+00 0.177D+01 0.310D+01 AT TIME T = 0.100D+02 DASSL RETURNED IDID = 3 LEFT SOL= 0.100D+01 -0.310D+01 RIGHT SOL= -0.100D+01 0.310D+01 U 0.100D+01 0.790D+00 0.295D+00 -0.295D+00 -0.790D+00 -0.100D+01 V -0.310D+01 -0.177D+01 -0.586D+00 0.586D+00 0.177D+01 0.310D+01 AT TIME T = 0.200D+02 DASSL RETURNED IDID = 3 LEFT SOL= 0.100D+01 -0.310D+01 RIGHT SOL= -0.100D+01 0.310D+01 U 0.100D+01 0.790D+00 0.295D+00 -0.295D+00 -0.790D+00 -0.100D+01 V -0.310D+01 -0.177D+01 -0.586D+00 0.586D+00 0.177D+01 0.310D+01 AT TIME T = 0.400D+02 DASSL RETURNED IDID = 3 LEFT SOL= 0.100D+01 -0.310D+01 RIGHT SOL= -0.100D+01 0.310D+01 U 0.100D+01 0.790D+00 0.295D+00 -0.295D+00 -0.790D+00 -0.100D+01 V -0.310D+01 -0.177D+01 -0.586D+00 0.586D+00 0.177D+01 0.310D+01 AT TIME T = 0.600D+02 DASSL RETURNED IDID = 3 LEFT SOL= 0.100D+01 -0.310D+01 RIGHT SOL= -0.100D+01 0.310D+01 U 0.100D+01 0.790D+00 0.295D+00 -0.295D+00 -0.790D+00 -0.100D+01 V -0.310D+01 -0.177D+01 -0.586D+00 0.586D+00 0.177D+01 0.310D+01 AT TIME T = 0.800D+02 DASSL RETURNED IDID = 3 LEFT SOL= 0.100D+01 -0.310D+01 RIGHT SOL= -0.100D+01 0.310D+01 U 0.100D+01 0.790D+00 0.295D+00 -0.295D+00 -0.790D+00 -0.100D+01 V -0.310D+01 -0.177D+01 -0.586D+00 0.586D+00 0.177D+01 0.310D+01 AT TIME T = 0.100D+03 DASSL RETURNED IDID = 3 LEFT SOL= 0.100D+01 -0.310D+01 RIGHT SOL= -0.100D+01 0.310D+01 U 0.100D+01 0.790D+00 0.295D+00 -0.295D+00 -0.790D+00 -0.100D+01 V -0.310D+01 -0.177D+01 -0.586D+00 0.586D+00 0.177D+01 0.310D+01 AT TIME T = 0.100D+04 DASSL RETURNED IDID = 2 LEFT SOL= 0.100D+01 -0.310D+01 RIGHT SOL= -0.100D+01 0.310D+01 U 0.100D+01 0.790D+00 0.295D+00 -0.295D+00 -0.790D+00 -0.100D+01 V -0.310D+01 -0.177D+01 -0.586D+00 0.586D+00 0.177D+01 0.310D+01 NSTEPS = 264 NRESID = 366 JAC = 201