5 SUBROUTINE dlinsd (NEQ, Y, T, YPRIME, CJ, P, PNRM, WT, LSOFF,
6 * STPTOL, IRET, RES, IRES, WM, IWM,
7 * FNRM, ICOPT, ID, R, YNEW, YPNEW, ICNFLG,
8 * ICNSTR, RLX, RPAR, IPAR)
73 IMPLICIT DOUBLE PRECISION(a-h,o-z)
75 dimension y(*), yprime(*), wt(*), r(*), id(*)
77 dimension ynew(*), ypnew(*), p(*), icnstr(*)
81 parameter(lnre=12, lkprin=31)
84 DATA alpha/1.0d-4/, one/1.0d0/, two/2.0d0/
88 f1nrm = (fnrm*fnrm)/two
90 IF (kprin .GE. 2)
THEN 91 msg =
'------ IN ROUTINE DLINSD-- PNRM = (R1) )' 92 CALL xerrwd(msg, 40, 901, 0, 0, 0, 0, 1, pnrm, 0.0d0)
102 IF (icnflg .NE. 0)
THEN 104 CALL dyypnw (neq,y,yprime,cj,rl,p,icopt,id,ynew,ypnew)
105 CALL dcnstr (neq, y, ynew, icnstr, tau, rlx, iret, ivar)
106 IF (iret .EQ. 1)
THEN 111 20 p(i) = p(i)*ratio1
113 IF (kprin .GE. 2)
THEN 114 msg =
'------ CONSTRAINT VIOL., PNRM = (R1), INDEX = (I1)' 115 CALL xerrwd(msg, 50, 902, 0, 1, ivar, 0, 1, pnrm, 0.0d0)
117 IF (pnrm .LE. stptol)
THEN 125 slpi = (-two*f1nrm)*ratio
127 IF (lsoff .EQ. 0 .AND. kprin .GE. 2)
THEN 128 msg =
'------ MIN. LAMBDA = (R1)' 129 CALL xerrwd(msg, 25, 903, 0, 0, 0, 0, 1, rlmin, 0.0d0)
136 CALL dyypnw (neq,y,yprime,cj,rl,p,icopt,id,ynew,ypnew)
137 CALL dfnrmd (neq, ynew, t, ypnew, r, cj, wt, res, ires,
138 * fnrmp, wm, iwm, rpar, ipar)
139 iwm(lnre) = iwm(lnre) + 1
140 IF (ires .NE. 0)
THEN 144 IF (lsoff .EQ. 1)
GO TO 150
146 f1nrmp = fnrmp*fnrmp/two
147 IF (kprin .GE. 2)
THEN 148 msg =
'------ LAMBDA = (R1)' 149 CALL xerrwd(msg, 20, 904, 0, 0, 0, 0, 1, rl, 0.0d0)
150 msg =
'------ NORM(F1) = (R1), NORM(F1NEW) = (R2)' 151 CALL xerrwd(msg, 43, 905, 0, 0, 0, 0, 2, f1nrm, f1nrmp)
153 IF (f1nrmp .GT. f1nrm + alpha*slpi*rl)
GO TO 200
159 CALL dcopy (neq, ynew, 1, y, 1)
160 CALL dcopy (neq, ypnew, 1, yprime, 1)
162 IF (kprin .GE. 1)
THEN 163 msg =
'------ LEAVING ROUTINE DLINSD, FNRM = (R1)' 164 CALL xerrwd(msg, 42, 906, 0, 0, 0, 0, 1, fnrm, 0.0d0)
173 IF (rl .LT. rlmin)
THEN OCTAVE_EXPORT octave_value_list etc The functions then dimension(columns)