2 SUBROUTINE slsode (F, NEQ, Y, T, TOUT, ITOL, RTOL, ATOL, ITASK,
3 1 istate, iopt, rwork, lrw, iwork, liw, jac, mf)
5 INTEGER NEQ, ITOL, ITASK, ISTATE, IOPT, LRW, IWORK, LIW, MF
6 REAL Y, T, TOUT, RTOL, ATOL, RWORK
7 dimension neq(*), y(*), rtol(*), atol(*), rwork(lrw), iwork(liw)
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
1217 1 ccmax, el0, h, hmin, hmxi, hu, rc, tn, uround
1218 REAL ATOLI, AYI, BIG, EWTI, H0, HMAX, HMX, RH, RTOLI,
1219 1 tcrit, tdist, tnext, tol, tolsf, tp,
SIZE, sum, w0
1223 SAVE mord, mxstp0, mxhnl0
1234 COMMON /sls001/ 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
1241 DATA mord(1),mord(2)/12,5/, mxstp0/500/, mxhnl0/10/
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
1259 IF (tout .EQ. t)
RETURN
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
1273 IF (itol .LT. 1 .OR. itol .GT. 4) go to 606
1274 IF (iopt .LT. 0 .OR. iopt .GT. 1) go to 607
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
1282 IF (ml .LT. 0 .OR. ml .GE. n) go to 609
1283 IF (mu .LT. 0 .OR. mu .GE. n) go to 610
1286 IF (iopt .EQ. 1) go to 40
1290 IF (istate .EQ. 1) h0 = 0.0e0
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))
1299 IF (mxstep .LT. 0) go to 612
1300 IF (mxstep .EQ. 0) mxstep = mxstp0
1302 IF (mxhnil .LT. 0) go to 613
1303 IF (mxhnil .EQ. 0) mxhnil = mxhnl0
1304 IF (istate .NE. 1) go to 50
1306 IF ((tout - t)*h0 .LT. 0.0e0) go to 614
1308 IF (hmax .LT. 0.0e0) go to 615
1310 IF (hmax .GT. 0.0e0) hmxi = 1.0e0/hmax
1312 IF (hmin .LT. 0.0e0) go to 616
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
1329 lenrw = lacor + n - 1
1333 IF (miter .EQ. 0 .OR. miter .EQ. 3) leniw = 20
1335 IF (lenrw .GT. lrw) go to 617
1336 IF (leniw .GT. liw) go to 618
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.0e0) go to 619
1344 IF (atoli .LT. 0.0e0) go to 620
1346 IF (istate .EQ. 1) go to 100
1349 IF (nq .LE. maxord) go to 90
1352 80 rwork(i+lsavf-1) = rwork(i+lwm-1)
1354 90
IF (miter .GT. 0) rwork(lwm) =
sqrt(uround)
1355 IF (n .EQ. nyh) go to 200
1358 i2 = lyh + (maxord + 1)*nyh - 1
1359 IF (i1 .GT. i2) go to 200
1370 100 uround = d1mach(4)
1372 IF (itask .NE. 4 .AND. itask .NE. 5) go to 110
1374 IF ((tcrit - tout)*(tout - t) .LT. 0.0e0) go to 625
1375 IF (h0 .NE. 0.0e0 .AND. (t + h0 - tcrit)*h0 .GT. 0.0e0)
1378 IF (miter .GT. 0) rwork(lwm) =
sqrt(uround)
1391 CALL
f(neq, t, y, rwork(lf0))
1395 115 rwork(i+lyh-1) = y(i)
1399 CALL
sewset(n, itol, rtol, atol, rwork(lyh), rwork(lewt))
1401 IF (rwork(i+lewt-1) .LE. 0.0e0) go to 621
1402 120 rwork(i+lewt-1) = 1.0e0/rwork(i+lewt-1)
1419 IF (h0 .NE. 0.0e0) go to 180
1420 tdist =
abs(tout - t)
1422 IF (tdist .LT. 2.0e0*uround*w0) go to 622
1424 IF (itol .LE. 2) go to 140
1426 130 tol =
max(tol,rtol(i))
1427 140
IF (tol .GT. 0.0e0) go to 160
1430 IF (itol .EQ. 2 .OR. itol .EQ. 4) atoli = atol(i)
1432 IF (ayi .NE. 0.0e0) tol =
max(tol,atoli/ayi)
1434 160 tol =
max(tol,100.0e0*uround)
1435 tol =
min(tol,0.001e0)
1436 sum = svnorm(n, rwork(lf0), rwork(lewt))
1437 sum = 1.0e0/(tol*w0*w0) + tol*sum**2
1438 h0 = 1.0e0/
sqrt(sum)
1440 h0 = sign(h0,tout-t)
1442 180 rh =
abs(h0)*hmxi
1443 IF (rh .GT. 1.0e0) h0 = h0/rh
1447 190 rwork(i+lf0-1) = h0*rwork(i+lf0-1)
1455 go to(210, 250, 220, 230, 240), itask
1456 210
IF ((tn - tout)*h .LT. 0.0e0) go to 250
1457 CALL
sintdy(tout, 0, rwork(lyh), nyh, y, iflag)
1458 IF (iflag .NE. 0) go to 627
1461 220 tp = tn - hu*(1.0e0 + 100.0e0*uround)
1462 IF ((tp - tout)*h .GT. 0.0e0) go to 623
1463 IF ((tn - tout)*h .LT. 0.0e0) go to 250
1465 230 tcrit = rwork(1)
1466 IF ((tn - tcrit)*h .GT. 0.0e0) go to 624
1467 IF ((tcrit - tout)*h .LT. 0.0e0) go to 625
1468 IF ((tn - tout)*h .LT. 0.0e0) go to 245
1469 CALL
sintdy(tout, 0, rwork(lyh), nyh, y, iflag)
1470 IF (iflag .NE. 0) go to 627
1473 240 tcrit = rwork(1)
1474 IF ((tn - tcrit)*h .GT. 0.0e0) go to 624
1475 245 hmx =
abs(tn) +
abs(h)
1476 ihit =
abs(tn - tcrit) .LE. 100.0e0*uround*hmx
1478 tnext = tn + h*(1.0e0 + 4.0e0*uround)
1479 IF ((tnext - tcrit)*h .LE. 0.0e0) go to 250
1480 h = (tcrit - tn)*(1.0e0 - 4.0e0*uround)
1481 IF (istate .EQ. 2) jstart = -2
1494 IF ((nst-nslast) .GE. mxstep) go to 500
1495 CALL
sewset(n, itol, rtol, atol, rwork(lyh), rwork(lewt))
1497 IF (rwork(i+lewt-1) .LE. 0.0e0) go to 510
1498 260 rwork(i+lewt-1) = 1.0e0/rwork(i+lewt-1)
1499 270 tolsf = uround*svnorm(n, rwork(lyh), rwork(lewt))
1500 IF (tolsf .LE. 1.0e0) go to 280
1502 IF (nst .EQ. 0) go to 626
1504 280
IF ((tn + h) .NE. tn) go to 290
1506 IF (nhnil .GT. mxhnil) go to 290
1507 CALL
xerrwd(
'SLSODE- Warning..internal T (=R1) and H (=R2) are',
1508 1 50, 101, 0, 0, 0, 0, 0, 0.0e0, 0.0e0)
1510 1
' such that in the machine, T + H = T on the next step ',
1511 1 60, 101, 0, 0, 0, 0, 0, 0.0e0, 0.0e0)
1512 CALL
xerrwd(
' (H = step size). Solver will continue anyway',
1513 1 50, 101, 0, 0, 0, 0, 2, tn, h)
1514 IF (nhnil .LT. mxhnil) go to 290
1515 CALL
xerrwd(
'SLSODE- Above warning has been issued I1 times. ',
1516 1 50, 102, 0, 0, 0, 0, 0, 0.0e0, 0.0e0)
1517 CALL
xerrwd(
' It will not be issued again for this problem',
1518 1 50, 102, 0, 1, mxhnil, 0, 0, 0.0e0, 0.0e0)
1523 CALL
sstode(neq, y, rwork(lyh), nyh, rwork(lyh), rwork(lewt),
1524 1 rwork(lsavf), rwork(lacor), rwork(lwm), iwork(liwm),
1527 go to(300, 530, 540), kgo
1534 go to(310, 400, 330, 340, 350), itask
1536 310
IF ((tn - tout)*h .LT. 0.0e0) go to 250
1537 CALL
sintdy(tout, 0, rwork(lyh), nyh, y, iflag)
1541 330
IF ((tn - tout)*h .GE. 0.0e0) go to 400
1544 340
IF ((tn - tout)*h .LT. 0.0e0) go to 345
1545 CALL
sintdy(tout, 0, rwork(lyh), nyh, y, iflag)
1548 345 hmx =
abs(tn) +
abs(h)
1549 ihit =
abs(tn - tcrit) .LE. 100.0e0*uround*hmx
1551 tnext = tn + h*(1.0e0 + 4.0e0*uround)
1552 IF ((tnext - tcrit)*h .LE. 0.0e0) go to 250
1553 h = (tcrit - tn)*(1.0e0 - 4.0e0*uround)
1557 350 hmx =
abs(tn) +
abs(h)
1558 ihit =
abs(tn - tcrit) .LE. 100.0e0*uround*hmx
1567 410 y(i) = rwork(i+lyh-1)
1569 IF (itask .NE. 4 .AND. itask .NE. 5) go to 420
1590 500 CALL
xerrwd(
'SLSODE- At current T (=R1), MXSTEP (=I1) steps ',
1591 1 50, 201, 0, 0, 0, 0, 0, 0.0e0, 0.0e0)
1592 CALL
xerrwd(
' taken on this call before reaching TOUT ',
1593 1 50, 201, 0, 1, mxstep, 0, 1, tn, 0.0e0)
1597 510 ewti = rwork(lewt+i-1)
1598 CALL
xerrwd(.LE.
'SLSODE- At T (=R1), EWT(I1) has become R2 0.',
1599 1 50, 202, 0, 1, i, 0, 2, tn, ewti)
1603 520 CALL
xerrwd(
'SLSODE- At T (=R1), too much accuracy requested ',
1604 1 50, 203, 0, 0, 0, 0, 0, 0.0e0, 0.0e0)
1605 CALL
xerrwd(
' for precision of machine.. see TOLSF (=R2) ',
1606 1 50, 203, 0, 0, 0, 0, 2, tn, tolsf)
1611 530 CALL
xerrwd(
'SLSODE- At T(=R1) and step size H(=R2), the error',
1612 1 50, 204, 0, 0, 0, 0, 0, 0.0e0, 0.0e0)
1613 CALL
xerrwd(
' test failed repeatedly or with ABS(H) = HMIN',
1614 1 50, 204, 0, 0, 0, 0, 2, tn, h)
1618 540 CALL
xerrwd(
'SLSODE- At T (=R1) and step size H (=R2), the ',
1619 1 50, 205, 0, 0, 0, 0, 0, 0.0e0, 0.0e0)
1620 CALL
xerrwd(
' corrector convergence failed repeatedly ',
1621 1 50, 205, 0, 0, 0, 0, 0, 0.0e0, 0.0e0)
1622 CALL
xerrwd(
' or with ABS(H) = HMIN ',
1623 1 30, 205, 0, 0, 0, 0, 2, tn, h)
1629 SIZE =
abs(rwork(i+lacor-1)*rwork(i+lewt-1))
1630 IF (big .GE.
size) go to 570
1637 590 y(i) = rwork(i+lyh-1)
1655 601 CALL
xerrwd(
'SLSODE- ISTATE (=I1) illegal ',
1656 1 30, 1, 0, 1, istate, 0, 0, 0.0e0, 0.0e0)
1657 IF (istate .LT. 0) go to 800
1659 602 CALL
xerrwd(
'SLSODE- ITASK (=I1) illegal ',
1660 1 30, 2, 0, 1, itask, 0, 0, 0.0e0, 0.0e0)
1662 603 CALL
xerrwd(.GT.
'SLSODE- ISTATE 1 but SLSODE not initialized ',
1663 1 50, 3, 0, 0, 0, 0, 0, 0.0e0, 0.0e0)
1665 604 CALL
xerrwd(.LT.
'SLSODE- NEQ (=I1) 1 ',
1666 1 30, 4, 0, 1, neq(1), 0, 0, 0.0e0, 0.0e0)
1668 605 CALL
xerrwd(
'SLSODE- ISTATE = 3 and NEQ increased (I1 to I2) ',
1669 1 50, 5, 0, 2, n, neq(1), 0, 0.0e0, 0.0e0)
1671 606 CALL
xerrwd(
'SLSODE- ITOL (=I1) illegal ',
1672 1 30, 6, 0, 1, itol, 0, 0, 0.0e0, 0.0e0)
1674 607 CALL
xerrwd(
'SLSODE- IOPT (=I1) illegal ',
1675 1 30, 7, 0, 1, iopt, 0, 0, 0.0e0, 0.0e0)
1677 608 CALL
xerrwd(
'SLSODE- MF (=I1) illegal ',
1678 1 30, 8, 0, 1, mf, 0, 0, 0.0e0, 0.0e0)
1680 609 CALL
xerrwd(.LT..GE.
'SLSODE- ML (=I1) illegal.. 0 or NEQ (=I2)',
1681 1 50, 9, 0, 2, ml, neq(1), 0, 0.0e0, 0.0e0)
1683 610 CALL
xerrwd(.LT..GE.
'SLSODE- MU (=I1) illegal.. 0 or NEQ (=I2)',
1684 1 50, 10, 0, 2, mu, neq(1), 0, 0.0e0, 0.0e0)
1686 611 CALL
xerrwd(.LT.
'SLSODE- MAXORD (=I1) 0 ',
1687 1 30, 11, 0, 1, maxord, 0, 0, 0.0e0, 0.0e0)
1689 612 CALL
xerrwd(.LT.
'SLSODE- MXSTEP (=I1) 0 ',
1690 1 30, 12, 0, 1, mxstep, 0, 0, 0.0e0, 0.0e0)
1692 613 CALL
xerrwd(.LT.
'SLSODE- MXHNIL (=I1) 0 ',
1693 1 30, 13, 0, 1, mxhnil, 0, 0, 0.0e0, 0.0e0)
1695 614 CALL
xerrwd(
'SLSODE- TOUT (=R1) behind T (=R2) ',
1696 1 40, 14, 0, 0, 0, 0, 2, tout, t)
1697 CALL
xerrwd(
' Integration direction is given by H0 (=R1) ',
1698 1 50, 14, 0, 0, 0, 0, 1, h0, 0.0e0)
1700 615 CALL
xerrwd(.LT.
'SLSODE- HMAX (=R1) 0.0 ',
1701 1 30, 15, 0, 0, 0, 0, 1, hmax, 0.0e0)
1703 616 CALL
xerrwd(.LT.
'SLSODE- HMIN (=R1) 0.0 ',
1704 1 30, 16, 0, 0, 0, 0, 1, hmin, 0.0e0)
1707 1
'SLSODE- RWORK length needed, LENRW (=I1), exceeds LRW (=I2)',
1708 1 60, 17, 0, 2, lenrw, lrw, 0, 0.0e0, 0.0e0)
1711 1
'SLSODE- IWORK length needed, LENIW (=I1), exceeds LIW (=I2)',
1712 1 60, 18, 0, 2, leniw, liw, 0, 0.0e0, 0.0e0)
1714 619 CALL
xerrwd(.LT.
'SLSODE- RTOL(I1) is R1 0.0 ',
1715 1 40, 19, 0, 1, i, 0, 1, rtoli, 0.0e0)
1717 620 CALL
xerrwd(.LT.
'SLSODE- ATOL(I1) is R1 0.0 ',
1718 1 40, 20, 0, 1, i, 0, 1, atoli, 0.0e0)
1720 621 ewti = rwork(lewt+i-1)
1721 CALL
xerrwd(.LE.
'SLSODE- EWT(I1) is R1 0.0 ',
1722 1 40, 21, 0, 1, i, 0, 1, ewti, 0.0e0)
1725 1
'SLSODE- TOUT (=R1) too close to T(=R2) to start integration',
1726 1 60, 22, 0, 0, 0, 0, 2, tout, t)
1729 1
'SLSODE- ITASK = I1 and TOUT (=R1) behind TCUR - HU (= R2) ',
1730 1 60, 23, 0, 1, itask, 0, 2, tout, tp)
1733 1
'SLSODE- ITASK = 4 OR 5 and TCRIT (=R1) behind TCUR (=R2) ',
1734 1 60, 24, 0, 0, 0, 0, 2, tcrit, tn)
1737 1
'SLSODE- ITASK = 4 or 5 and TCRIT (=R1) behind TOUT (=R2) ',
1738 1 60, 25, 0, 0, 0, 0, 2, tcrit, tout)
1740 626 CALL
xerrwd(
'SLSODE- At start of problem, too much accuracy ',
1741 1 50, 26, 0, 0, 0, 0, 0, 0.0e0, 0.0e0)
1743 1
' requested for precision of machine.. See TOLSF (=R1) ',
1744 1 60, 26, 0, 0, 0, 0, 1, tolsf, 0.0e0)
1747 627 CALL
xerrwd(
'SLSODE- Trouble in SINTDY. ITASK = I1, TOUT = R1',
1748 1 50, 27, 0, 1, itask, 0, 1, tout, 0.0e0)
1753 800 CALL
xerrwd(
'SLSODE- Run aborted.. apparent infinite loop ',
1754 1 50, 303, 2, 0, 0, 0, 0, 0.0e0, 0.0e0)
subroutine ssolsy(WM, IWM, X, TEM)
subroutine sewset(N, ITOL, RTOL, ATOL, YCUR, EWT)
std::string dimension(void) const
subroutine xerrwd(MSG, NMES, NERR, LEVEL, NI, I1, I2, NR, R1, R2)
subroutine slsode(F, NEQ, Y, T, TOUT, ITOL, RTOL, ATOL, ITASK, ISTATE, IOPT, RWORK, LRW, IWORK, LIW, JAC, MF)
subroutine sintdy(T, K, YH, NYH, DKY, IFLAG)
F77_RET_T const double const double * f
size_t size(T const (&)[z])
charNDArray max(char d, const charNDArray &m)
subroutine sprepj(NEQ, Y, YH, NYH, EWT, FTEM, SAVF, WM, IWM, F, JAC)
subroutine sstode(NEQ, Y, YH, NYH, YH1, EWT, SAVF, ACOR, WM, IWM, F, JAC, PJAC, SLVS)
octave_value sqrt(void) const
charNDArray min(char d, const charNDArray &m)