1 *DECK DLSODE 2 SUBROUTINE DLSODE (F, NEQ, Y, T, TOUT, ITOL, RTOL, ATOL, ITASK, 3 1 ISTATE, IOPT, RWORK, LRW, IWORK, LIW, JAC, MF) 4 EXTERNAL F, JAC 5 INTEGER NEQ, ITOL, ITASK, ISTATE, IOPT, LRW, IWORK, LIW, MF 6 DOUBLE PRECISION Y, T, TOUT, RTOL, ATOL, RWORK 7 DIMENSION NEQ(*), Y(*), RTOL(*), ATOL(*), RWORK(LRW), IWORK(LIW) 8 C***BEGIN PROLOGUE DLSODE 9 C***PURPOSE Livermore Solver for Ordinary Differential Equations. 10 C DLSODE solves the initial-value problem for stiff or 11 C nonstiff systems of first-order ODE's, 12 C dy/dt = f(t,y), or, in component form, 13 C dy(i)/dt = f(i) = f(i,t,y(1),y(2),...,y(N)), i=1,...,N. 14 C***CATEGORY I1A 15 C***TYPE DOUBLE PRECISION (SLSODE-S, DLSODE-D) 16 C***KEYWORDS ORDINARY DIFFERENTIAL EQUATIONS, INITIAL VALUE PROBLEM, 17 C STIFF, NONSTIFF 18 C***AUTHOR Hindmarsh, Alan C., (LLNL) 19 C Center for Applied Scientific Computing, L-561 20 C Lawrence Livermore National Laboratory 21 C Livermore, CA 94551. 22 C***DESCRIPTION 23 C 24 C NOTE: The "Usage" and "Arguments" sections treat only a subset of 25 C available options, in condensed fashion. The options 26 C covered and the information supplied will support most 27 C standard uses of DLSODE. 28 C 29 C For more sophisticated uses, full details on all options are 30 C given in the concluding section, headed "Long Description." 31 C A synopsis of the DLSODE Long Description is provided at the 32 C beginning of that section; general topics covered are: 33 C - Elements of the call sequence; optional input and output 34 C - Optional supplemental routines in the DLSODE package 35 C - internal COMMON block 36 C 37 C *Usage: 38 C Communication between the user and the DLSODE package, for normal 39 C situations, is summarized here. This summary describes a subset 40 C of the available options. See "Long Description" for complete 41 C details, including optional communication, nonstandard options, 42 C and instructions for special situations. 43 C 44 C A sample program is given in the "Examples" section. 45 C 46 C Refer to the argument descriptions for the definitions of the 47 C quantities that appear in the following sample declarations. 48 C 49 C For MF = 10, 50 C PARAMETER (LRW = 20 + 16*NEQ, LIW = 20) 51 C For MF = 21 or 22, 52 C PARAMETER (LRW = 22 + 9*NEQ + NEQ**2, LIW = 20 + NEQ) 53 C For MF = 24 or 25, 54 C PARAMETER (LRW = 22 + 10*NEQ + (2*ML+MU)*NEQ, 55 C * LIW = 20 + NEQ) 56 C 57 C EXTERNAL F, JAC 58 C INTEGER NEQ, ITOL, ITASK, ISTATE, IOPT, LRW, IWORK(LIW), 59 C * LIW, MF 60 C DOUBLE PRECISION Y(NEQ), T, TOUT, RTOL, ATOL(ntol), RWORK(LRW) 61 C 62 C CALL DLSODE (F, NEQ, Y, T, TOUT, ITOL, RTOL, ATOL, ITASK, 63 C * ISTATE, IOPT, RWORK, LRW, IWORK, LIW, JAC, MF) 64 C 65 C *Arguments: 66 C F :EXT Name of subroutine for right-hand-side vector f. 67 C This name must be declared EXTERNAL in calling 68 C program. The form of F must be: 69 C 70 C SUBROUTINE F (NEQ, T, Y, YDOT) 71 C INTEGER NEQ 72 C DOUBLE PRECISION T, Y(*), YDOT(*) 73 C 74 C The inputs are NEQ, T, Y. F is to set 75 C 76 C YDOT(i) = f(i,T,Y(1),Y(2),...,Y(NEQ)), 77 C i = 1, ..., NEQ . 78 C 79 C NEQ :IN Number of first-order ODE's. 80 C 81 C Y :INOUT Array of values of the y(t) vector, of length NEQ. 82 C Input: For the first call, Y should contain the 83 C values of y(t) at t = T. (Y is an input 84 C variable only if ISTATE = 1.) 85 C Output: On return, Y will contain the values at the 86 C new t-value. 87 C 88 C T :INOUT Value of the independent variable. On return it 89 C will be the current value of t (normally TOUT). 90 C 91 C TOUT :IN Next point where output is desired (.NE. T). 92 C 93 C ITOL :IN 1 or 2 according as ATOL (below) is a scalar or 94 C an array. 95 C 96 C RTOL :IN Relative tolerance parameter (scalar). 97 C 98 C ATOL :IN Absolute tolerance parameter (scalar or array). 99 C If ITOL = 1, ATOL need not be dimensioned. 100 C If ITOL = 2, ATOL must be dimensioned at least NEQ. 101 C 102 C The estimated local error in Y(i) will be controlled 103 C so as to be roughly less (in magnitude) than 104 C 105 C EWT(i) = RTOL*ABS(Y(i)) + ATOL if ITOL = 1, or 106 C EWT(i) = RTOL*ABS(Y(i)) + ATOL(i) if ITOL = 2. 107 C 108 C Thus the local error test passes if, in each 109 C component, either the absolute error is less than 110 C ATOL (or ATOL(i)), or the relative error is less 111 C than RTOL. 112 C 113 C Use RTOL = 0.0 for pure absolute error control, and 114 C use ATOL = 0.0 (or ATOL(i) = 0.0) for pure relative 115 C error control. Caution: Actual (global) errors may 116 C exceed these local tolerances, so choose them 117 C conservatively. 118 C 119 C ITASK :IN Flag indicating the task DLSODE is to perform. 120 C Use ITASK = 1 for normal computation of output 121 C values of y at t = TOUT. 122 C 123 C ISTATE:INOUT Index used for input and output to specify the state 124 C of the calculation. 125 C Input: 126 C 1 This is the first call for a problem. 127 C 2 This is a subsequent call. 128 C Output: 129 C 1 Nothing was done, because TOUT was equal to T. 130 C 2 DLSODE was successful (otherwise, negative). 131 C Note that ISTATE need not be modified after a 132 C successful return. 133 C -1 Excess work done on this call (perhaps wrong 134 C MF). 135 C -2 Excess accuracy requested (tolerances too 136 C small). 137 C -3 Illegal input detected (see printed message). 138 C -4 Repeated error test failures (check all 139 C inputs). 140 C -5 Repeated convergence failures (perhaps bad 141 C Jacobian supplied or wrong choice of MF or 142 C tolerances). 143 C -6 Error weight became zero during problem 144 C (solution component i vanished, and ATOL or 145 C ATOL(i) = 0.). 146 C 147 C IOPT :IN Flag indicating whether optional inputs are used: 148 C 0 No. 149 C 1 Yes. (See "Optional inputs" under "Long 150 C Description," Part 1.) 151 C 152 C RWORK :WORK Real work array of length at least: 153 C 20 + 16*NEQ for MF = 10, 154 C 22 + 9*NEQ + NEQ**2 for MF = 21 or 22, 155 C 22 + 10*NEQ + (2*ML + MU)*NEQ for MF = 24 or 25. 156 C 157 C LRW :IN Declared length of RWORK (in user's DIMENSION 158 C statement). 159 C 160 C IWORK :WORK Integer work array of length at least: 161 C 20 for MF = 10, 162 C 20 + NEQ for MF = 21, 22, 24, or 25. 163 C 164 C If MF = 24 or 25, input in IWORK(1),IWORK(2) the 165 C lower and upper Jacobian half-bandwidths ML,MU. 166 C 167 C On return, IWORK contains information that may be 168 C of interest to the user: 169 C 170 C Name Location Meaning 171 C ----- --------- ----------------------------------------- 172 C NST IWORK(11) Number of steps taken for the problem so 173 C far. 174 C NFE IWORK(12) Number of f evaluations for the problem 175 C so far. 176 C NJE IWORK(13) Number of Jacobian evaluations (and of 177 C matrix LU decompositions) for the problem 178 C so far. 179 C NQU IWORK(14) Method order last used (successfully). 180 C LENRW IWORK(17) Length of RWORK actually required. This 181 C is defined on normal returns and on an 182 C illegal input return for insufficient 183 C storage. 184 C LENIW IWORK(18) Length of IWORK actually required. This 185 C is defined on normal returns and on an 186 C illegal input return for insufficient 187 C storage. 188 C 189 C LIW :IN Declared length of IWORK (in user's DIMENSION 190 C statement). 191 C 192 C JAC :EXT Name of subroutine for Jacobian matrix (MF = 193 C 21 or 24). If used, this name must be declared 194 C EXTERNAL in calling program. If not used, pass a 195 C dummy name. The form of JAC must be: 196 C 197 C SUBROUTINE JAC (NEQ, T, Y, ML, MU, PD, NROWPD) 198 C INTEGER NEQ, ML, MU, NROWPD 199 C DOUBLE PRECISION T, Y(*), PD(NROWPD,*) 200 C 201 C See item c, under "Description" below for more 202 C information about JAC. 203 C 204 C MF :IN Method flag. Standard values are: 205 C 10 Nonstiff (Adams) method, no Jacobian used. 206 C 21 Stiff (BDF) method, user-supplied full Jacobian. 207 C 22 Stiff method, internally generated full 208 C Jacobian. 209 C 24 Stiff method, user-supplied banded Jacobian. 210 C 25 Stiff method, internally generated banded 211 C Jacobian. 212 C 213 C *Description: 214 C DLSODE solves the initial value problem for stiff or nonstiff 215 C systems of first-order ODE's, 216 C 217 C dy/dt = f(t,y) , 218 C 219 C or, in component form, 220 C 221 C dy(i)/dt = f(i) = f(i,t,y(1),y(2),...,y(NEQ)) 222 C (i = 1, ..., NEQ) . 223 C 224 C DLSODE is a package based on the GEAR and GEARB packages, and on 225 C the October 23, 1978, version of the tentative ODEPACK user 226 C interface standard, with minor modifications. 227 C 228 C The steps in solving such a problem are as follows. 229 C 230 C a. First write a subroutine of the form 231 C 232 C SUBROUTINE F (NEQ, T, Y, YDOT) 233 C INTEGER NEQ 234 C DOUBLE PRECISION T, Y(*), YDOT(*) 235 C 236 C which supplies the vector function f by loading YDOT(i) with 237 C f(i). 238 C 239 C b. Next determine (or guess) whether or not the problem is stiff. 240 C Stiffness occurs when the Jacobian matrix df/dy has an 241 C eigenvalue whose real part is negative and large in magnitude 242 C compared to the reciprocal of the t span of interest. If the 243 C problem is nonstiff, use method flag MF = 10. If it is stiff, 244 C there are four standard choices for MF, and DLSODE requires the 245 C Jacobian matrix in some form. This matrix is regarded either 246 C as full (MF = 21 or 22), or banded (MF = 24 or 25). In the 247 C banded case, DLSODE requires two half-bandwidth parameters ML 248 C and MU. These are, respectively, the widths of the lower and 249 C upper parts of the band, excluding the main diagonal. Thus the 250 C band consists of the locations (i,j) with 251 C 252 C i - ML <= j <= i + MU , 253 C 254 C and the full bandwidth is ML + MU + 1 . 255 C 256 C c. If the problem is stiff, you are encouraged to supply the 257 C Jacobian directly (MF = 21 or 24), but if this is not feasible, 258 C DLSODE will compute it internally by difference quotients (MF = 259 C 22 or 25). If you are supplying the Jacobian, write a 260 C subroutine of the form 261 C 262 C SUBROUTINE JAC (NEQ, T, Y, ML, MU, PD, NROWPD) 263 C INTEGER NEQ, ML, MU, NRWOPD 264 C DOUBLE PRECISION T, Y(*), PD(NROWPD,*) 265 C 266 C which provides df/dy by loading PD as follows: 267 C - For a full Jacobian (MF = 21), load PD(i,j) with df(i)/dy(j), 268 C the partial derivative of f(i) with respect to y(j). (Ignore 269 C the ML and MU arguments in this case.) 270 C - For a banded Jacobian (MF = 24), load PD(i-j+MU+1,j) with 271 C df(i)/dy(j); i.e., load the diagonal lines of df/dy into the 272 C rows of PD from the top down. 273 C - In either case, only nonzero elements need be loaded. 274 C 275 C d. Write a main program that calls subroutine DLSODE once for each 276 C point at which answers are desired. This should also provide 277 C for possible use of logical unit 6 for output of error messages 278 C by DLSODE. 279 C 280 C Before the first call to DLSODE, set ISTATE = 1, set Y and T to 281 C the initial values, and set TOUT to the first output point. To 282 C continue the integration after a successful return, simply 283 C reset TOUT and call DLSODE again. No other parameters need be 284 C reset. 285 C 286 C *Examples: 287 C The following is a simple example problem, with the coding needed 288 C for its solution by DLSODE. The problem is from chemical kinetics, 289 C and consists of the following three rate equations: 290 C 291 C dy1/dt = -.04*y1 + 1.E4*y2*y3 292 C dy2/dt = .04*y1 - 1.E4*y2*y3 - 3.E7*y2**2 293 C dy3/dt = 3.E7*y2**2 294 C 295 C on the interval from t = 0.0 to t = 4.E10, with initial conditions 296 C y1 = 1.0, y2 = y3 = 0. The problem is stiff. 297 C 298 C The following coding solves this problem with DLSODE, using 299 C MF = 21 and printing results at t = .4, 4., ..., 4.E10. It uses 300 C ITOL = 2 and ATOL much smaller for y2 than for y1 or y3 because y2 301 C has much smaller values. At the end of the run, statistical 302 C quantities of interest are printed. 303 C 304 C EXTERNAL FEX, JEX 305 C INTEGER IOPT, IOUT, ISTATE, ITASK, ITOL, IWORK(23), LIW, LRW, 306 C * MF, NEQ 307 C DOUBLE PRECISION ATOL(3), RTOL, RWORK(58), T, TOUT, Y(3) 308 C NEQ = 3 309 C Y(1) = 1.D0 310 C Y(2) = 0.D0 311 C Y(3) = 0.D0 312 C T = 0.D0 313 C TOUT = .4D0 314 C ITOL = 2 315 C RTOL = 1.D-4 316 C ATOL(1) = 1.D-6 317 C ATOL(2) = 1.D-10 318 C ATOL(3) = 1.D-6 319 C ITASK = 1 320 C ISTATE = 1 321 C IOPT = 0 322 C LRW = 58 323 C LIW = 23 324 C MF = 21 325 C DO 40 IOUT = 1,12 326 C CALL DLSODE (FEX, NEQ, Y, T, TOUT, ITOL, RTOL, ATOL, ITASK, 327 C * ISTATE, IOPT, RWORK, LRW, IWORK, LIW, JEX, MF) 328 C WRITE(6,20) T, Y(1), Y(2), Y(3) 329 C 20 FORMAT(' At t =',D12.4,' y =',3D14.6) 330 C IF (ISTATE .LT. 0) GO TO 80 331 C 40 TOUT = TOUT*10.D0 332 C WRITE(6,60) IWORK(11), IWORK(12), IWORK(13) 333 C 60 FORMAT(/' No. steps =',i4,', No. f-s =',i4,', No. J-s =',i4) 334 C STOP 335 C 80 WRITE(6,90) ISTATE 336 C 90 FORMAT(///' Error halt.. ISTATE =',I3) 337 C STOP 338 C END 339 C 340 C SUBROUTINE FEX (NEQ, T, Y, YDOT) 341 C INTEGER NEQ 342 C DOUBLE PRECISION T, Y(3), YDOT(3) 343 C YDOT(1) = -.04D0*Y(1) + 1.D4*Y(2)*Y(3) 344 C YDOT(3) = 3.D7*Y(2)*Y(2) 345 C YDOT(2) = -YDOT(1) - YDOT(3) 346 C RETURN 347 C END 348 C 349 C SUBROUTINE JEX (NEQ, T, Y, ML, MU, PD, NRPD) 350 C INTEGER NEQ, ML, MU, NRPD 351 C DOUBLE PRECISION T, Y(3), PD(NRPD,3) 352 C PD(1,1) = -.04D0 353 C PD(1,2) = 1.D4*Y(3) 354 C PD(1,3) = 1.D4*Y(2) 355 C PD(2,1) = .04D0 356 C PD(2,3) = -PD(1,3) 357 C PD(3,2) = 6.D7*Y(2) 358 C PD(2,2) = -PD(1,2) - PD(3,2) 359 C RETURN 360 C END 361 C 362 C The output from this program (on a Cray-1 in single precision) 363 C is as follows. 364 C 365 C At t = 4.0000e-01 y = 9.851726e-01 3.386406e-05 1.479357e-02 366 C At t = 4.0000e+00 y = 9.055142e-01 2.240418e-05 9.446344e-02 367 C At t = 4.0000e+01 y = 7.158050e-01 9.184616e-06 2.841858e-01 368 C At t = 4.0000e+02 y = 4.504846e-01 3.222434e-06 5.495122e-01 369 C At t = 4.0000e+03 y = 1.831701e-01 8.940379e-07 8.168290e-01 370 C At t = 4.0000e+04 y = 3.897016e-02 1.621193e-07 9.610297e-01 371 C At t = 4.0000e+05 y = 4.935213e-03 1.983756e-08 9.950648e-01 372 C At t = 4.0000e+06 y = 5.159269e-04 2.064759e-09 9.994841e-01 373 C At t = 4.0000e+07 y = 5.306413e-05 2.122677e-10 9.999469e-01 374 C At t = 4.0000e+08 y = 5.494530e-06 2.197825e-11 9.999945e-01 375 C At t = 4.0000e+09 y = 5.129458e-07 2.051784e-12 9.999995e-01 376 C At t = 4.0000e+10 y = -7.170603e-08 -2.868241e-13 1.000000e+00 377 C 378 C No. steps = 330, No. f-s = 405, No. J-s = 69 379 C 380 C *Accuracy: 381 C The accuracy of the solution depends on the choice of tolerances 382 C RTOL and ATOL. Actual (global) errors may exceed these local 383 C tolerances, so choose them conservatively. 384 C 385 C *Cautions: 386 C The work arrays should not be altered between calls to DLSODE for 387 C the same problem, except possibly for the conditional and optional 388 C inputs. 389 C 390 C *Portability: 391 C Since NEQ is dimensioned inside DLSODE, some compilers may object 392 C to a call to DLSODE with NEQ a scalar variable. In this event, 393 C use DIMENSION NEQ(1). Similar remarks apply to RTOL and ATOL. 394 C 395 C Note to Cray users: 396 C For maximum efficiency, use the CFT77 compiler. Appropriate 397 C compiler optimization directives have been inserted for CFT77. 398 C 399 C *Reference: 400 C Alan C. Hindmarsh, "ODEPACK, A Systematized Collection of ODE 401 C Solvers," in Scientific Computing, R. S. Stepleman, et al., Eds. 402 C (North-Holland, Amsterdam, 1983), pp. 55-64. 403 C 404 C *Long Description: 405 C The following complete description of the user interface to 406 C DLSODE consists of four parts: 407 C 408 C 1. The call sequence to subroutine DLSODE, which is a driver 409 C routine for the solver. This includes descriptions of both 410 C the call sequence arguments and user-supplied routines. 411 C Following these descriptions is a description of optional 412 C inputs available through the call sequence, and then a 413 C description of optional outputs in the work arrays. 414 C 415 C 2. Descriptions of other routines in the DLSODE package that may 416 C be (optionally) called by the user. These provide the ability 417 C to alter error message handling, save and restore the internal 418 C COMMON, and obtain specified derivatives of the solution y(t). 419 C 420 C 3. Descriptions of COMMON block to be declared in overlay or 421 C similar environments, or to be saved when doing an interrupt 422 C of the problem and continued solution later. 423 C 424 C 4. Description of two routines in the DLSODE package, either of 425 C which the user may replace with his own version, if desired. 426 C These relate to the measurement of errors. 427 C 428 C 429 C Part 1. Call Sequence 430 C ---------------------- 431 C 432 C Arguments 433 C --------- 434 C The call sequence parameters used for input only are 435 C 436 C F, NEQ, TOUT, ITOL, RTOL, ATOL, ITASK, IOPT, LRW, LIW, JAC, MF, 437 C 438 C and those used for both input and output are 439 C 440 C Y, T, ISTATE. 441 C 442 C The work arrays RWORK and IWORK are also used for conditional and 443 C optional inputs and optional outputs. (The term output here 444 C refers to the return from subroutine DLSODE to the user's calling 445 C program.) 446 C 447 C The legality of input parameters will be thoroughly checked on the 448 C initial call for the problem, but not checked thereafter unless a 449 C change in input parameters is flagged by ISTATE = 3 on input. 450 C 451 C The descriptions of the call arguments are as follows. 452 C 453 C F The name of the user-supplied subroutine defining the ODE 454 C system. The system must be put in the first-order form 455 C dy/dt = f(t,y), where f is a vector-valued function of 456 C the scalar t and the vector y. Subroutine F is to compute 457 C the function f. It is to have the form 458 C 459 C SUBROUTINE F (NEQ, T, Y, YDOT) 460 C DOUBLE PRECISION T, Y(*), YDOT(*) 461 C 462 C where NEQ, T, and Y are input, and the array YDOT = 463 C f(T,Y) is output. Y and YDOT are arrays of length NEQ. 464 C Subroutine F should not alter Y(1),...,Y(NEQ). F must be 465 C declared EXTERNAL in the calling program. 466 C 467 C Subroutine F may access user-defined quantities in 468 C NEQ(2),... and/or in Y(NEQ(1)+1),..., if NEQ is an array 469 C (dimensioned in F) and/or Y has length exceeding NEQ(1). 470 C See the descriptions of NEQ and Y below. 471 C 472 C If quantities computed in the F routine are needed 473 C externally to DLSODE, an extra call to F should be made 474 C for this purpose, for consistent and accurate results. 475 C If only the derivative dy/dt is needed, use DINTDY 476 C instead. 477 C 478 C NEQ The size of the ODE system (number of first-order 479 C ordinary differential equations). Used only for input. 480 C NEQ may be decreased, but not increased, during the 481 C problem. If NEQ is decreased (with ISTATE = 3 on input), 482 C the remaining components of Y should be left undisturbed, 483 C if these are to be accessed in F and/or JAC. 484 C 485 C Normally, NEQ is a scalar, and it is generally referred 486 C to as a scalar in this user interface description. 487 C However, NEQ may be an array, with NEQ(1) set to the 488 C system size. (The DLSODE package accesses only NEQ(1).) 489 C In either case, this parameter is passed as the NEQ 490 C argument in all calls to F and JAC. Hence, if it is an 491 C array, locations NEQ(2),... may be used to store other 492 C integer data and pass it to F and/or JAC. Subroutines 493 C F and/or JAC must include NEQ in a DIMENSION statement 494 C in that case. 495 C 496 C Y A real array for the vector of dependent variables, of 497 C length NEQ or more. Used for both input and output on 498 C the first call (ISTATE = 1), and only for output on 499 C other calls. On the first call, Y must contain the 500 C vector of initial values. On output, Y contains the 501 C computed solution vector, evaluated at T. If desired, 502 C the Y array may be used for other purposes between 503 C calls to the solver. 504 C 505 C This array is passed as the Y argument in all calls to F 506 C and JAC. Hence its length may exceed NEQ, and locations 507 C Y(NEQ+1),... may be used to store other real data and 508 C pass it to F and/or JAC. (The DLSODE package accesses 509 C only Y(1),...,Y(NEQ).) 510 C 511 C T The independent variable. On input, T is used only on 512 C the first call, as the initial point of the integration. 513 C On output, after each call, T is the value at which a 514 C computed solution Y is evaluated (usually the same as 515 C TOUT). On an error return, T is the farthest point 516 C reached. 517 C 518 C TOUT The next value of T at which a computed solution is 519 C desired. Used only for input. 520 C 521 C When starting the problem (ISTATE = 1), TOUT may be equal 522 C to T for one call, then should not equal T for the next 523 C call. For the initial T, an input value of TOUT .NE. T 524 C is used in order to determine the direction of the 525 C integration (i.e., the algebraic sign of the step sizes) 526 C and the rough scale of the problem. Integration in 527 C either direction (forward or backward in T) is permitted. 528 C 529 C If ITASK = 2 or 5 (one-step modes), TOUT is ignored 530 C after the first call (i.e., the first call with 531 C TOUT .NE. T). Otherwise, TOUT is required on every call. 532 C 533 C If ITASK = 1, 3, or 4, the values of TOUT need not be 534 C monotone, but a value of TOUT which backs up is limited 535 C to the current internal T interval, whose endpoints are 536 C TCUR - HU and TCUR. (See "Optional Outputs" below for 537 C TCUR and HU.) 538 C 539 C 540 C ITOL An indicator for the type of error control. See 541 C description below under ATOL. Used only for input. 542 C 543 C RTOL A relative error tolerance parameter, either a scalar or 544 C an array of length NEQ. See description below under 545 C ATOL. Input only. 546 C 547 C ATOL An absolute error tolerance parameter, either a scalar or 548 C an array of length NEQ. Input only. 549 C 550 C The input parameters ITOL, RTOL, and ATOL determine the 551 C error control performed by the solver. The solver will 552 C control the vector e = (e(i)) of estimated local errors 553 C in Y, according to an inequality of the form 554 C 555 C rms-norm of ( e(i)/EWT(i) ) <= 1, 556 C 557 C where 558 C 559 C EWT(i) = RTOL(i)*ABS(Y(i)) + ATOL(i), 560 C 561 C and the rms-norm (root-mean-square norm) here is 562 C 563 C rms-norm(v) = SQRT(sum v(i)**2 / NEQ). 564 C 565 C Here EWT = (EWT(i)) is a vector of weights which must 566 C always be positive, and the values of RTOL and ATOL 567 C should all be nonnegative. The following table gives the 568 C types (scalar/array) of RTOL and ATOL, and the 569 C corresponding form of EWT(i). 570 C 571 C ITOL RTOL ATOL EWT(i) 572 C ---- ------ ------ ----------------------------- 573 C 1 scalar scalar RTOL*ABS(Y(i)) + ATOL 574 C 2 scalar array RTOL*ABS(Y(i)) + ATOL(i) 575 C 3 array scalar RTOL(i)*ABS(Y(i)) + ATOL 576 C 4 array array RTOL(i)*ABS(Y(i)) + ATOL(i) 577 C 578 C When either of these parameters is a scalar, it need not 579 C be dimensioned in the user's calling program. 580 C 581 C If none of the above choices (with ITOL, RTOL, and ATOL 582 C fixed throughout the problem) is suitable, more general 583 C error controls can be obtained by substituting 584 C user-supplied routines for the setting of EWT and/or for 585 C the norm calculation. See Part 4 below. 586 C 587 C If global errors are to be estimated by making a repeated 588 C run on the same problem with smaller tolerances, then all 589 C components of RTOL and ATOL (i.e., of EWT) should be 590 C scaled down uniformly. 591 C 592 C ITASK An index specifying the task to be performed. Input 593 C only. ITASK has the following values and meanings: 594 C 1 Normal computation of output values of y(t) at 595 C t = TOUT (by overshooting and interpolating). 596 C 2 Take one step only and return. 597 C 3 Stop at the first internal mesh point at or beyond 598 C t = TOUT and return. 599 C 4 Normal computation of output values of y(t) at 600 C t = TOUT but without overshooting t = TCRIT. TCRIT 601 C must be input as RWORK(1). TCRIT may be equal to or 602 C beyond TOUT, but not behind it in the direction of 603 C integration. This option is useful if the problem 604 C has a singularity at or beyond t = TCRIT. 605 C 5 Take one step, without passing TCRIT, and return. 606 C TCRIT must be input as RWORK(1). 607 C 608 C Note: If ITASK = 4 or 5 and the solver reaches TCRIT 609 C (within roundoff), it will return T = TCRIT (exactly) to 610 C indicate this (unless ITASK = 4 and TOUT comes before 611 C TCRIT, in which case answers at T = TOUT are returned 612 C first). 613 C 614 C ISTATE An index used for input and output to specify the state 615 C of the calculation. 616 C 617 C On input, the values of ISTATE are as follows: 618 C 1 This is the first call for the problem 619 C (initializations will be done). See "Note" below. 620 C 2 This is not the first call, and the calculation is to 621 C continue normally, with no change in any input 622 C parameters except possibly TOUT and ITASK. (If ITOL, 623 C RTOL, and/or ATOL are changed between calls with 624 C ISTATE = 2, the new values will be used but not 625 C tested for legality.) 626 C 3 This is not the first call, and the calculation is to 627 C continue normally, but with a change in input 628 C parameters other than TOUT and ITASK. Changes are 629 C allowed in NEQ, ITOL, RTOL, ATOL, IOPT, LRW, LIW, MF, 630 C ML, MU, and any of the optional inputs except H0. 631 C (See IWORK description for ML and MU.) 632 C 633 C Note: A preliminary call with TOUT = T is not counted as 634 C a first call here, as no initialization or checking of 635 C input is done. (Such a call is sometimes useful for the 636 C purpose of outputting the initial conditions.) Thus the 637 C first call for which TOUT .NE. T requires ISTATE = 1 on 638 C input. 639 C 640 C On output, ISTATE has the following values and meanings: 641 C 1 Nothing was done, as TOUT was equal to T with 642 C ISTATE = 1 on input. 643 C 2 The integration was performed successfully. 644 C -1 An excessive amount of work (more than MXSTEP steps) 645 C was done on this call, before completing the 646 C requested task, but the integration was otherwise 647 C successful as far as T. (MXSTEP is an optional input 648 C and is normally 500.) To continue, the user may 649 C simply reset ISTATE to a value >1 and call again (the 650 C excess work step counter will be reset to 0). In 651 C addition, the user may increase MXSTEP to avoid this 652 C error return; see "Optional Inputs" below. 653 C -2 Too much accuracy was requested for the precision of 654 C the machine being used. This was detected before 655 C completing the requested task, but the integration 656 C was successful as far as T. To continue, the 657 C tolerance parameters must be reset, and ISTATE must 658 C be set to 3. The optional output TOLSF may be used 659 C for this purpose. (Note: If this condition is 660 C detected before taking any steps, then an illegal 661 C input return (ISTATE = -3) occurs instead.) 662 C -3 Illegal input was detected, before taking any 663 C integration steps. See written message for details. 664 C (Note: If the solver detects an infinite loop of 665 C calls to the solver with illegal input, it will cause 666 C the run to stop.) 667 C -4 There were repeated error-test failures on one 668 C attempted step, before completing the requested task, 669 C but the integration was successful as far as T. The 670 C problem may have a singularity, or the input may be 671 C inappropriate. 672 C -5 There were repeated convergence-test failures on one 673 C attempted step, before completing the requested task, 674 C but the integration was successful as far as T. This 675 C may be caused by an inaccurate Jacobian matrix, if 676 C one is being used. 677 C -6 EWT(i) became zero for some i during the integration. 678 C Pure relative error control (ATOL(i)=0.0) was 679 C requested on a variable which has now vanished. The 680 C integration was successful as far as T. 681 C 682 C Note: Since the normal output value of ISTATE is 2, it 683 C does not need to be reset for normal continuation. Also, 684 C since a negative input value of ISTATE will be regarded 685 C as illegal, a negative output value requires the user to 686 C change it, and possibly other inputs, before calling the 687 C solver again. 688 C 689 C IOPT An integer flag to specify whether any optional inputs 690 C are being used on this call. Input only. The optional 691 C inputs are listed under a separate heading below. 692 C 0 No optional inputs are being used. Default values 693 C will be used in all cases. 694 C 1 One or more optional inputs are being used. 695 C 696 C RWORK A real working array (double precision). The length of 697 C RWORK must be at least 698 C 699 C 20 + NYH*(MAXORD + 1) + 3*NEQ + LWM 700 C 701 C where 702 C NYH = the initial value of NEQ, 703 C MAXORD = 12 (if METH = 1) or 5 (if METH = 2) (unless a 704 C smaller value is given as an optional input), 705 C LWM = 0 if MITER = 0, 706 C LWM = NEQ**2 + 2 if MITER = 1 or 2, 707 C LWM = NEQ + 2 if MITER = 3, and 708 C LWM = (2*ML + MU + 1)*NEQ + 2 709 C if MITER = 4 or 5. 710 C (See the MF description below for METH and MITER.) 711 C 712 C Thus if MAXORD has its default value and NEQ is constant, 713 C this length is: 714 C 20 + 16*NEQ for MF = 10, 715 C 22 + 16*NEQ + NEQ**2 for MF = 11 or 12, 716 C 22 + 17*NEQ for MF = 13, 717 C 22 + 17*NEQ + (2*ML + MU)*NEQ for MF = 14 or 15, 718 C 20 + 9*NEQ for MF = 20, 719 C 22 + 9*NEQ + NEQ**2 for MF = 21 or 22, 720 C 22 + 10*NEQ for MF = 23, 721 C 22 + 10*NEQ + (2*ML + MU)*NEQ for MF = 24 or 25. 722 C 723 C The first 20 words of RWORK are reserved for conditional 724 C and optional inputs and optional outputs. 725 C 726 C The following word in RWORK is a conditional input: 727 C RWORK(1) = TCRIT, the critical value of t which the 728 C solver is not to overshoot. Required if ITASK 729 C is 4 or 5, and ignored otherwise. See ITASK. 730 C 731 C LRW The length of the array RWORK, as declared by the user. 732 C (This will be checked by the solver.) 733 C 734 C IWORK An integer work array. Its length must be at least 735 C 20 if MITER = 0 or 3 (MF = 10, 13, 20, 23), or 736 C 20 + NEQ otherwise (MF = 11, 12, 14, 15, 21, 22, 24, 25). 737 C (See the MF description below for MITER.) The first few 738 C words of IWORK are used for conditional and optional 739 C inputs and optional outputs. 740 C 741 C The following two words in IWORK are conditional inputs: 742 C IWORK(1) = ML These are the lower and upper half- 743 C IWORK(2) = MU bandwidths, respectively, of the banded 744 C Jacobian, excluding the main diagonal. 745 C The band is defined by the matrix locations 746 C (i,j) with i - ML <= j <= i + MU. ML and MU 747 C must satisfy 0 <= ML,MU <= NEQ - 1. These are 748 C required if MITER is 4 or 5, and ignored 749 C otherwise. ML and MU may in fact be the band 750 C parameters for a matrix to which df/dy is only 751 C approximately equal. 752 C 753 C LIW The length of the array IWORK, as declared by the user. 754 C (This will be checked by the solver.) 755 C 756 C Note: The work arrays must not be altered between calls to DLSODE 757 C for the same problem, except possibly for the conditional and 758 C optional inputs, and except for the last 3*NEQ words of RWORK. 759 C The latter space is used for internal scratch space, and so is 760 C available for use by the user outside DLSODE between calls, if 761 C desired (but not for use by F or JAC). 762 C 763 C JAC The name of the user-supplied routine (MITER = 1 or 4) to 764 C compute the Jacobian matrix, df/dy, as a function of the 765 C scalar t and the vector y. (See the MF description below 766 C for MITER.) It is to have the form 767 C 768 C SUBROUTINE JAC (NEQ, T, Y, ML, MU, PD, NROWPD) 769 C DOUBLE PRECISION T, Y(*), PD(NROWPD,*) 770 C 771 C where NEQ, T, Y, ML, MU, and NROWPD are input and the 772 C array PD is to be loaded with partial derivatives 773 C (elements of the Jacobian matrix) on output. PD must be 774 C given a first dimension of NROWPD. T and Y have the same 775 C meaning as in subroutine F. 776 C 777 C In the full matrix case (MITER = 1), ML and MU are 778 C ignored, and the Jacobian is to be loaded into PD in 779 C columnwise manner, with df(i)/dy(j) loaded into PD(i,j). 780 C 781 C In the band matrix case (MITER = 4), the elements within 782 C the band are to be loaded into PD in columnwise manner, 783 C with diagonal lines of df/dy loaded into the rows of PD. 784 C Thus df(i)/dy(j) is to be loaded into PD(i-j+MU+1,j). ML 785 C and MU are the half-bandwidth parameters (see IWORK). 786 C The locations in PD in the two triangular areas which 787 C correspond to nonexistent matrix elements can be ignored 788 C or loaded arbitrarily, as they are overwritten by DLSODE. 789 C 790 C JAC need not provide df/dy exactly. A crude approximation 791 C (possibly with a smaller bandwidth) will do. 792 C 793 C In either case, PD is preset to zero by the solver, so 794 C that only the nonzero elements need be loaded by JAC. 795 C Each call to JAC is preceded by a call to F with the same 796 C arguments NEQ, T, and Y. Thus to gain some efficiency, 797 C intermediate quantities shared by both calculations may 798 C be saved in a user COMMON block by F and not recomputed 799 C by JAC, if desired. Also, JAC may alter the Y array, if 800 C desired. JAC must be declared EXTERNAL in the calling 801 C program. 802 C 803 C Subroutine JAC may access user-defined quantities in 804 C NEQ(2),... and/or in Y(NEQ(1)+1),... if NEQ is an array 805 C (dimensioned in JAC) and/or Y has length exceeding 806 C NEQ(1). See the descriptions of NEQ and Y above. 807 C 808 C MF The method flag. Used only for input. The legal values 809 C of MF are 10, 11, 12, 13, 14, 15, 20, 21, 22, 23, 24, 810 C and 25. MF has decimal digits METH and MITER: 811 C MF = 10*METH + MITER . 812 C 813 C METH indicates the basic linear multistep method: 814 C 1 Implicit Adams method. 815 C 2 Method based on backward differentiation formulas 816 C (BDF's). 817 C 818 C MITER indicates the corrector iteration method: 819 C 0 Functional iteration (no Jacobian matrix is 820 C involved). 821 C 1 Chord iteration with a user-supplied full (NEQ by 822 C NEQ) Jacobian. 823 C 2 Chord iteration with an internally generated 824 C (difference quotient) full Jacobian (using NEQ 825 C extra calls to F per df/dy value). 826 C 3 Chord iteration with an internally generated 827 C diagonal Jacobian approximation (using one extra call 828 C to F per df/dy evaluation). 829 C 4 Chord iteration with a user-supplied banded Jacobian. 830 C 5 Chord iteration with an internally generated banded 831 C Jacobian (using ML + MU + 1 extra calls to F per 832 C df/dy evaluation). 833 C 834 C If MITER = 1 or 4, the user must supply a subroutine JAC 835 C (the name is arbitrary) as described above under JAC. 836 C For other values of MITER, a dummy argument can be used. 837 C 838 C Optional Inputs 839 C --------------- 840 C The following is a list of the optional inputs provided for in the 841 C call sequence. (See also Part 2.) For each such input variable, 842 C this table lists its name as used in this documentation, its 843 C location in the call sequence, its meaning, and the default value. 844 C The use of any of these inputs requires IOPT = 1, and in that case 845 C all of these inputs are examined. A value of zero for any of 846 C these optional inputs will cause the default value to be used. 847 C Thus to use a subset of the optional inputs, simply preload 848 C locations 5 to 10 in RWORK and IWORK to 0.0 and 0 respectively, 849 C and then set those of interest to nonzero values. 850 C 851 C Name Location Meaning and default value 852 C ------ --------- ----------------------------------------------- 853 C H0 RWORK(5) Step size to be attempted on the first step. 854 C The default value is determined by the solver. 855 C HMAX RWORK(6) Maximum absolute step size allowed. The 856 C default value is infinite. 857 C HMIN RWORK(7) Minimum absolute step size allowed. The 858 C default value is 0. (This lower bound is not 859 C enforced on the final step before reaching 860 C TCRIT when ITASK = 4 or 5.) 861 C MAXORD IWORK(5) Maximum order to be allowed. The default value 862 C is 12 if METH = 1, and 5 if METH = 2. (See the 863 C MF description above for METH.) If MAXORD 864 C exceeds the default value, it will be reduced 865 C to the default value. If MAXORD is changed 866 C during the problem, it may cause the current 867 C order to be reduced. 868 C MXSTEP IWORK(6) Maximum number of (internally defined) steps 869 C allowed during one call to the solver. The 870 C default value is 500. 871 C MXHNIL IWORK(7) Maximum number of messages printed (per 872 C problem) warning that T + H = T on a step 873 C (H = step size). This must be positive to 874 C result in a nondefault value. The default 875 C value is 10. 876 C 877 C Optional Outputs 878 C ---------------- 879 C As optional additional output from DLSODE, the variables listed 880 C below are quantities related to the performance of DLSODE which 881 C are available to the user. These are communicated by way of the 882 C work arrays, but also have internal mnemonic names as shown. 883 C Except where stated otherwise, all of these outputs are defined on 884 C any successful return from DLSODE, and on any return with ISTATE = 885 C -1, -2, -4, -5, or -6. On an illegal input return (ISTATE = -3), 886 C they will be unchanged from their existing values (if any), except 887 C possibly for TOLSF, LENRW, and LENIW. On any error return, 888 C outputs relevant to the error will be defined, as noted below. 889 C 890 C Name Location Meaning 891 C ----- --------- ------------------------------------------------ 892 C HU RWORK(11) Step size in t last used (successfully). 893 C HCUR RWORK(12) Step size to be attempted on the next step. 894 C TCUR RWORK(13) Current value of the independent variable which 895 C the solver has actually reached, i.e., the 896 C current internal mesh point in t. On output, 897 C TCUR will always be at least as far as the 898 C argument T, but may be farther (if interpolation 899 C was done). 900 C TOLSF RWORK(14) Tolerance scale factor, greater than 1.0, 901 C computed when a request for too much accuracy 902 C was detected (ISTATE = -3 if detected at the 903 C start of the problem, ISTATE = -2 otherwise). 904 C If ITOL is left unaltered but RTOL and ATOL are 905 C uniformly scaled up by a factor of TOLSF for the 906 C next call, then the solver is deemed likely to 907 C succeed. (The user may also ignore TOLSF and 908 C alter the tolerance parameters in any other way 909 C appropriate.) 910 C NST IWORK(11) Number of steps taken for the problem so far. 911 C NFE IWORK(12) Number of F evaluations for the problem so far. 912 C NJE IWORK(13) Number of Jacobian evaluations (and of matrix LU 913 C decompositions) for the problem so far. 914 C NQU IWORK(14) Method order last used (successfully). 915 C NQCUR IWORK(15) Order to be attempted on the next step. 916 C IMXER IWORK(16) Index of the component of largest magnitude in 917 C the weighted local error vector ( e(i)/EWT(i) ), 918 C on an error return with ISTATE = -4 or -5. 919 C LENRW IWORK(17) Length of RWORK actually required. This is 920 C defined on normal returns and on an illegal 921 C input return for insufficient storage. 922 C LENIW IWORK(18) Length of IWORK actually required. This is 923 C defined on normal returns and on an illegal 924 C input return for insufficient storage. 925 C 926 C The following two arrays are segments of the RWORK array which may 927 C also be of interest to the user as optional outputs. For each 928 C array, the table below gives its internal name, its base address 929 C in RWORK, and its description. 930 C 931 C Name Base address Description 932 C ---- ------------ ---------------------------------------------- 933 C YH 21 The Nordsieck history array, of size NYH by 934 C (NQCUR + 1), where NYH is the initial value of 935 C NEQ. For j = 0,1,...,NQCUR, column j + 1 of 936 C YH contains HCUR**j/factorial(j) times the jth 937 C derivative of the interpolating polynomial 938 C currently representing the solution, evaluated 939 C at t = TCUR. 940 C ACOR LENRW-NEQ+1 Array of size NEQ used for the accumulated 941 C corrections on each step, scaled on output to 942 C represent the estimated local error in Y on 943 C the last step. This is the vector e in the 944 C description of the error control. It is 945 C defined only on successful return from DLSODE. 946 C 947 C 948 C Part 2. Other Callable Routines 949 C -------------------------------- 950 C 951 C The following are optional calls which the user may make to gain 952 C additional capabilities in conjunction with DLSODE. 953 C 954 C Form of call Function 955 C ------------------------ ---------------------------------------- 956 C CALL XSETUN(LUN) Set the logical unit number, LUN, for 957 C output of messages from DLSODE, if the 958 C default is not desired. The default 959 C value of LUN is 6. This call may be made 960 C at any time and will take effect 961 C immediately. 962 C CALL XSETF(MFLAG) Set a flag to control the printing of 963 C messages by DLSODE. MFLAG = 0 means do 964 C not print. (Danger: this risks losing 965 C valuable information.) MFLAG = 1 means 966 C print (the default). This call may be 967 C made at any time and will take effect 968 C immediately. 969 C CALL DSRCOM(RSAV,ISAV,JOB) Saves and restores the contents of the 970 C internal COMMON blocks used by DLSODE 971 C (see Part 3 below). RSAV must be a 972 C real array of length 218 or more, and 973 C ISAV must be an integer array of length 974 C 37 or more. JOB = 1 means save COMMON 975 C into RSAV/ISAV. JOB = 2 means restore 976 C COMMON from same. DSRCOM is useful if 977 C one is interrupting a run and restarting 978 C later, or alternating between two or 979 C more problems solved with DLSODE. 980 C CALL DINTDY(,,,,,) Provide derivatives of y, of various 981 C (see below) orders, at a specified point t, if 982 C desired. It may be called only after a 983 C successful return from DLSODE. Detailed 984 C instructions follow. 985 C 986 C Detailed instructions for using DINTDY 987 C -------------------------------------- 988 C The form of the CALL is: 989 C 990 C CALL DINTDY (T, K, RWORK(21), NYH, DKY, IFLAG) 991 C 992 C The input parameters are: 993 C 994 C T Value of independent variable where answers are 995 C desired (normally the same as the T last returned by 996 C DLSODE). For valid results, T must lie between 997 C TCUR - HU and TCUR. (See "Optional Outputs" above 998 C for TCUR and HU.) 999 C K Integer order of the derivative desired. K must 1000 C satisfy 0 <= K <= NQCUR, where NQCUR is the current 1001 C order (see "Optional Outputs"). The capability 1002 C corresponding to K = 0, i.e., computing y(t), is 1003 C already provided by DLSODE directly. Since 1004 C NQCUR >= 1, the first derivative dy/dt is always 1005 C available with DINTDY. 1006 C RWORK(21) The base address of the history array YH. 1007 C NYH Column length of YH, equal to the initial value of NEQ. 1008 C 1009 C The output parameters are: 1010 C 1011 C DKY Real array of length NEQ containing the computed value 1012 C of the Kth derivative of y(t). 1013 C IFLAG Integer flag, returned as 0 if K and T were legal, 1014 C -1 if K was illegal, and -2 if T was illegal. 1015 C On an error return, a message is also written. 1016 C 1017 C 1018 C Part 3. Common Blocks 1019 C ---------------------- 1020 C 1021 C If DLSODE is to be used in an overlay situation, the user must 1022 C declare, in the primary overlay, the variables in: 1023 C (1) the call sequence to DLSODE, 1024 C (2) the internal COMMON block /DLS001/, of length 255 1025 C (218 double precision words followed by 37 integer words). 1026 C 1027 C If DLSODE is used on a system in which the contents of internal 1028 C COMMON blocks are not preserved between calls, the user should 1029 C declare the above COMMON block in his main program to insure that 1030 C its contents are preserved. 1031 C 1032 C If the solution of a given problem by DLSODE is to be interrupted 1033 C and then later continued, as when restarting an interrupted run or 1034 C alternating between two or more problems, the user should save, 1035 C following the return from the last DLSODE call prior to the 1036 C interruption, the contents of the call sequence variables and the 1037 C internal COMMON block, and later restore these values before the 1038 C next DLSODE call for that problem. In addition, if XSETUN and/or 1039 C XSETF was called for non-default handling of error messages, then 1040 C these calls must be repeated. To save and restore the COMMON 1041 C block, use subroutine DSRCOM (see Part 2 above). 1042 C 1043 C 1044 C Part 4. Optionally Replaceable Solver Routines 1045 C ----------------------------------------------- 1046 C 1047 C Below are descriptions of two routines in the DLSODE package which 1048 C relate to the measurement of errors. Either routine can be 1049 C replaced by a user-supplied version, if desired. However, since 1050 C such a replacement may have a major impact on performance, it 1051 C should be done only when absolutely necessary, and only with great 1052 C caution. (Note: The means by which the package version of a 1053 C routine is superseded by the user's version may be system- 1054 C dependent.) 1055 C 1056 C DEWSET 1057 C ------ 1058 C The following subroutine is called just before each internal 1059 C integration step, and sets the array of error weights, EWT, as 1060 C described under ITOL/RTOL/ATOL above: 1061 C 1062 C SUBROUTINE DEWSET (NEQ, ITOL, RTOL, ATOL, YCUR, EWT) 1063 C 1064 C where NEQ, ITOL, RTOL, and ATOL are as in the DLSODE call 1065 C sequence, YCUR contains the current dependent variable vector, 1066 C and EWT is the array of weights set by DEWSET. 1067 C 1068 C If the user supplies this subroutine, it must return in EWT(i) 1069 C (i = 1,...,NEQ) a positive quantity suitable for comparing errors 1070 C in Y(i) to. The EWT array returned by DEWSET is passed to the 1071 C DVNORM routine (see below), and also used by DLSODE in the 1072 C computation of the optional output IMXER, the diagonal Jacobian 1073 C approximation, and the increments for difference quotient 1074 C Jacobians. 1075 C 1076 C In the user-supplied version of DEWSET, it may be desirable to use 1077 C the current values of derivatives of y. Derivatives up to order NQ 1078 C are available from the history array YH, described above under 1079 C optional outputs. In DEWSET, YH is identical to the YCUR array, 1080 C extended to NQ + 1 columns with a column length of NYH and scale 1081 C factors of H**j/factorial(j). On the first call for the problem, 1082 C given by NST = 0, NQ is 1 and H is temporarily set to 1.0. 1083 C NYH is the initial value of NEQ. The quantities NQ, H, and NST 1084 C can be obtained by including in SEWSET the statements: 1085 C DOUBLE PRECISION RLS 1086 C COMMON /DLS001/ RLS(218),ILS(37) 1087 C NQ = ILS(33) 1088 C NST = ILS(34) 1089 C H = RLS(212) 1090 C Thus, for example, the current value of dy/dt can be obtained as 1091 C YCUR(NYH+i)/H (i=1,...,NEQ) (and the division by H is unnecessary 1092 C when NST = 0). 1093 C 1094 C DVNORM 1095 C ------ 1096 C DVNORM is a real function routine which computes the weighted 1097 C root-mean-square norm of a vector v: 1098 C 1099 C d = DVNORM (n, v, w) 1100 C 1101 C where: 1102 C n = the length of the vector, 1103 C v = real array of length n containing the vector, 1104 C w = real array of length n containing weights, 1105 C d = SQRT( (1/n) * sum(v(i)*w(i))**2 ). 1106 C 1107 C DVNORM is called with n = NEQ and with w(i) = 1.0/EWT(i), where 1108 C EWT is as set by subroutine DEWSET. 1109 C 1110 C If the user supplies this function, it should return a nonnegative 1111 C value of DVNORM suitable for use in the error control in DLSODE. 1112 C None of the arguments should be altered by DVNORM. For example, a 1113 C user-supplied DVNORM routine might: 1114 C - Substitute a max-norm of (v(i)*w(i)) for the rms-norm, or 1115 C - Ignore some components of v in the norm, with the effect of 1116 C suppressing the error control on those components of Y. 1117 C --------------------------------------------------------------------- 1118 C***ROUTINES CALLED DEWSET, DINTDY, DUMACH, DSTODE, DVNORM, XERRWD 1119 C***COMMON BLOCKS DLS001 1120 C***REVISION HISTORY (YYYYMMDD) 1121 C 19791129 DATE WRITTEN 1122 C 19791213 Minor changes to declarations; DELP init. in STODE. 1123 C 19800118 Treat NEQ as array; integer declarations added throughout; 1124 C minor changes to prologue. 1125 C 19800306 Corrected TESCO(1,NQP1) setting in CFODE. 1126 C 19800519 Corrected access of YH on forced order reduction; 1127 C numerous corrections to prologues and other comments. 1128 C 19800617 In main driver, added loading of SQRT(UROUND) in RWORK; 1129 C minor corrections to main prologue. 1130 C 19800923 Added zero initialization of HU and NQU. 1131 C 19801218 Revised XERRWD routine; minor corrections to main prologue. 1132 C 19810401 Minor changes to comments and an error message. 1133 C 19810814 Numerous revisions: replaced EWT by 1/EWT; used flags 1134 C JCUR, ICF, IERPJ, IERSL between STODE and subordinates; 1135 C added tuning parameters CCMAX, MAXCOR, MSBP, MXNCF; 1136 C reorganized returns from STODE; reorganized type decls.; 1137 C fixed message length in XERRWD; changed default LUNIT to 6; 1138 C changed Common lengths; changed comments throughout. 1139 C 19870330 Major update by ACH: corrected comments throughout; 1140 C removed TRET from Common; rewrote EWSET with 4 loops; 1141 C fixed t test in INTDY; added Cray directives in STODE; 1142 C in STODE, fixed DELP init. and logic around PJAC call; 1143 C combined routines to save/restore Common; 1144 C passed LEVEL = 0 in error message calls (except run abort). 1145 C 19890426 Modified prologue to SLATEC/LDOC format. (FNF) 1146 C 19890501 Many improvements to prologue. (FNF) 1147 C 19890503 A few final corrections to prologue. (FNF) 1148 C 19890504 Minor cosmetic changes. (FNF) 1149 C 19890510 Corrected description of Y in Arguments section. (FNF) 1150 C 19890517 Minor corrections to prologue. (FNF) 1151 C 19920514 Updated with prologue edited 891025 by G. Shaw for manual. 1152 C 19920515 Converted source lines to upper case. (FNF) 1153 C 19920603 Revised XERRWD calls using mixed upper-lower case. (ACH) 1154 C 19920616 Revised prologue comment regarding CFT. (ACH) 1155 C 19921116 Revised prologue comments regarding Common. (ACH). 1156 C 19930326 Added comment about non-reentrancy. (FNF) 1157 C 19930723 Changed D1MACH to DUMACH. (FNF) 1158 C 19930801 Removed ILLIN and NTREP from Common (affects driver logic); 1159 C minor changes to prologue and internal comments; 1160 C changed Hollerith strings to quoted strings; 1161 C changed internal comments to mixed case; 1162 C replaced XERRWD with new version using character type; 1163 C changed dummy dimensions from 1 to *. (ACH) 1164 C 19930809 Changed to generic intrinsic names; changed names of 1165 C subprograms and Common blocks to DLSODE etc. (ACH) 1166 C 19930929 Eliminated use of REAL intrinsic; other minor changes. (ACH) 1167 C 20010412 Removed all 'own' variables from Common block /DLS001/ 1168 C (affects declarations in 6 routines). (ACH) 1169 C 20010509 Minor corrections to prologue. (ACH) 1170 C 20031105 Restored 'own' variables to Common block /DLS001/, to 1171 C enable interrupt/restart feature. (ACH) 1172 C 20031112 Added SAVE statements for data-loaded constants. 1173 C 1174 C***END PROLOGUE DLSODE 1175 C 1176 C*Internal Notes: 1177 C 1178 C Other Routines in the DLSODE Package. 1179 C 1180 C In addition to Subroutine DLSODE, the DLSODE package includes the 1181 C following subroutines and function routines: 1182 C DINTDY computes an interpolated value of the y vector at t = TOUT. 1183 C DSTODE is the core integrator, which does one step of the 1184 C integration and the associated error control. 1185 C DCFODE sets all method coefficients and test constants. 1186 C DPREPJ computes and preprocesses the Jacobian matrix J = df/dy 1187 C and the Newton iteration matrix P = I - h*l0*J. 1188 C DSOLSY manages solution of linear system in chord iteration. 1189 C DEWSET sets the error weight vector EWT before each step. 1190 C DVNORM computes the weighted R.M.S. norm of a vector. 1191 C DSRCOM is a user-callable routine to save and restore 1192 C the contents of the internal Common block. 1193 C DGEFA and DGESL are routines from LINPACK for solving full 1194 C systems of linear algebraic equations. 1195 C DGBFA and DGBSL are routines from LINPACK for solving banded 1196 C linear systems. 1197 C DUMACH computes the unit roundoff in a machine-independent manner. 1198 C XERRWD, XSETUN, XSETF, IXSAV, IUMACH handle the printing of all 1199 C error messages and warnings. XERRWD is machine-dependent. 1200 C Note: DVNORM, DUMACH, IXSAV, and IUMACH are function routines. 1201 C All the others are subroutines. 1202 C 1203 C**End 1204 C 1205 C Declare externals. 1206 EXTERNAL DPREPJ, DSOLSY 1207 DOUBLE PRECISION DUMACH, DVNORM 1208 C 1209 C Declare all other variables. 1210 INTEGER INIT, MXSTEP, MXHNIL, NHNIL, NSLAST, NYH, IOWNS, 1211 1 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 1212 2 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 1213 3 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU 1214 INTEGER I, I1, I2, IFLAG, IMXER, KGO, LF0, 1215 1 LENIW, LENRW, LENWM, ML, MORD, MU, MXHNL0, MXSTP0 1216 DOUBLE PRECISION ROWNS, 1217 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND 1218 DOUBLE PRECISION ATOLI, AYI, BIG, EWTI, H0, HMAX, HMX, RH, RTOLI, 1219 1 TCRIT, TDIST, TNEXT, TOL, TOLSF, TP, SIZE, SUM, W0 1220 DIMENSION MORD(2) 1221 LOGICAL IHIT 1222 CHARACTER*80 MSG 1223 SAVE MORD, MXSTP0, MXHNL0 1224 C----------------------------------------------------------------------- 1225 C The following internal Common block contains 1226 C (a) variables which are local to any subroutine but whose values must 1227 C be preserved between calls to the routine ("own" variables), and 1228 C (b) variables which are communicated between subroutines. 1229 C The block DLS001 is declared in subroutines DLSODE, DINTDY, DSTODE, 1230 C DPREPJ, and DSOLSY. 1231 C Groups of variables are replaced by dummy arrays in the Common 1232 C declarations in routines where those variables are not used. 1233 C----------------------------------------------------------------------- 1234 COMMON /DLS001/ ROWNS(209), 1235 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND, 1236 2 INIT, MXSTEP, MXHNIL, NHNIL, NSLAST, NYH, IOWNS(6), 1237 3 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 1238 4 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 1239 5 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU 1240 C 1241 DATA MORD(1),MORD(2)/12,5/, MXSTP0/500/, MXHNL0/10/ 1242 C----------------------------------------------------------------------- 1243 C Block A. 1244 C This code block is executed on every call. 1245 C It tests ISTATE and ITASK for legality and branches appropriately. 1246 C If ISTATE .GT. 1 but the flag INIT shows that initialization has 1247 C not yet been done, an error return occurs. 1248 C If ISTATE = 1 and TOUT = T, return immediately. 1249 C----------------------------------------------------------------------- 1250 C 1251 C***FIRST EXECUTABLE STATEMENT DLSODE 1252 IF (ISTATE .LT. 1 .OR. ISTATE .GT. 3) GO TO 601 1253 IF (ITASK .LT. 1 .OR. ITASK .GT. 5) GO TO 602 1254 IF (ISTATE .EQ. 1) GO TO 10 1255 IF (INIT .EQ. 0) GO TO 603 1256 IF (ISTATE .EQ. 2) GO TO 200 1257 GO TO 20 1258 10 INIT = 0 1259 IF (TOUT .EQ. T) RETURN 1260 C----------------------------------------------------------------------- 1261 C Block B. 1262 C The next code block is executed for the initial call (ISTATE = 1), 1263 C or for a continuation call with parameter changes (ISTATE = 3). 1264 C It contains checking of all inputs and various initializations. 1265 C 1266 C First check legality of the non-optional inputs NEQ, ITOL, IOPT, 1267 C MF, ML, and MU. 1268 C----------------------------------------------------------------------- 1269 20 IF (NEQ(1) .LE. 0) GO TO 604 1270 IF (ISTATE .EQ. 1) GO TO 25 1271 IF (NEQ(1) .GT. N) GO TO 605 1272 25 N = NEQ(1) 1273 IF (ITOL .LT. 1 .OR. ITOL .GT. 4) GO TO 606 1274 IF (IOPT .LT. 0 .OR. IOPT .GT. 1) GO TO 607 1275 METH = MF/10 1276 MITER = MF - 10*METH 1277 IF (METH .LT. 1 .OR. METH .GT. 2) GO TO 608 1278 IF (MITER .LT. 0 .OR. MITER .GT. 5) GO TO 608 1279 IF (MITER .LE. 3) GO TO 30 1280 ML = IWORK(1) 1281 MU = IWORK(2) 1282 IF (ML .LT. 0 .OR. ML .GE. N) GO TO 609 1283 IF (MU .LT. 0 .OR. MU .GE. N) GO TO 610 1284 30 CONTINUE 1285 C Next process and check the optional inputs. -------------------------- 1286 IF (IOPT .EQ. 1) GO TO 40 1287 MAXORD = MORD(METH) 1288 MXSTEP = MXSTP0 1289 MXHNIL = MXHNL0 1290 IF (ISTATE .EQ. 1) H0 = 0.0D0 1291 HMXI = 0.0D0 1292 HMIN = 0.0D0 1293 GO TO 60 1294 40 MAXORD = IWORK(5) 1295 IF (MAXORD .LT. 0) GO TO 611 1296 IF (MAXORD .EQ. 0) MAXORD = 100 1297 MAXORD = MIN(MAXORD,MORD(METH)) 1298 MXSTEP = IWORK(6) 1299 IF (MXSTEP .LT. 0) GO TO 612 1300 IF (MXSTEP .EQ. 0) MXSTEP = MXSTP0 1301 MXHNIL = IWORK(7) 1302 IF (MXHNIL .LT. 0) GO TO 613 1303 IF (MXHNIL .EQ. 0) MXHNIL = MXHNL0 1304 IF (ISTATE .NE. 1) GO TO 50 1305 H0 = RWORK(5) 1306 IF ((TOUT - T)*H0 .LT. 0.0D0) GO TO 614 1307 50 HMAX = RWORK(6) 1308 IF (HMAX .LT. 0.0D0) GO TO 615 1309 HMXI = 0.0D0 1310 IF (HMAX .GT. 0.0D0) HMXI = 1.0D0/HMAX 1311 HMIN = RWORK(7) 1312 IF (HMIN .LT. 0.0D0) GO TO 616 1313 C----------------------------------------------------------------------- 1314 C Set work array pointers and check lengths LRW and LIW. 1315 C Pointers to segments of RWORK and IWORK are named by prefixing L to 1316 C the name of the segment. E.g., the segment YH starts at RWORK(LYH). 1317 C Segments of RWORK (in order) are denoted YH, WM, EWT, SAVF, ACOR. 1318 C----------------------------------------------------------------------- 1319 60 LYH = 21 1320 IF (ISTATE .EQ. 1) NYH = N 1321 LWM = LYH + (MAXORD + 1)*NYH 1322 IF (MITER .EQ. 0) LENWM = 0 1323 IF (MITER .EQ. 1 .OR. MITER .EQ. 2) LENWM = N*N + 2 1324 IF (MITER .EQ. 3) LENWM = N + 2 1325 IF (MITER .GE. 4) LENWM = (2*ML + MU + 1)*N + 2 1326 LEWT = LWM + LENWM 1327 LSAVF = LEWT + N 1328 LACOR = LSAVF + N 1329 LENRW = LACOR + N - 1 1330 IWORK(17) = LENRW 1331 LIWM = 1 1332 LENIW = 20 + N 1333 IF (MITER .EQ. 0 .OR. MITER .EQ. 3) LENIW = 20 1334 IWORK(18) = LENIW 1335 IF (LENRW .GT. LRW) GO TO 617 1336 IF (LENIW .GT. LIW) GO TO 618 1337 C Check RTOL and ATOL for legality. ------------------------------------ 1338 RTOLI = RTOL(1) 1339 ATOLI = ATOL(1) 1340 DO 70 I = 1,N 1341 IF (ITOL .GE. 3) RTOLI = RTOL(I) 1342 IF (ITOL .EQ. 2 .OR. ITOL .EQ. 4) ATOLI = ATOL(I) 1343 IF (RTOLI .LT. 0.0D0) GO TO 619 1344 IF (ATOLI .LT. 0.0D0) GO TO 620 1345 70 CONTINUE 1346 IF (ISTATE .EQ. 1) GO TO 100 1347 C If ISTATE = 3, set flag to signal parameter changes to DSTODE. ------- 1348 JSTART = -1 1349 IF (NQ .LE. MAXORD) GO TO 90 1350 C MAXORD was reduced below NQ. Copy YH(*,MAXORD+2) into SAVF. --------- 1351 DO 80 I = 1,N 1352 80 RWORK(I+LSAVF-1) = RWORK(I+LWM-1) 1353 C Reload WM(1) = RWORK(LWM), since LWM may have changed. --------------- 1354 90 IF (MITER .GT. 0) RWORK(LWM) = SQRT(UROUND) 1355 IF (N .EQ. NYH) GO TO 200 1356 C NEQ was reduced. Zero part of YH to avoid undefined references. ----- 1357 I1 = LYH + L*NYH 1358 I2 = LYH + (MAXORD + 1)*NYH - 1 1359 IF (I1 .GT. I2) GO TO 200 1360 DO 95 I = I1,I2 1361 95 RWORK(I) = 0.0D0 1362 GO TO 200 1363 C----------------------------------------------------------------------- 1364 C Block C. 1365 C The next block is for the initial call only (ISTATE = 1). 1366 C It contains all remaining initializations, the initial call to F, 1367 C and the calculation of the initial step size. 1368 C The error weights in EWT are inverted after being loaded. 1369 C----------------------------------------------------------------------- 1370 100 UROUND = DUMACH() 1371 TN = T 1372 IF (ITASK .NE. 4 .AND. ITASK .NE. 5) GO TO 110 1373 TCRIT = RWORK(1) 1374 IF ((TCRIT - TOUT)*(TOUT - T) .LT. 0.0D0) GO TO 625 1375 IF (H0 .NE. 0.0D0 .AND. (T + H0 - TCRIT)*H0 .GT. 0.0D0) 1376 1 H0 = TCRIT - T 1377 110 JSTART = 0 1378 IF (MITER .GT. 0) RWORK(LWM) = SQRT(UROUND) 1379 NHNIL = 0 1380 NST = 0 1381 NJE = 0 1382 NSLAST = 0 1383 HU = 0.0D0 1384 NQU = 0 1385 CCMAX = 0.3D0 1386 MAXCOR = 3 1387 MSBP = 20 1388 MXNCF = 10 1389 C Initial call to F. (LF0 points to YH(*,2).) ------------------------- 1390 LF0 = LYH + NYH 1391 CALL F (NEQ, T, Y, RWORK(LF0)) 1392 NFE = 1 1393 C Load the initial value vector in YH. --------------------------------- 1394 DO 115 I = 1,N 1395 115 RWORK(I+LYH-1) = Y(I) 1396 C Load and invert the EWT array. (H is temporarily set to 1.0.) ------- 1397 NQ = 1 1398 H = 1.0D0 1399 CALL DEWSET (N, ITOL, RTOL, ATOL, RWORK(LYH), RWORK(LEWT)) 1400 DO 120 I = 1,N 1401 IF (RWORK(I+LEWT-1) .LE. 0.0D0) GO TO 621 1402 120 RWORK(I+LEWT-1) = 1.0D0/RWORK(I+LEWT-1) 1403 C----------------------------------------------------------------------- 1404 C The coding below computes the step size, H0, to be attempted on the 1405 C first step, unless the user has supplied a value for this. 1406 C First check that TOUT - T differs significantly from zero. 1407 C A scalar tolerance quantity TOL is computed, as MAX(RTOL(I)) 1408 C if this is positive, or MAX(ATOL(I)/ABS(Y(I))) otherwise, adjusted 1409 C so as to be between 100*UROUND and 1.0E-3. 1410 C Then the computed value H0 is given by.. 1411 C NEQ 1412 C H0**2 = TOL / ( w0**-2 + (1/NEQ) * SUM ( f(i)/ywt(i) )**2 ) 1413 C 1 1414 C where w0 = MAX ( ABS(T), ABS(TOUT) ), 1415 C f(i) = i-th component of initial value of f, 1416 C ywt(i) = EWT(i)/TOL (a weight for y(i)). 1417 C The sign of H0 is inferred from the initial values of TOUT and T. 1418 C----------------------------------------------------------------------- 1419 IF (H0 .NE. 0.0D0) GO TO 180 1420 TDIST = ABS(TOUT - T) 1421 W0 = MAX(ABS(T),ABS(TOUT)) 1422 IF (TDIST .LT. 2.0D0*UROUND*W0) GO TO 622 1423 TOL = RTOL(1) 1424 IF (ITOL .LE. 2) GO TO 140 1425 DO 130 I = 1,N 1426 130 TOL = MAX(TOL,RTOL(I)) 1427 140 IF (TOL .GT. 0.0D0) GO TO 160 1428 ATOLI = ATOL(1) 1429 DO 150 I = 1,N 1430 IF (ITOL .EQ. 2 .OR. ITOL .EQ. 4) ATOLI = ATOL(I) 1431 AYI = ABS(Y(I)) 1432 IF (AYI .NE. 0.0D0) TOL = MAX(TOL,ATOLI/AYI) 1433 150 CONTINUE 1434 160 TOL = MAX(TOL,100.0D0*UROUND) 1435 TOL = MIN(TOL,0.001D0) 1436 SUM = DVNORM (N, RWORK(LF0), RWORK(LEWT)) 1437 SUM = 1.0D0/(TOL*W0*W0) + TOL*SUM**2 1438 H0 = 1.0D0/SQRT(SUM) 1439 H0 = MIN(H0,TDIST) 1440 H0 = SIGN(H0,TOUT-T) 1441 C Adjust H0 if necessary to meet HMAX bound. --------------------------- 1442 180 RH = ABS(H0)*HMXI 1443 IF (RH .GT. 1.0D0) H0 = H0/RH 1444 C Load H with H0 and scale YH(*,2) by H0. ------------------------------ 1445 H = H0 1446 DO 190 I = 1,N 1447 190 RWORK(I+LF0-1) = H0*RWORK(I+LF0-1) 1448 GO TO 270 1449 C----------------------------------------------------------------------- 1450 C Block D. 1451 C The next code block is for continuation calls only (ISTATE = 2 or 3) 1452 C and is to check stop conditions before taking a step. 1453 C----------------------------------------------------------------------- 1454 200 NSLAST = NST 1455 GO TO (210, 250, 220, 230, 240), ITASK 1456 210 IF ((TN - TOUT)*H .LT. 0.0D0) GO TO 250 1457 CALL DINTDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) 1458 IF (IFLAG .NE. 0) GO TO 627 1459 T = TOUT 1460 GO TO 420 1461 220 TP = TN - HU*(1.0D0 + 100.0D0*UROUND) 1462 IF ((TP - TOUT)*H .GT. 0.0D0) GO TO 623 1463 IF ((TN - TOUT)*H .LT. 0.0D0) GO TO 250 1464 GO TO 400 1465 230 TCRIT = RWORK(1) 1466 IF ((TN - TCRIT)*H .GT. 0.0D0) GO TO 624 1467 IF ((TCRIT - TOUT)*H .LT. 0.0D0) GO TO 625 1468 IF ((TN - TOUT)*H .LT. 0.0D0) GO TO 245 1469 CALL DINTDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) 1470 IF (IFLAG .NE. 0) GO TO 627 1471 T = TOUT 1472 GO TO 420 1473 240 TCRIT = RWORK(1) 1474 IF ((TN - TCRIT)*H .GT. 0.0D0) GO TO 624 1475 245 HMX = ABS(TN) + ABS(H) 1476 IHIT = ABS(TN - TCRIT) .LE. 100.0D0*UROUND*HMX 1477 IF (IHIT) GO TO 400 1478 TNEXT = TN + H*(1.0D0 + 4.0D0*UROUND) 1479 IF ((TNEXT - TCRIT)*H .LE. 0.0D0) GO TO 250 1480 H = (TCRIT - TN)*(1.0D0 - 4.0D0*UROUND) 1481 IF (ISTATE .EQ. 2) JSTART = -2 1482 C----------------------------------------------------------------------- 1483 C Block E. 1484 C The next block is normally executed for all calls and contains 1485 C the call to the one-step core integrator DSTODE. 1486 C 1487 C This is a looping point for the integration steps. 1488 C 1489 C First check for too many steps being taken, update EWT (if not at 1490 C start of problem), check for too much accuracy being requested, and 1491 C check for H below the roundoff level in T. 1492 C----------------------------------------------------------------------- 1493 250 CONTINUE 1494 IF ((NST-NSLAST) .GE. MXSTEP) GO TO 500 1495 CALL DEWSET (N, ITOL, RTOL, ATOL, RWORK(LYH), RWORK(LEWT)) 1496 DO 260 I = 1,N 1497 IF (RWORK(I+LEWT-1) .LE. 0.0D0) GO TO 510 1498 260 RWORK(I+LEWT-1) = 1.0D0/RWORK(I+LEWT-1) 1499 270 TOLSF = UROUND*DVNORM (N, RWORK(LYH), RWORK(LEWT)) 1500 IF (TOLSF .LE. 1.0D0) GO TO 280 1501 TOLSF = TOLSF*2.0D0 1502 IF (NST .EQ. 0) GO TO 626 1503 GO TO 520 1504 280 IF ((TN + H) .NE. TN) GO TO 290 1505 NHNIL = NHNIL + 1 1506 IF (NHNIL .GT. MXHNIL) GO TO 290 1507 MSG = 'DLSODE- Warning..internal T (=R1) and H (=R2) are' 1508 CALL XERRWD (MSG, 50, 101, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 1509 MSG=' such that in the machine, T + H = T on the next step ' 1510 CALL XERRWD (MSG, 60, 101, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 1511 MSG = ' (H = step size). Solver will continue anyway' 1512 CALL XERRWD (MSG, 50, 101, 0, 0, 0, 0, 2, TN, H) 1513 IF (NHNIL .LT. MXHNIL) GO TO 290 1514 MSG = 'DLSODE- Above warning has been issued I1 times. ' 1515 CALL XERRWD (MSG, 50, 102, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 1516 MSG = ' It will not be issued again for this problem' 1517 CALL XERRWD (MSG, 50, 102, 0, 1, MXHNIL, 0, 0, 0.0D0, 0.0D0) 1518 290 CONTINUE 1519 C----------------------------------------------------------------------- 1520 C CALL DSTODE(NEQ,Y,YH,NYH,YH,EWT,SAVF,ACOR,WM,IWM,F,JAC,DPREPJ,DSOLSY) 1521 C----------------------------------------------------------------------- 1522 CALL DSTODE (NEQ, Y, RWORK(LYH), NYH, RWORK(LYH), RWORK(LEWT), 1523 1 RWORK(LSAVF), RWORK(LACOR), RWORK(LWM), IWORK(LIWM), 1524 2 F, JAC, DPREPJ, DSOLSY) 1525 KGO = 1 - KFLAG 1526 GO TO (300, 530, 540), KGO 1527 C----------------------------------------------------------------------- 1528 C Block F. 1529 C The following block handles the case of a successful return from the 1530 C core integrator (KFLAG = 0). Test for stop conditions. 1531 C----------------------------------------------------------------------- 1532 300 INIT = 1 1533 GO TO (310, 400, 330, 340, 350), ITASK 1534 C ITASK = 1. If TOUT has been reached, interpolate. ------------------- 1535 310 IF ((TN - TOUT)*H .LT. 0.0D0) GO TO 250 1536 CALL DINTDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) 1537 T = TOUT 1538 GO TO 420 1539 C ITASK = 3. Jump to exit if TOUT was reached. ------------------------ 1540 330 IF ((TN - TOUT)*H .GE. 0.0D0) GO TO 400 1541 GO TO 250 1542 C ITASK = 4. See if TOUT or TCRIT was reached. Adjust H if necessary. 1543 340 IF ((TN - TOUT)*H .LT. 0.0D0) GO TO 345 1544 CALL DINTDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) 1545 T = TOUT 1546 GO TO 420 1547 345 HMX = ABS(TN) + ABS(H) 1548 IHIT = ABS(TN - TCRIT) .LE. 100.0D0*UROUND*HMX 1549 IF (IHIT) GO TO 400 1550 TNEXT = TN + H*(1.0D0 + 4.0D0*UROUND) 1551 IF ((TNEXT - TCRIT)*H .LE. 0.0D0) GO TO 250 1552 H = (TCRIT - TN)*(1.0D0 - 4.0D0*UROUND) 1553 JSTART = -2 1554 GO TO 250 1555 C ITASK = 5. See if TCRIT was reached and jump to exit. --------------- 1556 350 HMX = ABS(TN) + ABS(H) 1557 IHIT = ABS(TN - TCRIT) .LE. 100.0D0*UROUND*HMX 1558 C----------------------------------------------------------------------- 1559 C Block G. 1560 C The following block handles all successful returns from DLSODE. 1561 C If ITASK .NE. 1, Y is loaded from YH and T is set accordingly. 1562 C ISTATE is set to 2, and the optional outputs are loaded into the 1563 C work arrays before returning. 1564 C----------------------------------------------------------------------- 1565 400 DO 410 I = 1,N 1566 410 Y(I) = RWORK(I+LYH-1) 1567 T = TN 1568 IF (ITASK .NE. 4 .AND. ITASK .NE. 5) GO TO 420 1569 IF (IHIT) T = TCRIT 1570 420 ISTATE = 2 1571 RWORK(11) = HU 1572 RWORK(12) = H 1573 RWORK(13) = TN 1574 IWORK(11) = NST 1575 IWORK(12) = NFE 1576 IWORK(13) = NJE 1577 IWORK(14) = NQU 1578 IWORK(15) = NQ 1579 RETURN 1580 C----------------------------------------------------------------------- 1581 C Block H. 1582 C The following block handles all unsuccessful returns other than 1583 C those for illegal input. First the error message routine is called. 1584 C If there was an error test or convergence test failure, IMXER is set. 1585 C Then Y is loaded from YH and T is set to TN. The optional outputs 1586 C are loaded into the work arrays before returning. 1587 C----------------------------------------------------------------------- 1588 C The maximum number of steps was taken before reaching TOUT. ---------- 1589 500 MSG = 'DLSODE- At current T (=R1), MXSTEP (=I1) steps ' 1590 CALL XERRWD (MSG, 50, 201, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 1591 MSG = ' taken on this call before reaching TOUT ' 1592 CALL XERRWD (MSG, 50, 201, 0, 1, MXSTEP, 0, 1, TN, 0.0D0) 1593 ISTATE = -1 1594 GO TO 580 1595 C EWT(I) .LE. 0.0 for some I (not at start of problem). ---------------- 1596 510 EWTI = RWORK(LEWT+I-1) 1597 MSG = 'DLSODE- At T (=R1), EWT(I1) has become R2 .LE. 0.' 1598 CALL XERRWD (MSG, 50, 202, 0, 1, I, 0, 2, TN, EWTI) 1599 ISTATE = -6 1600 GO TO 580 1601 C Too much accuracy requested for machine precision. ------------------- 1602 520 MSG = 'DLSODE- At T (=R1), too much accuracy requested ' 1603 CALL XERRWD (MSG, 50, 203, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 1604 MSG = ' for precision of machine.. see TOLSF (=R2) ' 1605 CALL XERRWD (MSG, 50, 203, 0, 0, 0, 0, 2, TN, TOLSF) 1606 RWORK(14) = TOLSF 1607 ISTATE = -2 1608 GO TO 580 1609 C KFLAG = -1. Error test failed repeatedly or with ABS(H) = HMIN. ----- 1610 530 MSG = 'DLSODE- At T(=R1) and step size H(=R2), the error' 1611 CALL XERRWD (MSG, 50, 204, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 1612 MSG = ' test failed repeatedly or with ABS(H) = HMIN' 1613 CALL XERRWD (MSG, 50, 204, 0, 0, 0, 0, 2, TN, H) 1614 ISTATE = -4 1615 GO TO 560 1616 C KFLAG = -2. Convergence failed repeatedly or with ABS(H) = HMIN. ---- 1617 540 MSG = 'DLSODE- At T (=R1) and step size H (=R2), the ' 1618 CALL XERRWD (MSG, 50, 205, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 1619 MSG = ' corrector convergence failed repeatedly ' 1620 CALL XERRWD (MSG, 50, 205, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 1621 MSG = ' or with ABS(H) = HMIN ' 1622 CALL XERRWD (MSG, 30, 205, 0, 0, 0, 0, 2, TN, H) 1623 ISTATE = -5 1624 C Compute IMXER if relevant. ------------------------------------------- 1625 560 BIG = 0.0D0 1626 IMXER = 1 1627 DO 570 I = 1,N 1628 SIZE = ABS(RWORK(I+LACOR-1)*RWORK(I+LEWT-1)) 1629 IF (BIG .GE. SIZE) GO TO 570 1630 BIG = SIZE 1631 IMXER = I 1632 570 CONTINUE 1633 IWORK(16) = IMXER 1634 C Set Y vector, T, and optional outputs. ------------------------------- 1635 580 DO 590 I = 1,N 1636 590 Y(I) = RWORK(I+LYH-1) 1637 T = TN 1638 RWORK(11) = HU 1639 RWORK(12) = H 1640 RWORK(13) = TN 1641 IWORK(11) = NST 1642 IWORK(12) = NFE 1643 IWORK(13) = NJE 1644 IWORK(14) = NQU 1645 IWORK(15) = NQ 1646 RETURN 1647 C----------------------------------------------------------------------- 1648 C Block I. 1649 C The following block handles all error returns due to illegal input 1650 C (ISTATE = -3), as detected before calling the core integrator. 1651 C First the error message routine is called. If the illegal input 1652 C is a negative ISTATE, the run is aborted (apparent infinite loop). 1653 C----------------------------------------------------------------------- 1654 601 MSG = 'DLSODE- ISTATE (=I1) illegal ' 1655 CALL XERRWD (MSG, 30, 1, 0, 1, ISTATE, 0, 0, 0.0D0, 0.0D0) 1656 IF (ISTATE .LT. 0) GO TO 800 1657 GO TO 700 1658 602 MSG = 'DLSODE- ITASK (=I1) illegal ' 1659 CALL XERRWD (MSG, 30, 2, 0, 1, ITASK, 0, 0, 0.0D0, 0.0D0) 1660 GO TO 700 1661 603 MSG = 'DLSODE- ISTATE .GT. 1 but DLSODE not initialized ' 1662 CALL XERRWD (MSG, 50, 3, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 1663 GO TO 700 1664 604 MSG = 'DLSODE- NEQ (=I1) .LT. 1 ' 1665 CALL XERRWD (MSG, 30, 4, 0, 1, NEQ(1), 0, 0, 0.0D0, 0.0D0) 1666 GO TO 700 1667 605 MSG = 'DLSODE- ISTATE = 3 and NEQ increased (I1 to I2) ' 1668 CALL XERRWD (MSG, 50, 5, 0, 2, N, NEQ(1), 0, 0.0D0, 0.0D0) 1669 GO TO 700 1670 606 MSG = 'DLSODE- ITOL (=I1) illegal ' 1671 CALL XERRWD (MSG, 30, 6, 0, 1, ITOL, 0, 0, 0.0D0, 0.0D0) 1672 GO TO 700 1673 607 MSG = 'DLSODE- IOPT (=I1) illegal ' 1674 CALL XERRWD (MSG, 30, 7, 0, 1, IOPT, 0, 0, 0.0D0, 0.0D0) 1675 GO TO 700 1676 608 MSG = 'DLSODE- MF (=I1) illegal ' 1677 CALL XERRWD (MSG, 30, 8, 0, 1, MF, 0, 0, 0.0D0, 0.0D0) 1678 GO TO 700 1679 609 MSG = 'DLSODE- ML (=I1) illegal.. .LT.0 or .GE.NEQ (=I2)' 1680 CALL XERRWD (MSG, 50, 9, 0, 2, ML, NEQ(1), 0, 0.0D0, 0.0D0) 1681 GO TO 700 1682 610 MSG = 'DLSODE- MU (=I1) illegal.. .LT.0 or .GE.NEQ (=I2)' 1683 CALL XERRWD (MSG, 50, 10, 0, 2, MU, NEQ(1), 0, 0.0D0, 0.0D0) 1684 GO TO 700 1685 611 MSG = 'DLSODE- MAXORD (=I1) .LT. 0 ' 1686 CALL XERRWD (MSG, 30, 11, 0, 1, MAXORD, 0, 0, 0.0D0, 0.0D0) 1687 GO TO 700 1688 612 MSG = 'DLSODE- MXSTEP (=I1) .LT. 0 ' 1689 CALL XERRWD (MSG, 30, 12, 0, 1, MXSTEP, 0, 0, 0.0D0, 0.0D0) 1690 GO TO 700 1691 613 MSG = 'DLSODE- MXHNIL (=I1) .LT. 0 ' 1692 CALL XERRWD (MSG, 30, 13, 0, 1, MXHNIL, 0, 0, 0.0D0, 0.0D0) 1693 GO TO 700 1694 614 MSG = 'DLSODE- TOUT (=R1) behind T (=R2) ' 1695 CALL XERRWD (MSG, 40, 14, 0, 0, 0, 0, 2, TOUT, T) 1696 MSG = ' Integration direction is given by H0 (=R1) ' 1697 CALL XERRWD (MSG, 50, 14, 0, 0, 0, 0, 1, H0, 0.0D0) 1698 GO TO 700 1699 615 MSG = 'DLSODE- HMAX (=R1) .LT. 0.0 ' 1700 CALL XERRWD (MSG, 30, 15, 0, 0, 0, 0, 1, HMAX, 0.0D0) 1701 GO TO 700 1702 616 MSG = 'DLSODE- HMIN (=R1) .LT. 0.0 ' 1703 CALL XERRWD (MSG, 30, 16, 0, 0, 0, 0, 1, HMIN, 0.0D0) 1704 GO TO 700 1705 617 CONTINUE 1706 MSG='DLSODE- RWORK length needed, LENRW (=I1), exceeds LRW (=I2)' 1707 CALL XERRWD (MSG, 60, 17, 0, 2, LENRW, LRW, 0, 0.0D0, 0.0D0) 1708 GO TO 700 1709 618 CONTINUE 1710 MSG='DLSODE- IWORK length needed, LENIW (=I1), exceeds LIW (=I2)' 1711 CALL XERRWD (MSG, 60, 18, 0, 2, LENIW, LIW, 0, 0.0D0, 0.0D0) 1712 GO TO 700 1713 619 MSG = 'DLSODE- RTOL(I1) is R1 .LT. 0.0 ' 1714 CALL XERRWD (MSG, 40, 19, 0, 1, I, 0, 1, RTOLI, 0.0D0) 1715 GO TO 700 1716 620 MSG = 'DLSODE- ATOL(I1) is R1 .LT. 0.0 ' 1717 CALL XERRWD (MSG, 40, 20, 0, 1, I, 0, 1, ATOLI, 0.0D0) 1718 GO TO 700 1719 621 EWTI = RWORK(LEWT+I-1) 1720 MSG = 'DLSODE- EWT(I1) is R1 .LE. 0.0 ' 1721 CALL XERRWD (MSG, 40, 21, 0, 1, I, 0, 1, EWTI, 0.0D0) 1722 GO TO 700 1723 622 CONTINUE 1724 MSG='DLSODE- TOUT (=R1) too close to T(=R2) to start integration' 1725 CALL XERRWD (MSG, 60, 22, 0, 0, 0, 0, 2, TOUT, T) 1726 GO TO 700 1727 623 CONTINUE 1728 MSG='DLSODE- ITASK = I1 and TOUT (=R1) behind TCUR - HU (= R2) ' 1729 CALL XERRWD (MSG, 60, 23, 0, 1, ITASK, 0, 2, TOUT, TP) 1730 GO TO 700 1731 624 CONTINUE 1732 MSG='DLSODE- ITASK = 4 OR 5 and TCRIT (=R1) behind TCUR (=R2) ' 1733 CALL XERRWD (MSG, 60, 24, 0, 0, 0, 0, 2, TCRIT, TN) 1734 GO TO 700 1735 625 CONTINUE 1736 MSG='DLSODE- ITASK = 4 or 5 and TCRIT (=R1) behind TOUT (=R2) ' 1737 CALL XERRWD (MSG, 60, 25, 0, 0, 0, 0, 2, TCRIT, TOUT) 1738 GO TO 700 1739 626 MSG = 'DLSODE- At start of problem, too much accuracy ' 1740 CALL XERRWD (MSG, 50, 26, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 1741 MSG=' requested for precision of machine.. See TOLSF (=R1) ' 1742 CALL XERRWD (MSG, 60, 26, 0, 0, 0, 0, 1, TOLSF, 0.0D0) 1743 RWORK(14) = TOLSF 1744 GO TO 700 1745 627 MSG = 'DLSODE- Trouble in DINTDY. ITASK = I1, TOUT = R1' 1746 CALL XERRWD (MSG, 50, 27, 0, 1, ITASK, 0, 1, TOUT, 0.0D0) 1747 C 1748 700 ISTATE = -3 1749 RETURN 1750 C 1751 800 MSG = 'DLSODE- Run aborted.. apparent infinite loop ' 1752 CALL XERRWD (MSG, 50, 303, 2, 0, 0, 0, 0, 0.0D0, 0.0D0) 1753 RETURN 1754 C----------------------- END OF SUBROUTINE DLSODE ---------------------- 1755 END 1756 *DECK DLSODES 1757 SUBROUTINE DLSODES (F, NEQ, Y, T, TOUT, ITOL, RTOL, ATOL, ITASK, 1758 1 ISTATE, IOPT, RWORK, LRW, IWORK, LIW, JAC, MF) 1759 EXTERNAL F, JAC 1760 INTEGER NEQ, ITOL, ITASK, ISTATE, IOPT, LRW, IWORK, LIW, MF 1761 DOUBLE PRECISION Y, T, TOUT, RTOL, ATOL, RWORK 1762 DIMENSION NEQ(*), Y(*), RTOL(*), ATOL(*), RWORK(LRW), IWORK(LIW) 1763 C----------------------------------------------------------------------- 1764 C This is the 12 November 2003 version of 1765 C DLSODES: Livermore Solver for Ordinary Differential Equations 1766 C with general Sparse Jacobian matrix. 1767 C 1768 C This version is in double precision. 1769 C 1770 C DLSODES solves the initial value problem for stiff or nonstiff 1771 C systems of first order ODEs, 1772 C dy/dt = f(t,y) , or, in component form, 1773 C dy(i)/dt = f(i) = f(i,t,y(1),y(2),...,y(NEQ)) (i = 1,...,NEQ). 1774 C DLSODES is a variant of the DLSODE package, and is intended for 1775 C problems in which the Jacobian matrix df/dy has an arbitrary 1776 C sparse structure (when the problem is stiff). 1777 C 1778 C Authors: Alan C. Hindmarsh 1779 C Center for Applied Scientific Computing, L-561 1780 C Lawrence Livermore National Laboratory 1781 C Livermore, CA 94551 1782 C and 1783 C Andrew H. Sherman 1784 C J. S. Nolen and Associates 1785 C Houston, TX 77084 1786 C----------------------------------------------------------------------- 1787 C References: 1788 C 1. Alan C. Hindmarsh, ODEPACK, A Systematized Collection of ODE 1789 C Solvers, in Scientific Computing, R. S. Stepleman et al. (Eds.), 1790 C North-Holland, Amsterdam, 1983, pp. 55-64. 1791 C 1792 C 2. S. C. Eisenstat, M. C. Gursky, M. H. Schultz, and A. H. Sherman, 1793 C Yale Sparse Matrix Package: I. The Symmetric Codes, 1794 C Int. J. Num. Meth. Eng., 18 (1982), pp. 1145-1151. 1795 C 1796 C 3. S. C. Eisenstat, M. C. Gursky, M. H. Schultz, and A. H. Sherman, 1797 C Yale Sparse Matrix Package: II. The Nonsymmetric Codes, 1798 C Research Report No. 114, Dept. of Computer Sciences, Yale 1799 C University, 1977. 1800 C----------------------------------------------------------------------- 1801 C Summary of Usage. 1802 C 1803 C Communication between the user and the DLSODES package, for normal 1804 C situations, is summarized here. This summary describes only a subset 1805 C of the full set of options available. See the full description for 1806 C details, including optional communication, nonstandard options, 1807 C and instructions for special situations. See also the example 1808 C problem (with program and output) following this summary. 1809 C 1810 C A. First provide a subroutine of the form: 1811 C SUBROUTINE F (NEQ, T, Y, YDOT) 1812 C DOUBLE PRECISION T, Y(*), YDOT(*) 1813 C which supplies the vector function f by loading YDOT(i) with f(i). 1814 C 1815 C B. Next determine (or guess) whether or not the problem is stiff. 1816 C Stiffness occurs when the Jacobian matrix df/dy has an eigenvalue 1817 C whose real part is negative and large in magnitude, compared to the 1818 C reciprocal of the t span of interest. If the problem is nonstiff, 1819 C use a method flag MF = 10. If it is stiff, there are two standard 1820 C choices for the method flag, MF = 121 and MF = 222. In both cases, 1821 C DLSODES requires the Jacobian matrix in some form, and it treats this 1822 C matrix in general sparse form, with sparsity structure determined 1823 C internally. (For options where the user supplies the sparsity 1824 C structure, see the full description of MF below.) 1825 C 1826 C C. If the problem is stiff, you are encouraged to supply the Jacobian 1827 C directly (MF = 121), but if this is not feasible, DLSODES will 1828 C compute it internally by difference quotients (MF = 222). 1829 C If you are supplying the Jacobian, provide a subroutine of the form: 1830 C SUBROUTINE JAC (NEQ, T, Y, J, IAN, JAN, PDJ) 1831 C DOUBLE PRECISION T, Y(*), IAN(*), JAN(*), PDJ(*) 1832 C Here NEQ, T, Y, and J are input arguments, and the JAC routine is to 1833 C load the array PDJ (of length NEQ) with the J-th column of df/dy. 1834 C I.e., load PDJ(i) with df(i)/dy(J) for all relevant values of i. 1835 C The arguments IAN and JAN should be ignored for normal situations. 1836 C DLSODES will call the JAC routine with J = 1,2,...,NEQ. 1837 C Only nonzero elements need be loaded. Usually, a crude approximation 1838 C to df/dy, possibly with fewer nonzero elements, will suffice. 1839 C 1840 C D. Write a main program which calls Subroutine DLSODES once for 1841 C each point at which answers are desired. This should also provide 1842 C for possible use of logical unit 6 for output of error messages by 1843 C DLSODES. On the first call to DLSODES, supply arguments as follows: 1844 C F = name of subroutine for right-hand side vector f. 1845 C This name must be declared External in calling program. 1846 C NEQ = number of first order ODEs. 1847 C Y = array of initial values, of length NEQ. 1848 C T = the initial value of the independent variable t. 1849 C TOUT = first point where output is desired (.ne. T). 1850 C ITOL = 1 or 2 according as ATOL (below) is a scalar or array. 1851 C RTOL = relative tolerance parameter (scalar). 1852 C ATOL = absolute tolerance parameter (scalar or array). 1853 C The estimated local error in Y(i) will be controlled so as 1854 C to be roughly less (in magnitude) than 1855 C EWT(i) = RTOL*ABS(Y(i)) + ATOL if ITOL = 1, or 1856 C EWT(i) = RTOL*ABS(Y(i)) + ATOL(i) if ITOL = 2. 1857 C Thus the local error test passes if, in each component, 1858 C either the absolute error is less than ATOL (or ATOL(i)), 1859 C or the relative error is less than RTOL. 1860 C Use RTOL = 0.0 for pure absolute error control, and 1861 C use ATOL = 0.0 (or ATOL(i) = 0.0) for pure relative error 1862 C control. Caution: actual (global) errors may exceed these 1863 C local tolerances, so choose them conservatively. 1864 C ITASK = 1 for normal computation of output values of Y at t = TOUT. 1865 C ISTATE = integer flag (input and output). Set ISTATE = 1. 1866 C IOPT = 0 to indicate no optional inputs used. 1867 C RWORK = real work array of length at least: 1868 C 20 + 16*NEQ for MF = 10, 1869 C 20 + (2 + 1./LENRAT)*NNZ + (11 + 9./LENRAT)*NEQ 1870 C for MF = 121 or 222, 1871 C where: 1872 C NNZ = the number of nonzero elements in the sparse 1873 C Jacobian (if this is unknown, use an estimate), and 1874 C LENRAT = the real to integer wordlength ratio (usually 1 in 1875 C single precision and 2 in double precision). 1876 C In any case, the required size of RWORK cannot generally 1877 C be predicted in advance if MF = 121 or 222, and the value 1878 C above is a rough estimate of a crude lower bound. Some 1879 C experimentation with this size may be necessary. 1880 C (When known, the correct required length is an optional 1881 C output, available in IWORK(17).) 1882 C LRW = declared length of RWORK (in user dimension). 1883 C IWORK = integer work array of length at least 30. 1884 C LIW = declared length of IWORK (in user dimension). 1885 C JAC = name of subroutine for Jacobian matrix (MF = 121). 1886 C If used, this name must be declared External in calling 1887 C program. If not used, pass a dummy name. 1888 C MF = method flag. Standard values are: 1889 C 10 for nonstiff (Adams) method, no Jacobian used 1890 C 121 for stiff (BDF) method, user-supplied sparse Jacobian 1891 C 222 for stiff method, internally generated sparse Jacobian 1892 C Note that the main program must declare arrays Y, RWORK, IWORK, 1893 C and possibly ATOL. 1894 C 1895 C E. The output from the first call (or any call) is: 1896 C Y = array of computed values of y(t) vector. 1897 C T = corresponding value of independent variable (normally TOUT). 1898 C ISTATE = 2 if DLSODES was successful, negative otherwise. 1899 C -1 means excess work done on this call (perhaps wrong MF). 1900 C -2 means excess accuracy requested (tolerances too small). 1901 C -3 means illegal input detected (see printed message). 1902 C -4 means repeated error test failures (check all inputs). 1903 C -5 means repeated convergence failures (perhaps bad Jacobian 1904 C supplied or wrong choice of MF or tolerances). 1905 C -6 means error weight became zero during problem. (Solution 1906 C component i vanished, and ATOL or ATOL(i) = 0.) 1907 C -7 means a fatal error return flag came from sparse solver 1908 C CDRV by way of DPRJS or DSOLSS. Should never happen. 1909 C A return with ISTATE = -1, -4, or -5 may result from using 1910 C an inappropriate sparsity structure, one that is quite 1911 C different from the initial structure. Consider calling 1912 C DLSODES again with ISTATE = 3 to force the structure to be 1913 C reevaluated. See the full description of ISTATE below. 1914 C 1915 C F. To continue the integration after a successful return, simply 1916 C reset TOUT and call DLSODES again. No other parameters need be reset. 1917 C 1918 C----------------------------------------------------------------------- 1919 C Example Problem. 1920 C 1921 C The following is a simple example problem, with the coding 1922 C needed for its solution by DLSODES. The problem is from chemical 1923 C kinetics, and consists of the following 12 rate equations: 1924 C dy1/dt = -rk1*y1 1925 C dy2/dt = rk1*y1 + rk11*rk14*y4 + rk19*rk14*y5 1926 C - rk3*y2*y3 - rk15*y2*y12 - rk2*y2 1927 C dy3/dt = rk2*y2 - rk5*y3 - rk3*y2*y3 - rk7*y10*y3 1928 C + rk11*rk14*y4 + rk12*rk14*y6 1929 C dy4/dt = rk3*y2*y3 - rk11*rk14*y4 - rk4*y4 1930 C dy5/dt = rk15*y2*y12 - rk19*rk14*y5 - rk16*y5 1931 C dy6/dt = rk7*y10*y3 - rk12*rk14*y6 - rk8*y6 1932 C dy7/dt = rk17*y10*y12 - rk20*rk14*y7 - rk18*y7 1933 C dy8/dt = rk9*y10 - rk13*rk14*y8 - rk10*y8 1934 C dy9/dt = rk4*y4 + rk16*y5 + rk8*y6 + rk18*y7 1935 C dy10/dt = rk5*y3 + rk12*rk14*y6 + rk20*rk14*y7 1936 C + rk13*rk14*y8 - rk7*y10*y3 - rk17*y10*y12 1937 C - rk6*y10 - rk9*y10 1938 C dy11/dt = rk10*y8 1939 C dy12/dt = rk6*y10 + rk19*rk14*y5 + rk20*rk14*y7 1940 C - rk15*y2*y12 - rk17*y10*y12 1941 C 1942 C with rk1 = rk5 = 0.1, rk4 = rk8 = rk16 = rk18 = 2.5, 1943 C rk10 = 5.0, rk2 = rk6 = 10.0, rk14 = 30.0, 1944 C rk3 = rk7 = rk9 = rk11 = rk12 = rk13 = rk19 = rk20 = 50.0, 1945 C rk15 = rk17 = 100.0. 1946 C 1947 C The t interval is from 0 to 1000, and the initial conditions 1948 C are y1 = 1, y2 = y3 = ... = y12 = 0. The problem is stiff. 1949 C 1950 C The following coding solves this problem with DLSODES, using MF = 121 1951 C and printing results at t = .1, 1., 10., 100., 1000. It uses 1952 C ITOL = 1 and mixed relative/absolute tolerance controls. 1953 C During the run and at the end, statistical quantities of interest 1954 C are printed (see optional outputs in the full description below). 1955 C 1956 C EXTERNAL FEX, JEX 1957 C DOUBLE PRECISION ATOL, RTOL, RWORK, T, TOUT, Y 1958 C DIMENSION Y(12), RWORK(500), IWORK(30) 1959 C DATA LRW/500/, LIW/30/ 1960 C NEQ = 12 1961 C DO 10 I = 1,NEQ 1962 C 10 Y(I) = 0.0D0 1963 C Y(1) = 1.0D0 1964 C T = 0.0D0 1965 C TOUT = 0.1D0 1966 C ITOL = 1 1967 C RTOL = 1.0D-4 1968 C ATOL = 1.0D-6 1969 C ITASK = 1 1970 C ISTATE = 1 1971 C IOPT = 0 1972 C MF = 121 1973 C DO 40 IOUT = 1,5 1974 C CALL DLSODES (FEX, NEQ, Y, T, TOUT, ITOL, RTOL, ATOL, 1975 C 1 ITASK, ISTATE, IOPT, RWORK, LRW, IWORK, LIW, JEX, MF) 1976 C WRITE(6,30)T,IWORK(11),RWORK(11),(Y(I),I=1,NEQ) 1977 C 30 FORMAT(//' At t =',D11.3,4X, 1978 C 1 ' No. steps =',I5,4X,' Last step =',D11.3/ 1979 C 2 ' Y array = ',4D14.5/13X,4D14.5/13X,4D14.5) 1980 C IF (ISTATE .LT. 0) GO TO 80 1981 C TOUT = TOUT*10.0D0 1982 C 40 CONTINUE 1983 C LENRW = IWORK(17) 1984 C LENIW = IWORK(18) 1985 C NST = IWORK(11) 1986 C NFE = IWORK(12) 1987 C NJE = IWORK(13) 1988 C NLU = IWORK(21) 1989 C NNZ = IWORK(19) 1990 C NNZLU = IWORK(25) + IWORK(26) + NEQ 1991 C WRITE (6,70) LENRW,LENIW,NST,NFE,NJE,NLU,NNZ,NNZLU 1992 C 70 FORMAT(//' Required RWORK size =',I4,' IWORK size =',I4/ 1993 C 1 ' No. steps =',I4,' No. f-s =',I4,' No. J-s =',I4, 1994 C 2 ' No. LU-s =',I4/' No. of nonzeros in J =',I5, 1995 C 3 ' No. of nonzeros in LU =',I5) 1996 C STOP 1997 C 80 WRITE(6,90)ISTATE 1998 C 90 FORMAT(///' Error halt.. ISTATE =',I3) 1999 C STOP 2000 C END 2001 C 2002 C SUBROUTINE FEX (NEQ, T, Y, YDOT) 2003 C DOUBLE PRECISION T, Y, YDOT 2004 C DOUBLE PRECISION RK1, RK2, RK3, RK4, RK5, RK6, RK7, RK8, RK9, 2005 C 1 RK10, RK11, RK12, RK13, RK14, RK15, RK16, RK17 2006 C DIMENSION Y(12), YDOT(12) 2007 C DATA RK1/0.1D0/, RK2/10.0D0/, RK3/50.0D0/, RK4/2.5D0/, RK5/0.1D0/, 2008 C 1 RK6/10.0D0/, RK7/50.0D0/, RK8/2.5D0/, RK9/50.0D0/, RK10/5.0D0/, 2009 C 2 RK11/50.0D0/, RK12/50.0D0/, RK13/50.0D0/, RK14/30.0D0/, 2010 C 3 RK15/100.0D0/, RK16/2.5D0/, RK17/100.0D0/, RK18/2.5D0/, 2011 C 4 RK19/50.0D0/, RK20/50.0D0/ 2012 C YDOT(1) = -RK1*Y(1) 2013 C YDOT(2) = RK1*Y(1) + RK11*RK14*Y(4) + RK19*RK14*Y(5) 2014 C 1 - RK3*Y(2)*Y(3) - RK15*Y(2)*Y(12) - RK2*Y(2) 2015 C YDOT(3) = RK2*Y(2) - RK5*Y(3) - RK3*Y(2)*Y(3) - RK7*Y(10)*Y(3) 2016 C 1 + RK11*RK14*Y(4) + RK12*RK14*Y(6) 2017 C YDOT(4) = RK3*Y(2)*Y(3) - RK11*RK14*Y(4) - RK4*Y(4) 2018 C YDOT(5) = RK15*Y(2)*Y(12) - RK19*RK14*Y(5) - RK16*Y(5) 2019 C YDOT(6) = RK7*Y(10)*Y(3) - RK12*RK14*Y(6) - RK8*Y(6) 2020 C YDOT(7) = RK17*Y(10)*Y(12) - RK20*RK14*Y(7) - RK18*Y(7) 2021 C YDOT(8) = RK9*Y(10) - RK13*RK14*Y(8) - RK10*Y(8) 2022 C YDOT(9) = RK4*Y(4) + RK16*Y(5) + RK8*Y(6) + RK18*Y(7) 2023 C YDOT(10) = RK5*Y(3) + RK12*RK14*Y(6) + RK20*RK14*Y(7) 2024 C 1 + RK13*RK14*Y(8) - RK7*Y(10)*Y(3) - RK17*Y(10)*Y(12) 2025 C 2 - RK6*Y(10) - RK9*Y(10) 2026 C YDOT(11) = RK10*Y(8) 2027 C YDOT(12) = RK6*Y(10) + RK19*RK14*Y(5) + RK20*RK14*Y(7) 2028 C 1 - RK15*Y(2)*Y(12) - RK17*Y(10)*Y(12) 2029 C RETURN 2030 C END 2031 C 2032 C SUBROUTINE JEX (NEQ, T, Y, J, IA, JA, PDJ) 2033 C DOUBLE PRECISION T, Y, PDJ 2034 C DOUBLE PRECISION RK1, RK2, RK3, RK4, RK5, RK6, RK7, RK8, RK9, 2035 C 1 RK10, RK11, RK12, RK13, RK14, RK15, RK16, RK17 2036 C DIMENSION Y(12), IA(*), JA(*), PDJ(12) 2037 C DATA RK1/0.1D0/, RK2/10.0D0/, RK3/50.0D0/, RK4/2.5D0/, RK5/0.1D0/, 2038 C 1 RK6/10.0D0/, RK7/50.0D0/, RK8/2.5D0/, RK9/50.0D0/, RK10/5.0D0/, 2039 C 2 RK11/50.0D0/, RK12/50.0D0/, RK13/50.0D0/, RK14/30.0D0/, 2040 C 3 RK15/100.0D0/, RK16/2.5D0/, RK17/100.0D0/, RK18/2.5D0/, 2041 C 4 RK19/50.0D0/, RK20/50.0D0/ 2042 C GO TO (1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12), J 2043 C 1 PDJ(1) = -RK1 2044 C PDJ(2) = RK1 2045 C RETURN 2046 C 2 PDJ(2) = -RK3*Y(3) - RK15*Y(12) - RK2 2047 C PDJ(3) = RK2 - RK3*Y(3) 2048 C PDJ(4) = RK3*Y(3) 2049 C PDJ(5) = RK15*Y(12) 2050 C PDJ(12) = -RK15*Y(12) 2051 C RETURN 2052 C 3 PDJ(2) = -RK3*Y(2) 2053 C PDJ(3) = -RK5 - RK3*Y(2) - RK7*Y(10) 2054 C PDJ(4) = RK3*Y(2) 2055 C PDJ(6) = RK7*Y(10) 2056 C PDJ(10) = RK5 - RK7*Y(10) 2057 C RETURN 2058 C 4 PDJ(2) = RK11*RK14 2059 C PDJ(3) = RK11*RK14 2060 C PDJ(4) = -RK11*RK14 - RK4 2061 C PDJ(9) = RK4 2062 C RETURN 2063 C 5 PDJ(2) = RK19*RK14 2064 C PDJ(5) = -RK19*RK14 - RK16 2065 C PDJ(9) = RK16 2066 C PDJ(12) = RK19*RK14 2067 C RETURN 2068 C 6 PDJ(3) = RK12*RK14 2069 C PDJ(6) = -RK12*RK14 - RK8 2070 C PDJ(9) = RK8 2071 C PDJ(10) = RK12*RK14 2072 C RETURN 2073 C 7 PDJ(7) = -RK20*RK14 - RK18 2074 C PDJ(9) = RK18 2075 C PDJ(10) = RK20*RK14 2076 C PDJ(12) = RK20*RK14 2077 C RETURN 2078 C 8 PDJ(8) = -RK13*RK14 - RK10 2079 C PDJ(10) = RK13*RK14 2080 C PDJ(11) = RK10 2081 C 9 RETURN 2082 C 10 PDJ(3) = -RK7*Y(3) 2083 C PDJ(6) = RK7*Y(3) 2084 C PDJ(7) = RK17*Y(12) 2085 C PDJ(8) = RK9 2086 C PDJ(10) = -RK7*Y(3) - RK17*Y(12) - RK6 - RK9 2087 C PDJ(12) = RK6 - RK17*Y(12) 2088 C 11 RETURN 2089 C 12 PDJ(2) = -RK15*Y(2) 2090 C PDJ(5) = RK15*Y(2) 2091 C PDJ(7) = RK17*Y(10) 2092 C PDJ(10) = -RK17*Y(10) 2093 C PDJ(12) = -RK15*Y(2) - RK17*Y(10) 2094 C RETURN 2095 C END 2096 C 2097 C The output of this program (on a Cray-1 in single precision) 2098 C is as follows: 2099 C 2100 C 2101 C At t = 1.000e-01 No. steps = 12 Last step = 1.515e-02 2102 C Y array = 9.90050e-01 6.28228e-03 3.65313e-03 7.51934e-07 2103 C 1.12167e-09 1.18458e-09 1.77291e-12 3.26476e-07 2104 C 5.46720e-08 9.99500e-06 4.48483e-08 2.76398e-06 2105 C 2106 C 2107 C At t = 1.000e+00 No. steps = 33 Last step = 7.880e-02 2108 C Y array = 9.04837e-01 9.13105e-03 8.20622e-02 2.49177e-05 2109 C 1.85055e-06 1.96797e-06 1.46157e-07 2.39557e-05 2110 C 3.26306e-05 7.21621e-04 5.06433e-05 3.05010e-03 2111 C 2112 C 2113 C At t = 1.000e+01 No. steps = 48 Last step = 1.239e+00 2114 C Y array = 3.67876e-01 3.68958e-03 3.65133e-01 4.48325e-05 2115 C 6.10798e-05 4.33148e-05 5.90211e-05 1.18449e-04 2116 C 3.15235e-03 3.56531e-03 4.15520e-03 2.48741e-01 2117 C 2118 C 2119 C At t = 1.000e+02 No. steps = 91 Last step = 3.764e+00 2120 C Y array = 4.44981e-05 4.42666e-07 4.47273e-04 -3.53257e-11 2121 C 2.81577e-08 -9.67741e-11 2.77615e-07 1.45322e-07 2122 C 1.56230e-02 4.37394e-06 1.60104e-02 9.52246e-01 2123 C 2124 C 2125 C At t = 1.000e+03 No. steps = 111 Last step = 4.156e+02 2126 C Y array = -2.65492e-13 2.60539e-14 -8.59563e-12 6.29355e-14 2127 C -1.78066e-13 5.71471e-13 -1.47561e-12 4.58078e-15 2128 C 1.56314e-02 1.37878e-13 1.60184e-02 9.52719e-01 2129 C 2130 C 2131 C Required RWORK size = 442 IWORK size = 30 2132 C No. steps = 111 No. f-s = 142 No. J-s = 2 No. LU-s = 20 2133 C No. of nonzeros in J = 44 No. of nonzeros in LU = 50 2134 C 2135 C----------------------------------------------------------------------- 2136 C Full Description of User Interface to DLSODES. 2137 C 2138 C The user interface to DLSODES consists of the following parts. 2139 C 2140 C 1. The call sequence to Subroutine DLSODES, which is a driver 2141 C routine for the solver. This includes descriptions of both 2142 C the call sequence arguments and of user-supplied routines. 2143 C Following these descriptions is a description of 2144 C optional inputs available through the call sequence, and then 2145 C a description of optional outputs (in the work arrays). 2146 C 2147 C 2. Descriptions of other routines in the DLSODES package that may be 2148 C (optionally) called by the user. These provide the ability to 2149 C alter error message handling, save and restore the internal 2150 C Common, and obtain specified derivatives of the solution y(t). 2151 C 2152 C 3. Descriptions of Common blocks to be declared in overlay 2153 C or similar environments, or to be saved when doing an interrupt 2154 C of the problem and continued solution later. 2155 C 2156 C 4. Description of two routines in the DLSODES package, either of 2157 C which the user may replace with his/her own version, if desired. 2158 C These relate to the measurement of errors. 2159 C 2160 C----------------------------------------------------------------------- 2161 C Part 1. Call Sequence. 2162 C 2163 C The call sequence parameters used for input only are 2164 C F, NEQ, TOUT, ITOL, RTOL, ATOL, ITASK, IOPT, LRW, LIW, JAC, MF, 2165 C and those used for both input and output are 2166 C Y, T, ISTATE. 2167 C The work arrays RWORK and IWORK are also used for conditional and 2168 C optional inputs and optional outputs. (The term output here refers 2169 C to the return from Subroutine DLSODES to the user's calling program.) 2170 C 2171 C The legality of input parameters will be thoroughly checked on the 2172 C initial call for the problem, but not checked thereafter unless a 2173 C change in input parameters is flagged by ISTATE = 3 on input. 2174 C 2175 C The descriptions of the call arguments are as follows. 2176 C 2177 C F = the name of the user-supplied subroutine defining the 2178 C ODE system. The system must be put in the first-order 2179 C form dy/dt = f(t,y), where f is a vector-valued function 2180 C of the scalar t and the vector y. Subroutine F is to 2181 C compute the function f. It is to have the form 2182 C SUBROUTINE F (NEQ, T, Y, YDOT) 2183 C DOUBLE PRECISION T, Y(*), YDOT(*) 2184 C where NEQ, T, and Y are input, and the array YDOT = f(t,y) 2185 C is output. Y and YDOT are arrays of length NEQ. 2186 C Subroutine F should not alter y(1),...,y(NEQ). 2187 C F must be declared External in the calling program. 2188 C 2189 C Subroutine F may access user-defined quantities in 2190 C NEQ(2),... and/or in Y(NEQ(1)+1),... if NEQ is an array 2191 C (dimensioned in F) and/or Y has length exceeding NEQ(1). 2192 C See the descriptions of NEQ and Y below. 2193 C 2194 C If quantities computed in the F routine are needed 2195 C externally to DLSODES, an extra call to F should be made 2196 C for this purpose, for consistent and accurate results. 2197 C If only the derivative dy/dt is needed, use DINTDY instead. 2198 C 2199 C NEQ = the size of the ODE system (number of first order 2200 C ordinary differential equations). Used only for input. 2201 C NEQ may be decreased, but not increased, during the problem. 2202 C If NEQ is decreased (with ISTATE = 3 on input), the 2203 C remaining components of Y should be left undisturbed, if 2204 C these are to be accessed in F and/or JAC. 2205 C 2206 C Normally, NEQ is a scalar, and it is generally referred to 2207 C as a scalar in this user interface description. However, 2208 C NEQ may be an array, with NEQ(1) set to the system size. 2209 C (The DLSODES package accesses only NEQ(1).) In either case, 2210 C this parameter is passed as the NEQ argument in all calls 2211 C to F and JAC. Hence, if it is an array, locations 2212 C NEQ(2),... may be used to store other integer data and pass 2213 C it to F and/or JAC. Subroutines F and/or JAC must include 2214 C NEQ in a Dimension statement in that case. 2215 C 2216 C Y = a real array for the vector of dependent variables, of 2217 C length NEQ or more. Used for both input and output on the 2218 C first call (ISTATE = 1), and only for output on other calls. 2219 C on the first call, Y must contain the vector of initial 2220 C values. On output, Y contains the computed solution vector, 2221 C evaluated at T. If desired, the Y array may be used 2222 C for other purposes between calls to the solver. 2223 C 2224 C This array is passed as the Y argument in all calls to 2225 C F and JAC. Hence its length may exceed NEQ, and locations 2226 C Y(NEQ+1),... may be used to store other real data and 2227 C pass it to F and/or JAC. (The DLSODES package accesses only 2228 C Y(1),...,Y(NEQ).) 2229 C 2230 C T = the independent variable. On input, T is used only on the 2231 C first call, as the initial point of the integration. 2232 C on output, after each call, T is the value at which a 2233 C computed solution Y is evaluated (usually the same as TOUT). 2234 C On an error return, T is the farthest point reached. 2235 C 2236 C TOUT = the next value of t at which a computed solution is desired. 2237 C Used only for input. 2238 C 2239 C When starting the problem (ISTATE = 1), TOUT may be equal 2240 C to T for one call, then should .ne. T for the next call. 2241 C For the initial T, an input value of TOUT .ne. T is used 2242 C in order to determine the direction of the integration 2243 C (i.e. the algebraic sign of the step sizes) and the rough 2244 C scale of the problem. Integration in either direction 2245 C (forward or backward in t) is permitted. 2246 C 2247 C If ITASK = 2 or 5 (one-step modes), TOUT is ignored after 2248 C the first call (i.e. the first call with TOUT .ne. T). 2249 C Otherwise, TOUT is required on every call. 2250 C 2251 C If ITASK = 1, 3, or 4, the values of TOUT need not be 2252 C monotone, but a value of TOUT which backs up is limited 2253 C to the current internal T interval, whose endpoints are 2254 C TCUR - HU and TCUR (see optional outputs, below, for 2255 C TCUR and HU). 2256 C 2257 C ITOL = an indicator for the type of error control. See 2258 C description below under ATOL. Used only for input. 2259 C 2260 C RTOL = a relative error tolerance parameter, either a scalar or 2261 C an array of length NEQ. See description below under ATOL. 2262 C Input only. 2263 C 2264 C ATOL = an absolute error tolerance parameter, either a scalar or 2265 C an array of length NEQ. Input only. 2266 C 2267 C The input parameters ITOL, RTOL, and ATOL determine 2268 C the error control performed by the solver. The solver will 2269 C control the vector E = (E(i)) of estimated local errors 2270 C in y, according to an inequality of the form 2271 C RMS-norm of ( E(i)/EWT(i) ) .le. 1, 2272 C where EWT(i) = RTOL(i)*ABS(Y(i)) + ATOL(i), 2273 C and the RMS-norm (root-mean-square norm) here is 2274 C RMS-norm(v) = SQRT(sum v(i)**2 / NEQ). Here EWT = (EWT(i)) 2275 C is a vector of weights which must always be positive, and 2276 C the values of RTOL and ATOL should all be non-negative. 2277 C The following table gives the types (scalar/array) of 2278 C RTOL and ATOL, and the corresponding form of EWT(i). 2279 C 2280 C ITOL RTOL ATOL EWT(i) 2281 C 1 scalar scalar RTOL*ABS(Y(i)) + ATOL 2282 C 2 scalar array RTOL*ABS(Y(i)) + ATOL(i) 2283 C 3 array scalar RTOL(i)*ABS(Y(i)) + ATOL 2284 C 4 array array RTOL(i)*ABS(Y(i)) + ATOL(i) 2285 C 2286 C When either of these parameters is a scalar, it need not 2287 C be dimensioned in the user's calling program. 2288 C 2289 C If none of the above choices (with ITOL, RTOL, and ATOL 2290 C fixed throughout the problem) is suitable, more general 2291 C error controls can be obtained by substituting 2292 C user-supplied routines for the setting of EWT and/or for 2293 C the norm calculation. See Part 4 below. 2294 C 2295 C If global errors are to be estimated by making a repeated 2296 C run on the same problem with smaller tolerances, then all 2297 C components of RTOL and ATOL (i.e. of EWT) should be scaled 2298 C down uniformly. 2299 C 2300 C ITASK = an index specifying the task to be performed. 2301 C Input only. ITASK has the following values and meanings. 2302 C 1 means normal computation of output values of y(t) at 2303 C t = TOUT (by overshooting and interpolating). 2304 C 2 means take one step only and return. 2305 C 3 means stop at the first internal mesh point at or 2306 C beyond t = TOUT and return. 2307 C 4 means normal computation of output values of y(t) at 2308 C t = TOUT but without overshooting t = TCRIT. 2309 C TCRIT must be input as RWORK(1). TCRIT may be equal to 2310 C or beyond TOUT, but not behind it in the direction of 2311 C integration. This option is useful if the problem 2312 C has a singularity at or beyond t = TCRIT. 2313 C 5 means take one step, without passing TCRIT, and return. 2314 C TCRIT must be input as RWORK(1). 2315 C 2316 C Note: If ITASK = 4 or 5 and the solver reaches TCRIT 2317 C (within roundoff), it will return T = TCRIT (exactly) to 2318 C indicate this (unless ITASK = 4 and TOUT comes before TCRIT, 2319 C in which case answers at t = TOUT are returned first). 2320 C 2321 C ISTATE = an index used for input and output to specify the 2322 C the state of the calculation. 2323 C 2324 C On input, the values of ISTATE are as follows. 2325 C 1 means this is the first call for the problem 2326 C (initializations will be done). See note below. 2327 C 2 means this is not the first call, and the calculation 2328 C is to continue normally, with no change in any input 2329 C parameters except possibly TOUT and ITASK. 2330 C (If ITOL, RTOL, and/or ATOL are changed between calls 2331 C with ISTATE = 2, the new values will be used but not 2332 C tested for legality.) 2333 C 3 means this is not the first call, and the 2334 C calculation is to continue normally, but with 2335 C a change in input parameters other than 2336 C TOUT and ITASK. Changes are allowed in 2337 C NEQ, ITOL, RTOL, ATOL, IOPT, LRW, LIW, MF, 2338 C the conditional inputs IA and JA, 2339 C and any of the optional inputs except H0. 2340 C In particular, if MITER = 1 or 2, a call with ISTATE = 3 2341 C will cause the sparsity structure of the problem to be 2342 C recomputed (or reread from IA and JA if MOSS = 0). 2343 C Note: a preliminary call with TOUT = T is not counted 2344 C as a first call here, as no initialization or checking of 2345 C input is done. (Such a call is sometimes useful for the 2346 C purpose of outputting the initial conditions.) 2347 C Thus the first call for which TOUT .ne. T requires 2348 C ISTATE = 1 on input. 2349 C 2350 C On output, ISTATE has the following values and meanings. 2351 C 1 means nothing was done; TOUT = T and ISTATE = 1 on input. 2352 C 2 means the integration was performed successfully. 2353 C -1 means an excessive amount of work (more than MXSTEP 2354 C steps) was done on this call, before completing the 2355 C requested task, but the integration was otherwise 2356 C successful as far as T. (MXSTEP is an optional input 2357 C and is normally 500.) To continue, the user may 2358 C simply reset ISTATE to a value .gt. 1 and call again 2359 C (the excess work step counter will be reset to 0). 2360 C In addition, the user may increase MXSTEP to avoid 2361 C this error return (see below on optional inputs). 2362 C -2 means too much accuracy was requested for the precision 2363 C of the machine being used. This was detected before 2364 C completing the requested task, but the integration 2365 C was successful as far as T. To continue, the tolerance 2366 C parameters must be reset, and ISTATE must be set 2367 C to 3. The optional output TOLSF may be used for this 2368 C purpose. (Note: If this condition is detected before 2369 C taking any steps, then an illegal input return 2370 C (ISTATE = -3) occurs instead.) 2371 C -3 means illegal input was detected, before taking any 2372 C integration steps. See written message for details. 2373 C Note: If the solver detects an infinite loop of calls 2374 C to the solver with illegal input, it will cause 2375 C the run to stop. 2376 C -4 means there were repeated error test failures on 2377 C one attempted step, before completing the requested 2378 C task, but the integration was successful as far as T. 2379 C The problem may have a singularity, or the input 2380 C may be inappropriate. 2381 C -5 means there were repeated convergence test failures on 2382 C one attempted step, before completing the requested 2383 C task, but the integration was successful as far as T. 2384 C This may be caused by an inaccurate Jacobian matrix, 2385 C if one is being used. 2386 C -6 means EWT(i) became zero for some i during the 2387 C integration. Pure relative error control (ATOL(i)=0.0) 2388 C was requested on a variable which has now vanished. 2389 C The integration was successful as far as T. 2390 C -7 means a fatal error return flag came from the sparse 2391 C solver CDRV by way of DPRJS or DSOLSS (numerical 2392 C factorization or backsolve). This should never happen. 2393 C The integration was successful as far as T. 2394 C 2395 C Note: an error return with ISTATE = -1, -4, or -5 and with 2396 C MITER = 1 or 2 may mean that the sparsity structure of the 2397 C problem has changed significantly since it was last 2398 C determined (or input). In that case, one can attempt to 2399 C complete the integration by setting ISTATE = 3 on the next 2400 C call, so that a new structure determination is done. 2401 C 2402 C Note: since the normal output value of ISTATE is 2, 2403 C it does not need to be reset for normal continuation. 2404 C Also, since a negative input value of ISTATE will be 2405 C regarded as illegal, a negative output value requires the 2406 C user to change it, and possibly other inputs, before 2407 C calling the solver again. 2408 C 2409 C IOPT = an integer flag to specify whether or not any optional 2410 C inputs are being used on this call. Input only. 2411 C The optional inputs are listed separately below. 2412 C IOPT = 0 means no optional inputs are being used. 2413 C Default values will be used in all cases. 2414 C IOPT = 1 means one or more optional inputs are being used. 2415 C 2416 C RWORK = a work array used for a mixture of real (double precision) 2417 C and integer work space. 2418 C The length of RWORK (in real words) must be at least 2419 C 20 + NYH*(MAXORD + 1) + 3*NEQ + LWM where 2420 C NYH = the initial value of NEQ, 2421 C MAXORD = 12 (if METH = 1) or 5 (if METH = 2) (unless a 2422 C smaller value is given as an optional input), 2423 C LWM = 0 if MITER = 0, 2424 C LWM = 2*NNZ + 2*NEQ + (NNZ+9*NEQ)/LENRAT if MITER = 1, 2425 C LWM = 2*NNZ + 2*NEQ + (NNZ+10*NEQ)/LENRAT if MITER = 2, 2426 C LWM = NEQ + 2 if MITER = 3. 2427 C In the above formulas, 2428 C NNZ = number of nonzero elements in the Jacobian matrix. 2429 C LENRAT = the real to integer wordlength ratio (usually 1 in 2430 C single precision and 2 in double precision). 2431 C (See the MF description for METH and MITER.) 2432 C Thus if MAXORD has its default value and NEQ is constant, 2433 C the minimum length of RWORK is: 2434 C 20 + 16*NEQ for MF = 10, 2435 C 20 + 16*NEQ + LWM for MF = 11, 111, 211, 12, 112, 212, 2436 C 22 + 17*NEQ for MF = 13, 2437 C 20 + 9*NEQ for MF = 20, 2438 C 20 + 9*NEQ + LWM for MF = 21, 121, 221, 22, 122, 222, 2439 C 22 + 10*NEQ for MF = 23. 2440 C If MITER = 1 or 2, the above formula for LWM is only a 2441 C crude lower bound. The required length of RWORK cannot 2442 C be readily predicted in general, as it depends on the 2443 C sparsity structure of the problem. Some experimentation 2444 C may be necessary. 2445 C 2446 C The first 20 words of RWORK are reserved for conditional 2447 C and optional inputs and optional outputs. 2448 C 2449 C The following word in RWORK is a conditional input: 2450 C RWORK(1) = TCRIT = critical value of t which the solver 2451 C is not to overshoot. Required if ITASK is 2452 C 4 or 5, and ignored otherwise. (See ITASK.) 2453 C 2454 C LRW = the length of the array RWORK, as declared by the user. 2455 C (This will be checked by the solver.) 2456 C 2457 C IWORK = an integer work array. The length of IWORK must be at least 2458 C 31 + NEQ + NNZ if MOSS = 0 and MITER = 1 or 2, or 2459 C 30 otherwise. 2460 C (NNZ is the number of nonzero elements in df/dy.) 2461 C 2462 C In DLSODES, IWORK is used only for conditional and 2463 C optional inputs and optional outputs. 2464 C 2465 C The following two blocks of words in IWORK are conditional 2466 C inputs, required if MOSS = 0 and MITER = 1 or 2, but not 2467 C otherwise (see the description of MF for MOSS). 2468 C IWORK(30+j) = IA(j) (j=1,...,NEQ+1) 2469 C IWORK(31+NEQ+k) = JA(k) (k=1,...,NNZ) 2470 C The two arrays IA and JA describe the sparsity structure 2471 C to be assumed for the Jacobian matrix. JA contains the row 2472 C indices where nonzero elements occur, reading in columnwise 2473 C order, and IA contains the starting locations in JA of the 2474 C descriptions of columns 1,...,NEQ, in that order, with 2475 C IA(1) = 1. Thus, for each column index j = 1,...,NEQ, the 2476 C values of the row index i in column j where a nonzero 2477 C element may occur are given by 2478 C i = JA(k), where IA(j) .le. k .lt. IA(j+1). 2479 C If NNZ is the total number of nonzero locations assumed, 2480 C then the length of the JA array is NNZ, and IA(NEQ+1) must 2481 C be NNZ + 1. Duplicate entries are not allowed. 2482 C 2483 C LIW = the length of the array IWORK, as declared by the user. 2484 C (This will be checked by the solver.) 2485 C 2486 C Note: The work arrays must not be altered between calls to DLSODES 2487 C for the same problem, except possibly for the conditional and 2488 C optional inputs, and except for the last 3*NEQ words of RWORK. 2489 C The latter space is used for internal scratch space, and so is 2490 C available for use by the user outside DLSODES between calls, if 2491 C desired (but not for use by F or JAC). 2492 C 2493 C JAC = name of user-supplied routine (MITER = 1 or MOSS = 1) to 2494 C compute the Jacobian matrix, df/dy, as a function of 2495 C the scalar t and the vector y. It is to have the form 2496 C SUBROUTINE JAC (NEQ, T, Y, J, IAN, JAN, PDJ) 2497 C DOUBLE PRECISION T, Y(*), IAN(*), JAN(*), PDJ(*) 2498 C where NEQ, T, Y, J, IAN, and JAN are input, and the array 2499 C PDJ, of length NEQ, is to be loaded with column J 2500 C of the Jacobian on output. Thus df(i)/dy(J) is to be 2501 C loaded into PDJ(i) for all relevant values of i. 2502 C Here T and Y have the same meaning as in Subroutine F, 2503 C and J is a column index (1 to NEQ). IAN and JAN are 2504 C undefined in calls to JAC for structure determination 2505 C (MOSS = 1). otherwise, IAN and JAN are structure 2506 C descriptors, as defined under optional outputs below, and 2507 C so can be used to determine the relevant row indices i, if 2508 C desired. 2509 C JAC need not provide df/dy exactly. A crude 2510 C approximation (possibly with greater sparsity) will do. 2511 C In any case, PDJ is preset to zero by the solver, 2512 C so that only the nonzero elements need be loaded by JAC. 2513 C Calls to JAC are made with J = 1,...,NEQ, in that order, and 2514 C each such set of calls is preceded by a call to F with the 2515 C same arguments NEQ, T, and Y. Thus to gain some efficiency, 2516 C intermediate quantities shared by both calculations may be 2517 C saved in a user Common block by F and not recomputed by JAC, 2518 C if desired. JAC must not alter its input arguments. 2519 C JAC must be declared External in the calling program. 2520 C Subroutine JAC may access user-defined quantities in 2521 C NEQ(2),... and/or in Y(NEQ(1)+1),... if NEQ is an array 2522 C (dimensioned in JAC) and/or Y has length exceeding NEQ(1). 2523 C See the descriptions of NEQ and Y above. 2524 C 2525 C MF = the method flag. Used only for input. 2526 C MF has three decimal digits-- MOSS, METH, MITER-- 2527 C MF = 100*MOSS + 10*METH + MITER. 2528 C MOSS indicates the method to be used to obtain the sparsity 2529 C structure of the Jacobian matrix if MITER = 1 or 2: 2530 C MOSS = 0 means the user has supplied IA and JA 2531 C (see descriptions under IWORK above). 2532 C MOSS = 1 means the user has supplied JAC (see below) 2533 C and the structure will be obtained from NEQ 2534 C initial calls to JAC. 2535 C MOSS = 2 means the structure will be obtained from NEQ+1 2536 C initial calls to F. 2537 C METH indicates the basic linear multistep method: 2538 C METH = 1 means the implicit Adams method. 2539 C METH = 2 means the method based on Backward 2540 C Differentiation Formulas (BDFs). 2541 C MITER indicates the corrector iteration method: 2542 C MITER = 0 means functional iteration (no Jacobian matrix 2543 C is involved). 2544 C MITER = 1 means chord iteration with a user-supplied 2545 C sparse Jacobian, given by Subroutine JAC. 2546 C MITER = 2 means chord iteration with an internally 2547 C generated (difference quotient) sparse Jacobian 2548 C (using NGP extra calls to F per df/dy value, 2549 C where NGP is an optional output described below.) 2550 C MITER = 3 means chord iteration with an internally 2551 C generated diagonal Jacobian approximation 2552 C (using 1 extra call to F per df/dy evaluation). 2553 C If MITER = 1 or MOSS = 1, the user must supply a Subroutine 2554 C JAC (the name is arbitrary) as described above under JAC. 2555 C Otherwise, a dummy argument can be used. 2556 C 2557 C The standard choices for MF are: 2558 C MF = 10 for a nonstiff problem, 2559 C MF = 21 or 22 for a stiff problem with IA/JA supplied 2560 C (21 if JAC is supplied, 22 if not), 2561 C MF = 121 for a stiff problem with JAC supplied, 2562 C but not IA/JA, 2563 C MF = 222 for a stiff problem with neither IA/JA nor 2564 C JAC supplied. 2565 C The sparseness structure can be changed during the 2566 C problem by making a call to DLSODES with ISTATE = 3. 2567 C----------------------------------------------------------------------- 2568 C Optional Inputs. 2569 C 2570 C The following is a list of the optional inputs provided for in the 2571 C call sequence. (See also Part 2.) For each such input variable, 2572 C this table lists its name as used in this documentation, its 2573 C location in the call sequence, its meaning, and the default value. 2574 C The use of any of these inputs requires IOPT = 1, and in that 2575 C case all of these inputs are examined. A value of zero for any 2576 C of these optional inputs will cause the default value to be used. 2577 C Thus to use a subset of the optional inputs, simply preload 2578 C locations 5 to 10 in RWORK and IWORK to 0.0 and 0 respectively, and 2579 C then set those of interest to nonzero values. 2580 C 2581 C Name Location Meaning and Default Value 2582 C 2583 C H0 RWORK(5) the step size to be attempted on the first step. 2584 C The default value is determined by the solver. 2585 C 2586 C HMAX RWORK(6) the maximum absolute step size allowed. 2587 C The default value is infinite. 2588 C 2589 C HMIN RWORK(7) the minimum absolute step size allowed. 2590 C The default value is 0. (This lower bound is not 2591 C enforced on the final step before reaching TCRIT 2592 C when ITASK = 4 or 5.) 2593 C 2594 C SETH RWORK(8) the element threshhold for sparsity determination 2595 C when MOSS = 1 or 2. If the absolute value of 2596 C an estimated Jacobian element is .le. SETH, it 2597 C will be assumed to be absent in the structure. 2598 C The default value of SETH is 0. 2599 C 2600 C MAXORD IWORK(5) the maximum order to be allowed. The default 2601 C value is 12 if METH = 1, and 5 if METH = 2. 2602 C If MAXORD exceeds the default value, it will 2603 C be reduced to the default value. 2604 C If MAXORD is changed during the problem, it may 2605 C cause the current order to be reduced. 2606 C 2607 C MXSTEP IWORK(6) maximum number of (internally defined) steps 2608 C allowed during one call to the solver. 2609 C The default value is 500. 2610 C 2611 C MXHNIL IWORK(7) maximum number of messages printed (per problem) 2612 C warning that T + H = T on a step (H = step size). 2613 C This must be positive to result in a non-default 2614 C value. The default value is 10. 2615 C----------------------------------------------------------------------- 2616 C Optional Outputs. 2617 C 2618 C As optional additional output from DLSODES, the variables listed 2619 C below are quantities related to the performance of DLSODES 2620 C which are available to the user. These are communicated by way of 2621 C the work arrays, but also have internal mnemonic names as shown. 2622 C Except where stated otherwise, all of these outputs are defined 2623 C on any successful return from DLSODES, and on any return with 2624 C ISTATE = -1, -2, -4, -5, or -6. On an illegal input return 2625 C (ISTATE = -3), they will be unchanged from their existing values 2626 C (if any), except possibly for TOLSF, LENRW, and LENIW. 2627 C On any error return, outputs relevant to the error will be defined, 2628 C as noted below. 2629 C 2630 C Name Location Meaning 2631 C 2632 C HU RWORK(11) the step size in t last used (successfully). 2633 C 2634 C HCUR RWORK(12) the step size to be attempted on the next step. 2635 C 2636 C TCUR RWORK(13) the current value of the independent variable 2637 C which the solver has actually reached, i.e. the 2638 C current internal mesh point in t. On output, TCUR 2639 C will always be at least as far as the argument 2640 C T, but may be farther (if interpolation was done). 2641 C 2642 C TOLSF RWORK(14) a tolerance scale factor, greater than 1.0, 2643 C computed when a request for too much accuracy was 2644 C detected (ISTATE = -3 if detected at the start of 2645 C the problem, ISTATE = -2 otherwise). If ITOL is 2646 C left unaltered but RTOL and ATOL are uniformly 2647 C scaled up by a factor of TOLSF for the next call, 2648 C then the solver is deemed likely to succeed. 2649 C (The user may also ignore TOLSF and alter the 2650 C tolerance parameters in any other way appropriate.) 2651 C 2652 C NST IWORK(11) the number of steps taken for the problem so far. 2653 C 2654 C NFE IWORK(12) the number of f evaluations for the problem so far, 2655 C excluding those for structure determination 2656 C (MOSS = 2). 2657 C 2658 C NJE IWORK(13) the number of Jacobian evaluations for the problem 2659 C so far, excluding those for structure determination 2660 C (MOSS = 1). 2661 C 2662 C NQU IWORK(14) the method order last used (successfully). 2663 C 2664 C NQCUR IWORK(15) the order to be attempted on the next step. 2665 C 2666 C IMXER IWORK(16) the index of the component of largest magnitude in 2667 C the weighted local error vector ( E(i)/EWT(i) ), 2668 C on an error return with ISTATE = -4 or -5. 2669 C 2670 C LENRW IWORK(17) the length of RWORK actually required. 2671 C This is defined on normal returns and on an illegal 2672 C input return for insufficient storage. 2673 C 2674 C LENIW IWORK(18) the length of IWORK actually required. 2675 C This is defined on normal returns and on an illegal 2676 C input return for insufficient storage. 2677 C 2678 C NNZ IWORK(19) the number of nonzero elements in the Jacobian 2679 C matrix, including the diagonal (MITER = 1 or 2). 2680 C (This may differ from that given by IA(NEQ+1)-1 2681 C if MOSS = 0, because of added diagonal entries.) 2682 C 2683 C NGP IWORK(20) the number of groups of column indices, used in 2684 C difference quotient Jacobian aproximations if 2685 C MITER = 2. This is also the number of extra f 2686 C evaluations needed for each Jacobian evaluation. 2687 C 2688 C NLU IWORK(21) the number of sparse LU decompositions for the 2689 C problem so far. 2690 C 2691 C LYH IWORK(22) the base address in RWORK of the history array YH, 2692 C described below in this list. 2693 C 2694 C IPIAN IWORK(23) the base address of the structure descriptor array 2695 C IAN, described below in this list. 2696 C 2697 C IPJAN IWORK(24) the base address of the structure descriptor array 2698 C JAN, described below in this list. 2699 C 2700 C NZL IWORK(25) the number of nonzero elements in the strict lower 2701 C triangle of the LU factorization used in the chord 2702 C iteration (MITER = 1 or 2). 2703 C 2704 C NZU IWORK(26) the number of nonzero elements in the strict upper 2705 C triangle of the LU factorization used in the chord 2706 C iteration (MITER = 1 or 2). 2707 C The total number of nonzeros in the factorization 2708 C is therefore NZL + NZU + NEQ. 2709 C 2710 C The following four arrays are segments of the RWORK array which 2711 C may also be of interest to the user as optional outputs. 2712 C For each array, the table below gives its internal name, 2713 C its base address, and its description. 2714 C For YH and ACOR, the base addresses are in RWORK (a real array). 2715 C The integer arrays IAN and JAN are to be obtained by declaring an 2716 C integer array IWK and identifying IWK(1) with RWORK(21), using either 2717 C an equivalence statement or a subroutine call. Then the base 2718 C addresses IPIAN (of IAN) and IPJAN (of JAN) in IWK are to be obtained 2719 C as optional outputs IWORK(23) and IWORK(24), respectively. 2720 C Thus IAN(1) is IWK(IPIAN), etc. 2721 C 2722 C Name Base Address Description 2723 C 2724 C IAN IPIAN (in IWK) structure descriptor array of size NEQ + 1. 2725 C JAN IPJAN (in IWK) structure descriptor array of size NNZ. 2726 C (see above) IAN and JAN together describe the sparsity 2727 C structure of the Jacobian matrix, as used by 2728 C DLSODES when MITER = 1 or 2. 2729 C JAN contains the row indices of the nonzero 2730 C locations, reading in columnwise order, and 2731 C IAN contains the starting locations in JAN of 2732 C the descriptions of columns 1,...,NEQ, in 2733 C that order, with IAN(1) = 1. Thus for each 2734 C j = 1,...,NEQ, the row indices i of the 2735 C nonzero locations in column j are 2736 C i = JAN(k), IAN(j) .le. k .lt. IAN(j+1). 2737 C Note that IAN(NEQ+1) = NNZ + 1. 2738 C (If MOSS = 0, IAN/JAN may differ from the 2739 C input IA/JA because of a different ordering 2740 C in each column, and added diagonal entries.) 2741 C 2742 C YH LYH the Nordsieck history array, of size NYH by 2743 C (optional (NQCUR + 1), where NYH is the initial value 2744 C output) of NEQ. For j = 0,1,...,NQCUR, column j+1 2745 C of YH contains HCUR**j/factorial(j) times 2746 C the j-th derivative of the interpolating 2747 C polynomial currently representing the solution, 2748 C evaluated at t = TCUR. The base address LYH 2749 C is another optional output, listed above. 2750 C 2751 C ACOR LENRW-NEQ+1 array of size NEQ used for the accumulated 2752 C corrections on each step, scaled on output 2753 C to represent the estimated local error in y 2754 C on the last step. This is the vector E in 2755 C the description of the error control. It is 2756 C defined only on a successful return from 2757 C DLSODES. 2758 C 2759 C----------------------------------------------------------------------- 2760 C Part 2. Other Routines Callable. 2761 C 2762 C The following are optional calls which the user may make to 2763 C gain additional capabilities in conjunction with DLSODES. 2764 C (The routines XSETUN and XSETF are designed to conform to the 2765 C SLATEC error handling package.) 2766 C 2767 C Form of Call Function 2768 C CALL XSETUN(LUN) Set the logical unit number, LUN, for 2769 C output of messages from DLSODES, if 2770 C the default is not desired. 2771 C The default value of LUN is 6. 2772 C 2773 C CALL XSETF(MFLAG) Set a flag to control the printing of 2774 C messages by DLSODES. 2775 C MFLAG = 0 means do not print. (Danger: 2776 C This risks losing valuable information.) 2777 C MFLAG = 1 means print (the default). 2778 C 2779 C Either of the above calls may be made at 2780 C any time and will take effect immediately. 2781 C 2782 C CALL DSRCMS(RSAV,ISAV,JOB) saves and restores the contents of 2783 C the internal Common blocks used by 2784 C DLSODES (see Part 3 below). 2785 C RSAV must be a real array of length 224 2786 C or more, and ISAV must be an integer 2787 C array of length 71 or more. 2788 C JOB=1 means save Common into RSAV/ISAV. 2789 C JOB=2 means restore Common from RSAV/ISAV. 2790 C DSRCMS is useful if one is 2791 C interrupting a run and restarting 2792 C later, or alternating between two or 2793 C more problems solved with DLSODES. 2794 C 2795 C CALL DINTDY(,,,,,) Provide derivatives of y, of various 2796 C (see below) orders, at a specified point t, if 2797 C desired. It may be called only after 2798 C a successful return from DLSODES. 2799 C 2800 C The detailed instructions for using DINTDY are as follows. 2801 C The form of the call is: 2802 C 2803 C LYH = IWORK(22) 2804 C CALL DINTDY (T, K, RWORK(LYH), NYH, DKY, IFLAG) 2805 C 2806 C The input parameters are: 2807 C 2808 C T = value of independent variable where answers are desired 2809 C (normally the same as the T last returned by DLSODES). 2810 C For valid results, T must lie between TCUR - HU and TCUR. 2811 C (See optional outputs for TCUR and HU.) 2812 C K = integer order of the derivative desired. K must satisfy 2813 C 0 .le. K .le. NQCUR, where NQCUR is the current order 2814 C (See optional outputs). The capability corresponding 2815 C to K = 0, i.e. computing y(T), is already provided 2816 C by DLSODES directly. Since NQCUR .ge. 1, the first 2817 C derivative dy/dt is always available with DINTDY. 2818 C LYH = the base address of the history array YH, obtained 2819 C as an optional output as shown above. 2820 C NYH = column length of YH, equal to the initial value of NEQ. 2821 C 2822 C The output parameters are: 2823 C 2824 C DKY = a real array of length NEQ containing the computed value 2825 C of the K-th derivative of y(t). 2826 C IFLAG = integer flag, returned as 0 if K and T were legal, 2827 C -1 if K was illegal, and -2 if T was illegal. 2828 C On an error return, a message is also written. 2829 C----------------------------------------------------------------------- 2830 C Part 3. Common Blocks. 2831 C 2832 C If DLSODES is to be used in an overlay situation, the user 2833 C must declare, in the primary overlay, the variables in: 2834 C (1) the call sequence to DLSODES, and 2835 C (2) the two internal Common blocks 2836 C /DLS001/ of length 255 (218 double precision words 2837 C followed by 37 integer words), 2838 C /DLSS01/ of length 40 (6 double precision words 2839 C followed by 34 integer words), 2840 C 2841 C If DLSODES is used on a system in which the contents of internal 2842 C Common blocks are not preserved between calls, the user should 2843 C declare the above Common blocks in the calling program to insure 2844 C that their contents are preserved. 2845 C 2846 C If the solution of a given problem by DLSODES is to be interrupted 2847 C and then later continued, such as when restarting an interrupted run 2848 C or alternating between two or more problems, the user should save, 2849 C following the return from the last DLSODES call prior to the 2850 C interruption, the contents of the call sequence variables and the 2851 C internal Common blocks, and later restore these values before the 2852 C next DLSODES call for that problem. To save and restore the Common 2853 C blocks, use Subroutine DSRCMS (see Part 2 above). 2854 C 2855 C----------------------------------------------------------------------- 2856 C Part 4. Optionally Replaceable Solver Routines. 2857 C 2858 C Below are descriptions of two routines in the DLSODES package which 2859 C relate to the measurement of errors. Either routine can be 2860 C replaced by a user-supplied version, if desired. However, since such 2861 C a replacement may have a major impact on performance, it should be 2862 C done only when absolutely necessary, and only with great caution. 2863 C (Note: The means by which the package version of a routine is 2864 C superseded by the user's version may be system-dependent.) 2865 C 2866 C (a) DEWSET. 2867 C The following subroutine is called just before each internal 2868 C integration step, and sets the array of error weights, EWT, as 2869 C described under ITOL/RTOL/ATOL above: 2870 C Subroutine DEWSET (NEQ, ITOL, RTOL, ATOL, YCUR, EWT) 2871 C where NEQ, ITOL, RTOL, and ATOL are as in the DLSODES call sequence, 2872 C YCUR contains the current dependent variable vector, and 2873 C EWT is the array of weights set by DEWSET. 2874 C 2875 C If the user supplies this subroutine, it must return in EWT(i) 2876 C (i = 1,...,NEQ) a positive quantity suitable for comparing errors 2877 C in y(i) to. The EWT array returned by DEWSET is passed to the DVNORM 2878 C routine (see below), and also used by DLSODES in the computation 2879 C of the optional output IMXER, the diagonal Jacobian approximation, 2880 C and the increments for difference quotient Jacobians. 2881 C 2882 C In the user-supplied version of DEWSET, it may be desirable to use 2883 C the current values of derivatives of y. Derivatives up to order NQ 2884 C are available from the history array YH, described above under 2885 C optional outputs. In DEWSET, YH is identical to the YCUR array, 2886 C extended to NQ + 1 columns with a column length of NYH and scale 2887 C factors of H**j/factorial(j). On the first call for the problem, 2888 C given by NST = 0, NQ is 1 and H is temporarily set to 1.0. 2889 C NYH is the initial value of NEQ. The quantities NQ, H, and NST 2890 C can be obtained by including in DEWSET the statements: 2891 C DOUBLE PRECISION RLS 2892 C COMMON /DLS001/ RLS(218),ILS(37) 2893 C NQ = ILS(33) 2894 C NST = ILS(34) 2895 C H = RLS(212) 2896 C Thus, for example, the current value of dy/dt can be obtained as 2897 C YCUR(NYH+i)/H (i=1,...,NEQ) (and the division by H is 2898 C unnecessary when NST = 0). 2899 C 2900 C (b) DVNORM. 2901 C The following is a real function routine which computes the weighted 2902 C root-mean-square norm of a vector v: 2903 C D = DVNORM (N, V, W) 2904 C where 2905 C N = the length of the vector, 2906 C V = real array of length N containing the vector, 2907 C W = real array of length N containing weights, 2908 C D = SQRT( (1/N) * sum(V(i)*W(i))**2 ). 2909 C DVNORM is called with N = NEQ and with W(i) = 1.0/EWT(i), where 2910 C EWT is as set by Subroutine DEWSET. 2911 C 2912 C If the user supplies this function, it should return a non-negative 2913 C value of DVNORM suitable for use in the error control in DLSODES. 2914 C None of the arguments should be altered by DVNORM. 2915 C For example, a user-supplied DVNORM routine might: 2916 C -substitute a max-norm of (V(i)*W(i)) for the RMS-norm, or 2917 C -ignore some components of V in the norm, with the effect of 2918 C suppressing the error control on those components of y. 2919 C----------------------------------------------------------------------- 2920 C 2921 C***REVISION HISTORY (YYYYMMDD) 2922 C 19810120 DATE WRITTEN 2923 C 19820315 Upgraded MDI in ODRV package: operates on M + M-transpose. 2924 C 19820426 Numerous revisions in use of work arrays; 2925 C use wordlength ratio LENRAT; added IPISP & LRAT to Common; 2926 C added optional outputs IPIAN/IPJAN; 2927 C numerous corrections to comments. 2928 C 19830503 Added routine CNTNZU; added NZL and NZU to /LSS001/; 2929 C changed ADJLR call logic; added optional outputs NZL & NZU; 2930 C revised counter initializations; revised PREP stmt. numbers; 2931 C corrections to comments throughout. 2932 C 19870320 Corrected jump on test of umax in CDRV routine; 2933 C added ISTATE = -7 return. 2934 C 19870330 Major update: corrected comments throughout; 2935 C removed TRET from Common; rewrote EWSET with 4 loops; 2936 C fixed t test in INTDY; added Cray directives in STODE; 2937 C in STODE, fixed DELP init. and logic around PJAC call; 2938 C combined routines to save/restore Common; 2939 C passed LEVEL = 0 in error message calls (except run abort). 2940 C 20010425 Major update: convert source lines to upper case; 2941 C added *DECK lines; changed from 1 to * in dummy dimensions; 2942 C changed names R1MACH/D1MACH to RUMACH/DUMACH; 2943 C renamed routines for uniqueness across single/double prec.; 2944 C converted intrinsic names to generic form; 2945 C removed ILLIN and NTREP (data loaded) from Common; 2946 C removed all 'own' variables from Common; 2947 C changed error messages to quoted strings; 2948 C replaced XERRWV/XERRWD with 1993 revised version; 2949 C converted prologues, comments, error messages to mixed case; 2950 C converted arithmetic IF statements to logical IF statements; 2951 C numerous corrections to prologues and internal comments. 2952 C 20010507 Converted single precision source to double precision. 2953 C 20020502 Corrected declarations in descriptions of user routines. 2954 C 20031105 Restored 'own' variables to Common blocks, to enable 2955 C interrupt/restart feature. 2956 C 20031112 Added SAVE statements for data-loaded constants. 2957 C 2958 C----------------------------------------------------------------------- 2959 C Other routines in the DLSODES package. 2960 C 2961 C In addition to Subroutine DLSODES, the DLSODES package includes the 2962 C following subroutines and function routines: 2963 C DIPREP acts as an iterface between DLSODES and DPREP, and also does 2964 C adjusting of work space pointers and work arrays. 2965 C DPREP is called by DIPREP to compute sparsity and do sparse matrix 2966 C preprocessing if MITER = 1 or 2. 2967 C JGROUP is called by DPREP to compute groups of Jacobian column 2968 C indices for use when MITER = 2. 2969 C ADJLR adjusts the length of required sparse matrix work space. 2970 C It is called by DPREP. 2971 C CNTNZU is called by DPREP and counts the nonzero elements in the 2972 C strict upper triangle of J + J-transpose, where J = df/dy. 2973 C DINTDY computes an interpolated value of the y vector at t = TOUT. 2974 C DSTODE is the core integrator, which does one step of the 2975 C integration and the associated error control. 2976 C DCFODE sets all method coefficients and test constants. 2977 C DPRJS computes and preprocesses the Jacobian matrix J = df/dy 2978 C and the Newton iteration matrix P = I - h*l0*J. 2979 C DSOLSS manages solution of linear system in chord iteration. 2980 C DEWSET sets the error weight vector EWT before each step. 2981 C DVNORM computes the weighted RMS-norm of a vector. 2982 C DSRCMS is a user-callable routine to save and restore 2983 C the contents of the internal Common blocks. 2984 C ODRV constructs a reordering of the rows and columns of 2985 C a matrix by the minimum degree algorithm. ODRV is a 2986 C driver routine which calls Subroutines MD, MDI, MDM, 2987 C MDP, MDU, and SRO. See Ref. 2 for details. (The ODRV 2988 C module has been modified since Ref. 2, however.) 2989 C CDRV performs reordering, symbolic factorization, numerical 2990 C factorization, or linear system solution operations, 2991 C depending on a path argument ipath. CDRV is a 2992 C driver routine which calls Subroutines NROC, NSFC, 2993 C NNFC, NNSC, and NNTC. See Ref. 3 for details. 2994 C DLSODES uses CDRV to solve linear systems in which the 2995 C coefficient matrix is P = I - con*J, where I is the 2996 C identity, con is a scalar, and J is an approximation to 2997 C the Jacobian df/dy. Because CDRV deals with rowwise 2998 C sparsity descriptions, CDRV works with P-transpose, not P. 2999 C DUMACH computes the unit roundoff in a machine-independent manner. 3000 C XERRWD, XSETUN, XSETF, IXSAV, and IUMACH handle the printing of all 3001 C error messages and warnings. XERRWD is machine-dependent. 3002 C Note: DVNORM, DUMACH, IXSAV, and IUMACH are function routines. 3003 C All the others are subroutines. 3004 C 3005 C----------------------------------------------------------------------- 3006 EXTERNAL DPRJS, DSOLSS 3007 DOUBLE PRECISION DUMACH, DVNORM 3008 INTEGER INIT, MXSTEP, MXHNIL, NHNIL, NSLAST, NYH, IOWNS, 3009 1 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 3010 2 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 3011 3 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU 3012 INTEGER IPLOST, IESP, ISTATC, IYS, IBA, IBIAN, IBJAN, IBJGP, 3013 1 IPIAN, IPJAN, IPJGP, IPIGP, IPR, IPC, IPIC, IPISP, IPRSP, IPA, 3014 2 LENYH, LENYHM, LENWK, LREQ, LRAT, LREST, LWMIN, MOSS, MSBJ, 3015 3 NSLJ, NGP, NLU, NNZ, NSP, NZL, NZU 3016 INTEGER I, I1, I2, IFLAG, IMAX, IMUL, IMXER, IPFLAG, IPGO, IREM, 3017 1 J, KGO, LENRAT, LENYHT, LENIW, LENRW, LF0, LIA, LJA, 3018 2 LRTEM, LWTEM, LYHD, LYHN, MF1, MORD, MXHNL0, MXSTP0, NCOLM 3019 DOUBLE PRECISION ROWNS, 3020 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND 3021 DOUBLE PRECISION CON0, CONMIN, CCMXJ, PSMALL, RBIG, SETH 3022 DOUBLE PRECISION ATOLI, AYI, BIG, EWTI, H0, HMAX, HMX, RH, RTOLI, 3023 1 TCRIT, TDIST, TNEXT, TOL, TOLSF, TP, SIZE, SUM, W0 3024 DIMENSION MORD(2) 3025 LOGICAL IHIT 3026 CHARACTER*60 MSG 3027 SAVE LENRAT, MORD, MXSTP0, MXHNL0 3028 C----------------------------------------------------------------------- 3029 C The following two internal Common blocks contain 3030 C (a) variables which are local to any subroutine but whose values must 3031 C be preserved between calls to the routine ("own" variables), and 3032 C (b) variables which are communicated between subroutines. 3033 C The block DLS001 is declared in subroutines DLSODES, DIPREP, DPREP, 3034 C DINTDY, DSTODE, DPRJS, and DSOLSS. 3035 C The block DLSS01 is declared in subroutines DLSODES, DIPREP, DPREP, 3036 C DPRJS, and DSOLSS. 3037 C Groups of variables are replaced by dummy arrays in the Common 3038 C declarations in routines where those variables are not used. 3039 C----------------------------------------------------------------------- 3040 COMMON /DLS001/ ROWNS(209), 3041 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND, 3042 2 INIT, MXSTEP, MXHNIL, NHNIL, NSLAST, NYH, IOWNS(6), 3043 3 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 3044 4 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 3045 5 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU 3046 C 3047 COMMON /DLSS01/ CON0, CONMIN, CCMXJ, PSMALL, RBIG, SETH, 3048 1 IPLOST, IESP, ISTATC, IYS, IBA, IBIAN, IBJAN, IBJGP, 3049 2 IPIAN, IPJAN, IPJGP, IPIGP, IPR, IPC, IPIC, IPISP, IPRSP, IPA, 3050 3 LENYH, LENYHM, LENWK, LREQ, LRAT, LREST, LWMIN, MOSS, MSBJ, 3051 4 NSLJ, NGP, NLU, NNZ, NSP, NZL, NZU 3052 C 3053 DATA MORD(1),MORD(2)/12,5/, MXSTP0/500/, MXHNL0/10/ 3054 C----------------------------------------------------------------------- 3055 C In the Data statement below, set LENRAT equal to the ratio of 3056 C the wordlength for a real number to that for an integer. Usually, 3057 C LENRAT = 1 for single precision and 2 for double precision. If the 3058 C true ratio is not an integer, use the next smaller integer (.ge. 1). 3059 C----------------------------------------------------------------------- 3060 DATA LENRAT/2/ 3061 C----------------------------------------------------------------------- 3062 C Block A. 3063 C This code block is executed on every call. 3064 C It tests ISTATE and ITASK for legality and branches appropriately. 3065 C If ISTATE .gt. 1 but the flag INIT shows that initialization has 3066 C not yet been done, an error return occurs. 3067 C If ISTATE = 1 and TOUT = T, return immediately. 3068 C----------------------------------------------------------------------- 3069 IF (ISTATE .LT. 1 .OR. ISTATE .GT. 3) GO TO 601 3070 IF (ITASK .LT. 1 .OR. ITASK .GT. 5) GO TO 602 3071 IF (ISTATE .EQ. 1) GO TO 10 3072 IF (INIT .EQ. 0) GO TO 603 3073 IF (ISTATE .EQ. 2) GO TO 200 3074 GO TO 20 3075 10 INIT = 0 3076 IF (TOUT .EQ. T) RETURN 3077 C----------------------------------------------------------------------- 3078 C Block B. 3079 C The next code block is executed for the initial call (ISTATE = 1), 3080 C or for a continuation call with parameter changes (ISTATE = 3). 3081 C It contains checking of all inputs and various initializations. 3082 C If ISTATE = 1, the final setting of work space pointers, the matrix 3083 C preprocessing, and other initializations are done in Block C. 3084 C 3085 C First check legality of the non-optional inputs NEQ, ITOL, IOPT, 3086 C MF, ML, and MU. 3087 C----------------------------------------------------------------------- 3088 20 IF (NEQ(1) .LE. 0) GO TO 604 3089 IF (ISTATE .EQ. 1) GO TO 25 3090 IF (NEQ(1) .GT. N) GO TO 605 3091 25 N = NEQ(1) 3092 IF (ITOL .LT. 1 .OR. ITOL .GT. 4) GO TO 606 3093 IF (IOPT .LT. 0 .OR. IOPT .GT. 1) GO TO 607 3094 MOSS = MF/100 3095 MF1 = MF - 100*MOSS 3096 METH = MF1/10 3097 MITER = MF1 - 10*METH 3098 IF (MOSS .LT. 0 .OR. MOSS .GT. 2) GO TO 608 3099 IF (METH .LT. 1 .OR. METH .GT. 2) GO TO 608 3100 IF (MITER .LT. 0 .OR. MITER .GT. 3) GO TO 608 3101 IF (MITER .EQ. 0 .OR. MITER .EQ. 3) MOSS = 0 3102 C Next process and check the optional inputs. -------------------------- 3103 IF (IOPT .EQ. 1) GO TO 40 3104 MAXORD = MORD(METH) 3105 MXSTEP = MXSTP0 3106 MXHNIL = MXHNL0 3107 IF (ISTATE .EQ. 1) H0 = 0.0D0 3108 HMXI = 0.0D0 3109 HMIN = 0.0D0 3110 SETH = 0.0D0 3111 GO TO 60 3112 40 MAXORD = IWORK(5) 3113 IF (MAXORD .LT. 0) GO TO 611 3114 IF (MAXORD .EQ. 0) MAXORD = 100 3115 MAXORD = MIN(MAXORD,MORD(METH)) 3116 MXSTEP = IWORK(6) 3117 IF (MXSTEP .LT. 0) GO TO 612 3118 IF (MXSTEP .EQ. 0) MXSTEP = MXSTP0 3119 MXHNIL = IWORK(7) 3120 IF (MXHNIL .LT. 0) GO TO 613 3121 IF (MXHNIL .EQ. 0) MXHNIL = MXHNL0 3122 IF (ISTATE .NE. 1) GO TO 50 3123 H0 = RWORK(5) 3124 IF ((TOUT - T)*H0 .LT. 0.0D0) GO TO 614 3125 50 HMAX = RWORK(6) 3126 IF (HMAX .LT. 0.0D0) GO TO 615 3127 HMXI = 0.0D0 3128 IF (HMAX .GT. 0.0D0) HMXI = 1.0D0/HMAX 3129 HMIN = RWORK(7) 3130 IF (HMIN .LT. 0.0D0) GO TO 616 3131 SETH = RWORK(8) 3132 IF (SETH .LT. 0.0D0) GO TO 609 3133 C Check RTOL and ATOL for legality. ------------------------------------ 3134 60 RTOLI = RTOL(1) 3135 ATOLI = ATOL(1) 3136 DO 65 I = 1,N 3137 IF (ITOL .GE. 3) RTOLI = RTOL(I) 3138 IF (ITOL .EQ. 2 .OR. ITOL .EQ. 4) ATOLI = ATOL(I) 3139 IF (RTOLI .LT. 0.0D0) GO TO 619 3140 IF (ATOLI .LT. 0.0D0) GO TO 620 3141 65 CONTINUE 3142 C----------------------------------------------------------------------- 3143 C Compute required work array lengths, as far as possible, and test 3144 C these against LRW and LIW. Then set tentative pointers for work 3145 C arrays. Pointers to RWORK/IWORK segments are named by prefixing L to 3146 C the name of the segment. E.g., the segment YH starts at RWORK(LYH). 3147 C Segments of RWORK (in order) are denoted WM, YH, SAVF, EWT, ACOR. 3148 C If MITER = 1 or 2, the required length of the matrix work space WM 3149 C is not yet known, and so a crude minimum value is used for the 3150 C initial tests of LRW and LIW, and YH is temporarily stored as far 3151 C to the right in RWORK as possible, to leave the maximum amount 3152 C of space for WM for matrix preprocessing. Thus if MITER = 1 or 2 3153 C and MOSS .ne. 2, some of the segments of RWORK are temporarily 3154 C omitted, as they are not needed in the preprocessing. These 3155 C omitted segments are: ACOR if ISTATE = 1, EWT and ACOR if ISTATE = 3 3156 C and MOSS = 1, and SAVF, EWT, and ACOR if ISTATE = 3 and MOSS = 0. 3157 C----------------------------------------------------------------------- 3158 LRAT = LENRAT 3159 IF (ISTATE .EQ. 1) NYH = N 3160 LWMIN = 0 3161 IF (MITER .EQ. 1) LWMIN = 4*N + 10*N/LRAT 3162 IF (MITER .EQ. 2) LWMIN = 4*N + 11*N/LRAT 3163 IF (MITER .EQ. 3) LWMIN = N + 2 3164 LENYH = (MAXORD+1)*NYH 3165 LREST = LENYH + 3*N 3166 LENRW = 20 + LWMIN + LREST 3167 IWORK(17) = LENRW 3168 LENIW = 30 3169 IF (MOSS .EQ. 0 .AND. MITER .NE. 0 .AND. MITER .NE. 3) 3170 1 LENIW = LENIW + N + 1 3171 IWORK(18) = LENIW 3172 IF (LENRW .GT. LRW) GO TO 617 3173 IF (LENIW .GT. LIW) GO TO 618 3174 LIA = 31 3175 IF (MOSS .EQ. 0 .AND. MITER .NE. 0 .AND. MITER .NE. 3) 3176 1 LENIW = LENIW + IWORK(LIA+N) - 1 3177 IWORK(18) = LENIW 3178 IF (LENIW .GT. LIW) GO TO 618 3179 LJA = LIA + N + 1 3180 LIA = MIN(LIA,LIW) 3181 LJA = MIN(LJA,LIW) 3182 LWM = 21 3183 IF (ISTATE .EQ. 1) NQ = 1 3184 NCOLM = MIN(NQ+1,MAXORD+2) 3185 LENYHM = NCOLM*NYH 3186 LENYHT = LENYH 3187 IF (MITER .EQ. 1 .OR. MITER .EQ. 2) LENYHT = LENYHM 3188 IMUL = 2 3189 IF (ISTATE .EQ. 3) IMUL = MOSS 3190 IF (MOSS .EQ. 2) IMUL = 3 3191 LRTEM = LENYHT + IMUL*N 3192 LWTEM = LWMIN 3193 IF (MITER .EQ. 1 .OR. MITER .EQ. 2) LWTEM = LRW - 20 - LRTEM 3194 LENWK = LWTEM 3195 LYHN = LWM + LWTEM 3196 LSAVF = LYHN + LENYHT 3197 LEWT = LSAVF + N 3198 LACOR = LEWT + N 3199 ISTATC = ISTATE 3200 IF (ISTATE .EQ. 1) GO TO 100 3201 C----------------------------------------------------------------------- 3202 C ISTATE = 3. Move YH to its new location. 3203 C Note that only the part of YH needed for the next step, namely 3204 C MIN(NQ+1,MAXORD+2) columns, is actually moved. 3205 C A temporary error weight array EWT is loaded if MOSS = 2. 3206 C Sparse matrix processing is done in DIPREP/DPREP if MITER = 1 or 2. 3207 C If MAXORD was reduced below NQ, then the pointers are finally set 3208 C so that SAVF is identical to YH(*,MAXORD+2). 3209 C----------------------------------------------------------------------- 3210 LYHD = LYH - LYHN 3211 IMAX = LYHN - 1 + LENYHM 3212 C Move YH. Move right if LYHD < 0; move left if LYHD > 0. ------------- 3213 IF (LYHD .LT. 0) THEN 3214 DO 72 I = LYHN,IMAX 3215 J = IMAX + LYHN - I 3216 72 RWORK(J) = RWORK(J+LYHD) 3217 ENDIF 3218 IF (LYHD .GT. 0) THEN 3219 DO 76 I = LYHN,IMAX 3220 76 RWORK(I) = RWORK(I+LYHD) 3221 ENDIF 3222 80 LYH = LYHN 3223 IWORK(22) = LYH 3224 IF (MITER .EQ. 0 .OR. MITER .EQ. 3) GO TO 92 3225 IF (MOSS .NE. 2) GO TO 85 3226 C Temporarily load EWT if MITER = 1 or 2 and MOSS = 2. ----------------- 3227 CALL DEWSET (N, ITOL, RTOL, ATOL, RWORK(LYH), RWORK(LEWT)) 3228 DO 82 I = 1,N 3229 IF (RWORK(I+LEWT-1) .LE. 0.0D0) GO TO 621 3230 82 RWORK(I+LEWT-1) = 1.0D0/RWORK(I+LEWT-1) 3231 85 CONTINUE 3232 C DIPREP and DPREP do sparse matrix preprocessing if MITER = 1 or 2. --- 3233 LSAVF = MIN(LSAVF,LRW) 3234 LEWT = MIN(LEWT,LRW) 3235 LACOR = MIN(LACOR,LRW) 3236 CALL DIPREP (NEQ, Y, RWORK, IWORK(LIA),IWORK(LJA), IPFLAG, F, JAC) 3237 LENRW = LWM - 1 + LENWK + LREST 3238 IWORK(17) = LENRW 3239 IF (IPFLAG .NE. -1) IWORK(23) = IPIAN 3240 IF (IPFLAG .NE. -1) IWORK(24) = IPJAN 3241 IPGO = -IPFLAG + 1 3242 GO TO (90, 628, 629, 630, 631, 632, 633), IPGO 3243 90 IWORK(22) = LYH 3244 IF (LENRW .GT. LRW) GO TO 617 3245 C Set flag to signal parameter changes to DSTODE. ---------------------- 3246 92 JSTART = -1 3247 IF (N .EQ. NYH) GO TO 200 3248 C NEQ was reduced. Zero part of YH to avoid undefined references. ----- 3249 I1 = LYH + L*NYH 3250 I2 = LYH + (MAXORD + 1)*NYH - 1 3251 IF (I1 .GT. I2) GO TO 200 3252 DO 95 I = I1,I2 3253 95 RWORK(I) = 0.0D0 3254 GO TO 200 3255 C----------------------------------------------------------------------- 3256 C Block C. 3257 C The next block is for the initial call only (ISTATE = 1). 3258 C It contains all remaining initializations, the initial call to F, 3259 C the sparse matrix preprocessing (MITER = 1 or 2), and the 3260 C calculation of the initial step size. 3261 C The error weights in EWT are inverted after being loaded. 3262 C----------------------------------------------------------------------- 3263 100 CONTINUE 3264 LYH = LYHN 3265 IWORK(22) = LYH 3266 TN = T 3267 NST = 0 3268 H = 1.0D0 3269 NNZ = 0 3270 NGP = 0 3271 NZL = 0 3272 NZU = 0 3273 C Load the initial value vector in YH. --------------------------------- 3274 DO 105 I = 1,N 3275 105 RWORK(I+LYH-1) = Y(I) 3276 C Initial call to F. (LF0 points to YH(*,2).) ------------------------- 3277 LF0 = LYH + NYH 3278 CALL F (NEQ, T, Y, RWORK(LF0)) 3279 NFE = 1 3280 C Load and invert the EWT array. (H is temporarily set to 1.0.) ------- 3281 CALL DEWSET (N, ITOL, RTOL, ATOL, RWORK(LYH), RWORK(LEWT)) 3282 DO 110 I = 1,N 3283 IF (RWORK(I+LEWT-1) .LE. 0.0D0) GO TO 621 3284 110 RWORK(I+LEWT-1) = 1.0D0/RWORK(I+LEWT-1) 3285 IF (MITER .EQ. 0 .OR. MITER .EQ. 3) GO TO 120 3286 C DIPREP and DPREP do sparse matrix preprocessing if MITER = 1 or 2. --- 3287 LACOR = MIN(LACOR,LRW) 3288 CALL DIPREP (NEQ, Y, RWORK, IWORK(LIA),IWORK(LJA), IPFLAG, F, JAC) 3289 LENRW = LWM - 1 + LENWK + LREST 3290 IWORK(17) = LENRW 3291 IF (IPFLAG .NE. -1) IWORK(23) = IPIAN 3292 IF (IPFLAG .NE. -1) IWORK(24) = IPJAN 3293 IPGO = -IPFLAG + 1 3294 GO TO (115, 628, 629, 630, 631, 632, 633), IPGO 3295 115 IWORK(22) = LYH 3296 IF (LENRW .GT. LRW) GO TO 617 3297 C Check TCRIT for legality (ITASK = 4 or 5). --------------------------- 3298 120 CONTINUE 3299 IF (ITASK .NE. 4 .AND. ITASK .NE. 5) GO TO 125 3300 TCRIT = RWORK(1) 3301 IF ((TCRIT - TOUT)*(TOUT - T) .LT. 0.0D0) GO TO 625 3302 IF (H0 .NE. 0.0D0 .AND. (T + H0 - TCRIT)*H0 .GT. 0.0D0) 3303 1 H0 = TCRIT - T 3304 C Initialize all remaining parameters. --------------------------------- 3305 125 UROUND = DUMACH() 3306 JSTART = 0 3307 IF (MITER .NE. 0) RWORK(LWM) = SQRT(UROUND) 3308 MSBJ = 50 3309 NSLJ = 0 3310 CCMXJ = 0.2D0 3311 PSMALL = 1000.0D0*UROUND 3312 RBIG = 0.01D0/PSMALL 3313 NHNIL = 0 3314 NJE = 0 3315 NLU = 0 3316 NSLAST = 0 3317 HU = 0.0D0 3318 NQU = 0 3319 CCMAX = 0.3D0 3320 MAXCOR = 3 3321 MSBP = 20 3322 MXNCF = 10 3323 C----------------------------------------------------------------------- 3324 C The coding below computes the step size, H0, to be attempted on the 3325 C first step, unless the user has supplied a value for this. 3326 C First check that TOUT - T differs significantly from zero. 3327 C A scalar tolerance quantity TOL is computed, as MAX(RTOL(i)) 3328 C if this is positive, or MAX(ATOL(i)/ABS(Y(i))) otherwise, adjusted 3329 C so as to be between 100*UROUND and 1.0E-3. 3330 C Then the computed value H0 is given by.. 3331 C NEQ 3332 C H0**2 = TOL / ( w0**-2 + (1/NEQ) * Sum ( f(i)/ywt(i) )**2 ) 3333 C 1 3334 C where w0 = MAX ( ABS(T), ABS(TOUT) ), 3335 C f(i) = i-th component of initial value of f, 3336 C ywt(i) = EWT(i)/TOL (a weight for y(i)). 3337 C The sign of H0 is inferred from the initial values of TOUT and T. 3338 C ABS(H0) is made .le. ABS(TOUT-T) in any case. 3339 C----------------------------------------------------------------------- 3340 LF0 = LYH + NYH 3341 IF (H0 .NE. 0.0D0) GO TO 180 3342 TDIST = ABS(TOUT - T) 3343 W0 = MAX(ABS(T),ABS(TOUT)) 3344 IF (TDIST .LT. 2.0D0*UROUND*W0) GO TO 622 3345 TOL = RTOL(1) 3346 IF (ITOL .LE. 2) GO TO 140 3347 DO 130 I = 1,N 3348 130 TOL = MAX(TOL,RTOL(I)) 3349 140 IF (TOL .GT. 0.0D0) GO TO 160 3350 ATOLI = ATOL(1) 3351 DO 150 I = 1,N 3352 IF (ITOL .EQ. 2 .OR. ITOL .EQ. 4) ATOLI = ATOL(I) 3353 AYI = ABS(Y(I)) 3354 IF (AYI .NE. 0.0D0) TOL = MAX(TOL,ATOLI/AYI) 3355 150 CONTINUE 3356 160 TOL = MAX(TOL,100.0D0*UROUND) 3357 TOL = MIN(TOL,0.001D0) 3358 SUM = DVNORM (N, RWORK(LF0), RWORK(LEWT)) 3359 SUM = 1.0D0/(TOL*W0*W0) + TOL*SUM**2 3360 H0 = 1.0D0/SQRT(SUM) 3361 H0 = MIN(H0,TDIST) 3362 H0 = SIGN(H0,TOUT-T) 3363 C Adjust H0 if necessary to meet HMAX bound. --------------------------- 3364 180 RH = ABS(H0)*HMXI 3365 IF (RH .GT. 1.0D0) H0 = H0/RH 3366 C Load H with H0 and scale YH(*,2) by H0. ------------------------------ 3367 H = H0 3368 DO 190 I = 1,N 3369 190 RWORK(I+LF0-1) = H0*RWORK(I+LF0-1) 3370 GO TO 270 3371 C----------------------------------------------------------------------- 3372 C Block D. 3373 C The next code block is for continuation calls only (ISTATE = 2 or 3) 3374 C and is to check stop conditions before taking a step. 3375 C----------------------------------------------------------------------- 3376 200 NSLAST = NST 3377 GO TO (210, 250, 220, 230, 240), ITASK 3378 210 IF ((TN - TOUT)*H .LT. 0.0D0) GO TO 250 3379 CALL DINTDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) 3380 IF (IFLAG .NE. 0) GO TO 627 3381 T = TOUT 3382 GO TO 420 3383 220 TP = TN - HU*(1.0D0 + 100.0D0*UROUND) 3384 IF ((TP - TOUT)*H .GT. 0.0D0) GO TO 623 3385 IF ((TN - TOUT)*H .LT. 0.0D0) GO TO 250 3386 GO TO 400 3387 230 TCRIT = RWORK(1) 3388 IF ((TN - TCRIT)*H .GT. 0.0D0) GO TO 624 3389 IF ((TCRIT - TOUT)*H .LT. 0.0D0) GO TO 625 3390 IF ((TN - TOUT)*H .LT. 0.0D0) GO TO 245 3391 CALL DINTDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) 3392 IF (IFLAG .NE. 0) GO TO 627 3393 T = TOUT 3394 GO TO 420 3395 240 TCRIT = RWORK(1) 3396 IF ((TN - TCRIT)*H .GT. 0.0D0) GO TO 624 3397 245 HMX = ABS(TN) + ABS(H) 3398 IHIT = ABS(TN - TCRIT) .LE. 100.0D0*UROUND*HMX 3399 IF (IHIT) GO TO 400 3400 TNEXT = TN + H*(1.0D0 + 4.0D0*UROUND) 3401 IF ((TNEXT - TCRIT)*H .LE. 0.0D0) GO TO 250 3402 H = (TCRIT - TN)*(1.0D0 - 4.0D0*UROUND) 3403 IF (ISTATE .EQ. 2) JSTART = -2 3404 C----------------------------------------------------------------------- 3405 C Block E. 3406 C The next block is normally executed for all calls and contains 3407 C the call to the one-step core integrator DSTODE. 3408 C 3409 C This is a looping point for the integration steps. 3410 C 3411 C First check for too many steps being taken, update EWT (if not at 3412 C start of problem), check for too much accuracy being requested, and 3413 C check for H below the roundoff level in T. 3414 C----------------------------------------------------------------------- 3415 250 CONTINUE 3416 IF ((NST-NSLAST) .GE. MXSTEP) GO TO 500 3417 CALL DEWSET (N, ITOL, RTOL, ATOL, RWORK(LYH), RWORK(LEWT)) 3418 DO 260 I = 1,N 3419 IF (RWORK(I+LEWT-1) .LE. 0.0D0) GO TO 510 3420 260 RWORK(I+LEWT-1) = 1.0D0/RWORK(I+LEWT-1) 3421 270 TOLSF = UROUND*DVNORM (N, RWORK(LYH), RWORK(LEWT)) 3422 IF (TOLSF .LE. 1.0D0) GO TO 280 3423 TOLSF = TOLSF*2.0D0 3424 IF (NST .EQ. 0) GO TO 626 3425 GO TO 520 3426 280 IF ((TN + H) .NE. TN) GO TO 290 3427 NHNIL = NHNIL + 1 3428 IF (NHNIL .GT. MXHNIL) GO TO 290 3429 MSG = 'DLSODES- Warning..Internal T (=R1) and H (=R2) are' 3430 CALL XERRWD (MSG, 50, 101, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 3431 MSG=' such that in the machine, T + H = T on the next step ' 3432 CALL XERRWD (MSG, 60, 101, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 3433 MSG = ' (H = step size). Solver will continue anyway.' 3434 CALL XERRWD (MSG, 50, 101, 0, 0, 0, 0, 2, TN, H) 3435 IF (NHNIL .LT. MXHNIL) GO TO 290 3436 MSG = 'DLSODES- Above warning has been issued I1 times. ' 3437 CALL XERRWD (MSG, 50, 102, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 3438 MSG = ' It will not be issued again for this problem.' 3439 CALL XERRWD (MSG, 50, 102, 0, 1, MXHNIL, 0, 0, 0.0D0, 0.0D0) 3440 290 CONTINUE 3441 C----------------------------------------------------------------------- 3442 C CALL DSTODE(NEQ,Y,YH,NYH,YH,EWT,SAVF,ACOR,WM,WM,F,JAC,DPRJS,DSOLSS) 3443 C----------------------------------------------------------------------- 3444 CALL DSTODE (NEQ, Y, RWORK(LYH), NYH, RWORK(LYH), RWORK(LEWT), 3445 1 RWORK(LSAVF), RWORK(LACOR), RWORK(LWM), RWORK(LWM), 3446 2 F, JAC, DPRJS, DSOLSS) 3447 KGO = 1 - KFLAG 3448 GO TO (300, 530, 540, 550), KGO 3449 C----------------------------------------------------------------------- 3450 C Block F. 3451 C The following block handles the case of a successful return from the 3452 C core integrator (KFLAG = 0). Test for stop conditions. 3453 C----------------------------------------------------------------------- 3454 300 INIT = 1 3455 GO TO (310, 400, 330, 340, 350), ITASK 3456 C ITASK = 1. if TOUT has been reached, interpolate. ------------------- 3457 310 IF ((TN - TOUT)*H .LT. 0.0D0) GO TO 250 3458 CALL DINTDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) 3459 T = TOUT 3460 GO TO 420 3461 C ITASK = 3. Jump to exit if TOUT was reached. ------------------------ 3462 330 IF ((TN - TOUT)*H .GE. 0.0D0) GO TO 400 3463 GO TO 250 3464 C ITASK = 4. See if TOUT or TCRIT was reached. Adjust H if necessary. 3465 340 IF ((TN - TOUT)*H .LT. 0.0D0) GO TO 345 3466 CALL DINTDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) 3467 T = TOUT 3468 GO TO 420 3469 345 HMX = ABS(TN) + ABS(H) 3470 IHIT = ABS(TN - TCRIT) .LE. 100.0D0*UROUND*HMX 3471 IF (IHIT) GO TO 400 3472 TNEXT = TN + H*(1.0D0 + 4.0D0*UROUND) 3473 IF ((TNEXT - TCRIT)*H .LE. 0.0D0) GO TO 250 3474 H = (TCRIT - TN)*(1.0D0 - 4.0D0*UROUND) 3475 JSTART = -2 3476 GO TO 250 3477 C ITASK = 5. See if TCRIT was reached and jump to exit. --------------- 3478 350 HMX = ABS(TN) + ABS(H) 3479 IHIT = ABS(TN - TCRIT) .LE. 100.0D0*UROUND*HMX 3480 C----------------------------------------------------------------------- 3481 C Block G. 3482 C The following block handles all successful returns from DLSODES. 3483 C If ITASK .ne. 1, Y is loaded from YH and T is set accordingly. 3484 C ISTATE is set to 2, and the optional outputs are loaded into the 3485 C work arrays before returning. 3486 C----------------------------------------------------------------------- 3487 400 DO 410 I = 1,N 3488 410 Y(I) = RWORK(I+LYH-1) 3489 T = TN 3490 IF (ITASK .NE. 4 .AND. ITASK .NE. 5) GO TO 420 3491 IF (IHIT) T = TCRIT 3492 420 ISTATE = 2 3493 RWORK(11) = HU 3494 RWORK(12) = H 3495 RWORK(13) = TN 3496 IWORK(11) = NST 3497 IWORK(12) = NFE 3498 IWORK(13) = NJE 3499 IWORK(14) = NQU 3500 IWORK(15) = NQ 3501 IWORK(19) = NNZ 3502 IWORK(20) = NGP 3503 IWORK(21) = NLU 3504 IWORK(25) = NZL 3505 IWORK(26) = NZU 3506 RETURN 3507 C----------------------------------------------------------------------- 3508 C Block H. 3509 C The following block handles all unsuccessful returns other than 3510 C those for illegal input. First the error message routine is called. 3511 C If there was an error test or convergence test failure, IMXER is set. 3512 C Then Y is loaded from YH and T is set to TN. 3513 C The optional outputs are loaded into the work arrays before returning. 3514 C----------------------------------------------------------------------- 3515 C The maximum number of steps was taken before reaching TOUT. ---------- 3516 500 MSG = 'DLSODES- At current T (=R1), MXSTEP (=I1) steps ' 3517 CALL XERRWD (MSG, 50, 201, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 3518 MSG = ' taken on this call before reaching TOUT ' 3519 CALL XERRWD (MSG, 50, 201, 0, 1, MXSTEP, 0, 1, TN, 0.0D0) 3520 ISTATE = -1 3521 GO TO 580 3522 C EWT(i) .le. 0.0 for some i (not at start of problem). ---------------- 3523 510 EWTI = RWORK(LEWT+I-1) 3524 MSG = 'DLSODES- At T (=R1), EWT(I1) has become R2 .le. 0.' 3525 CALL XERRWD (MSG, 50, 202, 0, 1, I, 0, 2, TN, EWTI) 3526 ISTATE = -6 3527 GO TO 580 3528 C Too much accuracy requested for machine precision. ------------------- 3529 520 MSG = 'DLSODES- At T (=R1), too much accuracy requested ' 3530 CALL XERRWD (MSG, 50, 203, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 3531 MSG = ' for precision of machine.. See TOLSF (=R2) ' 3532 CALL XERRWD (MSG, 50, 203, 0, 0, 0, 0, 2, TN, TOLSF) 3533 RWORK(14) = TOLSF 3534 ISTATE = -2 3535 GO TO 580 3536 C KFLAG = -1. Error test failed repeatedly or with ABS(H) = HMIN. ----- 3537 530 MSG = 'DLSODES- At T(=R1) and step size H(=R2), the error' 3538 CALL XERRWD (MSG, 50, 204, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 3539 MSG = ' test failed repeatedly or with ABS(H) = HMIN' 3540 CALL XERRWD (MSG, 50, 204, 0, 0, 0, 0, 2, TN, H) 3541 ISTATE = -4 3542 GO TO 560 3543 C KFLAG = -2. Convergence failed repeatedly or with ABS(H) = HMIN. ---- 3544 540 MSG = 'DLSODES- At T (=R1) and step size H (=R2), the ' 3545 CALL XERRWD (MSG, 50, 205, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 3546 MSG = ' corrector convergence failed repeatedly ' 3547 CALL XERRWD (MSG, 50, 205, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 3548 MSG = ' or with ABS(H) = HMIN ' 3549 CALL XERRWD (MSG, 30, 205, 0, 0, 0, 0, 2, TN, H) 3550 ISTATE = -5 3551 GO TO 560 3552 C KFLAG = -3. Fatal error flag returned by DPRJS or DSOLSS (CDRV). ---- 3553 550 MSG = 'DLSODES- At T (=R1) and step size H (=R2), a fatal' 3554 CALL XERRWD (MSG, 50, 207, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 3555 MSG = ' error flag was returned by CDRV (by way of ' 3556 CALL XERRWD (MSG, 50, 207, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 3557 MSG = ' Subroutine DPRJS or DSOLSS) ' 3558 CALL XERRWD (MSG, 40, 207, 0, 0, 0, 0, 2, TN, H) 3559 ISTATE = -7 3560 GO TO 580 3561 C Compute IMXER if relevant. ------------------------------------------- 3562 560 BIG = 0.0D0 3563 IMXER = 1 3564 DO 570 I = 1,N 3565 SIZE = ABS(RWORK(I+LACOR-1)*RWORK(I+LEWT-1)) 3566 IF (BIG .GE. SIZE) GO TO 570 3567 BIG = SIZE 3568 IMXER = I 3569 570 CONTINUE 3570 IWORK(16) = IMXER 3571 C Set Y vector, T, and optional outputs. ------------------------------- 3572 580 DO 590 I = 1,N 3573 590 Y(I) = RWORK(I+LYH-1) 3574 T = TN 3575 RWORK(11) = HU 3576 RWORK(12) = H 3577 RWORK(13) = TN 3578 IWORK(11) = NST 3579 IWORK(12) = NFE 3580 IWORK(13) = NJE 3581 IWORK(14) = NQU 3582 IWORK(15) = NQ 3583 IWORK(19) = NNZ 3584 IWORK(20) = NGP 3585 IWORK(21) = NLU 3586 IWORK(25) = NZL 3587 IWORK(26) = NZU 3588 RETURN 3589 C----------------------------------------------------------------------- 3590 C Block I. 3591 C The following block handles all error returns due to illegal input 3592 C (ISTATE = -3), as detected before calling the core integrator. 3593 C First the error message routine is called. If the illegal input 3594 C is a negative ISTATE, the run is aborted (apparent infinite loop). 3595 C----------------------------------------------------------------------- 3596 601 MSG = 'DLSODES- ISTATE (=I1) illegal.' 3597 CALL XERRWD (MSG, 30, 1, 0, 1, ISTATE, 0, 0, 0.0D0, 0.0D0) 3598 IF (ISTATE .LT. 0) GO TO 800 3599 GO TO 700 3600 602 MSG = 'DLSODES- ITASK (=I1) illegal. ' 3601 CALL XERRWD (MSG, 30, 2, 0, 1, ITASK, 0, 0, 0.0D0, 0.0D0) 3602 GO TO 700 3603 603 MSG = 'DLSODES- ISTATE.gt.1 but DLSODES not initialized. ' 3604 CALL XERRWD (MSG, 50, 3, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 3605 GO TO 700 3606 604 MSG = 'DLSODES- NEQ (=I1) .lt. 1 ' 3607 CALL XERRWD (MSG, 30, 4, 0, 1, NEQ(1), 0, 0, 0.0D0, 0.0D0) 3608 GO TO 700 3609 605 MSG = 'DLSODES- ISTATE = 3 and NEQ increased (I1 to I2). ' 3610 CALL XERRWD (MSG, 50, 5, 0, 2, N, NEQ(1), 0, 0.0D0, 0.0D0) 3611 GO TO 700 3612 606 MSG = 'DLSODES- ITOL (=I1) illegal. ' 3613 CALL XERRWD (MSG, 30, 6, 0, 1, ITOL, 0, 0, 0.0D0, 0.0D0) 3614 GO TO 700 3615 607 MSG = 'DLSODES- IOPT (=I1) illegal. ' 3616 CALL XERRWD (MSG, 30, 7, 0, 1, IOPT, 0, 0, 0.0D0, 0.0D0) 3617 GO TO 700 3618 608 MSG = 'DLSODES- MF (=I1) illegal. ' 3619 CALL XERRWD (MSG, 30, 8, 0, 1, MF, 0, 0, 0.0D0, 0.0D0) 3620 GO TO 700 3621 609 MSG = 'DLSODES- SETH (=R1) .lt. 0.0 ' 3622 CALL XERRWD (MSG, 30, 9, 0, 0, 0, 0, 1, SETH, 0.0D0) 3623 GO TO 700 3624 611 MSG = 'DLSODES- MAXORD (=I1) .lt. 0 ' 3625 CALL XERRWD (MSG, 30, 11, 0, 1, MAXORD, 0, 0, 0.0D0, 0.0D0) 3626 GO TO 700 3627 612 MSG = 'DLSODES- MXSTEP (=I1) .lt. 0 ' 3628 CALL XERRWD (MSG, 30, 12, 0, 1, MXSTEP, 0, 0, 0.0D0, 0.0D0) 3629 GO TO 700 3630 613 MSG = 'DLSODES- MXHNIL (=I1) .lt. 0 ' 3631 CALL XERRWD (MSG, 30, 13, 0, 1, MXHNIL, 0, 0, 0.0D0, 0.0D0) 3632 GO TO 700 3633 614 MSG = 'DLSODES- TOUT (=R1) behind T (=R2) ' 3634 CALL XERRWD (MSG, 40, 14, 0, 0, 0, 0, 2, TOUT, T) 3635 MSG = ' Integration direction is given by H0 (=R1) ' 3636 CALL XERRWD (MSG, 50, 14, 0, 0, 0, 0, 1, H0, 0.0D0) 3637 GO TO 700 3638 615 MSG = 'DLSODES- HMAX (=R1) .lt. 0.0 ' 3639 CALL XERRWD (MSG, 30, 15, 0, 0, 0, 0, 1, HMAX, 0.0D0) 3640 GO TO 700 3641 616 MSG = 'DLSODES- HMIN (=R1) .lt. 0.0 ' 3642 CALL XERRWD (MSG, 30, 16, 0, 0, 0, 0, 1, HMIN, 0.0D0) 3643 GO TO 700 3644 617 MSG = 'DLSODES- RWORK length is insufficient to proceed. ' 3645 CALL XERRWD (MSG, 50, 17, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 3646 MSG=' Length needed is .ge. LENRW (=I1), exceeds LRW (=I2)' 3647 CALL XERRWD (MSG, 60, 17, 0, 2, LENRW, LRW, 0, 0.0D0, 0.0D0) 3648 GO TO 700 3649 618 MSG = 'DLSODES- IWORK length is insufficient to proceed. ' 3650 CALL XERRWD (MSG, 50, 18, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 3651 MSG=' Length needed is .ge. LENIW (=I1), exceeds LIW (=I2)' 3652 CALL XERRWD (MSG, 60, 18, 0, 2, LENIW, LIW, 0, 0.0D0, 0.0D0) 3653 GO TO 700 3654 619 MSG = 'DLSODES- RTOL(I1) is R1 .lt. 0.0 ' 3655 CALL XERRWD (MSG, 40, 19, 0, 1, I, 0, 1, RTOLI, 0.0D0) 3656 GO TO 700 3657 620 MSG = 'DLSODES- ATOL(I1) is R1 .lt. 0.0 ' 3658 CALL XERRWD (MSG, 40, 20, 0, 1, I, 0, 1, ATOLI, 0.0D0) 3659 GO TO 700 3660 621 EWTI = RWORK(LEWT+I-1) 3661 MSG = 'DLSODES- EWT(I1) is R1 .le. 0.0 ' 3662 CALL XERRWD (MSG, 40, 21, 0, 1, I, 0, 1, EWTI, 0.0D0) 3663 GO TO 700 3664 622 MSG='DLSODES- TOUT(=R1) too close to T(=R2) to start integration.' 3665 CALL XERRWD (MSG, 60, 22, 0, 0, 0, 0, 2, TOUT, T) 3666 GO TO 700 3667 623 MSG='DLSODES- ITASK = I1 and TOUT (=R1) behind TCUR - HU (= R2) ' 3668 CALL XERRWD (MSG, 60, 23, 0, 1, ITASK, 0, 2, TOUT, TP) 3669 GO TO 700 3670 624 MSG='DLSODES- ITASK = 4 or 5 and TCRIT (=R1) behind TCUR (=R2) ' 3671 CALL XERRWD (MSG, 60, 24, 0, 0, 0, 0, 2, TCRIT, TN) 3672 GO TO 700 3673 625 MSG='DLSODES- ITASK = 4 or 5 and TCRIT (=R1) behind TOUT (=R2) ' 3674 CALL XERRWD (MSG, 60, 25, 0, 0, 0, 0, 2, TCRIT, TOUT) 3675 GO TO 700 3676 626 MSG = 'DLSODES- At start of problem, too much accuracy ' 3677 CALL XERRWD (MSG, 50, 26, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 3678 MSG=' requested for precision of machine.. See TOLSF (=R1) ' 3679 CALL XERRWD (MSG, 60, 26, 0, 0, 0, 0, 1, TOLSF, 0.0D0) 3680 RWORK(14) = TOLSF 3681 GO TO 700 3682 627 MSG = 'DLSODES- Trouble in DINTDY. ITASK = I1, TOUT = R1' 3683 CALL XERRWD (MSG, 50, 27, 0, 1, ITASK, 0, 1, TOUT, 0.0D0) 3684 GO TO 700 3685 628 MSG='DLSODES- RWORK length insufficient (for Subroutine DPREP). ' 3686 CALL XERRWD (MSG, 60, 28, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 3687 MSG=' Length needed is .ge. LENRW (=I1), exceeds LRW (=I2)' 3688 CALL XERRWD (MSG, 60, 28, 0, 2, LENRW, LRW, 0, 0.0D0, 0.0D0) 3689 GO TO 700 3690 629 MSG='DLSODES- RWORK length insufficient (for Subroutine JGROUP). ' 3691 CALL XERRWD (MSG, 60, 29, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 3692 MSG=' Length needed is .ge. LENRW (=I1), exceeds LRW (=I2)' 3693 CALL XERRWD (MSG, 60, 29, 0, 2, LENRW, LRW, 0, 0.0D0, 0.0D0) 3694 GO TO 700 3695 630 MSG='DLSODES- RWORK length insufficient (for Subroutine ODRV). ' 3696 CALL XERRWD (MSG, 60, 30, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 3697 MSG=' Length needed is .ge. LENRW (=I1), exceeds LRW (=I2)' 3698 CALL XERRWD (MSG, 60, 30, 0, 2, LENRW, LRW, 0, 0.0D0, 0.0D0) 3699 GO TO 700 3700 631 MSG='DLSODES- Error from ODRV in Yale Sparse Matrix Package. ' 3701 CALL XERRWD (MSG, 60, 31, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 3702 IMUL = (IYS - 1)/N 3703 IREM = IYS - IMUL*N 3704 MSG=' At T (=R1), ODRV returned error flag = I1*NEQ + I2. ' 3705 CALL XERRWD (MSG, 60, 31, 0, 2, IMUL, IREM, 1, TN, 0.0D0) 3706 GO TO 700 3707 632 MSG='DLSODES- RWORK length insufficient (for Subroutine CDRV). ' 3708 CALL XERRWD (MSG, 60, 32, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 3709 MSG=' Length needed is .ge. LENRW (=I1), exceeds LRW (=I2)' 3710 CALL XERRWD (MSG, 60, 32, 0, 2, LENRW, LRW, 0, 0.0D0, 0.0D0) 3711 GO TO 700 3712 633 MSG='DLSODES- Error from CDRV in Yale Sparse Matrix Package. ' 3713 CALL XERRWD (MSG, 60, 33, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 3714 IMUL = (IYS - 1)/N 3715 IREM = IYS - IMUL*N 3716 MSG=' At T (=R1), CDRV returned error flag = I1*NEQ + I2. ' 3717 CALL XERRWD (MSG, 60, 33, 0, 2, IMUL, IREM, 1, TN, 0.0D0) 3718 IF (IMUL .EQ. 2) THEN 3719 MSG=' Duplicate entry in sparsity structure descriptors. ' 3720 CALL XERRWD (MSG, 60, 33, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 3721 ENDIF 3722 IF (IMUL .EQ. 3 .OR. IMUL .EQ. 6) THEN 3723 MSG=' Insufficient storage for NSFC (called by CDRV). ' 3724 CALL XERRWD (MSG, 60, 33, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 3725 ENDIF 3726 C 3727 700 ISTATE = -3 3728 RETURN 3729 C 3730 800 MSG = 'DLSODES- Run aborted.. apparent infinite loop. ' 3731 CALL XERRWD (MSG, 50, 303, 2, 0, 0, 0, 0, 0.0D0, 0.0D0) 3732 RETURN 3733 C----------------------- End of Subroutine DLSODES --------------------- 3734 END 3735 *DECK DLSODA 3736 SUBROUTINE DLSODA (F, NEQ, Y, T, TOUT, ITOL, RTOL, ATOL, ITASK, 3737 1 ISTATE, IOPT, RWORK, LRW, IWORK, LIW, JAC, JT) 3738 EXTERNAL F, JAC 3739 INTEGER NEQ, ITOL, ITASK, ISTATE, IOPT, LRW, IWORK, LIW, JT 3740 DOUBLE PRECISION Y, T, TOUT, RTOL, ATOL, RWORK 3741 DIMENSION NEQ(*), Y(*), RTOL(*), ATOL(*), RWORK(LRW), IWORK(LIW) 3742 C----------------------------------------------------------------------- 3743 C This is the 12 November 2003 version of 3744 C DLSODA: Livermore Solver for Ordinary Differential Equations, with 3745 C Automatic method switching for stiff and nonstiff problems. 3746 C 3747 C This version is in double precision. 3748 C 3749 C DLSODA solves the initial value problem for stiff or nonstiff 3750 C systems of first order ODEs, 3751 C dy/dt = f(t,y) , or, in component form, 3752 C dy(i)/dt = f(i) = f(i,t,y(1),y(2),...,y(NEQ)) (i = 1,...,NEQ). 3753 C 3754 C This a variant version of the DLSODE package. 3755 C It switches automatically between stiff and nonstiff methods. 3756 C This means that the user does not have to determine whether the 3757 C problem is stiff or not, and the solver will automatically choose the 3758 C appropriate method. It always starts with the nonstiff method. 3759 C 3760 C Authors: Alan C. Hindmarsh 3761 C Center for Applied Scientific Computing, L-561 3762 C Lawrence Livermore National Laboratory 3763 C Livermore, CA 94551 3764 C and 3765 C Linda R. Petzold 3766 C Univ. of California at Santa Barbara 3767 C Dept. of Computer Science 3768 C Santa Barbara, CA 93106 3769 C 3770 C References: 3771 C 1. Alan C. Hindmarsh, ODEPACK, A Systematized Collection of ODE 3772 C Solvers, in Scientific Computing, R. S. Stepleman et al. (Eds.), 3773 C North-Holland, Amsterdam, 1983, pp. 55-64. 3774 C 2. Linda R. Petzold, Automatic Selection of Methods for Solving 3775 C Stiff and Nonstiff Systems of Ordinary Differential Equations, 3776 C Siam J. Sci. Stat. Comput. 4 (1983), pp. 136-148. 3777 C----------------------------------------------------------------------- 3778 C Summary of Usage. 3779 C 3780 C Communication between the user and the DLSODA package, for normal 3781 C situations, is summarized here. This summary describes only a subset 3782 C of the full set of options available. See the full description for 3783 C details, including alternative treatment of the Jacobian matrix, 3784 C optional inputs and outputs, nonstandard options, and 3785 C instructions for special situations. See also the example 3786 C problem (with program and output) following this summary. 3787 C 3788 C A. First provide a subroutine of the form: 3789 C SUBROUTINE F (NEQ, T, Y, YDOT) 3790 C DOUBLE PRECISION T, Y(*), YDOT(*) 3791 C which supplies the vector function f by loading YDOT(i) with f(i). 3792 C 3793 C B. Write a main program which calls Subroutine DLSODA once for 3794 C each point at which answers are desired. This should also provide 3795 C for possible use of logical unit 6 for output of error messages 3796 C by DLSODA. On the first call to DLSODA, supply arguments as follows: 3797 C F = name of subroutine for right-hand side vector f. 3798 C This name must be declared External in calling program. 3799 C NEQ = number of first order ODEs. 3800 C Y = array of initial values, of length NEQ. 3801 C T = the initial value of the independent variable. 3802 C TOUT = first point where output is desired (.ne. T). 3803 C ITOL = 1 or 2 according as ATOL (below) is a scalar or array. 3804 C RTOL = relative tolerance parameter (scalar). 3805 C ATOL = absolute tolerance parameter (scalar or array). 3806 C the estimated local error in y(i) will be controlled so as 3807 C to be less than 3808 C EWT(i) = RTOL*ABS(Y(i)) + ATOL if ITOL = 1, or 3809 C EWT(i) = RTOL*ABS(Y(i)) + ATOL(i) if ITOL = 2. 3810 C Thus the local error test passes if, in each component, 3811 C either the absolute error is less than ATOL (or ATOL(i)), 3812 C or the relative error is less than RTOL. 3813 C Use RTOL = 0.0 for pure absolute error control, and 3814 C use ATOL = 0.0 (or ATOL(i) = 0.0) for pure relative error 3815 C control. Caution: actual (global) errors may exceed these 3816 C local tolerances, so choose them conservatively. 3817 C ITASK = 1 for normal computation of output values of y at t = TOUT. 3818 C ISTATE = integer flag (input and output). Set ISTATE = 1. 3819 C IOPT = 0 to indicate no optional inputs used. 3820 C RWORK = real work array of length at least: 3821 C 22 + NEQ * MAX(16, NEQ + 9). 3822 C See also Paragraph E below. 3823 C LRW = declared length of RWORK (in user's dimension). 3824 C IWORK = integer work array of length at least 20 + NEQ. 3825 C LIW = declared length of IWORK (in user's dimension). 3826 C JAC = name of subroutine for Jacobian matrix. 3827 C Use a dummy name. See also Paragraph E below. 3828 C JT = Jacobian type indicator. Set JT = 2. 3829 C See also Paragraph E below. 3830 C Note that the main program must declare arrays Y, RWORK, IWORK, 3831 C and possibly ATOL. 3832 C 3833 C C. The output from the first call (or any call) is: 3834 C Y = array of computed values of y(t) vector. 3835 C T = corresponding value of independent variable (normally TOUT). 3836 C ISTATE = 2 if DLSODA was successful, negative otherwise. 3837 C -1 means excess work done on this call (perhaps wrong JT). 3838 C -2 means excess accuracy requested (tolerances too small). 3839 C -3 means illegal input detected (see printed message). 3840 C -4 means repeated error test failures (check all inputs). 3841 C -5 means repeated convergence failures (perhaps bad Jacobian 3842 C supplied or wrong choice of JT or tolerances). 3843 C -6 means error weight became zero during problem. (Solution 3844 C component i vanished, and ATOL or ATOL(i) = 0.) 3845 C -7 means work space insufficient to finish (see messages). 3846 C 3847 C D. To continue the integration after a successful return, simply 3848 C reset TOUT and call DLSODA again. No other parameters need be reset. 3849 C 3850 C E. Note: If and when DLSODA regards the problem as stiff, and 3851 C switches methods accordingly, it must make use of the NEQ by NEQ 3852 C Jacobian matrix, J = df/dy. For the sake of simplicity, the 3853 C inputs to DLSODA recommended in Paragraph B above cause DLSODA to 3854 C treat J as a full matrix, and to approximate it internally by 3855 C difference quotients. Alternatively, J can be treated as a band 3856 C matrix (with great potential reduction in the size of the RWORK 3857 C array). Also, in either the full or banded case, the user can supply 3858 C J in closed form, with a routine whose name is passed as the JAC 3859 C argument. These alternatives are described in the paragraphs on 3860 C RWORK, JAC, and JT in the full description of the call sequence below. 3861 C 3862 C----------------------------------------------------------------------- 3863 C Example Problem. 3864 C 3865 C The following is a simple example problem, with the coding 3866 C needed for its solution by DLSODA. The problem is from chemical 3867 C kinetics, and consists of the following three rate equations: 3868 C dy1/dt = -.04*y1 + 1.e4*y2*y3 3869 C dy2/dt = .04*y1 - 1.e4*y2*y3 - 3.e7*y2**2 3870 C dy3/dt = 3.e7*y2**2 3871 C on the interval from t = 0.0 to t = 4.e10, with initial conditions 3872 C y1 = 1.0, y2 = y3 = 0. The problem is stiff. 3873 C 3874 C The following coding solves this problem with DLSODA, 3875 C printing results at t = .4, 4., ..., 4.e10. It uses 3876 C ITOL = 2 and ATOL much smaller for y2 than y1 or y3 because 3877 C y2 has much smaller values. 3878 C At the end of the run, statistical quantities of interest are 3879 C printed (see optional outputs in the full description below). 3880 C 3881 C EXTERNAL FEX 3882 C DOUBLE PRECISION ATOL, RTOL, RWORK, T, TOUT, Y 3883 C DIMENSION Y(3), ATOL(3), RWORK(70), IWORK(23) 3884 C NEQ = 3 3885 C Y(1) = 1. 3886 C Y(2) = 0. 3887 C Y(3) = 0. 3888 C T = 0. 3889 C TOUT = .4 3890 C ITOL = 2 3891 C RTOL = 1.D-4 3892 C ATOL(1) = 1.D-6 3893 C ATOL(2) = 1.D-10 3894 C ATOL(3) = 1.D-6 3895 C ITASK = 1 3896 C ISTATE = 1 3897 C IOPT = 0 3898 C LRW = 70 3899 C LIW = 23 3900 C JT = 2 3901 C DO 40 IOUT = 1,12 3902 C CALL DLSODA(FEX,NEQ,Y,T,TOUT,ITOL,RTOL,ATOL,ITASK,ISTATE, 3903 C 1 IOPT,RWORK,LRW,IWORK,LIW,JDUM,JT) 3904 C WRITE(6,20)T,Y(1),Y(2),Y(3) 3905 C 20 FORMAT(' At t =',D12.4,' Y =',3D14.6) 3906 C IF (ISTATE .LT. 0) GO TO 80 3907 C 40 TOUT = TOUT*10. 3908 C WRITE(6,60)IWORK(11),IWORK(12),IWORK(13),IWORK(19),RWORK(15) 3909 C 60 FORMAT(/' No. steps =',I4,' No. f-s =',I4,' No. J-s =',I4/ 3910 C 1 ' Method last used =',I2,' Last switch was at t =',D12.4) 3911 C STOP 3912 C 80 WRITE(6,90)ISTATE 3913 C 90 FORMAT(///' Error halt.. ISTATE =',I3) 3914 C STOP 3915 C END 3916 C 3917 C SUBROUTINE FEX (NEQ, T, Y, YDOT) 3918 C DOUBLE PRECISION T, Y, YDOT 3919 C DIMENSION Y(3), YDOT(3) 3920 C YDOT(1) = -.04*Y(1) + 1.D4*Y(2)*Y(3) 3921 C YDOT(3) = 3.D7*Y(2)*Y(2) 3922 C YDOT(2) = -YDOT(1) - YDOT(3) 3923 C RETURN 3924 C END 3925 C 3926 C The output of this program (on a CDC-7600 in single precision) 3927 C is as follows: 3928 C 3929 C At t = 4.0000e-01 y = 9.851712e-01 3.386380e-05 1.479493e-02 3930 C At t = 4.0000e+00 Y = 9.055333e-01 2.240655e-05 9.444430e-02 3931 C At t = 4.0000e+01 Y = 7.158403e-01 9.186334e-06 2.841505e-01 3932 C At t = 4.0000e+02 Y = 4.505250e-01 3.222964e-06 5.494717e-01 3933 C At t = 4.0000e+03 Y = 1.831975e-01 8.941774e-07 8.168016e-01 3934 C At t = 4.0000e+04 Y = 3.898730e-02 1.621940e-07 9.610125e-01 3935 C At t = 4.0000e+05 Y = 4.936363e-03 1.984221e-08 9.950636e-01 3936 C At t = 4.0000e+06 Y = 5.161831e-04 2.065786e-09 9.994838e-01 3937 C At t = 4.0000e+07 Y = 5.179817e-05 2.072032e-10 9.999482e-01 3938 C At t = 4.0000e+08 Y = 5.283401e-06 2.113371e-11 9.999947e-01 3939 C At t = 4.0000e+09 Y = 4.659031e-07 1.863613e-12 9.999995e-01 3940 C At t = 4.0000e+10 Y = 1.404280e-08 5.617126e-14 1.000000e+00 3941 C 3942 C No. steps = 361 No. f-s = 693 No. J-s = 64 3943 C Method last used = 2 Last switch was at t = 6.0092e-03 3944 C----------------------------------------------------------------------- 3945 C Full description of user interface to DLSODA. 3946 C 3947 C The user interface to DLSODA consists of the following parts. 3948 C 3949 C 1. The call sequence to Subroutine DLSODA, which is a driver 3950 C routine for the solver. This includes descriptions of both 3951 C the call sequence arguments and of user-supplied routines. 3952 C following these descriptions is a description of 3953 C optional inputs available through the call sequence, and then 3954 C a description of optional outputs (in the work arrays). 3955 C 3956 C 2. Descriptions of other routines in the DLSODA package that may be 3957 C (optionally) called by the user. These provide the ability to 3958 C alter error message handling, save and restore the internal 3959 C Common, and obtain specified derivatives of the solution y(t). 3960 C 3961 C 3. Descriptions of Common blocks to be declared in overlay 3962 C or similar environments, or to be saved when doing an interrupt 3963 C of the problem and continued solution later. 3964 C 3965 C 4. Description of a subroutine in the DLSODA package, 3966 C which the user may replace with his/her own version, if desired. 3967 C this relates to the measurement of errors. 3968 C 3969 C----------------------------------------------------------------------- 3970 C Part 1. Call Sequence. 3971 C 3972 C The call sequence parameters used for input only are 3973 C F, NEQ, TOUT, ITOL, RTOL, ATOL, ITASK, IOPT, LRW, LIW, JAC, JT, 3974 C and those used for both input and output are 3975 C Y, T, ISTATE. 3976 C The work arrays RWORK and IWORK are also used for conditional and 3977 C optional inputs and optional outputs. (The term output here refers 3978 C to the return from Subroutine DLSODA to the user's calling program.) 3979 C 3980 C The legality of input parameters will be thoroughly checked on the 3981 C initial call for the problem, but not checked thereafter unless a 3982 C change in input parameters is flagged by ISTATE = 3 on input. 3983 C 3984 C The descriptions of the call arguments are as follows. 3985 C 3986 C F = the name of the user-supplied subroutine defining the 3987 C ODE system. The system must be put in the first-order 3988 C form dy/dt = f(t,y), where f is a vector-valued function 3989 C of the scalar t and the vector y. Subroutine F is to 3990 C compute the function f. It is to have the form 3991 C SUBROUTINE F (NEQ, T, Y, YDOT) 3992 C DOUBLE PRECISION T, Y(*), YDOT(*) 3993 C where NEQ, T, and Y are input, and the array YDOT = f(t,y) 3994 C is output. Y and YDOT are arrays of length NEQ. 3995 C Subroutine F should not alter Y(1),...,Y(NEQ). 3996 C F must be declared External in the calling program. 3997 C 3998 C Subroutine F may access user-defined quantities in 3999 C NEQ(2),... and/or in Y(NEQ(1)+1),... if NEQ is an array 4000 C (dimensioned in F) and/or Y has length exceeding NEQ(1). 4001 C See the descriptions of NEQ and Y below. 4002 C 4003 C If quantities computed in the F routine are needed 4004 C externally to DLSODA, an extra call to F should be made 4005 C for this purpose, for consistent and accurate results. 4006 C If only the derivative dy/dt is needed, use DINTDY instead. 4007 C 4008 C NEQ = the size of the ODE system (number of first order 4009 C ordinary differential equations). Used only for input. 4010 C NEQ may be decreased, but not increased, during the problem. 4011 C If NEQ is decreased (with ISTATE = 3 on input), the 4012 C remaining components of Y should be left undisturbed, if 4013 C these are to be accessed in F and/or JAC. 4014 C 4015 C Normally, NEQ is a scalar, and it is generally referred to 4016 C as a scalar in this user interface description. However, 4017 C NEQ may be an array, with NEQ(1) set to the system size. 4018 C (The DLSODA package accesses only NEQ(1).) In either case, 4019 C this parameter is passed as the NEQ argument in all calls 4020 C to F and JAC. Hence, if it is an array, locations 4021 C NEQ(2),... may be used to store other integer data and pass 4022 C it to F and/or JAC. Subroutines F and/or JAC must include 4023 C NEQ in a Dimension statement in that case. 4024 C 4025 C Y = a real array for the vector of dependent variables, of 4026 C length NEQ or more. Used for both input and output on the 4027 C first call (ISTATE = 1), and only for output on other calls. 4028 C On the first call, Y must contain the vector of initial 4029 C values. On output, Y contains the computed solution vector, 4030 C evaluated at T. If desired, the Y array may be used 4031 C for other purposes between calls to the solver. 4032 C 4033 C This array is passed as the Y argument in all calls to 4034 C F and JAC. Hence its length may exceed NEQ, and locations 4035 C Y(NEQ+1),... may be used to store other real data and 4036 C pass it to F and/or JAC. (The DLSODA package accesses only 4037 C Y(1),...,Y(NEQ).) 4038 C 4039 C T = the independent variable. On input, T is used only on the 4040 C first call, as the initial point of the integration. 4041 C on output, after each call, T is the value at which a 4042 C computed solution Y is evaluated (usually the same as TOUT). 4043 C on an error return, T is the farthest point reached. 4044 C 4045 C TOUT = the next value of t at which a computed solution is desired. 4046 C Used only for input. 4047 C 4048 C When starting the problem (ISTATE = 1), TOUT may be equal 4049 C to T for one call, then should .ne. T for the next call. 4050 C For the initial t, an input value of TOUT .ne. T is used 4051 C in order to determine the direction of the integration 4052 C (i.e. the algebraic sign of the step sizes) and the rough 4053 C scale of the problem. Integration in either direction 4054 C (forward or backward in t) is permitted. 4055 C 4056 C If ITASK = 2 or 5 (one-step modes), TOUT is ignored after 4057 C the first call (i.e. the first call with TOUT .ne. T). 4058 C Otherwise, TOUT is required on every call. 4059 C 4060 C If ITASK = 1, 3, or 4, the values of TOUT need not be 4061 C monotone, but a value of TOUT which backs up is limited 4062 C to the current internal T interval, whose endpoints are 4063 C TCUR - HU and TCUR (see optional outputs, below, for 4064 C TCUR and HU). 4065 C 4066 C ITOL = an indicator for the type of error control. See 4067 C description below under ATOL. Used only for input. 4068 C 4069 C RTOL = a relative error tolerance parameter, either a scalar or 4070 C an array of length NEQ. See description below under ATOL. 4071 C Input only. 4072 C 4073 C ATOL = an absolute error tolerance parameter, either a scalar or 4074 C an array of length NEQ. Input only. 4075 C 4076 C The input parameters ITOL, RTOL, and ATOL determine 4077 C the error control performed by the solver. The solver will 4078 C control the vector E = (E(i)) of estimated local errors 4079 C in y, according to an inequality of the form 4080 C max-norm of ( E(i)/EWT(i) ) .le. 1, 4081 C where EWT = (EWT(i)) is a vector of positive error weights. 4082 C The values of RTOL and ATOL should all be non-negative. 4083 C The following table gives the types (scalar/array) of 4084 C RTOL and ATOL, and the corresponding form of EWT(i). 4085 C 4086 C ITOL RTOL ATOL EWT(i) 4087 C 1 scalar scalar RTOL*ABS(Y(i)) + ATOL 4088 C 2 scalar array RTOL*ABS(Y(i)) + ATOL(i) 4089 C 3 array scalar RTOL(i)*ABS(Y(i)) + ATOL 4090 C 4 array array RTOL(i)*ABS(Y(i)) + ATOL(i) 4091 C 4092 C When either of these parameters is a scalar, it need not 4093 C be dimensioned in the user's calling program. 4094 C 4095 C If none of the above choices (with ITOL, RTOL, and ATOL 4096 C fixed throughout the problem) is suitable, more general 4097 C error controls can be obtained by substituting a 4098 C user-supplied routine for the setting of EWT. 4099 C See Part 4 below. 4100 C 4101 C If global errors are to be estimated by making a repeated 4102 C run on the same problem with smaller tolerances, then all 4103 C components of RTOL and ATOL (i.e. of EWT) should be scaled 4104 C down uniformly. 4105 C 4106 C ITASK = an index specifying the task to be performed. 4107 C Input only. ITASK has the following values and meanings. 4108 C 1 means normal computation of output values of y(t) at 4109 C t = TOUT (by overshooting and interpolating). 4110 C 2 means take one step only and return. 4111 C 3 means stop at the first internal mesh point at or 4112 C beyond t = TOUT and return. 4113 C 4 means normal computation of output values of y(t) at 4114 C t = TOUT but without overshooting t = TCRIT. 4115 C TCRIT must be input as RWORK(1). TCRIT may be equal to 4116 C or beyond TOUT, but not behind it in the direction of 4117 C integration. This option is useful if the problem 4118 C has a singularity at or beyond t = TCRIT. 4119 C 5 means take one step, without passing TCRIT, and return. 4120 C TCRIT must be input as RWORK(1). 4121 C 4122 C Note: If ITASK = 4 or 5 and the solver reaches TCRIT 4123 C (within roundoff), it will return T = TCRIT (exactly) to 4124 C indicate this (unless ITASK = 4 and TOUT comes before TCRIT, 4125 C in which case answers at t = TOUT are returned first). 4126 C 4127 C ISTATE = an index used for input and output to specify the 4128 C the state of the calculation. 4129 C 4130 C On input, the values of ISTATE are as follows. 4131 C 1 means this is the first call for the problem 4132 C (initializations will be done). See note below. 4133 C 2 means this is not the first call, and the calculation 4134 C is to continue normally, with no change in any input 4135 C parameters except possibly TOUT and ITASK. 4136 C (If ITOL, RTOL, and/or ATOL are changed between calls 4137 C with ISTATE = 2, the new values will be used but not 4138 C tested for legality.) 4139 C 3 means this is not the first call, and the 4140 C calculation is to continue normally, but with 4141 C a change in input parameters other than 4142 C TOUT and ITASK. Changes are allowed in 4143 C NEQ, ITOL, RTOL, ATOL, IOPT, LRW, LIW, JT, ML, MU, 4144 C and any optional inputs except H0, MXORDN, and MXORDS. 4145 C (See IWORK description for ML and MU.) 4146 C Note: A preliminary call with TOUT = T is not counted 4147 C as a first call here, as no initialization or checking of 4148 C input is done. (Such a call is sometimes useful for the 4149 C purpose of outputting the initial conditions.) 4150 C Thus the first call for which TOUT .ne. T requires 4151 C ISTATE = 1 on input. 4152 C 4153 C On output, ISTATE has the following values and meanings. 4154 C 1 means nothing was done; TOUT = T and ISTATE = 1 on input. 4155 C 2 means the integration was performed successfully. 4156 C -1 means an excessive amount of work (more than MXSTEP 4157 C steps) was done on this call, before completing the 4158 C requested task, but the integration was otherwise 4159 C successful as far as T. (MXSTEP is an optional input 4160 C and is normally 500.) To continue, the user may 4161 C simply reset ISTATE to a value .gt. 1 and call again 4162 C (the excess work step counter will be reset to 0). 4163 C In addition, the user may increase MXSTEP to avoid 4164 C this error return (see below on optional inputs). 4165 C -2 means too much accuracy was requested for the precision 4166 C of the machine being used. This was detected before 4167 C completing the requested task, but the integration 4168 C was successful as far as T. To continue, the tolerance 4169 C parameters must be reset, and ISTATE must be set 4170 C to 3. The optional output TOLSF may be used for this 4171 C purpose. (Note: If this condition is detected before 4172 C taking any steps, then an illegal input return 4173 C (ISTATE = -3) occurs instead.) 4174 C -3 means illegal input was detected, before taking any 4175 C integration steps. See written message for details. 4176 C Note: If the solver detects an infinite loop of calls 4177 C to the solver with illegal input, it will cause 4178 C the run to stop. 4179 C -4 means there were repeated error test failures on 4180 C one attempted step, before completing the requested 4181 C task, but the integration was successful as far as T. 4182 C The problem may have a singularity, or the input 4183 C may be inappropriate. 4184 C -5 means there were repeated convergence test failures on 4185 C one attempted step, before completing the requested 4186 C task, but the integration was successful as far as T. 4187 C This may be caused by an inaccurate Jacobian matrix, 4188 C if one is being used. 4189 C -6 means EWT(i) became zero for some i during the 4190 C integration. Pure relative error control (ATOL(i)=0.0) 4191 C was requested on a variable which has now vanished. 4192 C The integration was successful as far as T. 4193 C -7 means the length of RWORK and/or IWORK was too small to 4194 C proceed, but the integration was successful as far as T. 4195 C This happens when DLSODA chooses to switch methods 4196 C but LRW and/or LIW is too small for the new method. 4197 C 4198 C Note: Since the normal output value of ISTATE is 2, 4199 C it does not need to be reset for normal continuation. 4200 C Also, since a negative input value of ISTATE will be 4201 C regarded as illegal, a negative output value requires the 4202 C user to change it, and possibly other inputs, before 4203 C calling the solver again. 4204 C 4205 C IOPT = an integer flag to specify whether or not any optional 4206 C inputs are being used on this call. Input only. 4207 C The optional inputs are listed separately below. 4208 C IOPT = 0 means no optional inputs are being used. 4209 C default values will be used in all cases. 4210 C IOPT = 1 means one or more optional inputs are being used. 4211 C 4212 C RWORK = a real array (double precision) for work space, and (in the 4213 C first 20 words) for conditional and optional inputs and 4214 C optional outputs. 4215 C As DLSODA switches automatically between stiff and nonstiff 4216 C methods, the required length of RWORK can change during the 4217 C problem. Thus the RWORK array passed to DLSODA can either 4218 C have a static (fixed) length large enough for both methods, 4219 C or have a dynamic (changing) length altered by the calling 4220 C program in response to output from DLSODA. 4221 C 4222 C --- Fixed Length Case --- 4223 C If the RWORK length is to be fixed, it should be at least 4224 C MAX (LRN, LRS), 4225 C where LRN and LRS are the RWORK lengths required when the 4226 C current method is nonstiff or stiff, respectively. 4227 C 4228 C The separate RWORK length requirements LRN and LRS are 4229 C as follows: 4230 C IF NEQ is constant and the maximum method orders have 4231 C their default values, then 4232 C LRN = 20 + 16*NEQ, 4233 C LRS = 22 + 9*NEQ + NEQ**2 if JT = 1 or 2, 4234 C LRS = 22 + 10*NEQ + (2*ML+MU)*NEQ if JT = 4 or 5. 4235 C Under any other conditions, LRN and LRS are given by: 4236 C LRN = 20 + NYH*(MXORDN+1) + 3*NEQ, 4237 C LRS = 20 + NYH*(MXORDS+1) + 3*NEQ + LMAT, 4238 C where 4239 C NYH = the initial value of NEQ, 4240 C MXORDN = 12, unless a smaller value is given as an 4241 C optional input, 4242 C MXORDS = 5, unless a smaller value is given as an 4243 C optional input, 4244 C LMAT = length of matrix work space: 4245 C LMAT = NEQ**2 + 2 if JT = 1 or 2, 4246 C LMAT = (2*ML + MU + 1)*NEQ + 2 if JT = 4 or 5. 4247 C 4248 C --- Dynamic Length Case --- 4249 C If the length of RWORK is to be dynamic, then it should 4250 C be at least LRN or LRS, as defined above, depending on the 4251 C current method. Initially, it must be at least LRN (since 4252 C DLSODA starts with the nonstiff method). On any return 4253 C from DLSODA, the optional output MCUR indicates the current 4254 C method. If MCUR differs from the value it had on the 4255 C previous return, or if there has only been one call to 4256 C DLSODA and MCUR is now 2, then DLSODA has switched 4257 C methods during the last call, and the length of RWORK 4258 C should be reset (to LRN if MCUR = 1, or to LRS if 4259 C MCUR = 2). (An increase in the RWORK length is required 4260 C if DLSODA returned ISTATE = -7, but not otherwise.) 4261 C After resetting the length, call DLSODA with ISTATE = 3 4262 C to signal that change. 4263 C 4264 C LRW = the length of the array RWORK, as declared by the user. 4265 C (This will be checked by the solver.) 4266 C 4267 C IWORK = an integer array for work space. 4268 C As DLSODA switches automatically between stiff and nonstiff 4269 C methods, the required length of IWORK can change during 4270 C problem, between 4271 C LIS = 20 + NEQ and LIN = 20, 4272 C respectively. Thus the IWORK array passed to DLSODA can 4273 C either have a fixed length of at least 20 + NEQ, or have a 4274 C dynamic length of at least LIN or LIS, depending on the 4275 C current method. The comments on dynamic length under 4276 C RWORK above apply here. Initially, this length need 4277 C only be at least LIN = 20. 4278 C 4279 C The first few words of IWORK are used for conditional and 4280 C optional inputs and optional outputs. 4281 C 4282 C The following 2 words in IWORK are conditional inputs: 4283 C IWORK(1) = ML these are the lower and upper 4284 C IWORK(2) = MU half-bandwidths, respectively, of the 4285 C banded Jacobian, excluding the main diagonal. 4286 C The band is defined by the matrix locations 4287 C (i,j) with i-ML .le. j .le. i+MU. ML and MU 4288 C must satisfy 0 .le. ML,MU .le. NEQ-1. 4289 C These are required if JT is 4 or 5, and 4290 C ignored otherwise. ML and MU may in fact be 4291 C the band parameters for a matrix to which 4292 C df/dy is only approximately equal. 4293 C 4294 C LIW = the length of the array IWORK, as declared by the user. 4295 C (This will be checked by the solver.) 4296 C 4297 C Note: The base addresses of the work arrays must not be 4298 C altered between calls to DLSODA for the same problem. 4299 C The contents of the work arrays must not be altered 4300 C between calls, except possibly for the conditional and 4301 C optional inputs, and except for the last 3*NEQ words of RWORK. 4302 C The latter space is used for internal scratch space, and so is 4303 C available for use by the user outside DLSODA between calls, if 4304 C desired (but not for use by F or JAC). 4305 C 4306 C JAC = the name of the user-supplied routine to compute the 4307 C Jacobian matrix, df/dy, if JT = 1 or 4. The JAC routine 4308 C is optional, but if the problem is expected to be stiff much 4309 C of the time, you are encouraged to supply JAC, for the sake 4310 C of efficiency. (Alternatively, set JT = 2 or 5 to have 4311 C DLSODA compute df/dy internally by difference quotients.) 4312 C If and when DLSODA uses df/dy, it treats this NEQ by NEQ 4313 C matrix either as full (JT = 1 or 2), or as banded (JT = 4314 C 4 or 5) with half-bandwidths ML and MU (discussed under 4315 C IWORK above). In either case, if JT = 1 or 4, the JAC 4316 C routine must compute df/dy as a function of the scalar t 4317 C and the vector y. It is to have the form 4318 C SUBROUTINE JAC (NEQ, T, Y, ML, MU, PD, NROWPD) 4319 C DOUBLE PRECISION T, Y(*), PD(NROWPD,*) 4320 C where NEQ, T, Y, ML, MU, and NROWPD are input and the array 4321 C PD is to be loaded with partial derivatives (elements of 4322 C the Jacobian matrix) on output. PD must be given a first 4323 C dimension of NROWPD. T and Y have the same meaning as in 4324 C Subroutine F. 4325 C In the full matrix case (JT = 1), ML and MU are 4326 C ignored, and the Jacobian is to be loaded into PD in 4327 C columnwise manner, with df(i)/dy(j) loaded into PD(i,j). 4328 C In the band matrix case (JT = 4), the elements 4329 C within the band are to be loaded into PD in columnwise 4330 C manner, with diagonal lines of df/dy loaded into the rows 4331 C of PD. Thus df(i)/dy(j) is to be loaded into PD(i-j+MU+1,j). 4332 C ML and MU are the half-bandwidth parameters (see IWORK). 4333 C The locations in PD in the two triangular areas which 4334 C correspond to nonexistent matrix elements can be ignored 4335 C or loaded arbitrarily, as they are overwritten by DLSODA. 4336 C JAC need not provide df/dy exactly. A crude 4337 C approximation (possibly with a smaller bandwidth) will do. 4338 C In either case, PD is preset to zero by the solver, 4339 C so that only the nonzero elements need be loaded by JAC. 4340 C Each call to JAC is preceded by a call to F with the same 4341 C arguments NEQ, T, and Y. Thus to gain some efficiency, 4342 C intermediate quantities shared by both calculations may be 4343 C saved in a user Common block by F and not recomputed by JAC, 4344 C if desired. Also, JAC may alter the Y array, if desired. 4345 C JAC must be declared External in the calling program. 4346 C Subroutine JAC may access user-defined quantities in 4347 C NEQ(2),... and/or in Y(NEQ(1)+1),... if NEQ is an array 4348 C (dimensioned in JAC) and/or Y has length exceeding NEQ(1). 4349 C See the descriptions of NEQ and Y above. 4350 C 4351 C JT = Jacobian type indicator. Used only for input. 4352 C JT specifies how the Jacobian matrix df/dy will be 4353 C treated, if and when DLSODA requires this matrix. 4354 C JT has the following values and meanings: 4355 C 1 means a user-supplied full (NEQ by NEQ) Jacobian. 4356 C 2 means an internally generated (difference quotient) full 4357 C Jacobian (using NEQ extra calls to F per df/dy value). 4358 C 4 means a user-supplied banded Jacobian. 4359 C 5 means an internally generated banded Jacobian (using 4360 C ML+MU+1 extra calls to F per df/dy evaluation). 4361 C If JT = 1 or 4, the user must supply a Subroutine JAC 4362 C (the name is arbitrary) as described above under JAC. 4363 C If JT = 2 or 5, a dummy argument can be used. 4364 C----------------------------------------------------------------------- 4365 C Optional Inputs. 4366 C 4367 C The following is a list of the optional inputs provided for in the 4368 C call sequence. (See also Part 2.) For each such input variable, 4369 C this table lists its name as used in this documentation, its 4370 C location in the call sequence, its meaning, and the default value. 4371 C The use of any of these inputs requires IOPT = 1, and in that 4372 C case all of these inputs are examined. A value of zero for any 4373 C of these optional inputs will cause the default value to be used. 4374 C Thus to use a subset of the optional inputs, simply preload 4375 C locations 5 to 10 in RWORK and IWORK to 0.0 and 0 respectively, and 4376 C then set those of interest to nonzero values. 4377 C 4378 C Name Location Meaning and Default Value 4379 C 4380 C H0 RWORK(5) the step size to be attempted on the first step. 4381 C The default value is determined by the solver. 4382 C 4383 C HMAX RWORK(6) the maximum absolute step size allowed. 4384 C The default value is infinite. 4385 C 4386 C HMIN RWORK(7) the minimum absolute step size allowed. 4387 C The default value is 0. (This lower bound is not 4388 C enforced on the final step before reaching TCRIT 4389 C when ITASK = 4 or 5.) 4390 C 4391 C IXPR IWORK(5) flag to generate extra printing at method switches. 4392 C IXPR = 0 means no extra printing (the default). 4393 C IXPR = 1 means print data on each switch. 4394 C T, H, and NST will be printed on the same logical 4395 C unit as used for error messages. 4396 C 4397 C MXSTEP IWORK(6) maximum number of (internally defined) steps 4398 C allowed during one call to the solver. 4399 C The default value is 500. 4400 C 4401 C MXHNIL IWORK(7) maximum number of messages printed (per problem) 4402 C warning that T + H = T on a step (H = step size). 4403 C This must be positive to result in a non-default 4404 C value. The default value is 10. 4405 C 4406 C MXORDN IWORK(8) the maximum order to be allowed for the nonstiff 4407 C (Adams) method. the default value is 12. 4408 C if MXORDN exceeds the default value, it will 4409 C be reduced to the default value. 4410 C MXORDN is held constant during the problem. 4411 C 4412 C MXORDS IWORK(9) the maximum order to be allowed for the stiff 4413 C (BDF) method. The default value is 5. 4414 C If MXORDS exceeds the default value, it will 4415 C be reduced to the default value. 4416 C MXORDS is held constant during the problem. 4417 C----------------------------------------------------------------------- 4418 C Optional Outputs. 4419 C 4420 C As optional additional output from DLSODA, the variables listed 4421 C below are quantities related to the performance of DLSODA 4422 C which are available to the user. These are communicated by way of 4423 C the work arrays, but also have internal mnemonic names as shown. 4424 C except where stated otherwise, all of these outputs are defined 4425 C on any successful return from DLSODA, and on any return with 4426 C ISTATE = -1, -2, -4, -5, or -6. On an illegal input return 4427 C (ISTATE = -3), they will be unchanged from their existing values 4428 C (if any), except possibly for TOLSF, LENRW, and LENIW. 4429 C On any error return, outputs relevant to the error will be defined, 4430 C as noted below. 4431 C 4432 C Name Location Meaning 4433 C 4434 C HU RWORK(11) the step size in t last used (successfully). 4435 C 4436 C HCUR RWORK(12) the step size to be attempted on the next step. 4437 C 4438 C TCUR RWORK(13) the current value of the independent variable 4439 C which the solver has actually reached, i.e. the 4440 C current internal mesh point in t. On output, TCUR 4441 C will always be at least as far as the argument 4442 C T, but may be farther (if interpolation was done). 4443 C 4444 C TOLSF RWORK(14) a tolerance scale factor, greater than 1.0, 4445 C computed when a request for too much accuracy was 4446 C detected (ISTATE = -3 if detected at the start of 4447 C the problem, ISTATE = -2 otherwise). If ITOL is 4448 C left unaltered but RTOL and ATOL are uniformly 4449 C scaled up by a factor of TOLSF for the next call, 4450 C then the solver is deemed likely to succeed. 4451 C (The user may also ignore TOLSF and alter the 4452 C tolerance parameters in any other way appropriate.) 4453 C 4454 C TSW RWORK(15) the value of t at the time of the last method 4455 C switch, if any. 4456 C 4457 C NST IWORK(11) the number of steps taken for the problem so far. 4458 C 4459 C NFE IWORK(12) the number of f evaluations for the problem so far. 4460 C 4461 C NJE IWORK(13) the number of Jacobian evaluations (and of matrix 4462 C LU decompositions) for the problem so far. 4463 C 4464 C NQU IWORK(14) the method order last used (successfully). 4465 C 4466 C NQCUR IWORK(15) the order to be attempted on the next step. 4467 C 4468 C IMXER IWORK(16) the index of the component of largest magnitude in 4469 C the weighted local error vector ( E(i)/EWT(i) ), 4470 C on an error return with ISTATE = -4 or -5. 4471 C 4472 C LENRW IWORK(17) the length of RWORK actually required, assuming 4473 C that the length of RWORK is to be fixed for the 4474 C rest of the problem, and that switching may occur. 4475 C This is defined on normal returns and on an illegal 4476 C input return for insufficient storage. 4477 C 4478 C LENIW IWORK(18) the length of IWORK actually required, assuming 4479 C that the length of IWORK is to be fixed for the 4480 C rest of the problem, and that switching may occur. 4481 C This is defined on normal returns and on an illegal 4482 C input return for insufficient storage. 4483 C 4484 C MUSED IWORK(19) the method indicator for the last successful step: 4485 C 1 means Adams (nonstiff), 2 means BDF (stiff). 4486 C 4487 C MCUR IWORK(20) the current method indicator: 4488 C 1 means Adams (nonstiff), 2 means BDF (stiff). 4489 C This is the method to be attempted 4490 C on the next step. Thus it differs from MUSED 4491 C only if a method switch has just been made. 4492 C 4493 C The following two arrays are segments of the RWORK array which 4494 C may also be of interest to the user as optional outputs. 4495 C For each array, the table below gives its internal name, 4496 C its base address in RWORK, and its description. 4497 C 4498 C Name Base Address Description 4499 C 4500 C YH 21 the Nordsieck history array, of size NYH by 4501 C (NQCUR + 1), where NYH is the initial value 4502 C of NEQ. For j = 0,1,...,NQCUR, column j+1 4503 C of YH contains HCUR**j/factorial(j) times 4504 C the j-th derivative of the interpolating 4505 C polynomial currently representing the solution, 4506 C evaluated at T = TCUR. 4507 C 4508 C ACOR LACOR array of size NEQ used for the accumulated 4509 C (from Common corrections on each step, scaled on output 4510 C as noted) to represent the estimated local error in y 4511 C on the last step. This is the vector E in 4512 C the description of the error control. It is 4513 C defined only on a successful return from 4514 C DLSODA. The base address LACOR is obtained by 4515 C including in the user's program the 4516 C following 2 lines: 4517 C COMMON /DLS001/ RLS(218), ILS(37) 4518 C LACOR = ILS(22) 4519 C 4520 C----------------------------------------------------------------------- 4521 C Part 2. Other Routines Callable. 4522 C 4523 C The following are optional calls which the user may make to 4524 C gain additional capabilities in conjunction with DLSODA. 4525 C (The routines XSETUN and XSETF are designed to conform to the 4526 C SLATEC error handling package.) 4527 C 4528 C Form of Call Function 4529 C CALL XSETUN(LUN) set the logical unit number, LUN, for 4530 C output of messages from DLSODA, if 4531 C the default is not desired. 4532 C The default value of LUN is 6. 4533 C 4534 C CALL XSETF(MFLAG) set a flag to control the printing of 4535 C messages by DLSODA. 4536 C MFLAG = 0 means do not print. (Danger: 4537 C This risks losing valuable information.) 4538 C MFLAG = 1 means print (the default). 4539 C 4540 C Either of the above calls may be made at 4541 C any time and will take effect immediately. 4542 C 4543 C CALL DSRCMA(RSAV,ISAV,JOB) saves and restores the contents of 4544 C the internal Common blocks used by 4545 C DLSODA (see Part 3 below). 4546 C RSAV must be a real array of length 240 4547 C or more, and ISAV must be an integer 4548 C array of length 46 or more. 4549 C JOB=1 means save Common into RSAV/ISAV. 4550 C JOB=2 means restore Common from RSAV/ISAV. 4551 C DSRCMA is useful if one is 4552 C interrupting a run and restarting 4553 C later, or alternating between two or 4554 C more problems solved with DLSODA. 4555 C 4556 C CALL DINTDY(,,,,,) provide derivatives of y, of various 4557 C (see below) orders, at a specified point t, if 4558 C desired. It may be called only after 4559 C a successful return from DLSODA. 4560 C 4561 C The detailed instructions for using DINTDY are as follows. 4562 C The form of the call is: 4563 C 4564 C CALL DINTDY (T, K, RWORK(21), NYH, DKY, IFLAG) 4565 C 4566 C The input parameters are: 4567 C 4568 C T = value of independent variable where answers are desired 4569 C (normally the same as the T last returned by DLSODA). 4570 C For valid results, T must lie between TCUR - HU and TCUR. 4571 C (See optional outputs for TCUR and HU.) 4572 C K = integer order of the derivative desired. K must satisfy 4573 C 0 .le. K .le. NQCUR, where NQCUR is the current order 4574 C (see optional outputs). The capability corresponding 4575 C to K = 0, i.e. computing y(T), is already provided 4576 C by DLSODA directly. Since NQCUR .ge. 1, the first 4577 C derivative dy/dt is always available with DINTDY. 4578 C RWORK(21) = the base address of the history array YH. 4579 C NYH = column length of YH, equal to the initial value of NEQ. 4580 C 4581 C The output parameters are: 4582 C 4583 C DKY = a real array of length NEQ containing the computed value 4584 C of the K-th derivative of y(t). 4585 C IFLAG = integer flag, returned as 0 if K and T were legal, 4586 C -1 if K was illegal, and -2 if T was illegal. 4587 C On an error return, a message is also written. 4588 C----------------------------------------------------------------------- 4589 C Part 3. Common Blocks. 4590 C 4591 C If DLSODA is to be used in an overlay situation, the user 4592 C must declare, in the primary overlay, the variables in: 4593 C (1) the call sequence to DLSODA, and 4594 C (2) the two internal Common blocks 4595 C /DLS001/ of length 255 (218 double precision words 4596 C followed by 37 integer words), 4597 C /DLSA01/ of length 31 (22 double precision words 4598 C followed by 9 integer words). 4599 C 4600 C If DLSODA is used on a system in which the contents of internal 4601 C Common blocks are not preserved between calls, the user should 4602 C declare the above Common blocks in the calling program to insure 4603 C that their contents are preserved. 4604 C 4605 C If the solution of a given problem by DLSODA is to be interrupted 4606 C and then later continued, such as when restarting an interrupted run 4607 C or alternating between two or more problems, the user should save, 4608 C following the return from the last DLSODA call prior to the 4609 C interruption, the contents of the call sequence variables and the 4610 C internal Common blocks, and later restore these values before the 4611 C next DLSODA call for that problem. To save and restore the Common 4612 C blocks, use Subroutine DSRCMA (see Part 2 above). 4613 C 4614 C----------------------------------------------------------------------- 4615 C Part 4. Optionally Replaceable Solver Routines. 4616 C 4617 C Below is a description of a routine in the DLSODA package which 4618 C relates to the measurement of errors, and can be 4619 C replaced by a user-supplied version, if desired. However, since such 4620 C a replacement may have a major impact on performance, it should be 4621 C done only when absolutely necessary, and only with great caution. 4622 C (Note: The means by which the package version of a routine is 4623 C superseded by the user's version may be system-dependent.) 4624 C 4625 C (a) DEWSET. 4626 C The following subroutine is called just before each internal 4627 C integration step, and sets the array of error weights, EWT, as 4628 C described under ITOL/RTOL/ATOL above: 4629 C Subroutine DEWSET (NEQ, ITOL, RTOL, ATOL, YCUR, EWT) 4630 C where NEQ, ITOL, RTOL, and ATOL are as in the DLSODA call sequence, 4631 C YCUR contains the current dependent variable vector, and 4632 C EWT is the array of weights set by DEWSET. 4633 C 4634 C If the user supplies this subroutine, it must return in EWT(i) 4635 C (i = 1,...,NEQ) a positive quantity suitable for comparing errors 4636 C in y(i) to. The EWT array returned by DEWSET is passed to the 4637 C DMNORM routine, and also used by DLSODA in the computation 4638 C of the optional output IMXER, and the increments for difference 4639 C quotient Jacobians. 4640 C 4641 C In the user-supplied version of DEWSET, it may be desirable to use 4642 C the current values of derivatives of y. Derivatives up to order NQ 4643 C are available from the history array YH, described above under 4644 C optional outputs. In DEWSET, YH is identical to the YCUR array, 4645 C extended to NQ + 1 columns with a column length of NYH and scale 4646 C factors of H**j/factorial(j). On the first call for the problem, 4647 C given by NST = 0, NQ is 1 and H is temporarily set to 1.0. 4648 C NYH is the initial value of NEQ. The quantities NQ, H, and NST 4649 C can be obtained by including in DEWSET the statements: 4650 C DOUBLE PRECISION RLS 4651 C COMMON /DLS001/ RLS(218),ILS(37) 4652 C NQ = ILS(33) 4653 C NST = ILS(34) 4654 C H = RLS(212) 4655 C Thus, for example, the current value of dy/dt can be obtained as 4656 C YCUR(NYH+i)/H (i=1,...,NEQ) (and the division by H is 4657 C unnecessary when NST = 0). 4658 C----------------------------------------------------------------------- 4659 C 4660 C***REVISION HISTORY (YYYYMMDD) 4661 C 19811102 DATE WRITTEN 4662 C 19820126 Fixed bug in tests of work space lengths; 4663 C minor corrections in main prologue and comments. 4664 C 19870330 Major update: corrected comments throughout; 4665 C removed TRET from Common; rewrote EWSET with 4 loops; 4666 C fixed t test in INTDY; added Cray directives in STODA; 4667 C in STODA, fixed DELP init. and logic around PJAC call; 4668 C combined routines to save/restore Common; 4669 C passed LEVEL = 0 in error message calls (except run abort). 4670 C 19970225 Fixed lines setting JSTART = -2 in Subroutine LSODA. 4671 C 20010425 Major update: convert source lines to upper case; 4672 C added *DECK lines; changed from 1 to * in dummy dimensions; 4673 C changed names R1MACH/D1MACH to RUMACH/DUMACH; 4674 C renamed routines for uniqueness across single/double prec.; 4675 C converted intrinsic names to generic form; 4676 C removed ILLIN and NTREP (data loaded) from Common; 4677 C removed all 'own' variables from Common; 4678 C changed error messages to quoted strings; 4679 C replaced XERRWV/XERRWD with 1993 revised version; 4680 C converted prologues, comments, error messages to mixed case; 4681 C numerous corrections to prologues and internal comments. 4682 C 20010507 Converted single precision source to double precision. 4683 C 20010613 Revised excess accuracy test (to match rest of ODEPACK). 4684 C 20010808 Fixed bug in DPRJA (matrix in DBNORM call). 4685 C 20020502 Corrected declarations in descriptions of user routines. 4686 C 20031105 Restored 'own' variables to Common blocks, to enable 4687 C interrupt/restart feature. 4688 C 20031112 Added SAVE statements for data-loaded constants. 4689 C 4690 C----------------------------------------------------------------------- 4691 C Other routines in the DLSODA package. 4692 C 4693 C In addition to Subroutine DLSODA, the DLSODA package includes the 4694 C following subroutines and function routines: 4695 C DINTDY computes an interpolated value of the y vector at t = TOUT. 4696 C DSTODA is the core integrator, which does one step of the 4697 C integration and the associated error control. 4698 C DCFODE sets all method coefficients and test constants. 4699 C DPRJA computes and preprocesses the Jacobian matrix J = df/dy 4700 C and the Newton iteration matrix P = I - h*l0*J. 4701 C DSOLSY manages solution of linear system in chord iteration. 4702 C DEWSET sets the error weight vector EWT before each step. 4703 C DMNORM computes the weighted max-norm of a vector. 4704 C DFNORM computes the norm of a full matrix consistent with the 4705 C weighted max-norm on vectors. 4706 C DBNORM computes the norm of a band matrix consistent with the 4707 C weighted max-norm on vectors. 4708 C DSRCMA is a user-callable routine to save and restore 4709 C the contents of the internal Common blocks. 4710 C DGEFA and DGESL are routines from LINPACK for solving full 4711 C systems of linear algebraic equations. 4712 C DGBFA and DGBSL are routines from LINPACK for solving banded 4713 C linear systems. 4714 C DUMACH computes the unit roundoff in a machine-independent manner. 4715 C XERRWD, XSETUN, XSETF, IXSAV, and IUMACH handle the printing of all 4716 C error messages and warnings. XERRWD is machine-dependent. 4717 C Note: DMNORM, DFNORM, DBNORM, DUMACH, IXSAV, and IUMACH are 4718 C function routines. All the others are subroutines. 4719 C 4720 C----------------------------------------------------------------------- 4721 EXTERNAL DPRJA, DSOLSY 4722 DOUBLE PRECISION DUMACH, DMNORM 4723 INTEGER INIT, MXSTEP, MXHNIL, NHNIL, NSLAST, NYH, IOWNS, 4724 1 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 4725 2 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 4726 3 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU 4727 INTEGER INSUFR, INSUFI, IXPR, IOWNS2, JTYP, MUSED, MXORDN, MXORDS 4728 INTEGER I, I1, I2, IFLAG, IMXER, KGO, LF0, 4729 1 LENIW, LENRW, LENWM, ML, MORD, MU, MXHNL0, MXSTP0 4730 INTEGER LEN1, LEN1C, LEN1N, LEN1S, LEN2, LENIWC, LENRWC 4731 DOUBLE PRECISION ROWNS, 4732 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND 4733 DOUBLE PRECISION TSW, ROWNS2, PDNORM 4734 DOUBLE PRECISION ATOLI, AYI, BIG, EWTI, H0, HMAX, HMX, RH, RTOLI, 4735 1 TCRIT, TDIST, TNEXT, TOL, TOLSF, TP, SIZE, SUM, W0 4736 DIMENSION MORD(2) 4737 LOGICAL IHIT 4738 CHARACTER*60 MSG 4739 SAVE MORD, MXSTP0, MXHNL0 4740 C----------------------------------------------------------------------- 4741 C The following two internal Common blocks contain 4742 C (a) variables which are local to any subroutine but whose values must 4743 C be preserved between calls to the routine ("own" variables), and 4744 C (b) variables which are communicated between subroutines. 4745 C The block DLS001 is declared in subroutines DLSODA, DINTDY, DSTODA, 4746 C DPRJA, and DSOLSY. 4747 C The block DLSA01 is declared in subroutines DLSODA, DSTODA, and DPRJA. 4748 C Groups of variables are replaced by dummy arrays in the Common 4749 C declarations in routines where those variables are not used. 4750 C----------------------------------------------------------------------- 4751 COMMON /DLS001/ ROWNS(209), 4752 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND, 4753 2 INIT, MXSTEP, MXHNIL, NHNIL, NSLAST, NYH, IOWNS(6), 4754 3 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 4755 4 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 4756 5 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU 4757 C 4758 COMMON /DLSA01/ TSW, ROWNS2(20), PDNORM, 4759 1 INSUFR, INSUFI, IXPR, IOWNS2(2), JTYP, MUSED, MXORDN, MXORDS 4760 C 4761 DATA MORD(1),MORD(2)/12,5/, MXSTP0/500/, MXHNL0/10/ 4762 C----------------------------------------------------------------------- 4763 C Block A. 4764 C This code block is executed on every call. 4765 C It tests ISTATE and ITASK for legality and branches appropriately. 4766 C If ISTATE .gt. 1 but the flag INIT shows that initialization has 4767 C not yet been done, an error return occurs. 4768 C If ISTATE = 1 and TOUT = T, return immediately. 4769 C----------------------------------------------------------------------- 4770 IF (ISTATE .LT. 1 .OR. ISTATE .GT. 3) GO TO 601 4771 IF (ITASK .LT. 1 .OR. ITASK .GT. 5) GO TO 602 4772 IF (ISTATE .EQ. 1) GO TO 10 4773 IF (INIT .EQ. 0) GO TO 603 4774 IF (ISTATE .EQ. 2) GO TO 200 4775 GO TO 20 4776 10 INIT = 0 4777 IF (TOUT .EQ. T) RETURN 4778 C----------------------------------------------------------------------- 4779 C Block B. 4780 C The next code block is executed for the initial call (ISTATE = 1), 4781 C or for a continuation call with parameter changes (ISTATE = 3). 4782 C It contains checking of all inputs and various initializations. 4783 C 4784 C First check legality of the non-optional inputs NEQ, ITOL, IOPT, 4785 C JT, ML, and MU. 4786 C----------------------------------------------------------------------- 4787 20 IF (NEQ(1) .LE. 0) GO TO 604 4788 IF (ISTATE .EQ. 1) GO TO 25 4789 IF (NEQ(1) .GT. N) GO TO 605 4790 25 N = NEQ(1) 4791 IF (ITOL .LT. 1 .OR. ITOL .GT. 4) GO TO 606 4792 IF (IOPT .LT. 0 .OR. IOPT .GT. 1) GO TO 607 4793 IF (JT .EQ. 3 .OR. JT .LT. 1 .OR. JT .GT. 5) GO TO 608 4794 JTYP = JT 4795 IF (JT .LE. 2) GO TO 30 4796 ML = IWORK(1) 4797 MU = IWORK(2) 4798 IF (ML .LT. 0 .OR. ML .GE. N) GO TO 609 4799 IF (MU .LT. 0 .OR. MU .GE. N) GO TO 610 4800 30 CONTINUE 4801 C Next process and check the optional inputs. -------------------------- 4802 IF (IOPT .EQ. 1) GO TO 40 4803 IXPR = 0 4804 MXSTEP = MXSTP0 4805 MXHNIL = MXHNL0 4806 HMXI = 0.0D0 4807 HMIN = 0.0D0 4808 IF (ISTATE .NE. 1) GO TO 60 4809 H0 = 0.0D0 4810 MXORDN = MORD(1) 4811 MXORDS = MORD(2) 4812 GO TO 60 4813 40 IXPR = IWORK(5) 4814 IF (IXPR .LT. 0 .OR. IXPR .GT. 1) GO TO 611 4815 MXSTEP = IWORK(6) 4816 IF (MXSTEP .LT. 0) GO TO 612 4817 IF (MXSTEP .EQ. 0) MXSTEP = MXSTP0 4818 MXHNIL = IWORK(7) 4819 IF (MXHNIL .LT. 0) GO TO 613 4820 IF (MXHNIL .EQ. 0) MXHNIL = MXHNL0 4821 IF (ISTATE .NE. 1) GO TO 50 4822 H0 = RWORK(5) 4823 MXORDN = IWORK(8) 4824 IF (MXORDN .LT. 0) GO TO 628 4825 IF (MXORDN .EQ. 0) MXORDN = 100 4826 MXORDN = MIN(MXORDN,MORD(1)) 4827 MXORDS = IWORK(9) 4828 IF (MXORDS .LT. 0) GO TO 629 4829 IF (MXORDS .EQ. 0) MXORDS = 100 4830 MXORDS = MIN(MXORDS,MORD(2)) 4831 IF ((TOUT - T)*H0 .LT. 0.0D0) GO TO 614 4832 50 HMAX = RWORK(6) 4833 IF (HMAX .LT. 0.0D0) GO TO 615 4834 HMXI = 0.0D0 4835 IF (HMAX .GT. 0.0D0) HMXI = 1.0D0/HMAX 4836 HMIN = RWORK(7) 4837 IF (HMIN .LT. 0.0D0) GO TO 616 4838 C----------------------------------------------------------------------- 4839 C Set work array pointers and check lengths LRW and LIW. 4840 C If ISTATE = 1, METH is initialized to 1 here to facilitate the 4841 C checking of work space lengths. 4842 C Pointers to segments of RWORK and IWORK are named by prefixing L to 4843 C the name of the segment. E.g., the segment YH starts at RWORK(LYH). 4844 C Segments of RWORK (in order) are denoted YH, WM, EWT, SAVF, ACOR. 4845 C If the lengths provided are insufficient for the current method, 4846 C an error return occurs. This is treated as illegal input on the 4847 C first call, but as a problem interruption with ISTATE = -7 on a 4848 C continuation call. If the lengths are sufficient for the current 4849 C method but not for both methods, a warning message is sent. 4850 C----------------------------------------------------------------------- 4851 60 IF (ISTATE .EQ. 1) METH = 1 4852 IF (ISTATE .EQ. 1) NYH = N 4853 LYH = 21 4854 LEN1N = 20 + (MXORDN + 1)*NYH 4855 LEN1S = 20 + (MXORDS + 1)*NYH 4856 LWM = LEN1S + 1 4857 IF (JT .LE. 2) LENWM = N*N + 2 4858 IF (JT .GE. 4) LENWM = (2*ML + MU + 1)*N + 2 4859 LEN1S = LEN1S + LENWM 4860 LEN1C = LEN1N 4861 IF (METH .EQ. 2) LEN1C = LEN1S 4862 LEN1 = MAX(LEN1N,LEN1S) 4863 LEN2 = 3*N 4864 LENRW = LEN1 + LEN2 4865 LENRWC = LEN1C + LEN2 4866 IWORK(17) = LENRW 4867 LIWM = 1 4868 LENIW = 20 + N 4869 LENIWC = 20 4870 IF (METH .EQ. 2) LENIWC = LENIW 4871 IWORK(18) = LENIW 4872 IF (ISTATE .EQ. 1 .AND. LRW .LT. LENRWC) GO TO 617 4873 IF (ISTATE .EQ. 1 .AND. LIW .LT. LENIWC) GO TO 618 4874 IF (ISTATE .EQ. 3 .AND. LRW .LT. LENRWC) GO TO 550 4875 IF (ISTATE .EQ. 3 .AND. LIW .LT. LENIWC) GO TO 555 4876 LEWT = LEN1 + 1 4877 INSUFR = 0 4878 IF (LRW .GE. LENRW) GO TO 65 4879 INSUFR = 2 4880 LEWT = LEN1C + 1 4881 MSG='DLSODA- Warning.. RWORK length is sufficient for now, but ' 4882 CALL XERRWD (MSG, 60, 103, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 4883 MSG=' may not be later. Integration will proceed anyway. ' 4884 CALL XERRWD (MSG, 60, 103, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 4885 MSG = ' Length needed is LENRW = I1, while LRW = I2.' 4886 CALL XERRWD (MSG, 50, 103, 0, 2, LENRW, LRW, 0, 0.0D0, 0.0D0) 4887 65 LSAVF = LEWT + N 4888 LACOR = LSAVF + N 4889 INSUFI = 0 4890 IF (LIW .GE. LENIW) GO TO 70 4891 INSUFI = 2 4892 MSG='DLSODA- Warning.. IWORK length is sufficient for now, but ' 4893 CALL XERRWD (MSG, 60, 104, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 4894 MSG=' may not be later. Integration will proceed anyway. ' 4895 CALL XERRWD (MSG, 60, 104, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 4896 MSG = ' Length needed is LENIW = I1, while LIW = I2.' 4897 CALL XERRWD (MSG, 50, 104, 0, 2, LENIW, LIW, 0, 0.0D0, 0.0D0) 4898 70 CONTINUE 4899 C Check RTOL and ATOL for legality. ------------------------------------ 4900 RTOLI = RTOL(1) 4901 ATOLI = ATOL(1) 4902 DO 75 I = 1,N 4903 IF (ITOL .GE. 3) RTOLI = RTOL(I) 4904 IF (ITOL .EQ. 2 .OR. ITOL .EQ. 4) ATOLI = ATOL(I) 4905 IF (RTOLI .LT. 0.0D0) GO TO 619 4906 IF (ATOLI .LT. 0.0D0) GO TO 620 4907 75 CONTINUE 4908 IF (ISTATE .EQ. 1) GO TO 100 4909 C If ISTATE = 3, set flag to signal parameter changes to DSTODA. ------- 4910 JSTART = -1 4911 IF (N .EQ. NYH) GO TO 200 4912 C NEQ was reduced. Zero part of YH to avoid undefined references. ----- 4913 I1 = LYH + L*NYH 4914 I2 = LYH + (MAXORD + 1)*NYH - 1 4915 IF (I1 .GT. I2) GO TO 200 4916 DO 95 I = I1,I2 4917 95 RWORK(I) = 0.0D0 4918 GO TO 200 4919 C----------------------------------------------------------------------- 4920 C Block C. 4921 C The next block is for the initial call only (ISTATE = 1). 4922 C It contains all remaining initializations, the initial call to F, 4923 C and the calculation of the initial step size. 4924 C The error weights in EWT are inverted after being loaded. 4925 C----------------------------------------------------------------------- 4926 100 UROUND = DUMACH() 4927 TN = T 4928 TSW = T 4929 MAXORD = MXORDN 4930 IF (ITASK .NE. 4 .AND. ITASK .NE. 5) GO TO 110 4931 TCRIT = RWORK(1) 4932 IF ((TCRIT - TOUT)*(TOUT - T) .LT. 0.0D0) GO TO 625 4933 IF (H0 .NE. 0.0D0 .AND. (T + H0 - TCRIT)*H0 .GT. 0.0D0) 4934 1 H0 = TCRIT - T 4935 110 JSTART = 0 4936 NHNIL = 0 4937 NST = 0 4938 NJE = 0 4939 NSLAST = 0 4940 HU = 0.0D0 4941 NQU = 0 4942 MUSED = 0 4943 MITER = 0 4944 CCMAX = 0.3D0 4945 MAXCOR = 3 4946 MSBP = 20 4947 MXNCF = 10 4948 C Initial call to F. (LF0 points to YH(*,2).) ------------------------- 4949 LF0 = LYH + NYH 4950 CALL F (NEQ, T, Y, RWORK(LF0)) 4951 NFE = 1 4952 C Load the initial value vector in YH. --------------------------------- 4953 DO 115 I = 1,N 4954 115 RWORK(I+LYH-1) = Y(I) 4955 C Load and invert the EWT array. (H is temporarily set to 1.0.) ------- 4956 NQ = 1 4957 H = 1.0D0 4958 CALL DEWSET (N, ITOL, RTOL, ATOL, RWORK(LYH), RWORK(LEWT)) 4959 DO 120 I = 1,N 4960 IF (RWORK(I+LEWT-1) .LE. 0.0D0) GO TO 621 4961 120 RWORK(I+LEWT-1) = 1.0D0/RWORK(I+LEWT-1) 4962 C----------------------------------------------------------------------- 4963 C The coding below computes the step size, H0, to be attempted on the 4964 C first step, unless the user has supplied a value for this. 4965 C First check that TOUT - T differs significantly from zero. 4966 C A scalar tolerance quantity TOL is computed, as MAX(RTOL(i)) 4967 C if this is positive, or MAX(ATOL(i)/ABS(Y(i))) otherwise, adjusted 4968 C so as to be between 100*UROUND and 1.0E-3. 4969 C Then the computed value H0 is given by: 4970 C 4971 C H0**(-2) = 1./(TOL * w0**2) + TOL * (norm(F))**2 4972 C 4973 C where w0 = MAX ( ABS(T), ABS(TOUT) ), 4974 C F = the initial value of the vector f(t,y), and 4975 C norm() = the weighted vector norm used throughout, given by 4976 C the DMNORM function routine, and weighted by the 4977 C tolerances initially loaded into the EWT array. 4978 C The sign of H0 is inferred from the initial values of TOUT and T. 4979 C ABS(H0) is made .le. ABS(TOUT-T) in any case. 4980 C----------------------------------------------------------------------- 4981 IF (H0 .NE. 0.0D0) GO TO 180 4982 TDIST = ABS(TOUT - T) 4983 W0 = MAX(ABS(T),ABS(TOUT)) 4984 IF (TDIST .LT. 2.0D0*UROUND*W0) GO TO 622 4985 TOL = RTOL(1) 4986 IF (ITOL .LE. 2) GO TO 140 4987 DO 130 I = 1,N 4988 130 TOL = MAX(TOL,RTOL(I)) 4989 140 IF (TOL .GT. 0.0D0) GO TO 160 4990 ATOLI = ATOL(1) 4991 DO 150 I = 1,N 4992 IF (ITOL .EQ. 2 .OR. ITOL .EQ. 4) ATOLI = ATOL(I) 4993 AYI = ABS(Y(I)) 4994 IF (AYI .NE. 0.0D0) TOL = MAX(TOL,ATOLI/AYI) 4995 150 CONTINUE 4996 160 TOL = MAX(TOL,100.0D0*UROUND) 4997 TOL = MIN(TOL,0.001D0) 4998 SUM = DMNORM (N, RWORK(LF0), RWORK(LEWT)) 4999 SUM = 1.0D0/(TOL*W0*W0) + TOL*SUM**2 5000 H0 = 1.0D0/SQRT(SUM) 5001 H0 = MIN(H0,TDIST) 5002 H0 = SIGN(H0,TOUT-T) 5003 C Adjust H0 if necessary to meet HMAX bound. --------------------------- 5004 180 RH = ABS(H0)*HMXI 5005 IF (RH .GT. 1.0D0) H0 = H0/RH 5006 C Load H with H0 and scale YH(*,2) by H0. ------------------------------ 5007 H = H0 5008 DO 190 I = 1,N 5009 190 RWORK(I+LF0-1) = H0*RWORK(I+LF0-1) 5010 GO TO 270 5011 C----------------------------------------------------------------------- 5012 C Block D. 5013 C The next code block is for continuation calls only (ISTATE = 2 or 3) 5014 C and is to check stop conditions before taking a step. 5015 C----------------------------------------------------------------------- 5016 200 NSLAST = NST 5017 GO TO (210, 250, 220, 230, 240), ITASK 5018 210 IF ((TN - TOUT)*H .LT. 0.0D0) GO TO 250 5019 CALL DINTDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) 5020 IF (IFLAG .NE. 0) GO TO 627 5021 T = TOUT 5022 GO TO 420 5023 220 TP = TN - HU*(1.0D0 + 100.0D0*UROUND) 5024 IF ((TP - TOUT)*H .GT. 0.0D0) GO TO 623 5025 IF ((TN - TOUT)*H .LT. 0.0D0) GO TO 250 5026 T = TN 5027 GO TO 400 5028 230 TCRIT = RWORK(1) 5029 IF ((TN - TCRIT)*H .GT. 0.0D0) GO TO 624 5030 IF ((TCRIT - TOUT)*H .LT. 0.0D0) GO TO 625 5031 IF ((TN - TOUT)*H .LT. 0.0D0) GO TO 245 5032 CALL DINTDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) 5033 IF (IFLAG .NE. 0) GO TO 627 5034 T = TOUT 5035 GO TO 420 5036 240 TCRIT = RWORK(1) 5037 IF ((TN - TCRIT)*H .GT. 0.0D0) GO TO 624 5038 245 HMX = ABS(TN) + ABS(H) 5039 IHIT = ABS(TN - TCRIT) .LE. 100.0D0*UROUND*HMX 5040 IF (IHIT) T = TCRIT 5041 IF (IHIT) GO TO 400 5042 TNEXT = TN + H*(1.0D0 + 4.0D0*UROUND) 5043 IF ((TNEXT - TCRIT)*H .LE. 0.0D0) GO TO 250 5044 H = (TCRIT - TN)*(1.0D0 - 4.0D0*UROUND) 5045 IF (ISTATE .EQ. 2 .AND. JSTART .GE. 0) JSTART = -2 5046 C----------------------------------------------------------------------- 5047 C Block E. 5048 C The next block is normally executed for all calls and contains 5049 C the call to the one-step core integrator DSTODA. 5050 C 5051 C This is a looping point for the integration steps. 5052 C 5053 C First check for too many steps being taken, update EWT (if not at 5054 C start of problem), check for too much accuracy being requested, and 5055 C check for H below the roundoff level in T. 5056 C----------------------------------------------------------------------- 5057 250 CONTINUE 5058 IF (METH .EQ. MUSED) GO TO 255 5059 IF (INSUFR .EQ. 1) GO TO 550 5060 IF (INSUFI .EQ. 1) GO TO 555 5061 255 IF ((NST-NSLAST) .GE. MXSTEP) GO TO 500 5062 CALL DEWSET (N, ITOL, RTOL, ATOL, RWORK(LYH), RWORK(LEWT)) 5063 DO 260 I = 1,N 5064 IF (RWORK(I+LEWT-1) .LE. 0.0D0) GO TO 510 5065 260 RWORK(I+LEWT-1) = 1.0D0/RWORK(I+LEWT-1) 5066 270 TOLSF = UROUND*DMNORM (N, RWORK(LYH), RWORK(LEWT)) 5067 IF (TOLSF .LE. 1.0D0) GO TO 280 5068 TOLSF = TOLSF*2.0D0 5069 IF (NST .EQ. 0) GO TO 626 5070 GO TO 520 5071 280 IF ((TN + H) .NE. TN) GO TO 290 5072 NHNIL = NHNIL + 1 5073 IF (NHNIL .GT. MXHNIL) GO TO 290 5074 MSG = 'DLSODA- Warning..Internal T (=R1) and H (=R2) are' 5075 CALL XERRWD (MSG, 50, 101, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 5076 MSG=' such that in the machine, T + H = T on the next step ' 5077 CALL XERRWD (MSG, 60, 101, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 5078 MSG = ' (H = step size). Solver will continue anyway.' 5079 CALL XERRWD (MSG, 50, 101, 0, 0, 0, 0, 2, TN, H) 5080 IF (NHNIL .LT. MXHNIL) GO TO 290 5081 MSG = 'DLSODA- Above warning has been issued I1 times. ' 5082 CALL XERRWD (MSG, 50, 102, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 5083 MSG = ' It will not be issued again for this problem.' 5084 CALL XERRWD (MSG, 50, 102, 0, 1, MXHNIL, 0, 0, 0.0D0, 0.0D0) 5085 290 CONTINUE 5086 C----------------------------------------------------------------------- 5087 C CALL DSTODA(NEQ,Y,YH,NYH,YH,EWT,SAVF,ACOR,WM,IWM,F,JAC,DPRJA,DSOLSY) 5088 C----------------------------------------------------------------------- 5089 CALL DSTODA (NEQ, Y, RWORK(LYH), NYH, RWORK(LYH), RWORK(LEWT), 5090 1 RWORK(LSAVF), RWORK(LACOR), RWORK(LWM), IWORK(LIWM), 5091 2 F, JAC, DPRJA, DSOLSY) 5092 KGO = 1 - KFLAG 5093 GO TO (300, 530, 540), KGO 5094 C----------------------------------------------------------------------- 5095 C Block F. 5096 C The following block handles the case of a successful return from the 5097 C core integrator (KFLAG = 0). 5098 C If a method switch was just made, record TSW, reset MAXORD, 5099 C set JSTART to -1 to signal DSTODA to complete the switch, 5100 C and do extra printing of data if IXPR = 1. 5101 C Then, in any case, check for stop conditions. 5102 C----------------------------------------------------------------------- 5103 300 INIT = 1 5104 IF (METH .EQ. MUSED) GO TO 310 5105 TSW = TN 5106 MAXORD = MXORDN 5107 IF (METH .EQ. 2) MAXORD = MXORDS 5108 IF (METH .EQ. 2) RWORK(LWM) = SQRT(UROUND) 5109 INSUFR = MIN(INSUFR,1) 5110 INSUFI = MIN(INSUFI,1) 5111 JSTART = -1 5112 IF (IXPR .EQ. 0) GO TO 310 5113 IF (METH .EQ. 2) THEN 5114 MSG='DLSODA- A switch to the BDF (stiff) method has occurred ' 5115 CALL XERRWD (MSG, 60, 105, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 5116 ENDIF 5117 IF (METH .EQ. 1) THEN 5118 MSG='DLSODA- A switch to the Adams (nonstiff) method has occurred' 5119 CALL XERRWD (MSG, 60, 106, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 5120 ENDIF 5121 MSG=' at T = R1, tentative step size H = R2, step NST = I1 ' 5122 CALL XERRWD (MSG, 60, 107, 0, 1, NST, 0, 2, TN, H) 5123 310 GO TO (320, 400, 330, 340, 350), ITASK 5124 C ITASK = 1. If TOUT has been reached, interpolate. ------------------- 5125 320 IF ((TN - TOUT)*H .LT. 0.0D0) GO TO 250 5126 CALL DINTDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) 5127 T = TOUT 5128 GO TO 420 5129 C ITASK = 3. Jump to exit if TOUT was reached. ------------------------ 5130 330 IF ((TN - TOUT)*H .GE. 0.0D0) GO TO 400 5131 GO TO 250 5132 C ITASK = 4. See if TOUT or TCRIT was reached. Adjust H if necessary. 5133 340 IF ((TN - TOUT)*H .LT. 0.0D0) GO TO 345 5134 CALL DINTDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) 5135 T = TOUT 5136 GO TO 420 5137 345 HMX = ABS(TN) + ABS(H) 5138 IHIT = ABS(TN - TCRIT) .LE. 100.0D0*UROUND*HMX 5139 IF (IHIT) GO TO 400 5140 TNEXT = TN + H*(1.0D0 + 4.0D0*UROUND) 5141 IF ((TNEXT - TCRIT)*H .LE. 0.0D0) GO TO 250 5142 H = (TCRIT - TN)*(1.0D0 - 4.0D0*UROUND) 5143 IF (JSTART .GE. 0) JSTART = -2 5144 GO TO 250 5145 C ITASK = 5. See if TCRIT was reached and jump to exit. --------------- 5146 350 HMX = ABS(TN) + ABS(H) 5147 IHIT = ABS(TN - TCRIT) .LE. 100.0D0*UROUND*HMX 5148 C----------------------------------------------------------------------- 5149 C Block G. 5150 C The following block handles all successful returns from DLSODA. 5151 C If ITASK .ne. 1, Y is loaded from YH and T is set accordingly. 5152 C ISTATE is set to 2, and the optional outputs are loaded into the 5153 C work arrays before returning. 5154 C----------------------------------------------------------------------- 5155 400 DO 410 I = 1,N 5156 410 Y(I) = RWORK(I+LYH-1) 5157 T = TN 5158 IF (ITASK .NE. 4 .AND. ITASK .NE. 5) GO TO 420 5159 IF (IHIT) T = TCRIT 5160 420 ISTATE = 2 5161 RWORK(11) = HU 5162 RWORK(12) = H 5163 RWORK(13) = TN 5164 RWORK(15) = TSW 5165 IWORK(11) = NST 5166 IWORK(12) = NFE 5167 IWORK(13) = NJE 5168 IWORK(14) = NQU 5169 IWORK(15) = NQ 5170 IWORK(19) = MUSED 5171 IWORK(20) = METH 5172 RETURN 5173 C----------------------------------------------------------------------- 5174 C Block H. 5175 C The following block handles all unsuccessful returns other than 5176 C those for illegal input. First the error message routine is called. 5177 C If there was an error test or convergence test failure, IMXER is set. 5178 C Then Y is loaded from YH and T is set to TN. 5179 C The optional outputs are loaded into the work arrays before returning. 5180 C----------------------------------------------------------------------- 5181 C The maximum number of steps was taken before reaching TOUT. ---------- 5182 C 500 MSG = 'DLSODA- At current T (=R1), MXSTEP (=I1) steps ' 5183 C CALL XERRWD (MSG, 50, 201, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 5184 C MSG = ' taken on this call before reaching TOUT ' 5185 C CALL XERRWD (MSG, 50, 201, 0, 1, MXSTEP, 0, 1, TN, 0.0D0) 5186 500 ISTATE = -1 5187 GO TO 580 5188 C EWT(i) .le. 0.0 for some i (not at start of problem). ---------------- 5189 510 EWTI = RWORK(LEWT+I-1) 5190 MSG = 'DLSODA- At T (=R1), EWT(I1) has become R2 .le. 0.' 5191 CALL XERRWD (MSG, 50, 202, 0, 1, I, 0, 2, TN, EWTI) 5192 ISTATE = -6 5193 GO TO 580 5194 C Too much accuracy requested for machine precision. ------------------- 5195 520 MSG = 'DLSODA- At T (=R1), too much accuracy requested ' 5196 CALL XERRWD (MSG, 50, 203, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 5197 MSG = ' for precision of machine.. See TOLSF (=R2) ' 5198 CALL XERRWD (MSG, 50, 203, 0, 0, 0, 0, 2, TN, TOLSF) 5199 RWORK(14) = TOLSF 5200 ISTATE = -2 5201 GO TO 580 5202 C KFLAG = -1. Error test failed repeatedly or with ABS(H) = HMIN. ----- 5203 530 MSG = 'DLSODA- At T(=R1) and step size H(=R2), the error' 5204 CALL XERRWD (MSG, 50, 204, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 5205 MSG = ' test failed repeatedly or with ABS(H) = HMIN' 5206 CALL XERRWD (MSG, 50, 204, 0, 0, 0, 0, 2, TN, H) 5207 ISTATE = -4 5208 GO TO 560 5209 C KFLAG = -2. Convergence failed repeatedly or with ABS(H) = HMIN. ---- 5210 540 MSG = 'DLSODA- At T (=R1) and step size H (=R2), the ' 5211 CALL XERRWD (MSG, 50, 205, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 5212 MSG = ' corrector convergence failed repeatedly ' 5213 CALL XERRWD (MSG, 50, 205, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 5214 MSG = ' or with ABS(H) = HMIN ' 5215 CALL XERRWD (MSG, 30, 205, 0, 0, 0, 0, 2, TN, H) 5216 ISTATE = -5 5217 GO TO 560 5218 C RWORK length too small to proceed. ----------------------------------- 5219 550 MSG = 'DLSODA- At current T(=R1), RWORK length too small' 5220 CALL XERRWD (MSG, 50, 206, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 5221 MSG=' to proceed. The integration was otherwise successful.' 5222 CALL XERRWD (MSG, 60, 206, 0, 0, 0, 0, 1, TN, 0.0D0) 5223 ISTATE = -7 5224 GO TO 580 5225 C IWORK length too small to proceed. ----------------------------------- 5226 555 MSG = 'DLSODA- At current T(=R1), IWORK length too small' 5227 CALL XERRWD (MSG, 50, 207, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 5228 MSG=' to proceed. The integration was otherwise successful.' 5229 CALL XERRWD (MSG, 60, 207, 0, 0, 0, 0, 1, TN, 0.0D0) 5230 ISTATE = -7 5231 GO TO 580 5232 C Compute IMXER if relevant. ------------------------------------------- 5233 560 BIG = 0.0D0 5234 IMXER = 1 5235 DO 570 I = 1,N 5236 SIZE = ABS(RWORK(I+LACOR-1)*RWORK(I+LEWT-1)) 5237 IF (BIG .GE. SIZE) GO TO 570 5238 BIG = SIZE 5239 IMXER = I 5240 570 CONTINUE 5241 IWORK(16) = IMXER 5242 C Set Y vector, T, and optional outputs. ------------------------------- 5243 580 DO 590 I = 1,N 5244 590 Y(I) = RWORK(I+LYH-1) 5245 T = TN 5246 RWORK(11) = HU 5247 RWORK(12) = H 5248 RWORK(13) = TN 5249 RWORK(15) = TSW 5250 IWORK(11) = NST 5251 IWORK(12) = NFE 5252 IWORK(13) = NJE 5253 IWORK(14) = NQU 5254 IWORK(15) = NQ 5255 IWORK(19) = MUSED 5256 IWORK(20) = METH 5257 RETURN 5258 C----------------------------------------------------------------------- 5259 C Block I. 5260 C The following block handles all error returns due to illegal input 5261 C (ISTATE = -3), as detected before calling the core integrator. 5262 C First the error message routine is called. If the illegal input 5263 C is a negative ISTATE, the run is aborted (apparent infinite loop). 5264 C----------------------------------------------------------------------- 5265 601 MSG = 'DLSODA- ISTATE (=I1) illegal.' 5266 CALL XERRWD (MSG, 30, 1, 0, 1, ISTATE, 0, 0, 0.0D0, 0.0D0) 5267 IF (ISTATE .LT. 0) GO TO 800 5268 GO TO 700 5269 602 MSG = 'DLSODA- ITASK (=I1) illegal. ' 5270 CALL XERRWD (MSG, 30, 2, 0, 1, ITASK, 0, 0, 0.0D0, 0.0D0) 5271 GO TO 700 5272 603 MSG = 'DLSODA- ISTATE .gt. 1 but DLSODA not initialized.' 5273 CALL XERRWD (MSG, 50, 3, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 5274 GO TO 700 5275 604 MSG = 'DLSODA- NEQ (=I1) .lt. 1 ' 5276 CALL XERRWD (MSG, 30, 4, 0, 1, NEQ(1), 0, 0, 0.0D0, 0.0D0) 5277 GO TO 700 5278 605 MSG = 'DLSODA- ISTATE = 3 and NEQ increased (I1 to I2). ' 5279 CALL XERRWD (MSG, 50, 5, 0, 2, N, NEQ(1), 0, 0.0D0, 0.0D0) 5280 GO TO 700 5281 606 MSG = 'DLSODA- ITOL (=I1) illegal. ' 5282 CALL XERRWD (MSG, 30, 6, 0, 1, ITOL, 0, 0, 0.0D0, 0.0D0) 5283 GO TO 700 5284 607 MSG = 'DLSODA- IOPT (=I1) illegal. ' 5285 CALL XERRWD (MSG, 30, 7, 0, 1, IOPT, 0, 0, 0.0D0, 0.0D0) 5286 GO TO 700 5287 608 MSG = 'DLSODA- JT (=I1) illegal. ' 5288 CALL XERRWD (MSG, 30, 8, 0, 1, JT, 0, 0, 0.0D0, 0.0D0) 5289 GO TO 700 5290 609 MSG = 'DLSODA- ML (=I1) illegal: .lt.0 or .ge.NEQ (=I2) ' 5291 CALL XERRWD (MSG, 50, 9, 0, 2, ML, NEQ(1), 0, 0.0D0, 0.0D0) 5292 GO TO 700 5293 610 MSG = 'DLSODA- MU (=I1) illegal: .lt.0 or .ge.NEQ (=I2) ' 5294 CALL XERRWD (MSG, 50, 10, 0, 2, MU, NEQ(1), 0, 0.0D0, 0.0D0) 5295 GO TO 700 5296 611 MSG = 'DLSODA- IXPR (=I1) illegal. ' 5297 CALL XERRWD (MSG, 30, 11, 0, 1, IXPR, 0, 0, 0.0D0, 0.0D0) 5298 GO TO 700 5299 612 MSG = 'DLSODA- MXSTEP (=I1) .lt. 0 ' 5300 CALL XERRWD (MSG, 30, 12, 0, 1, MXSTEP, 0, 0, 0.0D0, 0.0D0) 5301 GO TO 700 5302 613 MSG = 'DLSODA- MXHNIL (=I1) .lt. 0 ' 5303 CALL XERRWD (MSG, 30, 13, 0, 1, MXHNIL, 0, 0, 0.0D0, 0.0D0) 5304 GO TO 700 5305 614 MSG = 'DLSODA- TOUT (=R1) behind T (=R2) ' 5306 CALL XERRWD (MSG, 40, 14, 0, 0, 0, 0, 2, TOUT, T) 5307 MSG = ' Integration direction is given by H0 (=R1) ' 5308 CALL XERRWD (MSG, 50, 14, 0, 0, 0, 0, 1, H0, 0.0D0) 5309 GO TO 700 5310 615 MSG = 'DLSODA- HMAX (=R1) .lt. 0.0 ' 5311 CALL XERRWD (MSG, 30, 15, 0, 0, 0, 0, 1, HMAX, 0.0D0) 5312 GO TO 700 5313 616 MSG = 'DLSODA- HMIN (=R1) .lt. 0.0 ' 5314 CALL XERRWD (MSG, 30, 16, 0, 0, 0, 0, 1, HMIN, 0.0D0) 5315 GO TO 700 5316 617 MSG='DLSODA- RWORK length needed, LENRW (=I1), exceeds LRW (=I2)' 5317 CALL XERRWD (MSG, 60, 17, 0, 2, LENRW, LRW, 0, 0.0D0, 0.0D0) 5318 GO TO 700 5319 618 MSG='DLSODA- IWORK length needed, LENIW (=I1), exceeds LIW (=I2)' 5320 CALL XERRWD (MSG, 60, 18, 0, 2, LENIW, LIW, 0, 0.0D0, 0.0D0) 5321 GO TO 700 5322 619 MSG = 'DLSODA- RTOL(I1) is R1 .lt. 0.0 ' 5323 CALL XERRWD (MSG, 40, 19, 0, 1, I, 0, 1, RTOLI, 0.0D0) 5324 GO TO 700 5325 620 MSG = 'DLSODA- ATOL(I1) is R1 .lt. 0.0 ' 5326 CALL XERRWD (MSG, 40, 20, 0, 1, I, 0, 1, ATOLI, 0.0D0) 5327 GO TO 700 5328 621 EWTI = RWORK(LEWT+I-1) 5329 MSG = 'DLSODA- EWT(I1) is R1 .le. 0.0 ' 5330 CALL XERRWD (MSG, 40, 21, 0, 1, I, 0, 1, EWTI, 0.0D0) 5331 GO TO 700 5332 622 MSG='DLSODA- TOUT(=R1) too close to T(=R2) to start integration.' 5333 CALL XERRWD (MSG, 60, 22, 0, 0, 0, 0, 2, TOUT, T) 5334 GO TO 700 5335 623 MSG='DLSODA- ITASK = I1 and TOUT (=R1) behind TCUR - HU (= R2) ' 5336 CALL XERRWD (MSG, 60, 23, 0, 1, ITASK, 0, 2, TOUT, TP) 5337 GO TO 700 5338 624 MSG='DLSODA- ITASK = 4 or 5 and TCRIT (=R1) behind TCUR (=R2) ' 5339 CALL XERRWD (MSG, 60, 24, 0, 0, 0, 0, 2, TCRIT, TN) 5340 GO TO 700 5341 625 MSG='DLSODA- ITASK = 4 or 5 and TCRIT (=R1) behind TOUT (=R2) ' 5342 CALL XERRWD (MSG, 60, 25, 0, 0, 0, 0, 2, TCRIT, TOUT) 5343 GO TO 700 5344 626 MSG = 'DLSODA- At start of problem, too much accuracy ' 5345 CALL XERRWD (MSG, 50, 26, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 5346 MSG=' requested for precision of machine.. See TOLSF (=R1) ' 5347 CALL XERRWD (MSG, 60, 26, 0, 0, 0, 0, 1, TOLSF, 0.0D0) 5348 RWORK(14) = TOLSF 5349 GO TO 700 5350 627 MSG = 'DLSODA- Trouble in DINTDY. ITASK = I1, TOUT = R1' 5351 CALL XERRWD (MSG, 50, 27, 0, 1, ITASK, 0, 1, TOUT, 0.0D0) 5352 GO TO 700 5353 628 MSG = 'DLSODA- MXORDN (=I1) .lt. 0 ' 5354 CALL XERRWD (MSG, 30, 28, 0, 1, MXORDN, 0, 0, 0.0D0, 0.0D0) 5355 GO TO 700 5356 629 MSG = 'DLSODA- MXORDS (=I1) .lt. 0 ' 5357 CALL XERRWD (MSG, 30, 29, 0, 1, MXORDS, 0, 0, 0.0D0, 0.0D0) 5358 C 5359 700 ISTATE = -3 5360 RETURN 5361 C 5362 800 MSG = 'DLSODA- Run aborted.. apparent infinite loop. ' 5363 CALL XERRWD (MSG, 50, 303, 2, 0, 0, 0, 0, 0.0D0, 0.0D0) 5364 RETURN 5365 C----------------------- End of Subroutine DLSODA ---------------------- 5366 END 5367 *DECK DLSODAR 5368 SUBROUTINE DLSODAR (F, NEQ, Y, T, TOUT, ITOL, RTOL, ATOL, ITASK, 5369 1 ISTATE, IOPT, RWORK, LRW, IWORK, LIW, JAC, JT, 5370 2 G, NG, JROOT) 5371 EXTERNAL F, JAC, G 5372 INTEGER NEQ, ITOL, ITASK, ISTATE, IOPT, LRW, IWORK, LIW, JT, 5373 1 NG, JROOT 5374 DOUBLE PRECISION Y, T, TOUT, RTOL, ATOL, RWORK 5375 DIMENSION NEQ(*), Y(*), RTOL(*), ATOL(*), RWORK(LRW), IWORK(LIW), 5376 1 JROOT(NG) 5377 C----------------------------------------------------------------------- 5378 C This is the 12 November 2003 version of 5379 C DLSODAR: Livermore Solver for Ordinary Differential Equations, with 5380 C Automatic method switching for stiff and nonstiff problems, 5381 C and with Root-finding. 5382 C 5383 C This version is in double precision. 5384 C 5385 C DLSODAR solves the initial value problem for stiff or nonstiff 5386 C systems of first order ODEs, 5387 C dy/dt = f(t,y) , or, in component form, 5388 C dy(i)/dt = f(i) = f(i,t,y(1),y(2),...,y(NEQ)) (i = 1,...,NEQ). 5389 C At the same time, it locates the roots of any of a set of functions 5390 C g(i) = g(i,t,y(1),...,y(NEQ)) (i = 1,...,ng). 5391 C 5392 C This a variant version of the DLSODE package. It differs from it 5393 C in two ways: 5394 C (a) It switches automatically between stiff and nonstiff methods. 5395 C This means that the user does not have to determine whether the 5396 C problem is stiff or not, and the solver will automatically choose the 5397 C appropriate method. It always starts with the nonstiff method. 5398 C (b) It finds the root of at least one of a set of constraint 5399 C functions g(i) of the independent and dependent variables. 5400 C It finds only those roots for which some g(i), as a function 5401 C of t, changes sign in the interval of integration. 5402 C It then returns the solution at the root, if that occurs 5403 C sooner than the specified stop condition, and otherwise returns 5404 C the solution according the specified stop condition. 5405 C 5406 C Authors: Alan C. Hindmarsh, 5407 C Center for Applied Scientific Computing, L-561 5408 C Lawrence Livermore National Laboratory 5409 C Livermore, CA 94551 5410 C and 5411 C Linda R. Petzold 5412 C Univ. of California at Santa Barbara 5413 C Dept. of Computer Science 5414 C Santa Barbara, CA 93106 5415 C 5416 C References: 5417 C 1. Alan C. Hindmarsh, ODEPACK, A Systematized Collection of ODE 5418 C Solvers, in Scientific Computing, R. S. Stepleman et al. (Eds.), 5419 C North-Holland, Amsterdam, 1983, pp. 55-64. 5420 C 2. Linda R. Petzold, Automatic Selection of Methods for Solving 5421 C Stiff and Nonstiff Systems of Ordinary Differential Equations, 5422 C Siam J. Sci. Stat. Comput. 4 (1983), pp. 136-148. 5423 C 3. Kathie L. Hiebert and Lawrence F. Shampine, Implicitly Defined 5424 C Output Points for Solutions of ODEs, Sandia Report SAND80-0180, 5425 C February 1980. 5426 C----------------------------------------------------------------------- 5427 C Summary of Usage. 5428 C 5429 C Communication between the user and the DLSODAR package, for normal 5430 C situations, is summarized here. This summary describes only a subset 5431 C of the full set of options available. See the full description for 5432 C details, including alternative treatment of the Jacobian matrix, 5433 C optional inputs and outputs, nonstandard options, and 5434 C instructions for special situations. See also the example 5435 C problem (with program and output) following this summary. 5436 C 5437 C A. First provide a subroutine of the form: 5438 C SUBROUTINE F (NEQ, T, Y, YDOT) 5439 C DOUBLE PRECISION T, Y(*), YDOT(*) 5440 C which supplies the vector function f by loading YDOT(i) with f(i). 5441 C 5442 C B. Provide a subroutine of the form: 5443 C SUBROUTINE G (NEQ, T, Y, NG, GOUT) 5444 C DOUBLE PRECISION T, Y(*), GOUT(NG) 5445 C which supplies the vector function g by loading GOUT(i) with 5446 C g(i), the i-th constraint function whose root is sought. 5447 C 5448 C C. Write a main program which calls Subroutine DLSODAR once for 5449 C each point at which answers are desired. This should also provide 5450 C for possible use of logical unit 6 for output of error messages by 5451 C DLSODAR. On the first call to DLSODAR, supply arguments as follows: 5452 C F = name of subroutine for right-hand side vector f. 5453 C This name must be declared External in calling program. 5454 C NEQ = number of first order ODEs. 5455 C Y = array of initial values, of length NEQ. 5456 C T = the initial value of the independent variable. 5457 C TOUT = first point where output is desired (.ne. T). 5458 C ITOL = 1 or 2 according as ATOL (below) is a scalar or array. 5459 C RTOL = relative tolerance parameter (scalar). 5460 C ATOL = absolute tolerance parameter (scalar or array). 5461 C the estimated local error in y(i) will be controlled so as 5462 C to be less than 5463 C EWT(i) = RTOL*ABS(Y(i)) + ATOL if ITOL = 1, or 5464 C EWT(i) = RTOL*ABS(Y(i)) + ATOL(i) if ITOL = 2. 5465 C Thus the local error test passes if, in each component, 5466 C either the absolute error is less than ATOL (or ATOL(i)), 5467 C or the relative error is less than RTOL. 5468 C Use RTOL = 0.0 for pure absolute error control, and 5469 C use ATOL = 0.0 (or ATOL(i) = 0.0) for pure relative error 5470 C control. Caution: actual (global) errors may exceed these 5471 C local tolerances, so choose them conservatively. 5472 C ITASK = 1 for normal computation of output values of y at t = TOUT. 5473 C ISTATE = integer flag (input and output). Set ISTATE = 1. 5474 C IOPT = 0 to indicate no optional inputs used. 5475 C RWORK = real work array of length at least: 5476 C 22 + NEQ * MAX(16, NEQ + 9) + 3*NG. 5477 C See also Paragraph F below. 5478 C LRW = declared length of RWORK (in user's dimension). 5479 C IWORK = integer work array of length at least 20 + NEQ. 5480 C LIW = declared length of IWORK (in user's dimension). 5481 C JAC = name of subroutine for Jacobian matrix. 5482 C Use a dummy name. See also Paragraph F below. 5483 C JT = Jacobian type indicator. Set JT = 2. 5484 C See also Paragraph F below. 5485 C G = name of subroutine for constraint functions, whose 5486 C roots are desired during the integration. 5487 C This name must be declared External in calling program. 5488 C NG = number of constraint functions g(i). If there are none, 5489 C set NG = 0, and pass a dummy name for G. 5490 C JROOT = integer array of length NG for output of root information. 5491 C See next paragraph. 5492 C Note that the main program must declare arrays Y, RWORK, IWORK, 5493 C JROOT, and possibly ATOL. 5494 C 5495 C D. The output from the first call (or any call) is: 5496 C Y = array of computed values of y(t) vector. 5497 C T = corresponding value of independent variable. This is 5498 C TOUT if ISTATE = 2, or the root location if ISTATE = 3, 5499 C or the farthest point reached if DLSODAR was unsuccessful. 5500 C ISTATE = 2 or 3 if DLSODAR was successful, negative otherwise. 5501 C 2 means no root was found, and TOUT was reached as desired. 5502 C 3 means a root was found prior to reaching TOUT. 5503 C -1 means excess work done on this call (perhaps wrong JT). 5504 C -2 means excess accuracy requested (tolerances too small). 5505 C -3 means illegal input detected (see printed message). 5506 C -4 means repeated error test failures (check all inputs). 5507 C -5 means repeated convergence failures (perhaps bad Jacobian 5508 C supplied or wrong choice of JT or tolerances). 5509 C -6 means error weight became zero during problem. (Solution 5510 C component i vanished, and ATOL or ATOL(i) = 0.) 5511 C -7 means work space insufficient to finish (see messages). 5512 C JROOT = array showing roots found if ISTATE = 3 on return. 5513 C JROOT(i) = 1 if g(i) has a root at t, or 0 otherwise. 5514 C 5515 C E. To continue the integration after a successful return, proceed 5516 C as follows: 5517 C (a) If ISTATE = 2 on return, reset TOUT and call DLSODAR again. 5518 C (b) If ISTATE = 3 on return, reset ISTATE to 2, call DLSODAR again. 5519 C In either case, no other parameters need be reset. 5520 C 5521 C F. Note: If and when DLSODAR regards the problem as stiff, and 5522 C switches methods accordingly, it must make use of the NEQ by NEQ 5523 C Jacobian matrix, J = df/dy. For the sake of simplicity, the 5524 C inputs to DLSODAR recommended in Paragraph C above cause DLSODAR to 5525 C treat J as a full matrix, and to approximate it internally by 5526 C difference quotients. Alternatively, J can be treated as a band 5527 C matrix (with great potential reduction in the size of the RWORK 5528 C array). Also, in either the full or banded case, the user can supply 5529 C J in closed form, with a routine whose name is passed as the JAC 5530 C argument. These alternatives are described in the paragraphs on 5531 C RWORK, JAC, and JT in the full description of the call sequence below. 5532 C 5533 C----------------------------------------------------------------------- 5534 C Example Problem. 5535 C 5536 C The following is a simple example problem, with the coding 5537 C needed for its solution by DLSODAR. The problem is from chemical 5538 C kinetics, and consists of the following three rate equations: 5539 C dy1/dt = -.04*y1 + 1.e4*y2*y3 5540 C dy2/dt = .04*y1 - 1.e4*y2*y3 - 3.e7*y2**2 5541 C dy3/dt = 3.e7*y2**2 5542 C on the interval from t = 0.0 to t = 4.e10, with initial conditions 5543 C y1 = 1.0, y2 = y3 = 0. The problem is stiff. 5544 C In addition, we want to find the values of t, y1, y2, and y3 at which 5545 C (1) y1 reaches the value 1.e-4, and 5546 C (2) y3 reaches the value 1.e-2. 5547 C 5548 C The following coding solves this problem with DLSODAR, 5549 C printing results at t = .4, 4., ..., 4.e10, and at the computed 5550 C roots. It uses ITOL = 2 and ATOL much smaller for y2 than y1 or y3 5551 C because y2 has much smaller values. 5552 C At the end of the run, statistical quantities of interest are 5553 C printed (see optional outputs in the full description below). 5554 C 5555 C EXTERNAL FEX, GEX 5556 C DOUBLE PRECISION ATOL, RTOL, RWORK, T, TOUT, Y 5557 C DIMENSION Y(3), ATOL(3), RWORK(76), IWORK(23), JROOT(2) 5558 C NEQ = 3 5559 C Y(1) = 1. 5560 C Y(2) = 0. 5561 C Y(3) = 0. 5562 C T = 0. 5563 C TOUT = .4 5564 C ITOL = 2 5565 C RTOL = 1.D-4 5566 C ATOL(1) = 1.D-6 5567 C ATOL(2) = 1.D-10 5568 C ATOL(3) = 1.D-6 5569 C ITASK = 1 5570 C ISTATE = 1 5571 C IOPT = 0 5572 C LRW = 76 5573 C LIW = 23 5574 C JT = 2 5575 C NG = 2 5576 C DO 40 IOUT = 1,12 5577 C 10 CALL DLSODAR(FEX,NEQ,Y,T,TOUT,ITOL,RTOL,ATOL,ITASK,ISTATE, 5578 C 1 IOPT,RWORK,LRW,IWORK,LIW,JDUM,JT,GEX,NG,JROOT) 5579 C WRITE(6,20)T,Y(1),Y(2),Y(3) 5580 C 20 FORMAT(' At t =',D12.4,' Y =',3D14.6) 5581 C IF (ISTATE .LT. 0) GO TO 80 5582 C IF (ISTATE .EQ. 2) GO TO 40 5583 C WRITE(6,30)JROOT(1),JROOT(2) 5584 C 30 FORMAT(5X,' The above line is a root, JROOT =',2I5) 5585 C ISTATE = 2 5586 C GO TO 10 5587 C 40 TOUT = TOUT*10. 5588 C WRITE(6,60)IWORK(11),IWORK(12),IWORK(13),IWORK(10), 5589 C 1 IWORK(19),RWORK(15) 5590 C 60 FORMAT(/' No. steps =',I4,' No. f-s =',I4,' No. J-s =',I4, 5591 C 1 ' No. g-s =',I4/ 5592 C 2 ' Method last used =',I2,' Last switch was at t =',D12.4) 5593 C STOP 5594 C 80 WRITE(6,90)ISTATE 5595 C 90 FORMAT(///' Error halt.. ISTATE =',I3) 5596 C STOP 5597 C END 5598 C 5599 C SUBROUTINE FEX (NEQ, T, Y, YDOT) 5600 C DOUBLE PRECISION T, Y, YDOT 5601 C DIMENSION Y(3), YDOT(3) 5602 C YDOT(1) = -.04*Y(1) + 1.D4*Y(2)*Y(3) 5603 C YDOT(3) = 3.D7*Y(2)*Y(2) 5604 C YDOT(2) = -YDOT(1) - YDOT(3) 5605 C RETURN 5606 C END 5607 C 5608 C SUBROUTINE GEX (NEQ, T, Y, NG, GOUT) 5609 C DOUBLE PRECISION T, Y, GOUT 5610 C DIMENSION Y(3), GOUT(2) 5611 C GOUT(1) = Y(1) - 1.D-4 5612 C GOUT(2) = Y(3) - 1.D-2 5613 C RETURN 5614 C END 5615 C 5616 C The output of this program (on a CDC-7600 in single precision) 5617 C is as follows: 5618 C 5619 C At t = 2.6400e-01 y = 9.899653e-01 3.470563e-05 1.000000e-02 5620 C The above line is a root, JROOT = 0 1 5621 C At t = 4.0000e-01 Y = 9.851712e-01 3.386380e-05 1.479493e-02 5622 C At t = 4.0000e+00 Y = 9.055333e-01 2.240655e-05 9.444430e-02 5623 C At t = 4.0000e+01 Y = 7.158403e-01 9.186334e-06 2.841505e-01 5624 C At t = 4.0000e+02 Y = 4.505250e-01 3.222964e-06 5.494717e-01 5625 C At t = 4.0000e+03 Y = 1.831975e-01 8.941774e-07 8.168016e-01 5626 C At t = 4.0000e+04 Y = 3.898730e-02 1.621940e-07 9.610125e-01 5627 C At t = 4.0000e+05 Y = 4.936363e-03 1.984221e-08 9.950636e-01 5628 C At t = 4.0000e+06 Y = 5.161831e-04 2.065786e-09 9.994838e-01 5629 C At t = 2.0745e+07 Y = 1.000000e-04 4.000395e-10 9.999000e-01 5630 C The above line is a root, JROOT = 1 0 5631 C At t = 4.0000e+07 Y = 5.179817e-05 2.072032e-10 9.999482e-01 5632 C At t = 4.0000e+08 Y = 5.283401e-06 2.113371e-11 9.999947e-01 5633 C At t = 4.0000e+09 Y = 4.659031e-07 1.863613e-12 9.999995e-01 5634 C At t = 4.0000e+10 Y = 1.404280e-08 5.617126e-14 1.000000e+00 5635 C 5636 C No. steps = 361 No. f-s = 693 No. J-s = 64 No. g-s = 390 5637 C Method last used = 2 Last switch was at t = 6.0092e-03 5638 C 5639 C----------------------------------------------------------------------- 5640 C Full Description of User Interface to DLSODAR. 5641 C 5642 C The user interface to DLSODAR consists of the following parts. 5643 C 5644 C 1. The call sequence to Subroutine DLSODAR, which is a driver 5645 C routine for the solver. This includes descriptions of both 5646 C the call sequence arguments and of user-supplied routines. 5647 C Following these descriptions is a description of 5648 C optional inputs available through the call sequence, and then 5649 C a description of optional outputs (in the work arrays). 5650 C 5651 C 2. Descriptions of other routines in the DLSODAR package that may be 5652 C (optionally) called by the user. These provide the ability to 5653 C alter error message handling, save and restore the internal 5654 C Common, and obtain specified derivatives of the solution y(t). 5655 C 5656 C 3. Descriptions of Common blocks to be declared in overlay 5657 C or similar environments, or to be saved when doing an interrupt 5658 C of the problem and continued solution later. 5659 C 5660 C 4. Description of a subroutine in the DLSODAR package, 5661 C which the user may replace with his/her own version, if desired. 5662 C this relates to the measurement of errors. 5663 C 5664 C----------------------------------------------------------------------- 5665 C Part 1. Call Sequence. 5666 C 5667 C The call sequence parameters used for input only are 5668 C F, NEQ, TOUT, ITOL, RTOL, ATOL, ITASK, IOPT, LRW, LIW, JAC, 5669 C JT, G, and NG, 5670 C that used only for output is JROOT, 5671 C and those used for both input and output are 5672 C Y, T, ISTATE. 5673 C The work arrays RWORK and IWORK are also used for conditional and 5674 C optional inputs and optional outputs. (The term output here refers 5675 C to the return from Subroutine DLSODAR to the user's calling program.) 5676 C 5677 C The legality of input parameters will be thoroughly checked on the 5678 C initial call for the problem, but not checked thereafter unless a 5679 C change in input parameters is flagged by ISTATE = 3 on input. 5680 C 5681 C The descriptions of the call arguments are as follows. 5682 C 5683 C F = the name of the user-supplied subroutine defining the 5684 C ODE system. The system must be put in the first-order 5685 C form dy/dt = f(t,y), where f is a vector-valued function 5686 C of the scalar t and the vector y. Subroutine F is to 5687 C compute the function f. It is to have the form 5688 C SUBROUTINE F (NEQ, T, Y, YDOT) 5689 C DOUBLE PRECISION T, Y(*), YDOT(*) 5690 C where NEQ, T, and Y are input, and the array YDOT = f(t,y) 5691 C is output. Y and YDOT are arrays of length NEQ. 5692 C Subroutine F should not alter Y(1),...,Y(NEQ). 5693 C F must be declared External in the calling program. 5694 C 5695 C Subroutine F may access user-defined quantities in 5696 C NEQ(2),... and/or in Y(NEQ(1)+1),... if NEQ is an array 5697 C (dimensioned in F) and/or Y has length exceeding NEQ(1). 5698 C See the descriptions of NEQ and Y below. 5699 C 5700 C If quantities computed in the F routine are needed 5701 C externally to DLSODAR, an extra call to F should be made 5702 C for this purpose, for consistent and accurate results. 5703 C If only the derivative dy/dt is needed, use DINTDY instead. 5704 C 5705 C NEQ = the size of the ODE system (number of first order 5706 C ordinary differential equations). Used only for input. 5707 C NEQ may be decreased, but not increased, during the problem. 5708 C If NEQ is decreased (with ISTATE = 3 on input), the 5709 C remaining components of Y should be left undisturbed, if 5710 C these are to be accessed in F and/or JAC. 5711 C 5712 C Normally, NEQ is a scalar, and it is generally referred to 5713 C as a scalar in this user interface description. However, 5714 C NEQ may be an array, with NEQ(1) set to the system size. 5715 C (The DLSODAR package accesses only NEQ(1).) In either case, 5716 C this parameter is passed as the NEQ argument in all calls 5717 C to F, JAC, and G. Hence, if it is an array, locations 5718 C NEQ(2),... may be used to store other integer data and pass 5719 C it to F, JAC, and G. Each such subroutine must include 5720 C NEQ in a Dimension statement in that case. 5721 C 5722 C Y = a real array for the vector of dependent variables, of 5723 C length NEQ or more. Used for both input and output on the 5724 C first call (ISTATE = 1), and only for output on other calls. 5725 C On the first call, Y must contain the vector of initial 5726 C values. On output, Y contains the computed solution vector, 5727 C evaluated at T. If desired, the Y array may be used 5728 C for other purposes between calls to the solver. 5729 C 5730 C This array is passed as the Y argument in all calls to F, 5731 C JAC, and G. Hence its length may exceed NEQ, and locations 5732 C Y(NEQ+1),... may be used to store other real data and 5733 C pass it to F, JAC, and G. (The DLSODAR package accesses only 5734 C Y(1),...,Y(NEQ).) 5735 C 5736 C T = the independent variable. On input, T is used only on the 5737 C first call, as the initial point of the integration. 5738 C On output, after each call, T is the value at which a 5739 C computed solution y is evaluated (usually the same as TOUT). 5740 C If a root was found, T is the computed location of the 5741 C root reached first, on output. 5742 C On an error return, T is the farthest point reached. 5743 C 5744 C TOUT = the next value of t at which a computed solution is desired. 5745 C Used only for input. 5746 C 5747 C When starting the problem (ISTATE = 1), TOUT may be equal 5748 C to T for one call, then should .ne. T for the next call. 5749 C For the initial T, an input value of TOUT .ne. T is used 5750 C in order to determine the direction of the integration 5751 C (i.e. the algebraic sign of the step sizes) and the rough 5752 C scale of the problem. Integration in either direction 5753 C (forward or backward in t) is permitted. 5754 C 5755 C If ITASK = 2 or 5 (one-step modes), TOUT is ignored after 5756 C the first call (i.e. the first call with TOUT .ne. T). 5757 C Otherwise, TOUT is required on every call. 5758 C 5759 C If ITASK = 1, 3, or 4, the values of TOUT need not be 5760 C monotone, but a value of TOUT which backs up is limited 5761 C to the current internal T interval, whose endpoints are 5762 C TCUR - HU and TCUR (see optional outputs, below, for 5763 C TCUR and HU). 5764 C 5765 C ITOL = an indicator for the type of error control. See 5766 C description below under ATOL. Used only for input. 5767 C 5768 C RTOL = a relative error tolerance parameter, either a scalar or 5769 C an array of length NEQ. See description below under ATOL. 5770 C Input only. 5771 C 5772 C ATOL = an absolute error tolerance parameter, either a scalar or 5773 C an array of length NEQ. Input only. 5774 C 5775 C The input parameters ITOL, RTOL, and ATOL determine 5776 C the error control performed by the solver. The solver will 5777 C control the vector E = (E(i)) of estimated local errors 5778 C in y, according to an inequality of the form 5779 C max-norm of ( E(i)/EWT(i) ) .le. 1, 5780 C where EWT = (EWT(i)) is a vector of positive error weights. 5781 C The values of RTOL and ATOL should all be non-negative. 5782 C The following table gives the types (scalar/array) of 5783 C RTOL and ATOL, and the corresponding form of EWT(i). 5784 C 5785 C ITOL RTOL ATOL EWT(i) 5786 C 1 scalar scalar RTOL*ABS(Y(i)) + ATOL 5787 C 2 scalar array RTOL*ABS(Y(i)) + ATOL(i) 5788 C 3 array scalar RTOL(i)*ABS(Y(i)) + ATOL 5789 C 4 array array RTOL(i)*ABS(Y(i)) + ATOL(i) 5790 C 5791 C When either of these parameters is a scalar, it need not 5792 C be dimensioned in the user's calling program. 5793 C 5794 C If none of the above choices (with ITOL, RTOL, and ATOL 5795 C fixed throughout the problem) is suitable, more general 5796 C error controls can be obtained by substituting a 5797 C user-supplied routine for the setting of EWT. 5798 C See Part 4 below. 5799 C 5800 C If global errors are to be estimated by making a repeated 5801 C run on the same problem with smaller tolerances, then all 5802 C components of RTOL and ATOL (i.e. of EWT) should be scaled 5803 C down uniformly. 5804 C 5805 C ITASK = an index specifying the task to be performed. 5806 C input only. ITASK has the following values and meanings. 5807 C 1 means normal computation of output values of y(t) at 5808 C t = TOUT (by overshooting and interpolating). 5809 C 2 means take one step only and return. 5810 C 3 means stop at the first internal mesh point at or 5811 C beyond t = TOUT and return. 5812 C 4 means normal computation of output values of y(t) at 5813 C t = TOUT but without overshooting t = TCRIT. 5814 C TCRIT must be input as RWORK(1). TCRIT may be equal to 5815 C or beyond TOUT, but not behind it in the direction of 5816 C integration. This option is useful if the problem 5817 C has a singularity at or beyond t = TCRIT. 5818 C 5 means take one step, without passing TCRIT, and return. 5819 C TCRIT must be input as RWORK(1). 5820 C 5821 C Note: If ITASK = 4 or 5 and the solver reaches TCRIT 5822 C (within roundoff), it will return T = TCRIT (exactly) to 5823 C indicate this (unless ITASK = 4 and TOUT comes before TCRIT, 5824 C in which case answers at t = TOUT are returned first). 5825 C 5826 C ISTATE = an index used for input and output to specify the 5827 C the state of the calculation. 5828 C 5829 C On input, the values of ISTATE are as follows. 5830 C 1 means this is the first call for the problem 5831 C (initializations will be done). See note below. 5832 C 2 means this is not the first call, and the calculation 5833 C is to continue normally, with no change in any input 5834 C parameters except possibly TOUT and ITASK. 5835 C (If ITOL, RTOL, and/or ATOL are changed between calls 5836 C with ISTATE = 2, the new values will be used but not 5837 C tested for legality.) 5838 C 3 means this is not the first call, and the 5839 C calculation is to continue normally, but with 5840 C a change in input parameters other than 5841 C TOUT and ITASK. Changes are allowed in 5842 C NEQ, ITOL, RTOL, ATOL, IOPT, LRW, LIW, JT, ML, MU, 5843 C and any optional inputs except H0, MXORDN, and MXORDS. 5844 C (See IWORK description for ML and MU.) 5845 C In addition, immediately following a return with 5846 C ISTATE = 3 (root found), NG and G may be changed. 5847 C (But changing NG from 0 to .gt. 0 is not allowed.) 5848 C Note: A preliminary call with TOUT = T is not counted 5849 C as a first call here, as no initialization or checking of 5850 C input is done. (Such a call is sometimes useful for the 5851 C purpose of outputting the initial conditions.) 5852 C Thus the first call for which TOUT .ne. T requires 5853 C ISTATE = 1 on input. 5854 C 5855 C On output, ISTATE has the following values and meanings. 5856 C 1 means nothing was done; TOUT = t and ISTATE = 1 on input. 5857 C 2 means the integration was performed successfully, and 5858 C no roots were found. 5859 C 3 means the integration was successful, and one or more 5860 C roots were found before satisfying the stop condition 5861 C specified by ITASK. See JROOT. 5862 C -1 means an excessive amount of work (more than MXSTEP 5863 C steps) was done on this call, before completing the 5864 C requested task, but the integration was otherwise 5865 C successful as far as T. (MXSTEP is an optional input 5866 C and is normally 500.) To continue, the user may 5867 C simply reset ISTATE to a value .gt. 1 and call again 5868 C (the excess work step counter will be reset to 0). 5869 C In addition, the user may increase MXSTEP to avoid 5870 C this error return (see below on optional inputs). 5871 C -2 means too much accuracy was requested for the precision 5872 C of the machine being used. This was detected before 5873 C completing the requested task, but the integration 5874 C was successful as far as T. To continue, the tolerance 5875 C parameters must be reset, and ISTATE must be set 5876 C to 3. The optional output TOLSF may be used for this 5877 C purpose. (Note: If this condition is detected before 5878 C taking any steps, then an illegal input return 5879 C (ISTATE = -3) occurs instead.) 5880 C -3 means illegal input was detected, before taking any 5881 C integration steps. See written message for details. 5882 C Note: If the solver detects an infinite loop of calls 5883 C to the solver with illegal input, it will cause 5884 C the run to stop. 5885 C -4 means there were repeated error test failures on 5886 C one attempted step, before completing the requested 5887 C task, but the integration was successful as far as T. 5888 C The problem may have a singularity, or the input 5889 C may be inappropriate. 5890 C -5 means there were repeated convergence test failures on 5891 C one attempted step, before completing the requested 5892 C task, but the integration was successful as far as T. 5893 C This may be caused by an inaccurate Jacobian matrix, 5894 C if one is being used. 5895 C -6 means EWT(i) became zero for some i during the 5896 C integration. Pure relative error control (ATOL(i)=0.0) 5897 C was requested on a variable which has now vanished. 5898 C The integration was successful as far as T. 5899 C -7 means the length of RWORK and/or IWORK was too small to 5900 C proceed, but the integration was successful as far as T. 5901 C This happens when DLSODAR chooses to switch methods 5902 C but LRW and/or LIW is too small for the new method. 5903 C 5904 C Note: Since the normal output value of ISTATE is 2, 5905 C it does not need to be reset for normal continuation. 5906 C Also, since a negative input value of ISTATE will be 5907 C regarded as illegal, a negative output value requires the 5908 C user to change it, and possibly other inputs, before 5909 C calling the solver again. 5910 C 5911 C IOPT = an integer flag to specify whether or not any optional 5912 C inputs are being used on this call. Input only. 5913 C The optional inputs are listed separately below. 5914 C IOPT = 0 means no optional inputs are being used. 5915 C Default values will be used in all cases. 5916 C IOPT = 1 means one or more optional inputs are being used. 5917 C 5918 C RWORK = a real array (double precision) for work space, and (in the 5919 C first 20 words) for conditional and optional inputs and 5920 C optional outputs. 5921 C As DLSODAR switches automatically between stiff and nonstiff 5922 C methods, the required length of RWORK can change during the 5923 C problem. Thus the RWORK array passed to DLSODAR can either 5924 C have a static (fixed) length large enough for both methods, 5925 C or have a dynamic (changing) length altered by the calling 5926 C program in response to output from DLSODAR. 5927 C 5928 C --- Fixed Length Case --- 5929 C If the RWORK length is to be fixed, it should be at least 5930 C max (LRN, LRS), 5931 C where LRN and LRS are the RWORK lengths required when the 5932 C current method is nonstiff or stiff, respectively. 5933 C 5934 C The separate RWORK length requirements LRN and LRS are 5935 C as follows: 5936 C If NEQ is constant and the maximum method orders have 5937 C their default values, then 5938 C LRN = 20 + 16*NEQ + 3*NG, 5939 C LRS = 22 + 9*NEQ + NEQ**2 + 3*NG (JT = 1 or 2), 5940 C LRS = 22 + 10*NEQ + (2*ML+MU)*NEQ + 3*NG (JT = 4 or 5). 5941 C Under any other conditions, LRN and LRS are given by: 5942 C LRN = 20 + NYH*(MXORDN+1) + 3*NEQ + 3*NG, 5943 C LRS = 20 + NYH*(MXORDS+1) + 3*NEQ + LMAT + 3*NG, 5944 C where 5945 C NYH = the initial value of NEQ, 5946 C MXORDN = 12, unless a smaller value is given as an 5947 C optional input, 5948 C MXORDS = 5, unless a smaller value is given as an 5949 C optional input, 5950 C LMAT = length of matrix work space: 5951 C LMAT = NEQ**2 + 2 if JT = 1 or 2, 5952 C LMAT = (2*ML + MU + 1)*NEQ + 2 if JT = 4 or 5. 5953 C 5954 C --- Dynamic Length Case --- 5955 C If the length of RWORK is to be dynamic, then it should 5956 C be at least LRN or LRS, as defined above, depending on the 5957 C current method. Initially, it must be at least LRN (since 5958 C DLSODAR starts with the nonstiff method). On any return 5959 C from DLSODAR, the optional output MCUR indicates the current 5960 C method. If MCUR differs from the value it had on the 5961 C previous return, or if there has only been one call to 5962 C DLSODAR and MCUR is now 2, then DLSODAR has switched 5963 C methods during the last call, and the length of RWORK 5964 C should be reset (to LRN if MCUR = 1, or to LRS if 5965 C MCUR = 2). (An increase in the RWORK length is required 5966 C if DLSODAR returned ISTATE = -7, but not otherwise.) 5967 C After resetting the length, call DLSODAR with ISTATE = 3 5968 C to signal that change. 5969 C 5970 C LRW = the length of the array RWORK, as declared by the user. 5971 C (This will be checked by the solver.) 5972 C 5973 C IWORK = an integer array for work space. 5974 C As DLSODAR switches automatically between stiff and nonstiff 5975 C methods, the required length of IWORK can change during 5976 C problem, between 5977 C LIS = 20 + NEQ and LIN = 20, 5978 C respectively. Thus the IWORK array passed to DLSODAR can 5979 C either have a fixed length of at least 20 + NEQ, or have a 5980 C dynamic length of at least LIN or LIS, depending on the 5981 C current method. The comments on dynamic length under 5982 C RWORK above apply here. Initially, this length need 5983 C only be at least LIN = 20. 5984 C 5985 C The first few words of IWORK are used for conditional and 5986 C optional inputs and optional outputs. 5987 C 5988 C The following 2 words in IWORK are conditional inputs: 5989 C IWORK(1) = ML These are the lower and upper 5990 C IWORK(2) = MU half-bandwidths, respectively, of the 5991 C banded Jacobian, excluding the main diagonal. 5992 C The band is defined by the matrix locations 5993 C (i,j) with i-ML .le. j .le. i+MU. ML and MU 5994 C must satisfy 0 .le. ML,MU .le. NEQ-1. 5995 C These are required if JT is 4 or 5, and 5996 C ignored otherwise. ML and MU may in fact be 5997 C the band parameters for a matrix to which 5998 C df/dy is only approximately equal. 5999 C 6000 C LIW = the length of the array IWORK, as declared by the user. 6001 C (This will be checked by the solver.) 6002 C 6003 C Note: The base addresses of the work arrays must not be 6004 C altered between calls to DLSODAR for the same problem. 6005 C The contents of the work arrays must not be altered 6006 C between calls, except possibly for the conditional and 6007 C optional inputs, and except for the last 3*NEQ words of RWORK. 6008 C The latter space is used for internal scratch space, and so is 6009 C available for use by the user outside DLSODAR between calls, if 6010 C desired (but not for use by F, JAC, or G). 6011 C 6012 C JAC = the name of the user-supplied routine to compute the 6013 C Jacobian matrix, df/dy, if JT = 1 or 4. The JAC routine 6014 C is optional, but if the problem is expected to be stiff much 6015 C of the time, you are encouraged to supply JAC, for the sake 6016 C of efficiency. (Alternatively, set JT = 2 or 5 to have 6017 C DLSODAR compute df/dy internally by difference quotients.) 6018 C If and when DLSODAR uses df/dy, it treats this NEQ by NEQ 6019 C matrix either as full (JT = 1 or 2), or as banded (JT = 6020 C 4 or 5) with half-bandwidths ML and MU (discussed under 6021 C IWORK above). In either case, if JT = 1 or 4, the JAC 6022 C routine must compute df/dy as a function of the scalar t 6023 C and the vector y. It is to have the form 6024 C SUBROUTINE JAC (NEQ, T, Y, ML, MU, PD, NROWPD) 6025 C DOUBLE PRECISION T, Y(*), PD(NROWPD,*) 6026 C where NEQ, T, Y, ML, MU, and NROWPD are input and the array 6027 C PD is to be loaded with partial derivatives (elements of 6028 C the Jacobian matrix) on output. PD must be given a first 6029 C dimension of NROWPD. T and Y have the same meaning as in 6030 C Subroutine F. 6031 C In the full matrix case (JT = 1), ML and MU are 6032 C ignored, and the Jacobian is to be loaded into PD in 6033 C columnwise manner, with df(i)/dy(j) loaded into pd(i,j). 6034 C In the band matrix case (JT = 4), the elements 6035 C within the band are to be loaded into PD in columnwise 6036 C manner, with diagonal lines of df/dy loaded into the rows 6037 C of PD. Thus df(i)/dy(j) is to be loaded into PD(i-j+MU+1,j). 6038 C ML and MU are the half-bandwidth parameters (see IWORK). 6039 C The locations in PD in the two triangular areas which 6040 C correspond to nonexistent matrix elements can be ignored 6041 C or loaded arbitrarily, as they are overwritten by DLSODAR. 6042 C JAC need not provide df/dy exactly. A crude 6043 C approximation (possibly with a smaller bandwidth) will do. 6044 C In either case, PD is preset to zero by the solver, 6045 C so that only the nonzero elements need be loaded by JAC. 6046 C Each call to JAC is preceded by a call to F with the same 6047 C arguments NEQ, T, and Y. Thus to gain some efficiency, 6048 C intermediate quantities shared by both calculations may be 6049 C saved in a user Common block by F and not recomputed by JAC, 6050 C if desired. Also, JAC may alter the Y array, if desired. 6051 C JAC must be declared External in the calling program. 6052 C Subroutine JAC may access user-defined quantities in 6053 C NEQ(2),... and/or in Y(NEQ(1)+1),... if NEQ is an array 6054 C (dimensioned in JAC) and/or Y has length exceeding NEQ(1). 6055 C See the descriptions of NEQ and Y above. 6056 C 6057 C JT = Jacobian type indicator. Used only for input. 6058 C JT specifies how the Jacobian matrix df/dy will be 6059 C treated, if and when DLSODAR requires this matrix. 6060 C JT has the following values and meanings: 6061 C 1 means a user-supplied full (NEQ by NEQ) Jacobian. 6062 C 2 means an internally generated (difference quotient) full 6063 C Jacobian (using NEQ extra calls to F per df/dy value). 6064 C 4 means a user-supplied banded Jacobian. 6065 C 5 means an internally generated banded Jacobian (using 6066 C ML+MU+1 extra calls to F per df/dy evaluation). 6067 C If JT = 1 or 4, the user must supply a Subroutine JAC 6068 C (the name is arbitrary) as described above under JAC. 6069 C If JT = 2 or 5, a dummy argument can be used. 6070 C 6071 C G = the name of subroutine for constraint functions, whose 6072 C roots are desired during the integration. It is to have 6073 C the form 6074 C SUBROUTINE G (NEQ, T, Y, NG, GOUT) 6075 C DOUBLE PRECISION T, Y(*), GOUT(NG) 6076 C where NEQ, T, Y, and NG are input, and the array GOUT 6077 C is output. NEQ, T, and Y have the same meaning as in 6078 C the F routine, and GOUT is an array of length NG. 6079 C For i = 1,...,NG, this routine is to load into GOUT(i) 6080 C the value at (T,Y) of the i-th constraint function g(i). 6081 C DLSODAR will find roots of the g(i) of odd multiplicity 6082 C (i.e. sign changes) as they occur during the integration. 6083 C G must be declared External in the calling program. 6084 C 6085 C Caution: Because of numerical errors in the functions 6086 C g(i) due to roundoff and integration error, DLSODAR may 6087 C return false roots, or return the same root at two or more 6088 C nearly equal values of t. If such false roots are 6089 C suspected, the user should consider smaller error tolerances 6090 C and/or higher precision in the evaluation of the g(i). 6091 C 6092 C If a root of some g(i) defines the end of the problem, 6093 C the input to DLSODAR should nevertheless allow integration 6094 C to a point slightly past that root, so that DLSODAR can 6095 C locate the root by interpolation. 6096 C 6097 C Subroutine G may access user-defined quantities in 6098 C NEQ(2),... and Y(NEQ(1)+1),... if NEQ is an array 6099 C (dimensioned in G) and/or Y has length exceeding NEQ(1). 6100 C See the descriptions of NEQ and Y above. 6101 C 6102 C NG = number of constraint functions g(i). If there are none, 6103 C set NG = 0, and pass a dummy name for G. 6104 C 6105 C JROOT = integer array of length NG. Used only for output. 6106 C On a return with ISTATE = 3 (one or more roots found), 6107 C JROOT(i) = 1 if g(i) has a root at T, or JROOT(i) = 0 if not. 6108 C----------------------------------------------------------------------- 6109 C Optional Inputs. 6110 C 6111 C The following is a list of the optional inputs provided for in the 6112 C call sequence. (See also Part 2.) For each such input variable, 6113 C this table lists its name as used in this documentation, its 6114 C location in the call sequence, its meaning, and the default value. 6115 C The use of any of these inputs requires IOPT = 1, and in that 6116 C case all of these inputs are examined. A value of zero for any 6117 C of these optional inputs will cause the default value to be used. 6118 C Thus to use a subset of the optional inputs, simply preload 6119 C locations 5 to 10 in RWORK and IWORK to 0.0 and 0 respectively, and 6120 C then set those of interest to nonzero values. 6121 C 6122 C Name Location Meaning and Default Value 6123 C 6124 C H0 RWORK(5) the step size to be attempted on the first step. 6125 C The default value is determined by the solver. 6126 C 6127 C HMAX RWORK(6) the maximum absolute step size allowed. 6128 C The default value is infinite. 6129 C 6130 C HMIN RWORK(7) the minimum absolute step size allowed. 6131 C The default value is 0. (This lower bound is not 6132 C enforced on the final step before reaching TCRIT 6133 C when ITASK = 4 or 5.) 6134 C 6135 C IXPR IWORK(5) flag to generate extra printing at method switches. 6136 C IXPR = 0 means no extra printing (the default). 6137 C IXPR = 1 means print data on each switch. 6138 C T, H, and NST will be printed on the same logical 6139 C unit as used for error messages. 6140 C 6141 C MXSTEP IWORK(6) maximum number of (internally defined) steps 6142 C allowed during one call to the solver. 6143 C The default value is 500. 6144 C 6145 C MXHNIL IWORK(7) maximum number of messages printed (per problem) 6146 C warning that T + H = T on a step (H = step size). 6147 C This must be positive to result in a non-default 6148 C value. The default value is 10. 6149 C 6150 C MXORDN IWORK(8) the maximum order to be allowed for the nonstiff 6151 C (Adams) method. The default value is 12. 6152 C If MXORDN exceeds the default value, it will 6153 C be reduced to the default value. 6154 C MXORDN is held constant during the problem. 6155 C 6156 C MXORDS IWORK(9) the maximum order to be allowed for the stiff 6157 C (BDF) method. The default value is 5. 6158 C If MXORDS exceeds the default value, it will 6159 C be reduced to the default value. 6160 C MXORDS is held constant during the problem. 6161 C----------------------------------------------------------------------- 6162 C Optional Outputs. 6163 C 6164 C As optional additional output from DLSODAR, the variables listed 6165 C below are quantities related to the performance of DLSODAR 6166 C which are available to the user. These are communicated by way of 6167 C the work arrays, but also have internal mnemonic names as shown. 6168 C Except where stated otherwise, all of these outputs are defined 6169 C on any successful return from DLSODAR, and on any return with 6170 C ISTATE = -1, -2, -4, -5, or -6. On an illegal input return 6171 C (ISTATE = -3), they will be unchanged from their existing values 6172 C (if any), except possibly for TOLSF, LENRW, and LENIW. 6173 C On any error return, outputs relevant to the error will be defined, 6174 C as noted below. 6175 C 6176 C Name Location Meaning 6177 C 6178 C HU RWORK(11) the step size in t last used (successfully). 6179 C 6180 C HCUR RWORK(12) the step size to be attempted on the next step. 6181 C 6182 C TCUR RWORK(13) the current value of the independent variable 6183 C which the solver has actually reached, i.e. the 6184 C current internal mesh point in t. On output, TCUR 6185 C will always be at least as far as the argument 6186 C T, but may be farther (if interpolation was done). 6187 C 6188 C TOLSF RWORK(14) a tolerance scale factor, greater than 1.0, 6189 C computed when a request for too much accuracy was 6190 C detected (ISTATE = -3 if detected at the start of 6191 C the problem, ISTATE = -2 otherwise). If ITOL is 6192 C left unaltered but RTOL and ATOL are uniformly 6193 C scaled up by a factor of TOLSF for the next call, 6194 C then the solver is deemed likely to succeed. 6195 C (The user may also ignore TOLSF and alter the 6196 C tolerance parameters in any other way appropriate.) 6197 C 6198 C TSW RWORK(15) the value of t at the time of the last method 6199 C switch, if any. 6200 C 6201 C NGE IWORK(10) the number of g evaluations for the problem so far. 6202 C 6203 C NST IWORK(11) the number of steps taken for the problem so far. 6204 C 6205 C NFE IWORK(12) the number of f evaluations for the problem so far. 6206 C 6207 C NJE IWORK(13) the number of Jacobian evaluations (and of matrix 6208 C LU decompositions) for the problem so far. 6209 C 6210 C NQU IWORK(14) the method order last used (successfully). 6211 C 6212 C NQCUR IWORK(15) the order to be attempted on the next step. 6213 C 6214 C IMXER IWORK(16) the index of the component of largest magnitude in 6215 C the weighted local error vector ( E(i)/EWT(i) ), 6216 C on an error return with ISTATE = -4 or -5. 6217 C 6218 C LENRW IWORK(17) the length of RWORK actually required, assuming 6219 C that the length of RWORK is to be fixed for the 6220 C rest of the problem, and that switching may occur. 6221 C This is defined on normal returns and on an illegal 6222 C input return for insufficient storage. 6223 C 6224 C LENIW IWORK(18) the length of IWORK actually required, assuming 6225 C that the length of IWORK is to be fixed for the 6226 C rest of the problem, and that switching may occur. 6227 C This is defined on normal returns and on an illegal 6228 C input return for insufficient storage. 6229 C 6230 C MUSED IWORK(19) the method indicator for the last successful step: 6231 C 1 means Adams (nonstiff), 2 means BDF (stiff). 6232 C 6233 C MCUR IWORK(20) the current method indicator: 6234 C 1 means Adams (nonstiff), 2 means BDF (stiff). 6235 C This is the method to be attempted 6236 C on the next step. Thus it differs from MUSED 6237 C only if a method switch has just been made. 6238 C 6239 C The following two arrays are segments of the RWORK array which 6240 C may also be of interest to the user as optional outputs. 6241 C For each array, the table below gives its internal name, 6242 C its base address in RWORK, and its description. 6243 C 6244 C Name Base Address Description 6245 C 6246 C YH 21 + 3*NG the Nordsieck history array, of size NYH by 6247 C (NQCUR + 1), where NYH is the initial value 6248 C of NEQ. For j = 0,1,...,NQCUR, column j+1 6249 C of YH contains HCUR**j/factorial(j) times 6250 C the j-th derivative of the interpolating 6251 C polynomial currently representing the solution, 6252 C evaluated at t = TCUR. 6253 C 6254 C ACOR LACOR array of size NEQ used for the accumulated 6255 C (from Common corrections on each step, scaled on output 6256 C as noted) to represent the estimated local error in y 6257 C on the last step. This is the vector E in 6258 C the description of the error control. It is 6259 C defined only on a successful return from 6260 C DLSODAR. The base address LACOR is obtained by 6261 C including in the user's program the 6262 C following 2 lines: 6263 C COMMON /DLS001/ RLS(218), ILS(37) 6264 C LACOR = ILS(22) 6265 C 6266 C----------------------------------------------------------------------- 6267 C Part 2. Other Routines Callable. 6268 C 6269 C The following are optional calls which the user may make to 6270 C gain additional capabilities in conjunction with DLSODAR. 6271 C (The routines XSETUN and XSETF are designed to conform to the 6272 C SLATEC error handling package.) 6273 C 6274 C Form of Call Function 6275 C CALL XSETUN(LUN) Set the logical unit number, LUN, for 6276 C output of messages from DLSODAR, if 6277 C the default is not desired. 6278 C The default value of LUN is 6. 6279 C 6280 C CALL XSETF(MFLAG) Set a flag to control the printing of 6281 C messages by DLSODAR. 6282 C MFLAG = 0 means do not print. (Danger: 6283 C This risks losing valuable information.) 6284 C MFLAG = 1 means print (the default). 6285 C 6286 C Either of the above calls may be made at 6287 C any time and will take effect immediately. 6288 C 6289 C CALL DSRCAR(RSAV,ISAV,JOB) saves and restores the contents of 6290 C the internal Common blocks used by 6291 C DLSODAR (see Part 3 below). 6292 C RSAV must be a real array of length 245 6293 C or more, and ISAV must be an integer 6294 C array of length 55 or more. 6295 C JOB=1 means save Common into RSAV/ISAV. 6296 C JOB=2 means restore Common from RSAV/ISAV. 6297 C DSRCAR is useful if one is 6298 C interrupting a run and restarting 6299 C later, or alternating between two or 6300 C more problems solved with DLSODAR. 6301 C 6302 C CALL DINTDY(,,,,,) Provide derivatives of y, of various 6303 C (see below) orders, at a specified point t, if 6304 C desired. It may be called only after 6305 C a successful return from DLSODAR. 6306 C 6307 C The detailed instructions for using DINTDY are as follows. 6308 C The form of the call is: 6309 C 6310 C LYH = 21 + 3*NG 6311 C CALL DINTDY (T, K, RWORK(LYH), NYH, DKY, IFLAG) 6312 C 6313 C The input parameters are: 6314 C 6315 C T = value of independent variable where answers are desired 6316 C (normally the same as the T last returned by DLSODAR). 6317 C For valid results, T must lie between TCUR - HU and TCUR. 6318 C (See optional outputs for TCUR and HU.) 6319 C K = integer order of the derivative desired. K must satisfy 6320 C 0 .le. K .le. NQCUR, where NQCUR is the current order 6321 C (see optional outputs). The capability corresponding 6322 C to K = 0, i.e. computing y(t), is already provided 6323 C by DLSODAR directly. Since NQCUR .ge. 1, the first 6324 C derivative dy/dt is always available with DINTDY. 6325 C LYH = 21 + 3*NG = base address in RWORK of the history array YH. 6326 C NYH = column length of YH, equal to the initial value of NEQ. 6327 C 6328 C The output parameters are: 6329 C 6330 C DKY = a real array of length NEQ containing the computed value 6331 C of the K-th derivative of y(t). 6332 C IFLAG = integer flag, returned as 0 if K and T were legal, 6333 C -1 if K was illegal, and -2 if T was illegal. 6334 C On an error return, a message is also written. 6335 C----------------------------------------------------------------------- 6336 C Part 3. Common Blocks. 6337 C 6338 C If DLSODAR is to be used in an overlay situation, the user 6339 C must declare, in the primary overlay, the variables in: 6340 C (1) the call sequence to DLSODAR, and 6341 C (2) the three internal Common blocks 6342 C /DLS001/ of length 255 (218 double precision words 6343 C followed by 37 integer words), 6344 C /DLSA01/ of length 31 (22 double precision words 6345 C followed by 9 integer words). 6346 C /DLSR01/ of length 7 (3 double precision words 6347 C followed by 4 integer words). 6348 C 6349 C If DLSODAR is used on a system in which the contents of internal 6350 C Common blocks are not preserved between calls, the user should 6351 C declare the above Common blocks in the calling program to insure 6352 C that their contents are preserved. 6353 C 6354 C If the solution of a given problem by DLSODAR is to be interrupted 6355 C and then later continued, such as when restarting an interrupted run 6356 C or alternating between two or more problems, the user should save, 6357 C following the return from the last DLSODAR call prior to the 6358 C interruption, the contents of the call sequence variables and the 6359 C internal Common blocks, and later restore these values before the 6360 C next DLSODAR call for that problem. To save and restore the Common 6361 C blocks, use Subroutine DSRCAR (see Part 2 above). 6362 C 6363 C----------------------------------------------------------------------- 6364 C Part 4. Optionally Replaceable Solver Routines. 6365 C 6366 C Below is a description of a routine in the DLSODAR package which 6367 C relates to the measurement of errors, and can be 6368 C replaced by a user-supplied version, if desired. However, since such 6369 C a replacement may have a major impact on performance, it should be 6370 C done only when absolutely necessary, and only with great caution. 6371 C (Note: The means by which the package version of a routine is 6372 C superseded by the user's version may be system-dependent.) 6373 C 6374 C (a) DEWSET. 6375 C The following subroutine is called just before each internal 6376 C integration step, and sets the array of error weights, EWT, as 6377 C described under ITOL/RTOL/ATOL above: 6378 C Subroutine DEWSET (NEQ, ITOL, RTOL, ATOL, YCUR, EWT) 6379 C where NEQ, ITOL, RTOL, and ATOL are as in the DLSODAR call sequence, 6380 C YCUR contains the current dependent variable vector, and 6381 C EWT is the array of weights set by DEWSET. 6382 C 6383 C If the user supplies this subroutine, it must return in EWT(i) 6384 C (i = 1,...,NEQ) a positive quantity suitable for comparing errors 6385 C in y(i) to. The EWT array returned by DEWSET is passed to the 6386 C DMNORM routine, and also used by DLSODAR in the computation 6387 C of the optional output IMXER, and the increments for difference 6388 C quotient Jacobians. 6389 C 6390 C In the user-supplied version of DEWSET, it may be desirable to use 6391 C the current values of derivatives of y. Derivatives up to order NQ 6392 C are available from the history array YH, described above under 6393 C optional outputs. In DEWSET, YH is identical to the YCUR array, 6394 C extended to NQ + 1 columns with a column length of NYH and scale 6395 C factors of H**j/factorial(j). On the first call for the problem, 6396 C given by NST = 0, NQ is 1 and H is temporarily set to 1.0. 6397 C NYH is the initial value of NEQ. The quantities NQ, H, and NST 6398 C can be obtained by including in DEWSET the statements: 6399 C DOUBLE PRECISION RLS 6400 C COMMON /DLS001/ RLS(218),ILS(37) 6401 C NQ = ILS(33) 6402 C NST = ILS(34) 6403 C H = RLS(212) 6404 C Thus, for example, the current value of dy/dt can be obtained as 6405 C YCUR(NYH+i)/H (i=1,...,NEQ) (and the division by H is 6406 C unnecessary when NST = 0). 6407 C----------------------------------------------------------------------- 6408 C 6409 C***REVISION HISTORY (YYYYMMDD) 6410 C 19811102 DATE WRITTEN 6411 C 19820126 Fixed bug in tests of work space lengths; 6412 C minor corrections in main prologue and comments. 6413 C 19820507 Fixed bug in RCHEK in setting HMING. 6414 C 19870330 Major update: corrected comments throughout; 6415 C removed TRET from Common; rewrote EWSET with 4 loops; 6416 C fixed t test in INTDY; added Cray directives in STODA; 6417 C in STODA, fixed DELP init. and logic around PJAC call; 6418 C combined routines to save/restore Common; 6419 C passed LEVEL = 0 in error message calls (except run abort). 6420 C 19970225 Fixed lines setting JSTART = -2 in Subroutine LSODAR. 6421 C 20010425 Major update: convert source lines to upper case; 6422 C added *DECK lines; changed from 1 to * in dummy dimensions; 6423 C changed names R1MACH/D1MACH to RUMACH/DUMACH; 6424 C renamed routines for uniqueness across single/double prec.; 6425 C converted intrinsic names to generic form; 6426 C removed ILLIN and NTREP (data loaded) from Common; 6427 C removed all 'own' variables from Common; 6428 C changed error messages to quoted strings; 6429 C replaced XERRWV/XERRWD with 1993 revised version; 6430 C converted prologues, comments, error messages to mixed case; 6431 C numerous corrections to prologues and internal comments. 6432 C 20010507 Converted single precision source to double precision. 6433 C 20010613 Revised excess accuracy test (to match rest of ODEPACK). 6434 C 20010808 Fixed bug in DPRJA (matrix in DBNORM call). 6435 C 20020502 Corrected declarations in descriptions of user routines. 6436 C 20031105 Restored 'own' variables to Common blocks, to enable 6437 C interrupt/restart feature. 6438 C 20031112 Added SAVE statements for data-loaded constants. 6439 C 6440 C----------------------------------------------------------------------- 6441 C Other routines in the DLSODAR package. 6442 C 6443 C In addition to Subroutine DLSODAR, the DLSODAR package includes the 6444 C following subroutines and function routines: 6445 C DRCHEK does preliminary checking for roots, and serves as an 6446 C interface between Subroutine DLSODAR and Subroutine DROOTS. 6447 C DROOTS finds the leftmost root of a set of functions. 6448 C DINTDY computes an interpolated value of the y vector at t = TOUT. 6449 C DSTODA is the core integrator, which does one step of the 6450 C integration and the associated error control. 6451 C DCFODE sets all method coefficients and test constants. 6452 C DPRJA computes and preprocesses the Jacobian matrix J = df/dy 6453 C and the Newton iteration matrix P = I - h*l0*J. 6454 C DSOLSY manages solution of linear system in chord iteration. 6455 C DEWSET sets the error weight vector EWT before each step. 6456 C DMNORM computes the weighted max-norm of a vector. 6457 C DFNORM computes the norm of a full matrix consistent with the 6458 C weighted max-norm on vectors. 6459 C DBNORM computes the norm of a band matrix consistent with the 6460 C weighted max-norm on vectors. 6461 C DSRCAR is a user-callable routine to save and restore 6462 C the contents of the internal Common blocks. 6463 C DGEFA and DGESL are routines from LINPACK for solving full 6464 C systems of linear algebraic equations. 6465 C DGBFA and DGBSL are routines from LINPACK for solving banded 6466 C linear systems. 6467 C DCOPY is one of the basic linear algebra modules (BLAS). 6468 C DUMACH computes the unit roundoff in a machine-independent manner. 6469 C XERRWD, XSETUN, XSETF, IXSAV, and IUMACH handle the printing of all 6470 C error messages and warnings. XERRWD is machine-dependent. 6471 C Note: DMNORM, DFNORM, DBNORM, DUMACH, IXSAV, and IUMACH are 6472 C function routines. All the others are subroutines. 6473 C 6474 C----------------------------------------------------------------------- 6475 EXTERNAL DPRJA, DSOLSY 6476 DOUBLE PRECISION DUMACH, DMNORM 6477 INTEGER INIT, MXSTEP, MXHNIL, NHNIL, NSLAST, NYH, IOWNS, 6478 1 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 6479 2 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 6480 3 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU 6481 INTEGER INSUFR, INSUFI, IXPR, IOWNS2, JTYP, MUSED, MXORDN, MXORDS 6482 INTEGER LG0, LG1, LGX, IOWNR3, IRFND, ITASKC, NGC, NGE 6483 INTEGER I, I1, I2, IFLAG, IMXER, KGO, LENIW, 6484 1 LENRW, LENWM, LF0, ML, MORD, MU, MXHNL0, MXSTP0 6485 INTEGER LEN1, LEN1C, LEN1N, LEN1S, LEN2, LENIWC, LENRWC 6486 INTEGER IRFP, IRT, LENYH, LYHNEW 6487 DOUBLE PRECISION ROWNS, 6488 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND 6489 DOUBLE PRECISION TSW, ROWNS2, PDNORM 6490 DOUBLE PRECISION ROWNR3, T0, TLAST, TOUTC 6491 DOUBLE PRECISION ATOLI, AYI, BIG, EWTI, H0, HMAX, HMX, RH, RTOLI, 6492 1 TCRIT, TDIST, TNEXT, TOL, TOLSF, TP, SIZE, SUM, W0 6493 DIMENSION MORD(2) 6494 LOGICAL IHIT 6495 CHARACTER*60 MSG 6496 SAVE MORD, MXSTP0, MXHNL0 6497 C----------------------------------------------------------------------- 6498 C The following three internal Common blocks contain 6499 C (a) variables which are local to any subroutine but whose values must 6500 C be preserved between calls to the routine ("own" variables), and 6501 C (b) variables which are communicated between subroutines. 6502 C The block DLS001 is declared in subroutines DLSODAR, DINTDY, DSTODA, 6503 C DPRJA, and DSOLSY. 6504 C The block DLSA01 is declared in subroutines DLSODAR, DSTODA, DPRJA. 6505 C The block DLSR01 is declared in subroutines DLSODAR, DRCHEK, DROOTS. 6506 C Groups of variables are replaced by dummy arrays in the Common 6507 C declarations in routines where those variables are not used. 6508 C----------------------------------------------------------------------- 6509 COMMON /DLS001/ ROWNS(209), 6510 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND, 6511 2 INIT, MXSTEP, MXHNIL, NHNIL, NSLAST, NYH, IOWNS(6), 6512 3 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 6513 4 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 6514 5 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU 6515 C 6516 COMMON /DLSA01/ TSW, ROWNS2(20), PDNORM, 6517 1 INSUFR, INSUFI, IXPR, IOWNS2(2), JTYP, MUSED, MXORDN, MXORDS 6518 C 6519 COMMON /DLSR01/ ROWNR3(2), T0, TLAST, TOUTC, 6520 1 LG0, LG1, LGX, IOWNR3(2), IRFND, ITASKC, NGC, NGE 6521 C 6522 DATA MORD(1),MORD(2)/12,5/, MXSTP0/500/, MXHNL0/10/ 6523 C----------------------------------------------------------------------- 6524 C Block A. 6525 C This code block is executed on every call. 6526 C It tests ISTATE and ITASK for legality and branches appropriately. 6527 C If ISTATE .gt. 1 but the flag INIT shows that initialization has 6528 C not yet been done, an error return occurs. 6529 C If ISTATE = 1 and TOUT = T, return immediately. 6530 C----------------------------------------------------------------------- 6531 IF (ISTATE .LT. 1 .OR. ISTATE .GT. 3) GO TO 601 6532 IF (ITASK .LT. 1 .OR. ITASK .GT. 5) GO TO 602 6533 ITASKC = ITASK 6534 IF (ISTATE .EQ. 1) GO TO 10 6535 IF (INIT .EQ. 0) GO TO 603 6536 IF (ISTATE .EQ. 2) GO TO 200 6537 GO TO 20 6538 10 INIT = 0 6539 IF (TOUT .EQ. T) RETURN 6540 C----------------------------------------------------------------------- 6541 C Block B. 6542 C The next code block is executed for the initial call (ISTATE = 1), 6543 C or for a continuation call with parameter changes (ISTATE = 3). 6544 C It contains checking of all inputs and various initializations. 6545 C 6546 C First check legality of the non-optional inputs NEQ, ITOL, IOPT, 6547 C JT, ML, MU, and NG. 6548 C----------------------------------------------------------------------- 6549 20 IF (NEQ(1) .LE. 0) GO TO 604 6550 IF (ISTATE .EQ. 1) GO TO 25 6551 IF (NEQ(1) .GT. N) GO TO 605 6552 25 N = NEQ(1) 6553 IF (ITOL .LT. 1 .OR. ITOL .GT. 4) GO TO 606 6554 IF (IOPT .LT. 0 .OR. IOPT .GT. 1) GO TO 607 6555 IF (JT .EQ. 3 .OR. JT .LT. 1 .OR. JT .GT. 5) GO TO 608 6556 JTYP = JT 6557 IF (JT .LE. 2) GO TO 30 6558 ML = IWORK(1) 6559 MU = IWORK(2) 6560 IF (ML .LT. 0 .OR. ML .GE. N) GO TO 609 6561 IF (MU .LT. 0 .OR. MU .GE. N) GO TO 610 6562 30 CONTINUE 6563 IF (NG .LT. 0) GO TO 630 6564 IF (ISTATE .EQ. 1) GO TO 35 6565 IF (IRFND .EQ. 0 .AND. NG .NE. NGC) GO TO 631 6566 35 NGC = NG 6567 C Next process and check the optional inputs. -------------------------- 6568 IF (IOPT .EQ. 1) GO TO 40 6569 IXPR = 0 6570 MXSTEP = MXSTP0 6571 MXHNIL = MXHNL0 6572 HMXI = 0.0D0 6573 HMIN = 0.0D0 6574 IF (ISTATE .NE. 1) GO TO 60 6575 H0 = 0.0D0 6576 MXORDN = MORD(1) 6577 MXORDS = MORD(2) 6578 GO TO 60 6579 40 IXPR = IWORK(5) 6580 IF (IXPR .LT. 0 .OR. IXPR .GT. 1) GO TO 611 6581 MXSTEP = IWORK(6) 6582 IF (MXSTEP .LT. 0) GO TO 612 6583 IF (MXSTEP .EQ. 0) MXSTEP = MXSTP0 6584 MXHNIL = IWORK(7) 6585 IF (MXHNIL .LT. 0) GO TO 613 6586 IF (MXHNIL .EQ. 0) MXHNIL = MXHNL0 6587 IF (ISTATE .NE. 1) GO TO 50 6588 H0 = RWORK(5) 6589 MXORDN = IWORK(8) 6590 IF (MXORDN .LT. 0) GO TO 628 6591 IF (MXORDN .EQ. 0) MXORDN = 100 6592 MXORDN = MIN(MXORDN,MORD(1)) 6593 MXORDS = IWORK(9) 6594 IF (MXORDS .LT. 0) GO TO 629 6595 IF (MXORDS .EQ. 0) MXORDS = 100 6596 MXORDS = MIN(MXORDS,MORD(2)) 6597 IF ((TOUT - T)*H0 .LT. 0.0D0) GO TO 614 6598 50 HMAX = RWORK(6) 6599 IF (HMAX .LT. 0.0D0) GO TO 615 6600 HMXI = 0.0D0 6601 IF (HMAX .GT. 0.0D0) HMXI = 1.0D0/HMAX 6602 HMIN = RWORK(7) 6603 IF (HMIN .LT. 0.0D0) GO TO 616 6604 C----------------------------------------------------------------------- 6605 C Set work array pointers and check lengths LRW and LIW. 6606 C If ISTATE = 1, METH is initialized to 1 here to facilitate the 6607 C checking of work space lengths. 6608 C Pointers to segments of RWORK and IWORK are named by prefixing L to 6609 C the name of the segment. E.g., the segment YH starts at RWORK(LYH). 6610 C Segments of RWORK (in order) are denoted G0, G1, GX, YH, WM, 6611 C EWT, SAVF, ACOR. 6612 C If the lengths provided are insufficient for the current method, 6613 C an error return occurs. This is treated as illegal input on the 6614 C first call, but as a problem interruption with ISTATE = -7 on a 6615 C continuation call. If the lengths are sufficient for the current 6616 C method but not for both methods, a warning message is sent. 6617 C----------------------------------------------------------------------- 6618 60 IF (ISTATE .EQ. 1) METH = 1 6619 IF (ISTATE .EQ. 1) NYH = N 6620 LG0 = 21 6621 LG1 = LG0 + NG 6622 LGX = LG1 + NG 6623 LYHNEW = LGX + NG 6624 IF (ISTATE .EQ. 1) LYH = LYHNEW 6625 IF (LYHNEW .EQ. LYH) GO TO 62 6626 C If ISTATE = 3 and NG was changed, shift YH to its new location. ------ 6627 LENYH = L*NYH 6628 IF (LRW .LT. LYHNEW-1+LENYH) GO TO 62 6629 I1 = 1 6630 IF (LYHNEW .GT. LYH) I1 = -1 6631 CALL DCOPY (LENYH, RWORK(LYH), I1, RWORK(LYHNEW), I1) 6632 LYH = LYHNEW 6633 62 CONTINUE 6634 LEN1N = LYHNEW - 1 + (MXORDN + 1)*NYH 6635 LEN1S = LYHNEW - 1 + (MXORDS + 1)*NYH 6636 LWM = LEN1S + 1 6637 IF (JT .LE. 2) LENWM = N*N + 2 6638 IF (JT .GE. 4) LENWM = (2*ML + MU + 1)*N + 2 6639 LEN1S = LEN1S + LENWM 6640 LEN1C = LEN1N 6641 IF (METH .EQ. 2) LEN1C = LEN1S 6642 LEN1 = MAX(LEN1N,LEN1S) 6643 LEN2 = 3*N 6644 LENRW = LEN1 + LEN2 6645 LENRWC = LEN1C + LEN2 6646 IWORK(17) = LENRW 6647 LIWM = 1 6648 LENIW = 20 + N 6649 LENIWC = 20 6650 IF (METH .EQ. 2) LENIWC = LENIW 6651 IWORK(18) = LENIW 6652 IF (ISTATE .EQ. 1 .AND. LRW .LT. LENRWC) GO TO 617 6653 IF (ISTATE .EQ. 1 .AND. LIW .LT. LENIWC) GO TO 618 6654 IF (ISTATE .EQ. 3 .AND. LRW .LT. LENRWC) GO TO 550 6655 IF (ISTATE .EQ. 3 .AND. LIW .LT. LENIWC) GO TO 555 6656 LEWT = LEN1 + 1 6657 INSUFR = 0 6658 IF (LRW .GE. LENRW) GO TO 65 6659 INSUFR = 2 6660 LEWT = LEN1C + 1 6661 MSG='DLSODAR- Warning.. RWORK length is sufficient for now, but ' 6662 CALL XERRWD (MSG, 60, 103, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 6663 MSG=' may not be later. Integration will proceed anyway. ' 6664 CALL XERRWD (MSG, 60, 103, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 6665 MSG = ' Length needed is LENRW = I1, while LRW = I2.' 6666 CALL XERRWD (MSG, 50, 103, 0, 2, LENRW, LRW, 0, 0.0D0, 0.0D0) 6667 65 LSAVF = LEWT + N 6668 LACOR = LSAVF + N 6669 INSUFI = 0 6670 IF (LIW .GE. LENIW) GO TO 70 6671 INSUFI = 2 6672 MSG='DLSODAR- Warning.. IWORK length is sufficient for now, but ' 6673 CALL XERRWD (MSG, 60, 104, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 6674 MSG=' may not be later. Integration will proceed anyway. ' 6675 CALL XERRWD (MSG, 60, 104, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 6676 MSG = ' Length needed is LENIW = I1, while LIW = I2.' 6677 CALL XERRWD (MSG, 50, 104, 0, 2, LENIW, LIW, 0, 0.0D0, 0.0D0) 6678 70 CONTINUE 6679 C Check RTOL and ATOL for legality. ------------------------------------ 6680 RTOLI = RTOL(1) 6681 ATOLI = ATOL(1) 6682 DO 75 I = 1,N 6683 IF (ITOL .GE. 3) RTOLI = RTOL(I) 6684 IF (ITOL .EQ. 2 .OR. ITOL .EQ. 4) ATOLI = ATOL(I) 6685 IF (RTOLI .LT. 0.0D0) GO TO 619 6686 IF (ATOLI .LT. 0.0D0) GO TO 620 6687 75 CONTINUE 6688 IF (ISTATE .EQ. 1) GO TO 100 6689 C if ISTATE = 3, set flag to signal parameter changes to DSTODA. ------- 6690 JSTART = -1 6691 IF (N .EQ. NYH) GO TO 200 6692 C NEQ was reduced. zero part of yh to avoid undefined references. ----- 6693 I1 = LYH + L*NYH 6694 I2 = LYH + (MAXORD + 1)*NYH - 1 6695 IF (I1 .GT. I2) GO TO 200 6696 DO 95 I = I1,I2 6697 95 RWORK(I) = 0.0D0 6698 GO TO 200 6699 C----------------------------------------------------------------------- 6700 C Block C. 6701 C The next block is for the initial call only (ISTATE = 1). 6702 C It contains all remaining initializations, the initial call to F, 6703 C and the calculation of the initial step size. 6704 C The error weights in EWT are inverted after being loaded. 6705 C----------------------------------------------------------------------- 6706 100 UROUND = DUMACH() 6707 TN = T 6708 TSW = T 6709 MAXORD = MXORDN 6710 IF (ITASK .NE. 4 .AND. ITASK .NE. 5) GO TO 110 6711 TCRIT = RWORK(1) 6712 IF ((TCRIT - TOUT)*(TOUT - T) .LT. 0.0D0) GO TO 625 6713 IF (H0 .NE. 0.0D0 .AND. (T + H0 - TCRIT)*H0 .GT. 0.0D0) 6714 1 H0 = TCRIT - T 6715 110 JSTART = 0 6716 NHNIL = 0 6717 NST = 0 6718 NJE = 0 6719 NSLAST = 0 6720 HU = 0.0D0 6721 NQU = 0 6722 MUSED = 0 6723 MITER = 0 6724 CCMAX = 0.3D0 6725 MAXCOR = 3 6726 MSBP = 20 6727 MXNCF = 10 6728 C Initial call to F. (LF0 points to YH(*,2).) ------------------------- 6729 LF0 = LYH + NYH 6730 CALL F (NEQ, T, Y, RWORK(LF0)) 6731 NFE = 1 6732 C Load the initial value vector in YH. --------------------------------- 6733 DO 115 I = 1,N 6734 115 RWORK(I+LYH-1) = Y(I) 6735 C Load and invert the EWT array. (H is temporarily set to 1.0.) ------- 6736 NQ = 1 6737 H = 1.0D0 6738 CALL DEWSET (N, ITOL, RTOL, ATOL, RWORK(LYH), RWORK(LEWT)) 6739 DO 120 I = 1,N 6740 IF (RWORK(I+LEWT-1) .LE. 0.0D0) GO TO 621 6741 120 RWORK(I+LEWT-1) = 1.0D0/RWORK(I+LEWT-1) 6742 C----------------------------------------------------------------------- 6743 C The coding below computes the step size, H0, to be attempted on the 6744 C first step, unless the user has supplied a value for this. 6745 C First check that TOUT - T differs significantly from zero. 6746 C A scalar tolerance quantity TOL is computed, as MAX(RTOL(i)) 6747 C if this is positive, or MAX(ATOL(i)/ABS(Y(i))) otherwise, adjusted 6748 C so as to be between 100*UROUND and 1.0E-3. 6749 C Then the computed value H0 is given by: 6750 C 6751 C H0**(-2) = 1./(TOL * w0**2) + TOL * (norm(F))**2 6752 C 6753 C where w0 = MAX ( ABS(T), ABS(TOUT) ), 6754 C F = the initial value of the vector f(t,y), and 6755 C norm() = the weighted vector norm used throughout, given by 6756 C the DMNORM function routine, and weighted by the 6757 C tolerances initially loaded into the EWT array. 6758 C The sign of H0 is inferred from the initial values of TOUT and T. 6759 C ABS(H0) is made .le. ABS(TOUT-T) in any case. 6760 C----------------------------------------------------------------------- 6761 IF (H0 .NE. 0.0D0) GO TO 180 6762 TDIST = ABS(TOUT - T) 6763 W0 = MAX(ABS(T),ABS(TOUT)) 6764 IF (TDIST .LT. 2.0D0*UROUND*W0) GO TO 622 6765 TOL = RTOL(1) 6766 IF (ITOL .LE. 2) GO TO 140 6767 DO 130 I = 1,N 6768 130 TOL = MAX(TOL,RTOL(I)) 6769 140 IF (TOL .GT. 0.0D0) GO TO 160 6770 ATOLI = ATOL(1) 6771 DO 150 I = 1,N 6772 IF (ITOL .EQ. 2 .OR. ITOL .EQ. 4) ATOLI = ATOL(I) 6773 AYI = ABS(Y(I)) 6774 IF (AYI .NE. 0.0D0) TOL = MAX(TOL,ATOLI/AYI) 6775 150 CONTINUE 6776 160 TOL = MAX(TOL,100.0D0*UROUND) 6777 TOL = MIN(TOL,0.001D0) 6778 SUM = DMNORM (N, RWORK(LF0), RWORK(LEWT)) 6779 SUM = 1.0D0/(TOL*W0*W0) + TOL*SUM**2 6780 H0 = 1.0D0/SQRT(SUM) 6781 H0 = MIN(H0,TDIST) 6782 H0 = SIGN(H0,TOUT-T) 6783 C Adjust H0 if necessary to meet HMAX bound. --------------------------- 6784 180 RH = ABS(H0)*HMXI 6785 IF (RH .GT. 1.0D0) H0 = H0/RH 6786 C Load H with H0 and scale YH(*,2) by H0. ------------------------------ 6787 H = H0 6788 DO 190 I = 1,N 6789 190 RWORK(I+LF0-1) = H0*RWORK(I+LF0-1) 6790 C 6791 C Check for a zero of g at T. ------------------------------------------ 6792 IRFND = 0 6793 TOUTC = TOUT 6794 IF (NGC .EQ. 0) GO TO 270 6795 CALL DRCHEK (1, G, NEQ, Y, RWORK(LYH), NYH, 6796 1 RWORK(LG0), RWORK(LG1), RWORK(LGX), JROOT, IRT) 6797 IF (IRT .EQ. 0) GO TO 270 6798 GO TO 632 6799 C----------------------------------------------------------------------- 6800 C Block D. 6801 C The next code block is for continuation calls only (ISTATE = 2 or 3) 6802 C and is to check stop conditions before taking a step. 6803 C First, DRCHEK is called to check for a root within the last step 6804 C taken, other than the last root found there, if any. 6805 C If ITASK = 2 or 5, and y(TN) has not yet been returned to the user 6806 C because of an intervening root, return through Block G. 6807 C----------------------------------------------------------------------- 6808 200 NSLAST = NST 6809 C 6810 IRFP = IRFND 6811 IF (NGC .EQ. 0) GO TO 205 6812 IF (ITASK .EQ. 1 .OR. ITASK .EQ. 4) TOUTC = TOUT 6813 CALL DRCHEK (2, G, NEQ, Y, RWORK(LYH), NYH, 6814 1 RWORK(LG0), RWORK(LG1), RWORK(LGX), JROOT, IRT) 6815 IF (IRT .NE. 1) GO TO 205 6816 IRFND = 1 6817 ISTATE = 3 6818 T = T0 6819 GO TO 425 6820 205 CONTINUE 6821 IRFND = 0 6822 IF (IRFP .EQ. 1 .AND. TLAST .NE. TN .AND. ITASK .EQ. 2) GO TO 400 6823 C 6824 GO TO (210, 250, 220, 230, 240), ITASK 6825 210 IF ((TN - TOUT)*H .LT. 0.0D0) GO TO 250 6826 CALL DINTDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) 6827 IF (IFLAG .NE. 0) GO TO 627 6828 T = TOUT 6829 GO TO 420 6830 220 TP = TN - HU*(1.0D0 + 100.0D0*UROUND) 6831 IF ((TP - TOUT)*H .GT. 0.0D0) GO TO 623 6832 IF ((TN - TOUT)*H .LT. 0.0D0) GO TO 250 6833 T = TN 6834 GO TO 400 6835 230 TCRIT = RWORK(1) 6836 IF ((TN - TCRIT)*H .GT. 0.0D0) GO TO 624 6837 IF ((TCRIT - TOUT)*H .LT. 0.0D0) GO TO 625 6838 IF ((TN - TOUT)*H .LT. 0.0D0) GO TO 245 6839 CALL DINTDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) 6840 IF (IFLAG .NE. 0) GO TO 627 6841 T = TOUT 6842 GO TO 420 6843 240 TCRIT = RWORK(1) 6844 IF ((TN - TCRIT)*H .GT. 0.0D0) GO TO 624 6845 245 HMX = ABS(TN) + ABS(H) 6846 IHIT = ABS(TN - TCRIT) .LE. 100.0D0*UROUND*HMX 6847 IF (IHIT) T = TCRIT 6848 IF (IRFP .EQ. 1 .AND. TLAST .NE. TN .AND. ITASK .EQ. 5) GO TO 400 6849 IF (IHIT) GO TO 400 6850 TNEXT = TN + H*(1.0D0 + 4.0D0*UROUND) 6851 IF ((TNEXT - TCRIT)*H .LE. 0.0D0) GO TO 250 6852 H = (TCRIT - TN)*(1.0D0 - 4.0D0*UROUND) 6853 IF (ISTATE .EQ. 2 .AND. JSTART .GE. 0) JSTART = -2 6854 C----------------------------------------------------------------------- 6855 C Block E. 6856 C The next block is normally executed for all calls and contains 6857 C the call to the one-step core integrator DSTODA. 6858 C 6859 C This is a looping point for the integration steps. 6860 C 6861 C First check for too many steps being taken, update EWT (if not at 6862 C start of problem), check for too much accuracy being requested, and 6863 C check for H below the roundoff level in T. 6864 C----------------------------------------------------------------------- 6865 250 CONTINUE 6866 IF (METH .EQ. MUSED) GO TO 255 6867 IF (INSUFR .EQ. 1) GO TO 550 6868 IF (INSUFI .EQ. 1) GO TO 555 6869 255 IF ((NST-NSLAST) .GE. MXSTEP) GO TO 500 6870 CALL DEWSET (N, ITOL, RTOL, ATOL, RWORK(LYH), RWORK(LEWT)) 6871 DO 260 I = 1,N 6872 IF (RWORK(I+LEWT-1) .LE. 0.0D0) GO TO 510 6873 260 RWORK(I+LEWT-1) = 1.0D0/RWORK(I+LEWT-1) 6874 270 TOLSF = UROUND*DMNORM (N, RWORK(LYH), RWORK(LEWT)) 6875 IF (TOLSF .LE. 1.0D0) GO TO 280 6876 TOLSF = TOLSF*2.0D0 6877 IF (NST .EQ. 0) GO TO 626 6878 GO TO 520 6879 280 IF ((TN + H) .NE. TN) GO TO 290 6880 NHNIL = NHNIL + 1 6881 IF (NHNIL .GT. MXHNIL) GO TO 290 6882 MSG = 'DLSODAR- Warning..Internal T(=R1) and H(=R2) are ' 6883 CALL XERRWD (MSG, 50, 101, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 6884 MSG=' such that in the machine, T + H = T on the next step ' 6885 CALL XERRWD (MSG, 60, 101, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 6886 MSG = ' (H = step size). Solver will continue anyway.' 6887 CALL XERRWD (MSG, 50, 101, 0, 0, 0, 0, 2, TN, H) 6888 IF (NHNIL .LT. MXHNIL) GO TO 290 6889 MSG = 'DLSODAR- Above warning has been issued I1 times. ' 6890 CALL XERRWD (MSG, 50, 102, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 6891 MSG = ' It will not be issued again for this problem.' 6892 CALL XERRWD (MSG, 50, 102, 0, 1, MXHNIL, 0, 0, 0.0D0, 0.0D0) 6893 290 CONTINUE 6894 C----------------------------------------------------------------------- 6895 C CALL DSTODA(NEQ,Y,YH,NYH,YH,EWT,SAVF,ACOR,WM,IWM,F,JAC,DPRJA,DSOLSY) 6896 C----------------------------------------------------------------------- 6897 CALL DSTODA (NEQ, Y, RWORK(LYH), NYH, RWORK(LYH), RWORK(LEWT), 6898 1 RWORK(LSAVF), RWORK(LACOR), RWORK(LWM), IWORK(LIWM), 6899 2 F, JAC, DPRJA, DSOLSY) 6900 KGO = 1 - KFLAG 6901 GO TO (300, 530, 540), KGO 6902 C----------------------------------------------------------------------- 6903 C Block F. 6904 C The following block handles the case of a successful return from the 6905 C core integrator (KFLAG = 0). 6906 C If a method switch was just made, record TSW, reset MAXORD, 6907 C set JSTART to -1 to signal DSTODA to complete the switch, 6908 C and do extra printing of data if IXPR = 1. 6909 C Then call DRCHEK to check for a root within the last step. 6910 C Then, if no root was found, check for stop conditions. 6911 C----------------------------------------------------------------------- 6912 300 INIT = 1 6913 IF (METH .EQ. MUSED) GO TO 310 6914 TSW = TN 6915 MAXORD = MXORDN 6916 IF (METH .EQ. 2) MAXORD = MXORDS 6917 IF (METH .EQ. 2) RWORK(LWM) = SQRT(UROUND) 6918 INSUFR = MIN(INSUFR,1) 6919 INSUFI = MIN(INSUFI,1) 6920 JSTART = -1 6921 IF (IXPR .EQ. 0) GO TO 310 6922 IF (METH .EQ. 2) THEN 6923 MSG='DLSODAR- A switch to the BDF (stiff) method has occurred ' 6924 CALL XERRWD (MSG, 60, 105, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 6925 ENDIF 6926 IF (METH .EQ. 1) THEN 6927 MSG='DLSODAR- A switch to the Adams (nonstiff) method occurred ' 6928 CALL XERRWD (MSG, 60, 106, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 6929 ENDIF 6930 MSG=' at T = R1, tentative step size H = R2, step NST = I1 ' 6931 CALL XERRWD (MSG, 60, 107, 0, 1, NST, 0, 2, TN, H) 6932 310 CONTINUE 6933 C 6934 IF (NGC .EQ. 0) GO TO 315 6935 CALL DRCHEK (3, G, NEQ, Y, RWORK(LYH), NYH, 6936 1 RWORK(LG0), RWORK(LG1), RWORK(LGX), JROOT, IRT) 6937 IF (IRT .NE. 1) GO TO 315 6938 IRFND = 1 6939 ISTATE = 3 6940 T = T0 6941 GO TO 425 6942 315 CONTINUE 6943 C 6944 GO TO (320, 400, 330, 340, 350), ITASK 6945 C ITASK = 1. If TOUT has been reached, interpolate. ------------------- 6946 320 IF ((TN - TOUT)*H .LT. 0.0D0) GO TO 250 6947 CALL DINTDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) 6948 T = TOUT 6949 GO TO 420 6950 C ITASK = 3. Jump to exit if TOUT was reached. ------------------------ 6951 330 IF ((TN - TOUT)*H .GE. 0.0D0) GO TO 400 6952 GO TO 250 6953 C ITASK = 4. See if TOUT or TCRIT was reached. Adjust H if necessary. 6954 340 IF ((TN - TOUT)*H .LT. 0.0D0) GO TO 345 6955 CALL DINTDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) 6956 T = TOUT 6957 GO TO 420 6958 345 HMX = ABS(TN) + ABS(H) 6959 IHIT = ABS(TN - TCRIT) .LE. 100.0D0*UROUND*HMX 6960 IF (IHIT) GO TO 400 6961 TNEXT = TN + H*(1.0D0 + 4.0D0*UROUND) 6962 IF ((TNEXT - TCRIT)*H .LE. 0.0D0) GO TO 250 6963 H = (TCRIT - TN)*(1.0D0 - 4.0D0*UROUND) 6964 IF (JSTART .GE. 0) JSTART = -2 6965 GO TO 250 6966 C ITASK = 5. See if TCRIT was reached and jump to exit. --------------- 6967 350 HMX = ABS(TN) + ABS(H) 6968 IHIT = ABS(TN - TCRIT) .LE. 100.0D0*UROUND*HMX 6969 C----------------------------------------------------------------------- 6970 C Block G. 6971 C The following block handles all successful returns from DLSODAR. 6972 C If ITASK .ne. 1, Y is loaded from YH and T is set accordingly. 6973 C ISTATE is set to 2, and the optional outputs are loaded into the 6974 C work arrays before returning. 6975 C----------------------------------------------------------------------- 6976 400 DO 410 I = 1,N 6977 410 Y(I) = RWORK(I+LYH-1) 6978 T = TN 6979 IF (ITASK .NE. 4 .AND. ITASK .NE. 5) GO TO 420 6980 IF (IHIT) T = TCRIT 6981 420 ISTATE = 2 6982 425 CONTINUE 6983 RWORK(11) = HU 6984 RWORK(12) = H 6985 RWORK(13) = TN 6986 RWORK(15) = TSW 6987 IWORK(11) = NST 6988 IWORK(12) = NFE 6989 IWORK(13) = NJE 6990 IWORK(14) = NQU 6991 IWORK(15) = NQ 6992 IWORK(19) = MUSED 6993 IWORK(20) = METH 6994 IWORK(10) = NGE 6995 TLAST = T 6996 RETURN 6997 C----------------------------------------------------------------------- 6998 C Block H. 6999 C The following block handles all unsuccessful returns other than 7000 C those for illegal input. First the error message routine is called. 7001 C If there was an error test or convergence test failure, IMXER is set. 7002 C Then Y is loaded from YH and T is set to TN. 7003 C The optional outputs are loaded into the work arrays before returning. 7004 C----------------------------------------------------------------------- 7005 C The maximum number of steps was taken before reaching TOUT. ---------- 7006 500 MSG = 'DLSODAR- At current T (=R1), MXSTEP (=I1) steps ' 7007 CALL XERRWD (MSG, 50, 201, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 7008 MSG = ' taken on this call before reaching TOUT ' 7009 CALL XERRWD (MSG, 50, 201, 0, 1, MXSTEP, 0, 1, TN, 0.0D0) 7010 ISTATE = -1 7011 GO TO 580 7012 C EWT(i) .le. 0.0 for some i (not at start of problem). ---------------- 7013 510 EWTI = RWORK(LEWT+I-1) 7014 MSG = 'DLSODAR- At T(=R1), EWT(I1) has become R2 .le. 0.' 7015 CALL XERRWD (MSG, 50, 202, 0, 1, I, 0, 2, TN, EWTI) 7016 ISTATE = -6 7017 GO TO 580 7018 C Too much accuracy requested for machine precision. ------------------- 7019 520 MSG = 'DLSODAR- At T (=R1), too much accuracy requested ' 7020 CALL XERRWD (MSG, 50, 203, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 7021 MSG = ' for precision of machine.. See TOLSF (=R2) ' 7022 CALL XERRWD (MSG, 50, 203, 0, 0, 0, 0, 2, TN, TOLSF) 7023 RWORK(14) = TOLSF 7024 ISTATE = -2 7025 GO TO 580 7026 C KFLAG = -1. Error test failed repeatedly or with ABS(H) = HMIN. ----- 7027 530 MSG = 'DLSODAR- At T(=R1), step size H(=R2), the error ' 7028 CALL XERRWD (MSG, 50, 204, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 7029 MSG = ' test failed repeatedly or with ABS(H) = HMIN' 7030 CALL XERRWD (MSG, 50, 204, 0, 0, 0, 0, 2, TN, H) 7031 ISTATE = -4 7032 GO TO 560 7033 C KFLAG = -2. Convergence failed repeatedly or with ABS(H) = HMIN. ---- 7034 540 MSG = 'DLSODAR- At T (=R1) and step size H (=R2), the ' 7035 CALL XERRWD (MSG, 50, 205, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 7036 MSG = ' corrector convergence failed repeatedly ' 7037 CALL XERRWD (MSG, 50, 205, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 7038 MSG = ' or with ABS(H) = HMIN ' 7039 CALL XERRWD (MSG, 30, 205, 0, 0, 0, 0, 2, TN, H) 7040 ISTATE = -5 7041 GO TO 560 7042 C RWORK length too small to proceed. ----------------------------------- 7043 550 MSG = 'DLSODAR- At current T(=R1), RWORK length too small' 7044 CALL XERRWD (MSG, 50, 206, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 7045 MSG=' to proceed. The integration was otherwise successful.' 7046 CALL XERRWD (MSG, 60, 206, 0, 0, 0, 0, 1, TN, 0.0D0) 7047 ISTATE = -7 7048 GO TO 580 7049 C IWORK length too small to proceed. ----------------------------------- 7050 555 MSG = 'DLSODAR- At current T(=R1), IWORK length too small' 7051 CALL XERRWD (MSG, 50, 207, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 7052 MSG=' to proceed. The integration was otherwise successful.' 7053 CALL XERRWD (MSG, 60, 207, 0, 0, 0, 0, 1, TN, 0.0D0) 7054 ISTATE = -7 7055 GO TO 580 7056 C Compute IMXER if relevant. ------------------------------------------- 7057 560 BIG = 0.0D0 7058 IMXER = 1 7059 DO 570 I = 1,N 7060 SIZE = ABS(RWORK(I+LACOR-1)*RWORK(I+LEWT-1)) 7061 IF (BIG .GE. SIZE) GO TO 570 7062 BIG = SIZE 7063 IMXER = I 7064 570 CONTINUE 7065 IWORK(16) = IMXER 7066 C Set Y vector, T, and optional outputs. ------------------------------- 7067 580 DO 590 I = 1,N 7068 590 Y(I) = RWORK(I+LYH-1) 7069 T = TN 7070 RWORK(11) = HU 7071 RWORK(12) = H 7072 RWORK(13) = TN 7073 RWORK(15) = TSW 7074 IWORK(11) = NST 7075 IWORK(12) = NFE 7076 IWORK(13) = NJE 7077 IWORK(14) = NQU 7078 IWORK(15) = NQ 7079 IWORK(19) = MUSED 7080 IWORK(20) = METH 7081 IWORK(10) = NGE 7082 TLAST = T 7083 RETURN 7084 C----------------------------------------------------------------------- 7085 C Block I. 7086 C The following block handles all error returns due to illegal input 7087 C (ISTATE = -3), as detected before calling the core integrator. 7088 C First the error message routine is called. If the illegal input 7089 C is a negative ISTATE, the run is aborted (apparent infinite loop). 7090 C----------------------------------------------------------------------- 7091 601 MSG = 'DLSODAR- ISTATE(=I1) illegal.' 7092 CALL XERRWD (MSG, 30, 1, 0, 1, ISTATE, 0, 0, 0.0D0, 0.0D0) 7093 IF (ISTATE .LT. 0) GO TO 800 7094 GO TO 700 7095 602 MSG = 'DLSODAR- ITASK (=I1) illegal.' 7096 CALL XERRWD (MSG, 30, 2, 0, 1, ITASK, 0, 0, 0.0D0, 0.0D0) 7097 GO TO 700 7098 603 MSG = 'DLSODAR- ISTATE.gt.1 but DLSODAR not initialized.' 7099 CALL XERRWD (MSG, 50, 3, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 7100 GO TO 700 7101 604 MSG = 'DLSODAR- NEQ (=I1) .lt. 1 ' 7102 CALL XERRWD (MSG, 30, 4, 0, 1, NEQ(1), 0, 0, 0.0D0, 0.0D0) 7103 GO TO 700 7104 605 MSG = 'DLSODAR- ISTATE = 3 and NEQ increased (I1 to I2).' 7105 CALL XERRWD (MSG, 50, 5, 0, 2, N, NEQ(1), 0, 0.0D0, 0.0D0) 7106 GO TO 700 7107 606 MSG = 'DLSODAR- ITOL (=I1) illegal. ' 7108 CALL XERRWD (MSG, 30, 6, 0, 1, ITOL, 0, 0, 0.0D0, 0.0D0) 7109 GO TO 700 7110 607 MSG = 'DLSODAR- IOPT (=I1) illegal. ' 7111 CALL XERRWD (MSG, 30, 7, 0, 1, IOPT, 0, 0, 0.0D0, 0.0D0) 7112 GO TO 700 7113 608 MSG = 'DLSODAR- JT (=I1) illegal. ' 7114 CALL XERRWD (MSG, 30, 8, 0, 1, JT, 0, 0, 0.0D0, 0.0D0) 7115 GO TO 700 7116 609 MSG = 'DLSODAR- ML (=I1) illegal: .lt.0 or .ge.NEQ (=I2)' 7117 CALL XERRWD (MSG, 50, 9, 0, 2, ML, NEQ(1), 0, 0.0D0, 0.0D0) 7118 GO TO 700 7119 610 MSG = 'DLSODAR- MU (=I1) illegal: .lt.0 or .ge.NEQ (=I2)' 7120 CALL XERRWD (MSG, 50, 10, 0, 2, MU, NEQ(1), 0, 0.0D0, 0.0D0) 7121 GO TO 700 7122 611 MSG = 'DLSODAR- IXPR (=I1) illegal. ' 7123 CALL XERRWD (MSG, 30, 11, 0, 1, IXPR, 0, 0, 0.0D0, 0.0D0) 7124 GO TO 700 7125 612 MSG = 'DLSODAR- MXSTEP (=I1) .lt. 0 ' 7126 CALL XERRWD (MSG, 30, 12, 0, 1, MXSTEP, 0, 0, 0.0D0, 0.0D0) 7127 GO TO 700 7128 613 MSG = 'DLSODAR- MXHNIL (=I1) .lt. 0 ' 7129 CALL XERRWD (MSG, 30, 13, 0, 1, MXHNIL, 0, 0, 0.0D0, 0.0D0) 7130 GO TO 700 7131 614 MSG = 'DLSODAR- TOUT (=R1) behind T (=R2) ' 7132 CALL XERRWD (MSG, 40, 14, 0, 0, 0, 0, 2, TOUT, T) 7133 MSG = ' Integration direction is given by H0 (=R1) ' 7134 CALL XERRWD (MSG, 50, 14, 0, 0, 0, 0, 1, H0, 0.0D0) 7135 GO TO 700 7136 615 MSG = 'DLSODAR- HMAX (=R1) .lt. 0.0 ' 7137 CALL XERRWD (MSG, 30, 15, 0, 0, 0, 0, 1, HMAX, 0.0D0) 7138 GO TO 700 7139 616 MSG = 'DLSODAR- HMIN (=R1) .lt. 0.0 ' 7140 CALL XERRWD (MSG, 30, 16, 0, 0, 0, 0, 1, HMIN, 0.0D0) 7141 GO TO 700 7142 617 MSG='DLSODAR- RWORK length needed, LENRW(=I1), exceeds LRW(=I2) ' 7143 CALL XERRWD (MSG, 60, 17, 0, 2, LENRW, LRW, 0, 0.0D0, 0.0D0) 7144 GO TO 700 7145 618 MSG='DLSODAR- IWORK length needed, LENIW(=I1), exceeds LIW(=I2) ' 7146 CALL XERRWD (MSG, 60, 18, 0, 2, LENIW, LIW, 0, 0.0D0, 0.0D0) 7147 GO TO 700 7148 619 MSG = 'DLSODAR- RTOL(I1) is R1 .lt. 0.0 ' 7149 CALL XERRWD (MSG, 40, 19, 0, 1, I, 0, 1, RTOLI, 0.0D0) 7150 GO TO 700 7151 620 MSG = 'DLSODAR- ATOL(I1) is R1 .lt. 0.0 ' 7152 CALL XERRWD (MSG, 40, 20, 0, 1, I, 0, 1, ATOLI, 0.0D0) 7153 GO TO 700 7154 621 EWTI = RWORK(LEWT+I-1) 7155 MSG = 'DLSODAR- EWT(I1) is R1 .le. 0.0 ' 7156 CALL XERRWD (MSG, 40, 21, 0, 1, I, 0, 1, EWTI, 0.0D0) 7157 GO TO 700 7158 622 MSG='DLSODAR- TOUT(=R1) too close to T(=R2) to start integration.' 7159 CALL XERRWD (MSG, 60, 22, 0, 0, 0, 0, 2, TOUT, T) 7160 GO TO 700 7161 623 MSG='DLSODAR- ITASK = I1 and TOUT (=R1) behind TCUR - HU (= R2) ' 7162 CALL XERRWD (MSG, 60, 23, 0, 1, ITASK, 0, 2, TOUT, TP) 7163 GO TO 700 7164 624 MSG='DLSODAR- ITASK = 4 or 5 and TCRIT (=R1) behind TCUR (=R2) ' 7165 CALL XERRWD (MSG, 60, 24, 0, 0, 0, 0, 2, TCRIT, TN) 7166 GO TO 700 7167 625 MSG='DLSODAR- ITASK = 4 or 5 and TCRIT (=R1) behind TOUT (=R2) ' 7168 CALL XERRWD (MSG, 60, 25, 0, 0, 0, 0, 2, TCRIT, TOUT) 7169 GO TO 700 7170 626 MSG = 'DLSODAR- At start of problem, too much accuracy ' 7171 CALL XERRWD (MSG, 50, 26, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 7172 MSG=' requested for precision of machine.. See TOLSF (=R1) ' 7173 CALL XERRWD (MSG, 60, 26, 0, 0, 0, 0, 1, TOLSF, 0.0D0) 7174 RWORK(14) = TOLSF 7175 GO TO 700 7176 627 MSG = 'DLSODAR- Trouble in DINTDY. ITASK = I1, TOUT = R1' 7177 CALL XERRWD (MSG, 50, 27, 0, 1, ITASK, 0, 1, TOUT, 0.0D0) 7178 GO TO 700 7179 628 MSG = 'DLSODAR- MXORDN (=I1) .lt. 0 ' 7180 CALL XERRWD (MSG, 30, 28, 0, 1, MXORDN, 0, 0, 0.0D0, 0.0D0) 7181 GO TO 700 7182 629 MSG = 'DLSODAR- MXORDS (=I1) .lt. 0 ' 7183 CALL XERRWD (MSG, 30, 29, 0, 1, MXORDS, 0, 0, 0.0D0, 0.0D0) 7184 GO TO 700 7185 630 MSG = 'DLSODAR- NG (=I1) .lt. 0 ' 7186 CALL XERRWD (MSG, 30, 30, 0, 1, NG, 0, 0, 0.0D0, 0.0D0) 7187 GO TO 700 7188 631 MSG = 'DLSODAR- NG changed (from I1 to I2) illegally, ' 7189 CALL XERRWD (MSG, 50, 31, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 7190 MSG = ' i.e. not immediately after a root was found.' 7191 CALL XERRWD (MSG, 50, 31, 0, 2, NGC, NG, 0, 0.0D0, 0.0D0) 7192 GO TO 700 7193 632 MSG = 'DLSODAR- One or more components of g has a root ' 7194 CALL XERRWD (MSG, 50, 32, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 7195 MSG = ' too near to the initial point. ' 7196 CALL XERRWD (MSG, 40, 32, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 7197 C 7198 700 ISTATE = -3 7199 RETURN 7200 C 7201 800 MSG = 'DLSODAR- Run aborted.. apparent infinite loop. ' 7202 CALL XERRWD (MSG, 50, 303, 2, 0, 0, 0, 0, 0.0D0, 0.0D0) 7203 RETURN 7204 C----------------------- End of Subroutine DLSODAR --------------------- 7205 END 7206 *DECK DLSODPK 7207 SUBROUTINE DLSODPK (F, NEQ, Y, T, TOUT, ITOL, RTOL, ATOL, ITASK, 7208 1 ISTATE, IOPT, RWORK, LRW, IWORK, LIW, JAC, PSOL, MF) 7209 EXTERNAL F, JAC, PSOL 7210 INTEGER NEQ, ITOL, ITASK, ISTATE, IOPT, LRW, IWORK, LIW, MF 7211 DOUBLE PRECISION Y, T, TOUT, RTOL, ATOL, RWORK 7212 DIMENSION NEQ(*), Y(*), RTOL(*), ATOL(*), RWORK(LRW), IWORK(LIW) 7213 C----------------------------------------------------------------------- 7214 C This is the 18 November 2003 version of 7215 C DLSODPK: Livermore Solver for Ordinary Differential equations, 7216 C with Preconditioned Krylov iteration methods for the 7217 C Newton correction linear systems. 7218 C 7219 C This version is in double precision. 7220 C 7221 C DLSODPK solves the initial value problem for stiff or nonstiff 7222 C systems of first order ODEs, 7223 C dy/dt = f(t,y) , or, in component form, 7224 C dy(i)/dt = f(i) = f(i,t,y(1),y(2),...,y(NEQ)) (i = 1,...,NEQ). 7225 C----------------------------------------------------------------------- 7226 C Introduction. 7227 C 7228 C This is a modification of the DLSODE package which incorporates 7229 C various preconditioned Krylov subspace iteration methods for the 7230 C linear algebraic systems that arise in the case of stiff systems. 7231 C 7232 C The linear systems that must be solved have the form 7233 C A * x = b , where A = identity - hl0 * (df/dy) . 7234 C Here hl0 is a scalar, and df/dy is the Jacobian matrix of partial 7235 C derivatives of f (NEQ by NEQ). 7236 C 7237 C The particular Krylov method is chosen by setting the second digit, 7238 C MITER, in the method flag MF. 7239 C Currently, the values of MITER have the following meanings: 7240 C 7241 C MITER = 1 means the preconditioned Scaled Incomplete 7242 C Orthogonalization Method (SPIOM). 7243 C 7244 C 2 means an incomplete version of the Preconditioned Scaled 7245 C Generalized Minimal Residual method (SPIGMR). 7246 C This is the best choice in general. 7247 C 7248 C 3 means the Preconditioned Conjugate Gradient method (PCG). 7249 C Recommended only when df/dy is symmetric or nearly so. 7250 C 7251 C 4 means the scaled Preconditioned Conjugate Gradient method 7252 C (PCGS). Recommended only when D-inverse * df/dy * D is 7253 C symmetric or nearly so, where D is the diagonal scaling 7254 C matrix with elements 1/EWT(i) (see RTOL/ATOL description). 7255 C 7256 C 9 means that only a user-supplied matrix P (approximating A) 7257 C will be used, with no Krylov iteration done. This option 7258 C allows the user to provide the complete linear system 7259 C solution algorithm, if desired. 7260 C 7261 C The user can apply preconditioning to the linear system A*x = b, 7262 C by means of arbitrary matrices (the preconditioners). 7263 C In the case of SPIOM and SPIGMR, one can apply left and right 7264 C preconditioners P1 and P2, and the basic iterative method is then 7265 C applied to the matrix (P1-inverse)*A*(P2-inverse) instead of to the 7266 C matrix A. The product P1*P2 should be an approximation to matrix A 7267 C such that linear systems with P1 or P2 are easier to solve than with 7268 C A. Preconditioning from the left only or right only means using 7269 C P2 = identity or P1 = identity, respectively. 7270 C In the case of the PCG and PCGS methods, there is only one 7271 C preconditioner matrix P (but it can be the product of more than one). 7272 C It should approximate the matrix A but allow for relatively 7273 C easy solution of linear systems with coefficient matrix P. 7274 C For PCG, P should be positive definite symmetric, or nearly so, 7275 C and for PCGS, the scaled preconditioner D-inverse * P * D 7276 C should be symmetric or nearly so. 7277 C If the Jacobian J = df/dy splits in a natural way into a sum 7278 C J = J1 + J2, then one possible choice of preconditioners is 7279 C P1 = identity - hl0 * J1 and P2 = identity - hl0 * J2 7280 C provided each of these is easy to solve (or approximately solve). 7281 C 7282 C----------------------------------------------------------------------- 7283 C References: 7284 C 1. Peter N. Brown and Alan C. Hindmarsh, Reduced Storage Matrix 7285 C Methods in Stiff ODE Systems, J. Appl. Math. & Comp., 31 (1989), 7286 C pp. 40-91; also L.L.N.L. Report UCRL-95088, Rev. 1, June 1987. 7287 C 2. Alan C. Hindmarsh, ODEPACK, A Systematized Collection of ODE 7288 C Solvers, in Scientific Computing, R. S. Stepleman et al. (Eds.), 7289 C North-Holland, Amsterdam, 1983, pp. 55-64. 7290 C----------------------------------------------------------------------- 7291 C Authors: Alan C. Hindmarsh and Peter N. Brown 7292 C Center for Applied Scientific Computing, L-561 7293 C Lawrence Livermore National Laboratory 7294 C Livermore, CA 94551 7295 C----------------------------------------------------------------------- 7296 C Summary of Usage. 7297 C 7298 C Communication between the user and the DLSODPK package, for normal 7299 C situations, is summarized here. This summary describes only a subset 7300 C of the full set of options available. See the full description for 7301 C details, including optional communication, nonstandard options, 7302 C and instructions for special situations. See also the demonstration 7303 C program distributed with this solver. 7304 C 7305 C A. First provide a subroutine of the form: 7306 C SUBROUTINE F (NEQ, T, Y, YDOT) 7307 C DOUBLE PRECISION T, Y(*), YDOT(*) 7308 C which supplies the vector function f by loading YDOT(i) with f(i). 7309 C 7310 C B. Next determine (or guess) whether or not the problem is stiff. 7311 C Stiffness occurs when the Jacobian matrix df/dy has an eigenvalue 7312 C whose real part is negative and large in magnitude, compared to the 7313 C reciprocal of the t span of interest. If the problem is nonstiff, 7314 C use a method flag MF = 10. If it is stiff, MF should be between 21 7315 C and 24, or possibly 29. MF = 22 is generally the best choice. 7316 C Use 23 or 24 only if symmetry is present. Use MF = 29 if the 7317 C complete linear system solution is to be provided by the user. 7318 C The following four parameters must also be set. 7319 C IWORK(1) = LWP = length of real array WP for preconditioning. 7320 C IWORK(2) = LIWP = length of integer array IWP for preconditioning. 7321 C IWORK(3) = JPRE = preconditioner type flag: 7322 C = 0 for no preconditioning (P1 = P2 = P = identity) 7323 C = 1 for left-only preconditioning (P2 = identity) 7324 C = 2 for right-only preconditioning (P1 = identity) 7325 C = 3 for two-sided preconditioning (and PCG or PCGS) 7326 C IWORK(4) = JACFLG = flag for whether JAC is called. 7327 C = 0 if JAC is not to be called, 7328 C = 1 if JAC is to be called. 7329 C Use JACFLG = 1 if JAC computes any nonconstant data for use in 7330 C preconditioning, such as Jacobian elements. 7331 C The arrays WP and IWP are work arrays under the user's control, 7332 C for use in the routines that perform preconditioning operations. 7333 C 7334 C C. If the problem is stiff, you must supply two routines that deal 7335 C with the preconditioning of the linear systems to be solved. 7336 C These are as follows: 7337 C 7338 C SUBROUTINE JAC (F, NEQ, T, Y, YSV, REWT, FTY, V, HL0, WP,IWP, IER) 7339 C DOUBLE PRECISION T, Y(*),YSV(*), REWT(*), FTY(*), V(*), HL0, WP(*) 7340 C INTEGER IWP(*) 7341 C This routine must evaluate and preprocess any parts of the 7342 C Jacobian matrix df/dy involved in the preconditioners P1, P2, P. 7343 C The Y and FTY arrays contain the current values of y and f(t,y), 7344 C respectively, and YSV also contains the current value of y. 7345 C The array V is work space of length NEQ. 7346 C JAC must multiply all computed Jacobian elements by the scalar 7347 C -HL0, add the identity matrix, and do any factorization 7348 C operations called for, in preparation for solving linear systems 7349 C with a coefficient matrix of P1, P2, or P. The matrix P1*P2 or P 7350 C should be an approximation to identity - HL0 * (df/dy). 7351 C JAC should return IER = 0 if successful, and IER .ne. 0 if not. 7352 C (If IER .ne. 0, a smaller time step will be tried.) 7353 C 7354 C SUBROUTINE PSOL (NEQ, T, Y, FTY, WK, HL0, WP, IWP, B, LR, IER) 7355 C DOUBLE PRECISION T, Y(*), FTY(*), WK(*), HL0, WP(*), B(*) 7356 C INTEGER IWP(*) 7357 C This routine must solve a linear system with B as right-hand 7358 C side and one of the preconditioning matrices, P1, P2, or P, as 7359 C coefficient matrix, and return the solution vector in B. 7360 C LR is a flag concerning left vs right preconditioning, input 7361 C to PSOL. PSOL is to use P1 if LR = 1 and P2 if LR = 2. 7362 C In the case of the PCG or PCGS method, LR will be 3, and PSOL 7363 C should solve the system P*x = B with the preconditioner matrix P. 7364 C In the case MF = 29 (no Krylov iteration), LR will be 0, 7365 C and PSOL is to return in B the desired approximate solution 7366 C to A * x = B, where A = identity - HL0 * (df/dy). 7367 C PSOL can use data generated in the JAC routine and stored in 7368 C WP and IWP. WK is a work array of length NEQ. 7369 C The argument HL0 is the current value of the scalar appearing 7370 C in the linear system. If the old value, at the time of the last 7371 C JAC call, is needed, it must have been saved by JAC in WP. 7372 C On return, PSOL should set the error flag IER as follows: 7373 C IER = 0 if PSOL was successful, 7374 C IER .gt. 0 if a recoverable error occurred, meaning that the 7375 C time step will be retried, 7376 C IER .lt. 0 if an unrecoverable error occurred, meaning that the 7377 C solver is to stop immediately. 7378 C 7379 C D. Write a main program which calls Subroutine DLSODPK once for 7380 C each point at which answers are desired. This should also provide 7381 C for possible use of logical unit 6 for output of error messages by 7382 C DLSODPK. On the first call to DLSODPK, supply arguments as follows: 7383 C F = name of subroutine for right-hand side vector f. 7384 C This name must be declared External in calling program. 7385 C NEQ = number of first order ODEs. 7386 C Y = array of initial values, of length NEQ. 7387 C T = the initial value of the independent variable. 7388 C TOUT = first point where output is desired (.ne. T). 7389 C ITOL = 1 or 2 according as ATOL (below) is a scalar or array. 7390 C RTOL = relative tolerance parameter (scalar). 7391 C ATOL = absolute tolerance parameter (scalar or array). 7392 C the estimated local error in y(i) will be controlled so as 7393 C to be roughly less (in magnitude) than 7394 C EWT(i) = RTOL*ABS(Y(i)) + ATOL if ITOL = 1, or 7395 C EWT(i) = RTOL*ABS(Y(i)) + ATOL(i) if ITOL = 2. 7396 C Thus the local error test passes if, in each component, 7397 C either the absolute error is less than ATOL (or ATOL(i)), 7398 C or the relative error is less than RTOL. 7399 C Use RTOL = 0.0 for pure absolute error control, and 7400 C use ATOL = 0.0 (or ATOL(i) = 0.0) for pure relative error 7401 C control. Caution: Actual (global) errors may exceed these 7402 C local tolerances, so choose them conservatively. 7403 C ITASK = 1 for normal computation of output values of y at t = TOUT. 7404 C ISTATE = integer flag (input and output). Set ISTATE = 1. 7405 C IOPT = 0 to indicate no optional inputs used. 7406 C RWORK = real work array of length at least: 7407 C 20 + 16*NEQ for MF = 10, 7408 C 45 + 17*NEQ + LWP for MF = 21, 7409 C 61 + 17*NEQ + LWP for MF = 22, 7410 C 20 + 15*NEQ + LWP for MF = 23 or 24, 7411 C 20 + 12*NEQ + LWP for MF = 29. 7412 C LRW = declared length of RWORK (in user's dimension). 7413 C IWORK = integer work array of length at least: 7414 C 30 for MF = 10, 7415 C 35 + LIWP for MF = 21, 7416 C 30 + LIWP for MF = 22, 23, 24, or 29. 7417 C LIW = declared length of IWORK (in user's dimension). 7418 C JAC,PSOL = names of subroutines for preconditioning. 7419 C These names must be declared External in the calling program. 7420 C MF = method flag. Standard values are: 7421 C 10 for nonstiff (Adams) method. 7422 C 21 for stiff (BDF) method, with preconditioned SIOM. 7423 C 22 for stiff method, with preconditioned GMRES method. 7424 C 23 for stiff method, with preconditioned CG method. 7425 C 24 for stiff method, with scaled preconditioned CG method. 7426 C 29 for stiff method, with user's PSOL routine only. 7427 C Note that the main program must declare arrays Y, RWORK, IWORK, 7428 C and possibly ATOL. 7429 C 7430 C E. The output from the first call (or any call) is: 7431 C Y = array of computed values of y(t) vector. 7432 C T = corresponding value of independent variable (normally TOUT). 7433 C ISTATE = 2 if DLSODPK was successful, negative otherwise. 7434 C -1 means excess work done on this call (perhaps wrong MF). 7435 C -2 means excess accuracy requested (tolerances too small). 7436 C -3 means illegal input detected (see printed message). 7437 C -4 means repeated error test failures (check all inputs). 7438 C -5 means repeated convergence failures (perhaps bad JAC 7439 C or PSOL routine supplied or wrong choice of MF or 7440 C tolerances, or this solver is inappropriate). 7441 C -6 means error weight became zero during problem. (Solution 7442 C component i vanished, and ATOL or ATOL(i) = 0.) 7443 C -7 means an unrecoverable error occurred in PSOL. 7444 C 7445 C F. To continue the integration after a successful return, simply 7446 C reset TOUT and call DLSODPK again. No other parameters need be reset. 7447 C 7448 C----------------------------------------------------------------------- 7449 C----------------------------------------------------------------------- 7450 C Full Description of User Interface to DLSODPK. 7451 C 7452 C The user interface to DLSODPK consists of the following parts. 7453 C 7454 C 1. The call sequence to Subroutine DLSODPK, which is a driver 7455 C routine for the solver. This includes descriptions of both 7456 C the call sequence arguments and of user-supplied routines. 7457 C Following these descriptions is a description of 7458 C optional inputs available through the call sequence, and then 7459 C a description of optional outputs (in the work arrays). 7460 C 7461 C 2. Descriptions of other routines in the DLSODPK package that may be 7462 C (optionally) called by the user. These provide the ability to 7463 C alter error message handling, save and restore the internal 7464 C Common, and obtain specified derivatives of the solution y(t). 7465 C 7466 C 3. Descriptions of Common blocks to be declared in overlay 7467 C or similar environments, or to be saved when doing an interrupt 7468 C of the problem and continued solution later. 7469 C 7470 C 4. Description of two routines in the DLSODPK package, either of 7471 C which the user may replace with his/her own version, if desired. 7472 C These relate to the measurement of errors. 7473 C 7474 C----------------------------------------------------------------------- 7475 C Part 1. Call Sequence. 7476 C 7477 C The call sequence parameters used for input only are 7478 C F, NEQ, TOUT, ITOL, RTOL, ATOL, ITASK, IOPT, LRW, LIW, JAC, PSOL, MF, 7479 C and those used for both input and output are 7480 C Y, T, ISTATE. 7481 C The work arrays RWORK and IWORK are also used for conditional and 7482 C optional inputs and optional outputs. (The term output here refers 7483 C to the return from Subroutine DLSODPK to the user's calling program.) 7484 C 7485 C The legality of input parameters will be thoroughly checked on the 7486 C initial call for the problem, but not checked thereafter unless a 7487 C change in input parameters is flagged by ISTATE = 3 on input. 7488 C 7489 C The descriptions of the call arguments are as follows. 7490 C 7491 C F = the name of the user-supplied subroutine defining the 7492 C ODE system. The system must be put in the first-order 7493 C form dy/dt = f(t,y), where f is a vector-valued function 7494 C of the scalar t and the vector y. Subroutine F is to 7495 C compute the function f. It is to have the form 7496 C SUBROUTINE F (NEQ, T, Y, YDOT) 7497 C DOUBLE PRECISION T, Y(*), YDOT(*) 7498 C where NEQ, T, and Y are input, and the array YDOT = f(t,y) 7499 C is output. Y and YDOT are arrays of length NEQ. 7500 C Subroutine F should not alter Y(1),...,Y(NEQ). 7501 C F must be declared External in the calling program. 7502 C 7503 C Subroutine F may access user-defined quantities in 7504 C NEQ(2),... and/or in Y(NEQ(1)+1),... if NEQ is an array 7505 C (dimensioned in F) and/or Y has length exceeding NEQ(1). 7506 C See the descriptions of NEQ and Y below. 7507 C 7508 C If quantities computed in the F routine are needed 7509 C externally to DLSODPK, an extra call to F should be made 7510 C for this purpose, for consistent and accurate results. 7511 C If only the derivative dy/dt is needed, use DINTDY instead. 7512 C 7513 C NEQ = the size of the ODE system (number of first order 7514 C ordinary differential equations). Used only for input. 7515 C NEQ may be decreased, but not increased, during the problem. 7516 C If NEQ is decreased (with ISTATE = 3 on input), the 7517 C remaining components of Y should be left undisturbed, if 7518 C these are to be accessed in the user-supplied subroutines. 7519 C 7520 C Normally, NEQ is a scalar, and it is generally referred to 7521 C as a scalar in this user interface description. However, 7522 C NEQ may be an array, with NEQ(1) set to the system size. 7523 C (The DLSODPK package accesses only NEQ(1).) In either case, 7524 C this parameter is passed as the NEQ argument in all calls 7525 C to F, JAC, and PSOL. Hence, if it is an array, locations 7526 C NEQ(2),... may be used to store other integer data and pass 7527 C it to the user-supplied subroutines. Each such routine must 7528 C include NEQ in a Dimension statement in that case. 7529 C 7530 C Y = a real array for the vector of dependent variables, of 7531 C length NEQ or more. Used for both input and output on the 7532 C first call (ISTATE = 1), and only for output on other calls. 7533 C On the first call, Y must contain the vector of initial 7534 C values. On output, Y contains the computed solution vector, 7535 C evaluated at T. If desired, the Y array may be used 7536 C for other purposes between calls to the solver. 7537 C 7538 C This array is passed as the Y argument in all calls to F, 7539 C JAC, and PSOL. Hence its length may exceed NEQ, and locations 7540 C Y(NEQ+1),... may be used to store other real data and 7541 C pass it to the user-supplied subroutines. (The DLSODPK 7542 C package accesses only Y(1),...,Y(NEQ).) 7543 C 7544 C T = the independent variable. On input, T is used only on the 7545 C first call, as the initial point of the integration. 7546 C On output, after each call, T is the value at which a 7547 C computed solution y is evaluated (usually the same as TOUT). 7548 C On an error return, T is the farthest point reached. 7549 C 7550 C TOUT = the next value of t at which a computed solution is desired. 7551 C Used only for input. 7552 C 7553 C When starting the problem (ISTATE = 1), TOUT may be equal 7554 C to T for one call, then should .ne. T for the next call. 7555 C For the initial T, an input value of TOUT .ne. T is used 7556 C in order to determine the direction of the integration 7557 C (i.e. the algebraic sign of the step sizes) and the rough 7558 C scale of the problem. Integration in either direction 7559 C (forward or backward in t) is permitted. 7560 C 7561 C If ITASK = 2 or 5 (one-step modes), TOUT is ignored after 7562 C the first call (i.e. the first call with TOUT .ne. T). 7563 C Otherwise, TOUT is required on every call. 7564 C 7565 C If ITASK = 1, 3, or 4, the values of TOUT need not be 7566 C monotone, but a value of TOUT which backs up is limited 7567 C to the current internal T interval, whose endpoints are 7568 C TCUR - HU and TCUR (see optional outputs, below, for 7569 C TCUR and HU). 7570 C 7571 C ITOL = an indicator for the type of error control. See 7572 C description below under ATOL. Used only for input. 7573 C 7574 C RTOL = a relative error tolerance parameter, either a scalar or 7575 C an array of length NEQ. See description below under ATOL. 7576 C Input only. 7577 C 7578 C ATOL = an absolute error tolerance parameter, either a scalar or 7579 C an array of length NEQ. Input only. 7580 C 7581 C The input parameters ITOL, RTOL, and ATOL determine 7582 C the error control performed by the solver. The solver will 7583 C control the vector E = (E(i)) of estimated local errors 7584 C in y, according to an inequality of the form 7585 C RMS-norm of ( E(i)/EWT(i) ) .le. 1, 7586 C where EWT(i) = RTOL(i)*ABS(Y(i)) + ATOL(i), 7587 C and the RMS-norm (root-mean-square norm) here is 7588 C RMS-norm(v) = SQRT(sum v(i)**2 / NEQ). Here EWT = (EWT(i)) 7589 C is a vector of weights which must always be positive, and 7590 C the values of RTOL and ATOL should all be non-negative. 7591 C the following table gives the types (scalar/array) of 7592 C RTOL and ATOL, and the corresponding form of EWT(i). 7593 C 7594 C ITOL RTOL ATOL EWT(i) 7595 C 1 scalar scalar RTOL*ABS(Y(i)) + ATOL 7596 C 2 scalar array RTOL*ABS(Y(i)) + ATOL(i) 7597 C 3 array scalar RTOL(i)*ABS(Y(i)) + ATOL 7598 C 4 array array RTOL(i)*ABS(Y(i)) + ATOL(i) 7599 C 7600 C When either of these parameters is a scalar, it need not 7601 C be dimensioned in the user's calling program. 7602 C 7603 C If none of the above choices (with ITOL, RTOL, and ATOL 7604 C fixed throughout the problem) is suitable, more general 7605 C error controls can be obtained by substituting 7606 C user-supplied routines for the setting of EWT and/or for 7607 C the norm calculation. See Part 4 below. 7608 C 7609 C If global errors are to be estimated by making a repeated 7610 C run on the same problem with smaller tolerances, then all 7611 C components of RTOL and ATOL (i.e. of EWT) should be scaled 7612 C down uniformly. 7613 C 7614 C ITASK = an index specifying the task to be performed. 7615 C Input only. ITASK has the following values and meanings. 7616 C 1 means normal computation of output values of y(t) at 7617 C t = TOUT (by overshooting and interpolating). 7618 C 2 means take one step only and return. 7619 C 3 means stop at the first internal mesh point at or 7620 C beyond t = TOUT and return. 7621 C 4 means normal computation of output values of y(t) at 7622 C t = TOUT but without overshooting t = TCRIT. 7623 C TCRIT must be input as RWORK(1). TCRIT may be equal to 7624 C or beyond TOUT, but not behind it in the direction of 7625 C integration. This option is useful if the problem 7626 C has a singularity at or beyond t = TCRIT. 7627 C 5 means take one step, without passing TCRIT, and return. 7628 C TCRIT must be input as RWORK(1). 7629 C 7630 C Note: If ITASK = 4 or 5 and the solver reaches TCRIT 7631 C (within roundoff), it will return T = TCRIT (exactly) to 7632 C indicate this (unless ITASK = 4 and TOUT comes before TCRIT, 7633 C in which case answers at t = TOUT are returned first). 7634 C 7635 C ISTATE = an index used for input and output to specify the 7636 C the state of the calculation. 7637 C 7638 C On input, the values of ISTATE are as follows. 7639 C 1 means this is the first call for the problem 7640 C (initializations will be done). See note below. 7641 C 2 means this is not the first call, and the calculation 7642 C is to continue normally, with no change in any input 7643 C parameters except possibly TOUT and ITASK. 7644 C (If ITOL, RTOL, and/or ATOL are changed between calls 7645 C with ISTATE = 2, the new values will be used but not 7646 C tested for legality.) 7647 C 3 means this is not the first call, and the 7648 C calculation is to continue normally, but with 7649 C a change in input parameters other than 7650 C TOUT and ITASK. Changes are allowed in 7651 C NEQ, ITOL, RTOL, ATOL, IOPT, LRW, LIW, MF, 7652 C and any of the optional inputs except H0. 7653 C Note: A preliminary call with TOUT = T is not counted 7654 C as a first call here, as no initialization or checking of 7655 C input is done. (Such a call is sometimes useful for the 7656 C purpose of outputting the initial conditions.) 7657 C Thus the first call for which TOUT .ne. T requires 7658 C ISTATE = 1 on input. 7659 C 7660 C On output, ISTATE has the following values and meanings. 7661 C 1 means nothing was done; TOUT = T and ISTATE = 1 on input. 7662 C 2 means the integration was performed successfully. 7663 C -1 means an excessive amount of work (more than MXSTEP 7664 C steps) was done on this call, before completing the 7665 C requested task, but the integration was otherwise 7666 C successful as far as T. (MXSTEP is an optional input 7667 C and is normally 500.) To continue, the user may 7668 C simply reset ISTATE to a value .gt. 1 and call again 7669 C (the excess work step counter will be reset to 0). 7670 C In addition, the user may increase MXSTEP to avoid 7671 C this error return (see below on optional inputs). 7672 C -2 means too much accuracy was requested for the precision 7673 C of the machine being used. This was detected before 7674 C completing the requested task, but the integration 7675 C was successful as far as T. To continue, the tolerance 7676 C parameters must be reset, and ISTATE must be set 7677 C to 3. The optional output TOLSF may be used for this 7678 C purpose. (Note: If this condition is detected before 7679 C taking any steps, then an illegal input return 7680 C (ISTATE = -3) occurs instead.) 7681 C -3 means illegal input was detected, before taking any 7682 C integration steps. See written message for details. 7683 C Note: If the solver detects an infinite loop of calls 7684 C to the solver with illegal input, it will cause 7685 C the run to stop. 7686 C -4 means there were repeated error test failures on 7687 C one attempted step, before completing the requested 7688 C task, but the integration was successful as far as T. 7689 C The problem may have a singularity, or the input 7690 C may be inappropriate. 7691 C -5 means there were repeated convergence test failures on 7692 C one attempted step, before completing the requested 7693 C task, but the integration was successful as far as T. 7694 C -6 means EWT(i) became zero for some i during the 7695 C integration. Pure relative error control (ATOL(i)=0.0) 7696 C was requested on a variable which has now vanished. 7697 C The integration was successful as far as T. 7698 C -7 means the PSOL routine returned an unrecoverable error 7699 C flag (IER .lt. 0). The integration was successful as 7700 C far as T. 7701 C 7702 C Note: since the normal output value of ISTATE is 2, 7703 C it does not need to be reset for normal continuation. 7704 C Also, since a negative input value of ISTATE will be 7705 C regarded as illegal, a negative output value requires the 7706 C user to change it, and possibly other inputs, before 7707 C calling the solver again. 7708 C 7709 C IOPT = an integer flag to specify whether or not any optional 7710 C inputs are being used on this call. Input only. 7711 C The optional inputs are listed separately below. 7712 C IOPT = 0 means no optional inputs are being used. 7713 C Default values will be used in all cases. 7714 C IOPT = 1 means one or more optional inputs are being used. 7715 C 7716 C RWORK = a real working array (double precision). 7717 C The length of RWORK must be at least 7718 C 20 + NYH*(MAXORD + 1) + 3*NEQ + LENLS + LWP where 7719 C NYH = the initial value of NEQ, 7720 C MAXORD = 12 (if METH = 1) or 5 (if METH = 2) (unless a 7721 C smaller value is given as an optional input), 7722 C LENLS = length of work space for linear system (Krylov) 7723 C method, excluding preconditioning: 7724 C LENLS = 0 if MITER = 0, 7725 C LENLS = NEQ*(MAXL+3) + MAXL**2 if MITER = 1, 7726 C LENLS = NEQ*(MAXL+3+MIN(1,MAXL-KMP)) 7727 C + (MAXL+3)*MAXL + 1 if MITER = 2, 7728 C LENLS = 6*NEQ if MITER = 3 or 4, 7729 C LENLS = 3*NEQ if MITER = 9. 7730 C (See the MF description for METH and MITER, and the 7731 C list of optional inputs for MAXL and KMP.) 7732 C LWP = length of real user work space for preconditioning 7733 C (see JAC/PSOL). 7734 C Thus if default values are used and NEQ is constant, 7735 C this length is: 7736 C 20 + 16*NEQ for MF = 10, 7737 C 45 + 24*NEQ + LWP FOR MF = 11, 7738 C 61 + 24*NEQ + LWP FOR MF = 12, 7739 C 20 + 22*NEQ + LWP FOR MF = 13 OR 14, 7740 C 20 + 19*NEQ + LWP FOR MF = 19, 7741 C 20 + 9*NEQ FOR MF = 20, 7742 C 45 + 17*NEQ + LWP FOR MF = 21, 7743 C 61 + 17*NEQ + LWP FOR MF = 22, 7744 C 20 + 15*NEQ + LWP FOR MF = 23 OR 24, 7745 C 20 + 12*NEQ + LWP for MF = 29. 7746 C The first 20 words of RWORK are reserved for conditional 7747 C and optional inputs and optional outputs. 7748 C 7749 C The following word in RWORK is a conditional input: 7750 C RWORK(1) = TCRIT = critical value of t which the solver 7751 C is not to overshoot. Required if ITASK is 7752 C 4 or 5, and ignored otherwise. (See ITASK.) 7753 C 7754 C LRW = the length of the array RWORK, as declared by the user. 7755 C (This will be checked by the solver.) 7756 C 7757 C IWORK = an integer work array. The length of IWORK must be at least 7758 C 30 if MITER = 0 (MF = 10 or 20), 7759 C 30 + MAXL + LIWP if MITER = 1 (MF = 11, 21), 7760 C 30 + LIWP if MITER = 2, 3, 4, or 9. 7761 C MAXL = 5 unless a different optional input value is given. 7762 C LIWP = length of integer user work space for preconditioning 7763 C (see conditional input list following). 7764 C The first few words of IWORK are used for conditional and 7765 C optional inputs and optional outputs. 7766 C 7767 C The following 4 words in IWORK are conditional inputs, 7768 C required if MITER .ge. 1: 7769 C IWORK(1) = LWP = length of real array WP for use in 7770 C preconditioning (part of RWORK array). 7771 C IWORK(2) = LIWP = length of integer array IWP for use in 7772 C preconditioning (part of IWORK array). 7773 C The arrays WP and IWP are work arrays under the 7774 C user's control, for use in the routines that 7775 C perform preconditioning operations (JAC and PSOL). 7776 C IWORK(3) = JPRE = preconditioner type flag: 7777 C = 0 for no preconditioning (P1 = P2 = P = identity) 7778 C = 1 for left-only preconditioning (P2 = identity) 7779 C = 2 for right-only preconditioning (P1 = identity) 7780 C = 3 for two-sided preconditioning (and PCG or PCGS) 7781 C IWORK(4) = JACFLG = flag for whether JAC is called. 7782 C = 0 if JAC is not to be called, 7783 C = 1 if JAC is to be called. 7784 C Use JACFLG = 1 if JAC computes any nonconstant 7785 C data needed in preconditioning operations, 7786 C such as some of the Jacobian elements. 7787 C 7788 C LIW = the length of the array IWORK, as declared by the user. 7789 C (This will be checked by the solver.) 7790 C 7791 C Note: The work arrays must not be altered between calls to DLSODPK 7792 C for the same problem, except possibly for the conditional and 7793 C optional inputs, and except for the last 3*NEQ words of RWORK. 7794 C The latter space is used for internal scratch space, and so is 7795 C available for use by the user outside DLSODPK between calls, if 7796 C desired (but not for use by any of the user-supplied subroutines). 7797 C 7798 C JAC = the name of the user-supplied routine to compute any 7799 C Jacobian elements (or approximations) involved in the 7800 C matrix preconditioning operations (MITER .ge. 1). 7801 C It is to have the form 7802 C SUBROUTINE JAC (F, NEQ, T, Y, YSV, REWT, FTY, V, 7803 C 1 HL0, WP, IWP, IER) 7804 C DOUBLE PRECISION T, Y(*),YSV(*), REWT(*), FTY(*), V(*), 7805 C 1 HL0, WP(*) 7806 C INTEGER IWP(*) 7807 C This routine must evaluate and preprocess any parts of the 7808 C Jacobian matrix df/dy used in the preconditioners P1, P2, P. 7809 C the Y and FTY arrays contain the current values of y and 7810 C f(t,y), respectively, and YSV also contains the current 7811 C value of y. The array V is work space of length 7812 C NEQ for use by JAC. REWT is the array of reciprocal error 7813 C weights (1/EWT). JAC must multiply all computed Jacobian 7814 C elements by the scalar -HL0, add the identity matrix, and do 7815 C any factorization operations called for, in preparation 7816 C for solving linear systems with a coefficient matrix of 7817 C P1, P2, or P. The matrix P1*P2 or P should be an 7818 C approximation to identity - HL0 * (df/dy). JAC should 7819 C return IER = 0 if successful, and IER .ne. 0 if not. 7820 C (If IER .ne. 0, a smaller time step will be tried.) 7821 C The arrays WP (of length LWP) and IWP (of length LIWP) 7822 C are for use by JAC and PSOL for work space and for storage 7823 C of data needed for the solution of the preconditioner 7824 C linear systems. Their lengths and contents are under the 7825 C user's control. 7826 C The JAC routine may save relevant Jacobian elements (or 7827 C approximations) used in the preconditioners, along with the 7828 C value of HL0, and use these to reconstruct preconditioner 7829 C matrices later without reevaluationg those elements. 7830 C This may be cost-effective if JAC is called with HL0 7831 C considerably different from its earlier value, indicating 7832 C that a corrector convergence failure has occurred because 7833 C of the change in HL0, not because of changes in the 7834 C value of the Jacobian. In doing this, use the saved and 7835 C current values of HL0 to decide whether to use saved 7836 C or reevaluated elements. 7837 C JAC may alter V, but may not alter Y, YSV, REWT, FTY, or HL0. 7838 C JAC must be declared External in the calling program. 7839 C Subroutine JAC may access user-defined quantities in 7840 C NEQ(2),... and/or in Y(NEQ(1)+1),... if NEQ is an array 7841 C (dimensioned in JAC) and/or Y has length exceeding NEQ(1). 7842 C See the descriptions of NEQ and Y above. 7843 C 7844 C PSOL = the name of the user-supplied routine for the 7845 C solution of preconditioner linear systems. 7846 C It is to have the form 7847 C SUBROUTINE PSOL (NEQ, T, Y, FTY, WK,HL0, WP,IWP, B, LR,IER) 7848 C DOUBLE PRECISION T, Y(*), FTY(*), WK(*), HL0, WP(*), B(*) 7849 C INTEGER IWP(*) 7850 C This routine must solve a linear system with B as right-hand 7851 C side and one of the preconditioning matrices, P1, P2, or P, 7852 C as coefficient matrix, and return the solution vector in B. 7853 C LR is a flag concerning left vs right preconditioning, input 7854 C to PSOL. PSOL is to use P1 if LR = 1 and P2 if LR = 2. 7855 C In the case of the PCG or PCGS method, LR will be 3, and PSOL 7856 C should solve the system P*x = B with the preconditioner P. 7857 C In the case MITER = 9 (no Krylov iteration), LR will be 0, 7858 C and PSOL is to return in B the desired approximate solution 7859 C to A * x = B, where A = identity - HL0 * (df/dy). 7860 C PSOL can use data generated in the JAC routine and stored in 7861 C WP and IWP. 7862 C The Y and FTY arrays contain the current values of y and 7863 C f(t,y), respectively. The array WK is work space of length 7864 C NEQ for use by PSOL. 7865 C The argument HL0 is the current value of the scalar appearing 7866 C in the linear system. If the old value, as of the last 7867 C JAC call, is needed, it must have been saved by JAC in WP. 7868 C On return, PSOL should set the error flag IER as follows: 7869 C IER = 0 if PSOL was successful, 7870 C IER .gt. 0 on a recoverable error, meaning that the 7871 C time step will be retried, 7872 C IER .lt. 0 on an unrecoverable error, meaning that the 7873 C solver is to stop immediately. 7874 C PSOL may not alter Y, FTY, or HL0. 7875 C PSOL must be declared External in the calling program. 7876 C Subroutine PSOL may access user-defined quantities in 7877 C NEQ(2),... and Y(NEQ(1)+1),... if NEQ is an array 7878 C (dimensioned in PSOL) and/or Y has length exceeding NEQ(1). 7879 C See the descriptions of NEQ and Y above. 7880 C 7881 C MF = the method flag. Used only for input. The legal values of 7882 C MF are 10, 11, 12, 13, 14, 19, 20, 21, 22, 23, 24, and 29. 7883 C MF has decimal digits METH and MITER: MF = 10*METH + MITER. 7884 C METH indicates the basic linear multistep method: 7885 C METH = 1 means the implicit Adams method. 7886 C METH = 2 means the method based on Backward 7887 C Differentiation Formulas (BDFs). 7888 C MITER indicates the corrector iteration method: 7889 C MITER = 0 means functional iteration (no linear system 7890 C is involved). 7891 C MITER = 1 means Newton iteration with Scaled Preconditioned 7892 C Incomplete Orthogonalization Method (SPIOM) 7893 C for the linear systems. 7894 C MITER = 2 means Newton iteration with Scaled Preconditioned 7895 C Generalized Minimal Residual method (SPIGMR) 7896 C for the linear systems. 7897 C MITER = 3 means Newton iteration with Preconditioned 7898 C Conjugate Gradient method (PCG) 7899 C for the linear systems. 7900 C MITER = 4 means Newton iteration with scaled Preconditioned 7901 C Conjugate Gradient method (PCGS) 7902 C for the linear systems. 7903 C MITER = 9 means Newton iteration with only the 7904 C user-supplied PSOL routine called (no Krylov 7905 C iteration) for the linear systems. 7906 C JPRE is ignored, and PSOL is called with LR = 0. 7907 C See comments in the introduction about the choice of MITER. 7908 C If MITER .ge. 1, the user must supply routines JAC and PSOL 7909 C (the names are arbitrary) as described above. 7910 C For MITER = 0, dummy arguments can be used. 7911 C----------------------------------------------------------------------- 7912 C Optional Inputs. 7913 C 7914 C The following is a list of the optional inputs provided for in the 7915 C call sequence. (See also Part 2.) For each such input variable, 7916 C this table lists its name as used in this documentation, its 7917 C location in the call sequence, its meaning, and the default value. 7918 C The use of any of these inputs requires IOPT = 1, and in that 7919 C case all of these inputs are examined. A value of zero for any 7920 C of these optional inputs will cause the default value to be used. 7921 C Thus to use a subset of the optional inputs, simply preload 7922 C locations 5 to 10 in RWORK and IWORK to 0.0 and 0 respectively, and 7923 C then set those of interest to nonzero values. 7924 C 7925 C Name Location Meaning and Default Value 7926 C 7927 C H0 RWORK(5) the step size to be attempted on the first step. 7928 C The default value is determined by the solver. 7929 C 7930 C HMAX RWORK(6) the maximum absolute step size allowed. 7931 C The default value is infinite. 7932 C 7933 C HMIN RWORK(7) the minimum absolute step size allowed. 7934 C The default value is 0. (This lower bound is not 7935 C enforced on the final step before reaching TCRIT 7936 C when ITASK = 4 or 5.) 7937 C 7938 C DELT RWORK(8) convergence test constant in Krylov iteration 7939 C algorithm. The default is .05. 7940 C 7941 C MAXORD IWORK(5) the maximum order to be allowed. The default 7942 C value is 12 if METH = 1, and 5 if METH = 2. 7943 C If MAXORD exceeds the default value, it will 7944 C be reduced to the default value. 7945 C If MAXORD is changed during the problem, it may 7946 C cause the current order to be reduced. 7947 C 7948 C MXSTEP IWORK(6) maximum number of (internally defined) steps 7949 C allowed during one call to the solver. 7950 C The default value is 500. 7951 C 7952 C MXHNIL IWORK(7) maximum number of messages printed (per problem) 7953 C warning that T + H = T on a step (H = step size). 7954 C This must be positive to result in a non-default 7955 C value. The default value is 10. 7956 C 7957 C MAXL IWORK(8) maximum number of iterations in the SPIOM, SPIGMR, 7958 C PCG, or PCGS algorithm (.le. NEQ). 7959 C The default is MAXL = MIN(5,NEQ). 7960 C 7961 C KMP IWORK(9) number of vectors on which orthogonalization 7962 C is done in SPIOM or SPIGMR algorithm (.le. MAXL). 7963 C The default is KMP = MAXL. 7964 C Note: When KMP .lt. MAXL and MF = 22, the length 7965 C of RWORK must be defined accordingly. See 7966 C the definition of RWORK above. 7967 C----------------------------------------------------------------------- 7968 C Optional Outputs. 7969 C 7970 C As optional additional output from DLSODPK, the variables listed 7971 C below are quantities related to the performance of DLSODPK 7972 C which are available to the user. These are communicated by way of 7973 C the work arrays, but also have internal mnemonic names as shown. 7974 C Except where stated otherwise, all of these outputs are defined 7975 C on any successful return from DLSODPK, and on any return with 7976 C ISTATE = -1, -2, -4, -5, -6, or -7. On an illegal input return 7977 C (ISTATE = -3), they will be unchanged from their existing values 7978 C (if any), except possibly for TOLSF, LENRW, and LENIW. 7979 C On any error return, outputs relevant to the error will be defined, 7980 C as noted below. 7981 C 7982 C Name Location Meaning 7983 C 7984 C HU RWORK(11) the step size in t last used (successfully). 7985 C 7986 C HCUR RWORK(12) the step size to be attempted on the next step. 7987 C 7988 C TCUR RWORK(13) the current value of the independent variable 7989 C which the solver has actually reached, i.e. the 7990 C current internal mesh point in t. On output, TCUR 7991 C will always be at least as far as the argument 7992 C T, but may be farther (if interpolation was done). 7993 C 7994 C TOLSF RWORK(14) a tolerance scale factor, greater than 1.0, 7995 C computed when a request for too much accuracy was 7996 C detected (ISTATE = -3 if detected at the start of 7997 C the problem, ISTATE = -2 otherwise). If ITOL is 7998 C left unaltered but RTOL and ATOL are uniformly 7999 C scaled up by a factor of TOLSF for the next call, 8000 C then the solver is deemed likely to succeed. 8001 C (The user may also ignore TOLSF and alter the 8002 C tolerance parameters in any other way appropriate.) 8003 C 8004 C NST IWORK(11) the number of steps taken for the problem so far. 8005 C 8006 C NFE IWORK(12) the number of f evaluations for the problem so far. 8007 C 8008 C NPE IWORK(13) the number of calls to JAC so far (for Jacobian 8009 C evaluation associated with preconditioning). 8010 C 8011 C NQU IWORK(14) the method order last used (successfully). 8012 C 8013 C NQCUR IWORK(15) the order to be attempted on the next step. 8014 C 8015 C IMXER IWORK(16) the index of the component of largest magnitude in 8016 C the weighted local error vector ( E(i)/EWT(i) ), 8017 C on an error return with ISTATE = -4 or -5. 8018 C 8019 C LENRW IWORK(17) the length of RWORK actually required. 8020 C This is defined on normal returns and on an illegal 8021 C input return for insufficient storage. 8022 C 8023 C LENIW IWORK(18) the length of IWORK actually required. 8024 C This is defined on normal returns and on an illegal 8025 C input return for insufficient storage. 8026 C 8027 C NNI IWORK(19) number of nonlinear iterations so far (each of 8028 C which calls an iterative linear solver). 8029 C 8030 C NLI IWORK(20) number of linear iterations so far. 8031 C Note: A measure of the success of algorithm is 8032 C the average number of linear iterations per 8033 C nonlinear iteration, given by NLI/NNI. 8034 C If this is close to MAXL, MAXL may be too small. 8035 C 8036 C NPS IWORK(21) number of preconditioning solve operations 8037 C (PSOL calls) so far. 8038 C 8039 C NCFN IWORK(22) number of convergence failures of the nonlinear 8040 C (Newton) iteration so far. 8041 C Note: A measure of success is the overall 8042 C rate of nonlinear convergence failures, NCFN/NST. 8043 C 8044 C NCFL IWORK(23) number of convergence failures of the linear 8045 C iteration so far. 8046 C Note: A measure of success is the overall 8047 C rate of linear convergence failures, NCFL/NNI. 8048 C 8049 C The following two arrays are segments of the RWORK array which 8050 C may also be of interest to the user as optional outputs. 8051 C For each array, the table below gives its internal name, 8052 C its base address in RWORK, and its description. 8053 C 8054 C Name Base Address Description 8055 C 8056 C YH 21 the Nordsieck history array, of size NYH by 8057 C (NQCUR + 1), where NYH is the initial value 8058 C of NEQ. For j = 0,1,...,NQCUR, column j+1 8059 C of YH contains HCUR**j/factorial(j) times 8060 C the j-th derivative of the interpolating 8061 C polynomial currently representing the solution, 8062 C evaluated at t = TCUR. 8063 C 8064 C ACOR LENRW-NEQ+1 array of size NEQ used for the accumulated 8065 C corrections on each step, scaled on output 8066 C to represent the estimated local error in y 8067 C on the last step. This is the vector E in 8068 C the description of the error control. It is 8069 C defined only on a successful return from 8070 C DLSODPK. 8071 C 8072 C----------------------------------------------------------------------- 8073 C Part 2. Other Routines Callable. 8074 C 8075 C The following are optional calls which the user may make to 8076 C gain additional capabilities in conjunction with DLSODPK. 8077 C (The routines XSETUN and XSETF are designed to conform to the 8078 C SLATEC error handling package.) 8079 C 8080 C Form of Call Function 8081 C CALL XSETUN(LUN) Set the logical unit number, LUN, for 8082 C output of messages from DLSODPK, if 8083 C the default is not desired. 8084 C The default value of lun is 6. 8085 C 8086 C CALL XSETF(MFLAG) Set a flag to control the printing of 8087 C messages by DLSODPK. 8088 C MFLAG = 0 means do not print. (Danger: 8089 C This risks losing valuable information.) 8090 C MFLAG = 1 means print (the default). 8091 C 8092 C Either of the above calls may be made at 8093 C any time and will take effect immediately. 8094 C 8095 C CALL DSRCPK(RSAV,ISAV,JOB) saves and restores the contents of 8096 C the internal Common blocks used by 8097 C DLSODPK (see Part 3 below). 8098 C RSAV must be a real array of length 222 8099 C or more, and ISAV must be an integer 8100 C array of length 50 or more. 8101 C JOB=1 means save Common into RSAV/ISAV. 8102 C JOB=2 means restore Common from RSAV/ISAV. 8103 C DSRCPK is useful if one is 8104 C interrupting a run and restarting 8105 C later, or alternating between two or 8106 C more problems solved with DLSODPK. 8107 C 8108 C CALL DINTDY(,,,,,) Provide derivatives of y, of various 8109 C (See below) orders, at a specified point t, if 8110 C desired. It may be called only after 8111 C a successful return from DLSODPK. 8112 C 8113 C The detailed instructions for using DINTDY are as follows. 8114 C The form of the call is: 8115 C 8116 C CALL DINTDY (T, K, RWORK(21), NYH, DKY, IFLAG) 8117 C 8118 C The input parameters are: 8119 C 8120 C T = value of independent variable where answers are desired 8121 C (normally the same as the T last returned by DLSODPK). 8122 C for valid results, T must lie between TCUR - HU and TCUR. 8123 C (See optional outputs for TCUR and HU.) 8124 C K = integer order of the derivative desired. K must satisfy 8125 C 0 .le. K .le. NQCUR, where NQCUR is the current order 8126 C (see optional outputs). The capability corresponding 8127 C to K = 0, i.e. computing y(T), is already provided 8128 C by DLSODPK directly. Since NQCUR .ge. 1, the first 8129 C derivative dy/dt is always available with DINTDY. 8130 C RWORK(21) = the base address of the history array YH. 8131 C NYH = column length of YH, equal to the initial value of NEQ. 8132 C 8133 C The output parameters are: 8134 C 8135 C DKY = a real array of length NEQ containing the computed value 8136 C of the K-th derivative of y(t). 8137 C IFLAG = integer flag, returned as 0 if K and T were legal, 8138 C -1 if K was illegal, and -2 if T was illegal. 8139 C On an error return, a message is also written. 8140 C----------------------------------------------------------------------- 8141 C Part 3. Common Blocks. 8142 C 8143 C If DLSODPK is to be used in an overlay situation, the user 8144 C must declare, in the primary overlay, the variables in: 8145 C (1) the call sequence to DLSODPK, and 8146 C (2) the two internal Common blocks 8147 C /DLS001/ of length 255 (218 double precision words 8148 C followed by 37 integer words), 8149 C /DLPK01/ of length 17 (4 double precision words 8150 C followed by 13 integer words). 8151 C 8152 C If DLSODPK is used on a system in which the contents of internal 8153 C Common blocks are not preserved between calls, the user should 8154 C declare the above Common blocks in the calling program to insure 8155 C that their contents are preserved. 8156 C 8157 C If the solution of a given problem by DLSODPK is to be interrupted 8158 C and then later continued, such as when restarting an interrupted run 8159 C or alternating between two or more problems, the user should save, 8160 C following the return from the last DLSODPK call prior to the 8161 C interruption, the contents of the call sequence variables and the 8162 C internal Common blocks, and later restore these values before the 8163 C next DLSODPK call for that problem. To save and restore the Common 8164 C blocks, use Subroutine DSRCPK (see Part 2 above). 8165 C 8166 C----------------------------------------------------------------------- 8167 C Part 4. Optionally Replaceable Solver Routines. 8168 C 8169 C below are descriptions of two routines in the DLSODPK package which 8170 C relate to the measurement of errors. Either routine can be 8171 C replaced by a user-supplied version, if desired. However, since such 8172 C a replacement may have a major impact on performance, it should be 8173 C done only when absolutely necessary, and only with great caution. 8174 C (Note: The means by which the package version of a routine is 8175 C superseded by the user's version may be system-dependent.) 8176 C 8177 C (a) DEWSET. 8178 C The following subroutine is called just before each internal 8179 C integration step, and sets the array of error weights, EWT, as 8180 C described under ITOL/RTOL/ATOL above: 8181 C SUBROUTINE DEWSET (NEQ, ITOL, RTOL, ATOL, YCUR, EWT) 8182 C where NEQ, ITOL, RTOL, and ATOL are as in the DLSODPK call sequence, 8183 C YCUR contains the current dependent variable vector, and 8184 C EWT is the array of weights set by DEWSET. 8185 C 8186 C If the user supplies this subroutine, it must return in EWT(i) 8187 C (i = 1,...,NEQ) a positive quantity suitable for comparing errors 8188 C in y(i) to. The EWT array returned by DEWSET is passed to the DVNORM 8189 C routine (see below), and also used by DLSODPK in the computation 8190 C of the optional output IMXER, the diagonal Jacobian approximation, 8191 C and the increments for difference quotient Jacobians. 8192 C 8193 C In the user-supplied version of DEWSET, it may be desirable to use 8194 C the current values of derivatives of y. Derivatives up to order NQ 8195 C are available from the history array YH, described above under 8196 C optional outputs. In DEWSET, YH is identical to the YCUR array, 8197 C extended to NQ + 1 columns with a column length of NYH and scale 8198 C factors of H**j/factorial(j). On the first call for the problem, 8199 C given by NST = 0, NQ is 1 and H is temporarily set to 1.0. 8200 C NYH is the initial value of NEQ. The quantities NQ, H, and NST 8201 C can be obtained by including in DEWSET the statements: 8202 C DOUBLE PRECISION RLS 8203 C COMMON /DLS001/ RLS(218),ILS(37) 8204 C NQ = ILS(33) 8205 C NST = ILS(34) 8206 C H = RLS(212) 8207 C Thus, for example, the current value of dy/dt can be obtained as 8208 C YCUR(NYH+i)/H (i=1,...,NEQ) (and the division by H is 8209 C unnecessary when NST = 0). 8210 C 8211 C (b) DVNORM. 8212 C The following is a real function routine which computes the weighted 8213 C root-mean-square norm of a vector v: 8214 C D = DVNORM (N, V, W) 8215 C where: 8216 C N = the length of the vector, 8217 C V = real array of length N containing the vector, 8218 C W = real array of length N containing weights, 8219 C D = SQRT( (1/N) * sum(V(i)*W(i))**2 ). 8220 C DVNORM is called with N = NEQ and with W(i) = 1.0/EWT(i), where 8221 C EWT is as set by Subroutine DEWSET. 8222 C 8223 C If the user supplies this function, it should return a non-negative 8224 C value of DVNORM suitable for use in the error control in DLSODPK. 8225 C None of the arguments should be altered by DVNORM. 8226 C For example, a user-supplied DVNORM routine might: 8227 C -substitute a max-norm of (V(i)*W(i)) for the RMS-norm, or 8228 C -ignore some components of V in the norm, with the effect of 8229 C suppressing the error control on those components of y. 8230 C----------------------------------------------------------------------- 8231 C 8232 C***REVISION HISTORY (YYYYMMDD) 8233 C 19860901 DATE WRITTEN 8234 C 19861010 Numerous minor revisions to SPIOM and SPGMR routines; 8235 C minor corrections to prologues and comments. 8236 C 19870114 Changed name SPGMR to SPIGMR; revised residual norm 8237 C calculation in SPIGMR (for incomplete case); 8238 C revised error return logic in SPIGMR; 8239 C 19870330 Major update: corrected comments throughout; 8240 C removed TRET from Common; rewrote EWSET with 4 loops; 8241 C fixed t test in INTDY; added Cray directives in STODPK; 8242 C in STODPK, fixed DELP init. and logic around PJAC call; 8243 C combined routines to save/restore Common; 8244 C passed LEVEL = 0 in error message calls (except run abort). 8245 C 19871130 Added option MITER = 9; shortened WM array by 2; 8246 C revised early return from SPIOM and SPIGMR; 8247 C replaced copy loops with SCOPY/DCOPY calls; 8248 C minor corrections/revisions to SOLPK, SPIGMR, ATV, ATP; 8249 C corrections to main prologue and internal comments. 8250 C 19880304 Corrections to type declarations in SOLPK, SPIOM, USOL. 8251 C 19891025 Added ISTATE = -7 return; minor revisions to USOL; 8252 C added initialization of JACFLG in main driver; 8253 C removed YH and NYH from PKSET call list; 8254 C minor revisions to SPIOM and SPIGMR; 8255 C corrections to main prologue and internal comments. 8256 C 19900803 Added YSV to JAC call list; minor comment corrections. 8257 C 20010425 Major update: convert source lines to upper case; 8258 C added *DECK lines; changed from 1 to * in dummy dimensions; 8259 C changed names R1MACH/D1MACH to RUMACH/DUMACH; 8260 C renamed routines for uniqueness across single/double prec.; 8261 C converted intrinsic names to generic form; 8262 C removed ILLIN and NTREP (data loaded) from Common; 8263 C removed all 'own' variables from Common; 8264 C changed error messages to quoted strings; 8265 C replaced XERRWV/XERRWD with 1993 revised version; 8266 C converted prologues, comments, error messages to mixed case; 8267 C numerous corrections to prologues and internal comments. 8268 C 20010507 Converted single precision source to double precision. 8269 C 20020502 Corrected declarations in descriptions of user routines. 8270 C 20030603 Corrected duplicate type declaration for DUMACH. 8271 C 20031105 Restored 'own' variables to Common blocks, to enable 8272 C interrupt/restart feature. 8273 C 20031112 Added SAVE statements for data-loaded constants. 8274 C 20031117 Changed internal name NPE to NJE. 8275 C 8276 C----------------------------------------------------------------------- 8277 C Other routines in the DLSODPK package. 8278 C 8279 C In addition to Subroutine DLSODPK, the DLSODPK package includes the 8280 C following subroutines and function routines: 8281 C DINTDY computes an interpolated value of the y vector at t = TOUT. 8282 C DEWSET sets the error weight vector EWT before each step. 8283 C DVNORM computes the weighted RMS-norm of a vector. 8284 C DSTODPK is the core integrator, which does one step of the 8285 C integration and the associated error control. 8286 C DCFODE sets all method coefficients and test constants. 8287 C DPKSET interfaces between DSTODPK and the JAC routine. 8288 C DSOLPK manages solution of linear system in Newton iteration. 8289 C DSPIOM performs the SPIOM algorithm. 8290 C DATV computes a scaled, preconditioned product (I-hl0*J)*v. 8291 C DORTHOG orthogonalizes a vector against previous basis vectors. 8292 C DHEFA generates an LU factorization of a Hessenberg matrix. 8293 C DHESL solves a Hessenberg square linear system. 8294 C DSPIGMR performs the SPIGMR algorithm. 8295 C DHEQR generates a QR factorization of a Hessenberg matrix. 8296 C DHELS finds the least squares solution of a Hessenberg system. 8297 C DPCG performs Preconditioned Conjugate Gradient algorithm (PCG). 8298 C DPCGS performs the PCGS algorithm. 8299 C DATP computes the product A*p, where A = I - hl0*df/dy. 8300 C DUSOL interfaces to the user's PSOL routine (MITER = 9). 8301 C DSRCPK is a user-callable routine to save and restore 8302 C the contents of the internal Common blocks. 8303 C DAXPY, DCOPY, DDOT, DNRM2, and DSCAL are basic linear 8304 C algebra modules (from the BLAS collection). 8305 C DUMACH computes the unit roundoff in a machine-independent manner. 8306 C XERRWD, XSETUN, XSETF, IXSAV, and IUMACH handle the printing of all 8307 C error messages and warnings. XERRWD is machine-dependent. 8308 C Note: DVNORM, DDOT, DNRM2, DUMACH, IXSAV, and IUMACH are function 8309 C routines. All the others are subroutines. 8310 C 8311 C----------------------------------------------------------------------- 8312 DOUBLE PRECISION DUMACH, DVNORM 8313 INTEGER INIT, MXSTEP, MXHNIL, NHNIL, NSLAST, NYH, IOWNS, 8314 1 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 8315 2 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 8316 3 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU 8317 INTEGER JPRE, JACFLG, LOCWP, LOCIWP, LSAVX, KMP, MAXL, MNEWT, 8318 1 NNI, NLI, NPS, NCFN, NCFL 8319 INTEGER I, I1, I2, IFLAG, IMXER, KGO, LF0, LENIW, 8320 1 LENIWK, LENRW, LENWM, LENWK, LIWP, LWP, MORD, MXHNL0, MXSTP0, 8321 2 NCFN0, NCFL0, NLI0, NNI0, NNID, NSTD, NWARN 8322 DOUBLE PRECISION ROWNS, 8323 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND 8324 DOUBLE PRECISION DELT, EPCON, SQRTN, RSQRTN 8325 DOUBLE PRECISION ATOLI, AVDIM, AYI, BIG, EWTI, H0, HMAX, HMX, 8326 1 RCFL, RCFN, RH, RTOLI, TCRIT, 8327 2 TDIST, TNEXT, TOL, TOLSF, TP, SIZE, SUM, W0 8328 DIMENSION MORD(2) 8329 LOGICAL IHIT, LAVD, LCFN, LCFL, LWARN 8330 CHARACTER*60 MSG 8331 SAVE MORD, MXSTP0, MXHNL0 8332 C----------------------------------------------------------------------- 8333 C The following two internal Common blocks contain 8334 C (a) variables which are local to any subroutine but whose values must 8335 C be preserved between calls to the routine ("own" variables), and 8336 C (b) variables which are communicated between subroutines. 8337 C The block DLS001 is declared in subroutines DLSODPK, DINTDY, DSTODPK, 8338 C DSOLPK, and DATV. 8339 C The block DLPK01 is declared in subroutines DLSODPK, DSTODPK, DPKSET, 8340 C and DSOLPK. 8341 C Groups of variables are replaced by dummy arrays in the Common 8342 C declarations in routines where those variables are not used. 8343 C----------------------------------------------------------------------- 8344 COMMON /DLS001/ ROWNS(209), 8345 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND, 8346 2 INIT, MXSTEP, MXHNIL, NHNIL, NSLAST, NYH, IOWNS(6), 8347 3 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 8348 4 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 8349 5 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU 8350 C 8351 COMMON /DLPK01/ DELT, EPCON, SQRTN, RSQRTN, 8352 1 JPRE, JACFLG, LOCWP, LOCIWP, LSAVX, KMP, MAXL, MNEWT, 8353 2 NNI, NLI, NPS, NCFN, NCFL 8354 C 8355 DATA MORD(1),MORD(2)/12,5/, MXSTP0/500/, MXHNL0/10/ 8356 C----------------------------------------------------------------------- 8357 C Block A. 8358 C This code block is executed on every call. 8359 C It tests ISTATE and ITASK for legality and branches appropriately. 8360 C If ISTATE .gt. 1 but the flag INIT shows that initialization has 8361 C not yet been done, an error return occurs. 8362 C If ISTATE = 1 and TOUT = T, return immediately. 8363 C----------------------------------------------------------------------- 8364 IF (ISTATE .LT. 1 .OR. ISTATE .GT. 3) GO TO 601 8365 IF (ITASK .LT. 1 .OR. ITASK .GT. 5) GO TO 602 8366 IF (ISTATE .EQ. 1) GO TO 10 8367 IF (INIT .EQ. 0) GO TO 603 8368 IF (ISTATE .EQ. 2) GO TO 200 8369 GO TO 20 8370 10 INIT = 0 8371 IF (TOUT .EQ. T) RETURN 8372 C----------------------------------------------------------------------- 8373 C Block B. 8374 C The next code block is executed for the initial call (ISTATE = 1), 8375 C or for a continuation call with parameter changes (ISTATE = 3). 8376 C It contains checking of all inputs and various initializations. 8377 C 8378 C First check legality of the non-optional inputs NEQ, ITOL, IOPT, MF. 8379 C----------------------------------------------------------------------- 8380 20 IF (NEQ(1) .LE. 0) GO TO 604 8381 IF (ISTATE .EQ. 1) GO TO 25 8382 IF (NEQ(1) .GT. N) GO TO 605 8383 25 N = NEQ(1) 8384 IF (ITOL .LT. 1 .OR. ITOL .GT. 4) GO TO 606 8385 IF (IOPT .LT. 0 .OR. IOPT .GT. 1) GO TO 607 8386 METH = MF/10 8387 MITER = MF - 10*METH 8388 IF (METH .LT. 1 .OR. METH .GT. 2) GO TO 608 8389 IF (MITER .LT. 0) GO TO 608 8390 IF (MITER .GT. 4 .AND. MITER .LT. 9) GO TO 608 8391 IF (MITER .GE. 1) JPRE = IWORK(3) 8392 JACFLG = 0 8393 IF (MITER .GE. 1) JACFLG = IWORK(4) 8394 C Next process and check the optional inputs. -------------------------- 8395 IF (IOPT .EQ. 1) GO TO 40 8396 MAXORD = MORD(METH) 8397 MXSTEP = MXSTP0 8398 MXHNIL = MXHNL0 8399 IF (ISTATE .EQ. 1) H0 = 0.0D0 8400 HMXI = 0.0D0 8401 HMIN = 0.0D0 8402 MAXL = MIN(5,N) 8403 KMP = MAXL 8404 DELT = 0.05D0 8405 GO TO 60 8406 40 MAXORD = IWORK(5) 8407 IF (MAXORD .LT. 0) GO TO 611 8408 IF (MAXORD .EQ. 0) MAXORD = 100 8409 MAXORD = MIN(MAXORD,MORD(METH)) 8410 MXSTEP = IWORK(6) 8411 IF (MXSTEP .LT. 0) GO TO 612 8412 IF (MXSTEP .EQ. 0) MXSTEP = MXSTP0 8413 MXHNIL = IWORK(7) 8414 IF (MXHNIL .LT. 0) GO TO 613 8415 IF (MXHNIL .EQ. 0) MXHNIL = MXHNL0 8416 IF (ISTATE .NE. 1) GO TO 50 8417 H0 = RWORK(5) 8418 IF ((TOUT - T)*H0 .LT. 0.0D0) GO TO 614 8419 50 HMAX = RWORK(6) 8420 IF (HMAX .LT. 0.0D0) GO TO 615 8421 HMXI = 0.0D0 8422 IF (HMAX .GT. 0.0D0) HMXI = 1.0D0/HMAX 8423 HMIN = RWORK(7) 8424 IF (HMIN .LT. 0.0D0) GO TO 616 8425 MAXL = IWORK(8) 8426 IF (MAXL .EQ. 0) MAXL = 5 8427 MAXL = MIN(MAXL,N) 8428 KMP = IWORK(9) 8429 IF (KMP .EQ. 0 .OR. KMP .GT. MAXL) KMP = MAXL 8430 DELT = RWORK(8) 8431 IF (DELT .EQ. 0.0D0) DELT = 0.05D0 8432 C----------------------------------------------------------------------- 8433 C Set work array pointers and check lengths LRW and LIW. 8434 C Pointers to segments of RWORK and IWORK are named by prefixing L to 8435 C the name of the segment. E.g., the segment YH starts at RWORK(LYH). 8436 C RWORK segments (in order) are denoted YH, WM, EWT, SAVF, SAVX, ACOR. 8437 C----------------------------------------------------------------------- 8438 60 LYH = 21 8439 IF (ISTATE .EQ. 1) NYH = N 8440 LWM = LYH + (MAXORD + 1)*NYH 8441 IF (MITER .EQ. 0) LENWK = 0 8442 IF (MITER .EQ. 1) LENWK = N*(MAXL+2) + MAXL*MAXL 8443 IF (MITER .EQ. 2) 8444 1 LENWK = N*(MAXL+2+MIN(1,MAXL-KMP)) + (MAXL+3)*MAXL + 1 8445 IF (MITER .EQ. 3 .OR. MITER .EQ. 4) LENWK = 5*N 8446 IF (MITER .EQ. 9) LENWK = 2*N 8447 LWP = 0 8448 IF (MITER .GE. 1) LWP = IWORK(1) 8449 LENWM = LENWK + LWP 8450 LOCWP = LENWK + 1 8451 LEWT = LWM + LENWM 8452 LSAVF = LEWT + N 8453 LSAVX = LSAVF + N 8454 LACOR = LSAVX + N 8455 IF (MITER .EQ. 0) LACOR = LSAVF + N 8456 LENRW = LACOR + N - 1 8457 IWORK(17) = LENRW 8458 LIWM = 31 8459 LENIWK = 0 8460 IF (MITER .EQ. 1) LENIWK = MAXL 8461 LIWP = 0 8462 IF (MITER .GE. 1) LIWP = IWORK(2) 8463 LENIW = 30 + LENIWK + LIWP 8464 LOCIWP = LENIWK + 1 8465 IWORK(18) = LENIW 8466 IF (LENRW .GT. LRW) GO TO 617 8467 IF (LENIW .GT. LIW) GO TO 618 8468 C Check RTOL and ATOL for legality. ------------------------------------ 8469 RTOLI = RTOL(1) 8470 ATOLI = ATOL(1) 8471 DO 70 I = 1,N 8472 IF (ITOL .GE. 3) RTOLI = RTOL(I) 8473 IF (ITOL .EQ. 2 .OR. ITOL .EQ. 4) ATOLI = ATOL(I) 8474 IF (RTOLI .LT. 0.0D0) GO TO 619 8475 IF (ATOLI .LT. 0.0D0) GO TO 620 8476 70 CONTINUE 8477 C Load SQRT(N) and its reciprocal in Common. --------------------------- 8478 SQRTN = SQRT(REAL(N)) 8479 RSQRTN = 1.0D0/SQRTN 8480 IF (ISTATE .EQ. 1) GO TO 100 8481 C If ISTATE = 3, set flag to signal parameter changes to DSTODPK. ------ 8482 JSTART = -1 8483 IF (NQ .LE. MAXORD) GO TO 90 8484 C MAXORD was reduced below NQ. Copy YH(*,MAXORD+2) into SAVF. --------- 8485 DO 80 I = 1,N 8486 80 RWORK(I+LSAVF-1) = RWORK(I+LWM-1) 8487 90 CONTINUE 8488 IF (N .EQ. NYH) GO TO 200 8489 C NEQ was reduced. Zero part of YH to avoid undefined references. ----- 8490 I1 = LYH + L*NYH 8491 I2 = LYH + (MAXORD + 1)*NYH - 1 8492 IF (I1 .GT. I2) GO TO 200 8493 DO 95 I = I1,I2 8494 95 RWORK(I) = 0.0D0 8495 GO TO 200 8496 C----------------------------------------------------------------------- 8497 C Block C. 8498 C The next block is for the initial call only (ISTATE = 1). 8499 C It contains all remaining initializations, the initial call to F, 8500 C and the calculation of the initial step size. 8501 C The error weights in EWT are inverted after being loaded. 8502 C----------------------------------------------------------------------- 8503 100 UROUND = DUMACH() 8504 TN = T 8505 IF (ITASK .NE. 4 .AND. ITASK .NE. 5) GO TO 110 8506 TCRIT = RWORK(1) 8507 IF ((TCRIT - TOUT)*(TOUT - T) .LT. 0.0D0) GO TO 625 8508 IF (H0 .NE. 0.0D0 .AND. (T + H0 - TCRIT)*H0 .GT. 0.0D0) 8509 1 H0 = TCRIT - T 8510 110 JSTART = 0 8511 NHNIL = 0 8512 NST = 0 8513 NJE = 0 8514 NSLAST = 0 8515 NLI0 = 0 8516 NNI0 = 0 8517 NCFN0 = 0 8518 NCFL0 = 0 8519 NWARN = 0 8520 HU = 0.0D0 8521 NQU = 0 8522 CCMAX = 0.3D0 8523 MAXCOR = 3 8524 MSBP = 20 8525 MXNCF = 10 8526 NNI = 0 8527 NLI = 0 8528 NPS = 0 8529 NCFN = 0 8530 NCFL = 0 8531 C Initial call to F. (LF0 points to YH(*,2).) ------------------------- 8532 LF0 = LYH + NYH 8533 CALL F (NEQ, T, Y, RWORK(LF0)) 8534 NFE = 1 8535 C Load the initial value vector in YH. --------------------------------- 8536 DO 115 I = 1,N 8537 115 RWORK(I+LYH-1) = Y(I) 8538 C Load and invert the EWT array. (H is temporarily set to 1.0.) ------- 8539 NQ = 1 8540 H = 1.0D0 8541 CALL DEWSET (N, ITOL, RTOL, ATOL, RWORK(LYH), RWORK(LEWT)) 8542 DO 120 I = 1,N 8543 IF (RWORK(I+LEWT-1) .LE. 0.0D0) GO TO 621 8544 120 RWORK(I+LEWT-1) = 1.0D0/RWORK(I+LEWT-1) 8545 C----------------------------------------------------------------------- 8546 C The coding below computes the step size, H0, to be attempted on the 8547 C first step, unless the user has supplied a value for this. 8548 C First check that TOUT - T differs significantly from zero. 8549 C A scalar tolerance quantity TOL is computed, as MAX(RTOL(i)) 8550 C if this is positive, or MAX(ATOL(i)/ABS(Y(i))) otherwise, adjusted 8551 C so as to be between 100*UROUND and 1.0E-3. 8552 C Then the computed value H0 is given by.. 8553 C NEQ 8554 C H0**2 = TOL / ( w0**-2 + (1/NEQ) * Sum ( f(i)/ywt(i) )**2 ) 8555 C 1 8556 C where w0 = MAX ( ABS(T), ABS(TOUT) ), 8557 C f(i) = i-th component of initial value of f, 8558 C ywt(i) = EWT(i)/TOL (a weight for y(i)). 8559 C The sign of H0 is inferred from the initial values of TOUT and T. 8560 C----------------------------------------------------------------------- 8561 IF (H0 .NE. 0.0D0) GO TO 180 8562 TDIST = ABS(TOUT - T) 8563 W0 = MAX(ABS(T),ABS(TOUT)) 8564 IF (TDIST .LT. 2.0D0*UROUND*W0) GO TO 622 8565 TOL = RTOL(1) 8566 IF (ITOL .LE. 2) GO TO 140 8567 DO 130 I = 1,N 8568 130 TOL = MAX(TOL,RTOL(I)) 8569 140 IF (TOL .GT. 0.0D0) GO TO 160 8570 ATOLI = ATOL(1) 8571 DO 150 I = 1,N 8572 IF (ITOL .EQ. 2 .OR. ITOL .EQ. 4) ATOLI = ATOL(I) 8573 AYI = ABS(Y(I)) 8574 IF (AYI .NE. 0.0D0) TOL = MAX(TOL,ATOLI/AYI) 8575 150 CONTINUE 8576 160 TOL = MAX(TOL,100.0D0*UROUND) 8577 TOL = MIN(TOL,0.001D0) 8578 SUM = DVNORM (N, RWORK(LF0), RWORK(LEWT)) 8579 SUM = 1.0D0/(TOL*W0*W0) + TOL*SUM**2 8580 H0 = 1.0D0/SQRT(SUM) 8581 H0 = MIN(H0,TDIST) 8582 H0 = SIGN(H0,TOUT-T) 8583 C Adjust H0 if necessary to meet HMAX bound. --------------------------- 8584 180 RH = ABS(H0)*HMXI 8585 IF (RH .GT. 1.0D0) H0 = H0/RH 8586 C Load H with H0 and scale YH(*,2) by H0. ------------------------------ 8587 H = H0 8588 DO 190 I = 1,N 8589 190 RWORK(I+LF0-1) = H0*RWORK(I+LF0-1) 8590 GO TO 270 8591 C----------------------------------------------------------------------- 8592 C Block D. 8593 C The next code block is for continuation calls only (ISTATE = 2 or 3) 8594 C and is to check stop conditions before taking a step. 8595 C----------------------------------------------------------------------- 8596 200 NSLAST = NST 8597 NLI0 = NLI 8598 NNI0 = NNI 8599 NCFN0 = NCFN 8600 NCFL0 = NCFL 8601 NWARN = 0 8602 GO TO (210, 250, 220, 230, 240), ITASK 8603 210 IF ((TN - TOUT)*H .LT. 0.0D0) GO TO 250 8604 CALL DINTDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) 8605 IF (IFLAG .NE. 0) GO TO 627 8606 T = TOUT 8607 GO TO 420 8608 220 TP = TN - HU*(1.0D0 + 100.0D0*UROUND) 8609 IF ((TP - TOUT)*H .GT. 0.0D0) GO TO 623 8610 IF ((TN - TOUT)*H .LT. 0.0D0) GO TO 250 8611 GO TO 400 8612 230 TCRIT = RWORK(1) 8613 IF ((TN - TCRIT)*H .GT. 0.0D0) GO TO 624 8614 IF ((TCRIT - TOUT)*H .LT. 0.0D0) GO TO 625 8615 IF ((TN - TOUT)*H .LT. 0.0D0) GO TO 245 8616 CALL DINTDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) 8617 IF (IFLAG .NE. 0) GO TO 627 8618 T = TOUT 8619 GO TO 420 8620 240 TCRIT = RWORK(1) 8621 IF ((TN - TCRIT)*H .GT. 0.0D0) GO TO 624 8622 245 HMX = ABS(TN) + ABS(H) 8623 IHIT = ABS(TN - TCRIT) .LE. 100.0D0*UROUND*HMX 8624 IF (IHIT) GO TO 400 8625 TNEXT = TN + H*(1.0D0 + 4.0D0*UROUND) 8626 IF ((TNEXT - TCRIT)*H .LE. 0.0D0) GO TO 250 8627 H = (TCRIT - TN)*(1.0D0 - 4.0D0*UROUND) 8628 IF (ISTATE .EQ. 2) JSTART = -2 8629 C----------------------------------------------------------------------- 8630 C Block E. 8631 C The next block is normally executed for all calls and contains 8632 C the call to the one-step core integrator DSTODPK. 8633 C 8634 C This is a looping point for the integration steps. 8635 C 8636 C First check for too many steps being taken, 8637 C Check for poor Newton/Krylov method performance, update EWT (if not 8638 C at start of problem), check for too much accuracy being requested, 8639 C and check for H below the roundoff level in T. 8640 C----------------------------------------------------------------------- 8641 250 CONTINUE 8642 IF ((NST-NSLAST) .GE. MXSTEP) GO TO 500 8643 NSTD = NST - NSLAST 8644 NNID = NNI - NNI0 8645 IF (NSTD .LT. 10 .OR. NNID .EQ. 0) GO TO 255 8646 AVDIM = REAL(NLI - NLI0)/REAL(NNID) 8647 RCFN = REAL(NCFN - NCFN0)/REAL(NSTD) 8648 RCFL = REAL(NCFL - NCFL0)/REAL(NNID) 8649 LAVD = AVDIM .GT. (MAXL - 0.05D0) 8650 LCFN = RCFN .GT. 0.9D0 8651 LCFL = RCFL .GT. 0.9D0 8652 LWARN = LAVD .OR. LCFN .OR. LCFL 8653 IF (.NOT.LWARN) GO TO 255 8654 NWARN = NWARN + 1 8655 IF (NWARN .GT. 10) GO TO 255 8656 IF (LAVD) THEN 8657 MSG='DLSODPK- Warning. Poor iterative algorithm performance seen ' 8658 CALL XERRWD (MSG, 60, 111, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 8659 ENDIF 8660 IF (LAVD) THEN 8661 MSG=' at T = R1 by average no. of linear iterations = R2 ' 8662 CALL XERRWD (MSG, 60, 111, 0, 0, 0, 0, 2, TN, AVDIM) 8663 ENDIF 8664 IF (LCFN) THEN 8665 MSG='DLSODPK- Warning. Poor iterative algorithm performance seen ' 8666 CALL XERRWD (MSG, 60, 112, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 8667 ENDIF 8668 IF (LCFN) THEN 8669 MSG=' at T = R1 by nonlinear convergence failure rate = R2 ' 8670 CALL XERRWD (MSG, 60, 112, 0, 0, 0, 0, 2, TN, RCFN) 8671 ENDIF 8672 IF (LCFL) THEN 8673 MSG='DLSODPK- Warning. Poor iterative algorithm performance seen ' 8674 CALL XERRWD (MSG, 60, 113, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 8675 ENDIF 8676 IF (LCFL) THEN 8677 MSG=' at T = R1 by linear convergence failure rate = R2 ' 8678 CALL XERRWD (MSG, 60, 113, 0, 0, 0, 0, 2, TN, RCFL) 8679 ENDIF 8680 255 CONTINUE 8681 CALL DEWSET (N, ITOL, RTOL, ATOL, RWORK(LYH), RWORK(LEWT)) 8682 DO 260 I = 1,N 8683 IF (RWORK(I+LEWT-1) .LE. 0.0D0) GO TO 510 8684 260 RWORK(I+LEWT-1) = 1.0D0/RWORK(I+LEWT-1) 8685 270 TOLSF = UROUND*DVNORM (N, RWORK(LYH), RWORK(LEWT)) 8686 IF (TOLSF .LE. 1.0D0) GO TO 280 8687 TOLSF = TOLSF*2.0D0 8688 IF (NST .EQ. 0) GO TO 626 8689 GO TO 520 8690 280 IF ((TN + H) .NE. TN) GO TO 290 8691 NHNIL = NHNIL + 1 8692 IF (NHNIL .GT. MXHNIL) GO TO 290 8693 MSG = 'DLSODPK- Warning..Internal T(=R1) and H(=R2) are ' 8694 CALL XERRWD (MSG, 50, 101, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 8695 MSG=' such that in the machine, T + H = T on the next step ' 8696 CALL XERRWD (MSG, 60, 101, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 8697 MSG = ' (H = step size). Solver will continue anyway.' 8698 CALL XERRWD (MSG, 50, 101, 0, 0, 0, 0, 2, TN, H) 8699 IF (NHNIL .LT. MXHNIL) GO TO 290 8700 MSG = 'DLSODPK- Above warning has been issued I1 times. ' 8701 CALL XERRWD (MSG, 50, 102, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 8702 MSG = ' It will not be issued again for this problem.' 8703 CALL XERRWD (MSG, 50, 102, 0, 1, MXHNIL, 0, 0, 0.0D0, 0.0D0) 8704 290 CONTINUE 8705 C----------------------------------------------------------------------- 8706 C CALL DSTODPK(NEQ,Y,YH,NYH,YH,EWT,SAVF,SAVX,ACOR,WM,IWM,F,JAC,PSOL) 8707 C----------------------------------------------------------------------- 8708 CALL DSTODPK (NEQ, Y, RWORK(LYH), NYH, RWORK(LYH), RWORK(LEWT), 8709 1 RWORK(LSAVF), RWORK(LSAVX), RWORK(LACOR), RWORK(LWM), 8710 2 IWORK(LIWM), F, JAC, PSOL) 8711 KGO = 1 - KFLAG 8712 GO TO (300, 530, 540, 550), KGO 8713 C----------------------------------------------------------------------- 8714 C Block F. 8715 C The following block handles the case of a successful return from the 8716 C core integrator (KFLAG = 0). Test for stop conditions. 8717 C----------------------------------------------------------------------- 8718 300 INIT = 1 8719 GO TO (310, 400, 330, 340, 350), ITASK 8720 C ITASK = 1. If TOUT has been reached, interpolate. ------------------- 8721 310 IF ((TN - TOUT)*H .LT. 0.0D0) GO TO 250 8722 CALL DINTDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) 8723 T = TOUT 8724 GO TO 420 8725 C ITASK = 3. Jump to exit if TOUT was reached. ------------------------ 8726 330 IF ((TN - TOUT)*H .GE. 0.0D0) GO TO 400 8727 GO TO 250 8728 C ITASK = 4. See if TOUT or TCRIT was reached. Adjust H if necessary. 8729 340 IF ((TN - TOUT)*H .LT. 0.0D0) GO TO 345 8730 CALL DINTDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) 8731 T = TOUT 8732 GO TO 420 8733 345 HMX = ABS(TN) + ABS(H) 8734 IHIT = ABS(TN - TCRIT) .LE. 100.0D0*UROUND*HMX 8735 IF (IHIT) GO TO 400 8736 TNEXT = TN + H*(1.0D0 + 4.0D0*UROUND) 8737 IF ((TNEXT - TCRIT)*H .LE. 0.0D0) GO TO 250 8738 H = (TCRIT - TN)*(1.0D0 - 4.0D0*UROUND) 8739 JSTART = -2 8740 GO TO 250 8741 C ITASK = 5. see if TCRIT was reached and jump to exit. --------------- 8742 350 HMX = ABS(TN) + ABS(H) 8743 IHIT = ABS(TN - TCRIT) .LE. 100.0D0*UROUND*HMX 8744 C----------------------------------------------------------------------- 8745 C Block G. 8746 C The following block handles all successful returns from DLSODPK. 8747 C If ITASK .ne. 1, Y is loaded from YH and T is set accordingly. 8748 C ISTATE is set to 2, and the optional outputs are loaded into the 8749 C work arrays before returning. 8750 C----------------------------------------------------------------------- 8751 400 DO 410 I = 1,N 8752 410 Y(I) = RWORK(I+LYH-1) 8753 T = TN 8754 IF (ITASK .NE. 4 .AND. ITASK .NE. 5) GO TO 420 8755 IF (IHIT) T = TCRIT 8756 420 ISTATE = 2 8757 RWORK(11) = HU 8758 RWORK(12) = H 8759 RWORK(13) = TN 8760 IWORK(11) = NST 8761 IWORK(12) = NFE 8762 IWORK(13) = NJE 8763 IWORK(14) = NQU 8764 IWORK(15) = NQ 8765 IWORK(19) = NNI 8766 IWORK(20) = NLI 8767 IWORK(21) = NPS 8768 IWORK(22) = NCFN 8769 IWORK(23) = NCFL 8770 RETURN 8771 C----------------------------------------------------------------------- 8772 C Block H. 8773 C The following block handles all unsuccessful returns other than 8774 C those for illegal input. First the error message routine is called. 8775 C If there was an error test or convergence test failure, IMXER is set. 8776 C Then Y is loaded from YH and T is set to TN. 8777 C The optional outputs are loaded into the work arrays before returning. 8778 C----------------------------------------------------------------------- 8779 C The maximum number of steps was taken before reaching TOUT. ---------- 8780 500 MSG = 'DLSODPK- At current T (=R1), MXSTEP (=I1) steps ' 8781 CALL XERRWD (MSG, 50, 201, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 8782 MSG = ' taken on this call before reaching TOUT ' 8783 CALL XERRWD (MSG, 50, 201, 0, 1, MXSTEP, 0, 1, TN, 0.0D0) 8784 ISTATE = -1 8785 GO TO 580 8786 C EWT(i) .le. 0.0 for some i (not at start of problem). ---------------- 8787 510 EWTI = RWORK(LEWT+I-1) 8788 MSG = 'DLSODPK- At T (=R1), EWT(I1) has become R2.le.0. ' 8789 CALL XERRWD (MSG, 50, 202, 0, 1, I, 0, 2, TN, EWTI) 8790 ISTATE = -6 8791 GO TO 580 8792 C Too much accuracy requested for machine precision. ------------------- 8793 520 MSG = 'DLSODPK- At T (=R1), too much accuracy requested ' 8794 CALL XERRWD (MSG, 50, 203, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 8795 MSG = ' for precision of machine.. See TOLSF (=R2) ' 8796 CALL XERRWD (MSG, 50, 203, 0, 0, 0, 0, 2, TN, TOLSF) 8797 RWORK(14) = TOLSF 8798 ISTATE = -2 8799 GO TO 580 8800 C KFLAG = -1. Error test failed repeatedly or with ABS(H) = HMIN. ----- 8801 530 MSG = 'DLSODPK- At T(=R1), step size H(=R2), the error ' 8802 CALL XERRWD (MSG, 50, 204, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 8803 MSG = ' test failed repeatedly or with ABS(H) = HMIN' 8804 CALL XERRWD (MSG, 50, 204, 0, 0, 0, 0, 2, TN, H) 8805 ISTATE = -4 8806 GO TO 560 8807 C KFLAG = -2. Convergence failed repeatedly or with ABS(H) = HMIN. ---- 8808 540 MSG = 'DLSODPK- At T (=R1) and step size H (=R2), the ' 8809 CALL XERRWD (MSG, 50, 205, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 8810 MSG = ' corrector convergence failed repeatedly ' 8811 CALL XERRWD (MSG, 50, 205, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 8812 MSG = ' or with ABS(H) = HMIN ' 8813 CALL XERRWD (MSG, 30, 205, 0, 0, 0, 0, 2, TN, H) 8814 ISTATE = -5 8815 GO TO 560 8816 C KFLAG = -3. Unrecoverable error from PSOL. -------------------------- 8817 550 MSG = 'DLSODPK- At T (=R1) an unrecoverable error return' 8818 CALL XERRWD (MSG, 50, 205, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 8819 MSG = ' was made from Subroutine PSOL ' 8820 CALL XERRWD (MSG, 40, 205, 0, 0, 0, 0, 1, TN, 0.0D0) 8821 ISTATE = -7 8822 GO TO 580 8823 C Compute IMXER if relevant. ------------------------------------------- 8824 560 BIG = 0.0D0 8825 IMXER = 1 8826 DO 570 I = 1,N 8827 SIZE = ABS(RWORK(I+LACOR-1)*RWORK(I+LEWT-1)) 8828 IF (BIG .GE. SIZE) GO TO 570 8829 BIG = SIZE 8830 IMXER = I 8831 570 CONTINUE 8832 IWORK(16) = IMXER 8833 C Set Y vector, T, and optional outputs. ------------------------------- 8834 580 DO 590 I = 1,N 8835 590 Y(I) = RWORK(I+LYH-1) 8836 T = TN 8837 RWORK(11) = HU 8838 RWORK(12) = H 8839 RWORK(13) = TN 8840 IWORK(11) = NST 8841 IWORK(12) = NFE 8842 IWORK(13) = NJE 8843 IWORK(14) = NQU 8844 IWORK(15) = NQ 8845 IWORK(19) = NNI 8846 IWORK(20) = NLI 8847 IWORK(21) = NPS 8848 IWORK(22) = NCFN 8849 IWORK(23) = NCFL 8850 RETURN 8851 C----------------------------------------------------------------------- 8852 C Block I. 8853 C The following block handles all error returns due to illegal input 8854 C (ISTATE = -3), as detected before calling the core integrator. 8855 C First the error message routine is called. If the illegal input 8856 C is a negative ISTATE, the run is aborted (apparent infinite loop). 8857 C----------------------------------------------------------------------- 8858 601 MSG = 'DLSODPK- ISTATE(=I1) illegal.' 8859 CALL XERRWD (MSG, 30, 1, 0, 1, ISTATE, 0, 0, 0.0D0, 0.0D0) 8860 IF (ISTATE .LT. 0) GO TO 800 8861 GO TO 700 8862 602 MSG = 'DLSODPK- ITASK (=I1) illegal.' 8863 CALL XERRWD (MSG, 30, 2, 0, 1, ITASK, 0, 0, 0.0D0, 0.0D0) 8864 GO TO 700 8865 603 MSG = 'DLSODPK- ISTATE.gt.1 but DLSODPK not initialized.' 8866 CALL XERRWD (MSG, 50, 3, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 8867 GO TO 700 8868 604 MSG = 'DLSODPK- NEQ (=I1) .lt. 1 ' 8869 CALL XERRWD (MSG, 30, 4, 0, 1, NEQ(1), 0, 0, 0.0D0, 0.0D0) 8870 GO TO 700 8871 605 MSG = 'DLSODPK- ISTATE = 3 and NEQ increased (I1 to I2).' 8872 CALL XERRWD (MSG, 50, 5, 0, 2, N, NEQ(1), 0, 0.0D0, 0.0D0) 8873 GO TO 700 8874 606 MSG = 'DLSODPK- ITOL (=I1) illegal. ' 8875 CALL XERRWD (MSG, 30, 6, 0, 1, ITOL, 0, 0, 0.0D0, 0.0D0) 8876 GO TO 700 8877 607 MSG = 'DLSODPK- IOPT (=I1) illegal. ' 8878 CALL XERRWD (MSG, 30, 7, 0, 1, IOPT, 0, 0, 0.0D0, 0.0D0) 8879 GO TO 700 8880 608 MSG = 'DLSODPK- MF (=I1) illegal. ' 8881 CALL XERRWD (MSG, 30, 8, 0, 1, MF, 0, 0, 0.0D0, 0.0D0) 8882 GO TO 700 8883 611 MSG = 'DLSODPK- MAXORD (=I1) .lt. 0 ' 8884 CALL XERRWD (MSG, 30, 11, 0, 1, MAXORD, 0, 0, 0.0D0, 0.0D0) 8885 GO TO 700 8886 612 MSG = 'DLSODPK- MXSTEP (=I1) .lt. 0 ' 8887 CALL XERRWD (MSG, 30, 12, 0, 1, MXSTEP, 0, 0, 0.0D0, 0.0D0) 8888 GO TO 700 8889 613 MSG = 'DLSODPK- MXHNIL (=I1) .lt. 0 ' 8890 CALL XERRWD (MSG, 30, 13, 0, 1, MXHNIL, 0, 0, 0.0D0, 0.0D0) 8891 GO TO 700 8892 614 MSG = 'DLSODPK- TOUT (=R1) behind T (=R2) ' 8893 CALL XERRWD (MSG, 40, 14, 0, 0, 0, 0, 2, TOUT, T) 8894 MSG = ' Integration direction is given by H0 (=R1) ' 8895 CALL XERRWD (MSG, 50, 14, 0, 0, 0, 0, 1, H0, 0.0D0) 8896 GO TO 700 8897 615 MSG = 'DLSODPK- HMAX (=R1) .lt. 0.0 ' 8898 CALL XERRWD (MSG, 30, 15, 0, 0, 0, 0, 1, HMAX, 0.0D0) 8899 GO TO 700 8900 616 MSG = 'DLSODPK- HMIN (=R1) .lt. 0.0 ' 8901 CALL XERRWD (MSG, 30, 16, 0, 0, 0, 0, 1, HMIN, 0.0D0) 8902 GO TO 700 8903 617 MSG='DLSODPK- RWORK length needed, LENRW(=I1), exceeds LRW(=I2) ' 8904 CALL XERRWD (MSG, 60, 17, 0, 2, LENRW, LRW, 0, 0.0D0, 0.0D0) 8905 GO TO 700 8906 618 MSG='DLSODPK- IWORK length needed, LENIW(=I1), exceeds LIW(=I2) ' 8907 CALL XERRWD (MSG, 60, 18, 0, 2, LENIW, LIW, 0, 0.0D0, 0.0D0) 8908 GO TO 700 8909 619 MSG = 'DLSODPK- RTOL(I1) is R1 .lt. 0.0 ' 8910 CALL XERRWD (MSG, 40, 19, 0, 1, I, 0, 1, RTOLI, 0.0D0) 8911 GO TO 700 8912 620 MSG = 'DLSODPK- ATOL(I1) is R1 .lt. 0.0 ' 8913 CALL XERRWD (MSG, 40, 20, 0, 1, I, 0, 1, ATOLI, 0.0D0) 8914 GO TO 700 8915 621 EWTI = RWORK(LEWT+I-1) 8916 MSG = 'DLSODPK- EWT(I1) is R1 .le. 0.0 ' 8917 CALL XERRWD (MSG, 40, 21, 0, 1, I, 0, 1, EWTI, 0.0D0) 8918 GO TO 700 8919 622 MSG='DLSODPK- TOUT(=R1) too close to T(=R2) to start integration.' 8920 CALL XERRWD (MSG, 60, 22, 0, 0, 0, 0, 2, TOUT, T) 8921 GO TO 700 8922 623 MSG='DLSODPK- ITASK = I1 and TOUT (=R1) behind TCUR - HU (= R2) ' 8923 CALL XERRWD (MSG, 60, 23, 0, 1, ITASK, 0, 2, TOUT, TP) 8924 GO TO 700 8925 624 MSG='DLSODPK- ITASK = 4 or 5 and TCRIT (=R1) behind TCUR (=R2) ' 8926 CALL XERRWD (MSG, 60, 24, 0, 0, 0, 0, 2, TCRIT, TN) 8927 GO TO 700 8928 625 MSG='DLSODPK- ITASK = 4 or 5 and TCRIT (=R1) behind TOUT (=R2) ' 8929 CALL XERRWD (MSG, 60, 25, 0, 0, 0, 0, 2, TCRIT, TOUT) 8930 GO TO 700 8931 626 MSG = 'DLSODPK- At start of problem, too much accuracy ' 8932 CALL XERRWD (MSG, 50, 26, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 8933 MSG=' requested for precision of machine.. See TOLSF (=R1) ' 8934 CALL XERRWD (MSG, 60, 26, 0, 0, 0, 0, 1, TOLSF, 0.0D0) 8935 RWORK(14) = TOLSF 8936 GO TO 700 8937 627 MSG = 'DLSODPK- Trouble in DINTDY. ITASK = I1, TOUT = R1' 8938 CALL XERRWD (MSG, 50, 27, 0, 1, ITASK, 0, 1, TOUT, 0.0D0) 8939 C 8940 700 ISTATE = -3 8941 RETURN 8942 C 8943 800 MSG = 'DLSODPK- Run aborted.. apparent infinite loop. ' 8944 CALL XERRWD (MSG, 50, 303, 2, 0, 0, 0, 0, 0.0D0, 0.0D0) 8945 RETURN 8946 C----------------------- End of Subroutine DLSODPK --------------------- 8947 END 8948 *DECK DLSODKR 8949 SUBROUTINE DLSODKR (F, NEQ, Y, T, TOUT, ITOL, RTOL, ATOL, ITASK, 8950 1 ISTATE, IOPT, RWORK, LRW, IWORK, LIW, JAC, PSOL, 8951 2 MF, G, NG, JROOT) 8952 EXTERNAL F, JAC, PSOL, G 8953 INTEGER NEQ, ITOL, ITASK, ISTATE, IOPT, LRW, IWORK, LIW, MF, 8954 1 NG, JROOT 8955 DOUBLE PRECISION Y, T, TOUT, RTOL, ATOL, RWORK 8956 DIMENSION NEQ(*), Y(*), RTOL(*), ATOL(*), RWORK(LRW), IWORK(LIW), 8957 1 JROOT(*) 8958 C----------------------------------------------------------------------- 8959 C This is the 18 November 2003 version of 8960 C DLSODKR: Livermore Solver for Ordinary Differential equations, 8961 C with preconditioned Krylov iteration methods for the 8962 C Newton correction linear systems, and with Rootfinding. 8963 C 8964 C This version is in double precision. 8965 C 8966 C DLSODKR solves the initial value problem for stiff or nonstiff 8967 C systems of first order ODEs, 8968 C dy/dt = f(t,y) , or, in component form, 8969 C dy(i)/dt = f(i) = f(i,t,y(1),y(2),...,y(NEQ)) (i = 1,...,NEQ). 8970 C At the same time, it locates the roots of any of a set of functions 8971 C g(i) = g(i,t,y(1),...,y(NEQ)) (i = 1,...,ng). 8972 C 8973 C----------------------------------------------------------------------- 8974 C Introduction. 8975 C 8976 C This is a modification of the DLSODE package, and differs from it 8977 C in five ways: 8978 C (a) It uses various preconditioned Krylov subspace iteration methods 8979 C for the linear algebraic systems that arise in the case of stiff 8980 C systems. See the introductory notes below. 8981 C (b) It does automatic switching between functional (fixpoint) 8982 C iteration and Newton iteration in the corrector iteration. 8983 C (c) It finds the root of at least one of a set of constraint 8984 C functions g(i) of the independent and dependent variables. 8985 C It finds only those roots for which some g(i), as a function 8986 C of t, changes sign in the interval of integration. 8987 C It then returns the solution at the root, if that occurs 8988 C sooner than the specified stop condition, and otherwise returns 8989 C the solution according the specified stop condition. 8990 C (d) It supplies to JAC an input flag, JOK, which indicates whether 8991 C JAC may (optionally) bypass the evaluation of Jacobian matrix data 8992 C and instead process saved data (with the current value of scalar hl0). 8993 C (e) It contains a new subroutine that calculates the initial step 8994 C size to be attempted. 8995 C 8996 C 8997 C Introduction to the Krylov methods in DLSODKR: 8998 C 8999 C The linear systems that must be solved have the form 9000 C A * x = b , where A = identity - hl0 * (df/dy) . 9001 C Here hl0 is a scalar, and df/dy is the Jacobian matrix of partial 9002 C derivatives of f (NEQ by NEQ). 9003 C 9004 C The particular Krylov method is chosen by setting the second digit, 9005 C MITER, in the method flag MF. 9006 C Currently, the values of MITER have the following meanings: 9007 C 9008 C MITER = 1 means the Scaled Preconditioned Incomplete 9009 C Orthogonalization Method (SPIOM). 9010 C 9011 C 2 means an incomplete version of the preconditioned scaled 9012 C Generalized Minimal Residual method (SPIGMR). 9013 C This is the best choice in general. 9014 C 9015 C 3 means the Preconditioned Conjugate Gradient method (PCG). 9016 C Recommended only when df/dy is symmetric or nearly so. 9017 C 9018 C 4 means the scaled Preconditioned Conjugate Gradient method 9019 C (PCGS). Recommended only when D-inverse * df/dy * D is 9020 C symmetric or nearly so, where D is the diagonal scaling 9021 C matrix with elements 1/EWT(i) (see RTOL/ATOL description). 9022 C 9023 C 9 means that only a user-supplied matrix P (approximating A) 9024 C will be used, with no Krylov iteration done. This option 9025 C allows the user to provide the complete linear system 9026 C solution algorithm, if desired. 9027 C 9028 C The user can apply preconditioning to the linear system A*x = b, 9029 C by means of arbitrary matrices (the preconditioners). 9030 C In the case of SPIOM and SPIGMR, one can apply left and right 9031 C preconditioners P1 and P2, and the basic iterative method is then 9032 C applied to the matrix (P1-inverse)*A*(P2-inverse) instead of to the 9033 C matrix A. The product P1*P2 should be an approximation to matrix A 9034 C such that linear systems with P1 or P2 are easier to solve than with 9035 C A. Preconditioning from the left only or right only means using 9036 C P2 = identity or P1 = identity, respectively. 9037 C In the case of the PCG and PCGS methods, there is only one 9038 C preconditioner matrix P (but it can be the product of more than one). 9039 C It should approximate the matrix A but allow for relatively 9040 C easy solution of linear systems with coefficient matrix P. 9041 C For PCG, P should be positive definite symmetric, or nearly so, 9042 C and for PCGS, the scaled preconditioner D-inverse * P * D 9043 C should be symmetric or nearly so. 9044 C If the Jacobian J = df/dy splits in a natural way into a sum 9045 C J = J1 + J2, then one possible choice of preconditioners is 9046 C P1 = identity - hl0 * J1 and P2 = identity - hl0 * J2 9047 C provided each of these is easy to solve (or approximately solve). 9048 C 9049 C----------------------------------------------------------------------- 9050 C References: 9051 C 1. Peter N. Brown and Alan C. Hindmarsh, Reduced Storage Matrix 9052 C Methods in Stiff ODE Systems, J. Appl. Math. & Comp., 31 (1989), 9053 C pp. 40-91; also L.L.N.L. Report UCRL-95088, Rev. 1, June 1987. 9054 C 2. Alan C. Hindmarsh, ODEPACK, A Systematized Collection of ODE 9055 C Solvers, in Scientific Computing, R. S. Stepleman et al. (Eds.), 9056 C North-Holland, Amsterdam, 1983, pp. 55-64. 9057 C----------------------------------------------------------------------- 9058 C Authors: Alan C. Hindmarsh and Peter N. Brown 9059 C Center for Applied Scientific Computing, L-561 9060 C Lawrence Livermore National Laboratory 9061 C Livermore, CA 94551 9062 C----------------------------------------------------------------------- 9063 C Summary of Usage. 9064 C 9065 C Communication between the user and the DLSODKR package, for normal 9066 C situations, is summarized here. This summary describes only a subset 9067 C of the full set of options available. See the full description for 9068 C details, including optional communication, nonstandard options, 9069 C and instructions for special situations. See also the demonstration 9070 C program distributed with this solver. 9071 C 9072 C A. First provide a subroutine of the form: 9073 C SUBROUTINE F (NEQ, T, Y, YDOT) 9074 C DOUBLE PRECISION T, Y(*), YDOT(*) 9075 C which supplies the vector function f by loading YDOT(i) with f(i). 9076 C 9077 C B. Provide a subroutine of the form: 9078 C SUBROUTINE G (NEQ, T, Y, NG, GOUT) 9079 C DOUBLE PRECISION T, Y(*), GOUT(NG) 9080 C which supplies the vector function g by loading GOUT(i) with 9081 C g(i), the i-th constraint function whose root is sought. 9082 C 9083 C C. Next determine (or guess) whether or not the problem is stiff. 9084 C Stiffness occurs when the Jacobian matrix df/dy has an eigenvalue 9085 C whose real part is negative and large in magnitude, compared to the 9086 C reciprocal of the t span of interest. If the problem is nonstiff, 9087 C use a method flag MF = 10. If it is stiff, MF should be between 21 9088 C and 24, or possibly 29. MF = 22 is generally the best choice. 9089 C Use 23 or 24 only if symmetry is present. Use MF = 29 if the 9090 C complete linear system solution is to be provided by the user. 9091 C The following four parameters must also be set. 9092 C IWORK(1) = LWP = length of real array WP for preconditioning. 9093 C IWORK(2) = LIWP = length of integer array IWP for preconditioning. 9094 C IWORK(3) = JPRE = preconditioner type flag: 9095 C = 0 for no preconditioning (P1 = P2 = P = identity) 9096 C = 1 for left-only preconditioning (P2 = identity) 9097 C = 2 for right-only preconditioning (P1 = identity) 9098 C = 3 for two-sided preconditioning (and PCG or PCGS) 9099 C IWORK(4) = JACFLG = flag for whether JAC is called. 9100 C = 0 if JAC is not to be called, 9101 C = 1 if JAC is to be called. 9102 C Use JACFLG = 1 if JAC computes any nonconstant data for use in 9103 C preconditioning, such as Jacobian elements. 9104 C The arrays WP and IWP are work arrays under the user's control, 9105 C for use in the routines that perform preconditioning operations. 9106 C 9107 C D. If the problem is stiff, you must supply two routines that deal 9108 C with the preconditioning of the linear systems to be solved. 9109 C These are as follows: 9110 C 9111 C SUBROUTINE JAC (F, NEQ, T, Y, YSV, REWT, FTY,V,HL0,JOK,WP,IWP,IER) 9112 C DOUBLE PRECISION T, Y(*), YSV(*), REWT(*), FTY(*), V(*), HL0,WP(*) 9113 C INTEGER IWP(*) 9114 C This routine must evaluate and preprocess any parts of the 9115 C Jacobian matrix df/dy involved in the preconditioners P1, P2, P. 9116 C The Y and FTY arrays contain the current values of y and f(t,y), 9117 C respectively, and YSV also contains the current value of y. 9118 C The array V is work space of length NEQ. 9119 C JAC must multiply all computed Jacobian elements by the scalar 9120 C -HL0, add the identity matrix, and do any factorization 9121 C operations called for, in preparation for solving linear systems 9122 C with a coefficient matrix of P1, P2, or P. The matrix P1*P2 or P 9123 C should be an approximation to identity - hl0 * (df/dy). 9124 C JAC should return IER = 0 if successful, and IER .ne. 0 if not. 9125 C (If IER .ne. 0, a smaller time step will be tried.) 9126 C JAC may alter Y and V, but not YSV, REWT, FTY, or HL0. 9127 C The JOK argument can be ignored (or see full description below). 9128 C 9129 C SUBROUTINE PSOL (NEQ, T, Y, FTY, WK, HL0, WP, IWP, B, LR, IER) 9130 C DOUBLE PRECISION T, Y(*), FTY(*), WK(*), HL0, WP(*), B(*) 9131 C INTEGER IWP(*) 9132 C This routine must solve a linear system with B as right-hand 9133 C side and one of the preconditioning matrices, P1, P2, or P, as 9134 C coefficient matrix, and return the solution vector in B. 9135 C LR is a flag concerning left vs right preconditioning, input 9136 C to PSOL. PSOL is to use P1 if LR = 1 and P2 if LR = 2. 9137 C In the case of the PCG or PCGS method, LR will be 3, and PSOL 9138 C should solve the system P*x = B with the preconditioner matrix P. 9139 C In the case MF = 29 (no Krylov iteration), LR will be 0, 9140 C and PSOL is to return in B the desired approximate solution 9141 C to A * x = B, where A = identity - hl0 * (df/dy). 9142 C PSOL can use data generated in the JAC routine and stored in 9143 C WP and IWP. WK is a work array of length NEQ. 9144 C The argument HL0 is the current value of the scalar appearing 9145 C in the linear system. If the old value, at the time of the last 9146 C JAC call, is needed, it must have been saved by JAC in WP. 9147 C on return, PSOL should set the error flag IER as follows: 9148 C IER = 0 if PSOL was successful, 9149 C IER .gt. 0 if a recoverable error occurred, meaning that the 9150 C time step will be retried, 9151 C IER .lt. 0 if an unrecoverable error occurred, meaning that the 9152 C solver is to stop immediately. 9153 C 9154 C E. Write a main program which calls Subroutine DLSODKR once for 9155 C each point at which answers are desired. This should also provide 9156 C for possible use of logical unit 6 for output of error messages 9157 C by DLSODKR. On the first call to DLSODKR, supply arguments as 9158 C follows: 9159 C F = name of subroutine for right-hand side vector f. 9160 C This name must be declared External in calling program. 9161 C NEQ = number of first order ODEs. 9162 C Y = array of initial values, of length NEQ. 9163 C T = the initial value of the independent variable. 9164 C TOUT = first point where output is desired (.ne. T). 9165 C ITOL = 1 or 2 according as ATOL (below) is a scalar or array. 9166 C RTOL = relative tolerance parameter (scalar). 9167 C ATOL = absolute tolerance parameter (scalar or array). 9168 C The estimated local error in y(i) will be controlled so as 9169 C to be roughly less (in magnitude) than 9170 C EWT(i) = RTOL*ABS(Y(i)) + ATOL if ITOL = 1, or 9171 C EWT(i) = RTOL*ABS(Y(i)) + ATOL(i) if ITOL = 2. 9172 C Thus the local error test passes if, in each component, 9173 C either the absolute error is less than ATOL (or ATOL(i)), 9174 C or the relative error is less than RTOL. 9175 C Use RTOL = 0.0 for pure absolute error control, and 9176 C use ATOL = 0.0 (or ATOL(i) = 0.0) for pure relative error 9177 C control. Caution: Actual (global) errors may exceed these 9178 C local tolerances, so choose them conservatively. 9179 C ITASK = 1 for normal computation of output values of y at t = TOUT. 9180 C ISTATE = integer flag (input and output). Set ISTATE = 1. 9181 C IOPT = 0 to indicate no optional inputs used. 9182 C RWORK = real work array of length at least: 9183 C 20 + 16*NEQ + 3*NG for MF = 10, 9184 C 45 + 17*NEQ + 3*NG + LWP for MF = 21, 9185 C 61 + 17*NEQ + 3*NG + LWP for MF = 22, 9186 C 20 + 15*NEQ + 3*NG + LWP for MF = 23 or 24, 9187 C 20 + 12*NEQ + 3*NG + LWP for MF = 29. 9188 C LRW = declared length of RWORK (in user's dimension). 9189 C IWORK = integer work array of length at least: 9190 C 30 for MF = 10, 9191 C 35 + LIWP for MF = 21, 9192 C 30 + LIWP for MF = 22, 23, 24, or 29. 9193 C LIW = declared length of IWORK (in user's dimension). 9194 C JAC,PSOL = names of subroutines for preconditioning. 9195 C These names must be declared External in the calling program. 9196 C MF = method flag. Standard values are: 9197 C 10 for nonstiff (Adams) method. 9198 C 21 for stiff (BDF) method, with preconditioned SIOM. 9199 C 22 for stiff method, with preconditioned GMRES method. 9200 C 23 for stiff method, with preconditioned CG method. 9201 C 24 for stiff method, with scaled preconditioned CG method. 9202 C 29 for stiff method, with user's PSOL routine only. 9203 C G = name of subroutine for constraint functions, whose 9204 C roots are desired during the integration. 9205 C This name must be declared External in calling program. 9206 C NG = number of constraint functions g(i). If there are none, 9207 C set NG = 0, and pass a dummy name for G. 9208 C JROOT = integer array of length NG for output of root information. 9209 C See next paragraph. 9210 C Note that the main program must declare arrays Y, RWORK, IWORK, 9211 C JROOT, and possibly ATOL. 9212 C 9213 C F. The output from the first call (or any call) is: 9214 C Y = array of computed values of y(t) vector. 9215 C T = corresponding value of independent variable (normally TOUT). 9216 C ISTATE = 2 or 3 if DLSODKR was successful, negative otherwise. 9217 C 2 means no root was found, and TOUT was reached as desired. 9218 C 3 means a root was found prior to reaching TOUT. 9219 C -1 means excess work done on this call (perhaps wrong MF). 9220 C -2 means excess accuracy requested (tolerances too small). 9221 C -3 means illegal input detected (see printed message). 9222 C -4 means repeated error test failures (check all inputs). 9223 C -5 means repeated convergence failures (perhaps bad JAC 9224 C or PSOL routine supplied or wrong choice of MF or 9225 C tolerances, or this solver is inappropriate). 9226 C -6 means error weight became zero during problem. (Solution 9227 C component i vanished, and ATOL or ATOL(i) = 0.) 9228 C -7 means an unrecoverable error occurred in PSOL. 9229 C JROOT = array showing roots found if ISTATE = 3 on return. 9230 C JROOT(i) = 1 if g(i) has a root at T, or 0 otherwise. 9231 C 9232 C G. To continue the integration after a successful return, proceed 9233 C as follows: 9234 C (a) If ISTATE = 2 on return, reset TOUT and call DLSODKR again. 9235 C (b) If ISTATE = 3 on return, reset ISTATE to 2 and call DLSODKR again. 9236 C In either case, no other parameters need be reset. 9237 C 9238 C----------------------------------------------------------------------- 9239 C----------------------------------------------------------------------- 9240 C Full Description of User Interface to DLSODKR. 9241 C 9242 C The user interface to DLSODKR consists of the following parts. 9243 C 9244 C 1. The call sequence to Subroutine DLSODKR, which is a driver 9245 C routine for the solver. This includes descriptions of both 9246 C the call sequence arguments and of user-supplied routines. 9247 C Following these descriptions is a description of 9248 C optional inputs available through the call sequence, and then 9249 C a description of optional outputs (in the work arrays). 9250 C 9251 C 2. Descriptions of other routines in the DLSODKR package that may be 9252 C (optionally) called by the user. These provide the ability to 9253 C alter error message handling, save and restore the internal 9254 C Common, and obtain specified derivatives of the solution y(t). 9255 C 9256 C 3. Descriptions of Common blocks to be declared in overlay 9257 C or similar environments, or to be saved when doing an interrupt 9258 C of the problem and continued solution later. 9259 C 9260 C 4. Description of two routines in the DLSODKR package, either of 9261 C which the user may replace with his/her own version, if desired. 9262 C These relate to the measurement of errors. 9263 C 9264 C----------------------------------------------------------------------- 9265 C Part 1. Call Sequence. 9266 C 9267 C The call sequence parameters used for input only are 9268 C F, NEQ, TOUT, ITOL, RTOL, ATOL, ITASK, IOPT, LRW, LIW, JAC, PSOL, MF, 9269 C G, and NG, 9270 C that used only for output is JROOT, 9271 C and those used for both input and output are 9272 C Y, T, ISTATE. 9273 C The work arrays RWORK and IWORK are also used for conditional and 9274 C optional inputs and optional outputs. (The term output here refers 9275 C to the return from Subroutine DLSODKR to the user's calling program.) 9276 C 9277 C The legality of input parameters will be thoroughly checked on the 9278 C initial call for the problem, but not checked thereafter unless a 9279 C change in input parameters is flagged by ISTATE = 3 on input. 9280 C 9281 C The descriptions of the call arguments are as follows. 9282 C 9283 C F = the name of the user-supplied subroutine defining the 9284 C ODE system. The system must be put in the first-order 9285 C form dy/dt = f(t,y), where f is a vector-valued function 9286 C of the scalar t and the vector y. Subroutine F is to 9287 C compute the function f. It is to have the form 9288 C SUBROUTINE F (NEQ, T, Y, YDOT) 9289 C DOUBLE PRECISION T, Y(*), YDOT(*) 9290 C where NEQ, T, and Y are input, and the array YDOT = f(t,y) 9291 C is output. Y and YDOT are arrays of length NEQ. 9292 C Subroutine F should not alter Y(1),...,Y(NEQ). 9293 C F must be declared External in the calling program. 9294 C 9295 C Subroutine F may access user-defined quantities in 9296 C NEQ(2),... and/or in Y(NEQ(1)+1),... if NEQ is an array 9297 C (dimensioned in F) and/or Y has length exceeding NEQ(1). 9298 C See the descriptions of NEQ and Y below. 9299 C 9300 C If quantities computed in the F routine are needed 9301 C externally to DLSODKR, an extra call to F should be made 9302 C for this purpose, for consistent and accurate results. 9303 C If only the derivative dy/dt is needed, use DINTDY instead. 9304 C 9305 C NEQ = the size of the ODE system (number of first order 9306 C ordinary differential equations). Used only for input. 9307 C NEQ may be decreased, but not increased, during the problem. 9308 C If NEQ is decreased (with ISTATE = 3 on input), the 9309 C remaining components of Y should be left undisturbed, if 9310 C these are to be accessed in the user-supplied routines. 9311 C 9312 C Normally, NEQ is a scalar, and it is generally referred to 9313 C as a scalar in this user interface description. However, 9314 C NEQ may be an array, with NEQ(1) set to the system size. 9315 C (The DLSODKR package accesses only NEQ(1).) In either case, 9316 C this parameter is passed as the NEQ argument in all calls 9317 C to the user-supplied routines. Hence, if it is an array, 9318 C locations NEQ(2),... may be used to store other integer data 9319 C and pass it to the user-supplied routines. Each such routine 9320 C must include NEQ in a Dimension statement in that case. 9321 C 9322 C Y = a real array for the vector of dependent variables, of 9323 C length NEQ or more. Used for both input and output on the 9324 C first call (ISTATE = 1), and only for output on other calls. 9325 C On the first call, Y must contain the vector of initial 9326 C values. On output, Y contains the computed solution vector, 9327 C evaluated at T. If desired, the Y array may be used 9328 C for other purposes between calls to the solver. 9329 C 9330 C This array is passed as the Y argument in all calls to F, G, 9331 C JAC, and PSOL. Hence its length may exceed NEQ, and 9332 C locations Y(NEQ+1),... may be used to store other real data 9333 C and pass it to the user-supplied routines. 9334 C (The DLSODKR package accesses only Y(1),...,Y(NEQ).) 9335 C 9336 C T = the independent variable. On input, T is used only on the 9337 C first call, as the initial point of the integration. 9338 C On output, after each call, T is the value at which a 9339 C computed solution y is evaluated (usually the same as TOUT). 9340 C If a root was found, T is the computed location of the 9341 C root reached first, on output. 9342 C On an error return, T is the farthest point reached. 9343 C 9344 C TOUT = the next value of t at which a computed solution is desired. 9345 C Used only for input. 9346 C 9347 C When starting the problem (ISTATE = 1), TOUT may be equal 9348 C to T for one call, then should .ne. T for the next call. 9349 C For the initial T, an input value of TOUT .ne. T is used 9350 C in order to determine the direction of the integration 9351 C (i.e. the algebraic sign of the step sizes) and the rough 9352 C scale of the problem. Integration in either direction 9353 C (forward or backward in t) is permitted. 9354 C 9355 C If ITASK = 2 or 5 (one-step modes), TOUT is ignored after 9356 C the first call (i.e. the first call with TOUT .ne. T). 9357 C Otherwise, TOUT is required on every call. 9358 C 9359 C If ITASK = 1, 3, or 4, the values of TOUT need not be 9360 C monotone, but a value of TOUT which backs up is limited 9361 C to the current internal T interval, whose endpoints are 9362 C TCUR - HU and TCUR (see optional outputs, below, for 9363 C TCUR and HU). 9364 C 9365 C ITOL = an indicator for the type of error control. See 9366 C description below under ATOL. Used only for input. 9367 C 9368 C RTOL = a relative error tolerance parameter, either a scalar or 9369 C an array of length NEQ. See description below under ATOL. 9370 C Input only. 9371 C 9372 C ATOL = an absolute error tolerance parameter, either a scalar or 9373 C an array of length NEQ. Input only. 9374 C 9375 C The input parameters ITOL, RTOL, and ATOL determine 9376 C the error control performed by the solver. The solver will 9377 C control the vector E = (E(i)) of estimated local errors 9378 C in y, according to an inequality of the form 9379 C RMS-norm of ( E(i)/EWT(i) ) .le. 1, 9380 C where EWT(i) = RTOL(i)*ABS(Y(i)) + ATOL(i), 9381 C and the RMS-norm (root-mean-square norm) here is 9382 C RMS-norm(v) = SQRT(sum v(i)**2 / NEQ). Here EWT = (EWT(i)) 9383 C is a vector of weights which must always be positive, and 9384 C the values of RTOL and ATOL should all be non-negative. 9385 C The following table gives the types (scalar/array) of 9386 C RTOL and ATOL, and the corresponding form of EWT(i). 9387 C 9388 C ITOL RTOL ATOL EWT(i) 9389 C 1 scalar scalar RTOL*ABS(Y(i)) + ATOL 9390 C 2 scalar array RTOL*ABS(Y(i)) + ATOL(i) 9391 C 3 array scalar RTOL(i)*ABS(Y(i)) + ATOL 9392 C 4 array array RTOL(i)*ABS(Y(i)) + ATOL(i) 9393 C 9394 C When either of these parameters is a scalar, it need not 9395 C be dimensioned in the user's calling program. 9396 C 9397 C If none of the above choices (with ITOL, RTOL, and ATOL 9398 C fixed throughout the problem) is suitable, more general 9399 C error controls can be obtained by substituting 9400 C user-supplied routines for the setting of EWT and/or for 9401 C the norm calculation. See Part 4 below. 9402 C 9403 C If global errors are to be estimated by making a repeated 9404 C run on the same problem with smaller tolerances, then all 9405 C components of RTOL and ATOL (i.e. of EWT) should be scaled 9406 C down uniformly. 9407 C 9408 C ITASK = an index specifying the task to be performed. 9409 C Input only. ITASK has the following values and meanings. 9410 C 1 means normal computation of output values of y(t) at 9411 C t = TOUT (by overshooting and interpolating). 9412 C 2 means take one step only and return. 9413 C 3 means stop at the first internal mesh point at or 9414 C beyond t = TOUT and return. 9415 C 4 means normal computation of output values of y(t) at 9416 C t = TOUT but without overshooting t = TCRIT. 9417 C TCRIT must be input as RWORK(1). TCRIT may be equal to 9418 C or beyond TOUT, but not behind it in the direction of 9419 C integration. This option is useful if the problem 9420 C has a singularity at or beyond t = TCRIT. 9421 C 5 means take one step, without passing TCRIT, and return. 9422 C TCRIT must be input as RWORK(1). 9423 C 9424 C Note: If ITASK = 4 or 5 and the solver reaches TCRIT 9425 C (within roundoff), it will return T = TCRIT (exactly) to 9426 C indicate this (unless ITASK = 4 and TOUT comes before TCRIT, 9427 C in which case answers at T = TOUT are returned first). 9428 C 9429 C ISTATE = an index used for input and output to specify the 9430 C the state of the calculation. 9431 C 9432 C On input, the values of ISTATE are as follows. 9433 C 1 means this is the first call for the problem 9434 C (initializations will be done). See note below. 9435 C 2 means this is not the first call, and the calculation 9436 C is to continue normally, with no change in any input 9437 C parameters except possibly TOUT and ITASK. 9438 C (If ITOL, RTOL, and/or ATOL are changed between calls 9439 C with ISTATE = 2, the new values will be used but not 9440 C tested for legality.) 9441 C 3 means this is not the first call, and the 9442 C calculation is to continue normally, but with 9443 C a change in input parameters other than 9444 C TOUT and ITASK. Changes are allowed in 9445 C NEQ, ITOL, RTOL, ATOL, IOPT, LRW, LIW, MF, 9446 C and any of the optional inputs except H0. 9447 C In addition, immediately following a return with 9448 C ISTATE = 3 (root found), NG and G may be changed. 9449 C (But changing NG from 0 to .gt. 0 is not allowed.) 9450 C Note: A preliminary call with TOUT = T is not counted 9451 C as a first call here, as no initialization or checking of 9452 C input is done. (Such a call is sometimes useful for the 9453 C purpose of outputting the initial conditions.) 9454 C Thus the first call for which TOUT .ne. T requires 9455 C ISTATE = 1 on input. 9456 C 9457 C On output, ISTATE has the following values and meanings. 9458 C 1 means nothing was done; TOUT = T and ISTATE = 1 on input. 9459 C 2 means the integration was performed successfully. 9460 C 3 means the integration was successful, and one or more 9461 C roots were found before satisfying the stop condition 9462 C specified by ITASK. See JROOT. 9463 C -1 means an excessive amount of work (more than MXSTEP 9464 C steps) was done on this call, before completing the 9465 C requested task, but the integration was otherwise 9466 C successful as far as T. (MXSTEP is an optional input 9467 C and is normally 500.) To continue, the user may 9468 C simply reset ISTATE to a value .gt. 1 and call again 9469 C (the excess work step counter will be reset to 0). 9470 C In addition, the user may increase MXSTEP to avoid 9471 C this error return (see below on optional inputs). 9472 C -2 means too much accuracy was requested for the precision 9473 C of the machine being used. This was detected before 9474 C completing the requested task, but the integration 9475 C was successful as far as T. To continue, the tolerance 9476 C parameters must be reset, and ISTATE must be set 9477 C to 3. The optional output TOLSF may be used for this 9478 C purpose. (Note: If this condition is detected before 9479 C taking any steps, then an illegal input return 9480 C (ISTATE = -3) occurs instead.) 9481 C -3 means illegal input was detected, before taking any 9482 C integration steps. See written message for details. 9483 C Note: If the solver detects an infinite loop of calls 9484 C to the solver with illegal input, it will cause 9485 C the run to stop. 9486 C -4 means there were repeated error test failures on 9487 C one attempted step, before completing the requested 9488 C task, but the integration was successful as far as T. 9489 C The problem may have a singularity, or the input 9490 C may be inappropriate. 9491 C -5 means there were repeated convergence test failures on 9492 C one attempted step, before completing the requested 9493 C task, but the integration was successful as far as T. 9494 C -6 means EWT(i) became zero for some i during the 9495 C integration. Pure relative error control (ATOL(i)=0.0) 9496 C was requested on a variable which has now vanished. 9497 C The integration was successful as far as T. 9498 C -7 means the PSOL routine returned an unrecoverable error 9499 C flag (IER .lt. 0). The integration was successful as 9500 C far as T. 9501 C 9502 C Note: Since the normal output value of ISTATE is 2, 9503 C it does not need to be reset for normal continuation. 9504 C Also, since a negative input value of ISTATE will be 9505 C regarded as illegal, a negative output value requires the 9506 C user to change it, and possibly other inputs, before 9507 C calling the solver again. 9508 C 9509 C IOPT = an integer flag to specify whether or not any optional 9510 C inputs are being used on this call. Input only. 9511 C The optional inputs are listed separately below. 9512 C IOPT = 0 means no optional inputs are being used. 9513 C Default values will be used in all cases. 9514 C IOPT = 1 means one or more optional inputs are being used. 9515 C 9516 C RWORK = a real working array (double precision). 9517 C The length of RWORK must be at least 9518 C 20 + NYH*(MAXORD+1) + 3*NEQ + 3*NG + LENLS + LWP where 9519 C NYH = the initial value of NEQ, 9520 C MAXORD = 12 (if METH = 1) or 5 (if METH = 2) (unless a 9521 C smaller value is given as an optional input), 9522 C LENLS = length of work space for linear system (Krylov) 9523 C method, excluding preconditioning: 9524 C LENLS = 0 if MITER = 0, 9525 C LENLS = NEQ*(MAXL+3) + MAXL**2 if MITER = 1, 9526 C LENLS = NEQ*(MAXL+3+MIN(1,MAXL-KMP)) 9527 C + (MAXL+3)*MAXL + 1 if MITER = 2, 9528 C LENLS = 6*NEQ if MITER = 3 or 4, 9529 C LENLS = 3*NEQ if MITER = 9. 9530 C (See the MF description for METH and MITER, and the 9531 C list of optional inputs for MAXL and KMP.) 9532 C LWP = length of real user work space for preconditioning 9533 C (see JAC/PSOL). 9534 C Thus if default values are used and NEQ is constant, 9535 C this length is: 9536 C 20 + 16*NEQ + 3*NG for MF = 10, 9537 C 45 + 24*NEQ + 3*NG + LWP for MF = 11, 9538 C 61 + 24*NEQ + 3*NG + LWP for MF = 12, 9539 C 20 + 22*NEQ + 3*NG + LWP for MF = 13 or 14, 9540 C 20 + 19*NEQ + 3*NG + LWP for MF = 19, 9541 C 20 + 9*NEQ + 3*NG for MF = 20, 9542 C 45 + 17*NEQ + 3*NG + LWP for MF = 21, 9543 C 61 + 17*NEQ + 3*NG + LWP for MF = 22, 9544 C 20 + 15*NEQ + 3*NG + LWP for MF = 23 or 24, 9545 C 20 + 12*NEQ + 3*NG + LWP for MF = 29. 9546 C The first 20 words of RWORK are reserved for conditional 9547 C and optional inputs and optional outputs. 9548 C 9549 C The following word in RWORK is a conditional input: 9550 C RWORK(1) = TCRIT = critical value of t which the solver 9551 C is not to overshoot. Required if ITASK is 9552 C 4 or 5, and ignored otherwise. (See ITASK.) 9553 C 9554 C LRW = the length of the array RWORK, as declared by the user. 9555 C (This will be checked by the solver.) 9556 C 9557 C IWORK = an integer work array. The length of IWORK must be at least 9558 C 30 if MITER = 0 (MF = 10 or 20), 9559 C 30 + MAXL + LIWP if MITER = 1 (MF = 11, 21), 9560 C 30 + LIWP if MITER = 2, 3, 4, or 9. 9561 C MAXL = 5 unless a different optional input value is given. 9562 C LIWP = length of integer user work space for preconditioning 9563 C (see conditional input list following). 9564 C The first few words of IWORK are used for conditional and 9565 C optional inputs and optional outputs. 9566 C 9567 C The following 4 words in IWORK are conditional inputs, 9568 C required if MITER .ge. 1: 9569 C IWORK(1) = LWP = length of real array WP for use in 9570 C preconditioning (part of RWORK array). 9571 C IWORK(2) = LIWP = length of integer array IWP for use in 9572 C preconditioning (part of IWORK array). 9573 C The arrays WP and IWP are work arrays under the 9574 C user's control, for use in the routines that 9575 C perform preconditioning operations (JAC and PSOL). 9576 C IWORK(3) = JPRE = preconditioner type flag: 9577 C = 0 for no preconditioning (P1 = P2 = P = identity) 9578 C = 1 for left-only preconditioning (P2 = identity) 9579 C = 2 for right-only preconditioning (P1 = identity) 9580 C = 3 for two-sided preconditioning (and PCG or PCGS) 9581 C IWORK(4) = JACFLG = flag for whether JAC is called. 9582 C = 0 if JAC is not to be called, 9583 C = 1 if JAC is to be called. 9584 C Use JACFLG = 1 if JAC computes any nonconstant 9585 C data needed in preconditioning operations, 9586 C such as some of the Jacobian elements. 9587 C 9588 C LIW = the length of the array IWORK, as declared by the user. 9589 C (This will be checked by the solver.) 9590 C 9591 C Note: The work arrays must not be altered between calls to DLSODKR 9592 C for the same problem, except possibly for the conditional and 9593 C optional inputs, and except for the last 3*NEQ words of RWORK. 9594 C The latter space is used for internal scratch space, and so is 9595 C available for use by the user outside DLSODKR between calls, if 9596 C desired (but not for use by any of the user-supplied routines). 9597 C 9598 C JAC = the name of the user-supplied routine to compute any 9599 C Jacobian elements (or approximations) involved in the 9600 C matrix preconditioning operations (MITER .ge. 1). 9601 C It is to have the form 9602 C SUBROUTINE JAC (F, NEQ, T, Y, YSV, REWT, FTY, V, 9603 C 1 HL0, JOK, WP, IWP, IER) 9604 C DOUBLE PRECISION T, Y(*), YSV(*), REWT(*), FTY(*), V(*), 9605 C 1 HL0, WP(*) 9606 C INTEGER IWP(*) 9607 C This routine must evaluate and preprocess any parts of the 9608 C Jacobian matrix df/dy used in the preconditioners P1, P2, P. 9609 C The Y and FTY arrays contain the current values of y and 9610 C f(t,y), respectively, and the YSV array also contains 9611 C the current y vector. The array V is work space of length 9612 C NEQ for use by JAC. REWT is the array of reciprocal error 9613 C weights (1/EWT). JAC must multiply all computed Jacobian 9614 C elements by the scalar -HL0, add the identity matrix, and do 9615 C any factorization operations called for, in preparation 9616 C for solving linear systems with a coefficient matrix of 9617 C P1, P2, or P. The matrix P1*P2 or P should be an 9618 C approximation to identity - hl0 * (df/dy). JAC should 9619 C return IER = 0 if successful, and IER .ne. 0 if not. 9620 C (If IER .ne. 0, a smaller time step will be tried.) 9621 C The arrays WP (of length LWP) and IWP (of length LIWP) 9622 C are for use by JAC and PSOL for work space and for storage 9623 C of data needed for the solution of the preconditioner 9624 C linear systems. Their lengths and contents are under the 9625 C user's control. 9626 C The argument JOK is an input flag for optional use 9627 C by JAC in deciding whether to recompute Jacobian elements 9628 C or use saved values. If JOK = -1, then JAC must compute 9629 C any relevant Jacobian elements (or approximations) used in 9630 C the preconditioners. Optionally, JAC may also save these 9631 C elements for later reuse. If JOK = 1, the integrator has 9632 C made a judgement (based on the convergence history and the 9633 C value of HL0) that JAC need not recompute Jacobian elements, 9634 C but instead use saved values, and the current value of HL0, 9635 C to reconstruct the preconditioner matrices, followed by 9636 C any required factorizations. This may be cost-effective if 9637 C Jacobian elements are costly and storage is available. 9638 C JAC may alter Y and V, but not YSV, REWT, FTY, or HL0. 9639 C JAC must be declared External in the calling program. 9640 C Subroutine JAC may access user-defined quantities in 9641 C NEQ(2),... and/or in Y(NEQ(1)+1),... if NEQ is an array 9642 C (dimensioned in JAC) and/or Y has length exceeding NEQ(1). 9643 C See the descriptions of NEQ and Y above. 9644 C 9645 C PSOL = the name of the user-supplied routine for the 9646 C solution of preconditioner linear systems. 9647 C It is to have the form 9648 C SUBROUTINE PSOL (NEQ, T, Y, FTY, WK,HL0, WP,IWP, B, LR,IER) 9649 C DOUBLE PRECISION T, Y(*), FTY(*), WK(*), HL0, WP(*), B(*) 9650 C INTEGER IWP(*) 9651 C This routine must solve a linear system with B as right-hand 9652 C side and one of the preconditioning matrices, P1, P2, or P, 9653 C as coefficient matrix, and return the solution vector in B. 9654 C LR is a flag concerning left vs right preconditioning, input 9655 C to PSOL. PSOL is to use P1 if LR = 1 and P2 if LR = 2. 9656 C In the case of the PCG or PCGS method, LR will be 3, and PSOL 9657 C should solve the system P*x = B with the preconditioner P. 9658 C In the case MITER = 9 (no Krylov iteration), LR will be 0, 9659 C and PSOL is to return in B the desired approximate solution 9660 C to A * x = B, where A = identity - hl0 * (df/dy). 9661 C PSOL can use data generated in the JAC routine and stored in 9662 C WP and IWP. 9663 C The Y and FTY arrays contain the current values of y and 9664 C f(t,y), respectively. The array WK is work space of length 9665 C NEQ for use by PSOL. 9666 C The argument HL0 is the current value of the scalar appearing 9667 C in the linear system. If the old value, as of the last 9668 C JAC call, is needed, it must have been saved by JAC in WP. 9669 C On return, PSOL should set the error flag IER as follows: 9670 C IER = 0 if PSOL was successful, 9671 C IER .gt. 0 on a recoverable error, meaning that the 9672 C time step will be retried, 9673 C IER .lt. 0 on an unrecoverable error, meaning that the 9674 C solver is to stop immediately. 9675 C PSOL may not alter Y, FTY, or HL0. 9676 C PSOL must be declared External in the calling program. 9677 C Subroutine PSOL may access user-defined quantities in 9678 C NEQ(2),... and Y(NEQ(1)+1),... if NEQ is an array 9679 C (dimensioned in PSOL) and/or Y has length exceeding NEQ(1). 9680 C See the descriptions of NEQ and Y above. 9681 C 9682 C MF = the method flag. Used only for input. The legal values of 9683 C MF are 10, 11, 12, 13, 14, 19, 20, 21, 22, 23, 24, and 29. 9684 C MF has decimal digits METH and MITER: MF = 10*METH + MITER. 9685 C METH indicates the basic linear multistep method: 9686 C METH = 1 means the implicit Adams method. 9687 C METH = 2 means the method based on Backward 9688 C Differentiation Formulas (BDFs). 9689 C MITER indicates the corrector iteration method: 9690 C MITER = 0 means functional iteration (no linear system 9691 C is involved). 9692 C MITER = 1 means Newton iteration with Scaled Preconditioned 9693 C Incomplete Orthogonalization Method (SPIOM) 9694 C for the linear systems. 9695 C MITER = 2 means Newton iteration with Scaled Preconditioned 9696 C Incomplete Generalized Minimal Residual method 9697 C (SPIGMR) for the linear systems. 9698 C MITER = 3 means Newton iteration with Preconditioned 9699 C Conjugate Gradient method (PCG) 9700 C for the linear systems. 9701 C MITER = 4 means Newton iteration with scaled preconditioned 9702 C Conjugate Gradient method (PCGS) 9703 C for the linear systems. 9704 C MITER = 9 means Newton iteration with only the 9705 C user-supplied PSOL routine called (no Krylov 9706 C iteration) for the linear systems. 9707 C JPRE is ignored, and PSOL is called with LR = 0. 9708 C See comments in the introduction about the choice of MITER. 9709 C If MITER .ge. 1, the user must supply routines JAC and PSOL 9710 C (the names are arbitrary) as described above. 9711 C For MITER = 0, a dummy argument can be used. 9712 C 9713 C G = the name of subroutine for constraint functions, whose 9714 C roots are desired during the integration. It is to have 9715 C the form 9716 C SUBROUTINE G (NEQ, T, Y, NG, GOUT) 9717 C DOUBLE PRECISION T, Y(*), GOUT(NG) 9718 C where NEQ, T, Y, and NG are input, and the array GOUT 9719 C is output. NEQ, T, and Y have the same meaning as in 9720 C the F routine, and GOUT is an array of length NG. 9721 C For i = 1,...,NG, this routine is to load into GOUT(i) 9722 C the value at (t,y) of the i-th constraint function g(i). 9723 C DLSODKR will find roots of the g(i) of odd multiplicity 9724 C (i.e. sign changes) as they occur during the integration. 9725 C G must be declared External in the calling program. 9726 C 9727 C Caution: Because of numerical errors in the functions 9728 C g(i) due to roundoff and integration error, DLSODKR may 9729 C return false roots, or return the same root at two or more 9730 C nearly equal values of t. If such false roots are 9731 C suspected, the user should consider smaller error tolerances 9732 C and/or higher precision in the evaluation of the g(i). 9733 C 9734 C If a root of some g(i) defines the end of the problem, 9735 C the input to DLSODKR should nevertheless allow integration 9736 C to a point slightly past that root, so that DLSODKR can 9737 C locate the root by interpolation. 9738 C 9739 C Subroutine G may access user-defined quantities in 9740 C NEQ(2),... and Y(NEQ(1)+1),... if NEQ is an array 9741 C (dimensioned in G) and/or Y has length exceeding NEQ(1). 9742 C See the descriptions of NEQ and Y above. 9743 C 9744 C NG = number of constraint functions g(i). If there are none, 9745 C set NG = 0, and pass a dummy name for G. 9746 C 9747 C JROOT = integer array of length NG. Used only for output. 9748 C On a return with ISTATE = 3 (one or more roots found), 9749 C JROOT(i) = 1 if g(i) has a root at t, or JROOT(i) = 0 if not. 9750 C----------------------------------------------------------------------- 9751 C Optional Inputs. 9752 C 9753 C The following is a list of the optional inputs provided for in the 9754 C call sequence. (See also Part 2.) For each such input variable, 9755 C this table lists its name as used in this documentation, its 9756 C location in the call sequence, its meaning, and the default value. 9757 C The use of any of these inputs requires IOPT = 1, and in that 9758 C case all of these inputs are examined. A value of zero for any 9759 C of these optional inputs will cause the default value to be used. 9760 C Thus to use a subset of the optional inputs, simply preload 9761 C locations 5 to 10 in RWORK and IWORK to 0.0 and 0 respectively, and 9762 C then set those of interest to nonzero values. 9763 C 9764 C Name Location Meaning and Default Value 9765 C 9766 C H0 RWORK(5) the step size to be attempted on the first step. 9767 C The default value is determined by the solver. 9768 C 9769 C HMAX RWORK(6) the maximum absolute step size allowed. 9770 C The default value is infinite. 9771 C 9772 C HMIN RWORK(7) the minimum absolute step size allowed. 9773 C The default value is 0. (This lower bound is not 9774 C enforced on the final step before reaching TCRIT 9775 C when ITASK = 4 or 5.) 9776 C 9777 C DELT RWORK(8) convergence test constant in Krylov iteration 9778 C algorithm. The default is .05. 9779 C 9780 C MAXORD IWORK(5) the maximum order to be allowed. The default 9781 C value is 12 if METH = 1, and 5 if METH = 2. 9782 C If MAXORD exceeds the default value, it will 9783 C be reduced to the default value. 9784 C If MAXORD is changed during the problem, it may 9785 C cause the current order to be reduced. 9786 C 9787 C MXSTEP IWORK(6) maximum number of (internally defined) steps 9788 C allowed during one call to the solver. 9789 C The default value is 500. 9790 C 9791 C MXHNIL IWORK(7) maximum number of messages printed (per problem) 9792 C warning that T + H = T on a step (H = step size). 9793 C This must be positive to result in a non-default 9794 C value. The default value is 10. 9795 C 9796 C MAXL IWORK(8) maximum number of iterations in the SPIOM, SPIGMR, 9797 C PCG, or PCGS algorithm (.le. NEQ). 9798 C The default is MAXL = MIN(5,NEQ). 9799 C 9800 C KMP IWORK(9) number of vectors on which orthogonalization 9801 C is done in SPIOM or SPIGMR algorithm (.le. MAXL). 9802 C The default is KMP = MAXL. 9803 C Note: When KMP .lt. MAXL and MF = 22, the length 9804 C of RWORK must be defined accordingly. See 9805 C the definition of RWORK above. 9806 C----------------------------------------------------------------------- 9807 C Optional Outputs. 9808 C 9809 C As optional additional output from DLSODKR, the variables listed 9810 C below are quantities related to the performance of DLSODKR 9811 C which are available to the user. These are communicated by way of 9812 C the work arrays, but also have internal mnemonic names as shown. 9813 C Except where stated otherwise, all of these outputs are defined 9814 C on any successful return from DLSODKR, and on any return with 9815 C ISTATE = -1, -2, -4, -5, -6, or -7. On an illegal input return 9816 C (ISTATE = -3), they will be unchanged from their existing values 9817 C (if any), except possibly for TOLSF, LENRW, and LENIW. 9818 C On any error return, outputs relevant to the error will be defined, 9819 C as noted below. 9820 C 9821 C Name Location Meaning 9822 C 9823 C HU RWORK(11) the step size in t last used (successfully). 9824 C 9825 C HCUR RWORK(12) the step size to be attempted on the next step. 9826 C 9827 C TCUR RWORK(13) the current value of the independent variable 9828 C which the solver has actually reached, i.e. the 9829 C current internal mesh point in t. On output, TCUR 9830 C will always be at least as far as the argument 9831 C T, but may be farther (if interpolation was done). 9832 C 9833 C TOLSF RWORK(14) a tolerance scale factor, greater than 1.0, 9834 C computed when a request for too much accuracy was 9835 C detected (ISTATE = -3 if detected at the start of 9836 C the problem, ISTATE = -2 otherwise). If ITOL is 9837 C left unaltered but RTOL and ATOL are uniformly 9838 C scaled up by a factor of TOLSF for the next call, 9839 C then the solver is deemed likely to succeed. 9840 C (The user may also ignore TOLSF and alter the 9841 C tolerance parameters in any other way appropriate.) 9842 C 9843 C NGE IWORK(10) the number of g evaluations for the problem so far. 9844 C 9845 C NST IWORK(11) the number of steps taken for the problem so far. 9846 C 9847 C NFE IWORK(12) the number of f evaluations for the problem so far. 9848 C 9849 C NPE IWORK(13) the number of calls to JAC so far (for evaluation 9850 C of preconditioners). 9851 C 9852 C NQU IWORK(14) the method order last used (successfully). 9853 C 9854 C NQCUR IWORK(15) the order to be attempted on the next step. 9855 C 9856 C IMXER IWORK(16) the index of the component of largest magnitude in 9857 C the weighted local error vector ( E(i)/EWT(i) ), 9858 C on an error return with ISTATE = -4 or -5. 9859 C 9860 C LENRW IWORK(17) the length of RWORK actually required. 9861 C This is defined on normal returns and on an illegal 9862 C input return for insufficient storage. 9863 C 9864 C LENIW IWORK(18) the length of IWORK actually required. 9865 C This is defined on normal returns and on an illegal 9866 C input return for insufficient storage. 9867 C 9868 C NNI IWORK(19) number of nonlinear iterations so far (each of 9869 C which calls an iterative linear solver). 9870 C 9871 C NLI IWORK(20) number of linear iterations so far. 9872 C Note: A measure of the success of algorithm is 9873 C the average number of linear iterations per 9874 C nonlinear iteration, given by NLI/NNI. 9875 C If this is close to MAXL, MAXL may be too small. 9876 C 9877 C NPS IWORK(21) number of preconditioning solve operations 9878 C (PSOL calls) so far. 9879 C 9880 C NCFN IWORK(22) number of convergence failures of the nonlinear 9881 C (Newton) iteration so far. 9882 C Note: A measure of success is the overall 9883 C rate of nonlinear convergence failures, NCFN/NST. 9884 C 9885 C NCFL IWORK(23) number of convergence failures of the linear 9886 C iteration so far. 9887 C Note: A measure of success is the overall 9888 C rate of linear convergence failures, NCFL/NNI. 9889 C 9890 C NSFI IWORK(24) number of functional iteration steps so far. 9891 C Note: A measure of the extent to which the 9892 C problem is nonstiff is the ratio NSFI/NST. 9893 C 9894 C NJEV IWORK(25) number of JAC calls with JOK = -1 so far 9895 C (number of evaluations of Jacobian data). 9896 C 9897 C The following two arrays are segments of the RWORK array which 9898 C may also be of interest to the user as optional outputs. 9899 C For each array, the table below gives its internal name, 9900 C its base address in RWORK, and its description. 9901 C 9902 C Name Base Address Description 9903 C 9904 C YH 21 + 3*NG the Nordsieck history array, of size NYH by 9905 C (NQCUR + 1), where NYH is the initial value 9906 C of NEQ. For j = 0,1,...,NQCUR, column j+1 9907 C of YH contains HCUR**j/factorial(j) times 9908 C the j-th derivative of the interpolating 9909 C polynomial currently representing the solution, 9910 C evaluated at t = TCUR. 9911 C 9912 C ACOR LENRW-NEQ+1 array of size NEQ used for the accumulated 9913 C corrections on each step, scaled on output 9914 C to represent the estimated local error in y 9915 C on the last step. This is the vector E in 9916 C the description of the error control. It is 9917 C defined only on a successful return from 9918 C DLSODKR. 9919 C 9920 C----------------------------------------------------------------------- 9921 C Part 2. Other Routines Callable. 9922 C 9923 C The following are optional calls which the user may make to 9924 C gain additional capabilities in conjunction with DLSODKR. 9925 C (The routines XSETUN and XSETF are designed to conform to the 9926 C SLATEC error handling package.) 9927 C 9928 C Form of Call Function 9929 C CALL XSETUN(LUN) Set the logical unit number, LUN, for 9930 C output of messages from DLSODKR, if 9931 C the default is not desired. 9932 C The default value of LUN is 6. 9933 C 9934 C CALL XSETF(MFLAG) Set a flag to control the printing of 9935 C messages by DLSODKR. 9936 C MFLAG = 0 means do not print. (Danger: 9937 C This risks losing valuable information.) 9938 C MFLAG = 1 means print (the default). 9939 C 9940 C Either of the above calls may be made at 9941 C any time and will take effect immediately. 9942 C 9943 C CALL DSRCKR(RSAV,ISAV,JOB) saves and restores the contents of 9944 C the internal Common blocks used by 9945 C DLSODKR (see Part 3 below). 9946 C RSAV must be a real array of length 228 9947 C or more, and ISAV must be an integer 9948 C array of length 63 or more. 9949 C JOB=1 means save Common into RSAV/ISAV. 9950 C JOB=2 means restore Common from RSAV/ISAV. 9951 C DSRCKR is useful if one is 9952 C interrupting a run and restarting 9953 C later, or alternating between two or 9954 C more problems solved with DLSODKR. 9955 C 9956 C CALL DINTDY(,,,,,) Provide derivatives of y, of various 9957 C (see below) orders, at a specified point t, if 9958 C desired. It may be called only after 9959 C a successful return from DLSODKR. 9960 C 9961 C The detailed instructions for using DINTDY are as follows. 9962 C The form of the call is: 9963 C 9964 C LYH = 21 + 3*NG 9965 C CALL DINTDY (T, K, RWORK(LYH), NYH, DKY, IFLAG) 9966 C 9967 C The input parameters are: 9968 C 9969 C T = value of independent variable where answers are desired 9970 C (normally the same as the T last returned by DLSODKR). 9971 C For valid results, T must lie between TCUR - HU and TCUR. 9972 C (See optional outputs for TCUR and HU.) 9973 C K = integer order of the derivative desired. K must satisfy 9974 C 0 .le. K .le. NQCUR, where NQCUR is the current order 9975 C (see optional outputs). The capability corresponding 9976 C to K = 0, i.e. computing y(T), is already provided 9977 C by DLSODKR directly. Since NQCUR .ge. 1, the first 9978 C derivative dy/dt is always available with DINTDY. 9979 C LYH = 21 + 3*NG = base address in RWORK of the history array YH. 9980 C NYH = column length of YH, equal to the initial value of NEQ. 9981 C 9982 C The output parameters are: 9983 C 9984 C DKY = a real array of length NEQ containing the computed value 9985 C of the K-th derivative of y(t). 9986 C IFLAG = integer flag, returned as 0 if K and T were legal, 9987 C -1 if K was illegal, and -2 if T was illegal. 9988 C On an error return, a message is also written. 9989 C----------------------------------------------------------------------- 9990 C Part 3. Common Blocks. 9991 C 9992 C If DLSODKR is to be used in an overlay situation, the user 9993 C must declare, in the primary overlay, the variables in: 9994 C (1) the call sequence to DLSODKR, and 9995 C (2) the four internal Common blocks 9996 C /DLS001/ of length 255 (218 double precision words 9997 C followed by 37 integer words), 9998 C /DLS002/ of length 5 (1 double precision word 9999 C followed by 4 integer words), 10000 C /DLPK01/ of length 17 (4 double precision words 10001 C followed by 13 integer words), 10002 C /DLSR01/ of length 14 (5 double precision words 10003 C followed by 9 integer words). 10004 C 10005 C If DLSODKR is used on a system in which the contents of internal 10006 C Common blocks are not preserved between calls, the user should 10007 C declare the above Common blocks in the calling program to insure 10008 C that their contents are preserved. 10009 C 10010 C If the solution of a given problem by DLSODKR is to be interrupted 10011 C and then later continued, such as when restarting an interrupted run 10012 C or alternating between two or more problems, the user should save, 10013 C following the return from the last DLSODKR call prior to the 10014 C interruption, the contents of the call sequence variables and the 10015 C internal Common blocks, and later restore these values before the 10016 C next DLSODKR call for that problem. To save and restore the Common 10017 C blocks, use Subroutine DSRCKR (see Part 2 above). 10018 C 10019 C----------------------------------------------------------------------- 10020 C Part 4. Optionally Replaceable Solver Routines. 10021 C 10022 C Below are descriptions of two routines in the DLSODKR package which 10023 C relate to the measurement of errors. Either routine can be 10024 C replaced by a user-supplied version, if desired. However, since such 10025 C a replacement may have a major impact on performance, it should be 10026 C done only when absolutely necessary, and only with great caution. 10027 C (Note: The means by which the package version of a routine is 10028 C superseded by the user's version may be system-dependent.) 10029 C 10030 C (a) DEWSET. 10031 C The following subroutine is called just before each internal 10032 C integration step, and sets the array of error weights, EWT, as 10033 C described under ITOL/RTOL/ATOL above: 10034 C SUBROUTINE DEWSET (NEQ, ITOL, RTOL, ATOL, YCUR, EWT) 10035 C where NEQ, ITOL, RTOL, and ATOL are as in the DLSODKR call sequence, 10036 C YCUR contains the current dependent variable vector, and 10037 C EWT is the array of weights set by DEWSET. 10038 C 10039 C If the user supplies this subroutine, it must return in EWT(i) 10040 C (i = 1,...,NEQ) a positive quantity suitable for comparing errors 10041 C in y(i) to. The EWT array returned by DEWSET is passed to the DVNORM 10042 C routine (see below), and also used by DLSODKR in the computation 10043 C of the optional output IMXER, the diagonal Jacobian approximation, 10044 C and the increments for difference quotient Jacobians. 10045 C 10046 C In the user-supplied version of DEWSET, it may be desirable to use 10047 C the current values of derivatives of y. Derivatives up to order NQ 10048 C are available from the history array YH, described above under 10049 C optional outputs. In DEWSET, YH is identical to the YCUR array, 10050 C extended to NQ + 1 columns with a column length of NYH and scale 10051 C factors of H**j/factorial(j). On the first call for the problem, 10052 C given by NST = 0, NQ is 1 and H is temporarily set to 1.0. 10053 C NYH is the initial value of NEQ. The quantities NQ, H, and NST 10054 C can be obtained by including in DEWSET the statements: 10055 C DOUBLE PRECISION RLS 10056 C COMMON /DLS001/ RLS(218),ILS(37) 10057 C NQ = ILS(33) 10058 C NST = ILS(34) 10059 C H = RLS(212) 10060 C Thus, for example, the current value of dy/dt can be obtained as 10061 C YCUR(NYH+i)/H (i=1,...,NEQ) (and the division by H is 10062 C unnecessary when NST = 0). 10063 C 10064 C (b) DVNORM. 10065 C The following is a real function routine which computes the weighted 10066 C root-mean-square norm of a vector v: 10067 C D = DVNORM (N, V, W) 10068 C where: 10069 C N = the length of the vector, 10070 C V = real array of length N containing the vector, 10071 C W = real array of length N containing weights, 10072 C D = SQRT( (1/N) * sum(V(i)*W(i))**2 ). 10073 C DVNORM is called with N = NEQ and with W(i) = 1.0/EWT(i), where 10074 C EWT is as set by Subroutine DEWSET. 10075 C 10076 C If the user supplies this function, it should return a non-negative 10077 C value of DVNORM suitable for use in the error control in DLSODKR. 10078 C None of the arguments should be altered by DVNORM. 10079 C For example, a user-supplied DVNORM routine might: 10080 C -substitute a max-norm of (V(i)*W(i)) for the RMS-norm, or 10081 C -ignore some components of V in the norm, with the effect of 10082 C suppressing the error control on those components of y. 10083 C----------------------------------------------------------------------- 10084 C 10085 C***REVISION HISTORY (YYYYMMDD) 10086 C 19900117 DATE WRITTEN 10087 C 19900503 Added iteration switching (functional/Newton). 10088 C 19900802 Added flag for Jacobian-saving in user preconditioner. 10089 C 19900910 Added new initial stepsize routine LHIN. 10090 C 19901019 Corrected LHIN - y array restored. 10091 C 19910909 Changed names STOPK to STOKA, PKSET to SETPK; 10092 C removed unused variables in driver declarations; 10093 C minor corrections to main prologue. 10094 C 20010425 Major update: convert source lines to upper case; 10095 C added *DECK lines; changed from 1 to * in dummy dimensions; 10096 C changed names R1MACH/D1MACH to RUMACH/DUMACH; 10097 C renamed routines for uniqueness across single/double prec.; 10098 C converted intrinsic names to generic form; 10099 C removed ILLIN and NTREP (data loaded) from Common; 10100 C removed all 'own' variables from Common; 10101 C changed error messages to quoted strings; 10102 C replaced XERRWV/XERRWD with 1993 revised version; 10103 C converted prologues, comments, error messages to mixed case; 10104 C numerous corrections to prologues and internal comments. 10105 C 20010507 Converted single precision source to double precision. 10106 C 20020502 Corrected declarations in descriptions of user routines. 10107 C 20030603 Corrected duplicate type declaration for DUMACH. 10108 C 20031105 Restored 'own' variables to Common blocks, to enable 10109 C interrupt/restart feature. 10110 C 20031112 Added SAVE statements for data-loaded constants. 10111 C 20031117 Changed internal name NPE to NJE. 10112 C 10113 C----------------------------------------------------------------------- 10114 C Other routines in the DLSODKR package. 10115 C 10116 C In addition to Subroutine DLSODKR, the DLSODKR package includes the 10117 C following subroutines and function routines: 10118 C DLHIN calculates a step size to be attempted initially. 10119 C DRCHEK does preliminary checking for roots, and serves as an 10120 C interface between Subroutine DLSODKR and Subroutine DROOTS. 10121 C DROOTS finds the leftmost root of a set of functions. 10122 C DINTDY computes an interpolated value of the y vector at t = TOUT. 10123 C DEWSET sets the error weight vector EWT before each step. 10124 C DVNORM computes the weighted RMS-norm of a vector. 10125 C DSTOKA is the core integrator, which does one step of the 10126 C integration and the associated error control. 10127 C DCFODE sets all method coefficients and test constants. 10128 C DSETPK interfaces between DSTOKA and the JAC routine. 10129 C DSOLPK manages solution of linear system in Newton iteration. 10130 C DSPIOM performs the SPIOM algorithm. 10131 C DATV computes a scaled, preconditioned product (I-hl0*J)*v. 10132 C DORTHOG orthogonalizes a vector against previous basis vectors. 10133 C DHEFA generates an LU factorization of a Hessenberg matrix. 10134 C DHESL solves a Hessenberg square linear system. 10135 C DSPIGMR performs the SPIGMR algorithm. 10136 C DHEQR generates a QR factorization of a Hessenberg matrix. 10137 C DHELS finds the least squares solution of a Hessenberg system. 10138 C DPCG performs preconditioned conjugate gradient algorithm (PCG). 10139 C DPCGS performs the PCGS algorithm. 10140 C DATP computes the product A*p, where A = I - hl0*df/dy. 10141 C DUSOL interfaces to the user's PSOL routine (MITER = 9). 10142 C DSRCKR is a user-callable routine to save and restore 10143 C the contents of the internal Common blocks. 10144 C DAXPY, DCOPY, DDOT, DNRM2, and DSCAL are basic linear 10145 C algebra modules (from the BLAS collection). 10146 C DUMACH computes the unit roundoff in a machine-independent manner. 10147 C XERRWD, XSETUN, XSETF, IXSAV, and IUMACH handle the printing of all 10148 C error messages and warnings. XERRWD is machine-dependent. 10149 C Note: DVNORM, DDOT, DNRM2, DUMACH, IXSAV, and IUMACH are function 10150 C routines. All the others are subroutines. 10151 C 10152 C----------------------------------------------------------------------- 10153 DOUBLE PRECISION DUMACH, DVNORM 10154 INTEGER INIT, MXSTEP, MXHNIL, NHNIL, NSLAST, NYH, IOWNS, 10155 1 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 10156 2 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 10157 3 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU 10158 INTEGER NEWT, NSFI, NSLJ, NJEV 10159 INTEGER LG0, LG1, LGX, IOWNR3, IRFND, ITASKC, NGC, NGE 10160 INTEGER JPRE, JACFLG, LOCWP, LOCIWP, LSAVX, KMP, MAXL, MNEWT, 10161 1 NNI, NLI, NPS, NCFN, NCFL 10162 INTEGER I, I1, I2, IER, IFLAG, IMXER, KGO, LF0, 10163 1 LENIW, LENIWK, LENRW, LENWM, LENWK, LIWP, LWP, MORD, MXHNL0, 10164 2 MXSTP0, NCFN0, NCFL0, NITER, NLI0, NNI0, NNID, NSTD, NWARN 10165 INTEGER IRFP, IRT, LENYH, LYHNEW 10166 DOUBLE PRECISION ROWNS, 10167 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND 10168 DOUBLE PRECISION STIFR 10169 DOUBLE PRECISION ROWNR3, T0, TLAST, TOUTC 10170 DOUBLE PRECISION DELT, EPCON, SQRTN, RSQRTN 10171 DOUBLE PRECISION ATOLI, AVDIM, BIG, EWTI, H0, HMAX, HMX, RCFL, 10172 1 RCFN, RH, RTOLI, TCRIT, TNEXT, TOLSF, TP, SIZE 10173 DIMENSION MORD(2) 10174 LOGICAL IHIT, LAVD, LCFN, LCFL, LWARN 10175 CHARACTER*60 MSG 10176 SAVE MORD, MXSTP0, MXHNL0 10177 C----------------------------------------------------------------------- 10178 C The following four internal Common blocks contain 10179 C (a) variables which are local to any subroutine but whose values must 10180 C be preserved between calls to the routine ("own" variables), and 10181 C (b) variables which are communicated between subroutines. 10182 C The block DLS001 is declared in subroutines DLSODKR, DINTDY, 10183 C DSTOKA, DSOLPK, and DATV. 10184 C The block DLS002 is declared in subroutines DLSODKR and DSTOKA. 10185 C The block DLSR01 is declared in subroutines DLSODKR, DRCHEK, DROOTS. 10186 C The block DLPK01 is declared in subroutines DLSODKR, DSTOKA, DSETPK, 10187 C and DSOLPK. 10188 C Groups of variables are replaced by dummy arrays in the Common 10189 C declarations in routines where those variables are not used. 10190 C----------------------------------------------------------------------- 10191 COMMON /DLS001/ ROWNS(209), 10192 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND, 10193 2 INIT, MXSTEP, MXHNIL, NHNIL, NSLAST, NYH, IOWNS(6), 10194 3 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 10195 4 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 10196 5 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU 10197 C 10198 COMMON /DLS002/ STIFR, NEWT, NSFI, NSLJ, NJEV 10199 C 10200 COMMON /DLSR01/ ROWNR3(2), T0, TLAST, TOUTC, 10201 1 LG0, LG1, LGX, IOWNR3(2), IRFND, ITASKC, NGC, NGE 10202 C 10203 COMMON /DLPK01/ DELT, EPCON, SQRTN, RSQRTN, 10204 1 JPRE, JACFLG, LOCWP, LOCIWP, LSAVX, KMP, MAXL, MNEWT, 10205 2 NNI, NLI, NPS, NCFN, NCFL 10206 C 10207 DATA MORD(1),MORD(2)/12,5/, MXSTP0/500/, MXHNL0/10/ 10208 C----------------------------------------------------------------------- 10209 C Block A. 10210 C This code block is executed on every call. 10211 C It tests ISTATE and ITASK for legality and branches appropriately. 10212 C If ISTATE .gt. 1 but the flag INIT shows that initialization has 10213 C not yet been done, an error return occurs. 10214 C If ISTATE = 1 and TOUT = T, return immediately. 10215 C----------------------------------------------------------------------- 10216 IF (ISTATE .LT. 1 .OR. ISTATE .GT. 3) GO TO 601 10217 IF (ITASK .LT. 1 .OR. ITASK .GT. 5) GO TO 602 10218 ITASKC = ITASK 10219 IF (ISTATE .EQ. 1) GO TO 10 10220 IF (INIT .EQ. 0) GO TO 603 10221 IF (ISTATE .EQ. 2) GO TO 200 10222 GO TO 20 10223 10 INIT = 0 10224 IF (TOUT .EQ. T) RETURN 10225 C----------------------------------------------------------------------- 10226 C Block B. 10227 C The next code block is executed for the initial call (ISTATE = 1), 10228 C or for a continuation call with parameter changes (ISTATE = 3). 10229 C It contains checking of all inputs and various initializations. 10230 C 10231 C First check legality of the non-optional inputs NEQ, ITOL, IOPT, MF, 10232 C and NG. 10233 C----------------------------------------------------------------------- 10234 20 IF (NEQ(1) .LE. 0) GO TO 604 10235 IF (ISTATE .EQ. 1) GO TO 25 10236 IF (NEQ(1) .GT. N) GO TO 605 10237 25 N = NEQ(1) 10238 IF (ITOL .LT. 1 .OR. ITOL .GT. 4) GO TO 606 10239 IF (IOPT .LT. 0 .OR. IOPT .GT. 1) GO TO 607 10240 METH = MF/10 10241 MITER = MF - 10*METH 10242 IF (METH .LT. 1 .OR. METH .GT. 2) GO TO 608 10243 IF (MITER .LT. 0) GO TO 608 10244 IF (MITER .GT. 4 .AND. MITER .LT. 9) GO TO 608 10245 IF (MITER .GE. 1) JPRE = IWORK(3) 10246 JACFLG = 0 10247 IF (MITER .GE. 1) JACFLG = IWORK(4) 10248 IF (NG .LT. 0) GO TO 630 10249 IF (ISTATE .EQ. 1) GO TO 35 10250 IF (IRFND .EQ. 0 .AND. NG .NE. NGC) GO TO 631 10251 35 NGC = NG 10252 C Next process and check the optional inputs. -------------------------- 10253 IF (IOPT .EQ. 1) GO TO 40 10254 MAXORD = MORD(METH) 10255 MXSTEP = MXSTP0 10256 MXHNIL = MXHNL0 10257 IF (ISTATE .EQ. 1) H0 = 0.0D0 10258 HMXI = 0.0D0 10259 HMIN = 0.0D0 10260 MAXL = MIN(5,N) 10261 KMP = MAXL 10262 DELT = 0.05D0 10263 GO TO 60 10264 40 MAXORD = IWORK(5) 10265 IF (MAXORD .LT. 0) GO TO 611 10266 IF (MAXORD .EQ. 0) MAXORD = 100 10267 MAXORD = MIN(MAXORD,MORD(METH)) 10268 MXSTEP = IWORK(6) 10269 IF (MXSTEP .LT. 0) GO TO 612 10270 IF (MXSTEP .EQ. 0) MXSTEP = MXSTP0 10271 MXHNIL = IWORK(7) 10272 IF (MXHNIL .LT. 0) GO TO 613 10273 IF (MXHNIL .EQ. 0) MXHNIL = MXHNL0 10274 IF (ISTATE .NE. 1) GO TO 50 10275 H0 = RWORK(5) 10276 IF ((TOUT - T)*H0 .LT. 0.0D0) GO TO 614 10277 50 HMAX = RWORK(6) 10278 IF (HMAX .LT. 0.0D0) GO TO 615 10279 HMXI = 0.0D0 10280 IF (HMAX .GT. 0.0D0) HMXI = 1.0D0/HMAX 10281 HMIN = RWORK(7) 10282 IF (HMIN .LT. 0.0D0) GO TO 616 10283 MAXL = IWORK(8) 10284 IF (MAXL .EQ. 0) MAXL = 5 10285 MAXL = MIN(MAXL,N) 10286 KMP = IWORK(9) 10287 IF (KMP .EQ. 0 .OR. KMP .GT. MAXL) KMP = MAXL 10288 DELT = RWORK(8) 10289 IF (DELT .EQ. 0.0D0) DELT = 0.05D0 10290 C----------------------------------------------------------------------- 10291 C Set work array pointers and check lengths LRW and LIW. 10292 C Pointers to segments of RWORK and IWORK are named by prefixing L to 10293 C the name of the segment. E.g., the segment YH starts at RWORK(LYH). 10294 C RWORK segments (in order) are denoted G0, G1, GX, YH, WM, 10295 C EWT, SAVF, SAVX, ACOR. 10296 C----------------------------------------------------------------------- 10297 60 IF (ISTATE .EQ. 1) NYH = N 10298 LG0 = 21 10299 LG1 = LG0 + NG 10300 LGX = LG1 + NG 10301 LYHNEW = LGX + NG 10302 IF (ISTATE .EQ. 1) LYH = LYHNEW 10303 IF (LYHNEW .EQ. LYH) GO TO 62 10304 C If ISTATE = 3 and NG was changed, shift YH to its new location. ------ 10305 LENYH = L*NYH 10306 IF (LRW .LT. LYHNEW-1+LENYH) GO TO 62 10307 I1 = 1 10308 IF (LYHNEW .GT. LYH) I1 = -1 10309 CALL DCOPY (LENYH, RWORK(LYH), I1, RWORK(LYHNEW), I1) 10310 LYH = LYHNEW 10311 62 CONTINUE 10312 LWM = LYH + (MAXORD + 1)*NYH 10313 IF (MITER .EQ. 0) LENWK = 0 10314 IF (MITER .EQ. 1) LENWK = N*(MAXL+2) + MAXL*MAXL 10315 IF (MITER .EQ. 2) 10316 1 LENWK = N*(MAXL+2+MIN(1,MAXL-KMP)) + (MAXL+3)*MAXL + 1 10317 IF (MITER .EQ. 3 .OR. MITER .EQ. 4) LENWK = 5*N 10318 IF (MITER .EQ. 9) LENWK = 2*N 10319 LWP = 0 10320 IF (MITER .GE. 1) LWP = IWORK(1) 10321 LENWM = LENWK + LWP 10322 LOCWP = LENWK + 1 10323 LEWT = LWM + LENWM 10324 LSAVF = LEWT + N 10325 LSAVX = LSAVF + N 10326 LACOR = LSAVX + N 10327 IF (MITER .EQ. 0) LACOR = LSAVF + N 10328 LENRW = LACOR + N - 1 10329 IWORK(17) = LENRW 10330 LIWM = 31 10331 LENIWK = 0 10332 IF (MITER .EQ. 1) LENIWK = MAXL 10333 LIWP = 0 10334 IF (MITER .GE. 1) LIWP = IWORK(2) 10335 LENIW = 30 + LENIWK + LIWP 10336 LOCIWP = LENIWK + 1 10337 IWORK(18) = LENIW 10338 IF (LENRW .GT. LRW) GO TO 617 10339 IF (LENIW .GT. LIW) GO TO 618 10340 C Check RTOL and ATOL for legality. ------------------------------------ 10341 RTOLI = RTOL(1) 10342 ATOLI = ATOL(1) 10343 DO 70 I = 1,N 10344 IF (ITOL .GE. 3) RTOLI = RTOL(I) 10345 IF (ITOL .EQ. 2 .OR. ITOL .EQ. 4) ATOLI = ATOL(I) 10346 IF (RTOLI .LT. 0.0D0) GO TO 619 10347 IF (ATOLI .LT. 0.0D0) GO TO 620 10348 70 CONTINUE 10349 C Load SQRT(N) and its reciprocal in Common. --------------------------- 10350 SQRTN = SQRT(REAL(N)) 10351 RSQRTN = 1.0D0/SQRTN 10352 IF (ISTATE .EQ. 1) GO TO 100 10353 C If ISTATE = 3, set flag to signal parameter changes to DSTOKA.-------- 10354 JSTART = -1 10355 IF (NQ .LE. MAXORD) GO TO 90 10356 C MAXORD was reduced below NQ. Copy YH(*,MAXORD+2) into SAVF. --------- 10357 DO 80 I = 1,N 10358 80 RWORK(I+LSAVF-1) = RWORK(I+LWM-1) 10359 90 CONTINUE 10360 IF (N .EQ. NYH) GO TO 200 10361 C NEQ was reduced. Zero part of YH to avoid undefined references. ----- 10362 I1 = LYH + L*NYH 10363 I2 = LYH + (MAXORD + 1)*NYH - 1 10364 IF (I1 .GT. I2) GO TO 200 10365 DO 95 I = I1,I2 10366 95 RWORK(I) = 0.0D0 10367 GO TO 200 10368 C----------------------------------------------------------------------- 10369 C Block C. 10370 C The next block is for the initial call only (ISTATE = 1). 10371 C It contains all remaining initializations, the initial call to F, 10372 C and the calculation of the initial step size. 10373 C The error weights in EWT are inverted after being loaded. 10374 C----------------------------------------------------------------------- 10375 100 UROUND = DUMACH() 10376 TN = T 10377 IF (ITASK .NE. 4 .AND. ITASK .NE. 5) GO TO 110 10378 TCRIT = RWORK(1) 10379 IF ((TCRIT - TOUT)*(TOUT - T) .LT. 0.0D0) GO TO 625 10380 IF (H0 .NE. 0.0D0 .AND. (T + H0 - TCRIT)*H0 .GT. 0.0D0) 10381 1 H0 = TCRIT - T 10382 110 JSTART = 0 10383 NHNIL = 0 10384 NST = 0 10385 NJE = 0 10386 NSLAST = 0 10387 NLI0 = 0 10388 NNI0 = 0 10389 NCFN0 = 0 10390 NCFL0 = 0 10391 NWARN = 0 10392 HU = 0.0D0 10393 NQU = 0 10394 CCMAX = 0.3D0 10395 MAXCOR = 3 10396 MSBP = 20 10397 MXNCF = 10 10398 NNI = 0 10399 NLI = 0 10400 NPS = 0 10401 NCFN = 0 10402 NCFL = 0 10403 NSFI = 0 10404 NJEV = 0 10405 C Initial call to F. (LF0 points to YH(*,2).) ------------------------- 10406 LF0 = LYH + NYH 10407 CALL F (NEQ, T, Y, RWORK(LF0)) 10408 NFE = 1 10409 C Load the initial value vector in YH. --------------------------------- 10410 DO 115 I = 1,N 10411 115 RWORK(I+LYH-1) = Y(I) 10412 C Load and invert the EWT array. (H is temporarily set to 1.0.) ------- 10413 NQ = 1 10414 H = 1.0D0 10415 CALL DEWSET (N, ITOL, RTOL, ATOL, RWORK(LYH), RWORK(LEWT)) 10416 DO 120 I = 1,N 10417 IF (RWORK(I+LEWT-1) .LE. 0.0D0) GO TO 621 10418 120 RWORK(I+LEWT-1) = 1.0D0/RWORK(I+LEWT-1) 10419 IF (H0 .NE. 0.0D0) GO TO 180 10420 C Call DLHIN to set initial step size H0 to be attempted. -------------- 10421 CALL DLHIN (NEQ, N, T, RWORK(LYH), RWORK(LF0), F, TOUT, UROUND, 10422 1 RWORK(LEWT), ITOL, ATOL, Y, RWORK(LACOR), H0, NITER, IER) 10423 NFE = NFE + NITER 10424 IF (IER .NE. 0) GO TO 622 10425 C Adjust H0 if necessary to meet HMAX bound. --------------------------- 10426 180 RH = ABS(H0)*HMXI 10427 IF (RH .GT. 1.0D0) H0 = H0/RH 10428 C Load H with H0 and scale YH(*,2) by H0. ------------------------------ 10429 H = H0 10430 DO 190 I = 1,N 10431 190 RWORK(I+LF0-1) = H0*RWORK(I+LF0-1) 10432 C Check for a zero of g at T. ------------------------------------------ 10433 IRFND = 0 10434 TOUTC = TOUT 10435 IF (NGC .EQ. 0) GO TO 270 10436 CALL DRCHEK (1, G, NEQ, Y, RWORK(LYH), NYH, 10437 1 RWORK(LG0), RWORK(LG1), RWORK(LGX), JROOT, IRT) 10438 IF (IRT .EQ. 0) GO TO 270 10439 GO TO 632 10440 C----------------------------------------------------------------------- 10441 C Block D. 10442 C The next code block is for continuation calls only (ISTATE = 2 or 3) 10443 C and is to check stop conditions before taking a step. 10444 C First, DRCHEK is called to check for a root within the last step 10445 C taken, other than the last root found there, if any. 10446 C If ITASK = 2 or 5, and y(TN) has not yet been returned to the user 10447 C because of an intervening root, return through Block G. 10448 C----------------------------------------------------------------------- 10449 200 NSLAST = NST 10450 C 10451 IRFP = IRFND 10452 IF (NGC .EQ. 0) GO TO 205 10453 IF (ITASK .EQ. 1 .OR. ITASK .EQ. 4) TOUTC = TOUT 10454 CALL DRCHEK (2, G, NEQ, Y, RWORK(LYH), NYH, 10455 1 RWORK(LG0), RWORK(LG1), RWORK(LGX), JROOT, IRT) 10456 IF (IRT .NE. 1) GO TO 205 10457 IRFND = 1 10458 ISTATE = 3 10459 T = T0 10460 GO TO 425 10461 205 CONTINUE 10462 IRFND = 0 10463 IF (IRFP .EQ. 1 .AND. TLAST .NE. TN .AND. ITASK .EQ. 2) GO TO 400 10464 C 10465 NLI0 = NLI 10466 NNI0 = NNI 10467 NCFN0 = NCFN 10468 NCFL0 = NCFL 10469 NWARN = 0 10470 GO TO (210, 250, 220, 230, 240), ITASK 10471 210 IF ((TN - TOUT)*H .LT. 0.0D0) GO TO 250 10472 CALL DINTDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) 10473 IF (IFLAG .NE. 0) GO TO 627 10474 T = TOUT 10475 GO TO 420 10476 220 TP = TN - HU*(1.0D0 + 100.0D0*UROUND) 10477 IF ((TP - TOUT)*H .GT. 0.0D0) GO TO 623 10478 IF ((TN - TOUT)*H .LT. 0.0D0) GO TO 250 10479 GO TO 400 10480 230 TCRIT = RWORK(1) 10481 IF ((TN - TCRIT)*H .GT. 0.0D0) GO TO 624 10482 IF ((TCRIT - TOUT)*H .LT. 0.0D0) GO TO 625 10483 IF ((TN - TOUT)*H .LT. 0.0D0) GO TO 245 10484 CALL DINTDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) 10485 IF (IFLAG .NE. 0) GO TO 627 10486 T = TOUT 10487 GO TO 420 10488 240 TCRIT = RWORK(1) 10489 IF ((TN - TCRIT)*H .GT. 0.0D0) GO TO 624 10490 245 HMX = ABS(TN) + ABS(H) 10491 IHIT = ABS(TN - TCRIT) .LE. 100.0D0*UROUND*HMX 10492 IF (IHIT) T = TCRIT 10493 IF (IRFP .EQ. 1 .AND. TLAST .NE. TN .AND. ITASK .EQ. 5) GO TO 400 10494 IF (IHIT) GO TO 400 10495 TNEXT = TN + H*(1.0D0 + 4.0D0*UROUND) 10496 IF ((TNEXT - TCRIT)*H .LE. 0.0D0) GO TO 250 10497 H = (TCRIT - TN)*(1.0D0 - 4.0D0*UROUND) 10498 IF (ISTATE .EQ. 2) JSTART = -2 10499 C----------------------------------------------------------------------- 10500 C Block E. 10501 C The next block is normally executed for all calls and contains 10502 C the call to the one-step core integrator DSTOKA. 10503 C 10504 C This is a looping point for the integration steps. 10505 C 10506 C First check for too many steps being taken, 10507 C check for poor Newton/Krylov method performance, update EWT (if not 10508 C at start of problem), check for too much accuracy being requested, 10509 C and check for H below the roundoff level in T. 10510 C----------------------------------------------------------------------- 10511 250 CONTINUE 10512 IF ((NST-NSLAST) .GE. MXSTEP) GO TO 500 10513 NSTD = NST - NSLAST 10514 NNID = NNI - NNI0 10515 IF (NSTD .LT. 10 .OR. NNID .EQ. 0) GO TO 255 10516 AVDIM = REAL(NLI - NLI0)/REAL(NNID) 10517 RCFN = REAL(NCFN - NCFN0)/REAL(NSTD) 10518 RCFL = REAL(NCFL - NCFL0)/REAL(NNID) 10519 LAVD = AVDIM .GT. (MAXL - 0.05D0) 10520 LCFN = RCFN .GT. 0.9D0 10521 LCFL = RCFL .GT. 0.9D0 10522 LWARN = LAVD .OR. LCFN .OR. LCFL 10523 IF (.NOT.LWARN) GO TO 255 10524 NWARN = NWARN + 1 10525 IF (NWARN .GT. 10) GO TO 255 10526 IF (LAVD) THEN 10527 MSG='DLSODKR- Warning. Poor iterative algorithm performance seen ' 10528 CALL XERRWD (MSG, 60, 111, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 10529 ENDIF 10530 IF (LAVD) THEN 10531 MSG=' at T = R1 by average no. of linear iterations = R2 ' 10532 CALL XERRWD (MSG, 60, 111, 0, 0, 0, 0, 2, TN, AVDIM) 10533 ENDIF 10534 IF (LCFN) THEN 10535 MSG='DLSODKR- Warning. Poor iterative algorithm performance seen ' 10536 CALL XERRWD (MSG, 60, 112, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 10537 ENDIF 10538 IF (LCFN) THEN 10539 MSG=' at T = R1 by nonlinear convergence failure rate = R2 ' 10540 CALL XERRWD (MSG, 60, 112, 0, 0, 0, 0, 2, TN, RCFN) 10541 ENDIF 10542 IF (LCFL) THEN 10543 MSG='DLSODKR- Warning. Poor iterative algorithm performance seen ' 10544 CALL XERRWD (MSG, 60, 113, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 10545 ENDIF 10546 IF (LCFL) THEN 10547 MSG=' at T = R1 by linear convergence failure rate = R2 ' 10548 CALL XERRWD (MSG, 60, 113, 0, 0, 0, 0, 2, TN, RCFL) 10549 ENDIF 10550 255 CONTINUE 10551 CALL DEWSET (N, ITOL, RTOL, ATOL, RWORK(LYH), RWORK(LEWT)) 10552 DO 260 I = 1,N 10553 IF (RWORK(I+LEWT-1) .LE. 0.0D0) GO TO 510 10554 260 RWORK(I+LEWT-1) = 1.0D0/RWORK(I+LEWT-1) 10555 270 TOLSF = UROUND*DVNORM (N, RWORK(LYH), RWORK(LEWT)) 10556 IF (TOLSF .LE. 1.0D0) GO TO 280 10557 TOLSF = TOLSF*2.0D0 10558 IF (NST .EQ. 0) GO TO 626 10559 GO TO 520 10560 280 IF ((TN + H) .NE. TN) GO TO 290 10561 NHNIL = NHNIL + 1 10562 IF (NHNIL .GT. MXHNIL) GO TO 290 10563 MSG = 'DLSODKR- Warning.. Internal T(=R1) and H(=R2) are' 10564 CALL XERRWD (MSG, 50, 101, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 10565 MSG=' such that in the machine, T + H = T on the next step ' 10566 CALL XERRWD (MSG, 60, 101, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 10567 MSG = ' (H = step size). Solver will continue anyway.' 10568 CALL XERRWD (MSG, 50, 101, 0, 0, 0, 0, 2, TN, H) 10569 IF (NHNIL .LT. MXHNIL) GO TO 290 10570 MSG = 'DLSODKR- Above warning has been issued I1 times. ' 10571 CALL XERRWD (MSG, 50, 102, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 10572 MSG = ' It will not be issued again for this problem.' 10573 CALL XERRWD (MSG, 50, 102, 0, 1, MXHNIL, 0, 0, 0.0D0, 0.0D0) 10574 290 CONTINUE 10575 C----------------------------------------------------------------------- 10576 C CALL DSTOKA(NEQ,Y,YH,NYH,YH,EWT,SAVF,SAVX,ACOR,WM,IWM,F,JAC,PSOL) 10577 C----------------------------------------------------------------------- 10578 CALL DSTOKA (NEQ, Y, RWORK(LYH), NYH, RWORK(LYH), RWORK(LEWT), 10579 1 RWORK(LSAVF), RWORK(LSAVX), RWORK(LACOR), RWORK(LWM), 10580 2 IWORK(LIWM), F, JAC, PSOL) 10581 KGO = 1 - KFLAG 10582 GO TO (300, 530, 540, 550), KGO 10583 C----------------------------------------------------------------------- 10584 C Block F. 10585 C The following block handles the case of a successful return from the 10586 C core integrator (KFLAG = 0). 10587 C Call DRCHEK to check for a root within the last step. 10588 C Then, if no root was found, check for stop conditions. 10589 C----------------------------------------------------------------------- 10590 300 INIT = 1 10591 C 10592 IF (NGC .EQ. 0) GO TO 315 10593 CALL DRCHEK (3, G, NEQ, Y, RWORK(LYH), NYH, 10594 1 RWORK(LG0), RWORK(LG1), RWORK(LGX), JROOT, IRT) 10595 IF (IRT .NE. 1) GO TO 315 10596 IRFND = 1 10597 ISTATE = 3 10598 T = T0 10599 GO TO 425 10600 315 CONTINUE 10601 C 10602 GO TO (310, 400, 330, 340, 350), ITASK 10603 C ITASK = 1. If TOUT has been reached, interpolate. ------------------- 10604 310 IF ((TN - TOUT)*H .LT. 0.0D0) GO TO 250 10605 CALL DINTDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) 10606 T = TOUT 10607 GO TO 420 10608 C ITASK = 3. Jump to exit if TOUT was reached. ------------------------ 10609 330 IF ((TN - TOUT)*H .GE. 0.0D0) GO TO 400 10610 GO TO 250 10611 C ITASK = 4. See if TOUT or TCRIT was reached. Adjust H if necessary. 10612 340 IF ((TN - TOUT)*H .LT. 0.0D0) GO TO 345 10613 CALL DINTDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) 10614 T = TOUT 10615 GO TO 420 10616 345 HMX = ABS(TN) + ABS(H) 10617 IHIT = ABS(TN - TCRIT) .LE. 100.0D0*UROUND*HMX 10618 IF (IHIT) GO TO 400 10619 TNEXT = TN + H*(1.0D0 + 4.0D0*UROUND) 10620 IF ((TNEXT - TCRIT)*H .LE. 0.0D0) GO TO 250 10621 H = (TCRIT - TN)*(1.0D0 - 4.0D0*UROUND) 10622 JSTART = -2 10623 GO TO 250 10624 C ITASK = 5. See if TCRIT was reached and jump to exit. --------------- 10625 350 HMX = ABS(TN) + ABS(H) 10626 IHIT = ABS(TN - TCRIT) .LE. 100.0D0*UROUND*HMX 10627 C----------------------------------------------------------------------- 10628 C Block G. 10629 C The following block handles all successful returns from DLSODKR. 10630 C If ITASK .ne. 1, Y is loaded from YH and T is set accordingly. 10631 C ISTATE is set to 2, and the optional outputs are loaded into the 10632 C work arrays before returning. 10633 C----------------------------------------------------------------------- 10634 400 DO 410 I = 1,N 10635 410 Y(I) = RWORK(I+LYH-1) 10636 T = TN 10637 IF (ITASK .NE. 4 .AND. ITASK .NE. 5) GO TO 420 10638 IF (IHIT) T = TCRIT 10639 420 ISTATE = 2 10640 425 CONTINUE 10641 RWORK(11) = HU 10642 RWORK(12) = H 10643 RWORK(13) = TN 10644 IWORK(11) = NST 10645 IWORK(12) = NFE 10646 IWORK(13) = NJE 10647 IWORK(14) = NQU 10648 IWORK(15) = NQ 10649 IWORK(19) = NNI 10650 IWORK(20) = NLI 10651 IWORK(21) = NPS 10652 IWORK(22) = NCFN 10653 IWORK(23) = NCFL 10654 IWORK(24) = NSFI 10655 IWORK(25) = NJEV 10656 IWORK(10) = NGE 10657 TLAST = T 10658 RETURN 10659 C----------------------------------------------------------------------- 10660 C Block H. 10661 C The following block handles all unsuccessful returns other than 10662 C those for illegal input. First the error message routine is called. 10663 C If there was an error test or convergence test failure, IMXER is set. 10664 C Then Y is loaded from YH and T is set to TN. 10665 C The optional outputs are loaded into the work arrays before returning. 10666 C----------------------------------------------------------------------- 10667 C The maximum number of steps was taken before reaching TOUT. ---------- 10668 500 MSG = 'DLSODKR- At current T (=R1), MXSTEP (=I1) steps ' 10669 CALL XERRWD (MSG, 50, 201, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 10670 MSG = ' taken on this call before reaching TOUT ' 10671 CALL XERRWD (MSG, 50, 201, 0, 1, MXSTEP, 0, 1, TN, 0.0D0) 10672 ISTATE = -1 10673 GO TO 580 10674 C EWT(i) .le. 0.0 for some i (not at start of problem). ---------------- 10675 510 EWTI = RWORK(LEWT+I-1) 10676 MSG = 'DLSODKR- At T(=R1), EWT(I1) has become R2 .le. 0.' 10677 CALL XERRWD (MSG, 50, 202, 0, 1, I, 0, 2, TN, EWTI) 10678 ISTATE = -6 10679 GO TO 580 10680 C Too much accuracy requested for machine precision. ------------------- 10681 520 MSG = 'DLSODKR- At T (=R1), too much accuracy requested ' 10682 CALL XERRWD (MSG, 50, 203, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 10683 MSG = ' for precision of machine.. See TOLSF (=R2) ' 10684 CALL XERRWD (MSG, 50, 203, 0, 0, 0, 0, 2, TN, TOLSF) 10685 RWORK(14) = TOLSF 10686 ISTATE = -2 10687 GO TO 580 10688 C KFLAG = -1. Error test failed repeatedly or with ABS(H) = HMIN. ----- 10689 530 MSG = 'DLSODKR- At T(=R1) and step size H(=R2), the error' 10690 CALL XERRWD (MSG, 50, 204, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 10691 MSG = ' test failed repeatedly or with ABS(H) = HMIN' 10692 CALL XERRWD (MSG, 50, 204, 0, 0, 0, 0, 2, TN, H) 10693 ISTATE = -4 10694 GO TO 560 10695 C KFLAG = -2. Convergence failed repeatedly or with ABS(H) = HMIN. ---- 10696 540 MSG = 'DLSODKR- At T (=R1) and step size H (=R2), the ' 10697 CALL XERRWD (MSG, 50, 205, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 10698 MSG = ' corrector convergence failed repeatedly ' 10699 CALL XERRWD (MSG, 50, 205, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 10700 MSG = ' or with ABS(H) = HMIN ' 10701 CALL XERRWD (MSG, 30, 205, 0, 0, 0, 0, 2, TN, H) 10702 ISTATE = -5 10703 GO TO 580 10704 C KFLAG = -3. Unrecoverable error from PSOL. -------------------------- 10705 550 MSG = 'DLSODKR- At T (=R1) an unrecoverable error return' 10706 CALL XERRWD (MSG, 50, 206, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 10707 MSG = ' was made from Subroutine PSOL ' 10708 CALL XERRWD (MSG, 40, 206, 0, 0, 0, 0, 1, TN, 0.0D0) 10709 ISTATE = -7 10710 GO TO 580 10711 C Compute IMXER if relevant. ------------------------------------------- 10712 560 BIG = 0.0D0 10713 IMXER = 1 10714 DO 570 I = 1,N 10715 SIZE = ABS(RWORK(I+LACOR-1)*RWORK(I+LEWT-1)) 10716 IF (BIG .GE. SIZE) GO TO 570 10717 BIG = SIZE 10718 IMXER = I 10719 570 CONTINUE 10720 IWORK(16) = IMXER 10721 C Set Y vector, T, and optional outputs. ------------------------------- 10722 580 DO 590 I = 1,N 10723 590 Y(I) = RWORK(I+LYH-1) 10724 T = TN 10725 RWORK(11) = HU 10726 RWORK(12) = H 10727 RWORK(13) = TN 10728 IWORK(11) = NST 10729 IWORK(12) = NFE 10730 IWORK(13) = NJE 10731 IWORK(14) = NQU 10732 IWORK(15) = NQ 10733 IWORK(19) = NNI 10734 IWORK(20) = NLI 10735 IWORK(21) = NPS 10736 IWORK(22) = NCFN 10737 IWORK(23) = NCFL 10738 IWORK(24) = NSFI 10739 IWORK(25) = NJEV 10740 IWORK(10) = NGE 10741 TLAST = T 10742 RETURN 10743 C----------------------------------------------------------------------- 10744 C Block I. 10745 C The following block handles all error returns due to illegal input 10746 C (ISTATE = -3), as detected before calling the core integrator. 10747 C First the error message routine is called. If the illegal input 10748 C is a negative ISTATE, the run is aborted (apparent infinite loop). 10749 C----------------------------------------------------------------------- 10750 601 MSG = 'DLSODKR- ISTATE(=I1) illegal.' 10751 CALL XERRWD (MSG, 30, 1, 0, 1, ISTATE, 0, 0, 0.0D0, 0.0D0) 10752 IF (ISTATE .LT. 0) GO TO 800 10753 GO TO 700 10754 602 MSG = 'DLSODKR- ITASK (=I1) illegal.' 10755 CALL XERRWD (MSG, 30, 2, 0, 1, ITASK, 0, 0, 0.0D0, 0.0D0) 10756 GO TO 700 10757 603 MSG = 'DLSODKR- ISTATE.gt.1 but DLSODKR not initialized. ' 10758 CALL XERRWD (MSG, 50, 3, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 10759 GO TO 700 10760 604 MSG = 'DLSODKR- NEQ (=I1) .lt. 1 ' 10761 CALL XERRWD (MSG, 30, 4, 0, 1, NEQ(1), 0, 0, 0.0D0, 0.0D0) 10762 GO TO 700 10763 605 MSG = 'DLSODKR- ISTATE = 3 and NEQ increased (I1 to I2).' 10764 CALL XERRWD (MSG, 50, 5, 0, 2, N, NEQ(1), 0, 0.0D0, 0.0D0) 10765 GO TO 700 10766 606 MSG = 'DLSODKR- ITOL (=I1) illegal. ' 10767 CALL XERRWD (MSG, 30, 6, 0, 1, ITOL, 0, 0, 0.0D0, 0.0D0) 10768 GO TO 700 10769 607 MSG = 'DLSODKR- IOPT (=I1) illegal. ' 10770 CALL XERRWD (MSG, 30, 7, 0, 1, IOPT, 0, 0, 0.0D0, 0.0D0) 10771 GO TO 700 10772 608 MSG = 'DLSODKR- MF (=I1) illegal. ' 10773 CALL XERRWD (MSG, 30, 8, 0, 1, MF, 0, 0, 0.0D0, 0.0D0) 10774 GO TO 700 10775 611 MSG = 'DLSODKR- MAXORD (=I1) .lt. 0 ' 10776 CALL XERRWD (MSG, 30, 11, 0, 1, MAXORD, 0, 0, 0.0D0, 0.0D0) 10777 GO TO 700 10778 612 MSG = 'DLSODKR- MXSTEP (=I1) .lt. 0 ' 10779 CALL XERRWD (MSG, 30, 12, 0, 1, MXSTEP, 0, 0, 0.0D0, 0.0D0) 10780 GO TO 700 10781 613 MSG = 'DLSODKR- MXHNIL (=I1) .lt. 0 ' 10782 CALL XERRWD (MSG, 30, 13, 0, 1, MXHNIL, 0, 0, 0.0D0, 0.0D0) 10783 GO TO 700 10784 614 MSG = 'DLSODKR- TOUT (=R1) behind T (=R2) ' 10785 CALL XERRWD (MSG, 40, 14, 0, 0, 0, 0, 2, TOUT, T) 10786 MSG = ' Integration direction is given by H0 (=R1) ' 10787 CALL XERRWD (MSG, 50, 14, 0, 0, 0, 0, 1, H0, 0.0D0) 10788 GO TO 700 10789 615 MSG = 'DLSODKR- HMAX (=R1) .lt. 0.0 ' 10790 CALL XERRWD (MSG, 30, 15, 0, 0, 0, 0, 1, HMAX, 0.0D0) 10791 GO TO 700 10792 616 MSG = 'DLSODKR- HMIN (=R1) .lt. 0.0 ' 10793 CALL XERRWD (MSG, 30, 16, 0, 0, 0, 0, 1, HMIN, 0.0D0) 10794 GO TO 700 10795 617 MSG='DLSODKR- RWORK length needed, LENRW(=I1), exceeds LRW(=I2) ' 10796 CALL XERRWD (MSG, 60, 17, 0, 2, LENRW, LRW, 0, 0.0D0, 0.0D0) 10797 GO TO 700 10798 618 MSG='DLSODKR- IWORK length needed, LENIW(=I1), exceeds LIW(=I2) ' 10799 CALL XERRWD (MSG, 60, 18, 0, 2, LENIW, LIW, 0, 0.0D0, 0.0D0) 10800 GO TO 700 10801 619 MSG = 'DLSODKR- RTOL(I1) is R1 .lt. 0.0 ' 10802 CALL XERRWD (MSG, 40, 19, 0, 1, I, 0, 1, RTOLI, 0.0D0) 10803 GO TO 700 10804 620 MSG = 'DLSODKR- ATOL(I1) is R1 .lt. 0.0 ' 10805 CALL XERRWD (MSG, 40, 20, 0, 1, I, 0, 1, ATOLI, 0.0D0) 10806 GO TO 700 10807 621 EWTI = RWORK(LEWT+I-1) 10808 MSG = 'DLSODKR- EWT(I1) is R1 .le. 0.0 ' 10809 CALL XERRWD (MSG, 40, 21, 0, 1, I, 0, 1, EWTI, 0.0D0) 10810 GO TO 700 10811 622 MSG='DLSODKR- TOUT(=R1) too close to T(=R2) to start integration.' 10812 CALL XERRWD (MSG, 60, 22, 0, 0, 0, 0, 2, TOUT, T) 10813 GO TO 700 10814 623 MSG='DLSODKR- ITASK = I1 and TOUT (=R1) behind TCUR - HU (= R2) ' 10815 CALL XERRWD (MSG, 60, 23, 0, 1, ITASK, 0, 2, TOUT, TP) 10816 GO TO 700 10817 624 MSG='DLSODKR- ITASK = 4 or 5 and TCRIT (=R1) behind TCUR (=R2) ' 10818 CALL XERRWD (MSG, 60, 24, 0, 0, 0, 0, 2, TCRIT, TN) 10819 GO TO 700 10820 625 MSG='DLSODKR- ITASK = 4 or 5 and TCRIT (=R1) behind TOUT (=R2) ' 10821 CALL XERRWD (MSG, 60, 25, 0, 0, 0, 0, 2, TCRIT, TOUT) 10822 GO TO 700 10823 626 MSG = 'DLSODKR- At start of problem, too much accuracy ' 10824 CALL XERRWD (MSG, 50, 26, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 10825 MSG=' requested for precision of machine.. See TOLSF (=R1) ' 10826 CALL XERRWD (MSG, 60, 26, 0, 0, 0, 0, 1, TOLSF, 0.0D0) 10827 RWORK(14) = TOLSF 10828 GO TO 700 10829 627 MSG = 'DLSODKR- Trouble in DINTDY. ITASK = I1, TOUT = R1' 10830 CALL XERRWD (MSG, 50, 27, 0, 1, ITASK, 0, 1, TOUT, 0.0D0) 10831 GO TO 700 10832 630 MSG = 'DLSODKR- NG (=I1) .lt. 0 ' 10833 CALL XERRWD (MSG, 30, 30, 0, 1, NG, 0, 0, 0.0D0, 0.0D0) 10834 GO TO 700 10835 631 MSG = 'DLSODKR- NG changed (from I1 to I2) illegally, ' 10836 CALL XERRWD (MSG, 50, 31, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 10837 MSG = ' i.e. not immediately after a root was found.' 10838 CALL XERRWD (MSG, 50, 31, 0, 2, NGC, NG, 0, 0.0D0, 0.0D0) 10839 GO TO 700 10840 632 MSG = 'DLSODKR- One or more components of g has a root ' 10841 CALL XERRWD (MSG, 50, 32, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 10842 MSG = ' too near to the initial point. ' 10843 CALL XERRWD (MSG, 40, 32, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 10844 C 10845 700 ISTATE = -3 10846 RETURN 10847 C 10848 800 MSG = 'DLSODKR- Run aborted.. apparent infinite loop. ' 10849 CALL XERRWD (MSG, 50, 303, 2, 0, 0, 0, 0, 0.0D0, 0.0D0) 10850 RETURN 10851 C----------------------- End of Subroutine DLSODKR --------------------- 10852 END 10853 *DECK DLSODI 10854 SUBROUTINE DLSODI (RES, ADDA, JAC, NEQ, Y, YDOTI, T, TOUT, ITOL, 10855 1 RTOL, ATOL, ITASK, ISTATE, IOPT, RWORK, LRW, IWORK, LIW, MF ) 10856 EXTERNAL RES, ADDA, JAC 10857 INTEGER NEQ, ITOL, ITASK, ISTATE, IOPT, LRW, IWORK, LIW, MF 10858 DOUBLE PRECISION Y, YDOTI, T, TOUT, RTOL, ATOL, RWORK 10859 DIMENSION NEQ(*), Y(*), YDOTI(*), RTOL(*), ATOL(*), RWORK(LRW), 10860 1 IWORK(LIW) 10861 C----------------------------------------------------------------------- 10862 C This is the 18 November 2003 version of 10863 C DLSODI: Livermore Solver for Ordinary Differential Equations 10864 C (Implicit form). 10865 C 10866 C This version is in double precision. 10867 C 10868 C DLSODI solves the initial value problem for linearly implicit 10869 C systems of first order ODEs, 10870 C A(t,y) * dy/dt = g(t,y) , where A(t,y) is a square matrix, 10871 C or, in component form, 10872 C ( a * ( dy / dt )) + ... + ( a * ( dy / dt )) = 10873 C i,1 1 i,NEQ NEQ 10874 C 10875 C = g ( t, y , y ,..., y ) ( i = 1,...,NEQ ) 10876 C i 1 2 NEQ 10877 C 10878 C If A is singular, this is a differential-algebraic system. 10879 C 10880 C DLSODI is a variant version of the DLSODE package. 10881 C----------------------------------------------------------------------- 10882 C Reference: 10883 C Alan C. Hindmarsh, ODEPACK, A Systematized Collection of ODE 10884 C Solvers, in Scientific Computing, R. S. Stepleman et al. (Eds.), 10885 C North-Holland, Amsterdam, 1983, pp. 55-64. 10886 C----------------------------------------------------------------------- 10887 C Authors: Alan C. Hindmarsh and Jeffrey F. Painter 10888 C Center for Applied Scientific Computing, L-561 10889 C Lawrence Livermore National Laboratory 10890 C Livermore, CA 94551 10891 C----------------------------------------------------------------------- 10892 C Summary of Usage. 10893 C 10894 C Communication between the user and the DLSODI package, for normal 10895 C situations, is summarized here. This summary describes only a subset 10896 C of the full set of options available. See the full description for 10897 C details, including optional communication, nonstandard options, 10898 C and instructions for special situations. See also the example 10899 C problem (with program and output) following this summary. 10900 C 10901 C A. First, provide a subroutine of the form: 10902 C SUBROUTINE RES (NEQ, T, Y, S, R, IRES) 10903 C DOUBLE PRECISION T, Y(*), S(*), R(*) 10904 C which computes the residual function 10905 C r = g(t,y) - A(t,y) * s , 10906 C as a function of t and the vectors y and s. (s is an internally 10907 C generated approximation to dy/dt.) The arrays Y and S are inputs 10908 C to the RES routine and should not be altered. The residual 10909 C vector is to be stored in the array R. The argument IRES should be 10910 C ignored for casual use of DLSODI. (For uses of IRES, see the 10911 C paragraph on RES in the full description below.) 10912 C 10913 C B. Next, decide whether full or banded form is more economical 10914 C for the storage of matrices. DLSODI must deal internally with the 10915 C matrices A and dr/dy, where r is the residual function defined above. 10916 C DLSODI generates a linear combination of these two matrices, and 10917 C this is treated in either full or banded form. 10918 C The matrix structure is communicated by a method flag MF, 10919 C which is 21 or 22 for the full case, and 24 or 25 in the band case. 10920 C In the banded case, DLSODI requires two half-bandwidth 10921 C parameters ML and MU. These are, respectively, the widths of the 10922 C lower and upper parts of the band, excluding the main diagonal. 10923 C Thus the band consists of the locations (i,j) with 10924 C i-ML .le. j .le. i+MU, and the full bandwidth is ML+MU+1. 10925 C Note that the band must accommodate the nonzero elements of 10926 C A(t,y), dg/dy, and d(A*s)/dy (s fixed). Alternatively, one 10927 C can define a band that encloses only the elements that are relatively 10928 C large in magnitude, and gain some economy in storage and possibly 10929 C also efficiency, although the appropriate threshhold for 10930 C retaining matrix elements is highly problem-dependent. 10931 C 10932 C C. You must also provide a subroutine of the form: 10933 C SUBROUTINE ADDA (NEQ, T, Y, ML, MU, P, NROWP) 10934 C DOUBLE PRECISION T, Y(*), P(NROWP,*) 10935 C which adds the matrix A = A(t,y) to the contents of the array P. 10936 C T and the Y array are input and should not be altered. 10937 C In the full matrix case, this routine should add elements of 10938 C to P in the usual order. I.e., add A(i,j) to P(i,j). (Ignore the 10939 C ML and MU arguments in this case.) 10940 C In the band matrix case, this routine should add element A(i,j) 10941 C to P(i-j+MU+1,j). I.e., add the diagonal lines of A to the rows of 10942 C P from the top down (the top line of A added to the first row of P). 10943 C 10944 C D. For the sake of efficiency, you are encouraged to supply the 10945 C Jacobian matrix dr/dy in closed form, where r = g(t,y) - A(t,y)*s 10946 C (s = a fixed vector) as above. If dr/dy is being supplied, 10947 C use MF = 21 or 24, and provide a subroutine of the form: 10948 C SUBROUTINE JAC (NEQ, T, Y, S, ML, MU, P, NROWP) 10949 C DOUBLE PRECISION T, Y(*), S(*), P(NROWP,*) 10950 C which computes dr/dy as a function of t, y, and s. Here T, Y, and 10951 C S are inputs, and the routine is to load dr/dy into P as follows: 10952 C In the full matrix case (MF = 21), load P(i,j) with dr(i)/dy(j), 10953 C the partial derivative of r(i) with respect to y(j). (Ignore the 10954 C ML and MU arguments in this case.) 10955 C In the band matrix case (MF = 24), load P(i-j+mu+1,j) with 10956 C dr(i)/dy(j), i.e. load the diagonal lines of dr/dy into the rows of 10957 C P from the top down. 10958 C In either case, only nonzero elements need be loaded, and the 10959 C indexing of P is the same as in the ADDA routine. 10960 C Note that if A is independent of y (or this dependence 10961 C is weak enough to be ignored) then JAC is to compute dg/dy. 10962 C If it is not feasible to provide a JAC routine, use 10963 C MF = 22 or 25, and DLSODI will compute an approximate Jacobian 10964 C internally by difference quotients. 10965 C 10966 C E. Next decide whether or not to provide the initial value of the 10967 C derivative vector dy/dt. If the initial value of A(t,y) is 10968 C nonsingular (and not too ill-conditioned), you may let DLSODI compute 10969 C this vector (ISTATE = 0). (DLSODI will solve the system A*s = g for 10970 C s, with initial values of A and g.) If A(t,y) is initially 10971 C singular, then the system is a differential-algebraic system, and 10972 C you must make use of the particular form of the system to compute the 10973 C initial values of y and dy/dt. In that case, use ISTATE = 1 and 10974 C load the initial value of dy/dt into the array YDOTI. 10975 C The input array YDOTI and the initial Y array must be consistent with 10976 C the equations A*dy/dt = g. This implies that the initial residual 10977 C r = g(t,y) - A(t,y)*YDOTI must be approximately zero. 10978 C 10979 C F. Write a main program which calls Subroutine DLSODI once for 10980 C each point at which answers are desired. This should also provide 10981 C for possible use of logical unit 6 for output of error messages 10982 C by DLSODI. On the first call to DLSODI, supply arguments as follows: 10983 C RES = name of user subroutine for residual function r. 10984 C ADDA = name of user subroutine for computing and adding A(t,y). 10985 C JAC = name of user subroutine for Jacobian matrix dr/dy 10986 C (MF = 21 or 24). If not used, pass a dummy name. 10987 C Note: the names for the RES and ADDA routines and (if used) the 10988 C JAC routine must be declared External in the calling program. 10989 C NEQ = number of scalar equations in the system. 10990 C Y = array of initial values, of length NEQ. 10991 C YDOTI = array of length NEQ (containing initial dy/dt if ISTATE = 1). 10992 C T = the initial value of the independent variable. 10993 C TOUT = first point where output is desired (.ne. T). 10994 C ITOL = 1 or 2 according as ATOL (below) is a scalar or array. 10995 C RTOL = relative tolerance parameter (scalar). 10996 C ATOL = absolute tolerance parameter (scalar or array). 10997 C the estimated local error in y(i) will be controlled so as 10998 C to be roughly less (in magnitude) than 10999 C EWT(i) = RTOL*ABS(Y(i)) + ATOL if ITOL = 1, or 11000 C EWT(i) = RTOL*ABS(Y(i)) + ATOL(i) if ITOL = 2. 11001 C Thus the local error test passes if, in each component, 11002 C either the absolute error is less than ATOL (or ATOL(i)), 11003 C or the relative error is less than RTOL. 11004 C Use RTOL = 0.0 for pure absolute error control, and 11005 C use ATOL = 0.0 (or ATOL(i) = 0.0) for pure relative error 11006 C control. Caution: Actual (global) errors may exceed these 11007 C local tolerances, so choose them conservatively. 11008 C ITASK = 1 for normal computation of output values of y at t = TOUT. 11009 C ISTATE = integer flag (input and output). Set ISTATE = 1 if the 11010 C initial dy/dt is supplied, and 0 otherwise. 11011 C IOPT = 0 to indicate no optional inputs used. 11012 C RWORK = real work array of length at least: 11013 C 22 + 9*NEQ + NEQ**2 for MF = 21 or 22, 11014 C 22 + 10*NEQ + (2*ML + MU)*NEQ for MF = 24 or 25. 11015 C LRW = declared length of RWORK (in user's dimension). 11016 C IWORK = integer work array of length at least 20 + NEQ. 11017 C If MF = 24 or 25, input in IWORK(1),IWORK(2) the lower 11018 C and upper half-bandwidths ML,MU. 11019 C LIW = declared length of IWORK (in user's dimension). 11020 C MF = method flag. Standard values are: 11021 C 21 for a user-supplied full Jacobian. 11022 C 22 for an internally generated full Jacobian. 11023 C 24 for a user-supplied banded Jacobian. 11024 C 25 for an internally generated banded Jacobian. 11025 C for other choices of MF, see the paragraph on MF in 11026 C the full description below. 11027 C Note that the main program must declare arrays Y, YDOTI, RWORK, IWORK, 11028 C and possibly ATOL. 11029 C 11030 C G. The output from the first call (or any call) is: 11031 C Y = array of computed values of y(t) vector. 11032 C T = corresponding value of independent variable (normally TOUT). 11033 C ISTATE = 2 if DLSODI was successful, negative otherwise. 11034 C -1 means excess work done on this call (check all inputs). 11035 C -2 means excess accuracy requested (tolerances too small). 11036 C -3 means illegal input detected (see printed message). 11037 C -4 means repeated error test failures (check all inputs). 11038 C -5 means repeated convergence failures (perhaps bad Jacobian 11039 C supplied or wrong choice of tolerances). 11040 C -6 means error weight became zero during problem. (Solution 11041 C component i vanished, and ATOL or ATOL(i) = 0.) 11042 C -7 cannot occur in casual use. 11043 C -8 means DLSODI was unable to compute the initial dy/dt. 11044 C In casual use, this means A(t,y) is initially singular. 11045 C Supply YDOTI and use ISTATE = 1 on the first call. 11046 C 11047 C If DLSODI returns ISTATE = -1, -4, or -5, then the output of 11048 C DLSODI also includes YDOTI = array containing residual vector 11049 C r = g - A * dy/dt evaluated at the current t, y, and dy/dt. 11050 C 11051 C H. To continue the integration after a successful return, simply 11052 C reset TOUT and call DLSODI again. No other parameters need be reset. 11053 C 11054 C----------------------------------------------------------------------- 11055 C Example Problem. 11056 C 11057 C The following is a simple example problem, with the coding 11058 C needed for its solution by DLSODI. The problem is from chemical 11059 C kinetics, and consists of the following three equations: 11060 C dy1/dt = -.04*y1 + 1.e4*y2*y3 11061 C dy2/dt = .04*y1 - 1.e4*y2*y3 - 3.e7*y2**2 11062 C 0. = y1 + y2 + y3 - 1. 11063 C on the interval from t = 0.0 to t = 4.e10, with initial conditions 11064 C y1 = 1.0, y2 = y3 = 0. 11065 C 11066 C The following coding solves this problem with DLSODI, using MF = 21 11067 C and printing results at t = .4, 4., ..., 4.e10. It uses 11068 C ITOL = 2 and ATOL much smaller for y2 than y1 or y3 because 11069 C y2 has much smaller values. dy/dt is supplied in YDOTI. We had 11070 C obtained the initial value of dy3/dt by differentiating the 11071 C third equation and evaluating the first two at t = 0. 11072 C At the end of the run, statistical quantities of interest are 11073 C printed (see optional outputs in the full description below). 11074 C 11075 C EXTERNAL RESID, APLUSP, DGBYDY 11076 C DOUBLE PRECISION ATOL, RTOL, RWORK, T, TOUT, Y, YDOTI 11077 C DIMENSION Y(3), YDOTI(3), ATOL(3), RWORK(58), IWORK(23) 11078 C NEQ = 3 11079 C Y(1) = 1. 11080 C Y(2) = 0. 11081 C Y(3) = 0. 11082 C YDOTI(1) = -.04 11083 C YDOTI(2) = .04 11084 C YDOTI(3) = 0. 11085 C T = 0. 11086 C TOUT = .4 11087 C ITOL = 2 11088 C RTOL = 1.D-4 11089 C ATOL(1) = 1.D-6 11090 C ATOL(2) = 1.D-10 11091 C ATOL(3) = 1.D-6 11092 C ITASK = 1 11093 C ISTATE = 1 11094 C IOPT = 0 11095 C LRW = 58 11096 C LIW = 23 11097 C MF = 21 11098 C DO 40 IOUT = 1,12 11099 C CALL DLSODI(RESID, APLUSP, DGBYDY, NEQ, Y, YDOTI, T, TOUT, ITOL, 11100 C 1 RTOL, ATOL, ITASK, ISTATE, IOPT, RWORK, LRW, IWORK, LIW, MF) 11101 C WRITE (6,20) T, Y(1), Y(2), Y(3) 11102 C 20 FORMAT(' At t =',D12.4,' Y =',3D14.6) 11103 C IF (ISTATE .LT. 0 ) GO TO 80 11104 C 40 TOUT = TOUT*10. 11105 C WRITE (6,60) IWORK(11), IWORK(12), IWORK(13) 11106 C 60 FORMAT(/' No. steps =',I4,' No. r-s =',I4,' No. J-s =',I4) 11107 C STOP 11108 C 80 WRITE (6,90) ISTATE 11109 C 90 FORMAT(///' Error halt.. ISTATE =',I3) 11110 C STOP 11111 C END 11112 C 11113 C SUBROUTINE RESID(NEQ, T, Y, S, R, IRES) 11114 C DOUBLE PRECISION T, Y, S, R 11115 C DIMENSION Y(3), S(3), R(3) 11116 C R(1) = -.04*Y(1) + 1.D4*Y(2)*Y(3) - S(1) 11117 C R(2) = .04*Y(1) - 1.D4*Y(2)*Y(3) - 3.D7*Y(2)*Y(2) - S(2) 11118 C R(3) = Y(1) + Y(2) + Y(3) - 1. 11119 C RETURN 11120 C END 11121 C 11122 C SUBROUTINE APLUSP(NEQ, T, Y, ML, MU, P, NROWP) 11123 C DOUBLE PRECISION T, Y, P 11124 C DIMENSION Y(3), P(NROWP,3) 11125 C P(1,1) = P(1,1) + 1. 11126 C P(2,2) = P(2,2) + 1. 11127 C RETURN 11128 C END 11129 C 11130 C SUBROUTINE DGBYDY(NEQ, T, Y, S, ML, MU, P, NROWP) 11131 C DOUBLE PRECISION T, Y, S, P 11132 C DIMENSION Y(3), S(3), P(NROWP,3) 11133 C P(1,1) = -.04 11134 C P(1,2) = 1.D4*Y(3) 11135 C P(1,3) = 1.D4*Y(2) 11136 C P(2,1) = .04 11137 C P(2,2) = -1.D4*Y(3) - 6.D7*Y(2) 11138 C P(2,3) = -1.D4*Y(2) 11139 C P(3,1) = 1. 11140 C P(3,2) = 1. 11141 C P(3,3) = 1. 11142 C RETURN 11143 C END 11144 C 11145 C The output of this program (on a CDC-7600 in single precision) 11146 C is as follows: 11147 C 11148 C At t = 4.0000e-01 Y = 9.851726e-01 3.386406e-05 1.479357e-02 11149 C At t = 4.0000e+00 Y = 9.055142e-01 2.240418e-05 9.446344e-02 11150 C At t = 4.0000e+01 Y = 7.158050e-01 9.184616e-06 2.841858e-01 11151 C At t = 4.0000e+02 Y = 4.504846e-01 3.222434e-06 5.495122e-01 11152 C At t = 4.0000e+03 Y = 1.831701e-01 8.940379e-07 8.168290e-01 11153 C At t = 4.0000e+04 Y = 3.897016e-02 1.621193e-07 9.610297e-01 11154 C At t = 4.0000e+05 Y = 4.935213e-03 1.983756e-08 9.950648e-01 11155 C At t = 4.0000e+06 Y = 5.159269e-04 2.064759e-09 9.994841e-01 11156 C At t = 4.0000e+07 Y = 5.306413e-05 2.122677e-10 9.999469e-01 11157 C At t = 4.0000e+08 Y = 5.494532e-06 2.197826e-11 9.999945e-01 11158 C At t = 4.0000e+09 Y = 5.129457e-07 2.051784e-12 9.999995e-01 11159 C At t = 4.0000e+10 Y = -7.170472e-08 -2.868188e-13 1.000000e+00 11160 C 11161 C No. steps = 330 No. r-s = 404 No. J-s = 69 11162 C 11163 C----------------------------------------------------------------------- 11164 C Full Description of User Interface to DLSODI. 11165 C 11166 C The user interface to DLSODI consists of the following parts. 11167 C 11168 C 1. The call sequence to Subroutine DLSODI, which is a driver 11169 C routine for the solver. This includes descriptions of both 11170 C the call sequence arguments and of user-supplied routines. 11171 C Following these descriptions is a description of 11172 C optional inputs available through the call sequence, and then 11173 C a description of optional outputs (in the work arrays). 11174 C 11175 C 2. Descriptions of other routines in the DLSODI package that may be 11176 C (optionally) called by the user. These provide the ability to 11177 C alter error message handling, save and restore the internal 11178 C Common, and obtain specified derivatives of the solution y(t). 11179 C 11180 C 3. Descriptions of Common blocks to be declared in overlay 11181 C or similar environments, or to be saved when doing an interrupt 11182 C of the problem and continued solution later. 11183 C 11184 C 4. Description of two routines in the DLSODI package, either of 11185 C which the user may replace with his/her own version, if desired. 11186 C These relate to the measurement of errors. 11187 C 11188 C----------------------------------------------------------------------- 11189 C Part 1. Call Sequence. 11190 C 11191 C The call sequence parameters used for input only are 11192 C RES, ADDA, JAC, NEQ, TOUT, ITOL, RTOL, ATOL, ITASK, 11193 C IOPT, LRW, LIW, MF, 11194 C and those used for both input and output are 11195 C Y, T, ISTATE, YDOTI. 11196 C The work arrays RWORK and IWORK are also used for conditional and 11197 C optional inputs and optional outputs. (The term output here refers 11198 C to the return from Subroutine DLSODI to the user's calling program.) 11199 C 11200 C The legality of input parameters will be thoroughly checked on the 11201 C initial call for the problem, but not checked thereafter unless a 11202 C change in input parameters is flagged by ISTATE = 3 on input. 11203 C 11204 C The descriptions of the call arguments are as follows. 11205 C 11206 C RES = the name of the user-supplied subroutine which supplies 11207 C the residual vector for the ODE system, defined by 11208 C r = g(t,y) - A(t,y) * s 11209 C as a function of the scalar t and the vectors 11210 C s and y (s approximates dy/dt). This subroutine 11211 C is to have the form 11212 C SUBROUTINE RES (NEQ, T, Y, S, R, IRES) 11213 C DOUBLE PRECISION T, Y(*), S(*), R(*) 11214 C where NEQ, T, Y, S, and IRES are input, and R and 11215 C IRES are output. Y, S, and R are arrays of length NEQ. 11216 C On input, IRES indicates how DLSODI will use the 11217 C returned array R, as follows: 11218 C IRES = 1 means that DLSODI needs the full residual, 11219 C r = g - A*s, exactly. 11220 C IRES = -1 means that DLSODI is using R only to compute 11221 C the Jacobian dr/dy by difference quotients. 11222 C The RES routine can ignore IRES, or it can omit some terms 11223 C if IRES = -1. If A does not depend on y, then RES can 11224 C just return R = g when IRES = -1. If g - A*s contains other 11225 C additive terms that are independent of y, these can also be 11226 C dropped, if done consistently, when IRES = -1. 11227 C The subroutine should set the flag IRES if it 11228 C encounters a halt condition or illegal input. 11229 C Otherwise, it should not reset IRES. On output, 11230 C IRES = 1 or -1 represents a normal return, and 11231 C DLSODI continues integrating the ODE. Leave IRES 11232 C unchanged from its input value. 11233 C IRES = 2 tells DLSODI to immediately return control 11234 C to the calling program, with ISTATE = 3. This lets 11235 C the calling program change parameters of the problem, 11236 C if necessary. 11237 C IRES = 3 represents an error condition (for example, an 11238 C illegal value of y). DLSODI tries to integrate the system 11239 C without getting IRES = 3 from RES. If it cannot, DLSODI 11240 C returns with ISTATE = -7 or -1. 11241 C On an DLSODI return with ISTATE = 3, -1, or -7, the values 11242 C of T and Y returned correspond to the last point reached 11243 C successfully without getting the flag IRES = 2 or 3. 11244 C The flag values IRES = 2 and 3 should not be used to 11245 C handle switches or root-stop conditions. This is better 11246 C done by calling DLSODI in a one-step mode and checking the 11247 C stopping function for a sign change at each step. 11248 C If quantities computed in the RES routine are needed 11249 C externally to DLSODI, an extra call to RES should be made 11250 C for this purpose, for consistent and accurate results. 11251 C To get the current dy/dt for the S argument, use DINTDY. 11252 C RES must be declared External in the calling 11253 C program. See note below for more about RES. 11254 C 11255 C ADDA = the name of the user-supplied subroutine which adds the 11256 C matrix A = A(t,y) to another matrix stored in the same form 11257 C as A. The storage form is determined by MITER (see MF). 11258 C This subroutine is to have the form 11259 C SUBROUTINE ADDA (NEQ, T, Y, ML, MU, P, NROWP) 11260 C DOUBLE PRECISION T, Y(*), P(NROWP,*) 11261 C where NEQ, T, Y, ML, MU, and NROWP are input and P is 11262 C output. Y is an array of length NEQ, and the matrix P is 11263 C stored in an NROWP by NEQ array. 11264 C In the full matrix case ( MITER = 1 or 2) ADDA should 11265 C add A to P(i,j). ML and MU are ignored. 11266 C i,j 11267 C In the band matrix case ( MITER = 4 or 5) ADDA should 11268 C add A to P(i-j+MU+1,j). 11269 C i,j 11270 C See JAC for details on this band storage form. 11271 C ADDA must be declared External in the calling program. 11272 C See note below for more information about ADDA. 11273 C 11274 C JAC = the name of the user-supplied subroutine which supplies the 11275 C Jacobian matrix, dr/dy, where r = g - A*s. The form of the 11276 C Jacobian matrix is determined by MITER. JAC is required 11277 C if MITER = 1 or 4 -- otherwise a dummy name can be 11278 C passed. This subroutine is to have the form 11279 C SUBROUTINE JAC ( NEQ, T, Y, S, ML, MU, P, NROWP ) 11280 C DOUBLE PRECISION T, Y(*), S(*), P(NROWP,*) 11281 C where NEQ, T, Y, S, ML, MU, and NROWP are input and P 11282 C is output. Y and S are arrays of length NEQ, and the 11283 C matrix P is stored in an NROWP by NEQ array. 11284 C P is to be loaded with partial derivatives (elements 11285 C of the Jacobian matrix) on output. 11286 C In the full matrix case (MITER = 1), ML and MU 11287 C are ignored and the Jacobian is to be loaded into P 11288 C by columns-- i.e., dr(i)/dy(j) is loaded into P(i,j). 11289 C In the band matrix case (MITER = 4), the elements 11290 C within the band are to be loaded into P by columns, 11291 C with diagonal lines of dr/dy loaded into the 11292 C rows of P. Thus dr(i)/dy(j) is to be loaded 11293 C into P(i-j+MU+1,j). The locations in P in the two 11294 C triangular areas which correspond to nonexistent matrix 11295 C elements can be ignored or loaded arbitrarily, as they 11296 C they are overwritten by DLSODI. ML and MU are the 11297 C half-bandwidth parameters (see IWORK). 11298 C In either case, P is preset to zero by the solver, 11299 C so that only the nonzero elements need be loaded by JAC. 11300 C Each call to JAC is preceded by a call to RES with the same 11301 C arguments NEQ, T, Y, and S. Thus to gain some efficiency, 11302 C intermediate quantities shared by both calculations may be 11303 C saved in a user Common block by RES and not recomputed by JAC 11304 C if desired. Also, JAC may alter the Y array, if desired. 11305 C JAC need not provide dr/dy exactly. A crude 11306 C approximation (possibly with a smaller bandwidth) will do. 11307 C JAC must be declared External in the calling program. 11308 C See note below for more about JAC. 11309 C 11310 C Note on RES, ADDA, and JAC: 11311 C These subroutines may access user-defined quantities in 11312 C NEQ(2),... and/or in Y(NEQ(1)+1),... if NEQ is an array 11313 C (dimensioned in the subroutines) and/or Y has length 11314 C exceeding NEQ(1). However, these routines should not alter 11315 C NEQ(1), Y(1),...,Y(NEQ) or any other input variables. 11316 C See the descriptions of NEQ and Y below. 11317 C 11318 C NEQ = the size of the system (number of first order ordinary 11319 C differential equations or scalar algebraic equations). 11320 C Used only for input. 11321 C NEQ may be decreased, but not increased, during the problem. 11322 C If NEQ is decreased (with ISTATE = 3 on input), the 11323 C remaining components of Y should be left undisturbed, if 11324 C these are to be accessed in RES, ADDA, or JAC. 11325 C 11326 C Normally, NEQ is a scalar, and it is generally referred to 11327 C as a scalar in this user interface description. However, 11328 C NEQ may be an array, with NEQ(1) set to the system size. 11329 C (The DLSODI package accesses only NEQ(1).) In either case, 11330 C this parameter is passed as the NEQ argument in all calls 11331 C to RES, ADDA, and JAC. Hence, if it is an array, 11332 C locations NEQ(2),... may be used to store other integer data 11333 C and pass it to RES, ADDA, or JAC. Each such subroutine 11334 C must include NEQ in a Dimension statement in that case. 11335 C 11336 C Y = a real array for the vector of dependent variables, of 11337 C length NEQ or more. Used for both input and output on the 11338 C first call (ISTATE = 0 or 1), and only for output on other 11339 C calls. On the first call, Y must contain the vector of 11340 C initial values. On output, Y contains the computed solution 11341 C vector, evaluated at T. If desired, the Y array may be used 11342 C for other purposes between calls to the solver. 11343 C 11344 C This array is passed as the Y argument in all calls to RES, 11345 C ADDA, and JAC. Hence its length may exceed NEQ, 11346 C and locations Y(NEQ+1),... may be used to store other real 11347 C data and pass it to RES, ADDA, or JAC. (The DLSODI 11348 C package accesses only Y(1),...,Y(NEQ). ) 11349 C 11350 C YDOTI = a real array for the initial value of the vector 11351 C dy/dt and for work space, of dimension at least NEQ. 11352 C 11353 C On input: 11354 C If ISTATE = 0, then DLSODI will compute the initial value 11355 C of dy/dt, if A is nonsingular. Thus YDOTI will 11356 C serve only as work space and may have any value. 11357 C If ISTATE = 1, then YDOTI must contain the initial value 11358 C of dy/dt. 11359 C If ISTATE = 2 or 3 (continuation calls), then YDOTI 11360 C may have any value. 11361 C Note: If the initial value of A is singular, then 11362 C DLSODI cannot compute the initial value of dy/dt, so 11363 C it must be provided in YDOTI, with ISTATE = 1. 11364 C 11365 C On output, when DLSODI terminates abnormally with ISTATE = 11366 C -1, -4, or -5, YDOTI will contain the residual 11367 C r = g(t,y) - A(t,y)*(dy/dt). If r is large, t is near 11368 C its initial value, and YDOTI is supplied with ISTATE = 1, 11369 C then there may have been an incorrect input value of 11370 C YDOTI = dy/dt, or the problem (as given to DLSODI) 11371 C may not have a solution. 11372 C 11373 C If desired, the YDOTI array may be used for other 11374 C purposes between calls to the solver. 11375 C 11376 C T = the independent variable. On input, T is used only on the 11377 C first call, as the initial point of the integration. 11378 C On output, after each call, T is the value at which a 11379 C computed solution Y is evaluated (usually the same as TOUT). 11380 C on an error return, T is the farthest point reached. 11381 C 11382 C TOUT = the next value of t at which a computed solution is desired. 11383 C Used only for input. 11384 C 11385 C When starting the problem (ISTATE = 0 or 1), TOUT may be 11386 C equal to T for one call, then should .ne. T for the next 11387 C call. For the initial T, an input value of TOUT .ne. T is 11388 C used in order to determine the direction of the integration 11389 C (i.e. the algebraic sign of the step sizes) and the rough 11390 C scale of the problem. Integration in either direction 11391 C (forward or backward in t) is permitted. 11392 C 11393 C If ITASK = 2 or 5 (one-step modes), TOUT is ignored after 11394 C the first call (i.e. the first call with TOUT .ne. T). 11395 C Otherwise, TOUT is required on every call. 11396 C 11397 C If ITASK = 1, 3, or 4, the values of TOUT need not be 11398 C monotone, but a value of TOUT which backs up is limited 11399 C to the current internal T interval, whose endpoints are 11400 C TCUR - HU and TCUR (see optional outputs, below, for 11401 C TCUR and HU). 11402 C 11403 C ITOL = an indicator for the type of error control. See 11404 C description below under ATOL. Used only for input. 11405 C 11406 C RTOL = a relative error tolerance parameter, either a scalar or 11407 C an array of length NEQ. See description below under ATOL. 11408 C Input only. 11409 C 11410 C ATOL = an absolute error tolerance parameter, either a scalar or 11411 C an array of length NEQ. Input only. 11412 C 11413 C The input parameters ITOL, RTOL, and ATOL determine 11414 C the error control performed by the solver. The solver will 11415 C control the vector E = (E(i)) of estimated local errors 11416 C in y, according to an inequality of the form 11417 C RMS-norm of ( E(i)/EWT(i) ) .le. 1, 11418 C where EWT(i) = RTOL(i)*ABS(Y(i)) + ATOL(i), 11419 C and the RMS-norm (root-mean-square norm) here is 11420 C RMS-norm(v) = SQRT(sum v(i)**2 / NEQ). Here EWT = (EWT(i)) 11421 C is a vector of weights which must always be positive, and 11422 C the values of RTOL and ATOL should all be non-negative. 11423 C The following table gives the types (scalar/array) of 11424 C RTOL and ATOL, and the corresponding form of EWT(i). 11425 C 11426 C ITOL RTOL ATOL EWT(i) 11427 C 1 scalar scalar RTOL*ABS(Y(i)) + ATOL 11428 C 2 scalar array RTOL*ABS(Y(i)) + ATOL(i) 11429 C 3 array scalar RTOL(i)*ABS(Y(i)) + ATOL 11430 C 4 array scalar RTOL(i)*ABS(Y(i)) + ATOL(i) 11431 C 11432 C When either of these parameters is a scalar, it need not 11433 C be dimensioned in the user's calling program. 11434 C 11435 C If none of the above choices (with ITOL, RTOL, and ATOL 11436 C fixed throughout the problem) is suitable, more general 11437 C error controls can be obtained by substituting 11438 C user-supplied routines for the setting of EWT and/or for 11439 C the norm calculation. See Part 4 below. 11440 C 11441 C If global errors are to be estimated by making a repeated 11442 C run on the same problem with smaller tolerances, then all 11443 C components of RTOL and ATOL (i.e. of EWT) should be scaled 11444 C down uniformly. 11445 C 11446 C ITASK = an index specifying the task to be performed. 11447 C Input only. ITASK has the following values and meanings. 11448 C 1 means normal computation of output values of y(t) at 11449 C t = TOUT (by overshooting and interpolating). 11450 C 2 means take one step only and return. 11451 C 3 means stop at the first internal mesh point at or 11452 C beyond t = TOUT and return. 11453 C 4 means normal computation of output values of y(t) at 11454 C t = TOUT but without overshooting t = TCRIT. 11455 C TCRIT must be input as RWORK(1). TCRIT may be equal to 11456 C or beyond TOUT, but not behind it in the direction of 11457 C integration. This option is useful if the problem 11458 C has a singularity at or beyond t = TCRIT. 11459 C 5 means take one step, without passing TCRIT, and return. 11460 C TCRIT must be input as RWORK(1). 11461 C 11462 C Note: If ITASK = 4 or 5 and the solver reaches TCRIT 11463 C (within roundoff), it will return T = TCRIT (exactly) to 11464 C indicate this (unless ITASK = 4 and TOUT comes before TCRIT, 11465 C in which case answers at t = TOUT are returned first). 11466 C 11467 C ISTATE = an index used for input and output to specify the 11468 C state of the calculation. 11469 C 11470 C On input, the values of ISTATE are as follows. 11471 C 0 means this is the first call for the problem, and 11472 C DLSODI is to compute the initial value of dy/dt 11473 C (while doing other initializations). See note below. 11474 C 1 means this is the first call for the problem, and 11475 C the initial value of dy/dt has been supplied in 11476 C YDOTI (DLSODI will do other initializations). See note 11477 C below. 11478 C 2 means this is not the first call, and the calculation 11479 C is to continue normally, with no change in any input 11480 C parameters except possibly TOUT and ITASK. 11481 C (If ITOL, RTOL, and/or ATOL are changed between calls 11482 C with ISTATE = 2, the new values will be used but not 11483 C tested for legality.) 11484 C 3 means this is not the first call, and the 11485 C calculation is to continue normally, but with 11486 C a change in input parameters other than 11487 C TOUT and ITASK. Changes are allowed in 11488 C NEQ, ITOL, RTOL, ATOL, IOPT, LRW, LIW, MF, ML, MU, 11489 C and any of the optional inputs except H0. 11490 C (See IWORK description for ML and MU.) 11491 C Note: A preliminary call with TOUT = T is not counted 11492 C as a first call here, as no initialization or checking of 11493 C input is done. (Such a call is sometimes useful for the 11494 C purpose of outputting the initial conditions.) 11495 C Thus the first call for which TOUT .ne. T requires 11496 C ISTATE = 0 or 1 on input. 11497 C 11498 C On output, ISTATE has the following values and meanings. 11499 C 0 or 1 means nothing was done; TOUT = t and 11500 C ISTATE = 0 or 1 on input. 11501 C 2 means that the integration was performed successfully. 11502 C 3 means that the user-supplied Subroutine RES signalled 11503 C DLSODI to halt the integration and return (IRES = 2). 11504 C Integration as far as T was achieved with no occurrence 11505 C of IRES = 2, but this flag was set on attempting the 11506 C next step. 11507 C -1 means an excessive amount of work (more than MXSTEP 11508 C steps) was done on this call, before completing the 11509 C requested task, but the integration was otherwise 11510 C successful as far as T. (MXSTEP is an optional input 11511 C and is normally 500.) To continue, the user may 11512 C simply reset ISTATE to a value .gt. 1 and call again 11513 C (the excess work step counter will be reset to 0). 11514 C In addition, the user may increase MXSTEP to avoid 11515 C this error return (see below on optional inputs). 11516 C -2 means too much accuracy was requested for the precision 11517 C of the machine being used. This was detected before 11518 C completing the requested task, but the integration 11519 C was successful as far as T. To continue, the tolerance 11520 C parameters must be reset, and ISTATE must be set 11521 C to 3. The optional output TOLSF may be used for this 11522 C purpose. (Note: If this condition is detected before 11523 C taking any steps, then an illegal input return 11524 C (ISTATE = -3) occurs instead.) 11525 C -3 means illegal input was detected, before taking any 11526 C integration steps. See written message for details. 11527 C Note: If the solver detects an infinite loop of calls 11528 C to the solver with illegal input, it will cause 11529 C the run to stop. 11530 C -4 means there were repeated error test failures on 11531 C one attempted step, before completing the requested 11532 C task, but the integration was successful as far as T. 11533 C The problem may have a singularity, or the input 11534 C may be inappropriate. 11535 C -5 means there were repeated convergence test failures on 11536 C one attempted step, before completing the requested 11537 C task, but the integration was successful as far as T. 11538 C This may be caused by an inaccurate Jacobian matrix. 11539 C -6 means EWT(i) became zero for some i during the 11540 C integration. pure relative error control (ATOL(i)=0.0) 11541 C was requested on a variable which has now vanished. 11542 C the integration was successful as far as T. 11543 C -7 means that the user-supplied Subroutine RES set 11544 C its error flag (IRES = 3) despite repeated tries by 11545 C DLSODI to avoid that condition. 11546 C -8 means that ISTATE was 0 on input but DLSODI was unable 11547 C to compute the initial value of dy/dt. See the 11548 C printed message for details. 11549 C 11550 C Note: Since the normal output value of ISTATE is 2, 11551 C it does not need to be reset for normal continuation. 11552 C Similarly, ISTATE (= 3) need not be reset if RES told 11553 C DLSODI to return because the calling program must change 11554 C the parameters of the problem. 11555 C Also, since a negative input value of ISTATE will be 11556 C regarded as illegal, a negative output value requires the 11557 C user to change it, and possibly other inputs, before 11558 C calling the solver again. 11559 C 11560 C IOPT = an integer flag to specify whether or not any optional 11561 C inputs are being used on this call. Input only. 11562 C The optional inputs are listed separately below. 11563 C IOPT = 0 means no optional inputs are being used. 11564 C Default values will be used in all cases. 11565 C IOPT = 1 means one or more optional inputs are being used. 11566 C 11567 C RWORK = a real working array (double precision). 11568 C The length of RWORK must be at least 11569 C 20 + NYH*(MAXORD + 1) + 3*NEQ + LENWM where 11570 C NYH = the initial value of NEQ, 11571 C MAXORD = 12 (if METH = 1) or 5 (if METH = 2) (unless a 11572 C smaller value is given as an optional input), 11573 C LENWM = NEQ**2 + 2 if MITER is 1 or 2, and 11574 C LENWM = (2*ML+MU+1)*NEQ + 2 if MITER is 4 or 5. 11575 C (See MF description for the definition of METH and MITER.) 11576 C Thus if MAXORD has its default value and NEQ is constant, 11577 C this length is 11578 C 22 + 16*NEQ + NEQ**2 for MF = 11 or 12, 11579 C 22 + 17*NEQ + (2*ML+MU)*NEQ for MF = 14 or 15, 11580 C 22 + 9*NEQ + NEQ**2 for MF = 21 or 22, 11581 C 22 + 10*NEQ + (2*ML+MU)*NEQ for MF = 24 or 25. 11582 C The first 20 words of RWORK are reserved for conditional 11583 C and optional inputs and optional outputs. 11584 C 11585 C The following word in RWORK is a conditional input: 11586 C RWORK(1) = TCRIT = critical value of t which the solver 11587 C is not to overshoot. Required if ITASK is 11588 C 4 or 5, and ignored otherwise. (See ITASK.) 11589 C 11590 C LRW = the length of the array RWORK, as declared by the user. 11591 C (This will be checked by the solver.) 11592 C 11593 C IWORK = an integer work array. The length of IWORK must be at least 11594 C 20 + NEQ . The first few words of IWORK are used for 11595 C conditional and optional inputs and optional outputs. 11596 C 11597 C The following 2 words in IWORK are conditional inputs: 11598 C IWORK(1) = ML These are the lower and upper 11599 C IWORK(2) = MU half-bandwidths, respectively, of the 11600 C matrices in the problem-- the Jacobian dr/dy 11601 C and the left-hand side matrix A. These 11602 C half-bandwidths exclude the main diagonal, 11603 C so the total bandwidth is ML + MU + 1 . 11604 C The band is defined by the matrix locations 11605 C (i,j) with i-ML .le. j .le. i+MU. ML and MU 11606 C must satisfy 0 .le. ML,MU .le. NEQ-1. 11607 C These are required if MITER is 4 or 5, and 11608 C ignored otherwise. 11609 C ML and MU may in fact be the band parameters 11610 C for matrices to which dr/dy and A are only 11611 C approximately equal. 11612 C 11613 C LIW = the length of the array IWORK, as declared by the user. 11614 C (This will be checked by the solver.) 11615 C 11616 C Note: The work arrays must not be altered between calls to DLSODI 11617 C for the same problem, except possibly for the conditional and 11618 C optional inputs, and except for the last 3*NEQ words of RWORK. 11619 C The latter space is used for internal scratch space, and so is 11620 C available for use by the user outside DLSODI between calls, if 11621 C desired (but not for use by RES, ADDA, or JAC). 11622 C 11623 C MF = the method flag. Used only for input. The legal values of 11624 C MF are 11, 12, 14, 15, 21, 22, 24, and 25. 11625 C MF has decimal digits METH and MITER: MF = 10*METH + MITER. 11626 C METH indicates the basic linear multistep method: 11627 C METH = 1 means the implicit Adams method. 11628 C METH = 2 means the method based on Backward 11629 C Differentiation Formulas (BDFs). 11630 C The BDF method is strongly preferred for stiff 11631 C problems, while the Adams method is preferred when 11632 C the problem is not stiff. If the matrix A(t,y) is 11633 C nonsingular, stiffness here can be taken to mean that of 11634 C the explicit ODE system dy/dt = A-inverse * g. If A is 11635 C singular, the concept of stiffness is not well defined. 11636 C If you do not know whether the problem is stiff, we 11637 C recommend using METH = 2. If it is stiff, the advantage 11638 C of METH = 2 over METH = 1 will be great, while if it is 11639 C not stiff, the advantage of METH = 1 will be slight. 11640 C If maximum efficiency is important, some experimentation 11641 C with METH may be necessary. 11642 C MITER indicates the corrector iteration method: 11643 C MITER = 1 means chord iteration with a user-supplied 11644 C full (NEQ by NEQ) Jacobian. 11645 C MITER = 2 means chord iteration with an internally 11646 C generated (difference quotient) full Jacobian. 11647 C This uses NEQ+1 extra calls to RES per dr/dy 11648 C evaluation. 11649 C MITER = 4 means chord iteration with a user-supplied 11650 C banded Jacobian. 11651 C MITER = 5 means chord iteration with an internally 11652 C generated banded Jacobian (using ML+MU+2 11653 C extra calls to RES per dr/dy evaluation). 11654 C If MITER = 1 or 4, the user must supply a Subroutine JAC 11655 C (the name is arbitrary) as described above under JAC. 11656 C For other values of MITER, a dummy argument can be used. 11657 C----------------------------------------------------------------------- 11658 C Optional Inputs. 11659 C 11660 C The following is a list of the optional inputs provided for in the 11661 C call sequence. (See also Part 2.) For each such input variable, 11662 C this table lists its name as used in this documentation, its 11663 C location in the call sequence, its meaning, and the default value. 11664 C the use of any of these inputs requires IOPT = 1, and in that 11665 C case all of these inputs are examined. A value of zero for any 11666 C of these optional inputs will cause the default value to be used. 11667 C Thus to use a subset of the optional inputs, simply preload 11668 C locations 5 to 10 in RWORK and IWORK to 0.0 and 0 respectively, and 11669 C then set those of interest to nonzero values. 11670 C 11671 C Name Location Meaning and Default Value 11672 C 11673 C H0 RWORK(5) the step size to be attempted on the first step. 11674 C The default value is determined by the solver. 11675 C 11676 C HMAX RWORK(6) the maximum absolute step size allowed. 11677 C The default value is infinite. 11678 C 11679 C HMIN RWORK(7) the minimum absolute step size allowed. 11680 C The default value is 0. (This lower bound is not 11681 C enforced on the final step before reaching TCRIT 11682 C when ITASK = 4 or 5.) 11683 C 11684 C MAXORD IWORK(5) the maximum order to be allowed. The default 11685 C value is 12 if METH = 1, and 5 if METH = 2. 11686 C If MAXORD exceeds the default value, it will 11687 C be reduced to the default value. 11688 C If MAXORD is changed during the problem, it may 11689 C cause the current order to be reduced. 11690 C 11691 C MXSTEP IWORK(6) maximum number of (internally defined) steps 11692 C allowed during one call to the solver. 11693 C The default value is 500. 11694 C 11695 C MXHNIL IWORK(7) maximum number of messages printed (per problem) 11696 C warning that T + H = T on a step (H = step size). 11697 C This must be positive to result in a non-default 11698 C value. The default value is 10. 11699 C----------------------------------------------------------------------- 11700 C Optional Outputs. 11701 C 11702 C As optional additional output from DLSODI, the variables listed 11703 C below are quantities related to the performance of DLSODI 11704 C which are available to the user. These are communicated by way of 11705 C the work arrays, but also have internal mnemonic names as shown. 11706 C Except where stated otherwise, all of these outputs are defined 11707 C on any successful return from DLSODI, and on any return with 11708 C ISTATE = -1, -2, -4, -5, -6, or -7. On a return with -3 (illegal 11709 C input) or -8, they will be unchanged from their existing values 11710 C (if any), except possibly for TOLSF, LENRW, and LENIW. 11711 C On any error return, outputs relevant to the error will be defined, 11712 C as noted below. 11713 C 11714 C Name Location Meaning 11715 C 11716 C HU RWORK(11) the step size in t last used (successfully). 11717 C 11718 C HCUR RWORK(12) the step size to be attempted on the next step. 11719 C 11720 C TCUR RWORK(13) the current value of the independent variable 11721 C which the solver has actually reached, i.e. the 11722 C current internal mesh point in t. On output, TCUR 11723 C will always be at least as far as the argument 11724 C T, but may be farther (if interpolation was done). 11725 C 11726 C TOLSF RWORK(14) a tolerance scale factor, greater than 1.0, 11727 C computed when a request for too much accuracy was 11728 C detected (ISTATE = -3 if detected at the start of 11729 C the problem, ISTATE = -2 otherwise). If ITOL is 11730 C left unaltered but RTOL and ATOL are uniformly 11731 C scaled up by a factor of TOLSF for the next call, 11732 C then the solver is deemed likely to succeed. 11733 C (The user may also ignore TOLSF and alter the 11734 C tolerance parameters in any other way appropriate.) 11735 C 11736 C NST IWORK(11) the number of steps taken for the problem so far. 11737 C 11738 C NRE IWORK(12) the number of residual evaluations (RES calls) 11739 C for the problem so far. 11740 C 11741 C NJE IWORK(13) the number of Jacobian evaluations (each involving 11742 C an evaluation of A and dr/dy) for the problem so 11743 C far. This equals the number of calls to ADDA and 11744 C (if MITER = 1 or 4) JAC, and the number of matrix 11745 C LU decompositions. 11746 C 11747 C NQU IWORK(14) the method order last used (successfully). 11748 C 11749 C NQCUR IWORK(15) the order to be attempted on the next step. 11750 C 11751 C IMXER IWORK(16) the index of the component of largest magnitude in 11752 C the weighted local error vector ( E(i)/EWT(i) ), 11753 C on an error return with ISTATE = -4 or -5. 11754 C 11755 C LENRW IWORK(17) the length of RWORK actually required. 11756 C This is defined on normal returns and on an illegal 11757 C input return for insufficient storage. 11758 C 11759 C LENIW IWORK(18) the length of IWORK actually required. 11760 C This is defined on normal returns and on an illegal 11761 C input return for insufficient storage. 11762 C 11763 C 11764 C The following two arrays are segments of the RWORK array which 11765 C may also be of interest to the user as optional outputs. 11766 C For each array, the table below gives its internal name, 11767 C its base address in RWORK, and its description. 11768 C 11769 C Name Base Address Description 11770 C 11771 C YH 21 the Nordsieck history array, of size NYH by 11772 C (NQCUR + 1), where NYH is the initial value 11773 C of NEQ. For j = 0,1,...,NQCUR, column j+1 11774 C of YH contains HCUR**j/factorial(j) times 11775 C the j-th derivative of the interpolating 11776 C polynomial currently representing the solution, 11777 C evaluated at t = TCUR. 11778 C 11779 C ACOR LENRW-NEQ+1 array of size NEQ used for the accumulated 11780 C corrections on each step, scaled on output to 11781 C represent the estimated local error in y on the 11782 C last step. This is the vector E in the descrip- 11783 C tion of the error control. It is defined only 11784 C on a return from DLSODI with ISTATE = 2. 11785 C 11786 C----------------------------------------------------------------------- 11787 C Part 2. Other Routines Callable. 11788 C 11789 C The following are optional calls which the user may make to 11790 C gain additional capabilities in conjunction with DLSODI. 11791 C (The routines XSETUN and XSETF are designed to conform to the 11792 C SLATEC error handling package.) 11793 C 11794 C Form of Call Function 11795 C CALL XSETUN(LUN) Set the logical unit number, LUN, for 11796 C output of messages from DLSODI, if 11797 C the default is not desired. 11798 C The default value of LUN is 6. 11799 C 11800 C CALL XSETF(MFLAG) Set a flag to control the printing of 11801 C messages by DLSODI. 11802 C MFLAG = 0 means do not print. (Danger: 11803 C This risks losing valuable information.) 11804 C MFLAG = 1 means print (the default). 11805 C 11806 C Either of the above calls may be made at 11807 C any time and will take effect immediately. 11808 C 11809 C CALL DSRCOM(RSAV,ISAV,JOB) saves and restores the contents of 11810 C the internal Common blocks used by 11811 C DLSODI (see Part 3 below). 11812 C RSAV must be a real array of length 218 11813 C or more, and ISAV must be an integer 11814 C array of length 37 or more. 11815 C JOB=1 means save Common into RSAV/ISAV. 11816 C JOB=2 means restore Common from RSAV/ISAV. 11817 C DSRCOM is useful if one is 11818 C interrupting a run and restarting 11819 C later, or alternating between two or 11820 C more problems solved with DLSODI. 11821 C 11822 C CALL DINTDY(,,,,,) Provide derivatives of y, of various 11823 C (see below) orders, at a specified point t, if 11824 C desired. It may be called only after 11825 C a successful return from DLSODI. 11826 C 11827 C The detailed instructions for using DINTDY are as follows. 11828 C The form of the call is: 11829 C 11830 C CALL DINTDY (T, K, RWORK(21), NYH, DKY, IFLAG) 11831 C 11832 C The input parameters are: 11833 C 11834 C T = value of independent variable where answers are desired 11835 C (normally the same as the T last returned by DLSODI). 11836 C For valid results, T must lie between TCUR - HU and TCUR. 11837 C (See optional outputs for TCUR and HU.) 11838 C K = integer order of the derivative desired. K must satisfy 11839 C 0 .le. K .le. NQCUR, where NQCUR is the current order 11840 C (see optional outputs). The capability corresponding 11841 C to K = 0, i.e. computing y(T), is already provided 11842 C by DLSODI directly. Since NQCUR .ge. 1, the first 11843 C derivative dy/dt is always available with DINTDY. 11844 C RWORK(21) = the base address of the history array YH. 11845 C NYH = column length of YH, equal to the initial value of NEQ. 11846 C 11847 C The output parameters are: 11848 C 11849 C DKY = a real array of length NEQ containing the computed value 11850 C of the K-th derivative of y(t). 11851 C IFLAG = integer flag, returned as 0 if K and T were legal, 11852 C -1 if K was illegal, and -2 if T was illegal. 11853 C On an error return, a message is also written. 11854 C----------------------------------------------------------------------- 11855 C Part 3. Common Blocks. 11856 C 11857 C If DLSODI is to be used in an overlay situation, the user 11858 C must declare, in the primary overlay, the variables in: 11859 C (1) the call sequence to DLSODI, and 11860 C (2) the internal Common block 11861 C /DLS001/ of length 255 (218 double precision words 11862 C followed by 37 integer words), 11863 C 11864 C If DLSODI is used on a system in which the contents of internal 11865 C Common blocks are not preserved between calls, the user should 11866 C declare the above Common block in the calling program to insure 11867 C that their contents are preserved. 11868 C 11869 C If the solution of a given problem by DLSODI is to be interrupted 11870 C and then later continued, such as when restarting an interrupted run 11871 C or alternating between two or more problems, the user should save, 11872 C following the return from the last DLSODI call prior to the 11873 C interruption, the contents of the call sequence variables and the 11874 C internal Common blocks, and later restore these values before the 11875 C next DLSODI call for that problem. To save and restore the Common 11876 C blocks, use Subroutine DSRCOM (see Part 2 above). 11877 C 11878 C----------------------------------------------------------------------- 11879 C Part 4. Optionally Replaceable Solver Routines. 11880 C 11881 C Below are descriptions of two routines in the DLSODI package which 11882 C relate to the measurement of errors. Either routine can be 11883 C replaced by a user-supplied version, if desired. However, since such 11884 C a replacement may have a major impact on performance, it should be 11885 C done only when absolutely necessary, and only with great caution. 11886 C (Note: The means by which the package version of a routine is 11887 C superseded by the user's version may be system-dependent.) 11888 C 11889 C (a) DEWSET. 11890 C The following subroutine is called just before each internal 11891 C integration step, and sets the array of error weights, EWT, as 11892 C described under ITOL/RTOL/ATOL above: 11893 C SUBROUTINE DEWSET (NEQ, ITOL, RTOL, ATOL, YCUR, EWT) 11894 C where NEQ, ITOL, RTOL, and ATOL are as in the DLSODI call sequence, 11895 C YCUR contains the current dependent variable vector, and 11896 C EWT is the array of weights set by DEWSET. 11897 C 11898 C If the user supplies this subroutine, it must return in EWT(i) 11899 C (i = 1,...,NEQ) a positive quantity suitable for comparing errors 11900 C in y(i) to. The EWT array returned by DEWSET is passed to the DVNORM 11901 C routine (see below), and also used by DLSODI in the computation 11902 C of the optional output IMXER, the diagonal Jacobian approximation, 11903 C and the increments for difference quotient Jacobians. 11904 C 11905 C In the user-supplied version of DEWSET, it may be desirable to use 11906 C the current values of derivatives of y. Derivatives up to order NQ 11907 C are available from the history array YH, described above under 11908 C optional outputs. In DEWSET, YH is identical to the YCUR array, 11909 C extended to NQ + 1 columns with a column length of NYH and scale 11910 C factors of H**j/factorial(j). On the first call for the problem, 11911 C given by NST = 0, NQ is 1 and H is temporarily set to 1.0. 11912 C NYH is the initial value of NEQ. The quantities NQ, H, and NST 11913 C can be obtained by including in DEWSET the statements: 11914 C DOUBLE PRECISION RLS 11915 C COMMON /DLS001/ RLS(218),ILS(37) 11916 C NQ = ILS(33) 11917 C NST = ILS(34) 11918 C H = RLS(212) 11919 C Thus, for example, the current value of dy/dt can be obtained as 11920 C YCUR(NYH+i)/H (i=1,...,NEQ) (and the division by H is 11921 C unnecessary when NST = 0). 11922 C 11923 C (b) DVNORM. 11924 C The following is a real function routine which computes the weighted 11925 C root-mean-square norm of a vector v: 11926 C D = DVNORM (N, V, W) 11927 C where: 11928 C N = the length of the vector, 11929 C V = real array of length N containing the vector, 11930 C W = real array of length N containing weights, 11931 C D = SQRT( (1/N) * sum(V(i)*W(i))**2 ). 11932 C DVNORM is called with N = NEQ and with W(i) = 1.0/EWT(i), where 11933 C EWT is as set by Subroutine DEWSET. 11934 C 11935 C If the user supplies this function, it should return a non-negative 11936 C value of DVNORM suitable for use in the error control in DLSODI. 11937 C None of the arguments should be altered by DVNORM. 11938 C For example, a user-supplied DVNORM routine might: 11939 C -substitute a max-norm of (V(i)*W(i)) for the RMS-norm, or 11940 C -ignore some components of V in the norm, with the effect of 11941 C suppressing the error control on those components of y. 11942 C----------------------------------------------------------------------- 11943 C 11944 C***REVISION HISTORY (YYYYMMDD) 11945 C 19800424 DATE WRITTEN 11946 C 19800519 Corrected access of YH on forced order reduction; 11947 C numerous corrections to prologues and other comments. 11948 C 19800617 In main driver, added loading of SQRT(UROUND) in RWORK; 11949 C minor corrections to main prologue. 11950 C 19800903 Corrected ISTATE logic; minor changes in prologue. 11951 C 19800923 Added zero initialization of HU and NQU. 11952 C 19801028 Reorganized RES calls in AINVG, STODI, and PREPJI; 11953 C in LSODI, corrected NRE increment and reset LDY0 at 580; 11954 C numerous corrections to main prologue. 11955 C 19801218 Revised XERRWD routine; minor corrections to main prologue. 11956 C 19810330 Added Common block /LSI001/; use LSODE's INTDY and SOLSY; 11957 C minor corrections to XERRWD and error message at 604; 11958 C minor corrections to declarations; corrections to prologues. 11959 C 19810818 Numerous revisions: replaced EWT by 1/EWT; used flags 11960 C JCUR, ICF, IERPJ, IERSL between STODI and subordinates; 11961 C added tuning parameters CCMAX, MAXCOR, MSBP, MXNCF; 11962 C reorganized returns from STODI; reorganized type decls.; 11963 C fixed message length in XERRWD; changed default LUNIT to 6; 11964 C changed Common lengths; changed comments throughout. 11965 C 19820906 Corrected use of ABS(H) in STODI; minor comment fixes. 11966 C 19830510 Numerous revisions: revised diff. quotient increment; 11967 C eliminated block /LSI001/, using IERPJ flag; 11968 C revised STODI logic after PJAC return; 11969 C revised tuning of H change and step attempts in STODI; 11970 C corrections to main prologue and internal comments. 11971 C 19870330 Major update: corrected comments throughout; 11972 C removed TRET from Common; rewrote EWSET with 4 loops; 11973 C fixed t test in INTDY; added Cray directives in STODI; 11974 C in STODI, fixed DELP init. and logic around PJAC call; 11975 C combined routines to save/restore Common; 11976 C passed LEVEL = 0 in error message calls (except run abort). 11977 C 20010425 Major update: convert source lines to upper case; 11978 C added *DECK lines; changed from 1 to * in dummy dimensions; 11979 C changed names R1MACH/D1MACH to RUMACH/DUMACH; 11980 C renamed routines for uniqueness across single/double prec.; 11981 C converted intrinsic names to generic form; 11982 C removed ILLIN and NTREP (data loaded) from Common; 11983 C removed all 'own' variables from Common; 11984 C changed error messages to quoted strings; 11985 C replaced XERRWV/XERRWD with 1993 revised version; 11986 C converted prologues, comments, error messages to mixed case; 11987 C converted arithmetic IF statements to logical IF statements; 11988 C numerous corrections to prologues and internal comments. 11989 C 20010507 Converted single precision source to double precision. 11990 C 20020502 Corrected declarations in descriptions of user routines. 11991 C 20031105 Restored 'own' variables to Common block, to enable 11992 C interrupt/restart feature. 11993 C 20031112 Added SAVE statements for data-loaded constants. 11994 C 20031117 Changed internal names NRE, LSAVR to NFE, LSAVF resp. 11995 C 11996 C----------------------------------------------------------------------- 11997 C Other routines in the DLSODI package. 11998 C 11999 C In addition to Subroutine DLSODI, the DLSODI package includes the 12000 C following subroutines and function routines: 12001 C DAINVG computes the initial value of the vector 12002 C dy/dt = A-inverse * g 12003 C DINTDY computes an interpolated value of the y vector at t = TOUT. 12004 C DSTODI is the core integrator, which does one step of the 12005 C integration and the associated error control. 12006 C DCFODE sets all method coefficients and test constants. 12007 C DPREPJI computes and preprocesses the Jacobian matrix 12008 C and the Newton iteration matrix P. 12009 C DSOLSY manages solution of linear system in chord iteration. 12010 C DEWSET sets the error weight vector EWT before each step. 12011 C DVNORM computes the weighted RMS-norm of a vector. 12012 C DSRCOM is a user-callable routine to save and restore 12013 C the contents of the internal Common blocks. 12014 C DGEFA and DGESL are routines from LINPACK for solving full 12015 C systems of linear algebraic equations. 12016 C DGBFA and DGBSL are routines from LINPACK for solving banded 12017 C linear systems. 12018 C DUMACH computes the unit roundoff in a machine-independent manner. 12019 C XERRWD, XSETUN, XSETF, IXSAV, and IUMACH handle the printing of all 12020 C error messages and warnings. XERRWD is machine-dependent. 12021 C Note: DVNORM, DUMACH, IXSAV, and IUMACH are function routines. 12022 C All the others are subroutines. 12023 C 12024 C----------------------------------------------------------------------- 12025 EXTERNAL DPREPJI, DSOLSY 12026 DOUBLE PRECISION DUMACH, DVNORM 12027 INTEGER INIT, MXSTEP, MXHNIL, NHNIL, NSLAST, NYH, IOWNS, 12028 1 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 12029 2 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 12030 3 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU 12031 INTEGER I, I1, I2, IER, IFLAG, IMXER, IRES, KGO, 12032 1 LENIW, LENRW, LENWM, LP, LYD0, ML, MORD, MU, MXHNL0, MXSTP0 12033 DOUBLE PRECISION ROWNS, 12034 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND 12035 DOUBLE PRECISION ATOLI, AYI, BIG, EWTI, H0, HMAX, HMX, RH, RTOLI, 12036 1 TCRIT, TDIST, TNEXT, TOL, TOLSF, TP, SIZE, SUM, W0 12037 DIMENSION MORD(2) 12038 LOGICAL IHIT 12039 CHARACTER*60 MSG 12040 SAVE MORD, MXSTP0, MXHNL0 12041 C----------------------------------------------------------------------- 12042 C The following internal Common block contains 12043 C (a) variables which are local to any subroutine but whose values must 12044 C be preserved between calls to the routine ("own" variables), and 12045 C (b) variables which are communicated between subroutines. 12046 C The block DLS001 is declared in subroutines DLSODI, DINTDY, DSTODI, 12047 C DPREPJI, and DSOLSY. 12048 C Groups of variables are replaced by dummy arrays in the Common 12049 C declarations in routines where those variables are not used. 12050 C----------------------------------------------------------------------- 12051 COMMON /DLS001/ ROWNS(209), 12052 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND, 12053 2 INIT, MXSTEP, MXHNIL, NHNIL, NSLAST, NYH, IOWNS(6), 12054 3 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 12055 4 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 12056 5 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU 12057 C 12058 DATA MORD(1),MORD(2)/12,5/, MXSTP0/500/, MXHNL0/10/ 12059 C----------------------------------------------------------------------- 12060 C Block A. 12061 C This code block is executed on every call. 12062 C It tests ISTATE and ITASK for legality and branches appropriately. 12063 C If ISTATE .gt. 1 but the flag INIT shows that initialization has 12064 C not yet been done, an error return occurs. 12065 C If ISTATE = 0 or 1 and TOUT = T, return immediately. 12066 C----------------------------------------------------------------------- 12067 IF (ISTATE .LT. 0 .OR. ISTATE .GT. 3) GO TO 601 12068 IF (ITASK .LT. 1 .OR. ITASK .GT. 5) GO TO 602 12069 IF (ISTATE .LE. 1) GO TO 10 12070 IF (INIT .EQ. 0) GO TO 603 12071 IF (ISTATE .EQ. 2) GO TO 200 12072 GO TO 20 12073 10 INIT = 0 12074 IF (TOUT .EQ. T) RETURN 12075 C----------------------------------------------------------------------- 12076 C Block B. 12077 C The next code block is executed for the initial call (ISTATE = 0 or 1) 12078 C or for a continuation call with parameter changes (ISTATE = 3). 12079 C It contains checking of all inputs and various initializations. 12080 C 12081 C First check legality of the non-optional inputs NEQ, ITOL, IOPT, 12082 C MF, ML, and MU. 12083 C----------------------------------------------------------------------- 12084 20 IF (NEQ(1) .LE. 0) GO TO 604 12085 IF (ISTATE .LE. 1) GO TO 25 12086 IF (NEQ(1) .GT. N) GO TO 605 12087 25 N = NEQ(1) 12088 IF (ITOL .LT. 1 .OR. ITOL .GT. 4) GO TO 606 12089 IF (IOPT .LT. 0 .OR. IOPT .GT. 1) GO TO 607 12090 METH = MF/10 12091 MITER = MF - 10*METH 12092 IF (METH .LT. 1 .OR. METH .GT. 2) GO TO 608 12093 IF (MITER .LE. 0 .OR. MITER .GT. 5) GO TO 608 12094 IF (MITER .EQ. 3) GO TO 608 12095 IF (MITER .LT. 3) GO TO 30 12096 ML = IWORK(1) 12097 MU = IWORK(2) 12098 IF (ML .LT. 0 .OR. ML .GE. N) GO TO 609 12099 IF (MU .LT. 0 .OR. MU .GE. N) GO TO 610 12100 30 CONTINUE 12101 C Next process and check the optional inputs. -------------------------- 12102 IF (IOPT .EQ. 1) GO TO 40 12103 MAXORD = MORD(METH) 12104 MXSTEP = MXSTP0 12105 MXHNIL = MXHNL0 12106 IF (ISTATE .LE. 1) H0 = 0.0D0 12107 HMXI = 0.0D0 12108 HMIN = 0.0D0 12109 GO TO 60 12110 40 MAXORD = IWORK(5) 12111 IF (MAXORD .LT. 0) GO TO 611 12112 IF (MAXORD .EQ. 0) MAXORD = 100 12113 MAXORD = MIN(MAXORD,MORD(METH)) 12114 MXSTEP = IWORK(6) 12115 IF (MXSTEP .LT. 0) GO TO 612 12116 IF (MXSTEP .EQ. 0) MXSTEP = MXSTP0 12117 MXHNIL = IWORK(7) 12118 IF (MXHNIL .LT. 0) GO TO 613 12119 IF (MXHNIL .EQ. 0) MXHNIL = MXHNL0 12120 IF (ISTATE .GT. 1) GO TO 50 12121 H0 = RWORK(5) 12122 IF ((TOUT - T)*H0 .LT. 0.0D0) GO TO 614 12123 50 HMAX = RWORK(6) 12124 IF (HMAX .LT. 0.0D0) GO TO 615 12125 HMXI = 0.0D0 12126 IF (HMAX .GT. 0.0D0) HMXI = 1.0D0/HMAX 12127 HMIN = RWORK(7) 12128 IF (HMIN .LT. 0.0D0) GO TO 616 12129 C----------------------------------------------------------------------- 12130 C Set work array pointers and check lengths LRW and LIW. 12131 C Pointers to segments of RWORK and IWORK are named by prefixing L to 12132 C the name of the segment. E.g., the segment YH starts at RWORK(LYH). 12133 C Segments of RWORK (in order) are denoted YH, WM, EWT, SAVR, ACOR. 12134 C----------------------------------------------------------------------- 12135 60 LYH = 21 12136 IF (ISTATE .LE. 1) NYH = N 12137 LWM = LYH + (MAXORD + 1)*NYH 12138 IF (MITER .LE. 2) LENWM = N*N + 2 12139 IF (MITER .GE. 4) LENWM = (2*ML + MU + 1)*N + 2 12140 LEWT = LWM + LENWM 12141 LSAVF = LEWT + N 12142 LACOR = LSAVF + N 12143 LENRW = LACOR + N - 1 12144 IWORK(17) = LENRW 12145 LIWM = 1 12146 LENIW = 20 + N 12147 IWORK(18) = LENIW 12148 IF (LENRW .GT. LRW) GO TO 617 12149 IF (LENIW .GT. LIW) GO TO 618 12150 C Check RTOL and ATOL for legality. ------------------------------------ 12151 RTOLI = RTOL(1) 12152 ATOLI = ATOL(1) 12153 DO 70 I = 1,N 12154 IF (ITOL .GE. 3) RTOLI = RTOL(I) 12155 IF (ITOL .EQ. 2 .OR. ITOL .EQ. 4) ATOLI = ATOL(I) 12156 IF (RTOLI .LT. 0.0D0) GO TO 619 12157 IF (ATOLI .LT. 0.0D0) GO TO 620 12158 70 CONTINUE 12159 IF (ISTATE .LE. 1) GO TO 100 12160 C If ISTATE = 3, set flag to signal parameter changes to DSTODI. ------- 12161 JSTART = -1 12162 IF (NQ .LE. MAXORD) GO TO 90 12163 C MAXORD was reduced below NQ. Copy YH(*,MAXORD+2) into YDOTI.--------- 12164 DO 80 I = 1,N 12165 80 YDOTI(I) = RWORK(I+LWM-1) 12166 C Reload WM(1) = RWORK(lWM), since lWM may have changed. --------------- 12167 90 RWORK(LWM) = SQRT(UROUND) 12168 IF (N .EQ. NYH) GO TO 200 12169 C NEQ was reduced. Zero part of YH to avoid undefined references. ----- 12170 I1 = LYH + L*NYH 12171 I2 = LYH + (MAXORD + 1)*NYH - 1 12172 IF (I1 .GT. I2) GO TO 200 12173 DO 95 I = I1,I2 12174 95 RWORK(I) = 0.0D0 12175 GO TO 200 12176 C----------------------------------------------------------------------- 12177 C Block C. 12178 C The next block is for the initial call only (ISTATE = 0 or 1). 12179 C It contains all remaining initializations, the call to DAINVG 12180 C (if ISTATE = 1), and the calculation of the initial step size. 12181 C The error weights in EWT are inverted after being loaded. 12182 C----------------------------------------------------------------------- 12183 100 UROUND = DUMACH() 12184 TN = T 12185 IF (ITASK .NE. 4 .AND. ITASK .NE. 5) GO TO 105 12186 TCRIT = RWORK(1) 12187 IF ((TCRIT - TOUT)*(TOUT - T) .LT. 0.0D0) GO TO 625 12188 IF (H0 .NE. 0.0D0 .AND. (T + H0 - TCRIT)*H0 .GT. 0.0D0) 12189 1 H0 = TCRIT - T 12190 105 JSTART = 0 12191 RWORK(LWM) = SQRT(UROUND) 12192 NHNIL = 0 12193 NST = 0 12194 NFE = 0 12195 NJE = 0 12196 NSLAST = 0 12197 HU = 0.0D0 12198 NQU = 0 12199 CCMAX = 0.3D0 12200 MAXCOR = 3 12201 MSBP = 20 12202 MXNCF = 10 12203 C Compute initial dy/dt, if necessary, and load it and initial Y into YH 12204 LYD0 = LYH + NYH 12205 LP = LWM + 1 12206 IF (ISTATE .EQ. 1) GO TO 120 12207 C DLSODI must compute initial dy/dt (LYD0 points to YH(*,2)). ---------- 12208 CALL DAINVG( RES, ADDA, NEQ, T, Y, RWORK(LYD0), MITER, 12209 1 ML, MU, RWORK(LP), IWORK(21), IER ) 12210 NFE = NFE + 1 12211 IF (IER .LT. 0) GO TO 560 12212 IF (IER .GT. 0) GO TO 565 12213 DO 115 I = 1,N 12214 115 RWORK(I+LYH-1) = Y(I) 12215 GO TO 130 12216 C Initial dy/dt was supplied. Load into YH (LYD0 points to YH(*,2).). - 12217 120 DO 125 I = 1,N 12218 RWORK(I+LYH-1) = Y(I) 12219 125 RWORK(I+LYD0-1) = YDOTI(I) 12220 C Load and invert the EWT array. (H is temporarily set to 1.0.) ------- 12221 130 CONTINUE 12222 NQ = 1 12223 H = 1.0D0 12224 CALL DEWSET (N, ITOL, RTOL, ATOL, RWORK(LYH), RWORK(LEWT)) 12225 DO 135 I = 1,N 12226 IF (RWORK(I+LEWT-1) .LE. 0.0D0) GO TO 621 12227 135 RWORK(I+LEWT-1) = 1.0D0/RWORK(I+LEWT-1) 12228 C----------------------------------------------------------------------- 12229 C The coding below computes the step size, H0, to be attempted on the 12230 C first step, unless the user has supplied a value for this. 12231 C First check that TOUT - T differs significantly from zero. 12232 C A scalar tolerance quantity TOL is computed, as MAX(RTOL(i)) 12233 C if this is positive, or MAX(ATOL(i)/ABS(Y(i))) otherwise, adjusted 12234 C so as to be between 100*UROUND and 1.0E-3. 12235 C Then the computed value H0 is given by.. 12236 C NEQ 12237 C H0**2 = TOL / ( w0**-2 + (1/NEQ) * Sum ( YDOT(i)/ywt(i) )**2 ) 12238 C 1 12239 C where w0 = MAX ( ABS(T), ABS(TOUT) ), 12240 C YDOT(i) = i-th component of initial value of dy/dt, 12241 C ywt(i) = EWT(i)/TOL (a weight for y(i)). 12242 C The sign of H0 is inferred from the initial values of TOUT and T. 12243 C----------------------------------------------------------------------- 12244 IF (H0 .NE. 0.0D0) GO TO 180 12245 TDIST = ABS(TOUT - T) 12246 W0 = MAX(ABS(T),ABS(TOUT)) 12247 IF (TDIST .LT. 2.0D0*UROUND*W0) GO TO 622 12248 TOL = RTOL(1) 12249 IF (ITOL .LE. 2) GO TO 145 12250 DO 140 I = 1,N 12251 140 TOL = MAX(TOL,RTOL(I)) 12252 145 IF (TOL .GT. 0.0D0) GO TO 160 12253 ATOLI = ATOL(1) 12254 DO 150 I = 1,N 12255 IF (ITOL .EQ. 2 .OR. ITOL .EQ. 4) ATOLI = ATOL(I) 12256 AYI = ABS(Y(I)) 12257 IF (AYI .NE. 0.0D0) TOL = MAX(TOL,ATOLI/AYI) 12258 150 CONTINUE 12259 160 TOL = MAX(TOL,100.0D0*UROUND) 12260 TOL = MIN(TOL,0.001D0) 12261 SUM = DVNORM (N, RWORK(LYD0), RWORK(LEWT)) 12262 SUM = 1.0D0/(TOL*W0*W0) + TOL*SUM**2 12263 H0 = 1.0D0/SQRT(SUM) 12264 H0 = MIN(H0,TDIST) 12265 H0 = SIGN(H0,TOUT-T) 12266 C Adjust H0 if necessary to meet HMAX bound. --------------------------- 12267 180 RH = ABS(H0)*HMXI 12268 IF (RH .GT. 1.0D0) H0 = H0/RH 12269 C Load H with H0 and scale YH(*,2) by H0. ------------------------------ 12270 H = H0 12271 DO 190 I = 1,N 12272 190 RWORK(I+LYD0-1) = H0*RWORK(I+LYD0-1) 12273 GO TO 270 12274 C----------------------------------------------------------------------- 12275 C Block D. 12276 C The next code block is for continuation calls only (ISTATE = 2 or 3) 12277 C and is to check stop conditions before taking a step. 12278 C----------------------------------------------------------------------- 12279 200 NSLAST = NST 12280 GO TO (210, 250, 220, 230, 240), ITASK 12281 210 IF ((TN - TOUT)*H .LT. 0.0D0) GO TO 250 12282 CALL DINTDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) 12283 IF (IFLAG .NE. 0) GO TO 627 12284 T = TOUT 12285 GO TO 420 12286 220 TP = TN - HU*(1.0D0 + 100.0D0*UROUND) 12287 IF ((TP - TOUT)*H .GT. 0.0D0) GO TO 623 12288 IF ((TN - TOUT)*H .LT. 0.0D0) GO TO 250 12289 GO TO 400 12290 230 TCRIT = RWORK(1) 12291 IF ((TN - TCRIT)*H .GT. 0.0D0) GO TO 624 12292 IF ((TCRIT - TOUT)*H .LT. 0.0D0) GO TO 625 12293 IF ((TN - TOUT)*H .LT. 0.0D0) GO TO 245 12294 CALL DINTDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) 12295 IF (IFLAG .NE. 0) GO TO 627 12296 T = TOUT 12297 GO TO 420 12298 240 TCRIT = RWORK(1) 12299 IF ((TN - TCRIT)*H .GT. 0.0D0) GO TO 624 12300 245 HMX = ABS(TN) + ABS(H) 12301 IHIT = ABS(TN - TCRIT) .LE. 100.0D0*UROUND*HMX 12302 IF (IHIT) GO TO 400 12303 TNEXT = TN + H*(1.0D0 + 4.0D0*UROUND) 12304 IF ((TNEXT - TCRIT)*H .LE. 0.0D0) GO TO 250 12305 H = (TCRIT - TN)*(1.0D0 - 4.0D0*UROUND) 12306 IF (ISTATE .EQ. 2) JSTART = -2 12307 C----------------------------------------------------------------------- 12308 C Block E. 12309 C The next block is normally executed for all calls and contains 12310 C the call to the one-step core integrator DSTODI. 12311 C 12312 C This is a looping point for the integration steps. 12313 C 12314 C First check for too many steps being taken, update EWT (if not at 12315 C start of problem), check for too much accuracy being requested, and 12316 C check for H below the roundoff level in T. 12317 C----------------------------------------------------------------------- 12318 250 CONTINUE 12319 IF ((NST-NSLAST) .GE. MXSTEP) GO TO 500 12320 CALL DEWSET (N, ITOL, RTOL, ATOL, RWORK(LYH), RWORK(LEWT)) 12321 DO 260 I = 1,N 12322 IF (RWORK(I+LEWT-1) .LE. 0.0D0) GO TO 510 12323 260 RWORK(I+LEWT-1) = 1.0D0/RWORK(I+LEWT-1) 12324 270 TOLSF = UROUND*DVNORM (N, RWORK(LYH), RWORK(LEWT)) 12325 IF (TOLSF .LE. 1.0D0) GO TO 280 12326 TOLSF = TOLSF*2.0D0 12327 IF (NST .EQ. 0) GO TO 626 12328 GO TO 520 12329 280 IF ((TN + H) .NE. TN) GO TO 290 12330 NHNIL = NHNIL + 1 12331 IF (NHNIL .GT. MXHNIL) GO TO 290 12332 MSG = 'DLSODI- Warning..Internal T (=R1) and H (=R2) are' 12333 CALL XERRWD (MSG, 50, 101, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 12334 MSG=' such that in the machine, T + H = T on the next step ' 12335 CALL XERRWD (MSG, 60, 101, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 12336 MSG = ' (H = step size). Solver will continue anyway.' 12337 CALL XERRWD (MSG, 50, 101, 0, 0, 0, 0, 2, TN, H) 12338 IF (NHNIL .LT. MXHNIL) GO TO 290 12339 MSG = 'DLSODI- Above warning has been issued I1 times. ' 12340 CALL XERRWD (MSG, 50, 102, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 12341 MSG = ' It will not be issued again for this problem.' 12342 CALL XERRWD (MSG, 50, 102, 0, 1, MXHNIL, 0, 0, 0.0D0, 0.0D0) 12343 290 CONTINUE 12344 C----------------------------------------------------------------------- 12345 C CALL DSTODI(NEQ,Y,YH,NYH,YH1,EWT,SAVF,SAVR,ACOR,WM,IWM,RES, 12346 C ADDA,JAC,DPREPJI,DSOLSY) 12347 C Note: SAVF in DSTODI occupies the same space as YDOTI in DLSODI. 12348 C----------------------------------------------------------------------- 12349 CALL DSTODI (NEQ, Y, RWORK(LYH), NYH, RWORK(LYH), RWORK(LEWT), 12350 1 YDOTI, RWORK(LSAVF), RWORK(LACOR), RWORK(LWM), 12351 2 IWORK(LIWM), RES, ADDA, JAC, DPREPJI, DSOLSY ) 12352 KGO = 1 - KFLAG 12353 GO TO (300, 530, 540, 400, 550), KGO 12354 C 12355 C KGO = 1:success; 2:error test failure; 3:convergence failure; 12356 C 4:RES ordered return. 5:RES returned error. 12357 C----------------------------------------------------------------------- 12358 C Block F. 12359 C The following block handles the case of a successful return from the 12360 C core integrator (KFLAG = 0). Test for stop conditions. 12361 C----------------------------------------------------------------------- 12362 300 INIT = 1 12363 GO TO (310, 400, 330, 340, 350), ITASK 12364 C ITASK = 1. If TOUT has been reached, interpolate. ------------------- 12365 310 IF ((TN - TOUT)*H .LT. 0.0D0) GO TO 250 12366 CALL DINTDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) 12367 T = TOUT 12368 GO TO 420 12369 C ITASK = 3. Jump to exit if TOUT was reached. ------------------------ 12370 330 IF ((TN - TOUT)*H .GE. 0.0D0) GO TO 400 12371 GO TO 250 12372 C ITASK = 4. see if TOUT or TCRIT was reached. adjust h if necessary. 12373 340 IF ((TN - TOUT)*H .LT. 0.0D0) GO TO 345 12374 CALL DINTDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) 12375 T = TOUT 12376 GO TO 420 12377 345 HMX = ABS(TN) + ABS(H) 12378 IHIT = ABS(TN - TCRIT) .LE. 100.0D0*UROUND*HMX 12379 IF (IHIT) GO TO 400 12380 TNEXT = TN + H*(1.0D0 + 4.0D0*UROUND) 12381 IF ((TNEXT - TCRIT)*H .LE. 0.0D0) GO TO 250 12382 H = (TCRIT - TN)*(1.0D0 - 4.0D0*UROUND) 12383 JSTART = -2 12384 GO TO 250 12385 C ITASK = 5. See if TCRIT was reached and jump to exit. --------------- 12386 350 HMX = ABS(TN) + ABS(H) 12387 IHIT = ABS(TN - TCRIT) .LE. 100.0D0*UROUND*HMX 12388 C----------------------------------------------------------------------- 12389 C Block G. 12390 C The following block handles all successful returns from DLSODI. 12391 C if ITASK .ne. 1, Y is loaded from YH and T is set accordingly. 12392 C ISTATE is set to 2, and the optional outputs are loaded into the 12393 C work arrays before returning. 12394 C----------------------------------------------------------------------- 12395 400 DO 410 I = 1,N 12396 410 Y(I) = RWORK(I+LYH-1) 12397 T = TN 12398 IF (ITASK .NE. 4 .AND. ITASK .NE. 5) GO TO 420 12399 IF (IHIT) T = TCRIT 12400 420 ISTATE = 2 12401 IF (KFLAG .EQ. -3) ISTATE = 3 12402 RWORK(11) = HU 12403 RWORK(12) = H 12404 RWORK(13) = TN 12405 IWORK(11) = NST 12406 IWORK(12) = NFE 12407 IWORK(13) = NJE 12408 IWORK(14) = NQU 12409 IWORK(15) = NQ 12410 RETURN 12411 C----------------------------------------------------------------------- 12412 C Block H. 12413 C The following block handles all unsuccessful returns other than 12414 C those for illegal input. First the error message routine is called. 12415 C If there was an error test or convergence test failure, IMXER is set. 12416 C Then Y is loaded from YH and T is set to TN. 12417 C The optional outputs are loaded into the work arrays before returning. 12418 C----------------------------------------------------------------------- 12419 C The maximum number of steps was taken before reaching TOUT. ---------- 12420 500 MSG = 'DLSODI- At current T (=R1), MXSTEP (=I1) steps ' 12421 CALL XERRWD (MSG, 50, 201, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 12422 MSG = ' taken on this call before reaching TOUT ' 12423 CALL XERRWD (MSG, 50, 201, 0, 1, MXSTEP, 0, 1, TN, 0.0D0) 12424 ISTATE = -1 12425 GO TO 580 12426 C EWT(i) .le. 0.0 for some i (not at start of problem). ---------------- 12427 510 EWTI = RWORK(LEWT+I-1) 12428 MSG = 'DLSODI- At T (=R1), EWT(I1) has become R2 .le. 0.' 12429 CALL XERRWD (MSG, 50, 202, 0, 1, I, 0, 2, TN, EWTI) 12430 ISTATE = -6 12431 GO TO 590 12432 C Too much accuracy requested for machine precision. ------------------- 12433 520 MSG = 'DLSODI- At T (=R1), too much accuracy requested ' 12434 CALL XERRWD (MSG, 50, 203, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 12435 MSG = ' for precision of machine.. See TOLSF (=R2) ' 12436 CALL XERRWD (MSG, 50, 203, 0, 0, 0, 0, 2, TN, TOLSF) 12437 RWORK(14) = TOLSF 12438 ISTATE = -2 12439 GO TO 590 12440 C KFLAG = -1. Error test failed repeatedly or with ABS(H) = HMIN. ----- 12441 530 MSG = 'DLSODI- At T(=R1) and step size H(=R2), the error' 12442 CALL XERRWD (MSG, 50, 204, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 12443 MSG = ' test failed repeatedly or with ABS(H) = HMIN' 12444 CALL XERRWD (MSG, 50, 204, 0, 0, 0, 0, 2, TN, H) 12445 ISTATE = -4 12446 GO TO 570 12447 C KFLAG = -2. Convergence failed repeatedly or with ABS(H) = HMIN. ---- 12448 540 MSG = 'DLSODI- At T (=R1) and step size H (=R2), the ' 12449 CALL XERRWD (MSG, 50, 205, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 12450 MSG = ' corrector convergence failed repeatedly ' 12451 CALL XERRWD (MSG, 50, 205, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 12452 MSG = ' or with ABS(H) = HMIN ' 12453 CALL XERRWD (MSG, 30, 205, 0, 0, 0, 0, 2, TN, H) 12454 ISTATE = -5 12455 GO TO 570 12456 C IRES = 3 returned by RES, despite retries by DSTODI. ----------------- 12457 550 MSG = 'DLSODI- At T (=R1) residual routine returned ' 12458 CALL XERRWD (MSG, 50, 206, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 12459 MSG = ' error IRES = 3 repeatedly. ' 12460 CALL XERRWD (MSG, 40, 206, 0, 0, 0, 0, 1, TN, 0.0D0) 12461 ISTATE = -7 12462 GO TO 590 12463 C DAINVG failed because matrix A was singular. ------------------------- 12464 560 IER = -IER 12465 MSG='DLSODI- Attempt to initialize dy/dt failed: Matrix A is ' 12466 CALL XERRWD (MSG, 60, 207, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 12467 MSG = ' singular. DGEFA or DGBFA returned INFO = I1' 12468 CALL XERRWD (MSG, 50, 207, 0, 1, IER, 0, 0, 0.0D0, 0.0D0) 12469 ISTATE = -8 12470 RETURN 12471 C DAINVG failed because RES set IRES to 2 or 3. ------------------------ 12472 565 MSG = 'DLSODI- Attempt to initialize dy/dt failed ' 12473 CALL XERRWD (MSG, 50, 208, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 12474 MSG = ' because residual routine set its error flag ' 12475 CALL XERRWD (MSG, 50, 208, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 12476 MSG = ' to IRES = (I1)' 12477 CALL XERRWD (MSG, 20, 208, 0, 1, IER, 0, 0, 0.0D0, 0.0D0) 12478 ISTATE = -8 12479 RETURN 12480 C Compute IMXER if relevant. ------------------------------------------- 12481 570 BIG = 0.0D0 12482 IMXER = 1 12483 DO 575 I = 1,N 12484 SIZE = ABS(RWORK(I+LACOR-1)*RWORK(I+LEWT-1)) 12485 IF (BIG .GE. SIZE) GO TO 575 12486 BIG = SIZE 12487 IMXER = I 12488 575 CONTINUE 12489 IWORK(16) = IMXER 12490 C Compute residual if relevant. ---------------------------------------- 12491 580 LYD0 = LYH + NYH 12492 DO 585 I = 1,N 12493 RWORK(I+LSAVF-1) = RWORK(I+LYD0-1)/H 12494 585 Y(I) = RWORK(I+LYH-1) 12495 IRES = 1 12496 CALL RES (NEQ, TN, Y, RWORK(LSAVF), YDOTI, IRES ) 12497 NFE = NFE + 1 12498 IF (IRES .LE. 1) GO TO 595 12499 MSG = 'DLSODI- Residual routine set its flag IRES ' 12500 CALL XERRWD (MSG, 50, 210, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 12501 MSG = ' to (I1) when called for final output. ' 12502 CALL XERRWD (MSG, 50, 210, 0, 1, IRES, 0, 0, 0.0D0, 0.0D0) 12503 GO TO 595 12504 C Set Y vector, T, and optional outputs. ------------------------------- 12505 590 DO 592 I = 1,N 12506 592 Y(I) = RWORK(I+LYH-1) 12507 595 T = TN 12508 RWORK(11) = HU 12509 RWORK(12) = H 12510 RWORK(13) = TN 12511 IWORK(11) = NST 12512 IWORK(12) = NFE 12513 IWORK(13) = NJE 12514 IWORK(14) = NQU 12515 IWORK(15) = NQ 12516 RETURN 12517 C----------------------------------------------------------------------- 12518 C Block I. 12519 C The following block handles all error returns due to illegal input 12520 C (ISTATE = -3), as detected before calling the core integrator. 12521 C First the error message routine is called. If the illegal input 12522 C is a negative ISTATE, the run is aborted (apparent infinite loop). 12523 C----------------------------------------------------------------------- 12524 601 MSG = 'DLSODI- ISTATE (=I1) illegal.' 12525 CALL XERRWD (MSG, 30, 1, 0, 1, ISTATE, 0, 0, 0.0D0, 0.0D0) 12526 IF (ISTATE .LT. 0) GO TO 800 12527 GO TO 700 12528 602 MSG = 'DLSODI- ITASK (=I1) illegal. ' 12529 CALL XERRWD (MSG, 30, 2, 0, 1, ITASK, 0, 0, 0.0D0, 0.0D0) 12530 GO TO 700 12531 603 MSG = 'DLSODI- ISTATE .gt. 1 but DLSODI not initialized.' 12532 CALL XERRWD (MSG, 50, 3, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 12533 GO TO 700 12534 604 MSG = 'DLSODI- NEQ (=I1) .lt. 1 ' 12535 CALL XERRWD (MSG, 30, 4, 0, 1, NEQ(1), 0, 0, 0.0D0, 0.0D0) 12536 GO TO 700 12537 605 MSG = 'DLSODI- ISTATE = 3 and NEQ increased (I1 to I2). ' 12538 CALL XERRWD (MSG, 50, 5, 0, 2, N, NEQ(1), 0, 0.0D0, 0.0D0) 12539 GO TO 700 12540 606 MSG = 'DLSODI- ITOL (=I1) illegal. ' 12541 CALL XERRWD (MSG, 30, 6, 0, 1, ITOL, 0, 0, 0.0D0, 0.0D0) 12542 GO TO 700 12543 607 MSG = 'DLSODI- IOPT (=I1) illegal. ' 12544 CALL XERRWD (MSG, 30, 7, 0, 1, IOPT, 0, 0, 0.0D0, 0.0D0) 12545 GO TO 700 12546 608 MSG = 'DLSODI- MF (=I1) illegal. ' 12547 CALL XERRWD (MSG, 30, 8, 0, 1, MF, 0, 0, 0.0D0, 0.0D0) 12548 GO TO 700 12549 609 MSG = 'DLSODI- ML(=I1) illegal: .lt. 0 or .ge. NEQ(=I2) ' 12550 CALL XERRWD (MSG, 50, 9, 0, 2, ML, NEQ(1), 0, 0.0D0, 0.0D0) 12551 GO TO 700 12552 610 MSG = 'DLSODI- MU(=I1) illegal: .lt. 0 or .ge. NEQ(=I2) ' 12553 CALL XERRWD (MSG, 50, 10, 0, 2, MU, NEQ(1), 0, 0.0D0, 0.0D0) 12554 GO TO 700 12555 611 MSG = 'DLSODI- MAXORD (=I1) .lt. 0 ' 12556 CALL XERRWD (MSG, 30, 11, 0, 1, MAXORD, 0, 0, 0.0D0, 0.0D0) 12557 GO TO 700 12558 612 MSG = 'DLSODI- MXSTEP (=I1) .lt. 0 ' 12559 CALL XERRWD (MSG, 30, 12, 0, 1, MXSTEP, 0, 0, 0.0D0, 0.0D0) 12560 GO TO 700 12561 613 MSG = 'DLSODI- MXHNIL (=I1) .lt. 0 ' 12562 CALL XERRWD (MSG, 30, 13, 0, 1, MXHNIL, 0, 0, 0.0D0, 0.0D0) 12563 GO TO 700 12564 614 MSG = 'DLSODI- TOUT (=R1) behind T (=R2) ' 12565 CALL XERRWD (MSG, 40, 14, 0, 0, 0, 0, 2, TOUT, T) 12566 MSG = ' Integration direction is given by H0 (=R1) ' 12567 CALL XERRWD (MSG, 50, 14, 0, 0, 0, 0, 1, H0, 0.0D0) 12568 GO TO 700 12569 615 MSG = 'DLSODI- HMAX (=R1) .lt. 0.0 ' 12570 CALL XERRWD (MSG, 30, 15, 0, 0, 0, 0, 1, HMAX, 0.0D0) 12571 GO TO 700 12572 616 MSG = 'DLSODI- HMIN (=R1) .lt. 0.0 ' 12573 CALL XERRWD (MSG, 30, 16, 0, 0, 0, 0, 1, HMIN, 0.0D0) 12574 GO TO 700 12575 617 MSG='DLSODI- RWORK length needed, LENRW (=I1), exceeds LRW (=I2)' 12576 CALL XERRWD (MSG, 60, 17, 0, 2, LENRW, LRW, 0, 0.0D0, 0.0D0) 12577 GO TO 700 12578 618 MSG='DLSODI- IWORK length needed, LENIW (=I1), exceeds LIW (=I2)' 12579 CALL XERRWD (MSG, 60, 18, 0, 2, LENIW, LIW, 0, 0.0D0, 0.0D0) 12580 GO TO 700 12581 619 MSG = 'DLSODI- RTOL(=I1) is R1 .lt. 0.0 ' 12582 CALL XERRWD (MSG, 40, 19, 0, 1, I, 0, 1, RTOLI, 0.0D0) 12583 GO TO 700 12584 620 MSG = 'DLSODI- ATOL(=I1) is R1 .lt. 0.0 ' 12585 CALL XERRWD (MSG, 40, 20, 0, 1, I, 0, 1, ATOLI, 0.0D0) 12586 GO TO 700 12587 621 EWTI = RWORK(LEWT+I-1) 12588 MSG = 'DLSODI- EWT(I1) is R1 .le. 0.0 ' 12589 CALL XERRWD (MSG, 40, 21, 0, 1, I, 0, 1, EWTI, 0.0D0) 12590 GO TO 700 12591 622 MSG='DLSODI- TOUT(=R1) too close to T(=R2) to start integration.' 12592 CALL XERRWD (MSG, 60, 22, 0, 0, 0, 0, 2, TOUT, T) 12593 GO TO 700 12594 623 MSG='DLSODI- ITASK = I1 and TOUT (=R1) behind TCUR - HU (= R2) ' 12595 CALL XERRWD (MSG, 60, 23, 0, 1, ITASK, 0, 2, TOUT, TP) 12596 GO TO 700 12597 624 MSG='DLSODI- ITASK = 4 or 5 and TCRIT (=R1) behind TCUR (=R2) ' 12598 CALL XERRWD (MSG, 60, 24, 0, 0, 0, 0, 2, TCRIT, TN) 12599 GO TO 700 12600 625 MSG='DLSODI- ITASK = 4 or 5 and TCRIT (=R1) behind TOUT (=R2) ' 12601 CALL XERRWD (MSG, 60, 25, 0, 0, 0, 0, 2, TCRIT, TOUT) 12602 GO TO 700 12603 626 MSG = 'DLSODI- At start of problem, too much accuracy ' 12604 CALL XERRWD (MSG, 50, 26, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 12605 MSG=' requested for precision of machine.. See TOLSF (=R1) ' 12606 CALL XERRWD (MSG, 60, 26, 0, 0, 0, 0, 1, TOLSF, 0.0D0) 12607 RWORK(14) = TOLSF 12608 GO TO 700 12609 627 MSG = 'DLSODI- Trouble in DINTDY. ITASK = I1, TOUT = R1' 12610 CALL XERRWD (MSG, 50, 27, 0, 1, ITASK, 0, 1, TOUT, 0.0D0) 12611 C 12612 700 ISTATE = -3 12613 RETURN 12614 C 12615 800 MSG = 'DLSODI- Run aborted.. apparent infinite loop. ' 12616 CALL XERRWD (MSG, 50, 303, 2, 0, 0, 0, 0, 0.0D0, 0.0D0) 12617 RETURN 12618 C----------------------- End of Subroutine DLSODI ---------------------- 12619 END 12620 *DECK DLSOIBT 12621 SUBROUTINE DLSOIBT (RES, ADDA, JAC, NEQ, Y, YDOTI, T, TOUT, ITOL, 12622 1 RTOL, ATOL, ITASK, ISTATE, IOPT, RWORK, LRW, IWORK, LIW, MF ) 12623 EXTERNAL RES, ADDA, JAC 12624 INTEGER NEQ, ITOL, ITASK, ISTATE, IOPT, LRW, IWORK, LIW, MF 12625 DOUBLE PRECISION Y, YDOTI, T, TOUT, RTOL, ATOL, RWORK 12626 DIMENSION NEQ(*), Y(*), YDOTI(*), RTOL(*), ATOL(*), RWORK(LRW), 12627 1 IWORK(LIW) 12628 C----------------------------------------------------------------------- 12629 C This is the 18 November 2003 version of 12630 C DLSOIBT: Livermore Solver for Ordinary differential equations given 12631 C in Implicit form, with Block-Tridiagonal Jacobian treatment. 12632 C 12633 C This version is in double precision. 12634 C 12635 C DLSOIBT solves the initial value problem for linearly implicit 12636 C systems of first order ODEs, 12637 C A(t,y) * dy/dt = g(t,y) , where A(t,y) is a square matrix, 12638 C or, in component form, 12639 C ( a * ( dy / dt )) + ... + ( a * ( dy / dt )) = 12640 C i,1 1 i,NEQ NEQ 12641 C 12642 C = g ( t, y , y ,..., y ) ( i = 1,...,NEQ ) 12643 C i 1 2 NEQ 12644 C 12645 C If A is singular, this is a differential-algebraic system. 12646 C 12647 C DLSOIBT is a variant version of the DLSODI package, for the case where 12648 C the matrices A, dg/dy, and d(A*s)/dy are all block-tridiagonal. 12649 C----------------------------------------------------------------------- 12650 C Reference: 12651 C Alan C. Hindmarsh, ODEPACK, A Systematized Collection of ODE 12652 C Solvers, in Scientific Computing, R. S. Stepleman et al. (Eds.), 12653 C North-Holland, Amsterdam, 1983, pp. 55-64. 12654 C----------------------------------------------------------------------- 12655 C Authors: Alan C. Hindmarsh and Jeffrey F. Painter 12656 C Center for Applied Scientific Computing, L-561 12657 C Lawrence Livermore National Laboratory 12658 C Livermore, CA 94551 12659 C and 12660 C Charles S. Kenney 12661 C formerly at: Naval Weapons Center 12662 C China Lake, CA 93555 12663 C----------------------------------------------------------------------- 12664 C Summary of Usage. 12665 C 12666 C Communication between the user and the DLSOIBT package, for normal 12667 C situations, is summarized here. This summary describes only a subset 12668 C of the full set of options available. See the full description for 12669 C details, including optional communication, nonstandard options, 12670 C and instructions for special situations. See also the example 12671 C problem (with program and output) following this summary. 12672 C 12673 C A. First, provide a subroutine of the form: 12674 C SUBROUTINE RES (NEQ, T, Y, S, R, IRES) 12675 C DOUBLE PRECISION T, Y(*), S(*), R(*) 12676 C which computes the residual function 12677 C r = g(t,y) - A(t,y) * s , 12678 C as a function of t and the vectors y and s. (s is an internally 12679 C generated approximation to dy/dt.) The arrays Y and S are inputs 12680 C to the RES routine and should not be altered. The residual 12681 C vector is to be stored in the array R. The argument IRES should be 12682 C ignored for casual use of DLSOIBT. (For uses of IRES, see the 12683 C paragraph on RES in the full description below.) 12684 C 12685 C B. Next, identify the block structure of the matrices A = A(t,y) and 12686 C dr/dy. DLSOIBT must deal internally with a linear combination, P, of 12687 C these two matrices. The matrix P (hence both A and dr/dy) must have 12688 C a block-tridiagonal form with fixed structure parameters 12689 C MB = block size, MB .ge. 1, and 12690 C NB = number of blocks in each direction, NB .ge. 4, 12691 C with MB*NB = NEQ. In each of the NB block-rows of the matrix P 12692 C (each consisting of MB consecutive rows), the nonzero elements are 12693 C to lie in three consecutive MB by MB blocks. In block-rows 12694 C 2 through NB - 1, these are centered about the main diagonal. 12695 C in block-rows 1 and NB, they are the diagonal blocks and the two 12696 C blocks adjacent to the diagonal block. (Thus block positions (1,3) 12697 C and (NB,NB-2) can be nonzero.) 12698 C Alternatively, P (hence A and dr/dy) may be only approximately 12699 C equal to matrices with this form, and DLSOIBT should still succeed. 12700 C The block-tridiagonal matrix P is described by three arrays, 12701 C each of size MB by MB by NB: 12702 C PA = array of diagonal blocks, 12703 C PB = array of superdiagonal (and one subdiagonal) blocks, and 12704 C PC = array of subdiagonal (and one superdiagonal) blocks. 12705 C Specifically, the three MB by MB blocks in the k-th block-row of P 12706 C are stored in (reading across): 12707 C PC(*,*,k) = block to the left of the diagonal block, 12708 C PA(*,*,k) = diagonal block, and 12709 C PB(*,*,k) = block to the right of the diagonal block, 12710 C except for k = 1, where the three blocks (reading across) are 12711 C PA(*,*,1) (= diagonal block), PB(*,*,1), and PC(*,*,1), 12712 C and k = NB, where they are 12713 C PB(*,*,NB), PC(*,*,NB), and PA(*,*,NB) (= diagonal block). 12714 C (Each asterisk * stands for an index that ranges from 1 to MB.) 12715 C 12716 C C. You must also provide a subroutine of the form: 12717 C SUBROUTINE ADDA (NEQ, T, Y, MB, NB, PA, PB, PC) 12718 C DOUBLE PRECISION T, Y(*), PA(MB,MB,NB), PB(MB,MB,NB), PC(MB,MB,NB) 12719 C which adds the nonzero blocks of the matrix A = A(t,y) to the 12720 C contents of the arrays PA, PB, and PC, following the structure 12721 C description in Paragraph B above. 12722 C T and the Y array are input and should not be altered. 12723 C Thus the affect of ADDA should be the following: 12724 C DO 30 K = 1,NB 12725 C DO 20 J = 1,MB 12726 C DO 10 I = 1,MB 12727 C PA(I,J,K) = PA(I,J,K) + 12728 C ( (I,J) element of K-th diagonal block of A) 12729 C PB(I,J,K) = PB(I,J,K) + 12730 C ( (I,J) element of block in block position (K,K+1) of A, 12731 C or in block position (NB,NB-2) if K = NB) 12732 C PC(I,J,K) = PC(I,J,K) + 12733 C ( (I,J) element of block in block position (K,K-1) of A, 12734 C or in block position (1,3) if K = 1) 12735 C 10 CONTINUE 12736 C 20 CONTINUE 12737 C 30 CONTINUE 12738 C 12739 C D. For the sake of efficiency, you are encouraged to supply the 12740 C Jacobian matrix dr/dy in closed form, where r = g(t,y) - A(t,y)*s 12741 C (s = a fixed vector) as above. If dr/dy is being supplied, 12742 C use MF = 21, and provide a subroutine of the form: 12743 C SUBROUTINE JAC (NEQ, T, Y, S, MB, NB, PA, PB, PC) 12744 C DOUBLE PRECISION T, Y(*), S(*), PA(MB,MB,NB), PB(MB,MB,NB), 12745 C 1 PC(MB,MB,NB) 12746 C which computes dr/dy as a function of t, y, and s. Here T, Y, and 12747 C S are inputs, and the routine is to load dr/dy into PA, PB, PC, 12748 C according to the structure description in Paragraph B above. 12749 C That is, load the diagonal blocks into PA, the superdiagonal blocks 12750 C (and block (NB,NB-2) ) into PB, and the subdiagonal blocks (and 12751 C block (1,3) ) into PC. The blocks in block-row k of dr/dy are to 12752 C be loaded into PA(*,*,k), PB(*,*,k), and PC(*,*,k). 12753 C Only nonzero elements need be loaded, and the indexing 12754 C of PA, PB, and PC is the same as in the ADDA routine. 12755 C Note that if A is independent of Y (or this dependence 12756 C is weak enough to be ignored) then JAC is to compute dg/dy. 12757 C If it is not feasible to provide a JAC routine, use 12758 C MF = 22, and DLSOIBT will compute an approximate Jacobian 12759 C internally by difference quotients. 12760 C 12761 C E. Next decide whether or not to provide the initial value of the 12762 C derivative vector dy/dt. If the initial value of A(t,y) is 12763 C nonsingular (and not too ill-conditioned), you may let DLSOIBT compute 12764 C this vector (ISTATE = 0). (DLSOIBT will solve the system A*s = g for 12765 C s, with initial values of A and g.) If A(t,y) is initially 12766 C singular, then the system is a differential-algebraic system, and 12767 C you must make use of the particular form of the system to compute the 12768 C initial values of y and dy/dt. In that case, use ISTATE = 1 and 12769 C load the initial value of dy/dt into the array YDOTI. 12770 C The input array YDOTI and the initial Y array must be consistent with 12771 C the equations A*dy/dt = g. This implies that the initial residual 12772 C r = g(t,y) - A(t,y)*YDOTI must be approximately zero. 12773 C 12774 C F. Write a main program which calls Subroutine DLSOIBT once for 12775 C each point at which answers are desired. This should also provide 12776 C for possible use of logical unit 6 for output of error messages by 12777 C DLSOIBT. on the first call to DLSOIBT, supply arguments as follows: 12778 C RES = name of user subroutine for residual function r. 12779 C ADDA = name of user subroutine for computing and adding A(t,y). 12780 C JAC = name of user subroutine for Jacobian matrix dr/dy 12781 C (MF = 21). If not used, pass a dummy name. 12782 C Note: the names for the RES and ADDA routines and (if used) the 12783 C JAC routine must be declared External in the calling program. 12784 C NEQ = number of scalar equations in the system. 12785 C Y = array of initial values, of length NEQ. 12786 C YDOTI = array of length NEQ (containing initial dy/dt if ISTATE = 1). 12787 C T = the initial value of the independent variable. 12788 C TOUT = first point where output is desired (.ne. T). 12789 C ITOL = 1 or 2 according as ATOL (below) is a scalar or array. 12790 C RTOL = relative tolerance parameter (scalar). 12791 C ATOL = absolute tolerance parameter (scalar or array). 12792 C the estimated local error in y(i) will be controlled so as 12793 C to be roughly less (in magnitude) than 12794 C EWT(i) = RTOL*ABS(Y(i)) + ATOL if ITOL = 1, or 12795 C EWT(i) = RTOL*ABS(Y(i)) + ATOL(i) if ITOL = 2. 12796 C Thus the local error test passes if, in each component, 12797 C either the absolute error is less than ATOL (or ATOL(i)), 12798 C or the relative error is less than RTOL. 12799 C Use RTOL = 0.0 for pure absolute error control, and 12800 C use ATOL = 0.0 (or ATOL(i) = 0.0) for pure relative error 12801 C control. Caution: Actual (global) errors may exceed these 12802 C local tolerances, so choose them conservatively. 12803 C ITASK = 1 for normal computation of output values of y at t = TOUT. 12804 C ISTATE = integer flag (input and output). Set ISTATE = 1 if the 12805 C initial dy/dt is supplied, and 0 otherwise. 12806 C IOPT = 0 to indicate no optional inputs used. 12807 C RWORK = real work array of length at least: 12808 C 22 + 9*NEQ + 3*MB*MB*NB for MF = 21 or 22. 12809 C LRW = declared length of RWORK (in user's dimension). 12810 C IWORK = integer work array of length at least 20 + NEQ. 12811 C Input in IWORK(1) the block size MB and in IWORK(2) the 12812 C number NB of blocks in each direction along the matrix A. 12813 C These must satisfy MB .ge. 1, NB .ge. 4, and MB*NB = NEQ. 12814 C LIW = declared length of IWORK (in user's dimension). 12815 C MF = method flag. Standard values are: 12816 C 21 for a user-supplied Jacobian. 12817 C 22 for an internally generated Jacobian. 12818 C For other choices of MF, see the paragraph on MF in 12819 C the full description below. 12820 C Note that the main program must declare arrays Y, YDOTI, RWORK, IWORK, 12821 C and possibly ATOL. 12822 C 12823 C G. The output from the first call (or any call) is: 12824 C Y = array of computed values of y(t) vector. 12825 C T = corresponding value of independent variable (normally TOUT). 12826 C ISTATE = 2 if DLSOIBT was successful, negative otherwise. 12827 C -1 means excess work done on this call (check all inputs). 12828 C -2 means excess accuracy requested (tolerances too small). 12829 C -3 means illegal input detected (see printed message). 12830 C -4 means repeated error test failures (check all inputs). 12831 C -5 means repeated convergence failures (perhaps bad Jacobian 12832 C supplied or wrong choice of tolerances). 12833 C -6 means error weight became zero during problem. (Solution 12834 C component i vanished, and ATOL or ATOL(i) = 0.) 12835 C -7 cannot occur in casual use. 12836 C -8 means DLSOIBT was unable to compute the initial dy/dt. 12837 C In casual use, this means A(t,y) is initially singular. 12838 C Supply YDOTI and use ISTATE = 1 on the first call. 12839 C 12840 C If DLSOIBT returns ISTATE = -1, -4, or -5, then the output of 12841 C DLSOIBT also includes YDOTI = array containing residual vector 12842 C r = g - A * dy/dt evaluated at the current t, y, and dy/dt. 12843 C 12844 C H. To continue the integration after a successful return, simply 12845 C reset TOUT and call DLSOIBT again. No other parameters need be reset. 12846 C 12847 C----------------------------------------------------------------------- 12848 C Example Problem. 12849 C 12850 C The following is an example problem, with the coding needed 12851 C for its solution by DLSOIBT. The problem comes from the partial 12852 C differential equation (the Burgers equation) 12853 C du/dt = - u * du/dx + eta * d**2 u/dx**2, eta = .05, 12854 C on -1 .le. x .le. 1. The boundary conditions are 12855 C du/dx = 0 at x = -1 and at x = 1. 12856 C The initial profile is a square wave, 12857 C u = 1 in ABS(x) .lt. .5, u = .5 at ABS(x) = .5, u = 0 elsewhere. 12858 C The PDE is discretized in x by a simplified Galerkin method, 12859 C using piecewise linear basis functions, on a grid of 40 intervals. 12860 C The equations at x = -1 and 1 use a 3-point difference approximation 12861 C for the right-hand side. The result is a system A * dy/dt = g(y), 12862 C of size NEQ = 41, where y(i) is the approximation to u at x = x(i), 12863 C with x(i) = -1 + (i-1)*delx, delx = 2/(NEQ-1) = .05. The individual 12864 C equations in the system are 12865 C dy(1)/dt = ( y(3) - 2*y(2) + y(1) ) * eta / delx**2, 12866 C dy(NEQ)/dt = ( y(NEQ-2) - 2*y(NEQ-1) + y(NEQ) ) * eta / delx**2, 12867 C and for i = 2, 3, ..., NEQ-1, 12868 C (1/6) dy(i-1)/dt + (4/6) dy(i)/dt + (1/6) dy(i+1)/dt 12869 C = ( y(i-1)**2 - y(i+1)**2 ) / (4*delx) 12870 C + ( y(i+1) - 2*y(i) + y(i-1) ) * eta / delx**2. 12871 C The following coding solves the problem with MF = 21, with output 12872 C of solution statistics at t = .1, .2, .3, and .4, and of the 12873 C solution vector at t = .4. Here the block size is just MB = 1. 12874 C 12875 C EXTERNAL RESID, ADDABT, JACBT 12876 C DOUBLE PRECISION ATOL, RTOL, RWORK, T, TOUT, Y, YDOTI 12877 C DIMENSION Y(41), YDOTI(41), RWORK(514), IWORK(61) 12878 C NEQ = 41 12879 C DO 10 I = 1,NEQ 12880 C 10 Y(I) = 0.0 12881 C Y(11) = 0.5 12882 C DO 20 I = 12,30 12883 C 20 Y(I) = 1.0 12884 C Y(31) = 0.5 12885 C T = 0.0 12886 C TOUT = 0.1 12887 C ITOL = 1 12888 C RTOL = 1.0D-4 12889 C ATOL = 1.0D-5 12890 C ITASK = 1 12891 C ISTATE = 0 12892 C IOPT = 0 12893 C LRW = 514 12894 C LIW = 61 12895 C IWORK(1) = 1 12896 C IWORK(2) = NEQ 12897 C MF = 21 12898 C DO 40 IO = 1,4 12899 C CALL DLSOIBT (RESID, ADDABT, JACBT, NEQ, Y, YDOTI, T, TOUT, 12900 C 1 ITOL,RTOL,ATOL, ITASK, ISTATE, IOPT, RWORK,LRW,IWORK,LIW, MF) 12901 C WRITE (6,30) T, IWORK(11), IWORK(12), IWORK(13) 12902 C 30 FORMAT(' At t =',F5.2,' No. steps =',I4,' No. r-s =',I4, 12903 C 1 ' No. J-s =',I3) 12904 C IF (ISTATE .NE. 2) GO TO 90 12905 C TOUT = TOUT + 0.1 12906 C 40 CONTINUE 12907 C WRITE(6,50) (Y(I),I=1,NEQ) 12908 C 50 FORMAT(/' Final solution values..'/9(5D12.4/)) 12909 C STOP 12910 C 90 WRITE(6,95) ISTATE 12911 C 95 FORMAT(///' Error halt.. ISTATE =',I3) 12912 C STOP 12913 C END 12914 C 12915 C SUBROUTINE RESID (N, T, Y, S, R, IRES) 12916 C DOUBLE PRECISION T, Y, S, R, ETA, DELX, EODSQ 12917 C DIMENSION Y(N), S(N), R(N) 12918 C DATA ETA/0.05/, DELX/0.05/ 12919 C EODSQ = ETA/DELX**2 12920 C R(1) = EODSQ*(Y(3) - 2.0*Y(2) + Y(1)) - S(1) 12921 C NM1 = N - 1 12922 C DO 10 I = 2,NM1 12923 C R(I) = (Y(I-1)**2 - Y(I+1)**2)/(4.0*DELX) 12924 C 1 + EODSQ*(Y(I+1) - 2.0*Y(I) + Y(I-1)) 12925 C 2 - (S(I-1) + 4.0*S(I) + S(I+1))/6.0 12926 C 10 CONTINUE 12927 C R(N) = EODSQ*(Y(N-2) - 2.0*Y(NM1) + Y(N)) - S(N) 12928 C RETURN 12929 C END 12930 C 12931 C SUBROUTINE ADDABT (N, T, Y, MB, NB, PA, PB, PC) 12932 C DOUBLE PRECISION T, Y, PA, PB, PC 12933 C DIMENSION Y(N), PA(MB,MB,NB), PB(MB,MB,NB), PC(MB,MB,NB) 12934 C PA(1,1,1) = PA(1,1,1) + 1.0 12935 C NM1 = N - 1 12936 C DO 10 K = 2,NM1 12937 C PA(1,1,K) = PA(1,1,K) + (4.0/6.0) 12938 C PB(1,1,K) = PB(1,1,K) + (1.0/6.0) 12939 C PC(1,1,K) = PC(1,1,K) + (1.0/6.0) 12940 C 10 CONTINUE 12941 C PA(1,1,N) = PA(1,1,N) + 1.0 12942 C RETURN 12943 C END 12944 C 12945 C SUBROUTINE JACBT (N, T, Y, S, MB, NB, PA, PB, PC) 12946 C DOUBLE PRECISION T, Y, S, PA, PB, PC, ETA, DELX, EODSQ 12947 C DIMENSION Y(N), S(N), PA(MB,MB,NB),PB(MB,MB,NB),PC(MB,MB,NB) 12948 C DATA ETA/0.05/, DELX/0.05/ 12949 C EODSQ = ETA/DELX**2 12950 C PA(1,1,1) = EODSQ 12951 C PB(1,1,1) = -2.0*EODSQ 12952 C PC(1,1,1) = EODSQ 12953 C DO 10 K = 2,N 12954 C PA(1,1,K) = -2.0*EODSQ 12955 C PB(1,1,K) = -Y(K+1)*(0.5/DELX) + EODSQ 12956 C PC(1,1,K) = Y(K-1)*(0.5/DELX) + EODSQ 12957 C 10 CONTINUE 12958 C PB(1,1,N) = EODSQ 12959 C PC(1,1,N) = -2.0*EODSQ 12960 C PA(1,1,N) = EODSQ 12961 C RETURN 12962 C END 12963 C 12964 C The output of this program (on a CDC-7600 in single precision) 12965 C is as follows: 12966 C 12967 C At t = 0.10 No. steps = 35 No. r-s = 45 No. J-s = 9 12968 C At t = 0.20 No. steps = 43 No. r-s = 54 No. J-s = 10 12969 C At t = 0.30 No. steps = 48 No. r-s = 60 No. J-s = 11 12970 C At t = 0.40 No. steps = 51 No. r-s = 64 No. J-s = 12 12971 C 12972 C Final solution values.. 12973 C 1.2747e-02 1.1997e-02 1.5560e-02 2.3767e-02 3.7224e-02 12974 C 5.6646e-02 8.2645e-02 1.1557e-01 1.5541e-01 2.0177e-01 12975 C 2.5397e-01 3.1104e-01 3.7189e-01 4.3530e-01 5.0000e-01 12976 C 5.6472e-01 6.2816e-01 6.8903e-01 7.4612e-01 7.9829e-01 12977 C 8.4460e-01 8.8438e-01 9.1727e-01 9.4330e-01 9.6281e-01 12978 C 9.7632e-01 9.8426e-01 9.8648e-01 9.8162e-01 9.6617e-01 12979 C 9.3374e-01 8.7535e-01 7.8236e-01 6.5321e-01 5.0003e-01 12980 C 3.4709e-01 2.1876e-01 1.2771e-01 7.3671e-02 5.0642e-02 12981 C 5.4496e-02 12982 C 12983 C----------------------------------------------------------------------- 12984 C Full Description of User Interface to DLSOIBT. 12985 C 12986 C The user interface to DLSOIBT consists of the following parts. 12987 C 12988 C 1. The call sequence to Subroutine DLSOIBT, which is a driver 12989 C routine for the solver. This includes descriptions of both 12990 C the call sequence arguments and of user-supplied routines. 12991 C Following these descriptions is a description of 12992 C optional inputs available through the call sequence, and then 12993 C a description of optional outputs (in the work arrays). 12994 C 12995 C 2. Descriptions of other routines in the DLSOIBT package that may be 12996 C (optionally) called by the user. These provide the ability to 12997 C alter error message handling, save and restore the internal 12998 C Common, and obtain specified derivatives of the solution y(t). 12999 C 13000 C 3. Descriptions of Common blocks to be declared in overlay 13001 C or similar environments, or to be saved when doing an interrupt 13002 C of the problem and continued solution later. 13003 C 13004 C 4. Description of two routines in the DLSOIBT package, either of 13005 C which the user may replace with his/her own version, if desired. 13006 C These relate to the measurement of errors. 13007 C 13008 C----------------------------------------------------------------------- 13009 C Part 1. Call Sequence. 13010 C 13011 C The call sequence parameters used for input only are 13012 C RES, ADDA, JAC, NEQ, TOUT, ITOL, RTOL, ATOL, ITASK, 13013 C IOPT, LRW, LIW, MF, 13014 C and those used for both input and output are 13015 C Y, T, ISTATE, YDOTI. 13016 C The work arrays RWORK and IWORK are also used for additional and 13017 C optional inputs and optional outputs. (The term output here refers 13018 C to the return from Subroutine DLSOIBT to the user's calling program.) 13019 C 13020 C The legality of input parameters will be thoroughly checked on the 13021 C initial call for the problem, but not checked thereafter unless a 13022 C change in input parameters is flagged by ISTATE = 3 on input. 13023 C 13024 C The descriptions of the call arguments are as follows. 13025 C 13026 C RES = the name of the user-supplied subroutine which supplies 13027 C the residual vector for the ODE system, defined by 13028 C r = g(t,y) - A(t,y) * s 13029 C as a function of the scalar t and the vectors 13030 C s and y (s approximates dy/dt). This subroutine 13031 C is to have the form 13032 C SUBROUTINE RES (NEQ, T, Y, S, R, IRES) 13033 C DOUBLE PRECISION T, Y(*), S(*), R(*) 13034 C where NEQ, T, Y, S, and IRES are input, and R and 13035 C IRES are output. Y, S, and R are arrays of length NEQ. 13036 C On input, IRES indicates how DLSOIBT will use the 13037 C returned array R, as follows: 13038 C IRES = 1 means that DLSOIBT needs the full residual, 13039 C r = g - A*s, exactly. 13040 C IRES = -1 means that DLSOIBT is using R only to compute 13041 C the Jacobian dr/dy by difference quotients. 13042 C The RES routine can ignore IRES, or it can omit some terms 13043 C if IRES = -1. If A does not depend on y, then RES can 13044 C just return R = g when IRES = -1. If g - A*s contains other 13045 C additive terms that are independent of y, these can also be 13046 C dropped, if done consistently, when IRES = -1. 13047 C The subroutine should set the flag IRES if it 13048 C encounters a halt condition or illegal input. 13049 C Otherwise, it should not reset IRES. On output, 13050 C IRES = 1 or -1 represents a normal return, and 13051 C DLSOIBT continues integrating the ODE. Leave IRES 13052 C unchanged from its input value. 13053 C IRES = 2 tells DLSOIBT to immediately return control 13054 C to the calling program, with ISTATE = 3. This lets 13055 C the calling program change parameters of the problem 13056 C if necessary. 13057 C IRES = 3 represents an error condition (for example, an 13058 C illegal value of y). DLSOIBT tries to integrate the system 13059 C without getting IRES = 3 from RES. If it cannot, DLSOIBT 13060 C returns with ISTATE = -7 or -1. 13061 C On an DLSOIBT return with ISTATE = 3, -1, or -7, the 13062 C values of T and Y returned correspond to the last point 13063 C reached successfully without getting the flag IRES = 2 or 3. 13064 C The flag values IRES = 2 and 3 should not be used to 13065 C handle switches or root-stop conditions. This is better 13066 C done by calling DLSOIBT in a one-step mode and checking the 13067 C stopping function for a sign change at each step. 13068 C If quantities computed in the RES routine are needed 13069 C externally to DLSOIBT, an extra call to RES should be made 13070 C for this purpose, for consistent and accurate results. 13071 C To get the current dy/dt for the S argument, use DINTDY. 13072 C RES must be declared External in the calling 13073 C program. See note below for more about RES. 13074 C 13075 C ADDA = the name of the user-supplied subroutine which adds the 13076 C matrix A = A(t,y) to another matrix, P, stored in 13077 C block-tridiagonal form. This routine is to have the form 13078 C SUBROUTINE ADDA (NEQ, T, Y, MB, NB, PA, PB, PC) 13079 C DOUBLE PRECISION T, Y(*), PA(MB,MB,NB), PB(MB,MB,NB), 13080 C 1 PC(MB,MB,NB) 13081 C where NEQ, T, Y, MB, NB, and the arrays PA, PB, and PC 13082 C are input, and the arrays PA, PB, and PC are output. 13083 C Y is an array of length NEQ, and the arrays PA, PB, PC 13084 C are all MB by MB by NB. 13085 C Here a block-tridiagonal structure is assumed for A(t,y), 13086 C and also for the matrix P to which A is added here, 13087 C as described in Paragraph B of the Summary of Usage above. 13088 C Thus the affect of ADDA should be the following: 13089 C DO 30 K = 1,NB 13090 C DO 20 J = 1,MB 13091 C DO 10 I = 1,MB 13092 C PA(I,J,K) = PA(I,J,K) + 13093 C ( (I,J) element of K-th diagonal block of A) 13094 C PB(I,J,K) = PB(I,J,K) + 13095 C ( (I,J) element of block (K,K+1) of A, 13096 C or block (NB,NB-2) if K = NB) 13097 C PC(I,J,K) = PC(I,J,K) + 13098 C ( (I,J) element of block (K,K-1) of A, 13099 C or block (1,3) if K = 1) 13100 C 10 CONTINUE 13101 C 20 CONTINUE 13102 C 30 CONTINUE 13103 C ADDA must be declared External in the calling program. 13104 C See note below for more information about ADDA. 13105 C 13106 C JAC = the name of the user-supplied subroutine which supplies 13107 C the Jacobian matrix, dr/dy, where r = g - A*s. JAC is 13108 C required if MITER = 1. Otherwise a dummy name can be 13109 C passed. This subroutine is to have the form 13110 C SUBROUTINE JAC (NEQ, T, Y, S, MB, NB, PA, PB, PC) 13111 C DOUBLE PRECISION T, Y(*), S(*), PA(MB,MB,NB), 13112 C 1 PB(MB,MB,NB), PC(MB,MB,NB) 13113 C where NEQ, T, Y, S, MB, NB, and the arrays PA, PB, and PC 13114 C are input, and the arrays PA, PB, and PC are output. 13115 C Y and S are arrays of length NEQ, and the arrays PA, PB, PC 13116 C are all MB by MB by NB. 13117 C PA, PB, and PC are to be loaded with partial derivatives 13118 C (elements of the Jacobian matrix) on output, in terms of the 13119 C block-tridiagonal structure assumed, as described 13120 C in Paragraph B of the Summary of Usage above. 13121 C That is, load the diagonal blocks into PA, the 13122 C superdiagonal blocks (and block (NB,NB-2) ) into PB, and 13123 C the subdiagonal blocks (and block (1,3) ) into PC. 13124 C The blocks in block-row k of dr/dy are to be loaded into 13125 C PA(*,*,k), PB(*,*,k), and PC(*,*,k). 13126 C Thus the affect of JAC should be the following: 13127 C DO 30 K = 1,NB 13128 C DO 20 J = 1,MB 13129 C DO 10 I = 1,MB 13130 C PA(I,J,K) = ( (I,J) element of 13131 C K-th diagonal block of dr/dy) 13132 C PB(I,J,K) = ( (I,J) element of block (K,K+1) 13133 C of dr/dy, or block (NB,NB-2) if K = NB) 13134 C PC(I,J,K) = ( (I,J) element of block (K,K-1) 13135 C of dr/dy, or block (1,3) if K = 1) 13136 C 10 CONTINUE 13137 C 20 CONTINUE 13138 C 30 CONTINUE 13139 C PA, PB, and PC are preset to zero by the solver, 13140 C so that only the nonzero elements need be loaded by JAC. 13141 C Each call to JAC is preceded by a call to RES with the same 13142 C arguments NEQ, T, Y, and S. Thus to gain some efficiency, 13143 C intermediate quantities shared by both calculations may be 13144 C saved in a user Common block by RES and not recomputed by JAC 13145 C if desired. Also, JAC may alter the Y array, if desired. 13146 C JAC need not provide dr/dy exactly. A crude 13147 C approximation will do, so that DLSOIBT may be used when 13148 C A and dr/dy are not really block-tridiagonal, but are close 13149 C to matrices that are. 13150 C JAC must be declared External in the calling program. 13151 C See note below for more about JAC. 13152 C 13153 C Note on RES, ADDA, and JAC: 13154 C These subroutines may access user-defined quantities in 13155 C NEQ(2),... and/or in Y(NEQ(1)+1),... if NEQ is an array 13156 C (dimensioned in the subroutines) and/or Y has length 13157 C exceeding NEQ(1). However, these routines should not alter 13158 C NEQ(1), Y(1),...,Y(NEQ) or any other input variables. 13159 C See the descriptions of NEQ and Y below. 13160 C 13161 C NEQ = the size of the system (number of first order ordinary 13162 C differential equations or scalar algebraic equations). 13163 C Used only for input. 13164 C NEQ may be decreased, but not increased, during the problem. 13165 C If NEQ is decreased (with ISTATE = 3 on input), the 13166 C remaining components of Y should be left undisturbed, if 13167 C these are to be accessed in RES, ADDA, or JAC. 13168 C 13169 C Normally, NEQ is a scalar, and it is generally referred to 13170 C as a scalar in this user interface description. However, 13171 C NEQ may be an array, with NEQ(1) set to the system size. 13172 C (The DLSOIBT package accesses only NEQ(1).) In either case, 13173 C this parameter is passed as the NEQ argument in all calls 13174 C to RES, ADDA, and JAC. Hence, if it is an array, 13175 C locations NEQ(2),... may be used to store other integer data 13176 C and pass it to RES, ADDA, or JAC. Each such subroutine 13177 C must include NEQ in a Dimension statement in that case. 13178 C 13179 C Y = a real array for the vector of dependent variables, of 13180 C length NEQ or more. Used for both input and output on the 13181 C first call (ISTATE = 0 or 1), and only for output on other 13182 C calls. On the first call, Y must contain the vector of 13183 C initial values. On output, Y contains the computed solution 13184 C vector, evaluated at t. If desired, the Y array may be used 13185 C for other purposes between calls to the solver. 13186 C 13187 C This array is passed as the Y argument in all calls to RES, 13188 C ADDA, and JAC. Hence its length may exceed NEQ, 13189 C and locations Y(NEQ+1),... may be used to store other real 13190 C data and pass it to RES, ADDA, or JAC. (The DLSOIBT 13191 C package accesses only Y(1),...,Y(NEQ). ) 13192 C 13193 C YDOTI = a real array for the initial value of the vector 13194 C dy/dt and for work space, of dimension at least NEQ. 13195 C 13196 C On input: 13197 C If ISTATE = 0 then DLSOIBT will compute the initial value 13198 C of dy/dt, if A is nonsingular. Thus YDOTI will 13199 C serve only as work space and may have any value. 13200 C If ISTATE = 1 then YDOTI must contain the initial value 13201 C of dy/dt. 13202 C If ISTATE = 2 or 3 (continuation calls) then YDOTI 13203 C may have any value. 13204 C Note: If the initial value of A is singular, then 13205 C DLSOIBT cannot compute the initial value of dy/dt, so 13206 C it must be provided in YDOTI, with ISTATE = 1. 13207 C 13208 C On output, when DLSOIBT terminates abnormally with ISTATE = 13209 C -1, -4, or -5, YDOTI will contain the residual 13210 C r = g(t,y) - A(t,y)*(dy/dt). If r is large, t is near 13211 C its initial value, and YDOTI is supplied with ISTATE = 1, 13212 C there may have been an incorrect input value of 13213 C YDOTI = dy/dt, or the problem (as given to DLSOIBT) 13214 C may not have a solution. 13215 C 13216 C If desired, the YDOTI array may be used for other 13217 C purposes between calls to the solver. 13218 C 13219 C T = the independent variable. On input, T is used only on the 13220 C first call, as the initial point of the integration. 13221 C On output, after each call, T is the value at which a 13222 C computed solution y is evaluated (usually the same as TOUT). 13223 C On an error return, T is the farthest point reached. 13224 C 13225 C TOUT = the next value of t at which a computed solution is desired. 13226 C Used only for input. 13227 C 13228 C When starting the problem (ISTATE = 0 or 1), TOUT may be 13229 C equal to T for one call, then should .ne. T for the next 13230 C call. For the initial T, an input value of TOUT .ne. T is 13231 C used in order to determine the direction of the integration 13232 C (i.e. the algebraic sign of the step sizes) and the rough 13233 C scale of the problem. Integration in either direction 13234 C (forward or backward in t) is permitted. 13235 C 13236 C If ITASK = 2 or 5 (one-step modes), TOUT is ignored after 13237 C the first call (i.e. the first call with TOUT .ne. T). 13238 C Otherwise, TOUT is required on every call. 13239 C 13240 C If ITASK = 1, 3, or 4, the values of TOUT need not be 13241 C monotone, but a value of TOUT which backs up is limited 13242 C to the current internal T interval, whose endpoints are 13243 C TCUR - HU and TCUR (see optional outputs, below, for 13244 C TCUR and HU). 13245 C 13246 C ITOL = an indicator for the type of error control. See 13247 C description below under ATOL. Used only for input. 13248 C 13249 C RTOL = a relative error tolerance parameter, either a scalar or 13250 C an array of length NEQ. See description below under ATOL. 13251 C Input only. 13252 C 13253 C ATOL = an absolute error tolerance parameter, either a scalar or 13254 C an array of length NEQ. Input only. 13255 C 13256 C The input parameters ITOL, RTOL, and ATOL determine 13257 C the error control performed by the solver. The solver will 13258 C control the vector E = (E(i)) of estimated local errors 13259 C in y, according to an inequality of the form 13260 C RMS-norm of ( E(i)/EWT(i) ) .le. 1, 13261 C where EWT(i) = RTOL(i)*ABS(Y(i)) + ATOL(i), 13262 C and the RMS-norm (root-mean-square norm) here is 13263 C RMS-norm(v) = SQRT(sum v(i)**2 / NEQ). Here EWT = (EWT(i)) 13264 C is a vector of weights which must always be positive, and 13265 C the values of RTOL and ATOL should all be non-negative. 13266 C The following table gives the types (scalar/array) of 13267 C RTOL and ATOL, and the corresponding form of EWT(i). 13268 C 13269 C ITOL RTOL ATOL EWT(i) 13270 C 1 scalar scalar RTOL*ABS(Y(i)) + ATOL 13271 C 2 scalar array RTOL*ABS(Y(i)) + ATOL(i) 13272 C 3 array scalar RTOL(i)*ABS(Y(i)) + ATOL 13273 C 4 array scalar RTOL(i)*ABS(Y(i)) + ATOL(i) 13274 C 13275 C When either of these parameters is a scalar, it need not 13276 C be dimensioned in the user's calling program. 13277 C 13278 C If none of the above choices (with ITOL, RTOL, and ATOL 13279 C fixed throughout the problem) is suitable, more general 13280 C error controls can be obtained by substituting 13281 C user-supplied routines for the setting of EWT and/or for 13282 C the norm calculation. See Part 4 below. 13283 C 13284 C If global errors are to be estimated by making a repeated 13285 C run on the same problem with smaller tolerances, then all 13286 C components of RTOL and ATOL (i.e. of EWT) should be scaled 13287 C down uniformly. 13288 C 13289 C ITASK = an index specifying the task to be performed. 13290 C Input only. ITASK has the following values and meanings. 13291 C 1 means normal computation of output values of y(t) at 13292 C t = TOUT (by overshooting and interpolating). 13293 C 2 means take one step only and return. 13294 C 3 means stop at the first internal mesh point at or 13295 C beyond t = TOUT and return. 13296 C 4 means normal computation of output values of y(t) at 13297 C t = TOUT but without overshooting t = TCRIT. 13298 C TCRIT must be input as RWORK(1). TCRIT may be equal to 13299 C or beyond TOUT, but not behind it in the direction of 13300 C integration. This option is useful if the problem 13301 C has a singularity at or beyond t = TCRIT. 13302 C 5 means take one step, without passing TCRIT, and return. 13303 C TCRIT must be input as RWORK(1). 13304 C 13305 C Note: If ITASK = 4 or 5 and the solver reaches TCRIT 13306 C (within roundoff), it will return T = TCRIT (exactly) to 13307 C indicate this (unless ITASK = 4 and TOUT comes before TCRIT, 13308 C in which case answers at t = TOUT are returned first). 13309 C 13310 C ISTATE = an index used for input and output to specify the 13311 C state of the calculation. 13312 C 13313 C On input, the values of ISTATE are as follows. 13314 C 0 means this is the first call for the problem, and 13315 C DLSOIBT is to compute the initial value of dy/dt 13316 C (while doing other initializations). See note below. 13317 C 1 means this is the first call for the problem, and 13318 C the initial value of dy/dt has been supplied in 13319 C YDOTI (DLSOIBT will do other initializations). 13320 C See note below. 13321 C 2 means this is not the first call, and the calculation 13322 C is to continue normally, with no change in any input 13323 C parameters except possibly TOUT and ITASK. 13324 C (If ITOL, RTOL, and/or ATOL are changed between calls 13325 C with ISTATE = 2, the new values will be used but not 13326 C tested for legality.) 13327 C 3 means this is not the first call, and the 13328 C calculation is to continue normally, but with 13329 C a change in input parameters other than 13330 C TOUT and ITASK. Changes are allowed in 13331 C NEQ, ITOL, RTOL, ATOL, IOPT, LRW, LIW, MF, MB, NB, 13332 C and any of the optional inputs except H0. 13333 C (See IWORK description for MB and NB.) 13334 C Note: A preliminary call with TOUT = T is not counted 13335 C as a first call here, as no initialization or checking of 13336 C input is done. (Such a call is sometimes useful for the 13337 C purpose of outputting the initial conditions.) 13338 C Thus the first call for which TOUT .ne. T requires 13339 C ISTATE = 0 or 1 on input. 13340 C 13341 C On output, ISTATE has the following values and meanings. 13342 C 0 or 1 means nothing was done; TOUT = t and 13343 C ISTATE = 0 or 1 on input. 13344 C 2 means that the integration was performed successfully. 13345 C 3 means that the user-supplied Subroutine RES signalled 13346 C DLSOIBT to halt the integration and return (IRES = 2). 13347 C Integration as far as T was achieved with no occurrence 13348 C of IRES = 2, but this flag was set on attempting the 13349 C next step. 13350 C -1 means an excessive amount of work (more than MXSTEP 13351 C steps) was done on this call, before completing the 13352 C requested task, but the integration was otherwise 13353 C successful as far as T. (MXSTEP is an optional input 13354 C and is normally 500.) To continue, the user may 13355 C simply reset ISTATE to a value .gt. 1 and call again 13356 C (the excess work step counter will be reset to 0). 13357 C In addition, the user may increase MXSTEP to avoid 13358 C this error return (see below on optional inputs). 13359 C -2 means too much accuracy was requested for the precision 13360 C of the machine being used. This was detected before 13361 C completing the requested task, but the integration 13362 C was successful as far as T. To continue, the tolerance 13363 C parameters must be reset, and ISTATE must be set 13364 C to 3. The optional output TOLSF may be used for this 13365 C purpose. (Note: If this condition is detected before 13366 C taking any steps, then an illegal input return 13367 C (ISTATE = -3) occurs instead.) 13368 C -3 means illegal input was detected, before taking any 13369 C integration steps. See written message for details. 13370 C Note: If the solver detects an infinite loop of calls 13371 C to the solver with illegal input, it will cause 13372 C the run to stop. 13373 C -4 means there were repeated error test failures on 13374 C one attempted step, before completing the requested 13375 C task, but the integration was successful as far as T. 13376 C The problem may have a singularity, or the input 13377 C may be inappropriate. 13378 C -5 means there were repeated convergence test failures on 13379 C one attempted step, before completing the requested 13380 C task, but the integration was successful as far as T. 13381 C This may be caused by an inaccurate Jacobian matrix. 13382 C -6 means EWT(i) became zero for some i during the 13383 C integration. Pure relative error control (ATOL(i) = 0.0) 13384 C was requested on a variable which has now vanished. 13385 C The integration was successful as far as T. 13386 C -7 means that the user-supplied Subroutine RES set 13387 C its error flag (IRES = 3) despite repeated tries by 13388 C DLSOIBT to avoid that condition. 13389 C -8 means that ISTATE was 0 on input but DLSOIBT was unable 13390 C to compute the initial value of dy/dt. See the 13391 C printed message for details. 13392 C 13393 C Note: Since the normal output value of ISTATE is 2, 13394 C it does not need to be reset for normal continuation. 13395 C Similarly, ISTATE (= 3) need not be reset if RES told 13396 C DLSOIBT to return because the calling program must change 13397 C the parameters of the problem. 13398 C Also, since a negative input value of ISTATE will be 13399 C regarded as illegal, a negative output value requires the 13400 C user to change it, and possibly other inputs, before 13401 C calling the solver again. 13402 C 13403 C IOPT = an integer flag to specify whether or not any optional 13404 C inputs are being used on this call. Input only. 13405 C The optional inputs are listed separately below. 13406 C IOPT = 0 means no optional inputs are being used. 13407 C Default values will be used in all cases. 13408 C IOPT = 1 means one or more optional inputs are being used. 13409 C 13410 C RWORK = a real working array (double precision). 13411 C The length of RWORK must be at least 13412 C 20 + NYH*(MAXORD + 1) + 3*NEQ + LENWM where 13413 C NYH = the initial value of NEQ, 13414 C MAXORD = 12 (if METH = 1) or 5 (if METH = 2) (unless a 13415 C smaller value is given as an optional input), 13416 C LENWM = 3*MB*MB*NB + 2. 13417 C (See MF description for the definition of METH.) 13418 C Thus if MAXORD has its default value and NEQ is constant, 13419 C this length is 13420 C 22 + 16*NEQ + 3*MB*MB*NB for MF = 11 or 12, 13421 C 22 + 9*NEQ + 3*MB*MB*NB for MF = 21 or 22. 13422 C The first 20 words of RWORK are reserved for conditional 13423 C and optional inputs and optional outputs. 13424 C 13425 C The following word in RWORK is a conditional input: 13426 C RWORK(1) = TCRIT = critical value of t which the solver 13427 C is not to overshoot. Required if ITASK is 13428 C 4 or 5, and ignored otherwise. (See ITASK.) 13429 C 13430 C LRW = the length of the array RWORK, as declared by the user. 13431 C (This will be checked by the solver.) 13432 C 13433 C IWORK = an integer work array. The length of IWORK must be at least 13434 C 20 + NEQ . The first few words of IWORK are used for 13435 C additional and optional inputs and optional outputs. 13436 C 13437 C The following 2 words in IWORK are additional required 13438 C inputs to DLSOIBT: 13439 C IWORK(1) = MB = block size 13440 C IWORK(2) = NB = number of blocks in the main diagonal 13441 C These must satisfy MB .ge. 1, NB .ge. 4, and MB*NB = NEQ. 13442 C 13443 C LIW = the length of the array IWORK, as declared by the user. 13444 C (This will be checked by the solver.) 13445 C 13446 C Note: The work arrays must not be altered between calls to DLSOIBT 13447 C for the same problem, except possibly for the additional and 13448 C optional inputs, and except for the last 3*NEQ words of RWORK. 13449 C The latter space is used for internal scratch space, and so is 13450 C available for use by the user outside DLSOIBT between calls, if 13451 C desired (but not for use by RES, ADDA, or JAC). 13452 C 13453 C MF = the method flag. used only for input. The legal values of 13454 C MF are 11, 12, 21, and 22. 13455 C MF has decimal digits METH and MITER: MF = 10*METH + MITER. 13456 C METH indicates the basic linear multistep method: 13457 C METH = 1 means the implicit Adams method. 13458 C METH = 2 means the method based on Backward 13459 C Differentiation Formulas (BDFS). 13460 C The BDF method is strongly preferred for stiff 13461 C problems, while the Adams method is preferred when the 13462 C problem is not stiff. If the matrix A(t,y) is 13463 C nonsingular, stiffness here can be taken to mean that of 13464 C the explicit ODE system dy/dt = A-inverse * g. If A is 13465 C singular, the concept of stiffness is not well defined. 13466 C If you do not know whether the problem is stiff, we 13467 C recommend using METH = 2. If it is stiff, the advantage 13468 C of METH = 2 over METH = 1 will be great, while if it is 13469 C not stiff, the advantage of METH = 1 will be slight. 13470 C If maximum efficiency is important, some experimentation 13471 C with METH may be necessary. 13472 C MITER indicates the corrector iteration method: 13473 C MITER = 1 means chord iteration with a user-supplied 13474 C block-tridiagonal Jacobian. 13475 C MITER = 2 means chord iteration with an internally 13476 C generated (difference quotient) block- 13477 C tridiagonal Jacobian approximation, using 13478 C 3*MB+1 extra calls to RES per dr/dy evaluation. 13479 C If MITER = 1, the user must supply a Subroutine JAC 13480 C (the name is arbitrary) as described above under JAC. 13481 C For MITER = 2, a dummy argument can be used. 13482 C----------------------------------------------------------------------- 13483 C Optional Inputs. 13484 C 13485 C The following is a list of the optional inputs provided for in the 13486 C call sequence. (See also Part 2.) For each such input variable, 13487 C this table lists its name as used in this documentation, its 13488 C location in the call sequence, its meaning, and the default value. 13489 C The use of any of these inputs requires IOPT = 1, and in that 13490 C case all of these inputs are examined. A value of zero for any 13491 C of these optional inputs will cause the default value to be used. 13492 C Thus to use a subset of the optional inputs, simply preload 13493 C locations 5 to 10 in RWORK and IWORK to 0.0 and 0 respectively, and 13494 C then set those of interest to nonzero values. 13495 C 13496 C Name Location Meaning and Default Value 13497 C 13498 C H0 RWORK(5) the step size to be attempted on the first step. 13499 C The default value is determined by the solver. 13500 C 13501 C HMAX RWORK(6) the maximum absolute step size allowed. 13502 C The default value is infinite. 13503 C 13504 C HMIN RWORK(7) the minimum absolute step size allowed. 13505 C The default value is 0. (This lower bound is not 13506 C enforced on the final step before reaching TCRIT 13507 C when ITASK = 4 or 5.) 13508 C 13509 C MAXORD IWORK(5) the maximum order to be allowed. The default 13510 C value is 12 if METH = 1, and 5 if METH = 2. 13511 C If MAXORD exceeds the default value, it will 13512 C be reduced to the default value. 13513 C If MAXORD is changed during the problem, it may 13514 C cause the current order to be reduced. 13515 C 13516 C MXSTEP IWORK(6) maximum number of (internally defined) steps 13517 C allowed during one call to the solver. 13518 C The default value is 500. 13519 C 13520 C MXHNIL IWORK(7) maximum number of messages printed (per problem) 13521 C warning that T + H = T on a step (H = step size). 13522 C This must be positive to result in a non-default 13523 C value. The default value is 10. 13524 C----------------------------------------------------------------------- 13525 C Optional Outputs. 13526 C 13527 C As optional additional output from DLSOIBT, the variables listed 13528 C below are quantities related to the performance of DLSOIBT 13529 C which are available to the user. These are communicated by way of 13530 C the work arrays, but also have internal mnemonic names as shown. 13531 C Except where stated otherwise, all of these outputs are defined 13532 C on any successful return from DLSOIBT, and on any return with 13533 C ISTATE = -1, -2, -4, -5, -6, or -7. On a return with -3 (illegal 13534 C input) or -8, they will be unchanged from their existing values 13535 C (if any), except possibly for TOLSF, LENRW, and LENIW. 13536 C On any error return, outputs relevant to the error will be defined, 13537 C as noted below. 13538 C 13539 C Name Location Meaning 13540 C 13541 C HU RWORK(11) the step size in t last used (successfully). 13542 C 13543 C HCUR RWORK(12) the step size to be attempted on the next step. 13544 C 13545 C TCUR RWORK(13) the current value of the independent variable 13546 C which the solver has actually reached, i.e. the 13547 C current internal mesh point in t. On output, TCUR 13548 C will always be at least as far as the argument 13549 C T, but may be farther (if interpolation was done). 13550 C 13551 C TOLSF RWORK(14) a tolerance scale factor, greater than 1.0, 13552 C computed when a request for too much accuracy was 13553 C detected (ISTATE = -3 if detected at the start of 13554 C the problem, ISTATE = -2 otherwise). If ITOL is 13555 C left unaltered but RTOL and ATOL are uniformly 13556 C scaled up by a factor of TOLSF for the next call, 13557 C then the solver is deemed likely to succeed. 13558 C (The user may also ignore TOLSF and alter the 13559 C tolerance parameters in any other way appropriate.) 13560 C 13561 C NST IWORK(11) the number of steps taken for the problem so far. 13562 C 13563 C NRE IWORK(12) the number of residual evaluations (RES calls) 13564 C for the problem so far. 13565 C 13566 C NJE IWORK(13) the number of Jacobian evaluations (each involving 13567 C an evaluation of a and dr/dy) for the problem so 13568 C far. This equals the number of calls to ADDA and 13569 C (if MITER = 1) to JAC, and the number of matrix 13570 C LU decompositions. 13571 C 13572 C NQU IWORK(14) the method order last used (successfully). 13573 C 13574 C NQCUR IWORK(15) the order to be attempted on the next step. 13575 C 13576 C IMXER IWORK(16) the index of the component of largest magnitude in 13577 C the weighted local error vector ( E(i)/EWT(i) ), 13578 C on an error return with ISTATE = -4 or -5. 13579 C 13580 C LENRW IWORK(17) the length of RWORK actually required. 13581 C This is defined on normal returns and on an illegal 13582 C input return for insufficient storage. 13583 C 13584 C LENIW IWORK(18) the length of IWORK actually required. 13585 C This is defined on normal returns and on an illegal 13586 C input return for insufficient storage. 13587 C 13588 C 13589 C The following two arrays are segments of the RWORK array which 13590 C may also be of interest to the user as optional outputs. 13591 C For each array, the table below gives its internal name, 13592 C its base address in RWORK, and its description. 13593 C 13594 C Name Base Address Description 13595 C 13596 C YH 21 the Nordsieck history array, of size NYH by 13597 C (NQCUR + 1), where NYH is the initial value 13598 C of NEQ. For j = 0,1,...,NQCUR, column j+1 13599 C of YH contains HCUR**j/factorial(j) times 13600 C the j-th derivative of the interpolating 13601 C polynomial currently representing the solution, 13602 C evaluated at t = TCUR. 13603 C 13604 C ACOR LENRW-NEQ+1 array of size NEQ used for the accumulated 13605 C corrections on each step, scaled on output to 13606 C represent the estimated local error in y on 13607 C the last step. This is the vector E in the 13608 C description of the error control. It is 13609 C defined only on a return from DLSOIBT with 13610 C ISTATE = 2. 13611 C 13612 C----------------------------------------------------------------------- 13613 C Part 2. Other Routines Callable. 13614 C 13615 C The following are optional calls which the user may make to 13616 C gain additional capabilities in conjunction with DLSOIBT. 13617 C (The routines XSETUN and XSETF are designed to conform to the 13618 C SLATEC error handling package.) 13619 C 13620 C Form of Call Function 13621 C CALL XSETUN(LUN) Set the logical unit number, LUN, for 13622 C output of messages from DLSOIBT, if 13623 C the default is not desired. 13624 C The default value of LUN is 6. 13625 C 13626 C CALL XSETF(MFLAG) Set a flag to control the printing of 13627 C messages by DLSOIBT. 13628 C MFLAG = 0 means do not print. (Danger: 13629 C This risks losing valuable information.) 13630 C MFLAG = 1 means print (the default). 13631 C 13632 C Either of the above calls may be made at 13633 C any time and will take effect immediately. 13634 C 13635 C CALL DSRCOM(RSAV,ISAV,JOB) saves and restores the contents of 13636 C the internal Common blocks used by 13637 C DLSOIBT (see Part 3 below). 13638 C RSAV must be a real array of length 218 13639 C or more, and ISAV must be an integer 13640 C array of length 37 or more. 13641 C JOB=1 means save Common into RSAV/ISAV. 13642 C JOB=2 means restore Common from RSAV/ISAV. 13643 C DSRCOM is useful if one is 13644 C interrupting a run and restarting 13645 C later, or alternating between two or 13646 C more problems solved with DLSOIBT. 13647 C 13648 C CALL DINTDY(,,,,,) Provide derivatives of y, of various 13649 C (see below) orders, at a specified point t, if 13650 C desired. It may be called only after 13651 C a successful return from DLSOIBT. 13652 C 13653 C The detailed instructions for using DINTDY are as follows. 13654 C The form of the call is: 13655 C 13656 C CALL DINTDY (T, K, RWORK(21), NYH, DKY, IFLAG) 13657 C 13658 C The input parameters are: 13659 C 13660 C T = value of independent variable where answers are desired 13661 C (normally the same as the t last returned by DLSOIBT). 13662 C For valid results, T must lie between TCUR - HU and TCUR. 13663 C (See optional outputs for TCUR and HU.) 13664 C K = integer order of the derivative desired. K must satisfy 13665 C 0 .le. K .le. NQCUR, where NQCUR is the current order 13666 C (see optional outputs). The capability corresponding 13667 C to K = 0, i.e. computing y(t), is already provided 13668 C by DLSOIBT directly. Since NQCUR .ge. 1, the first 13669 C derivative dy/dt is always available with DINTDY. 13670 C RWORK(21) = the base address of the history array YH. 13671 C NYH = column length of YH, equal to the initial value of NEQ. 13672 C 13673 C The output parameters are: 13674 C 13675 C DKY = a real array of length NEQ containing the computed value 13676 C of the K-th derivative of y(t). 13677 C IFLAG = integer flag, returned as 0 if K and T were legal, 13678 C -1 if K was illegal, and -2 if T was illegal. 13679 C On an error return, a message is also written. 13680 C----------------------------------------------------------------------- 13681 C Part 3. Common Blocks. 13682 C 13683 C If DLSOIBT is to be used in an overlay situation, the user 13684 C must declare, in the primary overlay, the variables in: 13685 C (1) the call sequence to DLSOIBT, and 13686 C (2) the internal Common block 13687 C /DLS001/ of length 255 (218 double precision words 13688 C followed by 37 integer words), 13689 C 13690 C If DLSOIBT is used on a system in which the contents of internal 13691 C Common blocks are not preserved between calls, the user should 13692 C declare the above Common block in the calling program to insure 13693 C that their contents are preserved. 13694 C 13695 C If the solution of a given problem by DLSOIBT is to be interrupted 13696 C and then later continued, such as when restarting an interrupted run 13697 C or alternating between two or more problems, the user should save, 13698 C following the return from the last DLSOIBT call prior to the 13699 C interruption, the contents of the call sequence variables and the 13700 C internal Common blocks, and later restore these values before the 13701 C next DLSOIBT call for that problem. To save and restore the Common 13702 C blocks, use Subroutine DSRCOM (see Part 2 above). 13703 C 13704 C----------------------------------------------------------------------- 13705 C Part 4. Optionally Replaceable Solver Routines. 13706 C 13707 C Below are descriptions of two routines in the DLSOIBT package which 13708 C relate to the measurement of errors. Either routine can be 13709 C replaced by a user-supplied version, if desired. However, since such 13710 C a replacement may have a major impact on performance, it should be 13711 C done only when absolutely necessary, and only with great caution. 13712 C (Note: The means by which the package version of a routine is 13713 C superseded by the user's version may be system-dependent.) 13714 C 13715 C (a) DEWSET. 13716 C The following subroutine is called just before each internal 13717 C integration step, and sets the array of error weights, EWT, as 13718 C described under ITOL/RTOL/ATOL above: 13719 C SUBROUTINE DEWSET (NEQ, ITOL, RTOL, ATOL, YCUR, EWT) 13720 C where NEQ, ITOL, RTOL, and ATOL are as in the DLSOIBT call sequence, 13721 C YCUR contains the current dependent variable vector, and 13722 C EWT is the array of weights set by DEWSET. 13723 C 13724 C If the user supplies this subroutine, it must return in EWT(i) 13725 C (i = 1,...,NEQ) a positive quantity suitable for comparing errors 13726 C in y(i) to. The EWT array returned by DEWSET is passed to the DVNORM 13727 C routine (see below), and also used by DLSOIBT in the computation 13728 C of the optional output IMXER, the diagonal Jacobian approximation, 13729 C and the increments for difference quotient Jacobians. 13730 C 13731 C In the user-supplied version of DEWSET, it may be desirable to use 13732 C the current values of derivatives of y. Derivatives up to order NQ 13733 C are available from the history array YH, described above under 13734 C optional outputs. In DEWSET, YH is identical to the YCUR array, 13735 C extended to NQ + 1 columns with a column length of NYH and scale 13736 C factors of H**j/factorial(j). On the first call for the problem, 13737 C given by NST = 0, NQ is 1 and H is temporarily set to 1.0. 13738 C NYH is the initial value of NEQ. The quantities NQ, H, and NST 13739 C can be obtained by including in DEWSET the statements: 13740 C DOUBLE PRECISION RLS 13741 C COMMON /DLS001/ RLS(218),ILS(37) 13742 C NQ = ILS(33) 13743 C NST = ILS(34) 13744 C H = RLS(212) 13745 C Thus, for example, the current value of dy/dt can be obtained as 13746 C YCUR(NYH+i)/H (i=1,...,NEQ) (and the division by H is 13747 C unnecessary when NST = 0). 13748 C 13749 C (b) DVNORM. 13750 C The following is a real function routine which computes the weighted 13751 C root-mean-square norm of a vector v: 13752 C D = DVNORM (N, V, W) 13753 C where: 13754 C N = the length of the vector, 13755 C V = real array of length N containing the vector, 13756 C W = real array of length N containing weights, 13757 C D = SQRT( (1/N) * sum(V(i)*W(i))**2 ). 13758 C DVNORM is called with N = NEQ and with W(i) = 1.0/EWT(i), where 13759 C EWT is as set by Subroutine DEWSET. 13760 C 13761 C If the user supplies this function, it should return a non-negative 13762 C value of DVNORM suitable for use in the error control in DLSOIBT. 13763 C None of the arguments should be altered by DVNORM. 13764 C For example, a user-supplied DVNORM routine might: 13765 C -substitute a max-norm of (V(i)*W(i)) for the RMS-norm, or 13766 C -ignore some components of V in the norm, with the effect of 13767 C suppressing the error control on those components of y. 13768 C----------------------------------------------------------------------- 13769 C 13770 C***REVISION HISTORY (YYYYMMDD) 13771 C 19840625 DATE WRITTEN 13772 C 19870330 Major update: corrected comments throughout; 13773 C removed TRET from Common; rewrote EWSET with 4 loops; 13774 C fixed t test in INTDY; added Cray directives in STODI; 13775 C in STODI, fixed DELP init. and logic around PJAC call; 13776 C combined routines to save/restore Common; 13777 C passed LEVEL = 0 in error message calls (except run abort). 13778 C 20010425 Major update: convert source lines to upper case; 13779 C added *DECK lines; changed from 1 to * in dummy dimensions; 13780 C changed names R1MACH/D1MACH to RUMACH/DUMACH; 13781 C renamed routines for uniqueness across single/double prec.; 13782 C converted intrinsic names to generic form; 13783 C removed ILLIN and NTREP (data loaded) from Common; 13784 C removed all 'own' variables from Common; 13785 C changed error messages to quoted strings; 13786 C replaced XERRWV/XERRWD with 1993 revised version; 13787 C converted prologues, comments, error messages to mixed case; 13788 C converted arithmetic IF statements to logical IF statements; 13789 C numerous corrections to prologues and internal comments. 13790 C 20010507 Converted single precision source to double precision. 13791 C 20020502 Corrected declarations in descriptions of user routines. 13792 C 20031105 Restored 'own' variables to Common block, to enable 13793 C interrupt/restart feature. 13794 C 20031112 Added SAVE statements for data-loaded constants. 13795 C 20031117 Changed internal names NRE, LSAVR to NFE, LSAVF resp. 13796 C 13797 C----------------------------------------------------------------------- 13798 C Other routines in the DLSOIBT package. 13799 C 13800 C In addition to Subroutine DLSOIBT, the DLSOIBT package includes the 13801 C following subroutines and function routines: 13802 C DAIGBT computes the initial value of the vector 13803 C dy/dt = A-inverse * g 13804 C DINTDY computes an interpolated value of the y vector at t = TOUT. 13805 C DSTODI is the core integrator, which does one step of the 13806 C integration and the associated error control. 13807 C DCFODE sets all method coefficients and test constants. 13808 C DEWSET sets the error weight vector EWT before each step. 13809 C DVNORM computes the weighted RMS-norm of a vector. 13810 C DSRCOM is a user-callable routine to save and restore 13811 C the contents of the internal Common blocks. 13812 C DPJIBT computes and preprocesses the Jacobian matrix 13813 C and the Newton iteration matrix P. 13814 C DSLSBT manages solution of linear system in chord iteration. 13815 C DDECBT and DSOLBT are routines for solving block-tridiagonal 13816 C systems of linear algebraic equations. 13817 C DGEFA and DGESL are routines from LINPACK for solving full 13818 C systems of linear algebraic equations. 13819 C DDOT is one of the basic linear algebra modules (BLAS). 13820 C DUMACH computes the unit roundoff in a machine-independent manner. 13821 C XERRWD, XSETUN, XSETF, IXSAV, and IUMACH handle the printing of all 13822 C error messages and warnings. XERRWD is machine-dependent. 13823 C Note: DVNORM, DDOT, DUMACH, IXSAV, and IUMACH are function routines. 13824 C All the others are subroutines. 13825 C 13826 C----------------------------------------------------------------------- 13827 EXTERNAL DPJIBT, DSLSBT 13828 DOUBLE PRECISION DUMACH, DVNORM 13829 INTEGER INIT, MXSTEP, MXHNIL, NHNIL, NSLAST, NYH, IOWNS, 13830 1 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 13831 2 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 13832 3 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU 13833 INTEGER I, I1, I2, IER, IFLAG, IMXER, IRES, KGO, 13834 1 LENIW, LENRW, LENWM, LP, LYD0, MB, MORD, MXHNL0, MXSTP0, NB 13835 DOUBLE PRECISION ROWNS, 13836 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND 13837 DOUBLE PRECISION ATOLI, AYI, BIG, EWTI, H0, HMAX, HMX, RH, RTOLI, 13838 1 TCRIT, TDIST, TNEXT, TOL, TOLSF, TP, SIZE, SUM, W0 13839 DIMENSION MORD(2) 13840 LOGICAL IHIT 13841 CHARACTER*60 MSG 13842 SAVE MORD, MXSTP0, MXHNL0 13843 C----------------------------------------------------------------------- 13844 C The following internal Common block contains 13845 C (a) variables which are local to any subroutine but whose values must 13846 C be preserved between calls to the routine ("own" variables), and 13847 C (b) variables which are communicated between subroutines. 13848 C The block DLS001 is declared in subroutines DLSOIBT, DINTDY, DSTODI, 13849 C DPJIBT, and DSLSBT. 13850 C Groups of variables are replaced by dummy arrays in the Common 13851 C declarations in routines where those variables are not used. 13852 C----------------------------------------------------------------------- 13853 COMMON /DLS001/ ROWNS(209), 13854 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND, 13855 2 INIT, MXSTEP, MXHNIL, NHNIL, NSLAST, NYH, IOWNS(6), 13856 3 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 13857 4 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 13858 5 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU 13859 C 13860 DATA MORD(1),MORD(2)/12,5/, MXSTP0/500/, MXHNL0/10/ 13861 C----------------------------------------------------------------------- 13862 C Block A. 13863 C This code block is executed on every call. 13864 C It tests ISTATE and ITASK for legality and branches appropriately. 13865 C If ISTATE .gt. 1 but the flag INIT shows that initialization has 13866 C not yet been done, an error return occurs. 13867 C If ISTATE = 0 or 1 and TOUT = T, return immediately. 13868 C----------------------------------------------------------------------- 13869 IF (ISTATE .LT. 0 .OR. ISTATE .GT. 3) GO TO 601 13870 IF (ITASK .LT. 1 .OR. ITASK .GT. 5) GO TO 602 13871 IF (ISTATE .LE. 1) GO TO 10 13872 IF (INIT .EQ. 0) GO TO 603 13873 IF (ISTATE .EQ. 2) GO TO 200 13874 GO TO 20 13875 10 INIT = 0 13876 IF (TOUT .EQ. T) RETURN 13877 C----------------------------------------------------------------------- 13878 C Block B. 13879 C The next code block is executed for the initial call (ISTATE = 0 or 1) 13880 C or for a continuation call with parameter changes (ISTATE = 3). 13881 C It contains checking of all inputs and various initializations. 13882 C 13883 C First check legality of the non-optional inputs NEQ, ITOL, IOPT, 13884 C MF, MB, and NB. 13885 C----------------------------------------------------------------------- 13886 20 IF (NEQ(1) .LE. 0) GO TO 604 13887 IF (ISTATE .LE. 1) GO TO 25 13888 IF (NEQ(1) .GT. N) GO TO 605 13889 25 N = NEQ(1) 13890 IF (ITOL .LT. 1 .OR. ITOL .GT. 4) GO TO 606 13891 IF (IOPT .LT. 0 .OR. IOPT .GT. 1) GO TO 607 13892 METH = MF/10 13893 MITER = MF - 10*METH 13894 IF (METH .LT. 1 .OR. METH .GT. 2) GO TO 608 13895 IF (MITER .LT. 1 .OR. MITER .GT. 2) GO TO 608 13896 MB = IWORK(1) 13897 NB = IWORK(2) 13898 IF (MB .LT. 1 .OR. MB .GT. N) GO TO 609 13899 IF (NB .LT. 4) GO TO 610 13900 IF (MB*NB .NE. N) GO TO 609 13901 C Next process and check the optional inputs. -------------------------- 13902 IF (IOPT .EQ. 1) GO TO 40 13903 MAXORD = MORD(METH) 13904 MXSTEP = MXSTP0 13905 MXHNIL = MXHNL0 13906 IF (ISTATE .LE. 1) H0 = 0.0D0 13907 HMXI = 0.0D0 13908 HMIN = 0.0D0 13909 GO TO 60 13910 40 MAXORD = IWORK(5) 13911 IF (MAXORD .LT. 0) GO TO 611 13912 IF (MAXORD .EQ. 0) MAXORD = 100 13913 MAXORD = MIN(MAXORD,MORD(METH)) 13914 MXSTEP = IWORK(6) 13915 IF (MXSTEP .LT. 0) GO TO 612 13916 IF (MXSTEP .EQ. 0) MXSTEP = MXSTP0 13917 MXHNIL = IWORK(7) 13918 IF (MXHNIL .LT. 0) GO TO 613 13919 IF (MXHNIL .EQ. 0) MXHNIL = MXHNL0 13920 IF (ISTATE .GT. 1) GO TO 50 13921 H0 = RWORK(5) 13922 IF ((TOUT - T)*H0 .LT. 0.0D0) GO TO 614 13923 50 HMAX = RWORK(6) 13924 IF (HMAX .LT. 0.0D0) GO TO 615 13925 HMXI = 0.0D0 13926 IF (HMAX .GT. 0.0D0) HMXI = 1.0D0/HMAX 13927 HMIN = RWORK(7) 13928 IF (HMIN .LT. 0.0D0) GO TO 616 13929 C----------------------------------------------------------------------- 13930 C Set work array pointers and check lengths LRW and LIW. 13931 C Pointers to segments of RWORK and IWORK are named by prefixing L to 13932 C the name of the segment. E.g., the segment YH starts at RWORK(LYH). 13933 C Segments of RWORK (in order) are denoted YH, WM, EWT, SAVR, ACOR. 13934 C----------------------------------------------------------------------- 13935 60 LYH = 21 13936 IF (ISTATE .LE. 1) NYH = N 13937 LWM = LYH + (MAXORD + 1)*NYH 13938 LENWM = 3*MB*MB*NB + 2 13939 LEWT = LWM + LENWM 13940 LSAVF = LEWT + N 13941 LACOR = LSAVF + N 13942 LENRW = LACOR + N - 1 13943 IWORK(17) = LENRW 13944 LIWM = 1 13945 LENIW = 20 + N 13946 IWORK(18) = LENIW 13947 IF (LENRW .GT. LRW) GO TO 617 13948 IF (LENIW .GT. LIW) GO TO 618 13949 C Check RTOL and ATOL for legality. ------------------------------------ 13950 RTOLI = RTOL(1) 13951 ATOLI = ATOL(1) 13952 DO 70 I = 1,N 13953 IF (ITOL .GE. 3) RTOLI = RTOL(I) 13954 IF (ITOL .EQ. 2 .OR. ITOL .EQ. 4) ATOLI = ATOL(I) 13955 IF (RTOLI .LT. 0.0D0) GO TO 619 13956 IF (ATOLI .LT. 0.0D0) GO TO 620 13957 70 CONTINUE 13958 IF (ISTATE .LE. 1) GO TO 100 13959 C If ISTATE = 3, set flag to signal parameter changes to DSTODI. ------- 13960 JSTART = -1 13961 IF (NQ .LE. MAXORD) GO TO 90 13962 C MAXORD was reduced below NQ. Copy YH(*,MAXORD+2) into YDOTI.--------- 13963 DO 80 I = 1,N 13964 80 YDOTI(I) = RWORK(I+LWM-1) 13965 C Reload WM(1) = RWORK(lWM), since lWM may have changed. --------------- 13966 90 RWORK(LWM) = SQRT(UROUND) 13967 IF (N .EQ. NYH) GO TO 200 13968 C NEQ was reduced. Zero part of YH to avoid undefined references. ----- 13969 I1 = LYH + L*NYH 13970 I2 = LYH + (MAXORD + 1)*NYH - 1 13971 IF (I1 .GT. I2) GO TO 200 13972 DO 95 I = I1,I2 13973 95 RWORK(I) = 0.0D0 13974 GO TO 200 13975 C----------------------------------------------------------------------- 13976 C Block C. 13977 C The next block is for the initial call only (ISTATE = 0 or 1). 13978 C It contains all remaining initializations, the call to DAIGBT 13979 C (if ISTATE = 1), and the calculation of the initial step size. 13980 C The error weights in EWT are inverted after being loaded. 13981 C----------------------------------------------------------------------- 13982 100 UROUND = DUMACH() 13983 TN = T 13984 IF (ITASK .NE. 4 .AND. ITASK .NE. 5) GO TO 105 13985 TCRIT = RWORK(1) 13986 IF ((TCRIT - TOUT)*(TOUT - T) .LT. 0.0D0) GO TO 625 13987 IF (H0 .NE. 0.0D0 .AND. (T + H0 - TCRIT)*H0 .GT. 0.0D0) 13988 1 H0 = TCRIT - T 13989 105 JSTART = 0 13990 RWORK(LWM) = SQRT(UROUND) 13991 NHNIL = 0 13992 NST = 0 13993 NFE = 0 13994 NJE = 0 13995 NSLAST = 0 13996 HU = 0.0D0 13997 NQU = 0 13998 CCMAX = 0.3D0 13999 MAXCOR = 3 14000 MSBP = 20 14001 MXNCF = 10 14002 C Compute initial dy/dt, if necessary, and load it and initial Y into YH 14003 LYD0 = LYH + NYH 14004 LP = LWM + 1 14005 IF ( ISTATE .EQ. 1 ) GO TO 120 14006 C DLSOIBT must compute initial dy/dt (LYD0 points to YH(*,2)). --------- 14007 CALL DAIGBT( RES, ADDA, NEQ, T, Y, RWORK(LYD0), 14008 1 MB, NB, RWORK(LP), IWORK(21), IER ) 14009 NFE = NFE + 1 14010 IF (IER .LT. 0) GO TO 560 14011 IF (IER .GT. 0) GO TO 565 14012 DO 115 I = 1,N 14013 115 RWORK(I+LYH-1) = Y(I) 14014 GO TO 130 14015 C Initial dy/dt was supplied. Load into YH (LYD0 points to YH(*,2).). - 14016 120 DO 125 I = 1,N 14017 RWORK(I+LYH-1) = Y(I) 14018 125 RWORK(I+LYD0-1) = YDOTI(I) 14019 C Load and invert the EWT array. (H is temporarily set to 1.0.) ------- 14020 130 CONTINUE 14021 NQ = 1 14022 H = 1.0D0 14023 CALL DEWSET (N, ITOL, RTOL, ATOL, RWORK(LYH), RWORK(LEWT)) 14024 DO 135 I = 1,N 14025 IF (RWORK(I+LEWT-1) .LE. 0.0D0) GO TO 621 14026 135 RWORK(I+LEWT-1) = 1.0D0/RWORK(I+LEWT-1) 14027 C----------------------------------------------------------------------- 14028 C The coding below computes the step size, H0, to be attempted on the 14029 C first step, unless the user has supplied a value for this. 14030 C First check that TOUT - T differs significantly from zero. 14031 C A scalar tolerance quantity TOL is computed, as MAX(RTOL(i)) 14032 C if this is positive, or MAX(ATOL(i)/ABS(Y(i))) otherwise, adjusted 14033 C so as to be between 100*UROUND and 1.0E-3. 14034 C Then the computed value H0 is given by.. 14035 C NEQ 14036 C H0**2 = TOL / ( w0**-2 + (1/NEQ) * Sum ( YDOT(i)/ywt(i) )**2 ) 14037 C 1 14038 C where w0 = MAX ( ABS(T), ABS(TOUT) ), 14039 C YDOT(i) = i-th component of initial value of dy/dt, 14040 C ywt(i) = EWT(i)/TOL (a weight for y(i)). 14041 C The sign of H0 is inferred from the initial values of TOUT and T. 14042 C----------------------------------------------------------------------- 14043 IF (H0 .NE. 0.0D0) GO TO 180 14044 TDIST = ABS(TOUT - T) 14045 W0 = MAX(ABS(T),ABS(TOUT)) 14046 IF (TDIST .LT. 2.0D0*UROUND*W0) GO TO 622 14047 TOL = RTOL(1) 14048 IF (ITOL .LE. 2) GO TO 145 14049 DO 140 I = 1,N 14050 140 TOL = MAX(TOL,RTOL(I)) 14051 145 IF (TOL .GT. 0.0D0) GO TO 160 14052 ATOLI = ATOL(1) 14053 DO 150 I = 1,N 14054 IF (ITOL .EQ. 2 .OR. ITOL .EQ. 4) ATOLI = ATOL(I) 14055 AYI = ABS(Y(I)) 14056 IF (AYI .NE. 0.0D0) TOL = MAX(TOL,ATOLI/AYI) 14057 150 CONTINUE 14058 160 TOL = MAX(TOL,100.0D0*UROUND) 14059 TOL = MIN(TOL,0.001D0) 14060 SUM = DVNORM (N, RWORK(LYD0), RWORK(LEWT)) 14061 SUM = 1.0D0/(TOL*W0*W0) + TOL*SUM**2 14062 H0 = 1.0D0/SQRT(SUM) 14063 H0 = MIN(H0,TDIST) 14064 H0 = SIGN(H0,TOUT-T) 14065 C Adjust H0 if necessary to meet HMAX bound. --------------------------- 14066 180 RH = ABS(H0)*HMXI 14067 IF (RH .GT. 1.0D0) H0 = H0/RH 14068 C Load H with H0 and scale YH(*,2) by H0. ------------------------------ 14069 H = H0 14070 DO 190 I = 1,N 14071 190 RWORK(I+LYD0-1) = H0*RWORK(I+LYD0-1) 14072 GO TO 270 14073 C----------------------------------------------------------------------- 14074 C Block D. 14075 C The next code block is for continuation calls only (ISTATE = 2 or 3) 14076 C and is to check stop conditions before taking a step. 14077 C----------------------------------------------------------------------- 14078 200 NSLAST = NST 14079 GO TO (210, 250, 220, 230, 240), ITASK 14080 210 IF ((TN - TOUT)*H .LT. 0.0D0) GO TO 250 14081 CALL DINTDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) 14082 IF (IFLAG .NE. 0) GO TO 627 14083 T = TOUT 14084 GO TO 420 14085 220 TP = TN - HU*(1.0D0 + 100.0D0*UROUND) 14086 IF ((TP - TOUT)*H .GT. 0.0D0) GO TO 623 14087 IF ((TN - TOUT)*H .LT. 0.0D0) GO TO 250 14088 GO TO 400 14089 230 TCRIT = RWORK(1) 14090 IF ((TN - TCRIT)*H .GT. 0.0D0) GO TO 624 14091 IF ((TCRIT - TOUT)*H .LT. 0.0D0) GO TO 625 14092 IF ((TN - TOUT)*H .LT. 0.0D0) GO TO 245 14093 CALL DINTDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) 14094 IF (IFLAG .NE. 0) GO TO 627 14095 T = TOUT 14096 GO TO 420 14097 240 TCRIT = RWORK(1) 14098 IF ((TN - TCRIT)*H .GT. 0.0D0) GO TO 624 14099 245 HMX = ABS(TN) + ABS(H) 14100 IHIT = ABS(TN - TCRIT) .LE. 100.0D0*UROUND*HMX 14101 IF (IHIT) GO TO 400 14102 TNEXT = TN + H*(1.0D0 + 4.0D0*UROUND) 14103 IF ((TNEXT - TCRIT)*H .LE. 0.0D0) GO TO 250 14104 H = (TCRIT - TN)*(1.0D0 - 4.0D0*UROUND) 14105 IF (ISTATE .EQ. 2) JSTART = -2 14106 C----------------------------------------------------------------------- 14107 C Block E. 14108 C The next block is normally executed for all calls and contains 14109 C the call to the one-step core integrator DSTODI. 14110 C 14111 C This is a looping point for the integration steps. 14112 C 14113 C First check for too many steps being taken, update EWT (if not at 14114 C start of problem), check for too much accuracy being requested, and 14115 C check for H below the roundoff level in T. 14116 C----------------------------------------------------------------------- 14117 250 CONTINUE 14118 IF ((NST-NSLAST) .GE. MXSTEP) GO TO 500 14119 CALL DEWSET (N, ITOL, RTOL, ATOL, RWORK(LYH), RWORK(LEWT)) 14120 DO 260 I = 1,N 14121 IF (RWORK(I+LEWT-1) .LE. 0.0D0) GO TO 510 14122 260 RWORK(I+LEWT-1) = 1.0D0/RWORK(I+LEWT-1) 14123 270 TOLSF = UROUND*DVNORM (N, RWORK(LYH), RWORK(LEWT)) 14124 IF (TOLSF .LE. 1.0D0) GO TO 280 14125 TOLSF = TOLSF*2.0D0 14126 IF (NST .EQ. 0) GO TO 626 14127 GO TO 520 14128 280 IF ((TN + H) .NE. TN) GO TO 290 14129 NHNIL = NHNIL + 1 14130 IF (NHNIL .GT. MXHNIL) GO TO 290 14131 MSG = 'DLSOIBT- Warning..Internal T (=R1) and H (=R2) are' 14132 CALL XERRWD (MSG, 50, 101, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 14133 MSG=' such that in the machine, T + H = T on the next step ' 14134 CALL XERRWD (MSG, 60, 101, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 14135 MSG = ' (H = step size). Solver will continue anyway.' 14136 CALL XERRWD (MSG, 50, 101, 0, 0, 0, 0, 2, TN, H) 14137 IF (NHNIL .LT. MXHNIL) GO TO 290 14138 MSG = 'DLSOIBT- Above warning has been issued I1 times. ' 14139 CALL XERRWD (MSG, 50, 102, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 14140 MSG = ' It will not be issued again for this problem.' 14141 CALL XERRWD (MSG, 50, 102, 0, 1, MXHNIL, 0, 0, 0.0D0, 0.0D0) 14142 290 CONTINUE 14143 C----------------------------------------------------------------------- 14144 C CALL DSTODI(NEQ,Y,YH,NYH,YH1,EWT,SAVF,SAVR,ACOR,WM,IWM,RES, 14145 C ADDA,JAC,DPJIBT,DSLSBT) 14146 C Note: SAVF in DSTODI occupies the same space as YDOTI in DLSOIBT. 14147 C----------------------------------------------------------------------- 14148 CALL DSTODI (NEQ, Y, RWORK(LYH), NYH, RWORK(LYH), RWORK(LEWT), 14149 1 YDOTI, RWORK(LSAVF), RWORK(LACOR), RWORK(LWM), 14150 2 IWORK(LIWM), RES, ADDA, JAC, DPJIBT, DSLSBT ) 14151 KGO = 1 - KFLAG 14152 GO TO (300, 530, 540, 400, 550), KGO 14153 C 14154 C KGO = 1:success; 2:error test failure; 3:convergence failure; 14155 C 4:RES ordered return; 5:RES returned error. 14156 C----------------------------------------------------------------------- 14157 C Block F. 14158 C The following block handles the case of a successful return from the 14159 C core integrator (KFLAG = 0). Test for stop conditions. 14160 C----------------------------------------------------------------------- 14161 300 INIT = 1 14162 GO TO (310, 400, 330, 340, 350), ITASK 14163 C ITASK = 1. If TOUT has been reached, interpolate. ------------------- 14164 310 IF ((TN - TOUT)*H .LT. 0.0D0) GO TO 250 14165 CALL DINTDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) 14166 T = TOUT 14167 GO TO 420 14168 C ITASK = 3. Jump to exit if TOUT was reached. ------------------------ 14169 330 IF ((TN - TOUT)*H .GE. 0.0D0) GO TO 400 14170 GO TO 250 14171 C ITASK = 4. See if TOUT or TCRIT was reached. Adjust H if necessary. 14172 340 IF ((TN - TOUT)*H .LT. 0.0D0) GO TO 345 14173 CALL DINTDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) 14174 T = TOUT 14175 GO TO 420 14176 345 HMX = ABS(TN) + ABS(H) 14177 IHIT = ABS(TN - TCRIT) .LE. 100.0D0*UROUND*HMX 14178 IF (IHIT) GO TO 400 14179 TNEXT = TN + H*(1.0D0 + 4.0D0*UROUND) 14180 IF ((TNEXT - TCRIT)*H .LE. 0.0D0) GO TO 250 14181 H = (TCRIT - TN)*(1.0D0 - 4.0D0*UROUND) 14182 JSTART = -2 14183 GO TO 250 14184 C ITASK = 5. see if TCRIT was reached and jump to exit. --------------- 14185 350 HMX = ABS(TN) + ABS(H) 14186 IHIT = ABS(TN - TCRIT) .LE. 100.0D0*UROUND*HMX 14187 C----------------------------------------------------------------------- 14188 C Block G. 14189 C The following block handles all successful returns from DLSOIBT. 14190 C If ITASK .ne. 1, Y is loaded from YH and T is set accordingly. 14191 C ISTATE is set to 2, and the optional outputs are loaded into the 14192 C work arrays before returning. 14193 C----------------------------------------------------------------------- 14194 400 DO 410 I = 1,N 14195 410 Y(I) = RWORK(I+LYH-1) 14196 T = TN 14197 IF (ITASK .NE. 4 .AND. ITASK .NE. 5) GO TO 420 14198 IF (IHIT) T = TCRIT 14199 420 ISTATE = 2 14200 IF ( KFLAG .EQ. -3 ) ISTATE = 3 14201 RWORK(11) = HU 14202 RWORK(12) = H 14203 RWORK(13) = TN 14204 IWORK(11) = NST 14205 IWORK(12) = NFE 14206 IWORK(13) = NJE 14207 IWORK(14) = NQU 14208 IWORK(15) = NQ 14209 RETURN 14210 C----------------------------------------------------------------------- 14211 C Block H. 14212 C The following block handles all unsuccessful returns other than 14213 C those for illegal input. First the error message routine is called. 14214 C If there was an error test or convergence test failure, IMXER is set. 14215 C Then Y is loaded from YH and T is set to TN. 14216 C The optional outputs are loaded into the work arrays before returning. 14217 C----------------------------------------------------------------------- 14218 C The maximum number of steps was taken before reaching TOUT. ---------- 14219 500 MSG = 'DLSOIBT- At current T (=R1), MXSTEP (=I1) steps ' 14220 CALL XERRWD (MSG, 50, 201, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 14221 MSG = ' taken on this call before reaching TOUT ' 14222 CALL XERRWD (MSG, 50, 201, 0, 1, MXSTEP, 0, 1, TN, 0.0D0) 14223 ISTATE = -1 14224 GO TO 580 14225 C EWT(i) .le. 0.0 for some i (not at start of problem). ---------------- 14226 510 EWTI = RWORK(LEWT+I-1) 14227 MSG = 'DLSOIBT- At T (=R1), EWT(I1) has become R2 .le. 0.' 14228 CALL XERRWD (MSG, 50, 202, 0, 1, I, 0, 2, TN, EWTI) 14229 ISTATE = -6 14230 GO TO 590 14231 C Too much accuracy requested for machine precision. ------------------- 14232 520 MSG = 'DLSOIBT- At T (=R1), too much accuracy requested ' 14233 CALL XERRWD (MSG, 50, 203, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 14234 MSG = ' for precision of machine.. See TOLSF (=R2) ' 14235 CALL XERRWD (MSG, 50, 203, 0, 0, 0, 0, 2, TN, TOLSF) 14236 RWORK(14) = TOLSF 14237 ISTATE = -2 14238 GO TO 590 14239 C KFLAG = -1. Error test failed repeatedly or with ABS(H) = HMIN. ----- 14240 530 MSG = 'DLSOIBT- At T (=R1) and step size H (=R2), the ' 14241 CALL XERRWD (MSG, 50, 204, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 14242 MSG = 'error test failed repeatedly or with ABS(H) = HMIN' 14243 CALL XERRWD (MSG, 50, 204, 0, 0, 0, 0, 2, TN, H) 14244 ISTATE = -4 14245 GO TO 570 14246 C KFLAG = -2. Convergence failed repeatedly or with ABS(H) = HMIN. ---- 14247 540 MSG = 'DLSOIBT- At T (=R1) and step size H (=R2), the ' 14248 CALL XERRWD (MSG, 50, 205, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 14249 MSG = ' corrector convergence failed repeatedly ' 14250 CALL XERRWD (MSG, 50, 205, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 14251 MSG = ' or with ABS(H) = HMIN ' 14252 CALL XERRWD (MSG, 30, 205, 0, 0, 0, 0, 2, TN, H) 14253 ISTATE = -5 14254 GO TO 570 14255 C IRES = 3 returned by RES, despite retries by DSTODI.------------------ 14256 550 MSG = 'DLSOIBT- At T (=R1) residual routine returned ' 14257 CALL XERRWD (MSG, 50, 206, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 14258 MSG = ' error IRES = 3 repeatedly. ' 14259 CALL XERRWD (MSG, 40, 206, 0, 0, 0, 0, 1, TN, 0.0D0) 14260 ISTATE = -7 14261 GO TO 590 14262 C DAIGBT failed because a diagonal block of A matrix was singular. ----- 14263 560 IER = -IER 14264 MSG='DLSOIBT- Attempt to initialize dy/dt failed: Matrix A has a' 14265 CALL XERRWD (MSG, 60, 207, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 14266 MSG = ' singular diagonal block, block no. = (I1) ' 14267 CALL XERRWD (MSG, 50, 207, 0, 1, IER, 0, 0, 0.0D0, 0.0D0) 14268 ISTATE = -8 14269 RETURN 14270 C DAIGBT failed because RES set IRES to 2 or 3. ------------------------ 14271 565 MSG = 'DLSOIBT- Attempt to initialize dy/dt failed ' 14272 CALL XERRWD (MSG, 50, 208, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 14273 MSG = ' because residual routine set its error flag ' 14274 CALL XERRWD (MSG, 50, 208, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 14275 MSG = ' to IRES = (I1)' 14276 CALL XERRWD (MSG, 20, 208, 0, 1, IER, 0, 0, 0.0D0, 0.0D0) 14277 ISTATE = -8 14278 RETURN 14279 C Compute IMXER if relevant. ------------------------------------------- 14280 570 BIG = 0.0D0 14281 IMXER = 1 14282 DO 575 I = 1,N 14283 SIZE = ABS(RWORK(I+LACOR-1)*RWORK(I+LEWT-1)) 14284 IF (BIG .GE. SIZE) GO TO 575 14285 BIG = SIZE 14286 IMXER = I 14287 575 CONTINUE 14288 IWORK(16) = IMXER 14289 C Compute residual if relevant. ---------------------------------------- 14290 580 LYD0 = LYH + NYH 14291 DO 585 I = 1,N 14292 RWORK(I+LSAVF-1) = RWORK(I+LYD0-1)/H 14293 585 Y(I) = RWORK(I+LYH-1) 14294 IRES = 1 14295 CALL RES (NEQ, TN, Y, RWORK(LSAVF), YDOTI, IRES) 14296 NFE = NFE + 1 14297 IF (IRES .LE. 1) GO TO 595 14298 MSG = 'DLSOIBT- Residual routine set its flag IRES ' 14299 CALL XERRWD (MSG, 50, 210, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 14300 MSG = ' to (I1) when called for final output. ' 14301 CALL XERRWD (MSG, 50, 210, 0, 1, IRES, 0, 0, 0.0D0, 0.0D0) 14302 GO TO 595 14303 C Set Y vector, T, and optional outputs. ------------------------------- 14304 590 DO 592 I = 1,N 14305 592 Y(I) = RWORK(I+LYH-1) 14306 595 T = TN 14307 RWORK(11) = HU 14308 RWORK(12) = H 14309 RWORK(13) = TN 14310 IWORK(11) = NST 14311 IWORK(12) = NFE 14312 IWORK(13) = NJE 14313 IWORK(14) = NQU 14314 IWORK(15) = NQ 14315 RETURN 14316 C----------------------------------------------------------------------- 14317 C Block I. 14318 C The following block handles all error returns due to illegal input 14319 C (ISTATE = -3), as detected before calling the core integrator. 14320 C First the error message routine is called. If the illegal input 14321 C is a negative ISTATE, the run is aborted (apparent infinite loop). 14322 C----------------------------------------------------------------------- 14323 601 MSG = 'DLSOIBT- ISTATE (=I1) illegal.' 14324 CALL XERRWD (MSG, 30, 1, 0, 1, ISTATE, 0, 0, 0.0D0, 0.0D0) 14325 IF (ISTATE .LT. 0) GO TO 800 14326 GO TO 700 14327 602 MSG = 'DLSOIBT- ITASK (=I1) illegal. ' 14328 CALL XERRWD (MSG, 30, 2, 0, 1, ITASK, 0, 0, 0.0D0, 0.0D0) 14329 GO TO 700 14330 603 MSG = 'DLSOIBT- ISTATE.gt.1 but DLSOIBT not initialized. ' 14331 CALL XERRWD (MSG, 50, 3, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 14332 GO TO 700 14333 604 MSG = 'DLSOIBT- NEQ (=I1) .lt. 1 ' 14334 CALL XERRWD (MSG, 30, 4, 0, 1, NEQ(1), 0, 0, 0.0D0, 0.0D0) 14335 GO TO 700 14336 605 MSG = 'DLSOIBT- ISTATE = 3 and NEQ increased (I1 to I2). ' 14337 CALL XERRWD (MSG, 50, 5, 0, 2, N, NEQ(1), 0, 0.0D0, 0.0D0) 14338 GO TO 700 14339 606 MSG = 'DLSOIBT- ITOL (=I1) illegal. ' 14340 CALL XERRWD (MSG, 30, 6, 0, 1, ITOL, 0, 0, 0.0D0, 0.0D0) 14341 GO TO 700 14342 607 MSG = 'DLSOIBT- IOPT (=I1) illegal. ' 14343 CALL XERRWD (MSG, 30, 7, 0, 1, IOPT, 0, 0, 0.0D0, 0.0D0) 14344 GO TO 700 14345 608 MSG = 'DLSOIBT- MF (=I1) illegal. ' 14346 CALL XERRWD (MSG, 30, 8, 0, 1, MF, 0, 0, 0.0D0, 0.0D0) 14347 GO TO 700 14348 609 MSG = 'DLSOIBT- MB (=I1) or NB (=I2) illegal. ' 14349 CALL XERRWD (MSG, 40, 9, 0, 2, MB, NB, 0, 0.0D0, 0.0D0) 14350 GO TO 700 14351 610 MSG = 'DLSOIBT- NB (=I1) .lt. 4 illegal. ' 14352 CALL XERRWD (MSG, 40, 10, 0, 1, NB, 0, 0, 0.0D0, 0.0D0) 14353 GO TO 700 14354 611 MSG = 'DLSOIBT- MAXORD (=I1) .lt. 0 ' 14355 CALL XERRWD (MSG, 30, 11, 0, 1, MAXORD, 0, 0, 0.0D0, 0.0D0) 14356 GO TO 700 14357 612 MSG = 'DLSOIBT- MXSTEP (=I1) .lt. 0 ' 14358 CALL XERRWD (MSG, 30, 12, 0, 1, MXSTEP, 0, 0, 0.0D0, 0.0D0) 14359 GO TO 700 14360 613 MSG = 'DLSOIBT- MXHNIL (=I1) .lt. 0 ' 14361 CALL XERRWD (MSG, 30, 13, 0, 1, MXHNIL, 0, 0, 0.0D0, 0.0D0) 14362 GO TO 700 14363 614 MSG = 'DLSOIBT- TOUT (=R1) behind T (=R2) ' 14364 CALL XERRWD (MSG, 40, 14, 0, 0, 0, 0, 2, TOUT, T) 14365 MSG = ' Integration direction is given by H0 (=R1) ' 14366 CALL XERRWD (MSG, 50, 14, 0, 0, 0, 0, 1, H0, 0.0D0) 14367 GO TO 700 14368 615 MSG = 'DLSOIBT- HMAX (=R1) .lt. 0.0 ' 14369 CALL XERRWD (MSG, 30, 15, 0, 0, 0, 0, 1, HMAX, 0.0D0) 14370 GO TO 700 14371 616 MSG = 'DLSOIBT- HMIN (=R1) .lt. 0.0 ' 14372 CALL XERRWD (MSG, 30, 16, 0, 0, 0, 0, 1, HMIN, 0.0D0) 14373 GO TO 700 14374 617 MSG='DLSOIBT- RWORK length needed, LENRW (=I1), exceeds LRW (=I2)' 14375 CALL XERRWD (MSG, 60, 17, 0, 2, LENRW, LRW, 0, 0.0D0, 0.0D0) 14376 GO TO 700 14377 618 MSG='DLSOIBT- IWORK length needed, LENIW (=I1), exceeds LIW (=I2)' 14378 CALL XERRWD (MSG, 60, 18, 0, 2, LENIW, LIW, 0, 0.0D0, 0.0D0) 14379 GO TO 700 14380 619 MSG = 'DLSOIBT- RTOL(=I1) is R1 .lt. 0.0 ' 14381 CALL XERRWD (MSG, 40, 19, 0, 1, I, 0, 1, RTOLI, 0.0D0) 14382 GO TO 700 14383 620 MSG = 'DLSOIBT- ATOL(=I1) is R1 .lt. 0.0 ' 14384 CALL XERRWD (MSG, 40, 20, 0, 1, I, 0, 1, ATOLI, 0.0D0) 14385 GO TO 700 14386 621 EWTI = RWORK(LEWT+I-1) 14387 MSG = 'DLSOIBT- EWT(I1) is R1 .le. 0.0 ' 14388 CALL XERRWD (MSG, 40, 21, 0, 1, I, 0, 1, EWTI, 0.0D0) 14389 GO TO 700 14390 622 MSG='DLSOIBT- TOUT(=R1) too close to T(=R2) to start integration.' 14391 CALL XERRWD (MSG, 60, 22, 0, 0, 0, 0, 2, TOUT, T) 14392 GO TO 700 14393 623 MSG='DLSOIBT- ITASK = I1 and TOUT (=R1) behind TCUR - HU (= R2) ' 14394 CALL XERRWD (MSG, 60, 23, 0, 1, ITASK, 0, 2, TOUT, TP) 14395 GO TO 700 14396 624 MSG='DLSOIBT- ITASK = 4 or 5 and TCRIT (=R1) behind TCUR (=R2) ' 14397 CALL XERRWD (MSG, 60, 24, 0, 0, 0, 0, 2, TCRIT, TN) 14398 GO TO 700 14399 625 MSG='DLSOIBT- ITASK = 4 or 5 and TCRIT (=R1) behind TOUT (=R2) ' 14400 CALL XERRWD (MSG, 60, 25, 0, 0, 0, 0, 2, TCRIT, TOUT) 14401 GO TO 700 14402 626 MSG = 'DLSOIBT- At start of problem, too much accuracy ' 14403 CALL XERRWD (MSG, 50, 26, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 14404 MSG=' requested for precision of machine.. See TOLSF (=R1) ' 14405 CALL XERRWD (MSG, 60, 26, 0, 0, 0, 0, 1, TOLSF, 0.0D0) 14406 RWORK(14) = TOLSF 14407 GO TO 700 14408 627 MSG = 'DLSOIBT- Trouble in DINTDY. ITASK = I1, TOUT = R1' 14409 CALL XERRWD (MSG, 50, 27, 0, 1, ITASK, 0, 1, TOUT, 0.0D0) 14410 C 14411 700 ISTATE = -3 14412 RETURN 14413 C 14414 800 MSG = 'DLSOIBT- Run aborted.. apparent infinite loop. ' 14415 CALL XERRWD (MSG, 50, 303, 2, 0, 0, 0, 0, 0.0D0, 0.0D0) 14416 RETURN 14417 C----------------------- End of Subroutine DLSOIBT --------------------- 14418 END 14419 *DECK DLSODIS 14420 SUBROUTINE DLSODIS (RES, ADDA, JAC, NEQ, Y, YDOTI, T, TOUT, ITOL, 14421 1 RTOL, ATOL, ITASK, ISTATE, IOPT, RWORK, LRW, IWORK, LIW, MF ) 14422 EXTERNAL RES, ADDA, JAC 14423 INTEGER NEQ, ITOL, ITASK, ISTATE, IOPT, LRW, IWORK, LIW, MF 14424 DOUBLE PRECISION Y, YDOTI, T, TOUT, RTOL, ATOL, RWORK 14425 DIMENSION NEQ(*), Y(*), YDOTI(*), RTOL(*), ATOL(*), RWORK(LRW), 14426 1 IWORK(LIW) 14427 C----------------------------------------------------------------------- 14428 C This is the 18 November 2003 version of 14429 C DLSODIS: Livermore Solver for Ordinary Differential equations 14430 C (Implicit form) with general Sparse Jacobian matrices. 14431 C 14432 C This version is in double precision. 14433 C 14434 C DLSODIS solves the initial value problem for linearly implicit 14435 C systems of first order ODEs, 14436 C A(t,y) * dy/dt = g(t,y) , where A(t,y) is a square matrix, 14437 C or, in component form, 14438 C ( a * ( dy / dt )) + ... + ( a * ( dy / dt )) = 14439 C i,1 1 i,NEQ NEQ 14440 C 14441 C = g ( t, y , y ,..., y ) ( i = 1,...,NEQ ) 14442 C i 1 2 NEQ 14443 C 14444 C If A is singular, this is a differential-algebraic system. 14445 C 14446 C DLSODIS is a variant version of the DLSODI package, and is intended 14447 C for stiff problems in which the matrix A and the Jacobian matrix 14448 C d(g - A*s)/dy have arbitrary sparse structures. 14449 C 14450 C Authors: Alan C. Hindmarsh 14451 C Center for Applied Scientific Computing, L-561 14452 C Lawrence Livermore National Laboratory 14453 C Livermore, CA 94551 14454 C and 14455 C Sheila Balsdon 14456 C Zycor, Inc. 14457 C Austin, TX 78741 14458 C----------------------------------------------------------------------- 14459 C References: 14460 C 1. M. K. Seager and S. Balsdon, LSODIS, A Sparse Implicit 14461 C ODE Solver, in Proceedings of the IMACS 10th World Congress, 14462 C Montreal, August 8-13, 1982. 14463 C 14464 C 2. Alan C. Hindmarsh, LSODE and LSODI, Two New Initial Value 14465 C Ordinary Differential Equation Solvers, 14466 C ACM-SIGNUM Newsletter, vol. 15, no. 4 (1980), pp. 10-11. 14467 C 14468 C 3. S. C. Eisenstat, M. C. Gursky, M. H. Schultz, and A. H. Sherman, 14469 C Yale Sparse Matrix Package: I. The Symmetric Codes, 14470 C Int. J. Num. Meth. Eng., vol. 18 (1982), pp. 1145-1151. 14471 C 14472 C 4. S. C. Eisenstat, M. C. Gursky, M. H. Schultz, and A. H. Sherman, 14473 C Yale Sparse Matrix Package: II. The Nonsymmetric Codes, 14474 C Research Report No. 114, Dept. of Computer Sciences, Yale 14475 C University, 1977. 14476 C----------------------------------------------------------------------- 14477 C Summary of Usage. 14478 C 14479 C Communication between the user and the DLSODIS package, for normal 14480 C situations, is summarized here. This summary describes only a subset 14481 C of the full set of options available. See the full description for 14482 C details, including optional communication, nonstandard options, 14483 C and instructions for special situations. See also the example 14484 C problem (with program and output) following this summary. 14485 C 14486 C A. First, provide a subroutine of the form: 14487 C SUBROUTINE RES (NEQ, T, Y, S, R, IRES) 14488 C DOUBLE PRECISION T, Y(*), S(*), R(*) 14489 C which computes the residual function 14490 C r = g(t,y) - A(t,y) * s , 14491 C as a function of t and the vectors y and s. (s is an internally 14492 C generated approximation to dy/dt.) The arrays Y and S are inputs 14493 C to the RES routine and should not be altered. The residual 14494 C vector is to be stored in the array R. The argument IRES should be 14495 C ignored for casual use of DLSODIS. (For uses of IRES, see the 14496 C paragraph on RES in the full description below.) 14497 C 14498 C B. DLSODIS must deal internally with the matrices A and dr/dy, where 14499 C r is the residual function defined above. DLSODIS generates a linear 14500 C combination of these two matrices in sparse form. 14501 C The matrix structure is communicated by a method flag, MF: 14502 C MF = 21 or 22 when the user provides the structures of 14503 C matrix A and dr/dy, 14504 C MF = 121 or 222 when the user does not provide structure 14505 C information, and 14506 C MF = 321 or 422 when the user provides the structure 14507 C of matrix A. 14508 C 14509 C C. You must also provide a subroutine of the form: 14510 C SUBROUTINE ADDA (NEQ, T, Y, J, IAN, JAN, P) 14511 C DOUBLE PRECISION T, Y(*), P(*) 14512 C INTEGER IAN(*), JAN(*) 14513 C which adds the matrix A = A(t,y) to the contents of the array P. 14514 C NEQ, T, Y, and J are input arguments and should not be altered. 14515 C This routine should add the J-th column of matrix A to the array 14516 C P (of length NEQ). I.e. add A(i,J) to P(i) for all relevant 14517 C values of i. The arguments IAN and JAN should be ignored for normal 14518 C situations. DLSODIS will call the ADDA routine with J = 1,2,...,NEQ. 14519 C 14520 C D. For the sake of efficiency, you are encouraged to supply the 14521 C Jacobian matrix dr/dy in closed form, where r = g(t,y) - A(t,y)*s 14522 C (s = a fixed vector) as above. If dr/dy is being supplied, 14523 C use MF = 21, 121, or 321, and provide a subroutine of the form: 14524 C SUBROUTINE JAC (NEQ, T, Y, S, J, IAN, JAN, PDJ) 14525 C DOUBLE PRECISION T, Y(*), S(*), PDJ(*) 14526 C INTEGER IAN(*), JAN(*) 14527 C which computes dr/dy as a function of t, y, and s. Here NEQ, T, Y, S, 14528 C and J are input arguments, and the JAC routine is to load the array 14529 C PDJ (of length NEQ) with the J-th column of dr/dy. I.e. load PDJ(i) 14530 C with dr(i)/dy(J) for all relevant values of i. The arguments IAN and 14531 C JAN should be ignored for normal situations. DLSODIS will call the 14532 C JAC routine with J = 1,2,...,NEQ. 14533 C Only nonzero elements need be loaded. A crude approximation 14534 C to dr/dy, possibly with fewer nonzero elememts, will suffice. 14535 C Note that if A is independent of y (or this dependence 14536 C is weak enough to be ignored) then JAC is to compute dg/dy. 14537 C If it is not feasible to provide a JAC routine, use 14538 C MF = 22, 222, or 422 and DLSODIS will compute an approximate 14539 C Jacobian internally by difference quotients. 14540 C 14541 C E. Next decide whether or not to provide the initial value of the 14542 C derivative vector dy/dt. If the initial value of A(t,y) is 14543 C nonsingular (and not too ill-conditioned), you may let DLSODIS compute 14544 C this vector (ISTATE = 0). (DLSODIS will solve the system A*s = g for 14545 C s, with initial values of A and g.) If A(t,y) is initially 14546 C singular, then the system is a differential-algebraic system, and 14547 C you must make use of the particular form of the system to compute the 14548 C initial values of y and dy/dt. In that case, use ISTATE = 1 and 14549 C load the initial value of dy/dt into the array YDOTI. 14550 C The input array YDOTI and the initial Y array must be consistent with 14551 C the equations A*dy/dt = g. This implies that the initial residual 14552 C r = g(t,y) - A(t,y)*YDOTI must be approximately zero. 14553 C 14554 C F. Write a main program which calls Subroutine DLSODIS once for 14555 C each point at which answers are desired. This should also provide 14556 C for possible use of logical unit 6 for output of error messages by 14557 C DLSODIS. On the first call to DLSODIS, supply arguments as follows: 14558 C RES = name of user subroutine for residual function r. 14559 C ADDA = name of user subroutine for computing and adding A(t,y). 14560 C JAC = name of user subroutine for Jacobian matrix dr/dy 14561 C (MF = 121). If not used, pass a dummy name. 14562 C Note: The names for the RES and ADDA routines and (if used) the 14563 C JAC routine must be declared External in the calling program. 14564 C NEQ = number of scalar equations in the system. 14565 C Y = array of initial values, of length NEQ. 14566 C YDOTI = array of length NEQ (containing initial dy/dt if ISTATE = 1). 14567 C T = the initial value of the independent variable. 14568 C TOUT = first point where output is desired (.ne. T). 14569 C ITOL = 1 or 2 according as ATOL (below) is a scalar or array. 14570 C RTOL = relative tolerance parameter (scalar). 14571 C ATOL = absolute tolerance parameter (scalar or array). 14572 C The estimated local error in y(i) will be controlled so as 14573 C to be roughly less (in magnitude) than 14574 C EWT(i) = RTOL*ABS(Y(i)) + ATOL if ITOL = 1, or 14575 C EWT(i) = RTOL*ABS(Y(i)) + ATOL(i) if ITOL = 2. 14576 C Thus the local error test passes if, in each component, 14577 C either the absolute error is less than ATOL (or ATOL(i)), 14578 C or the relative error is less than RTOL. 14579 C Use RTOL = 0.0 for pure absolute error control, and 14580 C use ATOL = 0.0 (or ATOL(i) = 0.0) for pure relative error 14581 C control. Caution: Actual (global) errors may exceed these 14582 C local tolerances, so choose them conservatively. 14583 C ITASK = 1 for normal computation of output values of y at t = TOUT. 14584 C ISTATE = integer flag (input and output). Set ISTATE = 1 if the 14585 C initial dy/dt is supplied, and 0 otherwise. 14586 C IOPT = 0 to indicate no optional inputs used. 14587 C RWORK = real work array of length at least: 14588 C 20 + (2 + 1./LENRAT)*NNZ + (11 + 9./LENRAT)*NEQ 14589 C where: 14590 C NNZ = the number of nonzero elements in the sparse 14591 C iteration matrix P = A - con*dr/dy (con = scalar) 14592 C (If NNZ is unknown, use an estimate of it.) 14593 C LENRAT = the real to integer wordlength ratio (usually 1 in 14594 C single precision and 2 in double precision). 14595 C In any case, the required size of RWORK cannot generally 14596 C be predicted in advance for any value of MF, and the 14597 C value above is a rough estimate of a crude lower bound. 14598 C Some experimentation with this size may be necessary. 14599 C (When known, the correct required length is an optional 14600 C output, available in IWORK(17).) 14601 C LRW = declared length of RWORK (in user's dimension). 14602 C IWORK = integer work array of length at least 30. 14603 C LIW = declared length of IWORK (in user's dimension). 14604 C MF = method flag. Standard values are: 14605 C 121 for a user-supplied sparse Jacobian. 14606 C 222 for an internally generated sparse Jacobian. 14607 C For other choices of MF, see the paragraph on MF in 14608 C the full description below. 14609 C Note that the main program must declare arrays Y, YDOTI, RWORK, IWORK, 14610 C and possibly ATOL. 14611 C 14612 C G. The output from the first call, or any call, is: 14613 C Y = array of computed values of y(t) vector. 14614 C T = corresponding value of independent variable (normally TOUT). 14615 C ISTATE = 2 if DLSODIS was successful, negative otherwise. 14616 C -1 means excess work done on this call (check all inputs). 14617 C -2 means excess accuracy requested (tolerances too small). 14618 C -3 means illegal input detected (see printed message). 14619 C -4 means repeated error test failures (check all inputs). 14620 C -5 means repeated convergence failures (perhaps bad Jacobian 14621 C supplied or wrong choice of tolerances). 14622 C -6 means error weight became zero during problem. (Solution 14623 C component i vanished, and ATOL or ATOL(i) = 0.) 14624 C -7 cannot occur in casual use. 14625 C -8 means DLSODIS was unable to compute the initial dy/dt. 14626 C in casual use, this means A(t,y) is initially singular. 14627 C Supply YDOTI and use ISTATE = 1 on the first call. 14628 C -9 means a fatal error return flag came from sparse solver 14629 C CDRV by way of DPRJIS or DSOLSS. Should never happen. 14630 C 14631 C A return with ISTATE = -1, -4, or -5, may result from using 14632 C an inappropriate sparsity structure, one that is quite 14633 C different from the initial structure. Consider calling 14634 C DLSODIS again with ISTATE = 3 to force the structure to be 14635 C reevaluated. See the full description of ISTATE below. 14636 C 14637 C If DLSODIS returns ISTATE = -1, -4 or -5, then the output of 14638 C DLSODIS also includes YDOTI = array containing residual vector 14639 C r = g - A * dy/dt evaluated at the current t, y, and dy/dt. 14640 C 14641 C H. To continue the integration after a successful return, simply 14642 C reset TOUT and call DLSODIS again. No other parameters need be reset. 14643 C 14644 C----------------------------------------------------------------------- 14645 C Example Problem. 14646 C 14647 C The following is an example problem, with the coding needed 14648 C for its solution by DLSODIS. The problem comes from the partial 14649 C differential equation (the Burgers equation) 14650 C du/dt = - u * du/dx + eta * d**2 u/dx**2, eta = .05, 14651 C on -1 .le. x .le. 1. The boundary conditions are periodic: 14652 C u(-1,t) = u(1,t) and du/dx(-1,t) = du/dx(1,t) 14653 C The initial profile is a square wave, 14654 C u = 1 in ABS(x) .lt. .5, u = .5 at ABS(x) = .5, u = 0 elsewhere. 14655 C The PDE is discretized in x by a simplified Galerkin method, 14656 C using piecewise linear basis functions, on a grid of 40 intervals. 14657 C The result is a system A * dy/dt = g(y), of size NEQ = 40, 14658 C where y(i) is the approximation to u at x = x(i), with 14659 C x(i) = -1 + (i-1)*delx, delx = 2/NEQ = .05. 14660 C The individual equations in the system are (in order): 14661 C (1/6)dy(NEQ)/dt+(4/6)dy(1)/dt+(1/6)dy(2)/dt 14662 C = r4d*(y(NEQ)**2-y(2)**2)+eodsq*(y(2)-2*y(1)+y(NEQ)) 14663 C for i = 2,3,...,nm1, 14664 C (1/6)dy(i-1)/dt+(4/6)dy(i)/dt+(1/6)dy(i+1)/dt 14665 C = r4d*(y(i-1)**2-y(i+1)**2)+eodsq*(y(i+1)-2*y(i)+y(i-1)) 14666 C and finally 14667 C (1/6)dy(nm1)/dt+(4/6)dy(NEQ)/dt+(1/6)dy(1)/dt 14668 C = r4d*(y(nm1)**2-y(1)**2)+eodsq*(y(1)-2*y(NEQ)+y(nm1)) 14669 C where r4d = 1/(4*delx), eodsq = eta/delx**2 and nm1 = NEQ-1. 14670 C The following coding solves the problem with MF = 121, with output 14671 C of solution statistics at t = .1, .2, .3, and .4, and of the 14672 C solution vector at t = .4. Optional outputs (run statistics) are 14673 C also printed. 14674 C 14675 C EXTERNAL RESID, ADDASP, JACSP 14676 C DOUBLE PRECISION ATOL, RTOL, RW, T, TOUT, Y, YDOTI, R4D, EODSQ, DELX 14677 C DIMENSION Y(40), YDOTI(40), RW(1409), IW(30) 14678 C COMMON /TEST1/ R4D, EODSQ, NM1 14679 C DATA ITOL/1/, RTOL/1.0D-3/, ATOL/1.0D-3/, ITASK/1/, IOPT/0/ 14680 C DATA NEQ/40/, LRW/1409/, LIW/30/, MF/121/ 14681 C 14682 C DELX = 2.0/NEQ 14683 C R4D = 0.25/DELX 14684 C EODSQ = 0.05/DELX**2 14685 C NM1 = NEQ - 1 14686 C DO 10 I = 1,NEQ 14687 C 10 Y(I) = 0.0 14688 C Y(11) = 0.5 14689 C DO 15 I = 12,30 14690 C 15 Y(I) = 1.0 14691 C Y(31) = 0.5 14692 C T = 0.0 14693 C TOUT = 0.1 14694 C ISTATE = 0 14695 C DO 30 IO = 1,4 14696 C CALL DLSODIS (RESID, ADDASP, JACSP, NEQ, Y, YDOTI, T, TOUT, 14697 C 1 ITOL, RTOL, ATOL, ITASK, ISTATE, IOPT, RW, LRW, IW, LIW, MF) 14698 C WRITE(6,20) T,IW(11),RW(11) 14699 C 20 FORMAT(' At t =',F5.2,' No. steps =',I4, 14700 C 1 ' Last step =',D12.4) 14701 C IF (ISTATE .NE. 2) GO TO 90 14702 C TOUT = TOUT + 0.1 14703 C 30 CONTINUE 14704 C WRITE (6,40) (Y(I),I=1,NEQ) 14705 C 40 FORMAT(/' Final solution values..'/8(5D12.4/)) 14706 C WRITE(6,50) IW(17),IW(18),IW(11),IW(12),IW(13) 14707 C NNZLU = IW(25) + IW(26) + NEQ 14708 C WRITE(6,60) IW(19),NNZLU 14709 C 50 FORMAT(/' Required RW size =',I5,' IW size =',I4/ 14710 C 1 ' No. steps =',I4,' No. r-s =',I4,' No. J-s =',i4) 14711 C 60 FORMAT(' No. of nonzeros in P matrix =',I4, 14712 C 1 ' No. of nonzeros in LU =',I4) 14713 C STOP 14714 C 90 WRITE (6,95) ISTATE 14715 C 95 FORMAT(///' Error halt.. ISTATE =',I3) 14716 C STOP 14717 C END 14718 C 14719 C SUBROUTINE GFUN (N, T, Y, G) 14720 C DOUBLE PRECISION T, Y, G, R4D, EODSQ 14721 C DIMENSION G(N), Y(N) 14722 C COMMON /TEST1/ R4D, EODSQ, NM1 14723 C G(1) = R4D*(Y(N)**2-Y(2)**2) + EODSQ*(Y(2)-2.0*Y(1)+Y(N)) 14724 C DO 10 I = 2,NM1 14725 C G(I) = R4D*(Y(I-1)**2 - Y(I+1)**2) 14726 C 1 + EODSQ*(Y(I+1) - 2.0*Y(I) + Y(I-1)) 14727 C 10 CONTINUE 14728 C G(N) = R4D*(Y(NM1)**2-Y(1)**2) + EODSQ*(Y(1)-2.0*Y(N)+Y(NM1)) 14729 C RETURN 14730 C END 14731 C 14732 C SUBROUTINE RESID (N, T, Y, S, R, IRES) 14733 C DOUBLE PRECISION T, Y, S, R, R4D, EODSQ 14734 C DIMENSION Y(N), S(N), R(N) 14735 C COMMON /TEST1/ R4D, EODSQ, NM1 14736 C CALL GFUN (N, T, Y, R) 14737 C R(1) = R(1) - (S(N) + 4.0*S(1) + S(2))/6.0 14738 C DO 10 I = 2,NM1 14739 C 10 R(I) = R(I) - (S(I-1) + 4.0*S(I) + S(I+1))/6.0 14740 C R(N) = R(N) - (S(NM1) + 4.0*S(N) + S(1))/6.0 14741 C RETURN 14742 C END 14743 C 14744 C SUBROUTINE ADDASP (N, T, Y, J, IP, JP, P) 14745 C DOUBLE PRECISION T, Y, P 14746 C DIMENSION Y(N), IP(*), JP(*), P(N) 14747 C JM1 = J - 1 14748 C JP1 = J + 1 14749 C IF (J .EQ. N) JP1 = 1 14750 C IF (J .EQ. 1) JM1 = N 14751 C P(J) = P(J) + (2.0/3.0) 14752 C P(JP1) = P(JP1) + (1.0/6.0) 14753 C P(JM1) = P(JM1) + (1.0/6.0) 14754 C RETURN 14755 C END 14756 C 14757 C SUBROUTINE JACSP (N, T, Y, S, J, IP, JP, PDJ) 14758 C DOUBLE PRECISION T, Y, S, PDJ, R4D, EODSQ 14759 C DIMENSION Y(N), S(N), IP(*), JP(*), PDJ(N) 14760 C COMMON /TEST1/ R4D, EODSQ, NM1 14761 C JM1 = J - 1 14762 C JP1 = J + 1 14763 C IF (J .EQ. 1) JM1 = N 14764 C IF (J .EQ. N) JP1 = 1 14765 C PDJ(JM1) = -2.0*R4D*Y(J) + EODSQ 14766 C PDJ(J) = -2.0*EODSQ 14767 C PDJ(JP1) = 2.0*R4D*Y(J) + EODSQ 14768 C RETURN 14769 C END 14770 C 14771 C The output of this program (on a CDC-7600 in single precision) 14772 C is as follows: 14773 C 14774 C At t = 0.10 No. steps = 15 Last step = 1.6863e-02 14775 C At t = 0.20 No. steps = 19 Last step = 2.4101e-02 14776 C At t = 0.30 No. steps = 22 Last step = 4.3143e-02 14777 C At t = 0.40 No. steps = 24 Last step = 5.7819e-02 14778 C 14779 C Final solution values.. 14780 C 1.8371e-02 1.3578e-02 1.5864e-02 2.3805e-02 3.7245e-02 14781 C 5.6630e-02 8.2538e-02 1.1538e-01 1.5522e-01 2.0172e-01 14782 C 2.5414e-01 3.1150e-01 3.7259e-01 4.3608e-01 5.0060e-01 14783 C 5.6482e-01 6.2751e-01 6.8758e-01 7.4415e-01 7.9646e-01 14784 C 8.4363e-01 8.8462e-01 9.1853e-01 9.4500e-01 9.6433e-01 14785 C 9.7730e-01 9.8464e-01 9.8645e-01 9.8138e-01 9.6584e-01 14786 C 9.3336e-01 8.7497e-01 7.8213e-01 6.5315e-01 4.9997e-01 14787 C 3.4672e-01 2.1758e-01 1.2461e-01 6.6208e-02 3.3784e-02 14788 C 14789 C Required RW size = 1409 IW size = 30 14790 C No. steps = 24 No. r-s = 33 No. J-s = 8 14791 C No. of nonzeros in P matrix = 120 No. of nonzeros in LU = 194 14792 C 14793 C----------------------------------------------------------------------- 14794 C Full Description of User Interface to DLSODIS. 14795 C 14796 C The user interface to DLSODIS consists of the following parts. 14797 C 14798 C 1. The call sequence to Subroutine DLSODIS, which is a driver 14799 C routine for the solver. This includes descriptions of both 14800 C the call sequence arguments and of user-supplied routines. 14801 C Following these descriptions is a description of 14802 C optional inputs available through the call sequence, and then 14803 C a description of optional outputs (in the work arrays). 14804 C 14805 C 2. Descriptions of other routines in the DLSODIS package that may be 14806 C (optionally) called by the user. These provide the ability to 14807 C alter error message handling, save and restore the internal 14808 C Common, and obtain specified derivatives of the solution y(t). 14809 C 14810 C 3. Descriptions of Common blocks to be declared in overlay 14811 C or similar environments, or to be saved when doing an interrupt 14812 C of the problem and continued solution later. 14813 C 14814 C 4. Description of two routines in the DLSODIS package, either of 14815 C which the user may replace with his/her own version, if desired. 14816 C These relate to the measurement of errors. 14817 C 14818 C----------------------------------------------------------------------- 14819 C Part 1. Call Sequence. 14820 C 14821 C The call sequence parameters used for input only are 14822 C RES, ADDA, JAC, NEQ, TOUT, ITOL, RTOL, ATOL, ITASK, 14823 C IOPT, LRW, LIW, MF, 14824 C and those used for both input and output are 14825 C Y, T, ISTATE, YDOTI. 14826 C The work arrays RWORK and IWORK are also used for conditional and 14827 C optional inputs and optional outputs. (The term output here refers 14828 C to the return from Subroutine DLSODIS to the user's calling program.) 14829 C 14830 C The legality of input parameters will be thoroughly checked on the 14831 C initial call for the problem, but not checked thereafter unless a 14832 C change in input parameters is flagged by ISTATE = 3 on input. 14833 C 14834 C The descriptions of the call arguments are as follows. 14835 C 14836 C RES = the name of the user-supplied subroutine which supplies 14837 C the residual vector for the ODE system, defined by 14838 C r = g(t,y) - A(t,y) * s 14839 C as a function of the scalar t and the vectors 14840 C s and y (s approximates dy/dt). This subroutine 14841 C is to have the form 14842 C SUBROUTINE RES (NEQ, T, Y, S, R, IRES) 14843 C DOUBLE PRECISION T, Y(*), S(*), R(*) 14844 C where NEQ, T, Y, S, and IRES are input, and R and 14845 C IRES are output. Y, S, and R are arrays of length NEQ. 14846 C On input, IRES indicates how DLSODIS will use the 14847 C returned array R, as follows: 14848 C IRES = 1 means that DLSODIS needs the full residual, 14849 C r = g - A*s, exactly. 14850 C IRES = -1 means that DLSODIS is using R only to compute 14851 C the Jacobian dr/dy by difference quotients. 14852 C The RES routine can ignore IRES, or it can omit some terms 14853 C if IRES = -1. If A does not depend on y, then RES can 14854 C just return R = g when IRES = -1. If g - A*s contains other 14855 C additive terms that are independent of y, these can also be 14856 C dropped, if done consistently, when IRES = -1. 14857 C The subroutine should set the flag IRES if it 14858 C encounters a halt condition or illegal input. 14859 C Otherwise, it should not reset IRES. On output, 14860 C IRES = 1 or -1 represents a normal return, and 14861 C DLSODIS continues integrating the ODE. Leave IRES 14862 C unchanged from its input value. 14863 C IRES = 2 tells DLSODIS to immediately return control 14864 C to the calling program, with ISTATE = 3. This lets 14865 C the calling program change parameters of the problem 14866 C if necessary. 14867 C IRES = 3 represents an error condition (for example, an 14868 C illegal value of y). DLSODIS tries to integrate the system 14869 C without getting IRES = 3 from RES. If it cannot, DLSODIS 14870 C returns with ISTATE = -7 or -1. 14871 C On a return with ISTATE = 3, -1, or -7, the values 14872 C of T and Y returned correspond to the last point reached 14873 C successfully without getting the flag IRES = 2 or 3. 14874 C The flag values IRES = 2 and 3 should not be used to 14875 C handle switches or root-stop conditions. This is better 14876 C done by calling DLSODIS in a one-step mode and checking the 14877 C stopping function for a sign change at each step. 14878 C If quantities computed in the RES routine are needed 14879 C externally to DLSODIS, an extra call to RES should be made 14880 C for this purpose, for consistent and accurate results. 14881 C To get the current dy/dt for the S argument, use DINTDY. 14882 C RES must be declared External in the calling 14883 C program. See note below for more about RES. 14884 C 14885 C ADDA = the name of the user-supplied subroutine which adds the 14886 C matrix A = A(t,y) to another matrix stored in sparse form. 14887 C This subroutine is to have the form 14888 C SUBROUTINE ADDA (NEQ, T, Y, J, IAN, JAN, P) 14889 C DOUBLE PRECISION T, Y(*), P(*) 14890 C INTEGER IAN(*), JAN(*) 14891 C where NEQ, T, Y, J, IAN, JAN, and P are input. This routine 14892 C should add the J-th column of matrix A to the array P, of 14893 C length NEQ. Thus a(i,J) is to be added to P(i) for all 14894 C relevant values of i. Here T and Y have the same meaning as 14895 C in Subroutine RES, and J is a column index (1 to NEQ). 14896 C IAN and JAN are undefined in calls to ADDA for structure 14897 C determination (MOSS .ne. 0). Otherwise, IAN and JAN are 14898 C structure descriptors, as defined under optional outputs 14899 C below, and so can be used to determine the relevant row 14900 C indices i, if desired. 14901 C Calls to ADDA are made with J = 1,...,NEQ, in that 14902 C order. ADDA must not alter its input arguments. 14903 C ADDA must be declared External in the calling program. 14904 C See note below for more information about ADDA. 14905 C 14906 C JAC = the name of the user-supplied subroutine which supplies 14907 C the Jacobian matrix, dr/dy, where r = g - A*s. JAC is 14908 C required if MITER = 1, or MOSS = 1 or 3. Otherwise a dummy 14909 C name can be passed. This subroutine is to have the form 14910 C SUBROUTINE JAC (NEQ, T, Y, S, J, IAN, JAN, PDJ) 14911 C DOUBLE PRECISION T, Y(*), S(*), PDJ(*) 14912 C INTEGER IAN(*), JAN(*) 14913 C where NEQ, T, Y, S, J, IAN, and JAN are input. The 14914 C array PDJ, of length NEQ, is to be loaded with column J 14915 C of the Jacobian on output. Thus dr(i)/dy(J) is to be 14916 C loaded into PDJ(i) for all relevant values of i. 14917 C Here T, Y, and S have the same meaning as in Subroutine RES, 14918 C and J is a column index (1 to NEQ). IAN and JAN 14919 C are undefined in calls to JAC for structure determination 14920 C (MOSS .ne. 0). Otherwise, IAN and JAN are structure 14921 C descriptors, as defined under optional outputs below, and 14922 C so can be used to determine the relevant row indices i, if 14923 C desired. 14924 C JAC need not provide dr/dy exactly. A crude 14925 C approximation (possibly with greater sparsity) will do. 14926 C In any case, PDJ is preset to zero by the solver, 14927 C so that only the nonzero elements need be loaded by JAC. 14928 C Calls to JAC are made with J = 1,...,NEQ, in that order, and 14929 C each such set of calls is preceded by a call to RES with the 14930 C same arguments NEQ, T, Y, S, and IRES. Thus to gain some 14931 C efficiency intermediate quantities shared by both calculations 14932 C may be saved in a user Common block by RES and not recomputed 14933 C by JAC, if desired. JAC must not alter its input arguments. 14934 C JAC must be declared External in the calling program. 14935 C See note below for more about JAC. 14936 C 14937 C Note on RES, ADDA, and JAC: 14938 C These subroutines may access user-defined quantities in 14939 C NEQ(2),... and/or in Y(NEQ(1)+1),... if NEQ is an array 14940 C (dimensioned in the subroutines) and/or Y has length 14941 C exceeding NEQ(1). However, these subroutines should not 14942 C alter NEQ(1), Y(1),...,Y(NEQ) or any other input variables. 14943 C See the descriptions of NEQ and Y below. 14944 C 14945 C NEQ = the size of the system (number of first order ordinary 14946 C differential equations or scalar algebraic equations). 14947 C Used only for input. 14948 C NEQ may be decreased, but not increased, during the problem. 14949 C If NEQ is decreased (with ISTATE = 3 on input), the 14950 C remaining components of Y should be left undisturbed, if 14951 C these are to be accessed in RES, ADDA, or JAC. 14952 C 14953 C Normally, NEQ is a scalar, and it is generally referred to 14954 C as a scalar in this user interface description. However, 14955 C NEQ may be an array, with NEQ(1) set to the system size. 14956 C (The DLSODIS package accesses only NEQ(1).) In either case, 14957 C this parameter is passed as the NEQ argument in all calls 14958 C to RES, ADDA, and JAC. Hence, if it is an array, 14959 C locations NEQ(2),... may be used to store other integer data 14960 C and pass it to RES, ADDA, or JAC. Each such subroutine 14961 C must include NEQ in a Dimension statement in that case. 14962 C 14963 C Y = a real array for the vector of dependent variables, of 14964 C length NEQ or more. Used for both input and output on the 14965 C first call (ISTATE = 0 or 1), and only for output on other 14966 C calls. On the first call, Y must contain the vector of 14967 C initial values. On output, Y contains the computed solution 14968 C vector, evaluated at T. If desired, the Y array may be used 14969 C for other purposes between calls to the solver. 14970 C 14971 C This array is passed as the Y argument in all calls to RES, 14972 C ADDA, and JAC. Hence its length may exceed NEQ, 14973 C and locations Y(NEQ+1),... may be used to store other real 14974 C data and pass it to RES, ADDA, or JAC. (The DLSODIS 14975 C package accesses only Y(1),...,Y(NEQ). ) 14976 C 14977 C YDOTI = a real array for the initial value of the vector 14978 C dy/dt and for work space, of dimension at least NEQ. 14979 C 14980 C On input: 14981 C If ISTATE = 0 then DLSODIS will compute the initial value 14982 C of dy/dt, if A is nonsingular. Thus YDOTI will 14983 C serve only as work space and may have any value. 14984 C If ISTATE = 1 then YDOTI must contain the initial value 14985 C of dy/dt. 14986 C If ISTATE = 2 or 3 (continuation calls) then YDOTI 14987 C may have any value. 14988 C Note: If the initial value of A is singular, then 14989 C DLSODIS cannot compute the initial value of dy/dt, so 14990 C it must be provided in YDOTI, with ISTATE = 1. 14991 C 14992 C On output, when DLSODIS terminates abnormally with ISTATE = 14993 C -1, -4, or -5, YDOTI will contain the residual 14994 C r = g(t,y) - A(t,y)*(dy/dt). If r is large, t is near 14995 C its initial value, and YDOTI is supplied with ISTATE = 1, 14996 C there may have been an incorrect input value of 14997 C YDOTI = dy/dt, or the problem (as given to DLSODIS) 14998 C may not have a solution. 14999 C 15000 C If desired, the YDOTI array may be used for other 15001 C purposes between calls to the solver. 15002 C 15003 C T = the independent variable. On input, T is used only on the 15004 C first call, as the initial point of the integration. 15005 C On output, after each call, T is the value at which a 15006 C computed solution y is evaluated (usually the same as TOUT). 15007 C On an error return, T is the farthest point reached. 15008 C 15009 C TOUT = the next value of t at which a computed solution is desired. 15010 C Used only for input. 15011 C 15012 C When starting the problem (ISTATE = 0 or 1), TOUT may be 15013 C equal to T for one call, then should .ne. T for the next 15014 C call. For the initial T, an input value of TOUT .ne. T is 15015 C used in order to determine the direction of the integration 15016 C (i.e. the algebraic sign of the step sizes) and the rough 15017 C scale of the problem. Integration in either direction 15018 C (forward or backward in t) is permitted. 15019 C 15020 C If ITASK = 2 or 5 (one-step modes), TOUT is ignored after 15021 C the first call (i.e. the first call with TOUT .ne. T). 15022 C Otherwise, TOUT is required on every call. 15023 C 15024 C If ITASK = 1, 3, or 4, the values of TOUT need not be 15025 C monotone, but a value of TOUT which backs up is limited 15026 C to the current internal T interval, whose endpoints are 15027 C TCUR - HU and TCUR (see optional outputs, below, for 15028 C TCUR and HU). 15029 C 15030 C ITOL = an indicator for the type of error control. See 15031 C description below under ATOL. Used only for input. 15032 C 15033 C RTOL = a relative error tolerance parameter, either a scalar or 15034 C an array of length NEQ. See description below under ATOL. 15035 C Input only. 15036 C 15037 C ATOL = an absolute error tolerance parameter, either a scalar or 15038 C an array of length NEQ. Input only. 15039 C 15040 C The input parameters ITOL, RTOL, and ATOL determine 15041 C the error control performed by the solver. The solver will 15042 C control the vector E = (E(i)) of estimated local errors 15043 C in y, according to an inequality of the form 15044 C RMS-norm of ( E(i)/EWT(i) ) .le. 1, 15045 C where EWT(i) = RTOL(i)*ABS(Y(i)) + ATOL(i), 15046 C and the RMS-norm (root-mean-square norm) here is 15047 C RMS-norm(v) = SQRT(sum v(i)**2 / NEQ). Here EWT = (EWT(i)) 15048 C is a vector of weights which must always be positive, and 15049 C the values of RTOL and ATOL should all be non-negative. 15050 C The following table gives the types (scalar/array) of 15051 C RTOL and ATOL, and the corresponding form of EWT(i). 15052 C 15053 C ITOL RTOL ATOL EWT(i) 15054 C 1 scalar scalar RTOL*ABS(Y(i)) + ATOL 15055 C 2 scalar array RTOL*ABS(Y(i)) + ATOL(i) 15056 C 3 array scalar RTOL(i)*ABS(Y(i)) + ATOL 15057 C 4 array scalar RTOL(i)*ABS(Y(i)) + ATOL(i) 15058 C 15059 C When either of these parameters is a scalar, it need not 15060 C be dimensioned in the user's calling program. 15061 C 15062 C If none of the above choices (with ITOL, RTOL, and ATOL 15063 C fixed throughout the problem) is suitable, more general 15064 C error controls can be obtained by substituting 15065 C user-supplied routines for the setting of EWT and/or for 15066 C the norm calculation. See Part 4 below. 15067 C 15068 C If global errors are to be estimated by making a repeated 15069 C run on the same problem with smaller tolerances, then all 15070 C components of RTOL and ATOL (i.e. of EWT) should be scaled 15071 C down uniformly. 15072 C 15073 C ITASK = an index specifying the task to be performed. 15074 C Input only. ITASK has the following values and meanings. 15075 C 1 means normal computation of output values of y(t) at 15076 C t = TOUT (by overshooting and interpolating). 15077 C 2 means take one step only and return. 15078 C 3 means stop at the first internal mesh point at or 15079 C beyond t = TOUT and return. 15080 C 4 means normal computation of output values of y(t) at 15081 C t = TOUT but without overshooting t = TCRIT. 15082 C TCRIT must be input as RWORK(1). TCRIT may be equal to 15083 C or beyond TOUT, but not behind it in the direction of 15084 C integration. This option is useful if the problem 15085 C has a singularity at or beyond t = TCRIT. 15086 C 5 means take one step, without passing TCRIT, and return. 15087 C TCRIT must be input as RWORK(1). 15088 C 15089 C Note: If ITASK = 4 or 5 and the solver reaches TCRIT 15090 C (within roundoff), it will return T = TCRIT (exactly) to 15091 C indicate this (unless ITASK = 4 and TOUT comes before TCRIT, 15092 C in which case answers at t = TOUT are returned first). 15093 C 15094 C ISTATE = an index used for input and output to specify the 15095 C state of the calculation. 15096 C 15097 C On input, the values of ISTATE are as follows. 15098 C 0 means this is the first call for the problem, and 15099 C DLSODIS is to compute the initial value of dy/dt 15100 C (while doing other initializations). See note below. 15101 C 1 means this is the first call for the problem, and 15102 C the initial value of dy/dt has been supplied in 15103 C YDOTI (DLSODIS will do other initializations). 15104 C See note below. 15105 C 2 means this is not the first call, and the calculation 15106 C is to continue normally, with no change in any input 15107 C parameters except possibly TOUT and ITASK. 15108 C (If ITOL, RTOL, and/or ATOL are changed between calls 15109 C with ISTATE = 2, the new values will be used but not 15110 C tested for legality.) 15111 C 3 means this is not the first call, and the 15112 C calculation is to continue normally, but with 15113 C a change in input parameters other than 15114 C TOUT and ITASK. Changes are allowed in 15115 C NEQ, ITOL, RTOL, ATOL, IOPT, LRW, LIW, MF, 15116 C the conditional inputs IA, JA, IC, and JC, 15117 C and any of the optional inputs except H0. 15118 C A call with ISTATE = 3 will cause the sparsity 15119 C structure of the problem to be recomputed. 15120 C (Structure information is reread from IA and JA if 15121 C MOSS = 0, 3, or 4 and from IC and JC if MOSS = 0). 15122 C Note: A preliminary call with TOUT = T is not counted 15123 C as a first call here, as no initialization or checking of 15124 C input is done. (Such a call is sometimes useful for the 15125 C purpose of outputting the initial conditions.) 15126 C Thus the first call for which TOUT .ne. T requires 15127 C ISTATE = 0 or 1 on input. 15128 C 15129 C On output, ISTATE has the following values and meanings. 15130 C 0 or 1 means nothing was done; TOUT = T and 15131 C ISTATE = 0 or 1 on input. 15132 C 2 means that the integration was performed successfully. 15133 C 3 means that the user-supplied Subroutine RES signalled 15134 C DLSODIS to halt the integration and return (IRES = 2). 15135 C Integration as far as T was achieved with no occurrence 15136 C of IRES = 2, but this flag was set on attempting the 15137 C next step. 15138 C -1 means an excessive amount of work (more than MXSTEP 15139 C steps) was done on this call, before completing the 15140 C requested task, but the integration was otherwise 15141 C successful as far as T. (MXSTEP is an optional input 15142 C and is normally 500.) To continue, the user may 15143 C simply reset ISTATE to a value .gt. 1 and call again 15144 C (the excess work step counter will be reset to 0). 15145 C In addition, the user may increase MXSTEP to avoid 15146 C this error return (see below on optional inputs). 15147 C -2 means too much accuracy was requested for the precision 15148 C of the machine being used. This was detected before 15149 C completing the requested task, but the integration 15150 C was successful as far as T. To continue, the tolerance 15151 C parameters must be reset, and ISTATE must be set 15152 C to 3. The optional output TOLSF may be used for this 15153 C purpose. (Note: If this condition is detected before 15154 C taking any steps, then an illegal input return 15155 C (ISTATE = -3) occurs instead.) 15156 C -3 means illegal input was detected, before taking any 15157 C integration steps. See written message for details. 15158 C Note: If the solver detects an infinite loop of calls 15159 C to the solver with illegal input, it will cause 15160 C the run to stop. 15161 C -4 means there were repeated error test failures on 15162 C one attempted step, before completing the requested 15163 C task, but the integration was successful as far as T. 15164 C The problem may have a singularity, or the input 15165 C may be inappropriate. 15166 C -5 means there were repeated convergence test failures on 15167 C one attempted step, before completing the requested 15168 C task, but the integration was successful as far as T. 15169 C This may be caused by an inaccurate Jacobian matrix. 15170 C -6 means EWT(i) became zero for some i during the 15171 C integration. Pure relative error control (ATOL(i) = 0.0) 15172 C was requested on a variable which has now vanished. 15173 C the integration was successful as far as T. 15174 C -7 means that the user-supplied Subroutine RES set 15175 C its error flag (IRES = 3) despite repeated tries by 15176 C DLSODIS to avoid that condition. 15177 C -8 means that ISTATE was 0 on input but DLSODIS was unable 15178 C to compute the initial value of dy/dt. See the 15179 C printed message for details. 15180 C -9 means a fatal error return flag came from the sparse 15181 C solver CDRV by way of DPRJIS or DSOLSS (numerical 15182 C factorization or backsolve). This should never happen. 15183 C The integration was successful as far as T. 15184 C 15185 C Note: An error return with ISTATE = -1, -4, or -5 15186 C may mean that the sparsity structure of the 15187 C problem has changed significantly since it was last 15188 C determined (or input). In that case, one can attempt to 15189 C complete the integration by setting ISTATE = 3 on the next 15190 C call, so that a new structure determination is done. 15191 C 15192 C Note: Since the normal output value of ISTATE is 2, 15193 C it does not need to be reset for normal continuation. 15194 C similarly, ISTATE (= 3) need not be reset if RES told 15195 C DLSODIS to return because the calling program must change 15196 C the parameters of the problem. 15197 C Also, since a negative input value of ISTATE will be 15198 C regarded as illegal, a negative output value requires the 15199 C user to change it, and possibly other inputs, before 15200 C calling the solver again. 15201 C 15202 C IOPT = an integer flag to specify whether or not any optional 15203 C inputs are being used on this call. Input only. 15204 C The optional inputs are listed separately below. 15205 C IOPT = 0 means no optional inputs are being used. 15206 C Default values will be used in all cases. 15207 C IOPT = 1 means one or more optional inputs are being used. 15208 C 15209 C RWORK = a work array used for a mixture of real (double precision) 15210 C and integer work space. 15211 C The length of RWORK (in real words) must be at least 15212 C 20 + NYH*(MAXORD + 1) + 3*NEQ + LWM where 15213 C NYH = the initial value of NEQ, 15214 C MAXORD = 12 (if METH = 1) or 5 (if METH = 2) (unless a 15215 C smaller value is given as an optional input), 15216 C LWM = 2*NNZ + 2*NEQ + (NNZ+9*NEQ)/LENRAT if MITER = 1, 15217 C LWM = 2*NNZ + 2*NEQ + (NNZ+10*NEQ)/LENRAT if MITER = 2. 15218 C in the above formulas, 15219 C NNZ = number of nonzero elements in the iteration matrix 15220 C P = A - con*J (con is a constant and J is the 15221 C Jacobian matrix dr/dy). 15222 C LENRAT = the real to integer wordlength ratio (usually 1 in 15223 C single precision and 2 in double precision). 15224 C (See the MF description for METH and MITER.) 15225 C Thus if MAXORD has its default value and NEQ is constant, 15226 C the minimum length of RWORK is: 15227 C 20 + 16*NEQ + LWM for MF = 11, 111, 311, 12, 212, 412, 15228 C 20 + 9*NEQ + LWM for MF = 21, 121, 321, 22, 222, 422. 15229 C The above formula for LWM is only a crude lower bound. 15230 C The required length of RWORK cannot be readily predicted 15231 C in general, as it depends on the sparsity structure 15232 C of the problem. Some experimentation may be necessary. 15233 C 15234 C The first 20 words of RWORK are reserved for conditional 15235 C and optional inputs and optional outputs. 15236 C 15237 C The following word in RWORK is a conditional input: 15238 C RWORK(1) = TCRIT = critical value of t which the solver 15239 C is not to overshoot. Required if ITASK is 15240 C 4 or 5, and ignored otherwise. (See ITASK.) 15241 C 15242 C LRW = the length of the array RWORK, as declared by the user. 15243 C (This will be checked by the solver.) 15244 C 15245 C IWORK = an integer work array. The length of IWORK must be at least 15246 C 32 + 2*NEQ + NZA + NZC for MOSS = 0, 15247 C 30 for MOSS = 1 or 2, 15248 C 31 + NEQ + NZA for MOSS = 3 or 4. 15249 C (NZA is the number of nonzero elements in matrix A, and 15250 C NZC is the number of nonzero elements in dr/dy.) 15251 C 15252 C In DLSODIS, IWORK is used for conditional and 15253 C optional inputs and optional outputs. 15254 C 15255 C The following two blocks of words in IWORK are conditional 15256 C inputs, required if MOSS = 0, 3, or 4, but not otherwise 15257 C (see the description of MF for MOSS). 15258 C IWORK(30+j) = IA(j) (j=1,...,NEQ+1) 15259 C IWORK(31+NEQ+k) = JA(k) (k=1,...,NZA) 15260 C The two arrays IA and JA describe the sparsity structure 15261 C to be assumed for the matrix A. JA contains the row 15262 C indices where nonzero elements occur, reading in columnwise 15263 C order, and IA contains the starting locations in JA of the 15264 C descriptions of columns 1,...,NEQ, in that order, with 15265 C IA(1) = 1. Thus, for each column index j = 1,...,NEQ, the 15266 C values of the row index i in column j where a nonzero 15267 C element may occur are given by 15268 C i = JA(k), where IA(j) .le. k .lt. IA(j+1). 15269 C If NZA is the total number of nonzero locations assumed, 15270 C then the length of the JA array is NZA, and IA(NEQ+1) must 15271 C be NZA + 1. Duplicate entries are not allowed. 15272 C The following additional blocks of words are required 15273 C if MOSS = 0, but not otherwise. If LC = 31 + NEQ + NZA, then 15274 C IWORK(LC+j) = IC(j) (j=1,...,NEQ+1), and 15275 C IWORK(LC+NEQ+1+k) = JC(k) (k=1,...,NZC) 15276 C The two arrays IC and JC describe the sparsity 15277 C structure to be assumed for the Jacobian matrix dr/dy. 15278 C They are used in the same manner as the above IA and JA 15279 C arrays. If NZC is the number of nonzero locations 15280 C assumed, then the length of the JC array is NZC, and 15281 C IC(NEQ+1) must be NZC + 1. Duplicate entries are not 15282 C allowed. 15283 C 15284 C LIW = the length of the array IWORK, as declared by the user. 15285 C (This will be checked by the solver.) 15286 C 15287 C Note: The work arrays must not be altered between calls to DLSODIS 15288 C for the same problem, except possibly for the conditional and 15289 C optional inputs, and except for the last 3*NEQ words of RWORK. 15290 C The latter space is used for internal scratch space, and so is 15291 C available for use by the user outside DLSODIS between calls, if 15292 C desired (but not for use by RES, ADDA, or JAC). 15293 C 15294 C MF = the method flag. Used only for input. 15295 C MF has three decimal digits-- MOSS, METH, and MITER. 15296 C For standard options: 15297 C MF = 100*MOSS + 10*METH + MITER. 15298 C MOSS indicates the method to be used to obtain the sparsity 15299 C structure of the Jacobian matrix: 15300 C MOSS = 0 means the user has supplied IA, JA, IC, and JC 15301 C (see descriptions under IWORK above). 15302 C MOSS = 1 means the user has supplied JAC (see below) and 15303 C the structure will be obtained from NEQ initial 15304 C calls to JAC and NEQ initial calls to ADDA. 15305 C MOSS = 2 means the structure will be obtained from NEQ+1 15306 C initial calls to RES and NEQ initial calls to ADDA 15307 C MOSS = 3 like MOSS = 1, except user has supplied IA and JA. 15308 C MOSS = 4 like MOSS = 2, except user has supplied IA and JA. 15309 C METH indicates the basic linear multistep method: 15310 C METH = 1 means the implicit Adams method. 15311 C METH = 2 means the method based on Backward 15312 C Differentiation Formulas (BDFs). 15313 C The BDF method is strongly preferred for stiff problems, 15314 C while the Adams method is preferred when the problem is 15315 C not stiff. If the matrix A(t,y) is nonsingular, 15316 C stiffness here can be taken to mean that of the explicit 15317 C ODE system dy/dt = A-inverse * g. If A is singular, 15318 C the concept of stiffness is not well defined. 15319 C If you do not know whether the problem is stiff, we 15320 C recommend using METH = 2. If it is stiff, the advantage 15321 C of METH = 2 over METH = 1 will be great, while if it is 15322 C not stiff, the advantage of METH = 1 will be slight. 15323 C If maximum efficiency is important, some experimentation 15324 C with METH may be necessary. 15325 C MITER indicates the corrector iteration method: 15326 C MITER = 1 means chord iteration with a user-supplied 15327 C sparse Jacobian, given by Subroutine JAC. 15328 C MITER = 2 means chord iteration with an internally 15329 C generated (difference quotient) sparse 15330 C Jacobian (using NGP extra calls to RES per 15331 C dr/dy value, where NGP is an optional 15332 C output described below.) 15333 C If MITER = 1 or MOSS = 1 or 3 the user must supply a 15334 C Subroutine JAC (the name is arbitrary) as described above 15335 C under JAC. Otherwise, a dummy argument can be used. 15336 C 15337 C The standard choices for MF are: 15338 C MF = 21 or 22 for a stiff problem with IA/JA and IC/JC 15339 C supplied, 15340 C MF = 121 for a stiff problem with JAC supplied, but not 15341 C IA/JA or IC/JC, 15342 C MF = 222 for a stiff problem with neither IA/JA, IC/JC/, 15343 C nor JAC supplied, 15344 C MF = 321 for a stiff problem with IA/JA and JAC supplied, 15345 C but not IC/JC, 15346 C MF = 422 for a stiff problem with IA/JA supplied, but not 15347 C IC/JC or JAC. 15348 C 15349 C The sparseness structure can be changed during the problem 15350 C by making a call to DLSODIS with ISTATE = 3. 15351 C----------------------------------------------------------------------- 15352 C Optional Inputs. 15353 C 15354 C The following is a list of the optional inputs provided for in the 15355 C call sequence. (See also Part 2.) For each such input variable, 15356 C this table lists its name as used in this documentation, its 15357 C location in the call sequence, its meaning, and the default value. 15358 C The use of any of these inputs requires IOPT = 1, and in that 15359 C case all of these inputs are examined. A value of zero for any 15360 C of these optional inputs will cause the default value to be used. 15361 C Thus to use a subset of the optional inputs, simply preload 15362 C locations 5 to 10 in RWORK and IWORK to 0.0 and 0 respectively, and 15363 C then set those of interest to nonzero values. 15364 C 15365 C Name Location Meaning and Default Value 15366 C 15367 C H0 RWORK(5) the step size to be attempted on the first step. 15368 C The default value is determined by the solver. 15369 C 15370 C HMAX RWORK(6) the maximum absolute step size allowed. 15371 C The default value is infinite. 15372 C 15373 C HMIN RWORK(7) the minimum absolute step size allowed. 15374 C The default value is 0. (This lower bound is not 15375 C enforced on the final step before reaching TCRIT 15376 C when ITASK = 4 or 5.) 15377 C 15378 C MAXORD IWORK(5) the maximum order to be allowed. The default 15379 C value is 12 if METH = 1, and 5 if METH = 2. 15380 C If MAXORD exceeds the default value, it will 15381 C be reduced to the default value. 15382 C If MAXORD is changed during the problem, it may 15383 C cause the current order to be reduced. 15384 C 15385 C MXSTEP IWORK(6) maximum number of (internally defined) steps 15386 C allowed during one call to the solver. 15387 C The default value is 500. 15388 C 15389 C MXHNIL IWORK(7) maximum number of messages printed (per problem) 15390 C warning that T + H = T on a step (H = step size). 15391 C This must be positive to result in a non-default 15392 C value. The default value is 10. 15393 C----------------------------------------------------------------------- 15394 C Optional Outputs. 15395 C 15396 C As optional additional output from DLSODIS, the variables listed 15397 C below are quantities related to the performance of DLSODIS 15398 C which are available to the user. These are communicated by way of 15399 C the work arrays, but also have internal mnemonic names as shown. 15400 C Except where stated otherwise, all of these outputs are defined 15401 C on any successful return from DLSODIS, and on any return with 15402 C ISTATE = -1, -2, -4, -5, -6, or -7. On a return with -3 (illegal 15403 C input) or -8, they will be unchanged from their existing values 15404 C (if any), except possibly for TOLSF, LENRW, and LENIW. 15405 C On any error return, outputs relevant to the error will be defined, 15406 C as noted below. 15407 C 15408 C Name Location Meaning 15409 C 15410 C HU RWORK(11) the step size in t last used (successfully). 15411 C 15412 C HCUR RWORK(12) the step size to be attempted on the next step. 15413 C 15414 C TCUR RWORK(13) the current value of the independent variable 15415 C which the solver has actually reached, i.e. the 15416 C current internal mesh point in t. On output, TCUR 15417 C will always be at least as far as the argument 15418 C T, but may be farther (if interpolation was done). 15419 C 15420 C TOLSF RWORK(14) a tolerance scale factor, greater than 1.0, 15421 C computed when a request for too much accuracy was 15422 C detected (ISTATE = -3 if detected at the start of 15423 C the problem, ISTATE = -2 otherwise). If ITOL is 15424 C left unaltered but RTOL and ATOL are uniformly 15425 C scaled up by a factor of TOLSF for the next call, 15426 C then the solver is deemed likely to succeed. 15427 C (The user may also ignore TOLSF and alter the 15428 C tolerance parameters in any other way appropriate.) 15429 C 15430 C NST IWORK(11) the number of steps taken for the problem so far. 15431 C 15432 C NRE IWORK(12) the number of residual evaluations (RES calls) 15433 C for the problem so far, excluding those for 15434 C structure determination (MOSS = 2 or 4). 15435 C 15436 C NJE IWORK(13) the number of Jacobian evaluations (each involving 15437 C an evaluation of A and dr/dy) for the problem so 15438 C far, excluding those for structure determination 15439 C (MOSS = 1 or 3). This equals the number of calls 15440 C to ADDA and (if MITER = 1) JAC. 15441 C 15442 C NQU IWORK(14) the method order last used (successfully). 15443 C 15444 C NQCUR IWORK(15) the order to be attempted on the next step. 15445 C 15446 C IMXER IWORK(16) the index of the component of largest magnitude in 15447 C the weighted local error vector ( E(i)/EWT(i) ), 15448 C on an error return with ISTATE = -4 or -5. 15449 C 15450 C LENRW IWORK(17) the length of RWORK actually required. 15451 C This is defined on normal returns and on an illegal 15452 C input return for insufficient storage. 15453 C 15454 C LENIW IWORK(18) the length of IWORK actually required. 15455 C This is defined on normal returns and on an illegal 15456 C input return for insufficient storage. 15457 C 15458 C NNZ IWORK(19) the number of nonzero elements in the iteration 15459 C matrix P = A - con*J (con is a constant and 15460 C J is the Jacobian matrix dr/dy). 15461 C 15462 C NGP IWORK(20) the number of groups of column indices, used in 15463 C difference quotient Jacobian aproximations if 15464 C MITER = 2. This is also the number of extra RES 15465 C evaluations needed for each Jacobian evaluation. 15466 C 15467 C NLU IWORK(21) the number of sparse LU decompositions for the 15468 C problem so far. (Excludes the LU decomposition 15469 C necessary when ISTATE = 0.) 15470 C 15471 C LYH IWORK(22) the base address in RWORK of the history array YH, 15472 C described below in this list. 15473 C 15474 C IPIAN IWORK(23) the base address of the structure descriptor array 15475 C IAN, described below in this list. 15476 C 15477 C IPJAN IWORK(24) the base address of the structure descriptor array 15478 C JAN, described below in this list. 15479 C 15480 C NZL IWORK(25) the number of nonzero elements in the strict lower 15481 C triangle of the LU factorization used in the chord 15482 C iteration. 15483 C 15484 C NZU IWORK(26) the number of nonzero elements in the strict upper 15485 C triangle of the LU factorization used in the chord 15486 C iteration. The total number of nonzeros in the 15487 C factorization is therefore NZL + NZU + NEQ. 15488 C 15489 C The following four arrays are segments of the RWORK array which 15490 C may also be of interest to the user as optional outputs. 15491 C For each array, the table below gives its internal name, 15492 C its base address, and its description. 15493 C For YH and ACOR, the base addresses are in RWORK (a real array). 15494 C The integer arrays IAN and JAN are to be obtained by declaring an 15495 C integer array IWK and identifying IWK(1) with RWORK(21), using either 15496 C an equivalence statement or a subroutine call. Then the base 15497 C addresses IPIAN (of IAN) and IPJAN (of JAN) in IWK are to be obtained 15498 C as optional outputs IWORK(23) and IWORK(24), respectively. 15499 C Thus IAN(1) is IWK(ipian), etc. 15500 C 15501 C Name Base Address Description 15502 C 15503 C IAN IPIAN (in IWK) structure descriptor array of size NEQ + 1. 15504 C JAN IPJAN (in IWK) structure descriptor array of size NNZ. 15505 C (see above) IAN and JAN together describe the sparsity 15506 C structure of the iteration matrix 15507 C P = A - con*J, as used by DLSODIS. 15508 C JAN contains the row indices of the nonzero 15509 C locations, reading in columnwise order, and 15510 C IAN contains the starting locations in JAN of 15511 C the descriptions of columns 1,...,NEQ, in 15512 C that order, with IAN(1) = 1. Thus for each 15513 C j = 1,...,NEQ, the row indices i of the 15514 C nonzero locations in column j are 15515 C i = JAN(k), IAN(j) .le. k .lt. IAN(j+1). 15516 C Note that IAN(NEQ+1) = NNZ + 1. 15517 C YH LYH the Nordsieck history array, of size NYH by 15518 C (optional (NQCUR + 1), where NYH is the initial value 15519 C output) of NEQ. For j = 0,1,...,NQCUR, column j+1 15520 C of YH contains HCUR**j/factorial(j) times 15521 C the j-th derivative of the interpolating 15522 C polynomial currently representing the solution, 15523 C evaluated at t = TCUR. The base address LYH 15524 C is another optional output, listed above. 15525 C 15526 C ACOR LENRW-NEQ+1 array of size NEQ used for the accumulated 15527 C corrections on each step, scaled on output to 15528 C represent the estimated local error in y on the 15529 C last step. This is the vector E in the 15530 C description of the error control. It is defined 15531 C only on a return from DLSODIS with ISTATE = 2. 15532 C 15533 C----------------------------------------------------------------------- 15534 C Part 2. Other Routines Callable. 15535 C 15536 C The following are optional calls which the user may make to 15537 C gain additional capabilities in conjunction with DLSODIS. 15538 C (The routines XSETUN and XSETF are designed to conform to the 15539 C SLATEC error handling package.) 15540 C 15541 C Form of Call Function 15542 C CALL XSETUN(LUN) Set the logical unit number, LUN, for 15543 C output of messages from DLSODIS, if 15544 C The default is not desired. 15545 C The default value of LUN is 6. 15546 C 15547 C CALL XSETF(MFLAG) Set a flag to control the printing of 15548 C messages by DLSODIS. 15549 C MFLAG = 0 means do not print. (Danger: 15550 C This risks losing valuable information.) 15551 C MFLAG = 1 means print (the default). 15552 C 15553 C Either of the above calls may be made at 15554 C any time and will take effect immediately. 15555 C 15556 C CALL DSRCMS(RSAV,ISAV,JOB) saves and restores the contents of 15557 C the internal Common blocks used by 15558 C DLSODIS (see Part 3 below). 15559 C RSAV must be a real array of length 224 15560 C or more, and ISAV must be an integer 15561 C array of length 71 or more. 15562 C JOB=1 means save Common into RSAV/ISAV. 15563 C JOB=2 means restore Common from RSAV/ISAV. 15564 C DSRCMS is useful if one is 15565 C interrupting a run and restarting 15566 C later, or alternating between two or 15567 C more problems solved with DLSODIS. 15568 C 15569 C CALL DINTDY(,,,,,) Provide derivatives of y, of various 15570 C (see below) orders, at a specified point t, if 15571 C desired. It may be called only after 15572 C a successful return from DLSODIS. 15573 C 15574 C The detailed instructions for using DINTDY are as follows. 15575 C The form of the call is: 15576 C 15577 C LYH = IWORK(22) 15578 C CALL DINTDY (T, K, RWORK(LYH), NYH, DKY, IFLAG) 15579 C 15580 C The input parameters are: 15581 C 15582 C T = value of independent variable where answers are desired 15583 C (normally the same as the T last returned by DLSODIS). 15584 C For valid results, T must lie between TCUR - HU and TCUR. 15585 C (See optional outputs for TCUR and HU.) 15586 C K = integer order of the derivative desired. K must satisfy 15587 C 0 .le. K .le. NQCUR, where NQCUR is the current order 15588 C (see optional outputs). The capability corresponding 15589 C to K = 0, i.e. computing y(t), is already provided 15590 C by DLSODIS directly. Since NQCUR .ge. 1, the first 15591 C derivative dy/dt is always available with DINTDY. 15592 C LYH = the base address of the history array YH, obtained 15593 C as an optional output as shown above. 15594 C NYH = column length of YH, equal to the initial value of NEQ. 15595 C 15596 C The output parameters are: 15597 C 15598 C DKY = a real array of length NEQ containing the computed value 15599 C of the K-th derivative of y(t). 15600 C IFLAG = integer flag, returned as 0 if K and T were legal, 15601 C -1 if K was illegal, and -2 if T was illegal. 15602 C On an error return, a message is also written. 15603 C----------------------------------------------------------------------- 15604 C Part 3. Common Blocks. 15605 C 15606 C If DLSODIS is to be used in an overlay situation, the user 15607 C must declare, in the primary overlay, the variables in: 15608 C (1) the call sequence to DLSODIS, and 15609 C (2) the two internal Common blocks 15610 C /DLS001/ of length 255 (218 double precision words 15611 C followed by 37 integer words), 15612 C /DLSS01/ of length 40 (6 double precision words 15613 C followed by 34 integer words). 15614 C 15615 C If DLSODIS is used on a system in which the contents of internal 15616 C Common blocks are not preserved between calls, the user should 15617 C declare the above Common blocks in the calling program to insure 15618 C that their contents are preserved. 15619 C 15620 C If the solution of a given problem by DLSODIS is to be interrupted 15621 C and then later continued, such as when restarting an interrupted run 15622 C or alternating between two or more problems, the user should save, 15623 C following the return from the last DLSODIS call prior to the 15624 C interruption, the contents of the call sequence variables and the 15625 C internal Common blocks, and later restore these values before the 15626 C next DLSODIS call for that problem. To save and restore the Common 15627 C blocks, use Subroutines DSRCMS (see Part 2 above). 15628 C 15629 C----------------------------------------------------------------------- 15630 C Part 4. Optionally Replaceable Solver Routines. 15631 C 15632 C Below are descriptions of two routines in the DLSODIS package which 15633 C relate to the measurement of errors. Either routine can be 15634 C replaced by a user-supplied version, if desired. However, since such 15635 C a replacement may have a major impact on performance, it should be 15636 C done only when absolutely necessary, and only with great caution. 15637 C (Note: The means by which the package version of a routine is 15638 C superseded by the user's version may be system-dependent.) 15639 C 15640 C (a) DEWSET. 15641 C The following subroutine is called just before each internal 15642 C integration step, and sets the array of error weights, EWT, as 15643 C described under ITOL/RTOL/ATOL above: 15644 C SUBROUTINE DEWSET (NEQ, ITOL, RTOL, ATOL, YCUR, EWT) 15645 C where NEQ, ITOL, RTOL, and ATOL are as in the DLSODIS call sequence, 15646 C YCUR contains the current dependent variable vector, and 15647 C EWT is the array of weights set by DEWSET. 15648 C 15649 C If the user supplies this subroutine, it must return in EWT(i) 15650 C (i = 1,...,NEQ) a positive quantity suitable for comparing errors 15651 C in y(i) to. The EWT array returned by DEWSET is passed to the DVNORM 15652 C routine (see below), and also used by DLSODIS in the computation 15653 C of the optional output IMXER, and the increments for difference 15654 C quotient Jacobians. 15655 C 15656 C In the user-supplied version of DEWSET, it may be desirable to use 15657 C the current values of derivatives of y. Derivatives up to order NQ 15658 C are available from the history array YH, described above under 15659 C optional outputs. In DEWSET, YH is identical to the YCUR array, 15660 C extended to NQ + 1 columns with a column length of NYH and scale 15661 C factors of H**j/factorial(j). On the first call for the problem, 15662 C given by NST = 0, NQ is 1 and H is temporarily set to 1.0. 15663 C NYH is the initial value of NEQ. The quantities NQ, H, and NST 15664 C can be obtained by including in DEWSET the statements: 15665 C DOUBLE PRECISION RLS 15666 C COMMON /DLS001/ RLS(218),ILS(37) 15667 C NQ = ILS(33) 15668 C NST = ILS(34) 15669 C H = RLS(212) 15670 C Thus, for example, the current value of dy/dt can be obtained as 15671 C YCUR(NYH+i)/H (i=1,...,NEQ) (and the division by H is 15672 C unnecessary when NST = 0). 15673 C 15674 C (b) DVNORM. 15675 C The following is a real function routine which computes the weighted 15676 C root-mean-square norm of a vector v: 15677 C D = DVNORM (N, V, W) 15678 C where: 15679 C N = the length of the vector, 15680 C V = real array of length N containing the vector, 15681 C W = real array of length N containing weights, 15682 C D = SQRT( (1/N) * sum(V(i)*W(i))**2 ). 15683 C DVNORM is called with N = NEQ and with W(i) = 1.0/EWT(i), where 15684 C EWT is as set by Subroutine DEWSET. 15685 C 15686 C If the user supplies this function, it should return a non-negative 15687 C value of DVNORM suitable for use in the error control in DLSODIS. 15688 C None of the arguments should be altered by DVNORM. 15689 C For example, a user-supplied DVNORM routine might: 15690 C -substitute a max-norm of (V(i)*w(I)) for the RMS-norm, or 15691 C -ignore some components of V in the norm, with the effect of 15692 C suppressing the error control on those components of y. 15693 C----------------------------------------------------------------------- 15694 C 15695 C***REVISION HISTORY (YYYYMMDD) 15696 C 19820714 DATE WRITTEN 15697 C 19830812 Major update, based on recent LSODI and LSODES revisions: 15698 C Upgraded MDI in ODRV package: operates on M + M-transpose. 15699 C Numerous revisions in use of work arrays; 15700 C use wordlength ratio LENRAT; added IPISP & LRAT to Common; 15701 C added optional outputs IPIAN/IPJAN; 15702 C Added routine CNTNZU; added NZL and NZU to /LSS001/; 15703 C changed ADJLR call logic; added optional outputs NZL & NZU; 15704 C revised counter initializations; revised PREPI stmt. nos.; 15705 C revised difference quotient increment; 15706 C eliminated block /LSI001/, using IERPJ flag; 15707 C revised STODI logic after PJAC return; 15708 C revised tuning of H change and step attempts in STODI; 15709 C corrections to main prologue and comments throughout. 15710 C 19870320 Corrected jump on test of umax in CDRV routine. 15711 C 20010125 Numerous revisions: corrected comments throughout; 15712 C removed TRET from Common; rewrote EWSET with 4 loops; 15713 C fixed t test in INTDY; added Cray directives in STODI; 15714 C in STODI, fixed DELP init. and logic around PJAC call; 15715 C combined routines to save/restore Common; 15716 C passed LEVEL = 0 in error message calls (except run abort). 15717 C 20010425 Major update: convert source lines to upper case; 15718 C added *DECK lines; changed from 1 to * in dummy dimensions; 15719 C changed names R1MACH/D1MACH to RUMACH/DUMACH; 15720 C renamed routines for uniqueness across single/double prec.; 15721 C converted intrinsic names to generic form; 15722 C removed ILLIN and NTREP (data loaded) from Common; 15723 C removed all 'own' variables from Common; 15724 C changed error messages to quoted strings; 15725 C replaced XERRWV/XERRWD with 1993 revised version; 15726 C converted prologues, comments, error messages to mixed case; 15727 C converted arithmetic IF statements to logical IF statements; 15728 C numerous corrections to prologues and internal comments. 15729 C 20010507 Converted single precision source to double precision. 15730 C 20020502 Corrected declarations in descriptions of user routines. 15731 C 20031021 Fixed address offset bugs in Subroutine DPREPI. 15732 C 20031027 Changed 0. to 0.0D0 in Subroutine DPREPI. 15733 C 20031105 Restored 'own' variables to Common blocks, to enable 15734 C interrupt/restart feature. 15735 C 20031112 Added SAVE statements for data-loaded constants. 15736 C 20031117 Changed internal names NRE, LSAVR to NFE, LSAVF resp. 15737 C 15738 C----------------------------------------------------------------------- 15739 C Other routines in the DLSODIS package. 15740 C 15741 C In addition to Subroutine DLSODIS, the DLSODIS package includes the 15742 C following subroutines and function routines: 15743 C DIPREPI acts as an interface between DLSODIS and DPREPI, and also 15744 C does adjusting of work space pointers and work arrays. 15745 C DPREPI is called by DIPREPI to compute sparsity and do sparse 15746 C matrix preprocessing. 15747 C DAINVGS computes the initial value of the vector 15748 C dy/dt = A-inverse * g 15749 C ADJLR adjusts the length of required sparse matrix work space. 15750 C It is called by DPREPI. 15751 C CNTNZU is called by DPREPI and counts the nonzero elements in the 15752 C strict upper triangle of P + P-transpose. 15753 C JGROUP is called by DPREPI to compute groups of Jacobian column 15754 C indices for use when MITER = 2. 15755 C DINTDY computes an interpolated value of the y vector at t = TOUT. 15756 C DSTODI is the core integrator, which does one step of the 15757 C integration and the associated error control. 15758 C DCFODE sets all method coefficients and test constants. 15759 C DPRJIS computes and preprocesses the Jacobian matrix J = dr/dy 15760 C and the Newton iteration matrix P = A - h*l0*J. 15761 C DSOLSS manages solution of linear system in chord iteration. 15762 C DEWSET sets the error weight vector EWT before each step. 15763 C DVNORM computes the weighted RMS-norm of a vector. 15764 C DSRCMS is a user-callable routine to save and restore 15765 C the contents of the internal Common blocks. 15766 C ODRV constructs a reordering of the rows and columns of 15767 C a matrix by the minimum degree algorithm. ODRV is a 15768 C driver routine which calls Subroutines MD, MDI, MDM, 15769 C MDP, MDU, and SRO. See Ref. 2 for details. (The ODRV 15770 C module has been modified since Ref. 2, however.) 15771 C CDRV performs reordering, symbolic factorization, numerical 15772 C factorization, or linear system solution operations, 15773 C depending on a path argument IPATH. CDRV is a 15774 C driver routine which calls Subroutines NROC, NSFC, 15775 C NNFC, NNSC, and NNTC. See Ref. 3 for details. 15776 C DLSODIS uses CDRV to solve linear systems in which the 15777 C coefficient matrix is P = A - con*J, where A is the 15778 C matrix for the linear system A(t,y)*dy/dt = g(t,y), 15779 C con is a scalar, and J is an approximation to 15780 C the Jacobian dr/dy. Because CDRV deals with rowwise 15781 C sparsity descriptions, CDRV works with P-transpose, not P. 15782 C DLSODIS also uses CDRV to solve the linear system 15783 C A(t,y)*dy/dt = g(t,y) for dy/dt when ISTATE = 0. 15784 C (For this, CDRV works with A-transpose, not A.) 15785 C DUMACH computes the unit roundoff in a machine-independent manner. 15786 C XERRWD, XSETUN, XSETF, IXSAV, and IUMACH handle the printing of all 15787 C error messages and warnings. XERRWD is machine-dependent. 15788 C Note: DVNORM, DUMACH, IXSAV, and IUMACH are function routines. 15789 C All the others are subroutines. 15790 C 15791 C----------------------------------------------------------------------- 15792 EXTERNAL DPRJIS, DSOLSS 15793 DOUBLE PRECISION DUMACH, DVNORM 15794 INTEGER INIT, MXSTEP, MXHNIL, NHNIL, NSLAST, NYH, IOWNS, 15795 1 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 15796 2 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 15797 3 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU 15798 INTEGER IPLOST, IESP, ISTATC, IYS, IBA, IBIAN, IBJAN, IBJGP, 15799 1 IPIAN, IPJAN, IPJGP, IPIGP, IPR, IPC, IPIC, IPISP, IPRSP, IPA, 15800 2 LENYH, LENYHM, LENWK, LREQ, LRAT, LREST, LWMIN, MOSS, MSBJ, 15801 3 NSLJ, NGP, NLU, NNZ, NSP, NZL, NZU 15802 INTEGER I, I1, I2, IER, IGO, IFLAG, IMAX, IMUL, IMXER, IPFLAG, 15803 1 IPGO, IREM, IRES, J, KGO, LENRAT, LENYHT, LENIW, LENRW, 15804 2 LIA, LIC, LJA, LJC, LRTEM, LWTEM, LYD0, LYHD, LYHN, MF1, 15805 3 MORD, MXHNL0, MXSTP0, NCOLM 15806 DOUBLE PRECISION ROWNS, 15807 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND 15808 DOUBLE PRECISION CON0, CONMIN, CCMXJ, PSMALL, RBIG, SETH 15809 DOUBLE PRECISION ATOLI, AYI, BIG, EWTI, H0, HMAX, HMX, RH, RTOLI, 15810 1 TCRIT, TDIST, TNEXT, TOL, TOLSF, TP, SIZE, SUM, W0 15811 DIMENSION MORD(2) 15812 LOGICAL IHIT 15813 CHARACTER*60 MSG 15814 SAVE LENRAT, MORD, MXSTP0, MXHNL0 15815 C----------------------------------------------------------------------- 15816 C The following two internal Common blocks contain 15817 C (a) variables which are local to any subroutine but whose values must 15818 C be preserved between calls to the routine ("own" variables), and 15819 C (b) variables which are communicated between subroutines. 15820 C The block DLS001 is declared in subroutines DLSODIS, DIPREPI, DPREPI, 15821 C DINTDY, DSTODI, DPRJIS, and DSOLSS. 15822 C The block DLSS01 is declared in subroutines DLSODIS, DAINVGS, 15823 C DIPREPI, DPREPI, DPRJIS, and DSOLSS. 15824 C Groups of variables are replaced by dummy arrays in the Common 15825 C declarations in routines where those variables are not used. 15826 C----------------------------------------------------------------------- 15827 COMMON /DLS001/ ROWNS(209), 15828 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND, 15829 2 INIT, MXSTEP, MXHNIL, NHNIL, NSLAST, NYH, IOWNS(6), 15830 3 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 15831 4 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 15832 5 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU 15833 C 15834 COMMON /DLSS01/ CON0, CONMIN, CCMXJ, PSMALL, RBIG, SETH, 15835 1 IPLOST, IESP, ISTATC, IYS, IBA, IBIAN, IBJAN, IBJGP, 15836 2 IPIAN, IPJAN, IPJGP, IPIGP, IPR, IPC, IPIC, IPISP, IPRSP, IPA, 15837 3 LENYH, LENYHM, LENWK, LREQ, LRAT, LREST, LWMIN, MOSS, MSBJ, 15838 4 NSLJ, NGP, NLU, NNZ, NSP, NZL, NZU 15839 C 15840 DATA MORD(1),MORD(2)/12,5/, MXSTP0/500/, MXHNL0/10/ 15841 C----------------------------------------------------------------------- 15842 C In the Data statement below, set LENRAT equal to the ratio of 15843 C the wordlength for a real number to that for an integer. Usually, 15844 C LENRAT = 1 for single precision and 2 for double precision. If the 15845 C true ratio is not an integer, use the next smaller integer (.ge. 1), 15846 C----------------------------------------------------------------------- 15847 DATA LENRAT/2/ 15848 C----------------------------------------------------------------------- 15849 C Block A. 15850 C This code block is executed on every call. 15851 C It tests ISTATE and ITASK for legality and branches appropirately. 15852 C If ISTATE .gt. 1 but the flag INIT shows that initialization has 15853 C not yet been done, an error return occurs. 15854 C If ISTATE = 0 or 1 and TOUT = T, return immediately. 15855 C----------------------------------------------------------------------- 15856 IF (ISTATE .LT. 0 .OR. ISTATE .GT. 3) GO TO 601 15857 IF (ITASK .LT. 1 .OR. ITASK .GT. 5) GO TO 602 15858 IF (ISTATE .LE. 1) GO TO 10 15859 IF (INIT .EQ. 0) GO TO 603 15860 IF (ISTATE .EQ. 2) GO TO 200 15861 GO TO 20 15862 10 INIT = 0 15863 IF (TOUT .EQ. T) RETURN 15864 C----------------------------------------------------------------------- 15865 C Block B. 15866 C The next code block is executed for the initial call (ISTATE = 0 or 1) 15867 C or for a continuation call with parameter changes (ISTATE = 3). 15868 C It contains checking of all inputs and various initializations. 15869 C If ISTATE = 0 or 1, the final setting of work space pointers, the 15870 C matrix preprocessing, and other initializations are done in Block C. 15871 C 15872 C First check legality of the non-optional inputs NEQ, ITOL, IOPT, and 15873 C MF. 15874 C----------------------------------------------------------------------- 15875 20 IF (NEQ(1) .LE. 0) GO TO 604 15876 IF (ISTATE .LE. 1) GO TO 25 15877 IF (NEQ(1) .GT. N) GO TO 605 15878 25 N = NEQ(1) 15879 IF (ITOL .LT. 1 .OR. ITOL .GT. 4) GO TO 606 15880 IF (IOPT .LT. 0 .OR. IOPT .GT. 1) GO TO 607 15881 MOSS = MF/100 15882 MF1 = MF - 100*MOSS 15883 METH = MF1/10 15884 MITER = MF1 - 10*METH 15885 IF (MOSS .LT. 0 .OR. MOSS .GT. 4) GO TO 608 15886 IF (MITER .EQ. 2 .AND. MOSS .EQ. 1) MOSS = MOSS + 1 15887 IF (MITER .EQ. 2 .AND. MOSS .EQ. 3) MOSS = MOSS + 1 15888 IF (MITER .EQ. 1 .AND. MOSS .EQ. 2) MOSS = MOSS - 1 15889 IF (MITER .EQ. 1 .AND. MOSS .EQ. 4) MOSS = MOSS - 1 15890 IF (METH .LT. 1 .OR. METH .GT. 2) GO TO 608 15891 IF (MITER .LT. 1 .OR. MITER .GT. 2) GO TO 608 15892 C Next process and check the optional inputs. -------------------------- 15893 IF (IOPT .EQ. 1) GO TO 40 15894 MAXORD = MORD(METH) 15895 MXSTEP = MXSTP0 15896 MXHNIL = MXHNL0 15897 IF (ISTATE .LE. 1) H0 = 0.0D0 15898 HMXI = 0.0D0 15899 HMIN = 0.0D0 15900 GO TO 60 15901 40 MAXORD = IWORK(5) 15902 IF (MAXORD .LT. 0) GO TO 611 15903 IF (MAXORD .EQ. 0) MAXORD = 100 15904 MAXORD = MIN(MAXORD,MORD(METH)) 15905 MXSTEP = IWORK(6) 15906 IF (MXSTEP .LT. 0) GO TO 612 15907 IF (MXSTEP .EQ. 0) MXSTEP = MXSTP0 15908 MXHNIL = IWORK(7) 15909 IF (MXHNIL .LT. 0) GO TO 613 15910 IF (MXHNIL .EQ. 0) MXHNIL = MXHNL0 15911 IF (ISTATE .GT. 1) GO TO 50 15912 H0 = RWORK(5) 15913 IF ((TOUT - T)*H0 .LT. 0.0D0) GO TO 614 15914 50 HMAX = RWORK(6) 15915 IF (HMAX .LT. 0.0D0) GO TO 615 15916 HMXI = 0.0D0 15917 IF (HMAX .GT. 0.0D0) HMXI = 1.0D0/HMAX 15918 HMIN = RWORK(7) 15919 IF (HMIN .LT. 0.0D0) GO TO 616 15920 C Check RTOL and ATOL for legality. ------------------------------------ 15921 60 RTOLI = RTOL(1) 15922 ATOLI = ATOL(1) 15923 DO 65 I = 1,N 15924 IF (ITOL .GE. 3) RTOLI = RTOL(I) 15925 IF (ITOL .EQ. 2 .OR. ITOL .EQ. 4) ATOLI = ATOL(I) 15926 IF (RTOLI .LT. 0.0D0) GO TO 619 15927 IF (ATOLI .LT. 0.0D0) GO TO 620 15928 65 CONTINUE 15929 C----------------------------------------------------------------------- 15930 C Compute required work array lengths, as far as possible, and test 15931 C these against LRW and LIW. Then set tentative pointers for work 15932 C arrays. Pointers to RWORK/IWORK segments are named by prefixing L to 15933 C the name of the segment. E.g., the segment YH starts at RWORK(LYH). 15934 C Segments of RWORK (in order) are denoted WM, YH, SAVR, EWT, ACOR. 15935 C The required length of the matrix work space WM is not yet known, 15936 C and so a crude minimum value is used for the initial tests of LRW 15937 C and LIW, and YH is temporarily stored as far to the right in RWORK 15938 C as possible, to leave the maximum amount of space for WM for matrix 15939 C preprocessing. Thus if MOSS .ne. 2 or 4, some of the segments of 15940 C RWORK are temporarily omitted, as they are not needed in the 15941 C preprocessing. These omitted segments are: ACOR if ISTATE = 1, 15942 C EWT and ACOR if ISTATE = 3 and MOSS = 1, and SAVR, EWT, and ACOR if 15943 C ISTATE = 3 and MOSS = 0. 15944 C----------------------------------------------------------------------- 15945 LRAT = LENRAT 15946 IF (ISTATE .LE. 1) NYH = N 15947 IF (MITER .EQ. 1) LWMIN = 4*N + 10*N/LRAT 15948 IF (MITER .EQ. 2) LWMIN = 4*N + 11*N/LRAT 15949 LENYH = (MAXORD+1)*NYH 15950 LREST = LENYH + 3*N 15951 LENRW = 20 + LWMIN + LREST 15952 IWORK(17) = LENRW 15953 LENIW = 30 15954 IF (MOSS .NE. 1 .AND. MOSS .NE. 2) LENIW = LENIW + N + 1 15955 IWORK(18) = LENIW 15956 IF (LENRW .GT. LRW) GO TO 617 15957 IF (LENIW .GT. LIW) GO TO 618 15958 LIA = 31 15959 IF (MOSS .NE. 1 .AND. MOSS .NE. 2) 15960 1 LENIW = LENIW + IWORK(LIA+N) - 1 15961 IWORK(18) = LENIW 15962 IF (LENIW .GT. LIW) GO TO 618 15963 LJA = LIA + N + 1 15964 LIA = MIN(LIA,LIW) 15965 LJA = MIN(LJA,LIW) 15966 LIC = LENIW + 1 15967 IF (MOSS .EQ. 0) LENIW = LENIW + N + 1 15968 IWORK(18) = LENIW 15969 IF (LENIW .GT. LIW) GO TO 618 15970 IF (MOSS .EQ. 0) LENIW = LENIW + IWORK(LIC+N) - 1 15971 IWORK(18) = LENIW 15972 IF (LENIW .GT. LIW) GO TO 618 15973 LJC = LIC + N + 1 15974 LIC = MIN(LIC,LIW) 15975 LJC = MIN(LJC,LIW) 15976 LWM = 21 15977 IF (ISTATE .LE. 1) NQ = ISTATE 15978 NCOLM = MIN(NQ+1,MAXORD+2) 15979 LENYHM = NCOLM*NYH 15980 LENYHT = LENYHM 15981 IMUL = 2 15982 IF (ISTATE .EQ. 3) IMUL = MOSS 15983 IF (ISTATE .EQ. 3 .AND. MOSS .EQ. 3) IMUL = 1 15984 IF (MOSS .EQ. 2 .OR. MOSS .EQ. 4) IMUL = 3 15985 LRTEM = LENYHT + IMUL*N 15986 LWTEM = LRW - 20 - LRTEM 15987 LENWK = LWTEM 15988 LYHN = LWM + LWTEM 15989 LSAVF = LYHN + LENYHT 15990 LEWT = LSAVF + N 15991 LACOR = LEWT + N 15992 ISTATC = ISTATE 15993 IF (ISTATE .LE. 1) GO TO 100 15994 C----------------------------------------------------------------------- 15995 C ISTATE = 3. Move YH to its new location. 15996 C Note that only the part of YH needed for the next step, namely 15997 C MIN(NQ+1,MAXORD+2) columns, is actually moved. 15998 C A temporary error weight array EWT is loaded if MOSS = 2 or 4. 15999 C Sparse matrix processing is done in DIPREPI/DPREPI. 16000 C If MAXORD was reduced below NQ, then the pointers are finally set 16001 C so that SAVR is identical to (YH*,MAXORD+2) 16002 C----------------------------------------------------------------------- 16003 LYHD = LYH - LYHN 16004 IMAX = LYHN - 1 + LENYHM 16005 C Move YH. Move right if LYHD < 0; move left if LYHD > 0. ------------- 16006 IF (LYHD .LT. 0) THEN 16007 DO 72 I = LYHN,IMAX 16008 J = IMAX + LYHN - I 16009 72 RWORK(J) = RWORK(J+LYHD) 16010 ENDIF 16011 IF (LYHD .GT. 0) THEN 16012 DO 76 I = LYHN,IMAX 16013 76 RWORK(I) = RWORK(I+LYHD) 16014 ENDIF 16015 80 LYH = LYHN 16016 IWORK(22) = LYH 16017 IF (MOSS .NE. 2 .AND. MOSS .NE. 4) GO TO 85 16018 C Temporarily load EWT if MOSS = 2 or 4. 16019 CALL DEWSET (N,ITOL,RTOL,ATOL,RWORK(LYH),RWORK(LEWT)) 16020 DO 82 I = 1,N 16021 IF (RWORK(I+LEWT-1) .LE. 0.0D0) GO TO 621 16022 82 RWORK(I+LEWT-1) = 1.0D0/RWORK(I+LEWT-1) 16023 85 CONTINUE 16024 C DIPREPI and DPREPI do sparse matrix preprocessing. ------------------- 16025 LSAVF = MIN(LSAVF,LRW) 16026 LEWT = MIN(LEWT,LRW) 16027 LACOR = MIN(LACOR,LRW) 16028 CALL DIPREPI (NEQ, Y, YDOTI, RWORK, IWORK(LIA), IWORK(LJA), 16029 1 IWORK(LIC), IWORK(LJC), IPFLAG, RES, JAC, ADDA) 16030 LENRW = LWM - 1 + LENWK + LREST 16031 IWORK(17) = LENRW 16032 IF (IPFLAG .NE. -1) IWORK(23) = IPIAN 16033 IF (IPFLAG .NE. -1) IWORK(24) = IPJAN 16034 IPGO = -IPFLAG + 1 16035 GO TO (90, 628, 629, 630, 631, 632, 633, 634, 634), IPGO 16036 90 IWORK(22) = LYH 16037 LYD0 = LYH + N 16038 IF (LENRW .GT. LRW) GO TO 617 16039 C Set flag to signal changes to DSTODI.--------------------------------- 16040 JSTART = -1 16041 IF (NQ .LE. MAXORD) GO TO 94 16042 C MAXORD was reduced below NQ. Copy YH(*,MAXORD+2) into YDOTI. -------- 16043 DO 92 I = 1,N 16044 92 YDOTI(I) = RWORK(I+LSAVF-1) 16045 94 IF (N .EQ. NYH) GO TO 200 16046 C NEQ was reduced. Zero part of YH to avoid undefined references. ----- 16047 I1 = LYH + L*NYH 16048 I2 = LYH + (MAXORD + 1)*NYH - 1 16049 IF (I1 .GT. I2) GO TO 200 16050 DO 95 I = I1,I2 16051 95 RWORK(I) = 0.0D0 16052 GO TO 200 16053 C----------------------------------------------------------------------- 16054 C Block C. 16055 C The next block is for the initial call only (ISTATE = 0 or 1). 16056 C It contains all remaining initializations, the call to DAINVGS 16057 C (if ISTATE = 0), the sparse matrix preprocessing, and the 16058 C calculation if the initial step size. 16059 C The error weights in EWT are inverted after being loaded. 16060 C----------------------------------------------------------------------- 16061 100 CONTINUE 16062 LYH = LYHN 16063 IWORK(22) = LYH 16064 TN = T 16065 NST = 0 16066 NFE = 0 16067 H = 1.0D0 16068 NNZ = 0 16069 NGP = 0 16070 NZL = 0 16071 NZU = 0 16072 C Load the initial value vector in YH.---------------------------------- 16073 DO 105 I = 1,N 16074 105 RWORK(I+LYH-1) = Y(I) 16075 IF (ISTATE .NE. 1) GO TO 108 16076 C Initial dy/dt was supplied. Load it into YH (LYD0 points to YH(*,2).) 16077 LYD0 = LYH + NYH 16078 DO 106 I = 1,N 16079 106 RWORK(I+LYD0-1) = YDOTI(I) 16080 108 CONTINUE 16081 C Load and invert the EWT array. (H is temporarily set to 1.0.)-------- 16082 CALL DEWSET (N,ITOL,RTOL,ATOL,RWORK(LYH),RWORK(LEWT)) 16083 DO 110 I = 1,N 16084 IF (RWORK(I+LEWT-1) .LE. 0.0D0) GO TO 621 16085 110 RWORK(I+LEWT-1) = 1.0D0/RWORK(I+LEWT-1) 16086 C Call DIPREPI and DPREPI to do sparse matrix preprocessing.------------ 16087 LACOR = MIN(LACOR,LRW) 16088 CALL DIPREPI (NEQ, Y, YDOTI, RWORK, IWORK(LIA), IWORK(LJA), 16089 1 IWORK(LIC), IWORK(LJC), IPFLAG, RES, JAC, ADDA) 16090 LENRW = LWM - 1 + LENWK + LREST 16091 IWORK(17) = LENRW 16092 IF (IPFLAG .NE. -1) IWORK(23) = IPIAN 16093 IF (IPFLAG .NE. -1) IWORK(24) = IPJAN 16094 IPGO = -IPFLAG + 1 16095 GO TO (115, 628, 629, 630, 631, 632, 633, 634, 634), IPGO 16096 115 IWORK(22) = LYH 16097 IF (LENRW .GT. LRW) GO TO 617 16098 C Compute initial dy/dt, if necessary, and load it into YH.------------- 16099 LYD0 = LYH + N 16100 IF (ISTATE .NE. 0) GO TO 120 16101 CALL DAINVGS (NEQ, T, Y, RWORK(LWM), RWORK(LWM), RWORK(LACOR), 16102 1 RWORK(LYD0), IER, RES, ADDA) 16103 NFE = NFE + 1 16104 IGO = IER + 1 16105 GO TO (120, 565, 560, 560), IGO 16106 C Check TCRIT for legality (ITASK = 4 or 5). --------------------------- 16107 120 CONTINUE 16108 IF (ITASK .NE. 4 .AND. ITASK .NE. 5) GO TO 125 16109 TCRIT = RWORK(1) 16110 IF ((TCRIT - TOUT)*(TOUT - T) .LT. 0.0D0) GO TO 625 16111 IF (H0 .NE. 0.0D0 .AND. (T + H0 - TCRIT)*H0 .GT. 0.0D0) 16112 1 H0 = TCRIT - T 16113 C Initialize all remaining parameters. --------------------------------- 16114 125 UROUND = DUMACH() 16115 JSTART = 0 16116 RWORK(LWM) = SQRT(UROUND) 16117 NHNIL = 0 16118 NJE = 0 16119 NLU = 0 16120 NSLAST = 0 16121 HU = 0.0D0 16122 NQU = 0 16123 CCMAX = 0.3D0 16124 MAXCOR = 3 16125 MSBP = 20 16126 MXNCF = 10 16127 C----------------------------------------------------------------------- 16128 C The coding below computes the step size, H0, to be attempted on the 16129 C first step, unless the user has supplied a value for this. 16130 C First check that TOUT - T differs significantly from zero. 16131 C A scalar tolerance quantity TOL is computed, as MAX(RTOL(i)) 16132 C if this is positive, or MAX(ATOL(i)/ABS(Y(i))) otherwise, adjusted 16133 C so as to be between 100*UROUND and 1.0E-3. 16134 C Then the computed value H0 is given by.. 16135 C NEQ 16136 C H0**2 = TOL / ( w0**-2 + (1/NEQ) * Sum ( YDOT(i)/ywt(i) )**2 ) 16137 C 1 16138 C where w0 = MAX ( ABS(T), ABS(TOUT) ), 16139 C YDOT(i) = i-th component of initial value of dy/dt, 16140 C ywt(i) = EWT(i)/TOL (a weight for y(i)). 16141 C The sign of H0 is inferred from the initial values of TOUT and T. 16142 C----------------------------------------------------------------------- 16143 IF (H0 .NE. 0.0D0) GO TO 180 16144 TDIST = ABS(TOUT - T) 16145 W0 = MAX(ABS(T),ABS(TOUT)) 16146 IF (TDIST .LT. 2.0D0*UROUND*W0) GO TO 622 16147 TOL = RTOL(1) 16148 IF (ITOL .LE. 2) GO TO 145 16149 DO 140 I = 1,N 16150 140 TOL = MAX(TOL,RTOL(I)) 16151 145 IF (TOL .GT. 0.0D0) GO TO 160 16152 ATOLI = ATOL(1) 16153 DO 150 I = 1,N 16154 IF (ITOL .EQ. 2 .OR. ITOL .EQ. 4) ATOLI = ATOL(I) 16155 AYI = ABS(Y(I)) 16156 IF (AYI .NE. 0.0D0) TOL = MAX(TOL,ATOLI/AYI) 16157 150 CONTINUE 16158 160 TOL = MAX(TOL,100.0D0*UROUND) 16159 TOL = MIN(TOL,0.001D0) 16160 SUM = DVNORM (N, RWORK(LYD0), RWORK(LEWT)) 16161 SUM = 1.0D0/(TOL*W0*W0) + TOL*SUM**2 16162 H0 = 1.0D0/SQRT(SUM) 16163 H0 = MIN(H0,TDIST) 16164 H0 = SIGN(H0,TOUT-T) 16165 C Adjust H0 if necessary to meet HMAX bound. --------------------------- 16166 180 RH = ABS(H0)*HMXI 16167 IF (RH .GT. 1.0D0) H0 = H0/RH 16168 C Load H with H0 and scale YH(*,2) by H0. ------------------------------ 16169 H = H0 16170 DO 190 I = 1,N 16171 190 RWORK(I+LYD0-1) = H0*RWORK(I+LYD0-1) 16172 GO TO 270 16173 C----------------------------------------------------------------------- 16174 C Block D. 16175 C The next code block is for continuation calls only (ISTATE = 2 or 3) 16176 C and is to check stop conditions before taking a step. 16177 C----------------------------------------------------------------------- 16178 200 NSLAST = NST 16179 GO TO (210, 250, 220, 230, 240), ITASK 16180 210 IF ((TN - TOUT)*H .LT. 0.0D0) GO TO 250 16181 CALL DINTDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) 16182 IF (IFLAG .NE. 0) GO TO 627 16183 T = TOUT 16184 GO TO 420 16185 220 TP = TN - HU*(1.0D0 + 100.0D0*UROUND) 16186 IF ((TP - TOUT)*H .GT. 0.0D0) GO TO 623 16187 IF ((TN - TOUT)*H .LT. 0.0D0) GO TO 250 16188 GO TO 400 16189 230 TCRIT = RWORK(1) 16190 IF ((TN - TCRIT)*H .GT. 0.0D0) GO TO 624 16191 IF ((TCRIT - TOUT)*H .LT. 0.0D0) GO TO 625 16192 IF ((TN - TOUT)*H .LT. 0.0D0) GO TO 245 16193 CALL DINTDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) 16194 IF (IFLAG .NE. 0) GO TO 627 16195 T = TOUT 16196 GO TO 420 16197 240 TCRIT = RWORK(1) 16198 IF ((TN - TCRIT)*H .GT. 0.0D0) GO TO 624 16199 245 HMX = ABS(TN) + ABS(H) 16200 IHIT = ABS(TN - TCRIT) .LE. 100.0D0*UROUND*HMX 16201 IF (IHIT) GO TO 400 16202 TNEXT = TN + H*(1.0D0 + 4.0D0*UROUND) 16203 IF ((TNEXT - TCRIT)*H .LE. 0.0D0) GO TO 250 16204 H = (TCRIT - TN)*(1.0D0 - 4.0D0*UROUND) 16205 IF (ISTATE .EQ. 2) JSTART = -2 16206 C----------------------------------------------------------------------- 16207 C Block E. 16208 C The next block is normally executed for all calls and contains 16209 C the call to the one-step core integrator DSTODI. 16210 C 16211 C This is a looping point for the integration steps. 16212 C 16213 C First check for too many steps being taken, update EWT (if not at 16214 C start of problem), check for too much accuracy being requested, and 16215 C check for H below the roundoff level in T. 16216 C----------------------------------------------------------------------- 16217 250 CONTINUE 16218 IF ((NST-NSLAST) .GE. MXSTEP) GO TO 500 16219 CALL DEWSET (N, ITOL, RTOL, ATOL, RWORK(LYH), RWORK(LEWT)) 16220 DO 260 I = 1,N 16221 IF (RWORK(I+LEWT-1) .LE. 0.0D0) GO TO 510 16222 260 RWORK(I+LEWT-1) = 1.0D0/RWORK(I+LEWT-1) 16223 270 TOLSF = UROUND*DVNORM (N, RWORK(LYH), RWORK(LEWT)) 16224 IF (TOLSF .LE. 1.0D0) GO TO 280 16225 TOLSF = TOLSF*2.0D0 16226 IF (NST .EQ. 0) GO TO 626 16227 GO TO 520 16228 280 IF ((TN + H) .NE. TN) GO TO 290 16229 NHNIL = NHNIL + 1 16230 IF (NHNIL .GT. MXHNIL) GO TO 290 16231 MSG = 'DLSODIS- Warning..Internal T (=R1) and H (=R2) are' 16232 CALL XERRWD (MSG, 50, 101, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 16233 MSG=' such that in the machine, T + H = T on the next step ' 16234 CALL XERRWD (MSG, 60, 101, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 16235 MSG = ' (H = step size). Solver will continue anyway.' 16236 CALL XERRWD (MSG, 50, 101, 0, 0, 0, 0, 2, TN, H) 16237 IF (NHNIL .LT. MXHNIL) GO TO 290 16238 MSG = 'DLSODIS- Above warning has been issued I1 times. ' 16239 CALL XERRWD (MSG, 50, 102, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 16240 MSG = ' It will not be issued again for this problem.' 16241 CALL XERRWD (MSG, 50, 102, 0, 1, MXHNIL, 0, 0, 0.0D0, 0.0D0) 16242 290 CONTINUE 16243 C----------------------------------------------------------------------- 16244 C CALL DSTODI(NEQ,Y,YH,NYH,YH1,EWT,SAVF,SAVR,ACOR,WM,WM,RES, 16245 C ADDA,JAC,DPRJIS,DSOLSS) 16246 C Note: SAVF in DSTODI occupies the same space as YDOTI in DLSODIS. 16247 C----------------------------------------------------------------------- 16248 CALL DSTODI (NEQ, Y, RWORK(LYH), NYH, RWORK(LYH), RWORK(LEWT), 16249 1 YDOTI, RWORK(LSAVF), RWORK(LACOR), RWORK(LWM), 16250 2 RWORK(LWM), RES, ADDA, JAC, DPRJIS, DSOLSS ) 16251 KGO = 1 - KFLAG 16252 GO TO (300, 530, 540, 400, 550, 555), KGO 16253 C 16254 C KGO = 1:success; 2:error test failure; 3:convergence failure; 16255 C 4:RES ordered return; 5:RES returned error; 16256 C 6:fatal error from CDRV via DPRJIS or DSOLSS. 16257 C----------------------------------------------------------------------- 16258 C Block F. 16259 C The following block handles the case of a successful return from the 16260 C core integrator (KFLAG = 0). Test for stop conditions. 16261 C----------------------------------------------------------------------- 16262 300 INIT = 1 16263 GO TO (310, 400, 330, 340, 350), ITASK 16264 C ITASK = 1. If TOUT has been reached, interpolate. ------------------- 16265 310 iF ((TN - TOUT)*H .LT. 0.0D0) GO TO 250 16266 CALL DINTDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) 16267 T = TOUT 16268 GO TO 420 16269 C ITASK = 3. Jump to exit if TOUT was reached. ------------------------ 16270 330 IF ((TN - TOUT)*H .GE. 0.0D0) GO TO 400 16271 GO TO 250 16272 C ITASK = 4. See if TOUT or TCRIT was reached. Adjust H if necessary. 16273 340 IF ((TN - TOUT)*H .LT. 0.0D0) GO TO 345 16274 CALL DINTDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) 16275 T = TOUT 16276 GO TO 420 16277 345 HMX = ABS(TN) + ABS(H) 16278 IHIT = ABS(TN - TCRIT) .LE. 100.0D0*UROUND*HMX 16279 IF (IHIT) GO TO 400 16280 TNEXT = TN + H*(1.0D0 + 4.0D0*UROUND) 16281 IF ((TNEXT - TCRIT)*H .LE. 0.0D0) GO TO 250 16282 H = (TCRIT - TN)*(1.0D0 - 4.0D0*UROUND) 16283 JSTART = -2 16284 GO TO 250 16285 C ITASK = 5. See if TCRIT was reached and jump to exit. --------------- 16286 350 HMX = ABS(TN) + ABS(H) 16287 IHIT = ABS(TN - TCRIT) .LE. 100.0D0*UROUND*HMX 16288 C----------------------------------------------------------------------- 16289 C Block G. 16290 C The following block handles all successful returns from DLSODIS. 16291 C if ITASK .ne. 1, Y is loaded from YH and T is set accordingly. 16292 C ISTATE is set to 2, and the optional outputs are loaded into the 16293 C work arrays before returning. 16294 C----------------------------------------------------------------------- 16295 400 DO 410 I = 1,N 16296 410 Y(I) = RWORK(I+LYH-1) 16297 T = TN 16298 IF (ITASK .NE. 4 .AND. ITASK .NE. 5) GO TO 420 16299 IF (IHIT) T = TCRIT 16300 420 ISTATE = 2 16301 IF ( KFLAG .EQ. -3 ) ISTATE = 3 16302 RWORK(11) = HU 16303 RWORK(12) = H 16304 RWORK(13) = TN 16305 IWORK(11) = NST 16306 IWORK(12) = NFE 16307 IWORK(13) = NJE 16308 IWORK(14) = NQU 16309 IWORK(15) = NQ 16310 IWORK(19) = NNZ 16311 IWORK(20) = NGP 16312 IWORK(21) = NLU 16313 IWORK(25) = NZL 16314 IWORK(26) = NZU 16315 RETURN 16316 C----------------------------------------------------------------------- 16317 C Block H. 16318 C The following block handles all unsuccessful returns other than 16319 C those for illegal input. First the error message routine is called. 16320 C If there was an error test or convergence test failure, IMXER is set. 16321 C Then Y is loaded from YH and T is set to TN. 16322 C The optional outputs are loaded into the work arrays before returning. 16323 C----------------------------------------------------------------------- 16324 C The maximum number of steps was taken before reaching TOUT. ---------- 16325 500 MSG = 'DLSODIS- At current T (=R1), MXSTEP (=I1) steps ' 16326 CALL XERRWD (MSG, 50, 201, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 16327 MSG = ' taken on this call before reaching TOUT ' 16328 CALL XERRWD (MSG, 50, 201, 0, 1, MXSTEP, 0, 1, TN, 0.0D0) 16329 ISTATE = -1 16330 GO TO 580 16331 C EWT(i) .le. 0.0 for some i (not at start of problem). ---------------- 16332 510 EWTI = RWORK(LEWT+I-1) 16333 MSG = 'DLSODIS- At T (=R1), EWT(I1) has become R2 .le. 0.' 16334 CALL XERRWD (MSG, 50, 202, 0, 1, I, 0, 2, TN, EWTI) 16335 ISTATE = -6 16336 GO TO 590 16337 C Too much accuracy requested for machine precision. ------------------- 16338 520 MSG = 'DLSODIS- At T (=R1), too much accuracy requested ' 16339 CALL XERRWD (MSG, 50, 203, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 16340 MSG = ' for precision of machine.. See TOLSF (=R2) ' 16341 CALL XERRWD (MSG, 50, 203, 0, 0, 0, 0, 2, TN, TOLSF) 16342 RWORK(14) = TOLSF 16343 ISTATE = -2 16344 GO TO 590 16345 C KFLAG = -1. Error test failed repeatedly or with ABS(H) = HMIN. ----- 16346 530 MSG = 'DLSODIS- At T (=R1) and step size H (=R2), the ' 16347 CALL XERRWD (MSG, 50, 204, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 16348 MSG=' error test failed repeatedly or with ABS(H) = HMIN ' 16349 CALL XERRWD (MSG, 60, 204, 0, 0, 0, 0, 2, TN, H) 16350 ISTATE = -4 16351 GO TO 570 16352 C KFLAG = -2. Convergence failed repeatedly or with ABS(H) = HMIN. ---- 16353 540 MSG = 'DLSODIS- At T (=R1) and step size H (=R2), the ' 16354 CALL XERRWD (MSG, 50, 205, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 16355 MSG = ' corrector convergence failed repeatedly ' 16356 CALL XERRWD (MSG, 50, 205, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 16357 MSG = ' or with ABS(H) = HMIN ' 16358 CALL XERRWD (MSG, 30, 205, 0, 0, 0, 0, 2, TN, H) 16359 ISTATE = -5 16360 GO TO 570 16361 C IRES = 3 returned by RES, despite retries by DSTODI. ----------------- 16362 550 MSG = 'DLSODIS- At T (=R1) residual routine returned ' 16363 CALL XERRWD (MSG, 50, 206, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 16364 MSG = ' error IRES = 3 repeatedly.' 16365 CALL XERRWD (MSG, 30, 206, 1, 0, 0, 0, 0, TN, 0.0D0) 16366 ISTATE = -7 16367 GO TO 590 16368 C KFLAG = -5. Fatal error flag returned by DPRJIS or DSOLSS (CDRV). --- 16369 555 MSG = 'DLSODIS- At T (=R1) and step size H (=R2), a fatal' 16370 CALL XERRWD (MSG, 50, 207, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 16371 MSG = ' error flag was returned by CDRV (by way of ' 16372 CALL XERRWD (MSG, 50, 207, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 16373 MSG = ' Subroutine DPRJIS or DSOLSS) ' 16374 CALL XERRWD (MSG, 40, 207, 0, 0, 0, 0, 2, TN, H) 16375 ISTATE = -9 16376 GO TO 580 16377 C DAINVGS failed because matrix A was singular. ------------------------ 16378 560 MSG='DLSODIS- Attempt to initialize dy/dt failed because matrix A' 16379 CALL XERRWD (MSG, 60, 208, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 16380 MSG=' was singular. CDRV returned zero pivot error flag. ' 16381 CALL XERRWD (MSG, 60, 208, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 16382 MSG = 'DAINVGS set its error flag to IER = (I1)' 16383 CALL XERRWD (MSG, 40, 208, 0, 1, IER, 0, 0, 0.0D0, 0.0D0) 16384 ISTATE = -8 16385 RETURN 16386 C DAINVGS failed because RES set IRES to 2 or 3. ----------------------- 16387 565 MSG = 'DLSODIS- Attempt to initialize dy/dt failed ' 16388 CALL XERRWD (MSG, 50, 209, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 16389 MSG = ' because residual routine set its error flag ' 16390 CALL XERRWD (MSG, 50, 209, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 16391 MSG = ' to IRES = (I1)' 16392 CALL XERRWD (MSG, 20, 209, 0, 1, IER, 0, 0, 0.0D0, 0.0D0) 16393 ISTATE = -8 16394 RETURN 16395 C Compute IMXER if relevant. ------------------------------------------- 16396 570 BIG = 0.0D0 16397 IMXER = 1 16398 DO 575 I = 1,N 16399 SIZE = ABS(RWORK(I+LACOR-1)*RWORK(I+LEWT-1)) 16400 IF (BIG .GE. SIZE) GO TO 575 16401 BIG = SIZE 16402 IMXER = I 16403 575 CONTINUE 16404 IWORK(16) = IMXER 16405 C Compute residual if relevant. ---------------------------------------- 16406 580 LYD0 = LYH + NYH 16407 DO 585 I = 1, N 16408 RWORK(I+LSAVF-1) = RWORK(I+LYD0-1) / H 16409 585 Y(I) = RWORK(I+LYH-1) 16410 IRES = 1 16411 CALL RES (NEQ, TN, Y, RWORK(LSAVF), YDOTI, IRES) 16412 NFE = NFE + 1 16413 IF ( IRES .LE. 1 ) GO TO 595 16414 MSG = 'DLSODIS- Residual routine set its flag IRES ' 16415 CALL XERRWD (MSG, 50, 210, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 16416 MSG = ' to (I1) when called for final output. ' 16417 CALL XERRWD (MSG, 50, 210, 0, 1, IRES, 0, 0, 0.0D0, 0.0D0) 16418 GO TO 595 16419 C set y vector, t, and optional outputs. ------------------------------- 16420 590 DO 592 I = 1,N 16421 592 Y(I) = RWORK(I+LYH-1) 16422 595 T = TN 16423 RWORK(11) = HU 16424 RWORK(12) = H 16425 RWORK(13) = TN 16426 IWORK(11) = NST 16427 IWORK(12) = NFE 16428 IWORK(13) = NJE 16429 IWORK(14) = NQU 16430 IWORK(15) = NQ 16431 IWORK(19) = NNZ 16432 IWORK(20) = NGP 16433 IWORK(21) = NLU 16434 IWORK(25) = NZL 16435 IWORK(26) = NZU 16436 RETURN 16437 C----------------------------------------------------------------------- 16438 C Block I. 16439 C The following block handles all error returns due to illegal input 16440 C (ISTATE = -3), as detected before calling the core integrator. 16441 C First the error message routine is called. If the illegal input 16442 C is a negative ISTATE, the run is aborted (apparent infinite loop). 16443 C----------------------------------------------------------------------- 16444 601 MSG = 'DLSODIS- ISTATE (=I1) illegal.' 16445 CALL XERRWD (MSG, 30, 1, 0, 1, ISTATE, 0, 0, 0.0D0, 0.0D0) 16446 IF (ISTATE .LT. 0) GO TO 800 16447 GO TO 700 16448 602 MSG = 'DLSODIS- ITASK (=I1) illegal. ' 16449 CALL XERRWD (MSG, 30, 2, 0, 1, ITASK, 0, 0, 0.0D0, 0.0D0) 16450 GO TO 700 16451 603 MSG = 'DLSODIS-ISTATE .gt. 1 but DLSODIS not initialized.' 16452 CALL XERRWD (MSG, 50, 3, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 16453 GO TO 700 16454 604 MSG = 'DLSODIS- NEQ (=I1) .lt. 1 ' 16455 CALL XERRWD (MSG, 30, 4, 0, 1, NEQ(1), 0, 0, 0.0D0, 0.0D0) 16456 GO TO 700 16457 605 MSG = 'DLSODIS- ISTATE = 3 and NEQ increased (I1 to I2). ' 16458 CALL XERRWD (MSG, 50, 5, 0, 2, N, NEQ(1), 0, 0.0D0, 0.0D0) 16459 GO TO 700 16460 606 MSG = 'DLSODIS- ITOL (=I1) illegal. ' 16461 CALL XERRWD (MSG, 30, 6, 0, 1, ITOL, 0, 0, 0.0D0, 0.0D0) 16462 GO TO 700 16463 607 MSG = 'DLSODIS- IOPT (=I1) illegal. ' 16464 CALL XERRWD (MSG, 30, 7, 0, 1, IOPT, 0, 0, 0.0D0, 0.0D0) 16465 GO TO 700 16466 608 MSG = 'DLSODIS- MF (=I1) illegal. ' 16467 CALL XERRWD (MSG, 30, 8, 0, 1, MF, 0, 0, 0.0D0, 0.0D0) 16468 GO TO 700 16469 611 MSG = 'DLSODIS- MAXORD (=I1) .lt. 0 ' 16470 CALL XERRWD (MSG, 30, 11, 0, 1, MAXORD, 0, 0, 0.0D0, 0.0D0) 16471 GO TO 700 16472 612 MSG = 'DLSODIS- MXSTEP (=I1) .lt. 0 ' 16473 CALL XERRWD (MSG, 30, 12, 0, 1, MXSTEP, 0, 0, 0.0D0, 0.0D0) 16474 GO TO 700 16475 613 MSG = 'DLSODIS- MXHNIL (=I1) .lt. 0 ' 16476 CALL XERRWD (MSG, 30, 13, 0, 1, MXHNIL, 0, 0, 0.0D0, 0.0D0) 16477 GO TO 700 16478 614 MSG = 'DLSODIS- TOUT (=R1) behind T (=R2) ' 16479 CALL XERRWD (MSG, 40, 14, 0, 0, 0, 0, 2, TOUT, T) 16480 MSG = ' Integration direction is given by H0 (=R1) ' 16481 CALL XERRWD (MSG, 50, 14, 0, 0, 0, 0, 1, H0, 0.0D0) 16482 GO TO 700 16483 615 MSG = 'DLSODIS- HMAX (=R1) .lt. 0.0 ' 16484 CALL XERRWD (MSG, 30, 15, 0, 0, 0, 0, 1, HMAX, 0.0D0) 16485 GO TO 700 16486 616 MSG = 'DLSODIS- HMIN (=R1) .lt. 0.0 ' 16487 CALL XERRWD (MSG, 30, 16, 0, 0, 0, 0, 1, HMIN, 0.0D0) 16488 GO TO 700 16489 617 MSG = 'DLSODIS- RWORK length is insufficient to proceed. ' 16490 CALL XERRWD (MSG, 50, 17, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 16491 MSG=' Length needed is .ge. LENRW (=I1), exceeds LRW (=I2)' 16492 CALL XERRWD (MSG, 60, 17, 0, 2, LENRW, LRW, 0, 0.0D0, 0.0D0) 16493 GO TO 700 16494 618 MSG = 'DLSODIS- IWORK length is insufficient to proceed. ' 16495 CALL XERRWD (MSG, 50, 18, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 16496 MSG=' Length needed is .ge. LENIW (=I1), exceeds LIW (=I2)' 16497 CALL XERRWD (MSG, 60, 18, 0, 2, LENIW, LIW, 0, 0.0D0, 0.0D0) 16498 GO TO 700 16499 619 MSG = 'DLSODIS- RTOL(=I1) is R1 .lt. 0.0 ' 16500 CALL XERRWD (MSG, 40, 19, 0, 1, I, 0, 1, RTOLI, 0.0D0) 16501 GO TO 700 16502 620 MSG = 'DLSODIS- ATOL(=I1) is R1 .lt. 0.0 ' 16503 CALL XERRWD (MSG, 40, 20, 0, 1, I, 0, 1, ATOLI, 0.0D0) 16504 GO TO 700 16505 621 EWTI = RWORK(LEWT+I-1) 16506 MSG = 'DLSODIS- EWT(I1) is R1 .le. 0.0 ' 16507 CALL XERRWD (MSG, 40, 21, 0, 1, I, 0, 1, EWTI, 0.0D0) 16508 GO TO 700 16509 622 MSG='DLSODIS- TOUT(=R1) too close to T(=R2) to start integration.' 16510 CALL XERRWD (MSG, 60, 22, 0, 0, 0, 0, 2, TOUT, T) 16511 GO TO 700 16512 623 MSG='DLSODIS- ITASK = I1 and TOUT (=R1) behind TCUR - HU (= R2) ' 16513 CALL XERRWD (MSG, 60, 23, 0, 1, ITASK, 0, 2, TOUT, TP) 16514 GO TO 700 16515 624 MSG='DLSODIS- ITASK = 4 or 5 and TCRIT (=R1) behind TCUR (=R2) ' 16516 CALL XERRWD (MSG, 60, 24, 0, 0, 0, 0, 2, TCRIT, TN) 16517 GO TO 700 16518 625 MSG='DLSODIS- ITASK = 4 or 5 and TCRIT (=R1) behind TOUT (=R2) ' 16519 CALL XERRWD (MSG, 60, 25, 0, 0, 0, 0, 2, TCRIT, TOUT) 16520 GO TO 700 16521 626 MSG = 'DLSODIS- At start of problem, too much accuracy ' 16522 CALL XERRWD (MSG, 50, 26, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 16523 MSG=' requested for precision of machine.. See TOLSF (=R1) ' 16524 CALL XERRWD (MSG, 60, 26, 0, 0, 0, 0, 1, TOLSF, 0.0D0) 16525 RWORK(14) = TOLSF 16526 GO TO 700 16527 627 MSG = 'DLSODIS- Trouble in DINTDY. ITASK = I1, TOUT = R1' 16528 CALL XERRWD (MSG, 50, 27, 0, 1, ITASK, 0, 1, TOUT, 0.0D0) 16529 GO TO 700 16530 628 MSG='DLSODIS- RWORK length insufficient (for Subroutine DPREPI). ' 16531 CALL XERRWD (MSG, 60, 28, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 16532 MSG=' Length needed is .ge. LENRW (=I1), exceeds LRW (=I2)' 16533 CALL XERRWD (MSG, 60, 28, 0, 2, LENRW, LRW, 0, 0.0D0, 0.0D0) 16534 GO TO 700 16535 629 MSG='DLSODIS- RWORK length insufficient (for Subroutine JGROUP). ' 16536 CALL XERRWD (MSG, 60, 29, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 16537 MSG=' Length needed is .ge. LENRW (=I1), exceeds LRW (=I2)' 16538 CALL XERRWD (MSG, 60, 29, 0, 2, LENRW, LRW, 0, 0.0D0, 0.0D0) 16539 GO TO 700 16540 630 MSG='DLSODIS- RWORK length insufficient (for Subroutine ODRV). ' 16541 CALL XERRWD (MSG, 60, 30, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 16542 MSG=' Length needed is .ge. LENRW (=I1), exceeds LRW (=I2)' 16543 CALL XERRWD (MSG, 60, 30, 0, 2, LENRW, LRW, 0, 0.0D0, 0.0D0) 16544 GO TO 700 16545 631 MSG='DLSODIS- Error from ODRV in Yale Sparse Matrix Package. ' 16546 CALL XERRWD (MSG, 60, 31, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 16547 IMUL = (IYS - 1)/N 16548 IREM = IYS - IMUL*N 16549 MSG=' At T (=R1), ODRV returned error flag = I1*NEQ + I2. ' 16550 CALL XERRWD (MSG, 60, 31, 0, 2, IMUL, IREM, 1, TN, 0.0D0) 16551 GO TO 700 16552 632 MSG='DLSODIS- RWORK length insufficient (for Subroutine CDRV). ' 16553 CALL XERRWD (MSG, 60, 32, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 16554 MSG=' Length needed is .ge. LENRW (=I1), exceeds LRW (=I2)' 16555 CALL XERRWD (MSG, 60, 32, 0, 2, LENRW, LRW, 0, 0.0D0, 0.0D0) 16556 GO TO 700 16557 633 MSG='DLSODIS- Error from CDRV in Yale Sparse Matrix Package. ' 16558 CALL XERRWD (MSG, 60, 33, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 16559 IMUL = (IYS - 1)/N 16560 IREM = IYS - IMUL*N 16561 MSG=' At T (=R1), CDRV returned error flag = I1*NEQ + I2. ' 16562 CALL XERRWD (MSG, 60, 33, 0, 2, IMUL, IREM, 1, TN, 0.0D0) 16563 IF (IMUL .EQ. 2) THEN 16564 MSG=' Duplicate entry in sparsity structure descriptors. ' 16565 CALL XERRWD (MSG, 60, 33, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 16566 ENDIF 16567 IF (IMUL .EQ. 3 .OR. IMUL .EQ. 6) THEN 16568 MSG=' Insufficient storage for NSFC (called by CDRV). ' 16569 CALL XERRWD (MSG, 60, 33, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 16570 ENDIF 16571 GO TO 700 16572 634 MSG='DLSODIS- At T (=R1) residual routine (called by DPREPI) ' 16573 CALL XERRWD (MSG, 60, 34, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) 16574 IER = -IPFLAG - 5 16575 MSG = ' returned error IRES (=I1)' 16576 CALL XERRWD (MSG, 30, 34, 0, 1, IER, 0, 1, TN, 0.0D0) 16577 C 16578 700 ISTATE = -3 16579 RETURN 16580 C 16581 800 MSG = 'DLSODIS- Run aborted.. apparent infinite loop. ' 16582 CALL XERRWD (MSG, 50, 303, 2, 0, 0, 0, 0, 0.0D0, 0.0D0) 16583 RETURN 16584 C----------------------- End of Subroutine DLSODIS --------------------- 16585 END 16586 16587 16588 *DECK DUMACH 16589 DOUBLE PRECISION FUNCTION DUMACH () 16590 C***BEGIN PROLOGUE DUMACH 16591 C***PURPOSE Compute the unit roundoff of the machine. 16592 C***CATEGORY R1 16593 C***TYPE DOUBLE PRECISION (RUMACH-S, DUMACH-D) 16594 C***KEYWORDS MACHINE CONSTANTS 16595 C***AUTHOR Hindmarsh, Alan C., (LLNL) 16596 C***DESCRIPTION 16597 C *Usage: 16598 C DOUBLE PRECISION A, DUMACH 16599 C A = DUMACH() 16600 C 16601 C *Function Return Values: 16602 C A : the unit roundoff of the machine. 16603 C 16604 C *Description: 16605 C The unit roundoff is defined as the smallest positive machine 16606 C number u such that 1.0 + u .ne. 1.0. This is computed by DUMACH 16607 C in a machine-independent manner. 16608 C 16609 C***REFERENCES (NONE) 16610 C***ROUTINES CALLED DUMSUM 16611 C***REVISION HISTORY (YYYYMMDD) 16612 C 19930216 DATE WRITTEN 16613 C 19930818 Added SLATEC-format prologue. (FNF) 16614 C 20030707 Added DUMSUM to force normal storage of COMP. (ACH) 16615 C***END PROLOGUE DUMACH 16616 C 16617 DOUBLE PRECISION U, COMP 16618 C***FIRST EXECUTABLE STATEMENT DUMACH 16619 U = 1.0D0 16620 10 U = U*0.5D0 16621 CALL DUMSUM(1.0D0, U, COMP) 16622 IF (COMP .NE. 1.0D0) GO TO 10 16623 DUMACH = U*2.0D0 16624 RETURN 16625 C----------------------- End of Function DUMACH ------------------------ 16626 END 16627 SUBROUTINE DUMSUM(A,B,C) 16628 C Routine to force normal storing of A + B, for DUMACH. 16629 DOUBLE PRECISION A, B, C 16630 C = A + B 16631 RETURN 16632 END 16633 *DECK DCFODE 16634 SUBROUTINE DCFODE (METH, ELCO, TESCO) 16635 C***BEGIN PROLOGUE DCFODE 16636 C***SUBSIDIARY 16637 C***PURPOSE Set ODE integrator coefficients. 16638 C***TYPE DOUBLE PRECISION (SCFODE-S, DCFODE-D) 16639 C***AUTHOR Hindmarsh, Alan C., (LLNL) 16640 C***DESCRIPTION 16641 C 16642 C DCFODE is called by the integrator routine to set coefficients 16643 C needed there. The coefficients for the current method, as 16644 C given by the value of METH, are set for all orders and saved. 16645 C The maximum order assumed here is 12 if METH = 1 and 5 if METH = 2. 16646 C (A smaller value of the maximum order is also allowed.) 16647 C DCFODE is called once at the beginning of the problem, 16648 C and is not called again unless and until METH is changed. 16649 C 16650 C The ELCO array contains the basic method coefficients. 16651 C The coefficients el(i), 1 .le. i .le. nq+1, for the method of 16652 C order nq are stored in ELCO(i,nq). They are given by a genetrating 16653 C polynomial, i.e., 16654 C l(x) = el(1) + el(2)*x + ... + el(nq+1)*x**nq. 16655 C For the implicit Adams methods, l(x) is given by 16656 C dl/dx = (x+1)*(x+2)*...*(x+nq-1)/factorial(nq-1), l(-1) = 0. 16657 C For the BDF methods, l(x) is given by 16658 C l(x) = (x+1)*(x+2)* ... *(x+nq)/K, 16659 C where K = factorial(nq)*(1 + 1/2 + ... + 1/nq). 16660 C 16661 C The TESCO array contains test constants used for the 16662 C local error test and the selection of step size and/or order. 16663 C At order nq, TESCO(k,nq) is used for the selection of step 16664 C size at order nq - 1 if k = 1, at order nq if k = 2, and at order 16665 C nq + 1 if k = 3. 16666 C 16667 C***SEE ALSO DLSODE 16668 C***ROUTINES CALLED (NONE) 16669 C***REVISION HISTORY (YYMMDD) 16670 C 791129 DATE WRITTEN 16671 C 890501 Modified prologue to SLATEC/LDOC format. (FNF) 16672 C 890503 Minor cosmetic changes. (FNF) 16673 C 930809 Renamed to allow single/double precision versions. (ACH) 16674 C***END PROLOGUE DCFODE 16675 C**End 16676 INTEGER METH 16677 INTEGER I, IB, NQ, NQM1, NQP1 16678 DOUBLE PRECISION ELCO, TESCO 16679 DOUBLE PRECISION AGAMQ, FNQ, FNQM1, PC, PINT, RAGQ, 16680 1 RQFAC, RQ1FAC, TSIGN, XPIN 16681 DIMENSION ELCO(13,12), TESCO(3,12) 16682 DIMENSION PC(12) 16683 C 16684 C***FIRST EXECUTABLE STATEMENT DCFODE 16685 GO TO (100, 200), METH 16686 C 16687 100 ELCO(1,1) = 1.0D0 16688 ELCO(2,1) = 1.0D0 16689 TESCO(1,1) = 0.0D0 16690 TESCO(2,1) = 2.0D0 16691 TESCO(1,2) = 1.0D0 16692 TESCO(3,12) = 0.0D0 16693 PC(1) = 1.0D0 16694 RQFAC = 1.0D0 16695 DO 140 NQ = 2,12 16696 C----------------------------------------------------------------------- 16697 C The PC array will contain the coefficients of the polynomial 16698 C p(x) = (x+1)*(x+2)*...*(x+nq-1). 16699 C Initially, p(x) = 1. 16700 C----------------------------------------------------------------------- 16701 RQ1FAC = RQFAC 16702 RQFAC = RQFAC/NQ 16703 NQM1 = NQ - 1 16704 FNQM1 = NQM1 16705 NQP1 = NQ + 1 16706 C Form coefficients of p(x)*(x+nq-1). ---------------------------------- 16707 PC(NQ) = 0.0D0 16708 DO 110 IB = 1,NQM1 16709 I = NQP1 - IB 16710 110 PC(I) = PC(I-1) + FNQM1*PC(I) 16711 PC(1) = FNQM1*PC(1) 16712 C Compute integral, -1 to 0, of p(x) and x*p(x). ----------------------- 16713 PINT = PC(1) 16714 XPIN = PC(1)/2.0D0 16715 TSIGN = 1.0D0 16716 DO 120 I = 2,NQ 16717 TSIGN = -TSIGN 16718 PINT = PINT + TSIGN*PC(I)/I 16719 120 XPIN = XPIN + TSIGN*PC(I)/(I+1) 16720 C Store coefficients in ELCO and TESCO. -------------------------------- 16721 ELCO(1,NQ) = PINT*RQ1FAC 16722 ELCO(2,NQ) = 1.0D0 16723 DO 130 I = 2,NQ 16724 130 ELCO(I+1,NQ) = RQ1FAC*PC(I)/I 16725 AGAMQ = RQFAC*XPIN 16726 RAGQ = 1.0D0/AGAMQ 16727 TESCO(2,NQ) = RAGQ 16728 IF (NQ .LT. 12) TESCO(1,NQP1) = RAGQ*RQFAC/NQP1 16729 TESCO(3,NQM1) = RAGQ 16730 140 CONTINUE 16731 RETURN 16732 C 16733 200 PC(1) = 1.0D0 16734 RQ1FAC = 1.0D0 16735 DO 230 NQ = 1,5 16736 C----------------------------------------------------------------------- 16737 C The PC array will contain the coefficients of the polynomial 16738 C p(x) = (x+1)*(x+2)*...*(x+nq). 16739 C Initially, p(x) = 1. 16740 C----------------------------------------------------------------------- 16741 FNQ = NQ 16742 NQP1 = NQ + 1 16743 C Form coefficients of p(x)*(x+nq). ------------------------------------ 16744 PC(NQP1) = 0.0D0 16745 DO 210 IB = 1,NQ 16746 I = NQ + 2 - IB 16747 210 PC(I) = PC(I-1) + FNQ*PC(I) 16748 PC(1) = FNQ*PC(1) 16749 C Store coefficients in ELCO and TESCO. -------------------------------- 16750 DO 220 I = 1,NQP1 16751 220 ELCO(I,NQ) = PC(I)/PC(2) 16752 ELCO(2,NQ) = 1.0D0 16753 TESCO(1,NQ) = RQ1FAC 16754 TESCO(2,NQ) = NQP1/ELCO(1,NQ) 16755 TESCO(3,NQ) = (NQ+2)/ELCO(1,NQ) 16756 RQ1FAC = RQ1FAC/FNQ 16757 230 CONTINUE 16758 RETURN 16759 C----------------------- END OF SUBROUTINE DCFODE ---------------------- 16760 END 16761 *DECK DINTDY 16762 SUBROUTINE DINTDY (T, K, YH, NYH, DKY, IFLAG) 16763 C***BEGIN PROLOGUE DINTDY 16764 C***SUBSIDIARY 16765 C***PURPOSE Interpolate solution derivatives. 16766 C***TYPE DOUBLE PRECISION (SINTDY-S, DINTDY-D) 16767 C***AUTHOR Hindmarsh, Alan C., (LLNL) 16768 C***DESCRIPTION 16769 C 16770 C DINTDY computes interpolated values of the K-th derivative of the 16771 C dependent variable vector y, and stores it in DKY. This routine 16772 C is called within the package with K = 0 and T = TOUT, but may 16773 C also be called by the user for any K up to the current order. 16774 C (See detailed instructions in the usage documentation.) 16775 C 16776 C The computed values in DKY are gotten by interpolation using the 16777 C Nordsieck history array YH. This array corresponds uniquely to a 16778 C vector-valued polynomial of degree NQCUR or less, and DKY is set 16779 C to the K-th derivative of this polynomial at T. 16780 C The formula for DKY is: 16781 C q 16782 C DKY(i) = sum c(j,K) * (T - tn)**(j-K) * h**(-j) * YH(i,j+1) 16783 C j=K 16784 C where c(j,K) = j*(j-1)*...*(j-K+1), q = NQCUR, tn = TCUR, h = HCUR. 16785 C The quantities nq = NQCUR, l = nq+1, N = NEQ, tn, and h are 16786 C communicated by COMMON. The above sum is done in reverse order. 16787 C IFLAG is returned negative if either K or T is out of bounds. 16788 C 16789 C***SEE ALSO DLSODE 16790 C***ROUTINES CALLED XERRWD 16791 C***COMMON BLOCKS DLS001 16792 C***REVISION HISTORY (YYMMDD) 16793 C 791129 DATE WRITTEN 16794 C 890501 Modified prologue to SLATEC/LDOC format. (FNF) 16795 C 890503 Minor cosmetic changes. (FNF) 16796 C 930809 Renamed to allow single/double precision versions. (ACH) 16797 C 010418 Reduced size of Common block /DLS001/. (ACH) 16798 C 031105 Restored 'own' variables to Common block /DLS001/, to 16799 C enable interrupt/restart feature. (ACH) 16800 C***END PROLOGUE DINTDY 16801 C**End 16802 INTEGER K, NYH, IFLAG 16803 DOUBLE PRECISION T, YH, DKY 16804 DIMENSION YH(NYH,*), DKY(*) 16805 INTEGER IOWND, IOWNS, 16806 1 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 16807 2 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 16808 3 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU 16809 DOUBLE PRECISION ROWNS, 16810 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND 16811 COMMON /DLS001/ ROWNS(209), 16812 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND, 16813 2 IOWND(6), IOWNS(6), 16814 3 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 16815 4 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 16816 5 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU 16817 INTEGER I, IC, J, JB, JB2, JJ, JJ1, JP1 16818 DOUBLE PRECISION C, R, S, TP 16819 CHARACTER*80 MSG 16820 C 16821 C***FIRST EXECUTABLE STATEMENT DINTDY 16822 IFLAG = 0 16823 IF (K .LT. 0 .OR. K .GT. NQ) GO TO 80 16824 TP = TN - HU - 100.0D0*UROUND*(TN + HU) 16825 IF ((T-TP)*(T-TN) .GT. 0.0D0) GO TO 90 16826 C 16827 S = (T - TN)/H 16828 IC = 1 16829 IF (K .EQ. 0) GO TO 15 16830 JJ1 = L - K 16831 DO 10 JJ = JJ1,NQ 16832 10 IC = IC*JJ 16833 15 C = IC 16834 DO 20 I = 1,N 16835 20 DKY(I) = C*YH(I,L) 16836 IF (K .EQ. NQ) GO TO 55 16837 JB2 = NQ - K 16838 DO 50 JB = 1,JB2 16839 J = NQ - JB 16840 JP1 = J + 1 16841 IC = 1 16842 IF (K .EQ. 0) GO TO 35 16843 JJ1 = JP1 - K 16844 DO 30 JJ = JJ1,J 16845 30 IC = IC*JJ 16846 35 C = IC 16847 DO 40 I = 1,N 16848 40 DKY(I) = C*YH(I,JP1) + S*DKY(I) 16849 50 CONTINUE 16850 IF (K .EQ. 0) RETURN 16851 55 R = H**(-K) 16852 DO 60 I = 1,N 16853 60 DKY(I) = R*DKY(I) 16854 RETURN 16855 C 16856 80 MSG = 'DINTDY- K (=I1) illegal ' 16857 CALL XERRWD (MSG, 30, 51, 0, 1, K, 0, 0, 0.0D0, 0.0D0) 16858 IFLAG = -1 16859 RETURN 16860 90 MSG = 'DINTDY- T (=R1) illegal ' 16861 CALL XERRWD (MSG, 30, 52, 0, 0, 0, 0, 1, T, 0.0D0) 16862 MSG=' T not in interval TCUR - HU (= R1) to TCUR (=R2) ' 16863 CALL XERRWD (MSG, 60, 52, 0, 0, 0, 0, 2, TP, TN) 16864 IFLAG = -2 16865 RETURN 16866 C----------------------- END OF SUBROUTINE DINTDY ---------------------- 16867 END 16868 *DECK DPREPJ 16869 SUBROUTINE DPREPJ (NEQ, Y, YH, NYH, EWT, FTEM, SAVF, WM, IWM, 16870 1 F, JAC) 16871 C***BEGIN PROLOGUE DPREPJ 16872 C***SUBSIDIARY 16873 C***PURPOSE Compute and process Newton iteration matrix. 16874 C***TYPE DOUBLE PRECISION (SPREPJ-S, DPREPJ-D) 16875 C***AUTHOR Hindmarsh, Alan C., (LLNL) 16876 C***DESCRIPTION 16877 C 16878 C DPREPJ is called by DSTODE to compute and process the matrix 16879 C P = I - h*el(1)*J , where J is an approximation to the Jacobian. 16880 C Here J is computed by the user-supplied routine JAC if 16881 C MITER = 1 or 4, or by finite differencing if MITER = 2, 3, or 5. 16882 C If MITER = 3, a diagonal approximation to J is used. 16883 C J is stored in WM and replaced by P. If MITER .ne. 3, P is then 16884 C subjected to LU decomposition in preparation for later solution 16885 C of linear systems with P as coefficient matrix. This is done 16886 C by DGEFA if MITER = 1 or 2, and by DGBFA if MITER = 4 or 5. 16887 C 16888 C In addition to variables described in DSTODE and DLSODE prologues, 16889 C communication with DPREPJ uses the following: 16890 C Y = array containing predicted values on entry. 16891 C FTEM = work array of length N (ACOR in DSTODE). 16892 C SAVF = array containing f evaluated at predicted y. 16893 C WM = real work space for matrices. On output it contains the 16894 C inverse diagonal matrix if MITER = 3 and the LU decomposition 16895 C of P if MITER is 1, 2 , 4, or 5. 16896 C Storage of matrix elements starts at WM(3). 16897 C WM also contains the following matrix-related data: 16898 C WM(1) = SQRT(UROUND), used in numerical Jacobian increments. 16899 C WM(2) = H*EL0, saved for later use if MITER = 3. 16900 C IWM = integer work space containing pivot information, starting at 16901 C IWM(21), if MITER is 1, 2, 4, or 5. IWM also contains band 16902 C parameters ML = IWM(1) and MU = IWM(2) if MITER is 4 or 5. 16903 C EL0 = EL(1) (input). 16904 C IERPJ = output error flag, = 0 if no trouble, .gt. 0 if 16905 C P matrix found to be singular. 16906 C JCUR = output flag = 1 to indicate that the Jacobian matrix 16907 C (or approximation) is now current. 16908 C This routine also uses the COMMON variables EL0, H, TN, UROUND, 16909 C MITER, N, NFE, and NJE. 16910 C 16911 C***SEE ALSO DLSODE 16912 C***ROUTINES CALLED DGBFA, DGEFA, DVNORM 16913 C***COMMON BLOCKS DLS001 16914 C***REVISION HISTORY (YYMMDD) 16915 C 791129 DATE WRITTEN 16916 C 890501 Modified prologue to SLATEC/LDOC format. (FNF) 16917 C 890504 Minor cosmetic changes. (FNF) 16918 C 930809 Renamed to allow single/double precision versions. (ACH) 16919 C 010418 Reduced size of Common block /DLS001/. (ACH) 16920 C 031105 Restored 'own' variables to Common block /DLS001/, to 16921 C enable interrupt/restart feature. (ACH) 16922 C***END PROLOGUE DPREPJ 16923 C**End 16924 EXTERNAL F, JAC 16925 INTEGER NEQ, NYH, IWM 16926 DOUBLE PRECISION Y, YH, EWT, FTEM, SAVF, WM 16927 DIMENSION NEQ(*), Y(*), YH(NYH,*), EWT(*), FTEM(*), SAVF(*), 16928 1 WM(*), IWM(*) 16929 INTEGER IOWND, IOWNS, 16930 1 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 16931 2 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 16932 3 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU 16933 DOUBLE PRECISION ROWNS, 16934 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND 16935 COMMON /DLS001/ ROWNS(209), 16936 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND, 16937 2 IOWND(6), IOWNS(6), 16938 3 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 16939 4 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 16940 5 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU 16941 INTEGER I, I1, I2, IER, II, J, J1, JJ, LENP, 16942 1 MBA, MBAND, MEB1, MEBAND, ML, ML3, MU, NP1 16943 DOUBLE PRECISION CON, DI, FAC, HL0, R, R0, SRUR, YI, YJ, YJJ, 16944 1 DVNORM 16945 C 16946 C***FIRST EXECUTABLE STATEMENT DPREPJ 16947 NJE = NJE + 1 16948 IERPJ = 0 16949 JCUR = 1 16950 HL0 = H*EL0 16951 GO TO (100, 200, 300, 400, 500), MITER 16952 C If MITER = 1, call JAC and multiply by scalar. ----------------------- 16953 100 LENP = N*N 16954 DO 110 I = 1,LENP 16955 110 WM(I+2) = 0.0D0 16956 CALL JAC (NEQ, TN, Y, 0, 0, WM(3), N) 16957 CON = -HL0 16958 DO 120 I = 1,LENP 16959 120 WM(I+2) = WM(I+2)*CON 16960 GO TO 240 16961 C If MITER = 2, make N calls to F to approximate J. -------------------- 16962 200 FAC = DVNORM (N, SAVF, EWT) 16963 R0 = 1000.0D0*ABS(H)*UROUND*N*FAC 16964 IF (R0 .EQ. 0.0D0) R0 = 1.0D0 16965 SRUR = WM(1) 16966 J1 = 2 16967 DO 230 J = 1,N 16968 YJ = Y(J) 16969 R = MAX(SRUR*ABS(YJ),R0/EWT(J)) 16970 Y(J) = Y(J) + R 16971 FAC = -HL0/R 16972 CALL F (NEQ, TN, Y, FTEM) 16973 DO 220 I = 1,N 16974 220 WM(I+J1) = (FTEM(I) - SAVF(I))*FAC 16975 Y(J) = YJ 16976 J1 = J1 + N 16977 230 CONTINUE 16978 NFE = NFE + N 16979 C Add identity matrix. ------------------------------------------------- 16980 240 J = 3 16981 NP1 = N + 1 16982 DO 250 I = 1,N 16983 WM(J) = WM(J) + 1.0D0 16984 250 J = J + NP1 16985 C Do LU decomposition on P. -------------------------------------------- 16986 CALL DGEFA (WM(3), N, N, IWM(21), IER) 16987 IF (IER .NE. 0) IERPJ = 1 16988 RETURN 16989 C If MITER = 3, construct a diagonal approximation to J and P. --------- 16990 300 WM(2) = HL0 16991 R = EL0*0.1D0 16992 DO 310 I = 1,N 16993 310 Y(I) = Y(I) + R*(H*SAVF(I) - YH(I,2)) 16994 CALL F (NEQ, TN, Y, WM(3)) 16995 NFE = NFE + 1 16996 DO 320 I = 1,N 16997 R0 = H*SAVF(I) - YH(I,2) 16998 DI = 0.1D0*R0 - H*(WM(I+2) - SAVF(I)) 16999 WM(I+2) = 1.0D0 17000 IF (ABS(R0) .LT. UROUND/EWT(I)) GO TO 320 17001 IF (ABS(DI) .EQ. 0.0D0) GO TO 330 17002 WM(I+2) = 0.1D0*R0/DI 17003 320 CONTINUE 17004 RETURN 17005 330 IERPJ = 1 17006 RETURN 17007 C If MITER = 4, call JAC and multiply by scalar. ----------------------- 17008 400 ML = IWM(1) 17009 MU = IWM(2) 17010 ML3 = ML + 3 17011 MBAND = ML + MU + 1 17012 MEBAND = MBAND + ML 17013 LENP = MEBAND*N 17014 DO 410 I = 1,LENP 17015 410 WM(I+2) = 0.0D0 17016 CALL JAC (NEQ, TN, Y, ML, MU, WM(ML3), MEBAND) 17017 CON = -HL0 17018 DO 420 I = 1,LENP 17019 420 WM(I+2) = WM(I+2)*CON 17020 GO TO 570 17021 C If MITER = 5, make MBAND calls to F to approximate J. ---------------- 17022 500 ML = IWM(1) 17023 MU = IWM(2) 17024 MBAND = ML + MU + 1 17025 MBA = MIN(MBAND,N) 17026 MEBAND = MBAND + ML 17027 MEB1 = MEBAND - 1 17028 SRUR = WM(1) 17029 FAC = DVNORM (N, SAVF, EWT) 17030 R0 = 1000.0D0*ABS(H)*UROUND*N*FAC 17031 IF (R0 .EQ. 0.0D0) R0 = 1.0D0 17032 DO 560 J = 1,MBA 17033 DO 530 I = J,N,MBAND 17034 YI = Y(I) 17035 R = MAX(SRUR*ABS(YI),R0/EWT(I)) 17036 530 Y(I) = Y(I) + R 17037 CALL F (NEQ, TN, Y, FTEM) 17038 DO 550 JJ = J,N,MBAND 17039 Y(JJ) = YH(JJ,1) 17040 YJJ = Y(JJ) 17041 R = MAX(SRUR*ABS(YJJ),R0/EWT(JJ)) 17042 FAC = -HL0/R 17043 I1 = MAX(JJ-MU,1) 17044 I2 = MIN(JJ+ML,N) 17045 II = JJ*MEB1 - ML + 2 17046 DO 540 I = I1,I2 17047 540 WM(II+I) = (FTEM(I) - SAVF(I))*FAC 17048 550 CONTINUE 17049 560 CONTINUE 17050 NFE = NFE + MBA 17051 C Add identity matrix. ------------------------------------------------- 17052 570 II = MBAND + 2 17053 DO 580 I = 1,N 17054 WM(II) = WM(II) + 1.0D0 17055 580 II = II + MEBAND 17056 C Do LU decomposition of P. -------------------------------------------- 17057 CALL DGBFA (WM(3), MEBAND, N, ML, MU, IWM(21), IER) 17058 IF (IER .NE. 0) IERPJ = 1 17059 RETURN 17060 C----------------------- END OF SUBROUTINE DPREPJ ---------------------- 17061 END 17062 *DECK DSOLSY 17063 SUBROUTINE DSOLSY (WM, IWM, X, TEM) 17064 C***BEGIN PROLOGUE DSOLSY 17065 C***SUBSIDIARY 17066 C***PURPOSE ODEPACK linear system solver. 17067 C***TYPE DOUBLE PRECISION (SSOLSY-S, DSOLSY-D) 17068 C***AUTHOR Hindmarsh, Alan C., (LLNL) 17069 C***DESCRIPTION 17070 C 17071 C This routine manages the solution of the linear system arising from 17072 C a chord iteration. It is called if MITER .ne. 0. 17073 C If MITER is 1 or 2, it calls DGESL to accomplish this. 17074 C If MITER = 3 it updates the coefficient h*EL0 in the diagonal 17075 C matrix, and then computes the solution. 17076 C If MITER is 4 or 5, it calls DGBSL. 17077 C Communication with DSOLSY uses the following variables: 17078 C WM = real work space containing the inverse diagonal matrix if 17079 C MITER = 3 and the LU decomposition of the matrix otherwise. 17080 C Storage of matrix elements starts at WM(3). 17081 C WM also contains the following matrix-related data: 17082 C WM(1) = SQRT(UROUND) (not used here), 17083 C WM(2) = HL0, the previous value of h*EL0, used if MITER = 3. 17084 C IWM = integer work space containing pivot information, starting at 17085 C IWM(21), if MITER is 1, 2, 4, or 5. IWM also contains band 17086 C parameters ML = IWM(1) and MU = IWM(2) if MITER is 4 or 5. 17087 C X = the right-hand side vector on input, and the solution vector 17088 C on output, of length N. 17089 C TEM = vector of work space of length N, not used in this version. 17090 C IERSL = output flag (in COMMON). IERSL = 0 if no trouble occurred. 17091 C IERSL = 1 if a singular matrix arose with MITER = 3. 17092 C This routine also uses the COMMON variables EL0, H, MITER, and N. 17093 C 17094 C***SEE ALSO DLSODE 17095 C***ROUTINES CALLED DGBSL, DGESL 17096 C***COMMON BLOCKS DLS001 17097 C***REVISION HISTORY (YYMMDD) 17098 C 791129 DATE WRITTEN 17099 C 890501 Modified prologue to SLATEC/LDOC format. (FNF) 17100 C 890503 Minor cosmetic changes. (FNF) 17101 C 930809 Renamed to allow single/double precision versions. (ACH) 17102 C 010418 Reduced size of Common block /DLS001/. (ACH) 17103 C 031105 Restored 'own' variables to Common block /DLS001/, to 17104 C enable interrupt/restart feature. (ACH) 17105 C***END PROLOGUE DSOLSY 17106 C**End 17107 INTEGER IWM 17108 DOUBLE PRECISION WM, X, TEM 17109 DIMENSION WM(*), IWM(*), X(*), TEM(*) 17110 INTEGER IOWND, IOWNS, 17111 1 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 17112 2 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 17113 3 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU 17114 DOUBLE PRECISION ROWNS, 17115 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND 17116 COMMON /DLS001/ ROWNS(209), 17117 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND, 17118 2 IOWND(6), IOWNS(6), 17119 3 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 17120 4 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 17121 5 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU 17122 INTEGER I, MEBAND, ML, MU 17123 DOUBLE PRECISION DI, HL0, PHL0, R 17124 C 17125 C***FIRST EXECUTABLE STATEMENT DSOLSY 17126 IERSL = 0 17127 GO TO (100, 100, 300, 400, 400), MITER 17128 100 CALL DGESL (WM(3), N, N, IWM(21), X, 0) 17129 RETURN 17130 C 17131 300 PHL0 = WM(2) 17132 HL0 = H*EL0 17133 WM(2) = HL0 17134 IF (HL0 .EQ. PHL0) GO TO 330 17135 R = HL0/PHL0 17136 DO 320 I = 1,N 17137 DI = 1.0D0 - R*(1.0D0 - 1.0D0/WM(I+2)) 17138 IF (ABS(DI) .EQ. 0.0D0) GO TO 390 17139 320 WM(I+2) = 1.0D0/DI 17140 330 DO 340 I = 1,N 17141 340 X(I) = WM(I+2)*X(I) 17142 RETURN 17143 390 IERSL = 1 17144 RETURN 17145 C 17146 400 ML = IWM(1) 17147 MU = IWM(2) 17148 MEBAND = 2*ML + MU + 1 17149 CALL DGBSL (WM(3), MEBAND, N, ML, MU, IWM(21), X, 0) 17150 RETURN 17151 C----------------------- END OF SUBROUTINE DSOLSY ---------------------- 17152 END 17153 *DECK DSRCOM 17154 SUBROUTINE DSRCOM (RSAV, ISAV, JOB) 17155 C***BEGIN PROLOGUE DSRCOM 17156 C***SUBSIDIARY 17157 C***PURPOSE Save/restore ODEPACK COMMON blocks. 17158 C***TYPE DOUBLE PRECISION (SSRCOM-S, DSRCOM-D) 17159 C***AUTHOR Hindmarsh, Alan C., (LLNL) 17160 C***DESCRIPTION 17161 C 17162 C This routine saves or restores (depending on JOB) the contents of 17163 C the COMMON block DLS001, which is used internally 17164 C by one or more ODEPACK solvers. 17165 C 17166 C RSAV = real array of length 218 or more. 17167 C ISAV = integer array of length 37 or more. 17168 C JOB = flag indicating to save or restore the COMMON blocks: 17169 C JOB = 1 if COMMON is to be saved (written to RSAV/ISAV) 17170 C JOB = 2 if COMMON is to be restored (read from RSAV/ISAV) 17171 C A call with JOB = 2 presumes a prior call with JOB = 1. 17172 C 17173 C***SEE ALSO DLSODE 17174 C***ROUTINES CALLED (NONE) 17175 C***COMMON BLOCKS DLS001 17176 C***REVISION HISTORY (YYMMDD) 17177 C 791129 DATE WRITTEN 17178 C 890501 Modified prologue to SLATEC/LDOC format. (FNF) 17179 C 890503 Minor cosmetic changes. (FNF) 17180 C 921116 Deleted treatment of block /EH0001/. (ACH) 17181 C 930801 Reduced Common block length by 2. (ACH) 17182 C 930809 Renamed to allow single/double precision versions. (ACH) 17183 C 010418 Reduced Common block length by 209+12. (ACH) 17184 C 031105 Restored 'own' variables to Common block /DLS001/, to 17185 C enable interrupt/restart feature. (ACH) 17186 C 031112 Added SAVE statement for data-loaded constants. 17187 C***END PROLOGUE DSRCOM 17188 C**End 17189 INTEGER ISAV, JOB 17190 INTEGER ILS 17191 INTEGER I, LENILS, LENRLS 17192 DOUBLE PRECISION RSAV, RLS 17193 DIMENSION RSAV(*), ISAV(*) 17194 SAVE LENRLS, LENILS 17195 COMMON /DLS001/ RLS(218), ILS(37) 17196 DATA LENRLS/218/, LENILS/37/ 17197 C 17198 C***FIRST EXECUTABLE STATEMENT DSRCOM 17199 IF (JOB .EQ. 2) GO TO 100 17200 C 17201 DO 10 I = 1,LENRLS 17202 10 RSAV(I) = RLS(I) 17203 DO 20 I = 1,LENILS 17204 20 ISAV(I) = ILS(I) 17205 RETURN 17206 C 17207 100 CONTINUE 17208 DO 110 I = 1,LENRLS 17209 110 RLS(I) = RSAV(I) 17210 DO 120 I = 1,LENILS 17211 120 ILS(I) = ISAV(I) 17212 RETURN 17213 C----------------------- END OF SUBROUTINE DSRCOM ---------------------- 17214 END 17215 *DECK DSTODE 17216 SUBROUTINE DSTODE (NEQ, Y, YH, NYH, YH1, EWT, SAVF, ACOR, 17217 1 WM, IWM, F, JAC, PJAC, SLVS) 17218 C***BEGIN PROLOGUE DSTODE 17219 C***SUBSIDIARY 17220 C***PURPOSE Performs one step of an ODEPACK integration. 17221 C***TYPE DOUBLE PRECISION (SSTODE-S, DSTODE-D) 17222 C***AUTHOR Hindmarsh, Alan C., (LLNL) 17223 C***DESCRIPTION 17224 C 17225 C DSTODE performs one step of the integration of an initial value 17226 C problem for a system of ordinary differential equations. 17227 C Note: DSTODE is independent of the value of the iteration method 17228 C indicator MITER, when this is .ne. 0, and hence is independent 17229 C of the type of chord method used, or the Jacobian structure. 17230 C Communication with DSTODE is done with the following variables: 17231 C 17232 C NEQ = integer array containing problem size in NEQ(1), and 17233 C passed as the NEQ argument in all calls to F and JAC. 17234 C Y = an array of length .ge. N used as the Y argument in 17235 C all calls to F and JAC. 17236 C YH = an NYH by LMAX array containing the dependent variables 17237 C and their approximate scaled derivatives, where 17238 C LMAX = MAXORD + 1. YH(i,j+1) contains the approximate 17239 C j-th derivative of y(i), scaled by h**j/factorial(j) 17240 C (j = 0,1,...,NQ). on entry for the first step, the first 17241 C two columns of YH must be set from the initial values. 17242 C NYH = a constant integer .ge. N, the first dimension of YH. 17243 C YH1 = a one-dimensional array occupying the same space as YH. 17244 C EWT = an array of length N containing multiplicative weights 17245 C for local error measurements. Local errors in Y(i) are 17246 C compared to 1.0/EWT(i) in various error tests. 17247 C SAVF = an array of working storage, of length N. 17248 C Also used for input of YH(*,MAXORD+2) when JSTART = -1 17249 C and MAXORD .lt. the current order NQ. 17250 C ACOR = a work array of length N, used for the accumulated 17251 C corrections. On a successful return, ACOR(i) contains 17252 C the estimated one-step local error in Y(i). 17253 C WM,IWM = real and integer work arrays associated with matrix 17254 C operations in chord iteration (MITER .ne. 0). 17255 C PJAC = name of routine to evaluate and preprocess Jacobian matrix 17256 C and P = I - h*el0*JAC, if a chord method is being used. 17257 C SLVS = name of routine to solve linear system in chord iteration. 17258 C CCMAX = maximum relative change in h*el0 before PJAC is called. 17259 C H = the step size to be attempted on the next step. 17260 C H is altered by the error control algorithm during the 17261 C problem. H can be either positive or negative, but its 17262 C sign must remain constant throughout the problem. 17263 C HMIN = the minimum absolute value of the step size h to be used. 17264 C HMXI = inverse of the maximum absolute value of h to be used. 17265 C HMXI = 0.0 is allowed and corresponds to an infinite hmax. 17266 C HMIN and HMXI may be changed at any time, but will not 17267 C take effect until the next change of h is considered. 17268 C TN = the independent variable. TN is updated on each step taken. 17269 C JSTART = an integer used for input only, with the following 17270 C values and meanings: 17271 C 0 perform the first step. 17272 C .gt.0 take a new step continuing from the last. 17273 C -1 take the next step with a new value of H, MAXORD, 17274 C N, METH, MITER, and/or matrix parameters. 17275 C -2 take the next step with a new value of H, 17276 C but with other inputs unchanged. 17277 C On return, JSTART is set to 1 to facilitate continuation. 17278 C KFLAG = a completion code with the following meanings: 17279 C 0 the step was succesful. 17280 C -1 the requested error could not be achieved. 17281 C -2 corrector convergence could not be achieved. 17282 C -3 fatal error in PJAC or SLVS. 17283 C A return with KFLAG = -1 or -2 means either 17284 C abs(H) = HMIN or 10 consecutive failures occurred. 17285 C On a return with KFLAG negative, the values of TN and 17286 C the YH array are as of the beginning of the last 17287 C step, and H is the last step size attempted. 17288 C MAXORD = the maximum order of integration method to be allowed. 17289 C MAXCOR = the maximum number of corrector iterations allowed. 17290 C MSBP = maximum number of steps between PJAC calls (MITER .gt. 0). 17291 C MXNCF = maximum number of convergence failures allowed. 17292 C METH/MITER = the method flags. See description in driver. 17293 C N = the number of first-order differential equations. 17294 C The values of CCMAX, H, HMIN, HMXI, TN, JSTART, KFLAG, MAXORD, 17295 C MAXCOR, MSBP, MXNCF, METH, MITER, and N are communicated via COMMON. 17296 C 17297 C***SEE ALSO DLSODE 17298 C***ROUTINES CALLED DCFODE, DVNORM 17299 C***COMMON BLOCKS DLS001 17300 C***REVISION HISTORY (YYMMDD) 17301 C 791129 DATE WRITTEN 17302 C 890501 Modified prologue to SLATEC/LDOC format. (FNF) 17303 C 890503 Minor cosmetic changes. (FNF) 17304 C 930809 Renamed to allow single/double precision versions. (ACH) 17305 C 010418 Reduced size of Common block /DLS001/. (ACH) 17306 C 031105 Restored 'own' variables to Common block /DLS001/, to 17307 C enable interrupt/restart feature. (ACH) 17308 C***END PROLOGUE DSTODE 17309 C**End 17310 EXTERNAL F, JAC, PJAC, SLVS 17311 INTEGER NEQ, NYH, IWM 17312 DOUBLE PRECISION Y, YH, YH1, EWT, SAVF, ACOR, WM 17313 DIMENSION NEQ(*), Y(*), YH(NYH,*), YH1(*), EWT(*), SAVF(*), 17314 1 ACOR(*), WM(*), IWM(*) 17315 INTEGER IOWND, IALTH, IPUP, LMAX, MEO, NQNYH, NSLP, 17316 1 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 17317 2 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 17318 3 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU 17319 INTEGER I, I1, IREDO, IRET, J, JB, M, NCF, NEWQ 17320 DOUBLE PRECISION CONIT, CRATE, EL, ELCO, HOLD, RMAX, TESCO, 17321 2 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND 17322 DOUBLE PRECISION DCON, DDN, DEL, DELP, DSM, DUP, EXDN, EXSM, EXUP, 17323 1 R, RH, RHDN, RHSM, RHUP, TOLD, DVNORM 17324 COMMON /DLS001/ CONIT, CRATE, EL(13), ELCO(13,12), 17325 1 HOLD, RMAX, TESCO(3,12), 17326 2 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND, 17327 3 IOWND(6), IALTH, IPUP, LMAX, MEO, NQNYH, NSLP, 17328 3 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 17329 4 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 17330 5 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU 17331 C 17332 C***FIRST EXECUTABLE STATEMENT DSTODE 17333 KFLAG = 0 17334 TOLD = TN 17335 NCF = 0 17336 IERPJ = 0 17337 IERSL = 0 17338 JCUR = 0 17339 ICF = 0 17340 DELP = 0.0D0 17341 IF (JSTART .GT. 0) GO TO 200 17342 IF (JSTART .EQ. -1) GO TO 100 17343 IF (JSTART .EQ. -2) GO TO 160 17344 C----------------------------------------------------------------------- 17345 C On the first call, the order is set to 1, and other variables are 17346 C initialized. RMAX is the maximum ratio by which H can be increased 17347 C in a single step. It is initially 1.E4 to compensate for the small 17348 C initial H, but then is normally equal to 10. If a failure 17349 C occurs (in corrector convergence or error test), RMAX is set to 2 17350 C for the next increase. 17351 C----------------------------------------------------------------------- 17352 LMAX = MAXORD + 1 17353 NQ = 1 17354 L = 2 17355 IALTH = 2 17356 RMAX = 10000.0D0 17357 RC = 0.0D0 17358 EL0 = 1.0D0 17359 CRATE = 0.7D0 17360 HOLD = H 17361 MEO = METH 17362 NSLP = 0 17363 IPUP = MITER 17364 IRET = 3 17365 GO TO 140 17366 C----------------------------------------------------------------------- 17367 C The following block handles preliminaries needed when JSTART = -1. 17368 C IPUP is set to MITER to force a matrix update. 17369 C If an order increase is about to be considered (IALTH = 1), 17370 C IALTH is reset to 2 to postpone consideration one more step. 17371 C If the caller has changed METH, DCFODE is called to reset 17372 C the coefficients of the method. 17373 C If the caller has changed MAXORD to a value less than the current 17374 C order NQ, NQ is reduced to MAXORD, and a new H chosen accordingly. 17375 C If H is to be changed, YH must be rescaled. 17376 C If H or METH is being changed, IALTH is reset to L = NQ + 1 17377 C to prevent further changes in H for that many steps. 17378 C----------------------------------------------------------------------- 17379 100 IPUP = MITER 17380 LMAX = MAXORD + 1 17381 IF (IALTH .EQ. 1) IALTH = 2 17382 IF (METH .EQ. MEO) GO TO 110 17383 CALL DCFODE (METH, ELCO, TESCO) 17384 MEO = METH 17385 IF (NQ .GT. MAXORD) GO TO 120 17386 IALTH = L 17387 IRET = 1 17388 GO TO 150 17389 110 IF (NQ .LE. MAXORD) GO TO 160 17390 120 NQ = MAXORD 17391 L = LMAX 17392 DO 125 I = 1,L 17393 125 EL(I) = ELCO(I,NQ) 17394 NQNYH = NQ*NYH 17395 RC = RC*EL(1)/EL0 17396 EL0 = EL(1) 17397 CONIT = 0.5D0/(NQ+2) 17398 DDN = DVNORM (N, SAVF, EWT)/TESCO(1,L) 17399 EXDN = 1.0D0/L 17400 RHDN = 1.0D0/(1.3D0*DDN**EXDN + 0.0000013D0) 17401 RH = MIN(RHDN,1.0D0) 17402 IREDO = 3 17403 IF (H .EQ. HOLD) GO TO 170 17404 RH = MIN(RH,ABS(H/HOLD)) 17405 H = HOLD 17406 GO TO 175 17407 C----------------------------------------------------------------------- 17408 C DCFODE is called to get all the integration coefficients for the 17409 C current METH. Then the EL vector and related constants are reset 17410 C whenever the order NQ is changed, or at the start of the problem. 17411 C----------------------------------------------------------------------- 17412 140 CALL DCFODE (METH, ELCO, TESCO) 17413 150 DO 155 I = 1,L 17414 155 EL(I) = ELCO(I,NQ) 17415 NQNYH = NQ*NYH 17416 RC = RC*EL(1)/EL0 17417 EL0 = EL(1) 17418 CONIT = 0.5D0/(NQ+2) 17419 GO TO (160, 170, 200), IRET 17420 C----------------------------------------------------------------------- 17421 C If H is being changed, the H ratio RH is checked against 17422 C RMAX, HMIN, and HMXI, and the YH array rescaled. IALTH is set to 17423 C L = NQ + 1 to prevent a change of H for that many steps, unless 17424 C forced by a convergence or error test failure. 17425 C----------------------------------------------------------------------- 17426 160 IF (H .EQ. HOLD) GO TO 200 17427 RH = H/HOLD 17428 H = HOLD 17429 IREDO = 3 17430 GO TO 175 17431 170 RH = MAX(RH,HMIN/ABS(H)) 17432 175 RH = MIN(RH,RMAX) 17433 RH = RH/MAX(1.0D0,ABS(H)*HMXI*RH) 17434 R = 1.0D0 17435 DO 180 J = 2,L 17436 R = R*RH 17437 DO 180 I = 1,N 17438 180 YH(I,J) = YH(I,J)*R 17439 H = H*RH 17440 RC = RC*RH 17441 IALTH = L 17442 IF (IREDO .EQ. 0) GO TO 690 17443 C----------------------------------------------------------------------- 17444 C This section computes the predicted values by effectively 17445 C multiplying the YH array by the Pascal Triangle matrix. 17446 C RC is the ratio of new to old values of the coefficient H*EL(1). 17447 C When RC differs from 1 by more than CCMAX, IPUP is set to MITER 17448 C to force PJAC to be called, if a Jacobian is involved. 17449 C In any case, PJAC is called at least every MSBP steps. 17450 C----------------------------------------------------------------------- 17451 200 IF (ABS(RC-1.0D0) .GT. CCMAX) IPUP = MITER 17452 IF (NST .GE. NSLP+MSBP) IPUP = MITER 17453 TN = TN + H 17454 I1 = NQNYH + 1 17455 DO 215 JB = 1,NQ 17456 I1 = I1 - NYH 17457 Cdir$ ivdep 17458 DO 210 I = I1,NQNYH 17459 210 YH1(I) = YH1(I) + YH1(I+NYH) 17460 215 CONTINUE 17461 C----------------------------------------------------------------------- 17462 C Up to MAXCOR corrector iterations are taken. A convergence test is 17463 C made on the R.M.S. norm of each correction, weighted by the error 17464 C weight vector EWT. The sum of the corrections is accumulated in the 17465 C vector ACOR(i). The YH array is not altered in the corrector loop. 17466 C----------------------------------------------------------------------- 17467 220 M = 0 17468 DO 230 I = 1,N 17469 230 Y(I) = YH(I,1) 17470 CALL F (NEQ, TN, Y, SAVF) 17471 NFE = NFE + 1 17472 IF (IPUP .LE. 0) GO TO 250 17473 C----------------------------------------------------------------------- 17474 C If indicated, the matrix P = I - h*el(1)*J is reevaluated and 17475 C preprocessed before starting the corrector iteration. IPUP is set 17476 C to 0 as an indicator that this has been done. 17477 C----------------------------------------------------------------------- 17478 CALL PJAC (NEQ, Y, YH, NYH, EWT, ACOR, SAVF, WM, IWM, F, JAC) 17479 IPUP = 0 17480 RC = 1.0D0 17481 NSLP = NST 17482 CRATE = 0.7D0 17483 IF (IERPJ .NE. 0) GO TO 430 17484 250 DO 260 I = 1,N 17485 260 ACOR(I) = 0.0D0 17486 270 IF (MITER .NE. 0) GO TO 350 17487 C----------------------------------------------------------------------- 17488 C In the case of functional iteration, update Y directly from 17489 C the result of the last function evaluation. 17490 C----------------------------------------------------------------------- 17491 DO 290 I = 1,N 17492 SAVF(I) = H*SAVF(I) - YH(I,2) 17493 290 Y(I) = SAVF(I) - ACOR(I) 17494 DEL = DVNORM (N, Y, EWT) 17495 DO 300 I = 1,N 17496 Y(I) = YH(I,1) + EL(1)*SAVF(I) 17497 300 ACOR(I) = SAVF(I) 17498 GO TO 400 17499 C----------------------------------------------------------------------- 17500 C In the case of the chord method, compute the corrector error, 17501 C and solve the linear system with that as right-hand side and 17502 C P as coefficient matrix. 17503 C----------------------------------------------------------------------- 17504 350 DO 360 I = 1,N 17505 360 Y(I) = H*SAVF(I) - (YH(I,2) + ACOR(I)) 17506 CALL SLVS (WM, IWM, Y, SAVF) 17507 IF (IERSL .LT. 0) GO TO 430 17508 IF (IERSL .GT. 0) GO TO 410 17509 DEL = DVNORM (N, Y, EWT) 17510 DO 380 I = 1,N 17511 ACOR(I) = ACOR(I) + Y(I) 17512 380 Y(I) = YH(I,1) + EL(1)*ACOR(I) 17513 C----------------------------------------------------------------------- 17514 C Test for convergence. If M.gt.0, an estimate of the convergence 17515 C rate constant is stored in CRATE, and this is used in the test. 17516 C----------------------------------------------------------------------- 17517 400 IF (M .NE. 0) CRATE = MAX(0.2D0*CRATE,DEL/DELP) 17518 DCON = DEL*MIN(1.0D0,1.5D0*CRATE)/(TESCO(2,NQ)*CONIT) 17519 IF (DCON .LE. 1.0D0) GO TO 450 17520 M = M + 1 17521 IF (M .EQ. MAXCOR) GO TO 410 17522 IF (M .GE. 2 .AND. DEL .GT. 2.0D0*DELP) GO TO 410 17523 DELP = DEL 17524 CALL F (NEQ, TN, Y, SAVF) 17525 NFE = NFE + 1 17526 GO TO 270 17527 C----------------------------------------------------------------------- 17528 C The corrector iteration failed to converge. 17529 C If MITER .ne. 0 and the Jacobian is out of date, PJAC is called for 17530 C the next try. Otherwise the YH array is retracted to its values 17531 C before prediction, and H is reduced, if possible. If H cannot be 17532 C reduced or MXNCF failures have occurred, exit with KFLAG = -2. 17533 C----------------------------------------------------------------------- 17534 410 IF (MITER .EQ. 0 .OR. JCUR .EQ. 1) GO TO 430 17535 ICF = 1 17536 IPUP = MITER 17537 GO TO 220 17538 430 ICF = 2 17539 NCF = NCF + 1 17540 RMAX = 2.0D0 17541 TN = TOLD 17542 I1 = NQNYH + 1 17543 DO 445 JB = 1,NQ 17544 I1 = I1 - NYH 17545 Cdir$ ivdep 17546 DO 440 I = I1,NQNYH 17547 440 YH1(I) = YH1(I) - YH1(I+NYH) 17548 445 CONTINUE 17549 IF (IERPJ .LT. 0 .OR. IERSL .LT. 0) GO TO 680 17550 IF (ABS(H) .LE. HMIN*1.00001D0) GO TO 670 17551 IF (NCF .EQ. MXNCF) GO TO 670 17552 RH = 0.25D0 17553 IPUP = MITER 17554 IREDO = 1 17555 GO TO 170 17556 C----------------------------------------------------------------------- 17557 C The corrector has converged. JCUR is set to 0 17558 C to signal that the Jacobian involved may need updating later. 17559 C The local error test is made and control passes to statement 500 17560 C if it fails. 17561 C----------------------------------------------------------------------- 17562 450 JCUR = 0 17563 IF (M .EQ. 0) DSM = DEL/TESCO(2,NQ) 17564 IF (M .GT. 0) DSM = DVNORM (N, ACOR, EWT)/TESCO(2,NQ) 17565 IF (DSM .GT. 1.0D0) GO TO 500 17566 C----------------------------------------------------------------------- 17567 C After a successful step, update the YH array. 17568 C Consider changing H if IALTH = 1. Otherwise decrease IALTH by 1. 17569 C If IALTH is then 1 and NQ .lt. MAXORD, then ACOR is saved for 17570 C use in a possible order increase on the next step. 17571 C If a change in H is considered, an increase or decrease in order 17572 C by one is considered also. A change in H is made only if it is by a 17573 C factor of at least 1.1. If not, IALTH is set to 3 to prevent 17574 C testing for that many steps. 17575 C----------------------------------------------------------------------- 17576 KFLAG = 0 17577 IREDO = 0 17578 NST = NST + 1 17579 HU = H 17580 NQU = NQ 17581 DO 470 J = 1,L 17582 DO 470 I = 1,N 17583 470 YH(I,J) = YH(I,J) + EL(J)*ACOR(I) 17584 IALTH = IALTH - 1 17585 IF (IALTH .EQ. 0) GO TO 520 17586 IF (IALTH .GT. 1) GO TO 700 17587 IF (L .EQ. LMAX) GO TO 700 17588 DO 490 I = 1,N 17589 490 YH(I,LMAX) = ACOR(I) 17590 GO TO 700 17591 C----------------------------------------------------------------------- 17592 C The error test failed. KFLAG keeps track of multiple failures. 17593 C Restore TN and the YH array to their previous values, and prepare 17594 C to try the step again. Compute the optimum step size for this or 17595 C one lower order. After 2 or more failures, H is forced to decrease 17596 C by a factor of 0.2 or less. 17597 C----------------------------------------------------------------------- 17598 500 KFLAG = KFLAG - 1 17599 TN = TOLD 17600 I1 = NQNYH + 1 17601 DO 515 JB = 1,NQ 17602 I1 = I1 - NYH 17603 Cdir$ ivdep 17604 DO 510 I = I1,NQNYH 17605 510 YH1(I) = YH1(I) - YH1(I+NYH) 17606 515 CONTINUE 17607 RMAX = 2.0D0 17608 IF (ABS(H) .LE. HMIN*1.00001D0) GO TO 660 17609 IF (KFLAG .LE. -3) GO TO 640 17610 IREDO = 2 17611 RHUP = 0.0D0 17612 GO TO 540 17613 C----------------------------------------------------------------------- 17614 C Regardless of the success or failure of the step, factors 17615 C RHDN, RHSM, and RHUP are computed, by which H could be multiplied 17616 C at order NQ - 1, order NQ, or order NQ + 1, respectively. 17617 C In the case of failure, RHUP = 0.0 to avoid an order increase. 17618 C The largest of these is determined and the new order chosen 17619 C accordingly. If the order is to be increased, we compute one 17620 C additional scaled derivative. 17621 C----------------------------------------------------------------------- 17622 520 RHUP = 0.0D0 17623 IF (L .EQ. LMAX) GO TO 540 17624 DO 530 I = 1,N 17625 530 SAVF(I) = ACOR(I) - YH(I,LMAX) 17626 DUP = DVNORM (N, SAVF, EWT)/TESCO(3,NQ) 17627 EXUP = 1.0D0/(L+1) 17628 RHUP = 1.0D0/(1.4D0*DUP**EXUP + 0.0000014D0) 17629 540 EXSM = 1.0D0/L 17630 RHSM = 1.0D0/(1.2D0*DSM**EXSM + 0.0000012D0) 17631 RHDN = 0.0D0 17632 IF (NQ .EQ. 1) GO TO 560 17633 DDN = DVNORM (N, YH(1,L), EWT)/TESCO(1,NQ) 17634 EXDN = 1.0D0/NQ 17635 RHDN = 1.0D0/(1.3D0*DDN**EXDN + 0.0000013D0) 17636 560 IF (RHSM .GE. RHUP) GO TO 570 17637 IF (RHUP .GT. RHDN) GO TO 590 17638 GO TO 580 17639 570 IF (RHSM .LT. RHDN) GO TO 580 17640 NEWQ = NQ 17641 RH = RHSM 17642 GO TO 620 17643 580 NEWQ = NQ - 1 17644 RH = RHDN 17645 IF (KFLAG .LT. 0 .AND. RH .GT. 1.0D0) RH = 1.0D0 17646 GO TO 620 17647 590 NEWQ = L 17648 RH = RHUP 17649 IF (RH .LT. 1.1D0) GO TO 610 17650 R = EL(L)/L 17651 DO 600 I = 1,N 17652 600 YH(I,NEWQ+1) = ACOR(I)*R 17653 GO TO 630 17654 610 IALTH = 3 17655 GO TO 700 17656 620 IF ((KFLAG .EQ. 0) .AND. (RH .LT. 1.1D0)) GO TO 610 17657 IF (KFLAG .LE. -2) RH = MIN(RH,0.2D0) 17658 C----------------------------------------------------------------------- 17659 C If there is a change of order, reset NQ, l, and the coefficients. 17660 C In any case H is reset according to RH and the YH array is rescaled. 17661 C Then exit from 690 if the step was OK, or redo the step otherwise. 17662 C----------------------------------------------------------------------- 17663 IF (NEWQ .EQ. NQ) GO TO 170 17664 630 NQ = NEWQ 17665 L = NQ + 1 17666 IRET = 2 17667 GO TO 150 17668 C----------------------------------------------------------------------- 17669 C Control reaches this section if 3 or more failures have occured. 17670 C If 10 failures have occurred, exit with KFLAG = -1. 17671 C It is assumed that the derivatives that have accumulated in the 17672 C YH array have errors of the wrong order. Hence the first 17673 C derivative is recomputed, and the order is set to 1. Then 17674 C H is reduced by a factor of 10, and the step is retried, 17675 C until it succeeds or H reaches HMIN. 17676 C----------------------------------------------------------------------- 17677 640 IF (KFLAG .EQ. -10) GO TO 660 17678 RH = 0.1D0 17679 RH = MAX(HMIN/ABS(H),RH) 17680 H = H*RH 17681 DO 645 I = 1,N 17682 645 Y(I) = YH(I,1) 17683 CALL F (NEQ, TN, Y, SAVF) 17684 NFE = NFE + 1 17685 DO 650 I = 1,N 17686 650 YH(I,2) = H*SAVF(I) 17687 IPUP = MITER 17688 IALTH = 5 17689 IF (NQ .EQ. 1) GO TO 200 17690 NQ = 1 17691 L = 2 17692 IRET = 3 17693 GO TO 150 17694 C----------------------------------------------------------------------- 17695 C All returns are made through this section. H is saved in HOLD 17696 C to allow the caller to change H on the next step. 17697 C----------------------------------------------------------------------- 17698 660 KFLAG = -1 17699 GO TO 720 17700 670 KFLAG = -2 17701 GO TO 720 17702 680 KFLAG = -3 17703 GO TO 720 17704 690 RMAX = 10.0D0 17705 700 R = 1.0D0/TESCO(2,NQU) 17706 DO 710 I = 1,N 17707 710 ACOR(I) = ACOR(I)*R 17708 720 HOLD = H 17709 JSTART = 1 17710 RETURN 17711 C----------------------- END OF SUBROUTINE DSTODE ---------------------- 17712 END 17713 *DECK DEWSET 17714 SUBROUTINE DEWSET (N, ITOL, RTOL, ATOL, YCUR, EWT) 17715 C***BEGIN PROLOGUE DEWSET 17716 C***SUBSIDIARY 17717 C***PURPOSE Set error weight vector. 17718 C***TYPE DOUBLE PRECISION (SEWSET-S, DEWSET-D) 17719 C***AUTHOR Hindmarsh, Alan C., (LLNL) 17720 C***DESCRIPTION 17721 C 17722 C This subroutine sets the error weight vector EWT according to 17723 C EWT(i) = RTOL(i)*ABS(YCUR(i)) + ATOL(i), i = 1,...,N, 17724 C with the subscript on RTOL and/or ATOL possibly replaced by 1 above, 17725 C depending on the value of ITOL. 17726 C 17727 C***SEE ALSO DLSODE 17728 C***ROUTINES CALLED (NONE) 17729 C***REVISION HISTORY (YYMMDD) 17730 C 791129 DATE WRITTEN 17731 C 890501 Modified prologue to SLATEC/LDOC format. (FNF) 17732 C 890503 Minor cosmetic changes. (FNF) 17733 C 930809 Renamed to allow single/double precision versions. (ACH) 17734 C***END PROLOGUE DEWSET 17735 C**End 17736 INTEGER N, ITOL 17737 INTEGER I 17738 DOUBLE PRECISION RTOL, ATOL, YCUR, EWT 17739 DIMENSION RTOL(*), ATOL(*), YCUR(N), EWT(N) 17740 C 17741 C***FIRST EXECUTABLE STATEMENT DEWSET 17742 GO TO (10, 20, 30, 40), ITOL 17743 10 CONTINUE 17744 DO 15 I = 1,N 17745 15 EWT(I) = RTOL(1)*ABS(YCUR(I)) + ATOL(1) 17746 RETURN 17747 20 CONTINUE 17748 DO 25 I = 1,N 17749 25 EWT(I) = RTOL(1)*ABS(YCUR(I)) + ATOL(I) 17750 RETURN 17751 30 CONTINUE 17752 DO 35 I = 1,N 17753 35 EWT(I) = RTOL(I)*ABS(YCUR(I)) + ATOL(1) 17754 RETURN 17755 40 CONTINUE 17756 DO 45 I = 1,N 17757 45 EWT(I) = RTOL(I)*ABS(YCUR(I)) + ATOL(I) 17758 RETURN 17759 C----------------------- END OF SUBROUTINE DEWSET ---------------------- 17760 END 17761 *DECK DVNORM 17762 DOUBLE PRECISION FUNCTION DVNORM (N, V, W) 17763 C***BEGIN PROLOGUE DVNORM 17764 C***SUBSIDIARY 17765 C***PURPOSE Weighted root-mean-square vector norm. 17766 C***TYPE DOUBLE PRECISION (SVNORM-S, DVNORM-D) 17767 C***AUTHOR Hindmarsh, Alan C., (LLNL) 17768 C***DESCRIPTION 17769 C 17770 C This function routine computes the weighted root-mean-square norm 17771 C of the vector of length N contained in the array V, with weights 17772 C contained in the array W of length N: 17773 C DVNORM = SQRT( (1/N) * SUM( V(i)*W(i) )**2 ) 17774 C 17775 C***SEE ALSO DLSODE 17776 C***ROUTINES CALLED (NONE) 17777 C***REVISION HISTORY (YYMMDD) 17778 C 791129 DATE WRITTEN 17779 C 890501 Modified prologue to SLATEC/LDOC format. (FNF) 17780 C 890503 Minor cosmetic changes. (FNF) 17781 C 930809 Renamed to allow single/double precision versions. (ACH) 17782 C***END PROLOGUE DVNORM 17783 C**End 17784 INTEGER N, I 17785 DOUBLE PRECISION V, W, SUM 17786 DIMENSION V(N), W(N) 17787 C 17788 C***FIRST EXECUTABLE STATEMENT DVNORM 17789 SUM = 0.0D0 17790 DO 10 I = 1,N 17791 10 SUM = SUM + (V(I)*W(I))**2 17792 DVNORM = SQRT(SUM/N) 17793 RETURN 17794 C----------------------- END OF FUNCTION DVNORM ------------------------ 17795 END 17796 *DECK DIPREP 17797 SUBROUTINE DIPREP (NEQ, Y, RWORK, IA, JA, IPFLAG, F, JAC) 17798 EXTERNAL F, JAC 17799 INTEGER NEQ, IA, JA, IPFLAG 17800 DOUBLE PRECISION Y, RWORK 17801 DIMENSION NEQ(*), Y(*), RWORK(*), IA(*), JA(*) 17802 INTEGER IOWND, IOWNS, 17803 1 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 17804 2 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 17805 3 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU 17806 INTEGER IPLOST, IESP, ISTATC, IYS, IBA, IBIAN, IBJAN, IBJGP, 17807 1 IPIAN, IPJAN, IPJGP, IPIGP, IPR, IPC, IPIC, IPISP, IPRSP, IPA, 17808 2 LENYH, LENYHM, LENWK, LREQ, LRAT, LREST, LWMIN, MOSS, MSBJ, 17809 3 NSLJ, NGP, NLU, NNZ, NSP, NZL, NZU 17810 DOUBLE PRECISION ROWNS, 17811 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND 17812 DOUBLE PRECISION RLSS 17813 COMMON /DLS001/ ROWNS(209), 17814 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND, 17815 2 IOWND(6), IOWNS(6), 17816 3 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 17817 4 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 17818 5 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU 17819 COMMON /DLSS01/ RLSS(6), 17820 1 IPLOST, IESP, ISTATC, IYS, IBA, IBIAN, IBJAN, IBJGP, 17821 2 IPIAN, IPJAN, IPJGP, IPIGP, IPR, IPC, IPIC, IPISP, IPRSP, IPA, 17822 3 LENYH, LENYHM, LENWK, LREQ, LRAT, LREST, LWMIN, MOSS, MSBJ, 17823 4 NSLJ, NGP, NLU, NNZ, NSP, NZL, NZU 17824 INTEGER I, IMAX, LEWTN, LYHD, LYHN 17825 C----------------------------------------------------------------------- 17826 C This routine serves as an interface between the driver and 17827 C Subroutine DPREP. It is called only if MITER is 1 or 2. 17828 C Tasks performed here are: 17829 C * call DPREP, 17830 C * reset the required WM segment length LENWK, 17831 C * move YH back to its final location (following WM in RWORK), 17832 C * reset pointers for YH, SAVF, EWT, and ACOR, and 17833 C * move EWT to its new position if ISTATE = 1. 17834 C IPFLAG is an output error indication flag. IPFLAG = 0 if there was 17835 C no trouble, and IPFLAG is the value of the DPREP error flag IPPER 17836 C if there was trouble in Subroutine DPREP. 17837 C----------------------------------------------------------------------- 17838 IPFLAG = 0 17839 C Call DPREP to do matrix preprocessing operations. -------------------- 17840 CALL DPREP (NEQ, Y, RWORK(LYH), RWORK(LSAVF), RWORK(LEWT), 17841 1 RWORK(LACOR), IA, JA, RWORK(LWM), RWORK(LWM), IPFLAG, F, JAC) 17842 LENWK = MAX(LREQ,LWMIN) 17843 IF (IPFLAG .LT. 0) RETURN 17844 C If DPREP was successful, move YH to end of required space for WM. ---- 17845 LYHN = LWM + LENWK 17846 IF (LYHN .GT. LYH) RETURN 17847 LYHD = LYH - LYHN 17848 IF (LYHD .EQ. 0) GO TO 20 17849 IMAX = LYHN - 1 + LENYHM 17850 DO 10 I = LYHN,IMAX 17851 10 RWORK(I) = RWORK(I+LYHD) 17852 LYH = LYHN 17853 C Reset pointers for SAVF, EWT, and ACOR. ------------------------------ 17854 20 LSAVF = LYH + LENYH 17855 LEWTN = LSAVF + N 17856 LACOR = LEWTN + N 17857 IF (ISTATC .EQ. 3) GO TO 40 17858 C If ISTATE = 1, move EWT (left) to its new position. ------------------ 17859 IF (LEWTN .GT. LEWT) RETURN 17860 DO 30 I = 1,N 17861 30 RWORK(I+LEWTN-1) = RWORK(I+LEWT-1) 17862 40 LEWT = LEWTN 17863 RETURN 17864 C----------------------- End of Subroutine DIPREP ---------------------- 17865 END 17866 *DECK DPREP 17867 SUBROUTINE DPREP (NEQ, Y, YH, SAVF, EWT, FTEM, IA, JA, 17868 1 WK, IWK, IPPER, F, JAC) 17869 EXTERNAL F,JAC 17870 INTEGER NEQ, IA, JA, IWK, IPPER 17871 DOUBLE PRECISION Y, YH, SAVF, EWT, FTEM, WK 17872 DIMENSION NEQ(*), Y(*), YH(*), SAVF(*), EWT(*), FTEM(*), 17873 1 IA(*), JA(*), WK(*), IWK(*) 17874 INTEGER IOWND, IOWNS, 17875 1 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 17876 2 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 17877 3 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU 17878 INTEGER IPLOST, IESP, ISTATC, IYS, IBA, IBIAN, IBJAN, IBJGP, 17879 1 IPIAN, IPJAN, IPJGP, IPIGP, IPR, IPC, IPIC, IPISP, IPRSP, IPA, 17880 2 LENYH, LENYHM, LENWK, LREQ, LRAT, LREST, LWMIN, MOSS, MSBJ, 17881 3 NSLJ, NGP, NLU, NNZ, NSP, NZL, NZU 17882 DOUBLE PRECISION ROWNS, 17883 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND 17884 DOUBLE PRECISION CON0, CONMIN, CCMXJ, PSMALL, RBIG, SETH 17885 COMMON /DLS001/ ROWNS(209), 17886 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND, 17887 2 IOWND(6), IOWNS(6), 17888 3 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 17889 4 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 17890 5 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU 17891 COMMON /DLSS01/ CON0, CONMIN, CCMXJ, PSMALL, RBIG, SETH, 17892 1 IPLOST, IESP, ISTATC, IYS, IBA, IBIAN, IBJAN, IBJGP, 17893 2 IPIAN, IPJAN, IPJGP, IPIGP, IPR, IPC, IPIC, IPISP, IPRSP, IPA, 17894 3 LENYH, LENYHM, LENWK, LREQ, LRAT, LREST, LWMIN, MOSS, MSBJ, 17895 4 NSLJ, NGP, NLU, NNZ, NSP, NZL, NZU 17896 INTEGER I, IBR, IER, IPIL, IPIU, IPTT1, IPTT2, J, JFOUND, K, 17897 1 KNEW, KMAX, KMIN, LDIF, LENIGP, LIWK, MAXG, NP1, NZSUT 17898 DOUBLE PRECISION DQ, DYJ, ERWT, FAC, YJ 17899 C----------------------------------------------------------------------- 17900 C This routine performs preprocessing related to the sparse linear 17901 C systems that must be solved if MITER = 1 or 2. 17902 C The operations that are performed here are: 17903 C * compute sparseness structure of Jacobian according to MOSS, 17904 C * compute grouping of column indices (MITER = 2), 17905 C * compute a new ordering of rows and columns of the matrix, 17906 C * reorder JA corresponding to the new ordering, 17907 C * perform a symbolic LU factorization of the matrix, and 17908 C * set pointers for segments of the IWK/WK array. 17909 C In addition to variables described previously, DPREP uses the 17910 C following for communication: 17911 C YH = the history array. Only the first column, containing the 17912 C current Y vector, is used. Used only if MOSS .ne. 0. 17913 C SAVF = a work array of length NEQ, used only if MOSS .ne. 0. 17914 C EWT = array of length NEQ containing (inverted) error weights. 17915 C Used only if MOSS = 2 or if ISTATE = MOSS = 1. 17916 C FTEM = a work array of length NEQ, identical to ACOR in the driver, 17917 C used only if MOSS = 2. 17918 C WK = a real work array of length LENWK, identical to WM in 17919 C the driver. 17920 C IWK = integer work array, assumed to occupy the same space as WK. 17921 C LENWK = the length of the work arrays WK and IWK. 17922 C ISTATC = a copy of the driver input argument ISTATE (= 1 on the 17923 C first call, = 3 on a continuation call). 17924 C IYS = flag value from ODRV or CDRV. 17925 C IPPER = output error flag with the following values and meanings: 17926 C 0 no error. 17927 C -1 insufficient storage for internal structure pointers. 17928 C -2 insufficient storage for JGROUP. 17929 C -3 insufficient storage for ODRV. 17930 C -4 other error flag from ODRV (should never occur). 17931 C -5 insufficient storage for CDRV. 17932 C -6 other error flag from CDRV. 17933 C----------------------------------------------------------------------- 17934 IBIAN = LRAT*2 17935 IPIAN = IBIAN + 1 17936 NP1 = N + 1 17937 IPJAN = IPIAN + NP1 17938 IBJAN = IPJAN - 1 17939 LIWK = LENWK*LRAT 17940 IF (IPJAN+N-1 .GT. LIWK) GO TO 210 17941 IF (MOSS .EQ. 0) GO TO 30 17942 C 17943 IF (ISTATC .EQ. 3) GO TO 20 17944 C ISTATE = 1 and MOSS .ne. 0. Perturb Y for structure determination. -- 17945 DO 10 I = 1,N 17946 ERWT = 1.0D0/EWT(I) 17947 FAC = 1.0D0 + 1.0D0/(I + 1.0D0) 17948 Y(I) = Y(I) + FAC*SIGN(ERWT,Y(I)) 17949 10 CONTINUE 17950 GO TO (70, 100), MOSS 17951 C 17952 20 CONTINUE 17953 C ISTATE = 3 and MOSS .ne. 0. Load Y from YH(*,1). -------------------- 17954 DO 25 I = 1,N 17955 25 Y(I) = YH(I) 17956 GO TO (70, 100), MOSS 17957 C 17958 C MOSS = 0. Process user's IA,JA. Add diagonal entries if necessary. - 17959 30 KNEW = IPJAN 17960 KMIN = IA(1) 17961 IWK(IPIAN) = 1 17962 DO 60 J = 1,N 17963 JFOUND = 0 17964 KMAX = IA(J+1) - 1 17965 IF (KMIN .GT. KMAX) GO TO 45 17966 DO 40 K = KMIN,KMAX 17967 I = JA(K) 17968 IF (I .EQ. J) JFOUND = 1 17969 IF (KNEW .GT. LIWK) GO TO 210 17970 IWK(KNEW) = I 17971 KNEW = KNEW + 1 17972 40 CONTINUE 17973 IF (JFOUND .EQ. 1) GO TO 50 17974 45 IF (KNEW .GT. LIWK) GO TO 210 17975 IWK(KNEW) = J 17976 KNEW = KNEW + 1 17977 50 IWK(IPIAN+J) = KNEW + 1 - IPJAN 17978 KMIN = KMAX + 1 17979 60 CONTINUE 17980 GO TO 140 17981 C 17982 C MOSS = 1. Compute structure from user-supplied Jacobian routine JAC. 17983 70 CONTINUE 17984 C A dummy call to F allows user to create temporaries for use in JAC. -- 17985 CALL F (NEQ, TN, Y, SAVF) 17986 K = IPJAN 17987 IWK(IPIAN) = 1 17988 DO 90 J = 1,N 17989 IF (K .GT. LIWK) GO TO 210 17990 IWK(K) = J 17991 K = K + 1 17992 DO 75 I = 1,N 17993 75 SAVF(I) = 0.0D0 17994 CALL JAC (NEQ, TN, Y, J, IWK(IPIAN), IWK(IPJAN), SAVF) 17995 DO 80 I = 1,N 17996 IF (ABS(SAVF(I)) .LE. SETH) GO TO 80 17997 IF (I .EQ. J) GO TO 80 17998 IF (K .GT. LIWK) GO TO 210 17999 IWK(K) = I 18000 K = K + 1 18001 80 CONTINUE 18002 IWK(IPIAN+J) = K + 1 - IPJAN 18003 90 CONTINUE 18004 GO TO 140 18005 C 18006 C MOSS = 2. Compute structure from results of N + 1 calls to F. ------- 18007 100 K = IPJAN 18008 IWK(IPIAN) = 1 18009 CALL F (NEQ, TN, Y, SAVF) 18010 DO 120 J = 1,N 18011 IF (K .GT. LIWK) GO TO 210 18012 IWK(K) = J 18013 K = K + 1 18014 YJ = Y(J) 18015 ERWT = 1.0D0/EWT(J) 18016 DYJ = SIGN(ERWT,YJ) 18017 Y(J) = YJ + DYJ 18018 CALL F (NEQ, TN, Y, FTEM) 18019 Y(J) = YJ 18020 DO 110 I = 1,N 18021 DQ = (FTEM(I) - SAVF(I))/DYJ 18022 IF (ABS(DQ) .LE. SETH) GO TO 110 18023 IF (I .EQ. J) GO TO 110 18024 IF (K .GT. LIWK) GO TO 210 18025 IWK(K) = I 18026 K = K + 1 18027 110 CONTINUE 18028 IWK(IPIAN+J) = K + 1 - IPJAN 18029 120 CONTINUE 18030 C 18031 140 CONTINUE 18032 IF (MOSS .EQ. 0 .OR. ISTATC .NE. 1) GO TO 150 18033 C If ISTATE = 1 and MOSS .ne. 0, restore Y from YH. -------------------- 18034 DO 145 I = 1,N 18035 145 Y(I) = YH(I) 18036 150 NNZ = IWK(IPIAN+N) - 1 18037 LENIGP = 0 18038 IPIGP = IPJAN + NNZ 18039 IF (MITER .NE. 2) GO TO 160 18040 C 18041 C Compute grouping of column indices (MITER = 2). ---------------------- 18042 MAXG = NP1 18043 IPJGP = IPJAN + NNZ 18044 IBJGP = IPJGP - 1 18045 IPIGP = IPJGP + N 18046 IPTT1 = IPIGP + NP1 18047 IPTT2 = IPTT1 + N 18048 LREQ = IPTT2 + N - 1 18049 IF (LREQ .GT. LIWK) GO TO 220 18050 CALL JGROUP (N, IWK(IPIAN), IWK(IPJAN), MAXG, NGP, IWK(IPIGP), 18051 1 IWK(IPJGP), IWK(IPTT1), IWK(IPTT2), IER) 18052 IF (IER .NE. 0) GO TO 220 18053 LENIGP = NGP + 1 18054 C 18055 C Compute new ordering of rows/columns of Jacobian. -------------------- 18056 160 IPR = IPIGP + LENIGP 18057 IPC = IPR 18058 IPIC = IPC + N 18059 IPISP = IPIC + N 18060 IPRSP = (IPISP - 2)/LRAT + 2 18061 IESP = LENWK + 1 - IPRSP 18062 IF (IESP .LT. 0) GO TO 230 18063 IBR = IPR - 1 18064 DO 170 I = 1,N 18065 170 IWK(IBR+I) = I 18066 NSP = LIWK + 1 - IPISP 18067 CALL ODRV (N, IWK(IPIAN), IWK(IPJAN), WK, IWK(IPR), IWK(IPIC), 18068 1 NSP, IWK(IPISP), 1, IYS) 18069 IF (IYS .EQ. 11*N+1) GO TO 240 18070 IF (IYS .NE. 0) GO TO 230 18071 C 18072 C Reorder JAN and do symbolic LU factorization of matrix. -------------- 18073 IPA = LENWK + 1 - NNZ 18074 NSP = IPA - IPRSP 18075 LREQ = MAX(12*N/LRAT, 6*N/LRAT+2*N+NNZ) + 3 18076 LREQ = LREQ + IPRSP - 1 + NNZ 18077 IF (LREQ .GT. LENWK) GO TO 250 18078 IBA = IPA - 1 18079 DO 180 I = 1,NNZ 18080 180 WK(IBA+I) = 0.0D0 18081 IPISP = LRAT*(IPRSP - 1) + 1 18082 CALL CDRV (N,IWK(IPR),IWK(IPC),IWK(IPIC),IWK(IPIAN),IWK(IPJAN), 18083 1 WK(IPA),WK(IPA),WK(IPA),NSP,IWK(IPISP),WK(IPRSP),IESP,5,IYS) 18084 LREQ = LENWK - IESP 18085 IF (IYS .EQ. 10*N+1) GO TO 250 18086 IF (IYS .NE. 0) GO TO 260 18087 IPIL = IPISP 18088 IPIU = IPIL + 2*N + 1 18089 NZU = IWK(IPIL+N) - IWK(IPIL) 18090 NZL = IWK(IPIU+N) - IWK(IPIU) 18091 IF (LRAT .GT. 1) GO TO 190 18092 CALL ADJLR (N, IWK(IPISP), LDIF) 18093 LREQ = LREQ + LDIF 18094 190 CONTINUE 18095 IF (LRAT .EQ. 2 .AND. NNZ .EQ. N) LREQ = LREQ + 1 18096 NSP = NSP + LREQ - LENWK 18097 IPA = LREQ + 1 - NNZ 18098 IBA = IPA - 1 18099 IPPER = 0 18100 RETURN 18101 C 18102 210 IPPER = -1 18103 LREQ = 2 + (2*N + 1)/LRAT 18104 LREQ = MAX(LENWK+1,LREQ) 18105 RETURN 18106 C 18107 220 IPPER = -2 18108 LREQ = (LREQ - 1)/LRAT + 1 18109 RETURN 18110 C 18111 230 IPPER = -3 18112 CALL CNTNZU (N, IWK(IPIAN), IWK(IPJAN), NZSUT) 18113 LREQ = LENWK - IESP + (3*N + 4*NZSUT - 1)/LRAT + 1 18114 RETURN 18115 C 18116 240 IPPER = -4 18117 RETURN 18118 C 18119 250 IPPER = -5 18120 RETURN 18121 C 18122 260 IPPER = -6 18123 LREQ = LENWK 18124 RETURN 18125 C----------------------- End of Subroutine DPREP ----------------------- 18126 END 18127 *DECK JGROUP 18128 SUBROUTINE JGROUP (N,IA,JA,MAXG,NGRP,IGP,JGP,INCL,JDONE,IER) 18129 INTEGER N, IA, JA, MAXG, NGRP, IGP, JGP, INCL, JDONE, IER 18130 DIMENSION IA(*), JA(*), IGP(*), JGP(*), INCL(*), JDONE(*) 18131 C----------------------------------------------------------------------- 18132 C This subroutine constructs groupings of the column indices of 18133 C the Jacobian matrix, used in the numerical evaluation of the 18134 C Jacobian by finite differences. 18135 C 18136 C Input: 18137 C N = the order of the matrix. 18138 C IA,JA = sparse structure descriptors of the matrix by rows. 18139 C MAXG = length of available storage in the IGP array. 18140 C 18141 C Output: 18142 C NGRP = number of groups. 18143 C JGP = array of length N containing the column indices by groups. 18144 C IGP = pointer array of length NGRP + 1 to the locations in JGP 18145 C of the beginning of each group. 18146 C IER = error indicator. IER = 0 if no error occurred, or 1 if 18147 C MAXG was insufficient. 18148 C 18149 C INCL and JDONE are working arrays of length N. 18150 C----------------------------------------------------------------------- 18151 INTEGER I, J, K, KMIN, KMAX, NCOL, NG 18152 C 18153 IER = 0 18154 DO 10 J = 1,N 18155 10 JDONE(J) = 0 18156 NCOL = 1 18157 DO 60 NG = 1,MAXG 18158 IGP(NG) = NCOL 18159 DO 20 I = 1,N 18160 20 INCL(I) = 0 18161 DO 50 J = 1,N 18162 C Reject column J if it is already in a group.-------------------------- 18163 IF (JDONE(J) .EQ. 1) GO TO 50 18164 KMIN = IA(J) 18165 KMAX = IA(J+1) - 1 18166 DO 30 K = KMIN,KMAX 18167 C Reject column J if it overlaps any column already in this group.------ 18168 I = JA(K) 18169 IF (INCL(I) .EQ. 1) GO TO 50 18170 30 CONTINUE 18171 C Accept column J into group NG.---------------------------------------- 18172 JGP(NCOL) = J 18173 NCOL = NCOL + 1 18174 JDONE(J) = 1 18175 DO 40 K = KMIN,KMAX 18176 I = JA(K) 18177 40 INCL(I) = 1 18178 50 CONTINUE 18179 C Stop if this group is empty (grouping is complete).------------------- 18180 IF (NCOL .EQ. IGP(NG)) GO TO 70 18181 60 CONTINUE 18182 C Error return if not all columns were chosen (MAXG too small).--------- 18183 IF (NCOL .LE. N) GO TO 80 18184 NG = MAXG 18185 70 NGRP = NG - 1 18186 RETURN 18187 80 IER = 1 18188 RETURN 18189 C----------------------- End of Subroutine JGROUP ---------------------- 18190 END 18191 *DECK ADJLR 18192 SUBROUTINE ADJLR (N, ISP, LDIF) 18193 INTEGER N, ISP, LDIF 18194 DIMENSION ISP(*) 18195 C----------------------------------------------------------------------- 18196 C This routine computes an adjustment, LDIF, to the required 18197 C integer storage space in IWK (sparse matrix work space). 18198 C It is called only if the word length ratio is LRAT = 1. 18199 C This is to account for the possibility that the symbolic LU phase 18200 C may require more storage than the numerical LU and solution phases. 18201 C----------------------------------------------------------------------- 18202 INTEGER IP, JLMAX, JUMAX, LNFC, LSFC, NZLU 18203 C 18204 IP = 2*N + 1 18205 C Get JLMAX = IJL(N) and JUMAX = IJU(N) (sizes of JL and JU). ---------- 18206 JLMAX = ISP(IP) 18207 JUMAX = ISP(IP+IP) 18208 C NZLU = (size of L) + (size of U) = (IL(N+1)-IL(1)) + (IU(N+1)-IU(1)). 18209 NZLU = ISP(N+1) - ISP(1) + ISP(IP+N+1) - ISP(IP+1) 18210 LSFC = 12*N + 3 + 2*MAX(JLMAX,JUMAX) 18211 LNFC = 9*N + 2 + JLMAX + JUMAX + NZLU 18212 LDIF = MAX(0, LSFC - LNFC) 18213 RETURN 18214 C----------------------- End of Subroutine ADJLR ----------------------- 18215 END 18216 *DECK CNTNZU 18217 SUBROUTINE CNTNZU (N, IA, JA, NZSUT) 18218 INTEGER N, IA, JA, NZSUT 18219 DIMENSION IA(*), JA(*) 18220 C----------------------------------------------------------------------- 18221 C This routine counts the number of nonzero elements in the strict 18222 C upper triangle of the matrix M + M(transpose), where the sparsity 18223 C structure of M is given by pointer arrays IA and JA. 18224 C This is needed to compute the storage requirements for the 18225 C sparse matrix reordering operation in ODRV. 18226 C----------------------------------------------------------------------- 18227 INTEGER II, JJ, J, JMIN, JMAX, K, KMIN, KMAX, NUM 18228 C 18229 NUM = 0 18230 DO 50 II = 1,N 18231 JMIN = IA(II) 18232 JMAX = IA(II+1) - 1 18233 IF (JMIN .GT. JMAX) GO TO 50 18234 DO 40 J = JMIN,JMAX 18235 IF (JA(J) - II) 10, 40, 30 18236 10 JJ =JA(J) 18237 KMIN = IA(JJ) 18238 KMAX = IA(JJ+1) - 1 18239 IF (KMIN .GT. KMAX) GO TO 30 18240 DO 20 K = KMIN,KMAX 18241 IF (JA(K) .EQ. II) GO TO 40 18242 20 CONTINUE 18243 30 NUM = NUM + 1 18244 40 CONTINUE 18245 50 CONTINUE 18246 NZSUT = NUM 18247 RETURN 18248 C----------------------- End of Subroutine CNTNZU ---------------------- 18249 END 18250 *DECK DPRJS 18251 SUBROUTINE DPRJS (NEQ,Y,YH,NYH,EWT,FTEM,SAVF,WK,IWK,F,JAC) 18252 EXTERNAL F,JAC 18253 INTEGER NEQ, NYH, IWK 18254 DOUBLE PRECISION Y, YH, EWT, FTEM, SAVF, WK 18255 DIMENSION NEQ(*), Y(*), YH(NYH,*), EWT(*), FTEM(*), SAVF(*), 18256 1 WK(*), IWK(*) 18257 INTEGER IOWND, IOWNS, 18258 1 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 18259 2 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 18260 3 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU 18261 INTEGER IPLOST, IESP, ISTATC, IYS, IBA, IBIAN, IBJAN, IBJGP, 18262 1 IPIAN, IPJAN, IPJGP, IPIGP, IPR, IPC, IPIC, IPISP, IPRSP, IPA, 18263 2 LENYH, LENYHM, LENWK, LREQ, LRAT, LREST, LWMIN, MOSS, MSBJ, 18264 3 NSLJ, NGP, NLU, NNZ, NSP, NZL, NZU 18265 DOUBLE PRECISION ROWNS, 18266 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND 18267 DOUBLE PRECISION CON0, CONMIN, CCMXJ, PSMALL, RBIG, SETH 18268 COMMON /DLS001/ ROWNS(209), 18269 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND, 18270 2 IOWND(6), IOWNS(6), 18271 3 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 18272 4 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 18273 5 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU 18274 COMMON /DLSS01/ CON0, CONMIN, CCMXJ, PSMALL, RBIG, SETH, 18275 1 IPLOST, IESP, ISTATC, IYS, IBA, IBIAN, IBJAN, IBJGP, 18276 2 IPIAN, IPJAN, IPJGP, IPIGP, IPR, IPC, IPIC, IPISP, IPRSP, IPA, 18277 3 LENYH, LENYHM, LENWK, LREQ, LRAT, LREST, LWMIN, MOSS, MSBJ, 18278 4 NSLJ, NGP, NLU, NNZ, NSP, NZL, NZU 18279 INTEGER I, IMUL, J, JJ, JOK, JMAX, JMIN, K, KMAX, KMIN, NG 18280 DOUBLE PRECISION CON, DI, FAC, HL0, PIJ, R, R0, RCON, RCONT, 18281 1 SRUR, DVNORM 18282 C----------------------------------------------------------------------- 18283 C DPRJS is called to compute and process the matrix 18284 C P = I - H*EL(1)*J , where J is an approximation to the Jacobian. 18285 C J is computed by columns, either by the user-supplied routine JAC 18286 C if MITER = 1, or by finite differencing if MITER = 2. 18287 C if MITER = 3, a diagonal approximation to J is used. 18288 C if MITER = 1 or 2, and if the existing value of the Jacobian 18289 C (as contained in P) is considered acceptable, then a new value of 18290 C P is reconstructed from the old value. In any case, when MITER 18291 C is 1 or 2, the P matrix is subjected to LU decomposition in CDRV. 18292 C P and its LU decomposition are stored (separately) in WK. 18293 C 18294 C In addition to variables described previously, communication 18295 C with DPRJS uses the following: 18296 C Y = array containing predicted values on entry. 18297 C FTEM = work array of length N (ACOR in DSTODE). 18298 C SAVF = array containing f evaluated at predicted y. 18299 C WK = real work space for matrices. On output it contains the 18300 C inverse diagonal matrix if MITER = 3, and P and its sparse 18301 C LU decomposition if MITER is 1 or 2. 18302 C Storage of matrix elements starts at WK(3). 18303 C WK also contains the following matrix-related data: 18304 C WK(1) = SQRT(UROUND), used in numerical Jacobian increments. 18305 C WK(2) = H*EL0, saved for later use if MITER = 3. 18306 C IWK = integer work space for matrix-related data, assumed to 18307 C be equivalenced to WK. In addition, WK(IPRSP) and IWK(IPISP) 18308 C are assumed to have identical locations. 18309 C EL0 = EL(1) (input). 18310 C IERPJ = output error flag (in Common). 18311 C = 0 if no error. 18312 C = 1 if zero pivot found in CDRV. 18313 C = 2 if a singular matrix arose with MITER = 3. 18314 C = -1 if insufficient storage for CDRV (should not occur here). 18315 C = -2 if other error found in CDRV (should not occur here). 18316 C JCUR = output flag showing status of (approximate) Jacobian matrix: 18317 C = 1 to indicate that the Jacobian is now current, or 18318 C = 0 to indicate that a saved value was used. 18319 C This routine also uses other variables in Common. 18320 C----------------------------------------------------------------------- 18321 HL0 = H*EL0 18322 CON = -HL0 18323 IF (MITER .EQ. 3) GO TO 300 18324 C See whether J should be reevaluated (JOK = 0) or not (JOK = 1). ------ 18325 JOK = 1 18326 IF (NST .EQ. 0 .OR. NST .GE. NSLJ+MSBJ) JOK = 0 18327 IF (ICF .EQ. 1 .AND. ABS(RC - 1.0D0) .LT. CCMXJ) JOK = 0 18328 IF (ICF .EQ. 2) JOK = 0 18329 IF (JOK .EQ. 1) GO TO 250 18330 C 18331 C MITER = 1 or 2, and the Jacobian is to be reevaluated. --------------- 18332 20 JCUR = 1 18333 NJE = NJE + 1 18334 NSLJ = NST 18335 IPLOST = 0 18336 CONMIN = ABS(CON) 18337 GO TO (100, 200), MITER 18338 C 18339 C If MITER = 1, call JAC, multiply by scalar, and add identity. -------- 18340 100 CONTINUE 18341 KMIN = IWK(IPIAN) 18342 DO 130 J = 1, N 18343 KMAX = IWK(IPIAN+J) - 1 18344 DO 110 I = 1,N 18345 110 FTEM(I) = 0.0D0 18346 CALL JAC (NEQ, TN, Y, J, IWK(IPIAN), IWK(IPJAN), FTEM) 18347 DO 120 K = KMIN, KMAX 18348 I = IWK(IBJAN+K) 18349 WK(IBA+K) = FTEM(I)*CON 18350 IF (I .EQ. J) WK(IBA+K) = WK(IBA+K) + 1.0D0 18351 120 CONTINUE 18352 KMIN = KMAX + 1 18353 130 CONTINUE 18354 GO TO 290 18355 C 18356 C If MITER = 2, make NGP calls to F to approximate J and P. ------------ 18357 200 CONTINUE 18358 FAC = DVNORM(N, SAVF, EWT) 18359 R0 = 1000.0D0 * ABS(H) * UROUND * N * FAC 18360 IF (R0 .EQ. 0.0D0) R0 = 1.0D0 18361 SRUR = WK(1) 18362 JMIN = IWK(IPIGP) 18363 DO 240 NG = 1,NGP 18364 JMAX = IWK(IPIGP+NG) - 1 18365 DO 210 J = JMIN,JMAX 18366 JJ = IWK(IBJGP+J) 18367 R = MAX(SRUR*ABS(Y(JJ)),R0/EWT(JJ)) 18368 210 Y(JJ) = Y(JJ) + R 18369 CALL F (NEQ, TN, Y, FTEM) 18370 DO 230 J = JMIN,JMAX 18371 JJ = IWK(IBJGP+J) 18372 Y(JJ) = YH(JJ,1) 18373 R = MAX(SRUR*ABS(Y(JJ)),R0/EWT(JJ)) 18374 FAC = -HL0/R 18375 KMIN =IWK(IBIAN+JJ) 18376 KMAX =IWK(IBIAN+JJ+1) - 1 18377 DO 220 K = KMIN,KMAX 18378 I = IWK(IBJAN+K) 18379 WK(IBA+K) = (FTEM(I) - SAVF(I))*FAC 18380 IF (I .EQ. JJ) WK(IBA+K) = WK(IBA+K) + 1.0D0 18381 220 CONTINUE 18382 230 CONTINUE 18383 JMIN = JMAX + 1 18384 240 CONTINUE 18385 NFE = NFE + NGP 18386 GO TO 290 18387 C 18388 C If JOK = 1, reconstruct new P from old P. ---------------------------- 18389 250 JCUR = 0 18390 RCON = CON/CON0 18391 RCONT = ABS(CON)/CONMIN 18392 IF (RCONT .GT. RBIG .AND. IPLOST .EQ. 1) GO TO 20 18393 KMIN = IWK(IPIAN) 18394 DO 275 J = 1,N 18395 KMAX = IWK(IPIAN+J) - 1 18396 DO 270 K = KMIN,KMAX 18397 I = IWK(IBJAN+K) 18398 PIJ = WK(IBA+K) 18399 IF (I .NE. J) GO TO 260 18400 PIJ = PIJ - 1.0D0 18401 IF (ABS(PIJ) .GE. PSMALL) GO TO 260 18402 IPLOST = 1 18403 CONMIN = MIN(ABS(CON0),CONMIN) 18404 260 PIJ = PIJ*RCON 18405 IF (I .EQ. J) PIJ = PIJ + 1.0D0 18406 WK(IBA+K) = PIJ 18407 270 CONTINUE 18408 KMIN = KMAX + 1 18409 275 CONTINUE 18410 C 18411 C Do numerical factorization of P matrix. ------------------------------ 18412 290 NLU = NLU + 1 18413 CON0 = CON 18414 IERPJ = 0 18415 DO 295 I = 1,N 18416 295 FTEM(I) = 0.0D0 18417 CALL CDRV (N,IWK(IPR),IWK(IPC),IWK(IPIC),IWK(IPIAN),IWK(IPJAN), 18418 1 WK(IPA),FTEM,FTEM,NSP,IWK(IPISP),WK(IPRSP),IESP,2,IYS) 18419 IF (IYS .EQ. 0) RETURN 18420 IMUL = (IYS - 1)/N 18421 IERPJ = -2 18422 IF (IMUL .EQ. 8) IERPJ = 1 18423 IF (IMUL .EQ. 10) IERPJ = -1 18424 RETURN 18425 C 18426 C If MITER = 3, construct a diagonal approximation to J and P. --------- 18427 300 CONTINUE 18428 JCUR = 1 18429 NJE = NJE + 1 18430 WK(2) = HL0 18431 IERPJ = 0 18432 R = EL0*0.1D0 18433 DO 310 I = 1,N 18434 310 Y(I) = Y(I) + R*(H*SAVF(I) - YH(I,2)) 18435 CALL F (NEQ, TN, Y, WK(3)) 18436 NFE = NFE + 1 18437 DO 320 I = 1,N 18438 R0 = H*SAVF(I) - YH(I,2) 18439 DI = 0.1D0*R0 - H*(WK(I+2) - SAVF(I)) 18440 WK(I+2) = 1.0D0 18441 IF (ABS(R0) .LT. UROUND/EWT(I)) GO TO 320 18442 IF (ABS(DI) .EQ. 0.0D0) GO TO 330 18443 WK(I+2) = 0.1D0*R0/DI 18444 320 CONTINUE 18445 RETURN 18446 330 IERPJ = 2 18447 RETURN 18448 C----------------------- End of Subroutine DPRJS ----------------------- 18449 END 18450 *DECK DSOLSS 18451 SUBROUTINE DSOLSS (WK, IWK, X, TEM) 18452 INTEGER IWK 18453 DOUBLE PRECISION WK, X, TEM 18454 DIMENSION WK(*), IWK(*), X(*), TEM(*) 18455 INTEGER IOWND, IOWNS, 18456 1 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 18457 2 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 18458 3 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU 18459 INTEGER IPLOST, IESP, ISTATC, IYS, IBA, IBIAN, IBJAN, IBJGP, 18460 1 IPIAN, IPJAN, IPJGP, IPIGP, IPR, IPC, IPIC, IPISP, IPRSP, IPA, 18461 2 LENYH, LENYHM, LENWK, LREQ, LRAT, LREST, LWMIN, MOSS, MSBJ, 18462 3 NSLJ, NGP, NLU, NNZ, NSP, NZL, NZU 18463 DOUBLE PRECISION ROWNS, 18464 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND 18465 DOUBLE PRECISION RLSS 18466 COMMON /DLS001/ ROWNS(209), 18467 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND, 18468 2 IOWND(6), IOWNS(6), 18469 3 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 18470 4 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 18471 5 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU 18472 COMMON /DLSS01/ RLSS(6), 18473 1 IPLOST, IESP, ISTATC, IYS, IBA, IBIAN, IBJAN, IBJGP, 18474 2 IPIAN, IPJAN, IPJGP, IPIGP, IPR, IPC, IPIC, IPISP, IPRSP, IPA, 18475 3 LENYH, LENYHM, LENWK, LREQ, LRAT, LREST, LWMIN, MOSS, MSBJ, 18476 4 NSLJ, NGP, NLU, NNZ, NSP, NZL, NZU 18477 INTEGER I 18478 DOUBLE PRECISION DI, HL0, PHL0, R 18479 C----------------------------------------------------------------------- 18480 C This routine manages the solution of the linear system arising from 18481 C a chord iteration. It is called if MITER .ne. 0. 18482 C If MITER is 1 or 2, it calls CDRV to accomplish this. 18483 C If MITER = 3 it updates the coefficient H*EL0 in the diagonal 18484 C matrix, and then computes the solution. 18485 C communication with DSOLSS uses the following variables: 18486 C WK = real work space containing the inverse diagonal matrix if 18487 C MITER = 3 and the LU decomposition of the matrix otherwise. 18488 C Storage of matrix elements starts at WK(3). 18489 C WK also contains the following matrix-related data: 18490 C WK(1) = SQRT(UROUND) (not used here), 18491 C WK(2) = HL0, the previous value of H*EL0, used if MITER = 3. 18492 C IWK = integer work space for matrix-related data, assumed to 18493 C be equivalenced to WK. In addition, WK(IPRSP) and IWK(IPISP) 18494 C are assumed to have identical locations. 18495 C X = the right-hand side vector on input, and the solution vector 18496 C on output, of length N. 18497 C TEM = vector of work space of length N, not used in this version. 18498 C IERSL = output flag (in Common). 18499 C IERSL = 0 if no trouble occurred. 18500 C IERSL = -1 if CDRV returned an error flag (MITER = 1 or 2). 18501 C This should never occur and is considered fatal. 18502 C IERSL = 1 if a singular matrix arose with MITER = 3. 18503 C This routine also uses other variables in Common. 18504 C----------------------------------------------------------------------- 18505 IERSL = 0 18506 GO TO (100, 100, 300), MITER 18507 100 CALL CDRV (N,IWK(IPR),IWK(IPC),IWK(IPIC),IWK(IPIAN),IWK(IPJAN), 18508 1 WK(IPA),X,X,NSP,IWK(IPISP),WK(IPRSP),IESP,4,IERSL) 18509 IF (IERSL .NE. 0) IERSL = -1 18510 RETURN 18511 C 18512 300 PHL0 = WK(2) 18513 HL0 = H*EL0 18514 WK(2) = HL0 18515 IF (HL0 .EQ. PHL0) GO TO 330 18516 R = HL0/PHL0 18517 DO 320 I = 1,N 18518 DI = 1.0D0 - R*(1.0D0 - 1.0D0/WK(I+2)) 18519 IF (ABS(DI) .EQ. 0.0D0) GO TO 390 18520 320 WK(I+2) = 1.0D0/DI 18521 330 DO 340 I = 1,N 18522 340 X(I) = WK(I+2)*X(I) 18523 RETURN 18524 390 IERSL = 1 18525 RETURN 18526 C 18527 C----------------------- End of Subroutine DSOLSS ---------------------- 18528 END 18529 *DECK DSRCMS 18530 SUBROUTINE DSRCMS (RSAV, ISAV, JOB) 18531 C----------------------------------------------------------------------- 18532 C This routine saves or restores (depending on JOB) the contents of 18533 C the Common blocks DLS001, DLSS01, which are used 18534 C internally by one or more ODEPACK solvers. 18535 C 18536 C RSAV = real array of length 224 or more. 18537 C ISAV = integer array of length 71 or more. 18538 C JOB = flag indicating to save or restore the Common blocks: 18539 C JOB = 1 if Common is to be saved (written to RSAV/ISAV) 18540 C JOB = 2 if Common is to be restored (read from RSAV/ISAV) 18541 C A call with JOB = 2 presumes a prior call with JOB = 1. 18542 C----------------------------------------------------------------------- 18543 INTEGER ISAV, JOB 18544 INTEGER ILS, ILSS 18545 INTEGER I, LENILS, LENISS, LENRLS, LENRSS 18546 DOUBLE PRECISION RSAV, RLS, RLSS 18547 DIMENSION RSAV(*), ISAV(*) 18548 SAVE LENRLS, LENILS, LENRSS, LENISS 18549 COMMON /DLS001/ RLS(218), ILS(37) 18550 COMMON /DLSS01/ RLSS(6), ILSS(34) 18551 DATA LENRLS/218/, LENILS/37/, LENRSS/6/, LENISS/34/ 18552 C 18553 IF (JOB .EQ. 2) GO TO 100 18554 DO 10 I = 1,LENRLS 18555 10 RSAV(I) = RLS(I) 18556 DO 15 I = 1,LENRSS 18557 15 RSAV(LENRLS+I) = RLSS(I) 18558 C 18559 DO 20 I = 1,LENILS 18560 20 ISAV(I) = ILS(I) 18561 DO 25 I = 1,LENISS 18562 25 ISAV(LENILS+I) = ILSS(I) 18563 C 18564 RETURN 18565 C 18566 100 CONTINUE 18567 DO 110 I = 1,LENRLS 18568 110 RLS(I) = RSAV(I) 18569 DO 115 I = 1,LENRSS 18570 115 RLSS(I) = RSAV(LENRLS+I) 18571 C 18572 DO 120 I = 1,LENILS 18573 120 ILS(I) = ISAV(I) 18574 DO 125 I = 1,LENISS 18575 125 ILSS(I) = ISAV(LENILS+I) 18576 C 18577 RETURN 18578 C----------------------- End of Subroutine DSRCMS ---------------------- 18579 END 18580 *DECK ODRV 18581 subroutine odrv 18582 * (n, ia,ja,a, p,ip, nsp,isp, path, flag) 18583 c 5/2/83 18584 c*********************************************************************** 18585 c odrv -- driver for sparse matrix reordering routines 18586 c*********************************************************************** 18587 c 18588 c description 18589 c 18590 c odrv finds a minimum degree ordering of the rows and columns 18591 c of a matrix m stored in (ia,ja,a) format (see below). for the 18592 c reordered matrix, the work and storage required to perform 18593 c gaussian elimination is (usually) significantly less. 18594 c 18595 c note.. odrv and its subordinate routines have been modified to 18596 c compute orderings for general matrices, not necessarily having any 18597 c symmetry. the miminum degree ordering is computed for the 18598 c structure of the symmetric matrix m + m-transpose. 18599 c modifications to the original odrv module have been made in 18600 c the coding in subroutine mdi, and in the initial comments in 18601 c subroutines odrv and md. 18602 c 18603 c if only the nonzero entries in the upper triangle of m are being 18604 c stored, then odrv symmetrically reorders (ia,ja,a), (optionally) 18605 c with the diagonal entries placed first in each row. this is to 18606 c ensure that if m(i,j) will be in the upper triangle of m with 18607 c respect to the new ordering, then m(i,j) is stored in row i (and 18608 c thus m(j,i) is not stored), whereas if m(i,j) will be in the 18609 c strict lower triangle of m, then m(j,i) is stored in row j (and 18610 c thus m(i,j) is not stored). 18611 c 18612 c 18613 c storage of sparse matrices 18614 c 18615 c the nonzero entries of the matrix m are stored row-by-row in the 18616 c array a. to identify the individual nonzero entries in each row, 18617 c we need to know in which column each entry lies. these column 18618 c indices are stored in the array ja. i.e., if a(k) = m(i,j), then 18619 c ja(k) = j. to identify the individual rows, we need to know where 18620 c each row starts. these row pointers are stored in the array ia. 18621 c i.e., if m(i,j) is the first nonzero entry (stored) in the i-th row 18622 c and a(k) = m(i,j), then ia(i) = k. moreover, ia(n+1) points to 18623 c the first location following the last element in the last row. 18624 c thus, the number of entries in the i-th row is ia(i+1) - ia(i), 18625 c the nonzero entries in the i-th row are stored consecutively in 18626 c 18627 c a(ia(i)), a(ia(i)+1), ..., a(ia(i+1)-1), 18628 c 18629 c and the corresponding column indices are stored consecutively in 18630 c 18631 c ja(ia(i)), ja(ia(i)+1), ..., ja(ia(i+1)-1). 18632 c 18633 c when the coefficient matrix is symmetric, only the nonzero entries 18634 c in the upper triangle need be stored. for example, the matrix 18635 c 18636 c ( 1 0 2 3 0 ) 18637 c ( 0 4 0 0 0 ) 18638 c m = ( 2 0 5 6 0 ) 18639 c ( 3 0 6 7 8 ) 18640 c ( 0 0 0 8 9 ) 18641 c 18642 c could be stored as 18643 c 18644 c - 1 2 3 4 5 6 7 8 9 10 11 12 13 18645 c ---+-------------------------------------- 18646 c ia - 1 4 5 8 12 14 18647 c ja - 1 3 4 2 1 3 4 1 3 4 5 4 5 18648 c a - 1 2 3 4 2 5 6 3 6 7 8 8 9 18649 c 18650 c or (symmetrically) as 18651 c 18652 c - 1 2 3 4 5 6 7 8 9 18653 c ---+-------------------------- 18654 c ia - 1 4 5 7 9 10 18655 c ja - 1 3 4 2 3 4 4 5 5 18656 c a - 1 2 3 4 5 6 7 8 9 . 18657 c 18658 c 18659 c parameters 18660 c 18661 c n - order of the matrix 18662 c 18663 c ia - integer one-dimensional array containing pointers to delimit 18664 c rows in ja and a. dimension = n+1 18665 c 18666 c ja - integer one-dimensional array containing the column indices 18667 c corresponding to the elements of a. dimension = number of 18668 c nonzero entries in (the upper triangle of) m 18669 c 18670 c a - real one-dimensional array containing the nonzero entries in 18671 c (the upper triangle of) m, stored by rows. dimension = 18672 c number of nonzero entries in (the upper triangle of) m 18673 c 18674 c p - integer one-dimensional array used to return the permutation 18675 c of the rows and columns of m corresponding to the minimum 18676 c degree ordering. dimension = n 18677 c 18678 c ip - integer one-dimensional array used to return the inverse of 18679 c the permutation returned in p. dimension = n 18680 c 18681 c nsp - declared dimension of the one-dimensional array isp. nsp 18682 c must be at least 3n+4k, where k is the number of nonzeroes 18683 c in the strict upper triangle of m 18684 c 18685 c isp - integer one-dimensional array used for working storage. 18686 c dimension = nsp 18687 c 18688 c path - integer path specification. values and their meanings are - 18689 c 1 find minimum degree ordering only 18690 c 2 find minimum degree ordering and reorder symmetrically 18691 c stored matrix (used when only the nonzero entries in 18692 c the upper triangle of m are being stored) 18693 c 3 reorder symmetrically stored matrix as specified by 18694 c input permutation (used when an ordering has already 18695 c been determined and only the nonzero entries in the 18696 c upper triangle of m are being stored) 18697 c 4 same as 2 but put diagonal entries at start of each row 18698 c 5 same as 3 but put diagonal entries at start of each row 18699 c 18700 c flag - integer error flag. values and their meanings are - 18701 c 0 no errors detected 18702 c 9n+k insufficient storage in md 18703 c 10n+1 insufficient storage in odrv 18704 c 11n+1 illegal path specification 18705 c 18706 c 18707 c conversion from real to double precision 18708 c 18709 c change the real declarations in odrv and sro to double precision 18710 c declarations. 18711 c 18712 c----------------------------------------------------------------------- 18713 c 18714 integer ia(*), ja(*), p(*), ip(*), isp(*), path, flag, 18715 * v, l, head, tmp, q 18716 c... real a(*) 18717 double precision a(*) 18718 logical dflag 18719 c 18720 c----initialize error flag and validate path specification 18721 flag = 0 18722 if (path.lt.1 .or. 5.lt.path) go to 111 18723 c 18724 c----allocate storage and find minimum degree ordering 18725 if ((path-1) * (path-2) * (path-4) .ne. 0) go to 1 18726 max = (nsp-n)/2 18727 v = 1 18728 l = v + max 18729 head = l + max 18730 next = head + n 18731 if (max.lt.n) go to 110 18732 c 18733 call md 18734 * (n, ia,ja, max,isp(v),isp(l), isp(head),p,ip, isp(v), flag) 18735 if (flag.ne.0) go to 100 18736 c 18737 c----allocate storage and symmetrically reorder matrix 18738 1 if ((path-2) * (path-3) * (path-4) * (path-5) .ne. 0) go to 2 18739 tmp = (nsp+1) - n 18740 q = tmp - (ia(n+1)-1) 18741 if (q.lt.1) go to 110 18742 c 18743 dflag = path.eq.4 .or. path.eq.5 18744 call sro 18745 * (n, ip, ia, ja, a, isp(tmp), isp(q), dflag) 18746 c 18747 2 return 18748 c 18749 c ** error -- error detected in md 18750 100 return 18751 c ** error -- insufficient storage 18752 110 flag = 10*n + 1 18753 return 18754 c ** error -- illegal path specified 18755 111 flag = 11*n + 1 18756 return 18757 end 18758 subroutine md 18759 * (n, ia,ja, max, v,l, head,last,next, mark, flag) 18760 c*********************************************************************** 18761 c md -- minimum degree algorithm (based on element model) 18762 c*********************************************************************** 18763 c 18764 c description 18765 c 18766 c md finds a minimum degree ordering of the rows and columns of a 18767 c general sparse matrix m stored in (ia,ja,a) format. 18768 c when the structure of m is nonsymmetric, the ordering is that 18769 c obtained for the symmetric matrix m + m-transpose. 18770 c 18771 c 18772 c additional parameters 18773 c 18774 c max - declared dimension of the one-dimensional arrays v and l. 18775 c max must be at least n+2k, where k is the number of 18776 c nonzeroes in the strict upper triangle of m + m-transpose 18777 c 18778 c v - integer one-dimensional work array. dimension = max 18779 c 18780 c l - integer one-dimensional work array. dimension = max 18781 c 18782 c head - integer one-dimensional work array. dimension = n 18783 c 18784 c last - integer one-dimensional array used to return the permutation 18785 c of the rows and columns of m corresponding to the minimum 18786 c degree ordering. dimension = n 18787 c 18788 c next - integer one-dimensional array used to return the inverse of 18789 c the permutation returned in last. dimension = n 18790 c 18791 c mark - integer one-dimensional work array (may be the same as v). 18792 c dimension = n 18793 c 18794 c flag - integer error flag. values and their meanings are - 18795 c 0 no errors detected 18796 c 9n+k insufficient storage in md 18797 c 18798 c 18799 c definitions of internal parameters 18800 c 18801 c ---------+--------------------------------------------------------- 18802 c v(s) - value field of list entry 18803 c ---------+--------------------------------------------------------- 18804 c l(s) - link field of list entry (0 =) end of list) 18805 c ---------+--------------------------------------------------------- 18806 c l(vi) - pointer to element list of uneliminated vertex vi 18807 c ---------+--------------------------------------------------------- 18808 c l(ej) - pointer to boundary list of active element ej 18809 c ---------+--------------------------------------------------------- 18810 c head(d) - vj =) vj head of d-list d 18811 c - 0 =) no vertex in d-list d 18812 c 18813 c 18814 c - vi uneliminated vertex 18815 c - vi in ek - vi not in ek 18816 c ---------+-----------------------------+--------------------------- 18817 c next(vi) - undefined but nonnegative - vj =) vj next in d-list 18818 c - - 0 =) vi tail of d-list 18819 c ---------+-----------------------------+--------------------------- 18820 c last(vi) - (not set until mdp) - -d =) vi head of d-list d 18821 c --vk =) compute degree - vj =) vj last in d-list 18822 c - ej =) vi prototype of ej - 0 =) vi not in any d-list 18823 c - 0 =) do not compute degree - 18824 c ---------+-----------------------------+--------------------------- 18825 c mark(vi) - mark(vk) - nonneg. tag .lt. mark(vk) 18826 c 18827 c 18828 c - vi eliminated vertex 18829 c - ei active element - otherwise 18830 c ---------+-----------------------------+--------------------------- 18831 c next(vi) - -j =) vi was j-th vertex - -j =) vi was j-th vertex 18832 c - to be eliminated - to be eliminated 18833 c ---------+-----------------------------+--------------------------- 18834 c last(vi) - m =) size of ei = m - undefined 18835 c ---------+-----------------------------+--------------------------- 18836 c mark(vi) - -m =) overlap count of ei - undefined 18837 c - with ek = m - 18838 c - otherwise nonnegative tag - 18839 c - .lt. mark(vk) - 18840 c 18841 c----------------------------------------------------------------------- 18842 c 18843 integer ia(*), ja(*), v(*), l(*), head(*), last(*), next(*), 18844 * mark(*), flag, tag, dmin, vk,ek, tail 18845 equivalence (vk,ek) 18846 c 18847 c----initialization 18848 tag = 0 18849 call mdi 18850 * (n, ia,ja, max,v,l, head,last,next, mark,tag, flag) 18851 if (flag.ne.0) return 18852 c 18853 k = 0 18854 dmin = 1 18855 c 18856 c----while k .lt. n do 18857 1 if (k.ge.n) go to 4 18858 c 18859 c------search for vertex of minimum degree 18860 2 if (head(dmin).gt.0) go to 3 18861 dmin = dmin + 1 18862 go to 2 18863 c 18864 c------remove vertex vk of minimum degree from degree list 18865 3 vk = head(dmin) 18866 head(dmin) = next(vk) 18867 if (head(dmin).gt.0) last(head(dmin)) = -dmin 18868 c 18869 c------number vertex vk, adjust tag, and tag vk 18870 k = k+1 18871 next(vk) = -k 18872 last(ek) = dmin - 1 18873 tag = tag + last(ek) 18874 mark(vk) = tag 18875 c 18876 c------form element ek from uneliminated neighbors of vk 18877 call mdm 18878 * (vk,tail, v,l, last,next, mark) 18879 c 18880 c------purge inactive elements and do mass elimination 18881 call mdp 18882 * (k,ek,tail, v,l, head,last,next, mark) 18883 c 18884 c------update degrees of uneliminated vertices in ek 18885 call mdu 18886 * (ek,dmin, v,l, head,last,next, mark) 18887 c 18888 go to 1 18889 c 18890 c----generate inverse permutation from permutation 18891 4 do 5 k=1,n 18892 next(k) = -next(k) 18893 5 last(next(k)) = k 18894 c 18895 return 18896 end 18897 subroutine mdi 18898 * (n, ia,ja, max,v,l, head,last,next, mark,tag, flag) 18899 c*********************************************************************** 18900 c mdi -- initialization 18901 c*********************************************************************** 18902 integer ia(*), ja(*), v(*), l(*), head(*), last(*), next(*), 18903 * mark(*), tag, flag, sfs, vi,dvi, vj 18904 c 18905 c----initialize degrees, element lists, and degree lists 18906 do 1 vi=1,n 18907 mark(vi) = 1 18908 l(vi) = 0 18909 1 head(vi) = 0 18910 sfs = n+1 18911 c 18912 c----create nonzero structure 18913 c----for each nonzero entry a(vi,vj) 18914 do 6 vi=1,n 18915 jmin = ia(vi) 18916 jmax = ia(vi+1) - 1 18917 if (jmin.gt.jmax) go to 6 18918 do 5 j=jmin,jmax 18919 vj = ja(j) 18920 if (vj-vi) 2, 5, 4 18921 c 18922 c------if a(vi,vj) is in strict lower triangle 18923 c------check for previous occurrence of a(vj,vi) 18924 2 lvk = vi 18925 kmax = mark(vi) - 1 18926 if (kmax .eq. 0) go to 4 18927 do 3 k=1,kmax 18928 lvk = l(lvk) 18929 if (v(lvk).eq.vj) go to 5 18930 3 continue 18931 c----for unentered entries a(vi,vj) 18932 4 if (sfs.ge.max) go to 101 18933 c 18934 c------enter vj in element list for vi 18935 mark(vi) = mark(vi) + 1 18936 v(sfs) = vj 18937 l(sfs) = l(vi) 18938 l(vi) = sfs 18939 sfs = sfs+1 18940 c 18941 c------enter vi in element list for vj 18942 mark(vj) = mark(vj) + 1 18943 v(sfs) = vi 18944 l(sfs) = l(vj) 18945 l(vj) = sfs 18946 sfs = sfs+1 18947 5 continue 18948 6 continue 18949 c 18950 c----create degree lists and initialize mark vector 18951 do 7 vi=1,n 18952 dvi = mark(vi) 18953 next(vi) = head(dvi) 18954 head(dvi) = vi 18955 last(vi) = -dvi 18956 nextvi = next(vi) 18957 if (nextvi.gt.0) last(nextvi) = vi 18958 7 mark(vi) = tag 18959 c 18960 return 18961 c 18962 c ** error- insufficient storage 18963 101 flag = 9*n + vi 18964 return 18965 end 18966 subroutine mdm 18967 * (vk,tail, v,l, last,next, mark) 18968 c*********************************************************************** 18969 c mdm -- form element from uneliminated neighbors of vk 18970 c*********************************************************************** 18971 integer vk, tail, v(*), l(*), last(*), next(*), mark(*), 18972 * tag, s,ls,vs,es, b,lb,vb, blp,blpmax 18973 equivalence (vs, es) 18974 c 18975 c----initialize tag and list of uneliminated neighbors 18976 tag = mark(vk) 18977 tail = vk 18978 c 18979 c----for each vertex/element vs/es in element list of vk 18980 ls = l(vk) 18981 1 s = ls 18982 if (s.eq.0) go to 5 18983 ls = l(s) 18984 vs = v(s) 18985 if (next(vs).lt.0) go to 2 18986 c 18987 c------if vs is uneliminated vertex, then tag and append to list of 18988 c------uneliminated neighbors 18989 mark(vs) = tag 18990 l(tail) = s 18991 tail = s 18992 go to 4 18993 c 18994 c------if es is active element, then ... 18995 c--------for each vertex vb in boundary list of element es 18996 2 lb = l(es) 18997 blpmax = last(es) 18998 do 3 blp=1,blpmax 18999 b = lb 19000 lb = l(b) 19001 vb = v(b) 19002 c 19003 c----------if vb is untagged vertex, then tag and append to list of 19004 c----------uneliminated neighbors 19005 if (mark(vb).ge.tag) go to 3 19006 mark(vb) = tag 19007 l(tail) = b 19008 tail = b 19009 3 continue 19010 c 19011 c--------mark es inactive 19012 mark(es) = tag 19013 c 19014 4 go to 1 19015 c 19016 c----terminate list of uneliminated neighbors 19017 5 l(tail) = 0 19018 c 19019 return 19020 end 19021 subroutine mdp 19022 * (k,ek,tail, v,l, head,last,next, mark) 19023 c*********************************************************************** 19024 c mdp -- purge inactive elements and do mass elimination 19025 c*********************************************************************** 19026 integer ek, tail, v(*), l(*), head(*), last(*), next(*), 19027 * mark(*), tag, free, li,vi,lvi,evi, s,ls,es, ilp,ilpmax 19028 c 19029 c----initialize tag 19030 tag = mark(ek) 19031 c 19032 c----for each vertex vi in ek 19033 li = ek 19034 ilpmax = last(ek) 19035 if (ilpmax.le.0) go to 12 19036 do 11 ilp=1,ilpmax 19037 i = li 19038 li = l(i) 19039 vi = v(li) 19040 c 19041 c------remove vi from degree list 19042 if (last(vi).eq.0) go to 3 19043 if (last(vi).gt.0) go to 1 19044 head(-last(vi)) = next(vi) 19045 go to 2 19046 1 next(last(vi)) = next(vi) 19047 2 if (next(vi).gt.0) last(next(vi)) = last(vi) 19048 c 19049 c------remove inactive items from element list of vi 19050 3 ls = vi 19051 4 s = ls 19052 ls = l(s) 19053 if (ls.eq.0) go to 6 19054 es = v(ls) 19055 if (mark(es).lt.tag) go to 5 19056 free = ls 19057 l(s) = l(ls) 19058 ls = s 19059 5 go to 4 19060 c 19061 c------if vi is interior vertex, then remove from list and eliminate 19062 6 lvi = l(vi) 19063 if (lvi.ne.0) go to 7 19064 l(i) = l(li) 19065 li = i 19066 c 19067 k = k+1 19068 next(vi) = -k 19069 last(ek) = last(ek) - 1 19070 go to 11 19071 c 19072 c------else ... 19073 c--------classify vertex vi 19074 7 if (l(lvi).ne.0) go to 9 19075 evi = v(lvi) 19076 if (next(evi).ge.0) go to 9 19077 if (mark(evi).lt.0) go to 8 19078 c 19079 c----------if vi is prototype vertex, then mark as such, initialize 19080 c----------overlap count for corresponding element, and move vi to end 19081 c----------of boundary list 19082 last(vi) = evi 19083 mark(evi) = -1 19084 l(tail) = li 19085 tail = li 19086 l(i) = l(li) 19087 li = i 19088 go to 10 19089 c 19090 c----------else if vi is duplicate vertex, then mark as such and adjust 19091 c----------overlap count for corresponding element 19092 8 last(vi) = 0 19093 mark(evi) = mark(evi) - 1 19094 go to 10 19095 c 19096 c----------else mark vi to compute degree 19097 9 last(vi) = -ek 19098 c 19099 c--------insert ek in element list of vi 19100 10 v(free) = ek 19101 l(free) = l(vi) 19102 l(vi) = free 19103 11 continue 19104 c 19105 c----terminate boundary list 19106 12 l(tail) = 0 19107 c 19108 return 19109 end 19110 subroutine mdu 19111 * (ek,dmin, v,l, head,last,next, mark) 19112 c*********************************************************************** 19113 c mdu -- update degrees of uneliminated vertices in ek 19114 c*********************************************************************** 19115 integer ek, dmin, v(*), l(*), head(*), last(*), next(*), 19116 * mark(*), tag, vi,evi,dvi, s,vs,es, b,vb, ilp,ilpmax, 19117 * blp,blpmax 19118 equivalence (vs, es) 19119 c 19120 c----initialize tag 19121 tag = mark(ek) - last(ek) 19122 c 19123 c----for each vertex vi in ek 19124 i = ek 19125 ilpmax = last(ek) 19126 if (ilpmax.le.0) go to 11 19127 do 10 ilp=1,ilpmax 19128 i = l(i) 19129 vi = v(i) 19130 if (last(vi)) 1, 10, 8 19131 c 19132 c------if vi neither prototype nor duplicate vertex, then merge elements 19133 c------to compute degree 19134 1 tag = tag + 1 19135 dvi = last(ek) 19136 c 19137 c--------for each vertex/element vs/es in element list of vi 19138 s = l(vi) 19139 2 s = l(s) 19140 if (s.eq.0) go to 9 19141 vs = v(s) 19142 if (next(vs).lt.0) go to 3 19143 c 19144 c----------if vs is uneliminated vertex, then tag and adjust degree 19145 mark(vs) = tag 19146 dvi = dvi + 1 19147 go to 5 19148 c 19149 c----------if es is active element, then expand 19150 c------------check for outmatched vertex 19151 3 if (mark(es).lt.0) go to 6 19152 c 19153 c------------for each vertex vb in es 19154 b = es 19155 blpmax = last(es) 19156 do 4 blp=1,blpmax 19157 b = l(b) 19158 vb = v(b) 19159 c 19160 c--------------if vb is untagged, then tag and adjust degree 19161 if (mark(vb).ge.tag) go to 4 19162 mark(vb) = tag 19163 dvi = dvi + 1 19164 4 continue 19165 c 19166 5 go to 2 19167 c 19168 c------else if vi is outmatched vertex, then adjust overlaps but do not 19169 c------compute degree 19170 6 last(vi) = 0 19171 mark(es) = mark(es) - 1 19172 7 s = l(s) 19173 if (s.eq.0) go to 10 19174 es = v(s) 19175 if (mark(es).lt.0) mark(es) = mark(es) - 1 19176 go to 7 19177 c 19178 c------else if vi is prototype vertex, then calculate degree by 19179 c------inclusion/exclusion and reset overlap count 19180 8 evi = last(vi) 19181 dvi = last(ek) + last(evi) + mark(evi) 19182 mark(evi) = 0 19183 c 19184 c------insert vi in appropriate degree list 19185 9 next(vi) = head(dvi) 19186 head(dvi) = vi 19187 last(vi) = -dvi 19188 if (next(vi).gt.0) last(next(vi)) = vi 19189 if (dvi.lt.dmin) dmin = dvi 19190 c 19191 10 continue 19192 c 19193 11 return 19194 end 19195 subroutine sro 19196 * (n, ip, ia,ja,a, q, r, dflag) 19197 c*********************************************************************** 19198 c sro -- symmetric reordering of sparse symmetric matrix 19199 c*********************************************************************** 19200 c 19201 c description 19202 c 19203 c the nonzero entries of the matrix m are assumed to be stored 19204 c symmetrically in (ia,ja,a) format (i.e., not both m(i,j) and m(j,i) 19205 c are stored if i ne j). 19206 c 19207 c sro does not rearrange the order of the rows, but does move 19208 c nonzeroes from one row to another to ensure that if m(i,j) will be 19209 c in the upper triangle of m with respect to the new ordering, then 19210 c m(i,j) is stored in row i (and thus m(j,i) is not stored), whereas 19211 c if m(i,j) will be in the strict lower triangle of m, then m(j,i) is 19212 c stored in row j (and thus m(i,j) is not stored). 19213 c 19214 c 19215 c additional parameters 19216 c 19217 c q - integer one-dimensional work array. dimension = n 19218 c 19219 c r - integer one-dimensional work array. dimension = number of 19220 c nonzero entries in the upper triangle of m 19221 c 19222 c dflag - logical variable. if dflag = .true., then store nonzero 19223 c diagonal elements at the beginning of the row 19224 c 19225 c----------------------------------------------------------------------- 19226 c 19227 integer ip(*), ia(*), ja(*), q(*), r(*) 19228 c... real a(*), ak 19229 double precision a(*), ak 19230 logical dflag 19231 c 19232 c 19233 c--phase 1 -- find row in which to store each nonzero 19234 c----initialize count of nonzeroes to be stored in each row 19235 do 1 i=1,n 19236 1 q(i) = 0 19237 c 19238 c----for each nonzero element a(j) 19239 do 3 i=1,n 19240 jmin = ia(i) 19241 jmax = ia(i+1) - 1 19242 if (jmin.gt.jmax) go to 3 19243 do 2 j=jmin,jmax 19244 c 19245 c--------find row (=r(j)) and column (=ja(j)) in which to store a(j) ... 19246 k = ja(j) 19247 if (ip(k).lt.ip(i)) ja(j) = i 19248 if (ip(k).ge.ip(i)) k = i 19249 r(j) = k 19250 c 19251 c--------... and increment count of nonzeroes (=q(r(j)) in that row 19252 2 q(k) = q(k) + 1 19253 3 continue 19254 c 19255 c 19256 c--phase 2 -- find new ia and permutation to apply to (ja,a) 19257 c----determine pointers to delimit rows in permuted (ja,a) 19258 do 4 i=1,n 19259 ia(i+1) = ia(i) + q(i) 19260 4 q(i) = ia(i+1) 19261 c 19262 c----determine where each (ja(j),a(j)) is stored in permuted (ja,a) 19263 c----for each nonzero element (in reverse order) 19264 ilast = 0 19265 jmin = ia(1) 19266 jmax = ia(n+1) - 1 19267 j = jmax 19268 do 6 jdummy=jmin,jmax 19269 i = r(j) 19270 if (.not.dflag .or. ja(j).ne.i .or. i.eq.ilast) go to 5 19271 c 19272 c------if dflag, then put diagonal nonzero at beginning of row 19273 r(j) = ia(i) 19274 ilast = i 19275 go to 6 19276 c 19277 c------put (off-diagonal) nonzero in last unused location in row 19278 5 q(i) = q(i) - 1 19279 r(j) = q(i) 19280 c 19281 6 j = j-1 19282 c 19283 c 19284 c--phase 3 -- permute (ja,a) to upper triangular form (wrt new ordering) 19285 do 8 j=jmin,jmax 19286 7 if (r(j).eq.j) go to 8 19287 k = r(j) 19288 r(j) = r(k) 19289 r(k) = k 19290 jak = ja(k) 19291 ja(k) = ja(j) 19292 ja(j) = jak 19293 ak = a(k) 19294 a(k) = a(j) 19295 a(j) = ak 19296 go to 7 19297 8 continue 19298 c 19299 return 19300 end 19301 *DECK CDRV 19302 subroutine cdrv 19303 * (n, r,c,ic, ia,ja,a, b, z, nsp,isp,rsp,esp, path, flag) 19304 c*** subroutine cdrv 19305 c*** driver for subroutines for solving sparse nonsymmetric systems of 19306 c linear equations (compressed pointer storage) 19307 c 19308 c 19309 c parameters 19310 c class abbreviations are-- 19311 c n - integer variable 19312 c f - real variable 19313 c v - supplies a value to the driver 19314 c r - returns a result from the driver 19315 c i - used internally by the driver 19316 c a - array 19317 c 19318 c class - parameter 19319 c ------+---------- 19320 c - 19321 c the nonzero entries of the coefficient matrix m are stored 19322 c row-by-row in the array a. to identify the individual nonzero 19323 c entries in each row, we need to know in which column each entry 19324 c lies. the column indices which correspond to the nonzero entries 19325 c of m are stored in the array ja. i.e., if a(k) = m(i,j), then 19326 c ja(k) = j. in addition, we need to know where each row starts and 19327 c how long it is. the index positions in ja and a where the rows of 19328 c m begin are stored in the array ia. i.e., if m(i,j) is the first 19329 c nonzero entry (stored) in the i-th row and a(k) = m(i,j), then 19330 c ia(i) = k. moreover, the index in ja and a of the first location 19331 c following the last element in the last row is stored in ia(n+1). 19332 c thus, the number of entries in the i-th row is given by 19333 c ia(i+1) - ia(i), the nonzero entries of the i-th row are stored 19334 c consecutively in 19335 c a(ia(i)), a(ia(i)+1), ..., a(ia(i+1)-1), 19336 c and the corresponding column indices are stored consecutively in 19337 c ja(ia(i)), ja(ia(i)+1), ..., ja(ia(i+1)-1). 19338 c for example, the 5 by 5 matrix 19339 c ( 1. 0. 2. 0. 0.) 19340 c ( 0. 3. 0. 0. 0.) 19341 c m = ( 0. 4. 5. 6. 0.) 19342 c ( 0. 0. 0. 7. 0.) 19343 c ( 0. 0. 0. 8. 9.) 19344 c would be stored as 19345 c - 1 2 3 4 5 6 7 8 9 19346 c ---+-------------------------- 19347 c ia - 1 3 4 7 8 10 19348 c ja - 1 3 2 2 3 4 4 4 5 19349 c a - 1. 2. 3. 4. 5. 6. 7. 8. 9. . 19350 c 19351 c nv - n - number of variables/equations. 19352 c fva - a - nonzero entries of the coefficient matrix m, stored 19353 c - by rows. 19354 c - size = number of nonzero entries in m. 19355 c nva - ia - pointers to delimit the rows in a. 19356 c - size = n+1. 19357 c nva - ja - column numbers corresponding to the elements of a. 19358 c - size = size of a. 19359 c fva - b - right-hand side b. b and z can the same array. 19360 c - size = n. 19361 c fra - z - solution x. b and z can be the same array. 19362 c - size = n. 19363 c 19364 c the rows and columns of the original matrix m can be 19365 c reordered (e.g., to reduce fillin or ensure numerical stability) 19366 c before calling the driver. if no reordering is done, then set 19367 c r(i) = c(i) = ic(i) = i for i=1,...,n. the solution z is returned 19368 c in the original order. 19369 c if the columns have been reordered (i.e., c(i).ne.i for some 19370 c i), then the driver will call a subroutine (nroc) which rearranges 19371 c each row of ja and a, leaving the rows in the original order, but 19372 c placing the elements of each row in increasing order with respect 19373 c to the new ordering. if path.ne.1, then nroc is assumed to have 19374 c been called already. 19375 c 19376 c nva - r - ordering of the rows of m. 19377 c - size = n. 19378 c nva - c - ordering of the columns of m. 19379 c - size = n. 19380 c nva - ic - inverse of the ordering of the columns of m. i.e., 19381 c - ic(c(i)) = i for i=1,...,n. 19382 c - size = n. 19383 c 19384 c the solution of the system of linear equations is divided into 19385 c three stages -- 19386 c nsfc -- the matrix m is processed symbolically to determine where 19387 c fillin will occur during the numeric factorization. 19388 c nnfc -- the matrix m is factored numerically into the product ldu 19389 c of a unit lower triangular matrix l, a diagonal matrix 19390 c d, and a unit upper triangular matrix u, and the system 19391 c mx = b is solved. 19392 c nnsc -- the linear system mx = b is solved using the ldu 19393 c or factorization from nnfc. 19394 c nntc -- the transposed linear system mt x = b is solved using 19395 c the ldu factorization from nnf. 19396 c for several systems whose coefficient matrices have the same 19397 c nonzero structure, nsfc need be done only once (for the first 19398 c system). then nnfc is done once for each additional system. for 19399 c several systems with the same coefficient matrix, nsfc and nnfc 19400 c need be done only once (for the first system). then nnsc or nntc 19401 c is done once for each additional right-hand side. 19402 c 19403 c nv - path - path specification. values and their meanings are -- 19404 c - 1 perform nroc, nsfc, and nnfc. 19405 c - 2 perform nnfc only (nsfc is assumed to have been 19406 c - done in a manner compatible with the storage 19407 c - allocation used in the driver). 19408 c - 3 perform nnsc only (nsfc and nnfc are assumed to 19409 c - have been done in a manner compatible with the 19410 c - storage allocation used in the driver). 19411 c - 4 perform nntc only (nsfc and nnfc are assumed to 19412 c - have been done in a manner compatible with the 19413 c - storage allocation used in the driver). 19414 c - 5 perform nroc and nsfc. 19415 c 19416 c various errors are detected by the driver and the individual 19417 c subroutines. 19418 c 19419 c nr - flag - error flag. values and their meanings are -- 19420 c - 0 no errors detected 19421 c - n+k null row in a -- row = k 19422 c - 2n+k duplicate entry in a -- row = k 19423 c - 3n+k insufficient storage in nsfc -- row = k 19424 c - 4n+1 insufficient storage in nnfc 19425 c - 5n+k null pivot -- row = k 19426 c - 6n+k insufficient storage in nsfc -- row = k 19427 c - 7n+1 insufficient storage in nnfc 19428 c - 8n+k zero pivot -- row = k 19429 c - 10n+1 insufficient storage in cdrv 19430 c - 11n+1 illegal path specification 19431 c 19432 c working storage is needed for the factored form of the matrix 19433 c m plus various temporary vectors. the arrays isp and rsp should be 19434 c equivalenced. integer storage is allocated from the beginning of 19435 c isp and real storage from the end of rsp. 19436 c 19437 c nv - nsp - declared dimension of rsp. nsp generally must 19438 c - be larger than 8n+2 + 2k (where k = (number of 19439 c - nonzero entries in m)). 19440 c nvira - isp - integer working storage divided up into various arrays 19441 c - needed by the subroutines. isp and rsp should be 19442 c - equivalenced. 19443 c - size = lratio*nsp. 19444 c fvira - rsp - real working storage divided up into various arrays 19445 c - needed by the subroutines. isp and rsp should be 19446 c - equivalenced. 19447 c - size = nsp. 19448 c nr - esp - if sufficient storage was available to perform the 19449 c - symbolic factorization (nsfc), then esp is set to 19450 c - the amount of excess storage provided (negative if 19451 c - insufficient storage was available to perform the 19452 c - numeric factorization (nnfc)). 19453 c 19454 c 19455 c conversion to double precision 19456 c 19457 c to convert these routines for double precision arrays.. 19458 c (1) use the double precision declarations in place of the real 19459 c declarations in each subprogram, as given in comment cards. 19460 c (2) change the data-loaded value of the integer lratio 19461 c in subroutine cdrv, as indicated below. 19462 c (3) change e0 to d0 in the constants in statement number 10 19463 c in subroutine nnfc and the line following that. 19464 c 19465 integer r(*), c(*), ic(*), ia(*), ja(*), isp(*), esp, path, 19466 * flag, d, u, q, row, tmp, ar, umax 19467 c real a(*), b(*), z(*), rsp(*) 19468 double precision a(*), b(*), z(*), rsp(*) 19469 c 19470 c set lratio equal to the ratio between the length of floating point 19471 c and integer array data. e. g., lratio = 1 for (real, integer), 19472 c lratio = 2 for (double precision, integer) 19473 c 19474 data lratio/2/ 19475 c 19476 if (path.lt.1 .or. 5.lt.path) go to 111 19477 c******initialize and divide up temporary storage ******************* 19478 il = 1 19479 ijl = il + (n+1) 19480 iu = ijl + n 19481 iju = iu + (n+1) 19482 irl = iju + n 19483 jrl = irl + n 19484 jl = jrl + n 19485 c 19486 c ****** reorder a if necessary, call nsfc if flag is set *********** 19487 if ((path-1) * (path-5) .ne. 0) go to 5 19488 max = (lratio*nsp + 1 - jl) - (n+1) - 5*n 19489 jlmax = max/2 19490 q = jl + jlmax 19491 ira = q + (n+1) 19492 jra = ira + n 19493 irac = jra + n 19494 iru = irac + n 19495 jru = iru + n 19496 jutmp = jru + n 19497 jumax = lratio*nsp + 1 - jutmp 19498 esp = max/lratio 19499 if (jlmax.le.0 .or. jumax.le.0) go to 110 19500 c 19501 do 1 i=1,n 19502 if (c(i).ne.i) go to 2 19503 1 continue 19504 go to 3 19505 2 ar = nsp + 1 - n 19506 call nroc 19507 * (n, ic, ia,ja,a, isp(il), rsp(ar), isp(iu), flag) 19508 if (flag.ne.0) go to 100 19509 c 19510 3 call nsfc 19511 * (n, r, ic, ia,ja, 19512 * jlmax, isp(il), isp(jl), isp(ijl), 19513 * jumax, isp(iu), isp(jutmp), isp(iju), 19514 * isp(q), isp(ira), isp(jra), isp(irac), 19515 * isp(irl), isp(jrl), isp(iru), isp(jru), flag) 19516 if(flag .ne. 0) go to 100 19517 c ****** move ju next to jl ***************************************** 19518 jlmax = isp(ijl+n-1) 19519 ju = jl + jlmax 19520 jumax = isp(iju+n-1) 19521 if (jumax.le.0) go to 5 19522 do 4 j=1,jumax 19523 4 isp(ju+j-1) = isp(jutmp+j-1) 19524 c 19525 c ****** call remaining subroutines ********************************* 19526 5 jlmax = isp(ijl+n-1) 19527 ju = jl + jlmax 19528 jumax = isp(iju+n-1) 19529 l = (ju + jumax - 2 + lratio) / lratio + 1 19530 lmax = isp(il+n) - 1 19531 d = l + lmax 19532 u = d + n 19533 row = nsp + 1 - n 19534 tmp = row - n 19535 umax = tmp - u 19536 esp = umax - (isp(iu+n) - 1) 19537 c 19538 if ((path-1) * (path-2) .ne. 0) go to 6 19539 if (umax.lt.0) go to 110 19540 call nnfc 19541 * (n, r, c, ic, ia, ja, a, z, b, 19542 * lmax, isp(il), isp(jl), isp(ijl), rsp(l), rsp(d), 19543 * umax, isp(iu), isp(ju), isp(iju), rsp(u), 19544 * rsp(row), rsp(tmp), isp(irl), isp(jrl), flag) 19545 if(flag .ne. 0) go to 100 19546 c 19547 6 if ((path-3) .ne. 0) go to 7 19548 call nnsc 19549 * (n, r, c, isp(il), isp(jl), isp(ijl), rsp(l), 19550 * rsp(d), isp(iu), isp(ju), isp(iju), rsp(u), 19551 * z, b, rsp(tmp)) 19552 c 19553 7 if ((path-4) .ne. 0) go to 8 19554 call nntc 19555 * (n, r, c, isp(il), isp(jl), isp(ijl), rsp(l), 19556 * rsp(d), isp(iu), isp(ju), isp(iju), rsp(u), 19557 * z, b, rsp(tmp)) 19558 8 return 19559 c 19560 c ** error.. error detected in nroc, nsfc, nnfc, or nnsc 19561 100 return 19562 c ** error.. insufficient storage 19563 110 flag = 10*n + 1 19564 return 19565 c ** error.. illegal path specification 19566 111 flag = 11*n + 1 19567 return 19568 end 19569 subroutine nroc (n, ic, ia, ja, a, jar, ar, p, flag) 19570 c 19571 c ---------------------------------------------------------------- 19572 c 19573 c yale sparse matrix package - nonsymmetric codes 19574 c solving the system of equations mx = b 19575 c 19576 c i. calling sequences 19577 c the coefficient matrix can be processed by an ordering routine 19578 c (e.g., to reduce fillin or ensure numerical stability) before using 19579 c the remaining subroutines. if no reordering is done, then set 19580 c r(i) = c(i) = ic(i) = i for i=1,...,n. if an ordering subroutine 19581 c is used, then nroc should be used to reorder the coefficient matrix 19582 c the calling sequence is -- 19583 c ( (matrix ordering)) 19584 c (nroc (matrix reordering)) 19585 c nsfc (symbolic factorization to determine where fillin will 19586 c occur during numeric factorization) 19587 c nnfc (numeric factorization into product ldu of unit lower 19588 c triangular matrix l, diagonal matrix d, and unit 19589 c upper triangular matrix u, and solution of linear 19590 c system) 19591 c nnsc (solution of linear system for additional right-hand 19592 c side using ldu factorization from nnfc) 19593 c (if only one system of equations is to be solved, then the 19594 c subroutine trk should be used.) 19595 c 19596 c ii. storage of sparse matrices 19597 c the nonzero entries of the coefficient matrix m are stored 19598 c row-by-row in the array a. to identify the individual nonzero 19599 c entries in each row, we need to know in which column each entry 19600 c lies. the column indices which correspond to the nonzero entries 19601 c of m are stored in the array ja. i.e., if a(k) = m(i,j), then 19602 c ja(k) = j. in addition, we need to know where each row starts and 19603 c how long it is. the index positions in ja and a where the rows of 19604 c m begin are stored in the array ia. i.e., if m(i,j) is the first 19605 c (leftmost) entry in the i-th row and a(k) = m(i,j), then 19606 c ia(i) = k. moreover, the index in ja and a of the first location 19607 c following the last element in the last row is stored in ia(n+1). 19608 c thus, the number of entries in the i-th row is given by 19609 c ia(i+1) - ia(i), the nonzero entries of the i-th row are stored 19610 c consecutively in 19611 c a(ia(i)), a(ia(i)+1), ..., a(ia(i+1)-1), 19612 c and the corresponding column indices are stored consecutively in 19613 c ja(ia(i)), ja(ia(i)+1), ..., ja(ia(i+1)-1). 19614 c for example, the 5 by 5 matrix 19615 c ( 1. 0. 2. 0. 0.) 19616 c ( 0. 3. 0. 0. 0.) 19617 c m = ( 0. 4. 5. 6. 0.) 19618 c ( 0. 0. 0. 7. 0.) 19619 c ( 0. 0. 0. 8. 9.) 19620 c would be stored as 19621 c - 1 2 3 4 5 6 7 8 9 19622 c ---+-------------------------- 19623 c ia - 1 3 4 7 8 10 19624 c ja - 1 3 2 2 3 4 4 4 5 19625 c a - 1. 2. 3. 4. 5. 6. 7. 8. 9. . 19626 c 19627 c the strict upper (lower) triangular portion of the matrix 19628 c u (l) is stored in a similar fashion using the arrays iu, ju, u 19629 c (il, jl, l) except that an additional array iju (ijl) is used to 19630 c compress storage of ju (jl) by allowing some sequences of column 19631 c (row) indices to used for more than one row (column) (n.b., l is 19632 c stored by columns). iju(k) (ijl(k)) points to the starting 19633 c location in ju (jl) of entries for the kth row (column). 19634 c compression in ju (jl) occurs in two ways. first, if a row 19635 c (column) i was merged into the current row (column) k, and the 19636 c number of elements merged in from (the tail portion of) row 19637 c (column) i is the same as the final length of row (column) k, then 19638 c the kth row (column) and the tail of row (column) i are identical 19639 c and iju(k) (ijl(k)) points to the start of the tail. second, if 19640 c some tail portion of the (k-1)st row (column) is identical to the 19641 c head of the kth row (column), then iju(k) (ijl(k)) points to the 19642 c start of that tail portion. for example, the nonzero structure of 19643 c the strict upper triangular part of the matrix 19644 c d 0 x x x 19645 c 0 d 0 x x 19646 c 0 0 d x 0 19647 c 0 0 0 d x 19648 c 0 0 0 0 d 19649 c would be represented as 19650 c - 1 2 3 4 5 6 19651 c ----+------------ 19652 c iu - 1 4 6 7 8 8 19653 c ju - 3 4 5 4 19654 c iju - 1 2 4 3 . 19655 c the diagonal entries of l and u are assumed to be equal to one and 19656 c are not stored. the array d contains the reciprocals of the 19657 c diagonal entries of the matrix d. 19658 c 19659 c iii. additional storage savings 19660 c in nsfc, r and ic can be the same array in the calling 19661 c sequence if no reordering of the coefficient matrix has been done. 19662 c in nnfc, r, c, and ic can all be the same array if no 19663 c reordering has been done. if only the rows have been reordered, 19664 c then c and ic can be the same array. if the row and column 19665 c orderings are the same, then r and c can be the same array. z and 19666 c row can be the same array. 19667 c in nnsc or nntc, r and c can be the same array if no 19668 c reordering has been done or if the row and column orderings are the 19669 c same. z and b can be the same array. however, then b will be 19670 c destroyed. 19671 c 19672 c iv. parameters 19673 c following is a list of parameters to the programs. names are 19674 c uniform among the various subroutines. class abbreviations are -- 19675 c n - integer variable 19676 c f - real variable 19677 c v - supplies a value to a subroutine 19678 c r - returns a result from a subroutine 19679 c i - used internally by a subroutine 19680 c a - array 19681 c 19682 c class - parameter 19683 c ------+---------- 19684 c fva - a - nonzero entries of the coefficient matrix m, stored 19685 c - by rows. 19686 c - size = number of nonzero entries in m. 19687 c fva - b - right-hand side b. 19688 c - size = n. 19689 c nva - c - ordering of the columns of m. 19690 c - size = n. 19691 c fvra - d - reciprocals of the diagonal entries of the matrix d. 19692 c - size = n. 19693 c nr - flag - error flag. values and their meanings are -- 19694 c - 0 no errors detected 19695 c - n+k null row in a -- row = k 19696 c - 2n+k duplicate entry in a -- row = k 19697 c - 3n+k insufficient storage for jl -- row = k 19698 c - 4n+1 insufficient storage for l 19699 c - 5n+k null pivot -- row = k 19700 c - 6n+k insufficient storage for ju -- row = k 19701 c - 7n+1 insufficient storage for u 19702 c - 8n+k zero pivot -- row = k 19703 c nva - ia - pointers to delimit the rows of a. 19704 c - size = n+1. 19705 c nvra - ijl - pointers to the first element in each column in jl, 19706 c - used to compress storage in jl. 19707 c - size = n. 19708 c nvra - iju - pointers to the first element in each row in ju, used 19709 c - to compress storage in ju. 19710 c - size = n. 19711 c nvra - il - pointers to delimit the columns of l. 19712 c - size = n+1. 19713 c nvra - iu - pointers to delimit the rows of u. 19714 c - size = n+1. 19715 c nva - ja - column numbers corresponding to the elements of a. 19716 c - size = size of a. 19717 c nvra - jl - row numbers corresponding to the elements of l. 19718 c - size = jlmax. 19719 c nv - jlmax - declared dimension of jl. jlmax must be larger than 19720 c - the number of nonzeros in the strict lower triangle 19721 c - of m plus fillin minus compression. 19722 c nvra - ju - column numbers corresponding to the elements of u. 19723 c - size = jumax. 19724 c nv - jumax - declared dimension of ju. jumax must be larger than 19725 c - the number of nonzeros in the strict upper triangle 19726 c - of m plus fillin minus compression. 19727 c fvra - l - nonzero entries in the strict lower triangular portion 19728 c - of the matrix l, stored by columns. 19729 c - size = lmax. 19730 c nv - lmax - declared dimension of l. lmax must be larger than 19731 c - the number of nonzeros in the strict lower triangle 19732 c - of m plus fillin (il(n+1)-1 after nsfc). 19733 c nv - n - number of variables/equations. 19734 c nva - r - ordering of the rows of m. 19735 c - size = n. 19736 c fvra - u - nonzero entries in the strict upper triangular portion 19737 c - of the matrix u, stored by rows. 19738 c - size = umax. 19739 c nv - umax - declared dimension of u. umax must be larger than 19740 c - the number of nonzeros in the strict upper triangle 19741 c - of m plus fillin (iu(n+1)-1 after nsfc). 19742 c fra - z - solution x. 19743 c - size = n. 19744 c 19745 c ---------------------------------------------------------------- 19746 c 19747 c*** subroutine nroc 19748 c*** reorders rows of a, leaving row order unchanged 19749 c 19750 c 19751 c input parameters.. n, ic, ia, ja, a 19752 c output parameters.. ja, a, flag 19753 c 19754 c parameters used internally.. 19755 c nia - p - at the kth step, p is a linked list of the reordered 19756 c - column indices of the kth row of a. p(n+1) points 19757 c - to the first entry in the list. 19758 c - size = n+1. 19759 c nia - jar - at the kth step,jar contains the elements of the 19760 c - reordered column indices of a. 19761 c - size = n. 19762 c fia - ar - at the kth step, ar contains the elements of the 19763 c - reordered row of a. 19764 c - size = n. 19765 c 19766 integer ic(*), ia(*), ja(*), jar(*), p(*), flag 19767 c real a(*), ar(*) 19768 double precision a(*), ar(*) 19769 c 19770 c ****** for each nonempty row ******************************* 19771 do 5 k=1,n 19772 jmin = ia(k) 19773 jmax = ia(k+1) - 1 19774 if(jmin .gt. jmax) go to 5 19775 p(n+1) = n + 1 19776 c ****** insert each element in the list ********************* 19777 do 3 j=jmin,jmax 19778 newj = ic(ja(j)) 19779 i = n + 1 19780 1 if(p(i) .ge. newj) go to 2 19781 i = p(i) 19782 go to 1 19783 2 if(p(i) .eq. newj) go to 102 19784 p(newj) = p(i) 19785 p(i) = newj 19786 jar(newj) = ja(j) 19787 ar(newj) = a(j) 19788 3 continue 19789 c ****** replace old row in ja and a ************************* 19790 i = n + 1 19791 do 4 j=jmin,jmax 19792 i = p(i) 19793 ja(j) = jar(i) 19794 4 a(j) = ar(i) 19795 5 continue 19796 flag = 0 19797 return 19798 c 19799 c ** error.. duplicate entry in a 19800 102 flag = n + k 19801 return 19802 end 19803 subroutine nsfc 19804 * (n, r, ic, ia,ja, jlmax,il,jl,ijl, jumax,iu,ju,iju, 19805 * q, ira,jra, irac, irl,jrl, iru,jru, flag) 19806 c*** subroutine nsfc 19807 c*** symbolic ldu-factorization of nonsymmetric sparse matrix 19808 c (compressed pointer storage) 19809 c 19810 c 19811 c input variables.. n, r, ic, ia, ja, jlmax, jumax. 19812 c output variables.. il, jl, ijl, iu, ju, iju, flag. 19813 c 19814 c parameters used internally.. 19815 c nia - q - suppose m* is the result of reordering m. if 19816 c - processing of the ith row of m* (hence the ith 19817 c - row of u) is being done, q(j) is initially 19818 c - nonzero if m*(i,j) is nonzero (j.ge.i). since 19819 c - values need not be stored, each entry points to the 19820 c - next nonzero and q(n+1) points to the first. n+1 19821 c - indicates the end of the list. for example, if n=9 19822 c - and the 5th row of m* is 19823 c - 0 x x 0 x 0 0 x 0 19824 c - then q will initially be 19825 c - a a a a 8 a a 10 5 (a - arbitrary). 19826 c - as the algorithm proceeds, other elements of q 19827 c - are inserted in the list because of fillin. 19828 c - q is used in an analogous manner to compute the 19829 c - ith column of l. 19830 c - size = n+1. 19831 c nia - ira, - vectors used to find the columns of m. at the kth 19832 c nia - jra, step of the factorization, irac(k) points to the 19833 c nia - irac head of a linked list in jra of row indices i 19834 c - such that i .ge. k and m(i,k) is nonzero. zero 19835 c - indicates the end of the list. ira(i) (i.ge.k) 19836 c - points to the smallest j such that j .ge. k and 19837 c - m(i,j) is nonzero. 19838 c - size of each = n. 19839 c nia - irl, - vectors used to find the rows of l. at the kth step 19840 c nia - jrl of the factorization, jrl(k) points to the head 19841 c - of a linked list in jrl of column indices j 19842 c - such j .lt. k and l(k,j) is nonzero. zero 19843 c - indicates the end of the list. irl(j) (j.lt.k) 19844 c - points to the smallest i such that i .ge. k and 19845 c - l(i,j) is nonzero. 19846 c - size of each = n. 19847 c nia - iru, - vectors used in a manner analogous to irl and jrl 19848 c nia - jru to find the columns of u. 19849 c - size of each = n. 19850 c 19851 c internal variables.. 19852 c jlptr - points to the last position used in jl. 19853 c juptr - points to the last position used in ju. 19854 c jmin,jmax - are the indices in a or u of the first and last 19855 c elements to be examined in a given row. 19856 c for example, jmin=ia(k), jmax=ia(k+1)-1. 19857 c 19858 integer cend, qm, rend, rk, vj 19859 integer ia(*), ja(*), ira(*), jra(*), il(*), jl(*), ijl(*) 19860 integer iu(*), ju(*), iju(*), irl(*), jrl(*), iru(*), jru(*) 19861 integer r(*), ic(*), q(*), irac(*), flag 19862 c 19863 c ****** initialize pointers **************************************** 19864 np1 = n + 1 19865 jlmin = 1 19866 jlptr = 0 19867 il(1) = 1 19868 jumin = 1 19869 juptr = 0 19870 iu(1) = 1 19871 do 1 k=1,n 19872 irac(k) = 0 19873 jra(k) = 0 19874 jrl(k) = 0 19875 1 jru(k) = 0 19876 c ****** initialize column pointers for a *************************** 19877 do 2 k=1,n 19878 rk = r(k) 19879 iak = ia(rk) 19880 if (iak .ge. ia(rk+1)) go to 101 19881 jaiak = ic(ja(iak)) 19882 if (jaiak .gt. k) go to 105 19883 jra(k) = irac(jaiak) 19884 irac(jaiak) = k 19885 2 ira(k) = iak 19886 c 19887 c ****** for each column of l and row of u ************************** 19888 do 41 k=1,n 19889 c 19890 c ****** initialize q for computing kth column of l ***************** 19891 q(np1) = np1 19892 luk = -1 19893 c ****** by filling in kth column of a ****************************** 19894 vj = irac(k) 19895 if (vj .eq. 0) go to 5 19896 3 qm = np1 19897 4 m = qm 19898 qm = q(m) 19899 if (qm .lt. vj) go to 4 19900 if (qm .eq. vj) go to 102 19901 luk = luk + 1 19902 q(m) = vj 19903 q(vj) = qm 19904 vj = jra(vj) 19905 if (vj .ne. 0) go to 3 19906 c ****** link through jru ******************************************* 19907 5 lastid = 0 19908 lasti = 0 19909 ijl(k) = jlptr 19910 i = k 19911 6 i = jru(i) 19912 if (i .eq. 0) go to 10 19913 qm = np1 19914 jmin = irl(i) 19915 jmax = ijl(i) + il(i+1) - il(i) - 1 19916 long = jmax - jmin 19917 if (long .lt. 0) go to 6 19918 jtmp = jl(jmin) 19919 if (jtmp .ne. k) long = long + 1 19920 if (jtmp .eq. k) r(i) = -r(i) 19921 if (lastid .ge. long) go to 7 19922 lasti = i 19923 lastid = long 19924 c ****** and merge the corresponding columns into the kth column **** 19925 7 do 9 j=jmin,jmax 19926 vj = jl(j) 19927 8 m = qm 19928 qm = q(m) 19929 if (qm .lt. vj) go to 8 19930 if (qm .eq. vj) go to 9 19931 luk = luk + 1 19932 q(m) = vj 19933 q(vj) = qm 19934 qm = vj 19935 9 continue 19936 go to 6 19937 c ****** lasti is the longest column merged into the kth ************ 19938 c ****** see if it equals the entire kth column ********************* 19939 10 qm = q(np1) 19940 if (qm .ne. k) go to 105 19941 if (luk .eq. 0) go to 17 19942 if (lastid .ne. luk) go to 11 19943 c ****** if so, jl can be compressed ******************************** 19944 irll = irl(lasti) 19945 ijl(k) = irll + 1 19946 if (jl(irll) .ne. k) ijl(k) = ijl(k) - 1 19947 go to 17 19948 c ****** if not, see if kth column can overlap the previous one ***** 19949 11 if (jlmin .gt. jlptr) go to 15 19950 qm = q(qm) 19951 do 12 j=jlmin,jlptr 19952 if (jl(j) - qm) 12, 13, 15 19953 12 continue 19954 go to 15 19955 13 ijl(k) = j 19956 do 14 i=j,jlptr 19957 if (jl(i) .ne. qm) go to 15 19958 qm = q(qm) 19959 if (qm .gt. n) go to 17 19960 14 continue 19961 jlptr = j - 1 19962 c ****** move column indices from q to jl, update vectors *********** 19963 15 jlmin = jlptr + 1 19964 ijl(k) = jlmin 19965 if (luk .eq. 0) go to 17 19966 jlptr = jlptr + luk 19967 if (jlptr .gt. jlmax) go to 103 19968 qm = q(np1) 19969 do 16 j=jlmin,jlptr 19970 qm = q(qm) 19971 16 jl(j) = qm 19972 17 irl(k) = ijl(k) 19973 il(k+1) = il(k) + luk 19974 c 19975 c ****** initialize q for computing kth row of u ******************** 19976 q(np1) = np1 19977 luk = -1 19978 c ****** by filling in kth row of reordered a *********************** 19979 rk = r(k) 19980 jmin = ira(k) 19981 jmax = ia(rk+1) - 1 19982 if (jmin .gt. jmax) go to 20 19983 do 19 j=jmin,jmax 19984 vj = ic(ja(j)) 19985 qm = np1 19986 18 m = qm 19987 qm = q(m) 19988 if (qm .lt. vj) go to 18 19989 if (qm .eq. vj) go to 102 19990 luk = luk + 1 19991 q(m) = vj 19992 q(vj) = qm 19993 19 continue 19994 c ****** link through jrl, ****************************************** 19995 20 lastid = 0 19996 lasti = 0 19997 iju(k) = juptr 19998 i = k 19999 i1 = jrl(k) 20000 21 i = i1 20001 if (i .eq. 0) go to 26 20002 i1 = jrl(i) 20003 qm = np1 20004 jmin = iru(i) 20005 jmax = iju(i) + iu(i+1) - iu(i) - 1 20006 long = jmax - jmin 20007 if (long .lt. 0) go to 21 20008 jtmp = ju(jmin) 20009 if (jtmp .eq. k) go to 22 20010 c ****** update irl and jrl, ***************************************** 20011 long = long + 1 20012 cend = ijl(i) + il(i+1) - il(i) 20013 irl(i) = irl(i) + 1 20014 if (irl(i) .ge. cend) go to 22 20015 j = jl(irl(i)) 20016 jrl(i) = jrl(j) 20017 jrl(j) = i 20018 22 if (lastid .ge. long) go to 23 20019 lasti = i 20020 lastid = long 20021 c ****** and merge the corresponding rows into the kth row ********** 20022 23 do 25 j=jmin,jmax 20023 vj = ju(j) 20024 24 m = qm 20025 qm = q(m) 20026 if (qm .lt. vj) go to 24 20027 if (qm .eq. vj) go to 25 20028 luk = luk + 1 20029 q(m) = vj 20030 q(vj) = qm 20031 qm = vj 20032 25 continue 20033 go to 21 20034 c ****** update jrl(k) and irl(k) *********************************** 20035 26 if (il(k+1) .le. il(k)) go to 27 20036 j = jl(irl(k)) 20037 jrl(k) = jrl(j) 20038 jrl(j) = k 20039 c ****** lasti is the longest row merged into the kth *************** 20040 c ****** see if it equals the entire kth row ************************ 20041 27 qm = q(np1) 20042 if (qm .ne. k) go to 105 20043 if (luk .eq. 0) go to 34 20044 if (lastid .ne. luk) go to 28 20045 c ****** if so, ju can be compressed ******************************** 20046 irul = iru(lasti) 20047 iju(k) = irul + 1 20048 if (ju(irul) .ne. k) iju(k) = iju(k) - 1 20049 go to 34 20050 c ****** if not, see if kth row can overlap the previous one ******** 20051 28 if (jumin .gt. juptr) go to 32 20052 qm = q(qm) 20053 do 29 j=jumin,juptr 20054 if (ju(j) - qm) 29, 30, 32 20055 29 continue 20056 go to 32 20057 30 iju(k) = j 20058 do 31 i=j,juptr 20059 if (ju(i) .ne. qm) go to 32 20060 qm = q(qm) 20061 if (qm .gt. n) go to 34 20062 31 continue 20063 juptr = j - 1 20064 c ****** move row indices from q to ju, update vectors ************** 20065 32 jumin = juptr + 1 20066 iju(k) = jumin 20067 if (luk .eq. 0) go to 34 20068 juptr = juptr + luk 20069 if (juptr .gt. jumax) go to 106 20070 qm = q(np1) 20071 do 33 j=jumin,juptr 20072 qm = q(qm) 20073 33 ju(j) = qm 20074 34 iru(k) = iju(k) 20075 iu(k+1) = iu(k) + luk 20076 c 20077 c ****** update iru, jru ******************************************** 20078 i = k 20079 35 i1 = jru(i) 20080 if (r(i) .lt. 0) go to 36 20081 rend = iju(i) + iu(i+1) - iu(i) 20082 if (iru(i) .ge. rend) go to 37 20083 j = ju(iru(i)) 20084 jru(i) = jru(j) 20085 jru(j) = i 20086 go to 37 20087 36 r(i) = -r(i) 20088 37 i = i1 20089 if (i .eq. 0) go to 38 20090 iru(i) = iru(i) + 1 20091 go to 35 20092 c 20093 c ****** update ira, jra, irac ************************************** 20094 38 i = irac(k) 20095 if (i .eq. 0) go to 41 20096 39 i1 = jra(i) 20097 ira(i) = ira(i) + 1 20098 if (ira(i) .ge. ia(r(i)+1)) go to 40 20099 irai = ira(i) 20100 jairai = ic(ja(irai)) 20101 if (jairai .gt. i) go to 40 20102 jra(i) = irac(jairai) 20103 irac(jairai) = i 20104 40 i = i1 20105 if (i .ne. 0) go to 39 20106 41 continue 20107 c 20108 ijl(n) = jlptr 20109 iju(n) = juptr 20110 flag = 0 20111 return 20112 c 20113 c ** error.. null row in a 20114 101 flag = n + rk 20115 return 20116 c ** error.. duplicate entry in a 20117 102 flag = 2*n + rk 20118 return 20119 c ** error.. insufficient storage for jl 20120 103 flag = 3*n + k 20121 return 20122 c ** error.. null pivot 20123 105 flag = 5*n + k 20124 return 20125 c ** error.. insufficient storage for ju 20126 106 flag = 6*n + k 20127 return 20128 end 20129 subroutine nnfc 20130 * (n, r,c,ic, ia,ja,a, z, b, 20131 * lmax,il,jl,ijl,l, d, umax,iu,ju,iju,u, 20132 * row, tmp, irl,jrl, flag) 20133 c*** subroutine nnfc 20134 c*** numerical ldu-factorization of sparse nonsymmetric matrix and 20135 c solution of system of linear equations (compressed pointer 20136 c storage) 20137 c 20138 c 20139 c input variables.. n, r, c, ic, ia, ja, a, b, 20140 c il, jl, ijl, lmax, iu, ju, iju, umax 20141 c output variables.. z, l, d, u, flag 20142 c 20143 c parameters used internally.. 20144 c nia - irl, - vectors used to find the rows of l. at the kth step 20145 c nia - jrl of the factorization, jrl(k) points to the head 20146 c - of a linked list in jrl of column indices j 20147 c - such j .lt. k and l(k,j) is nonzero. zero 20148 c - indicates the end of the list. irl(j) (j.lt.k) 20149 c - points to the smallest i such that i .ge. k and 20150 c - l(i,j) is nonzero. 20151 c - size of each = n. 20152 c fia - row - holds intermediate values in calculation of u and l. 20153 c - size = n. 20154 c fia - tmp - holds new right-hand side b* for solution of the 20155 c - equation ux = b*. 20156 c - size = n. 20157 c 20158 c internal variables.. 20159 c jmin, jmax - indices of the first and last positions in a row to 20160 c be examined. 20161 c sum - used in calculating tmp. 20162 c 20163 integer rk,umax 20164 integer r(*), c(*), ic(*), ia(*), ja(*), il(*), jl(*), ijl(*) 20165 integer iu(*), ju(*), iju(*), irl(*), jrl(*), flag 20166 c real a(*), l(*), d(*), u(*), z(*), b(*), row(*) 20167 c real tmp(*), lki, sum, dk 20168 double precision a(*), l(*), d(*), u(*), z(*), b(*), row(*) 20169 double precision tmp(*), lki, sum, dk 20170 c 20171 c ****** initialize pointers and test storage *********************** 20172 if(il(n+1)-1 .gt. lmax) go to 104 20173 if(iu(n+1)-1 .gt. umax) go to 107 20174 do 1 k=1,n 20175 irl(k) = il(k) 20176 jrl(k) = 0 20177 1 continue 20178 c 20179 c ****** for each row *********************************************** 20180 do 19 k=1,n 20181 c ****** reverse jrl and zero row where kth row of l will fill in *** 20182 row(k) = 0 20183 i1 = 0 20184 if (jrl(k) .eq. 0) go to 3 20185 i = jrl(k) 20186 2 i2 = jrl(i) 20187 jrl(i) = i1 20188 i1 = i 20189 row(i) = 0 20190 i = i2 20191 if (i .ne. 0) go to 2 20192 c ****** set row to zero where u will fill in *********************** 20193 3 jmin = iju(k) 20194 jmax = jmin + iu(k+1) - iu(k) - 1 20195 if (jmin .gt. jmax) go to 5 20196 do 4 j=jmin,jmax 20197 4 row(ju(j)) = 0 20198 c ****** place kth row of a in row ********************************** 20199 5 rk = r(k) 20200 jmin = ia(rk) 20201 jmax = ia(rk+1) - 1 20202 do 6 j=jmin,jmax 20203 row(ic(ja(j))) = a(j) 20204 6 continue 20205 c ****** initialize sum, and link through jrl *********************** 20206 sum = b(rk) 20207 i = i1 20208 if (i .eq. 0) go to 10 20209 c ****** assign the kth row of l and adjust row, sum **************** 20210 7 lki = -row(i) 20211 c ****** if l is not required, then comment out the following line ** 20212 l(irl(i)) = -lki 20213 sum = sum + lki * tmp(i) 20214 jmin = iu(i) 20215 jmax = iu(i+1) - 1 20216 if (jmin .gt. jmax) go to 9 20217 mu = iju(i) - jmin 20218 do 8 j=jmin,jmax 20219 8 row(ju(mu+j)) = row(ju(mu+j)) + lki * u(j) 20220 9 i = jrl(i) 20221 if (i .ne. 0) go to 7 20222 c 20223 c ****** assign kth row of u and diagonal d, set tmp(k) ************* 20224 10 if (row(k) .eq. 0.0d0) go to 108 20225 dk = 1.0d0 / row(k) 20226 d(k) = dk 20227 tmp(k) = sum * dk 20228 if (k .eq. n) go to 19 20229 jmin = iu(k) 20230 jmax = iu(k+1) - 1 20231 if (jmin .gt. jmax) go to 12 20232 mu = iju(k) - jmin 20233 do 11 j=jmin,jmax 20234 11 u(j) = row(ju(mu+j)) * dk 20235 12 continue 20236 c 20237 c ****** update irl and jrl, keeping jrl in decreasing order ******** 20238 i = i1 20239 if (i .eq. 0) go to 18 20240 14 irl(i) = irl(i) + 1 20241 i1 = jrl(i) 20242 if (irl(i) .ge. il(i+1)) go to 17 20243 ijlb = irl(i) - il(i) + ijl(i) 20244 j = jl(ijlb) 20245 15 if (i .gt. jrl(j)) go to 16 20246 j = jrl(j) 20247 go to 15 20248 16 jrl(i) = jrl(j) 20249 jrl(j) = i 20250 17 i = i1 20251 if (i .ne. 0) go to 14 20252 18 if (irl(k) .ge. il(k+1)) go to 19 20253 j = jl(ijl(k)) 20254 jrl(k) = jrl(j) 20255 jrl(j) = k 20256 19 continue 20257 c 20258 c ****** solve ux = tmp by back substitution ********************** 20259 k = n 20260 do 22 i=1,n 20261 sum = tmp(k) 20262 jmin = iu(k) 20263 jmax = iu(k+1) - 1 20264 if (jmin .gt. jmax) go to 21 20265 mu = iju(k) - jmin 20266 do 20 j=jmin,jmax 20267 20 sum = sum - u(j) * tmp(ju(mu+j)) 20268 21 tmp(k) = sum 20269 z(c(k)) = sum 20270 22 k = k-1 20271 flag = 0 20272 return 20273 c 20274 c ** error.. insufficient storage for l 20275 104 flag = 4*n + 1 20276 return 20277 c ** error.. insufficient storage for u 20278 107 flag = 7*n + 1 20279 return 20280 c ** error.. zero pivot 20281 108 flag = 8*n + k 20282 return 20283 end 20284 subroutine nnsc 20285 * (n, r, c, il, jl, ijl, l, d, iu, ju, iju, u, z, b, tmp) 20286 c*** subroutine nnsc 20287 c*** numerical solution of sparse nonsymmetric system of linear 20288 c equations given ldu-factorization (compressed pointer storage) 20289 c 20290 c 20291 c input variables.. n, r, c, il, jl, ijl, l, d, iu, ju, iju, u, b 20292 c output variables.. z 20293 c 20294 c parameters used internally.. 20295 c fia - tmp - temporary vector which gets result of solving ly = b. 20296 c - size = n. 20297 c 20298 c internal variables.. 20299 c jmin, jmax - indices of the first and last positions in a row of 20300 c u or l to be used. 20301 c 20302 integer r(*), c(*), il(*), jl(*), ijl(*), iu(*), ju(*), iju(*) 20303 c real l(*), d(*), u(*), b(*), z(*), tmp(*), tmpk, sum 20304 double precision l(*), d(*), u(*), b(*), z(*), tmp(*), tmpk,sum 20305 c 20306 c ****** set tmp to reordered b ************************************* 20307 do 1 k=1,n 20308 1 tmp(k) = b(r(k)) 20309 c ****** solve ly = b by forward substitution ********************* 20310 do 3 k=1,n 20311 jmin = il(k) 20312 jmax = il(k+1) - 1 20313 tmpk = -d(k) * tmp(k) 20314 tmp(k) = -tmpk 20315 if (jmin .gt. jmax) go to 3 20316 ml = ijl(k) - jmin 20317 do 2 j=jmin,jmax 20318 2 tmp(jl(ml+j)) = tmp(jl(ml+j)) + tmpk * l(j) 20319 3 continue 20320 c ****** solve ux = y by back substitution ************************ 20321 k = n 20322 do 6 i=1,n 20323 sum = -tmp(k) 20324 jmin = iu(k) 20325 jmax = iu(k+1) - 1 20326 if (jmin .gt. jmax) go to 5 20327 mu = iju(k) - jmin 20328 do 4 j=jmin,jmax 20329 4 sum = sum + u(j) * tmp(ju(mu+j)) 20330 5 tmp(k) = -sum 20331 z(c(k)) = -sum 20332 k = k - 1 20333 6 continue 20334 return 20335 end 20336 subroutine nntc 20337 * (n, r, c, il, jl, ijl, l, d, iu, ju, iju, u, z, b, tmp) 20338 c*** subroutine nntc 20339 c*** numeric solution of the transpose of a sparse nonsymmetric system 20340 c of linear equations given lu-factorization (compressed pointer 20341 c storage) 20342 c 20343 c 20344 c input variables.. n, r, c, il, jl, ijl, l, d, iu, ju, iju, u, b 20345 c output variables.. z 20346 c 20347 c parameters used internally.. 20348 c fia - tmp - temporary vector which gets result of solving ut y = b 20349 c - size = n. 20350 c 20351 c internal variables.. 20352 c jmin, jmax - indices of the first and last positions in a row of 20353 c u or l to be used. 20354 c 20355 integer r(*), c(*), il(*), jl(*), ijl(*), iu(*), ju(*), iju(*) 20356 c real l(*), d(*), u(*), b(*), z(*), tmp(*), tmpk,sum 20357 double precision l(*), d(*), u(*), b(*), z(*), tmp(*), tmpk,sum 20358 c 20359 c ****** set tmp to reordered b ************************************* 20360 do 1 k=1,n 20361 1 tmp(k) = b(c(k)) 20362 c ****** solve ut y = b by forward substitution ******************* 20363 do 3 k=1,n 20364 jmin = iu(k) 20365 jmax = iu(k+1) - 1 20366 tmpk = -tmp(k) 20367 if (jmin .gt. jmax) go to 3 20368 mu = iju(k) - jmin 20369 do 2 j=jmin,jmax 20370 2 tmp(ju(mu+j)) = tmp(ju(mu+j)) + tmpk * u(j) 20371 3 continue 20372 c ****** solve lt x = y by back substitution ********************** 20373 k = n 20374 do 6 i=1,n 20375 sum = -tmp(k) 20376 jmin = il(k) 20377 jmax = il(k+1) - 1 20378 if (jmin .gt. jmax) go to 5 20379 ml = ijl(k) - jmin 20380 do 4 j=jmin,jmax 20381 4 sum = sum + l(j) * tmp(jl(ml+j)) 20382 5 tmp(k) = -sum * d(k) 20383 z(r(k)) = tmp(k) 20384 k = k - 1 20385 6 continue 20386 return 20387 end 20388 *DECK DSTODA 20389 SUBROUTINE DSTODA (NEQ, Y, YH, NYH, YH1, EWT, SAVF, ACOR, 20390 1 WM, IWM, F, JAC, PJAC, SLVS) 20391 EXTERNAL F, JAC, PJAC, SLVS 20392 INTEGER NEQ, NYH, IWM 20393 DOUBLE PRECISION Y, YH, YH1, EWT, SAVF, ACOR, WM 20394 DIMENSION NEQ(*), Y(*), YH(NYH,*), YH1(*), EWT(*), SAVF(*), 20395 1 ACOR(*), WM(*), IWM(*) 20396 INTEGER IOWND, IALTH, IPUP, LMAX, MEO, NQNYH, NSLP, 20397 1 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 20398 2 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 20399 3 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU 20400 INTEGER IOWND2, ICOUNT, IRFLAG, JTYP, MUSED, MXORDN, MXORDS 20401 DOUBLE PRECISION CONIT, CRATE, EL, ELCO, HOLD, RMAX, TESCO, 20402 2 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND 20403 DOUBLE PRECISION ROWND2, CM1, CM2, PDEST, PDLAST, RATIO, 20404 1 PDNORM 20405 COMMON /DLS001/ CONIT, CRATE, EL(13), ELCO(13,12), 20406 1 HOLD, RMAX, TESCO(3,12), 20407 2 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND, 20408 3 IOWND(6), IALTH, IPUP, LMAX, MEO, NQNYH, NSLP, 20409 4 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 20410 5 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 20411 6 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU 20412 COMMON /DLSA01/ ROWND2, CM1(12), CM2(5), PDEST, PDLAST, RATIO, 20413 1 PDNORM, 20414 2 IOWND2(3), ICOUNT, IRFLAG, JTYP, MUSED, MXORDN, MXORDS 20415 INTEGER I, I1, IREDO, IRET, J, JB, M, NCF, NEWQ 20416 INTEGER LM1, LM1P1, LM2, LM2P1, NQM1, NQM2 20417 DOUBLE PRECISION DCON, DDN, DEL, DELP, DSM, DUP, EXDN, EXSM, EXUP, 20418 1 R, RH, RHDN, RHSM, RHUP, TOLD, DMNORM 20419 DOUBLE PRECISION ALPHA, DM1,DM2, EXM1,EXM2, 20420 1 PDH, PNORM, RATE, RH1, RH1IT, RH2, RM, SM1(12) 20421 SAVE SM1 20422 DATA SM1/0.5D0, 0.575D0, 0.55D0, 0.45D0, 0.35D0, 0.25D0, 20423 1 0.20D0, 0.15D0, 0.10D0, 0.075D0, 0.050D0, 0.025D0/ 20424 C----------------------------------------------------------------------- 20425 C DSTODA performs one step of the integration of an initial value 20426 C problem for a system of ordinary differential equations. 20427 C Note: DSTODA is independent of the value of the iteration method 20428 C indicator MITER, when this is .ne. 0, and hence is independent 20429 C of the type of chord method used, or the Jacobian structure. 20430 C Communication with DSTODA is done with the following variables: 20431 C 20432 C Y = an array of length .ge. N used as the Y argument in 20433 C all calls to F and JAC. 20434 C NEQ = integer array containing problem size in NEQ(1), and 20435 C passed as the NEQ argument in all calls to F and JAC. 20436 C YH = an NYH by LMAX array containing the dependent variables 20437 C and their approximate scaled derivatives, where 20438 C LMAX = MAXORD + 1. YH(i,j+1) contains the approximate 20439 C j-th derivative of y(i), scaled by H**j/factorial(j) 20440 C (j = 0,1,...,NQ). On entry for the first step, the first 20441 C two columns of YH must be set from the initial values. 20442 C NYH = a constant integer .ge. N, the first dimension of YH. 20443 C YH1 = a one-dimensional array occupying the same space as YH. 20444 C EWT = an array of length N containing multiplicative weights 20445 C for local error measurements. Local errors in y(i) are 20446 C compared to 1.0/EWT(i) in various error tests. 20447 C SAVF = an array of working storage, of length N. 20448 C ACOR = a work array of length N, used for the accumulated 20449 C corrections. On a successful return, ACOR(i) contains 20450 C the estimated one-step local error in y(i). 20451 C WM,IWM = real and integer work arrays associated with matrix 20452 C operations in chord iteration (MITER .ne. 0). 20453 C PJAC = name of routine to evaluate and preprocess Jacobian matrix 20454 C and P = I - H*EL0*Jac, if a chord method is being used. 20455 C It also returns an estimate of norm(Jac) in PDNORM. 20456 C SLVS = name of routine to solve linear system in chord iteration. 20457 C CCMAX = maximum relative change in H*EL0 before PJAC is called. 20458 C H = the step size to be attempted on the next step. 20459 C H is altered by the error control algorithm during the 20460 C problem. H can be either positive or negative, but its 20461 C sign must remain constant throughout the problem. 20462 C HMIN = the minimum absolute value of the step size H to be used. 20463 C HMXI = inverse of the maximum absolute value of H to be used. 20464 C HMXI = 0.0 is allowed and corresponds to an infinite HMAX. 20465 C HMIN and HMXI may be changed at any time, but will not 20466 C take effect until the next change of H is considered. 20467 C TN = the independent variable. TN is updated on each step taken. 20468 C JSTART = an integer used for input only, with the following 20469 C values and meanings: 20470 C 0 perform the first step. 20471 C .gt.0 take a new step continuing from the last. 20472 C -1 take the next step with a new value of H, 20473 C N, METH, MITER, and/or matrix parameters. 20474 C -2 take the next step with a new value of H, 20475 C but with other inputs unchanged. 20476 C On return, JSTART is set to 1 to facilitate continuation. 20477 C KFLAG = a completion code with the following meanings: 20478 C 0 the step was succesful. 20479 C -1 the requested error could not be achieved. 20480 C -2 corrector convergence could not be achieved. 20481 C -3 fatal error in PJAC or SLVS. 20482 C A return with KFLAG = -1 or -2 means either 20483 C ABS(H) = HMIN or 10 consecutive failures occurred. 20484 C On a return with KFLAG negative, the values of TN and 20485 C the YH array are as of the beginning of the last 20486 C step, and H is the last step size attempted. 20487 C MAXORD = the maximum order of integration method to be allowed. 20488 C MAXCOR = the maximum number of corrector iterations allowed. 20489 C MSBP = maximum number of steps between PJAC calls (MITER .gt. 0). 20490 C MXNCF = maximum number of convergence failures allowed. 20491 C METH = current method. 20492 C METH = 1 means Adams method (nonstiff) 20493 C METH = 2 means BDF method (stiff) 20494 C METH may be reset by DSTODA. 20495 C MITER = corrector iteration method. 20496 C MITER = 0 means functional iteration. 20497 C MITER = JT .gt. 0 means a chord iteration corresponding 20498 C to Jacobian type JT. (The DLSODA/DLSODAR argument JT is 20499 C communicated here as JTYP, but is not used in DSTODA 20500 C except to load MITER following a method switch.) 20501 C MITER may be reset by DSTODA. 20502 C N = the number of first-order differential equations. 20503 C----------------------------------------------------------------------- 20504 KFLAG = 0 20505 TOLD = TN 20506 NCF = 0 20507 IERPJ = 0 20508 IERSL = 0 20509 JCUR = 0 20510 ICF = 0 20511 DELP = 0.0D0 20512 IF (JSTART .GT. 0) GO TO 200 20513 IF (JSTART .EQ. -1) GO TO 100 20514 IF (JSTART .EQ. -2) GO TO 160 20515 C----------------------------------------------------------------------- 20516 C On the first call, the order is set to 1, and other variables are 20517 C initialized. RMAX is the maximum ratio by which H can be increased 20518 C in a single step. It is initially 1.E4 to compensate for the small 20519 C initial H, but then is normally equal to 10. If a failure 20520 C occurs (in corrector convergence or error test), RMAX is set at 2 20521 C for the next increase. 20522 C DCFODE is called to get the needed coefficients for both methods. 20523 C----------------------------------------------------------------------- 20524 LMAX = MAXORD + 1 20525 NQ = 1 20526 L = 2 20527 IALTH = 2 20528 RMAX = 10000.0D0 20529 RC = 0.0D0 20530 EL0 = 1.0D0 20531 CRATE = 0.7D0 20532 HOLD = H 20533 NSLP = 0 20534 IPUP = MITER 20535 IRET = 3 20536 C Initialize switching parameters. METH = 1 is assumed initially. ----- 20537 ICOUNT = 20 20538 IRFLAG = 0 20539 PDEST = 0.0D0 20540 PDLAST = 0.0D0 20541 RATIO = 5.0D0 20542 CALL DCFODE (2, ELCO, TESCO) 20543 DO 10 I = 1,5 20544 10 CM2(I) = TESCO(2,I)*ELCO(I+1,I) 20545 CALL DCFODE (1, ELCO, TESCO) 20546 DO 20 I = 1,12 20547 20 CM1(I) = TESCO(2,I)*ELCO(I+1,I) 20548 GO TO 150 20549 C----------------------------------------------------------------------- 20550 C The following block handles preliminaries needed when JSTART = -1. 20551 C IPUP is set to MITER to force a matrix update. 20552 C If an order increase is about to be considered (IALTH = 1), 20553 C IALTH is reset to 2 to postpone consideration one more step. 20554 C If the caller has changed METH, DCFODE is called to reset 20555 C the coefficients of the method. 20556 C If H is to be changed, YH must be rescaled. 20557 C If H or METH is being changed, IALTH is reset to L = NQ + 1 20558 C to prevent further changes in H for that many steps. 20559 C----------------------------------------------------------------------- 20560 100 IPUP = MITER 20561 LMAX = MAXORD + 1 20562 IF (IALTH .EQ. 1) IALTH = 2 20563 IF (METH .EQ. MUSED) GO TO 160 20564 CALL DCFODE (METH, ELCO, TESCO) 20565 IALTH = L 20566 IRET = 1 20567 C----------------------------------------------------------------------- 20568 C The el vector and related constants are reset 20569 C whenever the order NQ is changed, or at the start of the problem. 20570 C----------------------------------------------------------------------- 20571 150 DO 155 I = 1,L 20572 155 EL(I) = ELCO(I,NQ) 20573 NQNYH = NQ*NYH 20574 RC = RC*EL(1)/EL0 20575 EL0 = EL(1) 20576 CONIT = 0.5D0/(NQ+2) 20577 GO TO (160, 170, 200), IRET 20578 C----------------------------------------------------------------------- 20579 C If H is being changed, the H ratio RH is checked against 20580 C RMAX, HMIN, and HMXI, and the YH array rescaled. IALTH is set to 20581 C L = NQ + 1 to prevent a change of H for that many steps, unless 20582 C forced by a convergence or error test failure. 20583 C----------------------------------------------------------------------- 20584 160 IF (H .EQ. HOLD) GO TO 200 20585 RH = H/HOLD 20586 H = HOLD 20587 IREDO = 3 20588 GO TO 175 20589 170 RH = MAX(RH,HMIN/ABS(H)) 20590 175 RH = MIN(RH,RMAX) 20591 RH = RH/MAX(1.0D0,ABS(H)*HMXI*RH) 20592 C----------------------------------------------------------------------- 20593 C If METH = 1, also restrict the new step size by the stability region. 20594 C If this reduces H, set IRFLAG to 1 so that if there are roundoff 20595 C problems later, we can assume that is the cause of the trouble. 20596 C----------------------------------------------------------------------- 20597 IF (METH .EQ. 2) GO TO 178 20598 IRFLAG = 0 20599 PDH = MAX(ABS(H)*PDLAST,0.000001D0) 20600 IF (RH*PDH*1.00001D0 .LT. SM1(NQ)) GO TO 178 20601 RH = SM1(NQ)/PDH 20602 IRFLAG = 1 20603 178 CONTINUE 20604 R = 1.0D0 20605 DO 180 J = 2,L 20606 R = R*RH 20607 DO 180 I = 1,N 20608 180 YH(I,J) = YH(I,J)*R 20609 H = H*RH 20610 RC = RC*RH 20611 IALTH = L 20612 IF (IREDO .EQ. 0) GO TO 690 20613 C----------------------------------------------------------------------- 20614 C This section computes the predicted values by effectively 20615 C multiplying the YH array by the Pascal triangle matrix. 20616 C RC is the ratio of new to old values of the coefficient H*EL(1). 20617 C When RC differs from 1 by more than CCMAX, IPUP is set to MITER 20618 C to force PJAC to be called, if a Jacobian is involved. 20619 C In any case, PJAC is called at least every MSBP steps. 20620 C----------------------------------------------------------------------- 20621 200 IF (ABS(RC-1.0D0) .GT. CCMAX) IPUP = MITER 20622 IF (NST .GE. NSLP+MSBP) IPUP = MITER 20623 TN = TN + H 20624 I1 = NQNYH + 1 20625 DO 215 JB = 1,NQ 20626 I1 = I1 - NYH 20627 CDIR$ IVDEP 20628 DO 210 I = I1,NQNYH 20629 210 YH1(I) = YH1(I) + YH1(I+NYH) 20630 215 CONTINUE 20631 PNORM = DMNORM (N, YH1, EWT) 20632 C----------------------------------------------------------------------- 20633 C Up to MAXCOR corrector iterations are taken. A convergence test is 20634 C made on the RMS-norm of each correction, weighted by the error 20635 C weight vector EWT. The sum of the corrections is accumulated in the 20636 C vector ACOR(i). The YH array is not altered in the corrector loop. 20637 C----------------------------------------------------------------------- 20638 220 M = 0 20639 RATE = 0.0D0 20640 DEL = 0.0D0 20641 DO 230 I = 1,N 20642 230 Y(I) = YH(I,1) 20643 CALL F (NEQ, TN, Y, SAVF) 20644 NFE = NFE + 1 20645 IF (IPUP .LE. 0) GO TO 250 20646 C----------------------------------------------------------------------- 20647 C If indicated, the matrix P = I - H*EL(1)*J is reevaluated and 20648 C preprocessed before starting the corrector iteration. IPUP is set 20649 C to 0 as an indicator that this has been done. 20650 C----------------------------------------------------------------------- 20651 CALL PJAC (NEQ, Y, YH, NYH, EWT, ACOR, SAVF, WM, IWM, F, JAC) 20652 IPUP = 0 20653 RC = 1.0D0 20654 NSLP = NST 20655 CRATE = 0.7D0 20656 IF (IERPJ .NE. 0) GO TO 430 20657 250 DO 260 I = 1,N 20658 260 ACOR(I) = 0.0D0 20659 270 IF (MITER .NE. 0) GO TO 350 20660 C----------------------------------------------------------------------- 20661 C In the case of functional iteration, update Y directly from 20662 C the result of the last function evaluation. 20663 C----------------------------------------------------------------------- 20664 DO 290 I = 1,N 20665 SAVF(I) = H*SAVF(I) - YH(I,2) 20666 290 Y(I) = SAVF(I) - ACOR(I) 20667 DEL = DMNORM (N, Y, EWT) 20668 DO 300 I = 1,N 20669 Y(I) = YH(I,1) + EL(1)*SAVF(I) 20670 300 ACOR(I) = SAVF(I) 20671 GO TO 400 20672 C----------------------------------------------------------------------- 20673 C In the case of the chord method, compute the corrector error, 20674 C and solve the linear system with that as right-hand side and 20675 C P as coefficient matrix. 20676 C----------------------------------------------------------------------- 20677 350 DO 360 I = 1,N 20678 360 Y(I) = H*SAVF(I) - (YH(I,2) + ACOR(I)) 20679 CALL SLVS (WM, IWM, Y, SAVF) 20680 IF (IERSL .LT. 0) GO TO 430 20681 IF (IERSL .GT. 0) GO TO 410 20682 DEL = DMNORM (N, Y, EWT) 20683 DO 380 I = 1,N 20684 ACOR(I) = ACOR(I) + Y(I) 20685 380 Y(I) = YH(I,1) + EL(1)*ACOR(I) 20686 C----------------------------------------------------------------------- 20687 C Test for convergence. If M .gt. 0, an estimate of the convergence 20688 C rate constant is stored in CRATE, and this is used in the test. 20689 C 20690 C We first check for a change of iterates that is the size of 20691 C roundoff error. If this occurs, the iteration has converged, and a 20692 C new rate estimate is not formed. 20693 C In all other cases, force at least two iterations to estimate a 20694 C local Lipschitz constant estimate for Adams methods. 20695 C On convergence, form PDEST = local maximum Lipschitz constant 20696 C estimate. PDLAST is the most recent nonzero estimate. 20697 C----------------------------------------------------------------------- 20698 400 CONTINUE 20699 IF (DEL .LE. 100.0D0*PNORM*UROUND) GO TO 450 20700 IF (M .EQ. 0 .AND. METH .EQ. 1) GO TO 405 20701 IF (M .EQ. 0) GO TO 402 20702 RM = 1024.0D0 20703 IF (DEL .LE. 1024.0D0*DELP) RM = DEL/DELP 20704 RATE = MAX(RATE,RM) 20705 CRATE = MAX(0.2D0*CRATE,RM) 20706 402 DCON = DEL*MIN(1.0D0,1.5D0*CRATE)/(TESCO(2,NQ)*CONIT) 20707 IF (DCON .GT. 1.0D0) GO TO 405 20708 PDEST = MAX(PDEST,RATE/ABS(H*EL(1))) 20709 IF (PDEST .NE. 0.0D0) PDLAST = PDEST 20710 GO TO 450 20711 405 CONTINUE 20712 M = M + 1 20713 IF (M .EQ. MAXCOR) GO TO 410 20714 IF (M .GE. 2 .AND. DEL .GT. 2.0D0*DELP) GO TO 410 20715 DELP = DEL 20716 CALL F (NEQ, TN, Y, SAVF) 20717 NFE = NFE + 1 20718 GO TO 270 20719 C----------------------------------------------------------------------- 20720 C The corrector iteration failed to converge. 20721 C If MITER .ne. 0 and the Jacobian is out of date, PJAC is called for 20722 C the next try. Otherwise the YH array is retracted to its values 20723 C before prediction, and H is reduced, if possible. If H cannot be 20724 C reduced or MXNCF failures have occurred, exit with KFLAG = -2. 20725 C----------------------------------------------------------------------- 20726 410 IF (MITER .EQ. 0 .OR. JCUR .EQ. 1) GO TO 430 20727 ICF = 1 20728 IPUP = MITER 20729 GO TO 220 20730 430 ICF = 2 20731 NCF = NCF + 1 20732 RMAX = 2.0D0 20733 TN = TOLD 20734 I1 = NQNYH + 1 20735 DO 445 JB = 1,NQ 20736 I1 = I1 - NYH 20737 CDIR$ IVDEP 20738 DO 440 I = I1,NQNYH 20739 440 YH1(I) = YH1(I) - YH1(I+NYH) 20740 445 CONTINUE 20741 IF (IERPJ .LT. 0 .OR. IERSL .LT. 0) GO TO 680 20742 IF (ABS(H) .LE. HMIN*1.00001D0) GO TO 670 20743 IF (NCF .EQ. MXNCF) GO TO 670 20744 RH = 0.25D0 20745 IPUP = MITER 20746 IREDO = 1 20747 GO TO 170 20748 C----------------------------------------------------------------------- 20749 C The corrector has converged. JCUR is set to 0 20750 C to signal that the Jacobian involved may need updating later. 20751 C The local error test is made and control passes to statement 500 20752 C if it fails. 20753 C----------------------------------------------------------------------- 20754 450 JCUR = 0 20755 IF (M .EQ. 0) DSM = DEL/TESCO(2,NQ) 20756 IF (M .GT. 0) DSM = DMNORM (N, ACOR, EWT)/TESCO(2,NQ) 20757 IF (DSM .GT. 1.0D0) GO TO 500 20758 C----------------------------------------------------------------------- 20759 C After a successful step, update the YH array. 20760 C Decrease ICOUNT by 1, and if it is -1, consider switching methods. 20761 C If a method switch is made, reset various parameters, 20762 C rescale the YH array, and exit. If there is no switch, 20763 C consider changing H if IALTH = 1. Otherwise decrease IALTH by 1. 20764 C If IALTH is then 1 and NQ .lt. MAXORD, then ACOR is saved for 20765 C use in a possible order increase on the next step. 20766 C If a change in H is considered, an increase or decrease in order 20767 C by one is considered also. A change in H is made only if it is by a 20768 C factor of at least 1.1. If not, IALTH is set to 3 to prevent 20769 C testing for that many steps. 20770 C----------------------------------------------------------------------- 20771 KFLAG = 0 20772 IREDO = 0 20773 NST = NST + 1 20774 HU = H 20775 NQU = NQ 20776 MUSED = METH 20777 DO 460 J = 1,L 20778 DO 460 I = 1,N 20779 460 YH(I,J) = YH(I,J) + EL(J)*ACOR(I) 20780 ICOUNT = ICOUNT - 1 20781 IF (ICOUNT .GE. 0) GO TO 488 20782 IF (METH .EQ. 2) GO TO 480 20783 C----------------------------------------------------------------------- 20784 C We are currently using an Adams method. Consider switching to BDF. 20785 C If the current order is greater than 5, assume the problem is 20786 C not stiff, and skip this section. 20787 C If the Lipschitz constant and error estimate are not polluted 20788 C by roundoff, go to 470 and perform the usual test. 20789 C Otherwise, switch to the BDF methods if the last step was 20790 C restricted to insure stability (irflag = 1), and stay with Adams 20791 C method if not. When switching to BDF with polluted error estimates, 20792 C in the absence of other information, double the step size. 20793 C 20794 C When the estimates are OK, we make the usual test by computing 20795 C the step size we could have (ideally) used on this step, 20796 C with the current (Adams) method, and also that for the BDF. 20797 C If NQ .gt. MXORDS, we consider changing to order MXORDS on switching. 20798 C Compare the two step sizes to decide whether to switch. 20799 C The step size advantage must be at least RATIO = 5 to switch. 20800 C----------------------------------------------------------------------- 20801 IF (NQ .GT. 5) GO TO 488 20802 IF (DSM .GT. 100.0D0*PNORM*UROUND .AND. PDEST .NE. 0.0D0) 20803 1 GO TO 470 20804 IF (IRFLAG .EQ. 0) GO TO 488 20805 RH2 = 2.0D0 20806 NQM2 = MIN(NQ,MXORDS) 20807 GO TO 478 20808 470 CONTINUE 20809 EXSM = 1.0D0/L 20810 RH1 = 1.0D0/(1.2D0*DSM**EXSM + 0.0000012D0) 20811 RH1IT = 2.0D0*RH1 20812 PDH = PDLAST*ABS(H) 20813 IF (PDH*RH1 .GT. 0.00001D0) RH1IT = SM1(NQ)/PDH 20814 RH1 = MIN(RH1,RH1IT) 20815 IF (NQ .LE. MXORDS) GO TO 474 20816 NQM2 = MXORDS 20817 LM2 = MXORDS + 1 20818 EXM2 = 1.0D0/LM2 20819 LM2P1 = LM2 + 1 20820 DM2 = DMNORM (N, YH(1,LM2P1), EWT)/CM2(MXORDS) 20821 RH2 = 1.0D0/(1.2D0*DM2**EXM2 + 0.0000012D0) 20822 GO TO 476 20823 474 DM2 = DSM*(CM1(NQ)/CM2(NQ)) 20824 RH2 = 1.0D0/(1.2D0*DM2**EXSM + 0.0000012D0) 20825 NQM2 = NQ 20826 476 CONTINUE 20827 IF (RH2 .LT. RATIO*RH1) GO TO 488 20828 C THE SWITCH TEST PASSED. RESET RELEVANT QUANTITIES FOR BDF. ---------- 20829 478 RH = RH2 20830 ICOUNT = 20 20831 METH = 2 20832 MITER = JTYP 20833 PDLAST = 0.0D0 20834 NQ = NQM2 20835 L = NQ + 1 20836 GO TO 170 20837 C----------------------------------------------------------------------- 20838 C We are currently using a BDF method. Consider switching to Adams. 20839 C Compute the step size we could have (ideally) used on this step, 20840 C with the current (BDF) method, and also that for the Adams. 20841 C If NQ .gt. MXORDN, we consider changing to order MXORDN on switching. 20842 C Compare the two step sizes to decide whether to switch. 20843 C The step size advantage must be at least 5/RATIO = 1 to switch. 20844 C If the step size for Adams would be so small as to cause 20845 C roundoff pollution, we stay with BDF. 20846 C----------------------------------------------------------------------- 20847 480 CONTINUE 20848 EXSM = 1.0D0/L 20849 IF (MXORDN .GE. NQ) GO TO 484 20850 NQM1 = MXORDN 20851 LM1 = MXORDN + 1 20852 EXM1 = 1.0D0/LM1 20853 LM1P1 = LM1 + 1 20854 DM1 = DMNORM (N, YH(1,LM1P1), EWT)/CM1(MXORDN) 20855 RH1 = 1.0D0/(1.2D0*DM1**EXM1 + 0.0000012D0) 20856 GO TO 486 20857 484 DM1 = DSM*(CM2(NQ)/CM1(NQ)) 20858 RH1 = 1.0D0/(1.2D0*DM1**EXSM + 0.0000012D0) 20859 NQM1 = NQ 20860 EXM1 = EXSM 20861 486 RH1IT = 2.0D0*RH1 20862 PDH = PDNORM*ABS(H) 20863 IF (PDH*RH1 .GT. 0.00001D0) RH1IT = SM1(NQM1)/PDH 20864 RH1 = MIN(RH1,RH1IT) 20865 RH2 = 1.0D0/(1.2D0*DSM**EXSM + 0.0000012D0) 20866 IF (RH1*RATIO .LT. 5.0D0*RH2) GO TO 488 20867 ALPHA = MAX(0.001D0,RH1) 20868 DM1 = (ALPHA**EXM1)*DM1 20869 IF (DM1 .LE. 1000.0D0*UROUND*PNORM) GO TO 488 20870 C The switch test passed. Reset relevant quantities for Adams. -------- 20871 RH = RH1 20872 ICOUNT = 20 20873 METH = 1 20874 MITER = 0 20875 PDLAST = 0.0D0 20876 NQ = NQM1 20877 L = NQ + 1 20878 GO TO 170 20879 C 20880 C No method switch is being made. Do the usual step/order selection. -- 20881 488 CONTINUE 20882 IALTH = IALTH - 1 20883 IF (IALTH .EQ. 0) GO TO 520 20884 IF (IALTH .GT. 1) GO TO 700 20885 IF (L .EQ. LMAX) GO TO 700 20886 DO 490 I = 1,N 20887 490 YH(I,LMAX) = ACOR(I) 20888 GO TO 700 20889 C----------------------------------------------------------------------- 20890 C The error test failed. KFLAG keeps track of multiple failures. 20891 C Restore TN and the YH array to their previous values, and prepare 20892 C to try the step again. Compute the optimum step size for this or 20893 C one lower order. After 2 or more failures, H is forced to decrease 20894 C by a factor of 0.2 or less. 20895 C----------------------------------------------------------------------- 20896 500 KFLAG = KFLAG - 1 20897 TN = TOLD 20898 I1 = NQNYH + 1 20899 DO 515 JB = 1,NQ 20900 I1 = I1 - NYH 20901 CDIR$ IVDEP 20902 DO 510 I = I1,NQNYH 20903 510 YH1(I) = YH1(I) - YH1(I+NYH) 20904 515 CONTINUE 20905 RMAX = 2.0D0 20906 IF (ABS(H) .LE. HMIN*1.00001D0) GO TO 660 20907 IF (KFLAG .LE. -3) GO TO 640 20908 IREDO = 2 20909 RHUP = 0.0D0 20910 GO TO 540 20911 C----------------------------------------------------------------------- 20912 C Regardless of the success or failure of the step, factors 20913 C RHDN, RHSM, and RHUP are computed, by which H could be multiplied 20914 C at order NQ - 1, order NQ, or order NQ + 1, respectively. 20915 C In the case of failure, RHUP = 0.0 to avoid an order increase. 20916 C The largest of these is determined and the new order chosen 20917 C accordingly. If the order is to be increased, we compute one 20918 C additional scaled derivative. 20919 C----------------------------------------------------------------------- 20920 520 RHUP = 0.0D0 20921 IF (L .EQ. LMAX) GO TO 540 20922 DO 530 I = 1,N 20923 530 SAVF(I) = ACOR(I) - YH(I,LMAX) 20924 DUP = DMNORM (N, SAVF, EWT)/TESCO(3,NQ) 20925 EXUP = 1.0D0/(L+1) 20926 RHUP = 1.0D0/(1.4D0*DUP**EXUP + 0.0000014D0) 20927 540 EXSM = 1.0D0/L 20928 RHSM = 1.0D0/(1.2D0*DSM**EXSM + 0.0000012D0) 20929 RHDN = 0.0D0 20930 IF (NQ .EQ. 1) GO TO 550 20931 DDN = DMNORM (N, YH(1,L), EWT)/TESCO(1,NQ) 20932 EXDN = 1.0D0/NQ 20933 RHDN = 1.0D0/(1.3D0*DDN**EXDN + 0.0000013D0) 20934 C If METH = 1, limit RH according to the stability region also. -------- 20935 550 IF (METH .EQ. 2) GO TO 560 20936 PDH = MAX(ABS(H)*PDLAST,0.000001D0) 20937 IF (L .LT. LMAX) RHUP = MIN(RHUP,SM1(L)/PDH) 20938 RHSM = MIN(RHSM,SM1(NQ)/PDH) 20939 IF (NQ .GT. 1) RHDN = MIN(RHDN,SM1(NQ-1)/PDH) 20940 PDEST = 0.0D0 20941 560 IF (RHSM .GE. RHUP) GO TO 570 20942 IF (RHUP .GT. RHDN) GO TO 590 20943 GO TO 580 20944 570 IF (RHSM .LT. RHDN) GO TO 580 20945 NEWQ = NQ 20946 RH = RHSM 20947 GO TO 620 20948 580 NEWQ = NQ - 1 20949 RH = RHDN 20950 IF (KFLAG .LT. 0 .AND. RH .GT. 1.0D0) RH = 1.0D0 20951 GO TO 620 20952 590 NEWQ = L 20953 RH = RHUP 20954 IF (RH .LT. 1.1D0) GO TO 610 20955 R = EL(L)/L 20956 DO 600 I = 1,N 20957 600 YH(I,NEWQ+1) = ACOR(I)*R 20958 GO TO 630 20959 610 IALTH = 3 20960 GO TO 700 20961 C If METH = 1 and H is restricted by stability, bypass 10 percent test. 20962 620 IF (METH .EQ. 2) GO TO 622 20963 IF (RH*PDH*1.00001D0 .GE. SM1(NEWQ)) GO TO 625 20964 622 IF (KFLAG .EQ. 0 .AND. RH .LT. 1.1D0) GO TO 610 20965 625 IF (KFLAG .LE. -2) RH = MIN(RH,0.2D0) 20966 C----------------------------------------------------------------------- 20967 C If there is a change of order, reset NQ, L, and the coefficients. 20968 C In any case H is reset according to RH and the YH array is rescaled. 20969 C Then exit from 690 if the step was OK, or redo the step otherwise. 20970 C----------------------------------------------------------------------- 20971 IF (NEWQ .EQ. NQ) GO TO 170 20972 630 NQ = NEWQ 20973 L = NQ + 1 20974 IRET = 2 20975 GO TO 150 20976 C----------------------------------------------------------------------- 20977 C Control reaches this section if 3 or more failures have occured. 20978 C If 10 failures have occurred, exit with KFLAG = -1. 20979 C It is assumed that the derivatives that have accumulated in the 20980 C YH array have errors of the wrong order. Hence the first 20981 C derivative is recomputed, and the order is set to 1. Then 20982 C H is reduced by a factor of 10, and the step is retried, 20983 C until it succeeds or H reaches HMIN. 20984 C----------------------------------------------------------------------- 20985 640 IF (KFLAG .EQ. -10) GO TO 660 20986 RH = 0.1D0 20987 RH = MAX(HMIN/ABS(H),RH) 20988 H = H*RH 20989 DO 645 I = 1,N 20990 645 Y(I) = YH(I,1) 20991 CALL F (NEQ, TN, Y, SAVF) 20992 NFE = NFE + 1 20993 DO 650 I = 1,N 20994 650 YH(I,2) = H*SAVF(I) 20995 IPUP = MITER 20996 IALTH = 5 20997 IF (NQ .EQ. 1) GO TO 200 20998 NQ = 1 20999 L = 2 21000 IRET = 3 21001 GO TO 150 21002 C----------------------------------------------------------------------- 21003 C All returns are made through this section. H is saved in HOLD 21004 C to allow the caller to change H on the next step. 21005 C----------------------------------------------------------------------- 21006 660 KFLAG = -1 21007 GO TO 720 21008 670 KFLAG = -2 21009 GO TO 720 21010 680 KFLAG = -3 21011 GO TO 720 21012 690 RMAX = 10.0D0 21013 700 R = 1.0D0/TESCO(2,NQU) 21014 DO 710 I = 1,N 21015 710 ACOR(I) = ACOR(I)*R 21016 720 HOLD = H 21017 JSTART = 1 21018 RETURN 21019 C----------------------- End of Subroutine DSTODA ---------------------- 21020 END 21021 *DECK DPRJA 21022 SUBROUTINE DPRJA (NEQ, Y, YH, NYH, EWT, FTEM, SAVF, WM, IWM, 21023 1 F, JAC) 21024 EXTERNAL F, JAC 21025 INTEGER NEQ, NYH, IWM 21026 DOUBLE PRECISION Y, YH, EWT, FTEM, SAVF, WM 21027 DIMENSION NEQ(*), Y(*), YH(NYH,*), EWT(*), FTEM(*), SAVF(*), 21028 1 WM(*), IWM(*) 21029 INTEGER IOWND, IOWNS, 21030 1 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 21031 2 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 21032 3 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU 21033 INTEGER IOWND2, IOWNS2, JTYP, MUSED, MXORDN, MXORDS 21034 DOUBLE PRECISION ROWNS, 21035 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND 21036 DOUBLE PRECISION ROWND2, ROWNS2, PDNORM 21037 COMMON /DLS001/ ROWNS(209), 21038 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND, 21039 2 IOWND(6), IOWNS(6), 21040 3 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 21041 4 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 21042 5 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU 21043 COMMON /DLSA01/ ROWND2, ROWNS2(20), PDNORM, 21044 1 IOWND2(3), IOWNS2(2), JTYP, MUSED, MXORDN, MXORDS 21045 INTEGER I, I1, I2, IER, II, J, J1, JJ, LENP, 21046 1 MBA, MBAND, MEB1, MEBAND, ML, ML3, MU, NP1 21047 DOUBLE PRECISION CON, FAC, HL0, R, R0, SRUR, YI, YJ, YJJ, 21048 1 DMNORM, DFNORM, DBNORM 21049 C----------------------------------------------------------------------- 21050 C DPRJA is called by DSTODA to compute and process the matrix 21051 C P = I - H*EL(1)*J , where J is an approximation to the Jacobian. 21052 C Here J is computed by the user-supplied routine JAC if 21053 C MITER = 1 or 4 or by finite differencing if MITER = 2 or 5. 21054 C J, scaled by -H*EL(1), is stored in WM. Then the norm of J (the 21055 C matrix norm consistent with the weighted max-norm on vectors given 21056 C by DMNORM) is computed, and J is overwritten by P. P is then 21057 C subjected to LU decomposition in preparation for later solution 21058 C of linear systems with P as coefficient matrix. This is done 21059 C by DGEFA if MITER = 1 or 2, and by DGBFA if MITER = 4 or 5. 21060 C 21061 C In addition to variables described previously, communication 21062 C with DPRJA uses the following: 21063 C Y = array containing predicted values on entry. 21064 C FTEM = work array of length N (ACOR in DSTODA). 21065 C SAVF = array containing f evaluated at predicted y. 21066 C WM = real work space for matrices. On output it contains the 21067 C LU decomposition of P. 21068 C Storage of matrix elements starts at WM(3). 21069 C WM also contains the following matrix-related data: 21070 C WM(1) = SQRT(UROUND), used in numerical Jacobian increments. 21071 C IWM = integer work space containing pivot information, starting at 21072 C IWM(21). IWM also contains the band parameters 21073 C ML = IWM(1) and MU = IWM(2) if MITER is 4 or 5. 21074 C EL0 = EL(1) (input). 21075 C PDNORM= norm of Jacobian matrix. (Output). 21076 C IERPJ = output error flag, = 0 if no trouble, .gt. 0 if 21077 C P matrix found to be singular. 21078 C JCUR = output flag = 1 to indicate that the Jacobian matrix 21079 C (or approximation) is now current. 21080 C This routine also uses the Common variables EL0, H, TN, UROUND, 21081 C MITER, N, NFE, and NJE. 21082 C----------------------------------------------------------------------- 21083 NJE = NJE + 1 21084 IERPJ = 0 21085 JCUR = 1 21086 HL0 = H*EL0 21087 GO TO (100, 200, 300, 400, 500), MITER 21088 C If MITER = 1, call JAC and multiply by scalar. ----------------------- 21089 100 LENP = N*N 21090 DO 110 I = 1,LENP 21091 110 WM(I+2) = 0.0D0 21092 CALL JAC (NEQ, TN, Y, 0, 0, WM(3), N) 21093 CON = -HL0 21094 DO 120 I = 1,LENP 21095 120 WM(I+2) = WM(I+2)*CON 21096 GO TO 240 21097 C If MITER = 2, make N calls to F to approximate J. -------------------- 21098 200 FAC = DMNORM (N, SAVF, EWT) 21099 R0 = 1000.0D0*ABS(H)*UROUND*N*FAC 21100 IF (R0 .EQ. 0.0D0) R0 = 1.0D0 21101 SRUR = WM(1) 21102 J1 = 2 21103 DO 230 J = 1,N 21104 YJ = Y(J) 21105 R = MAX(SRUR*ABS(YJ),R0/EWT(J)) 21106 Y(J) = Y(J) + R 21107 FAC = -HL0/R 21108 CALL F (NEQ, TN, Y, FTEM) 21109 DO 220 I = 1,N 21110 220 WM(I+J1) = (FTEM(I) - SAVF(I))*FAC 21111 Y(J) = YJ 21112 J1 = J1 + N 21113 230 CONTINUE 21114 NFE = NFE + N 21115 240 CONTINUE 21116 C Compute norm of Jacobian. -------------------------------------------- 21117 PDNORM = DFNORM (N, WM(3), EWT)/ABS(HL0) 21118 C Add identity matrix. ------------------------------------------------- 21119 J = 3 21120 NP1 = N + 1 21121 DO 250 I = 1,N 21122 WM(J) = WM(J) + 1.0D0 21123 250 J = J + NP1 21124 C Do LU decomposition on P. -------------------------------------------- 21125 CALL DGEFA (WM(3), N, N, IWM(21), IER) 21126 IF (IER .NE. 0) IERPJ = 1 21127 RETURN 21128 C Dummy block only, since MITER is never 3 in this routine. ------------ 21129 300 RETURN 21130 C If MITER = 4, call JAC and multiply by scalar. ----------------------- 21131 400 ML = IWM(1) 21132 MU = IWM(2) 21133 ML3 = ML + 3 21134 MBAND = ML + MU + 1 21135 MEBAND = MBAND + ML 21136 LENP = MEBAND*N 21137 DO 410 I = 1,LENP 21138 410 WM(I+2) = 0.0D0 21139 CALL JAC (NEQ, TN, Y, ML, MU, WM(ML3), MEBAND) 21140 CON = -HL0 21141 DO 420 I = 1,LENP 21142 420 WM(I+2) = WM(I+2)*CON 21143 GO TO 570 21144 C If MITER = 5, make MBAND calls to F to approximate J. ---------------- 21145 500 ML = IWM(1) 21146 MU = IWM(2) 21147 MBAND = ML + MU + 1 21148 MBA = MIN(MBAND,N) 21149 MEBAND = MBAND + ML 21150 MEB1 = MEBAND - 1 21151 SRUR = WM(1) 21152 FAC = DMNORM (N, SAVF, EWT) 21153 R0 = 1000.0D0*ABS(H)*UROUND*N*FAC 21154 IF (R0 .EQ. 0.0D0) R0 = 1.0D0 21155 DO 560 J = 1,MBA 21156 DO 530 I = J,N,MBAND 21157 YI = Y(I) 21158 R = MAX(SRUR*ABS(YI),R0/EWT(I)) 21159 530 Y(I) = Y(I) + R 21160 CALL F (NEQ, TN, Y, FTEM) 21161 DO 550 JJ = J,N,MBAND 21162 Y(JJ) = YH(JJ,1) 21163 YJJ = Y(JJ) 21164 R = MAX(SRUR*ABS(YJJ),R0/EWT(JJ)) 21165 FAC = -HL0/R 21166 I1 = MAX(JJ-MU,1) 21167 I2 = MIN(JJ+ML,N) 21168 II = JJ*MEB1 - ML + 2 21169 DO 540 I = I1,I2 21170 540 WM(II+I) = (FTEM(I) - SAVF(I))*FAC 21171 550 CONTINUE 21172 560 CONTINUE 21173 NFE = NFE + MBA 21174 570 CONTINUE 21175 C Compute norm of Jacobian. -------------------------------------------- 21176 PDNORM = DBNORM (N, WM(ML+3), MEBAND, ML, MU, EWT)/ABS(HL0) 21177 C Add identity matrix. ------------------------------------------------- 21178 II = MBAND + 2 21179 DO 580 I = 1,N 21180 WM(II) = WM(II) + 1.0D0 21181 580 II = II + MEBAND 21182 C Do LU decomposition of P. -------------------------------------------- 21183 CALL DGBFA (WM(3), MEBAND, N, ML, MU, IWM(21), IER) 21184 IF (IER .NE. 0) IERPJ = 1 21185 RETURN 21186 C----------------------- End of Subroutine DPRJA ----------------------- 21187 END 21188 *DECK DMNORM 21189 DOUBLE PRECISION FUNCTION DMNORM (N, V, W) 21190 C----------------------------------------------------------------------- 21191 C This function routine computes the weighted max-norm 21192 C of the vector of length N contained in the array V, with weights 21193 C contained in the array w of length N: 21194 C DMNORM = MAX(i=1,...,N) ABS(V(i))*W(i) 21195 C----------------------------------------------------------------------- 21196 INTEGER N, I 21197 DOUBLE PRECISION V, W, VM 21198 DIMENSION V(N), W(N) 21199 VM = 0.0D0 21200 DO 10 I = 1,N 21201 10 VM = MAX(VM,ABS(V(I))*W(I)) 21202 DMNORM = VM 21203 RETURN 21204 C----------------------- End of Function DMNORM ------------------------ 21205 END 21206 *DECK DFNORM 21207 DOUBLE PRECISION FUNCTION DFNORM (N, A, W) 21208 C----------------------------------------------------------------------- 21209 C This function computes the norm of a full N by N matrix, 21210 C stored in the array A, that is consistent with the weighted max-norm 21211 C on vectors, with weights stored in the array W: 21212 C DFNORM = MAX(i=1,...,N) ( W(i) * Sum(j=1,...,N) ABS(a(i,j))/W(j) ) 21213 C----------------------------------------------------------------------- 21214 INTEGER N, I, J 21215 DOUBLE PRECISION A, W, AN, SUM 21216 DIMENSION A(N,N), W(N) 21217 AN = 0.0D0 21218 DO 20 I = 1,N 21219 SUM = 0.0D0 21220 DO 10 J = 1,N 21221 10 SUM = SUM + ABS(A(I,J))/W(J) 21222 AN = MAX(AN,SUM*W(I)) 21223 20 CONTINUE 21224 DFNORM = AN 21225 RETURN 21226 C----------------------- End of Function DFNORM ------------------------ 21227 END 21228 *DECK DBNORM 21229 DOUBLE PRECISION FUNCTION DBNORM (N, A, NRA, ML, MU, W) 21230 C----------------------------------------------------------------------- 21231 C This function computes the norm of a banded N by N matrix, 21232 C stored in the array A, that is consistent with the weighted max-norm 21233 C on vectors, with weights stored in the array W. 21234 C ML and MU are the lower and upper half-bandwidths of the matrix. 21235 C NRA is the first dimension of the A array, NRA .ge. ML+MU+1. 21236 C In terms of the matrix elements a(i,j), the norm is given by: 21237 C DBNORM = MAX(i=1,...,N) ( W(i) * Sum(j=1,...,N) ABS(a(i,j))/W(j) ) 21238 C----------------------------------------------------------------------- 21239 INTEGER N, NRA, ML, MU 21240 INTEGER I, I1, JLO, JHI, J 21241 DOUBLE PRECISION A, W 21242 DOUBLE PRECISION AN, SUM 21243 DIMENSION A(NRA,N), W(N) 21244 AN = 0.0D0 21245 DO 20 I = 1,N 21246 SUM = 0.0D0 21247 I1 = I + MU + 1 21248 JLO = MAX(I-ML,1) 21249 JHI = MIN(I+MU,N) 21250 DO 10 J = JLO,JHI 21251 10 SUM = SUM + ABS(A(I1-J,J))/W(J) 21252 AN = MAX(AN,SUM*W(I)) 21253 20 CONTINUE 21254 DBNORM = AN 21255 RETURN 21256 C----------------------- End of Function DBNORM ------------------------ 21257 END 21258 *DECK DSRCMA 21259 SUBROUTINE DSRCMA (RSAV, ISAV, JOB) 21260 C----------------------------------------------------------------------- 21261 C This routine saves or restores (depending on JOB) the contents of 21262 C the Common blocks DLS001, DLSA01, which are used 21263 C internally by one or more ODEPACK solvers. 21264 C 21265 C RSAV = real array of length 240 or more. 21266 C ISAV = integer array of length 46 or more. 21267 C JOB = flag indicating to save or restore the Common blocks: 21268 C JOB = 1 if Common is to be saved (written to RSAV/ISAV) 21269 C JOB = 2 if Common is to be restored (read from RSAV/ISAV) 21270 C A call with JOB = 2 presumes a prior call with JOB = 1. 21271 C----------------------------------------------------------------------- 21272 INTEGER ISAV, JOB 21273 INTEGER ILS, ILSA 21274 INTEGER I, LENRLS, LENILS, LENRLA, LENILA 21275 DOUBLE PRECISION RSAV 21276 DOUBLE PRECISION RLS, RLSA 21277 DIMENSION RSAV(*), ISAV(*) 21278 SAVE LENRLS, LENILS, LENRLA, LENILA 21279 COMMON /DLS001/ RLS(218), ILS(37) 21280 COMMON /DLSA01/ RLSA(22), ILSA(9) 21281 DATA LENRLS/218/, LENILS/37/, LENRLA/22/, LENILA/9/ 21282 C 21283 IF (JOB .EQ. 2) GO TO 100 21284 DO 10 I = 1,LENRLS 21285 10 RSAV(I) = RLS(I) 21286 DO 15 I = 1,LENRLA 21287 15 RSAV(LENRLS+I) = RLSA(I) 21288 C 21289 DO 20 I = 1,LENILS 21290 20 ISAV(I) = ILS(I) 21291 DO 25 I = 1,LENILA 21292 25 ISAV(LENILS+I) = ILSA(I) 21293 C 21294 RETURN 21295 C 21296 100 CONTINUE 21297 DO 110 I = 1,LENRLS 21298 110 RLS(I) = RSAV(I) 21299 DO 115 I = 1,LENRLA 21300 115 RLSA(I) = RSAV(LENRLS+I) 21301 C 21302 DO 120 I = 1,LENILS 21303 120 ILS(I) = ISAV(I) 21304 DO 125 I = 1,LENILA 21305 125 ILSA(I) = ISAV(LENILS+I) 21306 C 21307 RETURN 21308 C----------------------- End of Subroutine DSRCMA ---------------------- 21309 END 21310 *DECK DRCHEK 21311 SUBROUTINE DRCHEK (JOB, G, NEQ, Y, YH,NYH, G0, G1, GX, JROOT, IRT) 21312 EXTERNAL G 21313 INTEGER JOB, NEQ, NYH, JROOT, IRT 21314 DOUBLE PRECISION Y, YH, G0, G1, GX 21315 DIMENSION NEQ(*), Y(*), YH(NYH,*), G0(*), G1(*), GX(*), JROOT(*) 21316 INTEGER IOWND, IOWNS, 21317 1 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 21318 2 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 21319 3 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU 21320 INTEGER IOWND3, IOWNR3, IRFND, ITASKC, NGC, NGE 21321 DOUBLE PRECISION ROWNS, 21322 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND 21323 DOUBLE PRECISION ROWNR3, T0, TLAST, TOUTC 21324 COMMON /DLS001/ ROWNS(209), 21325 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND, 21326 2 IOWND(6), IOWNS(6), 21327 3 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 21328 4 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 21329 5 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU 21330 COMMON /DLSR01/ ROWNR3(2), T0, TLAST, TOUTC, 21331 1 IOWND3(3), IOWNR3(2), IRFND, ITASKC, NGC, NGE 21332 INTEGER I, IFLAG, JFLAG 21333 DOUBLE PRECISION HMING, T1, TEMP1, TEMP2, X 21334 LOGICAL ZROOT 21335 C----------------------------------------------------------------------- 21336 C This routine checks for the presence of a root in the 21337 C vicinity of the current T, in a manner depending on the 21338 C input flag JOB. It calls Subroutine DROOTS to locate the root 21339 C as precisely as possible. 21340 C 21341 C In addition to variables described previously, DRCHEK 21342 C uses the following for communication: 21343 C JOB = integer flag indicating type of call: 21344 C JOB = 1 means the problem is being initialized, and DRCHEK 21345 C is to look for a root at or very near the initial T. 21346 C JOB = 2 means a continuation call to the solver was just 21347 C made, and DRCHEK is to check for a root in the 21348 C relevant part of the step last taken. 21349 C JOB = 3 means a successful step was just taken, and DRCHEK 21350 C is to look for a root in the interval of the step. 21351 C G0 = array of length NG, containing the value of g at T = T0. 21352 C G0 is input for JOB .ge. 2, and output in all cases. 21353 C G1,GX = arrays of length NG for work space. 21354 C IRT = completion flag: 21355 C IRT = 0 means no root was found. 21356 C IRT = -1 means JOB = 1 and a root was found too near to T. 21357 C IRT = 1 means a legitimate root was found (JOB = 2 or 3). 21358 C On return, T0 is the root location, and Y is the 21359 C corresponding solution vector. 21360 C T0 = value of T at one endpoint of interval of interest. Only 21361 C roots beyond T0 in the direction of integration are sought. 21362 C T0 is input if JOB .ge. 2, and output in all cases. 21363 C T0 is updated by DRCHEK, whether a root is found or not. 21364 C TLAST = last value of T returned by the solver (input only). 21365 C TOUTC = copy of TOUT (input only). 21366 C IRFND = input flag showing whether the last step taken had a root. 21367 C IRFND = 1 if it did, = 0 if not. 21368 C ITASKC = copy of ITASK (input only). 21369 C NGC = copy of NG (input only). 21370 C----------------------------------------------------------------------- 21371 IRT = 0 21372 DO 10 I = 1,NGC 21373 10 JROOT(I) = 0 21374 HMING = (ABS(TN) + ABS(H))*UROUND*100.0D0 21375 C 21376 GO TO (100, 200, 300), JOB 21377 C 21378 C Evaluate g at initial T, and check for zero values. ------------------ 21379 100 CONTINUE 21380 T0 = TN 21381 CALL G (NEQ, T0, Y, NGC, G0) 21382 NGE = 1 21383 ZROOT = .FALSE. 21384 DO 110 I = 1,NGC 21385 110 IF (ABS(G0(I)) .LE. 0.0D0) ZROOT = .TRUE. 21386 IF (.NOT. ZROOT) GO TO 190 21387 C g has a zero at T. Look at g at T + (small increment). -------------- 21388 TEMP1 = SIGN(HMING,H) 21389 T0 = T0 + TEMP1 21390 TEMP2 = TEMP1/H 21391 DO 120 I = 1,N 21392 120 Y(I) = Y(I) + TEMP2*YH(I,2) 21393 CALL G (NEQ, T0, Y, NGC, G0) 21394 NGE = NGE + 1 21395 ZROOT = .FALSE. 21396 DO 130 I = 1,NGC 21397 130 IF (ABS(G0(I)) .LE. 0.0D0) ZROOT = .TRUE. 21398 IF (.NOT. ZROOT) GO TO 190 21399 C g has a zero at T and also close to T. Take error return. ----------- 21400 IRT = -1 21401 RETURN 21402 C 21403 190 CONTINUE 21404 RETURN 21405 C 21406 C 21407 200 CONTINUE 21408 IF (IRFND .EQ. 0) GO TO 260 21409 C If a root was found on the previous step, evaluate G0 = g(T0). ------- 21410 CALL DINTDY (T0, 0, YH, NYH, Y, IFLAG) 21411 CALL G (NEQ, T0, Y, NGC, G0) 21412 NGE = NGE + 1 21413 ZROOT = .FALSE. 21414 DO 210 I = 1,NGC 21415 210 IF (ABS(G0(I)) .LE. 0.0D0) ZROOT = .TRUE. 21416 IF (.NOT. ZROOT) GO TO 260 21417 C g has a zero at T0. Look at g at T + (small increment). ------------- 21418 TEMP1 = SIGN(HMING,H) 21419 T0 = T0 + TEMP1 21420 IF ((T0 - TN)*H .LT. 0.0D0) GO TO 230 21421 TEMP2 = TEMP1/H 21422 DO 220 I = 1,N 21423 220 Y(I) = Y(I) + TEMP2*YH(I,2) 21424 GO TO 240 21425 230 CALL DINTDY (T0, 0, YH, NYH, Y, IFLAG) 21426 240 CALL G (NEQ, T0, Y, NGC, G0) 21427 NGE = NGE + 1 21428 ZROOT = .FALSE. 21429 DO 250 I = 1,NGC 21430 IF (ABS(G0(I)) .GT. 0.0D0) GO TO 250 21431 JROOT(I) = 1 21432 ZROOT = .TRUE. 21433 250 CONTINUE 21434 IF (.NOT. ZROOT) GO TO 260 21435 C g has a zero at T0 and also close to T0. Return root. --------------- 21436 IRT = 1 21437 RETURN 21438 C G0 has no zero components. Proceed to check relevant interval. ------ 21439 260 IF (TN .EQ. TLAST) GO TO 390 21440 C 21441 300 CONTINUE 21442 C Set T1 to TN or TOUTC, whichever comes first, and get g at T1. ------- 21443 IF (ITASKC.EQ.2 .OR. ITASKC.EQ.3 .OR. ITASKC.EQ.5) GO TO 310 21444 IF ((TOUTC - TN)*H .GE. 0.0D0) GO TO 310 21445 T1 = TOUTC 21446 IF ((T1 - T0)*H .LE. 0.0D0) GO TO 390 21447 CALL DINTDY (T1, 0, YH, NYH, Y, IFLAG) 21448 GO TO 330 21449 310 T1 = TN 21450 DO 320 I = 1,N 21451 320 Y(I) = YH(I,1) 21452 330 CALL G (NEQ, T1, Y, NGC, G1) 21453 NGE = NGE + 1 21454 C Call DROOTS to search for root in interval from T0 to T1. ------------ 21455 JFLAG = 0 21456 350 CONTINUE 21457 CALL DROOTS (NGC, HMING, JFLAG, T0, T1, G0, G1, GX, X, JROOT) 21458 IF (JFLAG .GT. 1) GO TO 360 21459 CALL DINTDY (X, 0, YH, NYH, Y, IFLAG) 21460 CALL G (NEQ, X, Y, NGC, GX) 21461 NGE = NGE + 1 21462 GO TO 350 21463 360 T0 = X 21464 CALL DCOPY (NGC, GX, 1, G0, 1) 21465 IF (JFLAG .EQ. 4) GO TO 390 21466 C Found a root. Interpolate to X and return. -------------------------- 21467 CALL DINTDY (X, 0, YH, NYH, Y, IFLAG) 21468 IRT = 1 21469 RETURN 21470 C 21471 390 CONTINUE 21472 RETURN 21473 C----------------------- End of Subroutine DRCHEK ---------------------- 21474 END 21475 *DECK DROOTS 21476 SUBROUTINE DROOTS (NG, HMIN, JFLAG, X0, X1, G0, G1, GX, X, JROOT) 21477 INTEGER NG, JFLAG, JROOT 21478 DOUBLE PRECISION HMIN, X0, X1, G0, G1, GX, X 21479 DIMENSION G0(NG), G1(NG), GX(NG), JROOT(NG) 21480 INTEGER IOWND3, IMAX, LAST, IDUM3 21481 DOUBLE PRECISION ALPHA, X2, RDUM3 21482 COMMON /DLSR01/ ALPHA, X2, RDUM3(3), 21483 1 IOWND3(3), IMAX, LAST, IDUM3(4) 21484 C----------------------------------------------------------------------- 21485 C This subroutine finds the leftmost root of a set of arbitrary 21486 C functions gi(x) (i = 1,...,NG) in an interval (X0,X1). Only roots 21487 C of odd multiplicity (i.e. changes of sign of the gi) are found. 21488 C Here the sign of X1 - X0 is arbitrary, but is constant for a given 21489 C problem, and -leftmost- means nearest to X0. 21490 C The values of the vector-valued function g(x) = (gi, i=1...NG) 21491 C are communicated through the call sequence of DROOTS. 21492 C The method used is the Illinois algorithm. 21493 C 21494 C Reference: 21495 C Kathie L. Hiebert and Lawrence F. Shampine, Implicitly Defined 21496 C Output Points for Solutions of ODEs, Sandia Report SAND80-0180, 21497 C February 1980. 21498 C 21499 C Description of parameters. 21500 C 21501 C NG = number of functions gi, or the number of components of 21502 C the vector valued function g(x). Input only. 21503 C 21504 C HMIN = resolution parameter in X. Input only. When a root is 21505 C found, it is located only to within an error of HMIN in X. 21506 C Typically, HMIN should be set to something on the order of 21507 C 100 * UROUND * MAX(ABS(X0),ABS(X1)), 21508 C where UROUND is the unit roundoff of the machine. 21509 C 21510 C JFLAG = integer flag for input and output communication. 21511 C 21512 C On input, set JFLAG = 0 on the first call for the problem, 21513 C and leave it unchanged until the problem is completed. 21514 C (The problem is completed when JFLAG .ge. 2 on return.) 21515 C 21516 C On output, JFLAG has the following values and meanings: 21517 C JFLAG = 1 means DROOTS needs a value of g(x). Set GX = g(X) 21518 C and call DROOTS again. 21519 C JFLAG = 2 means a root has been found. The root is 21520 C at X, and GX contains g(X). (Actually, X is the 21521 C rightmost approximation to the root on an interval 21522 C (X0,X1) of size HMIN or less.) 21523 C JFLAG = 3 means X = X1 is a root, with one or more of the gi 21524 C being zero at X1 and no sign changes in (X0,X1). 21525 C GX contains g(X) on output. 21526 C JFLAG = 4 means no roots (of odd multiplicity) were 21527 C found in (X0,X1) (no sign changes). 21528 C 21529 C X0,X1 = endpoints of the interval where roots are sought. 21530 C X1 and X0 are input when JFLAG = 0 (first call), and 21531 C must be left unchanged between calls until the problem is 21532 C completed. X0 and X1 must be distinct, but X1 - X0 may be 21533 C of either sign. However, the notion of -left- and -right- 21534 C will be used to mean nearer to X0 or X1, respectively. 21535 C When JFLAG .ge. 2 on return, X0 and X1 are output, and 21536 C are the endpoints of the relevant interval. 21537 C 21538 C G0,G1 = arrays of length NG containing the vectors g(X0) and g(X1), 21539 C respectively. When JFLAG = 0, G0 and G1 are input and 21540 C none of the G0(i) should be zero. 21541 C When JFLAG .ge. 2 on return, G0 and G1 are output. 21542 C 21543 C GX = array of length NG containing g(X). GX is input 21544 C when JFLAG = 1, and output when JFLAG .ge. 2. 21545 C 21546 C X = independent variable value. Output only. 21547 C When JFLAG = 1 on output, X is the point at which g(x) 21548 C is to be evaluated and loaded into GX. 21549 C When JFLAG = 2 or 3, X is the root. 21550 C When JFLAG = 4, X is the right endpoint of the interval, X1. 21551 C 21552 C JROOT = integer array of length NG. Output only. 21553 C When JFLAG = 2 or 3, JROOT indicates which components 21554 C of g(x) have a root at X. JROOT(i) is 1 if the i-th 21555 C component has a root, and JROOT(i) = 0 otherwise. 21556 C----------------------------------------------------------------------- 21557 INTEGER I, IMXOLD, NXLAST 21558 DOUBLE PRECISION T2, TMAX, ZERO 21559 LOGICAL ZROOT, SGNCHG, XROOT 21560 SAVE ZERO 21561 DATA ZERO/0.0D0/ 21562 C 21563 IF (JFLAG .EQ. 1) GO TO 200 21564 C JFLAG .ne. 1. Check for change in sign of g or zero at X1. ---------- 21565 IMAX = 0 21566 TMAX = ZERO 21567 ZROOT = .FALSE. 21568 DO 120 I = 1,NG 21569 IF (ABS(G1(I)) .GT. ZERO) GO TO 110 21570 ZROOT = .TRUE. 21571 GO TO 120 21572 C At this point, G0(i) has been checked and cannot be zero. ------------ 21573 110 IF (SIGN(1.0D0,G0(I)) .EQ. SIGN(1.0D0,G1(I))) GO TO 120 21574 T2 = ABS(G1(I)/(G1(I)-G0(I))) 21575 IF (T2 .LE. TMAX) GO TO 120 21576 TMAX = T2 21577 IMAX = I 21578 120 CONTINUE 21579 IF (IMAX .GT. 0) GO TO 130 21580 SGNCHG = .FALSE. 21581 GO TO 140 21582 130 SGNCHG = .TRUE. 21583 140 IF (.NOT. SGNCHG) GO TO 400 21584 C There is a sign change. Find the first root in the interval. -------- 21585 XROOT = .FALSE. 21586 NXLAST = 0 21587 LAST = 1 21588 C 21589 C Repeat until the first root in the interval is found. Loop point. --- 21590 150 CONTINUE 21591 IF (XROOT) GO TO 300 21592 IF (NXLAST .EQ. LAST) GO TO 160 21593 ALPHA = 1.0D0 21594 GO TO 180 21595 160 IF (LAST .EQ. 0) GO TO 170 21596 ALPHA = 0.5D0*ALPHA 21597 GO TO 180 21598 170 ALPHA = 2.0D0*ALPHA 21599 180 X2 = X1 - (X1-X0)*G1(IMAX)/(G1(IMAX) - ALPHA*G0(IMAX)) 21600 IF ((ABS(X2-X0) .LT. HMIN) .AND. 21601 1 (ABS(X1-X0) .GT. 10.0D0*HMIN)) X2 = X0 + 0.1D0*(X1-X0) 21602 JFLAG = 1 21603 X = X2 21604 C Return to the calling routine to get a value of GX = g(X). ----------- 21605 RETURN 21606 C Check to see in which interval g changes sign. ----------------------- 21607 200 IMXOLD = IMAX 21608 IMAX = 0 21609 TMAX = ZERO 21610 ZROOT = .FALSE. 21611 DO 220 I = 1,NG 21612 IF (ABS(GX(I)) .GT. ZERO) GO TO 210 21613 ZROOT = .TRUE. 21614 GO TO 220 21615 C Neither G0(i) nor GX(i) can be zero at this point. ------------------- 21616 210 IF (SIGN(1.0D0,G0(I)) .EQ. SIGN(1.0D0,GX(I))) GO TO 220 21617 T2 = ABS(GX(I)/(GX(I) - G0(I))) 21618 IF (T2 .LE. TMAX) GO TO 220 21619 TMAX = T2 21620 IMAX = I 21621 220 CONTINUE 21622 IF (IMAX .GT. 0) GO TO 230 21623 SGNCHG = .FALSE. 21624 IMAX = IMXOLD 21625 GO TO 240 21626 230 SGNCHG = .TRUE. 21627 240 NXLAST = LAST 21628 IF (.NOT. SGNCHG) GO TO 250 21629 C Sign change between X0 and X2, so replace X1 with X2. ---------------- 21630 X1 = X2 21631 CALL DCOPY (NG, GX, 1, G1, 1) 21632 LAST = 1 21633 XROOT = .FALSE. 21634 GO TO 270 21635 250 IF (.NOT. ZROOT) GO TO 260 21636 C Zero value at X2 and no sign change in (X0,X2), so X2 is a root. ----- 21637 X1 = X2 21638 CALL DCOPY (NG, GX, 1, G1, 1) 21639 XROOT = .TRUE. 21640 GO TO 270 21641 C No sign change between X0 and X2. Replace X0 with X2. --------------- 21642 260 CONTINUE 21643 CALL DCOPY (NG, GX, 1, G0, 1) 21644 X0 = X2 21645 LAST = 0 21646 XROOT = .FALSE. 21647 270 IF (ABS(X1-X0) .LE. HMIN) XROOT = .TRUE. 21648 GO TO 150 21649 C 21650 C Return with X1 as the root. Set JROOT. Set X = X1 and GX = G1. ----- 21651 300 JFLAG = 2 21652 X = X1 21653 CALL DCOPY (NG, G1, 1, GX, 1) 21654 DO 320 I = 1,NG 21655 JROOT(I) = 0 21656 IF (ABS(G1(I)) .GT. ZERO) GO TO 310 21657 JROOT(I) = 1 21658 GO TO 320 21659 310 IF (SIGN(1.0D0,G0(I)) .NE. SIGN(1.0D0,G1(I))) JROOT(I) = 1 21660 320 CONTINUE 21661 RETURN 21662 C 21663 C No sign change in the interval. Check for zero at right endpoint. --- 21664 400 IF (.NOT. ZROOT) GO TO 420 21665 C 21666 C Zero value at X1 and no sign change in (X0,X1). Return JFLAG = 3. --- 21667 X = X1 21668 CALL DCOPY (NG, G1, 1, GX, 1) 21669 DO 410 I = 1,NG 21670 JROOT(I) = 0 21671 IF (ABS(G1(I)) .LE. ZERO) JROOT (I) = 1 21672 410 CONTINUE 21673 JFLAG = 3 21674 RETURN 21675 C 21676 C No sign changes in this interval. Set X = X1, return JFLAG = 4. ----- 21677 420 CALL DCOPY (NG, G1, 1, GX, 1) 21678 X = X1 21679 JFLAG = 4 21680 RETURN 21681 C----------------------- End of Subroutine DROOTS ---------------------- 21682 END 21683 *DECK DSRCAR 21684 SUBROUTINE DSRCAR (RSAV, ISAV, JOB) 21685 C----------------------------------------------------------------------- 21686 C This routine saves or restores (depending on JOB) the contents of 21687 C the Common blocks DLS001, DLSA01, DLSR01, which are used 21688 C internally by one or more ODEPACK solvers. 21689 C 21690 C RSAV = real array of length 245 or more. 21691 C ISAV = integer array of length 55 or more. 21692 C JOB = flag indicating to save or restore the Common blocks: 21693 C JOB = 1 if Common is to be saved (written to RSAV/ISAV) 21694 C JOB = 2 if Common is to be restored (read from RSAV/ISAV) 21695 C A call with JOB = 2 presumes a prior call with JOB = 1. 21696 C----------------------------------------------------------------------- 21697 INTEGER ISAV, JOB 21698 INTEGER ILS, ILSA, ILSR 21699 INTEGER I, IOFF, LENRLS, LENILS, LENRLA, LENILA, LENRLR, LENILR 21700 DOUBLE PRECISION RSAV 21701 DOUBLE PRECISION RLS, RLSA, RLSR 21702 DIMENSION RSAV(*), ISAV(*) 21703 SAVE LENRLS, LENILS, LENRLA, LENILA, LENRLR, LENILR 21704 COMMON /DLS001/ RLS(218), ILS(37) 21705 COMMON /DLSA01/ RLSA(22), ILSA(9) 21706 COMMON /DLSR01/ RLSR(5), ILSR(9) 21707 DATA LENRLS/218/, LENILS/37/, LENRLA/22/, LENILA/9/ 21708 DATA LENRLR/5/, LENILR/9/ 21709 C 21710 IF (JOB .EQ. 2) GO TO 100 21711 DO 10 I = 1,LENRLS 21712 10 RSAV(I) = RLS(I) 21713 DO 15 I = 1,LENRLA 21714 15 RSAV(LENRLS+I) = RLSA(I) 21715 IOFF = LENRLS + LENRLA 21716 DO 20 I = 1,LENRLR 21717 20 RSAV(IOFF+I) = RLSR(I) 21718 C 21719 DO 30 I = 1,LENILS 21720 30 ISAV(I) = ILS(I) 21721 DO 35 I = 1,LENILA 21722 35 ISAV(LENILS+I) = ILSA(I) 21723 IOFF = LENILS + LENILA 21724 DO 40 I = 1,LENILR 21725 40 ISAV(IOFF+I) = ILSR(I) 21726 C 21727 RETURN 21728 C 21729 100 CONTINUE 21730 DO 110 I = 1,LENRLS 21731 110 RLS(I) = RSAV(I) 21732 DO 115 I = 1,LENRLA 21733 115 RLSA(I) = RSAV(LENRLS+I) 21734 IOFF = LENRLS + LENRLA 21735 DO 120 I = 1,LENRLR 21736 120 RLSR(I) = RSAV(IOFF+I) 21737 C 21738 DO 130 I = 1,LENILS 21739 130 ILS(I) = ISAV(I) 21740 DO 135 I = 1,LENILA 21741 135 ILSA(I) = ISAV(LENILS+I) 21742 IOFF = LENILS + LENILA 21743 DO 140 I = 1,LENILR 21744 140 ILSR(I) = ISAV(IOFF+I) 21745 C 21746 RETURN 21747 C----------------------- End of Subroutine DSRCAR ---------------------- 21748 END 21749 *DECK DSTODPK 21750 SUBROUTINE DSTODPK (NEQ, Y, YH, NYH, YH1, EWT, SAVF, SAVX, ACOR, 21751 1 WM, IWM, F, JAC, PSOL) 21752 EXTERNAL F, JAC, PSOL 21753 INTEGER NEQ, NYH, IWM 21754 DOUBLE PRECISION Y, YH, YH1, EWT, SAVF, SAVX, ACOR, WM 21755 DIMENSION NEQ(*), Y(*), YH(NYH,*), YH1(*), EWT(*), SAVF(*), 21756 1 SAVX(*), ACOR(*), WM(*), IWM(*) 21757 INTEGER IOWND, IALTH, IPUP, LMAX, MEO, NQNYH, NSLP, 21758 1 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 21759 2 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 21760 3 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU 21761 INTEGER JPRE, JACFLG, LOCWP, LOCIWP, LSAVX, KMP, MAXL, MNEWT, 21762 1 NNI, NLI, NPS, NCFN, NCFL 21763 DOUBLE PRECISION CONIT, CRATE, EL, ELCO, HOLD, RMAX, TESCO, 21764 2 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND 21765 DOUBLE PRECISION DELT, EPCON, SQRTN, RSQRTN 21766 COMMON /DLS001/ CONIT, CRATE, EL(13), ELCO(13,12), 21767 1 HOLD, RMAX, TESCO(3,12), 21768 2 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND, 21769 3 IOWND(6), IALTH, IPUP, LMAX, MEO, NQNYH, NSLP, 21770 3 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 21771 4 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 21772 5 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU 21773 COMMON /DLPK01/ DELT, EPCON, SQRTN, RSQRTN, 21774 1 JPRE, JACFLG, LOCWP, LOCIWP, LSAVX, KMP, MAXL, MNEWT, 21775 2 NNI, NLI, NPS, NCFN, NCFL 21776 C----------------------------------------------------------------------- 21777 C DSTODPK performs one step of the integration of an initial value 21778 C problem for a system of Ordinary Differential Equations. 21779 C----------------------------------------------------------------------- 21780 C The following changes were made to generate Subroutine DSTODPK 21781 C from Subroutine DSTODE: 21782 C 1. The array SAVX was added to the call sequence. 21783 C 2. PJAC and SLVS were replaced by PSOL in the call sequence. 21784 C 3. The Common block /DLPK01/ was added for communication. 21785 C 4. The test constant EPCON is loaded into Common below statement 21786 C numbers 125 and 155, and used below statement 400. 21787 C 5. The Newton iteration counter MNEWT is set below 220 and 400. 21788 C 6. The call to PJAC was replaced with a call to DPKSET (fixed name), 21789 C with a longer call sequence, called depending on JACFLG. 21790 C 7. The corrector residual is stored in SAVX (not Y) at 360, 21791 C and the solution vector is in SAVX in the 380 loop. 21792 C 8. SLVS was renamed DSOLPK and includes NEQ, SAVX, EWT, F, and JAC. 21793 C SAVX was added because DSOLPK now needs Y and SAVF undisturbed. 21794 C 9. The nonlinear convergence failure count NCFN is set at 430. 21795 C----------------------------------------------------------------------- 21796 C Note: DSTODPK is independent of the value of the iteration method 21797 C indicator MITER, when this is .ne. 0, and hence is independent 21798 C of the type of chord method used, or the Jacobian structure. 21799 C Communication with DSTODPK is done with the following variables: 21800 C 21801 C NEQ = integer array containing problem size in NEQ(1), and 21802 C passed as the NEQ argument in all calls to F and JAC. 21803 C Y = an array of length .ge. N used as the Y argument in 21804 C all calls to F and JAC. 21805 C YH = an NYH by LMAX array containing the dependent variables 21806 C and their approximate scaled derivatives, where 21807 C LMAX = MAXORD + 1. YH(i,j+1) contains the approximate 21808 C j-th derivative of y(i), scaled by H**j/factorial(j) 21809 C (j = 0,1,...,NQ). On entry for the first step, the first 21810 C two columns of YH must be set from the initial values. 21811 C NYH = a constant integer .ge. N, the first dimension of YH. 21812 C YH1 = a one-dimensional array occupying the same space as YH. 21813 C EWT = an array of length N containing multiplicative weights 21814 C for local error measurements. Local errors in y(i) are 21815 C compared to 1.0/EWT(i) in various error tests. 21816 C SAVF = an array of working storage, of length N. 21817 C Also used for input of YH(*,MAXORD+2) when JSTART = -1 21818 C and MAXORD .lt. the current order NQ. 21819 C SAVX = an array of working storage, of length N. 21820 C ACOR = a work array of length N, used for the accumulated 21821 C corrections. On a successful return, ACOR(i) contains 21822 C the estimated one-step local error in y(i). 21823 C WM,IWM = real and integer work arrays associated with matrix 21824 C operations in chord iteration (MITER .ne. 0). 21825 C CCMAX = maximum relative change in H*EL0 before DPKSET is called. 21826 C H = the step size to be attempted on the next step. 21827 C H is altered by the error control algorithm during the 21828 C problem. H can be either positive or negative, but its 21829 C sign must remain constant throughout the problem. 21830 C HMIN = the minimum absolute value of the step size H to be used. 21831 C HMXI = inverse of the maximum absolute value of H to be used. 21832 C HMXI = 0.0 is allowed and corresponds to an infinite HMAX. 21833 C HMIN and HMXI may be changed at any time, but will not 21834 C take effect until the next change of H is considered. 21835 C TN = the independent variable. TN is updated on each step taken. 21836 C JSTART = an integer used for input only, with the following 21837 C values and meanings: 21838 C 0 perform the first step. 21839 C .gt.0 take a new step continuing from the last. 21840 C -1 take the next step with a new value of H, MAXORD, 21841 C N, METH, MITER, and/or matrix parameters. 21842 C -2 take the next step with a new value of H, 21843 C but with other inputs unchanged. 21844 C On return, JSTART is set to 1 to facilitate continuation. 21845 C KFLAG = a completion code with the following meanings: 21846 C 0 the step was succesful. 21847 C -1 the requested error could not be achieved. 21848 C -2 corrector convergence could not be achieved. 21849 C -3 fatal error in DPKSET or DSOLPK. 21850 C A return with KFLAG = -1 or -2 means either 21851 C ABS(H) = HMIN or 10 consecutive failures occurred. 21852 C On a return with KFLAG negative, the values of TN and 21853 C the YH array are as of the beginning of the last 21854 C step, and H is the last step size attempted. 21855 C MAXORD = the maximum order of integration method to be allowed. 21856 C MAXCOR = the maximum number of corrector iterations allowed. 21857 C MSBP = maximum number of steps between DPKSET calls (MITER .gt. 0). 21858 C MXNCF = maximum number of convergence failures allowed. 21859 C METH/MITER = the method flags. See description in driver. 21860 C N = the number of first-order differential equations. 21861 C----------------------------------------------------------------------- 21862 INTEGER I, I1, IREDO, IRET, J, JB, M, NCF, NEWQ 21863 DOUBLE PRECISION DCON, DDN, DEL, DELP, DSM, DUP, EXDN, EXSM, EXUP, 21864 1 R, RH, RHDN, RHSM, RHUP, TOLD, DVNORM 21865 C 21866 KFLAG = 0 21867 TOLD = TN 21868 NCF = 0 21869 IERPJ = 0 21870 IERSL = 0 21871 JCUR = 0 21872 ICF = 0 21873 DELP = 0.0D0 21874 IF (JSTART .GT. 0) GO TO 200 21875 IF (JSTART .EQ. -1) GO TO 100 21876 IF (JSTART .EQ. -2) GO TO 160 21877 C----------------------------------------------------------------------- 21878 C On the first call, the order is set to 1, and other variables are 21879 C initialized. RMAX is the maximum ratio by which H can be increased 21880 C in a single step. It is initially 1.E4 to compensate for the small 21881 C initial H, but then is normally equal to 10. If a failure 21882 C occurs (in corrector convergence or error test), RMAX is set at 2 21883 C for the next increase. 21884 C----------------------------------------------------------------------- 21885 LMAX = MAXORD + 1 21886 NQ = 1 21887 L = 2 21888 IALTH = 2 21889 RMAX = 10000.0D0 21890 RC = 0.0D0 21891 EL0 = 1.0D0 21892 CRATE = 0.7D0 21893 HOLD = H 21894 MEO = METH 21895 NSLP = 0 21896 IPUP = MITER 21897 IRET = 3 21898 GO TO 140 21899 C----------------------------------------------------------------------- 21900 C The following block handles preliminaries needed when JSTART = -1. 21901 C IPUP is set to MITER to force a matrix update. 21902 C If an order increase is about to be considered (IALTH = 1), 21903 C IALTH is reset to 2 to postpone consideration one more step. 21904 C If the caller has changed METH, DCFODE is called to reset 21905 C the coefficients of the method. 21906 C If the caller has changed MAXORD to a value less than the current 21907 C order NQ, NQ is reduced to MAXORD, and a new H chosen accordingly. 21908 C If H is to be changed, YH must be rescaled. 21909 C If H or METH is being changed, IALTH is reset to L = NQ + 1 21910 C to prevent further changes in H for that many steps. 21911 C----------------------------------------------------------------------- 21912 100 IPUP = MITER 21913 LMAX = MAXORD + 1 21914 IF (IALTH .EQ. 1) IALTH = 2 21915 IF (METH .EQ. MEO) GO TO 110 21916 CALL DCFODE (METH, ELCO, TESCO) 21917 MEO = METH 21918 IF (NQ .GT. MAXORD) GO TO 120 21919 IALTH = L 21920 IRET = 1 21921 GO TO 150 21922 110 IF (NQ .LE. MAXORD) GO TO 160 21923 120 NQ = MAXORD 21924 L = LMAX 21925 DO 125 I = 1,L 21926 125 EL(I) = ELCO(I,NQ) 21927 NQNYH = NQ*NYH 21928 RC = RC*EL(1)/EL0 21929 EL0 = EL(1) 21930 CONIT = 0.5D0/(NQ+2) 21931 EPCON = CONIT*TESCO(2,NQ) 21932 DDN = DVNORM (N, SAVF, EWT)/TESCO(1,L) 21933 EXDN = 1.0D0/L 21934 RHDN = 1.0D0/(1.3D0*DDN**EXDN + 0.0000013D0) 21935 RH = MIN(RHDN,1.0D0) 21936 IREDO = 3 21937 IF (H .EQ. HOLD) GO TO 170 21938 RH = MIN(RH,ABS(H/HOLD)) 21939 H = HOLD 21940 GO TO 175 21941 C----------------------------------------------------------------------- 21942 C DCFODE is called to get all the integration coefficients for the 21943 C current METH. Then the EL vector and related constants are reset 21944 C whenever the order NQ is changed, or at the start of the problem. 21945 C----------------------------------------------------------------------- 21946 140 CALL DCFODE (METH, ELCO, TESCO) 21947 150 DO 155 I = 1,L 21948 155 EL(I) = ELCO(I,NQ) 21949 NQNYH = NQ*NYH 21950 RC = RC*EL(1)/EL0 21951 EL0 = EL(1) 21952 CONIT = 0.5D0/(NQ+2) 21953 EPCON = CONIT*TESCO(2,NQ) 21954 GO TO (160, 170, 200), IRET 21955 C----------------------------------------------------------------------- 21956 C If H is being changed, the H ratio RH is checked against 21957 C RMAX, HMIN, and HMXI, and the YH array rescaled. IALTH is set to 21958 C L = NQ + 1 to prevent a change of H for that many steps, unless 21959 C forced by a convergence or error test failure. 21960 C----------------------------------------------------------------------- 21961 160 IF (H .EQ. HOLD) GO TO 200 21962 RH = H/HOLD 21963 H = HOLD 21964 IREDO = 3 21965 GO TO 175 21966 170 RH = MAX(RH,HMIN/ABS(H)) 21967 175 RH = MIN(RH,RMAX) 21968 RH = RH/MAX(1.0D0,ABS(H)*HMXI*RH) 21969 R = 1.0D0 21970 DO 180 J = 2,L 21971 R = R*RH 21972 DO 180 I = 1,N 21973 180 YH(I,J) = YH(I,J)*R 21974 H = H*RH 21975 RC = RC*RH 21976 IALTH = L 21977 IF (IREDO .EQ. 0) GO TO 690 21978 C----------------------------------------------------------------------- 21979 C This section computes the predicted values by effectively 21980 C multiplying the YH array by the Pascal triangle matrix. 21981 C The flag IPUP is set according to whether matrix data is involved 21982 C (JACFLG .ne. 0) or not (JACFLG = 0), to trigger a call to DPKSET. 21983 C IPUP is set to MITER when RC differs from 1 by more than CCMAX, 21984 C and at least every MSBP steps, when JACFLG = 1. 21985 C RC is the ratio of new to old values of the coefficient H*EL(1). 21986 C----------------------------------------------------------------------- 21987 200 IF (JACFLG .NE. 0) GO TO 202 21988 IPUP = 0 21989 CRATE = 0.7D0 21990 GO TO 205 21991 202 IF (ABS(RC-1.0D0) .GT. CCMAX) IPUP = MITER 21992 IF (NST .GE. NSLP+MSBP) IPUP = MITER 21993 205 TN = TN + H 21994 I1 = NQNYH + 1 21995 DO 215 JB = 1,NQ 21996 I1 = I1 - NYH 21997 CDIR$ IVDEP 21998 DO 210 I = I1,NQNYH 21999 210 YH1(I) = YH1(I) + YH1(I+NYH) 22000 215 CONTINUE 22001 C----------------------------------------------------------------------- 22002 C Up to MAXCOR corrector iterations are taken. A convergence test is 22003 C made on the RMS-norm of each correction, weighted by the error 22004 C weight vector EWT. The sum of the corrections is accumulated in the 22005 C vector ACOR(i). The YH array is not altered in the corrector loop. 22006 C----------------------------------------------------------------------- 22007 220 M = 0 22008 MNEWT = 0 22009 DO 230 I = 1,N 22010 230 Y(I) = YH(I,1) 22011 CALL F (NEQ, TN, Y, SAVF) 22012 NFE = NFE + 1 22013 IF (IPUP .LE. 0) GO TO 250 22014 C----------------------------------------------------------------------- 22015 C If indicated, DPKSET is called to update any matrix data needed, 22016 C before starting the corrector iteration. 22017 C IPUP is set to 0 as an indicator that this has been done. 22018 C----------------------------------------------------------------------- 22019 CALL DPKSET (NEQ, Y, YH1, EWT, ACOR, SAVF, WM, IWM, F, JAC) 22020 IPUP = 0 22021 RC = 1.0D0 22022 NSLP = NST 22023 CRATE = 0.7D0 22024 IF (IERPJ .NE. 0) GO TO 430 22025 250 DO 260 I = 1,N 22026 260 ACOR(I) = 0.0D0 22027 270 IF (MITER .NE. 0) GO TO 350 22028 C----------------------------------------------------------------------- 22029 C In the case of functional iteration, update Y directly from 22030 C the result of the last function evaluation. 22031 C----------------------------------------------------------------------- 22032 DO 290 I = 1,N 22033 SAVF(I) = H*SAVF(I) - YH(I,2) 22034 290 Y(I) = SAVF(I) - ACOR(I) 22035 DEL = DVNORM (N, Y, EWT) 22036 DO 300 I = 1,N 22037 Y(I) = YH(I,1) + EL(1)*SAVF(I) 22038 300 ACOR(I) = SAVF(I) 22039 GO TO 400 22040 C----------------------------------------------------------------------- 22041 C In the case of the chord method, compute the corrector error, 22042 C and solve the linear system with that as right-hand side and 22043 C P as coefficient matrix. 22044 C----------------------------------------------------------------------- 22045 350 DO 360 I = 1,N 22046 360 SAVX(I) = H*SAVF(I) - (YH(I,2) + ACOR(I)) 22047 CALL DSOLPK (NEQ, Y, SAVF, SAVX, EWT, WM, IWM, F, PSOL) 22048 IF (IERSL .LT. 0) GO TO 430 22049 IF (IERSL .GT. 0) GO TO 410 22050 DEL = DVNORM (N, SAVX, EWT) 22051 DO 380 I = 1,N 22052 ACOR(I) = ACOR(I) + SAVX(I) 22053 380 Y(I) = YH(I,1) + EL(1)*ACOR(I) 22054 C----------------------------------------------------------------------- 22055 C Test for convergence. If M .gt. 0, an estimate of the convergence 22056 C rate constant is stored in CRATE, and this is used in the test. 22057 C----------------------------------------------------------------------- 22058 400 IF (M .NE. 0) CRATE = MAX(0.2D0*CRATE,DEL/DELP) 22059 DCON = DEL*MIN(1.0D0,1.5D0*CRATE)/EPCON 22060 IF (DCON .LE. 1.0D0) GO TO 450 22061 M = M + 1 22062 IF (M .EQ. MAXCOR) GO TO 410 22063 IF (M .GE. 2 .AND. DEL .GT. 2.0D0*DELP) GO TO 410 22064 MNEWT = M 22065 DELP = DEL 22066 CALL F (NEQ, TN, Y, SAVF) 22067 NFE = NFE + 1 22068 GO TO 270 22069 C----------------------------------------------------------------------- 22070 C The corrector iteration failed to converge. 22071 C If MITER .ne. 0 and the Jacobian is out of date, DPKSET is called for 22072 C the next try. Otherwise the YH array is retracted to its values 22073 C before prediction, and H is reduced, if possible. If H cannot be 22074 C reduced or MXNCF failures have occurred, exit with KFLAG = -2. 22075 C----------------------------------------------------------------------- 22076 410 IF (MITER.EQ.0 .OR. JCUR.EQ.1 .OR. JACFLG.EQ.0) GO TO 430 22077 ICF = 1 22078 IPUP = MITER 22079 GO TO 220 22080 430 ICF = 2 22081 NCF = NCF + 1 22082 NCFN = NCFN + 1 22083 RMAX = 2.0D0 22084 TN = TOLD 22085 I1 = NQNYH + 1 22086 DO 445 JB = 1,NQ 22087 I1 = I1 - NYH 22088 CDIR$ IVDEP 22089 DO 440 I = I1,NQNYH 22090 440 YH1(I) = YH1(I) - YH1(I+NYH) 22091 445 CONTINUE 22092 IF (IERPJ .LT. 0 .OR. IERSL .LT. 0) GO TO 680 22093 IF (ABS(H) .LE. HMIN*1.00001D0) GO TO 670 22094 IF (NCF .EQ. MXNCF) GO TO 670 22095 RH = 0.5D0 22096 IPUP = MITER 22097 IREDO = 1 22098 GO TO 170 22099 C----------------------------------------------------------------------- 22100 C The corrector has converged. JCUR is set to 0 22101 C to signal that the Jacobian involved may need updating later. 22102 C The local error test is made and control passes to statement 500 22103 C if it fails. 22104 C----------------------------------------------------------------------- 22105 450 JCUR = 0 22106 IF (M .EQ. 0) DSM = DEL/TESCO(2,NQ) 22107 IF (M .GT. 0) DSM = DVNORM (N, ACOR, EWT)/TESCO(2,NQ) 22108 IF (DSM .GT. 1.0D0) GO TO 500 22109 C----------------------------------------------------------------------- 22110 C After a successful step, update the YH array. 22111 C Consider changing H if IALTH = 1. Otherwise decrease IALTH by 1. 22112 C If IALTH is then 1 and NQ .lt. MAXORD, then ACOR is saved for 22113 C use in a possible order increase on the next step. 22114 C If a change in H is considered, an increase or decrease in order 22115 C by one is considered also. A change in H is made only if it is by a 22116 C factor of at least 1.1. If not, IALTH is set to 3 to prevent 22117 C testing for that many steps. 22118 C----------------------------------------------------------------------- 22119 KFLAG = 0 22120 IREDO = 0 22121 NST = NST + 1 22122 HU = H 22123 NQU = NQ 22124 DO 470 J = 1,L 22125 DO 470 I = 1,N 22126 470 YH(I,J) = YH(I,J) + EL(J)*ACOR(I) 22127 IALTH = IALTH - 1 22128 IF (IALTH .EQ. 0) GO TO 520 22129 IF (IALTH .GT. 1) GO TO 700 22130 IF (L .EQ. LMAX) GO TO 700 22131 DO 490 I = 1,N 22132 490 YH(I,LMAX) = ACOR(I) 22133 GO TO 700 22134 C----------------------------------------------------------------------- 22135 C The error test failed. KFLAG keeps track of multiple failures. 22136 C Restore TN and the YH array to their previous values, and prepare 22137 C to try the step again. Compute the optimum step size for this or 22138 C one lower order. After 2 or more failures, H is forced to decrease 22139 C by a factor of 0.2 or less. 22140 C----------------------------------------------------------------------- 22141 500 KFLAG = KFLAG - 1 22142 TN = TOLD 22143 I1 = NQNYH + 1 22144 DO 515 JB = 1,NQ 22145 I1 = I1 - NYH 22146 CDIR$ IVDEP 22147 DO 510 I = I1,NQNYH 22148 510 YH1(I) = YH1(I) - YH1(I+NYH) 22149 515 CONTINUE 22150 RMAX = 2.0D0 22151 IF (ABS(H) .LE. HMIN*1.00001D0) GO TO 660 22152 IF (KFLAG .LE. -3) GO TO 640 22153 IREDO = 2 22154 RHUP = 0.0D0 22155 GO TO 540 22156 C----------------------------------------------------------------------- 22157 C Regardless of the success or failure of the step, factors 22158 C RHDN, RHSM, and RHUP are computed, by which H could be multiplied 22159 C at order NQ - 1, order NQ, or order NQ + 1, respectively. 22160 C In the case of failure, RHUP = 0.0 to avoid an order increase. 22161 C the largest of these is determined and the new order chosen 22162 C accordingly. If the order is to be increased, we compute one 22163 C additional scaled derivative. 22164 C----------------------------------------------------------------------- 22165 520 RHUP = 0.0D0 22166 IF (L .EQ. LMAX) GO TO 540 22167 DO 530 I = 1,N 22168 530 SAVF(I) = ACOR(I) - YH(I,LMAX) 22169 DUP = DVNORM (N, SAVF, EWT)/TESCO(3,NQ) 22170 EXUP = 1.0D0/(L+1) 22171 RHUP = 1.0D0/(1.4D0*DUP**EXUP + 0.0000014D0) 22172 540 EXSM = 1.0D0/L 22173 RHSM = 1.0D0/(1.2D0*DSM**EXSM + 0.0000012D0) 22174 RHDN = 0.0D0 22175 IF (NQ .EQ. 1) GO TO 560 22176 DDN = DVNORM (N, YH(1,L), EWT)/TESCO(1,NQ) 22177 EXDN = 1.0D0/NQ 22178 RHDN = 1.0D0/(1.3D0*DDN**EXDN + 0.0000013D0) 22179 560 IF (RHSM .GE. RHUP) GO TO 570 22180 IF (RHUP .GT. RHDN) GO TO 590 22181 GO TO 580 22182 570 IF (RHSM .LT. RHDN) GO TO 580 22183 NEWQ = NQ 22184 RH = RHSM 22185 GO TO 620 22186 580 NEWQ = NQ - 1 22187 RH = RHDN 22188 IF (KFLAG .LT. 0 .AND. RH .GT. 1.0D0) RH = 1.0D0 22189 GO TO 620 22190 590 NEWQ = L 22191 RH = RHUP 22192 IF (RH .LT. 1.1D0) GO TO 610 22193 R = EL(L)/L 22194 DO 600 I = 1,N 22195 600 YH(I,NEWQ+1) = ACOR(I)*R 22196 GO TO 630 22197 610 IALTH = 3 22198 GO TO 700 22199 620 IF ((KFLAG .EQ. 0) .AND. (RH .LT. 1.1D0)) GO TO 610 22200 IF (KFLAG .LE. -2) RH = MIN(RH,0.2D0) 22201 C----------------------------------------------------------------------- 22202 C If there is a change of order, reset NQ, L, and the coefficients. 22203 C In any case H is reset according to RH and the YH array is rescaled. 22204 C Then exit from 690 if the step was OK, or redo the step otherwise. 22205 C----------------------------------------------------------------------- 22206 IF (NEWQ .EQ. NQ) GO TO 170 22207 630 NQ = NEWQ 22208 L = NQ + 1 22209 IRET = 2 22210 GO TO 150 22211 C----------------------------------------------------------------------- 22212 C Control reaches this section if 3 or more failures have occured. 22213 C If 10 failures have occurred, exit with KFLAG = -1. 22214 C It is assumed that the derivatives that have accumulated in the 22215 C YH array have errors of the wrong order. Hence the first 22216 C derivative is recomputed, and the order is set to 1. Then 22217 C H is reduced by a factor of 10, and the step is retried, 22218 C until it succeeds or H reaches HMIN. 22219 C----------------------------------------------------------------------- 22220 640 IF (KFLAG .EQ. -10) GO TO 660 22221 RH = 0.1D0 22222 RH = MAX(HMIN/ABS(H),RH) 22223 H = H*RH 22224 DO 645 I = 1,N 22225 645 Y(I) = YH(I,1) 22226 CALL F (NEQ, TN, Y, SAVF) 22227 NFE = NFE + 1 22228 DO 650 I = 1,N 22229 650 YH(I,2) = H*SAVF(I) 22230 IPUP = MITER 22231 IALTH = 5 22232 IF (NQ .EQ. 1) GO TO 200 22233 NQ = 1 22234 L = 2 22235 IRET = 3 22236 GO TO 150 22237 C----------------------------------------------------------------------- 22238 C All returns are made through this section. H is saved in HOLD 22239 C to allow the caller to change H on the next step. 22240 C----------------------------------------------------------------------- 22241 660 KFLAG = -1 22242 GO TO 720 22243 670 KFLAG = -2 22244 GO TO 720 22245 680 KFLAG = -3 22246 GO TO 720 22247 690 RMAX = 10.0D0 22248 700 R = 1.0D0/TESCO(2,NQU) 22249 DO 710 I = 1,N 22250 710 ACOR(I) = ACOR(I)*R 22251 720 HOLD = H 22252 JSTART = 1 22253 RETURN 22254 C----------------------- End of Subroutine DSTODPK --------------------- 22255 END 22256 *DECK DPKSET 22257 SUBROUTINE DPKSET (NEQ, Y, YSV, EWT, FTEM, SAVF, WM, IWM, F, JAC) 22258 EXTERNAL F, JAC 22259 INTEGER NEQ, IWM 22260 DOUBLE PRECISION Y, YSV, EWT, FTEM, SAVF, WM 22261 DIMENSION NEQ(*), Y(*), YSV(*), EWT(*), FTEM(*), SAVF(*), 22262 1 WM(*), IWM(*) 22263 INTEGER IOWND, IOWNS, 22264 1 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 22265 2 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 22266 3 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU 22267 INTEGER JPRE, JACFLG, LOCWP, LOCIWP, LSAVX, KMP, MAXL, MNEWT, 22268 1 NNI, NLI, NPS, NCFN, NCFL 22269 DOUBLE PRECISION ROWNS, 22270 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND 22271 DOUBLE PRECISION DELT, EPCON, SQRTN, RSQRTN 22272 COMMON /DLS001/ ROWNS(209), 22273 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND, 22274 2 IOWND(6), IOWNS(6), 22275 3 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 22276 4 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 22277 5 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU 22278 COMMON /DLPK01/ DELT, EPCON, SQRTN, RSQRTN, 22279 1 JPRE, JACFLG, LOCWP, LOCIWP, LSAVX, KMP, MAXL, MNEWT, 22280 2 NNI, NLI, NPS, NCFN, NCFL 22281 C----------------------------------------------------------------------- 22282 C DPKSET is called by DSTODPK to interface with the user-supplied 22283 C routine JAC, to compute and process relevant parts of 22284 C the matrix P = I - H*EL(1)*J , where J is the Jacobian df/dy, 22285 C as need for preconditioning matrix operations later. 22286 C 22287 C In addition to variables described previously, communication 22288 C with DPKSET uses the following: 22289 C Y = array containing predicted values on entry. 22290 C YSV = array containing predicted y, to be saved (YH1 in DSTODPK). 22291 C FTEM = work array of length N (ACOR in DSTODPK). 22292 C SAVF = array containing f evaluated at predicted y. 22293 C WM = real work space for matrices. 22294 C Space for preconditioning data starts at WM(LOCWP). 22295 C IWM = integer work space. 22296 C Space for preconditioning data starts at IWM(LOCIWP). 22297 C IERPJ = output error flag, = 0 if no trouble, .gt. 0 if 22298 C JAC returned an error flag. 22299 C JCUR = output flag = 1 to indicate that the Jacobian matrix 22300 C (or approximation) is now current. 22301 C This routine also uses Common variables EL0, H, TN, IERPJ, JCUR, NJE. 22302 C----------------------------------------------------------------------- 22303 INTEGER IER 22304 DOUBLE PRECISION HL0 22305 C 22306 IERPJ = 0 22307 JCUR = 1 22308 HL0 = EL0*H 22309 CALL JAC (F, NEQ, TN, Y, YSV, EWT, SAVF, FTEM, HL0, 22310 1 WM(LOCWP), IWM(LOCIWP), IER) 22311 NJE = NJE + 1 22312 IF (IER .EQ. 0) RETURN 22313 IERPJ = 1 22314 RETURN 22315 C----------------------- End of Subroutine DPKSET ---------------------- 22316 END 22317 *DECK DSOLPK 22318 SUBROUTINE DSOLPK (NEQ, Y, SAVF, X, EWT, WM, IWM, F, PSOL) 22319 EXTERNAL F, PSOL 22320 INTEGER NEQ, IWM 22321 DOUBLE PRECISION Y, SAVF, X, EWT, WM 22322 DIMENSION NEQ(*), Y(*), SAVF(*), X(*), EWT(*), WM(*), IWM(*) 22323 INTEGER IOWND, IOWNS, 22324 1 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 22325 2 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 22326 3 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU 22327 INTEGER JPRE, JACFLG, LOCWP, LOCIWP, LSAVX, KMP, MAXL, MNEWT, 22328 1 NNI, NLI, NPS, NCFN, NCFL 22329 DOUBLE PRECISION ROWNS, 22330 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND 22331 DOUBLE PRECISION DELT, EPCON, SQRTN, RSQRTN 22332 COMMON /DLS001/ ROWNS(209), 22333 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND, 22334 2 IOWND(6), IOWNS(6), 22335 3 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 22336 4 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 22337 5 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU 22338 COMMON /DLPK01/ DELT, EPCON, SQRTN, RSQRTN, 22339 1 JPRE, JACFLG, LOCWP, LOCIWP, LSAVX, KMP, MAXL, MNEWT, 22340 2 NNI, NLI, NPS, NCFN, NCFL 22341 C----------------------------------------------------------------------- 22342 C This routine interfaces to one of DSPIOM, DSPIGMR, DPCG, DPCGS, or 22343 C DUSOL, for the solution of the linear system arising from a Newton 22344 C iteration. It is called if MITER .ne. 0. 22345 C In addition to variables described elsewhere, 22346 C communication with DSOLPK uses the following variables: 22347 C WM = real work space containing data for the algorithm 22348 C (Krylov basis vectors, Hessenberg matrix, etc.) 22349 C IWM = integer work space containing data for the algorithm 22350 C X = the right-hand side vector on input, and the solution vector 22351 C on output, of length N. 22352 C IERSL = output flag (in Common): 22353 C IERSL = 0 means no trouble occurred. 22354 C IERSL = 1 means the iterative method failed to converge. 22355 C If the preconditioner is out of date, the step 22356 C is repeated with a new preconditioner. 22357 C Otherwise, the stepsize is reduced (forcing a 22358 C new evaluation of the preconditioner) and the 22359 C step is repeated. 22360 C IERSL = -1 means there was a nonrecoverable error in the 22361 C iterative solver, and an error exit occurs. 22362 C This routine also uses the Common variables TN, EL0, H, N, MITER, 22363 C DELT, EPCON, SQRTN, RSQRTN, MAXL, KMP, MNEWT, NNI, NLI, NPS, NCFL, 22364 C LOCWP, LOCIWP. 22365 C----------------------------------------------------------------------- 22366 INTEGER IFLAG, LB, LDL, LHES, LIOM, LGMR, LPCG, LP, LQ, LR, 22367 1 LV, LW, LWK, LZ, MAXLP1, NPSL 22368 DOUBLE PRECISION DELTA, HL0 22369 C 22370 IERSL = 0 22371 HL0 = H*EL0 22372 DELTA = DELT*EPCON 22373 GO TO (100, 200, 300, 400, 900, 900, 900, 900, 900), MITER 22374 C----------------------------------------------------------------------- 22375 C Use the SPIOM algorithm to solve the linear system P*x = -f. 22376 C----------------------------------------------------------------------- 22377 100 CONTINUE 22378 LV = 1 22379 LB = LV + N*MAXL 22380 LHES = LB + N 22381 LWK = LHES + MAXL*MAXL 22382 CALL DCOPY (N, X, 1, WM(LB), 1) 22383 CALL DSCAL (N, RSQRTN, EWT, 1) 22384 CALL DSPIOM (NEQ, TN, Y, SAVF, WM(LB), EWT, N, MAXL, KMP, DELTA, 22385 1 HL0, JPRE, MNEWT, F, PSOL, NPSL, X, WM(LV), WM(LHES), IWM, 22386 2 LIOM, WM(LOCWP), IWM(LOCIWP), WM(LWK), IFLAG) 22387 NNI = NNI + 1 22388 NLI = NLI + LIOM 22389 NPS = NPS + NPSL 22390 CALL DSCAL (N, SQRTN, EWT, 1) 22391 IF (IFLAG .NE. 0) NCFL = NCFL + 1 22392 IF (IFLAG .GE. 2) IERSL = 1 22393 IF (IFLAG .LT. 0) IERSL = -1 22394 RETURN 22395 C----------------------------------------------------------------------- 22396 C Use the SPIGMR algorithm to solve the linear system P*x = -f. 22397 C----------------------------------------------------------------------- 22398 200 CONTINUE 22399 MAXLP1 = MAXL + 1 22400 LV = 1 22401 LB = LV + N*MAXL 22402 LHES = LB + N + 1 22403 LQ = LHES + MAXL*MAXLP1 22404 LWK = LQ + 2*MAXL 22405 LDL = LWK + MIN(1,MAXL-KMP)*N 22406 CALL DCOPY (N, X, 1, WM(LB), 1) 22407 CALL DSCAL (N, RSQRTN, EWT, 1) 22408 CALL DSPIGMR (NEQ, TN, Y, SAVF, WM(LB), EWT, N, MAXL, MAXLP1, KMP, 22409 1 DELTA, HL0, JPRE, MNEWT, F, PSOL, NPSL, X, WM(LV), WM(LHES), 22410 2 WM(LQ), LGMR, WM(LOCWP), IWM(LOCIWP), WM(LWK), WM(LDL), IFLAG) 22411 NNI = NNI + 1 22412 NLI = NLI + LGMR 22413 NPS = NPS + NPSL 22414 CALL DSCAL (N, SQRTN, EWT, 1) 22415 IF (IFLAG .NE. 0) NCFL = NCFL + 1 22416 IF (IFLAG .GE. 2) IERSL = 1 22417 IF (IFLAG .LT. 0) IERSL = -1 22418 RETURN 22419 C----------------------------------------------------------------------- 22420 C Use DPCG to solve the linear system P*x = -f 22421 C----------------------------------------------------------------------- 22422 300 CONTINUE 22423 LR = 1 22424 LP = LR + N 22425 LW = LP + N 22426 LZ = LW + N 22427 LWK = LZ + N 22428 CALL DCOPY (N, X, 1, WM(LR), 1) 22429 CALL DPCG (NEQ, TN, Y, SAVF, WM(LR), EWT, N, MAXL, DELTA, HL0, 22430 1 JPRE, MNEWT, F, PSOL, NPSL, X, WM(LP), WM(LW), WM(LZ), 22431 2 LPCG, WM(LOCWP), IWM(LOCIWP), WM(LWK), IFLAG) 22432 NNI = NNI + 1 22433 NLI = NLI + LPCG 22434 NPS = NPS + NPSL 22435 IF (IFLAG .NE. 0) NCFL = NCFL + 1 22436 IF (IFLAG .GE. 2) IERSL = 1 22437 IF (IFLAG .LT. 0) IERSL = -1 22438 RETURN 22439 C----------------------------------------------------------------------- 22440 C Use DPCGS to solve the linear system P*x = -f 22441 C----------------------------------------------------------------------- 22442 400 CONTINUE 22443 LR = 1 22444 LP = LR + N 22445 LW = LP + N 22446 LZ = LW + N 22447 LWK = LZ + N 22448 CALL DCOPY (N, X, 1, WM(LR), 1) 22449 CALL DPCGS (NEQ, TN, Y, SAVF, WM(LR), EWT, N, MAXL, DELTA, HL0, 22450 1 JPRE, MNEWT, F, PSOL, NPSL, X, WM(LP), WM(LW), WM(LZ), 22451 2 LPCG, WM(LOCWP), IWM(LOCIWP), WM(LWK), IFLAG) 22452 NNI = NNI + 1 22453 NLI = NLI + LPCG 22454 NPS = NPS + NPSL 22455 IF (IFLAG .NE. 0) NCFL = NCFL + 1 22456 IF (IFLAG .GE. 2) IERSL = 1 22457 IF (IFLAG .LT. 0) IERSL = -1 22458 RETURN 22459 C----------------------------------------------------------------------- 22460 C Use DUSOL, which interfaces to PSOL, to solve the linear system 22461 C (no Krylov iteration). 22462 C----------------------------------------------------------------------- 22463 900 CONTINUE 22464 LB = 1 22465 LWK = LB + N 22466 CALL DCOPY (N, X, 1, WM(LB), 1) 22467 CALL DUSOL (NEQ, TN, Y, SAVF, WM(LB), EWT, N, DELTA, HL0, MNEWT, 22468 1 PSOL, NPSL, X, WM(LOCWP), IWM(LOCIWP), WM(LWK), IFLAG) 22469 NNI = NNI + 1 22470 NPS = NPS + NPSL 22471 IF (IFLAG .NE. 0) NCFL = NCFL + 1 22472 IF (IFLAG .EQ. 3) IERSL = 1 22473 IF (IFLAG .LT. 0) IERSL = -1 22474 RETURN 22475 C----------------------- End of Subroutine DSOLPK ---------------------- 22476 END 22477 *DECK DSPIOM 22478 SUBROUTINE DSPIOM (NEQ, TN, Y, SAVF, B, WGHT, N, MAXL, KMP, DELTA, 22479 1 HL0, JPRE, MNEWT, F, PSOL, NPSL, X, V, HES, IPVT, 22480 2 LIOM, WP, IWP, WK, IFLAG) 22481 EXTERNAL F, PSOL 22482 INTEGER NEQ,N,MAXL,KMP,JPRE,MNEWT,NPSL,IPVT,LIOM,IWP,IFLAG 22483 DOUBLE PRECISION TN,Y,SAVF,B,WGHT,DELTA,HL0,X,V,HES,WP,WK 22484 DIMENSION NEQ(*), Y(*), SAVF(*), B(*), WGHT(*), X(*), V(N,*), 22485 1 HES(MAXL,MAXL), IPVT(*), WP(*), IWP(*), WK(*) 22486 C----------------------------------------------------------------------- 22487 C This routine solves the linear system A * x = b using a scaled 22488 C preconditioned version of the Incomplete Orthogonalization Method. 22489 C An initial guess of x = 0 is assumed. 22490 C----------------------------------------------------------------------- 22491 C 22492 C On entry 22493 C 22494 C NEQ = problem size, passed to F and PSOL (NEQ(1) = N). 22495 C 22496 C TN = current value of t. 22497 C 22498 C Y = array containing current dependent variable vector. 22499 C 22500 C SAVF = array containing current value of f(t,y). 22501 C 22502 C B = the right hand side of the system A*x = b. 22503 C B is also used as work space when computing the 22504 C final approximation. 22505 C (B is the same as V(*,MAXL+1) in the call to DSPIOM.) 22506 C 22507 C WGHT = array of length N containing scale factors. 22508 C 1/WGHT(i) are the diagonal elements of the diagonal 22509 C scaling matrix D. 22510 C 22511 C N = the order of the matrix A, and the lengths 22512 C of the vectors Y, SAVF, B, WGHT, and X. 22513 C 22514 C MAXL = the maximum allowable order of the matrix HES. 22515 C 22516 C KMP = the number of previous vectors the new vector VNEW 22517 C must be made orthogonal to. KMP .le. MAXL. 22518 C 22519 C DELTA = tolerance on residuals b - A*x in weighted RMS-norm. 22520 C 22521 C HL0 = current value of (step size h) * (coefficient l0). 22522 C 22523 C JPRE = preconditioner type flag. 22524 C 22525 C MNEWT = Newton iteration counter (.ge. 0). 22526 C 22527 C WK = real work array of length N used by DATV and PSOL. 22528 C 22529 C WP = real work array used by preconditioner PSOL. 22530 C 22531 C IWP = integer work array used by preconditioner PSOL. 22532 C 22533 C On return 22534 C 22535 C X = the final computed approximation to the solution 22536 C of the system A*x = b. 22537 C 22538 C V = the N by (LIOM+1) array containing the LIOM 22539 C orthogonal vectors V(*,1) to V(*,LIOM). 22540 C 22541 C HES = the LU factorization of the LIOM by LIOM upper 22542 C Hessenberg matrix whose entries are the 22543 C scaled inner products of A*V(*,k) and V(*,i). 22544 C 22545 C IPVT = an integer array containg pivoting information. 22546 C It is loaded in DHEFA and used in DHESL. 22547 C 22548 C LIOM = the number of iterations performed, and current 22549 C order of the upper Hessenberg matrix HES. 22550 C 22551 C NPSL = the number of calls to PSOL. 22552 C 22553 C IFLAG = integer error flag: 22554 C 0 means convergence in LIOM iterations, LIOM.le.MAXL. 22555 C 1 means the convergence test did not pass in MAXL 22556 C iterations, but the residual norm is .lt. 1, 22557 C or .lt. norm(b) if MNEWT = 0, and so X is computed. 22558 C 2 means the convergence test did not pass in MAXL 22559 C iterations, residual .gt. 1, and X is undefined. 22560 C 3 means there was a recoverable error in PSOL 22561 C caused by the preconditioner being out of date. 22562 C -1 means there was a nonrecoverable error in PSOL. 22563 C 22564 C----------------------------------------------------------------------- 22565 INTEGER I, IER, INFO, J, K, LL, LM1 22566 DOUBLE PRECISION BNRM, BNRM0, PROD, RHO, SNORMW, DNRM2, TEM 22567 C 22568 IFLAG = 0 22569 LIOM = 0 22570 NPSL = 0 22571 C----------------------------------------------------------------------- 22572 C The initial residual is the vector b. Apply scaling to b, and test 22573 C for an immediate return with X = 0 or X = b. 22574 C----------------------------------------------------------------------- 22575 DO 10 I = 1,N 22576 10 V(I,1) = B(I)*WGHT(I) 22577 BNRM0 = DNRM2 (N, V, 1) 22578 BNRM = BNRM0 22579 IF (BNRM0 .GT. DELTA) GO TO 30 22580 IF (MNEWT .GT. 0) GO TO 20 22581 CALL DCOPY (N, B, 1, X, 1) 22582 RETURN 22583 20 DO 25 I = 1,N 22584 25 X(I) = 0.0D0 22585 RETURN 22586 30 CONTINUE 22587 C Apply inverse of left preconditioner to vector b. -------------------- 22588 IER = 0 22589 IF (JPRE .EQ. 0 .OR. JPRE .EQ. 2) GO TO 55 22590 CALL PSOL (NEQ, TN, Y, SAVF, WK, HL0, WP, IWP, B, 1, IER) 22591 NPSL = 1 22592 IF (IER .NE. 0) GO TO 300 22593 C Calculate norm of scaled vector V(*,1) and normalize it. ------------- 22594 DO 50 I = 1,N 22595 50 V(I,1) = B(I)*WGHT(I) 22596 BNRM = DNRM2(N, V, 1) 22597 DELTA = DELTA*(BNRM/BNRM0) 22598 55 TEM = 1.0D0/BNRM 22599 CALL DSCAL (N, TEM, V(1,1), 1) 22600 C Zero out the HES array. ---------------------------------------------- 22601 DO 65 J = 1,MAXL 22602 DO 60 I = 1,MAXL 22603 60 HES(I,J) = 0.0D0 22604 65 CONTINUE 22605 C----------------------------------------------------------------------- 22606 C Main loop on LL = l to compute the vectors V(*,2) to V(*,MAXL). 22607 C The running product PROD is needed for the convergence test. 22608 C----------------------------------------------------------------------- 22609 PROD = 1.0D0 22610 DO 90 LL = 1,MAXL 22611 LIOM = LL 22612 C----------------------------------------------------------------------- 22613 C Call routine DATV to compute VNEW = Abar*v(l), where Abar is 22614 C the matrix A with scaling and inverse preconditioner factors applied. 22615 C Call routine DORTHOG to orthogonalize the new vector vnew = V(*,l+1). 22616 C Call routine DHEFA to update the factors of HES. 22617 C----------------------------------------------------------------------- 22618 CALL DATV (NEQ, Y, SAVF, V(1,LL), WGHT, X, F, PSOL, V(1,LL+1), 22619 1 WK, WP, IWP, HL0, JPRE, IER, NPSL) 22620 IF (IER .NE. 0) GO TO 300 22621 CALL DORTHOG (V(1,LL+1), V, HES, N, LL, MAXL, KMP, SNORMW) 22622 CALL DHEFA (HES, MAXL, LL, IPVT, INFO, LL) 22623 LM1 = LL - 1 22624 IF (LL .GT. 1 .AND. IPVT(LM1) .EQ. LM1) PROD = PROD*HES(LL,LM1) 22625 IF (INFO .NE. LL) GO TO 70 22626 C----------------------------------------------------------------------- 22627 C The last pivot in HES was found to be zero. 22628 C If vnew = 0 or l = MAXL, take an error return with IFLAG = 2. 22629 C otherwise, continue the iteration without a convergence test. 22630 C----------------------------------------------------------------------- 22631 IF (SNORMW .EQ. 0.0D0) GO TO 120 22632 IF (LL .EQ. MAXL) GO TO 120 22633 GO TO 80 22634 C----------------------------------------------------------------------- 22635 C Update RHO, the estimate of the norm of the residual b - A*x(l). 22636 C test for convergence. If passed, compute approximation x(l). 22637 C If failed and l .lt. MAXL, then continue iterating. 22638 C----------------------------------------------------------------------- 22639 70 CONTINUE 22640 RHO = BNRM*SNORMW*ABS(PROD/HES(LL,LL)) 22641 IF (RHO .LE. DELTA) GO TO 200 22642 IF (LL .EQ. MAXL) GO TO 100 22643 C If l .lt. MAXL, store HES(l+1,l) and normalize the vector v(*,l+1). 22644 80 CONTINUE 22645 HES(LL+1,LL) = SNORMW 22646 TEM = 1.0D0/SNORMW 22647 CALL DSCAL (N, TEM, V(1,LL+1), 1) 22648 90 CONTINUE 22649 C----------------------------------------------------------------------- 22650 C l has reached MAXL without passing the convergence test: 22651 C If RHO is not too large, compute a solution anyway and return with 22652 C IFLAG = 1. Otherwise return with IFLAG = 2. 22653 C----------------------------------------------------------------------- 22654 100 CONTINUE 22655 IF (RHO .LE. 1.0D0) GO TO 150 22656 IF (RHO .LE. BNRM .AND. MNEWT .EQ. 0) GO TO 150 22657 120 CONTINUE 22658 IFLAG = 2 22659 RETURN 22660 150 IFLAG = 1 22661 C----------------------------------------------------------------------- 22662 C Compute the approximation x(l) to the solution. 22663 C Since the vector X was used as work space, and the initial guess 22664 C of the Newton correction is zero, X must be reset to zero. 22665 C----------------------------------------------------------------------- 22666 200 CONTINUE 22667 LL = LIOM 22668 DO 210 K = 1,LL 22669 210 B(K) = 0.0D0 22670 B(1) = BNRM 22671 CALL DHESL (HES, MAXL, LL, IPVT, B) 22672 DO 220 K = 1,N 22673 220 X(K) = 0.0D0 22674 DO 230 I = 1,LL 22675 CALL DAXPY (N, B(I), V(1,I), 1, X, 1) 22676 230 CONTINUE 22677 DO 240 I = 1,N 22678 240 X(I) = X(I)/WGHT(I) 22679 IF (JPRE .LE. 1) RETURN 22680 CALL PSOL (NEQ, TN, Y, SAVF, WK, HL0, WP, IWP, X, 2, IER) 22681 NPSL = NPSL + 1 22682 IF (IER .NE. 0) GO TO 300 22683 RETURN 22684 C----------------------------------------------------------------------- 22685 C This block handles error returns forced by routine PSOL. 22686 C----------------------------------------------------------------------- 22687 300 CONTINUE 22688 IF (IER .LT. 0) IFLAG = -1 22689 IF (IER .GT. 0) IFLAG = 3 22690 RETURN 22691 C----------------------- End of Subroutine DSPIOM ---------------------- 22692 END 22693 *DECK DATV 22694 SUBROUTINE DATV (NEQ, Y, SAVF, V, WGHT, FTEM, F, PSOL, Z, VTEM, 22695 1 WP, IWP, HL0, JPRE, IER, NPSL) 22696 EXTERNAL F, PSOL 22697 INTEGER NEQ, IWP, JPRE, IER, NPSL 22698 DOUBLE PRECISION Y, SAVF, V, WGHT, FTEM, Z, VTEM, WP, HL0 22699 DIMENSION NEQ(*), Y(*), SAVF(*), V(*), WGHT(*), FTEM(*), Z(*), 22700 1 VTEM(*), WP(*), IWP(*) 22701 INTEGER IOWND, IOWNS, 22702 1 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 22703 2 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 22704 3 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU 22705 DOUBLE PRECISION ROWNS, 22706 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND 22707 COMMON /DLS001/ ROWNS(209), 22708 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND, 22709 2 IOWND(6), IOWNS(6), 22710 3 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 22711 4 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 22712 5 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU 22713 C----------------------------------------------------------------------- 22714 C This routine computes the product 22715 C 22716 C (D-inverse)*(P1-inverse)*(I - hl0*df/dy)*(P2-inverse)*(D*v), 22717 C 22718 C where D is a diagonal scaling matrix, and P1 and P2 are the 22719 C left and right preconditioning matrices, respectively. 22720 C v is assumed to have WRMS norm equal to 1. 22721 C The product is stored in z. This is computed by a 22722 C difference quotient, a call to F, and two calls to PSOL. 22723 C----------------------------------------------------------------------- 22724 C 22725 C On entry 22726 C 22727 C NEQ = problem size, passed to F and PSOL (NEQ(1) = N). 22728 C 22729 C Y = array containing current dependent variable vector. 22730 C 22731 C SAVF = array containing current value of f(t,y). 22732 C 22733 C V = real array of length N (can be the same array as Z). 22734 C 22735 C WGHT = array of length N containing scale factors. 22736 C 1/WGHT(i) are the diagonal elements of the matrix D. 22737 C 22738 C FTEM = work array of length N. 22739 C 22740 C VTEM = work array of length N used to store the 22741 C unscaled version of V. 22742 C 22743 C WP = real work array used by preconditioner PSOL. 22744 C 22745 C IWP = integer work array used by preconditioner PSOL. 22746 C 22747 C HL0 = current value of (step size h) * (coefficient l0). 22748 C 22749 C JPRE = preconditioner type flag. 22750 C 22751 C 22752 C On return 22753 C 22754 C Z = array of length N containing desired scaled 22755 C matrix-vector product. 22756 C 22757 C IER = error flag from PSOL. 22758 C 22759 C NPSL = the number of calls to PSOL. 22760 C 22761 C In addition, this routine uses the Common variables TN, N, NFE. 22762 C----------------------------------------------------------------------- 22763 INTEGER I 22764 DOUBLE PRECISION FAC, RNORM, DNRM2, TEMPN 22765 C 22766 C Set VTEM = D * V. 22767 DO 10 I = 1,N 22768 10 VTEM(I) = V(I)/WGHT(I) 22769 IER = 0 22770 IF (JPRE .GE. 2) GO TO 30 22771 C 22772 C JPRE = 0 or 1. Save Y in Z and increment Y by VTEM. 22773 CALL DCOPY (N, Y, 1, Z, 1) 22774 DO 20 I = 1,N 22775 20 Y(I) = Z(I) + VTEM(I) 22776 FAC = HL0 22777 GO TO 60 22778 C 22779 C JPRE = 2 or 3. Apply inverse of right preconditioner to VTEM. 22780 30 CONTINUE 22781 CALL PSOL (NEQ, TN, Y, SAVF, FTEM, HL0, WP, IWP, VTEM, 2, IER) 22782 NPSL = NPSL + 1 22783 IF (IER .NE. 0) RETURN 22784 C Calculate L-2 norm of (D-inverse) * VTEM. 22785 DO 40 I = 1,N 22786 40 Z(I) = VTEM(I)*WGHT(I) 22787 TEMPN = DNRM2 (N, Z, 1) 22788 RNORM = 1.0D0/TEMPN 22789 C Save Y in Z and increment Y by VTEM/norm. 22790 CALL DCOPY (N, Y, 1, Z, 1) 22791 DO 50 I = 1,N 22792 50 Y(I) = Z(I) + VTEM(I)*RNORM 22793 FAC = HL0*TEMPN 22794 C 22795 C For all JPRE, call F with incremented Y argument, and restore Y. 22796 60 CONTINUE 22797 CALL F (NEQ, TN, Y, FTEM) 22798 NFE = NFE + 1 22799 CALL DCOPY (N, Z, 1, Y, 1) 22800 C Set Z = (identity - hl0*Jacobian) * VTEM, using difference quotient. 22801 DO 70 I = 1,N 22802 70 Z(I) = FTEM(I) - SAVF(I) 22803 DO 80 I = 1,N 22804 80 Z(I) = VTEM(I) - FAC*Z(I) 22805 C Apply inverse of left preconditioner to Z, if nontrivial. 22806 IF (JPRE .EQ. 0 .OR. JPRE .EQ. 2) GO TO 85 22807 CALL PSOL (NEQ, TN, Y, SAVF, FTEM, HL0, WP, IWP, Z, 1, IER) 22808 NPSL = NPSL + 1 22809 IF (IER .NE. 0) RETURN 22810 85 CONTINUE 22811 C Apply D-inverse to Z and return. 22812 DO 90 I = 1,N 22813 90 Z(I) = Z(I)*WGHT(I) 22814 RETURN 22815 C----------------------- End of Subroutine DATV ------------------------ 22816 END 22817 *DECK DORTHOG 22818 SUBROUTINE DORTHOG (VNEW, V, HES, N, LL, LDHES, KMP, SNORMW) 22819 INTEGER N, LL, LDHES, KMP 22820 DOUBLE PRECISION VNEW, V, HES, SNORMW 22821 DIMENSION VNEW(*), V(N,*), HES(LDHES,*) 22822 C----------------------------------------------------------------------- 22823 C This routine orthogonalizes the vector VNEW against the previous 22824 C KMP vectors in the V array. It uses a modified Gram-Schmidt 22825 C orthogonalization procedure with conditional reorthogonalization. 22826 C This is the version of 28 may 1986. 22827 C----------------------------------------------------------------------- 22828 C 22829 C On entry 22830 C 22831 C VNEW = the vector of length N containing a scaled product 22832 C of the Jacobian and the vector V(*,LL). 22833 C 22834 C V = the N x l array containing the previous LL 22835 C orthogonal vectors v(*,1) to v(*,LL). 22836 C 22837 C HES = an LL x LL upper Hessenberg matrix containing, 22838 C in HES(i,k), k.lt.LL, scaled inner products of 22839 C A*V(*,k) and V(*,i). 22840 C 22841 C LDHES = the leading dimension of the HES array. 22842 C 22843 C N = the order of the matrix A, and the length of VNEW. 22844 C 22845 C LL = the current order of the matrix HES. 22846 C 22847 C KMP = the number of previous vectors the new vector VNEW 22848 C must be made orthogonal to (KMP .le. MAXL). 22849 C 22850 C 22851 C On return 22852 C 22853 C VNEW = the new vector orthogonal to V(*,i0) to V(*,LL), 22854 C where i0 = MAX(1, LL-KMP+1). 22855 C 22856 C HES = upper Hessenberg matrix with column LL filled in with 22857 C scaled inner products of A*V(*,LL) and V(*,i). 22858 C 22859 C SNORMW = L-2 norm of VNEW. 22860 C 22861 C----------------------------------------------------------------------- 22862 INTEGER I, I0 22863 DOUBLE PRECISION ARG, DDOT, DNRM2, SUMDSQ, TEM, VNRM 22864 C 22865 C Get norm of unaltered VNEW for later use. ---------------------------- 22866 VNRM = DNRM2 (N, VNEW, 1) 22867 C----------------------------------------------------------------------- 22868 C Do modified Gram-Schmidt on VNEW = A*v(LL). 22869 C Scaled inner products give new column of HES. 22870 C Projections of earlier vectors are subtracted from VNEW. 22871 C----------------------------------------------------------------------- 22872 I0 = MAX(1,LL-KMP+1) 22873 DO 10 I = I0,LL 22874 HES(I,LL) = DDOT (N, V(1,I), 1, VNEW, 1) 22875 TEM = -HES(I,LL) 22876 CALL DAXPY (N, TEM, V(1,I), 1, VNEW, 1) 22877 10 CONTINUE 22878 C----------------------------------------------------------------------- 22879 C Compute SNORMW = norm of VNEW. 22880 C If VNEW is small compared to its input value (in norm), then 22881 C reorthogonalize VNEW to V(*,1) through V(*,LL). 22882 C Correct if relative correction exceeds 1000*(unit roundoff). 22883 C finally, correct SNORMW using the dot products involved. 22884 C----------------------------------------------------------------------- 22885 SNORMW = DNRM2 (N, VNEW, 1) 22886 IF (VNRM + 0.001D0*SNORMW .NE. VNRM) RETURN 22887 SUMDSQ = 0.0D0 22888 DO 30 I = I0,LL 22889 TEM = -DDOT (N, V(1,I), 1, VNEW, 1) 22890 IF (HES(I,LL) + 0.001D0*TEM .EQ. HES(I,LL)) GO TO 30 22891 HES(I,LL) = HES(I,LL) - TEM 22892 CALL DAXPY (N, TEM, V(1,I), 1, VNEW, 1) 22893 SUMDSQ = SUMDSQ + TEM**2 22894 30 CONTINUE 22895 IF (SUMDSQ .EQ. 0.0D0) RETURN 22896 ARG = MAX(0.0D0,SNORMW**2 - SUMDSQ) 22897 SNORMW = SQRT(ARG) 22898 C 22899 RETURN 22900 C----------------------- End of Subroutine DORTHOG --------------------- 22901 END 22902 *DECK DSPIGMR 22903 SUBROUTINE DSPIGMR (NEQ, TN, Y, SAVF, B, WGHT, N, MAXL, MAXLP1, 22904 1 KMP, DELTA, HL0, JPRE, MNEWT, F, PSOL, NPSL, X, V, HES, Q, 22905 2 LGMR, WP, IWP, WK, DL, IFLAG) 22906 EXTERNAL F, PSOL 22907 INTEGER NEQ,N,MAXL,MAXLP1,KMP,JPRE,MNEWT,NPSL,LGMR,IWP,IFLAG 22908 DOUBLE PRECISION TN,Y,SAVF,B,WGHT,DELTA,HL0,X,V,HES,Q,WP,WK,DL 22909 DIMENSION NEQ(*), Y(*), SAVF(*), B(*), WGHT(*), X(*), V(N,*), 22910 1 HES(MAXLP1,*), Q(*), WP(*), IWP(*), WK(*), DL(*) 22911 C----------------------------------------------------------------------- 22912 C This routine solves the linear system A * x = b using a scaled 22913 C preconditioned version of the Generalized Minimal Residual method. 22914 C An initial guess of x = 0 is assumed. 22915 C----------------------------------------------------------------------- 22916 C 22917 C On entry 22918 C 22919 C NEQ = problem size, passed to F and PSOL (NEQ(1) = N). 22920 C 22921 C TN = current value of t. 22922 C 22923 C Y = array containing current dependent variable vector. 22924 C 22925 C SAVF = array containing current value of f(t,y). 22926 C 22927 C B = the right hand side of the system A*x = b. 22928 C B is also used as work space when computing 22929 C the final approximation. 22930 C (B is the same as V(*,MAXL+1) in the call to DSPIGMR.) 22931 C 22932 C WGHT = the vector of length N containing the nonzero 22933 C elements of the diagonal scaling matrix. 22934 C 22935 C N = the order of the matrix A, and the lengths 22936 C of the vectors WGHT, B and X. 22937 C 22938 C MAXL = the maximum allowable order of the matrix HES. 22939 C 22940 C MAXLP1 = MAXL + 1, used for dynamic dimensioning of HES. 22941 C 22942 C KMP = the number of previous vectors the new vector VNEW 22943 C must be made orthogonal to. KMP .le. MAXL. 22944 C 22945 C DELTA = tolerance on residuals b - A*x in weighted RMS-norm. 22946 C 22947 C HL0 = current value of (step size h) * (coefficient l0). 22948 C 22949 C JPRE = preconditioner type flag. 22950 C 22951 C MNEWT = Newton iteration counter (.ge. 0). 22952 C 22953 C WK = real work array used by routine DATV and PSOL. 22954 C 22955 C DL = real work array used for calculation of the residual 22956 C norm RHO when the method is incomplete (KMP .lt. MAXL). 22957 C Not needed or referenced in complete case (KMP = MAXL). 22958 C 22959 C WP = real work array used by preconditioner PSOL. 22960 C 22961 C IWP = integer work array used by preconditioner PSOL. 22962 C 22963 C On return 22964 C 22965 C X = the final computed approximation to the solution 22966 C of the system A*x = b. 22967 C 22968 C LGMR = the number of iterations performed and 22969 C the current order of the upper Hessenberg 22970 C matrix HES. 22971 C 22972 C NPSL = the number of calls to PSOL. 22973 C 22974 C V = the N by (LGMR+1) array containing the LGMR 22975 C orthogonal vectors V(*,1) to V(*,LGMR). 22976 C 22977 C HES = the upper triangular factor of the QR decomposition 22978 C of the (LGMR+1) by lgmr upper Hessenberg matrix whose 22979 C entries are the scaled inner-products of A*V(*,i) 22980 C and V(*,k). 22981 C 22982 C Q = real array of length 2*MAXL containing the components 22983 C of the Givens rotations used in the QR decomposition 22984 C of HES. It is loaded in DHEQR and used in DHELS. 22985 C 22986 C IFLAG = integer error flag: 22987 C 0 means convergence in LGMR iterations, LGMR .le. MAXL. 22988 C 1 means the convergence test did not pass in MAXL 22989 C iterations, but the residual norm is .lt. 1, 22990 C or .lt. norm(b) if MNEWT = 0, and so x is computed. 22991 C 2 means the convergence test did not pass in MAXL 22992 C iterations, residual .gt. 1, and X is undefined. 22993 C 3 means there was a recoverable error in PSOL 22994 C caused by the preconditioner being out of date. 22995 C -1 means there was a nonrecoverable error in PSOL. 22996 C 22997 C----------------------------------------------------------------------- 22998 INTEGER I, IER, INFO, IP1, I2, J, K, LL, LLP1 22999 DOUBLE PRECISION BNRM,BNRM0,C,DLNRM,PROD,RHO,S,SNORMW,DNRM2,TEM 23000 C 23001 IFLAG = 0 23002 LGMR = 0 23003 NPSL = 0 23004 C----------------------------------------------------------------------- 23005 C The initial residual is the vector b. Apply scaling to b, and test 23006 C for an immediate return with X = 0 or X = b. 23007 C----------------------------------------------------------------------- 23008 DO 10 I = 1,N 23009 10 V(I,1) = B(I)*WGHT(I) 23010 BNRM0 = DNRM2 (N, V, 1) 23011 BNRM = BNRM0 23012 IF (BNRM0 .GT. DELTA) GO TO 30 23013 IF (MNEWT .GT. 0) GO TO 20 23014 CALL DCOPY (N, B, 1, X, 1) 23015 RETURN 23016 20 DO 25 I = 1,N 23017 25 X(I) = 0.0D0 23018 RETURN 23019 30 CONTINUE 23020 C Apply inverse of left preconditioner to vector b. -------------------- 23021 IER = 0 23022 IF (JPRE .EQ. 0 .OR. JPRE .EQ. 2) GO TO 55 23023 CALL PSOL (NEQ, TN, Y, SAVF, WK, HL0, WP, IWP, B, 1, IER) 23024 NPSL = 1 23025 IF (IER .NE. 0) GO TO 300 23026 C Calculate norm of scaled vector V(*,1) and normalize it. ------------- 23027 DO 50 I = 1,N 23028 50 V(I,1) = B(I)*WGHT(I) 23029 BNRM = DNRM2 (N, V, 1) 23030 DELTA = DELTA*(BNRM/BNRM0) 23031 55 TEM = 1.0D0/BNRM 23032 CALL DSCAL (N, TEM, V(1,1), 1) 23033 C Zero out the HES array. ---------------------------------------------- 23034 DO 65 J = 1,MAXL 23035 DO 60 I = 1,MAXLP1 23036 60 HES(I,J) = 0.0D0 23037 65 CONTINUE 23038 C----------------------------------------------------------------------- 23039 C Main loop to compute the vectors V(*,2) to V(*,MAXL). 23040 C The running product PROD is needed for the convergence test. 23041 C----------------------------------------------------------------------- 23042 PROD = 1.0D0 23043 DO 90 LL = 1,MAXL 23044 LGMR = LL 23045 C----------------------------------------------------------------------- 23046 C Call routine DATV to compute VNEW = Abar*v(ll), where Abar is 23047 C the matrix A with scaling and inverse preconditioner factors applied. 23048 C Call routine DORTHOG to orthogonalize the new vector VNEW = V(*,LL+1). 23049 C Call routine DHEQR to update the factors of HES. 23050 C----------------------------------------------------------------------- 23051 CALL DATV (NEQ, Y, SAVF, V(1,LL), WGHT, X, F, PSOL, V(1,LL+1), 23052 1 WK, WP, IWP, HL0, JPRE, IER, NPSL) 23053 IF (IER .NE. 0) GO TO 300 23054 CALL DORTHOG (V(1,LL+1), V, HES, N, LL, MAXLP1, KMP, SNORMW) 23055 HES(LL+1,LL) = SNORMW 23056 CALL DHEQR (HES, MAXLP1, LL, Q, INFO, LL) 23057 IF (INFO .EQ. LL) GO TO 120 23058 C----------------------------------------------------------------------- 23059 C Update RHO, the estimate of the norm of the residual b - A*xl. 23060 C If KMP .lt. MAXL, then the vectors V(*,1),...,V(*,LL+1) are not 23061 C necessarily orthogonal for LL .gt. KMP. The vector DL must then 23062 C be computed, and its norm used in the calculation of RHO. 23063 C----------------------------------------------------------------------- 23064 PROD = PROD*Q(2*LL) 23065 RHO = ABS(PROD*BNRM) 23066 IF ((LL.GT.KMP) .AND. (KMP.LT.MAXL)) THEN 23067 IF (LL .EQ. KMP+1) THEN 23068 CALL DCOPY (N, V(1,1), 1, DL, 1) 23069 DO 75 I = 1,KMP 23070 IP1 = I + 1 23071 I2 = I*2 23072 S = Q(I2) 23073 C = Q(I2-1) 23074 DO 70 K = 1,N 23075 70 DL(K) = S*DL(K) + C*V(K,IP1) 23076 75 CONTINUE 23077 ENDIF 23078 S = Q(2*LL) 23079 C = Q(2*LL-1)/SNORMW 23080 LLP1 = LL + 1 23081 DO 80 K = 1,N 23082 80 DL(K) = S*DL(K) + C*V(K,LLP1) 23083 DLNRM = DNRM2 (N, DL, 1) 23084 RHO = RHO*DLNRM 23085 ENDIF 23086 C----------------------------------------------------------------------- 23087 C Test for convergence. If passed, compute approximation xl. 23088 C if failed and LL .lt. MAXL, then continue iterating. 23089 C----------------------------------------------------------------------- 23090 IF (RHO .LE. DELTA) GO TO 200 23091 IF (LL .EQ. MAXL) GO TO 100 23092 C----------------------------------------------------------------------- 23093 C Rescale so that the norm of V(1,LL+1) is one. 23094 C----------------------------------------------------------------------- 23095 TEM = 1.0D0/SNORMW 23096 CALL DSCAL (N, TEM, V(1,LL+1), 1) 23097 90 CONTINUE 23098 100 CONTINUE 23099 IF (RHO .LE. 1.0D0) GO TO 150 23100 IF (RHO .LE. BNRM .AND. MNEWT .EQ. 0) GO TO 150 23101 120 CONTINUE 23102 IFLAG = 2 23103 RETURN 23104 150 IFLAG = 1 23105 C----------------------------------------------------------------------- 23106 C Compute the approximation xl to the solution. 23107 C Since the vector X was used as work space, and the initial guess 23108 C of the Newton correction is zero, X must be reset to zero. 23109 C----------------------------------------------------------------------- 23110 200 CONTINUE 23111 LL = LGMR 23112 LLP1 = LL + 1 23113 DO 210 K = 1,LLP1 23114 210 B(K) = 0.0D0 23115 B(1) = BNRM 23116 CALL DHELS (HES, MAXLP1, LL, Q, B) 23117 DO 220 K = 1,N 23118 220 X(K) = 0.0D0 23119 DO 230 I = 1,LL 23120 CALL DAXPY (N, B(I), V(1,I), 1, X, 1) 23121 230 CONTINUE 23122 DO 240 I = 1,N 23123 240 X(I) = X(I)/WGHT(I) 23124 IF (JPRE .LE. 1) RETURN 23125 CALL PSOL (NEQ, TN, Y, SAVF, WK, HL0, WP, IWP, X, 2, IER) 23126 NPSL = NPSL + 1 23127 IF (IER .NE. 0) GO TO 300 23128 RETURN 23129 C----------------------------------------------------------------------- 23130 C This block handles error returns forced by routine PSOL. 23131 C----------------------------------------------------------------------- 23132 300 CONTINUE 23133 IF (IER .LT. 0) IFLAG = -1 23134 IF (IER .GT. 0) IFLAG = 3 23135 C 23136 RETURN 23137 C----------------------- End of Subroutine DSPIGMR --------------------- 23138 END 23139 *DECK DPCG 23140 SUBROUTINE DPCG (NEQ, TN, Y, SAVF, R, WGHT, N, MAXL, DELTA, HL0, 23141 1 JPRE, MNEWT, F, PSOL, NPSL, X, P, W, Z, LPCG, WP, IWP, WK, IFLAG) 23142 EXTERNAL F, PSOL 23143 INTEGER NEQ, N, MAXL, JPRE, MNEWT, NPSL, LPCG, IWP, IFLAG 23144 DOUBLE PRECISION TN,Y,SAVF,R,WGHT,DELTA,HL0,X,P,W,Z,WP,WK 23145 DIMENSION NEQ(*), Y(*), SAVF(*), R(*), WGHT(*), X(*), P(*), W(*), 23146 1 Z(*), WP(*), IWP(*), WK(*) 23147 C----------------------------------------------------------------------- 23148 C This routine computes the solution to the system A*x = b using a 23149 C preconditioned version of the Conjugate Gradient algorithm. 23150 C It is assumed here that the matrix A and the preconditioner 23151 C matrix M are symmetric positive definite or nearly so. 23152 C----------------------------------------------------------------------- 23153 C 23154 C On entry 23155 C 23156 C NEQ = problem size, passed to F and PSOL (NEQ(1) = N). 23157 C 23158 C TN = current value of t. 23159 C 23160 C Y = array containing current dependent variable vector. 23161 C 23162 C SAVF = array containing current value of f(t,y). 23163 C 23164 C R = the right hand side of the system A*x = b. 23165 C 23166 C WGHT = array of length N containing scale factors. 23167 C 1/WGHT(i) are the diagonal elements of the diagonal 23168 C scaling matrix D. 23169 C 23170 C N = the order of the matrix A, and the lengths 23171 C of the vectors Y, SAVF, R, WGHT, P, W, Z, WK, and X. 23172 C 23173 C MAXL = the maximum allowable number of iterates. 23174 C 23175 C DELTA = tolerance on residuals b - A*x in weighted RMS-norm. 23176 C 23177 C HL0 = current value of (step size h) * (coefficient l0). 23178 C 23179 C JPRE = preconditioner type flag. 23180 C 23181 C MNEWT = Newton iteration counter (.ge. 0). 23182 C 23183 C WK = real work array used by routine DATP. 23184 C 23185 C WP = real work array used by preconditioner PSOL. 23186 C 23187 C IWP = integer work array used by preconditioner PSOL. 23188 C 23189 C On return 23190 C 23191 C X = the final computed approximation to the solution 23192 C of the system A*x = b. 23193 C 23194 C LPCG = the number of iterations performed, and current 23195 C order of the upper Hessenberg matrix HES. 23196 C 23197 C NPSL = the number of calls to PSOL. 23198 C 23199 C IFLAG = integer error flag: 23200 C 0 means convergence in LPCG iterations, LPCG .le. MAXL. 23201 C 1 means the convergence test did not pass in MAXL 23202 C iterations, but the residual norm is .lt. 1, 23203 C or .lt. norm(b) if MNEWT = 0, and so X is computed. 23204 C 2 means the convergence test did not pass in MAXL 23205 C iterations, residual .gt. 1, and X is undefined. 23206 C 3 means there was a recoverable error in PSOL 23207 C caused by the preconditioner being out of date. 23208 C 4 means there was a zero denominator in the algorithm. 23209 C The system matrix or preconditioner matrix is not 23210 C sufficiently close to being symmetric pos. definite. 23211 C -1 means there was a nonrecoverable error in PSOL. 23212 C 23213 C----------------------------------------------------------------------- 23214 INTEGER I, IER 23215 DOUBLE PRECISION ALPHA,BETA,BNRM,PTW,RNRM,DDOT,DVNORM,ZTR,ZTR0 23216 C 23217 IFLAG = 0 23218 NPSL = 0 23219 LPCG = 0 23220 DO 10 I = 1,N 23221 10 X(I) = 0.0D0 23222 BNRM = DVNORM (N, R, WGHT) 23223 C Test for immediate return with X = 0 or X = b. ----------------------- 23224 IF (BNRM .GT. DELTA) GO TO 20 23225 IF (MNEWT .GT. 0) RETURN 23226 CALL DCOPY (N, R, 1, X, 1) 23227 RETURN 23228 C 23229 20 ZTR = 0.0D0 23230 C Loop point for PCG iterations. --------------------------------------- 23231 30 CONTINUE 23232 LPCG = LPCG + 1 23233 CALL DCOPY (N, R, 1, Z, 1) 23234 IER = 0 23235 IF (JPRE .EQ. 0) GO TO 40 23236 CALL PSOL (NEQ, TN, Y, SAVF, WK, HL0, WP, IWP, Z, 3, IER) 23237 NPSL = NPSL + 1 23238 IF (IER .NE. 0) GO TO 100 23239 40 CONTINUE 23240 ZTR0 = ZTR 23241 ZTR = DDOT (N, Z, 1, R, 1) 23242 IF (LPCG .NE. 1) GO TO 50 23243 CALL DCOPY (N, Z, 1, P, 1) 23244 GO TO 70 23245 50 CONTINUE 23246 IF (ZTR0 .EQ. 0.0D0) GO TO 200 23247 BETA = ZTR/ZTR0 23248 DO 60 I = 1,N 23249 60 P(I) = Z(I) + BETA*P(I) 23250 70 CONTINUE 23251 C----------------------------------------------------------------------- 23252 C Call DATP to compute A*p and return the answer in W. 23253 C----------------------------------------------------------------------- 23254 CALL DATP (NEQ, Y, SAVF, P, WGHT, HL0, WK, F, W) 23255 C 23256 PTW = DDOT (N, P, 1, W, 1) 23257 IF (PTW .EQ. 0.0D0) GO TO 200 23258 ALPHA = ZTR/PTW 23259 CALL DAXPY (N, ALPHA, P, 1, X, 1) 23260 ALPHA = -ALPHA 23261 CALL DAXPY (N, ALPHA, W, 1, R, 1) 23262 RNRM = DVNORM (N, R, WGHT) 23263 IF (RNRM .LE. DELTA) RETURN 23264 IF (LPCG .LT. MAXL) GO TO 30 23265 IFLAG = 2 23266 IF (RNRM .LE. 1.0D0) IFLAG = 1 23267 IF (RNRM .LE. BNRM .AND. MNEWT .EQ. 0) IFLAG = 1 23268 RETURN 23269 C----------------------------------------------------------------------- 23270 C This block handles error returns from PSOL. 23271 C----------------------------------------------------------------------- 23272 100 CONTINUE 23273 IF (IER .LT. 0) IFLAG = -1 23274 IF (IER .GT. 0) IFLAG = 3 23275 RETURN 23276 C----------------------------------------------------------------------- 23277 C This block handles division by zero errors. 23278 C----------------------------------------------------------------------- 23279 200 CONTINUE 23280 IFLAG = 4 23281 RETURN 23282 C----------------------- End of Subroutine DPCG ------------------------ 23283 END 23284 *DECK DPCGS 23285 SUBROUTINE DPCGS (NEQ, TN, Y, SAVF, R, WGHT, N, MAXL, DELTA, HL0, 23286 1 JPRE, MNEWT, F, PSOL, NPSL, X, P, W, Z, LPCG, WP, IWP, WK, IFLAG) 23287 EXTERNAL F, PSOL 23288 INTEGER NEQ, N, MAXL, JPRE, MNEWT, NPSL, LPCG, IWP, IFLAG 23289 DOUBLE PRECISION TN,Y,SAVF,R,WGHT,DELTA,HL0,X,P,W,Z,WP,WK 23290 DIMENSION NEQ(*), Y(*), SAVF(*), R(*), WGHT(*), X(*), P(*), W(*), 23291 1 Z(*), WP(*), IWP(*), WK(*) 23292 C----------------------------------------------------------------------- 23293 C This routine computes the solution to the system A*x = b using a 23294 C scaled preconditioned version of the Conjugate Gradient algorithm. 23295 C It is assumed here that the scaled matrix D**-1 * A * D and the 23296 C scaled preconditioner D**-1 * M * D are close to being 23297 C symmetric positive definite. 23298 C----------------------------------------------------------------------- 23299 C 23300 C On entry 23301 C 23302 C NEQ = problem size, passed to F and PSOL (NEQ(1) = N). 23303 C 23304 C TN = current value of t. 23305 C 23306 C Y = array containing current dependent variable vector. 23307 C 23308 C SAVF = array containing current value of f(t,y). 23309 C 23310 C R = the right hand side of the system A*x = b. 23311 C 23312 C WGHT = array of length N containing scale factors. 23313 C 1/WGHT(i) are the diagonal elements of the diagonal 23314 C scaling matrix D. 23315 C 23316 C N = the order of the matrix A, and the lengths 23317 C of the vectors Y, SAVF, R, WGHT, P, W, Z, WK, and X. 23318 C 23319 C MAXL = the maximum allowable number of iterates. 23320 C 23321 C DELTA = tolerance on residuals b - A*x in weighted RMS-norm. 23322 C 23323 C HL0 = current value of (step size h) * (coefficient l0). 23324 C 23325 C JPRE = preconditioner type flag. 23326 C 23327 C MNEWT = Newton iteration counter (.ge. 0). 23328 C 23329 C WK = real work array used by routine DATP. 23330 C 23331 C WP = real work array used by preconditioner PSOL. 23332 C 23333 C IWP = integer work array used by preconditioner PSOL. 23334 C 23335 C On return 23336 C 23337 C X = the final computed approximation to the solution 23338 C of the system A*x = b. 23339 C 23340 C LPCG = the number of iterations performed, and current 23341 C order of the upper Hessenberg matrix HES. 23342 C 23343 C NPSL = the number of calls to PSOL. 23344 C 23345 C IFLAG = integer error flag: 23346 C 0 means convergence in LPCG iterations, LPCG .le. MAXL. 23347 C 1 means the convergence test did not pass in MAXL 23348 C iterations, but the residual norm is .lt. 1, 23349 C or .lt. norm(b) if MNEWT = 0, and so X is computed. 23350 C 2 means the convergence test did not pass in MAXL 23351 C iterations, residual .gt. 1, and X is undefined. 23352 C 3 means there was a recoverable error in PSOL 23353 C caused by the preconditioner being out of date. 23354 C 4 means there was a zero denominator in the algorithm. 23355 C the scaled matrix or scaled preconditioner is not 23356 C sufficiently close to being symmetric pos. definite. 23357 C -1 means there was a nonrecoverable error in PSOL. 23358 C 23359 C----------------------------------------------------------------------- 23360 INTEGER I, IER 23361 DOUBLE PRECISION ALPHA, BETA, BNRM, PTW, RNRM, DVNORM, ZTR, ZTR0 23362 C 23363 IFLAG = 0 23364 NPSL = 0 23365 LPCG = 0 23366 DO 10 I = 1,N 23367 10 X(I) = 0.0D0 23368 BNRM = DVNORM (N, R, WGHT) 23369 C Test for immediate return with X = 0 or X = b. ----------------------- 23370 IF (BNRM .GT. DELTA) GO TO 20 23371 IF (MNEWT .GT. 0) RETURN 23372 CALL DCOPY (N, R, 1, X, 1) 23373 RETURN 23374 C 23375 20 ZTR = 0.0D0 23376 C Loop point for PCG iterations. --------------------------------------- 23377 30 CONTINUE 23378 LPCG = LPCG + 1 23379 CALL DCOPY (N, R, 1, Z, 1) 23380 IER = 0 23381 IF (JPRE .EQ. 0) GO TO 40 23382 CALL PSOL (NEQ, TN, Y, SAVF, WK, HL0, WP, IWP, Z, 3, IER) 23383 NPSL = NPSL + 1 23384 IF (IER .NE. 0) GO TO 100 23385 40 CONTINUE 23386 ZTR0 = ZTR 23387 ZTR = 0.0D0 23388 DO 45 I = 1,N 23389 45 ZTR = ZTR + Z(I)*R(I)*WGHT(I)**2 23390 IF (LPCG .NE. 1) GO TO 50 23391 CALL DCOPY (N, Z, 1, P, 1) 23392 GO TO 70 23393 50 CONTINUE 23394 IF (ZTR0 .EQ. 0.0D0) GO TO 200 23395 BETA = ZTR/ZTR0 23396 DO 60 I = 1,N 23397 60 P(I) = Z(I) + BETA*P(I) 23398 70 CONTINUE 23399 C----------------------------------------------------------------------- 23400 C Call DATP to compute A*p and return the answer in W. 23401 C----------------------------------------------------------------------- 23402 CALL DATP (NEQ, Y, SAVF, P, WGHT, HL0, WK, F, W) 23403 C 23404 PTW = 0.0D0 23405 DO 80 I = 1,N 23406 80 PTW = PTW + P(I)*W(I)*WGHT(I)**2 23407 IF (PTW .EQ. 0.0D0) GO TO 200 23408 ALPHA = ZTR/PTW 23409 CALL DAXPY (N, ALPHA, P, 1, X, 1) 23410 ALPHA = -ALPHA 23411 CALL DAXPY (N, ALPHA, W, 1, R, 1) 23412 RNRM = DVNORM (N, R, WGHT) 23413 IF (RNRM .LE. DELTA) RETURN 23414 IF (LPCG .LT. MAXL) GO TO 30 23415 IFLAG = 2 23416 IF (RNRM .LE. 1.0D0) IFLAG = 1 23417 IF (RNRM .LE. BNRM .AND. MNEWT .EQ. 0) IFLAG = 1 23418 RETURN 23419 C----------------------------------------------------------------------- 23420 C This block handles error returns from PSOL. 23421 C----------------------------------------------------------------------- 23422 100 CONTINUE 23423 IF (IER .LT. 0) IFLAG = -1 23424 IF (IER .GT. 0) IFLAG = 3 23425 RETURN 23426 C----------------------------------------------------------------------- 23427 C This block handles division by zero errors. 23428 C----------------------------------------------------------------------- 23429 200 CONTINUE 23430 IFLAG = 4 23431 RETURN 23432 C----------------------- End of Subroutine DPCGS ----------------------- 23433 END 23434 *DECK DATP 23435 SUBROUTINE DATP (NEQ, Y, SAVF, P, WGHT, HL0, WK, F, W) 23436 EXTERNAL F 23437 INTEGER NEQ 23438 DOUBLE PRECISION Y, SAVF, P, WGHT, HL0, WK, W 23439 DIMENSION NEQ(*), Y(*), SAVF(*), P(*), WGHT(*), WK(*), W(*) 23440 INTEGER IOWND, IOWNS, 23441 1 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 23442 2 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 23443 3 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU 23444 DOUBLE PRECISION ROWNS, 23445 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND 23446 COMMON /DLS001/ ROWNS(209), 23447 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND, 23448 2 IOWND(6), IOWNS(6), 23449 3 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 23450 4 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 23451 5 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU 23452 C----------------------------------------------------------------------- 23453 C This routine computes the product 23454 C 23455 C w = (I - hl0*df/dy)*p 23456 C 23457 C This is computed by a call to F and a difference quotient. 23458 C----------------------------------------------------------------------- 23459 C 23460 C On entry 23461 C 23462 C NEQ = problem size, passed to F and PSOL (NEQ(1) = N). 23463 C 23464 C Y = array containing current dependent variable vector. 23465 C 23466 C SAVF = array containing current value of f(t,y). 23467 C 23468 C P = real array of length N. 23469 C 23470 C WGHT = array of length N containing scale factors. 23471 C 1/WGHT(i) are the diagonal elements of the matrix D. 23472 C 23473 C WK = work array of length N. 23474 C 23475 C On return 23476 C 23477 C 23478 C W = array of length N containing desired 23479 C matrix-vector product. 23480 C 23481 C In addition, this routine uses the Common variables TN, N, NFE. 23482 C----------------------------------------------------------------------- 23483 INTEGER I 23484 DOUBLE PRECISION FAC, PNRM, RPNRM, DVNORM 23485 C 23486 PNRM = DVNORM (N, P, WGHT) 23487 RPNRM = 1.0D0/PNRM 23488 CALL DCOPY (N, Y, 1, W, 1) 23489 DO 20 I = 1,N 23490 20 Y(I) = W(I) + P(I)*RPNRM 23491 CALL F (NEQ, TN, Y, WK) 23492 NFE = NFE + 1 23493 CALL DCOPY (N, W, 1, Y, 1) 23494 FAC = HL0*PNRM 23495 DO 40 I = 1,N 23496 40 W(I) = P(I) - FAC*(WK(I) - SAVF(I)) 23497 RETURN 23498 C----------------------- End of Subroutine DATP ------------------------ 23499 END 23500 *DECK DUSOL 23501 SUBROUTINE DUSOL (NEQ, TN, Y, SAVF, B, WGHT, N, DELTA, HL0, MNEWT, 23502 1 PSOL, NPSL, X, WP, IWP, WK, IFLAG) 23503 EXTERNAL PSOL 23504 INTEGER NEQ, N, MNEWT, NPSL, IWP, IFLAG 23505 DOUBLE PRECISION TN, Y, SAVF, B, WGHT, DELTA, HL0, X, WP, WK 23506 DIMENSION NEQ(*), Y(*), SAVF(*), B(*), WGHT(*), X(*), 23507 1 WP(*), IWP(*), WK(*) 23508 C----------------------------------------------------------------------- 23509 C This routine solves the linear system A * x = b using only a call 23510 C to the user-supplied routine PSOL (no Krylov iteration). 23511 C If the norm of the right-hand side vector b is smaller than DELTA, 23512 C the vector X returned is X = b (if MNEWT = 0) or X = 0 otherwise. 23513 C PSOL is called with an LR argument of 0. 23514 C----------------------------------------------------------------------- 23515 C 23516 C On entry 23517 C 23518 C NEQ = problem size, passed to F and PSOL (NEQ(1) = N). 23519 C 23520 C TN = current value of t. 23521 C 23522 C Y = array containing current dependent variable vector. 23523 C 23524 C SAVF = array containing current value of f(t,y). 23525 C 23526 C B = the right hand side of the system A*x = b. 23527 C 23528 C WGHT = the vector of length N containing the nonzero 23529 C elements of the diagonal scaling matrix. 23530 C 23531 C N = the order of the matrix A, and the lengths 23532 C of the vectors WGHT, B and X. 23533 C 23534 C DELTA = tolerance on residuals b - A*x in weighted RMS-norm. 23535 C 23536 C HL0 = current value of (step size h) * (coefficient l0). 23537 C 23538 C MNEWT = Newton iteration counter (.ge. 0). 23539 C 23540 C WK = real work array used by PSOL. 23541 C 23542 C WP = real work array used by preconditioner PSOL. 23543 C 23544 C IWP = integer work array used by preconditioner PSOL. 23545 C 23546 C On return 23547 C 23548 C X = the final computed approximation to the solution 23549 C of the system A*x = b. 23550 C 23551 C NPSL = the number of calls to PSOL. 23552 C 23553 C IFLAG = integer error flag: 23554 C 0 means no trouble occurred. 23555 C 3 means there was a recoverable error in PSOL 23556 C caused by the preconditioner being out of date. 23557 C -1 means there was a nonrecoverable error in PSOL. 23558 C 23559 C----------------------------------------------------------------------- 23560 INTEGER I, IER 23561 DOUBLE PRECISION BNRM, DVNORM 23562 C 23563 IFLAG = 0 23564 NPSL = 0 23565 C----------------------------------------------------------------------- 23566 C Test for an immediate return with X = 0 or X = b. 23567 C----------------------------------------------------------------------- 23568 BNRM = DVNORM (N, B, WGHT) 23569 IF (BNRM .GT. DELTA) GO TO 30 23570 IF (MNEWT .GT. 0) GO TO 10 23571 CALL DCOPY (N, B, 1, X, 1) 23572 RETURN 23573 10 DO 20 I = 1,N 23574 20 X(I) = 0.0D0 23575 RETURN 23576 C Make call to PSOL and copy result from B to X. ----------------------- 23577 30 IER = 0 23578 CALL PSOL (NEQ, TN, Y, SAVF, WK, HL0, WP, IWP, B, 0, IER) 23579 NPSL = 1 23580 IF (IER .NE. 0) GO TO 100 23581 CALL DCOPY (N, B, 1, X, 1) 23582 RETURN 23583 C----------------------------------------------------------------------- 23584 C This block handles error returns forced by routine PSOL. 23585 C----------------------------------------------------------------------- 23586 100 CONTINUE 23587 IF (IER .LT. 0) IFLAG = -1 23588 IF (IER .GT. 0) IFLAG = 3 23589 RETURN 23590 C----------------------- End of Subroutine DUSOL ----------------------- 23591 END 23592 *DECK DSRCPK 23593 SUBROUTINE DSRCPK (RSAV, ISAV, JOB) 23594 C----------------------------------------------------------------------- 23595 C This routine saves or restores (depending on JOB) the contents of 23596 C the Common blocks DLS001, DLPK01, which are used 23597 C internally by the DLSODPK solver. 23598 C 23599 C RSAV = real array of length 222 or more. 23600 C ISAV = integer array of length 50 or more. 23601 C JOB = flag indicating to save or restore the Common blocks: 23602 C JOB = 1 if Common is to be saved (written to RSAV/ISAV) 23603 C JOB = 2 if Common is to be restored (read from RSAV/ISAV) 23604 C A call with JOB = 2 presumes a prior call with JOB = 1. 23605 C----------------------------------------------------------------------- 23606 INTEGER ISAV, JOB 23607 INTEGER ILS, ILSP 23608 INTEGER I, LENILP, LENRLP, LENILS, LENRLS 23609 DOUBLE PRECISION RSAV, RLS, RLSP 23610 DIMENSION RSAV(*), ISAV(*) 23611 SAVE LENRLS, LENILS, LENRLP, LENILP 23612 COMMON /DLS001/ RLS(218), ILS(37) 23613 COMMON /DLPK01/ RLSP(4), ILSP(13) 23614 DATA LENRLS/218/, LENILS/37/, LENRLP/4/, LENILP/13/ 23615 C 23616 IF (JOB .EQ. 2) GO TO 100 23617 CALL DCOPY (LENRLS, RLS, 1, RSAV, 1) 23618 CALL DCOPY (LENRLP, RLSP, 1, RSAV(LENRLS+1), 1) 23619 DO 20 I = 1,LENILS 23620 20 ISAV(I) = ILS(I) 23621 DO 40 I = 1,LENILP 23622 40 ISAV(LENILS+I) = ILSP(I) 23623 RETURN 23624 C 23625 100 CONTINUE 23626 CALL DCOPY (LENRLS, RSAV, 1, RLS, 1) 23627 CALL DCOPY (LENRLP, RSAV(LENRLS+1), 1, RLSP, 1) 23628 DO 120 I = 1,LENILS 23629 120 ILS(I) = ISAV(I) 23630 DO 140 I = 1,LENILP 23631 140 ILSP(I) = ISAV(LENILS+I) 23632 RETURN 23633 C----------------------- End of Subroutine DSRCPK ---------------------- 23634 END 23635 *DECK DHEFA 23636 SUBROUTINE DHEFA (A, LDA, N, IPVT, INFO, JOB) 23637 INTEGER LDA, N, IPVT(*), INFO, JOB 23638 DOUBLE PRECISION A(LDA,*) 23639 C----------------------------------------------------------------------- 23640 C This routine is a modification of the LINPACK routine DGEFA and 23641 C performs an LU decomposition of an upper Hessenberg matrix A. 23642 C There are two options available: 23643 C 23644 C (1) performing a fresh factorization 23645 C (2) updating the LU factors by adding a row and a 23646 C column to the matrix A. 23647 C----------------------------------------------------------------------- 23648 C DHEFA factors an upper Hessenberg matrix by elimination. 23649 C 23650 C On entry 23651 C 23652 C A DOUBLE PRECISION(LDA, N) 23653 C the matrix to be factored. 23654 C 23655 C LDA INTEGER 23656 C the leading dimension of the array A . 23657 C 23658 C N INTEGER 23659 C the order of the matrix A . 23660 C 23661 C JOB INTEGER 23662 C JOB = 1 means that a fresh factorization of the 23663 C matrix A is desired. 23664 C JOB .ge. 2 means that the current factorization of A 23665 C will be updated by the addition of a row 23666 C and a column. 23667 C 23668 C On return 23669 C 23670 C A an upper triangular matrix and the multipliers 23671 C which were used to obtain it. 23672 C The factorization can be written A = L*U where 23673 C L is a product of permutation and unit lower 23674 C triangular matrices and U is upper triangular. 23675 C 23676 C IPVT INTEGER(N) 23677 C an integer vector of pivot indices. 23678 C 23679 C INFO INTEGER 23680 C = 0 normal value. 23681 C = k if U(k,k) .eq. 0.0 . This is not an error 23682 C condition for this subroutine, but it does 23683 C indicate that DHESL will divide by zero if called. 23684 C 23685 C Modification of LINPACK, by Peter Brown, LLNL. 23686 C Written 7/20/83. This version dated 6/20/01. 23687 C 23688 C BLAS called: DAXPY, IDAMAX 23689 C----------------------------------------------------------------------- 23690 INTEGER IDAMAX, J, K, KM1, KP1, L, NM1 23691 DOUBLE PRECISION T 23692 C 23693 IF (JOB .GT. 1) GO TO 80 23694 C 23695 C A new facorization is desired. This is essentially the LINPACK 23696 C code with the exception that we know there is only one nonzero 23697 C element below the main diagonal. 23698 C 23699 C Gaussian elimination with partial pivoting 23700 C 23701 INFO = 0 23702 NM1 = N - 1 23703 IF (NM1 .LT. 1) GO TO 70 23704 DO 60 K = 1, NM1 23705 KP1 = K + 1 23706 C 23707 C Find L = pivot index 23708 C 23709 L = IDAMAX (2, A(K,K), 1) + K - 1 23710 IPVT(K) = L 23711 C 23712 C Zero pivot implies this column already triangularized 23713 C 23714 IF (A(L,K) .EQ. 0.0D0) GO TO 40 23715 C 23716 C Interchange if necessary 23717 C 23718 IF (L .EQ. K) GO TO 10 23719 T = A(L,K) 23720 A(L,K) = A(K,K) 23721 A(K,K) = T 23722 10 CONTINUE 23723 C 23724 C Compute multipliers 23725 C 23726 T = -1.0D0/A(K,K) 23727 A(K+1,K) = A(K+1,K)*T 23728 C 23729 C Row elimination with column indexing 23730 C 23731 DO 30 J = KP1, N 23732 T = A(L,J) 23733 IF (L .EQ. K) GO TO 20 23734 A(L,J) = A(K,J) 23735 A(K,J) = T 23736 20 CONTINUE 23737 CALL DAXPY (N-K, T, A(K+1,K), 1, A(K+1,J), 1) 23738 30 CONTINUE 23739 GO TO 50 23740 40 CONTINUE 23741 INFO = K 23742 50 CONTINUE 23743 60 CONTINUE 23744 70 CONTINUE 23745 IPVT(N) = N 23746 IF (A(N,N) .EQ. 0.0D0) INFO = N 23747 RETURN 23748 C 23749 C The old factorization of A will be updated. A row and a column 23750 C has been added to the matrix A. 23751 C N-1 is now the old order of the matrix. 23752 C 23753 80 CONTINUE 23754 NM1 = N - 1 23755 C 23756 C Perform row interchanges on the elements of the new column, and 23757 C perform elimination operations on the elements using the multipliers. 23758 C 23759 IF (NM1 .LE. 1) GO TO 105 23760 DO 100 K = 2,NM1 23761 KM1 = K - 1 23762 L = IPVT(KM1) 23763 T = A(L,N) 23764 IF (L .EQ. KM1) GO TO 90 23765 A(L,N) = A(KM1,N) 23766 A(KM1,N) = T 23767 90 CONTINUE 23768 A(K,N) = A(K,N) + A(K,KM1)*T 23769 100 CONTINUE 23770 105 CONTINUE 23771 C 23772 C Complete update of factorization by decomposing last 2x2 block. 23773 C 23774 INFO = 0 23775 C 23776 C Find L = pivot index 23777 C 23778 L = IDAMAX (2, A(NM1,NM1), 1) + NM1 - 1 23779 IPVT(NM1) = L 23780 C 23781 C Zero pivot implies this column already triangularized 23782 C 23783 IF (A(L,NM1) .EQ. 0.0D0) GO TO 140 23784 C 23785 C Interchange if necessary 23786 C 23787 IF (L .EQ. NM1) GO TO 110 23788 T = A(L,NM1) 23789 A(L,NM1) = A(NM1,NM1) 23790 A(NM1,NM1) = T 23791 110 CONTINUE 23792 C 23793 C Compute multipliers 23794 C 23795 T = -1.0D0/A(NM1,NM1) 23796 A(N,NM1) = A(N,NM1)*T 23797 C 23798 C Row elimination with column indexing 23799 C 23800 T = A(L,N) 23801 IF (L .EQ. NM1) GO TO 120 23802 A(L,N) = A(NM1,N) 23803 A(NM1,N) = T 23804 120 CONTINUE 23805 A(N,N) = A(N,N) + T*A(N,NM1) 23806 GO TO 150 23807 140 CONTINUE 23808 INFO = NM1 23809 150 CONTINUE 23810 IPVT(N) = N 23811 IF (A(N,N) .EQ. 0.0D0) INFO = N 23812 RETURN 23813 C----------------------- End of Subroutine DHEFA ----------------------- 23814 END 23815 *DECK DHESL 23816 SUBROUTINE DHESL (A, LDA, N, IPVT, B) 23817 INTEGER LDA, N, IPVT(*) 23818 DOUBLE PRECISION A(LDA,*), B(*) 23819 C----------------------------------------------------------------------- 23820 C This is essentially the LINPACK routine DGESL except for changes 23821 C due to the fact that A is an upper Hessenberg matrix. 23822 C----------------------------------------------------------------------- 23823 C DHESL solves the real system A * x = b 23824 C using the factors computed by DHEFA. 23825 C 23826 C On entry 23827 C 23828 C A DOUBLE PRECISION(LDA, N) 23829 C the output from DHEFA. 23830 C 23831 C LDA INTEGER 23832 C the leading dimension of the array A . 23833 C 23834 C N INTEGER 23835 C the order of the matrix A . 23836 C 23837 C IPVT INTEGER(N) 23838 C the pivot vector from DHEFA. 23839 C 23840 C B DOUBLE PRECISION(N) 23841 C the right hand side vector. 23842 C 23843 C On return 23844 C 23845 C B the solution vector x . 23846 C 23847 C Modification of LINPACK, by Peter Brown, LLNL. 23848 C Written 7/20/83. This version dated 6/20/01. 23849 C 23850 C BLAS called: DAXPY 23851 C----------------------------------------------------------------------- 23852 INTEGER K, KB, L, NM1 23853 DOUBLE PRECISION T 23854 C 23855 NM1 = N - 1 23856 C 23857 C Solve A * x = b 23858 C First solve L*y = b 23859 C 23860 IF (NM1 .LT. 1) GO TO 30 23861 DO 20 K = 1, NM1 23862 L = IPVT(K) 23863 T = B(L) 23864 IF (L .EQ. K) GO TO 10 23865 B(L) = B(K) 23866 B(K) = T 23867 10 CONTINUE 23868 B(K+1) = B(K+1) + T*A(K+1,K) 23869 20 CONTINUE 23870 30 CONTINUE 23871 C 23872 C Now solve U*x = y 23873 C 23874 DO 40 KB = 1, N 23875 K = N + 1 - KB 23876 B(K) = B(K)/A(K,K) 23877 T = -B(K) 23878 CALL DAXPY (K-1, T, A(1,K), 1, B(1), 1) 23879 40 CONTINUE 23880 RETURN 23881 C----------------------- End of Subroutine DHESL ----------------------- 23882 END 23883 *DECK DHEQR 23884 SUBROUTINE DHEQR (A, LDA, N, Q, INFO, IJOB) 23885 INTEGER LDA, N, INFO, IJOB 23886 DOUBLE PRECISION A(LDA,*), Q(*) 23887 C----------------------------------------------------------------------- 23888 C This routine performs a QR decomposition of an upper 23889 C Hessenberg matrix A. There are two options available: 23890 C 23891 C (1) performing a fresh decomposition 23892 C (2) updating the QR factors by adding a row and a 23893 C column to the matrix A. 23894 C----------------------------------------------------------------------- 23895 C DHEQR decomposes an upper Hessenberg matrix by using Givens 23896 C rotations. 23897 C 23898 C On entry 23899 C 23900 C A DOUBLE PRECISION(LDA, N) 23901 C the matrix to be decomposed. 23902 C 23903 C LDA INTEGER 23904 C the leading dimension of the array A . 23905 C 23906 C N INTEGER 23907 C A is an (N+1) by N Hessenberg matrix. 23908 C 23909 C IJOB INTEGER 23910 C = 1 means that a fresh decomposition of the 23911 C matrix A is desired. 23912 C .ge. 2 means that the current decomposition of A 23913 C will be updated by the addition of a row 23914 C and a column. 23915 C On return 23916 C 23917 C A the upper triangular matrix R. 23918 C The factorization can be written Q*A = R, where 23919 C Q is a product of Givens rotations and R is upper 23920 C triangular. 23921 C 23922 C Q DOUBLE PRECISION(2*N) 23923 C the factors c and s of each Givens rotation used 23924 C in decomposing A. 23925 C 23926 C INFO INTEGER 23927 C = 0 normal value. 23928 C = k if A(k,k) .eq. 0.0 . This is not an error 23929 C condition for this subroutine, but it does 23930 C indicate that DHELS will divide by zero 23931 C if called. 23932 C 23933 C Modification of LINPACK, by Peter Brown, LLNL. 23934 C Written 1/13/86. This version dated 6/20/01. 23935 C----------------------------------------------------------------------- 23936 INTEGER I, IQ, J, K, KM1, KP1, NM1 23937 DOUBLE PRECISION C, S, T, T1, T2 23938 C 23939 IF (IJOB .GT. 1) GO TO 70 23940 C 23941 C A new facorization is desired. 23942 C 23943 C QR decomposition without pivoting 23944 C 23945 INFO = 0 23946 DO 60 K = 1, N 23947 KM1 = K - 1 23948 KP1 = K + 1 23949 C 23950 C Compute kth column of R. 23951 C First, multiply the kth column of A by the previous 23952 C k-1 Givens rotations. 23953 C 23954 IF (KM1 .LT. 1) GO TO 20 23955 DO 10 J = 1, KM1 23956 I = 2*(J-1) + 1 23957 T1 = A(J,K) 23958 T2 = A(J+1,K) 23959 C = Q(I) 23960 S = Q(I+1) 23961 A(J,K) = C*T1 - S*T2 23962 A(J+1,K) = S*T1 + C*T2 23963 10 CONTINUE 23964 C 23965 C Compute Givens components c and s 23966 C 23967 20 CONTINUE 23968 IQ = 2*KM1 + 1 23969 T1 = A(K,K) 23970 T2 = A(KP1,K) 23971 IF (T2 .NE. 0.0D0) GO TO 30 23972 C = 1.0D0 23973 S = 0.0D0 23974 GO TO 50 23975 30 CONTINUE 23976 IF (ABS(T2) .LT. ABS(T1)) GO TO 40 23977 T = T1/T2 23978 S = -1.0D0/SQRT(1.0D0+T*T) 23979 C = -S*T 23980 GO TO 50 23981 40 CONTINUE 23982 T = T2/T1 23983 C = 1.0D0/SQRT(1.0D0+T*T) 23984 S = -C*T 23985 50 CONTINUE 23986 Q(IQ) = C 23987 Q(IQ+1) = S 23988 A(K,K) = C*T1 - S*T2 23989 IF (A(K,K) .EQ. 0.0D0) INFO = K 23990 60 CONTINUE 23991 RETURN 23992 C 23993 C The old factorization of A will be updated. A row and a column 23994 C has been added to the matrix A. 23995 C N by N-1 is now the old size of the matrix. 23996 C 23997 70 CONTINUE 23998 NM1 = N - 1 23999 C 24000 C Multiply the new column by the N previous Givens rotations. 24001 C 24002 DO 100 K = 1,NM1 24003 I = 2*(K-1) + 1 24004 T1 = A(K,N) 24005 T2 = A(K+1,N) 24006 C = Q(I) 24007 S = Q(I+1) 24008 A(K,N) = C*T1 - S*T2 24009 A(K+1,N) = S*T1 + C*T2 24010 100 CONTINUE 24011 C 24012 C Complete update of decomposition by forming last Givens rotation, 24013 C and multiplying it times the column vector (A(N,N), A(N+1,N)). 24014 C 24015 INFO = 0 24016 T1 = A(N,N) 24017 T2 = A(N+1,N) 24018 IF (T2 .NE. 0.0D0) GO TO 110 24019 C = 1.0D0 24020 S = 0.0D0 24021 GO TO 130 24022 110 CONTINUE 24023 IF (ABS(T2) .LT. ABS(T1)) GO TO 120 24024 T = T1/T2 24025 S = -1.0D0/SQRT(1.0D0+T*T) 24026 C = -S*T 24027 GO TO 130 24028 120 CONTINUE 24029 T = T2/T1 24030 C = 1.0D0/SQRT(1.0D0+T*T) 24031 S = -C*T 24032 130 CONTINUE 24033 IQ = 2*N - 1 24034 Q(IQ) = C 24035 Q(IQ+1) = S 24036 A(N,N) = C*T1 - S*T2 24037 IF (A(N,N) .EQ. 0.0D0) INFO = N 24038 RETURN 24039 C----------------------- End of Subroutine DHEQR ----------------------- 24040 END 24041 *DECK DHELS 24042 SUBROUTINE DHELS (A, LDA, N, Q, B) 24043 INTEGER LDA, N 24044 DOUBLE PRECISION A(LDA,*), B(*), Q(*) 24045 C----------------------------------------------------------------------- 24046 C This is part of the LINPACK routine DGESL with changes 24047 C due to the fact that A is an upper Hessenberg matrix. 24048 C----------------------------------------------------------------------- 24049 C DHELS solves the least squares problem 24050 C 24051 C min (b-A*x, b-A*x) 24052 C 24053 C using the factors computed by DHEQR. 24054 C 24055 C On entry 24056 C 24057 C A DOUBLE PRECISION(LDA, N) 24058 C the output from DHEQR which contains the upper 24059 C triangular factor R in the QR decomposition of A. 24060 C 24061 C LDA INTEGER 24062 C the leading dimension of the array A . 24063 C 24064 C N INTEGER 24065 C A is originally an (N+1) by N matrix. 24066 C 24067 C Q DOUBLE PRECISION(2*N) 24068 C The coefficients of the N givens rotations 24069 C used in the QR factorization of A. 24070 C 24071 C B DOUBLE PRECISION(N+1) 24072 C the right hand side vector. 24073 C 24074 C On return 24075 C 24076 C B the solution vector x . 24077 C 24078 C Modification of LINPACK, by Peter Brown, LLNL. 24079 C Written 1/13/86. This version dated 6/20/01. 24080 C 24081 C BLAS called: DAXPY 24082 C----------------------------------------------------------------------- 24083 INTEGER IQ, K, KB, KP1 24084 DOUBLE PRECISION C, S, T, T1, T2 24085 C 24086 C Minimize (b-A*x, b-A*x) 24087 C First form Q*b. 24088 C 24089 DO 20 K = 1, N 24090 KP1 = K + 1 24091 IQ = 2*(K-1) + 1 24092 C = Q(IQ) 24093 S = Q(IQ+1) 24094 T1 = B(K) 24095 T2 = B(KP1) 24096 B(K) = C*T1 - S*T2 24097 B(KP1) = S*T1 + C*T2 24098 20 CONTINUE 24099 C 24100 C Now solve R*x = Q*b. 24101 C 24102 DO 40 KB = 1, N 24103 K = N + 1 - KB 24104 B(K) = B(K)/A(K,K) 24105 T = -B(K) 24106 CALL DAXPY (K-1, T, A(1,K), 1, B(1), 1) 24107 40 CONTINUE 24108 RETURN 24109 C----------------------- End of Subroutine DHELS ----------------------- 24110 END 24111 *DECK DLHIN 24112 SUBROUTINE DLHIN (NEQ, N, T0, Y0, YDOT, F, TOUT, UROUND, 24113 1 EWT, ITOL, ATOL, Y, TEMP, H0, NITER, IER) 24114 EXTERNAL F 24115 DOUBLE PRECISION T0, Y0, YDOT, TOUT, UROUND, EWT, ATOL, Y, 24116 1 TEMP, H0 24117 INTEGER NEQ, N, ITOL, NITER, IER 24118 DIMENSION NEQ(*), Y0(*), YDOT(*), EWT(*), ATOL(*), Y(*), TEMP(*) 24119 C----------------------------------------------------------------------- 24120 C Call sequence input -- NEQ, N, T0, Y0, YDOT, F, TOUT, UROUND, 24121 C EWT, ITOL, ATOL, Y, TEMP 24122 C Call sequence output -- H0, NITER, IER 24123 C Common block variables accessed -- None 24124 C 24125 C Subroutines called by DLHIN: F, DCOPY 24126 C Function routines called by DLHIN: DVNORM 24127 C----------------------------------------------------------------------- 24128 C This routine computes the step size, H0, to be attempted on the 24129 C first step, when the user has not supplied a value for this. 24130 C 24131 C First we check that TOUT - T0 differs significantly from zero. Then 24132 C an iteration is done to approximate the initial second derivative 24133 C and this is used to define H from WRMS-norm(H**2 * yddot / 2) = 1. 24134 C A bias factor of 1/2 is applied to the resulting h. 24135 C The sign of H0 is inferred from the initial values of TOUT and T0. 24136 C 24137 C Communication with DLHIN is done with the following variables: 24138 C 24139 C NEQ = NEQ array of solver, passed to F. 24140 C N = size of ODE system, input. 24141 C T0 = initial value of independent variable, input. 24142 C Y0 = vector of initial conditions, input. 24143 C YDOT = vector of initial first derivatives, input. 24144 C F = name of subroutine for right-hand side f(t,y), input. 24145 C TOUT = first output value of independent variable 24146 C UROUND = machine unit roundoff 24147 C EWT, ITOL, ATOL = error weights and tolerance parameters 24148 C as described in the driver routine, input. 24149 C Y, TEMP = work arrays of length N. 24150 C H0 = step size to be attempted, output. 24151 C NITER = number of iterations (and of f evaluations) to compute H0, 24152 C output. 24153 C IER = the error flag, returned with the value 24154 C IER = 0 if no trouble occurred, or 24155 C IER = -1 if TOUT and t0 are considered too close to proceed. 24156 C----------------------------------------------------------------------- 24157 C 24158 C Type declarations for local variables -------------------------------- 24159 C 24160 DOUBLE PRECISION AFI, ATOLI, DELYI, HALF, HG, HLB, HNEW, HRAT, 24161 1 HUB, HUN, PT1, T1, TDIST, TROUND, TWO, DVNORM, YDDNRM 24162 INTEGER I, ITER 24163 C----------------------------------------------------------------------- 24164 C The following Fortran-77 declaration is to cause the values of the 24165 C listed (local) variables to be saved between calls to this integrator. 24166 C----------------------------------------------------------------------- 24167 SAVE HALF, HUN, PT1, TWO 24168 DATA HALF /0.5D0/, HUN /100.0D0/, PT1 /0.1D0/, TWO /2.0D0/ 24169 C 24170 NITER = 0 24171 TDIST = ABS(TOUT - T0) 24172 TROUND = UROUND*MAX(ABS(T0),ABS(TOUT)) 24173 IF (TDIST .LT. TWO*TROUND) GO TO 100 24174 C 24175 C Set a lower bound on H based on the roundoff level in T0 and TOUT. --- 24176 HLB = HUN*TROUND 24177 C Set an upper bound on H based on TOUT-T0 and the initial Y and YDOT. - 24178 HUB = PT1*TDIST 24179 ATOLI = ATOL(1) 24180 DO 10 I = 1,N 24181 IF (ITOL .EQ. 2 .OR. ITOL .EQ. 4) ATOLI = ATOL(I) 24182 DELYI = PT1*ABS(Y0(I)) + ATOLI 24183 AFI = ABS(YDOT(I)) 24184 IF (AFI*HUB .GT. DELYI) HUB = DELYI/AFI 24185 10 CONTINUE 24186 C 24187 C Set initial guess for H as geometric mean of upper and lower bounds. - 24188 ITER = 0 24189 HG = SQRT(HLB*HUB) 24190 C If the bounds have crossed, exit with the mean value. ---------------- 24191 IF (HUB .LT. HLB) THEN 24192 H0 = HG 24193 GO TO 90 24194 ENDIF 24195 C 24196 C Looping point for iteration. ----------------------------------------- 24197 50 CONTINUE 24198 C Estimate the second derivative as a difference quotient in f. -------- 24199 T1 = T0 + HG 24200 DO 60 I = 1,N 24201 60 Y(I) = Y0(I) + HG*YDOT(I) 24202 CALL F (NEQ, T1, Y, TEMP) 24203 DO 70 I = 1,N 24204 70 TEMP(I) = (TEMP(I) - YDOT(I))/HG 24205 YDDNRM = DVNORM (N, TEMP, EWT) 24206 C Get the corresponding new value of H. -------------------------------- 24207 IF (YDDNRM*HUB*HUB .GT. TWO) THEN 24208 HNEW = SQRT(TWO/YDDNRM) 24209 ELSE 24210 HNEW = SQRT(HG*HUB) 24211 ENDIF 24212 ITER = ITER + 1 24213 C----------------------------------------------------------------------- 24214 C Test the stopping conditions. 24215 C Stop if the new and previous H values differ by a factor of .lt. 2. 24216 C Stop if four iterations have been done. Also, stop with previous H 24217 C if hnew/hg .gt. 2 after first iteration, as this probably means that 24218 C the second derivative value is bad because of cancellation error. 24219 C----------------------------------------------------------------------- 24220 IF (ITER .GE. 4) GO TO 80 24221 HRAT = HNEW/HG 24222 IF ( (HRAT .GT. HALF) .AND. (HRAT .LT. TWO) ) GO TO 80 24223 IF ( (ITER .GE. 2) .AND. (HNEW .GT. TWO*HG) ) THEN 24224 HNEW = HG 24225 GO TO 80 24226 ENDIF 24227 HG = HNEW 24228 GO TO 50 24229 C 24230 C Iteration done. Apply bounds, bias factor, and sign. ---------------- 24231 80 H0 = HNEW*HALF 24232 IF (H0 .LT. HLB) H0 = HLB 24233 IF (H0 .GT. HUB) H0 = HUB 24234 90 H0 = SIGN(H0, TOUT - T0) 24235 C Restore Y array from Y0, then exit. ---------------------------------- 24236 CALL DCOPY (N, Y0, 1, Y, 1) 24237 NITER = ITER 24238 IER = 0 24239 RETURN 24240 C Error return for TOUT - T0 too small. -------------------------------- 24241 100 IER = -1 24242 RETURN 24243 C----------------------- End of Subroutine DLHIN ----------------------- 24244 END 24245 *DECK DSTOKA 24246 SUBROUTINE DSTOKA (NEQ, Y, YH, NYH, YH1, EWT, SAVF, SAVX, ACOR, 24247 1 WM, IWM, F, JAC, PSOL) 24248 EXTERNAL F, JAC, PSOL 24249 INTEGER NEQ, NYH, IWM 24250 DOUBLE PRECISION Y, YH, YH1, EWT, SAVF, SAVX, ACOR, WM 24251 DIMENSION NEQ(*), Y(*), YH(NYH,*), YH1(*), EWT(*), SAVF(*), 24252 1 SAVX(*), ACOR(*), WM(*), IWM(*) 24253 INTEGER IOWND, IALTH, IPUP, LMAX, MEO, NQNYH, NSLP, 24254 1 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 24255 2 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 24256 3 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU 24257 INTEGER NEWT, NSFI, NSLJ, NJEV 24258 INTEGER JPRE, JACFLG, LOCWP, LOCIWP, LSAVX, KMP, MAXL, MNEWT, 24259 1 NNI, NLI, NPS, NCFN, NCFL 24260 DOUBLE PRECISION CONIT, CRATE, EL, ELCO, HOLD, RMAX, TESCO, 24261 2 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND 24262 DOUBLE PRECISION STIFR 24263 DOUBLE PRECISION DELT, EPCON, SQRTN, RSQRTN 24264 COMMON /DLS001/ CONIT, CRATE, EL(13), ELCO(13,12), 24265 1 HOLD, RMAX, TESCO(3,12), 24266 2 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND, 24267 3 IOWND(6), IALTH, IPUP, LMAX, MEO, NQNYH, NSLP, 24268 3 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 24269 4 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 24270 5 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU 24271 COMMON /DLS002/ STIFR, NEWT, NSFI, NSLJ, NJEV 24272 COMMON /DLPK01/ DELT, EPCON, SQRTN, RSQRTN, 24273 1 JPRE, JACFLG, LOCWP, LOCIWP, LSAVX, KMP, MAXL, MNEWT, 24274 2 NNI, NLI, NPS, NCFN, NCFL 24275 C----------------------------------------------------------------------- 24276 C DSTOKA performs one step of the integration of an initial value 24277 C problem for a system of Ordinary Differential Equations. 24278 C 24279 C This routine was derived from Subroutine DSTODPK in the DLSODPK 24280 C package by the addition of automatic functional/Newton iteration 24281 C switching and logic for re-use of Jacobian data. 24282 C----------------------------------------------------------------------- 24283 C Note: DSTOKA is independent of the value of the iteration method 24284 C indicator MITER, when this is .ne. 0, and hence is independent 24285 C of the type of chord method used, or the Jacobian structure. 24286 C Communication with DSTOKA is done with the following variables: 24287 C 24288 C NEQ = integer array containing problem size in NEQ(1), and 24289 C passed as the NEQ argument in all calls to F and JAC. 24290 C Y = an array of length .ge. N used as the Y argument in 24291 C all calls to F and JAC. 24292 C YH = an NYH by LMAX array containing the dependent variables 24293 C and their approximate scaled derivatives, where 24294 C LMAX = MAXORD + 1. YH(i,j+1) contains the approximate 24295 C j-th derivative of y(i), scaled by H**j/factorial(j) 24296 C (j = 0,1,...,NQ). On entry for the first step, the first 24297 C two columns of YH must be set from the initial values. 24298 C NYH = a constant integer .ge. N, the first dimension of YH. 24299 C YH1 = a one-dimensional array occupying the same space as YH. 24300 C EWT = an array of length N containing multiplicative weights 24301 C for local error measurements. Local errors in y(i) are 24302 C compared to 1.0/EWT(i) in various error tests. 24303 C SAVF = an array of working storage, of length N. 24304 C Also used for input of YH(*,MAXORD+2) when JSTART = -1 24305 C and MAXORD .lt. the current order NQ. 24306 C SAVX = an array of working storage, of length N. 24307 C ACOR = a work array of length N, used for the accumulated 24308 C corrections. On a successful return, ACOR(i) contains 24309 C the estimated one-step local error in y(i). 24310 C WM,IWM = real and integer work arrays associated with matrix 24311 C operations in chord iteration (MITER .ne. 0). 24312 C CCMAX = maximum relative change in H*EL0 before DSETPK is called. 24313 C H = the step size to be attempted on the next step. 24314 C H is altered by the error control algorithm during the 24315 C problem. H can be either positive or negative, but its 24316 C sign must remain constant throughout the problem. 24317 C HMIN = the minimum absolute value of the step size H to be used. 24318 C HMXI = inverse of the maximum absolute value of H to be used. 24319 C HMXI = 0.0 is allowed and corresponds to an infinite HMAX. 24320 C HMIN and HMXI may be changed at any time, but will not 24321 C take effect until the next change of H is considered. 24322 C TN = the independent variable. TN is updated on each step taken. 24323 C JSTART = an integer used for input only, with the following 24324 C values and meanings: 24325 C 0 perform the first step. 24326 C .gt.0 take a new step continuing from the last. 24327 C -1 take the next step with a new value of H, MAXORD, 24328 C N, METH, MITER, and/or matrix parameters. 24329 C -2 take the next step with a new value of H, 24330 C but with other inputs unchanged. 24331 C On return, JSTART is set to 1 to facilitate continuation. 24332 C KFLAG = a completion code with the following meanings: 24333 C 0 the step was succesful. 24334 C -1 the requested error could not be achieved. 24335 C -2 corrector convergence could not be achieved. 24336 C -3 fatal error in DSETPK or DSOLPK. 24337 C A return with KFLAG = -1 or -2 means either 24338 C ABS(H) = HMIN or 10 consecutive failures occurred. 24339 C On a return with KFLAG negative, the values of TN and 24340 C the YH array are as of the beginning of the last 24341 C step, and H is the last step size attempted. 24342 C MAXORD = the maximum order of integration method to be allowed. 24343 C MAXCOR = the maximum number of corrector iterations allowed. 24344 C MSBP = maximum number of steps between DSETPK calls (MITER .gt. 0). 24345 C MXNCF = maximum number of convergence failures allowed. 24346 C METH/MITER = the method flags. See description in driver. 24347 C N = the number of first-order differential equations. 24348 C----------------------------------------------------------------------- 24349 INTEGER I, I1, IREDO, IRET, J, JB, JOK, M, NCF, NEWQ, NSLOW 24350 DOUBLE PRECISION DCON, DDN, DEL, DELP, DRC, DSM, DUP, EXDN, EXSM, 24351 1 EXUP, DFNORM, R, RH, RHDN, RHSM, RHUP, ROC, STIFF, TOLD, DVNORM 24352 C 24353 KFLAG = 0 24354 TOLD = TN 24355 NCF = 0 24356 IERPJ = 0 24357 IERSL = 0 24358 JCUR = 0 24359 ICF = 0 24360 DELP = 0.0D0 24361 IF (JSTART .GT. 0) GO TO 200 24362 IF (JSTART .EQ. -1) GO TO 100 24363 IF (JSTART .EQ. -2) GO TO 160 24364 C----------------------------------------------------------------------- 24365 C On the first call, the order is set to 1, and other variables are 24366 C initialized. RMAX is the maximum ratio by which H can be increased 24367 C in a single step. It is initially 1.E4 to compensate for the small 24368 C initial H, but then is normally equal to 10. If a failure 24369 C occurs (in corrector convergence or error test), RMAX is set at 2 24370 C for the next increase. 24371 C----------------------------------------------------------------------- 24372 LMAX = MAXORD + 1 24373 NQ = 1 24374 L = 2 24375 IALTH = 2 24376 RMAX = 10000.0D0 24377 RC = 0.0D0 24378 EL0 = 1.0D0 24379 CRATE = 0.7D0 24380 HOLD = H 24381 MEO = METH 24382 NSLP = 0 24383 NSLJ = 0 24384 IPUP = 0 24385 IRET = 3 24386 NEWT = 0 24387 STIFR = 0.0D0 24388 GO TO 140 24389 C----------------------------------------------------------------------- 24390 C The following block handles preliminaries needed when JSTART = -1. 24391 C IPUP is set to MITER to force a matrix update. 24392 C If an order increase is about to be considered (IALTH = 1), 24393 C IALTH is reset to 2 to postpone consideration one more step. 24394 C If the caller has changed METH, DCFODE is called to reset 24395 C the coefficients of the method. 24396 C If the caller has changed MAXORD to a value less than the current 24397 C order NQ, NQ is reduced to MAXORD, and a new H chosen accordingly. 24398 C If H is to be changed, YH must be rescaled. 24399 C If H or METH is being changed, IALTH is reset to L = NQ + 1 24400 C to prevent further changes in H for that many steps. 24401 C----------------------------------------------------------------------- 24402 100 IPUP = MITER 24403 LMAX = MAXORD + 1 24404 IF (IALTH .EQ. 1) IALTH = 2 24405 IF (METH .EQ. MEO) GO TO 110 24406 CALL DCFODE (METH, ELCO, TESCO) 24407 MEO = METH 24408 IF (NQ .GT. MAXORD) GO TO 120 24409 IALTH = L 24410 IRET = 1 24411 GO TO 150 24412 110 IF (NQ .LE. MAXORD) GO TO 160 24413 120 NQ = MAXORD 24414 L = LMAX 24415 DO 125 I = 1,L 24416 125 EL(I) = ELCO(I,NQ) 24417 NQNYH = NQ*NYH 24418 RC = RC*EL(1)/EL0 24419 EL0 = EL(1) 24420 CONIT = 0.5D0/(NQ+2) 24421 EPCON = CONIT*TESCO(2,NQ) 24422 DDN = DVNORM (N, SAVF, EWT)/TESCO(1,L) 24423 EXDN = 1.0D0/L 24424 RHDN = 1.0D0/(1.3D0*DDN**EXDN + 0.0000013D0) 24425 RH = MIN(RHDN,1.0D0) 24426 IREDO = 3 24427 IF (H .EQ. HOLD) GO TO 170 24428 RH = MIN(RH,ABS(H/HOLD)) 24429 H = HOLD 24430 GO TO 175 24431 C----------------------------------------------------------------------- 24432 C DCFODE is called to get all the integration coefficients for the 24433 C current METH. Then the EL vector and related constants are reset 24434 C whenever the order NQ is changed, or at the start of the problem. 24435 C----------------------------------------------------------------------- 24436 140 CALL DCFODE (METH, ELCO, TESCO) 24437 150 DO 155 I = 1,L 24438 155 EL(I) = ELCO(I,NQ) 24439 NQNYH = NQ*NYH 24440 RC = RC*EL(1)/EL0 24441 EL0 = EL(1) 24442 CONIT = 0.5D0/(NQ+2) 24443 EPCON = CONIT*TESCO(2,NQ) 24444 GO TO (160, 170, 200), IRET 24445 C----------------------------------------------------------------------- 24446 C If H is being changed, the H ratio RH is checked against 24447 C RMAX, HMIN, and HMXI, and the YH array rescaled. IALTH is set to 24448 C L = NQ + 1 to prevent a change of H for that many steps, unless 24449 C forced by a convergence or error test failure. 24450 C----------------------------------------------------------------------- 24451 160 IF (H .EQ. HOLD) GO TO 200 24452 RH = H/HOLD 24453 H = HOLD 24454 IREDO = 3 24455 GO TO 175 24456 170 RH = MAX(RH,HMIN/ABS(H)) 24457 175 RH = MIN(RH,RMAX) 24458 RH = RH/MAX(1.0D0,ABS(H)*HMXI*RH) 24459 R = 1.0D0 24460 DO 180 J = 2,L 24461 R = R*RH 24462 DO 180 I = 1,N 24463 180 YH(I,J) = YH(I,J)*R 24464 H = H*RH 24465 RC = RC*RH 24466 IALTH = L 24467 IF (IREDO .EQ. 0) GO TO 690 24468 C----------------------------------------------------------------------- 24469 C This section computes the predicted values by effectively 24470 C multiplying the YH array by the Pascal triangle matrix. 24471 C The flag IPUP is set according to whether matrix data is involved 24472 C (NEWT .gt. 0 .and. JACFLG .ne. 0) or not, to trigger a call to DSETPK. 24473 C IPUP is set to MITER when RC differs from 1 by more than CCMAX, 24474 C and at least every MSBP steps, when JACFLG = 1. 24475 C RC is the ratio of new to old values of the coefficient H*EL(1). 24476 C----------------------------------------------------------------------- 24477 200 IF (NEWT .EQ. 0 .OR. JACFLG .EQ. 0) THEN 24478 DRC = 0.0D0 24479 IPUP = 0 24480 CRATE = 0.7D0 24481 ELSE 24482 DRC = ABS(RC - 1.0D0) 24483 IF (DRC .GT. CCMAX) IPUP = MITER 24484 IF (NST .GE. NSLP+MSBP) IPUP = MITER 24485 ENDIF 24486 TN = TN + H 24487 I1 = NQNYH + 1 24488 DO 215 JB = 1,NQ 24489 I1 = I1 - NYH 24490 CDIR$ IVDEP 24491 DO 210 I = I1,NQNYH 24492 210 YH1(I) = YH1(I) + YH1(I+NYH) 24493 215 CONTINUE 24494 C----------------------------------------------------------------------- 24495 C Up to MAXCOR corrector iterations are taken. A convergence test is 24496 C made on the RMS-norm of each correction, weighted by the error 24497 C weight vector EWT. The sum of the corrections is accumulated in the 24498 C vector ACOR(i). The YH array is not altered in the corrector loop. 24499 C Within the corrector loop, an estimated rate of convergence (ROC) 24500 C and a stiffness ratio estimate (STIFF) are kept. Corresponding 24501 C global estimates are kept as CRATE and stifr. 24502 C----------------------------------------------------------------------- 24503 220 M = 0 24504 MNEWT = 0 24505 STIFF = 0.0D0 24506 ROC = 0.05D0 24507 NSLOW = 0 24508 DO 230 I = 1,N 24509 230 Y(I) = YH(I,1) 24510 CALL F (NEQ, TN, Y, SAVF) 24511 NFE = NFE + 1 24512 IF (NEWT .EQ. 0 .OR. IPUP .LE. 0) GO TO 250 24513 C----------------------------------------------------------------------- 24514 C If indicated, DSETPK is called to update any matrix data needed, 24515 C before starting the corrector iteration. 24516 C JOK is set to indicate if the matrix data need not be recomputed. 24517 C IPUP is set to 0 as an indicator that the matrix data is up to date. 24518 C----------------------------------------------------------------------- 24519 JOK = 1 24520 IF (NST .EQ. 0 .OR. NST .GT. NSLJ+50) JOK = -1 24521 IF (ICF .EQ. 1 .AND. DRC .LT. 0.2D0) JOK = -1 24522 IF (ICF .EQ. 2) JOK = -1 24523 IF (JOK .EQ. -1) THEN 24524 NSLJ = NST 24525 NJEV = NJEV + 1 24526 ENDIF 24527 CALL DSETPK (NEQ, Y, YH1, EWT, ACOR, SAVF, JOK, WM, IWM, F, JAC) 24528 IPUP = 0 24529 RC = 1.0D0 24530 DRC = 0.0D0 24531 NSLP = NST 24532 CRATE = 0.7D0 24533 IF (IERPJ .NE. 0) GO TO 430 24534 250 DO 260 I = 1,N 24535 260 ACOR(I) = 0.0D0 24536 270 IF (NEWT .NE. 0) GO TO 350 24537 C----------------------------------------------------------------------- 24538 C In the case of functional iteration, update Y directly from 24539 C the result of the last function evaluation, and STIFF is set to 1.0. 24540 C----------------------------------------------------------------------- 24541 DO 290 I = 1,N 24542 SAVF(I) = H*SAVF(I) - YH(I,2) 24543 290 Y(I) = SAVF(I) - ACOR(I) 24544 DEL = DVNORM (N, Y, EWT) 24545 DO 300 I = 1,N 24546 Y(I) = YH(I,1) + EL(1)*SAVF(I) 24547 300 ACOR(I) = SAVF(I) 24548 STIFF = 1.0D0 24549 GO TO 400 24550 C----------------------------------------------------------------------- 24551 C In the case of the chord method, compute the corrector error, 24552 C and solve the linear system with that as right-hand side and 24553 C P as coefficient matrix. STIFF is set to the ratio of the norms 24554 C of the residual and the correction vector. 24555 C----------------------------------------------------------------------- 24556 350 DO 360 I = 1,N 24557 360 SAVX(I) = H*SAVF(I) - (YH(I,2) + ACOR(I)) 24558 DFNORM = DVNORM (N, SAVX, EWT) 24559 CALL DSOLPK (NEQ, Y, SAVF, SAVX, EWT, WM, IWM, F, PSOL) 24560 IF (IERSL .LT. 0) GO TO 430 24561 IF (IERSL .GT. 0) GO TO 410 24562 DEL = DVNORM (N, SAVX, EWT) 24563 IF (DEL .GT. 1.0D-8) STIFF = MAX(STIFF, DFNORM/DEL) 24564 DO 380 I = 1,N 24565 ACOR(I) = ACOR(I) + SAVX(I) 24566 380 Y(I) = YH(I,1) + EL(1)*ACOR(I) 24567 C----------------------------------------------------------------------- 24568 C Test for convergence. If M .gt. 0, an estimate of the convergence 24569 C rate constant is made for the iteration switch, and is also used 24570 C in the convergence test. If the iteration seems to be diverging or 24571 C converging at a slow rate (.gt. 0.8 more than once), it is stopped. 24572 C----------------------------------------------------------------------- 24573 400 IF (M .NE. 0) THEN 24574 ROC = MAX(0.05D0, DEL/DELP) 24575 CRATE = MAX(0.2D0*CRATE,ROC) 24576 ENDIF 24577 DCON = DEL*MIN(1.0D0,1.5D0*CRATE)/EPCON 24578 IF (DCON .LE. 1.0D0) GO TO 450 24579 M = M + 1 24580 IF (M .EQ. MAXCOR) GO TO 410 24581 IF (M .GE. 2 .AND. DEL .GT. 2.0D0*DELP) GO TO 410 24582 IF (ROC .GT. 10.0D0) GO TO 410 24583 IF (ROC .GT. 0.8D0) NSLOW = NSLOW + 1 24584 IF (NSLOW .GE. 2) GO TO 410 24585 MNEWT = M 24586 DELP = DEL 24587 CALL F (NEQ, TN, Y, SAVF) 24588 NFE = NFE + 1 24589 GO TO 270 24590 C----------------------------------------------------------------------- 24591 C The corrector iteration failed to converge. 24592 C If functional iteration is being done (NEWT = 0) and MITER .gt. 0 24593 C (and this is not the first step), then switch to Newton 24594 C (NEWT = MITER), and retry the step. (Setting STIFR = 1023 insures 24595 C that a switch back will not occur for 10 step attempts.) 24596 C If Newton iteration is being done, but using a preconditioner that 24597 C is out of date (JACFLG .ne. 0 .and. JCUR = 0), then signal for a 24598 C re-evalutation of the preconditioner, and retry the step. 24599 C In all other cases, the YH array is retracted to its values 24600 C before prediction, and H is reduced, if possible. If H cannot be 24601 C reduced or MXNCF failures have occurred, exit with KFLAG = -2. 24602 C----------------------------------------------------------------------- 24603 410 ICF = 1 24604 IF (NEWT .EQ. 0) THEN 24605 IF (NST .EQ. 0) GO TO 430 24606 IF (MITER .EQ. 0) GO TO 430 24607 NEWT = MITER 24608 STIFR = 1023.0D0 24609 IPUP = MITER 24610 GO TO 220 24611 ENDIF 24612 IF (JCUR.EQ.1 .OR. JACFLG.EQ.0) GO TO 430 24613 IPUP = MITER 24614 GO TO 220 24615 430 ICF = 2 24616 NCF = NCF + 1 24617 NCFN = NCFN + 1 24618 RMAX = 2.0D0 24619 TN = TOLD 24620 I1 = NQNYH + 1 24621 DO 445 JB = 1,NQ 24622 I1 = I1 - NYH 24623 CDIR$ IVDEP 24624 DO 440 I = I1,NQNYH 24625 440 YH1(I) = YH1(I) - YH1(I+NYH) 24626 445 CONTINUE 24627 IF (IERPJ .LT. 0 .OR. IERSL .LT. 0) GO TO 680 24628 IF (ABS(H) .LE. HMIN*1.00001D0) GO TO 670 24629 IF (NCF .EQ. MXNCF) GO TO 670 24630 RH = 0.5D0 24631 IPUP = MITER 24632 IREDO = 1 24633 GO TO 170 24634 C----------------------------------------------------------------------- 24635 C The corrector has converged. JCUR is set to 0 to signal that the 24636 C preconditioner involved may need updating later. 24637 C The stiffness ratio STIFR is updated using the latest STIFF value. 24638 C The local error test is made and control passes to statement 500 24639 C if it fails. 24640 C----------------------------------------------------------------------- 24641 450 JCUR = 0 24642 IF (NEWT .GT. 0) STIFR = 0.5D0*(STIFR + STIFF) 24643 IF (M .EQ. 0) DSM = DEL/TESCO(2,NQ) 24644 IF (M .GT. 0) DSM = DVNORM (N, ACOR, EWT)/TESCO(2,NQ) 24645 IF (DSM .GT. 1.0D0) GO TO 500 24646 C----------------------------------------------------------------------- 24647 C After a successful step, update the YH array. 24648 C If Newton iteration is being done and STIFR is less than 1.5, 24649 C then switch to functional iteration. 24650 C Consider changing H if IALTH = 1. Otherwise decrease IALTH by 1. 24651 C If IALTH is then 1 and NQ .lt. MAXORD, then ACOR is saved for 24652 C use in a possible order increase on the next step. 24653 C If a change in H is considered, an increase or decrease in order 24654 C by one is considered also. A change in H is made only if it is by a 24655 C factor of at least 1.1. If not, IALTH is set to 3 to prevent 24656 C testing for that many steps. 24657 C----------------------------------------------------------------------- 24658 KFLAG = 0 24659 IREDO = 0 24660 NST = NST + 1 24661 IF (NEWT .EQ. 0) NSFI = NSFI + 1 24662 IF (NEWT .GT. 0 .AND. STIFR .LT. 1.5D0) NEWT = 0 24663 HU = H 24664 NQU = NQ 24665 DO 470 J = 1,L 24666 DO 470 I = 1,N 24667 470 YH(I,J) = YH(I,J) + EL(J)*ACOR(I) 24668 IALTH = IALTH - 1 24669 IF (IALTH .EQ. 0) GO TO 520 24670 IF (IALTH .GT. 1) GO TO 700 24671 IF (L .EQ. LMAX) GO TO 700 24672 DO 490 I = 1,N 24673 490 YH(I,LMAX) = ACOR(I) 24674 GO TO 700 24675 C----------------------------------------------------------------------- 24676 C The error test failed. KFLAG keeps track of multiple failures. 24677 C Restore TN and the YH array to their previous values, and prepare 24678 C to try the step again. Compute the optimum step size for this or 24679 C one lower order. After 2 or more failures, H is forced to decrease 24680 C by a factor of 0.2 or less. 24681 C----------------------------------------------------------------------- 24682 500 KFLAG = KFLAG - 1 24683 TN = TOLD 24684 I1 = NQNYH + 1 24685 DO 515 JB = 1,NQ 24686 I1 = I1 - NYH 24687 CDIR$ IVDEP 24688 DO 510 I = I1,NQNYH 24689 510 YH1(I) = YH1(I) - YH1(I+NYH) 24690 515 CONTINUE 24691 RMAX = 2.0D0 24692 IF (ABS(H) .LE. HMIN*1.00001D0) GO TO 660 24693 IF (KFLAG .LE. -3) GO TO 640 24694 IREDO = 2 24695 RHUP = 0.0D0 24696 GO TO 540 24697 C----------------------------------------------------------------------- 24698 C Regardless of the success or failure of the step, factors 24699 C RHDN, RHSM, and RHUP are computed, by which H could be multiplied 24700 C at order NQ - 1, order NQ, or order NQ + 1, respectively. 24701 C in the case of failure, RHUP = 0.0 to avoid an order increase. 24702 C the largest of these is determined and the new order chosen 24703 C accordingly. If the order is to be increased, we compute one 24704 C additional scaled derivative. 24705 C----------------------------------------------------------------------- 24706 520 RHUP = 0.0D0 24707 IF (L .EQ. LMAX) GO TO 540 24708 DO 530 I = 1,N 24709 530 SAVF(I) = ACOR(I) - YH(I,LMAX) 24710 DUP = DVNORM (N, SAVF, EWT)/TESCO(3,NQ) 24711 EXUP = 1.0D0/(L+1) 24712 RHUP = 1.0D0/(1.4D0*DUP**EXUP + 0.0000014D0) 24713 540 EXSM = 1.0D0/L 24714 RHSM = 1.0D0/(1.2D0*DSM**EXSM + 0.0000012D0) 24715 RHDN = 0.0D0 24716 IF (NQ .EQ. 1) GO TO 560 24717 DDN = DVNORM (N, YH(1,L), EWT)/TESCO(1,NQ) 24718 EXDN = 1.0D0/NQ 24719 RHDN = 1.0D0/(1.3D0*DDN**EXDN + 0.0000013D0) 24720 560 IF (RHSM .GE. RHUP) GO TO 570 24721 IF (RHUP .GT. RHDN) GO TO 590 24722 GO TO 580 24723 570 IF (RHSM .LT. RHDN) GO TO 580 24724 NEWQ = NQ 24725 RH = RHSM 24726 GO TO 620 24727 580 NEWQ = NQ - 1 24728 RH = RHDN 24729 IF (KFLAG .LT. 0 .AND. RH .GT. 1.0D0) RH = 1.0D0 24730 GO TO 620 24731 590 NEWQ = L 24732 RH = RHUP 24733 IF (RH .LT. 1.1D0) GO TO 610 24734 R = EL(L)/L 24735 DO 600 I = 1,N 24736 600 YH(I,NEWQ+1) = ACOR(I)*R 24737 GO TO 630 24738 610 IALTH = 3 24739 GO TO 700 24740 620 IF ((KFLAG .EQ. 0) .AND. (RH .LT. 1.1D0)) GO TO 610 24741 IF (KFLAG .LE. -2) RH = MIN(RH,0.2D0) 24742 C----------------------------------------------------------------------- 24743 C If there is a change of order, reset NQ, L, and the coefficients. 24744 C In any case H is reset according to RH and the YH array is rescaled. 24745 C Then exit from 690 if the step was OK, or redo the step otherwise. 24746 C----------------------------------------------------------------------- 24747 IF (NEWQ .EQ. NQ) GO TO 170 24748 630 NQ = NEWQ 24749 L = NQ + 1 24750 IRET = 2 24751 GO TO 150 24752 C----------------------------------------------------------------------- 24753 C Control reaches this section if 3 or more failures have occured. 24754 C If 10 failures have occurred, exit with KFLAG = -1. 24755 C It is assumed that the derivatives that have accumulated in the 24756 C YH array have errors of the wrong order. Hence the first 24757 C derivative is recomputed, and the order is set to 1. Then 24758 C H is reduced by a factor of 10, and the step is retried, 24759 C until it succeeds or H reaches HMIN. 24760 C----------------------------------------------------------------------- 24761 640 IF (KFLAG .EQ. -10) GO TO 660 24762 RH = 0.1D0 24763 RH = MAX(HMIN/ABS(H),RH) 24764 H = H*RH 24765 DO 645 I = 1,N 24766 645 Y(I) = YH(I,1) 24767 CALL F (NEQ, TN, Y, SAVF) 24768 NFE = NFE + 1 24769 DO 650 I = 1,N 24770 650 YH(I,2) = H*SAVF(I) 24771 IPUP = MITER 24772 IALTH = 5 24773 IF (NQ .EQ. 1) GO TO 200 24774 NQ = 1 24775 L = 2 24776 IRET = 3 24777 GO TO 150 24778 C----------------------------------------------------------------------- 24779 C All returns are made through this section. H is saved in HOLD 24780 C to allow the caller to change H on the next step. 24781 C----------------------------------------------------------------------- 24782 660 KFLAG = -1 24783 GO TO 720 24784 670 KFLAG = -2 24785 GO TO 720 24786 680 KFLAG = -3 24787 GO TO 720 24788 690 RMAX = 10.0D0 24789 700 R = 1.0D0/TESCO(2,NQU) 24790 DO 710 I = 1,N 24791 710 ACOR(I) = ACOR(I)*R 24792 720 HOLD = H 24793 JSTART = 1 24794 RETURN 24795 C----------------------- End of Subroutine DSTOKA ---------------------- 24796 END 24797 *DECK DSETPK 24798 SUBROUTINE DSETPK (NEQ, Y, YSV, EWT, FTEM, SAVF, JOK, WM, IWM, 24799 1 F, JAC) 24800 EXTERNAL F, JAC 24801 INTEGER NEQ, JOK, IWM 24802 DOUBLE PRECISION Y, YSV, EWT, FTEM, SAVF, WM 24803 DIMENSION NEQ(*), Y(*), YSV(*), EWT(*), FTEM(*), SAVF(*), 24804 1 WM(*), IWM(*) 24805 INTEGER IOWND, IOWNS, 24806 1 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 24807 2 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 24808 3 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU 24809 INTEGER JPRE, JACFLG, LOCWP, LOCIWP, LSAVX, KMP, MAXL, MNEWT, 24810 1 NNI, NLI, NPS, NCFN, NCFL 24811 DOUBLE PRECISION ROWNS, 24812 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND 24813 DOUBLE PRECISION DELT, EPCON, SQRTN, RSQRTN 24814 COMMON /DLS001/ ROWNS(209), 24815 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND, 24816 2 IOWND(6), IOWNS(6), 24817 3 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 24818 4 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 24819 5 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU 24820 COMMON /DLPK01/ DELT, EPCON, SQRTN, RSQRTN, 24821 1 JPRE, JACFLG, LOCWP, LOCIWP, LSAVX, KMP, MAXL, MNEWT, 24822 2 NNI, NLI, NPS, NCFN, NCFL 24823 C----------------------------------------------------------------------- 24824 C DSETPK is called by DSTOKA to interface with the user-supplied 24825 C routine JAC, to compute and process relevant parts of 24826 C the matrix P = I - H*EL(1)*J , where J is the Jacobian df/dy, 24827 C as need for preconditioning matrix operations later. 24828 C 24829 C In addition to variables described previously, communication 24830 C with DSETPK uses the following: 24831 C Y = array containing predicted values on entry. 24832 C YSV = array containing predicted y, to be saved (YH1 in DSTOKA). 24833 C FTEM = work array of length N (ACOR in DSTOKA). 24834 C SAVF = array containing f evaluated at predicted y. 24835 C JOK = input flag showing whether it was judged that Jacobian matrix 24836 C data need not be recomputed (JOK = 1) or needs to be 24837 C (JOK = -1). 24838 C WM = real work space for matrices. 24839 C Space for preconditioning data starts at WM(LOCWP). 24840 C IWM = integer work space. 24841 C Space for preconditioning data starts at IWM(LOCIWP). 24842 C IERPJ = output error flag, = 0 if no trouble, .gt. 0 if 24843 C JAC returned an error flag. 24844 C JCUR = output flag to indicate whether the matrix data involved 24845 C is now current (JCUR = 1) or not (JCUR = 0). 24846 C This routine also uses Common variables EL0, H, TN, IERPJ, JCUR, NJE. 24847 C----------------------------------------------------------------------- 24848 INTEGER IER 24849 DOUBLE PRECISION HL0 24850 C 24851 IERPJ = 0 24852 JCUR = 0 24853 IF (JOK .EQ. -1) JCUR = 1 24854 HL0 = EL0*H 24855 CALL JAC (F, NEQ, TN, Y, YSV, EWT, SAVF, FTEM, HL0, JOK, 24856 1 WM(LOCWP), IWM(LOCIWP), IER) 24857 NJE = NJE + 1 24858 IF (IER .EQ. 0) RETURN 24859 IERPJ = 1 24860 RETURN 24861 C----------------------- End of Subroutine DSETPK ---------------------- 24862 END 24863 *DECK DSRCKR 24864 SUBROUTINE DSRCKR (RSAV, ISAV, JOB) 24865 C----------------------------------------------------------------------- 24866 C This routine saves or restores (depending on JOB) the contents of 24867 C the Common blocks DLS001, DLS002, DLSR01, DLPK01, which 24868 C are used internally by the DLSODKR solver. 24869 C 24870 C RSAV = real array of length 228 or more. 24871 C ISAV = integer array of length 63 or more. 24872 C JOB = flag indicating to save or restore the Common blocks: 24873 C JOB = 1 if Common is to be saved (written to RSAV/ISAV) 24874 C JOB = 2 if Common is to be restored (read from RSAV/ISAV) 24875 C A call with JOB = 2 presumes a prior call with JOB = 1. 24876 C----------------------------------------------------------------------- 24877 INTEGER ISAV, JOB 24878 INTEGER ILS, ILS2, ILSR, ILSP 24879 INTEGER I, IOFF, LENILP, LENRLP, LENILS, LENRLS, LENILR, LENRLR 24880 DOUBLE PRECISION RSAV, RLS, RLS2, RLSR, RLSP 24881 DIMENSION RSAV(*), ISAV(*) 24882 SAVE LENRLS, LENILS, LENRLP, LENILP, LENRLR, LENILR 24883 COMMON /DLS001/ RLS(218), ILS(37) 24884 COMMON /DLS002/ RLS2, ILS2(4) 24885 COMMON /DLSR01/ RLSR(5), ILSR(9) 24886 COMMON /DLPK01/ RLSP(4), ILSP(13) 24887 DATA LENRLS/218/, LENILS/37/, LENRLP/4/, LENILP/13/ 24888 DATA LENRLR/5/, LENILR/9/ 24889 C 24890 IF (JOB .EQ. 2) GO TO 100 24891 CALL DCOPY (LENRLS, RLS, 1, RSAV, 1) 24892 RSAV(LENRLS+1) = RLS2 24893 CALL DCOPY (LENRLR, RLSR, 1, RSAV(LENRLS+2), 1) 24894 CALL DCOPY (LENRLP, RLSP, 1, RSAV(LENRLS+LENRLR+2), 1) 24895 DO 20 I = 1,LENILS 24896 20 ISAV(I) = ILS(I) 24897 ISAV(LENILS+1) = ILS2(1) 24898 ISAV(LENILS+2) = ILS2(2) 24899 ISAV(LENILS+3) = ILS2(3) 24900 ISAV(LENILS+4) = ILS2(4) 24901 IOFF = LENILS + 2 24902 DO 30 I = 1,LENILR 24903 30 ISAV(IOFF+I) = ILSR(I) 24904 IOFF = IOFF + LENILR 24905 DO 40 I = 1,LENILP 24906 40 ISAV(IOFF+I) = ILSP(I) 24907 RETURN 24908 C 24909 100 CONTINUE 24910 CALL DCOPY (LENRLS, RSAV, 1, RLS, 1) 24911 RLS2 = RSAV(LENRLS+1) 24912 CALL DCOPY (LENRLR, RSAV(LENRLS+2), 1, RLSR, 1) 24913 CALL DCOPY (LENRLP, RSAV(LENRLS+LENRLR+2), 1, RLSP, 1) 24914 DO 120 I = 1,LENILS 24915 120 ILS(I) = ISAV(I) 24916 ILS2(1) = ISAV(LENILS+1) 24917 ILS2(2) = ISAV(LENILS+2) 24918 ILS2(3) = ISAV(LENILS+3) 24919 ILS2(4) = ISAV(LENILS+4) 24920 IOFF = LENILS + 2 24921 DO 130 I = 1,LENILR 24922 130 ILSR(I) = ISAV(IOFF+I) 24923 IOFF = IOFF + LENILR 24924 DO 140 I = 1,LENILP 24925 140 ILSP(I) = ISAV(IOFF+I) 24926 RETURN 24927 C----------------------- End of Subroutine DSRCKR ---------------------- 24928 END 24929 *DECK DAINVG 24930 SUBROUTINE DAINVG (RES, ADDA, NEQ, T, Y, YDOT, MITER, 24931 1 ML, MU, PW, IPVT, IER ) 24932 EXTERNAL RES, ADDA 24933 INTEGER NEQ, MITER, ML, MU, IPVT, IER 24934 INTEGER I, LENPW, MLP1, NROWPW 24935 DOUBLE PRECISION T, Y, YDOT, PW 24936 DIMENSION Y(*), YDOT(*), PW(*), IPVT(*) 24937 C----------------------------------------------------------------------- 24938 C This subroutine computes the initial value 24939 C of the vector YDOT satisfying 24940 C A * YDOT = g(t,y) 24941 C when A is nonsingular. It is called by DLSODI for 24942 C initialization only, when ISTATE = 0 . 24943 C DAINVG returns an error flag IER: 24944 C IER = 0 means DAINVG was successful. 24945 C IER .ge. 2 means RES returned an error flag IRES = IER. 24946 C IER .lt. 0 means the a-matrix was found to be singular. 24947 C----------------------------------------------------------------------- 24948 C 24949 IF (MITER .GE. 4) GO TO 100 24950 C 24951 C Full matrix case ----------------------------------------------------- 24952 C 24953 LENPW = NEQ*NEQ 24954 DO 10 I = 1, LENPW 24955 10 PW(I) = 0.0D0 24956 C 24957 IER = 1 24958 CALL RES ( NEQ, T, Y, PW, YDOT, IER ) 24959 IF (IER .GT. 1) RETURN 24960 C 24961 CALL ADDA ( NEQ, T, Y, 0, 0, PW, NEQ ) 24962 CALL DGEFA ( PW, NEQ, NEQ, IPVT, IER ) 24963 IF (IER .EQ. 0) GO TO 20 24964 IER = -IER 24965 RETURN 24966 20 CALL DGESL ( PW, NEQ, NEQ, IPVT, YDOT, 0 ) 24967 RETURN 24968 C 24969 C Band matrix case ----------------------------------------------------- 24970 C 24971 100 CONTINUE 24972 NROWPW = 2*ML + MU + 1 24973 LENPW = NEQ * NROWPW 24974 DO 110 I = 1, LENPW 24975 110 PW(I) = 0.0D0 24976 C 24977 IER = 1 24978 CALL RES ( NEQ, T, Y, PW, YDOT, IER ) 24979 IF (IER .GT. 1) RETURN 24980 C 24981 MLP1 = ML + 1 24982 CALL ADDA ( NEQ, T, Y, ML, MU, PW(MLP1), NROWPW ) 24983 CALL DGBFA ( PW, NROWPW, NEQ, ML, MU, IPVT, IER ) 24984 IF (IER .EQ. 0) GO TO 120 24985 IER = -IER 24986 RETURN 24987 120 CALL DGBSL ( PW, NROWPW, NEQ, ML, MU, IPVT, YDOT, 0 ) 24988 RETURN 24989 C----------------------- End of Subroutine DAINVG ---------------------- 24990 END 24991 *DECK DSTODI 24992 SUBROUTINE DSTODI (NEQ, Y, YH, NYH, YH1, EWT, SAVF, SAVR, 24993 1 ACOR, WM, IWM, RES, ADDA, JAC, PJAC, SLVS ) 24994 EXTERNAL RES, ADDA, JAC, PJAC, SLVS 24995 INTEGER NEQ, NYH, IWM 24996 DOUBLE PRECISION Y, YH, YH1, EWT, SAVF, SAVR, ACOR, WM 24997 DIMENSION NEQ(*), Y(*), YH(NYH,*), YH1(*), EWT(*), SAVF(*), 24998 1 SAVR(*), ACOR(*), WM(*), IWM(*) 24999 INTEGER IOWND, IALTH, IPUP, LMAX, MEO, NQNYH, NSLP, 25000 1 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 25001 2 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 25002 3 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU 25003 DOUBLE PRECISION CONIT, CRATE, EL, ELCO, HOLD, RMAX, TESCO, 25004 2 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND 25005 COMMON /DLS001/ CONIT, CRATE, EL(13), ELCO(13,12), 25006 1 HOLD, RMAX, TESCO(3,12), 25007 2 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND, 25008 3 IOWND(6), IALTH, IPUP, LMAX, MEO, NQNYH, NSLP, 25009 3 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 25010 4 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 25011 5 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU 25012 INTEGER I, I1, IREDO, IRES, IRET, J, JB, KGO, M, NCF, NEWQ 25013 DOUBLE PRECISION DCON, DDN, DEL, DELP, DSM, DUP, 25014 1 ELJH, EL1H, EXDN, EXSM, EXUP, 25015 2 R, RH, RHDN, RHSM, RHUP, TOLD, DVNORM 25016 C----------------------------------------------------------------------- 25017 C DSTODI performs one step of the integration of an initial value 25018 C problem for a system of Ordinary Differential Equations. 25019 C Note: DSTODI is independent of the value of the iteration method 25020 C indicator MITER, and hence is independent 25021 C of the type of chord method used, or the Jacobian structure. 25022 C Communication with DSTODI is done with the following variables: 25023 C 25024 C NEQ = integer array containing problem size in NEQ(1), and 25025 C passed as the NEQ argument in all calls to RES, ADDA, 25026 C and JAC. 25027 C Y = an array of length .ge. N used as the Y argument in 25028 C all calls to RES, JAC, and ADDA. 25029 C NEQ = integer array containing problem size in NEQ(1), and 25030 C passed as the NEQ argument in all calls tO RES, G, ADDA, 25031 C and JAC. 25032 C YH = an NYH by LMAX array containing the dependent variables 25033 C and their approximate scaled derivatives, where 25034 C LMAX = MAXORD + 1. YH(i,j+1) contains the approximate 25035 C j-th derivative of y(i), scaled by H**j/factorial(j) 25036 C (j = 0,1,...,NQ). On entry for the first step, the first 25037 C two columns of YH must be set from the initial values. 25038 C NYH = a constant integer .ge. N, the first dimension of YH. 25039 C YH1 = a one-dimensional array occupying the same space as YH. 25040 C EWT = an array of length N containing multiplicative weights 25041 C for local error measurements. Local errors in y(i) are 25042 C compared to 1.0/EWT(i) in various error tests. 25043 C SAVF = an array of working storage, of length N. also used for 25044 C input of YH(*,MAXORD+2) when JSTART = -1 and MAXORD is less 25045 C than the current order NQ. 25046 C Same as YDOTI in the driver. 25047 C SAVR = an array of working storage, of length N. 25048 C ACOR = a work array of length N used for the accumulated 25049 C corrections. On a succesful return, ACOR(i) contains 25050 C the estimated one-step local error in y(i). 25051 C WM,IWM = real and integer work arrays associated with matrix 25052 C operations in chord iteration. 25053 C PJAC = name of routine to evaluate and preprocess Jacobian matrix. 25054 C SLVS = name of routine to solve linear system in chord iteration. 25055 C CCMAX = maximum relative change in H*EL0 before PJAC is called. 25056 C H = the step size to be attempted on the next step. 25057 C H is altered by the error control algorithm during the 25058 C problem. H can be either positive or negative, but its 25059 C sign must remain constant throughout the problem. 25060 C HMIN = the minimum absolute value of the step size H to be used. 25061 C HMXI = inverse of the maximum absolute value of H to be used. 25062 C HMXI = 0.0 is allowed and corresponds to an infinite HMAX. 25063 C HMIN and HMXI may be changed at any time, but will not 25064 C take effect until the next change of H is considered. 25065 C TN = the independent variable. TN is updated on each step taken. 25066 C JSTART = an integer used for input only, with the following 25067 C values and meanings: 25068 C 0 perform the first step. 25069 C .gt.0 take a new step continuing from the last. 25070 C -1 take the next step with a new value of H, MAXORD, 25071 C N, METH, MITER, and/or matrix parameters. 25072 C -2 take the next step with a new value of H, 25073 C but with other inputs unchanged. 25074 C On return, JSTART is set to 1 to facilitate continuation. 25075 C KFLAG = a completion code with the following meanings: 25076 C 0 the step was succesful. 25077 C -1 the requested error could not be achieved. 25078 C -2 corrector convergence could not be achieved. 25079 C -3 RES ordered immediate return. 25080 C -4 error condition from RES could not be avoided. 25081 C -5 fatal error in PJAC or SLVS. 25082 C A return with KFLAG = -1, -2, or -4 means either 25083 C ABS(H) = HMIN or 10 consecutive failures occurred. 25084 C On a return with KFLAG negative, the values of TN and 25085 C the YH array are as of the beginning of the last 25086 C step, and H is the last step size attempted. 25087 C MAXORD = the maximum order of integration method to be allowed. 25088 C MAXCOR = the maximum number of corrector iterations allowed. 25089 C MSBP = maximum number of steps between PJAC calls. 25090 C MXNCF = maximum number of convergence failures allowed. 25091 C METH/MITER = the method flags. See description in driver. 25092 C N = the number of first-order differential equations. 25093 C----------------------------------------------------------------------- 25094 KFLAG = 0 25095 TOLD = TN 25096 NCF = 0 25097 IERPJ = 0 25098 IERSL = 0 25099 JCUR = 0 25100 ICF = 0 25101 DELP = 0.0D0 25102 IF (JSTART .GT. 0) GO TO 200 25103 IF (JSTART .EQ. -1) GO TO 100 25104 IF (JSTART .EQ. -2) GO TO 160 25105 C----------------------------------------------------------------------- 25106 C On the first call, the order is set to 1, and other variables are 25107 C initialized. RMAX is the maximum ratio by which H can be increased 25108 C in a single step. It is initially 1.E4 to compensate for the small 25109 C initial H, but then is normally equal to 10. If a failure 25110 C occurs (in corrector convergence or error test), RMAX is set at 2 25111 C for the next increase. 25112 C----------------------------------------------------------------------- 25113 LMAX = MAXORD + 1 25114 NQ = 1 25115 L = 2 25116 IALTH = 2 25117 RMAX = 10000.0D0 25118 RC = 0.0D0 25119 EL0 = 1.0D0 25120 CRATE = 0.7D0 25121 HOLD = H 25122 MEO = METH 25123 NSLP = 0 25124 IPUP = MITER 25125 IRET = 3 25126 GO TO 140 25127 C----------------------------------------------------------------------- 25128 C The following block handles preliminaries needed when JSTART = -1. 25129 C IPUP is set to MITER to force a matrix update. 25130 C If an order increase is about to be considered (IALTH = 1), 25131 C IALTH is reset to 2 to postpone consideration one more step. 25132 C If the caller has changed METH, DCFODE is called to reset 25133 C the coefficients of the method. 25134 C If the caller has changed MAXORD to a value less than the current 25135 C order NQ, NQ is reduced to MAXORD, and a new H chosen accordingly. 25136 C If H is to be changed, YH must be rescaled. 25137 C If H or METH is being changed, IALTH is reset to L = NQ + 1 25138 C to prevent further changes in H for that many steps. 25139 C----------------------------------------------------------------------- 25140 100 IPUP = MITER 25141 LMAX = MAXORD + 1 25142 IF (IALTH .EQ. 1) IALTH = 2 25143 IF (METH .EQ. MEO) GO TO 110 25144 CALL DCFODE (METH, ELCO, TESCO) 25145 MEO = METH 25146 IF (NQ .GT. MAXORD) GO TO 120 25147 IALTH = L 25148 IRET = 1 25149 GO TO 150 25150 110 IF (NQ .LE. MAXORD) GO TO 160 25151 120 NQ = MAXORD 25152 L = LMAX 25153 DO 125 I = 1,L 25154 125 EL(I) = ELCO(I,NQ) 25155 NQNYH = NQ*NYH 25156 RC = RC*EL(1)/EL0 25157 EL0 = EL(1) 25158 CONIT = 0.5D0/(NQ+2) 25159 DDN = DVNORM (N, SAVF, EWT)/TESCO(1,L) 25160 EXDN = 1.0D0/L 25161 RHDN = 1.0D0/(1.3D0*DDN**EXDN + 0.0000013D0) 25162 RH = MIN(RHDN,1.0D0) 25163 IREDO = 3 25164 IF (H .EQ. HOLD) GO TO 170 25165 RH = MIN(RH,ABS(H/HOLD)) 25166 H = HOLD 25167 GO TO 175 25168 C----------------------------------------------------------------------- 25169 C DCFODE is called to get all the integration coefficients for the 25170 C current METH. Then the EL vector and related constants are reset 25171 C whenever the order NQ is changed, or at the start of the problem. 25172 C----------------------------------------------------------------------- 25173 140 CALL DCFODE (METH, ELCO, TESCO) 25174 150 DO 155 I = 1,L 25175 155 EL(I) = ELCO(I,NQ) 25176 NQNYH = NQ*NYH 25177 RC = RC*EL(1)/EL0 25178 EL0 = EL(1) 25179 CONIT = 0.5D0/(NQ+2) 25180 GO TO (160, 170, 200), IRET 25181 C----------------------------------------------------------------------- 25182 C If H is being changed, the H ratio RH is checked against 25183 C RMAX, HMIN, and HMXI, and the YH array rescaled. IALTH is set to 25184 C L = NQ + 1 to prevent a change of H for that many steps, unless 25185 C forced by a convergence or error test failure. 25186 C----------------------------------------------------------------------- 25187 160 IF (H .EQ. HOLD) GO TO 200 25188 RH = H/HOLD 25189 H = HOLD 25190 IREDO = 3 25191 GO TO 175 25192 170 RH = MAX(RH,HMIN/ABS(H)) 25193 175 RH = MIN(RH,RMAX) 25194 RH = RH/MAX(1.0D0,ABS(H)*HMXI*RH) 25195 R = 1.0D0 25196 DO 180 J = 2,L 25197 R = R*RH 25198 DO 180 I = 1,N 25199 180 YH(I,J) = YH(I,J)*R 25200 H = H*RH 25201 RC = RC*RH 25202 IALTH = L 25203 IF (IREDO .EQ. 0) GO TO 690 25204 C----------------------------------------------------------------------- 25205 C This section computes the predicted values by effectively 25206 C multiplying the YH array by the Pascal triangle matrix. 25207 C RC is the ratio of new to old values of the coefficient H*EL(1). 25208 C When RC differs from 1 by more than CCMAX, IPUP is set to MITER 25209 C to force PJAC to be called. 25210 C In any case, PJAC is called at least every MSBP steps. 25211 C----------------------------------------------------------------------- 25212 200 IF (ABS(RC-1.0D0) .GT. CCMAX) IPUP = MITER 25213 IF (NST .GE. NSLP+MSBP) IPUP = MITER 25214 TN = TN + H 25215 I1 = NQNYH + 1 25216 DO 215 JB = 1,NQ 25217 I1 = I1 - NYH 25218 CDIR$ IVDEP 25219 DO 210 I = I1,NQNYH 25220 210 YH1(I) = YH1(I) + YH1(I+NYH) 25221 215 CONTINUE 25222 C----------------------------------------------------------------------- 25223 C Up to MAXCOR corrector iterations are taken. A convergence test is 25224 C made on the RMS-norm of each correction, weighted by H and the 25225 C error weight vector EWT. The sum of the corrections is accumulated 25226 C in ACOR(i). The YH array is not altered in the corrector loop. 25227 C----------------------------------------------------------------------- 25228 220 M = 0 25229 DO 230 I = 1,N 25230 SAVF(I) = YH(I,2) / H 25231 230 Y(I) = YH(I,1) 25232 IF (IPUP .LE. 0) GO TO 240 25233 C----------------------------------------------------------------------- 25234 C If indicated, the matrix P = A - H*EL(1)*dr/dy is reevaluated and 25235 C preprocessed before starting the corrector iteration. IPUP is set 25236 C to 0 as an indicator that this has been done. 25237 C----------------------------------------------------------------------- 25238 CALL PJAC (NEQ, Y, YH, NYH, EWT, ACOR, SAVR, SAVF, WM, IWM, 25239 1 RES, JAC, ADDA ) 25240 IPUP = 0 25241 RC = 1.0D0 25242 NSLP = NST 25243 CRATE = 0.7D0 25244 IF (IERPJ .EQ. 0) GO TO 250 25245 IF (IERPJ .LT. 0) GO TO 435 25246 IRES = IERPJ 25247 GO TO (430, 435, 430), IRES 25248 C Get residual at predicted values, if not already done in PJAC. ------- 25249 240 IRES = 1 25250 CALL RES ( NEQ, TN, Y, SAVF, SAVR, IRES ) 25251 NFE = NFE + 1 25252 KGO = ABS(IRES) 25253 GO TO ( 250, 435, 430 ) , KGO 25254 250 DO 260 I = 1,N 25255 260 ACOR(I) = 0.0D0 25256 C----------------------------------------------------------------------- 25257 C Solve the linear system with the current residual as 25258 C right-hand side and P as coefficient matrix. 25259 C----------------------------------------------------------------------- 25260 270 CONTINUE 25261 CALL SLVS (WM, IWM, SAVR, SAVF) 25262 IF (IERSL .LT. 0) GO TO 430 25263 IF (IERSL .GT. 0) GO TO 410 25264 EL1H = EL(1) * H 25265 DEL = DVNORM (N, SAVR, EWT) * ABS(H) 25266 DO 380 I = 1,N 25267 ACOR(I) = ACOR(I) + SAVR(I) 25268 SAVF(I) = ACOR(I) + YH(I,2)/H 25269 380 Y(I) = YH(I,1) + EL1H*ACOR(I) 25270 C----------------------------------------------------------------------- 25271 C Test for convergence. If M .gt. 0, an estimate of the convergence 25272 C rate constant is stored in CRATE, and this is used in the test. 25273 C----------------------------------------------------------------------- 25274 IF (M .NE. 0) CRATE = MAX(0.2D0*CRATE,DEL/DELP) 25275 DCON = DEL*MIN(1.0D0,1.5D0*CRATE)/(TESCO(2,NQ)*CONIT) 25276 IF (DCON .LE. 1.0D0) GO TO 460 25277 M = M + 1 25278 IF (M .EQ. MAXCOR) GO TO 410 25279 IF (M .GE. 2 .AND. DEL .GT. 2.0D0*DELP) GO TO 410 25280 DELP = DEL 25281 IRES = 1 25282 CALL RES ( NEQ, TN, Y, SAVF, SAVR, IRES ) 25283 NFE = NFE + 1 25284 KGO = ABS(IRES) 25285 GO TO ( 270, 435, 410 ) , KGO 25286 C----------------------------------------------------------------------- 25287 C The correctors failed to converge, or RES has returned abnormally. 25288 C on a convergence failure, if the Jacobian is out of date, PJAC is 25289 C called for the next try. Otherwise the YH array is retracted to its 25290 C values before prediction, and H is reduced, if possible. 25291 C take an error exit if IRES = 2, or H cannot be reduced, or MXNCF 25292 C failures have occurred, or a fatal error occurred in PJAC or SLVS. 25293 C----------------------------------------------------------------------- 25294 410 ICF = 1 25295 IF (JCUR .EQ. 1) GO TO 430 25296 IPUP = MITER 25297 GO TO 220 25298 430 ICF = 2 25299 NCF = NCF + 1 25300 RMAX = 2.0D0 25301 435 TN = TOLD 25302 I1 = NQNYH + 1 25303 DO 445 JB = 1,NQ 25304 I1 = I1 - NYH 25305 CDIR$ IVDEP 25306 DO 440 I = I1,NQNYH 25307 440 YH1(I) = YH1(I) - YH1(I+NYH) 25308 445 CONTINUE 25309 IF (IRES .EQ. 2) GO TO 680 25310 IF (IERPJ .LT. 0 .OR. IERSL .LT. 0) GO TO 685 25311 IF (ABS(H) .LE. HMIN*1.00001D0) GO TO 450 25312 IF (NCF .EQ. MXNCF) GO TO 450 25313 RH = 0.25D0 25314 IPUP = MITER 25315 IREDO = 1 25316 GO TO 170 25317 450 IF (IRES .EQ. 3) GO TO 680 25318 GO TO 670 25319 C----------------------------------------------------------------------- 25320 C The corrector has converged. JCUR is set to 0 25321 C to signal that the Jacobian involved may need updating later. 25322 C The local error test is made and control passes to statement 500 25323 C if it fails. 25324 C----------------------------------------------------------------------- 25325 460 JCUR = 0 25326 IF (M .EQ. 0) DSM = DEL/TESCO(2,NQ) 25327 IF (M .GT. 0) DSM = ABS(H) * DVNORM (N, ACOR, EWT)/TESCO(2,NQ) 25328 IF (DSM .GT. 1.0D0) GO TO 500 25329 C----------------------------------------------------------------------- 25330 C After a successful step, update the YH array. 25331 C Consider changing H if IALTH = 1. Otherwise decrease IALTH by 1. 25332 C If IALTH is then 1 and NQ .lt. MAXORD, then ACOR is saved for 25333 C use in a possible order increase on the next step. 25334 C If a change in H is considered, an increase or decrease in order 25335 C by one is considered also. A change in H is made only if it is by a 25336 C factor of at least 1.1. If not, IALTH is set to 3 to prevent 25337 C testing for that many steps. 25338 C----------------------------------------------------------------------- 25339 KFLAG = 0 25340 IREDO = 0 25341 NST = NST + 1 25342 HU = H 25343 NQU = NQ 25344 DO 470 J = 1,L 25345 ELJH = EL(J)*H 25346 DO 470 I = 1,N 25347 470 YH(I,J) = YH(I,J) + ELJH*ACOR(I) 25348 IALTH = IALTH - 1 25349 IF (IALTH .EQ. 0) GO TO 520 25350 IF (IALTH .GT. 1) GO TO 700 25351 IF (L .EQ. LMAX) GO TO 700 25352 DO 490 I = 1,N 25353 490 YH(I,LMAX) = ACOR(I) 25354 GO TO 700 25355 C----------------------------------------------------------------------- 25356 C The error test failed. KFLAG keeps track of multiple failures. 25357 C restore TN and the YH array to their previous values, and prepare 25358 C to try the step again. Compute the optimum step size for this or 25359 C one lower order. After 2 or more failures, H is forced to decrease 25360 C by a factor of 0.1 or less. 25361 C----------------------------------------------------------------------- 25362 500 KFLAG = KFLAG - 1 25363 TN = TOLD 25364 I1 = NQNYH + 1 25365 DO 515 JB = 1,NQ 25366 I1 = I1 - NYH 25367 CDIR$ IVDEP 25368 DO 510 I = I1,NQNYH 25369 510 YH1(I) = YH1(I) - YH1(I+NYH) 25370 515 CONTINUE 25371 RMAX = 2.0D0 25372 IF (ABS(H) .LE. HMIN*1.00001D0) GO TO 660 25373 IF (KFLAG .LE. -7) GO TO 660 25374 IREDO = 2 25375 RHUP = 0.0D0 25376 GO TO 540 25377 C----------------------------------------------------------------------- 25378 C Regardless of the success or failure of the step, factors 25379 C RHDN, RHSM, and RHUP are computed, by which H could be multiplied 25380 C at order NQ - 1, order NQ, or order NQ + 1, respectively. 25381 C In the case of failure, RHUP = 0.0 to avoid an order increase. 25382 C The largest of these is determined and the new order chosen 25383 C accordingly. If the order is to be increased, we compute one 25384 C additional scaled derivative. 25385 C----------------------------------------------------------------------- 25386 520 RHUP = 0.0D0 25387 IF (L .EQ. LMAX) GO TO 540 25388 DO 530 I = 1,N 25389 530 SAVF(I) = ACOR(I) - YH(I,LMAX) 25390 DUP = ABS(H) * DVNORM (N, SAVF, EWT)/TESCO(3,NQ) 25391 EXUP = 1.0D0/(L+1) 25392 RHUP = 1.0D0/(1.4D0*DUP**EXUP + 0.0000014D0) 25393 540 EXSM = 1.0D0/L 25394 RHSM = 1.0D0/(1.2D0*DSM**EXSM + 0.0000012D0) 25395 RHDN = 0.0D0 25396 IF (NQ .EQ. 1) GO TO 560 25397 DDN = DVNORM (N, YH(1,L), EWT)/TESCO(1,NQ) 25398 EXDN = 1.0D0/NQ 25399 RHDN = 1.0D0/(1.3D0*DDN**EXDN + 0.0000013D0) 25400 560 IF (RHSM .GE. RHUP) GO TO 570 25401 IF (RHUP .GT. RHDN) GO TO 590 25402 GO TO 580 25403 570 IF (RHSM .LT. RHDN) GO TO 580 25404 NEWQ = NQ 25405 RH = RHSM 25406 GO TO 620 25407 580 NEWQ = NQ - 1 25408 RH = RHDN 25409 IF (KFLAG .LT. 0 .AND. RH .GT. 1.0D0) RH = 1.0D0 25410 GO TO 620 25411 590 NEWQ = L 25412 RH = RHUP 25413 IF (RH .LT. 1.1D0) GO TO 610 25414 R = H*EL(L)/L 25415 DO 600 I = 1,N 25416 600 YH(I,NEWQ+1) = ACOR(I)*R 25417 GO TO 630 25418 610 IALTH = 3 25419 GO TO 700 25420 620 IF ((KFLAG .EQ. 0) .AND. (RH .LT. 1.1D0)) GO TO 610 25421 IF (KFLAG .LE. -2) RH = MIN(RH,0.1D0) 25422 C----------------------------------------------------------------------- 25423 C If there is a change of order, reset NQ, L, and the coefficients. 25424 C In any case H is reset according to RH and the YH array is rescaled. 25425 C Then exit from 690 if the step was OK, or redo the step otherwise. 25426 C----------------------------------------------------------------------- 25427 IF (NEWQ .EQ. NQ) GO TO 170 25428 630 NQ = NEWQ 25429 L = NQ + 1 25430 IRET = 2 25431 GO TO 150 25432 C----------------------------------------------------------------------- 25433 C All returns are made through this section. H is saved in HOLD 25434 C to allow the caller to change H on the next step. 25435 C----------------------------------------------------------------------- 25436 660 KFLAG = -1 25437 GO TO 720 25438 670 KFLAG = -2 25439 GO TO 720 25440 680 KFLAG = -1 - IRES 25441 GO TO 720 25442 685 KFLAG = -5 25443 GO TO 720 25444 690 RMAX = 10.0D0 25445 700 R = H/TESCO(2,NQU) 25446 DO 710 I = 1,N 25447 710 ACOR(I) = ACOR(I)*R 25448 720 HOLD = H 25449 JSTART = 1 25450 RETURN 25451 C----------------------- End of Subroutine DSTODI ---------------------- 25452 END 25453 *DECK DPREPJI 25454 SUBROUTINE DPREPJI (NEQ, Y, YH, NYH, EWT, RTEM, SAVR, S, WM, IWM, 25455 1 RES, JAC, ADDA) 25456 EXTERNAL RES, JAC, ADDA 25457 INTEGER NEQ, NYH, IWM 25458 DOUBLE PRECISION Y, YH, EWT, RTEM, SAVR, S, WM 25459 DIMENSION NEQ(*), Y(*), YH(NYH,*), EWT(*), RTEM(*), 25460 1 S(*), SAVR(*), WM(*), IWM(*) 25461 INTEGER IOWND, IOWNS, 25462 1 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 25463 2 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 25464 3 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU 25465 DOUBLE PRECISION ROWNS, 25466 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND 25467 COMMON /DLS001/ ROWNS(209), 25468 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND, 25469 2 IOWND(6), IOWNS(6), 25470 3 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 25471 4 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 25472 5 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU 25473 INTEGER I, I1, I2, IER, II, IRES, J, J1, JJ, LENP, 25474 1 MBA, MBAND, MEB1, MEBAND, ML, ML3, MU 25475 DOUBLE PRECISION CON, FAC, HL0, R, SRUR, YI, YJ, YJJ 25476 C----------------------------------------------------------------------- 25477 C DPREPJI is called by DSTODI to compute and process the matrix 25478 C P = A - H*EL(1)*J , where J is an approximation to the Jacobian dr/dy, 25479 C where r = g(t,y) - A(t,y)*s. Here J is computed by the user-supplied 25480 C routine JAC if MITER = 1 or 4, or by finite differencing if MITER = 25481 C 2 or 5. J is stored in WM, rescaled, and ADDA is called to generate 25482 C P. P is then subjected to LU decomposition in preparation 25483 C for later solution of linear systems with P as coefficient 25484 C matrix. This is done by DGEFA if MITER = 1 or 2, and by 25485 C DGBFA if MITER = 4 or 5. 25486 C 25487 C In addition to variables described previously, communication 25488 C with DPREPJI uses the following: 25489 C Y = array containing predicted values on entry. 25490 C RTEM = work array of length N (ACOR in DSTODI). 25491 C SAVR = array used for output only. On output it contains the 25492 C residual evaluated at current values of t and y. 25493 C S = array containing predicted values of dy/dt (SAVF in DSTODI). 25494 C WM = real work space for matrices. On output it contains the 25495 C LU decomposition of P. 25496 C Storage of matrix elements starts at WM(3). 25497 C WM also contains the following matrix-related data: 25498 C WM(1) = SQRT(UROUND), used in numerical Jacobian increments. 25499 C IWM = integer work space containing pivot information, starting at 25500 C IWM(21). IWM also contains the band parameters 25501 C ML = IWM(1) and MU = IWM(2) if MITER is 4 or 5. 25502 C EL0 = el(1) (input). 25503 C IERPJ = output error flag. 25504 C = 0 if no trouble occurred, 25505 C = 1 if the P matrix was found to be singular, 25506 C = IRES (= 2 or 3) if RES returned IRES = 2 or 3. 25507 C JCUR = output flag = 1 to indicate that the Jacobian matrix 25508 C (or approximation) is now current. 25509 C This routine also uses the Common variables EL0, H, TN, UROUND, 25510 C MITER, N, NFE, and NJE. 25511 C----------------------------------------------------------------------- 25512 NJE = NJE + 1 25513 HL0 = H*EL0 25514 IERPJ = 0 25515 JCUR = 1 25516 GO TO (100, 200, 300, 400, 500), MITER 25517 C If MITER = 1, call RES, then JAC, and multiply by scalar. ------------ 25518 100 IRES = 1 25519 CALL RES (NEQ, TN, Y, S, SAVR, IRES) 25520 NFE = NFE + 1 25521 IF (IRES .GT. 1) GO TO 600 25522 LENP = N*N 25523 DO 110 I = 1,LENP 25524 110 WM(I+2) = 0.0D0 25525 CALL JAC ( NEQ, TN, Y, S, 0, 0, WM(3), N ) 25526 CON = -HL0 25527 DO 120 I = 1,LENP 25528 120 WM(I+2) = WM(I+2)*CON 25529 GO TO 240 25530 C If MITER = 2, make N + 1 calls to RES to approximate J. -------------- 25531 200 CONTINUE 25532 IRES = -1 25533 CALL RES (NEQ, TN, Y, S, SAVR, IRES) 25534 NFE = NFE + 1 25535 IF (IRES .GT. 1) GO TO 600 25536 SRUR = WM(1) 25537 J1 = 2 25538 DO 230 J = 1,N 25539 YJ = Y(J) 25540 R = MAX(SRUR*ABS(YJ),0.01D0/EWT(J)) 25541 Y(J) = Y(J) + R 25542 FAC = -HL0/R 25543 CALL RES ( NEQ, TN, Y, S, RTEM, IRES ) 25544 NFE = NFE + 1 25545 IF (IRES .GT. 1) GO TO 600 25546 DO 220 I = 1,N 25547 220 WM(I+J1) = (RTEM(I) - SAVR(I))*FAC 25548 Y(J) = YJ 25549 J1 = J1 + N 25550 230 CONTINUE 25551 IRES = 1 25552 CALL RES (NEQ, TN, Y, S, SAVR, IRES) 25553 NFE = NFE + 1 25554 IF (IRES .GT. 1) GO TO 600 25555 C Add matrix A. -------------------------------------------------------- 25556 240 CONTINUE 25557 CALL ADDA(NEQ, TN, Y, 0, 0, WM(3), N) 25558 C Do LU decomposition on P. -------------------------------------------- 25559 CALL DGEFA (WM(3), N, N, IWM(21), IER) 25560 IF (IER .NE. 0) IERPJ = 1 25561 RETURN 25562 C Dummy section for MITER = 3 25563 300 RETURN 25564 C If MITER = 4, call RES, then JAC, and multiply by scalar. ------------ 25565 400 IRES = 1 25566 CALL RES (NEQ, TN, Y, S, SAVR, IRES) 25567 NFE = NFE + 1 25568 IF (IRES .GT. 1) GO TO 600 25569 ML = IWM(1) 25570 MU = IWM(2) 25571 ML3 = ML + 3 25572 MBAND = ML + MU + 1 25573 MEBAND = MBAND + ML 25574 LENP = MEBAND*N 25575 DO 410 I = 1,LENP 25576 410 WM(I+2) = 0.0D0 25577 CALL JAC ( NEQ, TN, Y, S, ML, MU, WM(ML3), MEBAND) 25578 CON = -HL0 25579 DO 420 I = 1,LENP 25580 420 WM(I+2) = WM(I+2)*CON 25581 GO TO 570 25582 C If MITER = 5, make ML + MU + 2 calls to RES to approximate J. -------- 25583 500 CONTINUE 25584 IRES = -1 25585 CALL RES (NEQ, TN, Y, S, SAVR, IRES) 25586 NFE = NFE + 1 25587 IF (IRES .GT. 1) GO TO 600 25588 ML = IWM(1) 25589 MU = IWM(2) 25590 ML3 = ML + 3 25591 MBAND = ML + MU + 1 25592 MBA = MIN(MBAND,N) 25593 MEBAND = MBAND + ML 25594 MEB1 = MEBAND - 1 25595 SRUR = WM(1) 25596 DO 560 J = 1,MBA 25597 DO 530 I = J,N,MBAND 25598 YI = Y(I) 25599 R = MAX(SRUR*ABS(YI),0.01D0/EWT(I)) 25600 530 Y(I) = Y(I) + R 25601 CALL RES ( NEQ, TN, Y, S, RTEM, IRES) 25602 NFE = NFE + 1 25603 IF (IRES .GT. 1) GO TO 600 25604 DO 550 JJ = J,N,MBAND 25605 Y(JJ) = YH(JJ,1) 25606 YJJ = Y(JJ) 25607 R = MAX(SRUR*ABS(YJJ),0.01D0/EWT(JJ)) 25608 FAC = -HL0/R 25609 I1 = MAX(JJ-MU,1) 25610 I2 = MIN(JJ+ML,N) 25611 II = JJ*MEB1 - ML + 2 25612 DO 540 I = I1,I2 25613 540 WM(II+I) = (RTEM(I) - SAVR(I))*FAC 25614 550 CONTINUE 25615 560 CONTINUE 25616 IRES = 1 25617 CALL RES (NEQ, TN, Y, S, SAVR, IRES) 25618 NFE = NFE + 1 25619 IF (IRES .GT. 1) GO TO 600 25620 C Add matrix A. -------------------------------------------------------- 25621 570 CONTINUE 25622 CALL ADDA(NEQ, TN, Y, ML, MU, WM(ML3), MEBAND) 25623 C Do LU decomposition of P. -------------------------------------------- 25624 CALL DGBFA (WM(3), MEBAND, N, ML, MU, IWM(21), IER) 25625 IF (IER .NE. 0) IERPJ = 1 25626 RETURN 25627 C Error return for IRES = 2 or IRES = 3 return from RES. --------------- 25628 600 IERPJ = IRES 25629 RETURN 25630 C----------------------- End of Subroutine DPREPJI --------------------- 25631 END 25632 *DECK DAIGBT 25633 SUBROUTINE DAIGBT (RES, ADDA, NEQ, T, Y, YDOT, 25634 1 MB, NB, PW, IPVT, IER ) 25635 EXTERNAL RES, ADDA 25636 INTEGER NEQ, MB, NB, IPVT, IER 25637 INTEGER I, LENPW, LBLOX, LPB, LPC 25638 DOUBLE PRECISION T, Y, YDOT, PW 25639 DIMENSION Y(*), YDOT(*), PW(*), IPVT(*), NEQ(*) 25640 C----------------------------------------------------------------------- 25641 C This subroutine computes the initial value 25642 C of the vector YDOT satisfying 25643 C A * YDOT = g(t,y) 25644 C when A is nonsingular. It is called by DLSOIBT for 25645 C initialization only, when ISTATE = 0 . 25646 C DAIGBT returns an error flag IER: 25647 C IER = 0 means DAIGBT was successful. 25648 C IER .ge. 2 means RES returned an error flag IRES = IER. 25649 C IER .lt. 0 means the A matrix was found to have a singular 25650 C diagonal block (hence YDOT could not be solved for). 25651 C----------------------------------------------------------------------- 25652 LBLOX = MB*MB*NB 25653 LPB = 1 + LBLOX 25654 LPC = LPB + LBLOX 25655 LENPW = 3*LBLOX 25656 DO 10 I = 1,LENPW 25657 10 PW(I) = 0.0D0 25658 IER = 1 25659 CALL RES (NEQ, T, Y, PW, YDOT, IER) 25660 IF (IER .GT. 1) RETURN 25661 CALL ADDA (NEQ, T, Y, MB, NB, PW(1), PW(LPB), PW(LPC) ) 25662 CALL DDECBT (MB, NB, PW, PW(LPB), PW(LPC), IPVT, IER) 25663 IF (IER .EQ. 0) GO TO 20 25664 IER = -IER 25665 RETURN 25666 20 CALL DSOLBT (MB, NB, PW, PW(LPB), PW(LPC), YDOT, IPVT) 25667 RETURN 25668 C----------------------- End of Subroutine DAIGBT ---------------------- 25669 END 25670 *DECK DPJIBT 25671 SUBROUTINE DPJIBT (NEQ, Y, YH, NYH, EWT, RTEM, SAVR, S, WM, IWM, 25672 1 RES, JAC, ADDA) 25673 EXTERNAL RES, JAC, ADDA 25674 INTEGER NEQ, NYH, IWM 25675 DOUBLE PRECISION Y, YH, EWT, RTEM, SAVR, S, WM 25676 DIMENSION NEQ(*), Y(*), YH(NYH,*), EWT(*), RTEM(*), 25677 1 S(*), SAVR(*), WM(*), IWM(*) 25678 INTEGER IOWND, IOWNS, 25679 1 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 25680 2 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 25681 3 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU 25682 DOUBLE PRECISION ROWNS, 25683 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND 25684 COMMON /DLS001/ ROWNS(209), 25685 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND, 25686 2 IOWND(6), IOWNS(6), 25687 3 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 25688 4 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 25689 5 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU 25690 INTEGER I, IER, IIA, IIB, IIC, IPA, IPB, IPC, IRES, J, J1, J2, 25691 1 K, K1, LENP, LBLOX, LPB, LPC, MB, MBSQ, MWID, NB 25692 DOUBLE PRECISION CON, FAC, HL0, R, SRUR 25693 C----------------------------------------------------------------------- 25694 C DPJIBT is called by DSTODI to compute and process the matrix 25695 C P = A - H*EL(1)*J , where J is an approximation to the Jacobian dr/dy, 25696 C and r = g(t,y) - A(t,y)*s. Here J is computed by the user-supplied 25697 C routine JAC if MITER = 1, or by finite differencing if MITER = 2. 25698 C J is stored in WM, rescaled, and ADDA is called to generate P. 25699 C P is then subjected to LU decomposition by DDECBT in preparation 25700 C for later solution of linear systems with P as coefficient matrix. 25701 C 25702 C In addition to variables described previously, communication 25703 C with DPJIBT uses the following: 25704 C Y = array containing predicted values on entry. 25705 C RTEM = work array of length N (ACOR in DSTODI). 25706 C SAVR = array used for output only. On output it contains the 25707 C residual evaluated at current values of t and y. 25708 C S = array containing predicted values of dy/dt (SAVF in DSTODI). 25709 C WM = real work space for matrices. On output it contains the 25710 C LU decomposition of P. 25711 C Storage of matrix elements starts at WM(3). 25712 C WM also contains the following matrix-related data: 25713 C WM(1) = SQRT(UROUND), used in numerical Jacobian increments. 25714 C IWM = integer work space containing pivot information, starting at 25715 C IWM(21). IWM also contains block structure parameters 25716 C MB = IWM(1) and NB = IWM(2). 25717 C EL0 = EL(1) (input). 25718 C IERPJ = output error flag. 25719 C = 0 if no trouble occurred, 25720 C = 1 if the P matrix was found to be unfactorable, 25721 C = IRES (= 2 or 3) if RES returned IRES = 2 or 3. 25722 C JCUR = output flag = 1 to indicate that the Jacobian matrix 25723 C (or approximation) is now current. 25724 C This routine also uses the Common variables EL0, H, TN, UROUND, 25725 C MITER, N, NFE, and NJE. 25726 C----------------------------------------------------------------------- 25727 NJE = NJE + 1 25728 HL0 = H*EL0 25729 IERPJ = 0 25730 JCUR = 1 25731 MB = IWM(1) 25732 NB = IWM(2) 25733 MBSQ = MB*MB 25734 LBLOX = MBSQ*NB 25735 LPB = 3 + LBLOX 25736 LPC = LPB + LBLOX 25737 LENP = 3*LBLOX 25738 GO TO (100, 200), MITER 25739 C If MITER = 1, call RES, then JAC, and multiply by scalar. ------------ 25740 100 IRES = 1 25741 CALL RES (NEQ, TN, Y, S, SAVR, IRES) 25742 NFE = NFE + 1 25743 IF (IRES .GT. 1) GO TO 600 25744 DO 110 I = 1,LENP 25745 110 WM(I+2) = 0.0D0 25746 CALL JAC (NEQ, TN, Y, S, MB, NB, WM(3), WM(LPB), WM(LPC)) 25747 CON = -HL0 25748 DO 120 I = 1,LENP 25749 120 WM(I+2) = WM(I+2)*CON 25750 GO TO 260 25751 C 25752 C If MITER = 2, make 3*MB + 1 calls to RES to approximate J. ----------- 25753 200 CONTINUE 25754 IRES = -1 25755 CALL RES (NEQ, TN, Y, S, SAVR, IRES) 25756 NFE = NFE + 1 25757 IF (IRES .GT. 1) GO TO 600 25758 MWID = 3*MB 25759 SRUR = WM(1) 25760 DO 205 I = 1,LENP 25761 205 WM(2+I) = 0.0D0 25762 DO 250 K = 1,3 25763 DO 240 J = 1,MB 25764 C Increment Y(I) for group of column indices, and call RES. ---- 25765 J1 = J+(K-1)*MB 25766 DO 210 I = J1,N,MWID 25767 R = MAX(SRUR*ABS(Y(I)),0.01D0/EWT(I)) 25768 Y(I) = Y(I) + R 25769 210 CONTINUE 25770 CALL RES (NEQ, TN, Y, S, RTEM, IRES) 25771 NFE = NFE + 1 25772 IF (IRES .GT. 1) GO TO 600 25773 DO 215 I = 1,N 25774 215 RTEM(I) = RTEM(I) - SAVR(I) 25775 K1 = K 25776 DO 230 I = J1,N,MWID 25777 C Get Jacobian elements in column I (block-column K1). ------- 25778 Y(I) = YH(I,1) 25779 R = MAX(SRUR*ABS(Y(I)),0.01D0/EWT(I)) 25780 FAC = -HL0/R 25781 C Compute and load elements PA(*,J,K1). ---------------------- 25782 IIA = I - J 25783 IPA = 2 + (J-1)*MB + (K1-1)*MBSQ 25784 DO 221 J2 = 1,MB 25785 221 WM(IPA+J2) = RTEM(IIA+J2)*FAC 25786 IF (K1 .LE. 1) GO TO 223 25787 C Compute and load elements PB(*,J,K1-1). -------------------- 25788 IIB = IIA - MB 25789 IPB = IPA + LBLOX - MBSQ 25790 DO 222 J2 = 1,MB 25791 222 WM(IPB+J2) = RTEM(IIB+J2)*FAC 25792 223 CONTINUE 25793 IF (K1 .GE. NB) GO TO 225 25794 C Compute and load elements PC(*,J,K1+1). -------------------- 25795 IIC = IIA + MB 25796 IPC = IPA + 2*LBLOX + MBSQ 25797 DO 224 J2 = 1,MB 25798 224 WM(IPC+J2) = RTEM(IIC+J2)*FAC 25799 225 CONTINUE 25800 IF (K1 .NE. 3) GO TO 227 25801 C Compute and load elements PC(*,J,1). ----------------------- 25802 IPC = IPA - 2*MBSQ + 2*LBLOX 25803 DO 226 J2 = 1,MB 25804 226 WM(IPC+J2) = RTEM(J2)*FAC 25805 227 CONTINUE 25806 IF (K1 .NE. NB-2) GO TO 229 25807 C Compute and load elements PB(*,J,NB). ---------------------- 25808 IIB = N - MB 25809 IPB = IPA + 2*MBSQ + LBLOX 25810 DO 228 J2 = 1,MB 25811 228 WM(IPB+J2) = RTEM(IIB+J2)*FAC 25812 229 K1 = K1 + 3 25813 230 CONTINUE 25814 240 CONTINUE 25815 250 CONTINUE 25816 C RES call for first corrector iteration. ------------------------------ 25817 IRES = 1 25818 CALL RES (NEQ, TN, Y, S, SAVR, IRES) 25819 NFE = NFE + 1 25820 IF (IRES .GT. 1) GO TO 600 25821 C Add matrix A. -------------------------------------------------------- 25822 260 CONTINUE 25823 CALL ADDA (NEQ, TN, Y, MB, NB, WM(3), WM(LPB), WM(LPC)) 25824 C Do LU decomposition on P. -------------------------------------------- 25825 CALL DDECBT (MB, NB, WM(3), WM(LPB), WM(LPC), IWM(21), IER) 25826 IF (IER .NE. 0) IERPJ = 1 25827 RETURN 25828 C Error return for IRES = 2 or IRES = 3 return from RES. --------------- 25829 600 IERPJ = IRES 25830 RETURN 25831 C----------------------- End of Subroutine DPJIBT ---------------------- 25832 END 25833 *DECK DSLSBT 25834 SUBROUTINE DSLSBT (WM, IWM, X, TEM) 25835 INTEGER IWM 25836 INTEGER LBLOX, LPB, LPC, MB, NB 25837 DOUBLE PRECISION WM, X, TEM 25838 DIMENSION WM(*), IWM(*), X(*), TEM(*) 25839 C----------------------------------------------------------------------- 25840 C This routine acts as an interface between the core integrator 25841 C routine and the DSOLBT routine for the solution of the linear system 25842 C arising from chord iteration. 25843 C Communication with DSLSBT uses the following variables: 25844 C WM = real work space containing the LU decomposition, 25845 C starting at WM(3). 25846 C IWM = integer work space containing pivot information, starting at 25847 C IWM(21). IWM also contains block structure parameters 25848 C MB = IWM(1) and NB = IWM(2). 25849 C X = the right-hand side vector on input, and the solution vector 25850 C on output, of length N. 25851 C TEM = vector of work space of length N, not used in this version. 25852 C----------------------------------------------------------------------- 25853 MB = IWM(1) 25854 NB = IWM(2) 25855 LBLOX = MB*MB*NB 25856 LPB = 3 + LBLOX 25857 LPC = LPB + LBLOX 25858 CALL DSOLBT (MB, NB, WM(3), WM(LPB), WM(LPC), X, IWM(21)) 25859 RETURN 25860 C----------------------- End of Subroutine DSLSBT ---------------------- 25861 END 25862 *DECK DDECBT 25863 SUBROUTINE DDECBT (M, N, A, B, C, IP, IER) 25864 INTEGER M, N, IP(M,N), IER 25865 DOUBLE PRECISION A(M,M,N), B(M,M,N), C(M,M,N) 25866 C----------------------------------------------------------------------- 25867 C Block-tridiagonal matrix decomposition routine. 25868 C Written by A. C. Hindmarsh. 25869 C Latest revision: November 10, 1983 (ACH) 25870 C Reference: UCID-30150 25871 C Solution of Block-Tridiagonal Systems of Linear 25872 C Algebraic Equations 25873 C A.C. Hindmarsh 25874 C February 1977 25875 C The input matrix contains three blocks of elements in each block-row, 25876 C including blocks in the (1,3) and (N,N-2) block positions. 25877 C DDECBT uses block Gauss elimination and Subroutines DGEFA and DGESL 25878 C for solution of blocks. Partial pivoting is done within 25879 C block-rows only. 25880 C 25881 C Note: this version uses LINPACK routines DGEFA/DGESL instead of 25882 C of dec/sol for solution of blocks, and it uses the BLAS routine DDOT 25883 C for dot product calculations. 25884 C 25885 C Input: 25886 C M = order of each block. 25887 C N = number of blocks in each direction of the matrix. 25888 C N must be 4 or more. The complete matrix has order M*N. 25889 C A = M by M by N array containing diagonal blocks. 25890 C A(i,j,k) contains the (i,j) element of the k-th block. 25891 C B = M by M by N array containing the super-diagonal blocks 25892 C (in B(*,*,k) for k = 1,...,N-1) and the block in the (N,N-2) 25893 C block position (in B(*,*,N)). 25894 C C = M by M by N array containing the subdiagonal blocks 25895 C (in C(*,*,k) for k = 2,3,...,N) and the block in the 25896 C (1,3) block position (in C(*,*,1)). 25897 C IP = integer array of length M*N for working storage. 25898 C Output: 25899 C A,B,C = M by M by N arrays containing the block-LU decomposition 25900 C of the input matrix. 25901 C IP = M by N array of pivot information. IP(*,k) contains 25902 C information for the k-th digonal block. 25903 C IER = 0 if no trouble occurred, or 25904 C = -1 if the input value of M or N was illegal, or 25905 C = k if a singular matrix was found in the k-th diagonal block. 25906 C Use DSOLBT to solve the associated linear system. 25907 C 25908 C External routines required: DGEFA and DGESL (from LINPACK) and 25909 C DDOT (from the BLAS, or Basic Linear Algebra package). 25910 C----------------------------------------------------------------------- 25911 INTEGER NM1, NM2, KM1, I, J, K 25912 DOUBLE PRECISION DP, DDOT 25913 IF (M .LT. 1 .OR. N .LT. 4) GO TO 210 25914 NM1 = N - 1 25915 NM2 = N - 2 25916 C Process the first block-row. ----------------------------------------- 25917 CALL DGEFA (A, M, M, IP, IER) 25918 K = 1 25919 IF (IER .NE. 0) GO TO 200 25920 DO 10 J = 1,M 25921 CALL DGESL (A, M, M, IP, B(1,J,1), 0) 25922 CALL DGESL (A, M, M, IP, C(1,J,1), 0) 25923 10 CONTINUE 25924 C Adjust B(*,*,2). ----------------------------------------------------- 25925 DO 40 J = 1,M 25926 DO 30 I = 1,M 25927 DP = DDOT (M, C(I,1,2), M, C(1,J,1), 1) 25928 B(I,J,2) = B(I,J,2) - DP 25929 30 CONTINUE 25930 40 CONTINUE 25931 C Main loop. Process block-rows 2 to N-1. ----------------------------- 25932 DO 100 K = 2,NM1 25933 KM1 = K - 1 25934 DO 70 J = 1,M 25935 DO 60 I = 1,M 25936 DP = DDOT (M, C(I,1,K), M, B(1,J,KM1), 1) 25937 A(I,J,K) = A(I,J,K) - DP 25938 60 CONTINUE 25939 70 CONTINUE 25940 CALL DGEFA (A(1,1,K), M, M, IP(1,K), IER) 25941 IF (IER .NE. 0) GO TO 200 25942 DO 80 J = 1,M 25943 80 CALL DGESL (A(1,1,K), M, M, IP(1,K), B(1,J,K), 0) 25944 100 CONTINUE 25945 C Process last block-row and return. ----------------------------------- 25946 DO 130 J = 1,M 25947 DO 120 I = 1,M 25948 DP = DDOT (M, B(I,1,N), M, B(1,J,NM2), 1) 25949 C(I,J,N) = C(I,J,N) - DP 25950 120 CONTINUE 25951 130 CONTINUE 25952 DO 160 J = 1,M 25953 DO 150 I = 1,M 25954 DP = DDOT (M, C(I,1,N), M, B(1,J,NM1), 1) 25955 A(I,J,N) = A(I,J,N) - DP 25956 150 CONTINUE 25957 160 CONTINUE 25958 CALL DGEFA (A(1,1,N), M, M, IP(1,N), IER) 25959 K = N 25960 IF (IER .NE. 0) GO TO 200 25961 RETURN 25962 C Error returns. ------------------------------------------------------- 25963 200 IER = K 25964 RETURN 25965 210 IER = -1 25966 RETURN 25967 C----------------------- End of Subroutine DDECBT ---------------------- 25968 END 25969 *DECK DSOLBT 25970 SUBROUTINE DSOLBT (M, N, A, B, C, Y, IP) 25971 INTEGER M, N, IP(M,N) 25972 DOUBLE PRECISION A(M,M,N), B(M,M,N), C(M,M,N), Y(M,N) 25973 C----------------------------------------------------------------------- 25974 C Solution of block-tridiagonal linear system. 25975 C Coefficient matrix must have been previously processed by DDECBT. 25976 C M, N, A,B,C, and IP must not have been changed since call to DDECBT. 25977 C Written by A. C. Hindmarsh. 25978 C Input: 25979 C M = order of each block. 25980 C N = number of blocks in each direction of matrix. 25981 C A,B,C = M by M by N arrays containing block LU decomposition 25982 C of coefficient matrix from DDECBT. 25983 C IP = M by N integer array of pivot information from DDECBT. 25984 C Y = array of length M*N containg the right-hand side vector 25985 C (treated as an M by N array here). 25986 C Output: 25987 C Y = solution vector, of length M*N. 25988 C 25989 C External routines required: DGESL (LINPACK) and DDOT (BLAS). 25990 C----------------------------------------------------------------------- 25991 C 25992 INTEGER NM1, NM2, I, K, KB, KM1, KP1 25993 DOUBLE PRECISION DP, DDOT 25994 NM1 = N - 1 25995 NM2 = N - 2 25996 C Forward solution sweep. ---------------------------------------------- 25997 CALL DGESL (A, M, M, IP, Y, 0) 25998 DO 30 K = 2,NM1 25999 KM1 = K - 1 26000 DO 20 I = 1,M 26001 DP = DDOT (M, C(I,1,K), M, Y(1,KM1), 1) 26002 Y(I,K) = Y(I,K) - DP 26003 20 CONTINUE 26004 CALL DGESL (A(1,1,K), M, M, IP(1,K), Y(1,K), 0) 26005 30 CONTINUE 26006 DO 50 I = 1,M 26007 DP = DDOT (M, C(I,1,N), M, Y(1,NM1), 1) 26008 1 + DDOT (M, B(I,1,N), M, Y(1,NM2), 1) 26009 Y(I,N) = Y(I,N) - DP 26010 50 CONTINUE 26011 CALL DGESL (A(1,1,N), M, M, IP(1,N), Y(1,N), 0) 26012 C Backward solution sweep. --------------------------------------------- 26013 DO 80 KB = 1,NM1 26014 K = N - KB 26015 KP1 = K + 1 26016 DO 70 I = 1,M 26017 DP = DDOT (M, B(I,1,K), M, Y(1,KP1), 1) 26018 Y(I,K) = Y(I,K) - DP 26019 70 CONTINUE 26020 80 CONTINUE 26021 DO 100 I = 1,M 26022 DP = DDOT (M, C(I,1,1), M, Y(1,3), 1) 26023 Y(I,1) = Y(I,1) - DP 26024 100 CONTINUE 26025 RETURN 26026 C----------------------- End of Subroutine DSOLBT ---------------------- 26027 END 26028 *DECK DIPREPI 26029 SUBROUTINE DIPREPI (NEQ, Y, S, RWORK, IA, JA, IC, JC, IPFLAG, 26030 1 RES, JAC, ADDA) 26031 EXTERNAL RES, JAC, ADDA 26032 INTEGER NEQ, IA, JA, IC, JC, IPFLAG 26033 DOUBLE PRECISION Y, S, RWORK 26034 DIMENSION NEQ(*), Y(*), S(*), RWORK(*), IA(*), JA(*), IC(*), JC(*) 26035 INTEGER IOWND, IOWNS, 26036 1 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 26037 2 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 26038 3 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU 26039 INTEGER IPLOST, IESP, ISTATC, IYS, IBA, IBIAN, IBJAN, IBJGP, 26040 1 IPIAN, IPJAN, IPJGP, IPIGP, IPR, IPC, IPIC, IPISP, IPRSP, IPA, 26041 2 LENYH, LENYHM, LENWK, LREQ, LRAT, LREST, LWMIN, MOSS, MSBJ, 26042 3 NSLJ, NGP, NLU, NNZ, NSP, NZL, NZU 26043 DOUBLE PRECISION ROWNS, 26044 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND 26045 DOUBLE PRECISION RLSS 26046 COMMON /DLS001/ ROWNS(209), 26047 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND, 26048 2 IOWND(6), IOWNS(6), 26049 3 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 26050 4 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 26051 5 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU 26052 COMMON /DLSS01/ RLSS(6), 26053 1 IPLOST, IESP, ISTATC, IYS, IBA, IBIAN, IBJAN, IBJGP, 26054 2 IPIAN, IPJAN, IPJGP, IPIGP, IPR, IPC, IPIC, IPISP, IPRSP, IPA, 26055 3 LENYH, LENYHM, LENWK, LREQ, LRAT, LREST, LWMIN, MOSS, MSBJ, 26056 4 NSLJ, NGP, NLU, NNZ, NSP, NZL, NZU 26057 INTEGER I, IMAX, LEWTN, LYHD, LYHN 26058 C----------------------------------------------------------------------- 26059 C This routine serves as an interface between the driver and 26060 C Subroutine DPREPI. Tasks performed here are: 26061 C * call DPREPI, 26062 C * reset the required WM segment length LENWK, 26063 C * move YH back to its final location (following WM in RWORK), 26064 C * reset pointers for YH, SAVR, EWT, and ACOR, and 26065 C * move EWT to its new position if ISTATE = 0 or 1. 26066 C IPFLAG is an output error indication flag. IPFLAG = 0 if there was 26067 C no trouble, and IPFLAG is the value of the DPREPI error flag IPPER 26068 C if there was trouble in Subroutine DPREPI. 26069 C----------------------------------------------------------------------- 26070 IPFLAG = 0 26071 C Call DPREPI to do matrix preprocessing operations. ------------------- 26072 CALL DPREPI (NEQ, Y, S, RWORK(LYH), RWORK(LSAVF), RWORK(LEWT), 26073 1 RWORK(LACOR), IA, JA, IC, JC, RWORK(LWM), RWORK(LWM), IPFLAG, 26074 2 RES, JAC, ADDA) 26075 LENWK = MAX(LREQ,LWMIN) 26076 IF (IPFLAG .LT. 0) RETURN 26077 C If DPREPI was successful, move YH to end of required space for WM. --- 26078 LYHN = LWM + LENWK 26079 IF (LYHN .GT. LYH) RETURN 26080 LYHD = LYH - LYHN 26081 IF (LYHD .EQ. 0) GO TO 20 26082 IMAX = LYHN - 1 + LENYHM 26083 DO 10 I=LYHN,IMAX 26084 10 RWORK(I) = RWORK(I+LYHD) 26085 LYH = LYHN 26086 C Reset pointers for SAVR, EWT, and ACOR. ------------------------------ 26087 20 LSAVF = LYH + LENYH 26088 LEWTN = LSAVF + N 26089 LACOR = LEWTN + N 26090 IF (ISTATC .EQ. 3) GO TO 40 26091 C If ISTATE = 1, move EWT (left) to its new position. ------------------ 26092 IF (LEWTN .GT. LEWT) RETURN 26093 DO 30 I=1,N 26094 30 RWORK(I+LEWTN-1) = RWORK(I+LEWT-1) 26095 40 LEWT = LEWTN 26096 RETURN 26097 C----------------------- End of Subroutine DIPREPI --------------------- 26098 END 26099 *DECK DPREPI 26100 SUBROUTINE DPREPI (NEQ, Y, S, YH, SAVR, EWT, RTEM, IA, JA, IC, JC, 26101 1 WK, IWK, IPPER, RES, JAC, ADDA) 26102 EXTERNAL RES, JAC, ADDA 26103 INTEGER NEQ, IA, JA, IC, JC, IWK, IPPER 26104 DOUBLE PRECISION Y, S, YH, SAVR, EWT, RTEM, WK 26105 DIMENSION NEQ(*), Y(*), S(*), YH(*), SAVR(*), EWT(*), RTEM(*), 26106 1 IA(*), JA(*), IC(*), JC(*), WK(*), IWK(*) 26107 INTEGER IOWND, IOWNS, 26108 1 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 26109 2 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 26110 3 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU 26111 INTEGER IPLOST, IESP, ISTATC, IYS, IBA, IBIAN, IBJAN, IBJGP, 26112 1 IPIAN, IPJAN, IPJGP, IPIGP, IPR, IPC, IPIC, IPISP, IPRSP, IPA, 26113 2 LENYH, LENYHM, LENWK, LREQ, LRAT, LREST, LWMIN, MOSS, MSBJ, 26114 3 NSLJ, NGP, NLU, NNZ, NSP, NZL, NZU 26115 DOUBLE PRECISION ROWNS, 26116 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND 26117 DOUBLE PRECISION RLSS 26118 COMMON /DLS001/ ROWNS(209), 26119 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND, 26120 2 IOWND(6), IOWNS(6), 26121 3 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 26122 4 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 26123 5 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU 26124 COMMON /DLSS01/ RLSS(6), 26125 1 IPLOST, IESP, ISTATC, IYS, IBA, IBIAN, IBJAN, IBJGP, 26126 2 IPIAN, IPJAN, IPJGP, IPIGP, IPR, IPC, IPIC, IPISP, IPRSP, IPA, 26127 3 LENYH, LENYHM, LENWK, LREQ, LRAT, LREST, LWMIN, MOSS, MSBJ, 26128 4 NSLJ, NGP, NLU, NNZ, NSP, NZL, NZU 26129 INTEGER I, IBR, IER, IPIL, IPIU, IPTT1, IPTT2, J, K, KNEW, KAMAX, 26130 1 KAMIN, KCMAX, KCMIN, LDIF, LENIGP, LENWK1, LIWK, LJFO, MAXG, 26131 2 NP1, NZSUT 26132 DOUBLE PRECISION ERWT, FAC, YJ 26133 C----------------------------------------------------------------------- 26134 C This routine performs preprocessing related to the sparse linear 26135 C systems that must be solved. 26136 C The operations that are performed here are: 26137 C * compute sparseness structure of the iteration matrix 26138 C P = A - con*J according to MOSS, 26139 C * compute grouping of column indices (MITER = 2), 26140 C * compute a new ordering of rows and columns of the matrix, 26141 C * reorder JA corresponding to the new ordering, 26142 C * perform a symbolic LU factorization of the matrix, and 26143 C * set pointers for segments of the IWK/WK array. 26144 C In addition to variables described previously, DPREPI uses the 26145 C following for communication: 26146 C YH = the history array. Only the first column, containing the 26147 C current Y vector, is used. Used only if MOSS .ne. 0. 26148 C S = array of length NEQ, identical to YDOTI in the driver, used 26149 C only if MOSS .ne. 0. 26150 C SAVR = a work array of length NEQ, used only if MOSS .ne. 0. 26151 C EWT = array of length NEQ containing (inverted) error weights. 26152 C Used only if MOSS = 2 or 4 or if ISTATE = MOSS = 1. 26153 C RTEM = a work array of length NEQ, identical to ACOR in the driver, 26154 C used only if MOSS = 2 or 4. 26155 C WK = a real work array of length LENWK, identical to WM in 26156 C the driver. 26157 C IWK = integer work array, assumed to occupy the same space as WK. 26158 C LENWK = the length of the work arrays WK and IWK. 26159 C ISTATC = a copy of the driver input argument ISTATE (= 1 on the 26160 C first call, = 3 on a continuation call). 26161 C IYS = flag value from ODRV or CDRV. 26162 C IPPER = output error flag , with the following values and meanings: 26163 C = 0 no error. 26164 C = -1 insufficient storage for internal structure pointers. 26165 C = -2 insufficient storage for JGROUP. 26166 C = -3 insufficient storage for ODRV. 26167 C = -4 other error flag from ODRV (should never occur). 26168 C = -5 insufficient storage for CDRV. 26169 C = -6 other error flag from CDRV. 26170 C = -7 if the RES routine returned error flag IRES = IER = 2. 26171 C = -8 if the RES routine returned error flag IRES = IER = 3. 26172 C----------------------------------------------------------------------- 26173 IBIAN = LRAT*2 26174 IPIAN = IBIAN + 1 26175 NP1 = N + 1 26176 IPJAN = IPIAN + NP1 26177 IBJAN = IPJAN - 1 26178 LENWK1 = LENWK - N 26179 LIWK = LENWK*LRAT 26180 IF (MOSS .EQ. 0) LIWK = LIWK - N 26181 IF (MOSS .EQ. 1 .OR. MOSS .EQ. 2) LIWK = LENWK1*LRAT 26182 IF (IPJAN+N-1 .GT. LIWK) GO TO 310 26183 IF (MOSS .EQ. 0) GO TO 30 26184 C 26185 IF (ISTATC .EQ. 3) GO TO 20 26186 C ISTATE = 1 and MOSS .ne. 0. Perturb Y for structure determination. 26187 C Initialize S with random nonzero elements for structure determination. 26188 DO 10 I=1,N 26189 ERWT = 1.0D0/EWT(I) 26190 FAC = 1.0D0 + 1.0D0/(I + 1.0D0) 26191 Y(I) = Y(I) + FAC*SIGN(ERWT,Y(I)) 26192 S(I) = 1.0D0 + FAC*ERWT 26193 10 CONTINUE 26194 GO TO (70, 100, 150, 200), MOSS 26195 C 26196 20 CONTINUE 26197 C ISTATE = 3 and MOSS .ne. 0. Load Y from YH(*,1) and S from YH(*,2). -- 26198 DO 25 I = 1,N 26199 Y(I) = YH(I) 26200 25 S(I) = YH(N+I) 26201 GO TO (70, 100, 150, 200), MOSS 26202 C 26203 C MOSS = 0. Process user's IA,JA and IC,JC. ---------------------------- 26204 30 KNEW = IPJAN 26205 KAMIN = IA(1) 26206 KCMIN = IC(1) 26207 IWK(IPIAN) = 1 26208 DO 60 J = 1,N 26209 DO 35 I = 1,N 26210 35 IWK(LIWK+I) = 0 26211 KAMAX = IA(J+1) - 1 26212 IF (KAMIN .GT. KAMAX) GO TO 45 26213 DO 40 K = KAMIN,KAMAX 26214 I = JA(K) 26215 IWK(LIWK+I) = 1 26216 IF (KNEW .GT. LIWK) GO TO 310 26217 IWK(KNEW) = I 26218 KNEW = KNEW + 1 26219 40 CONTINUE 26220 45 KAMIN = KAMAX + 1 26221 KCMAX = IC(J+1) - 1 26222 IF (KCMIN .GT. KCMAX) GO TO 55 26223 DO 50 K = KCMIN,KCMAX 26224 I = JC(K) 26225 IF (IWK(LIWK+I) .NE. 0) GO TO 50 26226 IF (KNEW .GT. LIWK) GO TO 310 26227 IWK(KNEW) = I 26228 KNEW = KNEW + 1 26229 50 CONTINUE 26230 55 IWK(IPIAN+J) = KNEW + 1 - IPJAN 26231 KCMIN = KCMAX + 1 26232 60 CONTINUE 26233 GO TO 240 26234 C 26235 C MOSS = 1. Compute structure from user-supplied Jacobian routine JAC. - 26236 70 CONTINUE 26237 C A dummy call to RES allows user to create temporaries for use in JAC. 26238 IER = 1 26239 CALL RES (NEQ, TN, Y, S, SAVR, IER) 26240 IF (IER .GT. 1) GO TO 370 26241 DO 75 I = 1,N 26242 SAVR(I) = 0.0D0 26243 75 WK(LENWK1+I) = 0.0D0 26244 K = IPJAN 26245 IWK(IPIAN) = 1 26246 DO 95 J = 1,N 26247 CALL ADDA (NEQ, TN, Y, J, IWK(IPIAN), IWK(IPJAN), WK(LENWK1+1)) 26248 CALL JAC (NEQ, TN, Y, S, J, IWK(IPIAN), IWK(IPJAN), SAVR) 26249 DO 90 I = 1,N 26250 LJFO = LENWK1 + I 26251 IF (WK(LJFO) .EQ. 0.0D0) GO TO 80 26252 WK(LJFO) = 0.0D0 26253 SAVR(I) = 0.0D0 26254 GO TO 85 26255 80 IF (SAVR(I) .EQ. 0.0D0) GO TO 90 26256 SAVR(I) = 0.0D0 26257 85 IF (K .GT. LIWK) GO TO 310 26258 IWK(K) = I 26259 K = K+1 26260 90 CONTINUE 26261 IWK(IPIAN+J) = K + 1 - IPJAN 26262 95 CONTINUE 26263 GO TO 240 26264 C 26265 C MOSS = 2. Compute structure from results of N + 1 calls to RES. ------ 26266 100 DO 105 I = 1,N 26267 105 WK(LENWK1+I) = 0.0D0 26268 K = IPJAN 26269 IWK(IPIAN) = 1 26270 IER = -1 26271 IF (MITER .EQ. 1) IER = 1 26272 CALL RES (NEQ, TN, Y, S, SAVR, IER) 26273 IF (IER .GT. 1) GO TO 370 26274 DO 130 J = 1,N 26275 CALL ADDA (NEQ, TN, Y, J, IWK(IPIAN), IWK(IPJAN), WK(LENWK1+1)) 26276 YJ = Y(J) 26277 ERWT = 1.0D0/EWT(J) 26278 Y(J) = YJ + SIGN(ERWT,YJ) 26279 CALL RES (NEQ, TN, Y, S, RTEM, IER) 26280 IF (IER .GT. 1) RETURN 26281 Y(J) = YJ 26282 DO 120 I = 1,N 26283 LJFO = LENWK1 + I 26284 IF (WK(LJFO) .EQ. 0.0D0) GO TO 110 26285 WK(LJFO) = 0.0D0 26286 GO TO 115 26287 110 IF (RTEM(I) .EQ. SAVR(I)) GO TO 120 26288 115 IF (K .GT. LIWK) GO TO 310 26289 IWK(K) = I 26290 K = K + 1 26291 120 CONTINUE 26292 IWK(IPIAN+J) = K + 1 - IPJAN 26293 130 CONTINUE 26294 GO TO 240 26295 C 26296 C MOSS = 3. Compute structure from the user's IA/JA and JAC routine. --- 26297 150 CONTINUE 26298 C A dummy call to RES allows user to create temporaries for use in JAC. 26299 IER = 1 26300 CALL RES (NEQ, TN, Y, S, SAVR, IER) 26301 IF (IER .GT. 1) GO TO 370 26302 DO 155 I = 1,N 26303 155 SAVR(I) = 0.0D0 26304 KNEW = IPJAN 26305 KAMIN = IA(1) 26306 IWK(IPIAN) = 1 26307 DO 190 J = 1,N 26308 CALL JAC (NEQ, TN, Y, S, J, IWK(IPIAN), IWK(IPJAN), SAVR) 26309 KAMAX = IA(J+1) - 1 26310 IF (KAMIN .GT. KAMAX) GO TO 170 26311 DO 160 K = KAMIN,KAMAX 26312 I = JA(K) 26313 SAVR(I) = 0.0D0 26314 IF (KNEW .GT. LIWK) GO TO 310 26315 IWK(KNEW) = I 26316 KNEW = KNEW + 1 26317 160 CONTINUE 26318 170 KAMIN = KAMAX + 1 26319 DO 180 I = 1,N 26320 IF (SAVR(I) .EQ. 0.0D0) GO TO 180 26321 SAVR(I) = 0.0D0 26322 IF (KNEW .GT. LIWK) GO TO 310 26323 IWK(KNEW) = I 26324 KNEW = KNEW + 1 26325 180 CONTINUE 26326 IWK(IPIAN+J) = KNEW + 1 - IPJAN 26327 190 CONTINUE 26328 GO TO 240 26329 C 26330 C MOSS = 4. Compute structure from user's IA/JA and N + 1 RES calls. --- 26331 200 KNEW = IPJAN 26332 KAMIN = IA(1) 26333 IWK(IPIAN) = 1 26334 IER = -1 26335 IF (MITER .EQ. 1) IER = 1 26336 CALL RES (NEQ, TN, Y, S, SAVR, IER) 26337 IF (IER .GT. 1) GO TO 370 26338 DO 235 J = 1,N 26339 YJ = Y(J) 26340 ERWT = 1.0D0/EWT(J) 26341 Y(J) = YJ + SIGN(ERWT,YJ) 26342 CALL RES (NEQ, TN, Y, S, RTEM, IER) 26343 IF (IER .GT. 1) RETURN 26344 Y(J) = YJ 26345 KAMAX = IA(J+1) - 1 26346 IF (KAMIN .GT. KAMAX) GO TO 225 26347 DO 220 K = KAMIN,KAMAX 26348 I = JA(K) 26349 RTEM(I) = SAVR(I) 26350 IF (KNEW .GT. LIWK) GO TO 310 26351 IWK(KNEW) = I 26352 KNEW = KNEW + 1 26353 220 CONTINUE 26354 225 KAMIN = KAMAX + 1 26355 DO 230 I = 1,N 26356 IF (RTEM(I) .EQ. SAVR(I)) GO TO 230 26357 IF (KNEW .GT. LIWK) GO TO 310 26358 IWK(KNEW) = I 26359 KNEW = KNEW + 1 26360 230 CONTINUE 26361 IWK(IPIAN+J) = KNEW + 1 - IPJAN 26362 235 CONTINUE 26363 C 26364 240 CONTINUE 26365 IF (MOSS .EQ. 0 .OR. ISTATC .EQ. 3) GO TO 250 26366 C If ISTATE = 0 or 1 and MOSS .ne. 0, restore Y from YH. --------------- 26367 DO 245 I = 1,N 26368 245 Y(I) = YH(I) 26369 250 NNZ = IWK(IPIAN+N) - 1 26370 IPPER = 0 26371 NGP = 0 26372 LENIGP = 0 26373 IPIGP = IPJAN + NNZ 26374 IF (MITER .NE. 2) GO TO 260 26375 C 26376 C Compute grouping of column indices (MITER = 2). ---------------------- 26377 C 26378 MAXG = NP1 26379 IPJGP = IPJAN + NNZ 26380 IBJGP = IPJGP - 1 26381 IPIGP = IPJGP + N 26382 IPTT1 = IPIGP + NP1 26383 IPTT2 = IPTT1 + N 26384 LREQ = IPTT2 + N - 1 26385 IF (LREQ .GT. LIWK) GO TO 320 26386 CALL JGROUP (N, IWK(IPIAN), IWK(IPJAN), MAXG, NGP, IWK(IPIGP), 26387 1 IWK(IPJGP), IWK(IPTT1), IWK(IPTT2), IER) 26388 IF (IER .NE. 0) GO TO 320 26389 LENIGP = NGP + 1 26390 C 26391 C Compute new ordering of rows/columns of Jacobian. -------------------- 26392 260 IPR = IPIGP + LENIGP 26393 IPC = IPR 26394 IPIC = IPC + N 26395 IPISP = IPIC + N 26396 IPRSP = (IPISP-2)/LRAT + 2 26397 IESP = LENWK + 1 - IPRSP 26398 IF (IESP .LT. 0) GO TO 330 26399 IBR = IPR - 1 26400 DO 270 I = 1,N 26401 270 IWK(IBR+I) = I 26402 NSP = LIWK + 1 - IPISP 26403 CALL ODRV(N, IWK(IPIAN), IWK(IPJAN), WK, IWK(IPR), IWK(IPIC), NSP, 26404 1 IWK(IPISP), 1, IYS) 26405 IF (IYS .EQ. 11*N+1) GO TO 340 26406 IF (IYS .NE. 0) GO TO 330 26407 C 26408 C Reorder JAN and do symbolic LU factorization of matrix. -------------- 26409 IPA = LENWK + 1 - NNZ 26410 NSP = IPA - IPRSP 26411 LREQ = MAX(12*N/LRAT, 6*N/LRAT+2*N+NNZ) + 3 26412 LREQ = LREQ + IPRSP - 1 + NNZ 26413 IF (LREQ .GT. LENWK) GO TO 350 26414 IBA = IPA - 1 26415 DO 280 I = 1,NNZ 26416 280 WK(IBA+I) = 0.0D0 26417 IPISP = LRAT*(IPRSP - 1) + 1 26418 CALL CDRV(N,IWK(IPR),IWK(IPC),IWK(IPIC),IWK(IPIAN),IWK(IPJAN), 26419 1 WK(IPA),WK(IPA),WK(IPA),NSP,IWK(IPISP),WK(IPRSP),IESP,5,IYS) 26420 LREQ = LENWK - IESP 26421 IF (IYS .EQ. 10*N+1) GO TO 350 26422 IF (IYS .NE. 0) GO TO 360 26423 IPIL = IPISP 26424 IPIU = IPIL + 2*N + 1 26425 NZU = IWK(IPIL+N) - IWK(IPIL) 26426 NZL = IWK(IPIU+N) - IWK(IPIU) 26427 IF (LRAT .GT. 1) GO TO 290 26428 CALL ADJLR (N, IWK(IPISP), LDIF) 26429 LREQ = LREQ + LDIF 26430 290 CONTINUE 26431 IF (LRAT .EQ. 2 .AND. NNZ .EQ. N) LREQ = LREQ + 1 26432 NSP = NSP + LREQ - LENWK 26433 IPA = LREQ + 1 - NNZ 26434 IBA = IPA - 1 26435 IPPER = 0 26436 RETURN 26437 C 26438 310 IPPER = -1 26439 LREQ = 2 + (2*N + 1)/LRAT 26440 LREQ = MAX(LENWK+1,LREQ) 26441 RETURN 26442 C 26443 320 IPPER = -2 26444 LREQ = (LREQ - 1)/LRAT + 1 26445 RETURN 26446 C 26447 330 IPPER = -3 26448 CALL CNTNZU (N, IWK(IPIAN), IWK(IPJAN), NZSUT) 26449 LREQ = LENWK - IESP + (3*N + 4*NZSUT - 1)/LRAT + 1 26450 RETURN 26451 C 26452 340 IPPER = -4 26453 RETURN 26454 C 26455 350 IPPER = -5 26456 RETURN 26457 C 26458 360 IPPER = -6 26459 LREQ = LENWK 26460 RETURN 26461 C 26462 370 IPPER = -IER - 5 26463 LREQ = 2 + (2*N + 1)/LRAT 26464 RETURN 26465 C----------------------- End of Subroutine DPREPI ---------------------- 26466 END 26467 *DECK DAINVGS 26468 SUBROUTINE DAINVGS (NEQ, T, Y, WK, IWK, TEM, YDOT, IER, RES, ADDA) 26469 EXTERNAL RES, ADDA 26470 INTEGER NEQ, IWK, IER 26471 INTEGER IPLOST, IESP, ISTATC, IYS, IBA, IBIAN, IBJAN, IBJGP, 26472 1 IPIAN, IPJAN, IPJGP, IPIGP, IPR, IPC, IPIC, IPISP, IPRSP, IPA, 26473 2 LENYH, LENYHM, LENWK, LREQ, LRAT, LREST, LWMIN, MOSS, MSBJ, 26474 3 NSLJ, NGP, NLU, NNZ, NSP, NZL, NZU 26475 INTEGER I, IMUL, J, K, KMIN, KMAX 26476 DOUBLE PRECISION T, Y, WK, TEM, YDOT 26477 DOUBLE PRECISION RLSS 26478 DIMENSION Y(*), WK(*), IWK(*), TEM(*), YDOT(*) 26479 COMMON /DLSS01/ RLSS(6), 26480 1 IPLOST, IESP, ISTATC, IYS, IBA, IBIAN, IBJAN, IBJGP, 26481 2 IPIAN, IPJAN, IPJGP, IPIGP, IPR, IPC, IPIC, IPISP, IPRSP, IPA, 26482 3 LENYH, LENYHM, LENWK, LREQ, LRAT, LREST, LWMIN, MOSS, MSBJ, 26483 4 NSLJ, NGP, NLU, NNZ, NSP, NZL, NZU 26484 C----------------------------------------------------------------------- 26485 C This subroutine computes the initial value of the vector YDOT 26486 C satisfying 26487 C A * YDOT = g(t,y) 26488 C when A is nonsingular. It is called by DLSODIS for initialization 26489 C only, when ISTATE = 0. The matrix A is subjected to LU 26490 C decomposition in CDRV. Then the system A*YDOT = g(t,y) is solved 26491 C in CDRV. 26492 C In addition to variables described previously, communication 26493 C with DAINVGS uses the following: 26494 C Y = array of initial values. 26495 C WK = real work space for matrices. On output it contains A and 26496 C its LU decomposition. The LU decomposition is not entirely 26497 C sparse unless the structure of the matrix A is identical to 26498 C the structure of the Jacobian matrix dr/dy. 26499 C Storage of matrix elements starts at WK(3). 26500 C WK(1) = SQRT(UROUND), not used here. 26501 C IWK = integer work space for matrix-related data, assumed to 26502 C be equivalenced to WK. In addition, WK(IPRSP) and WK(IPISP) 26503 C are assumed to have identical locations. 26504 C TEM = vector of work space of length N (ACOR in DSTODI). 26505 C YDOT = output vector containing the initial dy/dt. YDOT(i) contains 26506 C dy(i)/dt when the matrix A is non-singular. 26507 C IER = output error flag with the following values and meanings: 26508 C = 0 if DAINVGS was successful. 26509 C = 1 if the A-matrix was found to be singular. 26510 C = 2 if RES returned an error flag IRES = IER = 2. 26511 C = 3 if RES returned an error flag IRES = IER = 3. 26512 C = 4 if insufficient storage for CDRV (should not occur here). 26513 C = 5 if other error found in CDRV (should not occur here). 26514 C----------------------------------------------------------------------- 26515 C 26516 DO 10 I = 1,NNZ 26517 10 WK(IBA+I) = 0.0D0 26518 C 26519 IER = 1 26520 CALL RES (NEQ, T, Y, WK(IPA), YDOT, IER) 26521 IF (IER .GT. 1) RETURN 26522 C 26523 KMIN = IWK(IPIAN) 26524 DO 30 J = 1,NEQ 26525 KMAX = IWK(IPIAN+J) - 1 26526 DO 15 K = KMIN,KMAX 26527 I = IWK(IBJAN+K) 26528 15 TEM(I) = 0.0D0 26529 CALL ADDA (NEQ, T, Y, J, IWK(IPIAN), IWK(IPJAN), TEM) 26530 DO 20 K = KMIN,KMAX 26531 I = IWK(IBJAN+K) 26532 20 WK(IBA+K) = TEM(I) 26533 KMIN = KMAX + 1 26534 30 CONTINUE 26535 NLU = NLU + 1 26536 IER = 0 26537 DO 40 I = 1,NEQ 26538 40 TEM(I) = 0.0D0 26539 C 26540 C Numerical factorization of matrix A. --------------------------------- 26541 CALL CDRV (NEQ,IWK(IPR),IWK(IPC),IWK(IPIC),IWK(IPIAN),IWK(IPJAN), 26542 1 WK(IPA),TEM,TEM,NSP,IWK(IPISP),WK(IPRSP),IESP,2,IYS) 26543 IF (IYS .EQ. 0) GO TO 50 26544 IMUL = (IYS - 1)/NEQ 26545 IER = 5 26546 IF (IMUL .EQ. 8) IER = 1 26547 IF (IMUL .EQ. 10) IER = 4 26548 RETURN 26549 C 26550 C Solution of the linear system. --------------------------------------- 26551 50 CALL CDRV (NEQ,IWK(IPR),IWK(IPC),IWK(IPIC),IWK(IPIAN),IWK(IPJAN), 26552 1 WK(IPA),YDOT,YDOT,NSP,IWK(IPISP),WK(IPRSP),IESP,4,IYS) 26553 IF (IYS .NE. 0) IER = 5 26554 RETURN 26555 C----------------------- End of Subroutine DAINVGS --------------------- 26556 END 26557 *DECK DPRJIS 26558 SUBROUTINE DPRJIS (NEQ, Y, YH, NYH, EWT, RTEM, SAVR, S, WK, IWK, 26559 1 RES, JAC, ADDA) 26560 EXTERNAL RES, JAC, ADDA 26561 INTEGER NEQ, NYH, IWK 26562 DOUBLE PRECISION Y, YH, EWT, RTEM, SAVR, S, WK 26563 DIMENSION NEQ(*), Y(*), YH(NYH,*), EWT(*), RTEM(*), 26564 1 S(*), SAVR(*), WK(*), IWK(*) 26565 INTEGER IOWND, IOWNS, 26566 1 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 26567 2 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 26568 3 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU 26569 INTEGER IPLOST, IESP, ISTATC, IYS, IBA, IBIAN, IBJAN, IBJGP, 26570 1 IPIAN, IPJAN, IPJGP, IPIGP, IPR, IPC, IPIC, IPISP, IPRSP, IPA, 26571 2 LENYH, LENYHM, LENWK, LREQ, LRAT, LREST, LWMIN, MOSS, MSBJ, 26572 3 NSLJ, NGP, NLU, NNZ, NSP, NZL, NZU 26573 DOUBLE PRECISION ROWNS, 26574 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND 26575 DOUBLE PRECISION RLSS 26576 COMMON /DLS001/ ROWNS(209), 26577 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND, 26578 2 IOWND(6), IOWNS(6), 26579 3 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 26580 4 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 26581 5 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU 26582 COMMON /DLSS01/ RLSS(6), 26583 1 IPLOST, IESP, ISTATC, IYS, IBA, IBIAN, IBJAN, IBJGP, 26584 2 IPIAN, IPJAN, IPJGP, IPIGP, IPR, IPC, IPIC, IPISP, IPRSP, IPA, 26585 3 LENYH, LENYHM, LENWK, LREQ, LRAT, LREST, LWMIN, MOSS, MSBJ, 26586 4 NSLJ, NGP, NLU, NNZ, NSP, NZL, NZU 26587 INTEGER I, IMUL, IRES, J, JJ, JMAX, JMIN, K, KMAX, KMIN, NG 26588 DOUBLE PRECISION CON, FAC, HL0, R, SRUR 26589 C----------------------------------------------------------------------- 26590 C DPRJIS is called to compute and process the matrix 26591 C P = A - H*EL(1)*J, where J is an approximation to the Jacobian dr/dy, 26592 C where r = g(t,y) - A(t,y)*s. J is computed by columns, either by 26593 C the user-supplied routine JAC if MITER = 1, or by finite differencing 26594 C if MITER = 2. J is stored in WK, rescaled, and ADDA is called to 26595 C generate P. The matrix P is subjected to LU decomposition in CDRV. 26596 C P and its LU decomposition are stored separately in WK. 26597 C 26598 C In addition to variables described previously, communication 26599 C with DPRJIS uses the following: 26600 C Y = array containing predicted values on entry. 26601 C RTEM = work array of length N (ACOR in DSTODI). 26602 C SAVR = array containing r evaluated at predicted y. On output it 26603 C contains the residual evaluated at current values of t and y. 26604 C S = array containing predicted values of dy/dt (SAVF in DSTODI). 26605 C WK = real work space for matrices. On output it contains P and 26606 C its sparse LU decomposition. Storage of matrix elements 26607 C starts at WK(3). 26608 C WK also contains the following matrix-related data. 26609 C WK(1) = SQRT(UROUND), used in numerical Jacobian increments. 26610 C IWK = integer work space for matrix-related data, assumed to be 26611 C equivalenced to WK. In addition, WK(IPRSP) and IWK(IPISP) 26612 C are assumed to have identical locations. 26613 C EL0 = EL(1) (input). 26614 C IERPJ = output error flag (in COMMON). 26615 C = 0 if no error. 26616 C = 1 if zero pivot found in CDRV. 26617 C = IRES (= 2 or 3) if RES returned IRES = 2 or 3. 26618 C = -1 if insufficient storage for CDRV (should not occur). 26619 C = -2 if other error found in CDRV (should not occur here). 26620 C JCUR = output flag = 1 to indicate that the Jacobian matrix 26621 C (or approximation) is now current. 26622 C This routine also uses other variables in Common. 26623 C----------------------------------------------------------------------- 26624 HL0 = H*EL0 26625 CON = -HL0 26626 JCUR = 1 26627 NJE = NJE + 1 26628 GO TO (100, 200), MITER 26629 C 26630 C If MITER = 1, call RES, then call JAC and ADDA for each column. ------ 26631 100 IRES = 1 26632 CALL RES (NEQ, TN, Y, S, SAVR, IRES) 26633 NFE = NFE + 1 26634 IF (IRES .GT. 1) GO TO 600 26635 KMIN = IWK(IPIAN) 26636 DO 130 J = 1,N 26637 KMAX = IWK(IPIAN+J)-1 26638 DO 110 I = 1,N 26639 110 RTEM(I) = 0.0D0 26640 CALL JAC (NEQ, TN, Y, S, J, IWK(IPIAN), IWK(IPJAN), RTEM) 26641 DO 120 I = 1,N 26642 120 RTEM(I) = RTEM(I)*CON 26643 CALL ADDA (NEQ, TN, Y, J, IWK(IPIAN), IWK(IPJAN), RTEM) 26644 DO 125 K = KMIN,KMAX 26645 I = IWK(IBJAN+K) 26646 WK(IBA+K) = RTEM(I) 26647 125 CONTINUE 26648 KMIN = KMAX + 1 26649 130 CONTINUE 26650 GO TO 290 26651 C 26652 C If MITER = 2, make NGP + 1 calls to RES to approximate J and P. ------ 26653 200 CONTINUE 26654 IRES = -1 26655 CALL RES (NEQ, TN, Y, S, SAVR, IRES) 26656 NFE = NFE + 1 26657 IF (IRES .GT. 1) GO TO 600 26658 SRUR = WK(1) 26659 JMIN = IWK(IPIGP) 26660 DO 240 NG = 1,NGP 26661 JMAX = IWK(IPIGP+NG) - 1 26662 DO 210 J = JMIN,JMAX 26663 JJ = IWK(IBJGP+J) 26664 R = MAX(SRUR*ABS(Y(JJ)),0.01D0/EWT(JJ)) 26665 210 Y(JJ) = Y(JJ) + R 26666 CALL RES (NEQ,TN,Y,S,RTEM,IRES) 26667 NFE = NFE + 1 26668 IF (IRES .GT. 1) GO TO 600 26669 DO 230 J = JMIN,JMAX 26670 JJ = IWK(IBJGP+J) 26671 Y(JJ) = YH(JJ,1) 26672 R = MAX(SRUR*ABS(Y(JJ)),0.01D0/EWT(JJ)) 26673 FAC = -HL0/R 26674 KMIN = IWK(IBIAN+JJ) 26675 KMAX = IWK(IBIAN+JJ+1) - 1 26676 DO 220 K = KMIN,KMAX 26677 I = IWK(IBJAN+K) 26678 RTEM(I) = (RTEM(I) - SAVR(I))*FAC 26679 220 CONTINUE 26680 CALL ADDA (NEQ, TN, Y, JJ, IWK(IPIAN), IWK(IPJAN), RTEM) 26681 DO 225 K = KMIN,KMAX 26682 I = IWK(IBJAN+K) 26683 WK(IBA+K) = RTEM(I) 26684 225 CONTINUE 26685 230 CONTINUE 26686 JMIN = JMAX + 1 26687 240 CONTINUE 26688 IRES = 1 26689 CALL RES (NEQ, TN, Y, S, SAVR, IRES) 26690 NFE = NFE + 1 26691 IF (IRES .GT. 1) GO TO 600 26692 C 26693 C Do numerical factorization of P matrix. ------------------------------ 26694 290 NLU = NLU + 1 26695 IERPJ = 0 26696 DO 295 I = 1,N 26697 295 RTEM(I) = 0.0D0 26698 CALL CDRV (N,IWK(IPR),IWK(IPC),IWK(IPIC),IWK(IPIAN),IWK(IPJAN), 26699 1 WK(IPA),RTEM,RTEM,NSP,IWK(IPISP),WK(IPRSP),IESP,2,IYS) 26700 IF (IYS .EQ. 0) RETURN 26701 IMUL = (IYS - 1)/N 26702 IERPJ = -2 26703 IF (IMUL .EQ. 8) IERPJ = 1 26704 IF (IMUL .EQ. 10) IERPJ = -1 26705 RETURN 26706 C Error return for IRES = 2 or IRES = 3 return from RES. --------------- 26707 600 IERPJ = IRES 26708 RETURN 26709 C----------------------- End of Subroutine DPRJIS ---------------------- 26710 END 26711 26712 26713 *DECK DGEFA 26714 SUBROUTINE DGEFA (A, LDA, N, IPVT, INFO) 26715 C***BEGIN PROLOGUE DGEFA 26716 C***PURPOSE Factor a matrix using Gaussian elimination. 26717 C***CATEGORY D2A1 26718 C***TYPE DOUBLE PRECISION (SGEFA-S, DGEFA-D, CGEFA-C) 26719 C***KEYWORDS GENERAL MATRIX, LINEAR ALGEBRA, LINPACK, 26720 C MATRIX FACTORIZATION 26721 C***AUTHOR Moler, C. B., (U. of New Mexico) 26722 C***DESCRIPTION 26723 C 26724 C DGEFA factors a double precision matrix by Gaussian elimination. 26725 C 26726 C DGEFA is usually called by DGECO, but it can be called 26727 C directly with a saving in time if RCOND is not needed. 26728 C (Time for DGECO) = (1 + 9/N)*(Time for DGEFA) . 26729 C 26730 C On Entry 26731 C 26732 C A DOUBLE PRECISION(LDA, N) 26733 C the matrix to be factored. 26734 C 26735 C LDA INTEGER 26736 C the leading dimension of the array A . 26737 C 26738 C N INTEGER 26739 C the order of the matrix A . 26740 C 26741 C On Return 26742 C 26743 C A an upper triangular matrix and the multipliers 26744 C which were used to obtain it. 26745 C The factorization can be written A = L*U where 26746 C L is a product of permutation and unit lower 26747 C triangular matrices and U is upper triangular. 26748 C 26749 C IPVT INTEGER(N) 26750 C an integer vector of pivot indices. 26751 C 26752 C INFO INTEGER 26753 C = 0 normal value. 26754 C = K if U(K,K) .EQ. 0.0 . This is not an error 26755 C condition for this subroutine, but it does 26756 C indicate that DGESL or DGEDI will divide by zero 26757 C if called. Use RCOND in DGECO for a reliable 26758 C indication of singularity. 26759 C 26760 C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. 26761 C Stewart, LINPACK Users' Guide, SIAM, 1979. 26762 C***ROUTINES CALLED DAXPY, DSCAL, IDAMAX 26763 C***REVISION HISTORY (YYMMDD) 26764 C 780814 DATE WRITTEN 26765 C 890831 Modified array declarations. (WRB) 26766 C 890831 REVISION DATE from Version 3.2 26767 C 891214 Prologue converted to Version 4.0 format. (BAB) 26768 C 900326 Removed duplicate information from DESCRIPTION section. 26769 C (WRB) 26770 C 920501 Reformatted the REFERENCES section. (WRB) 26771 C***END PROLOGUE DGEFA 26772 INTEGER LDA,N,IPVT(*),INFO 26773 DOUBLE PRECISION A(LDA,*) 26774 C 26775 DOUBLE PRECISION T 26776 INTEGER IDAMAX,J,K,KP1,L,NM1 26777 C 26778 C GAUSSIAN ELIMINATION WITH PARTIAL PIVOTING 26779 C 26780 C***FIRST EXECUTABLE STATEMENT DGEFA 26781 INFO = 0 26782 NM1 = N - 1 26783 IF (NM1 .LT. 1) GO TO 70 26784 DO 60 K = 1, NM1 26785 KP1 = K + 1 26786 C 26787 C FIND L = PIVOT INDEX 26788 C 26789 L = IDAMAX(N-K+1,A(K,K),1) + K - 1 26790 IPVT(K) = L 26791 C 26792 C ZERO PIVOT IMPLIES THIS COLUMN ALREADY TRIANGULARIZED 26793 C 26794 IF (A(L,K) .EQ. 0.0D0) GO TO 40 26795 C 26796 C INTERCHANGE IF NECESSARY 26797 C 26798 IF (L .EQ. K) GO TO 10 26799 T = A(L,K) 26800 A(L,K) = A(K,K) 26801 A(K,K) = T 26802 10 CONTINUE 26803 C 26804 C COMPUTE MULTIPLIERS 26805 C 26806 T = -1.0D0/A(K,K) 26807 CALL DSCAL(N-K,T,A(K+1,K),1) 26808 C 26809 C ROW ELIMINATION WITH COLUMN INDEXING 26810 C 26811 DO 30 J = KP1, N 26812 T = A(L,J) 26813 IF (L .EQ. K) GO TO 20 26814 A(L,J) = A(K,J) 26815 A(K,J) = T 26816 20 CONTINUE 26817 CALL DAXPY(N-K,T,A(K+1,K),1,A(K+1,J),1) 26818 30 CONTINUE 26819 GO TO 50 26820 40 CONTINUE 26821 INFO = K 26822 50 CONTINUE 26823 60 CONTINUE 26824 70 CONTINUE 26825 IPVT(N) = N 26826 IF (A(N,N) .EQ. 0.0D0) INFO = N 26827 RETURN 26828 END 26829 *DECK DGESL 26830 SUBROUTINE DGESL (A, LDA, N, IPVT, B, JOB) 26831 C***BEGIN PROLOGUE DGESL 26832 C***PURPOSE Solve the real system A*X=B or TRANS(A)*X=B using the 26833 C factors computed by DGECO or DGEFA. 26834 C***CATEGORY D2A1 26835 C***TYPE DOUBLE PRECISION (SGESL-S, DGESL-D, CGESL-C) 26836 C***KEYWORDS LINEAR ALGEBRA, LINPACK, MATRIX, SOLVE 26837 C***AUTHOR Moler, C. B., (U. of New Mexico) 26838 C***DESCRIPTION 26839 C 26840 C DGESL solves the double precision system 26841 C A * X = B or TRANS(A) * X = B 26842 C using the factors computed by DGECO or DGEFA. 26843 C 26844 C On Entry 26845 C 26846 C A DOUBLE PRECISION(LDA, N) 26847 C the output from DGECO or DGEFA. 26848 C 26849 C LDA INTEGER 26850 C the leading dimension of the array A . 26851 C 26852 C N INTEGER 26853 C the order of the matrix A . 26854 C 26855 C IPVT INTEGER(N) 26856 C the pivot vector from DGECO or DGEFA. 26857 C 26858 C B DOUBLE PRECISION(N) 26859 C the right hand side vector. 26860 C 26861 C JOB INTEGER 26862 C = 0 to solve A*X = B , 26863 C = nonzero to solve TRANS(A)*X = B where 26864 C TRANS(A) is the transpose. 26865 C 26866 C On Return 26867 C 26868 C B the solution vector X . 26869 C 26870 C Error Condition 26871 C 26872 C A division by zero will occur if the input factor contains a 26873 C zero on the diagonal. Technically this indicates singularity 26874 C but it is often caused by improper arguments or improper 26875 C setting of LDA . It will not occur if the subroutines are 26876 C called correctly and if DGECO has set RCOND .GT. 0.0 26877 C or DGEFA has set INFO .EQ. 0 . 26878 C 26879 C To compute INVERSE(A) * C where C is a matrix 26880 C with P columns 26881 C CALL DGECO(A,LDA,N,IPVT,RCOND,Z) 26882 C IF (RCOND is too small) GO TO ... 26883 C DO 10 J = 1, P 26884 C CALL DGESL(A,LDA,N,IPVT,C(1,J),0) 26885 C 10 CONTINUE 26886 C 26887 C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. 26888 C Stewart, LINPACK Users' Guide, SIAM, 1979. 26889 C***ROUTINES CALLED DAXPY, DDOT 26890 C***REVISION HISTORY (YYMMDD) 26891 C 780814 DATE WRITTEN 26892 C 890831 Modified array declarations. (WRB) 26893 C 890831 REVISION DATE from Version 3.2 26894 C 891214 Prologue converted to Version 4.0 format. (BAB) 26895 C 900326 Removed duplicate information from DESCRIPTION section. 26896 C (WRB) 26897 C 920501 Reformatted the REFERENCES section. (WRB) 26898 C***END PROLOGUE DGESL 26899 INTEGER LDA,N,IPVT(*),JOB 26900 DOUBLE PRECISION A(LDA,*),B(*) 26901 C 26902 DOUBLE PRECISION DDOT,T 26903 INTEGER K,KB,L,NM1 26904 C***FIRST EXECUTABLE STATEMENT DGESL 26905 NM1 = N - 1 26906 IF (JOB .NE. 0) GO TO 50 26907 C 26908 C JOB = 0 , SOLVE A * X = B 26909 C FIRST SOLVE L*Y = B 26910 C 26911 IF (NM1 .LT. 1) GO TO 30 26912 DO 20 K = 1, NM1 26913 L = IPVT(K) 26914 T = B(L) 26915 IF (L .EQ. K) GO TO 10 26916 B(L) = B(K) 26917 B(K) = T 26918 10 CONTINUE 26919 CALL DAXPY(N-K,T,A(K+1,K),1,B(K+1),1) 26920 20 CONTINUE 26921 30 CONTINUE 26922 C 26923 C NOW SOLVE U*X = Y 26924 C 26925 DO 40 KB = 1, N 26926 K = N + 1 - KB 26927 B(K) = B(K)/A(K,K) 26928 T = -B(K) 26929 CALL DAXPY(K-1,T,A(1,K),1,B(1),1) 26930 40 CONTINUE 26931 GO TO 100 26932 50 CONTINUE 26933 C 26934 C JOB = NONZERO, SOLVE TRANS(A) * X = B 26935 C FIRST SOLVE TRANS(U)*Y = B 26936 C 26937 DO 60 K = 1, N 26938 T = DDOT(K-1,A(1,K),1,B(1),1) 26939 B(K) = (B(K) - T)/A(K,K) 26940 60 CONTINUE 26941 C 26942 C NOW SOLVE TRANS(L)*X = Y 26943 C 26944 IF (NM1 .LT. 1) GO TO 90 26945 DO 80 KB = 1, NM1 26946 K = N - KB 26947 B(K) = B(K) + DDOT(N-K,A(K+1,K),1,B(K+1),1) 26948 L = IPVT(K) 26949 IF (L .EQ. K) GO TO 70 26950 T = B(L) 26951 B(L) = B(K) 26952 B(K) = T 26953 70 CONTINUE 26954 80 CONTINUE 26955 90 CONTINUE 26956 100 CONTINUE 26957 RETURN 26958 END 26959 *DECK DGBFA 26960 SUBROUTINE DGBFA (ABD, LDA, N, ML, MU, IPVT, INFO) 26961 C***BEGIN PROLOGUE DGBFA 26962 C***PURPOSE Factor a band matrix using Gaussian elimination. 26963 C***CATEGORY D2A2 26964 C***TYPE DOUBLE PRECISION (SGBFA-S, DGBFA-D, CGBFA-C) 26965 C***KEYWORDS BANDED, LINEAR ALGEBRA, LINPACK, MATRIX FACTORIZATION 26966 C***AUTHOR Moler, C. B., (U. of New Mexico) 26967 C***DESCRIPTION 26968 C 26969 C DGBFA factors a double precision band matrix by elimination. 26970 C 26971 C DGBFA is usually called by DGBCO, but it can be called 26972 C directly with a saving in time if RCOND is not needed. 26973 C 26974 C On Entry 26975 C 26976 C ABD DOUBLE PRECISION(LDA, N) 26977 C contains the matrix in band storage. The columns 26978 C of the matrix are stored in the columns of ABD and 26979 C the diagonals of the matrix are stored in rows 26980 C ML+1 through 2*ML+MU+1 of ABD . 26981 C See the comments below for details. 26982 C 26983 C LDA INTEGER 26984 C the leading dimension of the array ABD . 26985 C LDA must be .GE. 2*ML + MU + 1 . 26986 C 26987 C N INTEGER 26988 C the order of the original matrix. 26989 C 26990 C ML INTEGER 26991 C number of diagonals below the main diagonal. 26992 C 0 .LE. ML .LT. N . 26993 C 26994 C MU INTEGER 26995 C number of diagonals above the main diagonal. 26996 C 0 .LE. MU .LT. N . 26997 C More efficient if ML .LE. MU . 26998 C On Return 26999 C 27000 C ABD an upper triangular matrix in band storage and 27001 C the multipliers which were used to obtain it. 27002 C The factorization can be written A = L*U where 27003 C L is a product of permutation and unit lower 27004 C triangular matrices and U is upper triangular. 27005 C 27006 C IPVT INTEGER(N) 27007 C an integer vector of pivot indices. 27008 C 27009 C INFO INTEGER 27010 C = 0 normal value. 27011 C = K if U(K,K) .EQ. 0.0 . This is not an error 27012 C condition for this subroutine, but it does 27013 C indicate that DGBSL will divide by zero if 27014 C called. Use RCOND in DGBCO for a reliable 27015 C indication of singularity. 27016 C 27017 C Band Storage 27018 C 27019 C If A is a band matrix, the following program segment 27020 C will set up the input. 27021 C 27022 C ML = (band width below the diagonal) 27023 C MU = (band width above the diagonal) 27024 C M = ML + MU + 1 27025 C DO 20 J = 1, N 27026 C I1 = MAX(1, J-MU) 27027 C I2 = MIN(N, J+ML) 27028 C DO 10 I = I1, I2 27029 C K = I - J + M 27030 C ABD(K,J) = A(I,J) 27031 C 10 CONTINUE 27032 C 20 CONTINUE 27033 C 27034 C This uses rows ML+1 through 2*ML+MU+1 of ABD . 27035 C In addition, the first ML rows in ABD are used for 27036 C elements generated during the triangularization. 27037 C The total number of rows needed in ABD is 2*ML+MU+1 . 27038 C The ML+MU by ML+MU upper left triangle and the 27039 C ML by ML lower right triangle are not referenced. 27040 C 27041 C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. 27042 C Stewart, LINPACK Users' Guide, SIAM, 1979. 27043 C***ROUTINES CALLED DAXPY, DSCAL, IDAMAX 27044 C***REVISION HISTORY (YYMMDD) 27045 C 780814 DATE WRITTEN 27046 C 890531 Changed all specific intrinsics to generic. (WRB) 27047 C 890831 Modified array declarations. (WRB) 27048 C 890831 REVISION DATE from Version 3.2 27049 C 891214 Prologue converted to Version 4.0 format. (BAB) 27050 C 900326 Removed duplicate information from DESCRIPTION section. 27051 C (WRB) 27052 C 920501 Reformatted the REFERENCES section. (WRB) 27053 C***END PROLOGUE DGBFA 27054 INTEGER LDA,N,ML,MU,IPVT(*),INFO 27055 DOUBLE PRECISION ABD(LDA,*) 27056 C 27057 DOUBLE PRECISION T 27058 INTEGER I,IDAMAX,I0,J,JU,JZ,J0,J1,K,KP1,L,LM,M,MM,NM1 27059 C 27060 C***FIRST EXECUTABLE STATEMENT DGBFA 27061 M = ML + MU + 1 27062 INFO = 0 27063 C 27064 C ZERO INITIAL FILL-IN COLUMNS 27065 C 27066 J0 = MU + 2 27067 J1 = MIN(N,M) - 1 27068 IF (J1 .LT. J0) GO TO 30 27069 DO 20 JZ = J0, J1 27070 I0 = M + 1 - JZ 27071 DO 10 I = I0, ML 27072 ABD(I,JZ) = 0.0D0 27073 10 CONTINUE 27074 20 CONTINUE 27075 30 CONTINUE 27076 JZ = J1 27077 JU = 0 27078 C 27079 C GAUSSIAN ELIMINATION WITH PARTIAL PIVOTING 27080 C 27081 NM1 = N - 1 27082 IF (NM1 .LT. 1) GO TO 130 27083 DO 120 K = 1, NM1 27084 KP1 = K + 1 27085 C 27086 C ZERO NEXT FILL-IN COLUMN 27087 C 27088 JZ = JZ + 1 27089 IF (JZ .GT. N) GO TO 50 27090 IF (ML .LT. 1) GO TO 50 27091 DO 40 I = 1, ML 27092 ABD(I,JZ) = 0.0D0 27093 40 CONTINUE 27094 50 CONTINUE 27095 C 27096 C FIND L = PIVOT INDEX 27097 C 27098 LM = MIN(ML,N-K) 27099 L = IDAMAX(LM+1,ABD(M,K),1) + M - 1 27100 IPVT(K) = L + K - M 27101 C 27102 C ZERO PIVOT IMPLIES THIS COLUMN ALREADY TRIANGULARIZED 27103 C 27104 IF (ABD(L,K) .EQ. 0.0D0) GO TO 100 27105 C 27106 C INTERCHANGE IF NECESSARY 27107 C 27108 IF (L .EQ. M) GO TO 60 27109 T = ABD(L,K) 27110 ABD(L,K) = ABD(M,K) 27111 ABD(M,K) = T 27112 60 CONTINUE 27113 C 27114 C COMPUTE MULTIPLIERS 27115 C 27116 T = -1.0D0/ABD(M,K) 27117 CALL DSCAL(LM,T,ABD(M+1,K),1) 27118 C 27119 C ROW ELIMINATION WITH COLUMN INDEXING 27120 C 27121 JU = MIN(MAX(JU,MU+IPVT(K)),N) 27122 MM = M 27123 IF (JU .LT. KP1) GO TO 90 27124 DO 80 J = KP1, JU 27125 L = L - 1 27126 MM = MM - 1 27127 T = ABD(L,J) 27128 IF (L .EQ. MM) GO TO 70 27129 ABD(L,J) = ABD(MM,J) 27130 ABD(MM,J) = T 27131 70 CONTINUE 27132 CALL DAXPY(LM,T,ABD(M+1,K),1,ABD(MM+1,J),1) 27133 80 CONTINUE 27134 90 CONTINUE 27135 GO TO 110 27136 100 CONTINUE 27137 INFO = K 27138 110 CONTINUE 27139 120 CONTINUE 27140 130 CONTINUE 27141 IPVT(N) = N 27142 IF (ABD(M,N) .EQ. 0.0D0) INFO = N 27143 RETURN 27144 END 27145 *DECK DGBSL 27146 SUBROUTINE DGBSL (ABD, LDA, N, ML, MU, IPVT, B, JOB) 27147 C***BEGIN PROLOGUE DGBSL 27148 C***PURPOSE Solve the real band system A*X=B or TRANS(A)*X=B using 27149 C the factors computed by DGBCO or DGBFA. 27150 C***CATEGORY D2A2 27151 C***TYPE DOUBLE PRECISION (SGBSL-S, DGBSL-D, CGBSL-C) 27152 C***KEYWORDS BANDED, LINEAR ALGEBRA, LINPACK, MATRIX, SOLVE 27153 C***AUTHOR Moler, C. B., (U. of New Mexico) 27154 C***DESCRIPTION 27155 C 27156 C DGBSL solves the double precision band system 27157 C A * X = B or TRANS(A) * X = B 27158 C using the factors computed by DGBCO or DGBFA. 27159 C 27160 C On Entry 27161 C 27162 C ABD DOUBLE PRECISION(LDA, N) 27163 C the output from DGBCO or DGBFA. 27164 C 27165 C LDA INTEGER 27166 C the leading dimension of the array ABD . 27167 C 27168 C N INTEGER 27169 C the order of the original matrix. 27170 C 27171 C ML INTEGER 27172 C number of diagonals below the main diagonal. 27173 C 27174 C MU INTEGER 27175 C number of diagonals above the main diagonal. 27176 C 27177 C IPVT INTEGER(N) 27178 C the pivot vector from DGBCO or DGBFA. 27179 C 27180 C B DOUBLE PRECISION(N) 27181 C the right hand side vector. 27182 C 27183 C JOB INTEGER 27184 C = 0 to solve A*X = B , 27185 C = nonzero to solve TRANS(A)*X = B , where 27186 C TRANS(A) is the transpose. 27187 C 27188 C On Return 27189 C 27190 C B the solution vector X . 27191 C 27192 C Error Condition 27193 C 27194 C A division by zero will occur if the input factor contains a 27195 C zero on the diagonal. Technically this indicates singularity 27196 C but it is often caused by improper arguments or improper 27197 C setting of LDA . It will not occur if the subroutines are 27198 C called correctly and if DGBCO has set RCOND .GT. 0.0 27199 C or DGBFA has set INFO .EQ. 0 . 27200 C 27201 C To compute INVERSE(A) * C where C is a matrix 27202 C with P columns 27203 C CALL DGBCO(ABD,LDA,N,ML,MU,IPVT,RCOND,Z) 27204 C IF (RCOND is too small) GO TO ... 27205 C DO 10 J = 1, P 27206 C CALL DGBSL(ABD,LDA,N,ML,MU,IPVT,C(1,J),0) 27207 C 10 CONTINUE 27208 C 27209 C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. 27210 C Stewart, LINPACK Users' Guide, SIAM, 1979. 27211 C***ROUTINES CALLED DAXPY, DDOT 27212 C***REVISION HISTORY (YYMMDD) 27213 C 780814 DATE WRITTEN 27214 C 890531 Changed all specific intrinsics to generic. (WRB) 27215 C 890831 Modified array declarations. (WRB) 27216 C 890831 REVISION DATE from Version 3.2 27217 C 891214 Prologue converted to Version 4.0 format. (BAB) 27218 C 900326 Removed duplicate information from DESCRIPTION section. 27219 C (WRB) 27220 C 920501 Reformatted the REFERENCES section. (WRB) 27221 C***END PROLOGUE DGBSL 27222 INTEGER LDA,N,ML,MU,IPVT(*),JOB 27223 DOUBLE PRECISION ABD(LDA,*),B(*) 27224 C 27225 DOUBLE PRECISION DDOT,T 27226 INTEGER K,KB,L,LA,LB,LM,M,NM1 27227 C***FIRST EXECUTABLE STATEMENT DGBSL 27228 M = MU + ML + 1 27229 NM1 = N - 1 27230 IF (JOB .NE. 0) GO TO 50 27231 C 27232 C JOB = 0 , SOLVE A * X = B 27233 C FIRST SOLVE L*Y = B 27234 C 27235 IF (ML .EQ. 0) GO TO 30 27236 IF (NM1 .LT. 1) GO TO 30 27237 DO 20 K = 1, NM1 27238 LM = MIN(ML,N-K) 27239 L = IPVT(K) 27240 T = B(L) 27241 IF (L .EQ. K) GO TO 10 27242 B(L) = B(K) 27243 B(K) = T 27244 10 CONTINUE 27245 CALL DAXPY(LM,T,ABD(M+1,K),1,B(K+1),1) 27246 20 CONTINUE 27247 30 CONTINUE 27248 C 27249 C NOW SOLVE U*X = Y 27250 C 27251 DO 40 KB = 1, N 27252 K = N + 1 - KB 27253 B(K) = B(K)/ABD(M,K) 27254 LM = MIN(K,M) - 1 27255 LA = M - LM 27256 LB = K - LM 27257 T = -B(K) 27258 CALL DAXPY(LM,T,ABD(LA,K),1,B(LB),1) 27259 40 CONTINUE 27260 GO TO 100 27261 50 CONTINUE 27262 C 27263 C JOB = NONZERO, SOLVE TRANS(A) * X = B 27264 C FIRST SOLVE TRANS(U)*Y = B 27265 C 27266 DO 60 K = 1, N 27267 LM = MIN(K,M) - 1 27268 LA = M - LM 27269 LB = K - LM 27270 T = DDOT(LM,ABD(LA,K),1,B(LB),1) 27271 B(K) = (B(K) - T)/ABD(M,K) 27272 60 CONTINUE 27273 C 27274 C NOW SOLVE TRANS(L)*X = Y 27275 C 27276 IF (ML .EQ. 0) GO TO 90 27277 IF (NM1 .LT. 1) GO TO 90 27278 DO 80 KB = 1, NM1 27279 K = N - KB 27280 LM = MIN(ML,N-K) 27281 B(K) = B(K) + DDOT(LM,ABD(M+1,K),1,B(K+1),1) 27282 L = IPVT(K) 27283 IF (L .EQ. K) GO TO 70 27284 T = B(L) 27285 B(L) = B(K) 27286 B(K) = T 27287 70 CONTINUE 27288 80 CONTINUE 27289 90 CONTINUE 27290 100 CONTINUE 27291 RETURN 27292 END 27293 SUBROUTINE XERRWD (MSG, NMES, NERR, LEVEL, NI, I1, I2, NR, R1, R2) 27294 C***BEGIN PROLOGUE XERRWD 27295 C***SUBSIDIARY 27296 C***PURPOSE Write error message with values. 27297 C***CATEGORY R3C 27298 C***TYPE DOUBLE PRECISION (XERRWV-S, XERRWD-D) 27299 C***AUTHOR Hindmarsh, Alan C., (LLNL) 27300 C***DESCRIPTION 27301 C 27302 C Subroutines XERRWD, XSETF, XSETUN, and the function routine IXSAV, 27303 C as given here, constitute a simplified version of the SLATEC error 27304 C handling package. 27305 C 27306 C All arguments are input arguments. 27307 C 27308 C MSG = The message (character array). 27309 C NMES = The length of MSG (number of characters). 27310 C NERR = The error number (not used). 27311 C LEVEL = The error level.. 27312 C 0 or 1 means recoverable (control returns to caller). 27313 C 2 means fatal (run is aborted--see note below). 27314 C NI = Number of integers (0, 1, or 2) to be printed with message. 27315 C I1,I2 = Integers to be printed, depending on NI. 27316 C NR = Number of reals (0, 1, or 2) to be printed with message. 27317 C R1,R2 = Reals to be printed, depending on NR. 27318 C 27319 C Note.. this routine is machine-dependent and specialized for use 27320 C in limited context, in the following ways.. 27321 C 1. The argument MSG is assumed to be of type CHARACTER, and 27322 C the message is printed with a format of (1X,A). 27323 C 2. The message is assumed to take only one line. 27324 C Multi-line messages are generated by repeated calls. 27325 C 3. If LEVEL = 2, control passes to the statement STOP 27326 C to abort the run. This statement may be machine-dependent. 27327 C 4. R1 and R2 are assumed to be in double precision and are printed 27328 C in D21.13 format. 27329 C 27330 C***ROUTINES CALLED IXSAV 27331 C***REVISION HISTORY (YYMMDD) 27332 C 920831 DATE WRITTEN 27333 C 921118 Replaced MFLGSV/LUNSAV by IXSAV. (ACH) 27334 C 930329 Modified prologue to SLATEC format. (FNF) 27335 C 930407 Changed MSG from CHARACTER*1 array to variable. (FNF) 27336 C 930922 Minor cosmetic change. (FNF) 27337 C***END PROLOGUE XERRWD 27338 C 27339 C*Internal Notes: 27340 C 27341 C For a different default logical unit number, IXSAV (or a subsidiary 27342 C routine that it calls) will need to be modified. 27343 C For a different run-abort command, change the statement following 27344 C statement 100 at the end. 27345 C----------------------------------------------------------------------- 27346 C Subroutines called by XERRWD.. None 27347 C Function routine called by XERRWD.. IXSAV 27348 C----------------------------------------------------------------------- 27349 C**End 27350 C 27351 C Declare arguments. 27352 C 27353 DOUBLE PRECISION R1, R2 27354 INTEGER NMES, NERR, LEVEL, NI, I1, I2, NR 27355 CHARACTER*(*) MSG 27356 C 27357 C Declare local variables. 27358 C 27359 INTEGER LUNIT, IXSAV, MESFLG 27360 C 27361 C Get logical unit number and message print flag. 27362 C 27363 C***FIRST EXECUTABLE STATEMENT XERRWD 27364 LUNIT = IXSAV (1, 0, .FALSE.) 27365 MESFLG = IXSAV (2, 0, .FALSE.) 27366 IF (MESFLG .EQ. 0) GO TO 100 27367 C 27368 C Write the message. 27369 C 27370 WRITE (LUNIT,10) MSG 27371 10 FORMAT(1X,A) 27372 IF (NI .EQ. 1) WRITE (LUNIT, 20) I1 27373 20 FORMAT(6X,'In above message, I1 =',I10) 27374 IF (NI .EQ. 2) WRITE (LUNIT, 30) I1,I2 27375 30 FORMAT(6X,'In above message, I1 =',I10,3X,'I2 =',I10) 27376 IF (NR .EQ. 1) WRITE (LUNIT, 40) R1 27377 40 FORMAT(6X,'In above message, R1 =',D21.13) 27378 IF (NR .EQ. 2) WRITE (LUNIT, 50) R1,R2 27379 50 FORMAT(6X,'In above, R1 =',D21.13,3X,'R2 =',D21.13) 27380 C 27381 C Abort the run if LEVEL = 2. 27382 C 27383 100 IF (LEVEL .NE. 2) RETURN 27384 STOP 27385 C----------------------- End of Subroutine XERRWD ---------------------- 27386 END 27387 *DECK XSETF 27388 SUBROUTINE XSETF (MFLAG) 27389 C***BEGIN PROLOGUE XSETF 27390 C***PURPOSE Reset the error print control flag. 27391 C***CATEGORY R3A 27392 C***TYPE ALL (XSETF-A) 27393 C***KEYWORDS ERROR CONTROL 27394 C***AUTHOR Hindmarsh, Alan C., (LLNL) 27395 C***DESCRIPTION 27396 C 27397 C XSETF sets the error print control flag to MFLAG: 27398 C MFLAG=1 means print all messages (the default). 27399 C MFLAG=0 means no printing. 27400 C 27401 C***SEE ALSO XERRWD, XERRWV 27402 C***REFERENCES (NONE) 27403 C***ROUTINES CALLED IXSAV 27404 C***REVISION HISTORY (YYMMDD) 27405 C 921118 DATE WRITTEN 27406 C 930329 Added SLATEC format prologue. (FNF) 27407 C 930407 Corrected SEE ALSO section. (FNF) 27408 C 930922 Made user-callable, and other cosmetic changes. (FNF) 27409 C***END PROLOGUE XSETF 27410 C 27411 C Subroutines called by XSETF.. None 27412 C Function routine called by XSETF.. IXSAV 27413 C----------------------------------------------------------------------- 27414 C**End 27415 INTEGER MFLAG, JUNK, IXSAV 27416 C 27417 C***FIRST EXECUTABLE STATEMENT XSETF 27418 IF (MFLAG .EQ. 0 .OR. MFLAG .EQ. 1) JUNK = IXSAV (2,MFLAG,.TRUE.) 27419 RETURN 27420 C----------------------- End of Subroutine XSETF ----------------------- 27421 END 27422 *DECK XSETUN 27423 SUBROUTINE XSETUN (LUN) 27424 C***BEGIN PROLOGUE XSETUN 27425 C***PURPOSE Reset the logical unit number for error messages. 27426 C***CATEGORY R3B 27427 C***TYPE ALL (XSETUN-A) 27428 C***KEYWORDS ERROR CONTROL 27429 C***DESCRIPTION 27430 C 27431 C XSETUN sets the logical unit number for error messages to LUN. 27432 C 27433 C***AUTHOR Hindmarsh, Alan C., (LLNL) 27434 C***SEE ALSO XERRWD, XERRWV 27435 C***REFERENCES (NONE) 27436 C***ROUTINES CALLED IXSAV 27437 C***REVISION HISTORY (YYMMDD) 27438 C 921118 DATE WRITTEN 27439 C 930329 Added SLATEC format prologue. (FNF) 27440 C 930407 Corrected SEE ALSO section. (FNF) 27441 C 930922 Made user-callable, and other cosmetic changes. (FNF) 27442 C***END PROLOGUE XSETUN 27443 C 27444 C Subroutines called by XSETUN.. None 27445 C Function routine called by XSETUN.. IXSAV 27446 C----------------------------------------------------------------------- 27447 C**End 27448 INTEGER LUN, JUNK, IXSAV 27449 C 27450 C***FIRST EXECUTABLE STATEMENT XSETUN 27451 IF (LUN .GT. 0) JUNK = IXSAV (1,LUN,.TRUE.) 27452 RETURN 27453 C----------------------- End of Subroutine XSETUN ---------------------- 27454 END 27455 *DECK IXSAV 27456 INTEGER FUNCTION IXSAV (IPAR, IVALUE, ISET) 27457 C***BEGIN PROLOGUE IXSAV 27458 C***SUBSIDIARY 27459 C***PURPOSE Save and recall error message control parameters. 27460 C***CATEGORY R3C 27461 C***TYPE ALL (IXSAV-A) 27462 C***AUTHOR Hindmarsh, Alan C., (LLNL) 27463 C***DESCRIPTION 27464 C 27465 C IXSAV saves and recalls one of two error message parameters: 27466 C LUNIT, the logical unit number to which messages are printed, and 27467 C MESFLG, the message print flag. 27468 C This is a modification of the SLATEC library routine J4SAVE. 27469 C 27470 C Saved local variables.. 27471 C LUNIT = Logical unit number for messages. The default is obtained 27472 C by a call to IUMACH (may be machine-dependent). 27473 C MESFLG = Print control flag.. 27474 C 1 means print all messages (the default). 27475 C 0 means no printing. 27476 C 27477 C On input.. 27478 C IPAR = Parameter indicator (1 for LUNIT, 2 for MESFLG). 27479 C IVALUE = The value to be set for the parameter, if ISET = .TRUE. 27480 C ISET = Logical flag to indicate whether to read or write. 27481 C If ISET = .TRUE., the parameter will be given 27482 C the value IVALUE. If ISET = .FALSE., the parameter 27483 C will be unchanged, and IVALUE is a dummy argument. 27484 C 27485 C On return.. 27486 C IXSAV = The (old) value of the parameter. 27487 C 27488 C***SEE ALSO XERRWD, XERRWV 27489 C***ROUTINES CALLED IUMACH 27490 C***REVISION HISTORY (YYMMDD) 27491 C 921118 DATE WRITTEN 27492 C 930329 Modified prologue to SLATEC format. (FNF) 27493 C 930915 Added IUMACH call to get default output unit. (ACH) 27494 C 930922 Minor cosmetic changes. (FNF) 27495 C 010425 Type declaration for IUMACH added. (ACH) 27496 C***END PROLOGUE IXSAV 27497 C 27498 C Subroutines called by IXSAV.. None 27499 C Function routine called by IXSAV.. IUMACH 27500 C----------------------------------------------------------------------- 27501 C**End 27502 LOGICAL ISET 27503 INTEGER IPAR, IVALUE 27504 C----------------------------------------------------------------------- 27505 INTEGER IUMACH, LUNIT, MESFLG 27506 C----------------------------------------------------------------------- 27507 C The following Fortran-77 declaration is to cause the values of the 27508 C listed (local) variables to be saved between calls to this routine. 27509 C----------------------------------------------------------------------- 27510 SAVE LUNIT, MESFLG 27511 DATA LUNIT/-1/, MESFLG/1/ 27512 C 27513 C***FIRST EXECUTABLE STATEMENT IXSAV 27514 IF (IPAR .EQ. 1) THEN 27515 IF (LUNIT .EQ. -1) LUNIT = IUMACH() 27516 IXSAV = LUNIT 27517 IF (ISET) LUNIT = IVALUE 27518 ENDIF 27519 C 27520 IF (IPAR .EQ. 2) THEN 27521 IXSAV = MESFLG 27522 IF (ISET) MESFLG = IVALUE 27523 ENDIF 27524 C 27525 RETURN 27526 C----------------------- End of Function IXSAV ------------------------- 27527 END 27528 *DECK IUMACH 27529 INTEGER FUNCTION IUMACH() 27530 C***BEGIN PROLOGUE IUMACH 27531 C***PURPOSE Provide standard output unit number. 27532 C***CATEGORY R1 27533 C***TYPE INTEGER (IUMACH-I) 27534 C***KEYWORDS MACHINE CONSTANTS 27535 C***AUTHOR Hindmarsh, Alan C., (LLNL) 27536 C***DESCRIPTION 27537 C *Usage: 27538 C INTEGER LOUT, IUMACH 27539 C LOUT = IUMACH() 27540 C 27541 C *Function Return Values: 27542 C LOUT : the standard logical unit for Fortran output. 27543 C 27544 C***REFERENCES (NONE) 27545 C***ROUTINES CALLED (NONE) 27546 C***REVISION HISTORY (YYMMDD) 27547 C 930915 DATE WRITTEN 27548 C 930922 Made user-callable, and other cosmetic changes. (FNF) 27549 C***END PROLOGUE IUMACH 27550 C 27551 C*Internal Notes: 27552 C The built-in value of 6 is standard on a wide range of Fortran 27553 C systems. This may be machine-dependent. 27554 C**End 27555 C***FIRST EXECUTABLE STATEMENT IUMACH 27556 IUMACH = 6 27557 C 27558 RETURN 27559 C----------------------- End of Function IUMACH ------------------------ 27560 END 27561