19 SUBROUTINE hbrd(fcn, n, x, fvec, epsfcn, tol, info, diag)
24 INTEGER,
INTENT(IN) :: n
25 REAL (dp),
INTENT(IN OUT) :: x(n)
26 REAL (dp),
INTENT(IN OUT) :: fvec(n)
27 REAL (dp),
INTENT(IN) :: epsfcn
28 REAL (dp),
INTENT(IN) :: tol
29 INTEGER,
INTENT(OUT) :: info
30 REAL (dp),
INTENT(OUT) :: diag(n)
34 SUBROUTINE fcn(N, X, FVEC, IFLAG)
35 use constants
, only:dp
37 INTEGER,
INTENT(IN) :: n
38 REAL (dp),
INTENT(IN) :: x(n)
39 REAL (dp),
INTENT(OUT) :: fvec(n)
40 INTEGER,
INTENT(IN OUT) :: iflag
128 INTEGER :: maxfev, ml, mode, mu, nfev, nprint
130 REAL (dp),
PARAMETER :: factor = 100.0_dp, zero = 0.0_dp
137 IF (n <= 0 .OR. epsfcn < zero .OR. tol < zero)
GO TO 20
147 CALL hybrd(fcn, n, x, fvec, xtol, maxfev, ml, mu, epsfcn, diag, mode, &
148 factor, nprint, info, nfev)
149 IF (info == 5) info = 4
158 SUBROUTINE hybrd(fcn, n, x, fvec, xtol, maxfev, ml, mu, epsfcn, diag, mode, &
159 factor, nprint, info, nfev)
161 INTEGER,
INTENT(IN) :: n
162 REAL (dp),
INTENT(IN OUT) :: x(n)
163 REAL (dp),
INTENT(IN OUT) :: fvec(n)
164 REAL (dp),
INTENT(IN) :: xtol
165 INTEGER,
INTENT(IN OUT) :: maxfev
166 INTEGER,
INTENT(IN OUT) :: ml
167 INTEGER,
INTENT(IN) :: mu
168 REAL (dp),
INTENT(IN) :: epsfcn
169 REAL (dp),
INTENT(OUT) :: diag(n)
170 INTEGER,
INTENT(IN) :: mode
171 REAL (dp),
INTENT(IN) :: factor
172 INTEGER,
INTENT(IN OUT) :: nprint
173 INTEGER,
INTENT(OUT) :: info
174 INTEGER,
INTENT(OUT) :: nfev
178 SUBROUTINE fcn(N, X, FVEC, IFLAG)
179 use constants
, only:dp
181 INTEGER,
INTENT(IN) :: n
182 REAL (dp),
INTENT(IN) :: x(n)
183 REAL (dp),
INTENT(OUT) :: fvec(n)
184 INTEGER,
INTENT(IN OUT) :: iflag
333 INTEGER :: i, iflag, iter, j, jm1, l, lr, msum, ncfail, ncsuc, nslow1, &
336 LOGICAL :: jeval, sing
337 REAL (dp) :: actred, delta, epsmch, fnorm, fnorm1, pnorm, prered, &
338 ratio, sum, temp, xnorm
339 REAL (dp),
PARAMETER :: one = 1.0_dp, p1 = 0.1_dp, p5 = 0.5_dp, &
340 p001 = 0.001_dp, p0001 = 0.0001_dp, zero = 0.0_dp
343 REAL (dp) :: fjac(n,n), r(n*(n+1)/2), qtf(n), wa1(n), wa2(n), &
348 epsmch = epsilon(1.0_dp)
357 IF (n > 0 .AND. xtol >= zero .AND. maxfev > 0 .AND. ml >= 0 .AND. mu >= &
358 0 .AND. factor > zero )
THEN 366 CALL fcn(n, x, fvec, iflag)
369 fnorm = enorm(n, fvec)
373 msum = min(ml+mu+1,n)
390 CALL fdjac1(fcn, n, x, fvec, fjac, n, iflag, ml, mu, epsfcn, wa1, wa2)
396 CALL qrfac(n, n, fjac, n, .false., iwa, 1, wa1, wa2, wa3)
405 IF (wa2(j) == zero) diag(j) = one
412 wa3(1:n) = diag(1:n) * x(1:n)
413 xnorm = enorm(n, wa3)
414 delta = factor * xnorm
415 IF (delta == zero) delta = factor
422 IF (fjac(j,j) /= zero)
THEN 425 sum = sum + fjac(i,j) * qtf(i)
427 temp = -sum / fjac(j,j)
429 qtf(i) = qtf(i) + fjac(i,j) * temp
447 IF (wa1(j) == zero) sing = .true.
452 CALL qform(n, n, fjac, n, wa1)
458 diag(j) = max(diag(j), wa2(j))
466 120
IF (nprint > 0)
THEN 468 IF (mod(iter-1, nprint) == 0)
CALL fcn(n, x, fvec, iflag)
469 IF (iflag < 0)
GO TO 190
474 CALL dogleg(n, r, lr, diag, qtf, delta, wa1, wa2, wa3)
480 wa2(j) = x(j) + wa1(j)
481 wa3(j) = diag(j) * wa1(j)
483 pnorm = enorm(n, wa3)
487 IF (iter == 1) delta = min(delta, pnorm)
492 CALL fcn(n, wa2, wa4, iflag)
495 fnorm1 = enorm(n, wa4)
500 IF (fnorm1 < fnorm) actred = one - (fnorm1/fnorm) ** 2
508 sum = sum + r(l) * wa1(j)
511 wa3(i) = qtf(i) + sum
515 IF (temp < fnorm) prered = one - (temp/fnorm) ** 2
520 IF (prered > zero) ratio = actred / prered
531 IF (ratio >= p5 .OR. ncsuc > 1) delta = max(delta,pnorm/p5)
532 IF (abs(ratio-one) <= p1) delta = pnorm / p5
537 IF (ratio >= p0001)
THEN 543 wa2(j) = diag(j) * x(j)
546 xnorm = enorm(n, wa2)
554 IF (actred >= p001) nslow1 = 0
555 IF (jeval) nslow2 = nslow2 + 1
556 IF (actred >= p1) nslow2 = 0
560 IF (delta <= xtol*xnorm .OR. fnorm == zero) info = 1
565 IF (nfev >= maxfev) info = 2
566 IF (p1*max(p1*delta, pnorm) <= epsmch*xnorm) info = 3
567 IF (nslow2 == 5) info = 4
568 IF (nslow1 == 10) info = 5
574 IF (ncfail /= 2)
THEN 582 sum = sum + fjac(i,j) * wa4(i)
584 wa2(j) = (sum-wa3(j)) / pnorm
585 wa1(j) = diag(j) * ((diag(j)*wa1(j))/pnorm)
586 IF (ratio >= p0001) qtf(j) = sum
591 CALL r1updt(n, n, r, lr, wa1, wa2, wa3, sing)
592 CALL r1mpyq(n, n, fjac, n, wa2, wa3)
593 CALL r1mpyq(1, n, qtf, 1, wa2, wa3)
613 190
IF (iflag < 0) info = iflag
615 IF (nprint > 0)
CALL fcn(n, x, fvec, iflag)
624 SUBROUTINE dogleg(n, r, lr, diag, qtb, delta, x, wa1, wa2)
626 INTEGER,
INTENT(IN) :: n
627 INTEGER,
INTENT(IN) :: lr
628 REAL (dp),
INTENT(IN) :: r(lr)
629 REAL (dp),
INTENT(IN) :: diag(n)
630 REAL (dp),
INTENT(IN) :: qtb(n)
631 REAL (dp),
INTENT(IN) :: delta
632 REAL (dp),
INTENT(IN OUT) :: x(n)
633 REAL (dp),
INTENT(OUT) :: wa1(n)
634 REAL (dp),
INTENT(OUT) :: wa2(n)
694 INTEGER :: i, j, jj, jp1, k, l
695 REAL (dp) :: alpha, bnorm, epsmch, gnorm, qnorm, sgnorm, sum, temp
699 epsmch = epsilon(1.0_dp)
703 jj = (n*(n+1)) / 2 + 1
712 sum = sum + r(l) * x(i)
717 IF (temp == 0.0_dp)
THEN 720 temp = max(temp,abs(r(l)))
724 IF (temp == 0.0_dp) temp = epsmch
726 x(j) = (qtb(j)-sum) / temp
733 wa2(j) = diag(j) * x(j)
735 qnorm = enorm(n, wa2)
736 IF (qnorm > delta)
THEN 745 wa1(i) = wa1(i) + r(l) * temp
748 wa1(j) = wa1(j) / diag(j)
754 gnorm = enorm(n, wa1)
756 alpha = delta / qnorm
757 IF (gnorm /= 0.0_dp)
THEN 763 wa1(j) = (wa1(j)/gnorm) / diag(j)
769 sum = sum + r(l) * wa1(i)
775 sgnorm = (gnorm/temp) / temp
780 IF (sgnorm < delta)
THEN 786 bnorm = enorm(n, qtb)
787 temp = (bnorm/gnorm) * (bnorm/qnorm) * (sgnorm/delta)
788 temp = temp - (delta/qnorm) * (sgnorm/delta) ** 2 + sqrt(( &
789 temp-(delta/qnorm))**2+(1.0_dp-(delta/qnorm)**2)*(1.0_dp-( sgnorm/delta)**2))
790 alpha = ((delta/qnorm)*(1.0_dp-(sgnorm/delta)**2)) / temp
797 temp = (1.0_dp-alpha) * min(sgnorm,delta)
799 x(j) = temp * wa1(j) + alpha * x(j)
803 END SUBROUTINE dogleg
806 SUBROUTINE fdjac1(fcn, n, x, fvec, fjac, ldfjac, iflag, ml, mu, epsfcn, &
809 INTEGER,
INTENT(IN) :: n
810 REAL (dp),
INTENT(IN OUT) :: x(n)
811 REAL (dp),
INTENT(IN) :: fvec(n)
812 INTEGER,
INTENT(IN) :: ldfjac
813 REAL (dp),
INTENT(OUT) :: fjac(ldfjac,n)
814 INTEGER,
INTENT(IN OUT) :: iflag
815 INTEGER,
INTENT(IN) :: ml
816 INTEGER,
INTENT(IN) :: mu
817 REAL (dp),
INTENT(IN) :: epsfcn
818 REAL (dp),
INTENT(IN OUT) :: wa1(n)
819 REAL (dp),
INTENT(OUT) :: wa2(n)
823 SUBROUTINE fcn(N, X, FVEC, IFLAG)
824 use constants
, only:dp
826 INTEGER,
INTENT(IN) :: n
827 REAL (dp),
INTENT(IN) :: x(n)
828 REAL (dp),
INTENT(OUT) :: fvec(n)
829 INTEGER,
INTENT(IN OUT) :: iflag
915 INTEGER :: i, j, k, msum
916 REAL (dp) :: eps, epsmch, h, temp
917 REAL (dp),
PARAMETER :: zero = 0.0_dp
921 epsmch = epsilon(1.0_dp)
923 eps = sqrt(max(epsfcn, epsmch))
932 IF (h == zero) h = eps
934 CALL fcn(n, x, wa1, iflag)
938 fjac(i,j) = (wa1(i)-fvec(i)) / h
948 h = eps * abs(wa2(j))
949 IF (h == zero) h = eps
952 CALL fcn(n, x, wa1, iflag)
956 h = eps * abs(wa2(j))
957 IF (h == zero) h = eps
960 IF (i >= j-mu .AND. i <= j+ml) fjac(i,j) = (wa1(i)-fvec(i)) / h
969 END SUBROUTINE fdjac1
973 SUBROUTINE qform(m, n, q, ldq, wa)
975 INTEGER,
INTENT(IN) :: m
976 INTEGER,
INTENT(IN) :: n
977 INTEGER,
INTENT(IN) :: ldq
978 REAL (dp),
INTENT(OUT) :: q(ldq,m)
979 REAL (dp),
INTENT(OUT) :: wa(m)
1017 INTEGER :: i, j, jm1, k, l, minmn, np1
1018 REAL (dp) :: sum, temp
1019 REAL (dp),
PARAMETER :: one = 1.0_dp, zero = 0.0_dp
1024 IF (minmn >= 2)
THEN 1054 IF (wa(k) /= zero)
THEN 1058 sum = sum + q(i,j) * wa(i)
1062 q(i,j) = q(i,j) - temp * wa(i)
1071 END SUBROUTINE qform
1074 SUBROUTINE qrfac(m, n, a, lda, pivot, ipvt, lipvt, rdiag, acnorm, wa)
1076 INTEGER,
INTENT(IN) :: m
1077 INTEGER,
INTENT(IN) :: n
1078 INTEGER,
INTENT(IN) :: lda
1079 REAL (dp),
INTENT(IN OUT) :: a(lda,n)
1080 LOGICAL,
INTENT(IN) :: pivot
1081 INTEGER,
INTENT(IN) :: lipvt
1082 INTEGER,
INTENT(OUT) :: ipvt(lipvt)
1083 REAL (dp),
INTENT(OUT) :: rdiag(n)
1084 REAL (dp),
INTENT(OUT) :: acnorm(n)
1085 REAL (dp),
INTENT(OUT) :: wa(n)
1159 INTEGER :: i, j, jp1, k, kmax, minmn
1160 REAL (dp) :: ajnorm, epsmch, sum, temp
1161 REAL (dp),
PARAMETER :: one = 1.0_dp, p05 = 0.05_dp, zero = 0.0_dp
1165 epsmch = epsilon(1.0_dp)
1170 acnorm(j) = enorm(m, a(1:,j))
1171 rdiag(j) = acnorm(j)
1173 IF (pivot) ipvt(j) = j
1186 IF (rdiag(k) > rdiag(kmax)) kmax = k
1194 rdiag(kmax) = rdiag(j)
1197 ipvt(j) = ipvt(kmax)
1205 ajnorm = enorm(m-j+1, a(j:,j))
1206 IF (ajnorm /= zero)
THEN 1207 IF (a(j,j) < zero) ajnorm = -ajnorm
1209 a(i,j) = a(i,j) / ajnorm
1211 a(j,j) = a(j,j) + one
1220 sum = sum + a(i,j) * a(i,k)
1224 a(i,k) = a(i,k) - temp * a(i,j)
1226 IF (.NOT.(.NOT.pivot.OR.rdiag(k) == zero))
THEN 1227 temp = a(j,k) / rdiag(k)
1228 rdiag(k) = rdiag(k) * sqrt(max(zero,one-temp**2))
1229 IF (p05*(rdiag(k)/wa(k))**2 <= epsmch)
THEN 1230 rdiag(k) = enorm(m-j, a(jp1:,k))
1243 END SUBROUTINE qrfac
1247 SUBROUTINE r1mpyq(m, n, a, lda, v, w)
1249 INTEGER,
INTENT(IN) :: m
1250 INTEGER,
INTENT(IN) :: n
1251 INTEGER,
INTENT(IN) :: lda
1252 REAL (dp),
INTENT(IN OUT) :: a(lda,n)
1253 REAL (dp),
INTENT(IN) :: v(n)
1254 REAL (dp),
INTENT(IN) :: w(n)
1302 INTEGER :: i, j, nmj, nm1
1303 REAL (dp) :: COS, SIN, temp
1304 REAL (dp),
PARAMETER :: one = 1.0_dp
1312 IF (abs(v(j)) > one) cos = one / v(j)
1313 IF (abs(v(j)) > one) sin = sqrt(one-cos**2)
1314 IF (abs(v(j)) <= one) sin = v(j)
1315 IF (abs(v(j)) <= one) cos = sqrt(one-sin**2)
1317 temp = cos * a(i,j) - sin * a(i,n)
1318 a(i,n) = sin * a(i,j) + cos * a(i,n)
1326 IF (abs(w(j)) > one) cos = one / w(j)
1327 IF (abs(w(j)) > one) sin = sqrt(one-cos**2)
1328 IF (abs(w(j)) <= one) sin = w(j)
1329 IF (abs(w(j)) <= one) cos = sqrt(one-sin**2)
1331 temp = cos * a(i,j) + sin * a(i,n)
1332 a(i,n) = -sin * a(i,j) + cos * a(i,n)
1341 END SUBROUTINE r1mpyq
1345 SUBROUTINE r1updt(m, n, s, ls, u, v, w, sing)
1347 INTEGER,
INTENT(IN) :: m
1348 INTEGER,
INTENT(IN) :: n
1349 INTEGER,
INTENT(IN) :: ls
1350 REAL (dp),
INTENT(IN OUT) :: s(ls)
1351 REAL (dp),
INTENT(IN) :: u(m)
1352 REAL (dp),
INTENT(IN OUT) :: v(n)
1353 REAL (dp),
INTENT(OUT) :: w(m)
1354 LOGICAL,
INTENT(OUT) :: sing
1420 INTEGER :: i, j, jj, l, nmj, nm1
1421 REAL (dp) :: COS, cotan, giant, SIN, TAN, tau, temp
1422 REAL (dp),
PARAMETER :: one = 1.0_dp, p5 = 0.5_dp, p25 = 0.25_dp, zero = 0.0_dp
1426 giant = huge(1.0_dp)
1430 jj = (n*(2*m-n+1)) / 2 - (m-n)
1449 IF (v(j) /= zero)
THEN 1453 IF (abs(v(n)) < abs(v(j)))
THEN 1455 sin = p5 / sqrt(p25+p25*cotan**2)
1458 IF (abs(cos)*giant > one) tau = one / cos
1461 cos = p5 / sqrt(p25+p25*tan**2)
1469 v(n) = sin * v(j) + cos * v(n)
1476 temp = cos * s(l) - sin * w(i)
1477 w(i) = sin * s(l) + cos * w(i)
1488 w(i) = w(i) + v(n) * u(i)
1496 IF (w(j) /= zero)
THEN 1501 IF (abs(s(jj)) < abs(w(j)))
THEN 1502 cotan = s(jj) / w(j)
1503 sin = p5 / sqrt(p25 + p25*cotan**2)
1506 IF (abs(cos)*giant > one) tau = one / cos
1509 cos = p5 / sqrt(p25+p25*tan**2)
1518 temp = cos * s(l) + sin * w(i)
1519 w(i) = -sin * s(l) + cos * w(i)
1531 IF (s(jj) == zero) sing = .true.
1543 IF (s(jj) == zero) sing = .true.
1548 END SUBROUTINE r1updt
1551 FUNCTION enorm(n, x)
RESULT(fn_val)
1553 INTEGER,
INTENT(IN) :: n
1554 REAL (dp),
INTENT(IN) :: x(n)
1592 REAL (dp) :: agiant, floatn, s1, s2, s3, xabs, x1max, x3max
1593 REAL (dp),
PARAMETER :: rdwarf = 1.0d-100, rgiant = 1.0d+100
1601 agiant = rgiant / floatn
1604 IF (xabs <= rdwarf .OR. xabs >= agiant)
THEN 1605 IF (xabs > rdwarf)
THEN 1609 IF (xabs > x1max)
THEN 1610 s1 = 1.0_dp + s1 * (x1max/xabs) ** 2
1613 s1 = s1 + (xabs/x1max) ** 2
1619 IF (xabs > x3max)
THEN 1620 s3 = 1.0_dp + s3 * (x3max/xabs) ** 2
1623 IF (xabs /= 0.0_dp) s3 = s3 + (xabs/x3max) ** 2
1636 IF (s1 /= 0.0_dp)
THEN 1637 fn_val = x1max * sqrt(s1 + (s2/x1max)/x1max)
1639 IF (s2 /= 0.0_dp)
THEN 1640 IF (s2 >= x3max) fn_val = sqrt(s2*(1.0_dp + (x3max/s2)*(x3max*s3)))
1641 IF (s2 < x3max) fn_val = sqrt(x3max*((s2/x3max) + (x3max*s3)))
1643 fn_val = x3max * sqrt(s3)
1649 END MODULE solve_nonlin