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.0d-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 OCTAVE_EXPORT octave_value_list etc The functions then dimension(columns)