subroutine bacol(t0, tout, atol, rtol, npde, kcol, nintmx, nint, & x, mflag, rpar, lrp, ipar, lip, y, idid) c----------------------------------------------------------------------- c Purpose: c The purpose of BACOL is to solve NPDE dimensional systems of c second order parabolic partial differential equations (PDEs) c in one space variable of the form: c c dU / \ c -- (t,x) = f | t, x, U(t,x), U (t,x), U (t,x) | , c dt \ x xx / c c where x_a < x < x_b and t > t0, with initial conditions at c time t = t0 are given by: c c u(t0,x) = u_0(x), c c for x_a <= x <= x_b, subject to separated boundary conditions c given by: c c / \ c b | t, U(t,x_a), U (t,x_a) | = 0, c x_a \ x / c c / \ c b | t, U(t,x_b), U (t,x_b) | = 0, c x_b \ x / c c for t > t0 and x = x_a, x = x_b, respectively. c c Guide to the above notation: c dU c -- (t,x) = denotes the first partial derivative of U(t,x) c dt with respect to the time variable t. c c U (t,x) = denotes the first partial derivative of U(t,x) c x with respect to space variable x. c c U (t,x) = denotes the second partial derivative of U(t,x) c xx with respect to space variable x. c c Further, the above functions NPDE dimensional vector functions. c c BACOL is a method of lines algorithm which uses bspline c collocation to discretize the spatial domain [x_a,x_b]. c The output is a vector of bspline coefficients which c can be used to calculate the approximate solution U(t,x) and c it's spatial derivatives at (tout,x) where x_a <= x <= x_b c and t0 < tout. c c----------------------------------------------------------------------- c----------------------------------------------------------------------- c Setup of BACOL: c BACOL requires that the user specifies the system of PDEs and c the related initial and boundary conditions as well as setting c input parameters (which define the bspline space and the c requested error tolerances) and allocating work storage. c c The calling sequence of BACOL is: c c call bacol(t0, tout, atol, rtol, npde, kcol, nintmx, nint, x, c & mflag, rpar, lrp, ipar, lip, y, idid) c c which will generate the vector y = Y(tout) upon successful c completion. Generally, the call to BACOL will be followed by a c call to VALUES to calculate the solution at a set of points: c c call values(kcol, xsol, nint, x, npde, npts, nderiv, c & usol, y, work) c c The details of the parameters to VALUES are documented within c the source code for that routine. The input parameters for c BACOL are dealt with in detail below, but a quick summary is: c c [t0, tout] is the time domain of the problem. c NPDE is the number of compenents in the PDE system. c atol is the absolute error tolerance. c rtol is the relative error tolerance. c kcol, nint, and x define the bspline space. c nintmx is the maximum number of subintervals allowed. c mflag(1:7) is used to control the operation of BACOL. c rpar(lrp) is a floating point work array. c ipar(lip) is an integer work array. c c The user must check idid to determine what further action needs c to be taken. c----------------------------------------------------------------------- c----------------------------------------------------------------------- c Subroutine Parameters: c Input: double precision t0 c On input, t0 < tout is the initial c time. On output, t0 is the current time, c t0 <= tout. c double precision tout c tout is the desired final output time. c c After a successful return from BACOL, c the time stepping may be resumed by c changing tout so that t0 < tout and c setting mflag(1) = 1 to indicate a c continuation of the previous problem. c integer npde c npde is the number of components in c the system of PDEs. npde > 0. c double precision atol(npde) c atol is the absolute error tolerance c request and is a scalar quantity if c mflag(2) = 0. c c If PDE components vary in importance, c then vector error tolerances may be c used by setting mflag(2) = 1. In this c case, the dimension of atol must be c npde. The user will define atol(1), c atol(2), ..., atol(npde) appropriately. c Note that a change from scalar to vector c tolerances (or vice versa) constitutes c a new problem, and BACOL will have to c be reinitialized. c double precision rtol(npde) c rtol is the relative error tolerance c request and is a scalar quantity if c mflag(2) = 0. c c If PDE components vary in importance, c then vector error tolerances may be c used by setting mflag(2) = 1. In this c case, the dimension of rtol must be c npde. The user will define rtol(1), c rtol(2), ..., rtol(npde) appropriately. c Note that a change from scalar to vector c tolerances (or vice versa) constitutes c a new problem, and BACOL will have to c be reinitialized. c integer kcol c kcol is the number of collocation points c to be used in each subinterval. c 1 < kcol <= mxkcol. c c The degree of the piecewise polynomial c is (kcol+1). c integer nint c on input, nint is the number of c subintervals defined by the spatial c mesh x at the initial time t0. c on output, nint is the number of c subintervals at tout. c nint >= 1. c integer nintmx c the maximum number of subintervals that c the user requires. c double precision x(nintmx+1) c x is the spatial mesh which divides the c interval [x_a,x_b] as: x_a = x(1) < c x(2) < x(3) < ... < x(nint+1) = x_b. c at input, x(1:nint+1) stores the mesh c points at the initial time t0. c at output, x(1:nint+1) stores the mesh c points at tout. c integer mflag(7) c This vector determines the interaction c of BACOL with DASSL. c c How to set mflag(1): c On the initial call to BACOL with a c new problem, set mflag(1) = 0, which c indicates that BACOL and DASSL should c perform the initialization steps that c are required by each code, respectively. c c In order to continue time stepping in c the current problem after a successful c return from BACOL, set mflag(1) = 1, c idid = 1, and ensure that t0 < tout. c c How to set mflag(2): c If scalar absolute and relative error c tolerances (atol and rtol) are desired, c then set mflag(2) = 0. c c For vector absolute and relative error c tolerances, set mflag(2) = 1, define c atol(1), ..., atol(npde), and c rtol(1), ..., rtol(npde), as described c above, ensuring that the dimension of c each of atol and rtol is at least npde. c c How to set mflag(3): c If there are no restrictions on t0, c then set mflag(3) = 0. c Since DASSL may actually "step over" c tout and then interpolate, there is the c option to enforce tstop >= tout. c If this is desirable, set mflag(3) = 1, c and define rpar(1) = tstop. c c How to set mflag(4): c If the user wishes, BACOL will return c the computed solution and derivative c after a certain number of accepted time c steps or at TOUT, whichever comes first. c This is a good way to proceed if the c user wants to see the behavior of the c solution. c If the user only wants the solution at c TOUT, set mflag(4) = 0; c else, set mflag(4) = 1, and assign a c positive integer for ipar(8) that c defines the number of time steps before c BACOL is stopped. c c How to set mflag(5): c If both boundary conditions are c dirichlet, set mflag(5) = 1; c else, set mflag(5) = 0. c c How to set mflag(6): c If the user wants to specify an initial c stepsize, set mflag(6) = 1, c and define rpar(2) = the c initial stepsize; c else, set mflag(6) = 0. c c How to set mflag(7): c If the user wants to use DASSL with the c BDF methods of maximum order to default c to 5, set mflag(7) = 0; c else, set mflag(7) = 1, and define c ipar(15) = the maximum order. c integer lrp c lrp is the size of the rpar storage c array and must satisfy: c lrp>=134+nintmx*(35+35*kcol+31*npde c + +38*npde*kcol+8*kcol*kcol)+14*kcol c + +79*npde+npde*npde*(21 c + +4*nintmx*kcol*kcol+12*nintmx*kcol c + +6*nintmx) c integer lip c lip is the size of the ipar integer c work array and must satisfy: c lip>=115+npde*(nintmx*(2*kcol+1)+4) c c Work Storage: double precision rpar(lrp) c rpar is a floating point work array c of size lrp. c integer ipar(lip) c ipar is an integer work array c of size lip. c c Output: double precision y(npde*(kcol*nintmx+2)) c On successful return from BACOL, c y(1:npde*(kcol*nint+2)) is c the vector of bspline coefficients at c the current time. c integer idid c idid is the BACOL exit status flag c which is based on the exit status from c DASSL plus some additional status codes c based on error checking performed by c BACOL on initialization. Positive c values of idid indicate a successful c return. Negative values of idid indicate c an error which may or may not be fatal. c The exact descriptions of idid return c values will be discussed below. c c For calls other than the first call c (mflag(1) = 1), the user must check c idid, set idid = 1 (if necessary), and c take other actions which are necessary c such as defining a new value of tout. c c An excerpt from the DASSL source code c documentation is included to define c the IDID return codes and clarify c the operation of DASSL within BACOL. c c----------------------------------------------------------------------- c The following is an excerpt from the DASSL source code documentation: c C -------- OUTPUT -- AFTER ANY RETURN FROM DASSL --------------------- 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 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 TSTOP was successfully C completed (T=TSTOP) by stepping exactly to TSTOP. 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 -- DASSL 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 -- DASSL failed to compute the initial C YPRIME. 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 C be appropriate for continuing the integration. However, C the reported solution at T was obtained using the input C values of RTOL and ATOL. 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 (mflag(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 If it has been necessary to prevent the integration from going C past a point TSTOP (mflag(3), rpar(itstop)), keep in mind that C the code will not integrate to any TOUT beyond the currently C specified TSTOP. Once TSTOP has been reached you must change C the value of TSTOP or set mflag(3)=0. You may change mflag(3) C or TSTOP at any time but you must supply the value of TSTOP in C rpar(itstop) whenever you set mflag(3)=1. C C -------- ERROR MESSAGES --------------------------------------------- C C The SLATEC error print routine XERMSG is called in the event of C unsuccessful completion of a task. Most of these are treated as C "recoverable errors", which means that (unless the user has directed C otherwise) control will be returned to the calling program for C possible action after the message has been printed. C C In the event of a negative value of IDID other than -33, an appro- C priate message is printed and the "error number" printed by XERMSG C is the value of IDID. There are quite a number of illegal input C errors that can lead to a returned value IDID=-33. The conditions C and their printed "error numbers" are as follows: C C Error number Condition C C 1 Some element of INFO vector is not zero or one. C 2 NEQ .le. 0 C 3 MAXORD not in range. C 4 LRW is less than the required length for RWORK. C 5 LIW is less than the required length for IWORK. C 6 Some element of RTOL is .lt. 0 C 7 Some element of ATOL is .lt. 0 C 8 All elements of RTOL and ATOL are zero. C 9 INFO(4)=1 and TSTOP is behind TOUT. C 10 HMAX .lt. 0.0 C 11 TOUT is behind T. C 12 INFO(8)=1 and H0=0.0 C 13 Some element of WT is .le. 0.0 C 14 TOUT is too close to T to start integration. C 15 INFO(4)=1 and TSTOP is behind T. C 16 --( Not used in this version )-- C 17 ML illegal. Either .lt. 0 or .gt. NEQ C 18 MU illegal. Either .lt. 0 or .gt. NEQ C 19 TOUT = T. c---------------------------------------------------------------------- C C If DASSL is called again without any action taken to remove the C cause of an unsuccessful return, XERMSG will be called with a fatal C error flag, which will cause unconditional termination of the C program. There are two such fatal errors: C C Error number -998: The last step was terminated with a negative C value of IDID other than -33, and no appropriate action was C taken. C C Error number -999: The previous call was terminated because of C illegal input (IDID=-33) and there is illegal input in the C present call, as well. (Suspect infinite loop.) C c----------------------------------------------------------------------- c Constants: integer nconti parameter (nconti = 2) c nconti continuity conditions are imposed c at the internal mesh points. c integer MAXORD parameter (MAXORD = 5) c MAXORD is the maximum order of the c backward differentiation formula (BDF) c methods used by DASSL. MAXORD = 5 is c the default used by DASSL. c integer mxkcol parameter (mxkcol = 10) c mxkcol is the maximum number of c collocation points per subinterval. c integer maxrsh parameter (maxrsh = 20) c maxrsh is the maximum number of c remesh times at one time step, c i.e., icount must less than or equal c to maxrsh c double precision zero parameter (zero = 0.0D0) c c----------------------------------------------------------------------- c Local variables: c integer neq1 c neq1=npde*ncpts1 is the number of c bspline coefficients (or DAEs) when c using dassl_{kcol}. c integer neq2 c neq2=neq1+npde*nint is the number of c bspline coefficients (or DAEs) when c using dassl_{kcol+1}. c integer neq c neq = neq1 + neq2. c integer leniw c leniw = 20 + neq is the length of the c integer work array required by dassl. c integer lenpd1 c lenpd1 is the size of the Almost Block c Diagonal (ABD) Jacobian required by c dassl_{kcol}. c lenpd1=npde*npde*(2*nconti c +kcol*(kcol+nconti)*nint) c integer lenpd2 c lenpd2 is the size of the Almost Block c Diagonal (ABD) Jacobian required by c dassl_{kcol+1}. c lenpd2=lenpd1+npde*npde*nint c *(2*kcol+nconti+1) c integer lenpd c lenpd = lenpd1 + lenpd2 . c integer lenrw c lenrw = 40+(MAXORD+4)*neq+lenpd c is the total size of the floating point c work array required by dassl_{kcol}. c integer lenin1 c lenin1 is the size of the floating c point work array used by INIY and INIYP c when using dassl_{kcol}. c lenin1>=lenpd1+2*neq1+npde*2+2*npde*npde c integer lenin2 c lenin2 is the size of the floating c point work array used by INIY and INIYP c when using dassl_{kcol+1}. c lenin2>=lenpd2+2*neq2+npde*2+2*npde*npde c integer lenri1 c lenri1 is the size of the floating c point work array used by REINIT when c using dassl_{kcol}. c integer lenri2 c lenri2 is the size of the floating c point work array used by REINIT when c using dassl_{kcol+1}. c integer lenrj c lenrj is the size of the floating c point work array used by RES and JAC. c lenrj>=4*npde+5*npde*npde. c integer lenerr c lenerr is the size of the floating point c work array used by ERREST. c lenerr>=2*npde*necpts+npde*nint. c integer ncpts1 c ncpts1=(kcol*nint+nconti) is the total c number of collocation points when using c dassl_{kcol}. c integer ncpts2 c ncpts2=ncpts1+nint is the total number c of collocation points when using c dassl_{kcol+1}. c integer necpts c necpts=(kcol+3)*nint is the total number c of collocation points used for c error estimate. c integer icflag c This is the status flag from the almost c block diagnonal factorization routine, c CRDCMP. c icflag = 0, indicates non-singularity. c icflag = -1, indicates singularity. c icflag = 1, indicates invalid input. c integer ieflag c ieflag is a status flag for remesh. c ieflag = 0, indicates no need remeshing. c ieflag = 1, indicates need remeshing. c double precision errrat c errrat is the value of the largest c component of rpar(ipar(iercom)). c double precision torign c torign is the initial time, i.e. = t0 c at the beginning. c integer istart c istart is a flag to begin the code. c istart = 0, it is the initial step; c = 1, it is not the initial step. c integer icount c icount is the number of remeshing times c at the current step. c integer isstep c isstep is the number of accepted time c steps since we restart BACOL in the c case that mflag(4) = 1. c integer ninold c ninold is the number of subintervals c before the current remeshing. c integer ninpre c ninpre is the number of subintervals c when icount = 0 before remeshing. c integer irshfg c irshfg is a flag for redefining all the c pointers. c irshfg = 0, initial step or any step c without needing remesh; c = 1, remesh with a hot start. c = 2, remesh with a cold start. c integer neqpre c neqpre is the number of bspline c coefficients when icount = 0 before c remeshing when using dassl_{kcol+1}. c integer irold c irold is the value of ipar(ixold) before c remeshing. c integer nstep c nstep is the number of steps which are c necessary for a remesh. c c----------------------------------------------------------------------- c Loop indices: integer i, ii, jj, kk c c----------------------------------------------------------------------- c Direct pointers into the RPAR floating point work array: integer itstop parameter (itstop = 1) c rpar(itstop) = tstop as defined when c mflag(3) = 1. c integer iiniss parameter (iiniss = 2) c rpar(iiniss) = the initial stepsize when c mflag(6) = 1. c integer irpstr parameter (irpstr = 11) c rpar(1:irpstr-1) are reserved to store c floating point scalar quantities. c c----------------------------------------------------------------------- c Direct pointers into the IPAR integer work array: integer inpde parameter (inpde = 1) c ipar(inpde) = npde c integer ikcol parameter (ikcol = 2) c ipar(ikcol) = kcol. c integer inint parameter (inint = 3) c ipar(inint) = nint. c integer incpt1 parameter (incpt1 = 4) c ipar(incpt1) = ncpts1. c integer ineq1 parameter (ineq1 = 5) c ipar(ineq1) = neq1. c integer iipstp parameter (iipstp = 6) c ipar(iipstp) = the minimum size of ipar. c integer irpstp parameter (irpstp = 7) c ipar(irpstp) = the minimum size of rpar. c integer iinstp parameter (iinstp = 8) c As input, ipar(iinstp) is the number of c intermediate time steps before the user c asks BACOL to return the computed c solution. c As output, ipar(iinstp) will keep the c same value unless TOUT is reached before c ipar(iinstp) time steps. If TOUT is c reached, ipar(iinstp) will be the number c of time steps before TOUT is reached. c See mflag(4) for more details. c integer irshin parameter (irshin = 9) c ipar(irshin) is the number of remeshing c times at the initial step. c integer isteps parameter (isteps = 10) c ipar(isteps) is the number of time steps c on the current problem. c integer irmesh parameter (irmesh = 11) c ipar(irmesh) is the number of remeshing c times after BACOL starts the initial c step. c integer istalr parameter (istalr = 12) c ipar(istalr) is the number of accepted c steps after the last successful c remeshing. c integer istblc parameter (istblc = 13) c ipar(istblc) is the number of steps c BACOL has taken before the latest cold c start. c integer icolds parameter (icolds = 14) c ipar(icolds) is the number of the times c when BACOL performs a cold start after c remeshing. c integer imxord parameter (imxord = 15) c ipar(imxord) is the maximum order for c the BDF methods employed in DASSL. c The default value is 5. c integer idasi parameter (idasi = 61) c ipar(idasi) stores, before remeshing, c the first 20 elements of the integer c point work array in dassl. c integer iinfo parameter (iinfo = 81) c ipar(iinfo) is an integer array c required by dassl_{kcol}. c ipar(iinfo) = mflag(1), c ipar(iinfo+1) = mflag(2), c ipar(iinfo+3) = mflag(3), c ipar(iinfo+7) = mflag(6). c ipar(iinfo+8) = mflag(7). c (See the documentation of DDASSL for c details.) c integer iiwork parameter (iiwork = 96) c ipar(iiwork) is the integer work array c for dassl. c integer ipivot parameter (ipivot = 116) c ipar(ipivot-1+i), i = 1, neq, contains c the pivoting information from the c factorization of the temporary matrix c for dassl. c c----------------------------------------------------------------------- c Indirect pointers into the RPAR floating point work array: integer ih parameter (ih = 21) c rpar(ipar(ih)) stores the mesh step c size sequence. c integer ixcol1 parameter (ixcol1 = 22) c rpar(ipar(ixcol1)) stores the c collocation points when using c dassl_{kcol}. c integer ixbs1 parameter (ixbs1 = 23) c rpar(ipar(ixbs1)) stores the breakpoint c sequence when using dassl_{kcol}. c integer iy1 parameter (iy1 = 24) c rpar(ipar(iy1)) stores the vector of c solution components to the DAE system c when using dassl_{kcol}. c integer iyp1 parameter (iyp1 = 25) c rpar(ipar(iyp1)) stores the vector of c solution component derivatives of the c DAE system when using dassl_{kcol}. c integer iabtp1 parameter (iabtp1 = 26) c rpar(ipar(iabtp1)) stores the top block c of the ABD collocation matrices when c using dassl_{kcol}. c integer iabbk1 parameter (iabbk1 = 27) c rpar(ipar(iabbk1)) stores the nint c blocks in the middle of the ABD c collocation matrices when using c dassl_{kcol}. c integer iabbt1 parameter (iabbt1 = 28) c rpar(ipar(iabbt1)) stores the bottom c block of the ABD collocation matrices c when using dassl_{kcol}. c integer irwork parameter (irwork = 29) c rpar(ipar(irwork)) stores the floating c point work array for DASSL. And it c is also used to be a work storage for c the subroutine INIY and INIYP to get c the initial condition. c integer iwkrj parameter (iwkrj = 30) c rpar(ipar(iwkrj)) stores an additional c work array required by RES and JAC. c integer ibasi1 parameter (ibasi1 = 31) c rpar(ipar(ibasi1)) stores the basis c function values at the collocation c points when using dassl_{kcol}. c rpar(ipar(ibasi1)) contains c a three dimensional array A of size c (kcol+nconti,3,ncpts1). A(k,j,i) stores c the values of the (j-1)st derivative c (j=1,2,3) of the k-th non-zero basis c function (k=1,...,kcol+nconti) at the c i-th collocation point. c integer itatol parameter (itatol = 32) c rpar(ipar(itatol)) is the absolute error c tolerance request on the integration c error. c integer itrtol parameter (itrtol = 33) c rpar(ipar(itrtol)) is the relative error c tolerance request on the integration c error. c integer iexcol parameter (iexcol = 34) c rpar(ipar(iexcol)) stores the c collocation points which are used for c error estimate. c integer iewts parameter (iewts = 35) c rpar(ipar(iewts)) stores the gaussian c weights which are used for error c estimate. c integer iebas1 parameter (iebas1 = 36) c rpar(ipar(iebas1)) stores the values c of the nonzero basis functions at c rpar(ipar(iexcol)) when using c dassl_{kcol}. c integer iebas2 parameter (iebas2 = 37) c rpar(ipar(iebas2)) stores the values c of the nonzero basis functions at c rpar(ipar(iexcol)) when using c dassl_{kcol+1}. c integer iercom parameter (iercom = 38) c rpar(ipar(iercom)) stores the error c estimate for each component. c integer ierint parameter (ierint = 39) c rpar(ipar(ierint)) stores the error c estimate at each subinterval. c integer iework parameter (iework = 40) c rpar(ipar(iework)) stores the floating c point work array for errest. c integer ixcol2 parameter (ixcol2 = 41) c rpar(ipar(ixcol2)) stores the c collocation points when using c dassl_{kcol+1}. c integer ixbs2 parameter (ixbs2 = 42) c rpar(ipar(ixbs2)) stores the breakpoint c sequence when using dassl_{kcol+1}. c integer iy2 parameter (iy2 = 43) c rpar(ipar(iy2)) stores the vector of c solution components to the DAE system c when using dassl_{kcol+1}. c integer iyp2 parameter (iyp2 = 44) c rpar(ipar(iyp2)) stores the vector of c solution component derivatives of the c DAE system when using dassl_{kcol+1}. c integer iabtp2 parameter (iabtp2 = 45) c rpar(ipar(iabtp2)) stores the top block c of the ABD collocation matrices when c using dassl_{kcol+1}. c integer iabbk2 parameter (iabbk2 = 46) c rpar(ipar(iabbk2)) stores the nint c blocks in the middle of the ABD c collocation matrices when using c dassl_{kcol+1}. c integer iabbt2 parameter (iabbt2 = 47) c rpar(ipar(iabbt2)) stores the bottom c block of the ABD collocation matrices c when using dassl_{kcol+1}. c integer ibasi2 parameter (ibasi2 = 48) c rpar(ipar(ibasi2)) stores the basis c function values at the collocation c points when using dassl_{kcol+1}. c rpar(ipar(ibasi2)) contains c a three dimensional array A of size c (kcol+1+nconti,3,ncpts2). A(k,j,i) c stores the values of the (j-1)st c derivative (j=1,2,3) of the k-th c non-zero basis function (k=1,..., c kcol+1+nconti) at the i-th collocation c point. c integer iwkdnm parameter (iwkdnm = 49) c rpar(ipar(iwkdnm)) is the work storage c for the modification version of the c subroutine DDANRM. c integer ixold parameter (ixold = 51) c rpar(ipar(ixold)) stores the mesh point c sequence when icount = 0 before c remeshing. c integer idasr parameter (idasr = 52) c rpar(ipar(idasr)) stores, before c remeshing, the first 40 elements of the c floating point work array in dassl. c integer iypre parameter (iypre = 53) c rpar(ipar(iypre)) stores the values of c rpar(ipar(iy2)) at the previous 6 steps. c It is required for a hot restart after c remeshing. c integer iyprer parameter (iyprer = 54) c rpar(ipar(iyprer)) stores the c information of at the previous steps c after remeshing. c integer iey1 parameter (iey1 = 55) c rpar(ipar(iey1)) stores the bspline c coefficients for dassl_{kcol} at the c farthest point integration has reached. c integer iey2 parameter (iey2 = 56) c rpar(ipar(iey2)) stores the bspline c coefficients for dassl_{kcol+1} at the c farthest point integration has reached. c c----------------------------------------------------------------------- c Subroutines Called: c colpnt c ddassl c divdif c errest c iniy c iniyp c meshsq c reinit c remesh c sucstp external jac external res c c----------------------------------------------------------------------- c BLAS Subroutines Called: c dcopy c c----------------------------------------------------------------------- c c Last modified by Rong Wang, July 8, 2004. c c----------------------------------------------------------------------- c Check validity of the mflag vector. do 1 i = 1, 7 if ((mflag(i) .lt. 0) .or. (mflag(i) .gt. 1)) goto 710 1 continue if (mflag(4) .eq. 1) then isstep = 0 if (ipar(iinstp) .le. 0) goto 715 endif irshfg = 0 istart = 0 icount = 0 torign = t0 c Check for continuation of a previous problem. if (mflag(1) .eq. 1) then istart = 1 neq1 = ipar(ineq1) neq2 = neq1 + npde * nint neq = neq1 + neq2 lenpd1 = npde*npde*(nconti+nconti+kcol*(kcol+nconti)*nint) lenpd = lenpd1+lenpd1+npde*npde*nint*(kcol+kcol+nconti+1) leniw = 20 + neq lenrw = 40 + (MAXORD + 4) * neq + lenpd goto 200 else c Check if the user specifies an initial stepsize if (mflag(6) .eq. 1) then if (((tout-t0)*rpar(iiniss)) .lt. zero) goto 720 if (rpar(iiniss) .eq. zero) goto 725 endif ipar(irmesh) = 0 ipar(irshin) = 0 ipar(istalr) = 0 ipar(istblc) = 0 ipar(icolds) = 0 endif c----------------------------------------------------------------------- c On the initial call or after remeshing, check for valid input and c initialize the workspace. c----------------------------------------------------------------------- 100 continue c Check validity of npde, kcol, and nint. if (npde .le. 0) goto 730 if ((kcol .le. 1) .or. (kcol .gt. mxkcol)) goto 740 if ((nint .le. 0) .or. (nint .gt. nintmx)) goto 640 c Check for a monotone mesh. do 110 i = 1, nint if (x(i) .ge. x(i+1)) goto 760 110 continue c----------------------------------------------------------------------- c Calculate the extra storage requirements of res and jac. lenrj = (4 + 5 * npde) * npde c Calculate the number of collocation points when using c dassl_{kcol}. ncpts1 = nint * kcol + nconti c Calculate the number of DAEs when using dassl_{kcol}. neq1 = npde * ncpts1 c Size of the ABD iteration matrix when using dassl_{kcol}. lenpd1 = npde*npde*(nconti+nconti+kcol*(kcol+nconti)*nint) c Calculate the extra storage requirements of iniy and iniyp when c using dassl_{kcol}. lenin1 = lenpd1 + 2 * neq1 + 2 * npde * (1 + npde) c----------------------------------------------------------------------- c Calculate the number of collocation points when using c dassl_{kcol+1}. ncpts2 = ncpts1 + nint c Calculate the number of DAEs when using dassl_{kcol+1}. neq2 = neq1 + npde * nint c Size of the ABD iteration matrix when using dassl_{kcol+1}. lenpd2 = lenpd1 + npde * npde * nint * (kcol + kcol + nconti + 1) c Calculate the extra storage requirements of iniy and iniyp when c using dassl_{kcol+1}. lenin2 = lenpd2 + 2 * neq2 + 2 * npde * (1 + npde) c----------------------------------------------------------------------- c Calculate the total number of variables given to dassl. neq = neq1 + neq2 c Size of the total iteration matrix in dassl. lenpd = lenpd1 + lenpd2 c Total size of the DASSL floating point work array. lenrw = 40 + (MAXORD + 4) * neq + lenpd c Total size of the DASSL integer work array. leniw = 20 + neq c----------------------------------------------------------------------- c Calculate the number of collocation point used for error estimate. necpts = (kcol + 3) * nint c Calculate the extra storage requirements of errest. lenerr = (2 * necpts + nint) * npde c----------------------------------------------------------------------- c Save the input parameters in the ipar integer communication c storage array. ipar(inpde) = npde ipar(ikcol) = kcol ipar(inint) = nint ipar(incpt1) = ncpts1 ipar(ineq1) = neq1 c----------------------------------------------------------------------- c Calculate the offsets into the rpar floating point storage array. c----------------------------------------------------------------------- ipar(itatol) = irpstr ipar(itrtol) = ipar(itatol) + npde ipar(ih) = ipar(itrtol) + npde ipar(iy1) = ipar(ih) + nint ipar(iy2) = ipar(iy1) + neq1 ipar(iyp1) = ipar(iy2) + neq2 ipar(iyp2) = ipar(iyp1) + neq1 ipar(ixcol1) = ipar(iyp2) + neq2 ipar(ixbs1) = ipar(ixcol1) + ncpts1 ipar(iabtp1) = ipar(ixbs1) + ncpts1 + kcol + nconti ipar(iabbk1) = ipar(iabtp1) + npde * npde * nconti ipar(iabbt1) = ipar(iabbk1) + npde * npde * nint * kcol & * (kcol + nconti) ipar(ibasi1) = ipar(iabbt1) + npde * npde * nconti ipar(irwork) = ipar(ibasi1) + (kcol + nconti) * 3 * ncpts1 ipar(iwkrj) = ipar(irwork) + lenrw ipar(iexcol) = ipar(iwkrj) + lenrj ipar(iewts) = ipar(iexcol) + necpts ipar(ierint) = ipar(iewts) + necpts ipar(iercom) = ipar(ierint) + nint ipar(iebas1) = ipar(iercom) + npde ipar(iebas2) = ipar(iebas1) + (kcol + nconti) * necpts ipar(iework) = ipar(iebas2) + (kcol + 1 + nconti) * necpts ipar(ixcol2) = ipar(iework) + lenerr ipar(ixbs2) = ipar(ixcol2) + ncpts2 ipar(iabtp2) = ipar(ixbs2) + ncpts2 + kcol + 1 + nconti ipar(iabbk2) = ipar(iabtp2) + npde * npde * nconti ipar(iabbt2) = ipar(iabbk2) + npde * npde * nint * (kcol+1) & * (kcol + 1 + nconti) ipar(ibasi2) = ipar(iabbt2) + npde * npde * nconti ipar(iwkdnm) = ipar(ibasi2) + (kcol + 1 + nconti) * 3 * ncpts2 ipar(iyprer) = ipar(iwkdnm) + neq ipar(ixold) = ipar(iyprer) + 6 * neq2 ipar(idasr) = ipar(ixold) + nintmx + 1 ipar(iypre) = ipar(idasr) + 40 ipar(iey1) = ipar(irwork) + 40 + 3 * neq ipar(iey2) = ipar(iey1) + neq1 c The offset is different between the initial call and remeshing. if ((irshfg .ne. 0) .and. (istart .eq. 1)) then ipar(irpstp) = ipar(iypre) + 6 * neqpre - 1 else ipar(irpstp) = ipar(iypre) + 6 * neq2 - 1 endif c Check for a sufficiently large rpar floating point work array. if (lrp .lt. ipar(irpstp)) goto 770 c Calculate the offsets into the integer storage array. ipar(iipstp) = ipivot + neq - 1 c Check for a sufficiently large ipar integer work array. if (lip .lt. ipar(iipstp)) goto 780 c Check whether it is initial call or for remeshing. if ((irshfg .ne. 0) .and. (istart .ne. 0)) goto 300 c----------------------------------------------------------------------- c Perform initializations for using dassl_{kcol}. c----------------------------------------------------------------------- c Check whether it is initial call or for remeshing. if (irshfg .eq. 0) then c Set the info vector required by DASSL. ipar(iinfo) = mflag(1) ipar(iinfo+1) = mflag(2) ipar(iinfo+2) = 1 ipar(iinfo+3) = mflag(3) do 120 i = 6, 14 ipar(iinfo+i-1) = 0 120 continue ipar(iinfo+8) = mflag(7) c Indicate whether an user-supplied initial stepsize is used. ipar(iinfo+7) = mflag(6) c Indicate an analytic user supplied Jacobian (iteration) matrix. ipar(iinfo+4) = 1 c Indicate an ABD Jacobian (Iteration) matrix. ipar(iinfo+14) = 1 else ipar(irshin) = ipar(irshin) + 1 endif call meshsq(kcol, nint, x, rpar(ipar(irwork)), rpar(ipar(ih)), & rpar(ipar(iexcol)), rpar(ipar(iewts))) call colpnt(kcol, nint, ncpts1, x, rpar(ipar(ih)), & rpar(ipar(irwork)), rpar(ipar(ixcol1)), & rpar(ipar(ixbs1))) icflag = 0 call iniy(t0, npde, kcol, nint, neq1, ncpts1, mflag(5), & rpar(ipar(ixcol1)), rpar(ipar(ixbs1)), & rpar(ipar(iabbk1)), rpar(ipar(ibasi1)), rpar(ipar(iy1)), & ipar(ipivot), rpar(ipar(irwork)), lenin1, icflag) if (icflag .ne. 0) then idid = -66 goto 620 endif call iniyp(t0, npde, kcol, nint, neq1, ncpts1, & rpar(ipar(ixcol1)), rpar(ipar(iabtp1)), & rpar(ipar(iabbk1)), rpar(ipar(iabbt1)), & rpar(ipar(ibasi1)), rpar(ipar(iy1)), rpar(ipar(iyp1)), & ipar(ipivot), rpar(ipar(irwork)), lenin1, icflag) if (icflag .ne. 0) then idid = -66 goto 620 endif irshfg = 0 c Set the parameters defining the ABD Jacobian (iteration) matrix. c This is inside the integer work array of dassl. Those parameter c include npde, kcol, nint. ipar(iiwork-1+17) = npde ipar(iiwork-1+18) = kcol ipar(iiwork-1+19) = nint c Set initial idid to be zero. idid = 0 c----------------------------------------------------------------------- c Perform initializations for using dassl_{kcol+1}. c----------------------------------------------------------------------- c Copy rtol and atol to be the relative and absolute error request c for the integration error. if (irshfg .eq. 0) then if (mflag(2) .eq. 0) then rpar(ipar(itatol)) = atol(1) rpar(ipar(itrtol)) = rtol(1) else do 130 i = 1, npde rpar(ipar(itatol)-1+i) = atol(i) 130 continue do 140 i = 1, npde rpar(ipar(itrtol)-1+i) = rtol(i) 140 continue endif endif call colpnt(kcol+1, nint, ncpts2, x, rpar(ipar(ih)), & rpar(ipar(irwork)), rpar(ipar(ixcol2)), & rpar(ipar(ixbs2))) icflag = 0 call iniy(t0, npde, kcol+1, nint, neq2, ncpts2, mflag(5), & rpar(ipar(ixcol2)), rpar(ipar(ixbs2)), & rpar(ipar(iabbk2)), rpar(ipar(ibasi2)), & rpar(ipar(iy2)), ipar(ipivot), & rpar(ipar(irwork)), lenin2, icflag) if (icflag .ne. 0) then idid = -66 goto 620 endif call iniyp(t0, npde, kcol+1, nint, neq2, ncpts2, & rpar(ipar(ixcol2)), rpar(ipar(iabtp2)), & rpar(ipar(iabbk2)), rpar(ipar(iabbt2)), & rpar(ipar(ibasi2)), rpar(ipar(iy2)), rpar(ipar(iyp2)), & ipar(ipivot), rpar(ipar(irwork)), lenin2, icflag) if (icflag .ne. 0) then idid = -66 goto 620 endif c Copy rpar(ipar(iy2)) to rpar(ipar(iypre)). call dcopy(neq2, rpar(ipar(iy2)), 1, rpar(ipar(iypre)), 1) if (mflag(3) .eq. 1) then rpar(ipar(irwork)) = rpar(itstop) endif c Set the initial stepsize if applicable. if (mflag(6) .eq. 1) rpar(ipar(irwork)+2) = rpar(iiniss) c Set the maximum BDF order for DASSL if applicable. if (mflag(7) .eq. 1) ipar(iiwork-1+3) = ipar(imxord) goto 400 c----------------------------------------------------------------------- c When an adaptive mesh is used, this is not the first call for c the problem, and integration is to continue. c----------------------------------------------------------------------- 200 continue c Examine idid to determine if DASSL can be called again. if (idid .ne. 1) goto 790 c If t0 must not go beyond tstop in the time stepping, then update c the DASSL floating point work array with the value of tstop. if (mflag(3) .eq. 1) then rpar(ipar(irwork)) = rpar(itstop) rpar(ipar(idasr)) = rpar(itstop) endif c Reset t0. If necessary, update rpar(ipar(iy1)), rpar(ipar(iyp1)), c rpar(ipar(iy2)) and rpar(ipar(iyp2)). if (rpar(ipar(irwork)-1+4) .lt. tout) then t0 = rpar(ipar(irwork)-1+4) goto 400 else t0 = tout call ddatrp(rpar(ipar(irwork)-1+4), tout, rpar(ipar(iy1)), & rpar(ipar(iyp1)), neq, ipar(iiwork-1+8), & rpar(ipar(irwork)+40+3*neq), & rpar(ipar(irwork)-1+29)) idid = 3 goto 500 endif c----------------------------------------------------------------------- c Initialization after remeshing. c----------------------------------------------------------------------- 300 continue ipar(irmesh) = ipar(irmesh) + 1 do 310 i = 1, 20 ipar(iiwork-1+i) = ipar(idasi-1+i) 310 continue c Tell DASSL to calculate the new iteration matrix and reset the c size of the iteration matrix. ipar(iiwork-1+5) = -1 ipar(iiwork-1+16) = lenpd c Reset the ABD information in DASSL. ipar(iiwork-1+19) = nint if (nint .lt. ninold) then call dcopy(nintmx+1+40+6*neqpre, rpar(irold), & 1, rpar(ipar(ixold)), 1) else if (nint .gt. ninold) then call dcopy(nintmx+1+40+6*neqpre, rpar(irold), & -1, rpar(ipar(ixold)), -1) endif endif c Reset the first 40 elements of the floating point work array in c DASSL. call dcopy(40, rpar(ipar(idasr)), 1, rpar(ipar(irwork)), 1) lenri1 = lenpd1 + kcol + 1 + nconti + (kcol + 1) * (ninpre + 1) & + 2 * nconti lenri2 = lenpd2 + kcol + 1 + nconti + (kcol + 1) * (ninpre + 1) & + 2 * nconti call meshsq(kcol, nint, x, rpar(ipar(irwork)+40), rpar(ipar(ih)), & rpar(ipar(iexcol)), rpar(ipar(iewts))) if (irshfg .ne. 2) then nstep = ipar(idasi-1+8) + 1 else nstep = 1 endif call reinit(npde, kcol, kcol+1, nint, ninpre, ncpts1, neq1, & neqpre, icount, ipar(idasi-1+11), nstep, x, & rpar(ipar(ixold)), rpar(ipar(iypre)), 0, & rpar(ipar(irwork)+40+6*neq1), lenri1, ipar(ipivot), & rpar(ipar(ih)), rpar(ipar(ixbs1)), rpar(ipar(ixcol1)), & rpar(ipar(ibasi1)), rpar(ipar(irwork)+40), & rpar(ipar(iabbk1)), icflag) if (icflag .ne. 0) then idid = -66 goto 630 endif c cold start. if (irshfg .eq. 2) then call dcopy(neq1, rpar(ipar(irwork)+40), 1, rpar(ipar(iy1)), 1) call iniyp(t0, npde, kcol, nint, neq1, ncpts1, & rpar(ipar(ixcol1)), rpar(ipar(iabtp1)), & rpar(ipar(iabbk1)), rpar(ipar(iabbt1)), & rpar(ipar(ibasi1)), rpar(ipar(iy1)), & rpar(ipar(iyp1)), ipar(ipivot), & rpar(ipar(irwork)), lenin1, icflag) goto 320 endif call divdif(neq1, ipar(idasi-1+8)+1, rpar(ipar(idasr)-1+29), & rpar(ipar(iework)), rpar(ipar(irwork)+40)) 320 continue call reinit(npde, kcol+1, kcol+1, nint, ninpre, ncpts2, & neq2, neqpre, icount, ipar(idasi-1+11), & nstep, x, rpar(ipar(ixold)), rpar(ipar(iypre)), 1, & rpar(ipar(irwork)+40+6*neq), lenri2, & ipar(ipivot), rpar(ipar(ih)), rpar(ipar(ixbs2)), & rpar(ipar(ixcol2)), rpar(ipar(ibasi2)), & rpar(ipar(irwork)+40+6*neq1), rpar(ipar(iabbk2)), & icflag) if (icflag .ne. 0) then idid = -66 goto 630 endif c cold start. if (irshfg .eq. 2) then call dcopy(neq2, rpar(ipar(irwork)+40+6*neq1), 1, & rpar(ipar(iy2)), 1) call iniyp(t0, npde, kcol+1, nint, neq2, ncpts2, & rpar(ipar(ixcol2)), rpar(ipar(iabtp2)), & rpar(ipar(iabbk2)), rpar(ipar(iabbt2)), & rpar(ipar(ibasi2)), rpar(ipar(iy2)), & rpar(ipar(iyp2)), ipar(ipivot), & rpar(ipar(irwork)), lenin2, icflag) if (icflag .ne. 0) then idid = -66 goto 630 endif goto 400 endif call dcopy(ipar(idasi-1+8)*neq2, rpar(ipar(irwork)+40+6*neq1), & 1, rpar(ipar(iyprer)), 1) call divdif(neq2, ipar(idasi-1+8)+1, rpar(ipar(idasr)-1+29), & rpar(ipar(iework)), rpar(ipar(irwork)+40+6*neq1)) ii = ipar(irwork) + 40 jj = ii + 3 * neq kk = ii + 6 * neq1 do 330 i = ipar(iiwork-1+8)+1, 1, -1 call dcopy(neq2, rpar(kk+(i-1)*neq2), -1, & rpar(jj+(i-1)*neq+neq1), -1) call dcopy(neq1, rpar(ii+(i-1)*neq1), -1, rpar(jj+(i-1)*neq), & -1) 330 continue c----------------------------------------------------------------------- c Time integration loop for DASSL. c----------------------------------------------------------------------- 400 continue call ddassl(res, neq, t0, rpar(ipar(iy1)), rpar(ipar(iyp1)), & tout, ipar(iinfo), rpar(ipar(itrtol)), & rpar(ipar(itatol)), idid, rpar(ipar(irwork)), lenrw, & ipar(iiwork), leniw, rpar, ipar, jac) c----------------------------------------------------------------------- c Check for a successful time step and decide whether to continue c integration or to perform a remeshing. c----------------------------------------------------------------------- if (idid .le. 0) goto 600 call errest(kcol, nint, npde, neq1, neq2, necpts, icount, & rpar(ipar(iexcol)), rpar(ipar(iewts)), & rpar(ipar(ixbs1)), rpar(ipar(ixbs2)), & rpar(ipar(iey1)), rpar(ipar(iey2)), istart, mflag(2), & atol, rtol, lenerr, rpar(ipar(iework)), & rpar(ipar(iebas1)), rpar(ipar(iebas2)), & errrat, rpar(ipar(ierint)), rpar(ipar(iercom)), & ieflag) if (ieflag .eq. 0) then c The current step is accepted. if (icount .ne. 0) then ipar(istalr) = 1 ipar(irpstp) = ipar(iypre) + 6 * neq2 - 1 c Check for a sufficiently large rpar floating point c work array. if (lrp .lt. ipar(irpstp)) goto 770 else ipar(istalr) = ipar(istalr) + 1 endif c Update the backup information. call sucstp(ipar(iiwork-1+11), ipar(iiwork-1+8)+1, icount, & neq2, ipar(iiwork), rpar(ipar(irwork)), & rpar(ipar(iey2)), rpar(ipar(iyprer)), ipar(idasi), & rpar(ipar(idasr)), rpar(ipar(iypre))) icount = 0 istart = 1 irshfg = 0 c Check whether the integration is done or not. if (mflag(4) .eq. 0) then if (t0 .lt. tout) then goto 400 else goto 500 endif else isstep = isstep + 1 if ((t0 .lt. tout) .and. (isstep .lt. ipar(iinstp))) then goto 400 else goto 500 endif endif else c The current step is rejected. if (icount .eq. maxrsh) goto 610 c For the first remeshing at the current step, save nintpre and c neqpre at the last successful step. if (icount .eq. 0) then ninpre = nint neqpre = neq2 endif ninold = nint irold = ipar(ixold) call remesh(istart, icount, nintmx, ninpre, ninold, & errrat, rpar(ipar(ierint)), irshfg, & rpar(ipar(ixold)), nint, kcol, x, & rpar(ipar(iework))) c print *, 'remesh here', ', nint now is ', nint if (istart .eq. 1) then c This is not the initial step. t0 = rpar(ipar(idasr)-1+4) c In the first step after a remeshing, we do not allow DASSL c to increase the step size. if (rpar(ipar(idasr)-1+3) .gt. rpar(ipar(idasr)-1+7)) then rpar(ipar(idasr)-1+3) = rpar(ipar(idasr)-1+7) endif c In the first step after a remeshing, we do not allow DASSL c to increase the order of BDF method. if (ipar(idasi-1+7) .gt. ipar(idasi-1+8)) then ipar(idasi-1+7) = ipar(idasi-1+8) endif if (irshfg .eq. 2) then c This is a cold start ipar(istblc) = ipar(istblc) + ipar(idasi-1+11) ipar(icolds) = ipar(icolds) + 1 ipar(iinfo) = 0 endif else c This is the initial step. t0 = torign ipar(iinfo) = 0 endif c print *, 't0 = ', t0, ' nint = ', nint c print *, 'istep = ', ipar(irmesh) c print *, (x(i),i=1,nint+1) goto 100 endif c----------------------------------------------------------------------- c Successful return section. c----------------------------------------------------------------------- 500 continue c Retrieve the value of mflag(1). mflag(1) = ipar(iinfo) c Retrieve the output vector y from the rpar communication array. do 510 i = 1, neq1 y(i) = rpar(ipar(iy1)-1+i) 510 continue c Retrieve information on the time stepping from the ipar array. ipar(isteps) = ipar(istblc) + ipar(iiwork-1+11) c Retrieve the value of ipar(iinstp) when mflag(4) = 1. if (mflag(4) .eq. 1) ipar(iinstp) = isstep return c----------------------------------------------------------------------- c Unsuccessful return section. c----------------------------------------------------------------------- 600 continue write(6,9999) 'ERROR: BACOL runtime error in time stepping.' write(6,9999) ' An error code and message should have' write(6,9999) ' been issued by DASSL.' return 610 continue if (istart .eq. 1) then write(6,9998) 'ERROR: BACOL has remeshed ', maxrsh, ' times at' & , ' t0 =', rpar(ipar(idasr)-1+4) else write(6,9998) 'ERROR: BACOL has remeshed ', maxrsh, ' times at' & , ' t0 =', torign endif idid = -41 return 620 continue write(6,9999) 'ERROR: A singular matrix arises at the initial' write(6,9999) ' step. ' idid = -42 return 630 continue write(6,9999) 'ERROR: A singular matrix arises during remeshing' write(6,9997) ' at t0 =', rpar(ipar(idasr)-1+4) idid = -43 return 640 continue if (istart .eq. 1) then write(6,9998) 'ERROR: nint >', nintmx, ' at' & , ' t0 =', rpar(ipar(idasr)-1+4) else write(6,9998) 'ERROR: nint >', nintmx, ' at' & , ' t0 =', torign endif idid = -44 return c----------------------------------------------------------------------- c The following section is the return point for invalid input. c----------------------------------------------------------------------- 710 continue write(6,9999) 'ERROR: BACOL input violation.' write(6,9999) 'Require: 0 <= mflag(i) <= 1, i = 1, 2, ..., 6.' idid = -51 return 715 continue write(6,9999) 'ERROR: BACOL input violation.' write(6,9999) 'Require: if mflag(4) = 1, ipar(8) must be set to' write(6,9999) 'be a positive integer.' idid = -52 return 720 continue write(6,9999) 'ERROR: BACOL input violation.' write(6,9999) 'Require: if mflag(6) = 1, tout must be in front' write(6,9999) 'of t0.' idid = -53 return 725 continue write(6,9999) 'ERROR: BACOL input violation.' write(6,9999) 'Require: if mflag(6) = 1, rpar(2) must be the' write(6,9999) 'initial stepsize, thus nonzero.' idid = -54 return 730 continue write(6,9999) 'ERROR: BACOL input violation.' write(6,9999) 'Require: npde > 0.' idid = -55 return 740 continue write(6,9999) 'ERROR: BACOL input violation.' write(6,9999) 'Require: 1 < kcol <=', mxkcol, '.' idid = -56 return 760 continue write(6,9999) 'ERROR: BACOL input violation.' write(6,9999) 'Require: x(1) < x(2) < ... < x(nint+1).' idid = -58 return 770 continue write(6,9999) 'ERROR: BACOL input violation.' write(6,9999) 'Require: lrp >= ', ipar(irpstp), '.' idid = -59 return 780 continue write(6,9999) 'ERROR: BACOL input violation.' write(6,9999) 'Require: lip >= ', ipar(iipstp), '.' idid = -60 return 790 continue write(6,9999) 'ERROR: BACOL input violation.' write(6,9999) 'IDID .ne. 1, on a continuation call of BACOL' write(6,9999) 'If IDID > 1, set idid = 1 and tout (t0 < tout)' write(6,9999) 'If IDID < -1, the code cannot be continued due to' write(6,9999) ' a previous error.' idid = -61 return c----------------------------------------------------------------------- 9997 format(a,e12.5) 9998 format(a,i4,a,a,e12.5) 9999 format(a,i10,a,i4,a,i4,a,i4,a,i4) c----------------------------------------------------------------------- end SUBROUTINE BSPLVD ( XT, K, X, ILEFT, VNIKX, NDERIV ) C----------------------------------------------------------------------- C THIS SUBROUTINE IS PART OF THE B-SPLINE PACKAGE FOR THE STABLE C EVALUATION OF ANY B-SPLINE BASIS FUNCTION OR DERIVATIVE VALUE. C SEE REFERENCE BELOW. C C CALCULATES THE VALUE AND THE FIRST NDERIV-1 DERIVATIVES OF ALL C B-SPLINES WHICH DO NOT VANISH AT X. THE ROUTINE FILLS THE TWO- C DIMENSIONAL ARRAY VNIKX(J,IDERIV), J=IDERIV, ... ,K WITH NONZERO C VALUES OF B-SPLINES OF ORDER K+1-IDERIV, IDERIV=NDERIV, ... ,1, BY C REPEATED CALLS TO BSPLVN. C C LAST MODIFIED BY RONG WANG, JAN 8, 2001. C C REFERENCE C C DEBOOR, C., PACKAGE FOR CALCULATING WITH B-SPLINES, SIAM J. C NUMER. ANAL., VOL. 14, NO. 3, JUNE 1977, PP. 441-472. C C PACKAGE ROUTINES CALLED.. BSPLVN C USER ROUTINES CALLED.. NONE C CALLED BY.. COLPNT,INITAL,VALUES C FORTRAN FUNCTIONS USED.. DBLE,MAX C----------------------------------------------------------------------- C SUBROUTINE PARAMETERS INTEGER K,NDERIV,ILEFT DOUBLE PRECISION X DOUBLE PRECISION XT(*),VNIKX(K,NDERIV) C----------------------------------------------------------------------- C LOCAL VARIABLES INTEGER KO,IDERIV,IDERVM,KMD,JM1,IPKMD,JLOW DOUBLE PRECISION A(20,20) DOUBLE PRECISION FKMD,DIFF,V C----------------------------------------------------------------------- C CONSTANT DOUBLE PRECISION ZERO, ONE PARAMETER (ZERO = 0.D0) PARAMETER (ONE = 1.D0) C----------------------------------------------------------------------- C LOOP INDICES INTEGER I,J,M,L C----------------------------------------------------------------------- KO = K + 1 - NDERIV CALL BSPLVN(XT,KO,1,X,ILEFT,VNIKX(NDERIV,NDERIV)) IF (NDERIV .LE. 1) GO TO 120 IDERIV = NDERIV DO 20 I=2,NDERIV IDERVM = IDERIV-1 DO 10 J=IDERIV,K VNIKX(J-1,IDERVM) = VNIKX(J,IDERIV) 10 CONTINUE IDERIV = IDERVM CALL BSPLVN(XT,0,2,X,ILEFT,VNIKX(IDERIV,IDERIV)) 20 CONTINUE DO 40 I=1,K DO 30 J=1,K A(I,J) = ZERO 30 CONTINUE A(I,I) = ONE 40 CONTINUE KMD = K DO 110 M=2,NDERIV KMD = KMD - 1 FKMD = DBLE(KMD) I = ILEFT J = K 50 CONTINUE JM1 = J-1 IPKMD = I + KMD DIFF = XT(IPKMD) -XT(I) IF (JM1 .NE. 0) THEN IF (DIFF .NE. ZERO) THEN DO 60 L=1,J A(L,J) = (A(L,J) - A(L,J-1))/DIFF*FKMD 60 CONTINUE ENDIF J = JM1 I = I - 1 GO TO 50 ENDIF IF (DIFF .NE. ZERO) THEN A(1,1) = A(1,1)/DIFF*FKMD ENDIF DO 110 I=1,K V = ZERO JLOW = MAX(I,M) DO 100 J=JLOW,K V = A(I,J)*VNIKX(J,M) + V 100 CONTINUE VNIKX(I,M) = V 110 CONTINUE 120 RETURN END SUBROUTINE BSPLVN ( XT, JHIGH, INDEX, X, ILEFT, VNIKX ) C----------------------------------------------------------------------- C THIS SUBROUTINE IS PART OF THE B-SPLINE PACKAGE FOR THE STABLE C EVALUATION OF ANY B-SPLINE BASIS FUNCTION OR DERIVATIVE VALUE. C SEE REFERENCE BELOW. C C CALCULATES THE VALUE OF ALL POSSIBLY NONZERO B-SPLINES AT THE C POINT X OF ORDER MAX(JHIGH,(J+1)(INDEX-1)) FOR THE BREAKPOINT SEQ- C UENCE XT. ASSUMING THAT XT(ILEFT) .LE. X .LE. XT(ILEFT+1), THE ROUT- C INE RETURNS THE B-SPLINE VALUES IN THE ONE DIMENSIONAL ARRAY VNIKX. C C LAST MODIFIED BY RONG WANG, JAN 8, 2001. C C REFERENCE C C DEBOOR, C., PACKAGE FOR CALCULATING WITH B-SPLINES, SIAM J. C NUMER. ANAL., VOL. 14, NO. 3, JUNE 1977, PP. 441-472. C C PACKAGE ROUTINES CALLED.. NONE C USER ROUTINES CALLED.. NONE C CALLED BY.. BSPLVD C FORTRAN FUNCTIONS USED.. NONE C----------------------------------------------------------------------- C SUBROUTINE PARAMETERS DOUBLE PRECISION XT(*),X,VNIKX(*) INTEGER JHIGH,INDEX,ILEFT C----------------------------------------------------------------------- C LOCAL VARIABLES INTEGER IPJ,IMJP1,JP1,JP1ML DOUBLE PRECISION VMPREV,VM C----------------------------------------------------------------------- C CONSTANT DOUBLE PRECISION ZERO, ONE PARAMETER (ZERO = 0.D0) PARAMETER (ONE = 1.D0) DOUBLE PRECISION DELTAM(20),DELTAP(20) INTEGER J C----------------------------------------------------------------------- C LOOP INDICE INTEGER L C----------------------------------------------------------------------- DATA J/1/,DELTAM/20*0.D+0/,DELTAP/20*0.D+0/ IF(INDEX.EQ.1) THEN J = 1 VNIKX(1) = ONE IF (J .GE. JHIGH) GO TO 40 ENDIF 20 CONTINUE IPJ = ILEFT+J DELTAP(J) = XT(IPJ) - X IMJP1 = ILEFT-J+1 DELTAM(J) = X - XT(IMJP1) VMPREV = ZERO JP1 = J+1 DO 30 L=1,J JP1ML = JP1-L VM = VNIKX(L)/(DELTAP(L) + DELTAM(JP1ML)) VNIKX(L) = VM*DELTAP(L) + VMPREV VMPREV = VM*DELTAM(JP1ML) 30 CONTINUE VNIKX(JP1) = VMPREV J = JP1 IF (J .LT. JHIGH) GO TO 20 40 RETURN END subroutine caljac(npde, kcol, nint, ncpts, neq, xcol, abdtop, & abdblk, abdbot, fbasis, t, y, yprime, cj, & work, pd) c----------------------------------------------------------------------- c Purpose: c This subroutine is called by jac. It provides a lower-level c interface to generate the iteration matrix. c c----------------------------------------------------------------------- c c Last modified by Rong Wang, August 13, 2001. c c----------------------------------------------------------------------- c Constants: integer nconti parameter (nconti = 2) c nconti continuity conditions are imposed c at the internal mesh points. c double precision zero parameter (zero = 0.0D0) c c----------------------------------------------------------------------- c Subroutine Parameters: c Input: integer npde c npde is the number of components in c the system of PDEs. npde > 0. c integer kcol c kcolis the number of collocation points c to be used in each subinterval. c integer nint c nint is the number of subintervals c defined by the spatial mesh x. c nint >= 1. c integer ncpts c ncpts=(kcol*nint+nconti) is the number c of collocation points. c integer neq c neq=npde*ncpts is the number of bspline c coefficients (or DAEs). c double precision xcol(ncpts) c xcol stores the collocation c points when using kcol collocation c points at each subinterval. c double precision abdtop(npde*npde*nconti) c abdtop stores the top block of the ABD c matrices. c double precision abdblk(npde*npde*nint*kcol * *(kcol+nconti)) c abdblk stores the nint c blocks in the middle of the ABD c collocation matrices when using kcol c collocation points at each subinterval. c double precision abdbot(npde*npde*nconti) c abdbot stores the bottom block of the c ABD matrices. c double precision fbasis((kcol+nconti)*3*ncpts) c fbasis stores the basis function values c at the collocation points. It acts like c a three dimensional array A of size c (kcol+nconti,3,ncpts). A(k,j,i) contains c the values of the (j-1)st derivative c (j=1,2,3) of the k-th non-zero basis c function (k=1,...,kcol+nconti) at the c i-th collocation point. c double precision t c t is the current time. c double precision y(neq) c y is the vector of bspline c coefficients at the current time. c double precision yprime(neq) c yprime is the derivative of y with c respect to time at the current time. c double precision cj c cj is a scalar chosen by DASSL to c accelerate convergence of the modified c Newton iteration used to solve the c implicit equations resulting from the c BDF methods. c c Work storage: double precision work(4*npde+5*npde*npde) c work is a floating point work array c of size 4*npde+5*npde*npde. c c Output: double precision pd(npde*npde*(2*nconti * +nint*kcol*(kcol+nconti))) c pd is the ABD Jacobian (iteration) c matrix of the residual of the DAE c system defined by RES. c c----------------------------------------------------------------------- c Local Variables: integer ipdtop c ipdtop is the pointer into pd where the c top block of the ABD Jacobian is stored. c integer ipdblk c ipdblk is the pointer into pd where the c nint blocks in the middle of the ABD c Jacobian are stored. c integer ipdbot c ipdbot is the pointer into pd where the c bottom block of the ABD Jacobian is c stored. c integer nsiztb c nsiztb is the size of the top block c as same as the bottom block of the ABD c Jacobian. c integer nsizbk c nsizbk is the size of a subblock in c the middle of ABD Jacobian. c c----------------------------------------------------------------------- c Loop indices: integer i integer j integer k integer m integer n c integer ii integer ij integer jj integer kk integer nn integer mm integer jk integer jk2 integer jk3 integer mn integer mn2 integer mn3 c c----------------------------------------------------------------------- c Pointers into the floating point work array work: integer iu c work(iu) stores the approximation to c u(t,x). c integer iux c work(iux) stores the approximation to c the first spatial derivative of u(t,x). c integer iuxx c work(iuxx) stores the approximation to c the second spatial derivative of u(t,x). c integer idfdu c work(idfdu) stores the Jacobian of f c with respect to u. c integer idfdux c work(idfdux) stores the Jacobian of f c with respect to u_x. c integer idfuxx c work(idfuxx) stores the Jacobian of f c with respect to u_xx. c integer idbdu c work(idbdu-1+i), i=1, npde*npde, c contains dbdu(npde,npde). That is, c dbdu(i,j) is the partial derivative c of the i-th component of the vector b c with respect to the j-th component c of the unknown function u. c integer idbdux c work(idbdux-1+i), i=1, npde*npde, c contains dbdux(npde,npde), That is, c dbdux(i,j) is the partial derivative c of the i-th component of the vector b c with respect to the j-th component c of the spatial derivative of the c unknown function u. c integer idbdt c work(idbdt-1+i), i=1, npde, contains c the partial derivative of the i-th c component of the vector b with respect c to time t. c c----------------------------------------------------------------------- c Subroutines Called: c derivf c difbxa c difbxb c eval c c----------------------------------------------------------------------- c BLAS Subroutines Called: c double precision: c daxpy c c----------------------------------------------------------------------- c Set pointers into the temporary floating point work array. iu = 1 iux = iu + npde iuxx = iux + npde idfdu = iuxx + npde idfdux = idfdu + npde * npde idfuxx = idfdux + npde * npde idbdu = idfuxx + npde * npde idbdux = idbdu + npde * npde idbdt = idbdux + npde * npde c Set the indices into pd which define the ABD Jacobian. ipdtop = 1 ipdblk = ipdtop + nconti * npde * npde ipdbot = ipdblk + nint * npde * npde * kcol * (kcol + nconti) c----------------------------------------------------------------------- c Calculate the size of top (or bottom) block and the size of a c subblock in the middle. nsiztb = npde * npde * nconti nsizbk = npde * npde * kcol * (kcol + nconti) c Initialize pdtop, pdblk and pdbot to zero. do 10 i = 1, nsiztb pd(ipdtop-1+i) = zero pd(ipdbot-1+i) = zero 10 continue do 20 i = 1, nint * nsizbk pd(ipdblk-1+i) = zero 20 continue c----------------------------------------------------------------------- c Loop over the nint blocks of collocation equations and c caluculate the portion of dG/dY which depends on them. do 70 i = 1, nint c ii+1 is the pointer to the first element at the i-th subblock c of the jacobian matrix, i = 1, nint. ii = ipdblk - 1 + (i - 1) * nsizbk c ij is the value of ileft for the current collocation point. ij = kcol + nconti + (i - 1) * kcol do 60 j = 1, kcol c jj+1 is the pointer to the first element corresponding to c the j-th collocation point in the i-th interval. jj = ii + (j - 1) * npde c mm is the index of the current collocation point. mm = (i - 1) * kcol + j + 1 c Generate the approximate solution and its spatial c derivatives at the current collocation point. call eval(npde,kcol,ij,mm,ncpts,work(iu),work(iux), & work(iuxx),fbasis(1+(mm-1)*(kcol+nconti)*3),y) c Generate dfdu, dfdux, and dfdux at the current c collocation point (the j-th point of the i-th c subinterval). call derivf(t, xcol(1+(i-1)*kcol+j), work(iu), & work(iux), work(iuxx), work(idfdu), & work(idfdux), work(idfuxx), npde) do 50 k = 1, kcol + nconti c kk+1 is the pointer to the first element of a npde by c npde submatrix, which is corresponding to the j-th c collocation point in the i-th interval, and the k-th c nonzero basis function. kk = jj + (k-1) * npde * npde * kcol c jk is the pointer to the k-th nonzero function at the c mm-th collocation point in the basis function, c fbasis(1). jk = (mm - 1) * (kcol + nconti) * 3 + k c jk2 is the pointer to the first derivative for the c above basis function. jk2 = jk + kcol + nconti c jk3 is the pointer to the second derivative for the c above basis function. jk3 = jk2 + kcol + nconti do 40 m = 1, npde do 30 n = 1, npde c nn is the pointer to the (n, m) element of the c npde by npde submatrix. nn = kk + (m-1)*npde*kcol + n c mn is the pointer to the (n, m) element of dfdu. mn = idfdu - 1 + (m - 1) * npde + n c mn2 is the pointer to the (n, m) element of dfdux. mn2 = mn + npde * npde c mn3 is the pointer to the (n, m) element of dfduxx. mn3 = mn2 + npde * npde c now set up the value in pd at the place nn. pd(nn) = - work(mn) * fbasis(jk) & - work(mn2) * fbasis(jk2) & - work(mn3) * fbasis(jk3) 30 continue 40 continue 50 continue 60 continue 70 continue c----------------------------------------------------------------------- c Update the values at the left boundary. call eval(npde, kcol, kcol+2, 1, ncpts, work(iu), work(iux), & work(iuxx), fbasis(1), y) call difbxa(t, work(iu), work(iux), work(idbdu), & work(idbdux), work(idbdt), npde) c Update the top block of the collocation matrix dG/dY'. do 90 j = 1, npde do 80 i = 1, npde ii = (j - 1) * npde + i jj = ii + npde * npde mm = (j - 1) * npde + i abdtop(jj) = & fbasis(2+kcol+nconti) * work(idbdux-1+mm) abdtop(ii) = & work(idbdu-1+mm) - abdtop(jj) 80 continue 90 continue c----------------------------------------------------------------------- c Update the values at the right boundary. call eval(npde, kcol, ncpts, ncpts, ncpts, work(iu), work(iux), & work(iuxx), fbasis(1+(ncpts-1)*(kcol+nconti)*3), y) call difbxb(t, work(iu), work(iux), work(idbdu), & work(idbdux), work(idbdt), npde) c Update the bottom block of the collocation matrix. do 110 j = 1, npde do 100 i = 1, npde ii = (j - 1) * npde + i jj = ii + npde * npde mm = (j - 1) * npde + i abdbot(ii) = & fbasis(1+kcol+kcol+nconti+(ncpts-1)*(kcol+nconti)*3) & * work(idbdux-1+mm) abdbot(jj) = & work(idbdu-1+mm) - abdbot(ii) 100 continue 110 continue c----------------------------------------------------------------------- c Add cj * A to pdmat. This is cj * dG/dY'. call daxpy(nsiztb, cj, abdtop, 1, pd(ipdtop), 1) call daxpy(nint*nsizbk, cj, abdblk, 1, pd(ipdblk), 1) call daxpy(nsiztb, cj, abdbot, 1, pd(ipdbot), 1) c----------------------------------------------------------------------- return end subroutine calres(npde, kcol, nint, ncpts, neq, xcol, abdblk, & fbasis, t, y, yprime, work, delta) c----------------------------------------------------------------------- c Purpose: c This subroutine is called by res. It provides a lower-level c interface to generate the residue at the current time t. c c----------------------------------------------------------------------- c c Last modified by Rong Wang, November 8, 2001. c c----------------------------------------------------------------------- c Constants: integer nconti parameter (nconti = 2) c nconti continuity conditions are imposed c at the internal mesh points. c double precision zero parameter (zero = 0.0D0) c double precision negone parameter (negone = -1.0D0) c c----------------------------------------------------------------------- c Subroutine Parameters: c Input: integer npde c npde is the number of components in c the system of PDEs. npde > 0. c integer kcol c kcol is the number of collocation points c to be used in each subinterval. c integer nint c nint is the number of subintervals c defined by the spatial mesh x. c nint >= 1. c integer ncpts c ncpts=(kcol*nint+nconti) is the number c of collocation points. c integer neq c neq=npde*ncpts is the number of bsplines c coefficients (or DAEs). c double precision xcol(ncpts) c xcol stores the collocation c points when using kcol collocation c points at each subinterval. c double precision abdblk(npde*npde*nint*kcol * *(kcol+nconti)) c abdblk stores the nint c blocks in the middle of the ABD c collocation matrices when using kcol c collocation points at each subinterval. c double precision fbasis((kcol+nconti)*3*ncpts) c fbasis stores the basis function values c at the collocation points. It acts like c a three dimensional array A of size c (kcol+nconti,3,ncpts). A(k,j,i) contains c the values of the (j-1)st derivative c (j=1,2,3) of the k-th non-zero basis c function (k=1,...,kcol+nconti) at the c i-th collocation point. c double precision t c T is the current time. c double precision y(neq) c y is the vector of bspline c coefficients at the current time. c double precision yprime(neq) c yprime is the derivative of y with c respect to time at the current time. c c Work storage: double precision work(4*npde+2*npde*npde) c work is a floating point work array c of size 4*npde+2*npde*npde. c c Output: double precision delta(neq) c delta is the residual of the DAE system. c c----------------------------------------------------------------------- c Loop indices: integer i integer j integer m integer k c c Indices: integer ii integer jj integer mm integer kk c c----------------------------------------------------------------------- c Pointers into the floating point work array work: integer iu c work(iu) stores the approximation to c u(t,x). c integer iux c work(iux) stores the approximation to c the first spatial derivative of u(t,x). c integer iuxx c work(iuxx) stores the approximation to c the second spatial derivative of u(t,x). c c----------------------------------------------------------------------- c Subroutines Called: c bndxa c bndxb c f c eval c----------------------------------------------------------------------- c----------------------------------------------------------------------- c BLAS Subroutines: c double precision: c dscal c----------------------------------------------------------------------- c Set pointers into the temporary floating point work array. iu = 1 iux = iu + npde iuxx = iux + npde c----------------------------------------------------------------------- c Initialize the residual to the zero vector. do 10 i = 1, neq delta(i) = zero 10 continue c----------------------------------------------------------------------- c Loop over the nint blocks of collocation equations. do 30 i = 1, nint c ii is the value of ileft for the current collocation point. ii = kcol + nconti + (i - 1) * kcol do 20 j = 1, kcol c jj is the pointer of collocation point. jj = (i - 1) * kcol + j + 1 c mm is the pointer of delta. mm = (jj - 1) * npde + 1 c kk is the pointer of the basis function values at c the current collocation point. kk =(jj-1)*(kcol+nconti)*3+1 c Generate the approximate solution and its spatial c derivatives at the current collocation point. call eval(npde,kcol,ii,jj,ncpts,work(iu),work(iux), & work(iuxx),fbasis(kk),y) c Evaluate the function f defining the PDE at the current c collocation point, storing the result in delta. call f(t, xcol(jj), work(iu), work(iux), & work(iuxx), delta(mm), npde) 20 continue 30 continue c Scale (delta(i), i=npde+1,npde*(ncpts-1)) with negative one. call dscal(npde*kcol*nint, negone, delta(npde+1), 1) c----------------------------------------------------------------------- c Calculate the portion of the residual vector which depends on the c collocation matrix. delta := delta + A*Yprime. c Calculate (delta(i), i=1, npde), which depend on the left c boundary point. call eval(npde, kcol, kcol+2, 1, ncpts, work(iu), work(iux), & work(iuxx), fbasis(1), y) call bndxa(t, work(iu), work(iux), delta(1), npde) c----------------------------------------------------------------------- c Calculate (delta(i), i=1, npde), which depend on the right c boundary point. call eval(npde, kcol, ncpts, ncpts, ncpts, work(iu), work(iux), & work(iuxx), fbasis(1+(ncpts-1)*(kcol+nconti)*3), y) call bndxb(t, work(iu), work(iux), delta(neq-npde+1), npde) c----------------------------------------------------------------------- c Calculate (delta(i), i = npde+1, (ncpts-1)*npde), which depend c on the nint blocks in the middle of the collocation matrix A. do 70 i = 1, nint do 60 j = 1, kcol + nconti do 50 k = 1, kcol kk = 1+(i-1)*npde*npde*kcol*(kcol+nconti) & +(j-1)*npde*npde*kcol+(k-1)*npde do 40 m = 1, npde ii = npde+(i-1)*npde*kcol+(k-1)*npde+m mm = (i-1)*kcol*npde+(j-1)*npde+m delta(ii) = delta(ii) + abdblk(kk) * yprime(mm) 40 continue 50 continue 60 continue 70 continue c----------------------------------------------------------------------- return end subroutine colpnt(kcol, nint, ncpts, x, h, work, xcol, xbs) c----------------------------------------------------------------------- c Purpose: c This routine generates the piecewise polynomial space breakpoint c sequence, and calculates the collocation point sequence. c c----------------------------------------------------------------------- c c Last modified by Rong Wang, April 3, 2001. c c----------------------------------------------------------------------- c Constants: integer nconti parameter (nconti = 2) c nconti continuity conditions are imposed c at the internal mesh points. c integer mxkcol parameter (mxkcol = 10) c mxkcol is the maximum number of c collocation points per subinterval. c c----------------------------------------------------------------------- c Subroutine Parameters: c Input: integer kcol c kcol is the number of collocation points c to be used in each subinterval. c integer nint c nint is the number of subintervals c defined by the spatial mesh x. c nint >= 1. c integer ncpts c ncpts=(kcol*nint+nconti) is the number c of collocation points. c double precision x(nint+1) c x is the spatial mesh which divides the c interval [x_a, x_b] as: x_a = x(1) < c x(2) < x(3) < ... < x(nint+1) = x_b. c double precision h(nint) c h is the mesh step size sequence. c c Work Storage: double precision work(kcol*kcol) c work is a floating point work storage c array of size lw. c c Output: double precision xcol(ncpts) c The sequence of collocation points on c the interval [a,b]. c double precision xbs(ncpts+kcol+nconti) c The breakpoint sequence. c xbs(i)=x(1), i=1, kcol+nconti; c xbs((i-1)*kcol+nconti+j)=x(i), c i=2, nint; j=1, kcol c xbs(ncpts+i)=x(nint+1), i=1,kcol+nconti. c c----------------------------------------------------------------------- c Local Variables: double precision rho(mxkcol+1) c rho stores the Gaussian points. c double precision wts(mxkcol+1) c wts stores the Gaussian weights. c c----------------------------------------------------------------------- c Loop indices: integer i integer j integer ii c c----------------------------------------------------------------------- c Subroutines Called: c gauleg c c----------------------------------------------------------------------- c Generate the piecewise polynomial space breakpoint sequence. do 10 i = 1, kcol + nconti xbs(i) = x(1) xbs(i + ncpts) = x(nint + 1) 10 continue do 30 i = 2, nint ii = (i - 2) * kcol + kcol + nconti do 20 j = 1, kcol xbs(ii + j) = x(i) 20 continue 30 continue c----------------------------------------------------------------------- c Compute the Gaussian points. call gauleg(kcol, kcol*kcol, rho, wts, work, 2) c Define the collocation point sequence. xcol(1) = x(1) do 50 i = 1, nint ii = (i - 1) * kcol + 1 do 40 j = 1, kcol xcol(ii + j) = x(i) + h(i) * rho(j) 40 continue 50 continue xcol(ncpts) = x(nint + 1) return end SUBROUTINE CRDCMP(N,TOPBLK,NRWTOP,NOVRLP,ARRAY,NRWBLK, * NCLBLK,NBLOKS,BOTBLK,NRWBOT,PIVOT,IFLAG) C C*************************************************************** C C C R D C M P DECOMPOSES THE ALMOST BLOCK DIAGONAL MATRIX A C USING MODIFIED ALTERNATE ROW AND COLUMN ELIMINATION WITH C PARTIAL PIVOTING. THE MATRIX A IS STORED IN THE ARRAYS C TOPBLK, ARRAY, AND BOTBLK. C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C ***** PARAMETERS ***** C C *** ON ENTRY ... C C N - INTEGER C THE ORDER OF THE LINEAR SYSTEM, C GIVEN BY NBLOKS*NRWBLK + NOVRLP C C TOPBLK - DOUBLE PRECISION(NRWTOP,NOVRLP) C THE FIRST BLOCK OF THE ALMOST BLOCK C DIAGONAL MATRIX A TO BE DECOMPOSED C C NRWTOP - INTEGER C NUMBER OF ROWS IN THE BLOCK TOPBLK C C NOVRLP - INTEGER C THE NUMBER OF COLUMNS IN WHICH SUCC- C ESSIVE BLOCKS OVERLAP, WHERE C NOVRLP = NRWTOP + NRWBOT C C ARRAY - DOUBLE PRECISION(NRWBLK,NCLBLK,NBLOKS) C ARRAY(,,K) CONTAINS THE K-TH NRWBLK C BY NCLBLK BLOCK OF THE MATRIX A C C NRWBLK - INTEGER C NUMBER OF ROWS IN K-TH BLOCK C C NCLBLK - INTEGER C NUMBER OF COLUMNS IN K-TH BLOCK C C NBLOKS - INTEGER C NUMBER OF NRWBLK BY NCLBLK BLOCKS IN C THE MATRIX A C C BOTBLK - DOUBLE PRECISION(NRWBOT,NOVRLP) C THE LAST BLOCK OF THE MATRIX A C C NRWBOT - INTEGER C NUMBER OF ROWS IN THE BLOCK BOTBLK C C PIVOT - INTEGER(N) C WORK SPACE C C *** ON RETURN ... C C TOPBLK,ARRAY,BOTBLK - ARRAYS CONTAINING THE C DESIRED DECOMPOSITION OF THE MATRIX A C (IF IFLAG = 0) C C PIVOT - INTEGER(N) C RECORDS THE PIVOTING INDICES DETER- C MINED IN THE DECOMPOSITION C C IFLAG - INTEGER C = 1, IF INPUT PARAMETERS ARE INVALID C = -1, IF MATRIX IS SINGULAR C = 0, OTHERWISE C C*************************************************************** C IMPLICIT NONE DOUBLE PRECISION TOPBLK,ARRAY,BOTBLK DOUBLE PRECISION ROWMAX,ROWPIV,ROWMLT,COLMAX,COLPIV DOUBLE PRECISION SWAP,COLMLT,PIVMAX,ZERO,TEMPIV INTEGER N,NRWTOP,NOVRLP,NRWBLK,NCLBLK,NBLOKS,NRWBOT,PIVOT(*), * IFLAG DIMENSION TOPBLK(NRWTOP,*),ARRAY(NRWBLK,NCLBLK,*), * BOTBLK(NRWBOT,*) INTEGER NRWEL1,NROWEL,I,IPVT,J,IPLUS1,L,INCR,K,NRWTP1,JMINN, * LOOP,JPLUS1,INCRJ,IPLUSN,IPVBLK,KPLUS1,IRWBLK,JRWBLK, * NVRLP0,INCRN DATA ZERO/0.0D0/ C C*************************************************************** C C **** DEFINE THE CONSTANTS USED THROUGHOUT **** C C*************************************************************** C IFLAG = 0 PIVMAX = ZERO NRWTP1 = NRWTOP+1 NROWEL = NRWBLK-NRWTOP NRWEL1 = NROWEL+1 NVRLP0 = NOVRLP-1 C C*************************************************************** C C **** CHECK VALIDITY OF THE INPUT PARAMETERS.... C C IF PARAMETERS ARE INVALID THEN TERMINATE AT 10; C ELSE CONTINUE AT 100. C C*************************************************************** C IF(N.NE.NBLOKS*NRWBLK+NOVRLP)GO TO 10 IF(NOVRLP.NE.NRWTOP+NRWBOT)GO TO 10 IF(NCLBLK.NE.NOVRLP+NRWBLK)GO TO 10 IF(NOVRLP.GT.NRWBLK)GO TO 10 C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C PARAMETERS ARE ACCEPTABLE - CONTINUE AT 100. C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C GO TO 100 10 CONTINUE C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C PARAMETERS ARE INVALID. SET IFLAG = 1, AND TERMINATE C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C IFLAG = 1 RETURN 100 CONTINUE C C*************************************************************** C C **** FIRST, IN TOPBLK.... C C*************************************************************** C C *** APPLY NRWTOP COLUMN ELIMINATIONS WITH COLUMN C PIVOTING .... C C*************************************************************** C DO 190 I = 1,NRWTOP IPLUS1 = I+1 C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C DETERMINE COLUMN PIVOT AND PIVOT INDEX C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C IPVT = I COLMAX = DABS(TOPBLK(I,I)) DO 110 J = IPLUS1,NOVRLP TEMPIV = DABS(TOPBLK(I,J)) IF(TEMPIV.LE.COLMAX)GO TO 110 IPVT = J COLMAX = TEMPIV 110 CONTINUE C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C TEST FOR SINGULARITY: C C IF SINGULAR THEN TERMINATE AT 1000; C ELSE CONTINUE. C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C IF(PIVMAX+COLMAX.EQ.PIVMAX)GO TO 1000 PIVMAX = DMAX1(COLMAX,PIVMAX) C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C IF NECESSARY INTERCHANGE COLUMNS C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C PIVOT(I) = IPVT IF(IPVT.EQ.I)GO TO 140 DO 120 L = I,NRWTOP SWAP = TOPBLK(L,IPVT) TOPBLK(L,IPVT) = TOPBLK(L,I) TOPBLK(L,I) = SWAP 120 CONTINUE DO 130 L = 1,NRWBLK SWAP = ARRAY(L,IPVT,1) ARRAY(L,IPVT,1) = ARRAY(L,I,1) ARRAY(L,I,1) = SWAP 130 CONTINUE 140 CONTINUE C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C COMPUTE MULTIPLIERS AND PERFORM COLUMN C ELIMINATION C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C COLPIV = TOPBLK(I,I) DO 180 J = IPLUS1,NOVRLP COLMLT = TOPBLK(I,J)/COLPIV TOPBLK(I,J) = COLMLT IF(IPLUS1.GT.NRWTOP)GO TO 160 DO 150 L = IPLUS1,NRWTOP TOPBLK(L,J) = TOPBLK(L,J)-COLMLT*TOPBLK(L,I) 150 CONTINUE 160 CONTINUE DO 170 L = 1,NRWBLK ARRAY(L,J,1) = ARRAY(L,J,1)-COLMLT*ARRAY(L,I,1) 170 CONTINUE 180 CONTINUE 190 CONTINUE C C*************************************************************** C C **** IN EACH BLOCK ARRAY(,,K).... C C*************************************************************** C INCR = 0 DO 395 K = 1,NBLOKS KPLUS1 = K+1 C C ***************************************************** C C *** FIRST APPLY NRWBLK-NRWTOP ROW ELIMINATIONS WITH C ROW PIVOTING.... C C ***************************************************** C DO 270 J = NRWTP1,NRWBLK JPLUS1 = J+1 JMINN = J-NRWTOP C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C DETERMINE ROW PIVOT AND PIVOT INDEX C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C IPVT = JMINN ROWMAX = DABS(ARRAY(JMINN,J,K)) LOOP = JMINN+1 DO 210 I = LOOP,NRWBLK TEMPIV = DABS(ARRAY(I,J,K)) IF(TEMPIV.LE.ROWMAX)GO TO 210 IPVT = I ROWMAX = TEMPIV 210 CONTINUE C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C TEST FOR SINGULARITY: C C IF SINGULAR THEN TERMINATE AT 1000; C ELSE CONTINUE. C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C IF(PIVMAX+ROWMAX.EQ.PIVMAX)GO TO 1000 PIVMAX = DMAX1(ROWMAX,PIVMAX) C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C IF NECESSARY INTERCHANGE ROWS C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C INCRJ = INCR+J PIVOT(INCRJ) = INCR+IPVT+NRWTOP IF(IPVT.EQ.JMINN)GO TO 230 DO 220 L = J,NCLBLK SWAP = ARRAY(IPVT,L,K) ARRAY(IPVT,L,K) = ARRAY(JMINN,L,K) ARRAY(JMINN,L,K) = SWAP 220 CONTINUE 230 CONTINUE C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C COMPUTE MULTIPLERS C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C ROWPIV = ARRAY(JMINN,J,K) DO 240 I = LOOP,NRWBLK ARRAY(I,J,K) = ARRAY(I,J,K)/ROWPIV 240 CONTINUE C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C PERFORM ROW ELIMINATION WITH COLUMN INDEXING C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C DO 260 L = JPLUS1,NCLBLK ROWMLT = ARRAY(JMINN,L,K) DO 250 I = LOOP,NRWBLK ARRAY(I,L,K) = ARRAY(I,L,K) * -ROWMLT*ARRAY(I,J,K) 250 CONTINUE 260 CONTINUE 270 CONTINUE C C ***************************************************** C C *** NOW APPLY NRWTOP COLUMN ELIMINATIONS WITH C COLUMN PIVOTING.... C C ***************************************************** C DO 390 I = NRWEL1,NRWBLK IPLUSN = I+NRWTOP IPLUS1 = I+1 C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C DETERMINE COLUMN PIVOT AND PIVOT INDEX C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C IPVT = IPLUSN COLMAX = DABS(ARRAY(I,IPVT,K)) LOOP = IPLUSN+1 DO 310 J = LOOP,NCLBLK TEMPIV = DABS(ARRAY(I,J,K)) IF(TEMPIV.LE.COLMAX)GO TO 310 IPVT = J COLMAX = TEMPIV 310 CONTINUE C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C TEST FOR SINGULARITY: C C IF SINGULAR THEN TERMINATE AT 1000; C ELSE CONTINUE. C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C IF(PIVMAX+COLMAX.EQ.PIVMAX)GO TO 1000 PIVMAX = DMAX1(COLMAX,PIVMAX) C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C IF NECESSARY INTERCHANGE COLUMNS C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C INCRN = INCR+IPLUSN PIVOT(INCRN) = INCR+IPVT IRWBLK = IPLUSN-NRWBLK IF(IPVT.EQ.IPLUSN)GO TO 340 DO 315 L = I,NRWBLK SWAP = ARRAY(L,IPVT,K) ARRAY(L,IPVT,K) = ARRAY(L,IPLUSN,K) ARRAY(L,IPLUSN,K) = SWAP 315 CONTINUE IPVBLK = IPVT-NRWBLK IF(K.EQ.NBLOKS)GO TO 330 DO 320 L = 1,NRWBLK SWAP = ARRAY(L,IPVBLK,KPLUS1) ARRAY(L,IPVBLK,KPLUS1) * = ARRAY(L,IRWBLK,KPLUS1) ARRAY(L,IRWBLK,KPLUS1) = SWAP 320 CONTINUE GO TO 340 330 CONTINUE DO 335 L = 1,NRWBOT SWAP = BOTBLK(L,IPVBLK) BOTBLK(L,IPVBLK) = BOTBLK(L,IRWBLK) BOTBLK(L,IRWBLK) = SWAP 335 CONTINUE 340 CONTINUE C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C COMPUTE MULTIPLIERS AND PERFORM COLUMN C ELIMINATION C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C COLPIV = ARRAY(I,IPLUSN,K) DO 380 J = LOOP,NCLBLK COLMLT = ARRAY(I,J,K)/COLPIV ARRAY(I,J,K) = COLMLT IF(I.EQ.NRWBLK)GO TO 350 DO 345 L = IPLUS1,NRWBLK ARRAY(L,J,K) = ARRAY(L,J,K) * -COLMLT*ARRAY(L,IPLUSN,K) 345 CONTINUE 350 CONTINUE JRWBLK = J-NRWBLK IF(K.EQ.NBLOKS)GO TO 370 DO 360 L = 1,NRWBLK ARRAY(L,JRWBLK,KPLUS1) = * ARRAY(L,JRWBLK,KPLUS1) * -COLMLT*ARRAY(L,IRWBLK,KPLUS1) 360 CONTINUE GO TO 380 370 CONTINUE DO 375 L = 1,NRWBOT BOTBLK(L,JRWBLK) = BOTBLK(L,JRWBLK) * -COLMLT*BOTBLK(L,IRWBLK) 375 CONTINUE 380 CONTINUE 390 CONTINUE INCR = INCR + NRWBLK 395 CONTINUE C C*************************************************************** C C **** FINALLY, IN BOTBLK.... C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C *** APPLY NRWBOT ROW ELIMINATIONS WITH ROW C PIVOTING.... C C IF BOT HAS JUST ONE ROW GO TO 500 C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C IF(NRWBOT.EQ.1)GO TO 500 DO 470 J = NRWTP1,NVRLP0 JPLUS1 = J+1 JMINN = J-NRWTOP C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C DETERMINE ROW PIVOT AND PIVOT INDEX C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C IPVT = JMINN ROWMAX = DABS(BOTBLK(JMINN,J)) LOOP = JMINN+1 DO 410 I = LOOP,NRWBOT TEMPIV = DABS(BOTBLK(I,J)) IF(TEMPIV.LE.ROWMAX) GO TO 410 IPVT = I ROWMAX = TEMPIV 410 CONTINUE C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C TEST FOR SINGULARITY: C C IF SINGULAR THEN TERMINATE AT 1000; C ELSE CONTINUE. C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C IF(PIVMAX+ROWMAX.EQ.PIVMAX)GO TO 1000 PIVMAX = DMAX1(ROWMAX,PIVMAX) C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C IF NECESSARY INTERCHANGE ROWS C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C INCRJ = INCR+J PIVOT(INCRJ) = INCR+IPVT+NRWTOP IF(IPVT.EQ.JMINN)GO TO 430 DO 420 L = J,NOVRLP SWAP = BOTBLK(IPVT,L) BOTBLK(IPVT,L) = BOTBLK(JMINN,L) BOTBLK(JMINN,L) = SWAP 420 CONTINUE 430 CONTINUE C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C COMPUTE MULTIPLIERS C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C ROWPIV = BOTBLK(JMINN,J) DO 440 I = LOOP,NRWBOT BOTBLK(I,J) = BOTBLK(I,J)/ROWPIV 440 CONTINUE C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C PERFORM ROW ELIMINATION WITH COLUMN INDEXING C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C DO 460 L = JPLUS1,NOVRLP ROWMLT = BOTBLK(JMINN,L) DO 450 I = LOOP,NRWBOT BOTBLK(I,L) = BOTBLK(I,L)-ROWMLT*BOTBLK(I,J) 450 CONTINUE 460 CONTINUE 470 CONTINUE 500 CONTINUE C C*************************************************************** C C DONE PROVIDED THE LAST ELEMENT IS NOT ZERO C C*************************************************************** C IF(PIVMAX+DABS(BOTBLK(NRWBOT,NOVRLP)).NE.PIVMAX) RETURN C C*************************************************************** C C **** MATRIX IS SINGULAR - SET IFLAG = - 1. C TERMINATE AT 1000. C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C 1000 CONTINUE IFLAG = -1 RETURN END SUBROUTINE CRSLVE(TOPBLK,NRWTOP,NOVRLP,ARRAY,NRWBLK, * NCLBLK,NBLOKS,BOTBLK,NRWBOT,PIVOT,B,JOB) C C*************************************************************** C C C R S L V E SOLVES THE LINEAR SYSTEM C A*X = B C USING THE DECOMPOSITION ALREADY GENERATED IN C R D C M P. C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C ***** PARAMETERS ***** C C *** ON ENTRY ... C C TOPBLK - DOUBLE PRECISION(NRWTOP,NOVRLP) C OUTPUT FROM C R D C M P C C NOVRLP - INTEGER C THE NUMBER OF COLUMNS IN WHICH SUCC- C ESSIVE BLOCKS OVERLAP, WHERE C NOVRLP = NRWTOP + NRWBOT C C NRWTOP - INTEGER C NUMBER OF ROWS IN THE BLOCK TOPBLK C C ARRAY - DOUBLE PRECISION(NRWBLK,NCLBLK,NBLOKS) C OUTPUT FROM C R D C M P C C NRWBLK - INTEGER C NUMBER OF ROWS IN K-TH BLOCK C C NCLBLK - INTEGER C NUMBER OF COLUMNS IN K-TH BLOCK C C NBLOKS - INTEGER C NUMBER OF NRWBLK BY NCLBLK BLOCKS IN C THE MATRIX A C C BOTBLK - DOUBLE PRECISION(NRWBOT,NOVRLP) C OUTPUT FROM C R D C M P C C NRWBOT - INTEGER C NUMBER OF ROWS IN THE BLOCK BOTBLK C C PIVOT - INTEGER(N) C THE PIVOT VECTOR FROM C R D C M P C C B - DOUBLE PRECISION(N) C THE RIGHT HAND SIDE VECTOR C C JOB - INTEGER, INDICATING: C = 0: SOLVE A*X = B; C NON-ZERO: SOLVE TRANSPOSE(A)*X = B. C C *** ON RETURN ... C C B - DOUBLE PRECISION(N) C THE SOLUTION VECTOR C C*************************************************************** C IMPLICIT NONE DOUBLE PRECISION TOPBLK,ARRAY,BOTBLK,B DOUBLE PRECISION DOTPRD,BJ,XINCRJ,BINCRJ,SWAP,BI INTEGER NRWTOP,NOVRLP,NRWBLK,NCLBLK,NBLOKS,NRWBOT,PIVOT(*), * JOB DIMENSION TOPBLK(NRWTOP,*),ARRAY(NRWBLK,NCLBLK,*), * BOTBLK(NRWBOT,*),B(*) INTEGER NRWTP1,NRWBK1,NVRLP1,NRWBT1,NROWEL,NVRLP0,NBLKS1, * NBKTOP,J,I,LOOP,INCR,INCRJ,INCRI,JPIVOT,JRWTOP, * LL,L1,IPLUSN,INCRN,NRWTP0,NRWEL1,K,INCRTP,NRWBTL, * IPVTN,NRWELL,IPVTI,L C C*************************************************************** C C **** DEFINE THE CONSTANTS USED THROUGHOUT **** C C*************************************************************** C NRWTP1 = NRWTOP+1 NRWBK1 = NRWBLK+1 NVRLP1 = NOVRLP+1 NRWTP0 = NRWTOP-1 NRWBT1 = NRWBOT+1 NROWEL = NRWBLK-NRWTOP NRWEL1 = NROWEL+1 NVRLP0 = NOVRLP-1 NBLKS1 = NBLOKS+1 NBKTOP = NRWBLK+NRWTOP C C IF JOB IS NON-ZERO, TRANSFER TO THE SECTION DEALING WITH C TRANSPOSE(A)*X = B. C IF ( JOB .NE. 0 ) GO TO 530 C C*************************************************************** C C **** FORWARD RECURSION **** C C*************************************************************** C C *** FIRST, IN TOPBLK.... C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C FORWARD SOLUTION C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C DO 130 J = 1,NRWTOP B(J) = B(J)/TOPBLK(J,J) IF(J.EQ.NRWTOP)GO TO 120 BJ = -B(J) LOOP = J+1 DO 110 I = LOOP,NRWTOP B(I) = B(I)+TOPBLK(I,J)*BJ 110 CONTINUE 120 CONTINUE 130 CONTINUE C C ******************************************************** C C *** IN EACH BLOCK ARRAY(,,K).... C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C INCR = 0 DO 280 K = 1,NBLOKS INCRTP = INCR+NRWTOP C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C FORWARD MODIFICATION C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C DO 220 J = 1,NRWTOP INCRJ = INCR+J XINCRJ = -B(INCRJ) DO 210 I = 1,NRWBLK INCRI = INCRTP+I B(INCRI) = B(INCRI)+ARRAY(I,J,K)*XINCRJ 210 CONTINUE 220 CONTINUE C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C FORWARD ELIMINATION C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C DO 240 J = NRWTP1,NRWBLK INCRJ = INCR+J JPIVOT = PIVOT(INCRJ) IF(JPIVOT.EQ.INCRJ)GO TO 225 SWAP = B(INCRJ) B(INCRJ) = B(JPIVOT) B(JPIVOT) = SWAP 225 CONTINUE BINCRJ = -B(INCRJ) LOOP = J-NRWTP0 DO 230 I = LOOP,NRWBLK INCRI = INCRTP+I B(INCRI) = B(INCRI)+ARRAY(I,J,K)*BINCRJ 230 CONTINUE 240 CONTINUE C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C FORWARD SOLUTION C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C DO 270 J = NRWBK1,NBKTOP INCRJ = INCR+J JRWTOP = J -NRWTOP B(INCRJ) = B(INCRJ)/ARRAY(JRWTOP,J,K) IF(J.EQ.NBKTOP)GO TO 260 XINCRJ = -B(INCRJ) LOOP = J-NRWTP0 DO 250 I = LOOP,NRWBLK INCRI = INCRTP+I B(INCRI) = B(INCRI)+ARRAY(I,J,K)*XINCRJ 250 CONTINUE 260 CONTINUE 270 CONTINUE INCR = INCR+NRWBLK 280 CONTINUE C C ******************************************************** C C *** FINALLY, IN BOTBLK.... C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C FORWARD MODIFICATION C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C INCRTP = INCR+NRWTOP DO 320 J = 1,NRWTOP INCRJ = INCR+J XINCRJ = -B(INCRJ) DO 310 I = 1,NRWBOT INCRI = INCRTP+I B(INCRI) = B(INCRI)+BOTBLK(I,J)*XINCRJ 310 CONTINUE 320 CONTINUE C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C FORWARD ELIMINATION C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C IF(NRWBOT.EQ.1)GO TO 350 DO 340 J = NRWTP1,NVRLP0 INCRJ = INCR+J JPIVOT = PIVOT(INCRJ) IF(JPIVOT.EQ.INCRJ)GO TO 325 SWAP = B(INCRJ) B(INCRJ) = B(JPIVOT) B(JPIVOT) = SWAP 325 CONTINUE BINCRJ = -B(INCRJ) LOOP = J-NRWTP0 DO 330 I = LOOP,NRWBOT INCRI = INCRTP+I B(INCRI) = B(INCRI)+BOTBLK(I,J)*BINCRJ 330 CONTINUE 340 CONTINUE 350 CONTINUE C C*************************************************************** C C **** BACKWARD RECURSION **** C C*************************************************************** C C *** FIRST IN BOTBLK.... C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C BACKWARD SOLUTION C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C DO 430 LL = 1,NRWBOT J = NVRLP1-LL INCRJ = INCR+J NRWBTL = NRWBT1-LL B(INCRJ) = B(INCRJ)/BOTBLK(NRWBTL,J) IF(LL.EQ.NRWBOT)GO TO 420 XINCRJ = -B(INCRJ) LOOP = NRWBOT-LL DO 410 I = 1,LOOP INCRI = INCRTP+I B(INCRI) = B(INCRI)+BOTBLK(I,J)*XINCRJ 410 CONTINUE 420 CONTINUE 430 CONTINUE C C ******************************************************** C C *** THEN IN EACH BLOCK ARRAY(,,K).... C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C DO 490 L = 1,NBLOKS C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C BACKWARD ELIMINATION C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C K = NBLKS1-L INCR = INCR-NRWBLK DO 450 L1 = NRWEL1,NRWBLK I = NRWBLK+NRWEL1-L1 IPLUSN = I+NRWTOP LOOP = IPLUSN+1 INCRN = INCR+IPLUSN DOTPRD = B(INCRN) DO 440 J = LOOP,NCLBLK INCRJ = INCR+J DOTPRD = DOTPRD-ARRAY(I,J,K)*B(INCRJ) 440 CONTINUE B(INCRN) = DOTPRD IPVTN = PIVOT(INCRN) IF(INCRN.EQ.IPVTN)GO TO 445 SWAP = B(INCRN) B(INCRN) = B(IPVTN) B(IPVTN) = SWAP 445 CONTINUE 450 CONTINUE C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C BACKWARD MODIFICATION C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C INCRTP = INCR+NRWTOP DO 460 J = NRWBK1,NCLBLK INCRJ = INCR+J XINCRJ = -B(INCRJ) DO 455 I = 1,NROWEL INCRI = INCRTP+I B(INCRI) = B(INCRI)+ARRAY(I,J,K)*XINCRJ 455 CONTINUE 460 CONTINUE C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C BACKWARD SOLUTION C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C DO 480 LL = 1,NROWEL J = NRWBK1-LL INCRJ = INCR+J NRWELL = NRWEL1-LL B(INCRJ) = B(INCRJ)/ARRAY(NRWELL,J,K) IF(LL.EQ.NROWEL)GO TO 470 XINCRJ = -B(INCRJ) LOOP = NROWEL-LL DO 465 I = 1,LOOP INCRI = INCRTP+I B(INCRI) = B(INCRI)+ARRAY(I,J,K)*XINCRJ 465 CONTINUE 470 CONTINUE 480 CONTINUE 490 CONTINUE C C ******************************************************** C C *** IN TOPBLK FINISH WITH.... C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C BACKWARD ELIMINATION C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C DO 520 L = 1,NRWTOP I = NRWTP1-L LOOP = I+1 DOTPRD = B(I) DO 510 J = LOOP,NOVRLP DOTPRD = DOTPRD-TOPBLK(I,J)*B(J) 510 CONTINUE B(I) = DOTPRD IPVTI = PIVOT(I) IF(I.EQ.IPVTI)GO TO 515 SWAP = B(I) B(I) = B(IPVTI) B(IPVTI) = SWAP 515 CONTINUE 520 CONTINUE C C RETURN FROM THE SOLUTION OF A.X = B. RETURN C C IF JOB IS NON-ZERO, SOLVE TRANSPOSE(A)*X = B: C 530 CONTINUE C FIRST, FORWARD ELIMINATION OF RHS USING TRANSPOSE(U). DO 540 I = 1,NRWTOP IPVTI = PIVOT(I) IF ( I .NE. IPVTI ) THEN SWAP = B(I) B(I) = B(IPVTI) B(IPVTI) = SWAP ENDIF BI = -B(I) LOOP = I+1 DO 535 J = LOOP,NOVRLP B(J) = B(J) + BI*TOPBLK(I,J) 535 CONTINUE 540 CONTINUE C IN EACH BLOCK, K = 1,..,NBLOKS: INCR = NRWTOP DO 590 K = 1,NBLOKS C FIRST, THE FORWARD SOLUTION. DO 550 J = 1,NROWEL INCRJ = INCR + J DO 545 I = 1,J-1 B(INCRJ) = B(INCRJ) - ARRAY(I,NRWTOP+J,K)*B(INCR+I) 545 CONTINUE B(INCRJ) = B(INCRJ)/ARRAY(J,NRWTOP+J,K) 550 CONTINUE C FORWARD MODIFICATION. DO 570 I = 1,NOVRLP INCRI = INCR + NROWEL + I LOOP = NRWBLK + I DO 560 J = 1,NROWEL INCRJ = INCR + J B(INCRI) = B(INCRI) - ARRAY(J,LOOP,K)*B(INCRJ) 560 CONTINUE 570 CONTINUE C NOW, FORWARD ELIMINATION OF RHS USING TRANSPOSE(U). THIS C CORRESPONDS TO THE LOOP 540 ABOVE. INCR = INCR + NROWEL DO 580 I = 1,NRWTOP INCRI = INCR + I IPVTI = PIVOT(INCRI) IF ( INCRI .NE. IPVTI ) THEN SWAP = B(INCRI) B(INCRI) = B(IPVTI) B(IPVTI) = SWAP ENDIF LOOP = NROWEL + I BI = -B(INCRI) DO 575 J = I+1,NOVRLP INCRJ = INCR+J L = NRWBLK + J B(INCRJ) = B(INCRJ) + BI*ARRAY(LOOP,L,K) 575 CONTINUE 580 CONTINUE INCR = INCR + NRWTOP 590 CONTINUE C FINALLY, FINISH WITH NRWBOT SOLUTIONS: DO 600 J = 1,NRWBOT INCRJ = INCR + J DO 595 I = 1,J-1 B(INCRJ) = B(INCRJ) - BOTBLK(I,J+NRWTOP)*B(INCR+I) 595 CONTINUE B(INCRJ) = B(INCRJ)/BOTBLK(J,J+NRWTOP) 600 CONTINUE C NOW, THE BACKWARD PASS: C FIRST, BACKWARD SOLUTION IN BOTBLK: INCRJ = INCR + NRWBOT DO 610 J = 1,NRWBOT-1 INCRJ = INCRJ - 1 DO 605 I = NRWBOT-J+1,NRWBOT INCRI = INCR + I B(INCRJ) = B(INCRJ) - BOTBLK(I,NOVRLP-J)*B(INCRI) 605 CONTINUE IF ( INCRJ .NE. PIVOT(INCRJ) ) THEN SWAP = B(INCRJ) B(INCRJ) = B(PIVOT(INCRJ)) B(PIVOT(INCRJ)) = SWAP ENDIF 610 CONTINUE C NOW DO THE DEFERRED OPERATIONS IN BOTBLOK: DO 620 J = 1,NRWTOP INCRJ = INCR - J + 1 DO 615 I = 1,NRWBOT INCRI = INCR + I B(INCRJ) = B(INCRJ) - BOTBLK(I,NRWTP1-J)*B(INCRI) 615 CONTINUE 620 CONTINUE C NOW, IN EACH BLOCK, K = NBLOKS,..,1: DO 800 K = NBLOKS,1,-1 C FIRST, THE BACKSUBSTITUIONS: DO 630 J = 1,NRWTOP INCRJ = INCR - J + 1 LOOP = NBKTOP - J + 1 DO 625 I = 1,J-1 INCRI = INCR - I + 1 B(INCRJ) = B(INCRJ) - ARRAY(NRWBLK-I+1,LOOP,K)*B(INCRI) 625 CONTINUE B(INCRJ) = B(INCRJ)/ARRAY(NRWBLK-J+1,LOOP,K) 630 CONTINUE C THEN THE BACKWARD SOLUTION IN THE KTH BLOCK: DO 650 J = 1,NROWEL INCRJ = INCR - NRWTOP -J + 1 DO 645 I = 1,J+NRWTOP-1 INCRI = INCRJ + I B(INCRJ) = B(INCRJ) - * ARRAY(NRWBLK-NRWTOP-J+1+I,NRWBLK-J+1,K)*B(INCRI) 645 CONTINUE IF ( INCRJ .NE. PIVOT(INCRJ) ) THEN SWAP = B(INCRJ) B(INCRJ) = B(PIVOT(INCRJ)) B(PIVOT(INCRJ)) = SWAP ENDIF 650 CONTINUE C NOW, THE DEFERRED OPERATIONS ON B: INCR = INCR - NRWBLK DO 660 J = 1,NRWTOP INCRJ = INCR + J - NRWTOP DO 655 I = 1,NRWBLK INCRI = INCR + I B(INCRJ) = B(INCRJ) - ARRAY(I,J,K)*B(INCRI) 655 CONTINUE 660 CONTINUE 800 CONTINUE C FINALLY, THE LAST SET OF BACK-SUBSTITUTIONS IN TOPBLK: DO 900 J = 1,NRWTOP INCRJ = NRWTOP -J + 1 DO 850 I = INCRJ+1,NRWTOP B(INCRJ) = B(INCRJ) - TOPBLK(I,INCRJ)*B(I) 850 CONTINUE B(INCRJ) = B(INCRJ)/TOPBLK(INCRJ,INCRJ) 900 CONTINUE C C RETURN FROM THE SOLUTION OF A-TRANSPOSE.X = B RETURN END DOUBLE PRECISION FUNCTION D1MACH(I) C C DOUBLE-PRECISION MACHINE CONSTANTS C C D1MACH( 1) = B**(EMIN-1), THE SMALLEST POSITIVE MAGNITUDE. C C D1MACH( 2) = B**EMAX*(1 - B**(-T)), THE LARGEST MAGNITUDE. C C D1MACH( 3) = B**(-T), THE SMALLEST RELATIVE SPACING. C C D1MACH( 4) = B**(1-T), THE LARGEST RELATIVE SPACING. C C D1MACH( 5) = LOG10(B) C C TO ALTER THIS FUNCTION FOR A PARTICULAR ENVIRONMENT, C THE DESIRED SET OF DATA STATEMENTS SHOULD BE ACTIVATED BY C REMOVING THE C FROM COLUMN 1. C ON RARE MACHINES A STATIC STATEMENT MAY NEED TO BE ADDED. C (BUT PROBABLY MORE SYSTEMS PROHIBIT IT THAN REQUIRE IT.) C C FOR IEEE-ARITHMETIC MACHINES (BINARY STANDARD), ONE OF THE FIRST C TWO SETS OF CONSTANTS BELOW SHOULD BE APPROPRIATE. IF YOU DO NOT C KNOW WHICH SET TO USE, TRY BOTH AND SEE WHICH GIVES PLAUSIBLE C VALUES. C C WHERE POSSIBLE, DECIMAL, OCTAL OR HEXADECIMAL CONSTANTS ARE USED C TO SPECIFY THE CONSTANTS EXACTLY. SOMETIMES THIS REQUIRES USING C EQUIVALENT INTEGER ARRAYS. IF YOUR COMPILER USES HALF-WORD C INTEGERS BY DEFAULT (SOMETIMES CALLED INTEGER*2), YOU MAY NEED TO C CHANGE INTEGER TO INTEGER*4 OR OTHERWISE INSTRUCT YOUR COMPILER C TO USE FULL-WORD INTEGERS IN THE NEXT 5 DECLARATIONS. C C COMMENTS JUST BEFORE THE END STATEMENT (LINES STARTING WITH *) C GIVE C SOURCE FOR D1MACH. C INTEGER I INTEGER SMALL(2) INTEGER LARGE(2) INTEGER RIGHT(2) INTEGER DIVER(2) INTEGER LOG10(2) INTEGER SC C DOUBLE PRECISION DMACH(5) C EQUIVALENCE (DMACH(1),SMALL(1)) EQUIVALENCE (DMACH(2),LARGE(1)) EQUIVALENCE (DMACH(3),RIGHT(1)) EQUIVALENCE (DMACH(4),DIVER(1)) EQUIVALENCE (DMACH(5),LOG10(1)) C C MACHINE CONSTANTS FOR BIG-ENDIAN IEEE ARITHMETIC (BINARY FORMAT) C MACHINES IN WHICH THE MOST SIGNIFICANT BYTE IS STORED FIRST, C SUCH AS THE AT&T 3B SERIES, MOTOROLA 68000 BASED MACHINES (E.G. C SUN 3), AND MACHINES THAT USE SPARC, HP, OR IBM RISC CHIPS. C C DATA SMALL(1),SMALL(2) / 1048576, 0 / C DATA LARGE(1),LARGE(2) / 2146435071, -1 / C DATA RIGHT(1),RIGHT(2) / 1017118720, 0 / C DATA DIVER(1),DIVER(2) / 1018167296, 0 / C DATA LOG10(1),LOG10(2) / 1070810131, 1352628735 /, SC/987/ c This is the modified part. Using DATA sometimes causes c confusion to some compilers, while the assignment c statement has no problem with it. SMALL(1) = 1048576 SMALL(2) = 0 LARGE(1) = 2146435071 LARGE(2) = -1 RIGHT(1) = 1017118720 RIGHT(2) = 0 DIVER(1) = 1018167296 DIVER(2) = 0 LOG10(1) = 1070810131 LOG10(2) = 1352628735 SC = 987 C C MACHINE CONSTANTS FOR LITTLE-ENDIAN (BINARY) IEEE ARITHMETIC C MACHINES IN WHICH THE LEAST SIGNIFICANT BYTE IS STORED FIRST, C E.G. IBM PCS AND OTHER MACHINES THAT USE INTEL 80X87 OR DEC C ALPHA CHIPS. C C DATA SMALL(1),SMALL(2) / 0, 1048576 / C DATA LARGE(1),LARGE(2) / -1, 2146435071 / C DATA RIGHT(1),RIGHT(2) / 0, 1017118720 / C DATA DIVER(1),DIVER(2) / 0, 1018167296 / C DATA LOG10(1),LOG10(2) / 1352628735, 1070810131 /, SC/987/ C C MACHINE CONSTANTS FOR AMDAHL MACHINES. C C DATA SMALL(1),SMALL(2) / 1048576, 0 / C DATA LARGE(1),LARGE(2) / 2147483647, -1 / C DATA RIGHT(1),RIGHT(2) / 856686592, 0 / C DATA DIVER(1),DIVER(2) / 873463808, 0 / C DATA LOG10(1),LOG10(2) / 1091781651, 1352628735 /, SC/987/ C C MACHINE CONSTANTS FOR THE BURROUGHS 1700 SYSTEM. C C DATA SMALL(1) / ZC00800000 / C DATA SMALL(2) / Z000000000 / C C DATA LARGE(1) / ZDFFFFFFFF / C DATA LARGE(2) / ZFFFFFFFFF / C C DATA RIGHT(1) / ZCC5800000 / C DATA RIGHT(2) / Z000000000 / C C DATA DIVER(1) / ZCC6800000 / C DATA DIVER(2) / Z000000000 / C C DATA LOG10(1) / ZD00E730E7 / C DATA LOG10(2) / ZC77800DC0 /, SC/987/ C C MACHINE CONSTANTS FOR THE BURROUGHS 5700 SYSTEM. C C DATA SMALL(1) / O1771000000000000 / C DATA SMALL(2) / O0000000000000000 / C C DATA LARGE(1) / O0777777777777777 / C DATA LARGE(2) / O0007777777777777 / C C DATA RIGHT(1) / O1461000000000000 / C DATA RIGHT(2) / O0000000000000000 / C C DATA DIVER(1) / O1451000000000000 / C DATA DIVER(2) / O0000000000000000 / C C DATA LOG10(1) / O1157163034761674 / C DATA LOG10(2) / O0006677466732724 /, SC/987/ C C MACHINE CONSTANTS FOR THE BURROUGHS 6700/7700 SYSTEMS. C C DATA SMALL(1) / O1771000000000000 / C DATA SMALL(2) / O7770000000000000 / C C DATA LARGE(1) / O0777777777777777 / C DATA LARGE(2) / O7777777777777777 / C C DATA RIGHT(1) / O1461000000000000 / C DATA RIGHT(2) / O0000000000000000 / C C DATA DIVER(1) / O1451000000000000 / C DATA DIVER(2) / O0000000000000000 / C C DATA LOG10(1) / O1157163034761674 / C DATA LOG10(2) / O0006677466732724 /, SC/987/ C C MACHINE CONSTANTS FOR FTN4 ON THE CDC 6000/7000 SERIES. C C DATA SMALL(1) / 00564000000000000000B / C DATA SMALL(2) / 00000000000000000000B / C C DATA LARGE(1) / 37757777777777777777B / C DATA LARGE(2) / 37157777777777777774B / C C DATA RIGHT(1) / 15624000000000000000B / C DATA RIGHT(2) / 00000000000000000000B / C C DATA DIVER(1) / 15634000000000000000B / C DATA DIVER(2) / 00000000000000000000B / C C DATA LOG10(1) / 17164642023241175717B / C DATA LOG10(2) / 16367571421742254654B /, SC/987/ C C MACHINE CONSTANTS FOR FTN5 ON THE CDC 6000/7000 SERIES. C C DATA SMALL(1) / O"00564000000000000000" / C DATA SMALL(2) / O"00000000000000000000" / C C DATA LARGE(1) / O"37757777777777777777" / C DATA LARGE(2) / O"37157777777777777774" / C C DATA RIGHT(1) / O"15624000000000000000" / C DATA RIGHT(2) / O"00000000000000000000" / C C DATA DIVER(1) / O"15634000000000000000" / C DATA DIVER(2) / O"00000000000000000000" / C C DATA LOG10(1) / O"17164642023241175717" / C DATA LOG10(2) / O"16367571421742254654" /, SC/987/ C C MACHINE CONSTANTS FOR CONVEX C-1 C C DATA SMALL(1),SMALL(2) / '00100000'X, '00000000'X / C DATA LARGE(1),LARGE(2) / '7FFFFFFF'X, 'FFFFFFFF'X / C DATA RIGHT(1),RIGHT(2) / '3CC00000'X, '00000000'X / C DATA DIVER(1),DIVER(2) / '3CD00000'X, '00000000'X / C DATA LOG10(1),LOG10(2) / '3FF34413'X, '509F79FF'X /, SC/987/ C C MACHINE CONSTANTS FOR THE CRAY 1, XMP, 2, AND 3. C C DATA SMALL(1) / 201354000000000000000B / C DATA SMALL(2) / 000000000000000000000B / C C DATA LARGE(1) / 577767777777777777777B / C DATA LARGE(2) / 000007777777777777776B / C C DATA RIGHT(1) / 376434000000000000000B / C DATA RIGHT(2) / 000000000000000000000B / C C DATA DIVER(1) / 376444000000000000000B / C DATA DIVER(2) / 000000000000000000000B / C C DATA LOG10(1) / 377774642023241175717B / C DATA LOG10(2) / 000007571421742254654B /, SC/987/ C C MACHINE CONSTANTS FOR THE DATA GENERAL ECLIPSE S/200 C C SMALL, LARGE, RIGHT, DIVER, LOG10 SHOULD BE DECLARED C INTEGER SMALL(4), LARGE(4), RIGHT(4), DIVER(4), LOG10(4) C C NOTE - IT MAY BE APPROPRIATE TO INCLUDE THE FOLLOWING LINE - C STATIC DMACH(5) C C DATA SMALL/20K,3*0/,LARGE/77777K,3*177777K/ C DATA RIGHT/31420K,3*0/,DIVER/32020K,3*0/ C DATA LOG10/40423K,42023K,50237K,74776K/, SC/987/ C C MACHINE CONSTANTS FOR THE HARRIS SLASH 6 AND SLASH 7 C C DATA SMALL(1),SMALL(2) / '20000000, '00000201 / C DATA LARGE(1),LARGE(2) / '37777777, '37777577 / C DATA RIGHT(1),RIGHT(2) / '20000000, '00000333 / C DATA DIVER(1),DIVER(2) / '20000000, '00000334 / C DATA LOG10(1),LOG10(2) / '23210115, '10237777 /, SC/987/ C C MACHINE CONSTANTS FOR THE HONEYWELL DPS 8/70 SERIES. C C DATA SMALL(1),SMALL(2) / O402400000000, O000000000000 / C DATA LARGE(1),LARGE(2) / O376777777777, O777777777777 / C DATA RIGHT(1),RIGHT(2) / O604400000000, O000000000000 / C DATA DIVER(1),DIVER(2) / O606400000000, O000000000000 / C DATA LOG10(1),LOG10(2) / O776464202324, O117571775714 /, SC/987/ C C MACHINE CONSTANTS FOR THE IBM 360/370 SERIES, C THE XEROX SIGMA 5/7/9 AND THE SEL SYSTEMS 85/86. C C DATA SMALL(1),SMALL(2) / Z00100000, Z00000000 / C DATA LARGE(1),LARGE(2) / Z7FFFFFFF, ZFFFFFFFF / C DATA RIGHT(1),RIGHT(2) / Z33100000, Z00000000 / C DATA DIVER(1),DIVER(2) / Z34100000, Z00000000 / C DATA LOG10(1),LOG10(2) / Z41134413, Z509F79FF /, SC/987/ C C MACHINE CONSTANTS FOR THE INTERDATA 8/32 C WITH THE UNIX SYSTEM FORTRAN 77 COMPILER. C C FOR THE INTERDATA FORTRAN VII COMPILER REPLACE C THE Z'S SPECIFYING HEX CONSTANTS WITH Y'S. C C DATA SMALL(1),SMALL(2) / Z'00100000', Z'00000000' / C DATA LARGE(1),LARGE(2) / Z'7EFFFFFF', Z'FFFFFFFF' / C DATA RIGHT(1),RIGHT(2) / Z'33100000', Z'00000000' / C DATA DIVER(1),DIVER(2) / Z'34100000', Z'00000000' / C DATA LOG10(1),LOG10(2) / Z'41134413', Z'509F79FF' /, SC/987/ C C MACHINE CONSTANTS FOR THE PDP-10 (KA PROCESSOR). C C DATA SMALL(1),SMALL(2) / "033400000000, "000000000000 / C DATA LARGE(1),LARGE(2) / "377777777777, "344777777777 / C DATA RIGHT(1),RIGHT(2) / "113400000000, "000000000000 / C DATA DIVER(1),DIVER(2) / "114400000000, "000000000000 / C DATA LOG10(1),LOG10(2) / "177464202324, "144117571776 /, SC/987/ C C MACHINE CONSTANTS FOR THE PDP-10 (KI PROCESSOR). C C DATA SMALL(1),SMALL(2) / "000400000000, "000000000000 / C DATA LARGE(1),LARGE(2) / "377777777777, "377777777777 / C DATA RIGHT(1),RIGHT(2) / "103400000000, "000000000000 / C DATA DIVER(1),DIVER(2) / "104400000000, "000000000000 / C DATA LOG10(1),LOG10(2) / "177464202324, "047674776746 /, SC/987/ C C MACHINE CONSTANTS FOR PDP-11 FORTRANS SUPPORTING C 32-BIT INTEGERS (EXPRESSED IN INTEGER AND OCTAL). C C DATA SMALL(1),SMALL(2) / 8388608, 0 / C DATA LARGE(1),LARGE(2) / 2147483647, -1 / C DATA RIGHT(1),RIGHT(2) / 612368384, 0 / C DATA DIVER(1),DIVER(2) / 620756992, 0 / C DATA LOG10(1),LOG10(2) / 1067065498, -2063872008 /, SC/987/ C C DATA SMALL(1),SMALL(2) / O00040000000, O00000000000 / C DATA LARGE(1),LARGE(2) / O17777777777, O37777777777 / C DATA RIGHT(1),RIGHT(2) / O04440000000, O00000000000 / C DATA DIVER(1),DIVER(2) / O04500000000, O00000000000 / C DATA LOG10(1),LOG10(2) / O07746420232, O20476747770 /, SC/987/ C C MACHINE CONSTANTS FOR PDP-11 FORTRANS SUPPORTING C 16-BIT INTEGERS (EXPRESSED IN INTEGER AND OCTAL). C C SMALL, LARGE, RIGHT, DIVER, LOG10 SHOULD BE DECLARED C INTEGER SMALL(4), LARGE(4), RIGHT(4), DIVER(4), LOG10(4) C C DATA SMALL(1),SMALL(2) / 128, 0 / C DATA SMALL(3),SMALL(4) / 0, 0 / C C DATA LARGE(1),LARGE(2) / 32767, -1 / C DATA LARGE(3),LARGE(4) / -1, -1 / C C DATA RIGHT(1),RIGHT(2) / 9344, 0 / C DATA RIGHT(3),RIGHT(4) / 0, 0 / C C DATA DIVER(1),DIVER(2) / 9472, 0 / C DATA DIVER(3),DIVER(4) / 0, 0 / C C DATA LOG10(1),LOG10(2) / 16282, 8346 / C DATA LOG10(3),LOG10(4) / -31493, -12296 /, SC/987/ C C DATA SMALL(1),SMALL(2) / O000200, O000000 / C DATA SMALL(3),SMALL(4) / O000000, O000000 / C C DATA LARGE(1),LARGE(2) / O077777, O177777 / C DATA LARGE(3),LARGE(4) / O177777, O177777 / C C DATA RIGHT(1),RIGHT(2) / O022200, O000000 / C DATA RIGHT(3),RIGHT(4) / O000000, O000000 / C C DATA DIVER(1),DIVER(2) / O022400, O000000 / C DATA DIVER(3),DIVER(4) / O000000, O000000 / C C DATA LOG10(1),LOG10(2) / O037632, O020232 / C DATA LOG10(3),LOG10(4) / O102373, O147770 /, SC/987/ C C MACHINE CONSTANTS FOR THE PRIME 50 SERIES SYSTEMS C WITH 32-BIT INTEGERS AND 64V MODE INSTRUCTIONS, C SUPPLIED BY IGOR BRAY. C C DATA SMALL(1),SMALL(2) / :10000000000, :00000100001 / C DATA LARGE(1),LARGE(2) / :17777777777, :37777677775 / C DATA RIGHT(1),RIGHT(2) / :10000000000, :00000000122 / C DATA DIVER(1),DIVER(2) / :10000000000, :00000000123 / C DATA LOG10(1),LOG10(2) / :11504046501, :07674600177 /, SC/987/ C C MACHINE CONSTANTS FOR THE SEQUENT BALANCE 8000 C C DATA SMALL(1),SMALL(2) / $00000000, $00100000 / C DATA LARGE(1),LARGE(2) / $FFFFFFFF, $7FEFFFFF / C DATA RIGHT(1),RIGHT(2) / $00000000, $3CA00000 / C DATA DIVER(1),DIVER(2) / $00000000, $3CB00000 / C DATA LOG10(1),LOG10(2) / $509F79FF, $3FD34413 /, SC/987/ C C MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES. C C DATA SMALL(1),SMALL(2) / O000040000000, O000000000000 / C DATA LARGE(1),LARGE(2) / O377777777777, O777777777777 / C DATA RIGHT(1),RIGHT(2) / O170540000000, O000000000000 / C DATA DIVER(1),DIVER(2) / O170640000000, O000000000000 / C DATA LOG10(1),LOG10(2) / O177746420232, O411757177572 /, SC/987/ C C MACHINE CONSTANTS FOR THE VAX UNIX F77 COMPILER C C DATA SMALL(1),SMALL(2) / 128, 0 / C DATA LARGE(1),LARGE(2) / -32769, -1 / C DATA RIGHT(1),RIGHT(2) / 9344, 0 / C DATA DIVER(1),DIVER(2) / 9472, 0 / C DATA LOG10(1),LOG10(2) / 546979738, -805796613 /, SC/987/ C C MACHINE CONSTANTS FOR THE VAX-11 WITH C FORTRAN IV-PLUS COMPILER C C DATA SMALL(1),SMALL(2) / Z00000080, Z00000000 / C DATA LARGE(1),LARGE(2) / ZFFFF7FFF, ZFFFFFFFF / C DATA RIGHT(1),RIGHT(2) / Z00002480, Z00000000 / C DATA DIVER(1),DIVER(2) / Z00002500, Z00000000 / C DATA LOG10(1),LOG10(2) / Z209A3F9A, ZCFF884FB /, SC/987/ C C MACHINE CONSTANTS FOR VAX/VMS VERSION 2.2 C C DATA SMALL(1),SMALL(2) / '80'X, '0'X / C DATA LARGE(1),LARGE(2) / 'FFFF7FFF'X, 'FFFFFFFF'X / C DATA RIGHT(1),RIGHT(2) / '2480'X, '0'X / C DATA DIVER(1),DIVER(2) / '2500'X, '0'X / C DATA LOG10(1),LOG10(2) / '209A3F9A'X, 'CFF884FB'X /, SC/987/ C C *** ISSUE STOP 779 IF ALL DATA STATEMENTS ARE COMMENTED... IF (SC .NE. 987) STOP 779 C *** ISSUE STOP 778 IF ALL DATA STATEMENTS ARE OBVIOUSLY WRONG... IF (DMACH(4) .GE. 1.0D0) STOP 778 IF (I .LT. 1 .OR. I .GT. 5) GOTO 999 D1MACH = DMACH(I) RETURN 999 WRITE(*,1999) I 1999 FORMAT(' D1MACH - I OUT OF BOUNDS',I10) STOP 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(*),dy(*),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 dcopy(n,dx,incx,dy,incy) c c copies a vector, x, to a vector, y. c uses unrolled loops for increments equal to one. c jack dongarra, linpack, 3/11/78. c double precision dx(*),dy(*) integer i,incx,incy,ix,iy,m,mp1,n c 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 dy(iy) = 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,7) if( m .eq. 0 ) go to 40 do 30 i = 1,m dy(i) = dx(i) 30 continue if( n .lt. 7 ) return 40 mp1 = m + 1 do 50 i = mp1,n,7 dy(i) = dx(i) dy(i + 1) = dx(i + 1) dy(i + 2) = dx(i + 2) dy(i + 3) = dx(i + 3) dy(i + 4) = dx(i + 4) dy(i + 5) = dx(i + 5) dy(i + 6) = dx(i + 6) 50 continue return end SUBROUTINE DDAINI (X, Y, YPRIME, NEQ, RES, JAC, H, WT, IDID, RPAR, + IPAR, PHI, DELTA, E, WM, IWM, HMIN, UROUND, NONNEG, NTEMP) C***BEGIN PROLOGUE DDAINI C***SUBSIDIARY C***PURPOSE Initialization routine for DDASSL. C***LIBRARY SLATEC (DASSL) C***TYPE DOUBLE PRECISION (SDAINI-S, DDAINI-D) C***AUTHOR PETZOLD, LINDA R., (LLNL) c----------------------------------------------------------------------- c This routine has been modified for the purpose of scaling the c interation matrix. c c----------------------------------------------------------------------- c c Last modified by Rong Wang, September 4, 2001. c c----------------------------------------------------------------------- C***DESCRIPTION C----------------------------------------------------------------- C DDAINI TAKES ONE STEP OF SIZE H OR SMALLER C WITH THE BACKWARD EULER METHOD, TO C FIND YPRIME. X AND Y ARE UPDATED TO BE CONSISTENT WITH THE C NEW STEP. A MODIFIED DAMPED NEWTON ITERATION IS USED TO C SOLVE THE CORRECTOR ITERATION. C C THE INITIAL GUESS FOR 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(X,Y,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***ROUTINES CALLED DDAJAC, DDANRM, DDASLV C***REVISION HISTORY (YYMMDD) C 830315 DATE WRITTEN C 901009 Finished conversion to SLATEC 4.0 format (F.N.Fritsch) C 901019 Merged changes made by C. Ulrich with SLATEC 4.0 format. C 901026 Added explicit declarations for all variables and minor C cosmetic changes to prologue. (FNF) C 901030 Minor corrections to declarations. (FNF) C***END PROLOGUE DDAINI C INTEGER NEQ, IDID, IPAR(*), IWM(*), NONNEG, NTEMP DOUBLE PRECISION * X, Y(*), YPRIME(*), H, WT(*), RPAR(*), PHI(NEQ,*), DELTA(*), * E(*), WM(*), HMIN, UROUND EXTERNAL RES, JAC C EXTERNAL DDAJAC, DDANRM, DDASLV DOUBLE PRECISION DDANRM C INTEGER I, IER, IRES, JCALC, LNJE, LNRE, M, MAXIT, MJAC, NCF, * NEF, NSF DOUBLE PRECISION * CJ, DAMP, DELNRM, ERR, OLDNRM, R, RATE, S, XOLD, YNORM LOGICAL CONVGD C PARAMETER (LNRE=12) PARAMETER (LNJE=13) C DATA MAXIT/10/,MJAC/5/ DATA DAMP/0.75D0/ C C C--------------------------------------------------- C BLOCK 1. C INITIALIZATIONS. C--------------------------------------------------- C C***FIRST EXECUTABLE STATEMENT DDAINI IDID=1 NEF=0 NCF=0 NSF=0 XOLD=X 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 BLOCK 2. C DO ONE BACKWARD EULER STEP. C---------------------------------------------------- C C SET UP FOR START OF CORRECTOR ITERATION 200 CJ=1.0D0/H X=X+H C C PREDICT SOLUTION AND DERIVATIVE 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(X,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,X,Y,YPRIME,DELTA,CJ,H, * IER,WT,E,WM,IWM,RES,IRES, * UROUND,JAC,RPAR,IPAR,NTEMP) C S=1000000.D0 IF (IRES.LT.0) GO TO 430 IF (IER.NE.0) GO TO 430 NSF=0 C C C C MULTIPLY RESIDUAL BY DAMPING FACTOR 310 CONTINUE DO 320 I=1,NEQ 320 DELTA(I)=DELTA(I)*DAMP C C COMPUTE A NEW ITERATE (BACK SUBSTITUTION) C STORE THE CORRECTION IN DELTA C c----------------------------------------------------------------------- CALL DDASLV(NEQ,DELTA,WM,IWM,CJ) c----------------------------------------------------------------------- C C UPDATE Y AND YPRIME DO 330 I=1,NEQ Y(I)=Y(I)-DELTA(I) 330 YPRIME(I)=YPRIME(I)-CJ*DELTA(I) 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/M) IF (RATE.GT.0.90D0) GO TO 430 S=RATE/(1.0D0-RATE) 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 GO TO 300 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)=MIN(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 DO 510 I=1,NEQ 510 E(I)=Y(I)-PHI(I,1) ERR=DDANRM(NEQ,E,WT,RPAR,IPAR) C IF (ERR.LE.1.0D0) RETURN C C C C-------------------------------------------------------- C BLOCK 4. C THE BACKWARD EULER STEP FAILED. RESTORE X, Y C AND YPRIME TO THEIR ORIGINAL VALUES. C REDUCE STEPSIZE AND TRY AGAIN, IF C POSSIBLE. C--------------------------------------------------------- C 600 CONTINUE X = XOLD 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.ABS(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.ABS(H).GE.HMIN) GO TO 690 IDID=-12 RETURN C 640 NEF=NEF+1 R=0.90D0/(2.0D0*ERR+0.0001D0) R=MAX(0.1D0,MIN(0.5D0,R)) H=H*R IF (ABS(H).GE.HMIN.AND.NEF.LT.10) GO TO 690 IDID=-12 RETURN 690 GO TO 200 C C-------------END OF SUBROUTINE DDAINI---------------------- END SUBROUTINE DDAJAC (NEQ, X, Y, YPRIME, DELTA, CJ, H, + IER, WT, E, WM, IWM, RES, IRES, UROUND, JAC, RPAR, + IPAR, NTEMP) c----------------------------------------------------------------------- c This routine has been modified to accept an almost block diagonal c (ABD) Jacobian matrix compatible with the linear algebra package, c COLROW. c c----------------------------------------------------------------------- c c Last modified by Rong Wang, August 13, 2001. c c----------------------------------------------------------------------- C***BEGIN PROLOGUE DDAJAC C***SUBSIDIARY C***PURPOSE Compute the iteration matrix for DDASSL and form the C LU-decomposition. C***LIBRARY SLATEC (DASSL) C***TYPE DOUBLE PRECISION (SDAJAC-S, DDAJAC-D) C***AUTHOR PETZOLD, LINDA R., (LLNL) C***DESCRIPTION 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***ROUTINES CALLED DGBFA, DGEFA C***REVISION HISTORY (YYMMDD) C 830315 DATE WRITTEN C 901009 Finished conversion to SLATEC 4.0 format (F.N.Fritsch) C 901010 Modified three MAX calls to be all on one line. (FNF) C 901019 Merged changes made by C. Ulrich with SLATEC 4.0 format. C 901026 Added explicit declarations for all variables and minor C cosmetic changes to prologue. (FNF) C 901101 Corrected PURPOSE. (FNF) C***END PROLOGUE DDAJAC C INTEGER NEQ, IER, IWM(*), IRES, IPAR(*), NTEMP DOUBLE PRECISION * X, Y(*), YPRIME(*), DELTA(*), CJ, H, WT(*), E(*), WM(*), * UROUND, RPAR(*) EXTERNAL RES, JAC C EXTERNAL DGBFA, DGEFA C INTEGER I, I1, I2, II, IPSAVE, ISAVE, J, K, L, LENPD, LIPVT, * LML, LMTYPE, LMU, MBA, MBAND, MEB1, MEBAND, MSAVE, MTYPE, N, * NPD, NPDM1, NROW DOUBLE PRECISION DEL, DELINV, SQUR, YPSAVE, YSAVE c----------------------------------------------------------------------- integer nconti parameter (nconti = 2) integer lnpde, lkcol, lnint integer npde, kcol, nint integer neq1, neq2 integer npdbk1, npdbt1 integer npdtp2, npdbk2, npdbt2 integer lipvt2 c----------------------------------------------------------------------- C PARAMETER (NPD=1) PARAMETER (LML=1) PARAMETER (LMU=2) PARAMETER (LMTYPE=4) c----------------------------------------------------------------------- parameter (lnpde = 17) parameter (lkcol = 18) parameter (lnint = 19) parameter (lipvt = 21) c----------------------------------------------------------------------- C C***FIRST EXECUTABLE STATEMENT DDAJAC 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 = SQRT(UROUND) DO 210 I=1,NEQ DEL=SQUR*MAX(ABS(Y(I)),ABS(H*YPRIME(I)),ABS(WT(I))) DEL=SIGN(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 c----------------------------------------------------------------------- 300 continue npde = iwm(lnpde) kcol = iwm(lkcol) nint = iwm(lnint) neq1 = npde * (kcol * nint + nconti) neq2 = neq1 + npde * nint npdbk1 = npd + npde * npde * nconti npdbt1 = npdbk1 + npde * npde * nint * kcol * (kcol + nconti) npdtp2 = npdbt1 + npde * npde * nconti npdbk2 = npdtp2 + npde * npde * nconti npdbt2 = npdbk2 + npde * npde * nint * (kcol + 1) * (kcol + 1 + & nconti) lipvt2 = lipvt + neq1 call jac(x,y,yprime,wm(npd),cj,rpar,ipar) call crdcmp(neq1, wm(npd), npde, 2*npde, wm(npdbk1), kcol*npde, & (kcol+nconti)*npde, nint, wm(npdbt1), npde, & iwm(lipvt), ier) call crdcmp(neq2, wm(npdtp2), npde, 2*npde, wm(npdbk2), & (kcol+1)*npde, (kcol+1+nconti)*npde, nint, & wm(npdbt2), npde, iwm(lipvt2), ier) 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=MIN(MBAND,NEQ) MEBAND=MBAND+IWM(LML) MEB1=MEBAND-1 MSAVE=(NEQ/MBAND)+1 ISAVE=NTEMP-1 IPSAVE=ISAVE+MSAVE IRES=0 SQUR=SQRT(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*MAX(ABS(Y(N)),ABS(H*YPRIME(N)),ABS(WT(N))) DEL=SIGN(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*MAX(ABS(Y(N)),ABS(H*YPRIME(N)),ABS(WT(N))) DEL=SIGN(DEL,H*YPRIME(N)) DEL=(Y(N)+DEL)-Y(N) DELINV=1.0D0/DEL I1=MAX(1,(N-IWM(LMU))) I2=MIN(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 DOUBLE PRECISION FUNCTION DDANRM (NEQ, V, WT, RPAR, IPAR) C***BEGIN PROLOGUE DDANRM C***SUBSIDIARY C***PURPOSE Compute vector norm for DDASSL. C***LIBRARY SLATEC (DASSL) C***TYPE DOUBLE PRECISION (SDANRM-S, DDANRM-D) C***AUTHOR PETZOLD, LINDA R., (LLNL) c----------------------------------------------------------------------- c c Last modified by Rong Wang, Feb 22, 2002. c c----------------------------------------------------------------------- C***DESCRIPTION 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***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C 830315 DATE WRITTEN C 901009 Finished conversion to SLATEC 4.0 format (F.N.Fritsch) C 901019 Merged changes made by C. Ulrich with SLATEC 4.0 format. C 901026 Added explicit declarations for all variables and minor C cosmetic changes to prologue. (FNF) C***END PROLOGUE DDANRM C INTEGER NEQ, IPAR(*) DOUBLE PRECISION V(NEQ), WT(NEQ), RPAR(*) C INTEGER I DOUBLE PRECISION SUM, VMAX C c----------------------------------------------------------------------- double precision temp integer itemp integer iwkdnm parameter (iwkdnm = 49) c rpar(ipar(iwkdnm)) is the work storage c for the modification version of the c subroutine DDANRM. c c----------------------------------------------------------------------- C***FIRST EXECUTABLE STATEMENT DDANRM DDANRM = 0.0D0 VMAX = 0.0D0 itemp = ipar(iwkdnm) - 1 DO 10 I = 1,NEQ c----------------------------------------------------------------------- itemp = itemp + 1 rpar(itemp) = abs(v(i)/wt(i)) if (rpar(itemp) .gt. vmax) vmax = rpar(itemp) c----------------------------------------------------------------------- 10 CONTINUE IF(VMAX .LE. 0.0D0) GO TO 30 SUM = 0.0D0 c----------------------------------------------------------------------- itemp = ipar(iwkdnm) - 1 c----------------------------------------------------------------------- DO 20 I = 1,NEQ c----------------------------------------------------------------------- itemp = itemp + 1 temp = rpar(itemp)/vmax sum = sum + temp * temp 20 continue c----------------------------------------------------------------------- DDANRM = VMAX*SQRT(SUM/NEQ) 30 CONTINUE RETURN C------END OF FUNCTION DDANRM------ END SUBROUTINE DDASLV (NEQ, DELTA, WM, IWM, CJ) c----------------------------------------------------------------------- c This routine has been modified to accept an almost block diagonal c (ABD) Jacobian matrix compatible with the linear algebra package, c COLROW. c c----------------------------------------------------------------------- c c Last modified by Rong Wang, September 4, 2001. c c----------------------------------------------------------------------- C***BEGIN PROLOGUE DDASLV C***SUBSIDIARY C***PURPOSE Linear system solver for DDASSL. C***LIBRARY SLATEC (DASSL) C***TYPE DOUBLE PRECISION (SDASLV-S, DDASLV-D) C***AUTHOR PETZOLD, LINDA R., (LLNL) C***DESCRIPTION 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***ROUTINES CALLED DGBSL, DGESL C***REVISION HISTORY (YYMMDD) C 830315 DATE WRITTEN C 901009 Finished conversion to SLATEC 4.0 format (F.N.Fritsch) C 901019 Merged changes made by C. Ulrich with SLATEC 4.0 format. C 901026 Added explicit declarations for all variables and minor C cosmetic changes to prologue. (FNF) C***END PROLOGUE DDASLV C INTEGER NEQ, IWM(*) DOUBLE PRECISION DELTA(*), WM(*) C EXTERNAL DGBSL, DGESL C INTEGER LIPVT, LML, LMU, LMTYPE, MEBAND, MTYPE, NPD c----------------------------------------------------------------------- double precision cj integer nconti parameter (nconti = 2) integer lnpde, lkcol, lnint integer npde, kcol, nint integer neq1 integer npdbk1, npdbt1 integer npdtp2, npdbk2, npdbt2 integer lipvt2 c----------------------------------------------------------------------- PARAMETER (NPD=1) PARAMETER (LML=1) PARAMETER (LMU=2) PARAMETER (LMTYPE=4) c----------------------------------------------------------------------- parameter (lnpde = 17) parameter (lkcol = 18) parameter (lnint = 19) parameter (lipvt = 21) c----------------------------------------------------------------------- C C***FIRST EXECUTABLE STATEMENT DDASLV 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 c----------------------------------------------------------------------- npde = iwm(lnpde) kcol = iwm(lkcol) nint = iwm(lnint) neq1 = npde * (kcol * nint + nconti) npdbk1 = npd + npde * npde * nconti npdbt1 = npdbk1 + npde * npde * nint * kcol * (kcol + nconti) npdtp2 = npdbt1 + npde * npde * nconti npdbk2 = npdtp2 + npde * npde * nconti npdbt2 = npdbk2 + npde * npde * nint * (kcol + 1) * (kcol + 1 + & nconti) lipvt2 = lipvt + neq1 call dscal(npde, cj, delta, 1) call dscal(npde, cj, delta(neq1-npde+1), 1) call crslve(wm(npd), npde, 2*npde, wm(npdbk1), kcol*npde, & (kcol+nconti)*npde, nint, wm(npdbt1), npde, & iwm(lipvt), delta, 0) call dscal(npde, cj, delta(neq1+1), 1) call dscal(npde, cj, delta(neq-npde+1), 1) call crslve(wm(npdtp2), npde, 2*npde, wm(npdbk2), & (kcol+1)*npde, (kcol+1+nconti)*npde, nint, & wm(npdbt2), npde, iwm(lipvt2), delta(neq1+1), 0) c----------------------------------------------------------------------- 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 DDASSL (RES, NEQ, T, Y, YPRIME, TOUT, INFO, RTOL, ATOL, + IDID, RWORK, LRW, IWORK, LIW, RPAR, IPAR, JAC) c----------------------------------------------------------------------- c This routine has been modified to accept an almost block diagonal c (ABD) Jacobian matrix compatible with the linear algebra package, c COLROW, and the dimension of atol and rtol (if a vector is used) c is modified from neq to npde to save the storage. c c The modification to the DASSL package to accommodate the ABD c linear algebra is limited to the routines: c c DASSL, DAJAC, and DASLV. c c The modification to atol and rtol is limited to the routines: c c DASSL, DAWTS. c c The modification to interation matrix for overcoming the c condition number problem in a index-1 DAE is limited to the c routines: c c DAINI, DASTP, DASLV (because the calling c sequence of DASLV is c modified) c c This is a result of the design of DASSL which allows the user to c specify his or her own linear algebra factorization and solve c routines. c c However, due to undeclared variables (using implicit versus c explicit declarations), the following routines have been changed: c c XERMSG, XERPRN, XGETUA, AND XSETUA. c c Modifications will be separated by comment lines with a "c" c followed by 71 "-"'s. c c----------------------------------------------------------------------- c c Last modified by Rong Wang, August 13, 2001. c c----------------------------------------------------------------------- C***BEGIN PROLOGUE DDASSL C***PURPOSE This code solves a system of differential/algebraic C equations of the form G(T,Y,YPRIME) = 0. C***LIBRARY SLATEC (DASSL) C***CATEGORY I1A2 C***TYPE DOUBLE PRECISION (SDASSL-S, DDASSL-D) C***KEYWORDS DIFFERENTIAL/ALGEBRAIC, BACKWARD DIFFERENTIATION FORMULAS, C IMPLICIT DIFFERENTIAL SYSTEMS C***AUTHOR PETZOLD, LINDA R., (LLNL) C COMPUTING AND MATHEMATICS RESEARCH DIVISION C LAWRENCE LIVERMORE NATIONAL LABORATORY C L - 316, P.O. BOX 808, C LIVERMORE, CA. 94550 C***DESCRIPTION C C *Usage: C C EXTERNAL RES, JAC C INTEGER NEQ, INFO(N), IDID, LRW, LIW, IWORK(LIW), IPAR C DOUBLE PRECISION T, Y(NEQ), YPRIME(NEQ), TOUT, RTOL, ATOL, C * RWORK(LRW), RPAR C C CALL DDASSL (RES, NEQ, T, Y, YPRIME, TOUT, INFO, RTOL, ATOL, C * IDID, RWORK, LRW, IWORK, LIW, RPAR, IPAR, JAC) C C C *Arguments: C (In the following, all real arrays should be type DOUBLE PRECISION.) C C RES:EXT This is a subroutine which you provide to define the C differential/algebraic system. C C NEQ:IN This is the number of equations to be solved. C C T:INOUT This is the current value of the independent variable. C C Y(*):INOUT This array contains the solution components at T. C C YPRIME(*):INOUT This array contains the derivatives of the solution C components at T. C C TOUT:IN This is a point at which a solution is desired. C C INFO(N):IN The basic task of the code is to solve the system from T C to TOUT and return an answer at TOUT. INFO is an integer C array which is used to communicate exactly how you want C this task to be carried out. (See below for details.) C N must be greater than or equal to 15. C C RTOL,ATOL:INOUT These quantities represent relative and absolute C error tolerances which you provide to indicate how C accurately you wish the solution to be computed. You C may choose them to be both scalars or else both vectors. C Caution: In Fortran 77, a scalar is not the same as an C array of length 1. Some compilers may object C to using scalars for RTOL,ATOL. C C IDID:OUT This scalar quantity is an indicator reporting what the C code did. You must monitor this integer variable to C decide what action to take next. C C RWORK:WORK A real work array of length LRW which provides the C code with needed storage space. C C LRW:IN The length of RWORK. (See below for required length.) C C IWORK:WORK An integer work array of length LIW which probides the C code with needed storage space. C C LIW:IN The length of IWORK. (See below for required length.) C C RPAR,IPAR:IN These are real and integer parameter arrays which C you can use for communication between your calling C program and the RES subroutine (and the JAC subroutine) C C JAC:EXT This is the name of a subroutine which you may choose C to provide for defining a matrix of partial derivatives C described below. C C Quantities which may be altered by DDASSL are: C T, Y(*), YPRIME(*), INFO(1), RTOL, ATOL, C IDID, RWORK(*) AND IWORK(*) C C *Description C C Subroutine DDASSL uses the backward differentiation formulas of C orders one through five to solve a system of the above form for Y and C YPRIME. Values for Y and YPRIME at the initial time must be given as C input. These values must be consistent, (that is, if T,Y,YPRIME are C the given initial values, they must satisfy G(T,Y,YPRIME) = 0.). The C subroutine solves the system from T to TOUT. It is easy to continue C the solution to get results at additional TOUT. This is the interval C mode of operation. Intermediate results can also be obtained easily C by using the intermediate-output capability. C C The following detailed description is divided into subsections: C 1. Input required for the first call to DDASSL. C 2. Output after any return from DDASSL. C 3. What to do to continue the integration. C 4. Error messages. C C C -------- INPUT -- WHAT TO DO ON THE FIRST CALL TO DDASSL ------------ 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 defferential/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 the NEQ C first derivatives of the solution components at the initial C point. You must dimension YPRIME at least NEQ in your C calling program. If you do not know initial values of some C of the solution 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 permissible 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 only the first C eleven entries. You must respond to all of the following C items, which are arranged as questions. The simplest use C of the code corresponds to answering all questions as yes, C 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, the code works with a full matrix of NEQ**2 C elements (stored in the conventional way). Computations C with 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 C will 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 initialHE 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 INFO(15) --DDASSL normally requires either a full or banded c Jacobian matrix. If the structure of the Jacobian c matrix is almost block diagonal (ABD) as defined by the c package COLROW, the user may chose this option to use c the linear algebra routines in order to save c storage requirements (and decrease the execution time). c In the case of an ABD Jacobian matrix, the user MUST c supply the routine JAC to define the analytic ABD c Jacobian matrix, since a finite difference ABD Jacobian c approximation routine has not been developed yet. Thus c INFO(5) will be ignored if the ABD linear algebra option c is chosen. c **** Is the Jacobian matrix full or banded? c Yes - Set INFO(15) = 0 c No - Set INFO(15) = 1 c and define the ABD structure by setting c IWORK(17) = npde, IWORK(18) = kcol, c IWORK(19) = nint. c----------------------------------------------------------------------- C C RTOL, ATOL -- You must assign relative (RTOL) and absolute (ATOL C error tolerances to tell the code how accurately you C want the solution to be computed. They must be defined C as variables because the code may change them. You C have two 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 C test 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 C true solution of the initial value problem and the C computed approximation. Practically all present day C codes, including this one, control the local error at C each step and do not even attempt to control the global C error directly. C Usually, but not always, the true accuracy of the C computed Y is comparable to the error tolerances. This C code will usually, but not always, deliver a more C accurate solution if you reduce the tolerances and C integrate again. By comparing two such solutions you C can get a fairly reliable idea of the true error in the C solution at the 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 C absolute error test on that component. A mixed test C with non-zero RTOL and ATOL corresponds roughly to a C relative error test when the solution component is much C bigger than ATOL and to an absolute error test when the C solution component is smaller than the threshhold ATOL. C C The code will not attempt to compute a solution at an C accuracy unreasonable for the machine being used. It will 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 For the case of a user-defined ABD Jacobian c (when INFO(15) = 1), we require that c c lrw = 40 + (IWORK(LMXORD) + 4) * NEQ + c npde * npde * (nconti + c nint * kcol * (kcol + nconti) + nconti) c npde * npde * (nconti + c nint * (kcol + 1) * (kcol + 1 + nconti) c + nconti) c c---------------------------------------------------------------------- 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, C ignore these parameters by treating them as dummy C arguments. If you do choose to use them, dimension C them in your calling program and in RES (and in JAC) C as arrays of appropriate 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 SUBROUTINE 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 component, 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 EXTERNAL statement in C your program that calls DDASSL. You must dimension Y, C YPRIME and PD 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 Give PD a first dimension of NEQ. 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 C of ML and MU) *** C Give PD a first dimension of 2*ML+MU+1. 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 C RPAR and IPAR are real and integer parameter arrays C which 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, C ignore these parameters by treating them as dummy C arguments. If you do choose to use them, dimension C them in your calling program and in JAC as arrays of C appropriate length. C C C OPTIONALLY REPLACEABLE NORM ROUTINE: C 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 TSTOP was successfully C completed (T=TSTOP) by stepping exactly to TSTOP. 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 C be appropriate for continuing the integration. However, C the reported solution at T was obtained using the input C values 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 C far. 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 C 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 -------- 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 beyond 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 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 C or ill-conditioned JACOBIAN may be the problem. If C you 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 IDID = -13,..,-32 --- Cannot occur with this code. C C C *** Following a terminated task *** C C If IDID= -33, you cannot continue the solution of this problem. C An attempt to do so will result in your C run being terminated. C C C -------- ERROR MESSAGES --------------------------------------------- C C The SLATEC error print routine XERMSG is called in the event of C unsuccessful completion of a task. Most of these are treated as C "recoverable errors", which means that (unless the user has directed C otherwise) control will be returned to the calling program for C possible action after the message has been printed. C C In the event of a negative value of IDID other than -33, an appro- C priate message is printed and the "error number" printed by XERMSG C is the value of IDID. There are quite a number of illegal input C errors that can lead to a returned value IDID=-33. The conditions C and their printed "error numbers" are as follows: C C Error number Condition C C 1 Some element of INFO vector is not zero or one. C 2 NEQ .le. 0 C 3 MAXORD not in range. C 4 LRW is less than the required length for RWORK. C 5 LIW is less than the required length for IWORK. C 6 Some element of RTOL is .lt. 0 C 7 Some element of ATOL is .lt. 0 C 8 All elements of RTOL and ATOL are zero. C 9 INFO(4)=1 and TSTOP is behind TOUT. C 10 HMAX .lt. 0.0 C 11 TOUT is behind T. C 12 INFO(8)=1 and H0=0.0 C 13 Some element of WT is .le. 0.0 C 14 TOUT is too close to T to start integration. C 15 INFO(4)=1 and TSTOP is behind T. C 16 --( Not used in this version )-- C 17 ML illegal. Either .lt. 0 or .gt. NEQ C 18 MU illegal. Either .lt. 0 or .gt. NEQ C 19 TOUT = T. C C If DDASSL is called again without any action taken to remove the C cause of an unsuccessful return, XERMSG will be called with a fatal C error flag, which will cause unconditional termination of the C program. There are two such fatal errors: C C Error number -998: The last step was terminated with a negative C value of IDID other than -33, and no appropriate action was C taken. C C Error number -999: The previous call was terminated because of C illegal input (IDID=-33) and there is illegal input in the C present call, as well. (Suspect infinite loop.) 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 D1MACH, DDAINI, DDANRM, DDASTP, DDATRP, DDAWTS, C XERMSG C***REVISION HISTORY (YYMMDD) C 830315 DATE WRITTEN C 880387 Code changes made. All common statements have been C replaced by a DATA statement, which defines pointers into C RWORK, and PARAMETER statements which define pointers C into IWORK. As well the documentation has gone through C grammatical changes. C 881005 The prologue has been changed to mixed case. C The subordinate routines had revision dates changed to C this date, although the documentation for these routines C is all upper case. No code changes. C 890511 Code changes made. The DATA statement in the declaration C section of DDASSL was replaced with a PARAMETER C statement. Also the statement S = 100.D0 was removed C from the top of the Newton iteration in DDASTP. C The subordinate routines had revision dates changed to C this date. C 890517 The revision date syntax was replaced with the revision C history syntax. Also the "DECK" comment was added to C the top of all subroutines. These changes are consistent C with new SLATEC guidelines. C The subordinate routines had revision dates changed to C this date. No code changes. C 891013 Code changes made. C Removed all occurrances of FLOAT or DBLE. All operations C are now performed with "mixed-mode" arithmetic. C Also, specific function names were replaced with generic C function names to be consistent with new SLATEC guidelines. C In particular: C Replaced DSQRT with SQRT everywhere. C Replaced DABS with ABS everywhere. C Replaced DMIN1 with MIN everywhere. C Replaced MIN0 with MIN everywhere. C Replaced DMAX1 with MAX everywhere. C Replaced MAX0 with MAX everywhere. C Replaced DSIGN with SIGN everywhere. C Also replaced REVISION DATE with REVISION HISTORY in all C subordinate routines. C 901004 Miscellaneous changes to prologue to complete conversion C to SLATEC 4.0 format. No code changes. (F.N.Fritsch) C 901009 Corrected GAMS classification code and converted subsidiary C routines to 4.0 format. No code changes. (F.N.Fritsch) C 901010 Converted XERRWV calls to XERMSG calls. (R.Clemens,AFWL) C 901019 Code changes made. C Merged SLATEC 4.0 changes with previous changes made C by C. Ulrich. Below is a history of the changes made by C C. Ulrich. (Changes in subsidiary routines are implied C by this history) C 891228 Bug was found and repaired inside the DDASSL C and DDAINI routines. DDAINI was incorrectly C returning the initial T with Y and YPRIME C computed at T+H. The routine now returns T+H C rather than the initial T. C Cosmetic changes made to DDASTP. C 900904 Three modifications were made to fix a bug (inside C DDASSL) re interpolation for continuation calls and C cases where TN is very close to TSTOP: C C 1) In testing for whether H is too large, just C compare H to (TSTOP - TN), rather than C (TSTOP - TN) * (1-4*UROUND), and set H to C TSTOP - TN. This will force DDASTP to step C exactly to TSTOP under certain situations C (i.e. when H returned from DDASTP would otherwise C take TN beyond TSTOP). C C 2) Inside the DDASTP loop, interpolate exactly to C TSTOP if TN is very close to TSTOP (rather than C interpolating to within roundoff of TSTOP). C C 3) Modified IDID description for IDID = 2 to say that C the solution is returned by stepping exactly to C TSTOP, rather than TOUT. (In some cases the C solution is actually obtained by extrapolating C over a distance near unit roundoff to TSTOP, C but this small distance is deemed acceptable in C these circumstances.) C 901026 Added explicit declarations for all variables and minor C cosmetic changes to prologue, removed unreferenced labels, C and improved XERMSG calls. (FNF) C 901030 Added ERROR MESSAGES section and reworked other sections to C be of more uniform format. (FNF) C 910624 Fixed minor bug related to HMAX (five lines ending in C statement 526 in DDASSL). (LRP) C C***END PROLOGUE DDASSL C C**End C C Declare arguments. C INTEGER NEQ, INFO(15), IDID, LRW, IWORK(*), LIW, IPAR(*) DOUBLE PRECISION * T, Y(*), YPRIME(*), TOUT, RTOL(*), ATOL(*), RWORK(*), * RPAR(*) EXTERNAL RES, JAC C C Declare externals. C EXTERNAL D1MACH, DDAINI, DDANRM, DDASTP, DDATRP, DDAWTS, XERMSG DOUBLE PRECISION D1MACH, DDANRM C C Declare local variables. C INTEGER I, ITEMP, LALPHA, LBETA, LCJ, LCJOLD, LDELTA, * LENIW, LENPD, LENRW, LE, LGAMMA, LH, LHMAX, LHOLD, * LJCALC, LK, LKOLD, LIWM, LML, LMTYPE, LMU, LMXORD, LNJE, LNPD, * LNRE, LNS, LNST, LNSTL, LPD, LPHASE, LPHI, LPSI, LROUND, LS, * LSIGMA, LTN, LTSTOP, LWM, LWT, MBAND, MSAVE, MXORD, NPD, NTEMP, * NZFLG c----------------------------------------------------------------------- integer lcjsca integer lnpde, lkcol, lnint, nconti integer npde, kcol, nint parameter (nconti = 2) c----------------------------------------------------------------------- DOUBLE PRECISION * ATOLI, H, HMAX, HMIN, HO, R, RH, RTOLI, TDIST, TN, TNEXT, * TSTOP, UROUND, YPNORM LOGICAL DONE C Auxiliary variables for conversion of values to be included in C error messages. CHARACTER*8 XERN1, XERN2 CHARACTER*16 XERN3, XERN4 C C SET POINTERS INTO IWORK PARAMETER (LML=1, LMU=2, LMXORD=3, LMTYPE=4, LNST=11, * LNRE=12, LNJE=13, LNPD=16, * LJCALC=5, LPHASE=6, LK=7, LKOLD=8, * LNS=9, LNSTL=10, LIWM=1) c----------------------------------------------------------------------- c Define the ABD related offsets. parameter (lnpde = 17) parameter (lkcol = 18) parameter (lnint = 19) c----------------------------------------------------------------------- C C SET RELATIVE OFFSET INTO RWORK PARAMETER (NPD=1) C C SET POINTERS INTO RWORK PARAMETER (LTSTOP=1, LHMAX=2, LH=3, LTN=4, * LCJ=5, LCJOLD=6, LHOLD=7, LS=8, LROUND=9, * LALPHA=11, LBETA=17, LGAMMA=23, * LPSI=29, LSIGMA=35, LDELTA=41) c----------------------------------------------------------------------- parameter (lcjsca = 10) C c upload the paramters related to an ABD Jacobian matrix. npde = iwork(lnpde) kcol = iwork(lkcol) nint = iwork(lnint) c----------------------------------------------------------------------- C***FIRST EXECUTABLE STATEMENT DDASSL 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----------------------------------------------------------------------- c Check to see whether info(15), for abd matrix, is valid. c if(info(15).ne.0.and.info(15).ne.1) go to 701 c----------------------------------------------------------------------- C IF(NEQ.LE.0)GO TO 702 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----------------------------------------------------------------------- 60 continue c Compute lenpd and lenrw with responding to an ABD Jacobian matrix. iwork(lmtype) = 3 lenpd = npde * npde * (nconti + nint * kcol * (kcol + nconti) & + nconti + nconti + nint * (kcol + 1) * (kcol + 1 & + nconti) + nconti) lenrw = 40 + (iwork(lmxord) + 4) * neq + lenpd c----------------------------------------------------------------------- C C CHECK LENGTHS OF RWORK AND IWORK LENIW=20+NEQ IWORK(LNPD)=LENPD 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 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. WRITE (XERN1, '(I8)') IDID CALL XERMSG ('SLATEC', 'DDASSL', * 'THE LAST STEP TERMINATED WITH A NEGATIVE VALUE OF IDID = ' // * XERN1 // ' AND NO APPROPRIATE ACTION WAS TAKEN. ' // * 'RUN TERMINATED', -998, 2) 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) c----------------------------------------------------------------------- DO 210 I=1,NPDE c----------------------------------------------------------------------- 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 NTEMP=NPD+IWORK(LNPD) 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 TN=T IDID=1 C C SET ERROR WEIGHT VECTOR WT c----------------------------------------------------------------------- CALL DDAWTS(INFO(2),RTOL,ATOL,Y,RWORK(LWT),RPAR,IPAR) c----------------------------------------------------------------------- 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*MAX(ABS(T),ABS(TOUT)) C C CHECK INITIAL INTERVAL TO SEE THAT IT IS LONG ENOUGH TDIST = ABS(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 = SIGN(HO,TOUT-T) C ADJUST HO IF NECESSARY TO MEET HMAX BOUND 320 IF (INFO(7) .EQ. 0) GO TO 330 RH = ABS(HO)/RWORK(LHMAX) 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, UPDATING TN AND Y, IF APPLICABLE 340 IF (INFO(11) .EQ. 0) GO TO 350 CALL DDAINI(TN,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),NTEMP) 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) 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 UROUND=RWORK(LROUND) DONE = .FALSE. TN=RWORK(LTN) H=RWORK(LH) IF(INFO(7) .EQ. 0) GO TO 410 RH = ABS(H)/RWORK(LHMAX) 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 WITHIN ROUNDOFF OF TSTOP IF(ABS(TN-TSTOP).GT.100.0D0*UROUND* * (ABS(TN)+ABS(H)))GO TO 460 CALL DDATRP(TN,TSTOP,Y,YPRIME,NEQ,IWORK(LKOLD), * RWORK(LPHI),RWORK(LPSI)) IDID=2 T=TSTOP DONE = .TRUE. GO TO 490 460 TNEXT=TN+H IF((TNEXT-TSTOP)*H.LE.0.0D0)GO TO 490 H=TSTOP-TN RWORK(LH)=H C 490 IF (DONE) GO TO 580 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 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 c----------------------------------------------------------------------- 510 CALL DDAWTS(INFO(2),RTOL,ATOL,RWORK(LPHI), * RWORK(LWT),RPAR,IPAR) c----------------------------------------------------------------------- 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 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*MAX(ABS(TN),ABS(TOUT)) C C TEST H VS. HMAX IF (INFO(7) .EQ. 0) GO TO 526 RH = ABS(H)/RWORK(LHMAX) IF (RH .GT. 1.0D0) H = H/RH 526 CONTINUE 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), c----------------------------------------------------------------------- * IWORK(LKOLD),IWORK(LNS),INFO(10),NTEMP,rwork(lcjsca)) c----------------------------------------------------------------------- 527 IF(IDID.LT.0)GO TO 600 C C-------------------------------------------------------- C THIS BLOCK HANDLES THE CASE OF A SUCCESSFUL RETURN C FROM DDASTP (IDID=1). TEST FOR STOP CONDITIONS. C-------------------------------------------------------- C 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(ABS(TN-TSTOP).LE.100.0D0*UROUND* * (ABS(TN)+ABS(H)))GO TO 545 TNEXT=TN+H IF((TNEXT-TSTOP)*H.LE.0.0D0)GO TO 500 H=TSTOP-TN GO TO 500 545 CALL DDATRP(TN,TSTOP,Y,YPRIME,NEQ, * IWORK(LKOLD),RWORK(LPHI),RWORK(LPSI)) IDID=2 T=TSTOP GO TO 580 550 IF((TN-TOUT)*H.GE.0.0D0)GO TO 555 IF(ABS(TN-TSTOP).LE.100.0D0*UROUND*(ABS(TN)+ABS(H)))GO TO 552 T=TN IDID=1 GO TO 580 552 CALL DDATRP(TN,TSTOP,Y,YPRIME,NEQ, * IWORK(LKOLD),RWORK(LPHI),RWORK(LPSI)) 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 GO TO 580 C C-------------------------------------------------------- C ALL SUCCESSFUL RETURNS FROM DDASSL ARE MADE FROM C THIS BLOCK. C-------------------------------------------------------- C 580 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 WRITE (XERN3, '(1P,D15.6)') TN CALL XERMSG ('SLATEC', 'DDASSL', * 'AT CURRENT T = ' // XERN3 // ' 500 STEPS TAKEN ON THIS ' // * 'CALL BEFORE REACHING TOUT', IDID, 1) GO TO 690 C C TOO MUCH ACCURACY FOR MACHINE PRECISION 620 WRITE (XERN3, '(1P,D15.6)') TN CALL XERMSG ('SLATEC', 'DDASSL', * 'AT T = ' // XERN3 // ' TOO MUCH ACCURACY REQUESTED FOR ' // * 'PRECISION OF MACHINE. RTOL AND ATOL WERE INCREASED TO ' // * 'APPROPRIATE VALUES', IDID, 1) GO TO 690 C C WT(I) .LE. 0.0 FOR SOME I (NOT AT START OF PROBLEM) 630 WRITE (XERN3, '(1P,D15.6)') TN CALL XERMSG ('SLATEC', 'DDASSL', * 'AT T = ' // XERN3 // ' SOME ELEMENT OF WT HAS BECOME .LE. ' // * '0.0', IDID, 1) GO TO 690 C C ERROR TEST FAILED REPEATEDLY OR WITH H=HMIN 640 WRITE (XERN3, '(1P,D15.6)') TN WRITE (XERN4, '(1P,D15.6)') H CALL XERMSG ('SLATEC', 'DDASSL', * 'AT T = ' // XERN3 // ' AND STEPSIZE H = ' // XERN4 // * ' THE ERROR TEST FAILED REPEATEDLY OR WITH ABS(H)=HMIN', * IDID, 1) GO TO 690 C C CORRECTOR CONVERGENCE FAILED REPEATEDLY OR WITH H=HMIN 650 WRITE (XERN3, '(1P,D15.6)') TN WRITE (XERN4, '(1P,D15.6)') H CALL XERMSG ('SLATEC', 'DDASSL', * 'AT T = ' // XERN3 // ' AND STEPSIZE H = ' // XERN4 // * ' THE CORRECTOR FAILED TO CONVERGE REPEATEDLY OR WITH ' // * 'ABS(H)=HMIN', IDID, 1) GO TO 690 C C THE ITERATION MATRIX IS SINGULAR 660 WRITE (XERN3, '(1P,D15.6)') TN WRITE (XERN4, '(1P,D15.6)') H CALL XERMSG ('SLATEC', 'DDASSL', * 'AT T = ' // XERN3 // ' AND STEPSIZE H = ' // XERN4 // * ' THE ITERATION MATRIX IS SINGULAR', IDID, 1) GO TO 690 C C CORRECTOR FAILURE PRECEEDED BY ERROR TEST FAILURES. 670 WRITE (XERN3, '(1P,D15.6)') TN WRITE (XERN4, '(1P,D15.6)') H CALL XERMSG ('SLATEC', 'DDASSL', * 'AT T = ' // XERN3 // ' AND STEPSIZE H = ' // XERN4 // * ' THE CORRECTOR COULD NOT CONVERGE. ALSO, THE ERROR TEST ' // * 'FAILED REPEATEDLY.', IDID, 1) GO TO 690 C C CORRECTOR FAILURE BECAUSE IRES = -1 675 WRITE (XERN3, '(1P,D15.6)') TN WRITE (XERN4, '(1P,D15.6)') H CALL XERMSG ('SLATEC', 'DDASSL', * 'AT T = ' // XERN3 // ' AND STEPSIZE H = ' // XERN4 // * ' THE CORRECTOR COULD NOT CONVERGE BECAUSE IRES WAS EQUAL ' // * 'TO MINUS ONE', IDID, 1) GO TO 690 C C FAILURE BECAUSE IRES = -2 680 WRITE (XERN3, '(1P,D15.6)') TN WRITE (XERN4, '(1P,D15.6)') H CALL XERMSG ('SLATEC', 'DDASSL', * 'AT T = ' // XERN3 // ' AND STEPSIZE H = ' // XERN4 // * ' IRES WAS EQUAL TO MINUS TWO', IDID, 1) GO TO 690 C C FAILED TO COMPUTE INITIAL YPRIME 685 WRITE (XERN3, '(1P,D15.6)') TN WRITE (XERN4, '(1P,D15.6)') HO CALL XERMSG ('SLATEC', 'DDASSL', * 'AT T = ' // XERN3 // ' AND STEPSIZE H = ' // XERN4 // * ' THE INITIAL YPRIME COULD NOT BE COMPUTED', IDID, 1) GO TO 690 C 690 CONTINUE INFO(1)=-1 T=TN RWORK(LTN)=TN RWORK(LH)=H RETURN C 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 XERMSG ('SLATEC', 'DDASSL', * 'SOME ELEMENT OF INFO VECTOR IS NOT ZERO OR ONE', 1, 1) GO TO 750 C 702 WRITE (XERN1, '(I8)') NEQ CALL XERMSG ('SLATEC', 'DDASSL', * 'NEQ = ' // XERN1 // ' .LE. 0', 2, 1) GO TO 750 C 703 WRITE (XERN1, '(I8)') MXORD CALL XERMSG ('SLATEC', 'DDASSL', * 'MAXORD = ' // XERN1 // ' NOT IN RANGE', 3, 1) GO TO 750 C 704 WRITE (XERN1, '(I8)') LENRW WRITE (XERN2, '(I8)') LRW CALL XERMSG ('SLATEC', 'DDASSL', * 'RWORK LENGTH NEEDED, LENRW = ' // XERN1 // * ', EXCEEDS LRW = ' // XERN2, 4, 1) GO TO 750 C 705 WRITE (XERN1, '(I8)') LENIW WRITE (XERN2, '(I8)') LIW CALL XERMSG ('SLATEC', 'DDASSL', * 'IWORK LENGTH NEEDED, LENIW = ' // XERN1 // * ', EXCEEDS LIW = ' // XERN2, 5, 1) GO TO 750 C 706 CALL XERMSG ('SLATEC', 'DDASSL', * 'SOME ELEMENT OF RTOL IS .LT. 0', 6, 1) GO TO 750 C 707 CALL XERMSG ('SLATEC', 'DDASSL', * 'SOME ELEMENT OF ATOL IS .LT. 0', 7, 1) GO TO 750 C 708 CALL XERMSG ('SLATEC', 'DDASSL', * 'ALL ELEMENTS OF RTOL AND ATOL ARE ZERO', 8, 1) GO TO 750 C 709 WRITE (XERN3, '(1P,D15.6)') TSTOP WRITE (XERN4, '(1P,D15.6)') TOUT CALL XERMSG ('SLATEC', 'DDASSL', * 'INFO(4) = 1 AND TSTOP = ' // XERN3 // ' BEHIND TOUT = ' // * XERN4, 9, 1) GO TO 750 C 710 WRITE (XERN3, '(1P,D15.6)') HMAX CALL XERMSG ('SLATEC', 'DDASSL', * 'HMAX = ' // XERN3 // ' .LT. 0.0', 10, 1) GO TO 750 C 711 WRITE (XERN3, '(1P,D15.6)') TOUT WRITE (XERN4, '(1P,D15.6)') T CALL XERMSG ('SLATEC', 'DDASSL', * 'TOUT = ' // XERN3 // ' BEHIND T = ' // XERN4, 11, 1) GO TO 750 C 712 CALL XERMSG ('SLATEC', 'DDASSL', * 'INFO(8)=1 AND H0=0.0', 12, 1) GO TO 750 C 713 CALL XERMSG ('SLATEC', 'DDASSL', * 'SOME ELEMENT OF WT IS .LE. 0.0', 13, 1) GO TO 750 C 714 WRITE (XERN3, '(1P,D15.6)') TOUT WRITE (XERN4, '(1P,D15.6)') T CALL XERMSG ('SLATEC', 'DDASSL', * 'TOUT = ' // XERN3 // ' TOO CLOSE TO T = ' // XERN4 // * ' TO START INTEGRATION', 14, 1) GO TO 750 C 715 WRITE (XERN3, '(1P,D15.6)') TSTOP WRITE (XERN4, '(1P,D15.6)') T CALL XERMSG ('SLATEC', 'DDASSL', * 'INFO(4)=1 AND TSTOP = ' // XERN3 // ' BEHIND T = ' // XERN4, * 15, 1) GO TO 750 C 717 WRITE (XERN1, '(I8)') IWORK(LML) CALL XERMSG ('SLATEC', 'DDASSL', * 'ML = ' // XERN1 // ' ILLEGAL. EITHER .LT. 0 OR .GT. NEQ', * 17, 1) GO TO 750 C 718 WRITE (XERN1, '(I8)') IWORK(LMU) CALL XERMSG ('SLATEC', 'DDASSL', * 'MU = ' // XERN1 // ' ILLEGAL. EITHER .LT. 0 OR .GT. NEQ', * 18, 1) GO TO 750 C 719 WRITE (XERN3, '(1P,D15.6)') TOUT CALL XERMSG ('SLATEC', 'DDASSL', * 'TOUT = T = ' // XERN3, 19, 1) GO TO 750 C 750 IDID=-33 IF(INFO(1).EQ.-1) THEN CALL XERMSG ('SLATEC', 'DDASSL', * 'REPEATED OCCURRENCES OF ILLEGAL INPUT$$' // * 'RUN TERMINATED. APPARENT INFINITE LOOP', -999, 2) ENDIF C INFO(1)=-1 RETURN C-----------END OF SUBROUTINE DDASSL------------------------------------ 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, c----------------------------------------------------------------------- + K, KOLD, NS, NONNEG, NTEMP, cjscal) c----------------------------------------------------------------------- C***BEGIN PROLOGUE DDASTP C***SUBSIDIARY C***PURPOSE Perform one step of the DDASSL integration. C***LIBRARY SLATEC (DASSL) C***TYPE DOUBLE PRECISION (SDASTP-S, DDASTP-D) C***AUTHOR PETZOLD, LINDA R., (LLNL) c----------------------------------------------------------------------- c This routine has been modified for the purpose of scaling the c interation matrix. c c----------------------------------------------------------------------- c c Last modified by Rong Wang, September 4, 2001. c c----------------------------------------------------------------------- C***DESCRIPTION C----------------------------------------------------------------------- C DDASTP 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 DDASTP WILL TRY TO SOLVE C THE PROBLEM WITHOUT GETTING IRES = -1. IF C IRES=-2, DDASTP 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 DDASTP C PHI -- ARRAY OF DIVIDED DIFFERENCES USED BY C DDASTP. THE LENGTH IS NEQ*(K+1),WHERE C K IS THE MAXIMUM ORDER C DELTA,E -- WORK VECTORS FOR DDASTP 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 DDASTP TO C CONTINUE FROM STEP TO STEP. C C----------------------------------------------------------------------- C***ROUTINES CALLED DDAJAC, DDANRM, DDASLV, DDATRP C***REVISION HISTORY (YYMMDD) C 830315 DATE WRITTEN C 901009 Finished conversion to SLATEC 4.0 format (F.N.Fritsch) C 901019 Merged changes made by C. Ulrich with SLATEC 4.0 format. C 901026 Added explicit declarations for all variables and minor C cosmetic changes to prologue. (FNF) C***END PROLOGUE DDASTP C INTEGER NEQ, JSTART, IDID, IPAR(*), IWM(*), IPHASE, JCALC, K, * KOLD, NS, NONNEG, NTEMP DOUBLE PRECISION * X, Y(*), YPRIME(*), H, WT(*), RPAR(*), PHI(NEQ,*), DELTA(*), * E(*), WM(*), ALPHA(*), BETA(*), GAMMA(*), PSI(*), SIGMA(*), CJ, * CJOLD, HOLD, S, HMIN, UROUND EXTERNAL RES, JAC C EXTERNAL DDAJAC, DDANRM, DDASLV, DDATRP DOUBLE PRECISION DDANRM C INTEGER I, IER, IRES, J, J1, KDIFF, KM1, KNEW, KP1, KP2, LCTF, * LETF, LMXORD, LNJE, LNRE, LNST, M, MAXIT, NCF, NEF, NSF, NSP1 DOUBLE PRECISION * ALPHA0, ALPHAS, CJLAST, CK, DELNRM, ENORM, ERK, ERKM1, * ERKM2, ERKP1, ERR, EST, HNEW, OLDNRM, PNORM, R, RATE, TEMP1, * TEMP2, TERK, TERKM1, TERKM2, TERKP1, XOLD, XRATE LOGICAL CONVGD c----------------------------------------------------------------------- double precision cjscal c----------------------------------------------------------------------- C PARAMETER (LMXORD=3) PARAMETER (LNST=11) PARAMETER (LNRE=12) PARAMETER (LNJE=13) PARAMETER (LETF=14) PARAMETER (LCTF=15) C 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 C***FIRST EXECUTABLE STATEMENT DDASTP 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=MIN(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)=(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/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 = ABS(ALPHA(KP1) + ALPHAS - ALPHA0) CK = MAX(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,NTEMP) c----------------------------------------------------------------------- cjscal = cj c----------------------------------------------------------------------- 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 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. c----------------------------------------------------------------------- CALL DDASLV(NEQ,DELTA,WM,IWM,cjscal) c----------------------------------------------------------------------- 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/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(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) = MIN(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. 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 = (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 = K*ERKM1 IF(K .GT. 2)GO TO 410 IF(TERKM1 .LE. 0.5D0*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 = (K-1)*ERKM2 IF(MAX(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(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/(K+2))*DDANRM(NEQ,DELTA,WT,RPAR,IPAR) TERKP1 = (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.MIN(TERK,TERKP1))GO TO 540 IF(TERKP1.GE.TERK.OR.K.EQ.IWM(LMXORD))GO TO 550 C C RAISE ORDER 530 K=KP1 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 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 = MAX(0.5D0,MIN(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. ABS(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. ABS(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 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 = MAX(0.25D0,MIN(0.9D0,R)) H = H*R IF (ABS(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 FOUR. 665 IF (NEF .GT. 2) GO TO 670 K = KNEW H = 0.25D0*H IF (ABS(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 FOUR. 670 K = 1 H = 0.25D0*H IF (ABS(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 DDASTP------ END SUBROUTINE DDATRP (X, XOUT, YOUT, YPOUT, NEQ, KOLD, PHI, PSI) C***BEGIN PROLOGUE DDATRP C***SUBSIDIARY C***PURPOSE Interpolation routine for DDASSL. C***LIBRARY SLATEC (DASSL) C***TYPE DOUBLE PRECISION (SDATRP-S, DDATRP-D) C***AUTHOR PETZOLD, LINDA R., (LLNL) C***DESCRIPTION C----------------------------------------------------------------------- C THE METHODS IN SUBROUTINE DDASTP 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 DDASTP, 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***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C 830315 DATE WRITTEN C 901009 Finished conversion to SLATEC 4.0 format (F.N.Fritsch) C 901019 Merged changes made by C. Ulrich with SLATEC 4.0 format. C 901026 Added explicit declarations for all variables and minor C cosmetic changes to prologue. (FNF) C***END PROLOGUE DDATRP C INTEGER NEQ, KOLD DOUBLE PRECISION X, XOUT, YOUT(*), YPOUT(*), PHI(NEQ,*), PSI(*) C INTEGER I, J, KOLDP1 DOUBLE PRECISION C, D, GAMMA, TEMP1 C C***FIRST EXECUTABLE STATEMENT DDATRP 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 c----------------------------------------------------------------------- SUBROUTINE DDAWTS (IWT, RTOL, ATOL, Y, WT, RPAR, IPAR) c----------------------------------------------------------------------- C***BEGIN PROLOGUE DDAWTS C***SUBSIDIARY C***PURPOSE Set error weight vector for DDASSL. C***LIBRARY SLATEC (DASSL) C***TYPE DOUBLE PRECISION (SDAWTS-S, DDAWTS-D) C***AUTHOR PETZOLD, LINDA R., (LLNL) C***DESCRIPTION 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***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C 830315 DATE WRITTEN C 901009 Finished conversion to SLATEC 4.0 format (F.N.Fritsch) C 901019 Merged changes made by C. Ulrich with SLATEC 4.0 format. C 901026 Added explicit declarations for all variables and minor C cosmetic changes to prologue. (FNF) C***END PROLOGUE DDAWTS c----------------------------------------------------------------------- c Last modified by Rong Wang, April 1, 2001 c----------------------------------------------------------------------- C INTEGER IWT, IPAR(*) DOUBLE PRECISION RTOL(*), ATOL(*), Y(*), WT(*), RPAR(*) c----------------------------------------------------------------------- c Constant: integer nconti parameter (nconti = 2) c integer npde, kcol, nint, npts, j, ij integer inpde, ikcol, inint c----------------------------------------------------------------------- C INTEGER I DOUBLE PRECISION ATOLI, RTOLI C c----------------------------------------------------------------------- c Direct IPAR indices: parameter (inpde = 1) parameter (ikcol = 2) parameter (inint = 3) c c----------------------------------------------------------------------- C***FIRST EXECUTABLE STATEMENT DDAWTS c----------------------------------------------------------------------- npde = ipar(inpde) nint = ipar(inint) kcol = ipar(ikcol) npts = nint * kcol + nconti + nint * (kcol + 1) + nconti if (iwt .eq. 0) then rtoli = rtol(1) atoli = atol(1) do 10 i = 1, npde * npts wt(i) = rtoli * abs(y(i)) + atoli 10 continue else do 30 i = 1, npts do 20 j = 1, npde rtoli = rtol(j) atoli = atol(j) ij = (i - 1) * npde + j wt(ij) = rtoli * abs(y(ij)) + atoli 20 continue 30 continue endif c----------------------------------------------------------------------- RETURN C-----------END OF SUBROUTINE DDAWTS------------------------------------ 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(*),dy(*),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 subroutine dgbfa(abd,lda,n,ml,mu,ipvt,info) integer lda,n,ml,mu,ipvt(*),info double precision abd(lda,*) 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(*),job double precision abd(lda,*),b(*) 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 dgefa(a,lda,n,ipvt,info) integer lda,n,ipvt(*),info double precision a(lda,*) 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(*),job double precision a(lda,*),b(*) 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 divdif(neq, nstep, psi, work, y) c----------------------------------------------------------------------- c Purpose: c This routine generates the divided difference, which is required c by DASSL for a hot start, after calculating the bspline c coefficients at the last nstep steps. c c----------------------------------------------------------------------- c c Last modified by Rong Wang, May 4, 2001. c c----------------------------------------------------------------------- c Subroutine Parameters: c Input: integer neq c neq is the number of bspline c coefficients after remeshing. c integer nstep c nstep is the number of time steps c on which the remeshing is needed. c double precision psi(6) c psi is the stepsize vector of the c previous 6 time steps. c c Work Storage: double precision work(6) c work is a floating point work storage c array. c c Output: double precision y(nstep*neq) c y is the vector of bspline coefficients c at the last nstep time steps after c remeshing. c c----------------------------------------------------------------------- c Loop indices: integer i integer j integer m c c----------------------------------------------------------------------- c Update y to be the divide difference. do 40 i = 1, nstep - 1 work(1) = psi(i) if (nstep .gt. 2) then do 10 j = 2, nstep-i work(j) = psi(j+i-1) - psi(j-1) 10 continue endif do 30 j = nstep, i+1, -1 do 20 m = 1, neq y((j-1)*neq+m) = (y((j-2)*neq+m) - y((j-1)*neq+m)) * / work(j-i) 20 continue 30 continue 40 continue work(1) = psi(1) do 50 i = 2, nstep - 1 work(i) = work(i-1) * psi(i) 50 continue do 70 i = 2, nstep do 60 m = 1, neq y((i-1)*neq+m) = y((i-1)*neq+m) * work(i-1) 60 continue 70 continue c----------------------------------------------------------------------- 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 modified 3/93 to return if incx .le. 0. c double precision da,dx(*) integer i,incx,m,mp1,n,nincx c if( n.le.0 .or. incx.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 subroutine errest(kcol, nint, npde, neq1, neq2, npts, icount, & xsol, wts, xbs1, xbs2, y1, y2, istart, mflag2, & atol, rtol, lenwk, work, errba1, errba2, errrat, & errint, errcom, ieflag) c----------------------------------------------------------------------- c Purpose: c This routine computes the error estimate at each subinterval c and for each component of PDEs, and decides whether a remeshing c is necessary or not. c c----------------------------------------------------------------------- c c Last modified by Rong Wang, November 8, 2001. c c----------------------------------------------------------------------- c Constants: integer nconti parameter (nconti = 2) c nconti continuity conditions are imposed c at the internal mesh points. c integer nintsm parameter (nintsm = 15) c when the current step is the first step c after remeshing, we require c if nint <= nintsm c errrat < saffa2 c else c saffa1 < errrat < saffa2. c endif c double precision zero parameter (zero = 0.0d0) c double precision one parameter (one = 1.0d0) c double precision two parameter (two = 2.0d0) c double precision saffa1 parameter (saffa1 = 0.1d0) c double precision saffa2 parameter (saffa2 = 0.4d0) c c----------------------------------------------------------------------- c Subroutine Parameters: c input integer kcol c kcol is the number of collocation points c to be used in each subinterval. c integer nint c nint is the number of subintervals c defined by the spatial mesh x. c nint >= 1. c integer npde c npde is the number of components in c the system of PDEs. npde > 0. c integer neq1 c neq1=npde*(nint*kcol+nconti) is the c number of bspline coefficients (or c DAEs) when using dassl_kcol. c integer neq2 c neq2=neq1+npde*nint is the number of c bspline coefficients (or DAEs) when c using dassl_kcol+1. c integer npts c npts is the number of points in the c x vector, which is equal to c nint*(kcol+3). c integer icount c icount is the number of remeshing times c at the current step. c double precision xsol(npts) c xsol is the npts Gauss-Legend c points at which the solution are c to be calculated. c double precision wts(npts) c wts is the npts Gauss-Legend c weights at the corresponding xsol. c double precision xbs1((kcol+1)*nint+nconti+nconti) c xbs1 is the breakpoint sequence when c using dassl_kcol. c double precision xbs2((kcol+2)*nint+nconti+nconti) c xbs2 is the breakpoint sequence when c using dassl_kcol+1. c double precision y1(neq1) c y1 is the vector of bspline c coefficients when using dassl_kcol. c double precision y2(neq2) c y2 is the vector of bspline c coefficients when using dassl_kcol+1. c integer istart c istart is a flag to begin the code. c istart = 0, it is the initial step; c = 1, it is not the initial step. c integer mflag2 c mflag2 = 0, scalar atol and rtol.; c mflag2 = 1, vector atol and rtol. c double precision atol(npde) c atol is the absolute error tolerance c request and is a scalar quantity if c mflag2 = 0. c double precision rtol(npde) c rtol is the relative error tolerance c request and is a scalar quantity if c mflag2 = 0. c integer lenwk c lenwk is the size of the work storage c array and must satisfy: c lenwk >= 2*npde*nint*(kcol+3) c +npde*nint c c Work Storage: double precision work(lenwk) c work is a floating point work storage c array of size lenwk. c c output: double precision errba1((kcol+nconti)*npts) c errba1 is the values of the nonzero c basis functions at xsol when using c dassl_kcol. c double precision errba2((kcol+1+nconti)*npts) c errba2 is the values of the nonzero c basis functions at xsol when using c dassl_kcol+1. c double precision errrat c errrat is the value of the largest c component of errcom. c double precision errint(nint) c errint is the error estimate at each c subinterval. c double precision errcom(npde) c errcom is the error estimate for c each component of pdes at the whole c range, i.e. from x_a to x_b. c integer ieflag c ieflag is a status flag for remesh. c ieflag = 0, indicates no need remeshing. c ieflag = 1, indicates need remeshing. c c----------------------------------------------------------------------- c Local Variables: double precision errsum c errsum is the sum of errint. c double precision errmax c errmax is the maximum value of c errint(i), i = 1, nint. c double precision aerr c aerr is the average value of errint(i), c i = 1, nint. c double precision disind c disind is equal to errmax/aerr, and it c indicates the error distribution over c the mesh. c c Pointers into the floating point work array: integer iusol1 c work(iusol1) stores the values at the c npts points when using dassl_kcol. c integer iusol2 c work(iusol2) stores the values at the c npts points when using dassl_kcol+1. c integer ierrci c work(ierrci) stores the error estimate c at each subinterval for each component. c c----------------------------------------------------------------------- c Loop indices: integer i, j, m, ij, im, mm c c----------------------------------------------------------------------- c Subroutines Called: c errval c c----------------------------------------------------------------------- c Set the pointers into the floating point work array. iusol1 = 1 iusol2 = iusol1 + npde * nint * (kcol + 3) ierrci = iusol2 + npde * nint * (kcol + 3) c----------------------------------------------------------------------- c Generate the different values at the npts points xsol, and save c in work(iusol1) and work(iusol2). call errval(kcol, nint, npde, neq1, kcol+3, istart, icount, xbs1, & xsol, y1, errba1, work(iusol1)) call errval(kcol+1, nint, npde, neq2, kcol+3, istart, icount, & xbs2, xsol, y2, errba2, work(iusol2)) c----------------------------------------------------------------------- c Initialization task. do 10 i = 1, nint errint(i) = zero 10 continue do 20 i = 1, npde errcom(i) = zero 20 continue do 30 i = 1, npde * nint work(ierrci - 1 + i) = zero 30 continue c----------------------------------------------------------------------- c Calculate the error estimate at each subinterval for each c component of PDEs. if (mflag2 .eq. 0) then do 60 m = 1, npde do 50 i = 1, nint do 40 j = 1, kcol + 3 ij = (i - 1) * (kcol + 3) + j mm = npde * (ij - 1) + m im = ierrci - 1 + (m - 1) * nint + i work(im) = work(im) + ((work(iusol1-1+mm) & - work(iusol2-1+mm)) / & (atol(1) + rtol(1)*abs(work(iusol1-1+mm)))) & **2 * wts(ij) 40 continue 50 continue 60 continue else do 90 m = 1, npde do 80 i = 1, nint do 70 j = 1, kcol + 3 ij = (i - 1) * (kcol + 3) + j mm = npde * (ij - 1) + m im = ierrci - 1 + (m - 1) * nint + i work(im) = work(im) + ((work(iusol1-1+mm) & - work(iusol2-1+mm)) / & (atol(m) + rtol(m)*abs(work(iusol1-1+mm)))) & **2 * wts(ij) 70 continue 80 continue 90 continue endif c----------------------------------------------------------------------- c Calculate errint and errcom. do 110 j = 1, npde do 100 i = 1, nint ij = ierrci - 1 + (j - 1) * nint + i errint(i) = errint(i) + work(ij) errcom(j) = errcom(j) + work(ij) 100 continue 110 continue c Take the square root and update errint and errcom. do 120 i = 1, nint errint(i) = sqrt(errint(i)) errint(i) = errint(i) ** (one/dble((kcol+2))) c errint(i) = errint(i) ** (one/dble(2*(kcol+2))) 120 continue do 130 i = 1, npde errcom(i) = sqrt(errcom(i)) 130 continue c----------------------------------------------------------------------- c Decide whether remeshing is needed. ieflag = 0 c update errrat. errrat = zero do 140 i = 1, npde if (errcom(i) .gt. errrat) then errrat = errcom(i) endif 140 continue c Calculate errsum to be the sum of the errint. Find the maximum c errint(i) and save it in errmax. errsum = errint(1) errmax = errint(1) do 150 i = 2, nint if (errmax .lt. errint(i)) errmax = errint(i) errsum = errint(i) + errsum 150 continue c Let aerr be the mean value of errint(i). aerr = errsum/dble(nint) c Calculate disind. disind = errmax/aerr if (disind .gt. two) then ieflag = 1 else if ((istart .ne. 1) .or. (icount .ne. 0)) then if (nint .gt. nintsm) then if ((errrat .ge. saffa2) .or. (errrat .le. saffa1)) & ieflag = 1 else if (errrat .ge. saffa2) ieflag = 1 endif else if (errrat .ge. one) ieflag = 1 endif endif return end subroutine errval(kcol, nint, npde, neq, nptse, istart, icount, & xbs, xsol, y, errbas, usol) c----------------------------------------------------------------------- c Purpose: c This routine computes the values of the (kcol+nconti) nonzero c bspline basis function at each Gaussian point of xsol. c Then determine the solution usol, which is used for error c estimate, at xsol. c c----------------------------------------------------------------------- c c Last modified by Rong Wang, August 29, 2001. c c----------------------------------------------------------------------- c Constants: integer nconti parameter (nconti = 2) c nconti continuity conditions are imposed c at the internal mesh points. c double precision zero parameter (zero = 0.0D0) c c----------------------------------------------------------------------- c Subroutine Parameters: c input integer kcol c kcol is the number of collocation points c to be used in each subinterval. c integer nint c nint is the number of subintervals c defined by the spatial mesh x. c nint >= 1. c integer npde c npde is the number of components in c the system of PDEs. npde > 0. c integer neq c neq=npde*(kcol*nint+2) is the number of c bspline coefficients. c integer nptse c nptse is the number of Gaussian points c in each subinterval for the error c estimate. c integer istart c istart is a flag to begin the code. c istart = 0, it is the initial step; c = 1, it is not the initial step. c integer icount c icount is the number of remeshing times c at the current step. c double precision xbs((kcol+1)*nint+nconti+nconti) c The breakpoint sequence. c double precision xsol(nptse*nint) c xsol is a set of spatial points at which c the solution are to be calculated for c error estimate. c double precision y(neq) c y is the vector of bspline coefficients. c c output: double precision errbas(kcol+nconti, nptse*nint) c errbas is the values of the nonzero c basis functions at xsol. c double precision usol(npde, nptse*nint) c usol is the solution at xsol. c c----------------------------------------------------------------------- c Local Variables: integer ileft c breakpoint information. c c----------------------------------------------------------------------- c Loop indices: integer i integer j integer k integer m integer jj integer mm c c----------------------------------------------------------------------- c Subroutines Called: c bsplvd c c----------------------------------------------------------------------- c check whether errbas is necessary to be calculated. if ((istart .eq. 1) .and. (icount .eq. 0)) goto 30 c calculate errbas. do 20 i = 1, nint ileft = kcol + nconti + (i - 1) * kcol do 10 j = 1, nptse jj = (i - 1) * nptse + j call bsplvd(xbs, kcol+nconti, xsol(jj), ileft, errbas(1,jj), & 1) 10 continue 20 continue 30 continue c compute the values of usol at xsol. do 70 i = 1, nint do 60 j = 1, nptse jj = (i - 1) * nptse + j do 50 k = 1, npde usol(k,jj) = zero do 40 m = 1, kcol + nconti mm = npde * (m + (i - 1) * kcol - 1) + k usol(k,jj) = usol(k,jj) + y(mm) * errbas(m,jj) 40 continue 50 continue 60 continue 70 continue return end subroutine eval(npde,kcol,ileft,icpt,ncpts,uval,uxval,uxxval, & fbasis,y) c----------------------------------------------------------------------- c Purpose: c This routine evaluates u(k), ux(k), and uxx(k), k=1 to npde, c at the icpt-th collocation point. c c----------------------------------------------------------------------- c c Last modified by Rong Wang, Feb. 11, 2001. c c----------------------------------------------------------------------- c Constants integer nconti parameter (nconti = 2) c nconti continuity conditions are imposed c at the internal mesh points. c double precision zero parameter (zero = 0.0D0) c----------------------------------------------------------------------- c Subroutine Parameters: c Input: integer npde c npde is the number of components in c the system of PDEs. npde > 0. c integer kcol c kcol is the number of collocation points c to be used in each subinterval. c integer ileft c breakpoint information. c integer icpt c the index of the collocation point. c integer ncpts c ncpts=(kcol*nint+nconti) is the number c of collocation points. c double precision fbasis((kcol+nconti)*3) c Basis function values at the icpt-th c collocation point. c fbasis(k+(j-1)*(kcol+nconti)) contains c the values of the (j-1)st derivative c (j=1,2,3) of the k-th non-zero basis c function (k=1,...,kcol+nconti). c double precision y(ncpts*npde) c y is the vector of bspline coefficients. c c Output: double precision uval(npde) c uval gives the approximation to c u(t,x). c double precision uxval(npde) c uxval gives the approximation to c the first spatial derivative of u(t,x). c double precision uxxval(npde) c uxxval gives the approximation to c the second spatial derivative of u(t,x). c c----------------------------------------------------------------------- c Loop indices: integer j integer m c----------------------------------------------------------------------- do 10 j = 1, npde uval(j) = zero uxval(j) = zero uxxval(j) = zero 10 continue if (icpt .ne. 1 .and. icpt .ne. ncpts) then do 30 j = 1, npde do 20 m = 1, kcol + nconti uval(j) = uval(j) + fbasis(m) * & y((ileft-kcol-3+m) * npde + j) uxval(j) = uxval(j) + fbasis(m+kcol+nconti) * & y((ileft-kcol-3+m) * npde + j) uxxval(j) = uxxval(j) + fbasis(m+2*(kcol+nconti)) * & y((ileft-kcol-3+m) * npde + j) 20 continue 30 continue else if (icpt .eq. 1) then do 40 j = 1, npde uval(j) = uval(j) + fbasis(1) * y(j) uxval(j) = uxval(j) + fbasis(1+kcol+nconti) * y(j) & + fbasis(2+kcol+nconti) * y(npde + j) uxxval(j) = uxxval(j) + fbasis(1+2*(kcol+nconti)) * y(j) & + fbasis(2+2*(kcol+nconti)) * y(npde + j) & + fbasis(3+2*(kcol+nconti)) * y(2*npde + j) 40 continue else do 50 j = 1, npde uval(j) = uval(j) + fbasis(kcol+nconti) & * y((ncpts - 1) * npde + j) uxval(j) = uxval(j) + fbasis((kcol+nconti)*2) & * y((ncpts - 1) * npde + j) & + fbasis((kcol+nconti)*2-1) & * y((ncpts - 2) * npde + j) uxxval(j) = uxxval(j) + fbasis((kcol+nconti)*3) & * y((ncpts - 1) * npde + j) & + fbasis((kcol+nconti)*3-1) & * y((ncpts - 2) * npde + j) & + fbasis((kcol+nconti)*3-2) & * y((ncpts - 3) * npde + j) 50 continue endif endif return end SUBROUTINE GAULEG(N, NSQ, PTS, WTS, WORK, FLAG) C $ID: GAULEG.F,V 1.11 1992/06/25 15:09:31 KEAST EXP $ C LAST MODIFIED BY RONG WANG, 2001/03/08 C C GAULEG RETURNS THE POINTS AND WEIGHTS FOR GAUSS-LEGENDRE C QUADRATURE OR GAUSS-LOBATTO QUADRATURE OVER THE INTERVAL C [-1,1] OR [0,1]. C C ON INPUT: C C N : THE NUMBER OF GAUSS-LEGENDRE POINTS. C NSQ : EQUAL TO N*N, TO HANDLE STORAGE FOR EIGENVECTORS. C PTS : DOUBLE PRECISION (N). C WTS : DOUBLE PRECISION (N). IF FLAG (SEE BELOW) IS 1 OR 3, C WTS IS USED ONLY FOR TEMPORARY WORKSPACE. C WORK : DOUBLE PRECISION (NSQ), WORK SPACE FOR CALL TO IMTQL2, C IF WEIGHTS ARE REQUIRED. IF FLAG IS 1 OR 3, WORK IS C NOT REFERENCED, AND MAY BE DECLARED AS SCALAR IN THE C CALLING PROGRAM. C FLAG : SPECIFIES WHETHER WEIGHTS ARE ALSO REQUIRED, AND C WHETHER GAUSS-LEGENDRE OR LOBATTO POINTS ARE WANTED. C FLAG = 1: GAUSS-LEGENDRE POINTS ONLY OVER [-1,1]; C = 2: GAUSS-LEGENDRE POINTS ONLY OVER [0,1]; C = 3: GAUSS-LEGENDRE POINTS AND WEIGHTS OVER C [-1,1]; C = 4: GAUSS-LEGENDRE POINTS AND WEIGHTS OVER C [0,1]; C = 5: LOBATTO POINTS ONLY OVER [-1,1]; C = 6: LOBATTO POINTS ONLY OVER [0,1]; C = 7: LOBATTO POINTS AND WEIGHTS OVER [-1,1]; C = 8: LOBATTO POINTS AND WEIGHTS OVER [0,1]; C FOR ANY OTHER VALUE, THE DEFAULT IS GAUSS-LEGENDRE C POINTS AND WEIGHTS OVER [-1,1]. C C ON OUTPUT: C C FOR FLAG <> 1 OR 2: C PTS : PTS(I) IS THE ITH GAUSS-LEGENDRE POINT IN [-1,1], C PTS(I) < PTS(I+1), I = 1,2,..,N-1. C WTS : WTS(I) IS THE ITH GAUSS-LEGENDRE WEIGHT IF FLAG <> 1. C C FOR FLAG = 3 OR 4: C PTS : PTS(I) IS THE ITH LOBATTO POINT IN [-1,1], C PTS(I) < PTS(I+1), I = 1,2,..,N-1. C CLEARLY, PTS(1) = -1.0, PTS(N) = 1.0. C WTS : WTS(I) IS THE ITH LOBATTO WEIGHT IF FLAG = 4. C C WORK : WORK, USED TO STORE EIGENVECTORS, UNREFERENCED IF FLAG C IS 1 OR 3. C C SUBROUTINES USED: C C IMQTL1: EISPACK ROUTINE TO COMPUTE THE EIGENVALUES OF A C SYMMETRIC TRIDIAGONAL MATRIX. C C IMQTL2: EISPACK ROUTINE TO COMPUTE THE EIGNEVECTORS AND C EIGENVALUES OF A SYMMETRIC TRIDIAGONAL MATRIX. C C FUNCTIONS USED: C C PYTHAG: EISPACK FUNCTION TO COMPUTE EUCLIDEAN NORM. C C INTRINSIC FUNCTIONS USED: C C SQRT, DBLE. C C VERSION: JUNE 22 1992, PAT KEAST. C C DECLARATIONS: C C PARAMETERS: C INTEGER N, NSQ, FLAG DOUBLE PRECISION PTS(N), WTS(N), WORK(NSQ) C C LOCAL VARIABLES: INTEGER IFAIL, J, NM2 DOUBLE PRECISION FOUR, THREE, TWO, ONE, ZERO * .. EXTERNAL FUNCTIONS .. EXTERNAL IMTQL2 PARAMETER ( FOUR = 4.0D0, THREE = 3.0D0, TWO = 2.0D0, * ONE = 1.0D0, ZERO = 0.0D0 ) DO 10 J = 1,N PTS(J) = ZERO 10 CONTINUE DO 20 J = 1,NSQ WORK(J) = ZERO 20 CONTINUE DO 30 J = 1,N WORK((J-1)*N+J) = ONE 30 CONTINUE IF ( FLAG .LE.4 .OR. FLAG .GT. 8 ) THEN C GAUS-LEGENDRE POINTS AND WEIGHTS. DO 40 J = 1,N-1 WTS(J+1) = DBLE(J)/SQRT(DBLE(4*J*J)-ONE) 40 CONTINUE IF ( FLAG .EQ. 1 .OR. FLAG .EQ. 2 ) THEN C COMPUTE ONLY THE GAUSS-LEGENDRE POINTS OVER [-1,1]. CALL IMTQL1(N, PTS, WTS, IFAIL ) C SCALE THE VALUES TO THE INTERVAL [0,1]. IF ( FLAG .EQ. 2 ) THEN DO 45 J = 1,N PTS(J) = (PTS(J)+ONE)/TWO 45 CONTINUE ENDIF ELSE C COMPUTE BOTH POINTS AND WEIGHTS OVER [-1,1]. IFAIL = 1 C CALL IMTQL2(N, N, PTS, WTS, WORK, IFAIL) DO 50 J = 1,N WTS(J) = TWO*WORK((J-1)*N+1)*WORK((J-1)*N+1) 50 CONTINUE C SCALE THE VALUES TO THE INTERVAL [0,1]. IF ( FLAG .EQ. 4 ) THEN DO 55 J = 1,N PTS(J) = (PTS(J)+ONE)/TWO WTS(J) = WTS(J)/TWO 55 CONTINUE ENDIF ENDIF C ELSE C THE LOBATTO POINTS AND WEIGHTS. C FIRST, COMPUTE THE ORDER N-2 JACOBI POINTS AND/OR WEIGHTS. NM2 = N-2 DO 60 J = 1,NM2-1 WTS(J+1) = SQRT(DBLE(J*(J+2))/DBLE((2*J+1)*(2*J+3))) 60 CONTINUE IF ( FLAG .EQ. 5 .OR. FLAG .EQ. 6) THEN C COMPUTE ONLY THE GAUSS-LOBATTO POINTS OVER [-1,1]. CALL IMTQL1(NM2, PTS(2), WTS, IFAIL ) PTS(1) = -ONE PTS(N) = ONE C SCALE THE VALUES TO THE INTERVAL [0,1]. IF ( FLAG .EQ. 6 ) THEN DO 65 J = 1,N PTS(J) = (PTS(J)+ONE)/TWO 65 CONTINUE ENDIF ELSE C COMPUTE BOTH POINTS AND WEIGHTS. IFAIL = 1 C CALL IMTQL2(NM2, NM2, PTS(2), WTS, WORK, IFAIL) PTS(1) = -ONE PTS(N) = ONE DO 70 J = 2,N-1 WTS(J) = (FOUR/THREE)*WORK((J-2)*NM2+1)*WORK((J-2)*NM2+1) * /(ONE - PTS(J)*PTS(J)) 70 CONTINUE WTS(1) = ZERO DO 80 J = 2,N-1 WTS(1) = WTS(1) - WTS(J) 80 CONTINUE WTS(1) = ONE + WTS(1)/TWO WTS(N) = WTS(1) C SCALE THE VALUES TO THE INTERVAL [0,1]. IF ( FLAG .EQ. 8 ) THEN DO 85 J = 1,N PTS(J) = (PTS(J)+ONE)/TWO WTS(J) = WTS(J)/TWO 85 CONTINUE ENDIF ENDIF C RETURN ENDIF * RETURN END INTEGER FUNCTION I1MACH(I) C C I/O UNIT NUMBERS. C C I1MACH( 1) = THE STANDARD INPUT UNIT. C C I1MACH( 2) = THE STANDARD OUTPUT UNIT. C C I1MACH( 3) = THE STANDARD PUNCH UNIT. C C I1MACH( 4) = THE STANDARD ERROR MESSAGE UNIT. C C WORDS. C C I1MACH( 5) = THE NUMBER OF BITS PER INTEGER STORAGE UNIT. C C I1MACH( 6) = THE NUMBER OF CHARACTERS PER CHARACTER STORAGE UNIT. C FOR FORTRAN 77, THIS IS ALWAYS 1. FOR FORTRAN 66, C CHARACTER STORAGE UNIT = INTEGER STORAGE UNIT. C C INTEGERS. C C ASSUME INTEGERS ARE REPRESENTED IN THE S-DIGIT, BASE-A FORM C C SIGN ( X(S-1)*A**(S-1) + ... + X(1)*A + X(0) ) C C WHERE 0 .LE. X(I) .LT. A FOR I=0,...,S-1. C C I1MACH( 7) = A, THE BASE. C C I1MACH( 8) = S, THE NUMBER OF BASE-A DIGITS. C C I1MACH( 9) = A**S - 1, THE LARGEST MAGNITUDE. C C FLOATING-POINT NUMBERS. C C ASSUME FLOATING-POINT NUMBERS ARE REPRESENTED IN THE T-DIGIT, C BASE-B FORM C C SIGN (B**E)*( (X(1)/B) + ... + (X(T)/B**T) ) C C WHERE 0 .LE. X(I) .LT. B FOR I=1,...,T, C 0 .LT. X(1), AND EMIN .LE. E .LE. EMAX. C C I1MACH(10) = B, THE BASE. C C SINGLE-PRECISION C C I1MACH(11) = T, THE NUMBER OF BASE-B DIGITS. C C I1MACH(12) = EMIN, THE SMALLEST EXPONENT E. C C I1MACH(13) = EMAX, THE LARGEST EXPONENT E. C C DOUBLE-PRECISION C C I1MACH(14) = T, THE NUMBER OF BASE-B DIGITS. C C I1MACH(15) = EMIN, THE SMALLEST EXPONENT E. C C I1MACH(16) = EMAX, THE LARGEST EXPONENT E. C C TO ALTER THIS FUNCTION FOR A PARTICULAR ENVIRONMENT, C THE DESIRED SET OF DATA STATEMENTS SHOULD BE ACTIVATED BY C REMOVING THE C FROM COLUMN 1. ALSO, THE VALUES OF C I1MACH(1) - I1MACH(4) SHOULD BE CHECKED FOR CONSISTENCY C WITH THE LOCAL OPERATING SYSTEM. FOR FORTRAN 77, YOU MAY WISH C TO ADJUST THE DATA STATEMENT SO IMACH(6) IS SET TO 1, AND C THEN TO COMMENT OUT THE EXECUTABLE TEST ON I .EQ. 6 BELOW. C C FOR IEEE-ARITHMETIC MACHINES (BINARY STANDARD), THE FIRST C SET OF CONSTANTS BELOW SHOULD BE APPROPRIATE, EXCEPT PERHAPS C FOR IMACH(1) - IMACH(4). C C COMMENTS JUST BEFORE THE END STATEMENT (LINES STARTING WITH *) C GIVE C SOURCE FOR I1MACH. C INTEGER I C INTEGER IMACH(16),OUTPUT,SANITY INTEGER IMACH(16),SANITY C c The following statement is removed because sometimes c EQUIVALENCE statements cause confusion to some compilers. C EQUIVALENCE (IMACH(4),OUTPUT) C C MACHINE CONSTANTS FOR IEEE ARITHMETIC MACHINES, SUCH AS THE AT&T C 3B SERIES, MOTOROLA 68000 BASED MACHINES (E.G. SUN 3 AND AT&T C PC 7300), AND 8087 BASED MICROS (E.G. IBM PC AND AT&T 6300). C DATA IMACH( 1) / 5 / DATA IMACH( 2) / 6 / DATA IMACH( 3) / 7 / DATA IMACH( 4) / 6 / DATA IMACH( 5) / 32 / DATA IMACH( 6) / 4 / DATA IMACH( 7) / 2 / DATA IMACH( 8) / 31 / DATA IMACH( 9) / 2147483647 / DATA IMACH(10) / 2 / DATA IMACH(11) / 24 / DATA IMACH(12) / -125 / DATA IMACH(13) / 128 / DATA IMACH(14) / 53 / DATA IMACH(15) / -1021 / DATA IMACH(16) / 1024 /, SANITY/987/ C C MACHINE CONSTANTS FOR AMDAHL MACHINES. C C DATA IMACH( 1) / 5 / C DATA IMACH( 2) / 6 / C DATA IMACH( 3) / 7 / C DATA IMACH( 4) / 6 / C DATA IMACH( 5) / 32 / C DATA IMACH( 6) / 4 / C DATA IMACH( 7) / 2 / C DATA IMACH( 8) / 31 / C DATA IMACH( 9) / 2147483647 / C DATA IMACH(10) / 16 / C DATA IMACH(11) / 6 / C DATA IMACH(12) / -64 / C DATA IMACH(13) / 63 / C DATA IMACH(14) / 14 / C DATA IMACH(15) / -64 / C DATA IMACH(16) / 63 /, SANITY/987/ C C MACHINE CONSTANTS FOR THE BURROUGHS 1700 SYSTEM. C C DATA IMACH( 1) / 7 / C DATA IMACH( 2) / 2 / C DATA IMACH( 3) / 2 / C DATA IMACH( 4) / 2 / C DATA IMACH( 5) / 36 / C DATA IMACH( 6) / 4 / C DATA IMACH( 7) / 2 / C DATA IMACH( 8) / 33 / C DATA IMACH( 9) / Z1FFFFFFFF / C DATA IMACH(10) / 2 / C DATA IMACH(11) / 24 / C DATA IMACH(12) / -256 / C DATA IMACH(13) / 255 / C DATA IMACH(14) / 60 / C DATA IMACH(15) / -256 / C DATA IMACH(16) / 255 /, SANITY/987/ C C MACHINE CONSTANTS FOR THE BURROUGHS 5700 SYSTEM. C C DATA IMACH( 1) / 5 / C DATA IMACH( 2) / 6 / C DATA IMACH( 3) / 7 / C DATA IMACH( 4) / 6 / C DATA IMACH( 5) / 48 / C DATA IMACH( 6) / 6 / C DATA IMACH( 7) / 2 / C DATA IMACH( 8) / 39 / C DATA IMACH( 9) / O0007777777777777 / C DATA IMACH(10) / 8 / C DATA IMACH(11) / 13 / C DATA IMACH(12) / -50 / C DATA IMACH(13) / 76 / C DATA IMACH(14) / 26 / C DATA IMACH(15) / -50 / C DATA IMACH(16) / 76 /, SANITY/987/ C C MACHINE CONSTANTS FOR THE BURROUGHS 6700/7700 SYSTEMS. C C DATA IMACH( 1) / 5 / C DATA IMACH( 2) / 6 / C DATA IMACH( 3) / 7 / C DATA IMACH( 4) / 6 / C DATA IMACH( 5) / 48 / C DATA IMACH( 6) / 6 / C DATA IMACH( 7) / 2 / C DATA IMACH( 8) / 39 / C DATA IMACH( 9) / O0007777777777777 / C DATA IMACH(10) / 8 / C DATA IMACH(11) / 13 / C DATA IMACH(12) / -50 / C DATA IMACH(13) / 76 / C DATA IMACH(14) / 26 / C DATA IMACH(15) / -32754 / C DATA IMACH(16) / 32780 /, SANITY/987/ C C MACHINE CONSTANTS FOR FTN4 ON THE CDC 6000/7000 SERIES. C C DATA IMACH( 1) / 5 / C DATA IMACH( 2) / 6 / C DATA IMACH( 3) / 7 / C DATA IMACH( 4) / 6 / C DATA IMACH( 5) / 60 / C DATA IMACH( 6) / 10 / C DATA IMACH( 7) / 2 / C DATA IMACH( 8) / 48 / C DATA IMACH( 9) / 00007777777777777777B / C DATA IMACH(10) / 2 / C DATA IMACH(11) / 47 / C DATA IMACH(12) / -929 / C DATA IMACH(13) / 1070 / C DATA IMACH(14) / 94 / C DATA IMACH(15) / -929 / C DATA IMACH(16) / 1069 /, SANITY/987/ C C MACHINE CONSTANTS FOR FTN5 ON THE CDC 6000/7000 SERIES. C C DATA IMACH( 1) / 5 / C DATA IMACH( 2) / 6 / C DATA IMACH( 3) / 7 / C DATA IMACH( 4) / 6 / C DATA IMACH( 5) / 60 / C DATA IMACH( 6) / 10 / C DATA IMACH( 7) / 2 / C DATA IMACH( 8) / 48 / C DATA IMACH( 9) / O"00007777777777777777" / C DATA IMACH(10) / 2 / C DATA IMACH(11) / 47 / C DATA IMACH(12) / -929 / C DATA IMACH(13) / 1070 / C DATA IMACH(14) / 94 / C DATA IMACH(15) / -929 / C DATA IMACH(16) / 1069 /, SANITY/987/ C C MACHINE CONSTANTS FOR CONVEX C-1. C C DATA IMACH( 1) / 5 / C DATA IMACH( 2) / 6 / C DATA IMACH( 3) / 7 / C DATA IMACH( 4) / 6 / C DATA IMACH( 5) / 32 / C DATA IMACH( 6) / 4 / C DATA IMACH( 7) / 2 / C DATA IMACH( 8) / 31 / C DATA IMACH( 9) / 2147483647 / C DATA IMACH(10) / 2 / C DATA IMACH(11) / 24 / C DATA IMACH(12) / -128 / C DATA IMACH(13) / 127 / C DATA IMACH(14) / 53 / C DATA IMACH(15) /-1024 / C DATA IMACH(16) / 1023 /, SANITY/987/ C C MACHINE CONSTANTS FOR THE CRAY 1, XMP, 2, AND 3. C C DATA IMACH( 1) / 5 / C DATA IMACH( 2) / 6 / C DATA IMACH( 3) / 102 / C DATA IMACH( 4) / 6 / C DATA IMACH( 5) / 64 / C DATA IMACH( 6) / 8 / C DATA IMACH( 7) / 2 / C DATA IMACH( 8) / 63 / C DATA IMACH( 9) / 777777777777777777777B / C DATA IMACH(10) / 2 / C DATA IMACH(11) / 47 / C DATA IMACH(12) / -8189 / C DATA IMACH(13) / 8190 / C DATA IMACH(14) / 94 / C DATA IMACH(15) / -8099 / C DATA IMACH(16) / 8190 /, SANITY/987/ C C MACHINE CONSTANTS FOR THE DATA GENERAL ECLIPSE S/200. C C DATA IMACH( 1) / 11 / C DATA IMACH( 2) / 12 / C DATA IMACH( 3) / 8 / C DATA IMACH( 4) / 10 / C DATA IMACH( 5) / 16 / C DATA IMACH( 6) / 2 / C DATA IMACH( 7) / 2 / C DATA IMACH( 8) / 15 / C DATA IMACH( 9) /32767 / C DATA IMACH(10) / 16 / C DATA IMACH(11) / 6 / C DATA IMACH(12) / -64 / C DATA IMACH(13) / 63 / C DATA IMACH(14) / 14 / C DATA IMACH(15) / -64 / C DATA IMACH(16) / 63 /, SANITY/987/ C C MACHINE CONSTANTS FOR THE HARRIS SLASH 6 AND SLASH 7. C C DATA IMACH( 1) / 5 / C DATA IMACH( 2) / 6 / C DATA IMACH( 3) / 0 / C DATA IMACH( 4) / 6 / C DATA IMACH( 5) / 24 / C DATA IMACH( 6) / 3 / C DATA IMACH( 7) / 2 / C DATA IMACH( 8) / 23 / C DATA IMACH( 9) / 8388607 / C DATA IMACH(10) / 2 / C DATA IMACH(11) / 23 / C DATA IMACH(12) / -127 / C DATA IMACH(13) / 127 / C DATA IMACH(14) / 38 / C DATA IMACH(15) / -127 / C DATA IMACH(16) / 127 /, SANITY/987/ C C MACHINE CONSTANTS FOR THE HONEYWELL DPS 8/70 SERIES. C C DATA IMACH( 1) / 5 / C DATA IMACH( 2) / 6 / C DATA IMACH( 3) / 43 / C DATA IMACH( 4) / 6 / C DATA IMACH( 5) / 36 / C DATA IMACH( 6) / 4 / C DATA IMACH( 7) / 2 / C DATA IMACH( 8) / 35 / C DATA IMACH( 9) / O377777777777 / C DATA IMACH(10) / 2 / C DATA IMACH(11) / 27 / C DATA IMACH(12) / -127 / C DATA IMACH(13) / 127 / C DATA IMACH(14) / 63 / C DATA IMACH(15) / -127 / C DATA IMACH(16) / 127 /, SANITY/987/ C C MACHINE CONSTANTS FOR THE IBM 360/370 SERIES, C THE XEROX SIGMA 5/7/9 AND THE SEL SYSTEMS 85/86. C C DATA IMACH( 1) / 5 / C DATA IMACH( 2) / 6 / C DATA IMACH( 3) / 7 / C DATA IMACH( 4) / 6 / C DATA IMACH( 5) / 32 / C DATA IMACH( 6) / 4 / C DATA IMACH( 7) / 2 / C DATA IMACH( 8) / 31 / C DATA IMACH( 9) / Z7FFFFFFF / C DATA IMACH(10) / 16 / C DATA IMACH(11) / 6 / C DATA IMACH(12) / -64 / C DATA IMACH(13) / 63 / C DATA IMACH(14) / 14 / C DATA IMACH(15) / -64 / C DATA IMACH(16) / 63 /, SANITY/987/ C C MACHINE CONSTANTS FOR THE INTERDATA 8/32 C WITH THE UNIX SYSTEM FORTRAN 77 COMPILER. C C FOR THE INTERDATA FORTRAN VII COMPILER REPLACE C THE Z'S SPECIFYING HEX CONSTANTS WITH Y'S. C C DATA IMACH( 1) / 5 / C DATA IMACH( 2) / 6 / C DATA IMACH( 3) / 6 / C DATA IMACH( 4) / 6 / C DATA IMACH( 5) / 32 / C DATA IMACH( 6) / 4 / C DATA IMACH( 7) / 2 / C DATA IMACH( 8) / 31 / C DATA IMACH( 9) / Z'7FFFFFFF' / C DATA IMACH(10) / 16 / C DATA IMACH(11) / 6 / C DATA IMACH(12) / -64 / C DATA IMACH(13) / 62 / C DATA IMACH(14) / 14 / C DATA IMACH(15) / -64 / C DATA IMACH(16) / 62 /, SANITY/987/ C C MACHINE CONSTANTS FOR THE PDP-10 (KA PROCESSOR). C C DATA IMACH( 1) / 5 / C DATA IMACH( 2) / 6 / C DATA IMACH( 3) / 7 / C DATA IMACH( 4) / 6 / C DATA IMACH( 5) / 36 / C DATA IMACH( 6) / 5 / C DATA IMACH( 7) / 2 / C DATA IMACH( 8) / 35 / C DATA IMACH( 9) / "377777777777 / C DATA IMACH(10) / 2 / C DATA IMACH(11) / 27 / C DATA IMACH(12) / -128 / C DATA IMACH(13) / 127 / C DATA IMACH(14) / 54 / C DATA IMACH(15) / -101 / C DATA IMACH(16) / 127 /, SANITY/987/ C C MACHINE CONSTANTS FOR THE PDP-10 (KI PROCESSOR). C C DATA IMACH( 1) / 5 / C DATA IMACH( 2) / 6 / C DATA IMACH( 3) / 7 / C DATA IMACH( 4) / 6 / C DATA IMACH( 5) / 36 / C DATA IMACH( 6) / 5 / C DATA IMACH( 7) / 2 / C DATA IMACH( 8) / 35 / C DATA IMACH( 9) / "377777777777 / C DATA IMACH(10) / 2 / C DATA IMACH(11) / 27 / C DATA IMACH(12) / -128 / C DATA IMACH(13) / 127 / C DATA IMACH(14) / 62 / C DATA IMACH(15) / -128 / C DATA IMACH(16) / 127 /, SANITY/987/ C C MACHINE CONSTANTS FOR PDP-11 FORTRANS SUPPORTING C 32-BIT INTEGER ARITHMETIC. C C DATA IMACH( 1) / 5 / C DATA IMACH( 2) / 6 / C DATA IMACH( 3) / 7 / C DATA IMACH( 4) / 6 / C DATA IMACH( 5) / 32 / C DATA IMACH( 6) / 4 / C DATA IMACH( 7) / 2 / C DATA IMACH( 8) / 31 / C DATA IMACH( 9) / 2147483647 / C DATA IMACH(10) / 2 / C DATA IMACH(11) / 24 / C DATA IMACH(12) / -127 / C DATA IMACH(13) / 127 / C DATA IMACH(14) / 56 / C DATA IMACH(15) / -127 / C DATA IMACH(16) / 127 /, SANITY/987/ C C MACHINE CONSTANTS FOR PDP-11 FORTRANS SUPPORTING C 16-BIT INTEGER ARITHMETIC. C C DATA IMACH( 1) / 5 / C DATA IMACH( 2) / 6 / C DATA IMACH( 3) / 7 / C DATA IMACH( 4) / 6 / C DATA IMACH( 5) / 16 / C DATA IMACH( 6) / 2 / C DATA IMACH( 7) / 2 / C DATA IMACH( 8) / 15 / C DATA IMACH( 9) / 32767 / C DATA IMACH(10) / 2 / C DATA IMACH(11) / 24 / C DATA IMACH(12) / -127 / C DATA IMACH(13) / 127 / C DATA IMACH(14) / 56 / C DATA IMACH(15) / -127 / C DATA IMACH(16) / 127 /, SANITY/987/ C C MACHINE CONSTANTS FOR THE PRIME 50 SERIES SYSTEMS C WTIH 32-BIT INTEGERS AND 64V MODE INSTRUCTIONS, C SUPPLIED BY IGOR BRAY. C C DATA IMACH( 1) / 1 / C DATA IMACH( 2) / 1 / C DATA IMACH( 3) / 2 / C DATA IMACH( 4) / 1 / C DATA IMACH( 5) / 32 / C DATA IMACH( 6) / 4 / C DATA IMACH( 7) / 2 / C DATA IMACH( 8) / 31 / C DATA IMACH( 9) / :17777777777 / C DATA IMACH(10) / 2 / C DATA IMACH(11) / 23 / C DATA IMACH(12) / -127 / C DATA IMACH(13) / +127 / C DATA IMACH(14) / 47 / C DATA IMACH(15) / -32895 / C DATA IMACH(16) / +32637 /, SANITY/987/ C C MACHINE CONSTANTS FOR THE SEQUENT BALANCE 8000. C C DATA IMACH( 1) / 0 / C DATA IMACH( 2) / 0 / C DATA IMACH( 3) / 7 / C DATA IMACH( 4) / 0 / C DATA IMACH( 5) / 32 / C DATA IMACH( 6) / 1 / C DATA IMACH( 7) / 2 / C DATA IMACH( 8) / 31 / C DATA IMACH( 9) / 2147483647 / C DATA IMACH(10) / 2 / C DATA IMACH(11) / 24 / C DATA IMACH(12) / -125 / C DATA IMACH(13) / 128 / C DATA IMACH(14) / 53 / C DATA IMACH(15) / -1021 / C DATA IMACH(16) / 1024 /, SANITY/987/ C C MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES. C C NOTE THAT THE PUNCH UNIT, I1MACH(3), HAS BEEN SET TO 7 C WHICH IS APPROPRIATE FOR THE UNIVAC-FOR SYSTEM. C IF YOU HAVE THE UNIVAC-FTN SYSTEM, SET IT TO 1. C C DATA IMACH( 1) / 5 / C DATA IMACH( 2) / 6 / C DATA IMACH( 3) / 7 / C DATA IMACH( 4) / 6 / C DATA IMACH( 5) / 36 / C DATA IMACH( 6) / 6 / C DATA IMACH( 7) / 2 / C DATA IMACH( 8) / 35 / C DATA IMACH( 9) / O377777777777 / C DATA IMACH(10) / 2 / C DATA IMACH(11) / 27 / C DATA IMACH(12) / -128 / C DATA IMACH(13) / 127 / C DATA IMACH(14) / 60 / C DATA IMACH(15) /-1024 / C DATA IMACH(16) / 1023 /, SANITY/987/ C C MACHINE CONSTANTS FOR VAX. C C DATA IMACH( 1) / 5 / C DATA IMACH( 2) / 6 / C DATA IMACH( 3) / 7 / C DATA IMACH( 4) / 6 / C DATA IMACH( 5) / 32 / C DATA IMACH( 6) / 4 / C DATA IMACH( 7) / 2 / C DATA IMACH( 8) / 31 / C DATA IMACH( 9) / 2147483647 / C DATA IMACH(10) / 2 / C DATA IMACH(11) / 24 / C DATA IMACH(12) / -127 / C DATA IMACH(13) / 127 / C DATA IMACH(14) / 56 / C DATA IMACH(15) / -127 / C DATA IMACH(16) / 127 /, SANITY/987/ C C *** ISSUE STOP 777 IF ALL DATA STATEMENTS ARE COMMENTED... IF (SANITY .NE. 987) STOP 777 IF (I .LT. 1 .OR. I .GT. 16) GO TO 10 C I1MACH = IMACH(I) C/6S C/7S IF(I.EQ.6) I1MACH=1 C/ RETURN 10 WRITE(6,1999) I 1999 FORMAT(' I1MACH - I OUT OF BOUNDS',I10) STOP 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 modified 3/93 to return if incx .le. 0. c double precision dx(*),dmax integer i,incx,ix,n c idamax = 0 if( n.lt.1 .or. incx.le.0 ) 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 SUBROUTINE IMTQL1(N,D,E,IERR) C INTEGER I,J,L,M,N,II,MML,IERR DOUBLE PRECISION D(N),E(N) DOUBLE PRECISION B,C,F,G,P,R,S,TST1,TST2,PYTHAG C C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE IMTQL1, C NUM. MATH. 12, 377-383(1968) BY MARTIN AND WILKINSON, C AS MODIFIED IN NUM. MATH. 15, 450(1970) BY DUBRULLE. C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 241-248(1971). C C THIS SUBROUTINE FINDS THE EIGENVALUES OF A SYMMETRIC C TRIDIAGONAL MATRIX BY THE IMPLICIT QL METHOD. C C ON INPUT C C N IS THE ORDER OF THE MATRIX. C C D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX. C C E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE INPUT MATRIX C IN ITS LAST N-1 POSITIONS. E(1) IS ARBITRARY. C C ON OUTPUT C C D CONTAINS THE EIGENVALUES IN ASCENDING ORDER. IF AN C ERROR EXIT IS MADE, THE EIGENVALUES ARE CORRECT AND C ORDERED FOR INDICES 1,2,...IERR-1, BUT MAY NOT BE C THE SMALLEST EIGENVALUES. C C E HAS BEEN DESTROYED. C C IERR IS SET TO C ZERO FOR NORMAL RETURN, C J IF THE J-TH EIGENVALUE HAS NOT BEEN C DETERMINED AFTER 30 ITERATIONS. C C CALLS PYTHAG FOR DSQRT(A*A + B*B) . C C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY C C THIS VERSION DATED APRIL 1983. C C ------------------------------------------------------------------ C IERR = 0 IF (N .EQ. 1) GO TO 1001 C DO 100 I = 2, N 100 E(I-1) = E(I) C E(N) = 0.0D0 C DO 290 L = 1, N J = 0 C .......... LOOK FOR SMALL SUB-DIAGONAL ELEMENT .......... 105 DO 110 M = L, N IF (M .EQ. N) GO TO 120 TST1 = DABS(D(M)) + DABS(D(M+1)) TST2 = TST1 + DABS(E(M)) IF (TST2 .EQ. TST1) GO TO 120 110 CONTINUE C 120 P = D(L) IF (M .EQ. L) GO TO 215 IF (J .EQ. 30) GO TO 1000 J = J + 1 C .......... FORM SHIFT .......... G = (D(L+1) - P) / (2.0D0 * E(L)) R = PYTHAG(G,1.0D0) G = D(M) - P + E(L) / (G + DSIGN(R,G)) S = 1.0D0 C = 1.0D0 P = 0.0D0 MML = M - L C .......... FOR I=M-1 STEP -1 UNTIL L DO -- .......... DO 200 II = 1, MML I = M - II F = S * E(I) B = C * E(I) R = PYTHAG(F,G) E(I+1) = R S = F / R C = G / R G = D(I+1) - P R = (D(I) - G) * S + 2.0D0 * C * B P = S * R D(I+1) = G + P G = C * R - B 200 CONTINUE C D(L) = D(L) - P E(L) = G E(M) = 0.0D0 GO TO 105 C .......... ORDER EIGENVALUES .......... 215 IF (L .EQ. 1) GO TO 250 C .......... FOR I=L STEP -1 UNTIL 2 DO -- .......... DO 230 II = 2, L I = L + 2 - II IF (P .GE. D(I-1)) GO TO 270 D(I) = D(I-1) 230 CONTINUE C 250 I = 1 270 D(I) = P 290 CONTINUE C GO TO 1001 C .......... SET ERROR -- NO CONVERGENCE TO AN C EIGENVALUE AFTER 30 ITERATIONS .......... 1000 IERR = L 1001 RETURN END SUBROUTINE IMTQL2(NM,N,D,E,Z,IERR) C INTEGER I,J,K,L,M,N,II,NM,MML,IERR DOUBLE PRECISION D(N),E(N),Z(NM,N) DOUBLE PRECISION B,C,F,G,P,R,S,TST1,TST2,PYTHAG C C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE IMTQL2, C NUM. MATH. 12, 377-383(1968) BY MARTIN AND WILKINSON, C AS MODIFIED IN NUM. MATH. 15, 450(1970) BY DUBRULLE. C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 241-248(1971). C C THIS SUBROUTINE FINDS THE EIGENVALUES AND EIGENVECTORS C OF A SYMMETRIC TRIDIAGONAL MATRIX BY THE IMPLICIT QL METHOD. C THE EIGENVECTORS OF A FULL SYMMETRIC MATRIX CAN ALSO C BE FOUND IF TRED2 HAS BEEN USED TO REDUCE THIS C FULL MATRIX TO TRIDIAGONAL FORM. C C ON INPUT C C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM C DIMENSION STATEMENT. C C N IS THE ORDER OF THE MATRIX. C C D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX. C C E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE INPUT MATRIX C IN ITS LAST N-1 POSITIONS. E(1) IS ARBITRARY. C C Z CONTAINS THE TRANSFORMATION MATRIX PRODUCED IN THE C REDUCTION BY TRED2, IF PERFORMED. IF THE EIGENVECTORS C OF THE TRIDIAGONAL MATRIX ARE DESIRED, Z MUST CONTAIN C THE IDENTITY MATRIX. C C ON OUTPUT C C D CONTAINS THE EIGENVALUES IN ASCENDING ORDER. IF AN C ERROR EXIT IS MADE, THE EIGENVALUES ARE CORRECT BUT C UNORDERED FOR INDICES 1,2,...,IERR-1. C C E HAS BEEN DESTROYED. C C Z CONTAINS ORTHONORMAL EIGENVECTORS OF THE SYMMETRIC C TRIDIAGONAL (OR FULL) MATRIX. IF AN ERROR EXIT IS MADE, C Z CONTAINS THE EIGENVECTORS ASSOCIATED WITH THE STORED C EIGENVALUES. C C IERR IS SET TO C ZERO FOR NORMAL RETURN, C J IF THE J-TH EIGENVALUE HAS NOT BEEN C DETERMINED AFTER 30 ITERATIONS. C C CALLS PYTHAG FOR DSQRT(A*A + B*B) . C C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY C C THIS VERSION DATED APRIL 1983. C C ------------------------------------------------------------------ C IERR = 0 IF (N .EQ. 1) GO TO 1001 C DO 100 I = 2, N 100 E(I-1) = E(I) C E(N) = 0.0D0 C DO 240 L = 1, N J = 0 C .......... LOOK FOR SMALL SUB-DIAGONAL ELEMENT .......... 105 DO 110 M = L, N IF (M .EQ. N) GO TO 120 TST1 = DABS(D(M)) + DABS(D(M+1)) TST2 = TST1 + DABS(E(M)) IF (TST2 .EQ. TST1) GO TO 120 110 CONTINUE C 120 P = D(L) IF (M .EQ. L) GO TO 240 IF (J .EQ. 30) GO TO 1000 J = J + 1 C .......... FORM SHIFT .......... G = (D(L+1) - P) / (2.0D0 * E(L)) R = PYTHAG(G,1.0D0) G = D(M) - P + E(L) / (G + DSIGN(R,G)) S = 1.0D0 C = 1.0D0 P = 0.0D0 MML = M - L C .......... FOR I=M-1 STEP -1 UNTIL L DO -- .......... DO 200 II = 1, MML I = M - II F = S * E(I) B = C * E(I) R = PYTHAG(F,G) E(I+1) = R S = F / R C = G / R G = D(I+1) - P R = (D(I) - G) * S + 2.0D0 * C * B P = S * R D(I+1) = G + P G = C * R - B C .......... FORM VECTOR .......... DO 180 K = 1, N F = Z(K,I+1) Z(K,I+1) = S * Z(K,I) + C * F Z(K,I) = C * Z(K,I) - S * F 180 CONTINUE C 200 CONTINUE C D(L) = D(L) - P E(L) = G E(M) = 0.0D0 GO TO 105 240 CONTINUE C .......... ORDER EIGENVALUES AND EIGENVECTORS .......... DO 300 II = 2, N I = II - 1 K = I P = D(I) C DO 260 J = II, N IF (D(J) .GE. P) GO TO 260 K = J P = D(J) 260 CONTINUE C IF (K .EQ. I) GO TO 300 D(K) = D(I) D(I) = P C DO 280 J = 1, N P = Z(J,I) Z(J,I) = Z(J,K) Z(J,K) = P 280 CONTINUE C 300 CONTINUE C GO TO 1001 C .......... SET ERROR -- NO CONVERGENCE TO AN C EIGENVALUE AFTER 30 ITERATIONS .......... 1000 IERR = L 1001 RETURN END subroutine iniy(t0, npde, kcol, nint, neq, ncpts, ifglin, xcol, & xbs, abdblk, fbasis, y, ipivot, work, lw, icflag) c----------------------------------------------------------------------- c Purpose: c This routine performs the initialization tasks required by c inital including: c c calculating the Bspline basis functions, c constructing abdblk of the collocation matrices and c determining y(t0). c c----------------------------------------------------------------------- c c Last modified by Rong Wang, November 8, 2001. c c----------------------------------------------------------------------- c Constants: integer nconti parameter (nconti = 2) c nconti continuity conditions are imposed c at the internal mesh points. c double precision zero parameter (zero = 0.0D0) c double precision negone parameter (negone = -1.0D0) c c----------------------------------------------------------------------- c Subroutine Parameters: c Input: double precision t0 c t0 is the initial time. c integer npde c npde is the number of components in c the system of PDEs. npde > 0. c integer kcol c kcol is the number of collocation points c to be used in each subinterval. c integer nint c nint is the number of subintervals c defined by the spatial mesh x. c nint >= 1. c integer neq c neq=npde*(kcol*nint+nconti) is c the number of bsplines c coefficients (or DAEs). c integer ncpts c ncpts=(kcol*nint+nconti) is the number c of collocation points. c integer ifglin c ifglin is a flag for the boundary c conditions. c ifglin = 1, indicate both derichlet c boundary conditions; c = 0, else. c double precision xcol(ncpts) c The sequence of collocation points on c the interval [x_a, x_b]. c double precision xbs(ncpts+kcol+nconti) c The breakpoint sequence. c xbs(i)=x(1), i=1, kcol+nconti; c xbs((i-1)*kcol+nconti+j)=x(i), c i=2, nint; j=1, kcol c xbs(ncpts+i)=x(nint+1), i=1,kcol+nconti. c integer lw c lw is the size of the work storage c array and must satisfy: c lw >= 2*npde*npde*nconti+ c npde*npde*kcol*(kcol+nconti)*nint c +2*neq+2*npde+2*npde*npde c c Work Storage: integer ipivot(neq) c pivoting information from the c factorization of the temporary matrix. c double precision work(lw) c work is a floating point work storage c array of size lw. c c Output: double precision abdblk(npde*npde*nint*kcol & *(kcol+nconti)) c The nint blocks in the middle of c the matrix A. c double precision fbasis(kcol+nconti, 3, ncpts) c Basis function values at the collocation c points. fbasis(k,j,i) contains the c values of the (j-1)st derivative c (j=1,2,3) of the k-th non-zero basis c function (k=1,...,kcol+nconti) at the c i-th collocation point. c double precision y(neq) c y = y(t0) is the initial vector of c bspline coefficients. c integer icflag c This is the status flag from COLROW c which is called by crdcmp. c icflag = 0, indicates non-singularity. c icflag = -1, indicates singularity. c icflag = 1, indicates invalid input. c----------------------------------------------------------------------- c Local Variables: integer ileft c breakpoint information. c integer nels c the number of elements in one c collocation block of work. c c Pointers into the floating point work array: integer iabdtp c work(iabdtp) contains a copy of the top c block which is required since crdcmp c overwrites the input collocation matrix. c integer iabdbk c work(iabdbk) contains a copy of abdblk c which is required since crdcmp c overwrites the input collocation matrix. c integer iabdbt c work(iabdbt) contains a copy of the c bottom block which is required since c crdcmp overwrites the input collocation c matrix. c integer idelta c work(idelta) contains the residual which c indicates how well y satisfies to the c boundary condition and the initial c condition at the internal collocation c points. c integer ivcol c work(ivcol) contains the values of u c at the internal collocation points. c integer iu c work(iu) stores the approximation to c u(t,x). c integer iux c work(iux) stores the approximation to c the first spatial derivative of u(t,x). c integer iuxx c work(iuxx) stores the approximation to c the second spatial derivative of u(t,x). c integer idbdu c work(idbdu-1+i), i=1, npde*npde, c contains dbdu(npde,npde). That is, c dbdu(i,j) is the partial derivative c of the i-th component of the vector b c with respect to the j-th component c of the unknown function u. c integer idbdux c work(idbdux-1+i), i=1, npde*npde, c contains dbdux(npde,npde). That is, c dbdux(i,j) is the partial derivative c of the i-th component of the vector b c with respect to the j-th component c of the spatial derivative of the c unknown function u. c integer idbdt c work(idbdt-1+i), i=1, npde, contains c the partial derivative of the i-th c component of the vector b with respect c to time t. c c----------------------------------------------------------------------- c Loop indices: integer i integer j integer l integer m integer ii integer jj integer ll integer mm c c----------------------------------------------------------------------- c Subroutines Called: c bndxa c bndxb c bsplvd c difbxa c difbxb c eval c uinit c crdcmp c crslve c c----------------------------------------------------------------------- c BLAS Subroutines Called: c double precision: c dcopy c dscal c c----------------------------------------------------------------------- nels = npde*npde*kcol*(kcol+nconti) c Set the pointers into the floating point work array. iabdtp = 1 iabdbk = iabdtp + npde*npde*nconti iabdbt = iabdbk + nint*nels idelta = iabdbt + npde*npde*nconti ivcol = idelta + neq iu = ivcol + neq-2*npde iux = iu + npde iuxx = iux + npde idbdu = iuxx + npde idbdux = idbdu + npde*npde idbdt = idbdux + npde*npde c----------------------------------------------------------------------- c Initialize abdblk, the top block and the bottom block to zero. do 20 i = 1, npde*npde*nconti work(iabdtp-1+i) = zero work(iabdbt-1+i) = zero 20 continue do 30 i = 1, nint*nels abdblk(i) = zero 30 continue c----------------------------------------------------------------------- c Bsplvd is called to compute the components of fbasis(k,i,j) c associated the first collocation point. Now ileft = kcol + nconti. call bsplvd(xbs,kcol+nconti,xcol(1),kcol+nconti,fbasis(1,1,1),3) c Uinit is called to evaluate the first npde components at the c left boundary point, and save in y. call uinit(xcol(1), y(1), npde) c Makeing use of the fact that only the first bspline has a nonzero c value at the left end point, set up the top block in work. do 40 i = 1, npde ii = (i-1) * npde + i work(iabdtp-1+ii) = fbasis(1,1,1) 40 continue c----------------------------------------------------------------------- c The nint blocks at the middle of the matrix will now be set up. do 80 i = 1, nint c Make use the fact that there are kcol collocation points in each c subinterval to find the value of ileft. ileft = kcol + nconti + (i - 1) * kcol do 70 j = 1, kcol c ii is the position in xcol of the j-th collocation point of the c i-th subinterval. ii = (i-1) * kcol + 1 + j c jj is the position in the y vector where the values for the c right hand side of the initial conditions, evaluated at the ii-th c collocation point are stored. jj = (ii - 1) * npde + 1 c compute information for ii-th collocation point. call bsplvd(xbs,kcol+nconti,xcol(ii),ileft,fbasis(1,1,ii),3) call uinit(xcol(ii), y(jj), npde) do 60 l = 1, kcol + nconti c generate the subblock in abdblk corresponding to the ii-th c collocation point. c ll = (l-1)*npde*npde*kcol + (i-1)*nels + (j-1)*npde do 50 m = 1, npde mm = ll + (m -1)*npde*kcol + m abdblk(mm) = fbasis(l,1,ii) 50 continue 60 continue 70 continue 80 continue c----------------------------------------------------------------------- c Now, set up the bottom block, using the fact that only the c last bspline basis function is non-zero at the right end point. c Simultaneously, set up the corresponding part of the right hand c side. c call bsplvd(xbs,kcol+nconti,xcol(ncpts),ncpts, & fbasis(1,1,ncpts),3) ii = neq - npde + 1 call uinit(xcol(ncpts), y(ii), npde) do 90 i = 1, npde ii = ((i-1)+npde)*npde + i work(iabdbt-1+ii) = fbasis(kcol+nconti,1,ncpts) 90 continue c----------------------------------------------------------------------- c Copy the middle of the collocation matrix into temporary storage. call dcopy(nint*nels,abdblk,1,work(iabdbk),1) c Check whether both boundary conditions are derichlet boundary c conditions. If no, copy the values at the internal collocation c points to work(ivcol), which will be used for newton iterations. if (ifglin .eq. 0) then call dcopy(neq-2*npde,y(npde+1),1,work(ivcol),1) call dscal(neq-2*npde,negone,work(ivcol),1) endif c----------------------------------------------------------------------- c Generate the initial vector y(t0). c----------------------------------------------------------------------- c LU decompose the matrix. call crdcmp(neq,work(iabdtp),npde,2*npde,work(iabdbk),kcol*npde, & (kcol+nconti)*npde,nint,work(iabdbt),npde,ipivot, & icflag) if (icflag .ne. 0) goto 999 c Solve the linear system. If derichlet boundary conditions are c given, this gives the basis function coefficients for the initial c conditions, i.e. y(t0). If not, this gives the predictor of y(t0). call crslve(work(iabdtp),npde,2*npde,work(iabdbk),kcol*npde, & (kcol+nconti)*npde,nint,work(iabdbt),npde,ipivot,y,0) if (icflag .ne. 0) goto 999 c Check whether both boundary conditions are derichlet boundary c conditions. if (ifglin .eq. 1) goto 999 c----------------------------------------------------------------------- c Newton iteration loop. c Calculate (work(idelta-1+i), i = npde+1, neq-npde), which depends c on the nint blocks in the middle of the collocation matrix A. call dcopy(neq-2*npde,work(ivcol),1,work(idelta+npde),1) do 130 i = 1, nint do 120 j = 1, kcol + nconti do 110 l = 1, kcol ll = 1+(i-1)*npde*npde*kcol*(kcol+nconti) & +(j-1)*npde*npde*kcol+(l-1)*npde do 100 m = 1, npde ii = idelta-1+npde+(i-1)*npde*kcol+(l-1)*npde+m mm = (i-1)*kcol*npde+(j-1)*npde+m work(ii) = work(ii) + abdblk(ll) * y(mm) 100 continue 110 continue 120 continue 130 continue c Copy the middle of the collocation matrix into temporary storage. call dcopy(nint*nels,abdblk,1,work(iabdbk),1) c Update the values at the left boundary. call eval(npde,kcol,kcol+2,1,ncpts,work(iu),work(iux), & work(iuxx),fbasis(1,1,1),y) call bndxa(t0, work(iu), work(iux), work(idelta), npde) call difbxa(t0, work(iu), work(iux), work(idbdu), & work(idbdux), work(idbdt), npde) c Set up the top block and save in work(iabdtp). do 150 j = 1, npde do 140 i = 1, npde ii = iabdtp - 1 + (j - 1) * npde + i jj = ii + npde * npde mm = (j - 1) * npde + i work(jj) = fbasis(2,2,1) * work(idbdux-1+mm) work(ii) = work(idbdu-1+mm) - work(jj) 140 continue 150 continue c Update the values at the right boundary. call eval(npde,kcol,ncpts,ncpts,ncpts,work(iu),work(iux), & work(iuxx),fbasis(1,1,ncpts),y) call bndxb(t0, work(iu), work(iux), work(idelta+neq-npde), npde) call difbxb(t0,work(iu),work(iux),work(idbdu), & work(idbdux),work(idbdt),npde) c Set up the bottom block and save in work(iabdbt). do 170 j = 1, npde do 160 i = 1, npde ii = iabdbt - 1 + (j - 1) * npde + i jj = ii + npde * npde mm = (j - 1) * npde + i work(ii) = fbasis(kcol+1,2,ncpts) * work(idbdux-1+mm) work(jj) = work(idbdu-1+mm) - work(ii) 160 continue 170 continue c LU decompose the matrix. call crdcmp(neq,work(iabdtp),npde,2*npde,work(iabdbk),kcol*npde, & (kcol+nconti)*npde,nint,work(iabdbt),npde,ipivot, & icflag) if (icflag .ne. 0) goto 999 c Solve the corrector equation. call crslve(work(iabdtp),npde,2*npde,work(iabdbk),kcol*npde, & (kcol+nconti)*npde,nint,work(iabdbt),npde,ipivot, & work(idelta),0) if (icflag .ne. 0) goto 999 c Now generate the corrector of y(t0). do 180 i = 1, neq y(i) = y(i) - work(idelta-1+i) 180 continue c----------------------------------------------------------------------- 999 return end subroutine iniyp(t0, npde, kcol, nint, neq, ncpts, xcol, & abdtop, abdblk, abdbot, fbasis, y, yprime, & ipivot, work, lw, icflag) c----------------------------------------------------------------------- c Purpose: c This routine performs the initialization tasks required by c bacol including: c c determining yprime(t0). c c----------------------------------------------------------------------- c c Last modified by Rong Wang, November 8, 2001. c c----------------------------------------------------------------------- c Constants: integer nconti parameter (nconti = 2) c nconti continuity conditions are imposed c at the internal mesh points. c double precision zero parameter (zero = 0.0D0) c c----------------------------------------------------------------------- c Subroutine Parameters: c Input: double precision t0 c t0 is the initial time. c integer npde c npde is the number of components in c the system of PDEs. npde > 0. c integer kcol c kcol is the number of collocation points c to be used in each subinterval. c integer nint c nint is the number of subintervals c defined by the spatial mesh x. c nint >= 1. c integer neq c neq=npde*(kcol*nint+nconti) is c the number of bsplines c coefficients (or DAEs). c integer ncpts c ncpts=(kcol*nint+nconti) is the number c of collocation points. c double precision xcol(ncpts) c The sequence of collocation points on c the interval [x_a,x_b]. c double precision abdblk(npde*npde*nint*kcol & *(kcol+nconti)) c The nint blocks in the middle of c the matrix A. c double precision fbasis(kcol+nconti, 3, ncpts) c Basis function values at the collocation c points. fbasis(k,j,i) contains the c values of the (j-1)st derivative c (j=1,2,3) of the k-th non-zero basis c function (k=1,...,kcol+nconti) at the c i-th collocation point. c double precision y(neq) c y = y(t0) is the initial vector of c bspline coefficients. c c Output: double precision abdtop(npde*npde*nconti) c The first block of the matrix A. c double precision abdbot(npde*npde*nconti) c The last block of the matrix A. c double precision yprime(neq) c yprime = yprime(t0) is the initial c vector of bspline coefficients c for the first temporal derivative. c integer icflag c This is the status flag from COLROW c which is called by crdcmp. c icflag = 0, indicates non-singularity. c icflag = -1, indicates singularity. c icflag = 1, indicates invalid input. c integer lw c lw is the size of the work storage c array and must satisfy: c lw >= 2*npde*npde*nconti+ c npde*npde*kcol*(kcol+nconti)*nint+ c npde*3+2*npde*npde+npde. c c Work Storage: double precision work(lw) c work is a floating point work storage c array of size lw. c integer ipivot(neq) c pivoting information from the c factorization of the temporary matrix. c c----------------------------------------------------------------------- c Local Variables: c Pointers into the floating point work array: integer iabdtp c work(iabdtp) contains a copy of abdtop c which is required since crdcmp c overwrites the input collocation matrix. c integer iabdbk c work(iabdbk) contains a copy of abdblk c which is required since crdcmp c overwrites the input collocation matrix. c integer iabdbt c work(iabdbt) contains a copy of abdbot c which is required since crdcmp c overwrites the input collocation matrix. c integer iu c work(iu) stores the approximation to c u(t,x). c integer iux c work(iux) stores the approximation to c the first spatial derivative of u(t,x). c integer iuxx c work(iuxx) stores the approximation to c the second spatial derivative of u(t,x). c integer idbdu c work(idbdu-1+i), i=1, npde*npde, c contains dbdu(npde,npde). That is, c dbdu(i,j) is the partial derivative c of the i-th component of the vector b c with respect to the j-th component c of the unknown function u. c integer idbdux c work(idbdux-1+i), i=1, npde*npde, c contains dbdux(npde,npde), That is, c dbdux(i,j) is the partial derivative c of the i-th component of the vector b c with respect to the j-th component c of the spatial derivative of the c unknown function u. c integer idbdt c work(idbdt-1+i), i=1, npde, contains c the partial derivative of the i-th c component of the vector b with respect c to time t. c c----------------------------------------------------------------------- c Loop indices: integer i integer j integer ii integer jj integer mm c c----------------------------------------------------------------------- c Subroutines Called: c crdcmp c crslve c eval c difbxa c difbxb c f c c----------------------------------------------------------------------- c BLAS Subroutines Called: c double precision: c dcopy c c----------------------------------------------------------------------- c Set the pointers into the floating point work array. iabdtp = 1 iabdbk = iabdtp + npde*npde*nconti iabdbt = iabdbk + npde*npde*kcol*(kcol+nconti)*nint iu = iabdbt + npde*npde*nconti iux = iu + npde iuxx = iux + npde idbdu = iuxx + npde idbdux = idbdu + npde*npde idbdt = idbdux + npde*npde c----------------------------------------------------------------------- c Initialize abdtop, abdbot and abdblk to zero. do 20 i = 1, npde * npde * nconti abdtop(i) = zero abdbot(i) = zero work(iabdtp-1+i) = zero work(iabdbt-1+i) = zero 20 continue c----------------------------------------------------------------------- c Update the values at the left boundary. call eval(npde,kcol,kcol+2,1,ncpts,work(iu),work(iux), & work(iuxx),fbasis(1,1,1),y) call difbxa(t0, work(iu), work(iux), work(idbdu), & work(idbdux), work(idbdt), npde) c Store -work(idbdt), which is the right side of the left boundary c conditions, into yprime. do 100 i = 1, npde yprime(i) = - work(idbdt-1+i) 100 continue c Set up the top block and save in abdtop. do 120 j = 1, npde do 110 i = 1, npde ii = (j - 1) * npde + i jj = ii + npde * npde mm = (j - 1) * npde + i abdtop(jj) = fbasis(2,2,1) * work(idbdux-1+mm) abdtop(ii) = work(idbdu-1+mm) - abdtop(jj) 110 continue 120 continue c----------------------------------------------------------------------- c Generate the right side of ODEs at the collocation points c and save in yprime(i), i = npde + 1, neq - npde. do 140 i = 1, nint c ii is the value of ileft for the current collocation point. ii = kcol + nconti + (i - 1) * kcol do 130 j = 1, kcol c jj is the index of the current collocation point. jj = (i - 1) * kcol + j + 1 c mm is the pointer of yprime. mm = (jj - 1) * npde + 1 c Generate the approximate solution and its spatial c derivatives at the current collocation point. call eval(npde,kcol,ii,jj,ncpts,work(iu),work(iux), & work(iuxx),fbasis(1,1,jj),y) c Evaluate the function f defining the PDE at the current c collocation point, storing the result in yprime. call f(t0,xcol(jj),work(iu),work(iux),work(iuxx),yprime(mm), & npde) 130 continue 140 continue c----------------------------------------------------------------------- c Update the values at the right boundary. call eval(npde,kcol,ncpts,ncpts,ncpts,work(iu),work(iux), & work(iuxx),fbasis(1,1,ncpts),y) call difbxb(t0,work(iu),work(iux),work(idbdu), & work(idbdux),work(idbdt),npde) c Store -work(idbdt), which is the right side of the right boundary c conditions, into yprime. do 150 i = 1, npde ii = neq - npde + i yprime(ii) = - work(idbdt-1+i) 150 continue c Set up the bottom block and save in abdbot. do 170 j = 1, npde do 160 i = 1, npde ii = (j - 1) * npde + i jj = ii + npde * npde mm = (j - 1) * npde + i abdbot(ii) = fbasis(kcol+1,2,ncpts) * work(idbdux-1+mm) abdbot(jj) = work(idbdu-1+mm) - abdbot(ii) 160 continue 170 continue c----------------------------------------------------------------------- c Copy the collocation matrix into temporary storage. call dcopy(npde*npde*nconti, abdtop, 1, work(iabdtp), 1) c call dcopy(npde*npde*kcol*(kcol+nconti)*nint, abdblk, 1, & work(iabdbk), 1) c call dcopy(npde*npde*nconti, abdbot, 1, work(iabdbt), 1) c----------------------------------------------------------------------- c Generate the initial vector yp(t0). c LU decompose the matrix. call crdcmp(neq,work(iabdtp),npde,2*npde,work(iabdbk),kcol*npde, & (kcol+nconti)*npde,nint,work(iabdbt),npde,ipivot, & icflag) if (icflag .ne. 0) go to 999 c c Solve the linear system. This gives yprime(t0) call crslve(work(iabdtp),npde,2*npde,work(iabdbk),kcol*npde, & (kcol+nconti)*npde,nint,work(iabdbt),npde,ipivot, & yprime,0) 999 continue return end SUBROUTINE INTERV ( XT, LXT, X, ILEFT, MFLAG, ILO) C----------------------------------------------------------------------- C THIS SUBROUTINE IS PART OF THE B-SPLINE PACKAGE FOR THE STABLE C EVALUATION OF ANY B-SPLINE BASIS FUNCTION OR DERIVATIVE VALUE. C SEE REFERENCE BELOW. C C COMPUTES LARGEST ILEFT IN (1,LXT) SUCH THAT XT(ILEFT) .LE. X. THE C PROGRAM STARTS THE SEARCH FOR ILEFT WITH THE VALUE OF ILEFT THAT WAS C RETURNED AT THE PREVIOUS CALL (AND WAS SAVED IN THE LOCAL VARIABLE C ILO) TO MINIMIZE THE WORK IN THE COMMON CASE THAT THE VALUE OF X ON C THIS CALL IS CLOSE TO THE VALUE OF X ON THE PREVIOUS CALL. SHOULD C THIS ASSUMPTION NOT BE VALID, THEN THE PROGRAM LOCATES ILO AND IHI C SUCH THAT XT(ILO) .LE. X .LT. XT(IHI) AND, ONCE THEY ARE FOUND USES C BISECTION TO FIND THE CORRECT VALUE FOR ILEFT. C C LAST MODIFIED BY RONG WANG, JAN 9, 2001. C C REFERENCE C C DEBOOR, C., PACKAGE FOR CALCULATING WITH B-SPLINES, SIAM J. C NUMER. ANAL., VOL. 14, NO. 3, JUNE 1977, PP. 441-472. C C PACKAGE ROUTINES CALLED.. NONE C USER ROUTINES CALLED.. NONE C CALLED BY.. COLPNT,INITAL,VALUES C FORTRAN FUNCTIONS USED.. NONE C----------------------------------------------------------------------- C SUBROUTINE PARAMETERS INTEGER LXT,ILEFT,MFLAG DOUBLE PRECISION XT(LXT),X C----------------------------------------------------------------------- C LOCAL VARIABLES INTEGER ILO,IHI,ISTEP,MIDDLE C----------------------------------------------------------------------- IF(MFLAG.EQ.-2) ILO = 1 IHI = ILO + 1 IF (IHI .LT. LXT) GO TO 20 IF (X .GE. XT(LXT)) GO TO 110 IF (LXT .LE. 1) GO TO 90 ILO = LXT - 1 GO TO 21 20 IF (X .GE. XT(IHI)) GO TO 40 21 IF (X .GE. XT(ILO)) GO TO 100 C----------------------------------------------------------------------- C NOW X .LT. XT(IHI). FIND LOWER BOUND. C----------------------------------------------------------------------- ISTEP = 1 31 IHI = ILO ILO = IHI - ISTEP IF (ILO .LE. 1) GO TO 35 IF (X .GE. XT(ILO)) GO TO 50 ISTEP = ISTEP*2 GO TO 31 35 ILO = 1 IF (X .LT. XT(1)) GO TO 90 GO TO 50 C----------------------------------------------------------------------- C NOW X .GE. XT(ILO). FIND UPPER BOUND. C----------------------------------------------------------------------- 40 ISTEP = 1 41 ILO = IHI IHI = ILO + ISTEP IF (IHI .GE. LXT) GO TO 45 IF (X .LT. XT(IHI)) GO TO 50 ISTEP = ISTEP*2 GO TO 41 45 IF (X .GE. XT(LXT)) GO TO 110 IHI = LXT C----------------------------------------------------------------------- C NOW XT(ILO) .LE. X .LT. XT(IHI). NARROW THE INTERVAL. C----------------------------------------------------------------------- 50 MIDDLE = (ILO + IHI)/2 IF (MIDDLE .EQ. ILO) GO TO 100 C----------------------------------------------------------------------- C NOTE.. IT IS ASSUMED THAT MIDDLE = ILO IN CASE IHI = ILO+1. C----------------------------------------------------------------------- IF (X .LT. XT(MIDDLE)) GO TO 53 ILO = MIDDLE GO TO 50 53 IHI = MIDDLE GO TO 50 C----------------------------------------------------------------------- C SET OUTPUT AND RETURN. C----------------------------------------------------------------------- 90 MFLAG = -1 ILEFT = 1 RETURN 100 MFLAG = 0 ILEFT = ILO RETURN 110 MFLAG = 1 ILEFT = LXT RETURN END subroutine jac(t, y, yprime, pd, cj, rpar, ipar) c----------------------------------------------------------------------- c Purpose: c This is the subroutine which defines the Jacobian of the c differential/algebraic system to be solved by DASSL. It returns: c PD := dG/dY + cj * dG/dY' c To be precise, the (i,j)th element of PD involves the partial c derivative of equation i with respect to the variable j (or its c time derivative). Or in psuedo-code we have: c c PD(i,j) = dG(i)/dY(j) + cj * dG(i)/dYprime(j). c c The DAE G(t, Y, Y') = 0 arises from applying the method-of-lines c and bspline collocation to the system of NPDE PDES of c the form: c u_t = f(t, x, u, u_x, u_xx) c In the discretized form this yields: c G(t, Y, Y') = A*Y' - F~ c The abd matrix A contains the collocation equations and some c boundary condition information, the vector F~ contains the rhs c of the collocation equations and the corresponding boundary c conditions. c c In view of this, we have: c PD = cj * A - dF~/dY. c Now by the product rule we can express df/dY as: c df/dY = df/du * du/dY + c df/du_x * du_x/dY + c df/du_xx * du_xx/dY. c So, in this fashion the elements of dF~/dY can be calculated. c c----------------------------------------------------------------------- c c Last modified by Rong Wang, August 13, 2001. c c----------------------------------------------------------------------- c Constants: integer nconti parameter (nconti = 2) c nconti continuity conditions are imposed c at the internal mesh points. c c----------------------------------------------------------------------- c Subroutine Parameters: c Input: double precision t c t is the current time. c double precision y(*) c y is the vector of bspline c coefficients at the current time. c double precision yprime(*) c yprime is the derivative of y with c respect to time at the current time. c double precision cj c cj is a scalar chosen by DASSL to c accelerate convergence of the modified c Newton iteration used to solve the c implicit equations resulting from the c BDF methods. c double precision rpar(*) c rpar is the BACOL floating point work c array. c integer ipar(*) c rpar is the BACOL integer work array. c c Output: double precision pd(*) c pd is the ABD Jacobian (iteration) c matrix of the residual of the DAE c system defined by RES. c c----------------------------------------------------------------------- c Direct pointers into the IPAR integer work array: integer inpde c ipar(inpde) = npde c integer ikcol c ipar(ikcol) = kcol. c integer inint c ipar(inint) = nint. c integer incpt1 c ipar(incpt1) = ncpts1. c integer ineq1 c ipar(ineq1) = neq1. c c----------------------------------------------------------------------- c Indirect pointers into the RPAR floating point work array: integer ixcol1 c rpar(ipar(ixcol1)) stores the c collocation points when using c dassl_kcol. c integer ixcol2 c rpar(ipar(ixcol2)) stores the c collocation points when using c dassl_kcol+1. c integer iabtp1 c rpar(ipar(iabtp1)) stores the top block c of the ABD collocation matrices when c using dassl_kcol. c integer iabtp2 c rpar(ipar(iabtp2)) stores the top block c of the ABD collocation matrices when c using dassl_kcol+1. c integer iabbk1 c rpar(ipar(iabbk1)) stores the nint c blocks in the middle of the ABD c collocation matrices when using c dassl_kcol. c integer iabbk2 c rpar(ipar(iabbk2)) stores the nint c blocks in the middle of the ABD c collocation matrices when using c dassl_kcol+1. c integer iabbt1 c rpar(ipar(iabbt1)) stores the bottom c block of the ABD collocation matrices c when using dassl_kcol. c integer iabbt2 c rpar(ipar(iabbt2)) stores the bottom c block of the ABD collocation matrices c when using dassl_kcol+1. c integer iwkrj c rpar(ipar(iwkrj)) stores an additional c work array required by res and jac. c integer ibasi1 c rpar(ipar(ibasi1)) stores the basis c function values at the collocation c points when using dassl_kcol. c rpar(ipar(ibasi1)) contains c a three dimensional array A of size c (kcol+nconti,3,ncpts). A(k,j,i) contains c the values of the (j-1)st derivative c (j=1,2,3) of the k-th non-zero basis c function (k=1,...,kcol+nconti) at the c i-th collocation point. c integer ibasi2 c rpar(ipar(ibasi2)) stores the basis c function values at the collocation c points when using dassl_kcol+1. c rpar(ipar(ibasi2)) contains c a three dimensional array A of size c (kcol+1+nconti,3,ncpts). A(k,j,i) c contains the values of the (j-1)st c derivative (j=1,2,3) of the k-th c non-zero basis function (k=1,..., c kcol+1+nconti) at the i-th collocation c point. c c c----------------------------------------------------------------------- c Local Variables: integer npde integer kcol integer nint integer ncpts1 integer ncpts2 integer neq1 integer neq2 integer npdp1 c c----------------------------------------------------------------------- c Direct IPAR indices: parameter (inpde = 1) parameter (ikcol = 2) parameter (inint = 3) parameter (incpt1 = 4) parameter (ineq1 = 5) c c----------------------------------------------------------------------- c IPAR indices which serve as an indirect pointer into RPAR: parameter (ixcol1 = 22) parameter (iabtp1 = 26) parameter (iabbk1 = 27) parameter (iabbt1 = 28) parameter (iwkrj = 30) parameter (ibasi1 = 31) c parameter (ixcol2 = 41) parameter (iabtp2 = 45) parameter (iabbk2 = 46) parameter (iabbt2 = 47) parameter (ibasi2 = 48) c c----------------------------------------------------------------------- c Subroutines Called: c caljac c c----------------------------------------------------------------------- npde = ipar(inpde) kcol = ipar(ikcol) nint = ipar(inint) ncpts1 = ipar(incpt1) neq1 = ipar(ineq1) ncpts2 = ncpts1 + nint neq2 = neq1 + nint * npde npdp1 = npde * npde * (2 * nconti + nint * kcol * & (kcol + nconti)) + 1 c Calculate jacobian for dassl_kcol. call caljac(npde, kcol, nint, ncpts1, neq1, rpar(ipar(ixcol1)), & rpar(ipar(iabtp1)), rpar(ipar(iabbk1)), & rpar(ipar(iabbt1)), rpar(ipar(ibasi1)), t, y, & yprime, cj, rpar(ipar(iwkrj)), pd) c Calculate jacobian for dassl_kcol+1. call caljac(npde, kcol+1, nint, ncpts2, neq2, rpar(ipar(ixcol2)), & rpar(ipar(iabtp2)), rpar(ipar(iabbk2)), & rpar(ipar(iabbt2)), rpar(ipar(ibasi2)), t, y(neq1+1), & yprime(neq1+1), cj, rpar(ipar(iwkrj)), pd(npdp1)) return end subroutine meshsq(kcol, nint, x, work, h, excol, ewts) c----------------------------------------------------------------------- c Purpose: c This routine calculates the mesh size sequence, then generates c the collocation points and Gaussian weights for error c estimate. c c----------------------------------------------------------------------- c c Last modified by Rong Wang, April 5, 2001. c c----------------------------------------------------------------------- c Constants: integer mxkcol parameter (mxkcol = 10) c mxkcol is the maximum number of c collocation points per subinterval. c c----------------------------------------------------------------------- c Subroutine Parameters: c Input: integer kcol c kcol is the number of collocation points c to be used in each subinterval. c integer nint c nint is the number of subintervals c defined by the spatial mesh x. c nint >= 1. c double precision x(nint+1) c x is the spatial mesh which divides the c interval [x_a, x_b] as: x_a = x(1) < c x(2) < x(3) < ... < x(nint+1) = x_b. c c Work Storage: double precision work((kcol+3)*(kcol+3)) c work is a floating point work storage c array. c c Output: double precision h(nint) c h is the mesh step size sequence. c double precision excol(nint*(kcol+3)) c excol is the collocation point sequence c which is used for error estimate. c double precision ewts(nint*(kcol+3)) c ewts is the gaussian weight sequence c which is used for error estimate. c c----------------------------------------------------------------------- c Local Variables: double precision rho(mxkcol+3) c rho stores the Gaussian points. c double precision wts(mxkcol+3) c wts stores the Gaussian weights. c c----------------------------------------------------------------------- c Loop indices: integer i integer j integer ii c c----------------------------------------------------------------------- c Subroutines Called: c gauleg c c----------------------------------------------------------------------- c Calculate the mesh step size sequence. do 10 i = 1, nint h(i) = x(i+1)-x(i) 10 continue c Compute the Gaussian points and Gaussian weights. call gauleg(kcol+3, (kcol+3)*(kcol+3), rho, wts, & work, 4) c Define the collocation point sequence. do 30 i = 1, nint ii = (i - 1) * (kcol + 3) do 20 j = 1, kcol+3 excol(ii + j) = x(i) + h(i) * rho(j) ewts(ii + j) = h(i) * wts(j) 20 continue 30 continue return end DOUBLE PRECISION FUNCTION PYTHAG(A,B) DOUBLE PRECISION A,B C C FINDS DSQRT(A**2+B**2) WITHOUT OVERFLOW OR DESTRUCTIVE UNDERFLOW C DOUBLE PRECISION P,Q,R,S,T P = DMAX1(DABS(A),DABS(B)) Q = DMIN1(DABS(A),DABS(B)) IF (Q .EQ. 0.0D0) GO TO 20 10 CONTINUE R = (Q/P)**2 T = 4.0D0 + R IF (T .EQ. 4.0D0) GO TO 20 S = R/T P = P + (2.0D0*S)*P Q = S*Q GO TO 10 20 PYTHAG = P RETURN END subroutine reinit(npde, kcol, kold, nint, ninold, ncpts, neq, & neqold, icount, istep, nstep, x, xold, yold, & iflag, work, lw, ipivot, h, xbs, xcol, & fbasis, y, abdblk, icflag) c----------------------------------------------------------------------- c Purpose: c This routine performs the initialization tasks after remeshing: c c calculating the mesh step size sequence, c generating the piecewise polynomial space breakpoint c sequence, c calculating the collocation point sequence, c calculating the B-spline basis functions, c constructing abdblk of the collocation matrices and c calculating the bspline coefficients at the last nstep c steps which is needed for a warm start. c c----------------------------------------------------------------------- c c Last modified by Rong Wang, November 8, 2001. c c----------------------------------------------------------------------- c Constants: integer nconti parameter (nconti = 2) c nconti continuity conditions are imposed c at the internal mesh points. c double precision zero parameter (zero = 0.0D0) c c----------------------------------------------------------------------- c Subroutine Parameters: c Input: integer npde c npde is the number of components in c the system of PDEs. npde > 0. c integer kcol c kcol is the number of collocation points c to be used in each subinterval after c remeshing. c integer kold c kold is the number of collocation points c to be used in each subinterval before c remeshing. c integer nint c nint is the number of subintervals after c remeshing. c integer ninold c ninold is the number of subintervals c before remeshing. c integer ncpts c ncpts=(kcol*nint+nconti) is the number c of collocation points. c integer neq c neq=npde*(kcol*nint+nconti) is c the number of bspline c coefficients after remeshing. c integer neqold c neqold=npde*(kold*ninold+nconti) is c the number of bspline c coefficients before remeshing. c integer icount c icount is the number of remeshing times c at the current step. c integer istep c istep is the number of time steps that c DASSL has taken when kcol collocation c points are used in each subinterval. c integer nstep c nstep is the number of time steps c on which the remeshing is needed. c double precision x(nint+1) c x is the spatial mesh after remeshing. c double precision xold(ninold+1) c xold is the spatial mesh before c remeshing. c double precision yold(6*neqold) c yold is the vector of bspline c coefficients at the last nstep time c steps before remeshing. c double precision h(nint) c h is the mesh step size sequence. c integer iflag c iflag is a flag. c iflag = 0, initialization is done for c dassl_kcol. c 1, initialization is done for c dassl_kcol+1. c integer lw c lw is the size of the work storage c array and must satisfy: c lw >= 2*npde*npde*nconti+ c npde*npde*kcol*(kcol+nconti)*nint c +(kold+nconti)+kold*(ninold+1) c +2*nconti c Since nint >= ninold/2 and kcol >= c kold+1, it implies that lw >= 3*neqold. c c Work Storage: double precision work(lw) c work is a floating point work storage c array of size lw. c integer ipivot(neq) c pivoting information from the c factorization of the temporary matrix. c c Output: double precision xcol(ncpts) c The sequence of collocation points on c the interval [x_a, x_b]. c double precision xbs(ncpts+kcol+nconti) c The breakpoint sequence. c double precision fbasis(kcol+nconti, 3, ncpts) c Basis function values at the collocation c points. c double precision y(nstep*neq) c y is the vector of bspline coefficients c at the last nstep time steps after c remeshing. c double precision abdblk(npde*npde*nint*kcol & *(kcol+nconti)) c The nint blocks in the middle of c the matrix A. c integer icflag c This is the status flag from COLROW c which is called by crdcmp. c icflag = 0, indicates non-singularity. c icflag = -1, indicates singularity. c icflag = 1, indicates invalid input. c----------------------------------------------------------------------- c Local Variables: integer ileft c breakpoint information. c integer nels c the number of elements in one c collocation block of work. c integer imod c c Pointers into the floating point work array: integer iabdtp c work(iabdtp) contains a copy of the top c block which is required since crdcmp c overwrites the input collocation matrix. c integer iabdbk c work(iabdbk) contains a copy of abdblk c which is required since crdcmp c overwrites the input collocation matrix. c integer iabdbt c work(iabdbt) contains a copy of the c bottom block which is required since c crdcmp overwrites the input collocation c matrix. c integer ivwork c work(ivwork) is the work storage c required by values. c c----------------------------------------------------------------------- c Loop indices: integer i integer j integer l integer m integer ii integer jj integer ll integer mm c c----------------------------------------------------------------------- c Subroutines Called: c bsplvd c colpnt c crdcmp c crslve c revalu c c----------------------------------------------------------------------- c BLAS Subroutines Called: c double precision: c dcopy c c----------------------------------------------------------------------- c Fortran Functions Used: c mod c c----------------------------------------------------------------------- c Generate the piecewise polynomial space breakpoint sequence, c and calculates the collocation point sequences. call colpnt(kcol, nint, ncpts, x, h, work, xcol, xbs) c----------------------------------------------------------------------- c Update yold. if ((iflag .ne. 0) .or. (icount .ne. 1)) goto 5 imod = mod(istep, 6) if (imod .eq. 0) then imod = 6 endif imod = 7 - imod if (imod .eq. 1) goto 5 if ((imod+nstep-1) .gt. 6) then if (imod .le. 3) then call dcopy((imod+nstep-1-6)*neqold, yold, 1, work, 1) call dcopy((6-imod+1)*neqold, yold((imod-1)*neqold+1), 1, & yold, 1) call dcopy((imod+nstep-1-6)*neqold, work, 1, & yold((6-imod+1)*neqold+1), 1) else call dcopy((6-imod+1)*neqold, yold((imod-1)*neqold+1), 1, & work, 1) call dcopy((imod+nstep-1-6)*neqold, yold, -1, & yold((6-imod+1)*neqold+1), -1) call dcopy((6-imod+1)*neqold, work, 1, yold, 1) endif else call dcopy(nstep*neqold, yold((imod-1)*neqold+1), 1, yold, 1) endif 5 continue c----------------------------------------------------------------------- nels = npde*npde*kcol*(kcol+nconti) c Set the pointers into the floating point work array. iabdtp = 1 iabdbk = iabdtp + npde*npde*nconti iabdbt = iabdbk + nint*nels ivwork = iabdbt + npde*npde*nconti c----------------------------------------------------------------------- c Call revalu to calculate the values at xcol and at the last nstep c time step. Then save in y. call revalu(kold, xcol, ninold, xold, npde, ncpts, nstep, & y, yold, work(ivwork)) c----------------------------------------------------------------------- c Initialize abdblk, the top block and the bottom block to zero. do 10 i = 1, npde * npde * nconti work(iabdtp-1+i) = zero work(iabdbt-1+i) = zero 10 continue do 20 i = 1, nint*nels abdblk(i) = zero 20 continue c----------------------------------------------------------------------- c Bsplvd is called to compute the components of fbasis(k,i,j) c associated the first collocation point. Now ileft = kcol + nconti. call bsplvd(xbs,kcol+nconti,xcol(1),kcol+nconti,fbasis(1,1,1),3) c Makeing use of the fact that only the first bspline has a nonzero c value at the left end point, set up the top block in work. do 30 i = 1, npde ii = (i-1) * npde + i work(iabdtp-1+ii) = fbasis(1,1,1) 30 continue c----------------------------------------------------------------------- c The nint blocks at the middle of the matrix will now be set up. do 70 i = 1, nint c Make use the fact that there are kcol collocation points in each c subinterval to find the value of ileft. ileft = kcol + nconti + (i - 1) * kcol do 60 j = 1, kcol c ii is the position in xcol of the j-th collocation point of the c i-th subinterval. ii = (i-1) * kcol + 1 + j c jj is the position in the y vector where the values for the c right hand side of the initial conditions, evaluated at the ii-th c collocation point are stored. jj = (ii - 1) * npde + 1 c compute information for ii-th collocation point. call bsplvd(xbs,kcol+nconti,xcol(ii),ileft,fbasis(1,1,ii),3) do 50 l = 1, kcol + nconti c generate the subblock in abdblk corresponding to the ii-th c collocation point. c ll = (l-1)*npde*npde*kcol + (i-1)*nels + (j-1)*npde do 40 m = 1, npde mm = ll + (m-1)*npde*kcol + m abdblk(mm) = fbasis(l,1,ii) 40 continue 50 continue 60 continue 70 continue c----------------------------------------------------------------------- c Now, set up the bottom block, using the fact that only the c last bspline basis function is non-zero at the right end point. c Simultaneously, set up the corresponding part of the right hand c side. c call bsplvd(xbs,kcol+nconti,xcol(ncpts),ncpts, & fbasis(1,1,ncpts),3) do 80 i = 1, npde ii = ((i-1)+npde)*npde + i work(iabdbt-1+ii) = fbasis(kcol+nconti,1,ncpts) 80 continue c----------------------------------------------------------------------- c Copy the middle of the collocation matrix into temporary storage. call dcopy(nels*nint,abdblk,1,work(iabdbk),1) c----------------------------------------------------------------------- c Generate the vector y. c LU decompose the matrix. call crdcmp(neq,work(iabdtp),npde,2*npde,work(iabdbk),kcol*npde, & (kcol+nconti)*npde,nint,work(iabdbt),npde,ipivot, & icflag) if (icflag .ne. 0) go to 999 c Solve the linear system. This gives the basis function c coefficients for the initial conditions, i.e. y(t0). do 90 i = 1, nstep ii = (i - 1) * neq + 1 call crslve(work(iabdtp),npde,2*npde,work(iabdbk),kcol*npde, & (kcol+nconti)*npde,nint,work(iabdbt),npde, & ipivot,y(ii),0) if (icflag .ne. 0) go to 999 90 continue 999 return end subroutine remesh(istart, icount, nintmx, ninpre, ninold, errrat, & errint, irshfg, xold, nint, kcol, x, work) c----------------------------------------------------------------------- c Purpose: c This routine generates a new mesh by equidistributing the error c in each subinterval. c c----------------------------------------------------------------------- c c Last modified by Rong Wang, August 22, 2001. c c----------------------------------------------------------------------- c Constants: double precision point5 parameter (point5 = 0.5d0) c double precision one parameter (one = 1.0d0) c double precision two parameter (two = 2.0d0) c double precision saffac parameter (saffac = 0.2d0) c c----------------------------------------------------------------------- c Subroutine Parameters: c input integer istart c istart is a flag to begin the code. c istart = 0, it is the initial step; c = 1, it is not the initial step. c integer icount c icount is the number of remeshing times c at the current step. c integer nintmx c the maximal number of subintervals that c the user requires. c integer ninpre c ninpre is the number of subintervals c when icount = 0 before remeshing. c integer ninold c ninold is the number of subintervals c before remeshing. c double precision errrat c errrat is the value of the largest c component of rpar(ipar(iercom)). c double precision errint(ninold) c errint is the error estimate at c each subintervals. c c Output: integer irshfg c irshfg is a flag for redefining all the c pointers. c irshfg = 0, initial call or continuation c calls; c = 1, remesh with a hot start. c = 2, remesh with a cold start. c double precision xold(ninpre+1) c xold is the spatial mesh when icount = 0 c before remeshing. c c In-output: integer kcol c kcol is the number of collocation points c to be used in each subinterval. c As input, it is the value before c remeshing; as output, it is the value c after remeshing. c integer nint c nint is the number of subintervals c defined by the spatial mesh x. c ninmx >= nint >= 1. c As input, it is the value before c remeshing; as output, it is the value c after remeshing. c double precision x(nintmx+1) c x is the spatial mesh. As input, it is c the value before remeshing; as output, c it is the value after remeshing. c c Work storage: double precision work(2*ninold+1) c c----------------------------------------------------------------------- c Local Variables: double precision aerr double precision berr c c Pointers into the floating point work array: integer ierror c work(ierror-1+i) is the L2-norm error c estimate at the first i subintervals. c integer ixold c work(ixold) contains a copy of mesh c points before remeshing. c c----------------------------------------------------------------------- c Loop indices: integer i integer j c c----------------------------------------------------------------------- c Functions used: c dble c int c c----------------------------------------------------------------------- c Set the pointers into the floating point work array. ierror = 1 ixold = ierror + ninold c----------------------------------------------------------------------- c Update xold. if (icount .eq. 0) then do 10 i = 1, ninpre + 1 xold(i) = x(i) 10 continue endif c----------------------------------------------------------------------- c Update icount, irshfg and nint. icount = icount + 1 c If this is the first remesh at the current step which is not the c initial step. if ((icount .eq. 1) .and. (istart .eq. 1)) then irshfg = 1 goto 20 endif c If after four hot start the code still can not satisfy the error c requirement, a cold start will take place. If ((icount .eq. 5) .and. (istart .eq. 1)) then irshfg = 2 nint = ninpre goto 20 endif c Update errrat. errrat = (errrat/saffac) ** (one/dble(kcol+2)) c Set the upper bound and lower bound of the ratio of nint over c ninold. if (errrat .gt. two) then errrat = two else if (errrat .lt. point5) then errrat = point5 endif endif nint = int(ninold * errrat) c The code does not allow nint = ninold. if (nint .eq. ninold) then nint = nint + 1 endif 20 continue c----------------------------------------------------------------------- c Update work(ixold) to be the mesh before remeshing. do 30 i = 1, ninold + 1 work(ixold-1+i) = x(i) 30 continue c----------------------------------------------------------------------- c Store work(i) to be the sum of the error at the first i c subintervals. work(ierror) = errint(1) do 40 i = ierror-1+2, ninold work(i) = errint(i) + work(i-1) 40 continue c Let aerr to be the mean value of errint(i). aerr = work(ninold)/dble(nint) c Equidistribute the mesh points. berr = aerr j = 1 do 60 i = 2, nint 50 continue if (berr .gt. work(j)) then j = j + 1 goto 50 else if (j .eq. 1) then x(i) = work(ixold) + (work(ixold-1+2) - work(ixold)) & * berr/work(1) else x(i) = work(ixold-1+j) + (work(ixold-1+j+1) - & work(ixold-1+j)) * (berr - work(j-1))/errint(j) endif endif berr = berr + aerr 60 continue x(1) = work(ixold) x(nint+1) = work(ixold-1+ninold+1) return end subroutine res(t, y, yprime, delta, ires, rpar, ipar) c----------------------------------------------------------------------- c Purpose: c This is the subroutine which defines the differential/algebraic c system to be solved by DASSL. It returns the residual (delta) of c the DAE system: c delta := G(t, Y, Y') c The DAE G(t, Y, Y') = 0 arises from applying the method-of-lines c and bspline collocation to the system of NPDE PDES of c the form: c u_t = f(t, x, u, u_x, u_xx) c In the discretized form this yields: c G(t, Y, Y') = A*Y' - F~ c The abd matrix A contains the collocation equations and some c boundary condition information, the vector F~ contains the rhs c of the collocation equations and the corresponding boundary c conditions. c c----------------------------------------------------------------------- c c Last modified by Rong Wang, November 8, 2001. c c----------------------------------------------------------------------- c Subroutine Parameters: c Input: double precision t c T is the current time. c double precision y(*) c y is the vector of bspline c coefficients at the current time. c double precision yprime(*) c yprime is the derivative of y with c respect to time at the current time. c double precision rpar(*) c rpar is the BACOL floating point work c array. c integer ipar(*) c rpar is the BACOL integer work array. c c Output: integer ires c ires is a user flag set to alert DASSL c of an illegal y vector. ires is not c used in this subroutine since there is c no restriction on the vector of c bspline coefficients. c double precision delta(*) c delta is the residual of the DAE system. c c----------------------------------------------------------------------- c Direct pointers into the IPAR integer work array: integer inpde c ipar(inpde) = npde c integer ikcol c ipar(ikcol) = kcol. c integer inint c ipar(inint) = nint. c integer incpt1 c ipar(incpt1) = ncpts1. c integer ineq1 c ipar(ineq1) = neq1. c c----------------------------------------------------------------------- c Indirect pointers into the RPAR floating point work array: integer ixcol1 c rpar(ipar(ixcol1)) stores the c collocation points when using c dassl_kcol. c integer ixcol2 c rpar(ipar(ixcol2)) stores the c collocation points when using c dassl_kcol+1. c integer iabbk1 c rpar(ipar(iabbk1)) stores the nint c blocks in the middle of the ABD c collocation matrices when using c dassl_kcol. c integer iabbk2 c rpar(ipar(iabbk2)) stores the nint c blocks in the middle of the ABD c collocation matrices when using c dassl_kcol+1. c integer iwkrj c rpar(ipar(iwkrj)) stores an additional c work array required by res and jac. c integer ibasi1 c rpar(ipar(ibasi1)) stores the basis c function values at the collocation c points when using dassl_kcol. c rpar(ipar(ibasi1)) contains c a three dimensional array A of size c (kcol+nconti,3,ncpts). A(k,j,i) contains c the values of the (j-1)st derivative c (j=1,2,3) of the k-th non-zero basis c function (k=1,...,kcol+nconti) at the c i-th collocation point. c integer ibasi2 c rpar(ipar(ibasi2)) stores the basis c function values at the collocation c points when using dassl_kcol+1. c rpar(ipar(ibasi2)) contains c a three dimensional array A of size c (kcol+1+nconti,3,ncpts). A(k,j,i) c contains the values of the (j-1)st c derivative (j=1,2,3) of the k-th c non-zero basis function (k=1,..., c kcol+1+nconti) at the i-th collocation c point. c c----------------------------------------------------------------------- c Local Variables: integer npde integer kcol integer nint integer ncpts1 integer ncpts2 integer neq1 integer neq2 c c----------------------------------------------------------------------- c Direct IPAR indices: parameter (inpde = 1) parameter (ikcol = 2) parameter (inint = 3) parameter (incpt1 = 4) parameter (ineq1 = 5) c c----------------------------------------------------------------------- c IPAR indices which serve as an indirect pointer into RPAR: parameter (ixcol1 = 22) parameter (iabbk1 = 27) parameter (iwkrj = 30) parameter (ibasi1 = 31) c parameter (ixcol2 = 41) parameter (iabbk2 = 46) parameter (ibasi2 = 48) c c----------------------------------------------------------------------- c Subroutines Called: c calres c c----------------------------------------------------------------------- npde = ipar(inpde) kcol = ipar(ikcol) nint = ipar(inint) ncpts1 = ipar(incpt1) neq1 = ipar(ineq1) ncpts2 = ncpts1 + nint neq2 = neq1 + nint * npde c Calculate residual for dassl_kcol. call calres(npde, kcol, nint, ncpts1, neq1, rpar(ipar(ixcol1)), & rpar(ipar(iabbk1)), rpar(ipar(ibasi1)), t, y, & yprime, rpar(ipar(iwkrj)), delta) c Calculate residual for dassl_kcol+1. call calres(npde, kcol+1, nint, ncpts2, neq2, rpar(ipar(ixcol2)), & rpar(ipar(iabbk2)), rpar(ipar(ibasi2)), t, y(neq1+1), & yprime(neq1+1), rpar(ipar(iwkrj)), delta(neq1+1)) return end subroutine revalu(kcol, xsol, nint, x, npde, npts, nstep, usol, & y, work) c----------------------------------------------------------------------- c Purpose: c This routine computes the solution u at the npts points xsol c and at the current and previous nstep-1 time step. Then return c them in the array usol. c c----------------------------------------------------------------------- c c Last modified by Rong Wang, Mar 31, 2006. c c----------------------------------------------------------------------- c Constants: integer nconti parameter (nconti = 2) c nconti continuity conditions are imposed c at the internal mesh points. c double precision zero parameter (zero = 0.0D0) c----------------------------------------------------------------------- c Subroutine Parameters: c input integer kcol c kcol is the number of collocation points c to be used in each subinterval. c integer npts c npts is the number of points in the c x vector. c double precision xsol(npts) c xsol is an arbitrary set of spatial c points at which the solution and the c first nderv derivative values are c to be calculated. c integer nint c nint is the number of subintervals c defined by the spatial mesh x. c nint >= 1. c double precision x(nint+1) c x is the spatial mesh which divides the c interval [x_a,x_b] as: x_a = x(1) < c x(2) < x(3) < ... < x(nint+1) = x_b. c integer npde c npde is the number of components in c the system of PDEs. npde > 0. c integer nstep c nstep-1 is the number of previous steps. c When user wants to calculate solution c at tout, let nstep = 1. c double precision y(npde*(nint*kcol+nconti), nstep) c y is the vector of bspline c coefficients at the current time step c and previous nstep-1 steps. c c output: double precision usol(npde, npts, nstep) c usol is the solution at the given c points and at the current time step c and previous nstep-1 steps. c c Work Storage: double precision work((kcol+nconti)+kcol*(nint+1) * +2*nconti) c work is a floating point work storage c array. c c----------------------------------------------------------------------- c Local Variables: integer ncpts c ncpts=(kcol*nint+nconti) is the number c of collocation points. c integer ileft c breakpoint information. c integer mflag c mflag is required by subroutine c interv. c integer ilo c ilo is required by subroutine c interv. c Pointers into the floating point work array: integer ixbs c work(ixbs) contains the breakpoint c sequence. c c----------------------------------------------------------------------- c Loop indices: integer i integer k integer m integer n integer ii integer mm c----------------------------------------------------------------------- c Subroutines Called: c bsplvd c interv c c----------------------------------------------------------------------- c set up the value for ileft and ncpts. ileft = 0 ncpts = nint * kcol + nconti c set the pointer into the floating point work array ixbs = (kcol+nconti) + 1 c Store the piecewise polynomial space breakpoint sequence in c work(ixbs). c do 10 i = 1, kcol + nconti work(ixbs-1+i) = x(1) work(ixbs-1+i+ncpts) = x(nint+1) 10 continue do 30 i = 2, nint ii = (i-2) * kcol + kcol + nconti do 20 k = 1, kcol work(ixbs-1+ii+k) = x(i) 20 continue 30 continue do 70 n = 1, nstep c c set up the value for ileft and ncpts. mflag = -2 do 60 i = 1, npts c c interv is called to compute ileft. bsplvd is called to compute c the values of the basis function at the required point. call interv(work(ixbs), ncpts, xsol(i), ileft, mflag, ilo) call bsplvd(work(ixbs),kcol+nconti,xsol(i),ileft,work,1) ii = ileft - kcol - nconti do 50 k = 1, npde usol(k,i,n) = zero do 40 m = 1, kcol + nconti mm = (m + ii - 1) * npde usol(k,i,n) = usol(k,i,n) + y(mm+k,n) * work(m) 40 continue 50 continue 60 continue 70 continue return end subroutine sucstp(istep, nstep, icount, neq2, icdas, cdasr, cypre, & cyprer, idas, dasr, ypre) c----------------------------------------------------------------------- c Purpose: c This routine stores the necessary information after each c accepted time step (i.e. no need remeshing). These information c is needed if a remeshing is required next step. c c----------------------------------------------------------------------- c c Last modified by Rong Wang, August 17, 2001. c c----------------------------------------------------------------------- c Subroutine Parameters: c input: integer istep c istep is the number of time steps that c DASSL has taken when using dassl. c integer nstep c nstep is the number of previous steps c necessary. c integer icount c icount is the number of remeshing times c at the current step. c integer neq2 c neq2 is the number of bspline c coefficients when using dassl_kcol+1. c integer icdas(20) c icdas stores the first 20 elements of c the integer work array in dassl. c double precision cdasr(40) c cdasr stores the first 40 elements of c the floating point work array in dassl. c double precision cypre(neq2) c cypre is the vector of bspline c coefficients at the current step. c double precision cyprer(6*neq2) c cyprer is the vector of bspline c coefficients at the previous steps. c c output: integer idas(20) c idas is a copy of icdas. c double precision dasr(40) c dasr is a copy of cdasr. c double precision ypre(6*neq2) c ypre1 stores the bspline coefficients c at the past 6 steps of dassl_kcol+1. c c----------------------------------------------------------------------- c Local Variables: integer imod integer itemp c c----------------------------------------------------------------------- c Loop Indices: integer i c c----------------------------------------------------------------------- c BLAS Subroutines Called: c dcopy c c----------------------------------------------------------------------- c Fortran Functions used: c mod c c----------------------------------------------------------------------- do 10 i = 1, 20 idas(i) = icdas(i) 10 continue call dcopy(40, cdasr, 1, dasr, 1) imod = mod(istep, 6) if (imod .eq. 0) then imod = 6 endif imod = 7 - imod call dcopy(neq2, cypre, 1, ypre((imod-1)*neq2+1), 1) if (icount .eq. 0) goto 99 c----------------------------------------------------------------------- c The following statement by set itemp = nstep is necessary to c avoid the confusion by some compilers. itemp = nstep if (itemp .eq. 6) then itemp = 5 endif if (imod .eq. 6) then call dcopy(itemp*neq2, cyprer, 1, ypre, 1) else if ((imod+itemp) .le. 6) then call dcopy(itemp*neq2, cyprer, 1, ypre(imod*neq2+1), 1) else call dcopy((6-imod)*neq2, cyprer, 1, ypre(imod*neq2+1), 1) call dcopy((itemp+imod-6)*neq2, cyprer((6-imod)*neq2+1), 1, & ypre, 1) endif endif c----------------------------------------------------------------------- 99 continue return end subroutine values(kcol, xsol, nint, x, npde, npts, nderiv, & usol, y, work) c----------------------------------------------------------------------- c Purpose: c This routine computes the solution u and the first nderv c derivatives of u at the npts points xsol. It then returns the c values in the array usol. c Constants: integer nconti parameter (nconti = 2) c nconti continuity conditions are imposed c at the internal mesh points. c double precision zero parameter (zero = 0.0D0) c----------------------------------------------------------------------- c c----------------------------------------------------------------------- c Subroutine Parameters: c input integer kcol c kcol is the number of collocation points to be used in c each subinterval. c integer npts c npts is the number of points in the x vector. c double precision xsol(npts) c xsol is an arbitrary set of spatial points at which the solution c and the first nderv derivative values are to be calculated. c integer nint c nint >= 1 is the number of subintervals defined by the spatial mesh x. c double precision x(nint+1) c x is the spatial mesh which divides the interval [x_a,x_b] into c x_a = x(1) < x(2) < x(3) < ... < x(nint+1) = x_b. c integer npde c npde is the number of components in the system of PDEs. npde > 0. c integer nderiv c nderiv is the number of derivatives of the solution which are c to be calculated. c double precision y(npde*(nint*kcol+nconti)) c y is the vector of bspline coefficients at the final time step. c c output: double precision usol(npde, npts, nderiv+1) c usol is the solution and the spatial derivatives up to the c nderiv-th derivative at the given points and at the final time step. c c Work Storage: double precision work((kcol+nconti)*(nderiv+1) * +kcol*(nint+1)+2*nconti) c work is a floating point work storage array. c c----------------------------------------------------------------------- c c----------------------------------------------------------------------- c Local Variables: integer ncpts c ncpts=(kcol*nint+nconti) is the number c of collocation points. c integer ileft c breakpoint information. c integer mflag c mflag is required by subroutine c interv. c integer ilo c ilo is required by subroutine c interv. c Pointers into the floating point work array: integer ixbs c work(ixbs) contains the breakpoint c sequence. c c----------------------------------------------------------------------- c Loop indices: integer i integer j integer k integer m integer ii integer mj integer mm c----------------------------------------------------------------------- c Subroutines Called: c bsplvd c interv c c----------------------------------------------------------------------- c set up the value for ileft, mflag and ncpts. ileft = 0 mflag = -2 ncpts = nint * kcol + nconti c set the pointer into the floating point work array ixbs = (kcol+nconti)*(nderiv+1) + 1 c Store the piecewise polynomial space breakpoint sequence in c work(ixbs). c do 10 i = 1, kcol + nconti work(ixbs-1+i) = x(1) work(ixbs-1+i+ncpts) = x(nint+1) 10 continue do 30 i = 2, nint ii = (i-2) * kcol + kcol + nconti do 20 k = 1, kcol work(ixbs-1+ii+k) = x(i) 20 continue 30 continue do 70 i = 1, npts c c interv is called to compute ileft. bsplvd is called to compute c the values of the basis function at the required point. call interv(work(ixbs), ncpts, xsol(i), ileft, mflag, ilo) call bsplvd(work(ixbs),kcol+nconti,xsol(i),ileft,work, & nderiv+1) ii = ileft - kcol - nconti do 60 j = 1, nderiv + 1 do 50 k = 1, npde usol(k,i,j) = zero do 40 m = 1, kcol + nconti mm = (m + ii - 1) * npde mj = (j - 1) * (kcol + nconti) + m usol(k,i,j) = usol(k,i,j) + y(mm+k) * work(mj) 40 continue 50 continue 60 continue 70 continue return end SUBROUTINE XERHLT (MESSG) C***BEGIN PROLOGUE XERHLT C***SUBSIDIARY C***PURPOSE Abort program execution and print error message. C***LIBRARY SLATEC (XERROR) C***CATEGORY R3C C***TYPE ALL (XERHLT-A) C***KEYWORDS ERROR, XERROR C***AUTHOR JONES, R. E., (SNLA) C***DESCRIPTION C C Abstract C ***Note*** machine dependent routine C XERHLT aborts the execution of the program. C The error message causing the abort is given in the calling C sequence, in case one needs it for printing on a dayfile, C for example. C C Description of Parameters C MESSG is as in XERROR. C C***REFERENCES JONES R.E., KAHANER D.K., 'XERROR, THE SLATEC ERROR- C HANDLING PACKAGE', SAND82-0800, SANDIA LABORATORIES, C 1982. C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C 790801 DATE WRITTEN as XERABT C 861211 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900206 Routine changed from user-callable to subsidiary. (WRB) C 900510 Changed calling sequence to delete length of char string C Changed subroutine name from XERABT to XERHLT. (RWC) C***END PROLOGUE XERHLT CHARACTER*(*) MESSG C***FIRST EXECUTABLE STATEMENT XERHLT STOP END C*DECK XERMSG SUBROUTINE XERMSG (LIBRAR, SUBROU, MESSG, NERR, LEVEL) c----------------------------------------------------------------------- c Explicit declarations made for variables declared by the implicit c Fortran 77 conventions. c----------------------------------------------------------------------- C***BEGIN PROLOGUE XERMSG C***PURPOSE Processes error messages for SLATEC and other libraries C***LIBRARY SLATEC C***CATEGORY R3C C***TYPE ALL C***KEYWORDS ERROR MESSAGE, XERROR C***AUTHOR FONG, KIRBY, (NMFECC AT LLNL) C Modified by C FRITSCH, F. N., (LLNL) C***DESCRIPTION C C XERMSG processes a diagnostic message in a manner determined by the C value of LEVEL and the current value of the library error control C flag, KONTRL. See subroutine XSETF for details. C (XSETF is inoperable in this version.). C C LIBRAR A character constant (or character variable) with the name C of the library. This will be 'SLATEC' for the SLATEC C Common Math Library. The error handling package is C general enough to be used by many libraries C simultaneously, so it is desirable for the routine that C detects and reports an error to identify the library name C as well as the routine name. C C SUBROU A character constant (or character variable) with the name C of the routine that detected the error. Usually it is the C name of the routine that is calling XERMSG. There are C some instances where a user callable library routine calls C lower level subsidiary routines where the error is C detected. In such cases it may be more informative to C supply the name of the routine the user called rather than C the name of the subsidiary routine that detected the C error. C C MESSG A character constant (or character variable) with the text C of the error or warning message. In the example below, C the message is a character constant that contains a C generic message. C C CALL XERMSG ('SLATEC', 'MMPY', C *'THE ORDER OF THE MATRIX EXCEEDS THE ROW DIMENSION', C *3, 1) C C It is possible (and is sometimes desirable) to generate a C specific message--e.g., one that contains actual numeric C values. Specific numeric values can be converted into C character strings using formatted WRITE statements into C character variables. This is called standard Fortran C internal file I/O and is exemplified in the first three C lines of the following example. You can also catenate C substrings of characters to construct the error message. C Here is an example showing the use of both writing to C an internal file and catenating character strings. C C CHARACTER*5 CHARN, CHARL C WRITE (CHARN,10) N C WRITE (CHARL,10) LDA C 10 FORMAT(I5) C CALL XERMSG ('SLATEC', 'MMPY', 'THE ORDER'//CHARN// C * ' OF THE MATRIX EXCEEDS ITS ROW DIMENSION OF'// C * CHARL, 3, 1) C C There are two subtleties worth mentioning. One is that C the // for character catenation is used to construct the C error message so that no single character constant is C continued to the next line. This avoids confusion as to C whether there are trailing blanks at the end of the line. C The second is that by catenating the parts of the message C as an actual argument rather than encoding the entire C message into one large character variable, we avoid C having to know how long the message will be in order to C declare an adequate length for that large character C variable. XERMSG calls XERPRN to print the message using C multiple lines if necessary. If the message is very long, C XERPRN will break it into pieces of 72 characters (as C requested by XERMSG) for printing on multiple lines. C Also, XERMSG asks XERPRN to prefix each line with ' * ' C so that the total line length could be 76 characters. C Note also that XERPRN scans the error message backwards C to ignore trailing blanks. Another feature is that C the substring '$$' is treated as a new line sentinel C by XERPRN. If you want to construct a multiline C message without having to count out multiples of 72 C characters, just use '$$' as a separator. '$$' C obviously must occur within 72 characters of the C start of each line to have its intended effect since C XERPRN is asked to wrap around at 72 characters in C addition to looking for '$$'. C C NERR An integer value that is chosen by the library routine's C author. It must be in the range -9999999 to 99999999 (8 C printable digits). Each distinct error should have its C own error number. These error numbers should be described C in the machine readable documentation for the routine. C The error numbers need be unique only within each routine, C so it is reasonable for each routine to start enumerating C errors from 1 and proceeding to the next integer. C C LEVEL An integer value in the range 0 to 2 that indicates the C level (severity) of the error. Their meanings are C C -1 A warning message. This is used if it is not clear C that there really is an error, but the user's attention C may be needed. An attempt is made to only print this C message once. C C 0 A warning message. This is used if it is not clear C that there really is an error, but the user's attention C may be needed. C C 1 A recoverable error. This is used even if the error is C so serious that the routine cannot return any useful C answer. If the user has told the error package to C return after recoverable errors, then XERMSG will C return to the Library routine which can then return to C the user's routine. The user may also permit the error C package to terminate the program upon encountering a C recoverable error. C C 2 A fatal error. XERMSG will not return to its caller C after it receives a fatal error. This level should C hardly ever be used; it is much better to allow the C user a chance to recover. An example of one of the few C cases in which it is permissible to declare a level 2 C error is a reverse communication Library routine that C is likely to be called repeatedly until it integrates C across some interval. If there is a serious error in C the input such that another step cannot be taken and C the Library routine is called again without the input C error having been corrected by the caller, the Library C routine will probably be called forever with improper C input. In this case, it is reasonable to declare the C error to be fatal. C C Each of the arguments to XERMSG is input; none will be modified by C XERMSG. A routine may make multiple calls to XERMSG with warning C level messages; however, after a call to XERMSG with a recoverable C error, the routine should return to the user. C C***REFERENCES JONES, RONDALL E. AND KAHANER, DAVID K., "XERROR, THE C SLATEC ERROR-HANDLING PACKAGE", SOFTWARE - PRACTICE C AND EXPERIENCE, VOLUME 13, NO. 3, PP. 251-257, C MARCH, 1983. C***ROUTINES CALLED XERHLT, XERPRN C***REVISION HISTORY (YYMMDD) C 880101 DATE WRITTEN C 880621 REVISED AS DIRECTED AT SLATEC CML MEETING OF FEBRUARY 1988. C THERE ARE TWO BASIC CHANGES. C 1. A NEW ROUTINE, XERPRN, IS USED INSTEAD OF XERPRT TO C PRINT MESSAGES. THIS ROUTINE WILL BREAK LONG MESSAGES C INTO PIECES FOR PRINTING ON MULTIPLE LINES. '$$' IS C ACCEPTED AS A NEW LINE SENTINEL. A PREFIX CAN BE C ADDED TO EACH LINE TO BE PRINTED. XERMSG USES EITHER C ' ***' OR ' * ' AND LONG MESSAGES ARE BROKEN EVERY C 72 CHARACTERS (AT MOST) SO THAT THE MAXIMUM LINE C LENGTH OUTPUT CAN NOW BE AS GREAT AS 76. C 2. THE TEXT OF ALL MESSAGES IS NOW IN UPPER CASE SINCE THE C FORTRAN STANDARD DOCUMENT DOES NOT ADMIT THE EXISTENCE C OF LOWER CASE. C 880708 REVISED AFTER THE SLATEC CML MEETING OF JUNE 29 AND 30. C THE PRINCIPAL CHANGES ARE C 1. CLARIFY COMMENTS IN THE PROLOGUES C 2. RENAME XRPRNT TO XERPRN C 3. REWORK HANDLING OF '$$' IN XERPRN TO HANDLE BLANK LINES C SIMILAR TO THE WAY FORMAT STATEMENTS HANDLE THE / C CHARACTER FOR NEW RECORDS. C 890706 REVISED WITH THE HELP OF FRED FRITSCH AND REG CLEMENS TO C CLEAN UP THE CODING. C 890721 REVISED TO USE NEW FEATURE IN XERPRN TO COUNT CHARACTERS IN C PREFIX. C 891013 REVISED TO CORRECT COMMENTS. C 891214 Prologue converted to Version 4.0 format. (WRB) C 900510 Changed test on NERR to be -9999999 < NERR < 99999999, but C NERR .ne. 0, and on LEVEL to be -2 < LEVEL < 3. Added C LEVEL=-1 logic, changed calls to XERSAV to XERSVE, and C XERCTL to XERCNT. (RWC) C 901011 Removed error saving features to produce a simplified C version for distribution with DASSL and other LLNL codes. C (FNF) C***END PROLOGUE XERMSG CHARACTER*(*) LIBRAR, SUBROU, MESSG CHARACTER*72 TEMP c----------------------------------------------------------------------- integer i, level, lkntrl, ltemp, mkntrl, nerr c----------------------------------------------------------------------- C***FIRST EXECUTABLE STATEMENT XERMSG C C WE PRINT A FATAL ERROR MESSAGE AND TERMINATE FOR AN ERROR IN C CALLING XERMSG. THE ERROR NUMBER SHOULD BE POSITIVE, C AND THE LEVEL SHOULD BE BETWEEN 0 AND 2. C IF (NERR.LT.-9999999 .OR. NERR.GT.99999999 .OR. NERR.EQ.0 .OR. * LEVEL.LT.-1 .OR. LEVEL.GT.2) THEN CALL XERPRN (' ***', -1, 'FATAL ERROR IN...$$ ' // * 'XERMSG -- INVALID ERROR NUMBER OR LEVEL$$ '// * 'JOB ABORT DUE TO FATAL ERROR.', 72) CALL XERHLT (' ***XERMSG -- INVALID INPUT') RETURN ENDIF C C SET DEFAULT VALUES FOR CONTROL PARAMETERS. C LKNTRL = 1 MKNTRL = 1 C C ANNOUNCE THE NAMES OF THE LIBRARY AND SUBROUTINE BY BUILDING A C MESSAGE IN CHARACTER VARIABLE TEMP (NOT EXCEEDING 66 CHARACTERS) C AND SENDING IT OUT VIA XERPRN. PRINT ONLY IF CONTROL FLAG C IS NOT ZERO. C IF (LKNTRL .NE. 0) THEN TEMP(1:21) = 'MESSAGE FROM ROUTINE ' I = MIN(LEN(SUBROU), 16) TEMP(22:21+I) = SUBROU(1:I) TEMP(22+I:33+I) = ' IN LIBRARY ' LTEMP = 33 + I I = MIN(LEN(LIBRAR), 16) TEMP(LTEMP+1:LTEMP+I) = LIBRAR (1:I) TEMP(LTEMP+I+1:LTEMP+I+1) = '.' LTEMP = LTEMP + I + 1 CALL XERPRN (' ***', -1, TEMP(1:LTEMP), 72) ENDIF C C IF LKNTRL IS POSITIVE, PRINT AN INTRODUCTORY LINE BEFORE C PRINTING THE MESSAGE. THE INTRODUCTORY LINE TELLS THE CHOICE C FROM EACH OF THE FOLLOWING TWO OPTIONS. C 1. LEVEL OF THE MESSAGE C 'INFORMATIVE MESSAGE' C 'POTENTIALLY RECOVERABLE ERROR' C 'FATAL ERROR' C 2. WHETHER CONTROL FLAG WILL ALLOW PROGRAM TO CONTINUE C 'PROGRAM CONTINUES' C 'PROGRAM ABORTED' C NOTICE THAT THE LINE INCLUDING FOUR PREFIX CHARACTERS WILL NOT C EXCEED 74 CHARACTERS. C WE SKIP THE NEXT BLOCK IF THE INTRODUCTORY LINE IS NOT NEEDED. C IF (LKNTRL .GT. 0) THEN C C THE FIRST PART OF THE MESSAGE TELLS ABOUT THE LEVEL. C IF (LEVEL .LE. 0) THEN TEMP(1:20) = 'INFORMATIVE MESSAGE,' LTEMP = 20 ELSEIF (LEVEL .EQ. 1) THEN TEMP(1:30) = 'POTENTIALLY RECOVERABLE ERROR,' LTEMP = 30 ELSE TEMP(1:12) = 'FATAL ERROR,' LTEMP = 12 ENDIF C C THEN WHETHER THE PROGRAM WILL CONTINUE. C IF ((MKNTRL.EQ.2 .AND. LEVEL.GE.1) .OR. * (MKNTRL.EQ.1 .AND. LEVEL.EQ.2)) THEN TEMP(LTEMP+1:LTEMP+17) = ' PROGRAM ABORTED.' LTEMP = LTEMP + 17 ELSE TEMP(LTEMP+1:LTEMP+19) = ' PROGRAM CONTINUES.' LTEMP = LTEMP + 19 ENDIF C CALL XERPRN (' ***', -1, TEMP(1:LTEMP), 72) ENDIF C C NOW SEND OUT THE MESSAGE. C CALL XERPRN (' * ', -1, MESSG, 72) C C IF LKNTRL IS POSITIVE, WRITE THE ERROR NUMBER. C IF (LKNTRL .GT. 0) THEN WRITE (TEMP, '(''ERROR NUMBER = '', I8)') NERR DO 10 I=16,22 IF (TEMP(I:I) .NE. ' ') GO TO 20 10 CONTINUE C 20 CALL XERPRN (' * ', -1, TEMP(1:15) // TEMP(I:23), 72) ENDIF C C IF LKNTRL IS NOT ZERO, PRINT A BLANK LINE AND AN END OF MESSAGE. C IF (LKNTRL .NE. 0) THEN CALL XERPRN (' * ', -1, ' ', 72) CALL XERPRN (' ***', -1, 'END OF MESSAGE', 72) CALL XERPRN (' ', 0, ' ', 72) ENDIF C C IF THE ERROR IS NOT FATAL OR THE ERROR IS RECOVERABLE AND THE C CONTROL FLAG IS SET FOR RECOVERY, THEN RETURN. C IF (LEVEL.LE.0 .OR. (LEVEL.EQ.1 .AND. MKNTRL.LE.1)) RETURN C C THE PROGRAM WILL BE STOPPED DUE TO AN UNRECOVERED ERROR OR A C FATAL ERROR. PRINT THE REASON FOR THE ABORT AND THE ERROR C SUMMARY IF THE CONTROL FLAG AND THE MAXIMUM ERROR COUNT PERMIT. C IF (LKNTRL.GT.0) THEN IF (LEVEL .EQ. 1) THEN CALL XERPRN * (' ***', -1, 'JOB ABORT DUE TO UNRECOVERED ERROR.', 72) ELSE CALL XERPRN(' ***', -1, 'JOB ABORT DUE TO FATAL ERROR.', 72) ENDIF CALL XERHLT (' ') ENDIF RETURN END C*DECK XERPRN SUBROUTINE XERPRN (PREFIX, NPREF, MESSG, NWRAP) c----------------------------------------------------------------------- c Explicit declarations made for variables declared by the implicit c Fortran 77 conventions. c----------------------------------------------------------------------- C***BEGIN PROLOGUE XERPRN C***SUBSIDIARY C***PURPOSE This routine is called by XERMSG to print error messages C***LIBRARY SLATEC C***CATEGORY R3C C***TYPE ALL C***KEYWORDS ERROR MESSAGES, PRINTING, XERROR C***AUTHOR FONG, KIRBY, (NMFECC AT LLNL) C***DESCRIPTION C C This routine sends one or more lines to each of the (up to five) C logical units to which error messages are to be sent. This routine C is called several times by XERMSG, sometimes with a single line to C print and sometimes with a (potentially very long) message that may C wrap around into multiple lines. C C PREFIX Input argument of type CHARACTER. This argument contains C characters to be put at the beginning of each line before C the body of the message. No more than 16 characters of C PREFIX will be used. C C NPREF Input argument of type INTEGER. This argument is the number C of characters to use from PREFIX. If it is negative, the C intrinsic function LEN is used to determine its length. If C it is zero, PREFIX is not used. If it exceeds 16 or if C LEN(PREFIX) exceeds 16, only the first 16 characters will be C used. If NPREF is positive and the length of PREFIX is less C than NPREF, a copy of PREFIX extended with blanks to length C NPREF will be used. C C MESSG Input argument of type CHARACTER. This is the text of a C message to be printed. If it is a long message, it will be C broken into pieces for printing on multiple lines. Each line C will start with the appropriate prefix and be followed by a C piece of the message. NWRAP is the number of characters per C piece; that is, after each NWRAP characters, we break and C start a new line. In addition the characters '$$' embedded C in MESSG are a sentinel for a new line. The counting of C characters up to NWRAP starts over for each new line. The C value of NWRAP typically used by XERMSG is 72 since many C older error messages in the SLATEC Library are laid out to C rely on wrap-around every 72 characters. C C NWRAP Input argument of type INTEGER. This gives the maximum size C piece into which to break MESSG for printing on multiple C lines. An embedded '$$' ends a line, and the count restarts C at the following character. If a line break does not occur C on a blank (it would split a word) that word is moved to the C next line. Values of NWRAP less than 16 will be treated as C 16. Values of NWRAP greater than 132 will be treated as 132. C The actual line length will be NPREF + NWRAP after NPREF has C been adjusted to fall between 0 and 16 and NWRAP has been C adjusted to fall between 16 and 132. C C***REFERENCES (NONE) C***ROUTINES CALLED I1MACH, XGETUA C***REVISION HISTORY (YYMMDD) C 880621 DATE WRITTEN C 880708 REVISED AFTER THE SLATEC CML SUBCOMMITTEE MEETING OF C JUNE 29 AND 30 TO CHANGE THE NAME TO XERPRN AND TO REWORK C THE HANDLING OF THE NEW LINE SENTINEL TO BEHAVE LIKE THE C SLASH CHARACTER IN FORMAT STATEMENTS. C 890706 REVISED WITH THE HELP OF FRED FRITSCH AND REG CLEMMENS TO C STREAMLINE THE CODING AND FIX A BUG THAT CAUSED EXTRA BLANK C LINES TO BE PRINTED. C 890721 REVISED TO ADD A NEW FEATURE. A NEGATIVE VALUE OF NPREF C CAUSES LEN(PREFIX) TO BE USED AS THE LENGTH. C 891013 REVISED TO CORRECT ERROR IN CALCULATING PREFIX LENGTH. C 891214 Prologue converted to Version 4.0 format. (WRB) C 900510 Added code to break messages between words. (RWC) C***END PROLOGUE XERPRN CHARACTER*(*) PREFIX, MESSG INTEGER NPREF, NWRAP CHARACTER*148 CBUFF INTEGER IU(5), NUNIT CHARACTER*2 NEWLIN PARAMETER (NEWLIN = '$$') c----------------------------------------------------------------------- integer i, idelta, lenmsg, lpiece, lpref, lwrap, n, nextc integer i1mach c----------------------------------------------------------------------- C***FIRST EXECUTABLE STATEMENT XERPRN CALL XGETUA(IU,NUNIT) C C A ZERO VALUE FOR A LOGICAL UNIT NUMBER MEANS TO USE THE STANDARD C ERROR MESSAGE UNIT INSTEAD. I1MACH(4) RETRIEVES THE STANDARD C ERROR MESSAGE UNIT. C N = I1MACH(4) DO 10 I=1,NUNIT IF (IU(I) .EQ. 0) IU(I) = N 10 CONTINUE C C LPREF IS THE LENGTH OF THE PREFIX. THE PREFIX IS PLACED AT THE C BEGINNING OF CBUFF, THE CHARACTER BUFFER, AND KEPT THERE DURING C THE REST OF THIS ROUTINE. C IF ( NPREF .LT. 0 ) THEN LPREF = LEN(PREFIX) ELSE LPREF = NPREF ENDIF LPREF = MIN(16, LPREF) IF (LPREF .NE. 0) CBUFF(1:LPREF) = PREFIX C C LWRAP IS THE MAXIMUM NUMBER OF CHARACTERS WE WANT TO TAKE AT ONE C TIME FROM MESSG TO PRINT ON ONE LINE. C LWRAP = MAX(16, MIN(132, NWRAP)) C C SET LENMSG TO THE LENGTH OF MESSG, IGNORE ANY TRAILING BLANKS. C LENMSG = LEN(MESSG) N = LENMSG DO 20 I=1,N IF (MESSG(LENMSG:LENMSG) .NE. ' ') GO TO 30 LENMSG = LENMSG - 1 20 CONTINUE 30 CONTINUE C C IF THE MESSAGE IS ALL BLANKS, THEN PRINT ONE BLANK LINE. C IF (LENMSG .EQ. 0) THEN CBUFF(LPREF+1:LPREF+1) = ' ' DO 40 I=1,NUNIT WRITE(IU(I), '(A)') CBUFF(1:LPREF+1) 40 CONTINUE RETURN ENDIF C C SET NEXTC TO THE POSITION IN MESSG WHERE THE NEXT SUBSTRING C STARTS. FROM THIS POSITION WE SCAN FOR THE NEW LINE SENTINEL. C WHEN NEXTC EXCEEDS LENMSG, THERE IS NO MORE TO PRINT. C WE LOOP BACK TO LABEL 50 UNTIL ALL PIECES HAVE BEEN PRINTED. C C WE LOOK FOR THE NEXT OCCURRENCE OF THE NEW LINE SENTINEL. THE C INDEX INTRINSIC FUNCTION RETURNS ZERO IF THERE IS NO OCCURRENCE C OR IF THE LENGTH OF THE FIRST ARGUMENT IS LESS THAN THE LENGTH C OF THE SECOND ARGUMENT. C C THERE ARE SEVERAL CASES WHICH SHOULD BE CHECKED FOR IN THE C FOLLOWING ORDER. WE ARE ATTEMPTING TO SET LPIECE TO THE NUMBER C OF CHARACTERS THAT SHOULD BE TAKEN FROM MESSG STARTING AT C POSITION NEXTC. C C LPIECE .EQ. 0 THE NEW LINE SENTINEL DOES NOT OCCUR IN THE C REMAINDER OF THE CHARACTER STRING. LPIECE C SHOULD BE SET TO LWRAP OR LENMSG+1-NEXTC, C WHICHEVER IS LESS. C C LPIECE .EQ. 1 THE NEW LINE SENTINEL STARTS AT MESSG(NEXTC: C NEXTC). LPIECE IS EFFECTIVELY ZERO, AND WE C PRINT NOTHING TO AVOID PRODUCING UNNECESSARY C BLANK LINES. THIS TAKES CARE OF THE SITUATION C WHERE THE LIBRARY ROUTINE HAS A MESSAGE OF C EXACTLY 72 CHARACTERS FOLLOWED BY A NEW LINE C SENTINEL FOLLOWED BY MORE CHARACTERS. NEXTC C SHOULD BE INCREMENTED BY 2. C C LPIECE .GT. LWRAP+1 REDUCE LPIECE TO LWRAP. C C ELSE THIS LAST CASE MEANS 2 .LE. LPIECE .LE. LWRAP+1 C RESET LPIECE = LPIECE-1. NOTE THAT THIS C PROPERLY HANDLES THE END CASE WHERE LPIECE .EQ. C LWRAP+1. THAT IS, THE SENTINEL FALLS EXACTLY C AT THE END OF A LINE. C NEXTC = 1 50 LPIECE = INDEX(MESSG(NEXTC:LENMSG), NEWLIN) IF (LPIECE .EQ. 0) THEN C C THERE WAS NO NEW LINE SENTINEL FOUND. C IDELTA = 0 LPIECE = MIN(LWRAP, LENMSG+1-NEXTC) IF (LPIECE .LT. LENMSG+1-NEXTC) THEN DO 52 I=LPIECE+1,2,-1 IF (MESSG(NEXTC+I-1:NEXTC+I-1) .EQ. ' ') THEN LPIECE = I-1 IDELTA = 1 GOTO 54 ENDIF 52 CONTINUE ENDIF 54 CBUFF(LPREF+1:LPREF+LPIECE) = MESSG(NEXTC:NEXTC+LPIECE-1) NEXTC = NEXTC + LPIECE + IDELTA ELSEIF (LPIECE .EQ. 1) THEN C C WE HAVE A NEW LINE SENTINEL AT MESSG(NEXTC:NEXTC+1). C DON'T PRINT A BLANK LINE. C NEXTC = NEXTC + 2 GO TO 50 ELSEIF (LPIECE .GT. LWRAP+1) THEN C C LPIECE SHOULD BE SET DOWN TO LWRAP. C IDELTA = 0 LPIECE = LWRAP DO 56 I=LPIECE+1,2,-1 IF (MESSG(NEXTC+I-1:NEXTC+I-1) .EQ. ' ') THEN LPIECE = I-1 IDELTA = 1 GOTO 58 ENDIF 56 CONTINUE 58 CBUFF(LPREF+1:LPREF+LPIECE) = MESSG(NEXTC:NEXTC+LPIECE-1) NEXTC = NEXTC + LPIECE + IDELTA ELSE C C IF WE ARRIVE HERE, IT MEANS 2 .LE. LPIECE .LE. LWRAP+1. C WE SHOULD DECREMENT LPIECE BY ONE. C LPIECE = LPIECE - 1 CBUFF(LPREF+1:LPREF+LPIECE) = MESSG(NEXTC:NEXTC+LPIECE-1) NEXTC = NEXTC + LPIECE + 2 ENDIF C C PRINT C DO 60 I=1,NUNIT WRITE(IU(I), '(A)') CBUFF(1:LPREF+LPIECE) 60 CONTINUE C IF (NEXTC .LE. LENMSG) GO TO 50 RETURN END C*DECK XGETUA SUBROUTINE XGETUA (IUNITA, N) c----------------------------------------------------------------------- c Explicit declarations made for variables declared by the implicit c Fortran 77 conventions. c----------------------------------------------------------------------- C***BEGIN PROLOGUE XGETUA C***PURPOSE Return unit number(s) to which error messages are being C sent. C***LIBRARY SLATEC (XERROR) C***CATEGORY R3C C***TYPE ALL (XGETUA-A) C***KEYWORDS ERROR, XERROR C***AUTHOR JONES, R. E., (SNLA) C Modified by C FRITSCH, F. N., (LLNL) C***DESCRIPTION C C Abstract C XGETUA may be called to determine the unit number or numbers C to which error messages are being sent. C These unit numbers may have been set by a call to XSETUN, C or a call to XSETUA, or may be a default value. C C Description of Parameters C --Output-- C IUNIT - an array of one to five unit numbers, depending C on the value of N. A value of zero refers to the C default unit, as defined by the I1MACH machine C constant routine. Only IUNIT(1),...,IUNIT(N) are C defined by XGETUA. The values of IUNIT(N+1),..., C IUNIT(5) are not defined (for N .LT. 5) or altered C in any way by XGETUA. C N - the number of units to which copies of the C error messages are being sent. N will be in the C range from 1 to 5. C C CAUTION: The use of COMMON in this version is not safe for C multiprocessing. C C***REFERENCES JONES R.E., KAHANER D.K., 'XERROR, THE SLATEC ERROR- C HANDLING PACKAGE', SAND82-0800, SANDIA LABORATORIES, C 1982. C***ROUTINES CALLED (NONE) C***COMMON BLOCKS XERUNI C***REVISION HISTORY (YYMMDD) C 790801 DATE WRITTEN C 861211 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 901011 Rewritten to not use J4SAVE. (FNF) C 901012 Corrected initialization problem. (FNF) C***END PROLOGUE XGETUA DIMENSION IUNITA(5) INTEGER NUNIT, IUNIT(5) COMMON /XERUNI/ NUNIT, IUNIT c----------------------------------------------------------------------- integer i, iunita, n c----------------------------------------------------------------------- C***FIRST EXECUTABLE STATEMENT XGETUA C Initialize so XERMSG will use standard error unit number if C block has not been set up by a CALL XSETUA. C CAUTION: This assumes uninitialized COMMON tests .LE.0 . IF (NUNIT.LE.0) THEN NUNIT = 1 IUNIT(1) = 0 ENDIF N = NUNIT DO 30 I=1,N IUNITA(I) = IUNIT(I) 30 CONTINUE RETURN END C*DECK XSETUA SUBROUTINE XSETUA (IUNITA, N) c----------------------------------------------------------------------- c Explicit declarations made for variables declared by the implicit c Fortran 77 conventions. c----------------------------------------------------------------------- C***BEGIN PROLOGUE XSETUA C***PURPOSE Set logical unit numbers (up to 5) to which error C messages are to be sent. C***LIBRARY SLATEC (XERROR) C***CATEGORY R3B C***TYPE ALL (XSETUA-A) C***KEYWORDS ERROR, XERROR C***AUTHOR JONES, R. E., (SNLA) C Modified by C FRITSCH, F. N., (LLNL) C***DESCRIPTION C C Abstract C XSETUA may be called to declare a list of up to five C logical units, each of which is to receive a copy of C each error message processed by this package. C The purpose of XSETUA is to allow simultaneous printing C of each error message on, say, a main output file, C an interactive terminal, and other files such as graphics C communication files. C C Description of Parameters C --Input-- C IUNIT - an array of up to five unit numbers. C Normally these numbers should all be different C (but duplicates are not prohibited.) C N - the number of unit numbers provided in IUNIT C must have 1 .LE. N .LE. 5. C C CAUTION: The use of COMMON in this version is not safe for C multiprocessing. C C***REFERENCES JONES R.E., KAHANER D.K., 'XERROR, THE SLATEC ERROR- C HANDLING PACKAGE', SAND82-0800, SANDIA LABORATORIES, C 1982. C***ROUTINES CALLED XERMSG C***COMMON BLOCKS XERUNI C***REVISION HISTORY (YYMMDD) C 790801 DATE WRITTEN C 861211 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900510 Change call to XERRWV to XERMSG. (RWC) C 901011 Rewritten to not use J4SAVE. (FNF) C***END PROLOGUE XSETUA DIMENSION IUNITA(5) INTEGER NUNIT, IUNIT(5) COMMON /XERUNI/ NUNIT, IUNIT CHARACTER *8 XERN1 c----------------------------------------------------------------------- integer i, iunita, n c----------------------------------------------------------------------- C***FIRST EXECUTABLE STATEMENT XSETUA C IF (N.LT.1 .OR. N.GT.5) THEN WRITE (XERN1, '(I8)') N CALL XERMSG ('SLATEC', 'XSETUA', * 'INVALID NUMBER OF UNITS, N = ' // XERN1, 1, 2) RETURN ENDIF C DO 10 I=1,N IUNIT(I) = IUNITA(I) 10 CONTINUE NUNIT = N RETURN END