5 SUBROUTINE dlinsk (NEQ, Y, T, YPRIME, SAVR, CJ, P, PNRM, WT,
6 * sqrtn, rsqrtn, lsoff, stptol, iret, res, ires, psol, wm, iwm,
7 * rhok, fnrm, icopt, id, wp, iwp, r, eplin, ynew, ypnew, pwk,
8 * icnflg, icnstr, rlx, rpar, ipar)
79 IMPLICIT DOUBLE PRECISION(a-
h,o-z)
81 dimension y(*), yprime(*), p(*), wt(*), savr(*), r(*), id(*)
82 dimension wm(*), iwm(*), ynew(*), ypnew(*), pwk(*), icnstr(*)
86 parameter(lnre=12, lnps=21, lkprin=31)
89 DATA alpha/1.0
d-4/, one/1.0d0/, two/2.0d0/
92 f1nrm = (fnrm*fnrm)/two
95 IF (kprin .GE. 2)
THEN
96 msg =
'------ IN ROUTINE DLINSK-- PNRM = (R1) )'
97 CALL
xerrwd(msg, 40, 921, 0, 0, 0, 0, 1, pnrm, 0.0d0)
107 IF (icnflg .NE. 0)
THEN
109 CALL
dyypnw(neq,y,yprime,cj,rl,p,icopt,id,ynew,ypnew)
110 CALL
dcnstr(neq, y, ynew, icnstr,
tau, rlx, iret, ivar)
111 IF (iret .EQ. 1)
THEN
116 20 p(i) = p(i)*ratio1
118 IF (kprin .GE. 2)
THEN
119 msg =
'------ CONSTRAINT VIOL., PNRM = (R1), INDEX = (I1)'
120 CALL
xerrwd(msg, 50, 922, 0, 1, ivar, 0, 1, pnrm, 0.0d0)
122 IF (pnrm .LE. stptol)
THEN
130 slpi = (-two*f1nrm + rhok*rhok)*ratio
132 IF (lsoff .EQ. 0 .AND. kprin .GE. 2)
THEN
133 msg =
'------ MIN. LAMBDA = (R1)'
134 CALL
xerrwd(msg, 25, 923, 0, 0, 0, 0, 1, rlmin, 0.0d0)
142 CALL
dyypnw(neq,y,yprime,cj,rl,p,icopt,id,ynew,ypnew)
143 CALL
dfnrmk(neq, ynew, t, ypnew, savr, r, cj, wt, sqrtn, rsqrtn,
144 * res, ires, psol, 0, ier, fnrmp, eplin, wp, iwp, pwk, rpar, ipar)
145 iwm(lnre) = iwm(lnre) + 1
146 IF (ires .GE. 0) iwm(lnps) = iwm(lnps) + 1
147 IF (ires .NE. 0 .OR. ier .NE. 0)
THEN
151 IF (lsoff .EQ. 1) go
to 150
153 f1nrmp = fnrmp*fnrmp/two
154 IF (kprin .GE. 2)
THEN
155 msg =
'------ LAMBDA = (R1)'
156 CALL
xerrwd(msg, 20, 924, 0, 0, 0, 0, 1, rl, 0.0d0)
157 msg =
'------ NORM(F1) = (R1), NORM(F1NEW) = (R2)'
158 CALL
xerrwd(msg, 43, 925, 0, 0, 0, 0, 2, f1nrm, f1nrmp)
160 IF (f1nrmp .GT. f1nrm +
alpha*slpi*rl) go
to 200
166 CALL dcopy(neq, ynew, 1, y, 1)
167 CALL dcopy(neq, ypnew, 1, yprime, 1)
169 IF (kprin .GE. 1)
THEN
170 msg =
'------ LEAVING ROUTINE DLINSK, FNRM = (R1)'
171 CALL
xerrwd(msg, 42, 926, 0, 0, 0, 0, 1, fnrm, 0.0d0)
180 IF (rl .LT. rlmin)
THEN
subroutine xerrwd(MSG, NMES, NERR, LEVEL, NI, I1, I2, NR, R1, R2)
F77_RET_T F77_REAL &F77_RET_T F77_DBLE &F77_RET_T F77_REAL &F77_RET_T F77_DBLE &F77_RET_T F77_REAL &F77_RET_T F77_DBLE &F77_RET_T const F77_REAL const F77_REAL F77_REAL &F77_RET_T const F77_DBLE const F77_DBLE F77_DBLE &F77_RET_T F77_REAL &F77_RET_T F77_DBLE &F77_RET_T F77_DBLE &F77_RET_T F77_REAL &F77_RET_T F77_REAL &F77_RET_T F77_DBLE &F77_RET_T const F77_DBLE F77_DBLE &F77_RET_T const F77_REAL F77_REAL &F77_RET_T F77_REAL F77_REAL &F77_RET_T F77_DBLE F77_DBLE &F77_RET_T const F77_DBLE const F77_DBLE F77_DBLE * d
void tau(int code, int p, int q)
subroutine dyypnw(NEQ, Y, YPRIME, CJ, RL, P, ICOPT, ID, YNEW, YPNEW)
subroutine dlinsk(NEQ, Y, T, YPRIME, SAVR, CJ, P, PNRM, WT, SQRTN, RSQRTN, LSOFF, STPTOL, IRET, RES, IRES, PSOL, WM, IWM, RHOK, FNRM, ICOPT, ID, WP, IWP, R, EPLIN, YNEW, YPNEW, PWK, ICNFLG, ICNSTR, RLX, RPAR, IPAR)
subroutine dcnstr(NEQ, Y, YNEW, ICNSTR, TAU, RLX, IRET, IVAR)
subroutine dfnrmk(NEQ, Y, T, YPRIME, SAVR, R, CJ, WT, SQRTN, RSQRTN, RES, IRES, PSOL, IRIN, IER, FNORM, EPLIN, WP, IWP, PWK, RPAR, IPAR)
may be zero for pure relative error test tem the relative tolerance must be greater than or equal to
OCTAVE_EXPORT octave_value_list etc The functions then dimension(columns)