From f8654923c8303799fe6fdd8b90777462109d7416 Mon Sep 17 00:00:00 2001 From: Ondrej Certik Date: Fri, 24 Feb 2012 18:22:12 -0800 Subject: [PATCH 01/30] Add current minpack from netlib.org --- LICENSE | 51 + chkder.f | 140 ++ chkdrv.f | 87 + covar.f | 145 ++ depend | 226 +++ dmchar.f | 212 +++ dogleg.f | 177 ++ dpmpar.f | 177 ++ enorm.f | 108 ++ errjac.f | 333 ++++ ex/file01 | 145 ++ ex/file02 | 4771 ++++++++++++++++++++++++++++++++++++++++++++++++++++ ex/file03 | 3526 +++++++++++++++++++++++++++++++++++++++ ex/file04 | 192 +++ ex/file05 | 4778 +++++++++++++++++++++++++++++++++++++++++++++++++++++ ex/file06 | 3528 +++++++++++++++++++++++++++++++++++++++ ex/file07 | 283 ++++ ex/file08 | 551 ++++++ ex/file09 | 879 ++++++++++ ex/file10 | 1022 ++++++++++++ ex/file11 | 1033 ++++++++++++ ex/file12 | 673 ++++++++ ex/file13 | 858 ++++++++++ ex/file14 | 284 ++++ ex/file15 | 552 +++++++ ex/file16 | 881 ++++++++++ ex/file17 | 1025 ++++++++++++ ex/file18 | 1036 ++++++++++++ ex/file19 | 675 ++++++++ ex/file20 | 860 ++++++++++ ex/file21 | 23 + ex/file22 | 29 + ex/file23 | 15 + fdjac1.f | 151 ++ fdjac2.f | 107 ++ grdfcn.f | 438 +++++ hesfcn.f | 651 ++++++++ hybdrv.f | 112 ++ hybipt.f | 167 ++ hybrd.f | 459 +++++ hybrd1.f | 123 ++ hybrj.f | 440 +++++ hybrj1.f | 127 ++ hyjdrv.f | 120 ++ ibmdpdr.f | 72 + lhesfcn.f | 663 ++++++++ lmddrv.f | 124 ++ lmder.f | 452 +++++ lmder1.f | 156 ++ lmdif.f | 454 +++++ lmdif1.f | 135 ++ lmdipt.f | 214 +++ lmfdrv.f | 121 ++ lmpar.f | 264 +++ lmsdrv.f | 135 ++ lmstr.f | 466 ++++++ lmstr1.f | 156 ++ makefile | 51 + objfcn.f | 342 ++++ ocpipt.f | 223 +++ qform.f | 95 ++ qrfac.f | 164 ++ qrsolv.f | 193 +++ r1mpyq.f | 92 ++ r1updt.f | 207 +++ readme | 18 + rwupdt.f | 113 ++ ssqfcn.f | 340 ++++ ssqjac.f | 347 ++++ ucodrv.f | 122 ++ vecfcn.f | 273 +++ vecjac.f | 321 ++++ 72 files changed, 38483 insertions(+) create mode 100644 LICENSE create mode 100644 chkder.f create mode 100644 chkdrv.f create mode 100644 covar.f create mode 100644 depend create mode 100644 dmchar.f create mode 100644 dogleg.f create mode 100644 dpmpar.f create mode 100644 enorm.f create mode 100644 errjac.f create mode 100644 ex/file01 create mode 100644 ex/file02 create mode 100644 ex/file03 create mode 100644 ex/file04 create mode 100644 ex/file05 create mode 100644 ex/file06 create mode 100644 ex/file07 create mode 100644 ex/file08 create mode 100644 ex/file09 create mode 100644 ex/file10 create mode 100644 ex/file11 create mode 100644 ex/file12 create mode 100644 ex/file13 create mode 100644 ex/file14 create mode 100644 ex/file15 create mode 100644 ex/file16 create mode 100644 ex/file17 create mode 100644 ex/file18 create mode 100644 ex/file19 create mode 100644 ex/file20 create mode 100644 ex/file21 create mode 100644 ex/file22 create mode 100644 ex/file23 create mode 100644 fdjac1.f create mode 100644 fdjac2.f create mode 100644 grdfcn.f create mode 100644 hesfcn.f create mode 100644 hybdrv.f create mode 100644 hybipt.f create mode 100644 hybrd.f create mode 100644 hybrd1.f create mode 100644 hybrj.f create mode 100644 hybrj1.f create mode 100644 hyjdrv.f create mode 100644 ibmdpdr.f create mode 100644 lhesfcn.f create mode 100644 lmddrv.f create mode 100644 lmder.f create mode 100644 lmder1.f create mode 100644 lmdif.f create mode 100644 lmdif1.f create mode 100644 lmdipt.f create mode 100644 lmfdrv.f create mode 100644 lmpar.f create mode 100644 lmsdrv.f create mode 100644 lmstr.f create mode 100644 lmstr1.f create mode 100644 makefile create mode 100644 objfcn.f create mode 100644 ocpipt.f create mode 100644 qform.f create mode 100644 qrfac.f create mode 100644 qrsolv.f create mode 100644 r1mpyq.f create mode 100644 r1updt.f create mode 100644 readme create mode 100644 rwupdt.f create mode 100644 ssqfcn.f create mode 100644 ssqjac.f create mode 100644 ucodrv.f create mode 100644 vecfcn.f create mode 100644 vecjac.f diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..132cc3f --- /dev/null +++ b/LICENSE @@ -0,0 +1,51 @@ +Minpack Copyright Notice (1999) University of Chicago. All rights reserved + +Redistribution and use in source and binary forms, with or +without modification, are permitted provided that the +following conditions are met: + +1. Redistributions of source code must retain the above +copyright notice, this list of conditions and the following +disclaimer. + +2. Redistributions in binary form must reproduce the above +copyright notice, this list of conditions and the following +disclaimer in the documentation and/or other materials +provided with the distribution. + +3. The end-user documentation included with the +redistribution, if any, must include the following +acknowledgment: + + "This product includes software developed by the + University of Chicago, as Operator of Argonne National + Laboratory. + +Alternately, this acknowledgment may appear in the software +itself, if and wherever such third-party acknowledgments +normally appear. + +4. WARRANTY DISCLAIMER. THE SOFTWARE IS SUPPLIED "AS IS" +WITHOUT WARRANTY OF ANY KIND. THE COPYRIGHT HOLDER, THE +UNITED STATES, THE UNITED STATES DEPARTMENT OF ENERGY, AND +THEIR EMPLOYEES: (1) DISCLAIM ANY WARRANTIES, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO ANY IMPLIED WARRANTIES +OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE, TITLE +OR NON-INFRINGEMENT, (2) DO NOT ASSUME ANY LEGAL LIABILITY +OR RESPONSIBILITY FOR THE ACCURACY, COMPLETENESS, OR +USEFULNESS OF THE SOFTWARE, (3) DO NOT REPRESENT THAT USE OF +THE SOFTWARE WOULD NOT INFRINGE PRIVATELY OWNED RIGHTS, (4) +DO NOT WARRANT THAT THE SOFTWARE WILL FUNCTION +UNINTERRUPTED, THAT IT IS ERROR-FREE OR THAT ANY ERRORS WILL +BE CORRECTED. + +5. LIMITATION OF LIABILITY. IN NO EVENT WILL THE COPYRIGHT +HOLDER, THE UNITED STATES, THE UNITED STATES DEPARTMENT OF +ENERGY, OR THEIR EMPLOYEES: BE LIABLE FOR ANY INDIRECT, +INCIDENTAL, CONSEQUENTIAL, SPECIAL OR PUNITIVE DAMAGES OF +ANY KIND OR NATURE, INCLUDING BUT NOT LIMITED TO LOSS OF +PROFITS OR LOSS OF DATA, FOR ANY REASON WHATSOEVER, WHETHER +SUCH LIABILITY IS ASSERTED ON THE BASIS OF CONTRACT, TORT +(INCLUDING NEGLIGENCE OR STRICT LIABILITY), OR OTHERWISE, +EVEN IF ANY OF SAID PARTIES HAS BEEN WARNED OF THE +POSSIBILITY OF SUCH LOSS OR DAMAGES. diff --git a/chkder.f b/chkder.f new file mode 100644 index 0000000..29578fc --- /dev/null +++ b/chkder.f @@ -0,0 +1,140 @@ + subroutine chkder(m,n,x,fvec,fjac,ldfjac,xp,fvecp,mode,err) + integer m,n,ldfjac,mode + double precision x(n),fvec(m),fjac(ldfjac,n),xp(n),fvecp(m), + * err(m) +c ********** +c +c subroutine chkder +c +c this subroutine checks the gradients of m nonlinear functions +c in n variables, evaluated at a point x, for consistency with +c the functions themselves. the user must call chkder twice, +c first with mode = 1 and then with mode = 2. +c +c mode = 1. on input, x must contain the point of evaluation. +c on output, xp is set to a neighboring point. +c +c mode = 2. on input, fvec must contain the functions and the +c rows of fjac must contain the gradients +c of the respective functions each evaluated +c at x, and fvecp must contain the functions +c evaluated at xp. +c on output, err contains measures of correctness of +c the respective gradients. +c +c the subroutine does not perform reliably if cancellation or +c rounding errors cause a severe loss of significance in the +c evaluation of a function. therefore, none of the components +c of x should be unusually small (in particular, zero) or any +c other value which may cause loss of significance. +c +c the subroutine statement is +c +c subroutine chkder(m,n,x,fvec,fjac,ldfjac,xp,fvecp,mode,err) +c +c where +c +c m is a positive integer input variable set to the number +c of functions. +c +c n is a positive integer input variable set to the number +c of variables. +c +c x is an input array of length n. +c +c fvec is an array of length m. on input when mode = 2, +c fvec must contain the functions evaluated at x. +c +c fjac is an m by n array. on input when mode = 2, +c the rows of fjac must contain the gradients of +c the respective functions evaluated at x. +c +c ldfjac is a positive integer input parameter not less than m +c which specifies the leading dimension of the array fjac. +c +c xp is an array of length n. on output when mode = 1, +c xp is set to a neighboring point of x. +c +c fvecp is an array of length m. on input when mode = 2, +c fvecp must contain the functions evaluated at xp. +c +c mode is an integer input variable set to 1 on the first call +c and 2 on the second. other values of mode are equivalent +c to mode = 1. +c +c err is an array of length m. on output when mode = 2, +c err contains measures of correctness of the respective +c gradients. if there is no severe loss of significance, +c then if err(i) is 1.0 the i-th gradient is correct, +c while if err(i) is 0.0 the i-th gradient is incorrect. +c for values of err between 0.0 and 1.0, the categorization +c is less certain. in general, a value of err(i) greater +c than 0.5 indicates that the i-th gradient is probably +c correct, while a value of err(i) less than 0.5 indicates +c that the i-th gradient is probably incorrect. +c +c subprograms called +c +c minpack supplied ... dpmpar +c +c fortran supplied ... dabs,dlog10,dsqrt +c +c argonne national laboratory. minpack project. march 1980. +c burton s. garbow, kenneth e. hillstrom, jorge j. more +c +c ********** + integer i,j + double precision eps,epsf,epslog,epsmch,factor,one,temp,zero + double precision dpmpar + data factor,one,zero /1.0d2,1.0d0,0.0d0/ +c +c epsmch is the machine precision. +c + epsmch = dpmpar(1) +c + eps = dsqrt(epsmch) +c + if (mode .eq. 2) go to 20 +c +c mode = 1. +c + do 10 j = 1, n + temp = eps*dabs(x(j)) + if (temp .eq. zero) temp = eps + xp(j) = x(j) + temp + 10 continue + go to 70 + 20 continue +c +c mode = 2. +c + epsf = factor*epsmch + epslog = dlog10(eps) + do 30 i = 1, m + err(i) = zero + 30 continue + do 50 j = 1, n + temp = dabs(x(j)) + if (temp .eq. zero) temp = one + do 40 i = 1, m + err(i) = err(i) + temp*fjac(i,j) + 40 continue + 50 continue + do 60 i = 1, m + temp = one + if (fvec(i) .ne. zero .and. fvecp(i) .ne. zero + * .and. dabs(fvecp(i)-fvec(i)) .ge. epsf*dabs(fvec(i))) + * temp = eps*dabs((fvecp(i)-fvec(i))/eps-err(i)) + * /(dabs(fvec(i)) + dabs(fvecp(i))) + err(i) = one + if (temp .gt. epsmch .and. temp .lt. eps) + * err(i) = (dlog10(temp) - epslog)/epslog + if (temp .ge. eps) err(i) = zero + 60 continue + 70 continue +c + return +c +c last card of subroutine chkder. +c + end diff --git a/chkdrv.f b/chkdrv.f new file mode 100644 index 0000000..d50c582 --- /dev/null +++ b/chkdrv.f @@ -0,0 +1,87 @@ +c ********** +c +c this program tests the ability of chkder to detect +c inconsistencies between functions and their first derivatives. +c fourteen test function vectors and jacobians are used. eleven of +c the tests are false(f), i.e. there are inconsistencies between +c the function vectors and the corresponding jacobians. three of +c the tests are true(t), i.e. there are no inconsistencies. the +c driver reads in data, calls chkder and prints out information +c required by and received from chkder. +c +c subprograms called +c +c minpack supplied ... chkder,errjac,initpt,vecfcn +c +c argonne national laboratory. minpack project. march 1980. +c burton s. garbow, kenneth e. hillstrom, jorge j. more +c +c ********** + integer i,ldfjac,lnp,mode,n,nprob,nread,nwrite + integer na(14),np(14) + logical a(14) + double precision cp,one + double precision diff(10),err(10),errmax(14),errmin(14), + * fjac(10,10),fvec1(10),fvec2(10),x1(10),x2(10) +c +c logical input unit is assumed to be number 5. +c logical output unit is assumed to be number 6. +c + data nread,nwrite /5,6/ +c + data a(1),a(2),a(3),a(4),a(5),a(6),a(7),a(8),a(9),a(10),a(11), + * a(12),a(13),a(14) + * /.false.,.false.,.false.,.true.,.false.,.false.,.false., + * .true.,.false.,.false.,.false.,.false.,.true.,.false./ + data cp,one /1.23d-1,1.0d0/ + ldfjac = 10 + 10 continue + read (nread,60) nprob,n + if (nprob .le. 0) go to 40 + call initpt(n,x1,nprob,one) + do 20 i = 1, n + x1(i) = x1(i) + cp + cp = -cp + 20 continue + write (nwrite,70) nprob,n,a(nprob) + mode = 1 + call chkder(n,n,x1,fvec1,fjac,ldfjac,x2,fvec2,mode,err) + mode = 2 + call vecfcn(n,x1,fvec1,nprob) + call errjac(n,x1,fjac,ldfjac,nprob) + call vecfcn(n,x2,fvec2,nprob) + call chkder(n,n,x1,fvec1,fjac,ldfjac,x2,fvec2,mode,err) + errmin(nprob) = err(1) + errmax(nprob) = err(1) + do 30 i = 1, n + diff(i) = fvec2(i) - fvec1(i) + if (errmin(nprob) .gt. err(i)) errmin(nprob) = err(i) + if (errmax(nprob) .lt. err(i)) errmax(nprob) = err(i) + 30 continue + np(nprob) = nprob + lnp = nprob + na(nprob) = n + write (nwrite,80) (fvec1(i), i = 1, n) + write (nwrite,90) (diff(i), i = 1, n) + write (nwrite,100) (err(i), i = 1, n) + go to 10 + 40 continue + write (nwrite,110) lnp + write (nwrite,120) + do 50 i = 1, lnp + write (nwrite,130) np(i),na(i),a(i),errmin(i),errmax(i) + 50 continue + stop + 60 format (2i5) + 70 format ( /// 5x, 8h problem, i5, 5x, 15h with dimension, i5, 2x, + * 5h is , l1) + 80 format ( // 5x, 25h first function vector // (5x, 5d15.7)) + 90 format ( // 5x, 27h function difference vector // (5x, 5d15.7)) + 100 format ( // 5x, 13h error vector // (5x, 5d15.7)) + 110 format (12h1summary of , i3, 16h tests of chkder /) + 120 format (46h nprob n status errmin errmax /) + 130 format (i4, i6, 6x, l1, 3x, 2d15.7) +c +c last card of derivative check test driver. +c + end diff --git a/covar.f b/covar.f new file mode 100644 index 0000000..c466758 --- /dev/null +++ b/covar.f @@ -0,0 +1,145 @@ + subroutine covar(n,r,ldr,ipvt,tol,wa) + integer n,ldr + integer ipvt(n) + double precision tol + double precision r(ldr,n),wa(n) +c ********** +c +c subroutine covar +c +c given an m by n matrix a, the problem is to determine +c the covariance matrix corresponding to a, defined as +c +c t +c inverse(a *a) . +c +c this subroutine completes the solution of the problem +c if it is provided with the necessary information from the +c qr factorization, with column pivoting, of a. that is, if +c a*p = q*r, where p is a permutation matrix, q has orthogonal +c columns, and r is an upper triangular matrix with diagonal +c elements of nonincreasing magnitude, then covar expects +c the full upper triangle of r and the permutation matrix p. +c the covariance matrix is then computed as +c +c t t +c p*inverse(r *r)*p . +c +c if a is nearly rank deficient, it may be desirable to compute +c the covariance matrix corresponding to the linearly independent +c columns of a. to define the numerical rank of a, covar uses +c the tolerance tol. if l is the largest integer such that +c +c abs(r(l,l)) .gt. tol*abs(r(1,1)) , +c +c then covar computes the covariance matrix corresponding to +c the first l columns of r. for k greater than l, column +c and row ipvt(k) of the covariance matrix are set to zero. +c +c the subroutine statement is +c +c subroutine covar(n,r,ldr,ipvt,tol,wa) +c +c where +c +c n is a positive integer input variable set to the order of r. +c +c r is an n by n array. on input the full upper triangle must +c contain the full upper triangle of the matrix r. on output +c r contains the square symmetric covariance matrix. +c +c ldr is a positive integer input variable not less than n +c which specifies the leading dimension of the array r. +c +c ipvt is an integer input array of length n which defines the +c permutation matrix p such that a*p = q*r. column j of p +c is column ipvt(j) of the identity matrix. +c +c tol is a nonnegative input variable used to define the +c numerical rank of a in the manner described above. +c +c wa is a work array of length n. +c +c subprograms called +c +c fortran-supplied ... dabs +c +c argonne national laboratory. minpack project. august 1980. +c burton s. garbow, kenneth e. hillstrom, jorge j. more +c +c ********** + integer i,ii,j,jj,k,km1,l + logical sing + double precision one,temp,tolr,zero + data one,zero /1.0d0,0.0d0/ +c +c form the inverse of r in the full upper triangle of r. +c + tolr = tol*dabs(r(1,1)) + l = 0 + do 40 k = 1, n + if (dabs(r(k,k)) .le. tolr) go to 50 + r(k,k) = one/r(k,k) + km1 = k - 1 + if (km1 .lt. 1) go to 30 + do 20 j = 1, km1 + temp = r(k,k)*r(j,k) + r(j,k) = zero + do 10 i = 1, j + r(i,k) = r(i,k) - temp*r(i,j) + 10 continue + 20 continue + 30 continue + l = k + 40 continue + 50 continue +c +c form the full upper triangle of the inverse of (r transpose)*r +c in the full upper triangle of r. +c + if (l .lt. 1) go to 110 + do 100 k = 1, l + km1 = k - 1 + if (km1 .lt. 1) go to 80 + do 70 j = 1, km1 + temp = r(j,k) + do 60 i = 1, j + r(i,j) = r(i,j) + temp*r(i,k) + 60 continue + 70 continue + 80 continue + temp = r(k,k) + do 90 i = 1, k + r(i,k) = temp*r(i,k) + 90 continue + 100 continue + 110 continue +c +c form the full lower triangle of the covariance matrix +c in the strict lower triangle of r and in wa. +c + do 130 j = 1, n + jj = ipvt(j) + sing = j .gt. l + do 120 i = 1, j + if (sing) r(i,j) = zero + ii = ipvt(i) + if (ii .gt. jj) r(ii,jj) = r(i,j) + if (ii .lt. jj) r(jj,ii) = r(i,j) + 120 continue + wa(jj) = r(j,j) + 130 continue +c +c symmetrize the covariance matrix in r. +c + do 150 j = 1, n + do 140 i = 1, j + r(i,j) = r(j,i) + 140 continue + r(j,j) = wa(j) + 150 continue + return +c +c last card of subroutine covar. +c + end diff --git a/depend b/depend new file mode 100644 index 0000000..722be8e --- /dev/null +++ b/depend @@ -0,0 +1,226 @@ +F chkder.f +D chkder_ +R dpmpar_ + +F chkdrv.f +D MAIN__ +R chkder_ +R errjac_ +R initpt_ +R vecfcn_ + +F covar.f +D covar_ + +F dmchar.f +D dmchar_ + +F dogleg.f +D dogleg_ +R dpmpar_ +R enorm_ + +F dpmpar.f +D dpmpar_ + +F enorm.f +D enorm_ + +F errjac.f +D errjac_ + +F fdjac1.f +D fdjac1_ +R dpmpar_ + +F fdjac2.f +D fdjac2_ +R dpmpar_ + +F grdfcn.f +D grdfcn_ + +F hesfcn.f +D hesfcn_ + +F hybdrv.f +D MAIN__ +D fcn_ +R dpmpar_ +R enorm_ +R hybrd1_ +R initpt_ +R vecfcn_ + +F hybipt.f +D initpt_ + +F hybrd.f +D hybrd_ +R dogleg_ +R dpmpar_ +R enorm_ +R fdjac1_ +R qform_ +R qrfac_ +R r1mpyq_ +R r1updt_ + +F hybrd1.f +D hybrd1_ +R hybrd_ + +F hybrj.f +D hybrj_ +R dogleg_ +R dpmpar_ +R enorm_ +R qform_ +R qrfac_ +R r1mpyq_ +R r1updt_ + +F hybrj1.f +D hybrj1_ +R hybrj_ + +F hyjdrv.f +D MAIN__ +D fcn_ +R dpmpar_ +R enorm_ +R hybrj1_ +R initpt_ +R vecfcn_ +R vecjac_ + +F ibmdpdr.f +D MAIN__ +R dmchar_ +R dpmpar_ + +F lhesfcn.f +D hesfcn_ + +F lmddrv.f +D MAIN__ +D fcn_ +R dpmpar_ +R enorm_ +R initpt_ +R lmder1_ +R ssqfcn_ +R ssqjac_ + +F lmder.f +D lmder_ +R dpmpar_ +R enorm_ +R lmpar_ +R qrfac_ + +F lmder1.f +D lmder1_ +R lmder_ + +F lmdif.f +D lmdif_ +R dpmpar_ +R enorm_ +R fdjac2_ +R lmpar_ +R qrfac_ + +F lmdif1.f +D lmdif1_ +R lmdif_ + +F lmdipt.f +D initpt_ + +F lmfdrv.f +D MAIN__ +D fcn_ +R dpmpar_ +R enorm_ +R initpt_ +R lmdif1_ +R ssqfcn_ + +F lmpar.f +D lmpar_ +R dpmpar_ +R enorm_ +R qrsolv_ + +F lmsdrv.f +D MAIN__ +D fcn_ +R dpmpar_ +R enorm_ +R initpt_ +R lmstr1_ +R ssqfcn_ +R ssqjac_ + +F lmstr.f +D lmstr_ +R dpmpar_ +R enorm_ +R lmpar_ +R qrfac_ +R rwupdt_ + +F lmstr1.f +D lmstr1_ +R lmstr_ + +F objfcn.f +D objfcn_ + +F ocpipt.f +D initpt_ + +F qform.f +D qform_ + +F qrfac.f +D qrfac_ +R dpmpar_ +R enorm_ + +F qrsolv.f +D qrsolv_ + +F r1mpyq.f +D r1mpyq_ + +F r1updt.f +D r1updt_ +R dpmpar_ + +F rwupdt.f +D rwupdt_ + +F ssqfcn.f +D ssqfcn_ + +F ssqjac.f +D ssqjac_ + +F ucodrv.f +D MAIN__ +D fcn_ +R dpmpar_ +R drvcr1_ +R enorm_ +R grdfcn_ +R initpt_ +R objfcn_ + +F vecfcn.f +D vecfcn_ + +F vecjac.f +D vecjac_ + diff --git a/dmchar.f b/dmchar.f new file mode 100644 index 0000000..e54d8be --- /dev/null +++ b/dmchar.f @@ -0,0 +1,212 @@ + subroutine dmchar(ibeta,it,irnd,ngrd,machep,negep,iexp,minexp, + 1 maxexp,eps,epsneg,xmin,xmax) +c + integer i,ibeta,iexp,irnd,it,iz,j,k,machep,maxexp,minexp, + 1 mx,negep,ngrd + double precision a,b,beta,betain,betam1,eps,epsneg,one,xmax, + 1 xmin,y,z,zero +c +c this subroutine is intended to determine the characteristics +c of the floating-point arithmetic system that are specified +c below. the first three are determined according to an +c algorithm due to m. malcolm, cacm 15 (1972), pp. 949-951, +c incorporating some, but not all, of the improvements +c suggested by m. gentleman and s. marovich, cacm 17 (1974), +c pp. 276-277. +c +c +c ibeta - the radix of the floating-point representation +c it - the number of base ibeta digits in the floating-point +c significand +c irnd - 0 if floating-point addition chops, +c 1 if floating-point addition rounds +c ngrd - the number of guard digits for multiplication. it is +c 0 if irnd=1, or if irnd=0 and only it base ibeta +c digits participate in the post normalization shift +c of the floating-point significand in multiplication +c 1 if irnd=0 and more than it base ibeta digits +c participate in the post normalization shift of the +c floating-point significand in multiplication +c machep - the largest negative integer such that +c 1.0+float(ibeta)**machep .ne. 1.0, except that +c machep is bounded below by -(it+3) +c negeps - the largest negative integer such that +c 1.0-float(ibeta)**negeps .ne. 1.0, except that +c negeps is bounded below by -(it+3) +c iexp - the number of bits (decimal places if ibeta = 10) +c reserved for the representation of the exponent +c (including the bias or sign) of a floating-point +c number +c minexp - the largest in magnitude negative integer such that +c float(ibeta)**minexp is a positive floating-point +c number +c maxexp - the largest positive integer exponent for a finite +c floating-point number +c eps - the smallest positive floating-point number such +c that 1.0+eps .ne. 1.0. in particular, if either +c ibeta = 2 or irnd = 0, eps = float(ibeta)**machep. +c otherwise, eps = (float(ibeta)**machep)/2 +c epsneg - a small positive floating-point number such that +c 1.0-epsneg .ne. 1.0. in particular, if ibeta = 2 +c or irnd = 0, epsneg = float(ibeta)**negeps. +c otherwise, epsneg = (ibeta**negeps)/2. because +c negeps is bounded below by -(it+3), epsneg may not +c be the smallest number which can alter 1.0 by +c subtraction. +c xmin - the smallest non-vanishing floating-point power of the +c radix. in particular, xmin = float(ibeta)**minexp +c xmax - the largest finite floating-point number. in +c particular xmax = (1.0-epsneg)*float(ibeta)**maxexp +c note - on some machines xmax will be only the +c second, or perhaps third, largest number, being +c too small by 1 or 2 units in the last digit of +c the significand. +c +c latest revision - october 22, 1979 +c +c author - w. j. cody +c argonne national laboratory +c +c----------------------------------------------------------------- + one = dble(float(1)) + zero = 0.0d0 +c----------------------------------------------------------------- +c determine ibeta,beta ala malcolm +c----------------------------------------------------------------- + a = one + 10 a = a + a + if (((a+one)-a)-one .eq. zero) go to 10 + b = one + 20 b = b + b + if ((a+b)-a .eq. zero) go to 20 + ibeta = int(sngl((a + b) - a)) + beta = dble(float(ibeta)) +c----------------------------------------------------------------- +c determine it, irnd +c----------------------------------------------------------------- + it = 0 + b = one + 100 it = it + 1 + b = b * beta + if (((b+one)-b)-one .eq. zero) go to 100 + irnd = 0 + betam1 = beta - one + if ((a+betam1)-a .ne. zero) irnd = 1 +c----------------------------------------------------------------- +c determine negep, epsneg +c----------------------------------------------------------------- + negep = it + 3 + betain = one / beta + a = one +c + do 200 i = 1, negep + a = a * betain + 200 continue +c + b = a + 210 if ((one-a)-one .ne. zero) go to 220 + a = a * beta + negep = negep - 1 + go to 210 + 220 negep = -negep + epsneg = a + if ((ibeta .eq. 2) .or. (irnd .eq. 0)) go to 300 + a = (a*(one+a)) / (one+one) + if ((one-a)-one .ne. zero) epsneg = a +c----------------------------------------------------------------- +c determine machep, eps +c----------------------------------------------------------------- + 300 machep = -it - 3 + a = b + 310 if((one+a)-one .ne. zero) go to 320 + a = a * beta + machep = machep + 1 + go to 310 + 320 eps = a + if ((ibeta .eq. 2) .or. (irnd .eq. 0)) go to 350 + a = (a*(one+a)) / (one+one) + if ((one+a)-one .ne. zero) eps = a +c----------------------------------------------------------------- +c determine ngrd +c----------------------------------------------------------------- + 350 ngrd = 0 + if ((irnd .eq. 0) .and. ((one+eps)*one-one) .ne. zero) ngrd = 1 +c----------------------------------------------------------------- +c determine iexp, minexp, xmin +c +c loop to determine largest i and k = 2**i such that +c (1/beta) ** (2**(i)) +c does not underflow +c exit from loop is signaled by an underflow. +c----------------------------------------------------------------- + i = 0 + k = 1 + z = betain + 400 y = z + z = y * y +c----------------------------------------------------------------- +c check for underflow here +c----------------------------------------------------------------- + a = z * one + if ((a+a .eq. zero) .or. (dabs(z) .ge. y)) go to 410 + i = i + 1 + k = k + k + go to 400 + 410 if (ibeta .eq. 10) go to 420 + iexp = i + 1 + mx = k + k + go to 450 +c----------------------------------------------------------------- +c for decimal machines only +c----------------------------------------------------------------- + 420 iexp = 2 + iz = ibeta + 430 if (k .lt. iz) go to 440 + iz = iz * ibeta + iexp = iexp + 1 + go to 430 + 440 mx = iz + iz - 1 +c----------------------------------------------------------------- +c loop to determine minexp, xmin +c exit from loop is signaled by an underflow. +c----------------------------------------------------------------- + 450 xmin = y + y = y * betain +c----------------------------------------------------------------- +c check for underflow here +c----------------------------------------------------------------- + a = y * one + if (((a+a) .eq. zero) .or. (dabs(y) .ge. xmin)) go to 460 + k = k + 1 + go to 450 + 460 minexp = -k +c----------------------------------------------------------------- +c determine maxexp, xmax +c----------------------------------------------------------------- + if ((mx .gt. k+k-3) .or. (ibeta .eq. 10)) go to 500 + mx = mx + mx + iexp = iexp + 1 + 500 maxexp = mx + minexp +c----------------------------------------------------------------- +c adjust for machines with implicit leading +c bit in binary significand and machines with +c radix point at extreme right of significand +c----------------------------------------------------------------- + i = maxexp + minexp + if ((ibeta .eq. 2) .and. (i .eq. 0)) maxexp = maxexp - 1 + if (i .gt. 20) maxexp = maxexp - 1 + if (a .ne. y) maxexp = maxexp - 2 + xmax = one - epsneg + if (xmax*one .ne. xmax) xmax = one - beta * epsneg + xmax = xmax / (beta * beta * beta * xmin) + i = maxexp + minexp + 3 + if (i .le. 0) go to 520 +c + do 510 j = 1, i + if (ibeta .eq. 2) xmax = xmax + xmax + if (ibeta .ne. 2) xmax = xmax * beta + 510 continue +c + 520 return +c ---------- last card of dmchar ---------- + end diff --git a/dogleg.f b/dogleg.f new file mode 100644 index 0000000..b812f19 --- /dev/null +++ b/dogleg.f @@ -0,0 +1,177 @@ + subroutine dogleg(n,r,lr,diag,qtb,delta,x,wa1,wa2) + integer n,lr + double precision delta + double precision r(lr),diag(n),qtb(n),x(n),wa1(n),wa2(n) +c ********** +c +c subroutine dogleg +c +c given an m by n matrix a, an n by n nonsingular diagonal +c matrix d, an m-vector b, and a positive number delta, the +c problem is to determine the convex combination x of the +c gauss-newton and scaled gradient directions that minimizes +c (a*x - b) in the least squares sense, subject to the +c restriction that the euclidean norm of d*x be at most delta. +c +c this subroutine completes the solution of the problem +c if it is provided with the necessary information from the +c qr factorization of a. that is, if a = q*r, where q has +c orthogonal columns and r is an upper triangular matrix, +c then dogleg expects the full upper triangle of r and +c the first n components of (q transpose)*b. +c +c the subroutine statement is +c +c subroutine dogleg(n,r,lr,diag,qtb,delta,x,wa1,wa2) +c +c where +c +c n is a positive integer input variable set to the order of r. +c +c r is an input array of length lr which must contain the upper +c triangular matrix r stored by rows. +c +c lr is a positive integer input variable not less than +c (n*(n+1))/2. +c +c diag is an input array of length n which must contain the +c diagonal elements of the matrix d. +c +c qtb is an input array of length n which must contain the first +c n elements of the vector (q transpose)*b. +c +c delta is a positive input variable which specifies an upper +c bound on the euclidean norm of d*x. +c +c x is an output array of length n which contains the desired +c convex combination of the gauss-newton direction and the +c scaled gradient direction. +c +c wa1 and wa2 are work arrays of length n. +c +c subprograms called +c +c minpack-supplied ... dpmpar,enorm +c +c fortran-supplied ... dabs,dmax1,dmin1,dsqrt +c +c argonne national laboratory. minpack project. march 1980. +c burton s. garbow, kenneth e. hillstrom, jorge j. more +c +c ********** + integer i,j,jj,jp1,k,l + double precision alpha,bnorm,epsmch,gnorm,one,qnorm,sgnorm,sum, + * temp,zero + double precision dpmpar,enorm + data one,zero /1.0d0,0.0d0/ +c +c epsmch is the machine precision. +c + epsmch = dpmpar(1) +c +c first, calculate the gauss-newton direction. +c + jj = (n*(n + 1))/2 + 1 + do 50 k = 1, n + j = n - k + 1 + jp1 = j + 1 + jj = jj - k + l = jj + 1 + sum = zero + if (n .lt. jp1) go to 20 + do 10 i = jp1, n + sum = sum + r(l)*x(i) + l = l + 1 + 10 continue + 20 continue + temp = r(jj) + if (temp .ne. zero) go to 40 + l = j + do 30 i = 1, j + temp = dmax1(temp,dabs(r(l))) + l = l + n - i + 30 continue + temp = epsmch*temp + if (temp .eq. zero) temp = epsmch + 40 continue + x(j) = (qtb(j) - sum)/temp + 50 continue +c +c test whether the gauss-newton direction is acceptable. +c + do 60 j = 1, n + wa1(j) = zero + wa2(j) = diag(j)*x(j) + 60 continue + qnorm = enorm(n,wa2) + if (qnorm .le. delta) go to 140 +c +c the gauss-newton direction is not acceptable. +c next, calculate the scaled gradient direction. +c + l = 1 + do 80 j = 1, n + temp = qtb(j) + do 70 i = j, n + wa1(i) = wa1(i) + r(l)*temp + l = l + 1 + 70 continue + wa1(j) = wa1(j)/diag(j) + 80 continue +c +c calculate the norm of the scaled gradient and test for +c the special case in which the scaled gradient is zero. +c + gnorm = enorm(n,wa1) + sgnorm = zero + alpha = delta/qnorm + if (gnorm .eq. zero) go to 120 +c +c calculate the point along the scaled gradient +c at which the quadratic is minimized. +c + do 90 j = 1, n + wa1(j) = (wa1(j)/gnorm)/diag(j) + 90 continue + l = 1 + do 110 j = 1, n + sum = zero + do 100 i = j, n + sum = sum + r(l)*wa1(i) + l = l + 1 + 100 continue + wa2(j) = sum + 110 continue + temp = enorm(n,wa2) + sgnorm = (gnorm/temp)/temp +c +c test whether the scaled gradient direction is acceptable. +c + alpha = zero + if (sgnorm .ge. delta) go to 120 +c +c the scaled gradient direction is not acceptable. +c finally, calculate the point along the dogleg +c at which the quadratic is minimized. +c + bnorm = enorm(n,qtb) + temp = (bnorm/gnorm)*(bnorm/qnorm)*(sgnorm/delta) + temp = temp - (delta/qnorm)*(sgnorm/delta)**2 + * + dsqrt((temp-(delta/qnorm))**2 + * +(one-(delta/qnorm)**2)*(one-(sgnorm/delta)**2)) + alpha = ((delta/qnorm)*(one - (sgnorm/delta)**2))/temp + 120 continue +c +c form appropriate convex combination of the gauss-newton +c direction and the scaled gradient direction. +c + temp = (one - alpha)*dmin1(sgnorm,delta) + do 130 j = 1, n + x(j) = temp*wa1(j) + alpha*x(j) + 130 continue + 140 continue + return +c +c last card of subroutine dogleg. +c + end diff --git a/dpmpar.f b/dpmpar.f new file mode 100644 index 0000000..cb6545a --- /dev/null +++ b/dpmpar.f @@ -0,0 +1,177 @@ + double precision function dpmpar(i) + integer i +c ********** +c +c Function dpmpar +c +c This function provides double precision machine parameters +c when the appropriate set of data statements is activated (by +c removing the c from column 1) and all other data statements are +c rendered inactive. Most of the parameter values were obtained +c from the corresponding Bell Laboratories Port Library function. +c +c The function statement is +c +c double precision function dpmpar(i) +c +c where +c +c i is an integer input variable set to 1, 2, or 3 which +c selects the desired machine parameter. If the machine has +c t base b digits and its smallest and largest exponents are +c emin and emax, respectively, then these parameters are +c +c dpmpar(1) = b**(1 - t), the machine precision, +c +c dpmpar(2) = b**(emin - 1), the smallest magnitude, +c +c dpmpar(3) = b**emax*(1 - b**(-t)), the largest magnitude. +c +c Argonne National Laboratory. MINPACK Project. November 1996. +c Burton S. Garbow, Kenneth E. Hillstrom, Jorge J. More' +c +c ********** + integer mcheps(4) + integer minmag(4) + integer maxmag(4) + double precision dmach(3) + equivalence (dmach(1),mcheps(1)) + equivalence (dmach(2),minmag(1)) + equivalence (dmach(3),maxmag(1)) +c +c Machine constants for the IBM 360/370 series, +c the Amdahl 470/V6, the ICL 2900, the Itel AS/6, +c the Xerox Sigma 5/7/9 and the Sel systems 85/86. +c +c data mcheps(1),mcheps(2) / z34100000, z00000000 / +c data minmag(1),minmag(2) / z00100000, z00000000 / +c data maxmag(1),maxmag(2) / z7fffffff, zffffffff / +c +c Machine constants for the Honeywell 600/6000 series. +c +c data mcheps(1),mcheps(2) / o606400000000, o000000000000 / +c data minmag(1),minmag(2) / o402400000000, o000000000000 / +c data maxmag(1),maxmag(2) / o376777777777, o777777777777 / +c +c Machine constants for the CDC 6000/7000 series. +c +c data mcheps(1) / 15614000000000000000b / +c data mcheps(2) / 15010000000000000000b / +c +c data minmag(1) / 00604000000000000000b / +c data minmag(2) / 00000000000000000000b / +c +c data maxmag(1) / 37767777777777777777b / +c data maxmag(2) / 37167777777777777777b / +c +c Machine constants for the PDP-10 (KA processor). +c +c data mcheps(1),mcheps(2) / "114400000000, "000000000000 / +c data minmag(1),minmag(2) / "033400000000, "000000000000 / +c data maxmag(1),maxmag(2) / "377777777777, "344777777777 / +c +c Machine constants for the PDP-10 (KI processor). +c +c data mcheps(1),mcheps(2) / "104400000000, "000000000000 / +c data minmag(1),minmag(2) / "000400000000, "000000000000 / +c data maxmag(1),maxmag(2) / "377777777777, "377777777777 / +c +c Machine constants for the PDP-11. +c +c data mcheps(1),mcheps(2) / 9472, 0 / +c data mcheps(3),mcheps(4) / 0, 0 / +c +c data minmag(1),minmag(2) / 128, 0 / +c data minmag(3),minmag(4) / 0, 0 / +c +c data maxmag(1),maxmag(2) / 32767, -1 / +c data maxmag(3),maxmag(4) / -1, -1 / +c +c Machine constants for the Burroughs 6700/7700 systems. +c +c data mcheps(1) / o1451000000000000 / +c data mcheps(2) / o0000000000000000 / +c +c data minmag(1) / o1771000000000000 / +c data minmag(2) / o7770000000000000 / +c +c data maxmag(1) / o0777777777777777 / +c data maxmag(2) / o7777777777777777 / +c +c Machine constants for the Burroughs 5700 system. +c +c data mcheps(1) / o1451000000000000 / +c data mcheps(2) / o0000000000000000 / +c +c data minmag(1) / o1771000000000000 / +c data minmag(2) / o0000000000000000 / +c +c data maxmag(1) / o0777777777777777 / +c data maxmag(2) / o0007777777777777 / +c +c Machine constants for the Burroughs 1700 system. +c +c data mcheps(1) / zcc6800000 / +c data mcheps(2) / z000000000 / +c +c data minmag(1) / zc00800000 / +c data minmag(2) / z000000000 / +c +c data maxmag(1) / zdffffffff / +c data maxmag(2) / zfffffffff / +c +c Machine constants for the Univac 1100 series. +c +c data mcheps(1),mcheps(2) / o170640000000, o000000000000 / +c data minmag(1),minmag(2) / o000040000000, o000000000000 / +c data maxmag(1),maxmag(2) / o377777777777, o777777777777 / +c +c Machine constants for the Data General Eclipse S/200. +c +c Note - it may be appropriate to include the following card - +c static dmach(3) +c +c data minmag/20k,3*0/,maxmag/77777k,3*177777k/ +c data mcheps/32020k,3*0/ +c +c Machine constants for the Harris 220. +c +c data mcheps(1),mcheps(2) / '20000000, '00000334 / +c data minmag(1),minmag(2) / '20000000, '00000201 / +c data maxmag(1),maxmag(2) / '37777777, '37777577 / +c +c Machine constants for the Cray-1. +c +c data mcheps(1) / 0376424000000000000000b / +c data mcheps(2) / 0000000000000000000000b / +c +c data minmag(1) / 0200034000000000000000b / +c data minmag(2) / 0000000000000000000000b / +c +c data maxmag(1) / 0577777777777777777777b / +c data maxmag(2) / 0000007777777777777776b / +c +c Machine constants for the Prime 400. +c +c data mcheps(1),mcheps(2) / :10000000000, :00000000123 / +c data minmag(1),minmag(2) / :10000000000, :00000100000 / +c data maxmag(1),maxmag(2) / :17777777777, :37777677776 / +c +c Machine constants for the VAX-11. +c +c data mcheps(1),mcheps(2) / 9472, 0 / +c data minmag(1),minmag(2) / 128, 0 / +c data maxmag(1),maxmag(2) / -32769, -1 / +c +c Machine constants for IEEE machines. +c + data dmach(1) /2.22044604926d-16/ + data dmach(2) /2.22507385852d-308/ + data dmach(3) /1.79769313485d+308/ +c + dpmpar = dmach(i) + return +c +c Last card of function dpmpar. +c + end diff --git a/enorm.f b/enorm.f new file mode 100644 index 0000000..2cb5b60 --- /dev/null +++ b/enorm.f @@ -0,0 +1,108 @@ + double precision function enorm(n,x) + integer n + double precision x(n) +c ********** +c +c function enorm +c +c given an n-vector x, this function calculates the +c euclidean norm of x. +c +c the euclidean norm is computed by accumulating the sum of +c squares in three different sums. the sums of squares for the +c small and large components are scaled so that no overflows +c occur. non-destructive underflows are permitted. underflows +c and overflows do not occur in the computation of the unscaled +c sum of squares for the intermediate components. +c the definitions of small, intermediate and large components +c depend on two constants, rdwarf and rgiant. the main +c restrictions on these constants are that rdwarf**2 not +c underflow and rgiant**2 not overflow. the constants +c given here are suitable for every known computer. +c +c the function statement is +c +c double precision function enorm(n,x) +c +c where +c +c n is a positive integer input variable. +c +c x is an input array of length n. +c +c subprograms called +c +c fortran-supplied ... dabs,dsqrt +c +c argonne national laboratory. minpack project. march 1980. +c burton s. garbow, kenneth e. hillstrom, jorge j. more +c +c ********** + integer i + double precision agiant,floatn,one,rdwarf,rgiant,s1,s2,s3,xabs, + * x1max,x3max,zero + data one,zero,rdwarf,rgiant /1.0d0,0.0d0,3.834d-20,1.304d19/ + s1 = zero + s2 = zero + s3 = zero + x1max = zero + x3max = zero + floatn = n + agiant = rgiant/floatn + do 90 i = 1, n + xabs = dabs(x(i)) + if (xabs .gt. rdwarf .and. xabs .lt. agiant) go to 70 + if (xabs .le. rdwarf) go to 30 +c +c sum for large components. +c + if (xabs .le. x1max) go to 10 + s1 = one + s1*(x1max/xabs)**2 + x1max = xabs + go to 20 + 10 continue + s1 = s1 + (xabs/x1max)**2 + 20 continue + go to 60 + 30 continue +c +c sum for small components. +c + if (xabs .le. x3max) go to 40 + s3 = one + s3*(x3max/xabs)**2 + x3max = xabs + go to 50 + 40 continue + if (xabs .ne. zero) s3 = s3 + (xabs/x3max)**2 + 50 continue + 60 continue + go to 80 + 70 continue +c +c sum for intermediate components. +c + s2 = s2 + xabs**2 + 80 continue + 90 continue +c +c calculation of norm. +c + if (s1 .eq. zero) go to 100 + enorm = x1max*dsqrt(s1+(s2/x1max)/x1max) + go to 130 + 100 continue + if (s2 .eq. zero) go to 110 + if (s2 .ge. x3max) + * enorm = dsqrt(s2*(one+(x3max/s2)*(x3max*s3))) + if (s2 .lt. x3max) + * enorm = dsqrt(x3max*((s2/x3max)+(x3max*s3))) + go to 120 + 110 continue + enorm = x3max*dsqrt(s3) + 120 continue + 130 continue + return +c +c last card of function enorm. +c + end diff --git a/errjac.f b/errjac.f new file mode 100644 index 0000000..3913f23 --- /dev/null +++ b/errjac.f @@ -0,0 +1,333 @@ + subroutine errjac(n,x,fjac,ldfjac,nprob) + integer n,ldfjac,nprob + double precision x(n),fjac(ldfjac,n) +c ********** +c +c subroutine errjac +c +c this subroutine is derived from vecjac which defines the +c jacobian matrices of fourteen test functions. the problem +c dimensions are as described in the prologue comments of vecfcn. +c various errors are deliberately introduced to provide a test +c for chkder. +c +c the subroutine statement is +c +c subroutine errjac(n,x,fjac,ldfjac,nprob) +c +c where +c +c n is a positive integer variable. +c +c x is an array of length n. +c +c fjac is an n by n array. on output fjac contains the +c jacobian matrix, with various errors deliberately +c introduced, of the nprob function evaluated at x. +c +c ldfjac is a positive integer variable not less than n +c which specifies the leading dimension of the array fjac. +c +c nprob is a positive integer variable which defines the +c number of the problem. nprob must not exceed 14. +c +c subprograms called +c +c fortran-supplied ... datan,dcos,dexp,dmin1,dsin,dsqrt, +c max0,min0 +c +c argonne national laboratory. minpack project. march 1980. +c burton s. garbow, kenneth e. hillstrom, jorge j. more +c +c ********** + integer i,ivar,j,k,k1,k2,ml,mu + double precision c1,c3,c4,c5,c6,c9,eight,fiftn,five,four,h, + * hundrd,one,prod,six,sum,sum1,sum2,temp,temp1, + * temp2,temp3,temp4,ten,three,ti,tj,tk,tpi, + * twenty,two,zero + double precision dfloat + data zero,one,two,three,four,five,six,eight,ten,fiftn,twenty, + * hundrd + * /0.0d0,1.0d0,2.0d0,3.0d0,4.0d0,5.0d0,6.0d0,8.0d0,1.0d1, + * 1.5d1,2.0d1,1.0d2/ + data c1,c3,c4,c5,c6,c9 /1.0d4,2.0d2,2.02d1,1.98d1,1.8d2,2.9d1/ + dfloat(ivar) = ivar +c +c jacobian routine selector. +c + go to (10,20,50,60,90,100,200,230,290,320,350,380,420,450), + * nprob +c +c rosenbrock function with sign reversal affecting element (1,1). +c + 10 continue + fjac(1,1) = one + fjac(1,2) = zero + fjac(2,1) = -twenty*x(1) + fjac(2,2) = ten + go to 490 +c +c powell singular function with sign reversal affecting element +c (3,3). +c + 20 continue + do 40 k = 1, 4 + do 30 j = 1, 4 + fjac(k,j) = zero + 30 continue + 40 continue + fjac(1,1) = one + fjac(1,2) = ten + fjac(2,3) = dsqrt(five) + fjac(2,4) = -fjac(2,3) + fjac(3,2) = two*(x(2) - two*x(3)) + fjac(3,3) = two*fjac(3,2) + fjac(4,1) = two*dsqrt(ten)*(x(1) - x(4)) + fjac(4,4) = -fjac(4,1) + go to 490 +c +c powell badly scaled function with the sign of the jacobian +c reversed. +c + 50 continue + fjac(1,1) = -c1*x(2) + fjac(1,2) = -c1*x(1) + fjac(2,1) = dexp(-x(1)) + fjac(2,2) = dexp(-x(2)) + go to 490 +c +c wood function without error. +c + 60 continue + do 80 k = 1, 4 + do 70 j = 1, 4 + fjac(k,j) = zero + 70 continue + 80 continue + temp1 = x(2) - three*x(1)**2 + temp2 = x(4) - three*x(3)**2 + fjac(1,1) = -c3*temp1 + one + fjac(1,2) = -c3*x(1) + fjac(2,1) = -two*c3*x(1) + fjac(2,2) = c3 + c4 + fjac(2,4) = c5 + fjac(3,3) = -c6*temp2 + one + fjac(3,4) = -c6*x(3) + fjac(4,2) = c5 + fjac(4,3) = -two*c6*x(3) + fjac(4,4) = c6 + c4 + go to 490 +c +c helical valley function with multiplicative error affecting +c elements (2,1) and (2,2). +c + 90 continue + tpi = eight*datan(one) + temp = x(1)**2 + x(2)**2 + temp1 = tpi*temp + temp2 = dsqrt(temp) + fjac(1,1) = hundrd*x(2)/temp1 + fjac(1,2) = -hundrd*x(1)/temp1 + fjac(1,3) = ten + fjac(2,1) = five*x(1)/temp2 + fjac(2,2) = five*x(2)/temp2 + fjac(2,3) = zero + fjac(3,1) = zero + fjac(3,2) = zero + fjac(3,3) = one + go to 490 +c +c watson function with sign reversals affecting the computation of +c temp1. +c + 100 continue + do 120 k = 1, n + do 110 j = k, n + fjac(k,j) = zero + 110 continue + 120 continue + do 170 i = 1, 29 + ti = dfloat(i)/c9 + sum1 = zero + temp = one + do 130 j = 2, n + sum1 = sum1 + dfloat(j-1)*temp*x(j) + temp = ti*temp + 130 continue + sum2 = zero + temp = one + do 140 j = 1, n + sum2 = sum2 + temp*x(j) + temp = ti*temp + 140 continue + temp1 = two*(sum1 + sum2**2 + one) + temp2 = two*sum2 + temp = ti**2 + tk = one + do 160 k = 1, n + tj = tk + do 150 j = k, n + fjac(k,j) = fjac(k,j) + * + tj + * *((dfloat(k-1)/ti - temp2) + * *(dfloat(j-1)/ti - temp2) - temp1) + tj = ti*tj + 150 continue + tk = temp*tk + 160 continue + 170 continue + fjac(1,1) = fjac(1,1) + six*x(1)**2 - two*x(2) + three + fjac(1,2) = fjac(1,2) - two*x(1) + fjac(2,2) = fjac(2,2) + one + do 190 k = 1, n + do 180 j = k, n + fjac(j,k) = fjac(k,j) + 180 continue + 190 continue + go to 490 +c +c chebyquad function with jacobian twice correct size. +c + 200 continue + tk = one/dfloat(n) + do 220 j = 1, n + temp1 = one + temp2 = two*x(j) - one + temp = two*temp2 + temp3 = zero + temp4 = two + do 210 k = 1, n + fjac(k,j) = two*tk*temp4 + ti = four*temp2 + temp*temp4 - temp3 + temp3 = temp4 + temp4 = ti + ti = temp*temp2 - temp1 + temp1 = temp2 + temp2 = ti + 210 continue + 220 continue + go to 490 +c +c brown almost-linear function without error. +c + 230 continue + prod = one + do 250 j = 1, n + prod = x(j)*prod + do 240 k = 1, n + fjac(k,j) = one + 240 continue + fjac(j,j) = two + 250 continue + do 280 j = 1, n + temp = x(j) + if (temp .ne. zero) go to 270 + temp = one + prod = one + do 260 k = 1, n + if (k .ne. j) prod = x(k)*prod + 260 continue + 270 continue + fjac(n,j) = prod/temp + 280 continue + go to 490 +c +c discrete boundary value function with multiplicative error +c affecting the jacobian diagonal. +c + 290 continue + h = one/dfloat(n+1) + do 310 k = 1, n + temp = three*(x(k) + dfloat(k)*h + one)**2 + do 300 j = 1, n + fjac(k,j) = zero + 300 continue + fjac(k,k) = four + temp*h**2 + if (k .ne. 1) fjac(k,k-1) = -one + if (k .ne. n) fjac(k,k+1) = -one + 310 continue + go to 490 +c +c discrete integral equation function with sign error affecting +c the jacobian diagonal. +c + 320 continue + h = one/dfloat(n+1) + do 340 k = 1, n + tk = dfloat(k)*h + do 330 j = 1, n + tj = dfloat(j)*h + temp = three*(x(j) + tj + one)**2 + fjac(k,j) = h*dmin1(tj*(one-tk),tk*(one-tj))*temp/two + 330 continue + fjac(k,k) = fjac(k,k) - one + 340 continue + go to 490 +c +c trigonometric function with sign errors affecting the +c offdiagonal elements of the jacobian. +c + 350 continue + do 370 j = 1, n + temp = dsin(x(j)) + do 360 k = 1, n + fjac(k,j) = -temp + 360 continue + fjac(j,j) = dfloat(j+1)*temp - dcos(x(j)) + 370 continue + go to 490 +c +c variably dimensioned function with operation error affecting +c the upper triangular elements of the jacobian. +c + 380 continue + sum = zero + do 390 j = 1, n + sum = sum + dfloat(j)*(x(j) - one) + 390 continue + temp = one + six*sum**2 + do 410 k = 1, n + do 400 j = k, n + fjac(k,j) = dfloat(k*j)/temp + fjac(j,k) = fjac(k,j) + 400 continue + fjac(k,k) = fjac(k,k) + one + 410 continue + go to 490 +c +c broyden tridiagonal function without error. +c + 420 continue + do 440 k = 1, n + do 430 j = 1, n + fjac(k,j) = zero + 430 continue + fjac(k,k) = three - four*x(k) + if (k .ne. 1) fjac(k,k-1) = -one + if (k .ne. n) fjac(k,k+1) = -two + 440 continue + go to 490 +c +c broyden banded function with sign error affecting the jacobian +c diagonal. +c + 450 continue + ml = 5 + mu = 1 + do 480 k = 1, n + do 460 j = 1, n + fjac(k,j) = zero + 460 continue + k1 = max0(1,k-ml) + k2 = min0(k+mu,n) + do 470 j = k1, k2 + if (j .ne. k) fjac(k,j) = -(one + two*x(j)) + 470 continue + fjac(k,k) = two - fiftn*x(k)**2 + 480 continue + 490 continue + return +c +c last card of subroutine errjac. +c + end diff --git a/ex/file01 b/ex/file01 new file mode 100644 index 0000000..d5d0c55 --- /dev/null +++ b/ex/file01 @@ -0,0 +1,145 @@ + REAL FUNCTION SPMPAR(I) + INTEGER I +C ********** +C +C FUNCTION SPMPAR +C +C THIS FUNCTION PROVIDES SINGLE PRECISION MACHINE PARAMETERS +C WHEN THE APPROPRIATE SET OF DATA STATEMENTS IS ACTIVATED (BY +C REMOVING THE C FROM COLUMN 1) AND ALL OTHER DATA STATEMENTS ARE +C RENDERED INACTIVE. MOST OF THE PARAMETER VALUES WERE OBTAINED +C FROM THE CORRESPONDING BELL LABORATORIES PORT LIBRARY FUNCTION. +C +C THE FUNCTION STATEMENT IS +C +C REAL FUNCTION SPMPAR(I) +C +C WHERE +C +C I IS AN INTEGER INPUT VARIABLE SET TO 1, 2, OR 3 WHICH +C SELECTS THE DESIRED MACHINE PARAMETER. IF THE MACHINE HAS +C T BASE B DIGITS AND ITS SMALLEST AND LARGEST EXPONENTS ARE +C EMIN AND EMAX, RESPECTIVELY, THEN THESE PARAMETERS ARE +C +C SPMPAR(1) = B**(1 - T), THE MACHINE PRECISION, +C +C SPMPAR(2) = B**(EMIN - 1), THE SMALLEST MAGNITUDE, +C +C SPMPAR(3) = B**EMAX*(1 - B**(-T)), THE LARGEST MAGNITUDE. +C +C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. +C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE +C +C ********** + INTEGER MCHEPS(2) + INTEGER MINMAG(2) + INTEGER MAXMAG(2) + REAL RMACH(3) + EQUIVALENCE (RMACH(1),MCHEPS(1)) + EQUIVALENCE (RMACH(2),MINMAG(1)) + EQUIVALENCE (RMACH(3),MAXMAG(1)) +C +C MACHINE CONSTANTS FOR THE IBM 360/370 SERIES, +C THE AMDAHL 470/V6, THE ICL 2900, THE ITEL AS/6, +C THE XEROX SIGMA 5/7/9 AND THE SEL SYSTEMS 85/86. +C + DATA RMACH(1) / Z3C100000 / + DATA RMACH(2) / Z00100000 / + DATA RMACH(3) / Z7FFFFFFF / +C +C MACHINE CONSTANTS FOR THE HONEYWELL 600/6000 SERIES. +C +C DATA RMACH(1) / O716400000000 / +C DATA RMACH(2) / O402400000000 / +C DATA RMACH(3) / O376777777777 / +C +C MACHINE CONSTANTS FOR THE CDC 6000/7000 SERIES. +C +C DATA RMACH(1) / 16414000000000000000B / +C DATA RMACH(2) / 00014000000000000000B / +C DATA RMACH(3) / 37767777777777777777B / +C +C MACHINE CONSTANTS FOR THE PDP-10 (KA OR KI PROCESSOR). +C +C DATA RMACH(1) / "147400000000 / +C DATA RMACH(2) / "000400000000 / +C DATA RMACH(3) / "377777777777 / +C +C MACHINE CONSTANTS FOR THE PDP-11 FORTRAN SUPPORTING +C 32-BIT INTEGERS (EXPRESSED IN INTEGER AND OCTAL). +C +C DATA MCHEPS(1) / 889192448 / +C DATA MINMAG(1) / 8388608 / +C DATA MAXMAG(1) / 2147483647 / +C +C DATA RMACH(1) / O06500000000 / +C DATA RMACH(2) / O00040000000 / +C DATA RMACH(3) / O17777777777 / +C +C MACHINE CONSTANTS FOR THE PDP-11 FORTRAN SUPPORTING +C 16-BIT INTEGERS (EXPRESSED IN INTEGER AND OCTAL). +C +C DATA MCHEPS(1),MCHEPS(2) / 13568, 0 / +C DATA MINMAG(1),MINMAG(2) / 128, 0 / +C DATA MAXMAG(1),MAXMAG(2) / 32767, -1 / +C +C DATA MCHEPS(1),MCHEPS(2) / O032400, O000000 / +C DATA MINMAG(1),MINMAG(2) / O000200, O000000 / +C DATA MAXMAG(1),MAXMAG(2) / O077777, O177777 / +C +C MACHINE CONSTANTS FOR THE BURROUGHS 5700/6700/7700 SYSTEMS. +C +C DATA RMACH(1) / O1301000000000000 / +C DATA RMACH(2) / O1771000000000000 / +C DATA RMACH(3) / O0777777777777777 / +C +C MACHINE CONSTANTS FOR THE BURROUGHS 1700 SYSTEM. +C +C DATA RMACH(1) / Z4EA800000 / +C DATA RMACH(2) / Z400800000 / +C DATA RMACH(3) / Z5FFFFFFFF / +C +C MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES. +C +C DATA RMACH(1) / O147400000000 / +C DATA RMACH(2) / O000400000000 / +C DATA RMACH(3) / O377777777777 / +C +C MACHINE CONSTANTS FOR THE DATA GENERAL ECLIPSE S/200. +C +C NOTE - IT MAY BE APPROPRIATE TO INCLUDE THE FOLLOWING CARD - +C STATIC RMACH(3) +C +C DATA MINMAG/20K,0/,MAXMAG/77777K,177777K/ +C DATA MCHEPS/36020K,0/ +C +C MACHINE CONSTANTS FOR THE HARRIS 220. +C +C DATA MCHEPS(1) / '20000000, '00000353 / +C DATA MINMAG(1) / '20000000, '00000201 / +C DATA MAXMAG(1) / '37777777, '00000177 / +C +C MACHINE CONSTANTS FOR THE CRAY-1. +C +C DATA RMACH(1) / 0377224000000000000000B / +C DATA RMACH(2) / 0200034000000000000000B / +C DATA RMACH(3) / 0577777777777777777776B / +C +C MACHINE CONSTANTS FOR THE PRIME 400. +C +C DATA MCHEPS(1) / :10000000153 / +C DATA MINMAG(1) / :10000000000 / +C DATA MAXMAG(1) / :17777777777 / +C +C MACHINE CONSTANTS FOR THE VAX-11. +C +C DATA MCHEPS(1) / 13568 / +C DATA MINMAG(1) / 128 / +C DATA MAXMAG(1) / -32769 / +C + SPMPAR = RMACH(I) + RETURN +C +C LAST CARD OF FUNCTION SPMPAR. +C + END diff --git a/ex/file02 b/ex/file02 new file mode 100644 index 0000000..5a3ec93 --- /dev/null +++ b/ex/file02 @@ -0,0 +1,4771 @@ + SUBROUTINE CHKDER(M,N,X,FVEC,FJAC,LDFJAC,XP,FVECP,MODE,ERR) + INTEGER M,N,LDFJAC,MODE + REAL X(N),FVEC(M),FJAC(LDFJAC,N),XP(N),FVECP(M),ERR(M) +C ********** +C +C SUBROUTINE CHKDER +C +C THIS SUBROUTINE CHECKS THE GRADIENTS OF M NONLINEAR FUNCTIONS +C IN N VARIABLES, EVALUATED AT A POINT X, FOR CONSISTENCY WITH +C THE FUNCTIONS THEMSELVES. THE USER MUST CALL CHKDER TWICE, +C FIRST WITH MODE = 1 AND THEN WITH MODE = 2. +C +C MODE = 1. ON INPUT, X MUST CONTAIN THE POINT OF EVALUATION. +C ON OUTPUT, XP IS SET TO A NEIGHBORING POINT. +C +C MODE = 2. ON INPUT, FVEC MUST CONTAIN THE FUNCTIONS AND THE +C ROWS OF FJAC MUST CONTAIN THE GRADIENTS +C OF THE RESPECTIVE FUNCTIONS EACH EVALUATED +C AT X, AND FVECP MUST CONTAIN THE FUNCTIONS +C EVALUATED AT XP. +C ON OUTPUT, ERR CONTAINS MEASURES OF CORRECTNESS OF +C THE RESPECTIVE GRADIENTS. +C +C THE SUBROUTINE DOES NOT PERFORM RELIABLY IF CANCELLATION OR +C ROUNDING ERRORS CAUSE A SEVERE LOSS OF SIGNIFICANCE IN THE +C EVALUATION OF A FUNCTION. THEREFORE, NONE OF THE COMPONENTS +C OF X SHOULD BE UNUSUALLY SMALL (IN PARTICULAR, ZERO) OR ANY +C OTHER VALUE WHICH MAY CAUSE LOSS OF SIGNIFICANCE. +C +C THE SUBROUTINE STATEMENT IS +C +C SUBROUTINE CHKDER(M,N,X,FVEC,FJAC,LDFJAC,XP,FVECP,MODE,ERR) +C +C WHERE +C +C M IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER +C OF FUNCTIONS. +C +C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER +C OF VARIABLES. +C +C X IS AN INPUT ARRAY OF LENGTH N. +C +C FVEC IS AN ARRAY OF LENGTH M. ON INPUT WHEN MODE = 2, +C FVEC MUST CONTAIN THE FUNCTIONS EVALUATED AT X. +C +C FJAC IS AN M BY N ARRAY. ON INPUT WHEN MODE = 2, +C THE ROWS OF FJAC MUST CONTAIN THE GRADIENTS OF +C THE RESPECTIVE FUNCTIONS EVALUATED AT X. +C +C LDFJAC IS A POSITIVE INTEGER INPUT PARAMETER NOT LESS THAN M +C WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY FJAC. +C +C XP IS AN ARRAY OF LENGTH N. ON OUTPUT WHEN MODE = 1, +C XP IS SET TO A NEIGHBORING POINT OF X. +C +C FVECP IS AN ARRAY OF LENGTH M. ON INPUT WHEN MODE = 2, +C FVECP MUST CONTAIN THE FUNCTIONS EVALUATED AT XP. +C +C MODE IS AN INTEGER INPUT VARIABLE SET TO 1 ON THE FIRST CALL +C AND 2 ON THE SECOND. OTHER VALUES OF MODE ARE EQUIVALENT +C TO MODE = 1. +C +C ERR IS AN ARRAY OF LENGTH M. ON OUTPUT WHEN MODE = 2, +C ERR CONTAINS MEASURES OF CORRECTNESS OF THE RESPECTIVE +C GRADIENTS. IF THERE IS NO SEVERE LOSS OF SIGNIFICANCE, +C THEN IF ERR(I) IS 1.0 THE I-TH GRADIENT IS CORRECT, +C WHILE IF ERR(I) IS 0.0 THE I-TH GRADIENT IS INCORRECT. +C FOR VALUES OF ERR BETWEEN 0.0 AND 1.0, THE CATEGORIZATION +C IS LESS CERTAIN. IN GENERAL, A VALUE OF ERR(I) GREATER +C THAN 0.5 INDICATES THAT THE I-TH GRADIENT IS PROBABLY +C CORRECT, WHILE A VALUE OF ERR(I) LESS THAN 0.5 INDICATES +C THAT THE I-TH GRADIENT IS PROBABLY INCORRECT. +C +C SUBPROGRAMS CALLED +C +C MINPACK SUPPLIED ... SPMPAR +C +C FORTRAN SUPPLIED ... ABS,ALOG10,SQRT +C +C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. +C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE +C +C ********** + INTEGER I,J + REAL EPS,EPSF,EPSLOG,EPSMCH,FACTOR,ONE,TEMP,ZERO + REAL SPMPAR + DATA FACTOR,ONE,ZERO /1.0E2,1.0E0,0.0E0/ +C +C EPSMCH IS THE MACHINE PRECISION. +C + EPSMCH = SPMPAR(1) +C + EPS = SQRT(EPSMCH) +C + IF (MODE .EQ. 2) GO TO 20 +C +C MODE = 1. +C + DO 10 J = 1, N + TEMP = EPS*ABS(X(J)) + IF (TEMP .EQ. ZERO) TEMP = EPS + XP(J) = X(J) + TEMP + 10 CONTINUE + GO TO 70 + 20 CONTINUE +C +C MODE = 2. +C + EPSF = FACTOR*EPSMCH + EPSLOG = ALOG10(EPS) + DO 30 I = 1, M + ERR(I) = ZERO + 30 CONTINUE + DO 50 J = 1, N + TEMP = ABS(X(J)) + IF (TEMP .EQ. ZERO) TEMP = ONE + DO 40 I = 1, M + ERR(I) = ERR(I) + TEMP*FJAC(I,J) + 40 CONTINUE + 50 CONTINUE + DO 60 I = 1, M + TEMP = ONE + IF (FVEC(I) .NE. ZERO .AND. FVECP(I) .NE. ZERO + * .AND. ABS(FVECP(I)-FVEC(I)) .GE. EPSF*ABS(FVEC(I))) + * TEMP = EPS*ABS((FVECP(I)-FVEC(I))/EPS-ERR(I)) + * /(ABS(FVEC(I)) + ABS(FVECP(I))) + ERR(I) = ONE + IF (TEMP .GT. EPSMCH .AND. TEMP .LT. EPS) + * ERR(I) = (ALOG10(TEMP) - EPSLOG)/EPSLOG + IF (TEMP .GE. EPS) ERR(I) = ZERO + 60 CONTINUE + 70 CONTINUE +C + RETURN +C +C LAST CARD OF SUBROUTINE CHKDER. +C + END + SUBROUTINE DOGLEG(N,R,LR,DIAG,QTB,DELTA,X,WA1,WA2) + INTEGER N,LR + REAL DELTA + REAL R(LR),DIAG(N),QTB(N),X(N),WA1(N),WA2(N) +C ********** +C +C SUBROUTINE DOGLEG +C +C GIVEN AN M BY N MATRIX A, AN N BY N NONSINGULAR DIAGONAL +C MATRIX D, AN M-VECTOR B, AND A POSITIVE NUMBER DELTA, THE +C PROBLEM IS TO DETERMINE THE CONVEX COMBINATION X OF THE +C GAUSS-NEWTON AND SCALED GRADIENT DIRECTIONS THAT MINIMIZES +C (A*X - B) IN THE LEAST SQUARES SENSE, SUBJECT TO THE +C RESTRICTION THAT THE EUCLIDEAN NORM OF D*X BE AT MOST DELTA. +C +C THIS SUBROUTINE COMPLETES THE SOLUTION OF THE PROBLEM +C IF IT IS PROVIDED WITH THE NECESSARY INFORMATION FROM THE +C QR FACTORIZATION OF A. THAT IS, IF A = Q*R, WHERE Q HAS +C ORTHOGONAL COLUMNS AND R IS AN UPPER TRIANGULAR MATRIX, +C THEN DOGLEG EXPECTS THE FULL UPPER TRIANGLE OF R AND +C THE FIRST N COMPONENTS OF (Q TRANSPOSE)*B. +C +C THE SUBROUTINE STATEMENT IS +C +C SUBROUTINE DOGLEG(N,R,LR,DIAG,QTB,DELTA,X,WA1,WA2) +C +C WHERE +C +C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE ORDER OF R. +C +C R IS AN INPUT ARRAY OF LENGTH LR WHICH MUST CONTAIN THE UPPER +C TRIANGULAR MATRIX R STORED BY ROWS. +C +C LR IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN +C (N*(N+1))/2. +C +C DIAG IS AN INPUT ARRAY OF LENGTH N WHICH MUST CONTAIN THE +C DIAGONAL ELEMENTS OF THE MATRIX D. +C +C QTB IS AN INPUT ARRAY OF LENGTH N WHICH MUST CONTAIN THE FIRST +C N ELEMENTS OF THE VECTOR (Q TRANSPOSE)*B. +C +C DELTA IS A POSITIVE INPUT VARIABLE WHICH SPECIFIES AN UPPER +C BOUND ON THE EUCLIDEAN NORM OF D*X. +C +C X IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE DESIRED +C CONVEX COMBINATION OF THE GAUSS-NEWTON DIRECTION AND THE +C SCALED GRADIENT DIRECTION. +C +C WA1 AND WA2 ARE WORK ARRAYS OF LENGTH N. +C +C SUBPROGRAMS CALLED +C +C MINPACK-SUPPLIED ... SPMPAR,ENORM +C +C FORTRAN-SUPPLIED ... ABS,AMAX1,AMIN1,SQRT +C +C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. +C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE +C +C ********** + INTEGER I,J,JJ,JP1,K,L + REAL ALPHA,BNORM,EPSMCH,GNORM,ONE,QNORM,SGNORM,SUM,TEMP,ZERO + REAL SPMPAR,ENORM + DATA ONE,ZERO /1.0E0,0.0E0/ +C +C EPSMCH IS THE MACHINE PRECISION. +C + EPSMCH = SPMPAR(1) +C +C FIRST, CALCULATE THE GAUSS-NEWTON DIRECTION. +C + JJ = (N*(N + 1))/2 + 1 + DO 50 K = 1, N + J = N - K + 1 + JP1 = J + 1 + JJ = JJ - K + L = JJ + 1 + SUM = ZERO + IF (N .LT. JP1) GO TO 20 + DO 10 I = JP1, N + SUM = SUM + R(L)*X(I) + L = L + 1 + 10 CONTINUE + 20 CONTINUE + TEMP = R(JJ) + IF (TEMP .NE. ZERO) GO TO 40 + L = J + DO 30 I = 1, J + TEMP = AMAX1(TEMP,ABS(R(L))) + L = L + N - I + 30 CONTINUE + TEMP = EPSMCH*TEMP + IF (TEMP .EQ. ZERO) TEMP = EPSMCH + 40 CONTINUE + X(J) = (QTB(J) - SUM)/TEMP + 50 CONTINUE +C +C TEST WHETHER THE GAUSS-NEWTON DIRECTION IS ACCEPTABLE. +C + DO 60 J = 1, N + WA1(J) = ZERO + WA2(J) = DIAG(J)*X(J) + 60 CONTINUE + QNORM = ENORM(N,WA2) + IF (QNORM .LE. DELTA) GO TO 140 +C +C THE GAUSS-NEWTON DIRECTION IS NOT ACCEPTABLE. +C NEXT, CALCULATE THE SCALED GRADIENT DIRECTION. +C + L = 1 + DO 80 J = 1, N + TEMP = QTB(J) + DO 70 I = J, N + WA1(I) = WA1(I) + R(L)*TEMP + L = L + 1 + 70 CONTINUE + WA1(J) = WA1(J)/DIAG(J) + 80 CONTINUE +C +C CALCULATE THE NORM OF THE SCALED GRADIENT AND TEST FOR +C THE SPECIAL CASE IN WHICH THE SCALED GRADIENT IS ZERO. +C + GNORM = ENORM(N,WA1) + SGNORM = ZERO + ALPHA = DELTA/QNORM + IF (GNORM .EQ. ZERO) GO TO 120 +C +C CALCULATE THE POINT ALONG THE SCALED GRADIENT +C AT WHICH THE QUADRATIC IS MINIMIZED. +C + DO 90 J = 1, N + WA1(J) = (WA1(J)/GNORM)/DIAG(J) + 90 CONTINUE + L = 1 + DO 110 J = 1, N + SUM = ZERO + DO 100 I = J, N + SUM = SUM + R(L)*WA1(I) + L = L + 1 + 100 CONTINUE + WA2(J) = SUM + 110 CONTINUE + TEMP = ENORM(N,WA2) + SGNORM = (GNORM/TEMP)/TEMP +C +C TEST WHETHER THE SCALED GRADIENT DIRECTION IS ACCEPTABLE. +C + ALPHA = ZERO + IF (SGNORM .GE. DELTA) GO TO 120 +C +C THE SCALED GRADIENT DIRECTION IS NOT ACCEPTABLE. +C FINALLY, CALCULATE THE POINT ALONG THE DOGLEG +C AT WHICH THE QUADRATIC IS MINIMIZED. +C + BNORM = ENORM(N,QTB) + TEMP = (BNORM/GNORM)*(BNORM/QNORM)*(SGNORM/DELTA) + TEMP = TEMP - (DELTA/QNORM)*(SGNORM/DELTA)**2 + * + SQRT((TEMP-(DELTA/QNORM))**2 + * +(ONE-(DELTA/QNORM)**2)*(ONE-(SGNORM/DELTA)**2)) + ALPHA = ((DELTA/QNORM)*(ONE - (SGNORM/DELTA)**2))/TEMP + 120 CONTINUE +C +C FORM APPROPRIATE CONVEX COMBINATION OF THE GAUSS-NEWTON +C DIRECTION AND THE SCALED GRADIENT DIRECTION. +C + TEMP = (ONE - ALPHA)*AMIN1(SGNORM,DELTA) + DO 130 J = 1, N + X(J) = TEMP*WA1(J) + ALPHA*X(J) + 130 CONTINUE + 140 CONTINUE + RETURN +C +C LAST CARD OF SUBROUTINE DOGLEG. +C + END + REAL FUNCTION ENORM(N,X) + INTEGER N + REAL X(N) +C ********** +C +C FUNCTION ENORM +C +C GIVEN AN N-VECTOR X, THIS FUNCTION CALCULATES THE +C EUCLIDEAN NORM OF X. +C +C THE EUCLIDEAN NORM IS COMPUTED BY ACCUMULATING THE SUM OF +C SQUARES IN THREE DIFFERENT SUMS. THE SUMS OF SQUARES FOR THE +C SMALL AND LARGE COMPONENTS ARE SCALED SO THAT NO OVERFLOWS +C OCCUR. NON-DESTRUCTIVE UNDERFLOWS ARE PERMITTED. UNDERFLOWS +C AND OVERFLOWS DO NOT OCCUR IN THE COMPUTATION OF THE UNSCALED +C SUM OF SQUARES FOR THE INTERMEDIATE COMPONENTS. +C THE DEFINITIONS OF SMALL, INTERMEDIATE AND LARGE COMPONENTS +C DEPEND ON TWO CONSTANTS, RDWARF AND RGIANT. THE MAIN +C RESTRICTIONS ON THESE CONSTANTS ARE THAT RDWARF**2 NOT +C UNDERFLOW AND RGIANT**2 NOT OVERFLOW. THE CONSTANTS +C GIVEN HERE ARE SUITABLE FOR EVERY KNOWN COMPUTER. +C +C THE FUNCTION STATEMENT IS +C +C REAL FUNCTION ENORM(N,X) +C +C WHERE +C +C N IS A POSITIVE INTEGER INPUT VARIABLE. +C +C X IS AN INPUT ARRAY OF LENGTH N. +C +C SUBPROGRAMS CALLED +C +C FORTRAN-SUPPLIED ... ABS,SQRT +C +C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. +C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE +C +C ********** + INTEGER I + REAL AGIANT,FLOATN,ONE,RDWARF,RGIANT,S1,S2,S3,XABS,X1MAX,X3MAX, + * ZERO + DATA ONE,ZERO,RDWARF,RGIANT /1.0E0,0.0E0,3.834E-20,1.304E19/ + S1 = ZERO + S2 = ZERO + S3 = ZERO + X1MAX = ZERO + X3MAX = ZERO + FLOATN = N + AGIANT = RGIANT/FLOATN + DO 90 I = 1, N + XABS = ABS(X(I)) + IF (XABS .GT. RDWARF .AND. XABS .LT. AGIANT) GO TO 70 + IF (XABS .LE. RDWARF) GO TO 30 +C +C SUM FOR LARGE COMPONENTS. +C + IF (XABS .LE. X1MAX) GO TO 10 + S1 = ONE + S1*(X1MAX/XABS)**2 + X1MAX = XABS + GO TO 20 + 10 CONTINUE + S1 = S1 + (XABS/X1MAX)**2 + 20 CONTINUE + GO TO 60 + 30 CONTINUE +C +C SUM FOR SMALL COMPONENTS. +C + IF (XABS .LE. X3MAX) GO TO 40 + S3 = ONE + S3*(X3MAX/XABS)**2 + X3MAX = XABS + GO TO 50 + 40 CONTINUE + IF (XABS .NE. ZERO) S3 = S3 + (XABS/X3MAX)**2 + 50 CONTINUE + 60 CONTINUE + GO TO 80 + 70 CONTINUE +C +C SUM FOR INTERMEDIATE COMPONENTS. +C + S2 = S2 + XABS**2 + 80 CONTINUE + 90 CONTINUE +C +C CALCULATION OF NORM. +C + IF (S1 .EQ. ZERO) GO TO 100 + ENORM = X1MAX*SQRT(S1+(S2/X1MAX)/X1MAX) + GO TO 130 + 100 CONTINUE + IF (S2 .EQ. ZERO) GO TO 110 + IF (S2 .GE. X3MAX) + * ENORM = SQRT(S2*(ONE+(X3MAX/S2)*(X3MAX*S3))) + IF (S2 .LT. X3MAX) + * ENORM = SQRT(X3MAX*((S2/X3MAX)+(X3MAX*S3))) + GO TO 120 + 110 CONTINUE + ENORM = X3MAX*SQRT(S3) + 120 CONTINUE + 130 CONTINUE + RETURN +C +C LAST CARD OF FUNCTION ENORM. +C + END + SUBROUTINE FDJAC1(FCN,N,X,FVEC,FJAC,LDFJAC,IFLAG,ML,MU,EPSFCN, + * WA1,WA2) + INTEGER N,LDFJAC,IFLAG,ML,MU + REAL EPSFCN + REAL X(N),FVEC(N),FJAC(LDFJAC,N),WA1(N),WA2(N) +C ********** +C +C SUBROUTINE FDJAC1 +C +C THIS SUBROUTINE COMPUTES A FORWARD-DIFFERENCE APPROXIMATION +C TO THE N BY N JACOBIAN MATRIX ASSOCIATED WITH A SPECIFIED +C PROBLEM OF N FUNCTIONS IN N VARIABLES. IF THE JACOBIAN HAS +C A BANDED FORM, THEN FUNCTION EVALUATIONS ARE SAVED BY ONLY +C APPROXIMATING THE NONZERO TERMS. +C +C THE SUBROUTINE STATEMENT IS +C +C SUBROUTINE FDJAC1(FCN,N,X,FVEC,FJAC,LDFJAC,IFLAG,ML,MU,EPSFCN, +C WA1,WA2) +C +C WHERE +C +C FCN IS THE NAME OF THE USER-SUPPLIED SUBROUTINE WHICH +C CALCULATES THE FUNCTIONS. FCN MUST BE DECLARED +C IN AN EXTERNAL STATEMENT IN THE USER CALLING +C PROGRAM, AND SHOULD BE WRITTEN AS FOLLOWS. +C +C SUBROUTINE FCN(N,X,FVEC,IFLAG) +C INTEGER N,IFLAG +C REAL X(N),FVEC(N) +C ---------- +C CALCULATE THE FUNCTIONS AT X AND +C RETURN THIS VECTOR IN FVEC. +C ---------- +C RETURN +C END +C +C THE VALUE OF IFLAG SHOULD NOT BE CHANGED BY FCN UNLESS +C THE USER WANTS TO TERMINATE EXECUTION OF FDJAC1. +C IN THIS CASE SET IFLAG TO A NEGATIVE INTEGER. +C +C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER +C OF FUNCTIONS AND VARIABLES. +C +C X IS AN INPUT ARRAY OF LENGTH N. +C +C FVEC IS AN INPUT ARRAY OF LENGTH N WHICH MUST CONTAIN THE +C FUNCTIONS EVALUATED AT X. +C +C FJAC IS AN OUTPUT N BY N ARRAY WHICH CONTAINS THE +C APPROXIMATION TO THE JACOBIAN MATRIX EVALUATED AT X. +C +C LDFJAC IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN N +C WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY FJAC. +C +C IFLAG IS AN INTEGER VARIABLE WHICH CAN BE USED TO TERMINATE +C THE EXECUTION OF FDJAC1. SEE DESCRIPTION OF FCN. +C +C ML IS A NONNEGATIVE INTEGER INPUT VARIABLE WHICH SPECIFIES +C THE NUMBER OF SUBDIAGONALS WITHIN THE BAND OF THE +C JACOBIAN MATRIX. IF THE JACOBIAN IS NOT BANDED, SET +C ML TO AT LEAST N - 1. +C +C EPSFCN IS AN INPUT VARIABLE USED IN DETERMINING A SUITABLE +C STEP LENGTH FOR THE FORWARD-DIFFERENCE APPROXIMATION. THIS +C APPROXIMATION ASSUMES THAT THE RELATIVE ERRORS IN THE +C FUNCTIONS ARE OF THE ORDER OF EPSFCN. IF EPSFCN IS LESS +C THAN THE MACHINE PRECISION, IT IS ASSUMED THAT THE RELATIVE +C ERRORS IN THE FUNCTIONS ARE OF THE ORDER OF THE MACHINE +C PRECISION. +C +C MU IS A NONNEGATIVE INTEGER INPUT VARIABLE WHICH SPECIFIES +C THE NUMBER OF SUPERDIAGONALS WITHIN THE BAND OF THE +C JACOBIAN MATRIX. IF THE JACOBIAN IS NOT BANDED, SET +C MU TO AT LEAST N - 1. +C +C WA1 AND WA2 ARE WORK ARRAYS OF LENGTH N. IF ML + MU + 1 IS AT +C LEAST N, THEN THE JACOBIAN IS CONSIDERED DENSE, AND WA2 IS +C NOT REFERENCED. +C +C SUBPROGRAMS CALLED +C +C MINPACK-SUPPLIED ... SPMPAR +C +C FORTRAN-SUPPLIED ... ABS,AMAX1,SQRT +C +C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. +C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE +C +C ********** + INTEGER I,J,K,MSUM + REAL EPS,EPSMCH,H,TEMP,ZERO + REAL SPMPAR + DATA ZERO /0.0E0/ +C +C EPSMCH IS THE MACHINE PRECISION. +C + EPSMCH = SPMPAR(1) +C + EPS = SQRT(AMAX1(EPSFCN,EPSMCH)) + MSUM = ML + MU + 1 + IF (MSUM .LT. N) GO TO 40 +C +C COMPUTATION OF DENSE APPROXIMATE JACOBIAN. +C + DO 20 J = 1, N + TEMP = X(J) + H = EPS*ABS(TEMP) + IF (H .EQ. ZERO) H = EPS + X(J) = TEMP + H + CALL FCN(N,X,WA1,IFLAG) + IF (IFLAG .LT. 0) GO TO 30 + X(J) = TEMP + DO 10 I = 1, N + FJAC(I,J) = (WA1(I) - FVEC(I))/H + 10 CONTINUE + 20 CONTINUE + 30 CONTINUE + GO TO 110 + 40 CONTINUE +C +C COMPUTATION OF BANDED APPROXIMATE JACOBIAN. +C + DO 90 K = 1, MSUM + DO 60 J = K, N, MSUM + WA2(J) = X(J) + H = EPS*ABS(WA2(J)) + IF (H .EQ. ZERO) H = EPS + X(J) = WA2(J) + H + 60 CONTINUE + CALL FCN(N,X,WA1,IFLAG) + IF (IFLAG .LT. 0) GO TO 100 + DO 80 J = K, N, MSUM + X(J) = WA2(J) + H = EPS*ABS(WA2(J)) + IF (H .EQ. ZERO) H = EPS + DO 70 I = 1, N + FJAC(I,J) = ZERO + IF (I .GE. J - MU .AND. I .LE. J + ML) + * FJAC(I,J) = (WA1(I) - FVEC(I))/H + 70 CONTINUE + 80 CONTINUE + 90 CONTINUE + 100 CONTINUE + 110 CONTINUE + RETURN +C +C LAST CARD OF SUBROUTINE FDJAC1. +C + END + SUBROUTINE FDJAC2(FCN,M,N,X,FVEC,FJAC,LDFJAC,IFLAG,EPSFCN,WA) + INTEGER M,N,LDFJAC,IFLAG + REAL EPSFCN + REAL X(N),FVEC(M),FJAC(LDFJAC,N),WA(M) +C ********** +C +C SUBROUTINE FDJAC2 +C +C THIS SUBROUTINE COMPUTES A FORWARD-DIFFERENCE APPROXIMATION +C TO THE M BY N JACOBIAN MATRIX ASSOCIATED WITH A SPECIFIED +C PROBLEM OF M FUNCTIONS IN N VARIABLES. +C +C THE SUBROUTINE STATEMENT IS +C +C SUBROUTINE FDJAC2(FCN,M,N,X,FVEC,FJAC,LDFJAC,IFLAG,EPSFCN,WA) +C +C WHERE +C +C FCN IS THE NAME OF THE USER-SUPPLIED SUBROUTINE WHICH +C CALCULATES THE FUNCTIONS. FCN MUST BE DECLARED +C IN AN EXTERNAL STATEMENT IN THE USER CALLING +C PROGRAM, AND SHOULD BE WRITTEN AS FOLLOWS. +C +C SUBROUTINE FCN(M,N,X,FVEC,IFLAG) +C INTEGER M,N,IFLAG +C REAL X(N),FVEC(M) +C ---------- +C CALCULATE THE FUNCTIONS AT X AND +C RETURN THIS VECTOR IN FVEC. +C ---------- +C RETURN +C END +C +C THE VALUE OF IFLAG SHOULD NOT BE CHANGED BY FCN UNLESS +C THE USER WANTS TO TERMINATE EXECUTION OF FDJAC2. +C IN THIS CASE SET IFLAG TO A NEGATIVE INTEGER. +C +C M IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER +C OF FUNCTIONS. +C +C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER +C OF VARIABLES. N MUST NOT EXCEED M. +C +C X IS AN INPUT ARRAY OF LENGTH N. +C +C FVEC IS AN INPUT ARRAY OF LENGTH M WHICH MUST CONTAIN THE +C FUNCTIONS EVALUATED AT X. +C +C FJAC IS AN OUTPUT M BY N ARRAY WHICH CONTAINS THE +C APPROXIMATION TO THE JACOBIAN MATRIX EVALUATED AT X. +C +C LDFJAC IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN M +C WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY FJAC. +C +C IFLAG IS AN INTEGER VARIABLE WHICH CAN BE USED TO TERMINATE +C THE EXECUTION OF FDJAC2. SEE DESCRIPTION OF FCN. +C +C EPSFCN IS AN INPUT VARIABLE USED IN DETERMINING A SUITABLE +C STEP LENGTH FOR THE FORWARD-DIFFERENCE APPROXIMATION. THIS +C APPROXIMATION ASSUMES THAT THE RELATIVE ERRORS IN THE +C FUNCTIONS ARE OF THE ORDER OF EPSFCN. IF EPSFCN IS LESS +C THAN THE MACHINE PRECISION, IT IS ASSUMED THAT THE RELATIVE +C ERRORS IN THE FUNCTIONS ARE OF THE ORDER OF THE MACHINE +C PRECISION. +C +C WA IS A WORK ARRAY OF LENGTH M. +C +C SUBPROGRAMS CALLED +C +C USER-SUPPLIED ...... FCN +C +C MINPACK-SUPPLIED ... SPMPAR +C +C FORTRAN-SUPPLIED ... ABS,AMAX1,SQRT +C +C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. +C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE +C +C ********** + INTEGER I,J + REAL EPS,EPSMCH,H,TEMP,ZERO + REAL SPMPAR + DATA ZERO /0.0E0/ +C +C EPSMCH IS THE MACHINE PRECISION. +C + EPSMCH = SPMPAR(1) +C + EPS = SQRT(AMAX1(EPSFCN,EPSMCH)) + DO 20 J = 1, N + TEMP = X(J) + H = EPS*ABS(TEMP) + IF (H .EQ. ZERO) H = EPS + X(J) = TEMP + H + CALL FCN(M,N,X,WA,IFLAG) + IF (IFLAG .LT. 0) GO TO 30 + X(J) = TEMP + DO 10 I = 1, M + FJAC(I,J) = (WA(I) - FVEC(I))/H + 10 CONTINUE + 20 CONTINUE + 30 CONTINUE + RETURN +C +C LAST CARD OF SUBROUTINE FDJAC2. +C + END + SUBROUTINE HYBRD(FCN,N,X,FVEC,XTOL,MAXFEV,ML,MU,EPSFCN,DIAG, + * MODE,FACTOR,NPRINT,INFO,NFEV,FJAC,LDFJAC,R,LR, + * QTF,WA1,WA2,WA3,WA4) + INTEGER N,MAXFEV,ML,MU,MODE,NPRINT,INFO,NFEV,LDFJAC,LR + REAL XTOL,EPSFCN,FACTOR + REAL X(N),FVEC(N),DIAG(N),FJAC(LDFJAC,N),R(LR),QTF(N),WA1(N), + * WA2(N),WA3(N),WA4(N) + EXTERNAL FCN +C ********** +C +C SUBROUTINE HYBRD +C +C THE PURPOSE OF HYBRD IS TO FIND A ZERO OF A SYSTEM OF +C N NONLINEAR FUNCTIONS IN N VARIABLES BY A MODIFICATION +C OF THE POWELL HYBRID METHOD. THE USER MUST PROVIDE A +C SUBROUTINE WHICH CALCULATES THE FUNCTIONS. THE JACOBIAN IS +C THEN CALCULATED BY A FORWARD-DIFFERENCE APPROXIMATION. +C +C THE SUBROUTINE STATEMENT IS +C +C SUBROUTINE HYBRD(FCN,N,X,FVEC,XTOL,MAXFEV,ML,MU,EPSFCN, +C DIAG,MODE,FACTOR,NPRINT,INFO,NFEV,FJAC, +C LDFJAC,R,LR,QTF,WA1,WA2,WA3,WA4) +C +C WHERE +C +C FCN IS THE NAME OF THE USER-SUPPLIED SUBROUTINE WHICH +C CALCULATES THE FUNCTIONS. FCN MUST BE DECLARED +C IN AN EXTERNAL STATEMENT IN THE USER CALLING +C PROGRAM, AND SHOULD BE WRITTEN AS FOLLOWS. +C +C SUBROUTINE FCN(N,X,FVEC,IFLAG) +C INTEGER N,IFLAG +C REAL X(N),FVEC(N) +C ---------- +C CALCULATE THE FUNCTIONS AT X AND +C RETURN THIS VECTOR IN FVEC. +C --------- +C RETURN +C END +C +C THE VALUE OF IFLAG SHOULD NOT BE CHANGED BY FCN UNLESS +C THE USER WANTS TO TERMINATE EXECUTION OF HYBRD. +C IN THIS CASE SET IFLAG TO A NEGATIVE INTEGER. +C +C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER +C OF FUNCTIONS AND VARIABLES. +C +C X IS AN ARRAY OF LENGTH N. ON INPUT X MUST CONTAIN +C AN INITIAL ESTIMATE OF THE SOLUTION VECTOR. ON OUTPUT X +C CONTAINS THE FINAL ESTIMATE OF THE SOLUTION VECTOR. +C +C FVEC IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS +C THE FUNCTIONS EVALUATED AT THE OUTPUT X. +C +C XTOL IS A NONNEGATIVE INPUT VARIABLE. TERMINATION +C OCCURS WHEN THE RELATIVE ERROR BETWEEN TWO CONSECUTIVE +C ITERATES IS AT MOST XTOL. +C +C MAXFEV IS A POSITIVE INTEGER INPUT VARIABLE. TERMINATION +C OCCURS WHEN THE NUMBER OF CALLS TO FCN IS AT LEAST MAXFEV +C BY THE END OF AN ITERATION. +C +C ML IS A NONNEGATIVE INTEGER INPUT VARIABLE WHICH SPECIFIES +C THE NUMBER OF SUBDIAGONALS WITHIN THE BAND OF THE +C JACOBIAN MATRIX. IF THE JACOBIAN IS NOT BANDED, SET +C ML TO AT LEAST N - 1. +C +C MU IS A NONNEGATIVE INTEGER INPUT VARIABLE WHICH SPECIFIES +C THE NUMBER OF SUPERDIAGONALS WITHIN THE BAND OF THE +C JACOBIAN MATRIX. IF THE JACOBIAN IS NOT BANDED, SET +C MU TO AT LEAST N - 1. +C +C EPSFCN IS AN INPUT VARIABLE USED IN DETERMINING A SUITABLE +C STEP LENGTH FOR THE FORWARD-DIFFERENCE APPROXIMATION. THIS +C APPROXIMATION ASSUMES THAT THE RELATIVE ERRORS IN THE +C FUNCTIONS ARE OF THE ORDER OF EPSFCN. IF EPSFCN IS LESS +C THAN THE MACHINE PRECISION, IT IS ASSUMED THAT THE RELATIVE +C ERRORS IN THE FUNCTIONS ARE OF THE ORDER OF THE MACHINE +C PRECISION. +C +C DIAG IS AN ARRAY OF LENGTH N. IF MODE = 1 (SEE +C BELOW), DIAG IS INTERNALLY SET. IF MODE = 2, DIAG +C MUST CONTAIN POSITIVE ENTRIES THAT SERVE AS +C MULTIPLICATIVE SCALE FACTORS FOR THE VARIABLES. +C +C MODE IS AN INTEGER INPUT VARIABLE. IF MODE = 1, THE +C VARIABLES WILL BE SCALED INTERNALLY. IF MODE = 2, +C THE SCALING IS SPECIFIED BY THE INPUT DIAG. OTHER +C VALUES OF MODE ARE EQUIVALENT TO MODE = 1. +C +C FACTOR IS A POSITIVE INPUT VARIABLE USED IN DETERMINING THE +C INITIAL STEP BOUND. THIS BOUND IS SET TO THE PRODUCT OF +C FACTOR AND THE EUCLIDEAN NORM OF DIAG*X IF NONZERO, OR ELSE +C TO FACTOR ITSELF. IN MOST CASES FACTOR SHOULD LIE IN THE +C INTERVAL (.1,100.). 100. IS A GENERALLY RECOMMENDED VALUE. +C +C NPRINT IS AN INTEGER INPUT VARIABLE THAT ENABLES CONTROLLED +C PRINTING OF ITERATES IF IT IS POSITIVE. IN THIS CASE, +C FCN IS CALLED WITH IFLAG = 0 AT THE BEGINNING OF THE FIRST +C ITERATION AND EVERY NPRINT ITERATIONS THEREAFTER AND +C IMMEDIATELY PRIOR TO RETURN, WITH X AND FVEC AVAILABLE +C FOR PRINTING. IF NPRINT IS NOT POSITIVE, NO SPECIAL CALLS +C OF FCN WITH IFLAG = 0 ARE MADE. +C +C INFO IS AN INTEGER OUTPUT VARIABLE. IF THE USER HAS +C TERMINATED EXECUTION, INFO IS SET TO THE (NEGATIVE) +C VALUE OF IFLAG. SEE DESCRIPTION OF FCN. OTHERWISE, +C INFO IS SET AS FOLLOWS. +C +C INFO = 0 IMPROPER INPUT PARAMETERS. +C +C INFO = 1 RELATIVE ERROR BETWEEN TWO CONSECUTIVE ITERATES +C IS AT MOST XTOL. +C +C INFO = 2 NUMBER OF CALLS TO FCN HAS REACHED OR EXCEEDED +C MAXFEV. +C +C INFO = 3 XTOL IS TOO SMALL. NO FURTHER IMPROVEMENT IN +C THE APPROXIMATE SOLUTION X IS POSSIBLE. +C +C INFO = 4 ITERATION IS NOT MAKING GOOD PROGRESS, AS +C MEASURED BY THE IMPROVEMENT FROM THE LAST +C FIVE JACOBIAN EVALUATIONS. +C +C INFO = 5 ITERATION IS NOT MAKING GOOD PROGRESS, AS +C MEASURED BY THE IMPROVEMENT FROM THE LAST +C TEN ITERATIONS. +C +C NFEV IS AN INTEGER OUTPUT VARIABLE SET TO THE NUMBER OF +C CALLS TO FCN. +C +C FJAC IS AN OUTPUT N BY N ARRAY WHICH CONTAINS THE +C ORTHOGONAL MATRIX Q PRODUCED BY THE QR FACTORIZATION +C OF THE FINAL APPROXIMATE JACOBIAN. +C +C LDFJAC IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN N +C WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY FJAC. +C +C R IS AN OUTPUT ARRAY OF LENGTH LR WHICH CONTAINS THE +C UPPER TRIANGULAR MATRIX PRODUCED BY THE QR FACTORIZATION +C OF THE FINAL APPROXIMATE JACOBIAN, STORED ROWWISE. +C +C LR IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN +C (N*(N+1))/2. +C +C QTF IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS +C THE VECTOR (Q TRANSPOSE)*FVEC. +C +C WA1, WA2, WA3, AND WA4 ARE WORK ARRAYS OF LENGTH N. +C +C SUBPROGRAMS CALLED +C +C USER-SUPPLIED ...... FCN +C +C MINPACK-SUPPLIED ... DOGLEG,SPMPAR,ENORM,FDJAC1, +C QFORM,QRFAC,R1MPYQ,R1UPDT +C +C FORTRAN-SUPPLIED ... ABS,AMAX1,AMIN1,MIN0,MOD +C +C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. +C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE +C +C ********** + INTEGER I,IFLAG,ITER,J,JM1,L,MSUM,NCFAIL,NCSUC,NSLOW1,NSLOW2 + INTEGER IWA(1) + LOGICAL JEVAL,SING + REAL ACTRED,DELTA,EPSMCH,FNORM,FNORM1,ONE,PNORM,PRERED,P1,P5, + * P001,P0001,RATIO,SUM,TEMP,XNORM,ZERO + REAL SPMPAR,ENORM + DATA ONE,P1,P5,P001,P0001,ZERO + * /1.0E0,1.0E-1,5.0E-1,1.0E-3,1.0E-4,0.0E0/ +C +C EPSMCH IS THE MACHINE PRECISION. +C + EPSMCH = SPMPAR(1) +C + INFO = 0 + IFLAG = 0 + NFEV = 0 +C +C CHECK THE INPUT PARAMETERS FOR ERRORS. +C + IF (N .LE. 0 .OR. XTOL .LT. ZERO .OR. MAXFEV .LE. 0 + * .OR. ML .LT. 0 .OR. MU .LT. 0 .OR. FACTOR .LE. ZERO + * .OR. LDFJAC .LT. N .OR. LR .LT. (N*(N + 1))/2) GO TO 300 + IF (MODE .NE. 2) GO TO 20 + DO 10 J = 1, N + IF (DIAG(J) .LE. ZERO) GO TO 300 + 10 CONTINUE + 20 CONTINUE +C +C EVALUATE THE FUNCTION AT THE STARTING POINT +C AND CALCULATE ITS NORM. +C + IFLAG = 1 + CALL FCN(N,X,FVEC,IFLAG) + NFEV = 1 + IF (IFLAG .LT. 0) GO TO 300 + FNORM = ENORM(N,FVEC) +C +C DETERMINE THE NUMBER OF CALLS TO FCN NEEDED TO COMPUTE +C THE JACOBIAN MATRIX. +C + MSUM = MIN0(ML+MU+1,N) +C +C INITIALIZE ITERATION COUNTER AND MONITORS. +C + ITER = 1 + NCSUC = 0 + NCFAIL = 0 + NSLOW1 = 0 + NSLOW2 = 0 +C +C BEGINNING OF THE OUTER LOOP. +C + 30 CONTINUE + JEVAL = .TRUE. +C +C CALCULATE THE JACOBIAN MATRIX. +C + IFLAG = 2 + CALL FDJAC1(FCN,N,X,FVEC,FJAC,LDFJAC,IFLAG,ML,MU,EPSFCN,WA1, + * WA2) + NFEV = NFEV + MSUM + IF (IFLAG .LT. 0) GO TO 300 +C +C COMPUTE THE QR FACTORIZATION OF THE JACOBIAN. +C + CALL QRFAC(N,N,FJAC,LDFJAC,.FALSE.,IWA,1,WA1,WA2,WA3) +C +C ON THE FIRST ITERATION AND IF MODE IS 1, SCALE ACCORDING +C TO THE NORMS OF THE COLUMNS OF THE INITIAL JACOBIAN. +C + IF (ITER .NE. 1) GO TO 70 + IF (MODE .EQ. 2) GO TO 50 + DO 40 J = 1, N + DIAG(J) = WA2(J) + IF (WA2(J) .EQ. ZERO) DIAG(J) = ONE + 40 CONTINUE + 50 CONTINUE +C +C ON THE FIRST ITERATION, CALCULATE THE NORM OF THE SCALED X +C AND INITIALIZE THE STEP BOUND DELTA. +C + DO 60 J = 1, N + WA3(J) = DIAG(J)*X(J) + 60 CONTINUE + XNORM = ENORM(N,WA3) + DELTA = FACTOR*XNORM + IF (DELTA .EQ. ZERO) DELTA = FACTOR + 70 CONTINUE +C +C FORM (Q TRANSPOSE)*FVEC AND STORE IN QTF. +C + DO 80 I = 1, N + QTF(I) = FVEC(I) + 80 CONTINUE + DO 120 J = 1, N + IF (FJAC(J,J) .EQ. ZERO) GO TO 110 + SUM = ZERO + DO 90 I = J, N + SUM = SUM + FJAC(I,J)*QTF(I) + 90 CONTINUE + TEMP = -SUM/FJAC(J,J) + DO 100 I = J, N + QTF(I) = QTF(I) + FJAC(I,J)*TEMP + 100 CONTINUE + 110 CONTINUE + 120 CONTINUE +C +C COPY THE TRIANGULAR FACTOR OF THE QR FACTORIZATION INTO R. +C + SING = .FALSE. + DO 150 J = 1, N + L = J + JM1 = J - 1 + IF (JM1 .LT. 1) GO TO 140 + DO 130 I = 1, JM1 + R(L) = FJAC(I,J) + L = L + N - I + 130 CONTINUE + 140 CONTINUE + R(L) = WA1(J) + IF (WA1(J) .EQ. ZERO) SING = .TRUE. + 150 CONTINUE +C +C ACCUMULATE THE ORTHOGONAL FACTOR IN FJAC. +C + CALL QFORM(N,N,FJAC,LDFJAC,WA1) +C +C RESCALE IF NECESSARY. +C + IF (MODE .EQ. 2) GO TO 170 + DO 160 J = 1, N + DIAG(J) = AMAX1(DIAG(J),WA2(J)) + 160 CONTINUE + 170 CONTINUE +C +C BEGINNING OF THE INNER LOOP. +C + 180 CONTINUE +C +C IF REQUESTED, CALL FCN TO ENABLE PRINTING OF ITERATES. +C + IF (NPRINT .LE. 0) GO TO 190 + IFLAG = 0 + IF (MOD(ITER-1,NPRINT) .EQ. 0) CALL FCN(N,X,FVEC,IFLAG) + IF (IFLAG .LT. 0) GO TO 300 + 190 CONTINUE +C +C DETERMINE THE DIRECTION P. +C + CALL DOGLEG(N,R,LR,DIAG,QTF,DELTA,WA1,WA2,WA3) +C +C STORE THE DIRECTION P AND X + P. CALCULATE THE NORM OF P. +C + DO 200 J = 1, N + WA1(J) = -WA1(J) + WA2(J) = X(J) + WA1(J) + WA3(J) = DIAG(J)*WA1(J) + 200 CONTINUE + PNORM = ENORM(N,WA3) +C +C ON THE FIRST ITERATION, ADJUST THE INITIAL STEP BOUND. +C + IF (ITER .EQ. 1) DELTA = AMIN1(DELTA,PNORM) +C +C EVALUATE THE FUNCTION AT X + P AND CALCULATE ITS NORM. +C + IFLAG = 1 + CALL FCN(N,WA2,WA4,IFLAG) + NFEV = NFEV + 1 + IF (IFLAG .LT. 0) GO TO 300 + FNORM1 = ENORM(N,WA4) +C +C COMPUTE THE SCALED ACTUAL REDUCTION. +C + ACTRED = -ONE + IF (FNORM1 .LT. FNORM) ACTRED = ONE - (FNORM1/FNORM)**2 +C +C COMPUTE THE SCALED PREDICTED REDUCTION. +C + L = 1 + DO 220 I = 1, N + SUM = ZERO + DO 210 J = I, N + SUM = SUM + R(L)*WA1(J) + L = L + 1 + 210 CONTINUE + WA3(I) = QTF(I) + SUM + 220 CONTINUE + TEMP = ENORM(N,WA3) + PRERED = ZERO + IF (TEMP .LT. FNORM) PRERED = ONE - (TEMP/FNORM)**2 +C +C COMPUTE THE RATIO OF THE ACTUAL TO THE PREDICTED +C REDUCTION. +C + RATIO = ZERO + IF (PRERED .GT. ZERO) RATIO = ACTRED/PRERED +C +C UPDATE THE STEP BOUND. +C + IF (RATIO .GE. P1) GO TO 230 + NCSUC = 0 + NCFAIL = NCFAIL + 1 + DELTA = P5*DELTA + GO TO 240 + 230 CONTINUE + NCFAIL = 0 + NCSUC = NCSUC + 1 + IF (RATIO .GE. P5 .OR. NCSUC .GT. 1) + * DELTA = AMAX1(DELTA,PNORM/P5) + IF (ABS(RATIO-ONE) .LE. P1) DELTA = PNORM/P5 + 240 CONTINUE +C +C TEST FOR SUCCESSFUL ITERATION. +C + IF (RATIO .LT. P0001) GO TO 260 +C +C SUCCESSFUL ITERATION. UPDATE X, FVEC, AND THEIR NORMS. +C + DO 250 J = 1, N + X(J) = WA2(J) + WA2(J) = DIAG(J)*X(J) + FVEC(J) = WA4(J) + 250 CONTINUE + XNORM = ENORM(N,WA2) + FNORM = FNORM1 + ITER = ITER + 1 + 260 CONTINUE +C +C DETERMINE THE PROGRESS OF THE ITERATION. +C + NSLOW1 = NSLOW1 + 1 + IF (ACTRED .GE. P001) NSLOW1 = 0 + IF (JEVAL) NSLOW2 = NSLOW2 + 1 + IF (ACTRED .GE. P1) NSLOW2 = 0 +C +C TEST FOR CONVERGENCE. +C + IF (DELTA .LE. XTOL*XNORM .OR. FNORM .EQ. ZERO) INFO = 1 + IF (INFO .NE. 0) GO TO 300 +C +C TESTS FOR TERMINATION AND STRINGENT TOLERANCES. +C + IF (NFEV .GE. MAXFEV) INFO = 2 + IF (P1*AMAX1(P1*DELTA,PNORM) .LE. EPSMCH*XNORM) INFO = 3 + IF (NSLOW2 .EQ. 5) INFO = 4 + IF (NSLOW1 .EQ. 10) INFO = 5 + IF (INFO .NE. 0) GO TO 300 +C +C CRITERION FOR RECALCULATING JACOBIAN APPROXIMATION +C BY FORWARD DIFFERENCES. +C + IF (NCFAIL .EQ. 2) GO TO 290 +C +C CALCULATE THE RANK ONE MODIFICATION TO THE JACOBIAN +C AND UPDATE QTF IF NECESSARY. +C + DO 280 J = 1, N + SUM = ZERO + DO 270 I = 1, N + SUM = SUM + FJAC(I,J)*WA4(I) + 270 CONTINUE + WA2(J) = (SUM - WA3(J))/PNORM + WA1(J) = DIAG(J)*((DIAG(J)*WA1(J))/PNORM) + IF (RATIO .GE. P0001) QTF(J) = SUM + 280 CONTINUE +C +C COMPUTE THE QR FACTORIZATION OF THE UPDATED JACOBIAN. +C + CALL R1UPDT(N,N,R,LR,WA1,WA2,WA3,SING) + CALL R1MPYQ(N,N,FJAC,LDFJAC,WA2,WA3) + CALL R1MPYQ(1,N,QTF,1,WA2,WA3) +C +C END OF THE INNER LOOP. +C + JEVAL = .FALSE. + GO TO 180 + 290 CONTINUE +C +C END OF THE OUTER LOOP. +C + GO TO 30 + 300 CONTINUE +C +C TERMINATION, EITHER NORMAL OR USER IMPOSED. +C + IF (IFLAG .LT. 0) INFO = IFLAG + IFLAG = 0 + IF (NPRINT .GT. 0) CALL FCN(N,X,FVEC,IFLAG) + RETURN +C +C LAST CARD OF SUBROUTINE HYBRD. +C + END + SUBROUTINE HYBRD1(FCN,N,X,FVEC,TOL,INFO,WA,LWA) + INTEGER N,INFO,LWA + REAL TOL + REAL X(N),FVEC(N),WA(LWA) + EXTERNAL FCN +C ********** +C +C SUBROUTINE HYBRD1 +C +C THE PURPOSE OF HYBRD1 IS TO FIND A ZERO OF A SYSTEM OF +C N NONLINEAR FUNCTIONS IN N VARIABLES BY A MODIFICATION +C OF THE POWELL HYBRID METHOD. THIS IS DONE BY USING THE +C MORE GENERAL NONLINEAR EQUATION SOLVER HYBRD. THE USER +C MUST PROVIDE A SUBROUTINE WHICH CALCULATES THE FUNCTIONS. +C THE JACOBIAN IS THEN CALCULATED BY A FORWARD-DIFFERENCE +C APPROXIMATION. +C +C THE SUBROUTINE STATEMENT IS +C +C SUBROUTINE HYBRD1(FCN,N,X,FVEC,TOL,INFO,WA,LWA) +C +C WHERE +C +C FCN IS THE NAME OF THE USER-SUPPLIED SUBROUTINE WHICH +C CALCULATES THE FUNCTIONS. FCN MUST BE DECLARED +C IN AN EXTERNAL STATEMENT IN THE USER CALLING +C PROGRAM, AND SHOULD BE WRITTEN AS FOLLOWS. +C +C SUBROUTINE FCN(N,X,FVEC,IFLAG) +C INTEGER N,IFLAG +C REAL X(N),FVEC(N) +C ---------- +C CALCULATE THE FUNCTIONS AT X AND +C RETURN THIS VECTOR IN FVEC. +C --------- +C RETURN +C END +C +C THE VALUE OF IFLAG SHOULD NOT BE CHANGED BY FCN UNLESS +C THE USER WANTS TO TERMINATE EXECUTION OF HYBRD1. +C IN THIS CASE SET IFLAG TO A NEGATIVE INTEGER. +C +C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER +C OF FUNCTIONS AND VARIABLES. +C +C X IS AN ARRAY OF LENGTH N. ON INPUT X MUST CONTAIN +C AN INITIAL ESTIMATE OF THE SOLUTION VECTOR. ON OUTPUT X +C CONTAINS THE FINAL ESTIMATE OF THE SOLUTION VECTOR. +C +C FVEC IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS +C THE FUNCTIONS EVALUATED AT THE OUTPUT X. +C +C TOL IS A NONNEGATIVE INPUT VARIABLE. TERMINATION OCCURS +C WHEN THE ALGORITHM ESTIMATES THAT THE RELATIVE ERROR +C BETWEEN X AND THE SOLUTION IS AT MOST TOL. +C +C INFO IS AN INTEGER OUTPUT VARIABLE. IF THE USER HAS +C TERMINATED EXECUTION, INFO IS SET TO THE (NEGATIVE) +C VALUE OF IFLAG. SEE DESCRIPTION OF FCN. OTHERWISE, +C INFO IS SET AS FOLLOWS. +C +C INFO = 0 IMPROPER INPUT PARAMETERS. +C +C INFO = 1 ALGORITHM ESTIMATES THAT THE RELATIVE ERROR +C BETWEEN X AND THE SOLUTION IS AT MOST TOL. +C +C INFO = 2 NUMBER OF CALLS TO FCN HAS REACHED OR EXCEEDED +C 200*(N+1). +C +C INFO = 3 TOL IS TOO SMALL. NO FURTHER IMPROVEMENT IN +C THE APPROXIMATE SOLUTION X IS POSSIBLE. +C +C INFO = 4 ITERATION IS NOT MAKING GOOD PROGRESS. +C +C WA IS A WORK ARRAY OF LENGTH LWA. +C +C LWA IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN +C (N*(3*N+13))/2. +C +C SUBPROGRAMS CALLED +C +C USER-SUPPLIED ...... FCN +C +C MINPACK-SUPPLIED ... HYBRD +C +C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. +C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE +C +C ********** + INTEGER INDEX,J,LR,MAXFEV,ML,MODE,MU,NFEV,NPRINT + REAL EPSFCN,FACTOR,ONE,XTOL,ZERO + DATA FACTOR,ONE,ZERO /1.0E2,1.0E0,0.0E0/ + INFO = 0 +C +C CHECK THE INPUT PARAMETERS FOR ERRORS. +C + IF (N .LE. 0 .OR. TOL .LT. ZERO .OR. LWA .LT. (N*(3*N + 13))/2) + * GO TO 20 +C +C CALL HYBRD. +C + MAXFEV = 200*(N + 1) + XTOL = TOL + ML = N - 1 + MU = N - 1 + EPSFCN = ZERO + MODE = 2 + DO 10 J = 1, N + WA(J) = ONE + 10 CONTINUE + NPRINT = 0 + LR = (N*(N + 1))/2 + INDEX = 6*N + LR + CALL HYBRD(FCN,N,X,FVEC,XTOL,MAXFEV,ML,MU,EPSFCN,WA(1),MODE, + * FACTOR,NPRINT,INFO,NFEV,WA(INDEX+1),N,WA(6*N+1),LR, + * WA(N+1),WA(2*N+1),WA(3*N+1),WA(4*N+1),WA(5*N+1)) + IF (INFO .EQ. 5) INFO = 4 + 20 CONTINUE + RETURN +C +C LAST CARD OF SUBROUTINE HYBRD1. +C + END + SUBROUTINE HYBRJ(FCN,N,X,FVEC,FJAC,LDFJAC,XTOL,MAXFEV,DIAG,MODE, + * FACTOR,NPRINT,INFO,NFEV,NJEV,R,LR,QTF,WA1,WA2, + * WA3,WA4) + INTEGER N,LDFJAC,MAXFEV,MODE,NPRINT,INFO,NFEV,NJEV,LR + REAL XTOL,FACTOR + REAL X(N),FVEC(N),FJAC(LDFJAC,N),DIAG(N),R(LR),QTF(N),WA1(N), + * WA2(N),WA3(N),WA4(N) +C ********** +C +C SUBROUTINE HYBRJ +C +C THE PURPOSE OF HYBRJ IS TO FIND A ZERO OF A SYSTEM OF +C N NONLINEAR FUNCTIONS IN N VARIABLES BY A MODIFICATION +C OF THE POWELL HYBRID METHOD. THE USER MUST PROVIDE A +C SUBROUTINE WHICH CALCULATES THE FUNCTIONS AND THE JACOBIAN. +C +C THE SUBROUTINE STATEMENT IS +C +C SUBROUTINE HYBRJ(FCN,N,X,FVEC,FJAC,LDFJAC,XTOL,MAXFEV,DIAG, +C MODE,FACTOR,NPRINT,INFO,NFEV,NJEV,R,LR,QTF, +C WA1,WA2,WA3,WA4) +C +C WHERE +C +C FCN IS THE NAME OF THE USER-SUPPLIED SUBROUTINE WHICH +C CALCULATES THE FUNCTIONS AND THE JACOBIAN. FCN MUST +C BE DECLARED IN AN EXTERNAL STATEMENT IN THE USER +C CALLING PROGRAM, AND SHOULD BE WRITTEN AS FOLLOWS. +C +C SUBROUTINE FCN(N,X,FVEC,FJAC,LDFJAC,IFLAG) +C INTEGER N,LDFJAC,IFLAG +C REAL X(N),FVEC(N),FJAC(LDFJAC,N) +C ---------- +C IF IFLAG = 1 CALCULATE THE FUNCTIONS AT X AND +C RETURN THIS VECTOR IN FVEC. DO NOT ALTER FJAC. +C IF IFLAG = 2 CALCULATE THE JACOBIAN AT X AND +C RETURN THIS MATRIX IN FJAC. DO NOT ALTER FVEC. +C --------- +C RETURN +C END +C +C THE VALUE OF IFLAG SHOULD NOT BE CHANGED BY FCN UNLESS +C THE USER WANTS TO TERMINATE EXECUTION OF HYBRJ. +C IN THIS CASE SET IFLAG TO A NEGATIVE INTEGER. +C +C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER +C OF FUNCTIONS AND VARIABLES. +C +C X IS AN ARRAY OF LENGTH N. ON INPUT X MUST CONTAIN +C AN INITIAL ESTIMATE OF THE SOLUTION VECTOR. ON OUTPUT X +C CONTAINS THE FINAL ESTIMATE OF THE SOLUTION VECTOR. +C +C FVEC IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS +C THE FUNCTIONS EVALUATED AT THE OUTPUT X. +C +C FJAC IS AN OUTPUT N BY N ARRAY WHICH CONTAINS THE +C ORTHOGONAL MATRIX Q PRODUCED BY THE QR FACTORIZATION +C OF THE FINAL APPROXIMATE JACOBIAN. +C +C LDFJAC IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN N +C WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY FJAC. +C +C XTOL IS A NONNEGATIVE INPUT VARIABLE. TERMINATION +C OCCURS WHEN THE RELATIVE ERROR BETWEEN TWO CONSECUTIVE +C ITERATES IS AT MOST XTOL. +C +C MAXFEV IS A POSITIVE INTEGER INPUT VARIABLE. TERMINATION +C OCCURS WHEN THE NUMBER OF CALLS TO FCN WITH IFLAG = 1 +C HAS REACHED MAXFEV. +C +C DIAG IS AN ARRAY OF LENGTH N. IF MODE = 1 (SEE +C BELOW), DIAG IS INTERNALLY SET. IF MODE = 2, DIAG +C MUST CONTAIN POSITIVE ENTRIES THAT SERVE AS +C MULTIPLICATIVE SCALE FACTORS FOR THE VARIABLES. +C +C MODE IS AN INTEGER INPUT VARIABLE. IF MODE = 1, THE +C VARIABLES WILL BE SCALED INTERNALLY. IF MODE = 2, +C THE SCALING IS SPECIFIED BY THE INPUT DIAG. OTHER +C VALUES OF MODE ARE EQUIVALENT TO MODE = 1. +C +C FACTOR IS A POSITIVE INPUT VARIABLE USED IN DETERMINING THE +C INITIAL STEP BOUND. THIS BOUND IS SET TO THE PRODUCT OF +C FACTOR AND THE EUCLIDEAN NORM OF DIAG*X IF NONZERO, OR ELSE +C TO FACTOR ITSELF. IN MOST CASES FACTOR SHOULD LIE IN THE +C INTERVAL (.1,100.). 100. IS A GENERALLY RECOMMENDED VALUE. +C +C NPRINT IS AN INTEGER INPUT VARIABLE THAT ENABLES CONTROLLED +C PRINTING OF ITERATES IF IT IS POSITIVE. IN THIS CASE, +C FCN IS CALLED WITH IFLAG = 0 AT THE BEGINNING OF THE FIRST +C ITERATION AND EVERY NPRINT ITERATIONS THEREAFTER AND +C IMMEDIATELY PRIOR TO RETURN, WITH X AND FVEC AVAILABLE +C FOR PRINTING. FVEC AND FJAC SHOULD NOT BE ALTERED. +C IF NPRINT IS NOT POSITIVE, NO SPECIAL CALLS OF FCN +C WITH IFLAG = 0 ARE MADE. +C +C INFO IS AN INTEGER OUTPUT VARIABLE. IF THE USER HAS +C TERMINATED EXECUTION, INFO IS SET TO THE (NEGATIVE) +C VALUE OF IFLAG. SEE DESCRIPTION OF FCN. OTHERWISE, +C INFO IS SET AS FOLLOWS. +C +C INFO = 0 IMPROPER INPUT PARAMETERS. +C +C INFO = 1 RELATIVE ERROR BETWEEN TWO CONSECUTIVE ITERATES +C IS AT MOST XTOL. +C +C INFO = 2 NUMBER OF CALLS TO FCN WITH IFLAG = 1 HAS +C REACHED MAXFEV. +C +C INFO = 3 XTOL IS TOO SMALL. NO FURTHER IMPROVEMENT IN +C THE APPROXIMATE SOLUTION X IS POSSIBLE. +C +C INFO = 4 ITERATION IS NOT MAKING GOOD PROGRESS, AS +C MEASURED BY THE IMPROVEMENT FROM THE LAST +C FIVE JACOBIAN EVALUATIONS. +C +C INFO = 5 ITERATION IS NOT MAKING GOOD PROGRESS, AS +C MEASURED BY THE IMPROVEMENT FROM THE LAST +C TEN ITERATIONS. +C +C NFEV IS AN INTEGER OUTPUT VARIABLE SET TO THE NUMBER OF +C CALLS TO FCN WITH IFLAG = 1. +C +C NJEV IS AN INTEGER OUTPUT VARIABLE SET TO THE NUMBER OF +C CALLS TO FCN WITH IFLAG = 2. +C +C R IS AN OUTPUT ARRAY OF LENGTH LR WHICH CONTAINS THE +C UPPER TRIANGULAR MATRIX PRODUCED BY THE QR FACTORIZATION +C OF THE FINAL APPROXIMATE JACOBIAN, STORED ROWWISE. +C +C LR IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN +C (N*(N+1))/2. +C +C QTF IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS +C THE VECTOR (Q TRANSPOSE)*FVEC. +C +C WA1, WA2, WA3, AND WA4 ARE WORK ARRAYS OF LENGTH N. +C +C SUBPROGRAMS CALLED +C +C USER-SUPPLIED ...... FCN +C +C MINPACK-SUPPLIED ... DOGLEG,SPMPAR,ENORM, +C QFORM,QRFAC,R1MPYQ,R1UPDT +C +C FORTRAN-SUPPLIED ... ABS,AMAX1,AMIN1,MOD +C +C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. +C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE +C +C ********** + INTEGER I,IFLAG,ITER,J,JM1,L,NCFAIL,NCSUC,NSLOW1,NSLOW2 + INTEGER IWA(1) + LOGICAL JEVAL,SING + REAL ACTRED,DELTA,EPSMCH,FNORM,FNORM1,ONE,PNORM,PRERED,P1,P5, + * P001,P0001,RATIO,SUM,TEMP,XNORM,ZERO + REAL SPMPAR,ENORM + DATA ONE,P1,P5,P001,P0001,ZERO + * /1.0E0,1.0E-1,5.0E-1,1.0E-3,1.0E-4,0.0E0/ +C +C EPSMCH IS THE MACHINE PRECISION. +C + EPSMCH = SPMPAR(1) +C + INFO = 0 + IFLAG = 0 + NFEV = 0 + NJEV = 0 +C +C CHECK THE INPUT PARAMETERS FOR ERRORS. +C + IF (N .LE. 0 .OR. LDFJAC .LT. N .OR. XTOL .LT. ZERO + * .OR. MAXFEV .LE. 0 .OR. FACTOR .LE. ZERO + * .OR. LR .LT. (N*(N + 1))/2) GO TO 300 + IF (MODE .NE. 2) GO TO 20 + DO 10 J = 1, N + IF (DIAG(J) .LE. ZERO) GO TO 300 + 10 CONTINUE + 20 CONTINUE +C +C EVALUATE THE FUNCTION AT THE STARTING POINT +C AND CALCULATE ITS NORM. +C + IFLAG = 1 + CALL FCN(N,X,FVEC,FJAC,LDFJAC,IFLAG) + NFEV = 1 + IF (IFLAG .LT. 0) GO TO 300 + FNORM = ENORM(N,FVEC) +C +C INITIALIZE ITERATION COUNTER AND MONITORS. +C + ITER = 1 + NCSUC = 0 + NCFAIL = 0 + NSLOW1 = 0 + NSLOW2 = 0 +C +C BEGINNING OF THE OUTER LOOP. +C + 30 CONTINUE + JEVAL = .TRUE. +C +C CALCULATE THE JACOBIAN MATRIX. +C + IFLAG = 2 + CALL FCN(N,X,FVEC,FJAC,LDFJAC,IFLAG) + NJEV = NJEV + 1 + IF (IFLAG .LT. 0) GO TO 300 +C +C COMPUTE THE QR FACTORIZATION OF THE JACOBIAN. +C + CALL QRFAC(N,N,FJAC,LDFJAC,.FALSE.,IWA,1,WA1,WA2,WA3) +C +C ON THE FIRST ITERATION AND IF MODE IS 1, SCALE ACCORDING +C TO THE NORMS OF THE COLUMNS OF THE INITIAL JACOBIAN. +C + IF (ITER .NE. 1) GO TO 70 + IF (MODE .EQ. 2) GO TO 50 + DO 40 J = 1, N + DIAG(J) = WA2(J) + IF (WA2(J) .EQ. ZERO) DIAG(J) = ONE + 40 CONTINUE + 50 CONTINUE +C +C ON THE FIRST ITERATION, CALCULATE THE NORM OF THE SCALED X +C AND INITIALIZE THE STEP BOUND DELTA. +C + DO 60 J = 1, N + WA3(J) = DIAG(J)*X(J) + 60 CONTINUE + XNORM = ENORM(N,WA3) + DELTA = FACTOR*XNORM + IF (DELTA .EQ. ZERO) DELTA = FACTOR + 70 CONTINUE +C +C FORM (Q TRANSPOSE)*FVEC AND STORE IN QTF. +C + DO 80 I = 1, N + QTF(I) = FVEC(I) + 80 CONTINUE + DO 120 J = 1, N + IF (FJAC(J,J) .EQ. ZERO) GO TO 110 + SUM = ZERO + DO 90 I = J, N + SUM = SUM + FJAC(I,J)*QTF(I) + 90 CONTINUE + TEMP = -SUM/FJAC(J,J) + DO 100 I = J, N + QTF(I) = QTF(I) + FJAC(I,J)*TEMP + 100 CONTINUE + 110 CONTINUE + 120 CONTINUE +C +C COPY THE TRIANGULAR FACTOR OF THE QR FACTORIZATION INTO R. +C + SING = .FALSE. + DO 150 J = 1, N + L = J + JM1 = J - 1 + IF (JM1 .LT. 1) GO TO 140 + DO 130 I = 1, JM1 + R(L) = FJAC(I,J) + L = L + N - I + 130 CONTINUE + 140 CONTINUE + R(L) = WA1(J) + IF (WA1(J) .EQ. ZERO) SING = .TRUE. + 150 CONTINUE +C +C ACCUMULATE THE ORTHOGONAL FACTOR IN FJAC. +C + CALL QFORM(N,N,FJAC,LDFJAC,WA1) +C +C RESCALE IF NECESSARY. +C + IF (MODE .EQ. 2) GO TO 170 + DO 160 J = 1, N + DIAG(J) = AMAX1(DIAG(J),WA2(J)) + 160 CONTINUE + 170 CONTINUE +C +C BEGINNING OF THE INNER LOOP. +C + 180 CONTINUE +C +C IF REQUESTED, CALL FCN TO ENABLE PRINTING OF ITERATES. +C + IF (NPRINT .LE. 0) GO TO 190 + IFLAG = 0 + IF (MOD(ITER-1,NPRINT) .EQ. 0) + * CALL FCN(N,X,FVEC,FJAC,LDFJAC,IFLAG) + IF (IFLAG .LT. 0) GO TO 300 + 190 CONTINUE +C +C DETERMINE THE DIRECTION P. +C + CALL DOGLEG(N,R,LR,DIAG,QTF,DELTA,WA1,WA2,WA3) +C +C STORE THE DIRECTION P AND X + P. CALCULATE THE NORM OF P. +C + DO 200 J = 1, N + WA1(J) = -WA1(J) + WA2(J) = X(J) + WA1(J) + WA3(J) = DIAG(J)*WA1(J) + 200 CONTINUE + PNORM = ENORM(N,WA3) +C +C ON THE FIRST ITERATION, ADJUST THE INITIAL STEP BOUND. +C + IF (ITER .EQ. 1) DELTA = AMIN1(DELTA,PNORM) +C +C EVALUATE THE FUNCTION AT X + P AND CALCULATE ITS NORM. +C + IFLAG = 1 + CALL FCN(N,WA2,WA4,FJAC,LDFJAC,IFLAG) + NFEV = NFEV + 1 + IF (IFLAG .LT. 0) GO TO 300 + FNORM1 = ENORM(N,WA4) +C +C COMPUTE THE SCALED ACTUAL REDUCTION. +C + ACTRED = -ONE + IF (FNORM1 .LT. FNORM) ACTRED = ONE - (FNORM1/FNORM)**2 +C +C COMPUTE THE SCALED PREDICTED REDUCTION. +C + L = 1 + DO 220 I = 1, N + SUM = ZERO + DO 210 J = I, N + SUM = SUM + R(L)*WA1(J) + L = L + 1 + 210 CONTINUE + WA3(I) = QTF(I) + SUM + 220 CONTINUE + TEMP = ENORM(N,WA3) + PRERED = ZERO + IF (TEMP .LT. FNORM) PRERED = ONE - (TEMP/FNORM)**2 +C +C COMPUTE THE RATIO OF THE ACTUAL TO THE PREDICTED +C REDUCTION. +C + RATIO = ZERO + IF (PRERED .GT. ZERO) RATIO = ACTRED/PRERED +C +C UPDATE THE STEP BOUND. +C + IF (RATIO .GE. P1) GO TO 230 + NCSUC = 0 + NCFAIL = NCFAIL + 1 + DELTA = P5*DELTA + GO TO 240 + 230 CONTINUE + NCFAIL = 0 + NCSUC = NCSUC + 1 + IF (RATIO .GE. P5 .OR. NCSUC .GT. 1) + * DELTA = AMAX1(DELTA,PNORM/P5) + IF (ABS(RATIO-ONE) .LE. P1) DELTA = PNORM/P5 + 240 CONTINUE +C +C TEST FOR SUCCESSFUL ITERATION. +C + IF (RATIO .LT. P0001) GO TO 260 +C +C SUCCESSFUL ITERATION. UPDATE X, FVEC, AND THEIR NORMS. +C + DO 250 J = 1, N + X(J) = WA2(J) + WA2(J) = DIAG(J)*X(J) + FVEC(J) = WA4(J) + 250 CONTINUE + XNORM = ENORM(N,WA2) + FNORM = FNORM1 + ITER = ITER + 1 + 260 CONTINUE +C +C DETERMINE THE PROGRESS OF THE ITERATION. +C + NSLOW1 = NSLOW1 + 1 + IF (ACTRED .GE. P001) NSLOW1 = 0 + IF (JEVAL) NSLOW2 = NSLOW2 + 1 + IF (ACTRED .GE. P1) NSLOW2 = 0 +C +C TEST FOR CONVERGENCE. +C + IF (DELTA .LE. XTOL*XNORM .OR. FNORM .EQ. ZERO) INFO = 1 + IF (INFO .NE. 0) GO TO 300 +C +C TESTS FOR TERMINATION AND STRINGENT TOLERANCES. +C + IF (NFEV .GE. MAXFEV) INFO = 2 + IF (P1*AMAX1(P1*DELTA,PNORM) .LE. EPSMCH*XNORM) INFO = 3 + IF (NSLOW2 .EQ. 5) INFO = 4 + IF (NSLOW1 .EQ. 10) INFO = 5 + IF (INFO .NE. 0) GO TO 300 +C +C CRITERION FOR RECALCULATING JACOBIAN. +C + IF (NCFAIL .EQ. 2) GO TO 290 +C +C CALCULATE THE RANK ONE MODIFICATION TO THE JACOBIAN +C AND UPDATE QTF IF NECESSARY. +C + DO 280 J = 1, N + SUM = ZERO + DO 270 I = 1, N + SUM = SUM + FJAC(I,J)*WA4(I) + 270 CONTINUE + WA2(J) = (SUM - WA3(J))/PNORM + WA1(J) = DIAG(J)*((DIAG(J)*WA1(J))/PNORM) + IF (RATIO .GE. P0001) QTF(J) = SUM + 280 CONTINUE +C +C COMPUTE THE QR FACTORIZATION OF THE UPDATED JACOBIAN. +C + CALL R1UPDT(N,N,R,LR,WA1,WA2,WA3,SING) + CALL R1MPYQ(N,N,FJAC,LDFJAC,WA2,WA3) + CALL R1MPYQ(1,N,QTF,1,WA2,WA3) +C +C END OF THE INNER LOOP. +C + JEVAL = .FALSE. + GO TO 180 + 290 CONTINUE +C +C END OF THE OUTER LOOP. +C + GO TO 30 + 300 CONTINUE +C +C TERMINATION, EITHER NORMAL OR USER IMPOSED. +C + IF (IFLAG .LT. 0) INFO = IFLAG + IFLAG = 0 + IF (NPRINT .GT. 0) CALL FCN(N,X,FVEC,FJAC,LDFJAC,IFLAG) + RETURN +C +C LAST CARD OF SUBROUTINE HYBRJ. +C + END + SUBROUTINE HYBRJ1(FCN,N,X,FVEC,FJAC,LDFJAC,TOL,INFO,WA,LWA) + INTEGER N,LDFJAC,INFO,LWA + REAL TOL + REAL X(N),FVEC(N),FJAC(LDFJAC,N),WA(LWA) + EXTERNAL FCN +C ********** +C +C SUBROUTINE HYBRJ1 +C +C THE PURPOSE OF HYBRJ1 IS TO FIND A ZERO OF A SYSTEM OF +C N NONLINEAR FUNCTIONS IN N VARIABLES BY A MODIFICATION +C OF THE POWELL HYBRID METHOD. THIS IS DONE BY USING THE +C MORE GENERAL NONLINEAR EQUATION SOLVER HYBRJ. THE USER +C MUST PROVIDE A SUBROUTINE WHICH CALCULATES THE FUNCTIONS +C AND THE JACOBIAN. +C +C THE SUBROUTINE STATEMENT IS +C +C SUBROUTINE HYBRJ1(FCN,N,X,FVEC,FJAC,LDFJAC,TOL,INFO,WA,LWA) +C +C WHERE +C +C FCN IS THE NAME OF THE USER-SUPPLIED SUBROUTINE WHICH +C CALCULATES THE FUNCTIONS AND THE JACOBIAN. FCN MUST +C BE DECLARED IN AN EXTERNAL STATEMENT IN THE USER +C CALLING PROGRAM, AND SHOULD BE WRITTEN AS FOLLOWS. +C +C SUBROUTINE FCN(N,X,FVEC,FJAC,LDFJAC,IFLAG) +C INTEGER N,LDFJAC,IFLAG +C REAL X(N),FVEC(N),FJAC(LDFJAC,N) +C ---------- +C IF IFLAG = 1 CALCULATE THE FUNCTIONS AT X AND +C RETURN THIS VECTOR IN FVEC. DO NOT ALTER FJAC. +C IF IFLAG = 2 CALCULATE THE JACOBIAN AT X AND +C RETURN THIS MATRIX IN FJAC. DO NOT ALTER FVEC. +C --------- +C RETURN +C END +C +C THE VALUE OF IFLAG SHOULD NOT BE CHANGED BY FCN UNLESS +C THE USER WANTS TO TERMINATE EXECUTION OF HYBRJ1. +C IN THIS CASE SET IFLAG TO A NEGATIVE INTEGER. +C +C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER +C OF FUNCTIONS AND VARIABLES. +C +C X IS AN ARRAY OF LENGTH N. ON INPUT X MUST CONTAIN +C AN INITIAL ESTIMATE OF THE SOLUTION VECTOR. ON OUTPUT X +C CONTAINS THE FINAL ESTIMATE OF THE SOLUTION VECTOR. +C +C FVEC IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS +C THE FUNCTIONS EVALUATED AT THE OUTPUT X. +C +C FJAC IS AN OUTPUT N BY N ARRAY WHICH CONTAINS THE +C ORTHOGONAL MATRIX Q PRODUCED BY THE QR FACTORIZATION +C OF THE FINAL APPROXIMATE JACOBIAN. +C +C LDFJAC IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN N +C WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY FJAC. +C +C TOL IS A NONNEGATIVE INPUT VARIABLE. TERMINATION OCCURS +C WHEN THE ALGORITHM ESTIMATES THAT THE RELATIVE ERROR +C BETWEEN X AND THE SOLUTION IS AT MOST TOL. +C +C INFO IS AN INTEGER OUTPUT VARIABLE. IF THE USER HAS +C TERMINATED EXECUTION, INFO IS SET TO THE (NEGATIVE) +C VALUE OF IFLAG. SEE DESCRIPTION OF FCN. OTHERWISE, +C INFO IS SET AS FOLLOWS. +C +C INFO = 0 IMPROPER INPUT PARAMETERS. +C +C INFO = 1 ALGORITHM ESTIMATES THAT THE RELATIVE ERROR +C BETWEEN X AND THE SOLUTION IS AT MOST TOL. +C +C INFO = 2 NUMBER OF CALLS TO FCN WITH IFLAG = 1 HAS +C REACHED 100*(N+1). +C +C INFO = 3 TOL IS TOO SMALL. NO FURTHER IMPROVEMENT IN +C THE APPROXIMATE SOLUTION X IS POSSIBLE. +C +C INFO = 4 ITERATION IS NOT MAKING GOOD PROGRESS. +C +C WA IS A WORK ARRAY OF LENGTH LWA. +C +C LWA IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN +C (N*(N+13))/2. +C +C SUBPROGRAMS CALLED +C +C USER-SUPPLIED ...... FCN +C +C MINPACK-SUPPLIED ... HYBRJ +C +C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. +C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE +C +C ********** + INTEGER J,LR,MAXFEV,MODE,NFEV,NJEV,NPRINT + REAL FACTOR,ONE,XTOL,ZERO + DATA FACTOR,ONE,ZERO /1.0E2,1.0E0,0.0E0/ + INFO = 0 +C +C CHECK THE INPUT PARAMETERS FOR ERRORS. +C + IF (N .LE. 0 .OR. LDFJAC .LT. N .OR. TOL .LT. ZERO + * .OR. LWA .LT. (N*(N + 13))/2) GO TO 20 +C +C CALL HYBRJ. +C + MAXFEV = 100*(N + 1) + XTOL = TOL + MODE = 2 + DO 10 J = 1, N + WA(J) = ONE + 10 CONTINUE + NPRINT = 0 + LR = (N*(N + 1))/2 + CALL HYBRJ(FCN,N,X,FVEC,FJAC,LDFJAC,XTOL,MAXFEV,WA(1),MODE, + * FACTOR,NPRINT,INFO,NFEV,NJEV,WA(6*N+1),LR,WA(N+1), + * WA(2*N+1),WA(3*N+1),WA(4*N+1),WA(5*N+1)) + IF (INFO .EQ. 5) INFO = 4 + 20 CONTINUE + RETURN +C +C LAST CARD OF SUBROUTINE HYBRJ1. +C + END + SUBROUTINE LMDER(FCN,M,N,X,FVEC,FJAC,LDFJAC,FTOL,XTOL,GTOL, + * MAXFEV,DIAG,MODE,FACTOR,NPRINT,INFO,NFEV,NJEV, + * IPVT,QTF,WA1,WA2,WA3,WA4) + INTEGER M,N,LDFJAC,MAXFEV,MODE,NPRINT,INFO,NFEV,NJEV + INTEGER IPVT(N) + REAL FTOL,XTOL,GTOL,FACTOR + REAL X(N),FVEC(M),FJAC(LDFJAC,N),DIAG(N),QTF(N),WA1(N),WA2(N), + * WA3(N),WA4(M) +C ********** +C +C SUBROUTINE LMDER +C +C THE PURPOSE OF LMDER IS TO MINIMIZE THE SUM OF THE SQUARES OF +C M NONLINEAR FUNCTIONS IN N VARIABLES BY A MODIFICATION OF +C THE LEVENBERG-MARQUARDT ALGORITHM. THE USER MUST PROVIDE A +C SUBROUTINE WHICH CALCULATES THE FUNCTIONS AND THE JACOBIAN. +C +C THE SUBROUTINE STATEMENT IS +C +C SUBROUTINE LMDER(FCN,M,N,X,FVEC,FJAC,LDFJAC,FTOL,XTOL,GTOL, +C MAXFEV,DIAG,MODE,FACTOR,NPRINT,INFO,NFEV, +C NJEV,IPVT,QTF,WA1,WA2,WA3,WA4) +C +C WHERE +C +C FCN IS THE NAME OF THE USER-SUPPLIED SUBROUTINE WHICH +C CALCULATES THE FUNCTIONS AND THE JACOBIAN. FCN MUST +C BE DECLARED IN AN EXTERNAL STATEMENT IN THE USER +C CALLING PROGRAM, AND SHOULD BE WRITTEN AS FOLLOWS. +C +C SUBROUTINE FCN(M,N,X,FVEC,FJAC,LDFJAC,IFLAG) +C INTEGER M,N,LDFJAC,IFLAG +C REAL X(N),FVEC(M),FJAC(LDFJAC,N) +C ---------- +C IF IFLAG = 1 CALCULATE THE FUNCTIONS AT X AND +C RETURN THIS VECTOR IN FVEC. DO NOT ALTER FJAC. +C IF IFLAG = 2 CALCULATE THE JACOBIAN AT X AND +C RETURN THIS MATRIX IN FJAC. DO NOT ALTER FVEC. +C ---------- +C RETURN +C END +C +C THE VALUE OF IFLAG SHOULD NOT BE CHANGED BY FCN UNLESS +C THE USER WANTS TO TERMINATE EXECUTION OF LMDER. +C IN THIS CASE SET IFLAG TO A NEGATIVE INTEGER. +C +C M IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER +C OF FUNCTIONS. +C +C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER +C OF VARIABLES. N MUST NOT EXCEED M. +C +C X IS AN ARRAY OF LENGTH N. ON INPUT X MUST CONTAIN +C AN INITIAL ESTIMATE OF THE SOLUTION VECTOR. ON OUTPUT X +C CONTAINS THE FINAL ESTIMATE OF THE SOLUTION VECTOR. +C +C FVEC IS AN OUTPUT ARRAY OF LENGTH M WHICH CONTAINS +C THE FUNCTIONS EVALUATED AT THE OUTPUT X. +C +C FJAC IS AN OUTPUT M BY N ARRAY. THE UPPER N BY N SUBMATRIX +C OF FJAC CONTAINS AN UPPER TRIANGULAR MATRIX R WITH +C DIAGONAL ELEMENTS OF NONINCREASING MAGNITUDE SUCH THAT +C +C T T T +C P *(JAC *JAC)*P = R *R, +C +C WHERE P IS A PERMUTATION MATRIX AND JAC IS THE FINAL +C CALCULATED JACOBIAN. COLUMN J OF P IS COLUMN IPVT(J) +C (SEE BELOW) OF THE IDENTITY MATRIX. THE LOWER TRAPEZOIDAL +C PART OF FJAC CONTAINS INFORMATION GENERATED DURING +C THE COMPUTATION OF R. +C +C LDFJAC IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN M +C WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY FJAC. +C +C FTOL IS A NONNEGATIVE INPUT VARIABLE. TERMINATION +C OCCURS WHEN BOTH THE ACTUAL AND PREDICTED RELATIVE +C REDUCTIONS IN THE SUM OF SQUARES ARE AT MOST FTOL. +C THEREFORE, FTOL MEASURES THE RELATIVE ERROR DESIRED +C IN THE SUM OF SQUARES. +C +C XTOL IS A NONNEGATIVE INPUT VARIABLE. TERMINATION +C OCCURS WHEN THE RELATIVE ERROR BETWEEN TWO CONSECUTIVE +C ITERATES IS AT MOST XTOL. THEREFORE, XTOL MEASURES THE +C RELATIVE ERROR DESIRED IN THE APPROXIMATE SOLUTION. +C +C GTOL IS A NONNEGATIVE INPUT VARIABLE. TERMINATION +C OCCURS WHEN THE COSINE OF THE ANGLE BETWEEN FVEC AND +C ANY COLUMN OF THE JACOBIAN IS AT MOST GTOL IN ABSOLUTE +C VALUE. THEREFORE, GTOL MEASURES THE ORTHOGONALITY +C DESIRED BETWEEN THE FUNCTION VECTOR AND THE COLUMNS +C OF THE JACOBIAN. +C +C MAXFEV IS A POSITIVE INTEGER INPUT VARIABLE. TERMINATION +C OCCURS WHEN THE NUMBER OF CALLS TO FCN WITH IFLAG = 1 +C HAS REACHED MAXFEV. +C +C DIAG IS AN ARRAY OF LENGTH N. IF MODE = 1 (SEE +C BELOW), DIAG IS INTERNALLY SET. IF MODE = 2, DIAG +C MUST CONTAIN POSITIVE ENTRIES THAT SERVE AS +C MULTIPLICATIVE SCALE FACTORS FOR THE VARIABLES. +C +C MODE IS AN INTEGER INPUT VARIABLE. IF MODE = 1, THE +C VARIABLES WILL BE SCALED INTERNALLY. IF MODE = 2, +C THE SCALING IS SPECIFIED BY THE INPUT DIAG. OTHER +C VALUES OF MODE ARE EQUIVALENT TO MODE = 1. +C +C FACTOR IS A POSITIVE INPUT VARIABLE USED IN DETERMINING THE +C INITIAL STEP BOUND. THIS BOUND IS SET TO THE PRODUCT OF +C FACTOR AND THE EUCLIDEAN NORM OF DIAG*X IF NONZERO, OR ELSE +C TO FACTOR ITSELF. IN MOST CASES FACTOR SHOULD LIE IN THE +C INTERVAL (.1,100.). 100. IS A GENERALLY RECOMMENDED VALUE. +C +C NPRINT IS AN INTEGER INPUT VARIABLE THAT ENABLES CONTROLLED +C PRINTING OF ITERATES IF IT IS POSITIVE. IN THIS CASE, +C FCN IS CALLED WITH IFLAG = 0 AT THE BEGINNING OF THE FIRST +C ITERATION AND EVERY NPRINT ITERATIONS THEREAFTER AND +C IMMEDIATELY PRIOR TO RETURN, WITH X, FVEC, AND FJAC +C AVAILABLE FOR PRINTING. FVEC AND FJAC SHOULD NOT BE +C ALTERED. IF NPRINT IS NOT POSITIVE, NO SPECIAL CALLS +C OF FCN WITH IFLAG = 0 ARE MADE. +C +C INFO IS AN INTEGER OUTPUT VARIABLE. IF THE USER HAS +C TERMINATED EXECUTION, INFO IS SET TO THE (NEGATIVE) +C VALUE OF IFLAG. SEE DESCRIPTION OF FCN. OTHERWISE, +C INFO IS SET AS FOLLOWS. +C +C INFO = 0 IMPROPER INPUT PARAMETERS. +C +C INFO = 1 BOTH ACTUAL AND PREDICTED RELATIVE REDUCTIONS +C IN THE SUM OF SQUARES ARE AT MOST FTOL. +C +C INFO = 2 RELATIVE ERROR BETWEEN TWO CONSECUTIVE ITERATES +C IS AT MOST XTOL. +C +C INFO = 3 CONDITIONS FOR INFO = 1 AND INFO = 2 BOTH HOLD. +C +C INFO = 4 THE COSINE OF THE ANGLE BETWEEN FVEC AND ANY +C COLUMN OF THE JACOBIAN IS AT MOST GTOL IN +C ABSOLUTE VALUE. +C +C INFO = 5 NUMBER OF CALLS TO FCN WITH IFLAG = 1 HAS +C REACHED MAXFEV. +C +C INFO = 6 FTOL IS TOO SMALL. NO FURTHER REDUCTION IN +C THE SUM OF SQUARES IS POSSIBLE. +C +C INFO = 7 XTOL IS TOO SMALL. NO FURTHER IMPROVEMENT IN +C THE APPROXIMATE SOLUTION X IS POSSIBLE. +C +C INFO = 8 GTOL IS TOO SMALL. FVEC IS ORTHOGONAL TO THE +C COLUMNS OF THE JACOBIAN TO MACHINE PRECISION. +C +C NFEV IS AN INTEGER OUTPUT VARIABLE SET TO THE NUMBER OF +C CALLS TO FCN WITH IFLAG = 1. +C +C NJEV IS AN INTEGER OUTPUT VARIABLE SET TO THE NUMBER OF +C CALLS TO FCN WITH IFLAG = 2. +C +C IPVT IS AN INTEGER OUTPUT ARRAY OF LENGTH N. IPVT +C DEFINES A PERMUTATION MATRIX P SUCH THAT JAC*P = Q*R, +C WHERE JAC IS THE FINAL CALCULATED JACOBIAN, Q IS +C ORTHOGONAL (NOT STORED), AND R IS UPPER TRIANGULAR +C WITH DIAGONAL ELEMENTS OF NONINCREASING MAGNITUDE. +C COLUMN J OF P IS COLUMN IPVT(J) OF THE IDENTITY MATRIX. +C +C QTF IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS +C THE FIRST N ELEMENTS OF THE VECTOR (Q TRANSPOSE)*FVEC. +C +C WA1, WA2, AND WA3 ARE WORK ARRAYS OF LENGTH N. +C +C WA4 IS A WORK ARRAY OF LENGTH M. +C +C SUBPROGRAMS CALLED +C +C USER-SUPPLIED ...... FCN +C +C MINPACK-SUPPLIED ... SPMPAR,ENORM,LMPAR,QRFAC +C +C FORTRAN-SUPPLIED ... ABS,AMAX1,AMIN1,SQRT,MOD +C +C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. +C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE +C +C ********** + INTEGER I,IFLAG,ITER,J,L + REAL ACTRED,DELTA,DIRDER,EPSMCH,FNORM,FNORM1,GNORM,ONE,PAR, + * PNORM,PRERED,P1,P5,P25,P75,P0001,RATIO,SUM,TEMP,TEMP1, + * TEMP2,XNORM,ZERO + REAL SPMPAR,ENORM + DATA ONE,P1,P5,P25,P75,P0001,ZERO + * /1.0E0,1.0E-1,5.0E-1,2.5E-1,7.5E-1,1.0E-4,0.0E0/ +C +C EPSMCH IS THE MACHINE PRECISION. +C + EPSMCH = SPMPAR(1) +C + INFO = 0 + IFLAG = 0 + NFEV = 0 + NJEV = 0 +C +C CHECK THE INPUT PARAMETERS FOR ERRORS. +C + IF (N .LE. 0 .OR. M .LT. N .OR. LDFJAC .LT. M + * .OR. FTOL .LT. ZERO .OR. XTOL .LT. ZERO .OR. GTOL .LT. ZERO + * .OR. MAXFEV .LE. 0 .OR. FACTOR .LE. ZERO) GO TO 300 + IF (MODE .NE. 2) GO TO 20 + DO 10 J = 1, N + IF (DIAG(J) .LE. ZERO) GO TO 300 + 10 CONTINUE + 20 CONTINUE +C +C EVALUATE THE FUNCTION AT THE STARTING POINT +C AND CALCULATE ITS NORM. +C + IFLAG = 1 + CALL FCN(M,N,X,FVEC,FJAC,LDFJAC,IFLAG) + NFEV = 1 + IF (IFLAG .LT. 0) GO TO 300 + FNORM = ENORM(M,FVEC) +C +C INITIALIZE LEVENBERG-MARQUARDT PARAMETER AND ITERATION COUNTER. +C + PAR = ZERO + ITER = 1 +C +C BEGINNING OF THE OUTER LOOP. +C + 30 CONTINUE +C +C CALCULATE THE JACOBIAN MATRIX. +C + IFLAG = 2 + CALL FCN(M,N,X,FVEC,FJAC,LDFJAC,IFLAG) + NJEV = NJEV + 1 + IF (IFLAG .LT. 0) GO TO 300 +C +C IF REQUESTED, CALL FCN TO ENABLE PRINTING OF ITERATES. +C + IF (NPRINT .LE. 0) GO TO 40 + IFLAG = 0 + IF (MOD(ITER-1,NPRINT) .EQ. 0) + * CALL FCN(M,N,X,FVEC,FJAC,LDFJAC,IFLAG) + IF (IFLAG .LT. 0) GO TO 300 + 40 CONTINUE +C +C COMPUTE THE QR FACTORIZATION OF THE JACOBIAN. +C + CALL QRFAC(M,N,FJAC,LDFJAC,.TRUE.,IPVT,N,WA1,WA2,WA3) +C +C ON THE FIRST ITERATION AND IF MODE IS 1, SCALE ACCORDING +C TO THE NORMS OF THE COLUMNS OF THE INITIAL JACOBIAN. +C + IF (ITER .NE. 1) GO TO 80 + IF (MODE .EQ. 2) GO TO 60 + DO 50 J = 1, N + DIAG(J) = WA2(J) + IF (WA2(J) .EQ. ZERO) DIAG(J) = ONE + 50 CONTINUE + 60 CONTINUE +C +C ON THE FIRST ITERATION, CALCULATE THE NORM OF THE SCALED X +C AND INITIALIZE THE STEP BOUND DELTA. +C + DO 70 J = 1, N + WA3(J) = DIAG(J)*X(J) + 70 CONTINUE + XNORM = ENORM(N,WA3) + DELTA = FACTOR*XNORM + IF (DELTA .EQ. ZERO) DELTA = FACTOR + 80 CONTINUE +C +C FORM (Q TRANSPOSE)*FVEC AND STORE THE FIRST N COMPONENTS IN +C QTF. +C + DO 90 I = 1, M + WA4(I) = FVEC(I) + 90 CONTINUE + DO 130 J = 1, N + IF (FJAC(J,J) .EQ. ZERO) GO TO 120 + SUM = ZERO + DO 100 I = J, M + SUM = SUM + FJAC(I,J)*WA4(I) + 100 CONTINUE + TEMP = -SUM/FJAC(J,J) + DO 110 I = J, M + WA4(I) = WA4(I) + FJAC(I,J)*TEMP + 110 CONTINUE + 120 CONTINUE + FJAC(J,J) = WA1(J) + QTF(J) = WA4(J) + 130 CONTINUE +C +C COMPUTE THE NORM OF THE SCALED GRADIENT. +C + GNORM = ZERO + IF (FNORM .EQ. ZERO) GO TO 170 + DO 160 J = 1, N + L = IPVT(J) + IF (WA2(L) .EQ. ZERO) GO TO 150 + SUM = ZERO + DO 140 I = 1, J + SUM = SUM + FJAC(I,J)*(QTF(I)/FNORM) + 140 CONTINUE + GNORM = AMAX1(GNORM,ABS(SUM/WA2(L))) + 150 CONTINUE + 160 CONTINUE + 170 CONTINUE +C +C TEST FOR CONVERGENCE OF THE GRADIENT NORM. +C + IF (GNORM .LE. GTOL) INFO = 4 + IF (INFO .NE. 0) GO TO 300 +C +C RESCALE IF NECESSARY. +C + IF (MODE .EQ. 2) GO TO 190 + DO 180 J = 1, N + DIAG(J) = AMAX1(DIAG(J),WA2(J)) + 180 CONTINUE + 190 CONTINUE +C +C BEGINNING OF THE INNER LOOP. +C + 200 CONTINUE +C +C DETERMINE THE LEVENBERG-MARQUARDT PARAMETER. +C + CALL LMPAR(N,FJAC,LDFJAC,IPVT,DIAG,QTF,DELTA,PAR,WA1,WA2, + * WA3,WA4) +C +C STORE THE DIRECTION P AND X + P. CALCULATE THE NORM OF P. +C + DO 210 J = 1, N + WA1(J) = -WA1(J) + WA2(J) = X(J) + WA1(J) + WA3(J) = DIAG(J)*WA1(J) + 210 CONTINUE + PNORM = ENORM(N,WA3) +C +C ON THE FIRST ITERATION, ADJUST THE INITIAL STEP BOUND. +C + IF (ITER .EQ. 1) DELTA = AMIN1(DELTA,PNORM) +C +C EVALUATE THE FUNCTION AT X + P AND CALCULATE ITS NORM. +C + IFLAG = 1 + CALL FCN(M,N,WA2,WA4,FJAC,LDFJAC,IFLAG) + NFEV = NFEV + 1 + IF (IFLAG .LT. 0) GO TO 300 + FNORM1 = ENORM(M,WA4) +C +C COMPUTE THE SCALED ACTUAL REDUCTION. +C + ACTRED = -ONE + IF (P1*FNORM1 .LT. FNORM) ACTRED = ONE - (FNORM1/FNORM)**2 +C +C COMPUTE THE SCALED PREDICTED REDUCTION AND +C THE SCALED DIRECTIONAL DERIVATIVE. +C + DO 230 J = 1, N + WA3(J) = ZERO + L = IPVT(J) + TEMP = WA1(L) + DO 220 I = 1, J + WA3(I) = WA3(I) + FJAC(I,J)*TEMP + 220 CONTINUE + 230 CONTINUE + TEMP1 = ENORM(N,WA3)/FNORM + TEMP2 = (SQRT(PAR)*PNORM)/FNORM + PRERED = TEMP1**2 + TEMP2**2/P5 + DIRDER = -(TEMP1**2 + TEMP2**2) +C +C COMPUTE THE RATIO OF THE ACTUAL TO THE PREDICTED +C REDUCTION. +C + RATIO = ZERO + IF (PRERED .NE. ZERO) RATIO = ACTRED/PRERED +C +C UPDATE THE STEP BOUND. +C + IF (RATIO .GT. P25) GO TO 240 + IF (ACTRED .GE. ZERO) TEMP = P5 + IF (ACTRED .LT. ZERO) + * TEMP = P5*DIRDER/(DIRDER + P5*ACTRED) + IF (P1*FNORM1 .GE. FNORM .OR. TEMP .LT. P1) TEMP = P1 + DELTA = TEMP*AMIN1(DELTA,PNORM/P1) + PAR = PAR/TEMP + GO TO 260 + 240 CONTINUE + IF (PAR .NE. ZERO .AND. RATIO .LT. P75) GO TO 250 + DELTA = PNORM/P5 + PAR = P5*PAR + 250 CONTINUE + 260 CONTINUE +C +C TEST FOR SUCCESSFUL ITERATION. +C + IF (RATIO .LT. P0001) GO TO 290 +C +C SUCCESSFUL ITERATION. UPDATE X, FVEC, AND THEIR NORMS. +C + DO 270 J = 1, N + X(J) = WA2(J) + WA2(J) = DIAG(J)*X(J) + 270 CONTINUE + DO 280 I = 1, M + FVEC(I) = WA4(I) + 280 CONTINUE + XNORM = ENORM(N,WA2) + FNORM = FNORM1 + ITER = ITER + 1 + 290 CONTINUE +C +C TESTS FOR CONVERGENCE. +C + IF (ABS(ACTRED) .LE. FTOL .AND. PRERED .LE. FTOL + * .AND. P5*RATIO .LE. ONE) INFO = 1 + IF (DELTA .LE. XTOL*XNORM) INFO = 2 + IF (ABS(ACTRED) .LE. FTOL .AND. PRERED .LE. FTOL + * .AND. P5*RATIO .LE. ONE .AND. INFO .EQ. 2) INFO = 3 + IF (INFO .NE. 0) GO TO 300 +C +C TESTS FOR TERMINATION AND STRINGENT TOLERANCES. +C + IF (NFEV .GE. MAXFEV) INFO = 5 + IF (ABS(ACTRED) .LE. EPSMCH .AND. PRERED .LE. EPSMCH + * .AND. P5*RATIO .LE. ONE) INFO = 6 + IF (DELTA .LE. EPSMCH*XNORM) INFO = 7 + IF (GNORM .LE. EPSMCH) INFO = 8 + IF (INFO .NE. 0) GO TO 300 +C +C END OF THE INNER LOOP. REPEAT IF ITERATION UNSUCCESSFUL. +C + IF (RATIO .LT. P0001) GO TO 200 +C +C END OF THE OUTER LOOP. +C + GO TO 30 + 300 CONTINUE +C +C TERMINATION, EITHER NORMAL OR USER IMPOSED. +C + IF (IFLAG .LT. 0) INFO = IFLAG + IFLAG = 0 + IF (NPRINT .GT. 0) CALL FCN(M,N,X,FVEC,FJAC,LDFJAC,IFLAG) + RETURN +C +C LAST CARD OF SUBROUTINE LMDER. +C + END + SUBROUTINE LMDER1(FCN,M,N,X,FVEC,FJAC,LDFJAC,TOL,INFO,IPVT,WA, + * LWA) + INTEGER M,N,LDFJAC,INFO,LWA + INTEGER IPVT(N) + REAL TOL + REAL X(N),FVEC(M),FJAC(LDFJAC,N),WA(LWA) + EXTERNAL FCN +C ********** +C +C SUBROUTINE LMDER1 +C +C THE PURPOSE OF LMDER1 IS TO MINIMIZE THE SUM OF THE SQUARES OF +C M NONLINEAR FUNCTIONS IN N VARIABLES BY A MODIFICATION OF THE +C LEVENBERG-MARQUARDT ALGORITHM. THIS IS DONE BY USING THE MORE +C GENERAL LEAST-SQUARES SOLVER LMDER. THE USER MUST PROVIDE A +C SUBROUTINE WHICH CALCULATES THE FUNCTIONS AND THE JACOBIAN. +C +C THE SUBROUTINE STATEMENT IS +C +C SUBROUTINE LMDER1(FCN,M,N,X,FVEC,FJAC,LDFJAC,TOL,INFO, +C IPVT,WA,LWA) +C +C WHERE +C +C FCN IS THE NAME OF THE USER-SUPPLIED SUBROUTINE WHICH +C CALCULATES THE FUNCTIONS AND THE JACOBIAN. FCN MUST +C BE DECLARED IN AN EXTERNAL STATEMENT IN THE USER +C CALLING PROGRAM, AND SHOULD BE WRITTEN AS FOLLOWS. +C +C SUBROUTINE FCN(M,N,X,FVEC,FJAC,LDFJAC,IFLAG) +C INTEGER M,N,LDFJAC,IFLAG +C REAL X(N),FVEC(M),FJAC(LDFJAC,N) +C ---------- +C IF IFLAG = 1 CALCULATE THE FUNCTIONS AT X AND +C RETURN THIS VECTOR IN FVEC. DO NOT ALTER FJAC. +C IF IFLAG = 2 CALCULATE THE JACOBIAN AT X AND +C RETURN THIS MATRIX IN FJAC. DO NOT ALTER FVEC. +C ---------- +C RETURN +C END +C +C THE VALUE OF IFLAG SHOULD NOT BE CHANGED BY FCN UNLESS +C THE USER WANTS TO TERMINATE EXECUTION OF LMDER1. +C IN THIS CASE SET IFLAG TO A NEGATIVE INTEGER. +C +C M IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER +C OF FUNCTIONS. +C +C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER +C OF VARIABLES. N MUST NOT EXCEED M. +C +C X IS AN ARRAY OF LENGTH N. ON INPUT X MUST CONTAIN +C AN INITIAL ESTIMATE OF THE SOLUTION VECTOR. ON OUTPUT X +C CONTAINS THE FINAL ESTIMATE OF THE SOLUTION VECTOR. +C +C FVEC IS AN OUTPUT ARRAY OF LENGTH M WHICH CONTAINS +C THE FUNCTIONS EVALUATED AT THE OUTPUT X. +C +C FJAC IS AN OUTPUT M BY N ARRAY. THE UPPER N BY N SUBMATRIX +C OF FJAC CONTAINS AN UPPER TRIANGULAR MATRIX R WITH +C DIAGONAL ELEMENTS OF NONINCREASING MAGNITUDE SUCH THAT +C +C T T T +C P *(JAC *JAC)*P = R *R, +C +C WHERE P IS A PERMUTATION MATRIX AND JAC IS THE FINAL +C CALCULATED JACOBIAN. COLUMN J OF P IS COLUMN IPVT(J) +C (SEE BELOW) OF THE IDENTITY MATRIX. THE LOWER TRAPEZOIDAL +C PART OF FJAC CONTAINS INFORMATION GENERATED DURING +C THE COMPUTATION OF R. +C +C LDFJAC IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN M +C WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY FJAC. +C +C TOL IS A NONNEGATIVE INPUT VARIABLE. TERMINATION OCCURS +C WHEN THE ALGORITHM ESTIMATES EITHER THAT THE RELATIVE +C ERROR IN THE SUM OF SQUARES IS AT MOST TOL OR THAT +C THE RELATIVE ERROR BETWEEN X AND THE SOLUTION IS AT +C MOST TOL. +C +C INFO IS AN INTEGER OUTPUT VARIABLE. IF THE USER HAS +C TERMINATED EXECUTION, INFO IS SET TO THE (NEGATIVE) +C VALUE OF IFLAG. SEE DESCRIPTION OF FCN. OTHERWISE, +C INFO IS SET AS FOLLOWS. +C +C INFO = 0 IMPROPER INPUT PARAMETERS. +C +C INFO = 1 ALGORITHM ESTIMATES THAT THE RELATIVE ERROR +C IN THE SUM OF SQUARES IS AT MOST TOL. +C +C INFO = 2 ALGORITHM ESTIMATES THAT THE RELATIVE ERROR +C BETWEEN X AND THE SOLUTION IS AT MOST TOL. +C +C INFO = 3 CONDITIONS FOR INFO = 1 AND INFO = 2 BOTH HOLD. +C +C INFO = 4 FVEC IS ORTHOGONAL TO THE COLUMNS OF THE +C JACOBIAN TO MACHINE PRECISION. +C +C INFO = 5 NUMBER OF CALLS TO FCN WITH IFLAG = 1 HAS +C REACHED 100*(N+1). +C +C INFO = 6 TOL IS TOO SMALL. NO FURTHER REDUCTION IN +C THE SUM OF SQUARES IS POSSIBLE. +C +C INFO = 7 TOL IS TOO SMALL. NO FURTHER IMPROVEMENT IN +C THE APPROXIMATE SOLUTION X IS POSSIBLE. +C +C IPVT IS AN INTEGER OUTPUT ARRAY OF LENGTH N. IPVT +C DEFINES A PERMUTATION MATRIX P SUCH THAT JAC*P = Q*R, +C WHERE JAC IS THE FINAL CALCULATED JACOBIAN, Q IS +C ORTHOGONAL (NOT STORED), AND R IS UPPER TRIANGULAR +C WITH DIAGONAL ELEMENTS OF NONINCREASING MAGNITUDE. +C COLUMN J OF P IS COLUMN IPVT(J) OF THE IDENTITY MATRIX. +C +C WA IS A WORK ARRAY OF LENGTH LWA. +C +C LWA IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN 5*N+M. +C +C SUBPROGRAMS CALLED +C +C USER-SUPPLIED ...... FCN +C +C MINPACK-SUPPLIED ... LMDER +C +C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. +C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE +C +C ********** + INTEGER MAXFEV,MODE,NFEV,NJEV,NPRINT + REAL FACTOR,FTOL,GTOL,XTOL,ZERO + DATA FACTOR,ZERO /1.0E2,0.0E0/ + INFO = 0 +C +C CHECK THE INPUT PARAMETERS FOR ERRORS. +C + IF (N .LE. 0 .OR. M .LT. N .OR. LDFJAC .LT. M .OR. TOL .LT. ZERO + * .OR. LWA .LT. 5*N + M) GO TO 10 +C +C CALL LMDER. +C + MAXFEV = 100*(N + 1) + FTOL = TOL + XTOL = TOL + GTOL = ZERO + MODE = 1 + NPRINT = 0 + CALL LMDER(FCN,M,N,X,FVEC,FJAC,LDFJAC,FTOL,XTOL,GTOL,MAXFEV, + * WA(1),MODE,FACTOR,NPRINT,INFO,NFEV,NJEV,IPVT,WA(N+1), + * WA(2*N+1),WA(3*N+1),WA(4*N+1),WA(5*N+1)) + IF (INFO .EQ. 8) INFO = 4 + 10 CONTINUE + RETURN +C +C LAST CARD OF SUBROUTINE LMDER1. +C + END + SUBROUTINE LMDIF(FCN,M,N,X,FVEC,FTOL,XTOL,GTOL,MAXFEV,EPSFCN, + * DIAG,MODE,FACTOR,NPRINT,INFO,NFEV,FJAC,LDFJAC, + * IPVT,QTF,WA1,WA2,WA3,WA4) + INTEGER M,N,MAXFEV,MODE,NPRINT,INFO,NFEV,LDFJAC + INTEGER IPVT(N) + REAL FTOL,XTOL,GTOL,EPSFCN,FACTOR + REAL X(N),FVEC(M),DIAG(N),FJAC(LDFJAC,N),QTF(N),WA1(N),WA2(N), + * WA3(N),WA4(M) + EXTERNAL FCN +C ********** +C +C SUBROUTINE LMDIF +C +C THE PURPOSE OF LMDIF IS TO MINIMIZE THE SUM OF THE SQUARES OF +C M NONLINEAR FUNCTIONS IN N VARIABLES BY A MODIFICATION OF +C THE LEVENBERG-MARQUARDT ALGORITHM. THE USER MUST PROVIDE A +C SUBROUTINE WHICH CALCULATES THE FUNCTIONS. THE JACOBIAN IS +C THEN CALCULATED BY A FORWARD-DIFFERENCE APPROXIMATION. +C +C THE SUBROUTINE STATEMENT IS +C +C SUBROUTINE LMDIF(FCN,M,N,X,FVEC,FTOL,XTOL,GTOL,MAXFEV,EPSFCN, +C DIAG,MODE,FACTOR,NPRINT,INFO,NFEV,FJAC, +C LDFJAC,IPVT,QTF,WA1,WA2,WA3,WA4) +C +C WHERE +C +C FCN IS THE NAME OF THE USER-SUPPLIED SUBROUTINE WHICH +C CALCULATES THE FUNCTIONS. FCN MUST BE DECLARED +C IN AN EXTERNAL STATEMENT IN THE USER CALLING +C PROGRAM, AND SHOULD BE WRITTEN AS FOLLOWS. +C +C SUBROUTINE FCN(M,N,X,FVEC,IFLAG) +C INTEGER M,N,IFLAG +C REAL X(N),FVEC(M) +C ---------- +C CALCULATE THE FUNCTIONS AT X AND +C RETURN THIS VECTOR IN FVEC. +C ---------- +C RETURN +C END +C +C THE VALUE OF IFLAG SHOULD NOT BE CHANGED BY FCN UNLESS +C THE USER WANTS TO TERMINATE EXECUTION OF LMDIF. +C IN THIS CASE SET IFLAG TO A NEGATIVE INTEGER. +C +C M IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER +C OF FUNCTIONS. +C +C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER +C OF VARIABLES. N MUST NOT EXCEED M. +C +C X IS AN ARRAY OF LENGTH N. ON INPUT X MUST CONTAIN +C AN INITIAL ESTIMATE OF THE SOLUTION VECTOR. ON OUTPUT X +C CONTAINS THE FINAL ESTIMATE OF THE SOLUTION VECTOR. +C +C FVEC IS AN OUTPUT ARRAY OF LENGTH M WHICH CONTAINS +C THE FUNCTIONS EVALUATED AT THE OUTPUT X. +C +C FTOL IS A NONNEGATIVE INPUT VARIABLE. TERMINATION +C OCCURS WHEN BOTH THE ACTUAL AND PREDICTED RELATIVE +C REDUCTIONS IN THE SUM OF SQUARES ARE AT MOST FTOL. +C THEREFORE, FTOL MEASURES THE RELATIVE ERROR DESIRED +C IN THE SUM OF SQUARES. +C +C XTOL IS A NONNEGATIVE INPUT VARIABLE. TERMINATION +C OCCURS WHEN THE RELATIVE ERROR BETWEEN TWO CONSECUTIVE +C ITERATES IS AT MOST XTOL. THEREFORE, XTOL MEASURES THE +C RELATIVE ERROR DESIRED IN THE APPROXIMATE SOLUTION. +C +C GTOL IS A NONNEGATIVE INPUT VARIABLE. TERMINATION +C OCCURS WHEN THE COSINE OF THE ANGLE BETWEEN FVEC AND +C ANY COLUMN OF THE JACOBIAN IS AT MOST GTOL IN ABSOLUTE +C VALUE. THEREFORE, GTOL MEASURES THE ORTHOGONALITY +C DESIRED BETWEEN THE FUNCTION VECTOR AND THE COLUMNS +C OF THE JACOBIAN. +C +C MAXFEV IS A POSITIVE INTEGER INPUT VARIABLE. TERMINATION +C OCCURS WHEN THE NUMBER OF CALLS TO FCN IS AT LEAST +C MAXFEV BY THE END OF AN ITERATION. +C +C EPSFCN IS AN INPUT VARIABLE USED IN DETERMINING A SUITABLE +C STEP LENGTH FOR THE FORWARD-DIFFERENCE APPROXIMATION. THIS +C APPROXIMATION ASSUMES THAT THE RELATIVE ERRORS IN THE +C FUNCTIONS ARE OF THE ORDER OF EPSFCN. IF EPSFCN IS LESS +C THAN THE MACHINE PRECISION, IT IS ASSUMED THAT THE RELATIVE +C ERRORS IN THE FUNCTIONS ARE OF THE ORDER OF THE MACHINE +C PRECISION. +C +C DIAG IS AN ARRAY OF LENGTH N. IF MODE = 1 (SEE +C BELOW), DIAG IS INTERNALLY SET. IF MODE = 2, DIAG +C MUST CONTAIN POSITIVE ENTRIES THAT SERVE AS +C MULTIPLICATIVE SCALE FACTORS FOR THE VARIABLES. +C +C MODE IS AN INTEGER INPUT VARIABLE. IF MODE = 1, THE +C VARIABLES WILL BE SCALED INTERNALLY. IF MODE = 2, +C THE SCALING IS SPECIFIED BY THE INPUT DIAG. OTHER +C VALUES OF MODE ARE EQUIVALENT TO MODE = 1. +C +C FACTOR IS A POSITIVE INPUT VARIABLE USED IN DETERMINING THE +C INITIAL STEP BOUND. THIS BOUND IS SET TO THE PRODUCT OF +C FACTOR AND THE EUCLIDEAN NORM OF DIAG*X IF NONZERO, OR ELSE +C TO FACTOR ITSELF. IN MOST CASES FACTOR SHOULD LIE IN THE +C INTERVAL (.1,100.). 100. IS A GENERALLY RECOMMENDED VALUE. +C +C NPRINT IS AN INTEGER INPUT VARIABLE THAT ENABLES CONTROLLED +C PRINTING OF ITERATES IF IT IS POSITIVE. IN THIS CASE, +C FCN IS CALLED WITH IFLAG = 0 AT THE BEGINNING OF THE FIRST +C ITERATION AND EVERY NPRINT ITERATIONS THEREAFTER AND +C IMMEDIATELY PRIOR TO RETURN, WITH X AND FVEC AVAILABLE +C FOR PRINTING. IF NPRINT IS NOT POSITIVE, NO SPECIAL CALLS +C OF FCN WITH IFLAG = 0 ARE MADE. +C +C INFO IS AN INTEGER OUTPUT VARIABLE. IF THE USER HAS +C TERMINATED EXECUTION, INFO IS SET TO THE (NEGATIVE) +C VALUE OF IFLAG. SEE DESCRIPTION OF FCN. OTHERWISE, +C INFO IS SET AS FOLLOWS. +C +C INFO = 0 IMPROPER INPUT PARAMETERS. +C +C INFO = 1 BOTH ACTUAL AND PREDICTED RELATIVE REDUCTIONS +C IN THE SUM OF SQUARES ARE AT MOST FTOL. +C +C INFO = 2 RELATIVE ERROR BETWEEN TWO CONSECUTIVE ITERATES +C IS AT MOST XTOL. +C +C INFO = 3 CONDITIONS FOR INFO = 1 AND INFO = 2 BOTH HOLD. +C +C INFO = 4 THE COSINE OF THE ANGLE BETWEEN FVEC AND ANY +C COLUMN OF THE JACOBIAN IS AT MOST GTOL IN +C ABSOLUTE VALUE. +C +C INFO = 5 NUMBER OF CALLS TO FCN HAS REACHED OR +C EXCEEDED MAXFEV. +C +C INFO = 6 FTOL IS TOO SMALL. NO FURTHER REDUCTION IN +C THE SUM OF SQUARES IS POSSIBLE. +C +C INFO = 7 XTOL IS TOO SMALL. NO FURTHER IMPROVEMENT IN +C THE APPROXIMATE SOLUTION X IS POSSIBLE. +C +C INFO = 8 GTOL IS TOO SMALL. FVEC IS ORTHOGONAL TO THE +C COLUMNS OF THE JACOBIAN TO MACHINE PRECISION. +C +C NFEV IS AN INTEGER OUTPUT VARIABLE SET TO THE NUMBER OF +C CALLS TO FCN. +C +C FJAC IS AN OUTPUT M BY N ARRAY. THE UPPER N BY N SUBMATRIX +C OF FJAC CONTAINS AN UPPER TRIANGULAR MATRIX R WITH +C DIAGONAL ELEMENTS OF NONINCREASING MAGNITUDE SUCH THAT +C +C T T T +C P *(JAC *JAC)*P = R *R, +C +C WHERE P IS A PERMUTATION MATRIX AND JAC IS THE FINAL +C CALCULATED JACOBIAN. COLUMN J OF P IS COLUMN IPVT(J) +C (SEE BELOW) OF THE IDENTITY MATRIX. THE LOWER TRAPEZOIDAL +C PART OF FJAC CONTAINS INFORMATION GENERATED DURING +C THE COMPUTATION OF R. +C +C LDFJAC IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN M +C WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY FJAC. +C +C IPVT IS AN INTEGER OUTPUT ARRAY OF LENGTH N. IPVT +C DEFINES A PERMUTATION MATRIX P SUCH THAT JAC*P = Q*R, +C WHERE JAC IS THE FINAL CALCULATED JACOBIAN, Q IS +C ORTHOGONAL (NOT STORED), AND R IS UPPER TRIANGULAR +C WITH DIAGONAL ELEMENTS OF NONINCREASING MAGNITUDE. +C COLUMN J OF P IS COLUMN IPVT(J) OF THE IDENTITY MATRIX. +C +C QTF IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS +C THE FIRST N ELEMENTS OF THE VECTOR (Q TRANSPOSE)*FVEC. +C +C WA1, WA2, AND WA3 ARE WORK ARRAYS OF LENGTH N. +C +C WA4 IS A WORK ARRAY OF LENGTH M. +C +C SUBPROGRAMS CALLED +C +C USER-SUPPLIED ...... FCN +C +C MINPACK-SUPPLIED ... SPMPAR,ENORM,FDJAC2,LMPAR,QRFAC +C +C FORTRAN-SUPPLIED ... ABS,AMAX1,AMIN1,SQRT,MOD +C +C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. +C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE +C +C ********** + INTEGER I,IFLAG,ITER,J,L + REAL ACTRED,DELTA,DIRDER,EPSMCH,FNORM,FNORM1,GNORM,ONE,PAR, + * PNORM,PRERED,P1,P5,P25,P75,P0001,RATIO,SUM,TEMP,TEMP1, + * TEMP2,XNORM,ZERO + REAL SPMPAR,ENORM + DATA ONE,P1,P5,P25,P75,P0001,ZERO + * /1.0E0,1.0E-1,5.0E-1,2.5E-1,7.5E-1,1.0E-4,0.0E0/ +C +C EPSMCH IS THE MACHINE PRECISION. +C + EPSMCH = SPMPAR(1) +C + INFO = 0 + IFLAG = 0 + NFEV = 0 +C +C CHECK THE INPUT PARAMETERS FOR ERRORS. +C + IF (N .LE. 0 .OR. M .LT. N .OR. LDFJAC .LT. M + * .OR. FTOL .LT. ZERO .OR. XTOL .LT. ZERO .OR. GTOL .LT. ZERO + * .OR. MAXFEV .LE. 0 .OR. FACTOR .LE. ZERO) GO TO 300 + IF (MODE .NE. 2) GO TO 20 + DO 10 J = 1, N + IF (DIAG(J) .LE. ZERO) GO TO 300 + 10 CONTINUE + 20 CONTINUE +C +C EVALUATE THE FUNCTION AT THE STARTING POINT +C AND CALCULATE ITS NORM. +C + IFLAG = 1 + CALL FCN(M,N,X,FVEC,IFLAG) + NFEV = 1 + IF (IFLAG .LT. 0) GO TO 300 + FNORM = ENORM(M,FVEC) +C +C INITIALIZE LEVENBERG-MARQUARDT PARAMETER AND ITERATION COUNTER. +C + PAR = ZERO + ITER = 1 +C +C BEGINNING OF THE OUTER LOOP. +C + 30 CONTINUE +C +C CALCULATE THE JACOBIAN MATRIX. +C + IFLAG = 2 + CALL FDJAC2(FCN,M,N,X,FVEC,FJAC,LDFJAC,IFLAG,EPSFCN,WA4) + NFEV = NFEV + N + IF (IFLAG .LT. 0) GO TO 300 +C +C IF REQUESTED, CALL FCN TO ENABLE PRINTING OF ITERATES. +C + IF (NPRINT .LE. 0) GO TO 40 + IFLAG = 0 + IF (MOD(ITER-1,NPRINT) .EQ. 0) CALL FCN(M,N,X,FVEC,IFLAG) + IF (IFLAG .LT. 0) GO TO 300 + 40 CONTINUE +C +C COMPUTE THE QR FACTORIZATION OF THE JACOBIAN. +C + CALL QRFAC(M,N,FJAC,LDFJAC,.TRUE.,IPVT,N,WA1,WA2,WA3) +C +C ON THE FIRST ITERATION AND IF MODE IS 1, SCALE ACCORDING +C TO THE NORMS OF THE COLUMNS OF THE INITIAL JACOBIAN. +C + IF (ITER .NE. 1) GO TO 80 + IF (MODE .EQ. 2) GO TO 60 + DO 50 J = 1, N + DIAG(J) = WA2(J) + IF (WA2(J) .EQ. ZERO) DIAG(J) = ONE + 50 CONTINUE + 60 CONTINUE +C +C ON THE FIRST ITERATION, CALCULATE THE NORM OF THE SCALED X +C AND INITIALIZE THE STEP BOUND DELTA. +C + DO 70 J = 1, N + WA3(J) = DIAG(J)*X(J) + 70 CONTINUE + XNORM = ENORM(N,WA3) + DELTA = FACTOR*XNORM + IF (DELTA .EQ. ZERO) DELTA = FACTOR + 80 CONTINUE +C +C FORM (Q TRANSPOSE)*FVEC AND STORE THE FIRST N COMPONENTS IN +C QTF. +C + DO 90 I = 1, M + WA4(I) = FVEC(I) + 90 CONTINUE + DO 130 J = 1, N + IF (FJAC(J,J) .EQ. ZERO) GO TO 120 + SUM = ZERO + DO 100 I = J, M + SUM = SUM + FJAC(I,J)*WA4(I) + 100 CONTINUE + TEMP = -SUM/FJAC(J,J) + DO 110 I = J, M + WA4(I) = WA4(I) + FJAC(I,J)*TEMP + 110 CONTINUE + 120 CONTINUE + FJAC(J,J) = WA1(J) + QTF(J) = WA4(J) + 130 CONTINUE +C +C COMPUTE THE NORM OF THE SCALED GRADIENT. +C + GNORM = ZERO + IF (FNORM .EQ. ZERO) GO TO 170 + DO 160 J = 1, N + L = IPVT(J) + IF (WA2(L) .EQ. ZERO) GO TO 150 + SUM = ZERO + DO 140 I = 1, J + SUM = SUM + FJAC(I,J)*(QTF(I)/FNORM) + 140 CONTINUE + GNORM = AMAX1(GNORM,ABS(SUM/WA2(L))) + 150 CONTINUE + 160 CONTINUE + 170 CONTINUE +C +C TEST FOR CONVERGENCE OF THE GRADIENT NORM. +C + IF (GNORM .LE. GTOL) INFO = 4 + IF (INFO .NE. 0) GO TO 300 +C +C RESCALE IF NECESSARY. +C + IF (MODE .EQ. 2) GO TO 190 + DO 180 J = 1, N + DIAG(J) = AMAX1(DIAG(J),WA2(J)) + 180 CONTINUE + 190 CONTINUE +C +C BEGINNING OF THE INNER LOOP. +C + 200 CONTINUE +C +C DETERMINE THE LEVENBERG-MARQUARDT PARAMETER. +C + CALL LMPAR(N,FJAC,LDFJAC,IPVT,DIAG,QTF,DELTA,PAR,WA1,WA2, + * WA3,WA4) +C +C STORE THE DIRECTION P AND X + P. CALCULATE THE NORM OF P. +C + DO 210 J = 1, N + WA1(J) = -WA1(J) + WA2(J) = X(J) + WA1(J) + WA3(J) = DIAG(J)*WA1(J) + 210 CONTINUE + PNORM = ENORM(N,WA3) +C +C ON THE FIRST ITERATION, ADJUST THE INITIAL STEP BOUND. +C + IF (ITER .EQ. 1) DELTA = AMIN1(DELTA,PNORM) +C +C EVALUATE THE FUNCTION AT X + P AND CALCULATE ITS NORM. +C + IFLAG = 1 + CALL FCN(M,N,WA2,WA4,IFLAG) + NFEV = NFEV + 1 + IF (IFLAG .LT. 0) GO TO 300 + FNORM1 = ENORM(M,WA4) +C +C COMPUTE THE SCALED ACTUAL REDUCTION. +C + ACTRED = -ONE + IF (P1*FNORM1 .LT. FNORM) ACTRED = ONE - (FNORM1/FNORM)**2 +C +C COMPUTE THE SCALED PREDICTED REDUCTION AND +C THE SCALED DIRECTIONAL DERIVATIVE. +C + DO 230 J = 1, N + WA3(J) = ZERO + L = IPVT(J) + TEMP = WA1(L) + DO 220 I = 1, J + WA3(I) = WA3(I) + FJAC(I,J)*TEMP + 220 CONTINUE + 230 CONTINUE + TEMP1 = ENORM(N,WA3)/FNORM + TEMP2 = (SQRT(PAR)*PNORM)/FNORM + PRERED = TEMP1**2 + TEMP2**2/P5 + DIRDER = -(TEMP1**2 + TEMP2**2) +C +C COMPUTE THE RATIO OF THE ACTUAL TO THE PREDICTED +C REDUCTION. +C + RATIO = ZERO + IF (PRERED .NE. ZERO) RATIO = ACTRED/PRERED +C +C UPDATE THE STEP BOUND. +C + IF (RATIO .GT. P25) GO TO 240 + IF (ACTRED .GE. ZERO) TEMP = P5 + IF (ACTRED .LT. ZERO) + * TEMP = P5*DIRDER/(DIRDER + P5*ACTRED) + IF (P1*FNORM1 .GE. FNORM .OR. TEMP .LT. P1) TEMP = P1 + DELTA = TEMP*AMIN1(DELTA,PNORM/P1) + PAR = PAR/TEMP + GO TO 260 + 240 CONTINUE + IF (PAR .NE. ZERO .AND. RATIO .LT. P75) GO TO 250 + DELTA = PNORM/P5 + PAR = P5*PAR + 250 CONTINUE + 260 CONTINUE +C +C TEST FOR SUCCESSFUL ITERATION. +C + IF (RATIO .LT. P0001) GO TO 290 +C +C SUCCESSFUL ITERATION. UPDATE X, FVEC, AND THEIR NORMS. +C + DO 270 J = 1, N + X(J) = WA2(J) + WA2(J) = DIAG(J)*X(J) + 270 CONTINUE + DO 280 I = 1, M + FVEC(I) = WA4(I) + 280 CONTINUE + XNORM = ENORM(N,WA2) + FNORM = FNORM1 + ITER = ITER + 1 + 290 CONTINUE +C +C TESTS FOR CONVERGENCE. +C + IF (ABS(ACTRED) .LE. FTOL .AND. PRERED .LE. FTOL + * .AND. P5*RATIO .LE. ONE) INFO = 1 + IF (DELTA .LE. XTOL*XNORM) INFO = 2 + IF (ABS(ACTRED) .LE. FTOL .AND. PRERED .LE. FTOL + * .AND. P5*RATIO .LE. ONE .AND. INFO .EQ. 2) INFO = 3 + IF (INFO .NE. 0) GO TO 300 +C +C TESTS FOR TERMINATION AND STRINGENT TOLERANCES. +C + IF (NFEV .GE. MAXFEV) INFO = 5 + IF (ABS(ACTRED) .LE. EPSMCH .AND. PRERED .LE. EPSMCH + * .AND. P5*RATIO .LE. ONE) INFO = 6 + IF (DELTA .LE. EPSMCH*XNORM) INFO = 7 + IF (GNORM .LE. EPSMCH) INFO = 8 + IF (INFO .NE. 0) GO TO 300 +C +C END OF THE INNER LOOP. REPEAT IF ITERATION UNSUCCESSFUL. +C + IF (RATIO .LT. P0001) GO TO 200 +C +C END OF THE OUTER LOOP. +C + GO TO 30 + 300 CONTINUE +C +C TERMINATION, EITHER NORMAL OR USER IMPOSED. +C + IF (IFLAG .LT. 0) INFO = IFLAG + IFLAG = 0 + IF (NPRINT .GT. 0) CALL FCN(M,N,X,FVEC,IFLAG) + RETURN +C +C LAST CARD OF SUBROUTINE LMDIF. +C + END + SUBROUTINE LMDIF1(FCN,M,N,X,FVEC,TOL,INFO,IWA,WA,LWA) + INTEGER M,N,INFO,LWA + INTEGER IWA(N) + REAL TOL + REAL X(N),FVEC(M),WA(LWA) + EXTERNAL FCN +C ********** +C +C SUBROUTINE LMDIF1 +C +C THE PURPOSE OF LMDIF1 IS TO MINIMIZE THE SUM OF THE SQUARES OF +C M NONLINEAR FUNCTIONS IN N VARIABLES BY A MODIFICATION OF THE +C LEVENBERG-MARQUARDT ALGORITHM. THIS IS DONE BY USING THE MORE +C GENERAL LEAST-SQUARES SOLVER LMDIF. THE USER MUST PROVIDE A +C SUBROUTINE WHICH CALCULATES THE FUNCTIONS. THE JACOBIAN IS +C THEN CALCULATED BY A FORWARD-DIFFERENCE APPROXIMATION. +C +C THE SUBROUTINE STATEMENT IS +C +C SUBROUTINE LMDIF1(FCN,M,N,X,FVEC,TOL,INFO,IWA,WA,LWA) +C +C WHERE +C +C FCN IS THE NAME OF THE USER-SUPPLIED SUBROUTINE WHICH +C CALCULATES THE FUNCTIONS. FCN MUST BE DECLARED +C IN AN EXTERNAL STATEMENT IN THE USER CALLING +C PROGRAM, AND SHOULD BE WRITTEN AS FOLLOWS. +C +C SUBROUTINE FCN(M,N,X,FVEC,IFLAG) +C INTEGER M,N,IFLAG +C REAL X(N),FVEC(M) +C ---------- +C CALCULATE THE FUNCTIONS AT X AND +C RETURN THIS VECTOR IN FVEC. +C ---------- +C RETURN +C END +C +C THE VALUE OF IFLAG SHOULD NOT BE CHANGED BY FCN UNLESS +C THE USER WANTS TO TERMINATE EXECUTION OF LMDIF1. +C IN THIS CASE SET IFLAG TO A NEGATIVE INTEGER. +C +C M IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER +C OF FUNCTIONS. +C +C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER +C OF VARIABLES. N MUST NOT EXCEED M. +C +C X IS AN ARRAY OF LENGTH N. ON INPUT X MUST CONTAIN +C AN INITIAL ESTIMATE OF THE SOLUTION VECTOR. ON OUTPUT X +C CONTAINS THE FINAL ESTIMATE OF THE SOLUTION VECTOR. +C +C FVEC IS AN OUTPUT ARRAY OF LENGTH M WHICH CONTAINS +C THE FUNCTIONS EVALUATED AT THE OUTPUT X. +C +C TOL IS A NONNEGATIVE INPUT VARIABLE. TERMINATION OCCURS +C WHEN THE ALGORITHM ESTIMATES EITHER THAT THE RELATIVE +C ERROR IN THE SUM OF SQUARES IS AT MOST TOL OR THAT +C THE RELATIVE ERROR BETWEEN X AND THE SOLUTION IS AT +C MOST TOL. +C +C INFO IS AN INTEGER OUTPUT VARIABLE. IF THE USER HAS +C TERMINATED EXECUTION, INFO IS SET TO THE (NEGATIVE) +C VALUE OF IFLAG. SEE DESCRIPTION OF FCN. OTHERWISE, +C INFO IS SET AS FOLLOWS. +C +C INFO = 0 IMPROPER INPUT PARAMETERS. +C +C INFO = 1 ALGORITHM ESTIMATES THAT THE RELATIVE ERROR +C IN THE SUM OF SQUARES IS AT MOST TOL. +C +C INFO = 2 ALGORITHM ESTIMATES THAT THE RELATIVE ERROR +C BETWEEN X AND THE SOLUTION IS AT MOST TOL. +C +C INFO = 3 CONDITIONS FOR INFO = 1 AND INFO = 2 BOTH HOLD. +C +C INFO = 4 FVEC IS ORTHOGONAL TO THE COLUMNS OF THE +C JACOBIAN TO MACHINE PRECISION. +C +C INFO = 5 NUMBER OF CALLS TO FCN HAS REACHED OR +C EXCEEDED 200*(N+1). +C +C INFO = 6 TOL IS TOO SMALL. NO FURTHER REDUCTION IN +C THE SUM OF SQUARES IS POSSIBLE. +C +C INFO = 7 TOL IS TOO SMALL. NO FURTHER IMPROVEMENT IN +C THE APPROXIMATE SOLUTION X IS POSSIBLE. +C +C IWA IS AN INTEGER WORK ARRAY OF LENGTH N. +C +C WA IS A WORK ARRAY OF LENGTH LWA. +C +C LWA IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN +C M*N+5*N+M. +C +C SUBPROGRAMS CALLED +C +C USER-SUPPLIED ...... FCN +C +C MINPACK-SUPPLIED ... LMDIF +C +C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. +C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE +C +C ********** + INTEGER MAXFEV,MODE,MP5N,NFEV,NPRINT + REAL EPSFCN,FACTOR,FTOL,GTOL,XTOL,ZERO + DATA FACTOR,ZERO /1.0E2,0.0E0/ + INFO = 0 +C +C CHECK THE INPUT PARAMETERS FOR ERRORS. +C + IF (N .LE. 0 .OR. M .LT. N .OR. TOL .LT. ZERO + * .OR. LWA .LT. M*N + 5*N + M) GO TO 10 +C +C CALL LMDIF. +C + MAXFEV = 200*(N + 1) + FTOL = TOL + XTOL = TOL + GTOL = ZERO + EPSFCN = ZERO + MODE = 1 + NPRINT = 0 + MP5N = M + 5*N + CALL LMDIF(FCN,M,N,X,FVEC,FTOL,XTOL,GTOL,MAXFEV,EPSFCN,WA(1), + * MODE,FACTOR,NPRINT,INFO,NFEV,WA(MP5N+1),M,IWA, + * WA(N+1),WA(2*N+1),WA(3*N+1),WA(4*N+1),WA(5*N+1)) + IF (INFO .EQ. 8) INFO = 4 + 10 CONTINUE + RETURN +C +C LAST CARD OF SUBROUTINE LMDIF1. +C + END + SUBROUTINE LMPAR(N,R,LDR,IPVT,DIAG,QTB,DELTA,PAR,X,SDIAG,WA1, + * WA2) + INTEGER N,LDR + INTEGER IPVT(N) + REAL DELTA,PAR + REAL R(LDR,N),DIAG(N),QTB(N),X(N),SDIAG(N),WA1(N),WA2(N) +C ********** +C +C SUBROUTINE LMPAR +C +C GIVEN AN M BY N MATRIX A, AN N BY N NONSINGULAR DIAGONAL +C MATRIX D, AN M-VECTOR B, AND A POSITIVE NUMBER DELTA, +C THE PROBLEM IS TO DETERMINE A VALUE FOR THE PARAMETER +C PAR SUCH THAT IF X SOLVES THE SYSTEM +C +C A*X = B , SQRT(PAR)*D*X = 0 , +C +C IN THE LEAST SQUARES SENSE, AND DXNORM IS THE EUCLIDEAN +C NORM OF D*X, THEN EITHER PAR IS ZERO AND +C +C (DXNORM-DELTA) .LE. 0.1*DELTA , +C +C OR PAR IS POSITIVE AND +C +C ABS(DXNORM-DELTA) .LE. 0.1*DELTA . +C +C THIS SUBROUTINE COMPLETES THE SOLUTION OF THE PROBLEM +C IF IT IS PROVIDED WITH THE NECESSARY INFORMATION FROM THE +C QR FACTORIZATION, WITH COLUMN PIVOTING, OF A. THAT IS, IF +C A*P = Q*R, WHERE P IS A PERMUTATION MATRIX, Q HAS ORTHOGONAL +C COLUMNS, AND R IS AN UPPER TRIANGULAR MATRIX WITH DIAGONAL +C ELEMENTS OF NONINCREASING MAGNITUDE, THEN LMPAR EXPECTS +C THE FULL UPPER TRIANGLE OF R, THE PERMUTATION MATRIX P, +C AND THE FIRST N COMPONENTS OF (Q TRANSPOSE)*B. ON OUTPUT +C LMPAR ALSO PROVIDES AN UPPER TRIANGULAR MATRIX S SUCH THAT +C +C T T T +C P *(A *A + PAR*D*D)*P = S *S . +C +C S IS EMPLOYED WITHIN LMPAR AND MAY BE OF SEPARATE INTEREST. +C +C ONLY A FEW ITERATIONS ARE GENERALLY NEEDED FOR CONVERGENCE +C OF THE ALGORITHM. IF, HOWEVER, THE LIMIT OF 10 ITERATIONS +C IS REACHED, THEN THE OUTPUT PAR WILL CONTAIN THE BEST +C VALUE OBTAINED SO FAR. +C +C THE SUBROUTINE STATEMENT IS +C +C SUBROUTINE LMPAR(N,R,LDR,IPVT,DIAG,QTB,DELTA,PAR,X,SDIAG, +C WA1,WA2) +C +C WHERE +C +C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE ORDER OF R. +C +C R IS AN N BY N ARRAY. ON INPUT THE FULL UPPER TRIANGLE +C MUST CONTAIN THE FULL UPPER TRIANGLE OF THE MATRIX R. +C ON OUTPUT THE FULL UPPER TRIANGLE IS UNALTERED, AND THE +C STRICT LOWER TRIANGLE CONTAINS THE STRICT UPPER TRIANGLE +C (TRANSPOSED) OF THE UPPER TRIANGULAR MATRIX S. +C +C LDR IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN N +C WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY R. +C +C IPVT IS AN INTEGER INPUT ARRAY OF LENGTH N WHICH DEFINES THE +C PERMUTATION MATRIX P SUCH THAT A*P = Q*R. COLUMN J OF P +C IS COLUMN IPVT(J) OF THE IDENTITY MATRIX. +C +C DIAG IS AN INPUT ARRAY OF LENGTH N WHICH MUST CONTAIN THE +C DIAGONAL ELEMENTS OF THE MATRIX D. +C +C QTB IS AN INPUT ARRAY OF LENGTH N WHICH MUST CONTAIN THE FIRST +C N ELEMENTS OF THE VECTOR (Q TRANSPOSE)*B. +C +C DELTA IS A POSITIVE INPUT VARIABLE WHICH SPECIFIES AN UPPER +C BOUND ON THE EUCLIDEAN NORM OF D*X. +C +C PAR IS A NONNEGATIVE VARIABLE. ON INPUT PAR CONTAINS AN +C INITIAL ESTIMATE OF THE LEVENBERG-MARQUARDT PARAMETER. +C ON OUTPUT PAR CONTAINS THE FINAL ESTIMATE. +C +C X IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE LEAST +C SQUARES SOLUTION OF THE SYSTEM A*X = B, SQRT(PAR)*D*X = 0, +C FOR THE OUTPUT PAR. +C +C SDIAG IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE +C DIAGONAL ELEMENTS OF THE UPPER TRIANGULAR MATRIX S. +C +C WA1 AND WA2 ARE WORK ARRAYS OF LENGTH N. +C +C SUBPROGRAMS CALLED +C +C MINPACK-SUPPLIED ... SPMPAR,ENORM,QRSOLV +C +C FORTRAN-SUPPLIED ... ABS,AMAX1,AMIN1,SQRT +C +C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. +C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE +C +C ********** + INTEGER I,ITER,J,JM1,JP1,K,L,NSING + REAL DXNORM,DWARF,FP,GNORM,PARC,PARL,PARU,P1,P001,SUM,TEMP,ZERO + REAL SPMPAR,ENORM + DATA P1,P001,ZERO /1.0E-1,1.0E-3,0.0E0/ +C +C DWARF IS THE SMALLEST POSITIVE MAGNITUDE. +C + DWARF = SPMPAR(2) +C +C COMPUTE AND STORE IN X THE GAUSS-NEWTON DIRECTION. IF THE +C JACOBIAN IS RANK-DEFICIENT, OBTAIN A LEAST SQUARES SOLUTION. +C + NSING = N + DO 10 J = 1, N + WA1(J) = QTB(J) + IF (R(J,J) .EQ. ZERO .AND. NSING .EQ. N) NSING = J - 1 + IF (NSING .LT. N) WA1(J) = ZERO + 10 CONTINUE + IF (NSING .LT. 1) GO TO 50 + DO 40 K = 1, NSING + J = NSING - K + 1 + WA1(J) = WA1(J)/R(J,J) + TEMP = WA1(J) + JM1 = J - 1 + IF (JM1 .LT. 1) GO TO 30 + DO 20 I = 1, JM1 + WA1(I) = WA1(I) - R(I,J)*TEMP + 20 CONTINUE + 30 CONTINUE + 40 CONTINUE + 50 CONTINUE + DO 60 J = 1, N + L = IPVT(J) + X(L) = WA1(J) + 60 CONTINUE +C +C INITIALIZE THE ITERATION COUNTER. +C EVALUATE THE FUNCTION AT THE ORIGIN, AND TEST +C FOR ACCEPTANCE OF THE GAUSS-NEWTON DIRECTION. +C + ITER = 0 + DO 70 J = 1, N + WA2(J) = DIAG(J)*X(J) + 70 CONTINUE + DXNORM = ENORM(N,WA2) + FP = DXNORM - DELTA + IF (FP .LE. P1*DELTA) GO TO 220 +C +C IF THE JACOBIAN IS NOT RANK DEFICIENT, THE NEWTON +C STEP PROVIDES A LOWER BOUND, PARL, FOR THE ZERO OF +C THE FUNCTION. OTHERWISE SET THIS BOUND TO ZERO. +C + PARL = ZERO + IF (NSING .LT. N) GO TO 120 + DO 80 J = 1, N + L = IPVT(J) + WA1(J) = DIAG(L)*(WA2(L)/DXNORM) + 80 CONTINUE + DO 110 J = 1, N + SUM = ZERO + JM1 = J - 1 + IF (JM1 .LT. 1) GO TO 100 + DO 90 I = 1, JM1 + SUM = SUM + R(I,J)*WA1(I) + 90 CONTINUE + 100 CONTINUE + WA1(J) = (WA1(J) - SUM)/R(J,J) + 110 CONTINUE + TEMP = ENORM(N,WA1) + PARL = ((FP/DELTA)/TEMP)/TEMP + 120 CONTINUE +C +C CALCULATE AN UPPER BOUND, PARU, FOR THE ZERO OF THE FUNCTION. +C + DO 140 J = 1, N + SUM = ZERO + DO 130 I = 1, J + SUM = SUM + R(I,J)*QTB(I) + 130 CONTINUE + L = IPVT(J) + WA1(J) = SUM/DIAG(L) + 140 CONTINUE + GNORM = ENORM(N,WA1) + PARU = GNORM/DELTA + IF (PARU .EQ. ZERO) PARU = DWARF/AMIN1(DELTA,P1) +C +C IF THE INPUT PAR LIES OUTSIDE OF THE INTERVAL (PARL,PARU), +C SET PAR TO THE CLOSER ENDPOINT. +C + PAR = AMAX1(PAR,PARL) + PAR = AMIN1(PAR,PARU) + IF (PAR .EQ. ZERO) PAR = GNORM/DXNORM +C +C BEGINNING OF AN ITERATION. +C + 150 CONTINUE + ITER = ITER + 1 +C +C EVALUATE THE FUNCTION AT THE CURRENT VALUE OF PAR. +C + IF (PAR .EQ. ZERO) PAR = AMAX1(DWARF,P001*PARU) + TEMP = SQRT(PAR) + DO 160 J = 1, N + WA1(J) = TEMP*DIAG(J) + 160 CONTINUE + CALL QRSOLV(N,R,LDR,IPVT,WA1,QTB,X,SDIAG,WA2) + DO 170 J = 1, N + WA2(J) = DIAG(J)*X(J) + 170 CONTINUE + DXNORM = ENORM(N,WA2) + TEMP = FP + FP = DXNORM - DELTA +C +C IF THE FUNCTION IS SMALL ENOUGH, ACCEPT THE CURRENT VALUE +C OF PAR. ALSO TEST FOR THE EXCEPTIONAL CASES WHERE PARL +C IS ZERO OR THE NUMBER OF ITERATIONS HAS REACHED 10. +C + IF (ABS(FP) .LE. P1*DELTA + * .OR. PARL .EQ. ZERO .AND. FP .LE. TEMP + * .AND. TEMP .LT. ZERO .OR. ITER .EQ. 10) GO TO 220 +C +C COMPUTE THE NEWTON CORRECTION. +C + DO 180 J = 1, N + L = IPVT(J) + WA1(J) = DIAG(L)*(WA2(L)/DXNORM) + 180 CONTINUE + DO 210 J = 1, N + WA1(J) = WA1(J)/SDIAG(J) + TEMP = WA1(J) + JP1 = J + 1 + IF (N .LT. JP1) GO TO 200 + DO 190 I = JP1, N + WA1(I) = WA1(I) - R(I,J)*TEMP + 190 CONTINUE + 200 CONTINUE + 210 CONTINUE + TEMP = ENORM(N,WA1) + PARC = ((FP/DELTA)/TEMP)/TEMP +C +C DEPENDING ON THE SIGN OF THE FUNCTION, UPDATE PARL OR PARU. +C + IF (FP .GT. ZERO) PARL = AMAX1(PARL,PAR) + IF (FP .LT. ZERO) PARU = AMIN1(PARU,PAR) +C +C COMPUTE AN IMPROVED ESTIMATE FOR PAR. +C + PAR = AMAX1(PARL,PAR+PARC) +C +C END OF AN ITERATION. +C + GO TO 150 + 220 CONTINUE +C +C TERMINATION. +C + IF (ITER .EQ. 0) PAR = ZERO + RETURN +C +C LAST CARD OF SUBROUTINE LMPAR. +C + END + SUBROUTINE LMSTR(FCN,M,N,X,FVEC,FJAC,LDFJAC,FTOL,XTOL,GTOL, + * MAXFEV,DIAG,MODE,FACTOR,NPRINT,INFO,NFEV,NJEV, + * IPVT,QTF,WA1,WA2,WA3,WA4) + INTEGER M,N,LDFJAC,MAXFEV,MODE,NPRINT,INFO,NFEV,NJEV + INTEGER IPVT(N) + LOGICAL SING + REAL FTOL,XTOL,GTOL,FACTOR + REAL X(N),FVEC(M),FJAC(LDFJAC,N),DIAG(N),QTF(N),WA1(N),WA2(N), + * WA3(N),WA4(M) +C ********** +C +C SUBROUTINE LMSTR +C +C THE PURPOSE OF LMSTR IS TO MINIMIZE THE SUM OF THE SQUARES OF +C M NONLINEAR FUNCTIONS IN N VARIABLES BY A MODIFICATION OF +C THE LEVENBERG-MARQUARDT ALGORITHM WHICH USES MINIMAL STORAGE. +C THE USER MUST PROVIDE A SUBROUTINE WHICH CALCULATES THE +C FUNCTIONS AND THE ROWS OF THE JACOBIAN. +C +C THE SUBROUTINE STATEMENT IS +C +C SUBROUTINE LMSTR(FCN,M,N,X,FVEC,FJAC,LDFJAC,FTOL,XTOL,GTOL, +C MAXFEV,DIAG,MODE,FACTOR,NPRINT,INFO,NFEV, +C NJEV,IPVT,QTF,WA1,WA2,WA3,WA4) +C +C WHERE +C +C FCN IS THE NAME OF THE USER-SUPPLIED SUBROUTINE WHICH +C CALCULATES THE FUNCTIONS AND THE ROWS OF THE JACOBIAN. +C FCN MUST BE DECLARED IN AN EXTERNAL STATEMENT IN THE +C USER CALLING PROGRAM, AND SHOULD BE WRITTEN AS FOLLOWS. +C +C SUBROUTINE FCN(M,N,X,FVEC,FJROW,IFLAG) +C INTEGER M,N,IFLAG +C REAL X(N),FVEC(M),FJROW(N) +C ---------- +C IF IFLAG = 1 CALCULATE THE FUNCTIONS AT X AND +C RETURN THIS VECTOR IN FVEC. +C IF IFLAG = I CALCULATE THE (I-1)-ST ROW OF THE +C JACOBIAN AT X AND RETURN THIS VECTOR IN FJROW. +C ---------- +C RETURN +C END +C +C THE VALUE OF IFLAG SHOULD NOT BE CHANGED BY FCN UNLESS +C THE USER WANTS TO TERMINATE EXECUTION OF LMSTR. +C IN THIS CASE SET IFLAG TO A NEGATIVE INTEGER. +C +C M IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER +C OF FUNCTIONS. +C +C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER +C OF VARIABLES. N MUST NOT EXCEED M. +C +C X IS AN ARRAY OF LENGTH N. ON INPUT X MUST CONTAIN +C AN INITIAL ESTIMATE OF THE SOLUTION VECTOR. ON OUTPUT X +C CONTAINS THE FINAL ESTIMATE OF THE SOLUTION VECTOR. +C +C FVEC IS AN OUTPUT ARRAY OF LENGTH M WHICH CONTAINS +C THE FUNCTIONS EVALUATED AT THE OUTPUT X. +C +C FJAC IS AN OUTPUT N BY N ARRAY. THE UPPER TRIANGLE OF FJAC +C CONTAINS AN UPPER TRIANGULAR MATRIX R SUCH THAT +C +C T T T +C P *(JAC *JAC)*P = R *R, +C +C WHERE P IS A PERMUTATION MATRIX AND JAC IS THE FINAL +C CALCULATED JACOBIAN. COLUMN J OF P IS COLUMN IPVT(J) +C (SEE BELOW) OF THE IDENTITY MATRIX. THE LOWER TRIANGULAR +C PART OF FJAC CONTAINS INFORMATION GENERATED DURING +C THE COMPUTATION OF R. +C +C LDFJAC IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN N +C WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY FJAC. +C +C FTOL IS A NONNEGATIVE INPUT VARIABLE. TERMINATION +C OCCURS WHEN BOTH THE ACTUAL AND PREDICTED RELATIVE +C REDUCTIONS IN THE SUM OF SQUARES ARE AT MOST FTOL. +C THEREFORE, FTOL MEASURES THE RELATIVE ERROR DESIRED +C IN THE SUM OF SQUARES. +C +C XTOL IS A NONNEGATIVE INPUT VARIABLE. TERMINATION +C OCCURS WHEN THE RELATIVE ERROR BETWEEN TWO CONSECUTIVE +C ITERATES IS AT MOST XTOL. THEREFORE, XTOL MEASURES THE +C RELATIVE ERROR DESIRED IN THE APPROXIMATE SOLUTION. +C +C GTOL IS A NONNEGATIVE INPUT VARIABLE. TERMINATION +C OCCURS WHEN THE COSINE OF THE ANGLE BETWEEN FVEC AND +C ANY COLUMN OF THE JACOBIAN IS AT MOST GTOL IN ABSOLUTE +C VALUE. THEREFORE, GTOL MEASURES THE ORTHOGONALITY +C DESIRED BETWEEN THE FUNCTION VECTOR AND THE COLUMNS +C OF THE JACOBIAN. +C +C MAXFEV IS A POSITIVE INTEGER INPUT VARIABLE. TERMINATION +C OCCURS WHEN THE NUMBER OF CALLS TO FCN WITH IFLAG = 1 +C HAS REACHED MAXFEV. +C +C DIAG IS AN ARRAY OF LENGTH N. IF MODE = 1 (SEE +C BELOW), DIAG IS INTERNALLY SET. IF MODE = 2, DIAG +C MUST CONTAIN POSITIVE ENTRIES THAT SERVE AS +C MULTIPLICATIVE SCALE FACTORS FOR THE VARIABLES. +C +C MODE IS AN INTEGER INPUT VARIABLE. IF MODE = 1, THE +C VARIABLES WILL BE SCALED INTERNALLY. IF MODE = 2, +C THE SCALING IS SPECIFIED BY THE INPUT DIAG. OTHER +C VALUES OF MODE ARE EQUIVALENT TO MODE = 1. +C +C FACTOR IS A POSITIVE INPUT VARIABLE USED IN DETERMINING THE +C INITIAL STEP BOUND. THIS BOUND IS SET TO THE PRODUCT OF +C FACTOR AND THE EUCLIDEAN NORM OF DIAG*X IF NONZERO, OR ELSE +C TO FACTOR ITSELF. IN MOST CASES FACTOR SHOULD LIE IN THE +C INTERVAL (.1,100.). 100. IS A GENERALLY RECOMMENDED VALUE. +C +C NPRINT IS AN INTEGER INPUT VARIABLE THAT ENABLES CONTROLLED +C PRINTING OF ITERATES IF IT IS POSITIVE. IN THIS CASE, +C FCN IS CALLED WITH IFLAG = 0 AT THE BEGINNING OF THE FIRST +C ITERATION AND EVERY NPRINT ITERATIONS THEREAFTER AND +C IMMEDIATELY PRIOR TO RETURN, WITH X AND FVEC AVAILABLE +C FOR PRINTING. IF NPRINT IS NOT POSITIVE, NO SPECIAL CALLS +C OF FCN WITH IFLAG = 0 ARE MADE. +C +C INFO IS AN INTEGER OUTPUT VARIABLE. IF THE USER HAS +C TERMINATED EXECUTION, INFO IS SET TO THE (NEGATIVE) +C VALUE OF IFLAG. SEE DESCRIPTION OF FCN. OTHERWISE, +C INFO IS SET AS FOLLOWS. +C +C INFO = 0 IMPROPER INPUT PARAMETERS. +C +C INFO = 1 BOTH ACTUAL AND PREDICTED RELATIVE REDUCTIONS +C IN THE SUM OF SQUARES ARE AT MOST FTOL. +C +C INFO = 2 RELATIVE ERROR BETWEEN TWO CONSECUTIVE ITERATES +C IS AT MOST XTOL. +C +C INFO = 3 CONDITIONS FOR INFO = 1 AND INFO = 2 BOTH HOLD. +C +C INFO = 4 THE COSINE OF THE ANGLE BETWEEN FVEC AND ANY +C COLUMN OF THE JACOBIAN IS AT MOST GTOL IN +C ABSOLUTE VALUE. +C +C INFO = 5 NUMBER OF CALLS TO FCN WITH IFLAG = 1 HAS +C REACHED MAXFEV. +C +C INFO = 6 FTOL IS TOO SMALL. NO FURTHER REDUCTION IN +C THE SUM OF SQUARES IS POSSIBLE. +C +C INFO = 7 XTOL IS TOO SMALL. NO FURTHER IMPROVEMENT IN +C THE APPROXIMATE SOLUTION X IS POSSIBLE. +C +C INFO = 8 GTOL IS TOO SMALL. FVEC IS ORTHOGONAL TO THE +C COLUMNS OF THE JACOBIAN TO MACHINE PRECISION. +C +C NFEV IS AN INTEGER OUTPUT VARIABLE SET TO THE NUMBER OF +C CALLS TO FCN WITH IFLAG = 1. +C +C NJEV IS AN INTEGER OUTPUT VARIABLE SET TO THE NUMBER OF +C CALLS TO FCN WITH IFLAG = 2. +C +C IPVT IS AN INTEGER OUTPUT ARRAY OF LENGTH N. IPVT +C DEFINES A PERMUTATION MATRIX P SUCH THAT JAC*P = Q*R, +C WHERE JAC IS THE FINAL CALCULATED JACOBIAN, Q IS +C ORTHOGONAL (NOT STORED), AND R IS UPPER TRIANGULAR. +C COLUMN J OF P IS COLUMN IPVT(J) OF THE IDENTITY MATRIX. +C +C QTF IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS +C THE FIRST N ELEMENTS OF THE VECTOR (Q TRANSPOSE)*FVEC. +C +C WA1, WA2, AND WA3 ARE WORK ARRAYS OF LENGTH N. +C +C WA4 IS A WORK ARRAY OF LENGTH M. +C +C SUBPROGRAMS CALLED +C +C USER-SUPPLIED ...... FCN +C +C MINPACK-SUPPLIED ... SPMPAR,ENORM,LMPAR,QRFAC,RWUPDT +C +C FORTRAN-SUPPLIED ... ABS,AMAX1,AMIN1,SQRT,MOD +C +C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. +C BURTON S. GARBOW, DUDLEY V. GOETSCHEL, KENNETH E. HILLSTROM, +C JORGE J. MORE +C +C ********** + INTEGER I,IFLAG,ITER,J,L + REAL ACTRED,DELTA,DIRDER,EPSMCH,FNORM,FNORM1,GNORM,ONE,PAR, + * PNORM,PRERED,P1,P5,P25,P75,P0001,RATIO,SUM,TEMP,TEMP1, + * TEMP2,XNORM,ZERO + REAL SPMPAR,ENORM + DATA ONE,P1,P5,P25,P75,P0001,ZERO + * /1.0E0,1.0E-1,5.0E-1,2.5E-1,7.5E-1,1.0E-4,0.0E0/ +C +C EPSMCH IS THE MACHINE PRECISION. +C + EPSMCH = SPMPAR(1) +C + INFO = 0 + IFLAG = 0 + NFEV = 0 + NJEV = 0 +C +C CHECK THE INPUT PARAMETERS FOR ERRORS. +C + IF (N .LE. 0 .OR. M .LT. N .OR. LDFJAC .LT. N + * .OR. FTOL .LT. ZERO .OR. XTOL .LT. ZERO .OR. GTOL .LT. ZERO + * .OR. MAXFEV .LE. 0 .OR. FACTOR .LE. ZERO) GO TO 340 + IF (MODE .NE. 2) GO TO 20 + DO 10 J = 1, N + IF (DIAG(J) .LE. ZERO) GO TO 340 + 10 CONTINUE + 20 CONTINUE +C +C EVALUATE THE FUNCTION AT THE STARTING POINT +C AND CALCULATE ITS NORM. +C + IFLAG = 1 + CALL FCN(M,N,X,FVEC,WA3,IFLAG) + NFEV = 1 + IF (IFLAG .LT. 0) GO TO 340 + FNORM = ENORM(M,FVEC) +C +C INITIALIZE LEVENBERG-MARQUARDT PARAMETER AND ITERATION COUNTER. +C + PAR = ZERO + ITER = 1 +C +C BEGINNING OF THE OUTER LOOP. +C + 30 CONTINUE +C +C IF REQUESTED, CALL FCN TO ENABLE PRINTING OF ITERATES. +C + IF (NPRINT .LE. 0) GO TO 40 + IFLAG = 0 + IF (MOD(ITER-1,NPRINT) .EQ. 0) CALL FCN(M,N,X,FVEC,WA3,IFLAG) + IF (IFLAG .LT. 0) GO TO 340 + 40 CONTINUE +C +C COMPUTE THE QR FACTORIZATION OF THE JACOBIAN MATRIX +C CALCULATED ONE ROW AT A TIME, WHILE SIMULTANEOUSLY +C FORMING (Q TRANSPOSE)*FVEC AND STORING THE FIRST +C N COMPONENTS IN QTF. +C + DO 60 J = 1, N + QTF(J) = ZERO + DO 50 I = 1, N + FJAC(I,J) = ZERO + 50 CONTINUE + 60 CONTINUE + IFLAG = 2 + DO 70 I = 1, M + CALL FCN(M,N,X,FVEC,WA3,IFLAG) + IF (IFLAG .LT. 0) GO TO 340 + TEMP = FVEC(I) + CALL RWUPDT(N,FJAC,LDFJAC,WA3,QTF,TEMP,WA1,WA2) + IFLAG = IFLAG + 1 + 70 CONTINUE + NJEV = NJEV + 1 +C +C IF THE JACOBIAN IS RANK DEFICIENT, CALL QRFAC TO +C REORDER ITS COLUMNS AND UPDATE THE COMPONENTS OF QTF. +C + SING = .FALSE. + DO 80 J = 1, N + IF (FJAC(J,J) .EQ. ZERO) SING = .TRUE. + IPVT(J) = J + WA2(J) = ENORM(J,FJAC(1,J)) + 80 CONTINUE + IF (.NOT.SING) GO TO 130 + CALL QRFAC(N,N,FJAC,LDFJAC,.TRUE.,IPVT,N,WA1,WA2,WA3) + DO 120 J = 1, N + IF (FJAC(J,J) .EQ. ZERO) GO TO 110 + SUM = ZERO + DO 90 I = J, N + SUM = SUM + FJAC(I,J)*QTF(I) + 90 CONTINUE + TEMP = -SUM/FJAC(J,J) + DO 100 I = J, N + QTF(I) = QTF(I) + FJAC(I,J)*TEMP + 100 CONTINUE + 110 CONTINUE + FJAC(J,J) = WA1(J) + 120 CONTINUE + 130 CONTINUE +C +C ON THE FIRST ITERATION AND IF MODE IS 1, SCALE ACCORDING +C TO THE NORMS OF THE COLUMNS OF THE INITIAL JACOBIAN. +C + IF (ITER .NE. 1) GO TO 170 + IF (MODE .EQ. 2) GO TO 150 + DO 140 J = 1, N + DIAG(J) = WA2(J) + IF (WA2(J) .EQ. ZERO) DIAG(J) = ONE + 140 CONTINUE + 150 CONTINUE +C +C ON THE FIRST ITERATION, CALCULATE THE NORM OF THE SCALED X +C AND INITIALIZE THE STEP BOUND DELTA. +C + DO 160 J = 1, N + WA3(J) = DIAG(J)*X(J) + 160 CONTINUE + XNORM = ENORM(N,WA3) + DELTA = FACTOR*XNORM + IF (DELTA .EQ. ZERO) DELTA = FACTOR + 170 CONTINUE +C +C COMPUTE THE NORM OF THE SCALED GRADIENT. +C + GNORM = ZERO + IF (FNORM .EQ. ZERO) GO TO 210 + DO 200 J = 1, N + L = IPVT(J) + IF (WA2(L) .EQ. ZERO) GO TO 190 + SUM = ZERO + DO 180 I = 1, J + SUM = SUM + FJAC(I,J)*(QTF(I)/FNORM) + 180 CONTINUE + GNORM = AMAX1(GNORM,ABS(SUM/WA2(L))) + 190 CONTINUE + 200 CONTINUE + 210 CONTINUE +C +C TEST FOR CONVERGENCE OF THE GRADIENT NORM. +C + IF (GNORM .LE. GTOL) INFO = 4 + IF (INFO .NE. 0) GO TO 340 +C +C RESCALE IF NECESSARY. +C + IF (MODE .EQ. 2) GO TO 230 + DO 220 J = 1, N + DIAG(J) = AMAX1(DIAG(J),WA2(J)) + 220 CONTINUE + 230 CONTINUE +C +C BEGINNING OF THE INNER LOOP. +C + 240 CONTINUE +C +C DETERMINE THE LEVENBERG-MARQUARDT PARAMETER. +C + CALL LMPAR(N,FJAC,LDFJAC,IPVT,DIAG,QTF,DELTA,PAR,WA1,WA2, + * WA3,WA4) +C +C STORE THE DIRECTION P AND X + P. CALCULATE THE NORM OF P. +C + DO 250 J = 1, N + WA1(J) = -WA1(J) + WA2(J) = X(J) + WA1(J) + WA3(J) = DIAG(J)*WA1(J) + 250 CONTINUE + PNORM = ENORM(N,WA3) +C +C ON THE FIRST ITERATION, ADJUST THE INITIAL STEP BOUND. +C + IF (ITER .EQ. 1) DELTA = AMIN1(DELTA,PNORM) +C +C EVALUATE THE FUNCTION AT X + P AND CALCULATE ITS NORM. +C + IFLAG = 1 + CALL FCN(M,N,WA2,WA4,WA3,IFLAG) + NFEV = NFEV + 1 + IF (IFLAG .LT. 0) GO TO 340 + FNORM1 = ENORM(M,WA4) +C +C COMPUTE THE SCALED ACTUAL REDUCTION. +C + ACTRED = -ONE + IF (P1*FNORM1 .LT. FNORM) ACTRED = ONE - (FNORM1/FNORM)**2 +C +C COMPUTE THE SCALED PREDICTED REDUCTION AND +C THE SCALED DIRECTIONAL DERIVATIVE. +C + DO 270 J = 1, N + WA3(J) = ZERO + L = IPVT(J) + TEMP = WA1(L) + DO 260 I = 1, J + WA3(I) = WA3(I) + FJAC(I,J)*TEMP + 260 CONTINUE + 270 CONTINUE + TEMP1 = ENORM(N,WA3)/FNORM + TEMP2 = (SQRT(PAR)*PNORM)/FNORM + PRERED = TEMP1**2 + TEMP2**2/P5 + DIRDER = -(TEMP1**2 + TEMP2**2) +C +C COMPUTE THE RATIO OF THE ACTUAL TO THE PREDICTED +C REDUCTION. +C + RATIO = ZERO + IF (PRERED .NE. ZERO) RATIO = ACTRED/PRERED +C +C UPDATE THE STEP BOUND. +C + IF (RATIO .GT. P25) GO TO 280 + IF (ACTRED .GE. ZERO) TEMP = P5 + IF (ACTRED .LT. ZERO) + * TEMP = P5*DIRDER/(DIRDER + P5*ACTRED) + IF (P1*FNORM1 .GE. FNORM .OR. TEMP .LT. P1) TEMP = P1 + DELTA = TEMP*AMIN1(DELTA,PNORM/P1) + PAR = PAR/TEMP + GO TO 300 + 280 CONTINUE + IF (PAR .NE. ZERO .AND. RATIO .LT. P75) GO TO 290 + DELTA = PNORM/P5 + PAR = P5*PAR + 290 CONTINUE + 300 CONTINUE +C +C TEST FOR SUCCESSFUL ITERATION. +C + IF (RATIO .LT. P0001) GO TO 330 +C +C SUCCESSFUL ITERATION. UPDATE X, FVEC, AND THEIR NORMS. +C + DO 310 J = 1, N + X(J) = WA2(J) + WA2(J) = DIAG(J)*X(J) + 310 CONTINUE + DO 320 I = 1, M + FVEC(I) = WA4(I) + 320 CONTINUE + XNORM = ENORM(N,WA2) + FNORM = FNORM1 + ITER = ITER + 1 + 330 CONTINUE +C +C TESTS FOR CONVERGENCE. +C + IF (ABS(ACTRED) .LE. FTOL .AND. PRERED .LE. FTOL + * .AND. P5*RATIO .LE. ONE) INFO = 1 + IF (DELTA .LE. XTOL*XNORM) INFO = 2 + IF (ABS(ACTRED) .LE. FTOL .AND. PRERED .LE. FTOL + * .AND. P5*RATIO .LE. ONE .AND. INFO .EQ. 2) INFO = 3 + IF (INFO .NE. 0) GO TO 340 +C +C TESTS FOR TERMINATION AND STRINGENT TOLERANCES. +C + IF (NFEV .GE. MAXFEV) INFO = 5 + IF (ABS(ACTRED) .LE. EPSMCH .AND. PRERED .LE. EPSMCH + * .AND. P5*RATIO .LE. ONE) INFO = 6 + IF (DELTA .LE. EPSMCH*XNORM) INFO = 7 + IF (GNORM .LE. EPSMCH) INFO = 8 + IF (INFO .NE. 0) GO TO 340 +C +C END OF THE INNER LOOP. REPEAT IF ITERATION UNSUCCESSFUL. +C + IF (RATIO .LT. P0001) GO TO 240 +C +C END OF THE OUTER LOOP. +C + GO TO 30 + 340 CONTINUE +C +C TERMINATION, EITHER NORMAL OR USER IMPOSED. +C + IF (IFLAG .LT. 0) INFO = IFLAG + IFLAG = 0 + IF (NPRINT .GT. 0) CALL FCN(M,N,X,FVEC,WA3,IFLAG) + RETURN +C +C LAST CARD OF SUBROUTINE LMSTR. +C + END + SUBROUTINE LMSTR1(FCN,M,N,X,FVEC,FJAC,LDFJAC,TOL,INFO,IPVT,WA, + * LWA) + INTEGER M,N,LDFJAC,INFO,LWA + INTEGER IPVT(N) + REAL TOL + REAL X(N),FVEC(M),FJAC(LDFJAC,N),WA(LWA) + EXTERNAL FCN +C ********** +C +C SUBROUTINE LMSTR1 +C +C THE PURPOSE OF LMSTR1 IS TO MINIMIZE THE SUM OF THE SQUARES OF +C M NONLINEAR FUNCTIONS IN N VARIABLES BY A MODIFICATION OF +C THE LEVENBERG-MARQUARDT ALGORITHM WHICH USES MINIMAL STORAGE. +C THIS IS DONE BY USING THE MORE GENERAL LEAST-SQUARES SOLVER +C LMSTR. THE USER MUST PROVIDE A SUBROUTINE WHICH CALCULATES +C THE FUNCTIONS AND THE ROWS OF THE JACOBIAN. +C +C THE SUBROUTINE STATEMENT IS +C +C SUBROUTINE LMSTR1(FCN,M,N,X,FVEC,FJAC,LDFJAC,TOL,INFO, +C IPVT,WA,LWA) +C +C WHERE +C +C FCN IS THE NAME OF THE USER-SUPPLIED SUBROUTINE WHICH +C CALCULATES THE FUNCTIONS AND THE ROWS OF THE JACOBIAN. +C FCN MUST BE DECLARED IN AN EXTERNAL STATEMENT IN THE +C USER CALLING PROGRAM, AND SHOULD BE WRITTEN AS FOLLOWS. +C +C SUBROUTINE FCN(M,N,X,FVEC,FJROW,IFLAG) +C INTEGER M,N,IFLAG +C REAL X(N),FVEC(M),FJROW(N) +C ---------- +C IF IFLAG = 1 CALCULATE THE FUNCTIONS AT X AND +C RETURN THIS VECTOR IN FVEC. +C IF IFLAG = I CALCULATE THE (I-1)-ST ROW OF THE +C JACOBIAN AT X AND RETURN THIS VECTOR IN FJROW. +C ---------- +C RETURN +C END +C +C THE VALUE OF IFLAG SHOULD NOT BE CHANGED BY FCN UNLESS +C THE USER WANTS TO TERMINATE EXECUTION OF LMSTR1. +C IN THIS CASE SET IFLAG TO A NEGATIVE INTEGER. +C +C M IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER +C OF FUNCTIONS. +C +C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER +C OF VARIABLES. N MUST NOT EXCEED M. +C +C X IS AN ARRAY OF LENGTH N. ON INPUT X MUST CONTAIN +C AN INITIAL ESTIMATE OF THE SOLUTION VECTOR. ON OUTPUT X +C CONTAINS THE FINAL ESTIMATE OF THE SOLUTION VECTOR. +C +C FVEC IS AN OUTPUT ARRAY OF LENGTH M WHICH CONTAINS +C THE FUNCTIONS EVALUATED AT THE OUTPUT X. +C +C FJAC IS AN OUTPUT N BY N ARRAY. THE UPPER TRIANGLE OF FJAC +C CONTAINS AN UPPER TRIANGULAR MATRIX R SUCH THAT +C +C T T T +C P *(JAC *JAC)*P = R *R, +C +C WHERE P IS A PERMUTATION MATRIX AND JAC IS THE FINAL +C CALCULATED JACOBIAN. COLUMN J OF P IS COLUMN IPVT(J) +C (SEE BELOW) OF THE IDENTITY MATRIX. THE LOWER TRIANGULAR +C PART OF FJAC CONTAINS INFORMATION GENERATED DURING +C THE COMPUTATION OF R. +C +C LDFJAC IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN N +C WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY FJAC. +C +C TOL IS A NONNEGATIVE INPUT VARIABLE. TERMINATION OCCURS +C WHEN THE ALGORITHM ESTIMATES EITHER THAT THE RELATIVE +C ERROR IN THE SUM OF SQUARES IS AT MOST TOL OR THAT +C THE RELATIVE ERROR BETWEEN X AND THE SOLUTION IS AT +C MOST TOL. +C +C INFO IS AN INTEGER OUTPUT VARIABLE. IF THE USER HAS +C TERMINATED EXECUTION, INFO IS SET TO THE (NEGATIVE) +C VALUE OF IFLAG. SEE DESCRIPTION OF FCN. OTHERWISE, +C INFO IS SET AS FOLLOWS. +C +C INFO = 0 IMPROPER INPUT PARAMETERS. +C +C INFO = 1 ALGORITHM ESTIMATES THAT THE RELATIVE ERROR +C IN THE SUM OF SQUARES IS AT MOST TOL. +C +C INFO = 2 ALGORITHM ESTIMATES THAT THE RELATIVE ERROR +C BETWEEN X AND THE SOLUTION IS AT MOST TOL. +C +C INFO = 3 CONDITIONS FOR INFO = 1 AND INFO = 2 BOTH HOLD. +C +C INFO = 4 FVEC IS ORTHOGONAL TO THE COLUMNS OF THE +C JACOBIAN TO MACHINE PRECISION. +C +C INFO = 5 NUMBER OF CALLS TO FCN WITH IFLAG = 1 HAS +C REACHED 100*(N+1). +C +C INFO = 6 TOL IS TOO SMALL. NO FURTHER REDUCTION IN +C THE SUM OF SQUARES IS POSSIBLE. +C +C INFO = 7 TOL IS TOO SMALL. NO FURTHER IMPROVEMENT IN +C THE APPROXIMATE SOLUTION X IS POSSIBLE. +C +C IPVT IS AN INTEGER OUTPUT ARRAY OF LENGTH N. IPVT +C DEFINES A PERMUTATION MATRIX P SUCH THAT JAC*P = Q*R, +C WHERE JAC IS THE FINAL CALCULATED JACOBIAN, Q IS +C ORTHOGONAL (NOT STORED), AND R IS UPPER TRIANGULAR. +C COLUMN J OF P IS COLUMN IPVT(J) OF THE IDENTITY MATRIX. +C +C WA IS A WORK ARRAY OF LENGTH LWA. +C +C LWA IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN 5*N+M. +C +C SUBPROGRAMS CALLED +C +C USER-SUPPLIED ...... FCN +C +C MINPACK-SUPPLIED ... LMSTR +C +C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. +C BURTON S. GARBOW, DUDLEY V. GOETSCHEL, KENNETH E. HILLSTROM, +C JORGE J. MORE +C +C ********** + INTEGER MAXFEV,MODE,NFEV,NJEV,NPRINT + REAL FACTOR,FTOL,GTOL,XTOL,ZERO + DATA FACTOR,ZERO /1.0E2,0.0E0/ + INFO = 0 +C +C CHECK THE INPUT PARAMETERS FOR ERRORS. +C + IF (N .LE. 0 .OR. M .LT. N .OR. LDFJAC .LT. N .OR. TOL .LT. ZERO + * .OR. LWA .LT. 5*N + M) GO TO 10 +C +C CALL LMSTR. +C + MAXFEV = 100*(N + 1) + FTOL = TOL + XTOL = TOL + GTOL = ZERO + MODE = 1 + NPRINT = 0 + CALL LMSTR(FCN,M,N,X,FVEC,FJAC,LDFJAC,FTOL,XTOL,GTOL,MAXFEV, + * WA(1),MODE,FACTOR,NPRINT,INFO,NFEV,NJEV,IPVT,WA(N+1), + * WA(2*N+1),WA(3*N+1),WA(4*N+1),WA(5*N+1)) + IF (INFO .EQ. 8) INFO = 4 + 10 CONTINUE + RETURN +C +C LAST CARD OF SUBROUTINE LMSTR1. +C + END + SUBROUTINE QFORM(M,N,Q,LDQ,WA) + INTEGER M,N,LDQ + REAL Q(LDQ,M),WA(M) +C ********** +C +C SUBROUTINE QFORM +C +C THIS SUBROUTINE PROCEEDS FROM THE COMPUTED QR FACTORIZATION OF +C AN M BY N MATRIX A TO ACCUMULATE THE M BY M ORTHOGONAL MATRIX +C Q FROM ITS FACTORED FORM. +C +C THE SUBROUTINE STATEMENT IS +C +C SUBROUTINE QFORM(M,N,Q,LDQ,WA) +C +C WHERE +C +C M IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER +C OF ROWS OF A AND THE ORDER OF Q. +C +C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER +C OF COLUMNS OF A. +C +C Q IS AN M BY M ARRAY. ON INPUT THE FULL LOWER TRAPEZOID IN +C THE FIRST MIN(M,N) COLUMNS OF Q CONTAINS THE FACTORED FORM. +C ON OUTPUT Q HAS BEEN ACCUMULATED INTO A SQUARE MATRIX. +C +C LDQ IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN M +C WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY Q. +C +C WA IS A WORK ARRAY OF LENGTH M. +C +C SUBPROGRAMS CALLED +C +C FORTRAN-SUPPLIED ... MIN0 +C +C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. +C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE +C +C ********** + INTEGER I,J,JM1,K,L,MINMN,NP1 + REAL ONE,SUM,TEMP,ZERO + DATA ONE,ZERO /1.0E0,0.0E0/ +C +C ZERO OUT UPPER TRIANGLE OF Q IN THE FIRST MIN(M,N) COLUMNS. +C + MINMN = MIN0(M,N) + IF (MINMN .LT. 2) GO TO 30 + DO 20 J = 2, MINMN + JM1 = J - 1 + DO 10 I = 1, JM1 + Q(I,J) = ZERO + 10 CONTINUE + 20 CONTINUE + 30 CONTINUE +C +C INITIALIZE REMAINING COLUMNS TO THOSE OF THE IDENTITY MATRIX. +C + NP1 = N + 1 + IF (M .LT. NP1) GO TO 60 + DO 50 J = NP1, M + DO 40 I = 1, M + Q(I,J) = ZERO + 40 CONTINUE + Q(J,J) = ONE + 50 CONTINUE + 60 CONTINUE +C +C ACCUMULATE Q FROM ITS FACTORED FORM. +C + DO 120 L = 1, MINMN + K = MINMN - L + 1 + DO 70 I = K, M + WA(I) = Q(I,K) + Q(I,K) = ZERO + 70 CONTINUE + Q(K,K) = ONE + IF (WA(K) .EQ. ZERO) GO TO 110 + DO 100 J = K, M + SUM = ZERO + DO 80 I = K, M + SUM = SUM + Q(I,J)*WA(I) + 80 CONTINUE + TEMP = SUM/WA(K) + DO 90 I = K, M + Q(I,J) = Q(I,J) - TEMP*WA(I) + 90 CONTINUE + 100 CONTINUE + 110 CONTINUE + 120 CONTINUE + RETURN +C +C LAST CARD OF SUBROUTINE QFORM. +C + END + SUBROUTINE QRFAC(M,N,A,LDA,PIVOT,IPVT,LIPVT,RDIAG,ACNORM,WA) + INTEGER M,N,LDA,LIPVT + INTEGER IPVT(LIPVT) + LOGICAL PIVOT + REAL A(LDA,N),RDIAG(N),ACNORM(N),WA(N) +C ********** +C +C SUBROUTINE QRFAC +C +C THIS SUBROUTINE USES HOUSEHOLDER TRANSFORMATIONS WITH COLUMN +C PIVOTING (OPTIONAL) TO COMPUTE A QR FACTORIZATION OF THE +C M BY N MATRIX A. THAT IS, QRFAC DETERMINES AN ORTHOGONAL +C MATRIX Q, A PERMUTATION MATRIX P, AND AN UPPER TRAPEZOIDAL +C MATRIX R WITH DIAGONAL ELEMENTS OF NONINCREASING MAGNITUDE, +C SUCH THAT A*P = Q*R. THE HOUSEHOLDER TRANSFORMATION FOR +C COLUMN K, K = 1,2,...,MIN(M,N), IS OF THE FORM +C +C T +C I - (1/U(K))*U*U +C +C WHERE U HAS ZEROS IN THE FIRST K-1 POSITIONS. THE FORM OF +C THIS TRANSFORMATION AND THE METHOD OF PIVOTING FIRST +C APPEARED IN THE CORRESPONDING LINPACK SUBROUTINE. +C +C THE SUBROUTINE STATEMENT IS +C +C SUBROUTINE QRFAC(M,N,A,LDA,PIVOT,IPVT,LIPVT,RDIAG,ACNORM,WA) +C +C WHERE +C +C M IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER +C OF ROWS OF A. +C +C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER +C OF COLUMNS OF A. +C +C A IS AN M BY N ARRAY. ON INPUT A CONTAINS THE MATRIX FOR +C WHICH THE QR FACTORIZATION IS TO BE COMPUTED. ON OUTPUT +C THE STRICT UPPER TRAPEZOIDAL PART OF A CONTAINS THE STRICT +C UPPER TRAPEZOIDAL PART OF R, AND THE LOWER TRAPEZOIDAL +C PART OF A CONTAINS A FACTORED FORM OF Q (THE NON-TRIVIAL +C ELEMENTS OF THE U VECTORS DESCRIBED ABOVE). +C +C LDA IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN M +C WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY A. +C +C PIVOT IS A LOGICAL INPUT VARIABLE. IF PIVOT IS SET TRUE, +C THEN COLUMN PIVOTING IS ENFORCED. IF PIVOT IS SET FALSE, +C THEN NO COLUMN PIVOTING IS DONE. +C +C IPVT IS AN INTEGER OUTPUT ARRAY OF LENGTH LIPVT. IPVT +C DEFINES THE PERMUTATION MATRIX P SUCH THAT A*P = Q*R. +C COLUMN J OF P IS COLUMN IPVT(J) OF THE IDENTITY MATRIX. +C IF PIVOT IS FALSE, IPVT IS NOT REFERENCED. +C +C LIPVT IS A POSITIVE INTEGER INPUT VARIABLE. IF PIVOT IS FALSE, +C THEN LIPVT MAY BE AS SMALL AS 1. IF PIVOT IS TRUE, THEN +C LIPVT MUST BE AT LEAST N. +C +C RDIAG IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE +C DIAGONAL ELEMENTS OF R. +C +C ACNORM IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE +C NORMS OF THE CORRESPONDING COLUMNS OF THE INPUT MATRIX A. +C IF THIS INFORMATION IS NOT NEEDED, THEN ACNORM CAN COINCIDE +C WITH RDIAG. +C +C WA IS A WORK ARRAY OF LENGTH N. IF PIVOT IS FALSE, THEN WA +C CAN COINCIDE WITH RDIAG. +C +C SUBPROGRAMS CALLED +C +C MINPACK-SUPPLIED ... SPMPAR,ENORM +C +C FORTRAN-SUPPLIED ... AMAX1,SQRT,MIN0 +C +C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. +C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE +C +C ********** + INTEGER I,J,JP1,K,KMAX,MINMN + REAL AJNORM,EPSMCH,ONE,P05,SUM,TEMP,ZERO + REAL SPMPAR,ENORM + DATA ONE,P05,ZERO /1.0E0,5.0E-2,0.0E0/ +C +C EPSMCH IS THE MACHINE PRECISION. +C + EPSMCH = SPMPAR(1) +C +C COMPUTE THE INITIAL COLUMN NORMS AND INITIALIZE SEVERAL ARRAYS. +C + DO 10 J = 1, N + ACNORM(J) = ENORM(M,A(1,J)) + RDIAG(J) = ACNORM(J) + WA(J) = RDIAG(J) + IF (PIVOT) IPVT(J) = J + 10 CONTINUE +C +C REDUCE A TO R WITH HOUSEHOLDER TRANSFORMATIONS. +C + MINMN = MIN0(M,N) + DO 110 J = 1, MINMN + IF (.NOT.PIVOT) GO TO 40 +C +C BRING THE COLUMN OF LARGEST NORM INTO THE PIVOT POSITION. +C + KMAX = J + DO 20 K = J, N + IF (RDIAG(K) .GT. RDIAG(KMAX)) KMAX = K + 20 CONTINUE + IF (KMAX .EQ. J) GO TO 40 + DO 30 I = 1, M + TEMP = A(I,J) + A(I,J) = A(I,KMAX) + A(I,KMAX) = TEMP + 30 CONTINUE + RDIAG(KMAX) = RDIAG(J) + WA(KMAX) = WA(J) + K = IPVT(J) + IPVT(J) = IPVT(KMAX) + IPVT(KMAX) = K + 40 CONTINUE +C +C COMPUTE THE HOUSEHOLDER TRANSFORMATION TO REDUCE THE +C J-TH COLUMN OF A TO A MULTIPLE OF THE J-TH UNIT VECTOR. +C + AJNORM = ENORM(M-J+1,A(J,J)) + IF (AJNORM .EQ. ZERO) GO TO 100 + IF (A(J,J) .LT. ZERO) AJNORM = -AJNORM + DO 50 I = J, M + A(I,J) = A(I,J)/AJNORM + 50 CONTINUE + A(J,J) = A(J,J) + ONE +C +C APPLY THE TRANSFORMATION TO THE REMAINING COLUMNS +C AND UPDATE THE NORMS. +C + JP1 = J + 1 + IF (N .LT. JP1) GO TO 100 + DO 90 K = JP1, N + SUM = ZERO + DO 60 I = J, M + SUM = SUM + A(I,J)*A(I,K) + 60 CONTINUE + TEMP = SUM/A(J,J) + DO 70 I = J, M + A(I,K) = A(I,K) - TEMP*A(I,J) + 70 CONTINUE + IF (.NOT.PIVOT .OR. RDIAG(K) .EQ. ZERO) GO TO 80 + TEMP = A(J,K)/RDIAG(K) + RDIAG(K) = RDIAG(K)*SQRT(AMAX1(ZERO,ONE-TEMP**2)) + IF (P05*(RDIAG(K)/WA(K))**2 .GT. EPSMCH) GO TO 80 + RDIAG(K) = ENORM(M-J,A(JP1,K)) + WA(K) = RDIAG(K) + 80 CONTINUE + 90 CONTINUE + 100 CONTINUE + RDIAG(J) = -AJNORM + 110 CONTINUE + RETURN +C +C LAST CARD OF SUBROUTINE QRFAC. +C + END + SUBROUTINE QRSOLV(N,R,LDR,IPVT,DIAG,QTB,X,SDIAG,WA) + INTEGER N,LDR + INTEGER IPVT(N) + REAL R(LDR,N),DIAG(N),QTB(N),X(N),SDIAG(N),WA(N) +C ********** +C +C SUBROUTINE QRSOLV +C +C GIVEN AN M BY N MATRIX A, AN N BY N DIAGONAL MATRIX D, +C AND AN M-VECTOR B, THE PROBLEM IS TO DETERMINE AN X WHICH +C SOLVES THE SYSTEM +C +C A*X = B , D*X = 0 , +C +C IN THE LEAST SQUARES SENSE. +C +C THIS SUBROUTINE COMPLETES THE SOLUTION OF THE PROBLEM +C IF IT IS PROVIDED WITH THE NECESSARY INFORMATION FROM THE +C QR FACTORIZATION, WITH COLUMN PIVOTING, OF A. THAT IS, IF +C A*P = Q*R, WHERE P IS A PERMUTATION MATRIX, Q HAS ORTHOGONAL +C COLUMNS, AND R IS AN UPPER TRIANGULAR MATRIX WITH DIAGONAL +C ELEMENTS OF NONINCREASING MAGNITUDE, THEN QRSOLV EXPECTS +C THE FULL UPPER TRIANGLE OF R, THE PERMUTATION MATRIX P, +C AND THE FIRST N COMPONENTS OF (Q TRANSPOSE)*B. THE SYSTEM +C A*X = B, D*X = 0, IS THEN EQUIVALENT TO +C +C T T +C R*Z = Q *B , P *D*P*Z = 0 , +C +C WHERE X = P*Z. IF THIS SYSTEM DOES NOT HAVE FULL RANK, +C THEN A LEAST SQUARES SOLUTION IS OBTAINED. ON OUTPUT QRSOLV +C ALSO PROVIDES AN UPPER TRIANGULAR MATRIX S SUCH THAT +C +C T T T +C P *(A *A + D*D)*P = S *S . +C +C S IS COMPUTED WITHIN QRSOLV AND MAY BE OF SEPARATE INTEREST. +C +C THE SUBROUTINE STATEMENT IS +C +C SUBROUTINE QRSOLV(N,R,LDR,IPVT,DIAG,QTB,X,SDIAG,WA) +C +C WHERE +C +C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE ORDER OF R. +C +C R IS AN N BY N ARRAY. ON INPUT THE FULL UPPER TRIANGLE +C MUST CONTAIN THE FULL UPPER TRIANGLE OF THE MATRIX R. +C ON OUTPUT THE FULL UPPER TRIANGLE IS UNALTERED, AND THE +C STRICT LOWER TRIANGLE CONTAINS THE STRICT UPPER TRIANGLE +C (TRANSPOSED) OF THE UPPER TRIANGULAR MATRIX S. +C +C LDR IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN N +C WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY R. +C +C IPVT IS AN INTEGER INPUT ARRAY OF LENGTH N WHICH DEFINES THE +C PERMUTATION MATRIX P SUCH THAT A*P = Q*R. COLUMN J OF P +C IS COLUMN IPVT(J) OF THE IDENTITY MATRIX. +C +C DIAG IS AN INPUT ARRAY OF LENGTH N WHICH MUST CONTAIN THE +C DIAGONAL ELEMENTS OF THE MATRIX D. +C +C QTB IS AN INPUT ARRAY OF LENGTH N WHICH MUST CONTAIN THE FIRST +C N ELEMENTS OF THE VECTOR (Q TRANSPOSE)*B. +C +C X IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE LEAST +C SQUARES SOLUTION OF THE SYSTEM A*X = B, D*X = 0. +C +C SDIAG IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE +C DIAGONAL ELEMENTS OF THE UPPER TRIANGULAR MATRIX S. +C +C WA IS A WORK ARRAY OF LENGTH N. +C +C SUBPROGRAMS CALLED +C +C FORTRAN-SUPPLIED ... ABS,SQRT +C +C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. +C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE +C +C ********** + INTEGER I,J,JP1,K,KP1,L,NSING + REAL COS,COTAN,P5,P25,QTBPJ,SIN,SUM,TAN,TEMP,ZERO + DATA P5,P25,ZERO /5.0E-1,2.5E-1,0.0E0/ +C +C COPY R AND (Q TRANSPOSE)*B TO PRESERVE INPUT AND INITIALIZE S. +C IN PARTICULAR, SAVE THE DIAGONAL ELEMENTS OF R IN X. +C + DO 20 J = 1, N + DO 10 I = J, N + R(I,J) = R(J,I) + 10 CONTINUE + X(J) = R(J,J) + WA(J) = QTB(J) + 20 CONTINUE +C +C ELIMINATE THE DIAGONAL MATRIX D USING A GIVENS ROTATION. +C + DO 100 J = 1, N +C +C PREPARE THE ROW OF D TO BE ELIMINATED, LOCATING THE +C DIAGONAL ELEMENT USING P FROM THE QR FACTORIZATION. +C + L = IPVT(J) + IF (DIAG(L) .EQ. ZERO) GO TO 90 + DO 30 K = J, N + SDIAG(K) = ZERO + 30 CONTINUE + SDIAG(J) = DIAG(L) +C +C THE TRANSFORMATIONS TO ELIMINATE THE ROW OF D +C MODIFY ONLY A SINGLE ELEMENT OF (Q TRANSPOSE)*B +C BEYOND THE FIRST N, WHICH IS INITIALLY ZERO. +C + QTBPJ = ZERO + DO 80 K = J, N +C +C DETERMINE A GIVENS ROTATION WHICH ELIMINATES THE +C APPROPRIATE ELEMENT IN THE CURRENT ROW OF D. +C + IF (SDIAG(K) .EQ. ZERO) GO TO 70 + IF (ABS(R(K,K)) .GE. ABS(SDIAG(K))) GO TO 40 + COTAN = R(K,K)/SDIAG(K) + SIN = P5/SQRT(P25+P25*COTAN**2) + COS = SIN*COTAN + GO TO 50 + 40 CONTINUE + TAN = SDIAG(K)/R(K,K) + COS = P5/SQRT(P25+P25*TAN**2) + SIN = COS*TAN + 50 CONTINUE +C +C COMPUTE THE MODIFIED DIAGONAL ELEMENT OF R AND +C THE MODIFIED ELEMENT OF ((Q TRANSPOSE)*B,0). +C + R(K,K) = COS*R(K,K) + SIN*SDIAG(K) + TEMP = COS*WA(K) + SIN*QTBPJ + QTBPJ = -SIN*WA(K) + COS*QTBPJ + WA(K) = TEMP +C +C ACCUMULATE THE TRANFORMATION IN THE ROW OF S. +C + KP1 = K + 1 + IF (N .LT. KP1) GO TO 70 + DO 60 I = KP1, N + TEMP = COS*R(I,K) + SIN*SDIAG(I) + SDIAG(I) = -SIN*R(I,K) + COS*SDIAG(I) + R(I,K) = TEMP + 60 CONTINUE + 70 CONTINUE + 80 CONTINUE + 90 CONTINUE +C +C STORE THE DIAGONAL ELEMENT OF S AND RESTORE +C THE CORRESPONDING DIAGONAL ELEMENT OF R. +C + SDIAG(J) = R(J,J) + R(J,J) = X(J) + 100 CONTINUE +C +C SOLVE THE TRIANGULAR SYSTEM FOR Z. IF THE SYSTEM IS +C SINGULAR, THEN OBTAIN A LEAST SQUARES SOLUTION. +C + NSING = N + DO 110 J = 1, N + IF (SDIAG(J) .EQ. ZERO .AND. NSING .EQ. N) NSING = J - 1 + IF (NSING .LT. N) WA(J) = ZERO + 110 CONTINUE + IF (NSING .LT. 1) GO TO 150 + DO 140 K = 1, NSING + J = NSING - K + 1 + SUM = ZERO + JP1 = J + 1 + IF (NSING .LT. JP1) GO TO 130 + DO 120 I = JP1, NSING + SUM = SUM + R(I,J)*WA(I) + 120 CONTINUE + 130 CONTINUE + WA(J) = (WA(J) - SUM)/SDIAG(J) + 140 CONTINUE + 150 CONTINUE +C +C PERMUTE THE COMPONENTS OF Z BACK TO COMPONENTS OF X. +C + DO 160 J = 1, N + L = IPVT(J) + X(L) = WA(J) + 160 CONTINUE + RETURN +C +C LAST CARD OF SUBROUTINE QRSOLV. +C + END + SUBROUTINE RWUPDT(N,R,LDR,W,B,ALPHA,COS,SIN) + INTEGER N,LDR + REAL ALPHA + REAL R(LDR,N),W(N),B(N),COS(N),SIN(N) +C ********** +C +C SUBROUTINE RWUPDT +C +C GIVEN AN N BY N UPPER TRIANGULAR MATRIX R, THIS SUBROUTINE +C COMPUTES THE QR DECOMPOSITION OF THE MATRIX FORMED WHEN A ROW +C IS ADDED TO R. IF THE ROW IS SPECIFIED BY THE VECTOR W, THEN +C RWUPDT DETERMINES AN ORTHOGONAL MATRIX Q SUCH THAT WHEN THE +C N+1 BY N MATRIX COMPOSED OF R AUGMENTED BY W IS PREMULTIPLIED +C BY (Q TRANSPOSE), THE RESULTING MATRIX IS UPPER TRAPEZOIDAL. +C THE MATRIX (Q TRANSPOSE) IS THE PRODUCT OF N TRANSFORMATIONS +C +C G(N)*G(N-1)* ... *G(1) +C +C WHERE G(I) IS A GIVENS ROTATION IN THE (I,N+1) PLANE WHICH +C ELIMINATES ELEMENTS IN THE (N+1)-ST PLANE. RWUPDT ALSO +C COMPUTES THE PRODUCT (Q TRANSPOSE)*C WHERE C IS THE +C (N+1)-VECTOR (B,ALPHA). Q ITSELF IS NOT ACCUMULATED, RATHER +C THE INFORMATION TO RECOVER THE G ROTATIONS IS SUPPLIED. +C +C THE SUBROUTINE STATEMENT IS +C +C SUBROUTINE RWUPDT(N,R,LDR,W,B,ALPHA,COS,SIN) +C +C WHERE +C +C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE ORDER OF R. +C +C R IS AN N BY N ARRAY. ON INPUT THE UPPER TRIANGULAR PART OF +C R MUST CONTAIN THE MATRIX TO BE UPDATED. ON OUTPUT R +C CONTAINS THE UPDATED TRIANGULAR MATRIX. +C +C LDR IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN N +C WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY R. +C +C W IS AN INPUT ARRAY OF LENGTH N WHICH MUST CONTAIN THE ROW +C VECTOR TO BE ADDED TO R. +C +C B IS AN ARRAY OF LENGTH N. ON INPUT B MUST CONTAIN THE +C FIRST N ELEMENTS OF THE VECTOR C. ON OUTPUT B CONTAINS +C THE FIRST N ELEMENTS OF THE VECTOR (Q TRANSPOSE)*C. +C +C ALPHA IS A VARIABLE. ON INPUT ALPHA MUST CONTAIN THE +C (N+1)-ST ELEMENT OF THE VECTOR C. ON OUTPUT ALPHA CONTAINS +C THE (N+1)-ST ELEMENT OF THE VECTOR (Q TRANSPOSE)*C. +C +C COS IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE +C COSINES OF THE TRANSFORMING GIVENS ROTATIONS. +C +C SIN IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE +C SINES OF THE TRANSFORMING GIVENS ROTATIONS. +C +C SUBPROGRAMS CALLED +C +C FORTRAN-SUPPLIED ... ABS,SQRT +C +C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. +C BURTON S. GARBOW, DUDLEY V. GOETSCHEL, KENNETH E. HILLSTROM, +C JORGE J. MORE +C +C ********** + INTEGER I,J,JM1 + REAL COTAN,ONE,P5,P25,ROWJ,TAN,TEMP,ZERO + DATA ONE,P5,P25,ZERO /1.0E0,5.0E-1,2.5E-1,0.0E0/ +C + DO 60 J = 1, N + ROWJ = W(J) + JM1 = J - 1 +C +C APPLY THE PREVIOUS TRANSFORMATIONS TO +C R(I,J), I=1,2,...,J-1, AND TO W(J). +C + IF (JM1 .LT. 1) GO TO 20 + DO 10 I = 1, JM1 + TEMP = COS(I)*R(I,J) + SIN(I)*ROWJ + ROWJ = -SIN(I)*R(I,J) + COS(I)*ROWJ + R(I,J) = TEMP + 10 CONTINUE + 20 CONTINUE +C +C DETERMINE A GIVENS ROTATION WHICH ELIMINATES W(J). +C + COS(J) = ONE + SIN(J) = ZERO + IF (ROWJ .EQ. ZERO) GO TO 50 + IF (ABS(R(J,J)) .GE. ABS(ROWJ)) GO TO 30 + COTAN = R(J,J)/ROWJ + SIN(J) = P5/SQRT(P25+P25*COTAN**2) + COS(J) = SIN(J)*COTAN + GO TO 40 + 30 CONTINUE + TAN = ROWJ/R(J,J) + COS(J) = P5/SQRT(P25+P25*TAN**2) + SIN(J) = COS(J)*TAN + 40 CONTINUE +C +C APPLY THE CURRENT TRANSFORMATION TO R(J,J), B(J), AND ALPHA. +C + R(J,J) = COS(J)*R(J,J) + SIN(J)*ROWJ + TEMP = COS(J)*B(J) + SIN(J)*ALPHA + ALPHA = -SIN(J)*B(J) + COS(J)*ALPHA + B(J) = TEMP + 50 CONTINUE + 60 CONTINUE + RETURN +C +C LAST CARD OF SUBROUTINE RWUPDT. +C + END + SUBROUTINE R1MPYQ(M,N,A,LDA,V,W) + INTEGER M,N,LDA + REAL A(LDA,N),V(N),W(N) +C ********** +C +C SUBROUTINE R1MPYQ +C +C GIVEN AN M BY N MATRIX A, THIS SUBROUTINE COMPUTES A*Q WHERE +C Q IS THE PRODUCT OF 2*(N - 1) TRANSFORMATIONS +C +C GV(N-1)*...*GV(1)*GW(1)*...*GW(N-1) +C +C AND GV(I), GW(I) ARE GIVENS ROTATIONS IN THE (I,N) PLANE WHICH +C ELIMINATE ELEMENTS IN THE I-TH AND N-TH PLANES, RESPECTIVELY. +C Q ITSELF IS NOT GIVEN, RATHER THE INFORMATION TO RECOVER THE +C GV, GW ROTATIONS IS SUPPLIED. +C +C THE SUBROUTINE STATEMENT IS +C +C SUBROUTINE R1MPYQ(M,N,A,LDA,V,W) +C +C WHERE +C +C M IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER +C OF ROWS OF A. +C +C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER +C OF COLUMNS OF A. +C +C A IS AN M BY N ARRAY. ON INPUT A MUST CONTAIN THE MATRIX +C TO BE POSTMULTIPLIED BY THE ORTHOGONAL MATRIX Q +C DESCRIBED ABOVE. ON OUTPUT A*Q HAS REPLACED A. +C +C LDA IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN M +C WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY A. +C +C V IS AN INPUT ARRAY OF LENGTH N. V(I) MUST CONTAIN THE +C INFORMATION NECESSARY TO RECOVER THE GIVENS ROTATION GV(I) +C DESCRIBED ABOVE. +C +C W IS AN INPUT ARRAY OF LENGTH N. W(I) MUST CONTAIN THE +C INFORMATION NECESSARY TO RECOVER THE GIVENS ROTATION GW(I) +C DESCRIBED ABOVE. +C +C SUBROUTINES CALLED +C +C FORTRAN-SUPPLIED ... ABS,SQRT +C +C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. +C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE +C +C ********** + INTEGER I,J,NMJ,NM1 + REAL COS,ONE,SIN,TEMP + DATA ONE /1.0E0/ +C +C APPLY THE FIRST SET OF GIVENS ROTATIONS TO A. +C + NM1 = N - 1 + IF (NM1 .LT. 1) GO TO 50 + DO 20 NMJ = 1, NM1 + J = N - NMJ + IF (ABS(V(J)) .GT. ONE) COS = ONE/V(J) + IF (ABS(V(J)) .GT. ONE) SIN = SQRT(ONE-COS**2) + IF (ABS(V(J)) .LE. ONE) SIN = V(J) + IF (ABS(V(J)) .LE. ONE) COS = SQRT(ONE-SIN**2) + DO 10 I = 1, M + TEMP = COS*A(I,J) - SIN*A(I,N) + A(I,N) = SIN*A(I,J) + COS*A(I,N) + A(I,J) = TEMP + 10 CONTINUE + 20 CONTINUE +C +C APPLY THE SECOND SET OF GIVENS ROTATIONS TO A. +C + DO 40 J = 1, NM1 + IF (ABS(W(J)) .GT. ONE) COS = ONE/W(J) + IF (ABS(W(J)) .GT. ONE) SIN = SQRT(ONE-COS**2) + IF (ABS(W(J)) .LE. ONE) SIN = W(J) + IF (ABS(W(J)) .LE. ONE) COS = SQRT(ONE-SIN**2) + DO 30 I = 1, M + TEMP = COS*A(I,J) + SIN*A(I,N) + A(I,N) = -SIN*A(I,J) + COS*A(I,N) + A(I,J) = TEMP + 30 CONTINUE + 40 CONTINUE + 50 CONTINUE + RETURN +C +C LAST CARD OF SUBROUTINE R1MPYQ. +C + END + SUBROUTINE R1UPDT(M,N,S,LS,U,V,W,SING) + INTEGER M,N,LS + LOGICAL SING + REAL S(LS),U(M),V(N),W(M) +C ********** +C +C SUBROUTINE R1UPDT +C +C GIVEN AN M BY N LOWER TRAPEZOIDAL MATRIX S, AN M-VECTOR U, +C AND AN N-VECTOR V, THE PROBLEM IS TO DETERMINE AN +C ORTHOGONAL MATRIX Q SUCH THAT +C +C T +C (S + U*V )*Q +C +C IS AGAIN LOWER TRAPEZOIDAL. +C +C THIS SUBROUTINE DETERMINES Q AS THE PRODUCT OF 2*(N - 1) +C TRANSFORMATIONS +C +C GV(N-1)*...*GV(1)*GW(1)*...*GW(N-1) +C +C WHERE GV(I), GW(I) ARE GIVENS ROTATIONS IN THE (I,N) PLANE +C WHICH ELIMINATE ELEMENTS IN THE I-TH AND N-TH PLANES, +C RESPECTIVELY. Q ITSELF IS NOT ACCUMULATED, RATHER THE +C INFORMATION TO RECOVER THE GV, GW ROTATIONS IS RETURNED. +C +C THE SUBROUTINE STATEMENT IS +C +C SUBROUTINE R1UPDT(M,N,S,LS,U,V,W,SING) +C +C WHERE +C +C M IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER +C OF ROWS OF S. +C +C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER +C OF COLUMNS OF S. N MUST NOT EXCEED M. +C +C S IS AN ARRAY OF LENGTH LS. ON INPUT S MUST CONTAIN THE LOWER +C TRAPEZOIDAL MATRIX S STORED BY COLUMNS. ON OUTPUT S CONTAINS +C THE LOWER TRAPEZOIDAL MATRIX PRODUCED AS DESCRIBED ABOVE. +C +C LS IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN +C (N*(2*M-N+1))/2. +C +C U IS AN INPUT ARRAY OF LENGTH M WHICH MUST CONTAIN THE +C VECTOR U. +C +C V IS AN ARRAY OF LENGTH N. ON INPUT V MUST CONTAIN THE VECTOR +C V. ON OUTPUT V(I) CONTAINS THE INFORMATION NECESSARY TO +C RECOVER THE GIVENS ROTATION GV(I) DESCRIBED ABOVE. +C +C W IS AN OUTPUT ARRAY OF LENGTH M. W(I) CONTAINS INFORMATION +C NECESSARY TO RECOVER THE GIVENS ROTATION GW(I) DESCRIBED +C ABOVE. +C +C SING IS A LOGICAL OUTPUT VARIABLE. SING IS SET TRUE IF ANY +C OF THE DIAGONAL ELEMENTS OF THE OUTPUT S ARE ZERO. OTHERWISE +C SING IS SET FALSE. +C +C SUBPROGRAMS CALLED +C +C MINPACK-SUPPLIED ... SPMPAR +C +C FORTRAN-SUPPLIED ... ABS,SQRT +C +C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. +C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE, +C JOHN L. NAZARETH +C +C ********** + INTEGER I,J,JJ,L,NMJ,NM1 + REAL COS,COTAN,GIANT,ONE,P5,P25,SIN,TAN,TAU,TEMP,ZERO + REAL SPMPAR + DATA ONE,P5,P25,ZERO /1.0E0,5.0E-1,2.5E-1,0.0E0/ +C +C GIANT IS THE LARGEST MAGNITUDE. +C + GIANT = SPMPAR(3) +C +C INITIALIZE THE DIAGONAL ELEMENT POINTER. +C + JJ = (N*(2*M - N + 1))/2 - (M - N) +C +C MOVE THE NONTRIVIAL PART OF THE LAST COLUMN OF S INTO W. +C + L = JJ + DO 10 I = N, M + W(I) = S(L) + L = L + 1 + 10 CONTINUE +C +C ROTATE THE VECTOR V INTO A MULTIPLE OF THE N-TH UNIT VECTOR +C IN SUCH A WAY THAT A SPIKE IS INTRODUCED INTO W. +C + NM1 = N - 1 + IF (NM1 .LT. 1) GO TO 70 + DO 60 NMJ = 1, NM1 + J = N - NMJ + JJ = JJ - (M - J + 1) + W(J) = ZERO + IF (V(J) .EQ. ZERO) GO TO 50 +C +C DETERMINE A GIVENS ROTATION WHICH ELIMINATES THE +C J-TH ELEMENT OF V. +C + IF (ABS(V(N)) .GE. ABS(V(J))) GO TO 20 + COTAN = V(N)/V(J) + SIN = P5/SQRT(P25+P25*COTAN**2) + COS = SIN*COTAN + TAU = ONE + IF (ABS(COS)*GIANT .GT. ONE) TAU = ONE/COS + GO TO 30 + 20 CONTINUE + TAN = V(J)/V(N) + COS = P5/SQRT(P25+P25*TAN**2) + SIN = COS*TAN + TAU = SIN + 30 CONTINUE +C +C APPLY THE TRANSFORMATION TO V AND STORE THE INFORMATION +C NECESSARY TO RECOVER THE GIVENS ROTATION. +C + V(N) = SIN*V(J) + COS*V(N) + V(J) = TAU +C +C APPLY THE TRANSFORMATION TO S AND EXTEND THE SPIKE IN W. +C + L = JJ + DO 40 I = J, M + TEMP = COS*S(L) - SIN*W(I) + W(I) = SIN*S(L) + COS*W(I) + S(L) = TEMP + L = L + 1 + 40 CONTINUE + 50 CONTINUE + 60 CONTINUE + 70 CONTINUE +C +C ADD THE SPIKE FROM THE RANK 1 UPDATE TO W. +C + DO 80 I = 1, M + W(I) = W(I) + V(N)*U(I) + 80 CONTINUE +C +C ELIMINATE THE SPIKE. +C + SING = .FALSE. + IF (NM1 .LT. 1) GO TO 140 + DO 130 J = 1, NM1 + IF (W(J) .EQ. ZERO) GO TO 120 +C +C DETERMINE A GIVENS ROTATION WHICH ELIMINATES THE +C J-TH ELEMENT OF THE SPIKE. +C + IF (ABS(S(JJ)) .GE. ABS(W(J))) GO TO 90 + COTAN = S(JJ)/W(J) + SIN = P5/SQRT(P25+P25*COTAN**2) + COS = SIN*COTAN + TAU = ONE + IF (ABS(COS)*GIANT .GT. ONE) TAU = ONE/COS + GO TO 100 + 90 CONTINUE + TAN = W(J)/S(JJ) + COS = P5/SQRT(P25+P25*TAN**2) + SIN = COS*TAN + TAU = SIN + 100 CONTINUE +C +C APPLY THE TRANSFORMATION TO S AND REDUCE THE SPIKE IN W. +C + L = JJ + DO 110 I = J, M + TEMP = COS*S(L) + SIN*W(I) + W(I) = -SIN*S(L) + COS*W(I) + S(L) = TEMP + L = L + 1 + 110 CONTINUE +C +C STORE THE INFORMATION NECESSARY TO RECOVER THE +C GIVENS ROTATION. +C + W(J) = TAU + 120 CONTINUE +C +C TEST FOR ZERO DIAGONAL ELEMENTS IN THE OUTPUT S. +C + IF (S(JJ) .EQ. ZERO) SING = .TRUE. + JJ = JJ + (M - J + 1) + 130 CONTINUE + 140 CONTINUE +C +C MOVE W BACK INTO THE LAST COLUMN OF THE OUTPUT S. +C + L = JJ + DO 150 I = N, M + S(L) = W(I) + L = L + 1 + 150 CONTINUE + IF (S(JJ) .EQ. ZERO) SING = .TRUE. + RETURN +C +C LAST CARD OF SUBROUTINE R1UPDT. +C + END diff --git a/ex/file03 b/ex/file03 new file mode 100644 index 0000000..bd737ec --- /dev/null +++ b/ex/file03 @@ -0,0 +1,3526 @@ +1 +0 Page +0 Documentation for MINPACK subroutine HYBRD1 +0 Single precision version +0 Argonne National Laboratory +0 Burton S. Garbow, Kenneth E. Hillstrom, Jorge J. More +0 March 1980 +0 + 1. Purpose. +0 The purpose of HYBRD1 is to find a zero of a system of N non- + linear functions in N variables by a modification of the Powell + hybrid method. This is done by using the more general nonlinea + equation solver HYBRD. The user must provide a subroutine whic + calculates the functions. The Jacobian is then calculated by a + forward-difference approximation. +0 + 2. Subroutine and type statements. +0 SUBROUTINE HYBRD1(FCN,N,X,FVEC,TOL,INFO,WA,LWA) + INTEGER N,INFO,LWA + REAL TOL + REAL X(N),FVEC(N),WA(LWA) + EXTERNAL FCN +0 + 3. Parameters. +0 Parameters designated as input parameters must be specified on + entry to HYBRD1 and are not changed on exit, while parameters + designated as output parameters need not be specified on entry + and are set to appropriate values on exit from HYBRD1. +0 FCN is the name of the user-supplied subroutine which calculate + the functions. FCN must be declared in an EXTERNAL statement + in the user calling program, and should be written as follows +0 SUBROUTINE FCN(N,X,FVEC,IFLAG) + INTEGER N,IFLAG + REAL X(N),FVEC(N) + ---------- + CALCULATE THE FUNCTIONS AT X AND + RETURN THIS VECTOR IN FVEC. + ---------- + RETURN + END +0 The value of IFLAG should not be changed by FCN unless the + user wants to terminate execution of HYBRD1. In this case se + IFLAG to a negative integer. +1 +0 Page +0 N is a positive integer input variable set to the number of + functions and variables. +0 X is an array of length N. On input X must contain an initial + estimate of the solution vector. On output X contains the + final estimate of the solution vector. +0 FVEC is an output array of length N which contains the function + evaluated at the output X. +0 TOL is a nonnegative input variable. Termination occurs when + the algorithm estimates that the relative error between X and + the solution is at most TOL. Section 4 contains more details + about TOL. +0 INFO is an integer output variable. If the user has terminated + execution, INFO is set to the (negative) value of IFLAG. See + description of FCN. Otherwise, INFO is set as follows. +0 INFO = 0 Improper input parameters. +0 INFO = 1 Algorithm estimates that the relative error between + X and the solution is at most TOL. +0 INFO = 2 Number of calls to FCN has reached or exceeded + 200*(N+1). +0 INFO = 3 TOL is too small. No further improvement in the + approximate solution X is possible. +0 INFO = 4 Iteration is not making good progress. +0 Sections 4 and 5 contain more details about INFO. +0 WA is a work array of length LWA. +0 LWA is a positive integer input variable not less than + (N*(3*N+13))/2. +0 + 4. Successful completion. +0 The accuracy of HYBRD1 is controlled by the convergence parame- + ter TOL. This parameter is used in a test which makes a compar + ison between the approximation X and a solution XSOL. HYBRD1 + terminates when the test is satisfied. If TOL is less than the + machine precision (as defined by the MINPACK function + SPMPAR(1)), then HYBRD1 only attempts to satisfy the test + defined by the machine precision. Further progress is not usu- + ally possible. Unless high precision solutions are required, + the recommended value for TOL is the square root of the machine + precision. +0 The test assumes that the functions are reasonably well behaved +1 +0 Page +0 If this condition is not satisfied, then HYBRD1 may incorrectly + indicate convergence. The validity of the answer can be + checked, for example, by rerunning HYBRD1 with a tighter toler- + ance. +0 Convergence test. If ENORM(Z) denotes the Euclidean norm of a + vector Z, then this test attempts to guarantee that +0 ENORM(X-XSOL) .LE. TOL*ENORM(XSOL). +0 If this condition is satisfied with TOL = 10**(-K), then the + larger components of X have K significant decimal digits and + INFO is set to 1. There is a danger that the smaller compo- + nents of X may have large relative errors, but the fast rate + of convergence of HYBRD1 usually avoids this possibility. +0 + 5. Unsuccessful completion. +0 Unsuccessful termination of HYBRD1 can be due to improper input + parameters, arithmetic interrupts, an excessive number of func- + tion evaluations, errors in the functions, or lack of good prog + ress. +0 Improper input parameters. INFO is set to 0 if N .LE. 0, or + TOL .LT. 0.E0, or LWA .LT. (N*(3*N+13))/2. +0 Arithmetic interrupts. If these interrupts occur in the FCN + subroutine during an early stage of the computation, they may + be caused by an unacceptable choice of X by HYBRD1. In this + case, it may be possible to remedy the situation by not evalu + ating the functions here, but instead setting the components + of FVEC to numbers that exceed those in the initial FVEC, + thereby indirectly reducing the step length. The step length + can be more directly controlled by using instead HYBRD, which + includes in its calling sequence the step-length- governing + parameter FACTOR. +0 Excessive number of function evaluations. If the number of + calls to FCN reaches 200*(N+1), then this indicates that the + routine is converging very slowly as measured by the progress + of FVEC, and INFO is set to 2. This situation should be unu- + sual because, as indicated below, lack of good progress is + usually diagnosed earlier by HYBRD1, causing termination with + INFO = 4. +0 Errors in the functions. The choice of step length in the for- + ward-difference approximation to the Jacobian assumes that th + relative errors in the functions are of the order of the + machine precision. If this is not the case, HYBRD1 may fail + (usually with INFO = 4). The user should then use HYBRD + instead, or one of the programs which require the analytic + Jacobian (HYBRJ1 and HYBRJ). +1 +0 Page +0 Lack of good progress. HYBRD1 searches for a zero of the syste + by minimizing the sum of the squares of the functions. In so + doing, it can become trapped in a region where the minimum + does not correspond to a zero of the system and, in this situ + ation, the iteration eventually fails to make good progress. + In particular, this will happen if the system does not have a + zero. If the system has a zero, rerunning HYBRD1 from a dif- + ferent starting point may be helpful. +0 + 6. Characteristics of the algorithm. +0 HYBRD1 is a modification of the Powell hybrid method. Two of + its main characteristics involve the choice of the correction a + a convex combination of the Newton and scaled gradient direc- + tions, and the updating of the Jacobian by the rank-1 method of + Broyden. The choice of the correction guarantees (under reason + able conditions) global convergence for starting points far fro + the solution and a fast rate of convergence. The Jacobian is + approximated by forward differences at the starting point, but + forward differences are not used again until the rank-1 method + fails to produce satisfactory progress. +0 Timing. The time required by HYBRD1 to solve a given problem + depends on N, the behavior of the functions, the accuracy + requested, and the starting point. The number of arithmetic + operations needed by HYBRD1 is about 11.5*(N**2) to process + each call to FCN. Unless FCN can be evaluated quickly, the + timing of HYBRD1 will be strongly influenced by the time spen + in FCN. +0 Storage. HYBRD1 requires (3*N**2 + 17*N)/2 single precision + storage locations, in addition to the storage required by the + program. There are no internally declared storage arrays. +0 + 7. Subprograms required. +0 USER-supplied ...... FCN +0 MINPACK-supplied ... DOGLEG,SPMPAR,ENORM,FDJAC1,HYBRD, + QFORM,QRFAC,R1MPYQ,R1UPDT +0 FORTRAN-supplied ... ABS,AMAX1,AMIN1,SQRT,MIN0,MOD +0 + 8. References. +0 M. J. D. Powell, A Hybrid Method for Nonlinear Equations. + Numerical Methods for Nonlinear Algebraic Equations, + P. Rabinowitz, editor. Gordon and Breach, 1970. +0 + 9. Example. +1 +0 Page +0 The problem is to determine the values of x(1), x(2), ..., x(9) + which solve the system of tridiagonal equations +0 (3-2*x(1))*x(1) -2*x(2) = -1 + -x(i-1) + (3-2*x(i))*x(i) -2*x(i+1) = -1, i=2-8 + -x(8) + (3-2*x(9))*x(9) = -1 +0 C ********** + C + C DRIVER FOR HYBRD1 EXAMPLE. + C SINGLE PRECISION VERSION + C + C ********** + INTEGER J,N,INFO,LWA,NWRITE + REAL TOL,FNORM + REAL X(9),FVEC(9),WA(180) + REAL ENORM,SPMPAR + EXTERNAL FCN + C + C LOGICAL OUTPUT UNIT IS ASSUMED TO BE NUMBER 6. + C + DATA NWRITE /6/ + C + N = 9 + C + C THE FOLLOWING STARTING VALUES PROVIDE A ROUGH SOLUTION. + C + DO 10 J = 1, 9 + X(J) = -1.E0 + 10 CONTINUE + C + LWA = 180 + C + C SET TOL TO THE SQUARE ROOT OF THE MACHINE PRECISION. + C UNLESS HIGH PRECISION SOLUTIONS ARE REQUIRED, + C THIS IS THE RECOMMENDED SETTING. + C + TOL = SQRT(SPMPAR(1)) + C + CALL HYBRD1(FCN,N,X,FVEC,TOL,INFO,WA,LWA) + FNORM = ENORM(N,FVEC) + WRITE (NWRITE,1000) FNORM,INFO,(X(J),J=1,N) + STOP + 1000 FORMAT (5X,31H FINAL L2 NORM OF THE RESIDUALS,E15.7 // + * 5X,15H EXIT PARAMETER,16X,I10 // + * 5X,27H FINAL APPROXIMATE SOLUTION // (5X,3E15.7)) + C + C LAST CARD OF DRIVER FOR HYBRD1 EXAMPLE. + C + END + SUBROUTINE FCN(N,X,FVEC,IFLAG) + INTEGER N,IFLAG + REAL X(N),FVEC(N) + C +1 +0 Page +0 C SUBROUTINE FCN FOR HYBRD1 EXAMPLE. + C + INTEGER K + REAL ONE,TEMP,TEMP1,TEMP2,THREE,TWO,ZERO + DATA ZERO,ONE,TWO,THREE /0.E0,1.E0,2.E0,3.E0/ + C + DO 10 K = 1, N + TEMP = (THREE - TWO*X(K))*X(K) + TEMP1 = ZERO + IF (K .NE. 1) TEMP1 = X(K-1) + TEMP2 = ZERO + IF (K .NE. N) TEMP2 = X(K+1) + FVEC(K) = TEMP - TEMP1 - TWO*TEMP2 + ONE + 10 CONTINUE + RETURN + C + C LAST CARD OF SUBROUTINE FCN. + C + END +0 Results obtained with different compilers or machines + may be slightly different. +0 FINAL L2 NORM OF THE RESIDUALS 0.1192636E-07 +0 EXIT PARAMETER 1 +0 FINAL APPROXIMATE SOLUTION +0 -0.5706545E+00 -0.6816283E+00 -0.7017325E+00 + -0.7042129E+00 -0.7013690E+00 -0.6918656E+00 + -0.6657920E+00 -0.5960342E+00 -0.4164121E+00 +1 +0 +1 +0 Page +0 Documentation for MINPACK subroutine HYBRD +0 Single precision version +0 Argonne National Laboratory +0 Burton S. Garbow, Kenneth E. Hillstrom, Jorge J. More +0 March 1980 +0 + 1. Purpose. +0 The purpose of HYBRD is to find a zero of a system of N non- + linear functions in N variables by a modification of the Powell + hybrid method. The user must provide a subroutine which calcu- + lates the functions. The Jacobian is then calculated by a for- + ward-difference approximation. +0 + 2. Subroutine and type statements. +0 SUBROUTINE HYBRD(FCN,N,X,FVEC,XTOL,MAXFEV,ML,MU,EPSFCN,DIAG, + * MODE,FACTOR,NPRINT,INFO,NFEV,FJAC,LDFJAC, + * R,LR,QTF,WA1,WA2,WA3,WA4) + INTEGER N,MAXFEV,ML,MU,MODE,NPRINT,INFO,NFEV,LDFJAC,LR + REAL XTOL,EPSFCN,FACTOR + REAL X(N),FVEC(N),DIAG(N),FJAC(LDFJAC,N),R(LR),QTF(N), + * WA1(N),WA2(N),WA3(N),WA4(N) + EXTERNAL FCN +0 + 3. Parameters. +0 Parameters designated as input parameters must be specified on + entry to HYBRD and are not changed on exit, while parameters + designated as output parameters need not be specified on entry + and are set to appropriate values on exit from HYBRD. +0 FCN is the name of the user-supplied subroutine which calculate + the functions. FCN must be declared in an EXTERNAL statement + in the user calling program, and should be written as follows +0 SUBROUTINE FCN(N,X,FVEC,IFLAG) + INTEGER N,IFLAG + REAL X(N),FVEC(N) + ---------- + CALCULATE THE FUNCTIONS AT X AND + RETURN THIS VECTOR IN FVEC. + ---------- + RETURN + END +0 The value of IFLAG should not be changed by FCN unless the +1 +0 Page +0 user wants to terminate execution of HYBRD. In this case set + IFLAG to a negative integer. +0 N is a positive integer input variable set to the number of + functions and variables. +0 X is an array of length N. On input X must contain an initial + estimate of the solution vector. On output X contains the + final estimate of the solution vector. +0 FVEC is an output array of length N which contains the function + evaluated at the output X. +0 XTOL is a nonnegative input variable. Termination occurs when + the relative error between two consecutive iterates is at mos + XTOL. Therefore, XTOL measures the relative error desired in + the approximate solution. Section 4 contains more details + about XTOL. +0 MAXFEV is a positive integer input variable. Termination occur + when the number of calls to FCN is at least MAXFEV by the end + of an iteration. +0 ML is a nonnegative integer input variable which specifies the + number of subdiagonals within the band of the Jacobian matrix + If the Jacobian is not banded, set ML to at least N - 1. +0 MU is a nonnegative integer input variable which specifies the + number of superdiagonals within the band of the Jacobian + matrix. If the Jacobian is not banded, set MU to at least + N - 1. +0 EPSFCN is an input variable used in determining a suitable step + for the forward-difference approximation. This approximation + assumes that the relative errors in the functions are of the + order of EPSFCN. If EPSFCN is less than the machine preci- + sion, it is assumed that the relative errors in the functions + are of the order of the machine precision. +0 DIAG is an array of length N. If MODE = 1 (see below), DIAG is + internally set. If MODE = 2, DIAG must contain positive + entries that serve as multiplicative scale factors for the + variables. +0 MODE is an integer input variable. If MODE = 1, the variables + will be scaled internally. If MODE = 2, the scaling is speci + fied by the input DIAG. Other values of MODE are equivalent + to MODE = 1. +0 FACTOR is a positive input variable used in determining the ini + tial step bound. This bound is set to the product of FACTOR + and the Euclidean norm of DIAG*X if nonzero, or else to FACTO + itself. In most cases FACTOR should lie in the interval + (.1,100.). 100. is a generally recommended value. +1 +0 Page +0 NPRINT is an integer input variable that enables controlled + printing of iterates if it is positive. In this case, FCN is + called with IFLAG = 0 at the beginning of the first iteration + and every NPRINT iterations thereafter and immediately prior + to return, with X and FVEC available for printing. If NPRINT + is not positive, no special calls of FCN with IFLAG = 0 are + made. +0 INFO is an integer output variable. If the user has terminated + execution, INFO is set to the (negative) value of IFLAG. See + description of FCN. Otherwise, INFO is set as follows. +0 INFO = 0 Improper input parameters. +0 INFO = 1 Relative error between two consecutive iterates is + at most XTOL. +0 INFO = 2 Number of calls to FCN has reached or exceeded + MAXFEV. +0 INFO = 3 XTOL is too small. No further improvement in the + approximate solution X is possible. +0 INFO = 4 Iteration is not making good progress, as measured + by the improvement from the last five Jacobian eval + uations. +0 INFO = 5 Iteration is not making good progress, as measured + by the improvement from the last ten iterations. +0 Sections 4 and 5 contain more details about INFO. +0 NFEV is an integer output variable set to the number of calls t + FCN. +0 FJAC is an output N by N array which contains the orthogonal + matrix Q produced by the QR factorization of the final approx + imate Jacobian. +0 LDFJAC is a positive integer input variable not less than N + which specifies the leading dimension of the array FJAC. +0 R is an output array of length LR which contains the upper + triangular matrix produced by the QR factorization of the + final approximate Jacobian, stored rowwise. +0 LR is a positive integer input variable not less than + (N*(N+1))/2. +0 QTF is an output array of length N which contains the vector + (Q transpose)*FVEC. +0 WA1, WA2, WA3, and WA4 are work arrays of length N. +1 +0 Page +0 + 4. Successful completion. +0 The accuracy of HYBRD is controlled by the convergence paramete + XTOL. This parameter is used in a test which makes a compariso + between the approximation X and a solution XSOL. HYBRD termi- + nates when the test is satisfied. If the convergence parameter + is less than the machine precision (as defined by the MINPACK + function SPMPAR(1)), then HYBRD only attempts to satisfy the + test defined by the machine precision. Further progress is not + usually possible. +0 The test assumes that the functions are reasonably well behaved + If this condition is not satisfied, then HYBRD may incorrectly + indicate convergence. The validity of the answer can be + checked, for example, by rerunning HYBRD with a tighter toler- + ance. +0 Convergence test. If ENORM(Z) denotes the Euclidean norm of a + vector Z and D is the diagonal matrix whose entries are + defined by the array DIAG, then this test attempts to guaran- + tee that +0 ENORM(D*(X-XSOL)) .LE. XTOL*ENORM(D*XSOL). +0 If this condition is satisfied with XTOL = 10**(-K), then the + larger components of D*X have K significant decimal digits an + INFO is set to 1. There is a danger that the smaller compo- + nents of D*X may have large relative errors, but the fast rat + of convergence of HYBRD usually avoids this possibility. + Unless high precision solutions are required, the recommended + value for XTOL is the square root of the machine precision. +0 + 5. Unsuccessful completion. +0 Unsuccessful termination of HYBRD can be due to improper input + parameters, arithmetic interrupts, an excessive number of func- + tion evaluations, or lack of good progress. +0 Improper input parameters. INFO is set to 0 if N .LE. 0, or + XTOL .LT. 0.E0, or MAXFEV .LE. 0, or ML .LT. 0, or MU .LT. 0, + or FACTOR .LE. 0.E0, or LDFJAC .LT. N, or LR .LT. (N*(N+1))/2 +0 Arithmetic interrupts. If these interrupts occur in the FCN + subroutine during an early stage of the computation, they may + be caused by an unacceptable choice of X by HYBRD. In this + case, it may be possible to remedy the situation by rerunning + HYBRD with a smaller value of FACTOR. +0 Excessive number of function evaluations. A reasonable value + for MAXFEV is 200*(N+1). If the number of calls to FCN + reaches MAXFEV, then this indicates that the routine is con- + verging very slowly as measured by the progress of FVEC, and +1 +0 Page +0 INFO is set to 2. This situation should be unusual because, + as indicated below, lack of good progress is usually diagnose + earlier by HYBRD, causing termination with INFO = 4 or + INFO = 5. +0 Lack of good progress. HYBRD searches for a zero of the system + by minimizing the sum of the squares of the functions. In so + doing, it can become trapped in a region where the minimum + does not correspond to a zero of the system and, in this situ + ation, the iteration eventually fails to make good progress. + In particular, this will happen if the system does not have a + zero. If the system has a zero, rerunning HYBRD from a dif- + ferent starting point may be helpful. +0 + 6. Characteristics of the algorithm. +0 HYBRD is a modification of the Powell hybrid method. Two of it + main characteristics involve the choice of the correction as a + convex combination of the Newton and scaled gradient directions + and the updating of the Jacobian by the rank-1 method of Broy- + den. The choice of the correction guarantees (under reasonable + conditions) global convergence for starting points far from the + solution and a fast rate of convergence. The Jacobian is + approximated by forward differences at the starting point, but + forward differences are not used again until the rank-1 method + fails to produce satisfactory progress. +0 Timing. The time required by HYBRD to solve a given problem + depends on N, the behavior of the functions, the accuracy + requested, and the starting point. The number of arithmetic + operations needed by HYBRD is about 11.5*(N**2) to process + each call to FCN. Unless FCN can be evaluated quickly, the + timing of HYBRD will be strongly influenced by the time spent + in FCN. +0 Storage. HYBRD requires (3*N**2 + 17*N)/2 single precision + storage locations, in addition to the storage required by the + program. There are no internally declared storage arrays. +0 + 7. Subprograms required. +0 USER-supplied ...... FCN +0 MINPACK-supplied ... DOGLEG,SPMPAR,ENORM,FDJAC1, + QFORM,QRFAC,R1MPYQ,R1UPDT +0 FORTRAN-supplied ... ABS,AMAX1,AMIN1,SQRT,MIN0,MOD +0 + 8. References. +0 M. J. D. Powell, A Hybrid Method for Nonlinear Equations. +1 +0 Page +0 Numerical Methods for Nonlinear Algebraic Equations, + P. Rabinowitz, editor. Gordon and Breach, 1970. +0 + 9. Example. +0 The problem is to determine the values of x(1), x(2), ..., x(9) + which solve the system of tridiagonal equations +0 (3-2*x(1))*x(1) -2*x(2) = -1 + -x(i-1) + (3-2*x(i))*x(i) -2*x(i+1) = -1, i=2-8 + -x(8) + (3-2*x(9))*x(9) = -1 +0 C ********** + C + C DRIVER FOR HYBRD EXAMPLE. + C SINGLE PRECISION VERSION + C + C ********** + INTEGER J,N,MAXFEV,ML,MU,MODE,NPRINT,INFO,NFEV,LDFJAC,LR,NWRITE + REAL XTOL,EPSFCN,FACTOR,FNORM + REAL X(9),FVEC(9),DIAG(9),FJAC(9,9),R(45),QTF(9), + * WA1(9),WA2(9),WA3(9),WA4(9) + REAL ENORM,SPMPAR + EXTERNAL FCN + C + C LOGICAL OUTPUT UNIT IS ASSUMED TO BE NUMBER 6. + C + DATA NWRITE /6/ + C + N = 9 + C + C THE FOLLOWING STARTING VALUES PROVIDE A ROUGH SOLUTION. + C + DO 10 J = 1, 9 + X(J) = -1.E0 + 10 CONTINUE + C + LDFJAC = 9 + LR = 45 + C + C SET XTOL TO THE SQUARE ROOT OF THE MACHINE PRECISION. + C UNLESS HIGH PRECISION SOLUTIONS ARE REQUIRED, + C THIS IS THE RECOMMENDED SETTING. + C + XTOL = SQRT(SPMPAR(1)) + C + MAXFEV = 2000 + ML = 1 + MU = 1 + EPSFCN = 0.E0 + MODE = 2 + DO 20 J = 1, 9 + DIAG(J) = 1.E0 +1 +0 Page +0 20 CONTINUE + FACTOR = 1.E2 + NPRINT = 0 + C + CALL HYBRD(FCN,N,X,FVEC,XTOL,MAXFEV,ML,MU,EPSFCN,DIAG, + * MODE,FACTOR,NPRINT,INFO,NFEV,FJAC,LDFJAC, + * R,LR,QTF,WA1,WA2,WA3,WA4) + FNORM = ENORM(N,FVEC) + WRITE (NWRITE,1000) FNORM,NFEV,INFO,(X(J),J=1,N) + STOP + 1000 FORMAT (5X,31H FINAL L2 NORM OF THE RESIDUALS,E15.7 // + * 5X,31H NUMBER OF FUNCTION EVALUATIONS,I10 // + * 5X,15H EXIT PARAMETER,16X,I10 // + * 5X,27H FINAL APPROXIMATE SOLUTION // (5X,3E15.7)) + C + C LAST CARD OF DRIVER FOR HYBRD EXAMPLE. + C + END + SUBROUTINE FCN(N,X,FVEC,IFLAG) + INTEGER N,IFLAG + REAL X(N),FVEC(N) + C + C SUBROUTINE FCN FOR HYBRD EXAMPLE. + C + INTEGER K + REAL ONE,TEMP,TEMP1,TEMP2,THREE,TWO,ZERO + DATA ZERO,ONE,TWO,THREE /0.E0,1.E0,2.E0,3.E0/ + C + IF (IFLAG .NE. 0) GO TO 5 + C + C INSERT PRINT STATEMENTS HERE WHEN NPRINT IS POSITIVE. + C + RETURN + 5 CONTINUE + DO 10 K = 1, N + TEMP = (THREE - TWO*X(K))*X(K) + TEMP1 = ZERO + IF (K .NE. 1) TEMP1 = X(K-1) + TEMP2 = ZERO + IF (K .NE. N) TEMP2 = X(K+1) + FVEC(K) = TEMP - TEMP1 - TWO*TEMP2 + ONE + 10 CONTINUE + RETURN + C + C LAST CARD OF SUBROUTINE FCN. + C + END +0 Results obtained with different compilers or machines + may be slightly different. +0 FINAL L2 NORM OF THE RESIDUALS 0.1192636E-07 +0 NUMBER OF FUNCTION EVALUATIONS 14 +1 +0 Page +0 EXIT PARAMETER 1 +0 FINAL APPROXIMATE SOLUTION +0 -0.5706545E+00 -0.6816283E+00 -0.7017325E+00 + -0.7042129E+00 -0.7013690E+00 -0.6918656E+00 + -0.6657920E+00 -0.5960342E+00 -0.4164121E+00 +1 +0 +1 +0 Page +0 Documentation for MINPACK subroutine HYBRJ1 +0 Single precision version +0 Argonne National Laboratory +0 Burton S. Garbow, Kenneth E. Hillstrom, Jorge J. More +0 March 1980 +0 + 1. Purpose. +0 The purpose of HYBRJ1 is to find a zero of a system of N non- + linear functions in N variables by a modification of the Powell + hybrid method. This is done by using the more general nonlinea + equation solver HYBRJ. The user must provide a subroutine whic + calculates the functions and the Jacobian. +0 + 2. Subroutine and type statements. +0 SUBROUTINE HYBRJ1(FCN,N,X,FVEC,FJAC,LDFJAC,TOL,INFO,WA,LWA) + INTEGER N,LDFJAC,INFO,LWA + REAL TOL + REAL X(N),FVEC(N),FJAC(LDFJAC,N),WA(LWA) + EXTERNAL FCN +0 + 3. Parameters. +0 Parameters designated as input parameters must be specified on + entry to HYBRJ1 and are not changed on exit, while parameters + designated as output parameters need not be specified on entry + and are set to appropriate values on exit from HYBRJ1. +0 FCN is the name of the user-supplied subroutine which calculate + the functions and the Jacobian. FCN must be declared in an + EXTERNAL statement in the user calling program, and should be + written as follows. +0 SUBROUTINE FCN(N,X,FVEC,FJAC,LDFJAC,IFLAG) + INTEGER N,LDFJAC,IFLAG + REAL X(N),FVEC(N),FJAC(LDFJAC,N) + ---------- + IF IFLAG = 1 CALCULATE THE FUNCTIONS AT X AND + RETURN THIS VECTOR IN FVEC. DO NOT ALTER FJAC. + IF IFLAG = 2 CALCULATE THE JACOBIAN AT X AND + RETURN THIS MATRIX IN FJAC. DO NOT ALTER FVEC. + ---------- + RETURN + END +0 The value of IFLAG should not be changed by FCN unless the +1 +0 Page +0 user wants to terminate execution of HYBRJ1. In this case se + IFLAG to a negative integer. +0 N is a positive integer input variable set to the number of + functions and variables. +0 X is an array of length N. On input X must contain an initial + estimate of the solution vector. On output X contains the + final estimate of the solution vector. +0 FVEC is an output array of length N which contains the function + evaluated at the output X. +0 FJAC is an output N by N array which contains the orthogonal + matrix Q produced by the QR factorization of the final approx + imate Jacobian. Section 6 contains more details about the + approximation to the Jacobian. +0 LDFJAC is a positive integer input variable not less than N + which specifies the leading dimension of the array FJAC. +0 TOL is a nonnegative input variable. Termination occurs when + the algorithm estimates that the relative error between X and + the solution is at most TOL. Section 4 contains more details + about TOL. +0 INFO is an integer output variable. If the user has terminated + execution, INFO is set to the (negative) value of IFLAG. See + description of FCN. Otherwise, INFO is set as follows. +0 INFO = 0 Improper input parameters. +0 INFO = 1 Algorithm estimates that the relative error between + X and the solution is at most TOL. +0 INFO = 2 Number of calls to FCN with IFLAG = 1 has reached + 100*(N+1). +0 INFO = 3 TOL is too small. No further improvement in the + approximate solution X is possible. +0 INFO = 4 Iteration is not making good progress. +0 Sections 4 and 5 contain more details about INFO. +0 WA is a work array of length LWA. +0 LWA is a positive integer input variable not less than + (N*(N+13))/2. +0 + 4. Successful completion. +0 The accuracy of HYBRJ1 is controlled by the convergence +1 +0 Page +0 parameter TOL. This parameter is used in a test which makes a + comparison between the approximation X and a solution XSOL. + HYBRJ1 terminates when the test is satisfied. If TOL is less + than the machine precision (as defined by the MINPACK function + SPMPAR(1)), then HYBRJ1 only attempts to satisfy the test + defined by the machine precision. Further progress is not usu- + ally possible. Unless high precision solutions are required, + the recommended value for TOL is the square root of the machine + precision. +0 The test assumes that the functions and the Jacobian are coded + consistently, and that the functions are reasonably well + behaved. If these conditions are not satisfied, then HYBRJ1 ma + incorrectly indicate convergence. The coding of the Jacobian + can be checked by the MINPACK subroutine CHKDER. If the Jaco- + bian is coded correctly, then the validity of the answer can be + checked, for example, by rerunning HYBRJ1 with a tighter toler- + ance. +0 Convergence test. If ENORM(Z) denotes the Euclidean norm of a + vector Z, then this test attempts to guarantee that +0 ENORM(X-XSOL) .LE. TOL*ENORM(XSOL). +0 If this condition is satisfied with TOL = 10**(-K), then the + larger components of X have K significant decimal digits and + INFO is set to 1. There is a danger that the smaller compo- + nents of X may have large relative errors, but the fast rate + of convergence of HYBRJ1 usually avoids this possibility. +0 + 5. Unsuccessful completion. +0 Unsuccessful termination of HYBRJ1 can be due to improper input + parameters, arithmetic interrupts, an excessive number of func- + tion evaluations, or lack of good progress. +0 Improper input parameters. INFO is set to 0 if N .LE. 0, or + LDFJAC .LT. N, or TOL .LT. 0.E0, or LWA .LT. (N*(N+13))/2. +0 Arithmetic interrupts. If these interrupts occur in the FCN + subroutine during an early stage of the computation, they may + be caused by an unacceptable choice of X by HYBRJ1. In this + case, it may be possible to remedy the situation by not evalu + ating the functions here, but instead setting the components + of FVEC to numbers that exceed those in the initial FVEC, + thereby indirectly reducing the step length. The step length + can be more directly controlled by using instead HYBRJ, which + includes in its calling sequence the step-length- governing + parameter FACTOR. +0 Excessive number of function evaluations. If the number of + calls to FCN with IFLAG = 1 reaches 100*(N+1), then this indi + cates that the routine is converging very slowly as measured +1 +0 Page +0 by the progress of FVEC, and INFO is set to 2. This situatio + should be unusual because, as indicated below, lack of good + progress is usually diagnosed earlier by HYBRJ1, causing ter- + mination with INFO = 4. +0 Lack of good progress. HYBRJ1 searches for a zero of the syste + by minimizing the sum of the squares of the functions. In so + doing, it can become trapped in a region where the minimum + does not correspond to a zero of the system and, in this situ + ation, the iteration eventually fails to make good progress. + In particular, this will happen if the system does not have a + zero. If the system has a zero, rerunning HYBRJ1 from a dif- + ferent starting point may be helpful. +0 + 6. Characteristics of the algorithm. +0 HYBRJ1 is a modification of the Powell hybrid method. Two of + its main characteristics involve the choice of the correction a + a convex combination of the Newton and scaled gradient direc- + tions, and the updating of the Jacobian by the rank-1 method of + Broyden. The choice of the correction guarantees (under reason + able conditions) global convergence for starting points far fro + the solution and a fast rate of convergence. The Jacobian is + calculated at the starting point, but it is not recalculated + until the rank-1 method fails to produce satisfactory progress. +0 Timing. The time required by HYBRJ1 to solve a given problem + depends on N, the behavior of the functions, the accuracy + requested, and the starting point. The number of arithmetic + operations needed by HYBRJ1 is about 11.5*(N**2) to process + each evaluation of the functions (call to FCN with IFLAG = 1) + and 1.3*(N**3) to process each evaluation of the Jacobian + (call to FCN with IFLAG = 2). Unless FCN can be evaluated + quickly, the timing of HYBRJ1 will be strongly influenced by + the time spent in FCN. +0 Storage. HYBRJ1 requires (3*N**2 + 17*N)/2 single precision + storage locations, in addition to the storage required by the + program. There are no internally declared storage arrays. +0 + 7. Subprograms required. +0 USER-supplied ...... FCN +0 MINPACK-supplied ... DOGLEG,SPMPAR,ENORM,HYBRJ, + QFORM,QRFAC,R1MPYQ,R1UPDT +0 FORTRAN-supplied ... ABS,AMAX1,AMIN1,SQRT,MIN0,MOD +0 + 8. References. +1 +0 Page +0 M. J. D. Powell, A Hybrid Method for Nonlinear Equations. + Numerical Methods for Nonlinear Algebraic Equations, + P. Rabinowitz, editor. Gordon and Breach, 1970. +0 + 9. Example. +0 The problem is to determine the values of x(1), x(2), ..., x(9) + which solve the system of tridiagonal equations +0 (3-2*x(1))*x(1) -2*x(2) = -1 + -x(i-1) + (3-2*x(i))*x(i) -2*x(i+1) = -1, i=2-8 + -x(8) + (3-2*x(9))*x(9) = -1 +0 C ********** + C + C DRIVER FOR HYBRJ1 EXAMPLE. + C SINGLE PRECISION VERSION + C + C ********** + INTEGER J,N,LDFJAC,INFO,LWA,NWRITE + REAL TOL,FNORM + REAL X(9),FVEC(9),FJAC(9,9),WA(99) + REAL ENORM,SPMPAR + EXTERNAL FCN + C + C LOGICAL OUTPUT UNIT IS ASSUMED TO BE NUMBER 6. + C + DATA NWRITE /6/ + C + N = 9 + C + C THE FOLLOWING STARTING VALUES PROVIDE A ROUGH SOLUTION. + C + DO 10 J = 1, 9 + X(J) = -1.E0 + 10 CONTINUE + C + LDFJAC = 9 + LWA = 99 + C + C SET TOL TO THE SQUARE ROOT OF THE MACHINE PRECISION. + C UNLESS HIGH PRECISION SOLUTIONS ARE REQUIRED, + C THIS IS THE RECOMMENDED SETTING. + C + TOL = SQRT(SPMPAR(1)) + C + CALL HYBRJ1(FCN,N,X,FVEC,FJAC,LDFJAC,TOL,INFO,WA,LWA) + FNORM = ENORM(N,FVEC) + WRITE (NWRITE,1000) FNORM,INFO,(X(J),J=1,N) + STOP + 1000 FORMAT (5X,31H FINAL L2 NORM OF THE RESIDUALS,E15.7 // + * 5X,15H EXIT PARAMETER,16X,I10 // + * 5X,27H FINAL APPROXIMATE SOLUTION // (5X,3E15.7)) +1 +0 Page +0 C + C LAST CARD OF DRIVER FOR HYBRJ1 EXAMPLE. + C + END + SUBROUTINE FCN(N,X,FVEC,FJAC,LDFJAC,IFLAG) + INTEGER N,LDFJAC,IFLAG + REAL X(N),FVEC(N),FJAC(LDFJAC,N) + C + C SUBROUTINE FCN FOR HYBRJ1 EXAMPLE. + C + INTEGER J,K + REAL ONE,TEMP,TEMP1,TEMP2,THREE,TWO,ZERO + DATA ZERO,ONE,TWO,THREE,FOUR /0.E0,1.E0,2.E0,3.E0,4.E0/ + C + IF (IFLAG .EQ. 2) GO TO 20 + DO 10 K = 1, N + TEMP = (THREE - TWO*X(K))*X(K) + TEMP1 = ZERO + IF (K .NE. 1) TEMP1 = X(K-1) + TEMP2 = ZERO + IF (K .NE. N) TEMP2 = X(K+1) + FVEC(K) = TEMP - TEMP1 - TWO*TEMP2 + ONE + 10 CONTINUE + GO TO 50 + 20 CONTINUE + DO 40 K = 1, N + DO 30 J = 1, N + FJAC(K,J) = ZERO + 30 CONTINUE + FJAC(K,K) = THREE - FOUR*X(K) + IF (K .NE. 1) FJAC(K,K-1) = -ONE + IF (K .NE. N) FJAC(K,K+1) = -TWO + 40 CONTINUE + 50 CONTINUE + RETURN + C + C LAST CARD OF SUBROUTINE FCN. + C + END +0 Results obtained with different compilers or machines + may be slightly different. +0 FINAL L2 NORM OF THE RESIDUALS 0.1192636E-07 +0 EXIT PARAMETER 1 +0 FINAL APPROXIMATE SOLUTION +0 -0.5706545E+00 -0.6816283E+00 -0.7017325E+00 + -0.7042129E+00 -0.7013690E+00 -0.6918656E+00 + -0.6657920E+00 -0.5960342E+00 -0.4164121E+00 +1 +0 +1 +0 Page +0 Documentation for MINPACK subroutine HYBRJ +0 Single precision version +0 Argonne National Laboratory +0 Burton S. Garbow, Kenneth E. Hillstrom, Jorge J. More +0 March 1980 +0 + 1. Purpose. +0 The purpose of HYBRJ is to find a zero of a system of N non- + linear functions in N variables by a modification of the Powell + hybrid method. The user must provide a subroutine which calcu- + lates the functions and the Jacobian. +0 + 2. Subroutine and type statements. +0 SUBROUTINE HYBRJ(FCN,N,X,FVEC,FJAC,LDFJAC,XTOL,MAXFEV,DIAG, + * MODE,FACTOR,NPRINT,INFO,NFEV,NJEV,R,LR,QTF, + * WA1,WA2,WA3,WA4) + INTEGER N,LDFJAC,MAXFEV,MODE,NPRINT,INFO,NFEV,NJEV,LR + REAL XTOL,FACTOR + REAL X(N),FVEC(N),FJAC(LDFJAC,N),DIAG(N),R(LR),QTF(N), + * WA1(N),WA2(N),WA3(N),WA4(N) +0 + 3. Parameters. +0 Parameters designated as input parameters must be specified on + entry to HYBRJ and are not changed on exit, while parameters + designated as output parameters need not be specified on entry + and are set to appropriate values on exit from HYBRJ. +0 FCN is the name of the user-supplied subroutine which calculate + the functions and the Jacobian. FCN must be declared in an + EXTERNAL statement in the user calling program, and should be + written as follows. +0 SUBROUTINE FCN(N,X,FVEC,FJAC,LDFJAC,IFLAG) + INTEGER N,LDFJAC,IFLAG + REAL X(N),FVEC(N),FJAC(LDFJAC,N) + ---------- + IF IFLAG = 1 CALCULATE THE FUNCTIONS AT X AND + RETURN THIS VECTOR IN FVEC. DO NOT ALTER FJAC. + IF IFLAG = 2 CALCULATE THE JACOBIAN AT X AND + RETURN THIS MATRIX IN FJAC. DO NOT ALTER FVEC. + ---------- + RETURN + END +1 +0 Page +0 The value of IFLAG should not be changed by FCN unless the + user wants to terminate execution of HYBRJ. In this case set + IFLAG to a negative integer. +0 N is a positive integer input variable set to the number of + functions and variables. +0 X is an array of length N. On input X must contain an initial + estimate of the solution vector. On output X contains the + final estimate of the solution vector. +0 FVEC is an output array of length N which contains the function + evaluated at the output X. +0 FJAC is an output N by N array which contains the orthogonal + matrix Q produced by the QR factorization of the final approx + imate Jacobian. Section 6 contains more details about the + approximation to the Jacobian. +0 LDFJAC is a positive integer input variable not less than N + which specifies the leading dimension of the array FJAC. +0 XTOL is a nonnegative input variable. Termination occurs when + the relative error between two consecutive iterates is at mos + XTOL. Therefore, XTOL measures the relative error desired in + the approximate solution. Section 4 contains more details + about XTOL. +0 MAXFEV is a positive integer input variable. Termination occur + when the number of calls to FCN with IFLAG = 1 has reached + MAXFEV. +0 DIAG is an array of length N. If MODE = 1 (see below), DIAG is + internally set. If MODE = 2, DIAG must contain positive + entries that serve as multiplicative scale factors for the + variables. +0 MODE is an integer input variable. If MODE = 1, the variables + will be scaled internally. If MODE = 2, the scaling is speci + fied by the input DIAG. Other values of MODE are equivalent + to MODE = 1. +0 FACTOR is a positive input variable used in determining the ini + tial step bound. This bound is set to the product of FACTOR + and the Euclidean norm of DIAG*X if nonzero, or else to FACTO + itself. In most cases FACTOR should lie in the interval + (.1,100.). 100. is a generally recommended value. +0 NPRINT is an integer input variable that enables controlled + printing of iterates if it is positive. In this case, FCN is + called with IFLAG = 0 at the beginning of the first iteration + and every NPRINT iterations thereafter and immediately prior + to return, with X and FVEC available for printing. FVEC and + FJAC should not be altered. If NPRINT is not positive, no +1 +0 Page +0 special calls of FCN with IFLAG = 0 are made. +0 INFO is an integer output variable. If the user has terminated + execution, INFO is set to the (negative) value of IFLAG. See + description of FCN. Otherwise, INFO is set as follows. +0 INFO = 0 Improper input parameters. +0 INFO = 1 Relative error between two consecutive iterates is + at most XTOL. +0 INFO = 2 Number of calls to FCN with IFLAG = 1 has reached + MAXFEV. +0 INFO = 3 XTOL is too small. No further improvement in the + approximate solution X is possible. +0 INFO = 4 Iteration is not making good progress, as measured + by the improvement from the last five Jacobian eval + uations. +0 INFO = 5 Iteration is not making good progress, as measured + by the improvement from the last ten iterations. +0 Sections 4 and 5 contain more details about INFO. +0 NFEV is an integer output variable set to the number of calls t + FCN with IFLAG = 1. +0 NJEV is an integer output variable set to the number of calls t + FCN with IFLAG = 2. +0 R is an output array of length LR which contains the upper + triangular matrix produced by the QR factorization of the + final approximate Jacobian, stored rowwise. +0 LR is a positive integer input variable not less than + (N*(N+1))/2. +0 QTF is an output array of length N which contains the vector + (Q transpose)*FVEC. +0 WA1, WA2, WA3, and WA4 are work arrays of length N. +0 + 4. Successful completion. +0 The accuracy of HYBRJ is controlled by the convergence paramete + XTOL. This parameter is used in a test which makes a compariso + between the approximation X and a solution XSOL. HYBRJ termi- + nates when the test is satisfied. If the convergence parameter + is less than the machine precision (as defined by the MINPACK + function SPMPAR(1)), then HYBRJ only attempts to satisfy the + test defined by the machine precision. Further progress is not +1 +0 Page +0 usually possible. +0 The test assumes that the functions and the Jacobian are coded + consistently, and that the functions are reasonably well + behaved. If these conditions are not satisfied, then HYBRJ may + incorrectly indicate convergence. The coding of the Jacobian + can be checked by the MINPACK subroutine CHKDER. If the Jaco- + bian is coded correctly, then the validity of the answer can be + checked, for example, by rerunning HYBRJ with a tighter toler- + ance. +0 Convergence test. If ENORM(Z) denotes the Euclidean norm of a + vector Z and D is the diagonal matrix whose entries are + defined by the array DIAG, then this test attempts to guaran- + tee that +0 ENORM(D*(X-XSOL)) .LE. XTOL*ENORM(D*XSOL). +0 If this condition is satisfied with XTOL = 10**(-K), then the + larger components of D*X have K significant decimal digits an + INFO is set to 1. There is a danger that the smaller compo- + nents of D*X may have large relative errors, but the fast rat + of convergence of HYBRJ usually avoids this possibility. + Unless high precision solutions are required, the recommended + value for XTOL is the square root of the machine precision. +0 + 5. Unsuccessful completion. +0 Unsuccessful termination of HYBRJ can be due to improper input + parameters, arithmetic interrupts, an excessive number of func- + tion evaluations, or lack of good progress. +0 Improper input parameters. INFO is set to 0 if N .LE. 0, or + LDFJAC .LT. N, or XTOL .LT. 0.E0, or MAXFEV .LE. 0, or + FACTOR .LE. 0.E0, or LR .LT. (N*(N+1))/2. +0 Arithmetic interrupts. If these interrupts occur in the FCN + subroutine during an early stage of the computation, they may + be caused by an unacceptable choice of X by HYBRJ. In this + case, it may be possible to remedy the situation by rerunning + HYBRJ with a smaller value of FACTOR. +0 Excessive number of function evaluations. A reasonable value + for MAXFEV is 100*(N+1). If the number of calls to FCN with + IFLAG = 1 reaches MAXFEV, then this indicates that the routin + is converging very slowly as measured by the progress of FVEC + and INFO is set to 2. This situation should be unusual + because, as indicated below, lack of good progress is usually + diagnosed earlier by HYBRJ, causing termination with INFO = 4 + or INFO = 5. +0 Lack of good progress. HYBRJ searches for a zero of the system + by minimizing the sum of the squares of the functions. In so +1 +0 Page +0 doing, it can become trapped in a region where the minimum + does not correspond to a zero of the system and, in this situ + ation, the iteration eventually fails to make good progress. + In particular, this will happen if the system does not have a + zero. If the system has a zero, rerunning HYBRJ from a dif- + ferent starting point may be helpful. +0 + 6. Characteristics of the algorithm. +0 HYBRJ is a modification of the Powell hybrid method. Two of it + main characteristics involve the choice of the correction as a + convex combination of the Newton and scaled gradient directions + and the updating of the Jacobian by the rank-1 method of Broy- + den. The choice of the correction guarantees (under reasonable + conditions) global convergence for starting points far from the + solution and a fast rate of convergence. The Jacobian is calcu + lated at the starting point, but it is not recalculated until + the rank-1 method fails to produce satisfactory progress. +0 Timing. The time required by HYBRJ to solve a given problem + depends on N, the behavior of the functions, the accuracy + requested, and the starting point. The number of arithmetic + operations needed by HYBRJ is about 11.5*(N**2) to process + each evaluation of the functions (call to FCN with IFLAG = 1) + and 1.3*(N**3) to process each evaluation of the Jacobian + (call to FCN with IFLAG = 2). Unless FCN can be evaluated + quickly, the timing of HYBRJ will be strongly influenced by + the time spent in FCN. +0 Storage. HYBRJ requires (3*N**2 + 17*N)/2 single precision + storage locations, in addition to the storage required by the + program. There are no internally declared storage arrays. +0 + 7. Subprograms required. +0 USER-supplied ...... FCN +0 MINPACK-supplied ... DOGLEG,SPMPAR,ENORM, + QFORM,QRFAC,R1MPYQ,R1UPDT +0 FORTRAN-supplied ... ABS,AMAX1,AMIN1,SQRT,MIN0,MOD +0 + 8. References. +0 M. J. D. Powell, A Hybrid Method for Nonlinear Equations. + Numerical Methods for Nonlinear Algebraic Equations, + P. Rabinowitz, editor. Gordon and Breach, 1970. +0 + 9. Example. +1 +0 Page +0 The problem is to determine the values of x(1), x(2), ..., x(9) + which solve the system of tridiagonal equations +0 (3-2*x(1))*x(1) -2*x(2) = -1 + -x(i-1) + (3-2*x(i))*x(i) -2*x(i+1) = -1, i=2-8 + -x(8) + (3-2*x(9))*x(9) = -1 +0 C ********** + C + C DRIVER FOR HYBRJ EXAMPLE. + C SINGLE PRECISION VERSION + C + C ********** + INTEGER J,N,LDFJAC,MAXFEV,MODE,NPRINT,INFO,NFEV,NJEV,LR,NWRITE + REAL XTOL,FACTOR,FNORM + REAL X(9),FVEC(9),FJAC(9,9),DIAG(9),R(45),QTF(9), + * WA1(9),WA2(9),WA3(9),WA4(9) + REAL ENORM,SPMPAR + EXTERNAL FCN + C + C LOGICAL OUTPUT UNIT IS ASSUMED TO BE NUMBER 6. + C + DATA NWRITE /6/ + C + N = 9 + C + C THE FOLLOWING STARTING VALUES PROVIDE A ROUGH SOLUTION. + C + DO 10 J = 1, 9 + X(J) = -1.E0 + 10 CONTINUE + C + LDFJAC = 9 + LR = 45 + C + C SET XTOL TO THE SQUARE ROOT OF THE MACHINE PRECISION. + C UNLESS HIGH PRECISION SOLUTIONS ARE REQUIRED, + C THIS IS THE RECOMMENDED SETTING. + C + XTOL = SQRT(SPMPAR(1)) + C + MAXFEV = 1000 + MODE = 2 + DO 20 J = 1, 9 + DIAG(J) = 1.E0 + 20 CONTINUE + FACTOR = 1.E2 + NPRINT = 0 + C + CALL HYBRJ(FCN,N,X,FVEC,FJAC,LDFJAC,XTOL,MAXFEV,DIAG, + * MODE,FACTOR,NPRINT,INFO,NFEV,NJEV,R,LR,QTF, + * WA1,WA2,WA3,WA4) + FNORM = ENORM(N,FVEC) + WRITE (NWRITE,1000) FNORM,NFEV,NJEV,INFO,(X(J),J=1,N) +1 +0 Page +0 STOP + 1000 FORMAT (5X,31H FINAL L2 NORM OF THE RESIDUALS,E15.7 // + * 5X,31H NUMBER OF FUNCTION EVALUATIONS,I10 // + * 5X,31H NUMBER OF JACOBIAN EVALUATIONS,I10 // + * 5X,15H EXIT PARAMETER,16X,I10 // + * 5X,27H FINAL APPROXIMATE SOLUTION // (5X,3E15.7)) + C + C LAST CARD OF DRIVER FOR HYBRJ EXAMPLE. + C + END + SUBROUTINE FCN(N,X,FVEC,FJAC,LDFJAC,IFLAG) + INTEGER N,LDFJAC,IFLAG + REAL X(N),FVEC(N),FJAC(LDFJAC,N) + C + C SUBROUTINE FCN FOR HYBRJ EXAMPLE. + C + INTEGER J,K + REAL ONE,TEMP,TEMP1,TEMP2,THREE,TWO,ZERO + DATA ZERO,ONE,TWO,THREE,FOUR /0.E0,1.E0,2.E0,3.E0,4.E0/ + C + IF (IFLAG .NE. 0) GO TO 5 + C + C INSERT PRINT STATEMENTS HERE WHEN NPRINT IS POSITIVE. + C + RETURN + 5 CONTINUE + IF (IFLAG .EQ. 2) GO TO 20 + DO 10 K = 1, N + TEMP = (THREE - TWO*X(K))*X(K) + TEMP1 = ZERO + IF (K .NE. 1) TEMP1 = X(K-1) + TEMP2 = ZERO + IF (K .NE. N) TEMP2 = X(K+1) + FVEC(K) = TEMP - TEMP1 - TWO*TEMP2 + ONE + 10 CONTINUE + GO TO 50 + 20 CONTINUE + DO 40 K = 1, N + DO 30 J = 1, N + FJAC(K,J) = ZERO + 30 CONTINUE + FJAC(K,K) = THREE - FOUR*X(K) + IF (K .NE. 1) FJAC(K,K-1) = -ONE + IF (K .NE. N) FJAC(K,K+1) = -TWO + 40 CONTINUE + 50 CONTINUE + RETURN + C + C LAST CARD OF SUBROUTINE FCN. + C + END +0 Results obtained with different compilers or machines + may be slightly different. +1 +0 Page +0 FINAL L2 NORM OF THE RESIDUALS 0.1192636E-07 +0 NUMBER OF FUNCTION EVALUATIONS 11 +0 NUMBER OF JACOBIAN EVALUATIONS 1 +0 EXIT PARAMETER 1 +0 FINAL APPROXIMATE SOLUTION +0 -0.5706545E+00 -0.6816283E+00 -0.7017325E+00 + -0.7042129E+00 -0.7013690E+00 -0.6918656E+00 + -0.6657920E+00 -0.5960342E+00 -0.4164121E+00 +1 +0 +1 +0 Page +0 Documentation for MINPACK subroutine LMDER1 +0 Single precision version +0 Argonne National Laboratory +0 Burton S. Garbow, Kenneth E. Hillstrom, Jorge J. More +0 March 1980 +0 + 1. Purpose. +0 The purpose of LMDER1 is to minimize the sum of the squares of + nonlinear functions in N variables by a modification of the + Levenberg-Marquardt algorithm. This is done by using the more + general least-squares solver LMDER. The user must provide a + subroutine which calculates the functions and the Jacobian. +0 + 2. Subroutine and type statements. +0 SUBROUTINE LMDER1(FCN,M,N,X,FVEC,FJAC,LDFJAC,TOL, + * INFO,IPVT,WA,LWA) + INTEGER M,N,LDFJAC,INFO,LWA + INTEGER IPVT(N) + REAL TOL + REAL X(N),FVEC(M),FJAC(LDFJAC,N),WA(LWA) + EXTERNAL FCN +0 + 3. Parameters. +0 Parameters designated as input parameters must be specified on + entry to LMDER1 and are not changed on exit, while parameters + designated as output parameters need not be specified on entry + and are set to appropriate values on exit from LMDER1. +0 FCN is the name of the user-supplied subroutine which calculate + the functions and the Jacobian. FCN must be declared in an + EXTERNAL statement in the user calling program, and should be + written as follows. +0 SUBROUTINE FCN(M,N,X,FVEC,FJAC,LDFJAC,IFLAG) + INTEGER M,N,LDFJAC,IFLAG + REAL X(N),FVEC(M),FJAC(LDFJAC,N) + ---------- + IF IFLAG = 1 CALCULATE THE FUNCTIONS AT X AND + RETURN THIS VECTOR IN FVEC. DO NOT ALTER FJAC. + IF IFLAG = 2 CALCULATE THE JACOBIAN AT X AND + RETURN THIS MATRIX IN FJAC. DO NOT ALTER FVEC. + ---------- + RETURN + END +1 +0 Page +0 The value of IFLAG should not be changed by FCN unless the + user wants to terminate execution of LMDER1. In this case se + IFLAG to a negative integer. +0 M is a positive integer input variable set to the number of + functions. +0 N is a positive integer input variable set to the number of + variables. N must not exceed M. +0 X is an array of length N. On input X must contain an initial + estimate of the solution vector. On output X contains the + final estimate of the solution vector. +0 FVEC is an output array of length M which contains the function + evaluated at the output X. +0 FJAC is an output M by N array. The upper N by N submatrix of + FJAC contains an upper triangular matrix R with diagonal ele- + ments of nonincreasing magnitude such that +0 T T T + P *(JAC *JAC)*P = R *R, +0 where P is a permutation matrix and JAC is the final calcu- + lated Jacobian. Column j of P is column IPVT(j) (see below) + of the identity matrix. The lower trapezoidal part of FJAC + contains information generated during the computation of R. +0 LDFJAC is a positive integer input variable not less than M + which specifies the leading dimension of the array FJAC. +0 TOL is a nonnegative input variable. Termination occurs when + the algorithm estimates either that the relative error in the + sum of squares is at most TOL or that the relative error + between X and the solution is at most TOL. Section 4 contain + more details about TOL. +0 INFO is an integer output variable. If the user has terminated + execution, INFO is set to the (negative) value of IFLAG. See + description of FCN. Otherwise, INFO is set as follows. +0 INFO = 0 Improper input parameters. +0 INFO = 1 Algorithm estimates that the relative error in the + sum of squares is at most TOL. +0 INFO = 2 Algorithm estimates that the relative error between + X and the solution is at most TOL. +0 INFO = 3 Conditions for INFO = 1 and INFO = 2 both hold. +0 INFO = 4 FVEC is orthogonal to the columns of the Jacobian t + machine precision. +1 +0 Page +0 INFO = 5 Number of calls to FCN with IFLAG = 1 has reached + 100*(N+1). +0 INFO = 6 TOL is too small. No further reduction in the sum + of squares is possible. +0 INFO = 7 TOL is too small. No further improvement in the + approximate solution X is possible. +0 Sections 4 and 5 contain more details about INFO. +0 IPVT is an integer output array of length N. IPVT defines a + permutation matrix P such that JAC*P = Q*R, where JAC is the + final calculated Jacobian, Q is orthogonal (not stored), and + is upper triangular with diagonal elements of nonincreasing + magnitude. Column j of P is column IPVT(j) of the identity + matrix. +0 WA is a work array of length LWA. +0 LWA is a positive integer input variable not less than 5*N+M. +0 + 4. Successful completion. +0 The accuracy of LMDER1 is controlled by the convergence parame- + ter TOL. This parameter is used in tests which make three type + of comparisons between the approximation X and a solution XSOL. + LMDER1 terminates when any of the tests is satisfied. If TOL i + less than the machine precision (as defined by the MINPACK func + tion SPMPAR(1)), then LMDER1 only attempts to satisfy the test + defined by the machine precision. Further progress is not usu- + ally possible. Unless high precision solutions are required, + the recommended value for TOL is the square root of the machine + precision. +0 The tests assume that the functions and the Jacobian are coded + consistently, and that the functions are reasonably well + behaved. If these conditions are not satisfied, then LMDER1 ma + incorrectly indicate convergence. The coding of the Jacobian + can be checked by the MINPACK subroutine CHKDER. If the Jaco- + bian is coded correctly, then the validity of the answer can be + checked, for example, by rerunning LMDER1 with a tighter toler- + ance. +0 First convergence test. If ENORM(Z) denotes the Euclidean norm + of a vector Z, then this test attempts to guarantee that +0 ENORM(FVEC) .LE. (1+TOL)*ENORM(FVECS), +0 where FVECS denotes the functions evaluated at XSOL. If this + condition is satisfied with TOL = 10**(-K), then the final + residual norm ENORM(FVEC) has K significant decimal digits an + INFO is set to 1 (or to 3 if the second test is also +1 +0 Page +0 satisfied). +0 Second convergence test. If D is a diagonal matrix (implicitly + generated by LMDER1) whose entries contain scale factors for + the variables, then this test attempts to guarantee that +0 ENORM(D*(X-XSOL)) .LE. TOL*ENORM(D*XSOL). +0 If this condition is satisfied with TOL = 10**(-K), then the + larger components of D*X have K significant decimal digits an + INFO is set to 2 (or to 3 if the first test is also satis- + fied). There is a danger that the smaller components of D*X + may have large relative errors, but the choice of D is such + that the accuracy of the components of X is usually related t + their sensitivity. +0 Third convergence test. This test is satisfied when FVEC is + orthogonal to the columns of the Jacobian to machine preci- + sion. There is no clear relationship between this test and + the accuracy of LMDER1, and furthermore, the test is equally + well satisfied at other critical points, namely maximizers an + saddle points. Therefore, termination caused by this test + (INFO = 4) should be examined carefully. +0 + 5. Unsuccessful completion. +0 Unsuccessful termination of LMDER1 can be due to improper input + parameters, arithmetic interrupts, or an excessive number of + function evaluations. +0 Improper input parameters. INFO is set to 0 if N .LE. 0, or + M .LT. N, or LDFJAC .LT. M, or TOL .LT. 0.E0, or + LWA .LT. 5*N+M. +0 Arithmetic interrupts. If these interrupts occur in the FCN + subroutine during an early stage of the computation, they may + be caused by an unacceptable choice of X by LMDER1. In this + case, it may be possible to remedy the situation by not evalu + ating the functions here, but instead setting the components + of FVEC to numbers that exceed those in the initial FVEC, + thereby indirectly reducing the step length. The step length + can be more directly controlled by using instead LMDER, which + includes in its calling sequence the step-length- governing + parameter FACTOR. +0 Excessive number of function evaluations. If the number of + calls to FCN with IFLAG = 1 reaches 100*(N+1), then this indi + cates that the routine is converging very slowly as measured + by the progress of FVEC, and INFO is set to 5. In this case, + it may be helpful to restart LMDER1, thereby forcing it to + disregard old (and possibly harmful) information. +0 +1 +0 Page +0 6. Characteristics of the algorithm. +0 LMDER1 is a modification of the Levenberg-Marquardt algorithm. + Two of its main characteristics involve the proper use of + implicitly scaled variables and an optimal choice for the cor- + rection. The use of implicitly scaled variables achieves scale + invariance of LMDER1 and limits the size of the correction in + any direction where the functions are changing rapidly. The + optimal choice of the correction guarantees (under reasonable + conditions) global convergence from starting points far from th + solution and a fast rate of convergence for problems with small + residuals. +0 Timing. The time required by LMDER1 to solve a given problem + depends on M and N, the behavior of the functions, the accu- + racy requested, and the starting point. The number of arith- + metic operations needed by LMDER1 is about N**3 to process + each evaluation of the functions (call to FCN with IFLAG = 1) + and M*(N**2) to process each evaluation of the Jacobian (call + to FCN with IFLAG = 2). Unless FCN can be evaluated quickly, + the timing of LMDER1 will be strongly influenced by the time + spent in FCN. +0 Storage. LMDER1 requires M*N + 2*M + 6*N single precision sto- + rage locations and N integer storage locations, in addition t + the storage required by the program. There are no internally + declared storage arrays. +0 + 7. Subprograms required. +0 USER-supplied ...... FCN +0 MINPACK-supplied ... SPMPAR,ENORM,LMDER,LMPAR,QRFAC,QRSOLV +0 FORTRAN-supplied ... ABS,AMAX1,AMIN1,SQRT,MOD +0 + 8. References. +0 Jorge J. More, The Levenberg-Marquardt Algorithm, Implementatio + and Theory. Numerical Analysis, G. A. Watson, editor. + Lecture Notes in Mathematics 630, Springer-Verlag, 1977. +0 + 9. Example. +0 The problem is to determine the values of x(1), x(2), and x(3) + which provide the best fit (in the least squares sense) of +0 x(1) + u(i)/(v(i)*x(2) + w(i)*x(3)), i = 1, 15 +0 to the data +1 +0 Page +0 y = (0.14,0.18,0.22,0.25,0.29,0.32,0.35,0.39, + 0.37,0.58,0.73,0.96,1.34,2.10,4.39), +0 where u(i) = i, v(i) = 16 - i, and w(i) = min(u(i),v(i)). The + i-th component of FVEC is thus defined by +0 y(i) - (x(1) + u(i)/(v(i)*x(2) + w(i)*x(3))). +0 C ********** + C + C DRIVER FOR LMDER1 EXAMPLE. + C SINGLE PRECISION VERSION + C + C ********** + INTEGER J,M,N,LDFJAC,INFO,LWA,NWRITE + INTEGER IPVT(3) + REAL TOL,FNORM + REAL X(3),FVEC(15),FJAC(15,3),WA(30) + REAL ENORM,SPMPAR + EXTERNAL FCN + C + C LOGICAL OUTPUT UNIT IS ASSUMED TO BE NUMBER 6. + C + DATA NWRITE /6/ + C + M = 15 + N = 3 + C + C THE FOLLOWING STARTING VALUES PROVIDE A ROUGH FIT. + C + X(1) = 1.E0 + X(2) = 1.E0 + X(3) = 1.E0 + C + LDFJAC = 15 + LWA = 30 + C + C SET TOL TO THE SQUARE ROOT OF THE MACHINE PRECISION. + C UNLESS HIGH PRECISION SOLUTIONS ARE REQUIRED, + C THIS IS THE RECOMMENDED SETTING. + C + TOL = SQRT(SPMPAR(1)) + C + CALL LMDER1(FCN,M,N,X,FVEC,FJAC,LDFJAC,TOL, + * INFO,IPVT,WA,LWA) + FNORM = ENORM(M,FVEC) + WRITE (NWRITE,1000) FNORM,INFO,(X(J),J=1,N) + STOP + 1000 FORMAT (5X,31H FINAL L2 NORM OF THE RESIDUALS,E15.7 // + * 5X,15H EXIT PARAMETER,16X,I10 // + * 5X,27H FINAL APPROXIMATE SOLUTION // 5X,3E15.7) + C + C LAST CARD OF DRIVER FOR LMDER1 EXAMPLE. + C +1 +0 Page +0 END + SUBROUTINE FCN(M,N,X,FVEC,FJAC,LDFJAC,IFLAG) + INTEGER M,N,LDFJAC,IFLAG + REAL X(N),FVEC(M),FJAC(LDFJAC,N) + C + C SUBROUTINE FCN FOR LMDER1 EXAMPLE. + C + INTEGER I + REAL TMP1,TMP2,TMP3,TMP4 + REAL Y(15) + DATA Y(1),Y(2),Y(3),Y(4),Y(5),Y(6),Y(7),Y(8), + * Y(9),Y(10),Y(11),Y(12),Y(13),Y(14),Y(15) + * /1.4E-1,1.8E-1,2.2E-1,2.5E-1,2.9E-1,3.2E-1,3.5E-1,3.9E-1, + * 3.7E-1,5.8E-1,7.3E-1,9.6E-1,1.34E0,2.1E0,4.39E0/ + C + IF (IFLAG .EQ. 2) GO TO 20 + DO 10 I = 1, 15 + TMP1 = I + TMP2 = 16 - I + TMP3 = TMP1 + IF (I .GT. 8) TMP3 = TMP2 + FVEC(I) = Y(I) - (X(1) + TMP1/(X(2)*TMP2 + X(3)*TMP3)) + 10 CONTINUE + GO TO 40 + 20 CONTINUE + DO 30 I = 1, 15 + TMP1 = I + TMP2 = 16 - I + TMP3 = TMP1 + IF (I .GT. 8) TMP3 = TMP2 + TMP4 = (X(2)*TMP2 + X(3)*TMP3)**2 + FJAC(I,1) = -1.E0 + FJAC(I,2) = TMP1*TMP2/TMP4 + FJAC(I,3) = TMP1*TMP3/TMP4 + 30 CONTINUE + 40 CONTINUE + RETURN + C + C LAST CARD OF SUBROUTINE FCN. + C + END +0 Results obtained with different compilers or machines + may be slightly different. +0 FINAL L2 NORM OF THE RESIDUALS 0.9063596E-01 +0 EXIT PARAMETER 1 +0 FINAL APPROXIMATE SOLUTION +0 0.8241058E-01 0.1133037E+01 0.2343695E+01 +1 +0 +1 +0 Page +0 Documentation for MINPACK subroutine LMDER +0 Single precision version +0 Argonne National Laboratory +0 Burton S. Garbow, Kenneth E. Hillstrom, Jorge J. More +0 March 1980 +0 + 1. Purpose. +0 The purpose of LMDER is to minimize the sum of the squares of M + nonlinear functions in N variables by a modification of the + Levenberg-Marquardt algorithm. The user must provide a subrou- + tine which calculates the functions and the Jacobian. +0 + 2. Subroutine and type statements. +0 SUBROUTINE LMDER(FCN,M,N,X,FVEC,FJAC,LDFJAC,FTOL,XTOL,GTOL, + * MAXFEV,DIAG,MODE,FACTOR,NPRINT,INFO,NFEV,NJEV, + * IPVT,QTF,WA1,WA2,WA3,WA4) + INTEGER M,N,LDFJAC,MAXFEV,MODE,NPRINT,INFO,NFEV,NJEV + INTEGER IPVT(N) + REAL FTOL,XTOL,GTOL,FACTOR + REAL X(N),FVEC(M),FJAC(LDFJAC,N),DIAG(N),QTF(N), + * WA1(N),WA2(N),WA3(N),WA4(M) +0 + 3. Parameters. +0 Parameters designated as input parameters must be specified on + entry to LMDER and are not changed on exit, while parameters + designated as output parameters need not be specified on entry + and are set to appropriate values on exit from LMDER. +0 FCN is the name of the user-supplied subroutine which calculate + the functions and the Jacobian. FCN must be declared in an + EXTERNAL statement in the user calling program, and should be + written as follows. +0 SUBROUTINE FCN(M,N,X,FVEC,FJAC,LDFJAC,IFLAG) + INTEGER M,N,LDFJAC,IFLAG + REAL X(N),FVEC(M),FJAC(LDFJAC,N) + ---------- + IF IFLAG = 1 CALCULATE THE FUNCTIONS AT X AND + RETURN THIS VECTOR IN FVEC. DO NOT ALTER FJAC. + IF IFLAG = 2 CALCULATE THE JACOBIAN AT X AND + RETURN THIS MATRIX IN FJAC. DO NOT ALTER FVEC. + ---------- + RETURN + END +1 +0 Page +0 The value of IFLAG should not be changed by FCN unless the + user wants to terminate execution of LMDER. In this case set + IFLAG to a negative integer. +0 M is a positive integer input variable set to the number of + functions. +0 N is a positive integer input variable set to the number of + variables. N must not exceed M. +0 X is an array of length N. On input X must contain an initial + estimate of the solution vector. On output X contains the + final estimate of the solution vector. +0 FVEC is an output array of length M which contains the function + evaluated at the output X. +0 FJAC is an output M by N array. The upper N by N submatrix of + FJAC contains an upper triangular matrix R with diagonal ele- + ments of nonincreasing magnitude such that +0 T T T + P *(JAC *JAC)*P = R *R, +0 where P is a permutation matrix and JAC is the final calcu- + lated Jacobian. Column j of P is column IPVT(j) (see below) + of the identity matrix. The lower trapezoidal part of FJAC + contains information generated during the computation of R. +0 LDFJAC is a positive integer input variable not less than M + which specifies the leading dimension of the array FJAC. +0 FTOL is a nonnegative input variable. Termination occurs when + both the actual and predicted relative reductions in the sum + of squares are at most FTOL. Therefore, FTOL measures the + relative error desired in the sum of squares. Section 4 con- + tains more details about FTOL. +0 XTOL is a nonnegative input variable. Termination occurs when + the relative error between two consecutive iterates is at mos + XTOL. Therefore, XTOL measures the relative error desired in + the approximate solution. Section 4 contains more details + about XTOL. +0 GTOL is a nonnegative input variable. Termination occurs when + the cosine of the angle between FVEC and any column of the + Jacobian is at most GTOL in absolute value. Therefore, GTOL + measures the orthogonality desired between the function vecto + and the columns of the Jacobian. Section 4 contains more + details about GTOL. +0 MAXFEV is a positive integer input variable. Termination occur + when the number of calls to FCN with IFLAG = 1 has reached + MAXFEV. +1 +0 Page +0 DIAG is an array of length N. If MODE = 1 (see below), DIAG is + internally set. If MODE = 2, DIAG must contain positive + entries that serve as multiplicative scale factors for the + variables. +0 MODE is an integer input variable. If MODE = 1, the variables + will be scaled internally. If MODE = 2, the scaling is speci + fied by the input DIAG. Other values of MODE are equivalent + to MODE = 1. +0 FACTOR is a positive input variable used in determining the ini + tial step bound. This bound is set to the product of FACTOR + and the Euclidean norm of DIAG*X if nonzero, or else to FACTO + itself. In most cases FACTOR should lie in the interval + (.1,100.). 100. is a generally recommended value. +0 NPRINT is an integer input variable that enables controlled + printing of iterates if it is positive. In this case, FCN is + called with IFLAG = 0 at the beginning of the first iteration + and every NPRINT iterations thereafter and immediately prior + to return, with X, FVEC, and FJAC available for printing. + FVEC and FJAC should not be altered. If NPRINT is not posi- + tive, no special calls of FCN with IFLAG = 0 are made. +0 INFO is an integer output variable. If the user has terminated + execution, INFO is set to the (negative) value of IFLAG. See + description of FCN. Otherwise, INFO is set as follows. +0 INFO = 0 Improper input parameters. +0 INFO = 1 Both actual and predicted relative reductions in th + sum of squares are at most FTOL. +0 INFO = 2 Relative error between two consecutive iterates is + at most XTOL. +0 INFO = 3 Conditions for INFO = 1 and INFO = 2 both hold. +0 INFO = 4 The cosine of the angle between FVEC and any column + of the Jacobian is at most GTOL in absolute value. +0 INFO = 5 Number of calls to FCN with IFLAG = 1 has reached + MAXFEV. +0 INFO = 6 FTOL is too small. No further reduction in the sum + of squares is possible. +0 INFO = 7 XTOL is too small. No further improvement in the + approximate solution X is possible. +0 INFO = 8 GTOL is too small. FVEC is orthogonal to the + columns of the Jacobian to machine precision. +0 Sections 4 and 5 contain more details about INFO. +1 +0 Page +0 NFEV is an integer output variable set to the number of calls t + FCN with IFLAG = 1. +0 NJEV is an integer output variable set to the number of calls t + FCN with IFLAG = 2. +0 IPVT is an integer output array of length N. IPVT defines a + permutation matrix P such that JAC*P = Q*R, where JAC is the + final calculated Jacobian, Q is orthogonal (not stored), and + is upper triangular with diagonal elements of nonincreasing + magnitude. Column j of P is column IPVT(j) of the identity + matrix. +0 QTF is an output array of length N which contains the first N + elements of the vector (Q transpose)*FVEC. +0 WA1, WA2, and WA3 are work arrays of length N. +0 WA4 is a work array of length M. +0 + 4. Successful completion. +0 The accuracy of LMDER is controlled by the convergence parame- + ters FTOL, XTOL, and GTOL. These parameters are used in tests + which make three types of comparisons between the approximation + X and a solution XSOL. LMDER terminates when any of the tests + is satisfied. If any of the convergence parameters is less tha + the machine precision (as defined by the MINPACK function + SPMPAR(1)), then LMDER only attempts to satisfy the test define + by the machine precision. Further progress is not usually pos- + sible. +0 The tests assume that the functions and the Jacobian are coded + consistently, and that the functions are reasonably well + behaved. If these conditions are not satisfied, then LMDER may + incorrectly indicate convergence. The coding of the Jacobian + can be checked by the MINPACK subroutine CHKDER. If the Jaco- + bian is coded correctly, then the validity of the answer can be + checked, for example, by rerunning LMDER with tighter toler- + ances. +0 First convergence test. If ENORM(Z) denotes the Euclidean norm + of a vector Z, then this test attempts to guarantee that +0 ENORM(FVEC) .LE. (1+FTOL)*ENORM(FVECS), +0 where FVECS denotes the functions evaluated at XSOL. If this + condition is satisfied with FTOL = 10**(-K), then the final + residual norm ENORM(FVEC) has K significant decimal digits an + INFO is set to 1 (or to 3 if the second test is also satis- + fied). Unless high precision solutions are required, the + recommended value for FTOL is the square root of the machine + precision. +1 +0 Page +0 Second convergence test. If D is the diagonal matrix whose + entries are defined by the array DIAG, then this test attempt + to guarantee that +0 ENORM(D*(X-XSOL)) .LE. XTOL*ENORM(D*XSOL). +0 If this condition is satisfied with XTOL = 10**(-K), then the + larger components of D*X have K significant decimal digits an + INFO is set to 2 (or to 3 if the first test is also satis- + fied). There is a danger that the smaller components of D*X + may have large relative errors, but if MODE = 1, then the + accuracy of the components of X is usually related to their + sensitivity. Unless high precision solutions are required, + the recommended value for XTOL is the square root of the + machine precision. +0 Third convergence test. This test is satisfied when the cosine + of the angle between FVEC and any column of the Jacobian at X + is at most GTOL in absolute value. There is no clear rela- + tionship between this test and the accuracy of LMDER, and + furthermore, the test is equally well satisfied at other crit + ical points, namely maximizers and saddle points. Therefore, + termination caused by this test (INFO = 4) should be examined + carefully. The recommended value for GTOL is zero. +0 + 5. Unsuccessful completion. +0 Unsuccessful termination of LMDER can be due to improper input + parameters, arithmetic interrupts, or an excessive number of + function evaluations. +0 Improper input parameters. INFO is set to 0 if N .LE. 0, or + M .LT. N, or LDFJAC .LT. M, or FTOL .LT. 0.E0, or + XTOL .LT. 0.E0, or GTOL .LT. 0.E0, or MAXFEV .LE. 0, or + FACTOR .LE. 0.E0. +0 Arithmetic interrupts. If these interrupts occur in the FCN + subroutine during an early stage of the computation, they may + be caused by an unacceptable choice of X by LMDER. In this + case, it may be possible to remedy the situation by rerunning + LMDER with a smaller value of FACTOR. +0 Excessive number of function evaluations. A reasonable value + for MAXFEV is 100*(N+1). If the number of calls to FCN with + IFLAG = 1 reaches MAXFEV, then this indicates that the routin + is converging very slowly as measured by the progress of FVEC + and INFO is set to 5. In this case, it may be helpful to + restart LMDER with MODE set to 1. +0 + 6. Characteristics of the algorithm. +0 LMDER is a modification of the Levenberg-Marquardt algorithm. +1 +0 Page +0 Two of its main characteristics involve the proper use of + implicitly scaled variables (if MODE = 1) and an optimal choice + for the correction. The use of implicitly scaled variables + achieves scale invariance of LMDER and limits the size of the + correction in any direction where the functions are changing + rapidly. The optimal choice of the correction guarantees (unde + reasonable conditions) global convergence from starting points + far from the solution and a fast rate of convergence for prob- + lems with small residuals. +0 Timing. The time required by LMDER to solve a given problem + depends on M and N, the behavior of the functions, the accu- + racy requested, and the starting point. The number of arith- + metic operations needed by LMDER is about N**3 to process eac + evaluation of the functions (call to FCN with IFLAG = 1) and + M*(N**2) to process each evaluation of the Jacobian (call to + FCN with IFLAG = 2). Unless FCN can be evaluated quickly, th + timing of LMDER will be strongly influenced by the time spent + in FCN. +0 Storage. LMDER requires M*N + 2*M + 6*N single precision sto- + rage locations and N integer storage locations, in addition t + the storage required by the program. There are no internally + declared storage arrays. +0 + 7. Subprograms required. +0 USER-supplied ...... FCN +0 MINPACK-supplied ... SPMPAR,ENORM,LMPAR,QRFAC,QRSOLV +0 FORTRAN-supplied ... ABS,AMAX1,AMIN1,SQRT,MOD +0 + 8. References. +0 Jorge J. More, The Levenberg-Marquardt Algorithm, Implementatio + and Theory. Numerical Analysis, G. A. Watson, editor. + Lecture Notes in Mathematics 630, Springer-Verlag, 1977. +0 + 9. Example. +0 The problem is to determine the values of x(1), x(2), and x(3) + which provide the best fit (in the least squares sense) of +0 x(1) + u(i)/(v(i)*x(2) + w(i)*x(3)), i = 1, 15 +0 to the data +0 y = (0.14,0.18,0.22,0.25,0.29,0.32,0.35,0.39, + 0.37,0.58,0.73,0.96,1.34,2.10,4.39), +1 +0 Page +0 where u(i) = i, v(i) = 16 - i, and w(i) = min(u(i),v(i)). The + i-th component of FVEC is thus defined by +0 y(i) - (x(1) + u(i)/(v(i)*x(2) + w(i)*x(3))). +0 C ********** + C + C DRIVER FOR LMDER EXAMPLE. + C SINGLE PRECISION VERSION + C + C ********** + INTEGER J,M,N,LDFJAC,MAXFEV,MODE,NPRINT,INFO,NFEV,NJEV,NWRITE + INTEGER IPVT(3) + REAL FTOL,XTOL,GTOL,FACTOR,FNORM + REAL X(3),FVEC(15),FJAC(15,3),DIAG(3),QTF(3), + * WA1(3),WA2(3),WA3(3),WA4(15) + REAL ENORM,SPMPAR + EXTERNAL FCN + C + C LOGICAL OUTPUT UNIT IS ASSUMED TO BE NUMBER 6. + C + DATA NWRITE /6/ + C + M = 15 + N = 3 + C + C THE FOLLOWING STARTING VALUES PROVIDE A ROUGH FIT. + C + X(1) = 1.E0 + X(2) = 1.E0 + X(3) = 1.E0 + C + LDFJAC = 15 + C + C SET FTOL AND XTOL TO THE SQUARE ROOT OF THE MACHINE PRECISION + C AND GTOL TO ZERO. UNLESS HIGH PRECISION SOLUTIONS ARE + C REQUIRED, THESE ARE THE RECOMMENDED SETTINGS. + C + FTOL = SQRT(SPMPAR(1)) + XTOL = SQRT(SPMPAR(1)) + GTOL = 0.E0 + C + MAXFEV = 400 + MODE = 1 + FACTOR = 1.E2 + NPRINT = 0 + C + CALL LMDER(FCN,M,N,X,FVEC,FJAC,LDFJAC,FTOL,XTOL,GTOL, + * MAXFEV,DIAG,MODE,FACTOR,NPRINT,INFO,NFEV,NJEV, + * IPVT,QTF,WA1,WA2,WA3,WA4) + FNORM = ENORM(M,FVEC) + WRITE (NWRITE,1000) FNORM,NFEV,NJEV,INFO,(X(J),J=1,N) + STOP + 1000 FORMAT (5X,31H FINAL L2 NORM OF THE RESIDUALS,E15.7 // +1 +0 Page +0 * 5X,31H NUMBER OF FUNCTION EVALUATIONS,I10 // + * 5X,31H NUMBER OF JACOBIAN EVALUATIONS,I10 // + * 5X,15H EXIT PARAMETER,16X,I10 // + * 5X,27H FINAL APPROXIMATE SOLUTION // 5X,3E15.7) + C + C LAST CARD OF DRIVER FOR LMDER EXAMPLE. + C + END + SUBROUTINE FCN(M,N,X,FVEC,FJAC,LDFJAC,IFLAG) + INTEGER M,N,LDFJAC,IFLAG + REAL X(N),FVEC(M),FJAC(LDFJAC,N) + C + C SUBROUTINE FCN FOR LMDER EXAMPLE. + C + INTEGER I + REAL TMP1,TMP2,TMP3,TMP4 + REAL Y(15) + DATA Y(1),Y(2),Y(3),Y(4),Y(5),Y(6),Y(7),Y(8), + * Y(9),Y(10),Y(11),Y(12),Y(13),Y(14),Y(15) + * /1.4E-1,1.8E-1,2.2E-1,2.5E-1,2.9E-1,3.2E-1,3.5E-1,3.9E-1, + * 3.7E-1,5.8E-1,7.3E-1,9.6E-1,1.34E0,2.1E0,4.39E0/ + C + IF (IFLAG .NE. 0) GO TO 5 + C + C INSERT PRINT STATEMENTS HERE WHEN NPRINT IS POSITIVE. + C + RETURN + 5 CONTINUE + IF (IFLAG .EQ. 2) GO TO 20 + DO 10 I = 1, 15 + TMP1 = I + TMP2 = 16 - I + TMP3 = TMP1 + IF (I .GT. 8) TMP3 = TMP2 + FVEC(I) = Y(I) - (X(1) + TMP1/(X(2)*TMP2 + X(3)*TMP3)) + 10 CONTINUE + GO TO 40 + 20 CONTINUE + DO 30 I = 1, 15 + TMP1 = I + TMP2 = 16 - I + TMP3 = TMP1 + IF (I .GT. 8) TMP3 = TMP2 + TMP4 = (X(2)*TMP2 + X(3)*TMP3)**2 + FJAC(I,1) = -1.E0 + FJAC(I,2) = TMP1*TMP2/TMP4 + FJAC(I,3) = TMP1*TMP3/TMP4 + 30 CONTINUE + 40 CONTINUE + RETURN + C + C LAST CARD OF SUBROUTINE FCN. + C + END +1 +0 Page +0 Results obtained with different compilers or machines + may be slightly different. +0 FINAL L2 NORM OF THE RESIDUALS 0.9063596E-01 +0 NUMBER OF FUNCTION EVALUATIONS 6 +0 NUMBER OF JACOBIAN EVALUATIONS 5 +0 EXIT PARAMETER 1 +0 FINAL APPROXIMATE SOLUTION +0 0.8241058E-01 0.1133037E+01 0.2343695E+01 +1 +0 +1 +0 Page +0 Documentation for MINPACK subroutine LMSTR1 +0 Single precision version +0 Argonne National Laboratory +0 Burton S. Garbow, Kenneth E. Hillstrom, Jorge J. More +0 March 1980 +0 + 1. Purpose. +0 The purpose of LMSTR1 is to minimize the sum of the squares of + nonlinear functions in N variables by a modification of the + Levenberg-Marquardt algorithm which uses minimal storage. This + is done by using the more general least-squares solver LMSTR. + The user must provide a subroutine which calculates the func- + tions and the rows of the Jacobian. +0 + 2. Subroutine and type statements. +0 SUBROUTINE LMSTR1(FCN,M,N,X,FVEC,FJAC,LDFJAC,TOL, + * INFO,IPVT,WA,LWA) + INTEGER M,N,LDFJAC,INFO,LWA + INTEGER IPVT(N) + REAL TOL + REAL X(N),FVEC(M),FJAC(LDFJAC,N),WA(LWA) + EXTERNAL FCN +0 + 3. Parameters. +0 Parameters designated as input parameters must be specified on + entry to LMSTR1 and are not changed on exit, while parameters + designated as output parameters need not be specified on entry + and are set to appropriate values on exit from LMSTR1. +0 FCN is the name of the user-supplied subroutine which calculate + the functions and the rows of the Jacobian. FCN must be + declared in an EXTERNAL statement in the user calling program + and should be written as follows. +0 SUBROUTINE FCN(M,N,X,FVEC,FJROW,IFLAG) + INTEGER M,N,IFLAG + REAL X(N),FVEC(M),FJROW(N) + ---------- + IF IFLAG = 1 CALCULATE THE FUNCTIONS AT X AND + RETURN THIS VECTOR IN FVEC. + IF IFLAG = I CALCULATE THE (I-1)-ST ROW OF THE + JACOBIAN AT X AND RETURN THIS VECTOR IN FJROW. + ---------- + RETURN +1 +0 Page +0 END +0 The value of IFLAG should not be changed by FCN unless the + user wants to terminate execution of LMSTR1. In this case se + IFLAG to a negative integer. +0 M is a positive integer input variable set to the number of + functions. +0 N is a positive integer input variable set to the number of + variables. N must not exceed M. +0 X is an array of length N. On input X must contain an initial + estimate of the solution vector. On output X contains the + final estimate of the solution vector. +0 FVEC is an output array of length M which contains the function + evaluated at the output X. +0 FJAC is an output N by N array. The upper triangle of FJAC con + tains an upper triangular matrix R such that +0 T T T + P *(JAC *JAC)*P = R *R, +0 where P is a permutation matrix and JAC is the final calcu- + lated Jacobian. Column j of P is column IPVT(j) (see below) + of the identity matrix. The lower triangular part of FJAC + contains information generated during the computation of R. +0 LDFJAC is a positive integer input variable not less than N + which specifies the leading dimension of the array FJAC. +0 TOL is a nonnegative input variable. Termination occurs when + the algorithm estimates either that the relative error in the + sum of squares is at most TOL or that the relative error + between X and the solution is at most TOL. Section 4 contain + more details about TOL. +0 INFO is an integer output variable. If the user has terminated + execution, INFO is set to the (negative) value of IFLAG. See + description of FCN. Otherwise, INFO is set as follows. +0 INFO = 0 Improper input parameters. +0 INFO = 1 Algorithm estimates that the relative error in the + sum of squares is at most TOL. +0 INFO = 2 Algorithm estimates that the relative error between + X and the solution is at most TOL. +0 INFO = 3 Conditions for INFO = 1 and INFO = 2 both hold. +0 INFO = 4 FVEC is orthogonal to the columns of the Jacobian t +1 +0 Page +0 machine precision. +0 INFO = 5 Number of calls to FCN with IFLAG = 1 has reached + 100*(N+1). +0 INFO = 6 TOL is too small. No further reduction in the sum + of squares is possible. +0 INFO = 7 TOL is too small. No further improvement in the + approximate solution X is possible. +0 Sections 4 and 5 contain more details about INFO. +0 IPVT is an integer output array of length N. IPVT defines a + permutation matrix P such that JAC*P = Q*R, where JAC is the + final calculated Jacobian, Q is orthogonal (not stored), and + is upper triangular. Column j of P is column IPVT(j) of the + identity matrix. +0 WA is a work array of length LWA. +0 LWA is a positive integer input variable not less than 5*N+M. +0 + 4. Successful completion. +0 The accuracy of LMSTR1 is controlled by the convergence parame- + ter TOL. This parameter is used in tests which make three type + of comparisons between the approximation X and a solution XSOL. + LMSTR1 terminates when any of the tests is satisfied. If TOL i + less than the machine precision (as defined by the MINPACK func + tion SPMPAR(1)), then LMSTR1 only attempts to satisfy the test + defined by the machine precision. Further progress is not usu- + ally possible. Unless high precision solutions are required, + the recommended value for TOL is the square root of the machine + precision. +0 The tests assume that the functions and the Jacobian are coded + consistently, and that the functions are reasonably well + behaved. If these conditions are not satisfied, then LMSTR1 ma + incorrectly indicate convergence. The coding of the Jacobian + can be checked by the MINPACK subroutine CHKDER. If the Jaco- + bian is coded correctly, then the validity of the answer can be + checked, for example, by rerunning LMSTR1 with a tighter toler- + ance. +0 First convergence test. If ENORM(Z) denotes the Euclidean norm + of a vector Z, then this test attempts to guarantee that +0 ENORM(FVEC) .LE. (1+TOL)*ENORM(FVECS), +0 where FVECS denotes the functions evaluated at XSOL. If this + condition is satisfied with TOL = 10**(-K), then the final + residual norm ENORM(FVEC) has K significant decimal digits an +1 +0 Page +0 INFO is set to 1 (or to 3 if the second test is also satis- + fied). +0 Second convergence test. If D is a diagonal matrix (implicitly + generated by LMSTR1) whose entries contain scale factors for + the variables, then this test attempts to guarantee that +0 ENORM(D*(X-XSOL)) .LE. TOL*ENORM(D*XSOL). +0 If this condition is satisfied with TOL = 10**(-K), then the + larger components of D*X have K significant decimal digits an + INFO is set to 2 (or to 3 if the first test is also satis- + fied). There is a danger that the smaller components of D*X + may have large relative errors, but the choice of D is such + that the accuracy of the components of X is usually related t + their sensitivity. +0 Third convergence test. This test is satisfied when FVEC is + orthogonal to the columns of the Jacobian to machine preci- + sion. There is no clear relationship between this test and + the accuracy of LMSTR1, and furthermore, the test is equally + well satisfied at other critical points, namely maximizers an + saddle points. Therefore, termination caused by this test + (INFO = 4) should be examined carefully. +0 + 5. Unsuccessful completion. +0 Unsuccessful termination of LMSTR1 can be due to improper input + parameters, arithmetic interrupts, or an excessive number of + function evaluations. +0 Improper input parameters. INFO is set to 0 if N .LE. 0, or + M .LT. N, or LDFJAC .LT. N, or TOL .LT. 0.E0, or + LWA .LT. 5*N+M. +0 Arithmetic interrupts. If these interrupts occur in the FCN + subroutine during an early stage of the computation, they may + be caused by an unacceptable choice of X by LMSTR1. In this + case, it may be possible to remedy the situation by not evalu + ating the functions here, but instead setting the components + of FVEC to numbers that exceed those in the initial FVEC, + thereby indirectly reducing the step length. The step length + can be more directly controlled by using instead LMSTR, which + includes in its calling sequence the step-length- governing + parameter FACTOR. +0 Excessive number of function evaluations. If the number of + calls to FCN with IFLAG = 1 reaches 100*(N+1), then this indi + cates that the routine is converging very slowly as measured + by the progress of FVEC, and INFO is set to 5. In this case, + it may be helpful to restart LMSTR1, thereby forcing it to + disregard old (and possibly harmful) information. +1 +0 Page +0 + 6. Characteristics of the algorithm. +0 LMSTR1 is a modification of the Levenberg-Marquardt algorithm. + Two of its main characteristics involve the proper use of + implicitly scaled variables and an optimal choice for the cor- + rection. The use of implicitly scaled variables achieves scale + invariance of LMSTR1 and limits the size of the correction in + any direction where the functions are changing rapidly. The + optimal choice of the correction guarantees (under reasonable + conditions) global convergence from starting points far from th + solution and a fast rate of convergence for problems with small + residuals. +0 Timing. The time required by LMSTR1 to solve a given problem + depends on M and N, the behavior of the functions, the accu- + racy requested, and the starting point. The number of arith- + metic operations needed by LMSTR1 is about N**3 to process + each evaluation of the functions (call to FCN with IFLAG = 1) + and 1.5*(N**2) to process each row of the Jacobian (call to + FCN with IFLAG .GE. 2). Unless FCN can be evaluated quickly, + the timing of LMSTR1 will be strongly influenced by the time + spent in FCN. +0 Storage. LMSTR1 requires N**2 + 2*M + 6*N single precision sto + rage locations and N integer storage locations, in addition t + the storage required by the program. There are no internally + declared storage arrays. +0 + 7. Subprograms required. +0 USER-supplied ...... FCN +0 MINPACK-supplied ... SPMPAR,ENORM,LMSTR,LMPAR,QRFAC,QRSOLV, + RWUPDT +0 FORTRAN-supplied ... ABS,AMAX1,AMIN1,SQRT,MOD +0 + 8. References. +0 Jorge J. More, The Levenberg-Marquardt Algorithm, Implementatio + and Theory. Numerical Analysis, G. A. Watson, editor. + Lecture Notes in Mathematics 630, Springer-Verlag, 1977. +0 + 9. Example. +0 The problem is to determine the values of x(1), x(2), and x(3) + which provide the best fit (in the least squares sense) of +0 x(1) + u(i)/(v(i)*x(2) + w(i)*x(3)), i = 1, 15 +1 +0 Page +0 to the data +0 y = (0.14,0.18,0.22,0.25,0.29,0.32,0.35,0.39, + 0.37,0.58,0.73,0.96,1.34,2.10,4.39), +0 where u(i) = i, v(i) = 16 - i, and w(i) = min(u(i),v(i)). The + i-th component of FVEC is thus defined by +0 y(i) - (x(1) + u(i)/(v(i)*x(2) + w(i)*x(3))). +0 C ********** + C + C DRIVER FOR LMSTR1 EXAMPLE. + C SINGLE PRECISION VERSION + C + C ********** + INTEGER J,M,N,LDFJAC,INFO,LWA,NWRITE + INTEGER IPVT(3) + REAL TOL,FNORM + REAL X(3),FVEC(15),FJAC(3,3),WA(30) + REAL ENORM,SPMPAR + EXTERNAL FCN + C + C LOGICAL OUTPUT UNIT IS ASSUMED TO BE NUMBER 6. + C + DATA NWRITE /6/ + C + M = 15 + N = 3 + C + C THE FOLLOWING STARTING VALUES PROVIDE A ROUGH FIT. + C + X(1) = 1.E0 + X(2) = 1.E0 + X(3) = 1.E0 + C + LDFJAC = 3 + LWA = 30 + C + C SET TOL TO THE SQUARE ROOT OF THE MACHINE PRECISION. + C UNLESS HIGH PRECISION SOLUTIONS ARE REQUIRED, + C THIS IS THE RECOMMENDED SETTING. + C + TOL = SQRT(SPMPAR(1)) + C + CALL LMSTR1(FCN,M,N,X,FVEC,FJAC,LDFJAC,TOL, + * INFO,IPVT,WA,LWA) + FNORM = ENORM(M,FVEC) + WRITE (NWRITE,1000) FNORM,INFO,(X(J),J=1,N) + STOP + 1000 FORMAT (5X,31H FINAL L2 NORM OF THE RESIDUALS,E15.7 // + * 5X,15H EXIT PARAMETER,16X,I10 // + * 5X,27H FINAL APPROXIMATE SOLUTION // 5X,3E15.7) + C +1 +0 Page +0 C LAST CARD OF DRIVER FOR LMSTR1 EXAMPLE. + C + END + SUBROUTINE FCN(M,N,X,FVEC,FJROW,IFLAG) + INTEGER M,N,IFLAG + REAL X(N),FVEC(M),FJROW(N) + C + C SUBROUTINE FCN FOR LMSTR1 EXAMPLE. + C + INTEGER I + REAL TMP1,TMP2,TMP3,TMP4 + REAL Y(15) + DATA Y(1),Y(2),Y(3),Y(4),Y(5),Y(6),Y(7),Y(8), + * Y(9),Y(10),Y(11),Y(12),Y(13),Y(14),Y(15) + * /1.4E-1,1.8E-1,2.2E-1,2.5E-1,2.9E-1,3.2E-1,3.5E-1,3.9E-1, + * 3.7E-1,5.8E-1,7.3E-1,9.6E-1,1.34E0,2.1E0,4.39E0/ + C + IF (IFLAG .GE. 2) GO TO 20 + DO 10 I = 1, 15 + TMP1 = I + TMP2 = 16 - I + TMP3 = TMP1 + IF (I .GT. 8) TMP3 = TMP2 + FVEC(I) = Y(I) - (X(1) + TMP1/(X(2)*TMP2 + X(3)*TMP3)) + 10 CONTINUE + GO TO 40 + 20 CONTINUE + I = IFLAG - 1 + TMP1 = I + TMP2 = 16 - I + TMP3 = TMP1 + IF (I .GT. 8) TMP3 = TMP2 + TMP4 = (X(2)*TMP2 + X(3)*TMP3)**2 + FJROW(1) = -1.E0 + FJROW(2) = TMP1*TMP2/TMP4 + FJROW(3) = TMP1*TMP3/TMP4 + 30 CONTINUE + 40 CONTINUE + RETURN + C + C LAST CARD OF SUBROUTINE FCN. + C + END +0 Results obtained with different compilers or machines + may be slightly different. +0 FINAL L2 NORM OF THE RESIDUALS 0.9063596E-01 +0 EXIT PARAMETER 1 +0 FINAL APPROXIMATE SOLUTION +0 0.8241058E-01 0.1133037E+01 0.2343695E+01 +1 +0 +1 +0 Page +0 Documentation for MINPACK subroutine LMSTR +0 Single precision version +0 Argonne National Laboratory +0 Burton S. Garbow, Kenneth E. Hillstrom, Jorge J. More +0 March 1980 +0 + 1. Purpose. +0 The purpose of LMSTR is to minimize the sum of the squares of M + nonlinear functions in N variables by a modification of the + Levenberg-Marquardt algorithm which uses minimal storage. The + user must provide a subroutine which calculates the functions + and the rows of the Jacobian. +0 + 2. Subroutine and type statements. +0 SUBROUTINE LMSTR(FCN,M,N,X,FVEC,FJAC,LDFJAC,FTOL,XTOL,GTOL, + * MAXFEV,DIAG,MODE,FACTOR,NPRINT,INFO,NFEV,NJEV, + * IPVT,QTF,WA1,WA2,WA3,WA4) + INTEGER M,N,LDFJAC,MAXFEV,MODE,NPRINT,INFO,NFEV,NJEV + INTEGER IPVT(N) + REAL FTOL,XTOL,GTOL,FACTOR + REAL X(N),FVEC(M),FJAC(LDFJAC,N),DIAG(N),QTF(N), + * WA1(N),WA2(N),WA3(N),WA4(M) +0 + 3. Parameters. +0 Parameters designated as input parameters must be specified on + entry to LMSTR and are not changed on exit, while parameters + designated as output parameters need not be specified on entry + and are set to appropriate values on exit from LMSTR. +0 FCN is the name of the user-supplied subroutine which calculate + the functions and the rows of the Jacobian. FCN must be + declared in an EXTERNAL statement in the user calling program + and should be written as follows. +0 SUBROUTINE FCN(M,N,X,FVEC,FJROW,IFLAG) + INTEGER M,N,IFLAG + REAL X(N),FVEC(M),FJROW(N) + ---------- + IF IFLAG = 1 CALCULATE THE FUNCTIONS AT X AND + RETURN THIS VECTOR IN FVEC. + IF IFLAG = I CALCULATE THE (I-1)-ST ROW OF THE + JACOBIAN AT X AND RETURN THIS VECTOR IN FJROW. + ---------- + RETURN +1 +0 Page +0 END +0 The value of IFLAG should not be changed by FCN unless the + user wants to terminate execution of LMSTR. In this case set + IFLAG to a negative integer. +0 M is a positive integer input variable set to the number of + functions. +0 N is a positive integer input variable set to the number of + variables. N must not exceed M. +0 X is an array of length N. On input X must contain an initial + estimate of the solution vector. On output X contains the + final estimate of the solution vector. +0 FVEC is an output array of length M which contains the function + evaluated at the output X. +0 FJAC is an output N by N array. The upper triangle of FJAC con + tains an upper triangular matrix R such that +0 T T T + P *(JAC *JAC)*P = R *R, +0 where P is a permutation matrix and JAC is the final calcu- + lated Jacobian. Column j of P is column IPVT(j) (see below) + of the identity matrix. The lower triangular part of FJAC + contains information generated during the computation of R. +0 LDFJAC is a positive integer input variable not less than N + which specifies the leading dimension of the array FJAC. +0 FTOL is a nonnegative input variable. Termination occurs when + both the actual and predicted relative reductions in the sum + of squares are at most FTOL. Therefore, FTOL measures the + relative error desired in the sum of squares. Section 4 con- + tains more details about FTOL. +0 XTOL is a nonnegative input variable. Termination occurs when + the relative error between two consecutive iterates is at mos + XTOL. Therefore, XTOL measures the relative error desired in + the approximate solution. Section 4 contains more details + about XTOL. +0 GTOL is a nonnegative input variable. Termination occurs when + the cosine of the angle between FVEC and any column of the + Jacobian is at most GTOL in absolute value. Therefore, GTOL + measures the orthogonality desired between the function vecto + and the columns of the Jacobian. Section 4 contains more + details about GTOL. +0 MAXFEV is a positive integer input variable. Termination occur + when the number of calls to FCN with IFLAG = 1 has reached +1 +0 Page +0 MAXFEV. +0 DIAG is an array of length N. If MODE = 1 (see below), DIAG is + internally set. If MODE = 2, DIAG must contain positive + entries that serve as multiplicative scale factors for the + variables. +0 MODE is an integer input variable. If MODE = 1, the variables + will be scaled internally. If MODE = 2, the scaling is speci + fied by the input DIAG. Other values of MODE are equivalent + to MODE = 1. +0 FACTOR is a positive input variable used in determining the ini + tial step bound. This bound is set to the product of FACTOR + and the Euclidean norm of DIAG*X if nonzero, or else to FACTO + itself. In most cases FACTOR should lie in the interval + (.1,100.). 100. is a generally recommended value. +0 NPRINT is an integer input variable that enables controlled + printing of iterates if it is positive. In this case, FCN is + called with IFLAG = 0 at the beginning of the first iteration + and every NPRINT iterations thereafter and immediately prior + to return, with X and FVEC available for printing. If NPRINT + is not positive, no special calls of FCN with IFLAG = 0 are + made. +0 INFO is an integer output variable. If the user has terminated + execution, INFO is set to the (negative) value of IFLAG. See + description of FCN. Otherwise, INFO is set as follows. +0 INFO = 0 Improper input parameters. +0 INFO = 1 Both actual and predicted relative reductions in th + sum of squares are at most FTOL. +0 INFO = 2 Relative error between two consecutive iterates is + at most XTOL. +0 INFO = 3 Conditions for INFO = 1 and INFO = 2 both hold. +0 INFO = 4 The cosine of the angle between FVEC and any column + of the Jacobian is at most GTOL in absolute value. +0 INFO = 5 Number of calls to FCN with IFLAG = 1 has reached + MAXFEV. +0 INFO = 6 FTOL is too small. No further reduction in the sum + of squares is possible. +0 INFO = 7 XTOL is too small. No further improvement in the + approximate solution X is possible. +0 INFO = 8 GTOL is too small. FVEC is orthogonal to the + columns of the Jacobian to machine precision. +1 +0 Page +0 Sections 4 and 5 contain more details about INFO. +0 NFEV is an integer output variable set to the number of calls t + FCN with IFLAG = 1. +0 NJEV is an integer output variable set to the number of calls t + FCN with IFLAG = 2. +0 IPVT is an integer output array of length N. IPVT defines a + permutation matrix P such that JAC*P = Q*R, where JAC is the + final calculated Jacobian, Q is orthogonal (not stored), and + is upper triangular. Column j of P is column IPVT(j) of the + identity matrix. +0 QTF is an output array of length N which contains the first N + elements of the vector (Q transpose)*FVEC. +0 WA1, WA2, and WA3 are work arrays of length N. +0 WA4 is a work array of length M. +0 + 4. Successful completion. +0 The accuracy of LMSTR is controlled by the convergence parame- + ters FTOL, XTOL, and GTOL. These parameters are used in tests + which make three types of comparisons between the approximation + X and a solution XSOL. LMSTR terminates when any of the tests + is satisfied. If any of the convergence parameters is less tha + the machine precision (as defined by the MINPACK function + SPMPAR(1)), then LMSTR only attempts to satisfy the test define + by the machine precision. Further progress is not usually pos- + sible. +0 The tests assume that the functions and the Jacobian are coded + consistently, and that the functions are reasonably well + behaved. If these conditions are not satisfied, then LMSTR may + incorrectly indicate convergence. The coding of the Jacobian + can be checked by the MINPACK subroutine CHKDER. If the Jaco- + bian is coded correctly, then the validity of the answer can be + checked, for example, by rerunning LMSTR with tighter toler- + ances. +0 First convergence test. If ENORM(Z) denotes the Euclidean norm + of a vector Z, then this test attempts to guarantee that +0 ENORM(FVEC) .LE. (1+FTOL)*ENORM(FVECS), +0 where FVECS denotes the functions evaluated at XSOL. If this + condition is satisfied with FTOL = 10**(-K), then the final + residual norm ENORM(FVEC) has K significant decimal digits an + INFO is set to 1 (or to 3 if the second test is also satis- + fied). Unless high precision solutions are required, the + recommended value for FTOL is the square root of the machine +1 +0 Page +0 precision. +0 Second convergence test. If D is the diagonal matrix whose + entries are defined by the array DIAG, then this test attempt + to guarantee that +0 ENORM(D*(X-XSOL)) .LE. XTOL*ENORM(D*XSOL). +0 If this condition is satisfied with XTOL = 10**(-K), then the + larger components of D*X have K significant decimal digits an + INFO is set to 2 (or to 3 if the first test is also satis- + fied). There is a danger that the smaller components of D*X + may have large relative errors, but if MODE = 1, then the + accuracy of the components of X is usually related to their + sensitivity. Unless high precision solutions are required, + the recommended value for XTOL is the square root of the + machine precision. +0 Third convergence test. This test is satisfied when the cosine + of the angle between FVEC and any column of the Jacobian at X + is at most GTOL in absolute value. There is no clear rela- + tionship between this test and the accuracy of LMSTR, and + furthermore, the test is equally well satisfied at other crit + ical points, namely maximizers and saddle points. Therefore, + termination caused by this test (INFO = 4) should be examined + carefully. The recommended value for GTOL is zero. +0 + 5. Unsuccessful completion. +0 Unsuccessful termination of LMSTR can be due to improper input + parameters, arithmetic interrupts, or an excessive number of + function evaluations. +0 Improper input parameters. INFO is set to 0 if N .LE. 0, or + M .LT. N, or LDFJAC .LT. N, or FTOL .LT. 0.E0, or + XTOL .LT. 0.E0, or GTOL .LT. 0.E0, or MAXFEV .LE. 0, or + FACTOR .LE. 0.E0. +0 Arithmetic interrupts. If these interrupts occur in the FCN + subroutine during an early stage of the computation, they may + be caused by an unacceptable choice of X by LMSTR. In this + case, it may be possible to remedy the situation by rerunning + LMSTR with a smaller value of FACTOR. +0 Excessive number of function evaluations. A reasonable value + for MAXFEV is 100*(N+1). If the number of calls to FCN with + IFLAG = 1 reaches MAXFEV, then this indicates that the routin + is converging very slowly as measured by the progress of FVEC + and INFO is set to 5. In this case, it may be helpful to + restart LMSTR with MODE set to 1. +0 + 6. Characteristics of the algorithm. +1 +0 Page +0 LMSTR is a modification of the Levenberg-Marquardt algorithm. + Two of its main characteristics involve the proper use of + implicitly scaled variables (if MODE = 1) and an optimal choice + for the correction. The use of implicitly scaled variables + achieves scale invariance of LMSTR and limits the size of the + correction in any direction where the functions are changing + rapidly. The optimal choice of the correction guarantees (unde + reasonable conditions) global convergence from starting points + far from the solution and a fast rate of convergence for prob- + lems with small residuals. +0 Timing. The time required by LMSTR to solve a given problem + depends on M and N, the behavior of the functions, the accu- + racy requested, and the starting point. The number of arith- + metic operations needed by LMSTR is about N**3 to process eac + evaluation of the functions (call to FCN with IFLAG = 1) and + 1.5*(N**2) to process each row of the Jacobian (call to FCN + with IFLAG .GE. 2). Unless FCN can be evaluated quickly, the + timing of LMSTR will be strongly influenced by the time spent + in FCN. +0 Storage. LMSTR requires N**2 + 2*M + 6*N single precision sto- + rage locations and N integer storage locations, in addition t + the storage required by the program. There are no internally + declared storage arrays. +0 + 7. Subprograms required. +0 USER-supplied ...... FCN +0 MINPACK-supplied ... SPMPAR,ENORM,LMPAR,QRFAC,QRSOLV,RWUPDT +0 FORTRAN-supplied ... ABS,AMAX1,AMIN1,SQRT,MOD +0 + 8. References. +0 Jorge J. More, The Levenberg-Marquardt Algorithm, Implementatio + and Theory. Numerical Analysis, G. A. Watson, editor. + Lecture Notes in Mathematics 630, Springer-Verlag, 1977. +0 + 9. Example. +0 The problem is to determine the values of x(1), x(2), and x(3) + which provide the best fit (in the least squares sense) of +0 x(1) + u(i)/(v(i)*x(2) + w(i)*x(3)), i = 1, 15 +0 to the data +0 y = (0.14,0.18,0.22,0.25,0.29,0.32,0.35,0.39, + 0.37,0.58,0.73,0.96,1.34,2.10,4.39), +1 +0 Page +0 where u(i) = i, v(i) = 16 - i, and w(i) = min(u(i),v(i)). The + i-th component of FVEC is thus defined by +0 y(i) - (x(1) + u(i)/(v(i)*x(2) + w(i)*x(3))). +0 C ********** + C + C DRIVER FOR LMSTR EXAMPLE. + C SINGLE PRECISION VERSION + C + C ********** + INTEGER J,M,N,LDFJAC,MAXFEV,MODE,NPRINT,INFO,NFEV,NJEV,NWRITE + INTEGER IPVT(3) + REAL FTOL,XTOL,GTOL,FACTOR,FNORM + REAL X(3),FVEC(15),FJAC(3,3),DIAG(3),QTF(3), + * WA1(3),WA2(3),WA3(3),WA4(15) + REAL ENORM,SPMPAR + EXTERNAL FCN + C + C LOGICAL OUTPUT UNIT IS ASSUMED TO BE NUMBER 6. + C + DATA NWRITE /6/ + C + M = 15 + N = 3 + C + C THE FOLLOWING STARTING VALUES PROVIDE A ROUGH FIT. + C + X(1) = 1.E0 + X(2) = 1.E0 + X(3) = 1.E0 + C + LDFJAC = 3 + C + C SET FTOL AND XTOL TO THE SQUARE ROOT OF THE MACHINE PRECISION + C AND GTOL TO ZERO. UNLESS HIGH PRECISION SOLUTIONS ARE + C REQUIRED, THESE ARE THE RECOMMENDED SETTINGS. + C + FTOL = SQRT(SPMPAR(1)) + XTOL = SQRT(SPMPAR(1)) + GTOL = 0.E0 + C + MAXFEV = 400 + MODE = 1 + FACTOR = 1.E2 + NPRINT = 0 + C + CALL LMSTR(FCN,M,N,X,FVEC,FJAC,LDFJAC,FTOL,XTOL,GTOL, + * MAXFEV,DIAG,MODE,FACTOR,NPRINT,INFO,NFEV,NJEV, + * IPVT,QTF,WA1,WA2,WA3,WA4) + FNORM = ENORM(M,FVEC) + WRITE (NWRITE,1000) FNORM,NFEV,NJEV,INFO,(X(J),J=1,N) + STOP + 1000 FORMAT (5X,31H FINAL L2 NORM OF THE RESIDUALS,E15.7 // +1 +0 Page +0 * 5X,31H NUMBER OF FUNCTION EVALUATIONS,I10 // + * 5X,31H NUMBER OF JACOBIAN EVALUATIONS,I10 // + * 5X,15H EXIT PARAMETER,16X,I10 // + * 5X,27H FINAL APPROXIMATE SOLUTION // 5X,3E15.7) + C + C LAST CARD OF DRIVER FOR LMSTR EXAMPLE. + C + END + SUBROUTINE FCN(M,N,X,FVEC,FJROW,IFLAG) + INTEGER M,N,IFLAG + REAL X(N),FVEC(M),FJROW(N) + C + C SUBROUTINE FCN FOR LMSTR EXAMPLE. + C + INTEGER I + REAL TMP1,TMP2,TMP3,TMP4 + REAL Y(15) + DATA Y(1),Y(2),Y(3),Y(4),Y(5),Y(6),Y(7),Y(8), + * Y(9),Y(10),Y(11),Y(12),Y(13),Y(14),Y(15) + * /1.4E-1,1.8E-1,2.2E-1,2.5E-1,2.9E-1,3.2E-1,3.5E-1,3.9E-1, + * 3.7E-1,5.8E-1,7.3E-1,9.6E-1,1.34E0,2.1E0,4.39E0/ + C + IF (IFLAG .NE. 0) GO TO 5 + C + C INSERT PRINT STATEMENTS HERE WHEN NPRINT IS POSITIVE. + C + RETURN + 5 CONTINUE + IF (IFLAG .GE. 2) GO TO 20 + DO 10 I = 1, 15 + TMP1 = I + TMP2 = 16 - I + TMP3 = TMP1 + IF (I .GT. 8) TMP3 = TMP2 + FVEC(I) = Y(I) - (X(1) + TMP1/(X(2)*TMP2 + X(3)*TMP3)) + 10 CONTINUE + GO TO 40 + 20 CONTINUE + I = IFLAG - 1 + TMP1 = I + TMP2 = 16 - I + TMP3 = TMP1 + IF (I .GT. 8) TMP3 = TMP2 + TMP4 = (X(2)*TMP2 + X(3)*TMP3)**2 + FJROW(1) = -1.E0 + FJROW(2) = TMP1*TMP2/TMP4 + FJROW(3) = TMP1*TMP3/TMP4 + 30 CONTINUE + 40 CONTINUE + RETURN + C + C LAST CARD OF SUBROUTINE FCN. + C + END +1 +0 Page +0 Results obtained with different compilers or machines + may be slightly different. +0 FINAL L2 NORM OF THE RESIDUALS 0.9063596E-01 +0 NUMBER OF FUNCTION EVALUATIONS 6 +0 NUMBER OF JACOBIAN EVALUATIONS 5 +0 EXIT PARAMETER 1 +0 FINAL APPROXIMATE SOLUTION +0 0.8241058E-01 0.1133037E+01 0.2343695E+01 +1 +0 +1 +0 Page +0 Documentation for MINPACK subroutine LMDIF1 +0 Single precision version +0 Argonne National Laboratory +0 Burton S. Garbow, Kenneth E. Hillstrom, Jorge J. More +0 March 1980 +0 + 1. Purpose. +0 The purpose of LMDIF1 is to minimize the sum of the squares of + nonlinear functions in N variables by a modification of the + Levenberg-Marquardt algorithm. This is done by using the more + general least-squares solver LMDIF. The user must provide a + subroutine which calculates the functions. The Jacobian is the + calculated by a forward-difference approximation. +0 + 2. Subroutine and type statements. +0 SUBROUTINE LMDIF1(FCN,M,N,X,FVEC,TOL,INFO,IWA,WA,LWA) + INTEGER M,N,INFO,LWA + INTEGER IWA(N) + REAL TOL + REAL X(N),FVEC(M),WA(LWA) + EXTERNAL FCN +0 + 3. Parameters. +0 Parameters designated as input parameters must be specified on + entry to LMDIF1 and are not changed on exit, while parameters + designated as output parameters need not be specified on entry + and are set to appropriate values on exit from LMDIF1. +0 FCN is the name of the user-supplied subroutine which calculate + the functions. FCN must be declared in an EXTERNAL statement + in the user calling program, and should be written as follows +0 SUBROUTINE FCN(M,N,X,FVEC,IFLAG) + INTEGER M,N,IFLAG + REAL X(N),FVEC(M) + ---------- + CALCULATE THE FUNCTIONS AT X AND + RETURN THIS VECTOR IN FVEC. + ---------- + RETURN + END +0 The value of IFLAG should not be changed by FCN unless the + user wants to terminate execution of LMDIF1. In this case se +1 +0 Page +0 IFLAG to a negative integer. +0 M is a positive integer input variable set to the number of + functions. +0 N is a positive integer input variable set to the number of + variables. N must not exceed M. +0 X is an array of length N. On input X must contain an initial + estimate of the solution vector. On output X contains the + final estimate of the solution vector. +0 FVEC is an output array of length M which contains the function + evaluated at the output X. +0 TOL is a nonnegative input variable. Termination occurs when + the algorithm estimates either that the relative error in the + sum of squares is at most TOL or that the relative error + between X and the solution is at most TOL. Section 4 contain + more details about TOL. +0 INFO is an integer output variable. If the user has terminated + execution, INFO is set to the (negative) value of IFLAG. See + description of FCN. Otherwise, INFO is set as follows. +0 INFO = 0 Improper input parameters. +0 INFO = 1 Algorithm estimates that the relative error in the + sum of squares is at most TOL. +0 INFO = 2 Algorithm estimates that the relative error between + X and the solution is at most TOL. +0 INFO = 3 Conditions for INFO = 1 and INFO = 2 both hold. +0 INFO = 4 FVEC is orthogonal to the columns of the Jacobian t + machine precision. +0 INFO = 5 Number of calls to FCN has reached or exceeded + 200*(N+1). +0 INFO = 6 TOL is too small. No further reduction in the sum + of squares is possible. +0 INFO = 7 TOL is too small. No further improvement in the + approximate solution X is possible. +0 Sections 4 and 5 contain more details about INFO. +0 IWA is an integer work array of length N. +0 WA is a work array of length LWA. +0 LWA is a positive integer input variable not less than +1 +0 Page +0 M*N+5*N+M. +0 + 4. Successful completion. +0 The accuracy of LMDIF1 is controlled by the convergence parame- + ter TOL. This parameter is used in tests which make three type + of comparisons between the approximation X and a solution XSOL. + LMDIF1 terminates when any of the tests is satisfied. If TOL i + less than the machine precision (as defined by the MINPACK func + tion SPMPAR(1)), then LMDIF1 only attempts to satisfy the test + defined by the machine precision. Further progress is not usu- + ally possible. Unless high precision solutions are required, + the recommended value for TOL is the square root of the machine + precision. +0 The tests assume that the functions are reasonably well behaved + If this condition is not satisfied, then LMDIF1 may incorrectly + indicate convergence. The validity of the answer can be + checked, for example, by rerunning LMDIF1 with a tighter toler- + ance. +0 First convergence test. If ENORM(Z) denotes the Euclidean norm + of a vector Z, then this test attempts to guarantee that +0 ENORM(FVEC) .LE. (1+TOL)*ENORM(FVECS), +0 where FVECS denotes the functions evaluated at XSOL. If this + condition is satisfied with TOL = 10**(-K), then the final + residual norm ENORM(FVEC) has K significant decimal digits an + INFO is set to 1 (or to 3 if the second test is also satis- + fied). +0 Second convergence test. If D is a diagonal matrix (implicitly + generated by LMDIF1) whose entries contain scale factors for + the variables, then this test attempts to guarantee that +0 ENORM(D*(X-XSOL)) .LE. TOL*ENORM(D*XSOL). +0 If this condition is satisfied with TOL = 10**(-K), then the + larger components of D*X have K significant decimal digits an + INFO is set to 2 (or to 3 if the first test is also satis- + fied). There is a danger that the smaller components of D*X + may have large relative errors, but the choice of D is such + that the accuracy of the components of X is usually related t + their sensitivity. +0 Third convergence test. This test is satisfied when FVEC is + orthogonal to the columns of the Jacobian to machine preci- + sion. There is no clear relationship between this test and + the accuracy of LMDIF1, and furthermore, the test is equally + well satisfied at other critical points, namely maximizers an + saddle points. Also, errors in the functions (see below) may + result in the test being satisfied at a point not close to th +1 +0 Page +0 minimum. Therefore, termination caused by this test + (INFO = 4) should be examined carefully. +0 + 5. Unsuccessful completion. +0 Unsuccessful termination of LMDIF1 can be due to improper input + parameters, arithmetic interrupts, an excessive number of func- + tion evaluations, or errors in the functions. +0 Improper input parameters. INFO is set to 0 if N .LE. 0, or + M .LT. N, or TOL .LT. 0.E0, or LWA .LT. M*N+5*N+M. +0 Arithmetic interrupts. If these interrupts occur in the FCN + subroutine during an early stage of the computation, they may + be caused by an unacceptable choice of X by LMDIF1. In this + case, it may be possible to remedy the situation by not evalu + ating the functions here, but instead setting the components + of FVEC to numbers that exceed those in the initial FVEC, + thereby indirectly reducing the step length. The step length + can be more directly controlled by using instead LMDIF, which + includes in its calling sequence the step-length-governing + parameter FACTOR. +0 Excessive number of function evaluations. If the number of + calls to FCN reaches 200*(N+1), then this indicates that the + routine is converging very slowly as measured by the progress + of FVEC, and INFO is set to 5. In this case, it may be help- + ful to restart LMDIF1, thereby forcing it to disregard old + (and possibly harmful) information. +0 Errors in the functions. The choice of step length in the for- + ward-difference approximation to the Jacobian assumes that th + relative errors in the functions are of the order of the + machine precision. If this is not the case, LMDIF1 may fail + (usually with INFO = 4). The user should then use LMDIF + instead, or one of the programs which require the analytic + Jacobian (LMDER1 and LMDER). +0 + 6. Characteristics of the algorithm. +0 LMDIF1 is a modification of the Levenberg-Marquardt algorithm. + Two of its main characteristics involve the proper use of + implicitly scaled variables and an optimal choice for the cor- + rection. The use of implicitly scaled variables achieves scale + invariance of LMDIF1 and limits the size of the correction in + any direction where the functions are changing rapidly. The + optimal choice of the correction guarantees (under reasonable + conditions) global convergence from starting points far from th + solution and a fast rate of convergence for problems with small + residuals. +0 Timing. The time required by LMDIF1 to solve a given problem +1 +0 Page +0 depends on M and N, the behavior of the functions, the accu- + racy requested, and the starting point. The number of arith- + metic operations needed by LMDIF1 is about N**3 to process + each evaluation of the functions (one call to FCN) and + M*(N**2) to process each approximation to the Jacobian (N + calls to FCN). Unless FCN can be evaluated quickly, the tim- + ing of LMDIF1 will be strongly influenced by the time spent i + FCN. +0 Storage. LMDIF1 requires M*N + 2*M + 6*N single precision sto- + rage locations and N integer storage locations, in addition t + the storage required by the program. There are no internally + declared storage arrays. +0 + 7. Subprograms required. +0 USER-supplied ...... FCN +0 MINPACK-supplied ... SPMPAR,ENORM,FDJAC2,LMDIF,LMPAR, + QRFAC,QRSOLV +0 FORTRAN-supplied ... ABS,AMAX1,AMIN1,SQRT,MOD +0 + 8. References. +0 Jorge J. More, The Levenberg-Marquardt Algorithm, Implementatio + and Theory. Numerical Analysis, G. A. Watson, editor. + Lecture Notes in Mathematics 630, Springer-Verlag, 1977. +0 + 9. Example. +0 The problem is to determine the values of x(1), x(2), and x(3) + which provide the best fit (in the least squares sense) of +0 x(1) + u(i)/(v(i)*x(2) + w(i)*x(3)), i = 1, 15 +0 to the data +0 y = (0.14,0.18,0.22,0.25,0.29,0.32,0.35,0.39, + 0.37,0.58,0.73,0.96,1.34,2.10,4.39), +0 where u(i) = i, v(i) = 16 - i, and w(i) = min(u(i),v(i)). The + i-th component of FVEC is thus defined by +0 y(i) - (x(1) + u(i)/(v(i)*x(2) + w(i)*x(3))). +0 C ********** + C + C DRIVER FOR LMDIF1 EXAMPLE. + C SINGLE PRECISION VERSION + C +1 +0 Page +0 C ********** + INTEGER J,M,N,INFO,LWA,NWRITE + INTEGER IWA(3) + REAL TOL,FNORM + REAL X(3),FVEC(15),WA(75) + REAL ENORM,SPMPAR + EXTERNAL FCN + C + C LOGICAL OUTPUT UNIT IS ASSUMED TO BE NUMBER 6. + C + DATA NWRITE /6/ + C + M = 15 + N = 3 + C + C THE FOLLOWING STARTING VALUES PROVIDE A ROUGH FIT. + C + X(1) = 1.E0 + X(2) = 1.E0 + X(3) = 1.E0 + C + LWA = 75 + C + C SET TOL TO THE SQUARE ROOT OF THE MACHINE PRECISION. + C UNLESS HIGH PRECISION SOLUTIONS ARE REQUIRED, + C THIS IS THE RECOMMENDED SETTING. + C + TOL = SQRT(SPMPAR(1)) + C + CALL LMDIF1(FCN,M,N,X,FVEC,TOL,INFO,IWA,WA,LWA) + FNORM = ENORM(M,FVEC) + WRITE (NWRITE,1000) FNORM,INFO,(X(J),J=1,N) + STOP + 1000 FORMAT (5X,31H FINAL L2 NORM OF THE RESIDUALS,E15.7 // + * 5X,15H EXIT PARAMETER,16X,I10 // + * 5X,27H FINAL APPROXIMATE SOLUTION // 5X,3E15.7) + C + C LAST CARD OF DRIVER FOR LMDIF1 EXAMPLE. + C + END + SUBROUTINE FCN(M,N,X,FVEC,IFLAG) + INTEGER M,N,IFLAG + REAL X(N),FVEC(M) + C + C SUBROUTINE FCN FOR LMDIF1 EXAMPLE. + C + INTEGER I + REAL TMP1,TMP2,TMP3 + REAL Y(15) + DATA Y(1),Y(2),Y(3),Y(4),Y(5),Y(6),Y(7),Y(8), + * Y(9),Y(10),Y(11),Y(12),Y(13),Y(14),Y(15) + * /1.4E-1,1.8E-1,2.2E-1,2.5E-1,2.9E-1,3.2E-1,3.5E-1,3.9E-1, + * 3.7E-1,5.8E-1,7.3E-1,9.6E-1,1.34E0,2.1E0,4.39E0/ + C +1 +0 Page +0 DO 10 I = 1, 15 + TMP1 = I + TMP2 = 16 - I + TMP3 = TMP1 + IF (I .GT. 8) TMP3 = TMP2 + FVEC(I) = Y(I) - (X(1) + TMP1/(X(2)*TMP2 + X(3)*TMP3)) + 10 CONTINUE + RETURN + C + C LAST CARD OF SUBROUTINE FCN. + C + END +0 Results obtained with different compilers or machines + may be slightly different. +0 FINAL L2 NORM OF THE RESIDUALS 0.9063596E-01 +0 EXIT PARAMETER 1 +0 FINAL APPROXIMATE SOLUTION +0 0.8241057E-01 0.1133037E+01 0.2343695E+01 +1 +0 +1 +0 Page +0 Documentation for MINPACK subroutine LMDIF +0 Single precision version +0 Argonne National Laboratory +0 Burton S. Garbow, Kenneth E. Hillstrom, Jorge J. More +0 March 1980 +0 + 1. Purpose. +0 The purpose of LMDIF is to minimize the sum of the squares of M + nonlinear functions in N variables by a modification of the + Levenberg-Marquardt algorithm. The user must provide a subrou- + tine which calculates the functions. The Jacobian is then cal- + culated by a forward-difference approximation. +0 + 2. Subroutine and type statements. +0 SUBROUTINE LMDIF(FCN,M,N,X,FVEC,FTOL,XTOL,GTOL,MAXFEV,EPSFCN, + * DIAG,MODE,FACTOR,NPRINT,INFO,NFEV,FJAC,LDFJAC, + * IPVT,QTF,WA1,WA2,WA3,WA4) + INTEGER M,N,MAXFEV,MODE,NPRINT,INFO,NFEV,LDFJAC + INTEGER IPVT(N) + REAL FTOL,XTOL,GTOL,EPSFCN,FACTOR + REAL X(N),FVEC(M),DIAG(N),FJAC(LDFJAC,N),QTF(N), + * WA1(N),WA2(N),WA3(N),WA4(M) + EXTERNAL FCN +0 + 3. Parameters. +0 Parameters designated as input parameters must be specified on + entry to LMDIF and are not changed on exit, while parameters + designated as output parameters need not be specified on entry + and are set to appropriate values on exit from LMDIF. +0 FCN is the name of the user-supplied subroutine which calculate + the functions. FCN must be declared in an EXTERNAL statement + in the user calling program, and should be written as follows +0 SUBROUTINE FCN(M,N,X,FVEC,IFLAG) + INTEGER M,N,IFLAG + REAL X(N),FVEC(M) + ---------- + CALCULATE THE FUNCTIONS AT X AND + RETURN THIS VECTOR IN FVEC. + ---------- + RETURN + END +1 +0 Page +0 The value of IFLAG should not be changed by FCN unless the + user wants to terminate execution of LMDIF. In this case set + IFLAG to a negative integer. +0 M is a positive integer input variable set to the number of + functions. +0 N is a positive integer input variable set to the number of + variables. N must not exceed M. +0 X is an array of length N. On input X must contain an initial + estimate of the solution vector. On output X contains the + final estimate of the solution vector. +0 FVEC is an output array of length M which contains the function + evaluated at the output X. +0 FTOL is a nonnegative input variable. Termination occurs when + both the actual and predicted relative reductions in the sum + of squares are at most FTOL. Therefore, FTOL measures the + relative error desired in the sum of squares. Section 4 con- + tains more details about FTOL. +0 XTOL is a nonnegative input variable. Termination occurs when + the relative error between two consecutive iterates is at mos + XTOL. Therefore, XTOL measures the relative error desired in + the approximate solution. Section 4 contains more details + about XTOL. +0 GTOL is a nonnegative input variable. Termination occurs when + the cosine of the angle between FVEC and any column of the + Jacobian is at most GTOL in absolute value. Therefore, GTOL + measures the orthogonality desired between the function vecto + and the columns of the Jacobian. Section 4 contains more + details about GTOL. +0 MAXFEV is a positive integer input variable. Termination occur + when the number of calls to FCN is at least MAXFEV by the end + of an iteration. +0 EPSFCN is an input variable used in determining a suitable step + for the forward-difference approximation. This approximation + assumes that the relative errors in the functions are of the + order of EPSFCN. If EPSFCN is less than the machine preci- + sion, it is assumed that the relative errors in the functions + are of the order of the machine precision. +0 DIAG is an array of length N. If MODE = 1 (see below), DIAG is + internally set. If MODE = 2, DIAG must contain positive + entries that serve as multiplicative scale factors for the + variables. +0 MODE is an integer input variable. If MODE = 1, the variables + will be scaled internally. If MODE = 2, the scaling is +1 +0 Page +0 specified by the input DIAG. Other values of MODE are equiva + lent to MODE = 1. +0 FACTOR is a positive input variable used in determining the ini + tial step bound. This bound is set to the product of FACTOR + and the Euclidean norm of DIAG*X if nonzero, or else to FACTO + itself. In most cases FACTOR should lie in the interval + (.1,100.). 100. is a generally recommended value. +0 NPRINT is an integer input variable that enables controlled + printing of iterates if it is positive. In this case, FCN is + called with IFLAG = 0 at the beginning of the first iteration + and every NPRINT iterations thereafter and immediately prior + to return, with X and FVEC available for printing. If NPRINT + is not positive, no special calls of FCN with IFLAG = 0 are + made. +0 INFO is an integer output variable. If the user has terminated + execution, INFO is set to the (negative) value of IFLAG. See + description of FCN. Otherwise, INFO is set as follows. +0 INFO = 0 Improper input parameters. +0 INFO = 1 Both actual and predicted relative reductions in th + sum of squares are at most FTOL. +0 INFO = 2 Relative error between two consecutive iterates is + at most XTOL. +0 INFO = 3 Conditions for INFO = 1 and INFO = 2 both hold. +0 INFO = 4 The cosine of the angle between FVEC and any column + of the Jacobian is at most GTOL in absolute value. +0 INFO = 5 Number of calls to FCN has reached or exceeded + MAXFEV. +0 INFO = 6 FTOL is too small. No further reduction in the sum + of squares is possible. +0 INFO = 7 XTOL is too small. No further improvement in the + approximate solution X is possible. +0 INFO = 8 GTOL is too small. FVEC is orthogonal to the + columns of the Jacobian to machine precision. +0 Sections 4 and 5 contain more details about INFO. +0 NFEV is an integer output variable set to the number of calls t + FCN. +0 FJAC is an output M by N array. The upper N by N submatrix of + FJAC contains an upper triangular matrix R with diagonal ele- + ments of nonincreasing magnitude such that +1 +0 Page +0 T T T + P *(JAC *JAC)*P = R *R, +0 where P is a permutation matrix and JAC is the final calcu- + lated Jacobian. Column j of P is column IPVT(j) (see below) + of the identity matrix. The lower trapezoidal part of FJAC + contains information generated during the computation of R. +0 LDFJAC is a positive integer input variable not less than M + which specifies the leading dimension of the array FJAC. +0 IPVT is an integer output array of length N. IPVT defines a + permutation matrix P such that JAC*P = Q*R, where JAC is the + final calculated Jacobian, Q is orthogonal (not stored), and + is upper triangular with diagonal elements of nonincreasing + magnitude. Column j of P is column IPVT(j) of the identity + matrix. +0 QTF is an output array of length N which contains the first N + elements of the vector (Q transpose)*FVEC. +0 WA1, WA2, and WA3 are work arrays of length N. +0 WA4 is a work array of length M. +0 + 4. Successful completion. +0 The accuracy of LMDIF is controlled by the convergence parame- + ters FTOL, XTOL, and GTOL. These parameters are used in tests + which make three types of comparisons between the approximation + X and a solution XSOL. LMDIF terminates when any of the tests + is satisfied. If any of the convergence parameters is less tha + the machine precision (as defined by the MINPACK function + SPMPAR(1)), then LMDIF only attempts to satisfy the test define + by the machine precision. Further progress is not usually pos- + sible. +0 The tests assume that the functions are reasonably well behaved + If this condition is not satisfied, then LMDIF may incorrectly + indicate convergence. The validity of the answer can be + checked, for example, by rerunning LMDIF with tighter toler- + ances. +0 First convergence test. If ENORM(Z) denotes the Euclidean norm + of a vector Z, then this test attempts to guarantee that +0 ENORM(FVEC) .LE. (1+FTOL)*ENORM(FVECS), +0 where FVECS denotes the functions evaluated at XSOL. If this + condition is satisfied with FTOL = 10**(-K), then the final + residual norm ENORM(FVEC) has K significant decimal digits an + INFO is set to 1 (or to 3 if the second test is also satis- + fied). Unless high precision solutions are required, the +1 +0 Page +0 recommended value for FTOL is the square root of the machine + precision. +0 Second convergence test. If D is the diagonal matrix whose + entries are defined by the array DIAG, then this test attempt + to guarantee that +0 ENORM(D*(X-XSOL)) .LE. XTOL*ENORM(D*XSOL). +0 If this condition is satisfied with XTOL = 10**(-K), then the + larger components of D*X have K significant decimal digits an + INFO is set to 2 (or to 3 if the first test is also satis- + fied). There is a danger that the smaller components of D*X + may have large relative errors, but if MODE = 1, then the + accuracy of the components of X is usually related to their + sensitivity. Unless high precision solutions are required, + the recommended value for XTOL is the square root of the + machine precision. +0 Third convergence test. This test is satisfied when the cosine + of the angle between FVEC and any column of the Jacobian at X + is at most GTOL in absolute value. There is no clear rela- + tionship between this test and the accuracy of LMDIF, and + furthermore, the test is equally well satisfied at other crit + ical points, namely maximizers and saddle points. Therefore, + termination caused by this test (INFO = 4) should be examined + carefully. The recommended value for GTOL is zero. +0 + 5. Unsuccessful completion. +0 Unsuccessful termination of LMDIF can be due to improper input + parameters, arithmetic interrupts, or an excessive number of + function evaluations. +0 Improper input parameters. INFO is set to 0 if N .LE. 0, or + M .LT. N, or LDFJAC .LT. M, or FTOL .LT. 0.E0, or + XTOL .LT. 0.E0, or GTOL .LT. 0.E0, or MAXFEV .LE. 0, or + FACTOR .LE. 0.E0. +0 Arithmetic interrupts. If these interrupts occur in the FCN + subroutine during an early stage of the computation, they may + be caused by an unacceptable choice of X by LMDIF. In this + case, it may be possible to remedy the situation by rerunning + LMDIF with a smaller value of FACTOR. +0 Excessive number of function evaluations. A reasonable value + for MAXFEV is 200*(N+1). If the number of calls to FCN + reaches MAXFEV, then this indicates that the routine is con- + verging very slowly as measured by the progress of FVEC, and + INFO is set to 5. In this case, it may be helpful to restart + LMDIF with MODE set to 1. +0 +1 +0 Page +0 6. Characteristics of the algorithm. +0 LMDIF is a modification of the Levenberg-Marquardt algorithm. + Two of its main characteristics involve the proper use of + implicitly scaled variables (if MODE = 1) and an optimal choice + for the correction. The use of implicitly scaled variables + achieves scale invariance of LMDIF and limits the size of the + correction in any direction where the functions are changing + rapidly. The optimal choice of the correction guarantees (unde + reasonable conditions) global convergence from starting points + far from the solution and a fast rate of convergence for prob- + lems with small residuals. +0 Timing. The time required by LMDIF to solve a given problem + depends on M and N, the behavior of the functions, the accu- + racy requested, and the starting point. The number of arith- + metic operations needed by LMDIF is about N**3 to process eac + evaluation of the functions (one call to FCN) and M*(N**2) to + process each approximation to the Jacobian (N calls to FCN). + Unless FCN can be evaluated quickly, the timing of LMDIF will + be strongly influenced by the time spent in FCN. +0 Storage. LMDIF requires M*N + 2*M + 6*N single precision sto- + rage locations and N integer storage locations, in addition t + the storage required by the program. There are no internally + declared storage arrays. +0 + 7. Subprograms required. +0 USER-supplied ...... FCN +0 MINPACK-supplied ... SPMPAR,ENORM,FDJAC2,LMPAR,QRFAC,QRSOLV +0 FORTRAN-supplied ... ABS,AMAX1,AMIN1,SQRT,MOD +0 + 8. References. +0 Jorge J. More, The Levenberg-Marquardt Algorithm, Implementatio + and Theory. Numerical Analysis, G. A. Watson, editor. + Lecture Notes in Mathematics 630, Springer-Verlag, 1977. +0 + 9. Example. +0 The problem is to determine the values of x(1), x(2), and x(3) + which provide the best fit (in the least squares sense) of +0 x(1) + u(i)/(v(i)*x(2) + w(i)*x(3)), i = 1, 15 +0 to the data +1 +0 Page +0 y = (0.14,0.18,0.22,0.25,0.29,0.32,0.35,0.39, + 0.37,0.58,0.73,0.96,1.34,2.10,4.39), +0 where u(i) = i, v(i) = 16 - i, and w(i) = min(u(i),v(i)). The + i-th component of FVEC is thus defined by +0 y(i) - (x(1) + u(i)/(v(i)*x(2) + w(i)*x(3))). +0 C ********** + C + C DRIVER FOR LMDIF EXAMPLE. + C SINGLE PRECISION VERSION + C + C ********** + INTEGER J,M,N,MAXFEV,MODE,NPRINT,INFO,NFEV,LDFJAC,NWRITE + INTEGER IPVT(3) + REAL FTOL,XTOL,GTOL,EPSFCN,FACTOR,FNORM + REAL X(3),FVEC(15),DIAG(3),FJAC(15,3),QTF(3), + * WA1(3),WA2(3),WA3(3),WA4(15) + REAL ENORM,SPMPAR + EXTERNAL FCN + C + C LOGICAL OUTPUT UNIT IS ASSUMED TO BE NUMBER 6. + C + DATA NWRITE /6/ + C + M = 15 + N = 3 + C + C THE FOLLOWING STARTING VALUES PROVIDE A ROUGH FIT. + C + X(1) = 1.E0 + X(2) = 1.E0 + X(3) = 1.E0 + C + LDFJAC = 15 + C + C SET FTOL AND XTOL TO THE SQUARE ROOT OF THE MACHINE PRECISION + C AND GTOL TO ZERO. UNLESS HIGH PRECISION SOLUTIONS ARE + C REQUIRED, THESE ARE THE RECOMMENDED SETTINGS. + C + FTOL = SQRT(SPMPAR(1)) + XTOL = SQRT(SPMPAR(1)) + GTOL = 0.E0 + C + MAXFEV = 800 + EPSFCN = 0.E0 + MODE = 1 + FACTOR = 1.E2 + NPRINT = 0 + C + CALL LMDIF(FCN,M,N,X,FVEC,FTOL,XTOL,GTOL,MAXFEV,EPSFCN, + * DIAG,MODE,FACTOR,NPRINT,INFO,NFEV,FJAC,LDFJAC, + * IPVT,QTF,WA1,WA2,WA3,WA4) +1 +0 Page +0 FNORM = ENORM(M,FVEC) + WRITE (NWRITE,1000) FNORM,NFEV,INFO,(X(J),J=1,N) + STOP + 1000 FORMAT (5X,31H FINAL L2 NORM OF THE RESIDUALS,E15.7 // + * 5X,31H NUMBER OF FUNCTION EVALUATIONS,I10 // + * 5X,15H EXIT PARAMETER,16X,I10 // + * 5X,27H FINAL APPROXIMATE SOLUTION // 5X,3E15.7) + C + C LAST CARD OF DRIVER FOR LMDIF EXAMPLE. + C + END + SUBROUTINE FCN(M,N,X,FVEC,IFLAG) + INTEGER M,N,IFLAG + REAL X(N),FVEC(M) + C + C SUBROUTINE FCN FOR LMDIF EXAMPLE. + C + INTEGER I + REAL TMP1,TMP2,TMP3 + REAL Y(15) + DATA Y(1),Y(2),Y(3),Y(4),Y(5),Y(6),Y(7),Y(8), + * Y(9),Y(10),Y(11),Y(12),Y(13),Y(14),Y(15) + * /1.4E-1,1.8E-1,2.2E-1,2.5E-1,2.9E-1,3.2E-1,3.5E-1,3.9E-1, + * 3.7E-1,5.8E-1,7.3E-1,9.6E-1,1.34E0,2.1E0,4.39E0/ + C + IF (IFLAG .NE. 0) GO TO 5 + C + C INSERT PRINT STATEMENTS HERE WHEN NPRINT IS POSITIVE. + C + RETURN + 5 CONTINUE + DO 10 I = 1, 15 + TMP1 = I + TMP2 = 16 - I + TMP3 = TMP1 + IF (I .GT. 8) TMP3 = TMP2 + FVEC(I) = Y(I) - (X(1) + TMP1/(X(2)*TMP2 + X(3)*TMP3)) + 10 CONTINUE + RETURN + C + C LAST CARD OF SUBROUTINE FCN. + C + END +0 Results obtained with different compilers or machines + may be slightly different. +0 FINAL L2 NORM OF THE RESIDUALS 0.9063596E-01 +0 NUMBER OF FUNCTION EVALUATIONS 21 +0 EXIT PARAMETER 1 +0 FINAL APPROXIMATE SOLUTION +1 +0 Page +0 0.8241057E-01 0.1133037E+01 0.2343695E+01 +1 +0 +1 +0 Page +0 Documentation for MINPACK subroutine CHKDER +0 Single precision version +0 Argonne National Laboratory +0 Burton S. Garbow, Kenneth E. Hillstrom, Jorge J. More +0 March 1980 +0 + 1. Purpose. +0 The purpose of CHKDER is to check the gradients of M nonlinear + functions in N variables, evaluated at a point X, for consis- + tency with the functions themselves. The user must call CHKDER + twice, first with MODE = 1 and then with MODE = 2. +0 + 2. Subroutine and type statements. +0 SUBROUTINE CHKDER(M,N,X,FVEC,FJAC,LDFJAC,XP,FVECP,MODE,ERR) + INTEGER M,N,LDFJAC,MODE + REAL X(N),FVEC(M),FJAC(LDFJAC,N),XP(N),FVECP(M),ERR(M) +0 + 3. Parameters. +0 Parameters designated as input parameters must be specified on + entry to CHKDER and are not changed on exit, while parameters + designated as output parameters need not be specified on entry + and are set to appropriate values on exit from CHKDER. +0 M is a positive integer input variable set to the number of + functions. +0 N is a positive integer input variable set to the number of + variables. +0 X is an input array of length N. +0 FVEC is an array of length M. On input when MODE = 2, FVEC mus + contain the functions evaluated at X. +0 FJAC is an M by N array. On input when MODE = 2, the rows of + FJAC must contain the gradients of the respective functions + evaluated at X. +0 LDFJAC is a positive integer input variable not less than M + which specifies the leading dimension of the array FJAC. +0 XP is an array of length N. On output when MODE = 1, XP is set + to a neighboring point of X. +1 +0 Page +0 FVECP is an array of length M. On input when MODE = 2, FVECP + must contain the functions evaluated at XP. +0 MODE is an integer input variable set to 1 on the first call an + 2 on the second. Other values of MODE are equivalent to + MODE = 1. +0 ERR is an array of length M. On output when MODE = 2, ERR con- + tains measures of correctness of the respective gradients. I + there is no severe loss of significance, then if ERR(I) is 1. + the I-th gradient is correct, while if ERR(I) is 0.0 the I-th + gradient is incorrect. For values of ERR between 0.0 and 1.0 + the categorization is less certain. In general, a value of + ERR(I) greater than 0.5 indicates that the I-th gradient is + probably correct, while a value of ERR(I) less than 0.5 indi- + cates that the I-th gradient is probably incorrect. +0 + 4. Successful completion. +0 CHKDER usually guarantees that if ERR(I) is 1.0, then the I-th + gradient at X is consistent with the I-th function. This sug- + gests that the input X be such that consistency of the gradient + at X implies consistency of the gradient at all points of inter + est. If all the components of X are distinct and the fractiona + part of each one has two nonzero digits, then X is likely to be + a satisfactory choice. +0 If ERR(I) is not 1.0 but is greater than 0.5, then the I-th gra + dient is probably consistent with the I-th function (the more s + the larger ERR(I) is), but the conditions for ERR(I) to be 1.0 + have not been completely satisfied. In this case, it is recom- + mended that CHKDER be rerun with other input values of X. If + ERR(I) is always greater than 0.5, then the I-th gradient is + consistent with the I-th function. +0 + 5. Unsuccessful completion. +0 CHKDER does not perform reliably if cancellation or rounding + errors cause a severe loss of significance in the evaluation of + a function. Therefore, none of the components of X should be + unusually small (in particular, zero) or any other value which + may cause loss of significance. The relative differences + between corresponding elements of FVECP and FVEC should be at + least two orders of magnitude greater than the machine precisio + (as defined by the MINPACK function SPMPAR(1)). If there is a + severe loss of significance in the evaluation of the I-th func- + tion, then ERR(I) may be 0.0 and yet the I-th gradient could be + correct. +0 If ERR(I) is not 0.0 but is less than 0.5, then the I-th gra- + dient is probably not consistent with the I-th function (the + more so the smaller ERR(I) is), but the conditions for ERR(I) t +1 +0 Page +0 be 0.0 have not been completely satisfied. In this case, it is + recommended that CHKDER be rerun with other input values of X. + If ERR(I) is always less than 0.5 and if there is no severe los + of significance, then the I-th gradient is not consistent with + the I-th function. +0 + 6. Characteristics of the algorithm. +0 CHKDER checks the I-th gradient for consistency with the I-th + function by computing a forward-difference approximation along + suitably chosen direction and comparing this approximation with + the user-supplied gradient along the same direction. The prin- + cipal characteristic of CHKDER is its invariance to changes in + scale of the variables or functions. +0 Timing. The time required by CHKDER depends only on M and N. + The number of arithmetic operations needed by CHKDER is about + N when MODE = 1 and M*N when MODE = 2. +0 Storage. CHKDER requires M*N + 3*M + 2*N single precision stor + age locations, in addition to the storage required by the pro + gram. There are no internally declared storage arrays. +0 + 7. Subprograms required. +0 MINPACK-supplied ... SPMPAR +0 FORTRAN-supplied ... ABS,ALOG10,SQRT +0 + 8. References. +0 None. +0 + 9. Example. +0 This example checks the Jacobian matrix for the problem that + determines the values of x(1), x(2), and x(3) which provide the + best fit (in the least squares sense) of +0 x(1) + u(i)/(v(i)*x(2) + w(i)*x(3)), i = 1, 15 +0 to the data +0 y = (0.14,0.18,0.22,0.25,0.29,0.32,0.35,0.39, + 0.37,0.58,0.73,0.96,1.34,2.10,4.39), +0 where u(i) = i, v(i) = 16 - i, and w(i) = min(u(i),v(i)). The + i-th component of FVEC is thus defined by +0 y(i) - (x(1) + u(i)/(v(i)*x(2) + w(i)*x(3))). +1 +0 Page +0 C ********** + C + C DRIVER FOR CHKDER EXAMPLE. + C SINGLE PRECISION VERSION + C + C ********** + INTEGER I,M,N,LDFJAC,MODE,NWRITE + REAL X(3),FVEC(15),FJAC(15,3),XP(3),FVECP(15),ERR(15) + C + C LOGICAL OUTPUT UNIT IS ASSUMED TO BE NUMBER 6. + C + DATA NWRITE /6/ + C + M = 15 + N = 3 + C + C THE FOLLOWING VALUES SHOULD BE SUITABLE FOR + C CHECKING THE JACOBIAN MATRIX. + C + X(1) = 9.2E-1 + X(2) = 1.3E-1 + X(3) = 5.4E-1 + C + LDFJAC = 15 + C + MODE = 1 + CALL CHKDER(M,N,X,FVEC,FJAC,LDFJAC,XP,FVECP,MODE,ERR) + MODE = 2 + CALL FCN(M,N,X,FVEC,FJAC,LDFJAC,1) + CALL FCN(M,N,X,FVEC,FJAC,LDFJAC,2) + CALL FCN(M,N,XP,FVECP,FJAC,LDFJAC,1) + CALL CHKDER(M,N,X,FVEC,FJAC,LDFJAC,XP,FVECP,MODE,ERR) + C + DO 10 I = 1, M + FVECP(I) = FVECP(I) - FVEC(I) + 10 CONTINUE + WRITE (NWRITE,1000) (FVEC(I),I=1,M) + WRITE (NWRITE,2000) (FVECP(I),I=1,M) + WRITE (NWRITE,3000) (ERR(I),I=1,M) + STOP + 1000 FORMAT (/5X,5H FVEC // (5X,3E15.7)) + 2000 FORMAT (/5X,13H FVECP - FVEC // (5X,3E15.7)) + 3000 FORMAT (/5X,4H ERR // (5X,3E15.7)) + C + C LAST CARD OF DRIVER FOR CHKDER EXAMPLE. + C + END + SUBROUTINE FCN(M,N,X,FVEC,FJAC,LDFJAC,IFLAG) + INTEGER M,N,LDFJAC,IFLAG + REAL X(N),FVEC(M),FJAC(LDFJAC,N) + C + C SUBROUTINE FCN FOR CHKDER EXAMPLE. + C + INTEGER I +1 +0 Page +0 REAL TMP1,TMP2,TMP3,TMP4 + REAL Y(15) + DATA Y(1),Y(2),Y(3),Y(4),Y(5),Y(6),Y(7),Y(8), + * Y(9),Y(10),Y(11),Y(12),Y(13),Y(14),Y(15) + * /1.4E-1,1.8E-1,2.2E-1,2.5E-1,2.9E-1,3.2E-1,3.5E-1,3.9E-1, + * 3.7E-1,5.8E-1,7.3E-1,9.6E-1,1.34E0,2.1E0,4.39E0/ + C + IF (IFLAG .EQ. 2) GO TO 20 + DO 10 I = 1, 15 + TMP1 = I + TMP2 = 16 - I + TMP3 = TMP1 + IF (I .GT. 8) TMP3 = TMP2 + FVEC(I) = Y(I) - (X(1) + TMP1/(X(2)*TMP2 + X(3)*TMP3)) + 10 CONTINUE + GO TO 40 + 20 CONTINUE + DO 30 I = 1, 15 + TMP1 = I + TMP2 = 16 - I + C + C ERROR INTRODUCED INTO NEXT STATEMENT FOR ILLUSTRATION. + C CORRECTED STATEMENT SHOULD READ TMP3 = TMP1 . + C + TMP3 = TMP2 + IF (I .GT. 8) TMP3 = TMP2 + TMP4 = (X(2)*TMP2 + X(3)*TMP3)**2 + FJAC(I,1) = -1.E0 + FJAC(I,2) = TMP1*TMP2/TMP4 + FJAC(I,3) = TMP1*TMP3/TMP4 + 30 CONTINUE + 40 CONTINUE + RETURN + C + C LAST CARD OF SUBROUTINE FCN. + C + END +0 Results obtained with different compilers or machines + may be different. In particular, the differences + FVECP - FVEC are machine dependent. +0 FVEC +0 -0.1181606E+01 -0.1429655E+01 -0.1606344E+01 + -0.1745269E+01 -0.1840654E+01 -0.1921586E+01 + -0.1984141E+01 -0.2022537E+01 -0.2468977E+01 + -0.2827562E+01 -0.3473582E+01 -0.4437612E+01 + -0.6047662E+01 -0.9267761E+01 -0.1891806E+02 +0 FVECP - FVEC +0 -0.7724666E-08 -0.3432405E-08 -0.2034843E-09 + 0.2313685E-08 0.4331078E-08 0.5984096E-08 +1 +0 Page +0 0.7363281E-08 0.8531470E-08 0.1488591E-07 + 0.2335850E-07 0.3522012E-07 0.5301255E-07 + 0.8266660E-07 0.1419747E-06 0.3198990E-06 +0 ERR +0 0.1141397E+00 0.9943516E-01 0.9674474E-01 + 0.9980447E-01 0.1073116E+00 0.1220445E+00 + 0.1526814E+00 0.1000000E+01 0.1000000E+01 + 0.1000000E+01 0.1000000E+01 0.1000000E+01 + 0.1000000E+01 0.1000000E+01 0.1000000E+01 diff --git a/ex/file04 b/ex/file04 new file mode 100644 index 0000000..7205031 --- /dev/null +++ b/ex/file04 @@ -0,0 +1,192 @@ + DOUBLE PRECISION FUNCTION DPMPAR(I) + INTEGER I +C ********** +C +C FUNCTION DPMPAR +C +C THIS FUNCTION PROVIDES DOUBLE PRECISION MACHINE PARAMETERS +C WHEN THE APPROPRIATE SET OF DATA STATEMENTS IS ACTIVATED (BY +C REMOVING THE C FROM COLUMN 1) AND ALL OTHER DATA STATEMENTS ARE +C RENDERED INACTIVE. MOST OF THE PARAMETER VALUES WERE OBTAINED +C FROM THE CORRESPONDING BELL LABORATORIES PORT LIBRARY FUNCTION. +C +C THE FUNCTION STATEMENT IS +C +C DOUBLE PRECISION FUNCTION DPMPAR(I) +C +C WHERE +C +C I IS AN INTEGER INPUT VARIABLE SET TO 1, 2, OR 3 WHICH +C SELECTS THE DESIRED MACHINE PARAMETER. IF THE MACHINE HAS +C T BASE B DIGITS AND ITS SMALLEST AND LARGEST EXPONENTS ARE +C EMIN AND EMAX, RESPECTIVELY, THEN THESE PARAMETERS ARE +C +C DPMPAR(1) = B**(1 - T), THE MACHINE PRECISION, +C +C DPMPAR(2) = B**(EMIN - 1), THE SMALLEST MAGNITUDE, +C +C DPMPAR(3) = B**EMAX*(1 - B**(-T)), THE LARGEST MAGNITUDE. +C +C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. +C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE +C +C ********** + INTEGER MCHEPS(4) + INTEGER MINMAG(4) + INTEGER MAXMAG(4) + DOUBLE PRECISION DMACH(3) + EQUIVALENCE (DMACH(1),MCHEPS(1)) + EQUIVALENCE (DMACH(2),MINMAG(1)) + EQUIVALENCE (DMACH(3),MAXMAG(1)) +C +C MACHINE CONSTANTS FOR THE IBM 360/370 SERIES, +C THE AMDAHL 470/V6, THE ICL 2900, THE ITEL AS/6, +C THE XEROX SIGMA 5/7/9 AND THE SEL SYSTEMS 85/86. +C + DATA MCHEPS(1),MCHEPS(2) / Z34100000, Z00000000 / + DATA MINMAG(1),MINMAG(2) / Z00100000, Z00000000 / + DATA MAXMAG(1),MAXMAG(2) / Z7FFFFFFF, ZFFFFFFFF / +C +C MACHINE CONSTANTS FOR THE HONEYWELL 600/6000 SERIES. +C +C DATA MCHEPS(1),MCHEPS(2) / O606400000000, O000000000000 / +C DATA MINMAG(1),MINMAG(2) / O402400000000, O000000000000 / +C DATA MAXMAG(1),MAXMAG(2) / O376777777777, O777777777777 / +C +C MACHINE CONSTANTS FOR THE CDC 6000/7000 SERIES. +C +C DATA MCHEPS(1) / 15614000000000000000B / +C DATA MCHEPS(2) / 15010000000000000000B / +C +C DATA MINMAG(1) / 00604000000000000000B / +C DATA MINMAG(2) / 00000000000000000000B / +C +C DATA MAXMAG(1) / 37767777777777777777B / +C DATA MAXMAG(2) / 37167777777777777777B / +C +C MACHINE CONSTANTS FOR THE PDP-10 (KA PROCESSOR). +C +C DATA MCHEPS(1),MCHEPS(2) / "114400000000, "000000000000 / +C DATA MINMAG(1),MINMAG(2) / "033400000000, "000000000000 / +C DATA MAXMAG(1),MAXMAG(2) / "377777777777, "344777777777 / +C +C MACHINE CONSTANTS FOR THE PDP-10 (KI PROCESSOR). +C +C DATA MCHEPS(1),MCHEPS(2) / "104400000000, "000000000000 / +C DATA MINMAG(1),MINMAG(2) / "000400000000, "000000000000 / +C DATA MAXMAG(1),MAXMAG(2) / "377777777777, "377777777777 / +C +C MACHINE CONSTANTS FOR THE PDP-11 FORTRAN SUPPORTING +C 32-BIT INTEGERS (EXPRESSED IN INTEGER AND OCTAL). +C +C DATA MCHEPS(1),MCHEPS(2) / 620756992, 0 / +C DATA MINMAG(1),MINMAG(2) / 8388608, 0 / +C DATA MAXMAG(1),MAXMAG(2) / 2147483647, -1 / +C +C DATA MCHEPS(1),MCHEPS(2) / O04500000000, O00000000000 / +C DATA MINMAG(1),MINMAG(2) / O00040000000, O00000000000 / +C DATA MAXMAG(1),MAXMAG(2) / O17777777777, O37777777777 / +C +C MACHINE CONSTANTS FOR THE PDP-11 FORTRAN SUPPORTING +C 16-BIT INTEGERS (EXPRESSED IN INTEGER AND OCTAL). +C +C DATA MCHEPS(1),MCHEPS(2) / 9472, 0 / +C DATA MCHEPS(3),MCHEPS(4) / 0, 0 / +C +C DATA MINMAG(1),MINMAG(2) / 128, 0 / +C DATA MINMAG(3),MINMAG(4) / 0, 0 / +C +C DATA MAXMAG(1),MAXMAG(2) / 32767, -1 / +C DATA MAXMAG(3),MAXMAG(4) / -1, -1 / +C +C DATA MCHEPS(1),MCHEPS(2) / O022400, O000000 / +C DATA MCHEPS(3),MCHEPS(4) / O000000, O000000 / +C +C DATA MINMAG(1),MINMAG(2) / O000200, O000000 / +C DATA MINMAG(3),MINMAG(4) / O000000, O000000 / +C +C DATA MAXMAG(1),MAXMAG(2) / O077777, O177777 / +C DATA MAXMAG(3),MAXMAG(4) / O177777, O177777 / +C +C MACHINE CONSTANTS FOR THE BURROUGHS 6700/7700 SYSTEMS. +C +C DATA MCHEPS(1) / O1451000000000000 / +C DATA MCHEPS(2) / O0000000000000000 / +C +C DATA MINMAG(1) / O1771000000000000 / +C DATA MINMAG(2) / O7770000000000000 / +C +C DATA MAXMAG(1) / O0777777777777777 / +C DATA MAXMAG(2) / O7777777777777777 / +C +C MACHINE CONSTANTS FOR THE BURROUGHS 5700 SYSTEM. +C +C DATA MCHEPS(1) / O1451000000000000 / +C DATA MCHEPS(2) / O0000000000000000 / +C +C DATA MINMAG(1) / O1771000000000000 / +C DATA MINMAG(2) / O0000000000000000 / +C +C DATA MAXMAG(1) / O0777777777777777 / +C DATA MAXMAG(2) / O0007777777777777 / +C +C MACHINE CONSTANTS FOR THE BURROUGHS 1700 SYSTEM. +C +C DATA MCHEPS(1) / ZCC6800000 / +C DATA MCHEPS(2) / Z000000000 / +C +C DATA MINMAG(1) / ZC00800000 / +C DATA MINMAG(2) / Z000000000 / +C +C DATA MAXMAG(1) / ZDFFFFFFFF / +C DATA MAXMAG(2) / ZFFFFFFFFF / +C +C MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES. +C +C DATA MCHEPS(1),MCHEPS(2) / O170640000000, O000000000000 / +C DATA MINMAG(1),MINMAG(2) / O000040000000, O000000000000 / +C DATA MAXMAG(1),MAXMAG(2) / O377777777777, O777777777777 / +C +C MACHINE CONSTANTS FOR THE DATA GENERAL ECLIPSE S/200. +C +C NOTE - IT MAY BE APPROPRIATE TO INCLUDE THE FOLLOWING CARD - +C STATIC DMACH(3) +C +C DATA MINMAG/20K,3*0/,MAXMAG/77777K,3*177777K/ +C DATA MCHEPS/32020K,3*0/ +C +C MACHINE CONSTANTS FOR THE HARRIS 220. +C +C DATA MCHEPS(1),MCHEPS(2) / '20000000, '00000334 / +C DATA MINMAG(1),MINMAG(2) / '20000000, '00000201 / +C DATA MAXMAG(1),MAXMAG(2) / '37777777, '37777577 / +C +C MACHINE CONSTANTS FOR THE CRAY-1. +C +C DATA MCHEPS(1) / 0376424000000000000000B / +C DATA MCHEPS(2) / 0000000000000000000000B / +C +C DATA MINMAG(1) / 0200034000000000000000B / +C DATA MINMAG(2) / 0000000000000000000000B / +C +C DATA MAXMAG(1) / 0577777777777777777777B / +C DATA MAXMAG(2) / 0000007777777777777776B / +C +C MACHINE CONSTANTS FOR THE PRIME 400. +C +C DATA MCHEPS(1),MCHEPS(2) / :10000000000, :00000000123 / +C DATA MINMAG(1),MINMAG(2) / :10000000000, :00000100000 / +C DATA MAXMAG(1),MAXMAG(2) / :17777777777, :37777677776 / +C +C MACHINE CONSTANTS FOR THE VAX-11. +C +C DATA MCHEPS(1),MCHEPS(2) / 9472, 0 / +C DATA MINMAG(1),MINMAG(2) / 128, 0 / +C DATA MAXMAG(1),MAXMAG(2) / -32769, -1 / +C + DPMPAR = DMACH(I) + RETURN +C +C LAST CARD OF FUNCTION DPMPAR. +C + END diff --git a/ex/file05 b/ex/file05 new file mode 100644 index 0000000..f777577 --- /dev/null +++ b/ex/file05 @@ -0,0 +1,4778 @@ + SUBROUTINE CHKDER(M,N,X,FVEC,FJAC,LDFJAC,XP,FVECP,MODE,ERR) + INTEGER M,N,LDFJAC,MODE + DOUBLE PRECISION X(N),FVEC(M),FJAC(LDFJAC,N),XP(N),FVECP(M), + * ERR(M) +C ********** +C +C SUBROUTINE CHKDER +C +C THIS SUBROUTINE CHECKS THE GRADIENTS OF M NONLINEAR FUNCTIONS +C IN N VARIABLES, EVALUATED AT A POINT X, FOR CONSISTENCY WITH +C THE FUNCTIONS THEMSELVES. THE USER MUST CALL CHKDER TWICE, +C FIRST WITH MODE = 1 AND THEN WITH MODE = 2. +C +C MODE = 1. ON INPUT, X MUST CONTAIN THE POINT OF EVALUATION. +C ON OUTPUT, XP IS SET TO A NEIGHBORING POINT. +C +C MODE = 2. ON INPUT, FVEC MUST CONTAIN THE FUNCTIONS AND THE +C ROWS OF FJAC MUST CONTAIN THE GRADIENTS +C OF THE RESPECTIVE FUNCTIONS EACH EVALUATED +C AT X, AND FVECP MUST CONTAIN THE FUNCTIONS +C EVALUATED AT XP. +C ON OUTPUT, ERR CONTAINS MEASURES OF CORRECTNESS OF +C THE RESPECTIVE GRADIENTS. +C +C THE SUBROUTINE DOES NOT PERFORM RELIABLY IF CANCELLATION OR +C ROUNDING ERRORS CAUSE A SEVERE LOSS OF SIGNIFICANCE IN THE +C EVALUATION OF A FUNCTION. THEREFORE, NONE OF THE COMPONENTS +C OF X SHOULD BE UNUSUALLY SMALL (IN PARTICULAR, ZERO) OR ANY +C OTHER VALUE WHICH MAY CAUSE LOSS OF SIGNIFICANCE. +C +C THE SUBROUTINE STATEMENT IS +C +C SUBROUTINE CHKDER(M,N,X,FVEC,FJAC,LDFJAC,XP,FVECP,MODE,ERR) +C +C WHERE +C +C M IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER +C OF FUNCTIONS. +C +C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER +C OF VARIABLES. +C +C X IS AN INPUT ARRAY OF LENGTH N. +C +C FVEC IS AN ARRAY OF LENGTH M. ON INPUT WHEN MODE = 2, +C FVEC MUST CONTAIN THE FUNCTIONS EVALUATED AT X. +C +C FJAC IS AN M BY N ARRAY. ON INPUT WHEN MODE = 2, +C THE ROWS OF FJAC MUST CONTAIN THE GRADIENTS OF +C THE RESPECTIVE FUNCTIONS EVALUATED AT X. +C +C LDFJAC IS A POSITIVE INTEGER INPUT PARAMETER NOT LESS THAN M +C WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY FJAC. +C +C XP IS AN ARRAY OF LENGTH N. ON OUTPUT WHEN MODE = 1, +C XP IS SET TO A NEIGHBORING POINT OF X. +C +C FVECP IS AN ARRAY OF LENGTH M. ON INPUT WHEN MODE = 2, +C FVECP MUST CONTAIN THE FUNCTIONS EVALUATED AT XP. +C +C MODE IS AN INTEGER INPUT VARIABLE SET TO 1 ON THE FIRST CALL +C AND 2 ON THE SECOND. OTHER VALUES OF MODE ARE EQUIVALENT +C TO MODE = 1. +C +C ERR IS AN ARRAY OF LENGTH M. ON OUTPUT WHEN MODE = 2, +C ERR CONTAINS MEASURES OF CORRECTNESS OF THE RESPECTIVE +C GRADIENTS. IF THERE IS NO SEVERE LOSS OF SIGNIFICANCE, +C THEN IF ERR(I) IS 1.0 THE I-TH GRADIENT IS CORRECT, +C WHILE IF ERR(I) IS 0.0 THE I-TH GRADIENT IS INCORRECT. +C FOR VALUES OF ERR BETWEEN 0.0 AND 1.0, THE CATEGORIZATION +C IS LESS CERTAIN. IN GENERAL, A VALUE OF ERR(I) GREATER +C THAN 0.5 INDICATES THAT THE I-TH GRADIENT IS PROBABLY +C CORRECT, WHILE A VALUE OF ERR(I) LESS THAN 0.5 INDICATES +C THAT THE I-TH GRADIENT IS PROBABLY INCORRECT. +C +C SUBPROGRAMS CALLED +C +C MINPACK SUPPLIED ... DPMPAR +C +C FORTRAN SUPPLIED ... DABS,DLOG10,DSQRT +C +C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. +C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE +C +C ********** + INTEGER I,J + DOUBLE PRECISION EPS,EPSF,EPSLOG,EPSMCH,FACTOR,ONE,TEMP,ZERO + DOUBLE PRECISION DPMPAR + DATA FACTOR,ONE,ZERO /1.0D2,1.0D0,0.0D0/ +C +C EPSMCH IS THE MACHINE PRECISION. +C + EPSMCH = DPMPAR(1) +C + EPS = DSQRT(EPSMCH) +C + IF (MODE .EQ. 2) GO TO 20 +C +C MODE = 1. +C + DO 10 J = 1, N + TEMP = EPS*DABS(X(J)) + IF (TEMP .EQ. ZERO) TEMP = EPS + XP(J) = X(J) + TEMP + 10 CONTINUE + GO TO 70 + 20 CONTINUE +C +C MODE = 2. +C + EPSF = FACTOR*EPSMCH + EPSLOG = DLOG10(EPS) + DO 30 I = 1, M + ERR(I) = ZERO + 30 CONTINUE + DO 50 J = 1, N + TEMP = DABS(X(J)) + IF (TEMP .EQ. ZERO) TEMP = ONE + DO 40 I = 1, M + ERR(I) = ERR(I) + TEMP*FJAC(I,J) + 40 CONTINUE + 50 CONTINUE + DO 60 I = 1, M + TEMP = ONE + IF (FVEC(I) .NE. ZERO .AND. FVECP(I) .NE. ZERO + * .AND. DABS(FVECP(I)-FVEC(I)) .GE. EPSF*DABS(FVEC(I))) + * TEMP = EPS*DABS((FVECP(I)-FVEC(I))/EPS-ERR(I)) + * /(DABS(FVEC(I)) + DABS(FVECP(I))) + ERR(I) = ONE + IF (TEMP .GT. EPSMCH .AND. TEMP .LT. EPS) + * ERR(I) = (DLOG10(TEMP) - EPSLOG)/EPSLOG + IF (TEMP .GE. EPS) ERR(I) = ZERO + 60 CONTINUE + 70 CONTINUE +C + RETURN +C +C LAST CARD OF SUBROUTINE CHKDER. +C + END + SUBROUTINE DOGLEG(N,R,LR,DIAG,QTB,DELTA,X,WA1,WA2) + INTEGER N,LR + DOUBLE PRECISION DELTA + DOUBLE PRECISION R(LR),DIAG(N),QTB(N),X(N),WA1(N),WA2(N) +C ********** +C +C SUBROUTINE DOGLEG +C +C GIVEN AN M BY N MATRIX A, AN N BY N NONSINGULAR DIAGONAL +C MATRIX D, AN M-VECTOR B, AND A POSITIVE NUMBER DELTA, THE +C PROBLEM IS TO DETERMINE THE CONVEX COMBINATION X OF THE +C GAUSS-NEWTON AND SCALED GRADIENT DIRECTIONS THAT MINIMIZES +C (A*X - B) IN THE LEAST SQUARES SENSE, SUBJECT TO THE +C RESTRICTION THAT THE EUCLIDEAN NORM OF D*X BE AT MOST DELTA. +C +C THIS SUBROUTINE COMPLETES THE SOLUTION OF THE PROBLEM +C IF IT IS PROVIDED WITH THE NECESSARY INFORMATION FROM THE +C QR FACTORIZATION OF A. THAT IS, IF A = Q*R, WHERE Q HAS +C ORTHOGONAL COLUMNS AND R IS AN UPPER TRIANGULAR MATRIX, +C THEN DOGLEG EXPECTS THE FULL UPPER TRIANGLE OF R AND +C THE FIRST N COMPONENTS OF (Q TRANSPOSE)*B. +C +C THE SUBROUTINE STATEMENT IS +C +C SUBROUTINE DOGLEG(N,R,LR,DIAG,QTB,DELTA,X,WA1,WA2) +C +C WHERE +C +C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE ORDER OF R. +C +C R IS AN INPUT ARRAY OF LENGTH LR WHICH MUST CONTAIN THE UPPER +C TRIANGULAR MATRIX R STORED BY ROWS. +C +C LR IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN +C (N*(N+1))/2. +C +C DIAG IS AN INPUT ARRAY OF LENGTH N WHICH MUST CONTAIN THE +C DIAGONAL ELEMENTS OF THE MATRIX D. +C +C QTB IS AN INPUT ARRAY OF LENGTH N WHICH MUST CONTAIN THE FIRST +C N ELEMENTS OF THE VECTOR (Q TRANSPOSE)*B. +C +C DELTA IS A POSITIVE INPUT VARIABLE WHICH SPECIFIES AN UPPER +C BOUND ON THE EUCLIDEAN NORM OF D*X. +C +C X IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE DESIRED +C CONVEX COMBINATION OF THE GAUSS-NEWTON DIRECTION AND THE +C SCALED GRADIENT DIRECTION. +C +C WA1 AND WA2 ARE WORK ARRAYS OF LENGTH N. +C +C SUBPROGRAMS CALLED +C +C MINPACK-SUPPLIED ... DPMPAR,ENORM +C +C FORTRAN-SUPPLIED ... DABS,DMAX1,DMIN1,DSQRT +C +C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. +C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE +C +C ********** + INTEGER I,J,JJ,JP1,K,L + DOUBLE PRECISION ALPHA,BNORM,EPSMCH,GNORM,ONE,QNORM,SGNORM,SUM, + * TEMP,ZERO + DOUBLE PRECISION DPMPAR,ENORM + DATA ONE,ZERO /1.0D0,0.0D0/ +C +C EPSMCH IS THE MACHINE PRECISION. +C + EPSMCH = DPMPAR(1) +C +C FIRST, CALCULATE THE GAUSS-NEWTON DIRECTION. +C + JJ = (N*(N + 1))/2 + 1 + DO 50 K = 1, N + J = N - K + 1 + JP1 = J + 1 + JJ = JJ - K + L = JJ + 1 + SUM = ZERO + IF (N .LT. JP1) GO TO 20 + DO 10 I = JP1, N + SUM = SUM + R(L)*X(I) + L = L + 1 + 10 CONTINUE + 20 CONTINUE + TEMP = R(JJ) + IF (TEMP .NE. ZERO) GO TO 40 + L = J + DO 30 I = 1, J + TEMP = DMAX1(TEMP,DABS(R(L))) + L = L + N - I + 30 CONTINUE + TEMP = EPSMCH*TEMP + IF (TEMP .EQ. ZERO) TEMP = EPSMCH + 40 CONTINUE + X(J) = (QTB(J) - SUM)/TEMP + 50 CONTINUE +C +C TEST WHETHER THE GAUSS-NEWTON DIRECTION IS ACCEPTABLE. +C + DO 60 J = 1, N + WA1(J) = ZERO + WA2(J) = DIAG(J)*X(J) + 60 CONTINUE + QNORM = ENORM(N,WA2) + IF (QNORM .LE. DELTA) GO TO 140 +C +C THE GAUSS-NEWTON DIRECTION IS NOT ACCEPTABLE. +C NEXT, CALCULATE THE SCALED GRADIENT DIRECTION. +C + L = 1 + DO 80 J = 1, N + TEMP = QTB(J) + DO 70 I = J, N + WA1(I) = WA1(I) + R(L)*TEMP + L = L + 1 + 70 CONTINUE + WA1(J) = WA1(J)/DIAG(J) + 80 CONTINUE +C +C CALCULATE THE NORM OF THE SCALED GRADIENT AND TEST FOR +C THE SPECIAL CASE IN WHICH THE SCALED GRADIENT IS ZERO. +C + GNORM = ENORM(N,WA1) + SGNORM = ZERO + ALPHA = DELTA/QNORM + IF (GNORM .EQ. ZERO) GO TO 120 +C +C CALCULATE THE POINT ALONG THE SCALED GRADIENT +C AT WHICH THE QUADRATIC IS MINIMIZED. +C + DO 90 J = 1, N + WA1(J) = (WA1(J)/GNORM)/DIAG(J) + 90 CONTINUE + L = 1 + DO 110 J = 1, N + SUM = ZERO + DO 100 I = J, N + SUM = SUM + R(L)*WA1(I) + L = L + 1 + 100 CONTINUE + WA2(J) = SUM + 110 CONTINUE + TEMP = ENORM(N,WA2) + SGNORM = (GNORM/TEMP)/TEMP +C +C TEST WHETHER THE SCALED GRADIENT DIRECTION IS ACCEPTABLE. +C + ALPHA = ZERO + IF (SGNORM .GE. DELTA) GO TO 120 +C +C THE SCALED GRADIENT DIRECTION IS NOT ACCEPTABLE. +C FINALLY, CALCULATE THE POINT ALONG THE DOGLEG +C AT WHICH THE QUADRATIC IS MINIMIZED. +C + BNORM = ENORM(N,QTB) + TEMP = (BNORM/GNORM)*(BNORM/QNORM)*(SGNORM/DELTA) + TEMP = TEMP - (DELTA/QNORM)*(SGNORM/DELTA)**2 + * + DSQRT((TEMP-(DELTA/QNORM))**2 + * +(ONE-(DELTA/QNORM)**2)*(ONE-(SGNORM/DELTA)**2)) + ALPHA = ((DELTA/QNORM)*(ONE - (SGNORM/DELTA)**2))/TEMP + 120 CONTINUE +C +C FORM APPROPRIATE CONVEX COMBINATION OF THE GAUSS-NEWTON +C DIRECTION AND THE SCALED GRADIENT DIRECTION. +C + TEMP = (ONE - ALPHA)*DMIN1(SGNORM,DELTA) + DO 130 J = 1, N + X(J) = TEMP*WA1(J) + ALPHA*X(J) + 130 CONTINUE + 140 CONTINUE + RETURN +C +C LAST CARD OF SUBROUTINE DOGLEG. +C + END + DOUBLE PRECISION FUNCTION ENORM(N,X) + INTEGER N + DOUBLE PRECISION X(N) +C ********** +C +C FUNCTION ENORM +C +C GIVEN AN N-VECTOR X, THIS FUNCTION CALCULATES THE +C EUCLIDEAN NORM OF X. +C +C THE EUCLIDEAN NORM IS COMPUTED BY ACCUMULATING THE SUM OF +C SQUARES IN THREE DIFFERENT SUMS. THE SUMS OF SQUARES FOR THE +C SMALL AND LARGE COMPONENTS ARE SCALED SO THAT NO OVERFLOWS +C OCCUR. NON-DESTRUCTIVE UNDERFLOWS ARE PERMITTED. UNDERFLOWS +C AND OVERFLOWS DO NOT OCCUR IN THE COMPUTATION OF THE UNSCALED +C SUM OF SQUARES FOR THE INTERMEDIATE COMPONENTS. +C THE DEFINITIONS OF SMALL, INTERMEDIATE AND LARGE COMPONENTS +C DEPEND ON TWO CONSTANTS, RDWARF AND RGIANT. THE MAIN +C RESTRICTIONS ON THESE CONSTANTS ARE THAT RDWARF**2 NOT +C UNDERFLOW AND RGIANT**2 NOT OVERFLOW. THE CONSTANTS +C GIVEN HERE ARE SUITABLE FOR EVERY KNOWN COMPUTER. +C +C THE FUNCTION STATEMENT IS +C +C DOUBLE PRECISION FUNCTION ENORM(N,X) +C +C WHERE +C +C N IS A POSITIVE INTEGER INPUT VARIABLE. +C +C X IS AN INPUT ARRAY OF LENGTH N. +C +C SUBPROGRAMS CALLED +C +C FORTRAN-SUPPLIED ... DABS,DSQRT +C +C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. +C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE +C +C ********** + INTEGER I + DOUBLE PRECISION AGIANT,FLOATN,ONE,RDWARF,RGIANT,S1,S2,S3,XABS, + * X1MAX,X3MAX,ZERO + DATA ONE,ZERO,RDWARF,RGIANT /1.0D0,0.0D0,3.834D-20,1.304D19/ + S1 = ZERO + S2 = ZERO + S3 = ZERO + X1MAX = ZERO + X3MAX = ZERO + FLOATN = N + AGIANT = RGIANT/FLOATN + DO 90 I = 1, N + XABS = DABS(X(I)) + IF (XABS .GT. RDWARF .AND. XABS .LT. AGIANT) GO TO 70 + IF (XABS .LE. RDWARF) GO TO 30 +C +C SUM FOR LARGE COMPONENTS. +C + IF (XABS .LE. X1MAX) GO TO 10 + S1 = ONE + S1*(X1MAX/XABS)**2 + X1MAX = XABS + GO TO 20 + 10 CONTINUE + S1 = S1 + (XABS/X1MAX)**2 + 20 CONTINUE + GO TO 60 + 30 CONTINUE +C +C SUM FOR SMALL COMPONENTS. +C + IF (XABS .LE. X3MAX) GO TO 40 + S3 = ONE + S3*(X3MAX/XABS)**2 + X3MAX = XABS + GO TO 50 + 40 CONTINUE + IF (XABS .NE. ZERO) S3 = S3 + (XABS/X3MAX)**2 + 50 CONTINUE + 60 CONTINUE + GO TO 80 + 70 CONTINUE +C +C SUM FOR INTERMEDIATE COMPONENTS. +C + S2 = S2 + XABS**2 + 80 CONTINUE + 90 CONTINUE +C +C CALCULATION OF NORM. +C + IF (S1 .EQ. ZERO) GO TO 100 + ENORM = X1MAX*DSQRT(S1+(S2/X1MAX)/X1MAX) + GO TO 130 + 100 CONTINUE + IF (S2 .EQ. ZERO) GO TO 110 + IF (S2 .GE. X3MAX) + * ENORM = DSQRT(S2*(ONE+(X3MAX/S2)*(X3MAX*S3))) + IF (S2 .LT. X3MAX) + * ENORM = DSQRT(X3MAX*((S2/X3MAX)+(X3MAX*S3))) + GO TO 120 + 110 CONTINUE + ENORM = X3MAX*DSQRT(S3) + 120 CONTINUE + 130 CONTINUE + RETURN +C +C LAST CARD OF FUNCTION ENORM. +C + END + SUBROUTINE FDJAC1(FCN,N,X,FVEC,FJAC,LDFJAC,IFLAG,ML,MU,EPSFCN, + * WA1,WA2) + INTEGER N,LDFJAC,IFLAG,ML,MU + DOUBLE PRECISION EPSFCN + DOUBLE PRECISION X(N),FVEC(N),FJAC(LDFJAC,N),WA1(N),WA2(N) +C ********** +C +C SUBROUTINE FDJAC1 +C +C THIS SUBROUTINE COMPUTES A FORWARD-DIFFERENCE APPROXIMATION +C TO THE N BY N JACOBIAN MATRIX ASSOCIATED WITH A SPECIFIED +C PROBLEM OF N FUNCTIONS IN N VARIABLES. IF THE JACOBIAN HAS +C A BANDED FORM, THEN FUNCTION EVALUATIONS ARE SAVED BY ONLY +C APPROXIMATING THE NONZERO TERMS. +C +C THE SUBROUTINE STATEMENT IS +C +C SUBROUTINE FDJAC1(FCN,N,X,FVEC,FJAC,LDFJAC,IFLAG,ML,MU,EPSFCN, +C WA1,WA2) +C +C WHERE +C +C FCN IS THE NAME OF THE USER-SUPPLIED SUBROUTINE WHICH +C CALCULATES THE FUNCTIONS. FCN MUST BE DECLARED +C IN AN EXTERNAL STATEMENT IN THE USER CALLING +C PROGRAM, AND SHOULD BE WRITTEN AS FOLLOWS. +C +C SUBROUTINE FCN(N,X,FVEC,IFLAG) +C INTEGER N,IFLAG +C DOUBLE PRECISION X(N),FVEC(N) +C ---------- +C CALCULATE THE FUNCTIONS AT X AND +C RETURN THIS VECTOR IN FVEC. +C ---------- +C RETURN +C END +C +C THE VALUE OF IFLAG SHOULD NOT BE CHANGED BY FCN UNLESS +C THE USER WANTS TO TERMINATE EXECUTION OF FDJAC1. +C IN THIS CASE SET IFLAG TO A NEGATIVE INTEGER. +C +C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER +C OF FUNCTIONS AND VARIABLES. +C +C X IS AN INPUT ARRAY OF LENGTH N. +C +C FVEC IS AN INPUT ARRAY OF LENGTH N WHICH MUST CONTAIN THE +C FUNCTIONS EVALUATED AT X. +C +C FJAC IS AN OUTPUT N BY N ARRAY WHICH CONTAINS THE +C APPROXIMATION TO THE JACOBIAN MATRIX EVALUATED AT X. +C +C LDFJAC IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN N +C WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY FJAC. +C +C IFLAG IS AN INTEGER VARIABLE WHICH CAN BE USED TO TERMINATE +C THE EXECUTION OF FDJAC1. SEE DESCRIPTION OF FCN. +C +C ML IS A NONNEGATIVE INTEGER INPUT VARIABLE WHICH SPECIFIES +C THE NUMBER OF SUBDIAGONALS WITHIN THE BAND OF THE +C JACOBIAN MATRIX. IF THE JACOBIAN IS NOT BANDED, SET +C ML TO AT LEAST N - 1. +C +C EPSFCN IS AN INPUT VARIABLE USED IN DETERMINING A SUITABLE +C STEP LENGTH FOR THE FORWARD-DIFFERENCE APPROXIMATION. THIS +C APPROXIMATION ASSUMES THAT THE RELATIVE ERRORS IN THE +C FUNCTIONS ARE OF THE ORDER OF EPSFCN. IF EPSFCN IS LESS +C THAN THE MACHINE PRECISION, IT IS ASSUMED THAT THE RELATIVE +C ERRORS IN THE FUNCTIONS ARE OF THE ORDER OF THE MACHINE +C PRECISION. +C +C MU IS A NONNEGATIVE INTEGER INPUT VARIABLE WHICH SPECIFIES +C THE NUMBER OF SUPERDIAGONALS WITHIN THE BAND OF THE +C JACOBIAN MATRIX. IF THE JACOBIAN IS NOT BANDED, SET +C MU TO AT LEAST N - 1. +C +C WA1 AND WA2 ARE WORK ARRAYS OF LENGTH N. IF ML + MU + 1 IS AT +C LEAST N, THEN THE JACOBIAN IS CONSIDERED DENSE, AND WA2 IS +C NOT REFERENCED. +C +C SUBPROGRAMS CALLED +C +C MINPACK-SUPPLIED ... DPMPAR +C +C FORTRAN-SUPPLIED ... DABS,DMAX1,DSQRT +C +C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. +C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE +C +C ********** + INTEGER I,J,K,MSUM + DOUBLE PRECISION EPS,EPSMCH,H,TEMP,ZERO + DOUBLE PRECISION DPMPAR + DATA ZERO /0.0D0/ +C +C EPSMCH IS THE MACHINE PRECISION. +C + EPSMCH = DPMPAR(1) +C + EPS = DSQRT(DMAX1(EPSFCN,EPSMCH)) + MSUM = ML + MU + 1 + IF (MSUM .LT. N) GO TO 40 +C +C COMPUTATION OF DENSE APPROXIMATE JACOBIAN. +C + DO 20 J = 1, N + TEMP = X(J) + H = EPS*DABS(TEMP) + IF (H .EQ. ZERO) H = EPS + X(J) = TEMP + H + CALL FCN(N,X,WA1,IFLAG) + IF (IFLAG .LT. 0) GO TO 30 + X(J) = TEMP + DO 10 I = 1, N + FJAC(I,J) = (WA1(I) - FVEC(I))/H + 10 CONTINUE + 20 CONTINUE + 30 CONTINUE + GO TO 110 + 40 CONTINUE +C +C COMPUTATION OF BANDED APPROXIMATE JACOBIAN. +C + DO 90 K = 1, MSUM + DO 60 J = K, N, MSUM + WA2(J) = X(J) + H = EPS*DABS(WA2(J)) + IF (H .EQ. ZERO) H = EPS + X(J) = WA2(J) + H + 60 CONTINUE + CALL FCN(N,X,WA1,IFLAG) + IF (IFLAG .LT. 0) GO TO 100 + DO 80 J = K, N, MSUM + X(J) = WA2(J) + H = EPS*DABS(WA2(J)) + IF (H .EQ. ZERO) H = EPS + DO 70 I = 1, N + FJAC(I,J) = ZERO + IF (I .GE. J - MU .AND. I .LE. J + ML) + * FJAC(I,J) = (WA1(I) - FVEC(I))/H + 70 CONTINUE + 80 CONTINUE + 90 CONTINUE + 100 CONTINUE + 110 CONTINUE + RETURN +C +C LAST CARD OF SUBROUTINE FDJAC1. +C + END + SUBROUTINE FDJAC2(FCN,M,N,X,FVEC,FJAC,LDFJAC,IFLAG,EPSFCN,WA) + INTEGER M,N,LDFJAC,IFLAG + DOUBLE PRECISION EPSFCN + DOUBLE PRECISION X(N),FVEC(M),FJAC(LDFJAC,N),WA(M) +C ********** +C +C SUBROUTINE FDJAC2 +C +C THIS SUBROUTINE COMPUTES A FORWARD-DIFFERENCE APPROXIMATION +C TO THE M BY N JACOBIAN MATRIX ASSOCIATED WITH A SPECIFIED +C PROBLEM OF M FUNCTIONS IN N VARIABLES. +C +C THE SUBROUTINE STATEMENT IS +C +C SUBROUTINE FDJAC2(FCN,M,N,X,FVEC,FJAC,LDFJAC,IFLAG,EPSFCN,WA) +C +C WHERE +C +C FCN IS THE NAME OF THE USER-SUPPLIED SUBROUTINE WHICH +C CALCULATES THE FUNCTIONS. FCN MUST BE DECLARED +C IN AN EXTERNAL STATEMENT IN THE USER CALLING +C PROGRAM, AND SHOULD BE WRITTEN AS FOLLOWS. +C +C SUBROUTINE FCN(M,N,X,FVEC,IFLAG) +C INTEGER M,N,IFLAG +C DOUBLE PRECISION X(N),FVEC(M) +C ---------- +C CALCULATE THE FUNCTIONS AT X AND +C RETURN THIS VECTOR IN FVEC. +C ---------- +C RETURN +C END +C +C THE VALUE OF IFLAG SHOULD NOT BE CHANGED BY FCN UNLESS +C THE USER WANTS TO TERMINATE EXECUTION OF FDJAC2. +C IN THIS CASE SET IFLAG TO A NEGATIVE INTEGER. +C +C M IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER +C OF FUNCTIONS. +C +C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER +C OF VARIABLES. N MUST NOT EXCEED M. +C +C X IS AN INPUT ARRAY OF LENGTH N. +C +C FVEC IS AN INPUT ARRAY OF LENGTH M WHICH MUST CONTAIN THE +C FUNCTIONS EVALUATED AT X. +C +C FJAC IS AN OUTPUT M BY N ARRAY WHICH CONTAINS THE +C APPROXIMATION TO THE JACOBIAN MATRIX EVALUATED AT X. +C +C LDFJAC IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN M +C WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY FJAC. +C +C IFLAG IS AN INTEGER VARIABLE WHICH CAN BE USED TO TERMINATE +C THE EXECUTION OF FDJAC2. SEE DESCRIPTION OF FCN. +C +C EPSFCN IS AN INPUT VARIABLE USED IN DETERMINING A SUITABLE +C STEP LENGTH FOR THE FORWARD-DIFFERENCE APPROXIMATION. THIS +C APPROXIMATION ASSUMES THAT THE RELATIVE ERRORS IN THE +C FUNCTIONS ARE OF THE ORDER OF EPSFCN. IF EPSFCN IS LESS +C THAN THE MACHINE PRECISION, IT IS ASSUMED THAT THE RELATIVE +C ERRORS IN THE FUNCTIONS ARE OF THE ORDER OF THE MACHINE +C PRECISION. +C +C WA IS A WORK ARRAY OF LENGTH M. +C +C SUBPROGRAMS CALLED +C +C USER-SUPPLIED ...... FCN +C +C MINPACK-SUPPLIED ... DPMPAR +C +C FORTRAN-SUPPLIED ... DABS,DMAX1,DSQRT +C +C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. +C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE +C +C ********** + INTEGER I,J + DOUBLE PRECISION EPS,EPSMCH,H,TEMP,ZERO + DOUBLE PRECISION DPMPAR + DATA ZERO /0.0D0/ +C +C EPSMCH IS THE MACHINE PRECISION. +C + EPSMCH = DPMPAR(1) +C + EPS = DSQRT(DMAX1(EPSFCN,EPSMCH)) + DO 20 J = 1, N + TEMP = X(J) + H = EPS*DABS(TEMP) + IF (H .EQ. ZERO) H = EPS + X(J) = TEMP + H + CALL FCN(M,N,X,WA,IFLAG) + IF (IFLAG .LT. 0) GO TO 30 + X(J) = TEMP + DO 10 I = 1, M + FJAC(I,J) = (WA(I) - FVEC(I))/H + 10 CONTINUE + 20 CONTINUE + 30 CONTINUE + RETURN +C +C LAST CARD OF SUBROUTINE FDJAC2. +C + END + SUBROUTINE HYBRD(FCN,N,X,FVEC,XTOL,MAXFEV,ML,MU,EPSFCN,DIAG, + * MODE,FACTOR,NPRINT,INFO,NFEV,FJAC,LDFJAC,R,LR, + * QTF,WA1,WA2,WA3,WA4) + INTEGER N,MAXFEV,ML,MU,MODE,NPRINT,INFO,NFEV,LDFJAC,LR + DOUBLE PRECISION XTOL,EPSFCN,FACTOR + DOUBLE PRECISION X(N),FVEC(N),DIAG(N),FJAC(LDFJAC,N),R(LR), + * QTF(N),WA1(N),WA2(N),WA3(N),WA4(N) + EXTERNAL FCN +C ********** +C +C SUBROUTINE HYBRD +C +C THE PURPOSE OF HYBRD IS TO FIND A ZERO OF A SYSTEM OF +C N NONLINEAR FUNCTIONS IN N VARIABLES BY A MODIFICATION +C OF THE POWELL HYBRID METHOD. THE USER MUST PROVIDE A +C SUBROUTINE WHICH CALCULATES THE FUNCTIONS. THE JACOBIAN IS +C THEN CALCULATED BY A FORWARD-DIFFERENCE APPROXIMATION. +C +C THE SUBROUTINE STATEMENT IS +C +C SUBROUTINE HYBRD(FCN,N,X,FVEC,XTOL,MAXFEV,ML,MU,EPSFCN, +C DIAG,MODE,FACTOR,NPRINT,INFO,NFEV,FJAC, +C LDFJAC,R,LR,QTF,WA1,WA2,WA3,WA4) +C +C WHERE +C +C FCN IS THE NAME OF THE USER-SUPPLIED SUBROUTINE WHICH +C CALCULATES THE FUNCTIONS. FCN MUST BE DECLARED +C IN AN EXTERNAL STATEMENT IN THE USER CALLING +C PROGRAM, AND SHOULD BE WRITTEN AS FOLLOWS. +C +C SUBROUTINE FCN(N,X,FVEC,IFLAG) +C INTEGER N,IFLAG +C DOUBLE PRECISION X(N),FVEC(N) +C ---------- +C CALCULATE THE FUNCTIONS AT X AND +C RETURN THIS VECTOR IN FVEC. +C --------- +C RETURN +C END +C +C THE VALUE OF IFLAG SHOULD NOT BE CHANGED BY FCN UNLESS +C THE USER WANTS TO TERMINATE EXECUTION OF HYBRD. +C IN THIS CASE SET IFLAG TO A NEGATIVE INTEGER. +C +C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER +C OF FUNCTIONS AND VARIABLES. +C +C X IS AN ARRAY OF LENGTH N. ON INPUT X MUST CONTAIN +C AN INITIAL ESTIMATE OF THE SOLUTION VECTOR. ON OUTPUT X +C CONTAINS THE FINAL ESTIMATE OF THE SOLUTION VECTOR. +C +C FVEC IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS +C THE FUNCTIONS EVALUATED AT THE OUTPUT X. +C +C XTOL IS A NONNEGATIVE INPUT VARIABLE. TERMINATION +C OCCURS WHEN THE RELATIVE ERROR BETWEEN TWO CONSECUTIVE +C ITERATES IS AT MOST XTOL. +C +C MAXFEV IS A POSITIVE INTEGER INPUT VARIABLE. TERMINATION +C OCCURS WHEN THE NUMBER OF CALLS TO FCN IS AT LEAST MAXFEV +C BY THE END OF AN ITERATION. +C +C ML IS A NONNEGATIVE INTEGER INPUT VARIABLE WHICH SPECIFIES +C THE NUMBER OF SUBDIAGONALS WITHIN THE BAND OF THE +C JACOBIAN MATRIX. IF THE JACOBIAN IS NOT BANDED, SET +C ML TO AT LEAST N - 1. +C +C MU IS A NONNEGATIVE INTEGER INPUT VARIABLE WHICH SPECIFIES +C THE NUMBER OF SUPERDIAGONALS WITHIN THE BAND OF THE +C JACOBIAN MATRIX. IF THE JACOBIAN IS NOT BANDED, SET +C MU TO AT LEAST N - 1. +C +C EPSFCN IS AN INPUT VARIABLE USED IN DETERMINING A SUITABLE +C STEP LENGTH FOR THE FORWARD-DIFFERENCE APPROXIMATION. THIS +C APPROXIMATION ASSUMES THAT THE RELATIVE ERRORS IN THE +C FUNCTIONS ARE OF THE ORDER OF EPSFCN. IF EPSFCN IS LESS +C THAN THE MACHINE PRECISION, IT IS ASSUMED THAT THE RELATIVE +C ERRORS IN THE FUNCTIONS ARE OF THE ORDER OF THE MACHINE +C PRECISION. +C +C DIAG IS AN ARRAY OF LENGTH N. IF MODE = 1 (SEE +C BELOW), DIAG IS INTERNALLY SET. IF MODE = 2, DIAG +C MUST CONTAIN POSITIVE ENTRIES THAT SERVE AS +C MULTIPLICATIVE SCALE FACTORS FOR THE VARIABLES. +C +C MODE IS AN INTEGER INPUT VARIABLE. IF MODE = 1, THE +C VARIABLES WILL BE SCALED INTERNALLY. IF MODE = 2, +C THE SCALING IS SPECIFIED BY THE INPUT DIAG. OTHER +C VALUES OF MODE ARE EQUIVALENT TO MODE = 1. +C +C FACTOR IS A POSITIVE INPUT VARIABLE USED IN DETERMINING THE +C INITIAL STEP BOUND. THIS BOUND IS SET TO THE PRODUCT OF +C FACTOR AND THE EUCLIDEAN NORM OF DIAG*X IF NONZERO, OR ELSE +C TO FACTOR ITSELF. IN MOST CASES FACTOR SHOULD LIE IN THE +C INTERVAL (.1,100.). 100. IS A GENERALLY RECOMMENDED VALUE. +C +C NPRINT IS AN INTEGER INPUT VARIABLE THAT ENABLES CONTROLLED +C PRINTING OF ITERATES IF IT IS POSITIVE. IN THIS CASE, +C FCN IS CALLED WITH IFLAG = 0 AT THE BEGINNING OF THE FIRST +C ITERATION AND EVERY NPRINT ITERATIONS THEREAFTER AND +C IMMEDIATELY PRIOR TO RETURN, WITH X AND FVEC AVAILABLE +C FOR PRINTING. IF NPRINT IS NOT POSITIVE, NO SPECIAL CALLS +C OF FCN WITH IFLAG = 0 ARE MADE. +C +C INFO IS AN INTEGER OUTPUT VARIABLE. IF THE USER HAS +C TERMINATED EXECUTION, INFO IS SET TO THE (NEGATIVE) +C VALUE OF IFLAG. SEE DESCRIPTION OF FCN. OTHERWISE, +C INFO IS SET AS FOLLOWS. +C +C INFO = 0 IMPROPER INPUT PARAMETERS. +C +C INFO = 1 RELATIVE ERROR BETWEEN TWO CONSECUTIVE ITERATES +C IS AT MOST XTOL. +C +C INFO = 2 NUMBER OF CALLS TO FCN HAS REACHED OR EXCEEDED +C MAXFEV. +C +C INFO = 3 XTOL IS TOO SMALL. NO FURTHER IMPROVEMENT IN +C THE APPROXIMATE SOLUTION X IS POSSIBLE. +C +C INFO = 4 ITERATION IS NOT MAKING GOOD PROGRESS, AS +C MEASURED BY THE IMPROVEMENT FROM THE LAST +C FIVE JACOBIAN EVALUATIONS. +C +C INFO = 5 ITERATION IS NOT MAKING GOOD PROGRESS, AS +C MEASURED BY THE IMPROVEMENT FROM THE LAST +C TEN ITERATIONS. +C +C NFEV IS AN INTEGER OUTPUT VARIABLE SET TO THE NUMBER OF +C CALLS TO FCN. +C +C FJAC IS AN OUTPUT N BY N ARRAY WHICH CONTAINS THE +C ORTHOGONAL MATRIX Q PRODUCED BY THE QR FACTORIZATION +C OF THE FINAL APPROXIMATE JACOBIAN. +C +C LDFJAC IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN N +C WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY FJAC. +C +C R IS AN OUTPUT ARRAY OF LENGTH LR WHICH CONTAINS THE +C UPPER TRIANGULAR MATRIX PRODUCED BY THE QR FACTORIZATION +C OF THE FINAL APPROXIMATE JACOBIAN, STORED ROWWISE. +C +C LR IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN +C (N*(N+1))/2. +C +C QTF IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS +C THE VECTOR (Q TRANSPOSE)*FVEC. +C +C WA1, WA2, WA3, AND WA4 ARE WORK ARRAYS OF LENGTH N. +C +C SUBPROGRAMS CALLED +C +C USER-SUPPLIED ...... FCN +C +C MINPACK-SUPPLIED ... DOGLEG,DPMPAR,ENORM,FDJAC1, +C QFORM,QRFAC,R1MPYQ,R1UPDT +C +C FORTRAN-SUPPLIED ... DABS,DMAX1,DMIN1,MIN0,MOD +C +C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. +C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE +C +C ********** + INTEGER I,IFLAG,ITER,J,JM1,L,MSUM,NCFAIL,NCSUC,NSLOW1,NSLOW2 + INTEGER IWA(1) + LOGICAL JEVAL,SING + DOUBLE PRECISION ACTRED,DELTA,EPSMCH,FNORM,FNORM1,ONE,PNORM, + * PRERED,P1,P5,P001,P0001,RATIO,SUM,TEMP,XNORM, + * ZERO + DOUBLE PRECISION DPMPAR,ENORM + DATA ONE,P1,P5,P001,P0001,ZERO + * /1.0D0,1.0D-1,5.0D-1,1.0D-3,1.0D-4,0.0D0/ +C +C EPSMCH IS THE MACHINE PRECISION. +C + EPSMCH = DPMPAR(1) +C + INFO = 0 + IFLAG = 0 + NFEV = 0 +C +C CHECK THE INPUT PARAMETERS FOR ERRORS. +C + IF (N .LE. 0 .OR. XTOL .LT. ZERO .OR. MAXFEV .LE. 0 + * .OR. ML .LT. 0 .OR. MU .LT. 0 .OR. FACTOR .LE. ZERO + * .OR. LDFJAC .LT. N .OR. LR .LT. (N*(N + 1))/2) GO TO 300 + IF (MODE .NE. 2) GO TO 20 + DO 10 J = 1, N + IF (DIAG(J) .LE. ZERO) GO TO 300 + 10 CONTINUE + 20 CONTINUE +C +C EVALUATE THE FUNCTION AT THE STARTING POINT +C AND CALCULATE ITS NORM. +C + IFLAG = 1 + CALL FCN(N,X,FVEC,IFLAG) + NFEV = 1 + IF (IFLAG .LT. 0) GO TO 300 + FNORM = ENORM(N,FVEC) +C +C DETERMINE THE NUMBER OF CALLS TO FCN NEEDED TO COMPUTE +C THE JACOBIAN MATRIX. +C + MSUM = MIN0(ML+MU+1,N) +C +C INITIALIZE ITERATION COUNTER AND MONITORS. +C + ITER = 1 + NCSUC = 0 + NCFAIL = 0 + NSLOW1 = 0 + NSLOW2 = 0 +C +C BEGINNING OF THE OUTER LOOP. +C + 30 CONTINUE + JEVAL = .TRUE. +C +C CALCULATE THE JACOBIAN MATRIX. +C + IFLAG = 2 + CALL FDJAC1(FCN,N,X,FVEC,FJAC,LDFJAC,IFLAG,ML,MU,EPSFCN,WA1, + * WA2) + NFEV = NFEV + MSUM + IF (IFLAG .LT. 0) GO TO 300 +C +C COMPUTE THE QR FACTORIZATION OF THE JACOBIAN. +C + CALL QRFAC(N,N,FJAC,LDFJAC,.FALSE.,IWA,1,WA1,WA2,WA3) +C +C ON THE FIRST ITERATION AND IF MODE IS 1, SCALE ACCORDING +C TO THE NORMS OF THE COLUMNS OF THE INITIAL JACOBIAN. +C + IF (ITER .NE. 1) GO TO 70 + IF (MODE .EQ. 2) GO TO 50 + DO 40 J = 1, N + DIAG(J) = WA2(J) + IF (WA2(J) .EQ. ZERO) DIAG(J) = ONE + 40 CONTINUE + 50 CONTINUE +C +C ON THE FIRST ITERATION, CALCULATE THE NORM OF THE SCALED X +C AND INITIALIZE THE STEP BOUND DELTA. +C + DO 60 J = 1, N + WA3(J) = DIAG(J)*X(J) + 60 CONTINUE + XNORM = ENORM(N,WA3) + DELTA = FACTOR*XNORM + IF (DELTA .EQ. ZERO) DELTA = FACTOR + 70 CONTINUE +C +C FORM (Q TRANSPOSE)*FVEC AND STORE IN QTF. +C + DO 80 I = 1, N + QTF(I) = FVEC(I) + 80 CONTINUE + DO 120 J = 1, N + IF (FJAC(J,J) .EQ. ZERO) GO TO 110 + SUM = ZERO + DO 90 I = J, N + SUM = SUM + FJAC(I,J)*QTF(I) + 90 CONTINUE + TEMP = -SUM/FJAC(J,J) + DO 100 I = J, N + QTF(I) = QTF(I) + FJAC(I,J)*TEMP + 100 CONTINUE + 110 CONTINUE + 120 CONTINUE +C +C COPY THE TRIANGULAR FACTOR OF THE QR FACTORIZATION INTO R. +C + SING = .FALSE. + DO 150 J = 1, N + L = J + JM1 = J - 1 + IF (JM1 .LT. 1) GO TO 140 + DO 130 I = 1, JM1 + R(L) = FJAC(I,J) + L = L + N - I + 130 CONTINUE + 140 CONTINUE + R(L) = WA1(J) + IF (WA1(J) .EQ. ZERO) SING = .TRUE. + 150 CONTINUE +C +C ACCUMULATE THE ORTHOGONAL FACTOR IN FJAC. +C + CALL QFORM(N,N,FJAC,LDFJAC,WA1) +C +C RESCALE IF NECESSARY. +C + IF (MODE .EQ. 2) GO TO 170 + DO 160 J = 1, N + DIAG(J) = DMAX1(DIAG(J),WA2(J)) + 160 CONTINUE + 170 CONTINUE +C +C BEGINNING OF THE INNER LOOP. +C + 180 CONTINUE +C +C IF REQUESTED, CALL FCN TO ENABLE PRINTING OF ITERATES. +C + IF (NPRINT .LE. 0) GO TO 190 + IFLAG = 0 + IF (MOD(ITER-1,NPRINT) .EQ. 0) CALL FCN(N,X,FVEC,IFLAG) + IF (IFLAG .LT. 0) GO TO 300 + 190 CONTINUE +C +C DETERMINE THE DIRECTION P. +C + CALL DOGLEG(N,R,LR,DIAG,QTF,DELTA,WA1,WA2,WA3) +C +C STORE THE DIRECTION P AND X + P. CALCULATE THE NORM OF P. +C + DO 200 J = 1, N + WA1(J) = -WA1(J) + WA2(J) = X(J) + WA1(J) + WA3(J) = DIAG(J)*WA1(J) + 200 CONTINUE + PNORM = ENORM(N,WA3) +C +C ON THE FIRST ITERATION, ADJUST THE INITIAL STEP BOUND. +C + IF (ITER .EQ. 1) DELTA = DMIN1(DELTA,PNORM) +C +C EVALUATE THE FUNCTION AT X + P AND CALCULATE ITS NORM. +C + IFLAG = 1 + CALL FCN(N,WA2,WA4,IFLAG) + NFEV = NFEV + 1 + IF (IFLAG .LT. 0) GO TO 300 + FNORM1 = ENORM(N,WA4) +C +C COMPUTE THE SCALED ACTUAL REDUCTION. +C + ACTRED = -ONE + IF (FNORM1 .LT. FNORM) ACTRED = ONE - (FNORM1/FNORM)**2 +C +C COMPUTE THE SCALED PREDICTED REDUCTION. +C + L = 1 + DO 220 I = 1, N + SUM = ZERO + DO 210 J = I, N + SUM = SUM + R(L)*WA1(J) + L = L + 1 + 210 CONTINUE + WA3(I) = QTF(I) + SUM + 220 CONTINUE + TEMP = ENORM(N,WA3) + PRERED = ZERO + IF (TEMP .LT. FNORM) PRERED = ONE - (TEMP/FNORM)**2 +C +C COMPUTE THE RATIO OF THE ACTUAL TO THE PREDICTED +C REDUCTION. +C + RATIO = ZERO + IF (PRERED .GT. ZERO) RATIO = ACTRED/PRERED +C +C UPDATE THE STEP BOUND. +C + IF (RATIO .GE. P1) GO TO 230 + NCSUC = 0 + NCFAIL = NCFAIL + 1 + DELTA = P5*DELTA + GO TO 240 + 230 CONTINUE + NCFAIL = 0 + NCSUC = NCSUC + 1 + IF (RATIO .GE. P5 .OR. NCSUC .GT. 1) + * DELTA = DMAX1(DELTA,PNORM/P5) + IF (DABS(RATIO-ONE) .LE. P1) DELTA = PNORM/P5 + 240 CONTINUE +C +C TEST FOR SUCCESSFUL ITERATION. +C + IF (RATIO .LT. P0001) GO TO 260 +C +C SUCCESSFUL ITERATION. UPDATE X, FVEC, AND THEIR NORMS. +C + DO 250 J = 1, N + X(J) = WA2(J) + WA2(J) = DIAG(J)*X(J) + FVEC(J) = WA4(J) + 250 CONTINUE + XNORM = ENORM(N,WA2) + FNORM = FNORM1 + ITER = ITER + 1 + 260 CONTINUE +C +C DETERMINE THE PROGRESS OF THE ITERATION. +C + NSLOW1 = NSLOW1 + 1 + IF (ACTRED .GE. P001) NSLOW1 = 0 + IF (JEVAL) NSLOW2 = NSLOW2 + 1 + IF (ACTRED .GE. P1) NSLOW2 = 0 +C +C TEST FOR CONVERGENCE. +C + IF (DELTA .LE. XTOL*XNORM .OR. FNORM .EQ. ZERO) INFO = 1 + IF (INFO .NE. 0) GO TO 300 +C +C TESTS FOR TERMINATION AND STRINGENT TOLERANCES. +C + IF (NFEV .GE. MAXFEV) INFO = 2 + IF (P1*DMAX1(P1*DELTA,PNORM) .LE. EPSMCH*XNORM) INFO = 3 + IF (NSLOW2 .EQ. 5) INFO = 4 + IF (NSLOW1 .EQ. 10) INFO = 5 + IF (INFO .NE. 0) GO TO 300 +C +C CRITERION FOR RECALCULATING JACOBIAN APPROXIMATION +C BY FORWARD DIFFERENCES. +C + IF (NCFAIL .EQ. 2) GO TO 290 +C +C CALCULATE THE RANK ONE MODIFICATION TO THE JACOBIAN +C AND UPDATE QTF IF NECESSARY. +C + DO 280 J = 1, N + SUM = ZERO + DO 270 I = 1, N + SUM = SUM + FJAC(I,J)*WA4(I) + 270 CONTINUE + WA2(J) = (SUM - WA3(J))/PNORM + WA1(J) = DIAG(J)*((DIAG(J)*WA1(J))/PNORM) + IF (RATIO .GE. P0001) QTF(J) = SUM + 280 CONTINUE +C +C COMPUTE THE QR FACTORIZATION OF THE UPDATED JACOBIAN. +C + CALL R1UPDT(N,N,R,LR,WA1,WA2,WA3,SING) + CALL R1MPYQ(N,N,FJAC,LDFJAC,WA2,WA3) + CALL R1MPYQ(1,N,QTF,1,WA2,WA3) +C +C END OF THE INNER LOOP. +C + JEVAL = .FALSE. + GO TO 180 + 290 CONTINUE +C +C END OF THE OUTER LOOP. +C + GO TO 30 + 300 CONTINUE +C +C TERMINATION, EITHER NORMAL OR USER IMPOSED. +C + IF (IFLAG .LT. 0) INFO = IFLAG + IFLAG = 0 + IF (NPRINT .GT. 0) CALL FCN(N,X,FVEC,IFLAG) + RETURN +C +C LAST CARD OF SUBROUTINE HYBRD. +C + END + SUBROUTINE HYBRD1(FCN,N,X,FVEC,TOL,INFO,WA,LWA) + INTEGER N,INFO,LWA + DOUBLE PRECISION TOL + DOUBLE PRECISION X(N),FVEC(N),WA(LWA) + EXTERNAL FCN +C ********** +C +C SUBROUTINE HYBRD1 +C +C THE PURPOSE OF HYBRD1 IS TO FIND A ZERO OF A SYSTEM OF +C N NONLINEAR FUNCTIONS IN N VARIABLES BY A MODIFICATION +C OF THE POWELL HYBRID METHOD. THIS IS DONE BY USING THE +C MORE GENERAL NONLINEAR EQUATION SOLVER HYBRD. THE USER +C MUST PROVIDE A SUBROUTINE WHICH CALCULATES THE FUNCTIONS. +C THE JACOBIAN IS THEN CALCULATED BY A FORWARD-DIFFERENCE +C APPROXIMATION. +C +C THE SUBROUTINE STATEMENT IS +C +C SUBROUTINE HYBRD1(FCN,N,X,FVEC,TOL,INFO,WA,LWA) +C +C WHERE +C +C FCN IS THE NAME OF THE USER-SUPPLIED SUBROUTINE WHICH +C CALCULATES THE FUNCTIONS. FCN MUST BE DECLARED +C IN AN EXTERNAL STATEMENT IN THE USER CALLING +C PROGRAM, AND SHOULD BE WRITTEN AS FOLLOWS. +C +C SUBROUTINE FCN(N,X,FVEC,IFLAG) +C INTEGER N,IFLAG +C DOUBLE PRECISION X(N),FVEC(N) +C ---------- +C CALCULATE THE FUNCTIONS AT X AND +C RETURN THIS VECTOR IN FVEC. +C --------- +C RETURN +C END +C +C THE VALUE OF IFLAG SHOULD NOT BE CHANGED BY FCN UNLESS +C THE USER WANTS TO TERMINATE EXECUTION OF HYBRD1. +C IN THIS CASE SET IFLAG TO A NEGATIVE INTEGER. +C +C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER +C OF FUNCTIONS AND VARIABLES. +C +C X IS AN ARRAY OF LENGTH N. ON INPUT X MUST CONTAIN +C AN INITIAL ESTIMATE OF THE SOLUTION VECTOR. ON OUTPUT X +C CONTAINS THE FINAL ESTIMATE OF THE SOLUTION VECTOR. +C +C FVEC IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS +C THE FUNCTIONS EVALUATED AT THE OUTPUT X. +C +C TOL IS A NONNEGATIVE INPUT VARIABLE. TERMINATION OCCURS +C WHEN THE ALGORITHM ESTIMATES THAT THE RELATIVE ERROR +C BETWEEN X AND THE SOLUTION IS AT MOST TOL. +C +C INFO IS AN INTEGER OUTPUT VARIABLE. IF THE USER HAS +C TERMINATED EXECUTION, INFO IS SET TO THE (NEGATIVE) +C VALUE OF IFLAG. SEE DESCRIPTION OF FCN. OTHERWISE, +C INFO IS SET AS FOLLOWS. +C +C INFO = 0 IMPROPER INPUT PARAMETERS. +C +C INFO = 1 ALGORITHM ESTIMATES THAT THE RELATIVE ERROR +C BETWEEN X AND THE SOLUTION IS AT MOST TOL. +C +C INFO = 2 NUMBER OF CALLS TO FCN HAS REACHED OR EXCEEDED +C 200*(N+1). +C +C INFO = 3 TOL IS TOO SMALL. NO FURTHER IMPROVEMENT IN +C THE APPROXIMATE SOLUTION X IS POSSIBLE. +C +C INFO = 4 ITERATION IS NOT MAKING GOOD PROGRESS. +C +C WA IS A WORK ARRAY OF LENGTH LWA. +C +C LWA IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN +C (N*(3*N+13))/2. +C +C SUBPROGRAMS CALLED +C +C USER-SUPPLIED ...... FCN +C +C MINPACK-SUPPLIED ... HYBRD +C +C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. +C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE +C +C ********** + INTEGER INDEX,J,LR,MAXFEV,ML,MODE,MU,NFEV,NPRINT + DOUBLE PRECISION EPSFCN,FACTOR,ONE,XTOL,ZERO + DATA FACTOR,ONE,ZERO /1.0D2,1.0D0,0.0D0/ + INFO = 0 +C +C CHECK THE INPUT PARAMETERS FOR ERRORS. +C + IF (N .LE. 0 .OR. TOL .LT. ZERO .OR. LWA .LT. (N*(3*N + 13))/2) + * GO TO 20 +C +C CALL HYBRD. +C + MAXFEV = 200*(N + 1) + XTOL = TOL + ML = N - 1 + MU = N - 1 + EPSFCN = ZERO + MODE = 2 + DO 10 J = 1, N + WA(J) = ONE + 10 CONTINUE + NPRINT = 0 + LR = (N*(N + 1))/2 + INDEX = 6*N + LR + CALL HYBRD(FCN,N,X,FVEC,XTOL,MAXFEV,ML,MU,EPSFCN,WA(1),MODE, + * FACTOR,NPRINT,INFO,NFEV,WA(INDEX+1),N,WA(6*N+1),LR, + * WA(N+1),WA(2*N+1),WA(3*N+1),WA(4*N+1),WA(5*N+1)) + IF (INFO .EQ. 5) INFO = 4 + 20 CONTINUE + RETURN +C +C LAST CARD OF SUBROUTINE HYBRD1. +C + END + SUBROUTINE HYBRJ(FCN,N,X,FVEC,FJAC,LDFJAC,XTOL,MAXFEV,DIAG,MODE, + * FACTOR,NPRINT,INFO,NFEV,NJEV,R,LR,QTF,WA1,WA2, + * WA3,WA4) + INTEGER N,LDFJAC,MAXFEV,MODE,NPRINT,INFO,NFEV,NJEV,LR + DOUBLE PRECISION XTOL,FACTOR + DOUBLE PRECISION X(N),FVEC(N),FJAC(LDFJAC,N),DIAG(N),R(LR), + * QTF(N),WA1(N),WA2(N),WA3(N),WA4(N) +C ********** +C +C SUBROUTINE HYBRJ +C +C THE PURPOSE OF HYBRJ IS TO FIND A ZERO OF A SYSTEM OF +C N NONLINEAR FUNCTIONS IN N VARIABLES BY A MODIFICATION +C OF THE POWELL HYBRID METHOD. THE USER MUST PROVIDE A +C SUBROUTINE WHICH CALCULATES THE FUNCTIONS AND THE JACOBIAN. +C +C THE SUBROUTINE STATEMENT IS +C +C SUBROUTINE HYBRJ(FCN,N,X,FVEC,FJAC,LDFJAC,XTOL,MAXFEV,DIAG, +C MODE,FACTOR,NPRINT,INFO,NFEV,NJEV,R,LR,QTF, +C WA1,WA2,WA3,WA4) +C +C WHERE +C +C FCN IS THE NAME OF THE USER-SUPPLIED SUBROUTINE WHICH +C CALCULATES THE FUNCTIONS AND THE JACOBIAN. FCN MUST +C BE DECLARED IN AN EXTERNAL STATEMENT IN THE USER +C CALLING PROGRAM, AND SHOULD BE WRITTEN AS FOLLOWS. +C +C SUBROUTINE FCN(N,X,FVEC,FJAC,LDFJAC,IFLAG) +C INTEGER N,LDFJAC,IFLAG +C DOUBLE PRECISION X(N),FVEC(N),FJAC(LDFJAC,N) +C ---------- +C IF IFLAG = 1 CALCULATE THE FUNCTIONS AT X AND +C RETURN THIS VECTOR IN FVEC. DO NOT ALTER FJAC. +C IF IFLAG = 2 CALCULATE THE JACOBIAN AT X AND +C RETURN THIS MATRIX IN FJAC. DO NOT ALTER FVEC. +C --------- +C RETURN +C END +C +C THE VALUE OF IFLAG SHOULD NOT BE CHANGED BY FCN UNLESS +C THE USER WANTS TO TERMINATE EXECUTION OF HYBRJ. +C IN THIS CASE SET IFLAG TO A NEGATIVE INTEGER. +C +C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER +C OF FUNCTIONS AND VARIABLES. +C +C X IS AN ARRAY OF LENGTH N. ON INPUT X MUST CONTAIN +C AN INITIAL ESTIMATE OF THE SOLUTION VECTOR. ON OUTPUT X +C CONTAINS THE FINAL ESTIMATE OF THE SOLUTION VECTOR. +C +C FVEC IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS +C THE FUNCTIONS EVALUATED AT THE OUTPUT X. +C +C FJAC IS AN OUTPUT N BY N ARRAY WHICH CONTAINS THE +C ORTHOGONAL MATRIX Q PRODUCED BY THE QR FACTORIZATION +C OF THE FINAL APPROXIMATE JACOBIAN. +C +C LDFJAC IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN N +C WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY FJAC. +C +C XTOL IS A NONNEGATIVE INPUT VARIABLE. TERMINATION +C OCCURS WHEN THE RELATIVE ERROR BETWEEN TWO CONSECUTIVE +C ITERATES IS AT MOST XTOL. +C +C MAXFEV IS A POSITIVE INTEGER INPUT VARIABLE. TERMINATION +C OCCURS WHEN THE NUMBER OF CALLS TO FCN WITH IFLAG = 1 +C HAS REACHED MAXFEV. +C +C DIAG IS AN ARRAY OF LENGTH N. IF MODE = 1 (SEE +C BELOW), DIAG IS INTERNALLY SET. IF MODE = 2, DIAG +C MUST CONTAIN POSITIVE ENTRIES THAT SERVE AS +C MULTIPLICATIVE SCALE FACTORS FOR THE VARIABLES. +C +C MODE IS AN INTEGER INPUT VARIABLE. IF MODE = 1, THE +C VARIABLES WILL BE SCALED INTERNALLY. IF MODE = 2, +C THE SCALING IS SPECIFIED BY THE INPUT DIAG. OTHER +C VALUES OF MODE ARE EQUIVALENT TO MODE = 1. +C +C FACTOR IS A POSITIVE INPUT VARIABLE USED IN DETERMINING THE +C INITIAL STEP BOUND. THIS BOUND IS SET TO THE PRODUCT OF +C FACTOR AND THE EUCLIDEAN NORM OF DIAG*X IF NONZERO, OR ELSE +C TO FACTOR ITSELF. IN MOST CASES FACTOR SHOULD LIE IN THE +C INTERVAL (.1,100.). 100. IS A GENERALLY RECOMMENDED VALUE. +C +C NPRINT IS AN INTEGER INPUT VARIABLE THAT ENABLES CONTROLLED +C PRINTING OF ITERATES IF IT IS POSITIVE. IN THIS CASE, +C FCN IS CALLED WITH IFLAG = 0 AT THE BEGINNING OF THE FIRST +C ITERATION AND EVERY NPRINT ITERATIONS THEREAFTER AND +C IMMEDIATELY PRIOR TO RETURN, WITH X AND FVEC AVAILABLE +C FOR PRINTING. FVEC AND FJAC SHOULD NOT BE ALTERED. +C IF NPRINT IS NOT POSITIVE, NO SPECIAL CALLS OF FCN +C WITH IFLAG = 0 ARE MADE. +C +C INFO IS AN INTEGER OUTPUT VARIABLE. IF THE USER HAS +C TERMINATED EXECUTION, INFO IS SET TO THE (NEGATIVE) +C VALUE OF IFLAG. SEE DESCRIPTION OF FCN. OTHERWISE, +C INFO IS SET AS FOLLOWS. +C +C INFO = 0 IMPROPER INPUT PARAMETERS. +C +C INFO = 1 RELATIVE ERROR BETWEEN TWO CONSECUTIVE ITERATES +C IS AT MOST XTOL. +C +C INFO = 2 NUMBER OF CALLS TO FCN WITH IFLAG = 1 HAS +C REACHED MAXFEV. +C +C INFO = 3 XTOL IS TOO SMALL. NO FURTHER IMPROVEMENT IN +C THE APPROXIMATE SOLUTION X IS POSSIBLE. +C +C INFO = 4 ITERATION IS NOT MAKING GOOD PROGRESS, AS +C MEASURED BY THE IMPROVEMENT FROM THE LAST +C FIVE JACOBIAN EVALUATIONS. +C +C INFO = 5 ITERATION IS NOT MAKING GOOD PROGRESS, AS +C MEASURED BY THE IMPROVEMENT FROM THE LAST +C TEN ITERATIONS. +C +C NFEV IS AN INTEGER OUTPUT VARIABLE SET TO THE NUMBER OF +C CALLS TO FCN WITH IFLAG = 1. +C +C NJEV IS AN INTEGER OUTPUT VARIABLE SET TO THE NUMBER OF +C CALLS TO FCN WITH IFLAG = 2. +C +C R IS AN OUTPUT ARRAY OF LENGTH LR WHICH CONTAINS THE +C UPPER TRIANGULAR MATRIX PRODUCED BY THE QR FACTORIZATION +C OF THE FINAL APPROXIMATE JACOBIAN, STORED ROWWISE. +C +C LR IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN +C (N*(N+1))/2. +C +C QTF IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS +C THE VECTOR (Q TRANSPOSE)*FVEC. +C +C WA1, WA2, WA3, AND WA4 ARE WORK ARRAYS OF LENGTH N. +C +C SUBPROGRAMS CALLED +C +C USER-SUPPLIED ...... FCN +C +C MINPACK-SUPPLIED ... DOGLEG,DPMPAR,ENORM, +C QFORM,QRFAC,R1MPYQ,R1UPDT +C +C FORTRAN-SUPPLIED ... DABS,DMAX1,DMIN1,MOD +C +C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. +C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE +C +C ********** + INTEGER I,IFLAG,ITER,J,JM1,L,NCFAIL,NCSUC,NSLOW1,NSLOW2 + INTEGER IWA(1) + LOGICAL JEVAL,SING + DOUBLE PRECISION ACTRED,DELTA,EPSMCH,FNORM,FNORM1,ONE,PNORM, + * PRERED,P1,P5,P001,P0001,RATIO,SUM,TEMP,XNORM, + * ZERO + DOUBLE PRECISION DPMPAR,ENORM + DATA ONE,P1,P5,P001,P0001,ZERO + * /1.0D0,1.0D-1,5.0D-1,1.0D-3,1.0D-4,0.0D0/ +C +C EPSMCH IS THE MACHINE PRECISION. +C + EPSMCH = DPMPAR(1) +C + INFO = 0 + IFLAG = 0 + NFEV = 0 + NJEV = 0 +C +C CHECK THE INPUT PARAMETERS FOR ERRORS. +C + IF (N .LE. 0 .OR. LDFJAC .LT. N .OR. XTOL .LT. ZERO + * .OR. MAXFEV .LE. 0 .OR. FACTOR .LE. ZERO + * .OR. LR .LT. (N*(N + 1))/2) GO TO 300 + IF (MODE .NE. 2) GO TO 20 + DO 10 J = 1, N + IF (DIAG(J) .LE. ZERO) GO TO 300 + 10 CONTINUE + 20 CONTINUE +C +C EVALUATE THE FUNCTION AT THE STARTING POINT +C AND CALCULATE ITS NORM. +C + IFLAG = 1 + CALL FCN(N,X,FVEC,FJAC,LDFJAC,IFLAG) + NFEV = 1 + IF (IFLAG .LT. 0) GO TO 300 + FNORM = ENORM(N,FVEC) +C +C INITIALIZE ITERATION COUNTER AND MONITORS. +C + ITER = 1 + NCSUC = 0 + NCFAIL = 0 + NSLOW1 = 0 + NSLOW2 = 0 +C +C BEGINNING OF THE OUTER LOOP. +C + 30 CONTINUE + JEVAL = .TRUE. +C +C CALCULATE THE JACOBIAN MATRIX. +C + IFLAG = 2 + CALL FCN(N,X,FVEC,FJAC,LDFJAC,IFLAG) + NJEV = NJEV + 1 + IF (IFLAG .LT. 0) GO TO 300 +C +C COMPUTE THE QR FACTORIZATION OF THE JACOBIAN. +C + CALL QRFAC(N,N,FJAC,LDFJAC,.FALSE.,IWA,1,WA1,WA2,WA3) +C +C ON THE FIRST ITERATION AND IF MODE IS 1, SCALE ACCORDING +C TO THE NORMS OF THE COLUMNS OF THE INITIAL JACOBIAN. +C + IF (ITER .NE. 1) GO TO 70 + IF (MODE .EQ. 2) GO TO 50 + DO 40 J = 1, N + DIAG(J) = WA2(J) + IF (WA2(J) .EQ. ZERO) DIAG(J) = ONE + 40 CONTINUE + 50 CONTINUE +C +C ON THE FIRST ITERATION, CALCULATE THE NORM OF THE SCALED X +C AND INITIALIZE THE STEP BOUND DELTA. +C + DO 60 J = 1, N + WA3(J) = DIAG(J)*X(J) + 60 CONTINUE + XNORM = ENORM(N,WA3) + DELTA = FACTOR*XNORM + IF (DELTA .EQ. ZERO) DELTA = FACTOR + 70 CONTINUE +C +C FORM (Q TRANSPOSE)*FVEC AND STORE IN QTF. +C + DO 80 I = 1, N + QTF(I) = FVEC(I) + 80 CONTINUE + DO 120 J = 1, N + IF (FJAC(J,J) .EQ. ZERO) GO TO 110 + SUM = ZERO + DO 90 I = J, N + SUM = SUM + FJAC(I,J)*QTF(I) + 90 CONTINUE + TEMP = -SUM/FJAC(J,J) + DO 100 I = J, N + QTF(I) = QTF(I) + FJAC(I,J)*TEMP + 100 CONTINUE + 110 CONTINUE + 120 CONTINUE +C +C COPY THE TRIANGULAR FACTOR OF THE QR FACTORIZATION INTO R. +C + SING = .FALSE. + DO 150 J = 1, N + L = J + JM1 = J - 1 + IF (JM1 .LT. 1) GO TO 140 + DO 130 I = 1, JM1 + R(L) = FJAC(I,J) + L = L + N - I + 130 CONTINUE + 140 CONTINUE + R(L) = WA1(J) + IF (WA1(J) .EQ. ZERO) SING = .TRUE. + 150 CONTINUE +C +C ACCUMULATE THE ORTHOGONAL FACTOR IN FJAC. +C + CALL QFORM(N,N,FJAC,LDFJAC,WA1) +C +C RESCALE IF NECESSARY. +C + IF (MODE .EQ. 2) GO TO 170 + DO 160 J = 1, N + DIAG(J) = DMAX1(DIAG(J),WA2(J)) + 160 CONTINUE + 170 CONTINUE +C +C BEGINNING OF THE INNER LOOP. +C + 180 CONTINUE +C +C IF REQUESTED, CALL FCN TO ENABLE PRINTING OF ITERATES. +C + IF (NPRINT .LE. 0) GO TO 190 + IFLAG = 0 + IF (MOD(ITER-1,NPRINT) .EQ. 0) + * CALL FCN(N,X,FVEC,FJAC,LDFJAC,IFLAG) + IF (IFLAG .LT. 0) GO TO 300 + 190 CONTINUE +C +C DETERMINE THE DIRECTION P. +C + CALL DOGLEG(N,R,LR,DIAG,QTF,DELTA,WA1,WA2,WA3) +C +C STORE THE DIRECTION P AND X + P. CALCULATE THE NORM OF P. +C + DO 200 J = 1, N + WA1(J) = -WA1(J) + WA2(J) = X(J) + WA1(J) + WA3(J) = DIAG(J)*WA1(J) + 200 CONTINUE + PNORM = ENORM(N,WA3) +C +C ON THE FIRST ITERATION, ADJUST THE INITIAL STEP BOUND. +C + IF (ITER .EQ. 1) DELTA = DMIN1(DELTA,PNORM) +C +C EVALUATE THE FUNCTION AT X + P AND CALCULATE ITS NORM. +C + IFLAG = 1 + CALL FCN(N,WA2,WA4,FJAC,LDFJAC,IFLAG) + NFEV = NFEV + 1 + IF (IFLAG .LT. 0) GO TO 300 + FNORM1 = ENORM(N,WA4) +C +C COMPUTE THE SCALED ACTUAL REDUCTION. +C + ACTRED = -ONE + IF (FNORM1 .LT. FNORM) ACTRED = ONE - (FNORM1/FNORM)**2 +C +C COMPUTE THE SCALED PREDICTED REDUCTION. +C + L = 1 + DO 220 I = 1, N + SUM = ZERO + DO 210 J = I, N + SUM = SUM + R(L)*WA1(J) + L = L + 1 + 210 CONTINUE + WA3(I) = QTF(I) + SUM + 220 CONTINUE + TEMP = ENORM(N,WA3) + PRERED = ZERO + IF (TEMP .LT. FNORM) PRERED = ONE - (TEMP/FNORM)**2 +C +C COMPUTE THE RATIO OF THE ACTUAL TO THE PREDICTED +C REDUCTION. +C + RATIO = ZERO + IF (PRERED .GT. ZERO) RATIO = ACTRED/PRERED +C +C UPDATE THE STEP BOUND. +C + IF (RATIO .GE. P1) GO TO 230 + NCSUC = 0 + NCFAIL = NCFAIL + 1 + DELTA = P5*DELTA + GO TO 240 + 230 CONTINUE + NCFAIL = 0 + NCSUC = NCSUC + 1 + IF (RATIO .GE. P5 .OR. NCSUC .GT. 1) + * DELTA = DMAX1(DELTA,PNORM/P5) + IF (DABS(RATIO-ONE) .LE. P1) DELTA = PNORM/P5 + 240 CONTINUE +C +C TEST FOR SUCCESSFUL ITERATION. +C + IF (RATIO .LT. P0001) GO TO 260 +C +C SUCCESSFUL ITERATION. UPDATE X, FVEC, AND THEIR NORMS. +C + DO 250 J = 1, N + X(J) = WA2(J) + WA2(J) = DIAG(J)*X(J) + FVEC(J) = WA4(J) + 250 CONTINUE + XNORM = ENORM(N,WA2) + FNORM = FNORM1 + ITER = ITER + 1 + 260 CONTINUE +C +C DETERMINE THE PROGRESS OF THE ITERATION. +C + NSLOW1 = NSLOW1 + 1 + IF (ACTRED .GE. P001) NSLOW1 = 0 + IF (JEVAL) NSLOW2 = NSLOW2 + 1 + IF (ACTRED .GE. P1) NSLOW2 = 0 +C +C TEST FOR CONVERGENCE. +C + IF (DELTA .LE. XTOL*XNORM .OR. FNORM .EQ. ZERO) INFO = 1 + IF (INFO .NE. 0) GO TO 300 +C +C TESTS FOR TERMINATION AND STRINGENT TOLERANCES. +C + IF (NFEV .GE. MAXFEV) INFO = 2 + IF (P1*DMAX1(P1*DELTA,PNORM) .LE. EPSMCH*XNORM) INFO = 3 + IF (NSLOW2 .EQ. 5) INFO = 4 + IF (NSLOW1 .EQ. 10) INFO = 5 + IF (INFO .NE. 0) GO TO 300 +C +C CRITERION FOR RECALCULATING JACOBIAN. +C + IF (NCFAIL .EQ. 2) GO TO 290 +C +C CALCULATE THE RANK ONE MODIFICATION TO THE JACOBIAN +C AND UPDATE QTF IF NECESSARY. +C + DO 280 J = 1, N + SUM = ZERO + DO 270 I = 1, N + SUM = SUM + FJAC(I,J)*WA4(I) + 270 CONTINUE + WA2(J) = (SUM - WA3(J))/PNORM + WA1(J) = DIAG(J)*((DIAG(J)*WA1(J))/PNORM) + IF (RATIO .GE. P0001) QTF(J) = SUM + 280 CONTINUE +C +C COMPUTE THE QR FACTORIZATION OF THE UPDATED JACOBIAN. +C + CALL R1UPDT(N,N,R,LR,WA1,WA2,WA3,SING) + CALL R1MPYQ(N,N,FJAC,LDFJAC,WA2,WA3) + CALL R1MPYQ(1,N,QTF,1,WA2,WA3) +C +C END OF THE INNER LOOP. +C + JEVAL = .FALSE. + GO TO 180 + 290 CONTINUE +C +C END OF THE OUTER LOOP. +C + GO TO 30 + 300 CONTINUE +C +C TERMINATION, EITHER NORMAL OR USER IMPOSED. +C + IF (IFLAG .LT. 0) INFO = IFLAG + IFLAG = 0 + IF (NPRINT .GT. 0) CALL FCN(N,X,FVEC,FJAC,LDFJAC,IFLAG) + RETURN +C +C LAST CARD OF SUBROUTINE HYBRJ. +C + END + SUBROUTINE HYBRJ1(FCN,N,X,FVEC,FJAC,LDFJAC,TOL,INFO,WA,LWA) + INTEGER N,LDFJAC,INFO,LWA + DOUBLE PRECISION TOL + DOUBLE PRECISION X(N),FVEC(N),FJAC(LDFJAC,N),WA(LWA) + EXTERNAL FCN +C ********** +C +C SUBROUTINE HYBRJ1 +C +C THE PURPOSE OF HYBRJ1 IS TO FIND A ZERO OF A SYSTEM OF +C N NONLINEAR FUNCTIONS IN N VARIABLES BY A MODIFICATION +C OF THE POWELL HYBRID METHOD. THIS IS DONE BY USING THE +C MORE GENERAL NONLINEAR EQUATION SOLVER HYBRJ. THE USER +C MUST PROVIDE A SUBROUTINE WHICH CALCULATES THE FUNCTIONS +C AND THE JACOBIAN. +C +C THE SUBROUTINE STATEMENT IS +C +C SUBROUTINE HYBRJ1(FCN,N,X,FVEC,FJAC,LDFJAC,TOL,INFO,WA,LWA) +C +C WHERE +C +C FCN IS THE NAME OF THE USER-SUPPLIED SUBROUTINE WHICH +C CALCULATES THE FUNCTIONS AND THE JACOBIAN. FCN MUST +C BE DECLARED IN AN EXTERNAL STATEMENT IN THE USER +C CALLING PROGRAM, AND SHOULD BE WRITTEN AS FOLLOWS. +C +C SUBROUTINE FCN(N,X,FVEC,FJAC,LDFJAC,IFLAG) +C INTEGER N,LDFJAC,IFLAG +C DOUBLE PRECISION X(N),FVEC(N),FJAC(LDFJAC,N) +C ---------- +C IF IFLAG = 1 CALCULATE THE FUNCTIONS AT X AND +C RETURN THIS VECTOR IN FVEC. DO NOT ALTER FJAC. +C IF IFLAG = 2 CALCULATE THE JACOBIAN AT X AND +C RETURN THIS MATRIX IN FJAC. DO NOT ALTER FVEC. +C --------- +C RETURN +C END +C +C THE VALUE OF IFLAG SHOULD NOT BE CHANGED BY FCN UNLESS +C THE USER WANTS TO TERMINATE EXECUTION OF HYBRJ1. +C IN THIS CASE SET IFLAG TO A NEGATIVE INTEGER. +C +C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER +C OF FUNCTIONS AND VARIABLES. +C +C X IS AN ARRAY OF LENGTH N. ON INPUT X MUST CONTAIN +C AN INITIAL ESTIMATE OF THE SOLUTION VECTOR. ON OUTPUT X +C CONTAINS THE FINAL ESTIMATE OF THE SOLUTION VECTOR. +C +C FVEC IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS +C THE FUNCTIONS EVALUATED AT THE OUTPUT X. +C +C FJAC IS AN OUTPUT N BY N ARRAY WHICH CONTAINS THE +C ORTHOGONAL MATRIX Q PRODUCED BY THE QR FACTORIZATION +C OF THE FINAL APPROXIMATE JACOBIAN. +C +C LDFJAC IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN N +C WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY FJAC. +C +C TOL IS A NONNEGATIVE INPUT VARIABLE. TERMINATION OCCURS +C WHEN THE ALGORITHM ESTIMATES THAT THE RELATIVE ERROR +C BETWEEN X AND THE SOLUTION IS AT MOST TOL. +C +C INFO IS AN INTEGER OUTPUT VARIABLE. IF THE USER HAS +C TERMINATED EXECUTION, INFO IS SET TO THE (NEGATIVE) +C VALUE OF IFLAG. SEE DESCRIPTION OF FCN. OTHERWISE, +C INFO IS SET AS FOLLOWS. +C +C INFO = 0 IMPROPER INPUT PARAMETERS. +C +C INFO = 1 ALGORITHM ESTIMATES THAT THE RELATIVE ERROR +C BETWEEN X AND THE SOLUTION IS AT MOST TOL. +C +C INFO = 2 NUMBER OF CALLS TO FCN WITH IFLAG = 1 HAS +C REACHED 100*(N+1). +C +C INFO = 3 TOL IS TOO SMALL. NO FURTHER IMPROVEMENT IN +C THE APPROXIMATE SOLUTION X IS POSSIBLE. +C +C INFO = 4 ITERATION IS NOT MAKING GOOD PROGRESS. +C +C WA IS A WORK ARRAY OF LENGTH LWA. +C +C LWA IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN +C (N*(N+13))/2. +C +C SUBPROGRAMS CALLED +C +C USER-SUPPLIED ...... FCN +C +C MINPACK-SUPPLIED ... HYBRJ +C +C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. +C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE +C +C ********** + INTEGER J,LR,MAXFEV,MODE,NFEV,NJEV,NPRINT + DOUBLE PRECISION FACTOR,ONE,XTOL,ZERO + DATA FACTOR,ONE,ZERO /1.0D2,1.0D0,0.0D0/ + INFO = 0 +C +C CHECK THE INPUT PARAMETERS FOR ERRORS. +C + IF (N .LE. 0 .OR. LDFJAC .LT. N .OR. TOL .LT. ZERO + * .OR. LWA .LT. (N*(N + 13))/2) GO TO 20 +C +C CALL HYBRJ. +C + MAXFEV = 100*(N + 1) + XTOL = TOL + MODE = 2 + DO 10 J = 1, N + WA(J) = ONE + 10 CONTINUE + NPRINT = 0 + LR = (N*(N + 1))/2 + CALL HYBRJ(FCN,N,X,FVEC,FJAC,LDFJAC,XTOL,MAXFEV,WA(1),MODE, + * FACTOR,NPRINT,INFO,NFEV,NJEV,WA(6*N+1),LR,WA(N+1), + * WA(2*N+1),WA(3*N+1),WA(4*N+1),WA(5*N+1)) + IF (INFO .EQ. 5) INFO = 4 + 20 CONTINUE + RETURN +C +C LAST CARD OF SUBROUTINE HYBRJ1. +C + END + SUBROUTINE LMDER(FCN,M,N,X,FVEC,FJAC,LDFJAC,FTOL,XTOL,GTOL, + * MAXFEV,DIAG,MODE,FACTOR,NPRINT,INFO,NFEV,NJEV, + * IPVT,QTF,WA1,WA2,WA3,WA4) + INTEGER M,N,LDFJAC,MAXFEV,MODE,NPRINT,INFO,NFEV,NJEV + INTEGER IPVT(N) + DOUBLE PRECISION FTOL,XTOL,GTOL,FACTOR + DOUBLE PRECISION X(N),FVEC(M),FJAC(LDFJAC,N),DIAG(N),QTF(N), + * WA1(N),WA2(N),WA3(N),WA4(M) +C ********** +C +C SUBROUTINE LMDER +C +C THE PURPOSE OF LMDER IS TO MINIMIZE THE SUM OF THE SQUARES OF +C M NONLINEAR FUNCTIONS IN N VARIABLES BY A MODIFICATION OF +C THE LEVENBERG-MARQUARDT ALGORITHM. THE USER MUST PROVIDE A +C SUBROUTINE WHICH CALCULATES THE FUNCTIONS AND THE JACOBIAN. +C +C THE SUBROUTINE STATEMENT IS +C +C SUBROUTINE LMDER(FCN,M,N,X,FVEC,FJAC,LDFJAC,FTOL,XTOL,GTOL, +C MAXFEV,DIAG,MODE,FACTOR,NPRINT,INFO,NFEV, +C NJEV,IPVT,QTF,WA1,WA2,WA3,WA4) +C +C WHERE +C +C FCN IS THE NAME OF THE USER-SUPPLIED SUBROUTINE WHICH +C CALCULATES THE FUNCTIONS AND THE JACOBIAN. FCN MUST +C BE DECLARED IN AN EXTERNAL STATEMENT IN THE USER +C CALLING PROGRAM, AND SHOULD BE WRITTEN AS FOLLOWS. +C +C SUBROUTINE FCN(M,N,X,FVEC,FJAC,LDFJAC,IFLAG) +C INTEGER M,N,LDFJAC,IFLAG +C DOUBLE PRECISION X(N),FVEC(M),FJAC(LDFJAC,N) +C ---------- +C IF IFLAG = 1 CALCULATE THE FUNCTIONS AT X AND +C RETURN THIS VECTOR IN FVEC. DO NOT ALTER FJAC. +C IF IFLAG = 2 CALCULATE THE JACOBIAN AT X AND +C RETURN THIS MATRIX IN FJAC. DO NOT ALTER FVEC. +C ---------- +C RETURN +C END +C +C THE VALUE OF IFLAG SHOULD NOT BE CHANGED BY FCN UNLESS +C THE USER WANTS TO TERMINATE EXECUTION OF LMDER. +C IN THIS CASE SET IFLAG TO A NEGATIVE INTEGER. +C +C M IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER +C OF FUNCTIONS. +C +C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER +C OF VARIABLES. N MUST NOT EXCEED M. +C +C X IS AN ARRAY OF LENGTH N. ON INPUT X MUST CONTAIN +C AN INITIAL ESTIMATE OF THE SOLUTION VECTOR. ON OUTPUT X +C CONTAINS THE FINAL ESTIMATE OF THE SOLUTION VECTOR. +C +C FVEC IS AN OUTPUT ARRAY OF LENGTH M WHICH CONTAINS +C THE FUNCTIONS EVALUATED AT THE OUTPUT X. +C +C FJAC IS AN OUTPUT M BY N ARRAY. THE UPPER N BY N SUBMATRIX +C OF FJAC CONTAINS AN UPPER TRIANGULAR MATRIX R WITH +C DIAGONAL ELEMENTS OF NONINCREASING MAGNITUDE SUCH THAT +C +C T T T +C P *(JAC *JAC)*P = R *R, +C +C WHERE P IS A PERMUTATION MATRIX AND JAC IS THE FINAL +C CALCULATED JACOBIAN. COLUMN J OF P IS COLUMN IPVT(J) +C (SEE BELOW) OF THE IDENTITY MATRIX. THE LOWER TRAPEZOIDAL +C PART OF FJAC CONTAINS INFORMATION GENERATED DURING +C THE COMPUTATION OF R. +C +C LDFJAC IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN M +C WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY FJAC. +C +C FTOL IS A NONNEGATIVE INPUT VARIABLE. TERMINATION +C OCCURS WHEN BOTH THE ACTUAL AND PREDICTED RELATIVE +C REDUCTIONS IN THE SUM OF SQUARES ARE AT MOST FTOL. +C THEREFORE, FTOL MEASURES THE RELATIVE ERROR DESIRED +C IN THE SUM OF SQUARES. +C +C XTOL IS A NONNEGATIVE INPUT VARIABLE. TERMINATION +C OCCURS WHEN THE RELATIVE ERROR BETWEEN TWO CONSECUTIVE +C ITERATES IS AT MOST XTOL. THEREFORE, XTOL MEASURES THE +C RELATIVE ERROR DESIRED IN THE APPROXIMATE SOLUTION. +C +C GTOL IS A NONNEGATIVE INPUT VARIABLE. TERMINATION +C OCCURS WHEN THE COSINE OF THE ANGLE BETWEEN FVEC AND +C ANY COLUMN OF THE JACOBIAN IS AT MOST GTOL IN ABSOLUTE +C VALUE. THEREFORE, GTOL MEASURES THE ORTHOGONALITY +C DESIRED BETWEEN THE FUNCTION VECTOR AND THE COLUMNS +C OF THE JACOBIAN. +C +C MAXFEV IS A POSITIVE INTEGER INPUT VARIABLE. TERMINATION +C OCCURS WHEN THE NUMBER OF CALLS TO FCN WITH IFLAG = 1 +C HAS REACHED MAXFEV. +C +C DIAG IS AN ARRAY OF LENGTH N. IF MODE = 1 (SEE +C BELOW), DIAG IS INTERNALLY SET. IF MODE = 2, DIAG +C MUST CONTAIN POSITIVE ENTRIES THAT SERVE AS +C MULTIPLICATIVE SCALE FACTORS FOR THE VARIABLES. +C +C MODE IS AN INTEGER INPUT VARIABLE. IF MODE = 1, THE +C VARIABLES WILL BE SCALED INTERNALLY. IF MODE = 2, +C THE SCALING IS SPECIFIED BY THE INPUT DIAG. OTHER +C VALUES OF MODE ARE EQUIVALENT TO MODE = 1. +C +C FACTOR IS A POSITIVE INPUT VARIABLE USED IN DETERMINING THE +C INITIAL STEP BOUND. THIS BOUND IS SET TO THE PRODUCT OF +C FACTOR AND THE EUCLIDEAN NORM OF DIAG*X IF NONZERO, OR ELSE +C TO FACTOR ITSELF. IN MOST CASES FACTOR SHOULD LIE IN THE +C INTERVAL (.1,100.).100. IS A GENERALLY RECOMMENDED VALUE. +C +C NPRINT IS AN INTEGER INPUT VARIABLE THAT ENABLES CONTROLLED +C PRINTING OF ITERATES IF IT IS POSITIVE. IN THIS CASE, +C FCN IS CALLED WITH IFLAG = 0 AT THE BEGINNING OF THE FIRST +C ITERATION AND EVERY NPRINT ITERATIONS THEREAFTER AND +C IMMEDIATELY PRIOR TO RETURN, WITH X, FVEC, AND FJAC +C AVAILABLE FOR PRINTING. FVEC AND FJAC SHOULD NOT BE +C ALTERED. IF NPRINT IS NOT POSITIVE, NO SPECIAL CALLS +C OF FCN WITH IFLAG = 0 ARE MADE. +C +C INFO IS AN INTEGER OUTPUT VARIABLE. IF THE USER HAS +C TERMINATED EXECUTION, INFO IS SET TO THE (NEGATIVE) +C VALUE OF IFLAG. SEE DESCRIPTION OF FCN. OTHERWISE, +C INFO IS SET AS FOLLOWS. +C +C INFO = 0 IMPROPER INPUT PARAMETERS. +C +C INFO = 1 BOTH ACTUAL AND PREDICTED RELATIVE REDUCTIONS +C IN THE SUM OF SQUARES ARE AT MOST FTOL. +C +C INFO = 2 RELATIVE ERROR BETWEEN TWO CONSECUTIVE ITERATES +C IS AT MOST XTOL. +C +C INFO = 3 CONDITIONS FOR INFO = 1 AND INFO = 2 BOTH HOLD. +C +C INFO = 4 THE COSINE OF THE ANGLE BETWEEN FVEC AND ANY +C COLUMN OF THE JACOBIAN IS AT MOST GTOL IN +C ABSOLUTE VALUE. +C +C INFO = 5 NUMBER OF CALLS TO FCN WITH IFLAG = 1 HAS +C REACHED MAXFEV. +C +C INFO = 6 FTOL IS TOO SMALL. NO FURTHER REDUCTION IN +C THE SUM OF SQUARES IS POSSIBLE. +C +C INFO = 7 XTOL IS TOO SMALL. NO FURTHER IMPROVEMENT IN +C THE APPROXIMATE SOLUTION X IS POSSIBLE. +C +C INFO = 8 GTOL IS TOO SMALL. FVEC IS ORTHOGONAL TO THE +C COLUMNS OF THE JACOBIAN TO MACHINE PRECISION. +C +C NFEV IS AN INTEGER OUTPUT VARIABLE SET TO THE NUMBER OF +C CALLS TO FCN WITH IFLAG = 1. +C +C NJEV IS AN INTEGER OUTPUT VARIABLE SET TO THE NUMBER OF +C CALLS TO FCN WITH IFLAG = 2. +C +C IPVT IS AN INTEGER OUTPUT ARRAY OF LENGTH N. IPVT +C DEFINES A PERMUTATION MATRIX P SUCH THAT JAC*P = Q*R, +C WHERE JAC IS THE FINAL CALCULATED JACOBIAN, Q IS +C ORTHOGONAL (NOT STORED), AND R IS UPPER TRIANGULAR +C WITH DIAGONAL ELEMENTS OF NONINCREASING MAGNITUDE. +C COLUMN J OF P IS COLUMN IPVT(J) OF THE IDENTITY MATRIX. +C +C QTF IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS +C THE FIRST N ELEMENTS OF THE VECTOR (Q TRANSPOSE)*FVEC. +C +C WA1, WA2, AND WA3 ARE WORK ARRAYS OF LENGTH N. +C +C WA4 IS A WORK ARRAY OF LENGTH M. +C +C SUBPROGRAMS CALLED +C +C USER-SUPPLIED ...... FCN +C +C MINPACK-SUPPLIED ... DPMPAR,ENORM,LMPAR,QRFAC +C +C FORTRAN-SUPPLIED ... DABS,DMAX1,DMIN1,DSQRT,MOD +C +C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. +C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE +C +C ********** + INTEGER I,IFLAG,ITER,J,L + DOUBLE PRECISION ACTRED,DELTA,DIRDER,EPSMCH,FNORM,FNORM1,GNORM, + * ONE,PAR,PNORM,PRERED,P1,P5,P25,P75,P0001,RATIO, + * SUM,TEMP,TEMP1,TEMP2,XNORM,ZERO + DOUBLE PRECISION DPMPAR,ENORM + DATA ONE,P1,P5,P25,P75,P0001,ZERO + * /1.0D0,1.0D-1,5.0D-1,2.5D-1,7.5D-1,1.0D-4,0.0D0/ +C +C EPSMCH IS THE MACHINE PRECISION. +C + EPSMCH = DPMPAR(1) +C + INFO = 0 + IFLAG = 0 + NFEV = 0 + NJEV = 0 +C +C CHECK THE INPUT PARAMETERS FOR ERRORS. +C + IF (N .LE. 0 .OR. M .LT. N .OR. LDFJAC .LT. M + * .OR. FTOL .LT. ZERO .OR. XTOL .LT. ZERO .OR. GTOL .LT. ZERO + * .OR. MAXFEV .LE. 0 .OR. FACTOR .LE. ZERO) GO TO 300 + IF (MODE .NE. 2) GO TO 20 + DO 10 J = 1, N + IF (DIAG(J) .LE. ZERO) GO TO 300 + 10 CONTINUE + 20 CONTINUE +C +C EVALUATE THE FUNCTION AT THE STARTING POINT +C AND CALCULATE ITS NORM. +C + IFLAG = 1 + CALL FCN(M,N,X,FVEC,FJAC,LDFJAC,IFLAG) + NFEV = 1 + IF (IFLAG .LT. 0) GO TO 300 + FNORM = ENORM(M,FVEC) +C +C INITIALIZE LEVENBERG-MARQUARDT PARAMETER AND ITERATION COUNTER. +C + PAR = ZERO + ITER = 1 +C +C BEGINNING OF THE OUTER LOOP. +C + 30 CONTINUE +C +C CALCULATE THE JACOBIAN MATRIX. +C + IFLAG = 2 + CALL FCN(M,N,X,FVEC,FJAC,LDFJAC,IFLAG) + NJEV = NJEV + 1 + IF (IFLAG .LT. 0) GO TO 300 +C +C IF REQUESTED, CALL FCN TO ENABLE PRINTING OF ITERATES. +C + IF (NPRINT .LE. 0) GO TO 40 + IFLAG = 0 + IF (MOD(ITER-1,NPRINT) .EQ. 0) + * CALL FCN(M,N,X,FVEC,FJAC,LDFJAC,IFLAG) + IF (IFLAG .LT. 0) GO TO 300 + 40 CONTINUE +C +C COMPUTE THE QR FACTORIZATION OF THE JACOBIAN. +C + CALL QRFAC(M,N,FJAC,LDFJAC,.TRUE.,IPVT,N,WA1,WA2,WA3) +C +C ON THE FIRST ITERATION AND IF MODE IS 1, SCALE ACCORDING +C TO THE NORMS OF THE COLUMNS OF THE INITIAL JACOBIAN. +C + IF (ITER .NE. 1) GO TO 80 + IF (MODE .EQ. 2) GO TO 60 + DO 50 J = 1, N + DIAG(J) = WA2(J) + IF (WA2(J) .EQ. ZERO) DIAG(J) = ONE + 50 CONTINUE + 60 CONTINUE +C +C ON THE FIRST ITERATION, CALCULATE THE NORM OF THE SCALED X +C AND INITIALIZE THE STEP BOUND DELTA. +C + DO 70 J = 1, N + WA3(J) = DIAG(J)*X(J) + 70 CONTINUE + XNORM = ENORM(N,WA3) + DELTA = FACTOR*XNORM + IF (DELTA .EQ. ZERO) DELTA = FACTOR + 80 CONTINUE +C +C FORM (Q TRANSPOSE)*FVEC AND STORE THE FIRST N COMPONENTS IN +C QTF. +C + DO 90 I = 1, M + WA4(I) = FVEC(I) + 90 CONTINUE + DO 130 J = 1, N + IF (FJAC(J,J) .EQ. ZERO) GO TO 120 + SUM = ZERO + DO 100 I = J, M + SUM = SUM + FJAC(I,J)*WA4(I) + 100 CONTINUE + TEMP = -SUM/FJAC(J,J) + DO 110 I = J, M + WA4(I) = WA4(I) + FJAC(I,J)*TEMP + 110 CONTINUE + 120 CONTINUE + FJAC(J,J) = WA1(J) + QTF(J) = WA4(J) + 130 CONTINUE +C +C COMPUTE THE NORM OF THE SCALED GRADIENT. +C + GNORM = ZERO + IF (FNORM .EQ. ZERO) GO TO 170 + DO 160 J = 1, N + L = IPVT(J) + IF (WA2(L) .EQ. ZERO) GO TO 150 + SUM = ZERO + DO 140 I = 1, J + SUM = SUM + FJAC(I,J)*(QTF(I)/FNORM) + 140 CONTINUE + GNORM = DMAX1(GNORM,DABS(SUM/WA2(L))) + 150 CONTINUE + 160 CONTINUE + 170 CONTINUE +C +C TEST FOR CONVERGENCE OF THE GRADIENT NORM. +C + IF (GNORM .LE. GTOL) INFO = 4 + IF (INFO .NE. 0) GO TO 300 +C +C RESCALE IF NECESSARY. +C + IF (MODE .EQ. 2) GO TO 190 + DO 180 J = 1, N + DIAG(J) = DMAX1(DIAG(J),WA2(J)) + 180 CONTINUE + 190 CONTINUE +C +C BEGINNING OF THE INNER LOOP. +C + 200 CONTINUE +C +C DETERMINE THE LEVENBERG-MARQUARDT PARAMETER. +C + CALL LMPAR(N,FJAC,LDFJAC,IPVT,DIAG,QTF,DELTA,PAR,WA1,WA2, + * WA3,WA4) +C +C STORE THE DIRECTION P AND X + P. CALCULATE THE NORM OF P. +C + DO 210 J = 1, N + WA1(J) = -WA1(J) + WA2(J) = X(J) + WA1(J) + WA3(J) = DIAG(J)*WA1(J) + 210 CONTINUE + PNORM = ENORM(N,WA3) +C +C ON THE FIRST ITERATION, ADJUST THE INITIAL STEP BOUND. +C + IF (ITER .EQ. 1) DELTA = DMIN1(DELTA,PNORM) +C +C EVALUATE THE FUNCTION AT X + P AND CALCULATE ITS NORM. +C + IFLAG = 1 + CALL FCN(M,N,WA2,WA4,FJAC,LDFJAC,IFLAG) + NFEV = NFEV + 1 + IF (IFLAG .LT. 0) GO TO 300 + FNORM1 = ENORM(M,WA4) +C +C COMPUTE THE SCALED ACTUAL REDUCTION. +C + ACTRED = -ONE + IF (P1*FNORM1 .LT. FNORM) ACTRED = ONE - (FNORM1/FNORM)**2 +C +C COMPUTE THE SCALED PREDICTED REDUCTION AND +C THE SCALED DIRECTIONAL DERIVATIVE. +C + DO 230 J = 1, N + WA3(J) = ZERO + L = IPVT(J) + TEMP = WA1(L) + DO 220 I = 1, J + WA3(I) = WA3(I) + FJAC(I,J)*TEMP + 220 CONTINUE + 230 CONTINUE + TEMP1 = ENORM(N,WA3)/FNORM + TEMP2 = (DSQRT(PAR)*PNORM)/FNORM + PRERED = TEMP1**2 + TEMP2**2/P5 + DIRDER = -(TEMP1**2 + TEMP2**2) +C +C COMPUTE THE RATIO OF THE ACTUAL TO THE PREDICTED +C REDUCTION. +C + RATIO = ZERO + IF (PRERED .NE. ZERO) RATIO = ACTRED/PRERED +C +C UPDATE THE STEP BOUND. +C + IF (RATIO .GT. P25) GO TO 240 + IF (ACTRED .GE. ZERO) TEMP = P5 + IF (ACTRED .LT. ZERO) + * TEMP = P5*DIRDER/(DIRDER + P5*ACTRED) + IF (P1*FNORM1 .GE. FNORM .OR. TEMP .LT. P1) TEMP = P1 + DELTA = TEMP*DMIN1(DELTA,PNORM/P1) + PAR = PAR/TEMP + GO TO 260 + 240 CONTINUE + IF (PAR .NE. ZERO .AND. RATIO .LT. P75) GO TO 250 + DELTA = PNORM/P5 + PAR = P5*PAR + 250 CONTINUE + 260 CONTINUE +C +C TEST FOR SUCCESSFUL ITERATION. +C + IF (RATIO .LT. P0001) GO TO 290 +C +C SUCCESSFUL ITERATION. UPDATE X, FVEC, AND THEIR NORMS. +C + DO 270 J = 1, N + X(J) = WA2(J) + WA2(J) = DIAG(J)*X(J) + 270 CONTINUE + DO 280 I = 1, M + FVEC(I) = WA4(I) + 280 CONTINUE + XNORM = ENORM(N,WA2) + FNORM = FNORM1 + ITER = ITER + 1 + 290 CONTINUE +C +C TESTS FOR CONVERGENCE. +C + IF (DABS(ACTRED) .LE. FTOL .AND. PRERED .LE. FTOL + * .AND. P5*RATIO .LE. ONE) INFO = 1 + IF (DELTA .LE. XTOL*XNORM) INFO = 2 + IF (DABS(ACTRED) .LE. FTOL .AND. PRERED .LE. FTOL + * .AND. P5*RATIO .LE. ONE .AND. INFO .EQ. 2) INFO = 3 + IF (INFO .NE. 0) GO TO 300 +C +C TESTS FOR TERMINATION AND STRINGENT TOLERANCES. +C + IF (NFEV .GE. MAXFEV) INFO = 5 + IF (DABS(ACTRED) .LE. EPSMCH .AND. PRERED .LE. EPSMCH + * .AND. P5*RATIO .LE. ONE) INFO = 6 + IF (DELTA .LE. EPSMCH*XNORM) INFO = 7 + IF (GNORM .LE. EPSMCH) INFO = 8 + IF (INFO .NE. 0) GO TO 300 +C +C END OF THE INNER LOOP. REPEAT IF ITERATION UNSUCCESSFUL. +C + IF (RATIO .LT. P0001) GO TO 200 +C +C END OF THE OUTER LOOP. +C + GO TO 30 + 300 CONTINUE +C +C TERMINATION, EITHER NORMAL OR USER IMPOSED. +C + IF (IFLAG .LT. 0) INFO = IFLAG + IFLAG = 0 + IF (NPRINT .GT. 0) CALL FCN(M,N,X,FVEC,FJAC,LDFJAC,IFLAG) + RETURN +C +C LAST CARD OF SUBROUTINE LMDER. +C + END + SUBROUTINE LMDER1(FCN,M,N,X,FVEC,FJAC,LDFJAC,TOL,INFO,IPVT,WA, + * LWA) + INTEGER M,N,LDFJAC,INFO,LWA + INTEGER IPVT(N) + DOUBLE PRECISION TOL + DOUBLE PRECISION X(N),FVEC(M),FJAC(LDFJAC,N),WA(LWA) + EXTERNAL FCN +C ********** +C +C SUBROUTINE LMDER1 +C +C THE PURPOSE OF LMDER1 IS TO MINIMIZE THE SUM OF THE SQUARES OF +C M NONLINEAR FUNCTIONS IN N VARIABLES BY A MODIFICATION OF THE +C LEVENBERG-MARQUARDT ALGORITHM. THIS IS DONE BY USING THE MORE +C GENERAL LEAST-SQUARES SOLVER LMDER. THE USER MUST PROVIDE A +C SUBROUTINE WHICH CALCULATES THE FUNCTIONS AND THE JACOBIAN. +C +C THE SUBROUTINE STATEMENT IS +C +C SUBROUTINE LMDER1(FCN,M,N,X,FVEC,FJAC,LDFJAC,TOL,INFO, +C IPVT,WA,LWA) +C +C WHERE +C +C FCN IS THE NAME OF THE USER-SUPPLIED SUBROUTINE WHICH +C CALCULATES THE FUNCTIONS AND THE JACOBIAN. FCN MUST +C BE DECLARED IN AN EXTERNAL STATEMENT IN THE USER +C CALLING PROGRAM, AND SHOULD BE WRITTEN AS FOLLOWS. +C +C SUBROUTINE FCN(M,N,X,FVEC,FJAC,LDFJAC,IFLAG) +C INTEGER M,N,LDFJAC,IFLAG +C DOUBLE PRECISION X(N),FVEC(M),FJAC(LDFJAC,N) +C ---------- +C IF IFLAG = 1 CALCULATE THE FUNCTIONS AT X AND +C RETURN THIS VECTOR IN FVEC. DO NOT ALTER FJAC. +C IF IFLAG = 2 CALCULATE THE JACOBIAN AT X AND +C RETURN THIS MATRIX IN FJAC. DO NOT ALTER FVEC. +C ---------- +C RETURN +C END +C +C THE VALUE OF IFLAG SHOULD NOT BE CHANGED BY FCN UNLESS +C THE USER WANTS TO TERMINATE EXECUTION OF LMDER1. +C IN THIS CASE SET IFLAG TO A NEGATIVE INTEGER. +C +C M IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER +C OF FUNCTIONS. +C +C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER +C OF VARIABLES. N MUST NOT EXCEED M. +C +C X IS AN ARRAY OF LENGTH N. ON INPUT X MUST CONTAIN +C AN INITIAL ESTIMATE OF THE SOLUTION VECTOR. ON OUTPUT X +C CONTAINS THE FINAL ESTIMATE OF THE SOLUTION VECTOR. +C +C FVEC IS AN OUTPUT ARRAY OF LENGTH M WHICH CONTAINS +C THE FUNCTIONS EVALUATED AT THE OUTPUT X. +C +C FJAC IS AN OUTPUT M BY N ARRAY. THE UPPER N BY N SUBMATRIX +C OF FJAC CONTAINS AN UPPER TRIANGULAR MATRIX R WITH +C DIAGONAL ELEMENTS OF NONINCREASING MAGNITUDE SUCH THAT +C +C T T T +C P *(JAC *JAC)*P = R *R, +C +C WHERE P IS A PERMUTATION MATRIX AND JAC IS THE FINAL +C CALCULATED JACOBIAN. COLUMN J OF P IS COLUMN IPVT(J) +C (SEE BELOW) OF THE IDENTITY MATRIX. THE LOWER TRAPEZOIDAL +C PART OF FJAC CONTAINS INFORMATION GENERATED DURING +C THE COMPUTATION OF R. +C +C LDFJAC IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN M +C WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY FJAC. +C +C TOL IS A NONNEGATIVE INPUT VARIABLE. TERMINATION OCCURS +C WHEN THE ALGORITHM ESTIMATES EITHER THAT THE RELATIVE +C ERROR IN THE SUM OF SQUARES IS AT MOST TOL OR THAT +C THE RELATIVE ERROR BETWEEN X AND THE SOLUTION IS AT +C MOST TOL. +C +C INFO IS AN INTEGER OUTPUT VARIABLE. IF THE USER HAS +C TERMINATED EXECUTION, INFO IS SET TO THE (NEGATIVE) +C VALUE OF IFLAG. SEE DESCRIPTION OF FCN. OTHERWISE, +C INFO IS SET AS FOLLOWS. +C +C INFO = 0 IMPROPER INPUT PARAMETERS. +C +C INFO = 1 ALGORITHM ESTIMATES THAT THE RELATIVE ERROR +C IN THE SUM OF SQUARES IS AT MOST TOL. +C +C INFO = 2 ALGORITHM ESTIMATES THAT THE RELATIVE ERROR +C BETWEEN X AND THE SOLUTION IS AT MOST TOL. +C +C INFO = 3 CONDITIONS FOR INFO = 1 AND INFO = 2 BOTH HOLD. +C +C INFO = 4 FVEC IS ORTHOGONAL TO THE COLUMNS OF THE +C JACOBIAN TO MACHINE PRECISION. +C +C INFO = 5 NUMBER OF CALLS TO FCN WITH IFLAG = 1 HAS +C REACHED 100*(N+1). +C +C INFO = 6 TOL IS TOO SMALL. NO FURTHER REDUCTION IN +C THE SUM OF SQUARES IS POSSIBLE. +C +C INFO = 7 TOL IS TOO SMALL. NO FURTHER IMPROVEMENT IN +C THE APPROXIMATE SOLUTION X IS POSSIBLE. +C +C IPVT IS AN INTEGER OUTPUT ARRAY OF LENGTH N. IPVT +C DEFINES A PERMUTATION MATRIX P SUCH THAT JAC*P = Q*R, +C WHERE JAC IS THE FINAL CALCULATED JACOBIAN, Q IS +C ORTHOGONAL (NOT STORED), AND R IS UPPER TRIANGULAR +C WITH DIAGONAL ELEMENTS OF NONINCREASING MAGNITUDE. +C COLUMN J OF P IS COLUMN IPVT(J) OF THE IDENTITY MATRIX. +C +C WA IS A WORK ARRAY OF LENGTH LWA. +C +C LWA IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN 5*N+M. +C +C SUBPROGRAMS CALLED +C +C USER-SUPPLIED ...... FCN +C +C MINPACK-SUPPLIED ... LMDER +C +C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. +C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE +C +C ********** + INTEGER MAXFEV,MODE,NFEV,NJEV,NPRINT + DOUBLE PRECISION FACTOR,FTOL,GTOL,XTOL,ZERO + DATA FACTOR,ZERO /1.0D2,0.0D0/ + INFO = 0 +C +C CHECK THE INPUT PARAMETERS FOR ERRORS. +C + IF (N .LE. 0 .OR. M .LT. N .OR. LDFJAC .LT. M .OR. TOL .LT. ZERO + * .OR. LWA .LT. 5*N + M) GO TO 10 +C +C CALL LMDER. +C + MAXFEV = 100*(N + 1) + FTOL = TOL + XTOL = TOL + GTOL = ZERO + MODE = 1 + NPRINT = 0 + CALL LMDER(FCN,M,N,X,FVEC,FJAC,LDFJAC,FTOL,XTOL,GTOL,MAXFEV, + * WA(1),MODE,FACTOR,NPRINT,INFO,NFEV,NJEV,IPVT,WA(N+1), + * WA(2*N+1),WA(3*N+1),WA(4*N+1),WA(5*N+1)) + IF (INFO .EQ. 8) INFO = 4 + 10 CONTINUE + RETURN +C +C LAST CARD OF SUBROUTINE LMDER1. +C + END + SUBROUTINE LMDIF(FCN,M,N,X,FVEC,FTOL,XTOL,GTOL,MAXFEV,EPSFCN, + * DIAG,MODE,FACTOR,NPRINT,INFO,NFEV,FJAC,LDFJAC, + * IPVT,QTF,WA1,WA2,WA3,WA4) + INTEGER M,N,MAXFEV,MODE,NPRINT,INFO,NFEV,LDFJAC + INTEGER IPVT(N) + DOUBLE PRECISION FTOL,XTOL,GTOL,EPSFCN,FACTOR + DOUBLE PRECISION X(N),FVEC(M),DIAG(N),FJAC(LDFJAC,N),QTF(N), + * WA1(N),WA2(N),WA3(N),WA4(M) + EXTERNAL FCN +C ********** +C +C SUBROUTINE LMDIF +C +C THE PURPOSE OF LMDIF IS TO MINIMIZE THE SUM OF THE SQUARES OF +C M NONLINEAR FUNCTIONS IN N VARIABLES BY A MODIFICATION OF +C THE LEVENBERG-MARQUARDT ALGORITHM. THE USER MUST PROVIDE A +C SUBROUTINE WHICH CALCULATES THE FUNCTIONS. THE JACOBIAN IS +C THEN CALCULATED BY A FORWARD-DIFFERENCE APPROXIMATION. +C +C THE SUBROUTINE STATEMENT IS +C +C SUBROUTINE LMDIF(FCN,M,N,X,FVEC,FTOL,XTOL,GTOL,MAXFEV,EPSFCN, +C DIAG,MODE,FACTOR,NPRINT,INFO,NFEV,FJAC, +C LDFJAC,IPVT,QTF,WA1,WA2,WA3,WA4) +C +C WHERE +C +C FCN IS THE NAME OF THE USER-SUPPLIED SUBROUTINE WHICH +C CALCULATES THE FUNCTIONS. FCN MUST BE DECLARED +C IN AN EXTERNAL STATEMENT IN THE USER CALLING +C PROGRAM, AND SHOULD BE WRITTEN AS FOLLOWS. +C +C SUBROUTINE FCN(M,N,X,FVEC,IFLAG) +C INTEGER M,N,IFLAG +C DOUBLE PRECISION X(N),FVEC(M) +C ---------- +C CALCULATE THE FUNCTIONS AT X AND +C RETURN THIS VECTOR IN FVEC. +C ---------- +C RETURN +C END +C +C THE VALUE OF IFLAG SHOULD NOT BE CHANGED BY FCN UNLESS +C THE USER WANTS TO TERMINATE EXECUTION OF LMDIF. +C IN THIS CASE SET IFLAG TO A NEGATIVE INTEGER. +C +C M IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER +C OF FUNCTIONS. +C +C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER +C OF VARIABLES. N MUST NOT EXCEED M. +C +C X IS AN ARRAY OF LENGTH N. ON INPUT X MUST CONTAIN +C AN INITIAL ESTIMATE OF THE SOLUTION VECTOR. ON OUTPUT X +C CONTAINS THE FINAL ESTIMATE OF THE SOLUTION VECTOR. +C +C FVEC IS AN OUTPUT ARRAY OF LENGTH M WHICH CONTAINS +C THE FUNCTIONS EVALUATED AT THE OUTPUT X. +C +C FTOL IS A NONNEGATIVE INPUT VARIABLE. TERMINATION +C OCCURS WHEN BOTH THE ACTUAL AND PREDICTED RELATIVE +C REDUCTIONS IN THE SUM OF SQUARES ARE AT MOST FTOL. +C THEREFORE, FTOL MEASURES THE RELATIVE ERROR DESIRED +C IN THE SUM OF SQUARES. +C +C XTOL IS A NONNEGATIVE INPUT VARIABLE. TERMINATION +C OCCURS WHEN THE RELATIVE ERROR BETWEEN TWO CONSECUTIVE +C ITERATES IS AT MOST XTOL. THEREFORE, XTOL MEASURES THE +C RELATIVE ERROR DESIRED IN THE APPROXIMATE SOLUTION. +C +C GTOL IS A NONNEGATIVE INPUT VARIABLE. TERMINATION +C OCCURS WHEN THE COSINE OF THE ANGLE BETWEEN FVEC AND +C ANY COLUMN OF THE JACOBIAN IS AT MOST GTOL IN ABSOLUTE +C VALUE. THEREFORE, GTOL MEASURES THE ORTHOGONALITY +C DESIRED BETWEEN THE FUNCTION VECTOR AND THE COLUMNS +C OF THE JACOBIAN. +C +C MAXFEV IS A POSITIVE INTEGER INPUT VARIABLE. TERMINATION +C OCCURS WHEN THE NUMBER OF CALLS TO FCN IS AT LEAST +C MAXFEV BY THE END OF AN ITERATION. +C +C EPSFCN IS AN INPUT VARIABLE USED IN DETERMINING A SUITABLE +C STEP LENGTH FOR THE FORWARD-DIFFERENCE APPROXIMATION. THIS +C APPROXIMATION ASSUMES THAT THE RELATIVE ERRORS IN THE +C FUNCTIONS ARE OF THE ORDER OF EPSFCN. IF EPSFCN IS LESS +C THAN THE MACHINE PRECISION, IT IS ASSUMED THAT THE RELATIVE +C ERRORS IN THE FUNCTIONS ARE OF THE ORDER OF THE MACHINE +C PRECISION. +C +C DIAG IS AN ARRAY OF LENGTH N. IF MODE = 1 (SEE +C BELOW), DIAG IS INTERNALLY SET. IF MODE = 2, DIAG +C MUST CONTAIN POSITIVE ENTRIES THAT SERVE AS +C MULTIPLICATIVE SCALE FACTORS FOR THE VARIABLES. +C +C MODE IS AN INTEGER INPUT VARIABLE. IF MODE = 1, THE +C VARIABLES WILL BE SCALED INTERNALLY. IF MODE = 2, +C THE SCALING IS SPECIFIED BY THE INPUT DIAG. OTHER +C VALUES OF MODE ARE EQUIVALENT TO MODE = 1. +C +C FACTOR IS A POSITIVE INPUT VARIABLE USED IN DETERMINING THE +C INITIAL STEP BOUND. THIS BOUND IS SET TO THE PRODUCT OF +C FACTOR AND THE EUCLIDEAN NORM OF DIAG*X IF NONZERO, OR ELSE +C TO FACTOR ITSELF. IN MOST CASES FACTOR SHOULD LIE IN THE +C INTERVAL (.1,100.). 100. IS A GENERALLY RECOMMENDED VALUE. +C +C NPRINT IS AN INTEGER INPUT VARIABLE THAT ENABLES CONTROLLED +C PRINTING OF ITERATES IF IT IS POSITIVE. IN THIS CASE, +C FCN IS CALLED WITH IFLAG = 0 AT THE BEGINNING OF THE FIRST +C ITERATION AND EVERY NPRINT ITERATIONS THEREAFTER AND +C IMMEDIATELY PRIOR TO RETURN, WITH X AND FVEC AVAILABLE +C FOR PRINTING. IF NPRINT IS NOT POSITIVE, NO SPECIAL CALLS +C OF FCN WITH IFLAG = 0 ARE MADE. +C +C INFO IS AN INTEGER OUTPUT VARIABLE. IF THE USER HAS +C TERMINATED EXECUTION, INFO IS SET TO THE (NEGATIVE) +C VALUE OF IFLAG. SEE DESCRIPTION OF FCN. OTHERWISE, +C INFO IS SET AS FOLLOWS. +C +C INFO = 0 IMPROPER INPUT PARAMETERS. +C +C INFO = 1 BOTH ACTUAL AND PREDICTED RELATIVE REDUCTIONS +C IN THE SUM OF SQUARES ARE AT MOST FTOL. +C +C INFO = 2 RELATIVE ERROR BETWEEN TWO CONSECUTIVE ITERATES +C IS AT MOST XTOL. +C +C INFO = 3 CONDITIONS FOR INFO = 1 AND INFO = 2 BOTH HOLD. +C +C INFO = 4 THE COSINE OF THE ANGLE BETWEEN FVEC AND ANY +C COLUMN OF THE JACOBIAN IS AT MOST GTOL IN +C ABSOLUTE VALUE. +C +C INFO = 5 NUMBER OF CALLS TO FCN HAS REACHED OR +C EXCEEDED MAXFEV. +C +C INFO = 6 FTOL IS TOO SMALL. NO FURTHER REDUCTION IN +C THE SUM OF SQUARES IS POSSIBLE. +C +C INFO = 7 XTOL IS TOO SMALL. NO FURTHER IMPROVEMENT IN +C THE APPROXIMATE SOLUTION X IS POSSIBLE. +C +C INFO = 8 GTOL IS TOO SMALL. FVEC IS ORTHOGONAL TO THE +C COLUMNS OF THE JACOBIAN TO MACHINE PRECISION. +C +C NFEV IS AN INTEGER OUTPUT VARIABLE SET TO THE NUMBER OF +C CALLS TO FCN. +C +C FJAC IS AN OUTPUT M BY N ARRAY. THE UPPER N BY N SUBMATRIX +C OF FJAC CONTAINS AN UPPER TRIANGULAR MATRIX R WITH +C DIAGONAL ELEMENTS OF NONINCREASING MAGNITUDE SUCH THAT +C +C T T T +C P *(JAC *JAC)*P = R *R, +C +C WHERE P IS A PERMUTATION MATRIX AND JAC IS THE FINAL +C CALCULATED JACOBIAN. COLUMN J OF P IS COLUMN IPVT(J) +C (SEE BELOW) OF THE IDENTITY MATRIX. THE LOWER TRAPEZOIDAL +C PART OF FJAC CONTAINS INFORMATION GENERATED DURING +C THE COMPUTATION OF R. +C +C LDFJAC IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN M +C WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY FJAC. +C +C IPVT IS AN INTEGER OUTPUT ARRAY OF LENGTH N. IPVT +C DEFINES A PERMUTATION MATRIX P SUCH THAT JAC*P = Q*R, +C WHERE JAC IS THE FINAL CALCULATED JACOBIAN, Q IS +C ORTHOGONAL (NOT STORED), AND R IS UPPER TRIANGULAR +C WITH DIAGONAL ELEMENTS OF NONINCREASING MAGNITUDE. +C COLUMN J OF P IS COLUMN IPVT(J) OF THE IDENTITY MATRIX. +C +C QTF IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS +C THE FIRST N ELEMENTS OF THE VECTOR (Q TRANSPOSE)*FVEC. +C +C WA1, WA2, AND WA3 ARE WORK ARRAYS OF LENGTH N. +C +C WA4 IS A WORK ARRAY OF LENGTH M. +C +C SUBPROGRAMS CALLED +C +C USER-SUPPLIED ...... FCN +C +C MINPACK-SUPPLIED ... DPMPAR,ENORM,FDJAC2,LMPAR,QRFAC +C +C FORTRAN-SUPPLIED ... DABS,DMAX1,DMIN1,DSQRT,MOD +C +C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. +C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE +C +C ********** + INTEGER I,IFLAG,ITER,J,L + DOUBLE PRECISION ACTRED,DELTA,DIRDER,EPSMCH,FNORM,FNORM1,GNORM, + * ONE,PAR,PNORM,PRERED,P1,P5,P25,P75,P0001,RATIO, + * SUM,TEMP,TEMP1,TEMP2,XNORM,ZERO + DOUBLE PRECISION DPMPAR,ENORM + DATA ONE,P1,P5,P25,P75,P0001,ZERO + * /1.0D0,1.0D-1,5.0D-1,2.5D-1,7.5D-1,1.0D-4,0.0D0/ +C +C EPSMCH IS THE MACHINE PRECISION. +C + EPSMCH = DPMPAR(1) +C + INFO = 0 + IFLAG = 0 + NFEV = 0 +C +C CHECK THE INPUT PARAMETERS FOR ERRORS. +C + IF (N .LE. 0 .OR. M .LT. N .OR. LDFJAC .LT. M + * .OR. FTOL .LT. ZERO .OR. XTOL .LT. ZERO .OR. GTOL .LT. ZERO + * .OR. MAXFEV .LE. 0 .OR. FACTOR .LE. ZERO) GO TO 300 + IF (MODE .NE. 2) GO TO 20 + DO 10 J = 1, N + IF (DIAG(J) .LE. ZERO) GO TO 300 + 10 CONTINUE + 20 CONTINUE +C +C EVALUATE THE FUNCTION AT THE STARTING POINT +C AND CALCULATE ITS NORM. +C + IFLAG = 1 + CALL FCN(M,N,X,FVEC,IFLAG) + NFEV = 1 + IF (IFLAG .LT. 0) GO TO 300 + FNORM = ENORM(M,FVEC) +C +C INITIALIZE LEVENBERG-MARQUARDT PARAMETER AND ITERATION COUNTER. +C + PAR = ZERO + ITER = 1 +C +C BEGINNING OF THE OUTER LOOP. +C + 30 CONTINUE +C +C CALCULATE THE JACOBIAN MATRIX. +C + IFLAG = 2 + CALL FDJAC2(FCN,M,N,X,FVEC,FJAC,LDFJAC,IFLAG,EPSFCN,WA4) + NFEV = NFEV + N + IF (IFLAG .LT. 0) GO TO 300 +C +C IF REQUESTED, CALL FCN TO ENABLE PRINTING OF ITERATES. +C + IF (NPRINT .LE. 0) GO TO 40 + IFLAG = 0 + IF (MOD(ITER-1,NPRINT) .EQ. 0) CALL FCN(M,N,X,FVEC,IFLAG) + IF (IFLAG .LT. 0) GO TO 300 + 40 CONTINUE +C +C COMPUTE THE QR FACTORIZATION OF THE JACOBIAN. +C + CALL QRFAC(M,N,FJAC,LDFJAC,.TRUE.,IPVT,N,WA1,WA2,WA3) +C +C ON THE FIRST ITERATION AND IF MODE IS 1, SCALE ACCORDING +C TO THE NORMS OF THE COLUMNS OF THE INITIAL JACOBIAN. +C + IF (ITER .NE. 1) GO TO 80 + IF (MODE .EQ. 2) GO TO 60 + DO 50 J = 1, N + DIAG(J) = WA2(J) + IF (WA2(J) .EQ. ZERO) DIAG(J) = ONE + 50 CONTINUE + 60 CONTINUE +C +C ON THE FIRST ITERATION, CALCULATE THE NORM OF THE SCALED X +C AND INITIALIZE THE STEP BOUND DELTA. +C + DO 70 J = 1, N + WA3(J) = DIAG(J)*X(J) + 70 CONTINUE + XNORM = ENORM(N,WA3) + DELTA = FACTOR*XNORM + IF (DELTA .EQ. ZERO) DELTA = FACTOR + 80 CONTINUE +C +C FORM (Q TRANSPOSE)*FVEC AND STORE THE FIRST N COMPONENTS IN +C QTF. +C + DO 90 I = 1, M + WA4(I) = FVEC(I) + 90 CONTINUE + DO 130 J = 1, N + IF (FJAC(J,J) .EQ. ZERO) GO TO 120 + SUM = ZERO + DO 100 I = J, M + SUM = SUM + FJAC(I,J)*WA4(I) + 100 CONTINUE + TEMP = -SUM/FJAC(J,J) + DO 110 I = J, M + WA4(I) = WA4(I) + FJAC(I,J)*TEMP + 110 CONTINUE + 120 CONTINUE + FJAC(J,J) = WA1(J) + QTF(J) = WA4(J) + 130 CONTINUE +C +C COMPUTE THE NORM OF THE SCALED GRADIENT. +C + GNORM = ZERO + IF (FNORM .EQ. ZERO) GO TO 170 + DO 160 J = 1, N + L = IPVT(J) + IF (WA2(L) .EQ. ZERO) GO TO 150 + SUM = ZERO + DO 140 I = 1, J + SUM = SUM + FJAC(I,J)*(QTF(I)/FNORM) + 140 CONTINUE + GNORM = DMAX1(GNORM,DABS(SUM/WA2(L))) + 150 CONTINUE + 160 CONTINUE + 170 CONTINUE +C +C TEST FOR CONVERGENCE OF THE GRADIENT NORM. +C + IF (GNORM .LE. GTOL) INFO = 4 + IF (INFO .NE. 0) GO TO 300 +C +C RESCALE IF NECESSARY. +C + IF (MODE .EQ. 2) GO TO 190 + DO 180 J = 1, N + DIAG(J) = DMAX1(DIAG(J),WA2(J)) + 180 CONTINUE + 190 CONTINUE +C +C BEGINNING OF THE INNER LOOP. +C + 200 CONTINUE +C +C DETERMINE THE LEVENBERG-MARQUARDT PARAMETER. +C + CALL LMPAR(N,FJAC,LDFJAC,IPVT,DIAG,QTF,DELTA,PAR,WA1,WA2, + * WA3,WA4) +C +C STORE THE DIRECTION P AND X + P. CALCULATE THE NORM OF P. +C + DO 210 J = 1, N + WA1(J) = -WA1(J) + WA2(J) = X(J) + WA1(J) + WA3(J) = DIAG(J)*WA1(J) + 210 CONTINUE + PNORM = ENORM(N,WA3) +C +C ON THE FIRST ITERATION, ADJUST THE INITIAL STEP BOUND. +C + IF (ITER .EQ. 1) DELTA = DMIN1(DELTA,PNORM) +C +C EVALUATE THE FUNCTION AT X + P AND CALCULATE ITS NORM. +C + IFLAG = 1 + CALL FCN(M,N,WA2,WA4,IFLAG) + NFEV = NFEV + 1 + IF (IFLAG .LT. 0) GO TO 300 + FNORM1 = ENORM(M,WA4) +C +C COMPUTE THE SCALED ACTUAL REDUCTION. +C + ACTRED = -ONE + IF (P1*FNORM1 .LT. FNORM) ACTRED = ONE - (FNORM1/FNORM)**2 +C +C COMPUTE THE SCALED PREDICTED REDUCTION AND +C THE SCALED DIRECTIONAL DERIVATIVE. +C + DO 230 J = 1, N + WA3(J) = ZERO + L = IPVT(J) + TEMP = WA1(L) + DO 220 I = 1, J + WA3(I) = WA3(I) + FJAC(I,J)*TEMP + 220 CONTINUE + 230 CONTINUE + TEMP1 = ENORM(N,WA3)/FNORM + TEMP2 = (DSQRT(PAR)*PNORM)/FNORM + PRERED = TEMP1**2 + TEMP2**2/P5 + DIRDER = -(TEMP1**2 + TEMP2**2) +C +C COMPUTE THE RATIO OF THE ACTUAL TO THE PREDICTED +C REDUCTION. +C + RATIO = ZERO + IF (PRERED .NE. ZERO) RATIO = ACTRED/PRERED +C +C UPDATE THE STEP BOUND. +C + IF (RATIO .GT. P25) GO TO 240 + IF (ACTRED .GE. ZERO) TEMP = P5 + IF (ACTRED .LT. ZERO) + * TEMP = P5*DIRDER/(DIRDER + P5*ACTRED) + IF (P1*FNORM1 .GE. FNORM .OR. TEMP .LT. P1) TEMP = P1 + DELTA = TEMP*DMIN1(DELTA,PNORM/P1) + PAR = PAR/TEMP + GO TO 260 + 240 CONTINUE + IF (PAR .NE. ZERO .AND. RATIO .LT. P75) GO TO 250 + DELTA = PNORM/P5 + PAR = P5*PAR + 250 CONTINUE + 260 CONTINUE +C +C TEST FOR SUCCESSFUL ITERATION. +C + IF (RATIO .LT. P0001) GO TO 290 +C +C SUCCESSFUL ITERATION. UPDATE X, FVEC, AND THEIR NORMS. +C + DO 270 J = 1, N + X(J) = WA2(J) + WA2(J) = DIAG(J)*X(J) + 270 CONTINUE + DO 280 I = 1, M + FVEC(I) = WA4(I) + 280 CONTINUE + XNORM = ENORM(N,WA2) + FNORM = FNORM1 + ITER = ITER + 1 + 290 CONTINUE +C +C TESTS FOR CONVERGENCE. +C + IF (DABS(ACTRED) .LE. FTOL .AND. PRERED .LE. FTOL + * .AND. P5*RATIO .LE. ONE) INFO = 1 + IF (DELTA .LE. XTOL*XNORM) INFO = 2 + IF (DABS(ACTRED) .LE. FTOL .AND. PRERED .LE. FTOL + * .AND. P5*RATIO .LE. ONE .AND. INFO .EQ. 2) INFO = 3 + IF (INFO .NE. 0) GO TO 300 +C +C TESTS FOR TERMINATION AND STRINGENT TOLERANCES. +C + IF (NFEV .GE. MAXFEV) INFO = 5 + IF (DABS(ACTRED) .LE. EPSMCH .AND. PRERED .LE. EPSMCH + * .AND. P5*RATIO .LE. ONE) INFO = 6 + IF (DELTA .LE. EPSMCH*XNORM) INFO = 7 + IF (GNORM .LE. EPSMCH) INFO = 8 + IF (INFO .NE. 0) GO TO 300 +C +C END OF THE INNER LOOP. REPEAT IF ITERATION UNSUCCESSFUL. +C + IF (RATIO .LT. P0001) GO TO 200 +C +C END OF THE OUTER LOOP. +C + GO TO 30 + 300 CONTINUE +C +C TERMINATION, EITHER NORMAL OR USER IMPOSED. +C + IF (IFLAG .LT. 0) INFO = IFLAG + IFLAG = 0 + IF (NPRINT .GT. 0) CALL FCN(M,N,X,FVEC,IFLAG) + RETURN +C +C LAST CARD OF SUBROUTINE LMDIF. +C + END + SUBROUTINE LMDIF1(FCN,M,N,X,FVEC,TOL,INFO,IWA,WA,LWA) + INTEGER M,N,INFO,LWA + INTEGER IWA(N) + DOUBLE PRECISION TOL + DOUBLE PRECISION X(N),FVEC(M),WA(LWA) + EXTERNAL FCN +C ********** +C +C SUBROUTINE LMDIF1 +C +C THE PURPOSE OF LMDIF1 IS TO MINIMIZE THE SUM OF THE SQUARES OF +C M NONLINEAR FUNCTIONS IN N VARIABLES BY A MODIFICATION OF THE +C LEVENBERG-MARQUARDT ALGORITHM. THIS IS DONE BY USING THE MORE +C GENERAL LEAST-SQUARES SOLVER LMDIF. THE USER MUST PROVIDE A +C SUBROUTINE WHICH CALCULATES THE FUNCTIONS. THE JACOBIAN IS +C THEN CALCULATED BY A FORWARD-DIFFERENCE APPROXIMATION. +C +C THE SUBROUTINE STATEMENT IS +C +C SUBROUTINE LMDIF1(FCN,M,N,X,FVEC,TOL,INFO,IWA,WA,LWA) +C +C WHERE +C +C FCN IS THE NAME OF THE USER-SUPPLIED SUBROUTINE WHICH +C CALCULATES THE FUNCTIONS. FCN MUST BE DECLARED +C IN AN EXTERNAL STATEMENT IN THE USER CALLING +C PROGRAM, AND SHOULD BE WRITTEN AS FOLLOWS. +C +C SUBROUTINE FCN(M,N,X,FVEC,IFLAG) +C INTEGER M,N,IFLAG +C DOUBLE PRECISION X(N),FVEC(M) +C ---------- +C CALCULATE THE FUNCTIONS AT X AND +C RETURN THIS VECTOR IN FVEC. +C ---------- +C RETURN +C END +C +C THE VALUE OF IFLAG SHOULD NOT BE CHANGED BY FCN UNLESS +C THE USER WANTS TO TERMINATE EXECUTION OF LMDIF1. +C IN THIS CASE SET IFLAG TO A NEGATIVE INTEGER. +C +C M IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER +C OF FUNCTIONS. +C +C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER +C OF VARIABLES. N MUST NOT EXCEED M. +C +C X IS AN ARRAY OF LENGTH N. ON INPUT X MUST CONTAIN +C AN INITIAL ESTIMATE OF THE SOLUTION VECTOR. ON OUTPUT X +C CONTAINS THE FINAL ESTIMATE OF THE SOLUTION VECTOR. +C +C FVEC IS AN OUTPUT ARRAY OF LENGTH M WHICH CONTAINS +C THE FUNCTIONS EVALUATED AT THE OUTPUT X. +C +C TOL IS A NONNEGATIVE INPUT VARIABLE. TERMINATION OCCURS +C WHEN THE ALGORITHM ESTIMATES EITHER THAT THE RELATIVE +C ERROR IN THE SUM OF SQUARES IS AT MOST TOL OR THAT +C THE RELATIVE ERROR BETWEEN X AND THE SOLUTION IS AT +C MOST TOL. +C +C INFO IS AN INTEGER OUTPUT VARIABLE. IF THE USER HAS +C TERMINATED EXECUTION, INFO IS SET TO THE (NEGATIVE) +C VALUE OF IFLAG. SEE DESCRIPTION OF FCN. OTHERWISE, +C INFO IS SET AS FOLLOWS. +C +C INFO = 0 IMPROPER INPUT PARAMETERS. +C +C INFO = 1 ALGORITHM ESTIMATES THAT THE RELATIVE ERROR +C IN THE SUM OF SQUARES IS AT MOST TOL. +C +C INFO = 2 ALGORITHM ESTIMATES THAT THE RELATIVE ERROR +C BETWEEN X AND THE SOLUTION IS AT MOST TOL. +C +C INFO = 3 CONDITIONS FOR INFO = 1 AND INFO = 2 BOTH HOLD. +C +C INFO = 4 FVEC IS ORTHOGONAL TO THE COLUMNS OF THE +C JACOBIAN TO MACHINE PRECISION. +C +C INFO = 5 NUMBER OF CALLS TO FCN HAS REACHED OR +C EXCEEDED 200*(N+1). +C +C INFO = 6 TOL IS TOO SMALL. NO FURTHER REDUCTION IN +C THE SUM OF SQUARES IS POSSIBLE. +C +C INFO = 7 TOL IS TOO SMALL. NO FURTHER IMPROVEMENT IN +C THE APPROXIMATE SOLUTION X IS POSSIBLE. +C +C IWA IS AN INTEGER WORK ARRAY OF LENGTH N. +C +C WA IS A WORK ARRAY OF LENGTH LWA. +C +C LWA IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN +C M*N+5*N+M. +C +C SUBPROGRAMS CALLED +C +C USER-SUPPLIED ...... FCN +C +C MINPACK-SUPPLIED ... LMDIF +C +C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. +C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE +C +C ********** + INTEGER MAXFEV,MODE,MP5N,NFEV,NPRINT + DOUBLE PRECISION EPSFCN,FACTOR,FTOL,GTOL,XTOL,ZERO + DATA FACTOR,ZERO /1.0D2,0.0D0/ + INFO = 0 +C +C CHECK THE INPUT PARAMETERS FOR ERRORS. +C + IF (N .LE. 0 .OR. M .LT. N .OR. TOL .LT. ZERO + * .OR. LWA .LT. M*N + 5*N + M) GO TO 10 +C +C CALL LMDIF. +C + MAXFEV = 200*(N + 1) + FTOL = TOL + XTOL = TOL + GTOL = ZERO + EPSFCN = ZERO + MODE = 1 + NPRINT = 0 + MP5N = M + 5*N + CALL LMDIF(FCN,M,N,X,FVEC,FTOL,XTOL,GTOL,MAXFEV,EPSFCN,WA(1), + * MODE,FACTOR,NPRINT,INFO,NFEV,WA(MP5N+1),M,IWA, + * WA(N+1),WA(2*N+1),WA(3*N+1),WA(4*N+1),WA(5*N+1)) + IF (INFO .EQ. 8) INFO = 4 + 10 CONTINUE + RETURN +C +C LAST CARD OF SUBROUTINE LMDIF1. +C + END + SUBROUTINE LMPAR(N,R,LDR,IPVT,DIAG,QTB,DELTA,PAR,X,SDIAG,WA1, + * WA2) + INTEGER N,LDR + INTEGER IPVT(N) + DOUBLE PRECISION DELTA,PAR + DOUBLE PRECISION R(LDR,N),DIAG(N),QTB(N),X(N),SDIAG(N),WA1(N), + * WA2(N) +C ********** +C +C SUBROUTINE LMPAR +C +C GIVEN AN M BY N MATRIX A, AN N BY N NONSINGULAR DIAGONAL +C MATRIX D, AN M-VECTOR B, AND A POSITIVE NUMBER DELTA, +C THE PROBLEM IS TO DETERMINE A VALUE FOR THE PARAMETER +C PAR SUCH THAT IF X SOLVES THE SYSTEM +C +C A*X = B , SQRT(PAR)*D*X = 0 , +C +C IN THE LEAST SQUARES SENSE, AND DXNORM IS THE EUCLIDEAN +C NORM OF D*X, THEN EITHER PAR IS ZERO AND +C +C (DXNORM-DELTA) .LE. 0.1*DELTA , +C +C OR PAR IS POSITIVE AND +C +C ABS(DXNORM-DELTA) .LE. 0.1*DELTA . +C +C THIS SUBROUTINE COMPLETES THE SOLUTION OF THE PROBLEM +C IF IT IS PROVIDED WITH THE NECESSARY INFORMATION FROM THE +C QR FACTORIZATION, WITH COLUMN PIVOTING, OF A. THAT IS, IF +C A*P = Q*R, WHERE P IS A PERMUTATION MATRIX, Q HAS ORTHOGONAL +C COLUMNS, AND R IS AN UPPER TRIANGULAR MATRIX WITH DIAGONAL +C ELEMENTS OF NONINCREASING MAGNITUDE, THEN LMPAR EXPECTS +C THE FULL UPPER TRIANGLE OF R, THE PERMUTATION MATRIX P, +C AND THE FIRST N COMPONENTS OF (Q TRANSPOSE)*B. ON OUTPUT +C LMPAR ALSO PROVIDES AN UPPER TRIANGULAR MATRIX S SUCH THAT +C +C T T T +C P *(A *A + PAR*D*D)*P = S *S . +C +C S IS EMPLOYED WITHIN LMPAR AND MAY BE OF SEPARATE INTEREST. +C +C ONLY A FEW ITERATIONS ARE GENERALLY NEEDED FOR CONVERGENCE +C OF THE ALGORITHM. IF, HOWEVER, THE LIMIT OF 10 ITERATIONS +C IS REACHED, THEN THE OUTPUT PAR WILL CONTAIN THE BEST +C VALUE OBTAINED SO FAR. +C +C THE SUBROUTINE STATEMENT IS +C +C SUBROUTINE LMPAR(N,R,LDR,IPVT,DIAG,QTB,DELTA,PAR,X,SDIAG, +C WA1,WA2) +C +C WHERE +C +C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE ORDER OF R. +C +C R IS AN N BY N ARRAY. ON INPUT THE FULL UPPER TRIANGLE +C MUST CONTAIN THE FULL UPPER TRIANGLE OF THE MATRIX R. +C ON OUTPUT THE FULL UPPER TRIANGLE IS UNALTERED, AND THE +C STRICT LOWER TRIANGLE CONTAINS THE STRICT UPPER TRIANGLE +C (TRANSPOSED) OF THE UPPER TRIANGULAR MATRIX S. +C +C LDR IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN N +C WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY R. +C +C IPVT IS AN INTEGER INPUT ARRAY OF LENGTH N WHICH DEFINES THE +C PERMUTATION MATRIX P SUCH THAT A*P = Q*R. COLUMN J OF P +C IS COLUMN IPVT(J) OF THE IDENTITY MATRIX. +C +C DIAG IS AN INPUT ARRAY OF LENGTH N WHICH MUST CONTAIN THE +C DIAGONAL ELEMENTS OF THE MATRIX D. +C +C QTB IS AN INPUT ARRAY OF LENGTH N WHICH MUST CONTAIN THE FIRST +C N ELEMENTS OF THE VECTOR (Q TRANSPOSE)*B. +C +C DELTA IS A POSITIVE INPUT VARIABLE WHICH SPECIFIES AN UPPER +C BOUND ON THE EUCLIDEAN NORM OF D*X. +C +C PAR IS A NONNEGATIVE VARIABLE. ON INPUT PAR CONTAINS AN +C INITIAL ESTIMATE OF THE LEVENBERG-MARQUARDT PARAMETER. +C ON OUTPUT PAR CONTAINS THE FINAL ESTIMATE. +C +C X IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE LEAST +C SQUARES SOLUTION OF THE SYSTEM A*X = B, SQRT(PAR)*D*X = 0, +C FOR THE OUTPUT PAR. +C +C SDIAG IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE +C DIAGONAL ELEMENTS OF THE UPPER TRIANGULAR MATRIX S. +C +C WA1 AND WA2 ARE WORK ARRAYS OF LENGTH N. +C +C SUBPROGRAMS CALLED +C +C MINPACK-SUPPLIED ... DPMPAR,ENORM,QRSOLV +C +C FORTRAN-SUPPLIED ... DABS,DMAX1,DMIN1,DSQRT +C +C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. +C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE +C +C ********** + INTEGER I,ITER,J,JM1,JP1,K,L,NSING + DOUBLE PRECISION DXNORM,DWARF,FP,GNORM,PARC,PARL,PARU,P1,P001, + * SUM,TEMP,ZERO + DOUBLE PRECISION DPMPAR,ENORM + DATA P1,P001,ZERO /1.0D-1,1.0D-3,0.0D0/ +C +C DWARF IS THE SMALLEST POSITIVE MAGNITUDE. +C + DWARF = DPMPAR(2) +C +C COMPUTE AND STORE IN X THE GAUSS-NEWTON DIRECTION. IF THE +C JACOBIAN IS RANK-DEFICIENT, OBTAIN A LEAST SQUARES SOLUTION. +C + NSING = N + DO 10 J = 1, N + WA1(J) = QTB(J) + IF (R(J,J) .EQ. ZERO .AND. NSING .EQ. N) NSING = J - 1 + IF (NSING .LT. N) WA1(J) = ZERO + 10 CONTINUE + IF (NSING .LT. 1) GO TO 50 + DO 40 K = 1, NSING + J = NSING - K + 1 + WA1(J) = WA1(J)/R(J,J) + TEMP = WA1(J) + JM1 = J - 1 + IF (JM1 .LT. 1) GO TO 30 + DO 20 I = 1, JM1 + WA1(I) = WA1(I) - R(I,J)*TEMP + 20 CONTINUE + 30 CONTINUE + 40 CONTINUE + 50 CONTINUE + DO 60 J = 1, N + L = IPVT(J) + X(L) = WA1(J) + 60 CONTINUE +C +C INITIALIZE THE ITERATION COUNTER. +C EVALUATE THE FUNCTION AT THE ORIGIN, AND TEST +C FOR ACCEPTANCE OF THE GAUSS-NEWTON DIRECTION. +C + ITER = 0 + DO 70 J = 1, N + WA2(J) = DIAG(J)*X(J) + 70 CONTINUE + DXNORM = ENORM(N,WA2) + FP = DXNORM - DELTA + IF (FP .LE. P1*DELTA) GO TO 220 +C +C IF THE JACOBIAN IS NOT RANK DEFICIENT, THE NEWTON +C STEP PROVIDES A LOWER BOUND, PARL, FOR THE ZERO OF +C THE FUNCTION. OTHERWISE SET THIS BOUND TO ZERO. +C + PARL = ZERO + IF (NSING .LT. N) GO TO 120 + DO 80 J = 1, N + L = IPVT(J) + WA1(J) = DIAG(L)*(WA2(L)/DXNORM) + 80 CONTINUE + DO 110 J = 1, N + SUM = ZERO + JM1 = J - 1 + IF (JM1 .LT. 1) GO TO 100 + DO 90 I = 1, JM1 + SUM = SUM + R(I,J)*WA1(I) + 90 CONTINUE + 100 CONTINUE + WA1(J) = (WA1(J) - SUM)/R(J,J) + 110 CONTINUE + TEMP = ENORM(N,WA1) + PARL = ((FP/DELTA)/TEMP)/TEMP + 120 CONTINUE +C +C CALCULATE AN UPPER BOUND, PARU, FOR THE ZERO OF THE FUNCTION. +C + DO 140 J = 1, N + SUM = ZERO + DO 130 I = 1, J + SUM = SUM + R(I,J)*QTB(I) + 130 CONTINUE + L = IPVT(J) + WA1(J) = SUM/DIAG(L) + 140 CONTINUE + GNORM = ENORM(N,WA1) + PARU = GNORM/DELTA + IF (PARU .EQ. ZERO) PARU = DWARF/DMIN1(DELTA,P1) +C +C IF THE INPUT PAR LIES OUTSIDE OF THE INTERVAL (PARL,PARU), +C SET PAR TO THE CLOSER ENDPOINT. +C + PAR = DMAX1(PAR,PARL) + PAR = DMIN1(PAR,PARU) + IF (PAR .EQ. ZERO) PAR = GNORM/DXNORM +C +C BEGINNING OF AN ITERATION. +C + 150 CONTINUE + ITER = ITER + 1 +C +C EVALUATE THE FUNCTION AT THE CURRENT VALUE OF PAR. +C + IF (PAR .EQ. ZERO) PAR = DMAX1(DWARF,P001*PARU) + TEMP = DSQRT(PAR) + DO 160 J = 1, N + WA1(J) = TEMP*DIAG(J) + 160 CONTINUE + CALL QRSOLV(N,R,LDR,IPVT,WA1,QTB,X,SDIAG,WA2) + DO 170 J = 1, N + WA2(J) = DIAG(J)*X(J) + 170 CONTINUE + DXNORM = ENORM(N,WA2) + TEMP = FP + FP = DXNORM - DELTA +C +C IF THE FUNCTION IS SMALL ENOUGH, ACCEPT THE CURRENT VALUE +C OF PAR. ALSO TEST FOR THE EXCEPTIONAL CASES WHERE PARL +C IS ZERO OR THE NUMBER OF ITERATIONS HAS REACHED 10. +C + IF (DABS(FP) .LE. P1*DELTA + * .OR. PARL .EQ. ZERO .AND. FP .LE. TEMP + * .AND. TEMP .LT. ZERO .OR. ITER .EQ. 10) GO TO 220 +C +C COMPUTE THE NEWTON CORRECTION. +C + DO 180 J = 1, N + L = IPVT(J) + WA1(J) = DIAG(L)*(WA2(L)/DXNORM) + 180 CONTINUE + DO 210 J = 1, N + WA1(J) = WA1(J)/SDIAG(J) + TEMP = WA1(J) + JP1 = J + 1 + IF (N .LT. JP1) GO TO 200 + DO 190 I = JP1, N + WA1(I) = WA1(I) - R(I,J)*TEMP + 190 CONTINUE + 200 CONTINUE + 210 CONTINUE + TEMP = ENORM(N,WA1) + PARC = ((FP/DELTA)/TEMP)/TEMP +C +C DEPENDING ON THE SIGN OF THE FUNCTION, UPDATE PARL OR PARU. +C + IF (FP .GT. ZERO) PARL = DMAX1(PARL,PAR) + IF (FP .LT. ZERO) PARU = DMIN1(PARU,PAR) +C +C COMPUTE AN IMPROVED ESTIMATE FOR PAR. +C + PAR = DMAX1(PARL,PAR+PARC) +C +C END OF AN ITERATION. +C + GO TO 150 + 220 CONTINUE +C +C TERMINATION. +C + IF (ITER .EQ. 0) PAR = ZERO + RETURN +C +C LAST CARD OF SUBROUTINE LMPAR. +C + END + SUBROUTINE LMSTR(FCN,M,N,X,FVEC,FJAC,LDFJAC,FTOL,XTOL,GTOL, + * MAXFEV,DIAG,MODE,FACTOR,NPRINT,INFO,NFEV,NJEV, + * IPVT,QTF,WA1,WA2,WA3,WA4) + INTEGER M,N,LDFJAC,MAXFEV,MODE,NPRINT,INFO,NFEV,NJEV + INTEGER IPVT(N) + LOGICAL SING + DOUBLE PRECISION FTOL,XTOL,GTOL,FACTOR + DOUBLE PRECISION X(N),FVEC(M),FJAC(LDFJAC,N),DIAG(N),QTF(N), + * WA1(N),WA2(N),WA3(N),WA4(M) +C ********** +C +C SUBROUTINE LMSTR +C +C THE PURPOSE OF LMSTR IS TO MINIMIZE THE SUM OF THE SQUARES OF +C M NONLINEAR FUNCTIONS IN N VARIABLES BY A MODIFICATION OF +C THE LEVENBERG-MARQUARDT ALGORITHM WHICH USES MINIMAL STORAGE. +C THE USER MUST PROVIDE A SUBROUTINE WHICH CALCULATES THE +C FUNCTIONS AND THE ROWS OF THE JACOBIAN. +C +C THE SUBROUTINE STATEMENT IS +C +C SUBROUTINE LMSTR(FCN,M,N,X,FVEC,FJAC,LDFJAC,FTOL,XTOL,GTOL, +C MAXFEV,DIAG,MODE,FACTOR,NPRINT,INFO,NFEV, +C NJEV,IPVT,QTF,WA1,WA2,WA3,WA4) +C +C WHERE +C +C FCN IS THE NAME OF THE USER-SUPPLIED SUBROUTINE WHICH +C CALCULATES THE FUNCTIONS AND THE ROWS OF THE JACOBIAN. +C FCN MUST BE DECLARED IN AN EXTERNAL STATEMENT IN THE +C USER CALLING PROGRAM, AND SHOULD BE WRITTEN AS FOLLOWS. +C +C SUBROUTINE FCN(M,N,X,FVEC,FJROW,IFLAG) +C INTEGER M,N,IFLAG +C DOUBLE PRECISION X(N),FVEC(M),FJROW(N) +C ---------- +C IF IFLAG = 1 CALCULATE THE FUNCTIONS AT X AND +C RETURN THIS VECTOR IN FVEC. +C IF IFLAG = I CALCULATE THE (I-1)-ST ROW OF THE +C JACOBIAN AT X AND RETURN THIS VECTOR IN FJROW. +C ---------- +C RETURN +C END +C +C THE VALUE OF IFLAG SHOULD NOT BE CHANGED BY FCN UNLESS +C THE USER WANTS TO TERMINATE EXECUTION OF LMSTR. +C IN THIS CASE SET IFLAG TO A NEGATIVE INTEGER. +C +C M IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER +C OF FUNCTIONS. +C +C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER +C OF VARIABLES. N MUST NOT EXCEED M. +C +C X IS AN ARRAY OF LENGTH N. ON INPUT X MUST CONTAIN +C AN INITIAL ESTIMATE OF THE SOLUTION VECTOR. ON OUTPUT X +C CONTAINS THE FINAL ESTIMATE OF THE SOLUTION VECTOR. +C +C FVEC IS AN OUTPUT ARRAY OF LENGTH M WHICH CONTAINS +C THE FUNCTIONS EVALUATED AT THE OUTPUT X. +C +C FJAC IS AN OUTPUT N BY N ARRAY. THE UPPER TRIANGLE OF FJAC +C CONTAINS AN UPPER TRIANGULAR MATRIX R SUCH THAT +C +C T T T +C P *(JAC *JAC)*P = R *R, +C +C WHERE P IS A PERMUTATION MATRIX AND JAC IS THE FINAL +C CALCULATED JACOBIAN. COLUMN J OF P IS COLUMN IPVT(J) +C (SEE BELOW) OF THE IDENTITY MATRIX. THE LOWER TRIANGULAR +C PART OF FJAC CONTAINS INFORMATION GENERATED DURING +C THE COMPUTATION OF R. +C +C LDFJAC IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN N +C WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY FJAC. +C +C FTOL IS A NONNEGATIVE INPUT VARIABLE. TERMINATION +C OCCURS WHEN BOTH THE ACTUAL AND PREDICTED RELATIVE +C REDUCTIONS IN THE SUM OF SQUARES ARE AT MOST FTOL. +C THEREFORE, FTOL MEASURES THE RELATIVE ERROR DESIRED +C IN THE SUM OF SQUARES. +C +C XTOL IS A NONNEGATIVE INPUT VARIABLE. TERMINATION +C OCCURS WHEN THE RELATIVE ERROR BETWEEN TWO CONSECUTIVE +C ITERATES IS AT MOST XTOL. THEREFORE, XTOL MEASURES THE +C RELATIVE ERROR DESIRED IN THE APPROXIMATE SOLUTION. +C +C GTOL IS A NONNEGATIVE INPUT VARIABLE. TERMINATION +C OCCURS WHEN THE COSINE OF THE ANGLE BETWEEN FVEC AND +C ANY COLUMN OF THE JACOBIAN IS AT MOST GTOL IN ABSOLUTE +C VALUE. THEREFORE, GTOL MEASURES THE ORTHOGONALITY +C DESIRED BETWEEN THE FUNCTION VECTOR AND THE COLUMNS +C OF THE JACOBIAN. +C +C MAXFEV IS A POSITIVE INTEGER INPUT VARIABLE. TERMINATION +C OCCURS WHEN THE NUMBER OF CALLS TO FCN WITH IFLAG = 1 +C HAS REACHED MAXFEV. +C +C DIAG IS AN ARRAY OF LENGTH N. IF MODE = 1 (SEE +C BELOW), DIAG IS INTERNALLY SET. IF MODE = 2, DIAG +C MUST CONTAIN POSITIVE ENTRIES THAT SERVE AS +C MULTIPLICATIVE SCALE FACTORS FOR THE VARIABLES. +C +C MODE IS AN INTEGER INPUT VARIABLE. IF MODE = 1, THE +C VARIABLES WILL BE SCALED INTERNALLY. IF MODE = 2, +C THE SCALING IS SPECIFIED BY THE INPUT DIAG. OTHER +C VALUES OF MODE ARE EQUIVALENT TO MODE = 1. +C +C FACTOR IS A POSITIVE INPUT VARIABLE USED IN DETERMINING THE +C INITIAL STEP BOUND. THIS BOUND IS SET TO THE PRODUCT OF +C FACTOR AND THE EUCLIDEAN NORM OF DIAG*X IF NONZERO, OR ELSE +C TO FACTOR ITSELF. IN MOST CASES FACTOR SHOULD LIE IN THE +C INTERVAL (.1,100.). 100. IS A GENERALLY RECOMMENDED VALUE. +C +C NPRINT IS AN INTEGER INPUT VARIABLE THAT ENABLES CONTROLLED +C PRINTING OF ITERATES IF IT IS POSITIVE. IN THIS CASE, +C FCN IS CALLED WITH IFLAG = 0 AT THE BEGINNING OF THE FIRST +C ITERATION AND EVERY NPRINT ITERATIONS THEREAFTER AND +C IMMEDIATELY PRIOR TO RETURN, WITH X AND FVEC AVAILABLE +C FOR PRINTING. IF NPRINT IS NOT POSITIVE, NO SPECIAL CALLS +C OF FCN WITH IFLAG = 0 ARE MADE. +C +C INFO IS AN INTEGER OUTPUT VARIABLE. IF THE USER HAS +C TERMINATED EXECUTION, INFO IS SET TO THE (NEGATIVE) +C VALUE OF IFLAG. SEE DESCRIPTION OF FCN. OTHERWISE, +C INFO IS SET AS FOLLOWS. +C +C INFO = 0 IMPROPER INPUT PARAMETERS. +C +C INFO = 1 BOTH ACTUAL AND PREDICTED RELATIVE REDUCTIONS +C IN THE SUM OF SQUARES ARE AT MOST FTOL. +C +C INFO = 2 RELATIVE ERROR BETWEEN TWO CONSECUTIVE ITERATES +C IS AT MOST XTOL. +C +C INFO = 3 CONDITIONS FOR INFO = 1 AND INFO = 2 BOTH HOLD. +C +C INFO = 4 THE COSINE OF THE ANGLE BETWEEN FVEC AND ANY +C COLUMN OF THE JACOBIAN IS AT MOST GTOL IN +C ABSOLUTE VALUE. +C +C INFO = 5 NUMBER OF CALLS TO FCN WITH IFLAG = 1 HAS +C REACHED MAXFEV. +C +C INFO = 6 FTOL IS TOO SMALL. NO FURTHER REDUCTION IN +C THE SUM OF SQUARES IS POSSIBLE. +C +C INFO = 7 XTOL IS TOO SMALL. NO FURTHER IMPROVEMENT IN +C THE APPROXIMATE SOLUTION X IS POSSIBLE. +C +C INFO = 8 GTOL IS TOO SMALL. FVEC IS ORTHOGONAL TO THE +C COLUMNS OF THE JACOBIAN TO MACHINE PRECISION. +C +C NFEV IS AN INTEGER OUTPUT VARIABLE SET TO THE NUMBER OF +C CALLS TO FCN WITH IFLAG = 1. +C +C NJEV IS AN INTEGER OUTPUT VARIABLE SET TO THE NUMBER OF +C CALLS TO FCN WITH IFLAG = 2. +C +C IPVT IS AN INTEGER OUTPUT ARRAY OF LENGTH N. IPVT +C DEFINES A PERMUTATION MATRIX P SUCH THAT JAC*P = Q*R, +C WHERE JAC IS THE FINAL CALCULATED JACOBIAN, Q IS +C ORTHOGONAL (NOT STORED), AND R IS UPPER TRIANGULAR. +C COLUMN J OF P IS COLUMN IPVT(J) OF THE IDENTITY MATRIX. +C +C QTF IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS +C THE FIRST N ELEMENTS OF THE VECTOR (Q TRANSPOSE)*FVEC. +C +C WA1, WA2, AND WA3 ARE WORK ARRAYS OF LENGTH N. +C +C WA4 IS A WORK ARRAY OF LENGTH M. +C +C SUBPROGRAMS CALLED +C +C USER-SUPPLIED ...... FCN +C +C MINPACK-SUPPLIED ... DPMPAR,ENORM,LMPAR,QRFAC,RWUPDT +C +C FORTRAN-SUPPLIED ... DABS,DMAX1,DMIN1,DSQRT,MOD +C +C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. +C BURTON S. GARBOW, DUDLEY V. GOETSCHEL, KENNETH E. HILLSTROM, +C JORGE J. MORE +C +C ********** + INTEGER I,IFLAG,ITER,J,L + DOUBLE PRECISION ACTRED,DELTA,DIRDER,EPSMCH,FNORM,FNORM1,GNORM, + * ONE,PAR,PNORM,PRERED,P1,P5,P25,P75,P0001,RATIO, + * SUM,TEMP,TEMP1,TEMP2,XNORM,ZERO + DOUBLE PRECISION DPMPAR,ENORM + DATA ONE,P1,P5,P25,P75,P0001,ZERO + * /1.0D0,1.0D-1,5.0D-1,2.5D-1,7.5D-1,1.0D-4,0.0D0/ +C +C EPSMCH IS THE MACHINE PRECISION. +C + EPSMCH = DPMPAR(1) +C + INFO = 0 + IFLAG = 0 + NFEV = 0 + NJEV = 0 +C +C CHECK THE INPUT PARAMETERS FOR ERRORS. +C + IF (N .LE. 0 .OR. M .LT. N .OR. LDFJAC .LT. N + * .OR. FTOL .LT. ZERO .OR. XTOL .LT. ZERO .OR. GTOL .LT. ZERO + * .OR. MAXFEV .LE. 0 .OR. FACTOR .LE. ZERO) GO TO 340 + IF (MODE .NE. 2) GO TO 20 + DO 10 J = 1, N + IF (DIAG(J) .LE. ZERO) GO TO 340 + 10 CONTINUE + 20 CONTINUE +C +C EVALUATE THE FUNCTION AT THE STARTING POINT +C AND CALCULATE ITS NORM. +C + IFLAG = 1 + CALL FCN(M,N,X,FVEC,WA3,IFLAG) + NFEV = 1 + IF (IFLAG .LT. 0) GO TO 340 + FNORM = ENORM(M,FVEC) +C +C INITIALIZE LEVENBERG-MARQUARDT PARAMETER AND ITERATION COUNTER. +C + PAR = ZERO + ITER = 1 +C +C BEGINNING OF THE OUTER LOOP. +C + 30 CONTINUE +C +C IF REQUESTED, CALL FCN TO ENABLE PRINTING OF ITERATES. +C + IF (NPRINT .LE. 0) GO TO 40 + IFLAG = 0 + IF (MOD(ITER-1,NPRINT) .EQ. 0) CALL FCN(M,N,X,FVEC,WA3,IFLAG) + IF (IFLAG .LT. 0) GO TO 340 + 40 CONTINUE +C +C COMPUTE THE QR FACTORIZATION OF THE JACOBIAN MATRIX +C CALCULATED ONE ROW AT A TIME, WHILE SIMULTANEOUSLY +C FORMING (Q TRANSPOSE)*FVEC AND STORING THE FIRST +C N COMPONENTS IN QTF. +C + DO 60 J = 1, N + QTF(J) = ZERO + DO 50 I = 1, N + FJAC(I,J) = ZERO + 50 CONTINUE + 60 CONTINUE + IFLAG = 2 + DO 70 I = 1, M + CALL FCN(M,N,X,FVEC,WA3,IFLAG) + IF (IFLAG .LT. 0) GO TO 340 + TEMP = FVEC(I) + CALL RWUPDT(N,FJAC,LDFJAC,WA3,QTF,TEMP,WA1,WA2) + IFLAG = IFLAG + 1 + 70 CONTINUE + NJEV = NJEV + 1 +C +C IF THE JACOBIAN IS RANK DEFICIENT, CALL QRFAC TO +C REORDER ITS COLUMNS AND UPDATE THE COMPONENTS OF QTF. +C + SING = .FALSE. + DO 80 J = 1, N + IF (FJAC(J,J) .EQ. ZERO) SING = .TRUE. + IPVT(J) = J + WA2(J) = ENORM(J,FJAC(1,J)) + 80 CONTINUE + IF (.NOT.SING) GO TO 130 + CALL QRFAC(N,N,FJAC,LDFJAC,.TRUE.,IPVT,N,WA1,WA2,WA3) + DO 120 J = 1, N + IF (FJAC(J,J) .EQ. ZERO) GO TO 110 + SUM = ZERO + DO 90 I = J, N + SUM = SUM + FJAC(I,J)*QTF(I) + 90 CONTINUE + TEMP = -SUM/FJAC(J,J) + DO 100 I = J, N + QTF(I) = QTF(I) + FJAC(I,J)*TEMP + 100 CONTINUE + 110 CONTINUE + FJAC(J,J) = WA1(J) + 120 CONTINUE + 130 CONTINUE +C +C ON THE FIRST ITERATION AND IF MODE IS 1, SCALE ACCORDING +C TO THE NORMS OF THE COLUMNS OF THE INITIAL JACOBIAN. +C + IF (ITER .NE. 1) GO TO 170 + IF (MODE .EQ. 2) GO TO 150 + DO 140 J = 1, N + DIAG(J) = WA2(J) + IF (WA2(J) .EQ. ZERO) DIAG(J) = ONE + 140 CONTINUE + 150 CONTINUE +C +C ON THE FIRST ITERATION, CALCULATE THE NORM OF THE SCALED X +C AND INITIALIZE THE STEP BOUND DELTA. +C + DO 160 J = 1, N + WA3(J) = DIAG(J)*X(J) + 160 CONTINUE + XNORM = ENORM(N,WA3) + DELTA = FACTOR*XNORM + IF (DELTA .EQ. ZERO) DELTA = FACTOR + 170 CONTINUE +C +C COMPUTE THE NORM OF THE SCALED GRADIENT. +C + GNORM = ZERO + IF (FNORM .EQ. ZERO) GO TO 210 + DO 200 J = 1, N + L = IPVT(J) + IF (WA2(L) .EQ. ZERO) GO TO 190 + SUM = ZERO + DO 180 I = 1, J + SUM = SUM + FJAC(I,J)*(QTF(I)/FNORM) + 180 CONTINUE + GNORM = DMAX1(GNORM,DABS(SUM/WA2(L))) + 190 CONTINUE + 200 CONTINUE + 210 CONTINUE +C +C TEST FOR CONVERGENCE OF THE GRADIENT NORM. +C + IF (GNORM .LE. GTOL) INFO = 4 + IF (INFO .NE. 0) GO TO 340 +C +C RESCALE IF NECESSARY. +C + IF (MODE .EQ. 2) GO TO 230 + DO 220 J = 1, N + DIAG(J) = DMAX1(DIAG(J),WA2(J)) + 220 CONTINUE + 230 CONTINUE +C +C BEGINNING OF THE INNER LOOP. +C + 240 CONTINUE +C +C DETERMINE THE LEVENBERG-MARQUARDT PARAMETER. +C + CALL LMPAR(N,FJAC,LDFJAC,IPVT,DIAG,QTF,DELTA,PAR,WA1,WA2, + * WA3,WA4) +C +C STORE THE DIRECTION P AND X + P. CALCULATE THE NORM OF P. +C + DO 250 J = 1, N + WA1(J) = -WA1(J) + WA2(J) = X(J) + WA1(J) + WA3(J) = DIAG(J)*WA1(J) + 250 CONTINUE + PNORM = ENORM(N,WA3) +C +C ON THE FIRST ITERATION, ADJUST THE INITIAL STEP BOUND. +C + IF (ITER .EQ. 1) DELTA = DMIN1(DELTA,PNORM) +C +C EVALUATE THE FUNCTION AT X + P AND CALCULATE ITS NORM. +C + IFLAG = 1 + CALL FCN(M,N,WA2,WA4,WA3,IFLAG) + NFEV = NFEV + 1 + IF (IFLAG .LT. 0) GO TO 340 + FNORM1 = ENORM(M,WA4) +C +C COMPUTE THE SCALED ACTUAL REDUCTION. +C + ACTRED = -ONE + IF (P1*FNORM1 .LT. FNORM) ACTRED = ONE - (FNORM1/FNORM)**2 +C +C COMPUTE THE SCALED PREDICTED REDUCTION AND +C THE SCALED DIRECTIONAL DERIVATIVE. +C + DO 270 J = 1, N + WA3(J) = ZERO + L = IPVT(J) + TEMP = WA1(L) + DO 260 I = 1, J + WA3(I) = WA3(I) + FJAC(I,J)*TEMP + 260 CONTINUE + 270 CONTINUE + TEMP1 = ENORM(N,WA3)/FNORM + TEMP2 = (DSQRT(PAR)*PNORM)/FNORM + PRERED = TEMP1**2 + TEMP2**2/P5 + DIRDER = -(TEMP1**2 + TEMP2**2) +C +C COMPUTE THE RATIO OF THE ACTUAL TO THE PREDICTED +C REDUCTION. +C + RATIO = ZERO + IF (PRERED .NE. ZERO) RATIO = ACTRED/PRERED +C +C UPDATE THE STEP BOUND. +C + IF (RATIO .GT. P25) GO TO 280 + IF (ACTRED .GE. ZERO) TEMP = P5 + IF (ACTRED .LT. ZERO) + * TEMP = P5*DIRDER/(DIRDER + P5*ACTRED) + IF (P1*FNORM1 .GE. FNORM .OR. TEMP .LT. P1) TEMP = P1 + DELTA = TEMP*DMIN1(DELTA,PNORM/P1) + PAR = PAR/TEMP + GO TO 300 + 280 CONTINUE + IF (PAR .NE. ZERO .AND. RATIO .LT. P75) GO TO 290 + DELTA = PNORM/P5 + PAR = P5*PAR + 290 CONTINUE + 300 CONTINUE +C +C TEST FOR SUCCESSFUL ITERATION. +C + IF (RATIO .LT. P0001) GO TO 330 +C +C SUCCESSFUL ITERATION. UPDATE X, FVEC, AND THEIR NORMS. +C + DO 310 J = 1, N + X(J) = WA2(J) + WA2(J) = DIAG(J)*X(J) + 310 CONTINUE + DO 320 I = 1, M + FVEC(I) = WA4(I) + 320 CONTINUE + XNORM = ENORM(N,WA2) + FNORM = FNORM1 + ITER = ITER + 1 + 330 CONTINUE +C +C TESTS FOR CONVERGENCE. +C + IF (DABS(ACTRED) .LE. FTOL .AND. PRERED .LE. FTOL + * .AND. P5*RATIO .LE. ONE) INFO = 1 + IF (DELTA .LE. XTOL*XNORM) INFO = 2 + IF (DABS(ACTRED) .LE. FTOL .AND. PRERED .LE. FTOL + * .AND. P5*RATIO .LE. ONE .AND. INFO .EQ. 2) INFO = 3 + IF (INFO .NE. 0) GO TO 340 +C +C TESTS FOR TERMINATION AND STRINGENT TOLERANCES. +C + IF (NFEV .GE. MAXFEV) INFO = 5 + IF (DABS(ACTRED) .LE. EPSMCH .AND. PRERED .LE. EPSMCH + * .AND. P5*RATIO .LE. ONE) INFO = 6 + IF (DELTA .LE. EPSMCH*XNORM) INFO = 7 + IF (GNORM .LE. EPSMCH) INFO = 8 + IF (INFO .NE. 0) GO TO 340 +C +C END OF THE INNER LOOP. REPEAT IF ITERATION UNSUCCESSFUL. +C + IF (RATIO .LT. P0001) GO TO 240 +C +C END OF THE OUTER LOOP. +C + GO TO 30 + 340 CONTINUE +C +C TERMINATION, EITHER NORMAL OR USER IMPOSED. +C + IF (IFLAG .LT. 0) INFO = IFLAG + IFLAG = 0 + IF (NPRINT .GT. 0) CALL FCN(M,N,X,FVEC,WA3,IFLAG) + RETURN +C +C LAST CARD OF SUBROUTINE LMSTR. +C + END + SUBROUTINE LMSTR1(FCN,M,N,X,FVEC,FJAC,LDFJAC,TOL,INFO,IPVT,WA, + * LWA) + INTEGER M,N,LDFJAC,INFO,LWA + INTEGER IPVT(N) + DOUBLE PRECISION TOL + DOUBLE PRECISION X(N),FVEC(M),FJAC(LDFJAC,N),WA(LWA) + EXTERNAL FCN +C ********** +C +C SUBROUTINE LMSTR1 +C +C THE PURPOSE OF LMSTR1 IS TO MINIMIZE THE SUM OF THE SQUARES OF +C M NONLINEAR FUNCTIONS IN N VARIABLES BY A MODIFICATION OF +C THE LEVENBERG-MARQUARDT ALGORITHM WHICH USES MINIMAL STORAGE. +C THIS IS DONE BY USING THE MORE GENERAL LEAST-SQUARES SOLVER +C LMSTR. THE USER MUST PROVIDE A SUBROUTINE WHICH CALCULATES +C THE FUNCTIONS AND THE ROWS OF THE JACOBIAN. +C +C THE SUBROUTINE STATEMENT IS +C +C SUBROUTINE LMSTR1(FCN,M,N,X,FVEC,FJAC,LDFJAC,TOL,INFO, +C IPVT,WA,LWA) +C +C WHERE +C +C FCN IS THE NAME OF THE USER-SUPPLIED SUBROUTINE WHICH +C CALCULATES THE FUNCTIONS AND THE ROWS OF THE JACOBIAN. +C FCN MUST BE DECLARED IN AN EXTERNAL STATEMENT IN THE +C USER CALLING PROGRAM, AND SHOULD BE WRITTEN AS FOLLOWS. +C +C SUBROUTINE FCN(M,N,X,FVEC,FJROW,IFLAG) +C INTEGER M,N,IFLAG +C DOUBLE PRECISION X(N),FVEC(M),FJROW(N) +C ---------- +C IF IFLAG = 1 CALCULATE THE FUNCTIONS AT X AND +C RETURN THIS VECTOR IN FVEC. +C IF IFLAG = I CALCULATE THE (I-1)-ST ROW OF THE +C JACOBIAN AT X AND RETURN THIS VECTOR IN FJROW. +C ---------- +C RETURN +C END +C +C THE VALUE OF IFLAG SHOULD NOT BE CHANGED BY FCN UNLESS +C THE USER WANTS TO TERMINATE EXECUTION OF LMSTR1. +C IN THIS CASE SET IFLAG TO A NEGATIVE INTEGER. +C +C M IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER +C OF FUNCTIONS. +C +C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER +C OF VARIABLES. N MUST NOT EXCEED M. +C +C X IS AN ARRAY OF LENGTH N. ON INPUT X MUST CONTAIN +C AN INITIAL ESTIMATE OF THE SOLUTION VECTOR. ON OUTPUT X +C CONTAINS THE FINAL ESTIMATE OF THE SOLUTION VECTOR. +C +C FVEC IS AN OUTPUT ARRAY OF LENGTH M WHICH CONTAINS +C THE FUNCTIONS EVALUATED AT THE OUTPUT X. +C +C FJAC IS AN OUTPUT N BY N ARRAY. THE UPPER TRIANGLE OF FJAC +C CONTAINS AN UPPER TRIANGULAR MATRIX R SUCH THAT +C +C T T T +C P *(JAC *JAC)*P = R *R, +C +C WHERE P IS A PERMUTATION MATRIX AND JAC IS THE FINAL +C CALCULATED JACOBIAN. COLUMN J OF P IS COLUMN IPVT(J) +C (SEE BELOW) OF THE IDENTITY MATRIX. THE LOWER TRIANGULAR +C PART OF FJAC CONTAINS INFORMATION GENERATED DURING +C THE COMPUTATION OF R. +C +C LDFJAC IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN N +C WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY FJAC. +C +C TOL IS A NONNEGATIVE INPUT VARIABLE. TERMINATION OCCURS +C WHEN THE ALGORITHM ESTIMATES EITHER THAT THE RELATIVE +C ERROR IN THE SUM OF SQUARES IS AT MOST TOL OR THAT +C THE RELATIVE ERROR BETWEEN X AND THE SOLUTION IS AT +C MOST TOL. +C +C INFO IS AN INTEGER OUTPUT VARIABLE. IF THE USER HAS +C TERMINATED EXECUTION, INFO IS SET TO THE (NEGATIVE) +C VALUE OF IFLAG. SEE DESCRIPTION OF FCN. OTHERWISE, +C INFO IS SET AS FOLLOWS. +C +C INFO = 0 IMPROPER INPUT PARAMETERS. +C +C INFO = 1 ALGORITHM ESTIMATES THAT THE RELATIVE ERROR +C IN THE SUM OF SQUARES IS AT MOST TOL. +C +C INFO = 2 ALGORITHM ESTIMATES THAT THE RELATIVE ERROR +C BETWEEN X AND THE SOLUTION IS AT MOST TOL. +C +C INFO = 3 CONDITIONS FOR INFO = 1 AND INFO = 2 BOTH HOLD. +C +C INFO = 4 FVEC IS ORTHOGONAL TO THE COLUMNS OF THE +C JACOBIAN TO MACHINE PRECISION. +C +C INFO = 5 NUMBER OF CALLS TO FCN WITH IFLAG = 1 HAS +C REACHED 100*(N+1). +C +C INFO = 6 TOL IS TOO SMALL. NO FURTHER REDUCTION IN +C THE SUM OF SQUARES IS POSSIBLE. +C +C INFO = 7 TOL IS TOO SMALL. NO FURTHER IMPROVEMENT IN +C THE APPROXIMATE SOLUTION X IS POSSIBLE. +C +C IPVT IS AN INTEGER OUTPUT ARRAY OF LENGTH N. IPVT +C DEFINES A PERMUTATION MATRIX P SUCH THAT JAC*P = Q*R, +C WHERE JAC IS THE FINAL CALCULATED JACOBIAN, Q IS +C ORTHOGONAL (NOT STORED), AND R IS UPPER TRIANGULAR. +C COLUMN J OF P IS COLUMN IPVT(J) OF THE IDENTITY MATRIX. +C +C WA IS A WORK ARRAY OF LENGTH LWA. +C +C LWA IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN 5*N+M. +C +C SUBPROGRAMS CALLED +C +C USER-SUPPLIED ...... FCN +C +C MINPACK-SUPPLIED ... LMSTR +C +C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. +C BURTON S. GARBOW, DUDLEY V. GOETSCHEL, KENNETH E. HILLSTROM, +C JORGE J. MORE +C +C ********** + INTEGER MAXFEV,MODE,NFEV,NJEV,NPRINT + DOUBLE PRECISION FACTOR,FTOL,GTOL,XTOL,ZERO + DATA FACTOR,ZERO /1.0D2,0.0D0/ + INFO = 0 +C +C CHECK THE INPUT PARAMETERS FOR ERRORS. +C + IF (N .LE. 0 .OR. M .LT. N .OR. LDFJAC .LT. N .OR. TOL .LT. ZERO + * .OR. LWA .LT. 5*N + M) GO TO 10 +C +C CALL LMSTR. +C + MAXFEV = 100*(N + 1) + FTOL = TOL + XTOL = TOL + GTOL = ZERO + MODE = 1 + NPRINT = 0 + CALL LMSTR(FCN,M,N,X,FVEC,FJAC,LDFJAC,FTOL,XTOL,GTOL,MAXFEV, + * WA(1),MODE,FACTOR,NPRINT,INFO,NFEV,NJEV,IPVT,WA(N+1), + * WA(2*N+1),WA(3*N+1),WA(4*N+1),WA(5*N+1)) + IF (INFO .EQ. 8) INFO = 4 + 10 CONTINUE + RETURN +C +C LAST CARD OF SUBROUTINE LMSTR1. +C + END + SUBROUTINE QFORM(M,N,Q,LDQ,WA) + INTEGER M,N,LDQ + DOUBLE PRECISION Q(LDQ,M),WA(M) +C ********** +C +C SUBROUTINE QFORM +C +C THIS SUBROUTINE PROCEEDS FROM THE COMPUTED QR FACTORIZATION OF +C AN M BY N MATRIX A TO ACCUMULATE THE M BY M ORTHOGONAL MATRIX +C Q FROM ITS FACTORED FORM. +C +C THE SUBROUTINE STATEMENT IS +C +C SUBROUTINE QFORM(M,N,Q,LDQ,WA) +C +C WHERE +C +C M IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER +C OF ROWS OF A AND THE ORDER OF Q. +C +C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER +C OF COLUMNS OF A. +C +C Q IS AN M BY M ARRAY. ON INPUT THE FULL LOWER TRAPEZOID IN +C THE FIRST MIN(M,N) COLUMNS OF Q CONTAINS THE FACTORED FORM. +C ON OUTPUT Q HAS BEEN ACCUMULATED INTO A SQUARE MATRIX. +C +C LDQ IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN M +C WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY Q. +C +C WA IS A WORK ARRAY OF LENGTH M. +C +C SUBPROGRAMS CALLED +C +C FORTRAN-SUPPLIED ... MIN0 +C +C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. +C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE +C +C ********** + INTEGER I,J,JM1,K,L,MINMN,NP1 + DOUBLE PRECISION ONE,SUM,TEMP,ZERO + DATA ONE,ZERO /1.0D0,0.0D0/ +C +C ZERO OUT UPPER TRIANGLE OF Q IN THE FIRST MIN(M,N) COLUMNS. +C + MINMN = MIN0(M,N) + IF (MINMN .LT. 2) GO TO 30 + DO 20 J = 2, MINMN + JM1 = J - 1 + DO 10 I = 1, JM1 + Q(I,J) = ZERO + 10 CONTINUE + 20 CONTINUE + 30 CONTINUE +C +C INITIALIZE REMAINING COLUMNS TO THOSE OF THE IDENTITY MATRIX. +C + NP1 = N + 1 + IF (M .LT. NP1) GO TO 60 + DO 50 J = NP1, M + DO 40 I = 1, M + Q(I,J) = ZERO + 40 CONTINUE + Q(J,J) = ONE + 50 CONTINUE + 60 CONTINUE +C +C ACCUMULATE Q FROM ITS FACTORED FORM. +C + DO 120 L = 1, MINMN + K = MINMN - L + 1 + DO 70 I = K, M + WA(I) = Q(I,K) + Q(I,K) = ZERO + 70 CONTINUE + Q(K,K) = ONE + IF (WA(K) .EQ. ZERO) GO TO 110 + DO 100 J = K, M + SUM = ZERO + DO 80 I = K, M + SUM = SUM + Q(I,J)*WA(I) + 80 CONTINUE + TEMP = SUM/WA(K) + DO 90 I = K, M + Q(I,J) = Q(I,J) - TEMP*WA(I) + 90 CONTINUE + 100 CONTINUE + 110 CONTINUE + 120 CONTINUE + RETURN +C +C LAST CARD OF SUBROUTINE QFORM. +C + END + SUBROUTINE QRFAC(M,N,A,LDA,PIVOT,IPVT,LIPVT,RDIAG,ACNORM,WA) + INTEGER M,N,LDA,LIPVT + INTEGER IPVT(LIPVT) + LOGICAL PIVOT + DOUBLE PRECISION A(LDA,N),RDIAG(N),ACNORM(N),WA(N) +C ********** +C +C SUBROUTINE QRFAC +C +C THIS SUBROUTINE USES HOUSEHOLDER TRANSFORMATIONS WITH COLUMN +C PIVOTING (OPTIONAL) TO COMPUTE A QR FACTORIZATION OF THE +C M BY N MATRIX A. THAT IS, QRFAC DETERMINES AN ORTHOGONAL +C MATRIX Q, A PERMUTATION MATRIX P, AND AN UPPER TRAPEZOIDAL +C MATRIX R WITH DIAGONAL ELEMENTS OF NONINCREASING MAGNITUDE, +C SUCH THAT A*P = Q*R. THE HOUSEHOLDER TRANSFORMATION FOR +C COLUMN K, K = 1,2,...,MIN(M,N), IS OF THE FORM +C +C T +C I - (1/U(K))*U*U +C +C WHERE U HAS ZEROS IN THE FIRST K-1 POSITIONS. THE FORM OF +C THIS TRANSFORMATION AND THE METHOD OF PIVOTING FIRST +C APPEARED IN THE CORRESPONDING LINPACK SUBROUTINE. +C +C THE SUBROUTINE STATEMENT IS +C +C SUBROUTINE QRFAC(M,N,A,LDA,PIVOT,IPVT,LIPVT,RDIAG,ACNORM,WA) +C +C WHERE +C +C M IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER +C OF ROWS OF A. +C +C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER +C OF COLUMNS OF A. +C +C A IS AN M BY N ARRAY. ON INPUT A CONTAINS THE MATRIX FOR +C WHICH THE QR FACTORIZATION IS TO BE COMPUTED. ON OUTPUT +C THE STRICT UPPER TRAPEZOIDAL PART OF A CONTAINS THE STRICT +C UPPER TRAPEZOIDAL PART OF R, AND THE LOWER TRAPEZOIDAL +C PART OF A CONTAINS A FACTORED FORM OF Q (THE NON-TRIVIAL +C ELEMENTS OF THE U VECTORS DESCRIBED ABOVE). +C +C LDA IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN M +C WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY A. +C +C PIVOT IS A LOGICAL INPUT VARIABLE. IF PIVOT IS SET TRUE, +C THEN COLUMN PIVOTING IS ENFORCED. IF PIVOT IS SET FALSE, +C THEN NO COLUMN PIVOTING IS DONE. +C +C IPVT IS AN INTEGER OUTPUT ARRAY OF LENGTH LIPVT. IPVT +C DEFINES THE PERMUTATION MATRIX P SUCH THAT A*P = Q*R. +C COLUMN J OF P IS COLUMN IPVT(J) OF THE IDENTITY MATRIX. +C IF PIVOT IS FALSE, IPVT IS NOT REFERENCED. +C +C LIPVT IS A POSITIVE INTEGER INPUT VARIABLE. IF PIVOT IS FALSE, +C THEN LIPVT MAY BE AS SMALL AS 1. IF PIVOT IS TRUE, THEN +C LIPVT MUST BE AT LEAST N. +C +C RDIAG IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE +C DIAGONAL ELEMENTS OF R. +C +C ACNORM IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE +C NORMS OF THE CORRESPONDING COLUMNS OF THE INPUT MATRIX A. +C IF THIS INFORMATION IS NOT NEEDED, THEN ACNORM CAN COINCIDE +C WITH RDIAG. +C +C WA IS A WORK ARRAY OF LENGTH N. IF PIVOT IS FALSE, THEN WA +C CAN COINCIDE WITH RDIAG. +C +C SUBPROGRAMS CALLED +C +C MINPACK-SUPPLIED ... DPMPAR,ENORM +C +C FORTRAN-SUPPLIED ... DMAX1,DSQRT,MIN0 +C +C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. +C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE +C +C ********** + INTEGER I,J,JP1,K,KMAX,MINMN + DOUBLE PRECISION AJNORM,EPSMCH,ONE,P05,SUM,TEMP,ZERO + DOUBLE PRECISION DPMPAR,ENORM + DATA ONE,P05,ZERO /1.0D0,5.0D-2,0.0D0/ +C +C EPSMCH IS THE MACHINE PRECISION. +C + EPSMCH = DPMPAR(1) +C +C COMPUTE THE INITIAL COLUMN NORMS AND INITIALIZE SEVERAL ARRAYS. +C + DO 10 J = 1, N + ACNORM(J) = ENORM(M,A(1,J)) + RDIAG(J) = ACNORM(J) + WA(J) = RDIAG(J) + IF (PIVOT) IPVT(J) = J + 10 CONTINUE +C +C REDUCE A TO R WITH HOUSEHOLDER TRANSFORMATIONS. +C + MINMN = MIN0(M,N) + DO 110 J = 1, MINMN + IF (.NOT.PIVOT) GO TO 40 +C +C BRING THE COLUMN OF LARGEST NORM INTO THE PIVOT POSITION. +C + KMAX = J + DO 20 K = J, N + IF (RDIAG(K) .GT. RDIAG(KMAX)) KMAX = K + 20 CONTINUE + IF (KMAX .EQ. J) GO TO 40 + DO 30 I = 1, M + TEMP = A(I,J) + A(I,J) = A(I,KMAX) + A(I,KMAX) = TEMP + 30 CONTINUE + RDIAG(KMAX) = RDIAG(J) + WA(KMAX) = WA(J) + K = IPVT(J) + IPVT(J) = IPVT(KMAX) + IPVT(KMAX) = K + 40 CONTINUE +C +C COMPUTE THE HOUSEHOLDER TRANSFORMATION TO REDUCE THE +C J-TH COLUMN OF A TO A MULTIPLE OF THE J-TH UNIT VECTOR. +C + AJNORM = ENORM(M-J+1,A(J,J)) + IF (AJNORM .EQ. ZERO) GO TO 100 + IF (A(J,J) .LT. ZERO) AJNORM = -AJNORM + DO 50 I = J, M + A(I,J) = A(I,J)/AJNORM + 50 CONTINUE + A(J,J) = A(J,J) + ONE +C +C APPLY THE TRANSFORMATION TO THE REMAINING COLUMNS +C AND UPDATE THE NORMS. +C + JP1 = J + 1 + IF (N .LT. JP1) GO TO 100 + DO 90 K = JP1, N + SUM = ZERO + DO 60 I = J, M + SUM = SUM + A(I,J)*A(I,K) + 60 CONTINUE + TEMP = SUM/A(J,J) + DO 70 I = J, M + A(I,K) = A(I,K) - TEMP*A(I,J) + 70 CONTINUE + IF (.NOT.PIVOT .OR. RDIAG(K) .EQ. ZERO) GO TO 80 + TEMP = A(J,K)/RDIAG(K) + RDIAG(K) = RDIAG(K)*DSQRT(DMAX1(ZERO,ONE-TEMP**2)) + IF (P05*(RDIAG(K)/WA(K))**2 .GT. EPSMCH) GO TO 80 + RDIAG(K) = ENORM(M-J,A(JP1,K)) + WA(K) = RDIAG(K) + 80 CONTINUE + 90 CONTINUE + 100 CONTINUE + RDIAG(J) = -AJNORM + 110 CONTINUE + RETURN +C +C LAST CARD OF SUBROUTINE QRFAC. +C + END + SUBROUTINE QRSOLV(N,R,LDR,IPVT,DIAG,QTB,X,SDIAG,WA) + INTEGER N,LDR + INTEGER IPVT(N) + DOUBLE PRECISION R(LDR,N),DIAG(N),QTB(N),X(N),SDIAG(N),WA(N) +C ********** +C +C SUBROUTINE QRSOLV +C +C GIVEN AN M BY N MATRIX A, AN N BY N DIAGONAL MATRIX D, +C AND AN M-VECTOR B, THE PROBLEM IS TO DETERMINE AN X WHICH +C SOLVES THE SYSTEM +C +C A*X = B , D*X = 0 , +C +C IN THE LEAST SQUARES SENSE. +C +C THIS SUBROUTINE COMPLETES THE SOLUTION OF THE PROBLEM +C IF IT IS PROVIDED WITH THE NECESSARY INFORMATION FROM THE +C QR FACTORIZATION, WITH COLUMN PIVOTING, OF A. THAT IS, IF +C A*P = Q*R, WHERE P IS A PERMUTATION MATRIX, Q HAS ORTHOGONAL +C COLUMNS, AND R IS AN UPPER TRIANGULAR MATRIX WITH DIAGONAL +C ELEMENTS OF NONINCREASING MAGNITUDE, THEN QRSOLV EXPECTS +C THE FULL UPPER TRIANGLE OF R, THE PERMUTATION MATRIX P, +C AND THE FIRST N COMPONENTS OF (Q TRANSPOSE)*B. THE SYSTEM +C A*X = B, D*X = 0, IS THEN EQUIVALENT TO +C +C T T +C R*Z = Q *B , P *D*P*Z = 0 , +C +C WHERE X = P*Z. IF THIS SYSTEM DOES NOT HAVE FULL RANK, +C THEN A LEAST SQUARES SOLUTION IS OBTAINED. ON OUTPUT QRSOLV +C ALSO PROVIDES AN UPPER TRIANGULAR MATRIX S SUCH THAT +C +C T T T +C P *(A *A + D*D)*P = S *S . +C +C S IS COMPUTED WITHIN QRSOLV AND MAY BE OF SEPARATE INTEREST. +C +C THE SUBROUTINE STATEMENT IS +C +C SUBROUTINE QRSOLV(N,R,LDR,IPVT,DIAG,QTB,X,SDIAG,WA) +C +C WHERE +C +C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE ORDER OF R. +C +C R IS AN N BY N ARRAY. ON INPUT THE FULL UPPER TRIANGLE +C MUST CONTAIN THE FULL UPPER TRIANGLE OF THE MATRIX R. +C ON OUTPUT THE FULL UPPER TRIANGLE IS UNALTERED, AND THE +C STRICT LOWER TRIANGLE CONTAINS THE STRICT UPPER TRIANGLE +C (TRANSPOSED) OF THE UPPER TRIANGULAR MATRIX S. +C +C LDR IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN N +C WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY R. +C +C IPVT IS AN INTEGER INPUT ARRAY OF LENGTH N WHICH DEFINES THE +C PERMUTATION MATRIX P SUCH THAT A*P = Q*R. COLUMN J OF P +C IS COLUMN IPVT(J) OF THE IDENTITY MATRIX. +C +C DIAG IS AN INPUT ARRAY OF LENGTH N WHICH MUST CONTAIN THE +C DIAGONAL ELEMENTS OF THE MATRIX D. +C +C QTB IS AN INPUT ARRAY OF LENGTH N WHICH MUST CONTAIN THE FIRST +C N ELEMENTS OF THE VECTOR (Q TRANSPOSE)*B. +C +C X IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE LEAST +C SQUARES SOLUTION OF THE SYSTEM A*X = B, D*X = 0. +C +C SDIAG IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE +C DIAGONAL ELEMENTS OF THE UPPER TRIANGULAR MATRIX S. +C +C WA IS A WORK ARRAY OF LENGTH N. +C +C SUBPROGRAMS CALLED +C +C FORTRAN-SUPPLIED ... DABS,DSQRT +C +C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. +C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE +C +C ********** + INTEGER I,J,JP1,K,KP1,L,NSING + DOUBLE PRECISION COS,COTAN,P5,P25,QTBPJ,SIN,SUM,TAN,TEMP,ZERO + DATA P5,P25,ZERO /5.0D-1,2.5D-1,0.0D0/ +C +C COPY R AND (Q TRANSPOSE)*B TO PRESERVE INPUT AND INITIALIZE S. +C IN PARTICULAR, SAVE THE DIAGONAL ELEMENTS OF R IN X. +C + DO 20 J = 1, N + DO 10 I = J, N + R(I,J) = R(J,I) + 10 CONTINUE + X(J) = R(J,J) + WA(J) = QTB(J) + 20 CONTINUE +C +C ELIMINATE THE DIAGONAL MATRIX D USING A GIVENS ROTATION. +C + DO 100 J = 1, N +C +C PREPARE THE ROW OF D TO BE ELIMINATED, LOCATING THE +C DIAGONAL ELEMENT USING P FROM THE QR FACTORIZATION. +C + L = IPVT(J) + IF (DIAG(L) .EQ. ZERO) GO TO 90 + DO 30 K = J, N + SDIAG(K) = ZERO + 30 CONTINUE + SDIAG(J) = DIAG(L) +C +C THE TRANSFORMATIONS TO ELIMINATE THE ROW OF D +C MODIFY ONLY A SINGLE ELEMENT OF (Q TRANSPOSE)*B +C BEYOND THE FIRST N, WHICH IS INITIALLY ZERO. +C + QTBPJ = ZERO + DO 80 K = J, N +C +C DETERMINE A GIVENS ROTATION WHICH ELIMINATES THE +C APPROPRIATE ELEMENT IN THE CURRENT ROW OF D. +C + IF (SDIAG(K) .EQ. ZERO) GO TO 70 + IF (DABS(R(K,K)) .GE. DABS(SDIAG(K))) GO TO 40 + COTAN = R(K,K)/SDIAG(K) + SIN = P5/DSQRT(P25+P25*COTAN**2) + COS = SIN*COTAN + GO TO 50 + 40 CONTINUE + TAN = SDIAG(K)/R(K,K) + COS = P5/DSQRT(P25+P25*TAN**2) + SIN = COS*TAN + 50 CONTINUE +C +C COMPUTE THE MODIFIED DIAGONAL ELEMENT OF R AND +C THE MODIFIED ELEMENT OF ((Q TRANSPOSE)*B,0). +C + R(K,K) = COS*R(K,K) + SIN*SDIAG(K) + TEMP = COS*WA(K) + SIN*QTBPJ + QTBPJ = -SIN*WA(K) + COS*QTBPJ + WA(K) = TEMP +C +C ACCUMULATE THE TRANFORMATION IN THE ROW OF S. +C + KP1 = K + 1 + IF (N .LT. KP1) GO TO 70 + DO 60 I = KP1, N + TEMP = COS*R(I,K) + SIN*SDIAG(I) + SDIAG(I) = -SIN*R(I,K) + COS*SDIAG(I) + R(I,K) = TEMP + 60 CONTINUE + 70 CONTINUE + 80 CONTINUE + 90 CONTINUE +C +C STORE THE DIAGONAL ELEMENT OF S AND RESTORE +C THE CORRESPONDING DIAGONAL ELEMENT OF R. +C + SDIAG(J) = R(J,J) + R(J,J) = X(J) + 100 CONTINUE +C +C SOLVE THE TRIANGULAR SYSTEM FOR Z. IF THE SYSTEM IS +C SINGULAR, THEN OBTAIN A LEAST SQUARES SOLUTION. +C + NSING = N + DO 110 J = 1, N + IF (SDIAG(J) .EQ. ZERO .AND. NSING .EQ. N) NSING = J - 1 + IF (NSING .LT. N) WA(J) = ZERO + 110 CONTINUE + IF (NSING .LT. 1) GO TO 150 + DO 140 K = 1, NSING + J = NSING - K + 1 + SUM = ZERO + JP1 = J + 1 + IF (NSING .LT. JP1) GO TO 130 + DO 120 I = JP1, NSING + SUM = SUM + R(I,J)*WA(I) + 120 CONTINUE + 130 CONTINUE + WA(J) = (WA(J) - SUM)/SDIAG(J) + 140 CONTINUE + 150 CONTINUE +C +C PERMUTE THE COMPONENTS OF Z BACK TO COMPONENTS OF X. +C + DO 160 J = 1, N + L = IPVT(J) + X(L) = WA(J) + 160 CONTINUE + RETURN +C +C LAST CARD OF SUBROUTINE QRSOLV. +C + END + SUBROUTINE RWUPDT(N,R,LDR,W,B,ALPHA,COS,SIN) + INTEGER N,LDR + DOUBLE PRECISION ALPHA + DOUBLE PRECISION R(LDR,N),W(N),B(N),COS(N),SIN(N) +C ********** +C +C SUBROUTINE RWUPDT +C +C GIVEN AN N BY N UPPER TRIANGULAR MATRIX R, THIS SUBROUTINE +C COMPUTES THE QR DECOMPOSITION OF THE MATRIX FORMED WHEN A ROW +C IS ADDED TO R. IF THE ROW IS SPECIFIED BY THE VECTOR W, THEN +C RWUPDT DETERMINES AN ORTHOGONAL MATRIX Q SUCH THAT WHEN THE +C N+1 BY N MATRIX COMPOSED OF R AUGMENTED BY W IS PREMULTIPLIED +C BY (Q TRANSPOSE), THE RESULTING MATRIX IS UPPER TRAPEZOIDAL. +C THE MATRIX (Q TRANSPOSE) IS THE PRODUCT OF N TRANSFORMATIONS +C +C G(N)*G(N-1)* ... *G(1) +C +C WHERE G(I) IS A GIVENS ROTATION IN THE (I,N+1) PLANE WHICH +C ELIMINATES ELEMENTS IN THE (N+1)-ST PLANE. RWUPDT ALSO +C COMPUTES THE PRODUCT (Q TRANSPOSE)*C WHERE C IS THE +C (N+1)-VECTOR (B,ALPHA). Q ITSELF IS NOT ACCUMULATED, RATHER +C THE INFORMATION TO RECOVER THE G ROTATIONS IS SUPPLIED. +C +C THE SUBROUTINE STATEMENT IS +C +C SUBROUTINE RWUPDT(N,R,LDR,W,B,ALPHA,COS,SIN) +C +C WHERE +C +C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE ORDER OF R. +C +C R IS AN N BY N ARRAY. ON INPUT THE UPPER TRIANGULAR PART OF +C R MUST CONTAIN THE MATRIX TO BE UPDATED. ON OUTPUT R +C CONTAINS THE UPDATED TRIANGULAR MATRIX. +C +C LDR IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN N +C WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY R. +C +C W IS AN INPUT ARRAY OF LENGTH N WHICH MUST CONTAIN THE ROW +C VECTOR TO BE ADDED TO R. +C +C B IS AN ARRAY OF LENGTH N. ON INPUT B MUST CONTAIN THE +C FIRST N ELEMENTS OF THE VECTOR C. ON OUTPUT B CONTAINS +C THE FIRST N ELEMENTS OF THE VECTOR (Q TRANSPOSE)*C. +C +C ALPHA IS A VARIABLE. ON INPUT ALPHA MUST CONTAIN THE +C (N+1)-ST ELEMENT OF THE VECTOR C. ON OUTPUT ALPHA CONTAINS +C THE (N+1)-ST ELEMENT OF THE VECTOR (Q TRANSPOSE)*C. +C +C COS IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE +C COSINES OF THE TRANSFORMING GIVENS ROTATIONS. +C +C SIN IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE +C SINES OF THE TRANSFORMING GIVENS ROTATIONS. +C +C SUBPROGRAMS CALLED +C +C FORTRAN-SUPPLIED ... DABS,DSQRT +C +C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. +C BURTON S. GARBOW, DUDLEY V. GOETSCHEL, KENNETH E. HILLSTROM, +C JORGE J. MORE +C +C ********** + INTEGER I,J,JM1 + DOUBLE PRECISION COTAN,ONE,P5,P25,ROWJ,TAN,TEMP,ZERO + DATA ONE,P5,P25,ZERO /1.0D0,5.0D-1,2.5D-1,0.0D0/ +C + DO 60 J = 1, N + ROWJ = W(J) + JM1 = J - 1 +C +C APPLY THE PREVIOUS TRANSFORMATIONS TO +C R(I,J), I=1,2,...,J-1, AND TO W(J). +C + IF (JM1 .LT. 1) GO TO 20 + DO 10 I = 1, JM1 + TEMP = COS(I)*R(I,J) + SIN(I)*ROWJ + ROWJ = -SIN(I)*R(I,J) + COS(I)*ROWJ + R(I,J) = TEMP + 10 CONTINUE + 20 CONTINUE +C +C DETERMINE A GIVENS ROTATION WHICH ELIMINATES W(J). +C + COS(J) = ONE + SIN(J) = ZERO + IF (ROWJ .EQ. ZERO) GO TO 50 + IF (DABS(R(J,J)) .GE. DABS(ROWJ)) GO TO 30 + COTAN = R(J,J)/ROWJ + SIN(J) = P5/DSQRT(P25+P25*COTAN**2) + COS(J) = SIN(J)*COTAN + GO TO 40 + 30 CONTINUE + TAN = ROWJ/R(J,J) + COS(J) = P5/DSQRT(P25+P25*TAN**2) + SIN(J) = COS(J)*TAN + 40 CONTINUE +C +C APPLY THE CURRENT TRANSFORMATION TO R(J,J), B(J), AND ALPHA. +C + R(J,J) = COS(J)*R(J,J) + SIN(J)*ROWJ + TEMP = COS(J)*B(J) + SIN(J)*ALPHA + ALPHA = -SIN(J)*B(J) + COS(J)*ALPHA + B(J) = TEMP + 50 CONTINUE + 60 CONTINUE + RETURN +C +C LAST CARD OF SUBROUTINE RWUPDT. +C + END + SUBROUTINE R1MPYQ(M,N,A,LDA,V,W) + INTEGER M,N,LDA + DOUBLE PRECISION A(LDA,N),V(N),W(N) +C ********** +C +C SUBROUTINE R1MPYQ +C +C GIVEN AN M BY N MATRIX A, THIS SUBROUTINE COMPUTES A*Q WHERE +C Q IS THE PRODUCT OF 2*(N - 1) TRANSFORMATIONS +C +C GV(N-1)*...*GV(1)*GW(1)*...*GW(N-1) +C +C AND GV(I), GW(I) ARE GIVENS ROTATIONS IN THE (I,N) PLANE WHICH +C ELIMINATE ELEMENTS IN THE I-TH AND N-TH PLANES, RESPECTIVELY. +C Q ITSELF IS NOT GIVEN, RATHER THE INFORMATION TO RECOVER THE +C GV, GW ROTATIONS IS SUPPLIED. +C +C THE SUBROUTINE STATEMENT IS +C +C SUBROUTINE R1MPYQ(M,N,A,LDA,V,W) +C +C WHERE +C +C M IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER +C OF ROWS OF A. +C +C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER +C OF COLUMNS OF A. +C +C A IS AN M BY N ARRAY. ON INPUT A MUST CONTAIN THE MATRIX +C TO BE POSTMULTIPLIED BY THE ORTHOGONAL MATRIX Q +C DESCRIBED ABOVE. ON OUTPUT A*Q HAS REPLACED A. +C +C LDA IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN M +C WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY A. +C +C V IS AN INPUT ARRAY OF LENGTH N. V(I) MUST CONTAIN THE +C INFORMATION NECESSARY TO RECOVER THE GIVENS ROTATION GV(I) +C DESCRIBED ABOVE. +C +C W IS AN INPUT ARRAY OF LENGTH N. W(I) MUST CONTAIN THE +C INFORMATION NECESSARY TO RECOVER THE GIVENS ROTATION GW(I) +C DESCRIBED ABOVE. +C +C SUBROUTINES CALLED +C +C FORTRAN-SUPPLIED ... DABS,DSQRT +C +C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. +C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE +C +C ********** + INTEGER I,J,NMJ,NM1 + DOUBLE PRECISION COS,ONE,SIN,TEMP + DATA ONE /1.0D0/ +C +C APPLY THE FIRST SET OF GIVENS ROTATIONS TO A. +C + NM1 = N - 1 + IF (NM1 .LT. 1) GO TO 50 + DO 20 NMJ = 1, NM1 + J = N - NMJ + IF (DABS(V(J)) .GT. ONE) COS = ONE/V(J) + IF (DABS(V(J)) .GT. ONE) SIN = DSQRT(ONE-COS**2) + IF (DABS(V(J)) .LE. ONE) SIN = V(J) + IF (DABS(V(J)) .LE. ONE) COS = DSQRT(ONE-SIN**2) + DO 10 I = 1, M + TEMP = COS*A(I,J) - SIN*A(I,N) + A(I,N) = SIN*A(I,J) + COS*A(I,N) + A(I,J) = TEMP + 10 CONTINUE + 20 CONTINUE +C +C APPLY THE SECOND SET OF GIVENS ROTATIONS TO A. +C + DO 40 J = 1, NM1 + IF (DABS(W(J)) .GT. ONE) COS = ONE/W(J) + IF (DABS(W(J)) .GT. ONE) SIN = DSQRT(ONE-COS**2) + IF (DABS(W(J)) .LE. ONE) SIN = W(J) + IF (DABS(W(J)) .LE. ONE) COS = DSQRT(ONE-SIN**2) + DO 30 I = 1, M + TEMP = COS*A(I,J) + SIN*A(I,N) + A(I,N) = -SIN*A(I,J) + COS*A(I,N) + A(I,J) = TEMP + 30 CONTINUE + 40 CONTINUE + 50 CONTINUE + RETURN +C +C LAST CARD OF SUBROUTINE R1MPYQ. +C + END + SUBROUTINE R1UPDT(M,N,S,LS,U,V,W,SING) + INTEGER M,N,LS + LOGICAL SING + DOUBLE PRECISION S(LS),U(M),V(N),W(M) +C ********** +C +C SUBROUTINE R1UPDT +C +C GIVEN AN M BY N LOWER TRAPEZOIDAL MATRIX S, AN M-VECTOR U, +C AND AN N-VECTOR V, THE PROBLEM IS TO DETERMINE AN +C ORTHOGONAL MATRIX Q SUCH THAT +C +C T +C (S + U*V )*Q +C +C IS AGAIN LOWER TRAPEZOIDAL. +C +C THIS SUBROUTINE DETERMINES Q AS THE PRODUCT OF 2*(N - 1) +C TRANSFORMATIONS +C +C GV(N-1)*...*GV(1)*GW(1)*...*GW(N-1) +C +C WHERE GV(I), GW(I) ARE GIVENS ROTATIONS IN THE (I,N) PLANE +C WHICH ELIMINATE ELEMENTS IN THE I-TH AND N-TH PLANES, +C RESPECTIVELY. Q ITSELF IS NOT ACCUMULATED, RATHER THE +C INFORMATION TO RECOVER THE GV, GW ROTATIONS IS RETURNED. +C +C THE SUBROUTINE STATEMENT IS +C +C SUBROUTINE R1UPDT(M,N,S,LS,U,V,W,SING) +C +C WHERE +C +C M IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER +C OF ROWS OF S. +C +C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER +C OF COLUMNS OF S. N MUST NOT EXCEED M. +C +C S IS AN ARRAY OF LENGTH LS. ON INPUT S MUST CONTAIN THE LOWER +C TRAPEZOIDAL MATRIX S STORED BY COLUMNS. ON OUTPUT S CONTAINS +C THE LOWER TRAPEZOIDAL MATRIX PRODUCED AS DESCRIBED ABOVE. +C +C LS IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN +C (N*(2*M-N+1))/2. +C +C U IS AN INPUT ARRAY OF LENGTH M WHICH MUST CONTAIN THE +C VECTOR U. +C +C V IS AN ARRAY OF LENGTH N. ON INPUT V MUST CONTAIN THE VECTOR +C V. ON OUTPUT V(I) CONTAINS THE INFORMATION NECESSARY TO +C RECOVER THE GIVENS ROTATION GV(I) DESCRIBED ABOVE. +C +C W IS AN OUTPUT ARRAY OF LENGTH M. W(I) CONTAINS INFORMATION +C NECESSARY TO RECOVER THE GIVENS ROTATION GW(I) DESCRIBED +C ABOVE. +C +C SING IS A LOGICAL OUTPUT VARIABLE. SING IS SET TRUE IF ANY +C OF THE DIAGONAL ELEMENTS OF THE OUTPUT S ARE ZERO. OTHERWISE +C SING IS SET FALSE. +C +C SUBPROGRAMS CALLED +C +C MINPACK-SUPPLIED ... DPMPAR +C +C FORTRAN-SUPPLIED ... DABS,DSQRT +C +C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. +C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE, +C JOHN L. NAZARETH +C +C ********** + INTEGER I,J,JJ,L,NMJ,NM1 + DOUBLE PRECISION COS,COTAN,GIANT,ONE,P5,P25,SIN,TAN,TAU,TEMP, + * ZERO + DOUBLE PRECISION DPMPAR + DATA ONE,P5,P25,ZERO /1.0D0,5.0D-1,2.5D-1,0.0D0/ +C +C GIANT IS THE LARGEST MAGNITUDE. +C + GIANT = DPMPAR(3) +C +C INITIALIZE THE DIAGONAL ELEMENT POINTER. +C + JJ = (N*(2*M - N + 1))/2 - (M - N) +C +C MOVE THE NONTRIVIAL PART OF THE LAST COLUMN OF S INTO W. +C + L = JJ + DO 10 I = N, M + W(I) = S(L) + L = L + 1 + 10 CONTINUE +C +C ROTATE THE VECTOR V INTO A MULTIPLE OF THE N-TH UNIT VECTOR +C IN SUCH A WAY THAT A SPIKE IS INTRODUCED INTO W. +C + NM1 = N - 1 + IF (NM1 .LT. 1) GO TO 70 + DO 60 NMJ = 1, NM1 + J = N - NMJ + JJ = JJ - (M - J + 1) + W(J) = ZERO + IF (V(J) .EQ. ZERO) GO TO 50 +C +C DETERMINE A GIVENS ROTATION WHICH ELIMINATES THE +C J-TH ELEMENT OF V. +C + IF (DABS(V(N)) .GE. DABS(V(J))) GO TO 20 + COTAN = V(N)/V(J) + SIN = P5/DSQRT(P25+P25*COTAN**2) + COS = SIN*COTAN + TAU = ONE + IF (DABS(COS)*GIANT .GT. ONE) TAU = ONE/COS + GO TO 30 + 20 CONTINUE + TAN = V(J)/V(N) + COS = P5/DSQRT(P25+P25*TAN**2) + SIN = COS*TAN + TAU = SIN + 30 CONTINUE +C +C APPLY THE TRANSFORMATION TO V AND STORE THE INFORMATION +C NECESSARY TO RECOVER THE GIVENS ROTATION. +C + V(N) = SIN*V(J) + COS*V(N) + V(J) = TAU +C +C APPLY THE TRANSFORMATION TO S AND EXTEND THE SPIKE IN W. +C + L = JJ + DO 40 I = J, M + TEMP = COS*S(L) - SIN*W(I) + W(I) = SIN*S(L) + COS*W(I) + S(L) = TEMP + L = L + 1 + 40 CONTINUE + 50 CONTINUE + 60 CONTINUE + 70 CONTINUE +C +C ADD THE SPIKE FROM THE RANK 1 UPDATE TO W. +C + DO 80 I = 1, M + W(I) = W(I) + V(N)*U(I) + 80 CONTINUE +C +C ELIMINATE THE SPIKE. +C + SING = .FALSE. + IF (NM1 .LT. 1) GO TO 140 + DO 130 J = 1, NM1 + IF (W(J) .EQ. ZERO) GO TO 120 +C +C DETERMINE A GIVENS ROTATION WHICH ELIMINATES THE +C J-TH ELEMENT OF THE SPIKE. +C + IF (DABS(S(JJ)) .GE. DABS(W(J))) GO TO 90 + COTAN = S(JJ)/W(J) + SIN = P5/DSQRT(P25+P25*COTAN**2) + COS = SIN*COTAN + TAU = ONE + IF (DABS(COS)*GIANT .GT. ONE) TAU = ONE/COS + GO TO 100 + 90 CONTINUE + TAN = W(J)/S(JJ) + COS = P5/DSQRT(P25+P25*TAN**2) + SIN = COS*TAN + TAU = SIN + 100 CONTINUE +C +C APPLY THE TRANSFORMATION TO S AND REDUCE THE SPIKE IN W. +C + L = JJ + DO 110 I = J, M + TEMP = COS*S(L) + SIN*W(I) + W(I) = -SIN*S(L) + COS*W(I) + S(L) = TEMP + L = L + 1 + 110 CONTINUE +C +C STORE THE INFORMATION NECESSARY TO RECOVER THE +C GIVENS ROTATION. +C + W(J) = TAU + 120 CONTINUE +C +C TEST FOR ZERO DIAGONAL ELEMENTS IN THE OUTPUT S. +C + IF (S(JJ) .EQ. ZERO) SING = .TRUE. + JJ = JJ + (M - J + 1) + 130 CONTINUE + 140 CONTINUE +C +C MOVE W BACK INTO THE LAST COLUMN OF THE OUTPUT S. +C + L = JJ + DO 150 I = N, M + S(L) = W(I) + L = L + 1 + 150 CONTINUE + IF (S(JJ) .EQ. ZERO) SING = .TRUE. + RETURN +C +C LAST CARD OF SUBROUTINE R1UPDT. +C + END diff --git a/ex/file06 b/ex/file06 new file mode 100644 index 0000000..b9da052 --- /dev/null +++ b/ex/file06 @@ -0,0 +1,3528 @@ +1 +0 Page +0 Documentation for MINPACK subroutine HYBRD1 +0 Double precision version +0 Argonne National Laboratory +0 Burton S. Garbow, Kenneth E. Hillstrom, Jorge J. More +0 March 1980 +0 + 1. Purpose. +0 The purpose of HYBRD1 is to find a zero of a system of N non- + linear functions in N variables by a modification of the Powell + hybrid method. This is done by using the more general nonlinea + equation solver HYBRD. The user must provide a subroutine whic + calculates the functions. The Jacobian is then calculated by a + forward-difference approximation. +0 + 2. Subroutine and type statements. +0 SUBROUTINE HYBRD1(FCN,N,X,FVEC,TOL,INFO,WA,LWA) + INTEGER N,INFO,LWA + DOUBLE PRECISION TOL + DOUBLE PRECISION X(N),FVEC(N),WA(LWA) + EXTERNAL FCN +0 + 3. Parameters. +0 Parameters designated as input parameters must be specified on + entry to HYBRD1 and are not changed on exit, while parameters + designated as output parameters need not be specified on entry + and are set to appropriate values on exit from HYBRD1. +0 FCN is the name of the user-supplied subroutine which calculate + the functions. FCN must be declared in an EXTERNAL statement + in the user calling program, and should be written as follows +0 SUBROUTINE FCN(N,X,FVEC,IFLAG) + INTEGER N,IFLAG + DOUBLE PRECISION X(N),FVEC(N) + ---------- + CALCULATE THE FUNCTIONS AT X AND + RETURN THIS VECTOR IN FVEC. + ---------- + RETURN + END +0 The value of IFLAG should not be changed by FCN unless the + user wants to terminate execution of HYBRD1. In this case se + IFLAG to a negative integer. +1 +0 Page +0 N is a positive integer input variable set to the number of + functions and variables. +0 X is an array of length N. On input X must contain an initial + estimate of the solution vector. On output X contains the + final estimate of the solution vector. +0 FVEC is an output array of length N which contains the function + evaluated at the output X. +0 TOL is a nonnegative input variable. Termination occurs when + the algorithm estimates that the relative error between X and + the solution is at most TOL. Section 4 contains more details + about TOL. +0 INFO is an integer output variable. If the user has terminated + execution, INFO is set to the (negative) value of IFLAG. See + description of FCN. Otherwise, INFO is set as follows. +0 INFO = 0 Improper input parameters. +0 INFO = 1 Algorithm estimates that the relative error between + X and the solution is at most TOL. +0 INFO = 2 Number of calls to FCN has reached or exceeded + 200*(N+1). +0 INFO = 3 TOL is too small. No further improvement in the + approximate solution X is possible. +0 INFO = 4 Iteration is not making good progress. +0 Sections 4 and 5 contain more details about INFO. +0 WA is a work array of length LWA. +0 LWA is a positive integer input variable not less than + (N*(3*N+13))/2. +0 + 4. Successful completion. +0 The accuracy of HYBRD1 is controlled by the convergence parame- + ter TOL. This parameter is used in a test which makes a compar + ison between the approximation X and a solution XSOL. HYBRD1 + terminates when the test is satisfied. If TOL is less than the + machine precision (as defined by the MINPACK function + DPMPAR(1)), then HYBRD1 only attempts to satisfy the test + defined by the machine precision. Further progress is not usu- + ally possible. Unless high precision solutions are required, + the recommended value for TOL is the square root of the machine + precision. +0 The test assumes that the functions are reasonably well behaved +1 +0 Page +0 If this condition is not satisfied, then HYBRD1 may incorrectly + indicate convergence. The validity of the answer can be + checked, for example, by rerunning HYBRD1 with a tighter toler- + ance. +0 Convergence test. If ENORM(Z) denotes the Euclidean norm of a + vector Z, then this test attempts to guarantee that +0 ENORM(X-XSOL) .LE. TOL*ENORM(XSOL). +0 If this condition is satisfied with TOL = 10**(-K), then the + larger components of X have K significant decimal digits and + INFO is set to 1. There is a danger that the smaller compo- + nents of X may have large relative errors, but the fast rate + of convergence of HYBRD1 usually avoids this possibility. +0 + 5. Unsuccessful completion. +0 Unsuccessful termination of HYBRD1 can be due to improper input + parameters, arithmetic interrupts, an excessive number of func- + tion evaluations, errors in the functions, or lack of good prog + ress. +0 Improper input parameters. INFO is set to 0 if N .LE. 0, or + TOL .LT. 0.D0, or LWA .LT. (N*(3*N+13))/2. +0 Arithmetic interrupts. If these interrupts occur in the FCN + subroutine during an early stage of the computation, they may + be caused by an unacceptable choice of X by HYBRD1. In this + case, it may be possible to remedy the situation by not evalu + ating the functions here, but instead setting the components + of FVEC to numbers that exceed those in the initial FVEC, + thereby indirectly reducing the step length. The step length + can be more directly controlled by using instead HYBRD, which + includes in its calling sequence the step-length- governing + parameter FACTOR. +0 Excessive number of function evaluations. If the number of + calls to FCN reaches 200*(N+1), then this indicates that the + routine is converging very slowly as measured by the progress + of FVEC, and INFO is set to 2. This situation should be unu- + sual because, as indicated below, lack of good progress is + usually diagnosed earlier by HYBRD1, causing termination with + INFO = 4. +0 Errors in the functions. The choice of step length in the for- + ward-difference approximation to the Jacobian assumes that th + relative errors in the functions are of the order of the + machine precision. If this is not the case, HYBRD1 may fail + (usually with INFO = 4). The user should then use HYBRD + instead, or one of the programs which require the analytic + Jacobian (HYBRJ1 and HYBRJ). +1 +0 Page +0 Lack of good progress. HYBRD1 searches for a zero of the syste + by minimizing the sum of the squares of the functions. In so + doing, it can become trapped in a region where the minimum + does not correspond to a zero of the system and, in this situ + ation, the iteration eventually fails to make good progress. + In particular, this will happen if the system does not have a + zero. If the system has a zero, rerunning HYBRD1 from a dif- + ferent starting point may be helpful. +0 + 6. Characteristics of the algorithm. +0 HYBRD1 is a modification of the Powell hybrid method. Two of + its main characteristics involve the choice of the correction a + a convex combination of the Newton and scaled gradient direc- + tions, and the updating of the Jacobian by the rank-1 method of + Broyden. The choice of the correction guarantees (under reason + able conditions) global convergence for starting points far fro + the solution and a fast rate of convergence. The Jacobian is + approximated by forward differences at the starting point, but + forward differences are not used again until the rank-1 method + fails to produce satisfactory progress. +0 Timing. The time required by HYBRD1 to solve a given problem + depends on N, the behavior of the functions, the accuracy + requested, and the starting point. The number of arithmetic + operations needed by HYBRD1 is about 11.5*(N**2) to process + each call to FCN. Unless FCN can be evaluated quickly, the + timing of HYBRD1 will be strongly influenced by the time spen + in FCN. +0 Storage. HYBRD1 requires (3*N**2 + 17*N)/2 double precision + storage locations, in addition to the storage required by the + program. There are no internally declared storage arrays. +0 + 7. Subprograms required. +0 USER-supplied ...... FCN +0 MINPACK-supplied ... DOGLEG,DPMPAR,ENORM,FDJAC1,HYBRD, + QFORM,QRFAC,R1MPYQ,R1UPDT +0 FORTRAN-supplied ... DABS,DMAX1,DMIN1,DSQRT,MIN0,MOD +0 + 8. References. +0 M. J. D. Powell, A Hybrid Method for Nonlinear Equations. + Numerical Methods for Nonlinear Algebraic Equations, + P. Rabinowitz, editor. Gordon and Breach, 1970. +0 + 9. Example. +1 +0 Page +0 The problem is to determine the values of x(1), x(2), ..., x(9) + which solve the system of tridiagonal equations +0 (3-2*x(1))*x(1) -2*x(2) = -1 + -x(i-1) + (3-2*x(i))*x(i) -2*x(i+1) = -1, i=2-8 + -x(8) + (3-2*x(9))*x(9) = -1 +0 C ********** + C + C DRIVER FOR HYBRD1 EXAMPLE. + C DOUBLE PRECISION VERSION + C + C ********** + INTEGER J,N,INFO,LWA,NWRITE + DOUBLE PRECISION TOL,FNORM + DOUBLE PRECISION X(9),FVEC(9),WA(180) + DOUBLE PRECISION ENORM,DPMPAR + EXTERNAL FCN + C + C LOGICAL OUTPUT UNIT IS ASSUMED TO BE NUMBER 6. + C + DATA NWRITE /6/ + C + N = 9 + C + C THE FOLLOWING STARTING VALUES PROVIDE A ROUGH SOLUTION. + C + DO 10 J = 1, 9 + X(J) = -1.D0 + 10 CONTINUE + C + LWA = 180 + C + C SET TOL TO THE SQUARE ROOT OF THE MACHINE PRECISION. + C UNLESS HIGH PRECISION SOLUTIONS ARE REQUIRED, + C THIS IS THE RECOMMENDED SETTING. + C + TOL = DSQRT(DPMPAR(1)) + C + CALL HYBRD1(FCN,N,X,FVEC,TOL,INFO,WA,LWA) + FNORM = ENORM(N,FVEC) + WRITE (NWRITE,1000) FNORM,INFO,(X(J),J=1,N) + STOP + 1000 FORMAT (5X,31H FINAL L2 NORM OF THE RESIDUALS,D15.7 // + * 5X,15H EXIT PARAMETER,16X,I10 // + * 5X,27H FINAL APPROXIMATE SOLUTION // (5X,3D15.7)) + C + C LAST CARD OF DRIVER FOR HYBRD1 EXAMPLE. + C + END + SUBROUTINE FCN(N,X,FVEC,IFLAG) + INTEGER N,IFLAG + DOUBLE PRECISION X(N),FVEC(N) + C +1 +0 Page +0 C SUBROUTINE FCN FOR HYBRD1 EXAMPLE. + C + INTEGER K + DOUBLE PRECISION ONE,TEMP,TEMP1,TEMP2,THREE,TWO,ZERO + DATA ZERO,ONE,TWO,THREE /0.D0,1.D0,2.D0,3.D0/ + C + DO 10 K = 1, N + TEMP = (THREE - TWO*X(K))*X(K) + TEMP1 = ZERO + IF (K .NE. 1) TEMP1 = X(K-1) + TEMP2 = ZERO + IF (K .NE. N) TEMP2 = X(K+1) + FVEC(K) = TEMP - TEMP1 - TWO*TEMP2 + ONE + 10 CONTINUE + RETURN + C + C LAST CARD OF SUBROUTINE FCN. + C + END +0 Results obtained with different compilers or machines + may be slightly different. +0 FINAL L2 NORM OF THE RESIDUALS 0.1192636D-07 +0 EXIT PARAMETER 1 +0 FINAL APPROXIMATE SOLUTION +0 -0.5706545D+00 -0.6816283D+00 -0.7017325D+00 + -0.7042129D+00 -0.7013690D+00 -0.6918656D+00 + -0.6657920D+00 -0.5960342D+00 -0.4164121D+00 +1 +0 +1 +0 Page +0 Documentation for MINPACK subroutine HYBRD +0 Double precision version +0 Argonne National Laboratory +0 Burton S. Garbow, Kenneth E. Hillstrom, Jorge J. More +0 March 1980 +0 + 1. Purpose. +0 The purpose of HYBRD is to find a zero of a system of N non- + linear functions in N variables by a modification of the Powell + hybrid method. The user must provide a subroutine which calcu- + lates the functions. The Jacobian is then calculated by a for- + ward-difference approximation. +0 + 2. Subroutine and type statements. +0 SUBROUTINE HYBRD(FCN,N,X,FVEC,XTOL,MAXFEV,ML,MU,EPSFCN,DIAG, + * MODE,FACTOR,NPRINT,INFO,NFEV,FJAC,LDFJAC, + * R,LR,QTF,WA1,WA2,WA3,WA4) + INTEGER N,MAXFEV,ML,MU,MODE,NPRINT,INFO,NFEV,LDFJAC,LR + DOUBLE PRECISION XTOL,EPSFCN,FACTOR + DOUBLE PRECISION X(N),FVEC(N),DIAG(N),FJAC(LDFJAC,N),R(LR),QTF( + * WA1(N),WA2(N),WA3(N),WA4(N) + EXTERNAL FCN +0 + 3. Parameters. +0 Parameters designated as input parameters must be specified on + entry to HYBRD and are not changed on exit, while parameters + designated as output parameters need not be specified on entry + and are set to appropriate values on exit from HYBRD. +0 FCN is the name of the user-supplied subroutine which calculate + the functions. FCN must be declared in an EXTERNAL statement + in the user calling program, and should be written as follows +0 SUBROUTINE FCN(N,X,FVEC,IFLAG) + INTEGER N,IFLAG + DOUBLE PRECISION X(N),FVEC(N) + ---------- + CALCULATE THE FUNCTIONS AT X AND + RETURN THIS VECTOR IN FVEC. + ---------- + RETURN + END +0 The value of IFLAG should not be changed by FCN unless the +1 +0 Page +0 user wants to terminate execution of HYBRD. In this case set + IFLAG to a negative integer. +0 N is a positive integer input variable set to the number of + functions and variables. +0 X is an array of length N. On input X must contain an initial + estimate of the solution vector. On output X contains the + final estimate of the solution vector. +0 FVEC is an output array of length N which contains the function + evaluated at the output X. +0 XTOL is a nonnegative input variable. Termination occurs when + the relative error between two consecutive iterates is at mos + XTOL. Therefore, XTOL measures the relative error desired in + the approximate solution. Section 4 contains more details + about XTOL. +0 MAXFEV is a positive integer input variable. Termination occur + when the number of calls to FCN is at least MAXFEV by the end + of an iteration. +0 ML is a nonnegative integer input variable which specifies the + number of subdiagonals within the band of the Jacobian matrix + If the Jacobian is not banded, set ML to at least N - 1. +0 MU is a nonnegative integer input variable which specifies the + number of superdiagonals within the band of the Jacobian + matrix. If the Jacobian is not banded, set MU to at least + N - 1. +0 EPSFCN is an input variable used in determining a suitable step + for the forward-difference approximation. This approximation + assumes that the relative errors in the functions are of the + order of EPSFCN. If EPSFCN is less than the machine preci- + sion, it is assumed that the relative errors in the functions + are of the order of the machine precision. +0 DIAG is an array of length N. If MODE = 1 (see below), DIAG is + internally set. If MODE = 2, DIAG must contain positive + entries that serve as multiplicative scale factors for the + variables. +0 MODE is an integer input variable. If MODE = 1, the variables + will be scaled internally. If MODE = 2, the scaling is speci + fied by the input DIAG. Other values of MODE are equivalent + to MODE = 1. +0 FACTOR is a positive input variable used in determining the ini + tial step bound. This bound is set to the product of FACTOR + and the Euclidean norm of DIAG*X if nonzero, or else to FACTO + itself. In most cases FACTOR should lie in the interval + (.1,100.). 100. is a generally recommended value. +1 +0 Page +0 NPRINT is an integer input variable that enables controlled + printing of iterates if it is positive. In this case, FCN is + called with IFLAG = 0 at the beginning of the first iteration + and every NPRINT iterations thereafter and immediately prior + to return, with X and FVEC available for printing. If NPRINT + is not positive, no special calls of FCN with IFLAG = 0 are + made. +0 INFO is an integer output variable. If the user has terminated + execution, INFO is set to the (negative) value of IFLAG. See + description of FCN. Otherwise, INFO is set as follows. +0 INFO = 0 Improper input parameters. +0 INFO = 1 Relative error between two consecutive iterates is + at most XTOL. +0 INFO = 2 Number of calls to FCN has reached or exceeded + MAXFEV. +0 INFO = 3 XTOL is too small. No further improvement in the + approximate solution X is possible. +0 INFO = 4 Iteration is not making good progress, as measured + by the improvement from the last five Jacobian eval + uations. +0 INFO = 5 Iteration is not making good progress, as measured + by the improvement from the last ten iterations. +0 Sections 4 and 5 contain more details about INFO. +0 NFEV is an integer output variable set to the number of calls t + FCN. +0 FJAC is an output N by N array which contains the orthogonal + matrix Q produced by the QR factorization of the final approx + imate Jacobian. +0 LDFJAC is a positive integer input variable not less than N + which specifies the leading dimension of the array FJAC. +0 R is an output array of length LR which contains the upper + triangular matrix produced by the QR factorization of the + final approximate Jacobian, stored rowwise. +0 LR is a positive integer input variable not less than + (N*(N+1))/2. +0 QTF is an output array of length N which contains the vector + (Q transpose)*FVEC. +0 WA1, WA2, WA3, and WA4 are work arrays of length N. +1 +0 Page +0 + 4. Successful completion. +0 The accuracy of HYBRD is controlled by the convergence paramete + XTOL. This parameter is used in a test which makes a compariso + between the approximation X and a solution XSOL. HYBRD termi- + nates when the test is satisfied. If the convergence parameter + is less than the machine precision (as defined by the MINPACK + function DPMPAR(1)), then HYBRD only attempts to satisfy the + test defined by the machine precision. Further progress is not + usually possible. +0 The test assumes that the functions are reasonably well behaved + If this condition is not satisfied, then HYBRD may incorrectly + indicate convergence. The validity of the answer can be + checked, for example, by rerunning HYBRD with a tighter toler- + ance. +0 Convergence test. If ENORM(Z) denotes the Euclidean norm of a + vector Z and D is the diagonal matrix whose entries are + defined by the array DIAG, then this test attempts to guaran- + tee that +0 ENORM(D*(X-XSOL)) .LE. XTOL*ENORM(D*XSOL). +0 If this condition is satisfied with XTOL = 10**(-K), then the + larger components of D*X have K significant decimal digits an + INFO is set to 1. There is a danger that the smaller compo- + nents of D*X may have large relative errors, but the fast rat + of convergence of HYBRD usually avoids this possibility. + Unless high precision solutions are required, the recommended + value for XTOL is the square root of the machine precision. +0 + 5. Unsuccessful completion. +0 Unsuccessful termination of HYBRD can be due to improper input + parameters, arithmetic interrupts, an excessive number of func- + tion evaluations, or lack of good progress. +0 Improper input parameters. INFO is set to 0 if N .LE. 0, or + XTOL .LT. 0.D0, or MAXFEV .LE. 0, or ML .LT. 0, or MU .LT. 0, + or FACTOR .LE. 0.D0, or LDFJAC .LT. N, or LR .LT. (N*(N+1))/2 +0 Arithmetic interrupts. If these interrupts occur in the FCN + subroutine during an early stage of the computation, they may + be caused by an unacceptable choice of X by HYBRD. In this + case, it may be possible to remedy the situation by rerunning + HYBRD with a smaller value of FACTOR. +0 Excessive number of function evaluations. A reasonable value + for MAXFEV is 200*(N+1). If the number of calls to FCN + reaches MAXFEV, then this indicates that the routine is con- + verging very slowly as measured by the progress of FVEC, and +1 +0 Page +0 INFO is set to 2. This situation should be unusual because, + as indicated below, lack of good progress is usually diagnose + earlier by HYBRD, causing termination with INFO = 4 or + INFO = 5. +0 Lack of good progress. HYBRD searches for a zero of the system + by minimizing the sum of the squares of the functions. In so + doing, it can become trapped in a region where the minimum + does not correspond to a zero of the system and, in this situ + ation, the iteration eventually fails to make good progress. + In particular, this will happen if the system does not have a + zero. If the system has a zero, rerunning HYBRD from a dif- + ferent starting point may be helpful. +0 + 6. Characteristics of the algorithm. +0 HYBRD is a modification of the Powell hybrid method. Two of it + main characteristics involve the choice of the correction as a + convex combination of the Newton and scaled gradient directions + and the updating of the Jacobian by the rank-1 method of Broy- + den. The choice of the correction guarantees (under reasonable + conditions) global convergence for starting points far from the + solution and a fast rate of convergence. The Jacobian is + approximated by forward differences at the starting point, but + forward differences are not used again until the rank-1 method + fails to produce satisfactory progress. +0 Timing. The time required by HYBRD to solve a given problem + depends on N, the behavior of the functions, the accuracy + requested, and the starting point. The number of arithmetic + operations needed by HYBRD is about 11.5*(N**2) to process + each call to FCN. Unless FCN can be evaluated quickly, the + timing of HYBRD will be strongly influenced by the time spent + in FCN. +0 Storage. HYBRD requires (3*N**2 + 17*N)/2 double precision + storage locations, in addition to the storage required by the + program. There are no internally declared storage arrays. +0 + 7. Subprograms required. +0 USER-supplied ...... FCN +0 MINPACK-supplied ... DOGLEG,DPMPAR,ENORM,FDJAC1, + QFORM,QRFAC,R1MPYQ,R1UPDT +0 FORTRAN-supplied ... DABS,DMAX1,DMIN1,DSQRT,MIN0,MOD +0 + 8. References. +0 M. J. D. Powell, A Hybrid Method for Nonlinear Equations. +1 +0 Page +0 Numerical Methods for Nonlinear Algebraic Equations, + P. Rabinowitz, editor. Gordon and Breach, 1970. +0 + 9. Example. +0 The problem is to determine the values of x(1), x(2), ..., x(9) + which solve the system of tridiagonal equations +0 (3-2*x(1))*x(1) -2*x(2) = -1 + -x(i-1) + (3-2*x(i))*x(i) -2*x(i+1) = -1, i=2-8 + -x(8) + (3-2*x(9))*x(9) = -1 +0 C ********** + C + C DRIVER FOR HYBRD EXAMPLE. + C DOUBLE PRECISION VERSION + C + C ********** + INTEGER J,N,MAXFEV,ML,MU,MODE,NPRINT,INFO,NFEV,LDFJAC,LR,NWRITE + DOUBLE PRECISION XTOL,EPSFCN,FACTOR,FNORM + DOUBLE PRECISION X(9),FVEC(9),DIAG(9),FJAC(9,9),R(45),QTF(9), + * WA1(9),WA2(9),WA3(9),WA4(9) + DOUBLE PRECISION ENORM,DPMPAR + EXTERNAL FCN + C + C LOGICAL OUTPUT UNIT IS ASSUMED TO BE NUMBER 6. + C + DATA NWRITE /6/ + C + N = 9 + C + C THE FOLLOWING STARTING VALUES PROVIDE A ROUGH SOLUTION. + C + DO 10 J = 1, 9 + X(J) = -1.D0 + 10 CONTINUE + C + LDFJAC = 9 + LR = 45 + C + C SET XTOL TO THE SQUARE ROOT OF THE MACHINE PRECISION. + C UNLESS HIGH PRECISION SOLUTIONS ARE REQUIRED, + C THIS IS THE RECOMMENDED SETTING. + C + XTOL = DSQRT(DPMPAR(1)) + C + MAXFEV = 2000 + ML = 1 + MU = 1 + EPSFCN = 0.D0 + MODE = 2 + DO 20 J = 1, 9 + DIAG(J) = 1.D0 +1 +0 Page +0 20 CONTINUE + FACTOR = 1.D2 + NPRINT = 0 + C + CALL HYBRD(FCN,N,X,FVEC,XTOL,MAXFEV,ML,MU,EPSFCN,DIAG, + * MODE,FACTOR,NPRINT,INFO,NFEV,FJAC,LDFJAC, + * R,LR,QTF,WA1,WA2,WA3,WA4) + FNORM = ENORM(N,FVEC) + WRITE (NWRITE,1000) FNORM,NFEV,INFO,(X(J),J=1,N) + STOP + 1000 FORMAT (5X,31H FINAL L2 NORM OF THE RESIDUALS,D15.7 // + * 5X,31H NUMBER OF FUNCTION EVALUATIONS,I10 // + * 5X,15H EXIT PARAMETER,16X,I10 // + * 5X,27H FINAL APPROXIMATE SOLUTION // (5X,3D15.7)) + C + C LAST CARD OF DRIVER FOR HYBRD EXAMPLE. + C + END + SUBROUTINE FCN(N,X,FVEC,IFLAG) + INTEGER N,IFLAG + DOUBLE PRECISION X(N),FVEC(N) + C + C SUBROUTINE FCN FOR HYBRD EXAMPLE. + C + INTEGER K + DOUBLE PRECISION ONE,TEMP,TEMP1,TEMP2,THREE,TWO,ZERO + DATA ZERO,ONE,TWO,THREE /0.D0,1.D0,2.D0,3.D0/ + C + IF (IFLAG .NE. 0) GO TO 5 + C + C INSERT PRINT STATEMENTS HERE WHEN NPRINT IS POSITIVE. + C + RETURN + 5 CONTINUE + DO 10 K = 1, N + TEMP = (THREE - TWO*X(K))*X(K) + TEMP1 = ZERO + IF (K .NE. 1) TEMP1 = X(K-1) + TEMP2 = ZERO + IF (K .NE. N) TEMP2 = X(K+1) + FVEC(K) = TEMP - TEMP1 - TWO*TEMP2 + ONE + 10 CONTINUE + RETURN + C + C LAST CARD OF SUBROUTINE FCN. + C + END +0 Results obtained with different compilers or machines + may be slightly different. +0 FINAL L2 NORM OF THE RESIDUALS 0.1192636D-07 +0 NUMBER OF FUNCTION EVALUATIONS 14 +1 +0 Page +0 EXIT PARAMETER 1 +0 FINAL APPROXIMATE SOLUTION +0 -0.5706545D+00 -0.6816283D+00 -0.7017325D+00 + -0.7042129D+00 -0.7013690D+00 -0.6918656D+00 + -0.6657920D+00 -0.5960342D+00 -0.4164121D+00 +1 +0 +1 +0 Page +0 Documentation for MINPACK subroutine HYBRJ1 +0 Double precision version +0 Argonne National Laboratory +0 Burton S. Garbow, Kenneth E. Hillstrom, Jorge J. More +0 March 1980 +0 + 1. Purpose. +0 The purpose of HYBRJ1 is to find a zero of a system of N non- + linear functions in N variables by a modification of the Powell + hybrid method. This is done by using the more general nonlinea + equation solver HYBRJ. The user must provide a subroutine whic + calculates the functions and the Jacobian. +0 + 2. Subroutine and type statements. +0 SUBROUTINE HYBRJ1(FCN,N,X,FVEC,FJAC,LDFJAC,TOL,INFO,WA,LWA) + INTEGER N,LDFJAC,INFO,LWA + DOUBLE PRECISION TOL + DOUBLE PRECISION X(N),FVEC(N),FJAC(LDFJAC,N),WA(LWA) + EXTERNAL FCN +0 + 3. Parameters. +0 Parameters designated as input parameters must be specified on + entry to HYBRJ1 and are not changed on exit, while parameters + designated as output parameters need not be specified on entry + and are set to appropriate values on exit from HYBRJ1. +0 FCN is the name of the user-supplied subroutine which calculate + the functions and the Jacobian. FCN must be declared in an + EXTERNAL statement in the user calling program, and should be + written as follows. +0 SUBROUTINE FCN(N,X,FVEC,FJAC,LDFJAC,IFLAG) + INTEGER N,LDFJAC,IFLAG + DOUBLE PRECISION X(N),FVEC(N),FJAC(LDFJAC,N) + ---------- + IF IFLAG = 1 CALCULATE THE FUNCTIONS AT X AND + RETURN THIS VECTOR IN FVEC. DO NOT ALTER FJAC. + IF IFLAG = 2 CALCULATE THE JACOBIAN AT X AND + RETURN THIS MATRIX IN FJAC. DO NOT ALTER FVEC. + ---------- + RETURN + END +0 The value of IFLAG should not be changed by FCN unless the +1 +0 Page +0 user wants to terminate execution of HYBRJ1. In this case se + IFLAG to a negative integer. +0 N is a positive integer input variable set to the number of + functions and variables. +0 X is an array of length N. On input X must contain an initial + estimate of the solution vector. On output X contains the + final estimate of the solution vector. +0 FVEC is an output array of length N which contains the function + evaluated at the output X. +0 FJAC is an output N by N array which contains the orthogonal + matrix Q produced by the QR factorization of the final approx + imate Jacobian. Section 6 contains more details about the + approximation to the Jacobian. +0 LDFJAC is a positive integer input variable not less than N + which specifies the leading dimension of the array FJAC. +0 TOL is a nonnegative input variable. Termination occurs when + the algorithm estimates that the relative error between X and + the solution is at most TOL. Section 4 contains more details + about TOL. +0 INFO is an integer output variable. If the user has terminated + execution, INFO is set to the (negative) value of IFLAG. See + description of FCN. Otherwise, INFO is set as follows. +0 INFO = 0 Improper input parameters. +0 INFO = 1 Algorithm estimates that the relative error between + X and the solution is at most TOL. +0 INFO = 2 Number of calls to FCN with IFLAG = 1 has reached + 100*(N+1). +0 INFO = 3 TOL is too small. No further improvement in the + approximate solution X is possible. +0 INFO = 4 Iteration is not making good progress. +0 Sections 4 and 5 contain more details about INFO. +0 WA is a work array of length LWA. +0 LWA is a positive integer input variable not less than + (N*(N+13))/2. +0 + 4. Successful completion. +0 The accuracy of HYBRJ1 is controlled by the convergence +1 +0 Page +0 parameter TOL. This parameter is used in a test which makes a + comparison between the approximation X and a solution XSOL. + HYBRJ1 terminates when the test is satisfied. If TOL is less + than the machine precision (as defined by the MINPACK function + DPMPAR(1)), then HYBRJ1 only attempts to satisfy the test + defined by the machine precision. Further progress is not usu- + ally possible. Unless high precision solutions are required, + the recommended value for TOL is the square root of the machine + precision. +0 The test assumes that the functions and the Jacobian are coded + consistently, and that the functions are reasonably well + behaved. If these conditions are not satisfied, then HYBRJ1 ma + incorrectly indicate convergence. The coding of the Jacobian + can be checked by the MINPACK subroutine CHKDER. If the Jaco- + bian is coded correctly, then the validity of the answer can be + checked, for example, by rerunning HYBRJ1 with a tighter toler- + ance. +0 Convergence test. If ENORM(Z) denotes the Euclidean norm of a + vector Z, then this test attempts to guarantee that +0 ENORM(X-XSOL) .LE. TOL*ENORM(XSOL). +0 If this condition is satisfied with TOL = 10**(-K), then the + larger components of X have K significant decimal digits and + INFO is set to 1. There is a danger that the smaller compo- + nents of X may have large relative errors, but the fast rate + of convergence of HYBRJ1 usually avoids this possibility. +0 + 5. Unsuccessful completion. +0 Unsuccessful termination of HYBRJ1 can be due to improper input + parameters, arithmetic interrupts, an excessive number of func- + tion evaluations, or lack of good progress. +0 Improper input parameters. INFO is set to 0 if N .LE. 0, or + LDFJAC .LT. N, or TOL .LT. 0.D0, or LWA .LT. (N*(N+13))/2. +0 Arithmetic interrupts. If these interrupts occur in the FCN + subroutine during an early stage of the computation, they may + be caused by an unacceptable choice of X by HYBRJ1. In this + case, it may be possible to remedy the situation by not evalu + ating the functions here, but instead setting the components + of FVEC to numbers that exceed those in the initial FVEC, + thereby indirectly reducing the step length. The step length + can be more directly controlled by using instead HYBRJ, which + includes in its calling sequence the step-length- governing + parameter FACTOR. +0 Excessive number of function evaluations. If the number of + calls to FCN with IFLAG = 1 reaches 100*(N+1), then this indi + cates that the routine is converging very slowly as measured +1 +0 Page +0 by the progress of FVEC, and INFO is set to 2. This situatio + should be unusual because, as indicated below, lack of good + progress is usually diagnosed earlier by HYBRJ1, causing ter- + mination with INFO = 4. +0 Lack of good progress. HYBRJ1 searches for a zero of the syste + by minimizing the sum of the squares of the functions. In so + doing, it can become trapped in a region where the minimum + does not correspond to a zero of the system and, in this situ + ation, the iteration eventually fails to make good progress. + In particular, this will happen if the system does not have a + zero. If the system has a zero, rerunning HYBRJ1 from a dif- + ferent starting point may be helpful. +0 + 6. Characteristics of the algorithm. +0 HYBRJ1 is a modification of the Powell hybrid method. Two of + its main characteristics involve the choice of the correction a + a convex combination of the Newton and scaled gradient direc- + tions, and the updating of the Jacobian by the rank-1 method of + Broyden. The choice of the correction guarantees (under reason + able conditions) global convergence for starting points far fro + the solution and a fast rate of convergence. The Jacobian is + calculated at the starting point, but it is not recalculated + until the rank-1 method fails to produce satisfactory progress. +0 Timing. The time required by HYBRJ1 to solve a given problem + depends on N, the behavior of the functions, the accuracy + requested, and the starting point. The number of arithmetic + operations needed by HYBRJ1 is about 11.5*(N**2) to process + each evaluation of the functions (call to FCN with IFLAG = 1) + and 1.3*(N**3) to process each evaluation of the Jacobian + (call to FCN with IFLAG = 2). Unless FCN can be evaluated + quickly, the timing of HYBRJ1 will be strongly influenced by + the time spent in FCN. +0 Storage. HYBRJ1 requires (3*N**2 + 17*N)/2 double precision + storage locations, in addition to the storage required by the + program. There are no internally declared storage arrays. +0 + 7. Subprograms required. +0 USER-supplied ...... FCN +0 MINPACK-supplied ... DOGLEG,DPMPAR,ENORM,HYBRJ, + QFORM,QRFAC,R1MPYQ,R1UPDT +0 FORTRAN-supplied ... DABS,DMAX1,DMIN1,DSQRT,MIN0,MOD +0 + 8. References. +1 +0 Page +0 M. J. D. Powell, A Hybrid Method for Nonlinear Equations. + Numerical Methods for Nonlinear Algebraic Equations, + P. Rabinowitz, editor. Gordon and Breach, 1970. +0 + 9. Example. +0 The problem is to determine the values of x(1), x(2), ..., x(9) + which solve the system of tridiagonal equations +0 (3-2*x(1))*x(1) -2*x(2) = -1 + -x(i-1) + (3-2*x(i))*x(i) -2*x(i+1) = -1, i=2-8 + -x(8) + (3-2*x(9))*x(9) = -1 +0 C ********** + C + C DRIVER FOR HYBRJ1 EXAMPLE. + C DOUBLE PRECISION VERSION + C + C ********** + INTEGER J,N,LDFJAC,INFO,LWA,NWRITE + DOUBLE PRECISION TOL,FNORM + DOUBLE PRECISION X(9),FVEC(9),FJAC(9,9),WA(99) + DOUBLE PRECISION ENORM,DPMPAR + EXTERNAL FCN + C + C LOGICAL OUTPUT UNIT IS ASSUMED TO BE NUMBER 6. + C + DATA NWRITE /6/ + C + N = 9 + C + C THE FOLLOWING STARTING VALUES PROVIDE A ROUGH SOLUTION. + C + DO 10 J = 1, 9 + X(J) = -1.D0 + 10 CONTINUE + C + LDFJAC = 9 + LWA = 99 + C + C SET TOL TO THE SQUARE ROOT OF THE MACHINE PRECISION. + C UNLESS HIGH PRECISION SOLUTIONS ARE REQUIRED, + C THIS IS THE RECOMMENDED SETTING. + C + TOL = DSQRT(DPMPAR(1)) + C + CALL HYBRJ1(FCN,N,X,FVEC,FJAC,LDFJAC,TOL,INFO,WA,LWA) + FNORM = ENORM(N,FVEC) + WRITE (NWRITE,1000) FNORM,INFO,(X(J),J=1,N) + STOP + 1000 FORMAT (5X,31H FINAL L2 NORM OF THE RESIDUALS,D15.7 // + * 5X,15H EXIT PARAMETER,16X,I10 // + * 5X,27H FINAL APPROXIMATE SOLUTION // (5X,3D15.7)) +1 +0 Page +0 C + C LAST CARD OF DRIVER FOR HYBRJ1 EXAMPLE. + C + END + SUBROUTINE FCN(N,X,FVEC,FJAC,LDFJAC,IFLAG) + INTEGER N,LDFJAC,IFLAG + DOUBLE PRECISION X(N),FVEC(N),FJAC(LDFJAC,N) + C + C SUBROUTINE FCN FOR HYBRJ1 EXAMPLE. + C + INTEGER J,K + DOUBLE PRECISION ONE,TEMP,TEMP1,TEMP2,THREE,TWO,ZERO + DATA ZERO,ONE,TWO,THREE,FOUR /0.D0,1.D0,2.D0,3.D0,4.D0/ + C + IF (IFLAG .EQ. 2) GO TO 20 + DO 10 K = 1, N + TEMP = (THREE - TWO*X(K))*X(K) + TEMP1 = ZERO + IF (K .NE. 1) TEMP1 = X(K-1) + TEMP2 = ZERO + IF (K .NE. N) TEMP2 = X(K+1) + FVEC(K) = TEMP - TEMP1 - TWO*TEMP2 + ONE + 10 CONTINUE + GO TO 50 + 20 CONTINUE + DO 40 K = 1, N + DO 30 J = 1, N + FJAC(K,J) = ZERO + 30 CONTINUE + FJAC(K,K) = THREE - FOUR*X(K) + IF (K .NE. 1) FJAC(K,K-1) = -ONE + IF (K .NE. N) FJAC(K,K+1) = -TWO + 40 CONTINUE + 50 CONTINUE + RETURN + C + C LAST CARD OF SUBROUTINE FCN. + C + END +0 Results obtained with different compilers or machines + may be slightly different. +0 FINAL L2 NORM OF THE RESIDUALS 0.1192636D-07 +0 EXIT PARAMETER 1 +0 FINAL APPROXIMATE SOLUTION +0 -0.5706545D+00 -0.6816283D+00 -0.7017325D+00 + -0.7042129D+00 -0.7013690D+00 -0.6918656D+00 + -0.6657920D+00 -0.5960342D+00 -0.4164121D+00 +1 +0 +1 +0 Page +0 Documentation for MINPACK subroutine HYBRJ +0 Double precision version +0 Argonne National Laboratory +0 Burton S. Garbow, Kenneth E. Hillstrom, Jorge J. More +0 March 1980 +0 + 1. Purpose. +0 The purpose of HYBRJ is to find a zero of a system of N non- + linear functions in N variables by a modification of the Powell + hybrid method. The user must provide a subroutine which calcu- + lates the functions and the Jacobian. +0 + 2. Subroutine and type statements. +0 SUBROUTINE HYBRJ(FCN,N,X,FVEC,FJAC,LDFJAC,XTOL,MAXFEV,DIAG, + * MODE,FACTOR,NPRINT,INFO,NFEV,NJEV,R,LR,QTF, + * WA1,WA2,WA3,WA4) + INTEGER N,LDFJAC,MAXFEV,MODE,NPRINT,INFO,NFEV,NJEV,LR + DOUBLE PRECISION XTOL,FACTOR + DOUBLE PRECISION X(N),FVEC(N),FJAC(LDFJAC,N),DIAG(N),R(LR),QTF( + * WA1(N),WA2(N),WA3(N),WA4(N) +0 + 3. Parameters. +0 Parameters designated as input parameters must be specified on + entry to HYBRJ and are not changed on exit, while parameters + designated as output parameters need not be specified on entry + and are set to appropriate values on exit from HYBRJ. +0 FCN is the name of the user-supplied subroutine which calculate + the functions and the Jacobian. FCN must be declared in an + EXTERNAL statement in the user calling program, and should be + written as follows. +0 SUBROUTINE FCN(N,X,FVEC,FJAC,LDFJAC,IFLAG) + INTEGER N,LDFJAC,IFLAG + DOUBLE PRECISION X(N),FVEC(N),FJAC(LDFJAC,N) + ---------- + IF IFLAG = 1 CALCULATE THE FUNCTIONS AT X AND + RETURN THIS VECTOR IN FVEC. DO NOT ALTER FJAC. + IF IFLAG = 2 CALCULATE THE JACOBIAN AT X AND + RETURN THIS MATRIX IN FJAC. DO NOT ALTER FVEC. + ---------- + RETURN + END +1 +0 Page +0 The value of IFLAG should not be changed by FCN unless the + user wants to terminate execution of HYBRJ. In this case set + IFLAG to a negative integer. +0 N is a positive integer input variable set to the number of + functions and variables. +0 X is an array of length N. On input X must contain an initial + estimate of the solution vector. On output X contains the + final estimate of the solution vector. +0 FVEC is an output array of length N which contains the function + evaluated at the output X. +0 FJAC is an output N by N array which contains the orthogonal + matrix Q produced by the QR factorization of the final approx + imate Jacobian. Section 6 contains more details about the + approximation to the Jacobian. +0 LDFJAC is a positive integer input variable not less than N + which specifies the leading dimension of the array FJAC. +0 XTOL is a nonnegative input variable. Termination occurs when + the relative error between two consecutive iterates is at mos + XTOL. Therefore, XTOL measures the relative error desired in + the approximate solution. Section 4 contains more details + about XTOL. +0 MAXFEV is a positive integer input variable. Termination occur + when the number of calls to FCN with IFLAG = 1 has reached + MAXFEV. +0 DIAG is an array of length N. If MODE = 1 (see below), DIAG is + internally set. If MODE = 2, DIAG must contain positive + entries that serve as multiplicative scale factors for the + variables. +0 MODE is an integer input variable. If MODE = 1, the variables + will be scaled internally. If MODE = 2, the scaling is speci + fied by the input DIAG. Other values of MODE are equivalent + to MODE = 1. +0 FACTOR is a positive input variable used in determining the ini + tial step bound. This bound is set to the product of FACTOR + and the Euclidean norm of DIAG*X if nonzero, or else to FACTO + itself. In most cases FACTOR should lie in the interval + (.1,100.). 100. is a generally recommended value. +0 NPRINT is an integer input variable that enables controlled + printing of iterates if it is positive. In this case, FCN is + called with IFLAG = 0 at the beginning of the first iteration + and every NPRINT iterations thereafter and immediately prior + to return, with X and FVEC available for printing. FVEC and + FJAC should not be altered. If NPRINT is not positive, no +1 +0 Page +0 special calls of FCN with IFLAG = 0 are made. +0 INFO is an integer output variable. If the user has terminated + execution, INFO is set to the (negative) value of IFLAG. See + description of FCN. Otherwise, INFO is set as follows. +0 INFO = 0 Improper input parameters. +0 INFO = 1 Relative error between two consecutive iterates is + at most XTOL. +0 INFO = 2 Number of calls to FCN with IFLAG = 1 has reached + MAXFEV. +0 INFO = 3 XTOL is too small. No further improvement in the + approximate solution X is possible. +0 INFO = 4 Iteration is not making good progress, as measured + by the improvement from the last five Jacobian eval + uations. +0 INFO = 5 Iteration is not making good progress, as measured + by the improvement from the last ten iterations. +0 Sections 4 and 5 contain more details about INFO. +0 NFEV is an integer output variable set to the number of calls t + FCN with IFLAG = 1. +0 NJEV is an integer output variable set to the number of calls t + FCN with IFLAG = 2. +0 R is an output array of length LR which contains the upper + triangular matrix produced by the QR factorization of the + final approximate Jacobian, stored rowwise. +0 LR is a positive integer input variable not less than + (N*(N+1))/2. +0 QTF is an output array of length N which contains the vector + (Q transpose)*FVEC. +0 WA1, WA2, WA3, and WA4 are work arrays of length N. +0 + 4. Successful completion. +0 The accuracy of HYBRJ is controlled by the convergence paramete + XTOL. This parameter is used in a test which makes a compariso + between the approximation X and a solution XSOL. HYBRJ termi- + nates when the test is satisfied. If the convergence parameter + is less than the machine precision (as defined by the MINPACK + function DPMPAR(1)), then HYBRJ only attempts to satisfy the + test defined by the machine precision. Further progress is not +1 +0 Page +0 usually possible. +0 The test assumes that the functions and the Jacobian are coded + consistently, and that the functions are reasonably well + behaved. If these conditions are not satisfied, then HYBRJ may + incorrectly indicate convergence. The coding of the Jacobian + can be checked by the MINPACK subroutine CHKDER. If the Jaco- + bian is coded correctly, then the validity of the answer can be + checked, for example, by rerunning HYBRJ with a tighter toler- + ance. +0 Convergence test. If ENORM(Z) denotes the Euclidean norm of a + vector Z and D is the diagonal matrix whose entries are + defined by the array DIAG, then this test attempts to guaran- + tee that +0 ENORM(D*(X-XSOL)) .LE. XTOL*ENORM(D*XSOL). +0 If this condition is satisfied with XTOL = 10**(-K), then the + larger components of D*X have K significant decimal digits an + INFO is set to 1. There is a danger that the smaller compo- + nents of D*X may have large relative errors, but the fast rat + of convergence of HYBRJ usually avoids this possibility. + Unless high precision solutions are required, the recommended + value for XTOL is the square root of the machine precision. +0 + 5. Unsuccessful completion. +0 Unsuccessful termination of HYBRJ can be due to improper input + parameters, arithmetic interrupts, an excessive number of func- + tion evaluations, or lack of good progress. +0 Improper input parameters. INFO is set to 0 if N .LE. 0, or + LDFJAC .LT. N, or XTOL .LT. 0.D0, or MAXFEV .LE. 0, or + FACTOR .LE. 0.D0, or LR .LT. (N*(N+1))/2. +0 Arithmetic interrupts. If these interrupts occur in the FCN + subroutine during an early stage of the computation, they may + be caused by an unacceptable choice of X by HYBRJ. In this + case, it may be possible to remedy the situation by rerunning + HYBRJ with a smaller value of FACTOR. +0 Excessive number of function evaluations. A reasonable value + for MAXFEV is 100*(N+1). If the number of calls to FCN with + IFLAG = 1 reaches MAXFEV, then this indicates that the routin + is converging very slowly as measured by the progress of FVEC + and INFO is set to 2. This situation should be unusual + because, as indicated below, lack of good progress is usually + diagnosed earlier by HYBRJ, causing termination with INFO = 4 + or INFO = 5. +0 Lack of good progress. HYBRJ searches for a zero of the system + by minimizing the sum of the squares of the functions. In so +1 +0 Page +0 doing, it can become trapped in a region where the minimum + does not correspond to a zero of the system and, in this situ + ation, the iteration eventually fails to make good progress. + In particular, this will happen if the system does not have a + zero. If the system has a zero, rerunning HYBRJ from a dif- + ferent starting point may be helpful. +0 + 6. Characteristics of the algorithm. +0 HYBRJ is a modification of the Powell hybrid method. Two of it + main characteristics involve the choice of the correction as a + convex combination of the Newton and scaled gradient directions + and the updating of the Jacobian by the rank-1 method of Broy- + den. The choice of the correction guarantees (under reasonable + conditions) global convergence for starting points far from the + solution and a fast rate of convergence. The Jacobian is calcu + lated at the starting point, but it is not recalculated until + the rank-1 method fails to produce satisfactory progress. +0 Timing. The time required by HYBRJ to solve a given problem + depends on N, the behavior of the functions, the accuracy + requested, and the starting point. The number of arithmetic + operations needed by HYBRJ is about 11.5*(N**2) to process + each evaluation of the functions (call to FCN with IFLAG = 1) + and 1.3*(N**3) to process each evaluation of the Jacobian + (call to FCN with IFLAG = 2). Unless FCN can be evaluated + quickly, the timing of HYBRJ will be strongly influenced by + the time spent in FCN. +0 Storage. HYBRJ requires (3*N**2 + 17*N)/2 double precision + storage locations, in addition to the storage required by the + program. There are no internally declared storage arrays. +0 + 7. Subprograms required. +0 USER-supplied ...... FCN +0 MINPACK-supplied ... DOGLEG,DPMPAR,ENORM, + QFORM,QRFAC,R1MPYQ,R1UPDT +0 FORTRAN-supplied ... DABS,DMAX1,DMIN1,DSQRT,MIN0,MOD +0 + 8. References. +0 M. J. D. Powell, A Hybrid Method for Nonlinear Equations. + Numerical Methods for Nonlinear Algebraic Equations, + P. Rabinowitz, editor. Gordon and Breach, 1970. +0 + 9. Example. +1 +0 Page +0 The problem is to determine the values of x(1), x(2), ..., x(9) + which solve the system of tridiagonal equations +0 (3-2*x(1))*x(1) -2*x(2) = -1 + -x(i-1) + (3-2*x(i))*x(i) -2*x(i+1) = -1, i=2-8 + -x(8) + (3-2*x(9))*x(9) = -1 +0 C ********** + C + C DRIVER FOR HYBRJ EXAMPLE. + C DOUBLE PRECISION VERSION + C + C ********** + INTEGER J,N,LDFJAC,MAXFEV,MODE,NPRINT,INFO,NFEV,NJEV,LR,NWRITE + DOUBLE PRECISION XTOL,FACTOR,FNORM + DOUBLE PRECISION X(9),FVEC(9),FJAC(9,9),DIAG(9),R(45),QTF(9), + * WA1(9),WA2(9),WA3(9),WA4(9) + DOUBLE PRECISION ENORM,DPMPAR + EXTERNAL FCN + C + C LOGICAL OUTPUT UNIT IS ASSUMED TO BE NUMBER 6. + C + DATA NWRITE /6/ + C + N = 9 + C + C THE FOLLOWING STARTING VALUES PROVIDE A ROUGH SOLUTION. + C + DO 10 J = 1, 9 + X(J) = -1.D0 + 10 CONTINUE + C + LDFJAC = 9 + LR = 45 + C + C SET XTOL TO THE SQUARE ROOT OF THE MACHINE PRECISION. + C UNLESS HIGH PRECISION SOLUTIONS ARE REQUIRED, + C THIS IS THE RECOMMENDED SETTING. + C + XTOL = DSQRT(DPMPAR(1)) + C + MAXFEV = 1000 + MODE = 2 + DO 20 J = 1, 9 + DIAG(J) = 1.D0 + 20 CONTINUE + FACTOR = 1.D2 + NPRINT = 0 + C + CALL HYBRJ(FCN,N,X,FVEC,FJAC,LDFJAC,XTOL,MAXFEV,DIAG, + * MODE,FACTOR,NPRINT,INFO,NFEV,NJEV,R,LR,QTF, + * WA1,WA2,WA3,WA4) + FNORM = ENORM(N,FVEC) + WRITE (NWRITE,1000) FNORM,NFEV,NJEV,INFO,(X(J),J=1,N) +1 +0 Page +0 STOP + 1000 FORMAT (5X,31H FINAL L2 NORM OF THE RESIDUALS,D15.7 // + * 5X,31H NUMBER OF FUNCTION EVALUATIONS,I10 // + * 5X,31H NUMBER OF JACOBIAN EVALUATIONS,I10 // + * 5X,15H EXIT PARAMETER,16X,I10 // + * 5X,27H FINAL APPROXIMATE SOLUTION // (5X,3D15.7)) + C + C LAST CARD OF DRIVER FOR HYBRJ EXAMPLE. + C + END + SUBROUTINE FCN(N,X,FVEC,FJAC,LDFJAC,IFLAG) + INTEGER N,LDFJAC,IFLAG + DOUBLE PRECISION X(N),FVEC(N),FJAC(LDFJAC,N) + C + C SUBROUTINE FCN FOR HYBRJ EXAMPLE. + C + INTEGER J,K + DOUBLE PRECISION ONE,TEMP,TEMP1,TEMP2,THREE,TWO,ZERO + DATA ZERO,ONE,TWO,THREE,FOUR /0.D0,1.D0,2.D0,3.D0,4.D0/ + C + IF (IFLAG .NE. 0) GO TO 5 + C + C INSERT PRINT STATEMENTS HERE WHEN NPRINT IS POSITIVE. + C + RETURN + 5 CONTINUE + IF (IFLAG .EQ. 2) GO TO 20 + DO 10 K = 1, N + TEMP = (THREE - TWO*X(K))*X(K) + TEMP1 = ZERO + IF (K .NE. 1) TEMP1 = X(K-1) + TEMP2 = ZERO + IF (K .NE. N) TEMP2 = X(K+1) + FVEC(K) = TEMP - TEMP1 - TWO*TEMP2 + ONE + 10 CONTINUE + GO TO 50 + 20 CONTINUE + DO 40 K = 1, N + DO 30 J = 1, N + FJAC(K,J) = ZERO + 30 CONTINUE + FJAC(K,K) = THREE - FOUR*X(K) + IF (K .NE. 1) FJAC(K,K-1) = -ONE + IF (K .NE. N) FJAC(K,K+1) = -TWO + 40 CONTINUE + 50 CONTINUE + RETURN + C + C LAST CARD OF SUBROUTINE FCN. + C + END +0 Results obtained with different compilers or machines + may be slightly different. +1 +0 Page +0 FINAL L2 NORM OF THE RESIDUALS 0.1192636D-07 +0 NUMBER OF FUNCTION EVALUATIONS 11 +0 NUMBER OF JACOBIAN EVALUATIONS 1 +0 EXIT PARAMETER 1 +0 FINAL APPROXIMATE SOLUTION +0 -0.5706545D+00 -0.6816283D+00 -0.7017325D+00 + -0.7042129D+00 -0.7013690D+00 -0.6918656D+00 + -0.6657920D+00 -0.5960342D+00 -0.4164121D+00 +1 +0 +1 +0 Page +0 Documentation for MINPACK subroutine LMDER1 +0 Double precision version +0 Argonne National Laboratory +0 Burton S. Garbow, Kenneth E. Hillstrom, Jorge J. More +0 March 1980 +0 + 1. Purpose. +0 The purpose of LMDER1 is to minimize the sum of the squares of + nonlinear functions in N variables by a modification of the + Levenberg-Marquardt algorithm. This is done by using the more + general least-squares solver LMDER. The user must provide a + subroutine which calculates the functions and the Jacobian. +0 + 2. Subroutine and type statements. +0 SUBROUTINE LMDER1(FCN,M,N,X,FVEC,FJAC,LDFJAC,TOL, + * INFO,IPVT,WA,LWA) + INTEGER M,N,LDFJAC,INFO,LWA + INTEGER IPVT(N) + DOUBLE PRECISION TOL + DOUBLE PRECISION X(N),FVEC(M),FJAC(LDFJAC,N),WA(LWA) + EXTERNAL FCN +0 + 3. Parameters. +0 Parameters designated as input parameters must be specified on + entry to LMDER1 and are not changed on exit, while parameters + designated as output parameters need not be specified on entry + and are set to appropriate values on exit from LMDER1. +0 FCN is the name of the user-supplied subroutine which calculate + the functions and the Jacobian. FCN must be declared in an + EXTERNAL statement in the user calling program, and should be + written as follows. +0 SUBROUTINE FCN(M,N,X,FVEC,FJAC,LDFJAC,IFLAG) + INTEGER M,N,LDFJAC,IFLAG + DOUBLE PRECISION X(N),FVEC(M),FJAC(LDFJAC,N) + ---------- + IF IFLAG = 1 CALCULATE THE FUNCTIONS AT X AND + RETURN THIS VECTOR IN FVEC. DO NOT ALTER FJAC. + IF IFLAG = 2 CALCULATE THE JACOBIAN AT X AND + RETURN THIS MATRIX IN FJAC. DO NOT ALTER FVEC. + ---------- + RETURN + END +1 +0 Page +0 The value of IFLAG should not be changed by FCN unless the + user wants to terminate execution of LMDER1. In this case se + IFLAG to a negative integer. +0 M is a positive integer input variable set to the number of + functions. +0 N is a positive integer input variable set to the number of + variables. N must not exceed M. +0 X is an array of length N. On input X must contain an initial + estimate of the solution vector. On output X contains the + final estimate of the solution vector. +0 FVEC is an output array of length M which contains the function + evaluated at the output X. +0 FJAC is an output M by N array. The upper N by N submatrix of + FJAC contains an upper triangular matrix R with diagonal ele- + ments of nonincreasing magnitude such that +0 T T T + P *(JAC *JAC)*P = R *R, +0 where P is a permutation matrix and JAC is the final calcu- + lated Jacobian. Column j of P is column IPVT(j) (see below) + of the identity matrix. The lower trapezoidal part of FJAC + contains information generated during the computation of R. +0 LDFJAC is a positive integer input variable not less than M + which specifies the leading dimension of the array FJAC. +0 TOL is a nonnegative input variable. Termination occurs when + the algorithm estimates either that the relative error in the + sum of squares is at most TOL or that the relative error + between X and the solution is at most TOL. Section 4 contain + more details about TOL. +0 INFO is an integer output variable. If the user has terminated + execution, INFO is set to the (negative) value of IFLAG. See + description of FCN. Otherwise, INFO is set as follows. +0 INFO = 0 Improper input parameters. +0 INFO = 1 Algorithm estimates that the relative error in the + sum of squares is at most TOL. +0 INFO = 2 Algorithm estimates that the relative error between + X and the solution is at most TOL. +0 INFO = 3 Conditions for INFO = 1 and INFO = 2 both hold. +0 INFO = 4 FVEC is orthogonal to the columns of the Jacobian t + machine precision. +1 +0 Page +0 INFO = 5 Number of calls to FCN with IFLAG = 1 has reached + 100*(N+1). +0 INFO = 6 TOL is too small. No further reduction in the sum + of squares is possible. +0 INFO = 7 TOL is too small. No further improvement in the + approximate solution X is possible. +0 Sections 4 and 5 contain more details about INFO. +0 IPVT is an integer output array of length N. IPVT defines a + permutation matrix P such that JAC*P = Q*R, where JAC is the + final calculated Jacobian, Q is orthogonal (not stored), and + is upper triangular with diagonal elements of nonincreasing + magnitude. Column j of P is column IPVT(j) of the identity + matrix. +0 WA is a work array of length LWA. +0 LWA is a positive integer input variable not less than 5*N+M. +0 + 4. Successful completion. +0 The accuracy of LMDER1 is controlled by the convergence parame- + ter TOL. This parameter is used in tests which make three type + of comparisons between the approximation X and a solution XSOL. + LMDER1 terminates when any of the tests is satisfied. If TOL i + less than the machine precision (as defined by the MINPACK func + tion DPMPAR(1)), then LMDER1 only attempts to satisfy the test + defined by the machine precision. Further progress is not usu- + ally possible. Unless high precision solutions are required, + the recommended value for TOL is the square root of the machine + precision. +0 The tests assume that the functions and the Jacobian are coded + consistently, and that the functions are reasonably well + behaved. If these conditions are not satisfied, then LMDER1 ma + incorrectly indicate convergence. The coding of the Jacobian + can be checked by the MINPACK subroutine CHKDER. If the Jaco- + bian is coded correctly, then the validity of the answer can be + checked, for example, by rerunning LMDER1 with a tighter toler- + ance. +0 First convergence test. If ENORM(Z) denotes the Euclidean norm + of a vector Z, then this test attempts to guarantee that +0 ENORM(FVEC) .LE. (1+TOL)*ENORM(FVECS), +0 where FVECS denotes the functions evaluated at XSOL. If this + condition is satisfied with TOL = 10**(-K), then the final + residual norm ENORM(FVEC) has K significant decimal digits an + INFO is set to 1 (or to 3 if the second test is also +1 +0 Page +0 satisfied). +0 Second convergence test. If D is a diagonal matrix (implicitly + generated by LMDER1) whose entries contain scale factors for + the variables, then this test attempts to guarantee that +0 ENORM(D*(X-XSOL)) .LE. TOL*ENORM(D*XSOL). +0 If this condition is satisfied with TOL = 10**(-K), then the + larger components of D*X have K significant decimal digits an + INFO is set to 2 (or to 3 if the first test is also satis- + fied). There is a danger that the smaller components of D*X + may have large relative errors, but the choice of D is such + that the accuracy of the components of X is usually related t + their sensitivity. +0 Third convergence test. This test is satisfied when FVEC is + orthogonal to the columns of the Jacobian to machine preci- + sion. There is no clear relationship between this test and + the accuracy of LMDER1, and furthermore, the test is equally + well satisfied at other critical points, namely maximizers an + saddle points. Therefore, termination caused by this test + (INFO = 4) should be examined carefully. +0 + 5. Unsuccessful completion. +0 Unsuccessful termination of LMDER1 can be due to improper input + parameters, arithmetic interrupts, or an excessive number of + function evaluations. +0 Improper input parameters. INFO is set to 0 if N .LE. 0, or + M .LT. N, or LDFJAC .LT. M, or TOL .LT. 0.D0, or + LWA .LT. 5*N+M. +0 Arithmetic interrupts. If these interrupts occur in the FCN + subroutine during an early stage of the computation, they may + be caused by an unacceptable choice of X by LMDER1. In this + case, it may be possible to remedy the situation by not evalu + ating the functions here, but instead setting the components + of FVEC to numbers that exceed those in the initial FVEC, + thereby indirectly reducing the step length. The step length + can be more directly controlled by using instead LMDER, which + includes in its calling sequence the step-length- governing + parameter FACTOR. +0 Excessive number of function evaluations. If the number of + calls to FCN with IFLAG = 1 reaches 100*(N+1), then this indi + cates that the routine is converging very slowly as measured + by the progress of FVEC, and INFO is set to 5. In this case, + it may be helpful to restart LMDER1, thereby forcing it to + disregard old (and possibly harmful) information. +0 +1 +0 Page +0 6. Characteristics of the algorithm. +0 LMDER1 is a modification of the Levenberg-Marquardt algorithm. + Two of its main characteristics involve the proper use of + implicitly scaled variables and an optimal choice for the cor- + rection. The use of implicitly scaled variables achieves scale + invariance of LMDER1 and limits the size of the correction in + any direction where the functions are changing rapidly. The + optimal choice of the correction guarantees (under reasonable + conditions) global convergence from starting points far from th + solution and a fast rate of convergence for problems with small + residuals. +0 Timing. The time required by LMDER1 to solve a given problem + depends on M and N, the behavior of the functions, the accu- + racy requested, and the starting point. The number of arith- + metic operations needed by LMDER1 is about N**3 to process + each evaluation of the functions (call to FCN with IFLAG = 1) + and M*(N**2) to process each evaluation of the Jacobian (call + to FCN with IFLAG = 2). Unless FCN can be evaluated quickly, + the timing of LMDER1 will be strongly influenced by the time + spent in FCN. +0 Storage. LMDER1 requires M*N + 2*M + 6*N double precision sto- + rage locations and N integer storage locations, in addition t + the storage required by the program. There are no internally + declared storage arrays. +0 + 7. Subprograms required. +0 USER-supplied ...... FCN +0 MINPACK-supplied ... DPMPAR,ENORM,LMDER,LMPAR,QRFAC,QRSOLV +0 FORTRAN-supplied ... DABS,DMAX1,DMIN1,DSQRT,MOD +0 + 8. References. +0 Jorge J. More, The Levenberg-Marquardt Algorithm, Implementatio + and Theory. Numerical Analysis, G. A. Watson, editor. + Lecture Notes in Mathematics 630, Springer-Verlag, 1977. +0 + 9. Example. +0 The problem is to determine the values of x(1), x(2), and x(3) + which provide the best fit (in the least squares sense) of +0 x(1) + u(i)/(v(i)*x(2) + w(i)*x(3)), i = 1, 15 +0 to the data +1 +0 Page +0 y = (0.14,0.18,0.22,0.25,0.29,0.32,0.35,0.39, + 0.37,0.58,0.73,0.96,1.34,2.10,4.39), +0 where u(i) = i, v(i) = 16 - i, and w(i) = min(u(i),v(i)). The + i-th component of FVEC is thus defined by +0 y(i) - (x(1) + u(i)/(v(i)*x(2) + w(i)*x(3))). +0 C ********** + C + C DRIVER FOR LMDER1 EXAMPLE. + C DOUBLE PRECISION VERSION + C + C ********** + INTEGER J,M,N,LDFJAC,INFO,LWA,NWRITE + INTEGER IPVT(3) + DOUBLE PRECISION TOL,FNORM + DOUBLE PRECISION X(3),FVEC(15),FJAC(15,3),WA(30) + DOUBLE PRECISION ENORM,DPMPAR + EXTERNAL FCN + C + C LOGICAL OUTPUT UNIT IS ASSUMED TO BE NUMBER 6. + C + DATA NWRITE /6/ + C + M = 15 + N = 3 + C + C THE FOLLOWING STARTING VALUES PROVIDE A ROUGH FIT. + C + X(1) = 1.D0 + X(2) = 1.D0 + X(3) = 1.D0 + C + LDFJAC = 15 + LWA = 30 + C + C SET TOL TO THE SQUARE ROOT OF THE MACHINE PRECISION. + C UNLESS HIGH PRECISION SOLUTIONS ARE REQUIRED, + C THIS IS THE RECOMMENDED SETTING. + C + TOL = DSQRT(DPMPAR(1)) + C + CALL LMDER1(FCN,M,N,X,FVEC,FJAC,LDFJAC,TOL, + * INFO,IPVT,WA,LWA) + FNORM = ENORM(M,FVEC) + WRITE (NWRITE,1000) FNORM,INFO,(X(J),J=1,N) + STOP + 1000 FORMAT (5X,31H FINAL L2 NORM OF THE RESIDUALS,D15.7 // + * 5X,15H EXIT PARAMETER,16X,I10 // + * 5X,27H FINAL APPROXIMATE SOLUTION // 5X,3D15.7) + C + C LAST CARD OF DRIVER FOR LMDER1 EXAMPLE. + C +1 +0 Page +0 END + SUBROUTINE FCN(M,N,X,FVEC,FJAC,LDFJAC,IFLAG) + INTEGER M,N,LDFJAC,IFLAG + DOUBLE PRECISION X(N),FVEC(M),FJAC(LDFJAC,N) + C + C SUBROUTINE FCN FOR LMDER1 EXAMPLE. + C + INTEGER I + DOUBLE PRECISION TMP1,TMP2,TMP3,TMP4 + DOUBLE PRECISION Y(15) + DATA Y(1),Y(2),Y(3),Y(4),Y(5),Y(6),Y(7),Y(8), + * Y(9),Y(10),Y(11),Y(12),Y(13),Y(14),Y(15) + * /1.4D-1,1.8D-1,2.2D-1,2.5D-1,2.9D-1,3.2D-1,3.5D-1,3.9D-1, + * 3.7D-1,5.8D-1,7.3D-1,9.6D-1,1.34D0,2.1D0,4.39D0/ + C + IF (IFLAG .EQ. 2) GO TO 20 + DO 10 I = 1, 15 + TMP1 = I + TMP2 = 16 - I + TMP3 = TMP1 + IF (I .GT. 8) TMP3 = TMP2 + FVEC(I) = Y(I) - (X(1) + TMP1/(X(2)*TMP2 + X(3)*TMP3)) + 10 CONTINUE + GO TO 40 + 20 CONTINUE + DO 30 I = 1, 15 + TMP1 = I + TMP2 = 16 - I + TMP3 = TMP1 + IF (I .GT. 8) TMP3 = TMP2 + TMP4 = (X(2)*TMP2 + X(3)*TMP3)**2 + FJAC(I,1) = -1.D0 + FJAC(I,2) = TMP1*TMP2/TMP4 + FJAC(I,3) = TMP1*TMP3/TMP4 + 30 CONTINUE + 40 CONTINUE + RETURN + C + C LAST CARD OF SUBROUTINE FCN. + C + END +0 Results obtained with different compilers or machines + may be slightly different. +0 FINAL L2 NORM OF THE RESIDUALS 0.9063596D-01 +0 EXIT PARAMETER 1 +0 FINAL APPROXIMATE SOLUTION +0 0.8241058D-01 0.1133037D+01 0.2343695D+01 +1 +0 +1 +0 Page +0 Documentation for MINPACK subroutine LMDER +0 Double precision version +0 Argonne National Laboratory +0 Burton S. Garbow, Kenneth E. Hillstrom, Jorge J. More +0 March 1980 +0 + 1. Purpose. +0 The purpose of LMDER is to minimize the sum of the squares of M + nonlinear functions in N variables by a modification of the + Levenberg-Marquardt algorithm. The user must provide a subrou- + tine which calculates the functions and the Jacobian. +0 + 2. Subroutine and type statements. +0 SUBROUTINE LMDER(FCN,M,N,X,FVEC,FJAC,LDFJAC,FTOL,XTOL,GTOL, + * MAXFEV,DIAG,MODE,FACTOR,NPRINT,INFO,NFEV,NJEV, + * IPVT,QTF,WA1,WA2,WA3,WA4) + INTEGER M,N,LDFJAC,MAXFEV,MODE,NPRINT,INFO,NFEV,NJEV + INTEGER IPVT(N) + DOUBLE PRECISION FTOL,XTOL,GTOL,FACTOR + DOUBLE PRECISION X(N),FVEC(M),FJAC(LDFJAC,N),DIAG(N),QTF(N), + * WA1(N),WA2(N),WA3(N),WA4(M) +0 + 3. Parameters. +0 Parameters designated as input parameters must be specified on + entry to LMDER and are not changed on exit, while parameters + designated as output parameters need not be specified on entry + and are set to appropriate values on exit from LMDER. +0 FCN is the name of the user-supplied subroutine which calculate + the functions and the Jacobian. FCN must be declared in an + EXTERNAL statement in the user calling program, and should be + written as follows. +0 SUBROUTINE FCN(M,N,X,FVEC,FJAC,LDFJAC,IFLAG) + INTEGER M,N,LDFJAC,IFLAG + DOUBLE PRECISION X(N),FVEC(M),FJAC(LDFJAC,N) + ---------- + IF IFLAG = 1 CALCULATE THE FUNCTIONS AT X AND + RETURN THIS VECTOR IN FVEC. DO NOT ALTER FJAC. + IF IFLAG = 2 CALCULATE THE JACOBIAN AT X AND + RETURN THIS MATRIX IN FJAC. DO NOT ALTER FVEC. + ---------- + RETURN + END +1 +0 Page +0 The value of IFLAG should not be changed by FCN unless the + user wants to terminate execution of LMDER. In this case set + IFLAG to a negative integer. +0 M is a positive integer input variable set to the number of + functions. +0 N is a positive integer input variable set to the number of + variables. N must not exceed M. +0 X is an array of length N. On input X must contain an initial + estimate of the solution vector. On output X contains the + final estimate of the solution vector. +0 FVEC is an output array of length M which contains the function + evaluated at the output X. +0 FJAC is an output M by N array. The upper N by N submatrix of + FJAC contains an upper triangular matrix R with diagonal ele- + ments of nonincreasing magnitude such that +0 T T T + P *(JAC *JAC)*P = R *R, +0 where P is a permutation matrix and JAC is the final calcu- + lated Jacobian. Column j of P is column IPVT(j) (see below) + of the identity matrix. The lower trapezoidal part of FJAC + contains information generated during the computation of R. +0 LDFJAC is a positive integer input variable not less than M + which specifies the leading dimension of the array FJAC. +0 FTOL is a nonnegative input variable. Termination occurs when + both the actual and predicted relative reductions in the sum + of squares are at most FTOL. Therefore, FTOL measures the + relative error desired in the sum of squares. Section 4 con- + tains more details about FTOL. +0 XTOL is a nonnegative input variable. Termination occurs when + the relative error between two consecutive iterates is at mos + XTOL. Therefore, XTOL measures the relative error desired in + the approximate solution. Section 4 contains more details + about XTOL. +0 GTOL is a nonnegative input variable. Termination occurs when + the cosine of the angle between FVEC and any column of the + Jacobian is at most GTOL in absolute value. Therefore, GTOL + measures the orthogonality desired between the function vecto + and the columns of the Jacobian. Section 4 contains more + details about GTOL. +0 MAXFEV is a positive integer input variable. Termination occur + when the number of calls to FCN with IFLAG = 1 has reached + MAXFEV. +1 +0 Page +0 DIAG is an array of length N. If MODE = 1 (see below), DIAG is + internally set. If MODE = 2, DIAG must contain positive + entries that serve as multiplicative scale factors for the + variables. +0 MODE is an integer input variable. If MODE = 1, the variables + will be scaled internally. If MODE = 2, the scaling is speci + fied by the input DIAG. Other values of MODE are equivalent + to MODE = 1. +0 FACTOR is a positive input variable used in determining the ini + tial step bound. This bound is set to the product of FACTOR + and the Euclidean norm of DIAG*X if nonzero, or else to FACTO + itself. In most cases FACTOR should lie in the interval + (.1,100.). 100. is a generally recommended value. +0 NPRINT is an integer input variable that enables controlled + printing of iterates if it is positive. In this case, FCN is + called with IFLAG = 0 at the beginning of the first iteration + and every NPRINT iterations thereafter and immediately prior + to return, with X, FVEC, and FJAC available for printing. + FVEC and FJAC should not be altered. If NPRINT is not posi- + tive, no special calls of FCN with IFLAG = 0 are made. +0 INFO is an integer output variable. If the user has terminated + execution, INFO is set to the (negative) value of IFLAG. See + description of FCN. Otherwise, INFO is set as follows. +0 INFO = 0 Improper input parameters. +0 INFO = 1 Both actual and predicted relative reductions in th + sum of squares are at most FTOL. +0 INFO = 2 Relative error between two consecutive iterates is + at most XTOL. +0 INFO = 3 Conditions for INFO = 1 and INFO = 2 both hold. +0 INFO = 4 The cosine of the angle between FVEC and any column + of the Jacobian is at most GTOL in absolute value. +0 INFO = 5 Number of calls to FCN with IFLAG = 1 has reached + MAXFEV. +0 INFO = 6 FTOL is too small. No further reduction in the sum + of squares is possible. +0 INFO = 7 XTOL is too small. No further improvement in the + approximate solution X is possible. +0 INFO = 8 GTOL is too small. FVEC is orthogonal to the + columns of the Jacobian to machine precision. +0 Sections 4 and 5 contain more details about INFO. +1 +0 Page +0 NFEV is an integer output variable set to the number of calls t + FCN with IFLAG = 1. +0 NJEV is an integer output variable set to the number of calls t + FCN with IFLAG = 2. +0 IPVT is an integer output array of length N. IPVT defines a + permutation matrix P such that JAC*P = Q*R, where JAC is the + final calculated Jacobian, Q is orthogonal (not stored), and + is upper triangular with diagonal elements of nonincreasing + magnitude. Column j of P is column IPVT(j) of the identity + matrix. +0 QTF is an output array of length N which contains the first N + elements of the vector (Q transpose)*FVEC. +0 WA1, WA2, and WA3 are work arrays of length N. +0 WA4 is a work array of length M. +0 + 4. Successful completion. +0 The accuracy of LMDER is controlled by the convergence parame- + ters FTOL, XTOL, and GTOL. These parameters are used in tests + which make three types of comparisons between the approximation + X and a solution XSOL. LMDER terminates when any of the tests + is satisfied. If any of the convergence parameters is less tha + the machine precision (as defined by the MINPACK function + DPMPAR(1)), then LMDER only attempts to satisfy the test define + by the machine precision. Further progress is not usually pos- + sible. +0 The tests assume that the functions and the Jacobian are coded + consistently, and that the functions are reasonably well + behaved. If these conditions are not satisfied, then LMDER may + incorrectly indicate convergence. The coding of the Jacobian + can be checked by the MINPACK subroutine CHKDER. If the Jaco- + bian is coded correctly, then the validity of the answer can be + checked, for example, by rerunning LMDER with tighter toler- + ances. +0 First convergence test. If ENORM(Z) denotes the Euclidean norm + of a vector Z, then this test attempts to guarantee that +0 ENORM(FVEC) .LE. (1+FTOL)*ENORM(FVECS), +0 where FVECS denotes the functions evaluated at XSOL. If this + condition is satisfied with FTOL = 10**(-K), then the final + residual norm ENORM(FVEC) has K significant decimal digits an + INFO is set to 1 (or to 3 if the second test is also satis- + fied). Unless high precision solutions are required, the + recommended value for FTOL is the square root of the machine + precision. +1 +0 Page +0 Second convergence test. If D is the diagonal matrix whose + entries are defined by the array DIAG, then this test attempt + to guarantee that +0 ENORM(D*(X-XSOL)) .LE. XTOL*ENORM(D*XSOL). +0 If this condition is satisfied with XTOL = 10**(-K), then the + larger components of D*X have K significant decimal digits an + INFO is set to 2 (or to 3 if the first test is also satis- + fied). There is a danger that the smaller components of D*X + may have large relative errors, but if MODE = 1, then the + accuracy of the components of X is usually related to their + sensitivity. Unless high precision solutions are required, + the recommended value for XTOL is the square root of the + machine precision. +0 Third convergence test. This test is satisfied when the cosine + of the angle between FVEC and any column of the Jacobian at X + is at most GTOL in absolute value. There is no clear rela- + tionship between this test and the accuracy of LMDER, and + furthermore, the test is equally well satisfied at other crit + ical points, namely maximizers and saddle points. Therefore, + termination caused by this test (INFO = 4) should be examined + carefully. The recommended value for GTOL is zero. +0 + 5. Unsuccessful completion. +0 Unsuccessful termination of LMDER can be due to improper input + parameters, arithmetic interrupts, or an excessive number of + function evaluations. +0 Improper input parameters. INFO is set to 0 if N .LE. 0, or + M .LT. N, or LDFJAC .LT. M, or FTOL .LT. 0.D0, or + XTOL .LT. 0.D0, or GTOL .LT. 0.D0, or MAXFEV .LE. 0, or + FACTOR .LE. 0.D0. +0 Arithmetic interrupts. If these interrupts occur in the FCN + subroutine during an early stage of the computation, they may + be caused by an unacceptable choice of X by LMDER. In this + case, it may be possible to remedy the situation by rerunning + LMDER with a smaller value of FACTOR. +0 Excessive number of function evaluations. A reasonable value + for MAXFEV is 100*(N+1). If the number of calls to FCN with + IFLAG = 1 reaches MAXFEV, then this indicates that the routin + is converging very slowly as measured by the progress of FVEC + and INFO is set to 5. In this case, it may be helpful to + restart LMDER with MODE set to 1. +0 + 6. Characteristics of the algorithm. +0 LMDER is a modification of the Levenberg-Marquardt algorithm. +1 +0 Page +0 Two of its main characteristics involve the proper use of + implicitly scaled variables (if MODE = 1) and an optimal choice + for the correction. The use of implicitly scaled variables + achieves scale invariance of LMDER and limits the size of the + correction in any direction where the functions are changing + rapidly. The optimal choice of the correction guarantees (unde + reasonable conditions) global convergence from starting points + far from the solution and a fast rate of convergence for prob- + lems with small residuals. +0 Timing. The time required by LMDER to solve a given problem + depends on M and N, the behavior of the functions, the accu- + racy requested, and the starting point. The number of arith- + metic operations needed by LMDER is about N**3 to process eac + evaluation of the functions (call to FCN with IFLAG = 1) and + M*(N**2) to process each evaluation of the Jacobian (call to + FCN with IFLAG = 2). Unless FCN can be evaluated quickly, th + timing of LMDER will be strongly influenced by the time spent + in FCN. +0 Storage. LMDER requires M*N + 2*M + 6*N double precision sto- + rage locations and N integer storage locations, in addition t + the storage required by the program. There are no internally + declared storage arrays. +0 + 7. Subprograms required. +0 USER-supplied ...... FCN +0 MINPACK-supplied ... DPMPAR,ENORM,LMPAR,QRFAC,QRSOLV +0 FORTRAN-supplied ... DABS,DMAX1,DMIN1,DSQRT,MOD +0 + 8. References. +0 Jorge J. More, The Levenberg-Marquardt Algorithm, Implementatio + and Theory. Numerical Analysis, G. A. Watson, editor. + Lecture Notes in Mathematics 630, Springer-Verlag, 1977. +0 + 9. Example. +0 The problem is to determine the values of x(1), x(2), and x(3) + which provide the best fit (in the least squares sense) of +0 x(1) + u(i)/(v(i)*x(2) + w(i)*x(3)), i = 1, 15 +0 to the data +0 y = (0.14,0.18,0.22,0.25,0.29,0.32,0.35,0.39, + 0.37,0.58,0.73,0.96,1.34,2.10,4.39), +1 +0 Page +0 where u(i) = i, v(i) = 16 - i, and w(i) = min(u(i),v(i)). The + i-th component of FVEC is thus defined by +0 y(i) - (x(1) + u(i)/(v(i)*x(2) + w(i)*x(3))). +0 C ********** + C + C DRIVER FOR LMDER EXAMPLE. + C DOUBLE PRECISION VERSION + C + C ********** + INTEGER J,M,N,LDFJAC,MAXFEV,MODE,NPRINT,INFO,NFEV,NJEV,NWRITE + INTEGER IPVT(3) + DOUBLE PRECISION FTOL,XTOL,GTOL,FACTOR,FNORM + DOUBLE PRECISION X(3),FVEC(15),FJAC(15,3),DIAG(3),QTF(3), + * WA1(3),WA2(3),WA3(3),WA4(15) + DOUBLE PRECISION ENORM,DPMPAR + EXTERNAL FCN + C + C LOGICAL OUTPUT UNIT IS ASSUMED TO BE NUMBER 6. + C + DATA NWRITE /6/ + C + M = 15 + N = 3 + C + C THE FOLLOWING STARTING VALUES PROVIDE A ROUGH FIT. + C + X(1) = 1.D0 + X(2) = 1.D0 + X(3) = 1.D0 + C + LDFJAC = 15 + C + C SET FTOL AND XTOL TO THE SQUARE ROOT OF THE MACHINE PRECISION + C AND GTOL TO ZERO. UNLESS HIGH PRECISION SOLUTIONS ARE + C REQUIRED, THESE ARE THE RECOMMENDED SETTINGS. + C + FTOL = DSQRT(DPMPAR(1)) + XTOL = DSQRT(DPMPAR(1)) + GTOL = 0.D0 + C + MAXFEV = 400 + MODE = 1 + FACTOR = 1.D2 + NPRINT = 0 + C + CALL LMDER(FCN,M,N,X,FVEC,FJAC,LDFJAC,FTOL,XTOL,GTOL, + * MAXFEV,DIAG,MODE,FACTOR,NPRINT,INFO,NFEV,NJEV, + * IPVT,QTF,WA1,WA2,WA3,WA4) + FNORM = ENORM(M,FVEC) + WRITE (NWRITE,1000) FNORM,NFEV,NJEV,INFO,(X(J),J=1,N) + STOP + 1000 FORMAT (5X,31H FINAL L2 NORM OF THE RESIDUALS,D15.7 // +1 +0 Page +0 * 5X,31H NUMBER OF FUNCTION EVALUATIONS,I10 // + * 5X,31H NUMBER OF JACOBIAN EVALUATIONS,I10 // + * 5X,15H EXIT PARAMETER,16X,I10 // + * 5X,27H FINAL APPROXIMATE SOLUTION // 5X,3D15.7) + C + C LAST CARD OF DRIVER FOR LMDER EXAMPLE. + C + END + SUBROUTINE FCN(M,N,X,FVEC,FJAC,LDFJAC,IFLAG) + INTEGER M,N,LDFJAC,IFLAG + DOUBLE PRECISION X(N),FVEC(M),FJAC(LDFJAC,N) + C + C SUBROUTINE FCN FOR LMDER EXAMPLE. + C + INTEGER I + DOUBLE PRECISION TMP1,TMP2,TMP3,TMP4 + DOUBLE PRECISION Y(15) + DATA Y(1),Y(2),Y(3),Y(4),Y(5),Y(6),Y(7),Y(8), + * Y(9),Y(10),Y(11),Y(12),Y(13),Y(14),Y(15) + * /1.4D-1,1.8D-1,2.2D-1,2.5D-1,2.9D-1,3.2D-1,3.5D-1,3.9D-1, + * 3.7D-1,5.8D-1,7.3D-1,9.6D-1,1.34D0,2.1D0,4.39D0/ + C + IF (IFLAG .NE. 0) GO TO 5 + C + C INSERT PRINT STATEMENTS HERE WHEN NPRINT IS POSITIVE. + C + RETURN + 5 CONTINUE + IF (IFLAG .EQ. 2) GO TO 20 + DO 10 I = 1, 15 + TMP1 = I + TMP2 = 16 - I + TMP3 = TMP1 + IF (I .GT. 8) TMP3 = TMP2 + FVEC(I) = Y(I) - (X(1) + TMP1/(X(2)*TMP2 + X(3)*TMP3)) + 10 CONTINUE + GO TO 40 + 20 CONTINUE + DO 30 I = 1, 15 + TMP1 = I + TMP2 = 16 - I + TMP3 = TMP1 + IF (I .GT. 8) TMP3 = TMP2 + TMP4 = (X(2)*TMP2 + X(3)*TMP3)**2 + FJAC(I,1) = -1.D0 + FJAC(I,2) = TMP1*TMP2/TMP4 + FJAC(I,3) = TMP1*TMP3/TMP4 + 30 CONTINUE + 40 CONTINUE + RETURN + C + C LAST CARD OF SUBROUTINE FCN. + C + END +1 +0 Page +0 Results obtained with different compilers or machines + may be slightly different. +0 FINAL L2 NORM OF THE RESIDUALS 0.9063596D-01 +0 NUMBER OF FUNCTION EVALUATIONS 6 +0 NUMBER OF JACOBIAN EVALUATIONS 5 +0 EXIT PARAMETER 1 +0 FINAL APPROXIMATE SOLUTION +0 0.8241058D-01 0.1133037D+01 0.2343695D+01 +1 +0 +1 +0 Page +0 Documentation for MINPACK subroutine LMSTR1 +0 Double precision version +0 Argonne National Laboratory +0 Burton S. Garbow, Kenneth E. Hillstrom, Jorge J. More +0 March 1980 +0 + 1. Purpose. +0 The purpose of LMSTR1 is to minimize the sum of the squares of + nonlinear functions in N variables by a modification of the + Levenberg-Marquardt algorithm which uses minimal storage. This + is done by using the more general least-squares solver LMSTR. + The user must provide a subroutine which calculates the func- + tions and the rows of the Jacobian. +0 + 2. Subroutine and type statements. +0 SUBROUTINE LMSTR1(FCN,M,N,X,FVEC,FJAC,LDFJAC,TOL, + * INFO,IPVT,WA,LWA) + INTEGER M,N,LDFJAC,INFO,LWA + INTEGER IPVT(N) + DOUBLE PRECISION TOL + DOUBLE PRECISION X(N),FVEC(M),FJAC(LDFJAC,N),WA(LWA) + EXTERNAL FCN +0 + 3. Parameters. +0 Parameters designated as input parameters must be specified on + entry to LMSTR1 and are not changed on exit, while parameters + designated as output parameters need not be specified on entry + and are set to appropriate values on exit from LMSTR1. +0 FCN is the name of the user-supplied subroutine which calculate + the functions and the rows of the Jacobian. FCN must be + declared in an EXTERNAL statement in the user calling program + and should be written as follows. +0 SUBROUTINE FCN(M,N,X,FVEC,FJROW,IFLAG) + INTEGER M,N,IFLAG + DOUBLE PRECISION X(N),FVEC(M),FJROW(N) + ---------- + IF IFLAG = 1 CALCULATE THE FUNCTIONS AT X AND + RETURN THIS VECTOR IN FVEC. + IF IFLAG = I CALCULATE THE (I-1)-ST ROW OF THE + JACOBIAN AT X AND RETURN THIS VECTOR IN FJROW. + ---------- + RETURN +1 +0 Page +0 END +0 The value of IFLAG should not be changed by FCN unless the + user wants to terminate execution of LMSTR1. In this case se + IFLAG to a negative integer. +0 M is a positive integer input variable set to the number of + functions. +0 N is a positive integer input variable set to the number of + variables. N must not exceed M. +0 X is an array of length N. On input X must contain an initial + estimate of the solution vector. On output X contains the + final estimate of the solution vector. +0 FVEC is an output array of length M which contains the function + evaluated at the output X. +0 FJAC is an output N by N array. The upper triangle of FJAC con + tains an upper triangular matrix R such that +0 T T T + P *(JAC *JAC)*P = R *R, +0 where P is a permutation matrix and JAC is the final calcu- + lated Jacobian. Column j of P is column IPVT(j) (see below) + of the identity matrix. The lower triangular part of FJAC + contains information generated during the computation of R. +0 LDFJAC is a positive integer input variable not less than N + which specifies the leading dimension of the array FJAC. +0 TOL is a nonnegative input variable. Termination occurs when + the algorithm estimates either that the relative error in the + sum of squares is at most TOL or that the relative error + between X and the solution is at most TOL. Section 4 contain + more details about TOL. +0 INFO is an integer output variable. If the user has terminated + execution, INFO is set to the (negative) value of IFLAG. See + description of FCN. Otherwise, INFO is set as follows. +0 INFO = 0 Improper input parameters. +0 INFO = 1 Algorithm estimates that the relative error in the + sum of squares is at most TOL. +0 INFO = 2 Algorithm estimates that the relative error between + X and the solution is at most TOL. +0 INFO = 3 Conditions for INFO = 1 and INFO = 2 both hold. +0 INFO = 4 FVEC is orthogonal to the columns of the Jacobian t +1 +0 Page +0 machine precision. +0 INFO = 5 Number of calls to FCN with IFLAG = 1 has reached + 100*(N+1). +0 INFO = 6 TOL is too small. No further reduction in the sum + of squares is possible. +0 INFO = 7 TOL is too small. No further improvement in the + approximate solution X is possible. +0 Sections 4 and 5 contain more details about INFO. +0 IPVT is an integer output array of length N. IPVT defines a + permutation matrix P such that JAC*P = Q*R, where JAC is the + final calculated Jacobian, Q is orthogonal (not stored), and + is upper triangular. Column j of P is column IPVT(j) of the + identity matrix. +0 WA is a work array of length LWA. +0 LWA is a positive integer input variable not less than 5*N+M. +0 + 4. Successful completion. +0 The accuracy of LMSTR1 is controlled by the convergence parame- + ter TOL. This parameter is used in tests which make three type + of comparisons between the approximation X and a solution XSOL. + LMSTR1 terminates when any of the tests is satisfied. If TOL i + less than the machine precision (as defined by the MINPACK func + tion DPMPAR(1)), then LMSTR1 only attempts to satisfy the test + defined by the machine precision. Further progress is not usu- + ally possible. Unless high precision solutions are required, + the recommended value for TOL is the square root of the machine + precision. +0 The tests assume that the functions and the Jacobian are coded + consistently, and that the functions are reasonably well + behaved. If these conditions are not satisfied, then LMSTR1 ma + incorrectly indicate convergence. The coding of the Jacobian + can be checked by the MINPACK subroutine CHKDER. If the Jaco- + bian is coded correctly, then the validity of the answer can be + checked, for example, by rerunning LMSTR1 with a tighter toler- + ance. +0 First convergence test. If ENORM(Z) denotes the Euclidean norm + of a vector Z, then this test attempts to guarantee that +0 ENORM(FVEC) .LE. (1+TOL)*ENORM(FVECS), +0 where FVECS denotes the functions evaluated at XSOL. If this + condition is satisfied with TOL = 10**(-K), then the final + residual norm ENORM(FVEC) has K significant decimal digits an +1 +0 Page +0 INFO is set to 1 (or to 3 if the second test is also satis- + fied). +0 Second convergence test. If D is a diagonal matrix (implicitly + generated by LMSTR1) whose entries contain scale factors for + the variables, then this test attempts to guarantee that +0 ENORM(D*(X-XSOL)) .LE. TOL*ENORM(D*XSOL). +0 If this condition is satisfied with TOL = 10**(-K), then the + larger components of D*X have K significant decimal digits an + INFO is set to 2 (or to 3 if the first test is also satis- + fied). There is a danger that the smaller components of D*X + may have large relative errors, but the choice of D is such + that the accuracy of the components of X is usually related t + their sensitivity. +0 Third convergence test. This test is satisfied when FVEC is + orthogonal to the columns of the Jacobian to machine preci- + sion. There is no clear relationship between this test and + the accuracy of LMSTR1, and furthermore, the test is equally + well satisfied at other critical points, namely maximizers an + saddle points. Therefore, termination caused by this test + (INFO = 4) should be examined carefully. +0 + 5. Unsuccessful completion. +0 Unsuccessful termination of LMSTR1 can be due to improper input + parameters, arithmetic interrupts, or an excessive number of + function evaluations. +0 Improper input parameters. INFO is set to 0 if N .LE. 0, or + M .LT. N, or LDFJAC .LT. N, or TOL .LT. 0.D0, or + LWA .LT. 5*N+M. +0 Arithmetic interrupts. If these interrupts occur in the FCN + subroutine during an early stage of the computation, they may + be caused by an unacceptable choice of X by LMSTR1. In this + case, it may be possible to remedy the situation by not evalu + ating the functions here, but instead setting the components + of FVEC to numbers that exceed those in the initial FVEC, + thereby indirectly reducing the step length. The step length + can be more directly controlled by using instead LMSTR, which + includes in its calling sequence the step-length- governing + parameter FACTOR. +0 Excessive number of function evaluations. If the number of + calls to FCN with IFLAG = 1 reaches 100*(N+1), then this indi + cates that the routine is converging very slowly as measured + by the progress of FVEC, and INFO is set to 5. In this case, + it may be helpful to restart LMSTR1, thereby forcing it to + disregard old (and possibly harmful) information. +1 +0 Page +0 + 6. Characteristics of the algorithm. +0 LMSTR1 is a modification of the Levenberg-Marquardt algorithm. + Two of its main characteristics involve the proper use of + implicitly scaled variables and an optimal choice for the cor- + rection. The use of implicitly scaled variables achieves scale + invariance of LMSTR1 and limits the size of the correction in + any direction where the functions are changing rapidly. The + optimal choice of the correction guarantees (under reasonable + conditions) global convergence from starting points far from th + solution and a fast rate of convergence for problems with small + residuals. +0 Timing. The time required by LMSTR1 to solve a given problem + depends on M and N, the behavior of the functions, the accu- + racy requested, and the starting point. The number of arith- + metic operations needed by LMSTR1 is about N**3 to process + each evaluation of the functions (call to FCN with IFLAG = 1) + and 1.5*(N**2) to process each row of the Jacobian (call to + FCN with IFLAG .GE. 2). Unless FCN can be evaluated quickly, + the timing of LMSTR1 will be strongly influenced by the time + spent in FCN. +0 Storage. LMSTR1 requires N**2 + 2*M + 6*N double precision sto + rage locations and N integer storage locations, in addition t + the storage required by the program. There are no internally + declared storage arrays. +0 + 7. Subprograms required. +0 USER-supplied ...... FCN +0 MINPACK-supplied ... DPMPAR,ENORM,LMSTR,LMPAR,QRFAC,QRSOLV, + RWUPDT +0 FORTRAN-supplied ... DABS,DMAX1,DMIN1,DSQRT,MOD +0 + 8. References. +0 Jorge J. More, The Levenberg-Marquardt Algorithm, Implementatio + and Theory. Numerical Analysis, G. A. Watson, editor. + Lecture Notes in Mathematics 630, Springer-Verlag, 1977. +0 + 9. Example. +0 The problem is to determine the values of x(1), x(2), and x(3) + which provide the best fit (in the least squares sense) of +0 x(1) + u(i)/(v(i)*x(2) + w(i)*x(3)), i = 1, 15 +1 +0 Page +0 to the data +0 y = (0.14,0.18,0.22,0.25,0.29,0.32,0.35,0.39, + 0.37,0.58,0.73,0.96,1.34,2.10,4.39), +0 where u(i) = i, v(i) = 16 - i, and w(i) = min(u(i),v(i)). The + i-th component of FVEC is thus defined by +0 y(i) - (x(1) + u(i)/(v(i)*x(2) + w(i)*x(3))). +0 C ********** + C + C DRIVER FOR LMSTR1 EXAMPLE. + C DOUBLE PRECISION VERSION + C + C ********** + INTEGER J,M,N,LDFJAC,INFO,LWA,NWRITE + INTEGER IPVT(3) + DOUBLE PRECISION TOL,FNORM + DOUBLE PRECISION X(3),FVEC(15),FJAC(3,3),WA(30) + DOUBLE PRECISION ENORM,DPMPAR + EXTERNAL FCN + C + C LOGICAL OUTPUT UNIT IS ASSUMED TO BE NUMBER 6. + C + DATA NWRITE /6/ + C + M = 15 + N = 3 + C + C THE FOLLOWING STARTING VALUES PROVIDE A ROUGH FIT. + C + X(1) = 1.D0 + X(2) = 1.D0 + X(3) = 1.D0 + C + LDFJAC = 3 + LWA = 30 + C + C SET TOL TO THE SQUARE ROOT OF THE MACHINE PRECISION. + C UNLESS HIGH PRECISION SOLUTIONS ARE REQUIRED, + C THIS IS THE RECOMMENDED SETTING. + C + TOL = DSQRT(DPMPAR(1)) + C + CALL LMSTR1(FCN,M,N,X,FVEC,FJAC,LDFJAC,TOL, + * INFO,IPVT,WA,LWA) + FNORM = ENORM(M,FVEC) + WRITE (NWRITE,1000) FNORM,INFO,(X(J),J=1,N) + STOP + 1000 FORMAT (5X,31H FINAL L2 NORM OF THE RESIDUALS,D15.7 // + * 5X,15H EXIT PARAMETER,16X,I10 // + * 5X,27H FINAL APPROXIMATE SOLUTION // 5X,3D15.7) + C +1 +0 Page +0 C LAST CARD OF DRIVER FOR LMSTR1 EXAMPLE. + C + END + SUBROUTINE FCN(M,N,X,FVEC,FJROW,IFLAG) + INTEGER M,N,IFLAG + DOUBLE PRECISION X(N),FVEC(M),FJROW(N) + C + C SUBROUTINE FCN FOR LMSTR1 EXAMPLE. + C + INTEGER I + DOUBLE PRECISION TMP1,TMP2,TMP3,TMP4 + DOUBLE PRECISION Y(15) + DATA Y(1),Y(2),Y(3),Y(4),Y(5),Y(6),Y(7),Y(8), + * Y(9),Y(10),Y(11),Y(12),Y(13),Y(14),Y(15) + * /1.4D-1,1.8D-1,2.2D-1,2.5D-1,2.9D-1,3.2D-1,3.5D-1,3.9D-1, + * 3.7D-1,5.8D-1,7.3D-1,9.6D-1,1.34D0,2.1D0,4.39D0/ + C + IF (IFLAG .GE. 2) GO TO 20 + DO 10 I = 1, 15 + TMP1 = I + TMP2 = 16 - I + TMP3 = TMP1 + IF (I .GT. 8) TMP3 = TMP2 + FVEC(I) = Y(I) - (X(1) + TMP1/(X(2)*TMP2 + X(3)*TMP3)) + 10 CONTINUE + GO TO 40 + 20 CONTINUE + I = IFLAG - 1 + TMP1 = I + TMP2 = 16 - I + TMP3 = TMP1 + IF (I .GT. 8) TMP3 = TMP2 + TMP4 = (X(2)*TMP2 + X(3)*TMP3)**2 + FJROW(1) = -1.D0 + FJROW(2) = TMP1*TMP2/TMP4 + FJROW(3) = TMP1*TMP3/TMP4 + 30 CONTINUE + 40 CONTINUE + RETURN + C + C LAST CARD OF SUBROUTINE FCN. + C + END +0 Results obtained with different compilers or machines + may be slightly different. +0 FINAL L2 NORM OF THE RESIDUALS 0.9063596D-01 +0 EXIT PARAMETER 1 +0 FINAL APPROXIMATE SOLUTION +0 0.8241058D-01 0.1133037D+01 0.2343695D+01 +1 +0 +1 +0 Page +0 Documentation for MINPACK subroutine LMSTR +0 Double precision version +0 Argonne National Laboratory +0 Burton S. Garbow, Kenneth E. Hillstrom, Jorge J. More +0 March 1980 +0 + 1. Purpose. +0 The purpose of LMSTR is to minimize the sum of the squares of M + nonlinear functions in N variables by a modification of the + Levenberg-Marquardt algorithm which uses minimal storage. The + user must provide a subroutine which calculates the functions + and the rows of the Jacobian. +0 + 2. Subroutine and type statements. +0 SUBROUTINE LMSTR(FCN,M,N,X,FVEC,FJAC,LDFJAC,FTOL,XTOL,GTOL, + * MAXFEV,DIAG,MODE,FACTOR,NPRINT,INFO,NFEV,NJEV, + * IPVT,QTF,WA1,WA2,WA3,WA4) + INTEGER M,N,LDFJAC,MAXFEV,MODE,NPRINT,INFO,NFEV,NJEV + INTEGER IPVT(N) + DOUBLE PRECISION FTOL,XTOL,GTOL,FACTOR + DOUBLE PRECISION X(N),FVEC(M),FJAC(LDFJAC,N),DIAG(N),QTF(N), + * WA1(N),WA2(N),WA3(N),WA4(M) +0 + 3. Parameters. +0 Parameters designated as input parameters must be specified on + entry to LMSTR and are not changed on exit, while parameters + designated as output parameters need not be specified on entry + and are set to appropriate values on exit from LMSTR. +0 FCN is the name of the user-supplied subroutine which calculate + the functions and the rows of the Jacobian. FCN must be + declared in an EXTERNAL statement in the user calling program + and should be written as follows. +0 SUBROUTINE FCN(M,N,X,FVEC,FJROW,IFLAG) + INTEGER M,N,IFLAG + DOUBLE PRECISION X(N),FVEC(M),FJROW(N) + ---------- + IF IFLAG = 1 CALCULATE THE FUNCTIONS AT X AND + RETURN THIS VECTOR IN FVEC. + IF IFLAG = I CALCULATE THE (I-1)-ST ROW OF THE + JACOBIAN AT X AND RETURN THIS VECTOR IN FJROW. + ---------- + RETURN +1 +0 Page +0 END +0 The value of IFLAG should not be changed by FCN unless the + user wants to terminate execution of LMSTR. In this case set + IFLAG to a negative integer. +0 M is a positive integer input variable set to the number of + functions. +0 N is a positive integer input variable set to the number of + variables. N must not exceed M. +0 X is an array of length N. On input X must contain an initial + estimate of the solution vector. On output X contains the + final estimate of the solution vector. +0 FVEC is an output array of length M which contains the function + evaluated at the output X. +0 FJAC is an output N by N array. The upper triangle of FJAC con + tains an upper triangular matrix R such that +0 T T T + P *(JAC *JAC)*P = R *R, +0 where P is a permutation matrix and JAC is the final calcu- + lated Jacobian. Column j of P is column IPVT(j) (see below) + of the identity matrix. The lower triangular part of FJAC + contains information generated during the computation of R. +0 LDFJAC is a positive integer input variable not less than N + which specifies the leading dimension of the array FJAC. +0 FTOL is a nonnegative input variable. Termination occurs when + both the actual and predicted relative reductions in the sum + of squares are at most FTOL. Therefore, FTOL measures the + relative error desired in the sum of squares. Section 4 con- + tains more details about FTOL. +0 XTOL is a nonnegative input variable. Termination occurs when + the relative error between two consecutive iterates is at mos + XTOL. Therefore, XTOL measures the relative error desired in + the approximate solution. Section 4 contains more details + about XTOL. +0 GTOL is a nonnegative input variable. Termination occurs when + the cosine of the angle between FVEC and any column of the + Jacobian is at most GTOL in absolute value. Therefore, GTOL + measures the orthogonality desired between the function vecto + and the columns of the Jacobian. Section 4 contains more + details about GTOL. +0 MAXFEV is a positive integer input variable. Termination occur + when the number of calls to FCN with IFLAG = 1 has reached +1 +0 Page +0 MAXFEV. +0 DIAG is an array of length N. If MODE = 1 (see below), DIAG is + internally set. If MODE = 2, DIAG must contain positive + entries that serve as multiplicative scale factors for the + variables. +0 MODE is an integer input variable. If MODE = 1, the variables + will be scaled internally. If MODE = 2, the scaling is speci + fied by the input DIAG. Other values of MODE are equivalent + to MODE = 1. +0 FACTOR is a positive input variable used in determining the ini + tial step bound. This bound is set to the product of FACTOR + and the Euclidean norm of DIAG*X if nonzero, or else to FACTO + itself. In most cases FACTOR should lie in the interval + (.1,100.). 100. is a generally recommended value. +0 NPRINT is an integer input variable that enables controlled + printing of iterates if it is positive. In this case, FCN is + called with IFLAG = 0 at the beginning of the first iteration + and every NPRINT iterations thereafter and immediately prior + to return, with X and FVEC available for printing. If NPRINT + is not positive, no special calls of FCN with IFLAG = 0 are + made. +0 INFO is an integer output variable. If the user has terminated + execution, INFO is set to the (negative) value of IFLAG. See + description of FCN. Otherwise, INFO is set as follows. +0 INFO = 0 Improper input parameters. +0 INFO = 1 Both actual and predicted relative reductions in th + sum of squares are at most FTOL. +0 INFO = 2 Relative error between two consecutive iterates is + at most XTOL. +0 INFO = 3 Conditions for INFO = 1 and INFO = 2 both hold. +0 INFO = 4 The cosine of the angle between FVEC and any column + of the Jacobian is at most GTOL in absolute value. +0 INFO = 5 Number of calls to FCN with IFLAG = 1 has reached + MAXFEV. +0 INFO = 6 FTOL is too small. No further reduction in the sum + of squares is possible. +0 INFO = 7 XTOL is too small. No further improvement in the + approximate solution X is possible. +0 INFO = 8 GTOL is too small. FVEC is orthogonal to the + columns of the Jacobian to machine precision. +1 +0 Page +0 Sections 4 and 5 contain more details about INFO. +0 NFEV is an integer output variable set to the number of calls t + FCN with IFLAG = 1. +0 NJEV is an integer output variable set to the number of calls t + FCN with IFLAG = 2. +0 IPVT is an integer output array of length N. IPVT defines a + permutation matrix P such that JAC*P = Q*R, where JAC is the + final calculated Jacobian, Q is orthogonal (not stored), and + is upper triangular. Column j of P is column IPVT(j) of the + identity matrix. +0 QTF is an output array of length N which contains the first N + elements of the vector (Q transpose)*FVEC. +0 WA1, WA2, and WA3 are work arrays of length N. +0 WA4 is a work array of length M. +0 + 4. Successful completion. +0 The accuracy of LMSTR is controlled by the convergence parame- + ters FTOL, XTOL, and GTOL. These parameters are used in tests + which make three types of comparisons between the approximation + X and a solution XSOL. LMSTR terminates when any of the tests + is satisfied. If any of the convergence parameters is less tha + the machine precision (as defined by the MINPACK function + DPMPAR(1)), then LMSTR only attempts to satisfy the test define + by the machine precision. Further progress is not usually pos- + sible. +0 The tests assume that the functions and the Jacobian are coded + consistently, and that the functions are reasonably well + behaved. If these conditions are not satisfied, then LMSTR may + incorrectly indicate convergence. The coding of the Jacobian + can be checked by the MINPACK subroutine CHKDER. If the Jaco- + bian is coded correctly, then the validity of the answer can be + checked, for example, by rerunning LMSTR with tighter toler- + ances. +0 First convergence test. If ENORM(Z) denotes the Euclidean norm + of a vector Z, then this test attempts to guarantee that +0 ENORM(FVEC) .LE. (1+FTOL)*ENORM(FVECS), +0 where FVECS denotes the functions evaluated at XSOL. If this + condition is satisfied with FTOL = 10**(-K), then the final + residual norm ENORM(FVEC) has K significant decimal digits an + INFO is set to 1 (or to 3 if the second test is also satis- + fied). Unless high precision solutions are required, the + recommended value for FTOL is the square root of the machine +1 +0 Page +0 precision. +0 Second convergence test. If D is the diagonal matrix whose + entries are defined by the array DIAG, then this test attempt + to guarantee that +0 ENORM(D*(X-XSOL)) .LE. XTOL*ENORM(D*XSOL). +0 If this condition is satisfied with XTOL = 10**(-K), then the + larger components of D*X have K significant decimal digits an + INFO is set to 2 (or to 3 if the first test is also satis- + fied). There is a danger that the smaller components of D*X + may have large relative errors, but if MODE = 1, then the + accuracy of the components of X is usually related to their + sensitivity. Unless high precision solutions are required, + the recommended value for XTOL is the square root of the + machine precision. +0 Third convergence test. This test is satisfied when the cosine + of the angle between FVEC and any column of the Jacobian at X + is at most GTOL in absolute value. There is no clear rela- + tionship between this test and the accuracy of LMSTR, and + furthermore, the test is equally well satisfied at other crit + ical points, namely maximizers and saddle points. Therefore, + termination caused by this test (INFO = 4) should be examined + carefully. The recommended value for GTOL is zero. +0 + 5. Unsuccessful completion. +0 Unsuccessful termination of LMSTR can be due to improper input + parameters, arithmetic interrupts, or an excessive number of + function evaluations. +0 Improper input parameters. INFO is set to 0 if N .LE. 0, or + M .LT. N, or LDFJAC .LT. N, or FTOL .LT. 0.D0, or + XTOL .LT. 0.D0, or GTOL .LT. 0.D0, or MAXFEV .LE. 0, or + FACTOR .LE. 0.D0. +0 Arithmetic interrupts. If these interrupts occur in the FCN + subroutine during an early stage of the computation, they may + be caused by an unacceptable choice of X by LMSTR. In this + case, it may be possible to remedy the situation by rerunning + LMSTR with a smaller value of FACTOR. +0 Excessive number of function evaluations. A reasonable value + for MAXFEV is 100*(N+1). If the number of calls to FCN with + IFLAG = 1 reaches MAXFEV, then this indicates that the routin + is converging very slowly as measured by the progress of FVEC + and INFO is set to 5. In this case, it may be helpful to + restart LMSTR with MODE set to 1. +0 + 6. Characteristics of the algorithm. +1 +0 Page +0 LMSTR is a modification of the Levenberg-Marquardt algorithm. + Two of its main characteristics involve the proper use of + implicitly scaled variables (if MODE = 1) and an optimal choice + for the correction. The use of implicitly scaled variables + achieves scale invariance of LMSTR and limits the size of the + correction in any direction where the functions are changing + rapidly. The optimal choice of the correction guarantees (unde + reasonable conditions) global convergence from starting points + far from the solution and a fast rate of convergence for prob- + lems with small residuals. +0 Timing. The time required by LMSTR to solve a given problem + depends on M and N, the behavior of the functions, the accu- + racy requested, and the starting point. The number of arith- + metic operations needed by LMSTR is about N**3 to process eac + evaluation of the functions (call to FCN with IFLAG = 1) and + 1.5*(N**2) to process each row of the Jacobian (call to FCN + with IFLAG .GE. 2). Unless FCN can be evaluated quickly, the + timing of LMSTR will be strongly influenced by the time spent + in FCN. +0 Storage. LMSTR requires N**2 + 2*M + 6*N double precision sto- + rage locations and N integer storage locations, in addition t + the storage required by the program. There are no internally + declared storage arrays. +0 + 7. Subprograms required. +0 USER-supplied ...... FCN +0 MINPACK-supplied ... DPMPAR,ENORM,LMPAR,QRFAC,QRSOLV,RWUPDT +0 FORTRAN-supplied ... DABS,DMAX1,DMIN1,DSQRT,MOD +0 + 8. References. +0 Jorge J. More, The Levenberg-Marquardt Algorithm, Implementatio + and Theory. Numerical Analysis, G. A. Watson, editor. + Lecture Notes in Mathematics 630, Springer-Verlag, 1977. +0 + 9. Example. +0 The problem is to determine the values of x(1), x(2), and x(3) + which provide the best fit (in the least squares sense) of +0 x(1) + u(i)/(v(i)*x(2) + w(i)*x(3)), i = 1, 15 +0 to the data +0 y = (0.14,0.18,0.22,0.25,0.29,0.32,0.35,0.39, + 0.37,0.58,0.73,0.96,1.34,2.10,4.39), +1 +0 Page +0 where u(i) = i, v(i) = 16 - i, and w(i) = min(u(i),v(i)). The + i-th component of FVEC is thus defined by +0 y(i) - (x(1) + u(i)/(v(i)*x(2) + w(i)*x(3))). +0 C ********** + C + C DRIVER FOR LMSTR EXAMPLE. + C DOUBLE PRECISION VERSION + C + C ********** + INTEGER J,M,N,LDFJAC,MAXFEV,MODE,NPRINT,INFO,NFEV,NJEV,NWRITE + INTEGER IPVT(3) + DOUBLE PRECISION FTOL,XTOL,GTOL,FACTOR,FNORM + DOUBLE PRECISION X(3),FVEC(15),FJAC(3,3),DIAG(3),QTF(3), + * WA1(3),WA2(3),WA3(3),WA4(15) + DOUBLE PRECISION ENORM,DPMPAR + EXTERNAL FCN + C + C LOGICAL OUTPUT UNIT IS ASSUMED TO BE NUMBER 6. + C + DATA NWRITE /6/ + C + M = 15 + N = 3 + C + C THE FOLLOWING STARTING VALUES PROVIDE A ROUGH FIT. + C + X(1) = 1.D0 + X(2) = 1.D0 + X(3) = 1.D0 + C + LDFJAC = 3 + C + C SET FTOL AND XTOL TO THE SQUARE ROOT OF THE MACHINE PRECISION + C AND GTOL TO ZERO. UNLESS HIGH PRECISION SOLUTIONS ARE + C REQUIRED, THESE ARE THE RECOMMENDED SETTINGS. + C + FTOL = DSQRT(DPMPAR(1)) + XTOL = DSQRT(DPMPAR(1)) + GTOL = 0.D0 + C + MAXFEV = 400 + MODE = 1 + FACTOR = 1.D2 + NPRINT = 0 + C + CALL LMSTR(FCN,M,N,X,FVEC,FJAC,LDFJAC,FTOL,XTOL,GTOL, + * MAXFEV,DIAG,MODE,FACTOR,NPRINT,INFO,NFEV,NJEV, + * IPVT,QTF,WA1,WA2,WA3,WA4) + FNORM = ENORM(M,FVEC) + WRITE (NWRITE,1000) FNORM,NFEV,NJEV,INFO,(X(J),J=1,N) + STOP + 1000 FORMAT (5X,31H FINAL L2 NORM OF THE RESIDUALS,D15.7 // +1 +0 Page +0 * 5X,31H NUMBER OF FUNCTION EVALUATIONS,I10 // + * 5X,31H NUMBER OF JACOBIAN EVALUATIONS,I10 // + * 5X,15H EXIT PARAMETER,16X,I10 // + * 5X,27H FINAL APPROXIMATE SOLUTION // 5X,3D15.7) + C + C LAST CARD OF DRIVER FOR LMSTR EXAMPLE. + C + END + SUBROUTINE FCN(M,N,X,FVEC,FJROW,IFLAG) + INTEGER M,N,IFLAG + DOUBLE PRECISION X(N),FVEC(M),FJROW(N) + C + C SUBROUTINE FCN FOR LMSTR EXAMPLE. + C + INTEGER I + DOUBLE PRECISION TMP1,TMP2,TMP3,TMP4 + DOUBLE PRECISION Y(15) + DATA Y(1),Y(2),Y(3),Y(4),Y(5),Y(6),Y(7),Y(8), + * Y(9),Y(10),Y(11),Y(12),Y(13),Y(14),Y(15) + * /1.4D-1,1.8D-1,2.2D-1,2.5D-1,2.9D-1,3.2D-1,3.5D-1,3.9D-1, + * 3.7D-1,5.8D-1,7.3D-1,9.6D-1,1.34D0,2.1D0,4.39D0/ + C + IF (IFLAG .NE. 0) GO TO 5 + C + C INSERT PRINT STATEMENTS HERE WHEN NPRINT IS POSITIVE. + C + RETURN + 5 CONTINUE + IF (IFLAG .GE. 2) GO TO 20 + DO 10 I = 1, 15 + TMP1 = I + TMP2 = 16 - I + TMP3 = TMP1 + IF (I .GT. 8) TMP3 = TMP2 + FVEC(I) = Y(I) - (X(1) + TMP1/(X(2)*TMP2 + X(3)*TMP3)) + 10 CONTINUE + GO TO 40 + 20 CONTINUE + I = IFLAG - 1 + TMP1 = I + TMP2 = 16 - I + TMP3 = TMP1 + IF (I .GT. 8) TMP3 = TMP2 + TMP4 = (X(2)*TMP2 + X(3)*TMP3)**2 + FJROW(1) = -1.D0 + FJROW(2) = TMP1*TMP2/TMP4 + FJROW(3) = TMP1*TMP3/TMP4 + 30 CONTINUE + 40 CONTINUE + RETURN + C + C LAST CARD OF SUBROUTINE FCN. + C + END +1 +0 Page +0 Results obtained with different compilers or machines + may be slightly different. +0 FINAL L2 NORM OF THE RESIDUALS 0.9063596D-01 +0 NUMBER OF FUNCTION EVALUATIONS 6 +0 NUMBER OF JACOBIAN EVALUATIONS 5 +0 EXIT PARAMETER 1 +0 FINAL APPROXIMATE SOLUTION +0 0.8241058D-01 0.1133037D+01 0.2343695D+01 +1 +0 +1 +0 Page +0 Documentation for MINPACK subroutine LMDIF1 +0 Double precision version +0 Argonne National Laboratory +0 Burton S. Garbow, Kenneth E. Hillstrom, Jorge J. More +0 March 1980 +0 + 1. Purpose. +0 The purpose of LMDIF1 is to minimize the sum of the squares of + nonlinear functions in N variables by a modification of the + Levenberg-Marquardt algorithm. This is done by using the more + general least-squares solver LMDIF. The user must provide a + subroutine which calculates the functions. The Jacobian is the + calculated by a forward-difference approximation. +0 + 2. Subroutine and type statements. +0 SUBROUTINE LMDIF1(FCN,M,N,X,FVEC,TOL,INFO,IWA,WA,LWA) + INTEGER M,N,INFO,LWA + INTEGER IWA(N) + DOUBLE PRECISION TOL + DOUBLE PRECISION X(N),FVEC(M),WA(LWA) + EXTERNAL FCN +0 + 3. Parameters. +0 Parameters designated as input parameters must be specified on + entry to LMDIF1 and are not changed on exit, while parameters + designated as output parameters need not be specified on entry + and are set to appropriate values on exit from LMDIF1. +0 FCN is the name of the user-supplied subroutine which calculate + the functions. FCN must be declared in an EXTERNAL statement + in the user calling program, and should be written as follows +0 SUBROUTINE FCN(M,N,X,FVEC,IFLAG) + INTEGER M,N,IFLAG + DOUBLE PRECISION X(N),FVEC(M) + ---------- + CALCULATE THE FUNCTIONS AT X AND + RETURN THIS VECTOR IN FVEC. + ---------- + RETURN + END +0 The value of IFLAG should not be changed by FCN unless the + user wants to terminate execution of LMDIF1. In this case se +1 +0 Page +0 IFLAG to a negative integer. +0 M is a positive integer input variable set to the number of + functions. +0 N is a positive integer input variable set to the number of + variables. N must not exceed M. +0 X is an array of length N. On input X must contain an initial + estimate of the solution vector. On output X contains the + final estimate of the solution vector. +0 FVEC is an output array of length M which contains the function + evaluated at the output X. +0 TOL is a nonnegative input variable. Termination occurs when + the algorithm estimates either that the relative error in the + sum of squares is at most TOL or that the relative error + between X and the solution is at most TOL. Section 4 contain + more details about TOL. +0 INFO is an integer output variable. If the user has terminated + execution, INFO is set to the (negative) value of IFLAG. See + description of FCN. Otherwise, INFO is set as follows. +0 INFO = 0 Improper input parameters. +0 INFO = 1 Algorithm estimates that the relative error in the + sum of squares is at most TOL. +0 INFO = 2 Algorithm estimates that the relative error between + X and the solution is at most TOL. +0 INFO = 3 Conditions for INFO = 1 and INFO = 2 both hold. +0 INFO = 4 FVEC is orthogonal to the columns of the Jacobian t + machine precision. +0 INFO = 5 Number of calls to FCN has reached or exceeded + 200*(N+1). +0 INFO = 6 TOL is too small. No further reduction in the sum + of squares is possible. +0 INFO = 7 TOL is too small. No further improvement in the + approximate solution X is possible. +0 Sections 4 and 5 contain more details about INFO. +0 IWA is an integer work array of length N. +0 WA is a work array of length LWA. +0 LWA is a positive integer input variable not less than +1 +0 Page +0 M*N+5*N+M. +0 + 4. Successful completion. +0 The accuracy of LMDIF1 is controlled by the convergence parame- + ter TOL. This parameter is used in tests which make three type + of comparisons between the approximation X and a solution XSOL. + LMDIF1 terminates when any of the tests is satisfied. If TOL i + less than the machine precision (as defined by the MINPACK func + tion DPMPAR(1)), then LMDIF1 only attempts to satisfy the test + defined by the machine precision. Further progress is not usu- + ally possible. Unless high precision solutions are required, + the recommended value for TOL is the square root of the machine + precision. +0 The tests assume that the functions are reasonably well behaved + If this condition is not satisfied, then LMDIF1 may incorrectly + indicate convergence. The validity of the answer can be + checked, for example, by rerunning LMDIF1 with a tighter toler- + ance. +0 First convergence test. If ENORM(Z) denotes the Euclidean norm + of a vector Z, then this test attempts to guarantee that +0 ENORM(FVEC) .LE. (1+TOL)*ENORM(FVECS), +0 where FVECS denotes the functions evaluated at XSOL. If this + condition is satisfied with TOL = 10**(-K), then the final + residual norm ENORM(FVEC) has K significant decimal digits an + INFO is set to 1 (or to 3 if the second test is also satis- + fied). +0 Second convergence test. If D is a diagonal matrix (implicitly + generated by LMDIF1) whose entries contain scale factors for + the variables, then this test attempts to guarantee that +0 ENORM(D*(X-XSOL)) .LE. TOL*ENORM(D*XSOL). +0 If this condition is satisfied with TOL = 10**(-K), then the + larger components of D*X have K significant decimal digits an + INFO is set to 2 (or to 3 if the first test is also satis- + fied). There is a danger that the smaller components of D*X + may have large relative errors, but the choice of D is such + that the accuracy of the components of X is usually related t + their sensitivity. +0 Third convergence test. This test is satisfied when FVEC is + orthogonal to the columns of the Jacobian to machine preci- + sion. There is no clear relationship between this test and + the accuracy of LMDIF1, and furthermore, the test is equally + well satisfied at other critical points, namely maximizers an + saddle points. Also, errors in the functions (see below) may + result in the test being satisfied at a point not close to th +1 +0 Page +0 minimum. Therefore, termination caused by this test + (INFO = 4) should be examined carefully. +0 + 5. Unsuccessful completion. +0 Unsuccessful termination of LMDIF1 can be due to improper input + parameters, arithmetic interrupts, an excessive number of func- + tion evaluations, or errors in the functions. +0 Improper input parameters. INFO is set to 0 if N .LE. 0, or + M .LT. N, or TOL .LT. 0.D0, or LWA .LT. M*N+5*N+M. +0 Arithmetic interrupts. If these interrupts occur in the FCN + subroutine during an early stage of the computation, they may + be caused by an unacceptable choice of X by LMDIF1. In this + case, it may be possible to remedy the situation by not evalu + ating the functions here, but instead setting the components + of FVEC to numbers that exceed those in the initial FVEC, + thereby indirectly reducing the step length. The step length + can be more directly controlled by using instead LMDIF, which + includes in its calling sequence the step-length-governing + parameter FACTOR. +0 Excessive number of function evaluations. If the number of + calls to FCN reaches 200*(N+1), then this indicates that the + routine is converging very slowly as measured by the progress + of FVEC, and INFO is set to 5. In this case, it may be help- + ful to restart LMDIF1, thereby forcing it to disregard old + (and possibly harmful) information. +0 Errors in the functions. The choice of step length in the for- + ward-difference approximation to the Jacobian assumes that th + relative errors in the functions are of the order of the + machine precision. If this is not the case, LMDIF1 may fail + (usually with INFO = 4). The user should then use LMDIF + instead, or one of the programs which require the analytic + Jacobian (LMDER1 and LMDER). +0 + 6. Characteristics of the algorithm. +0 LMDIF1 is a modification of the Levenberg-Marquardt algorithm. + Two of its main characteristics involve the proper use of + implicitly scaled variables and an optimal choice for the cor- + rection. The use of implicitly scaled variables achieves scale + invariance of LMDIF1 and limits the size of the correction in + any direction where the functions are changing rapidly. The + optimal choice of the correction guarantees (under reasonable + conditions) global convergence from starting points far from th + solution and a fast rate of convergence for problems with small + residuals. +0 Timing. The time required by LMDIF1 to solve a given problem +1 +0 Page +0 depends on M and N, the behavior of the functions, the accu- + racy requested, and the starting point. The number of arith- + metic operations needed by LMDIF1 is about N**3 to process + each evaluation of the functions (one call to FCN) and + M*(N**2) to process each approximation to the Jacobian (N + calls to FCN). Unless FCN can be evaluated quickly, the tim- + ing of LMDIF1 will be strongly influenced by the time spent i + FCN. +0 Storage. LMDIF1 requires M*N + 2*M + 6*N double precision sto- + rage locations and N integer storage locations, in addition t + the storage required by the program. There are no internally + declared storage arrays. +0 + 7. Subprograms required. +0 USER-supplied ...... FCN +0 MINPACK-supplied ... DPMPAR,ENORM,FDJAC2,LMDIF,LMPAR, + QRFAC,QRSOLV +0 FORTRAN-supplied ... DABS,DMAX1,DMIN1,DSQRT,MOD +0 + 8. References. +0 Jorge J. More, The Levenberg-Marquardt Algorithm, Implementatio + and Theory. Numerical Analysis, G. A. Watson, editor. + Lecture Notes in Mathematics 630, Springer-Verlag, 1977. +0 + 9. Example. +0 The problem is to determine the values of x(1), x(2), and x(3) + which provide the best fit (in the least squares sense) of +0 x(1) + u(i)/(v(i)*x(2) + w(i)*x(3)), i = 1, 15 +0 to the data +0 y = (0.14,0.18,0.22,0.25,0.29,0.32,0.35,0.39, + 0.37,0.58,0.73,0.96,1.34,2.10,4.39), +0 where u(i) = i, v(i) = 16 - i, and w(i) = min(u(i),v(i)). The + i-th component of FVEC is thus defined by +0 y(i) - (x(1) + u(i)/(v(i)*x(2) + w(i)*x(3))). +0 C ********** + C + C DRIVER FOR LMDIF1 EXAMPLE. + C DOUBLE PRECISION VERSION + C +1 +0 Page +0 C ********** + INTEGER J,M,N,INFO,LWA,NWRITE + INTEGER IWA(3) + DOUBLE PRECISION TOL,FNORM + DOUBLE PRECISION X(3),FVEC(15),WA(75) + DOUBLE PRECISION ENORM,DPMPAR + EXTERNAL FCN + C + C LOGICAL OUTPUT UNIT IS ASSUMED TO BE NUMBER 6. + C + DATA NWRITE /6/ + C + M = 15 + N = 3 + C + C THE FOLLOWING STARTING VALUES PROVIDE A ROUGH FIT. + C + X(1) = 1.D0 + X(2) = 1.D0 + X(3) = 1.D0 + C + LWA = 75 + C + C SET TOL TO THE SQUARE ROOT OF THE MACHINE PRECISION. + C UNLESS HIGH PRECISION SOLUTIONS ARE REQUIRED, + C THIS IS THE RECOMMENDED SETTING. + C + TOL = DSQRT(DPMPAR(1)) + C + CALL LMDIF1(FCN,M,N,X,FVEC,TOL,INFO,IWA,WA,LWA) + FNORM = ENORM(M,FVEC) + WRITE (NWRITE,1000) FNORM,INFO,(X(J),J=1,N) + STOP + 1000 FORMAT (5X,31H FINAL L2 NORM OF THE RESIDUALS,D15.7 // + * 5X,15H EXIT PARAMETER,16X,I10 // + * 5X,27H FINAL APPROXIMATE SOLUTION // 5X,3D15.7) + C + C LAST CARD OF DRIVER FOR LMDIF1 EXAMPLE. + C + END + SUBROUTINE FCN(M,N,X,FVEC,IFLAG) + INTEGER M,N,IFLAG + DOUBLE PRECISION X(N),FVEC(M) + C + C SUBROUTINE FCN FOR LMDIF1 EXAMPLE. + C + INTEGER I + DOUBLE PRECISION TMP1,TMP2,TMP3 + DOUBLE PRECISION Y(15) + DATA Y(1),Y(2),Y(3),Y(4),Y(5),Y(6),Y(7),Y(8), + * Y(9),Y(10),Y(11),Y(12),Y(13),Y(14),Y(15) + * /1.4D-1,1.8D-1,2.2D-1,2.5D-1,2.9D-1,3.2D-1,3.5D-1,3.9D-1, + * 3.7D-1,5.8D-1,7.3D-1,9.6D-1,1.34D0,2.1D0,4.39D0/ + C +1 +0 Page +0 DO 10 I = 1, 15 + TMP1 = I + TMP2 = 16 - I + TMP3 = TMP1 + IF (I .GT. 8) TMP3 = TMP2 + FVEC(I) = Y(I) - (X(1) + TMP1/(X(2)*TMP2 + X(3)*TMP3)) + 10 CONTINUE + RETURN + C + C LAST CARD OF SUBROUTINE FCN. + C + END +0 Results obtained with different compilers or machines + may be slightly different. +0 FINAL L2 NORM OF THE RESIDUALS 0.9063596D-01 +0 EXIT PARAMETER 1 +0 FINAL APPROXIMATE SOLUTION +0 0.8241057D-01 0.1133037D+01 0.2343695D+01 +1 +0 +1 +0 Page +0 Documentation for MINPACK subroutine LMDIF +0 Double precision version +0 Argonne National Laboratory +0 Burton S. Garbow, Kenneth E. Hillstrom, Jorge J. More +0 March 1980 +0 + 1. Purpose. +0 The purpose of LMDIF is to minimize the sum of the squares of M + nonlinear functions in N variables by a modification of the + Levenberg-Marquardt algorithm. The user must provide a subrou- + tine which calculates the functions. The Jacobian is then cal- + culated by a forward-difference approximation. +0 + 2. Subroutine and type statements. +0 SUBROUTINE LMDIF(FCN,M,N,X,FVEC,FTOL,XTOL,GTOL,MAXFEV,EPSFCN, + * DIAG,MODE,FACTOR,NPRINT,INFO,NFEV,FJAC,LDFJAC, + * IPVT,QTF,WA1,WA2,WA3,WA4) + INTEGER M,N,MAXFEV,MODE,NPRINT,INFO,NFEV,LDFJAC + INTEGER IPVT(N) + DOUBLE PRECISION FTOL,XTOL,GTOL,EPSFCN,FACTOR + DOUBLE PRECISION X(N),FVEC(M),DIAG(N),FJAC(LDFJAC,N),QTF(N), + * WA1(N),WA2(N),WA3(N),WA4(M) + EXTERNAL FCN +0 + 3. Parameters. +0 Parameters designated as input parameters must be specified on + entry to LMDIF and are not changed on exit, while parameters + designated as output parameters need not be specified on entry + and are set to appropriate values on exit from LMDIF. +0 FCN is the name of the user-supplied subroutine which calculate + the functions. FCN must be declared in an EXTERNAL statement + in the user calling program, and should be written as follows +0 SUBROUTINE FCN(M,N,X,FVEC,IFLAG) + INTEGER M,N,IFLAG + DOUBLE PRECISION X(N),FVEC(M) + ---------- + CALCULATE THE FUNCTIONS AT X AND + RETURN THIS VECTOR IN FVEC. + ---------- + RETURN + END +1 +0 Page +0 The value of IFLAG should not be changed by FCN unless the + user wants to terminate execution of LMDIF. In this case set + IFLAG to a negative integer. +0 M is a positive integer input variable set to the number of + functions. +0 N is a positive integer input variable set to the number of + variables. N must not exceed M. +0 X is an array of length N. On input X must contain an initial + estimate of the solution vector. On output X contains the + final estimate of the solution vector. +0 FVEC is an output array of length M which contains the function + evaluated at the output X. +0 FTOL is a nonnegative input variable. Termination occurs when + both the actual and predicted relative reductions in the sum + of squares are at most FTOL. Therefore, FTOL measures the + relative error desired in the sum of squares. Section 4 con- + tains more details about FTOL. +0 XTOL is a nonnegative input variable. Termination occurs when + the relative error between two consecutive iterates is at mos + XTOL. Therefore, XTOL measures the relative error desired in + the approximate solution. Section 4 contains more details + about XTOL. +0 GTOL is a nonnegative input variable. Termination occurs when + the cosine of the angle between FVEC and any column of the + Jacobian is at most GTOL in absolute value. Therefore, GTOL + measures the orthogonality desired between the function vecto + and the columns of the Jacobian. Section 4 contains more + details about GTOL. +0 MAXFEV is a positive integer input variable. Termination occur + when the number of calls to FCN is at least MAXFEV by the end + of an iteration. +0 EPSFCN is an input variable used in determining a suitable step + for the forward-difference approximation. This approximation + assumes that the relative errors in the functions are of the + order of EPSFCN. If EPSFCN is less than the machine preci- + sion, it is assumed that the relative errors in the functions + are of the order of the machine precision. +0 DIAG is an array of length N. If MODE = 1 (see below), DIAG is + internally set. If MODE = 2, DIAG must contain positive + entries that serve as multiplicative scale factors for the + variables. +0 MODE is an integer input variable. If MODE = 1, the variables + will be scaled internally. If MODE = 2, the scaling is +1 +0 Page +0 specified by the input DIAG. Other values of MODE are equiva + lent to MODE = 1. +0 FACTOR is a positive input variable used in determining the ini + tial step bound. This bound is set to the product of FACTOR + and the Euclidean norm of DIAG*X if nonzero, or else to FACTO + itself. In most cases FACTOR should lie in the interval + (.1,100.). 100. is a generally recommended value. +0 NPRINT is an integer input variable that enables controlled + printing of iterates if it is positive. In this case, FCN is + called with IFLAG = 0 at the beginning of the first iteration + and every NPRINT iterations thereafter and immediately prior + to return, with X and FVEC available for printing. If NPRINT + is not positive, no special calls of FCN with IFLAG = 0 are + made. +0 INFO is an integer output variable. If the user has terminated + execution, INFO is set to the (negative) value of IFLAG. See + description of FCN. Otherwise, INFO is set as follows. +0 INFO = 0 Improper input parameters. +0 INFO = 1 Both actual and predicted relative reductions in th + sum of squares are at most FTOL. +0 INFO = 2 Relative error between two consecutive iterates is + at most XTOL. +0 INFO = 3 Conditions for INFO = 1 and INFO = 2 both hold. +0 INFO = 4 The cosine of the angle between FVEC and any column + of the Jacobian is at most GTOL in absolute value. +0 INFO = 5 Number of calls to FCN has reached or exceeded + MAXFEV. +0 INFO = 6 FTOL is too small. No further reduction in the sum + of squares is possible. +0 INFO = 7 XTOL is too small. No further improvement in the + approximate solution X is possible. +0 INFO = 8 GTOL is too small. FVEC is orthogonal to the + columns of the Jacobian to machine precision. +0 Sections 4 and 5 contain more details about INFO. +0 NFEV is an integer output variable set to the number of calls t + FCN. +0 FJAC is an output M by N array. The upper N by N submatrix of + FJAC contains an upper triangular matrix R with diagonal ele- + ments of nonincreasing magnitude such that +1 +0 Page +0 T T T + P *(JAC *JAC)*P = R *R, +0 where P is a permutation matrix and JAC is the final calcu- + lated Jacobian. Column j of P is column IPVT(j) (see below) + of the identity matrix. The lower trapezoidal part of FJAC + contains information generated during the computation of R. +0 LDFJAC is a positive integer input variable not less than M + which specifies the leading dimension of the array FJAC. +0 IPVT is an integer output array of length N. IPVT defines a + permutation matrix P such that JAC*P = Q*R, where JAC is the + final calculated Jacobian, Q is orthogonal (not stored), and + is upper triangular with diagonal elements of nonincreasing + magnitude. Column j of P is column IPVT(j) of the identity + matrix. +0 QTF is an output array of length N which contains the first N + elements of the vector (Q transpose)*FVEC. +0 WA1, WA2, and WA3 are work arrays of length N. +0 WA4 is a work array of length M. +0 + 4. Successful completion. +0 The accuracy of LMDIF is controlled by the convergence parame- + ters FTOL, XTOL, and GTOL. These parameters are used in tests + which make three types of comparisons between the approximation + X and a solution XSOL. LMDIF terminates when any of the tests + is satisfied. If any of the convergence parameters is less tha + the machine precision (as defined by the MINPACK function + DPMPAR(1)), then LMDIF only attempts to satisfy the test define + by the machine precision. Further progress is not usually pos- + sible. +0 The tests assume that the functions are reasonably well behaved + If this condition is not satisfied, then LMDIF may incorrectly + indicate convergence. The validity of the answer can be + checked, for example, by rerunning LMDIF with tighter toler- + ances. +0 First convergence test. If ENORM(Z) denotes the Euclidean norm + of a vector Z, then this test attempts to guarantee that +0 ENORM(FVEC) .LE. (1+FTOL)*ENORM(FVECS), +0 where FVECS denotes the functions evaluated at XSOL. If this + condition is satisfied with FTOL = 10**(-K), then the final + residual norm ENORM(FVEC) has K significant decimal digits an + INFO is set to 1 (or to 3 if the second test is also satis- + fied). Unless high precision solutions are required, the +1 +0 Page +0 recommended value for FTOL is the square root of the machine + precision. +0 Second convergence test. If D is the diagonal matrix whose + entries are defined by the array DIAG, then this test attempt + to guarantee that +0 ENORM(D*(X-XSOL)) .LE. XTOL*ENORM(D*XSOL). +0 If this condition is satisfied with XTOL = 10**(-K), then the + larger components of D*X have K significant decimal digits an + INFO is set to 2 (or to 3 if the first test is also satis- + fied). There is a danger that the smaller components of D*X + may have large relative errors, but if MODE = 1, then the + accuracy of the components of X is usually related to their + sensitivity. Unless high precision solutions are required, + the recommended value for XTOL is the square root of the + machine precision. +0 Third convergence test. This test is satisfied when the cosine + of the angle between FVEC and any column of the Jacobian at X + is at most GTOL in absolute value. There is no clear rela- + tionship between this test and the accuracy of LMDIF, and + furthermore, the test is equally well satisfied at other crit + ical points, namely maximizers and saddle points. Therefore, + termination caused by this test (INFO = 4) should be examined + carefully. The recommended value for GTOL is zero. +0 + 5. Unsuccessful completion. +0 Unsuccessful termination of LMDIF can be due to improper input + parameters, arithmetic interrupts, or an excessive number of + function evaluations. +0 Improper input parameters. INFO is set to 0 if N .LE. 0, or + M .LT. N, or LDFJAC .LT. M, or FTOL .LT. 0.D0, or + XTOL .LT. 0.D0, or GTOL .LT. 0.D0, or MAXFEV .LE. 0, or + FACTOR .LE. 0.D0. +0 Arithmetic interrupts. If these interrupts occur in the FCN + subroutine during an early stage of the computation, they may + be caused by an unacceptable choice of X by LMDIF. In this + case, it may be possible to remedy the situation by rerunning + LMDIF with a smaller value of FACTOR. +0 Excessive number of function evaluations. A reasonable value + for MAXFEV is 200*(N+1). If the number of calls to FCN + reaches MAXFEV, then this indicates that the routine is con- + verging very slowly as measured by the progress of FVEC, and + INFO is set to 5. In this case, it may be helpful to restart + LMDIF with MODE set to 1. +0 +1 +0 Page +0 6. Characteristics of the algorithm. +0 LMDIF is a modification of the Levenberg-Marquardt algorithm. + Two of its main characteristics involve the proper use of + implicitly scaled variables (if MODE = 1) and an optimal choice + for the correction. The use of implicitly scaled variables + achieves scale invariance of LMDIF and limits the size of the + correction in any direction where the functions are changing + rapidly. The optimal choice of the correction guarantees (unde + reasonable conditions) global convergence from starting points + far from the solution and a fast rate of convergence for prob- + lems with small residuals. +0 Timing. The time required by LMDIF to solve a given problem + depends on M and N, the behavior of the functions, the accu- + racy requested, and the starting point. The number of arith- + metic operations needed by LMDIF is about N**3 to process eac + evaluation of the functions (one call to FCN) and M*(N**2) to + process each approximation to the Jacobian (N calls to FCN). + Unless FCN can be evaluated quickly, the timing of LMDIF will + be strongly influenced by the time spent in FCN. +0 Storage. LMDIF requires M*N + 2*M + 6*N double precision sto- + rage locations and N integer storage locations, in addition t + the storage required by the program. There are no internally + declared storage arrays. +0 + 7. Subprograms required. +0 USER-supplied ...... FCN +0 MINPACK-supplied ... DPMPAR,ENORM,FDJAC2,LMPAR,QRFAC,QRSOLV +0 FORTRAN-supplied ... DABS,DMAX1,DMIN1,DSQRT,MOD +0 + 8. References. +0 Jorge J. More, The Levenberg-Marquardt Algorithm, Implementatio + and Theory. Numerical Analysis, G. A. Watson, editor. + Lecture Notes in Mathematics 630, Springer-Verlag, 1977. +0 + 9. Example. +0 The problem is to determine the values of x(1), x(2), and x(3) + which provide the best fit (in the least squares sense) of +0 x(1) + u(i)/(v(i)*x(2) + w(i)*x(3)), i = 1, 15 +0 to the data +1 +0 Page +0 y = (0.14,0.18,0.22,0.25,0.29,0.32,0.35,0.39, + 0.37,0.58,0.73,0.96,1.34,2.10,4.39), +0 where u(i) = i, v(i) = 16 - i, and w(i) = min(u(i),v(i)). The + i-th component of FVEC is thus defined by +0 y(i) - (x(1) + u(i)/(v(i)*x(2) + w(i)*x(3))). +0 C ********** + C + C DRIVER FOR LMDIF EXAMPLE. + C DOUBLE PRECISION VERSION + C + C ********** + INTEGER J,M,N,MAXFEV,MODE,NPRINT,INFO,NFEV,LDFJAC,NWRITE + INTEGER IPVT(3) + DOUBLE PRECISION FTOL,XTOL,GTOL,EPSFCN,FACTOR,FNORM + DOUBLE PRECISION X(3),FVEC(15),DIAG(3),FJAC(15,3),QTF(3), + * WA1(3),WA2(3),WA3(3),WA4(15) + DOUBLE PRECISION ENORM,DPMPAR + EXTERNAL FCN + C + C LOGICAL OUTPUT UNIT IS ASSUMED TO BE NUMBER 6. + C + DATA NWRITE /6/ + C + M = 15 + N = 3 + C + C THE FOLLOWING STARTING VALUES PROVIDE A ROUGH FIT. + C + X(1) = 1.D0 + X(2) = 1.D0 + X(3) = 1.D0 + C + LDFJAC = 15 + C + C SET FTOL AND XTOL TO THE SQUARE ROOT OF THE MACHINE PRECISION + C AND GTOL TO ZERO. UNLESS HIGH PRECISION SOLUTIONS ARE + C REQUIRED, THESE ARE THE RECOMMENDED SETTINGS. + C + FTOL = DSQRT(DPMPAR(1)) + XTOL = DSQRT(DPMPAR(1)) + GTOL = 0.D0 + C + MAXFEV = 800 + EPSFCN = 0.D0 + MODE = 1 + FACTOR = 1.D2 + NPRINT = 0 + C + CALL LMDIF(FCN,M,N,X,FVEC,FTOL,XTOL,GTOL,MAXFEV,EPSFCN, + * DIAG,MODE,FACTOR,NPRINT,INFO,NFEV,FJAC,LDFJAC, + * IPVT,QTF,WA1,WA2,WA3,WA4) +1 +0 Page +0 FNORM = ENORM(M,FVEC) + WRITE (NWRITE,1000) FNORM,NFEV,INFO,(X(J),J=1,N) + STOP + 1000 FORMAT (5X,31H FINAL L2 NORM OF THE RESIDUALS,D15.7 // + * 5X,31H NUMBER OF FUNCTION EVALUATIONS,I10 // + * 5X,15H EXIT PARAMETER,16X,I10 // + * 5X,27H FINAL APPROXIMATE SOLUTION // 5X,3D15.7) + C + C LAST CARD OF DRIVER FOR LMDIF EXAMPLE. + C + END + SUBROUTINE FCN(M,N,X,FVEC,IFLAG) + INTEGER M,N,IFLAG + DOUBLE PRECISION X(N),FVEC(M) + C + C SUBROUTINE FCN FOR LMDIF EXAMPLE. + C + INTEGER I + DOUBLE PRECISION TMP1,TMP2,TMP3 + DOUBLE PRECISION Y(15) + DATA Y(1),Y(2),Y(3),Y(4),Y(5),Y(6),Y(7),Y(8), + * Y(9),Y(10),Y(11),Y(12),Y(13),Y(14),Y(15) + * /1.4D-1,1.8D-1,2.2D-1,2.5D-1,2.9D-1,3.2D-1,3.5D-1,3.9D-1, + * 3.7D-1,5.8D-1,7.3D-1,9.6D-1,1.34D0,2.1D0,4.39D0/ + C + IF (IFLAG .NE. 0) GO TO 5 + C + C INSERT PRINT STATEMENTS HERE WHEN NPRINT IS POSITIVE. + C + RETURN + 5 CONTINUE + DO 10 I = 1, 15 + TMP1 = I + TMP2 = 16 - I + TMP3 = TMP1 + IF (I .GT. 8) TMP3 = TMP2 + FVEC(I) = Y(I) - (X(1) + TMP1/(X(2)*TMP2 + X(3)*TMP3)) + 10 CONTINUE + RETURN + C + C LAST CARD OF SUBROUTINE FCN. + C + END +0 Results obtained with different compilers or machines + may be slightly different. +0 FINAL L2 NORM OF THE RESIDUALS 0.9063596D-01 +0 NUMBER OF FUNCTION EVALUATIONS 21 +0 EXIT PARAMETER 1 +0 FINAL APPROXIMATE SOLUTION +1 +0 Page +0 0.8241057D-01 0.1133037D+01 0.2343695D+01 +1 +0 +1 +0 Page +0 Documentation for MINPACK subroutine CHKDER +0 Double precision version +0 Argonne National Laboratory +0 Burton S. Garbow, Kenneth E. Hillstrom, Jorge J. More +0 March 1980 +0 + 1. Purpose. +0 The purpose of CHKDER is to check the gradients of M nonlinear + functions in N variables, evaluated at a point X, for consis- + tency with the functions themselves. The user must call CHKDER + twice, first with MODE = 1 and then with MODE = 2. +0 + 2. Subroutine and type statements. +0 SUBROUTINE CHKDER(M,N,X,FVEC,FJAC,LDFJAC,XP,FVECP,MODE,ERR) + INTEGER M,N,LDFJAC,MODE + DOUBLE PRECISION X(N),FVEC(M),FJAC(LDFJAC,N),XP(N),FVECP(M), + * ERR(M) +0 + 3. Parameters. +0 Parameters designated as input parameters must be specified on + entry to CHKDER and are not changed on exit, while parameters + designated as output parameters need not be specified on entry + and are set to appropriate values on exit from CHKDER. +0 M is a positive integer input variable set to the number of + functions. +0 N is a positive integer input variable set to the number of + variables. +0 X is an input array of length N. +0 FVEC is an array of length M. On input when MODE = 2, FVEC mus + contain the functions evaluated at X. +0 FJAC is an M by N array. On input when MODE = 2, the rows of + FJAC must contain the gradients of the respective functions + evaluated at X. +0 LDFJAC is a positive integer input variable not less than M + which specifies the leading dimension of the array FJAC. +0 XP is an array of length N. On output when MODE = 1, XP is set + to a neighboring point of X. +1 +0 Page +0 FVECP is an array of length M. On input when MODE = 2, FVECP + must contain the functions evaluated at XP. +0 MODE is an integer input variable set to 1 on the first call an + 2 on the second. Other values of MODE are equivalent to + MODE = 1. +0 ERR is an array of length M. On output when MODE = 2, ERR con- + tains measures of correctness of the respective gradients. I + there is no severe loss of significance, then if ERR(I) is 1. + the I-th gradient is correct, while if ERR(I) is 0.0 the I-th + gradient is incorrect. For values of ERR between 0.0 and 1.0 + the categorization is less certain. In general, a value of + ERR(I) greater than 0.5 indicates that the I-th gradient is + probably correct, while a value of ERR(I) less than 0.5 indi- + cates that the I-th gradient is probably incorrect. +0 + 4. Successful completion. +0 CHKDER usually guarantees that if ERR(I) is 1.0, then the I-th + gradient at X is consistent with the I-th function. This sug- + gests that the input X be such that consistency of the gradient + at X implies consistency of the gradient at all points of inter + est. If all the components of X are distinct and the fractiona + part of each one has two nonzero digits, then X is likely to be + a satisfactory choice. +0 If ERR(I) is not 1.0 but is greater than 0.5, then the I-th gra + dient is probably consistent with the I-th function (the more s + the larger ERR(I) is), but the conditions for ERR(I) to be 1.0 + have not been completely satisfied. In this case, it is recom- + mended that CHKDER be rerun with other input values of X. If + ERR(I) is always greater than 0.5, then the I-th gradient is + consistent with the I-th function. +0 + 5. Unsuccessful completion. +0 CHKDER does not perform reliably if cancellation or rounding + errors cause a severe loss of significance in the evaluation of + a function. Therefore, none of the components of X should be + unusually small (in particular, zero) or any other value which + may cause loss of significance. The relative differences + between corresponding elements of FVECP and FVEC should be at + least two orders of magnitude greater than the machine precisio + (as defined by the MINPACK function DPMPAR(1)). If there is a + severe loss of significance in the evaluation of the I-th func- + tion, then ERR(I) may be 0.0 and yet the I-th gradient could be + correct. +0 If ERR(I) is not 0.0 but is less than 0.5, then the I-th gra- + dient is probably not consistent with the I-th function (the + more so the smaller ERR(I) is), but the conditions for ERR(I) t +1 +0 Page +0 be 0.0 have not been completely satisfied. In this case, it is + recommended that CHKDER be rerun with other input values of X. + If ERR(I) is always less than 0.5 and if there is no severe los + of significance, then the I-th gradient is not consistent with + the I-th function. +0 + 6. Characteristics of the algorithm. +0 CHKDER checks the I-th gradient for consistency with the I-th + function by computing a forward-difference approximation along + suitably chosen direction and comparing this approximation with + the user-supplied gradient along the same direction. The prin- + cipal characteristic of CHKDER is its invariance to changes in + scale of the variables or functions. +0 Timing. The time required by CHKDER depends only on M and N. + The number of arithmetic operations needed by CHKDER is about + N when MODE = 1 and M*N when MODE = 2. +0 Storage. CHKDER requires M*N + 3*M + 2*N double precision stor + age locations, in addition to the storage required by the pro + gram. There are no internally declared storage arrays. +0 + 7. Subprograms required. +0 MINPACK-supplied ... DPMPAR +0 FORTRAN-supplied ... DABS,DLOG10,DSQRT +0 + 8. References. +0 None. +0 + 9. Example. +0 This example checks the Jacobian matrix for the problem that + determines the values of x(1), x(2), and x(3) which provide the + best fit (in the least squares sense) of +0 x(1) + u(i)/(v(i)*x(2) + w(i)*x(3)), i = 1, 15 +0 to the data +0 y = (0.14,0.18,0.22,0.25,0.29,0.32,0.35,0.39, + 0.37,0.58,0.73,0.96,1.34,2.10,4.39), +0 where u(i) = i, v(i) = 16 - i, and w(i) = min(u(i),v(i)). The + i-th component of FVEC is thus defined by +0 y(i) - (x(1) + u(i)/(v(i)*x(2) + w(i)*x(3))). +1 +0 Page +0 C ********** + C + C DRIVER FOR CHKDER EXAMPLE. + C DOUBLE PRECISION VERSION + C + C ********** + INTEGER I,M,N,LDFJAC,MODE,NWRITE + DOUBLE PRECISION X(3),FVEC(15),FJAC(15,3),XP(3),FVECP(15), + * ERR(15) + C + C LOGICAL OUTPUT UNIT IS ASSUMED TO BE NUMBER 6. + C + DATA NWRITE /6/ + C + M = 15 + N = 3 + C + C THE FOLLOWING VALUES SHOULD BE SUITABLE FOR + C CHECKING THE JACOBIAN MATRIX. + C + X(1) = 9.2D-1 + X(2) = 1.3D-1 + X(3) = 5.4D-1 + C + LDFJAC = 15 + C + MODE = 1 + CALL CHKDER(M,N,X,FVEC,FJAC,LDFJAC,XP,FVECP,MODE,ERR) + MODE = 2 + CALL FCN(M,N,X,FVEC,FJAC,LDFJAC,1) + CALL FCN(M,N,X,FVEC,FJAC,LDFJAC,2) + CALL FCN(M,N,XP,FVECP,FJAC,LDFJAC,1) + CALL CHKDER(M,N,X,FVEC,FJAC,LDFJAC,XP,FVECP,MODE,ERR) + C + DO 10 I = 1, M + FVECP(I) = FVECP(I) - FVEC(I) + 10 CONTINUE + WRITE (NWRITE,1000) (FVEC(I),I=1,M) + WRITE (NWRITE,2000) (FVECP(I),I=1,M) + WRITE (NWRITE,3000) (ERR(I),I=1,M) + STOP + 1000 FORMAT (/5X,5H FVEC // (5X,3D15.7)) + 2000 FORMAT (/5X,13H FVECP - FVEC // (5X,3D15.7)) + 3000 FORMAT (/5X,4H ERR // (5X,3D15.7)) + C + C LAST CARD OF DRIVER FOR CHKDER EXAMPLE. + C + END + SUBROUTINE FCN(M,N,X,FVEC,FJAC,LDFJAC,IFLAG) + INTEGER M,N,LDFJAC,IFLAG + DOUBLE PRECISION X(N),FVEC(M),FJAC(LDFJAC,N) + C + C SUBROUTINE FCN FOR CHKDER EXAMPLE. + C +1 +0 Page +0 INTEGER I + DOUBLE PRECISION TMP1,TMP2,TMP3,TMP4 + DOUBLE PRECISION Y(15) + DATA Y(1),Y(2),Y(3),Y(4),Y(5),Y(6),Y(7),Y(8), + * Y(9),Y(10),Y(11),Y(12),Y(13),Y(14),Y(15) + * /1.4D-1,1.8D-1,2.2D-1,2.5D-1,2.9D-1,3.2D-1,3.5D-1,3.9D-1, + * 3.7D-1,5.8D-1,7.3D-1,9.6D-1,1.34D0,2.1D0,4.39D0/ + C + IF (IFLAG .EQ. 2) GO TO 20 + DO 10 I = 1, 15 + TMP1 = I + TMP2 = 16 - I + TMP3 = TMP1 + IF (I .GT. 8) TMP3 = TMP2 + FVEC(I) = Y(I) - (X(1) + TMP1/(X(2)*TMP2 + X(3)*TMP3)) + 10 CONTINUE + GO TO 40 + 20 CONTINUE + DO 30 I = 1, 15 + TMP1 = I + TMP2 = 16 - I + C + C ERROR INTRODUCED INTO NEXT STATEMENT FOR ILLUSTRATION. + C CORRECTED STATEMENT SHOULD READ TMP3 = TMP1 . + C + TMP3 = TMP2 + IF (I .GT. 8) TMP3 = TMP2 + TMP4 = (X(2)*TMP2 + X(3)*TMP3)**2 + FJAC(I,1) = -1.D0 + FJAC(I,2) = TMP1*TMP2/TMP4 + FJAC(I,3) = TMP1*TMP3/TMP4 + 30 CONTINUE + 40 CONTINUE + RETURN + C + C LAST CARD OF SUBROUTINE FCN. + C + END +0 Results obtained with different compilers or machines + may be different. In particular, the differences + FVECP - FVEC are machine dependent. +0 FVEC +0 -0.1181606D+01 -0.1429655D+01 -0.1606344D+01 + -0.1745269D+01 -0.1840654D+01 -0.1921586D+01 + -0.1984141D+01 -0.2022537D+01 -0.2468977D+01 + -0.2827562D+01 -0.3473582D+01 -0.4437612D+01 + -0.6047662D+01 -0.9267761D+01 -0.1891806D+02 +0 FVECP - FVEC +0 -0.7724666D-08 -0.3432405D-08 -0.2034843D-09 +1 +0 Page +0 0.2313685D-08 0.4331078D-08 0.5984096D-08 + 0.7363281D-08 0.8531470D-08 0.1488591D-07 + 0.2335850D-07 0.3522012D-07 0.5301255D-07 + 0.8266660D-07 0.1419747D-06 0.3198990D-06 +0 ERR +0 0.1141397D+00 0.9943516D-01 0.9674474D-01 + 0.9980447D-01 0.1073116D+00 0.1220445D+00 + 0.1526814D+00 0.1000000D+01 0.1000000D+01 + 0.1000000D+01 0.1000000D+01 0.1000000D+01 + 0.1000000D+01 0.1000000D+01 0.1000000D+01 diff --git a/ex/file07 b/ex/file07 new file mode 100644 index 0000000..c9403b1 --- /dev/null +++ b/ex/file07 @@ -0,0 +1,283 @@ +C ********** +C +C THIS PROGRAM CHECKS THE CONSTANTS OF MACHINE PRECISION AND +C SMALLEST AND LARGEST MACHINE REPRESENTABLE NUMBERS SPECIFIED IN +C FUNCTION SPMPAR, AGAINST THE CORRESPONDING HARDWARE-DETERMINED +C MACHINE CONSTANTS OBTAINED BY SMCHAR, A SUBROUTINE DUE TO +C W. J. CODY. +C +C DATA STATEMENTS IN SPMPAR CORRESPONDING TO THE MACHINE USED MUST +C BE ACTIVATED BY REMOVING C IN COLUMN 1. +C +C THE PRINTED OUTPUT CONSISTS OF THE MACHINE CONSTANTS OBTAINED BY +C SMCHAR AND COMPARISONS OF THE SPMPAR CONSTANTS WITH THEIR +C SMCHAR COUNTERPARTS. DESCRIPTIONS OF THE MACHINE CONSTANTS ARE +C GIVEN IN THE PROLOGUE COMMENTS OF SMCHAR. +C +C SUBPROGRAMS CALLED +C +C MINPACK-SUPPLIED ... SMCHAR,SPMPAR +C +C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. +C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE +C +C ********** + INTEGER IBETA,IEXP,IRND,IT,MACHEP,MAXEXP,MINEXP,NEGEP,NGRD, + * NWRITE + REAL DWARF,EPS,EPSMCH,EPSNEG,GIANT,XMAX,XMIN + REAL RERR(3) + REAL SPMPAR +C +C LOGICAL OUTPUT UNIT IS ASSUMED TO BE NUMBER 6. +C + DATA NWRITE /6/ +C +C DETERMINE THE MACHINE CONSTANTS DYNAMICALLY FROM SMCHAR. +C + CALL SMCHAR(IBETA,IT,IRND,NGRD,MACHEP,NEGEP,IEXP,MINEXP,MAXEXP, + * EPS,EPSNEG,XMIN,XMAX) +C +C COMPARE THE SPMPAR CONSTANTS WITH THEIR SMCHAR COUNTERPARTS AND +C STORE THE RELATIVE DIFFERENCES IN RERR. +C + EPSMCH = SPMPAR(1) + DWARF = SPMPAR(2) + GIANT = SPMPAR(3) + RERR(1) = (EPSMCH - EPS)/EPSMCH + RERR(2) = (DWARF - XMIN)/DWARF + RERR(3) = (XMAX - GIANT)/GIANT +C +C WRITE THE SMCHAR CONSTANTS. +C + WRITE (NWRITE,10) + * IBETA,IT,IRND,NGRD,MACHEP,NEGEP,IEXP,MINEXP,MAXEXP,EPS, + * EPSNEG,XMIN,XMAX +C +C WRITE THE SPMPAR CONSTANTS AND THE RELATIVE DIFFERENCES. +C + WRITE (NWRITE,20) EPSMCH,RERR(1),DWARF,RERR(2),GIANT,RERR(3) + STOP + 10 FORMAT (17H1SMCHAR CONSTANTS /// 8H IBETA =, I6 // 8H IT =, + * I6 // 8H IRND =, I6 // 8H NGRD =, I6 // 9H MACHEP =, + * I6 // 8H NEGEP =, I6 // 7H IEXP =, I6 // 9H MINEXP =, + * I6 // 9H MAXEXP =, I6 // 6H EPS =, E15.7 // 9H EPSNEG =, + * E15.7 // 7H XMIN =, E15.7 // 7H XMAX =, E15.7) + 20 FORMAT ( /// 42H SPMPAR CONSTANTS AND RELATIVE DIFFERENCES /// + * 9H EPSMCH =, E15.7 / 10H RERR(1) =, E15.7 // + * 8H DWARF =, E15.7 / 10H RERR(2) =, E15.7 // 8H GIANT =, + * E15.7 / 10H RERR(3) =, E15.7) +C +C LAST CARD OF DRIVER. +C + END + SUBROUTINE SMCHAR(IBETA,IT,IRND,NGRD,MACHEP,NEGEP,IEXP,MINEXP, + 1 MAXEXP,EPS,EPSNEG,XMIN,XMAX) +C + INTEGER I,IBETA,IEXP,IRND,IT,IZ,J,K,MACHEP,MAXEXP,MINEXP, + 1 MX,NEGEP,NGRD + REAL A,B,BETA,BETAIN,BETAM1,EPS,EPSNEG,ONE,XMAX,XMIN,Y,Z,ZERO +C +C THIS SUBROUTINE IS INTENDED TO DETERMINE THE CHARACTERISTICS +C OF THE FLOATING-POINT ARITHMETIC SYSTEM THAT ARE SPECIFIED +C BELOW. THE FIRST THREE ARE DETERMINED ACCORDING TO AN +C ALGORITHM DUE TO M. MALCOLM, CACM 15 (1972), PP. 949-951, +C INCORPORATING SOME, BUT NOT ALL, OF THE IMPROVEMENTS +C SUGGESTED BY M. GENTLEMAN AND S. MAROVICH, CACM 17 (1974), +C PP. 276-277. +C +C +C IBETA - THE RADIX OF THE FLOATING-POINT REPRESENTATION +C IT - THE NUMBER OF BASE IBETA DIGITS IN THE FLOATING-POINT +C SIGNIFICAND +C IRND - 0 IF FLOATING-POINT ADDITION CHOPS, +C 1 IF FLOATING-POINT ADDITION ROUNDS +C NGRD - THE NUMBER OF GUARD DIGITS FOR MULTIPLICATION. IT IS +C 0 IF IRND=1, OR IF IRND=0 AND ONLY IT BASE IBET +C DIGITS PARTICIPATE IN THE POST NORMALIZATION SHIFT +C OF THE FLOATING-POINT SIGNIFICAND IN MULTIPLICATION +C 1 IF IRND=0 AND MORE THAN IT BASE IBETA DIGITS +C PARTICIPATE IN THE POST NORMALIZATION SHIFT OF THE +C FLOATING-POINT SIGNIFICAND IN MULTIPLICATION +C MACHEP - THE LARGEST NEGATIVE INTEGER SUCH THAT +C 1.0+FLOAT(IBETA)**MACHEP .NE. 1.0, EXCEPT THAT +C MACHEP IS BOUNDED BELOW BY -(IT+3) +C NEGEPS - THE LARGEST NEGATIVE INTEGER SUCH THAT +C 1.0-FLOAT(IBETA)**NEGEPS .NE. 1.0, EXCEPT THAT +C NEGEPS IS BOUNDED BELOW BY -(IT+3) +C IEXP - THE NUMBER OF BITS (DECIMAL PLACES IF IBETA = 10) +C RESERVED FOR THE REPRESENTATION OF THE EXPONENT +C (INCLUDING THE BIAS OR SIGN) OF A FLOATING-POINT +C NUMBER +C MINEXP - THE LARGEST IN MAGNITUDE NEGATIVE INTEGER SUCH THAT +C FLOAT(IBETA)**MINEXP IS A POSITIVE FLOATING-POINT +C NUMBER +C MAXEXP - THE LARGEST POSITIVE INTEGER EXPONENT FOR A FINITE +C FLOATING-POINT NUMBER +C EPS - THE SMALLEST POSITIVE FLOATING-POINT NUMBER SUCH +C THAT 1.0+EPS .NE. 1.0. IN PARTICULAR, IF EITHER +C IBETA = 2 OR IRND = 0, EPS = FLOAT(IBETA)**MACHEP. +C OTHERWISE, EPS = (FLOAT(IBETA)**MACHEP)/2 +C EPSNEG - A SMALL POSITIVE FLOATING-POINT NUMBER SUCH THAT +C 1.0-EPSNEG .NE. 1.0. IN PARTICULAR, IF IBETA = 2 +C OR IRND = 0, EPSNEG = FLOAT(IBETA)**NEGEPS. +C OTHERWISE, EPSNEG = (IBETA**NEGEPS)/2. BECAUSE +C NEGEPS IS BOUNDED BELOW BY -(IT+3), EPSNEG MAY NOT +C BE THE SMALLEST NUMBER WHICH CAN ALTER 1.0 BY +C SUBTRACTION. +C XMIN - THE SMALLEST NON-VANISHING FLOATING-POINT POWER OF TH +C RADIX. IN PARTICULAR, XMIN = FLOAT(IBETA)**MINEXP +C XMAX - THE LARGEST FINITE FLOATING-POINT NUMBER. IN +C PARTICULAR XMAX = (1.0-EPSNEG)*FLOAT(IBETA)**MAXEXP +C NOTE - ON SOME MACHINES XMAX WILL BE ONLY THE +C SECOND, OR PERHAPS THIRD, LARGEST NUMBER, BEING +C TOO SMALL BY 1 OR 2 UNITS IN THE LAST DIGIT OF +C THE SIGNIFICAND. +C +C LATEST REVISION - OCTOBER 22, 1979 +C +C AUTHOR - W. J. CODY +C ARGONNE NATIONAL LABORATORY +C +C----------------------------------------------------------------- + ONE = FLOAT(1) + ZERO = 0.0E0 +C----------------------------------------------------------------- +C DETERMINE IBETA,BETA ALA MALCOLM +C----------------------------------------------------------------- + A = ONE + 10 A = A + A + IF (((A+ONE)-A)-ONE .EQ. ZERO) GO TO 10 + B = ONE + 20 B = B + B + IF ((A+B)-A .EQ. ZERO) GO TO 20 + IBETA = INT((A+B)-A) + BETA = FLOAT(IBETA) +C----------------------------------------------------------------- +C DETERMINE IT, IRND +C----------------------------------------------------------------- + IT = 0 + B = ONE + 100 IT = IT + 1 + B = B * BETA + IF (((B+ONE)-B)-ONE .EQ. ZERO) GO TO 100 + IRND = 0 + BETAM1 = BETA - ONE + IF ((A+BETAM1)-A .NE. ZERO) IRND = 1 +C----------------------------------------------------------------- +C DETERMINE NEGEP, EPSNEG +C----------------------------------------------------------------- + NEGEP = IT + 3 + BETAIN = ONE / BETA + A = ONE +C + DO 200 I = 1, NEGEP + A = A * BETAIN + 200 CONTINUE +C + B = A + 210 IF ((ONE-A)-ONE .NE. ZERO) GO TO 220 + A = A * BETA + NEGEP = NEGEP - 1 + GO TO 210 + 220 NEGEP = -NEGEP + EPSNEG = A + IF ((IBETA .EQ. 2) .OR. (IRND .EQ. 0)) GO TO 300 + A = (A*(ONE+A)) / (ONE+ONE) + IF ((ONE-A)-ONE .NE. ZERO) EPSNEG = A +C----------------------------------------------------------------- +C DETERMINE MACHEP, EPS +C----------------------------------------------------------------- + 300 MACHEP = -IT - 3 + A = B + 310 IF((ONE+A)-ONE .NE. ZERO) GO TO 320 + A = A * BETA + MACHEP = MACHEP + 1 + GO TO 310 + 320 EPS = A + IF ((IBETA .EQ. 2) .OR. (IRND .EQ. 0)) GO TO 350 + A = (A*(ONE+A)) / (ONE+ONE) + IF ((ONE+A)-ONE .NE. ZERO) EPS = A +C----------------------------------------------------------------- +C DETERMINE NGRD +C----------------------------------------------------------------- + 350 NGRD = 0 + IF ((IRND .EQ. 0) .AND. ((ONE+EPS)*ONE-ONE) .NE. ZERO) NGRD = 1 +C----------------------------------------------------------------- +C DETERMINE IEXP, MINEXP, XMIN +C +C LOOP TO DETERMINE LARGEST I AND K = 2**I SUCH THAT +C (1/BETA) ** (2**(I)) +C DOES NOT UNDERFLOW +C EXIT FROM LOOP IS SIGNALED BY AN UNDERFLOW. +C----------------------------------------------------------------- + I = 0 + K = 1 + Z = BETAIN + 400 Y = Z + Z = Y * Y +C----------------------------------------------------------------- +C CHECK FOR UNDERFLOW HERE +C----------------------------------------------------------------- + A = Z * ONE + IF ((A+A .EQ. ZERO) .OR. (ABS(Z) .GE. Y)) GO TO 410 + I = I + 1 + K = K + K + GO TO 400 + 410 IF (IBETA .EQ. 10) GO TO 420 + IEXP = I + 1 + MX = K + K + GO TO 450 +C----------------------------------------------------------------- +C FOR DECIMAL MACHINES ONLY +C----------------------------------------------------------------- + 420 IEXP = 2 + IZ = IBETA + 430 IF (K .LT. IZ) GO TO 440 + IZ = IZ * IBETA + IEXP = IEXP + 1 + GO TO 430 + 440 MX = IZ + IZ - 1 +C----------------------------------------------------------------- +C LOOP TO DETERMINE MINEXP, XMIN +C EXIT FROM LOOP IS SIGNALED BY AN UNDERFLOW. +C----------------------------------------------------------------- + 450 XMIN = Y + Y = Y * BETAIN +C----------------------------------------------------------------- +C CHECK FOR UNDERFLOW HERE +C----------------------------------------------------------------- + A = Y * ONE + IF (((A+A) .EQ. ZERO) .OR. (ABS(Y) .GE. XMIN)) GO TO 460 + K = K + 1 + GO TO 450 + 460 MINEXP = -K +C----------------------------------------------------------------- +C DETERMINE MAXEXP, XMAX +C----------------------------------------------------------------- + IF ((MX .GT. K+K-3) .OR. (IBETA .EQ. 10)) GO TO 500 + MX = MX + MX + IEXP = IEXP + 1 + 500 MAXEXP = MX + MINEXP +C----------------------------------------------------------------- +C ADJUST FOR MACHINES WITH IMPLICIT LEADING +C BIT IN BINARY SIGNIFICAND AND MACHINES WITH +C RADIX POINT AT EXTREME RIGHT OF SIGNIFICAND +C----------------------------------------------------------------- + I = MAXEXP + MINEXP + IF ((IBETA .EQ. 2) .AND. (I .EQ. 0)) MAXEXP = MAXEXP - 1 + IF (I .GT. 20) MAXEXP = MAXEXP - 1 + IF (A .NE. Y) MAXEXP = MAXEXP - 2 + XMAX = ONE - EPSNEG + IF (XMAX*ONE .NE. XMAX) XMAX = ONE - BETA * EPSNEG + XMAX = XMAX / (BETA * BETA * BETA * XMIN) + I = MAXEXP + MINEXP + 3 + IF (I .LE. 0) GO TO 520 +C + DO 510 J = 1, I + IF (IBETA .EQ. 2) XMAX = XMAX + XMAX + IF (IBETA .NE. 2) XMAX = XMAX * BETA + 510 CONTINUE +C + 520 RETURN +C ---------- LAST CARD OF SMCHAR ---------- + END diff --git a/ex/file08 b/ex/file08 new file mode 100644 index 0000000..47fdb71 --- /dev/null +++ b/ex/file08 @@ -0,0 +1,551 @@ +C ********** +C +C THIS PROGRAM TESTS CODES FOR THE SOLUTION OF N NONLINEAR +C EQUATIONS IN N VARIABLES. IT CONSISTS OF A DRIVER AND AN +C INTERFACE SUBROUTINE FCN. THE DRIVER READS IN DATA, CALLS THE +C NONLINEAR EQUATION SOLVER, AND FINALLY PRINTS OUT INFORMATION +C ON THE PERFORMANCE OF THE SOLVER. THIS IS ONLY A SAMPLE DRIVER, +C MANY OTHER DRIVERS ARE POSSIBLE. THE INTERFACE SUBROUTINE FCN +C IS NECESSARY TO TAKE INTO ACCOUNT THE FORMS OF CALLING +C SEQUENCES USED BY THE FUNCTION SUBROUTINES IN THE VARIOUS +C NONLINEAR EQUATION SOLVERS. +C +C SUBPROGRAMS CALLED +C +C USER-SUPPLIED ...... FCN +C +C MINPACK-SUPPLIED ... SPMPAR,ENORM,HYBRD1,INITPT,VECFCN +C +C FORTRAN-SUPPLIED ... SQRT +C +C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. +C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE +C +C ********** + INTEGER I,IC,INFO,K,LWA,N,NFEV,NPROB,NREAD,NTRIES,NWRITE + INTEGER NA(60),NF(60),NP(60),NX(60) + REAL FACTOR,FNORM1,FNORM2,ONE,TEN,TOL + REAL FNM(60),FVEC(40),WA(2660),X(40) + REAL SPMPAR,ENORM + EXTERNAL FCN + COMMON /REFNUM/ NPROB,NFEV +C +C LOGICAL INPUT UNIT IS ASSUMED TO BE NUMBER 5. +C LOGICAL OUTPUT UNIT IS ASSUMED TO BE NUMBER 6. +C + DATA NREAD,NWRITE /5,6/ +C + DATA ONE,TEN /1.0E0,1.0E1/ + TOL = SQRT(SPMPAR(1)) + LWA = 2660 + IC = 0 + 10 CONTINUE + READ (NREAD,50) NPROB,N,NTRIES + IF (NPROB .LE. 0) GO TO 30 + FACTOR = ONE + DO 20 K = 1, NTRIES + IC = IC + 1 + CALL INITPT(N,X,NPROB,FACTOR) + CALL VECFCN(N,X,FVEC,NPROB) + FNORM1 = ENORM(N,FVEC) + WRITE (NWRITE,60) NPROB,N + NFEV = 0 + CALL HYBRD1(FCN,N,X,FVEC,TOL,INFO,WA,LWA) + FNORM2 = ENORM(N,FVEC) + NP(IC) = NPROB + NA(IC) = N + NF(IC) = NFEV + NX(IC) = INFO + FNM(IC) = FNORM2 + WRITE (NWRITE,70) FNORM1,FNORM2,NFEV,INFO,(X(I), I = 1, N) + FACTOR = TEN*FACTOR + 20 CONTINUE + GO TO 10 + 30 CONTINUE + WRITE (NWRITE,80) IC + WRITE (NWRITE,90) + DO 40 I = 1, IC + WRITE (NWRITE,100) NP(I),NA(I),NF(I),NX(I),FNM(I) + 40 CONTINUE + STOP + 50 FORMAT (3I5) + 60 FORMAT ( //// 5X, 8H PROBLEM, I5, 5X, 10H DIMENSION, I5, 5X //) + 70 FORMAT (5X, 33H INITIAL L2 NORM OF THE RESIDUALS, E15.7 // 5X, + * 33H FINAL L2 NORM OF THE RESIDUALS , E15.7 // 5X, + * 33H NUMBER OF FUNCTION EVALUATIONS , I10 // 5X, + * 15H EXIT PARAMETER, 18X, I10 // 5X, + * 27H FINAL APPROXIMATE SOLUTION // (5X, 5E15.7)) + 80 FORMAT (12H1SUMMARY OF , I3, 16H CALLS TO HYBRD1 /) + 90 FORMAT (39H NPROB N NFEV INFO FINAL L2 NORM /) + 100 FORMAT (I4, I6, I7, I6, 1X, E15.7) +C +C LAST CARD OF DRIVER. +C + END + SUBROUTINE FCN(N,X,FVEC,IFLAG) + INTEGER N,IFLAG + REAL X(N),FVEC(N) +C ********** +C +C THE CALLING SEQUENCE OF FCN SHOULD BE IDENTICAL TO THE +C CALLING SEQUENCE OF THE FUNCTION SUBROUTINE IN THE NONLINEAR +C EQUATION SOLVER. FCN SHOULD ONLY CALL THE TESTING FUNCTION +C SUBROUTINE VECFCN WITH THE APPROPRIATE VALUE OF PROBLEM +C NUMBER (NPROB). +C +C SUBPROGRAMS CALLED +C +C MINPACK-SUPPLIED ... VECFCN +C +C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. +C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE +C +C ********** + INTEGER NPROB,NFEV + COMMON /REFNUM/ NPROB,NFEV + CALL VECFCN(N,X,FVEC,NPROB) + NFEV = NFEV + 1 + RETURN +C +C LAST CARD OF INTERFACE SUBROUTINE FCN. +C + END + SUBROUTINE VECFCN(N,X,FVEC,NPROB) + INTEGER N,NPROB + REAL X(N),FVEC(N) +C ********** +C +C SUBROUTINE VECFCN +C +C THIS SUBROUTINE DEFINES FOURTEEN TEST FUNCTIONS. THE FIRST +C FIVE TEST FUNCTIONS ARE OF DIMENSIONS 2,4,2,4,3, RESPECTIVELY, +C WHILE THE REMAINING TEST FUNCTIONS ARE OF VARIABLE DIMENSION +C N FOR ANY N GREATER THAN OR EQUAL TO 1 (PROBLEM 6 IS AN +C EXCEPTION TO THIS, SINCE IT DOES NOT ALLOW N = 1). +C +C THE SUBROUTINE STATEMENT IS +C +C SUBROUTINE VECFCN(N,X,FVEC,NPROB) +C +C WHERE +C +C N IS A POSITIVE INTEGER INPUT VARIABLE. +C +C X IS AN INPUT ARRAY OF LENGTH N. +C +C FVEC IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE NPROB +C FUNCTION VECTOR EVALUATED AT X. +C +C NPROB IS A POSITIVE INTEGER INPUT VARIABLE WHICH DEFINES THE +C NUMBER OF THE PROBLEM. NPROB MUST NOT EXCEED 14. +C +C SUBPROGRAMS CALLED +C +C FORTRAN-SUPPLIED ... ATAN,COS,EXP,SIGN,SIN,SQRT, +C MAX0,MIN0 +C +C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. +C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE +C +C ********** + INTEGER I,IEV,IVAR,J,K,K1,K2,KP1,ML,MU + REAL C1,C2,C3,C4,C5,C6,C7,C8,C9,EIGHT,FIVE,H,ONE,PROD,SUM,SUM1, + * SUM2,TEMP,TEMP1,TEMP2,TEN,THREE,TI,TJ,TK,TPI,TWO,ZERO + REAL FLOAT + DATA ZERO,ONE,TWO,THREE,FIVE,EIGHT,TEN + * /0.0E0,1.0E0,2.0E0,3.0E0,5.0E0,8.0E0,1.0E1/ + DATA C1,C2,C3,C4,C5,C6,C7,C8,C9 + * /1.0E4,1.0001E0,2.0E2,2.02E1,1.98E1,1.8E2,2.5E-1,5.0E-1, + * 2.9E1/ + FLOAT(IVAR) = IVAR +C +C PROBLEM SELECTOR. +C + GO TO (10,20,30,40,50,60,120,170,200,220,270,300,330,350), NPROB +C +C ROSENBROCK FUNCTION. +C + 10 CONTINUE + FVEC(1) = ONE - X(1) + FVEC(2) = TEN*(X(2) - X(1)**2) + GO TO 380 +C +C POWELL SINGULAR FUNCTION. +C + 20 CONTINUE + FVEC(1) = X(1) + TEN*X(2) + FVEC(2) = SQRT(FIVE)*(X(3) - X(4)) + FVEC(3) = (X(2) - TWO*X(3))**2 + FVEC(4) = SQRT(TEN)*(X(1) - X(4))**2 + GO TO 380 +C +C POWELL BADLY SCALED FUNCTION. +C + 30 CONTINUE + FVEC(1) = C1*X(1)*X(2) - ONE + FVEC(2) = EXP(-X(1)) + EXP(-X(2)) - C2 + GO TO 380 +C +C WOOD FUNCTION. +C + 40 CONTINUE + TEMP1 = X(2) - X(1)**2 + TEMP2 = X(4) - X(3)**2 + FVEC(1) = -C3*X(1)*TEMP1 - (ONE - X(1)) + FVEC(2) = C3*TEMP1 + C4*(X(2) - ONE) + C5*(X(4) - ONE) + FVEC(3) = -C6*X(3)*TEMP2 - (ONE - X(3)) + FVEC(4) = C6*TEMP2 + C4*(X(4) - ONE) + C5*(X(2) - ONE) + GO TO 380 +C +C HELICAL VALLEY FUNCTION. +C + 50 CONTINUE + TPI = EIGHT*ATAN(ONE) + TEMP1 = SIGN(C7,X(2)) + IF (X(1) .GT. ZERO) TEMP1 = ATAN(X(2)/X(1))/TPI + IF (X(1) .LT. ZERO) TEMP1 = ATAN(X(2)/X(1))/TPI + C8 + TEMP2 = SQRT(X(1)**2+X(2)**2) + FVEC(1) = TEN*(X(3) - TEN*TEMP1) + FVEC(2) = TEN*(TEMP2 - ONE) + FVEC(3) = X(3) + GO TO 380 +C +C WATSON FUNCTION. +C + 60 CONTINUE + DO 70 K = 1, N + FVEC(K) = ZERO + 70 CONTINUE + DO 110 I = 1, 29 + TI = FLOAT(I)/C9 + SUM1 = ZERO + TEMP = ONE + DO 80 J = 2, N + SUM1 = SUM1 + FLOAT(J-1)*TEMP*X(J) + TEMP = TI*TEMP + 80 CONTINUE + SUM2 = ZERO + TEMP = ONE + DO 90 J = 1, N + SUM2 = SUM2 + TEMP*X(J) + TEMP = TI*TEMP + 90 CONTINUE + TEMP1 = SUM1 - SUM2**2 - ONE + TEMP2 = TWO*TI*SUM2 + TEMP = ONE/TI + DO 100 K = 1, N + FVEC(K) = FVEC(K) + TEMP*(FLOAT(K-1) - TEMP2)*TEMP1 + TEMP = TI*TEMP + 100 CONTINUE + 110 CONTINUE + TEMP = X(2) - X(1)**2 - ONE + FVEC(1) = FVEC(1) + X(1)*(ONE - TWO*TEMP) + FVEC(2) = FVEC(2) + TEMP + GO TO 380 +C +C CHEBYQUAD FUNCTION. +C + 120 CONTINUE + DO 130 K = 1, N + FVEC(K) = ZERO + 130 CONTINUE + DO 150 J = 1, N + TEMP1 = ONE + TEMP2 = TWO*X(J) - ONE + TEMP = TWO*TEMP2 + DO 140 I = 1, N + FVEC(I) = FVEC(I) + TEMP2 + TI = TEMP*TEMP2 - TEMP1 + TEMP1 = TEMP2 + TEMP2 = TI + 140 CONTINUE + 150 CONTINUE + TK = ONE/FLOAT(N) + IEV = -1 + DO 160 K = 1, N + FVEC(K) = TK*FVEC(K) + IF (IEV .GT. 0) FVEC(K) = FVEC(K) + ONE/(FLOAT(K)**2 - ONE) + IEV = -IEV + 160 CONTINUE + GO TO 380 +C +C BROWN ALMOST-LINEAR FUNCTION. +C + 170 CONTINUE + SUM = -FLOAT(N+1) + PROD = ONE + DO 180 J = 1, N + SUM = SUM + X(J) + PROD = X(J)*PROD + 180 CONTINUE + DO 190 K = 1, N + FVEC(K) = X(K) + SUM + 190 CONTINUE + FVEC(N) = PROD - ONE + GO TO 380 +C +C DISCRETE BOUNDARY VALUE FUNCTION. +C + 200 CONTINUE + H = ONE/FLOAT(N+1) + DO 210 K = 1, N + TEMP = (X(K) + FLOAT(K)*H + ONE)**3 + TEMP1 = ZERO + IF (K .NE. 1) TEMP1 = X(K-1) + TEMP2 = ZERO + IF (K .NE. N) TEMP2 = X(K+1) + FVEC(K) = TWO*X(K) - TEMP1 - TEMP2 + TEMP*H**2/TWO + 210 CONTINUE + GO TO 380 +C +C DISCRETE INTEGRAL EQUATION FUNCTION. +C + 220 CONTINUE + H = ONE/FLOAT(N+1) + DO 260 K = 1, N + TK = FLOAT(K)*H + SUM1 = ZERO + DO 230 J = 1, K + TJ = FLOAT(J)*H + TEMP = (X(J) + TJ + ONE)**3 + SUM1 = SUM1 + TJ*TEMP + 230 CONTINUE + SUM2 = ZERO + KP1 = K + 1 + IF (N .LT. KP1) GO TO 250 + DO 240 J = KP1, N + TJ = FLOAT(J)*H + TEMP = (X(J) + TJ + ONE)**3 + SUM2 = SUM2 + (ONE - TJ)*TEMP + 240 CONTINUE + 250 CONTINUE + FVEC(K) = X(K) + H*((ONE - TK)*SUM1 + TK*SUM2)/TWO + 260 CONTINUE + GO TO 380 +C +C TRIGONOMETRIC FUNCTION. +C + 270 CONTINUE + SUM = ZERO + DO 280 J = 1, N + FVEC(J) = COS(X(J)) + SUM = SUM + FVEC(J) + 280 CONTINUE + DO 290 K = 1, N + FVEC(K) = FLOAT(N+K) - SIN(X(K)) - SUM - FLOAT(K)*FVEC(K) + 290 CONTINUE + GO TO 380 +C +C VARIABLY DIMENSIONED FUNCTION. +C + 300 CONTINUE + SUM = ZERO + DO 310 J = 1, N + SUM = SUM + FLOAT(J)*(X(J) - ONE) + 310 CONTINUE + TEMP = SUM*(ONE + TWO*SUM**2) + DO 320 K = 1, N + FVEC(K) = X(K) - ONE + FLOAT(K)*TEMP + 320 CONTINUE + GO TO 380 +C +C BROYDEN TRIDIAGONAL FUNCTION. +C + 330 CONTINUE + DO 340 K = 1, N + TEMP = (THREE - TWO*X(K))*X(K) + TEMP1 = ZERO + IF (K .NE. 1) TEMP1 = X(K-1) + TEMP2 = ZERO + IF (K .NE. N) TEMP2 = X(K+1) + FVEC(K) = TEMP - TEMP1 - TWO*TEMP2 + ONE + 340 CONTINUE + GO TO 380 +C +C BROYDEN BANDED FUNCTION. +C + 350 CONTINUE + ML = 5 + MU = 1 + DO 370 K = 1, N + K1 = MAX0(1,K-ML) + K2 = MIN0(K+MU,N) + TEMP = ZERO + DO 360 J = K1, K2 + IF (J .NE. K) TEMP = TEMP + X(J)*(ONE + X(J)) + 360 CONTINUE + FVEC(K) = X(K)*(TWO + FIVE*X(K)**2) + ONE - TEMP + 370 CONTINUE + 380 CONTINUE + RETURN +C +C LAST CARD OF SUBROUTINE VECFCN. +C + END + SUBROUTINE INITPT(N,X,NPROB,FACTOR) + INTEGER N,NPROB + REAL FACTOR + REAL X(N) +C ********** +C +C SUBROUTINE INITPT +C +C THIS SUBROUTINE SPECIFIES THE STANDARD STARTING POINTS FOR +C THE FUNCTIONS DEFINED BY SUBROUTINE VECFCN. THE SUBROUTINE +C RETURNS IN X A MULTIPLE (FACTOR) OF THE STANDARD STARTING +C POINT. FOR THE SIXTH FUNCTION THE STANDARD STARTING POINT IS +C ZERO, SO IN THIS CASE, IF FACTOR IS NOT UNITY, THEN THE +C SUBROUTINE RETURNS THE VECTOR X(J) = FACTOR, J=1,...,N. +C +C THE SUBROUTINE STATEMENT IS +C +C SUBROUTINE INITPT(N,X,NPROB,FACTOR) +C +C WHERE +C +C N IS A POSITIVE INTEGER INPUT VARIABLE. +C +C X IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE STANDARD +C STARTING POINT FOR PROBLEM NPROB MULTIPLIED BY FACTOR. +C +C NPROB IS A POSITIVE INTEGER INPUT VARIABLE WHICH DEFINES THE +C NUMBER OF THE PROBLEM. NPROB MUST NOT EXCEED 14. +C +C FACTOR IS AN INPUT VARIABLE WHICH SPECIFIES THE MULTIPLE OF +C THE STANDARD STARTING POINT. IF FACTOR IS UNITY, NO +C MULTIPLICATION IS PERFORMED. +C +C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. +C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE +C +C ********** + INTEGER IVAR,J + REAL C1,H,HALF,ONE,THREE,TJ,ZERO + REAL FLOAT + DATA ZERO,HALF,ONE,THREE,C1 /0.0E0,5.0E-1,1.0E0,3.0E0,1.2E0/ + FLOAT(IVAR) = IVAR +C +C SELECTION OF INITIAL POINT. +C + GO TO (10,20,30,40,50,60,80,100,120,120,140,160,180,180), NPROB +C +C ROSENBROCK FUNCTION. +C + 10 CONTINUE + X(1) = -C1 + X(2) = ONE + GO TO 200 +C +C POWELL SINGULAR FUNCTION. +C + 20 CONTINUE + X(1) = THREE + X(2) = -ONE + X(3) = ZERO + X(4) = ONE + GO TO 200 +C +C POWELL BADLY SCALED FUNCTION. +C + 30 CONTINUE + X(1) = ZERO + X(2) = ONE + GO TO 200 +C +C WOOD FUNCTION. +C + 40 CONTINUE + X(1) = -THREE + X(2) = -ONE + X(3) = -THREE + X(4) = -ONE + GO TO 200 +C +C HELICAL VALLEY FUNCTION. +C + 50 CONTINUE + X(1) = -ONE + X(2) = ZERO + X(3) = ZERO + GO TO 200 +C +C WATSON FUNCTION. +C + 60 CONTINUE + DO 70 J = 1, N + X(J) = ZERO + 70 CONTINUE + GO TO 200 +C +C CHEBYQUAD FUNCTION. +C + 80 CONTINUE + H = ONE/FLOAT(N+1) + DO 90 J = 1, N + X(J) = FLOAT(J)*H + 90 CONTINUE + GO TO 200 +C +C BROWN ALMOST-LINEAR FUNCTION. +C + 100 CONTINUE + DO 110 J = 1, N + X(J) = HALF + 110 CONTINUE + GO TO 200 +C +C DISCRETE BOUNDARY VALUE AND INTEGRAL EQUATION FUNCTIONS. +C + 120 CONTINUE + H = ONE/FLOAT(N+1) + DO 130 J = 1, N + TJ = FLOAT(J)*H + X(J) = TJ*(TJ - ONE) + 130 CONTINUE + GO TO 200 +C +C TRIGONOMETRIC FUNCTION. +C + 140 CONTINUE + H = ONE/FLOAT(N) + DO 150 J = 1, N + X(J) = H + 150 CONTINUE + GO TO 200 +C +C VARIABLY DIMENSIONED FUNCTION. +C + 160 CONTINUE + H = ONE/FLOAT(N) + DO 170 J = 1, N + X(J) = ONE - FLOAT(J)*H + 170 CONTINUE + GO TO 200 +C +C BROYDEN TRIDIAGONAL AND BANDED FUNCTIONS. +C + 180 CONTINUE + DO 190 J = 1, N + X(J) = -ONE + 190 CONTINUE + 200 CONTINUE +C +C COMPUTE MULTIPLE OF INITIAL POINT. +C + IF (FACTOR .EQ. ONE) GO TO 250 + IF (NPROB .EQ. 6) GO TO 220 + DO 210 J = 1, N + X(J) = FACTOR*X(J) + 210 CONTINUE + GO TO 240 + 220 CONTINUE + DO 230 J = 1, N + X(J) = FACTOR + 230 CONTINUE + 240 CONTINUE + 250 CONTINUE + RETURN +C +C LAST CARD OF SUBROUTINE INITPT. +C + END diff --git a/ex/file09 b/ex/file09 new file mode 100644 index 0000000..672ec01 --- /dev/null +++ b/ex/file09 @@ -0,0 +1,879 @@ +C ********** +C +C THIS PROGRAM TESTS CODES FOR THE SOLUTION OF N NONLINEAR +C EQUATIONS IN N VARIABLES. IT CONSISTS OF A DRIVER AND AN +C INTERFACE SUBROUTINE FCN. THE DRIVER READS IN DATA, CALLS THE +C NONLINEAR EQUATION SOLVER, AND FINALLY PRINTS OUT INFORMATION +C ON THE PERFORMANCE OF THE SOLVER. THIS IS ONLY A SAMPLE DRIVER, +C MANY OTHER DRIVERS ARE POSSIBLE. THE INTERFACE SUBROUTINE FCN +C IS NECESSARY TO TAKE INTO ACCOUNT THE FORMS OF CALLING +C SEQUENCES USED BY THE FUNCTION AND JACOBIAN SUBROUTINES IN +C THE VARIOUS NONLINEAR EQUATION SOLVERS. +C +C SUBPROGRAMS CALLED +C +C USER-SUPPLIED ...... FCN +C +C MINPACK-SUPPLIED ... SPMPAR,ENORM,HYBRJ1,INITPT,VECFCN +C +C FORTRAN-SUPPLIED ... SQRT +C +C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. +C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE +C +C ********** + INTEGER I,IC,INFO,K,LDFJAC,LWA,N,NFEV,NJEV,NPROB,NREAD,NTRIES, + * NWRITE + INTEGER NA(60),NF(60),NJ(60),NP(60),NX(60) + REAL FACTOR,FNORM1,FNORM2,ONE,TEN,TOL + REAL FNM(60),FJAC(40,40),FVEC(40),WA(1060),X(40) + REAL SPMPAR,ENORM + EXTERNAL FCN + COMMON /REFNUM/ NPROB,NFEV,NJEV +C +C LOGICAL INPUT UNIT IS ASSUMED TO BE NUMBER 5. +C LOGICAL OUTPUT UNIT IS ASSUMED TO BE NUMBER 6. +C + DATA NREAD,NWRITE /5,6/ +C + DATA ONE,TEN /1.0E0,1.0E1/ + TOL = SQRT(SPMPAR(1)) + LDFJAC = 40 + LWA = 1060 + IC = 0 + 10 CONTINUE + READ (NREAD,50) NPROB,N,NTRIES + IF (NPROB .LE. 0) GO TO 30 + FACTOR = ONE + DO 20 K = 1, NTRIES + IC = IC + 1 + CALL INITPT(N,X,NPROB,FACTOR) + CALL VECFCN(N,X,FVEC,NPROB) + FNORM1 = ENORM(N,FVEC) + WRITE (NWRITE,60) NPROB,N + NFEV = 0 + NJEV = 0 + CALL HYBRJ1(FCN,N,X,FVEC,FJAC,LDFJAC,TOL,INFO,WA,LWA) + FNORM2 = ENORM(N,FVEC) + NP(IC) = NPROB + NA(IC) = N + NF(IC) = NFEV + NJ(IC) = NJEV + NX(IC) = INFO + FNM(IC) = FNORM2 + WRITE (NWRITE,70) + * FNORM1,FNORM2,NFEV,NJEV,INFO,(X(I), I = 1, N) + FACTOR = TEN*FACTOR + 20 CONTINUE + GO TO 10 + 30 CONTINUE + WRITE (NWRITE,80) IC + WRITE (NWRITE,90) + DO 40 I = 1, IC + WRITE (NWRITE,100) NP(I),NA(I),NF(I),NJ(I),NX(I),FNM(I) + 40 CONTINUE + STOP + 50 FORMAT (3I5) + 60 FORMAT ( //// 5X, 8H PROBLEM, I5, 5X, 10H DIMENSION, I5, 5X //) + 70 FORMAT (5X, 33H INITIAL L2 NORM OF THE RESIDUALS, E15.7 // 5X, + * 33H FINAL L2 NORM OF THE RESIDUALS , E15.7 // 5X, + * 33H NUMBER OF FUNCTION EVALUATIONS , I10 // 5X, + * 33H NUMBER OF JACOBIAN EVALUATIONS , I10 // 5X, + * 15H EXIT PARAMETER, 18X, I10 // 5X, + * 27H FINAL APPROXIMATE SOLUTION // (5X, 5E15.7)) + 80 FORMAT (12H1SUMMARY OF , I3, 16H CALLS TO HYBRJ1 /) + 90 FORMAT (46H NPROB N NFEV NJEV INFO FINAL L2 NORM /) + 100 FORMAT (I4, I6, 2I7, I6, 1X, E15.7) +C +C LAST CARD OF DRIVER. +C + END + SUBROUTINE FCN(N,X,FVEC,FJAC,LDFJAC,IFLAG) + INTEGER N,LDFJAC,IFLAG + REAL X(N),FVEC(N),FJAC(LDFJAC,N) +C ********** +C +C THE CALLING SEQUENCE OF FCN SHOULD BE IDENTICAL TO THE +C CALLING SEQUENCE OF THE FUNCTION SUBROUTINE IN THE NONLINEAR +C EQUATION SOLVER. FCN SHOULD ONLY CALL THE TESTING FUNCTION +C AND JACOBIAN SUBROUTINES VECFCN AND VECJAC WITH THE +C APPROPRIATE VALUE OF PROBLEM NUMBER (NPROB). +C +C SUBPROGRAMS CALLED +C +C MINPACK-SUPPLIED ... VECFCN,VECJAC +C +C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. +C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE +C +C ********** + INTEGER NPROB,NFEV,NJEV + COMMON /REFNUM/ NPROB,NFEV,NJEV + IF (IFLAG .EQ. 1) CALL VECFCN(N,X,FVEC,NPROB) + IF (IFLAG .EQ. 2) CALL VECJAC(N,X,FJAC,LDFJAC,NPROB) + IF (IFLAG .EQ. 1) NFEV = NFEV + 1 + IF (IFLAG .EQ. 2) NJEV = NJEV + 1 + RETURN +C +C LAST CARD OF INTERFACE SUBROUTINE FCN. +C + END + SUBROUTINE VECJAC(N,X,FJAC,LDFJAC,NPROB) + INTEGER N,LDFJAC,NPROB + REAL X(N),FJAC(LDFJAC,N) +C ********** +C +C SUBROUTINE VECJAC +C +C THIS SUBROUTINE DEFINES THE JACOBIAN MATRICES OF FOURTEEN +C TEST FUNCTIONS. THE PROBLEM DIMENSIONS ARE AS DESCRIBED +C IN THE PROLOGUE COMMENTS OF VECFCN. +C +C THE SUBROUTINE STATEMENT IS +C +C SUBROUTINE VECJAC(N,X,FJAC,LDFJAC,NPROB) +C +C WHERE +C +C N IS A POSITIVE INTEGER VARIABLE. +C +C X IS AN ARRAY OF LENGTH N. +C +C FJAC IS AN N BY N ARRAY. ON OUTPUT FJAC CONTAINS THE +C JACOBIAN MATRIX OF THE NPROB FUNCTION EVALUATED AT X. +C +C LDFJAC IS A POSITIVE INTEGER VARIABLE NOT LESS THAN N +C WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY FJAC. +C +C NPROB IS A POSITIVE INTEGER VARIABLE WHICH DEFINES THE +C NUMBER OF THE PROBLEM. NPROB MUST NOT EXCEED 14. +C +C SUBPROGRAMS CALLED +C +C FORTRAN-SUPPLIED ... ATAN,COS,EXP,AMIN1,SIN,SQRT, +C MAX0,MIN0 +C +C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. +C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE +C +C ********** + INTEGER I,IVAR,J,K,K1,K2,ML,MU + REAL C1,C3,C4,C5,C6,C9,EIGHT,FIFTN,FIVE,FOUR,H,HUNDRD,ONE,PROD, + * SIX,SUM,SUM1,SUM2,TEMP,TEMP1,TEMP2,TEMP3,TEMP4,TEN,THREE, + * TI,TJ,TK,TPI,TWENTY,TWO,ZERO + REAL FLOAT + DATA ZERO,ONE,TWO,THREE,FOUR,FIVE,SIX,EIGHT,TEN,FIFTN,TWENTY, + * HUNDRD + * /0.0E0,1.0E0,2.0E0,3.0E0,4.0E0,5.0E0,6.0E0,8.0E0,1.0E1, + * 1.5E1,2.0E1,1.0E2/ + DATA C1,C3,C4,C5,C6,C9 /1.0E4,2.0E2,2.02E1,1.98E1,1.8E2,2.9E1/ + FLOAT(IVAR) = IVAR +C +C JACOBIAN ROUTINE SELECTOR. +C + GO TO (10,20,50,60,90,100,200,230,290,320,350,380,420,450), + * NPROB +C +C ROSENBROCK FUNCTION. +C + 10 CONTINUE + FJAC(1,1) = -ONE + FJAC(1,2) = ZERO + FJAC(2,1) = -TWENTY*X(1) + FJAC(2,2) = TEN + GO TO 490 +C +C POWELL SINGULAR FUNCTION. +C + 20 CONTINUE + DO 40 K = 1, 4 + DO 30 J = 1, 4 + FJAC(K,J) = ZERO + 30 CONTINUE + 40 CONTINUE + FJAC(1,1) = ONE + FJAC(1,2) = TEN + FJAC(2,3) = SQRT(FIVE) + FJAC(2,4) = -FJAC(2,3) + FJAC(3,2) = TWO*(X(2) - TWO*X(3)) + FJAC(3,3) = -TWO*FJAC(3,2) + FJAC(4,1) = TWO*SQRT(TEN)*(X(1) - X(4)) + FJAC(4,4) = -FJAC(4,1) + GO TO 490 +C +C POWELL BADLY SCALED FUNCTION. +C + 50 CONTINUE + FJAC(1,1) = C1*X(2) + FJAC(1,2) = C1*X(1) + FJAC(2,1) = -EXP(-X(1)) + FJAC(2,2) = -EXP(-X(2)) + GO TO 490 +C +C WOOD FUNCTION. +C + 60 CONTINUE + DO 80 K = 1, 4 + DO 70 J = 1, 4 + FJAC(K,J) = ZERO + 70 CONTINUE + 80 CONTINUE + TEMP1 = X(2) - THREE*X(1)**2 + TEMP2 = X(4) - THREE*X(3)**2 + FJAC(1,1) = -C3*TEMP1 + ONE + FJAC(1,2) = -C3*X(1) + FJAC(2,1) = -TWO*C3*X(1) + FJAC(2,2) = C3 + C4 + FJAC(2,4) = C5 + FJAC(3,3) = -C6*TEMP2 + ONE + FJAC(3,4) = -C6*X(3) + FJAC(4,2) = C5 + FJAC(4,3) = -TWO*C6*X(3) + FJAC(4,4) = C6 + C4 + GO TO 490 +C +C HELICAL VALLEY FUNCTION. +C + 90 CONTINUE + TPI = EIGHT*ATAN(ONE) + TEMP = X(1)**2 + X(2)**2 + TEMP1 = TPI*TEMP + TEMP2 = SQRT(TEMP) + FJAC(1,1) = HUNDRD*X(2)/TEMP1 + FJAC(1,2) = -HUNDRD*X(1)/TEMP1 + FJAC(1,3) = TEN + FJAC(2,1) = TEN*X(1)/TEMP2 + FJAC(2,2) = TEN*X(2)/TEMP2 + FJAC(2,3) = ZERO + FJAC(3,1) = ZERO + FJAC(3,2) = ZERO + FJAC(3,3) = ONE + GO TO 490 +C +C WATSON FUNCTION. +C + 100 CONTINUE + DO 120 K = 1, N + DO 110 J = K, N + FJAC(K,J) = ZERO + 110 CONTINUE + 120 CONTINUE + DO 170 I = 1, 29 + TI = FLOAT(I)/C9 + SUM1 = ZERO + TEMP = ONE + DO 130 J = 2, N + SUM1 = SUM1 + FLOAT(J-1)*TEMP*X(J) + TEMP = TI*TEMP + 130 CONTINUE + SUM2 = ZERO + TEMP = ONE + DO 140 J = 1, N + SUM2 = SUM2 + TEMP*X(J) + TEMP = TI*TEMP + 140 CONTINUE + TEMP1 = TWO*(SUM1 - SUM2**2 - ONE) + TEMP2 = TWO*SUM2 + TEMP = TI**2 + TK = ONE + DO 160 K = 1, N + TJ = TK + DO 150 J = K, N + FJAC(K,J) = FJAC(K,J) + * + TJ + * *((FLOAT(K-1)/TI - TEMP2) + * *(FLOAT(J-1)/TI - TEMP2) - TEMP1) + TJ = TI*TJ + 150 CONTINUE + TK = TEMP*TK + 160 CONTINUE + 170 CONTINUE + FJAC(1,1) = FJAC(1,1) + SIX*X(1)**2 - TWO*X(2) + THREE + FJAC(1,2) = FJAC(1,2) - TWO*X(1) + FJAC(2,2) = FJAC(2,2) + ONE + DO 190 K = 1, N + DO 180 J = K, N + FJAC(J,K) = FJAC(K,J) + 180 CONTINUE + 190 CONTINUE + GO TO 490 +C +C CHEBYQUAD FUNCTION. +C + 200 CONTINUE + TK = ONE/FLOAT(N) + DO 220 J = 1, N + TEMP1 = ONE + TEMP2 = TWO*X(J) - ONE + TEMP = TWO*TEMP2 + TEMP3 = ZERO + TEMP4 = TWO + DO 210 K = 1, N + FJAC(K,J) = TK*TEMP4 + TI = FOUR*TEMP2 + TEMP*TEMP4 - TEMP3 + TEMP3 = TEMP4 + TEMP4 = TI + TI = TEMP*TEMP2 - TEMP1 + TEMP1 = TEMP2 + TEMP2 = TI + 210 CONTINUE + 220 CONTINUE + GO TO 490 +C +C BROWN ALMOST-LINEAR FUNCTION. +C + 230 CONTINUE + PROD = ONE + DO 250 J = 1, N + PROD = X(J)*PROD + DO 240 K = 1, N + FJAC(K,J) = ONE + 240 CONTINUE + FJAC(J,J) = TWO + 250 CONTINUE + DO 280 J = 1, N + TEMP = X(J) + IF (TEMP .NE. ZERO) GO TO 270 + TEMP = ONE + PROD = ONE + DO 260 K = 1, N + IF (K .NE. J) PROD = X(K)*PROD + 260 CONTINUE + 270 CONTINUE + FJAC(N,J) = PROD/TEMP + 280 CONTINUE + GO TO 490 +C +C DISCRETE BOUNDARY VALUE FUNCTION. +C + 290 CONTINUE + H = ONE/FLOAT(N+1) + DO 310 K = 1, N + TEMP = THREE*(X(K) + FLOAT(K)*H + ONE)**2 + DO 300 J = 1, N + FJAC(K,J) = ZERO + 300 CONTINUE + FJAC(K,K) = TWO + TEMP*H**2/TWO + IF (K .NE. 1) FJAC(K,K-1) = -ONE + IF (K .NE. N) FJAC(K,K+1) = -ONE + 310 CONTINUE + GO TO 490 +C +C DISCRETE INTEGRAL EQUATION FUNCTION. +C + 320 CONTINUE + H = ONE/FLOAT(N+1) + DO 340 K = 1, N + TK = FLOAT(K)*H + DO 330 J = 1, N + TJ = FLOAT(J)*H + TEMP = THREE*(X(J) + TJ + ONE)**2 + FJAC(K,J) = H*AMIN1(TJ*(ONE-TK),TK*(ONE-TJ))*TEMP/TWO + 330 CONTINUE + FJAC(K,K) = FJAC(K,K) + ONE + 340 CONTINUE + GO TO 490 +C +C TRIGONOMETRIC FUNCTION. +C + 350 CONTINUE + DO 370 J = 1, N + TEMP = SIN(X(J)) + DO 360 K = 1, N + FJAC(K,J) = TEMP + 360 CONTINUE + FJAC(J,J) = FLOAT(J+1)*TEMP - COS(X(J)) + 370 CONTINUE + GO TO 490 +C +C VARIABLY DIMENSIONED FUNCTION. +C + 380 CONTINUE + SUM = ZERO + DO 390 J = 1, N + SUM = SUM + FLOAT(J)*(X(J) - ONE) + 390 CONTINUE + TEMP = ONE + SIX*SUM**2 + DO 410 K = 1, N + DO 400 J = K, N + FJAC(K,J) = FLOAT(K*J)*TEMP + FJAC(J,K) = FJAC(K,J) + 400 CONTINUE + FJAC(K,K) = FJAC(K,K) + ONE + 410 CONTINUE + GO TO 490 +C +C BROYDEN TRIDIAGONAL FUNCTION. +C + 420 CONTINUE + DO 440 K = 1, N + DO 430 J = 1, N + FJAC(K,J) = ZERO + 430 CONTINUE + FJAC(K,K) = THREE - FOUR*X(K) + IF (K .NE. 1) FJAC(K,K-1) = -ONE + IF (K .NE. N) FJAC(K,K+1) = -TWO + 440 CONTINUE + GO TO 490 +C +C BROYDEN BANDED FUNCTION. +C + 450 CONTINUE + ML = 5 + MU = 1 + DO 480 K = 1, N + DO 460 J = 1, N + FJAC(K,J) = ZERO + 460 CONTINUE + K1 = MAX0(1,K-ML) + K2 = MIN0(K+MU,N) + DO 470 J = K1, K2 + IF (J .NE. K) FJAC(K,J) = -(ONE + TWO*X(J)) + 470 CONTINUE + FJAC(K,K) = TWO + FIFTN*X(K)**2 + 480 CONTINUE + 490 CONTINUE + RETURN +C +C LAST CARD OF SUBROUTINE VECJAC. +C + END + SUBROUTINE INITPT(N,X,NPROB,FACTOR) + INTEGER N,NPROB + REAL FACTOR + REAL X(N) +C ********** +C +C SUBROUTINE INITPT +C +C THIS SUBROUTINE SPECIFIES THE STANDARD STARTING POINTS FOR +C THE FUNCTIONS DEFINED BY SUBROUTINE VECFCN. THE SUBROUTINE +C RETURNS IN X A MULTIPLE (FACTOR) OF THE STANDARD STARTING +C POINT. FOR THE SIXTH FUNCTION THE STANDARD STARTING POINT IS +C ZERO, SO IN THIS CASE, IF FACTOR IS NOT UNITY, THEN THE +C SUBROUTINE RETURNS THE VECTOR X(J) = FACTOR, J=1,...,N. +C +C THE SUBROUTINE STATEMENT IS +C +C SUBROUTINE INITPT(N,X,NPROB,FACTOR) +C +C WHERE +C +C N IS A POSITIVE INTEGER INPUT VARIABLE. +C +C X IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE STANDARD +C STARTING POINT FOR PROBLEM NPROB MULTIPLIED BY FACTOR. +C +C NPROB IS A POSITIVE INTEGER INPUT VARIABLE WHICH DEFINES THE +C NUMBER OF THE PROBLEM. NPROB MUST NOT EXCEED 14. +C +C FACTOR IS AN INPUT VARIABLE WHICH SPECIFIES THE MULTIPLE OF +C THE STANDARD STARTING POINT. IF FACTOR IS UNITY, NO +C MULTIPLICATION IS PERFORMED. +C +C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. +C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE +C +C ********** + INTEGER IVAR,J + REAL C1,H,HALF,ONE,THREE,TJ,ZERO + REAL FLOAT + DATA ZERO,HALF,ONE,THREE,C1 /0.0E0,5.0E-1,1.0E0,3.0E0,1.2E0/ + FLOAT(IVAR) = IVAR +C +C SELECTION OF INITIAL POINT. +C + GO TO (10,20,30,40,50,60,80,100,120,120,140,160,180,180), NPROB +C +C ROSENBROCK FUNCTION. +C + 10 CONTINUE + X(1) = -C1 + X(2) = ONE + GO TO 200 +C +C POWELL SINGULAR FUNCTION. +C + 20 CONTINUE + X(1) = THREE + X(2) = -ONE + X(3) = ZERO + X(4) = ONE + GO TO 200 +C +C POWELL BADLY SCALED FUNCTION. +C + 30 CONTINUE + X(1) = ZERO + X(2) = ONE + GO TO 200 +C +C WOOD FUNCTION. +C + 40 CONTINUE + X(1) = -THREE + X(2) = -ONE + X(3) = -THREE + X(4) = -ONE + GO TO 200 +C +C HELICAL VALLEY FUNCTION. +C + 50 CONTINUE + X(1) = -ONE + X(2) = ZERO + X(3) = ZERO + GO TO 200 +C +C WATSON FUNCTION. +C + 60 CONTINUE + DO 70 J = 1, N + X(J) = ZERO + 70 CONTINUE + GO TO 200 +C +C CHEBYQUAD FUNCTION. +C + 80 CONTINUE + H = ONE/FLOAT(N+1) + DO 90 J = 1, N + X(J) = FLOAT(J)*H + 90 CONTINUE + GO TO 200 +C +C BROWN ALMOST-LINEAR FUNCTION. +C + 100 CONTINUE + DO 110 J = 1, N + X(J) = HALF + 110 CONTINUE + GO TO 200 +C +C DISCRETE BOUNDARY VALUE AND INTEGRAL EQUATION FUNCTIONS. +C + 120 CONTINUE + H = ONE/FLOAT(N+1) + DO 130 J = 1, N + TJ = FLOAT(J)*H + X(J) = TJ*(TJ - ONE) + 130 CONTINUE + GO TO 200 +C +C TRIGONOMETRIC FUNCTION. +C + 140 CONTINUE + H = ONE/FLOAT(N) + DO 150 J = 1, N + X(J) = H + 150 CONTINUE + GO TO 200 +C +C VARIABLY DIMENSIONED FUNCTION. +C + 160 CONTINUE + H = ONE/FLOAT(N) + DO 170 J = 1, N + X(J) = ONE - FLOAT(J)*H + 170 CONTINUE + GO TO 200 +C +C BROYDEN TRIDIAGONAL AND BANDED FUNCTIONS. +C + 180 CONTINUE + DO 190 J = 1, N + X(J) = -ONE + 190 CONTINUE + 200 CONTINUE +C +C COMPUTE MULTIPLE OF INITIAL POINT. +C + IF (FACTOR .EQ. ONE) GO TO 250 + IF (NPROB .EQ. 6) GO TO 220 + DO 210 J = 1, N + X(J) = FACTOR*X(J) + 210 CONTINUE + GO TO 240 + 220 CONTINUE + DO 230 J = 1, N + X(J) = FACTOR + 230 CONTINUE + 240 CONTINUE + 250 CONTINUE + RETURN +C +C LAST CARD OF SUBROUTINE INITPT. +C + END + SUBROUTINE VECFCN(N,X,FVEC,NPROB) + INTEGER N,NPROB + REAL X(N),FVEC(N) +C ********** +C +C SUBROUTINE VECFCN +C +C THIS SUBROUTINE DEFINES FOURTEEN TEST FUNCTIONS. THE FIRST +C FIVE TEST FUNCTIONS ARE OF DIMENSIONS 2,4,2,4,3, RESPECTIVELY, +C WHILE THE REMAINING TEST FUNCTIONS ARE OF VARIABLE DIMENSION +C N FOR ANY N GREATER THAN OR EQUAL TO 1 (PROBLEM 6 IS AN +C EXCEPTION TO THIS, SINCE IT DOES NOT ALLOW N = 1). +C +C THE SUBROUTINE STATEMENT IS +C +C SUBROUTINE VECFCN(N,X,FVEC,NPROB) +C +C WHERE +C +C N IS A POSITIVE INTEGER INPUT VARIABLE. +C +C X IS AN INPUT ARRAY OF LENGTH N. +C +C FVEC IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE NPROB +C FUNCTION VECTOR EVALUATED AT X. +C +C NPROB IS A POSITIVE INTEGER INPUT VARIABLE WHICH DEFINES THE +C NUMBER OF THE PROBLEM. NPROB MUST NOT EXCEED 14. +C +C SUBPROGRAMS CALLED +C +C FORTRAN-SUPPLIED ... ATAN,COS,EXP,SIGN,SIN,SQRT, +C MAX0,MIN0 +C +C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. +C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE +C +C ********** + INTEGER I,IEV,IVAR,J,K,K1,K2,KP1,ML,MU + REAL C1,C2,C3,C4,C5,C6,C7,C8,C9,EIGHT,FIVE,H,ONE,PROD,SUM,SUM1, + * SUM2,TEMP,TEMP1,TEMP2,TEN,THREE,TI,TJ,TK,TPI,TWO,ZERO + REAL FLOAT + DATA ZERO,ONE,TWO,THREE,FIVE,EIGHT,TEN + * /0.0E0,1.0E0,2.0E0,3.0E0,5.0E0,8.0E0,1.0E1/ + DATA C1,C2,C3,C4,C5,C6,C7,C8,C9 + * /1.0E4,1.0001E0,2.0E2,2.02E1,1.98E1,1.8E2,2.5E-1,5.0E-1, + * 2.9E1/ + FLOAT(IVAR) = IVAR +C +C PROBLEM SELECTOR. +C + GO TO (10,20,30,40,50,60,120,170,200,220,270,300,330,350), NPROB +C +C ROSENBROCK FUNCTION. +C + 10 CONTINUE + FVEC(1) = ONE - X(1) + FVEC(2) = TEN*(X(2) - X(1)**2) + GO TO 380 +C +C POWELL SINGULAR FUNCTION. +C + 20 CONTINUE + FVEC(1) = X(1) + TEN*X(2) + FVEC(2) = SQRT(FIVE)*(X(3) - X(4)) + FVEC(3) = (X(2) - TWO*X(3))**2 + FVEC(4) = SQRT(TEN)*(X(1) - X(4))**2 + GO TO 380 +C +C POWELL BADLY SCALED FUNCTION. +C + 30 CONTINUE + FVEC(1) = C1*X(1)*X(2) - ONE + FVEC(2) = EXP(-X(1)) + EXP(-X(2)) - C2 + GO TO 380 +C +C WOOD FUNCTION. +C + 40 CONTINUE + TEMP1 = X(2) - X(1)**2 + TEMP2 = X(4) - X(3)**2 + FVEC(1) = -C3*X(1)*TEMP1 - (ONE - X(1)) + FVEC(2) = C3*TEMP1 + C4*(X(2) - ONE) + C5*(X(4) - ONE) + FVEC(3) = -C6*X(3)*TEMP2 - (ONE - X(3)) + FVEC(4) = C6*TEMP2 + C4*(X(4) - ONE) + C5*(X(2) - ONE) + GO TO 380 +C +C HELICAL VALLEY FUNCTION. +C + 50 CONTINUE + TPI = EIGHT*ATAN(ONE) + TEMP1 = SIGN(C7,X(2)) + IF (X(1) .GT. ZERO) TEMP1 = ATAN(X(2)/X(1))/TPI + IF (X(1) .LT. ZERO) TEMP1 = ATAN(X(2)/X(1))/TPI + C8 + TEMP2 = SQRT(X(1)**2+X(2)**2) + FVEC(1) = TEN*(X(3) - TEN*TEMP1) + FVEC(2) = TEN*(TEMP2 - ONE) + FVEC(3) = X(3) + GO TO 380 +C +C WATSON FUNCTION. +C + 60 CONTINUE + DO 70 K = 1, N + FVEC(K) = ZERO + 70 CONTINUE + DO 110 I = 1, 29 + TI = FLOAT(I)/C9 + SUM1 = ZERO + TEMP = ONE + DO 80 J = 2, N + SUM1 = SUM1 + FLOAT(J-1)*TEMP*X(J) + TEMP = TI*TEMP + 80 CONTINUE + SUM2 = ZERO + TEMP = ONE + DO 90 J = 1, N + SUM2 = SUM2 + TEMP*X(J) + TEMP = TI*TEMP + 90 CONTINUE + TEMP1 = SUM1 - SUM2**2 - ONE + TEMP2 = TWO*TI*SUM2 + TEMP = ONE/TI + DO 100 K = 1, N + FVEC(K) = FVEC(K) + TEMP*(FLOAT(K-1) - TEMP2)*TEMP1 + TEMP = TI*TEMP + 100 CONTINUE + 110 CONTINUE + TEMP = X(2) - X(1)**2 - ONE + FVEC(1) = FVEC(1) + X(1)*(ONE - TWO*TEMP) + FVEC(2) = FVEC(2) + TEMP + GO TO 380 +C +C CHEBYQUAD FUNCTION. +C + 120 CONTINUE + DO 130 K = 1, N + FVEC(K) = ZERO + 130 CONTINUE + DO 150 J = 1, N + TEMP1 = ONE + TEMP2 = TWO*X(J) - ONE + TEMP = TWO*TEMP2 + DO 140 I = 1, N + FVEC(I) = FVEC(I) + TEMP2 + TI = TEMP*TEMP2 - TEMP1 + TEMP1 = TEMP2 + TEMP2 = TI + 140 CONTINUE + 150 CONTINUE + TK = ONE/FLOAT(N) + IEV = -1 + DO 160 K = 1, N + FVEC(K) = TK*FVEC(K) + IF (IEV .GT. 0) FVEC(K) = FVEC(K) + ONE/(FLOAT(K)**2 - ONE) + IEV = -IEV + 160 CONTINUE + GO TO 380 +C +C BROWN ALMOST-LINEAR FUNCTION. +C + 170 CONTINUE + SUM = -FLOAT(N+1) + PROD = ONE + DO 180 J = 1, N + SUM = SUM + X(J) + PROD = X(J)*PROD + 180 CONTINUE + DO 190 K = 1, N + FVEC(K) = X(K) + SUM + 190 CONTINUE + FVEC(N) = PROD - ONE + GO TO 380 +C +C DISCRETE BOUNDARY VALUE FUNCTION. +C + 200 CONTINUE + H = ONE/FLOAT(N+1) + DO 210 K = 1, N + TEMP = (X(K) + FLOAT(K)*H + ONE)**3 + TEMP1 = ZERO + IF (K .NE. 1) TEMP1 = X(K-1) + TEMP2 = ZERO + IF (K .NE. N) TEMP2 = X(K+1) + FVEC(K) = TWO*X(K) - TEMP1 - TEMP2 + TEMP*H**2/TWO + 210 CONTINUE + GO TO 380 +C +C DISCRETE INTEGRAL EQUATION FUNCTION. +C + 220 CONTINUE + H = ONE/FLOAT(N+1) + DO 260 K = 1, N + TK = FLOAT(K)*H + SUM1 = ZERO + DO 230 J = 1, K + TJ = FLOAT(J)*H + TEMP = (X(J) + TJ + ONE)**3 + SUM1 = SUM1 + TJ*TEMP + 230 CONTINUE + SUM2 = ZERO + KP1 = K + 1 + IF (N .LT. KP1) GO TO 250 + DO 240 J = KP1, N + TJ = FLOAT(J)*H + TEMP = (X(J) + TJ + ONE)**3 + SUM2 = SUM2 + (ONE - TJ)*TEMP + 240 CONTINUE + 250 CONTINUE + FVEC(K) = X(K) + H*((ONE - TK)*SUM1 + TK*SUM2)/TWO + 260 CONTINUE + GO TO 380 +C +C TRIGONOMETRIC FUNCTION. +C + 270 CONTINUE + SUM = ZERO + DO 280 J = 1, N + FVEC(J) = COS(X(J)) + SUM = SUM + FVEC(J) + 280 CONTINUE + DO 290 K = 1, N + FVEC(K) = FLOAT(N+K) - SIN(X(K)) - SUM - FLOAT(K)*FVEC(K) + 290 CONTINUE + GO TO 380 +C +C VARIABLY DIMENSIONED FUNCTION. +C + 300 CONTINUE + SUM = ZERO + DO 310 J = 1, N + SUM = SUM + FLOAT(J)*(X(J) - ONE) + 310 CONTINUE + TEMP = SUM*(ONE + TWO*SUM**2) + DO 320 K = 1, N + FVEC(K) = X(K) - ONE + FLOAT(K)*TEMP + 320 CONTINUE + GO TO 380 +C +C BROYDEN TRIDIAGONAL FUNCTION. +C + 330 CONTINUE + DO 340 K = 1, N + TEMP = (THREE - TWO*X(K))*X(K) + TEMP1 = ZERO + IF (K .NE. 1) TEMP1 = X(K-1) + TEMP2 = ZERO + IF (K .NE. N) TEMP2 = X(K+1) + FVEC(K) = TEMP - TEMP1 - TWO*TEMP2 + ONE + 340 CONTINUE + GO TO 380 +C +C BROYDEN BANDED FUNCTION. +C + 350 CONTINUE + ML = 5 + MU = 1 + DO 370 K = 1, N + K1 = MAX0(1,K-ML) + K2 = MIN0(K+MU,N) + TEMP = ZERO + DO 360 J = K1, K2 + IF (J .NE. K) TEMP = TEMP + X(J)*(ONE + X(J)) + 360 CONTINUE + FVEC(K) = X(K)*(TWO + FIVE*X(K)**2) + ONE - TEMP + 370 CONTINUE + 380 CONTINUE + RETURN +C +C LAST CARD OF SUBROUTINE VECFCN. +C + END diff --git a/ex/file10 b/ex/file10 new file mode 100644 index 0000000..fea853e --- /dev/null +++ b/ex/file10 @@ -0,0 +1,1022 @@ +C ********** +C +C THIS PROGRAM TESTS CODES FOR THE LEAST-SQUARES SOLUTION OF +C M NONLINEAR EQUATIONS IN N VARIABLES. IT CONSISTS OF A DRIVER +C AND AN INTERFACE SUBROUTINE FCN. THE DRIVER READS IN DATA, +C CALLS THE NONLINEAR LEAST-SQUARES SOLVER, AND FINALLY PRINTS +C OUT INFORMATION ON THE PERFORMANCE OF THE SOLVER. THIS IS +C ONLY A SAMPLE DRIVER, MANY OTHER DRIVERS ARE POSSIBLE. THE +C INTERFACE SUBROUTINE FCN IS NECESSARY TO TAKE INTO ACCOUNT THE +C FORMS OF CALLING SEQUENCES USED BY THE FUNCTION AND JACOBIAN +C SUBROUTINES IN THE VARIOUS NONLINEAR LEAST-SQUARES SOLVERS. +C +C SUBPROGRAMS CALLED +C +C USER-SUPPLIED ...... FCN +C +C MINPACK-SUPPLIED ... SPMPAR,ENORM,INITPT,LMDER1,SSQFCN +C +C FORTRAN-SUPPLIED ... SQRT +C +C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. +C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE +C +C ********** + INTEGER I,IC,INFO,K,LDFJAC,LWA,M,N,NFEV,NJEV,NPROB,NREAD,NTRIES, + * NWRITE + INTEGER IWA(40),MA(60),NA(60),NF(60),NJ(60),NP(60),NX(60) + REAL FACTOR,FNORM1,FNORM2,ONE,TEN,TOL + REAL FJAC(65,40),FNM(60),FVEC(65),WA(265),X(40) + REAL SPMPAR,ENORM + EXTERNAL FCN + COMMON /REFNUM/ NPROB,NFEV,NJEV +C +C LOGICAL INPUT UNIT IS ASSUMED TO BE NUMBER 5. +C LOGICAL OUTPUT UNIT IS ASSUMED TO BE NUMBER 6. +C + DATA NREAD,NWRITE /5,6/ +C + DATA ONE,TEN /1.0E0,1.0E1/ + TOL = SQRT(SPMPAR(1)) + LDFJAC = 65 + LWA = 265 + IC = 0 + 10 CONTINUE + READ (NREAD,50) NPROB,N,M,NTRIES + IF (NPROB .LE. 0) GO TO 30 + FACTOR = ONE + DO 20 K = 1, NTRIES + IC = IC + 1 + CALL INITPT(N,X,NPROB,FACTOR) + CALL SSQFCN(M,N,X,FVEC,NPROB) + FNORM1 = ENORM(M,FVEC) + WRITE (NWRITE,60) NPROB,N,M + NFEV = 0 + NJEV = 0 + CALL LMDER1(FCN,M,N,X,FVEC,FJAC,LDFJAC,TOL,INFO,IWA,WA, + * LWA) + CALL SSQFCN(M,N,X,FVEC,NPROB) + FNORM2 = ENORM(M,FVEC) + NP(IC) = NPROB + NA(IC) = N + MA(IC) = M + NF(IC) = NFEV + NJ(IC) = NJEV + NX(IC) = INFO + FNM(IC) = FNORM2 + WRITE (NWRITE,70) + * FNORM1,FNORM2,NFEV,NJEV,INFO,(X(I), I = 1, N) + FACTOR = TEN*FACTOR + 20 CONTINUE + GO TO 10 + 30 CONTINUE + WRITE (NWRITE,80) IC + WRITE (NWRITE,90) + DO 40 I = 1, IC + WRITE (NWRITE,100) NP(I),NA(I),MA(I),NF(I),NJ(I),NX(I),FNM(I) + 40 CONTINUE + STOP + 50 FORMAT (4I5) + 60 FORMAT ( //// 5X, 8H PROBLEM, I5, 5X, 11H DIMENSIONS, 2I5, 5X // + * ) + 70 FORMAT (5X, 33H INITIAL L2 NORM OF THE RESIDUALS, E15.7 // 5X, + * 33H FINAL L2 NORM OF THE RESIDUALS , E15.7 // 5X, + * 33H NUMBER OF FUNCTION EVALUATIONS , I10 // 5X, + * 33H NUMBER OF JACOBIAN EVALUATIONS , I10 // 5X, + * 15H EXIT PARAMETER, 18X, I10 // 5X, + * 27H FINAL APPROXIMATE SOLUTION // (5X, 5E15.7)) + 80 FORMAT (12H1SUMMARY OF , I3, 16H CALLS TO LMDER1 /) + 90 FORMAT (49H NPROB N M NFEV NJEV INFO FINAL L2 NORM /) + 100 FORMAT (3I5, 3I6, 2X, E15.7) +C +C LAST CARD OF DRIVER. +C + END + SUBROUTINE FCN(M,N,X,FVEC,FJAC,LDFJAC,IFLAG) + INTEGER M,N,LDFJAC,IFLAG + REAL X(N),FVEC(M),FJAC(LDFJAC,N) +C ********** +C +C THE CALLING SEQUENCE OF FCN SHOULD BE IDENTICAL TO THE +C CALLING SEQUENCE OF THE FUNCTION SUBROUTINE IN THE NONLINEAR +C LEAST-SQUARES SOLVER. FCN SHOULD ONLY CALL THE TESTING +C FUNCTION AND JACOBIAN SUBROUTINES SSQFCN AND SSQJAC WITH +C THE APPROPRIATE VALUE OF PROBLEM NUMBER (NPROB). +C +C SUBPROGRAMS CALLED +C +C MINPACK-SUPPLIED ... SSQFCN,SSQJAC +C +C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. +C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE +C +C ********** + INTEGER NPROB,NFEV,NJEV + COMMON /REFNUM/ NPROB,NFEV,NJEV + IF (IFLAG .EQ. 1) CALL SSQFCN(M,N,X,FVEC,NPROB) + IF (IFLAG .EQ. 2) CALL SSQJAC(M,N,X,FJAC,LDFJAC,NPROB) + IF (IFLAG .EQ. 1) NFEV = NFEV + 1 + IF (IFLAG .EQ. 2) NJEV = NJEV + 1 + RETURN +C +C LAST CARD OF INTERFACE SUBROUTINE FCN. +C + END + SUBROUTINE SSQJAC(M,N,X,FJAC,LDFJAC,NPROB) + INTEGER M,N,LDFJAC,NPROB + REAL X(N),FJAC(LDFJAC,N) +C ********** +C +C SUBROUTINE SSQJAC +C +C THIS SUBROUTINE DEFINES THE JACOBIAN MATRICES OF EIGHTEEN +C NONLINEAR LEAST SQUARES PROBLEMS. THE PROBLEM DIMENSIONS ARE +C AS DESCRIBED IN THE PROLOGUE COMMENTS OF SSQFCN. +C +C THE SUBROUTINE STATEMENT IS +C +C SUBROUTINE SSQJAC(M,N,X,FJAC,LDFJAC,NPROB) +C +C WHERE +C +C M AND N ARE POSITIVE INTEGER INPUT VARIABLES. N MUST NOT +C EXCEED M. +C +C X IS AN INPUT ARRAY OF LENGTH N. +C +C FJAC IS AN M BY N OUTPUT ARRAY WHICH CONTAINS THE JACOBIAN +C MATRIX OF THE NPROB FUNCTION EVALUATED AT X. +C +C LDFJAC IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN M +C WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY FJAC. +C +C NPROB IS A POSITIVE INTEGER VARIABLE WHICH DEFINES THE +C NUMBER OF THE PROBLEM. NPROB MUST NOT EXCEED 18. +C +C SUBPROGRAMS CALLED +C +C FORTRAN-SUPPLIED ... ATAN,COS,EXP,SIN,SQRT +C +C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. +C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE +C +C ********** + INTEGER I,IVAR,J,K,MM1,NM1 + REAL C14,C20,C29,C45,C100,DIV,DX,EIGHT,FIVE,FOUR,ONE,PROD,S2, + * TEMP,TEN,THREE,TI,TMP1,TMP2,TMP3,TMP4,TPI,TWO,ZERO + REAL V(11) + REAL FLOAT + DATA ZERO,ONE,TWO,THREE,FOUR,FIVE,EIGHT,TEN,C14,C20,C29,C45,C100 + * /0.0E0,1.0E0,2.0E0,3.0E0,4.0E0,5.0E0,8.0E0,1.0E1,1.4E1, + * 2.0E1,2.9E1,4.5E1,1.0E2/ + DATA V(1),V(2),V(3),V(4),V(5),V(6),V(7),V(8),V(9),V(10),V(11) + * /4.0E0,2.0E0,1.0E0,5.0E-1,2.5E-1,1.67E-1,1.25E-1,1.0E-1, + * 8.33E-2,7.14E-2,6.25E-2/ + FLOAT(IVAR) = IVAR +C +C JACOBIAN ROUTINE SELECTOR. +C + GO TO (10,40,70,130,140,150,180,190,210,230,250,310,330,350,370, + * 400,460,480), NPROB +C +C LINEAR FUNCTION - FULL RANK. +C + 10 CONTINUE + TEMP = TWO/FLOAT(M) + DO 30 J = 1, N + DO 20 I = 1, M + FJAC(I,J) = -TEMP + 20 CONTINUE + FJAC(J,J) = FJAC(J,J) + ONE + 30 CONTINUE + GO TO 500 +C +C LINEAR FUNCTION - RANK 1. +C + 40 CONTINUE + DO 60 J = 1, N + DO 50 I = 1, M + FJAC(I,J) = FLOAT(I)*FLOAT(J) + 50 CONTINUE + 60 CONTINUE + GO TO 500 +C +C LINEAR FUNCTION - RANK 1 WITH ZERO COLUMNS AND ROWS. +C + 70 CONTINUE + DO 90 J = 1, N + DO 80 I = 1, M + FJAC(I,J) = ZERO + 80 CONTINUE + 90 CONTINUE + NM1 = N - 1 + MM1 = M - 1 + IF (NM1 .LT. 2) GO TO 120 + DO 110 J = 2, NM1 + DO 100 I = 2, MM1 + FJAC(I,J) = FLOAT(I-1)*FLOAT(J) + 100 CONTINUE + 110 CONTINUE + 120 CONTINUE + GO TO 500 +C +C ROSENBROCK FUNCTION. +C + 130 CONTINUE + FJAC(1,1) = -C20*X(1) + FJAC(1,2) = TEN + FJAC(2,1) = -ONE + FJAC(2,2) = ZERO + GO TO 500 +C +C HELICAL VALLEY FUNCTION. +C + 140 CONTINUE + TPI = EIGHT*ATAN(ONE) + TEMP = X(1)**2 + X(2)**2 + TMP1 = TPI*TEMP + TMP2 = SQRT(TEMP) + FJAC(1,1) = C100*X(2)/TMP1 + FJAC(1,2) = -C100*X(1)/TMP1 + FJAC(1,3) = TEN + FJAC(2,1) = TEN*X(1)/TMP2 + FJAC(2,2) = TEN*X(2)/TMP2 + FJAC(2,3) = ZERO + FJAC(3,1) = ZERO + FJAC(3,2) = ZERO + FJAC(3,3) = ONE + GO TO 500 +C +C POWELL SINGULAR FUNCTION. +C + 150 CONTINUE + DO 170 J = 1, 4 + DO 160 I = 1, 4 + FJAC(I,J) = ZERO + 160 CONTINUE + 170 CONTINUE + FJAC(1,1) = ONE + FJAC(1,2) = TEN + FJAC(2,3) = SQRT(FIVE) + FJAC(2,4) = -FJAC(2,3) + FJAC(3,2) = TWO*(X(2) - TWO*X(3)) + FJAC(3,3) = -TWO*FJAC(3,2) + FJAC(4,1) = TWO*SQRT(TEN)*(X(1) - X(4)) + FJAC(4,4) = -FJAC(4,1) + GO TO 500 +C +C FREUDENSTEIN AND ROTH FUNCTION. +C + 180 CONTINUE + FJAC(1,1) = ONE + FJAC(1,2) = X(2)*(TEN - THREE*X(2)) - TWO + FJAC(2,1) = ONE + FJAC(2,2) = X(2)*(TWO + THREE*X(2)) - C14 + GO TO 500 +C +C BARD FUNCTION. +C + 190 CONTINUE + DO 200 I = 1, 15 + TMP1 = FLOAT(I) + TMP2 = FLOAT(16-I) + TMP3 = TMP1 + IF (I .GT. 8) TMP3 = TMP2 + TMP4 = (X(2)*TMP2 + X(3)*TMP3)**2 + FJAC(I,1) = -ONE + FJAC(I,2) = TMP1*TMP2/TMP4 + FJAC(I,3) = TMP1*TMP3/TMP4 + 200 CONTINUE + GO TO 500 +C +C KOWALIK AND OSBORNE FUNCTION. +C + 210 CONTINUE + DO 220 I = 1, 11 + TMP1 = V(I)*(V(I) + X(2)) + TMP2 = V(I)*(V(I) + X(3)) + X(4) + FJAC(I,1) = -TMP1/TMP2 + FJAC(I,2) = -V(I)*X(1)/TMP2 + FJAC(I,3) = FJAC(I,1)*FJAC(I,2) + FJAC(I,4) = FJAC(I,3)/V(I) + 220 CONTINUE + GO TO 500 +C +C MEYER FUNCTION. +C + 230 CONTINUE + DO 240 I = 1, 16 + TEMP = FIVE*FLOAT(I) + C45 + X(3) + TMP1 = X(2)/TEMP + TMP2 = EXP(TMP1) + FJAC(I,1) = TMP2 + FJAC(I,2) = X(1)*TMP2/TEMP + FJAC(I,3) = -TMP1*FJAC(I,2) + 240 CONTINUE + GO TO 500 +C +C WATSON FUNCTION. +C + 250 CONTINUE + DO 280 I = 1, 29 + DIV = FLOAT(I)/C29 + S2 = ZERO + DX = ONE + DO 260 J = 1, N + S2 = S2 + DX*X(J) + DX = DIV*DX + 260 CONTINUE + TEMP = TWO*DIV*S2 + DX = ONE/DIV + DO 270 J = 1, N + FJAC(I,J) = DX*(FLOAT(J-1) - TEMP) + DX = DIV*DX + 270 CONTINUE + 280 CONTINUE + DO 300 J = 1, N + DO 290 I = 30, 31 + FJAC(I,J) = ZERO + 290 CONTINUE + 300 CONTINUE + FJAC(30,1) = ONE + FJAC(31,1) = -TWO*X(1) + FJAC(31,2) = ONE + GO TO 500 +C +C BOX 3-DIMENSIONAL FUNCTION. +C + 310 CONTINUE + DO 320 I = 1, M + TEMP = FLOAT(I) + TMP1 = TEMP/TEN + FJAC(I,1) = -TMP1*EXP(-TMP1*X(1)) + FJAC(I,2) = TMP1*EXP(-TMP1*X(2)) + FJAC(I,3) = EXP(-TEMP) - EXP(-TMP1) + 320 CONTINUE + GO TO 500 +C +C JENNRICH AND SAMPSON FUNCTION. +C + 330 CONTINUE + DO 340 I = 1, M + TEMP = FLOAT(I) + FJAC(I,1) = -TEMP*EXP(TEMP*X(1)) + FJAC(I,2) = -TEMP*EXP(TEMP*X(2)) + 340 CONTINUE + GO TO 500 +C +C BROWN AND DENNIS FUNCTION. +C + 350 CONTINUE + DO 360 I = 1, M + TEMP = FLOAT(I)/FIVE + TI = SIN(TEMP) + TMP1 = X(1) + TEMP*X(2) - EXP(TEMP) + TMP2 = X(3) + TI*X(4) - COS(TEMP) + FJAC(I,1) = TWO*TMP1 + FJAC(I,2) = TEMP*FJAC(I,1) + FJAC(I,3) = TWO*TMP2 + FJAC(I,4) = TI*FJAC(I,3) + 360 CONTINUE + GO TO 500 +C +C CHEBYQUAD FUNCTION. +C + 370 CONTINUE + DX = ONE/FLOAT(N) + DO 390 J = 1, N + TMP1 = ONE + TMP2 = TWO*X(J) - ONE + TEMP = TWO*TMP2 + TMP3 = ZERO + TMP4 = TWO + DO 380 I = 1, M + FJAC(I,J) = DX*TMP4 + TI = FOUR*TMP2 + TEMP*TMP4 - TMP3 + TMP3 = TMP4 + TMP4 = TI + TI = TEMP*TMP2 - TMP1 + TMP1 = TMP2 + TMP2 = TI + 380 CONTINUE + 390 CONTINUE + GO TO 500 +C +C BROWN ALMOST-LINEAR FUNCTION. +C + 400 CONTINUE + PROD = ONE + DO 420 J = 1, N + PROD = X(J)*PROD + DO 410 I = 1, N + FJAC(I,J) = ONE + 410 CONTINUE + FJAC(J,J) = TWO + 420 CONTINUE + DO 450 J = 1, N + TEMP = X(J) + IF (TEMP .NE. ZERO) GO TO 440 + TEMP = ONE + PROD = ONE + DO 430 K = 1, N + IF (K .NE. J) PROD = X(K)*PROD + 430 CONTINUE + 440 CONTINUE + FJAC(N,J) = PROD/TEMP + 450 CONTINUE + GO TO 500 +C +C OSBORNE 1 FUNCTION. +C + 460 CONTINUE + DO 470 I = 1, 33 + TEMP = TEN*FLOAT(I-1) + TMP1 = EXP(-X(4)*TEMP) + TMP2 = EXP(-X(5)*TEMP) + FJAC(I,1) = -ONE + FJAC(I,2) = -TMP1 + FJAC(I,3) = -TMP2 + FJAC(I,4) = TEMP*X(2)*TMP1 + FJAC(I,5) = TEMP*X(3)*TMP2 + 470 CONTINUE + GO TO 500 +C +C OSBORNE 2 FUNCTION. +C + 480 CONTINUE + DO 490 I = 1, 65 + TEMP = FLOAT(I-1)/TEN + TMP1 = EXP(-X(5)*TEMP) + TMP2 = EXP(-X(6)*(TEMP-X(9))**2) + TMP3 = EXP(-X(7)*(TEMP-X(10))**2) + TMP4 = EXP(-X(8)*(TEMP-X(11))**2) + FJAC(I,1) = -TMP1 + FJAC(I,2) = -TMP2 + FJAC(I,3) = -TMP3 + FJAC(I,4) = -TMP4 + FJAC(I,5) = TEMP*X(1)*TMP1 + FJAC(I,6) = X(2)*(TEMP - X(9))**2*TMP2 + FJAC(I,7) = X(3)*(TEMP - X(10))**2*TMP3 + FJAC(I,8) = X(4)*(TEMP - X(11))**2*TMP4 + FJAC(I,9) = -TWO*X(2)*X(6)*(TEMP - X(9))*TMP2 + FJAC(I,10) = -TWO*X(3)*X(7)*(TEMP - X(10))*TMP3 + FJAC(I,11) = -TWO*X(4)*X(8)*(TEMP - X(11))*TMP4 + 490 CONTINUE + 500 CONTINUE + RETURN +C +C LAST CARD OF SUBROUTINE SSQJAC. +C + END + SUBROUTINE INITPT(N,X,NPROB,FACTOR) + INTEGER N,NPROB + REAL FACTOR + REAL X(N) +C ********** +C +C SUBROUTINE INITPT +C +C THIS SUBROUTINE SPECIFIES THE STANDARD STARTING POINTS FOR THE +C FUNCTIONS DEFINED BY SUBROUTINE SSQFCN. THE SUBROUTINE RETURNS +C IN X A MULTIPLE (FACTOR) OF THE STANDARD STARTING POINT. FOR +C THE 11TH FUNCTION THE STANDARD STARTING POINT IS ZERO, SO IN +C THIS CASE, IF FACTOR IS NOT UNITY, THEN THE SUBROUTINE RETURNS +C THE VECTOR X(J) = FACTOR, J=1,...,N. +C +C THE SUBROUTINE STATEMENT IS +C +C SUBROUTINE INITPT(N,X,NPROB,FACTOR) +C +C WHERE +C +C N IS A POSITIVE INTEGER INPUT VARIABLE. +C +C X IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE STANDARD +C STARTING POINT FOR PROBLEM NPROB MULTIPLIED BY FACTOR. +C +C NPROB IS A POSITIVE INTEGER INPUT VARIABLE WHICH DEFINES THE +C NUMBER OF THE PROBLEM. NPROB MUST NOT EXCEED 18. +C +C FACTOR IS AN INPUT VARIABLE WHICH SPECIFIES THE MULTIPLE OF +C THE STANDARD STARTING POINT. IF FACTOR IS UNITY, NO +C MULTIPLICATION IS PERFORMED. +C +C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. +C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE +C +C ********** + INTEGER IVAR,J + REAL C1,C2,C3,C4,C5,C6,C7,C8,C9,C10,C11,C12,C13,C14,C15,C16,C17, + * FIVE,H,HALF,ONE,SEVEN,TEN,THREE,TWENTY,TWNTF,TWO,ZERO + REAL FLOAT + DATA ZERO,HALF,ONE,TWO,THREE,FIVE,SEVEN,TEN,TWENTY,TWNTF + * /0.0E0,5.0E-1,1.0E0,2.0E0,3.0E0,5.0E0,7.0E0,1.0E1,2.0E1, + * 2.5E1/ + DATA C1,C2,C3,C4,C5,C6,C7,C8,C9,C10,C11,C12,C13,C14,C15,C16,C17 + * /1.2E0,2.5E-1,3.9E-1,4.15E-1,2.0E-2,4.0E3,2.5E2,3.0E-1, + * 4.0E-1,1.5E0,1.0E-2,1.3E0,6.5E-1,7.0E-1,6.0E-1,4.5E0, + * 5.5E0/ + FLOAT(IVAR) = IVAR +C +C SELECTION OF INITIAL POINT. +C + GO TO (10,10,10,30,40,50,60,70,80,90,100,120,130,140,150,170, + * 190,200), NPROB +C +C LINEAR FUNCTION - FULL RANK OR RANK 1. +C + 10 CONTINUE + DO 20 J = 1, N + X(J) = ONE + 20 CONTINUE + GO TO 210 +C +C ROSENBROCK FUNCTION. +C + 30 CONTINUE + X(1) = -C1 + X(2) = ONE + GO TO 210 +C +C HELICAL VALLEY FUNCTION. +C + 40 CONTINUE + X(1) = -ONE + X(2) = ZERO + X(3) = ZERO + GO TO 210 +C +C POWELL SINGULAR FUNCTION. +C + 50 CONTINUE + X(1) = THREE + X(2) = -ONE + X(3) = ZERO + X(4) = ONE + GO TO 210 +C +C FREUDENSTEIN AND ROTH FUNCTION. +C + 60 CONTINUE + X(1) = HALF + X(2) = -TWO + GO TO 210 +C +C BARD FUNCTION. +C + 70 CONTINUE + X(1) = ONE + X(2) = ONE + X(3) = ONE + GO TO 210 +C +C KOWALIK AND OSBORNE FUNCTION. +C + 80 CONTINUE + X(1) = C2 + X(2) = C3 + X(3) = C4 + X(4) = C3 + GO TO 210 +C +C MEYER FUNCTION. +C + 90 CONTINUE + X(1) = C5 + X(2) = C6 + X(3) = C7 + GO TO 210 +C +C WATSON FUNCTION. +C + 100 CONTINUE + DO 110 J = 1, N + X(J) = ZERO + 110 CONTINUE + GO TO 210 +C +C BOX 3-DIMENSIONAL FUNCTION. +C + 120 CONTINUE + X(1) = ZERO + X(2) = TEN + X(3) = TWENTY + GO TO 210 +C +C JENNRICH AND SAMPSON FUNCTION. +C + 130 CONTINUE + X(1) = C8 + X(2) = C9 + GO TO 210 +C +C BROWN AND DENNIS FUNCTION. +C + 140 CONTINUE + X(1) = TWNTF + X(2) = FIVE + X(3) = -FIVE + X(4) = -ONE + GO TO 210 +C +C CHEBYQUAD FUNCTION. +C + 150 CONTINUE + H = ONE/FLOAT(N+1) + DO 160 J = 1, N + X(J) = FLOAT(J)*H + 160 CONTINUE + GO TO 210 +C +C BROWN ALMOST-LINEAR FUNCTION. +C + 170 CONTINUE + DO 180 J = 1, N + X(J) = HALF + 180 CONTINUE + GO TO 210 +C +C OSBORNE 1 FUNCTION. +C + 190 CONTINUE + X(1) = HALF + X(2) = C10 + X(3) = -ONE + X(4) = C11 + X(5) = C5 + GO TO 210 +C +C OSBORNE 2 FUNCTION. +C + 200 CONTINUE + X(1) = C12 + X(2) = C13 + X(3) = C13 + X(4) = C14 + X(5) = C15 + X(6) = THREE + X(7) = FIVE + X(8) = SEVEN + X(9) = TWO + X(10) = C16 + X(11) = C17 + 210 CONTINUE +C +C COMPUTE MULTIPLE OF INITIAL POINT. +C + IF (FACTOR .EQ. ONE) GO TO 260 + IF (NPROB .EQ. 11) GO TO 230 + DO 220 J = 1, N + X(J) = FACTOR*X(J) + 220 CONTINUE + GO TO 250 + 230 CONTINUE + DO 240 J = 1, N + X(J) = FACTOR + 240 CONTINUE + 250 CONTINUE + 260 CONTINUE + RETURN +C +C LAST CARD OF SUBROUTINE INITPT. +C + END + SUBROUTINE SSQFCN(M,N,X,FVEC,NPROB) + INTEGER M,N,NPROB + REAL X(N),FVEC(M) +C ********** +C +C SUBROUTINE SSQFCN +C +C THIS SUBROUTINE DEFINES THE FUNCTIONS OF EIGHTEEN NONLINEAR +C LEAST SQUARES PROBLEMS. THE ALLOWABLE VALUES OF (M,N) FOR +C FUNCTIONS 1,2 AND 3 ARE VARIABLE BUT WITH M .GE. N. +C FOR FUNCTIONS 4,5,6,7,8,9 AND 10 THE VALUES OF (M,N) ARE +C (2,2),(3,3),(4,4),(2,2),(15,3),(11,4) AND (16,3), RESPECTIVELY. +C FUNCTION 11 (WATSON) HAS M = 31 WITH N USUALLY 6 OR 9. +C HOWEVER, ANY N, N = 2,...,31, IS PERMITTED. +C FUNCTIONS 12,13 AND 14 HAVE N = 3,2 AND 4, RESPECTIVELY, BUT +C ALLOW ANY M .GE. N, WITH THE USUAL CHOICES BEING 10,10 AND 20. +C FUNCTION 15 (CHEBYQUAD) ALLOWS M AND N VARIABLE WITH M .GE. N. +C FUNCTION 16 (BROWN) ALLOWS N VARIABLE WITH M = N. +C FOR FUNCTIONS 17 AND 18, THE VALUES OF (M,N) ARE +C (33,5) AND (65,11), RESPECTIVELY. +C +C THE SUBROUTINE STATEMENT IS +C +C SUBROUTINE SSQFCN(M,N,X,FVEC,NPROB) +C +C WHERE +C +C M AND N ARE POSITIVE INTEGER INPUT VARIABLES. N MUST NOT +C EXCEED M. +C +C X IS AN INPUT ARRAY OF LENGTH N. +C +C FVEC IS AN OUTPUT ARRAY OF LENGTH M WHICH CONTAINS THE NPROB +C FUNCTION EVALUATED AT X. +C +C NPROB IS A POSITIVE INTEGER INPUT VARIABLE WHICH DEFINES THE +C NUMBER OF THE PROBLEM. NPROB MUST NOT EXCEED 18. +C +C SUBPROGRAMS CALLED +C +C FORTRAN-SUPPLIED ... ATAN,COS,EXP,SIN,SQRT,SIGN +C +C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. +C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE +C +C ********** + INTEGER I,IEV,IVAR,J,NM1 + REAL C13,C14,C29,C45,DIV,DX,EIGHT,FIVE,ONE,PROD,SUM,S1,S2,TEMP, + * TEN,TI,TMP1,TMP2,TMP3,TMP4,TPI,TWO,ZERO,ZP25,ZP5 + REAL V(11),Y1(15),Y2(11),Y3(16),Y4(33),Y5(65) + REAL FLOAT + DATA ZERO,ZP25,ZP5,ONE,TWO,FIVE,EIGHT,TEN,C13,C14,C29,C45 + * /0.0E0,2.5E-1,5.0E-1,1.0E0,2.0E0,5.0E0,8.0E0,1.0E1,1.3E1, + * 1.4E1,2.9E1,4.5E1/ + DATA V(1),V(2),V(3),V(4),V(5),V(6),V(7),V(8),V(9),V(10),V(11) + * /4.0E0,2.0E0,1.0E0,5.0E-1,2.5E-1,1.67E-1,1.25E-1,1.0E-1, + * 8.33E-2,7.14E-2,6.25E-2/ + DATA Y1(1),Y1(2),Y1(3),Y1(4),Y1(5),Y1(6),Y1(7),Y1(8),Y1(9), + * Y1(10),Y1(11),Y1(12),Y1(13),Y1(14),Y1(15) + * /1.4E-1,1.8E-1,2.2E-1,2.5E-1,2.9E-1,3.2E-1,3.5E-1,3.9E-1, + * 3.7E-1,5.8E-1,7.3E-1,9.6E-1,1.34E0,2.1E0,4.39E0/ + DATA Y2(1),Y2(2),Y2(3),Y2(4),Y2(5),Y2(6),Y2(7),Y2(8),Y2(9), + * Y2(10),Y2(11) + * /1.957E-1,1.947E-1,1.735E-1,1.6E-1,8.44E-2,6.27E-2,4.56E-2, + * 3.42E-2,3.23E-2,2.35E-2,2.46E-2/ + DATA Y3(1),Y3(2),Y3(3),Y3(4),Y3(5),Y3(6),Y3(7),Y3(8),Y3(9), + * Y3(10),Y3(11),Y3(12),Y3(13),Y3(14),Y3(15),Y3(16) + * /3.478E4,2.861E4,2.365E4,1.963E4,1.637E4,1.372E4,1.154E4, + * 9.744E3,8.261E3,7.03E3,6.005E3,5.147E3,4.427E3,3.82E3, + * 3.307E3,2.872E3/ + DATA Y4(1),Y4(2),Y4(3),Y4(4),Y4(5),Y4(6),Y4(7),Y4(8),Y4(9), + * Y4(10),Y4(11),Y4(12),Y4(13),Y4(14),Y4(15),Y4(16),Y4(17), + * Y4(18),Y4(19),Y4(20),Y4(21),Y4(22),Y4(23),Y4(24),Y4(25), + * Y4(26),Y4(27),Y4(28),Y4(29),Y4(30),Y4(31),Y4(32),Y4(33) + * /8.44E-1,9.08E-1,9.32E-1,9.36E-1,9.25E-1,9.08E-1,8.81E-1, + * 8.5E-1,8.18E-1,7.84E-1,7.51E-1,7.18E-1,6.85E-1,6.58E-1, + * 6.28E-1,6.03E-1,5.8E-1,5.58E-1,5.38E-1,5.22E-1,5.06E-1, + * 4.9E-1,4.78E-1,4.67E-1,4.57E-1,4.48E-1,4.38E-1,4.31E-1, + * 4.24E-1,4.2E-1,4.14E-1,4.11E-1,4.06E-1/ + DATA Y5(1),Y5(2),Y5(3),Y5(4),Y5(5),Y5(6),Y5(7),Y5(8),Y5(9), + * Y5(10),Y5(11),Y5(12),Y5(13),Y5(14),Y5(15),Y5(16),Y5(17), + * Y5(18),Y5(19),Y5(20),Y5(21),Y5(22),Y5(23),Y5(24),Y5(25), + * Y5(26),Y5(27),Y5(28),Y5(29),Y5(30),Y5(31),Y5(32),Y5(33), + * Y5(34),Y5(35),Y5(36),Y5(37),Y5(38),Y5(39),Y5(40),Y5(41), + * Y5(42),Y5(43),Y5(44),Y5(45),Y5(46),Y5(47),Y5(48),Y5(49), + * Y5(50),Y5(51),Y5(52),Y5(53),Y5(54),Y5(55),Y5(56),Y5(57), + * Y5(58),Y5(59),Y5(60),Y5(61),Y5(62),Y5(63),Y5(64),Y5(65) + * /1.366E0,1.191E0,1.112E0,1.013E0,9.91E-1,8.85E-1,8.31E-1, + * 8.47E-1,7.86E-1,7.25E-1,7.46E-1,6.79E-1,6.08E-1,6.55E-1, + * 6.16E-1,6.06E-1,6.02E-1,6.26E-1,6.51E-1,7.24E-1,6.49E-1, + * 6.49E-1,6.94E-1,6.44E-1,6.24E-1,6.61E-1,6.12E-1,5.58E-1, + * 5.33E-1,4.95E-1,5.0E-1,4.23E-1,3.95E-1,3.75E-1,3.72E-1, + * 3.91E-1,3.96E-1,4.05E-1,4.28E-1,4.29E-1,5.23E-1,5.62E-1, + * 6.07E-1,6.53E-1,6.72E-1,7.08E-1,6.33E-1,6.68E-1,6.45E-1, + * 6.32E-1,5.91E-1,5.59E-1,5.97E-1,6.25E-1,7.39E-1,7.1E-1, + * 7.29E-1,7.2E-1,6.36E-1,5.81E-1,4.28E-1,2.92E-1,1.62E-1, + * 9.8E-2,5.4E-2/ + FLOAT(IVAR) = IVAR +C +C FUNCTION ROUTINE SELECTOR. +C + GO TO (10,40,70,110,120,130,140,150,170,190,210,250,270,290,310, + * 360,390,410), NPROB +C +C LINEAR FUNCTION - FULL RANK. +C + 10 CONTINUE + SUM = ZERO + DO 20 J = 1, N + SUM = SUM + X(J) + 20 CONTINUE + TEMP = TWO*SUM/FLOAT(M) + ONE + DO 30 I = 1, M + FVEC(I) = -TEMP + IF (I .LE. N) FVEC(I) = FVEC(I) + X(I) + 30 CONTINUE + GO TO 430 +C +C LINEAR FUNCTION - RANK 1. +C + 40 CONTINUE + SUM = ZERO + DO 50 J = 1, N + SUM = SUM + FLOAT(J)*X(J) + 50 CONTINUE + DO 60 I = 1, M + FVEC(I) = FLOAT(I)*SUM - ONE + 60 CONTINUE + GO TO 430 +C +C LINEAR FUNCTION - RANK 1 WITH ZERO COLUMNS AND ROWS. +C + 70 CONTINUE + SUM = ZERO + NM1 = N - 1 + IF (NM1 .LT. 2) GO TO 90 + DO 80 J = 2, NM1 + SUM = SUM + FLOAT(J)*X(J) + 80 CONTINUE + 90 CONTINUE + DO 100 I = 1, M + FVEC(I) = FLOAT(I-1)*SUM - ONE + 100 CONTINUE + FVEC(M) = -ONE + GO TO 430 +C +C ROSENBROCK FUNCTION. +C + 110 CONTINUE + FVEC(1) = TEN*(X(2) - X(1)**2) + FVEC(2) = ONE - X(1) + GO TO 430 +C +C HELICAL VALLEY FUNCTION. +C + 120 CONTINUE + TPI = EIGHT*ATAN(ONE) + TMP1 = SIGN(ZP25,X(2)) + IF (X(1) .GT. ZERO) TMP1 = ATAN(X(2)/X(1))/TPI + IF (X(1) .LT. ZERO) TMP1 = ATAN(X(2)/X(1))/TPI + ZP5 + TMP2 = SQRT(X(1)**2+X(2)**2) + FVEC(1) = TEN*(X(3) - TEN*TMP1) + FVEC(2) = TEN*(TMP2 - ONE) + FVEC(3) = X(3) + GO TO 430 +C +C POWELL SINGULAR FUNCTION. +C + 130 CONTINUE + FVEC(1) = X(1) + TEN*X(2) + FVEC(2) = SQRT(FIVE)*(X(3) - X(4)) + FVEC(3) = (X(2) - TWO*X(3))**2 + FVEC(4) = SQRT(TEN)*(X(1) - X(4))**2 + GO TO 430 +C +C FREUDENSTEIN AND ROTH FUNCTION. +C + 140 CONTINUE + FVEC(1) = -C13 + X(1) + ((FIVE - X(2))*X(2) - TWO)*X(2) + FVEC(2) = -C29 + X(1) + ((ONE + X(2))*X(2) - C14)*X(2) + GO TO 430 +C +C BARD FUNCTION. +C + 150 CONTINUE + DO 160 I = 1, 15 + TMP1 = FLOAT(I) + TMP2 = FLOAT(16-I) + TMP3 = TMP1 + IF (I .GT. 8) TMP3 = TMP2 + FVEC(I) = Y1(I) - (X(1) + TMP1/(X(2)*TMP2 + X(3)*TMP3)) + 160 CONTINUE + GO TO 430 +C +C KOWALIK AND OSBORNE FUNCTION. +C + 170 CONTINUE + DO 180 I = 1, 11 + TMP1 = V(I)*(V(I) + X(2)) + TMP2 = V(I)*(V(I) + X(3)) + X(4) + FVEC(I) = Y2(I) - X(1)*TMP1/TMP2 + 180 CONTINUE + GO TO 430 +C +C MEYER FUNCTION. +C + 190 CONTINUE + DO 200 I = 1, 16 + TEMP = FIVE*FLOAT(I) + C45 + X(3) + TMP1 = X(2)/TEMP + TMP2 = EXP(TMP1) + FVEC(I) = X(1)*TMP2 - Y3(I) + 200 CONTINUE + GO TO 430 +C +C WATSON FUNCTION. +C + 210 CONTINUE + DO 240 I = 1, 29 + DIV = FLOAT(I)/C29 + S1 = ZERO + DX = ONE + DO 220 J = 2, N + S1 = S1 + FLOAT(J-1)*DX*X(J) + DX = DIV*DX + 220 CONTINUE + S2 = ZERO + DX = ONE + DO 230 J = 1, N + S2 = S2 + DX*X(J) + DX = DIV*DX + 230 CONTINUE + FVEC(I) = S1 - S2**2 - ONE + 240 CONTINUE + FVEC(30) = X(1) + FVEC(31) = X(2) - X(1)**2 - ONE + GO TO 430 +C +C BOX 3-DIMENSIONAL FUNCTION. +C + 250 CONTINUE + DO 260 I = 1, M + TEMP = FLOAT(I) + TMP1 = TEMP/TEN + FVEC(I) = EXP(-TMP1*X(1)) - EXP(-TMP1*X(2)) + * + (EXP(-TEMP) - EXP(-TMP1))*X(3) + 260 CONTINUE + GO TO 430 +C +C JENNRICH AND SAMPSON FUNCTION. +C + 270 CONTINUE + DO 280 I = 1, M + TEMP = FLOAT(I) + FVEC(I) = TWO + TWO*TEMP - EXP(TEMP*X(1)) - EXP(TEMP*X(2)) + 280 CONTINUE + GO TO 430 +C +C BROWN AND DENNIS FUNCTION. +C + 290 CONTINUE + DO 300 I = 1, M + TEMP = FLOAT(I)/FIVE + TMP1 = X(1) + TEMP*X(2) - EXP(TEMP) + TMP2 = X(3) + SIN(TEMP)*X(4) - COS(TEMP) + FVEC(I) = TMP1**2 + TMP2**2 + 300 CONTINUE + GO TO 430 +C +C CHEBYQUAD FUNCTION. +C + 310 CONTINUE + DO 320 I = 1, M + FVEC(I) = ZERO + 320 CONTINUE + DO 340 J = 1, N + TMP1 = ONE + TMP2 = TWO*X(J) - ONE + TEMP = TWO*TMP2 + DO 330 I = 1, M + FVEC(I) = FVEC(I) + TMP2 + TI = TEMP*TMP2 - TMP1 + TMP1 = TMP2 + TMP2 = TI + 330 CONTINUE + 340 CONTINUE + DX = ONE/FLOAT(N) + IEV = -1 + DO 350 I = 1, M + FVEC(I) = DX*FVEC(I) + IF (IEV .GT. 0) FVEC(I) = FVEC(I) + ONE/(FLOAT(I)**2 - ONE) + IEV = -IEV + 350 CONTINUE + GO TO 430 +C +C BROWN ALMOST-LINEAR FUNCTION. +C + 360 CONTINUE + SUM = -FLOAT(N+1) + PROD = ONE + DO 370 J = 1, N + SUM = SUM + X(J) + PROD = X(J)*PROD + 370 CONTINUE + DO 380 I = 1, N + FVEC(I) = X(I) + SUM + 380 CONTINUE + FVEC(N) = PROD - ONE + GO TO 430 +C +C OSBORNE 1 FUNCTION. +C + 390 CONTINUE + DO 400 I = 1, 33 + TEMP = TEN*FLOAT(I-1) + TMP1 = EXP(-X(4)*TEMP) + TMP2 = EXP(-X(5)*TEMP) + FVEC(I) = Y4(I) - (X(1) + X(2)*TMP1 + X(3)*TMP2) + 400 CONTINUE + GO TO 430 +C +C OSBORNE 2 FUNCTION. +C + 410 CONTINUE + DO 420 I = 1, 65 + TEMP = FLOAT(I-1)/TEN + TMP1 = EXP(-X(5)*TEMP) + TMP2 = EXP(-X(6)*(TEMP-X(9))**2) + TMP3 = EXP(-X(7)*(TEMP-X(10))**2) + TMP4 = EXP(-X(8)*(TEMP-X(11))**2) + FVEC(I) = Y5(I) + * - (X(1)*TMP1 + X(2)*TMP2 + X(3)*TMP3 + X(4)*TMP4) + 420 CONTINUE + 430 CONTINUE + RETURN +C +C LAST CARD OF SUBROUTINE SSQFCN. +C + END diff --git a/ex/file11 b/ex/file11 new file mode 100644 index 0000000..adbbbdd --- /dev/null +++ b/ex/file11 @@ -0,0 +1,1033 @@ +C ********** +C +C THIS PROGRAM TESTS CODES FOR THE LEAST-SQUARES SOLUTION OF +C M NONLINEAR EQUATIONS IN N VARIABLES. IT CONSISTS OF A DRIVER +C AND AN INTERFACE SUBROUTINE FCN. THE DRIVER READS IN DATA, +C CALLS THE NONLINEAR LEAST-SQUARES SOLVER, AND FINALLY PRINTS +C OUT INFORMATION ON THE PERFORMANCE OF THE SOLVER. THIS IS +C ONLY A SAMPLE DRIVER, MANY OTHER DRIVERS ARE POSSIBLE. THE +C INTERFACE SUBROUTINE FCN IS NECESSARY TO TAKE INTO ACCOUNT THE +C FORMS OF CALLING SEQUENCES USED BY THE FUNCTION AND JACOBIAN +C SUBROUTINES IN THE VARIOUS NONLINEAR LEAST-SQUARES SOLVERS. +C +C SUBPROGRAMS CALLED +C +C USER-SUPPLIED ...... FCN +C +C MINPACK-SUPPLIED ... SPMPAR,ENORM,INITPT,LMSTR1,SSQFCN +C +C FORTRAN-SUPPLIED ... SQRT +C +C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. +C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE +C +C ********** + INTEGER I,IC,INFO,K,LDFJAC,LWA,M,N,NFEV,NJEV,NPROB,NREAD,NTRIES, + * NWRITE + INTEGER IWA(40),MA(60),NA(60),NF(60),NJ(60),NP(60),NX(60) + REAL FACTOR,FNORM1,FNORM2,ONE,TEN,TOL + REAL FJAC(40,40),FNM(60),FVEC(65),WA(265),X(40) + REAL SPMPAR,ENORM + EXTERNAL FCN + COMMON /REFNUM/ NPROB,NFEV,NJEV +C +C LOGICAL INPUT UNIT IS ASSUMED TO BE NUMBER 5. +C LOGICAL OUTPUT UNIT IS ASSUMED TO BE NUMBER 6. +C + DATA NREAD,NWRITE /5,6/ +C + DATA ONE,TEN /1.0E0,1.0E1/ + TOL = SQRT(SPMPAR(1)) + LDFJAC = 40 + LWA = 265 + IC = 0 + 10 CONTINUE + READ (NREAD,50) NPROB,N,M,NTRIES + IF (NPROB .LE. 0) GO TO 30 + FACTOR = ONE + DO 20 K = 1, NTRIES + IC = IC + 1 + CALL INITPT(N,X,NPROB,FACTOR) + CALL SSQFCN(M,N,X,FVEC,NPROB) + FNORM1 = ENORM(M,FVEC) + WRITE (NWRITE,60) NPROB,N,M + NFEV = 0 + NJEV = 0 + CALL LMSTR1(FCN,M,N,X,FVEC,FJAC,LDFJAC,TOL,INFO,IWA,WA, + * LWA) + CALL SSQFCN(M,N,X,FVEC,NPROB) + FNORM2 = ENORM(M,FVEC) + NP(IC) = NPROB + NA(IC) = N + MA(IC) = M + NF(IC) = NFEV + NJ(IC) = NJEV + NX(IC) = INFO + FNM(IC) = FNORM2 + WRITE (NWRITE,70) + * FNORM1,FNORM2,NFEV,NJEV,INFO,(X(I), I = 1, N) + FACTOR = TEN*FACTOR + 20 CONTINUE + GO TO 10 + 30 CONTINUE + WRITE (NWRITE,80) IC + WRITE (NWRITE,90) + DO 40 I = 1, IC + WRITE (NWRITE,100) NP(I),NA(I),MA(I),NF(I),NJ(I),NX(I),FNM(I) + 40 CONTINUE + STOP + 50 FORMAT (4I5) + 60 FORMAT ( //// 5X, 8H PROBLEM, I5, 5X, 11H DIMENSIONS, 2I5, 5X // + * ) + 70 FORMAT (5X, 33H INITIAL L2 NORM OF THE RESIDUALS, E15.7 // 5X, + * 33H FINAL L2 NORM OF THE RESIDUALS , E15.7 // 5X, + * 33H NUMBER OF FUNCTION EVALUATIONS , I10 // 5X, + * 33H NUMBER OF JACOBIAN EVALUATIONS , I10 // 5X, + * 15H EXIT PARAMETER, 18X, I10 // 5X, + * 27H FINAL APPROXIMATE SOLUTION // (5X, 5E15.7)) + 80 FORMAT (12H1SUMMARY OF , I3, 16H CALLS TO LMSTR1 /) + 90 FORMAT (49H NPROB N M NFEV NJEV INFO FINAL L2 NORM /) + 100 FORMAT (3I5, 3I6, 2X, E15.7) +C +C LAST CARD OF DRIVER. +C + END + SUBROUTINE FCN(M,N,X,FVEC,FJROW,IFLAG) + INTEGER M,N,IFLAG + REAL X(N),FVEC(M),FJROW(N) +C ********** +C +C THE CALLING SEQUENCE OF FCN SHOULD BE IDENTICAL TO THE +C CALLING SEQUENCE OF THE FUNCTION SUBROUTINE IN THE NONLINEAR +C LEAST SQUARES SOLVER. IF IFLAG = 1, FCN SHOULD ONLY CALL THE +C TESTING FUNCTION SUBROUTINE SSQFCN. IF IFLAG = I, I .GE. 2, +C FCN SHOULD ONLY CALL SUBROUTINE SSQJAC TO CALCULATE THE +C (I-1)-ST ROW OF THE JACOBIAN. (THE SSQJAC SUBROUTINE PROVIDED +C HERE FOR TESTING PURPOSES CALCULATES THE ENTIRE JACOBIAN +C MATRIX AND IS THEREFORE CALLED ONLY WHEN IFLAG = 2.) EACH +C CALL TO SSQFCN OR SSQJAC SHOULD SPECIFY THE APPROPRIATE +C VALUE OF PROBLEM NUMBER (NPROB). +C +C SUBPROGRAMS CALLED +C +C MINPACK-SUPPLIED ... SSQFCN,SSQJAC +C +C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. +C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE +C +C ********** + INTEGER NPROB,NFEV,NJEV,J + REAL TEMP(65,40) + COMMON /REFNUM/ NPROB,NFEV,NJEV + IF (IFLAG .EQ. 1) CALL SSQFCN(M,N,X,FVEC,NPROB) + IF (IFLAG .EQ. 2) CALL SSQJAC(M,N,X,TEMP,65,NPROB) + IF (IFLAG .EQ. 1) NFEV = NFEV + 1 + IF (IFLAG .EQ. 2) NJEV = NJEV + 1 + IF (IFLAG .EQ. 1) GO TO 120 + DO 110 J = 1, N + FJROW(J) = TEMP(IFLAG-1,J) + 110 CONTINUE + 120 CONTINUE + RETURN +C +C LAST CARD OF INTERFACE SUBROUTINE FCN. +C + END + SUBROUTINE SSQJAC(M,N,X,FJAC,LDFJAC,NPROB) + INTEGER M,N,LDFJAC,NPROB + REAL X(N),FJAC(LDFJAC,N) +C ********** +C +C SUBROUTINE SSQJAC +C +C THIS SUBROUTINE DEFINES THE JACOBIAN MATRICES OF EIGHTEEN +C NONLINEAR LEAST SQUARES PROBLEMS. THE PROBLEM DIMENSIONS ARE +C AS DESCRIBED IN THE PROLOGUE COMMENTS OF SSQFCN. +C +C THE SUBROUTINE STATEMENT IS +C +C SUBROUTINE SSQJAC(M,N,X,FJAC,LDFJAC,NPROB) +C +C WHERE +C +C M AND N ARE POSITIVE INTEGER INPUT VARIABLES. N MUST NOT +C EXCEED M. +C +C X IS AN INPUT ARRAY OF LENGTH N. +C +C FJAC IS AN M BY N OUTPUT ARRAY WHICH CONTAINS THE JACOBIAN +C MATRIX OF THE NPROB FUNCTION EVALUATED AT X. +C +C LDFJAC IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN M +C WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY FJAC. +C +C NPROB IS A POSITIVE INTEGER VARIABLE WHICH DEFINES THE +C NUMBER OF THE PROBLEM. NPROB MUST NOT EXCEED 18. +C +C SUBPROGRAMS CALLED +C +C FORTRAN-SUPPLIED ... ATAN,COS,EXP,SIN,SQRT +C +C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. +C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE +C +C ********** + INTEGER I,IVAR,J,K,MM1,NM1 + REAL C14,C20,C29,C45,C100,DIV,DX,EIGHT,FIVE,FOUR,ONE,PROD,S2, + * TEMP,TEN,THREE,TI,TMP1,TMP2,TMP3,TMP4,TPI,TWO,ZERO + REAL V(11) + REAL FLOAT + DATA ZERO,ONE,TWO,THREE,FOUR,FIVE,EIGHT,TEN,C14,C20,C29,C45,C100 + * /0.0E0,1.0E0,2.0E0,3.0E0,4.0E0,5.0E0,8.0E0,1.0E1,1.4E1, + * 2.0E1,2.9E1,4.5E1,1.0E2/ + DATA V(1),V(2),V(3),V(4),V(5),V(6),V(7),V(8),V(9),V(10),V(11) + * /4.0E0,2.0E0,1.0E0,5.0E-1,2.5E-1,1.67E-1,1.25E-1,1.0E-1, + * 8.33E-2,7.14E-2,6.25E-2/ + FLOAT(IVAR) = IVAR +C +C JACOBIAN ROUTINE SELECTOR. +C + GO TO (10,40,70,130,140,150,180,190,210,230,250,310,330,350,370, + * 400,460,480), NPROB +C +C LINEAR FUNCTION - FULL RANK. +C + 10 CONTINUE + TEMP = TWO/FLOAT(M) + DO 30 J = 1, N + DO 20 I = 1, M + FJAC(I,J) = -TEMP + 20 CONTINUE + FJAC(J,J) = FJAC(J,J) + ONE + 30 CONTINUE + GO TO 500 +C +C LINEAR FUNCTION - RANK 1. +C + 40 CONTINUE + DO 60 J = 1, N + DO 50 I = 1, M + FJAC(I,J) = FLOAT(I)*FLOAT(J) + 50 CONTINUE + 60 CONTINUE + GO TO 500 +C +C LINEAR FUNCTION - RANK 1 WITH ZERO COLUMNS AND ROWS. +C + 70 CONTINUE + DO 90 J = 1, N + DO 80 I = 1, M + FJAC(I,J) = ZERO + 80 CONTINUE + 90 CONTINUE + NM1 = N - 1 + MM1 = M - 1 + IF (NM1 .LT. 2) GO TO 120 + DO 110 J = 2, NM1 + DO 100 I = 2, MM1 + FJAC(I,J) = FLOAT(I-1)*FLOAT(J) + 100 CONTINUE + 110 CONTINUE + 120 CONTINUE + GO TO 500 +C +C ROSENBROCK FUNCTION. +C + 130 CONTINUE + FJAC(1,1) = -C20*X(1) + FJAC(1,2) = TEN + FJAC(2,1) = -ONE + FJAC(2,2) = ZERO + GO TO 500 +C +C HELICAL VALLEY FUNCTION. +C + 140 CONTINUE + TPI = EIGHT*ATAN(ONE) + TEMP = X(1)**2 + X(2)**2 + TMP1 = TPI*TEMP + TMP2 = SQRT(TEMP) + FJAC(1,1) = C100*X(2)/TMP1 + FJAC(1,2) = -C100*X(1)/TMP1 + FJAC(1,3) = TEN + FJAC(2,1) = TEN*X(1)/TMP2 + FJAC(2,2) = TEN*X(2)/TMP2 + FJAC(2,3) = ZERO + FJAC(3,1) = ZERO + FJAC(3,2) = ZERO + FJAC(3,3) = ONE + GO TO 500 +C +C POWELL SINGULAR FUNCTION. +C + 150 CONTINUE + DO 170 J = 1, 4 + DO 160 I = 1, 4 + FJAC(I,J) = ZERO + 160 CONTINUE + 170 CONTINUE + FJAC(1,1) = ONE + FJAC(1,2) = TEN + FJAC(2,3) = SQRT(FIVE) + FJAC(2,4) = -FJAC(2,3) + FJAC(3,2) = TWO*(X(2) - TWO*X(3)) + FJAC(3,3) = -TWO*FJAC(3,2) + FJAC(4,1) = TWO*SQRT(TEN)*(X(1) - X(4)) + FJAC(4,4) = -FJAC(4,1) + GO TO 500 +C +C FREUDENSTEIN AND ROTH FUNCTION. +C + 180 CONTINUE + FJAC(1,1) = ONE + FJAC(1,2) = X(2)*(TEN - THREE*X(2)) - TWO + FJAC(2,1) = ONE + FJAC(2,2) = X(2)*(TWO + THREE*X(2)) - C14 + GO TO 500 +C +C BARD FUNCTION. +C + 190 CONTINUE + DO 200 I = 1, 15 + TMP1 = FLOAT(I) + TMP2 = FLOAT(16-I) + TMP3 = TMP1 + IF (I .GT. 8) TMP3 = TMP2 + TMP4 = (X(2)*TMP2 + X(3)*TMP3)**2 + FJAC(I,1) = -ONE + FJAC(I,2) = TMP1*TMP2/TMP4 + FJAC(I,3) = TMP1*TMP3/TMP4 + 200 CONTINUE + GO TO 500 +C +C KOWALIK AND OSBORNE FUNCTION. +C + 210 CONTINUE + DO 220 I = 1, 11 + TMP1 = V(I)*(V(I) + X(2)) + TMP2 = V(I)*(V(I) + X(3)) + X(4) + FJAC(I,1) = -TMP1/TMP2 + FJAC(I,2) = -V(I)*X(1)/TMP2 + FJAC(I,3) = FJAC(I,1)*FJAC(I,2) + FJAC(I,4) = FJAC(I,3)/V(I) + 220 CONTINUE + GO TO 500 +C +C MEYER FUNCTION. +C + 230 CONTINUE + DO 240 I = 1, 16 + TEMP = FIVE*FLOAT(I) + C45 + X(3) + TMP1 = X(2)/TEMP + TMP2 = EXP(TMP1) + FJAC(I,1) = TMP2 + FJAC(I,2) = X(1)*TMP2/TEMP + FJAC(I,3) = -TMP1*FJAC(I,2) + 240 CONTINUE + GO TO 500 +C +C WATSON FUNCTION. +C + 250 CONTINUE + DO 280 I = 1, 29 + DIV = FLOAT(I)/C29 + S2 = ZERO + DX = ONE + DO 260 J = 1, N + S2 = S2 + DX*X(J) + DX = DIV*DX + 260 CONTINUE + TEMP = TWO*DIV*S2 + DX = ONE/DIV + DO 270 J = 1, N + FJAC(I,J) = DX*(FLOAT(J-1) - TEMP) + DX = DIV*DX + 270 CONTINUE + 280 CONTINUE + DO 300 J = 1, N + DO 290 I = 30, 31 + FJAC(I,J) = ZERO + 290 CONTINUE + 300 CONTINUE + FJAC(30,1) = ONE + FJAC(31,1) = -TWO*X(1) + FJAC(31,2) = ONE + GO TO 500 +C +C BOX 3-DIMENSIONAL FUNCTION. +C + 310 CONTINUE + DO 320 I = 1, M + TEMP = FLOAT(I) + TMP1 = TEMP/TEN + FJAC(I,1) = -TMP1*EXP(-TMP1*X(1)) + FJAC(I,2) = TMP1*EXP(-TMP1*X(2)) + FJAC(I,3) = EXP(-TEMP) - EXP(-TMP1) + 320 CONTINUE + GO TO 500 +C +C JENNRICH AND SAMPSON FUNCTION. +C + 330 CONTINUE + DO 340 I = 1, M + TEMP = FLOAT(I) + FJAC(I,1) = -TEMP*EXP(TEMP*X(1)) + FJAC(I,2) = -TEMP*EXP(TEMP*X(2)) + 340 CONTINUE + GO TO 500 +C +C BROWN AND DENNIS FUNCTION. +C + 350 CONTINUE + DO 360 I = 1, M + TEMP = FLOAT(I)/FIVE + TI = SIN(TEMP) + TMP1 = X(1) + TEMP*X(2) - EXP(TEMP) + TMP2 = X(3) + TI*X(4) - COS(TEMP) + FJAC(I,1) = TWO*TMP1 + FJAC(I,2) = TEMP*FJAC(I,1) + FJAC(I,3) = TWO*TMP2 + FJAC(I,4) = TI*FJAC(I,3) + 360 CONTINUE + GO TO 500 +C +C CHEBYQUAD FUNCTION. +C + 370 CONTINUE + DX = ONE/FLOAT(N) + DO 390 J = 1, N + TMP1 = ONE + TMP2 = TWO*X(J) - ONE + TEMP = TWO*TMP2 + TMP3 = ZERO + TMP4 = TWO + DO 380 I = 1, M + FJAC(I,J) = DX*TMP4 + TI = FOUR*TMP2 + TEMP*TMP4 - TMP3 + TMP3 = TMP4 + TMP4 = TI + TI = TEMP*TMP2 - TMP1 + TMP1 = TMP2 + TMP2 = TI + 380 CONTINUE + 390 CONTINUE + GO TO 500 +C +C BROWN ALMOST-LINEAR FUNCTION. +C + 400 CONTINUE + PROD = ONE + DO 420 J = 1, N + PROD = X(J)*PROD + DO 410 I = 1, N + FJAC(I,J) = ONE + 410 CONTINUE + FJAC(J,J) = TWO + 420 CONTINUE + DO 450 J = 1, N + TEMP = X(J) + IF (TEMP .NE. ZERO) GO TO 440 + TEMP = ONE + PROD = ONE + DO 430 K = 1, N + IF (K .NE. J) PROD = X(K)*PROD + 430 CONTINUE + 440 CONTINUE + FJAC(N,J) = PROD/TEMP + 450 CONTINUE + GO TO 500 +C +C OSBORNE 1 FUNCTION. +C + 460 CONTINUE + DO 470 I = 1, 33 + TEMP = TEN*FLOAT(I-1) + TMP1 = EXP(-X(4)*TEMP) + TMP2 = EXP(-X(5)*TEMP) + FJAC(I,1) = -ONE + FJAC(I,2) = -TMP1 + FJAC(I,3) = -TMP2 + FJAC(I,4) = TEMP*X(2)*TMP1 + FJAC(I,5) = TEMP*X(3)*TMP2 + 470 CONTINUE + GO TO 500 +C +C OSBORNE 2 FUNCTION. +C + 480 CONTINUE + DO 490 I = 1, 65 + TEMP = FLOAT(I-1)/TEN + TMP1 = EXP(-X(5)*TEMP) + TMP2 = EXP(-X(6)*(TEMP-X(9))**2) + TMP3 = EXP(-X(7)*(TEMP-X(10))**2) + TMP4 = EXP(-X(8)*(TEMP-X(11))**2) + FJAC(I,1) = -TMP1 + FJAC(I,2) = -TMP2 + FJAC(I,3) = -TMP3 + FJAC(I,4) = -TMP4 + FJAC(I,5) = TEMP*X(1)*TMP1 + FJAC(I,6) = X(2)*(TEMP - X(9))**2*TMP2 + FJAC(I,7) = X(3)*(TEMP - X(10))**2*TMP3 + FJAC(I,8) = X(4)*(TEMP - X(11))**2*TMP4 + FJAC(I,9) = -TWO*X(2)*X(6)*(TEMP - X(9))*TMP2 + FJAC(I,10) = -TWO*X(3)*X(7)*(TEMP - X(10))*TMP3 + FJAC(I,11) = -TWO*X(4)*X(8)*(TEMP - X(11))*TMP4 + 490 CONTINUE + 500 CONTINUE + RETURN +C +C LAST CARD OF SUBROUTINE SSQJAC. +C + END + SUBROUTINE INITPT(N,X,NPROB,FACTOR) + INTEGER N,NPROB + REAL FACTOR + REAL X(N) +C ********** +C +C SUBROUTINE INITPT +C +C THIS SUBROUTINE SPECIFIES THE STANDARD STARTING POINTS FOR THE +C FUNCTIONS DEFINED BY SUBROUTINE SSQFCN. THE SUBROUTINE RETURNS +C IN X A MULTIPLE (FACTOR) OF THE STANDARD STARTING POINT. FOR +C THE 11TH FUNCTION THE STANDARD STARTING POINT IS ZERO, SO IN +C THIS CASE, IF FACTOR IS NOT UNITY, THEN THE SUBROUTINE RETURNS +C THE VECTOR X(J) = FACTOR, J=1,...,N. +C +C THE SUBROUTINE STATEMENT IS +C +C SUBROUTINE INITPT(N,X,NPROB,FACTOR) +C +C WHERE +C +C N IS A POSITIVE INTEGER INPUT VARIABLE. +C +C X IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE STANDARD +C STARTING POINT FOR PROBLEM NPROB MULTIPLIED BY FACTOR. +C +C NPROB IS A POSITIVE INTEGER INPUT VARIABLE WHICH DEFINES THE +C NUMBER OF THE PROBLEM. NPROB MUST NOT EXCEED 18. +C +C FACTOR IS AN INPUT VARIABLE WHICH SPECIFIES THE MULTIPLE OF +C THE STANDARD STARTING POINT. IF FACTOR IS UNITY, NO +C MULTIPLICATION IS PERFORMED. +C +C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. +C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE +C +C ********** + INTEGER IVAR,J + REAL C1,C2,C3,C4,C5,C6,C7,C8,C9,C10,C11,C12,C13,C14,C15,C16,C17, + * FIVE,H,HALF,ONE,SEVEN,TEN,THREE,TWENTY,TWNTF,TWO,ZERO + REAL FLOAT + DATA ZERO,HALF,ONE,TWO,THREE,FIVE,SEVEN,TEN,TWENTY,TWNTF + * /0.0E0,5.0E-1,1.0E0,2.0E0,3.0E0,5.0E0,7.0E0,1.0E1,2.0E1, + * 2.5E1/ + DATA C1,C2,C3,C4,C5,C6,C7,C8,C9,C10,C11,C12,C13,C14,C15,C16,C17 + * /1.2E0,2.5E-1,3.9E-1,4.15E-1,2.0E-2,4.0E3,2.5E2,3.0E-1, + * 4.0E-1,1.5E0,1.0E-2,1.3E0,6.5E-1,7.0E-1,6.0E-1,4.5E0, + * 5.5E0/ + FLOAT(IVAR) = IVAR +C +C SELECTION OF INITIAL POINT. +C + GO TO (10,10,10,30,40,50,60,70,80,90,100,120,130,140,150,170, + * 190,200), NPROB +C +C LINEAR FUNCTION - FULL RANK OR RANK 1. +C + 10 CONTINUE + DO 20 J = 1, N + X(J) = ONE + 20 CONTINUE + GO TO 210 +C +C ROSENBROCK FUNCTION. +C + 30 CONTINUE + X(1) = -C1 + X(2) = ONE + GO TO 210 +C +C HELICAL VALLEY FUNCTION. +C + 40 CONTINUE + X(1) = -ONE + X(2) = ZERO + X(3) = ZERO + GO TO 210 +C +C POWELL SINGULAR FUNCTION. +C + 50 CONTINUE + X(1) = THREE + X(2) = -ONE + X(3) = ZERO + X(4) = ONE + GO TO 210 +C +C FREUDENSTEIN AND ROTH FUNCTION. +C + 60 CONTINUE + X(1) = HALF + X(2) = -TWO + GO TO 210 +C +C BARD FUNCTION. +C + 70 CONTINUE + X(1) = ONE + X(2) = ONE + X(3) = ONE + GO TO 210 +C +C KOWALIK AND OSBORNE FUNCTION. +C + 80 CONTINUE + X(1) = C2 + X(2) = C3 + X(3) = C4 + X(4) = C3 + GO TO 210 +C +C MEYER FUNCTION. +C + 90 CONTINUE + X(1) = C5 + X(2) = C6 + X(3) = C7 + GO TO 210 +C +C WATSON FUNCTION. +C + 100 CONTINUE + DO 110 J = 1, N + X(J) = ZERO + 110 CONTINUE + GO TO 210 +C +C BOX 3-DIMENSIONAL FUNCTION. +C + 120 CONTINUE + X(1) = ZERO + X(2) = TEN + X(3) = TWENTY + GO TO 210 +C +C JENNRICH AND SAMPSON FUNCTION. +C + 130 CONTINUE + X(1) = C8 + X(2) = C9 + GO TO 210 +C +C BROWN AND DENNIS FUNCTION. +C + 140 CONTINUE + X(1) = TWNTF + X(2) = FIVE + X(3) = -FIVE + X(4) = -ONE + GO TO 210 +C +C CHEBYQUAD FUNCTION. +C + 150 CONTINUE + H = ONE/FLOAT(N+1) + DO 160 J = 1, N + X(J) = FLOAT(J)*H + 160 CONTINUE + GO TO 210 +C +C BROWN ALMOST-LINEAR FUNCTION. +C + 170 CONTINUE + DO 180 J = 1, N + X(J) = HALF + 180 CONTINUE + GO TO 210 +C +C OSBORNE 1 FUNCTION. +C + 190 CONTINUE + X(1) = HALF + X(2) = C10 + X(3) = -ONE + X(4) = C11 + X(5) = C5 + GO TO 210 +C +C OSBORNE 2 FUNCTION. +C + 200 CONTINUE + X(1) = C12 + X(2) = C13 + X(3) = C13 + X(4) = C14 + X(5) = C15 + X(6) = THREE + X(7) = FIVE + X(8) = SEVEN + X(9) = TWO + X(10) = C16 + X(11) = C17 + 210 CONTINUE +C +C COMPUTE MULTIPLE OF INITIAL POINT. +C + IF (FACTOR .EQ. ONE) GO TO 260 + IF (NPROB .EQ. 11) GO TO 230 + DO 220 J = 1, N + X(J) = FACTOR*X(J) + 220 CONTINUE + GO TO 250 + 230 CONTINUE + DO 240 J = 1, N + X(J) = FACTOR + 240 CONTINUE + 250 CONTINUE + 260 CONTINUE + RETURN +C +C LAST CARD OF SUBROUTINE INITPT. +C + END + SUBROUTINE SSQFCN(M,N,X,FVEC,NPROB) + INTEGER M,N,NPROB + REAL X(N),FVEC(M) +C ********** +C +C SUBROUTINE SSQFCN +C +C THIS SUBROUTINE DEFINES THE FUNCTIONS OF EIGHTEEN NONLINEAR +C LEAST SQUARES PROBLEMS. THE ALLOWABLE VALUES OF (M,N) FOR +C FUNCTIONS 1,2 AND 3 ARE VARIABLE BUT WITH M .GE. N. +C FOR FUNCTIONS 4,5,6,7,8,9 AND 10 THE VALUES OF (M,N) ARE +C (2,2),(3,3),(4,4),(2,2),(15,3),(11,4) AND (16,3), RESPECTIVELY. +C FUNCTION 11 (WATSON) HAS M = 31 WITH N USUALLY 6 OR 9. +C HOWEVER, ANY N, N = 2,...,31, IS PERMITTED. +C FUNCTIONS 12,13 AND 14 HAVE N = 3,2 AND 4, RESPECTIVELY, BUT +C ALLOW ANY M .GE. N, WITH THE USUAL CHOICES BEING 10,10 AND 20. +C FUNCTION 15 (CHEBYQUAD) ALLOWS M AND N VARIABLE WITH M .GE. N. +C FUNCTION 16 (BROWN) ALLOWS N VARIABLE WITH M = N. +C FOR FUNCTIONS 17 AND 18, THE VALUES OF (M,N) ARE +C (33,5) AND (65,11), RESPECTIVELY. +C +C THE SUBROUTINE STATEMENT IS +C +C SUBROUTINE SSQFCN(M,N,X,FVEC,NPROB) +C +C WHERE +C +C M AND N ARE POSITIVE INTEGER INPUT VARIABLES. N MUST NOT +C EXCEED M. +C +C X IS AN INPUT ARRAY OF LENGTH N. +C +C FVEC IS AN OUTPUT ARRAY OF LENGTH M WHICH CONTAINS THE NPROB +C FUNCTION EVALUATED AT X. +C +C NPROB IS A POSITIVE INTEGER INPUT VARIABLE WHICH DEFINES THE +C NUMBER OF THE PROBLEM. NPROB MUST NOT EXCEED 18. +C +C SUBPROGRAMS CALLED +C +C FORTRAN-SUPPLIED ... ATAN,COS,EXP,SIN,SQRT,SIGN +C +C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. +C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE +C +C ********** + INTEGER I,IEV,IVAR,J,NM1 + REAL C13,C14,C29,C45,DIV,DX,EIGHT,FIVE,ONE,PROD,SUM,S1,S2,TEMP, + * TEN,TI,TMP1,TMP2,TMP3,TMP4,TPI,TWO,ZERO,ZP25,ZP5 + REAL V(11),Y1(15),Y2(11),Y3(16),Y4(33),Y5(65) + REAL FLOAT + DATA ZERO,ZP25,ZP5,ONE,TWO,FIVE,EIGHT,TEN,C13,C14,C29,C45 + * /0.0E0,2.5E-1,5.0E-1,1.0E0,2.0E0,5.0E0,8.0E0,1.0E1,1.3E1, + * 1.4E1,2.9E1,4.5E1/ + DATA V(1),V(2),V(3),V(4),V(5),V(6),V(7),V(8),V(9),V(10),V(11) + * /4.0E0,2.0E0,1.0E0,5.0E-1,2.5E-1,1.67E-1,1.25E-1,1.0E-1, + * 8.33E-2,7.14E-2,6.25E-2/ + DATA Y1(1),Y1(2),Y1(3),Y1(4),Y1(5),Y1(6),Y1(7),Y1(8),Y1(9), + * Y1(10),Y1(11),Y1(12),Y1(13),Y1(14),Y1(15) + * /1.4E-1,1.8E-1,2.2E-1,2.5E-1,2.9E-1,3.2E-1,3.5E-1,3.9E-1, + * 3.7E-1,5.8E-1,7.3E-1,9.6E-1,1.34E0,2.1E0,4.39E0/ + DATA Y2(1),Y2(2),Y2(3),Y2(4),Y2(5),Y2(6),Y2(7),Y2(8),Y2(9), + * Y2(10),Y2(11) + * /1.957E-1,1.947E-1,1.735E-1,1.6E-1,8.44E-2,6.27E-2,4.56E-2, + * 3.42E-2,3.23E-2,2.35E-2,2.46E-2/ + DATA Y3(1),Y3(2),Y3(3),Y3(4),Y3(5),Y3(6),Y3(7),Y3(8),Y3(9), + * Y3(10),Y3(11),Y3(12),Y3(13),Y3(14),Y3(15),Y3(16) + * /3.478E4,2.861E4,2.365E4,1.963E4,1.637E4,1.372E4,1.154E4, + * 9.744E3,8.261E3,7.03E3,6.005E3,5.147E3,4.427E3,3.82E3, + * 3.307E3,2.872E3/ + DATA Y4(1),Y4(2),Y4(3),Y4(4),Y4(5),Y4(6),Y4(7),Y4(8),Y4(9), + * Y4(10),Y4(11),Y4(12),Y4(13),Y4(14),Y4(15),Y4(16),Y4(17), + * Y4(18),Y4(19),Y4(20),Y4(21),Y4(22),Y4(23),Y4(24),Y4(25), + * Y4(26),Y4(27),Y4(28),Y4(29),Y4(30),Y4(31),Y4(32),Y4(33) + * /8.44E-1,9.08E-1,9.32E-1,9.36E-1,9.25E-1,9.08E-1,8.81E-1, + * 8.5E-1,8.18E-1,7.84E-1,7.51E-1,7.18E-1,6.85E-1,6.58E-1, + * 6.28E-1,6.03E-1,5.8E-1,5.58E-1,5.38E-1,5.22E-1,5.06E-1, + * 4.9E-1,4.78E-1,4.67E-1,4.57E-1,4.48E-1,4.38E-1,4.31E-1, + * 4.24E-1,4.2E-1,4.14E-1,4.11E-1,4.06E-1/ + DATA Y5(1),Y5(2),Y5(3),Y5(4),Y5(5),Y5(6),Y5(7),Y5(8),Y5(9), + * Y5(10),Y5(11),Y5(12),Y5(13),Y5(14),Y5(15),Y5(16),Y5(17), + * Y5(18),Y5(19),Y5(20),Y5(21),Y5(22),Y5(23),Y5(24),Y5(25), + * Y5(26),Y5(27),Y5(28),Y5(29),Y5(30),Y5(31),Y5(32),Y5(33), + * Y5(34),Y5(35),Y5(36),Y5(37),Y5(38),Y5(39),Y5(40),Y5(41), + * Y5(42),Y5(43),Y5(44),Y5(45),Y5(46),Y5(47),Y5(48),Y5(49), + * Y5(50),Y5(51),Y5(52),Y5(53),Y5(54),Y5(55),Y5(56),Y5(57), + * Y5(58),Y5(59),Y5(60),Y5(61),Y5(62),Y5(63),Y5(64),Y5(65) + * /1.366E0,1.191E0,1.112E0,1.013E0,9.91E-1,8.85E-1,8.31E-1, + * 8.47E-1,7.86E-1,7.25E-1,7.46E-1,6.79E-1,6.08E-1,6.55E-1, + * 6.16E-1,6.06E-1,6.02E-1,6.26E-1,6.51E-1,7.24E-1,6.49E-1, + * 6.49E-1,6.94E-1,6.44E-1,6.24E-1,6.61E-1,6.12E-1,5.58E-1, + * 5.33E-1,4.95E-1,5.0E-1,4.23E-1,3.95E-1,3.75E-1,3.72E-1, + * 3.91E-1,3.96E-1,4.05E-1,4.28E-1,4.29E-1,5.23E-1,5.62E-1, + * 6.07E-1,6.53E-1,6.72E-1,7.08E-1,6.33E-1,6.68E-1,6.45E-1, + * 6.32E-1,5.91E-1,5.59E-1,5.97E-1,6.25E-1,7.39E-1,7.1E-1, + * 7.29E-1,7.2E-1,6.36E-1,5.81E-1,4.28E-1,2.92E-1,1.62E-1, + * 9.8E-2,5.4E-2/ + FLOAT(IVAR) = IVAR +C +C FUNCTION ROUTINE SELECTOR. +C + GO TO (10,40,70,110,120,130,140,150,170,190,210,250,270,290,310, + * 360,390,410), NPROB +C +C LINEAR FUNCTION - FULL RANK. +C + 10 CONTINUE + SUM = ZERO + DO 20 J = 1, N + SUM = SUM + X(J) + 20 CONTINUE + TEMP = TWO*SUM/FLOAT(M) + ONE + DO 30 I = 1, M + FVEC(I) = -TEMP + IF (I .LE. N) FVEC(I) = FVEC(I) + X(I) + 30 CONTINUE + GO TO 430 +C +C LINEAR FUNCTION - RANK 1. +C + 40 CONTINUE + SUM = ZERO + DO 50 J = 1, N + SUM = SUM + FLOAT(J)*X(J) + 50 CONTINUE + DO 60 I = 1, M + FVEC(I) = FLOAT(I)*SUM - ONE + 60 CONTINUE + GO TO 430 +C +C LINEAR FUNCTION - RANK 1 WITH ZERO COLUMNS AND ROWS. +C + 70 CONTINUE + SUM = ZERO + NM1 = N - 1 + IF (NM1 .LT. 2) GO TO 90 + DO 80 J = 2, NM1 + SUM = SUM + FLOAT(J)*X(J) + 80 CONTINUE + 90 CONTINUE + DO 100 I = 1, M + FVEC(I) = FLOAT(I-1)*SUM - ONE + 100 CONTINUE + FVEC(M) = -ONE + GO TO 430 +C +C ROSENBROCK FUNCTION. +C + 110 CONTINUE + FVEC(1) = TEN*(X(2) - X(1)**2) + FVEC(2) = ONE - X(1) + GO TO 430 +C +C HELICAL VALLEY FUNCTION. +C + 120 CONTINUE + TPI = EIGHT*ATAN(ONE) + TMP1 = SIGN(ZP25,X(2)) + IF (X(1) .GT. ZERO) TMP1 = ATAN(X(2)/X(1))/TPI + IF (X(1) .LT. ZERO) TMP1 = ATAN(X(2)/X(1))/TPI + ZP5 + TMP2 = SQRT(X(1)**2+X(2)**2) + FVEC(1) = TEN*(X(3) - TEN*TMP1) + FVEC(2) = TEN*(TMP2 - ONE) + FVEC(3) = X(3) + GO TO 430 +C +C POWELL SINGULAR FUNCTION. +C + 130 CONTINUE + FVEC(1) = X(1) + TEN*X(2) + FVEC(2) = SQRT(FIVE)*(X(3) - X(4)) + FVEC(3) = (X(2) - TWO*X(3))**2 + FVEC(4) = SQRT(TEN)*(X(1) - X(4))**2 + GO TO 430 +C +C FREUDENSTEIN AND ROTH FUNCTION. +C + 140 CONTINUE + FVEC(1) = -C13 + X(1) + ((FIVE - X(2))*X(2) - TWO)*X(2) + FVEC(2) = -C29 + X(1) + ((ONE + X(2))*X(2) - C14)*X(2) + GO TO 430 +C +C BARD FUNCTION. +C + 150 CONTINUE + DO 160 I = 1, 15 + TMP1 = FLOAT(I) + TMP2 = FLOAT(16-I) + TMP3 = TMP1 + IF (I .GT. 8) TMP3 = TMP2 + FVEC(I) = Y1(I) - (X(1) + TMP1/(X(2)*TMP2 + X(3)*TMP3)) + 160 CONTINUE + GO TO 430 +C +C KOWALIK AND OSBORNE FUNCTION. +C + 170 CONTINUE + DO 180 I = 1, 11 + TMP1 = V(I)*(V(I) + X(2)) + TMP2 = V(I)*(V(I) + X(3)) + X(4) + FVEC(I) = Y2(I) - X(1)*TMP1/TMP2 + 180 CONTINUE + GO TO 430 +C +C MEYER FUNCTION. +C + 190 CONTINUE + DO 200 I = 1, 16 + TEMP = FIVE*FLOAT(I) + C45 + X(3) + TMP1 = X(2)/TEMP + TMP2 = EXP(TMP1) + FVEC(I) = X(1)*TMP2 - Y3(I) + 200 CONTINUE + GO TO 430 +C +C WATSON FUNCTION. +C + 210 CONTINUE + DO 240 I = 1, 29 + DIV = FLOAT(I)/C29 + S1 = ZERO + DX = ONE + DO 220 J = 2, N + S1 = S1 + FLOAT(J-1)*DX*X(J) + DX = DIV*DX + 220 CONTINUE + S2 = ZERO + DX = ONE + DO 230 J = 1, N + S2 = S2 + DX*X(J) + DX = DIV*DX + 230 CONTINUE + FVEC(I) = S1 - S2**2 - ONE + 240 CONTINUE + FVEC(30) = X(1) + FVEC(31) = X(2) - X(1)**2 - ONE + GO TO 430 +C +C BOX 3-DIMENSIONAL FUNCTION. +C + 250 CONTINUE + DO 260 I = 1, M + TEMP = FLOAT(I) + TMP1 = TEMP/TEN + FVEC(I) = EXP(-TMP1*X(1)) - EXP(-TMP1*X(2)) + * + (EXP(-TEMP) - EXP(-TMP1))*X(3) + 260 CONTINUE + GO TO 430 +C +C JENNRICH AND SAMPSON FUNCTION. +C + 270 CONTINUE + DO 280 I = 1, M + TEMP = FLOAT(I) + FVEC(I) = TWO + TWO*TEMP - EXP(TEMP*X(1)) - EXP(TEMP*X(2)) + 280 CONTINUE + GO TO 430 +C +C BROWN AND DENNIS FUNCTION. +C + 290 CONTINUE + DO 300 I = 1, M + TEMP = FLOAT(I)/FIVE + TMP1 = X(1) + TEMP*X(2) - EXP(TEMP) + TMP2 = X(3) + SIN(TEMP)*X(4) - COS(TEMP) + FVEC(I) = TMP1**2 + TMP2**2 + 300 CONTINUE + GO TO 430 +C +C CHEBYQUAD FUNCTION. +C + 310 CONTINUE + DO 320 I = 1, M + FVEC(I) = ZERO + 320 CONTINUE + DO 340 J = 1, N + TMP1 = ONE + TMP2 = TWO*X(J) - ONE + TEMP = TWO*TMP2 + DO 330 I = 1, M + FVEC(I) = FVEC(I) + TMP2 + TI = TEMP*TMP2 - TMP1 + TMP1 = TMP2 + TMP2 = TI + 330 CONTINUE + 340 CONTINUE + DX = ONE/FLOAT(N) + IEV = -1 + DO 350 I = 1, M + FVEC(I) = DX*FVEC(I) + IF (IEV .GT. 0) FVEC(I) = FVEC(I) + ONE/(FLOAT(I)**2 - ONE) + IEV = -IEV + 350 CONTINUE + GO TO 430 +C +C BROWN ALMOST-LINEAR FUNCTION. +C + 360 CONTINUE + SUM = -FLOAT(N+1) + PROD = ONE + DO 370 J = 1, N + SUM = SUM + X(J) + PROD = X(J)*PROD + 370 CONTINUE + DO 380 I = 1, N + FVEC(I) = X(I) + SUM + 380 CONTINUE + FVEC(N) = PROD - ONE + GO TO 430 +C +C OSBORNE 1 FUNCTION. +C + 390 CONTINUE + DO 400 I = 1, 33 + TEMP = TEN*FLOAT(I-1) + TMP1 = EXP(-X(4)*TEMP) + TMP2 = EXP(-X(5)*TEMP) + FVEC(I) = Y4(I) - (X(1) + X(2)*TMP1 + X(3)*TMP2) + 400 CONTINUE + GO TO 430 +C +C OSBORNE 2 FUNCTION. +C + 410 CONTINUE + DO 420 I = 1, 65 + TEMP = FLOAT(I-1)/TEN + TMP1 = EXP(-X(5)*TEMP) + TMP2 = EXP(-X(6)*(TEMP-X(9))**2) + TMP3 = EXP(-X(7)*(TEMP-X(10))**2) + TMP4 = EXP(-X(8)*(TEMP-X(11))**2) + FVEC(I) = Y5(I) + * - (X(1)*TMP1 + X(2)*TMP2 + X(3)*TMP3 + X(4)*TMP4) + 420 CONTINUE + 430 CONTINUE + RETURN +C +C LAST CARD OF SUBROUTINE SSQFCN. +C + END diff --git a/ex/file12 b/ex/file12 new file mode 100644 index 0000000..d051988 --- /dev/null +++ b/ex/file12 @@ -0,0 +1,673 @@ +C ********** +C +C THIS PROGRAM TESTS CODES FOR THE LEAST-SQUARES SOLUTION OF +C M NONLINEAR EQUATIONS IN N VARIABLES. IT CONSISTS OF A DRIVER +C AND AN INTERFACE SUBROUTINE FCN. THE DRIVER READS IN DATA, +C CALLS THE NONLINEAR LEAST-SQUARES SOLVER, AND FINALLY PRINTS +C OUT INFORMATION ON THE PERFORMANCE OF THE SOLVER. THIS IS +C ONLY A SAMPLE DRIVER, MANY OTHER DRIVERS ARE POSSIBLE. THE +C INTERFACE SUBROUTINE FCN IS NECESSARY TO TAKE INTO ACCOUNT THE +C FORMS OF CALLING SEQUENCES USED BY THE FUNCTION AND JACOBIAN +C SUBROUTINES IN THE VARIOUS NONLINEAR LEAST-SQUARES SOLVERS. +C +C SUBPROGRAMS CALLED +C +C USER-SUPPLIED ...... FCN +C +C MINPACK-SUPPLIED ... SPMPAR,ENORM,INITPT,LMDIF1,SSQFCN +C +C FORTRAN-SUPPLIED ... SQRT +C +C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. +C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE +C +C ********** + INTEGER I,IC,INFO,K,LWA,M,N,NFEV,NJEV,NPROB,NREAD,NTRIES,NWRITE + INTEGER IWA(40),MA(60),NA(60),NF(60),NJ(60),NP(60),NX(60) + REAL FACTOR,FNORM1,FNORM2,ONE,TEN,TOL + REAL FNM(60),FVEC(65),WA(2865),X(40) + REAL SPMPAR,ENORM + EXTERNAL FCN + COMMON /REFNUM/ NPROB,NFEV,NJEV +C +C LOGICAL INPUT UNIT IS ASSUMED TO BE NUMBER 5. +C LOGICAL OUTPUT UNIT IS ASSUMED TO BE NUMBER 6. +C + DATA NREAD,NWRITE /5,6/ +C + DATA ONE,TEN /1.0E0,1.0E1/ + TOL = SQRT(SPMPAR(1)) + LWA = 2865 + IC = 0 + 10 CONTINUE + READ (NREAD,50) NPROB,N,M,NTRIES + IF (NPROB .LE. 0) GO TO 30 + FACTOR = ONE + DO 20 K = 1, NTRIES + IC = IC + 1 + CALL INITPT(N,X,NPROB,FACTOR) + CALL SSQFCN(M,N,X,FVEC,NPROB) + FNORM1 = ENORM(M,FVEC) + WRITE (NWRITE,60) NPROB,N,M + NFEV = 0 + NJEV = 0 + CALL LMDIF1(FCN,M,N,X,FVEC,TOL,INFO,IWA,WA,LWA) + CALL SSQFCN(M,N,X,FVEC,NPROB) + FNORM2 = ENORM(M,FVEC) + NP(IC) = NPROB + NA(IC) = N + MA(IC) = M + NF(IC) = NFEV + NJEV = NJEV/N + NJ(IC) = NJEV + NX(IC) = INFO + FNM(IC) = FNORM2 + WRITE (NWRITE,70) + * FNORM1,FNORM2,NFEV,NJEV,INFO,(X(I), I = 1, N) + FACTOR = TEN*FACTOR + 20 CONTINUE + GO TO 10 + 30 CONTINUE + WRITE (NWRITE,80) IC + WRITE (NWRITE,90) + DO 40 I = 1, IC + WRITE (NWRITE,100) NP(I),NA(I),MA(I),NF(I),NJ(I),NX(I),FNM(I) + 40 CONTINUE + STOP + 50 FORMAT (4I5) + 60 FORMAT ( //// 5X, 8H PROBLEM, I5, 5X, 11H DIMENSIONS, 2I5, 5X // + * ) + 70 FORMAT (5X, 33H INITIAL L2 NORM OF THE RESIDUALS, E15.7 // 5X, + * 33H FINAL L2 NORM OF THE RESIDUALS , E15.7 // 5X, + * 33H NUMBER OF FUNCTION EVALUATIONS , I10 // 5X, + * 33H NUMBER OF JACOBIAN EVALUATIONS , I10 // 5X, + * 15H EXIT PARAMETER, 18X, I10 // 5X, + * 27H FINAL APPROXIMATE SOLUTION // (5X, 5E15.7)) + 80 FORMAT (12H1SUMMARY OF , I3, 16H CALLS TO LMDIF1 /) + 90 FORMAT (49H NPROB N M NFEV NJEV INFO FINAL L2 NORM /) + 100 FORMAT (3I5, 3I6, 2X, E15.7) +C +C LAST CARD OF DRIVER. +C + END + SUBROUTINE FCN(M,N,X,FVEC,IFLAG) + INTEGER M,N,IFLAG + REAL X(N),FVEC(M) +C ********** +C +C THE CALLING SEQUENCE OF FCN SHOULD BE IDENTICAL TO THE +C CALLING SEQUENCE OF THE FUNCTION SUBROUTINE IN THE NONLINEAR +C LEAST-SQUARES SOLVER. FCN SHOULD ONLY CALL THE TESTING +C FUNCTION SUBROUTINE SSQFCN WITH THE APPROPRIATE VALUE OF +C PROBLEM NUMBER (NPROB). +C +C SUBPROGRAMS CALLED +C +C MINPACK-SUPPLIED ... SSQFCN +C +C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. +C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE +C +C ********** + INTEGER NPROB,NFEV,NJEV + COMMON /REFNUM/ NPROB,NFEV,NJEV + CALL SSQFCN(M,N,X,FVEC,NPROB) + IF (IFLAG .EQ. 1) NFEV = NFEV + 1 + IF (IFLAG .EQ. 2) NJEV = NJEV + 1 + RETURN +C +C LAST CARD OF INTERFACE SUBROUTINE FCN. +C + END + SUBROUTINE SSQFCN(M,N,X,FVEC,NPROB) + INTEGER M,N,NPROB + REAL X(N),FVEC(M) +C ********** +C +C SUBROUTINE SSQFCN +C +C THIS SUBROUTINE DEFINES THE FUNCTIONS OF EIGHTEEN NONLINEAR +C LEAST SQUARES PROBLEMS. THE ALLOWABLE VALUES OF (M,N) FOR +C FUNCTIONS 1,2 AND 3 ARE VARIABLE BUT WITH M .GE. N. +C FOR FUNCTIONS 4,5,6,7,8,9 AND 10 THE VALUES OF (M,N) ARE +C (2,2),(3,3),(4,4),(2,2),(15,3),(11,4) AND (16,3), RESPECTIVELY. +C FUNCTION 11 (WATSON) HAS M = 31 WITH N USUALLY 6 OR 9. +C HOWEVER, ANY N, N = 2,...,31, IS PERMITTED. +C FUNCTIONS 12,13 AND 14 HAVE N = 3,2 AND 4, RESPECTIVELY, BUT +C ALLOW ANY M .GE. N, WITH THE USUAL CHOICES BEING 10,10 AND 20. +C FUNCTION 15 (CHEBYQUAD) ALLOWS M AND N VARIABLE WITH M .GE. N. +C FUNCTION 16 (BROWN) ALLOWS N VARIABLE WITH M = N. +C FOR FUNCTIONS 17 AND 18, THE VALUES OF (M,N) ARE +C (33,5) AND (65,11), RESPECTIVELY. +C +C THE SUBROUTINE STATEMENT IS +C +C SUBROUTINE SSQFCN(M,N,X,FVEC,NPROB) +C +C WHERE +C +C M AND N ARE POSITIVE INTEGER INPUT VARIABLES. N MUST NOT +C EXCEED M. +C +C X IS AN INPUT ARRAY OF LENGTH N. +C +C FVEC IS AN OUTPUT ARRAY OF LENGTH M WHICH CONTAINS THE NPROB +C FUNCTION EVALUATED AT X. +C +C NPROB IS A POSITIVE INTEGER INPUT VARIABLE WHICH DEFINES THE +C NUMBER OF THE PROBLEM. NPROB MUST NOT EXCEED 18. +C +C SUBPROGRAMS CALLED +C +C FORTRAN-SUPPLIED ... ATAN,COS,EXP,SIN,SQRT,SIGN +C +C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. +C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE +C +C ********** + INTEGER I,IEV,IVAR,J,NM1 + REAL C13,C14,C29,C45,DIV,DX,EIGHT,FIVE,ONE,PROD,SUM,S1,S2,TEMP, + * TEN,TI,TMP1,TMP2,TMP3,TMP4,TPI,TWO,ZERO,ZP25,ZP5 + REAL V(11),Y1(15),Y2(11),Y3(16),Y4(33),Y5(65) + REAL FLOAT + DATA ZERO,ZP25,ZP5,ONE,TWO,FIVE,EIGHT,TEN,C13,C14,C29,C45 + * /0.0E0,2.5E-1,5.0E-1,1.0E0,2.0E0,5.0E0,8.0E0,1.0E1,1.3E1, + * 1.4E1,2.9E1,4.5E1/ + DATA V(1),V(2),V(3),V(4),V(5),V(6),V(7),V(8),V(9),V(10),V(11) + * /4.0E0,2.0E0,1.0E0,5.0E-1,2.5E-1,1.67E-1,1.25E-1,1.0E-1, + * 8.33E-2,7.14E-2,6.25E-2/ + DATA Y1(1),Y1(2),Y1(3),Y1(4),Y1(5),Y1(6),Y1(7),Y1(8),Y1(9), + * Y1(10),Y1(11),Y1(12),Y1(13),Y1(14),Y1(15) + * /1.4E-1,1.8E-1,2.2E-1,2.5E-1,2.9E-1,3.2E-1,3.5E-1,3.9E-1, + * 3.7E-1,5.8E-1,7.3E-1,9.6E-1,1.34E0,2.1E0,4.39E0/ + DATA Y2(1),Y2(2),Y2(3),Y2(4),Y2(5),Y2(6),Y2(7),Y2(8),Y2(9), + * Y2(10),Y2(11) + * /1.957E-1,1.947E-1,1.735E-1,1.6E-1,8.44E-2,6.27E-2,4.56E-2, + * 3.42E-2,3.23E-2,2.35E-2,2.46E-2/ + DATA Y3(1),Y3(2),Y3(3),Y3(4),Y3(5),Y3(6),Y3(7),Y3(8),Y3(9), + * Y3(10),Y3(11),Y3(12),Y3(13),Y3(14),Y3(15),Y3(16) + * /3.478E4,2.861E4,2.365E4,1.963E4,1.637E4,1.372E4,1.154E4, + * 9.744E3,8.261E3,7.03E3,6.005E3,5.147E3,4.427E3,3.82E3, + * 3.307E3,2.872E3/ + DATA Y4(1),Y4(2),Y4(3),Y4(4),Y4(5),Y4(6),Y4(7),Y4(8),Y4(9), + * Y4(10),Y4(11),Y4(12),Y4(13),Y4(14),Y4(15),Y4(16),Y4(17), + * Y4(18),Y4(19),Y4(20),Y4(21),Y4(22),Y4(23),Y4(24),Y4(25), + * Y4(26),Y4(27),Y4(28),Y4(29),Y4(30),Y4(31),Y4(32),Y4(33) + * /8.44E-1,9.08E-1,9.32E-1,9.36E-1,9.25E-1,9.08E-1,8.81E-1, + * 8.5E-1,8.18E-1,7.84E-1,7.51E-1,7.18E-1,6.85E-1,6.58E-1, + * 6.28E-1,6.03E-1,5.8E-1,5.58E-1,5.38E-1,5.22E-1,5.06E-1, + * 4.9E-1,4.78E-1,4.67E-1,4.57E-1,4.48E-1,4.38E-1,4.31E-1, + * 4.24E-1,4.2E-1,4.14E-1,4.11E-1,4.06E-1/ + DATA Y5(1),Y5(2),Y5(3),Y5(4),Y5(5),Y5(6),Y5(7),Y5(8),Y5(9), + * Y5(10),Y5(11),Y5(12),Y5(13),Y5(14),Y5(15),Y5(16),Y5(17), + * Y5(18),Y5(19),Y5(20),Y5(21),Y5(22),Y5(23),Y5(24),Y5(25), + * Y5(26),Y5(27),Y5(28),Y5(29),Y5(30),Y5(31),Y5(32),Y5(33), + * Y5(34),Y5(35),Y5(36),Y5(37),Y5(38),Y5(39),Y5(40),Y5(41), + * Y5(42),Y5(43),Y5(44),Y5(45),Y5(46),Y5(47),Y5(48),Y5(49), + * Y5(50),Y5(51),Y5(52),Y5(53),Y5(54),Y5(55),Y5(56),Y5(57), + * Y5(58),Y5(59),Y5(60),Y5(61),Y5(62),Y5(63),Y5(64),Y5(65) + * /1.366E0,1.191E0,1.112E0,1.013E0,9.91E-1,8.85E-1,8.31E-1, + * 8.47E-1,7.86E-1,7.25E-1,7.46E-1,6.79E-1,6.08E-1,6.55E-1, + * 6.16E-1,6.06E-1,6.02E-1,6.26E-1,6.51E-1,7.24E-1,6.49E-1, + * 6.49E-1,6.94E-1,6.44E-1,6.24E-1,6.61E-1,6.12E-1,5.58E-1, + * 5.33E-1,4.95E-1,5.0E-1,4.23E-1,3.95E-1,3.75E-1,3.72E-1, + * 3.91E-1,3.96E-1,4.05E-1,4.28E-1,4.29E-1,5.23E-1,5.62E-1, + * 6.07E-1,6.53E-1,6.72E-1,7.08E-1,6.33E-1,6.68E-1,6.45E-1, + * 6.32E-1,5.91E-1,5.59E-1,5.97E-1,6.25E-1,7.39E-1,7.1E-1, + * 7.29E-1,7.2E-1,6.36E-1,5.81E-1,4.28E-1,2.92E-1,1.62E-1, + * 9.8E-2,5.4E-2/ + FLOAT(IVAR) = IVAR +C +C FUNCTION ROUTINE SELECTOR. +C + GO TO (10,40,70,110,120,130,140,150,170,190,210,250,270,290,310, + * 360,390,410), NPROB +C +C LINEAR FUNCTION - FULL RANK. +C + 10 CONTINUE + SUM = ZERO + DO 20 J = 1, N + SUM = SUM + X(J) + 20 CONTINUE + TEMP = TWO*SUM/FLOAT(M) + ONE + DO 30 I = 1, M + FVEC(I) = -TEMP + IF (I .LE. N) FVEC(I) = FVEC(I) + X(I) + 30 CONTINUE + GO TO 430 +C +C LINEAR FUNCTION - RANK 1. +C + 40 CONTINUE + SUM = ZERO + DO 50 J = 1, N + SUM = SUM + FLOAT(J)*X(J) + 50 CONTINUE + DO 60 I = 1, M + FVEC(I) = FLOAT(I)*SUM - ONE + 60 CONTINUE + GO TO 430 +C +C LINEAR FUNCTION - RANK 1 WITH ZERO COLUMNS AND ROWS. +C + 70 CONTINUE + SUM = ZERO + NM1 = N - 1 + IF (NM1 .LT. 2) GO TO 90 + DO 80 J = 2, NM1 + SUM = SUM + FLOAT(J)*X(J) + 80 CONTINUE + 90 CONTINUE + DO 100 I = 1, M + FVEC(I) = FLOAT(I-1)*SUM - ONE + 100 CONTINUE + FVEC(M) = -ONE + GO TO 430 +C +C ROSENBROCK FUNCTION. +C + 110 CONTINUE + FVEC(1) = TEN*(X(2) - X(1)**2) + FVEC(2) = ONE - X(1) + GO TO 430 +C +C HELICAL VALLEY FUNCTION. +C + 120 CONTINUE + TPI = EIGHT*ATAN(ONE) + TMP1 = SIGN(ZP25,X(2)) + IF (X(1) .GT. ZERO) TMP1 = ATAN(X(2)/X(1))/TPI + IF (X(1) .LT. ZERO) TMP1 = ATAN(X(2)/X(1))/TPI + ZP5 + TMP2 = SQRT(X(1)**2+X(2)**2) + FVEC(1) = TEN*(X(3) - TEN*TMP1) + FVEC(2) = TEN*(TMP2 - ONE) + FVEC(3) = X(3) + GO TO 430 +C +C POWELL SINGULAR FUNCTION. +C + 130 CONTINUE + FVEC(1) = X(1) + TEN*X(2) + FVEC(2) = SQRT(FIVE)*(X(3) - X(4)) + FVEC(3) = (X(2) - TWO*X(3))**2 + FVEC(4) = SQRT(TEN)*(X(1) - X(4))**2 + GO TO 430 +C +C FREUDENSTEIN AND ROTH FUNCTION. +C + 140 CONTINUE + FVEC(1) = -C13 + X(1) + ((FIVE - X(2))*X(2) - TWO)*X(2) + FVEC(2) = -C29 + X(1) + ((ONE + X(2))*X(2) - C14)*X(2) + GO TO 430 +C +C BARD FUNCTION. +C + 150 CONTINUE + DO 160 I = 1, 15 + TMP1 = FLOAT(I) + TMP2 = FLOAT(16-I) + TMP3 = TMP1 + IF (I .GT. 8) TMP3 = TMP2 + FVEC(I) = Y1(I) - (X(1) + TMP1/(X(2)*TMP2 + X(3)*TMP3)) + 160 CONTINUE + GO TO 430 +C +C KOWALIK AND OSBORNE FUNCTION. +C + 170 CONTINUE + DO 180 I = 1, 11 + TMP1 = V(I)*(V(I) + X(2)) + TMP2 = V(I)*(V(I) + X(3)) + X(4) + FVEC(I) = Y2(I) - X(1)*TMP1/TMP2 + 180 CONTINUE + GO TO 430 +C +C MEYER FUNCTION. +C + 190 CONTINUE + DO 200 I = 1, 16 + TEMP = FIVE*FLOAT(I) + C45 + X(3) + TMP1 = X(2)/TEMP + TMP2 = EXP(TMP1) + FVEC(I) = X(1)*TMP2 - Y3(I) + 200 CONTINUE + GO TO 430 +C +C WATSON FUNCTION. +C + 210 CONTINUE + DO 240 I = 1, 29 + DIV = FLOAT(I)/C29 + S1 = ZERO + DX = ONE + DO 220 J = 2, N + S1 = S1 + FLOAT(J-1)*DX*X(J) + DX = DIV*DX + 220 CONTINUE + S2 = ZERO + DX = ONE + DO 230 J = 1, N + S2 = S2 + DX*X(J) + DX = DIV*DX + 230 CONTINUE + FVEC(I) = S1 - S2**2 - ONE + 240 CONTINUE + FVEC(30) = X(1) + FVEC(31) = X(2) - X(1)**2 - ONE + GO TO 430 +C +C BOX 3-DIMENSIONAL FUNCTION. +C + 250 CONTINUE + DO 260 I = 1, M + TEMP = FLOAT(I) + TMP1 = TEMP/TEN + FVEC(I) = EXP(-TMP1*X(1)) - EXP(-TMP1*X(2)) + * + (EXP(-TEMP) - EXP(-TMP1))*X(3) + 260 CONTINUE + GO TO 430 +C +C JENNRICH AND SAMPSON FUNCTION. +C + 270 CONTINUE + DO 280 I = 1, M + TEMP = FLOAT(I) + FVEC(I) = TWO + TWO*TEMP - EXP(TEMP*X(1)) - EXP(TEMP*X(2)) + 280 CONTINUE + GO TO 430 +C +C BROWN AND DENNIS FUNCTION. +C + 290 CONTINUE + DO 300 I = 1, M + TEMP = FLOAT(I)/FIVE + TMP1 = X(1) + TEMP*X(2) - EXP(TEMP) + TMP2 = X(3) + SIN(TEMP)*X(4) - COS(TEMP) + FVEC(I) = TMP1**2 + TMP2**2 + 300 CONTINUE + GO TO 430 +C +C CHEBYQUAD FUNCTION. +C + 310 CONTINUE + DO 320 I = 1, M + FVEC(I) = ZERO + 320 CONTINUE + DO 340 J = 1, N + TMP1 = ONE + TMP2 = TWO*X(J) - ONE + TEMP = TWO*TMP2 + DO 330 I = 1, M + FVEC(I) = FVEC(I) + TMP2 + TI = TEMP*TMP2 - TMP1 + TMP1 = TMP2 + TMP2 = TI + 330 CONTINUE + 340 CONTINUE + DX = ONE/FLOAT(N) + IEV = -1 + DO 350 I = 1, M + FVEC(I) = DX*FVEC(I) + IF (IEV .GT. 0) FVEC(I) = FVEC(I) + ONE/(FLOAT(I)**2 - ONE) + IEV = -IEV + 350 CONTINUE + GO TO 430 +C +C BROWN ALMOST-LINEAR FUNCTION. +C + 360 CONTINUE + SUM = -FLOAT(N+1) + PROD = ONE + DO 370 J = 1, N + SUM = SUM + X(J) + PROD = X(J)*PROD + 370 CONTINUE + DO 380 I = 1, N + FVEC(I) = X(I) + SUM + 380 CONTINUE + FVEC(N) = PROD - ONE + GO TO 430 +C +C OSBORNE 1 FUNCTION. +C + 390 CONTINUE + DO 400 I = 1, 33 + TEMP = TEN*FLOAT(I-1) + TMP1 = EXP(-X(4)*TEMP) + TMP2 = EXP(-X(5)*TEMP) + FVEC(I) = Y4(I) - (X(1) + X(2)*TMP1 + X(3)*TMP2) + 400 CONTINUE + GO TO 430 +C +C OSBORNE 2 FUNCTION. +C + 410 CONTINUE + DO 420 I = 1, 65 + TEMP = FLOAT(I-1)/TEN + TMP1 = EXP(-X(5)*TEMP) + TMP2 = EXP(-X(6)*(TEMP-X(9))**2) + TMP3 = EXP(-X(7)*(TEMP-X(10))**2) + TMP4 = EXP(-X(8)*(TEMP-X(11))**2) + FVEC(I) = Y5(I) + * - (X(1)*TMP1 + X(2)*TMP2 + X(3)*TMP3 + X(4)*TMP4) + 420 CONTINUE + 430 CONTINUE + RETURN +C +C LAST CARD OF SUBROUTINE SSQFCN. +C + END + SUBROUTINE INITPT(N,X,NPROB,FACTOR) + INTEGER N,NPROB + REAL FACTOR + REAL X(N) +C ********** +C +C SUBROUTINE INITPT +C +C THIS SUBROUTINE SPECIFIES THE STANDARD STARTING POINTS FOR THE +C FUNCTIONS DEFINED BY SUBROUTINE SSQFCN. THE SUBROUTINE RETURNS +C IN X A MULTIPLE (FACTOR) OF THE STANDARD STARTING POINT. FOR +C THE 11TH FUNCTION THE STANDARD STARTING POINT IS ZERO, SO IN +C THIS CASE, IF FACTOR IS NOT UNITY, THEN THE SUBROUTINE RETURNS +C THE VECTOR X(J) = FACTOR, J=1,...,N. +C +C THE SUBROUTINE STATEMENT IS +C +C SUBROUTINE INITPT(N,X,NPROB,FACTOR) +C +C WHERE +C +C N IS A POSITIVE INTEGER INPUT VARIABLE. +C +C X IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE STANDARD +C STARTING POINT FOR PROBLEM NPROB MULTIPLIED BY FACTOR. +C +C NPROB IS A POSITIVE INTEGER INPUT VARIABLE WHICH DEFINES THE +C NUMBER OF THE PROBLEM. NPROB MUST NOT EXCEED 18. +C +C FACTOR IS AN INPUT VARIABLE WHICH SPECIFIES THE MULTIPLE OF +C THE STANDARD STARTING POINT. IF FACTOR IS UNITY, NO +C MULTIPLICATION IS PERFORMED. +C +C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. +C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE +C +C ********** + INTEGER IVAR,J + REAL C1,C2,C3,C4,C5,C6,C7,C8,C9,C10,C11,C12,C13,C14,C15,C16,C17, + * FIVE,H,HALF,ONE,SEVEN,TEN,THREE,TWENTY,TWNTF,TWO,ZERO + REAL FLOAT + DATA ZERO,HALF,ONE,TWO,THREE,FIVE,SEVEN,TEN,TWENTY,TWNTF + * /0.0E0,5.0E-1,1.0E0,2.0E0,3.0E0,5.0E0,7.0E0,1.0E1,2.0E1, + * 2.5E1/ + DATA C1,C2,C3,C4,C5,C6,C7,C8,C9,C10,C11,C12,C13,C14,C15,C16,C17 + * /1.2E0,2.5E-1,3.9E-1,4.15E-1,2.0E-2,4.0E3,2.5E2,3.0E-1, + * 4.0E-1,1.5E0,1.0E-2,1.3E0,6.5E-1,7.0E-1,6.0E-1,4.5E0, + * 5.5E0/ + FLOAT(IVAR) = IVAR +C +C SELECTION OF INITIAL POINT. +C + GO TO (10,10,10,30,40,50,60,70,80,90,100,120,130,140,150,170, + * 190,200), NPROB +C +C LINEAR FUNCTION - FULL RANK OR RANK 1. +C + 10 CONTINUE + DO 20 J = 1, N + X(J) = ONE + 20 CONTINUE + GO TO 210 +C +C ROSENBROCK FUNCTION. +C + 30 CONTINUE + X(1) = -C1 + X(2) = ONE + GO TO 210 +C +C HELICAL VALLEY FUNCTION. +C + 40 CONTINUE + X(1) = -ONE + X(2) = ZERO + X(3) = ZERO + GO TO 210 +C +C POWELL SINGULAR FUNCTION. +C + 50 CONTINUE + X(1) = THREE + X(2) = -ONE + X(3) = ZERO + X(4) = ONE + GO TO 210 +C +C FREUDENSTEIN AND ROTH FUNCTION. +C + 60 CONTINUE + X(1) = HALF + X(2) = -TWO + GO TO 210 +C +C BARD FUNCTION. +C + 70 CONTINUE + X(1) = ONE + X(2) = ONE + X(3) = ONE + GO TO 210 +C +C KOWALIK AND OSBORNE FUNCTION. +C + 80 CONTINUE + X(1) = C2 + X(2) = C3 + X(3) = C4 + X(4) = C3 + GO TO 210 +C +C MEYER FUNCTION. +C + 90 CONTINUE + X(1) = C5 + X(2) = C6 + X(3) = C7 + GO TO 210 +C +C WATSON FUNCTION. +C + 100 CONTINUE + DO 110 J = 1, N + X(J) = ZERO + 110 CONTINUE + GO TO 210 +C +C BOX 3-DIMENSIONAL FUNCTION. +C + 120 CONTINUE + X(1) = ZERO + X(2) = TEN + X(3) = TWENTY + GO TO 210 +C +C JENNRICH AND SAMPSON FUNCTION. +C + 130 CONTINUE + X(1) = C8 + X(2) = C9 + GO TO 210 +C +C BROWN AND DENNIS FUNCTION. +C + 140 CONTINUE + X(1) = TWNTF + X(2) = FIVE + X(3) = -FIVE + X(4) = -ONE + GO TO 210 +C +C CHEBYQUAD FUNCTION. +C + 150 CONTINUE + H = ONE/FLOAT(N+1) + DO 160 J = 1, N + X(J) = FLOAT(J)*H + 160 CONTINUE + GO TO 210 +C +C BROWN ALMOST-LINEAR FUNCTION. +C + 170 CONTINUE + DO 180 J = 1, N + X(J) = HALF + 180 CONTINUE + GO TO 210 +C +C OSBORNE 1 FUNCTION. +C + 190 CONTINUE + X(1) = HALF + X(2) = C10 + X(3) = -ONE + X(4) = C11 + X(5) = C5 + GO TO 210 +C +C OSBORNE 2 FUNCTION. +C + 200 CONTINUE + X(1) = C12 + X(2) = C13 + X(3) = C13 + X(4) = C14 + X(5) = C15 + X(6) = THREE + X(7) = FIVE + X(8) = SEVEN + X(9) = TWO + X(10) = C16 + X(11) = C17 + 210 CONTINUE +C +C COMPUTE MULTIPLE OF INITIAL POINT. +C + IF (FACTOR .EQ. ONE) GO TO 260 + IF (NPROB .EQ. 11) GO TO 230 + DO 220 J = 1, N + X(J) = FACTOR*X(J) + 220 CONTINUE + GO TO 250 + 230 CONTINUE + DO 240 J = 1, N + X(J) = FACTOR + 240 CONTINUE + 250 CONTINUE + 260 CONTINUE + RETURN +C +C LAST CARD OF SUBROUTINE INITPT. +C + END diff --git a/ex/file13 b/ex/file13 new file mode 100644 index 0000000..d299bb3 --- /dev/null +++ b/ex/file13 @@ -0,0 +1,858 @@ +C ********** +C +C THIS PROGRAM TESTS THE ABILITY OF CHKDER TO DETECT +C INCONSISTENCIES BETWEEN FUNCTIONS AND THEIR FIRST DERIVATIVES. +C FOURTEEN TEST FUNCTION VECTORS AND JACOBIANS ARE USED. ELEVEN OF +C THE TESTS ARE FALSE(F), I.E. THERE ARE INCONSISTENCIES BETWEEN +C THE FUNCTION VECTORS AND THE CORRESPONDING JACOBIANS. THREE OF +C THE TESTS ARE TRUE(T), I.E. THERE ARE NO INCONSISTENCIES. THE +C DRIVER READS IN DATA, CALLS CHKDER AND PRINTS OUT INFORMATION +C REQUIRED BY AND RECEIVED FROM CHKDER. +C +C SUBPROGRAMS CALLED +C +C MINPACK SUPPLIED ... CHKDER,ERRJAC,INITPT,VECFCN +C +C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. +C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE +C +C ********** + INTEGER I,LDFJAC,LNP,MODE,N,NPROB,NREAD,NWRITE + INTEGER NA(14),NP(14) + LOGICAL A(14) + REAL CP,ONE + REAL DIFF(10),ERR(10),ERRMAX(14),ERRMIN(14),FJAC(10,10), + * FVEC1(10),FVEC2(10),X1(10),X2(10) +C +C LOGICAL INPUT UNIT IS ASSUMED TO BE NUMBER 5. +C LOGICAL OUTPUT UNIT IS ASSUMED TO BE NUMBER 6. +C + DATA NREAD,NWRITE /5,6/ +C + DATA A(1),A(2),A(3),A(4),A(5),A(6),A(7),A(8),A(9),A(10),A(11), + * A(12),A(13),A(14) + * /.FALSE.,.FALSE.,.FALSE.,.TRUE.,.FALSE.,.FALSE.,.FALSE., + * .TRUE.,.FALSE.,.FALSE.,.FALSE.,.FALSE.,.TRUE.,.FALSE./ + DATA CP,ONE /1.23E-1,1.0E0/ + LDFJAC = 10 + 10 CONTINUE + READ (NREAD,60) NPROB,N + IF (NPROB .LE. 0) GO TO 40 + CALL INITPT(N,X1,NPROB,ONE) + DO 20 I = 1, N + X1(I) = X1(I) + CP + CP = -CP + 20 CONTINUE + WRITE (NWRITE,70) NPROB,N,A(NPROB) + MODE = 1 + CALL CHKDER(N,N,X1,FVEC1,FJAC,LDFJAC,X2,FVEC2,MODE,ERR) + MODE = 2 + CALL VECFCN(N,X1,FVEC1,NPROB) + CALL ERRJAC(N,X1,FJAC,LDFJAC,NPROB) + CALL VECFCN(N,X2,FVEC2,NPROB) + CALL CHKDER(N,N,X1,FVEC1,FJAC,LDFJAC,X2,FVEC2,MODE,ERR) + ERRMIN(NPROB) = ERR(1) + ERRMAX(NPROB) = ERR(1) + DO 30 I = 1, N + DIFF(I) = FVEC2(I) - FVEC1(I) + IF (ERRMIN(NPROB) .GT. ERR(I)) ERRMIN(NPROB) = ERR(I) + IF (ERRMAX(NPROB) .LT. ERR(I)) ERRMAX(NPROB) = ERR(I) + 30 CONTINUE + NP(NPROB) = NPROB + LNP = NPROB + NA(NPROB) = N + WRITE (NWRITE,80) (FVEC1(I), I = 1, N) + WRITE (NWRITE,90) (DIFF(I), I = 1, N) + WRITE (NWRITE,100) (ERR(I), I = 1, N) + GO TO 10 + 40 CONTINUE + WRITE (NWRITE,110) LNP + WRITE (NWRITE,120) + DO 50 I = 1, LNP + WRITE (NWRITE,130) NP(I),NA(I),A(I),ERRMIN(I),ERRMAX(I) + 50 CONTINUE + STOP + 60 FORMAT (2I5) + 70 FORMAT ( /// 5X, 8H PROBLEM, I5, 5X, 15H WITH DIMENSION, I5, 2X, + * 5H IS , L1) + 80 FORMAT ( // 5X, 25H FIRST FUNCTION VECTOR // (5X, 5E15.7)) + 90 FORMAT ( // 5X, 27H FUNCTION DIFFERENCE VECTOR // (5X, 5E15.7)) + 100 FORMAT ( // 5X, 13H ERROR VECTOR // (5X, 5E15.7)) + 110 FORMAT (12H1SUMMARY OF , I3, 16H TESTS OF CHKDER /) + 120 FORMAT (46H NPROB N STATUS ERRMIN ERRMAX /) + 130 FORMAT (I4, I6, 6X, L1, 3X, 2E15.7) +C +C LAST CARD OF DERIVATIVE CHECK TEST DRIVER. +C + END + SUBROUTINE ERRJAC(N,X,FJAC,LDFJAC,NPROB) + INTEGER N,LDFJAC,NPROB + REAL X(N),FJAC(LDFJAC,N) +C ********** +C +C SUBROUTINE ERRJAC +C +C THIS SUBROUTINE IS DERIVED FROM VECJAC WHICH DEFINES THE +C JACOBIAN MATRICES OF FOURTEEN TEST FUNCTIONS. THE PROBLEM +C DIMENSIONS ARE AS DESCRIBED IN THE PROLOGUE COMMENTS OF VECFCN. +C VARIOUS ERRORS ARE DELIBERATELY INTRODUCED TO PROVIDE A TEST +C FOR CHKDER. +C +C THE SUBROUTINE STATEMENT IS +C +C SUBROUTINE ERRJAC(N,X,FJAC,LDFJAC,NPROB) +C +C WHERE +C +C N IS A POSITIVE INTEGER VARIABLE. +C +C X IS AN ARRAY OF LENGTH N. +C +C FJAC IS AN N BY N ARRAY. ON OUTPUT FJAC CONTAINS THE +C JACOBIAN MATRIX, WITH VARIOUS ERRORS DELIBERATELY +C INTRODUCED, OF THE NPROB FUNCTION EVALUATED AT X. +C +C LDFJAC IS A POSITIVE INTEGER VARIABLE NOT LESS THAN N +C WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY FJAC. +C +C NPROB IS A POSITIVE INTEGER VARIABLE WHICH DEFINES THE +C NUMBER OF THE PROBLEM. NPROB MUST NOT EXCEED 14. +C +C SUBPROGRAMS CALLED +C +C FORTRAN-SUPPLIED ... ATAN,COS,EXP,AMIN1,SIN,SQRT, +C MAX0,MIN0 +C +C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. +C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE +C +C ********** + INTEGER I,IVAR,J,K,K1,K2,ML,MU + REAL C1,C3,C4,C5,C6,C9,EIGHT,FIFTN,FIVE,FOUR,H,HUNDRD,ONE,PROD, + * SIX,SUM,SUM1,SUM2,TEMP,TEMP1,TEMP2,TEMP3,TEMP4,TEN,THREE, + * TI,TJ,TK,TPI,TWENTY,TWO,ZERO + REAL FLOAT + DATA ZERO,ONE,TWO,THREE,FOUR,FIVE,SIX,EIGHT,TEN,FIFTN,TWENTY, + * HUNDRD + * /0.0E0,1.0E0,2.0E0,3.0E0,4.0E0,5.0E0,6.0E0,8.0E0,1.0E1, + * 1.5E1,2.0E1,1.0E2/ + DATA C1,C3,C4,C5,C6,C9 /1.0E4,2.0E2,2.02E1,1.98E1,1.8E2,2.9E1/ + FLOAT(IVAR) = IVAR +C +C JACOBIAN ROUTINE SELECTOR. +C + GO TO (10,20,50,60,90,100,200,230,290,320,350,380,420,450), + * NPROB +C +C ROSENBROCK FUNCTION WITH SIGN REVERSAL AFFECTING ELEMENT (1,1). +C + 10 CONTINUE + FJAC(1,1) = ONE + FJAC(1,2) = ZERO + FJAC(2,1) = -TWENTY*X(1) + FJAC(2,2) = TEN + GO TO 490 +C +C POWELL SINGULAR FUNCTION WITH SIGN REVERSAL AFFECTING ELEMENT +C (3,3). +C + 20 CONTINUE + DO 40 K = 1, 4 + DO 30 J = 1, 4 + FJAC(K,J) = ZERO + 30 CONTINUE + 40 CONTINUE + FJAC(1,1) = ONE + FJAC(1,2) = TEN + FJAC(2,3) = SQRT(FIVE) + FJAC(2,4) = -FJAC(2,3) + FJAC(3,2) = TWO*(X(2) - TWO*X(3)) + FJAC(3,3) = TWO*FJAC(3,2) + FJAC(4,1) = TWO*SQRT(TEN)*(X(1) - X(4)) + FJAC(4,4) = -FJAC(4,1) + GO TO 490 +C +C POWELL BADLY SCALED FUNCTION WITH THE SIGN OF THE JACOBIAN +C REVERSED. +C + 50 CONTINUE + FJAC(1,1) = -C1*X(2) + FJAC(1,2) = -C1*X(1) + FJAC(2,1) = EXP(-X(1)) + FJAC(2,2) = EXP(-X(2)) + GO TO 490 +C +C WOOD FUNCTION WITHOUT ERROR. +C + 60 CONTINUE + DO 80 K = 1, 4 + DO 70 J = 1, 4 + FJAC(K,J) = ZERO + 70 CONTINUE + 80 CONTINUE + TEMP1 = X(2) - THREE*X(1)**2 + TEMP2 = X(4) - THREE*X(3)**2 + FJAC(1,1) = -C3*TEMP1 + ONE + FJAC(1,2) = -C3*X(1) + FJAC(2,1) = -TWO*C3*X(1) + FJAC(2,2) = C3 + C4 + FJAC(2,4) = C5 + FJAC(3,3) = -C6*TEMP2 + ONE + FJAC(3,4) = -C6*X(3) + FJAC(4,2) = C5 + FJAC(4,3) = -TWO*C6*X(3) + FJAC(4,4) = C6 + C4 + GO TO 490 +C +C HELICAL VALLEY FUNCTION WITH MULTIPLICATIVE ERROR AFFECTING +C ELEMENTS (2,1) AND (2,2). +C + 90 CONTINUE + TPI = EIGHT*ATAN(ONE) + TEMP = X(1)**2 + X(2)**2 + TEMP1 = TPI*TEMP + TEMP2 = SQRT(TEMP) + FJAC(1,1) = HUNDRD*X(2)/TEMP1 + FJAC(1,2) = -HUNDRD*X(1)/TEMP1 + FJAC(1,3) = TEN + FJAC(2,1) = FIVE*X(1)/TEMP2 + FJAC(2,2) = FIVE*X(2)/TEMP2 + FJAC(2,3) = ZERO + FJAC(3,1) = ZERO + FJAC(3,2) = ZERO + FJAC(3,3) = ONE + GO TO 490 +C +C WATSON FUNCTION WITH SIGN REVERSALS AFFECTING THE COMPUTATION OF +C TEMP1. +C + 100 CONTINUE + DO 120 K = 1, N + DO 110 J = K, N + FJAC(K,J) = ZERO + 110 CONTINUE + 120 CONTINUE + DO 170 I = 1, 29 + TI = FLOAT(I)/C9 + SUM1 = ZERO + TEMP = ONE + DO 130 J = 2, N + SUM1 = SUM1 + FLOAT(J-1)*TEMP*X(J) + TEMP = TI*TEMP + 130 CONTINUE + SUM2 = ZERO + TEMP = ONE + DO 140 J = 1, N + SUM2 = SUM2 + TEMP*X(J) + TEMP = TI*TEMP + 140 CONTINUE + TEMP1 = TWO*(SUM1 + SUM2**2 + ONE) + TEMP2 = TWO*SUM2 + TEMP = TI**2 + TK = ONE + DO 160 K = 1, N + TJ = TK + DO 150 J = K, N + FJAC(K,J) = FJAC(K,J) + * + TJ + * *((FLOAT(K-1)/TI - TEMP2) + * *(FLOAT(J-1)/TI - TEMP2) - TEMP1) + TJ = TI*TJ + 150 CONTINUE + TK = TEMP*TK + 160 CONTINUE + 170 CONTINUE + FJAC(1,1) = FJAC(1,1) + SIX*X(1)**2 - TWO*X(2) + THREE + FJAC(1,2) = FJAC(1,2) - TWO*X(1) + FJAC(2,2) = FJAC(2,2) + ONE + DO 190 K = 1, N + DO 180 J = K, N + FJAC(J,K) = FJAC(K,J) + 180 CONTINUE + 190 CONTINUE + GO TO 490 +C +C CHEBYQUAD FUNCTION WITH JACOBIAN TWICE CORRECT SIZE. +C + 200 CONTINUE + TK = ONE/FLOAT(N) + DO 220 J = 1, N + TEMP1 = ONE + TEMP2 = TWO*X(J) - ONE + TEMP = TWO*TEMP2 + TEMP3 = ZERO + TEMP4 = TWO + DO 210 K = 1, N + FJAC(K,J) = TWO*TK*TEMP4 + TI = FOUR*TEMP2 + TEMP*TEMP4 - TEMP3 + TEMP3 = TEMP4 + TEMP4 = TI + TI = TEMP*TEMP2 - TEMP1 + TEMP1 = TEMP2 + TEMP2 = TI + 210 CONTINUE + 220 CONTINUE + GO TO 490 +C +C BROWN ALMOST-LINEAR FUNCTION WITHOUT ERROR. +C + 230 CONTINUE + PROD = ONE + DO 250 J = 1, N + PROD = X(J)*PROD + DO 240 K = 1, N + FJAC(K,J) = ONE + 240 CONTINUE + FJAC(J,J) = TWO + 250 CONTINUE + DO 280 J = 1, N + TEMP = X(J) + IF (TEMP .NE. ZERO) GO TO 270 + TEMP = ONE + PROD = ONE + DO 260 K = 1, N + IF (K .NE. J) PROD = X(K)*PROD + 260 CONTINUE + 270 CONTINUE + FJAC(N,J) = PROD/TEMP + 280 CONTINUE + GO TO 490 +C +C DISCRETE BOUNDARY VALUE FUNCTION WITH MULTIPLICATIVE ERROR +C AFFECTING THE JACOBIAN DIAGONAL. +C + 290 CONTINUE + H = ONE/FLOAT(N+1) + DO 310 K = 1, N + TEMP = THREE*(X(K) + FLOAT(K)*H + ONE)**2 + DO 300 J = 1, N + FJAC(K,J) = ZERO + 300 CONTINUE + FJAC(K,K) = FOUR + TEMP*H**2 + IF (K .NE. 1) FJAC(K,K-1) = -ONE + IF (K .NE. N) FJAC(K,K+1) = -ONE + 310 CONTINUE + GO TO 490 +C +C DISCRETE INTEGRAL EQUATION FUNCTION WITH SIGN ERROR AFFECTING +C THE JACOBIAN DIAGONAL. +C + 320 CONTINUE + H = ONE/FLOAT(N+1) + DO 340 K = 1, N + TK = FLOAT(K)*H + DO 330 J = 1, N + TJ = FLOAT(J)*H + TEMP = THREE*(X(J) + TJ + ONE)**2 + FJAC(K,J) = H*AMIN1(TJ*(ONE-TK),TK*(ONE-TJ))*TEMP/TWO + 330 CONTINUE + FJAC(K,K) = FJAC(K,K) - ONE + 340 CONTINUE + GO TO 490 +C +C TRIGONOMETRIC FUNCTION WITH SIGN ERRORS AFFECTING THE +C OFFDIAGONAL ELEMENTS OF THE JACOBIAN. +C + 350 CONTINUE + DO 370 J = 1, N + TEMP = SIN(X(J)) + DO 360 K = 1, N + FJAC(K,J) = -TEMP + 360 CONTINUE + FJAC(J,J) = FLOAT(J+1)*TEMP - COS(X(J)) + 370 CONTINUE + GO TO 490 +C +C VARIABLY DIMENSIONED FUNCTION WITH OPERATION ERROR AFFECTING +C THE UPPER TRIANGULAR ELEMENTS OF THE JACOBIAN. +C + 380 CONTINUE + SUM = ZERO + DO 390 J = 1, N + SUM = SUM + FLOAT(J)*(X(J) - ONE) + 390 CONTINUE + TEMP = ONE + SIX*SUM**2 + DO 410 K = 1, N + DO 400 J = K, N + FJAC(K,J) = FLOAT(K*J)/TEMP + FJAC(J,K) = FJAC(K,J) + 400 CONTINUE + FJAC(K,K) = FJAC(K,K) + ONE + 410 CONTINUE + GO TO 490 +C +C BROYDEN TRIDIAGONAL FUNCTION WITHOUT ERROR. +C + 420 CONTINUE + DO 440 K = 1, N + DO 430 J = 1, N + FJAC(K,J) = ZERO + 430 CONTINUE + FJAC(K,K) = THREE - FOUR*X(K) + IF (K .NE. 1) FJAC(K,K-1) = -ONE + IF (K .NE. N) FJAC(K,K+1) = -TWO + 440 CONTINUE + GO TO 490 +C +C BROYDEN BANDED FUNCTION WITH SIGN ERROR AFFECTING THE JACOBIAN +C DIAGONAL. +C + 450 CONTINUE + ML = 5 + MU = 1 + DO 480 K = 1, N + DO 460 J = 1, N + FJAC(K,J) = ZERO + 460 CONTINUE + K1 = MAX0(1,K-ML) + K2 = MIN0(K+MU,N) + DO 470 J = K1, K2 + IF (J .NE. K) FJAC(K,J) = -(ONE + TWO*X(J)) + 470 CONTINUE + FJAC(K,K) = TWO - FIFTN*X(K)**2 + 480 CONTINUE + 490 CONTINUE + RETURN +C +C LAST CARD OF SUBROUTINE ERRJAC. +C + END + SUBROUTINE INITPT(N,X,NPROB,FACTOR) + INTEGER N,NPROB + REAL FACTOR + REAL X(N) +C ********** +C +C SUBROUTINE INITPT +C +C THIS SUBROUTINE SPECIFIES THE STANDARD STARTING POINTS FOR +C THE FUNCTIONS DEFINED BY SUBROUTINE VECFCN. THE SUBROUTINE +C RETURNS IN X A MULTIPLE (FACTOR) OF THE STANDARD STARTING +C POINT. FOR THE SIXTH FUNCTION THE STANDARD STARTING POINT IS +C ZERO, SO IN THIS CASE, IF FACTOR IS NOT UNITY, THEN THE +C SUBROUTINE RETURNS THE VECTOR X(J) = FACTOR, J=1,...,N. +C +C THE SUBROUTINE STATEMENT IS +C +C SUBROUTINE INITPT(N,X,NPROB,FACTOR) +C +C WHERE +C +C N IS A POSITIVE INTEGER INPUT VARIABLE. +C +C X IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE STANDARD +C STARTING POINT FOR PROBLEM NPROB MULTIPLIED BY FACTOR. +C +C NPROB IS A POSITIVE INTEGER INPUT VARIABLE WHICH DEFINES THE +C NUMBER OF THE PROBLEM. NPROB MUST NOT EXCEED 14. +C +C FACTOR IS AN INPUT VARIABLE WHICH SPECIFIES THE MULTIPLE OF +C THE STANDARD STARTING POINT. IF FACTOR IS UNITY, NO +C MULTIPLICATION IS PERFORMED. +C +C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. +C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE +C +C ********** + INTEGER IVAR,J + REAL C1,H,HALF,ONE,THREE,TJ,ZERO + REAL FLOAT + DATA ZERO,HALF,ONE,THREE,C1 /0.0E0,5.0E-1,1.0E0,3.0E0,1.2E0/ + FLOAT(IVAR) = IVAR +C +C SELECTION OF INITIAL POINT. +C + GO TO (10,20,30,40,50,60,80,100,120,120,140,160,180,180), NPROB +C +C ROSENBROCK FUNCTION. +C + 10 CONTINUE + X(1) = -C1 + X(2) = ONE + GO TO 200 +C +C POWELL SINGULAR FUNCTION. +C + 20 CONTINUE + X(1) = THREE + X(2) = -ONE + X(3) = ZERO + X(4) = ONE + GO TO 200 +C +C POWELL BADLY SCALED FUNCTION. +C + 30 CONTINUE + X(1) = ZERO + X(2) = ONE + GO TO 200 +C +C WOOD FUNCTION. +C + 40 CONTINUE + X(1) = -THREE + X(2) = -ONE + X(3) = -THREE + X(4) = -ONE + GO TO 200 +C +C HELICAL VALLEY FUNCTION. +C + 50 CONTINUE + X(1) = -ONE + X(2) = ZERO + X(3) = ZERO + GO TO 200 +C +C WATSON FUNCTION. +C + 60 CONTINUE + DO 70 J = 1, N + X(J) = ZERO + 70 CONTINUE + GO TO 200 +C +C CHEBYQUAD FUNCTION. +C + 80 CONTINUE + H = ONE/FLOAT(N+1) + DO 90 J = 1, N + X(J) = FLOAT(J)*H + 90 CONTINUE + GO TO 200 +C +C BROWN ALMOST-LINEAR FUNCTION. +C + 100 CONTINUE + DO 110 J = 1, N + X(J) = HALF + 110 CONTINUE + GO TO 200 +C +C DISCRETE BOUNDARY VALUE AND INTEGRAL EQUATION FUNCTIONS. +C + 120 CONTINUE + H = ONE/FLOAT(N+1) + DO 130 J = 1, N + TJ = FLOAT(J)*H + X(J) = TJ*(TJ - ONE) + 130 CONTINUE + GO TO 200 +C +C TRIGONOMETRIC FUNCTION. +C + 140 CONTINUE + H = ONE/FLOAT(N) + DO 150 J = 1, N + X(J) = H + 150 CONTINUE + GO TO 200 +C +C VARIABLY DIMENSIONED FUNCTION. +C + 160 CONTINUE + H = ONE/FLOAT(N) + DO 170 J = 1, N + X(J) = ONE - FLOAT(J)*H + 170 CONTINUE + GO TO 200 +C +C BROYDEN TRIDIAGONAL AND BANDED FUNCTIONS. +C + 180 CONTINUE + DO 190 J = 1, N + X(J) = -ONE + 190 CONTINUE + 200 CONTINUE +C +C COMPUTE MULTIPLE OF INITIAL POINT. +C + IF (FACTOR .EQ. ONE) GO TO 250 + IF (NPROB .EQ. 6) GO TO 220 + DO 210 J = 1, N + X(J) = FACTOR*X(J) + 210 CONTINUE + GO TO 240 + 220 CONTINUE + DO 230 J = 1, N + X(J) = FACTOR + 230 CONTINUE + 240 CONTINUE + 250 CONTINUE + RETURN +C +C LAST CARD OF SUBROUTINE INITPT. +C + END + SUBROUTINE VECFCN(N,X,FVEC,NPROB) + INTEGER N,NPROB + REAL X(N),FVEC(N) +C ********** +C +C SUBROUTINE VECFCN +C +C THIS SUBROUTINE DEFINES FOURTEEN TEST FUNCTIONS. THE FIRST +C FIVE TEST FUNCTIONS ARE OF DIMENSIONS 2,4,2,4,3, RESPECTIVELY, +C WHILE THE REMAINING TEST FUNCTIONS ARE OF VARIABLE DIMENSION +C N FOR ANY N GREATER THAN OR EQUAL TO 1 (PROBLEM 6 IS AN +C EXCEPTION TO THIS, SINCE IT DOES NOT ALLOW N = 1). +C +C THE SUBROUTINE STATEMENT IS +C +C SUBROUTINE VECFCN(N,X,FVEC,NPROB) +C +C WHERE +C +C N IS A POSITIVE INTEGER INPUT VARIABLE. +C +C X IS AN INPUT ARRAY OF LENGTH N. +C +C FVEC IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE NPROB +C FUNCTION VECTOR EVALUATED AT X. +C +C NPROB IS A POSITIVE INTEGER INPUT VARIABLE WHICH DEFINES THE +C NUMBER OF THE PROBLEM. NPROB MUST NOT EXCEED 14. +C +C SUBPROGRAMS CALLED +C +C FORTRAN-SUPPLIED ... ATAN,COS,EXP,SIGN,SIN,SQRT, +C MAX0,MIN0 +C +C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. +C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE +C +C ********** + INTEGER I,IEV,IVAR,J,K,K1,K2,KP1,ML,MU + REAL C1,C2,C3,C4,C5,C6,C7,C8,C9,EIGHT,FIVE,H,ONE,PROD,SUM,SUM1, + * SUM2,TEMP,TEMP1,TEMP2,TEN,THREE,TI,TJ,TK,TPI,TWO,ZERO + REAL FLOAT + DATA ZERO,ONE,TWO,THREE,FIVE,EIGHT,TEN + * /0.0E0,1.0E0,2.0E0,3.0E0,5.0E0,8.0E0,1.0E1/ + DATA C1,C2,C3,C4,C5,C6,C7,C8,C9 + * /1.0E4,1.0001E0,2.0E2,2.02E1,1.98E1,1.8E2,2.5E-1,5.0E-1, + * 2.9E1/ + FLOAT(IVAR) = IVAR +C +C PROBLEM SELECTOR. +C + GO TO (10,20,30,40,50,60,120,170,200,220,270,300,330,350), NPROB +C +C ROSENBROCK FUNCTION. +C + 10 CONTINUE + FVEC(1) = ONE - X(1) + FVEC(2) = TEN*(X(2) - X(1)**2) + GO TO 380 +C +C POWELL SINGULAR FUNCTION. +C + 20 CONTINUE + FVEC(1) = X(1) + TEN*X(2) + FVEC(2) = SQRT(FIVE)*(X(3) - X(4)) + FVEC(3) = (X(2) - TWO*X(3))**2 + FVEC(4) = SQRT(TEN)*(X(1) - X(4))**2 + GO TO 380 +C +C POWELL BADLY SCALED FUNCTION. +C + 30 CONTINUE + FVEC(1) = C1*X(1)*X(2) - ONE + FVEC(2) = EXP(-X(1)) + EXP(-X(2)) - C2 + GO TO 380 +C +C WOOD FUNCTION. +C + 40 CONTINUE + TEMP1 = X(2) - X(1)**2 + TEMP2 = X(4) - X(3)**2 + FVEC(1) = -C3*X(1)*TEMP1 - (ONE - X(1)) + FVEC(2) = C3*TEMP1 + C4*(X(2) - ONE) + C5*(X(4) - ONE) + FVEC(3) = -C6*X(3)*TEMP2 - (ONE - X(3)) + FVEC(4) = C6*TEMP2 + C4*(X(4) - ONE) + C5*(X(2) - ONE) + GO TO 380 +C +C HELICAL VALLEY FUNCTION. +C + 50 CONTINUE + TPI = EIGHT*ATAN(ONE) + TEMP1 = SIGN(C7,X(2)) + IF (X(1) .GT. ZERO) TEMP1 = ATAN(X(2)/X(1))/TPI + IF (X(1) .LT. ZERO) TEMP1 = ATAN(X(2)/X(1))/TPI + C8 + TEMP2 = SQRT(X(1)**2+X(2)**2) + FVEC(1) = TEN*(X(3) - TEN*TEMP1) + FVEC(2) = TEN*(TEMP2 - ONE) + FVEC(3) = X(3) + GO TO 380 +C +C WATSON FUNCTION. +C + 60 CONTINUE + DO 70 K = 1, N + FVEC(K) = ZERO + 70 CONTINUE + DO 110 I = 1, 29 + TI = FLOAT(I)/C9 + SUM1 = ZERO + TEMP = ONE + DO 80 J = 2, N + SUM1 = SUM1 + FLOAT(J-1)*TEMP*X(J) + TEMP = TI*TEMP + 80 CONTINUE + SUM2 = ZERO + TEMP = ONE + DO 90 J = 1, N + SUM2 = SUM2 + TEMP*X(J) + TEMP = TI*TEMP + 90 CONTINUE + TEMP1 = SUM1 - SUM2**2 - ONE + TEMP2 = TWO*TI*SUM2 + TEMP = ONE/TI + DO 100 K = 1, N + FVEC(K) = FVEC(K) + TEMP*(FLOAT(K-1) - TEMP2)*TEMP1 + TEMP = TI*TEMP + 100 CONTINUE + 110 CONTINUE + TEMP = X(2) - X(1)**2 - ONE + FVEC(1) = FVEC(1) + X(1)*(ONE - TWO*TEMP) + FVEC(2) = FVEC(2) + TEMP + GO TO 380 +C +C CHEBYQUAD FUNCTION. +C + 120 CONTINUE + DO 130 K = 1, N + FVEC(K) = ZERO + 130 CONTINUE + DO 150 J = 1, N + TEMP1 = ONE + TEMP2 = TWO*X(J) - ONE + TEMP = TWO*TEMP2 + DO 140 I = 1, N + FVEC(I) = FVEC(I) + TEMP2 + TI = TEMP*TEMP2 - TEMP1 + TEMP1 = TEMP2 + TEMP2 = TI + 140 CONTINUE + 150 CONTINUE + TK = ONE/FLOAT(N) + IEV = -1 + DO 160 K = 1, N + FVEC(K) = TK*FVEC(K) + IF (IEV .GT. 0) FVEC(K) = FVEC(K) + ONE/(FLOAT(K)**2 - ONE) + IEV = -IEV + 160 CONTINUE + GO TO 380 +C +C BROWN ALMOST-LINEAR FUNCTION. +C + 170 CONTINUE + SUM = -FLOAT(N+1) + PROD = ONE + DO 180 J = 1, N + SUM = SUM + X(J) + PROD = X(J)*PROD + 180 CONTINUE + DO 190 K = 1, N + FVEC(K) = X(K) + SUM + 190 CONTINUE + FVEC(N) = PROD - ONE + GO TO 380 +C +C DISCRETE BOUNDARY VALUE FUNCTION. +C + 200 CONTINUE + H = ONE/FLOAT(N+1) + DO 210 K = 1, N + TEMP = (X(K) + FLOAT(K)*H + ONE)**3 + TEMP1 = ZERO + IF (K .NE. 1) TEMP1 = X(K-1) + TEMP2 = ZERO + IF (K .NE. N) TEMP2 = X(K+1) + FVEC(K) = TWO*X(K) - TEMP1 - TEMP2 + TEMP*H**2/TWO + 210 CONTINUE + GO TO 380 +C +C DISCRETE INTEGRAL EQUATION FUNCTION. +C + 220 CONTINUE + H = ONE/FLOAT(N+1) + DO 260 K = 1, N + TK = FLOAT(K)*H + SUM1 = ZERO + DO 230 J = 1, K + TJ = FLOAT(J)*H + TEMP = (X(J) + TJ + ONE)**3 + SUM1 = SUM1 + TJ*TEMP + 230 CONTINUE + SUM2 = ZERO + KP1 = K + 1 + IF (N .LT. KP1) GO TO 250 + DO 240 J = KP1, N + TJ = FLOAT(J)*H + TEMP = (X(J) + TJ + ONE)**3 + SUM2 = SUM2 + (ONE - TJ)*TEMP + 240 CONTINUE + 250 CONTINUE + FVEC(K) = X(K) + H*((ONE - TK)*SUM1 + TK*SUM2)/TWO + 260 CONTINUE + GO TO 380 +C +C TRIGONOMETRIC FUNCTION. +C + 270 CONTINUE + SUM = ZERO + DO 280 J = 1, N + FVEC(J) = COS(X(J)) + SUM = SUM + FVEC(J) + 280 CONTINUE + DO 290 K = 1, N + FVEC(K) = FLOAT(N+K) - SIN(X(K)) - SUM - FLOAT(K)*FVEC(K) + 290 CONTINUE + GO TO 380 +C +C VARIABLY DIMENSIONED FUNCTION. +C + 300 CONTINUE + SUM = ZERO + DO 310 J = 1, N + SUM = SUM + FLOAT(J)*(X(J) - ONE) + 310 CONTINUE + TEMP = SUM*(ONE + TWO*SUM**2) + DO 320 K = 1, N + FVEC(K) = X(K) - ONE + FLOAT(K)*TEMP + 320 CONTINUE + GO TO 380 +C +C BROYDEN TRIDIAGONAL FUNCTION. +C + 330 CONTINUE + DO 340 K = 1, N + TEMP = (THREE - TWO*X(K))*X(K) + TEMP1 = ZERO + IF (K .NE. 1) TEMP1 = X(K-1) + TEMP2 = ZERO + IF (K .NE. N) TEMP2 = X(K+1) + FVEC(K) = TEMP - TEMP1 - TWO*TEMP2 + ONE + 340 CONTINUE + GO TO 380 +C +C BROYDEN BANDED FUNCTION. +C + 350 CONTINUE + ML = 5 + MU = 1 + DO 370 K = 1, N + K1 = MAX0(1,K-ML) + K2 = MIN0(K+MU,N) + TEMP = ZERO + DO 360 J = K1, K2 + IF (J .NE. K) TEMP = TEMP + X(J)*(ONE + X(J)) + 360 CONTINUE + FVEC(K) = X(K)*(TWO + FIVE*X(K)**2) + ONE - TEMP + 370 CONTINUE + 380 CONTINUE + RETURN +C +C LAST CARD OF SUBROUTINE VECFCN. +C + END diff --git a/ex/file14 b/ex/file14 new file mode 100644 index 0000000..9ad38d8 --- /dev/null +++ b/ex/file14 @@ -0,0 +1,284 @@ +C ********** +C +C THIS PROGRAM CHECKS THE CONSTANTS OF MACHINE PRECISION AND +C SMALLEST AND LARGEST MACHINE REPRESENTABLE NUMBERS SPECIFIED IN +C FUNCTION DPMPAR, AGAINST THE CORRESPONDING HARDWARE-DETERMINED +C MACHINE CONSTANTS OBTAINED BY DMCHAR, A SUBROUTINE DUE TO +C W. J. CODY. +C +C DATA STATEMENTS IN DPMPAR CORRESPONDING TO THE MACHINE USED MUST +C BE ACTIVATED BY REMOVING C IN COLUMN 1. +C +C THE PRINTED OUTPUT CONSISTS OF THE MACHINE CONSTANTS OBTAINED BY +C DMCHAR AND COMPARISONS OF THE DPMPAR CONSTANTS WITH THEIR +C DMCHAR COUNTERPARTS. DESCRIPTIONS OF THE MACHINE CONSTANTS ARE +C GIVEN IN THE PROLOGUE COMMENTS OF DMCHAR. +C +C SUBPROGRAMS CALLED +C +C MINPACK-SUPPLIED ... DMCHAR,DPMPAR +C +C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. +C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE +C +C ********** + INTEGER IBETA,IEXP,IRND,IT,MACHEP,MAXEXP,MINEXP,NEGEP,NGRD, + * NWRITE + DOUBLE PRECISION DWARF,EPS,EPSMCH,EPSNEG,GIANT,XMAX,XMIN + DOUBLE PRECISION RERR(3) + DOUBLE PRECISION DPMPAR +C +C LOGICAL OUTPUT UNIT IS ASSUMED TO BE NUMBER 6. +C + DATA NWRITE /6/ +C +C DETERMINE THE MACHINE CONSTANTS DYNAMICALLY FROM DMCHAR. +C + CALL DMCHAR(IBETA,IT,IRND,NGRD,MACHEP,NEGEP,IEXP,MINEXP,MAXEXP, + * EPS,EPSNEG,XMIN,XMAX) +C +C COMPARE THE DPMPAR CONSTANTS WITH THEIR DMCHAR COUNTERPARTS AND +C STORE THE RELATIVE DIFFERENCES IN RERR. +C + EPSMCH = DPMPAR(1) + DWARF = DPMPAR(2) + GIANT = DPMPAR(3) + RERR(1) = (EPSMCH - EPS)/EPSMCH + RERR(2) = (DWARF - XMIN)/DWARF + RERR(3) = (XMAX - GIANT)/GIANT +C +C WRITE THE DMCHAR CONSTANTS. +C + WRITE (NWRITE,10) + * IBETA,IT,IRND,NGRD,MACHEP,NEGEP,IEXP,MINEXP,MAXEXP,EPS, + * EPSNEG,XMIN,XMAX +C +C WRITE THE DPMPAR CONSTANTS AND THE RELATIVE DIFFERENCES. +C + WRITE (NWRITE,20) EPSMCH,RERR(1),DWARF,RERR(2),GIANT,RERR(3) + STOP + 10 FORMAT (17H1DMCHAR CONSTANTS /// 8H IBETA =, I6 // 8H IT =, + * I6 // 8H IRND =, I6 // 8H NGRD =, I6 // 9H MACHEP =, + * I6 // 8H NEGEP =, I6 // 7H IEXP =, I6 // 9H MINEXP =, + * I6 // 9H MAXEXP =, I6 // 6H EPS =, D15.7 // 9H EPSNEG =, + * D15.7 // 7H XMIN =, D15.7 // 7H XMAX =, D15.7) + 20 FORMAT ( /// 42H DPMPAR CONSTANTS AND RELATIVE DIFFERENCES /// + * 9H EPSMCH =, D15.7 / 10H RERR(1) =, D15.7 // + * 8H DWARF =, D15.7 / 10H RERR(2) =, D15.7 // 8H GIANT =, + * D15.7 / 10H RERR(3) =, D15.7) +C +C LAST CARD OF DRIVER. +C + END + SUBROUTINE DMCHAR(IBETA,IT,IRND,NGRD,MACHEP,NEGEP,IEXP,MINEXP, + 1 MAXEXP,EPS,EPSNEG,XMIN,XMAX) +C + INTEGER I,IBETA,IEXP,IRND,IT,IZ,J,K,MACHEP,MAXEXP,MINEXP, + 1 MX,NEGEP,NGRD + DOUBLE PRECISION A,B,BETA,BETAIN,BETAM1,EPS,EPSNEG,ONE,XMAX, + 1 XMIN,Y,Z,ZERO +C +C THIS SUBROUTINE IS INTENDED TO DETERMINE THE CHARACTERISTICS +C OF THE FLOATING-POINT ARITHMETIC SYSTEM THAT ARE SPECIFIED +C BELOW. THE FIRST THREE ARE DETERMINED ACCORDING TO AN +C ALGORITHM DUE TO M. MALCOLM, CACM 15 (1972), PP. 949-951, +C INCORPORATING SOME, BUT NOT ALL, OF THE IMPROVEMENTS +C SUGGESTED BY M. GENTLEMAN AND S. MAROVICH, CACM 17 (1974), +C PP. 276-277. +C +C +C IBETA - THE RADIX OF THE FLOATING-POINT REPRESENTATION +C IT - THE NUMBER OF BASE IBETA DIGITS IN THE FLOATING-POINT +C SIGNIFICAND +C IRND - 0 IF FLOATING-POINT ADDITION CHOPS, +C 1 IF FLOATING-POINT ADDITION ROUNDS +C NGRD - THE NUMBER OF GUARD DIGITS FOR MULTIPLICATION. IT IS +C 0 IF IRND=1, OR IF IRND=0 AND ONLY IT BASE IBET +C DIGITS PARTICIPATE IN THE POST NORMALIZATION SHIFT +C OF THE FLOATING-POINT SIGNIFICAND IN MULTIPLICATION +C 1 IF IRND=0 AND MORE THAN IT BASE IBETA DIGITS +C PARTICIPATE IN THE POST NORMALIZATION SHIFT OF THE +C FLOATING-POINT SIGNIFICAND IN MULTIPLICATION +C MACHEP - THE LARGEST NEGATIVE INTEGER SUCH THAT +C 1.0+FLOAT(IBETA)**MACHEP .NE. 1.0, EXCEPT THAT +C MACHEP IS BOUNDED BELOW BY -(IT+3) +C NEGEPS - THE LARGEST NEGATIVE INTEGER SUCH THAT +C 1.0-FLOAT(IBETA)**NEGEPS .NE. 1.0, EXCEPT THAT +C NEGEPS IS BOUNDED BELOW BY -(IT+3) +C IEXP - THE NUMBER OF BITS (DECIMAL PLACES IF IBETA = 10) +C RESERVED FOR THE REPRESENTATION OF THE EXPONENT +C (INCLUDING THE BIAS OR SIGN) OF A FLOATING-POINT +C NUMBER +C MINEXP - THE LARGEST IN MAGNITUDE NEGATIVE INTEGER SUCH THAT +C FLOAT(IBETA)**MINEXP IS A POSITIVE FLOATING-POINT +C NUMBER +C MAXEXP - THE LARGEST POSITIVE INTEGER EXPONENT FOR A FINITE +C FLOATING-POINT NUMBER +C EPS - THE SMALLEST POSITIVE FLOATING-POINT NUMBER SUCH +C THAT 1.0+EPS .NE. 1.0. IN PARTICULAR, IF EITHER +C IBETA = 2 OR IRND = 0, EPS = FLOAT(IBETA)**MACHEP. +C OTHERWISE, EPS = (FLOAT(IBETA)**MACHEP)/2 +C EPSNEG - A SMALL POSITIVE FLOATING-POINT NUMBER SUCH THAT +C 1.0-EPSNEG .NE. 1.0. IN PARTICULAR, IF IBETA = 2 +C OR IRND = 0, EPSNEG = FLOAT(IBETA)**NEGEPS. +C OTHERWISE, EPSNEG = (IBETA**NEGEPS)/2. BECAUSE +C NEGEPS IS BOUNDED BELOW BY -(IT+3), EPSNEG MAY NOT +C BE THE SMALLEST NUMBER WHICH CAN ALTER 1.0 BY +C SUBTRACTION. +C XMIN - THE SMALLEST NON-VANISHING FLOATING-POINT POWER OF TH +C RADIX. IN PARTICULAR, XMIN = FLOAT(IBETA)**MINEXP +C XMAX - THE LARGEST FINITE FLOATING-POINT NUMBER. IN +C PARTICULAR XMAX = (1.0-EPSNEG)*FLOAT(IBETA)**MAXEXP +C NOTE - ON SOME MACHINES XMAX WILL BE ONLY THE +C SECOND, OR PERHAPS THIRD, LARGEST NUMBER, BEING +C TOO SMALL BY 1 OR 2 UNITS IN THE LAST DIGIT OF +C THE SIGNIFICAND. +C +C LATEST REVISION - OCTOBER 22, 1979 +C +C AUTHOR - W. J. CODY +C ARGONNE NATIONAL LABORATORY +C +C----------------------------------------------------------------- + ONE = DBLE(FLOAT(1)) + ZERO = 0.0D0 +C----------------------------------------------------------------- +C DETERMINE IBETA,BETA ALA MALCOLM +C----------------------------------------------------------------- + A = ONE + 10 A = A + A + IF (((A+ONE)-A)-ONE .EQ. ZERO) GO TO 10 + B = ONE + 20 B = B + B + IF ((A+B)-A .EQ. ZERO) GO TO 20 + IBETA = INT(SNGL((A + B) - A)) + BETA = DBLE(FLOAT(IBETA)) +C----------------------------------------------------------------- +C DETERMINE IT, IRND +C----------------------------------------------------------------- + IT = 0 + B = ONE + 100 IT = IT + 1 + B = B * BETA + IF (((B+ONE)-B)-ONE .EQ. ZERO) GO TO 100 + IRND = 0 + BETAM1 = BETA - ONE + IF ((A+BETAM1)-A .NE. ZERO) IRND = 1 +C----------------------------------------------------------------- +C DETERMINE NEGEP, EPSNEG +C----------------------------------------------------------------- + NEGEP = IT + 3 + BETAIN = ONE / BETA + A = ONE +C + DO 200 I = 1, NEGEP + A = A * BETAIN + 200 CONTINUE +C + B = A + 210 IF ((ONE-A)-ONE .NE. ZERO) GO TO 220 + A = A * BETA + NEGEP = NEGEP - 1 + GO TO 210 + 220 NEGEP = -NEGEP + EPSNEG = A + IF ((IBETA .EQ. 2) .OR. (IRND .EQ. 0)) GO TO 300 + A = (A*(ONE+A)) / (ONE+ONE) + IF ((ONE-A)-ONE .NE. ZERO) EPSNEG = A +C----------------------------------------------------------------- +C DETERMINE MACHEP, EPS +C----------------------------------------------------------------- + 300 MACHEP = -IT - 3 + A = B + 310 IF((ONE+A)-ONE .NE. ZERO) GO TO 320 + A = A * BETA + MACHEP = MACHEP + 1 + GO TO 310 + 320 EPS = A + IF ((IBETA .EQ. 2) .OR. (IRND .EQ. 0)) GO TO 350 + A = (A*(ONE+A)) / (ONE+ONE) + IF ((ONE+A)-ONE .NE. ZERO) EPS = A +C----------------------------------------------------------------- +C DETERMINE NGRD +C----------------------------------------------------------------- + 350 NGRD = 0 + IF ((IRND .EQ. 0) .AND. ((ONE+EPS)*ONE-ONE) .NE. ZERO) NGRD = 1 +C----------------------------------------------------------------- +C DETERMINE IEXP, MINEXP, XMIN +C +C LOOP TO DETERMINE LARGEST I AND K = 2**I SUCH THAT +C (1/BETA) ** (2**(I)) +C DOES NOT UNDERFLOW +C EXIT FROM LOOP IS SIGNALED BY AN UNDERFLOW. +C----------------------------------------------------------------- + I = 0 + K = 1 + Z = BETAIN + 400 Y = Z + Z = Y * Y +C----------------------------------------------------------------- +C CHECK FOR UNDERFLOW HERE +C----------------------------------------------------------------- + A = Z * ONE + IF ((A+A .EQ. ZERO) .OR. (DABS(Z) .GE. Y)) GO TO 410 + I = I + 1 + K = K + K + GO TO 400 + 410 IF (IBETA .EQ. 10) GO TO 420 + IEXP = I + 1 + MX = K + K + GO TO 450 +C----------------------------------------------------------------- +C FOR DECIMAL MACHINES ONLY +C----------------------------------------------------------------- + 420 IEXP = 2 + IZ = IBETA + 430 IF (K .LT. IZ) GO TO 440 + IZ = IZ * IBETA + IEXP = IEXP + 1 + GO TO 430 + 440 MX = IZ + IZ - 1 +C----------------------------------------------------------------- +C LOOP TO DETERMINE MINEXP, XMIN +C EXIT FROM LOOP IS SIGNALED BY AN UNDERFLOW. +C----------------------------------------------------------------- + 450 XMIN = Y + Y = Y * BETAIN +C----------------------------------------------------------------- +C CHECK FOR UNDERFLOW HERE +C----------------------------------------------------------------- + A = Y * ONE + IF (((A+A) .EQ. ZERO) .OR. (DABS(Y) .GE. XMIN)) GO TO 460 + K = K + 1 + GO TO 450 + 460 MINEXP = -K +C----------------------------------------------------------------- +C DETERMINE MAXEXP, XMAX +C----------------------------------------------------------------- + IF ((MX .GT. K+K-3) .OR. (IBETA .EQ. 10)) GO TO 500 + MX = MX + MX + IEXP = IEXP + 1 + 500 MAXEXP = MX + MINEXP +C----------------------------------------------------------------- +C ADJUST FOR MACHINES WITH IMPLICIT LEADING +C BIT IN BINARY SIGNIFICAND AND MACHINES WITH +C RADIX POINT AT EXTREME RIGHT OF SIGNIFICAND +C----------------------------------------------------------------- + I = MAXEXP + MINEXP + IF ((IBETA .EQ. 2) .AND. (I .EQ. 0)) MAXEXP = MAXEXP - 1 + IF (I .GT. 20) MAXEXP = MAXEXP - 1 + IF (A .NE. Y) MAXEXP = MAXEXP - 2 + XMAX = ONE - EPSNEG + IF (XMAX*ONE .NE. XMAX) XMAX = ONE - BETA * EPSNEG + XMAX = XMAX / (BETA * BETA * BETA * XMIN) + I = MAXEXP + MINEXP + 3 + IF (I .LE. 0) GO TO 520 +C + DO 510 J = 1, I + IF (IBETA .EQ. 2) XMAX = XMAX + XMAX + IF (IBETA .NE. 2) XMAX = XMAX * BETA + 510 CONTINUE +C + 520 RETURN +C ---------- LAST CARD OF DMCHAR ---------- + END diff --git a/ex/file15 b/ex/file15 new file mode 100644 index 0000000..13312c7 --- /dev/null +++ b/ex/file15 @@ -0,0 +1,552 @@ +C ********** +C +C THIS PROGRAM TESTS CODES FOR THE SOLUTION OF N NONLINEAR +C EQUATIONS IN N VARIABLES. IT CONSISTS OF A DRIVER AND AN +C INTERFACE SUBROUTINE FCN. THE DRIVER READS IN DATA, CALLS THE +C NONLINEAR EQUATION SOLVER, AND FINALLY PRINTS OUT INFORMATION +C ON THE PERFORMANCE OF THE SOLVER. THIS IS ONLY A SAMPLE DRIVER, +C MANY OTHER DRIVERS ARE POSSIBLE. THE INTERFACE SUBROUTINE FCN +C IS NECESSARY TO TAKE INTO ACCOUNT THE FORMS OF CALLING +C SEQUENCES USED BY THE FUNCTION SUBROUTINES IN THE VARIOUS +C NONLINEAR EQUATION SOLVERS. +C +C SUBPROGRAMS CALLED +C +C USER-SUPPLIED ...... FCN +C +C MINPACK-SUPPLIED ... DPMPAR,ENORM,HYBRD1,INITPT,VECFCN +C +C FORTRAN-SUPPLIED ... DSQRT +C +C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. +C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE +C +C ********** + INTEGER I,IC,INFO,K,LWA,N,NFEV,NPROB,NREAD,NTRIES,NWRITE + INTEGER NA(60),NF(60),NP(60),NX(60) + DOUBLE PRECISION FACTOR,FNORM1,FNORM2,ONE,TEN,TOL + DOUBLE PRECISION FNM(60),FVEC(40),WA(2660),X(40) + DOUBLE PRECISION DPMPAR,ENORM + EXTERNAL FCN + COMMON /REFNUM/ NPROB,NFEV +C +C LOGICAL INPUT UNIT IS ASSUMED TO BE NUMBER 5. +C LOGICAL OUTPUT UNIT IS ASSUMED TO BE NUMBER 6. +C + DATA NREAD,NWRITE /5,6/ +C + DATA ONE,TEN /1.0D0,1.0D1/ + TOL = DSQRT(DPMPAR(1)) + LWA = 2660 + IC = 0 + 10 CONTINUE + READ (NREAD,50) NPROB,N,NTRIES + IF (NPROB .LE. 0) GO TO 30 + FACTOR = ONE + DO 20 K = 1, NTRIES + IC = IC + 1 + CALL INITPT(N,X,NPROB,FACTOR) + CALL VECFCN(N,X,FVEC,NPROB) + FNORM1 = ENORM(N,FVEC) + WRITE (NWRITE,60) NPROB,N + NFEV = 0 + CALL HYBRD1(FCN,N,X,FVEC,TOL,INFO,WA,LWA) + FNORM2 = ENORM(N,FVEC) + NP(IC) = NPROB + NA(IC) = N + NF(IC) = NFEV + NX(IC) = INFO + FNM(IC) = FNORM2 + WRITE (NWRITE,70) FNORM1,FNORM2,NFEV,INFO,(X(I), I = 1, N) + FACTOR = TEN*FACTOR + 20 CONTINUE + GO TO 10 + 30 CONTINUE + WRITE (NWRITE,80) IC + WRITE (NWRITE,90) + DO 40 I = 1, IC + WRITE (NWRITE,100) NP(I),NA(I),NF(I),NX(I),FNM(I) + 40 CONTINUE + STOP + 50 FORMAT (3I5) + 60 FORMAT ( //// 5X, 8H PROBLEM, I5, 5X, 10H DIMENSION, I5, 5X //) + 70 FORMAT (5X, 33H INITIAL L2 NORM OF THE RESIDUALS, D15.7 // 5X, + * 33H FINAL L2 NORM OF THE RESIDUALS , D15.7 // 5X, + * 33H NUMBER OF FUNCTION EVALUATIONS , I10 // 5X, + * 15H EXIT PARAMETER, 18X, I10 // 5X, + * 27H FINAL APPROXIMATE SOLUTION // (5X, 5D15.7)) + 80 FORMAT (12H1SUMMARY OF , I3, 16H CALLS TO HYBRD1 /) + 90 FORMAT (39H NPROB N NFEV INFO FINAL L2 NORM /) + 100 FORMAT (I4, I6, I7, I6, 1X, D15.7) +C +C LAST CARD OF DRIVER. +C + END + SUBROUTINE FCN(N,X,FVEC,IFLAG) + INTEGER N,IFLAG + DOUBLE PRECISION X(N),FVEC(N) +C ********** +C +C THE CALLING SEQUENCE OF FCN SHOULD BE IDENTICAL TO THE +C CALLING SEQUENCE OF THE FUNCTION SUBROUTINE IN THE NONLINEAR +C EQUATION SOLVER. FCN SHOULD ONLY CALL THE TESTING FUNCTION +C SUBROUTINE VECFCN WITH THE APPROPRIATE VALUE OF PROBLEM +C NUMBER (NPROB). +C +C SUBPROGRAMS CALLED +C +C MINPACK-SUPPLIED ... VECFCN +C +C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. +C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE +C +C ********** + INTEGER NPROB,NFEV + COMMON /REFNUM/ NPROB,NFEV + CALL VECFCN(N,X,FVEC,NPROB) + NFEV = NFEV + 1 + RETURN +C +C LAST CARD OF INTERFACE SUBROUTINE FCN. +C + END + SUBROUTINE VECFCN(N,X,FVEC,NPROB) + INTEGER N,NPROB + DOUBLE PRECISION X(N),FVEC(N) +C ********** +C +C SUBROUTINE VECFCN +C +C THIS SUBROUTINE DEFINES FOURTEEN TEST FUNCTIONS. THE FIRST +C FIVE TEST FUNCTIONS ARE OF DIMENSIONS 2,4,2,4,3, RESPECTIVELY, +C WHILE THE REMAINING TEST FUNCTIONS ARE OF VARIABLE DIMENSION +C N FOR ANY N GREATER THAN OR EQUAL TO 1 (PROBLEM 6 IS AN +C EXCEPTION TO THIS, SINCE IT DOES NOT ALLOW N = 1). +C +C THE SUBROUTINE STATEMENT IS +C +C SUBROUTINE VECFCN(N,X,FVEC,NPROB) +C +C WHERE +C +C N IS A POSITIVE INTEGER INPUT VARIABLE. +C +C X IS AN INPUT ARRAY OF LENGTH N. +C +C FVEC IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE NPROB +C FUNCTION VECTOR EVALUATED AT X. +C +C NPROB IS A POSITIVE INTEGER INPUT VARIABLE WHICH DEFINES THE +C NUMBER OF THE PROBLEM. NPROB MUST NOT EXCEED 14. +C +C SUBPROGRAMS CALLED +C +C FORTRAN-SUPPLIED ... DATAN,DCOS,DEXP,DSIGN,DSIN,DSQRT, +C MAX0,MIN0 +C +C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. +C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE +C +C ********** + INTEGER I,IEV,IVAR,J,K,K1,K2,KP1,ML,MU + DOUBLE PRECISION C1,C2,C3,C4,C5,C6,C7,C8,C9,EIGHT,FIVE,H,ONE, + * PROD,SUM,SUM1,SUM2,TEMP,TEMP1,TEMP2,TEN,THREE, + * TI,TJ,TK,TPI,TWO,ZERO + DOUBLE PRECISION DFLOAT + DATA ZERO,ONE,TWO,THREE,FIVE,EIGHT,TEN + * /0.0D0,1.0D0,2.0D0,3.0D0,5.0D0,8.0D0,1.0D1/ + DATA C1,C2,C3,C4,C5,C6,C7,C8,C9 + * /1.0D4,1.0001D0,2.0D2,2.02D1,1.98D1,1.8D2,2.5D-1,5.0D-1, + * 2.9D1/ + DFLOAT(IVAR) = IVAR +C +C PROBLEM SELECTOR. +C + GO TO (10,20,30,40,50,60,120,170,200,220,270,300,330,350), NPROB +C +C ROSENBROCK FUNCTION. +C + 10 CONTINUE + FVEC(1) = ONE - X(1) + FVEC(2) = TEN*(X(2) - X(1)**2) + GO TO 380 +C +C POWELL SINGULAR FUNCTION. +C + 20 CONTINUE + FVEC(1) = X(1) + TEN*X(2) + FVEC(2) = DSQRT(FIVE)*(X(3) - X(4)) + FVEC(3) = (X(2) - TWO*X(3))**2 + FVEC(4) = DSQRT(TEN)*(X(1) - X(4))**2 + GO TO 380 +C +C POWELL BADLY SCALED FUNCTION. +C + 30 CONTINUE + FVEC(1) = C1*X(1)*X(2) - ONE + FVEC(2) = DEXP(-X(1)) + DEXP(-X(2)) - C2 + GO TO 380 +C +C WOOD FUNCTION. +C + 40 CONTINUE + TEMP1 = X(2) - X(1)**2 + TEMP2 = X(4) - X(3)**2 + FVEC(1) = -C3*X(1)*TEMP1 - (ONE - X(1)) + FVEC(2) = C3*TEMP1 + C4*(X(2) - ONE) + C5*(X(4) - ONE) + FVEC(3) = -C6*X(3)*TEMP2 - (ONE - X(3)) + FVEC(4) = C6*TEMP2 + C4*(X(4) - ONE) + C5*(X(2) - ONE) + GO TO 380 +C +C HELICAL VALLEY FUNCTION. +C + 50 CONTINUE + TPI = EIGHT*DATAN(ONE) + TEMP1 = DSIGN(C7,X(2)) + IF (X(1) .GT. ZERO) TEMP1 = DATAN(X(2)/X(1))/TPI + IF (X(1) .LT. ZERO) TEMP1 = DATAN(X(2)/X(1))/TPI + C8 + TEMP2 = DSQRT(X(1)**2+X(2)**2) + FVEC(1) = TEN*(X(3) - TEN*TEMP1) + FVEC(2) = TEN*(TEMP2 - ONE) + FVEC(3) = X(3) + GO TO 380 +C +C WATSON FUNCTION. +C + 60 CONTINUE + DO 70 K = 1, N + FVEC(K) = ZERO + 70 CONTINUE + DO 110 I = 1, 29 + TI = DFLOAT(I)/C9 + SUM1 = ZERO + TEMP = ONE + DO 80 J = 2, N + SUM1 = SUM1 + DFLOAT(J-1)*TEMP*X(J) + TEMP = TI*TEMP + 80 CONTINUE + SUM2 = ZERO + TEMP = ONE + DO 90 J = 1, N + SUM2 = SUM2 + TEMP*X(J) + TEMP = TI*TEMP + 90 CONTINUE + TEMP1 = SUM1 - SUM2**2 - ONE + TEMP2 = TWO*TI*SUM2 + TEMP = ONE/TI + DO 100 K = 1, N + FVEC(K) = FVEC(K) + TEMP*(DFLOAT(K-1) - TEMP2)*TEMP1 + TEMP = TI*TEMP + 100 CONTINUE + 110 CONTINUE + TEMP = X(2) - X(1)**2 - ONE + FVEC(1) = FVEC(1) + X(1)*(ONE - TWO*TEMP) + FVEC(2) = FVEC(2) + TEMP + GO TO 380 +C +C CHEBYQUAD FUNCTION. +C + 120 CONTINUE + DO 130 K = 1, N + FVEC(K) = ZERO + 130 CONTINUE + DO 150 J = 1, N + TEMP1 = ONE + TEMP2 = TWO*X(J) - ONE + TEMP = TWO*TEMP2 + DO 140 I = 1, N + FVEC(I) = FVEC(I) + TEMP2 + TI = TEMP*TEMP2 - TEMP1 + TEMP1 = TEMP2 + TEMP2 = TI + 140 CONTINUE + 150 CONTINUE + TK = ONE/DFLOAT(N) + IEV = -1 + DO 160 K = 1, N + FVEC(K) = TK*FVEC(K) + IF (IEV .GT. 0) FVEC(K) = FVEC(K) + ONE/(DFLOAT(K)**2 - ONE) + IEV = -IEV + 160 CONTINUE + GO TO 380 +C +C BROWN ALMOST-LINEAR FUNCTION. +C + 170 CONTINUE + SUM = -DFLOAT(N+1) + PROD = ONE + DO 180 J = 1, N + SUM = SUM + X(J) + PROD = X(J)*PROD + 180 CONTINUE + DO 190 K = 1, N + FVEC(K) = X(K) + SUM + 190 CONTINUE + FVEC(N) = PROD - ONE + GO TO 380 +C +C DISCRETE BOUNDARY VALUE FUNCTION. +C + 200 CONTINUE + H = ONE/DFLOAT(N+1) + DO 210 K = 1, N + TEMP = (X(K) + DFLOAT(K)*H + ONE)**3 + TEMP1 = ZERO + IF (K .NE. 1) TEMP1 = X(K-1) + TEMP2 = ZERO + IF (K .NE. N) TEMP2 = X(K+1) + FVEC(K) = TWO*X(K) - TEMP1 - TEMP2 + TEMP*H**2/TWO + 210 CONTINUE + GO TO 380 +C +C DISCRETE INTEGRAL EQUATION FUNCTION. +C + 220 CONTINUE + H = ONE/DFLOAT(N+1) + DO 260 K = 1, N + TK = DFLOAT(K)*H + SUM1 = ZERO + DO 230 J = 1, K + TJ = DFLOAT(J)*H + TEMP = (X(J) + TJ + ONE)**3 + SUM1 = SUM1 + TJ*TEMP + 230 CONTINUE + SUM2 = ZERO + KP1 = K + 1 + IF (N .LT. KP1) GO TO 250 + DO 240 J = KP1, N + TJ = DFLOAT(J)*H + TEMP = (X(J) + TJ + ONE)**3 + SUM2 = SUM2 + (ONE - TJ)*TEMP + 240 CONTINUE + 250 CONTINUE + FVEC(K) = X(K) + H*((ONE - TK)*SUM1 + TK*SUM2)/TWO + 260 CONTINUE + GO TO 380 +C +C TRIGONOMETRIC FUNCTION. +C + 270 CONTINUE + SUM = ZERO + DO 280 J = 1, N + FVEC(J) = DCOS(X(J)) + SUM = SUM + FVEC(J) + 280 CONTINUE + DO 290 K = 1, N + FVEC(K) = DFLOAT(N+K) - DSIN(X(K)) - SUM - DFLOAT(K)*FVEC(K) + 290 CONTINUE + GO TO 380 +C +C VARIABLY DIMENSIONED FUNCTION. +C + 300 CONTINUE + SUM = ZERO + DO 310 J = 1, N + SUM = SUM + DFLOAT(J)*(X(J) - ONE) + 310 CONTINUE + TEMP = SUM*(ONE + TWO*SUM**2) + DO 320 K = 1, N + FVEC(K) = X(K) - ONE + DFLOAT(K)*TEMP + 320 CONTINUE + GO TO 380 +C +C BROYDEN TRIDIAGONAL FUNCTION. +C + 330 CONTINUE + DO 340 K = 1, N + TEMP = (THREE - TWO*X(K))*X(K) + TEMP1 = ZERO + IF (K .NE. 1) TEMP1 = X(K-1) + TEMP2 = ZERO + IF (K .NE. N) TEMP2 = X(K+1) + FVEC(K) = TEMP - TEMP1 - TWO*TEMP2 + ONE + 340 CONTINUE + GO TO 380 +C +C BROYDEN BANDED FUNCTION. +C + 350 CONTINUE + ML = 5 + MU = 1 + DO 370 K = 1, N + K1 = MAX0(1,K-ML) + K2 = MIN0(K+MU,N) + TEMP = ZERO + DO 360 J = K1, K2 + IF (J .NE. K) TEMP = TEMP + X(J)*(ONE + X(J)) + 360 CONTINUE + FVEC(K) = X(K)*(TWO + FIVE*X(K)**2) + ONE - TEMP + 370 CONTINUE + 380 CONTINUE + RETURN +C +C LAST CARD OF SUBROUTINE VECFCN. +C + END + SUBROUTINE INITPT(N,X,NPROB,FACTOR) + INTEGER N,NPROB + DOUBLE PRECISION FACTOR + DOUBLE PRECISION X(N) +C ********** +C +C SUBROUTINE INITPT +C +C THIS SUBROUTINE SPECIFIES THE STANDARD STARTING POINTS FOR +C THE FUNCTIONS DEFINED BY SUBROUTINE VECFCN. THE SUBROUTINE +C RETURNS IN X A MULTIPLE (FACTOR) OF THE STANDARD STARTING +C POINT. FOR THE SIXTH FUNCTION THE STANDARD STARTING POINT IS +C ZERO, SO IN THIS CASE, IF FACTOR IS NOT UNITY, THEN THE +C SUBROUTINE RETURNS THE VECTOR X(J) = FACTOR, J=1,...,N. +C +C THE SUBROUTINE STATEMENT IS +C +C SUBROUTINE INITPT(N,X,NPROB,FACTOR) +C +C WHERE +C +C N IS A POSITIVE INTEGER INPUT VARIABLE. +C +C X IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE STANDARD +C STARTING POINT FOR PROBLEM NPROB MULTIPLIED BY FACTOR. +C +C NPROB IS A POSITIVE INTEGER INPUT VARIABLE WHICH DEFINES THE +C NUMBER OF THE PROBLEM. NPROB MUST NOT EXCEED 14. +C +C FACTOR IS AN INPUT VARIABLE WHICH SPECIFIES THE MULTIPLE OF +C THE STANDARD STARTING POINT. IF FACTOR IS UNITY, NO +C MULTIPLICATION IS PERFORMED. +C +C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. +C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE +C +C ********** + INTEGER IVAR,J + DOUBLE PRECISION C1,H,HALF,ONE,THREE,TJ,ZERO + DOUBLE PRECISION DFLOAT + DATA ZERO,HALF,ONE,THREE,C1 /0.0D0,5.0D-1,1.0D0,3.0D0,1.2D0/ + DFLOAT(IVAR) = IVAR +C +C SELECTION OF INITIAL POINT. +C + GO TO (10,20,30,40,50,60,80,100,120,120,140,160,180,180), NPROB +C +C ROSENBROCK FUNCTION. +C + 10 CONTINUE + X(1) = -C1 + X(2) = ONE + GO TO 200 +C +C POWELL SINGULAR FUNCTION. +C + 20 CONTINUE + X(1) = THREE + X(2) = -ONE + X(3) = ZERO + X(4) = ONE + GO TO 200 +C +C POWELL BADLY SCALED FUNCTION. +C + 30 CONTINUE + X(1) = ZERO + X(2) = ONE + GO TO 200 +C +C WOOD FUNCTION. +C + 40 CONTINUE + X(1) = -THREE + X(2) = -ONE + X(3) = -THREE + X(4) = -ONE + GO TO 200 +C +C HELICAL VALLEY FUNCTION. +C + 50 CONTINUE + X(1) = -ONE + X(2) = ZERO + X(3) = ZERO + GO TO 200 +C +C WATSON FUNCTION. +C + 60 CONTINUE + DO 70 J = 1, N + X(J) = ZERO + 70 CONTINUE + GO TO 200 +C +C CHEBYQUAD FUNCTION. +C + 80 CONTINUE + H = ONE/DFLOAT(N+1) + DO 90 J = 1, N + X(J) = DFLOAT(J)*H + 90 CONTINUE + GO TO 200 +C +C BROWN ALMOST-LINEAR FUNCTION. +C + 100 CONTINUE + DO 110 J = 1, N + X(J) = HALF + 110 CONTINUE + GO TO 200 +C +C DISCRETE BOUNDARY VALUE AND INTEGRAL EQUATION FUNCTIONS. +C + 120 CONTINUE + H = ONE/DFLOAT(N+1) + DO 130 J = 1, N + TJ = DFLOAT(J)*H + X(J) = TJ*(TJ - ONE) + 130 CONTINUE + GO TO 200 +C +C TRIGONOMETRIC FUNCTION. +C + 140 CONTINUE + H = ONE/DFLOAT(N) + DO 150 J = 1, N + X(J) = H + 150 CONTINUE + GO TO 200 +C +C VARIABLY DIMENSIONED FUNCTION. +C + 160 CONTINUE + H = ONE/DFLOAT(N) + DO 170 J = 1, N + X(J) = ONE - DFLOAT(J)*H + 170 CONTINUE + GO TO 200 +C +C BROYDEN TRIDIAGONAL AND BANDED FUNCTIONS. +C + 180 CONTINUE + DO 190 J = 1, N + X(J) = -ONE + 190 CONTINUE + 200 CONTINUE +C +C COMPUTE MULTIPLE OF INITIAL POINT. +C + IF (FACTOR .EQ. ONE) GO TO 250 + IF (NPROB .EQ. 6) GO TO 220 + DO 210 J = 1, N + X(J) = FACTOR*X(J) + 210 CONTINUE + GO TO 240 + 220 CONTINUE + DO 230 J = 1, N + X(J) = FACTOR + 230 CONTINUE + 240 CONTINUE + 250 CONTINUE + RETURN +C +C LAST CARD OF SUBROUTINE INITPT. +C + END diff --git a/ex/file16 b/ex/file16 new file mode 100644 index 0000000..165efe3 --- /dev/null +++ b/ex/file16 @@ -0,0 +1,881 @@ +C ********** +C +C THIS PROGRAM TESTS CODES FOR THE SOLUTION OF N NONLINEAR +C EQUATIONS IN N VARIABLES. IT CONSISTS OF A DRIVER AND AN +C INTERFACE SUBROUTINE FCN. THE DRIVER READS IN DATA, CALLS THE +C NONLINEAR EQUATION SOLVER, AND FINALLY PRINTS OUT INFORMATION +C ON THE PERFORMANCE OF THE SOLVER. THIS IS ONLY A SAMPLE DRIVER, +C MANY OTHER DRIVERS ARE POSSIBLE. THE INTERFACE SUBROUTINE FCN +C IS NECESSARY TO TAKE INTO ACCOUNT THE FORMS OF CALLING +C SEQUENCES USED BY THE FUNCTION AND JACOBIAN SUBROUTINES IN +C THE VARIOUS NONLINEAR EQUATION SOLVERS. +C +C SUBPROGRAMS CALLED +C +C USER-SUPPLIED ...... FCN +C +C MINPACK-SUPPLIED ... DPMPAR,ENORM,HYBRJ1,INITPT,VECFCN +C +C FORTRAN-SUPPLIED ... DSQRT +C +C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. +C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE +C +C ********** + INTEGER I,IC,INFO,K,LDFJAC,LWA,N,NFEV,NJEV,NPROB,NREAD,NTRIES, + 1 NWRITE + INTEGER NA(60),NF(60),NJ(60),NP(60),NX(60) + DOUBLE PRECISION FACTOR,FNORM1,FNORM2,ONE,TEN,TOL + DOUBLE PRECISION FNM(60),FJAC(40,40),FVEC(40),WA(1060),X(40) + DOUBLE PRECISION DPMPAR,ENORM + EXTERNAL FCN + COMMON /REFNUM/ NPROB,NFEV,NJEV +C +C LOGICAL INPUT UNIT IS ASSUMED TO BE NUMBER 5. +C LOGICAL OUTPUT UNIT IS ASSUMED TO BE NUMBER 6. +C + DATA NREAD,NWRITE /5,6/ +C + DATA ONE,TEN /1.0D0,1.0D1/ + TOL = DSQRT(DPMPAR(1)) + LDFJAC = 40 + LWA = 1060 + IC = 0 + 10 CONTINUE + READ (NREAD,50) NPROB,N,NTRIES + IF (NPROB .LE. 0) GO TO 30 + FACTOR = ONE + DO 20 K = 1, NTRIES + IC = IC + 1 + CALL INITPT(N,X,NPROB,FACTOR) + CALL VECFCN(N,X,FVEC,NPROB) + FNORM1 = ENORM(N,FVEC) + WRITE (NWRITE,60) NPROB,N + NFEV = 0 + NJEV = 0 + CALL HYBRJ1(FCN,N,X,FVEC,FJAC,LDFJAC,TOL,INFO,WA,LWA) + FNORM2 = ENORM(N,FVEC) + NP(IC) = NPROB + NA(IC) = N + NF(IC) = NFEV + NJ(IC) = NJEV + NX(IC) = INFO + FNM(IC) = FNORM2 + WRITE (NWRITE,70) + 1 FNORM1,FNORM2,NFEV,NJEV,INFO,(X(I), I = 1, N) + FACTOR = TEN*FACTOR + 20 CONTINUE + GO TO 10 + 30 CONTINUE + WRITE (NWRITE,80) IC + WRITE (NWRITE,90) + DO 40 I = 1, IC + WRITE (NWRITE,100) NP(I),NA(I),NF(I),NJ(I),NX(I),FNM(I) + 40 CONTINUE + STOP + 50 FORMAT (3I5) + 60 FORMAT ( //// 5X, 8H PROBLEM, I5, 5X, 10H DIMENSION, I5, 5X //) + 70 FORMAT (5X, 33H INITIAL L2 NORM OF THE RESIDUALS, D15.7 // 5X, + 1 33H FINAL L2 NORM OF THE RESIDUALS , D15.7 // 5X, + 2 33H NUMBER OF FUNCTION EVALUATIONS , I10 // 5X, + 3 33H NUMBER OF JACOBIAN EVALUATIONS , I10 // 5X, + 4 15H EXIT PARAMETER, 18X, I10 // 5X, + 5 27H FINAL APPROXIMATE SOLUTION // (5X, 5D15.7)) + 80 FORMAT (12H1SUMMARY OF , I3, 16H CALLS TO HYBRJ1 /) + 90 FORMAT (46H NPROB N NFEV NJEV INFO FINAL L2 NORM /) + 100 FORMAT (I4, I6, 2I7, I6, 1X, D15.7) +C +C LAST CARD OF DRIVER. +C + END + SUBROUTINE FCN(N,X,FVEC,FJAC,LDFJAC,IFLAG) + INTEGER N,LDFJAC,IFLAG + DOUBLE PRECISION X(N),FVEC(N),FJAC(LDFJAC,N) +C ********** +C +C THE CALLING SEQUENCE OF FCN SHOULD BE IDENTICAL TO THE +C CALLING SEQUENCE OF THE FUNCTION SUBROUTINE IN THE NONLINEAR +C EQUATION SOLVER. FCN SHOULD ONLY CALL THE TESTING FUNCTION +C AND JACOBIAN SUBROUTINES VECFCN AND VECJAC WITH THE +C APPROPRIATE VALUE OF PROBLEM NUMBER (NPROB). +C +C SUBPROGRAMS CALLED +C +C MINPACK-SUPPLIED ... VECFCN,VECJAC +C +C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. +C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE +C +C ********** + INTEGER NPROB,NFEV,NJEV + COMMON /REFNUM/ NPROB,NFEV,NJEV + IF (IFLAG .EQ. 1) CALL VECFCN(N,X,FVEC,NPROB) + IF (IFLAG .EQ. 2) CALL VECJAC(N,X,FJAC,LDFJAC,NPROB) + IF (IFLAG .EQ. 1) NFEV = NFEV + 1 + IF (IFLAG .EQ. 2) NJEV = NJEV + 1 + RETURN +C +C LAST CARD OF INTERFACE SUBROUTINE FCN. +C + END + SUBROUTINE VECJAC(N,X,FJAC,LDFJAC,NPROB) + INTEGER N,LDFJAC,NPROB + DOUBLE PRECISION X(N),FJAC(LDFJAC,N) +C ********** +C +C SUBROUTINE VECJAC +C +C THIS SUBROUTINE DEFINES THE JACOBIAN MATRICES OF FOURTEEN +C TEST FUNCTIONS. THE PROBLEM DIMENSIONS ARE AS DESCRIBED +C IN THE PROLOGUE COMMENTS OF VECFCN. +C +C THE SUBROUTINE STATEMENT IS +C +C SUBROUTINE VECJAC(N,X,FJAC,LDFJAC,NPROB) +C +C WHERE +C +C N IS A POSITIVE INTEGER VARIABLE. +C +C X IS AN ARRAY OF LENGTH N. +C +C FJAC IS AN N BY N ARRAY. ON OUTPUT FJAC CONTAINS THE +C JACOBIAN MATRIX OF THE NPROB FUNCTION EVALUATED AT X. +C +C LDFJAC IS A POSITIVE INTEGER VARIABLE NOT LESS THAN N +C WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY FJAC. +C +C NPROB IS A POSITIVE INTEGER VARIABLE WHICH DEFINES THE +C NUMBER OF THE PROBLEM. NPROB MUST NOT EXCEED 14. +C +C SUBPROGRAMS CALLED +C +C FORTRAN-SUPPLIED ... DATAN,DCOS,DEXP,DMIN1,DSIN,DSQRT, +C MAX0,MIN0 +C +C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. +C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE +C +C ********** + INTEGER I,IVAR,J,K,K1,K2,ML,MU + DOUBLE PRECISION C1,C3,C4,C5,C6,C9,EIGHT,FIFTN,FIVE,FOUR,H, + * HUNDRD,ONE,PROD,SIX,SUM,SUM1,SUM2,TEMP,TEMP1, + * TEMP2,TEMP3,TEMP4,TEN,THREE,TI,TJ,TK,TPI, + * TWENTY,TWO,ZERO + DOUBLE PRECISION DFLOAT + DATA ZERO,ONE,TWO,THREE,FOUR,FIVE,SIX,EIGHT,TEN,FIFTN,TWENTY, + * HUNDRD + * /0.0D0,1.0D0,2.0D0,3.0D0,4.0D0,5.0D0,6.0D0,8.0D0,1.0D1, + * 1.5D1,2.0D1,1.0D2/ + DATA C1,C3,C4,C5,C6,C9 /1.0D4,2.0D2,2.02D1,1.98D1,1.8D2,2.9D1/ + DFLOAT(IVAR) = IVAR +C +C JACOBIAN ROUTINE SELECTOR. +C + GO TO (10,20,50,60,90,100,200,230,290,320,350,380,420,450), + * NPROB +C +C ROSENBROCK FUNCTION. +C + 10 CONTINUE + FJAC(1,1) = -ONE + FJAC(1,2) = ZERO + FJAC(2,1) = -TWENTY*X(1) + FJAC(2,2) = TEN + GO TO 490 +C +C POWELL SINGULAR FUNCTION. +C + 20 CONTINUE + DO 40 K = 1, 4 + DO 30 J = 1, 4 + FJAC(K,J) = ZERO + 30 CONTINUE + 40 CONTINUE + FJAC(1,1) = ONE + FJAC(1,2) = TEN + FJAC(2,3) = DSQRT(FIVE) + FJAC(2,4) = -FJAC(2,3) + FJAC(3,2) = TWO*(X(2) - TWO*X(3)) + FJAC(3,3) = -TWO*FJAC(3,2) + FJAC(4,1) = TWO*DSQRT(TEN)*(X(1) - X(4)) + FJAC(4,4) = -FJAC(4,1) + GO TO 490 +C +C POWELL BADLY SCALED FUNCTION. +C + 50 CONTINUE + FJAC(1,1) = C1*X(2) + FJAC(1,2) = C1*X(1) + FJAC(2,1) = -DEXP(-X(1)) + FJAC(2,2) = -DEXP(-X(2)) + GO TO 490 +C +C WOOD FUNCTION. +C + 60 CONTINUE + DO 80 K = 1, 4 + DO 70 J = 1, 4 + FJAC(K,J) = ZERO + 70 CONTINUE + 80 CONTINUE + TEMP1 = X(2) - THREE*X(1)**2 + TEMP2 = X(4) - THREE*X(3)**2 + FJAC(1,1) = -C3*TEMP1 + ONE + FJAC(1,2) = -C3*X(1) + FJAC(2,1) = -TWO*C3*X(1) + FJAC(2,2) = C3 + C4 + FJAC(2,4) = C5 + FJAC(3,3) = -C6*TEMP2 + ONE + FJAC(3,4) = -C6*X(3) + FJAC(4,2) = C5 + FJAC(4,3) = -TWO*C6*X(3) + FJAC(4,4) = C6 + C4 + GO TO 490 +C +C HELICAL VALLEY FUNCTION. +C + 90 CONTINUE + TPI = EIGHT*DATAN(ONE) + TEMP = X(1)**2 + X(2)**2 + TEMP1 = TPI*TEMP + TEMP2 = DSQRT(TEMP) + FJAC(1,1) = HUNDRD*X(2)/TEMP1 + FJAC(1,2) = -HUNDRD*X(1)/TEMP1 + FJAC(1,3) = TEN + FJAC(2,1) = TEN*X(1)/TEMP2 + FJAC(2,2) = TEN*X(2)/TEMP2 + FJAC(2,3) = ZERO + FJAC(3,1) = ZERO + FJAC(3,2) = ZERO + FJAC(3,3) = ONE + GO TO 490 +C +C WATSON FUNCTION. +C + 100 CONTINUE + DO 120 K = 1, N + DO 110 J = K, N + FJAC(K,J) = ZERO + 110 CONTINUE + 120 CONTINUE + DO 170 I = 1, 29 + TI = DFLOAT(I)/C9 + SUM1 = ZERO + TEMP = ONE + DO 130 J = 2, N + SUM1 = SUM1 + DFLOAT(J-1)*TEMP*X(J) + TEMP = TI*TEMP + 130 CONTINUE + SUM2 = ZERO + TEMP = ONE + DO 140 J = 1, N + SUM2 = SUM2 + TEMP*X(J) + TEMP = TI*TEMP + 140 CONTINUE + TEMP1 = TWO*(SUM1 - SUM2**2 - ONE) + TEMP2 = TWO*SUM2 + TEMP = TI**2 + TK = ONE + DO 160 K = 1, N + TJ = TK + DO 150 J = K, N + FJAC(K,J) = FJAC(K,J) + * + TJ + * *((DFLOAT(K-1)/TI - TEMP2) + * *(DFLOAT(J-1)/TI - TEMP2) - TEMP1) + TJ = TI*TJ + 150 CONTINUE + TK = TEMP*TK + 160 CONTINUE + 170 CONTINUE + FJAC(1,1) = FJAC(1,1) + SIX*X(1)**2 - TWO*X(2) + THREE + FJAC(1,2) = FJAC(1,2) - TWO*X(1) + FJAC(2,2) = FJAC(2,2) + ONE + DO 190 K = 1, N + DO 180 J = K, N + FJAC(J,K) = FJAC(K,J) + 180 CONTINUE + 190 CONTINUE + GO TO 490 +C +C CHEBYQUAD FUNCTION. +C + 200 CONTINUE + TK = ONE/DFLOAT(N) + DO 220 J = 1, N + TEMP1 = ONE + TEMP2 = TWO*X(J) - ONE + TEMP = TWO*TEMP2 + TEMP3 = ZERO + TEMP4 = TWO + DO 210 K = 1, N + FJAC(K,J) = TK*TEMP4 + TI = FOUR*TEMP2 + TEMP*TEMP4 - TEMP3 + TEMP3 = TEMP4 + TEMP4 = TI + TI = TEMP*TEMP2 - TEMP1 + TEMP1 = TEMP2 + TEMP2 = TI + 210 CONTINUE + 220 CONTINUE + GO TO 490 +C +C BROWN ALMOST-LINEAR FUNCTION. +C + 230 CONTINUE + PROD = ONE + DO 250 J = 1, N + PROD = X(J)*PROD + DO 240 K = 1, N + FJAC(K,J) = ONE + 240 CONTINUE + FJAC(J,J) = TWO + 250 CONTINUE + DO 280 J = 1, N + TEMP = X(J) + IF (TEMP .NE. ZERO) GO TO 270 + TEMP = ONE + PROD = ONE + DO 260 K = 1, N + IF (K .NE. J) PROD = X(K)*PROD + 260 CONTINUE + 270 CONTINUE + FJAC(N,J) = PROD/TEMP + 280 CONTINUE + GO TO 490 +C +C DISCRETE BOUNDARY VALUE FUNCTION. +C + 290 CONTINUE + H = ONE/DFLOAT(N+1) + DO 310 K = 1, N + TEMP = THREE*(X(K) + DFLOAT(K)*H + ONE)**2 + DO 300 J = 1, N + FJAC(K,J) = ZERO + 300 CONTINUE + FJAC(K,K) = TWO + TEMP*H**2/TWO + IF (K .NE. 1) FJAC(K,K-1) = -ONE + IF (K .NE. N) FJAC(K,K+1) = -ONE + 310 CONTINUE + GO TO 490 +C +C DISCRETE INTEGRAL EQUATION FUNCTION. +C + 320 CONTINUE + H = ONE/DFLOAT(N+1) + DO 340 K = 1, N + TK = DFLOAT(K)*H + DO 330 J = 1, N + TJ = DFLOAT(J)*H + TEMP = THREE*(X(J) + TJ + ONE)**2 + FJAC(K,J) = H*DMIN1(TJ*(ONE-TK),TK*(ONE-TJ))*TEMP/TWO + 330 CONTINUE + FJAC(K,K) = FJAC(K,K) + ONE + 340 CONTINUE + GO TO 490 +C +C TRIGONOMETRIC FUNCTION. +C + 350 CONTINUE + DO 370 J = 1, N + TEMP = DSIN(X(J)) + DO 360 K = 1, N + FJAC(K,J) = TEMP + 360 CONTINUE + FJAC(J,J) = DFLOAT(J+1)*TEMP - DCOS(X(J)) + 370 CONTINUE + GO TO 490 +C +C VARIABLY DIMENSIONED FUNCTION. +C + 380 CONTINUE + SUM = ZERO + DO 390 J = 1, N + SUM = SUM + DFLOAT(J)*(X(J) - ONE) + 390 CONTINUE + TEMP = ONE + SIX*SUM**2 + DO 410 K = 1, N + DO 400 J = K, N + FJAC(K,J) = DFLOAT(K*J)*TEMP + FJAC(J,K) = FJAC(K,J) + 400 CONTINUE + FJAC(K,K) = FJAC(K,K) + ONE + 410 CONTINUE + GO TO 490 +C +C BROYDEN TRIDIAGONAL FUNCTION. +C + 420 CONTINUE + DO 440 K = 1, N + DO 430 J = 1, N + FJAC(K,J) = ZERO + 430 CONTINUE + FJAC(K,K) = THREE - FOUR*X(K) + IF (K .NE. 1) FJAC(K,K-1) = -ONE + IF (K .NE. N) FJAC(K,K+1) = -TWO + 440 CONTINUE + GO TO 490 +C +C BROYDEN BANDED FUNCTION. +C + 450 CONTINUE + ML = 5 + MU = 1 + DO 480 K = 1, N + DO 460 J = 1, N + FJAC(K,J) = ZERO + 460 CONTINUE + K1 = MAX0(1,K-ML) + K2 = MIN0(K+MU,N) + DO 470 J = K1, K2 + IF (J .NE. K) FJAC(K,J) = -(ONE + TWO*X(J)) + 470 CONTINUE + FJAC(K,K) = TWO + FIFTN*X(K)**2 + 480 CONTINUE + 490 CONTINUE + RETURN +C +C LAST CARD OF SUBROUTINE VECJAC. +C + END + SUBROUTINE INITPT(N,X,NPROB,FACTOR) + INTEGER N,NPROB + DOUBLE PRECISION FACTOR + DOUBLE PRECISION X(N) +C ********** +C +C SUBROUTINE INITPT +C +C THIS SUBROUTINE SPECIFIES THE STANDARD STARTING POINTS FOR +C THE FUNCTIONS DEFINED BY SUBROUTINE VECFCN. THE SUBROUTINE +C RETURNS IN X A MULTIPLE (FACTOR) OF THE STANDARD STARTING +C POINT. FOR THE SIXTH FUNCTION THE STANDARD STARTING POINT IS +C ZERO, SO IN THIS CASE, IF FACTOR IS NOT UNITY, THEN THE +C SUBROUTINE RETURNS THE VECTOR X(J) = FACTOR, J=1,...,N. +C +C THE SUBROUTINE STATEMENT IS +C +C SUBROUTINE INITPT(N,X,NPROB,FACTOR) +C +C WHERE +C +C N IS A POSITIVE INTEGER INPUT VARIABLE. +C +C X IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE STANDARD +C STARTING POINT FOR PROBLEM NPROB MULTIPLIED BY FACTOR. +C +C NPROB IS A POSITIVE INTEGER INPUT VARIABLE WHICH DEFINES THE +C NUMBER OF THE PROBLEM. NPROB MUST NOT EXCEED 14. +C +C FACTOR IS AN INPUT VARIABLE WHICH SPECIFIES THE MULTIPLE OF +C THE STANDARD STARTING POINT. IF FACTOR IS UNITY, NO +C MULTIPLICATION IS PERFORMED. +C +C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. +C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE +C +C ********** + INTEGER IVAR,J + DOUBLE PRECISION C1,H,HALF,ONE,THREE,TJ,ZERO + DOUBLE PRECISION DFLOAT + DATA ZERO,HALF,ONE,THREE,C1 /0.0D0,5.0D-1,1.0D0,3.0D0,1.2D0/ + DFLOAT(IVAR) = IVAR +C +C SELECTION OF INITIAL POINT. +C + GO TO (10,20,30,40,50,60,80,100,120,120,140,160,180,180), NPROB +C +C ROSENBROCK FUNCTION. +C + 10 CONTINUE + X(1) = -C1 + X(2) = ONE + GO TO 200 +C +C POWELL SINGULAR FUNCTION. +C + 20 CONTINUE + X(1) = THREE + X(2) = -ONE + X(3) = ZERO + X(4) = ONE + GO TO 200 +C +C POWELL BADLY SCALED FUNCTION. +C + 30 CONTINUE + X(1) = ZERO + X(2) = ONE + GO TO 200 +C +C WOOD FUNCTION. +C + 40 CONTINUE + X(1) = -THREE + X(2) = -ONE + X(3) = -THREE + X(4) = -ONE + GO TO 200 +C +C HELICAL VALLEY FUNCTION. +C + 50 CONTINUE + X(1) = -ONE + X(2) = ZERO + X(3) = ZERO + GO TO 200 +C +C WATSON FUNCTION. +C + 60 CONTINUE + DO 70 J = 1, N + X(J) = ZERO + 70 CONTINUE + GO TO 200 +C +C CHEBYQUAD FUNCTION. +C + 80 CONTINUE + H = ONE/DFLOAT(N+1) + DO 90 J = 1, N + X(J) = DFLOAT(J)*H + 90 CONTINUE + GO TO 200 +C +C BROWN ALMOST-LINEAR FUNCTION. +C + 100 CONTINUE + DO 110 J = 1, N + X(J) = HALF + 110 CONTINUE + GO TO 200 +C +C DISCRETE BOUNDARY VALUE AND INTEGRAL EQUATION FUNCTIONS. +C + 120 CONTINUE + H = ONE/DFLOAT(N+1) + DO 130 J = 1, N + TJ = DFLOAT(J)*H + X(J) = TJ*(TJ - ONE) + 130 CONTINUE + GO TO 200 +C +C TRIGONOMETRIC FUNCTION. +C + 140 CONTINUE + H = ONE/DFLOAT(N) + DO 150 J = 1, N + X(J) = H + 150 CONTINUE + GO TO 200 +C +C VARIABLY DIMENSIONED FUNCTION. +C + 160 CONTINUE + H = ONE/DFLOAT(N) + DO 170 J = 1, N + X(J) = ONE - DFLOAT(J)*H + 170 CONTINUE + GO TO 200 +C +C BROYDEN TRIDIAGONAL AND BANDED FUNCTIONS. +C + 180 CONTINUE + DO 190 J = 1, N + X(J) = -ONE + 190 CONTINUE + 200 CONTINUE +C +C COMPUTE MULTIPLE OF INITIAL POINT. +C + IF (FACTOR .EQ. ONE) GO TO 250 + IF (NPROB .EQ. 6) GO TO 220 + DO 210 J = 1, N + X(J) = FACTOR*X(J) + 210 CONTINUE + GO TO 240 + 220 CONTINUE + DO 230 J = 1, N + X(J) = FACTOR + 230 CONTINUE + 240 CONTINUE + 250 CONTINUE + RETURN +C +C LAST CARD OF SUBROUTINE INITPT. +C + END + SUBROUTINE VECFCN(N,X,FVEC,NPROB) + INTEGER N,NPROB + DOUBLE PRECISION X(N),FVEC(N) +C ********** +C +C SUBROUTINE VECFCN +C +C THIS SUBROUTINE DEFINES FOURTEEN TEST FUNCTIONS. THE FIRST +C FIVE TEST FUNCTIONS ARE OF DIMENSIONS 2,4,2,4,3, RESPECTIVELY, +C WHILE THE REMAINING TEST FUNCTIONS ARE OF VARIABLE DIMENSION +C N FOR ANY N GREATER THAN OR EQUAL TO 1 (PROBLEM 6 IS AN +C EXCEPTION TO THIS, SINCE IT DOES NOT ALLOW N = 1). +C +C THE SUBROUTINE STATEMENT IS +C +C SUBROUTINE VECFCN(N,X,FVEC,NPROB) +C +C WHERE +C +C N IS A POSITIVE INTEGER INPUT VARIABLE. +C +C X IS AN INPUT ARRAY OF LENGTH N. +C +C FVEC IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE NPROB +C FUNCTION VECTOR EVALUATED AT X. +C +C NPROB IS A POSITIVE INTEGER INPUT VARIABLE WHICH DEFINES THE +C NUMBER OF THE PROBLEM. NPROB MUST NOT EXCEED 14. +C +C SUBPROGRAMS CALLED +C +C FORTRAN-SUPPLIED ... DATAN,DCOS,DEXP,DSIGN,DSIN,DSQRT, +C MAX0,MIN0 +C +C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. +C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE +C +C ********** + INTEGER I,IEV,IVAR,J,K,K1,K2,KP1,ML,MU + DOUBLE PRECISION C1,C2,C3,C4,C5,C6,C7,C8,C9,EIGHT,FIVE,H,ONE, + * PROD,SUM,SUM1,SUM2,TEMP,TEMP1,TEMP2,TEN,THREE, + * TI,TJ,TK,TPI,TWO,ZERO + DOUBLE PRECISION DFLOAT + DATA ZERO,ONE,TWO,THREE,FIVE,EIGHT,TEN + * /0.0D0,1.0D0,2.0D0,3.0D0,5.0D0,8.0D0,1.0D1/ + DATA C1,C2,C3,C4,C5,C6,C7,C8,C9 + * /1.0D4,1.0001D0,2.0D2,2.02D1,1.98D1,1.8D2,2.5D-1,5.0D-1, + * 2.9D1/ + DFLOAT(IVAR) = IVAR +C +C PROBLEM SELECTOR. +C + GO TO (10,20,30,40,50,60,120,170,200,220,270,300,330,350), NPROB +C +C ROSENBROCK FUNCTION. +C + 10 CONTINUE + FVEC(1) = ONE - X(1) + FVEC(2) = TEN*(X(2) - X(1)**2) + GO TO 380 +C +C POWELL SINGULAR FUNCTION. +C + 20 CONTINUE + FVEC(1) = X(1) + TEN*X(2) + FVEC(2) = DSQRT(FIVE)*(X(3) - X(4)) + FVEC(3) = (X(2) - TWO*X(3))**2 + FVEC(4) = DSQRT(TEN)*(X(1) - X(4))**2 + GO TO 380 +C +C POWELL BADLY SCALED FUNCTION. +C + 30 CONTINUE + FVEC(1) = C1*X(1)*X(2) - ONE + FVEC(2) = DEXP(-X(1)) + DEXP(-X(2)) - C2 + GO TO 380 +C +C WOOD FUNCTION. +C + 40 CONTINUE + TEMP1 = X(2) - X(1)**2 + TEMP2 = X(4) - X(3)**2 + FVEC(1) = -C3*X(1)*TEMP1 - (ONE - X(1)) + FVEC(2) = C3*TEMP1 + C4*(X(2) - ONE) + C5*(X(4) - ONE) + FVEC(3) = -C6*X(3)*TEMP2 - (ONE - X(3)) + FVEC(4) = C6*TEMP2 + C4*(X(4) - ONE) + C5*(X(2) - ONE) + GO TO 380 +C +C HELICAL VALLEY FUNCTION. +C + 50 CONTINUE + TPI = EIGHT*DATAN(ONE) + TEMP1 = DSIGN(C7,X(2)) + IF (X(1) .GT. ZERO) TEMP1 = DATAN(X(2)/X(1))/TPI + IF (X(1) .LT. ZERO) TEMP1 = DATAN(X(2)/X(1))/TPI + C8 + TEMP2 = DSQRT(X(1)**2+X(2)**2) + FVEC(1) = TEN*(X(3) - TEN*TEMP1) + FVEC(2) = TEN*(TEMP2 - ONE) + FVEC(3) = X(3) + GO TO 380 +C +C WATSON FUNCTION. +C + 60 CONTINUE + DO 70 K = 1, N + FVEC(K) = ZERO + 70 CONTINUE + DO 110 I = 1, 29 + TI = DFLOAT(I)/C9 + SUM1 = ZERO + TEMP = ONE + DO 80 J = 2, N + SUM1 = SUM1 + DFLOAT(J-1)*TEMP*X(J) + TEMP = TI*TEMP + 80 CONTINUE + SUM2 = ZERO + TEMP = ONE + DO 90 J = 1, N + SUM2 = SUM2 + TEMP*X(J) + TEMP = TI*TEMP + 90 CONTINUE + TEMP1 = SUM1 - SUM2**2 - ONE + TEMP2 = TWO*TI*SUM2 + TEMP = ONE/TI + DO 100 K = 1, N + FVEC(K) = FVEC(K) + TEMP*(DFLOAT(K-1) - TEMP2)*TEMP1 + TEMP = TI*TEMP + 100 CONTINUE + 110 CONTINUE + TEMP = X(2) - X(1)**2 - ONE + FVEC(1) = FVEC(1) + X(1)*(ONE - TWO*TEMP) + FVEC(2) = FVEC(2) + TEMP + GO TO 380 +C +C CHEBYQUAD FUNCTION. +C + 120 CONTINUE + DO 130 K = 1, N + FVEC(K) = ZERO + 130 CONTINUE + DO 150 J = 1, N + TEMP1 = ONE + TEMP2 = TWO*X(J) - ONE + TEMP = TWO*TEMP2 + DO 140 I = 1, N + FVEC(I) = FVEC(I) + TEMP2 + TI = TEMP*TEMP2 - TEMP1 + TEMP1 = TEMP2 + TEMP2 = TI + 140 CONTINUE + 150 CONTINUE + TK = ONE/DFLOAT(N) + IEV = -1 + DO 160 K = 1, N + FVEC(K) = TK*FVEC(K) + IF (IEV .GT. 0) FVEC(K) = FVEC(K) + ONE/(DFLOAT(K)**2 - ONE) + IEV = -IEV + 160 CONTINUE + GO TO 380 +C +C BROWN ALMOST-LINEAR FUNCTION. +C + 170 CONTINUE + SUM = -DFLOAT(N+1) + PROD = ONE + DO 180 J = 1, N + SUM = SUM + X(J) + PROD = X(J)*PROD + 180 CONTINUE + DO 190 K = 1, N + FVEC(K) = X(K) + SUM + 190 CONTINUE + FVEC(N) = PROD - ONE + GO TO 380 +C +C DISCRETE BOUNDARY VALUE FUNCTION. +C + 200 CONTINUE + H = ONE/DFLOAT(N+1) + DO 210 K = 1, N + TEMP = (X(K) + DFLOAT(K)*H + ONE)**3 + TEMP1 = ZERO + IF (K .NE. 1) TEMP1 = X(K-1) + TEMP2 = ZERO + IF (K .NE. N) TEMP2 = X(K+1) + FVEC(K) = TWO*X(K) - TEMP1 - TEMP2 + TEMP*H**2/TWO + 210 CONTINUE + GO TO 380 +C +C DISCRETE INTEGRAL EQUATION FUNCTION. +C + 220 CONTINUE + H = ONE/DFLOAT(N+1) + DO 260 K = 1, N + TK = DFLOAT(K)*H + SUM1 = ZERO + DO 230 J = 1, K + TJ = DFLOAT(J)*H + TEMP = (X(J) + TJ + ONE)**3 + SUM1 = SUM1 + TJ*TEMP + 230 CONTINUE + SUM2 = ZERO + KP1 = K + 1 + IF (N .LT. KP1) GO TO 250 + DO 240 J = KP1, N + TJ = DFLOAT(J)*H + TEMP = (X(J) + TJ + ONE)**3 + SUM2 = SUM2 + (ONE - TJ)*TEMP + 240 CONTINUE + 250 CONTINUE + FVEC(K) = X(K) + H*((ONE - TK)*SUM1 + TK*SUM2)/TWO + 260 CONTINUE + GO TO 380 +C +C TRIGONOMETRIC FUNCTION. +C + 270 CONTINUE + SUM = ZERO + DO 280 J = 1, N + FVEC(J) = DCOS(X(J)) + SUM = SUM + FVEC(J) + 280 CONTINUE + DO 290 K = 1, N + FVEC(K) = DFLOAT(N+K) - DSIN(X(K)) - SUM - DFLOAT(K)*FVEC(K) + 290 CONTINUE + GO TO 380 +C +C VARIABLY DIMENSIONED FUNCTION. +C + 300 CONTINUE + SUM = ZERO + DO 310 J = 1, N + SUM = SUM + DFLOAT(J)*(X(J) - ONE) + 310 CONTINUE + TEMP = SUM*(ONE + TWO*SUM**2) + DO 320 K = 1, N + FVEC(K) = X(K) - ONE + DFLOAT(K)*TEMP + 320 CONTINUE + GO TO 380 +C +C BROYDEN TRIDIAGONAL FUNCTION. +C + 330 CONTINUE + DO 340 K = 1, N + TEMP = (THREE - TWO*X(K))*X(K) + TEMP1 = ZERO + IF (K .NE. 1) TEMP1 = X(K-1) + TEMP2 = ZERO + IF (K .NE. N) TEMP2 = X(K+1) + FVEC(K) = TEMP - TEMP1 - TWO*TEMP2 + ONE + 340 CONTINUE + GO TO 380 +C +C BROYDEN BANDED FUNCTION. +C + 350 CONTINUE + ML = 5 + MU = 1 + DO 370 K = 1, N + K1 = MAX0(1,K-ML) + K2 = MIN0(K+MU,N) + TEMP = ZERO + DO 360 J = K1, K2 + IF (J .NE. K) TEMP = TEMP + X(J)*(ONE + X(J)) + 360 CONTINUE + FVEC(K) = X(K)*(TWO + FIVE*X(K)**2) + ONE - TEMP + 370 CONTINUE + 380 CONTINUE + RETURN +C +C LAST CARD OF SUBROUTINE VECFCN. +C + END diff --git a/ex/file17 b/ex/file17 new file mode 100644 index 0000000..e901bac --- /dev/null +++ b/ex/file17 @@ -0,0 +1,1025 @@ +C ********** +C +C THIS PROGRAM TESTS CODES FOR THE LEAST-SQUARES SOLUTION OF +C M NONLINEAR EQUATIONS IN N VARIABLES. IT CONSISTS OF A DRIVER +C AND AN INTERFACE SUBROUTINE FCN. THE DRIVER READS IN DATA, +C CALLS THE NONLINEAR LEAST-SQUARES SOLVER, AND FINALLY PRINTS +C OUT INFORMATION ON THE PERFORMANCE OF THE SOLVER. THIS IS +C ONLY A SAMPLE DRIVER, MANY OTHER DRIVERS ARE POSSIBLE. THE +C INTERFACE SUBROUTINE FCN IS NECESSARY TO TAKE INTO ACCOUNT THE +C FORMS OF CALLING SEQUENCES USED BY THE FUNCTION AND JACOBIAN +C SUBROUTINES IN THE VARIOUS NONLINEAR LEAST-SQUARES SOLVERS. +C +C SUBPROGRAMS CALLED +C +C USER-SUPPLIED ...... FCN +C +C MINPACK-SUPPLIED ... DPMPAR,ENORM,INITPT,LMDER1,SSQFCN +C +C FORTRAN-SUPPLIED ... DSQRT +C +C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. +C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE +C +C ********** + INTEGER I,IC,INFO,K,LDFJAC,LWA,M,N,NFEV,NJEV,NPROB,NREAD,NTRIES, + * NWRITE + INTEGER IWA(40),MA(60),NA(60),NF(60),NJ(60),NP(60),NX(60) + DOUBLE PRECISION FACTOR,FNORM1,FNORM2,ONE,TEN,TOL + DOUBLE PRECISION FJAC(65,40),FNM(60),FVEC(65),WA(265),X(40) + DOUBLE PRECISION DPMPAR,ENORM + EXTERNAL FCN + COMMON /REFNUM/ NPROB,NFEV,NJEV +C +C LOGICAL INPUT UNIT IS ASSUMED TO BE NUMBER 5. +C LOGICAL OUTPUT UNIT IS ASSUMED TO BE NUMBER 6. +C + DATA NREAD,NWRITE /5,6/ +C + DATA ONE,TEN /1.0D0,1.0D1/ + TOL = DSQRT(DPMPAR(1)) + LDFJAC = 65 + LWA = 265 + IC = 0 + 10 CONTINUE + READ (NREAD,50) NPROB,N,M,NTRIES + IF (NPROB .LE. 0) GO TO 30 + FACTOR = ONE + DO 20 K = 1, NTRIES + IC = IC + 1 + CALL INITPT(N,X,NPROB,FACTOR) + CALL SSQFCN(M,N,X,FVEC,NPROB) + FNORM1 = ENORM(M,FVEC) + WRITE (NWRITE,60) NPROB,N,M + NFEV = 0 + NJEV = 0 + CALL LMDER1(FCN,M,N,X,FVEC,FJAC,LDFJAC,TOL,INFO,IWA,WA, + * LWA) + CALL SSQFCN(M,N,X,FVEC,NPROB) + FNORM2 = ENORM(M,FVEC) + NP(IC) = NPROB + NA(IC) = N + MA(IC) = M + NF(IC) = NFEV + NJ(IC) = NJEV + NX(IC) = INFO + FNM(IC) = FNORM2 + WRITE (NWRITE,70) + * FNORM1,FNORM2,NFEV,NJEV,INFO,(X(I), I = 1, N) + FACTOR = TEN*FACTOR + 20 CONTINUE + GO TO 10 + 30 CONTINUE + WRITE (NWRITE,80) IC + WRITE (NWRITE,90) + DO 40 I = 1, IC + WRITE (NWRITE,100) NP(I),NA(I),MA(I),NF(I),NJ(I),NX(I),FNM(I) + 40 CONTINUE + STOP + 50 FORMAT (4I5) + 60 FORMAT ( //// 5X, 8H PROBLEM, I5, 5X, 11H DIMENSIONS, 2I5, 5X // + * ) + 70 FORMAT (5X, 33H INITIAL L2 NORM OF THE RESIDUALS, D15.7 // 5X, + * 33H FINAL L2 NORM OF THE RESIDUALS , D15.7 // 5X, + * 33H NUMBER OF FUNCTION EVALUATIONS , I10 // 5X, + * 33H NUMBER OF JACOBIAN EVALUATIONS , I10 // 5X, + * 15H EXIT PARAMETER, 18X, I10 // 5X, + * 27H FINAL APPROXIMATE SOLUTION // (5X, 5D15.7)) + 80 FORMAT (12H1SUMMARY OF , I3, 16H CALLS TO LMDER1 /) + 90 FORMAT (49H NPROB N M NFEV NJEV INFO FINAL L2 NORM /) + 100 FORMAT (3I5, 3I6, 1X, D15.7) +C +C LAST CARD OF DRIVER. +C + END + SUBROUTINE FCN(M,N,X,FVEC,FJAC,LDFJAC,IFLAG) + INTEGER M,N,LDFJAC,IFLAG + DOUBLE PRECISION X(N),FVEC(M),FJAC(LDFJAC,N) +C ********** +C +C THE CALLING SEQUENCE OF FCN SHOULD BE IDENTICAL TO THE +C CALLING SEQUENCE OF THE FUNCTION SUBROUTINE IN THE NONLINEAR +C LEAST-SQUARES SOLVER. FCN SHOULD ONLY CALL THE TESTING +C FUNCTION AND JACOBIAN SUBROUTINES SSQFCN AND SSQJAC WITH +C THE APPROPRIATE VALUE OF PROBLEM NUMBER (NPROB). +C +C SUBPROGRAMS CALLED +C +C MINPACK-SUPPLIED ... SSQFCN,SSQJAC +C +C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. +C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE +C +C ********** + INTEGER NPROB,NFEV,NJEV + COMMON /REFNUM/ NPROB,NFEV,NJEV + IF (IFLAG .EQ. 1) CALL SSQFCN(M,N,X,FVEC,NPROB) + IF (IFLAG .EQ. 2) CALL SSQJAC(M,N,X,FJAC,LDFJAC,NPROB) + IF (IFLAG .EQ. 1) NFEV = NFEV + 1 + IF (IFLAG .EQ. 2) NJEV = NJEV + 1 + RETURN +C +C LAST CARD OF INTERFACE SUBROUTINE FCN. +C + END + SUBROUTINE SSQJAC(M,N,X,FJAC,LDFJAC,NPROB) + INTEGER M,N,LDFJAC,NPROB + DOUBLE PRECISION X(N),FJAC(LDFJAC,N) +C ********** +C +C SUBROUTINE SSQJAC +C +C THIS SUBROUTINE DEFINES THE JACOBIAN MATRICES OF EIGHTEEN +C NONLINEAR LEAST SQUARES PROBLEMS. THE PROBLEM DIMENSIONS ARE +C AS DESCRIBED IN THE PROLOGUE COMMENTS OF SSQFCN. +C +C THE SUBROUTINE STATEMENT IS +C +C SUBROUTINE SSQJAC(M,N,X,FJAC,LDFJAC,NPROB) +C +C WHERE +C +C M AND N ARE POSITIVE INTEGER INPUT VARIABLES. N MUST NOT +C EXCEED M. +C +C X IS AN INPUT ARRAY OF LENGTH N. +C +C FJAC IS AN M BY N OUTPUT ARRAY WHICH CONTAINS THE JACOBIAN +C MATRIX OF THE NPROB FUNCTION EVALUATED AT X. +C +C LDFJAC IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN M +C WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY FJAC. +C +C NPROB IS A POSITIVE INTEGER VARIABLE WHICH DEFINES THE +C NUMBER OF THE PROBLEM. NPROB MUST NOT EXCEED 18. +C +C SUBPROGRAMS CALLED +C +C FORTRAN-SUPPLIED ... DATAN,DCOS,DEXP,DSIN,DSQRT +C +C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. +C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE +C +C ********** + INTEGER I,IVAR,J,K,MM1,NM1 + DOUBLE PRECISION C14,C20,C29,C45,C100,DIV,DX,EIGHT,FIVE,FOUR, + * ONE,PROD,S2,TEMP,TEN,THREE,TI,TMP1,TMP2,TMP3, + * TMP4,TPI,TWO,ZERO + DOUBLE PRECISION V(11) + DOUBLE PRECISION DFLOAT + DATA ZERO,ONE,TWO,THREE,FOUR,FIVE,EIGHT,TEN,C14,C20,C29,C45,C100 + * /0.0D0,1.0D0,2.0D0,3.0D0,4.0D0,5.0D0,8.0D0,1.0D1,1.4D1, + * 2.0D1,2.9D1,4.5D1,1.0D2/ + DATA V(1),V(2),V(3),V(4),V(5),V(6),V(7),V(8),V(9),V(10),V(11) + * /4.0D0,2.0D0,1.0D0,5.0D-1,2.5D-1,1.67D-1,1.25D-1,1.0D-1, + * 8.33D-2,7.14D-2,6.25D-2/ + DFLOAT(IVAR) = IVAR +C +C JACOBIAN ROUTINE SELECTOR. +C + GO TO (10,40,70,130,140,150,180,190,210,230,250,310,330,350,370, + * 400,460,480), NPROB +C +C LINEAR FUNCTION - FULL RANK. +C + 10 CONTINUE + TEMP = TWO/DFLOAT(M) + DO 30 J = 1, N + DO 20 I = 1, M + FJAC(I,J) = -TEMP + 20 CONTINUE + FJAC(J,J) = FJAC(J,J) + ONE + 30 CONTINUE + GO TO 500 +C +C LINEAR FUNCTION - RANK 1. +C + 40 CONTINUE + DO 60 J = 1, N + DO 50 I = 1, M + FJAC(I,J) = DFLOAT(I)*DFLOAT(J) + 50 CONTINUE + 60 CONTINUE + GO TO 500 +C +C LINEAR FUNCTION - RANK 1 WITH ZERO COLUMNS AND ROWS. +C + 70 CONTINUE + DO 90 J = 1, N + DO 80 I = 1, M + FJAC(I,J) = ZERO + 80 CONTINUE + 90 CONTINUE + NM1 = N - 1 + MM1 = M - 1 + IF (NM1 .LT. 2) GO TO 120 + DO 110 J = 2, NM1 + DO 100 I = 2, MM1 + FJAC(I,J) = DFLOAT(I-1)*DFLOAT(J) + 100 CONTINUE + 110 CONTINUE + 120 CONTINUE + GO TO 500 +C +C ROSENBROCK FUNCTION. +C + 130 CONTINUE + FJAC(1,1) = -C20*X(1) + FJAC(1,2) = TEN + FJAC(2,1) = -ONE + FJAC(2,2) = ZERO + GO TO 500 +C +C HELICAL VALLEY FUNCTION. +C + 140 CONTINUE + TPI = EIGHT*DATAN(ONE) + TEMP = X(1)**2 + X(2)**2 + TMP1 = TPI*TEMP + TMP2 = DSQRT(TEMP) + FJAC(1,1) = C100*X(2)/TMP1 + FJAC(1,2) = -C100*X(1)/TMP1 + FJAC(1,3) = TEN + FJAC(2,1) = TEN*X(1)/TMP2 + FJAC(2,2) = TEN*X(2)/TMP2 + FJAC(2,3) = ZERO + FJAC(3,1) = ZERO + FJAC(3,2) = ZERO + FJAC(3,3) = ONE + GO TO 500 +C +C POWELL SINGULAR FUNCTION. +C + 150 CONTINUE + DO 170 J = 1, 4 + DO 160 I = 1, 4 + FJAC(I,J) = ZERO + 160 CONTINUE + 170 CONTINUE + FJAC(1,1) = ONE + FJAC(1,2) = TEN + FJAC(2,3) = DSQRT(FIVE) + FJAC(2,4) = -FJAC(2,3) + FJAC(3,2) = TWO*(X(2) - TWO*X(3)) + FJAC(3,3) = -TWO*FJAC(3,2) + FJAC(4,1) = TWO*DSQRT(TEN)*(X(1) - X(4)) + FJAC(4,4) = -FJAC(4,1) + GO TO 500 +C +C FREUDENSTEIN AND ROTH FUNCTION. +C + 180 CONTINUE + FJAC(1,1) = ONE + FJAC(1,2) = X(2)*(TEN - THREE*X(2)) - TWO + FJAC(2,1) = ONE + FJAC(2,2) = X(2)*(TWO + THREE*X(2)) - C14 + GO TO 500 +C +C BARD FUNCTION. +C + 190 CONTINUE + DO 200 I = 1, 15 + TMP1 = DFLOAT(I) + TMP2 = DFLOAT(16-I) + TMP3 = TMP1 + IF (I .GT. 8) TMP3 = TMP2 + TMP4 = (X(2)*TMP2 + X(3)*TMP3)**2 + FJAC(I,1) = -ONE + FJAC(I,2) = TMP1*TMP2/TMP4 + FJAC(I,3) = TMP1*TMP3/TMP4 + 200 CONTINUE + GO TO 500 +C +C KOWALIK AND OSBORNE FUNCTION. +C + 210 CONTINUE + DO 220 I = 1, 11 + TMP1 = V(I)*(V(I) + X(2)) + TMP2 = V(I)*(V(I) + X(3)) + X(4) + FJAC(I,1) = -TMP1/TMP2 + FJAC(I,2) = -V(I)*X(1)/TMP2 + FJAC(I,3) = FJAC(I,1)*FJAC(I,2) + FJAC(I,4) = FJAC(I,3)/V(I) + 220 CONTINUE + GO TO 500 +C +C MEYER FUNCTION. +C + 230 CONTINUE + DO 240 I = 1, 16 + TEMP = FIVE*DFLOAT(I) + C45 + X(3) + TMP1 = X(2)/TEMP + TMP2 = DEXP(TMP1) + FJAC(I,1) = TMP2 + FJAC(I,2) = X(1)*TMP2/TEMP + FJAC(I,3) = -TMP1*FJAC(I,2) + 240 CONTINUE + GO TO 500 +C +C WATSON FUNCTION. +C + 250 CONTINUE + DO 280 I = 1, 29 + DIV = DFLOAT(I)/C29 + S2 = ZERO + DX = ONE + DO 260 J = 1, N + S2 = S2 + DX*X(J) + DX = DIV*DX + 260 CONTINUE + TEMP = TWO*DIV*S2 + DX = ONE/DIV + DO 270 J = 1, N + FJAC(I,J) = DX*(DFLOAT(J-1) - TEMP) + DX = DIV*DX + 270 CONTINUE + 280 CONTINUE + DO 300 J = 1, N + DO 290 I = 30, 31 + FJAC(I,J) = ZERO + 290 CONTINUE + 300 CONTINUE + FJAC(30,1) = ONE + FJAC(31,1) = -TWO*X(1) + FJAC(31,2) = ONE + GO TO 500 +C +C BOX 3-DIMENSIONAL FUNCTION. +C + 310 CONTINUE + DO 320 I = 1, M + TEMP = DFLOAT(I) + TMP1 = TEMP/TEN + FJAC(I,1) = -TMP1*DEXP(-TMP1*X(1)) + FJAC(I,2) = TMP1*DEXP(-TMP1*X(2)) + FJAC(I,3) = DEXP(-TEMP) - DEXP(-TMP1) + 320 CONTINUE + GO TO 500 +C +C JENNRICH AND SAMPSON FUNCTION. +C + 330 CONTINUE + DO 340 I = 1, M + TEMP = DFLOAT(I) + FJAC(I,1) = -TEMP*DEXP(TEMP*X(1)) + FJAC(I,2) = -TEMP*DEXP(TEMP*X(2)) + 340 CONTINUE + GO TO 500 +C +C BROWN AND DENNIS FUNCTION. +C + 350 CONTINUE + DO 360 I = 1, M + TEMP = DFLOAT(I)/FIVE + TI = DSIN(TEMP) + TMP1 = X(1) + TEMP*X(2) - DEXP(TEMP) + TMP2 = X(3) + TI*X(4) - DCOS(TEMP) + FJAC(I,1) = TWO*TMP1 + FJAC(I,2) = TEMP*FJAC(I,1) + FJAC(I,3) = TWO*TMP2 + FJAC(I,4) = TI*FJAC(I,3) + 360 CONTINUE + GO TO 500 +C +C CHEBYQUAD FUNCTION. +C + 370 CONTINUE + DX = ONE/DFLOAT(N) + DO 390 J = 1, N + TMP1 = ONE + TMP2 = TWO*X(J) - ONE + TEMP = TWO*TMP2 + TMP3 = ZERO + TMP4 = TWO + DO 380 I = 1, M + FJAC(I,J) = DX*TMP4 + TI = FOUR*TMP2 + TEMP*TMP4 - TMP3 + TMP3 = TMP4 + TMP4 = TI + TI = TEMP*TMP2 - TMP1 + TMP1 = TMP2 + TMP2 = TI + 380 CONTINUE + 390 CONTINUE + GO TO 500 +C +C BROWN ALMOST-LINEAR FUNCTION. +C + 400 CONTINUE + PROD = ONE + DO 420 J = 1, N + PROD = X(J)*PROD + DO 410 I = 1, N + FJAC(I,J) = ONE + 410 CONTINUE + FJAC(J,J) = TWO + 420 CONTINUE + DO 450 J = 1, N + TEMP = X(J) + IF (TEMP .NE. ZERO) GO TO 440 + TEMP = ONE + PROD = ONE + DO 430 K = 1, N + IF (K .NE. J) PROD = X(K)*PROD + 430 CONTINUE + 440 CONTINUE + FJAC(N,J) = PROD/TEMP + 450 CONTINUE + GO TO 500 +C +C OSBORNE 1 FUNCTION. +C + 460 CONTINUE + DO 470 I = 1, 33 + TEMP = TEN*DFLOAT(I-1) + TMP1 = DEXP(-X(4)*TEMP) + TMP2 = DEXP(-X(5)*TEMP) + FJAC(I,1) = -ONE + FJAC(I,2) = -TMP1 + FJAC(I,3) = -TMP2 + FJAC(I,4) = TEMP*X(2)*TMP1 + FJAC(I,5) = TEMP*X(3)*TMP2 + 470 CONTINUE + GO TO 500 +C +C OSBORNE 2 FUNCTION. +C + 480 CONTINUE + DO 490 I = 1, 65 + TEMP = DFLOAT(I-1)/TEN + TMP1 = DEXP(-X(5)*TEMP) + TMP2 = DEXP(-X(6)*(TEMP-X(9))**2) + TMP3 = DEXP(-X(7)*(TEMP-X(10))**2) + TMP4 = DEXP(-X(8)*(TEMP-X(11))**2) + FJAC(I,1) = -TMP1 + FJAC(I,2) = -TMP2 + FJAC(I,3) = -TMP3 + FJAC(I,4) = -TMP4 + FJAC(I,5) = TEMP*X(1)*TMP1 + FJAC(I,6) = X(2)*(TEMP - X(9))**2*TMP2 + FJAC(I,7) = X(3)*(TEMP - X(10))**2*TMP3 + FJAC(I,8) = X(4)*(TEMP - X(11))**2*TMP4 + FJAC(I,9) = -TWO*X(2)*X(6)*(TEMP - X(9))*TMP2 + FJAC(I,10) = -TWO*X(3)*X(7)*(TEMP - X(10))*TMP3 + FJAC(I,11) = -TWO*X(4)*X(8)*(TEMP - X(11))*TMP4 + 490 CONTINUE + 500 CONTINUE + RETURN +C +C LAST CARD OF SUBROUTINE SSQJAC. +C + END + SUBROUTINE INITPT(N,X,NPROB,FACTOR) + INTEGER N,NPROB + DOUBLE PRECISION FACTOR + DOUBLE PRECISION X(N) +C ********** +C +C SUBROUTINE INITPT +C +C THIS SUBROUTINE SPECIFIES THE STANDARD STARTING POINTS FOR THE +C FUNCTIONS DEFINED BY SUBROUTINE SSQFCN. THE SUBROUTINE RETURNS +C IN X A MULTIPLE (FACTOR) OF THE STANDARD STARTING POINT. FOR +C THE 11TH FUNCTION THE STANDARD STARTING POINT IS ZERO, SO IN +C THIS CASE, IF FACTOR IS NOT UNITY, THEN THE SUBROUTINE RETURNS +C THE VECTOR X(J) = FACTOR, J=1,...,N. +C +C THE SUBROUTINE STATEMENT IS +C +C SUBROUTINE INITPT(N,X,NPROB,FACTOR) +C +C WHERE +C +C N IS A POSITIVE INTEGER INPUT VARIABLE. +C +C X IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE STANDARD +C STARTING POINT FOR PROBLEM NPROB MULTIPLIED BY FACTOR. +C +C NPROB IS A POSITIVE INTEGER INPUT VARIABLE WHICH DEFINES THE +C NUMBER OF THE PROBLEM. NPROB MUST NOT EXCEED 18. +C +C FACTOR IS AN INPUT VARIABLE WHICH SPECIFIES THE MULTIPLE OF +C THE STANDARD STARTING POINT. IF FACTOR IS UNITY, NO +C MULTIPLICATION IS PERFORMED. +C +C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. +C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE +C +C ********** + INTEGER IVAR,J + DOUBLE PRECISION C1,C2,C3,C4,C5,C6,C7,C8,C9,C10,C11,C12,C13,C14, + * C15,C16,C17,FIVE,H,HALF,ONE,SEVEN,TEN,THREE, + * TWENTY,TWNTF,TWO,ZERO + DOUBLE PRECISION DFLOAT + DATA ZERO,HALF,ONE,TWO,THREE,FIVE,SEVEN,TEN,TWENTY,TWNTF + * /0.0D0,5.0D-1,1.0D0,2.0D0,3.0D0,5.0D0,7.0D0,1.0D1,2.0D1, + * 2.5D1/ + DATA C1,C2,C3,C4,C5,C6,C7,C8,C9,C10,C11,C12,C13,C14,C15,C16,C17 + * /1.2D0,2.5D-1,3.9D-1,4.15D-1,2.0D-2,4.0D3,2.5D2,3.0D-1, + * 4.0D-1,1.5D0,1.0D-2,1.3D0,6.5D-1,7.0D-1,6.0D-1,4.5D0, + * 5.5D0/ + DFLOAT(IVAR) = IVAR +C +C SELECTION OF INITIAL POINT. +C + GO TO (10,10,10,30,40,50,60,70,80,90,100,120,130,140,150,170, + * 190,200), NPROB +C +C LINEAR FUNCTION - FULL RANK OR RANK 1. +C + 10 CONTINUE + DO 20 J = 1, N + X(J) = ONE + 20 CONTINUE + GO TO 210 +C +C ROSENBROCK FUNCTION. +C + 30 CONTINUE + X(1) = -C1 + X(2) = ONE + GO TO 210 +C +C HELICAL VALLEY FUNCTION. +C + 40 CONTINUE + X(1) = -ONE + X(2) = ZERO + X(3) = ZERO + GO TO 210 +C +C POWELL SINGULAR FUNCTION. +C + 50 CONTINUE + X(1) = THREE + X(2) = -ONE + X(3) = ZERO + X(4) = ONE + GO TO 210 +C +C FREUDENSTEIN AND ROTH FUNCTION. +C + 60 CONTINUE + X(1) = HALF + X(2) = -TWO + GO TO 210 +C +C BARD FUNCTION. +C + 70 CONTINUE + X(1) = ONE + X(2) = ONE + X(3) = ONE + GO TO 210 +C +C KOWALIK AND OSBORNE FUNCTION. +C + 80 CONTINUE + X(1) = C2 + X(2) = C3 + X(3) = C4 + X(4) = C3 + GO TO 210 +C +C MEYER FUNCTION. +C + 90 CONTINUE + X(1) = C5 + X(2) = C6 + X(3) = C7 + GO TO 210 +C +C WATSON FUNCTION. +C + 100 CONTINUE + DO 110 J = 1, N + X(J) = ZERO + 110 CONTINUE + GO TO 210 +C +C BOX 3-DIMENSIONAL FUNCTION. +C + 120 CONTINUE + X(1) = ZERO + X(2) = TEN + X(3) = TWENTY + GO TO 210 +C +C JENNRICH AND SAMPSON FUNCTION. +C + 130 CONTINUE + X(1) = C8 + X(2) = C9 + GO TO 210 +C +C BROWN AND DENNIS FUNCTION. +C + 140 CONTINUE + X(1) = TWNTF + X(2) = FIVE + X(3) = -FIVE + X(4) = -ONE + GO TO 210 +C +C CHEBYQUAD FUNCTION. +C + 150 CONTINUE + H = ONE/DFLOAT(N+1) + DO 160 J = 1, N + X(J) = DFLOAT(J)*H + 160 CONTINUE + GO TO 210 +C +C BROWN ALMOST-LINEAR FUNCTION. +C + 170 CONTINUE + DO 180 J = 1, N + X(J) = HALF + 180 CONTINUE + GO TO 210 +C +C OSBORNE 1 FUNCTION. +C + 190 CONTINUE + X(1) = HALF + X(2) = C10 + X(3) = -ONE + X(4) = C11 + X(5) = C5 + GO TO 210 +C +C OSBORNE 2 FUNCTION. +C + 200 CONTINUE + X(1) = C12 + X(2) = C13 + X(3) = C13 + X(4) = C14 + X(5) = C15 + X(6) = THREE + X(7) = FIVE + X(8) = SEVEN + X(9) = TWO + X(10) = C16 + X(11) = C17 + 210 CONTINUE +C +C COMPUTE MULTIPLE OF INITIAL POINT. +C + IF (FACTOR .EQ. ONE) GO TO 260 + IF (NPROB .EQ. 11) GO TO 230 + DO 220 J = 1, N + X(J) = FACTOR*X(J) + 220 CONTINUE + GO TO 250 + 230 CONTINUE + DO 240 J = 1, N + X(J) = FACTOR + 240 CONTINUE + 250 CONTINUE + 260 CONTINUE + RETURN +C +C LAST CARD OF SUBROUTINE INITPT. +C + END + SUBROUTINE SSQFCN(M,N,X,FVEC,NPROB) + INTEGER M,N,NPROB + DOUBLE PRECISION X(N),FVEC(M) +C ********** +C +C SUBROUTINE SSQFCN +C +C THIS SUBROUTINE DEFINES THE FUNCTIONS OF EIGHTEEN NONLINEAR +C LEAST SQUARES PROBLEMS. THE ALLOWABLE VALUES OF (M,N) FOR +C FUNCTIONS 1,2 AND 3 ARE VARIABLE BUT WITH M .GE. N. +C FOR FUNCTIONS 4,5,6,7,8,9 AND 10 THE VALUES OF (M,N) ARE +C (2,2),(3,3),(4,4),(2,2),(15,3),(11,4) AND (16,3), RESPECTIVELY. +C FUNCTION 11 (WATSON) HAS M = 31 WITH N USUALLY 6 OR 9. +C HOWEVER, ANY N, N = 2,...,31, IS PERMITTED. +C FUNCTIONS 12,13 AND 14 HAVE N = 3,2 AND 4, RESPECTIVELY, BUT +C ALLOW ANY M .GE. N, WITH THE USUAL CHOICES BEING 10,10 AND 20. +C FUNCTION 15 (CHEBYQUAD) ALLOWS M AND N VARIABLE WITH M .GE. N. +C FUNCTION 16 (BROWN) ALLOWS N VARIABLE WITH M = N. +C FOR FUNCTIONS 17 AND 18, THE VALUES OF (M,N) ARE +C (33,5) AND (65,11), RESPECTIVELY. +C +C THE SUBROUTINE STATEMENT IS +C +C SUBROUTINE SSQFCN(M,N,X,FVEC,NPROB) +C +C WHERE +C +C M AND N ARE POSITIVE INTEGER INPUT VARIABLES. N MUST NOT +C EXCEED M. +C +C X IS AN INPUT ARRAY OF LENGTH N. +C +C FVEC IS AN OUTPUT ARRAY OF LENGTH M WHICH CONTAINS THE NPROB +C FUNCTION EVALUATED AT X. +C +C NPROB IS A POSITIVE INTEGER INPUT VARIABLE WHICH DEFINES THE +C NUMBER OF THE PROBLEM. NPROB MUST NOT EXCEED 18. +C +C SUBPROGRAMS CALLED +C +C FORTRAN-SUPPLIED ... DATAN,DCOS,DEXP,DSIN,DSQRT,DSIGN +C +C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. +C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE +C +C ********** + INTEGER I,IEV,IVAR,J,NM1 + DOUBLE PRECISION C13,C14,C29,C45,DIV,DX,EIGHT,FIVE,ONE,PROD,SUM, + * S1,S2,TEMP,TEN,TI,TMP1,TMP2,TMP3,TMP4,TPI,TWO, + * ZERO,ZP25,ZP5 + DOUBLE PRECISION V(11),Y1(15),Y2(11),Y3(16),Y4(33),Y5(65) + DOUBLE PRECISION DFLOAT + DATA ZERO,ZP25,ZP5,ONE,TWO,FIVE,EIGHT,TEN,C13,C14,C29,C45 + * /0.0D0,2.5D-1,5.0D-1,1.0D0,2.0D0,5.0D0,8.0D0,1.0D1,1.3D1, + * 1.4D1,2.9D1,4.5D1/ + DATA V(1),V(2),V(3),V(4),V(5),V(6),V(7),V(8),V(9),V(10),V(11) + * /4.0D0,2.0D0,1.0D0,5.0D-1,2.5D-1,1.67D-1,1.25D-1,1.0D-1, + * 8.33D-2,7.14D-2,6.25D-2/ + DATA Y1(1),Y1(2),Y1(3),Y1(4),Y1(5),Y1(6),Y1(7),Y1(8),Y1(9), + * Y1(10),Y1(11),Y1(12),Y1(13),Y1(14),Y1(15) + * /1.4D-1,1.8D-1,2.2D-1,2.5D-1,2.9D-1,3.2D-1,3.5D-1,3.9D-1, + * 3.7D-1,5.8D-1,7.3D-1,9.6D-1,1.34D0,2.1D0,4.39D0/ + DATA Y2(1),Y2(2),Y2(3),Y2(4),Y2(5),Y2(6),Y2(7),Y2(8),Y2(9), + * Y2(10),Y2(11) + * /1.957D-1,1.947D-1,1.735D-1,1.6D-1,8.44D-2,6.27D-2,4.56D-2, + * 3.42D-2,3.23D-2,2.35D-2,2.46D-2/ + DATA Y3(1),Y3(2),Y3(3),Y3(4),Y3(5),Y3(6),Y3(7),Y3(8),Y3(9), + * Y3(10),Y3(11),Y3(12),Y3(13),Y3(14),Y3(15),Y3(16) + * /3.478D4,2.861D4,2.365D4,1.963D4,1.637D4,1.372D4,1.154D4, + * 9.744D3,8.261D3,7.03D3,6.005D3,5.147D3,4.427D3,3.82D3, + * 3.307D3,2.872D3/ + DATA Y4(1),Y4(2),Y4(3),Y4(4),Y4(5),Y4(6),Y4(7),Y4(8),Y4(9), + * Y4(10),Y4(11),Y4(12),Y4(13),Y4(14),Y4(15),Y4(16),Y4(17), + * Y4(18),Y4(19),Y4(20),Y4(21),Y4(22),Y4(23),Y4(24),Y4(25), + * Y4(26),Y4(27),Y4(28),Y4(29),Y4(30),Y4(31),Y4(32),Y4(33) + * /8.44D-1,9.08D-1,9.32D-1,9.36D-1,9.25D-1,9.08D-1,8.81D-1, + * 8.5D-1,8.18D-1,7.84D-1,7.51D-1,7.18D-1,6.85D-1,6.58D-1, + * 6.28D-1,6.03D-1,5.8D-1,5.58D-1,5.38D-1,5.22D-1,5.06D-1, + * 4.9D-1,4.78D-1,4.67D-1,4.57D-1,4.48D-1,4.38D-1,4.31D-1, + * 4.24D-1,4.2D-1,4.14D-1,4.11D-1,4.06D-1/ + DATA Y5(1),Y5(2),Y5(3),Y5(4),Y5(5),Y5(6),Y5(7),Y5(8),Y5(9), + * Y5(10),Y5(11),Y5(12),Y5(13),Y5(14),Y5(15),Y5(16),Y5(17), + * Y5(18),Y5(19),Y5(20),Y5(21),Y5(22),Y5(23),Y5(24),Y5(25), + * Y5(26),Y5(27),Y5(28),Y5(29),Y5(30),Y5(31),Y5(32),Y5(33), + * Y5(34),Y5(35),Y5(36),Y5(37),Y5(38),Y5(39),Y5(40),Y5(41), + * Y5(42),Y5(43),Y5(44),Y5(45),Y5(46),Y5(47),Y5(48),Y5(49), + * Y5(50),Y5(51),Y5(52),Y5(53),Y5(54),Y5(55),Y5(56),Y5(57), + * Y5(58),Y5(59),Y5(60),Y5(61),Y5(62),Y5(63),Y5(64),Y5(65) + * /1.366D0,1.191D0,1.112D0,1.013D0,9.91D-1,8.85D-1,8.31D-1, + * 8.47D-1,7.86D-1,7.25D-1,7.46D-1,6.79D-1,6.08D-1,6.55D-1, + * 6.16D-1,6.06D-1,6.02D-1,6.26D-1,6.51D-1,7.24D-1,6.49D-1, + * 6.49D-1,6.94D-1,6.44D-1,6.24D-1,6.61D-1,6.12D-1,5.58D-1, + * 5.33D-1,4.95D-1,5.0D-1,4.23D-1,3.95D-1,3.75D-1,3.72D-1, + * 3.91D-1,3.96D-1,4.05D-1,4.28D-1,4.29D-1,5.23D-1,5.62D-1, + * 6.07D-1,6.53D-1,6.72D-1,7.08D-1,6.33D-1,6.68D-1,6.45D-1, + * 6.32D-1,5.91D-1,5.59D-1,5.97D-1,6.25D-1,7.39D-1,7.1D-1, + * 7.29D-1,7.2D-1,6.36D-1,5.81D-1,4.28D-1,2.92D-1,1.62D-1, + * 9.8D-2,5.4D-2/ + DFLOAT(IVAR) = IVAR +C +C FUNCTION ROUTINE SELECTOR. +C + GO TO (10,40,70,110,120,130,140,150,170,190,210,250,270,290,310, + * 360,390,410), NPROB +C +C LINEAR FUNCTION - FULL RANK. +C + 10 CONTINUE + SUM = ZERO + DO 20 J = 1, N + SUM = SUM + X(J) + 20 CONTINUE + TEMP = TWO*SUM/DFLOAT(M) + ONE + DO 30 I = 1, M + FVEC(I) = -TEMP + IF (I .LE. N) FVEC(I) = FVEC(I) + X(I) + 30 CONTINUE + GO TO 430 +C +C LINEAR FUNCTION - RANK 1. +C + 40 CONTINUE + SUM = ZERO + DO 50 J = 1, N + SUM = SUM + DFLOAT(J)*X(J) + 50 CONTINUE + DO 60 I = 1, M + FVEC(I) = DFLOAT(I)*SUM - ONE + 60 CONTINUE + GO TO 430 +C +C LINEAR FUNCTION - RANK 1 WITH ZERO COLUMNS AND ROWS. +C + 70 CONTINUE + SUM = ZERO + NM1 = N - 1 + IF (NM1 .LT. 2) GO TO 90 + DO 80 J = 2, NM1 + SUM = SUM + DFLOAT(J)*X(J) + 80 CONTINUE + 90 CONTINUE + DO 100 I = 1, M + FVEC(I) = DFLOAT(I-1)*SUM - ONE + 100 CONTINUE + FVEC(M) = -ONE + GO TO 430 +C +C ROSENBROCK FUNCTION. +C + 110 CONTINUE + FVEC(1) = TEN*(X(2) - X(1)**2) + FVEC(2) = ONE - X(1) + GO TO 430 +C +C HELICAL VALLEY FUNCTION. +C + 120 CONTINUE + TPI = EIGHT*DATAN(ONE) + TMP1 = DSIGN(ZP25,X(2)) + IF (X(1) .GT. ZERO) TMP1 = DATAN(X(2)/X(1))/TPI + IF (X(1) .LT. ZERO) TMP1 = DATAN(X(2)/X(1))/TPI + ZP5 + TMP2 = DSQRT(X(1)**2+X(2)**2) + FVEC(1) = TEN*(X(3) - TEN*TMP1) + FVEC(2) = TEN*(TMP2 - ONE) + FVEC(3) = X(3) + GO TO 430 +C +C POWELL SINGULAR FUNCTION. +C + 130 CONTINUE + FVEC(1) = X(1) + TEN*X(2) + FVEC(2) = DSQRT(FIVE)*(X(3) - X(4)) + FVEC(3) = (X(2) - TWO*X(3))**2 + FVEC(4) = DSQRT(TEN)*(X(1) - X(4))**2 + GO TO 430 +C +C FREUDENSTEIN AND ROTH FUNCTION. +C + 140 CONTINUE + FVEC(1) = -C13 + X(1) + ((FIVE - X(2))*X(2) - TWO)*X(2) + FVEC(2) = -C29 + X(1) + ((ONE + X(2))*X(2) - C14)*X(2) + GO TO 430 +C +C BARD FUNCTION. +C + 150 CONTINUE + DO 160 I = 1, 15 + TMP1 = DFLOAT(I) + TMP2 = DFLOAT(16-I) + TMP3 = TMP1 + IF (I .GT. 8) TMP3 = TMP2 + FVEC(I) = Y1(I) - (X(1) + TMP1/(X(2)*TMP2 + X(3)*TMP3)) + 160 CONTINUE + GO TO 430 +C +C KOWALIK AND OSBORNE FUNCTION. +C + 170 CONTINUE + DO 180 I = 1, 11 + TMP1 = V(I)*(V(I) + X(2)) + TMP2 = V(I)*(V(I) + X(3)) + X(4) + FVEC(I) = Y2(I) - X(1)*TMP1/TMP2 + 180 CONTINUE + GO TO 430 +C +C MEYER FUNCTION. +C + 190 CONTINUE + DO 200 I = 1, 16 + TEMP = FIVE*DFLOAT(I) + C45 + X(3) + TMP1 = X(2)/TEMP + TMP2 = DEXP(TMP1) + FVEC(I) = X(1)*TMP2 - Y3(I) + 200 CONTINUE + GO TO 430 +C +C WATSON FUNCTION. +C + 210 CONTINUE + DO 240 I = 1, 29 + DIV = DFLOAT(I)/C29 + S1 = ZERO + DX = ONE + DO 220 J = 2, N + S1 = S1 + DFLOAT(J-1)*DX*X(J) + DX = DIV*DX + 220 CONTINUE + S2 = ZERO + DX = ONE + DO 230 J = 1, N + S2 = S2 + DX*X(J) + DX = DIV*DX + 230 CONTINUE + FVEC(I) = S1 - S2**2 - ONE + 240 CONTINUE + FVEC(30) = X(1) + FVEC(31) = X(2) - X(1)**2 - ONE + GO TO 430 +C +C BOX 3-DIMENSIONAL FUNCTION. +C + 250 CONTINUE + DO 260 I = 1, M + TEMP = DFLOAT(I) + TMP1 = TEMP/TEN + FVEC(I) = DEXP(-TMP1*X(1)) - DEXP(-TMP1*X(2)) + * + (DEXP(-TEMP) - DEXP(-TMP1))*X(3) + 260 CONTINUE + GO TO 430 +C +C JENNRICH AND SAMPSON FUNCTION. +C + 270 CONTINUE + DO 280 I = 1, M + TEMP = DFLOAT(I) + FVEC(I) = TWO + TWO*TEMP - DEXP(TEMP*X(1)) - DEXP(TEMP*X(2)) + 280 CONTINUE + GO TO 430 +C +C BROWN AND DENNIS FUNCTION. +C + 290 CONTINUE + DO 300 I = 1, M + TEMP = DFLOAT(I)/FIVE + TMP1 = X(1) + TEMP*X(2) - DEXP(TEMP) + TMP2 = X(3) + DSIN(TEMP)*X(4) - DCOS(TEMP) + FVEC(I) = TMP1**2 + TMP2**2 + 300 CONTINUE + GO TO 430 +C +C CHEBYQUAD FUNCTION. +C + 310 CONTINUE + DO 320 I = 1, M + FVEC(I) = ZERO + 320 CONTINUE + DO 340 J = 1, N + TMP1 = ONE + TMP2 = TWO*X(J) - ONE + TEMP = TWO*TMP2 + DO 330 I = 1, M + FVEC(I) = FVEC(I) + TMP2 + TI = TEMP*TMP2 - TMP1 + TMP1 = TMP2 + TMP2 = TI + 330 CONTINUE + 340 CONTINUE + DX = ONE/DFLOAT(N) + IEV = -1 + DO 350 I = 1, M + FVEC(I) = DX*FVEC(I) + IF (IEV .GT. 0) FVEC(I) = FVEC(I) + ONE/(DFLOAT(I)**2 - ONE) + IEV = -IEV + 350 CONTINUE + GO TO 430 +C +C BROWN ALMOST-LINEAR FUNCTION. +C + 360 CONTINUE + SUM = -DFLOAT(N+1) + PROD = ONE + DO 370 J = 1, N + SUM = SUM + X(J) + PROD = X(J)*PROD + 370 CONTINUE + DO 380 I = 1, N + FVEC(I) = X(I) + SUM + 380 CONTINUE + FVEC(N) = PROD - ONE + GO TO 430 +C +C OSBORNE 1 FUNCTION. +C + 390 CONTINUE + DO 400 I = 1, 33 + TEMP = TEN*DFLOAT(I-1) + TMP1 = DEXP(-X(4)*TEMP) + TMP2 = DEXP(-X(5)*TEMP) + FVEC(I) = Y4(I) - (X(1) + X(2)*TMP1 + X(3)*TMP2) + 400 CONTINUE + GO TO 430 +C +C OSBORNE 2 FUNCTION. +C + 410 CONTINUE + DO 420 I = 1, 65 + TEMP = DFLOAT(I-1)/TEN + TMP1 = DEXP(-X(5)*TEMP) + TMP2 = DEXP(-X(6)*(TEMP-X(9))**2) + TMP3 = DEXP(-X(7)*(TEMP-X(10))**2) + TMP4 = DEXP(-X(8)*(TEMP-X(11))**2) + FVEC(I) = Y5(I) + * - (X(1)*TMP1 + X(2)*TMP2 + X(3)*TMP3 + X(4)*TMP4) + 420 CONTINUE + 430 CONTINUE + RETURN +C +C LAST CARD OF SUBROUTINE SSQFCN. +C + END diff --git a/ex/file18 b/ex/file18 new file mode 100644 index 0000000..7497b7f --- /dev/null +++ b/ex/file18 @@ -0,0 +1,1036 @@ +C ********** +C +C THIS PROGRAM TESTS CODES FOR THE LEAST-SQUARES SOLUTION OF +C M NONLINEAR EQUATIONS IN N VARIABLES. IT CONSISTS OF A DRIVER +C AND AN INTERFACE SUBROUTINE FCN. THE DRIVER READS IN DATA, +C CALLS THE NONLINEAR LEAST-SQUARES SOLVER, AND FINALLY PRINTS +C OUT INFORMATION ON THE PERFORMANCE OF THE SOLVER. THIS IS +C ONLY A SAMPLE DRIVER, MANY OTHER DRIVERS ARE POSSIBLE. THE +C INTERFACE SUBROUTINE FCN IS NECESSARY TO TAKE INTO ACCOUNT THE +C FORMS OF CALLING SEQUENCES USED BY THE FUNCTION AND JACOBIAN +C SUBROUTINES IN THE VARIOUS NONLINEAR LEAST-SQUARES SOLVERS. +C +C SUBPROGRAMS CALLED +C +C USER-SUPPLIED ...... FCN +C +C MINPACK-SUPPLIED ... DPMPAR,ENORM,INITPT,LMSTR1,SSQFCN +C +C FORTRAN-SUPPLIED ... DSQRT +C +C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. +C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE +C +C ********** + INTEGER I,IC,INFO,K,LDFJAC,LWA,M,N,NFEV,NJEV,NPROB,NREAD,NTRIES, + * NWRITE + INTEGER IWA(40),MA(60),NA(60),NF(60),NJ(60),NP(60),NX(60) + DOUBLE PRECISION FACTOR,FNORM1,FNORM2,ONE,TEN,TOL + DOUBLE PRECISION FJAC(40,40),FNM(60),FVEC(65),WA(265),X(40) + DOUBLE PRECISION DPMPAR,ENORM + EXTERNAL FCN + COMMON /REFNUM/ NPROB,NFEV,NJEV +C +C LOGICAL INPUT UNIT IS ASSUMED TO BE NUMBER 5. +C LOGICAL OUTPUT UNIT IS ASSUMED TO BE NUMBER 6. +C + DATA NREAD,NWRITE /5,6/ +C + DATA ONE,TEN /1.0D0,1.0D1/ + TOL = DSQRT(DPMPAR(1)) + LDFJAC = 40 + LWA = 265 + IC = 0 + 10 CONTINUE + READ (NREAD,50) NPROB,N,M,NTRIES + IF (NPROB .LE. 0) GO TO 30 + FACTOR = ONE + DO 20 K = 1, NTRIES + IC = IC + 1 + CALL INITPT(N,X,NPROB,FACTOR) + CALL SSQFCN(M,N,X,FVEC,NPROB) + FNORM1 = ENORM(M,FVEC) + WRITE (NWRITE,60) NPROB,N,M + NFEV = 0 + NJEV = 0 + CALL LMSTR1(FCN,M,N,X,FVEC,FJAC,LDFJAC,TOL,INFO,IWA,WA, + * LWA) + CALL SSQFCN(M,N,X,FVEC,NPROB) + FNORM2 = ENORM(M,FVEC) + NP(IC) = NPROB + NA(IC) = N + MA(IC) = M + NF(IC) = NFEV + NJ(IC) = NJEV + NX(IC) = INFO + FNM(IC) = FNORM2 + WRITE (NWRITE,70) + * FNORM1,FNORM2,NFEV,NJEV,INFO,(X(I), I = 1, N) + FACTOR = TEN*FACTOR + 20 CONTINUE + GO TO 10 + 30 CONTINUE + WRITE (NWRITE,80) IC + WRITE (NWRITE,90) + DO 40 I = 1, IC + WRITE (NWRITE,100) NP(I),NA(I),MA(I),NF(I),NJ(I),NX(I),FNM(I) + 40 CONTINUE + STOP + 50 FORMAT (4I5) + 60 FORMAT ( //// 5X, 8H PROBLEM, I5, 5X, 11H DIMENSIONS, 2I5, 5X // + * ) + 70 FORMAT (5X, 33H INITIAL L2 NORM OF THE RESIDUALS, D15.7 // 5X, + * 33H FINAL L2 NORM OF THE RESIDUALS , D15.7 // 5X, + * 33H NUMBER OF FUNCTION EVALUATIONS , I10 // 5X, + * 33H NUMBER OF JACOBIAN EVALUATIONS , I10 // 5X, + * 15H EXIT PARAMETER, 18X, I10 // 5X, + * 27H FINAL APPROXIMATE SOLUTION // (5X, 5D15.7)) + 80 FORMAT (12H1SUMMARY OF , I3, 16H CALLS TO LMSTR1 /) + 90 FORMAT (49H NPROB N M NFEV NJEV INFO FINAL L2 NORM /) + 100 FORMAT (3I5, 3I6, 1X, D15.7) +C +C LAST CARD OF DRIVER. +C + END + SUBROUTINE FCN(M,N,X,FVEC,FJROW,IFLAG) + INTEGER M,N,IFLAG + DOUBLE PRECISION X(N),FVEC(M),FJROW(N) +C ********** +C +C THE CALLING SEQUENCE OF FCN SHOULD BE IDENTICAL TO THE +C CALLING SEQUENCE OF THE FUNCTION SUBROUTINE IN THE NONLINEAR +C LEAST SQUARES SOLVER. IF IFLAG = 1, FCN SHOULD ONLY CALL THE +C TESTING FUNCTION SUBROUTINE SSQFCN. IF IFLAG = I, I .GE. 2, +C FCN SHOULD ONLY CALL SUBROUTINE SSQJAC TO CALCULATE THE +C (I-1)-ST ROW OF THE JACOBIAN. (THE SSQJAC SUBROUTINE PROVIDED +C HERE FOR TESTING PURPOSES CALCULATES THE ENTIRE JACOBIAN +C MATRIX AND IS THEREFORE CALLED ONLY WHEN IFLAG = 2.) EACH +C CALL TO SSQFCN OR SSQJAC SHOULD SPECIFY THE APPROPRIATE +C VALUE OF PROBLEM NUMBER (NPROB). +C +C SUBPROGRAMS CALLED +C +C MINPACK-SUPPLIED ... SSQFCN,SSQJAC +C +C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. +C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE +C +C ********** + INTEGER NPROB,NFEV,NJEV,J + DOUBLE PRECISION TEMP(65,40) + COMMON /REFNUM/ NPROB,NFEV,NJEV + IF (IFLAG .EQ. 1) CALL SSQFCN(M,N,X,FVEC,NPROB) + IF (IFLAG .EQ. 2) CALL SSQJAC(M,N,X,TEMP,65,NPROB) + IF (IFLAG .EQ. 1) NFEV = NFEV + 1 + IF (IFLAG .EQ. 2) NJEV = NJEV + 1 + IF (IFLAG .EQ. 1) GO TO 120 + DO 110 J = 1, N + FJROW(J) = TEMP(IFLAG-1,J) + 110 CONTINUE + 120 CONTINUE + RETURN +C +C LAST CARD OF INTERFACE SUBROUTINE FCN. +C + END + SUBROUTINE SSQJAC(M,N,X,FJAC,LDFJAC,NPROB) + INTEGER M,N,LDFJAC,NPROB + DOUBLE PRECISION X(N),FJAC(LDFJAC,N) +C ********** +C +C SUBROUTINE SSQJAC +C +C THIS SUBROUTINE DEFINES THE JACOBIAN MATRICES OF EIGHTEEN +C NONLINEAR LEAST SQUARES PROBLEMS. THE PROBLEM DIMENSIONS ARE +C AS DESCRIBED IN THE PROLOGUE COMMENTS OF SSQFCN. +C +C THE SUBROUTINE STATEMENT IS +C +C SUBROUTINE SSQJAC(M,N,X,FJAC,LDFJAC,NPROB) +C +C WHERE +C +C M AND N ARE POSITIVE INTEGER INPUT VARIABLES. N MUST NOT +C EXCEED M. +C +C X IS AN INPUT ARRAY OF LENGTH N. +C +C FJAC IS AN M BY N OUTPUT ARRAY WHICH CONTAINS THE JACOBIAN +C MATRIX OF THE NPROB FUNCTION EVALUATED AT X. +C +C LDFJAC IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN M +C WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY FJAC. +C +C NPROB IS A POSITIVE INTEGER VARIABLE WHICH DEFINES THE +C NUMBER OF THE PROBLEM. NPROB MUST NOT EXCEED 18. +C +C SUBPROGRAMS CALLED +C +C FORTRAN-SUPPLIED ... DATAN,DCOS,DEXP,DSIN,DSQRT +C +C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. +C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE +C +C ********** + INTEGER I,IVAR,J,K,MM1,NM1 + DOUBLE PRECISION C14,C20,C29,C45,C100,DIV,DX,EIGHT,FIVE,FOUR, + * ONE,PROD,S2,TEMP,TEN,THREE,TI,TMP1,TMP2,TMP3, + * TMP4,TPI,TWO,ZERO + DOUBLE PRECISION V(11) + DOUBLE PRECISION DFLOAT + DATA ZERO,ONE,TWO,THREE,FOUR,FIVE,EIGHT,TEN,C14,C20,C29,C45,C100 + * /0.0D0,1.0D0,2.0D0,3.0D0,4.0D0,5.0D0,8.0D0,1.0D1,1.4D1, + * 2.0D1,2.9D1,4.5D1,1.0D2/ + DATA V(1),V(2),V(3),V(4),V(5),V(6),V(7),V(8),V(9),V(10),V(11) + * /4.0D0,2.0D0,1.0D0,5.0D-1,2.5D-1,1.67D-1,1.25D-1,1.0D-1, + * 8.33D-2,7.14D-2,6.25D-2/ + DFLOAT(IVAR) = IVAR +C +C JACOBIAN ROUTINE SELECTOR. +C + GO TO (10,40,70,130,140,150,180,190,210,230,250,310,330,350,370, + * 400,460,480), NPROB +C +C LINEAR FUNCTION - FULL RANK. +C + 10 CONTINUE + TEMP = TWO/DFLOAT(M) + DO 30 J = 1, N + DO 20 I = 1, M + FJAC(I,J) = -TEMP + 20 CONTINUE + FJAC(J,J) = FJAC(J,J) + ONE + 30 CONTINUE + GO TO 500 +C +C LINEAR FUNCTION - RANK 1. +C + 40 CONTINUE + DO 60 J = 1, N + DO 50 I = 1, M + FJAC(I,J) = DFLOAT(I)*DFLOAT(J) + 50 CONTINUE + 60 CONTINUE + GO TO 500 +C +C LINEAR FUNCTION - RANK 1 WITH ZERO COLUMNS AND ROWS. +C + 70 CONTINUE + DO 90 J = 1, N + DO 80 I = 1, M + FJAC(I,J) = ZERO + 80 CONTINUE + 90 CONTINUE + NM1 = N - 1 + MM1 = M - 1 + IF (NM1 .LT. 2) GO TO 120 + DO 110 J = 2, NM1 + DO 100 I = 2, MM1 + FJAC(I,J) = DFLOAT(I-1)*DFLOAT(J) + 100 CONTINUE + 110 CONTINUE + 120 CONTINUE + GO TO 500 +C +C ROSENBROCK FUNCTION. +C + 130 CONTINUE + FJAC(1,1) = -C20*X(1) + FJAC(1,2) = TEN + FJAC(2,1) = -ONE + FJAC(2,2) = ZERO + GO TO 500 +C +C HELICAL VALLEY FUNCTION. +C + 140 CONTINUE + TPI = EIGHT*DATAN(ONE) + TEMP = X(1)**2 + X(2)**2 + TMP1 = TPI*TEMP + TMP2 = DSQRT(TEMP) + FJAC(1,1) = C100*X(2)/TMP1 + FJAC(1,2) = -C100*X(1)/TMP1 + FJAC(1,3) = TEN + FJAC(2,1) = TEN*X(1)/TMP2 + FJAC(2,2) = TEN*X(2)/TMP2 + FJAC(2,3) = ZERO + FJAC(3,1) = ZERO + FJAC(3,2) = ZERO + FJAC(3,3) = ONE + GO TO 500 +C +C POWELL SINGULAR FUNCTION. +C + 150 CONTINUE + DO 170 J = 1, 4 + DO 160 I = 1, 4 + FJAC(I,J) = ZERO + 160 CONTINUE + 170 CONTINUE + FJAC(1,1) = ONE + FJAC(1,2) = TEN + FJAC(2,3) = DSQRT(FIVE) + FJAC(2,4) = -FJAC(2,3) + FJAC(3,2) = TWO*(X(2) - TWO*X(3)) + FJAC(3,3) = -TWO*FJAC(3,2) + FJAC(4,1) = TWO*DSQRT(TEN)*(X(1) - X(4)) + FJAC(4,4) = -FJAC(4,1) + GO TO 500 +C +C FREUDENSTEIN AND ROTH FUNCTION. +C + 180 CONTINUE + FJAC(1,1) = ONE + FJAC(1,2) = X(2)*(TEN - THREE*X(2)) - TWO + FJAC(2,1) = ONE + FJAC(2,2) = X(2)*(TWO + THREE*X(2)) - C14 + GO TO 500 +C +C BARD FUNCTION. +C + 190 CONTINUE + DO 200 I = 1, 15 + TMP1 = DFLOAT(I) + TMP2 = DFLOAT(16-I) + TMP3 = TMP1 + IF (I .GT. 8) TMP3 = TMP2 + TMP4 = (X(2)*TMP2 + X(3)*TMP3)**2 + FJAC(I,1) = -ONE + FJAC(I,2) = TMP1*TMP2/TMP4 + FJAC(I,3) = TMP1*TMP3/TMP4 + 200 CONTINUE + GO TO 500 +C +C KOWALIK AND OSBORNE FUNCTION. +C + 210 CONTINUE + DO 220 I = 1, 11 + TMP1 = V(I)*(V(I) + X(2)) + TMP2 = V(I)*(V(I) + X(3)) + X(4) + FJAC(I,1) = -TMP1/TMP2 + FJAC(I,2) = -V(I)*X(1)/TMP2 + FJAC(I,3) = FJAC(I,1)*FJAC(I,2) + FJAC(I,4) = FJAC(I,3)/V(I) + 220 CONTINUE + GO TO 500 +C +C MEYER FUNCTION. +C + 230 CONTINUE + DO 240 I = 1, 16 + TEMP = FIVE*DFLOAT(I) + C45 + X(3) + TMP1 = X(2)/TEMP + TMP2 = DEXP(TMP1) + FJAC(I,1) = TMP2 + FJAC(I,2) = X(1)*TMP2/TEMP + FJAC(I,3) = -TMP1*FJAC(I,2) + 240 CONTINUE + GO TO 500 +C +C WATSON FUNCTION. +C + 250 CONTINUE + DO 280 I = 1, 29 + DIV = DFLOAT(I)/C29 + S2 = ZERO + DX = ONE + DO 260 J = 1, N + S2 = S2 + DX*X(J) + DX = DIV*DX + 260 CONTINUE + TEMP = TWO*DIV*S2 + DX = ONE/DIV + DO 270 J = 1, N + FJAC(I,J) = DX*(DFLOAT(J-1) - TEMP) + DX = DIV*DX + 270 CONTINUE + 280 CONTINUE + DO 300 J = 1, N + DO 290 I = 30, 31 + FJAC(I,J) = ZERO + 290 CONTINUE + 300 CONTINUE + FJAC(30,1) = ONE + FJAC(31,1) = -TWO*X(1) + FJAC(31,2) = ONE + GO TO 500 +C +C BOX 3-DIMENSIONAL FUNCTION. +C + 310 CONTINUE + DO 320 I = 1, M + TEMP = DFLOAT(I) + TMP1 = TEMP/TEN + FJAC(I,1) = -TMP1*DEXP(-TMP1*X(1)) + FJAC(I,2) = TMP1*DEXP(-TMP1*X(2)) + FJAC(I,3) = DEXP(-TEMP) - DEXP(-TMP1) + 320 CONTINUE + GO TO 500 +C +C JENNRICH AND SAMPSON FUNCTION. +C + 330 CONTINUE + DO 340 I = 1, M + TEMP = DFLOAT(I) + FJAC(I,1) = -TEMP*DEXP(TEMP*X(1)) + FJAC(I,2) = -TEMP*DEXP(TEMP*X(2)) + 340 CONTINUE + GO TO 500 +C +C BROWN AND DENNIS FUNCTION. +C + 350 CONTINUE + DO 360 I = 1, M + TEMP = DFLOAT(I)/FIVE + TI = DSIN(TEMP) + TMP1 = X(1) + TEMP*X(2) - DEXP(TEMP) + TMP2 = X(3) + TI*X(4) - DCOS(TEMP) + FJAC(I,1) = TWO*TMP1 + FJAC(I,2) = TEMP*FJAC(I,1) + FJAC(I,3) = TWO*TMP2 + FJAC(I,4) = TI*FJAC(I,3) + 360 CONTINUE + GO TO 500 +C +C CHEBYQUAD FUNCTION. +C + 370 CONTINUE + DX = ONE/DFLOAT(N) + DO 390 J = 1, N + TMP1 = ONE + TMP2 = TWO*X(J) - ONE + TEMP = TWO*TMP2 + TMP3 = ZERO + TMP4 = TWO + DO 380 I = 1, M + FJAC(I,J) = DX*TMP4 + TI = FOUR*TMP2 + TEMP*TMP4 - TMP3 + TMP3 = TMP4 + TMP4 = TI + TI = TEMP*TMP2 - TMP1 + TMP1 = TMP2 + TMP2 = TI + 380 CONTINUE + 390 CONTINUE + GO TO 500 +C +C BROWN ALMOST-LINEAR FUNCTION. +C + 400 CONTINUE + PROD = ONE + DO 420 J = 1, N + PROD = X(J)*PROD + DO 410 I = 1, N + FJAC(I,J) = ONE + 410 CONTINUE + FJAC(J,J) = TWO + 420 CONTINUE + DO 450 J = 1, N + TEMP = X(J) + IF (TEMP .NE. ZERO) GO TO 440 + TEMP = ONE + PROD = ONE + DO 430 K = 1, N + IF (K .NE. J) PROD = X(K)*PROD + 430 CONTINUE + 440 CONTINUE + FJAC(N,J) = PROD/TEMP + 450 CONTINUE + GO TO 500 +C +C OSBORNE 1 FUNCTION. +C + 460 CONTINUE + DO 470 I = 1, 33 + TEMP = TEN*DFLOAT(I-1) + TMP1 = DEXP(-X(4)*TEMP) + TMP2 = DEXP(-X(5)*TEMP) + FJAC(I,1) = -ONE + FJAC(I,2) = -TMP1 + FJAC(I,3) = -TMP2 + FJAC(I,4) = TEMP*X(2)*TMP1 + FJAC(I,5) = TEMP*X(3)*TMP2 + 470 CONTINUE + GO TO 500 +C +C OSBORNE 2 FUNCTION. +C + 480 CONTINUE + DO 490 I = 1, 65 + TEMP = DFLOAT(I-1)/TEN + TMP1 = DEXP(-X(5)*TEMP) + TMP2 = DEXP(-X(6)*(TEMP-X(9))**2) + TMP3 = DEXP(-X(7)*(TEMP-X(10))**2) + TMP4 = DEXP(-X(8)*(TEMP-X(11))**2) + FJAC(I,1) = -TMP1 + FJAC(I,2) = -TMP2 + FJAC(I,3) = -TMP3 + FJAC(I,4) = -TMP4 + FJAC(I,5) = TEMP*X(1)*TMP1 + FJAC(I,6) = X(2)*(TEMP - X(9))**2*TMP2 + FJAC(I,7) = X(3)*(TEMP - X(10))**2*TMP3 + FJAC(I,8) = X(4)*(TEMP - X(11))**2*TMP4 + FJAC(I,9) = -TWO*X(2)*X(6)*(TEMP - X(9))*TMP2 + FJAC(I,10) = -TWO*X(3)*X(7)*(TEMP - X(10))*TMP3 + FJAC(I,11) = -TWO*X(4)*X(8)*(TEMP - X(11))*TMP4 + 490 CONTINUE + 500 CONTINUE + RETURN +C +C LAST CARD OF SUBROUTINE SSQJAC. +C + END + SUBROUTINE INITPT(N,X,NPROB,FACTOR) + INTEGER N,NPROB + DOUBLE PRECISION FACTOR + DOUBLE PRECISION X(N) +C ********** +C +C SUBROUTINE INITPT +C +C THIS SUBROUTINE SPECIFIES THE STANDARD STARTING POINTS FOR THE +C FUNCTIONS DEFINED BY SUBROUTINE SSQFCN. THE SUBROUTINE RETURNS +C IN X A MULTIPLE (FACTOR) OF THE STANDARD STARTING POINT. FOR +C THE 11TH FUNCTION THE STANDARD STARTING POINT IS ZERO, SO IN +C THIS CASE, IF FACTOR IS NOT UNITY, THEN THE SUBROUTINE RETURNS +C THE VECTOR X(J) = FACTOR, J=1,...,N. +C +C THE SUBROUTINE STATEMENT IS +C +C SUBROUTINE INITPT(N,X,NPROB,FACTOR) +C +C WHERE +C +C N IS A POSITIVE INTEGER INPUT VARIABLE. +C +C X IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE STANDARD +C STARTING POINT FOR PROBLEM NPROB MULTIPLIED BY FACTOR. +C +C NPROB IS A POSITIVE INTEGER INPUT VARIABLE WHICH DEFINES THE +C NUMBER OF THE PROBLEM. NPROB MUST NOT EXCEED 18. +C +C FACTOR IS AN INPUT VARIABLE WHICH SPECIFIES THE MULTIPLE OF +C THE STANDARD STARTING POINT. IF FACTOR IS UNITY, NO +C MULTIPLICATION IS PERFORMED. +C +C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. +C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE +C +C ********** + INTEGER IVAR,J + DOUBLE PRECISION C1,C2,C3,C4,C5,C6,C7,C8,C9,C10,C11,C12,C13,C14, + * C15,C16,C17,FIVE,H,HALF,ONE,SEVEN,TEN,THREE, + * TWENTY,TWNTF,TWO,ZERO + DOUBLE PRECISION DFLOAT + DATA ZERO,HALF,ONE,TWO,THREE,FIVE,SEVEN,TEN,TWENTY,TWNTF + * /0.0D0,5.0D-1,1.0D0,2.0D0,3.0D0,5.0D0,7.0D0,1.0D1,2.0D1, + * 2.5D1/ + DATA C1,C2,C3,C4,C5,C6,C7,C8,C9,C10,C11,C12,C13,C14,C15,C16,C17 + * /1.2D0,2.5D-1,3.9D-1,4.15D-1,2.0D-2,4.0D3,2.5D2,3.0D-1, + * 4.0D-1,1.5D0,1.0D-2,1.3D0,6.5D-1,7.0D-1,6.0D-1,4.5D0, + * 5.5D0/ + DFLOAT(IVAR) = IVAR +C +C SELECTION OF INITIAL POINT. +C + GO TO (10,10,10,30,40,50,60,70,80,90,100,120,130,140,150,170, + * 190,200), NPROB +C +C LINEAR FUNCTION - FULL RANK OR RANK 1. +C + 10 CONTINUE + DO 20 J = 1, N + X(J) = ONE + 20 CONTINUE + GO TO 210 +C +C ROSENBROCK FUNCTION. +C + 30 CONTINUE + X(1) = -C1 + X(2) = ONE + GO TO 210 +C +C HELICAL VALLEY FUNCTION. +C + 40 CONTINUE + X(1) = -ONE + X(2) = ZERO + X(3) = ZERO + GO TO 210 +C +C POWELL SINGULAR FUNCTION. +C + 50 CONTINUE + X(1) = THREE + X(2) = -ONE + X(3) = ZERO + X(4) = ONE + GO TO 210 +C +C FREUDENSTEIN AND ROTH FUNCTION. +C + 60 CONTINUE + X(1) = HALF + X(2) = -TWO + GO TO 210 +C +C BARD FUNCTION. +C + 70 CONTINUE + X(1) = ONE + X(2) = ONE + X(3) = ONE + GO TO 210 +C +C KOWALIK AND OSBORNE FUNCTION. +C + 80 CONTINUE + X(1) = C2 + X(2) = C3 + X(3) = C4 + X(4) = C3 + GO TO 210 +C +C MEYER FUNCTION. +C + 90 CONTINUE + X(1) = C5 + X(2) = C6 + X(3) = C7 + GO TO 210 +C +C WATSON FUNCTION. +C + 100 CONTINUE + DO 110 J = 1, N + X(J) = ZERO + 110 CONTINUE + GO TO 210 +C +C BOX 3-DIMENSIONAL FUNCTION. +C + 120 CONTINUE + X(1) = ZERO + X(2) = TEN + X(3) = TWENTY + GO TO 210 +C +C JENNRICH AND SAMPSON FUNCTION. +C + 130 CONTINUE + X(1) = C8 + X(2) = C9 + GO TO 210 +C +C BROWN AND DENNIS FUNCTION. +C + 140 CONTINUE + X(1) = TWNTF + X(2) = FIVE + X(3) = -FIVE + X(4) = -ONE + GO TO 210 +C +C CHEBYQUAD FUNCTION. +C + 150 CONTINUE + H = ONE/DFLOAT(N+1) + DO 160 J = 1, N + X(J) = DFLOAT(J)*H + 160 CONTINUE + GO TO 210 +C +C BROWN ALMOST-LINEAR FUNCTION. +C + 170 CONTINUE + DO 180 J = 1, N + X(J) = HALF + 180 CONTINUE + GO TO 210 +C +C OSBORNE 1 FUNCTION. +C + 190 CONTINUE + X(1) = HALF + X(2) = C10 + X(3) = -ONE + X(4) = C11 + X(5) = C5 + GO TO 210 +C +C OSBORNE 2 FUNCTION. +C + 200 CONTINUE + X(1) = C12 + X(2) = C13 + X(3) = C13 + X(4) = C14 + X(5) = C15 + X(6) = THREE + X(7) = FIVE + X(8) = SEVEN + X(9) = TWO + X(10) = C16 + X(11) = C17 + 210 CONTINUE +C +C COMPUTE MULTIPLE OF INITIAL POINT. +C + IF (FACTOR .EQ. ONE) GO TO 260 + IF (NPROB .EQ. 11) GO TO 230 + DO 220 J = 1, N + X(J) = FACTOR*X(J) + 220 CONTINUE + GO TO 250 + 230 CONTINUE + DO 240 J = 1, N + X(J) = FACTOR + 240 CONTINUE + 250 CONTINUE + 260 CONTINUE + RETURN +C +C LAST CARD OF SUBROUTINE INITPT. +C + END + SUBROUTINE SSQFCN(M,N,X,FVEC,NPROB) + INTEGER M,N,NPROB + DOUBLE PRECISION X(N),FVEC(M) +C ********** +C +C SUBROUTINE SSQFCN +C +C THIS SUBROUTINE DEFINES THE FUNCTIONS OF EIGHTEEN NONLINEAR +C LEAST SQUARES PROBLEMS. THE ALLOWABLE VALUES OF (M,N) FOR +C FUNCTIONS 1,2 AND 3 ARE VARIABLE BUT WITH M .GE. N. +C FOR FUNCTIONS 4,5,6,7,8,9 AND 10 THE VALUES OF (M,N) ARE +C (2,2),(3,3),(4,4),(2,2),(15,3),(11,4) AND (16,3), RESPECTIVELY. +C FUNCTION 11 (WATSON) HAS M = 31 WITH N USUALLY 6 OR 9. +C HOWEVER, ANY N, N = 2,...,31, IS PERMITTED. +C FUNCTIONS 12,13 AND 14 HAVE N = 3,2 AND 4, RESPECTIVELY, BUT +C ALLOW ANY M .GE. N, WITH THE USUAL CHOICES BEING 10,10 AND 20. +C FUNCTION 15 (CHEBYQUAD) ALLOWS M AND N VARIABLE WITH M .GE. N. +C FUNCTION 16 (BROWN) ALLOWS N VARIABLE WITH M = N. +C FOR FUNCTIONS 17 AND 18, THE VALUES OF (M,N) ARE +C (33,5) AND (65,11), RESPECTIVELY. +C +C THE SUBROUTINE STATEMENT IS +C +C SUBROUTINE SSQFCN(M,N,X,FVEC,NPROB) +C +C WHERE +C +C M AND N ARE POSITIVE INTEGER INPUT VARIABLES. N MUST NOT +C EXCEED M. +C +C X IS AN INPUT ARRAY OF LENGTH N. +C +C FVEC IS AN OUTPUT ARRAY OF LENGTH M WHICH CONTAINS THE NPROB +C FUNCTION EVALUATED AT X. +C +C NPROB IS A POSITIVE INTEGER INPUT VARIABLE WHICH DEFINES THE +C NUMBER OF THE PROBLEM. NPROB MUST NOT EXCEED 18. +C +C SUBPROGRAMS CALLED +C +C FORTRAN-SUPPLIED ... DATAN,DCOS,DEXP,DSIN,DSQRT,DSIGN +C +C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. +C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE +C +C ********** + INTEGER I,IEV,IVAR,J,NM1 + DOUBLE PRECISION C13,C14,C29,C45,DIV,DX,EIGHT,FIVE,ONE,PROD,SUM, + * S1,S2,TEMP,TEN,TI,TMP1,TMP2,TMP3,TMP4,TPI,TWO, + * ZERO,ZP25,ZP5 + DOUBLE PRECISION V(11),Y1(15),Y2(11),Y3(16),Y4(33),Y5(65) + DOUBLE PRECISION DFLOAT + DATA ZERO,ZP25,ZP5,ONE,TWO,FIVE,EIGHT,TEN,C13,C14,C29,C45 + * /0.0D0,2.5D-1,5.0D-1,1.0D0,2.0D0,5.0D0,8.0D0,1.0D1,1.3D1, + * 1.4D1,2.9D1,4.5D1/ + DATA V(1),V(2),V(3),V(4),V(5),V(6),V(7),V(8),V(9),V(10),V(11) + * /4.0D0,2.0D0,1.0D0,5.0D-1,2.5D-1,1.67D-1,1.25D-1,1.0D-1, + * 8.33D-2,7.14D-2,6.25D-2/ + DATA Y1(1),Y1(2),Y1(3),Y1(4),Y1(5),Y1(6),Y1(7),Y1(8),Y1(9), + * Y1(10),Y1(11),Y1(12),Y1(13),Y1(14),Y1(15) + * /1.4D-1,1.8D-1,2.2D-1,2.5D-1,2.9D-1,3.2D-1,3.5D-1,3.9D-1, + * 3.7D-1,5.8D-1,7.3D-1,9.6D-1,1.34D0,2.1D0,4.39D0/ + DATA Y2(1),Y2(2),Y2(3),Y2(4),Y2(5),Y2(6),Y2(7),Y2(8),Y2(9), + * Y2(10),Y2(11) + * /1.957D-1,1.947D-1,1.735D-1,1.6D-1,8.44D-2,6.27D-2,4.56D-2, + * 3.42D-2,3.23D-2,2.35D-2,2.46D-2/ + DATA Y3(1),Y3(2),Y3(3),Y3(4),Y3(5),Y3(6),Y3(7),Y3(8),Y3(9), + * Y3(10),Y3(11),Y3(12),Y3(13),Y3(14),Y3(15),Y3(16) + * /3.478D4,2.861D4,2.365D4,1.963D4,1.637D4,1.372D4,1.154D4, + * 9.744D3,8.261D3,7.03D3,6.005D3,5.147D3,4.427D3,3.82D3, + * 3.307D3,2.872D3/ + DATA Y4(1),Y4(2),Y4(3),Y4(4),Y4(5),Y4(6),Y4(7),Y4(8),Y4(9), + * Y4(10),Y4(11),Y4(12),Y4(13),Y4(14),Y4(15),Y4(16),Y4(17), + * Y4(18),Y4(19),Y4(20),Y4(21),Y4(22),Y4(23),Y4(24),Y4(25), + * Y4(26),Y4(27),Y4(28),Y4(29),Y4(30),Y4(31),Y4(32),Y4(33) + * /8.44D-1,9.08D-1,9.32D-1,9.36D-1,9.25D-1,9.08D-1,8.81D-1, + * 8.5D-1,8.18D-1,7.84D-1,7.51D-1,7.18D-1,6.85D-1,6.58D-1, + * 6.28D-1,6.03D-1,5.8D-1,5.58D-1,5.38D-1,5.22D-1,5.06D-1, + * 4.9D-1,4.78D-1,4.67D-1,4.57D-1,4.48D-1,4.38D-1,4.31D-1, + * 4.24D-1,4.2D-1,4.14D-1,4.11D-1,4.06D-1/ + DATA Y5(1),Y5(2),Y5(3),Y5(4),Y5(5),Y5(6),Y5(7),Y5(8),Y5(9), + * Y5(10),Y5(11),Y5(12),Y5(13),Y5(14),Y5(15),Y5(16),Y5(17), + * Y5(18),Y5(19),Y5(20),Y5(21),Y5(22),Y5(23),Y5(24),Y5(25), + * Y5(26),Y5(27),Y5(28),Y5(29),Y5(30),Y5(31),Y5(32),Y5(33), + * Y5(34),Y5(35),Y5(36),Y5(37),Y5(38),Y5(39),Y5(40),Y5(41), + * Y5(42),Y5(43),Y5(44),Y5(45),Y5(46),Y5(47),Y5(48),Y5(49), + * Y5(50),Y5(51),Y5(52),Y5(53),Y5(54),Y5(55),Y5(56),Y5(57), + * Y5(58),Y5(59),Y5(60),Y5(61),Y5(62),Y5(63),Y5(64),Y5(65) + * /1.366D0,1.191D0,1.112D0,1.013D0,9.91D-1,8.85D-1,8.31D-1, + * 8.47D-1,7.86D-1,7.25D-1,7.46D-1,6.79D-1,6.08D-1,6.55D-1, + * 6.16D-1,6.06D-1,6.02D-1,6.26D-1,6.51D-1,7.24D-1,6.49D-1, + * 6.49D-1,6.94D-1,6.44D-1,6.24D-1,6.61D-1,6.12D-1,5.58D-1, + * 5.33D-1,4.95D-1,5.0D-1,4.23D-1,3.95D-1,3.75D-1,3.72D-1, + * 3.91D-1,3.96D-1,4.05D-1,4.28D-1,4.29D-1,5.23D-1,5.62D-1, + * 6.07D-1,6.53D-1,6.72D-1,7.08D-1,6.33D-1,6.68D-1,6.45D-1, + * 6.32D-1,5.91D-1,5.59D-1,5.97D-1,6.25D-1,7.39D-1,7.1D-1, + * 7.29D-1,7.2D-1,6.36D-1,5.81D-1,4.28D-1,2.92D-1,1.62D-1, + * 9.8D-2,5.4D-2/ + DFLOAT(IVAR) = IVAR +C +C FUNCTION ROUTINE SELECTOR. +C + GO TO (10,40,70,110,120,130,140,150,170,190,210,250,270,290,310, + * 360,390,410), NPROB +C +C LINEAR FUNCTION - FULL RANK. +C + 10 CONTINUE + SUM = ZERO + DO 20 J = 1, N + SUM = SUM + X(J) + 20 CONTINUE + TEMP = TWO*SUM/DFLOAT(M) + ONE + DO 30 I = 1, M + FVEC(I) = -TEMP + IF (I .LE. N) FVEC(I) = FVEC(I) + X(I) + 30 CONTINUE + GO TO 430 +C +C LINEAR FUNCTION - RANK 1. +C + 40 CONTINUE + SUM = ZERO + DO 50 J = 1, N + SUM = SUM + DFLOAT(J)*X(J) + 50 CONTINUE + DO 60 I = 1, M + FVEC(I) = DFLOAT(I)*SUM - ONE + 60 CONTINUE + GO TO 430 +C +C LINEAR FUNCTION - RANK 1 WITH ZERO COLUMNS AND ROWS. +C + 70 CONTINUE + SUM = ZERO + NM1 = N - 1 + IF (NM1 .LT. 2) GO TO 90 + DO 80 J = 2, NM1 + SUM = SUM + DFLOAT(J)*X(J) + 80 CONTINUE + 90 CONTINUE + DO 100 I = 1, M + FVEC(I) = DFLOAT(I-1)*SUM - ONE + 100 CONTINUE + FVEC(M) = -ONE + GO TO 430 +C +C ROSENBROCK FUNCTION. +C + 110 CONTINUE + FVEC(1) = TEN*(X(2) - X(1)**2) + FVEC(2) = ONE - X(1) + GO TO 430 +C +C HELICAL VALLEY FUNCTION. +C + 120 CONTINUE + TPI = EIGHT*DATAN(ONE) + TMP1 = DSIGN(ZP25,X(2)) + IF (X(1) .GT. ZERO) TMP1 = DATAN(X(2)/X(1))/TPI + IF (X(1) .LT. ZERO) TMP1 = DATAN(X(2)/X(1))/TPI + ZP5 + TMP2 = DSQRT(X(1)**2+X(2)**2) + FVEC(1) = TEN*(X(3) - TEN*TMP1) + FVEC(2) = TEN*(TMP2 - ONE) + FVEC(3) = X(3) + GO TO 430 +C +C POWELL SINGULAR FUNCTION. +C + 130 CONTINUE + FVEC(1) = X(1) + TEN*X(2) + FVEC(2) = DSQRT(FIVE)*(X(3) - X(4)) + FVEC(3) = (X(2) - TWO*X(3))**2 + FVEC(4) = DSQRT(TEN)*(X(1) - X(4))**2 + GO TO 430 +C +C FREUDENSTEIN AND ROTH FUNCTION. +C + 140 CONTINUE + FVEC(1) = -C13 + X(1) + ((FIVE - X(2))*X(2) - TWO)*X(2) + FVEC(2) = -C29 + X(1) + ((ONE + X(2))*X(2) - C14)*X(2) + GO TO 430 +C +C BARD FUNCTION. +C + 150 CONTINUE + DO 160 I = 1, 15 + TMP1 = DFLOAT(I) + TMP2 = DFLOAT(16-I) + TMP3 = TMP1 + IF (I .GT. 8) TMP3 = TMP2 + FVEC(I) = Y1(I) - (X(1) + TMP1/(X(2)*TMP2 + X(3)*TMP3)) + 160 CONTINUE + GO TO 430 +C +C KOWALIK AND OSBORNE FUNCTION. +C + 170 CONTINUE + DO 180 I = 1, 11 + TMP1 = V(I)*(V(I) + X(2)) + TMP2 = V(I)*(V(I) + X(3)) + X(4) + FVEC(I) = Y2(I) - X(1)*TMP1/TMP2 + 180 CONTINUE + GO TO 430 +C +C MEYER FUNCTION. +C + 190 CONTINUE + DO 200 I = 1, 16 + TEMP = FIVE*DFLOAT(I) + C45 + X(3) + TMP1 = X(2)/TEMP + TMP2 = DEXP(TMP1) + FVEC(I) = X(1)*TMP2 - Y3(I) + 200 CONTINUE + GO TO 430 +C +C WATSON FUNCTION. +C + 210 CONTINUE + DO 240 I = 1, 29 + DIV = DFLOAT(I)/C29 + S1 = ZERO + DX = ONE + DO 220 J = 2, N + S1 = S1 + DFLOAT(J-1)*DX*X(J) + DX = DIV*DX + 220 CONTINUE + S2 = ZERO + DX = ONE + DO 230 J = 1, N + S2 = S2 + DX*X(J) + DX = DIV*DX + 230 CONTINUE + FVEC(I) = S1 - S2**2 - ONE + 240 CONTINUE + FVEC(30) = X(1) + FVEC(31) = X(2) - X(1)**2 - ONE + GO TO 430 +C +C BOX 3-DIMENSIONAL FUNCTION. +C + 250 CONTINUE + DO 260 I = 1, M + TEMP = DFLOAT(I) + TMP1 = TEMP/TEN + FVEC(I) = DEXP(-TMP1*X(1)) - DEXP(-TMP1*X(2)) + * + (DEXP(-TEMP) - DEXP(-TMP1))*X(3) + 260 CONTINUE + GO TO 430 +C +C JENNRICH AND SAMPSON FUNCTION. +C + 270 CONTINUE + DO 280 I = 1, M + TEMP = DFLOAT(I) + FVEC(I) = TWO + TWO*TEMP - DEXP(TEMP*X(1)) - DEXP(TEMP*X(2)) + 280 CONTINUE + GO TO 430 +C +C BROWN AND DENNIS FUNCTION. +C + 290 CONTINUE + DO 300 I = 1, M + TEMP = DFLOAT(I)/FIVE + TMP1 = X(1) + TEMP*X(2) - DEXP(TEMP) + TMP2 = X(3) + DSIN(TEMP)*X(4) - DCOS(TEMP) + FVEC(I) = TMP1**2 + TMP2**2 + 300 CONTINUE + GO TO 430 +C +C CHEBYQUAD FUNCTION. +C + 310 CONTINUE + DO 320 I = 1, M + FVEC(I) = ZERO + 320 CONTINUE + DO 340 J = 1, N + TMP1 = ONE + TMP2 = TWO*X(J) - ONE + TEMP = TWO*TMP2 + DO 330 I = 1, M + FVEC(I) = FVEC(I) + TMP2 + TI = TEMP*TMP2 - TMP1 + TMP1 = TMP2 + TMP2 = TI + 330 CONTINUE + 340 CONTINUE + DX = ONE/DFLOAT(N) + IEV = -1 + DO 350 I = 1, M + FVEC(I) = DX*FVEC(I) + IF (IEV .GT. 0) FVEC(I) = FVEC(I) + ONE/(DFLOAT(I)**2 - ONE) + IEV = -IEV + 350 CONTINUE + GO TO 430 +C +C BROWN ALMOST-LINEAR FUNCTION. +C + 360 CONTINUE + SUM = -DFLOAT(N+1) + PROD = ONE + DO 370 J = 1, N + SUM = SUM + X(J) + PROD = X(J)*PROD + 370 CONTINUE + DO 380 I = 1, N + FVEC(I) = X(I) + SUM + 380 CONTINUE + FVEC(N) = PROD - ONE + GO TO 430 +C +C OSBORNE 1 FUNCTION. +C + 390 CONTINUE + DO 400 I = 1, 33 + TEMP = TEN*DFLOAT(I-1) + TMP1 = DEXP(-X(4)*TEMP) + TMP2 = DEXP(-X(5)*TEMP) + FVEC(I) = Y4(I) - (X(1) + X(2)*TMP1 + X(3)*TMP2) + 400 CONTINUE + GO TO 430 +C +C OSBORNE 2 FUNCTION. +C + 410 CONTINUE + DO 420 I = 1, 65 + TEMP = DFLOAT(I-1)/TEN + TMP1 = DEXP(-X(5)*TEMP) + TMP2 = DEXP(-X(6)*(TEMP-X(9))**2) + TMP3 = DEXP(-X(7)*(TEMP-X(10))**2) + TMP4 = DEXP(-X(8)*(TEMP-X(11))**2) + FVEC(I) = Y5(I) + * - (X(1)*TMP1 + X(2)*TMP2 + X(3)*TMP3 + X(4)*TMP4) + 420 CONTINUE + 430 CONTINUE + RETURN +C +C LAST CARD OF SUBROUTINE SSQFCN. +C + END diff --git a/ex/file19 b/ex/file19 new file mode 100644 index 0000000..9e1ba54 --- /dev/null +++ b/ex/file19 @@ -0,0 +1,675 @@ +C ********** +C +C THIS PROGRAM TESTS CODES FOR THE LEAST-SQUARES SOLUTION OF +C M NONLINEAR EQUATIONS IN N VARIABLES. IT CONSISTS OF A DRIVER +C AND AN INTERFACE SUBROUTINE FCN. THE DRIVER READS IN DATA, +C CALLS THE NONLINEAR LEAST-SQUARES SOLVER, AND FINALLY PRINTS +C OUT INFORMATION ON THE PERFORMANCE OF THE SOLVER. THIS IS +C ONLY A SAMPLE DRIVER, MANY OTHER DRIVERS ARE POSSIBLE. THE +C INTERFACE SUBROUTINE FCN IS NECESSARY TO TAKE INTO ACCOUNT THE +C FORMS OF CALLING SEQUENCES USED BY THE FUNCTION AND JACOBIAN +C SUBROUTINES IN THE VARIOUS NONLINEAR LEAST-SQUARES SOLVERS. +C +C SUBPROGRAMS CALLED +C +C USER-SUPPLIED ...... FCN +C +C MINPACK-SUPPLIED ... DPMPAR,ENORM,INITPT,LMDIF1,SSQFCN +C +C FORTRAN-SUPPLIED ... DSQRT +C +C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. +C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE +C +C ********** + INTEGER I,IC,INFO,K,LWA,M,N,NFEV,NJEV,NPROB,NREAD,NTRIES,NWRITE + INTEGER IWA(40),MA(60),NA(60),NF(60),NJ(60),NP(60),NX(60) + DOUBLE PRECISION FACTOR,FNORM1,FNORM2,ONE,TEN,TOL + DOUBLE PRECISION FNM(60),FVEC(65),WA(2865),X(40) + DOUBLE PRECISION DPMPAR,ENORM + EXTERNAL FCN + COMMON /REFNUM/ NPROB,NFEV,NJEV +C +C LOGICAL INPUT UNIT IS ASSUMED TO BE NUMBER 5. +C LOGICAL OUTPUT UNIT IS ASSUMED TO BE NUMBER 6. +C + DATA NREAD,NWRITE /5,6/ +C + DATA ONE,TEN /1.0D0,1.0D1/ + TOL = DSQRT(DPMPAR(1)) + LWA = 2865 + IC = 0 + 10 CONTINUE + READ (NREAD,50) NPROB,N,M,NTRIES + IF (NPROB .LE. 0) GO TO 30 + FACTOR = ONE + DO 20 K = 1, NTRIES + IC = IC + 1 + CALL INITPT(N,X,NPROB,FACTOR) + CALL SSQFCN(M,N,X,FVEC,NPROB) + FNORM1 = ENORM(M,FVEC) + WRITE (NWRITE,60) NPROB,N,M + NFEV = 0 + NJEV = 0 + CALL LMDIF1(FCN,M,N,X,FVEC,TOL,INFO,IWA,WA,LWA) + CALL SSQFCN(M,N,X,FVEC,NPROB) + FNORM2 = ENORM(M,FVEC) + NP(IC) = NPROB + NA(IC) = N + MA(IC) = M + NF(IC) = NFEV + NJEV = NJEV/N + NJ(IC) = NJEV + NX(IC) = INFO + FNM(IC) = FNORM2 + WRITE (NWRITE,70) + * FNORM1,FNORM2,NFEV,NJEV,INFO,(X(I), I = 1, N) + FACTOR = TEN*FACTOR + 20 CONTINUE + GO TO 10 + 30 CONTINUE + WRITE (NWRITE,80) IC + WRITE (NWRITE,90) + DO 40 I = 1, IC + WRITE (NWRITE,100) NP(I),NA(I),MA(I),NF(I),NJ(I),NX(I),FNM(I) + 40 CONTINUE + STOP + 50 FORMAT (4I5) + 60 FORMAT ( //// 5X, 8H PROBLEM, I5, 5X, 11H DIMENSIONS, 2I5, 5X // + * ) + 70 FORMAT (5X, 33H INITIAL L2 NORM OF THE RESIDUALS, D15.7 // 5X, + * 33H FINAL L2 NORM OF THE RESIDUALS , D15.7 // 5X, + * 33H NUMBER OF FUNCTION EVALUATIONS , I10 // 5X, + * 33H NUMBER OF JACOBIAN EVALUATIONS , I10 // 5X, + * 15H EXIT PARAMETER, 18X, I10 // 5X, + * 27H FINAL APPROXIMATE SOLUTION // (5X, 5D15.7)) + 80 FORMAT (12H1SUMMARY OF , I3, 16H CALLS TO LMDIF1 /) + 90 FORMAT (49H NPROB N M NFEV NJEV INFO FINAL L2 NORM /) + 100 FORMAT (3I5, 3I6, 1X, D15.7) +C +C LAST CARD OF DRIVER. +C + END + SUBROUTINE FCN(M,N,X,FVEC,IFLAG) + INTEGER M,N,IFLAG + DOUBLE PRECISION X(N),FVEC(M) +C ********** +C +C THE CALLING SEQUENCE OF FCN SHOULD BE IDENTICAL TO THE +C CALLING SEQUENCE OF THE FUNCTION SUBROUTINE IN THE NONLINEAR +C LEAST-SQUARES SOLVER. FCN SHOULD ONLY CALL THE TESTING +C FUNCTION SUBROUTINE SSQFCN WITH THE APPROPRIATE VALUE OF +C PROBLEM NUMBER (NPROB). +C +C SUBPROGRAMS CALLED +C +C MINPACK-SUPPLIED ... SSQFCN +C +C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. +C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE +C +C ********** + INTEGER NPROB,NFEV,NJEV + COMMON /REFNUM/ NPROB,NFEV,NJEV + CALL SSQFCN(M,N,X,FVEC,NPROB) + IF (IFLAG .EQ. 1) NFEV = NFEV + 1 + IF (IFLAG .EQ. 2) NJEV = NJEV + 1 + RETURN +C +C LAST CARD OF INTERFACE SUBROUTINE FCN. +C + END + SUBROUTINE SSQFCN(M,N,X,FVEC,NPROB) + INTEGER M,N,NPROB + DOUBLE PRECISION X(N),FVEC(M) +C ********** +C +C SUBROUTINE SSQFCN +C +C THIS SUBROUTINE DEFINES THE FUNCTIONS OF EIGHTEEN NONLINEAR +C LEAST SQUARES PROBLEMS. THE ALLOWABLE VALUES OF (M,N) FOR +C FUNCTIONS 1,2 AND 3 ARE VARIABLE BUT WITH M .GE. N. +C FOR FUNCTIONS 4,5,6,7,8,9 AND 10 THE VALUES OF (M,N) ARE +C (2,2),(3,3),(4,4),(2,2),(15,3),(11,4) AND (16,3), RESPECTIVELY. +C FUNCTION 11 (WATSON) HAS M = 31 WITH N USUALLY 6 OR 9. +C HOWEVER, ANY N, N = 2,...,31, IS PERMITTED. +C FUNCTIONS 12,13 AND 14 HAVE N = 3,2 AND 4, RESPECTIVELY, BUT +C ALLOW ANY M .GE. N, WITH THE USUAL CHOICES BEING 10,10 AND 20. +C FUNCTION 15 (CHEBYQUAD) ALLOWS M AND N VARIABLE WITH M .GE. N. +C FUNCTION 16 (BROWN) ALLOWS N VARIABLE WITH M = N. +C FOR FUNCTIONS 17 AND 18, THE VALUES OF (M,N) ARE +C (33,5) AND (65,11), RESPECTIVELY. +C +C THE SUBROUTINE STATEMENT IS +C +C SUBROUTINE SSQFCN(M,N,X,FVEC,NPROB) +C +C WHERE +C +C M AND N ARE POSITIVE INTEGER INPUT VARIABLES. N MUST NOT +C EXCEED M. +C +C X IS AN INPUT ARRAY OF LENGTH N. +C +C FVEC IS AN OUTPUT ARRAY OF LENGTH M WHICH CONTAINS THE NPROB +C FUNCTION EVALUATED AT X. +C +C NPROB IS A POSITIVE INTEGER INPUT VARIABLE WHICH DEFINES THE +C NUMBER OF THE PROBLEM. NPROB MUST NOT EXCEED 18. +C +C SUBPROGRAMS CALLED +C +C FORTRAN-SUPPLIED ... DATAN,DCOS,DEXP,DSIN,DSQRT,DSIGN +C +C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. +C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE +C +C ********** + INTEGER I,IEV,IVAR,J,NM1 + DOUBLE PRECISION C13,C14,C29,C45,DIV,DX,EIGHT,FIVE,ONE,PROD,SUM, + * S1,S2,TEMP,TEN,TI,TMP1,TMP2,TMP3,TMP4,TPI,TWO, + * ZERO,ZP25,ZP5 + DOUBLE PRECISION V(11),Y1(15),Y2(11),Y3(16),Y4(33),Y5(65) + DOUBLE PRECISION DFLOAT + DATA ZERO,ZP25,ZP5,ONE,TWO,FIVE,EIGHT,TEN,C13,C14,C29,C45 + * /0.0D0,2.5D-1,5.0D-1,1.0D0,2.0D0,5.0D0,8.0D0,1.0D1,1.3D1, + * 1.4D1,2.9D1,4.5D1/ + DATA V(1),V(2),V(3),V(4),V(5),V(6),V(7),V(8),V(9),V(10),V(11) + * /4.0D0,2.0D0,1.0D0,5.0D-1,2.5D-1,1.67D-1,1.25D-1,1.0D-1, + * 8.33D-2,7.14D-2,6.25D-2/ + DATA Y1(1),Y1(2),Y1(3),Y1(4),Y1(5),Y1(6),Y1(7),Y1(8),Y1(9), + * Y1(10),Y1(11),Y1(12),Y1(13),Y1(14),Y1(15) + * /1.4D-1,1.8D-1,2.2D-1,2.5D-1,2.9D-1,3.2D-1,3.5D-1,3.9D-1, + * 3.7D-1,5.8D-1,7.3D-1,9.6D-1,1.34D0,2.1D0,4.39D0/ + DATA Y2(1),Y2(2),Y2(3),Y2(4),Y2(5),Y2(6),Y2(7),Y2(8),Y2(9), + * Y2(10),Y2(11) + * /1.957D-1,1.947D-1,1.735D-1,1.6D-1,8.44D-2,6.27D-2,4.56D-2, + * 3.42D-2,3.23D-2,2.35D-2,2.46D-2/ + DATA Y3(1),Y3(2),Y3(3),Y3(4),Y3(5),Y3(6),Y3(7),Y3(8),Y3(9), + * Y3(10),Y3(11),Y3(12),Y3(13),Y3(14),Y3(15),Y3(16) + * /3.478D4,2.861D4,2.365D4,1.963D4,1.637D4,1.372D4,1.154D4, + * 9.744D3,8.261D3,7.03D3,6.005D3,5.147D3,4.427D3,3.82D3, + * 3.307D3,2.872D3/ + DATA Y4(1),Y4(2),Y4(3),Y4(4),Y4(5),Y4(6),Y4(7),Y4(8),Y4(9), + * Y4(10),Y4(11),Y4(12),Y4(13),Y4(14),Y4(15),Y4(16),Y4(17), + * Y4(18),Y4(19),Y4(20),Y4(21),Y4(22),Y4(23),Y4(24),Y4(25), + * Y4(26),Y4(27),Y4(28),Y4(29),Y4(30),Y4(31),Y4(32),Y4(33) + * /8.44D-1,9.08D-1,9.32D-1,9.36D-1,9.25D-1,9.08D-1,8.81D-1, + * 8.5D-1,8.18D-1,7.84D-1,7.51D-1,7.18D-1,6.85D-1,6.58D-1, + * 6.28D-1,6.03D-1,5.8D-1,5.58D-1,5.38D-1,5.22D-1,5.06D-1, + * 4.9D-1,4.78D-1,4.67D-1,4.57D-1,4.48D-1,4.38D-1,4.31D-1, + * 4.24D-1,4.2D-1,4.14D-1,4.11D-1,4.06D-1/ + DATA Y5(1),Y5(2),Y5(3),Y5(4),Y5(5),Y5(6),Y5(7),Y5(8),Y5(9), + * Y5(10),Y5(11),Y5(12),Y5(13),Y5(14),Y5(15),Y5(16),Y5(17), + * Y5(18),Y5(19),Y5(20),Y5(21),Y5(22),Y5(23),Y5(24),Y5(25), + * Y5(26),Y5(27),Y5(28),Y5(29),Y5(30),Y5(31),Y5(32),Y5(33), + * Y5(34),Y5(35),Y5(36),Y5(37),Y5(38),Y5(39),Y5(40),Y5(41), + * Y5(42),Y5(43),Y5(44),Y5(45),Y5(46),Y5(47),Y5(48),Y5(49), + * Y5(50),Y5(51),Y5(52),Y5(53),Y5(54),Y5(55),Y5(56),Y5(57), + * Y5(58),Y5(59),Y5(60),Y5(61),Y5(62),Y5(63),Y5(64),Y5(65) + * /1.366D0,1.191D0,1.112D0,1.013D0,9.91D-1,8.85D-1,8.31D-1, + * 8.47D-1,7.86D-1,7.25D-1,7.46D-1,6.79D-1,6.08D-1,6.55D-1, + * 6.16D-1,6.06D-1,6.02D-1,6.26D-1,6.51D-1,7.24D-1,6.49D-1, + * 6.49D-1,6.94D-1,6.44D-1,6.24D-1,6.61D-1,6.12D-1,5.58D-1, + * 5.33D-1,4.95D-1,5.0D-1,4.23D-1,3.95D-1,3.75D-1,3.72D-1, + * 3.91D-1,3.96D-1,4.05D-1,4.28D-1,4.29D-1,5.23D-1,5.62D-1, + * 6.07D-1,6.53D-1,6.72D-1,7.08D-1,6.33D-1,6.68D-1,6.45D-1, + * 6.32D-1,5.91D-1,5.59D-1,5.97D-1,6.25D-1,7.39D-1,7.1D-1, + * 7.29D-1,7.2D-1,6.36D-1,5.81D-1,4.28D-1,2.92D-1,1.62D-1, + * 9.8D-2,5.4D-2/ + DFLOAT(IVAR) = IVAR +C +C FUNCTION ROUTINE SELECTOR. +C + GO TO (10,40,70,110,120,130,140,150,170,190,210,250,270,290,310, + * 360,390,410), NPROB +C +C LINEAR FUNCTION - FULL RANK. +C + 10 CONTINUE + SUM = ZERO + DO 20 J = 1, N + SUM = SUM + X(J) + 20 CONTINUE + TEMP = TWO*SUM/DFLOAT(M) + ONE + DO 30 I = 1, M + FVEC(I) = -TEMP + IF (I .LE. N) FVEC(I) = FVEC(I) + X(I) + 30 CONTINUE + GO TO 430 +C +C LINEAR FUNCTION - RANK 1. +C + 40 CONTINUE + SUM = ZERO + DO 50 J = 1, N + SUM = SUM + DFLOAT(J)*X(J) + 50 CONTINUE + DO 60 I = 1, M + FVEC(I) = DFLOAT(I)*SUM - ONE + 60 CONTINUE + GO TO 430 +C +C LINEAR FUNCTION - RANK 1 WITH ZERO COLUMNS AND ROWS. +C + 70 CONTINUE + SUM = ZERO + NM1 = N - 1 + IF (NM1 .LT. 2) GO TO 90 + DO 80 J = 2, NM1 + SUM = SUM + DFLOAT(J)*X(J) + 80 CONTINUE + 90 CONTINUE + DO 100 I = 1, M + FVEC(I) = DFLOAT(I-1)*SUM - ONE + 100 CONTINUE + FVEC(M) = -ONE + GO TO 430 +C +C ROSENBROCK FUNCTION. +C + 110 CONTINUE + FVEC(1) = TEN*(X(2) - X(1)**2) + FVEC(2) = ONE - X(1) + GO TO 430 +C +C HELICAL VALLEY FUNCTION. +C + 120 CONTINUE + TPI = EIGHT*DATAN(ONE) + TMP1 = DSIGN(ZP25,X(2)) + IF (X(1) .GT. ZERO) TMP1 = DATAN(X(2)/X(1))/TPI + IF (X(1) .LT. ZERO) TMP1 = DATAN(X(2)/X(1))/TPI + ZP5 + TMP2 = DSQRT(X(1)**2+X(2)**2) + FVEC(1) = TEN*(X(3) - TEN*TMP1) + FVEC(2) = TEN*(TMP2 - ONE) + FVEC(3) = X(3) + GO TO 430 +C +C POWELL SINGULAR FUNCTION. +C + 130 CONTINUE + FVEC(1) = X(1) + TEN*X(2) + FVEC(2) = DSQRT(FIVE)*(X(3) - X(4)) + FVEC(3) = (X(2) - TWO*X(3))**2 + FVEC(4) = DSQRT(TEN)*(X(1) - X(4))**2 + GO TO 430 +C +C FREUDENSTEIN AND ROTH FUNCTION. +C + 140 CONTINUE + FVEC(1) = -C13 + X(1) + ((FIVE - X(2))*X(2) - TWO)*X(2) + FVEC(2) = -C29 + X(1) + ((ONE + X(2))*X(2) - C14)*X(2) + GO TO 430 +C +C BARD FUNCTION. +C + 150 CONTINUE + DO 160 I = 1, 15 + TMP1 = DFLOAT(I) + TMP2 = DFLOAT(16-I) + TMP3 = TMP1 + IF (I .GT. 8) TMP3 = TMP2 + FVEC(I) = Y1(I) - (X(1) + TMP1/(X(2)*TMP2 + X(3)*TMP3)) + 160 CONTINUE + GO TO 430 +C +C KOWALIK AND OSBORNE FUNCTION. +C + 170 CONTINUE + DO 180 I = 1, 11 + TMP1 = V(I)*(V(I) + X(2)) + TMP2 = V(I)*(V(I) + X(3)) + X(4) + FVEC(I) = Y2(I) - X(1)*TMP1/TMP2 + 180 CONTINUE + GO TO 430 +C +C MEYER FUNCTION. +C + 190 CONTINUE + DO 200 I = 1, 16 + TEMP = FIVE*DFLOAT(I) + C45 + X(3) + TMP1 = X(2)/TEMP + TMP2 = DEXP(TMP1) + FVEC(I) = X(1)*TMP2 - Y3(I) + 200 CONTINUE + GO TO 430 +C +C WATSON FUNCTION. +C + 210 CONTINUE + DO 240 I = 1, 29 + DIV = DFLOAT(I)/C29 + S1 = ZERO + DX = ONE + DO 220 J = 2, N + S1 = S1 + DFLOAT(J-1)*DX*X(J) + DX = DIV*DX + 220 CONTINUE + S2 = ZERO + DX = ONE + DO 230 J = 1, N + S2 = S2 + DX*X(J) + DX = DIV*DX + 230 CONTINUE + FVEC(I) = S1 - S2**2 - ONE + 240 CONTINUE + FVEC(30) = X(1) + FVEC(31) = X(2) - X(1)**2 - ONE + GO TO 430 +C +C BOX 3-DIMENSIONAL FUNCTION. +C + 250 CONTINUE + DO 260 I = 1, M + TEMP = DFLOAT(I) + TMP1 = TEMP/TEN + FVEC(I) = DEXP(-TMP1*X(1)) - DEXP(-TMP1*X(2)) + * + (DEXP(-TEMP) - DEXP(-TMP1))*X(3) + 260 CONTINUE + GO TO 430 +C +C JENNRICH AND SAMPSON FUNCTION. +C + 270 CONTINUE + DO 280 I = 1, M + TEMP = DFLOAT(I) + FVEC(I) = TWO + TWO*TEMP - DEXP(TEMP*X(1)) - DEXP(TEMP*X(2)) + 280 CONTINUE + GO TO 430 +C +C BROWN AND DENNIS FUNCTION. +C + 290 CONTINUE + DO 300 I = 1, M + TEMP = DFLOAT(I)/FIVE + TMP1 = X(1) + TEMP*X(2) - DEXP(TEMP) + TMP2 = X(3) + DSIN(TEMP)*X(4) - DCOS(TEMP) + FVEC(I) = TMP1**2 + TMP2**2 + 300 CONTINUE + GO TO 430 +C +C CHEBYQUAD FUNCTION. +C + 310 CONTINUE + DO 320 I = 1, M + FVEC(I) = ZERO + 320 CONTINUE + DO 340 J = 1, N + TMP1 = ONE + TMP2 = TWO*X(J) - ONE + TEMP = TWO*TMP2 + DO 330 I = 1, M + FVEC(I) = FVEC(I) + TMP2 + TI = TEMP*TMP2 - TMP1 + TMP1 = TMP2 + TMP2 = TI + 330 CONTINUE + 340 CONTINUE + DX = ONE/DFLOAT(N) + IEV = -1 + DO 350 I = 1, M + FVEC(I) = DX*FVEC(I) + IF (IEV .GT. 0) FVEC(I) = FVEC(I) + ONE/(DFLOAT(I)**2 - ONE) + IEV = -IEV + 350 CONTINUE + GO TO 430 +C +C BROWN ALMOST-LINEAR FUNCTION. +C + 360 CONTINUE + SUM = -DFLOAT(N+1) + PROD = ONE + DO 370 J = 1, N + SUM = SUM + X(J) + PROD = X(J)*PROD + 370 CONTINUE + DO 380 I = 1, N + FVEC(I) = X(I) + SUM + 380 CONTINUE + FVEC(N) = PROD - ONE + GO TO 430 +C +C OSBORNE 1 FUNCTION. +C + 390 CONTINUE + DO 400 I = 1, 33 + TEMP = TEN*DFLOAT(I-1) + TMP1 = DEXP(-X(4)*TEMP) + TMP2 = DEXP(-X(5)*TEMP) + FVEC(I) = Y4(I) - (X(1) + X(2)*TMP1 + X(3)*TMP2) + 400 CONTINUE + GO TO 430 +C +C OSBORNE 2 FUNCTION. +C + 410 CONTINUE + DO 420 I = 1, 65 + TEMP = DFLOAT(I-1)/TEN + TMP1 = DEXP(-X(5)*TEMP) + TMP2 = DEXP(-X(6)*(TEMP-X(9))**2) + TMP3 = DEXP(-X(7)*(TEMP-X(10))**2) + TMP4 = DEXP(-X(8)*(TEMP-X(11))**2) + FVEC(I) = Y5(I) + * - (X(1)*TMP1 + X(2)*TMP2 + X(3)*TMP3 + X(4)*TMP4) + 420 CONTINUE + 430 CONTINUE + RETURN +C +C LAST CARD OF SUBROUTINE SSQFCN. +C + END + SUBROUTINE INITPT(N,X,NPROB,FACTOR) + INTEGER N,NPROB + DOUBLE PRECISION FACTOR + DOUBLE PRECISION X(N) +C ********** +C +C SUBROUTINE INITPT +C +C THIS SUBROUTINE SPECIFIES THE STANDARD STARTING POINTS FOR THE +C FUNCTIONS DEFINED BY SUBROUTINE SSQFCN. THE SUBROUTINE RETURNS +C IN X A MULTIPLE (FACTOR) OF THE STANDARD STARTING POINT. FOR +C THE 11TH FUNCTION THE STANDARD STARTING POINT IS ZERO, SO IN +C THIS CASE, IF FACTOR IS NOT UNITY, THEN THE SUBROUTINE RETURNS +C THE VECTOR X(J) = FACTOR, J=1,...,N. +C +C THE SUBROUTINE STATEMENT IS +C +C SUBROUTINE INITPT(N,X,NPROB,FACTOR) +C +C WHERE +C +C N IS A POSITIVE INTEGER INPUT VARIABLE. +C +C X IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE STANDARD +C STARTING POINT FOR PROBLEM NPROB MULTIPLIED BY FACTOR. +C +C NPROB IS A POSITIVE INTEGER INPUT VARIABLE WHICH DEFINES THE +C NUMBER OF THE PROBLEM. NPROB MUST NOT EXCEED 18. +C +C FACTOR IS AN INPUT VARIABLE WHICH SPECIFIES THE MULTIPLE OF +C THE STANDARD STARTING POINT. IF FACTOR IS UNITY, NO +C MULTIPLICATION IS PERFORMED. +C +C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. +C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE +C +C ********** + INTEGER IVAR,J + DOUBLE PRECISION C1,C2,C3,C4,C5,C6,C7,C8,C9,C10,C11,C12,C13,C14, + * C15,C16,C17,FIVE,H,HALF,ONE,SEVEN,TEN,THREE, + * TWENTY,TWNTF,TWO,ZERO + DOUBLE PRECISION DFLOAT + DATA ZERO,HALF,ONE,TWO,THREE,FIVE,SEVEN,TEN,TWENTY,TWNTF + * /0.0D0,5.0D-1,1.0D0,2.0D0,3.0D0,5.0D0,7.0D0,1.0D1,2.0D1, + * 2.5D1/ + DATA C1,C2,C3,C4,C5,C6,C7,C8,C9,C10,C11,C12,C13,C14,C15,C16,C17 + * /1.2D0,2.5D-1,3.9D-1,4.15D-1,2.0D-2,4.0D3,2.5D2,3.0D-1, + * 4.0D-1,1.5D0,1.0D-2,1.3D0,6.5D-1,7.0D-1,6.0D-1,4.5D0, + * 5.5D0/ + DFLOAT(IVAR) = IVAR +C +C SELECTION OF INITIAL POINT. +C + GO TO (10,10,10,30,40,50,60,70,80,90,100,120,130,140,150,170, + * 190,200), NPROB +C +C LINEAR FUNCTION - FULL RANK OR RANK 1. +C + 10 CONTINUE + DO 20 J = 1, N + X(J) = ONE + 20 CONTINUE + GO TO 210 +C +C ROSENBROCK FUNCTION. +C + 30 CONTINUE + X(1) = -C1 + X(2) = ONE + GO TO 210 +C +C HELICAL VALLEY FUNCTION. +C + 40 CONTINUE + X(1) = -ONE + X(2) = ZERO + X(3) = ZERO + GO TO 210 +C +C POWELL SINGULAR FUNCTION. +C + 50 CONTINUE + X(1) = THREE + X(2) = -ONE + X(3) = ZERO + X(4) = ONE + GO TO 210 +C +C FREUDENSTEIN AND ROTH FUNCTION. +C + 60 CONTINUE + X(1) = HALF + X(2) = -TWO + GO TO 210 +C +C BARD FUNCTION. +C + 70 CONTINUE + X(1) = ONE + X(2) = ONE + X(3) = ONE + GO TO 210 +C +C KOWALIK AND OSBORNE FUNCTION. +C + 80 CONTINUE + X(1) = C2 + X(2) = C3 + X(3) = C4 + X(4) = C3 + GO TO 210 +C +C MEYER FUNCTION. +C + 90 CONTINUE + X(1) = C5 + X(2) = C6 + X(3) = C7 + GO TO 210 +C +C WATSON FUNCTION. +C + 100 CONTINUE + DO 110 J = 1, N + X(J) = ZERO + 110 CONTINUE + GO TO 210 +C +C BOX 3-DIMENSIONAL FUNCTION. +C + 120 CONTINUE + X(1) = ZERO + X(2) = TEN + X(3) = TWENTY + GO TO 210 +C +C JENNRICH AND SAMPSON FUNCTION. +C + 130 CONTINUE + X(1) = C8 + X(2) = C9 + GO TO 210 +C +C BROWN AND DENNIS FUNCTION. +C + 140 CONTINUE + X(1) = TWNTF + X(2) = FIVE + X(3) = -FIVE + X(4) = -ONE + GO TO 210 +C +C CHEBYQUAD FUNCTION. +C + 150 CONTINUE + H = ONE/DFLOAT(N+1) + DO 160 J = 1, N + X(J) = DFLOAT(J)*H + 160 CONTINUE + GO TO 210 +C +C BROWN ALMOST-LINEAR FUNCTION. +C + 170 CONTINUE + DO 180 J = 1, N + X(J) = HALF + 180 CONTINUE + GO TO 210 +C +C OSBORNE 1 FUNCTION. +C + 190 CONTINUE + X(1) = HALF + X(2) = C10 + X(3) = -ONE + X(4) = C11 + X(5) = C5 + GO TO 210 +C +C OSBORNE 2 FUNCTION. +C + 200 CONTINUE + X(1) = C12 + X(2) = C13 + X(3) = C13 + X(4) = C14 + X(5) = C15 + X(6) = THREE + X(7) = FIVE + X(8) = SEVEN + X(9) = TWO + X(10) = C16 + X(11) = C17 + 210 CONTINUE +C +C COMPUTE MULTIPLE OF INITIAL POINT. +C + IF (FACTOR .EQ. ONE) GO TO 260 + IF (NPROB .EQ. 11) GO TO 230 + DO 220 J = 1, N + X(J) = FACTOR*X(J) + 220 CONTINUE + GO TO 250 + 230 CONTINUE + DO 240 J = 1, N + X(J) = FACTOR + 240 CONTINUE + 250 CONTINUE + 260 CONTINUE + RETURN +C +C LAST CARD OF SUBROUTINE INITPT. +C + END diff --git a/ex/file20 b/ex/file20 new file mode 100644 index 0000000..e7c61a3 --- /dev/null +++ b/ex/file20 @@ -0,0 +1,860 @@ +C ********** +C +C THIS PROGRAM TESTS THE ABILITY OF CHKDER TO DETECT +C INCONSISTENCIES BETWEEN FUNCTIONS AND THEIR FIRST DERIVATIVES. +C FOURTEEN TEST FUNCTION VECTORS AND JACOBIANS ARE USED. ELEVEN OF +C THE TESTS ARE FALSE(F), I.E. THERE ARE INCONSISTENCIES BETWEEN +C THE FUNCTION VECTORS AND THE CORRESPONDING JACOBIANS. THREE OF +C THE TESTS ARE TRUE(T), I.E. THERE ARE NO INCONSISTENCIES. THE +C DRIVER READS IN DATA, CALLS CHKDER AND PRINTS OUT INFORMATION +C REQUIRED BY AND RECEIVED FROM CHKDER. +C +C SUBPROGRAMS CALLED +C +C MINPACK SUPPLIED ... CHKDER,ERRJAC,INITPT,VECFCN +C +C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. +C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE +C +C ********** + INTEGER I,LDFJAC,LNP,MODE,N,NPROB,NREAD,NWRITE + INTEGER NA(14),NP(14) + LOGICAL A(14) + DOUBLE PRECISION CP,ONE + DOUBLE PRECISION DIFF(10),ERR(10),ERRMAX(14),ERRMIN(14), + * FJAC(10,10),FVEC1(10),FVEC2(10),X1(10),X2(10) +C +C LOGICAL INPUT UNIT IS ASSUMED TO BE NUMBER 5. +C LOGICAL OUTPUT UNIT IS ASSUMED TO BE NUMBER 6. +C + DATA NREAD,NWRITE /5,6/ +C + DATA A(1),A(2),A(3),A(4),A(5),A(6),A(7),A(8),A(9),A(10),A(11), + * A(12),A(13),A(14) + * /.FALSE.,.FALSE.,.FALSE.,.TRUE.,.FALSE.,.FALSE.,.FALSE., + * .TRUE.,.FALSE.,.FALSE.,.FALSE.,.FALSE.,.TRUE.,.FALSE./ + DATA CP,ONE /1.23D-1,1.0D0/ + LDFJAC = 10 + 10 CONTINUE + READ (NREAD,60) NPROB,N + IF (NPROB .LE. 0) GO TO 40 + CALL INITPT(N,X1,NPROB,ONE) + DO 20 I = 1, N + X1(I) = X1(I) + CP + CP = -CP + 20 CONTINUE + WRITE (NWRITE,70) NPROB,N,A(NPROB) + MODE = 1 + CALL CHKDER(N,N,X1,FVEC1,FJAC,LDFJAC,X2,FVEC2,MODE,ERR) + MODE = 2 + CALL VECFCN(N,X1,FVEC1,NPROB) + CALL ERRJAC(N,X1,FJAC,LDFJAC,NPROB) + CALL VECFCN(N,X2,FVEC2,NPROB) + CALL CHKDER(N,N,X1,FVEC1,FJAC,LDFJAC,X2,FVEC2,MODE,ERR) + ERRMIN(NPROB) = ERR(1) + ERRMAX(NPROB) = ERR(1) + DO 30 I = 1, N + DIFF(I) = FVEC2(I) - FVEC1(I) + IF (ERRMIN(NPROB) .GT. ERR(I)) ERRMIN(NPROB) = ERR(I) + IF (ERRMAX(NPROB) .LT. ERR(I)) ERRMAX(NPROB) = ERR(I) + 30 CONTINUE + NP(NPROB) = NPROB + LNP = NPROB + NA(NPROB) = N + WRITE (NWRITE,80) (FVEC1(I), I = 1, N) + WRITE (NWRITE,90) (DIFF(I), I = 1, N) + WRITE (NWRITE,100) (ERR(I), I = 1, N) + GO TO 10 + 40 CONTINUE + WRITE (NWRITE,110) LNP + WRITE (NWRITE,120) + DO 50 I = 1, LNP + WRITE (NWRITE,130) NP(I),NA(I),A(I),ERRMIN(I),ERRMAX(I) + 50 CONTINUE + STOP + 60 FORMAT (2I5) + 70 FORMAT ( /// 5X, 8H PROBLEM, I5, 5X, 15H WITH DIMENSION, I5, 2X, + * 5H IS , L1) + 80 FORMAT ( // 5X, 25H FIRST FUNCTION VECTOR // (5X, 5D15.7)) + 90 FORMAT ( // 5X, 27H FUNCTION DIFFERENCE VECTOR // (5X, 5D15.7)) + 100 FORMAT ( // 5X, 13H ERROR VECTOR // (5X, 5D15.7)) + 110 FORMAT (12H1SUMMARY OF , I3, 16H TESTS OF CHKDER /) + 120 FORMAT (46H NPROB N STATUS ERRMIN ERRMAX /) + 130 FORMAT (I4, I6, 6X, L1, 3X, 2D15.7) +C +C LAST CARD OF DERIVATIVE CHECK TEST DRIVER. +C + END + SUBROUTINE ERRJAC(N,X,FJAC,LDFJAC,NPROB) + INTEGER N,LDFJAC,NPROB + DOUBLE PRECISION X(N),FJAC(LDFJAC,N) +C ********** +C +C SUBROUTINE ERRJAC +C +C THIS SUBROUTINE IS DERIVED FROM VECJAC WHICH DEFINES THE +C JACOBIAN MATRICES OF FOURTEEN TEST FUNCTIONS. THE PROBLEM +C DIMENSIONS ARE AS DESCRIBED IN THE PROLOGUE COMMENTS OF VECFCN. +C VARIOUS ERRORS ARE DELIBERATELY INTRODUCED TO PROVIDE A TEST +C FOR CHKDER. +C +C THE SUBROUTINE STATEMENT IS +C +C SUBROUTINE ERRJAC(N,X,FJAC,LDFJAC,NPROB) +C +C WHERE +C +C N IS A POSITIVE INTEGER VARIABLE. +C +C X IS AN ARRAY OF LENGTH N. +C +C FJAC IS AN N BY N ARRAY. ON OUTPUT FJAC CONTAINS THE +C JACOBIAN MATRIX, WITH VARIOUS ERRORS DELIBERATELY +C INTRODUCED, OF THE NPROB FUNCTION EVALUATED AT X. +C +C LDFJAC IS A POSITIVE INTEGER VARIABLE NOT LESS THAN N +C WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY FJAC. +C +C NPROB IS A POSITIVE INTEGER VARIABLE WHICH DEFINES THE +C NUMBER OF THE PROBLEM. NPROB MUST NOT EXCEED 14. +C +C SUBPROGRAMS CALLED +C +C FORTRAN-SUPPLIED ... DATAN,DCOS,DEXP,DMIN1,DSIN,DSQRT, +C MAX0,MIN0 +C +C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. +C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE +C +C ********** + INTEGER I,IVAR,J,K,K1,K2,ML,MU + DOUBLE PRECISION C1,C3,C4,C5,C6,C9,EIGHT,FIFTN,FIVE,FOUR,H, + * HUNDRD,ONE,PROD,SIX,SUM,SUM1,SUM2,TEMP,TEMP1, + * TEMP2,TEMP3,TEMP4,TEN,THREE,TI,TJ,TK,TPI, + * TWENTY,TWO,ZERO + DOUBLE PRECISION DFLOAT + DATA ZERO,ONE,TWO,THREE,FOUR,FIVE,SIX,EIGHT,TEN,FIFTN,TWENTY, + * HUNDRD + * /0.0D0,1.0D0,2.0D0,3.0D0,4.0D0,5.0D0,6.0D0,8.0D0,1.0D1, + * 1.5D1,2.0D1,1.0D2/ + DATA C1,C3,C4,C5,C6,C9 /1.0D4,2.0D2,2.02D1,1.98D1,1.8D2,2.9D1/ + DFLOAT(IVAR) = IVAR +C +C JACOBIAN ROUTINE SELECTOR. +C + GO TO (10,20,50,60,90,100,200,230,290,320,350,380,420,450), + * NPROB +C +C ROSENBROCK FUNCTION WITH SIGN REVERSAL AFFECTING ELEMENT (1,1). +C + 10 CONTINUE + FJAC(1,1) = ONE + FJAC(1,2) = ZERO + FJAC(2,1) = -TWENTY*X(1) + FJAC(2,2) = TEN + GO TO 490 +C +C POWELL SINGULAR FUNCTION WITH SIGN REVERSAL AFFECTING ELEMENT +C (3,3). +C + 20 CONTINUE + DO 40 K = 1, 4 + DO 30 J = 1, 4 + FJAC(K,J) = ZERO + 30 CONTINUE + 40 CONTINUE + FJAC(1,1) = ONE + FJAC(1,2) = TEN + FJAC(2,3) = DSQRT(FIVE) + FJAC(2,4) = -FJAC(2,3) + FJAC(3,2) = TWO*(X(2) - TWO*X(3)) + FJAC(3,3) = TWO*FJAC(3,2) + FJAC(4,1) = TWO*DSQRT(TEN)*(X(1) - X(4)) + FJAC(4,4) = -FJAC(4,1) + GO TO 490 +C +C POWELL BADLY SCALED FUNCTION WITH THE SIGN OF THE JACOBIAN +C REVERSED. +C + 50 CONTINUE + FJAC(1,1) = -C1*X(2) + FJAC(1,2) = -C1*X(1) + FJAC(2,1) = DEXP(-X(1)) + FJAC(2,2) = DEXP(-X(2)) + GO TO 490 +C +C WOOD FUNCTION WITHOUT ERROR. +C + 60 CONTINUE + DO 80 K = 1, 4 + DO 70 J = 1, 4 + FJAC(K,J) = ZERO + 70 CONTINUE + 80 CONTINUE + TEMP1 = X(2) - THREE*X(1)**2 + TEMP2 = X(4) - THREE*X(3)**2 + FJAC(1,1) = -C3*TEMP1 + ONE + FJAC(1,2) = -C3*X(1) + FJAC(2,1) = -TWO*C3*X(1) + FJAC(2,2) = C3 + C4 + FJAC(2,4) = C5 + FJAC(3,3) = -C6*TEMP2 + ONE + FJAC(3,4) = -C6*X(3) + FJAC(4,2) = C5 + FJAC(4,3) = -TWO*C6*X(3) + FJAC(4,4) = C6 + C4 + GO TO 490 +C +C HELICAL VALLEY FUNCTION WITH MULTIPLICATIVE ERROR AFFECTING +C ELEMENTS (2,1) AND (2,2). +C + 90 CONTINUE + TPI = EIGHT*DATAN(ONE) + TEMP = X(1)**2 + X(2)**2 + TEMP1 = TPI*TEMP + TEMP2 = DSQRT(TEMP) + FJAC(1,1) = HUNDRD*X(2)/TEMP1 + FJAC(1,2) = -HUNDRD*X(1)/TEMP1 + FJAC(1,3) = TEN + FJAC(2,1) = FIVE*X(1)/TEMP2 + FJAC(2,2) = FIVE*X(2)/TEMP2 + FJAC(2,3) = ZERO + FJAC(3,1) = ZERO + FJAC(3,2) = ZERO + FJAC(3,3) = ONE + GO TO 490 +C +C WATSON FUNCTION WITH SIGN REVERSALS AFFECTING THE COMPUTATION OF +C TEMP1. +C + 100 CONTINUE + DO 120 K = 1, N + DO 110 J = K, N + FJAC(K,J) = ZERO + 110 CONTINUE + 120 CONTINUE + DO 170 I = 1, 29 + TI = DFLOAT(I)/C9 + SUM1 = ZERO + TEMP = ONE + DO 130 J = 2, N + SUM1 = SUM1 + DFLOAT(J-1)*TEMP*X(J) + TEMP = TI*TEMP + 130 CONTINUE + SUM2 = ZERO + TEMP = ONE + DO 140 J = 1, N + SUM2 = SUM2 + TEMP*X(J) + TEMP = TI*TEMP + 140 CONTINUE + TEMP1 = TWO*(SUM1 + SUM2**2 + ONE) + TEMP2 = TWO*SUM2 + TEMP = TI**2 + TK = ONE + DO 160 K = 1, N + TJ = TK + DO 150 J = K, N + FJAC(K,J) = FJAC(K,J) + * + TJ + * *((DFLOAT(K-1)/TI - TEMP2) + * *(DFLOAT(J-1)/TI - TEMP2) - TEMP1) + TJ = TI*TJ + 150 CONTINUE + TK = TEMP*TK + 160 CONTINUE + 170 CONTINUE + FJAC(1,1) = FJAC(1,1) + SIX*X(1)**2 - TWO*X(2) + THREE + FJAC(1,2) = FJAC(1,2) - TWO*X(1) + FJAC(2,2) = FJAC(2,2) + ONE + DO 190 K = 1, N + DO 180 J = K, N + FJAC(J,K) = FJAC(K,J) + 180 CONTINUE + 190 CONTINUE + GO TO 490 +C +C CHEBYQUAD FUNCTION WITH JACOBIAN TWICE CORRECT SIZE. +C + 200 CONTINUE + TK = ONE/DFLOAT(N) + DO 220 J = 1, N + TEMP1 = ONE + TEMP2 = TWO*X(J) - ONE + TEMP = TWO*TEMP2 + TEMP3 = ZERO + TEMP4 = TWO + DO 210 K = 1, N + FJAC(K,J) = TWO*TK*TEMP4 + TI = FOUR*TEMP2 + TEMP*TEMP4 - TEMP3 + TEMP3 = TEMP4 + TEMP4 = TI + TI = TEMP*TEMP2 - TEMP1 + TEMP1 = TEMP2 + TEMP2 = TI + 210 CONTINUE + 220 CONTINUE + GO TO 490 +C +C BROWN ALMOST-LINEAR FUNCTION WITHOUT ERROR. +C + 230 CONTINUE + PROD = ONE + DO 250 J = 1, N + PROD = X(J)*PROD + DO 240 K = 1, N + FJAC(K,J) = ONE + 240 CONTINUE + FJAC(J,J) = TWO + 250 CONTINUE + DO 280 J = 1, N + TEMP = X(J) + IF (TEMP .NE. ZERO) GO TO 270 + TEMP = ONE + PROD = ONE + DO 260 K = 1, N + IF (K .NE. J) PROD = X(K)*PROD + 260 CONTINUE + 270 CONTINUE + FJAC(N,J) = PROD/TEMP + 280 CONTINUE + GO TO 490 +C +C DISCRETE BOUNDARY VALUE FUNCTION WITH MULTIPLICATIVE ERROR +C AFFECTING THE JACOBIAN DIAGONAL. +C + 290 CONTINUE + H = ONE/DFLOAT(N+1) + DO 310 K = 1, N + TEMP = THREE*(X(K) + DFLOAT(K)*H + ONE)**2 + DO 300 J = 1, N + FJAC(K,J) = ZERO + 300 CONTINUE + FJAC(K,K) = FOUR + TEMP*H**2 + IF (K .NE. 1) FJAC(K,K-1) = -ONE + IF (K .NE. N) FJAC(K,K+1) = -ONE + 310 CONTINUE + GO TO 490 +C +C DISCRETE INTEGRAL EQUATION FUNCTION WITH SIGN ERROR AFFECTING +C THE JACOBIAN DIAGONAL. +C + 320 CONTINUE + H = ONE/DFLOAT(N+1) + DO 340 K = 1, N + TK = DFLOAT(K)*H + DO 330 J = 1, N + TJ = DFLOAT(J)*H + TEMP = THREE*(X(J) + TJ + ONE)**2 + FJAC(K,J) = H*DMIN1(TJ*(ONE-TK),TK*(ONE-TJ))*TEMP/TWO + 330 CONTINUE + FJAC(K,K) = FJAC(K,K) - ONE + 340 CONTINUE + GO TO 490 +C +C TRIGONOMETRIC FUNCTION WITH SIGN ERRORS AFFECTING THE +C OFFDIAGONAL ELEMENTS OF THE JACOBIAN. +C + 350 CONTINUE + DO 370 J = 1, N + TEMP = DSIN(X(J)) + DO 360 K = 1, N + FJAC(K,J) = -TEMP + 360 CONTINUE + FJAC(J,J) = DFLOAT(J+1)*TEMP - DCOS(X(J)) + 370 CONTINUE + GO TO 490 +C +C VARIABLY DIMENSIONED FUNCTION WITH OPERATION ERROR AFFECTING +C THE UPPER TRIANGULAR ELEMENTS OF THE JACOBIAN. +C + 380 CONTINUE + SUM = ZERO + DO 390 J = 1, N + SUM = SUM + DFLOAT(J)*(X(J) - ONE) + 390 CONTINUE + TEMP = ONE + SIX*SUM**2 + DO 410 K = 1, N + DO 400 J = K, N + FJAC(K,J) = DFLOAT(K*J)/TEMP + FJAC(J,K) = FJAC(K,J) + 400 CONTINUE + FJAC(K,K) = FJAC(K,K) + ONE + 410 CONTINUE + GO TO 490 +C +C BROYDEN TRIDIAGONAL FUNCTION WITHOUT ERROR. +C + 420 CONTINUE + DO 440 K = 1, N + DO 430 J = 1, N + FJAC(K,J) = ZERO + 430 CONTINUE + FJAC(K,K) = THREE - FOUR*X(K) + IF (K .NE. 1) FJAC(K,K-1) = -ONE + IF (K .NE. N) FJAC(K,K+1) = -TWO + 440 CONTINUE + GO TO 490 +C +C BROYDEN BANDED FUNCTION WITH SIGN ERROR AFFECTING THE JACOBIAN +C DIAGONAL. +C + 450 CONTINUE + ML = 5 + MU = 1 + DO 480 K = 1, N + DO 460 J = 1, N + FJAC(K,J) = ZERO + 460 CONTINUE + K1 = MAX0(1,K-ML) + K2 = MIN0(K+MU,N) + DO 470 J = K1, K2 + IF (J .NE. K) FJAC(K,J) = -(ONE + TWO*X(J)) + 470 CONTINUE + FJAC(K,K) = TWO - FIFTN*X(K)**2 + 480 CONTINUE + 490 CONTINUE + RETURN +C +C LAST CARD OF SUBROUTINE ERRJAC. +C + END + SUBROUTINE INITPT(N,X,NPROB,FACTOR) + INTEGER N,NPROB + DOUBLE PRECISION FACTOR + DOUBLE PRECISION X(N) +C ********** +C +C SUBROUTINE INITPT +C +C THIS SUBROUTINE SPECIFIES THE STANDARD STARTING POINTS FOR +C THE FUNCTIONS DEFINED BY SUBROUTINE VECFCN. THE SUBROUTINE +C RETURNS IN X A MULTIPLE (FACTOR) OF THE STANDARD STARTING +C POINT. FOR THE SIXTH FUNCTION THE STANDARD STARTING POINT IS +C ZERO, SO IN THIS CASE, IF FACTOR IS NOT UNITY, THEN THE +C SUBROUTINE RETURNS THE VECTOR X(J) = FACTOR, J=1,...,N. +C +C THE SUBROUTINE STATEMENT IS +C +C SUBROUTINE INITPT(N,X,NPROB,FACTOR) +C +C WHERE +C +C N IS A POSITIVE INTEGER INPUT VARIABLE. +C +C X IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE STANDARD +C STARTING POINT FOR PROBLEM NPROB MULTIPLIED BY FACTOR. +C +C NPROB IS A POSITIVE INTEGER INPUT VARIABLE WHICH DEFINES THE +C NUMBER OF THE PROBLEM. NPROB MUST NOT EXCEED 14. +C +C FACTOR IS AN INPUT VARIABLE WHICH SPECIFIES THE MULTIPLE OF +C THE STANDARD STARTING POINT. IF FACTOR IS UNITY, NO +C MULTIPLICATION IS PERFORMED. +C +C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. +C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE +C +C ********** + INTEGER IVAR,J + DOUBLE PRECISION C1,H,HALF,ONE,THREE,TJ,ZERO + DOUBLE PRECISION DFLOAT + DATA ZERO,HALF,ONE,THREE,C1 /0.0D0,5.0D-1,1.0D0,3.0D0,1.2D0/ + DFLOAT(IVAR) = IVAR +C +C SELECTION OF INITIAL POINT. +C + GO TO (10,20,30,40,50,60,80,100,120,120,140,160,180,180), NPROB +C +C ROSENBROCK FUNCTION. +C + 10 CONTINUE + X(1) = -C1 + X(2) = ONE + GO TO 200 +C +C POWELL SINGULAR FUNCTION. +C + 20 CONTINUE + X(1) = THREE + X(2) = -ONE + X(3) = ZERO + X(4) = ONE + GO TO 200 +C +C POWELL BADLY SCALED FUNCTION. +C + 30 CONTINUE + X(1) = ZERO + X(2) = ONE + GO TO 200 +C +C WOOD FUNCTION. +C + 40 CONTINUE + X(1) = -THREE + X(2) = -ONE + X(3) = -THREE + X(4) = -ONE + GO TO 200 +C +C HELICAL VALLEY FUNCTION. +C + 50 CONTINUE + X(1) = -ONE + X(2) = ZERO + X(3) = ZERO + GO TO 200 +C +C WATSON FUNCTION. +C + 60 CONTINUE + DO 70 J = 1, N + X(J) = ZERO + 70 CONTINUE + GO TO 200 +C +C CHEBYQUAD FUNCTION. +C + 80 CONTINUE + H = ONE/DFLOAT(N+1) + DO 90 J = 1, N + X(J) = DFLOAT(J)*H + 90 CONTINUE + GO TO 200 +C +C BROWN ALMOST-LINEAR FUNCTION. +C + 100 CONTINUE + DO 110 J = 1, N + X(J) = HALF + 110 CONTINUE + GO TO 200 +C +C DISCRETE BOUNDARY VALUE AND INTEGRAL EQUATION FUNCTIONS. +C + 120 CONTINUE + H = ONE/DFLOAT(N+1) + DO 130 J = 1, N + TJ = DFLOAT(J)*H + X(J) = TJ*(TJ - ONE) + 130 CONTINUE + GO TO 200 +C +C TRIGONOMETRIC FUNCTION. +C + 140 CONTINUE + H = ONE/DFLOAT(N) + DO 150 J = 1, N + X(J) = H + 150 CONTINUE + GO TO 200 +C +C VARIABLY DIMENSIONED FUNCTION. +C + 160 CONTINUE + H = ONE/DFLOAT(N) + DO 170 J = 1, N + X(J) = ONE - DFLOAT(J)*H + 170 CONTINUE + GO TO 200 +C +C BROYDEN TRIDIAGONAL AND BANDED FUNCTIONS. +C + 180 CONTINUE + DO 190 J = 1, N + X(J) = -ONE + 190 CONTINUE + 200 CONTINUE +C +C COMPUTE MULTIPLE OF INITIAL POINT. +C + IF (FACTOR .EQ. ONE) GO TO 250 + IF (NPROB .EQ. 6) GO TO 220 + DO 210 J = 1, N + X(J) = FACTOR*X(J) + 210 CONTINUE + GO TO 240 + 220 CONTINUE + DO 230 J = 1, N + X(J) = FACTOR + 230 CONTINUE + 240 CONTINUE + 250 CONTINUE + RETURN +C +C LAST CARD OF SUBROUTINE INITPT. +C + END + SUBROUTINE VECFCN(N,X,FVEC,NPROB) + INTEGER N,NPROB + DOUBLE PRECISION X(N),FVEC(N) +C ********** +C +C SUBROUTINE VECFCN +C +C THIS SUBROUTINE DEFINES FOURTEEN TEST FUNCTIONS. THE FIRST +C FIVE TEST FUNCTIONS ARE OF DIMENSIONS 2,4,2,4,3, RESPECTIVELY, +C WHILE THE REMAINING TEST FUNCTIONS ARE OF VARIABLE DIMENSION +C N FOR ANY N GREATER THAN OR EQUAL TO 1 (PROBLEM 6 IS AN +C EXCEPTION TO THIS, SINCE IT DOES NOT ALLOW N = 1). +C +C THE SUBROUTINE STATEMENT IS +C +C SUBROUTINE VECFCN(N,X,FVEC,NPROB) +C +C WHERE +C +C N IS A POSITIVE INTEGER INPUT VARIABLE. +C +C X IS AN INPUT ARRAY OF LENGTH N. +C +C FVEC IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE NPROB +C FUNCTION VECTOR EVALUATED AT X. +C +C NPROB IS A POSITIVE INTEGER INPUT VARIABLE WHICH DEFINES THE +C NUMBER OF THE PROBLEM. NPROB MUST NOT EXCEED 14. +C +C SUBPROGRAMS CALLED +C +C FORTRAN-SUPPLIED ... DATAN,DCOS,DEXP,DSIGN,DSIN,DSQRT, +C MAX0,MIN0 +C +C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. +C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE +C +C ********** + INTEGER I,IEV,IVAR,J,K,K1,K2,KP1,ML,MU + DOUBLE PRECISION C1,C2,C3,C4,C5,C6,C7,C8,C9,EIGHT,FIVE,H,ONE, + * PROD,SUM,SUM1,SUM2,TEMP,TEMP1,TEMP2,TEN,THREE, + * TI,TJ,TK,TPI,TWO,ZERO + DOUBLE PRECISION DFLOAT + DATA ZERO,ONE,TWO,THREE,FIVE,EIGHT,TEN + * /0.0D0,1.0D0,2.0D0,3.0D0,5.0D0,8.0D0,1.0D1/ + DATA C1,C2,C3,C4,C5,C6,C7,C8,C9 + * /1.0D4,1.0001D0,2.0D2,2.02D1,1.98D1,1.8D2,2.5D-1,5.0D-1, + * 2.9D1/ + DFLOAT(IVAR) = IVAR +C +C PROBLEM SELECTOR. +C + GO TO (10,20,30,40,50,60,120,170,200,220,270,300,330,350), NPROB +C +C ROSENBROCK FUNCTION. +C + 10 CONTINUE + FVEC(1) = ONE - X(1) + FVEC(2) = TEN*(X(2) - X(1)**2) + GO TO 380 +C +C POWELL SINGULAR FUNCTION. +C + 20 CONTINUE + FVEC(1) = X(1) + TEN*X(2) + FVEC(2) = DSQRT(FIVE)*(X(3) - X(4)) + FVEC(3) = (X(2) - TWO*X(3))**2 + FVEC(4) = DSQRT(TEN)*(X(1) - X(4))**2 + GO TO 380 +C +C POWELL BADLY SCALED FUNCTION. +C + 30 CONTINUE + FVEC(1) = C1*X(1)*X(2) - ONE + FVEC(2) = DEXP(-X(1)) + DEXP(-X(2)) - C2 + GO TO 380 +C +C WOOD FUNCTION. +C + 40 CONTINUE + TEMP1 = X(2) - X(1)**2 + TEMP2 = X(4) - X(3)**2 + FVEC(1) = -C3*X(1)*TEMP1 - (ONE - X(1)) + FVEC(2) = C3*TEMP1 + C4*(X(2) - ONE) + C5*(X(4) - ONE) + FVEC(3) = -C6*X(3)*TEMP2 - (ONE - X(3)) + FVEC(4) = C6*TEMP2 + C4*(X(4) - ONE) + C5*(X(2) - ONE) + GO TO 380 +C +C HELICAL VALLEY FUNCTION. +C + 50 CONTINUE + TPI = EIGHT*DATAN(ONE) + TEMP1 = DSIGN(C7,X(2)) + IF (X(1) .GT. ZERO) TEMP1 = DATAN(X(2)/X(1))/TPI + IF (X(1) .LT. ZERO) TEMP1 = DATAN(X(2)/X(1))/TPI + C8 + TEMP2 = DSQRT(X(1)**2+X(2)**2) + FVEC(1) = TEN*(X(3) - TEN*TEMP1) + FVEC(2) = TEN*(TEMP2 - ONE) + FVEC(3) = X(3) + GO TO 380 +C +C WATSON FUNCTION. +C + 60 CONTINUE + DO 70 K = 1, N + FVEC(K) = ZERO + 70 CONTINUE + DO 110 I = 1, 29 + TI = DFLOAT(I)/C9 + SUM1 = ZERO + TEMP = ONE + DO 80 J = 2, N + SUM1 = SUM1 + DFLOAT(J-1)*TEMP*X(J) + TEMP = TI*TEMP + 80 CONTINUE + SUM2 = ZERO + TEMP = ONE + DO 90 J = 1, N + SUM2 = SUM2 + TEMP*X(J) + TEMP = TI*TEMP + 90 CONTINUE + TEMP1 = SUM1 - SUM2**2 - ONE + TEMP2 = TWO*TI*SUM2 + TEMP = ONE/TI + DO 100 K = 1, N + FVEC(K) = FVEC(K) + TEMP*(DFLOAT(K-1) - TEMP2)*TEMP1 + TEMP = TI*TEMP + 100 CONTINUE + 110 CONTINUE + TEMP = X(2) - X(1)**2 - ONE + FVEC(1) = FVEC(1) + X(1)*(ONE - TWO*TEMP) + FVEC(2) = FVEC(2) + TEMP + GO TO 380 +C +C CHEBYQUAD FUNCTION. +C + 120 CONTINUE + DO 130 K = 1, N + FVEC(K) = ZERO + 130 CONTINUE + DO 150 J = 1, N + TEMP1 = ONE + TEMP2 = TWO*X(J) - ONE + TEMP = TWO*TEMP2 + DO 140 I = 1, N + FVEC(I) = FVEC(I) + TEMP2 + TI = TEMP*TEMP2 - TEMP1 + TEMP1 = TEMP2 + TEMP2 = TI + 140 CONTINUE + 150 CONTINUE + TK = ONE/DFLOAT(N) + IEV = -1 + DO 160 K = 1, N + FVEC(K) = TK*FVEC(K) + IF (IEV .GT. 0) FVEC(K) = FVEC(K) + ONE/(DFLOAT(K)**2 - ONE) + IEV = -IEV + 160 CONTINUE + GO TO 380 +C +C BROWN ALMOST-LINEAR FUNCTION. +C + 170 CONTINUE + SUM = -DFLOAT(N+1) + PROD = ONE + DO 180 J = 1, N + SUM = SUM + X(J) + PROD = X(J)*PROD + 180 CONTINUE + DO 190 K = 1, N + FVEC(K) = X(K) + SUM + 190 CONTINUE + FVEC(N) = PROD - ONE + GO TO 380 +C +C DISCRETE BOUNDARY VALUE FUNCTION. +C + 200 CONTINUE + H = ONE/DFLOAT(N+1) + DO 210 K = 1, N + TEMP = (X(K) + DFLOAT(K)*H + ONE)**3 + TEMP1 = ZERO + IF (K .NE. 1) TEMP1 = X(K-1) + TEMP2 = ZERO + IF (K .NE. N) TEMP2 = X(K+1) + FVEC(K) = TWO*X(K) - TEMP1 - TEMP2 + TEMP*H**2/TWO + 210 CONTINUE + GO TO 380 +C +C DISCRETE INTEGRAL EQUATION FUNCTION. +C + 220 CONTINUE + H = ONE/DFLOAT(N+1) + DO 260 K = 1, N + TK = DFLOAT(K)*H + SUM1 = ZERO + DO 230 J = 1, K + TJ = DFLOAT(J)*H + TEMP = (X(J) + TJ + ONE)**3 + SUM1 = SUM1 + TJ*TEMP + 230 CONTINUE + SUM2 = ZERO + KP1 = K + 1 + IF (N .LT. KP1) GO TO 250 + DO 240 J = KP1, N + TJ = DFLOAT(J)*H + TEMP = (X(J) + TJ + ONE)**3 + SUM2 = SUM2 + (ONE - TJ)*TEMP + 240 CONTINUE + 250 CONTINUE + FVEC(K) = X(K) + H*((ONE - TK)*SUM1 + TK*SUM2)/TWO + 260 CONTINUE + GO TO 380 +C +C TRIGONOMETRIC FUNCTION. +C + 270 CONTINUE + SUM = ZERO + DO 280 J = 1, N + FVEC(J) = DCOS(X(J)) + SUM = SUM + FVEC(J) + 280 CONTINUE + DO 290 K = 1, N + FVEC(K) = DFLOAT(N+K) - DSIN(X(K)) - SUM - DFLOAT(K)*FVEC(K) + 290 CONTINUE + GO TO 380 +C +C VARIABLY DIMENSIONED FUNCTION. +C + 300 CONTINUE + SUM = ZERO + DO 310 J = 1, N + SUM = SUM + DFLOAT(J)*(X(J) - ONE) + 310 CONTINUE + TEMP = SUM*(ONE + TWO*SUM**2) + DO 320 K = 1, N + FVEC(K) = X(K) - ONE + DFLOAT(K)*TEMP + 320 CONTINUE + GO TO 380 +C +C BROYDEN TRIDIAGONAL FUNCTION. +C + 330 CONTINUE + DO 340 K = 1, N + TEMP = (THREE - TWO*X(K))*X(K) + TEMP1 = ZERO + IF (K .NE. 1) TEMP1 = X(K-1) + TEMP2 = ZERO + IF (K .NE. N) TEMP2 = X(K+1) + FVEC(K) = TEMP - TEMP1 - TWO*TEMP2 + ONE + 340 CONTINUE + GO TO 380 +C +C BROYDEN BANDED FUNCTION. +C + 350 CONTINUE + ML = 5 + MU = 1 + DO 370 K = 1, N + K1 = MAX0(1,K-ML) + K2 = MIN0(K+MU,N) + TEMP = ZERO + DO 360 J = K1, K2 + IF (J .NE. K) TEMP = TEMP + X(J)*(ONE + X(J)) + 360 CONTINUE + FVEC(K) = X(K)*(TWO + FIVE*X(K)**2) + ONE - TEMP + 370 CONTINUE + 380 CONTINUE + RETURN +C +C LAST CARD OF SUBROUTINE VECFCN. +C + END diff --git a/ex/file21 b/ex/file21 new file mode 100644 index 0000000..9d867c8 --- /dev/null +++ b/ex/file21 @@ -0,0 +1,23 @@ + 1 2 3 + 2 4 3 + 3 2 2 + 4 4 3 + 5 3 3 + 6 6 2 + 6 9 2 + 7 5 3 + 7 6 3 + 7 7 3 + 7 8 1 + 7 9 1 + 8 10 3 + 8 30 1 + 8 40 1 + 9 10 3 + 10 1 3 + 10 10 3 + 11 10 3 + 12 10 3 + 13 10 3 + 14 10 3 + 0 0 0 diff --git a/ex/file22 b/ex/file22 new file mode 100644 index 0000000..b3cf138 --- /dev/null +++ b/ex/file22 @@ -0,0 +1,29 @@ + 1 5 10 1 + 1 5 50 1 + 2 5 10 1 + 2 5 50 1 + 3 5 10 1 + 3 5 50 1 + 4 2 2 3 + 5 3 3 3 + 6 4 4 3 + 7 2 2 3 + 8 3 15 3 + 9 4 11 3 + 10 3 16 2 + 11 6 31 3 + 11 9 31 3 + 11 12 31 3 + 12 3 10 1 + 13 2 10 1 + 14 4 20 3 + 15 1 8 3 + 15 8 8 1 + 15 9 9 1 + 15 10 10 1 + 16 10 10 3 + 16 30 30 1 + 16 40 40 1 + 17 5 33 1 + 18 11 65 1 + 0 0 0 0 diff --git a/ex/file23 b/ex/file23 new file mode 100644 index 0000000..0dff12e --- /dev/null +++ b/ex/file23 @@ -0,0 +1,15 @@ + 1 2 + 2 4 + 3 2 + 4 4 + 5 3 + 6 9 + 7 7 + 8 10 + 9 10 + 10 10 + 11 10 + 12 10 + 13 10 + 14 10 + 0 0 diff --git a/fdjac1.f b/fdjac1.f new file mode 100644 index 0000000..031ed46 --- /dev/null +++ b/fdjac1.f @@ -0,0 +1,151 @@ + subroutine fdjac1(fcn,n,x,fvec,fjac,ldfjac,iflag,ml,mu,epsfcn, + * wa1,wa2) + integer n,ldfjac,iflag,ml,mu + double precision epsfcn + double precision x(n),fvec(n),fjac(ldfjac,n),wa1(n),wa2(n) +c ********** +c +c subroutine fdjac1 +c +c this subroutine computes a forward-difference approximation +c to the n by n jacobian matrix associated with a specified +c problem of n functions in n variables. if the jacobian has +c a banded form, then function evaluations are saved by only +c approximating the nonzero terms. +c +c the subroutine statement is +c +c subroutine fdjac1(fcn,n,x,fvec,fjac,ldfjac,iflag,ml,mu,epsfcn, +c wa1,wa2) +c +c where +c +c fcn is the name of the user-supplied subroutine which +c calculates the functions. fcn must be declared +c in an external statement in the user calling +c program, and should be written as follows. +c +c subroutine fcn(n,x,fvec,iflag) +c integer n,iflag +c double precision x(n),fvec(n) +c ---------- +c calculate the functions at x and +c return this vector in fvec. +c ---------- +c return +c end +c +c the value of iflag should not be changed by fcn unless +c the user wants to terminate execution of fdjac1. +c in this case set iflag to a negative integer. +c +c n is a positive integer input variable set to the number +c of functions and variables. +c +c x is an input array of length n. +c +c fvec is an input array of length n which must contain the +c functions evaluated at x. +c +c fjac is an output n by n array which contains the +c approximation to the jacobian matrix evaluated at x. +c +c ldfjac is a positive integer input variable not less than n +c which specifies the leading dimension of the array fjac. +c +c iflag is an integer variable which can be used to terminate +c the execution of fdjac1. see description of fcn. +c +c ml is a nonnegative integer input variable which specifies +c the number of subdiagonals within the band of the +c jacobian matrix. if the jacobian is not banded, set +c ml to at least n - 1. +c +c epsfcn is an input variable used in determining a suitable +c step length for the forward-difference approximation. this +c approximation assumes that the relative errors in the +c functions are of the order of epsfcn. if epsfcn is less +c than the machine precision, it is assumed that the relative +c errors in the functions are of the order of the machine +c precision. +c +c mu is a nonnegative integer input variable which specifies +c the number of superdiagonals within the band of the +c jacobian matrix. if the jacobian is not banded, set +c mu to at least n - 1. +c +c wa1 and wa2 are work arrays of length n. if ml + mu + 1 is at +c least n, then the jacobian is considered dense, and wa2 is +c not referenced. +c +c subprograms called +c +c minpack-supplied ... dpmpar +c +c fortran-supplied ... dabs,dmax1,dsqrt +c +c argonne national laboratory. minpack project. march 1980. +c burton s. garbow, kenneth e. hillstrom, jorge j. more +c +c ********** + integer i,j,k,msum + double precision eps,epsmch,h,temp,zero + double precision dpmpar + data zero /0.0d0/ +c +c epsmch is the machine precision. +c + epsmch = dpmpar(1) +c + eps = dsqrt(dmax1(epsfcn,epsmch)) + msum = ml + mu + 1 + if (msum .lt. n) go to 40 +c +c computation of dense approximate jacobian. +c + do 20 j = 1, n + temp = x(j) + h = eps*dabs(temp) + if (h .eq. zero) h = eps + x(j) = temp + h + call fcn(n,x,wa1,iflag) + if (iflag .lt. 0) go to 30 + x(j) = temp + do 10 i = 1, n + fjac(i,j) = (wa1(i) - fvec(i))/h + 10 continue + 20 continue + 30 continue + go to 110 + 40 continue +c +c computation of banded approximate jacobian. +c + do 90 k = 1, msum + do 60 j = k, n, msum + wa2(j) = x(j) + h = eps*dabs(wa2(j)) + if (h .eq. zero) h = eps + x(j) = wa2(j) + h + 60 continue + call fcn(n,x,wa1,iflag) + if (iflag .lt. 0) go to 100 + do 80 j = k, n, msum + x(j) = wa2(j) + h = eps*dabs(wa2(j)) + if (h .eq. zero) h = eps + do 70 i = 1, n + fjac(i,j) = zero + if (i .ge. j - mu .and. i .le. j + ml) + * fjac(i,j) = (wa1(i) - fvec(i))/h + 70 continue + 80 continue + 90 continue + 100 continue + 110 continue + return +c +c last card of subroutine fdjac1. +c + end + diff --git a/fdjac2.f b/fdjac2.f new file mode 100644 index 0000000..218ab94 --- /dev/null +++ b/fdjac2.f @@ -0,0 +1,107 @@ + subroutine fdjac2(fcn,m,n,x,fvec,fjac,ldfjac,iflag,epsfcn,wa) + integer m,n,ldfjac,iflag + double precision epsfcn + double precision x(n),fvec(m),fjac(ldfjac,n),wa(m) +c ********** +c +c subroutine fdjac2 +c +c this subroutine computes a forward-difference approximation +c to the m by n jacobian matrix associated with a specified +c problem of m functions in n variables. +c +c the subroutine statement is +c +c subroutine fdjac2(fcn,m,n,x,fvec,fjac,ldfjac,iflag,epsfcn,wa) +c +c where +c +c fcn is the name of the user-supplied subroutine which +c calculates the functions. fcn must be declared +c in an external statement in the user calling +c program, and should be written as follows. +c +c subroutine fcn(m,n,x,fvec,iflag) +c integer m,n,iflag +c double precision x(n),fvec(m) +c ---------- +c calculate the functions at x and +c return this vector in fvec. +c ---------- +c return +c end +c +c the value of iflag should not be changed by fcn unless +c the user wants to terminate execution of fdjac2. +c in this case set iflag to a negative integer. +c +c m is a positive integer input variable set to the number +c of functions. +c +c n is a positive integer input variable set to the number +c of variables. n must not exceed m. +c +c x is an input array of length n. +c +c fvec is an input array of length m which must contain the +c functions evaluated at x. +c +c fjac is an output m by n array which contains the +c approximation to the jacobian matrix evaluated at x. +c +c ldfjac is a positive integer input variable not less than m +c which specifies the leading dimension of the array fjac. +c +c iflag is an integer variable which can be used to terminate +c the execution of fdjac2. see description of fcn. +c +c epsfcn is an input variable used in determining a suitable +c step length for the forward-difference approximation. this +c approximation assumes that the relative errors in the +c functions are of the order of epsfcn. if epsfcn is less +c than the machine precision, it is assumed that the relative +c errors in the functions are of the order of the machine +c precision. +c +c wa is a work array of length m. +c +c subprograms called +c +c user-supplied ...... fcn +c +c minpack-supplied ... dpmpar +c +c fortran-supplied ... dabs,dmax1,dsqrt +c +c argonne national laboratory. minpack project. march 1980. +c burton s. garbow, kenneth e. hillstrom, jorge j. more +c +c ********** + integer i,j + double precision eps,epsmch,h,temp,zero + double precision dpmpar + data zero /0.0d0/ +c +c epsmch is the machine precision. +c + epsmch = dpmpar(1) +c + eps = dsqrt(dmax1(epsfcn,epsmch)) + do 20 j = 1, n + temp = x(j) + h = eps*dabs(temp) + if (h .eq. zero) h = eps + x(j) = temp + h + call fcn(m,n,x,wa,iflag) + if (iflag .lt. 0) go to 30 + x(j) = temp + do 10 i = 1, m + fjac(i,j) = (wa(i) - fvec(i))/h + 10 continue + 20 continue + 30 continue + return +c +c last card of subroutine fdjac2. +c + end diff --git a/grdfcn.f b/grdfcn.f new file mode 100644 index 0000000..1dcb003 --- /dev/null +++ b/grdfcn.f @@ -0,0 +1,438 @@ + subroutine grdfcn(n,x,g,nprob) + integer n,nprob + double precision x(n),g(n) +c ********** +c +c subroutine grdfcn +c +c this subroutine defines the gradient vectors of eighteen +c nonlinear unconstrained minimization problems. the problem +c dimensions are as described in the prologue comments of objfcn. +c +c the subroutine statement is +c +c subroutine grdfcn(n,x,g,nprob) +c +c where +c +c n is a positive integer input variable. +c +c x is an input array of length n. +c +c g is an output array of length n which contains the components +c of the gradient vector of the nprob objective function +c evaluated at x. +c +c nprob is a positive integer input variable which defines the +c number of the problem. nprob must not exceed 18. +c +c subprograms called +c +c fortran-supplied ... dabs,datan,dcos,dexp,dlog,dsign,dsin, +c dsqrt +c +c argonne national laboratory. minpack project. march 1980. +c burton s. garbow, kenneth e. hillstrom, jorge j. more +c +c ********** + integer i,iev,ivar,j + double precision ap,arg,c2pdm6,cp0001,cp1,cp2,cp25,cp5,c1p5, + * c2p25,c2p625,c3p5,c19p8,c20p2,c25,c29,c100, + * c180,c200,c10000,c1pd6,d1,d2,eight,fifty,five, + * four,one,r,s1,s2,s3,t,t1,t2,t3,ten,th,three, + * tpi,twenty,two,zero + double precision fvec(50),y(15) + double precision dfloat + data zero,one,two,three,four,five,eight,ten,twenty,fifty + * /0.0d0,1.0d0,2.0d0,3.0d0,4.0d0,5.0d0,8.0d0,1.0d1,2.0d1, + * 5.0d1/ + data c2pdm6,cp0001,cp1,cp2,cp25,cp5,c1p5,c2p25,c2p625,c3p5, + * c19p8,c20p2,c25,c29,c100,c180,c200,c10000,c1pd6 + * /2.0d-6,1.0d-4,1.0d-1,2.0d-1,2.5d-1,5.0d-1,1.5d0,2.25d0, + * 2.625d0,3.5d0,1.98d1,2.02d1,2.5d1,2.9d1,1.0d2,1.8d2,2.0d2, + * 1.0d4,1.0d6/ + data ap /1.0d-5/ + data y(1),y(2),y(3),y(4),y(5),y(6),y(7),y(8),y(9),y(10),y(11), + * y(12),y(13),y(14),y(15) + * /9.0d-4,4.4d-3,1.75d-2,5.4d-2,1.295d-1,2.42d-1,3.521d-1, + * 3.989d-1,3.521d-1,2.42d-1,1.295d-1,5.4d-2,1.75d-2,4.4d-3, + * 9.0d-4/ + dfloat(ivar) = ivar +c +c gradient routine selector. +c + go to (10,20,50,70,80,100,130,190,220,260,270,290,310,350,370, + * 390,400,410), nprob +c +c helical valley function. +c + 10 continue + tpi = eight*datan(one) + th = dsign(cp25,x(2)) + if (x(1) .gt. zero) th = datan(x(2)/x(1))/tpi + if (x(1) .lt. zero) th = datan(x(2)/x(1))/tpi + cp5 + arg = x(1)**2 + x(2)**2 + r = dsqrt(arg) + t = x(3) - ten*th + s1 = ten*t/(tpi*arg) + g(1) = c200*(x(1) - x(1)/r + x(2)*s1) + g(2) = c200*(x(2) - x(2)/r - x(1)*s1) + g(3) = two*(c100*t + x(3)) + go to 490 +c +c biggs exp6 function. +c + 20 continue + do 30 j = 1, 6 + g(j) = zero + 30 continue + do 40 i = 1, 13 + d1 = dfloat(i)/ten + d2 = dexp(-d1) - five*dexp(-ten*d1) + three*dexp(-four*d1) + s1 = dexp(-d1*x(1)) + s2 = dexp(-d1*x(2)) + s3 = dexp(-d1*x(5)) + t = x(3)*s1 - x(4)*s2 + x(6)*s3 - d2 + th = d1*t + g(1) = g(1) - s1*th + g(2) = g(2) + s2*th + g(3) = g(3) + s1*t + g(4) = g(4) - s2*t + g(5) = g(5) - s3*th + g(6) = g(6) + s3*t + 40 continue + g(1) = two*x(3)*g(1) + g(2) = two*x(4)*g(2) + g(3) = two*g(3) + g(4) = two*g(4) + g(5) = two*x(6)*g(5) + g(6) = two*g(6) + go to 490 +c +c gaussian function. +c + 50 continue + g(1) = zero + g(2) = zero + g(3) = zero + do 60 i = 1, 15 + d1 = cp5*dfloat(i-1) + d2 = c3p5 - d1 - x(3) + arg = -cp5*x(2)*d2**2 + r = dexp(arg) + t = x(1)*r - y(i) + s1 = r*t + s2 = d2*s1 + g(1) = g(1) + s1 + g(2) = g(2) - d2*s2 + g(3) = g(3) + s2 + 60 continue + g(1) = two*g(1) + g(2) = x(1)*g(2) + g(3) = two*x(1)*x(2)*g(3) + go to 490 +c +c powell badly scaled function. +c + 70 continue + t1 = c10000*x(1)*x(2) - one + s1 = dexp(-x(1)) + s2 = dexp(-x(2)) + t2 = s1 + s2 - one - cp0001 + g(1) = two*(c10000*x(2)*t1 - s1*t2) + g(2) = two*(c10000*x(1)*t1 - s2*t2) + go to 490 +c +c box 3-dimensional function. +c + 80 continue + g(1) = zero + g(2) = zero + g(3) = zero + do 90 i = 1, 10 + d1 = dfloat(i) + d2 = d1/ten + s1 = dexp(-d2*x(1)) + s2 = dexp(-d2*x(2)) + s3 = dexp(-d2) - dexp(-d1) + t = s1 - s2 - s3*x(3) + th = d2*t + g(1) = g(1) - s1*th + g(2) = g(2) + s2*th + g(3) = g(3) - s3*t + 90 continue + g(1) = two*g(1) + g(2) = two*g(2) + g(3) = two*g(3) + go to 490 +c +c variably dimensioned function. +c + 100 continue + t1 = zero + do 110 j = 1, n + t1 = t1 + dfloat(j)*(x(j) - one) + 110 continue + t = t1*(one + two*t1**2) + do 120 j = 1, n + g(j) = two*(x(j) - one + dfloat(j)*t) + 120 continue + go to 490 +c +c watson function. +c + 130 continue + do 140 j = 1, n + g(j) = zero + 140 continue + do 180 i = 1, 29 + d1 = dfloat(i)/c29 + s1 = zero + d2 = one + do 150 j = 2, n + s1 = s1 + dfloat(j-1)*d2*x(j) + d2 = d1*d2 + 150 continue + s2 = zero + d2 = one + do 160 j = 1, n + s2 = s2 + d2*x(j) + d2 = d1*d2 + 160 continue + t = s1 - s2**2 - one + s3 = two*d1*s2 + d2 = two/d1 + do 170 j = 1, n + g(j) = g(j) + d2*(dfloat(j-1) - s3)*t + d2 = d1*d2 + 170 continue + 180 continue + t1 = x(2) - x(1)**2 - one + g(1) = g(1) + x(1)*(two - four*t1) + g(2) = g(2) + two*t1 + go to 490 +c +c penalty function i. +c + 190 continue + t1 = -cp25 + do 200 j = 1, n + t1 = t1 + x(j)**2 + 200 continue + d1 = two*ap + th = four*t1 + do 210 j = 1, n + g(j) = d1*(x(j) - one) + x(j)*th + 210 continue + go to 490 +c +c penalty function ii. +c + 220 continue + t1 = -one + do 230 j = 1, n + t1 = t1 + dfloat(n-j+1)*x(j)**2 + 230 continue + d1 = dexp(cp1) + d2 = one + th = four*t1 + do 250 j = 1, n + g(j) = dfloat(n-j+1)*x(j)*th + s1 = dexp(x(j)/ten) + if (j .eq. 1) go to 240 + s3 = s1 + s2 - d2*(d1 + one) + g(j) = g(j) + ap*s1*(s3 + s1 - one/d1)/five + g(j-1) = g(j-1) + ap*s2*s3/five + 240 continue + s2 = s1 + d2 = d1*d2 + 250 continue + g(1) = g(1) + two*(x(1) - cp2) + go to 490 +c +c brown badly scaled function. +c + 260 continue + t1 = x(1) - c1pd6 + t2 = x(2) - c2pdm6 + t3 = x(1)*x(2) - two + g(1) = two*(t1 + x(2)*t3) + g(2) = two*(t2 + x(1)*t3) + go to 490 +c +c brown and dennis function. +c + 270 continue + g(1) = zero + g(2) = zero + g(3) = zero + g(4) = zero + do 280 i = 1, 20 + d1 = dfloat(i)/five + d2 = dsin(d1) + t1 = x(1) + d1*x(2) - dexp(d1) + t2 = x(3) + d2*x(4) - dcos(d1) + t = t1**2 + t2**2 + s1 = t1*t + s2 = t2*t + g(1) = g(1) + s1 + g(2) = g(2) + d1*s1 + g(3) = g(3) + s2 + g(4) = g(4) + d2*s2 + 280 continue + g(1) = four*g(1) + g(2) = four*g(2) + g(3) = four*g(3) + g(4) = four*g(4) + go to 490 +c +c gulf research and development function. +c + 290 continue + g(1) = zero + g(2) = zero + g(3) = zero + d1 = two/three + do 300 i = 1, 99 + arg = dfloat(i)/c100 + r = (-fifty*dlog(arg))**d1 + c25 - x(2) + t1 = dabs(r)**x(3)/x(1) + t2 = dexp(-t1) + t = t2 - arg + s1 = t1*t2*t + g(1) = g(1) + s1 + g(2) = g(2) + s1/r + g(3) = g(3) - s1*dlog(dabs(r)) + 300 continue + g(1) = two*g(1)/x(1) + g(2) = two*x(3)*g(2) + g(3) = two*g(3) + go to 490 +c +c trigonometric function. +c + 310 continue + s1 = zero + do 320 j = 1, n + g(j) = dcos(x(j)) + s1 = s1 + g(j) + 320 continue + s2 = zero + do 330 j = 1, n + th = dsin(x(j)) + t = dfloat(n+j) - th - s1 - dfloat(j)*g(j) + s2 = s2 + t + g(j) = (dfloat(j)*th - g(j))*t + 330 continue + do 340 j = 1, n + g(j) = two*(g(j) + dsin(x(j))*s2) + 340 continue + go to 490 +c +c extended rosenbrock function. +c + 350 continue + do 360 j = 1, n, 2 + t1 = one - x(j) + g(j+1) = c200*(x(j+1) - x(j)**2) + g(j) = -two*(x(j)*g(j+1) + t1) + 360 continue + go to 490 +c +c extended powell function. +c + 370 continue + do 380 j = 1, n, 4 + t = x(j) + ten*x(j+1) + t1 = x(j+2) - x(j+3) + s1 = five*t1 + t2 = x(j+1) - two*x(j+2) + s2 = four*t2**3 + t3 = x(j) - x(j+3) + s3 = twenty*t3**3 + g(j) = two*(t + s3) + g(j+1) = twenty*t + s2 + g(j+2) = two*(s1 - s2) + g(j+3) = -two*(s1 + s3) + 380 continue + go to 490 +c +c beale function. +c + 390 continue + s1 = one - x(2) + t1 = c1p5 - x(1)*s1 + s2 = one - x(2)**2 + t2 = c2p25 - x(1)*s2 + s3 = one - x(2)**3 + t3 = c2p625 - x(1)*s3 + g(1) = -two*(s1*t1 + s2*t2 + s3*t3) + g(2) = two*x(1)*(t1 + x(2)*(two*t2 + three*x(2)*t3)) + go to 490 +c +c wood function. +c + 400 continue + s1 = x(2) - x(1)**2 + s2 = one - x(1) + s3 = x(2) - one + t1 = x(4) - x(3)**2 + t2 = one - x(3) + t3 = x(4) - one + g(1) = -two*(c200*x(1)*s1 + s2) + g(2) = c200*s1 + c20p2*s3 + c19p8*t3 + g(3) = -two*(c180*x(3)*t1 + t2) + g(4) = c180*t1 + c20p2*t3 + c19p8*s3 + go to 490 +c +c chebyquad function. +c + 410 continue + do 420 i = 1, n + fvec(i) = zero + 420 continue + do 440 j = 1, n + t1 = one + t2 = two*x(j) - one + t = two*t2 + do 430 i = 1, n + fvec(i) = fvec(i) + t2 + th = t*t2 - t1 + t1 = t2 + t2 = th + 430 continue + 440 continue + d1 = one/dfloat(n) + iev = -1 + do 450 i = 1, n + fvec(i) = d1*fvec(i) + if (iev .gt. 0) fvec(i) = fvec(i) + one/(dfloat(i)**2 - one) + iev = -iev + 450 continue + do 470 j = 1, n + g(j) = zero + t1 = one + t2 = two*x(j) - one + t = two*t2 + s1 = zero + s2 = two + do 460 i = 1, n + g(j) = g(j) + fvec(i)*s2 + th = four*t2 + t*s2 - s1 + s1 = s2 + s2 = th + th = t*t2 - t1 + t1 = t2 + t2 = th + 460 continue + 470 continue + d2 = two*d1 + do 480 j = 1, n + g(j) = d2*g(j) + 480 continue + 490 continue + return +c +c last card of subroutine grdfcn. +c + end diff --git a/hesfcn.f b/hesfcn.f new file mode 100644 index 0000000..15a8d03 --- /dev/null +++ b/hesfcn.f @@ -0,0 +1,651 @@ + subroutine hesfcn(n,x,h,ldh,nprob) + integer n,ldh,nprob + double precision x(n),h(ldh,n) +c ********** +c +c subroutine hesfcn +c +c this subroutine defines the hessian matrices of eighteen +c nonlinear unconstrained minimization problems. the problem +c dimensions are as described in the prologue comments of objfcn. +c the upper triangle of the (symmetric) hessian matrix is +c computed columnwise. storage locations below the diagonal +c are not disturbed until the final step, which reflects the +c upper triangle to fill the square matrix. +c +c the subroutine statement is +c +c subroutine hesfcn(n,x,h,ldh,nprob) +c +c where +c +c n is a positive integer input variable. +c +c x is an input array of length n. +c +c h is an n by n array. on output h contains the hessian +c matrix of the nprob objective function evaluated at x. +c +c ldh is a positive integer input variable not less than n +c which specifies the leading dimension of the array h. +c +c nprob is a positive integer input variable which defines the +c number of the problem. nprob must not exceed 18. +c +c subprograms called +c +c fortran-supplied ... dabs,datan,dcos,dexp,dlog,dsign,dsin, +c dsqrt +c +c argonne national laboratory. minpack project. march 1980. +c burton s. garbow, kenneth e. hillstrom, jorge j. more +c +c ********** + integer i,iev,ivar,j,k,n2 + double precision ap,arg,cp0001,cp1,cp25,cp5,c1p5,c2p25, + * c2p625,c3p5,c19p8,c25,c29,c100,c200,c10000,d1, + * d2,eight,fifty,five,four,one,r,s1,s2,s3,t,t1, + * t2,t3,ten,th,three,tpi,twenty,two,zero + double precision d3,r1,r2,r3,u1,u2,v,v1,v2 + double precision fvec(50),fvec1(50),y(15) + double precision dfloat + double precision six,xnine,twelve,c120,c200p2,c202,c220p2,c360, + * c400,c1200 + data six,xnine,twelve,c120,c200p2,c202,c220p2,c360,c400,c1200 + * /6.0d0,9.0d0,1.2d1,1.2d2,2.002d2,2.02d2,2.202d2,3.6d2, + * 4.0d2,1.2d3/ + data zero,one,two,three,four,five,eight,ten,twenty,fifty + * /0.0d0,1.0d0,2.0d0,3.0d0,4.0d0,5.0d0,8.0d0,1.0d1,2.0d1, + * 5.0d1/ + data cp0001,cp1,cp25,cp5,c1p5,c2p25,c2p625,c3p5,c19p8,c25,c29, + * c100,c200,c10000 + * /1.0d-4,1.0d-1,2.5d-1,5.0d-1,1.5d0,2.25d0,2.625d0,3.5d0, + * 1.98d1,2.5d1,2.9d1,1.0d2,2.0d2,1.0d4/ + data ap /1.0d-5/ + data y(1),y(2),y(3),y(4),y(5),y(6),y(7),y(8),y(9),y(10),y(11), + * y(12),y(13),y(14),y(15) + * /9.0d-4,4.4d-3,1.75d-2,5.4d-2,1.295d-1,2.42d-1,3.521d-1, + * 3.989d-1,3.521d-1,2.42d-1,1.295d-1,5.4d-2,1.75d-2,4.4d-3, + * 9.0d-4/ + dfloat(ivar) = ivar +c +c hessian routine selector. +c + go to (10,20,60,100,110,170,210,290,330,380,390,450,490,580,620, + * 660,670,680), nprob +c +c helical valley function. +c + 10 continue + tpi = eight*datan(one) + th = dsign(cp25,x(2)) + if (x(1) .gt. zero) th = datan(x(2)/x(1))/tpi + if (x(1) .lt. zero) th = datan(x(2)/x(1))/tpi + cp5 + arg = x(1)**2 + x(2)**2 + r = dsqrt(arg) + t = x(3) - ten*th + s1 = ten*t/(tpi*arg) + t1 = ten/tpi + t2 = t1/arg + t3 = (x(1)/r - t1*t2*x(1) - two*x(2)*s1)/arg + h(1,1) = c200 + * *(one - x(2)/arg*(x(2)/r - t1*t2*x(2) + two*x(1)*s1)) + h(1,2) = c200*(s1 + x(2)*t3) + h(2,2) = c200*(one - x(1)*t3) + h(1,3) = c200*t2*x(2) + h(2,3) = -c200*t2*x(1) + h(3,3) = c202 + go to 800 +c +c biggs exp6 function. +c + 20 continue + do 40 j = 1, 6 + do 30 i = 1, j + h(i,j) = zero + 30 continue + 40 continue + do 50 i = 1, 13 + d1 = dfloat(i)/ten + d2 = dexp(-d1) - five*dexp(-ten*d1) + three*dexp(-four*d1) + s1 = dexp(-d1*x(1)) + s2 = dexp(-d1*x(2)) + s3 = dexp(-d1*x(5)) + t = x(3)*s1 - x(4)*s2 + x(6)*s3 - d2 + th = d1*t + r1 = d1*s1 + r2 = d1*s2 + r3 = d1*s3 + h(1,1) = h(1,1) + r1*(th + x(3)*r1) + h(1,2) = h(1,2) - r1*r2 + h(2,2) = h(2,2) - r2*(th - x(4)*r2) + h(1,3) = h(1,3) - s1*(th + x(3)*r1) + h(3,3) = h(3,3) + s1**2 + h(1,4) = h(1,4) + r1*s2 + h(2,4) = h(2,4) + s2*(th - x(4)*r2) + h(3,4) = h(3,4) - s1*s2 + h(4,4) = h(4,4) + s2**2 + h(1,5) = h(1,5) + r1*r3 + h(2,5) = h(2,5) - r2*r3 + h(5,5) = h(5,5) + r3*(th + x(6)*r3) + h(1,6) = h(1,6) - r1*s3 + h(2,6) = h(2,6) + r2*s3 + h(3,6) = h(3,6) + s1*s3 + h(4,6) = h(4,6) - s2*s3 + h(5,6) = h(5,6) - s3*(th + x(6)*r3) + h(6,6) = h(6,6) + s3**2 + 50 continue + h(1,1) = two*x(3)*h(1,1) + h(1,2) = two*x(3)*x(4)*h(1,2) + h(2,2) = two*x(4)*h(2,2) + h(1,3) = two*h(1,3) + h(2,3) = two*x(4)*h(1,4) + h(3,3) = two*h(3,3) + h(1,4) = two*x(3)*h(1,4) + h(2,4) = two*h(2,4) + h(3,4) = two*h(3,4) + h(4,4) = two*h(4,4) + h(1,5) = two*x(3)*x(6)*h(1,5) + h(2,5) = two*x(4)*x(6)*h(2,5) + h(3,5) = two*x(6)*h(1,6) + h(4,5) = two*x(6)*h(2,6) + h(5,5) = two*x(6)*h(5,5) + h(1,6) = two*x(3)*h(1,6) + h(2,6) = two*x(4)*h(2,6) + h(3,6) = two*h(3,6) + h(4,6) = two*h(4,6) + h(5,6) = two*h(5,6) + h(6,6) = two*h(6,6) + go to 800 +c +c gaussian function. +c + 60 continue + do 80 j = 1, 3 + do 70 i = 1, j + h(i,j) = zero + 70 continue + 80 continue + do 90 i = 1, 15 + d1 = cp5*dfloat(i-1) + d2 = c3p5 - d1 - x(3) + arg = -cp5*x(2)*d2**2 + r = dexp(arg) + t = x(1)*r - y(i) + s1 = r*t + s2 = d2*s1 + t1 = s2 + d2*x(1)*r**2 + t2 = d2*t1 + h(1,1) = h(1,1) + r**2 + h(1,2) = h(1,2) - t2 + h(2,2) = h(2,2) + d2**2*t2 + h(1,3) = h(1,3) + t1 + h(2,3) = h(2,3) + two*s2 - d2*x(2)*t2 + h(3,3) = h(3,3) + x(2)*t2 - s1 + 90 continue + h(1,1) = two*h(1,1) + h(1,2) = h(1,2) + h(2,2) = cp5*x(1)*h(2,2) + h(1,3) = two*x(2)*h(1,3) + h(2,3) = x(1)*h(2,3) + h(3,3) = two*x(1)*x(2)*h(3,3) + go to 800 +c +c powell badly scaled function. +c + 100 continue + t1 = c10000*x(1)*x(2) - one + s1 = dexp(-x(1)) + s2 = dexp(-x(2)) + t2 = s1 + s2 - one - cp0001 + h(1,1) = two*((c10000*x(2))**2 + s1*(s1 + t2)) + h(1,2) = two*(c10000*(one + two*t1) + s1*s2) + h(2,2) = two*((c10000*x(1))**2 + s2*(s2 + t2)) + go to 800 +c +c box 3-dimensional function. +c + 110 continue + do 130 j = 1, 3 + do 120 i = 1, j + h(i,j) = zero + 120 continue + 130 continue + do 140 i = 1, 10 + d1 = dfloat(i) + d2 = d1/ten + s1 = dexp(-d2*x(1)) + s2 = dexp(-d2*x(2)) + s3 = dexp(-d2) - dexp(-d1) + t = s1 - s2 - s3*x(3) + th = d2*t + r1 = d2*s1 + r2 = d2*s2 + h(1,1) = h(1,1) + r1*(th + r1) + h(1,2) = h(1,2) - r1*r2 + h(2,2) = h(2,2) - r2*(th - r2) + h(1,3) = h(1,3) + r1*s3 + h(2,3) = h(2,3) - r2*s3 + h(3,3) = h(3,3) + s3**2 + 140 continue + do 160 j = 1, 3 + do 150 i = 1, j + h(i,j) = two*h(i,j) + 150 continue + 160 continue + go to 800 +c +c variably dimensioned function. +c + 170 continue + t1 = zero + do 180 j = 1, n + t1 = t1 + dfloat(j)*(x(j) - one) + 180 continue +c t = t1*(one + two*t1**2) + t2 = two + twelve*t1**2 + do 200 j = 1, n + do 190 i = 1, j + h(i,j) = dfloat(i*j)*t2 + 190 continue + h(j,j) = h(j,j) + two + 200 continue + go to 800 +c +c watson function. +c + 210 continue + do 230 j = 1, n + do 220 k = 1, j + h(k,j) = zero + 220 continue + 230 continue + do 280 i = 1, 29 + d1 = dfloat(i)/c29 + s1 = zero + d2 = one + do 240 j = 2, n + s1 = s1 + dfloat(j-1)*d2*x(j) + d2 = d1*d2 + 240 continue + s2 = zero + d2 = one + do 250 j = 1, n + s2 = s2 + d2*x(j) + d2 = d1*d2 + 250 continue + t = s1 - s2**2 - one + s3 = two*d1*s2 + d2 = two/d1 + th = two*d1**2*t + do 270 j = 1, n + v = dfloat(j-1) - s3 + d3 = one/d1 + do 260 k = 1, j + h(k,j) = h(k,j) + d2*d3*(v*(dfloat(k-1) - s3) - th) + d3 = d1*d3 + 260 continue + d2 = d1*d2 + 270 continue + 280 continue + t1 = x(2) - x(1)**2 - one + h(1,1) = h(1,1) + eight*x(1)**2 + two - four*t1 + h(1,2) = h(1,2) - four*x(1) + h(2,2) = h(2,2) + two + go to 800 +c +c penalty function i. +c + 290 continue + t1 = -cp25 + do 300 j = 1, n + t1 = t1 + x(j)**2 + 300 continue + d1 = two*ap + th = four*t1 + do 320 j = 1, n + t2 = eight*x(j) + do 310 i = 1, j + h(i,j) = x(i)*t2 + 310 continue + h(j,j) = h(j,j) + d1 + th + 320 continue + go to 800 +c +c penalty function ii. +c + 330 continue + t1 = -one + do 340 j = 1, n + t1 = t1 + dfloat(n-j+1)*x(j)**2 + 340 continue + d1 = dexp(cp1) + d2 = one + th = four*t1 + do 370 j = 1, n + t2 = eight*dfloat(n-j+1)*x(j) + do 350 i = 1, j + h(i,j) = dfloat(n-i+1)*x(i)*t2 + 350 continue + h(j,j) = h(j,j) + dfloat(n-j+1)*th + s1 = dexp(x(j)/ten) + if (j .eq. 1) go to 360 + s3 = s1 + s2 - d2*(d1 + one) + h(j,j) = h(j,j) + ap*s1*(s3 + three*s1 - one/d1)/fifty + h(j-1,j) = h(j-1,j) + ap*s1*s2/fifty + h(j-1,j-1) = h(j-1,j-1) + ap*s2*(s2 + s3)/fifty + 360 continue + s2 = s1 + d2 = d1*d2 + 370 continue + h(1,1) = h(1,1) + two + go to 800 +c +c brown badly scaled function. +c + 380 continue +c t1 = x(1) - c1pd6 +c t2 = x(2) - c2pdm6 + t3 = x(1)*x(2) - two + h(1,1) = two*(one + x(2)**2) + h(1,2) = four*(one + t3) + h(2,2) = two*(one + x(1)**2) + go to 800 +c +c brown and dennis function. +c + 390 continue + do 410 j = 1, 4 + do 400 i = 1, j + h(i,j) = zero + 400 continue + 410 continue + do 420 i = 1, 20 + d1 = dfloat(i)/five + d2 = dsin(d1) + t1 = x(1) + d1*x(2) - dexp(d1) + t2 = x(3) + d2*x(4) - dcos(d1) + t = t1**2 + t2**2 +c s1 = t1*t +c s2 = t2*t + s3 = two*t1*t2 + r1 = t + two*t1**2 + r2 = t + two*t2**2 + h(1,1) = h(1,1) + r1 + h(1,2) = h(1,2) + d1*r1 + h(2,2) = h(2,2) + d1**2*r1 + h(1,3) = h(1,3) + s3 + h(2,3) = h(2,3) + d1*s3 + h(3,3) = h(3,3) + r2 + h(1,4) = h(1,4) + d2*s3 + h(2,4) = h(2,4) + d1*d2*s3 + h(3,4) = h(3,4) + d2*r2 + h(4,4) = h(4,4) + d2**2*r2 + 420 continue + do 440 j = 1, 4 + do 430 i = 1, j + h(i,j) = four*h(i,j) + 430 continue + 440 continue + go to 800 +c +c gulf research and development function. +c + 450 continue + do 470 j = 1, 3 + do 460 i = 1, j + h(i,j) = zero + 460 continue + 470 continue + d1 = two/three + do 480 i = 1, 99 + arg = dfloat(i)/c100 + r = (-fifty*dlog(arg))**d1 + c25 - x(2) + t1 = dabs(r)**x(3)/x(1) + t2 = dexp(-t1) + t = t2 - arg + s1 = t1*t2*t + s2 = t1*(s1 + t2*(t1*t2 - t)) + r1 = dlog(dabs(r)) + r2 = r1*s2 + h(1,1) = h(1,1) + s2 - s1 + h(1,2) = h(1,2) + s2/r + h(2,2) = h(2,2) + (s1 + x(3)*s2)/r**2 + h(1,3) = h(1,3) - r2 + h(2,3) = h(2,3) + (s1 - x(3)*r2)/r + h(3,3) = h(3,3) + r1*r2 + 480 continue + h(1,1) = two*h(1,1)/x(1)**2 + h(1,2) = two*x(3)*h(1,2)/x(1) + h(2,2) = two*x(3)*h(2,2) + h(1,3) = two*h(1,3)/x(1) + h(2,3) = two*h(2,3) + h(3,3) = two*h(3,3) + go to 800 +c +c trigonometric function. +c + 490 continue + u2 = dcos(x(n)) + s1 = u2 + if (n .eq. 1) go to 510 + u1 = dcos(x(n-1)) + s1 = s1 + u1 + if (n .eq. 2) go to 510 + n2 = n - 2 + do 500 j = 1, n2 + h(j,n-1) = dcos(x(j)) + s1 = s1 + h(j,n-1) + 500 continue + 510 continue + v2 = dsin(x(n)) + s2 = dfloat(2*n) - v2 - s1 - dfloat(n)*u2 + r2 = dfloat(2*n)*v2 - u2 + if (n .eq. 1) go to 570 + v1 = dsin(x(n-1)) + s2 = s2 + dfloat(2*n-1) - v1 - s1 - dfloat(n-1)*u1 + r1 = dfloat(2*n-1)*v1 - u1 + if (n .eq. 2) go to 560 + do 520 j = 1, n2 + h(j,n) = dsin(x(j)) + t = dfloat(n+j) - h(j,n) - s1 - dfloat(j)*h(j,n-1) + s2 = s2 + t + 520 continue + do 540 j = 1, n2 + v = dfloat(j)*h(j,n-1) + h(j,n) + t = dfloat(n+j) - s1 - v + t1 = dfloat(n+j)*h(j,n) - h(j,n-1) + do 530 i = 1, j + th = dfloat(i)*h(i,n) - h(i,n-1) + h(i,j) = two*(h(i,n)*t1 + h(j,n)*th) + 530 continue + h(j,j) = h(j,j) + two*(h(j,n-1)*s2 + v*t + th**2) + 540 continue + do 550 i = 1, n2 + th = dfloat(i)*h(i,n) - h(i,n-1) + h(i,n-1) = two*(h(i,n)*r1 + v1*th) + h(i,n) = two*(h(i,n)*r2 + v2*th) + 550 continue + 560 continue + v = dfloat(n-1)*u1 + v1 + t = dfloat(2*n-1) - s1 - v + th = dfloat(n-1)*v1 - u1 + h(n-1,n-1) = two*(v1*(r1 + th) + u1*s2 + v*t + th**2) + h(n-1,n) = two*(v1*r2 + v2*th) + 570 continue + v = dfloat(n)*u2 + v2 + t = dfloat(2*n) - s1 - v + th = dfloat(n)*v2 - u2 + h(n,n) = two*(v2*(r2 + th) + u2*s2 + v*t + th**2) + go to 800 +c +c extended rosenbrock function. +c + 580 continue + do 600 j = 1, n + do 590 i = 1, j + h(i,j) = zero + 590 continue + 600 continue + do 610 j = 1, n, 2 +c t1 = one - x(j) + h(j,j) = c1200*x(j)**2 - c400*x(j+1) + two + h(j,j+1) = -c400*x(j) + h(j+1,j+1) = c200 + 610 continue + go to 800 +c +c extended powell function. +c + 620 continue + do 640 j = 1, n + do 630 i = 1, j + h(i,j) = zero + 630 continue + 640 continue + do 650 j = 1, n, 4 +c t = x(j) + ten*x(j+1) +c t1 = x(j+2) - x(j+3) +c s1 = five*t1 + t2 = x(j+1) - two*x(j+2) +c s2 = four*t2**3 + t3 = x(j) - x(j+3) +c s3 = twenty*t3**3 + r2 = twelve*t2**2 + r3 = c120*t3**2 + h(j,j) = two + r3 + h(j,j+1) = twenty + h(j+1,j+1) = c200 + r2 + h(j+1,j+2) = -two*r2 + h(j+2,j+2) = ten + four*r2 + h(j,j+3) = -r3 + h(j+2,j+3) = -ten + h(j+3,j+3) = ten + r3 + 650 continue + go to 800 +c +c beale function. +c + 660 continue + s1 = one - x(2) + t1 = c1p5 - x(1)*s1 + s2 = one - x(2)**2 + t2 = c2p25 - x(1)*s2 + s3 = one - x(2)**3 + t3 = c2p625 - x(1)*s3 + h(1,1) = two*(s1**2 + s2**2 + s3**2) + h(1,2) = two + * *(t1 + x(2)*(two*t2 + three*x(2)*t3) + * - x(1)*(s1 + x(2)*(two*s2 + three*x(2)*s3))) + h(2,2) = two*x(1) + * *(x(1) + two*t2 + * + x(2)*(six*t3 + x(1)*x(2)*(four + xnine*x(2)**2))) + go to 800 +c +c wood function. +c + 670 continue + s1 = x(2) - x(1)**2 +c s2 = one - x(1) +c s3 = x(2) - one + t1 = x(4) - x(3)**2 +c t2 = one - x(3) +c t3 = x(4) - one + h(1,1) = c400*(two*x(1)**2 - s1) + two + h(1,2) = -c400*x(1) + h(2,2) = c220p2 + h(1,3) = zero + h(2,3) = zero + h(3,3) = c360*(two*x(3)**2 - t1) + two + h(1,4) = zero + h(2,4) = c19p8 + h(3,4) = -c360*x(3) + h(4,4) = c200p2 + go to 800 +c +c chebyquad function. +c + 680 continue + do 690 i = 1, n + fvec(i) = zero + 690 continue + do 710 j = 1, n + t1 = one + t2 = two*x(j) - one + t = two*t2 + do 700 i = 1, n + fvec(i) = fvec(i) + t2 + th = t*t2 - t1 + t1 = t2 + t2 = th + 700 continue + 710 continue + d1 = one/dfloat(n) + iev = -1 + do 720 i = 1, n + fvec(i) = d1*fvec(i) + if (iev .gt. 0) fvec(i) = fvec(i) + one/(dfloat(i)**2 - one) + iev = -iev + 720 continue + do 770 j = 1, n + do 730 k = 1, j + h(k,j) = zero + 730 continue + t1 = one + t2 = two*x(j) - one + t = two*t2 + s1 = zero + s2 = two + r1 = zero + r2 = zero + do 740 i = 1, n + h(j,j) = h(j,j) + fvec(i)*r2 + th = eight*s2 + t*r2 - r1 + r1 = r2 + r2 = th + fvec1(i) = d1*s2 + th = four*t2 + t*s2 - s1 + s1 = s2 + s2 = th + th = t*t2 - t1 + t1 = t2 + t2 = th + 740 continue + do 760 k = 1, j + v1 = one + v2 = two*x(k) - one + v = two*v2 + u1 = zero + u2 = two + do 750 i = 1, n + h(k,j) = h(k,j) + fvec1(i)*u2 + th = four*v2 + v*u2 - u1 + u1 = u2 + u2 = th + th = v*v2 - v1 + v1 = v2 + v2 = th + 750 continue + 760 continue + 770 continue + d2 = two*d1 + do 790 j = 1, n + do 780 k = 1, j + h(k,j) = d2*h(k,j) + 780 continue + 790 continue +c +c reflect the upper triangle to fill the square matrix. +c + 800 continue + do 820 j = 1, n + do 810 i = j, n + h(i,j) = h(j,i) + 810 continue + 820 continue + return +c +c last card of subroutine hesfcn. +c + end + diff --git a/hybdrv.f b/hybdrv.f new file mode 100644 index 0000000..29b8b45 --- /dev/null +++ b/hybdrv.f @@ -0,0 +1,112 @@ +c ********** +c +c this program tests codes for the solution of n nonlinear +c equations in n variables. it consists of a driver and an +c interface subroutine fcn. the driver reads in data, calls the +c nonlinear equation solver, and finally prints out information +c on the performance of the solver. this is only a sample driver, +c many other drivers are possible. the interface subroutine fcn +c is necessary to take into account the forms of calling +c sequences used by the function subroutines in the various +c nonlinear equation solvers. +c +c subprograms called +c +c user-supplied ...... fcn +c +c minpack-supplied ... dpmpar,enorm,hybrd1,initpt,vecfcn +c +c fortran-supplied ... dsqrt +c +c argonne national laboratory. minpack project. march 1980. +c burton s. garbow, kenneth e. hillstrom, jorge j. more +c +c ********** + integer i,ic,info,k,lwa,n,nfev,nprob,nread,ntries,nwrite + integer na(60),nf(60),np(60),nx(60) + double precision factor,fnorm1,fnorm2,one,ten,tol + double precision fnm(60),fvec(40),wa(2660),x(40) + double precision dpmpar,enorm + external fcn + common /refnum/ nprob,nfev +c +c logical input unit is assumed to be number 5. +c logical output unit is assumed to be number 6. +c + data nread,nwrite /5,6/ +c + data one,ten /1.0d0,1.0d1/ + tol = dsqrt(dpmpar(1)) + lwa = 2660 + ic = 0 + 10 continue + read (nread,50) nprob,n,ntries + if (nprob .le. 0) go to 30 + factor = one + do 20 k = 1, ntries + ic = ic + 1 + call initpt(n,x,nprob,factor) + call vecfcn(n,x,fvec,nprob) + fnorm1 = enorm(n,fvec) + write (nwrite,60) nprob,n + nfev = 0 + call hybrd1(fcn,n,x,fvec,tol,info,wa,lwa) + fnorm2 = enorm(n,fvec) + np(ic) = nprob + na(ic) = n + nf(ic) = nfev + nx(ic) = info + fnm(ic) = fnorm2 + write (nwrite,70) fnorm1,fnorm2,nfev,info,(x(i), i = 1, n) + factor = ten*factor + 20 continue + go to 10 + 30 continue + write (nwrite,80) ic + write (nwrite,90) + do 40 i = 1, ic + write (nwrite,100) np(i),na(i),nf(i),nx(i),fnm(i) + 40 continue + stop + 50 format (3i5) + 60 format ( //// 5x, 8h problem, i5, 5x, 10h dimension, i5, 5x //) + 70 format (5x, 33h initial l2 norm of the residuals, d15.7 // 5x, + * 33h final l2 norm of the residuals , d15.7 // 5x, + * 33h number of function evaluations , i10 // 5x, + * 15h exit parameter, 18x, i10 // 5x, + * 27h final approximate solution // (5x, 5d15.7)) + 80 format (12h1summary of , i3, 16h calls to hybrd1 /) + 90 format (39h nprob n nfev info final l2 norm /) + 100 format (i4, i6, i7, i6, 1x, d15.7) +c +c last card of driver. +c + end + subroutine fcn(n,x,fvec,iflag) + integer n,iflag + double precision x(n),fvec(n) +c ********** +c +c the calling sequence of fcn should be identical to the +c calling sequence of the function subroutine in the nonlinear +c equation solver. fcn should only call the testing function +c subroutine vecfcn with the appropriate value of problem +c number (nprob). +c +c subprograms called +c +c minpack-supplied ... vecfcn +c +c argonne national laboratory. minpack project. march 1980. +c burton s. garbow, kenneth e. hillstrom, jorge j. more +c +c ********** + integer nprob,nfev + common /refnum/ nprob,nfev + call vecfcn(n,x,fvec,nprob) + nfev = nfev + 1 + return +c +c last card of interface subroutine fcn. +c + end diff --git a/hybipt.f b/hybipt.f new file mode 100644 index 0000000..5bf4d2e --- /dev/null +++ b/hybipt.f @@ -0,0 +1,167 @@ + subroutine initpt(n,x,nprob,factor) + integer n,nprob + double precision factor + double precision x(n) +c ********** +c +c subroutine initpt +c +c this subroutine specifies the standard starting points for +c the functions defined by subroutine vecfcn. the subroutine +c returns in x a multiple (factor) of the standard starting +c point. for the sixth function the standard starting point is +c zero, so in this case, if factor is not unity, then the +c subroutine returns the vector x(j) = factor, j=1,...,n. +c +c the subroutine statement is +c +c subroutine initpt(n,x,nprob,factor) +c +c where +c +c n is a positive integer input variable. +c +c x is an output array of length n which contains the standard +c starting point for problem nprob multiplied by factor. +c +c nprob is a positive integer input variable which defines the +c number of the problem. nprob must not exceed 14. +c +c factor is an input variable which specifies the multiple of +c the standard starting point. if factor is unity, no +c multiplication is performed. +c +c argonne national laboratory. minpack project. march 1980. +c burton s. garbow, kenneth e. hillstrom, jorge j. more +c +c ********** + integer ivar,j + double precision c1,h,half,one,three,tj,zero + double precision dfloat + data zero,half,one,three,c1 /0.0d0,5.0d-1,1.0d0,3.0d0,1.2d0/ + dfloat(ivar) = ivar +c +c selection of initial point. +c + go to (10,20,30,40,50,60,80,100,120,120,140,160,180,180), nprob +c +c rosenbrock function. +c + 10 continue + x(1) = -c1 + x(2) = one + go to 200 +c +c powell singular function. +c + 20 continue + x(1) = three + x(2) = -one + x(3) = zero + x(4) = one + go to 200 +c +c powell badly scaled function. +c + 30 continue + x(1) = zero + x(2) = one + go to 200 +c +c wood function. +c + 40 continue + x(1) = -three + x(2) = -one + x(3) = -three + x(4) = -one + go to 200 +c +c helical valley function. +c + 50 continue + x(1) = -one + x(2) = zero + x(3) = zero + go to 200 +c +c watson function. +c + 60 continue + do 70 j = 1, n + x(j) = zero + 70 continue + go to 200 +c +c chebyquad function. +c + 80 continue + h = one/dfloat(n+1) + do 90 j = 1, n + x(j) = dfloat(j)*h + 90 continue + go to 200 +c +c brown almost-linear function. +c + 100 continue + do 110 j = 1, n + x(j) = half + 110 continue + go to 200 +c +c discrete boundary value and integral equation functions. +c + 120 continue + h = one/dfloat(n+1) + do 130 j = 1, n + tj = dfloat(j)*h + x(j) = tj*(tj - one) + 130 continue + go to 200 +c +c trigonometric function. +c + 140 continue + h = one/dfloat(n) + do 150 j = 1, n + x(j) = h + 150 continue + go to 200 +c +c variably dimensioned function. +c + 160 continue + h = one/dfloat(n) + do 170 j = 1, n + x(j) = one - dfloat(j)*h + 170 continue + go to 200 +c +c broyden tridiagonal and banded functions. +c + 180 continue + do 190 j = 1, n + x(j) = -one + 190 continue + 200 continue +c +c compute multiple of initial point. +c + if (factor .eq. one) go to 250 + if (nprob .eq. 6) go to 220 + do 210 j = 1, n + x(j) = factor*x(j) + 210 continue + go to 240 + 220 continue + do 230 j = 1, n + x(j) = factor + 230 continue + 240 continue + 250 continue + return +c +c last card of subroutine initpt. +c + end diff --git a/hybrd.f b/hybrd.f new file mode 100644 index 0000000..fc0b4c2 --- /dev/null +++ b/hybrd.f @@ -0,0 +1,459 @@ + subroutine hybrd(fcn,n,x,fvec,xtol,maxfev,ml,mu,epsfcn,diag, + * mode,factor,nprint,info,nfev,fjac,ldfjac,r,lr, + * qtf,wa1,wa2,wa3,wa4) + integer n,maxfev,ml,mu,mode,nprint,info,nfev,ldfjac,lr + double precision xtol,epsfcn,factor + double precision x(n),fvec(n),diag(n),fjac(ldfjac,n),r(lr), + * qtf(n),wa1(n),wa2(n),wa3(n),wa4(n) + external fcn +c ********** +c +c subroutine hybrd +c +c the purpose of hybrd is to find a zero of a system of +c n nonlinear functions in n variables by a modification +c of the powell hybrid method. the user must provide a +c subroutine which calculates the functions. the jacobian is +c then calculated by a forward-difference approximation. +c +c the subroutine statement is +c +c subroutine hybrd(fcn,n,x,fvec,xtol,maxfev,ml,mu,epsfcn, +c diag,mode,factor,nprint,info,nfev,fjac, +c ldfjac,r,lr,qtf,wa1,wa2,wa3,wa4) +c +c where +c +c fcn is the name of the user-supplied subroutine which +c calculates the functions. fcn must be declared +c in an external statement in the user calling +c program, and should be written as follows. +c +c subroutine fcn(n,x,fvec,iflag) +c integer n,iflag +c double precision x(n),fvec(n) +c ---------- +c calculate the functions at x and +c return this vector in fvec. +c --------- +c return +c end +c +c the value of iflag should not be changed by fcn unless +c the user wants to terminate execution of hybrd. +c in this case set iflag to a negative integer. +c +c n is a positive integer input variable set to the number +c of functions and variables. +c +c x is an array of length n. on input x must contain +c an initial estimate of the solution vector. on output x +c contains the final estimate of the solution vector. +c +c fvec is an output array of length n which contains +c the functions evaluated at the output x. +c +c xtol is a nonnegative input variable. termination +c occurs when the relative error between two consecutive +c iterates is at most xtol. +c +c maxfev is a positive integer input variable. termination +c occurs when the number of calls to fcn is at least maxfev +c by the end of an iteration. +c +c ml is a nonnegative integer input variable which specifies +c the number of subdiagonals within the band of the +c jacobian matrix. if the jacobian is not banded, set +c ml to at least n - 1. +c +c mu is a nonnegative integer input variable which specifies +c the number of superdiagonals within the band of the +c jacobian matrix. if the jacobian is not banded, set +c mu to at least n - 1. +c +c epsfcn is an input variable used in determining a suitable +c step length for the forward-difference approximation. this +c approximation assumes that the relative errors in the +c functions are of the order of epsfcn. if epsfcn is less +c than the machine precision, it is assumed that the relative +c errors in the functions are of the order of the machine +c precision. +c +c diag is an array of length n. if mode = 1 (see +c below), diag is internally set. if mode = 2, diag +c must contain positive entries that serve as +c multiplicative scale factors for the variables. +c +c mode is an integer input variable. if mode = 1, the +c variables will be scaled internally. if mode = 2, +c the scaling is specified by the input diag. other +c values of mode are equivalent to mode = 1. +c +c factor is a positive input variable used in determining the +c initial step bound. this bound is set to the product of +c factor and the euclidean norm of diag*x if nonzero, or else +c to factor itself. in most cases factor should lie in the +c interval (.1,100.). 100. is a generally recommended value. +c +c nprint is an integer input variable that enables controlled +c printing of iterates if it is positive. in this case, +c fcn is called with iflag = 0 at the beginning of the first +c iteration and every nprint iterations thereafter and +c immediately prior to return, with x and fvec available +c for printing. if nprint is not positive, no special calls +c of fcn with iflag = 0 are made. +c +c info is an integer output variable. if the user has +c terminated execution, info is set to the (negative) +c value of iflag. see description of fcn. otherwise, +c info is set as follows. +c +c info = 0 improper input parameters. +c +c info = 1 relative error between two consecutive iterates +c is at most xtol. +c +c info = 2 number of calls to fcn has reached or exceeded +c maxfev. +c +c info = 3 xtol is too small. no further improvement in +c the approximate solution x is possible. +c +c info = 4 iteration is not making good progress, as +c measured by the improvement from the last +c five jacobian evaluations. +c +c info = 5 iteration is not making good progress, as +c measured by the improvement from the last +c ten iterations. +c +c nfev is an integer output variable set to the number of +c calls to fcn. +c +c fjac is an output n by n array which contains the +c orthogonal matrix q produced by the qr factorization +c of the final approximate jacobian. +c +c ldfjac is a positive integer input variable not less than n +c which specifies the leading dimension of the array fjac. +c +c r is an output array of length lr which contains the +c upper triangular matrix produced by the qr factorization +c of the final approximate jacobian, stored rowwise. +c +c lr is a positive integer input variable not less than +c (n*(n+1))/2. +c +c qtf is an output array of length n which contains +c the vector (q transpose)*fvec. +c +c wa1, wa2, wa3, and wa4 are work arrays of length n. +c +c subprograms called +c +c user-supplied ...... fcn +c +c minpack-supplied ... dogleg,dpmpar,enorm,fdjac1, +c qform,qrfac,r1mpyq,r1updt +c +c fortran-supplied ... dabs,dmax1,dmin1,min0,mod +c +c argonne national laboratory. minpack project. march 1980. +c burton s. garbow, kenneth e. hillstrom, jorge j. more +c +c ********** + integer i,iflag,iter,j,jm1,l,msum,ncfail,ncsuc,nslow1,nslow2 + integer iwa(1) + logical jeval,sing + double precision actred,delta,epsmch,fnorm,fnorm1,one,pnorm, + * prered,p1,p5,p001,p0001,ratio,sum,temp,xnorm, + * zero + double precision dpmpar,enorm + data one,p1,p5,p001,p0001,zero + * /1.0d0,1.0d-1,5.0d-1,1.0d-3,1.0d-4,0.0d0/ +c +c epsmch is the machine precision. +c + epsmch = dpmpar(1) +c + info = 0 + iflag = 0 + nfev = 0 +c +c check the input parameters for errors. +c + if (n .le. 0 .or. xtol .lt. zero .or. maxfev .le. 0 + * .or. ml .lt. 0 .or. mu .lt. 0 .or. factor .le. zero + * .or. ldfjac .lt. n .or. lr .lt. (n*(n + 1))/2) go to 300 + if (mode .ne. 2) go to 20 + do 10 j = 1, n + if (diag(j) .le. zero) go to 300 + 10 continue + 20 continue +c +c evaluate the function at the starting point +c and calculate its norm. +c + iflag = 1 + call fcn(n,x,fvec,iflag) + nfev = 1 + if (iflag .lt. 0) go to 300 + fnorm = enorm(n,fvec) +c +c determine the number of calls to fcn needed to compute +c the jacobian matrix. +c + msum = min0(ml+mu+1,n) +c +c initialize iteration counter and monitors. +c + iter = 1 + ncsuc = 0 + ncfail = 0 + nslow1 = 0 + nslow2 = 0 +c +c beginning of the outer loop. +c + 30 continue + jeval = .true. +c +c calculate the jacobian matrix. +c + iflag = 2 + call fdjac1(fcn,n,x,fvec,fjac,ldfjac,iflag,ml,mu,epsfcn,wa1, + * wa2) + nfev = nfev + msum + if (iflag .lt. 0) go to 300 +c +c compute the qr factorization of the jacobian. +c + call qrfac(n,n,fjac,ldfjac,.false.,iwa,1,wa1,wa2,wa3) +c +c on the first iteration and if mode is 1, scale according +c to the norms of the columns of the initial jacobian. +c + if (iter .ne. 1) go to 70 + if (mode .eq. 2) go to 50 + do 40 j = 1, n + diag(j) = wa2(j) + if (wa2(j) .eq. zero) diag(j) = one + 40 continue + 50 continue +c +c on the first iteration, calculate the norm of the scaled x +c and initialize the step bound delta. +c + do 60 j = 1, n + wa3(j) = diag(j)*x(j) + 60 continue + xnorm = enorm(n,wa3) + delta = factor*xnorm + if (delta .eq. zero) delta = factor + 70 continue +c +c form (q transpose)*fvec and store in qtf. +c + do 80 i = 1, n + qtf(i) = fvec(i) + 80 continue + do 120 j = 1, n + if (fjac(j,j) .eq. zero) go to 110 + sum = zero + do 90 i = j, n + sum = sum + fjac(i,j)*qtf(i) + 90 continue + temp = -sum/fjac(j,j) + do 100 i = j, n + qtf(i) = qtf(i) + fjac(i,j)*temp + 100 continue + 110 continue + 120 continue +c +c copy the triangular factor of the qr factorization into r. +c + sing = .false. + do 150 j = 1, n + l = j + jm1 = j - 1 + if (jm1 .lt. 1) go to 140 + do 130 i = 1, jm1 + r(l) = fjac(i,j) + l = l + n - i + 130 continue + 140 continue + r(l) = wa1(j) + if (wa1(j) .eq. zero) sing = .true. + 150 continue +c +c accumulate the orthogonal factor in fjac. +c + call qform(n,n,fjac,ldfjac,wa1) +c +c rescale if necessary. +c + if (mode .eq. 2) go to 170 + do 160 j = 1, n + diag(j) = dmax1(diag(j),wa2(j)) + 160 continue + 170 continue +c +c beginning of the inner loop. +c + 180 continue +c +c if requested, call fcn to enable printing of iterates. +c + if (nprint .le. 0) go to 190 + iflag = 0 + if (mod(iter-1,nprint) .eq. 0) call fcn(n,x,fvec,iflag) + if (iflag .lt. 0) go to 300 + 190 continue +c +c determine the direction p. +c + call dogleg(n,r,lr,diag,qtf,delta,wa1,wa2,wa3) +c +c store the direction p and x + p. calculate the norm of p. +c + do 200 j = 1, n + wa1(j) = -wa1(j) + wa2(j) = x(j) + wa1(j) + wa3(j) = diag(j)*wa1(j) + 200 continue + pnorm = enorm(n,wa3) +c +c on the first iteration, adjust the initial step bound. +c + if (iter .eq. 1) delta = dmin1(delta,pnorm) +c +c evaluate the function at x + p and calculate its norm. +c + iflag = 1 + call fcn(n,wa2,wa4,iflag) + nfev = nfev + 1 + if (iflag .lt. 0) go to 300 + fnorm1 = enorm(n,wa4) +c +c compute the scaled actual reduction. +c + actred = -one + if (fnorm1 .lt. fnorm) actred = one - (fnorm1/fnorm)**2 +c +c compute the scaled predicted reduction. +c + l = 1 + do 220 i = 1, n + sum = zero + do 210 j = i, n + sum = sum + r(l)*wa1(j) + l = l + 1 + 210 continue + wa3(i) = qtf(i) + sum + 220 continue + temp = enorm(n,wa3) + prered = zero + if (temp .lt. fnorm) prered = one - (temp/fnorm)**2 +c +c compute the ratio of the actual to the predicted +c reduction. +c + ratio = zero + if (prered .gt. zero) ratio = actred/prered +c +c update the step bound. +c + if (ratio .ge. p1) go to 230 + ncsuc = 0 + ncfail = ncfail + 1 + delta = p5*delta + go to 240 + 230 continue + ncfail = 0 + ncsuc = ncsuc + 1 + if (ratio .ge. p5 .or. ncsuc .gt. 1) + * delta = dmax1(delta,pnorm/p5) + if (dabs(ratio-one) .le. p1) delta = pnorm/p5 + 240 continue +c +c test for successful iteration. +c + if (ratio .lt. p0001) go to 260 +c +c successful iteration. update x, fvec, and their norms. +c + do 250 j = 1, n + x(j) = wa2(j) + wa2(j) = diag(j)*x(j) + fvec(j) = wa4(j) + 250 continue + xnorm = enorm(n,wa2) + fnorm = fnorm1 + iter = iter + 1 + 260 continue +c +c determine the progress of the iteration. +c + nslow1 = nslow1 + 1 + if (actred .ge. p001) nslow1 = 0 + if (jeval) nslow2 = nslow2 + 1 + if (actred .ge. p1) nslow2 = 0 +c +c test for convergence. +c + if (delta .le. xtol*xnorm .or. fnorm .eq. zero) info = 1 + if (info .ne. 0) go to 300 +c +c tests for termination and stringent tolerances. +c + if (nfev .ge. maxfev) info = 2 + if (p1*dmax1(p1*delta,pnorm) .le. epsmch*xnorm) info = 3 + if (nslow2 .eq. 5) info = 4 + if (nslow1 .eq. 10) info = 5 + if (info .ne. 0) go to 300 +c +c criterion for recalculating jacobian approximation +c by forward differences. +c + if (ncfail .eq. 2) go to 290 +c +c calculate the rank one modification to the jacobian +c and update qtf if necessary. +c + do 280 j = 1, n + sum = zero + do 270 i = 1, n + sum = sum + fjac(i,j)*wa4(i) + 270 continue + wa2(j) = (sum - wa3(j))/pnorm + wa1(j) = diag(j)*((diag(j)*wa1(j))/pnorm) + if (ratio .ge. p0001) qtf(j) = sum + 280 continue +c +c compute the qr factorization of the updated jacobian. +c + call r1updt(n,n,r,lr,wa1,wa2,wa3,sing) + call r1mpyq(n,n,fjac,ldfjac,wa2,wa3) + call r1mpyq(1,n,qtf,1,wa2,wa3) +c +c end of the inner loop. +c + jeval = .false. + go to 180 + 290 continue +c +c end of the outer loop. +c + go to 30 + 300 continue +c +c termination, either normal or user imposed. +c + if (iflag .lt. 0) info = iflag + iflag = 0 + if (nprint .gt. 0) call fcn(n,x,fvec,iflag) + return +c +c last card of subroutine hybrd. +c + end diff --git a/hybrd1.f b/hybrd1.f new file mode 100644 index 0000000..c0a8592 --- /dev/null +++ b/hybrd1.f @@ -0,0 +1,123 @@ + subroutine hybrd1(fcn,n,x,fvec,tol,info,wa,lwa) + integer n,info,lwa + double precision tol + double precision x(n),fvec(n),wa(lwa) + external fcn +c ********** +c +c subroutine hybrd1 +c +c the purpose of hybrd1 is to find a zero of a system of +c n nonlinear functions in n variables by a modification +c of the powell hybrid method. this is done by using the +c more general nonlinear equation solver hybrd. the user +c must provide a subroutine which calculates the functions. +c the jacobian is then calculated by a forward-difference +c approximation. +c +c the subroutine statement is +c +c subroutine hybrd1(fcn,n,x,fvec,tol,info,wa,lwa) +c +c where +c +c fcn is the name of the user-supplied subroutine which +c calculates the functions. fcn must be declared +c in an external statement in the user calling +c program, and should be written as follows. +c +c subroutine fcn(n,x,fvec,iflag) +c integer n,iflag +c double precision x(n),fvec(n) +c ---------- +c calculate the functions at x and +c return this vector in fvec. +c --------- +c return +c end +c +c the value of iflag should not be changed by fcn unless +c the user wants to terminate execution of hybrd1. +c in this case set iflag to a negative integer. +c +c n is a positive integer input variable set to the number +c of functions and variables. +c +c x is an array of length n. on input x must contain +c an initial estimate of the solution vector. on output x +c contains the final estimate of the solution vector. +c +c fvec is an output array of length n which contains +c the functions evaluated at the output x. +c +c tol is a nonnegative input variable. termination occurs +c when the algorithm estimates that the relative error +c between x and the solution is at most tol. +c +c info is an integer output variable. if the user has +c terminated execution, info is set to the (negative) +c value of iflag. see description of fcn. otherwise, +c info is set as follows. +c +c info = 0 improper input parameters. +c +c info = 1 algorithm estimates that the relative error +c between x and the solution is at most tol. +c +c info = 2 number of calls to fcn has reached or exceeded +c 200*(n+1). +c +c info = 3 tol is too small. no further improvement in +c the approximate solution x is possible. +c +c info = 4 iteration is not making good progress. +c +c wa is a work array of length lwa. +c +c lwa is a positive integer input variable not less than +c (n*(3*n+13))/2. +c +c subprograms called +c +c user-supplied ...... fcn +c +c minpack-supplied ... hybrd +c +c argonne national laboratory. minpack project. march 1980. +c burton s. garbow, kenneth e. hillstrom, jorge j. more +c +c ********** + integer index,j,lr,maxfev,ml,mode,mu,nfev,nprint + double precision epsfcn,factor,one,xtol,zero + data factor,one,zero /1.0d2,1.0d0,0.0d0/ + info = 0 +c +c check the input parameters for errors. +c + if (n .le. 0 .or. tol .lt. zero .or. lwa .lt. (n*(3*n + 13))/2) + * go to 20 +c +c call hybrd. +c + maxfev = 200*(n + 1) + xtol = tol + ml = n - 1 + mu = n - 1 + epsfcn = zero + mode = 2 + do 10 j = 1, n + wa(j) = one + 10 continue + nprint = 0 + lr = (n*(n + 1))/2 + index = 6*n + lr + call hybrd(fcn,n,x,fvec,xtol,maxfev,ml,mu,epsfcn,wa(1),mode, + * factor,nprint,info,nfev,wa(index+1),n,wa(6*n+1),lr, + * wa(n+1),wa(2*n+1),wa(3*n+1),wa(4*n+1),wa(5*n+1)) + if (info .eq. 5) info = 4 + 20 continue + return +c +c last card of subroutine hybrd1. +c + end diff --git a/hybrj.f b/hybrj.f new file mode 100644 index 0000000..3070dad --- /dev/null +++ b/hybrj.f @@ -0,0 +1,440 @@ + subroutine hybrj(fcn,n,x,fvec,fjac,ldfjac,xtol,maxfev,diag,mode, + * factor,nprint,info,nfev,njev,r,lr,qtf,wa1,wa2, + * wa3,wa4) + integer n,ldfjac,maxfev,mode,nprint,info,nfev,njev,lr + double precision xtol,factor + double precision x(n),fvec(n),fjac(ldfjac,n),diag(n),r(lr), + * qtf(n),wa1(n),wa2(n),wa3(n),wa4(n) +c ********** +c +c subroutine hybrj +c +c the purpose of hybrj is to find a zero of a system of +c n nonlinear functions in n variables by a modification +c of the powell hybrid method. the user must provide a +c subroutine which calculates the functions and the jacobian. +c +c the subroutine statement is +c +c subroutine hybrj(fcn,n,x,fvec,fjac,ldfjac,xtol,maxfev,diag, +c mode,factor,nprint,info,nfev,njev,r,lr,qtf, +c wa1,wa2,wa3,wa4) +c +c where +c +c fcn is the name of the user-supplied subroutine which +c calculates the functions and the jacobian. fcn must +c be declared in an external statement in the user +c calling program, and should be written as follows. +c +c subroutine fcn(n,x,fvec,fjac,ldfjac,iflag) +c integer n,ldfjac,iflag +c double precision x(n),fvec(n),fjac(ldfjac,n) +c ---------- +c if iflag = 1 calculate the functions at x and +c return this vector in fvec. do not alter fjac. +c if iflag = 2 calculate the jacobian at x and +c return this matrix in fjac. do not alter fvec. +c --------- +c return +c end +c +c the value of iflag should not be changed by fcn unless +c the user wants to terminate execution of hybrj. +c in this case set iflag to a negative integer. +c +c n is a positive integer input variable set to the number +c of functions and variables. +c +c x is an array of length n. on input x must contain +c an initial estimate of the solution vector. on output x +c contains the final estimate of the solution vector. +c +c fvec is an output array of length n which contains +c the functions evaluated at the output x. +c +c fjac is an output n by n array which contains the +c orthogonal matrix q produced by the qr factorization +c of the final approximate jacobian. +c +c ldfjac is a positive integer input variable not less than n +c which specifies the leading dimension of the array fjac. +c +c xtol is a nonnegative input variable. termination +c occurs when the relative error between two consecutive +c iterates is at most xtol. +c +c maxfev is a positive integer input variable. termination +c occurs when the number of calls to fcn with iflag = 1 +c has reached maxfev. +c +c diag is an array of length n. if mode = 1 (see +c below), diag is internally set. if mode = 2, diag +c must contain positive entries that serve as +c multiplicative scale factors for the variables. +c +c mode is an integer input variable. if mode = 1, the +c variables will be scaled internally. if mode = 2, +c the scaling is specified by the input diag. other +c values of mode are equivalent to mode = 1. +c +c factor is a positive input variable used in determining the +c initial step bound. this bound is set to the product of +c factor and the euclidean norm of diag*x if nonzero, or else +c to factor itself. in most cases factor should lie in the +c interval (.1,100.). 100. is a generally recommended value. +c +c nprint is an integer input variable that enables controlled +c printing of iterates if it is positive. in this case, +c fcn is called with iflag = 0 at the beginning of the first +c iteration and every nprint iterations thereafter and +c immediately prior to return, with x and fvec available +c for printing. fvec and fjac should not be altered. +c if nprint is not positive, no special calls of fcn +c with iflag = 0 are made. +c +c info is an integer output variable. if the user has +c terminated execution, info is set to the (negative) +c value of iflag. see description of fcn. otherwise, +c info is set as follows. +c +c info = 0 improper input parameters. +c +c info = 1 relative error between two consecutive iterates +c is at most xtol. +c +c info = 2 number of calls to fcn with iflag = 1 has +c reached maxfev. +c +c info = 3 xtol is too small. no further improvement in +c the approximate solution x is possible. +c +c info = 4 iteration is not making good progress, as +c measured by the improvement from the last +c five jacobian evaluations. +c +c info = 5 iteration is not making good progress, as +c measured by the improvement from the last +c ten iterations. +c +c nfev is an integer output variable set to the number of +c calls to fcn with iflag = 1. +c +c njev is an integer output variable set to the number of +c calls to fcn with iflag = 2. +c +c r is an output array of length lr which contains the +c upper triangular matrix produced by the qr factorization +c of the final approximate jacobian, stored rowwise. +c +c lr is a positive integer input variable not less than +c (n*(n+1))/2. +c +c qtf is an output array of length n which contains +c the vector (q transpose)*fvec. +c +c wa1, wa2, wa3, and wa4 are work arrays of length n. +c +c subprograms called +c +c user-supplied ...... fcn +c +c minpack-supplied ... dogleg,dpmpar,enorm, +c qform,qrfac,r1mpyq,r1updt +c +c fortran-supplied ... dabs,dmax1,dmin1,mod +c +c argonne national laboratory. minpack project. march 1980. +c burton s. garbow, kenneth e. hillstrom, jorge j. more +c +c ********** + integer i,iflag,iter,j,jm1,l,ncfail,ncsuc,nslow1,nslow2 + integer iwa(1) + logical jeval,sing + double precision actred,delta,epsmch,fnorm,fnorm1,one,pnorm, + * prered,p1,p5,p001,p0001,ratio,sum,temp,xnorm, + * zero + double precision dpmpar,enorm + data one,p1,p5,p001,p0001,zero + * /1.0d0,1.0d-1,5.0d-1,1.0d-3,1.0d-4,0.0d0/ +c +c epsmch is the machine precision. +c + epsmch = dpmpar(1) +c + info = 0 + iflag = 0 + nfev = 0 + njev = 0 +c +c check the input parameters for errors. +c + if (n .le. 0 .or. ldfjac .lt. n .or. xtol .lt. zero + * .or. maxfev .le. 0 .or. factor .le. zero + * .or. lr .lt. (n*(n + 1))/2) go to 300 + if (mode .ne. 2) go to 20 + do 10 j = 1, n + if (diag(j) .le. zero) go to 300 + 10 continue + 20 continue +c +c evaluate the function at the starting point +c and calculate its norm. +c + iflag = 1 + call fcn(n,x,fvec,fjac,ldfjac,iflag) + nfev = 1 + if (iflag .lt. 0) go to 300 + fnorm = enorm(n,fvec) +c +c initialize iteration counter and monitors. +c + iter = 1 + ncsuc = 0 + ncfail = 0 + nslow1 = 0 + nslow2 = 0 +c +c beginning of the outer loop. +c + 30 continue + jeval = .true. +c +c calculate the jacobian matrix. +c + iflag = 2 + call fcn(n,x,fvec,fjac,ldfjac,iflag) + njev = njev + 1 + if (iflag .lt. 0) go to 300 +c +c compute the qr factorization of the jacobian. +c + call qrfac(n,n,fjac,ldfjac,.false.,iwa,1,wa1,wa2,wa3) +c +c on the first iteration and if mode is 1, scale according +c to the norms of the columns of the initial jacobian. +c + if (iter .ne. 1) go to 70 + if (mode .eq. 2) go to 50 + do 40 j = 1, n + diag(j) = wa2(j) + if (wa2(j) .eq. zero) diag(j) = one + 40 continue + 50 continue +c +c on the first iteration, calculate the norm of the scaled x +c and initialize the step bound delta. +c + do 60 j = 1, n + wa3(j) = diag(j)*x(j) + 60 continue + xnorm = enorm(n,wa3) + delta = factor*xnorm + if (delta .eq. zero) delta = factor + 70 continue +c +c form (q transpose)*fvec and store in qtf. +c + do 80 i = 1, n + qtf(i) = fvec(i) + 80 continue + do 120 j = 1, n + if (fjac(j,j) .eq. zero) go to 110 + sum = zero + do 90 i = j, n + sum = sum + fjac(i,j)*qtf(i) + 90 continue + temp = -sum/fjac(j,j) + do 100 i = j, n + qtf(i) = qtf(i) + fjac(i,j)*temp + 100 continue + 110 continue + 120 continue +c +c copy the triangular factor of the qr factorization into r. +c + sing = .false. + do 150 j = 1, n + l = j + jm1 = j - 1 + if (jm1 .lt. 1) go to 140 + do 130 i = 1, jm1 + r(l) = fjac(i,j) + l = l + n - i + 130 continue + 140 continue + r(l) = wa1(j) + if (wa1(j) .eq. zero) sing = .true. + 150 continue +c +c accumulate the orthogonal factor in fjac. +c + call qform(n,n,fjac,ldfjac,wa1) +c +c rescale if necessary. +c + if (mode .eq. 2) go to 170 + do 160 j = 1, n + diag(j) = dmax1(diag(j),wa2(j)) + 160 continue + 170 continue +c +c beginning of the inner loop. +c + 180 continue +c +c if requested, call fcn to enable printing of iterates. +c + if (nprint .le. 0) go to 190 + iflag = 0 + if (mod(iter-1,nprint) .eq. 0) + * call fcn(n,x,fvec,fjac,ldfjac,iflag) + if (iflag .lt. 0) go to 300 + 190 continue +c +c determine the direction p. +c + call dogleg(n,r,lr,diag,qtf,delta,wa1,wa2,wa3) +c +c store the direction p and x + p. calculate the norm of p. +c + do 200 j = 1, n + wa1(j) = -wa1(j) + wa2(j) = x(j) + wa1(j) + wa3(j) = diag(j)*wa1(j) + 200 continue + pnorm = enorm(n,wa3) +c +c on the first iteration, adjust the initial step bound. +c + if (iter .eq. 1) delta = dmin1(delta,pnorm) +c +c evaluate the function at x + p and calculate its norm. +c + iflag = 1 + call fcn(n,wa2,wa4,fjac,ldfjac,iflag) + nfev = nfev + 1 + if (iflag .lt. 0) go to 300 + fnorm1 = enorm(n,wa4) +c +c compute the scaled actual reduction. +c + actred = -one + if (fnorm1 .lt. fnorm) actred = one - (fnorm1/fnorm)**2 +c +c compute the scaled predicted reduction. +c + l = 1 + do 220 i = 1, n + sum = zero + do 210 j = i, n + sum = sum + r(l)*wa1(j) + l = l + 1 + 210 continue + wa3(i) = qtf(i) + sum + 220 continue + temp = enorm(n,wa3) + prered = zero + if (temp .lt. fnorm) prered = one - (temp/fnorm)**2 +c +c compute the ratio of the actual to the predicted +c reduction. +c + ratio = zero + if (prered .gt. zero) ratio = actred/prered +c +c update the step bound. +c + if (ratio .ge. p1) go to 230 + ncsuc = 0 + ncfail = ncfail + 1 + delta = p5*delta + go to 240 + 230 continue + ncfail = 0 + ncsuc = ncsuc + 1 + if (ratio .ge. p5 .or. ncsuc .gt. 1) + * delta = dmax1(delta,pnorm/p5) + if (dabs(ratio-one) .le. p1) delta = pnorm/p5 + 240 continue +c +c test for successful iteration. +c + if (ratio .lt. p0001) go to 260 +c +c successful iteration. update x, fvec, and their norms. +c + do 250 j = 1, n + x(j) = wa2(j) + wa2(j) = diag(j)*x(j) + fvec(j) = wa4(j) + 250 continue + xnorm = enorm(n,wa2) + fnorm = fnorm1 + iter = iter + 1 + 260 continue +c +c determine the progress of the iteration. +c + nslow1 = nslow1 + 1 + if (actred .ge. p001) nslow1 = 0 + if (jeval) nslow2 = nslow2 + 1 + if (actred .ge. p1) nslow2 = 0 +c +c test for convergence. +c + if (delta .le. xtol*xnorm .or. fnorm .eq. zero) info = 1 + if (info .ne. 0) go to 300 +c +c tests for termination and stringent tolerances. +c + if (nfev .ge. maxfev) info = 2 + if (p1*dmax1(p1*delta,pnorm) .le. epsmch*xnorm) info = 3 + if (nslow2 .eq. 5) info = 4 + if (nslow1 .eq. 10) info = 5 + if (info .ne. 0) go to 300 +c +c criterion for recalculating jacobian. +c + if (ncfail .eq. 2) go to 290 +c +c calculate the rank one modification to the jacobian +c and update qtf if necessary. +c + do 280 j = 1, n + sum = zero + do 270 i = 1, n + sum = sum + fjac(i,j)*wa4(i) + 270 continue + wa2(j) = (sum - wa3(j))/pnorm + wa1(j) = diag(j)*((diag(j)*wa1(j))/pnorm) + if (ratio .ge. p0001) qtf(j) = sum + 280 continue +c +c compute the qr factorization of the updated jacobian. +c + call r1updt(n,n,r,lr,wa1,wa2,wa3,sing) + call r1mpyq(n,n,fjac,ldfjac,wa2,wa3) + call r1mpyq(1,n,qtf,1,wa2,wa3) +c +c end of the inner loop. +c + jeval = .false. + go to 180 + 290 continue +c +c end of the outer loop. +c + go to 30 + 300 continue +c +c termination, either normal or user imposed. +c + if (iflag .lt. 0) info = iflag + iflag = 0 + if (nprint .gt. 0) call fcn(n,x,fvec,fjac,ldfjac,iflag) + return +c +c last card of subroutine hybrj. +c + end diff --git a/hybrj1.f b/hybrj1.f new file mode 100644 index 0000000..9f51c49 --- /dev/null +++ b/hybrj1.f @@ -0,0 +1,127 @@ + subroutine hybrj1(fcn,n,x,fvec,fjac,ldfjac,tol,info,wa,lwa) + integer n,ldfjac,info,lwa + double precision tol + double precision x(n),fvec(n),fjac(ldfjac,n),wa(lwa) + external fcn +c ********** +c +c subroutine hybrj1 +c +c the purpose of hybrj1 is to find a zero of a system of +c n nonlinear functions in n variables by a modification +c of the powell hybrid method. this is done by using the +c more general nonlinear equation solver hybrj. the user +c must provide a subroutine which calculates the functions +c and the jacobian. +c +c the subroutine statement is +c +c subroutine hybrj1(fcn,n,x,fvec,fjac,ldfjac,tol,info,wa,lwa) +c +c where +c +c fcn is the name of the user-supplied subroutine which +c calculates the functions and the jacobian. fcn must +c be declared in an external statement in the user +c calling program, and should be written as follows. +c +c subroutine fcn(n,x,fvec,fjac,ldfjac,iflag) +c integer n,ldfjac,iflag +c double precision x(n),fvec(n),fjac(ldfjac,n) +c ---------- +c if iflag = 1 calculate the functions at x and +c return this vector in fvec. do not alter fjac. +c if iflag = 2 calculate the jacobian at x and +c return this matrix in fjac. do not alter fvec. +c --------- +c return +c end +c +c the value of iflag should not be changed by fcn unless +c the user wants to terminate execution of hybrj1. +c in this case set iflag to a negative integer. +c +c n is a positive integer input variable set to the number +c of functions and variables. +c +c x is an array of length n. on input x must contain +c an initial estimate of the solution vector. on output x +c contains the final estimate of the solution vector. +c +c fvec is an output array of length n which contains +c the functions evaluated at the output x. +c +c fjac is an output n by n array which contains the +c orthogonal matrix q produced by the qr factorization +c of the final approximate jacobian. +c +c ldfjac is a positive integer input variable not less than n +c which specifies the leading dimension of the array fjac. +c +c tol is a nonnegative input variable. termination occurs +c when the algorithm estimates that the relative error +c between x and the solution is at most tol. +c +c info is an integer output variable. if the user has +c terminated execution, info is set to the (negative) +c value of iflag. see description of fcn. otherwise, +c info is set as follows. +c +c info = 0 improper input parameters. +c +c info = 1 algorithm estimates that the relative error +c between x and the solution is at most tol. +c +c info = 2 number of calls to fcn with iflag = 1 has +c reached 100*(n+1). +c +c info = 3 tol is too small. no further improvement in +c the approximate solution x is possible. +c +c info = 4 iteration is not making good progress. +c +c wa is a work array of length lwa. +c +c lwa is a positive integer input variable not less than +c (n*(n+13))/2. +c +c subprograms called +c +c user-supplied ...... fcn +c +c minpack-supplied ... hybrj +c +c argonne national laboratory. minpack project. march 1980. +c burton s. garbow, kenneth e. hillstrom, jorge j. more +c +c ********** + integer j,lr,maxfev,mode,nfev,njev,nprint + double precision factor,one,xtol,zero + data factor,one,zero /1.0d2,1.0d0,0.0d0/ + info = 0 +c +c check the input parameters for errors. +c + if (n .le. 0 .or. ldfjac .lt. n .or. tol .lt. zero + * .or. lwa .lt. (n*(n + 13))/2) go to 20 +c +c call hybrj. +c + maxfev = 100*(n + 1) + xtol = tol + mode = 2 + do 10 j = 1, n + wa(j) = one + 10 continue + nprint = 0 + lr = (n*(n + 1))/2 + call hybrj(fcn,n,x,fvec,fjac,ldfjac,xtol,maxfev,wa(1),mode, + * factor,nprint,info,nfev,njev,wa(6*n+1),lr,wa(n+1), + * wa(2*n+1),wa(3*n+1),wa(4*n+1),wa(5*n+1)) + if (info .eq. 5) info = 4 + 20 continue + return +c +c last card of subroutine hybrj1. +c + end diff --git a/hyjdrv.f b/hyjdrv.f new file mode 100644 index 0000000..dca87ad --- /dev/null +++ b/hyjdrv.f @@ -0,0 +1,120 @@ +c ********** +c +c this program tests codes for the solution of n nonlinear +c equations in n variables. it consists of a driver and an +c interface subroutine fcn. the driver reads in data, calls the +c nonlinear equation solver, and finally prints out information +c on the performance of the solver. this is only a sample driver, +c many other drivers are possible. the interface subroutine fcn +c is necessary to take into account the forms of calling +c sequences used by the function and jacobian subroutines in +c the various nonlinear equation solvers. +c +c subprograms called +c +c user-supplied ...... fcn +c +c minpack-supplied ... dpmpar,enorm,hybrj1,initpt,vecfcn +c +c fortran-supplied ... dsqrt +c +c argonne national laboratory. minpack project. march 1980. +c burton s. garbow, kenneth e. hillstrom, jorge j. more +c +c ********** + integer i,ic,info,k,ldfjac,lwa,n,nfev,njev,nprob,nread,ntries, + 1 nwrite + integer na(60),nf(60),nj(60),np(60),nx(60) + double precision factor,fnorm1,fnorm2,one,ten,tol + double precision fnm(60),fjac(40,40),fvec(40),wa(1060),x(40) + double precision dpmpar,enorm + external fcn + common /refnum/ nprob,nfev,njev +c +c logical input unit is assumed to be number 5. +c logical output unit is assumed to be number 6. +c + data nread,nwrite /5,6/ +c + data one,ten /1.0d0,1.0d1/ + tol = dsqrt(dpmpar(1)) + ldfjac = 40 + lwa = 1060 + ic = 0 + 10 continue + read (nread,50) nprob,n,ntries + if (nprob .le. 0) go to 30 + factor = one + do 20 k = 1, ntries + ic = ic + 1 + call initpt(n,x,nprob,factor) + call vecfcn(n,x,fvec,nprob) + fnorm1 = enorm(n,fvec) + write (nwrite,60) nprob,n + nfev = 0 + njev = 0 + call hybrj1(fcn,n,x,fvec,fjac,ldfjac,tol,info,wa,lwa) + fnorm2 = enorm(n,fvec) + np(ic) = nprob + na(ic) = n + nf(ic) = nfev + nj(ic) = njev + nx(ic) = info + fnm(ic) = fnorm2 + write (nwrite,70) + 1 fnorm1,fnorm2,nfev,njev,info,(x(i), i = 1, n) + factor = ten*factor + 20 continue + go to 10 + 30 continue + write (nwrite,80) ic + write (nwrite,90) + do 40 i = 1, ic + write (nwrite,100) np(i),na(i),nf(i),nj(i),nx(i),fnm(i) + 40 continue + stop + 50 format (3i5) + 60 format ( //// 5x, 8h problem, i5, 5x, 10h dimension, i5, 5x //) + 70 format (5x, 33h initial l2 norm of the residuals, d15.7 // 5x, + 1 33h final l2 norm of the residuals , d15.7 // 5x, + 2 33h number of function evaluations , i10 // 5x, + 3 33h number of jacobian evaluations , i10 // 5x, + 4 15h exit parameter, 18x, i10 // 5x, + 5 27h final approximate solution // (5x, 5d15.7)) + 80 format (12h1summary of , i3, 16h calls to hybrj1 /) + 90 format (46h nprob n nfev njev info final l2 norm /) + 100 format (i4, i6, 2i7, i6, 1x, d15.7) +c +c last card of driver. +c + end + subroutine fcn(n,x,fvec,fjac,ldfjac,iflag) + integer n,ldfjac,iflag + double precision x(n),fvec(n),fjac(ldfjac,n) +c ********** +c +c the calling sequence of fcn should be identical to the +c calling sequence of the function subroutine in the nonlinear +c equation solver. fcn should only call the testing function +c and jacobian subroutines vecfcn and vecjac with the +c appropriate value of problem number (nprob). +c +c subprograms called +c +c minpack-supplied ... vecfcn,vecjac +c +c argonne national laboratory. minpack project. march 1980. +c burton s. garbow, kenneth e. hillstrom, jorge j. more +c +c ********** + integer nprob,nfev,njev + common /refnum/ nprob,nfev,njev + if (iflag .eq. 1) call vecfcn(n,x,fvec,nprob) + if (iflag .eq. 2) call vecjac(n,x,fjac,ldfjac,nprob) + if (iflag .eq. 1) nfev = nfev + 1 + if (iflag .eq. 2) njev = njev + 1 + return +c +c last card of interface subroutine fcn. +c + end diff --git a/ibmdpdr.f b/ibmdpdr.f new file mode 100644 index 0000000..0d76f86 --- /dev/null +++ b/ibmdpdr.f @@ -0,0 +1,72 @@ +c ********** +c +c this program checks the constants of machine precision and +c smallest and largest machine representable numbers specified in +c function dpmpar, against the corresponding hardware-determined +c machine constants obtained by dmchar, a subroutine due to +c w. j. cody. +c +c data statements in dpmpar corresponding to the machine used must +c be activated by removing c in column 1. +c +c the printed output consists of the machine constants obtained by +c dmchar and comparisons of the dpmpar constants with their +c dmchar counterparts. descriptions of the machine constants are +c given in the prologue comments of dmchar. +c +c subprograms called +c +c minpack-supplied ... dmchar,dpmpar +c +c argonne national laboratory. minpack project. march 1980. +c burton s. garbow, kenneth e. hillstrom, jorge j. more +c +c ********** + integer ibeta,iexp,irnd,it,machep,maxexp,minexp,negep,ngrd, + * nwrite + double precision dwarf,eps,epsmch,epsneg,giant,xmax,xmin + double precision rerr(3) + double precision dpmpar +c +c logical output unit is assumed to be number 6. +c + data nwrite /6/ +c +c determine the machine constants dynamically from dmchar. +c + call dmchar(ibeta,it,irnd,ngrd,machep,negep,iexp,minexp,maxexp, + * eps,epsneg,xmin,xmax) +c +c compare the dpmpar constants with their dmchar counterparts and +c store the relative differences in rerr. +c + epsmch = dpmpar(1) + dwarf = dpmpar(2) + giant = dpmpar(3) + rerr(1) = (epsmch - eps)/epsmch + rerr(2) = (dwarf - xmin)/dwarf + rerr(3) = (xmax - giant)/giant +c +c write the dmchar constants. +c + write (nwrite,10) + * ibeta,it,irnd,ngrd,machep,negep,iexp,minexp,maxexp,eps, + * epsneg,xmin,xmax +c +c write the dpmpar constants and the relative differences. +c + write (nwrite,20) epsmch,rerr(1),dwarf,rerr(2),giant,rerr(3) + stop + 10 format (17h1dmchar constants /// 8h ibeta =, i6 // 8h it =, + * i6 // 8h irnd =, i6 // 8h ngrd =, i6 // 9h machep =, + * i6 // 8h negep =, i6 // 7h iexp =, i6 // 9h minexp =, + * i6 // 9h maxexp =, i6 // 6h eps =, d15.7 // 9h epsneg =, + * d15.7 // 7h xmin =, d15.7 // 7h xmax =, d15.7) + 20 format ( /// 42h dpmpar constants and relative differences /// + * 9h epsmch =, d15.7 / 10h rerr(1) =, d15.7 // + * 8h dwarf =, d15.7 / 10h rerr(2) =, d15.7 // 8h giant =, + * d15.7 / 10h rerr(3) =, d15.7) +c +c last card of driver. +c + end diff --git a/lhesfcn.f b/lhesfcn.f new file mode 100644 index 0000000..146e272 --- /dev/null +++ b/lhesfcn.f @@ -0,0 +1,663 @@ + subroutine hesfcn(n,x,h,ldh,nprob) + integer n,ldh,nprob + double precision x(n),h(ldh) +c ********** +c +c subroutine hesfcn +c +c this subroutine defines the hessian matrices of eighteen +c nonlinear unconstrained minimization problems. the problem +c dimensions are as described in the prologue comments of objfcn. +c the upper triangle of the (symmetric) hessian matrix is +c computed columnwise and stored as a one-dimensional array. +c +c the subroutine statement is +c +c subroutine hesfcn(n,x,h,ldh,nprob) +c +c where +c +c n is a positive integer input variable. +c +c x is an input array of length n. +c +c h is an array of length ldh. on output h contains the hessian +c matrix of the nprob objective function evaluated at x. +c +c ldh is a positive integer input variable not less than +c (n*(n+1))/2 which specifies the dimension of the array h. +c +c nprob is a positive integer input variable which defines the +c number of the problem. nprob must not exceed 18. +c +c subprograms called +c +c fortran-supplied ... dabs,datan,dcos,dexp,dlog,dsign,dsin, +c dsqrt +c +c argonne national laboratory. minpack project. march 1980. +c burton s. garbow, kenneth e. hillstrom, jorge j. more +c +c ********** + integer i,iev,ivar,j,k,n2 + integer ij,ijm1,ijp1,ijp2,ijp3,ki,kip1,kj,kjp1,ntr + double precision ap,arg,cp0001,cp1,cp25,cp5,c1p5,c2p25, + * c2p625,c3p5,c19p8,c25,c29,c100,c200,c10000,d1, + * d2,eight,fifty,five,four,one,r,s1,s2,s3,t,t1, + * t2,t3,ten,th,three,tpi,twenty,two,zero + double precision d3,r1,r2,r3,u1,u2,v,v1,v2 + double precision fvec(50),fvec1(50),y(15) + double precision dfloat + double precision six,xnine,twelve,c120,c200p2,c202,c220p2,c360, + * c400,c1200 + data six,xnine,twelve,c120,c200p2,c202,c220p2,c360,c400,c1200 + * /6.0d0,9.0d0,1.2d1,1.2d2,2.002d2,2.02d2,2.202d2,3.6d2, + * 4.0d2,1.2d3/ + data zero,one,two,three,four,five,eight,ten,twenty,fifty + * /0.0d0,1.0d0,2.0d0,3.0d0,4.0d0,5.0d0,8.0d0,1.0d1,2.0d1, + * 5.0d1/ + data cp0001,cp1,cp25,cp5,c1p5,c2p25,c2p625,c3p5,c19p8,c25,c29, + * c100,c200,c10000 + * /1.0d-4,1.0d-1,2.5d-1,5.0d-1,1.5d0,2.25d0,2.625d0,3.5d0, + * 1.98d1,2.5d1,2.9d1,1.0d2,2.0d2,1.0d4/ + data ap /1.0d-5/ + data y(1),y(2),y(3),y(4),y(5),y(6),y(7),y(8),y(9),y(10),y(11), + * y(12),y(13),y(14),y(15) + * /9.0d-4,4.4d-3,1.75d-2,5.4d-2,1.295d-1,2.42d-1,3.521d-1, + * 3.989d-1,3.521d-1,2.42d-1,1.295d-1,5.4d-2,1.75d-2,4.4d-3, + * 9.0d-4/ + dfloat(ivar) = ivar +c +c hessian routine selector. +c + go to (10,20,60,100,110,170,210,290,330,380,390,450,490,580,620, + * 660,670,680), nprob +c +c helical valley function. +c + 10 continue + tpi = eight*datan(one) + th = dsign(cp25,x(2)) + if (x(1) .gt. zero) th = datan(x(2)/x(1))/tpi + if (x(1) .lt. zero) th = datan(x(2)/x(1))/tpi + cp5 + arg = x(1)**2 + x(2)**2 + r = dsqrt(arg) + t = x(3) - ten*th + s1 = ten*t/(tpi*arg) + t1 = ten/tpi + t2 = t1/arg + t3 = (x(1)/r - t1*t2*x(1) - two*x(2)*s1)/arg + h(1) = c200 + * *(one - x(2)/arg*(x(2)/r - t1*t2*x(2) + two*x(1)*s1)) + h(2) = c200*(s1 + x(2)*t3) + h(3) = c200*(one - x(1)*t3) + h(4) = c200*t2*x(2) + h(5) = -c200*t2*x(1) + h(6) = c202 + go to 800 +c +c biggs exp6 function. +c + 20 continue + do 40 ij = 1, 21 + h(ij) = zero + 40 continue + do 50 i = 1, 13 + d1 = dfloat(i)/ten + d2 = dexp(-d1) - five*dexp(-ten*d1) + three*dexp(-four*d1) + s1 = dexp(-d1*x(1)) + s2 = dexp(-d1*x(2)) + s3 = dexp(-d1*x(5)) + t = x(3)*s1 - x(4)*s2 + x(6)*s3 - d2 + th = d1*t + r1 = d1*s1 + r2 = d1*s2 + r3 = d1*s3 + h(1) = h(1) + r1*(th + x(3)*r1) + h(2) = h(2) - r1*r2 + h(3) = h(3) - r2*(th - x(4)*r2) + h(4) = h(4) - s1*(th + x(3)*r1) + h(6) = h(6) + s1**2 + h(7) = h(7) + r1*s2 + h(8) = h(8) + s2*(th - x(4)*r2) + h(9) = h(9) - s1*s2 + h(10) = h(10) + s2**2 + h(11) = h(11) + r1*r3 + h(12) = h(12) - r2*r3 + h(15) = h(15) + r3*(th + x(6)*r3) + h(16) = h(16) - r1*s3 + h(17) = h(17) + r2*s3 + h(18) = h(18) + s1*s3 + h(19) = h(19) - s2*s3 + h(20) = h(20) - s3*(th + x(6)*r3) + h(21) = h(21) + s3**2 + 50 continue + h(1) = two*x(3)*h(1) + h(2) = two*x(3)*x(4)*h(2) + h(3) = two*x(4)*h(3) + h(4) = two*h(4) + h(5) = two*x(4)*h(7) + h(6) = two*h(6) + h(7) = two*x(3)*h(7) + h(8) = two*h(8) + h(9) = two*h(9) + h(10) = two*h(10) + h(11) = two*x(3)*x(6)*h(11) + h(12) = two*x(4)*x(6)*h(12) + h(13) = two*x(6)*h(16) + h(14) = two*x(6)*h(17) + h(15) = two*x(6)*h(15) + h(16) = two*x(3)*h(16) + h(17) = two*x(4)*h(17) + h(18) = two*h(18) + h(19) = two*h(19) + h(20) = two*h(20) + h(21) = two*h(21) + go to 800 +c +c gaussian function. +c + 60 continue + do 80 ij = 1, 6 + h(ij) = zero + 80 continue + do 90 i = 1, 15 + d1 = cp5*dfloat(i-1) + d2 = c3p5 - d1 - x(3) + arg = -cp5*x(2)*d2**2 + r = dexp(arg) + t = x(1)*r - y(i) + s1 = r*t + s2 = d2*s1 + t1 = s2 + d2*x(1)*r**2 + t2 = d2*t1 + h(1) = h(1) + r**2 + h(2) = h(2) - t2 + h(3) = h(3) + d2**2*t2 + h(4) = h(4) + t1 + h(5) = h(5) + two*s2 - d2*x(2)*t2 + h(6) = h(6) + x(2)*t2 - s1 + 90 continue + h(1) = two*h(1) + h(2) = h(2) + h(3) = cp5*x(1)*h(3) + h(4) = two*x(2)*h(4) + h(5) = x(1)*h(5) + h(6) = two*x(1)*x(2)*h(6) + go to 800 +c +c powell badly scaled function. +c + 100 continue + t1 = c10000*x(1)*x(2) - one + s1 = dexp(-x(1)) + s2 = dexp(-x(2)) + t2 = s1 + s2 - one - cp0001 + h(1) = two*((c10000*x(2))**2 + s1*(s1 + t2)) + h(2) = two*(c10000*(one + two*t1) + s1*s2) + h(3) = two*((c10000*x(1))**2 + s2*(s2 + t2)) + go to 800 +c +c box 3-dimensional function. +c + 110 continue + do 130 ij = 1, 6 + h(ij) = zero + 130 continue + do 140 i = 1, 10 + d1 = dfloat(i) + d2 = d1/ten + s1 = dexp(-d2*x(1)) + s2 = dexp(-d2*x(2)) + s3 = dexp(-d2) - dexp(-d1) + t = s1 - s2 - s3*x(3) + th = d2*t + r1 = d2*s1 + r2 = d2*s2 + h(1) = h(1) + r1*(th + r1) + h(2) = h(2) - r1*r2 + h(3) = h(3) - r2*(th - r2) + h(4) = h(4) + r1*s3 + h(5) = h(5) - r2*s3 + h(6) = h(6) + s3**2 + 140 continue + do 160 ij = 1, 6 + h(ij) = two*h(ij) + 160 continue + go to 800 +c +c variably dimensioned function. +c + 170 continue + t1 = zero + do 180 j = 1, n + t1 = t1 + dfloat(j)*(x(j) - one) + 180 continue +c t = t1*(one + two*t1**2) + t2 = two + twelve*t1**2 + ij = 0 + do 200 j = 1, n + do 190 i = 1, j + ij = ij + 1 + h(ij) = dfloat(i*j)*t2 + 190 continue + h(ij) = h(ij) + two + 200 continue + go to 800 +c +c watson function. +c + 210 continue + ntr = (n*(n + 1))/2 + do 230 kj = 1, ntr + h(kj) = zero + 230 continue + do 280 i = 1, 29 + d1 = dfloat(i)/c29 + s1 = zero + d2 = one + do 240 j = 2, n + s1 = s1 + dfloat(j-1)*d2*x(j) + d2 = d1*d2 + 240 continue + s2 = zero + d2 = one + do 250 j = 1, n + s2 = s2 + d2*x(j) + d2 = d1*d2 + 250 continue + t = s1 - s2**2 - one + s3 = two*d1*s2 + d2 = two/d1 + th = two*d1**2*t + kj = 0 + do 270 j = 1, n + v = dfloat(j-1) - s3 + d3 = one/d1 + do 260 k = 1, j + kj = kj + 1 + h(kj) = h(kj) + d2*d3*(v*(dfloat(k-1) - s3) - th) + d3 = d1*d3 + 260 continue + d2 = d1*d2 + 270 continue + 280 continue + t1 = x(2) - x(1)**2 - one + h(1) = h(1) + eight*x(1)**2 + two - four*t1 + h(2) = h(2) - four*x(1) + h(3) = h(3) + two + go to 800 +c +c penalty function i. +c + 290 continue + t1 = -cp25 + do 300 j = 1, n + t1 = t1 + x(j)**2 + 300 continue + d1 = two*ap + th = four*t1 + ij = 0 + do 320 j = 1, n + t2 = eight*x(j) + do 310 i = 1, j + ij = ij + 1 + h(ij) = x(i)*t2 + 310 continue + h(ij) = h(ij) + d1 + th + 320 continue + go to 800 +c +c penalty function ii. +c + 330 continue + t1 = -one + do 340 j = 1, n + t1 = t1 + dfloat(n-j+1)*x(j)**2 + 340 continue + d1 = dexp(cp1) + d2 = one + th = four*t1 + ij = 0 + do 370 j = 1, n + t2 = eight*dfloat(n-j+1)*x(j) + do 350 i = 1, j + ij = ij + 1 + h(ij) = dfloat(n-i+1)*x(i)*t2 + 350 continue + h(ij) = h(ij) + dfloat(n-j+1)*th + s1 = dexp(x(j)/ten) + if (j .eq. 1) go to 360 + s3 = s1 + s2 - d2*(d1 + one) + h(ij) = h(ij) + ap*s1*(s3 + three*s1 - one/d1)/fifty + h(ij-1) = h(ij-1) + ap*s1*s2/fifty + h(ijm1) = h(ijm1) + ap*s2*(s2 + s3)/fifty + 360 continue + s2 = s1 + d2 = d1*d2 + ijm1 = ij + 370 continue + h(1) = h(1) + two + go to 800 +c +c brown badly scaled function. +c + 380 continue +c t1 = x(1) - c1pd6 +c t2 = x(2) - c2pdm6 + t3 = x(1)*x(2) - two + h(1) = two*(one + x(2)**2) + h(2) = four*(one + t3) + h(3) = two*(one + x(1)**2) + go to 800 +c +c brown and dennis function. +c + 390 continue + do 410 ij = 1, 10 + h(ij) = zero + 410 continue + do 420 i = 1, 20 + d1 = dfloat(i)/five + d2 = dsin(d1) + t1 = x(1) + d1*x(2) - dexp(d1) + t2 = x(3) + d2*x(4) - dcos(d1) + t = t1**2 + t2**2 +c s1 = t1*t +c s2 = t2*t + s3 = two*t1*t2 + r1 = t + two*t1**2 + r2 = t + two*t2**2 + h(1) = h(1) + r1 + h(2) = h(2) + d1*r1 + h(3) = h(3) + d1**2*r1 + h(4) = h(4) + s3 + h(5) = h(5) + d1*s3 + h(6) = h(6) + r2 + h(7) = h(7) + d2*s3 + h(8) = h(8) + d1*d2*s3 + h(9) = h(9) + d2*r2 + h(10) = h(10) + d2**2*r2 + 420 continue + do 440 ij = 1, 10 + h(ij) = four*h(ij) + 440 continue + go to 800 +c +c gulf research and development function. +c + 450 continue + do 470 ij = 1, 6 + h(ij) = zero + 470 continue + d1 = two/three + do 480 i = 1, 99 + arg = dfloat(i)/c100 + r = (-fifty*dlog(arg))**d1 + c25 - x(2) + t1 = dabs(r)**x(3)/x(1) + t2 = dexp(-t1) + t = t2 - arg + s1 = t1*t2*t + s2 = t1*(s1 + t2*(t1*t2 - t)) + r1 = dlog(dabs(r)) + r2 = r1*s2 + h(1) = h(1) + s2 - s1 + h(2) = h(2) + s2/r + h(3) = h(3) + (s1 + x(3)*s2)/r**2 + h(4) = h(4) - r2 + h(5) = h(5) + (s1 - x(3)*r2)/r + h(6) = h(6) + r1*r2 + 480 continue + h(1) = two*h(1)/x(1)**2 + h(2) = two*x(3)*h(2)/x(1) + h(3) = two*x(3)*h(3) + h(4) = two*h(4)/x(1) + h(5) = two*h(5) + h(6) = two*h(6) + go to 800 +c +c trigonometric function. +c + 490 continue + u2 = dcos(x(n)) + s1 = u2 + if (n .eq. 1) go to 510 + u1 = dcos(x(n-1)) + s1 = s1 + u1 + if (n .eq. 2) go to 510 + n2 = n - 2 + ntr = (n2*(n - 1))/2 + kj = ntr + do 500 j = 1, n2 + kj = kj + 1 + h(kj) = dcos(x(j)) + s1 = s1 + h(kj) + 500 continue + 510 continue + v2 = dsin(x(n)) + s2 = dfloat(2*n) - v2 - s1 - dfloat(n)*u2 + r2 = dfloat(2*n)*v2 - u2 + ij = 0 + if (n .eq. 1) go to 570 + v1 = dsin(x(n-1)) + s2 = s2 + dfloat(2*n-1) - v1 - s1 - dfloat(n-1)*u1 + r1 = dfloat(2*n-1)*v1 - u1 + if (n .eq. 2) go to 560 + kj = ntr + do 520 j = 1, n2 + kjp1 = kj + n + kj = kj + 1 + h(kjp1) = dsin(x(j)) + t = dfloat(n+j) - h(kjp1) - s1 - dfloat(j)*h(kj) + s2 = s2 + t + 520 continue + kj = ntr + do 540 j = 1, n2 + kjp1 = kj + n + kj = kj + 1 + v = dfloat(j)*h(kj) + h(kjp1) + t = dfloat(n+j) - s1 - v + t1 = dfloat(n+j)*h(kjp1) - h(kj) + ki = ntr + do 530 i = 1, j + ij = ij + 1 + kip1 = ki + n + ki = ki + 1 + th = dfloat(i)*h(kip1) - h(ki) + h(ij) = two*(h(kip1)*t1 + h(kjp1)*th) + 530 continue + h(ij) = h(ij) + two*(h(kj)*s2 + v*t + th**2) + 540 continue + do 550 i = 1, n2 + ijp1 = ij + n + ij = ij + 1 + th = dfloat(i)*h(ijp1) - h(ij) + h(ij) = two*(h(ijp1)*r1 + v1*th) + h(ijp1) = two*(h(ijp1)*r2 + v2*th) + 550 continue + 560 continue + v = dfloat(n-1)*u1 + v1 + t = dfloat(2*n-1) - s1 - v + th = dfloat(n-1)*v1 - u1 + ijp1 = ij + n + ij = ij + 1 + h(ij) = two*(v1*(r1 + th) + u1*s2 + v*t + th**2) + h(ijp1) = two*(v1*r2 + v2*th) + 570 continue + v = dfloat(n)*u2 + v2 + t = dfloat(2*n) - s1 - v + th = dfloat(n)*v2 - u2 + ijp1 = ij + n + h(ijp1) = two*(v2*(r2 + th) + u2*s2 + v*t + th**2) + go to 800 +c +c extended rosenbrock function. +c + 580 continue + ntr = (n*(n + 1))/2 + do 600 ij = 1, ntr + h(ij) = zero + 600 continue + ijp1 = 0 + do 610 j = 1, n, 2 +c t1 = one - x(j) + ij = ijp1 + j + ijp1 = ij + j + 1 + h(ij) = c1200*x(j)**2 - c400*x(j+1) + two + h(ijp1-1) = -c400*x(j) + h(ijp1) = c200 + 610 continue + go to 800 +c +c extended powell function. +c + 620 continue + ntr = (n*(n + 1))/2 + do 640 ij = 1, ntr + h(ij) = zero + 640 continue + ijp3 = 0 + do 650 j = 1, n, 4 +c t = x(j) + ten*x(j+1) +c t1 = x(j+2) - x(j+3) +c s1 = five*t1 + t2 = x(j+1) - two*x(j+2) +c s2 = four*t2**3 + t3 = x(j) - x(j+3) +c s3 = twenty*t3**3 + r2 = twelve*t2**2 + r3 = c120*t3**2 + ij = ijp3 + j + ijp1 = ij + j + 1 + ijp2 = ijp1 + j + 2 + ijp3 = ijp2 + j + 3 + h(ij) = two + r3 + h(ijp1-1) = twenty + h(ijp1) = c200 + r2 + h(ijp2-1) = -two*r2 + h(ijp2) = ten + four*r2 + h(ijp3-3) = -r3 + h(ijp3-1) = -ten + h(ijp3) = ten + r3 + 650 continue + go to 800 +c +c beale function. +c + 660 continue + s1 = one - x(2) + t1 = c1p5 - x(1)*s1 + s2 = one - x(2)**2 + t2 = c2p25 - x(1)*s2 + s3 = one - x(2)**3 + t3 = c2p625 - x(1)*s3 + h(1) = two*(s1**2 + s2**2 + s3**2) + h(2) = two + * *(t1 + x(2)*(two*t2 + three*x(2)*t3) + * - x(1)*(s1 + x(2)*(two*s2 + three*x(2)*s3))) + h(3) = two*x(1) + * *(x(1) + two*t2 + * + x(2)*(six*t3 + x(1)*x(2)*(four + xnine*x(2)**2))) + go to 800 +c +c wood function. +c + 670 continue + s1 = x(2) - x(1)**2 +c s2 = one - x(1) +c s3 = x(2) - one + t1 = x(4) - x(3)**2 +c t2 = one - x(3) +c t3 = x(4) - one + h(1) = c400*(two*x(1)**2 - s1) + two + h(2) = -c400*x(1) + h(3) = c220p2 + h(4) = zero + h(5) = zero + h(6) = c360*(two*x(3)**2 - t1) + two + h(7) = zero + h(8) = c19p8 + h(9) = -c360*x(3) + h(10) = c200p2 + go to 800 +c +c chebyquad function. +c + 680 continue + do 690 i = 1, n + fvec(i) = zero + 690 continue + do 710 j = 1, n + t1 = one + t2 = two*x(j) - one + t = two*t2 + do 700 i = 1, n + fvec(i) = fvec(i) + t2 + th = t*t2 - t1 + t1 = t2 + t2 = th + 700 continue + 710 continue + d1 = one/dfloat(n) + iev = -1 + do 720 i = 1, n + fvec(i) = d1*fvec(i) + if (iev .gt. 0) fvec(i) = fvec(i) + one/(dfloat(i)**2 - one) + iev = -iev + 720 continue + kj = 0 + do 770 j = 1, n + do 730 k = 1, j + kj = kj + 1 + h(kj) = zero + 730 continue + t1 = one + t2 = two*x(j) - one + t = two*t2 + s1 = zero + s2 = two + r1 = zero + r2 = zero + do 740 i = 1, n + h(kj) = h(kj) + fvec(i)*r2 + th = eight*s2 + t*r2 - r1 + r1 = r2 + r2 = th + fvec1(i) = d1*s2 + th = four*t2 + t*s2 - s1 + s1 = s2 + s2 = th + th = t*t2 - t1 + t1 = t2 + t2 = th + 740 continue + kj = kj - j + do 760 k = 1, j + kj = kj + 1 + v1 = one + v2 = two*x(k) - one + v = two*v2 + u1 = zero + u2 = two + do 750 i = 1, n + h(kj) = h(kj) + fvec1(i)*u2 + th = four*v2 + v*u2 - u1 + u1 = u2 + u2 = th + th = v*v2 - v1 + v1 = v2 + v2 = th + 750 continue + 760 continue + 770 continue + d2 = two*d1 + ntr = (n*(n + 1))/2 + do 790 kj = 1, ntr + h(kj) = d2*h(kj) + 790 continue + 800 continue + return +c +c last card of subroutine hesfcn. +c + end diff --git a/lmddrv.f b/lmddrv.f new file mode 100644 index 0000000..31a34c9 --- /dev/null +++ b/lmddrv.f @@ -0,0 +1,124 @@ +c ********** +c +c this program tests codes for the least-squares solution of +c m nonlinear equations in n variables. it consists of a driver +c and an interface subroutine fcn. the driver reads in data, +c calls the nonlinear least-squares solver, and finally prints +c out information on the performance of the solver. this is +c only a sample driver, many other drivers are possible. the +c interface subroutine fcn is necessary to take into account the +c forms of calling sequences used by the function and jacobian +c subroutines in the various nonlinear least-squares solvers. +c +c subprograms called +c +c user-supplied ...... fcn +c +c minpack-supplied ... dpmpar,enorm,initpt,lmder1,ssqfcn +c +c fortran-supplied ... dsqrt +c +c argonne national laboratory. minpack project. march 1980. +c burton s. garbow, kenneth e. hillstrom, jorge j. more +c +c ********** + integer i,ic,info,k,ldfjac,lwa,m,n,nfev,njev,nprob,nread,ntries, + * nwrite + integer iwa(40),ma(60),na(60),nf(60),nj(60),np(60),nx(60) + double precision factor,fnorm1,fnorm2,one,ten,tol + double precision fjac(65,40),fnm(60),fvec(65),wa(265),x(40) + double precision dpmpar,enorm + external fcn + common /refnum/ nprob,nfev,njev +c +c logical input unit is assumed to be number 5. +c logical output unit is assumed to be number 6. +c + data nread,nwrite /5,6/ +c + data one,ten /1.0d0,1.0d1/ + tol = dsqrt(dpmpar(1)) + ldfjac = 65 + lwa = 265 + ic = 0 + 10 continue + read (nread,50) nprob,n,m,ntries + if (nprob .le. 0) go to 30 + factor = one + do 20 k = 1, ntries + ic = ic + 1 + call initpt(n,x,nprob,factor) + call ssqfcn(m,n,x,fvec,nprob) + fnorm1 = enorm(m,fvec) + write (nwrite,60) nprob,n,m + nfev = 0 + njev = 0 + call lmder1(fcn,m,n,x,fvec,fjac,ldfjac,tol,info,iwa,wa, + * lwa) + call ssqfcn(m,n,x,fvec,nprob) + fnorm2 = enorm(m,fvec) + np(ic) = nprob + na(ic) = n + ma(ic) = m + nf(ic) = nfev + nj(ic) = njev + nx(ic) = info + fnm(ic) = fnorm2 + write (nwrite,70) + * fnorm1,fnorm2,nfev,njev,info,(x(i), i = 1, n) + factor = ten*factor + 20 continue + go to 10 + 30 continue + write (nwrite,80) ic + write (nwrite,90) + do 40 i = 1, ic + write (nwrite,100) np(i),na(i),ma(i),nf(i),nj(i),nx(i),fnm(i) + 40 continue + stop + 50 format (4i5) + 60 format ( //// 5x, 8h problem, i5, 5x, 11h dimensions, 2i5, 5x // + * ) + 70 format (5x, 33h initial l2 norm of the residuals, d15.7 // 5x, + * 33h final l2 norm of the residuals , d15.7 // 5x, + * 33h number of function evaluations , i10 // 5x, + * 33h number of jacobian evaluations , i10 // 5x, + * 15h exit parameter, 18x, i10 // 5x, + * 27h final approximate solution // (5x, 5d15.7)) + 80 format (12h1summary of , i3, 16h calls to lmder1 /) + 90 format (49h nprob n m nfev njev info final l2 norm /) + 100 format (3i5, 3i6, 1x, d15.7) +c +c last card of driver. +c + end + subroutine fcn(m,n,x,fvec,fjac,ldfjac,iflag) + integer m,n,ldfjac,iflag + double precision x(n),fvec(m),fjac(ldfjac,n) +c ********** +c +c the calling sequence of fcn should be identical to the +c calling sequence of the function subroutine in the nonlinear +c least-squares solver. fcn should only call the testing +c function and jacobian subroutines ssqfcn and ssqjac with +c the appropriate value of problem number (nprob). +c +c subprograms called +c +c minpack-supplied ... ssqfcn,ssqjac +c +c argonne national laboratory. minpack project. march 1980. +c burton s. garbow, kenneth e. hillstrom, jorge j. more +c +c ********** + integer nprob,nfev,njev + common /refnum/ nprob,nfev,njev + if (iflag .eq. 1) call ssqfcn(m,n,x,fvec,nprob) + if (iflag .eq. 2) call ssqjac(m,n,x,fjac,ldfjac,nprob) + if (iflag .eq. 1) nfev = nfev + 1 + if (iflag .eq. 2) njev = njev + 1 + return +c +c last card of interface subroutine fcn. +c + end diff --git a/lmder.f b/lmder.f new file mode 100644 index 0000000..8797d8b --- /dev/null +++ b/lmder.f @@ -0,0 +1,452 @@ + subroutine lmder(fcn,m,n,x,fvec,fjac,ldfjac,ftol,xtol,gtol, + * maxfev,diag,mode,factor,nprint,info,nfev,njev, + * ipvt,qtf,wa1,wa2,wa3,wa4) + integer m,n,ldfjac,maxfev,mode,nprint,info,nfev,njev + integer ipvt(n) + double precision ftol,xtol,gtol,factor + double precision x(n),fvec(m),fjac(ldfjac,n),diag(n),qtf(n), + * wa1(n),wa2(n),wa3(n),wa4(m) +c ********** +c +c subroutine lmder +c +c the purpose of lmder is to minimize the sum of the squares of +c m nonlinear functions in n variables by a modification of +c the levenberg-marquardt algorithm. the user must provide a +c subroutine which calculates the functions and the jacobian. +c +c the subroutine statement is +c +c subroutine lmder(fcn,m,n,x,fvec,fjac,ldfjac,ftol,xtol,gtol, +c maxfev,diag,mode,factor,nprint,info,nfev, +c njev,ipvt,qtf,wa1,wa2,wa3,wa4) +c +c where +c +c fcn is the name of the user-supplied subroutine which +c calculates the functions and the jacobian. fcn must +c be declared in an external statement in the user +c calling program, and should be written as follows. +c +c subroutine fcn(m,n,x,fvec,fjac,ldfjac,iflag) +c integer m,n,ldfjac,iflag +c double precision x(n),fvec(m),fjac(ldfjac,n) +c ---------- +c if iflag = 1 calculate the functions at x and +c return this vector in fvec. do not alter fjac. +c if iflag = 2 calculate the jacobian at x and +c return this matrix in fjac. do not alter fvec. +c ---------- +c return +c end +c +c the value of iflag should not be changed by fcn unless +c the user wants to terminate execution of lmder. +c in this case set iflag to a negative integer. +c +c m is a positive integer input variable set to the number +c of functions. +c +c n is a positive integer input variable set to the number +c of variables. n must not exceed m. +c +c x is an array of length n. on input x must contain +c an initial estimate of the solution vector. on output x +c contains the final estimate of the solution vector. +c +c fvec is an output array of length m which contains +c the functions evaluated at the output x. +c +c fjac is an output m by n array. the upper n by n submatrix +c of fjac contains an upper triangular matrix r with +c diagonal elements of nonincreasing magnitude such that +c +c t t t +c p *(jac *jac)*p = r *r, +c +c where p is a permutation matrix and jac is the final +c calculated jacobian. column j of p is column ipvt(j) +c (see below) of the identity matrix. the lower trapezoidal +c part of fjac contains information generated during +c the computation of r. +c +c ldfjac is a positive integer input variable not less than m +c which specifies the leading dimension of the array fjac. +c +c ftol is a nonnegative input variable. termination +c occurs when both the actual and predicted relative +c reductions in the sum of squares are at most ftol. +c therefore, ftol measures the relative error desired +c in the sum of squares. +c +c xtol is a nonnegative input variable. termination +c occurs when the relative error between two consecutive +c iterates is at most xtol. therefore, xtol measures the +c relative error desired in the approximate solution. +c +c gtol is a nonnegative input variable. termination +c occurs when the cosine of the angle between fvec and +c any column of the jacobian is at most gtol in absolute +c value. therefore, gtol measures the orthogonality +c desired between the function vector and the columns +c of the jacobian. +c +c maxfev is a positive integer input variable. termination +c occurs when the number of calls to fcn with iflag = 1 +c has reached maxfev. +c +c diag is an array of length n. if mode = 1 (see +c below), diag is internally set. if mode = 2, diag +c must contain positive entries that serve as +c multiplicative scale factors for the variables. +c +c mode is an integer input variable. if mode = 1, the +c variables will be scaled internally. if mode = 2, +c the scaling is specified by the input diag. other +c values of mode are equivalent to mode = 1. +c +c factor is a positive input variable used in determining the +c initial step bound. this bound is set to the product of +c factor and the euclidean norm of diag*x if nonzero, or else +c to factor itself. in most cases factor should lie in the +c interval (.1,100.).100. is a generally recommended value. +c +c nprint is an integer input variable that enables controlled +c printing of iterates if it is positive. in this case, +c fcn is called with iflag = 0 at the beginning of the first +c iteration and every nprint iterations thereafter and +c immediately prior to return, with x, fvec, and fjac +c available for printing. fvec and fjac should not be +c altered. if nprint is not positive, no special calls +c of fcn with iflag = 0 are made. +c +c info is an integer output variable. if the user has +c terminated execution, info is set to the (negative) +c value of iflag. see description of fcn. otherwise, +c info is set as follows. +c +c info = 0 improper input parameters. +c +c info = 1 both actual and predicted relative reductions +c in the sum of squares are at most ftol. +c +c info = 2 relative error between two consecutive iterates +c is at most xtol. +c +c info = 3 conditions for info = 1 and info = 2 both hold. +c +c info = 4 the cosine of the angle between fvec and any +c column of the jacobian is at most gtol in +c absolute value. +c +c info = 5 number of calls to fcn with iflag = 1 has +c reached maxfev. +c +c info = 6 ftol is too small. no further reduction in +c the sum of squares is possible. +c +c info = 7 xtol is too small. no further improvement in +c the approximate solution x is possible. +c +c info = 8 gtol is too small. fvec is orthogonal to the +c columns of the jacobian to machine precision. +c +c nfev is an integer output variable set to the number of +c calls to fcn with iflag = 1. +c +c njev is an integer output variable set to the number of +c calls to fcn with iflag = 2. +c +c ipvt is an integer output array of length n. ipvt +c defines a permutation matrix p such that jac*p = q*r, +c where jac is the final calculated jacobian, q is +c orthogonal (not stored), and r is upper triangular +c with diagonal elements of nonincreasing magnitude. +c column j of p is column ipvt(j) of the identity matrix. +c +c qtf is an output array of length n which contains +c the first n elements of the vector (q transpose)*fvec. +c +c wa1, wa2, and wa3 are work arrays of length n. +c +c wa4 is a work array of length m. +c +c subprograms called +c +c user-supplied ...... fcn +c +c minpack-supplied ... dpmpar,enorm,lmpar,qrfac +c +c fortran-supplied ... dabs,dmax1,dmin1,dsqrt,mod +c +c argonne national laboratory. minpack project. march 1980. +c burton s. garbow, kenneth e. hillstrom, jorge j. more +c +c ********** + integer i,iflag,iter,j,l + double precision actred,delta,dirder,epsmch,fnorm,fnorm1,gnorm, + * one,par,pnorm,prered,p1,p5,p25,p75,p0001,ratio, + * sum,temp,temp1,temp2,xnorm,zero + double precision dpmpar,enorm + data one,p1,p5,p25,p75,p0001,zero + * /1.0d0,1.0d-1,5.0d-1,2.5d-1,7.5d-1,1.0d-4,0.0d0/ +c +c epsmch is the machine precision. +c + epsmch = dpmpar(1) +c + info = 0 + iflag = 0 + nfev = 0 + njev = 0 +c +c check the input parameters for errors. +c + if (n .le. 0 .or. m .lt. n .or. ldfjac .lt. m + * .or. ftol .lt. zero .or. xtol .lt. zero .or. gtol .lt. zero + * .or. maxfev .le. 0 .or. factor .le. zero) go to 300 + if (mode .ne. 2) go to 20 + do 10 j = 1, n + if (diag(j) .le. zero) go to 300 + 10 continue + 20 continue +c +c evaluate the function at the starting point +c and calculate its norm. +c + iflag = 1 + call fcn(m,n,x,fvec,fjac,ldfjac,iflag) + nfev = 1 + if (iflag .lt. 0) go to 300 + fnorm = enorm(m,fvec) +c +c initialize levenberg-marquardt parameter and iteration counter. +c + par = zero + iter = 1 +c +c beginning of the outer loop. +c + 30 continue +c +c calculate the jacobian matrix. +c + iflag = 2 + call fcn(m,n,x,fvec,fjac,ldfjac,iflag) + njev = njev + 1 + if (iflag .lt. 0) go to 300 +c +c if requested, call fcn to enable printing of iterates. +c + if (nprint .le. 0) go to 40 + iflag = 0 + if (mod(iter-1,nprint) .eq. 0) + * call fcn(m,n,x,fvec,fjac,ldfjac,iflag) + if (iflag .lt. 0) go to 300 + 40 continue +c +c compute the qr factorization of the jacobian. +c + call qrfac(m,n,fjac,ldfjac,.true.,ipvt,n,wa1,wa2,wa3) +c +c on the first iteration and if mode is 1, scale according +c to the norms of the columns of the initial jacobian. +c + if (iter .ne. 1) go to 80 + if (mode .eq. 2) go to 60 + do 50 j = 1, n + diag(j) = wa2(j) + if (wa2(j) .eq. zero) diag(j) = one + 50 continue + 60 continue +c +c on the first iteration, calculate the norm of the scaled x +c and initialize the step bound delta. +c + do 70 j = 1, n + wa3(j) = diag(j)*x(j) + 70 continue + xnorm = enorm(n,wa3) + delta = factor*xnorm + if (delta .eq. zero) delta = factor + 80 continue +c +c form (q transpose)*fvec and store the first n components in +c qtf. +c + do 90 i = 1, m + wa4(i) = fvec(i) + 90 continue + do 130 j = 1, n + if (fjac(j,j) .eq. zero) go to 120 + sum = zero + do 100 i = j, m + sum = sum + fjac(i,j)*wa4(i) + 100 continue + temp = -sum/fjac(j,j) + do 110 i = j, m + wa4(i) = wa4(i) + fjac(i,j)*temp + 110 continue + 120 continue + fjac(j,j) = wa1(j) + qtf(j) = wa4(j) + 130 continue +c +c compute the norm of the scaled gradient. +c + gnorm = zero + if (fnorm .eq. zero) go to 170 + do 160 j = 1, n + l = ipvt(j) + if (wa2(l) .eq. zero) go to 150 + sum = zero + do 140 i = 1, j + sum = sum + fjac(i,j)*(qtf(i)/fnorm) + 140 continue + gnorm = dmax1(gnorm,dabs(sum/wa2(l))) + 150 continue + 160 continue + 170 continue +c +c test for convergence of the gradient norm. +c + if (gnorm .le. gtol) info = 4 + if (info .ne. 0) go to 300 +c +c rescale if necessary. +c + if (mode .eq. 2) go to 190 + do 180 j = 1, n + diag(j) = dmax1(diag(j),wa2(j)) + 180 continue + 190 continue +c +c beginning of the inner loop. +c + 200 continue +c +c determine the levenberg-marquardt parameter. +c + call lmpar(n,fjac,ldfjac,ipvt,diag,qtf,delta,par,wa1,wa2, + * wa3,wa4) +c +c store the direction p and x + p. calculate the norm of p. +c + do 210 j = 1, n + wa1(j) = -wa1(j) + wa2(j) = x(j) + wa1(j) + wa3(j) = diag(j)*wa1(j) + 210 continue + pnorm = enorm(n,wa3) +c +c on the first iteration, adjust the initial step bound. +c + if (iter .eq. 1) delta = dmin1(delta,pnorm) +c +c evaluate the function at x + p and calculate its norm. +c + iflag = 1 + call fcn(m,n,wa2,wa4,fjac,ldfjac,iflag) + nfev = nfev + 1 + if (iflag .lt. 0) go to 300 + fnorm1 = enorm(m,wa4) +c +c compute the scaled actual reduction. +c + actred = -one + if (p1*fnorm1 .lt. fnorm) actred = one - (fnorm1/fnorm)**2 +c +c compute the scaled predicted reduction and +c the scaled directional derivative. +c + do 230 j = 1, n + wa3(j) = zero + l = ipvt(j) + temp = wa1(l) + do 220 i = 1, j + wa3(i) = wa3(i) + fjac(i,j)*temp + 220 continue + 230 continue + temp1 = enorm(n,wa3)/fnorm + temp2 = (dsqrt(par)*pnorm)/fnorm + prered = temp1**2 + temp2**2/p5 + dirder = -(temp1**2 + temp2**2) +c +c compute the ratio of the actual to the predicted +c reduction. +c + ratio = zero + if (prered .ne. zero) ratio = actred/prered +c +c update the step bound. +c + if (ratio .gt. p25) go to 240 + if (actred .ge. zero) temp = p5 + if (actred .lt. zero) + * temp = p5*dirder/(dirder + p5*actred) + if (p1*fnorm1 .ge. fnorm .or. temp .lt. p1) temp = p1 + delta = temp*dmin1(delta,pnorm/p1) + par = par/temp + go to 260 + 240 continue + if (par .ne. zero .and. ratio .lt. p75) go to 250 + delta = pnorm/p5 + par = p5*par + 250 continue + 260 continue +c +c test for successful iteration. +c + if (ratio .lt. p0001) go to 290 +c +c successful iteration. update x, fvec, and their norms. +c + do 270 j = 1, n + x(j) = wa2(j) + wa2(j) = diag(j)*x(j) + 270 continue + do 280 i = 1, m + fvec(i) = wa4(i) + 280 continue + xnorm = enorm(n,wa2) + fnorm = fnorm1 + iter = iter + 1 + 290 continue +c +c tests for convergence. +c + if (dabs(actred) .le. ftol .and. prered .le. ftol + * .and. p5*ratio .le. one) info = 1 + if (delta .le. xtol*xnorm) info = 2 + if (dabs(actred) .le. ftol .and. prered .le. ftol + * .and. p5*ratio .le. one .and. info .eq. 2) info = 3 + if (info .ne. 0) go to 300 +c +c tests for termination and stringent tolerances. +c + if (nfev .ge. maxfev) info = 5 + if (dabs(actred) .le. epsmch .and. prered .le. epsmch + * .and. p5*ratio .le. one) info = 6 + if (delta .le. epsmch*xnorm) info = 7 + if (gnorm .le. epsmch) info = 8 + if (info .ne. 0) go to 300 +c +c end of the inner loop. repeat if iteration unsuccessful. +c + if (ratio .lt. p0001) go to 200 +c +c end of the outer loop. +c + go to 30 + 300 continue +c +c termination, either normal or user imposed. +c + if (iflag .lt. 0) info = iflag + iflag = 0 + if (nprint .gt. 0) call fcn(m,n,x,fvec,fjac,ldfjac,iflag) + return +c +c last card of subroutine lmder. +c + end diff --git a/lmder1.f b/lmder1.f new file mode 100644 index 0000000..d691940 --- /dev/null +++ b/lmder1.f @@ -0,0 +1,156 @@ + subroutine lmder1(fcn,m,n,x,fvec,fjac,ldfjac,tol,info,ipvt,wa, + * lwa) + integer m,n,ldfjac,info,lwa + integer ipvt(n) + double precision tol + double precision x(n),fvec(m),fjac(ldfjac,n),wa(lwa) + external fcn +c ********** +c +c subroutine lmder1 +c +c the purpose of lmder1 is to minimize the sum of the squares of +c m nonlinear functions in n variables by a modification of the +c levenberg-marquardt algorithm. this is done by using the more +c general least-squares solver lmder. the user must provide a +c subroutine which calculates the functions and the jacobian. +c +c the subroutine statement is +c +c subroutine lmder1(fcn,m,n,x,fvec,fjac,ldfjac,tol,info, +c ipvt,wa,lwa) +c +c where +c +c fcn is the name of the user-supplied subroutine which +c calculates the functions and the jacobian. fcn must +c be declared in an external statement in the user +c calling program, and should be written as follows. +c +c subroutine fcn(m,n,x,fvec,fjac,ldfjac,iflag) +c integer m,n,ldfjac,iflag +c double precision x(n),fvec(m),fjac(ldfjac,n) +c ---------- +c if iflag = 1 calculate the functions at x and +c return this vector in fvec. do not alter fjac. +c if iflag = 2 calculate the jacobian at x and +c return this matrix in fjac. do not alter fvec. +c ---------- +c return +c end +c +c the value of iflag should not be changed by fcn unless +c the user wants to terminate execution of lmder1. +c in this case set iflag to a negative integer. +c +c m is a positive integer input variable set to the number +c of functions. +c +c n is a positive integer input variable set to the number +c of variables. n must not exceed m. +c +c x is an array of length n. on input x must contain +c an initial estimate of the solution vector. on output x +c contains the final estimate of the solution vector. +c +c fvec is an output array of length m which contains +c the functions evaluated at the output x. +c +c fjac is an output m by n array. the upper n by n submatrix +c of fjac contains an upper triangular matrix r with +c diagonal elements of nonincreasing magnitude such that +c +c t t t +c p *(jac *jac)*p = r *r, +c +c where p is a permutation matrix and jac is the final +c calculated jacobian. column j of p is column ipvt(j) +c (see below) of the identity matrix. the lower trapezoidal +c part of fjac contains information generated during +c the computation of r. +c +c ldfjac is a positive integer input variable not less than m +c which specifies the leading dimension of the array fjac. +c +c tol is a nonnegative input variable. termination occurs +c when the algorithm estimates either that the relative +c error in the sum of squares is at most tol or that +c the relative error between x and the solution is at +c most tol. +c +c info is an integer output variable. if the user has +c terminated execution, info is set to the (negative) +c value of iflag. see description of fcn. otherwise, +c info is set as follows. +c +c info = 0 improper input parameters. +c +c info = 1 algorithm estimates that the relative error +c in the sum of squares is at most tol. +c +c info = 2 algorithm estimates that the relative error +c between x and the solution is at most tol. +c +c info = 3 conditions for info = 1 and info = 2 both hold. +c +c info = 4 fvec is orthogonal to the columns of the +c jacobian to machine precision. +c +c info = 5 number of calls to fcn with iflag = 1 has +c reached 100*(n+1). +c +c info = 6 tol is too small. no further reduction in +c the sum of squares is possible. +c +c info = 7 tol is too small. no further improvement in +c the approximate solution x is possible. +c +c ipvt is an integer output array of length n. ipvt +c defines a permutation matrix p such that jac*p = q*r, +c where jac is the final calculated jacobian, q is +c orthogonal (not stored), and r is upper triangular +c with diagonal elements of nonincreasing magnitude. +c column j of p is column ipvt(j) of the identity matrix. +c +c wa is a work array of length lwa. +c +c lwa is a positive integer input variable not less than 5*n+m. +c +c subprograms called +c +c user-supplied ...... fcn +c +c minpack-supplied ... lmder +c +c argonne national laboratory. minpack project. march 1980. +c burton s. garbow, kenneth e. hillstrom, jorge j. more +c +c ********** + integer maxfev,mode,nfev,njev,nprint + double precision factor,ftol,gtol,xtol,zero + data factor,zero /1.0d2,0.0d0/ + info = 0 +c +c check the input parameters for errors. +c + if (n .le. 0 .or. m .lt. n .or. ldfjac .lt. m .or. tol .lt. zero + * .or. lwa .lt. 5*n + m) go to 10 +c +c call lmder. +c + maxfev = 100*(n + 1) + ftol = tol + xtol = tol + gtol = zero + mode = 1 + nprint = 0 + call lmder(fcn,m,n,x,fvec,fjac,ldfjac,ftol,xtol,gtol,maxfev, + * wa(1),mode,factor,nprint,info,nfev,njev,ipvt,wa(n+1), + * wa(2*n+1),wa(3*n+1),wa(4*n+1),wa(5*n+1)) + if (info .eq. 8) info = 4 + 10 continue + return +c +c last card of subroutine lmder1. +c + end diff --git a/lmdif.f b/lmdif.f new file mode 100644 index 0000000..dd3d4ee --- /dev/null +++ b/lmdif.f @@ -0,0 +1,454 @@ + subroutine lmdif(fcn,m,n,x,fvec,ftol,xtol,gtol,maxfev,epsfcn, + * diag,mode,factor,nprint,info,nfev,fjac,ldfjac, + * ipvt,qtf,wa1,wa2,wa3,wa4) + integer m,n,maxfev,mode,nprint,info,nfev,ldfjac + integer ipvt(n) + double precision ftol,xtol,gtol,epsfcn,factor + double precision x(n),fvec(m),diag(n),fjac(ldfjac,n),qtf(n), + * wa1(n),wa2(n),wa3(n),wa4(m) + external fcn +c ********** +c +c subroutine lmdif +c +c the purpose of lmdif is to minimize the sum of the squares of +c m nonlinear functions in n variables by a modification of +c the levenberg-marquardt algorithm. the user must provide a +c subroutine which calculates the functions. the jacobian is +c then calculated by a forward-difference approximation. +c +c the subroutine statement is +c +c subroutine lmdif(fcn,m,n,x,fvec,ftol,xtol,gtol,maxfev,epsfcn, +c diag,mode,factor,nprint,info,nfev,fjac, +c ldfjac,ipvt,qtf,wa1,wa2,wa3,wa4) +c +c where +c +c fcn is the name of the user-supplied subroutine which +c calculates the functions. fcn must be declared +c in an external statement in the user calling +c program, and should be written as follows. +c +c subroutine fcn(m,n,x,fvec,iflag) +c integer m,n,iflag +c double precision x(n),fvec(m) +c ---------- +c calculate the functions at x and +c return this vector in fvec. +c ---------- +c return +c end +c +c the value of iflag should not be changed by fcn unless +c the user wants to terminate execution of lmdif. +c in this case set iflag to a negative integer. +c +c m is a positive integer input variable set to the number +c of functions. +c +c n is a positive integer input variable set to the number +c of variables. n must not exceed m. +c +c x is an array of length n. on input x must contain +c an initial estimate of the solution vector. on output x +c contains the final estimate of the solution vector. +c +c fvec is an output array of length m which contains +c the functions evaluated at the output x. +c +c ftol is a nonnegative input variable. termination +c occurs when both the actual and predicted relative +c reductions in the sum of squares are at most ftol. +c therefore, ftol measures the relative error desired +c in the sum of squares. +c +c xtol is a nonnegative input variable. termination +c occurs when the relative error between two consecutive +c iterates is at most xtol. therefore, xtol measures the +c relative error desired in the approximate solution. +c +c gtol is a nonnegative input variable. termination +c occurs when the cosine of the angle between fvec and +c any column of the jacobian is at most gtol in absolute +c value. therefore, gtol measures the orthogonality +c desired between the function vector and the columns +c of the jacobian. +c +c maxfev is a positive integer input variable. termination +c occurs when the number of calls to fcn is at least +c maxfev by the end of an iteration. +c +c epsfcn is an input variable used in determining a suitable +c step length for the forward-difference approximation. this +c approximation assumes that the relative errors in the +c functions are of the order of epsfcn. if epsfcn is less +c than the machine precision, it is assumed that the relative +c errors in the functions are of the order of the machine +c precision. +c +c diag is an array of length n. if mode = 1 (see +c below), diag is internally set. if mode = 2, diag +c must contain positive entries that serve as +c multiplicative scale factors for the variables. +c +c mode is an integer input variable. if mode = 1, the +c variables will be scaled internally. if mode = 2, +c the scaling is specified by the input diag. other +c values of mode are equivalent to mode = 1. +c +c factor is a positive input variable used in determining the +c initial step bound. this bound is set to the product of +c factor and the euclidean norm of diag*x if nonzero, or else +c to factor itself. in most cases factor should lie in the +c interval (.1,100.). 100. is a generally recommended value. +c +c nprint is an integer input variable that enables controlled +c printing of iterates if it is positive. in this case, +c fcn is called with iflag = 0 at the beginning of the first +c iteration and every nprint iterations thereafter and +c immediately prior to return, with x and fvec available +c for printing. if nprint is not positive, no special calls +c of fcn with iflag = 0 are made. +c +c info is an integer output variable. if the user has +c terminated execution, info is set to the (negative) +c value of iflag. see description of fcn. otherwise, +c info is set as follows. +c +c info = 0 improper input parameters. +c +c info = 1 both actual and predicted relative reductions +c in the sum of squares are at most ftol. +c +c info = 2 relative error between two consecutive iterates +c is at most xtol. +c +c info = 3 conditions for info = 1 and info = 2 both hold. +c +c info = 4 the cosine of the angle between fvec and any +c column of the jacobian is at most gtol in +c absolute value. +c +c info = 5 number of calls to fcn has reached or +c exceeded maxfev. +c +c info = 6 ftol is too small. no further reduction in +c the sum of squares is possible. +c +c info = 7 xtol is too small. no further improvement in +c the approximate solution x is possible. +c +c info = 8 gtol is too small. fvec is orthogonal to the +c columns of the jacobian to machine precision. +c +c nfev is an integer output variable set to the number of +c calls to fcn. +c +c fjac is an output m by n array. the upper n by n submatrix +c of fjac contains an upper triangular matrix r with +c diagonal elements of nonincreasing magnitude such that +c +c t t t +c p *(jac *jac)*p = r *r, +c +c where p is a permutation matrix and jac is the final +c calculated jacobian. column j of p is column ipvt(j) +c (see below) of the identity matrix. the lower trapezoidal +c part of fjac contains information generated during +c the computation of r. +c +c ldfjac is a positive integer input variable not less than m +c which specifies the leading dimension of the array fjac. +c +c ipvt is an integer output array of length n. ipvt +c defines a permutation matrix p such that jac*p = q*r, +c where jac is the final calculated jacobian, q is +c orthogonal (not stored), and r is upper triangular +c with diagonal elements of nonincreasing magnitude. +c column j of p is column ipvt(j) of the identity matrix. +c +c qtf is an output array of length n which contains +c the first n elements of the vector (q transpose)*fvec. +c +c wa1, wa2, and wa3 are work arrays of length n. +c +c wa4 is a work array of length m. +c +c subprograms called +c +c user-supplied ...... fcn +c +c minpack-supplied ... dpmpar,enorm,fdjac2,lmpar,qrfac +c +c fortran-supplied ... dabs,dmax1,dmin1,dsqrt,mod +c +c argonne national laboratory. minpack project. march 1980. +c burton s. garbow, kenneth e. hillstrom, jorge j. more +c +c ********** + integer i,iflag,iter,j,l + double precision actred,delta,dirder,epsmch,fnorm,fnorm1,gnorm, + * one,par,pnorm,prered,p1,p5,p25,p75,p0001,ratio, + * sum,temp,temp1,temp2,xnorm,zero + double precision dpmpar,enorm + data one,p1,p5,p25,p75,p0001,zero + * /1.0d0,1.0d-1,5.0d-1,2.5d-1,7.5d-1,1.0d-4,0.0d0/ +c +c epsmch is the machine precision. +c + epsmch = dpmpar(1) +c + info = 0 + iflag = 0 + nfev = 0 +c +c check the input parameters for errors. +c + if (n .le. 0 .or. m .lt. n .or. ldfjac .lt. m + * .or. ftol .lt. zero .or. xtol .lt. zero .or. gtol .lt. zero + * .or. maxfev .le. 0 .or. factor .le. zero) go to 300 + if (mode .ne. 2) go to 20 + do 10 j = 1, n + if (diag(j) .le. zero) go to 300 + 10 continue + 20 continue +c +c evaluate the function at the starting point +c and calculate its norm. +c + iflag = 1 + call fcn(m,n,x,fvec,iflag) + nfev = 1 + if (iflag .lt. 0) go to 300 + fnorm = enorm(m,fvec) +c +c initialize levenberg-marquardt parameter and iteration counter. +c + par = zero + iter = 1 +c +c beginning of the outer loop. +c + 30 continue +c +c calculate the jacobian matrix. +c + iflag = 2 + call fdjac2(fcn,m,n,x,fvec,fjac,ldfjac,iflag,epsfcn,wa4) + nfev = nfev + n + if (iflag .lt. 0) go to 300 +c +c if requested, call fcn to enable printing of iterates. +c + if (nprint .le. 0) go to 40 + iflag = 0 + if (mod(iter-1,nprint) .eq. 0) call fcn(m,n,x,fvec,iflag) + if (iflag .lt. 0) go to 300 + 40 continue +c +c compute the qr factorization of the jacobian. +c + call qrfac(m,n,fjac,ldfjac,.true.,ipvt,n,wa1,wa2,wa3) +c +c on the first iteration and if mode is 1, scale according +c to the norms of the columns of the initial jacobian. +c + if (iter .ne. 1) go to 80 + if (mode .eq. 2) go to 60 + do 50 j = 1, n + diag(j) = wa2(j) + if (wa2(j) .eq. zero) diag(j) = one + 50 continue + 60 continue +c +c on the first iteration, calculate the norm of the scaled x +c and initialize the step bound delta. +c + do 70 j = 1, n + wa3(j) = diag(j)*x(j) + 70 continue + xnorm = enorm(n,wa3) + delta = factor*xnorm + if (delta .eq. zero) delta = factor + 80 continue +c +c form (q transpose)*fvec and store the first n components in +c qtf. +c + do 90 i = 1, m + wa4(i) = fvec(i) + 90 continue + do 130 j = 1, n + if (fjac(j,j) .eq. zero) go to 120 + sum = zero + do 100 i = j, m + sum = sum + fjac(i,j)*wa4(i) + 100 continue + temp = -sum/fjac(j,j) + do 110 i = j, m + wa4(i) = wa4(i) + fjac(i,j)*temp + 110 continue + 120 continue + fjac(j,j) = wa1(j) + qtf(j) = wa4(j) + 130 continue +c +c compute the norm of the scaled gradient. +c + gnorm = zero + if (fnorm .eq. zero) go to 170 + do 160 j = 1, n + l = ipvt(j) + if (wa2(l) .eq. zero) go to 150 + sum = zero + do 140 i = 1, j + sum = sum + fjac(i,j)*(qtf(i)/fnorm) + 140 continue + gnorm = dmax1(gnorm,dabs(sum/wa2(l))) + 150 continue + 160 continue + 170 continue +c +c test for convergence of the gradient norm. +c + if (gnorm .le. gtol) info = 4 + if (info .ne. 0) go to 300 +c +c rescale if necessary. +c + if (mode .eq. 2) go to 190 + do 180 j = 1, n + diag(j) = dmax1(diag(j),wa2(j)) + 180 continue + 190 continue +c +c beginning of the inner loop. +c + 200 continue +c +c determine the levenberg-marquardt parameter. +c + call lmpar(n,fjac,ldfjac,ipvt,diag,qtf,delta,par,wa1,wa2, + * wa3,wa4) +c +c store the direction p and x + p. calculate the norm of p. +c + do 210 j = 1, n + wa1(j) = -wa1(j) + wa2(j) = x(j) + wa1(j) + wa3(j) = diag(j)*wa1(j) + 210 continue + pnorm = enorm(n,wa3) +c +c on the first iteration, adjust the initial step bound. +c + if (iter .eq. 1) delta = dmin1(delta,pnorm) +c +c evaluate the function at x + p and calculate its norm. +c + iflag = 1 + call fcn(m,n,wa2,wa4,iflag) + nfev = nfev + 1 + if (iflag .lt. 0) go to 300 + fnorm1 = enorm(m,wa4) +c +c compute the scaled actual reduction. +c + actred = -one + if (p1*fnorm1 .lt. fnorm) actred = one - (fnorm1/fnorm)**2 +c +c compute the scaled predicted reduction and +c the scaled directional derivative. +c + do 230 j = 1, n + wa3(j) = zero + l = ipvt(j) + temp = wa1(l) + do 220 i = 1, j + wa3(i) = wa3(i) + fjac(i,j)*temp + 220 continue + 230 continue + temp1 = enorm(n,wa3)/fnorm + temp2 = (dsqrt(par)*pnorm)/fnorm + prered = temp1**2 + temp2**2/p5 + dirder = -(temp1**2 + temp2**2) +c +c compute the ratio of the actual to the predicted +c reduction. +c + ratio = zero + if (prered .ne. zero) ratio = actred/prered +c +c update the step bound. +c + if (ratio .gt. p25) go to 240 + if (actred .ge. zero) temp = p5 + if (actred .lt. zero) + * temp = p5*dirder/(dirder + p5*actred) + if (p1*fnorm1 .ge. fnorm .or. temp .lt. p1) temp = p1 + delta = temp*dmin1(delta,pnorm/p1) + par = par/temp + go to 260 + 240 continue + if (par .ne. zero .and. ratio .lt. p75) go to 250 + delta = pnorm/p5 + par = p5*par + 250 continue + 260 continue +c +c test for successful iteration. +c + if (ratio .lt. p0001) go to 290 +c +c successful iteration. update x, fvec, and their norms. +c + do 270 j = 1, n + x(j) = wa2(j) + wa2(j) = diag(j)*x(j) + 270 continue + do 280 i = 1, m + fvec(i) = wa4(i) + 280 continue + xnorm = enorm(n,wa2) + fnorm = fnorm1 + iter = iter + 1 + 290 continue +c +c tests for convergence. +c + if (dabs(actred) .le. ftol .and. prered .le. ftol + * .and. p5*ratio .le. one) info = 1 + if (delta .le. xtol*xnorm) info = 2 + if (dabs(actred) .le. ftol .and. prered .le. ftol + * .and. p5*ratio .le. one .and. info .eq. 2) info = 3 + if (info .ne. 0) go to 300 +c +c tests for termination and stringent tolerances. +c + if (nfev .ge. maxfev) info = 5 + if (dabs(actred) .le. epsmch .and. prered .le. epsmch + * .and. p5*ratio .le. one) info = 6 + if (delta .le. epsmch*xnorm) info = 7 + if (gnorm .le. epsmch) info = 8 + if (info .ne. 0) go to 300 +c +c end of the inner loop. repeat if iteration unsuccessful. +c + if (ratio .lt. p0001) go to 200 +c +c end of the outer loop. +c + go to 30 + 300 continue +c +c termination, either normal or user imposed. +c + if (iflag .lt. 0) info = iflag + iflag = 0 + if (nprint .gt. 0) call fcn(m,n,x,fvec,iflag) + return +c +c last card of subroutine lmdif. +c + end diff --git a/lmdif1.f b/lmdif1.f new file mode 100644 index 0000000..70f8aae --- /dev/null +++ b/lmdif1.f @@ -0,0 +1,135 @@ + subroutine lmdif1(fcn,m,n,x,fvec,tol,info,iwa,wa,lwa) + integer m,n,info,lwa + integer iwa(n) + double precision tol + double precision x(n),fvec(m),wa(lwa) + external fcn +c ********** +c +c subroutine lmdif1 +c +c the purpose of lmdif1 is to minimize the sum of the squares of +c m nonlinear functions in n variables by a modification of the +c levenberg-marquardt algorithm. this is done by using the more +c general least-squares solver lmdif. the user must provide a +c subroutine which calculates the functions. the jacobian is +c then calculated by a forward-difference approximation. +c +c the subroutine statement is +c +c subroutine lmdif1(fcn,m,n,x,fvec,tol,info,iwa,wa,lwa) +c +c where +c +c fcn is the name of the user-supplied subroutine which +c calculates the functions. fcn must be declared +c in an external statement in the user calling +c program, and should be written as follows. +c +c subroutine fcn(m,n,x,fvec,iflag) +c integer m,n,iflag +c double precision x(n),fvec(m) +c ---------- +c calculate the functions at x and +c return this vector in fvec. +c ---------- +c return +c end +c +c the value of iflag should not be changed by fcn unless +c the user wants to terminate execution of lmdif1. +c in this case set iflag to a negative integer. +c +c m is a positive integer input variable set to the number +c of functions. +c +c n is a positive integer input variable set to the number +c of variables. n must not exceed m. +c +c x is an array of length n. on input x must contain +c an initial estimate of the solution vector. on output x +c contains the final estimate of the solution vector. +c +c fvec is an output array of length m which contains +c the functions evaluated at the output x. +c +c tol is a nonnegative input variable. termination occurs +c when the algorithm estimates either that the relative +c error in the sum of squares is at most tol or that +c the relative error between x and the solution is at +c most tol. +c +c info is an integer output variable. if the user has +c terminated execution, info is set to the (negative) +c value of iflag. see description of fcn. otherwise, +c info is set as follows. +c +c info = 0 improper input parameters. +c +c info = 1 algorithm estimates that the relative error +c in the sum of squares is at most tol. +c +c info = 2 algorithm estimates that the relative error +c between x and the solution is at most tol. +c +c info = 3 conditions for info = 1 and info = 2 both hold. +c +c info = 4 fvec is orthogonal to the columns of the +c jacobian to machine precision. +c +c info = 5 number of calls to fcn has reached or +c exceeded 200*(n+1). +c +c info = 6 tol is too small. no further reduction in +c the sum of squares is possible. +c +c info = 7 tol is too small. no further improvement in +c the approximate solution x is possible. +c +c iwa is an integer work array of length n. +c +c wa is a work array of length lwa. +c +c lwa is a positive integer input variable not less than +c m*n+5*n+m. +c +c subprograms called +c +c user-supplied ...... fcn +c +c minpack-supplied ... lmdif +c +c argonne national laboratory. minpack project. march 1980. +c burton s. garbow, kenneth e. hillstrom, jorge j. more +c +c ********** + integer maxfev,mode,mp5n,nfev,nprint + double precision epsfcn,factor,ftol,gtol,xtol,zero + data factor,zero /1.0d2,0.0d0/ + info = 0 +c +c check the input parameters for errors. +c + if (n .le. 0 .or. m .lt. n .or. tol .lt. zero + * .or. lwa .lt. m*n + 5*n + m) go to 10 +c +c call lmdif. +c + maxfev = 200*(n + 1) + ftol = tol + xtol = tol + gtol = zero + epsfcn = zero + mode = 1 + nprint = 0 + mp5n = m + 5*n + call lmdif(fcn,m,n,x,fvec,ftol,xtol,gtol,maxfev,epsfcn,wa(1), + * mode,factor,nprint,info,nfev,wa(mp5n+1),m,iwa, + * wa(n+1),wa(2*n+1),wa(3*n+1),wa(4*n+1),wa(5*n+1)) + if (info .eq. 8) info = 4 + 10 continue + return +c +c last card of subroutine lmdif1. +c + end diff --git a/lmdipt.f b/lmdipt.f new file mode 100644 index 0000000..bdc93a3 --- /dev/null +++ b/lmdipt.f @@ -0,0 +1,214 @@ + subroutine initpt(n,x,nprob,factor) + integer n,nprob + double precision factor + double precision x(n) +c ********** +c +c subroutine initpt +c +c this subroutine specifies the standard starting points for the +c functions defined by subroutine ssqfcn. the subroutine returns +c in x a multiple (factor) of the standard starting point. for +c the 11th function the standard starting point is zero, so in +c this case, if factor is not unity, then the subroutine returns +c the vector x(j) = factor, j=1,...,n. +c +c the subroutine statement is +c +c subroutine initpt(n,x,nprob,factor) +c +c where +c +c n is a positive integer input variable. +c +c x is an output array of length n which contains the standard +c starting point for problem nprob multiplied by factor. +c +c nprob is a positive integer input variable which defines the +c number of the problem. nprob must not exceed 18. +c +c factor is an input variable which specifies the multiple of +c the standard starting point. if factor is unity, no +c multiplication is performed. +c +c argonne national laboratory. minpack project. march 1980. +c burton s. garbow, kenneth e. hillstrom, jorge j. more +c +c ********** + integer ivar,j + double precision c1,c2,c3,c4,c5,c6,c7,c8,c9,c10,c11,c12,c13,c14, + * c15,c16,c17,five,h,half,one,seven,ten,three, + * twenty,twntf,two,zero + double precision dfloat + data zero,half,one,two,three,five,seven,ten,twenty,twntf + * /0.0d0,5.0d-1,1.0d0,2.0d0,3.0d0,5.0d0,7.0d0,1.0d1,2.0d1, + * 2.5d1/ + data c1,c2,c3,c4,c5,c6,c7,c8,c9,c10,c11,c12,c13,c14,c15,c16,c17 + * /1.2d0,2.5d-1,3.9d-1,4.15d-1,2.0d-2,4.0d3,2.5d2,3.0d-1, + * 4.0d-1,1.5d0,1.0d-2,1.3d0,6.5d-1,7.0d-1,6.0d-1,4.5d0, + * 5.5d0/ + dfloat(ivar) = ivar +c +c selection of initial point. +c + go to (10,10,10,30,40,50,60,70,80,90,100,120,130,140,150,170, + * 190,200), nprob +c +c linear function - full rank or rank 1. +c + 10 continue + do 20 j = 1, n + x(j) = one + 20 continue + go to 210 +c +c rosenbrock function. +c + 30 continue + x(1) = -c1 + x(2) = one + go to 210 +c +c helical valley function. +c + 40 continue + x(1) = -one + x(2) = zero + x(3) = zero + go to 210 +c +c powell singular function. +c + 50 continue + x(1) = three + x(2) = -one + x(3) = zero + x(4) = one + go to 210 +c +c freudenstein and roth function. +c + 60 continue + x(1) = half + x(2) = -two + go to 210 +c +c bard function. +c + 70 continue + x(1) = one + x(2) = one + x(3) = one + go to 210 +c +c kowalik and osborne function. +c + 80 continue + x(1) = c2 + x(2) = c3 + x(3) = c4 + x(4) = c3 + go to 210 +c +c meyer function. +c + 90 continue + x(1) = c5 + x(2) = c6 + x(3) = c7 + go to 210 +c +c watson function. +c + 100 continue + do 110 j = 1, n + x(j) = zero + 110 continue + go to 210 +c +c box 3-dimensional function. +c + 120 continue + x(1) = zero + x(2) = ten + x(3) = twenty + go to 210 +c +c jennrich and sampson function. +c + 130 continue + x(1) = c8 + x(2) = c9 + go to 210 +c +c brown and dennis function. +c + 140 continue + x(1) = twntf + x(2) = five + x(3) = -five + x(4) = -one + go to 210 +c +c chebyquad function. +c + 150 continue + h = one/dfloat(n+1) + do 160 j = 1, n + x(j) = dfloat(j)*h + 160 continue + go to 210 +c +c brown almost-linear function. +c + 170 continue + do 180 j = 1, n + x(j) = half + 180 continue + go to 210 +c +c osborne 1 function. +c + 190 continue + x(1) = half + x(2) = c10 + x(3) = -one + x(4) = c11 + x(5) = c5 + go to 210 +c +c osborne 2 function. +c + 200 continue + x(1) = c12 + x(2) = c13 + x(3) = c13 + x(4) = c14 + x(5) = c15 + x(6) = three + x(7) = five + x(8) = seven + x(9) = two + x(10) = c16 + x(11) = c17 + 210 continue +c +c compute multiple of initial point. +c + if (factor .eq. one) go to 260 + if (nprob .eq. 11) go to 230 + do 220 j = 1, n + x(j) = factor*x(j) + 220 continue + go to 250 + 230 continue + do 240 j = 1, n + x(j) = factor + 240 continue + 250 continue + 260 continue + return +c +c last card of subroutine initpt. +c + end diff --git a/lmfdrv.f b/lmfdrv.f new file mode 100644 index 0000000..ad8756f --- /dev/null +++ b/lmfdrv.f @@ -0,0 +1,121 @@ +c ********** +c +c this program tests codes for the least-squares solution of +c m nonlinear equations in n variables. it consists of a driver +c and an interface subroutine fcn. the driver reads in data, +c calls the nonlinear least-squares solver, and finally prints +c out information on the performance of the solver. this is +c only a sample driver, many other drivers are possible. the +c interface subroutine fcn is necessary to take into account the +c forms of calling sequences used by the function and jacobian +c subroutines in the various nonlinear least-squares solvers. +c +c subprograms called +c +c user-supplied ...... fcn +c +c minpack-supplied ... dpmpar,enorm,initpt,lmdif1,ssqfcn +c +c fortran-supplied ... dsqrt +c +c argonne national laboratory. minpack project. march 1980. +c burton s. garbow, kenneth e. hillstrom, jorge j. more +c +c ********** + integer i,ic,info,k,lwa,m,n,nfev,njev,nprob,nread,ntries,nwrite + integer iwa(40),ma(60),na(60),nf(60),nj(60),np(60),nx(60) + double precision factor,fnorm1,fnorm2,one,ten,tol + double precision fnm(60),fvec(65),wa(2865),x(40) + double precision dpmpar,enorm + external fcn + common /refnum/ nprob,nfev,njev +c +c logical input unit is assumed to be number 5. +c logical output unit is assumed to be number 6. +c + data nread,nwrite /5,6/ +c + data one,ten /1.0d0,1.0d1/ + tol = dsqrt(dpmpar(1)) + lwa = 2865 + ic = 0 + 10 continue + read (nread,50) nprob,n,m,ntries + if (nprob .le. 0) go to 30 + factor = one + do 20 k = 1, ntries + ic = ic + 1 + call initpt(n,x,nprob,factor) + call ssqfcn(m,n,x,fvec,nprob) + fnorm1 = enorm(m,fvec) + write (nwrite,60) nprob,n,m + nfev = 0 + njev = 0 + call lmdif1(fcn,m,n,x,fvec,tol,info,iwa,wa,lwa) + call ssqfcn(m,n,x,fvec,nprob) + fnorm2 = enorm(m,fvec) + np(ic) = nprob + na(ic) = n + ma(ic) = m + nf(ic) = nfev + njev = njev/n + nj(ic) = njev + nx(ic) = info + fnm(ic) = fnorm2 + write (nwrite,70) + * fnorm1,fnorm2,nfev,njev,info,(x(i), i = 1, n) + factor = ten*factor + 20 continue + go to 10 + 30 continue + write (nwrite,80) ic + write (nwrite,90) + do 40 i = 1, ic + write (nwrite,100) np(i),na(i),ma(i),nf(i),nj(i),nx(i),fnm(i) + 40 continue + stop + 50 format (4i5) + 60 format ( //// 5x, 8h problem, i5, 5x, 11h dimensions, 2i5, 5x // + * ) + 70 format (5x, 33h initial l2 norm of the residuals, d15.7 // 5x, + * 33h final l2 norm of the residuals , d15.7 // 5x, + * 33h number of function evaluations , i10 // 5x, + * 33h number of jacobian evaluations , i10 // 5x, + * 15h exit parameter, 18x, i10 // 5x, + * 27h final approximate solution // (5x, 5d15.7)) + 80 format (12h1summary of , i3, 16h calls to lmdif1 /) + 90 format (49h nprob n m nfev njev info final l2 norm /) + 100 format (3i5, 3i6, 1x, d15.7) +c +c last card of driver. +c + end + subroutine fcn(m,n,x,fvec,iflag) + integer m,n,iflag + double precision x(n),fvec(m) +c ********** +c +c the calling sequence of fcn should be identical to the +c calling sequence of the function subroutine in the nonlinear +c least-squares solver. fcn should only call the testing +c function subroutine ssqfcn with the appropriate value of +c problem number (nprob). +c +c subprograms called +c +c minpack-supplied ... ssqfcn +c +c argonne national laboratory. minpack project. march 1980. +c burton s. garbow, kenneth e. hillstrom, jorge j. more +c +c ********** + integer nprob,nfev,njev + common /refnum/ nprob,nfev,njev + call ssqfcn(m,n,x,fvec,nprob) + if (iflag .eq. 1) nfev = nfev + 1 + if (iflag .eq. 2) njev = njev + 1 + return +c +c last card of interface subroutine fcn. +c + end diff --git a/lmpar.f b/lmpar.f new file mode 100644 index 0000000..26c422a --- /dev/null +++ b/lmpar.f @@ -0,0 +1,264 @@ + subroutine lmpar(n,r,ldr,ipvt,diag,qtb,delta,par,x,sdiag,wa1, + * wa2) + integer n,ldr + integer ipvt(n) + double precision delta,par + double precision r(ldr,n),diag(n),qtb(n),x(n),sdiag(n),wa1(n), + * wa2(n) +c ********** +c +c subroutine lmpar +c +c given an m by n matrix a, an n by n nonsingular diagonal +c matrix d, an m-vector b, and a positive number delta, +c the problem is to determine a value for the parameter +c par such that if x solves the system +c +c a*x = b , sqrt(par)*d*x = 0 , +c +c in the least squares sense, and dxnorm is the euclidean +c norm of d*x, then either par is zero and +c +c (dxnorm-delta) .le. 0.1*delta , +c +c or par is positive and +c +c abs(dxnorm-delta) .le. 0.1*delta . +c +c this subroutine completes the solution of the problem +c if it is provided with the necessary information from the +c qr factorization, with column pivoting, of a. that is, if +c a*p = q*r, where p is a permutation matrix, q has orthogonal +c columns, and r is an upper triangular matrix with diagonal +c elements of nonincreasing magnitude, then lmpar expects +c the full upper triangle of r, the permutation matrix p, +c and the first n components of (q transpose)*b. on output +c lmpar also provides an upper triangular matrix s such that +c +c t t t +c p *(a *a + par*d*d)*p = s *s . +c +c s is employed within lmpar and may be of separate interest. +c +c only a few iterations are generally needed for convergence +c of the algorithm. if, however, the limit of 10 iterations +c is reached, then the output par will contain the best +c value obtained so far. +c +c the subroutine statement is +c +c subroutine lmpar(n,r,ldr,ipvt,diag,qtb,delta,par,x,sdiag, +c wa1,wa2) +c +c where +c +c n is a positive integer input variable set to the order of r. +c +c r is an n by n array. on input the full upper triangle +c must contain the full upper triangle of the matrix r. +c on output the full upper triangle is unaltered, and the +c strict lower triangle contains the strict upper triangle +c (transposed) of the upper triangular matrix s. +c +c ldr is a positive integer input variable not less than n +c which specifies the leading dimension of the array r. +c +c ipvt is an integer input array of length n which defines the +c permutation matrix p such that a*p = q*r. column j of p +c is column ipvt(j) of the identity matrix. +c +c diag is an input array of length n which must contain the +c diagonal elements of the matrix d. +c +c qtb is an input array of length n which must contain the first +c n elements of the vector (q transpose)*b. +c +c delta is a positive input variable which specifies an upper +c bound on the euclidean norm of d*x. +c +c par is a nonnegative variable. on input par contains an +c initial estimate of the levenberg-marquardt parameter. +c on output par contains the final estimate. +c +c x is an output array of length n which contains the least +c squares solution of the system a*x = b, sqrt(par)*d*x = 0, +c for the output par. +c +c sdiag is an output array of length n which contains the +c diagonal elements of the upper triangular matrix s. +c +c wa1 and wa2 are work arrays of length n. +c +c subprograms called +c +c minpack-supplied ... dpmpar,enorm,qrsolv +c +c fortran-supplied ... dabs,dmax1,dmin1,dsqrt +c +c argonne national laboratory. minpack project. march 1980. +c burton s. garbow, kenneth e. hillstrom, jorge j. more +c +c ********** + integer i,iter,j,jm1,jp1,k,l,nsing + double precision dxnorm,dwarf,fp,gnorm,parc,parl,paru,p1,p001, + * sum,temp,zero + double precision dpmpar,enorm + data p1,p001,zero /1.0d-1,1.0d-3,0.0d0/ +c +c dwarf is the smallest positive magnitude. +c + dwarf = dpmpar(2) +c +c compute and store in x the gauss-newton direction. if the +c jacobian is rank-deficient, obtain a least squares solution. +c + nsing = n + do 10 j = 1, n + wa1(j) = qtb(j) + if (r(j,j) .eq. zero .and. nsing .eq. n) nsing = j - 1 + if (nsing .lt. n) wa1(j) = zero + 10 continue + if (nsing .lt. 1) go to 50 + do 40 k = 1, nsing + j = nsing - k + 1 + wa1(j) = wa1(j)/r(j,j) + temp = wa1(j) + jm1 = j - 1 + if (jm1 .lt. 1) go to 30 + do 20 i = 1, jm1 + wa1(i) = wa1(i) - r(i,j)*temp + 20 continue + 30 continue + 40 continue + 50 continue + do 60 j = 1, n + l = ipvt(j) + x(l) = wa1(j) + 60 continue +c +c initialize the iteration counter. +c evaluate the function at the origin, and test +c for acceptance of the gauss-newton direction. +c + iter = 0 + do 70 j = 1, n + wa2(j) = diag(j)*x(j) + 70 continue + dxnorm = enorm(n,wa2) + fp = dxnorm - delta + if (fp .le. p1*delta) go to 220 +c +c if the jacobian is not rank deficient, the newton +c step provides a lower bound, parl, for the zero of +c the function. otherwise set this bound to zero. +c + parl = zero + if (nsing .lt. n) go to 120 + do 80 j = 1, n + l = ipvt(j) + wa1(j) = diag(l)*(wa2(l)/dxnorm) + 80 continue + do 110 j = 1, n + sum = zero + jm1 = j - 1 + if (jm1 .lt. 1) go to 100 + do 90 i = 1, jm1 + sum = sum + r(i,j)*wa1(i) + 90 continue + 100 continue + wa1(j) = (wa1(j) - sum)/r(j,j) + 110 continue + temp = enorm(n,wa1) + parl = ((fp/delta)/temp)/temp + 120 continue +c +c calculate an upper bound, paru, for the zero of the function. +c + do 140 j = 1, n + sum = zero + do 130 i = 1, j + sum = sum + r(i,j)*qtb(i) + 130 continue + l = ipvt(j) + wa1(j) = sum/diag(l) + 140 continue + gnorm = enorm(n,wa1) + paru = gnorm/delta + if (paru .eq. zero) paru = dwarf/dmin1(delta,p1) +c +c if the input par lies outside of the interval (parl,paru), +c set par to the closer endpoint. +c + par = dmax1(par,parl) + par = dmin1(par,paru) + if (par .eq. zero) par = gnorm/dxnorm +c +c beginning of an iteration. +c + 150 continue + iter = iter + 1 +c +c evaluate the function at the current value of par. +c + if (par .eq. zero) par = dmax1(dwarf,p001*paru) + temp = dsqrt(par) + do 160 j = 1, n + wa1(j) = temp*diag(j) + 160 continue + call qrsolv(n,r,ldr,ipvt,wa1,qtb,x,sdiag,wa2) + do 170 j = 1, n + wa2(j) = diag(j)*x(j) + 170 continue + dxnorm = enorm(n,wa2) + temp = fp + fp = dxnorm - delta +c +c if the function is small enough, accept the current value +c of par. also test for the exceptional cases where parl +c is zero or the number of iterations has reached 10. +c + if (dabs(fp) .le. p1*delta + * .or. parl .eq. zero .and. fp .le. temp + * .and. temp .lt. zero .or. iter .eq. 10) go to 220 +c +c compute the newton correction. +c + do 180 j = 1, n + l = ipvt(j) + wa1(j) = diag(l)*(wa2(l)/dxnorm) + 180 continue + do 210 j = 1, n + wa1(j) = wa1(j)/sdiag(j) + temp = wa1(j) + jp1 = j + 1 + if (n .lt. jp1) go to 200 + do 190 i = jp1, n + wa1(i) = wa1(i) - r(i,j)*temp + 190 continue + 200 continue + 210 continue + temp = enorm(n,wa1) + parc = ((fp/delta)/temp)/temp +c +c depending on the sign of the function, update parl or paru. +c + if (fp .gt. zero) parl = dmax1(parl,par) + if (fp .lt. zero) paru = dmin1(paru,par) +c +c compute an improved estimate for par. +c + par = dmax1(parl,par+parc) +c +c end of an iteration. +c + go to 150 + 220 continue +c +c termination. +c + if (iter .eq. 0) par = zero + return +c +c last card of subroutine lmpar. +c + end diff --git a/lmsdrv.f b/lmsdrv.f new file mode 100644 index 0000000..8681beb --- /dev/null +++ b/lmsdrv.f @@ -0,0 +1,135 @@ +c ********** +c +c this program tests codes for the least-squares solution of +c m nonlinear equations in n variables. it consists of a driver +c and an interface subroutine fcn. the driver reads in data, +c calls the nonlinear least-squares solver, and finally prints +c out information on the performance of the solver. this is +c only a sample driver, many other drivers are possible. the +c interface subroutine fcn is necessary to take into account the +c forms of calling sequences used by the function and jacobian +c subroutines in the various nonlinear least-squares solvers. +c +c subprograms called +c +c user-supplied ...... fcn +c +c minpack-supplied ... dpmpar,enorm,initpt,lmstr1,ssqfcn +c +c fortran-supplied ... dsqrt +c +c argonne national laboratory. minpack project. march 1980. +c burton s. garbow, kenneth e. hillstrom, jorge j. more +c +c ********** + integer i,ic,info,k,ldfjac,lwa,m,n,nfev,njev,nprob,nread,ntries, + * nwrite + integer iwa(40),ma(60),na(60),nf(60),nj(60),np(60),nx(60) + double precision factor,fnorm1,fnorm2,one,ten,tol + double precision fjac(40,40),fnm(60),fvec(65),wa(265),x(40) + double precision dpmpar,enorm + external fcn + common /refnum/ nprob,nfev,njev +c +c logical input unit is assumed to be number 5. +c logical output unit is assumed to be number 6. +c + data nread,nwrite /5,6/ +c + data one,ten /1.0d0,1.0d1/ + tol = dsqrt(dpmpar(1)) + ldfjac = 40 + lwa = 265 + ic = 0 + 10 continue + read (nread,50) nprob,n,m,ntries + if (nprob .le. 0) go to 30 + factor = one + do 20 k = 1, ntries + ic = ic + 1 + call initpt(n,x,nprob,factor) + call ssqfcn(m,n,x,fvec,nprob) + fnorm1 = enorm(m,fvec) + write (nwrite,60) nprob,n,m + nfev = 0 + njev = 0 + call lmstr1(fcn,m,n,x,fvec,fjac,ldfjac,tol,info,iwa,wa, + * lwa) + call ssqfcn(m,n,x,fvec,nprob) + fnorm2 = enorm(m,fvec) + np(ic) = nprob + na(ic) = n + ma(ic) = m + nf(ic) = nfev + nj(ic) = njev + nx(ic) = info + fnm(ic) = fnorm2 + write (nwrite,70) + * fnorm1,fnorm2,nfev,njev,info,(x(i), i = 1, n) + factor = ten*factor + 20 continue + go to 10 + 30 continue + write (nwrite,80) ic + write (nwrite,90) + do 40 i = 1, ic + write (nwrite,100) np(i),na(i),ma(i),nf(i),nj(i),nx(i),fnm(i) + 40 continue + stop + 50 format (4i5) + 60 format ( //// 5x, 8h problem, i5, 5x, 11h dimensions, 2i5, 5x // + * ) + 70 format (5x, 33h initial l2 norm of the residuals, d15.7 // 5x, + * 33h final l2 norm of the residuals , d15.7 // 5x, + * 33h number of function evaluations , i10 // 5x, + * 33h number of jacobian evaluations , i10 // 5x, + * 15h exit parameter, 18x, i10 // 5x, + * 27h final approximate solution // (5x, 5d15.7)) + 80 format (12h1summary of , i3, 16h calls to lmstr1 /) + 90 format (49h nprob n m nfev njev info final l2 norm /) + 100 format (3i5, 3i6, 1x, d15.7) +c +c last card of driver. +c + end + subroutine fcn(m,n,x,fvec,fjrow,iflag) + integer m,n,iflag + double precision x(n),fvec(m),fjrow(n) +c ********** +c +c the calling sequence of fcn should be identical to the +c calling sequence of the function subroutine in the nonlinear +c least squares solver. if iflag = 1, fcn should only call the +c testing function subroutine ssqfcn. if iflag = i, i .ge. 2, +c fcn should only call subroutine ssqjac to calculate the +c (i-1)-st row of the jacobian. (the ssqjac subroutine provided +c here for testing purposes calculates the entire jacobian +c matrix and is therefore called only when iflag = 2.) each +c call to ssqfcn or ssqjac should specify the appropriate +c value of problem number (nprob). +c +c subprograms called +c +c minpack-supplied ... ssqfcn,ssqjac +c +c argonne national laboratory. minpack project. march 1980. +c burton s. garbow, kenneth e. hillstrom, jorge j. more +c +c ********** + integer nprob,nfev,njev,j + double precision temp(65,40) + common /refnum/ nprob,nfev,njev + if (iflag .eq. 1) call ssqfcn(m,n,x,fvec,nprob) + if (iflag .eq. 2) call ssqjac(m,n,x,temp,65,nprob) + if (iflag .eq. 1) nfev = nfev + 1 + if (iflag .eq. 2) njev = njev + 1 + if (iflag .eq. 1) go to 120 + do 110 j = 1, n + fjrow(j) = temp(iflag-1,j) + 110 continue + 120 continue + return +c +c last card of interface subroutine fcn. +c + end diff --git a/lmstr.f b/lmstr.f new file mode 100644 index 0000000..d9a7893 --- /dev/null +++ b/lmstr.f @@ -0,0 +1,466 @@ + subroutine lmstr(fcn,m,n,x,fvec,fjac,ldfjac,ftol,xtol,gtol, + * maxfev,diag,mode,factor,nprint,info,nfev,njev, + * ipvt,qtf,wa1,wa2,wa3,wa4) + integer m,n,ldfjac,maxfev,mode,nprint,info,nfev,njev + integer ipvt(n) + logical sing + double precision ftol,xtol,gtol,factor + double precision x(n),fvec(m),fjac(ldfjac,n),diag(n),qtf(n), + * wa1(n),wa2(n),wa3(n),wa4(m) +c ********** +c +c subroutine lmstr +c +c the purpose of lmstr is to minimize the sum of the squares of +c m nonlinear functions in n variables by a modification of +c the levenberg-marquardt algorithm which uses minimal storage. +c the user must provide a subroutine which calculates the +c functions and the rows of the jacobian. +c +c the subroutine statement is +c +c subroutine lmstr(fcn,m,n,x,fvec,fjac,ldfjac,ftol,xtol,gtol, +c maxfev,diag,mode,factor,nprint,info,nfev, +c njev,ipvt,qtf,wa1,wa2,wa3,wa4) +c +c where +c +c fcn is the name of the user-supplied subroutine which +c calculates the functions and the rows of the jacobian. +c fcn must be declared in an external statement in the +c user calling program, and should be written as follows. +c +c subroutine fcn(m,n,x,fvec,fjrow,iflag) +c integer m,n,iflag +c double precision x(n),fvec(m),fjrow(n) +c ---------- +c if iflag = 1 calculate the functions at x and +c return this vector in fvec. +c if iflag = i calculate the (i-1)-st row of the +c jacobian at x and return this vector in fjrow. +c ---------- +c return +c end +c +c the value of iflag should not be changed by fcn unless +c the user wants to terminate execution of lmstr. +c in this case set iflag to a negative integer. +c +c m is a positive integer input variable set to the number +c of functions. +c +c n is a positive integer input variable set to the number +c of variables. n must not exceed m. +c +c x is an array of length n. on input x must contain +c an initial estimate of the solution vector. on output x +c contains the final estimate of the solution vector. +c +c fvec is an output array of length m which contains +c the functions evaluated at the output x. +c +c fjac is an output n by n array. the upper triangle of fjac +c contains an upper triangular matrix r such that +c +c t t t +c p *(jac *jac)*p = r *r, +c +c where p is a permutation matrix and jac is the final +c calculated jacobian. column j of p is column ipvt(j) +c (see below) of the identity matrix. the lower triangular +c part of fjac contains information generated during +c the computation of r. +c +c ldfjac is a positive integer input variable not less than n +c which specifies the leading dimension of the array fjac. +c +c ftol is a nonnegative input variable. termination +c occurs when both the actual and predicted relative +c reductions in the sum of squares are at most ftol. +c therefore, ftol measures the relative error desired +c in the sum of squares. +c +c xtol is a nonnegative input variable. termination +c occurs when the relative error between two consecutive +c iterates is at most xtol. therefore, xtol measures the +c relative error desired in the approximate solution. +c +c gtol is a nonnegative input variable. termination +c occurs when the cosine of the angle between fvec and +c any column of the jacobian is at most gtol in absolute +c value. therefore, gtol measures the orthogonality +c desired between the function vector and the columns +c of the jacobian. +c +c maxfev is a positive integer input variable. termination +c occurs when the number of calls to fcn with iflag = 1 +c has reached maxfev. +c +c diag is an array of length n. if mode = 1 (see +c below), diag is internally set. if mode = 2, diag +c must contain positive entries that serve as +c multiplicative scale factors for the variables. +c +c mode is an integer input variable. if mode = 1, the +c variables will be scaled internally. if mode = 2, +c the scaling is specified by the input diag. other +c values of mode are equivalent to mode = 1. +c +c factor is a positive input variable used in determining the +c initial step bound. this bound is set to the product of +c factor and the euclidean norm of diag*x if nonzero, or else +c to factor itself. in most cases factor should lie in the +c interval (.1,100.). 100. is a generally recommended value. +c +c nprint is an integer input variable that enables controlled +c printing of iterates if it is positive. in this case, +c fcn is called with iflag = 0 at the beginning of the first +c iteration and every nprint iterations thereafter and +c immediately prior to return, with x and fvec available +c for printing. if nprint is not positive, no special calls +c of fcn with iflag = 0 are made. +c +c info is an integer output variable. if the user has +c terminated execution, info is set to the (negative) +c value of iflag. see description of fcn. otherwise, +c info is set as follows. +c +c info = 0 improper input parameters. +c +c info = 1 both actual and predicted relative reductions +c in the sum of squares are at most ftol. +c +c info = 2 relative error between two consecutive iterates +c is at most xtol. +c +c info = 3 conditions for info = 1 and info = 2 both hold. +c +c info = 4 the cosine of the angle between fvec and any +c column of the jacobian is at most gtol in +c absolute value. +c +c info = 5 number of calls to fcn with iflag = 1 has +c reached maxfev. +c +c info = 6 ftol is too small. no further reduction in +c the sum of squares is possible. +c +c info = 7 xtol is too small. no further improvement in +c the approximate solution x is possible. +c +c info = 8 gtol is too small. fvec is orthogonal to the +c columns of the jacobian to machine precision. +c +c nfev is an integer output variable set to the number of +c calls to fcn with iflag = 1. +c +c njev is an integer output variable set to the number of +c calls to fcn with iflag = 2. +c +c ipvt is an integer output array of length n. ipvt +c defines a permutation matrix p such that jac*p = q*r, +c where jac is the final calculated jacobian, q is +c orthogonal (not stored), and r is upper triangular. +c column j of p is column ipvt(j) of the identity matrix. +c +c qtf is an output array of length n which contains +c the first n elements of the vector (q transpose)*fvec. +c +c wa1, wa2, and wa3 are work arrays of length n. +c +c wa4 is a work array of length m. +c +c subprograms called +c +c user-supplied ...... fcn +c +c minpack-supplied ... dpmpar,enorm,lmpar,qrfac,rwupdt +c +c fortran-supplied ... dabs,dmax1,dmin1,dsqrt,mod +c +c argonne national laboratory. minpack project. march 1980. +c burton s. garbow, dudley v. goetschel, kenneth e. hillstrom, +c jorge j. more +c +c ********** + integer i,iflag,iter,j,l + double precision actred,delta,dirder,epsmch,fnorm,fnorm1,gnorm, + * one,par,pnorm,prered,p1,p5,p25,p75,p0001,ratio, + * sum,temp,temp1,temp2,xnorm,zero + double precision dpmpar,enorm + data one,p1,p5,p25,p75,p0001,zero + * /1.0d0,1.0d-1,5.0d-1,2.5d-1,7.5d-1,1.0d-4,0.0d0/ +c +c epsmch is the machine precision. +c + epsmch = dpmpar(1) +c + info = 0 + iflag = 0 + nfev = 0 + njev = 0 +c +c check the input parameters for errors. +c + if (n .le. 0 .or. m .lt. n .or. ldfjac .lt. n + * .or. ftol .lt. zero .or. xtol .lt. zero .or. gtol .lt. zero + * .or. maxfev .le. 0 .or. factor .le. zero) go to 340 + if (mode .ne. 2) go to 20 + do 10 j = 1, n + if (diag(j) .le. zero) go to 340 + 10 continue + 20 continue +c +c evaluate the function at the starting point +c and calculate its norm. +c + iflag = 1 + call fcn(m,n,x,fvec,wa3,iflag) + nfev = 1 + if (iflag .lt. 0) go to 340 + fnorm = enorm(m,fvec) +c +c initialize levenberg-marquardt parameter and iteration counter. +c + par = zero + iter = 1 +c +c beginning of the outer loop. +c + 30 continue +c +c if requested, call fcn to enable printing of iterates. +c + if (nprint .le. 0) go to 40 + iflag = 0 + if (mod(iter-1,nprint) .eq. 0) call fcn(m,n,x,fvec,wa3,iflag) + if (iflag .lt. 0) go to 340 + 40 continue +c +c compute the qr factorization of the jacobian matrix +c calculated one row at a time, while simultaneously +c forming (q transpose)*fvec and storing the first +c n components in qtf. +c + do 60 j = 1, n + qtf(j) = zero + do 50 i = 1, n + fjac(i,j) = zero + 50 continue + 60 continue + iflag = 2 + do 70 i = 1, m + call fcn(m,n,x,fvec,wa3,iflag) + if (iflag .lt. 0) go to 340 + temp = fvec(i) + call rwupdt(n,fjac,ldfjac,wa3,qtf,temp,wa1,wa2) + iflag = iflag + 1 + 70 continue + njev = njev + 1 +c +c if the jacobian is rank deficient, call qrfac to +c reorder its columns and update the components of qtf. +c + sing = .false. + do 80 j = 1, n + if (fjac(j,j) .eq. zero) sing = .true. + ipvt(j) = j + wa2(j) = enorm(j,fjac(1,j)) + 80 continue + if (.not.sing) go to 130 + call qrfac(n,n,fjac,ldfjac,.true.,ipvt,n,wa1,wa2,wa3) + do 120 j = 1, n + if (fjac(j,j) .eq. zero) go to 110 + sum = zero + do 90 i = j, n + sum = sum + fjac(i,j)*qtf(i) + 90 continue + temp = -sum/fjac(j,j) + do 100 i = j, n + qtf(i) = qtf(i) + fjac(i,j)*temp + 100 continue + 110 continue + fjac(j,j) = wa1(j) + 120 continue + 130 continue +c +c on the first iteration and if mode is 1, scale according +c to the norms of the columns of the initial jacobian. +c + if (iter .ne. 1) go to 170 + if (mode .eq. 2) go to 150 + do 140 j = 1, n + diag(j) = wa2(j) + if (wa2(j) .eq. zero) diag(j) = one + 140 continue + 150 continue +c +c on the first iteration, calculate the norm of the scaled x +c and initialize the step bound delta. +c + do 160 j = 1, n + wa3(j) = diag(j)*x(j) + 160 continue + xnorm = enorm(n,wa3) + delta = factor*xnorm + if (delta .eq. zero) delta = factor + 170 continue +c +c compute the norm of the scaled gradient. +c + gnorm = zero + if (fnorm .eq. zero) go to 210 + do 200 j = 1, n + l = ipvt(j) + if (wa2(l) .eq. zero) go to 190 + sum = zero + do 180 i = 1, j + sum = sum + fjac(i,j)*(qtf(i)/fnorm) + 180 continue + gnorm = dmax1(gnorm,dabs(sum/wa2(l))) + 190 continue + 200 continue + 210 continue +c +c test for convergence of the gradient norm. +c + if (gnorm .le. gtol) info = 4 + if (info .ne. 0) go to 340 +c +c rescale if necessary. +c + if (mode .eq. 2) go to 230 + do 220 j = 1, n + diag(j) = dmax1(diag(j),wa2(j)) + 220 continue + 230 continue +c +c beginning of the inner loop. +c + 240 continue +c +c determine the levenberg-marquardt parameter. +c + call lmpar(n,fjac,ldfjac,ipvt,diag,qtf,delta,par,wa1,wa2, + * wa3,wa4) +c +c store the direction p and x + p. calculate the norm of p. +c + do 250 j = 1, n + wa1(j) = -wa1(j) + wa2(j) = x(j) + wa1(j) + wa3(j) = diag(j)*wa1(j) + 250 continue + pnorm = enorm(n,wa3) +c +c on the first iteration, adjust the initial step bound. +c + if (iter .eq. 1) delta = dmin1(delta,pnorm) +c +c evaluate the function at x + p and calculate its norm. +c + iflag = 1 + call fcn(m,n,wa2,wa4,wa3,iflag) + nfev = nfev + 1 + if (iflag .lt. 0) go to 340 + fnorm1 = enorm(m,wa4) +c +c compute the scaled actual reduction. +c + actred = -one + if (p1*fnorm1 .lt. fnorm) actred = one - (fnorm1/fnorm)**2 +c +c compute the scaled predicted reduction and +c the scaled directional derivative. +c + do 270 j = 1, n + wa3(j) = zero + l = ipvt(j) + temp = wa1(l) + do 260 i = 1, j + wa3(i) = wa3(i) + fjac(i,j)*temp + 260 continue + 270 continue + temp1 = enorm(n,wa3)/fnorm + temp2 = (dsqrt(par)*pnorm)/fnorm + prered = temp1**2 + temp2**2/p5 + dirder = -(temp1**2 + temp2**2) +c +c compute the ratio of the actual to the predicted +c reduction. +c + ratio = zero + if (prered .ne. zero) ratio = actred/prered +c +c update the step bound. +c + if (ratio .gt. p25) go to 280 + if (actred .ge. zero) temp = p5 + if (actred .lt. zero) + * temp = p5*dirder/(dirder + p5*actred) + if (p1*fnorm1 .ge. fnorm .or. temp .lt. p1) temp = p1 + delta = temp*dmin1(delta,pnorm/p1) + par = par/temp + go to 300 + 280 continue + if (par .ne. zero .and. ratio .lt. p75) go to 290 + delta = pnorm/p5 + par = p5*par + 290 continue + 300 continue +c +c test for successful iteration. +c + if (ratio .lt. p0001) go to 330 +c +c successful iteration. update x, fvec, and their norms. +c + do 310 j = 1, n + x(j) = wa2(j) + wa2(j) = diag(j)*x(j) + 310 continue + do 320 i = 1, m + fvec(i) = wa4(i) + 320 continue + xnorm = enorm(n,wa2) + fnorm = fnorm1 + iter = iter + 1 + 330 continue +c +c tests for convergence. +c + if (dabs(actred) .le. ftol .and. prered .le. ftol + * .and. p5*ratio .le. one) info = 1 + if (delta .le. xtol*xnorm) info = 2 + if (dabs(actred) .le. ftol .and. prered .le. ftol + * .and. p5*ratio .le. one .and. info .eq. 2) info = 3 + if (info .ne. 0) go to 340 +c +c tests for termination and stringent tolerances. +c + if (nfev .ge. maxfev) info = 5 + if (dabs(actred) .le. epsmch .and. prered .le. epsmch + * .and. p5*ratio .le. one) info = 6 + if (delta .le. epsmch*xnorm) info = 7 + if (gnorm .le. epsmch) info = 8 + if (info .ne. 0) go to 340 +c +c end of the inner loop. repeat if iteration unsuccessful. +c + if (ratio .lt. p0001) go to 240 +c +c end of the outer loop. +c + go to 30 + 340 continue +c +c termination, either normal or user imposed. +c + if (iflag .lt. 0) info = iflag + iflag = 0 + if (nprint .gt. 0) call fcn(m,n,x,fvec,wa3,iflag) + return +c +c last card of subroutine lmstr. +c + end diff --git a/lmstr1.f b/lmstr1.f new file mode 100644 index 0000000..2fa8ee1 --- /dev/null +++ b/lmstr1.f @@ -0,0 +1,156 @@ + subroutine lmstr1(fcn,m,n,x,fvec,fjac,ldfjac,tol,info,ipvt,wa, + * lwa) + integer m,n,ldfjac,info,lwa + integer ipvt(n) + double precision tol + double precision x(n),fvec(m),fjac(ldfjac,n),wa(lwa) + external fcn +c ********** +c +c subroutine lmstr1 +c +c the purpose of lmstr1 is to minimize the sum of the squares of +c m nonlinear functions in n variables by a modification of +c the levenberg-marquardt algorithm which uses minimal storage. +c this is done by using the more general least-squares solver +c lmstr. the user must provide a subroutine which calculates +c the functions and the rows of the jacobian. +c +c the subroutine statement is +c +c subroutine lmstr1(fcn,m,n,x,fvec,fjac,ldfjac,tol,info, +c ipvt,wa,lwa) +c +c where +c +c fcn is the name of the user-supplied subroutine which +c calculates the functions and the rows of the jacobian. +c fcn must be declared in an external statement in the +c user calling program, and should be written as follows. +c +c subroutine fcn(m,n,x,fvec,fjrow,iflag) +c integer m,n,iflag +c double precision x(n),fvec(m),fjrow(n) +c ---------- +c if iflag = 1 calculate the functions at x and +c return this vector in fvec. +c if iflag = i calculate the (i-1)-st row of the +c jacobian at x and return this vector in fjrow. +c ---------- +c return +c end +c +c the value of iflag should not be changed by fcn unless +c the user wants to terminate execution of lmstr1. +c in this case set iflag to a negative integer. +c +c m is a positive integer input variable set to the number +c of functions. +c +c n is a positive integer input variable set to the number +c of variables. n must not exceed m. +c +c x is an array of length n. on input x must contain +c an initial estimate of the solution vector. on output x +c contains the final estimate of the solution vector. +c +c fvec is an output array of length m which contains +c the functions evaluated at the output x. +c +c fjac is an output n by n array. the upper triangle of fjac +c contains an upper triangular matrix r such that +c +c t t t +c p *(jac *jac)*p = r *r, +c +c where p is a permutation matrix and jac is the final +c calculated jacobian. column j of p is column ipvt(j) +c (see below) of the identity matrix. the lower triangular +c part of fjac contains information generated during +c the computation of r. +c +c ldfjac is a positive integer input variable not less than n +c which specifies the leading dimension of the array fjac. +c +c tol is a nonnegative input variable. termination occurs +c when the algorithm estimates either that the relative +c error in the sum of squares is at most tol or that +c the relative error between x and the solution is at +c most tol. +c +c info is an integer output variable. if the user has +c terminated execution, info is set to the (negative) +c value of iflag. see description of fcn. otherwise, +c info is set as follows. +c +c info = 0 improper input parameters. +c +c info = 1 algorithm estimates that the relative error +c in the sum of squares is at most tol. +c +c info = 2 algorithm estimates that the relative error +c between x and the solution is at most tol. +c +c info = 3 conditions for info = 1 and info = 2 both hold. +c +c info = 4 fvec is orthogonal to the columns of the +c jacobian to machine precision. +c +c info = 5 number of calls to fcn with iflag = 1 has +c reached 100*(n+1). +c +c info = 6 tol is too small. no further reduction in +c the sum of squares is possible. +c +c info = 7 tol is too small. no further improvement in +c the approximate solution x is possible. +c +c ipvt is an integer output array of length n. ipvt +c defines a permutation matrix p such that jac*p = q*r, +c where jac is the final calculated jacobian, q is +c orthogonal (not stored), and r is upper triangular. +c column j of p is column ipvt(j) of the identity matrix. +c +c wa is a work array of length lwa. +c +c lwa is a positive integer input variable not less than 5*n+m. +c +c subprograms called +c +c user-supplied ...... fcn +c +c minpack-supplied ... lmstr +c +c argonne national laboratory. minpack project. march 1980. +c burton s. garbow, dudley v. goetschel, kenneth e. hillstrom, +c jorge j. more +c +c ********** + integer maxfev,mode,nfev,njev,nprint + double precision factor,ftol,gtol,xtol,zero + data factor,zero /1.0d2,0.0d0/ + info = 0 +c +c check the input parameters for errors. +c + if (n .le. 0 .or. m .lt. n .or. ldfjac .lt. n .or. tol .lt. zero + * .or. lwa .lt. 5*n + m) go to 10 +c +c call lmstr. +c + maxfev = 100*(n + 1) + ftol = tol + xtol = tol + gtol = zero + mode = 1 + nprint = 0 + call lmstr(fcn,m,n,x,fvec,fjac,ldfjac,ftol,xtol,gtol,maxfev, + * wa(1),mode,factor,nprint,info,nfev,njev,ipvt,wa(n+1), + * wa(2*n+1),wa(3*n+1),wa(4*n+1),wa(5*n+1)) + if (info .eq. 8) info = 4 + 10 continue + return +c +c last card of subroutine lmstr1. +c + end diff --git a/makefile b/makefile new file mode 100644 index 0000000..063cf7c --- /dev/null +++ b/makefile @@ -0,0 +1,51 @@ +LIB=minpack +FFLAGS=-O +OBJ = \ + covar.o \ + dmchar.o \ + dogleg.o \ + dpmpar.o \ + enorm.o \ + errjac.o \ + fdjac1.o \ + fdjac2.o \ + grdfcn.o \ + hesfcn.o \ + hybipt.o \ + hybrd.o \ + hybrd1.o \ + hybrj.o \ + hybrj1.o \ + lhesfcn.o \ + lmder.o \ + lmder1.o \ + lmdif.o \ + lmdif1.o \ + lmdipt.o \ + lmpar.o \ + lmstr.o \ + lmstr1.o \ + objfcn.o \ + ocpipt.o \ + qform.o \ + qrfac.o \ + qrsolv.o \ + r1mpyq.o \ + r1updt.o \ + rwupdt.o \ + ssqfcn.o \ + ssqjac.o \ + vecfcn.o \ + vecjac.o + +lib$(LIB).a: $(OBJ) + ar ru lib$(LIB).a $? + ranlib lib$(LIB).a + +install: lib$(LIB).a + ln -s /netlib/netlib/minpack/lib$(LIB).a /usr/local/lib + rm *.o + +test: test.o + f77 test.o -l$(LIB) + time a.out diff --git a/objfcn.f b/objfcn.f new file mode 100644 index 0000000..979325d --- /dev/null +++ b/objfcn.f @@ -0,0 +1,342 @@ + subroutine objfcn(n,x,f,nprob) + integer n,nprob + double precision f + double precision x(n) +c ********** +c +c subroutine objfcn +c +c this subroutine defines the objective functions of eighteen +c nonlinear unconstrained minimization problems. the values +c of n for functions 1,2,3,4,5,10,11,12,16 and 17 are +c 3,6,3,2,3,2,4,3,2 and 4, respectively. +c for function 7, n may be 2 or greater but is usually 6 or 9. +c for functions 6,8,9,13,14,15 and 18 n may be variable, +c however it must be even for function 14, a multiple of 4 for +c function 15, and not greater than 50 for function 18. +c +c the subroutine statement is +c +c subroutine objfcn(n,x,f,nprob) +c +c where +c +c n is a positive integer input variable. +c +c x is an input array of length n. +c +c f is an output variable which contains the value of +c the nprob objective function evaluated at x. +c +c nprob is a positive integer input variable which defines the +c number of the problem. nprob must not exceed 18. +c +c subprograms called +c +c fortran-supplied ... dabs,datan,dcos,dexp,dlog,dsign,dsin, +c dsqrt +c +c argonne national laboratory. minpack project. march 1980. +c burton s. garbow, kenneth e. hillstrom, jorge j. more +c +c ********** + integer i,iev,ivar,j + double precision ap,arg,c2pdm6,cp0001,cp1,cp2,cp25,cp5,c1p5, + * c2p25,c2p625,c3p5,c25,c29,c90,c100,c10000, + * c1pd6,d1,d2,eight,fifty,five,four,one,r,s1,s2, + * s3,t,t1,t2,t3,ten,th,three,tpi,two,zero + double precision fvec(50),y(15) + double precision dfloat + data zero,one,two,three,four,five,eight,ten,fifty + * /0.0d0,1.0d0,2.0d0,3.0d0,4.0d0,5.0d0,8.0d0,1.0d1,5.0d1/ + data c2pdm6,cp0001,cp1,cp2,cp25,cp5,c1p5,c2p25,c2p625,c3p5,c25, + * c29,c90,c100,c10000,c1pd6 + * /2.0d-6,1.0d-4,1.0d-1,2.0d-1,2.5d-1,5.0d-1,1.5d0,2.25d0, + * 2.625d0,3.5d0,2.5d1,2.9d1,9.0d1,1.0d2,1.0d4,1.0d6/ + data ap /1.0d-5/ + data y(1),y(2),y(3),y(4),y(5),y(6),y(7),y(8),y(9),y(10),y(11), + * y(12),y(13),y(14),y(15) + * /9.0d-4,4.4d-3,1.75d-2,5.4d-2,1.295d-1,2.42d-1,3.521d-1, + * 3.989d-1,3.521d-1,2.42d-1,1.295d-1,5.4d-2,1.75d-2,4.4d-3, + * 9.0d-4/ + dfloat(ivar) = ivar +c +c function routine selector. +c + go to (10,20,40,60,70,90,110,150,170,200,210,230,250,280,300, + * 320,330,340), nprob +c +c helical valley function. +c + 10 continue + tpi = eight*datan(one) + th = dsign(cp25,x(2)) + if (x(1) .gt. zero) th = datan(x(2)/x(1))/tpi + if (x(1) .lt. zero) th = datan(x(2)/x(1))/tpi + cp5 + arg = x(1)**2 + x(2)**2 + r = dsqrt(arg) + t = x(3) - ten*th + f = c100*(t**2 + (r - one)**2) + x(3)**2 + go to 390 +c +c biggs exp6 function. +c + 20 continue + f = zero + do 30 i = 1, 13 + d1 = dfloat(i)/ten + d2 = dexp(-d1) - five*dexp(-ten*d1) + three*dexp(-four*d1) + s1 = dexp(-d1*x(1)) + s2 = dexp(-d1*x(2)) + s3 = dexp(-d1*x(5)) + t = x(3)*s1 - x(4)*s2 + x(6)*s3 - d2 + f = f + t**2 + 30 continue + go to 390 +c +c gaussian function. +c + 40 continue + f = zero + do 50 i = 1, 15 + d1 = cp5*dfloat(i-1) + d2 = c3p5 - d1 - x(3) + arg = -cp5*x(2)*d2**2 + r = dexp(arg) + t = x(1)*r - y(i) + f = f + t**2 + 50 continue + go to 390 +c +c powell badly scaled function. +c + 60 continue + t1 = c10000*x(1)*x(2) - one + s1 = dexp(-x(1)) + s2 = dexp(-x(2)) + t2 = s1 + s2 - one - cp0001 + f = t1**2 + t2**2 + go to 390 +c +c box 3-dimensional function. +c + 70 continue + f = zero + do 80 i = 1, 10 + d1 = dfloat(i) + d2 = d1/ten + s1 = dexp(-d2*x(1)) + s2 = dexp(-d2*x(2)) + s3 = dexp(-d2) - dexp(-d1) + t = s1 - s2 - s3*x(3) + f = f + t**2 + 80 continue + go to 390 +c +c variably dimensioned function. +c + 90 continue + t1 = zero + t2 = zero + do 100 j = 1, n + t1 = t1 + dfloat(j)*(x(j) - one) + t2 = t2 + (x(j) - one)**2 + 100 continue + f = t2 + t1**2*(one + t1**2) + go to 390 +c +c watson function. +c + 110 continue + f = zero + do 140 i = 1, 29 + d1 = dfloat(i)/c29 + s1 = zero + d2 = one + do 120 j = 2, n + s1 = s1 + dfloat(j-1)*d2*x(j) + d2 = d1*d2 + 120 continue + s2 = zero + d2 = one + do 130 j = 1, n + s2 = s2 + d2*x(j) + d2 = d1*d2 + 130 continue + t = s1 - s2**2 - one + f = f + t**2 + 140 continue + t1 = x(2) - x(1)**2 - one + f = f + x(1)**2 + t1**2 + go to 390 +c +c penalty function i. +c + 150 continue + t1 = -cp25 + t2 = zero + do 160 j = 1, n + t1 = t1 + x(j)**2 + t2 = t2 + (x(j) - one)**2 + 160 continue + f = ap*t2 + t1**2 + go to 390 +c +c penalty function ii. +c + 170 continue + t1 = -one + t2 = zero + t3 = zero + d1 = dexp(cp1) + d2 = one + do 190 j = 1, n + t1 = t1 + dfloat(n-j+1)*x(j)**2 + s1 = dexp(x(j)/ten) + if (j .eq. 1) go to 180 + s3 = s1 + s2 - d2*(d1 + one) + t2 = t2 + s3**2 + t3 = t3 + (s1 - one/d1)**2 + 180 continue + s2 = s1 + d2 = d1*d2 + 190 continue + f = ap*(t2 + t3) + t1**2 + (x(1) - cp2)**2 + go to 390 +c +c brown badly scaled function. +c + 200 continue + t1 = x(1) - c1pd6 + t2 = x(2) - c2pdm6 + t3 = x(1)*x(2) - two + f = t1**2 + t2**2 + t3**2 + go to 390 +c +c brown and dennis function. +c + 210 continue + f = zero + do 220 i = 1, 20 + d1 = dfloat(i)/five + d2 = dsin(d1) + t1 = x(1) + d1*x(2) - dexp(d1) + t2 = x(3) + d2*x(4) - dcos(d1) + t = t1**2 + t2**2 + f = f + t**2 + 220 continue + go to 390 +c +c gulf research and development function. +c + 230 continue + f = zero + d1 = two/three + do 240 i = 1, 99 + arg = dfloat(i)/c100 + r = (-fifty*dlog(arg))**d1 + c25 - x(2) + t1 = dabs(r)**x(3)/x(1) + t2 = dexp(-t1) + t = t2 - arg + f = f + t**2 + 240 continue + go to 390 +c +c trigonometric function. +c + 250 continue + s1 = zero + do 260 j = 1, n + s1 = s1 + dcos(x(j)) + 260 continue + f = zero + do 270 j = 1, n + t = dfloat(n+j) - dsin(x(j)) - s1 - dfloat(j)*dcos(x(j)) + f = f + t**2 + 270 continue + go to 390 +c +c extended rosenbrock function. +c + 280 continue + f = zero + do 290 j = 1, n, 2 + t1 = one - x(j) + t2 = ten*(x(j+1) - x(j)**2) + f = f + t1**2 + t2**2 + 290 continue + go to 390 +c +c extended powell function. +c + 300 continue + f = zero + do 310 j = 1, n, 4 + t = x(j) + ten*x(j+1) + t1 = x(j+2) - x(j+3) + s1 = five*t1 + t2 = x(j+1) - two*x(j+2) + s2 = t2**3 + t3 = x(j) - x(j+3) + s3 = ten*t3**3 + f = f + t**2 + s1*t1 + s2*t2 + s3*t3 + 310 continue + go to 390 +c +c beale function. +c + 320 continue + s1 = one - x(2) + t1 = c1p5 - x(1)*s1 + s2 = one - x(2)**2 + t2 = c2p25 - x(1)*s2 + s3 = one - x(2)**3 + t3 = c2p625 - x(1)*s3 + f = t1**2 + t2**2 + t3**2 + go to 390 +c +c wood function. +c + 330 continue + s1 = x(2) - x(1)**2 + s2 = one - x(1) + s3 = x(2) - one + t1 = x(4) - x(3)**2 + t2 = one - x(3) + t3 = x(4) - one + f = c100*s1**2 + s2**2 + c90*t1**2 + t2**2 + ten*(s3 + t3)**2 + * + (s3 - t3)**2/ten + go to 390 +c +c chebyquad function. +c + 340 continue + do 350 i = 1, n + fvec(i) = zero + 350 continue + do 370 j = 1, n + t1 = one + t2 = two*x(j) - one + t = two*t2 + do 360 i = 1, n + fvec(i) = fvec(i) + t2 + th = t*t2 - t1 + t1 = t2 + t2 = th + 360 continue + 370 continue + f = zero + d1 = one/dfloat(n) + iev = -1 + do 380 i = 1, n + t = d1*fvec(i) + if (iev .gt. 0) t = t + one/(dfloat(i)**2 - one) + f = f + t**2 + iev = -iev + 380 continue + 390 continue + return +c +c last card of subroutine objfcn. +c + end diff --git a/ocpipt.f b/ocpipt.f new file mode 100644 index 0000000..762ae9e --- /dev/null +++ b/ocpipt.f @@ -0,0 +1,223 @@ + subroutine initpt(n,x,nprob,factor) + integer n,nprob + double precision factor + double precision x(n) +c ********** +c +c subroutine initpt +c +c this subroutine specifies the standard starting points for the +c functions defined by subroutine objfcn. the subroutine returns +c in x a multiple (factor) of the standard starting point. for +c the seventh function the standard starting point is zero, so in +c this case, if factor is not unity, then the subroutine returns +c the vector x(j) = factor, j=1,...,n. +c +c the subroutine statement is +c +c subroutine initpt(n,x,nprob,factor) +c +c where +c +c n is a positive integer input variable. +c +c x is an output array of length n which contains the standard +c starting point for problem nprob multiplied by factor. +c +c nprob is a positive integer input variable which defines the +c number of the problem. nprob must not exceed 18. +c +c factor is an input variable which specifies the multiple of +c the standard starting point. if factor is unity, no +c multiplication is performed. +c +c argonne national laboratory. minpack project. march 1980. +c burton s. garbow, kenneth e. hillstrom, jorge j. more +c +c ********** + integer ivar,j + double precision c1,c2,c3,c4,five,h,half,one,ten,three,twenty, + * twntf,two,zero + double precision dfloat + data zero,half,one,two,three,five,ten,twenty,twntf + * /0.0d0,0.5d0,1.0d0,2.0d0,3.0d0,5.0d0,1.0d1,2.0d1,2.5d1/ + data c1,c2,c3,c4 /4.0d-1,2.5d0,1.5d-1,1.2d0/ + dfloat(ivar) = ivar +c +c selection of initial point. +c + go to (10,20,30,40,50,60,80,100,120,140,150,160,170,190,210,230, + * 240,250), nprob +c +c helical valley function. +c + 10 continue + x(1) = -one + x(2) = zero + x(3) = zero + go to 270 +c +c biggs exp6 function. +c + 20 continue + x(1) = one + x(2) = two + x(3) = one + x(4) = one + x(5) = one + x(6) = one + go to 270 +c +c gaussian function. +c + 30 continue + x(1) = c1 + x(2) = one + x(3) = zero + go to 270 +c +c powell badly scaled function. +c + 40 continue + x(1) = zero + x(2) = one + go to 270 +c +c box 3-dimensional function. +c + 50 continue + x(1) = zero + x(2) = ten + x(3) = twenty + go to 270 +c +c variably dimensioned function. +c + 60 continue + h = one/dfloat(n) + do 70 j = 1, n + x(j) = one - dfloat(j)*h + 70 continue + go to 270 +c +c watson function. +c + 80 continue + do 90 j = 1, n + x(j) = zero + 90 continue + go to 270 +c +c penalty function i. +c + 100 continue + do 110 j = 1, n + x(j) = dfloat(j) + 110 continue + go to 270 +c +c penalty function ii. +c + 120 continue + do 130 j = 1, n + x(j) = half + 130 continue + go to 270 +c +c brown badly scaled function. +c + 140 continue + x(1) = one + x(2) = one + go to 270 +c +c brown and dennis function. +c + 150 continue + x(1) = twntf + x(2) = five + x(3) = -five + x(4) = -one + go to 270 +c +c gulf research and development function. +c + 160 continue + x(1) = five + x(2) = c2 + x(3) = c3 + go to 270 +c +c trigonometric function. +c + 170 continue + h = one/dfloat(n) + do 180 j = 1, n + x(j) = h + 180 continue + go to 270 +c +c extended rosenbrock function. +c + 190 continue + do 200 j = 1, n, 2 + x(j) = -c4 + x(j+1) = one + 200 continue + go to 270 +c +c extended powell singular function. +c + 210 continue + do 220 j = 1, n, 4 + x(j) = three + x(j+1) = -one + x(j+2) = zero + x(j+3) = one + 220 continue + go to 270 +c +c beale function. +c + 230 continue + x(1) = one + x(2) = one + go to 270 +c +c wood function. +c + 240 continue + x(1) = -three + x(2) = -one + x(3) = -three + x(4) = -one + go to 270 +c +c chebyquad function. +c + 250 continue + h = one/dfloat(n+1) + do 260 j = 1, n + x(j) = dfloat(j)*h + 260 continue + 270 continue +c +c compute multiple of initial point. +c + if (factor .eq. one) go to 320 + if (nprob .eq. 7) go to 290 + do 280 j = 1, n + x(j) = factor*x(j) + 280 continue + go to 310 + 290 continue + do 300 j = 1, n + x(j) = factor + 300 continue + 310 continue + 320 continue + return +c +c last card of subroutine initpt. +c + end diff --git a/qform.f b/qform.f new file mode 100644 index 0000000..087b247 --- /dev/null +++ b/qform.f @@ -0,0 +1,95 @@ + subroutine qform(m,n,q,ldq,wa) + integer m,n,ldq + double precision q(ldq,m),wa(m) +c ********** +c +c subroutine qform +c +c this subroutine proceeds from the computed qr factorization of +c an m by n matrix a to accumulate the m by m orthogonal matrix +c q from its factored form. +c +c the subroutine statement is +c +c subroutine qform(m,n,q,ldq,wa) +c +c where +c +c m is a positive integer input variable set to the number +c of rows of a and the order of q. +c +c n is a positive integer input variable set to the number +c of columns of a. +c +c q is an m by m array. on input the full lower trapezoid in +c the first min(m,n) columns of q contains the factored form. +c on output q has been accumulated into a square matrix. +c +c ldq is a positive integer input variable not less than m +c which specifies the leading dimension of the array q. +c +c wa is a work array of length m. +c +c subprograms called +c +c fortran-supplied ... min0 +c +c argonne national laboratory. minpack project. march 1980. +c burton s. garbow, kenneth e. hillstrom, jorge j. more +c +c ********** + integer i,j,jm1,k,l,minmn,np1 + double precision one,sum,temp,zero + data one,zero /1.0d0,0.0d0/ +c +c zero out upper triangle of q in the first min(m,n) columns. +c + minmn = min0(m,n) + if (minmn .lt. 2) go to 30 + do 20 j = 2, minmn + jm1 = j - 1 + do 10 i = 1, jm1 + q(i,j) = zero + 10 continue + 20 continue + 30 continue +c +c initialize remaining columns to those of the identity matrix. +c + np1 = n + 1 + if (m .lt. np1) go to 60 + do 50 j = np1, m + do 40 i = 1, m + q(i,j) = zero + 40 continue + q(j,j) = one + 50 continue + 60 continue +c +c accumulate q from its factored form. +c + do 120 l = 1, minmn + k = minmn - l + 1 + do 70 i = k, m + wa(i) = q(i,k) + q(i,k) = zero + 70 continue + q(k,k) = one + if (wa(k) .eq. zero) go to 110 + do 100 j = k, m + sum = zero + do 80 i = k, m + sum = sum + q(i,j)*wa(i) + 80 continue + temp = sum/wa(k) + do 90 i = k, m + q(i,j) = q(i,j) - temp*wa(i) + 90 continue + 100 continue + 110 continue + 120 continue + return +c +c last card of subroutine qform. +c + end diff --git a/qrfac.f b/qrfac.f new file mode 100644 index 0000000..cb68608 --- /dev/null +++ b/qrfac.f @@ -0,0 +1,164 @@ + subroutine qrfac(m,n,a,lda,pivot,ipvt,lipvt,rdiag,acnorm,wa) + integer m,n,lda,lipvt + integer ipvt(lipvt) + logical pivot + double precision a(lda,n),rdiag(n),acnorm(n),wa(n) +c ********** +c +c subroutine qrfac +c +c this subroutine uses householder transformations with column +c pivoting (optional) to compute a qr factorization of the +c m by n matrix a. that is, qrfac determines an orthogonal +c matrix q, a permutation matrix p, and an upper trapezoidal +c matrix r with diagonal elements of nonincreasing magnitude, +c such that a*p = q*r. the householder transformation for +c column k, k = 1,2,...,min(m,n), is of the form +c +c t +c i - (1/u(k))*u*u +c +c where u has zeros in the first k-1 positions. the form of +c this transformation and the method of pivoting first +c appeared in the corresponding linpack subroutine. +c +c the subroutine statement is +c +c subroutine qrfac(m,n,a,lda,pivot,ipvt,lipvt,rdiag,acnorm,wa) +c +c where +c +c m is a positive integer input variable set to the number +c of rows of a. +c +c n is a positive integer input variable set to the number +c of columns of a. +c +c a is an m by n array. on input a contains the matrix for +c which the qr factorization is to be computed. on output +c the strict upper trapezoidal part of a contains the strict +c upper trapezoidal part of r, and the lower trapezoidal +c part of a contains a factored form of q (the non-trivial +c elements of the u vectors described above). +c +c lda is a positive integer input variable not less than m +c which specifies the leading dimension of the array a. +c +c pivot is a logical input variable. if pivot is set true, +c then column pivoting is enforced. if pivot is set false, +c then no column pivoting is done. +c +c ipvt is an integer output array of length lipvt. ipvt +c defines the permutation matrix p such that a*p = q*r. +c column j of p is column ipvt(j) of the identity matrix. +c if pivot is false, ipvt is not referenced. +c +c lipvt is a positive integer input variable. if pivot is false, +c then lipvt may be as small as 1. if pivot is true, then +c lipvt must be at least n. +c +c rdiag is an output array of length n which contains the +c diagonal elements of r. +c +c acnorm is an output array of length n which contains the +c norms of the corresponding columns of the input matrix a. +c if this information is not needed, then acnorm can coincide +c with rdiag. +c +c wa is a work array of length n. if pivot is false, then wa +c can coincide with rdiag. +c +c subprograms called +c +c minpack-supplied ... dpmpar,enorm +c +c fortran-supplied ... dmax1,dsqrt,min0 +c +c argonne national laboratory. minpack project. march 1980. +c burton s. garbow, kenneth e. hillstrom, jorge j. more +c +c ********** + integer i,j,jp1,k,kmax,minmn + double precision ajnorm,epsmch,one,p05,sum,temp,zero + double precision dpmpar,enorm + data one,p05,zero /1.0d0,5.0d-2,0.0d0/ +c +c epsmch is the machine precision. +c + epsmch = dpmpar(1) +c +c compute the initial column norms and initialize several arrays. +c + do 10 j = 1, n + acnorm(j) = enorm(m,a(1,j)) + rdiag(j) = acnorm(j) + wa(j) = rdiag(j) + if (pivot) ipvt(j) = j + 10 continue +c +c reduce a to r with householder transformations. +c + minmn = min0(m,n) + do 110 j = 1, minmn + if (.not.pivot) go to 40 +c +c bring the column of largest norm into the pivot position. +c + kmax = j + do 20 k = j, n + if (rdiag(k) .gt. rdiag(kmax)) kmax = k + 20 continue + if (kmax .eq. j) go to 40 + do 30 i = 1, m + temp = a(i,j) + a(i,j) = a(i,kmax) + a(i,kmax) = temp + 30 continue + rdiag(kmax) = rdiag(j) + wa(kmax) = wa(j) + k = ipvt(j) + ipvt(j) = ipvt(kmax) + ipvt(kmax) = k + 40 continue +c +c compute the householder transformation to reduce the +c j-th column of a to a multiple of the j-th unit vector. +c + ajnorm = enorm(m-j+1,a(j,j)) + if (ajnorm .eq. zero) go to 100 + if (a(j,j) .lt. zero) ajnorm = -ajnorm + do 50 i = j, m + a(i,j) = a(i,j)/ajnorm + 50 continue + a(j,j) = a(j,j) + one +c +c apply the transformation to the remaining columns +c and update the norms. +c + jp1 = j + 1 + if (n .lt. jp1) go to 100 + do 90 k = jp1, n + sum = zero + do 60 i = j, m + sum = sum + a(i,j)*a(i,k) + 60 continue + temp = sum/a(j,j) + do 70 i = j, m + a(i,k) = a(i,k) - temp*a(i,j) + 70 continue + if (.not.pivot .or. rdiag(k) .eq. zero) go to 80 + temp = a(j,k)/rdiag(k) + rdiag(k) = rdiag(k)*dsqrt(dmax1(zero,one-temp**2)) + if (p05*(rdiag(k)/wa(k))**2 .gt. epsmch) go to 80 + rdiag(k) = enorm(m-j,a(jp1,k)) + wa(k) = rdiag(k) + 80 continue + 90 continue + 100 continue + rdiag(j) = -ajnorm + 110 continue + return +c +c last card of subroutine qrfac. +c + end diff --git a/qrsolv.f b/qrsolv.f new file mode 100644 index 0000000..f48954b --- /dev/null +++ b/qrsolv.f @@ -0,0 +1,193 @@ + subroutine qrsolv(n,r,ldr,ipvt,diag,qtb,x,sdiag,wa) + integer n,ldr + integer ipvt(n) + double precision r(ldr,n),diag(n),qtb(n),x(n),sdiag(n),wa(n) +c ********** +c +c subroutine qrsolv +c +c given an m by n matrix a, an n by n diagonal matrix d, +c and an m-vector b, the problem is to determine an x which +c solves the system +c +c a*x = b , d*x = 0 , +c +c in the least squares sense. +c +c this subroutine completes the solution of the problem +c if it is provided with the necessary information from the +c qr factorization, with column pivoting, of a. that is, if +c a*p = q*r, where p is a permutation matrix, q has orthogonal +c columns, and r is an upper triangular matrix with diagonal +c elements of nonincreasing magnitude, then qrsolv expects +c the full upper triangle of r, the permutation matrix p, +c and the first n components of (q transpose)*b. the system +c a*x = b, d*x = 0, is then equivalent to +c +c t t +c r*z = q *b , p *d*p*z = 0 , +c +c where x = p*z. if this system does not have full rank, +c then a least squares solution is obtained. on output qrsolv +c also provides an upper triangular matrix s such that +c +c t t t +c p *(a *a + d*d)*p = s *s . +c +c s is computed within qrsolv and may be of separate interest. +c +c the subroutine statement is +c +c subroutine qrsolv(n,r,ldr,ipvt,diag,qtb,x,sdiag,wa) +c +c where +c +c n is a positive integer input variable set to the order of r. +c +c r is an n by n array. on input the full upper triangle +c must contain the full upper triangle of the matrix r. +c on output the full upper triangle is unaltered, and the +c strict lower triangle contains the strict upper triangle +c (transposed) of the upper triangular matrix s. +c +c ldr is a positive integer input variable not less than n +c which specifies the leading dimension of the array r. +c +c ipvt is an integer input array of length n which defines the +c permutation matrix p such that a*p = q*r. column j of p +c is column ipvt(j) of the identity matrix. +c +c diag is an input array of length n which must contain the +c diagonal elements of the matrix d. +c +c qtb is an input array of length n which must contain the first +c n elements of the vector (q transpose)*b. +c +c x is an output array of length n which contains the least +c squares solution of the system a*x = b, d*x = 0. +c +c sdiag is an output array of length n which contains the +c diagonal elements of the upper triangular matrix s. +c +c wa is a work array of length n. +c +c subprograms called +c +c fortran-supplied ... dabs,dsqrt +c +c argonne national laboratory. minpack project. march 1980. +c burton s. garbow, kenneth e. hillstrom, jorge j. more +c +c ********** + integer i,j,jp1,k,kp1,l,nsing + double precision cos,cotan,p5,p25,qtbpj,sin,sum,tan,temp,zero + data p5,p25,zero /5.0d-1,2.5d-1,0.0d0/ +c +c copy r and (q transpose)*b to preserve input and initialize s. +c in particular, save the diagonal elements of r in x. +c + do 20 j = 1, n + do 10 i = j, n + r(i,j) = r(j,i) + 10 continue + x(j) = r(j,j) + wa(j) = qtb(j) + 20 continue +c +c eliminate the diagonal matrix d using a givens rotation. +c + do 100 j = 1, n +c +c prepare the row of d to be eliminated, locating the +c diagonal element using p from the qr factorization. +c + l = ipvt(j) + if (diag(l) .eq. zero) go to 90 + do 30 k = j, n + sdiag(k) = zero + 30 continue + sdiag(j) = diag(l) +c +c the transformations to eliminate the row of d +c modify only a single element of (q transpose)*b +c beyond the first n, which is initially zero. +c + qtbpj = zero + do 80 k = j, n +c +c determine a givens rotation which eliminates the +c appropriate element in the current row of d. +c + if (sdiag(k) .eq. zero) go to 70 + if (dabs(r(k,k)) .ge. dabs(sdiag(k))) go to 40 + cotan = r(k,k)/sdiag(k) + sin = p5/dsqrt(p25+p25*cotan**2) + cos = sin*cotan + go to 50 + 40 continue + tan = sdiag(k)/r(k,k) + cos = p5/dsqrt(p25+p25*tan**2) + sin = cos*tan + 50 continue +c +c compute the modified diagonal element of r and +c the modified element of ((q transpose)*b,0). +c + r(k,k) = cos*r(k,k) + sin*sdiag(k) + temp = cos*wa(k) + sin*qtbpj + qtbpj = -sin*wa(k) + cos*qtbpj + wa(k) = temp +c +c accumulate the tranformation in the row of s. +c + kp1 = k + 1 + if (n .lt. kp1) go to 70 + do 60 i = kp1, n + temp = cos*r(i,k) + sin*sdiag(i) + sdiag(i) = -sin*r(i,k) + cos*sdiag(i) + r(i,k) = temp + 60 continue + 70 continue + 80 continue + 90 continue +c +c store the diagonal element of s and restore +c the corresponding diagonal element of r. +c + sdiag(j) = r(j,j) + r(j,j) = x(j) + 100 continue +c +c solve the triangular system for z. if the system is +c singular, then obtain a least squares solution. +c + nsing = n + do 110 j = 1, n + if (sdiag(j) .eq. zero .and. nsing .eq. n) nsing = j - 1 + if (nsing .lt. n) wa(j) = zero + 110 continue + if (nsing .lt. 1) go to 150 + do 140 k = 1, nsing + j = nsing - k + 1 + sum = zero + jp1 = j + 1 + if (nsing .lt. jp1) go to 130 + do 120 i = jp1, nsing + sum = sum + r(i,j)*wa(i) + 120 continue + 130 continue + wa(j) = (wa(j) - sum)/sdiag(j) + 140 continue + 150 continue +c +c permute the components of z back to components of x. +c + do 160 j = 1, n + l = ipvt(j) + x(l) = wa(j) + 160 continue + return +c +c last card of subroutine qrsolv. +c + end diff --git a/r1mpyq.f b/r1mpyq.f new file mode 100644 index 0000000..ec99b96 --- /dev/null +++ b/r1mpyq.f @@ -0,0 +1,92 @@ + subroutine r1mpyq(m,n,a,lda,v,w) + integer m,n,lda + double precision a(lda,n),v(n),w(n) +c ********** +c +c subroutine r1mpyq +c +c given an m by n matrix a, this subroutine computes a*q where +c q is the product of 2*(n - 1) transformations +c +c gv(n-1)*...*gv(1)*gw(1)*...*gw(n-1) +c +c and gv(i), gw(i) are givens rotations in the (i,n) plane which +c eliminate elements in the i-th and n-th planes, respectively. +c q itself is not given, rather the information to recover the +c gv, gw rotations is supplied. +c +c the subroutine statement is +c +c subroutine r1mpyq(m,n,a,lda,v,w) +c +c where +c +c m is a positive integer input variable set to the number +c of rows of a. +c +c n is a positive integer input variable set to the number +c of columns of a. +c +c a is an m by n array. on input a must contain the matrix +c to be postmultiplied by the orthogonal matrix q +c described above. on output a*q has replaced a. +c +c lda is a positive integer input variable not less than m +c which specifies the leading dimension of the array a. +c +c v is an input array of length n. v(i) must contain the +c information necessary to recover the givens rotation gv(i) +c described above. +c +c w is an input array of length n. w(i) must contain the +c information necessary to recover the givens rotation gw(i) +c described above. +c +c subroutines called +c +c fortran-supplied ... dabs,dsqrt +c +c argonne national laboratory. minpack project. march 1980. +c burton s. garbow, kenneth e. hillstrom, jorge j. more +c +c ********** + integer i,j,nmj,nm1 + double precision cos,one,sin,temp + data one /1.0d0/ +c +c apply the first set of givens rotations to a. +c + nm1 = n - 1 + if (nm1 .lt. 1) go to 50 + do 20 nmj = 1, nm1 + j = n - nmj + if (dabs(v(j)) .gt. one) cos = one/v(j) + if (dabs(v(j)) .gt. one) sin = dsqrt(one-cos**2) + if (dabs(v(j)) .le. one) sin = v(j) + if (dabs(v(j)) .le. one) cos = dsqrt(one-sin**2) + do 10 i = 1, m + temp = cos*a(i,j) - sin*a(i,n) + a(i,n) = sin*a(i,j) + cos*a(i,n) + a(i,j) = temp + 10 continue + 20 continue +c +c apply the second set of givens rotations to a. +c + do 40 j = 1, nm1 + if (dabs(w(j)) .gt. one) cos = one/w(j) + if (dabs(w(j)) .gt. one) sin = dsqrt(one-cos**2) + if (dabs(w(j)) .le. one) sin = w(j) + if (dabs(w(j)) .le. one) cos = dsqrt(one-sin**2) + do 30 i = 1, m + temp = cos*a(i,j) + sin*a(i,n) + a(i,n) = -sin*a(i,j) + cos*a(i,n) + a(i,j) = temp + 30 continue + 40 continue + 50 continue + return +c +c last card of subroutine r1mpyq. +c + end diff --git a/r1updt.f b/r1updt.f new file mode 100644 index 0000000..e034973 --- /dev/null +++ b/r1updt.f @@ -0,0 +1,207 @@ + subroutine r1updt(m,n,s,ls,u,v,w,sing) + integer m,n,ls + logical sing + double precision s(ls),u(m),v(n),w(m) +c ********** +c +c subroutine r1updt +c +c given an m by n lower trapezoidal matrix s, an m-vector u, +c and an n-vector v, the problem is to determine an +c orthogonal matrix q such that +c +c t +c (s + u*v )*q +c +c is again lower trapezoidal. +c +c this subroutine determines q as the product of 2*(n - 1) +c transformations +c +c gv(n-1)*...*gv(1)*gw(1)*...*gw(n-1) +c +c where gv(i), gw(i) are givens rotations in the (i,n) plane +c which eliminate elements in the i-th and n-th planes, +c respectively. q itself is not accumulated, rather the +c information to recover the gv, gw rotations is returned. +c +c the subroutine statement is +c +c subroutine r1updt(m,n,s,ls,u,v,w,sing) +c +c where +c +c m is a positive integer input variable set to the number +c of rows of s. +c +c n is a positive integer input variable set to the number +c of columns of s. n must not exceed m. +c +c s is an array of length ls. on input s must contain the lower +c trapezoidal matrix s stored by columns. on output s contains +c the lower trapezoidal matrix produced as described above. +c +c ls is a positive integer input variable not less than +c (n*(2*m-n+1))/2. +c +c u is an input array of length m which must contain the +c vector u. +c +c v is an array of length n. on input v must contain the vector +c v. on output v(i) contains the information necessary to +c recover the givens rotation gv(i) described above. +c +c w is an output array of length m. w(i) contains information +c necessary to recover the givens rotation gw(i) described +c above. +c +c sing is a logical output variable. sing is set true if any +c of the diagonal elements of the output s are zero. otherwise +c sing is set false. +c +c subprograms called +c +c minpack-supplied ... dpmpar +c +c fortran-supplied ... dabs,dsqrt +c +c argonne national laboratory. minpack project. march 1980. +c burton s. garbow, kenneth e. hillstrom, jorge j. more, +c john l. nazareth +c +c ********** + integer i,j,jj,l,nmj,nm1 + double precision cos,cotan,giant,one,p5,p25,sin,tan,tau,temp, + * zero + double precision dpmpar + data one,p5,p25,zero /1.0d0,5.0d-1,2.5d-1,0.0d0/ +c +c giant is the largest magnitude. +c + giant = dpmpar(3) +c +c initialize the diagonal element pointer. +c + jj = (n*(2*m - n + 1))/2 - (m - n) +c +c move the nontrivial part of the last column of s into w. +c + l = jj + do 10 i = n, m + w(i) = s(l) + l = l + 1 + 10 continue +c +c rotate the vector v into a multiple of the n-th unit vector +c in such a way that a spike is introduced into w. +c + nm1 = n - 1 + if (nm1 .lt. 1) go to 70 + do 60 nmj = 1, nm1 + j = n - nmj + jj = jj - (m - j + 1) + w(j) = zero + if (v(j) .eq. zero) go to 50 +c +c determine a givens rotation which eliminates the +c j-th element of v. +c + if (dabs(v(n)) .ge. dabs(v(j))) go to 20 + cotan = v(n)/v(j) + sin = p5/dsqrt(p25+p25*cotan**2) + cos = sin*cotan + tau = one + if (dabs(cos)*giant .gt. one) tau = one/cos + go to 30 + 20 continue + tan = v(j)/v(n) + cos = p5/dsqrt(p25+p25*tan**2) + sin = cos*tan + tau = sin + 30 continue +c +c apply the transformation to v and store the information +c necessary to recover the givens rotation. +c + v(n) = sin*v(j) + cos*v(n) + v(j) = tau +c +c apply the transformation to s and extend the spike in w. +c + l = jj + do 40 i = j, m + temp = cos*s(l) - sin*w(i) + w(i) = sin*s(l) + cos*w(i) + s(l) = temp + l = l + 1 + 40 continue + 50 continue + 60 continue + 70 continue +c +c add the spike from the rank 1 update to w. +c + do 80 i = 1, m + w(i) = w(i) + v(n)*u(i) + 80 continue +c +c eliminate the spike. +c + sing = .false. + if (nm1 .lt. 1) go to 140 + do 130 j = 1, nm1 + if (w(j) .eq. zero) go to 120 +c +c determine a givens rotation which eliminates the +c j-th element of the spike. +c + if (dabs(s(jj)) .ge. dabs(w(j))) go to 90 + cotan = s(jj)/w(j) + sin = p5/dsqrt(p25+p25*cotan**2) + cos = sin*cotan + tau = one + if (dabs(cos)*giant .gt. one) tau = one/cos + go to 100 + 90 continue + tan = w(j)/s(jj) + cos = p5/dsqrt(p25+p25*tan**2) + sin = cos*tan + tau = sin + 100 continue +c +c apply the transformation to s and reduce the spike in w. +c + l = jj + do 110 i = j, m + temp = cos*s(l) + sin*w(i) + w(i) = -sin*s(l) + cos*w(i) + s(l) = temp + l = l + 1 + 110 continue +c +c store the information necessary to recover the +c givens rotation. +c + w(j) = tau + 120 continue +c +c test for zero diagonal elements in the output s. +c + if (s(jj) .eq. zero) sing = .true. + jj = jj + (m - j + 1) + 130 continue + 140 continue +c +c move w back into the last column of the output s. +c + l = jj + do 150 i = n, m + s(l) = w(i) + l = l + 1 + 150 continue + if (s(jj) .eq. zero) sing = .true. + return +c +c last card of subroutine r1updt. +c + end diff --git a/readme b/readme new file mode 100644 index 0000000..5476691 --- /dev/null +++ b/readme @@ -0,0 +1,18 @@ +====== readme for minpack ====== + +Minpack includes software for solving nonlinear equations and +nonlinear least squares problems. Five algorithmic paths each include +a core subroutine and an easy-to-use driver. The algorithms proceed +either from an analytic specification of the Jacobian matrix or +directly from the problem functions. The paths include facilities for +systems of equations with a banded Jacobian matrix, for least squares +problems with a large amount of data, and for checking the consistency +of the Jacobian matrix with the functions. + +This directory contains the double-precision versions. + +Jorge More', Burt Garbow, and Ken Hillstrom at Argonne National Laboratory. + +For copyright information see; + +http://www.netlib.org/minpack/disclaimer diff --git a/rwupdt.f b/rwupdt.f new file mode 100644 index 0000000..05282b5 --- /dev/null +++ b/rwupdt.f @@ -0,0 +1,113 @@ + subroutine rwupdt(n,r,ldr,w,b,alpha,cos,sin) + integer n,ldr + double precision alpha + double precision r(ldr,n),w(n),b(n),cos(n),sin(n) +c ********** +c +c subroutine rwupdt +c +c given an n by n upper triangular matrix r, this subroutine +c computes the qr decomposition of the matrix formed when a row +c is added to r. if the row is specified by the vector w, then +c rwupdt determines an orthogonal matrix q such that when the +c n+1 by n matrix composed of r augmented by w is premultiplied +c by (q transpose), the resulting matrix is upper trapezoidal. +c the matrix (q transpose) is the product of n transformations +c +c g(n)*g(n-1)* ... *g(1) +c +c where g(i) is a givens rotation in the (i,n+1) plane which +c eliminates elements in the (n+1)-st plane. rwupdt also +c computes the product (q transpose)*c where c is the +c (n+1)-vector (b,alpha). q itself is not accumulated, rather +c the information to recover the g rotations is supplied. +c +c the subroutine statement is +c +c subroutine rwupdt(n,r,ldr,w,b,alpha,cos,sin) +c +c where +c +c n is a positive integer input variable set to the order of r. +c +c r is an n by n array. on input the upper triangular part of +c r must contain the matrix to be updated. on output r +c contains the updated triangular matrix. +c +c ldr is a positive integer input variable not less than n +c which specifies the leading dimension of the array r. +c +c w is an input array of length n which must contain the row +c vector to be added to r. +c +c b is an array of length n. on input b must contain the +c first n elements of the vector c. on output b contains +c the first n elements of the vector (q transpose)*c. +c +c alpha is a variable. on input alpha must contain the +c (n+1)-st element of the vector c. on output alpha contains +c the (n+1)-st element of the vector (q transpose)*c. +c +c cos is an output array of length n which contains the +c cosines of the transforming givens rotations. +c +c sin is an output array of length n which contains the +c sines of the transforming givens rotations. +c +c subprograms called +c +c fortran-supplied ... dabs,dsqrt +c +c argonne national laboratory. minpack project. march 1980. +c burton s. garbow, dudley v. goetschel, kenneth e. hillstrom, +c jorge j. more +c +c ********** + integer i,j,jm1 + double precision cotan,one,p5,p25,rowj,tan,temp,zero + data one,p5,p25,zero /1.0d0,5.0d-1,2.5d-1,0.0d0/ +c + do 60 j = 1, n + rowj = w(j) + jm1 = j - 1 +c +c apply the previous transformations to +c r(i,j), i=1,2,...,j-1, and to w(j). +c + if (jm1 .lt. 1) go to 20 + do 10 i = 1, jm1 + temp = cos(i)*r(i,j) + sin(i)*rowj + rowj = -sin(i)*r(i,j) + cos(i)*rowj + r(i,j) = temp + 10 continue + 20 continue +c +c determine a givens rotation which eliminates w(j). +c + cos(j) = one + sin(j) = zero + if (rowj .eq. zero) go to 50 + if (dabs(r(j,j)) .ge. dabs(rowj)) go to 30 + cotan = r(j,j)/rowj + sin(j) = p5/dsqrt(p25+p25*cotan**2) + cos(j) = sin(j)*cotan + go to 40 + 30 continue + tan = rowj/r(j,j) + cos(j) = p5/dsqrt(p25+p25*tan**2) + sin(j) = cos(j)*tan + 40 continue +c +c apply the current transformation to r(j,j), b(j), and alpha. +c + r(j,j) = cos(j)*r(j,j) + sin(j)*rowj + temp = cos(j)*b(j) + sin(j)*alpha + alpha = -sin(j)*b(j) + cos(j)*alpha + b(j) = temp + 50 continue + 60 continue + return +c +c last card of subroutine rwupdt. +c + end diff --git a/ssqfcn.f b/ssqfcn.f new file mode 100644 index 0000000..828c8d1 --- /dev/null +++ b/ssqfcn.f @@ -0,0 +1,340 @@ + subroutine ssqfcn(m,n,x,fvec,nprob) + integer m,n,nprob + double precision x(n),fvec(m) +c ********** +c +c subroutine ssqfcn +c +c this subroutine defines the functions of eighteen nonlinear +c least squares problems. the allowable values of (m,n) for +c functions 1,2 and 3 are variable but with m .ge. n. +c for functions 4,5,6,7,8,9 and 10 the values of (m,n) are +c (2,2),(3,3),(4,4),(2,2),(15,3),(11,4) and (16,3), respectively. +c function 11 (watson) has m = 31 with n usually 6 or 9. +c however, any n, n = 2,...,31, is permitted. +c functions 12,13 and 14 have n = 3,2 and 4, respectively, but +c allow any m .ge. n, with the usual choices being 10,10 and 20. +c function 15 (chebyquad) allows m and n variable with m .ge. n. +c function 16 (brown) allows n variable with m = n. +c for functions 17 and 18, the values of (m,n) are +c (33,5) and (65,11), respectively. +c +c the subroutine statement is +c +c subroutine ssqfcn(m,n,x,fvec,nprob) +c +c where +c +c m and n are positive integer input variables. n must not +c exceed m. +c +c x is an input array of length n. +c +c fvec is an output array of length m which contains the nprob +c function evaluated at x. +c +c nprob is a positive integer input variable which defines the +c number of the problem. nprob must not exceed 18. +c +c subprograms called +c +c fortran-supplied ... datan,dcos,dexp,dsin,dsqrt,dsign +c +c argonne national laboratory. minpack project. march 1980. +c burton s. garbow, kenneth e. hillstrom, jorge j. more +c +c ********** + integer i,iev,ivar,j,nm1 + double precision c13,c14,c29,c45,div,dx,eight,five,one,prod,sum, + * s1,s2,temp,ten,ti,tmp1,tmp2,tmp3,tmp4,tpi,two, + * zero,zp25,zp5 + double precision v(11),y1(15),y2(11),y3(16),y4(33),y5(65) + double precision dfloat + data zero,zp25,zp5,one,two,five,eight,ten,c13,c14,c29,c45 + * /0.0d0,2.5d-1,5.0d-1,1.0d0,2.0d0,5.0d0,8.0d0,1.0d1,1.3d1, + * 1.4d1,2.9d1,4.5d1/ + data v(1),v(2),v(3),v(4),v(5),v(6),v(7),v(8),v(9),v(10),v(11) + * /4.0d0,2.0d0,1.0d0,5.0d-1,2.5d-1,1.67d-1,1.25d-1,1.0d-1, + * 8.33d-2,7.14d-2,6.25d-2/ + data y1(1),y1(2),y1(3),y1(4),y1(5),y1(6),y1(7),y1(8),y1(9), + * y1(10),y1(11),y1(12),y1(13),y1(14),y1(15) + * /1.4d-1,1.8d-1,2.2d-1,2.5d-1,2.9d-1,3.2d-1,3.5d-1,3.9d-1, + * 3.7d-1,5.8d-1,7.3d-1,9.6d-1,1.34d0,2.1d0,4.39d0/ + data y2(1),y2(2),y2(3),y2(4),y2(5),y2(6),y2(7),y2(8),y2(9), + * y2(10),y2(11) + * /1.957d-1,1.947d-1,1.735d-1,1.6d-1,8.44d-2,6.27d-2,4.56d-2, + * 3.42d-2,3.23d-2,2.35d-2,2.46d-2/ + data y3(1),y3(2),y3(3),y3(4),y3(5),y3(6),y3(7),y3(8),y3(9), + * y3(10),y3(11),y3(12),y3(13),y3(14),y3(15),y3(16) + * /3.478d4,2.861d4,2.365d4,1.963d4,1.637d4,1.372d4,1.154d4, + * 9.744d3,8.261d3,7.03d3,6.005d3,5.147d3,4.427d3,3.82d3, + * 3.307d3,2.872d3/ + data y4(1),y4(2),y4(3),y4(4),y4(5),y4(6),y4(7),y4(8),y4(9), + * y4(10),y4(11),y4(12),y4(13),y4(14),y4(15),y4(16),y4(17), + * y4(18),y4(19),y4(20),y4(21),y4(22),y4(23),y4(24),y4(25), + * y4(26),y4(27),y4(28),y4(29),y4(30),y4(31),y4(32),y4(33) + * /8.44d-1,9.08d-1,9.32d-1,9.36d-1,9.25d-1,9.08d-1,8.81d-1, + * 8.5d-1,8.18d-1,7.84d-1,7.51d-1,7.18d-1,6.85d-1,6.58d-1, + * 6.28d-1,6.03d-1,5.8d-1,5.58d-1,5.38d-1,5.22d-1,5.06d-1, + * 4.9d-1,4.78d-1,4.67d-1,4.57d-1,4.48d-1,4.38d-1,4.31d-1, + * 4.24d-1,4.2d-1,4.14d-1,4.11d-1,4.06d-1/ + data y5(1),y5(2),y5(3),y5(4),y5(5),y5(6),y5(7),y5(8),y5(9), + * y5(10),y5(11),y5(12),y5(13),y5(14),y5(15),y5(16),y5(17), + * y5(18),y5(19),y5(20),y5(21),y5(22),y5(23),y5(24),y5(25), + * y5(26),y5(27),y5(28),y5(29),y5(30),y5(31),y5(32),y5(33), + * y5(34),y5(35),y5(36),y5(37),y5(38),y5(39),y5(40),y5(41), + * y5(42),y5(43),y5(44),y5(45),y5(46),y5(47),y5(48),y5(49), + * y5(50),y5(51),y5(52),y5(53),y5(54),y5(55),y5(56),y5(57), + * y5(58),y5(59),y5(60),y5(61),y5(62),y5(63),y5(64),y5(65) + * /1.366d0,1.191d0,1.112d0,1.013d0,9.91d-1,8.85d-1,8.31d-1, + * 8.47d-1,7.86d-1,7.25d-1,7.46d-1,6.79d-1,6.08d-1,6.55d-1, + * 6.16d-1,6.06d-1,6.02d-1,6.26d-1,6.51d-1,7.24d-1,6.49d-1, + * 6.49d-1,6.94d-1,6.44d-1,6.24d-1,6.61d-1,6.12d-1,5.58d-1, + * 5.33d-1,4.95d-1,5.0d-1,4.23d-1,3.95d-1,3.75d-1,3.72d-1, + * 3.91d-1,3.96d-1,4.05d-1,4.28d-1,4.29d-1,5.23d-1,5.62d-1, + * 6.07d-1,6.53d-1,6.72d-1,7.08d-1,6.33d-1,6.68d-1,6.45d-1, + * 6.32d-1,5.91d-1,5.59d-1,5.97d-1,6.25d-1,7.39d-1,7.1d-1, + * 7.29d-1,7.2d-1,6.36d-1,5.81d-1,4.28d-1,2.92d-1,1.62d-1, + * 9.8d-2,5.4d-2/ + dfloat(ivar) = ivar +c +c function routine selector. +c + go to (10,40,70,110,120,130,140,150,170,190,210,250,270,290,310, + * 360,390,410), nprob +c +c linear function - full rank. +c + 10 continue + sum = zero + do 20 j = 1, n + sum = sum + x(j) + 20 continue + temp = two*sum/dfloat(m) + one + do 30 i = 1, m + fvec(i) = -temp + if (i .le. n) fvec(i) = fvec(i) + x(i) + 30 continue + go to 430 +c +c linear function - rank 1. +c + 40 continue + sum = zero + do 50 j = 1, n + sum = sum + dfloat(j)*x(j) + 50 continue + do 60 i = 1, m + fvec(i) = dfloat(i)*sum - one + 60 continue + go to 430 +c +c linear function - rank 1 with zero columns and rows. +c + 70 continue + sum = zero + nm1 = n - 1 + if (nm1 .lt. 2) go to 90 + do 80 j = 2, nm1 + sum = sum + dfloat(j)*x(j) + 80 continue + 90 continue + do 100 i = 1, m + fvec(i) = dfloat(i-1)*sum - one + 100 continue + fvec(m) = -one + go to 430 +c +c rosenbrock function. +c + 110 continue + fvec(1) = ten*(x(2) - x(1)**2) + fvec(2) = one - x(1) + go to 430 +c +c helical valley function. +c + 120 continue + tpi = eight*datan(one) + tmp1 = dsign(zp25,x(2)) + if (x(1) .gt. zero) tmp1 = datan(x(2)/x(1))/tpi + if (x(1) .lt. zero) tmp1 = datan(x(2)/x(1))/tpi + zp5 + tmp2 = dsqrt(x(1)**2+x(2)**2) + fvec(1) = ten*(x(3) - ten*tmp1) + fvec(2) = ten*(tmp2 - one) + fvec(3) = x(3) + go to 430 +c +c powell singular function. +c + 130 continue + fvec(1) = x(1) + ten*x(2) + fvec(2) = dsqrt(five)*(x(3) - x(4)) + fvec(3) = (x(2) - two*x(3))**2 + fvec(4) = dsqrt(ten)*(x(1) - x(4))**2 + go to 430 +c +c freudenstein and roth function. +c + 140 continue + fvec(1) = -c13 + x(1) + ((five - x(2))*x(2) - two)*x(2) + fvec(2) = -c29 + x(1) + ((one + x(2))*x(2) - c14)*x(2) + go to 430 +c +c bard function. +c + 150 continue + do 160 i = 1, 15 + tmp1 = dfloat(i) + tmp2 = dfloat(16-i) + tmp3 = tmp1 + if (i .gt. 8) tmp3 = tmp2 + fvec(i) = y1(i) - (x(1) + tmp1/(x(2)*tmp2 + x(3)*tmp3)) + 160 continue + go to 430 +c +c kowalik and osborne function. +c + 170 continue + do 180 i = 1, 11 + tmp1 = v(i)*(v(i) + x(2)) + tmp2 = v(i)*(v(i) + x(3)) + x(4) + fvec(i) = y2(i) - x(1)*tmp1/tmp2 + 180 continue + go to 430 +c +c meyer function. +c + 190 continue + do 200 i = 1, 16 + temp = five*dfloat(i) + c45 + x(3) + tmp1 = x(2)/temp + tmp2 = dexp(tmp1) + fvec(i) = x(1)*tmp2 - y3(i) + 200 continue + go to 430 +c +c watson function. +c + 210 continue + do 240 i = 1, 29 + div = dfloat(i)/c29 + s1 = zero + dx = one + do 220 j = 2, n + s1 = s1 + dfloat(j-1)*dx*x(j) + dx = div*dx + 220 continue + s2 = zero + dx = one + do 230 j = 1, n + s2 = s2 + dx*x(j) + dx = div*dx + 230 continue + fvec(i) = s1 - s2**2 - one + 240 continue + fvec(30) = x(1) + fvec(31) = x(2) - x(1)**2 - one + go to 430 +c +c box 3-dimensional function. +c + 250 continue + do 260 i = 1, m + temp = dfloat(i) + tmp1 = temp/ten + fvec(i) = dexp(-tmp1*x(1)) - dexp(-tmp1*x(2)) + * + (dexp(-temp) - dexp(-tmp1))*x(3) + 260 continue + go to 430 +c +c jennrich and sampson function. +c + 270 continue + do 280 i = 1, m + temp = dfloat(i) + fvec(i) = two + two*temp - dexp(temp*x(1)) - dexp(temp*x(2)) + 280 continue + go to 430 +c +c brown and dennis function. +c + 290 continue + do 300 i = 1, m + temp = dfloat(i)/five + tmp1 = x(1) + temp*x(2) - dexp(temp) + tmp2 = x(3) + dsin(temp)*x(4) - dcos(temp) + fvec(i) = tmp1**2 + tmp2**2 + 300 continue + go to 430 +c +c chebyquad function. +c + 310 continue + do 320 i = 1, m + fvec(i) = zero + 320 continue + do 340 j = 1, n + tmp1 = one + tmp2 = two*x(j) - one + temp = two*tmp2 + do 330 i = 1, m + fvec(i) = fvec(i) + tmp2 + ti = temp*tmp2 - tmp1 + tmp1 = tmp2 + tmp2 = ti + 330 continue + 340 continue + dx = one/dfloat(n) + iev = -1 + do 350 i = 1, m + fvec(i) = dx*fvec(i) + if (iev .gt. 0) fvec(i) = fvec(i) + one/(dfloat(i)**2 - one) + iev = -iev + 350 continue + go to 430 +c +c brown almost-linear function. +c + 360 continue + sum = -dfloat(n+1) + prod = one + do 370 j = 1, n + sum = sum + x(j) + prod = x(j)*prod + 370 continue + do 380 i = 1, n + fvec(i) = x(i) + sum + 380 continue + fvec(n) = prod - one + go to 430 +c +c osborne 1 function. +c + 390 continue + do 400 i = 1, 33 + temp = ten*dfloat(i-1) + tmp1 = dexp(-x(4)*temp) + tmp2 = dexp(-x(5)*temp) + fvec(i) = y4(i) - (x(1) + x(2)*tmp1 + x(3)*tmp2) + 400 continue + go to 430 +c +c osborne 2 function. +c + 410 continue + do 420 i = 1, 65 + temp = dfloat(i-1)/ten + tmp1 = dexp(-x(5)*temp) + tmp2 = dexp(-x(6)*(temp-x(9))**2) + tmp3 = dexp(-x(7)*(temp-x(10))**2) + tmp4 = dexp(-x(8)*(temp-x(11))**2) + fvec(i) = y5(i) + * - (x(1)*tmp1 + x(2)*tmp2 + x(3)*tmp3 + x(4)*tmp4) + 420 continue + 430 continue + return +c +c last card of subroutine ssqfcn. +c + end diff --git a/ssqjac.f b/ssqjac.f new file mode 100644 index 0000000..c57b8bd --- /dev/null +++ b/ssqjac.f @@ -0,0 +1,347 @@ + subroutine ssqjac(m,n,x,fjac,ldfjac,nprob) + integer m,n,ldfjac,nprob + double precision x(n),fjac(ldfjac,n) +c ********** +c +c subroutine ssqjac +c +c this subroutine defines the jacobian matrices of eighteen +c nonlinear least squares problems. the problem dimensions are +c as described in the prologue comments of ssqfcn. +c +c the subroutine statement is +c +c subroutine ssqjac(m,n,x,fjac,ldfjac,nprob) +c +c where +c +c m and n are positive integer input variables. n must not +c exceed m. +c +c x is an input array of length n. +c +c fjac is an m by n output array which contains the jacobian +c matrix of the nprob function evaluated at x. +c +c ldfjac is a positive integer input variable not less than m +c which specifies the leading dimension of the array fjac. +c +c nprob is a positive integer variable which defines the +c number of the problem. nprob must not exceed 18. +c +c subprograms called +c +c fortran-supplied ... datan,dcos,dexp,dsin,dsqrt +c +c argonne national laboratory. minpack project. march 1980. +c burton s. garbow, kenneth e. hillstrom, jorge j. more +c +c ********** + integer i,ivar,j,k,mm1,nm1 + double precision c14,c20,c29,c45,c100,div,dx,eight,five,four, + * one,prod,s2,temp,ten,three,ti,tmp1,tmp2,tmp3, + * tmp4,tpi,two,zero + double precision v(11) + double precision dfloat + data zero,one,two,three,four,five,eight,ten,c14,c20,c29,c45,c100 + * /0.0d0,1.0d0,2.0d0,3.0d0,4.0d0,5.0d0,8.0d0,1.0d1,1.4d1, + * 2.0d1,2.9d1,4.5d1,1.0d2/ + data v(1),v(2),v(3),v(4),v(5),v(6),v(7),v(8),v(9),v(10),v(11) + * /4.0d0,2.0d0,1.0d0,5.0d-1,2.5d-1,1.67d-1,1.25d-1,1.0d-1, + * 8.33d-2,7.14d-2,6.25d-2/ + dfloat(ivar) = ivar +c +c jacobian routine selector. +c + go to (10,40,70,130,140,150,180,190,210,230,250,310,330,350,370, + * 400,460,480), nprob +c +c linear function - full rank. +c + 10 continue + temp = two/dfloat(m) + do 30 j = 1, n + do 20 i = 1, m + fjac(i,j) = -temp + 20 continue + fjac(j,j) = fjac(j,j) + one + 30 continue + go to 500 +c +c linear function - rank 1. +c + 40 continue + do 60 j = 1, n + do 50 i = 1, m + fjac(i,j) = dfloat(i)*dfloat(j) + 50 continue + 60 continue + go to 500 +c +c linear function - rank 1 with zero columns and rows. +c + 70 continue + do 90 j = 1, n + do 80 i = 1, m + fjac(i,j) = zero + 80 continue + 90 continue + nm1 = n - 1 + mm1 = m - 1 + if (nm1 .lt. 2) go to 120 + do 110 j = 2, nm1 + do 100 i = 2, mm1 + fjac(i,j) = dfloat(i-1)*dfloat(j) + 100 continue + 110 continue + 120 continue + go to 500 +c +c rosenbrock function. +c + 130 continue + fjac(1,1) = -c20*x(1) + fjac(1,2) = ten + fjac(2,1) = -one + fjac(2,2) = zero + go to 500 +c +c helical valley function. +c + 140 continue + tpi = eight*datan(one) + temp = x(1)**2 + x(2)**2 + tmp1 = tpi*temp + tmp2 = dsqrt(temp) + fjac(1,1) = c100*x(2)/tmp1 + fjac(1,2) = -c100*x(1)/tmp1 + fjac(1,3) = ten + fjac(2,1) = ten*x(1)/tmp2 + fjac(2,2) = ten*x(2)/tmp2 + fjac(2,3) = zero + fjac(3,1) = zero + fjac(3,2) = zero + fjac(3,3) = one + go to 500 +c +c powell singular function. +c + 150 continue + do 170 j = 1, 4 + do 160 i = 1, 4 + fjac(i,j) = zero + 160 continue + 170 continue + fjac(1,1) = one + fjac(1,2) = ten + fjac(2,3) = dsqrt(five) + fjac(2,4) = -fjac(2,3) + fjac(3,2) = two*(x(2) - two*x(3)) + fjac(3,3) = -two*fjac(3,2) + fjac(4,1) = two*dsqrt(ten)*(x(1) - x(4)) + fjac(4,4) = -fjac(4,1) + go to 500 +c +c freudenstein and roth function. +c + 180 continue + fjac(1,1) = one + fjac(1,2) = x(2)*(ten - three*x(2)) - two + fjac(2,1) = one + fjac(2,2) = x(2)*(two + three*x(2)) - c14 + go to 500 +c +c bard function. +c + 190 continue + do 200 i = 1, 15 + tmp1 = dfloat(i) + tmp2 = dfloat(16-i) + tmp3 = tmp1 + if (i .gt. 8) tmp3 = tmp2 + tmp4 = (x(2)*tmp2 + x(3)*tmp3)**2 + fjac(i,1) = -one + fjac(i,2) = tmp1*tmp2/tmp4 + fjac(i,3) = tmp1*tmp3/tmp4 + 200 continue + go to 500 +c +c kowalik and osborne function. +c + 210 continue + do 220 i = 1, 11 + tmp1 = v(i)*(v(i) + x(2)) + tmp2 = v(i)*(v(i) + x(3)) + x(4) + fjac(i,1) = -tmp1/tmp2 + fjac(i,2) = -v(i)*x(1)/tmp2 + fjac(i,3) = fjac(i,1)*fjac(i,2) + fjac(i,4) = fjac(i,3)/v(i) + 220 continue + go to 500 +c +c meyer function. +c + 230 continue + do 240 i = 1, 16 + temp = five*dfloat(i) + c45 + x(3) + tmp1 = x(2)/temp + tmp2 = dexp(tmp1) + fjac(i,1) = tmp2 + fjac(i,2) = x(1)*tmp2/temp + fjac(i,3) = -tmp1*fjac(i,2) + 240 continue + go to 500 +c +c watson function. +c + 250 continue + do 280 i = 1, 29 + div = dfloat(i)/c29 + s2 = zero + dx = one + do 260 j = 1, n + s2 = s2 + dx*x(j) + dx = div*dx + 260 continue + temp = two*div*s2 + dx = one/div + do 270 j = 1, n + fjac(i,j) = dx*(dfloat(j-1) - temp) + dx = div*dx + 270 continue + 280 continue + do 300 j = 1, n + do 290 i = 30, 31 + fjac(i,j) = zero + 290 continue + 300 continue + fjac(30,1) = one + fjac(31,1) = -two*x(1) + fjac(31,2) = one + go to 500 +c +c box 3-dimensional function. +c + 310 continue + do 320 i = 1, m + temp = dfloat(i) + tmp1 = temp/ten + fjac(i,1) = -tmp1*dexp(-tmp1*x(1)) + fjac(i,2) = tmp1*dexp(-tmp1*x(2)) + fjac(i,3) = dexp(-temp) - dexp(-tmp1) + 320 continue + go to 500 +c +c jennrich and sampson function. +c + 330 continue + do 340 i = 1, m + temp = dfloat(i) + fjac(i,1) = -temp*dexp(temp*x(1)) + fjac(i,2) = -temp*dexp(temp*x(2)) + 340 continue + go to 500 +c +c brown and dennis function. +c + 350 continue + do 360 i = 1, m + temp = dfloat(i)/five + ti = dsin(temp) + tmp1 = x(1) + temp*x(2) - dexp(temp) + tmp2 = x(3) + ti*x(4) - dcos(temp) + fjac(i,1) = two*tmp1 + fjac(i,2) = temp*fjac(i,1) + fjac(i,3) = two*tmp2 + fjac(i,4) = ti*fjac(i,3) + 360 continue + go to 500 +c +c chebyquad function. +c + 370 continue + dx = one/dfloat(n) + do 390 j = 1, n + tmp1 = one + tmp2 = two*x(j) - one + temp = two*tmp2 + tmp3 = zero + tmp4 = two + do 380 i = 1, m + fjac(i,j) = dx*tmp4 + ti = four*tmp2 + temp*tmp4 - tmp3 + tmp3 = tmp4 + tmp4 = ti + ti = temp*tmp2 - tmp1 + tmp1 = tmp2 + tmp2 = ti + 380 continue + 390 continue + go to 500 +c +c brown almost-linear function. +c + 400 continue + prod = one + do 420 j = 1, n + prod = x(j)*prod + do 410 i = 1, n + fjac(i,j) = one + 410 continue + fjac(j,j) = two + 420 continue + do 450 j = 1, n + temp = x(j) + if (temp .ne. zero) go to 440 + temp = one + prod = one + do 430 k = 1, n + if (k .ne. j) prod = x(k)*prod + 430 continue + 440 continue + fjac(n,j) = prod/temp + 450 continue + go to 500 +c +c osborne 1 function. +c + 460 continue + do 470 i = 1, 33 + temp = ten*dfloat(i-1) + tmp1 = dexp(-x(4)*temp) + tmp2 = dexp(-x(5)*temp) + fjac(i,1) = -one + fjac(i,2) = -tmp1 + fjac(i,3) = -tmp2 + fjac(i,4) = temp*x(2)*tmp1 + fjac(i,5) = temp*x(3)*tmp2 + 470 continue + go to 500 +c +c osborne 2 function. +c + 480 continue + do 490 i = 1, 65 + temp = dfloat(i-1)/ten + tmp1 = dexp(-x(5)*temp) + tmp2 = dexp(-x(6)*(temp-x(9))**2) + tmp3 = dexp(-x(7)*(temp-x(10))**2) + tmp4 = dexp(-x(8)*(temp-x(11))**2) + fjac(i,1) = -tmp1 + fjac(i,2) = -tmp2 + fjac(i,3) = -tmp3 + fjac(i,4) = -tmp4 + fjac(i,5) = temp*x(1)*tmp1 + fjac(i,6) = x(2)*(temp - x(9))**2*tmp2 + fjac(i,7) = x(3)*(temp - x(10))**2*tmp3 + fjac(i,8) = x(4)*(temp - x(11))**2*tmp4 + fjac(i,9) = -two*x(2)*x(6)*(temp - x(9))*tmp2 + fjac(i,10) = -two*x(3)*x(7)*(temp - x(10))*tmp3 + fjac(i,11) = -two*x(4)*x(8)*(temp - x(11))*tmp4 + 490 continue + 500 continue + return +c +c last card of subroutine ssqjac. +c + end diff --git a/ucodrv.f b/ucodrv.f new file mode 100644 index 0000000..3df3c44 --- /dev/null +++ b/ucodrv.f @@ -0,0 +1,122 @@ +c ********** +c +c this program tests codes for the unconstrained optimization of +c a nonlinear function of n variables. it consists of a driver +c and an interface subroutine fcn. the driver reads in data, +c calls the unconstrained optimizer, and finally prints out +c information on the performance of the optimizer. this is +c only a sample driver, many other drivers are possible. the +c interface subroutine fcn is necessary to take into account the +c forms of calling sequences used by the function subroutines +c in the various unconstrained optimizers. +c +c subprograms called +c +c user-supplied ...... fcn +c +c minpack-supplied ... dpmpar,drvcr1,enorm,grdfcn,initpt,objfcn +c +c fortran-supplied ... dsqrt +c +c argonne national laboratory. minpack project. march 1980. +c burton s. garbow, kenneth e. hillstrom, jorge j. more +c +c ********** + integer i,ic,info,k,lwa,n,nfev,nprob,nread,ntries,nwrite + integer na(120),nf(120),np(120),nx(120) + double precision factor,f1,f2,gnorm1,gnorm2,one,ten,tol + double precision fval(120),gvec(100),gnm(120),wa(6130),x(100) + double precision dpmpar,enorm + external fcn + common /refnum/ nprob,nfev +c +c logical input unit is assumed to be number 5. +c logical output unit is assumed to be number 6. +c + data nread,nwrite /5,6/ +c + data one,ten /1.0d0,1.0d1/ + tol = dsqrt(dpmpar(1)) + lwa = 6130 + ic = 0 + 10 continue + read (nread,50) nprob,n,ntries + if (nprob .le. 0) go to 30 + factor = one + do 20 k = 1, ntries + ic = ic + 1 + call initpt(n,x,nprob,factor) + call objfcn(n,x,f1,nprob) + call grdfcn(n,x,gvec,nprob) + gnorm1 = enorm(n,gvec) + write (nwrite,60) nprob,n + nfev = 0 + call drvcr1(fcn,n,x,f2,gvec,tol,info,wa,lwa) + call objfcn(n,x,f2,nprob) + call grdfcn(n,x,gvec,nprob) + gnorm2 = enorm(n,gvec) + np(ic) = nprob + na(ic) = n + nf(ic) = nfev + nx(ic) = info + fval(ic) = f2 + gnm(ic) = gnorm2 + write (nwrite,70) + * f1,f2,gnorm1,gnorm2,nfev,info,(x(i), i = 1, n) + factor = ten*factor + 20 continue + go to 10 + 30 continue + write (nwrite,80) ic + write (nwrite,90) + do 40 i = 1, ic + write (nwrite,100) np(i),na(i),nf(i),nx(i),fval(i),gnm(i) + 40 continue + stop + 50 format (3i5) + 60 format ( //// 5x, 8h problem, i5, 5x, 10h dimension, i5, 5x //) + 70 format (5x, 23h initial function value, d15.7 // 5x, + * 23h final function value , d15.7 // 5x, + * 23h initial gradient norm , d15.7 // 5x, + * 23h final gradient norm , d15.7 // 5x, + * 33h number of function evaluations , i10 // 5x, + * 15h exit parameter, 18x, i10 // 5x, + * 27h final approximate solution // (5x, 5d15.7)) + 80 format (12h1summary of , i3, 16h calls to drvcr1 /) + 90 format (25h nprob n nfev info , + * 42h final function value final gradient norm /) + 100 format (i4, i6, i7, i6, 5x, d15.7, 6x, d15.7) +c +c last card of driver. +c + end + subroutine fcn(n,x,f,gvec,iflag) + integer n,iflag + double precision f + double precision x(n),gvec(n) +c ********** +c +c the calling sequence of fcn should be identical to the +c calling sequence of the function subroutine in the +c unconstrained optimizer. fcn should only call the testing +c function and gradient subroutines objfcn and grdfcn with +c the appropriate value of problem number (nprob). +c +c subprograms called +c +c minpack-supplied ... grdfcn,objfcn +c +c argonne national laboratory. minpack project. march 1980. +c burton s. garbow, kenneth e. hillstrom, jorge j. more +c +c ********** + integer nprob,nfev + common /refnum/ nprob,nfev + call objfcn(n,x,f,nprob) + call grdfcn(n,x,gvec,nprob) + nfev = nfev + 1 + return +c +c last card of interface subroutine fcn. +c + end diff --git a/vecfcn.f b/vecfcn.f new file mode 100644 index 0000000..aa7e16a --- /dev/null +++ b/vecfcn.f @@ -0,0 +1,273 @@ + subroutine vecfcn(n,x,fvec,nprob) + integer n,nprob + double precision x(n),fvec(n) +c ********** +c +c subroutine vecfcn +c +c this subroutine defines fourteen test functions. the first +c five test functions are of dimensions 2,4,2,4,3, respectively, +c while the remaining test functions are of variable dimension +c n for any n greater than or equal to 1 (problem 6 is an +c exception to this, since it does not allow n = 1). +c +c the subroutine statement is +c +c subroutine vecfcn(n,x,fvec,nprob) +c +c where +c +c n is a positive integer input variable. +c +c x is an input array of length n. +c +c fvec is an output array of length n which contains the nprob +c function vector evaluated at x. +c +c nprob is a positive integer input variable which defines the +c number of the problem. nprob must not exceed 14. +c +c subprograms called +c +c fortran-supplied ... datan,dcos,dexp,dsign,dsin,dsqrt, +c max0,min0 +c +c argonne national laboratory. minpack project. march 1980. +c burton s. garbow, kenneth e. hillstrom, jorge j. more +c +c ********** + integer i,iev,ivar,j,k,k1,k2,kp1,ml,mu + double precision c1,c2,c3,c4,c5,c6,c7,c8,c9,eight,five,h,one, + * prod,sum,sum1,sum2,temp,temp1,temp2,ten,three, + * ti,tj,tk,tpi,two,zero + double precision dfloat + data zero,one,two,three,five,eight,ten + * /0.0d0,1.0d0,2.0d0,3.0d0,5.0d0,8.0d0,1.0d1/ + data c1,c2,c3,c4,c5,c6,c7,c8,c9 + * /1.0d4,1.0001d0,2.0d2,2.02d1,1.98d1,1.8d2,2.5d-1,5.0d-1, + * 2.9d1/ + dfloat(ivar) = ivar +c +c problem selector. +c + go to (10,20,30,40,50,60,120,170,200,220,270,300,330,350), nprob +c +c rosenbrock function. +c + 10 continue + fvec(1) = one - x(1) + fvec(2) = ten*(x(2) - x(1)**2) + go to 380 +c +c powell singular function. +c + 20 continue + fvec(1) = x(1) + ten*x(2) + fvec(2) = dsqrt(five)*(x(3) - x(4)) + fvec(3) = (x(2) - two*x(3))**2 + fvec(4) = dsqrt(ten)*(x(1) - x(4))**2 + go to 380 +c +c powell badly scaled function. +c + 30 continue + fvec(1) = c1*x(1)*x(2) - one + fvec(2) = dexp(-x(1)) + dexp(-x(2)) - c2 + go to 380 +c +c wood function. +c + 40 continue + temp1 = x(2) - x(1)**2 + temp2 = x(4) - x(3)**2 + fvec(1) = -c3*x(1)*temp1 - (one - x(1)) + fvec(2) = c3*temp1 + c4*(x(2) - one) + c5*(x(4) - one) + fvec(3) = -c6*x(3)*temp2 - (one - x(3)) + fvec(4) = c6*temp2 + c4*(x(4) - one) + c5*(x(2) - one) + go to 380 +c +c helical valley function. +c + 50 continue + tpi = eight*datan(one) + temp1 = dsign(c7,x(2)) + if (x(1) .gt. zero) temp1 = datan(x(2)/x(1))/tpi + if (x(1) .lt. zero) temp1 = datan(x(2)/x(1))/tpi + c8 + temp2 = dsqrt(x(1)**2+x(2)**2) + fvec(1) = ten*(x(3) - ten*temp1) + fvec(2) = ten*(temp2 - one) + fvec(3) = x(3) + go to 380 +c +c watson function. +c + 60 continue + do 70 k = 1, n + fvec(k) = zero + 70 continue + do 110 i = 1, 29 + ti = dfloat(i)/c9 + sum1 = zero + temp = one + do 80 j = 2, n + sum1 = sum1 + dfloat(j-1)*temp*x(j) + temp = ti*temp + 80 continue + sum2 = zero + temp = one + do 90 j = 1, n + sum2 = sum2 + temp*x(j) + temp = ti*temp + 90 continue + temp1 = sum1 - sum2**2 - one + temp2 = two*ti*sum2 + temp = one/ti + do 100 k = 1, n + fvec(k) = fvec(k) + temp*(dfloat(k-1) - temp2)*temp1 + temp = ti*temp + 100 continue + 110 continue + temp = x(2) - x(1)**2 - one + fvec(1) = fvec(1) + x(1)*(one - two*temp) + fvec(2) = fvec(2) + temp + go to 380 +c +c chebyquad function. +c + 120 continue + do 130 k = 1, n + fvec(k) = zero + 130 continue + do 150 j = 1, n + temp1 = one + temp2 = two*x(j) - one + temp = two*temp2 + do 140 i = 1, n + fvec(i) = fvec(i) + temp2 + ti = temp*temp2 - temp1 + temp1 = temp2 + temp2 = ti + 140 continue + 150 continue + tk = one/dfloat(n) + iev = -1 + do 160 k = 1, n + fvec(k) = tk*fvec(k) + if (iev .gt. 0) fvec(k) = fvec(k) + one/(dfloat(k)**2 - one) + iev = -iev + 160 continue + go to 380 +c +c brown almost-linear function. +c + 170 continue + sum = -dfloat(n+1) + prod = one + do 180 j = 1, n + sum = sum + x(j) + prod = x(j)*prod + 180 continue + do 190 k = 1, n + fvec(k) = x(k) + sum + 190 continue + fvec(n) = prod - one + go to 380 +c +c discrete boundary value function. +c + 200 continue + h = one/dfloat(n+1) + do 210 k = 1, n + temp = (x(k) + dfloat(k)*h + one)**3 + temp1 = zero + if (k .ne. 1) temp1 = x(k-1) + temp2 = zero + if (k .ne. n) temp2 = x(k+1) + fvec(k) = two*x(k) - temp1 - temp2 + temp*h**2/two + 210 continue + go to 380 +c +c discrete integral equation function. +c + 220 continue + h = one/dfloat(n+1) + do 260 k = 1, n + tk = dfloat(k)*h + sum1 = zero + do 230 j = 1, k + tj = dfloat(j)*h + temp = (x(j) + tj + one)**3 + sum1 = sum1 + tj*temp + 230 continue + sum2 = zero + kp1 = k + 1 + if (n .lt. kp1) go to 250 + do 240 j = kp1, n + tj = dfloat(j)*h + temp = (x(j) + tj + one)**3 + sum2 = sum2 + (one - tj)*temp + 240 continue + 250 continue + fvec(k) = x(k) + h*((one - tk)*sum1 + tk*sum2)/two + 260 continue + go to 380 +c +c trigonometric function. +c + 270 continue + sum = zero + do 280 j = 1, n + fvec(j) = dcos(x(j)) + sum = sum + fvec(j) + 280 continue + do 290 k = 1, n + fvec(k) = dfloat(n+k) - dsin(x(k)) - sum - dfloat(k)*fvec(k) + 290 continue + go to 380 +c +c variably dimensioned function. +c + 300 continue + sum = zero + do 310 j = 1, n + sum = sum + dfloat(j)*(x(j) - one) + 310 continue + temp = sum*(one + two*sum**2) + do 320 k = 1, n + fvec(k) = x(k) - one + dfloat(k)*temp + 320 continue + go to 380 +c +c broyden tridiagonal function. +c + 330 continue + do 340 k = 1, n + temp = (three - two*x(k))*x(k) + temp1 = zero + if (k .ne. 1) temp1 = x(k-1) + temp2 = zero + if (k .ne. n) temp2 = x(k+1) + fvec(k) = temp - temp1 - two*temp2 + one + 340 continue + go to 380 +c +c broyden banded function. +c + 350 continue + ml = 5 + mu = 1 + do 370 k = 1, n + k1 = max0(1,k-ml) + k2 = min0(k+mu,n) + temp = zero + do 360 j = k1, k2 + if (j .ne. k) temp = temp + x(j)*(one + x(j)) + 360 continue + fvec(k) = x(k)*(two + five*x(k)**2) + one - temp + 370 continue + 380 continue + return +c +c last card of subroutine vecfcn. +c + end diff --git a/vecjac.f b/vecjac.f new file mode 100644 index 0000000..7debfed --- /dev/null +++ b/vecjac.f @@ -0,0 +1,321 @@ + subroutine vecjac(n,x,fjac,ldfjac,nprob) + integer n,ldfjac,nprob + double precision x(n),fjac(ldfjac,n) +c ********** +c +c subroutine vecjac +c +c this subroutine defines the jacobian matrices of fourteen +c test functions. the problem dimensions are as described +c in the prologue comments of vecfcn. +c +c the subroutine statement is +c +c subroutine vecjac(n,x,fjac,ldfjac,nprob) +c +c where +c +c n is a positive integer variable. +c +c x is an array of length n. +c +c fjac is an n by n array. on output fjac contains the +c jacobian matrix of the nprob function evaluated at x. +c +c ldfjac is a positive integer variable not less than n +c which specifies the leading dimension of the array fjac. +c +c nprob is a positive integer variable which defines the +c number of the problem. nprob must not exceed 14. +c +c subprograms called +c +c fortran-supplied ... datan,dcos,dexp,dmin1,dsin,dsqrt, +c max0,min0 +c +c argonne national laboratory. minpack project. march 1980. +c burton s. garbow, kenneth e. hillstrom, jorge j. more +c +c ********** + integer i,ivar,j,k,k1,k2,ml,mu + double precision c1,c3,c4,c5,c6,c9,eight,fiftn,five,four,h, + * hundrd,one,prod,six,sum,sum1,sum2,temp,temp1, + * temp2,temp3,temp4,ten,three,ti,tj,tk,tpi, + * twenty,two,zero + double precision dfloat + data zero,one,two,three,four,five,six,eight,ten,fiftn,twenty, + * hundrd + * /0.0d0,1.0d0,2.0d0,3.0d0,4.0d0,5.0d0,6.0d0,8.0d0,1.0d1, + * 1.5d1,2.0d1,1.0d2/ + data c1,c3,c4,c5,c6,c9 /1.0d4,2.0d2,2.02d1,1.98d1,1.8d2,2.9d1/ + dfloat(ivar) = ivar +c +c jacobian routine selector. +c + go to (10,20,50,60,90,100,200,230,290,320,350,380,420,450), + * nprob +c +c rosenbrock function. +c + 10 continue + fjac(1,1) = -one + fjac(1,2) = zero + fjac(2,1) = -twenty*x(1) + fjac(2,2) = ten + go to 490 +c +c powell singular function. +c + 20 continue + do 40 k = 1, 4 + do 30 j = 1, 4 + fjac(k,j) = zero + 30 continue + 40 continue + fjac(1,1) = one + fjac(1,2) = ten + fjac(2,3) = dsqrt(five) + fjac(2,4) = -fjac(2,3) + fjac(3,2) = two*(x(2) - two*x(3)) + fjac(3,3) = -two*fjac(3,2) + fjac(4,1) = two*dsqrt(ten)*(x(1) - x(4)) + fjac(4,4) = -fjac(4,1) + go to 490 +c +c powell badly scaled function. +c + 50 continue + fjac(1,1) = c1*x(2) + fjac(1,2) = c1*x(1) + fjac(2,1) = -dexp(-x(1)) + fjac(2,2) = -dexp(-x(2)) + go to 490 +c +c wood function. +c + 60 continue + do 80 k = 1, 4 + do 70 j = 1, 4 + fjac(k,j) = zero + 70 continue + 80 continue + temp1 = x(2) - three*x(1)**2 + temp2 = x(4) - three*x(3)**2 + fjac(1,1) = -c3*temp1 + one + fjac(1,2) = -c3*x(1) + fjac(2,1) = -two*c3*x(1) + fjac(2,2) = c3 + c4 + fjac(2,4) = c5 + fjac(3,3) = -c6*temp2 + one + fjac(3,4) = -c6*x(3) + fjac(4,2) = c5 + fjac(4,3) = -two*c6*x(3) + fjac(4,4) = c6 + c4 + go to 490 +c +c helical valley function. +c + 90 continue + tpi = eight*datan(one) + temp = x(1)**2 + x(2)**2 + temp1 = tpi*temp + temp2 = dsqrt(temp) + fjac(1,1) = hundrd*x(2)/temp1 + fjac(1,2) = -hundrd*x(1)/temp1 + fjac(1,3) = ten + fjac(2,1) = ten*x(1)/temp2 + fjac(2,2) = ten*x(2)/temp2 + fjac(2,3) = zero + fjac(3,1) = zero + fjac(3,2) = zero + fjac(3,3) = one + go to 490 +c +c watson function. +c + 100 continue + do 120 k = 1, n + do 110 j = k, n + fjac(k,j) = zero + 110 continue + 120 continue + do 170 i = 1, 29 + ti = dfloat(i)/c9 + sum1 = zero + temp = one + do 130 j = 2, n + sum1 = sum1 + dfloat(j-1)*temp*x(j) + temp = ti*temp + 130 continue + sum2 = zero + temp = one + do 140 j = 1, n + sum2 = sum2 + temp*x(j) + temp = ti*temp + 140 continue + temp1 = two*(sum1 - sum2**2 - one) + temp2 = two*sum2 + temp = ti**2 + tk = one + do 160 k = 1, n + tj = tk + do 150 j = k, n + fjac(k,j) = fjac(k,j) + * + tj + * *((dfloat(k-1)/ti - temp2) + * *(dfloat(j-1)/ti - temp2) - temp1) + tj = ti*tj + 150 continue + tk = temp*tk + 160 continue + 170 continue + fjac(1,1) = fjac(1,1) + six*x(1)**2 - two*x(2) + three + fjac(1,2) = fjac(1,2) - two*x(1) + fjac(2,2) = fjac(2,2) + one + do 190 k = 1, n + do 180 j = k, n + fjac(j,k) = fjac(k,j) + 180 continue + 190 continue + go to 490 +c +c chebyquad function. +c + 200 continue + tk = one/dfloat(n) + do 220 j = 1, n + temp1 = one + temp2 = two*x(j) - one + temp = two*temp2 + temp3 = zero + temp4 = two + do 210 k = 1, n + fjac(k,j) = tk*temp4 + ti = four*temp2 + temp*temp4 - temp3 + temp3 = temp4 + temp4 = ti + ti = temp*temp2 - temp1 + temp1 = temp2 + temp2 = ti + 210 continue + 220 continue + go to 490 +c +c brown almost-linear function. +c + 230 continue + prod = one + do 250 j = 1, n + prod = x(j)*prod + do 240 k = 1, n + fjac(k,j) = one + 240 continue + fjac(j,j) = two + 250 continue + do 280 j = 1, n + temp = x(j) + if (temp .ne. zero) go to 270 + temp = one + prod = one + do 260 k = 1, n + if (k .ne. j) prod = x(k)*prod + 260 continue + 270 continue + fjac(n,j) = prod/temp + 280 continue + go to 490 +c +c discrete boundary value function. +c + 290 continue + h = one/dfloat(n+1) + do 310 k = 1, n + temp = three*(x(k) + dfloat(k)*h + one)**2 + do 300 j = 1, n + fjac(k,j) = zero + 300 continue + fjac(k,k) = two + temp*h**2/two + if (k .ne. 1) fjac(k,k-1) = -one + if (k .ne. n) fjac(k,k+1) = -one + 310 continue + go to 490 +c +c discrete integral equation function. +c + 320 continue + h = one/dfloat(n+1) + do 340 k = 1, n + tk = dfloat(k)*h + do 330 j = 1, n + tj = dfloat(j)*h + temp = three*(x(j) + tj + one)**2 + fjac(k,j) = h*dmin1(tj*(one-tk),tk*(one-tj))*temp/two + 330 continue + fjac(k,k) = fjac(k,k) + one + 340 continue + go to 490 +c +c trigonometric function. +c + 350 continue + do 370 j = 1, n + temp = dsin(x(j)) + do 360 k = 1, n + fjac(k,j) = temp + 360 continue + fjac(j,j) = dfloat(j+1)*temp - dcos(x(j)) + 370 continue + go to 490 +c +c variably dimensioned function. +c + 380 continue + sum = zero + do 390 j = 1, n + sum = sum + dfloat(j)*(x(j) - one) + 390 continue + temp = one + six*sum**2 + do 410 k = 1, n + do 400 j = k, n + fjac(k,j) = dfloat(k*j)*temp + fjac(j,k) = fjac(k,j) + 400 continue + fjac(k,k) = fjac(k,k) + one + 410 continue + go to 490 +c +c broyden tridiagonal function. +c + 420 continue + do 440 k = 1, n + do 430 j = 1, n + fjac(k,j) = zero + 430 continue + fjac(k,k) = three - four*x(k) + if (k .ne. 1) fjac(k,k-1) = -one + if (k .ne. n) fjac(k,k+1) = -two + 440 continue + go to 490 +c +c broyden banded function. +c + 450 continue + ml = 5 + mu = 1 + do 480 k = 1, n + do 460 j = 1, n + fjac(k,j) = zero + 460 continue + k1 = max0(1,k-ml) + k2 = min0(k+mu,n) + do 470 j = k1, k2 + if (j .ne. k) fjac(k,j) = -(one + two*x(j)) + 470 continue + fjac(k,k) = two + fiftn*x(k)**2 + 480 continue + 490 continue + return +c +c last card of subroutine vecjac. +c + end From 1db227672d7adeaf32a87ab299192c8c02b165a4 Mon Sep 17 00:00:00 2001 From: Ondrej Certik Date: Fri, 24 Feb 2012 18:36:07 -0800 Subject: [PATCH 02/30] Move library sources into src/ --- covar.f => src/covar.f | 0 dmchar.f => src/dmchar.f | 0 dogleg.f => src/dogleg.f | 0 dpmpar.f => src/dpmpar.f | 0 enorm.f => src/enorm.f | 0 errjac.f => src/errjac.f | 0 fdjac1.f => src/fdjac1.f | 0 fdjac2.f => src/fdjac2.f | 0 grdfcn.f => src/grdfcn.f | 0 hesfcn.f => src/hesfcn.f | 0 hybipt.f => src/hybipt.f | 0 hybrd.f => src/hybrd.f | 0 hybrd1.f => src/hybrd1.f | 0 hybrj.f => src/hybrj.f | 0 hybrj1.f => src/hybrj1.f | 0 lhesfcn.f => src/lhesfcn.f | 0 lmder.f => src/lmder.f | 0 lmder1.f => src/lmder1.f | 0 lmdif.f => src/lmdif.f | 0 lmdif1.f => src/lmdif1.f | 0 lmdipt.f => src/lmdipt.f | 0 lmpar.f => src/lmpar.f | 0 lmstr.f => src/lmstr.f | 0 lmstr1.f => src/lmstr1.f | 0 objfcn.f => src/objfcn.f | 0 ocpipt.f => src/ocpipt.f | 0 qform.f => src/qform.f | 0 qrfac.f => src/qrfac.f | 0 qrsolv.f => src/qrsolv.f | 0 r1mpyq.f => src/r1mpyq.f | 0 r1updt.f => src/r1updt.f | 0 rwupdt.f => src/rwupdt.f | 0 ssqfcn.f => src/ssqfcn.f | 0 ssqjac.f => src/ssqjac.f | 0 vecfcn.f => src/vecfcn.f | 0 vecjac.f => src/vecjac.f | 0 36 files changed, 0 insertions(+), 0 deletions(-) rename covar.f => src/covar.f (100%) rename dmchar.f => src/dmchar.f (100%) rename dogleg.f => src/dogleg.f (100%) rename dpmpar.f => src/dpmpar.f (100%) rename enorm.f => src/enorm.f (100%) rename errjac.f => src/errjac.f (100%) rename fdjac1.f => src/fdjac1.f (100%) rename fdjac2.f => src/fdjac2.f (100%) rename grdfcn.f => src/grdfcn.f (100%) rename hesfcn.f => src/hesfcn.f (100%) rename hybipt.f => src/hybipt.f (100%) rename hybrd.f => src/hybrd.f (100%) rename hybrd1.f => src/hybrd1.f (100%) rename hybrj.f => src/hybrj.f (100%) rename hybrj1.f => src/hybrj1.f (100%) rename lhesfcn.f => src/lhesfcn.f (100%) rename lmder.f => src/lmder.f (100%) rename lmder1.f => src/lmder1.f (100%) rename lmdif.f => src/lmdif.f (100%) rename lmdif1.f => src/lmdif1.f (100%) rename lmdipt.f => src/lmdipt.f (100%) rename lmpar.f => src/lmpar.f (100%) rename lmstr.f => src/lmstr.f (100%) rename lmstr1.f => src/lmstr1.f (100%) rename objfcn.f => src/objfcn.f (100%) rename ocpipt.f => src/ocpipt.f (100%) rename qform.f => src/qform.f (100%) rename qrfac.f => src/qrfac.f (100%) rename qrsolv.f => src/qrsolv.f (100%) rename r1mpyq.f => src/r1mpyq.f (100%) rename r1updt.f => src/r1updt.f (100%) rename rwupdt.f => src/rwupdt.f (100%) rename ssqfcn.f => src/ssqfcn.f (100%) rename ssqjac.f => src/ssqjac.f (100%) rename vecfcn.f => src/vecfcn.f (100%) rename vecjac.f => src/vecjac.f (100%) diff --git a/covar.f b/src/covar.f similarity index 100% rename from covar.f rename to src/covar.f diff --git a/dmchar.f b/src/dmchar.f similarity index 100% rename from dmchar.f rename to src/dmchar.f diff --git a/dogleg.f b/src/dogleg.f similarity index 100% rename from dogleg.f rename to src/dogleg.f diff --git a/dpmpar.f b/src/dpmpar.f similarity index 100% rename from dpmpar.f rename to src/dpmpar.f diff --git a/enorm.f b/src/enorm.f similarity index 100% rename from enorm.f rename to src/enorm.f diff --git a/errjac.f b/src/errjac.f similarity index 100% rename from errjac.f rename to src/errjac.f diff --git a/fdjac1.f b/src/fdjac1.f similarity index 100% rename from fdjac1.f rename to src/fdjac1.f diff --git a/fdjac2.f b/src/fdjac2.f similarity index 100% rename from fdjac2.f rename to src/fdjac2.f diff --git a/grdfcn.f b/src/grdfcn.f similarity index 100% rename from grdfcn.f rename to src/grdfcn.f diff --git a/hesfcn.f b/src/hesfcn.f similarity index 100% rename from hesfcn.f rename to src/hesfcn.f diff --git a/hybipt.f b/src/hybipt.f similarity index 100% rename from hybipt.f rename to src/hybipt.f diff --git a/hybrd.f b/src/hybrd.f similarity index 100% rename from hybrd.f rename to src/hybrd.f diff --git a/hybrd1.f b/src/hybrd1.f similarity index 100% rename from hybrd1.f rename to src/hybrd1.f diff --git a/hybrj.f b/src/hybrj.f similarity index 100% rename from hybrj.f rename to src/hybrj.f diff --git a/hybrj1.f b/src/hybrj1.f similarity index 100% rename from hybrj1.f rename to src/hybrj1.f diff --git a/lhesfcn.f b/src/lhesfcn.f similarity index 100% rename from lhesfcn.f rename to src/lhesfcn.f diff --git a/lmder.f b/src/lmder.f similarity index 100% rename from lmder.f rename to src/lmder.f diff --git a/lmder1.f b/src/lmder1.f similarity index 100% rename from lmder1.f rename to src/lmder1.f diff --git a/lmdif.f b/src/lmdif.f similarity index 100% rename from lmdif.f rename to src/lmdif.f diff --git a/lmdif1.f b/src/lmdif1.f similarity index 100% rename from lmdif1.f rename to src/lmdif1.f diff --git a/lmdipt.f b/src/lmdipt.f similarity index 100% rename from lmdipt.f rename to src/lmdipt.f diff --git a/lmpar.f b/src/lmpar.f similarity index 100% rename from lmpar.f rename to src/lmpar.f diff --git a/lmstr.f b/src/lmstr.f similarity index 100% rename from lmstr.f rename to src/lmstr.f diff --git a/lmstr1.f b/src/lmstr1.f similarity index 100% rename from lmstr1.f rename to src/lmstr1.f diff --git a/objfcn.f b/src/objfcn.f similarity index 100% rename from objfcn.f rename to src/objfcn.f diff --git a/ocpipt.f b/src/ocpipt.f similarity index 100% rename from ocpipt.f rename to src/ocpipt.f diff --git a/qform.f b/src/qform.f similarity index 100% rename from qform.f rename to src/qform.f diff --git a/qrfac.f b/src/qrfac.f similarity index 100% rename from qrfac.f rename to src/qrfac.f diff --git a/qrsolv.f b/src/qrsolv.f similarity index 100% rename from qrsolv.f rename to src/qrsolv.f diff --git a/r1mpyq.f b/src/r1mpyq.f similarity index 100% rename from r1mpyq.f rename to src/r1mpyq.f diff --git a/r1updt.f b/src/r1updt.f similarity index 100% rename from r1updt.f rename to src/r1updt.f diff --git a/rwupdt.f b/src/rwupdt.f similarity index 100% rename from rwupdt.f rename to src/rwupdt.f diff --git a/ssqfcn.f b/src/ssqfcn.f similarity index 100% rename from ssqfcn.f rename to src/ssqfcn.f diff --git a/ssqjac.f b/src/ssqjac.f similarity index 100% rename from ssqjac.f rename to src/ssqjac.f diff --git a/vecfcn.f b/src/vecfcn.f similarity index 100% rename from vecfcn.f rename to src/vecfcn.f diff --git a/vecjac.f b/src/vecjac.f similarity index 100% rename from vecjac.f rename to src/vecjac.f From f9e807abc2071e47ccc98191e159d7f8b3114d91 Mon Sep 17 00:00:00 2001 From: Ondrej Certik Date: Fri, 24 Feb 2012 18:37:40 -0800 Subject: [PATCH 03/30] Move *drv.f into ex/ --- chkdrv.f => ex/chkdrv.f | 0 hybdrv.f => ex/hybdrv.f | 0 hyjdrv.f => ex/hyjdrv.f | 0 lmddrv.f => ex/lmddrv.f | 0 lmfdrv.f => ex/lmfdrv.f | 0 lmsdrv.f => ex/lmsdrv.f | 0 ucodrv.f => ex/ucodrv.f | 0 7 files changed, 0 insertions(+), 0 deletions(-) rename chkdrv.f => ex/chkdrv.f (100%) rename hybdrv.f => ex/hybdrv.f (100%) rename hyjdrv.f => ex/hyjdrv.f (100%) rename lmddrv.f => ex/lmddrv.f (100%) rename lmfdrv.f => ex/lmfdrv.f (100%) rename lmsdrv.f => ex/lmsdrv.f (100%) rename ucodrv.f => ex/ucodrv.f (100%) diff --git a/chkdrv.f b/ex/chkdrv.f similarity index 100% rename from chkdrv.f rename to ex/chkdrv.f diff --git a/hybdrv.f b/ex/hybdrv.f similarity index 100% rename from hybdrv.f rename to ex/hybdrv.f diff --git a/hyjdrv.f b/ex/hyjdrv.f similarity index 100% rename from hyjdrv.f rename to ex/hyjdrv.f diff --git a/lmddrv.f b/ex/lmddrv.f similarity index 100% rename from lmddrv.f rename to ex/lmddrv.f diff --git a/lmfdrv.f b/ex/lmfdrv.f similarity index 100% rename from lmfdrv.f rename to ex/lmfdrv.f diff --git a/lmsdrv.f b/ex/lmsdrv.f similarity index 100% rename from lmsdrv.f rename to ex/lmsdrv.f diff --git a/ucodrv.f b/ex/ucodrv.f similarity index 100% rename from ucodrv.f rename to ex/ucodrv.f From af26405f04d1272bafd28be0872cf30c1031973f Mon Sep 17 00:00:00 2001 From: Ondrej Certik Date: Fri, 24 Feb 2012 18:38:44 -0800 Subject: [PATCH 04/30] Remove old makefile --- makefile | 51 --------------------------------------------------- 1 file changed, 51 deletions(-) delete mode 100644 makefile diff --git a/makefile b/makefile deleted file mode 100644 index 063cf7c..0000000 --- a/makefile +++ /dev/null @@ -1,51 +0,0 @@ -LIB=minpack -FFLAGS=-O -OBJ = \ - covar.o \ - dmchar.o \ - dogleg.o \ - dpmpar.o \ - enorm.o \ - errjac.o \ - fdjac1.o \ - fdjac2.o \ - grdfcn.o \ - hesfcn.o \ - hybipt.o \ - hybrd.o \ - hybrd1.o \ - hybrj.o \ - hybrj1.o \ - lhesfcn.o \ - lmder.o \ - lmder1.o \ - lmdif.o \ - lmdif1.o \ - lmdipt.o \ - lmpar.o \ - lmstr.o \ - lmstr1.o \ - objfcn.o \ - ocpipt.o \ - qform.o \ - qrfac.o \ - qrsolv.o \ - r1mpyq.o \ - r1updt.o \ - rwupdt.o \ - ssqfcn.o \ - ssqjac.o \ - vecfcn.o \ - vecjac.o - -lib$(LIB).a: $(OBJ) - ar ru lib$(LIB).a $? - ranlib lib$(LIB).a - -install: lib$(LIB).a - ln -s /netlib/netlib/minpack/lib$(LIB).a /usr/local/lib - rm *.o - -test: test.o - f77 test.o -l$(LIB) - time a.out From ea58496837f42f8b2ae1e456e339a109fb36b1c1 Mon Sep 17 00:00:00 2001 From: Ondrej Certik Date: Fri, 24 Feb 2012 18:44:55 -0800 Subject: [PATCH 05/30] Remove the depend file --- depend | 226 --------------------------------------------------------- 1 file changed, 226 deletions(-) delete mode 100644 depend diff --git a/depend b/depend deleted file mode 100644 index 722be8e..0000000 --- a/depend +++ /dev/null @@ -1,226 +0,0 @@ -F chkder.f -D chkder_ -R dpmpar_ - -F chkdrv.f -D MAIN__ -R chkder_ -R errjac_ -R initpt_ -R vecfcn_ - -F covar.f -D covar_ - -F dmchar.f -D dmchar_ - -F dogleg.f -D dogleg_ -R dpmpar_ -R enorm_ - -F dpmpar.f -D dpmpar_ - -F enorm.f -D enorm_ - -F errjac.f -D errjac_ - -F fdjac1.f -D fdjac1_ -R dpmpar_ - -F fdjac2.f -D fdjac2_ -R dpmpar_ - -F grdfcn.f -D grdfcn_ - -F hesfcn.f -D hesfcn_ - -F hybdrv.f -D MAIN__ -D fcn_ -R dpmpar_ -R enorm_ -R hybrd1_ -R initpt_ -R vecfcn_ - -F hybipt.f -D initpt_ - -F hybrd.f -D hybrd_ -R dogleg_ -R dpmpar_ -R enorm_ -R fdjac1_ -R qform_ -R qrfac_ -R r1mpyq_ -R r1updt_ - -F hybrd1.f -D hybrd1_ -R hybrd_ - -F hybrj.f -D hybrj_ -R dogleg_ -R dpmpar_ -R enorm_ -R qform_ -R qrfac_ -R r1mpyq_ -R r1updt_ - -F hybrj1.f -D hybrj1_ -R hybrj_ - -F hyjdrv.f -D MAIN__ -D fcn_ -R dpmpar_ -R enorm_ -R hybrj1_ -R initpt_ -R vecfcn_ -R vecjac_ - -F ibmdpdr.f -D MAIN__ -R dmchar_ -R dpmpar_ - -F lhesfcn.f -D hesfcn_ - -F lmddrv.f -D MAIN__ -D fcn_ -R dpmpar_ -R enorm_ -R initpt_ -R lmder1_ -R ssqfcn_ -R ssqjac_ - -F lmder.f -D lmder_ -R dpmpar_ -R enorm_ -R lmpar_ -R qrfac_ - -F lmder1.f -D lmder1_ -R lmder_ - -F lmdif.f -D lmdif_ -R dpmpar_ -R enorm_ -R fdjac2_ -R lmpar_ -R qrfac_ - -F lmdif1.f -D lmdif1_ -R lmdif_ - -F lmdipt.f -D initpt_ - -F lmfdrv.f -D MAIN__ -D fcn_ -R dpmpar_ -R enorm_ -R initpt_ -R lmdif1_ -R ssqfcn_ - -F lmpar.f -D lmpar_ -R dpmpar_ -R enorm_ -R qrsolv_ - -F lmsdrv.f -D MAIN__ -D fcn_ -R dpmpar_ -R enorm_ -R initpt_ -R lmstr1_ -R ssqfcn_ -R ssqjac_ - -F lmstr.f -D lmstr_ -R dpmpar_ -R enorm_ -R lmpar_ -R qrfac_ -R rwupdt_ - -F lmstr1.f -D lmstr1_ -R lmstr_ - -F objfcn.f -D objfcn_ - -F ocpipt.f -D initpt_ - -F qform.f -D qform_ - -F qrfac.f -D qrfac_ -R dpmpar_ -R enorm_ - -F qrsolv.f -D qrsolv_ - -F r1mpyq.f -D r1mpyq_ - -F r1updt.f -D r1updt_ -R dpmpar_ - -F rwupdt.f -D rwupdt_ - -F ssqfcn.f -D ssqfcn_ - -F ssqjac.f -D ssqjac_ - -F ucodrv.f -D MAIN__ -D fcn_ -R dpmpar_ -R drvcr1_ -R enorm_ -R grdfcn_ -R initpt_ -R objfcn_ - -F vecfcn.f -D vecfcn_ - -F vecjac.f -D vecjac_ - From 58a3094ef86e36dd560d4a73589a9bb56659d6e0 Mon Sep 17 00:00:00 2001 From: Ondrej Certik Date: Fri, 24 Feb 2012 18:40:20 -0800 Subject: [PATCH 06/30] Add MIT license --- LICENSE | 22 ++++++++++++++++++++++ 1 file changed, 22 insertions(+) diff --git a/LICENSE b/LICENSE index 132cc3f..60e9b11 100644 --- a/LICENSE +++ b/LICENSE @@ -1,3 +1,25 @@ +Copyright (c) 2012 Ondřej Čertík + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in +all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN +THE SOFTWARE. + +----------------------------------------------------------------------------- + Minpack Copyright Notice (1999) University of Chicago. All rights reserved Redistribution and use in source and binary forms, with or From 730325cc31152c503ae75cb7b90e919336ed05b7 Mon Sep 17 00:00:00 2001 From: Ondrej Certik Date: Fri, 24 Feb 2012 18:44:36 -0800 Subject: [PATCH 07/30] Update the README --- README.rst | 52 ++++++++++++++++++++++++++++++++++++++++++++++++++++ readme | 18 ------------------ 2 files changed, 52 insertions(+), 18 deletions(-) create mode 100644 README.rst delete mode 100644 readme diff --git a/README.rst b/README.rst new file mode 100644 index 0000000..0cc3683 --- /dev/null +++ b/README.rst @@ -0,0 +1,52 @@ +Minpack +======= + +Information +----------- + +This repository contains the original double precision Minpack from netlib.org, +together with CMake makefiles and examples. + +About Minpack +------------- + +Minpack includes software for solving nonlinear equations and +nonlinear least squares problems. Five algorithmic paths each include +a core subroutine and an easy-to-use driver. The algorithms proceed +either from an analytic specification of the Jacobian matrix or +directly from the problem functions. The paths include facilities for +systems of equations with a banded Jacobian matrix, for least squares +problems with a large amount of data, and for checking the consistency +of the Jacobian matrix with the functions. + +Jorge More', Burt Garbow, and Ken Hillstrom at Argonne National Laboratory. + +Documentation +------------- + +Minpack contains 4 subroutines for solution of systems of nonlinear equations: + +* ``hybrd``, ``hybrd1``: Jacobian matrix is calculated by a forward difference + approximation +* ``hybrj``, ``hybrj1``: Jacobian matrix is provided by the user + +and 6 subroutines for nonlinear least squares problems: + +* ``lmdif``, ``lmdif1``: Jacobian matrix is calculated by a forward difference + approximation +* ``lmder``, ``lmder1``: Jacobian matrix is provided by the user +* ``lmstr``, ``lmstr1``: Jacobian matrix is provided by the user, one row per + call (uses less memory) + +The routines without ``1`` in the name expose all parameters to the user (`core +subroutines`), routines with ``1`` only expose the essential parameters and set +default values for the rest (`easy-to-use driver`). Finally: + +* ``chkder``: checks the consistency of the Jacobian matrix with the functions + +Detailed documentation for all these routines together with an example is given +in the file ``ex/file06`` (for double precision). Ready to use examples of +usage are in the ``examples`` directory. + +Other files in the ``ex`` directory are original examples of usage of various +routines (single and double precision), but are not compiled by default. diff --git a/readme b/readme deleted file mode 100644 index 5476691..0000000 --- a/readme +++ /dev/null @@ -1,18 +0,0 @@ -====== readme for minpack ====== - -Minpack includes software for solving nonlinear equations and -nonlinear least squares problems. Five algorithmic paths each include -a core subroutine and an easy-to-use driver. The algorithms proceed -either from an analytic specification of the Jacobian matrix or -directly from the problem functions. The paths include facilities for -systems of equations with a banded Jacobian matrix, for least squares -problems with a large amount of data, and for checking the consistency -of the Jacobian matrix with the functions. - -This directory contains the double-precision versions. - -Jorge More', Burt Garbow, and Ken Hillstrom at Argonne National Laboratory. - -For copyright information see; - -http://www.netlib.org/minpack/disclaimer From 01e2eb10a9a2ca7d56bfe83d04140078d1271fda Mon Sep 17 00:00:00 2001 From: Ondrej Certik Date: Fri, 24 Feb 2012 20:38:00 -0800 Subject: [PATCH 08/30] Add CMake files --- CMakeLists.txt | 42 ++++++++++++++++++++++++++++++++++++++++ cmake/UserOverride.cmake | 18 +++++++++++++++++ src/CMakeLists.txt | 16 +++++++++++++++ 3 files changed, 76 insertions(+) create mode 100644 CMakeLists.txt create mode 100644 cmake/UserOverride.cmake create mode 100644 src/CMakeLists.txt diff --git a/CMakeLists.txt b/CMakeLists.txt new file mode 100644 index 0000000..9ebe2ef --- /dev/null +++ b/CMakeLists.txt @@ -0,0 +1,42 @@ +cmake_minimum_required(VERSION 2.6 FATAL_ERROR) + +set(CMAKE_USER_MAKE_RULES_OVERRIDE ${CMAKE_SOURCE_DIR}/cmake/UserOverride.cmake) + +project(minpack) +enable_language(Fortran) + +set(CMAKE_MODULE_PATH ${PROJECT_SOURCE_DIR}/cmake) + +# Make sure that CMAKE_BUILD_TYPE is either Debug or Release: +if (NOT CMAKE_BUILD_TYPE) + set(CMAKE_BUILD_TYPE Debug + CACHE STRING "Build type (Debug, Release)" FORCE) +endif () +if (NOT (CMAKE_BUILD_TYPE STREQUAL "Debug" OR + CMAKE_BUILD_TYPE STREQUAL "Release")) + message("${CMAKE_BUILD_TYPE}") + message(FATAL_ERROR "CMAKE_BUILD_TYPE must be one of: Debug, Release (current value: '${CMAKE_BUILD_TYPE}')") +endif () + +if (CMAKE_Fortran_COMPILER_ID STREQUAL "GNU") + # gfortran + # Enable this if you want to check for single/double corruption (and use + # the Debug build): + #set(CMAKE_Fortran_FLAGS_DEBUG "${CMAKE_Fortran_FLAGS_DEBUG} -fdefault-real-8") +endif () + + +#add_subdirectory(examples) +add_subdirectory(src) + +message("\n") +message("Configuration results") +message("---------------------") +message("Fortran compiler: ${CMAKE_Fortran_COMPILER}") +message("Build type: ${CMAKE_BUILD_TYPE}") +if (CMAKE_BUILD_TYPE STREQUAL "Debug") + message("Fortran compiler flags: ${CMAKE_Fortran_FLAGS_DEBUG}") +else () + message("Fortran compiler flags: ${CMAKE_Fortran_FLAGS_RELEASE}") +endif () +message("Installation prefix: ${CMAKE_INSTALL_PREFIX}") diff --git a/cmake/UserOverride.cmake b/cmake/UserOverride.cmake new file mode 100644 index 0000000..dc3acb8 --- /dev/null +++ b/cmake/UserOverride.cmake @@ -0,0 +1,18 @@ +# This overrides the default CMake Debug and Release compiler options. +# The user can still specify different options by setting the +# CMAKE_Fortran_FLAGS_[RELEASE,DEBUG] variables (on the command line or in the +# CMakeList.txt). This files serves as better CMake defaults and should only be +# modified if the default values are to be changed. Project specific compiler +# flags should be set in the CMakeList.txt by setting the CMAKE_Fortran_FLAGS_* +# variables. +if (CMAKE_Fortran_COMPILER_ID STREQUAL "GNU") + # gfortran + set(common "-std=f2003 -Wall -Wextra -Wimplicit-interface -Werror -fPIC -fmax-errors=1") + set(CMAKE_Fortran_FLAGS_RELEASE_INIT "${common} -O3 -march=native -ffast-math -funroll-loops") + set(CMAKE_Fortran_FLAGS_DEBUG_INIT "${common} -g -fbounds-check -fcheck-array-temporaries -fbacktrace") +elseif (CMAKE_Fortran_COMPILER_ID STREQUAL "Intel") + # ifort + set(common "-std2003 -warn all") + set(CMAKE_Fortran_FLAGS_RELEASE_INIT "${common} -xHOST -O3 -no-prec-div -static") + set(CMAKE_Fortran_FLAGS_DEBUG_INIT "${common} -check all") +endif () diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt new file mode 100644 index 0000000..3e3757d --- /dev/null +++ b/src/CMakeLists.txt @@ -0,0 +1,16 @@ +set(SRC + covar.f errjac.f hybipt.f lhesfcn.f lmdipt.f ocpipt.f r1updt.f + vecjac.f + dmchar.f fdjac1.f hybrd1.f lmder1.f lmpar.f qform.f rwupdt.f + dogleg.f fdjac2.f hybrd.f lmder.f lmstr1.f qrfac.f ssqfcn.f + dpmpar.f grdfcn.f hybrj1.f lmdif1.f lmstr.f qrsolv.f ssqjac.f + enorm.f hesfcn.f hybrj.f lmdif.f objfcn.f r1mpyq.f vecfcn.f +) + +add_definitions(-std=legacy -Wno-implicit-interface) +add_library(minpack ${SRC}) +install(TARGETS minpack + RUNTIME DESTINATION bin + ARCHIVE DESTINATION lib + LIBRARY DESTINATION lib + ) From ee9134ba2182f378546d92643bb7bf67d6583552 Mon Sep 17 00:00:00 2001 From: Ondrej Certik Date: Fri, 24 Feb 2012 20:30:14 -0800 Subject: [PATCH 09/30] Add f90 interface to minpack --- src/CMakeLists.txt | 2 ++ src/minpack.f90 | 49 ++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 51 insertions(+) create mode 100644 src/minpack.f90 diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt index 3e3757d..7c731e5 100644 --- a/src/CMakeLists.txt +++ b/src/CMakeLists.txt @@ -5,6 +5,8 @@ set(SRC dogleg.f fdjac2.f hybrd.f lmder.f lmstr1.f qrfac.f ssqfcn.f dpmpar.f grdfcn.f hybrj1.f lmdif1.f lmstr.f qrsolv.f ssqjac.f enorm.f hesfcn.f hybrj.f lmdif.f objfcn.f r1mpyq.f vecfcn.f + + minpack.f90 ) add_definitions(-std=legacy -Wno-implicit-interface) diff --git a/src/minpack.f90 b/src/minpack.f90 new file mode 100644 index 0000000..b0be41e --- /dev/null +++ b/src/minpack.f90 @@ -0,0 +1,49 @@ +module minpack +implicit none + +interface + + double precision function dpmpar(i) + integer i + end function + + double precision function enorm(n,x) + integer n + double precision x(n) + end function + + subroutine lmder1(fcn,m,n,x,fvec,fjac,ldfjac,tol,info,ipvt,wa,lwa) + integer m,n,ldfjac,info,lwa + integer ipvt(n) + double precision tol + double precision x(n),fvec(m),fjac(ldfjac,n),wa(lwa) + interface + subroutine fcn(m,n,x,fvec,fjac,ldfjac,iflag) + implicit none + integer, intent(in) :: m,n,ldfjac,iflag + double precision, intent(in) :: x(n) + double precision, intent(out) :: fvec(m),fjac(ldfjac,n) + end subroutine + end interface + end subroutine + + subroutine lmdif1(fcn,m,n,x,fvec,tol,info,iwa,wa,lwa) + integer m,n,info,lwa + integer iwa(n) + double precision tol + double precision x(n),fvec(m),wa(lwa) + interface + subroutine fcn(m,n,x,fvec,iflag) + implicit none + integer, intent(in) :: m,n,iflag + double precision, intent(in) :: x(n) + double precision, intent(out) :: fvec(m) + end subroutine + end interface + end subroutine + +end interface + +contains + +end module From 63350e8f7b28d07697c15880600016efbc7d681a Mon Sep 17 00:00:00 2001 From: Ondrej Certik Date: Fri, 24 Feb 2012 20:38:42 -0800 Subject: [PATCH 10/30] Add f90 example for lmder1() --- CMakeLists.txt | 2 +- examples/CMakeLists.txt | 4 +++ examples/example_lmder1.f90 | 70 +++++++++++++++++++++++++++++++++++++ 3 files changed, 75 insertions(+), 1 deletion(-) create mode 100644 examples/CMakeLists.txt create mode 100644 examples/example_lmder1.f90 diff --git a/CMakeLists.txt b/CMakeLists.txt index 9ebe2ef..890c799 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -26,7 +26,7 @@ if (CMAKE_Fortran_COMPILER_ID STREQUAL "GNU") endif () -#add_subdirectory(examples) +add_subdirectory(examples) add_subdirectory(src) message("\n") diff --git a/examples/CMakeLists.txt b/examples/CMakeLists.txt new file mode 100644 index 0000000..1afd09e --- /dev/null +++ b/examples/CMakeLists.txt @@ -0,0 +1,4 @@ +include_directories(${PROJECT_BINARY_DIR}/src) + +add_executable(example_lmder1 example_lmder1.f90) +target_link_libraries(example_lmder1 minpack) diff --git a/examples/example_lmder1.f90 b/examples/example_lmder1.f90 new file mode 100644 index 0000000..002ac74 --- /dev/null +++ b/examples/example_lmder1.f90 @@ -0,0 +1,70 @@ +module testmod +implicit none +private +public fcn, dp + +integer, parameter :: dp=kind(0d0) + +contains + +subroutine fcn(m, n, x, fvec, fjac, ldfjac, iflag) +integer, intent(in) :: m, n, ldfjac, iflag +real(dp), intent(in) :: x(n) +real(dp), intent(out) :: fvec(m), fjac(ldfjac, n) + +integer :: i +real(dp) :: tmp1, tmp2, tmp3, tmp4, y(15) +y = [1.4D-1, 1.8D-1, 2.2D-1, 2.5D-1, 2.9D-1, 3.2D-1, 3.5D-1, 3.9D-1, & + 3.7D-1, 5.8D-1, 7.3D-1, 9.6D-1, 1.34D0, 2.1D0, 4.39D0] + +if (iflag == 1) then + do i = 1, 15 + tmp1 = i + tmp2 = 16 - i + tmp3 = tmp1 + if (i .gt. 8) tmp3 = tmp2 + fvec(i) = y(i) - (x(1) + tmp1/(x(2)*tmp2 + x(3)*tmp3)) + end do +else + do i = 1, 15 + tmp1 = i + tmp2 = 16 - i + tmp3 = tmp1 + if (i .gt. 8) tmp3 = tmp2 + tmp4 = (x(2)*tmp2 + x(3)*tmp3)**2 + fjac(i,1) = -1.D0 + fjac(i,2) = tmp1*tmp2/tmp4 + fjac(i,3) = tmp1*tmp3/tmp4 + end do +end if +end subroutine + +end module + + +program example_lmder1 +use minpack, only: enorm, dpmpar, lmder1 +use testmod, only: dp, fcn +implicit none + +integer :: info +real(dp) :: tol, x(3), fvec(15), fjac(size(fvec), size(x)) +integer :: ipvt(size(x)) +real(dp), allocatable :: wa(:) + +! The following starting values provide a rough fit. +x = [1._dp, 1._dp, 1._dp] + +! Set tol to the square root of the machine precision. Unless high precision +! solutions are required, this is the recommended setting. +tol = sqrt(dpmpar(1)) + +allocate(wa(5*size(x) + size(fvec))) +call lmder1(fcn, size(fvec), size(x), x, fvec, fjac, size(fjac, 1), tol, & + info, ipvt, wa, size(wa)) +print 1000, enorm(size(fvec), fvec), info, x +1000 format(5x, 'FINAL L2 NORM OF THE RESIDUALS', d15.7 // & + 5x, 'EXIT PARAMETER', 16x, i10 // & + 5x, 'FINAL APPROXIMATE SOLUTION' // & + 5x, 3d15.7) +end program From 69ce22f857f10b555299ac2e88e96d9fcc7b7685 Mon Sep 17 00:00:00 2001 From: Ondrej Certik Date: Fri, 24 Feb 2012 21:39:11 -0800 Subject: [PATCH 11/30] Add example for lmdif1() --- examples/CMakeLists.txt | 3 ++ examples/example_lmdif1.f90 | 60 +++++++++++++++++++++++++++++++++++++ 2 files changed, 63 insertions(+) create mode 100644 examples/example_lmdif1.f90 diff --git a/examples/CMakeLists.txt b/examples/CMakeLists.txt index 1afd09e..4305186 100644 --- a/examples/CMakeLists.txt +++ b/examples/CMakeLists.txt @@ -2,3 +2,6 @@ include_directories(${PROJECT_BINARY_DIR}/src) add_executable(example_lmder1 example_lmder1.f90) target_link_libraries(example_lmder1 minpack) + +add_executable(example_lmdif1 example_lmdif1.f90) +target_link_libraries(example_lmdif1 minpack) diff --git a/examples/example_lmdif1.f90 b/examples/example_lmdif1.f90 new file mode 100644 index 0000000..790b28d --- /dev/null +++ b/examples/example_lmdif1.f90 @@ -0,0 +1,60 @@ +module testmod_dif +implicit none +private +public fcn, dp + +integer, parameter :: dp=kind(0d0) + +contains + +subroutine fcn(m, n, x, fvec, iflag) +integer, intent(in) :: m, n, iflag +real(dp), intent(in) :: x(n) +real(dp), intent(out) :: fvec(m) + +integer :: i +real(dp) :: tmp1, tmp2, tmp3, y(15) +! Suppress compiler warning: +y(1) = iflag +y = [1.4D-1, 1.8D-1, 2.2D-1, 2.5D-1, 2.9D-1, 3.2D-1, 3.5D-1, 3.9D-1, & + 3.7D-1, 5.8D-1, 7.3D-1, 9.6D-1, 1.34D0, 2.1D0, 4.39D0] + +do i = 1, 15 + tmp1 = i + tmp2 = 16 - i + tmp3 = tmp1 + if (i .gt. 8) tmp3 = tmp2 + fvec(i) = y(i) - (x(1) + tmp1/(x(2)*tmp2 + x(3)*tmp3)) +end do +end subroutine + +end module + + +program example_lmdif1 +use minpack, only: enorm, dpmpar, lmdif1 +use testmod_dif, only: dp, fcn +implicit none + +integer :: info, m, n +real(dp) :: tol, x(3), fvec(15) +integer :: iwa(size(x)) +real(dp), allocatable :: wa(:) + +! The following starting values provide a rough fit. +x = [1._dp, 1._dp, 1._dp] + +! Set tol to the square root of the machine precision. Unless high precision +! solutions are required, this is the recommended setting. +tol = sqrt(dpmpar(1)) + +m = size(fvec) +n = size(x) +allocate(wa(m*n + 5*n + m)) +call lmdif1(fcn, size(fvec), size(x), x, fvec, tol, info, iwa, wa, size(wa)) +print 1000, enorm(size(fvec), fvec), info, x +1000 format(5x, 'FINAL L2 NORM OF THE RESIDUALS', d15.7 // & + 5x, 'EXIT PARAMETER', 16x, i10 // & + 5x, 'FINAL APPROXIMATE SOLUTION' // & + 5x, 3d15.7) +end program From e0544f7cfb685e1ba82ee4c96fff77786049628f Mon Sep 17 00:00:00 2001 From: Ondrej Certik Date: Fri, 24 Feb 2012 21:46:15 -0800 Subject: [PATCH 12/30] Remove ibmdpdr.f --- ibmdpdr.f | 72 ------------------------------------------------------- 1 file changed, 72 deletions(-) delete mode 100644 ibmdpdr.f diff --git a/ibmdpdr.f b/ibmdpdr.f deleted file mode 100644 index 0d76f86..0000000 --- a/ibmdpdr.f +++ /dev/null @@ -1,72 +0,0 @@ -c ********** -c -c this program checks the constants of machine precision and -c smallest and largest machine representable numbers specified in -c function dpmpar, against the corresponding hardware-determined -c machine constants obtained by dmchar, a subroutine due to -c w. j. cody. -c -c data statements in dpmpar corresponding to the machine used must -c be activated by removing c in column 1. -c -c the printed output consists of the machine constants obtained by -c dmchar and comparisons of the dpmpar constants with their -c dmchar counterparts. descriptions of the machine constants are -c given in the prologue comments of dmchar. -c -c subprograms called -c -c minpack-supplied ... dmchar,dpmpar -c -c argonne national laboratory. minpack project. march 1980. -c burton s. garbow, kenneth e. hillstrom, jorge j. more -c -c ********** - integer ibeta,iexp,irnd,it,machep,maxexp,minexp,negep,ngrd, - * nwrite - double precision dwarf,eps,epsmch,epsneg,giant,xmax,xmin - double precision rerr(3) - double precision dpmpar -c -c logical output unit is assumed to be number 6. -c - data nwrite /6/ -c -c determine the machine constants dynamically from dmchar. -c - call dmchar(ibeta,it,irnd,ngrd,machep,negep,iexp,minexp,maxexp, - * eps,epsneg,xmin,xmax) -c -c compare the dpmpar constants with their dmchar counterparts and -c store the relative differences in rerr. -c - epsmch = dpmpar(1) - dwarf = dpmpar(2) - giant = dpmpar(3) - rerr(1) = (epsmch - eps)/epsmch - rerr(2) = (dwarf - xmin)/dwarf - rerr(3) = (xmax - giant)/giant -c -c write the dmchar constants. -c - write (nwrite,10) - * ibeta,it,irnd,ngrd,machep,negep,iexp,minexp,maxexp,eps, - * epsneg,xmin,xmax -c -c write the dpmpar constants and the relative differences. -c - write (nwrite,20) epsmch,rerr(1),dwarf,rerr(2),giant,rerr(3) - stop - 10 format (17h1dmchar constants /// 8h ibeta =, i6 // 8h it =, - * i6 // 8h irnd =, i6 // 8h ngrd =, i6 // 9h machep =, - * i6 // 8h negep =, i6 // 7h iexp =, i6 // 9h minexp =, - * i6 // 9h maxexp =, i6 // 6h eps =, d15.7 // 9h epsneg =, - * d15.7 // 7h xmin =, d15.7 // 7h xmax =, d15.7) - 20 format ( /// 42h dpmpar constants and relative differences /// - * 9h epsmch =, d15.7 / 10h rerr(1) =, d15.7 // - * 8h dwarf =, d15.7 / 10h rerr(2) =, d15.7 // 8h giant =, - * d15.7 / 10h rerr(3) =, d15.7) -c -c last card of driver. -c - end From a9492a54454dd5253d1a325c6d7fcd78ae817077 Mon Sep 17 00:00:00 2001 From: Ondrej Certik Date: Fri, 24 Feb 2012 21:47:23 -0800 Subject: [PATCH 13/30] Move chkder.f to src/ and compile it --- src/CMakeLists.txt | 2 +- chkder.f => src/chkder.f | 0 2 files changed, 1 insertion(+), 1 deletion(-) rename chkder.f => src/chkder.f (100%) diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt index 7c731e5..51d1676 100644 --- a/src/CMakeLists.txt +++ b/src/CMakeLists.txt @@ -1,6 +1,6 @@ set(SRC covar.f errjac.f hybipt.f lhesfcn.f lmdipt.f ocpipt.f r1updt.f - vecjac.f + vecjac.f chkder.f dmchar.f fdjac1.f hybrd1.f lmder1.f lmpar.f qform.f rwupdt.f dogleg.f fdjac2.f hybrd.f lmder.f lmstr1.f qrfac.f ssqfcn.f dpmpar.f grdfcn.f hybrj1.f lmdif1.f lmstr.f qrsolv.f ssqjac.f diff --git a/chkder.f b/src/chkder.f similarity index 100% rename from chkder.f rename to src/chkder.f From a0b317439a48c9a69e46c4ef32f2d467df361c06 Mon Sep 17 00:00:00 2001 From: Ondrej Certik Date: Fri, 24 Feb 2012 22:00:20 -0800 Subject: [PATCH 14/30] Export chkder() --- src/minpack.f90 | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/minpack.f90 b/src/minpack.f90 index b0be41e..799011a 100644 --- a/src/minpack.f90 +++ b/src/minpack.f90 @@ -42,6 +42,11 @@ subroutine fcn(m,n,x,fvec,iflag) end interface end subroutine + subroutine chkder(m,n,x,fvec,fjac,ldfjac,xp,fvecp,mode,err) + integer m,n,ldfjac,mode + double precision x(n),fvec(m),fjac(ldfjac,n),xp(n),fvecp(m),err(m) + end subroutine + end interface contains From 9787b2d2b0101f53be4511ee2c0d93bb61f9bf38 Mon Sep 17 00:00:00 2001 From: Ondrej Certik Date: Fri, 24 Feb 2012 22:00:37 -0800 Subject: [PATCH 15/30] Fix the name of the module --- examples/example_lmdif1.f90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/examples/example_lmdif1.f90 b/examples/example_lmdif1.f90 index 790b28d..075229f 100644 --- a/examples/example_lmdif1.f90 +++ b/examples/example_lmdif1.f90 @@ -1,4 +1,4 @@ -module testmod_dif +module testmod_dif1 implicit none private public fcn, dp @@ -33,7 +33,7 @@ subroutine fcn(m, n, x, fvec, iflag) program example_lmdif1 use minpack, only: enorm, dpmpar, lmdif1 -use testmod_dif, only: dp, fcn +use testmod_dif1, only: dp, fcn implicit none integer :: info, m, n From dde41b631177afe4974d2fd633bba883a093e0ef Mon Sep 17 00:00:00 2001 From: Ondrej Certik Date: Fri, 24 Feb 2012 22:00:48 -0800 Subject: [PATCH 16/30] Check derivatives using chkder() --- examples/example_lmder1.f90 | 24 +++++++++++++++++++++--- 1 file changed, 21 insertions(+), 3 deletions(-) diff --git a/examples/example_lmder1.f90 b/examples/example_lmder1.f90 index 002ac74..b119257 100644 --- a/examples/example_lmder1.f90 +++ b/examples/example_lmder1.f90 @@ -1,4 +1,4 @@ -module testmod +module testmod_der1 implicit none private public fcn, dp @@ -43,8 +43,8 @@ subroutine fcn(m, n, x, fvec, fjac, ldfjac, iflag) program example_lmder1 -use minpack, only: enorm, dpmpar, lmder1 -use testmod, only: dp, fcn +use minpack, only: enorm, dpmpar, lmder1, chkder +use testmod_der1, only: dp, fcn implicit none integer :: info @@ -55,6 +55,8 @@ program example_lmder1 ! The following starting values provide a rough fit. x = [1._dp, 1._dp, 1._dp] +call check_deriv() + ! Set tol to the square root of the machine precision. Unless high precision ! solutions are required, this is the recommended setting. tol = sqrt(dpmpar(1)) @@ -67,4 +69,20 @@ program example_lmder1 5x, 'EXIT PARAMETER', 16x, i10 // & 5x, 'FINAL APPROXIMATE SOLUTION' // & 5x, 3d15.7) + +contains + +subroutine check_deriv() +real(dp) :: xp(size(x)), fvecp(size(fvec)), err(size(fvec)) +call chkder(size(fvec), size(x), x, fvec, fjac, size(fjac, 1), xp, fvecp, & + 1, err) +call fcn(size(fvec), size(x), x, fvec, fjac, size(fjac, 1), 1) +call fcn(size(fvec), size(x), x, fvec, fjac, size(fjac, 1), 2) +call fcn(size(fvec), size(x), xp, fvecp, fjac, size(fjac, 1), 1) +call chkder(size(fvec), size(x), x, fvec, fjac, size(fjac, 1), xp, fvecp, & + 2, err) +print *, "Derivatives check (1.0 is correct, 0.0 is incorrect):" +print *, err +end subroutine + end program From 8261e8afdcc7d80ade1e1b523891f0a0d9fa3d01 Mon Sep 17 00:00:00 2001 From: Ondrej Certik Date: Fri, 24 Feb 2012 22:14:09 -0800 Subject: [PATCH 17/30] Make dpmpar portable using epsilon, tiny and huge --- src/dpmpar.f | 140 ++------------------------------------------------- 1 file changed, 4 insertions(+), 136 deletions(-) diff --git a/src/dpmpar.f b/src/dpmpar.f index cb6545a..5432a16 100644 --- a/src/dpmpar.f +++ b/src/dpmpar.f @@ -31,143 +31,11 @@ double precision function dpmpar(i) c Burton S. Garbow, Kenneth E. Hillstrom, Jorge J. More' c c ********** - integer mcheps(4) - integer minmag(4) - integer maxmag(4) + double precision dmach(3) - equivalence (dmach(1),mcheps(1)) - equivalence (dmach(2),minmag(1)) - equivalence (dmach(3),maxmag(1)) -c -c Machine constants for the IBM 360/370 series, -c the Amdahl 470/V6, the ICL 2900, the Itel AS/6, -c the Xerox Sigma 5/7/9 and the Sel systems 85/86. -c -c data mcheps(1),mcheps(2) / z34100000, z00000000 / -c data minmag(1),minmag(2) / z00100000, z00000000 / -c data maxmag(1),maxmag(2) / z7fffffff, zffffffff / -c -c Machine constants for the Honeywell 600/6000 series. -c -c data mcheps(1),mcheps(2) / o606400000000, o000000000000 / -c data minmag(1),minmag(2) / o402400000000, o000000000000 / -c data maxmag(1),maxmag(2) / o376777777777, o777777777777 / -c -c Machine constants for the CDC 6000/7000 series. -c -c data mcheps(1) / 15614000000000000000b / -c data mcheps(2) / 15010000000000000000b / -c -c data minmag(1) / 00604000000000000000b / -c data minmag(2) / 00000000000000000000b / -c -c data maxmag(1) / 37767777777777777777b / -c data maxmag(2) / 37167777777777777777b / -c -c Machine constants for the PDP-10 (KA processor). -c -c data mcheps(1),mcheps(2) / "114400000000, "000000000000 / -c data minmag(1),minmag(2) / "033400000000, "000000000000 / -c data maxmag(1),maxmag(2) / "377777777777, "344777777777 / -c -c Machine constants for the PDP-10 (KI processor). -c -c data mcheps(1),mcheps(2) / "104400000000, "000000000000 / -c data minmag(1),minmag(2) / "000400000000, "000000000000 / -c data maxmag(1),maxmag(2) / "377777777777, "377777777777 / -c -c Machine constants for the PDP-11. -c -c data mcheps(1),mcheps(2) / 9472, 0 / -c data mcheps(3),mcheps(4) / 0, 0 / -c -c data minmag(1),minmag(2) / 128, 0 / -c data minmag(3),minmag(4) / 0, 0 / -c -c data maxmag(1),maxmag(2) / 32767, -1 / -c data maxmag(3),maxmag(4) / -1, -1 / -c -c Machine constants for the Burroughs 6700/7700 systems. -c -c data mcheps(1) / o1451000000000000 / -c data mcheps(2) / o0000000000000000 / -c -c data minmag(1) / o1771000000000000 / -c data minmag(2) / o7770000000000000 / -c -c data maxmag(1) / o0777777777777777 / -c data maxmag(2) / o7777777777777777 / -c -c Machine constants for the Burroughs 5700 system. -c -c data mcheps(1) / o1451000000000000 / -c data mcheps(2) / o0000000000000000 / -c -c data minmag(1) / o1771000000000000 / -c data minmag(2) / o0000000000000000 / -c -c data maxmag(1) / o0777777777777777 / -c data maxmag(2) / o0007777777777777 / -c -c Machine constants for the Burroughs 1700 system. -c -c data mcheps(1) / zcc6800000 / -c data mcheps(2) / z000000000 / -c -c data minmag(1) / zc00800000 / -c data minmag(2) / z000000000 / -c -c data maxmag(1) / zdffffffff / -c data maxmag(2) / zfffffffff / -c -c Machine constants for the Univac 1100 series. -c -c data mcheps(1),mcheps(2) / o170640000000, o000000000000 / -c data minmag(1),minmag(2) / o000040000000, o000000000000 / -c data maxmag(1),maxmag(2) / o377777777777, o777777777777 / -c -c Machine constants for the Data General Eclipse S/200. -c -c Note - it may be appropriate to include the following card - -c static dmach(3) -c -c data minmag/20k,3*0/,maxmag/77777k,3*177777k/ -c data mcheps/32020k,3*0/ -c -c Machine constants for the Harris 220. -c -c data mcheps(1),mcheps(2) / '20000000, '00000334 / -c data minmag(1),minmag(2) / '20000000, '00000201 / -c data maxmag(1),maxmag(2) / '37777777, '37777577 / -c -c Machine constants for the Cray-1. -c -c data mcheps(1) / 0376424000000000000000b / -c data mcheps(2) / 0000000000000000000000b / -c -c data minmag(1) / 0200034000000000000000b / -c data minmag(2) / 0000000000000000000000b / -c -c data maxmag(1) / 0577777777777777777777b / -c data maxmag(2) / 0000007777777777777776b / -c -c Machine constants for the Prime 400. -c -c data mcheps(1),mcheps(2) / :10000000000, :00000000123 / -c data minmag(1),minmag(2) / :10000000000, :00000100000 / -c data maxmag(1),maxmag(2) / :17777777777, :37777677776 / -c -c Machine constants for the VAX-11. -c -c data mcheps(1),mcheps(2) / 9472, 0 / -c data minmag(1),minmag(2) / 128, 0 / -c data maxmag(1),maxmag(2) / -32769, -1 / -c -c Machine constants for IEEE machines. -c - data dmach(1) /2.22044604926d-16/ - data dmach(2) /2.22507385852d-308/ - data dmach(3) /1.79769313485d+308/ + dmach(1) = epsilon(1d0) + dmach(2) = tiny(1d0) + dmach(3) = huge(1d0) c dpmpar = dmach(i) return From a8021e3a2d8dca96395081d52713af30f95dde16 Mon Sep 17 00:00:00 2001 From: Ondrej Certik Date: Fri, 24 Feb 2012 22:17:14 -0800 Subject: [PATCH 18/30] Use epsilon() intrinsic --- examples/example_lmder1.f90 | 4 ++-- examples/example_lmdif1.f90 | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/examples/example_lmder1.f90 b/examples/example_lmder1.f90 index b119257..984207e 100644 --- a/examples/example_lmder1.f90 +++ b/examples/example_lmder1.f90 @@ -43,7 +43,7 @@ subroutine fcn(m, n, x, fvec, fjac, ldfjac, iflag) program example_lmder1 -use minpack, only: enorm, dpmpar, lmder1, chkder +use minpack, only: enorm, lmder1, chkder use testmod_der1, only: dp, fcn implicit none @@ -59,7 +59,7 @@ program example_lmder1 ! Set tol to the square root of the machine precision. Unless high precision ! solutions are required, this is the recommended setting. -tol = sqrt(dpmpar(1)) +tol = sqrt(epsilon(1._dp)) allocate(wa(5*size(x) + size(fvec))) call lmder1(fcn, size(fvec), size(x), x, fvec, fjac, size(fjac, 1), tol, & diff --git a/examples/example_lmdif1.f90 b/examples/example_lmdif1.f90 index 075229f..7da6b75 100644 --- a/examples/example_lmdif1.f90 +++ b/examples/example_lmdif1.f90 @@ -32,7 +32,7 @@ subroutine fcn(m, n, x, fvec, iflag) program example_lmdif1 -use minpack, only: enorm, dpmpar, lmdif1 +use minpack, only: enorm, lmdif1 use testmod_dif1, only: dp, fcn implicit none @@ -46,7 +46,7 @@ program example_lmdif1 ! Set tol to the square root of the machine precision. Unless high precision ! solutions are required, this is the recommended setting. -tol = sqrt(dpmpar(1)) +tol = sqrt(epsilon(1._dp)) m = size(fvec) n = size(x) From 56b802fed467ec20be334ca1fb375e6b0898e6cc Mon Sep 17 00:00:00 2001 From: Ondrej Certik Date: Fri, 24 Feb 2012 23:02:40 -0800 Subject: [PATCH 19/30] Use the f2008 standard --- cmake/UserOverride.cmake | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/cmake/UserOverride.cmake b/cmake/UserOverride.cmake index dc3acb8..31737fa 100644 --- a/cmake/UserOverride.cmake +++ b/cmake/UserOverride.cmake @@ -7,7 +7,7 @@ # variables. if (CMAKE_Fortran_COMPILER_ID STREQUAL "GNU") # gfortran - set(common "-std=f2003 -Wall -Wextra -Wimplicit-interface -Werror -fPIC -fmax-errors=1") + set(common "-std=f2008 -Wall -Wextra -Wimplicit-interface -Werror -fPIC -fmax-errors=1") set(CMAKE_Fortran_FLAGS_RELEASE_INIT "${common} -O3 -march=native -ffast-math -funroll-loops") set(CMAKE_Fortran_FLAGS_DEBUG_INIT "${common} -g -fbounds-check -fcheck-array-temporaries -fbacktrace") elseif (CMAKE_Fortran_COMPILER_ID STREQUAL "Intel") From d52ca03df7aa63bc94d1d77a0f9f55b2b1f7ea70 Mon Sep 17 00:00:00 2001 From: Ondrej Certik Date: Fri, 24 Feb 2012 23:02:28 -0800 Subject: [PATCH 20/30] Add example_primes.f90 --- examples/CMakeLists.txt | 3 ++ examples/example_primes.f90 | 95 +++++++++++++++++++++++++++++++++++++ 2 files changed, 98 insertions(+) create mode 100644 examples/example_primes.f90 diff --git a/examples/CMakeLists.txt b/examples/CMakeLists.txt index 4305186..eacd314 100644 --- a/examples/CMakeLists.txt +++ b/examples/CMakeLists.txt @@ -5,3 +5,6 @@ target_link_libraries(example_lmder1 minpack) add_executable(example_lmdif1 example_lmdif1.f90) target_link_libraries(example_lmdif1 minpack) + +add_executable(example_primes example_primes.f90) +target_link_libraries(example_primes minpack) diff --git a/examples/example_primes.f90 b/examples/example_primes.f90 new file mode 100644 index 0000000..d125537 --- /dev/null +++ b/examples/example_primes.f90 @@ -0,0 +1,95 @@ +module types +implicit none +private +public dp + +integer, parameter :: dp=kind(0d0) + +end module + +module find_fit_module + +! This module contains a general function find_fit() for a nonlinear least +! squares fitting. The function can fit any nonlinear expression to any data. + +use minpack, only: lmdif1 +use types, only: dp +implicit none +private +public find_fit + +contains + +subroutine find_fit(data_x, data_y, expr, pars) +! Fits the (data_x, data_y) arrays with the function expr(x, pars). +! The user can provide any nonlinear function 'expr' depending on any number of +! parameters 'pars' and it must return the evaluated expression on the +! array 'x'. The arrays 'data_x' and 'data_y' must have the same +! length. +real(dp), intent(in) :: data_x(:), data_y(:) +interface + function expr(x, pars) result(y) + use types, only: dp + implicit none + real(dp), intent(in) :: x(:), pars(:) + real(dp) :: y(size(x)) + end function +end interface +real(dp), intent(inout) :: pars(:) + +real(dp) :: tol, fvec(size(data_x)) +integer :: iwa(size(pars)), info, m, n +real(dp), allocatable :: wa(:) + +tol = sqrt(epsilon(1._dp)) +m = size(fvec) +n = size(pars) +allocate(wa(m*n + 5*n + m)) +call lmdif1(fcn, m, n, pars, fvec, tol, info, iwa, wa, size(wa)) +if (info /= 1) stop "failed to converge" + +contains + +subroutine fcn(m, n, x, fvec, iflag) +integer, intent(in) :: m, n, iflag +real(dp), intent(in) :: x(n) +real(dp), intent(out) :: fvec(m) +! Suppress compiler warning: +fvec(1) = iflag +fvec = data_y - expr(data_x, x) +end subroutine + +end subroutine + +end module + + +program example_primes + +! Find a nonlinear fit of the form a*x*log(b + c*x) to a list of primes. + +use find_fit_module, only: find_fit +use types, only: dp +implicit none + +real(dp) :: pars(3) +real(dp), parameter :: y(*) = [2, 3, 5, 7, 11, 13, 17, 19, 23, 29, 31, & + 37, 41, 43, 47, 53, 59, 61, 67, 71] +integer :: i +pars = [1._dp, 1._dp, 1._dp] +call find_fit([(real(i, dp), i=1,size(y))], y, expression, pars) +print *, pars + +contains + +function expression(x, pars) result(y) +real(dp), intent(in) :: x(:), pars(:) +real(dp) :: y(size(x)) +real(dp) :: a, b, c +a = pars(1) +b = pars(2) +c = pars(3) +y = a*x*log(b + c*x) +end function + +end program From 10fb5e1f29d59809e239e6e799bd84acb82679a2 Mon Sep 17 00:00:00 2001 From: Ondrej Certik Date: Wed, 6 Jun 2012 16:59:44 -0700 Subject: [PATCH 21/30] Add links to documentation into the README --- README.rst | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) diff --git a/README.rst b/README.rst index 0cc3683..82fac48 100644 --- a/README.rst +++ b/README.rst @@ -19,7 +19,7 @@ systems of equations with a banded Jacobian matrix, for least squares problems with a large amount of data, and for checking the consistency of the Jacobian matrix with the functions. -Jorge More', Burt Garbow, and Ken Hillstrom at Argonne National Laboratory. +Jorge Moré, Burt Garbow, and Ken Hillstrom at Argonne National Laboratory. Documentation ------------- @@ -44,9 +44,13 @@ default values for the rest (`easy-to-use driver`). Finally: * ``chkder``: checks the consistency of the Jacobian matrix with the functions -Detailed documentation for all these routines together with an example is given -in the file ``ex/file06`` (for double precision). Ready to use examples of -usage are in the ``examples`` directory. +More general documentation is given in +the 1980 Argonne technical report written by the authors of Minpack, +`Chapters 1-3 `_. +The `Chapter 4 `_ (also available in +the file ``ex/file06``) contains detailed documentation for all these routines +together with an example of usage. Ready to use examples of usage are in the +``examples`` directory. Other files in the ``ex`` directory are original examples of usage of various routines (single and double precision), but are not compiled by default. From b3ea6c29debe689a20cb6884cce9b09dce6d0a00 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ond=C5=99ej=20=C4=8Cert=C3=ADk?= Date: Wed, 18 Feb 2015 13:51:50 -0700 Subject: [PATCH 22/30] Remove -Werror --- cmake/UserOverride.cmake | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/cmake/UserOverride.cmake b/cmake/UserOverride.cmake index 31737fa..c93e4ca 100644 --- a/cmake/UserOverride.cmake +++ b/cmake/UserOverride.cmake @@ -7,7 +7,7 @@ # variables. if (CMAKE_Fortran_COMPILER_ID STREQUAL "GNU") # gfortran - set(common "-std=f2008 -Wall -Wextra -Wimplicit-interface -Werror -fPIC -fmax-errors=1") + set(common "-std=f2008 -Wall -Wextra -Wimplicit-interface -fPIC -fmax-errors=1") set(CMAKE_Fortran_FLAGS_RELEASE_INIT "${common} -O3 -march=native -ffast-math -funroll-loops") set(CMAKE_Fortran_FLAGS_DEBUG_INIT "${common} -g -fbounds-check -fcheck-array-temporaries -fbacktrace") elseif (CMAKE_Fortran_COMPILER_ID STREQUAL "Intel") From 8971880aad2379be22491cbcfd833d3b553b496e Mon Sep 17 00:00:00 2001 From: Carlos Une Date: Fri, 2 Apr 2021 02:02:28 -0300 Subject: [PATCH 23/30] Add support for fpm --- .gitignore | 1 + fpm.toml | 33 +++++++++++++++++++++++++++++++++ 2 files changed, 34 insertions(+) create mode 100644 .gitignore create mode 100644 fpm.toml diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..a007fea --- /dev/null +++ b/.gitignore @@ -0,0 +1 @@ +build/* diff --git a/fpm.toml b/fpm.toml new file mode 100644 index 0000000..1159b63 --- /dev/null +++ b/fpm.toml @@ -0,0 +1,33 @@ +name = "minpack" +description = "Minpack includes software for solving nonlinear equations and nonlinear least squares problems." +homepage = "http://www.netlib.org/minpack/" +version = "1.0.0" +license = "http://www.netlib.org/minpack/disclaimer" +author = "Jorge Moré, Burt Garbow, and Ken Hillstrom" +maintainer = "@fortran-lang" +copyright = "Minpack Copyright Notice (1999) University of Chicago. All rights reserved" +categories = ["numerical"] +keywords = ["least squares", "linear equations", "nonlinear equations"] + +[build] +auto-executables = false +auto-tests = false +auto-examples = false + +[install] +library = false + +[[ example ]] +name = "example_lmder1" +source-dir = "examples" +main = "example_lmder1.f90" + +[[ example ]] +name = "example_lmdif1" +source-dir = "examples" +main = "example_lmdif1.f90" + +[[ example ]] +name = "example_primes" +source-dir = "examples" +main = "example_primes.f90" From 0d159539ea146c784bd79922789acff992d1435d Mon Sep 17 00:00:00 2001 From: Carlos Une Date: Thu, 27 May 2021 09:56:11 -0300 Subject: [PATCH 24/30] Add CI: fpm.yml --- .github/workflows/fpm.yml | 38 ++++++++++++++++++++++++++++++++++++++ 1 file changed, 38 insertions(+) create mode 100644 .github/workflows/fpm.yml diff --git a/.github/workflows/fpm.yml b/.github/workflows/fpm.yml new file mode 100644 index 0000000..9540785 --- /dev/null +++ b/.github/workflows/fpm.yml @@ -0,0 +1,38 @@ +name: fpm + +on: [push, pull_request] + +jobs: + gfortran: + runs-on: ubuntu-latest + + env: + FC: gfortran + GCC_V: 10 + + steps: + - name: Checkout code + uses: actions/checkout@v1 + + - name: Install gfortran + run: | + sudo update-alternatives --install /usr/bin/gcc gcc /usr/bin/gcc-${GCC_V} 100 \ + --slave /usr/bin/gfortran gfortran /usr/bin/gfortran-${GCC_V} \ + --slave /usr/bin/gcov gcov /usr/bin/gcov-${GCC_V} + + - name: Install fpm + uses: fortran-lang/setup-fpm@v3 + with: + github-token: ${{ secrets.GITHUB_TOKEN }} + + - name: Build minpack + run: | + gfortran --version + fpm build + + - name: Run examples + run: | + gfortran --version + fpm run --example example_lmder1 + fpm run --example example_lmdif1 + fpm run --example example_primes From ce9ebbbe9c6ff9b537f2bbbf4ea54da0382c67f3 Mon Sep 17 00:00:00 2001 From: zoziha13 <1325686572@qq.com> Date: Wed, 21 Jul 2021 23:54:04 +0800 Subject: [PATCH 25/30] Add hybrd1 interface and example. Update README.rst. --- README.rst | 15 ++++++++ examples/CMakeLists.txt | 3 ++ examples/example_hybrd1.f90 | 74 +++++++++++++++++++++++++++++++++++++ fpm.toml | 5 +++ src/minpack.f90 | 15 ++++++++ 5 files changed, 112 insertions(+) create mode 100644 examples/example_hybrd1.f90 diff --git a/README.rst b/README.rst index 82fac48..796a18a 100644 --- a/README.rst +++ b/README.rst @@ -21,6 +21,21 @@ of the Jacobian matrix with the functions. Jorge Moré, Burt Garbow, and Ken Hillstrom at Argonne National Laboratory. +Build with [fortran-lang/fpm](https://github.com/fortran-lang/fpm) +------------- +Fortran Package Manager (fpm) is a great package manager and build system for Fortran. +You can build using provided `fpm.toml`: +```bash +fpm build +fpm run --example +``` + +To use `minpack` within your fpm project, add the following to your `fpm.toml` file: +```toml +[dependencies] +minpack = { git="https://github.com/certik/minpack.git" } +``` + Documentation ------------- diff --git a/examples/CMakeLists.txt b/examples/CMakeLists.txt index eacd314..7c70e3a 100644 --- a/examples/CMakeLists.txt +++ b/examples/CMakeLists.txt @@ -1,5 +1,8 @@ include_directories(${PROJECT_BINARY_DIR}/src) +add_executable(example_hybrd1 example_hybrd1.f90) +target_link_libraries(example_hybrd1 minpack) + add_executable(example_lmder1 example_lmder1.f90) target_link_libraries(example_lmder1 minpack) diff --git a/examples/example_hybrd1.f90 b/examples/example_hybrd1.f90 new file mode 100644 index 0000000..aecf4a7 --- /dev/null +++ b/examples/example_hybrd1.f90 @@ -0,0 +1,74 @@ +!> the problem is to determine the values of x(1), x(2), ..., x(9), +!> which solve the system of tridiagonal equations. +!> +!> (3-2*x(1))*x(1) -2*x(2) = -1 +!> -x(i-1) + (3-2*x(i))*x(i) -2*x(i+1) = -1, i=2-8 +!> -x(8) + (3-2*x(9))*x(9) = -1 +program example_hybrd1 + + use minpack, only: hybrd1 + implicit none + integer j, n, info, lwa, nwrite + double precision tol, fnorm + double precision x(9), fvec(9), wa(180) + double precision enorm, dpmpar + + data nwrite/6/ + + n = 9 + + !> The following starting values provide a rough solution. + do j = 1, 9 + x(j) = -1.d0 + end do + + lwa = 180 + tol = dsqrt(dpmpar(1)) + + call hybrd1(fcn, n, x, fvec, tol, info, wa, lwa) + fnorm = enorm(n, fvec) + write (nwrite, 1000) fnorm, info, (x(j), j=1, n) + +1000 format(5x, "FINAL L2 NORM OF THE RESIDUALS", d15.7// & + 5x, "EXIT PARAMETER", 16x, i10// & + 5x, "FINAL APPROXIMATE SOLUTION"// & + (5x, 3d15.7)) + + !> Results obtained with different compilers or machines + !> may be slightly different. + !> + !>> FINAL L2 NORM OF THE RESIDUALS 0.1192636D-07 + !>> + !>> EXIT PARAMETER 1 + !>> + !>> FINAL APPROXIMATE SOLUTION + !>> + !>> -0.5706545D+00 -0.6816283D+00 -0.7017325D+00 + !>> -0.7042129D+00 -0.7013690D+00 -0.6918656D+00 + !>> -0.6657920D+00 -0.5960342D+00 -0.4164121D+00 + +contains + + !> subroutine fcn for hybrd1 example. + subroutine fcn(n, x, fvec, iflag) + + implicit none + integer n, iflag + double precision x(n), fvec(n) + + integer k + double precision one, temp, temp1, temp2, three, two, zero + data zero, one, two, three/0.0d0, 1.0d0, 2.0d0, 3.0d0/ + + do k = 1, n + temp = (three - two*x(k))*x(k) + temp1 = zero + if (k /= 1) temp1 = x(k - 1) + temp2 = zero + if (k /= n) temp2 = x(k + 1) + fvec(k) = temp - temp1 - two*temp2 + one + end do + + end subroutine fcn + +end program example_hybrd1 diff --git a/fpm.toml b/fpm.toml index 1159b63..7515a80 100644 --- a/fpm.toml +++ b/fpm.toml @@ -17,6 +17,11 @@ auto-examples = false [install] library = false +[[ example ]] +name = "example_hybrd1" +source-dir = "examples" +main = "example_hybrd1.f90" + [[ example ]] name = "example_lmder1" source-dir = "examples" diff --git a/src/minpack.f90 b/src/minpack.f90 index 799011a..17486e3 100644 --- a/src/minpack.f90 +++ b/src/minpack.f90 @@ -12,6 +12,21 @@ double precision function enorm(n,x) double precision x(n) end function + !> The purpose of `hybrd1` is to find a zero of a system of + !> n nonlinear functions in n variables by a modification + !> of the powell hybrid method. + subroutine hybrd1(fcn,n,x,fvec,tol,info,wa,lwa) + integer n,info,lwa + double precision tol + double precision x(n),fvec(n),wa(lwa) + interface + subroutine fcn(n,x,fvec,iflag) + integer n,iflag + double precision x(n),fvec(n) + end subroutine fcn + end interface + end subroutine hybrd1 + subroutine lmder1(fcn,m,n,x,fvec,fjac,ldfjac,tol,info,ipvt,wa,lwa) integer m,n,ldfjac,info,lwa integer ipvt(n) From be736dafb6ce8dd5656f8aaf7eaa3ec3cced1ee8 Mon Sep 17 00:00:00 2001 From: zoziha13 <1325686572@qq.com> Date: Thu, 22 Jul 2021 00:20:25 +0800 Subject: [PATCH 26/30] Fix README.rst --- README.rst | 33 +++++++++++++++++++-------------- 1 file changed, 19 insertions(+), 14 deletions(-) diff --git a/README.rst b/README.rst index 796a18a..4dccd0e 100644 --- a/README.rst +++ b/README.rst @@ -21,20 +21,25 @@ of the Jacobian matrix with the functions. Jorge Moré, Burt Garbow, and Ken Hillstrom at Argonne National Laboratory. -Build with [fortran-lang/fpm](https://github.com/fortran-lang/fpm) -------------- -Fortran Package Manager (fpm) is a great package manager and build system for Fortran. -You can build using provided `fpm.toml`: -```bash -fpm build -fpm run --example -``` - -To use `minpack` within your fpm project, add the following to your `fpm.toml` file: -```toml -[dependencies] -minpack = { git="https://github.com/certik/minpack.git" } -``` +Build with `fortran-lang/fpm `_ +-------------------------------------------------------------------- + +Fortran Package Manager (fpm) is a great package manager and build system for Fortran. + +You can build using provided ``fpm.toml``: + +.. code-block:: bash + + fpm build + fpm run --example + + +To use ``minpack`` within your fpm project, add the following to your ``fpm.toml`` file: + +.. code-block:: toml + + [dependencies] + minpack = { git="https://github.com/certik/minpack.git" } Documentation ------------- From a297fdb56b7e9aadfcf3a18dd51fb034c8f1d349 Mon Sep 17 00:00:00 2001 From: Carlos Une Date: Wed, 21 Jul 2021 23:43:23 -0300 Subject: [PATCH 27/30] Update CI: add windows and macOS; Closes #2. --- .github/workflows/fpm.yml | 31 +++++++++++++++++++++++++++---- 1 file changed, 27 insertions(+), 4 deletions(-) diff --git a/.github/workflows/fpm.yml b/.github/workflows/fpm.yml index 9540785..134e784 100644 --- a/.github/workflows/fpm.yml +++ b/.github/workflows/fpm.yml @@ -3,18 +3,40 @@ name: fpm on: [push, pull_request] jobs: - gfortran: - runs-on: ubuntu-latest + build: + runs-on: ${{ matrix.os }} + strategy: + fail-fast: false + matrix: + os: [ubuntu-latest, macos-latest, windows-latest] + gcc_v: [10] # Version of GFortran we want to use. + include: + - os: ubuntu-latest + os-arch: linux-x86_64 + + - os: macos-latest + os-arch: macos-x86_64 + + - os: windows-latest + os-arch: windows-x86_64 env: FC: gfortran - GCC_V: 10 + GCC_V: ${{ matrix.gcc_v }} steps: - name: Checkout code uses: actions/checkout@v1 - - name: Install gfortran + - name: Install GFortran macOS + if: contains(matrix.os, 'macos') + run: | + ln -s /usr/local/bin/gfortran-${GCC_V} /usr/local/bin/gfortran + which gfortran-${GCC_V} + which gfortran + + - name: Install GFortran Linux + if: contains(matrix.os, 'ubuntu') run: | sudo update-alternatives --install /usr/bin/gcc gcc /usr/bin/gcc-${GCC_V} 100 \ --slave /usr/bin/gfortran gfortran /usr/bin/gfortran-${GCC_V} \ @@ -36,3 +58,4 @@ jobs: fpm run --example example_lmder1 fpm run --example example_lmdif1 fpm run --example example_primes + fpm run --example example_hybrd1 From 1976de27cb54032edcc0ec3d97ea479dfc676e60 Mon Sep 17 00:00:00 2001 From: zoziha13 <1325686572@qq.com> Date: Mon, 26 Jul 2021 12:50:28 +0800 Subject: [PATCH 28/30] Add hybrd interface and example. --- examples/CMakeLists.txt | 3 ++ examples/example_hybrd.f90 | 101 ++++++++++++++++++++++++++++++++++++ examples/example_hybrd1.f90 | 16 +++--- fpm.toml | 5 ++ src/minpack.f90 | 20 +++++++ 5 files changed, 139 insertions(+), 6 deletions(-) create mode 100644 examples/example_hybrd.f90 diff --git a/examples/CMakeLists.txt b/examples/CMakeLists.txt index 7c70e3a..ede7a42 100644 --- a/examples/CMakeLists.txt +++ b/examples/CMakeLists.txt @@ -1,5 +1,8 @@ include_directories(${PROJECT_BINARY_DIR}/src) +add_executable(example_hybrd example_hybrd.f90) +target_link_libraries(example_hybrd minpack) + add_executable(example_hybrd1 example_hybrd1.f90) target_link_libraries(example_hybrd1 minpack) diff --git a/examples/example_hybrd.f90 b/examples/example_hybrd.f90 new file mode 100644 index 0000000..80f97cf --- /dev/null +++ b/examples/example_hybrd.f90 @@ -0,0 +1,101 @@ +!> The problem is to determine the values of x(1), x(2), ..., x(9) +!> which solve the system of tridiagonal equations +!> (3-2*x(1))*x(1) -2*x(2) = -1 +!> -x(i-1) + (3-2*x(i))*x(i) -2*x(i+1) = -1, i=2-8 +!> -x(8) + (3-2*x(9))*x(9) = -1 +program example_hybrd + + use minpack, only: hybrd, enorm, dpmpar + implicit none + integer j, n, maxfev, ml, mu, mode, nprint, info, nfev, ldfjac, lr, nwrite + double precision xtol, epsfcn, factor, fnorm + double precision x(9), fvec(9), diag(9), fjac(9, 9), r(45), qtf(9), & + wa1(9), wa2(9), wa3(9), wa4(9) + + !> Logical output unit is assumed to be number 6. + data nwrite/6/ + + n = 9 + + !> The following starting values provide a rough solution. + do j = 1, 9 + x(j) = -1.0d0 + end do + + ldfjac = 9 + lr = 45 + + !> Set xtol to the square root of the machine precision. + !> unless high precision solutions are required, + !> this is the recommended setting. + xtol = dsqrt(dpmpar(1)) + + maxfev = 2000 + ml = 1 + mu = 1 + epsfcn = 0.0d0 + mode = 2 + do j = 1, 9 + diag(j) = 1.0d0 + end do + factor = 1.0d2 + nprint = 0 + + call hybrd(fcn, n, x, fvec, xtol, maxfev, ml, mu, epsfcn, diag, & + mode, factor, nprint, info, nfev, fjac, ldfjac, & + r, lr, qtf, wa1, wa2, wa3, wa4) + fnorm = enorm(n, fvec) + write (nwrite, 1000) fnorm, nfev, info, (x(j), j=1, n) + +1000 format(5x, "FINAL L2 NORM OF THE RESIDUALS", d15.7// & + 5x, "NUMBER OF FUNCTION EVALUATIONS", i10// & + 5x, "EXIT PARAMETER", 16x, i10// & + 5x, "FINAL APPROXIMATE SOLUTION"//(5x, 3d15.7)) + + !> Results obtained with different compilers or machines + !> may be slightly different. + !> + !>> FINAL L2 NORM OF THE RESIDUALS 0.1192636D-07 + !>> + !>> NUMBER OF FUNCTION EVALUATIONS 14 + !>> + !>> EXIT PARAMETER 1 + !>> + !>> FINAL APPROXIMATE SOLUTION + !>> + !>> -0.5706545D+00 -0.6816283D+00 -0.7017325D+00 + !>> -0.7042129D+00 -0.7013690D+00 -0.6918656D+00 + !>> -0.6657920D+00 -0.5960342D+00 -0.4164121D+00 + +contains + + !> Subroutine fcn for hybrd example. + subroutine fcn(n, x, fvec, iflag) + + implicit none + integer n, iflag + double precision x(n), fvec(n) + + integer k + double precision one, temp, temp1, temp2, three, two, zero + data zero, one, two, three/0.0d0, 1.0d0, 2.0d0, 3.0d0/ + + if (iflag /= 0) go to 5 + + !! Insert print statements here when nprint is positive. + + return +5 continue + do k = 1, n + temp = (three - two*x(k))*x(k) + temp1 = zero + if (k /= 1) temp1 = x(k - 1) + temp2 = zero + if (k /= n) temp2 = x(k + 1) + fvec(k) = temp - temp1 - two*temp2 + one + end do + return + + end subroutine fcn + +end program example_hybrd diff --git a/examples/example_hybrd1.f90 b/examples/example_hybrd1.f90 index aecf4a7..29c2fc8 100644 --- a/examples/example_hybrd1.f90 +++ b/examples/example_hybrd1.f90 @@ -2,17 +2,17 @@ !> which solve the system of tridiagonal equations. !> !> (3-2*x(1))*x(1) -2*x(2) = -1 -!> -x(i-1) + (3-2*x(i))*x(i) -2*x(i+1) = -1, i=2-8 -!> -x(8) + (3-2*x(9))*x(9) = -1 +!> -x(i-1) + (3-2*x(i))*x(i) -2*x(i+1) = -1, i=2-8 +!> -x(8) + (3-2*x(9))*x(9) = -1 program example_hybrd1 - use minpack, only: hybrd1 + use minpack, only: hybrd1, dpmpar, enorm implicit none integer j, n, info, lwa, nwrite double precision tol, fnorm double precision x(9), fvec(9), wa(180) - double precision enorm, dpmpar + !> Logical output unit is assumed to be number 6. data nwrite/6/ n = 9 @@ -23,6 +23,10 @@ program example_hybrd1 end do lwa = 180 + + !> Set tol to the square root of the machine precision. + !> unless high precision solutions are required, + !> this is the recommended setting. tol = dsqrt(dpmpar(1)) call hybrd1(fcn, n, x, fvec, tol, info, wa, lwa) @@ -35,7 +39,7 @@ program example_hybrd1 (5x, 3d15.7)) !> Results obtained with different compilers or machines - !> may be slightly different. + !> may be slightly different. !> !>> FINAL L2 NORM OF THE RESIDUALS 0.1192636D-07 !>> @@ -49,7 +53,7 @@ program example_hybrd1 contains - !> subroutine fcn for hybrd1 example. + !> Subroutine fcn for hybrd1 example. subroutine fcn(n, x, fvec, iflag) implicit none diff --git a/fpm.toml b/fpm.toml index 7515a80..0c3d917 100644 --- a/fpm.toml +++ b/fpm.toml @@ -17,6 +17,11 @@ auto-examples = false [install] library = false +[[ example ]] +name = "example_hybrd" +source-dir = "examples" +main = "example_hybrd.f90" + [[ example ]] name = "example_hybrd1" source-dir = "examples" diff --git a/src/minpack.f90 b/src/minpack.f90 index 17486e3..294b144 100644 --- a/src/minpack.f90 +++ b/src/minpack.f90 @@ -12,6 +12,26 @@ double precision function enorm(n,x) double precision x(n) end function + !> The purpose of `hybrd` is to find a zero of a system of N non- + !> linear functions in N variables by a modification of the Powell + !> hybrid method. The user must provide a subroutine which calcu- + !> lates the functions. The Jacobian is then calculated by a for- + !> ward-difference approximation. + subroutine hybrd(fcn,n,x,fvec,xtol,maxfev,ml,mu,epsfcn,diag, & + mode,factor,nprint,info,nfev,fjac,ldfjac, & + r,lr,qtf,wa1,wa2,wa3,wa4) + integer n,maxfev,ml,mu,mode,nprint,info,nfev,ldfjac,lr + double precision xtol,epsfcn,factor + double precision x(n),fvec(n),diag(n),fjac(ldfjac,n),r(lr),qtf(n), & + wa1(n),wa2(n),wa3(n),wa4(n) + interface + subroutine fcn(n,x,fvec,iflag) + integer n,iflag + double precision x(n),fvec(n) + end subroutine fcn + end interface + end subroutine hybrd + !> The purpose of `hybrd1` is to find a zero of a system of !> n nonlinear functions in n variables by a modification !> of the powell hybrid method. From 1ad35d27805772df8c45488d0175f02fd99cc047 Mon Sep 17 00:00:00 2001 From: zoziha13 <1325686572@qq.com> Date: Mon, 26 Jul 2021 14:18:38 +0800 Subject: [PATCH 29/30] Add example_hybrd to fpm.yml (CI tasks) --- .github/workflows/fpm.yml | 1 + 1 file changed, 1 insertion(+) diff --git a/.github/workflows/fpm.yml b/.github/workflows/fpm.yml index 134e784..046c4f8 100644 --- a/.github/workflows/fpm.yml +++ b/.github/workflows/fpm.yml @@ -58,4 +58,5 @@ jobs: fpm run --example example_lmder1 fpm run --example example_lmdif1 fpm run --example example_primes + fpm run --example example_hybrd fpm run --example example_hybrd1 From a4bf26910a433336024c1d503c899138ef9ef329 Mon Sep 17 00:00:00 2001 From: Sebastian Ehlert <28669218+awvwgk@users.noreply.github.com> Date: Wed, 9 Feb 2022 23:50:52 +0100 Subject: [PATCH 30/30] Extract examples from certik/minpack --- .github/workflows/fpm.yml | 62 - .gitignore | 1 - CMakeLists.txt | 42 - LICENSE | 73 - README.rst | 76 - cmake/UserOverride.cmake | 18 - ex/chkdrv.f | 87 - ex/file01 | 145 -- ex/file02 | 4771 ---------------------------------- ex/file03 | 3526 -------------------------- ex/file04 | 192 -- ex/file05 | 4778 ----------------------------------- ex/file06 | 3528 -------------------------- ex/file07 | 283 --- ex/file08 | 551 ---- ex/file09 | 879 ------- ex/file10 | 1022 -------- ex/file11 | 1033 -------- ex/file12 | 673 ----- ex/file13 | 858 ------- ex/file14 | 284 --- ex/file15 | 552 ---- ex/file16 | 881 ------- ex/file17 | 1025 -------- ex/file18 | 1036 -------- ex/file19 | 675 ----- ex/file20 | 860 ------- ex/file21 | 23 - ex/file22 | 29 - ex/file23 | 15 - ex/hybdrv.f | 112 - ex/hyjdrv.f | 120 - ex/lmddrv.f | 124 - ex/lmfdrv.f | 121 - ex/lmsdrv.f | 135 - ex/ucodrv.f | 122 - examples/CMakeLists.txt | 16 - examples/example_hybrd.f90 | 2 +- examples/example_hybrd1.f90 | 2 +- examples/example_lmder1.f90 | 2 +- examples/example_lmdif1.f90 | 2 +- examples/example_primes.f90 | 2 +- fpm.toml | 43 - src/CMakeLists.txt | 18 - src/chkder.f | 140 - src/covar.f | 145 -- src/dmchar.f | 212 -- src/dogleg.f | 177 -- src/dpmpar.f | 45 - src/enorm.f | 108 - src/errjac.f | 333 --- src/fdjac1.f | 151 -- src/fdjac2.f | 107 - src/grdfcn.f | 438 ---- src/hesfcn.f | 651 ----- src/hybipt.f | 167 -- src/hybrd.f | 459 ---- src/hybrd1.f | 123 - src/hybrj.f | 440 ---- src/hybrj1.f | 127 - src/lhesfcn.f | 663 ----- src/lmder.f | 452 ---- src/lmder1.f | 156 -- src/lmdif.f | 454 ---- src/lmdif1.f | 135 - src/lmdipt.f | 214 -- src/lmpar.f | 264 -- src/lmstr.f | 466 ---- src/lmstr1.f | 156 -- src/minpack.f90 | 89 - src/objfcn.f | 342 --- src/ocpipt.f | 223 -- src/qform.f | 95 - src/qrfac.f | 164 -- src/qrsolv.f | 193 -- src/r1mpyq.f | 92 - src/r1updt.f | 207 -- src/rwupdt.f | 113 - src/ssqfcn.f | 340 --- src/ssqjac.f | 347 --- src/vecfcn.f | 273 -- src/vecjac.f | 321 --- 82 files changed, 5 insertions(+), 38376 deletions(-) delete mode 100644 .github/workflows/fpm.yml delete mode 100644 .gitignore delete mode 100644 CMakeLists.txt delete mode 100644 LICENSE delete mode 100644 README.rst delete mode 100644 cmake/UserOverride.cmake delete mode 100644 ex/chkdrv.f delete mode 100644 ex/file01 delete mode 100644 ex/file02 delete mode 100644 ex/file03 delete mode 100644 ex/file04 delete mode 100644 ex/file05 delete mode 100644 ex/file06 delete mode 100644 ex/file07 delete mode 100644 ex/file08 delete mode 100644 ex/file09 delete mode 100644 ex/file10 delete mode 100644 ex/file11 delete mode 100644 ex/file12 delete mode 100644 ex/file13 delete mode 100644 ex/file14 delete mode 100644 ex/file15 delete mode 100644 ex/file16 delete mode 100644 ex/file17 delete mode 100644 ex/file18 delete mode 100644 ex/file19 delete mode 100644 ex/file20 delete mode 100644 ex/file21 delete mode 100644 ex/file22 delete mode 100644 ex/file23 delete mode 100644 ex/hybdrv.f delete mode 100644 ex/hyjdrv.f delete mode 100644 ex/lmddrv.f delete mode 100644 ex/lmfdrv.f delete mode 100644 ex/lmsdrv.f delete mode 100644 ex/ucodrv.f delete mode 100644 examples/CMakeLists.txt delete mode 100644 fpm.toml delete mode 100644 src/CMakeLists.txt delete mode 100644 src/chkder.f delete mode 100644 src/covar.f delete mode 100644 src/dmchar.f delete mode 100644 src/dogleg.f delete mode 100644 src/dpmpar.f delete mode 100644 src/enorm.f delete mode 100644 src/errjac.f delete mode 100644 src/fdjac1.f delete mode 100644 src/fdjac2.f delete mode 100644 src/grdfcn.f delete mode 100644 src/hesfcn.f delete mode 100644 src/hybipt.f delete mode 100644 src/hybrd.f delete mode 100644 src/hybrd1.f delete mode 100644 src/hybrj.f delete mode 100644 src/hybrj1.f delete mode 100644 src/lhesfcn.f delete mode 100644 src/lmder.f delete mode 100644 src/lmder1.f delete mode 100644 src/lmdif.f delete mode 100644 src/lmdif1.f delete mode 100644 src/lmdipt.f delete mode 100644 src/lmpar.f delete mode 100644 src/lmstr.f delete mode 100644 src/lmstr1.f delete mode 100644 src/minpack.f90 delete mode 100644 src/objfcn.f delete mode 100644 src/ocpipt.f delete mode 100644 src/qform.f delete mode 100644 src/qrfac.f delete mode 100644 src/qrsolv.f delete mode 100644 src/r1mpyq.f delete mode 100644 src/r1updt.f delete mode 100644 src/rwupdt.f delete mode 100644 src/ssqfcn.f delete mode 100644 src/ssqjac.f delete mode 100644 src/vecfcn.f delete mode 100644 src/vecjac.f diff --git a/.github/workflows/fpm.yml b/.github/workflows/fpm.yml deleted file mode 100644 index 046c4f8..0000000 --- a/.github/workflows/fpm.yml +++ /dev/null @@ -1,62 +0,0 @@ -name: fpm - -on: [push, pull_request] - -jobs: - build: - runs-on: ${{ matrix.os }} - strategy: - fail-fast: false - matrix: - os: [ubuntu-latest, macos-latest, windows-latest] - gcc_v: [10] # Version of GFortran we want to use. - include: - - os: ubuntu-latest - os-arch: linux-x86_64 - - - os: macos-latest - os-arch: macos-x86_64 - - - os: windows-latest - os-arch: windows-x86_64 - - env: - FC: gfortran - GCC_V: ${{ matrix.gcc_v }} - - steps: - - name: Checkout code - uses: actions/checkout@v1 - - - name: Install GFortran macOS - if: contains(matrix.os, 'macos') - run: | - ln -s /usr/local/bin/gfortran-${GCC_V} /usr/local/bin/gfortran - which gfortran-${GCC_V} - which gfortran - - - name: Install GFortran Linux - if: contains(matrix.os, 'ubuntu') - run: | - sudo update-alternatives --install /usr/bin/gcc gcc /usr/bin/gcc-${GCC_V} 100 \ - --slave /usr/bin/gfortran gfortran /usr/bin/gfortran-${GCC_V} \ - --slave /usr/bin/gcov gcov /usr/bin/gcov-${GCC_V} - - - name: Install fpm - uses: fortran-lang/setup-fpm@v3 - with: - github-token: ${{ secrets.GITHUB_TOKEN }} - - - name: Build minpack - run: | - gfortran --version - fpm build - - - name: Run examples - run: | - gfortran --version - fpm run --example example_lmder1 - fpm run --example example_lmdif1 - fpm run --example example_primes - fpm run --example example_hybrd - fpm run --example example_hybrd1 diff --git a/.gitignore b/.gitignore deleted file mode 100644 index a007fea..0000000 --- a/.gitignore +++ /dev/null @@ -1 +0,0 @@ -build/* diff --git a/CMakeLists.txt b/CMakeLists.txt deleted file mode 100644 index 890c799..0000000 --- a/CMakeLists.txt +++ /dev/null @@ -1,42 +0,0 @@ -cmake_minimum_required(VERSION 2.6 FATAL_ERROR) - -set(CMAKE_USER_MAKE_RULES_OVERRIDE ${CMAKE_SOURCE_DIR}/cmake/UserOverride.cmake) - -project(minpack) -enable_language(Fortran) - -set(CMAKE_MODULE_PATH ${PROJECT_SOURCE_DIR}/cmake) - -# Make sure that CMAKE_BUILD_TYPE is either Debug or Release: -if (NOT CMAKE_BUILD_TYPE) - set(CMAKE_BUILD_TYPE Debug - CACHE STRING "Build type (Debug, Release)" FORCE) -endif () -if (NOT (CMAKE_BUILD_TYPE STREQUAL "Debug" OR - CMAKE_BUILD_TYPE STREQUAL "Release")) - message("${CMAKE_BUILD_TYPE}") - message(FATAL_ERROR "CMAKE_BUILD_TYPE must be one of: Debug, Release (current value: '${CMAKE_BUILD_TYPE}')") -endif () - -if (CMAKE_Fortran_COMPILER_ID STREQUAL "GNU") - # gfortran - # Enable this if you want to check for single/double corruption (and use - # the Debug build): - #set(CMAKE_Fortran_FLAGS_DEBUG "${CMAKE_Fortran_FLAGS_DEBUG} -fdefault-real-8") -endif () - - -add_subdirectory(examples) -add_subdirectory(src) - -message("\n") -message("Configuration results") -message("---------------------") -message("Fortran compiler: ${CMAKE_Fortran_COMPILER}") -message("Build type: ${CMAKE_BUILD_TYPE}") -if (CMAKE_BUILD_TYPE STREQUAL "Debug") - message("Fortran compiler flags: ${CMAKE_Fortran_FLAGS_DEBUG}") -else () - message("Fortran compiler flags: ${CMAKE_Fortran_FLAGS_RELEASE}") -endif () -message("Installation prefix: ${CMAKE_INSTALL_PREFIX}") diff --git a/LICENSE b/LICENSE deleted file mode 100644 index 60e9b11..0000000 --- a/LICENSE +++ /dev/null @@ -1,73 +0,0 @@ -Copyright (c) 2012 Ondřej Čertík - -Permission is hereby granted, free of charge, to any person obtaining a copy -of this software and associated documentation files (the "Software"), to deal -in the Software without restriction, including without limitation the rights -to use, copy, modify, merge, publish, distribute, sublicense, and/or sell -copies of the Software, and to permit persons to whom the Software is -furnished to do so, subject to the following conditions: - -The above copyright notice and this permission notice shall be included in -all copies or substantial portions of the Software. - -THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, -OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN -THE SOFTWARE. - ------------------------------------------------------------------------------ - -Minpack Copyright Notice (1999) University of Chicago. All rights reserved - -Redistribution and use in source and binary forms, with or -without modification, are permitted provided that the -following conditions are met: - -1. Redistributions of source code must retain the above -copyright notice, this list of conditions and the following -disclaimer. - -2. Redistributions in binary form must reproduce the above -copyright notice, this list of conditions and the following -disclaimer in the documentation and/or other materials -provided with the distribution. - -3. The end-user documentation included with the -redistribution, if any, must include the following -acknowledgment: - - "This product includes software developed by the - University of Chicago, as Operator of Argonne National - Laboratory. - -Alternately, this acknowledgment may appear in the software -itself, if and wherever such third-party acknowledgments -normally appear. - -4. WARRANTY DISCLAIMER. THE SOFTWARE IS SUPPLIED "AS IS" -WITHOUT WARRANTY OF ANY KIND. THE COPYRIGHT HOLDER, THE -UNITED STATES, THE UNITED STATES DEPARTMENT OF ENERGY, AND -THEIR EMPLOYEES: (1) DISCLAIM ANY WARRANTIES, EXPRESS OR -IMPLIED, INCLUDING BUT NOT LIMITED TO ANY IMPLIED WARRANTIES -OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE, TITLE -OR NON-INFRINGEMENT, (2) DO NOT ASSUME ANY LEGAL LIABILITY -OR RESPONSIBILITY FOR THE ACCURACY, COMPLETENESS, OR -USEFULNESS OF THE SOFTWARE, (3) DO NOT REPRESENT THAT USE OF -THE SOFTWARE WOULD NOT INFRINGE PRIVATELY OWNED RIGHTS, (4) -DO NOT WARRANT THAT THE SOFTWARE WILL FUNCTION -UNINTERRUPTED, THAT IT IS ERROR-FREE OR THAT ANY ERRORS WILL -BE CORRECTED. - -5. LIMITATION OF LIABILITY. IN NO EVENT WILL THE COPYRIGHT -HOLDER, THE UNITED STATES, THE UNITED STATES DEPARTMENT OF -ENERGY, OR THEIR EMPLOYEES: BE LIABLE FOR ANY INDIRECT, -INCIDENTAL, CONSEQUENTIAL, SPECIAL OR PUNITIVE DAMAGES OF -ANY KIND OR NATURE, INCLUDING BUT NOT LIMITED TO LOSS OF -PROFITS OR LOSS OF DATA, FOR ANY REASON WHATSOEVER, WHETHER -SUCH LIABILITY IS ASSERTED ON THE BASIS OF CONTRACT, TORT -(INCLUDING NEGLIGENCE OR STRICT LIABILITY), OR OTHERWISE, -EVEN IF ANY OF SAID PARTIES HAS BEEN WARNED OF THE -POSSIBILITY OF SUCH LOSS OR DAMAGES. diff --git a/README.rst b/README.rst deleted file mode 100644 index 4dccd0e..0000000 --- a/README.rst +++ /dev/null @@ -1,76 +0,0 @@ -Minpack -======= - -Information ------------ - -This repository contains the original double precision Minpack from netlib.org, -together with CMake makefiles and examples. - -About Minpack -------------- - -Minpack includes software for solving nonlinear equations and -nonlinear least squares problems. Five algorithmic paths each include -a core subroutine and an easy-to-use driver. The algorithms proceed -either from an analytic specification of the Jacobian matrix or -directly from the problem functions. The paths include facilities for -systems of equations with a banded Jacobian matrix, for least squares -problems with a large amount of data, and for checking the consistency -of the Jacobian matrix with the functions. - -Jorge Moré, Burt Garbow, and Ken Hillstrom at Argonne National Laboratory. - -Build with `fortran-lang/fpm `_ --------------------------------------------------------------------- - -Fortran Package Manager (fpm) is a great package manager and build system for Fortran. - -You can build using provided ``fpm.toml``: - -.. code-block:: bash - - fpm build - fpm run --example - - -To use ``minpack`` within your fpm project, add the following to your ``fpm.toml`` file: - -.. code-block:: toml - - [dependencies] - minpack = { git="https://github.com/certik/minpack.git" } - -Documentation -------------- - -Minpack contains 4 subroutines for solution of systems of nonlinear equations: - -* ``hybrd``, ``hybrd1``: Jacobian matrix is calculated by a forward difference - approximation -* ``hybrj``, ``hybrj1``: Jacobian matrix is provided by the user - -and 6 subroutines for nonlinear least squares problems: - -* ``lmdif``, ``lmdif1``: Jacobian matrix is calculated by a forward difference - approximation -* ``lmder``, ``lmder1``: Jacobian matrix is provided by the user -* ``lmstr``, ``lmstr1``: Jacobian matrix is provided by the user, one row per - call (uses less memory) - -The routines without ``1`` in the name expose all parameters to the user (`core -subroutines`), routines with ``1`` only expose the essential parameters and set -default values for the rest (`easy-to-use driver`). Finally: - -* ``chkder``: checks the consistency of the Jacobian matrix with the functions - -More general documentation is given in -the 1980 Argonne technical report written by the authors of Minpack, -`Chapters 1-3 `_. -The `Chapter 4 `_ (also available in -the file ``ex/file06``) contains detailed documentation for all these routines -together with an example of usage. Ready to use examples of usage are in the -``examples`` directory. - -Other files in the ``ex`` directory are original examples of usage of various -routines (single and double precision), but are not compiled by default. diff --git a/cmake/UserOverride.cmake b/cmake/UserOverride.cmake deleted file mode 100644 index c93e4ca..0000000 --- a/cmake/UserOverride.cmake +++ /dev/null @@ -1,18 +0,0 @@ -# This overrides the default CMake Debug and Release compiler options. -# The user can still specify different options by setting the -# CMAKE_Fortran_FLAGS_[RELEASE,DEBUG] variables (on the command line or in the -# CMakeList.txt). This files serves as better CMake defaults and should only be -# modified if the default values are to be changed. Project specific compiler -# flags should be set in the CMakeList.txt by setting the CMAKE_Fortran_FLAGS_* -# variables. -if (CMAKE_Fortran_COMPILER_ID STREQUAL "GNU") - # gfortran - set(common "-std=f2008 -Wall -Wextra -Wimplicit-interface -fPIC -fmax-errors=1") - set(CMAKE_Fortran_FLAGS_RELEASE_INIT "${common} -O3 -march=native -ffast-math -funroll-loops") - set(CMAKE_Fortran_FLAGS_DEBUG_INIT "${common} -g -fbounds-check -fcheck-array-temporaries -fbacktrace") -elseif (CMAKE_Fortran_COMPILER_ID STREQUAL "Intel") - # ifort - set(common "-std2003 -warn all") - set(CMAKE_Fortran_FLAGS_RELEASE_INIT "${common} -xHOST -O3 -no-prec-div -static") - set(CMAKE_Fortran_FLAGS_DEBUG_INIT "${common} -check all") -endif () diff --git a/ex/chkdrv.f b/ex/chkdrv.f deleted file mode 100644 index d50c582..0000000 --- a/ex/chkdrv.f +++ /dev/null @@ -1,87 +0,0 @@ -c ********** -c -c this program tests the ability of chkder to detect -c inconsistencies between functions and their first derivatives. -c fourteen test function vectors and jacobians are used. eleven of -c the tests are false(f), i.e. there are inconsistencies between -c the function vectors and the corresponding jacobians. three of -c the tests are true(t), i.e. there are no inconsistencies. the -c driver reads in data, calls chkder and prints out information -c required by and received from chkder. -c -c subprograms called -c -c minpack supplied ... chkder,errjac,initpt,vecfcn -c -c argonne national laboratory. minpack project. march 1980. -c burton s. garbow, kenneth e. hillstrom, jorge j. more -c -c ********** - integer i,ldfjac,lnp,mode,n,nprob,nread,nwrite - integer na(14),np(14) - logical a(14) - double precision cp,one - double precision diff(10),err(10),errmax(14),errmin(14), - * fjac(10,10),fvec1(10),fvec2(10),x1(10),x2(10) -c -c logical input unit is assumed to be number 5. -c logical output unit is assumed to be number 6. -c - data nread,nwrite /5,6/ -c - data a(1),a(2),a(3),a(4),a(5),a(6),a(7),a(8),a(9),a(10),a(11), - * a(12),a(13),a(14) - * /.false.,.false.,.false.,.true.,.false.,.false.,.false., - * .true.,.false.,.false.,.false.,.false.,.true.,.false./ - data cp,one /1.23d-1,1.0d0/ - ldfjac = 10 - 10 continue - read (nread,60) nprob,n - if (nprob .le. 0) go to 40 - call initpt(n,x1,nprob,one) - do 20 i = 1, n - x1(i) = x1(i) + cp - cp = -cp - 20 continue - write (nwrite,70) nprob,n,a(nprob) - mode = 1 - call chkder(n,n,x1,fvec1,fjac,ldfjac,x2,fvec2,mode,err) - mode = 2 - call vecfcn(n,x1,fvec1,nprob) - call errjac(n,x1,fjac,ldfjac,nprob) - call vecfcn(n,x2,fvec2,nprob) - call chkder(n,n,x1,fvec1,fjac,ldfjac,x2,fvec2,mode,err) - errmin(nprob) = err(1) - errmax(nprob) = err(1) - do 30 i = 1, n - diff(i) = fvec2(i) - fvec1(i) - if (errmin(nprob) .gt. err(i)) errmin(nprob) = err(i) - if (errmax(nprob) .lt. err(i)) errmax(nprob) = err(i) - 30 continue - np(nprob) = nprob - lnp = nprob - na(nprob) = n - write (nwrite,80) (fvec1(i), i = 1, n) - write (nwrite,90) (diff(i), i = 1, n) - write (nwrite,100) (err(i), i = 1, n) - go to 10 - 40 continue - write (nwrite,110) lnp - write (nwrite,120) - do 50 i = 1, lnp - write (nwrite,130) np(i),na(i),a(i),errmin(i),errmax(i) - 50 continue - stop - 60 format (2i5) - 70 format ( /// 5x, 8h problem, i5, 5x, 15h with dimension, i5, 2x, - * 5h is , l1) - 80 format ( // 5x, 25h first function vector // (5x, 5d15.7)) - 90 format ( // 5x, 27h function difference vector // (5x, 5d15.7)) - 100 format ( // 5x, 13h error vector // (5x, 5d15.7)) - 110 format (12h1summary of , i3, 16h tests of chkder /) - 120 format (46h nprob n status errmin errmax /) - 130 format (i4, i6, 6x, l1, 3x, 2d15.7) -c -c last card of derivative check test driver. -c - end diff --git a/ex/file01 b/ex/file01 deleted file mode 100644 index d5d0c55..0000000 --- a/ex/file01 +++ /dev/null @@ -1,145 +0,0 @@ - REAL FUNCTION SPMPAR(I) - INTEGER I -C ********** -C -C FUNCTION SPMPAR -C -C THIS FUNCTION PROVIDES SINGLE PRECISION MACHINE PARAMETERS -C WHEN THE APPROPRIATE SET OF DATA STATEMENTS IS ACTIVATED (BY -C REMOVING THE C FROM COLUMN 1) AND ALL OTHER DATA STATEMENTS ARE -C RENDERED INACTIVE. MOST OF THE PARAMETER VALUES WERE OBTAINED -C FROM THE CORRESPONDING BELL LABORATORIES PORT LIBRARY FUNCTION. -C -C THE FUNCTION STATEMENT IS -C -C REAL FUNCTION SPMPAR(I) -C -C WHERE -C -C I IS AN INTEGER INPUT VARIABLE SET TO 1, 2, OR 3 WHICH -C SELECTS THE DESIRED MACHINE PARAMETER. IF THE MACHINE HAS -C T BASE B DIGITS AND ITS SMALLEST AND LARGEST EXPONENTS ARE -C EMIN AND EMAX, RESPECTIVELY, THEN THESE PARAMETERS ARE -C -C SPMPAR(1) = B**(1 - T), THE MACHINE PRECISION, -C -C SPMPAR(2) = B**(EMIN - 1), THE SMALLEST MAGNITUDE, -C -C SPMPAR(3) = B**EMAX*(1 - B**(-T)), THE LARGEST MAGNITUDE. -C -C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. -C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE -C -C ********** - INTEGER MCHEPS(2) - INTEGER MINMAG(2) - INTEGER MAXMAG(2) - REAL RMACH(3) - EQUIVALENCE (RMACH(1),MCHEPS(1)) - EQUIVALENCE (RMACH(2),MINMAG(1)) - EQUIVALENCE (RMACH(3),MAXMAG(1)) -C -C MACHINE CONSTANTS FOR THE IBM 360/370 SERIES, -C THE AMDAHL 470/V6, THE ICL 2900, THE ITEL AS/6, -C THE XEROX SIGMA 5/7/9 AND THE SEL SYSTEMS 85/86. -C - DATA RMACH(1) / Z3C100000 / - DATA RMACH(2) / Z00100000 / - DATA RMACH(3) / Z7FFFFFFF / -C -C MACHINE CONSTANTS FOR THE HONEYWELL 600/6000 SERIES. -C -C DATA RMACH(1) / O716400000000 / -C DATA RMACH(2) / O402400000000 / -C DATA RMACH(3) / O376777777777 / -C -C MACHINE CONSTANTS FOR THE CDC 6000/7000 SERIES. -C -C DATA RMACH(1) / 16414000000000000000B / -C DATA RMACH(2) / 00014000000000000000B / -C DATA RMACH(3) / 37767777777777777777B / -C -C MACHINE CONSTANTS FOR THE PDP-10 (KA OR KI PROCESSOR). -C -C DATA RMACH(1) / "147400000000 / -C DATA RMACH(2) / "000400000000 / -C DATA RMACH(3) / "377777777777 / -C -C MACHINE CONSTANTS FOR THE PDP-11 FORTRAN SUPPORTING -C 32-BIT INTEGERS (EXPRESSED IN INTEGER AND OCTAL). -C -C DATA MCHEPS(1) / 889192448 / -C DATA MINMAG(1) / 8388608 / -C DATA MAXMAG(1) / 2147483647 / -C -C DATA RMACH(1) / O06500000000 / -C DATA RMACH(2) / O00040000000 / -C DATA RMACH(3) / O17777777777 / -C -C MACHINE CONSTANTS FOR THE PDP-11 FORTRAN SUPPORTING -C 16-BIT INTEGERS (EXPRESSED IN INTEGER AND OCTAL). -C -C DATA MCHEPS(1),MCHEPS(2) / 13568, 0 / -C DATA MINMAG(1),MINMAG(2) / 128, 0 / -C DATA MAXMAG(1),MAXMAG(2) / 32767, -1 / -C -C DATA MCHEPS(1),MCHEPS(2) / O032400, O000000 / -C DATA MINMAG(1),MINMAG(2) / O000200, O000000 / -C DATA MAXMAG(1),MAXMAG(2) / O077777, O177777 / -C -C MACHINE CONSTANTS FOR THE BURROUGHS 5700/6700/7700 SYSTEMS. -C -C DATA RMACH(1) / O1301000000000000 / -C DATA RMACH(2) / O1771000000000000 / -C DATA RMACH(3) / O0777777777777777 / -C -C MACHINE CONSTANTS FOR THE BURROUGHS 1700 SYSTEM. -C -C DATA RMACH(1) / Z4EA800000 / -C DATA RMACH(2) / Z400800000 / -C DATA RMACH(3) / Z5FFFFFFFF / -C -C MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES. -C -C DATA RMACH(1) / O147400000000 / -C DATA RMACH(2) / O000400000000 / -C DATA RMACH(3) / O377777777777 / -C -C MACHINE CONSTANTS FOR THE DATA GENERAL ECLIPSE S/200. -C -C NOTE - IT MAY BE APPROPRIATE TO INCLUDE THE FOLLOWING CARD - -C STATIC RMACH(3) -C -C DATA MINMAG/20K,0/,MAXMAG/77777K,177777K/ -C DATA MCHEPS/36020K,0/ -C -C MACHINE CONSTANTS FOR THE HARRIS 220. -C -C DATA MCHEPS(1) / '20000000, '00000353 / -C DATA MINMAG(1) / '20000000, '00000201 / -C DATA MAXMAG(1) / '37777777, '00000177 / -C -C MACHINE CONSTANTS FOR THE CRAY-1. -C -C DATA RMACH(1) / 0377224000000000000000B / -C DATA RMACH(2) / 0200034000000000000000B / -C DATA RMACH(3) / 0577777777777777777776B / -C -C MACHINE CONSTANTS FOR THE PRIME 400. -C -C DATA MCHEPS(1) / :10000000153 / -C DATA MINMAG(1) / :10000000000 / -C DATA MAXMAG(1) / :17777777777 / -C -C MACHINE CONSTANTS FOR THE VAX-11. -C -C DATA MCHEPS(1) / 13568 / -C DATA MINMAG(1) / 128 / -C DATA MAXMAG(1) / -32769 / -C - SPMPAR = RMACH(I) - RETURN -C -C LAST CARD OF FUNCTION SPMPAR. -C - END diff --git a/ex/file02 b/ex/file02 deleted file mode 100644 index 5a3ec93..0000000 --- a/ex/file02 +++ /dev/null @@ -1,4771 +0,0 @@ - SUBROUTINE CHKDER(M,N,X,FVEC,FJAC,LDFJAC,XP,FVECP,MODE,ERR) - INTEGER M,N,LDFJAC,MODE - REAL X(N),FVEC(M),FJAC(LDFJAC,N),XP(N),FVECP(M),ERR(M) -C ********** -C -C SUBROUTINE CHKDER -C -C THIS SUBROUTINE CHECKS THE GRADIENTS OF M NONLINEAR FUNCTIONS -C IN N VARIABLES, EVALUATED AT A POINT X, FOR CONSISTENCY WITH -C THE FUNCTIONS THEMSELVES. THE USER MUST CALL CHKDER TWICE, -C FIRST WITH MODE = 1 AND THEN WITH MODE = 2. -C -C MODE = 1. ON INPUT, X MUST CONTAIN THE POINT OF EVALUATION. -C ON OUTPUT, XP IS SET TO A NEIGHBORING POINT. -C -C MODE = 2. ON INPUT, FVEC MUST CONTAIN THE FUNCTIONS AND THE -C ROWS OF FJAC MUST CONTAIN THE GRADIENTS -C OF THE RESPECTIVE FUNCTIONS EACH EVALUATED -C AT X, AND FVECP MUST CONTAIN THE FUNCTIONS -C EVALUATED AT XP. -C ON OUTPUT, ERR CONTAINS MEASURES OF CORRECTNESS OF -C THE RESPECTIVE GRADIENTS. -C -C THE SUBROUTINE DOES NOT PERFORM RELIABLY IF CANCELLATION OR -C ROUNDING ERRORS CAUSE A SEVERE LOSS OF SIGNIFICANCE IN THE -C EVALUATION OF A FUNCTION. THEREFORE, NONE OF THE COMPONENTS -C OF X SHOULD BE UNUSUALLY SMALL (IN PARTICULAR, ZERO) OR ANY -C OTHER VALUE WHICH MAY CAUSE LOSS OF SIGNIFICANCE. -C -C THE SUBROUTINE STATEMENT IS -C -C SUBROUTINE CHKDER(M,N,X,FVEC,FJAC,LDFJAC,XP,FVECP,MODE,ERR) -C -C WHERE -C -C M IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER -C OF FUNCTIONS. -C -C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER -C OF VARIABLES. -C -C X IS AN INPUT ARRAY OF LENGTH N. -C -C FVEC IS AN ARRAY OF LENGTH M. ON INPUT WHEN MODE = 2, -C FVEC MUST CONTAIN THE FUNCTIONS EVALUATED AT X. -C -C FJAC IS AN M BY N ARRAY. ON INPUT WHEN MODE = 2, -C THE ROWS OF FJAC MUST CONTAIN THE GRADIENTS OF -C THE RESPECTIVE FUNCTIONS EVALUATED AT X. -C -C LDFJAC IS A POSITIVE INTEGER INPUT PARAMETER NOT LESS THAN M -C WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY FJAC. -C -C XP IS AN ARRAY OF LENGTH N. ON OUTPUT WHEN MODE = 1, -C XP IS SET TO A NEIGHBORING POINT OF X. -C -C FVECP IS AN ARRAY OF LENGTH M. ON INPUT WHEN MODE = 2, -C FVECP MUST CONTAIN THE FUNCTIONS EVALUATED AT XP. -C -C MODE IS AN INTEGER INPUT VARIABLE SET TO 1 ON THE FIRST CALL -C AND 2 ON THE SECOND. OTHER VALUES OF MODE ARE EQUIVALENT -C TO MODE = 1. -C -C ERR IS AN ARRAY OF LENGTH M. ON OUTPUT WHEN MODE = 2, -C ERR CONTAINS MEASURES OF CORRECTNESS OF THE RESPECTIVE -C GRADIENTS. IF THERE IS NO SEVERE LOSS OF SIGNIFICANCE, -C THEN IF ERR(I) IS 1.0 THE I-TH GRADIENT IS CORRECT, -C WHILE IF ERR(I) IS 0.0 THE I-TH GRADIENT IS INCORRECT. -C FOR VALUES OF ERR BETWEEN 0.0 AND 1.0, THE CATEGORIZATION -C IS LESS CERTAIN. IN GENERAL, A VALUE OF ERR(I) GREATER -C THAN 0.5 INDICATES THAT THE I-TH GRADIENT IS PROBABLY -C CORRECT, WHILE A VALUE OF ERR(I) LESS THAN 0.5 INDICATES -C THAT THE I-TH GRADIENT IS PROBABLY INCORRECT. -C -C SUBPROGRAMS CALLED -C -C MINPACK SUPPLIED ... SPMPAR -C -C FORTRAN SUPPLIED ... ABS,ALOG10,SQRT -C -C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. -C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE -C -C ********** - INTEGER I,J - REAL EPS,EPSF,EPSLOG,EPSMCH,FACTOR,ONE,TEMP,ZERO - REAL SPMPAR - DATA FACTOR,ONE,ZERO /1.0E2,1.0E0,0.0E0/ -C -C EPSMCH IS THE MACHINE PRECISION. -C - EPSMCH = SPMPAR(1) -C - EPS = SQRT(EPSMCH) -C - IF (MODE .EQ. 2) GO TO 20 -C -C MODE = 1. -C - DO 10 J = 1, N - TEMP = EPS*ABS(X(J)) - IF (TEMP .EQ. ZERO) TEMP = EPS - XP(J) = X(J) + TEMP - 10 CONTINUE - GO TO 70 - 20 CONTINUE -C -C MODE = 2. -C - EPSF = FACTOR*EPSMCH - EPSLOG = ALOG10(EPS) - DO 30 I = 1, M - ERR(I) = ZERO - 30 CONTINUE - DO 50 J = 1, N - TEMP = ABS(X(J)) - IF (TEMP .EQ. ZERO) TEMP = ONE - DO 40 I = 1, M - ERR(I) = ERR(I) + TEMP*FJAC(I,J) - 40 CONTINUE - 50 CONTINUE - DO 60 I = 1, M - TEMP = ONE - IF (FVEC(I) .NE. ZERO .AND. FVECP(I) .NE. ZERO - * .AND. ABS(FVECP(I)-FVEC(I)) .GE. EPSF*ABS(FVEC(I))) - * TEMP = EPS*ABS((FVECP(I)-FVEC(I))/EPS-ERR(I)) - * /(ABS(FVEC(I)) + ABS(FVECP(I))) - ERR(I) = ONE - IF (TEMP .GT. EPSMCH .AND. TEMP .LT. EPS) - * ERR(I) = (ALOG10(TEMP) - EPSLOG)/EPSLOG - IF (TEMP .GE. EPS) ERR(I) = ZERO - 60 CONTINUE - 70 CONTINUE -C - RETURN -C -C LAST CARD OF SUBROUTINE CHKDER. -C - END - SUBROUTINE DOGLEG(N,R,LR,DIAG,QTB,DELTA,X,WA1,WA2) - INTEGER N,LR - REAL DELTA - REAL R(LR),DIAG(N),QTB(N),X(N),WA1(N),WA2(N) -C ********** -C -C SUBROUTINE DOGLEG -C -C GIVEN AN M BY N MATRIX A, AN N BY N NONSINGULAR DIAGONAL -C MATRIX D, AN M-VECTOR B, AND A POSITIVE NUMBER DELTA, THE -C PROBLEM IS TO DETERMINE THE CONVEX COMBINATION X OF THE -C GAUSS-NEWTON AND SCALED GRADIENT DIRECTIONS THAT MINIMIZES -C (A*X - B) IN THE LEAST SQUARES SENSE, SUBJECT TO THE -C RESTRICTION THAT THE EUCLIDEAN NORM OF D*X BE AT MOST DELTA. -C -C THIS SUBROUTINE COMPLETES THE SOLUTION OF THE PROBLEM -C IF IT IS PROVIDED WITH THE NECESSARY INFORMATION FROM THE -C QR FACTORIZATION OF A. THAT IS, IF A = Q*R, WHERE Q HAS -C ORTHOGONAL COLUMNS AND R IS AN UPPER TRIANGULAR MATRIX, -C THEN DOGLEG EXPECTS THE FULL UPPER TRIANGLE OF R AND -C THE FIRST N COMPONENTS OF (Q TRANSPOSE)*B. -C -C THE SUBROUTINE STATEMENT IS -C -C SUBROUTINE DOGLEG(N,R,LR,DIAG,QTB,DELTA,X,WA1,WA2) -C -C WHERE -C -C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE ORDER OF R. -C -C R IS AN INPUT ARRAY OF LENGTH LR WHICH MUST CONTAIN THE UPPER -C TRIANGULAR MATRIX R STORED BY ROWS. -C -C LR IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN -C (N*(N+1))/2. -C -C DIAG IS AN INPUT ARRAY OF LENGTH N WHICH MUST CONTAIN THE -C DIAGONAL ELEMENTS OF THE MATRIX D. -C -C QTB IS AN INPUT ARRAY OF LENGTH N WHICH MUST CONTAIN THE FIRST -C N ELEMENTS OF THE VECTOR (Q TRANSPOSE)*B. -C -C DELTA IS A POSITIVE INPUT VARIABLE WHICH SPECIFIES AN UPPER -C BOUND ON THE EUCLIDEAN NORM OF D*X. -C -C X IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE DESIRED -C CONVEX COMBINATION OF THE GAUSS-NEWTON DIRECTION AND THE -C SCALED GRADIENT DIRECTION. -C -C WA1 AND WA2 ARE WORK ARRAYS OF LENGTH N. -C -C SUBPROGRAMS CALLED -C -C MINPACK-SUPPLIED ... SPMPAR,ENORM -C -C FORTRAN-SUPPLIED ... ABS,AMAX1,AMIN1,SQRT -C -C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. -C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE -C -C ********** - INTEGER I,J,JJ,JP1,K,L - REAL ALPHA,BNORM,EPSMCH,GNORM,ONE,QNORM,SGNORM,SUM,TEMP,ZERO - REAL SPMPAR,ENORM - DATA ONE,ZERO /1.0E0,0.0E0/ -C -C EPSMCH IS THE MACHINE PRECISION. -C - EPSMCH = SPMPAR(1) -C -C FIRST, CALCULATE THE GAUSS-NEWTON DIRECTION. -C - JJ = (N*(N + 1))/2 + 1 - DO 50 K = 1, N - J = N - K + 1 - JP1 = J + 1 - JJ = JJ - K - L = JJ + 1 - SUM = ZERO - IF (N .LT. JP1) GO TO 20 - DO 10 I = JP1, N - SUM = SUM + R(L)*X(I) - L = L + 1 - 10 CONTINUE - 20 CONTINUE - TEMP = R(JJ) - IF (TEMP .NE. ZERO) GO TO 40 - L = J - DO 30 I = 1, J - TEMP = AMAX1(TEMP,ABS(R(L))) - L = L + N - I - 30 CONTINUE - TEMP = EPSMCH*TEMP - IF (TEMP .EQ. ZERO) TEMP = EPSMCH - 40 CONTINUE - X(J) = (QTB(J) - SUM)/TEMP - 50 CONTINUE -C -C TEST WHETHER THE GAUSS-NEWTON DIRECTION IS ACCEPTABLE. -C - DO 60 J = 1, N - WA1(J) = ZERO - WA2(J) = DIAG(J)*X(J) - 60 CONTINUE - QNORM = ENORM(N,WA2) - IF (QNORM .LE. DELTA) GO TO 140 -C -C THE GAUSS-NEWTON DIRECTION IS NOT ACCEPTABLE. -C NEXT, CALCULATE THE SCALED GRADIENT DIRECTION. -C - L = 1 - DO 80 J = 1, N - TEMP = QTB(J) - DO 70 I = J, N - WA1(I) = WA1(I) + R(L)*TEMP - L = L + 1 - 70 CONTINUE - WA1(J) = WA1(J)/DIAG(J) - 80 CONTINUE -C -C CALCULATE THE NORM OF THE SCALED GRADIENT AND TEST FOR -C THE SPECIAL CASE IN WHICH THE SCALED GRADIENT IS ZERO. -C - GNORM = ENORM(N,WA1) - SGNORM = ZERO - ALPHA = DELTA/QNORM - IF (GNORM .EQ. ZERO) GO TO 120 -C -C CALCULATE THE POINT ALONG THE SCALED GRADIENT -C AT WHICH THE QUADRATIC IS MINIMIZED. -C - DO 90 J = 1, N - WA1(J) = (WA1(J)/GNORM)/DIAG(J) - 90 CONTINUE - L = 1 - DO 110 J = 1, N - SUM = ZERO - DO 100 I = J, N - SUM = SUM + R(L)*WA1(I) - L = L + 1 - 100 CONTINUE - WA2(J) = SUM - 110 CONTINUE - TEMP = ENORM(N,WA2) - SGNORM = (GNORM/TEMP)/TEMP -C -C TEST WHETHER THE SCALED GRADIENT DIRECTION IS ACCEPTABLE. -C - ALPHA = ZERO - IF (SGNORM .GE. DELTA) GO TO 120 -C -C THE SCALED GRADIENT DIRECTION IS NOT ACCEPTABLE. -C FINALLY, CALCULATE THE POINT ALONG THE DOGLEG -C AT WHICH THE QUADRATIC IS MINIMIZED. -C - BNORM = ENORM(N,QTB) - TEMP = (BNORM/GNORM)*(BNORM/QNORM)*(SGNORM/DELTA) - TEMP = TEMP - (DELTA/QNORM)*(SGNORM/DELTA)**2 - * + SQRT((TEMP-(DELTA/QNORM))**2 - * +(ONE-(DELTA/QNORM)**2)*(ONE-(SGNORM/DELTA)**2)) - ALPHA = ((DELTA/QNORM)*(ONE - (SGNORM/DELTA)**2))/TEMP - 120 CONTINUE -C -C FORM APPROPRIATE CONVEX COMBINATION OF THE GAUSS-NEWTON -C DIRECTION AND THE SCALED GRADIENT DIRECTION. -C - TEMP = (ONE - ALPHA)*AMIN1(SGNORM,DELTA) - DO 130 J = 1, N - X(J) = TEMP*WA1(J) + ALPHA*X(J) - 130 CONTINUE - 140 CONTINUE - RETURN -C -C LAST CARD OF SUBROUTINE DOGLEG. -C - END - REAL FUNCTION ENORM(N,X) - INTEGER N - REAL X(N) -C ********** -C -C FUNCTION ENORM -C -C GIVEN AN N-VECTOR X, THIS FUNCTION CALCULATES THE -C EUCLIDEAN NORM OF X. -C -C THE EUCLIDEAN NORM IS COMPUTED BY ACCUMULATING THE SUM OF -C SQUARES IN THREE DIFFERENT SUMS. THE SUMS OF SQUARES FOR THE -C SMALL AND LARGE COMPONENTS ARE SCALED SO THAT NO OVERFLOWS -C OCCUR. NON-DESTRUCTIVE UNDERFLOWS ARE PERMITTED. UNDERFLOWS -C AND OVERFLOWS DO NOT OCCUR IN THE COMPUTATION OF THE UNSCALED -C SUM OF SQUARES FOR THE INTERMEDIATE COMPONENTS. -C THE DEFINITIONS OF SMALL, INTERMEDIATE AND LARGE COMPONENTS -C DEPEND ON TWO CONSTANTS, RDWARF AND RGIANT. THE MAIN -C RESTRICTIONS ON THESE CONSTANTS ARE THAT RDWARF**2 NOT -C UNDERFLOW AND RGIANT**2 NOT OVERFLOW. THE CONSTANTS -C GIVEN HERE ARE SUITABLE FOR EVERY KNOWN COMPUTER. -C -C THE FUNCTION STATEMENT IS -C -C REAL FUNCTION ENORM(N,X) -C -C WHERE -C -C N IS A POSITIVE INTEGER INPUT VARIABLE. -C -C X IS AN INPUT ARRAY OF LENGTH N. -C -C SUBPROGRAMS CALLED -C -C FORTRAN-SUPPLIED ... ABS,SQRT -C -C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. -C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE -C -C ********** - INTEGER I - REAL AGIANT,FLOATN,ONE,RDWARF,RGIANT,S1,S2,S3,XABS,X1MAX,X3MAX, - * ZERO - DATA ONE,ZERO,RDWARF,RGIANT /1.0E0,0.0E0,3.834E-20,1.304E19/ - S1 = ZERO - S2 = ZERO - S3 = ZERO - X1MAX = ZERO - X3MAX = ZERO - FLOATN = N - AGIANT = RGIANT/FLOATN - DO 90 I = 1, N - XABS = ABS(X(I)) - IF (XABS .GT. RDWARF .AND. XABS .LT. AGIANT) GO TO 70 - IF (XABS .LE. RDWARF) GO TO 30 -C -C SUM FOR LARGE COMPONENTS. -C - IF (XABS .LE. X1MAX) GO TO 10 - S1 = ONE + S1*(X1MAX/XABS)**2 - X1MAX = XABS - GO TO 20 - 10 CONTINUE - S1 = S1 + (XABS/X1MAX)**2 - 20 CONTINUE - GO TO 60 - 30 CONTINUE -C -C SUM FOR SMALL COMPONENTS. -C - IF (XABS .LE. X3MAX) GO TO 40 - S3 = ONE + S3*(X3MAX/XABS)**2 - X3MAX = XABS - GO TO 50 - 40 CONTINUE - IF (XABS .NE. ZERO) S3 = S3 + (XABS/X3MAX)**2 - 50 CONTINUE - 60 CONTINUE - GO TO 80 - 70 CONTINUE -C -C SUM FOR INTERMEDIATE COMPONENTS. -C - S2 = S2 + XABS**2 - 80 CONTINUE - 90 CONTINUE -C -C CALCULATION OF NORM. -C - IF (S1 .EQ. ZERO) GO TO 100 - ENORM = X1MAX*SQRT(S1+(S2/X1MAX)/X1MAX) - GO TO 130 - 100 CONTINUE - IF (S2 .EQ. ZERO) GO TO 110 - IF (S2 .GE. X3MAX) - * ENORM = SQRT(S2*(ONE+(X3MAX/S2)*(X3MAX*S3))) - IF (S2 .LT. X3MAX) - * ENORM = SQRT(X3MAX*((S2/X3MAX)+(X3MAX*S3))) - GO TO 120 - 110 CONTINUE - ENORM = X3MAX*SQRT(S3) - 120 CONTINUE - 130 CONTINUE - RETURN -C -C LAST CARD OF FUNCTION ENORM. -C - END - SUBROUTINE FDJAC1(FCN,N,X,FVEC,FJAC,LDFJAC,IFLAG,ML,MU,EPSFCN, - * WA1,WA2) - INTEGER N,LDFJAC,IFLAG,ML,MU - REAL EPSFCN - REAL X(N),FVEC(N),FJAC(LDFJAC,N),WA1(N),WA2(N) -C ********** -C -C SUBROUTINE FDJAC1 -C -C THIS SUBROUTINE COMPUTES A FORWARD-DIFFERENCE APPROXIMATION -C TO THE N BY N JACOBIAN MATRIX ASSOCIATED WITH A SPECIFIED -C PROBLEM OF N FUNCTIONS IN N VARIABLES. IF THE JACOBIAN HAS -C A BANDED FORM, THEN FUNCTION EVALUATIONS ARE SAVED BY ONLY -C APPROXIMATING THE NONZERO TERMS. -C -C THE SUBROUTINE STATEMENT IS -C -C SUBROUTINE FDJAC1(FCN,N,X,FVEC,FJAC,LDFJAC,IFLAG,ML,MU,EPSFCN, -C WA1,WA2) -C -C WHERE -C -C FCN IS THE NAME OF THE USER-SUPPLIED SUBROUTINE WHICH -C CALCULATES THE FUNCTIONS. FCN MUST BE DECLARED -C IN AN EXTERNAL STATEMENT IN THE USER CALLING -C PROGRAM, AND SHOULD BE WRITTEN AS FOLLOWS. -C -C SUBROUTINE FCN(N,X,FVEC,IFLAG) -C INTEGER N,IFLAG -C REAL X(N),FVEC(N) -C ---------- -C CALCULATE THE FUNCTIONS AT X AND -C RETURN THIS VECTOR IN FVEC. -C ---------- -C RETURN -C END -C -C THE VALUE OF IFLAG SHOULD NOT BE CHANGED BY FCN UNLESS -C THE USER WANTS TO TERMINATE EXECUTION OF FDJAC1. -C IN THIS CASE SET IFLAG TO A NEGATIVE INTEGER. -C -C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER -C OF FUNCTIONS AND VARIABLES. -C -C X IS AN INPUT ARRAY OF LENGTH N. -C -C FVEC IS AN INPUT ARRAY OF LENGTH N WHICH MUST CONTAIN THE -C FUNCTIONS EVALUATED AT X. -C -C FJAC IS AN OUTPUT N BY N ARRAY WHICH CONTAINS THE -C APPROXIMATION TO THE JACOBIAN MATRIX EVALUATED AT X. -C -C LDFJAC IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN N -C WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY FJAC. -C -C IFLAG IS AN INTEGER VARIABLE WHICH CAN BE USED TO TERMINATE -C THE EXECUTION OF FDJAC1. SEE DESCRIPTION OF FCN. -C -C ML IS A NONNEGATIVE INTEGER INPUT VARIABLE WHICH SPECIFIES -C THE NUMBER OF SUBDIAGONALS WITHIN THE BAND OF THE -C JACOBIAN MATRIX. IF THE JACOBIAN IS NOT BANDED, SET -C ML TO AT LEAST N - 1. -C -C EPSFCN IS AN INPUT VARIABLE USED IN DETERMINING A SUITABLE -C STEP LENGTH FOR THE FORWARD-DIFFERENCE APPROXIMATION. THIS -C APPROXIMATION ASSUMES THAT THE RELATIVE ERRORS IN THE -C FUNCTIONS ARE OF THE ORDER OF EPSFCN. IF EPSFCN IS LESS -C THAN THE MACHINE PRECISION, IT IS ASSUMED THAT THE RELATIVE -C ERRORS IN THE FUNCTIONS ARE OF THE ORDER OF THE MACHINE -C PRECISION. -C -C MU IS A NONNEGATIVE INTEGER INPUT VARIABLE WHICH SPECIFIES -C THE NUMBER OF SUPERDIAGONALS WITHIN THE BAND OF THE -C JACOBIAN MATRIX. IF THE JACOBIAN IS NOT BANDED, SET -C MU TO AT LEAST N - 1. -C -C WA1 AND WA2 ARE WORK ARRAYS OF LENGTH N. IF ML + MU + 1 IS AT -C LEAST N, THEN THE JACOBIAN IS CONSIDERED DENSE, AND WA2 IS -C NOT REFERENCED. -C -C SUBPROGRAMS CALLED -C -C MINPACK-SUPPLIED ... SPMPAR -C -C FORTRAN-SUPPLIED ... ABS,AMAX1,SQRT -C -C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. -C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE -C -C ********** - INTEGER I,J,K,MSUM - REAL EPS,EPSMCH,H,TEMP,ZERO - REAL SPMPAR - DATA ZERO /0.0E0/ -C -C EPSMCH IS THE MACHINE PRECISION. -C - EPSMCH = SPMPAR(1) -C - EPS = SQRT(AMAX1(EPSFCN,EPSMCH)) - MSUM = ML + MU + 1 - IF (MSUM .LT. N) GO TO 40 -C -C COMPUTATION OF DENSE APPROXIMATE JACOBIAN. -C - DO 20 J = 1, N - TEMP = X(J) - H = EPS*ABS(TEMP) - IF (H .EQ. ZERO) H = EPS - X(J) = TEMP + H - CALL FCN(N,X,WA1,IFLAG) - IF (IFLAG .LT. 0) GO TO 30 - X(J) = TEMP - DO 10 I = 1, N - FJAC(I,J) = (WA1(I) - FVEC(I))/H - 10 CONTINUE - 20 CONTINUE - 30 CONTINUE - GO TO 110 - 40 CONTINUE -C -C COMPUTATION OF BANDED APPROXIMATE JACOBIAN. -C - DO 90 K = 1, MSUM - DO 60 J = K, N, MSUM - WA2(J) = X(J) - H = EPS*ABS(WA2(J)) - IF (H .EQ. ZERO) H = EPS - X(J) = WA2(J) + H - 60 CONTINUE - CALL FCN(N,X,WA1,IFLAG) - IF (IFLAG .LT. 0) GO TO 100 - DO 80 J = K, N, MSUM - X(J) = WA2(J) - H = EPS*ABS(WA2(J)) - IF (H .EQ. ZERO) H = EPS - DO 70 I = 1, N - FJAC(I,J) = ZERO - IF (I .GE. J - MU .AND. I .LE. J + ML) - * FJAC(I,J) = (WA1(I) - FVEC(I))/H - 70 CONTINUE - 80 CONTINUE - 90 CONTINUE - 100 CONTINUE - 110 CONTINUE - RETURN -C -C LAST CARD OF SUBROUTINE FDJAC1. -C - END - SUBROUTINE FDJAC2(FCN,M,N,X,FVEC,FJAC,LDFJAC,IFLAG,EPSFCN,WA) - INTEGER M,N,LDFJAC,IFLAG - REAL EPSFCN - REAL X(N),FVEC(M),FJAC(LDFJAC,N),WA(M) -C ********** -C -C SUBROUTINE FDJAC2 -C -C THIS SUBROUTINE COMPUTES A FORWARD-DIFFERENCE APPROXIMATION -C TO THE M BY N JACOBIAN MATRIX ASSOCIATED WITH A SPECIFIED -C PROBLEM OF M FUNCTIONS IN N VARIABLES. -C -C THE SUBROUTINE STATEMENT IS -C -C SUBROUTINE FDJAC2(FCN,M,N,X,FVEC,FJAC,LDFJAC,IFLAG,EPSFCN,WA) -C -C WHERE -C -C FCN IS THE NAME OF THE USER-SUPPLIED SUBROUTINE WHICH -C CALCULATES THE FUNCTIONS. FCN MUST BE DECLARED -C IN AN EXTERNAL STATEMENT IN THE USER CALLING -C PROGRAM, AND SHOULD BE WRITTEN AS FOLLOWS. -C -C SUBROUTINE FCN(M,N,X,FVEC,IFLAG) -C INTEGER M,N,IFLAG -C REAL X(N),FVEC(M) -C ---------- -C CALCULATE THE FUNCTIONS AT X AND -C RETURN THIS VECTOR IN FVEC. -C ---------- -C RETURN -C END -C -C THE VALUE OF IFLAG SHOULD NOT BE CHANGED BY FCN UNLESS -C THE USER WANTS TO TERMINATE EXECUTION OF FDJAC2. -C IN THIS CASE SET IFLAG TO A NEGATIVE INTEGER. -C -C M IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER -C OF FUNCTIONS. -C -C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER -C OF VARIABLES. N MUST NOT EXCEED M. -C -C X IS AN INPUT ARRAY OF LENGTH N. -C -C FVEC IS AN INPUT ARRAY OF LENGTH M WHICH MUST CONTAIN THE -C FUNCTIONS EVALUATED AT X. -C -C FJAC IS AN OUTPUT M BY N ARRAY WHICH CONTAINS THE -C APPROXIMATION TO THE JACOBIAN MATRIX EVALUATED AT X. -C -C LDFJAC IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN M -C WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY FJAC. -C -C IFLAG IS AN INTEGER VARIABLE WHICH CAN BE USED TO TERMINATE -C THE EXECUTION OF FDJAC2. SEE DESCRIPTION OF FCN. -C -C EPSFCN IS AN INPUT VARIABLE USED IN DETERMINING A SUITABLE -C STEP LENGTH FOR THE FORWARD-DIFFERENCE APPROXIMATION. THIS -C APPROXIMATION ASSUMES THAT THE RELATIVE ERRORS IN THE -C FUNCTIONS ARE OF THE ORDER OF EPSFCN. IF EPSFCN IS LESS -C THAN THE MACHINE PRECISION, IT IS ASSUMED THAT THE RELATIVE -C ERRORS IN THE FUNCTIONS ARE OF THE ORDER OF THE MACHINE -C PRECISION. -C -C WA IS A WORK ARRAY OF LENGTH M. -C -C SUBPROGRAMS CALLED -C -C USER-SUPPLIED ...... FCN -C -C MINPACK-SUPPLIED ... SPMPAR -C -C FORTRAN-SUPPLIED ... ABS,AMAX1,SQRT -C -C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. -C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE -C -C ********** - INTEGER I,J - REAL EPS,EPSMCH,H,TEMP,ZERO - REAL SPMPAR - DATA ZERO /0.0E0/ -C -C EPSMCH IS THE MACHINE PRECISION. -C - EPSMCH = SPMPAR(1) -C - EPS = SQRT(AMAX1(EPSFCN,EPSMCH)) - DO 20 J = 1, N - TEMP = X(J) - H = EPS*ABS(TEMP) - IF (H .EQ. ZERO) H = EPS - X(J) = TEMP + H - CALL FCN(M,N,X,WA,IFLAG) - IF (IFLAG .LT. 0) GO TO 30 - X(J) = TEMP - DO 10 I = 1, M - FJAC(I,J) = (WA(I) - FVEC(I))/H - 10 CONTINUE - 20 CONTINUE - 30 CONTINUE - RETURN -C -C LAST CARD OF SUBROUTINE FDJAC2. -C - END - SUBROUTINE HYBRD(FCN,N,X,FVEC,XTOL,MAXFEV,ML,MU,EPSFCN,DIAG, - * MODE,FACTOR,NPRINT,INFO,NFEV,FJAC,LDFJAC,R,LR, - * QTF,WA1,WA2,WA3,WA4) - INTEGER N,MAXFEV,ML,MU,MODE,NPRINT,INFO,NFEV,LDFJAC,LR - REAL XTOL,EPSFCN,FACTOR - REAL X(N),FVEC(N),DIAG(N),FJAC(LDFJAC,N),R(LR),QTF(N),WA1(N), - * WA2(N),WA3(N),WA4(N) - EXTERNAL FCN -C ********** -C -C SUBROUTINE HYBRD -C -C THE PURPOSE OF HYBRD IS TO FIND A ZERO OF A SYSTEM OF -C N NONLINEAR FUNCTIONS IN N VARIABLES BY A MODIFICATION -C OF THE POWELL HYBRID METHOD. THE USER MUST PROVIDE A -C SUBROUTINE WHICH CALCULATES THE FUNCTIONS. THE JACOBIAN IS -C THEN CALCULATED BY A FORWARD-DIFFERENCE APPROXIMATION. -C -C THE SUBROUTINE STATEMENT IS -C -C SUBROUTINE HYBRD(FCN,N,X,FVEC,XTOL,MAXFEV,ML,MU,EPSFCN, -C DIAG,MODE,FACTOR,NPRINT,INFO,NFEV,FJAC, -C LDFJAC,R,LR,QTF,WA1,WA2,WA3,WA4) -C -C WHERE -C -C FCN IS THE NAME OF THE USER-SUPPLIED SUBROUTINE WHICH -C CALCULATES THE FUNCTIONS. FCN MUST BE DECLARED -C IN AN EXTERNAL STATEMENT IN THE USER CALLING -C PROGRAM, AND SHOULD BE WRITTEN AS FOLLOWS. -C -C SUBROUTINE FCN(N,X,FVEC,IFLAG) -C INTEGER N,IFLAG -C REAL X(N),FVEC(N) -C ---------- -C CALCULATE THE FUNCTIONS AT X AND -C RETURN THIS VECTOR IN FVEC. -C --------- -C RETURN -C END -C -C THE VALUE OF IFLAG SHOULD NOT BE CHANGED BY FCN UNLESS -C THE USER WANTS TO TERMINATE EXECUTION OF HYBRD. -C IN THIS CASE SET IFLAG TO A NEGATIVE INTEGER. -C -C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER -C OF FUNCTIONS AND VARIABLES. -C -C X IS AN ARRAY OF LENGTH N. ON INPUT X MUST CONTAIN -C AN INITIAL ESTIMATE OF THE SOLUTION VECTOR. ON OUTPUT X -C CONTAINS THE FINAL ESTIMATE OF THE SOLUTION VECTOR. -C -C FVEC IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS -C THE FUNCTIONS EVALUATED AT THE OUTPUT X. -C -C XTOL IS A NONNEGATIVE INPUT VARIABLE. TERMINATION -C OCCURS WHEN THE RELATIVE ERROR BETWEEN TWO CONSECUTIVE -C ITERATES IS AT MOST XTOL. -C -C MAXFEV IS A POSITIVE INTEGER INPUT VARIABLE. TERMINATION -C OCCURS WHEN THE NUMBER OF CALLS TO FCN IS AT LEAST MAXFEV -C BY THE END OF AN ITERATION. -C -C ML IS A NONNEGATIVE INTEGER INPUT VARIABLE WHICH SPECIFIES -C THE NUMBER OF SUBDIAGONALS WITHIN THE BAND OF THE -C JACOBIAN MATRIX. IF THE JACOBIAN IS NOT BANDED, SET -C ML TO AT LEAST N - 1. -C -C MU IS A NONNEGATIVE INTEGER INPUT VARIABLE WHICH SPECIFIES -C THE NUMBER OF SUPERDIAGONALS WITHIN THE BAND OF THE -C JACOBIAN MATRIX. IF THE JACOBIAN IS NOT BANDED, SET -C MU TO AT LEAST N - 1. -C -C EPSFCN IS AN INPUT VARIABLE USED IN DETERMINING A SUITABLE -C STEP LENGTH FOR THE FORWARD-DIFFERENCE APPROXIMATION. THIS -C APPROXIMATION ASSUMES THAT THE RELATIVE ERRORS IN THE -C FUNCTIONS ARE OF THE ORDER OF EPSFCN. IF EPSFCN IS LESS -C THAN THE MACHINE PRECISION, IT IS ASSUMED THAT THE RELATIVE -C ERRORS IN THE FUNCTIONS ARE OF THE ORDER OF THE MACHINE -C PRECISION. -C -C DIAG IS AN ARRAY OF LENGTH N. IF MODE = 1 (SEE -C BELOW), DIAG IS INTERNALLY SET. IF MODE = 2, DIAG -C MUST CONTAIN POSITIVE ENTRIES THAT SERVE AS -C MULTIPLICATIVE SCALE FACTORS FOR THE VARIABLES. -C -C MODE IS AN INTEGER INPUT VARIABLE. IF MODE = 1, THE -C VARIABLES WILL BE SCALED INTERNALLY. IF MODE = 2, -C THE SCALING IS SPECIFIED BY THE INPUT DIAG. OTHER -C VALUES OF MODE ARE EQUIVALENT TO MODE = 1. -C -C FACTOR IS A POSITIVE INPUT VARIABLE USED IN DETERMINING THE -C INITIAL STEP BOUND. THIS BOUND IS SET TO THE PRODUCT OF -C FACTOR AND THE EUCLIDEAN NORM OF DIAG*X IF NONZERO, OR ELSE -C TO FACTOR ITSELF. IN MOST CASES FACTOR SHOULD LIE IN THE -C INTERVAL (.1,100.). 100. IS A GENERALLY RECOMMENDED VALUE. -C -C NPRINT IS AN INTEGER INPUT VARIABLE THAT ENABLES CONTROLLED -C PRINTING OF ITERATES IF IT IS POSITIVE. IN THIS CASE, -C FCN IS CALLED WITH IFLAG = 0 AT THE BEGINNING OF THE FIRST -C ITERATION AND EVERY NPRINT ITERATIONS THEREAFTER AND -C IMMEDIATELY PRIOR TO RETURN, WITH X AND FVEC AVAILABLE -C FOR PRINTING. IF NPRINT IS NOT POSITIVE, NO SPECIAL CALLS -C OF FCN WITH IFLAG = 0 ARE MADE. -C -C INFO IS AN INTEGER OUTPUT VARIABLE. IF THE USER HAS -C TERMINATED EXECUTION, INFO IS SET TO THE (NEGATIVE) -C VALUE OF IFLAG. SEE DESCRIPTION OF FCN. OTHERWISE, -C INFO IS SET AS FOLLOWS. -C -C INFO = 0 IMPROPER INPUT PARAMETERS. -C -C INFO = 1 RELATIVE ERROR BETWEEN TWO CONSECUTIVE ITERATES -C IS AT MOST XTOL. -C -C INFO = 2 NUMBER OF CALLS TO FCN HAS REACHED OR EXCEEDED -C MAXFEV. -C -C INFO = 3 XTOL IS TOO SMALL. NO FURTHER IMPROVEMENT IN -C THE APPROXIMATE SOLUTION X IS POSSIBLE. -C -C INFO = 4 ITERATION IS NOT MAKING GOOD PROGRESS, AS -C MEASURED BY THE IMPROVEMENT FROM THE LAST -C FIVE JACOBIAN EVALUATIONS. -C -C INFO = 5 ITERATION IS NOT MAKING GOOD PROGRESS, AS -C MEASURED BY THE IMPROVEMENT FROM THE LAST -C TEN ITERATIONS. -C -C NFEV IS AN INTEGER OUTPUT VARIABLE SET TO THE NUMBER OF -C CALLS TO FCN. -C -C FJAC IS AN OUTPUT N BY N ARRAY WHICH CONTAINS THE -C ORTHOGONAL MATRIX Q PRODUCED BY THE QR FACTORIZATION -C OF THE FINAL APPROXIMATE JACOBIAN. -C -C LDFJAC IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN N -C WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY FJAC. -C -C R IS AN OUTPUT ARRAY OF LENGTH LR WHICH CONTAINS THE -C UPPER TRIANGULAR MATRIX PRODUCED BY THE QR FACTORIZATION -C OF THE FINAL APPROXIMATE JACOBIAN, STORED ROWWISE. -C -C LR IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN -C (N*(N+1))/2. -C -C QTF IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS -C THE VECTOR (Q TRANSPOSE)*FVEC. -C -C WA1, WA2, WA3, AND WA4 ARE WORK ARRAYS OF LENGTH N. -C -C SUBPROGRAMS CALLED -C -C USER-SUPPLIED ...... FCN -C -C MINPACK-SUPPLIED ... DOGLEG,SPMPAR,ENORM,FDJAC1, -C QFORM,QRFAC,R1MPYQ,R1UPDT -C -C FORTRAN-SUPPLIED ... ABS,AMAX1,AMIN1,MIN0,MOD -C -C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. -C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE -C -C ********** - INTEGER I,IFLAG,ITER,J,JM1,L,MSUM,NCFAIL,NCSUC,NSLOW1,NSLOW2 - INTEGER IWA(1) - LOGICAL JEVAL,SING - REAL ACTRED,DELTA,EPSMCH,FNORM,FNORM1,ONE,PNORM,PRERED,P1,P5, - * P001,P0001,RATIO,SUM,TEMP,XNORM,ZERO - REAL SPMPAR,ENORM - DATA ONE,P1,P5,P001,P0001,ZERO - * /1.0E0,1.0E-1,5.0E-1,1.0E-3,1.0E-4,0.0E0/ -C -C EPSMCH IS THE MACHINE PRECISION. -C - EPSMCH = SPMPAR(1) -C - INFO = 0 - IFLAG = 0 - NFEV = 0 -C -C CHECK THE INPUT PARAMETERS FOR ERRORS. -C - IF (N .LE. 0 .OR. XTOL .LT. ZERO .OR. MAXFEV .LE. 0 - * .OR. ML .LT. 0 .OR. MU .LT. 0 .OR. FACTOR .LE. ZERO - * .OR. LDFJAC .LT. N .OR. LR .LT. (N*(N + 1))/2) GO TO 300 - IF (MODE .NE. 2) GO TO 20 - DO 10 J = 1, N - IF (DIAG(J) .LE. ZERO) GO TO 300 - 10 CONTINUE - 20 CONTINUE -C -C EVALUATE THE FUNCTION AT THE STARTING POINT -C AND CALCULATE ITS NORM. -C - IFLAG = 1 - CALL FCN(N,X,FVEC,IFLAG) - NFEV = 1 - IF (IFLAG .LT. 0) GO TO 300 - FNORM = ENORM(N,FVEC) -C -C DETERMINE THE NUMBER OF CALLS TO FCN NEEDED TO COMPUTE -C THE JACOBIAN MATRIX. -C - MSUM = MIN0(ML+MU+1,N) -C -C INITIALIZE ITERATION COUNTER AND MONITORS. -C - ITER = 1 - NCSUC = 0 - NCFAIL = 0 - NSLOW1 = 0 - NSLOW2 = 0 -C -C BEGINNING OF THE OUTER LOOP. -C - 30 CONTINUE - JEVAL = .TRUE. -C -C CALCULATE THE JACOBIAN MATRIX. -C - IFLAG = 2 - CALL FDJAC1(FCN,N,X,FVEC,FJAC,LDFJAC,IFLAG,ML,MU,EPSFCN,WA1, - * WA2) - NFEV = NFEV + MSUM - IF (IFLAG .LT. 0) GO TO 300 -C -C COMPUTE THE QR FACTORIZATION OF THE JACOBIAN. -C - CALL QRFAC(N,N,FJAC,LDFJAC,.FALSE.,IWA,1,WA1,WA2,WA3) -C -C ON THE FIRST ITERATION AND IF MODE IS 1, SCALE ACCORDING -C TO THE NORMS OF THE COLUMNS OF THE INITIAL JACOBIAN. -C - IF (ITER .NE. 1) GO TO 70 - IF (MODE .EQ. 2) GO TO 50 - DO 40 J = 1, N - DIAG(J) = WA2(J) - IF (WA2(J) .EQ. ZERO) DIAG(J) = ONE - 40 CONTINUE - 50 CONTINUE -C -C ON THE FIRST ITERATION, CALCULATE THE NORM OF THE SCALED X -C AND INITIALIZE THE STEP BOUND DELTA. -C - DO 60 J = 1, N - WA3(J) = DIAG(J)*X(J) - 60 CONTINUE - XNORM = ENORM(N,WA3) - DELTA = FACTOR*XNORM - IF (DELTA .EQ. ZERO) DELTA = FACTOR - 70 CONTINUE -C -C FORM (Q TRANSPOSE)*FVEC AND STORE IN QTF. -C - DO 80 I = 1, N - QTF(I) = FVEC(I) - 80 CONTINUE - DO 120 J = 1, N - IF (FJAC(J,J) .EQ. ZERO) GO TO 110 - SUM = ZERO - DO 90 I = J, N - SUM = SUM + FJAC(I,J)*QTF(I) - 90 CONTINUE - TEMP = -SUM/FJAC(J,J) - DO 100 I = J, N - QTF(I) = QTF(I) + FJAC(I,J)*TEMP - 100 CONTINUE - 110 CONTINUE - 120 CONTINUE -C -C COPY THE TRIANGULAR FACTOR OF THE QR FACTORIZATION INTO R. -C - SING = .FALSE. - DO 150 J = 1, N - L = J - JM1 = J - 1 - IF (JM1 .LT. 1) GO TO 140 - DO 130 I = 1, JM1 - R(L) = FJAC(I,J) - L = L + N - I - 130 CONTINUE - 140 CONTINUE - R(L) = WA1(J) - IF (WA1(J) .EQ. ZERO) SING = .TRUE. - 150 CONTINUE -C -C ACCUMULATE THE ORTHOGONAL FACTOR IN FJAC. -C - CALL QFORM(N,N,FJAC,LDFJAC,WA1) -C -C RESCALE IF NECESSARY. -C - IF (MODE .EQ. 2) GO TO 170 - DO 160 J = 1, N - DIAG(J) = AMAX1(DIAG(J),WA2(J)) - 160 CONTINUE - 170 CONTINUE -C -C BEGINNING OF THE INNER LOOP. -C - 180 CONTINUE -C -C IF REQUESTED, CALL FCN TO ENABLE PRINTING OF ITERATES. -C - IF (NPRINT .LE. 0) GO TO 190 - IFLAG = 0 - IF (MOD(ITER-1,NPRINT) .EQ. 0) CALL FCN(N,X,FVEC,IFLAG) - IF (IFLAG .LT. 0) GO TO 300 - 190 CONTINUE -C -C DETERMINE THE DIRECTION P. -C - CALL DOGLEG(N,R,LR,DIAG,QTF,DELTA,WA1,WA2,WA3) -C -C STORE THE DIRECTION P AND X + P. CALCULATE THE NORM OF P. -C - DO 200 J = 1, N - WA1(J) = -WA1(J) - WA2(J) = X(J) + WA1(J) - WA3(J) = DIAG(J)*WA1(J) - 200 CONTINUE - PNORM = ENORM(N,WA3) -C -C ON THE FIRST ITERATION, ADJUST THE INITIAL STEP BOUND. -C - IF (ITER .EQ. 1) DELTA = AMIN1(DELTA,PNORM) -C -C EVALUATE THE FUNCTION AT X + P AND CALCULATE ITS NORM. -C - IFLAG = 1 - CALL FCN(N,WA2,WA4,IFLAG) - NFEV = NFEV + 1 - IF (IFLAG .LT. 0) GO TO 300 - FNORM1 = ENORM(N,WA4) -C -C COMPUTE THE SCALED ACTUAL REDUCTION. -C - ACTRED = -ONE - IF (FNORM1 .LT. FNORM) ACTRED = ONE - (FNORM1/FNORM)**2 -C -C COMPUTE THE SCALED PREDICTED REDUCTION. -C - L = 1 - DO 220 I = 1, N - SUM = ZERO - DO 210 J = I, N - SUM = SUM + R(L)*WA1(J) - L = L + 1 - 210 CONTINUE - WA3(I) = QTF(I) + SUM - 220 CONTINUE - TEMP = ENORM(N,WA3) - PRERED = ZERO - IF (TEMP .LT. FNORM) PRERED = ONE - (TEMP/FNORM)**2 -C -C COMPUTE THE RATIO OF THE ACTUAL TO THE PREDICTED -C REDUCTION. -C - RATIO = ZERO - IF (PRERED .GT. ZERO) RATIO = ACTRED/PRERED -C -C UPDATE THE STEP BOUND. -C - IF (RATIO .GE. P1) GO TO 230 - NCSUC = 0 - NCFAIL = NCFAIL + 1 - DELTA = P5*DELTA - GO TO 240 - 230 CONTINUE - NCFAIL = 0 - NCSUC = NCSUC + 1 - IF (RATIO .GE. P5 .OR. NCSUC .GT. 1) - * DELTA = AMAX1(DELTA,PNORM/P5) - IF (ABS(RATIO-ONE) .LE. P1) DELTA = PNORM/P5 - 240 CONTINUE -C -C TEST FOR SUCCESSFUL ITERATION. -C - IF (RATIO .LT. P0001) GO TO 260 -C -C SUCCESSFUL ITERATION. UPDATE X, FVEC, AND THEIR NORMS. -C - DO 250 J = 1, N - X(J) = WA2(J) - WA2(J) = DIAG(J)*X(J) - FVEC(J) = WA4(J) - 250 CONTINUE - XNORM = ENORM(N,WA2) - FNORM = FNORM1 - ITER = ITER + 1 - 260 CONTINUE -C -C DETERMINE THE PROGRESS OF THE ITERATION. -C - NSLOW1 = NSLOW1 + 1 - IF (ACTRED .GE. P001) NSLOW1 = 0 - IF (JEVAL) NSLOW2 = NSLOW2 + 1 - IF (ACTRED .GE. P1) NSLOW2 = 0 -C -C TEST FOR CONVERGENCE. -C - IF (DELTA .LE. XTOL*XNORM .OR. FNORM .EQ. ZERO) INFO = 1 - IF (INFO .NE. 0) GO TO 300 -C -C TESTS FOR TERMINATION AND STRINGENT TOLERANCES. -C - IF (NFEV .GE. MAXFEV) INFO = 2 - IF (P1*AMAX1(P1*DELTA,PNORM) .LE. EPSMCH*XNORM) INFO = 3 - IF (NSLOW2 .EQ. 5) INFO = 4 - IF (NSLOW1 .EQ. 10) INFO = 5 - IF (INFO .NE. 0) GO TO 300 -C -C CRITERION FOR RECALCULATING JACOBIAN APPROXIMATION -C BY FORWARD DIFFERENCES. -C - IF (NCFAIL .EQ. 2) GO TO 290 -C -C CALCULATE THE RANK ONE MODIFICATION TO THE JACOBIAN -C AND UPDATE QTF IF NECESSARY. -C - DO 280 J = 1, N - SUM = ZERO - DO 270 I = 1, N - SUM = SUM + FJAC(I,J)*WA4(I) - 270 CONTINUE - WA2(J) = (SUM - WA3(J))/PNORM - WA1(J) = DIAG(J)*((DIAG(J)*WA1(J))/PNORM) - IF (RATIO .GE. P0001) QTF(J) = SUM - 280 CONTINUE -C -C COMPUTE THE QR FACTORIZATION OF THE UPDATED JACOBIAN. -C - CALL R1UPDT(N,N,R,LR,WA1,WA2,WA3,SING) - CALL R1MPYQ(N,N,FJAC,LDFJAC,WA2,WA3) - CALL R1MPYQ(1,N,QTF,1,WA2,WA3) -C -C END OF THE INNER LOOP. -C - JEVAL = .FALSE. - GO TO 180 - 290 CONTINUE -C -C END OF THE OUTER LOOP. -C - GO TO 30 - 300 CONTINUE -C -C TERMINATION, EITHER NORMAL OR USER IMPOSED. -C - IF (IFLAG .LT. 0) INFO = IFLAG - IFLAG = 0 - IF (NPRINT .GT. 0) CALL FCN(N,X,FVEC,IFLAG) - RETURN -C -C LAST CARD OF SUBROUTINE HYBRD. -C - END - SUBROUTINE HYBRD1(FCN,N,X,FVEC,TOL,INFO,WA,LWA) - INTEGER N,INFO,LWA - REAL TOL - REAL X(N),FVEC(N),WA(LWA) - EXTERNAL FCN -C ********** -C -C SUBROUTINE HYBRD1 -C -C THE PURPOSE OF HYBRD1 IS TO FIND A ZERO OF A SYSTEM OF -C N NONLINEAR FUNCTIONS IN N VARIABLES BY A MODIFICATION -C OF THE POWELL HYBRID METHOD. THIS IS DONE BY USING THE -C MORE GENERAL NONLINEAR EQUATION SOLVER HYBRD. THE USER -C MUST PROVIDE A SUBROUTINE WHICH CALCULATES THE FUNCTIONS. -C THE JACOBIAN IS THEN CALCULATED BY A FORWARD-DIFFERENCE -C APPROXIMATION. -C -C THE SUBROUTINE STATEMENT IS -C -C SUBROUTINE HYBRD1(FCN,N,X,FVEC,TOL,INFO,WA,LWA) -C -C WHERE -C -C FCN IS THE NAME OF THE USER-SUPPLIED SUBROUTINE WHICH -C CALCULATES THE FUNCTIONS. FCN MUST BE DECLARED -C IN AN EXTERNAL STATEMENT IN THE USER CALLING -C PROGRAM, AND SHOULD BE WRITTEN AS FOLLOWS. -C -C SUBROUTINE FCN(N,X,FVEC,IFLAG) -C INTEGER N,IFLAG -C REAL X(N),FVEC(N) -C ---------- -C CALCULATE THE FUNCTIONS AT X AND -C RETURN THIS VECTOR IN FVEC. -C --------- -C RETURN -C END -C -C THE VALUE OF IFLAG SHOULD NOT BE CHANGED BY FCN UNLESS -C THE USER WANTS TO TERMINATE EXECUTION OF HYBRD1. -C IN THIS CASE SET IFLAG TO A NEGATIVE INTEGER. -C -C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER -C OF FUNCTIONS AND VARIABLES. -C -C X IS AN ARRAY OF LENGTH N. ON INPUT X MUST CONTAIN -C AN INITIAL ESTIMATE OF THE SOLUTION VECTOR. ON OUTPUT X -C CONTAINS THE FINAL ESTIMATE OF THE SOLUTION VECTOR. -C -C FVEC IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS -C THE FUNCTIONS EVALUATED AT THE OUTPUT X. -C -C TOL IS A NONNEGATIVE INPUT VARIABLE. TERMINATION OCCURS -C WHEN THE ALGORITHM ESTIMATES THAT THE RELATIVE ERROR -C BETWEEN X AND THE SOLUTION IS AT MOST TOL. -C -C INFO IS AN INTEGER OUTPUT VARIABLE. IF THE USER HAS -C TERMINATED EXECUTION, INFO IS SET TO THE (NEGATIVE) -C VALUE OF IFLAG. SEE DESCRIPTION OF FCN. OTHERWISE, -C INFO IS SET AS FOLLOWS. -C -C INFO = 0 IMPROPER INPUT PARAMETERS. -C -C INFO = 1 ALGORITHM ESTIMATES THAT THE RELATIVE ERROR -C BETWEEN X AND THE SOLUTION IS AT MOST TOL. -C -C INFO = 2 NUMBER OF CALLS TO FCN HAS REACHED OR EXCEEDED -C 200*(N+1). -C -C INFO = 3 TOL IS TOO SMALL. NO FURTHER IMPROVEMENT IN -C THE APPROXIMATE SOLUTION X IS POSSIBLE. -C -C INFO = 4 ITERATION IS NOT MAKING GOOD PROGRESS. -C -C WA IS A WORK ARRAY OF LENGTH LWA. -C -C LWA IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN -C (N*(3*N+13))/2. -C -C SUBPROGRAMS CALLED -C -C USER-SUPPLIED ...... FCN -C -C MINPACK-SUPPLIED ... HYBRD -C -C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. -C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE -C -C ********** - INTEGER INDEX,J,LR,MAXFEV,ML,MODE,MU,NFEV,NPRINT - REAL EPSFCN,FACTOR,ONE,XTOL,ZERO - DATA FACTOR,ONE,ZERO /1.0E2,1.0E0,0.0E0/ - INFO = 0 -C -C CHECK THE INPUT PARAMETERS FOR ERRORS. -C - IF (N .LE. 0 .OR. TOL .LT. ZERO .OR. LWA .LT. (N*(3*N + 13))/2) - * GO TO 20 -C -C CALL HYBRD. -C - MAXFEV = 200*(N + 1) - XTOL = TOL - ML = N - 1 - MU = N - 1 - EPSFCN = ZERO - MODE = 2 - DO 10 J = 1, N - WA(J) = ONE - 10 CONTINUE - NPRINT = 0 - LR = (N*(N + 1))/2 - INDEX = 6*N + LR - CALL HYBRD(FCN,N,X,FVEC,XTOL,MAXFEV,ML,MU,EPSFCN,WA(1),MODE, - * FACTOR,NPRINT,INFO,NFEV,WA(INDEX+1),N,WA(6*N+1),LR, - * WA(N+1),WA(2*N+1),WA(3*N+1),WA(4*N+1),WA(5*N+1)) - IF (INFO .EQ. 5) INFO = 4 - 20 CONTINUE - RETURN -C -C LAST CARD OF SUBROUTINE HYBRD1. -C - END - SUBROUTINE HYBRJ(FCN,N,X,FVEC,FJAC,LDFJAC,XTOL,MAXFEV,DIAG,MODE, - * FACTOR,NPRINT,INFO,NFEV,NJEV,R,LR,QTF,WA1,WA2, - * WA3,WA4) - INTEGER N,LDFJAC,MAXFEV,MODE,NPRINT,INFO,NFEV,NJEV,LR - REAL XTOL,FACTOR - REAL X(N),FVEC(N),FJAC(LDFJAC,N),DIAG(N),R(LR),QTF(N),WA1(N), - * WA2(N),WA3(N),WA4(N) -C ********** -C -C SUBROUTINE HYBRJ -C -C THE PURPOSE OF HYBRJ IS TO FIND A ZERO OF A SYSTEM OF -C N NONLINEAR FUNCTIONS IN N VARIABLES BY A MODIFICATION -C OF THE POWELL HYBRID METHOD. THE USER MUST PROVIDE A -C SUBROUTINE WHICH CALCULATES THE FUNCTIONS AND THE JACOBIAN. -C -C THE SUBROUTINE STATEMENT IS -C -C SUBROUTINE HYBRJ(FCN,N,X,FVEC,FJAC,LDFJAC,XTOL,MAXFEV,DIAG, -C MODE,FACTOR,NPRINT,INFO,NFEV,NJEV,R,LR,QTF, -C WA1,WA2,WA3,WA4) -C -C WHERE -C -C FCN IS THE NAME OF THE USER-SUPPLIED SUBROUTINE WHICH -C CALCULATES THE FUNCTIONS AND THE JACOBIAN. FCN MUST -C BE DECLARED IN AN EXTERNAL STATEMENT IN THE USER -C CALLING PROGRAM, AND SHOULD BE WRITTEN AS FOLLOWS. -C -C SUBROUTINE FCN(N,X,FVEC,FJAC,LDFJAC,IFLAG) -C INTEGER N,LDFJAC,IFLAG -C REAL X(N),FVEC(N),FJAC(LDFJAC,N) -C ---------- -C IF IFLAG = 1 CALCULATE THE FUNCTIONS AT X AND -C RETURN THIS VECTOR IN FVEC. DO NOT ALTER FJAC. -C IF IFLAG = 2 CALCULATE THE JACOBIAN AT X AND -C RETURN THIS MATRIX IN FJAC. DO NOT ALTER FVEC. -C --------- -C RETURN -C END -C -C THE VALUE OF IFLAG SHOULD NOT BE CHANGED BY FCN UNLESS -C THE USER WANTS TO TERMINATE EXECUTION OF HYBRJ. -C IN THIS CASE SET IFLAG TO A NEGATIVE INTEGER. -C -C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER -C OF FUNCTIONS AND VARIABLES. -C -C X IS AN ARRAY OF LENGTH N. ON INPUT X MUST CONTAIN -C AN INITIAL ESTIMATE OF THE SOLUTION VECTOR. ON OUTPUT X -C CONTAINS THE FINAL ESTIMATE OF THE SOLUTION VECTOR. -C -C FVEC IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS -C THE FUNCTIONS EVALUATED AT THE OUTPUT X. -C -C FJAC IS AN OUTPUT N BY N ARRAY WHICH CONTAINS THE -C ORTHOGONAL MATRIX Q PRODUCED BY THE QR FACTORIZATION -C OF THE FINAL APPROXIMATE JACOBIAN. -C -C LDFJAC IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN N -C WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY FJAC. -C -C XTOL IS A NONNEGATIVE INPUT VARIABLE. TERMINATION -C OCCURS WHEN THE RELATIVE ERROR BETWEEN TWO CONSECUTIVE -C ITERATES IS AT MOST XTOL. -C -C MAXFEV IS A POSITIVE INTEGER INPUT VARIABLE. TERMINATION -C OCCURS WHEN THE NUMBER OF CALLS TO FCN WITH IFLAG = 1 -C HAS REACHED MAXFEV. -C -C DIAG IS AN ARRAY OF LENGTH N. IF MODE = 1 (SEE -C BELOW), DIAG IS INTERNALLY SET. IF MODE = 2, DIAG -C MUST CONTAIN POSITIVE ENTRIES THAT SERVE AS -C MULTIPLICATIVE SCALE FACTORS FOR THE VARIABLES. -C -C MODE IS AN INTEGER INPUT VARIABLE. IF MODE = 1, THE -C VARIABLES WILL BE SCALED INTERNALLY. IF MODE = 2, -C THE SCALING IS SPECIFIED BY THE INPUT DIAG. OTHER -C VALUES OF MODE ARE EQUIVALENT TO MODE = 1. -C -C FACTOR IS A POSITIVE INPUT VARIABLE USED IN DETERMINING THE -C INITIAL STEP BOUND. THIS BOUND IS SET TO THE PRODUCT OF -C FACTOR AND THE EUCLIDEAN NORM OF DIAG*X IF NONZERO, OR ELSE -C TO FACTOR ITSELF. IN MOST CASES FACTOR SHOULD LIE IN THE -C INTERVAL (.1,100.). 100. IS A GENERALLY RECOMMENDED VALUE. -C -C NPRINT IS AN INTEGER INPUT VARIABLE THAT ENABLES CONTROLLED -C PRINTING OF ITERATES IF IT IS POSITIVE. IN THIS CASE, -C FCN IS CALLED WITH IFLAG = 0 AT THE BEGINNING OF THE FIRST -C ITERATION AND EVERY NPRINT ITERATIONS THEREAFTER AND -C IMMEDIATELY PRIOR TO RETURN, WITH X AND FVEC AVAILABLE -C FOR PRINTING. FVEC AND FJAC SHOULD NOT BE ALTERED. -C IF NPRINT IS NOT POSITIVE, NO SPECIAL CALLS OF FCN -C WITH IFLAG = 0 ARE MADE. -C -C INFO IS AN INTEGER OUTPUT VARIABLE. IF THE USER HAS -C TERMINATED EXECUTION, INFO IS SET TO THE (NEGATIVE) -C VALUE OF IFLAG. SEE DESCRIPTION OF FCN. OTHERWISE, -C INFO IS SET AS FOLLOWS. -C -C INFO = 0 IMPROPER INPUT PARAMETERS. -C -C INFO = 1 RELATIVE ERROR BETWEEN TWO CONSECUTIVE ITERATES -C IS AT MOST XTOL. -C -C INFO = 2 NUMBER OF CALLS TO FCN WITH IFLAG = 1 HAS -C REACHED MAXFEV. -C -C INFO = 3 XTOL IS TOO SMALL. NO FURTHER IMPROVEMENT IN -C THE APPROXIMATE SOLUTION X IS POSSIBLE. -C -C INFO = 4 ITERATION IS NOT MAKING GOOD PROGRESS, AS -C MEASURED BY THE IMPROVEMENT FROM THE LAST -C FIVE JACOBIAN EVALUATIONS. -C -C INFO = 5 ITERATION IS NOT MAKING GOOD PROGRESS, AS -C MEASURED BY THE IMPROVEMENT FROM THE LAST -C TEN ITERATIONS. -C -C NFEV IS AN INTEGER OUTPUT VARIABLE SET TO THE NUMBER OF -C CALLS TO FCN WITH IFLAG = 1. -C -C NJEV IS AN INTEGER OUTPUT VARIABLE SET TO THE NUMBER OF -C CALLS TO FCN WITH IFLAG = 2. -C -C R IS AN OUTPUT ARRAY OF LENGTH LR WHICH CONTAINS THE -C UPPER TRIANGULAR MATRIX PRODUCED BY THE QR FACTORIZATION -C OF THE FINAL APPROXIMATE JACOBIAN, STORED ROWWISE. -C -C LR IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN -C (N*(N+1))/2. -C -C QTF IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS -C THE VECTOR (Q TRANSPOSE)*FVEC. -C -C WA1, WA2, WA3, AND WA4 ARE WORK ARRAYS OF LENGTH N. -C -C SUBPROGRAMS CALLED -C -C USER-SUPPLIED ...... FCN -C -C MINPACK-SUPPLIED ... DOGLEG,SPMPAR,ENORM, -C QFORM,QRFAC,R1MPYQ,R1UPDT -C -C FORTRAN-SUPPLIED ... ABS,AMAX1,AMIN1,MOD -C -C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. -C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE -C -C ********** - INTEGER I,IFLAG,ITER,J,JM1,L,NCFAIL,NCSUC,NSLOW1,NSLOW2 - INTEGER IWA(1) - LOGICAL JEVAL,SING - REAL ACTRED,DELTA,EPSMCH,FNORM,FNORM1,ONE,PNORM,PRERED,P1,P5, - * P001,P0001,RATIO,SUM,TEMP,XNORM,ZERO - REAL SPMPAR,ENORM - DATA ONE,P1,P5,P001,P0001,ZERO - * /1.0E0,1.0E-1,5.0E-1,1.0E-3,1.0E-4,0.0E0/ -C -C EPSMCH IS THE MACHINE PRECISION. -C - EPSMCH = SPMPAR(1) -C - INFO = 0 - IFLAG = 0 - NFEV = 0 - NJEV = 0 -C -C CHECK THE INPUT PARAMETERS FOR ERRORS. -C - IF (N .LE. 0 .OR. LDFJAC .LT. N .OR. XTOL .LT. ZERO - * .OR. MAXFEV .LE. 0 .OR. FACTOR .LE. ZERO - * .OR. LR .LT. (N*(N + 1))/2) GO TO 300 - IF (MODE .NE. 2) GO TO 20 - DO 10 J = 1, N - IF (DIAG(J) .LE. ZERO) GO TO 300 - 10 CONTINUE - 20 CONTINUE -C -C EVALUATE THE FUNCTION AT THE STARTING POINT -C AND CALCULATE ITS NORM. -C - IFLAG = 1 - CALL FCN(N,X,FVEC,FJAC,LDFJAC,IFLAG) - NFEV = 1 - IF (IFLAG .LT. 0) GO TO 300 - FNORM = ENORM(N,FVEC) -C -C INITIALIZE ITERATION COUNTER AND MONITORS. -C - ITER = 1 - NCSUC = 0 - NCFAIL = 0 - NSLOW1 = 0 - NSLOW2 = 0 -C -C BEGINNING OF THE OUTER LOOP. -C - 30 CONTINUE - JEVAL = .TRUE. -C -C CALCULATE THE JACOBIAN MATRIX. -C - IFLAG = 2 - CALL FCN(N,X,FVEC,FJAC,LDFJAC,IFLAG) - NJEV = NJEV + 1 - IF (IFLAG .LT. 0) GO TO 300 -C -C COMPUTE THE QR FACTORIZATION OF THE JACOBIAN. -C - CALL QRFAC(N,N,FJAC,LDFJAC,.FALSE.,IWA,1,WA1,WA2,WA3) -C -C ON THE FIRST ITERATION AND IF MODE IS 1, SCALE ACCORDING -C TO THE NORMS OF THE COLUMNS OF THE INITIAL JACOBIAN. -C - IF (ITER .NE. 1) GO TO 70 - IF (MODE .EQ. 2) GO TO 50 - DO 40 J = 1, N - DIAG(J) = WA2(J) - IF (WA2(J) .EQ. ZERO) DIAG(J) = ONE - 40 CONTINUE - 50 CONTINUE -C -C ON THE FIRST ITERATION, CALCULATE THE NORM OF THE SCALED X -C AND INITIALIZE THE STEP BOUND DELTA. -C - DO 60 J = 1, N - WA3(J) = DIAG(J)*X(J) - 60 CONTINUE - XNORM = ENORM(N,WA3) - DELTA = FACTOR*XNORM - IF (DELTA .EQ. ZERO) DELTA = FACTOR - 70 CONTINUE -C -C FORM (Q TRANSPOSE)*FVEC AND STORE IN QTF. -C - DO 80 I = 1, N - QTF(I) = FVEC(I) - 80 CONTINUE - DO 120 J = 1, N - IF (FJAC(J,J) .EQ. ZERO) GO TO 110 - SUM = ZERO - DO 90 I = J, N - SUM = SUM + FJAC(I,J)*QTF(I) - 90 CONTINUE - TEMP = -SUM/FJAC(J,J) - DO 100 I = J, N - QTF(I) = QTF(I) + FJAC(I,J)*TEMP - 100 CONTINUE - 110 CONTINUE - 120 CONTINUE -C -C COPY THE TRIANGULAR FACTOR OF THE QR FACTORIZATION INTO R. -C - SING = .FALSE. - DO 150 J = 1, N - L = J - JM1 = J - 1 - IF (JM1 .LT. 1) GO TO 140 - DO 130 I = 1, JM1 - R(L) = FJAC(I,J) - L = L + N - I - 130 CONTINUE - 140 CONTINUE - R(L) = WA1(J) - IF (WA1(J) .EQ. ZERO) SING = .TRUE. - 150 CONTINUE -C -C ACCUMULATE THE ORTHOGONAL FACTOR IN FJAC. -C - CALL QFORM(N,N,FJAC,LDFJAC,WA1) -C -C RESCALE IF NECESSARY. -C - IF (MODE .EQ. 2) GO TO 170 - DO 160 J = 1, N - DIAG(J) = AMAX1(DIAG(J),WA2(J)) - 160 CONTINUE - 170 CONTINUE -C -C BEGINNING OF THE INNER LOOP. -C - 180 CONTINUE -C -C IF REQUESTED, CALL FCN TO ENABLE PRINTING OF ITERATES. -C - IF (NPRINT .LE. 0) GO TO 190 - IFLAG = 0 - IF (MOD(ITER-1,NPRINT) .EQ. 0) - * CALL FCN(N,X,FVEC,FJAC,LDFJAC,IFLAG) - IF (IFLAG .LT. 0) GO TO 300 - 190 CONTINUE -C -C DETERMINE THE DIRECTION P. -C - CALL DOGLEG(N,R,LR,DIAG,QTF,DELTA,WA1,WA2,WA3) -C -C STORE THE DIRECTION P AND X + P. CALCULATE THE NORM OF P. -C - DO 200 J = 1, N - WA1(J) = -WA1(J) - WA2(J) = X(J) + WA1(J) - WA3(J) = DIAG(J)*WA1(J) - 200 CONTINUE - PNORM = ENORM(N,WA3) -C -C ON THE FIRST ITERATION, ADJUST THE INITIAL STEP BOUND. -C - IF (ITER .EQ. 1) DELTA = AMIN1(DELTA,PNORM) -C -C EVALUATE THE FUNCTION AT X + P AND CALCULATE ITS NORM. -C - IFLAG = 1 - CALL FCN(N,WA2,WA4,FJAC,LDFJAC,IFLAG) - NFEV = NFEV + 1 - IF (IFLAG .LT. 0) GO TO 300 - FNORM1 = ENORM(N,WA4) -C -C COMPUTE THE SCALED ACTUAL REDUCTION. -C - ACTRED = -ONE - IF (FNORM1 .LT. FNORM) ACTRED = ONE - (FNORM1/FNORM)**2 -C -C COMPUTE THE SCALED PREDICTED REDUCTION. -C - L = 1 - DO 220 I = 1, N - SUM = ZERO - DO 210 J = I, N - SUM = SUM + R(L)*WA1(J) - L = L + 1 - 210 CONTINUE - WA3(I) = QTF(I) + SUM - 220 CONTINUE - TEMP = ENORM(N,WA3) - PRERED = ZERO - IF (TEMP .LT. FNORM) PRERED = ONE - (TEMP/FNORM)**2 -C -C COMPUTE THE RATIO OF THE ACTUAL TO THE PREDICTED -C REDUCTION. -C - RATIO = ZERO - IF (PRERED .GT. ZERO) RATIO = ACTRED/PRERED -C -C UPDATE THE STEP BOUND. -C - IF (RATIO .GE. P1) GO TO 230 - NCSUC = 0 - NCFAIL = NCFAIL + 1 - DELTA = P5*DELTA - GO TO 240 - 230 CONTINUE - NCFAIL = 0 - NCSUC = NCSUC + 1 - IF (RATIO .GE. P5 .OR. NCSUC .GT. 1) - * DELTA = AMAX1(DELTA,PNORM/P5) - IF (ABS(RATIO-ONE) .LE. P1) DELTA = PNORM/P5 - 240 CONTINUE -C -C TEST FOR SUCCESSFUL ITERATION. -C - IF (RATIO .LT. P0001) GO TO 260 -C -C SUCCESSFUL ITERATION. UPDATE X, FVEC, AND THEIR NORMS. -C - DO 250 J = 1, N - X(J) = WA2(J) - WA2(J) = DIAG(J)*X(J) - FVEC(J) = WA4(J) - 250 CONTINUE - XNORM = ENORM(N,WA2) - FNORM = FNORM1 - ITER = ITER + 1 - 260 CONTINUE -C -C DETERMINE THE PROGRESS OF THE ITERATION. -C - NSLOW1 = NSLOW1 + 1 - IF (ACTRED .GE. P001) NSLOW1 = 0 - IF (JEVAL) NSLOW2 = NSLOW2 + 1 - IF (ACTRED .GE. P1) NSLOW2 = 0 -C -C TEST FOR CONVERGENCE. -C - IF (DELTA .LE. XTOL*XNORM .OR. FNORM .EQ. ZERO) INFO = 1 - IF (INFO .NE. 0) GO TO 300 -C -C TESTS FOR TERMINATION AND STRINGENT TOLERANCES. -C - IF (NFEV .GE. MAXFEV) INFO = 2 - IF (P1*AMAX1(P1*DELTA,PNORM) .LE. EPSMCH*XNORM) INFO = 3 - IF (NSLOW2 .EQ. 5) INFO = 4 - IF (NSLOW1 .EQ. 10) INFO = 5 - IF (INFO .NE. 0) GO TO 300 -C -C CRITERION FOR RECALCULATING JACOBIAN. -C - IF (NCFAIL .EQ. 2) GO TO 290 -C -C CALCULATE THE RANK ONE MODIFICATION TO THE JACOBIAN -C AND UPDATE QTF IF NECESSARY. -C - DO 280 J = 1, N - SUM = ZERO - DO 270 I = 1, N - SUM = SUM + FJAC(I,J)*WA4(I) - 270 CONTINUE - WA2(J) = (SUM - WA3(J))/PNORM - WA1(J) = DIAG(J)*((DIAG(J)*WA1(J))/PNORM) - IF (RATIO .GE. P0001) QTF(J) = SUM - 280 CONTINUE -C -C COMPUTE THE QR FACTORIZATION OF THE UPDATED JACOBIAN. -C - CALL R1UPDT(N,N,R,LR,WA1,WA2,WA3,SING) - CALL R1MPYQ(N,N,FJAC,LDFJAC,WA2,WA3) - CALL R1MPYQ(1,N,QTF,1,WA2,WA3) -C -C END OF THE INNER LOOP. -C - JEVAL = .FALSE. - GO TO 180 - 290 CONTINUE -C -C END OF THE OUTER LOOP. -C - GO TO 30 - 300 CONTINUE -C -C TERMINATION, EITHER NORMAL OR USER IMPOSED. -C - IF (IFLAG .LT. 0) INFO = IFLAG - IFLAG = 0 - IF (NPRINT .GT. 0) CALL FCN(N,X,FVEC,FJAC,LDFJAC,IFLAG) - RETURN -C -C LAST CARD OF SUBROUTINE HYBRJ. -C - END - SUBROUTINE HYBRJ1(FCN,N,X,FVEC,FJAC,LDFJAC,TOL,INFO,WA,LWA) - INTEGER N,LDFJAC,INFO,LWA - REAL TOL - REAL X(N),FVEC(N),FJAC(LDFJAC,N),WA(LWA) - EXTERNAL FCN -C ********** -C -C SUBROUTINE HYBRJ1 -C -C THE PURPOSE OF HYBRJ1 IS TO FIND A ZERO OF A SYSTEM OF -C N NONLINEAR FUNCTIONS IN N VARIABLES BY A MODIFICATION -C OF THE POWELL HYBRID METHOD. THIS IS DONE BY USING THE -C MORE GENERAL NONLINEAR EQUATION SOLVER HYBRJ. THE USER -C MUST PROVIDE A SUBROUTINE WHICH CALCULATES THE FUNCTIONS -C AND THE JACOBIAN. -C -C THE SUBROUTINE STATEMENT IS -C -C SUBROUTINE HYBRJ1(FCN,N,X,FVEC,FJAC,LDFJAC,TOL,INFO,WA,LWA) -C -C WHERE -C -C FCN IS THE NAME OF THE USER-SUPPLIED SUBROUTINE WHICH -C CALCULATES THE FUNCTIONS AND THE JACOBIAN. FCN MUST -C BE DECLARED IN AN EXTERNAL STATEMENT IN THE USER -C CALLING PROGRAM, AND SHOULD BE WRITTEN AS FOLLOWS. -C -C SUBROUTINE FCN(N,X,FVEC,FJAC,LDFJAC,IFLAG) -C INTEGER N,LDFJAC,IFLAG -C REAL X(N),FVEC(N),FJAC(LDFJAC,N) -C ---------- -C IF IFLAG = 1 CALCULATE THE FUNCTIONS AT X AND -C RETURN THIS VECTOR IN FVEC. DO NOT ALTER FJAC. -C IF IFLAG = 2 CALCULATE THE JACOBIAN AT X AND -C RETURN THIS MATRIX IN FJAC. DO NOT ALTER FVEC. -C --------- -C RETURN -C END -C -C THE VALUE OF IFLAG SHOULD NOT BE CHANGED BY FCN UNLESS -C THE USER WANTS TO TERMINATE EXECUTION OF HYBRJ1. -C IN THIS CASE SET IFLAG TO A NEGATIVE INTEGER. -C -C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER -C OF FUNCTIONS AND VARIABLES. -C -C X IS AN ARRAY OF LENGTH N. ON INPUT X MUST CONTAIN -C AN INITIAL ESTIMATE OF THE SOLUTION VECTOR. ON OUTPUT X -C CONTAINS THE FINAL ESTIMATE OF THE SOLUTION VECTOR. -C -C FVEC IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS -C THE FUNCTIONS EVALUATED AT THE OUTPUT X. -C -C FJAC IS AN OUTPUT N BY N ARRAY WHICH CONTAINS THE -C ORTHOGONAL MATRIX Q PRODUCED BY THE QR FACTORIZATION -C OF THE FINAL APPROXIMATE JACOBIAN. -C -C LDFJAC IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN N -C WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY FJAC. -C -C TOL IS A NONNEGATIVE INPUT VARIABLE. TERMINATION OCCURS -C WHEN THE ALGORITHM ESTIMATES THAT THE RELATIVE ERROR -C BETWEEN X AND THE SOLUTION IS AT MOST TOL. -C -C INFO IS AN INTEGER OUTPUT VARIABLE. IF THE USER HAS -C TERMINATED EXECUTION, INFO IS SET TO THE (NEGATIVE) -C VALUE OF IFLAG. SEE DESCRIPTION OF FCN. OTHERWISE, -C INFO IS SET AS FOLLOWS. -C -C INFO = 0 IMPROPER INPUT PARAMETERS. -C -C INFO = 1 ALGORITHM ESTIMATES THAT THE RELATIVE ERROR -C BETWEEN X AND THE SOLUTION IS AT MOST TOL. -C -C INFO = 2 NUMBER OF CALLS TO FCN WITH IFLAG = 1 HAS -C REACHED 100*(N+1). -C -C INFO = 3 TOL IS TOO SMALL. NO FURTHER IMPROVEMENT IN -C THE APPROXIMATE SOLUTION X IS POSSIBLE. -C -C INFO = 4 ITERATION IS NOT MAKING GOOD PROGRESS. -C -C WA IS A WORK ARRAY OF LENGTH LWA. -C -C LWA IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN -C (N*(N+13))/2. -C -C SUBPROGRAMS CALLED -C -C USER-SUPPLIED ...... FCN -C -C MINPACK-SUPPLIED ... HYBRJ -C -C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. -C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE -C -C ********** - INTEGER J,LR,MAXFEV,MODE,NFEV,NJEV,NPRINT - REAL FACTOR,ONE,XTOL,ZERO - DATA FACTOR,ONE,ZERO /1.0E2,1.0E0,0.0E0/ - INFO = 0 -C -C CHECK THE INPUT PARAMETERS FOR ERRORS. -C - IF (N .LE. 0 .OR. LDFJAC .LT. N .OR. TOL .LT. ZERO - * .OR. LWA .LT. (N*(N + 13))/2) GO TO 20 -C -C CALL HYBRJ. -C - MAXFEV = 100*(N + 1) - XTOL = TOL - MODE = 2 - DO 10 J = 1, N - WA(J) = ONE - 10 CONTINUE - NPRINT = 0 - LR = (N*(N + 1))/2 - CALL HYBRJ(FCN,N,X,FVEC,FJAC,LDFJAC,XTOL,MAXFEV,WA(1),MODE, - * FACTOR,NPRINT,INFO,NFEV,NJEV,WA(6*N+1),LR,WA(N+1), - * WA(2*N+1),WA(3*N+1),WA(4*N+1),WA(5*N+1)) - IF (INFO .EQ. 5) INFO = 4 - 20 CONTINUE - RETURN -C -C LAST CARD OF SUBROUTINE HYBRJ1. -C - END - SUBROUTINE LMDER(FCN,M,N,X,FVEC,FJAC,LDFJAC,FTOL,XTOL,GTOL, - * MAXFEV,DIAG,MODE,FACTOR,NPRINT,INFO,NFEV,NJEV, - * IPVT,QTF,WA1,WA2,WA3,WA4) - INTEGER M,N,LDFJAC,MAXFEV,MODE,NPRINT,INFO,NFEV,NJEV - INTEGER IPVT(N) - REAL FTOL,XTOL,GTOL,FACTOR - REAL X(N),FVEC(M),FJAC(LDFJAC,N),DIAG(N),QTF(N),WA1(N),WA2(N), - * WA3(N),WA4(M) -C ********** -C -C SUBROUTINE LMDER -C -C THE PURPOSE OF LMDER IS TO MINIMIZE THE SUM OF THE SQUARES OF -C M NONLINEAR FUNCTIONS IN N VARIABLES BY A MODIFICATION OF -C THE LEVENBERG-MARQUARDT ALGORITHM. THE USER MUST PROVIDE A -C SUBROUTINE WHICH CALCULATES THE FUNCTIONS AND THE JACOBIAN. -C -C THE SUBROUTINE STATEMENT IS -C -C SUBROUTINE LMDER(FCN,M,N,X,FVEC,FJAC,LDFJAC,FTOL,XTOL,GTOL, -C MAXFEV,DIAG,MODE,FACTOR,NPRINT,INFO,NFEV, -C NJEV,IPVT,QTF,WA1,WA2,WA3,WA4) -C -C WHERE -C -C FCN IS THE NAME OF THE USER-SUPPLIED SUBROUTINE WHICH -C CALCULATES THE FUNCTIONS AND THE JACOBIAN. FCN MUST -C BE DECLARED IN AN EXTERNAL STATEMENT IN THE USER -C CALLING PROGRAM, AND SHOULD BE WRITTEN AS FOLLOWS. -C -C SUBROUTINE FCN(M,N,X,FVEC,FJAC,LDFJAC,IFLAG) -C INTEGER M,N,LDFJAC,IFLAG -C REAL X(N),FVEC(M),FJAC(LDFJAC,N) -C ---------- -C IF IFLAG = 1 CALCULATE THE FUNCTIONS AT X AND -C RETURN THIS VECTOR IN FVEC. DO NOT ALTER FJAC. -C IF IFLAG = 2 CALCULATE THE JACOBIAN AT X AND -C RETURN THIS MATRIX IN FJAC. DO NOT ALTER FVEC. -C ---------- -C RETURN -C END -C -C THE VALUE OF IFLAG SHOULD NOT BE CHANGED BY FCN UNLESS -C THE USER WANTS TO TERMINATE EXECUTION OF LMDER. -C IN THIS CASE SET IFLAG TO A NEGATIVE INTEGER. -C -C M IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER -C OF FUNCTIONS. -C -C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER -C OF VARIABLES. N MUST NOT EXCEED M. -C -C X IS AN ARRAY OF LENGTH N. ON INPUT X MUST CONTAIN -C AN INITIAL ESTIMATE OF THE SOLUTION VECTOR. ON OUTPUT X -C CONTAINS THE FINAL ESTIMATE OF THE SOLUTION VECTOR. -C -C FVEC IS AN OUTPUT ARRAY OF LENGTH M WHICH CONTAINS -C THE FUNCTIONS EVALUATED AT THE OUTPUT X. -C -C FJAC IS AN OUTPUT M BY N ARRAY. THE UPPER N BY N SUBMATRIX -C OF FJAC CONTAINS AN UPPER TRIANGULAR MATRIX R WITH -C DIAGONAL ELEMENTS OF NONINCREASING MAGNITUDE SUCH THAT -C -C T T T -C P *(JAC *JAC)*P = R *R, -C -C WHERE P IS A PERMUTATION MATRIX AND JAC IS THE FINAL -C CALCULATED JACOBIAN. COLUMN J OF P IS COLUMN IPVT(J) -C (SEE BELOW) OF THE IDENTITY MATRIX. THE LOWER TRAPEZOIDAL -C PART OF FJAC CONTAINS INFORMATION GENERATED DURING -C THE COMPUTATION OF R. -C -C LDFJAC IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN M -C WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY FJAC. -C -C FTOL IS A NONNEGATIVE INPUT VARIABLE. TERMINATION -C OCCURS WHEN BOTH THE ACTUAL AND PREDICTED RELATIVE -C REDUCTIONS IN THE SUM OF SQUARES ARE AT MOST FTOL. -C THEREFORE, FTOL MEASURES THE RELATIVE ERROR DESIRED -C IN THE SUM OF SQUARES. -C -C XTOL IS A NONNEGATIVE INPUT VARIABLE. TERMINATION -C OCCURS WHEN THE RELATIVE ERROR BETWEEN TWO CONSECUTIVE -C ITERATES IS AT MOST XTOL. THEREFORE, XTOL MEASURES THE -C RELATIVE ERROR DESIRED IN THE APPROXIMATE SOLUTION. -C -C GTOL IS A NONNEGATIVE INPUT VARIABLE. TERMINATION -C OCCURS WHEN THE COSINE OF THE ANGLE BETWEEN FVEC AND -C ANY COLUMN OF THE JACOBIAN IS AT MOST GTOL IN ABSOLUTE -C VALUE. THEREFORE, GTOL MEASURES THE ORTHOGONALITY -C DESIRED BETWEEN THE FUNCTION VECTOR AND THE COLUMNS -C OF THE JACOBIAN. -C -C MAXFEV IS A POSITIVE INTEGER INPUT VARIABLE. TERMINATION -C OCCURS WHEN THE NUMBER OF CALLS TO FCN WITH IFLAG = 1 -C HAS REACHED MAXFEV. -C -C DIAG IS AN ARRAY OF LENGTH N. IF MODE = 1 (SEE -C BELOW), DIAG IS INTERNALLY SET. IF MODE = 2, DIAG -C MUST CONTAIN POSITIVE ENTRIES THAT SERVE AS -C MULTIPLICATIVE SCALE FACTORS FOR THE VARIABLES. -C -C MODE IS AN INTEGER INPUT VARIABLE. IF MODE = 1, THE -C VARIABLES WILL BE SCALED INTERNALLY. IF MODE = 2, -C THE SCALING IS SPECIFIED BY THE INPUT DIAG. OTHER -C VALUES OF MODE ARE EQUIVALENT TO MODE = 1. -C -C FACTOR IS A POSITIVE INPUT VARIABLE USED IN DETERMINING THE -C INITIAL STEP BOUND. THIS BOUND IS SET TO THE PRODUCT OF -C FACTOR AND THE EUCLIDEAN NORM OF DIAG*X IF NONZERO, OR ELSE -C TO FACTOR ITSELF. IN MOST CASES FACTOR SHOULD LIE IN THE -C INTERVAL (.1,100.). 100. IS A GENERALLY RECOMMENDED VALUE. -C -C NPRINT IS AN INTEGER INPUT VARIABLE THAT ENABLES CONTROLLED -C PRINTING OF ITERATES IF IT IS POSITIVE. IN THIS CASE, -C FCN IS CALLED WITH IFLAG = 0 AT THE BEGINNING OF THE FIRST -C ITERATION AND EVERY NPRINT ITERATIONS THEREAFTER AND -C IMMEDIATELY PRIOR TO RETURN, WITH X, FVEC, AND FJAC -C AVAILABLE FOR PRINTING. FVEC AND FJAC SHOULD NOT BE -C ALTERED. IF NPRINT IS NOT POSITIVE, NO SPECIAL CALLS -C OF FCN WITH IFLAG = 0 ARE MADE. -C -C INFO IS AN INTEGER OUTPUT VARIABLE. IF THE USER HAS -C TERMINATED EXECUTION, INFO IS SET TO THE (NEGATIVE) -C VALUE OF IFLAG. SEE DESCRIPTION OF FCN. OTHERWISE, -C INFO IS SET AS FOLLOWS. -C -C INFO = 0 IMPROPER INPUT PARAMETERS. -C -C INFO = 1 BOTH ACTUAL AND PREDICTED RELATIVE REDUCTIONS -C IN THE SUM OF SQUARES ARE AT MOST FTOL. -C -C INFO = 2 RELATIVE ERROR BETWEEN TWO CONSECUTIVE ITERATES -C IS AT MOST XTOL. -C -C INFO = 3 CONDITIONS FOR INFO = 1 AND INFO = 2 BOTH HOLD. -C -C INFO = 4 THE COSINE OF THE ANGLE BETWEEN FVEC AND ANY -C COLUMN OF THE JACOBIAN IS AT MOST GTOL IN -C ABSOLUTE VALUE. -C -C INFO = 5 NUMBER OF CALLS TO FCN WITH IFLAG = 1 HAS -C REACHED MAXFEV. -C -C INFO = 6 FTOL IS TOO SMALL. NO FURTHER REDUCTION IN -C THE SUM OF SQUARES IS POSSIBLE. -C -C INFO = 7 XTOL IS TOO SMALL. NO FURTHER IMPROVEMENT IN -C THE APPROXIMATE SOLUTION X IS POSSIBLE. -C -C INFO = 8 GTOL IS TOO SMALL. FVEC IS ORTHOGONAL TO THE -C COLUMNS OF THE JACOBIAN TO MACHINE PRECISION. -C -C NFEV IS AN INTEGER OUTPUT VARIABLE SET TO THE NUMBER OF -C CALLS TO FCN WITH IFLAG = 1. -C -C NJEV IS AN INTEGER OUTPUT VARIABLE SET TO THE NUMBER OF -C CALLS TO FCN WITH IFLAG = 2. -C -C IPVT IS AN INTEGER OUTPUT ARRAY OF LENGTH N. IPVT -C DEFINES A PERMUTATION MATRIX P SUCH THAT JAC*P = Q*R, -C WHERE JAC IS THE FINAL CALCULATED JACOBIAN, Q IS -C ORTHOGONAL (NOT STORED), AND R IS UPPER TRIANGULAR -C WITH DIAGONAL ELEMENTS OF NONINCREASING MAGNITUDE. -C COLUMN J OF P IS COLUMN IPVT(J) OF THE IDENTITY MATRIX. -C -C QTF IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS -C THE FIRST N ELEMENTS OF THE VECTOR (Q TRANSPOSE)*FVEC. -C -C WA1, WA2, AND WA3 ARE WORK ARRAYS OF LENGTH N. -C -C WA4 IS A WORK ARRAY OF LENGTH M. -C -C SUBPROGRAMS CALLED -C -C USER-SUPPLIED ...... FCN -C -C MINPACK-SUPPLIED ... SPMPAR,ENORM,LMPAR,QRFAC -C -C FORTRAN-SUPPLIED ... ABS,AMAX1,AMIN1,SQRT,MOD -C -C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. -C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE -C -C ********** - INTEGER I,IFLAG,ITER,J,L - REAL ACTRED,DELTA,DIRDER,EPSMCH,FNORM,FNORM1,GNORM,ONE,PAR, - * PNORM,PRERED,P1,P5,P25,P75,P0001,RATIO,SUM,TEMP,TEMP1, - * TEMP2,XNORM,ZERO - REAL SPMPAR,ENORM - DATA ONE,P1,P5,P25,P75,P0001,ZERO - * /1.0E0,1.0E-1,5.0E-1,2.5E-1,7.5E-1,1.0E-4,0.0E0/ -C -C EPSMCH IS THE MACHINE PRECISION. -C - EPSMCH = SPMPAR(1) -C - INFO = 0 - IFLAG = 0 - NFEV = 0 - NJEV = 0 -C -C CHECK THE INPUT PARAMETERS FOR ERRORS. -C - IF (N .LE. 0 .OR. M .LT. N .OR. LDFJAC .LT. M - * .OR. FTOL .LT. ZERO .OR. XTOL .LT. ZERO .OR. GTOL .LT. ZERO - * .OR. MAXFEV .LE. 0 .OR. FACTOR .LE. ZERO) GO TO 300 - IF (MODE .NE. 2) GO TO 20 - DO 10 J = 1, N - IF (DIAG(J) .LE. ZERO) GO TO 300 - 10 CONTINUE - 20 CONTINUE -C -C EVALUATE THE FUNCTION AT THE STARTING POINT -C AND CALCULATE ITS NORM. -C - IFLAG = 1 - CALL FCN(M,N,X,FVEC,FJAC,LDFJAC,IFLAG) - NFEV = 1 - IF (IFLAG .LT. 0) GO TO 300 - FNORM = ENORM(M,FVEC) -C -C INITIALIZE LEVENBERG-MARQUARDT PARAMETER AND ITERATION COUNTER. -C - PAR = ZERO - ITER = 1 -C -C BEGINNING OF THE OUTER LOOP. -C - 30 CONTINUE -C -C CALCULATE THE JACOBIAN MATRIX. -C - IFLAG = 2 - CALL FCN(M,N,X,FVEC,FJAC,LDFJAC,IFLAG) - NJEV = NJEV + 1 - IF (IFLAG .LT. 0) GO TO 300 -C -C IF REQUESTED, CALL FCN TO ENABLE PRINTING OF ITERATES. -C - IF (NPRINT .LE. 0) GO TO 40 - IFLAG = 0 - IF (MOD(ITER-1,NPRINT) .EQ. 0) - * CALL FCN(M,N,X,FVEC,FJAC,LDFJAC,IFLAG) - IF (IFLAG .LT. 0) GO TO 300 - 40 CONTINUE -C -C COMPUTE THE QR FACTORIZATION OF THE JACOBIAN. -C - CALL QRFAC(M,N,FJAC,LDFJAC,.TRUE.,IPVT,N,WA1,WA2,WA3) -C -C ON THE FIRST ITERATION AND IF MODE IS 1, SCALE ACCORDING -C TO THE NORMS OF THE COLUMNS OF THE INITIAL JACOBIAN. -C - IF (ITER .NE. 1) GO TO 80 - IF (MODE .EQ. 2) GO TO 60 - DO 50 J = 1, N - DIAG(J) = WA2(J) - IF (WA2(J) .EQ. ZERO) DIAG(J) = ONE - 50 CONTINUE - 60 CONTINUE -C -C ON THE FIRST ITERATION, CALCULATE THE NORM OF THE SCALED X -C AND INITIALIZE THE STEP BOUND DELTA. -C - DO 70 J = 1, N - WA3(J) = DIAG(J)*X(J) - 70 CONTINUE - XNORM = ENORM(N,WA3) - DELTA = FACTOR*XNORM - IF (DELTA .EQ. ZERO) DELTA = FACTOR - 80 CONTINUE -C -C FORM (Q TRANSPOSE)*FVEC AND STORE THE FIRST N COMPONENTS IN -C QTF. -C - DO 90 I = 1, M - WA4(I) = FVEC(I) - 90 CONTINUE - DO 130 J = 1, N - IF (FJAC(J,J) .EQ. ZERO) GO TO 120 - SUM = ZERO - DO 100 I = J, M - SUM = SUM + FJAC(I,J)*WA4(I) - 100 CONTINUE - TEMP = -SUM/FJAC(J,J) - DO 110 I = J, M - WA4(I) = WA4(I) + FJAC(I,J)*TEMP - 110 CONTINUE - 120 CONTINUE - FJAC(J,J) = WA1(J) - QTF(J) = WA4(J) - 130 CONTINUE -C -C COMPUTE THE NORM OF THE SCALED GRADIENT. -C - GNORM = ZERO - IF (FNORM .EQ. ZERO) GO TO 170 - DO 160 J = 1, N - L = IPVT(J) - IF (WA2(L) .EQ. ZERO) GO TO 150 - SUM = ZERO - DO 140 I = 1, J - SUM = SUM + FJAC(I,J)*(QTF(I)/FNORM) - 140 CONTINUE - GNORM = AMAX1(GNORM,ABS(SUM/WA2(L))) - 150 CONTINUE - 160 CONTINUE - 170 CONTINUE -C -C TEST FOR CONVERGENCE OF THE GRADIENT NORM. -C - IF (GNORM .LE. GTOL) INFO = 4 - IF (INFO .NE. 0) GO TO 300 -C -C RESCALE IF NECESSARY. -C - IF (MODE .EQ. 2) GO TO 190 - DO 180 J = 1, N - DIAG(J) = AMAX1(DIAG(J),WA2(J)) - 180 CONTINUE - 190 CONTINUE -C -C BEGINNING OF THE INNER LOOP. -C - 200 CONTINUE -C -C DETERMINE THE LEVENBERG-MARQUARDT PARAMETER. -C - CALL LMPAR(N,FJAC,LDFJAC,IPVT,DIAG,QTF,DELTA,PAR,WA1,WA2, - * WA3,WA4) -C -C STORE THE DIRECTION P AND X + P. CALCULATE THE NORM OF P. -C - DO 210 J = 1, N - WA1(J) = -WA1(J) - WA2(J) = X(J) + WA1(J) - WA3(J) = DIAG(J)*WA1(J) - 210 CONTINUE - PNORM = ENORM(N,WA3) -C -C ON THE FIRST ITERATION, ADJUST THE INITIAL STEP BOUND. -C - IF (ITER .EQ. 1) DELTA = AMIN1(DELTA,PNORM) -C -C EVALUATE THE FUNCTION AT X + P AND CALCULATE ITS NORM. -C - IFLAG = 1 - CALL FCN(M,N,WA2,WA4,FJAC,LDFJAC,IFLAG) - NFEV = NFEV + 1 - IF (IFLAG .LT. 0) GO TO 300 - FNORM1 = ENORM(M,WA4) -C -C COMPUTE THE SCALED ACTUAL REDUCTION. -C - ACTRED = -ONE - IF (P1*FNORM1 .LT. FNORM) ACTRED = ONE - (FNORM1/FNORM)**2 -C -C COMPUTE THE SCALED PREDICTED REDUCTION AND -C THE SCALED DIRECTIONAL DERIVATIVE. -C - DO 230 J = 1, N - WA3(J) = ZERO - L = IPVT(J) - TEMP = WA1(L) - DO 220 I = 1, J - WA3(I) = WA3(I) + FJAC(I,J)*TEMP - 220 CONTINUE - 230 CONTINUE - TEMP1 = ENORM(N,WA3)/FNORM - TEMP2 = (SQRT(PAR)*PNORM)/FNORM - PRERED = TEMP1**2 + TEMP2**2/P5 - DIRDER = -(TEMP1**2 + TEMP2**2) -C -C COMPUTE THE RATIO OF THE ACTUAL TO THE PREDICTED -C REDUCTION. -C - RATIO = ZERO - IF (PRERED .NE. ZERO) RATIO = ACTRED/PRERED -C -C UPDATE THE STEP BOUND. -C - IF (RATIO .GT. P25) GO TO 240 - IF (ACTRED .GE. ZERO) TEMP = P5 - IF (ACTRED .LT. ZERO) - * TEMP = P5*DIRDER/(DIRDER + P5*ACTRED) - IF (P1*FNORM1 .GE. FNORM .OR. TEMP .LT. P1) TEMP = P1 - DELTA = TEMP*AMIN1(DELTA,PNORM/P1) - PAR = PAR/TEMP - GO TO 260 - 240 CONTINUE - IF (PAR .NE. ZERO .AND. RATIO .LT. P75) GO TO 250 - DELTA = PNORM/P5 - PAR = P5*PAR - 250 CONTINUE - 260 CONTINUE -C -C TEST FOR SUCCESSFUL ITERATION. -C - IF (RATIO .LT. P0001) GO TO 290 -C -C SUCCESSFUL ITERATION. UPDATE X, FVEC, AND THEIR NORMS. -C - DO 270 J = 1, N - X(J) = WA2(J) - WA2(J) = DIAG(J)*X(J) - 270 CONTINUE - DO 280 I = 1, M - FVEC(I) = WA4(I) - 280 CONTINUE - XNORM = ENORM(N,WA2) - FNORM = FNORM1 - ITER = ITER + 1 - 290 CONTINUE -C -C TESTS FOR CONVERGENCE. -C - IF (ABS(ACTRED) .LE. FTOL .AND. PRERED .LE. FTOL - * .AND. P5*RATIO .LE. ONE) INFO = 1 - IF (DELTA .LE. XTOL*XNORM) INFO = 2 - IF (ABS(ACTRED) .LE. FTOL .AND. PRERED .LE. FTOL - * .AND. P5*RATIO .LE. ONE .AND. INFO .EQ. 2) INFO = 3 - IF (INFO .NE. 0) GO TO 300 -C -C TESTS FOR TERMINATION AND STRINGENT TOLERANCES. -C - IF (NFEV .GE. MAXFEV) INFO = 5 - IF (ABS(ACTRED) .LE. EPSMCH .AND. PRERED .LE. EPSMCH - * .AND. P5*RATIO .LE. ONE) INFO = 6 - IF (DELTA .LE. EPSMCH*XNORM) INFO = 7 - IF (GNORM .LE. EPSMCH) INFO = 8 - IF (INFO .NE. 0) GO TO 300 -C -C END OF THE INNER LOOP. REPEAT IF ITERATION UNSUCCESSFUL. -C - IF (RATIO .LT. P0001) GO TO 200 -C -C END OF THE OUTER LOOP. -C - GO TO 30 - 300 CONTINUE -C -C TERMINATION, EITHER NORMAL OR USER IMPOSED. -C - IF (IFLAG .LT. 0) INFO = IFLAG - IFLAG = 0 - IF (NPRINT .GT. 0) CALL FCN(M,N,X,FVEC,FJAC,LDFJAC,IFLAG) - RETURN -C -C LAST CARD OF SUBROUTINE LMDER. -C - END - SUBROUTINE LMDER1(FCN,M,N,X,FVEC,FJAC,LDFJAC,TOL,INFO,IPVT,WA, - * LWA) - INTEGER M,N,LDFJAC,INFO,LWA - INTEGER IPVT(N) - REAL TOL - REAL X(N),FVEC(M),FJAC(LDFJAC,N),WA(LWA) - EXTERNAL FCN -C ********** -C -C SUBROUTINE LMDER1 -C -C THE PURPOSE OF LMDER1 IS TO MINIMIZE THE SUM OF THE SQUARES OF -C M NONLINEAR FUNCTIONS IN N VARIABLES BY A MODIFICATION OF THE -C LEVENBERG-MARQUARDT ALGORITHM. THIS IS DONE BY USING THE MORE -C GENERAL LEAST-SQUARES SOLVER LMDER. THE USER MUST PROVIDE A -C SUBROUTINE WHICH CALCULATES THE FUNCTIONS AND THE JACOBIAN. -C -C THE SUBROUTINE STATEMENT IS -C -C SUBROUTINE LMDER1(FCN,M,N,X,FVEC,FJAC,LDFJAC,TOL,INFO, -C IPVT,WA,LWA) -C -C WHERE -C -C FCN IS THE NAME OF THE USER-SUPPLIED SUBROUTINE WHICH -C CALCULATES THE FUNCTIONS AND THE JACOBIAN. FCN MUST -C BE DECLARED IN AN EXTERNAL STATEMENT IN THE USER -C CALLING PROGRAM, AND SHOULD BE WRITTEN AS FOLLOWS. -C -C SUBROUTINE FCN(M,N,X,FVEC,FJAC,LDFJAC,IFLAG) -C INTEGER M,N,LDFJAC,IFLAG -C REAL X(N),FVEC(M),FJAC(LDFJAC,N) -C ---------- -C IF IFLAG = 1 CALCULATE THE FUNCTIONS AT X AND -C RETURN THIS VECTOR IN FVEC. DO NOT ALTER FJAC. -C IF IFLAG = 2 CALCULATE THE JACOBIAN AT X AND -C RETURN THIS MATRIX IN FJAC. DO NOT ALTER FVEC. -C ---------- -C RETURN -C END -C -C THE VALUE OF IFLAG SHOULD NOT BE CHANGED BY FCN UNLESS -C THE USER WANTS TO TERMINATE EXECUTION OF LMDER1. -C IN THIS CASE SET IFLAG TO A NEGATIVE INTEGER. -C -C M IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER -C OF FUNCTIONS. -C -C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER -C OF VARIABLES. N MUST NOT EXCEED M. -C -C X IS AN ARRAY OF LENGTH N. ON INPUT X MUST CONTAIN -C AN INITIAL ESTIMATE OF THE SOLUTION VECTOR. ON OUTPUT X -C CONTAINS THE FINAL ESTIMATE OF THE SOLUTION VECTOR. -C -C FVEC IS AN OUTPUT ARRAY OF LENGTH M WHICH CONTAINS -C THE FUNCTIONS EVALUATED AT THE OUTPUT X. -C -C FJAC IS AN OUTPUT M BY N ARRAY. THE UPPER N BY N SUBMATRIX -C OF FJAC CONTAINS AN UPPER TRIANGULAR MATRIX R WITH -C DIAGONAL ELEMENTS OF NONINCREASING MAGNITUDE SUCH THAT -C -C T T T -C P *(JAC *JAC)*P = R *R, -C -C WHERE P IS A PERMUTATION MATRIX AND JAC IS THE FINAL -C CALCULATED JACOBIAN. COLUMN J OF P IS COLUMN IPVT(J) -C (SEE BELOW) OF THE IDENTITY MATRIX. THE LOWER TRAPEZOIDAL -C PART OF FJAC CONTAINS INFORMATION GENERATED DURING -C THE COMPUTATION OF R. -C -C LDFJAC IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN M -C WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY FJAC. -C -C TOL IS A NONNEGATIVE INPUT VARIABLE. TERMINATION OCCURS -C WHEN THE ALGORITHM ESTIMATES EITHER THAT THE RELATIVE -C ERROR IN THE SUM OF SQUARES IS AT MOST TOL OR THAT -C THE RELATIVE ERROR BETWEEN X AND THE SOLUTION IS AT -C MOST TOL. -C -C INFO IS AN INTEGER OUTPUT VARIABLE. IF THE USER HAS -C TERMINATED EXECUTION, INFO IS SET TO THE (NEGATIVE) -C VALUE OF IFLAG. SEE DESCRIPTION OF FCN. OTHERWISE, -C INFO IS SET AS FOLLOWS. -C -C INFO = 0 IMPROPER INPUT PARAMETERS. -C -C INFO = 1 ALGORITHM ESTIMATES THAT THE RELATIVE ERROR -C IN THE SUM OF SQUARES IS AT MOST TOL. -C -C INFO = 2 ALGORITHM ESTIMATES THAT THE RELATIVE ERROR -C BETWEEN X AND THE SOLUTION IS AT MOST TOL. -C -C INFO = 3 CONDITIONS FOR INFO = 1 AND INFO = 2 BOTH HOLD. -C -C INFO = 4 FVEC IS ORTHOGONAL TO THE COLUMNS OF THE -C JACOBIAN TO MACHINE PRECISION. -C -C INFO = 5 NUMBER OF CALLS TO FCN WITH IFLAG = 1 HAS -C REACHED 100*(N+1). -C -C INFO = 6 TOL IS TOO SMALL. NO FURTHER REDUCTION IN -C THE SUM OF SQUARES IS POSSIBLE. -C -C INFO = 7 TOL IS TOO SMALL. NO FURTHER IMPROVEMENT IN -C THE APPROXIMATE SOLUTION X IS POSSIBLE. -C -C IPVT IS AN INTEGER OUTPUT ARRAY OF LENGTH N. IPVT -C DEFINES A PERMUTATION MATRIX P SUCH THAT JAC*P = Q*R, -C WHERE JAC IS THE FINAL CALCULATED JACOBIAN, Q IS -C ORTHOGONAL (NOT STORED), AND R IS UPPER TRIANGULAR -C WITH DIAGONAL ELEMENTS OF NONINCREASING MAGNITUDE. -C COLUMN J OF P IS COLUMN IPVT(J) OF THE IDENTITY MATRIX. -C -C WA IS A WORK ARRAY OF LENGTH LWA. -C -C LWA IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN 5*N+M. -C -C SUBPROGRAMS CALLED -C -C USER-SUPPLIED ...... FCN -C -C MINPACK-SUPPLIED ... LMDER -C -C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. -C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE -C -C ********** - INTEGER MAXFEV,MODE,NFEV,NJEV,NPRINT - REAL FACTOR,FTOL,GTOL,XTOL,ZERO - DATA FACTOR,ZERO /1.0E2,0.0E0/ - INFO = 0 -C -C CHECK THE INPUT PARAMETERS FOR ERRORS. -C - IF (N .LE. 0 .OR. M .LT. N .OR. LDFJAC .LT. M .OR. TOL .LT. ZERO - * .OR. LWA .LT. 5*N + M) GO TO 10 -C -C CALL LMDER. -C - MAXFEV = 100*(N + 1) - FTOL = TOL - XTOL = TOL - GTOL = ZERO - MODE = 1 - NPRINT = 0 - CALL LMDER(FCN,M,N,X,FVEC,FJAC,LDFJAC,FTOL,XTOL,GTOL,MAXFEV, - * WA(1),MODE,FACTOR,NPRINT,INFO,NFEV,NJEV,IPVT,WA(N+1), - * WA(2*N+1),WA(3*N+1),WA(4*N+1),WA(5*N+1)) - IF (INFO .EQ. 8) INFO = 4 - 10 CONTINUE - RETURN -C -C LAST CARD OF SUBROUTINE LMDER1. -C - END - SUBROUTINE LMDIF(FCN,M,N,X,FVEC,FTOL,XTOL,GTOL,MAXFEV,EPSFCN, - * DIAG,MODE,FACTOR,NPRINT,INFO,NFEV,FJAC,LDFJAC, - * IPVT,QTF,WA1,WA2,WA3,WA4) - INTEGER M,N,MAXFEV,MODE,NPRINT,INFO,NFEV,LDFJAC - INTEGER IPVT(N) - REAL FTOL,XTOL,GTOL,EPSFCN,FACTOR - REAL X(N),FVEC(M),DIAG(N),FJAC(LDFJAC,N),QTF(N),WA1(N),WA2(N), - * WA3(N),WA4(M) - EXTERNAL FCN -C ********** -C -C SUBROUTINE LMDIF -C -C THE PURPOSE OF LMDIF IS TO MINIMIZE THE SUM OF THE SQUARES OF -C M NONLINEAR FUNCTIONS IN N VARIABLES BY A MODIFICATION OF -C THE LEVENBERG-MARQUARDT ALGORITHM. THE USER MUST PROVIDE A -C SUBROUTINE WHICH CALCULATES THE FUNCTIONS. THE JACOBIAN IS -C THEN CALCULATED BY A FORWARD-DIFFERENCE APPROXIMATION. -C -C THE SUBROUTINE STATEMENT IS -C -C SUBROUTINE LMDIF(FCN,M,N,X,FVEC,FTOL,XTOL,GTOL,MAXFEV,EPSFCN, -C DIAG,MODE,FACTOR,NPRINT,INFO,NFEV,FJAC, -C LDFJAC,IPVT,QTF,WA1,WA2,WA3,WA4) -C -C WHERE -C -C FCN IS THE NAME OF THE USER-SUPPLIED SUBROUTINE WHICH -C CALCULATES THE FUNCTIONS. FCN MUST BE DECLARED -C IN AN EXTERNAL STATEMENT IN THE USER CALLING -C PROGRAM, AND SHOULD BE WRITTEN AS FOLLOWS. -C -C SUBROUTINE FCN(M,N,X,FVEC,IFLAG) -C INTEGER M,N,IFLAG -C REAL X(N),FVEC(M) -C ---------- -C CALCULATE THE FUNCTIONS AT X AND -C RETURN THIS VECTOR IN FVEC. -C ---------- -C RETURN -C END -C -C THE VALUE OF IFLAG SHOULD NOT BE CHANGED BY FCN UNLESS -C THE USER WANTS TO TERMINATE EXECUTION OF LMDIF. -C IN THIS CASE SET IFLAG TO A NEGATIVE INTEGER. -C -C M IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER -C OF FUNCTIONS. -C -C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER -C OF VARIABLES. N MUST NOT EXCEED M. -C -C X IS AN ARRAY OF LENGTH N. ON INPUT X MUST CONTAIN -C AN INITIAL ESTIMATE OF THE SOLUTION VECTOR. ON OUTPUT X -C CONTAINS THE FINAL ESTIMATE OF THE SOLUTION VECTOR. -C -C FVEC IS AN OUTPUT ARRAY OF LENGTH M WHICH CONTAINS -C THE FUNCTIONS EVALUATED AT THE OUTPUT X. -C -C FTOL IS A NONNEGATIVE INPUT VARIABLE. TERMINATION -C OCCURS WHEN BOTH THE ACTUAL AND PREDICTED RELATIVE -C REDUCTIONS IN THE SUM OF SQUARES ARE AT MOST FTOL. -C THEREFORE, FTOL MEASURES THE RELATIVE ERROR DESIRED -C IN THE SUM OF SQUARES. -C -C XTOL IS A NONNEGATIVE INPUT VARIABLE. TERMINATION -C OCCURS WHEN THE RELATIVE ERROR BETWEEN TWO CONSECUTIVE -C ITERATES IS AT MOST XTOL. THEREFORE, XTOL MEASURES THE -C RELATIVE ERROR DESIRED IN THE APPROXIMATE SOLUTION. -C -C GTOL IS A NONNEGATIVE INPUT VARIABLE. TERMINATION -C OCCURS WHEN THE COSINE OF THE ANGLE BETWEEN FVEC AND -C ANY COLUMN OF THE JACOBIAN IS AT MOST GTOL IN ABSOLUTE -C VALUE. THEREFORE, GTOL MEASURES THE ORTHOGONALITY -C DESIRED BETWEEN THE FUNCTION VECTOR AND THE COLUMNS -C OF THE JACOBIAN. -C -C MAXFEV IS A POSITIVE INTEGER INPUT VARIABLE. TERMINATION -C OCCURS WHEN THE NUMBER OF CALLS TO FCN IS AT LEAST -C MAXFEV BY THE END OF AN ITERATION. -C -C EPSFCN IS AN INPUT VARIABLE USED IN DETERMINING A SUITABLE -C STEP LENGTH FOR THE FORWARD-DIFFERENCE APPROXIMATION. THIS -C APPROXIMATION ASSUMES THAT THE RELATIVE ERRORS IN THE -C FUNCTIONS ARE OF THE ORDER OF EPSFCN. IF EPSFCN IS LESS -C THAN THE MACHINE PRECISION, IT IS ASSUMED THAT THE RELATIVE -C ERRORS IN THE FUNCTIONS ARE OF THE ORDER OF THE MACHINE -C PRECISION. -C -C DIAG IS AN ARRAY OF LENGTH N. IF MODE = 1 (SEE -C BELOW), DIAG IS INTERNALLY SET. IF MODE = 2, DIAG -C MUST CONTAIN POSITIVE ENTRIES THAT SERVE AS -C MULTIPLICATIVE SCALE FACTORS FOR THE VARIABLES. -C -C MODE IS AN INTEGER INPUT VARIABLE. IF MODE = 1, THE -C VARIABLES WILL BE SCALED INTERNALLY. IF MODE = 2, -C THE SCALING IS SPECIFIED BY THE INPUT DIAG. OTHER -C VALUES OF MODE ARE EQUIVALENT TO MODE = 1. -C -C FACTOR IS A POSITIVE INPUT VARIABLE USED IN DETERMINING THE -C INITIAL STEP BOUND. THIS BOUND IS SET TO THE PRODUCT OF -C FACTOR AND THE EUCLIDEAN NORM OF DIAG*X IF NONZERO, OR ELSE -C TO FACTOR ITSELF. IN MOST CASES FACTOR SHOULD LIE IN THE -C INTERVAL (.1,100.). 100. IS A GENERALLY RECOMMENDED VALUE. -C -C NPRINT IS AN INTEGER INPUT VARIABLE THAT ENABLES CONTROLLED -C PRINTING OF ITERATES IF IT IS POSITIVE. IN THIS CASE, -C FCN IS CALLED WITH IFLAG = 0 AT THE BEGINNING OF THE FIRST -C ITERATION AND EVERY NPRINT ITERATIONS THEREAFTER AND -C IMMEDIATELY PRIOR TO RETURN, WITH X AND FVEC AVAILABLE -C FOR PRINTING. IF NPRINT IS NOT POSITIVE, NO SPECIAL CALLS -C OF FCN WITH IFLAG = 0 ARE MADE. -C -C INFO IS AN INTEGER OUTPUT VARIABLE. IF THE USER HAS -C TERMINATED EXECUTION, INFO IS SET TO THE (NEGATIVE) -C VALUE OF IFLAG. SEE DESCRIPTION OF FCN. OTHERWISE, -C INFO IS SET AS FOLLOWS. -C -C INFO = 0 IMPROPER INPUT PARAMETERS. -C -C INFO = 1 BOTH ACTUAL AND PREDICTED RELATIVE REDUCTIONS -C IN THE SUM OF SQUARES ARE AT MOST FTOL. -C -C INFO = 2 RELATIVE ERROR BETWEEN TWO CONSECUTIVE ITERATES -C IS AT MOST XTOL. -C -C INFO = 3 CONDITIONS FOR INFO = 1 AND INFO = 2 BOTH HOLD. -C -C INFO = 4 THE COSINE OF THE ANGLE BETWEEN FVEC AND ANY -C COLUMN OF THE JACOBIAN IS AT MOST GTOL IN -C ABSOLUTE VALUE. -C -C INFO = 5 NUMBER OF CALLS TO FCN HAS REACHED OR -C EXCEEDED MAXFEV. -C -C INFO = 6 FTOL IS TOO SMALL. NO FURTHER REDUCTION IN -C THE SUM OF SQUARES IS POSSIBLE. -C -C INFO = 7 XTOL IS TOO SMALL. NO FURTHER IMPROVEMENT IN -C THE APPROXIMATE SOLUTION X IS POSSIBLE. -C -C INFO = 8 GTOL IS TOO SMALL. FVEC IS ORTHOGONAL TO THE -C COLUMNS OF THE JACOBIAN TO MACHINE PRECISION. -C -C NFEV IS AN INTEGER OUTPUT VARIABLE SET TO THE NUMBER OF -C CALLS TO FCN. -C -C FJAC IS AN OUTPUT M BY N ARRAY. THE UPPER N BY N SUBMATRIX -C OF FJAC CONTAINS AN UPPER TRIANGULAR MATRIX R WITH -C DIAGONAL ELEMENTS OF NONINCREASING MAGNITUDE SUCH THAT -C -C T T T -C P *(JAC *JAC)*P = R *R, -C -C WHERE P IS A PERMUTATION MATRIX AND JAC IS THE FINAL -C CALCULATED JACOBIAN. COLUMN J OF P IS COLUMN IPVT(J) -C (SEE BELOW) OF THE IDENTITY MATRIX. THE LOWER TRAPEZOIDAL -C PART OF FJAC CONTAINS INFORMATION GENERATED DURING -C THE COMPUTATION OF R. -C -C LDFJAC IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN M -C WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY FJAC. -C -C IPVT IS AN INTEGER OUTPUT ARRAY OF LENGTH N. IPVT -C DEFINES A PERMUTATION MATRIX P SUCH THAT JAC*P = Q*R, -C WHERE JAC IS THE FINAL CALCULATED JACOBIAN, Q IS -C ORTHOGONAL (NOT STORED), AND R IS UPPER TRIANGULAR -C WITH DIAGONAL ELEMENTS OF NONINCREASING MAGNITUDE. -C COLUMN J OF P IS COLUMN IPVT(J) OF THE IDENTITY MATRIX. -C -C QTF IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS -C THE FIRST N ELEMENTS OF THE VECTOR (Q TRANSPOSE)*FVEC. -C -C WA1, WA2, AND WA3 ARE WORK ARRAYS OF LENGTH N. -C -C WA4 IS A WORK ARRAY OF LENGTH M. -C -C SUBPROGRAMS CALLED -C -C USER-SUPPLIED ...... FCN -C -C MINPACK-SUPPLIED ... SPMPAR,ENORM,FDJAC2,LMPAR,QRFAC -C -C FORTRAN-SUPPLIED ... ABS,AMAX1,AMIN1,SQRT,MOD -C -C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. -C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE -C -C ********** - INTEGER I,IFLAG,ITER,J,L - REAL ACTRED,DELTA,DIRDER,EPSMCH,FNORM,FNORM1,GNORM,ONE,PAR, - * PNORM,PRERED,P1,P5,P25,P75,P0001,RATIO,SUM,TEMP,TEMP1, - * TEMP2,XNORM,ZERO - REAL SPMPAR,ENORM - DATA ONE,P1,P5,P25,P75,P0001,ZERO - * /1.0E0,1.0E-1,5.0E-1,2.5E-1,7.5E-1,1.0E-4,0.0E0/ -C -C EPSMCH IS THE MACHINE PRECISION. -C - EPSMCH = SPMPAR(1) -C - INFO = 0 - IFLAG = 0 - NFEV = 0 -C -C CHECK THE INPUT PARAMETERS FOR ERRORS. -C - IF (N .LE. 0 .OR. M .LT. N .OR. LDFJAC .LT. M - * .OR. FTOL .LT. ZERO .OR. XTOL .LT. ZERO .OR. GTOL .LT. ZERO - * .OR. MAXFEV .LE. 0 .OR. FACTOR .LE. ZERO) GO TO 300 - IF (MODE .NE. 2) GO TO 20 - DO 10 J = 1, N - IF (DIAG(J) .LE. ZERO) GO TO 300 - 10 CONTINUE - 20 CONTINUE -C -C EVALUATE THE FUNCTION AT THE STARTING POINT -C AND CALCULATE ITS NORM. -C - IFLAG = 1 - CALL FCN(M,N,X,FVEC,IFLAG) - NFEV = 1 - IF (IFLAG .LT. 0) GO TO 300 - FNORM = ENORM(M,FVEC) -C -C INITIALIZE LEVENBERG-MARQUARDT PARAMETER AND ITERATION COUNTER. -C - PAR = ZERO - ITER = 1 -C -C BEGINNING OF THE OUTER LOOP. -C - 30 CONTINUE -C -C CALCULATE THE JACOBIAN MATRIX. -C - IFLAG = 2 - CALL FDJAC2(FCN,M,N,X,FVEC,FJAC,LDFJAC,IFLAG,EPSFCN,WA4) - NFEV = NFEV + N - IF (IFLAG .LT. 0) GO TO 300 -C -C IF REQUESTED, CALL FCN TO ENABLE PRINTING OF ITERATES. -C - IF (NPRINT .LE. 0) GO TO 40 - IFLAG = 0 - IF (MOD(ITER-1,NPRINT) .EQ. 0) CALL FCN(M,N,X,FVEC,IFLAG) - IF (IFLAG .LT. 0) GO TO 300 - 40 CONTINUE -C -C COMPUTE THE QR FACTORIZATION OF THE JACOBIAN. -C - CALL QRFAC(M,N,FJAC,LDFJAC,.TRUE.,IPVT,N,WA1,WA2,WA3) -C -C ON THE FIRST ITERATION AND IF MODE IS 1, SCALE ACCORDING -C TO THE NORMS OF THE COLUMNS OF THE INITIAL JACOBIAN. -C - IF (ITER .NE. 1) GO TO 80 - IF (MODE .EQ. 2) GO TO 60 - DO 50 J = 1, N - DIAG(J) = WA2(J) - IF (WA2(J) .EQ. ZERO) DIAG(J) = ONE - 50 CONTINUE - 60 CONTINUE -C -C ON THE FIRST ITERATION, CALCULATE THE NORM OF THE SCALED X -C AND INITIALIZE THE STEP BOUND DELTA. -C - DO 70 J = 1, N - WA3(J) = DIAG(J)*X(J) - 70 CONTINUE - XNORM = ENORM(N,WA3) - DELTA = FACTOR*XNORM - IF (DELTA .EQ. ZERO) DELTA = FACTOR - 80 CONTINUE -C -C FORM (Q TRANSPOSE)*FVEC AND STORE THE FIRST N COMPONENTS IN -C QTF. -C - DO 90 I = 1, M - WA4(I) = FVEC(I) - 90 CONTINUE - DO 130 J = 1, N - IF (FJAC(J,J) .EQ. ZERO) GO TO 120 - SUM = ZERO - DO 100 I = J, M - SUM = SUM + FJAC(I,J)*WA4(I) - 100 CONTINUE - TEMP = -SUM/FJAC(J,J) - DO 110 I = J, M - WA4(I) = WA4(I) + FJAC(I,J)*TEMP - 110 CONTINUE - 120 CONTINUE - FJAC(J,J) = WA1(J) - QTF(J) = WA4(J) - 130 CONTINUE -C -C COMPUTE THE NORM OF THE SCALED GRADIENT. -C - GNORM = ZERO - IF (FNORM .EQ. ZERO) GO TO 170 - DO 160 J = 1, N - L = IPVT(J) - IF (WA2(L) .EQ. ZERO) GO TO 150 - SUM = ZERO - DO 140 I = 1, J - SUM = SUM + FJAC(I,J)*(QTF(I)/FNORM) - 140 CONTINUE - GNORM = AMAX1(GNORM,ABS(SUM/WA2(L))) - 150 CONTINUE - 160 CONTINUE - 170 CONTINUE -C -C TEST FOR CONVERGENCE OF THE GRADIENT NORM. -C - IF (GNORM .LE. GTOL) INFO = 4 - IF (INFO .NE. 0) GO TO 300 -C -C RESCALE IF NECESSARY. -C - IF (MODE .EQ. 2) GO TO 190 - DO 180 J = 1, N - DIAG(J) = AMAX1(DIAG(J),WA2(J)) - 180 CONTINUE - 190 CONTINUE -C -C BEGINNING OF THE INNER LOOP. -C - 200 CONTINUE -C -C DETERMINE THE LEVENBERG-MARQUARDT PARAMETER. -C - CALL LMPAR(N,FJAC,LDFJAC,IPVT,DIAG,QTF,DELTA,PAR,WA1,WA2, - * WA3,WA4) -C -C STORE THE DIRECTION P AND X + P. CALCULATE THE NORM OF P. -C - DO 210 J = 1, N - WA1(J) = -WA1(J) - WA2(J) = X(J) + WA1(J) - WA3(J) = DIAG(J)*WA1(J) - 210 CONTINUE - PNORM = ENORM(N,WA3) -C -C ON THE FIRST ITERATION, ADJUST THE INITIAL STEP BOUND. -C - IF (ITER .EQ. 1) DELTA = AMIN1(DELTA,PNORM) -C -C EVALUATE THE FUNCTION AT X + P AND CALCULATE ITS NORM. -C - IFLAG = 1 - CALL FCN(M,N,WA2,WA4,IFLAG) - NFEV = NFEV + 1 - IF (IFLAG .LT. 0) GO TO 300 - FNORM1 = ENORM(M,WA4) -C -C COMPUTE THE SCALED ACTUAL REDUCTION. -C - ACTRED = -ONE - IF (P1*FNORM1 .LT. FNORM) ACTRED = ONE - (FNORM1/FNORM)**2 -C -C COMPUTE THE SCALED PREDICTED REDUCTION AND -C THE SCALED DIRECTIONAL DERIVATIVE. -C - DO 230 J = 1, N - WA3(J) = ZERO - L = IPVT(J) - TEMP = WA1(L) - DO 220 I = 1, J - WA3(I) = WA3(I) + FJAC(I,J)*TEMP - 220 CONTINUE - 230 CONTINUE - TEMP1 = ENORM(N,WA3)/FNORM - TEMP2 = (SQRT(PAR)*PNORM)/FNORM - PRERED = TEMP1**2 + TEMP2**2/P5 - DIRDER = -(TEMP1**2 + TEMP2**2) -C -C COMPUTE THE RATIO OF THE ACTUAL TO THE PREDICTED -C REDUCTION. -C - RATIO = ZERO - IF (PRERED .NE. ZERO) RATIO = ACTRED/PRERED -C -C UPDATE THE STEP BOUND. -C - IF (RATIO .GT. P25) GO TO 240 - IF (ACTRED .GE. ZERO) TEMP = P5 - IF (ACTRED .LT. ZERO) - * TEMP = P5*DIRDER/(DIRDER + P5*ACTRED) - IF (P1*FNORM1 .GE. FNORM .OR. TEMP .LT. P1) TEMP = P1 - DELTA = TEMP*AMIN1(DELTA,PNORM/P1) - PAR = PAR/TEMP - GO TO 260 - 240 CONTINUE - IF (PAR .NE. ZERO .AND. RATIO .LT. P75) GO TO 250 - DELTA = PNORM/P5 - PAR = P5*PAR - 250 CONTINUE - 260 CONTINUE -C -C TEST FOR SUCCESSFUL ITERATION. -C - IF (RATIO .LT. P0001) GO TO 290 -C -C SUCCESSFUL ITERATION. UPDATE X, FVEC, AND THEIR NORMS. -C - DO 270 J = 1, N - X(J) = WA2(J) - WA2(J) = DIAG(J)*X(J) - 270 CONTINUE - DO 280 I = 1, M - FVEC(I) = WA4(I) - 280 CONTINUE - XNORM = ENORM(N,WA2) - FNORM = FNORM1 - ITER = ITER + 1 - 290 CONTINUE -C -C TESTS FOR CONVERGENCE. -C - IF (ABS(ACTRED) .LE. FTOL .AND. PRERED .LE. FTOL - * .AND. P5*RATIO .LE. ONE) INFO = 1 - IF (DELTA .LE. XTOL*XNORM) INFO = 2 - IF (ABS(ACTRED) .LE. FTOL .AND. PRERED .LE. FTOL - * .AND. P5*RATIO .LE. ONE .AND. INFO .EQ. 2) INFO = 3 - IF (INFO .NE. 0) GO TO 300 -C -C TESTS FOR TERMINATION AND STRINGENT TOLERANCES. -C - IF (NFEV .GE. MAXFEV) INFO = 5 - IF (ABS(ACTRED) .LE. EPSMCH .AND. PRERED .LE. EPSMCH - * .AND. P5*RATIO .LE. ONE) INFO = 6 - IF (DELTA .LE. EPSMCH*XNORM) INFO = 7 - IF (GNORM .LE. EPSMCH) INFO = 8 - IF (INFO .NE. 0) GO TO 300 -C -C END OF THE INNER LOOP. REPEAT IF ITERATION UNSUCCESSFUL. -C - IF (RATIO .LT. P0001) GO TO 200 -C -C END OF THE OUTER LOOP. -C - GO TO 30 - 300 CONTINUE -C -C TERMINATION, EITHER NORMAL OR USER IMPOSED. -C - IF (IFLAG .LT. 0) INFO = IFLAG - IFLAG = 0 - IF (NPRINT .GT. 0) CALL FCN(M,N,X,FVEC,IFLAG) - RETURN -C -C LAST CARD OF SUBROUTINE LMDIF. -C - END - SUBROUTINE LMDIF1(FCN,M,N,X,FVEC,TOL,INFO,IWA,WA,LWA) - INTEGER M,N,INFO,LWA - INTEGER IWA(N) - REAL TOL - REAL X(N),FVEC(M),WA(LWA) - EXTERNAL FCN -C ********** -C -C SUBROUTINE LMDIF1 -C -C THE PURPOSE OF LMDIF1 IS TO MINIMIZE THE SUM OF THE SQUARES OF -C M NONLINEAR FUNCTIONS IN N VARIABLES BY A MODIFICATION OF THE -C LEVENBERG-MARQUARDT ALGORITHM. THIS IS DONE BY USING THE MORE -C GENERAL LEAST-SQUARES SOLVER LMDIF. THE USER MUST PROVIDE A -C SUBROUTINE WHICH CALCULATES THE FUNCTIONS. THE JACOBIAN IS -C THEN CALCULATED BY A FORWARD-DIFFERENCE APPROXIMATION. -C -C THE SUBROUTINE STATEMENT IS -C -C SUBROUTINE LMDIF1(FCN,M,N,X,FVEC,TOL,INFO,IWA,WA,LWA) -C -C WHERE -C -C FCN IS THE NAME OF THE USER-SUPPLIED SUBROUTINE WHICH -C CALCULATES THE FUNCTIONS. FCN MUST BE DECLARED -C IN AN EXTERNAL STATEMENT IN THE USER CALLING -C PROGRAM, AND SHOULD BE WRITTEN AS FOLLOWS. -C -C SUBROUTINE FCN(M,N,X,FVEC,IFLAG) -C INTEGER M,N,IFLAG -C REAL X(N),FVEC(M) -C ---------- -C CALCULATE THE FUNCTIONS AT X AND -C RETURN THIS VECTOR IN FVEC. -C ---------- -C RETURN -C END -C -C THE VALUE OF IFLAG SHOULD NOT BE CHANGED BY FCN UNLESS -C THE USER WANTS TO TERMINATE EXECUTION OF LMDIF1. -C IN THIS CASE SET IFLAG TO A NEGATIVE INTEGER. -C -C M IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER -C OF FUNCTIONS. -C -C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER -C OF VARIABLES. N MUST NOT EXCEED M. -C -C X IS AN ARRAY OF LENGTH N. ON INPUT X MUST CONTAIN -C AN INITIAL ESTIMATE OF THE SOLUTION VECTOR. ON OUTPUT X -C CONTAINS THE FINAL ESTIMATE OF THE SOLUTION VECTOR. -C -C FVEC IS AN OUTPUT ARRAY OF LENGTH M WHICH CONTAINS -C THE FUNCTIONS EVALUATED AT THE OUTPUT X. -C -C TOL IS A NONNEGATIVE INPUT VARIABLE. TERMINATION OCCURS -C WHEN THE ALGORITHM ESTIMATES EITHER THAT THE RELATIVE -C ERROR IN THE SUM OF SQUARES IS AT MOST TOL OR THAT -C THE RELATIVE ERROR BETWEEN X AND THE SOLUTION IS AT -C MOST TOL. -C -C INFO IS AN INTEGER OUTPUT VARIABLE. IF THE USER HAS -C TERMINATED EXECUTION, INFO IS SET TO THE (NEGATIVE) -C VALUE OF IFLAG. SEE DESCRIPTION OF FCN. OTHERWISE, -C INFO IS SET AS FOLLOWS. -C -C INFO = 0 IMPROPER INPUT PARAMETERS. -C -C INFO = 1 ALGORITHM ESTIMATES THAT THE RELATIVE ERROR -C IN THE SUM OF SQUARES IS AT MOST TOL. -C -C INFO = 2 ALGORITHM ESTIMATES THAT THE RELATIVE ERROR -C BETWEEN X AND THE SOLUTION IS AT MOST TOL. -C -C INFO = 3 CONDITIONS FOR INFO = 1 AND INFO = 2 BOTH HOLD. -C -C INFO = 4 FVEC IS ORTHOGONAL TO THE COLUMNS OF THE -C JACOBIAN TO MACHINE PRECISION. -C -C INFO = 5 NUMBER OF CALLS TO FCN HAS REACHED OR -C EXCEEDED 200*(N+1). -C -C INFO = 6 TOL IS TOO SMALL. NO FURTHER REDUCTION IN -C THE SUM OF SQUARES IS POSSIBLE. -C -C INFO = 7 TOL IS TOO SMALL. NO FURTHER IMPROVEMENT IN -C THE APPROXIMATE SOLUTION X IS POSSIBLE. -C -C IWA IS AN INTEGER WORK ARRAY OF LENGTH N. -C -C WA IS A WORK ARRAY OF LENGTH LWA. -C -C LWA IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN -C M*N+5*N+M. -C -C SUBPROGRAMS CALLED -C -C USER-SUPPLIED ...... FCN -C -C MINPACK-SUPPLIED ... LMDIF -C -C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. -C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE -C -C ********** - INTEGER MAXFEV,MODE,MP5N,NFEV,NPRINT - REAL EPSFCN,FACTOR,FTOL,GTOL,XTOL,ZERO - DATA FACTOR,ZERO /1.0E2,0.0E0/ - INFO = 0 -C -C CHECK THE INPUT PARAMETERS FOR ERRORS. -C - IF (N .LE. 0 .OR. M .LT. N .OR. TOL .LT. ZERO - * .OR. LWA .LT. M*N + 5*N + M) GO TO 10 -C -C CALL LMDIF. -C - MAXFEV = 200*(N + 1) - FTOL = TOL - XTOL = TOL - GTOL = ZERO - EPSFCN = ZERO - MODE = 1 - NPRINT = 0 - MP5N = M + 5*N - CALL LMDIF(FCN,M,N,X,FVEC,FTOL,XTOL,GTOL,MAXFEV,EPSFCN,WA(1), - * MODE,FACTOR,NPRINT,INFO,NFEV,WA(MP5N+1),M,IWA, - * WA(N+1),WA(2*N+1),WA(3*N+1),WA(4*N+1),WA(5*N+1)) - IF (INFO .EQ. 8) INFO = 4 - 10 CONTINUE - RETURN -C -C LAST CARD OF SUBROUTINE LMDIF1. -C - END - SUBROUTINE LMPAR(N,R,LDR,IPVT,DIAG,QTB,DELTA,PAR,X,SDIAG,WA1, - * WA2) - INTEGER N,LDR - INTEGER IPVT(N) - REAL DELTA,PAR - REAL R(LDR,N),DIAG(N),QTB(N),X(N),SDIAG(N),WA1(N),WA2(N) -C ********** -C -C SUBROUTINE LMPAR -C -C GIVEN AN M BY N MATRIX A, AN N BY N NONSINGULAR DIAGONAL -C MATRIX D, AN M-VECTOR B, AND A POSITIVE NUMBER DELTA, -C THE PROBLEM IS TO DETERMINE A VALUE FOR THE PARAMETER -C PAR SUCH THAT IF X SOLVES THE SYSTEM -C -C A*X = B , SQRT(PAR)*D*X = 0 , -C -C IN THE LEAST SQUARES SENSE, AND DXNORM IS THE EUCLIDEAN -C NORM OF D*X, THEN EITHER PAR IS ZERO AND -C -C (DXNORM-DELTA) .LE. 0.1*DELTA , -C -C OR PAR IS POSITIVE AND -C -C ABS(DXNORM-DELTA) .LE. 0.1*DELTA . -C -C THIS SUBROUTINE COMPLETES THE SOLUTION OF THE PROBLEM -C IF IT IS PROVIDED WITH THE NECESSARY INFORMATION FROM THE -C QR FACTORIZATION, WITH COLUMN PIVOTING, OF A. THAT IS, IF -C A*P = Q*R, WHERE P IS A PERMUTATION MATRIX, Q HAS ORTHOGONAL -C COLUMNS, AND R IS AN UPPER TRIANGULAR MATRIX WITH DIAGONAL -C ELEMENTS OF NONINCREASING MAGNITUDE, THEN LMPAR EXPECTS -C THE FULL UPPER TRIANGLE OF R, THE PERMUTATION MATRIX P, -C AND THE FIRST N COMPONENTS OF (Q TRANSPOSE)*B. ON OUTPUT -C LMPAR ALSO PROVIDES AN UPPER TRIANGULAR MATRIX S SUCH THAT -C -C T T T -C P *(A *A + PAR*D*D)*P = S *S . -C -C S IS EMPLOYED WITHIN LMPAR AND MAY BE OF SEPARATE INTEREST. -C -C ONLY A FEW ITERATIONS ARE GENERALLY NEEDED FOR CONVERGENCE -C OF THE ALGORITHM. IF, HOWEVER, THE LIMIT OF 10 ITERATIONS -C IS REACHED, THEN THE OUTPUT PAR WILL CONTAIN THE BEST -C VALUE OBTAINED SO FAR. -C -C THE SUBROUTINE STATEMENT IS -C -C SUBROUTINE LMPAR(N,R,LDR,IPVT,DIAG,QTB,DELTA,PAR,X,SDIAG, -C WA1,WA2) -C -C WHERE -C -C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE ORDER OF R. -C -C R IS AN N BY N ARRAY. ON INPUT THE FULL UPPER TRIANGLE -C MUST CONTAIN THE FULL UPPER TRIANGLE OF THE MATRIX R. -C ON OUTPUT THE FULL UPPER TRIANGLE IS UNALTERED, AND THE -C STRICT LOWER TRIANGLE CONTAINS THE STRICT UPPER TRIANGLE -C (TRANSPOSED) OF THE UPPER TRIANGULAR MATRIX S. -C -C LDR IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN N -C WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY R. -C -C IPVT IS AN INTEGER INPUT ARRAY OF LENGTH N WHICH DEFINES THE -C PERMUTATION MATRIX P SUCH THAT A*P = Q*R. COLUMN J OF P -C IS COLUMN IPVT(J) OF THE IDENTITY MATRIX. -C -C DIAG IS AN INPUT ARRAY OF LENGTH N WHICH MUST CONTAIN THE -C DIAGONAL ELEMENTS OF THE MATRIX D. -C -C QTB IS AN INPUT ARRAY OF LENGTH N WHICH MUST CONTAIN THE FIRST -C N ELEMENTS OF THE VECTOR (Q TRANSPOSE)*B. -C -C DELTA IS A POSITIVE INPUT VARIABLE WHICH SPECIFIES AN UPPER -C BOUND ON THE EUCLIDEAN NORM OF D*X. -C -C PAR IS A NONNEGATIVE VARIABLE. ON INPUT PAR CONTAINS AN -C INITIAL ESTIMATE OF THE LEVENBERG-MARQUARDT PARAMETER. -C ON OUTPUT PAR CONTAINS THE FINAL ESTIMATE. -C -C X IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE LEAST -C SQUARES SOLUTION OF THE SYSTEM A*X = B, SQRT(PAR)*D*X = 0, -C FOR THE OUTPUT PAR. -C -C SDIAG IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE -C DIAGONAL ELEMENTS OF THE UPPER TRIANGULAR MATRIX S. -C -C WA1 AND WA2 ARE WORK ARRAYS OF LENGTH N. -C -C SUBPROGRAMS CALLED -C -C MINPACK-SUPPLIED ... SPMPAR,ENORM,QRSOLV -C -C FORTRAN-SUPPLIED ... ABS,AMAX1,AMIN1,SQRT -C -C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. -C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE -C -C ********** - INTEGER I,ITER,J,JM1,JP1,K,L,NSING - REAL DXNORM,DWARF,FP,GNORM,PARC,PARL,PARU,P1,P001,SUM,TEMP,ZERO - REAL SPMPAR,ENORM - DATA P1,P001,ZERO /1.0E-1,1.0E-3,0.0E0/ -C -C DWARF IS THE SMALLEST POSITIVE MAGNITUDE. -C - DWARF = SPMPAR(2) -C -C COMPUTE AND STORE IN X THE GAUSS-NEWTON DIRECTION. IF THE -C JACOBIAN IS RANK-DEFICIENT, OBTAIN A LEAST SQUARES SOLUTION. -C - NSING = N - DO 10 J = 1, N - WA1(J) = QTB(J) - IF (R(J,J) .EQ. ZERO .AND. NSING .EQ. N) NSING = J - 1 - IF (NSING .LT. N) WA1(J) = ZERO - 10 CONTINUE - IF (NSING .LT. 1) GO TO 50 - DO 40 K = 1, NSING - J = NSING - K + 1 - WA1(J) = WA1(J)/R(J,J) - TEMP = WA1(J) - JM1 = J - 1 - IF (JM1 .LT. 1) GO TO 30 - DO 20 I = 1, JM1 - WA1(I) = WA1(I) - R(I,J)*TEMP - 20 CONTINUE - 30 CONTINUE - 40 CONTINUE - 50 CONTINUE - DO 60 J = 1, N - L = IPVT(J) - X(L) = WA1(J) - 60 CONTINUE -C -C INITIALIZE THE ITERATION COUNTER. -C EVALUATE THE FUNCTION AT THE ORIGIN, AND TEST -C FOR ACCEPTANCE OF THE GAUSS-NEWTON DIRECTION. -C - ITER = 0 - DO 70 J = 1, N - WA2(J) = DIAG(J)*X(J) - 70 CONTINUE - DXNORM = ENORM(N,WA2) - FP = DXNORM - DELTA - IF (FP .LE. P1*DELTA) GO TO 220 -C -C IF THE JACOBIAN IS NOT RANK DEFICIENT, THE NEWTON -C STEP PROVIDES A LOWER BOUND, PARL, FOR THE ZERO OF -C THE FUNCTION. OTHERWISE SET THIS BOUND TO ZERO. -C - PARL = ZERO - IF (NSING .LT. N) GO TO 120 - DO 80 J = 1, N - L = IPVT(J) - WA1(J) = DIAG(L)*(WA2(L)/DXNORM) - 80 CONTINUE - DO 110 J = 1, N - SUM = ZERO - JM1 = J - 1 - IF (JM1 .LT. 1) GO TO 100 - DO 90 I = 1, JM1 - SUM = SUM + R(I,J)*WA1(I) - 90 CONTINUE - 100 CONTINUE - WA1(J) = (WA1(J) - SUM)/R(J,J) - 110 CONTINUE - TEMP = ENORM(N,WA1) - PARL = ((FP/DELTA)/TEMP)/TEMP - 120 CONTINUE -C -C CALCULATE AN UPPER BOUND, PARU, FOR THE ZERO OF THE FUNCTION. -C - DO 140 J = 1, N - SUM = ZERO - DO 130 I = 1, J - SUM = SUM + R(I,J)*QTB(I) - 130 CONTINUE - L = IPVT(J) - WA1(J) = SUM/DIAG(L) - 140 CONTINUE - GNORM = ENORM(N,WA1) - PARU = GNORM/DELTA - IF (PARU .EQ. ZERO) PARU = DWARF/AMIN1(DELTA,P1) -C -C IF THE INPUT PAR LIES OUTSIDE OF THE INTERVAL (PARL,PARU), -C SET PAR TO THE CLOSER ENDPOINT. -C - PAR = AMAX1(PAR,PARL) - PAR = AMIN1(PAR,PARU) - IF (PAR .EQ. ZERO) PAR = GNORM/DXNORM -C -C BEGINNING OF AN ITERATION. -C - 150 CONTINUE - ITER = ITER + 1 -C -C EVALUATE THE FUNCTION AT THE CURRENT VALUE OF PAR. -C - IF (PAR .EQ. ZERO) PAR = AMAX1(DWARF,P001*PARU) - TEMP = SQRT(PAR) - DO 160 J = 1, N - WA1(J) = TEMP*DIAG(J) - 160 CONTINUE - CALL QRSOLV(N,R,LDR,IPVT,WA1,QTB,X,SDIAG,WA2) - DO 170 J = 1, N - WA2(J) = DIAG(J)*X(J) - 170 CONTINUE - DXNORM = ENORM(N,WA2) - TEMP = FP - FP = DXNORM - DELTA -C -C IF THE FUNCTION IS SMALL ENOUGH, ACCEPT THE CURRENT VALUE -C OF PAR. ALSO TEST FOR THE EXCEPTIONAL CASES WHERE PARL -C IS ZERO OR THE NUMBER OF ITERATIONS HAS REACHED 10. -C - IF (ABS(FP) .LE. P1*DELTA - * .OR. PARL .EQ. ZERO .AND. FP .LE. TEMP - * .AND. TEMP .LT. ZERO .OR. ITER .EQ. 10) GO TO 220 -C -C COMPUTE THE NEWTON CORRECTION. -C - DO 180 J = 1, N - L = IPVT(J) - WA1(J) = DIAG(L)*(WA2(L)/DXNORM) - 180 CONTINUE - DO 210 J = 1, N - WA1(J) = WA1(J)/SDIAG(J) - TEMP = WA1(J) - JP1 = J + 1 - IF (N .LT. JP1) GO TO 200 - DO 190 I = JP1, N - WA1(I) = WA1(I) - R(I,J)*TEMP - 190 CONTINUE - 200 CONTINUE - 210 CONTINUE - TEMP = ENORM(N,WA1) - PARC = ((FP/DELTA)/TEMP)/TEMP -C -C DEPENDING ON THE SIGN OF THE FUNCTION, UPDATE PARL OR PARU. -C - IF (FP .GT. ZERO) PARL = AMAX1(PARL,PAR) - IF (FP .LT. ZERO) PARU = AMIN1(PARU,PAR) -C -C COMPUTE AN IMPROVED ESTIMATE FOR PAR. -C - PAR = AMAX1(PARL,PAR+PARC) -C -C END OF AN ITERATION. -C - GO TO 150 - 220 CONTINUE -C -C TERMINATION. -C - IF (ITER .EQ. 0) PAR = ZERO - RETURN -C -C LAST CARD OF SUBROUTINE LMPAR. -C - END - SUBROUTINE LMSTR(FCN,M,N,X,FVEC,FJAC,LDFJAC,FTOL,XTOL,GTOL, - * MAXFEV,DIAG,MODE,FACTOR,NPRINT,INFO,NFEV,NJEV, - * IPVT,QTF,WA1,WA2,WA3,WA4) - INTEGER M,N,LDFJAC,MAXFEV,MODE,NPRINT,INFO,NFEV,NJEV - INTEGER IPVT(N) - LOGICAL SING - REAL FTOL,XTOL,GTOL,FACTOR - REAL X(N),FVEC(M),FJAC(LDFJAC,N),DIAG(N),QTF(N),WA1(N),WA2(N), - * WA3(N),WA4(M) -C ********** -C -C SUBROUTINE LMSTR -C -C THE PURPOSE OF LMSTR IS TO MINIMIZE THE SUM OF THE SQUARES OF -C M NONLINEAR FUNCTIONS IN N VARIABLES BY A MODIFICATION OF -C THE LEVENBERG-MARQUARDT ALGORITHM WHICH USES MINIMAL STORAGE. -C THE USER MUST PROVIDE A SUBROUTINE WHICH CALCULATES THE -C FUNCTIONS AND THE ROWS OF THE JACOBIAN. -C -C THE SUBROUTINE STATEMENT IS -C -C SUBROUTINE LMSTR(FCN,M,N,X,FVEC,FJAC,LDFJAC,FTOL,XTOL,GTOL, -C MAXFEV,DIAG,MODE,FACTOR,NPRINT,INFO,NFEV, -C NJEV,IPVT,QTF,WA1,WA2,WA3,WA4) -C -C WHERE -C -C FCN IS THE NAME OF THE USER-SUPPLIED SUBROUTINE WHICH -C CALCULATES THE FUNCTIONS AND THE ROWS OF THE JACOBIAN. -C FCN MUST BE DECLARED IN AN EXTERNAL STATEMENT IN THE -C USER CALLING PROGRAM, AND SHOULD BE WRITTEN AS FOLLOWS. -C -C SUBROUTINE FCN(M,N,X,FVEC,FJROW,IFLAG) -C INTEGER M,N,IFLAG -C REAL X(N),FVEC(M),FJROW(N) -C ---------- -C IF IFLAG = 1 CALCULATE THE FUNCTIONS AT X AND -C RETURN THIS VECTOR IN FVEC. -C IF IFLAG = I CALCULATE THE (I-1)-ST ROW OF THE -C JACOBIAN AT X AND RETURN THIS VECTOR IN FJROW. -C ---------- -C RETURN -C END -C -C THE VALUE OF IFLAG SHOULD NOT BE CHANGED BY FCN UNLESS -C THE USER WANTS TO TERMINATE EXECUTION OF LMSTR. -C IN THIS CASE SET IFLAG TO A NEGATIVE INTEGER. -C -C M IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER -C OF FUNCTIONS. -C -C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER -C OF VARIABLES. N MUST NOT EXCEED M. -C -C X IS AN ARRAY OF LENGTH N. ON INPUT X MUST CONTAIN -C AN INITIAL ESTIMATE OF THE SOLUTION VECTOR. ON OUTPUT X -C CONTAINS THE FINAL ESTIMATE OF THE SOLUTION VECTOR. -C -C FVEC IS AN OUTPUT ARRAY OF LENGTH M WHICH CONTAINS -C THE FUNCTIONS EVALUATED AT THE OUTPUT X. -C -C FJAC IS AN OUTPUT N BY N ARRAY. THE UPPER TRIANGLE OF FJAC -C CONTAINS AN UPPER TRIANGULAR MATRIX R SUCH THAT -C -C T T T -C P *(JAC *JAC)*P = R *R, -C -C WHERE P IS A PERMUTATION MATRIX AND JAC IS THE FINAL -C CALCULATED JACOBIAN. COLUMN J OF P IS COLUMN IPVT(J) -C (SEE BELOW) OF THE IDENTITY MATRIX. THE LOWER TRIANGULAR -C PART OF FJAC CONTAINS INFORMATION GENERATED DURING -C THE COMPUTATION OF R. -C -C LDFJAC IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN N -C WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY FJAC. -C -C FTOL IS A NONNEGATIVE INPUT VARIABLE. TERMINATION -C OCCURS WHEN BOTH THE ACTUAL AND PREDICTED RELATIVE -C REDUCTIONS IN THE SUM OF SQUARES ARE AT MOST FTOL. -C THEREFORE, FTOL MEASURES THE RELATIVE ERROR DESIRED -C IN THE SUM OF SQUARES. -C -C XTOL IS A NONNEGATIVE INPUT VARIABLE. TERMINATION -C OCCURS WHEN THE RELATIVE ERROR BETWEEN TWO CONSECUTIVE -C ITERATES IS AT MOST XTOL. THEREFORE, XTOL MEASURES THE -C RELATIVE ERROR DESIRED IN THE APPROXIMATE SOLUTION. -C -C GTOL IS A NONNEGATIVE INPUT VARIABLE. TERMINATION -C OCCURS WHEN THE COSINE OF THE ANGLE BETWEEN FVEC AND -C ANY COLUMN OF THE JACOBIAN IS AT MOST GTOL IN ABSOLUTE -C VALUE. THEREFORE, GTOL MEASURES THE ORTHOGONALITY -C DESIRED BETWEEN THE FUNCTION VECTOR AND THE COLUMNS -C OF THE JACOBIAN. -C -C MAXFEV IS A POSITIVE INTEGER INPUT VARIABLE. TERMINATION -C OCCURS WHEN THE NUMBER OF CALLS TO FCN WITH IFLAG = 1 -C HAS REACHED MAXFEV. -C -C DIAG IS AN ARRAY OF LENGTH N. IF MODE = 1 (SEE -C BELOW), DIAG IS INTERNALLY SET. IF MODE = 2, DIAG -C MUST CONTAIN POSITIVE ENTRIES THAT SERVE AS -C MULTIPLICATIVE SCALE FACTORS FOR THE VARIABLES. -C -C MODE IS AN INTEGER INPUT VARIABLE. IF MODE = 1, THE -C VARIABLES WILL BE SCALED INTERNALLY. IF MODE = 2, -C THE SCALING IS SPECIFIED BY THE INPUT DIAG. OTHER -C VALUES OF MODE ARE EQUIVALENT TO MODE = 1. -C -C FACTOR IS A POSITIVE INPUT VARIABLE USED IN DETERMINING THE -C INITIAL STEP BOUND. THIS BOUND IS SET TO THE PRODUCT OF -C FACTOR AND THE EUCLIDEAN NORM OF DIAG*X IF NONZERO, OR ELSE -C TO FACTOR ITSELF. IN MOST CASES FACTOR SHOULD LIE IN THE -C INTERVAL (.1,100.). 100. IS A GENERALLY RECOMMENDED VALUE. -C -C NPRINT IS AN INTEGER INPUT VARIABLE THAT ENABLES CONTROLLED -C PRINTING OF ITERATES IF IT IS POSITIVE. IN THIS CASE, -C FCN IS CALLED WITH IFLAG = 0 AT THE BEGINNING OF THE FIRST -C ITERATION AND EVERY NPRINT ITERATIONS THEREAFTER AND -C IMMEDIATELY PRIOR TO RETURN, WITH X AND FVEC AVAILABLE -C FOR PRINTING. IF NPRINT IS NOT POSITIVE, NO SPECIAL CALLS -C OF FCN WITH IFLAG = 0 ARE MADE. -C -C INFO IS AN INTEGER OUTPUT VARIABLE. IF THE USER HAS -C TERMINATED EXECUTION, INFO IS SET TO THE (NEGATIVE) -C VALUE OF IFLAG. SEE DESCRIPTION OF FCN. OTHERWISE, -C INFO IS SET AS FOLLOWS. -C -C INFO = 0 IMPROPER INPUT PARAMETERS. -C -C INFO = 1 BOTH ACTUAL AND PREDICTED RELATIVE REDUCTIONS -C IN THE SUM OF SQUARES ARE AT MOST FTOL. -C -C INFO = 2 RELATIVE ERROR BETWEEN TWO CONSECUTIVE ITERATES -C IS AT MOST XTOL. -C -C INFO = 3 CONDITIONS FOR INFO = 1 AND INFO = 2 BOTH HOLD. -C -C INFO = 4 THE COSINE OF THE ANGLE BETWEEN FVEC AND ANY -C COLUMN OF THE JACOBIAN IS AT MOST GTOL IN -C ABSOLUTE VALUE. -C -C INFO = 5 NUMBER OF CALLS TO FCN WITH IFLAG = 1 HAS -C REACHED MAXFEV. -C -C INFO = 6 FTOL IS TOO SMALL. NO FURTHER REDUCTION IN -C THE SUM OF SQUARES IS POSSIBLE. -C -C INFO = 7 XTOL IS TOO SMALL. NO FURTHER IMPROVEMENT IN -C THE APPROXIMATE SOLUTION X IS POSSIBLE. -C -C INFO = 8 GTOL IS TOO SMALL. FVEC IS ORTHOGONAL TO THE -C COLUMNS OF THE JACOBIAN TO MACHINE PRECISION. -C -C NFEV IS AN INTEGER OUTPUT VARIABLE SET TO THE NUMBER OF -C CALLS TO FCN WITH IFLAG = 1. -C -C NJEV IS AN INTEGER OUTPUT VARIABLE SET TO THE NUMBER OF -C CALLS TO FCN WITH IFLAG = 2. -C -C IPVT IS AN INTEGER OUTPUT ARRAY OF LENGTH N. IPVT -C DEFINES A PERMUTATION MATRIX P SUCH THAT JAC*P = Q*R, -C WHERE JAC IS THE FINAL CALCULATED JACOBIAN, Q IS -C ORTHOGONAL (NOT STORED), AND R IS UPPER TRIANGULAR. -C COLUMN J OF P IS COLUMN IPVT(J) OF THE IDENTITY MATRIX. -C -C QTF IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS -C THE FIRST N ELEMENTS OF THE VECTOR (Q TRANSPOSE)*FVEC. -C -C WA1, WA2, AND WA3 ARE WORK ARRAYS OF LENGTH N. -C -C WA4 IS A WORK ARRAY OF LENGTH M. -C -C SUBPROGRAMS CALLED -C -C USER-SUPPLIED ...... FCN -C -C MINPACK-SUPPLIED ... SPMPAR,ENORM,LMPAR,QRFAC,RWUPDT -C -C FORTRAN-SUPPLIED ... ABS,AMAX1,AMIN1,SQRT,MOD -C -C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. -C BURTON S. GARBOW, DUDLEY V. GOETSCHEL, KENNETH E. HILLSTROM, -C JORGE J. MORE -C -C ********** - INTEGER I,IFLAG,ITER,J,L - REAL ACTRED,DELTA,DIRDER,EPSMCH,FNORM,FNORM1,GNORM,ONE,PAR, - * PNORM,PRERED,P1,P5,P25,P75,P0001,RATIO,SUM,TEMP,TEMP1, - * TEMP2,XNORM,ZERO - REAL SPMPAR,ENORM - DATA ONE,P1,P5,P25,P75,P0001,ZERO - * /1.0E0,1.0E-1,5.0E-1,2.5E-1,7.5E-1,1.0E-4,0.0E0/ -C -C EPSMCH IS THE MACHINE PRECISION. -C - EPSMCH = SPMPAR(1) -C - INFO = 0 - IFLAG = 0 - NFEV = 0 - NJEV = 0 -C -C CHECK THE INPUT PARAMETERS FOR ERRORS. -C - IF (N .LE. 0 .OR. M .LT. N .OR. LDFJAC .LT. N - * .OR. FTOL .LT. ZERO .OR. XTOL .LT. ZERO .OR. GTOL .LT. ZERO - * .OR. MAXFEV .LE. 0 .OR. FACTOR .LE. ZERO) GO TO 340 - IF (MODE .NE. 2) GO TO 20 - DO 10 J = 1, N - IF (DIAG(J) .LE. ZERO) GO TO 340 - 10 CONTINUE - 20 CONTINUE -C -C EVALUATE THE FUNCTION AT THE STARTING POINT -C AND CALCULATE ITS NORM. -C - IFLAG = 1 - CALL FCN(M,N,X,FVEC,WA3,IFLAG) - NFEV = 1 - IF (IFLAG .LT. 0) GO TO 340 - FNORM = ENORM(M,FVEC) -C -C INITIALIZE LEVENBERG-MARQUARDT PARAMETER AND ITERATION COUNTER. -C - PAR = ZERO - ITER = 1 -C -C BEGINNING OF THE OUTER LOOP. -C - 30 CONTINUE -C -C IF REQUESTED, CALL FCN TO ENABLE PRINTING OF ITERATES. -C - IF (NPRINT .LE. 0) GO TO 40 - IFLAG = 0 - IF (MOD(ITER-1,NPRINT) .EQ. 0) CALL FCN(M,N,X,FVEC,WA3,IFLAG) - IF (IFLAG .LT. 0) GO TO 340 - 40 CONTINUE -C -C COMPUTE THE QR FACTORIZATION OF THE JACOBIAN MATRIX -C CALCULATED ONE ROW AT A TIME, WHILE SIMULTANEOUSLY -C FORMING (Q TRANSPOSE)*FVEC AND STORING THE FIRST -C N COMPONENTS IN QTF. -C - DO 60 J = 1, N - QTF(J) = ZERO - DO 50 I = 1, N - FJAC(I,J) = ZERO - 50 CONTINUE - 60 CONTINUE - IFLAG = 2 - DO 70 I = 1, M - CALL FCN(M,N,X,FVEC,WA3,IFLAG) - IF (IFLAG .LT. 0) GO TO 340 - TEMP = FVEC(I) - CALL RWUPDT(N,FJAC,LDFJAC,WA3,QTF,TEMP,WA1,WA2) - IFLAG = IFLAG + 1 - 70 CONTINUE - NJEV = NJEV + 1 -C -C IF THE JACOBIAN IS RANK DEFICIENT, CALL QRFAC TO -C REORDER ITS COLUMNS AND UPDATE THE COMPONENTS OF QTF. -C - SING = .FALSE. - DO 80 J = 1, N - IF (FJAC(J,J) .EQ. ZERO) SING = .TRUE. - IPVT(J) = J - WA2(J) = ENORM(J,FJAC(1,J)) - 80 CONTINUE - IF (.NOT.SING) GO TO 130 - CALL QRFAC(N,N,FJAC,LDFJAC,.TRUE.,IPVT,N,WA1,WA2,WA3) - DO 120 J = 1, N - IF (FJAC(J,J) .EQ. ZERO) GO TO 110 - SUM = ZERO - DO 90 I = J, N - SUM = SUM + FJAC(I,J)*QTF(I) - 90 CONTINUE - TEMP = -SUM/FJAC(J,J) - DO 100 I = J, N - QTF(I) = QTF(I) + FJAC(I,J)*TEMP - 100 CONTINUE - 110 CONTINUE - FJAC(J,J) = WA1(J) - 120 CONTINUE - 130 CONTINUE -C -C ON THE FIRST ITERATION AND IF MODE IS 1, SCALE ACCORDING -C TO THE NORMS OF THE COLUMNS OF THE INITIAL JACOBIAN. -C - IF (ITER .NE. 1) GO TO 170 - IF (MODE .EQ. 2) GO TO 150 - DO 140 J = 1, N - DIAG(J) = WA2(J) - IF (WA2(J) .EQ. ZERO) DIAG(J) = ONE - 140 CONTINUE - 150 CONTINUE -C -C ON THE FIRST ITERATION, CALCULATE THE NORM OF THE SCALED X -C AND INITIALIZE THE STEP BOUND DELTA. -C - DO 160 J = 1, N - WA3(J) = DIAG(J)*X(J) - 160 CONTINUE - XNORM = ENORM(N,WA3) - DELTA = FACTOR*XNORM - IF (DELTA .EQ. ZERO) DELTA = FACTOR - 170 CONTINUE -C -C COMPUTE THE NORM OF THE SCALED GRADIENT. -C - GNORM = ZERO - IF (FNORM .EQ. ZERO) GO TO 210 - DO 200 J = 1, N - L = IPVT(J) - IF (WA2(L) .EQ. ZERO) GO TO 190 - SUM = ZERO - DO 180 I = 1, J - SUM = SUM + FJAC(I,J)*(QTF(I)/FNORM) - 180 CONTINUE - GNORM = AMAX1(GNORM,ABS(SUM/WA2(L))) - 190 CONTINUE - 200 CONTINUE - 210 CONTINUE -C -C TEST FOR CONVERGENCE OF THE GRADIENT NORM. -C - IF (GNORM .LE. GTOL) INFO = 4 - IF (INFO .NE. 0) GO TO 340 -C -C RESCALE IF NECESSARY. -C - IF (MODE .EQ. 2) GO TO 230 - DO 220 J = 1, N - DIAG(J) = AMAX1(DIAG(J),WA2(J)) - 220 CONTINUE - 230 CONTINUE -C -C BEGINNING OF THE INNER LOOP. -C - 240 CONTINUE -C -C DETERMINE THE LEVENBERG-MARQUARDT PARAMETER. -C - CALL LMPAR(N,FJAC,LDFJAC,IPVT,DIAG,QTF,DELTA,PAR,WA1,WA2, - * WA3,WA4) -C -C STORE THE DIRECTION P AND X + P. CALCULATE THE NORM OF P. -C - DO 250 J = 1, N - WA1(J) = -WA1(J) - WA2(J) = X(J) + WA1(J) - WA3(J) = DIAG(J)*WA1(J) - 250 CONTINUE - PNORM = ENORM(N,WA3) -C -C ON THE FIRST ITERATION, ADJUST THE INITIAL STEP BOUND. -C - IF (ITER .EQ. 1) DELTA = AMIN1(DELTA,PNORM) -C -C EVALUATE THE FUNCTION AT X + P AND CALCULATE ITS NORM. -C - IFLAG = 1 - CALL FCN(M,N,WA2,WA4,WA3,IFLAG) - NFEV = NFEV + 1 - IF (IFLAG .LT. 0) GO TO 340 - FNORM1 = ENORM(M,WA4) -C -C COMPUTE THE SCALED ACTUAL REDUCTION. -C - ACTRED = -ONE - IF (P1*FNORM1 .LT. FNORM) ACTRED = ONE - (FNORM1/FNORM)**2 -C -C COMPUTE THE SCALED PREDICTED REDUCTION AND -C THE SCALED DIRECTIONAL DERIVATIVE. -C - DO 270 J = 1, N - WA3(J) = ZERO - L = IPVT(J) - TEMP = WA1(L) - DO 260 I = 1, J - WA3(I) = WA3(I) + FJAC(I,J)*TEMP - 260 CONTINUE - 270 CONTINUE - TEMP1 = ENORM(N,WA3)/FNORM - TEMP2 = (SQRT(PAR)*PNORM)/FNORM - PRERED = TEMP1**2 + TEMP2**2/P5 - DIRDER = -(TEMP1**2 + TEMP2**2) -C -C COMPUTE THE RATIO OF THE ACTUAL TO THE PREDICTED -C REDUCTION. -C - RATIO = ZERO - IF (PRERED .NE. ZERO) RATIO = ACTRED/PRERED -C -C UPDATE THE STEP BOUND. -C - IF (RATIO .GT. P25) GO TO 280 - IF (ACTRED .GE. ZERO) TEMP = P5 - IF (ACTRED .LT. ZERO) - * TEMP = P5*DIRDER/(DIRDER + P5*ACTRED) - IF (P1*FNORM1 .GE. FNORM .OR. TEMP .LT. P1) TEMP = P1 - DELTA = TEMP*AMIN1(DELTA,PNORM/P1) - PAR = PAR/TEMP - GO TO 300 - 280 CONTINUE - IF (PAR .NE. ZERO .AND. RATIO .LT. P75) GO TO 290 - DELTA = PNORM/P5 - PAR = P5*PAR - 290 CONTINUE - 300 CONTINUE -C -C TEST FOR SUCCESSFUL ITERATION. -C - IF (RATIO .LT. P0001) GO TO 330 -C -C SUCCESSFUL ITERATION. UPDATE X, FVEC, AND THEIR NORMS. -C - DO 310 J = 1, N - X(J) = WA2(J) - WA2(J) = DIAG(J)*X(J) - 310 CONTINUE - DO 320 I = 1, M - FVEC(I) = WA4(I) - 320 CONTINUE - XNORM = ENORM(N,WA2) - FNORM = FNORM1 - ITER = ITER + 1 - 330 CONTINUE -C -C TESTS FOR CONVERGENCE. -C - IF (ABS(ACTRED) .LE. FTOL .AND. PRERED .LE. FTOL - * .AND. P5*RATIO .LE. ONE) INFO = 1 - IF (DELTA .LE. XTOL*XNORM) INFO = 2 - IF (ABS(ACTRED) .LE. FTOL .AND. PRERED .LE. FTOL - * .AND. P5*RATIO .LE. ONE .AND. INFO .EQ. 2) INFO = 3 - IF (INFO .NE. 0) GO TO 340 -C -C TESTS FOR TERMINATION AND STRINGENT TOLERANCES. -C - IF (NFEV .GE. MAXFEV) INFO = 5 - IF (ABS(ACTRED) .LE. EPSMCH .AND. PRERED .LE. EPSMCH - * .AND. P5*RATIO .LE. ONE) INFO = 6 - IF (DELTA .LE. EPSMCH*XNORM) INFO = 7 - IF (GNORM .LE. EPSMCH) INFO = 8 - IF (INFO .NE. 0) GO TO 340 -C -C END OF THE INNER LOOP. REPEAT IF ITERATION UNSUCCESSFUL. -C - IF (RATIO .LT. P0001) GO TO 240 -C -C END OF THE OUTER LOOP. -C - GO TO 30 - 340 CONTINUE -C -C TERMINATION, EITHER NORMAL OR USER IMPOSED. -C - IF (IFLAG .LT. 0) INFO = IFLAG - IFLAG = 0 - IF (NPRINT .GT. 0) CALL FCN(M,N,X,FVEC,WA3,IFLAG) - RETURN -C -C LAST CARD OF SUBROUTINE LMSTR. -C - END - SUBROUTINE LMSTR1(FCN,M,N,X,FVEC,FJAC,LDFJAC,TOL,INFO,IPVT,WA, - * LWA) - INTEGER M,N,LDFJAC,INFO,LWA - INTEGER IPVT(N) - REAL TOL - REAL X(N),FVEC(M),FJAC(LDFJAC,N),WA(LWA) - EXTERNAL FCN -C ********** -C -C SUBROUTINE LMSTR1 -C -C THE PURPOSE OF LMSTR1 IS TO MINIMIZE THE SUM OF THE SQUARES OF -C M NONLINEAR FUNCTIONS IN N VARIABLES BY A MODIFICATION OF -C THE LEVENBERG-MARQUARDT ALGORITHM WHICH USES MINIMAL STORAGE. -C THIS IS DONE BY USING THE MORE GENERAL LEAST-SQUARES SOLVER -C LMSTR. THE USER MUST PROVIDE A SUBROUTINE WHICH CALCULATES -C THE FUNCTIONS AND THE ROWS OF THE JACOBIAN. -C -C THE SUBROUTINE STATEMENT IS -C -C SUBROUTINE LMSTR1(FCN,M,N,X,FVEC,FJAC,LDFJAC,TOL,INFO, -C IPVT,WA,LWA) -C -C WHERE -C -C FCN IS THE NAME OF THE USER-SUPPLIED SUBROUTINE WHICH -C CALCULATES THE FUNCTIONS AND THE ROWS OF THE JACOBIAN. -C FCN MUST BE DECLARED IN AN EXTERNAL STATEMENT IN THE -C USER CALLING PROGRAM, AND SHOULD BE WRITTEN AS FOLLOWS. -C -C SUBROUTINE FCN(M,N,X,FVEC,FJROW,IFLAG) -C INTEGER M,N,IFLAG -C REAL X(N),FVEC(M),FJROW(N) -C ---------- -C IF IFLAG = 1 CALCULATE THE FUNCTIONS AT X AND -C RETURN THIS VECTOR IN FVEC. -C IF IFLAG = I CALCULATE THE (I-1)-ST ROW OF THE -C JACOBIAN AT X AND RETURN THIS VECTOR IN FJROW. -C ---------- -C RETURN -C END -C -C THE VALUE OF IFLAG SHOULD NOT BE CHANGED BY FCN UNLESS -C THE USER WANTS TO TERMINATE EXECUTION OF LMSTR1. -C IN THIS CASE SET IFLAG TO A NEGATIVE INTEGER. -C -C M IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER -C OF FUNCTIONS. -C -C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER -C OF VARIABLES. N MUST NOT EXCEED M. -C -C X IS AN ARRAY OF LENGTH N. ON INPUT X MUST CONTAIN -C AN INITIAL ESTIMATE OF THE SOLUTION VECTOR. ON OUTPUT X -C CONTAINS THE FINAL ESTIMATE OF THE SOLUTION VECTOR. -C -C FVEC IS AN OUTPUT ARRAY OF LENGTH M WHICH CONTAINS -C THE FUNCTIONS EVALUATED AT THE OUTPUT X. -C -C FJAC IS AN OUTPUT N BY N ARRAY. THE UPPER TRIANGLE OF FJAC -C CONTAINS AN UPPER TRIANGULAR MATRIX R SUCH THAT -C -C T T T -C P *(JAC *JAC)*P = R *R, -C -C WHERE P IS A PERMUTATION MATRIX AND JAC IS THE FINAL -C CALCULATED JACOBIAN. COLUMN J OF P IS COLUMN IPVT(J) -C (SEE BELOW) OF THE IDENTITY MATRIX. THE LOWER TRIANGULAR -C PART OF FJAC CONTAINS INFORMATION GENERATED DURING -C THE COMPUTATION OF R. -C -C LDFJAC IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN N -C WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY FJAC. -C -C TOL IS A NONNEGATIVE INPUT VARIABLE. TERMINATION OCCURS -C WHEN THE ALGORITHM ESTIMATES EITHER THAT THE RELATIVE -C ERROR IN THE SUM OF SQUARES IS AT MOST TOL OR THAT -C THE RELATIVE ERROR BETWEEN X AND THE SOLUTION IS AT -C MOST TOL. -C -C INFO IS AN INTEGER OUTPUT VARIABLE. IF THE USER HAS -C TERMINATED EXECUTION, INFO IS SET TO THE (NEGATIVE) -C VALUE OF IFLAG. SEE DESCRIPTION OF FCN. OTHERWISE, -C INFO IS SET AS FOLLOWS. -C -C INFO = 0 IMPROPER INPUT PARAMETERS. -C -C INFO = 1 ALGORITHM ESTIMATES THAT THE RELATIVE ERROR -C IN THE SUM OF SQUARES IS AT MOST TOL. -C -C INFO = 2 ALGORITHM ESTIMATES THAT THE RELATIVE ERROR -C BETWEEN X AND THE SOLUTION IS AT MOST TOL. -C -C INFO = 3 CONDITIONS FOR INFO = 1 AND INFO = 2 BOTH HOLD. -C -C INFO = 4 FVEC IS ORTHOGONAL TO THE COLUMNS OF THE -C JACOBIAN TO MACHINE PRECISION. -C -C INFO = 5 NUMBER OF CALLS TO FCN WITH IFLAG = 1 HAS -C REACHED 100*(N+1). -C -C INFO = 6 TOL IS TOO SMALL. NO FURTHER REDUCTION IN -C THE SUM OF SQUARES IS POSSIBLE. -C -C INFO = 7 TOL IS TOO SMALL. NO FURTHER IMPROVEMENT IN -C THE APPROXIMATE SOLUTION X IS POSSIBLE. -C -C IPVT IS AN INTEGER OUTPUT ARRAY OF LENGTH N. IPVT -C DEFINES A PERMUTATION MATRIX P SUCH THAT JAC*P = Q*R, -C WHERE JAC IS THE FINAL CALCULATED JACOBIAN, Q IS -C ORTHOGONAL (NOT STORED), AND R IS UPPER TRIANGULAR. -C COLUMN J OF P IS COLUMN IPVT(J) OF THE IDENTITY MATRIX. -C -C WA IS A WORK ARRAY OF LENGTH LWA. -C -C LWA IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN 5*N+M. -C -C SUBPROGRAMS CALLED -C -C USER-SUPPLIED ...... FCN -C -C MINPACK-SUPPLIED ... LMSTR -C -C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. -C BURTON S. GARBOW, DUDLEY V. GOETSCHEL, KENNETH E. HILLSTROM, -C JORGE J. MORE -C -C ********** - INTEGER MAXFEV,MODE,NFEV,NJEV,NPRINT - REAL FACTOR,FTOL,GTOL,XTOL,ZERO - DATA FACTOR,ZERO /1.0E2,0.0E0/ - INFO = 0 -C -C CHECK THE INPUT PARAMETERS FOR ERRORS. -C - IF (N .LE. 0 .OR. M .LT. N .OR. LDFJAC .LT. N .OR. TOL .LT. ZERO - * .OR. LWA .LT. 5*N + M) GO TO 10 -C -C CALL LMSTR. -C - MAXFEV = 100*(N + 1) - FTOL = TOL - XTOL = TOL - GTOL = ZERO - MODE = 1 - NPRINT = 0 - CALL LMSTR(FCN,M,N,X,FVEC,FJAC,LDFJAC,FTOL,XTOL,GTOL,MAXFEV, - * WA(1),MODE,FACTOR,NPRINT,INFO,NFEV,NJEV,IPVT,WA(N+1), - * WA(2*N+1),WA(3*N+1),WA(4*N+1),WA(5*N+1)) - IF (INFO .EQ. 8) INFO = 4 - 10 CONTINUE - RETURN -C -C LAST CARD OF SUBROUTINE LMSTR1. -C - END - SUBROUTINE QFORM(M,N,Q,LDQ,WA) - INTEGER M,N,LDQ - REAL Q(LDQ,M),WA(M) -C ********** -C -C SUBROUTINE QFORM -C -C THIS SUBROUTINE PROCEEDS FROM THE COMPUTED QR FACTORIZATION OF -C AN M BY N MATRIX A TO ACCUMULATE THE M BY M ORTHOGONAL MATRIX -C Q FROM ITS FACTORED FORM. -C -C THE SUBROUTINE STATEMENT IS -C -C SUBROUTINE QFORM(M,N,Q,LDQ,WA) -C -C WHERE -C -C M IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER -C OF ROWS OF A AND THE ORDER OF Q. -C -C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER -C OF COLUMNS OF A. -C -C Q IS AN M BY M ARRAY. ON INPUT THE FULL LOWER TRAPEZOID IN -C THE FIRST MIN(M,N) COLUMNS OF Q CONTAINS THE FACTORED FORM. -C ON OUTPUT Q HAS BEEN ACCUMULATED INTO A SQUARE MATRIX. -C -C LDQ IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN M -C WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY Q. -C -C WA IS A WORK ARRAY OF LENGTH M. -C -C SUBPROGRAMS CALLED -C -C FORTRAN-SUPPLIED ... MIN0 -C -C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. -C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE -C -C ********** - INTEGER I,J,JM1,K,L,MINMN,NP1 - REAL ONE,SUM,TEMP,ZERO - DATA ONE,ZERO /1.0E0,0.0E0/ -C -C ZERO OUT UPPER TRIANGLE OF Q IN THE FIRST MIN(M,N) COLUMNS. -C - MINMN = MIN0(M,N) - IF (MINMN .LT. 2) GO TO 30 - DO 20 J = 2, MINMN - JM1 = J - 1 - DO 10 I = 1, JM1 - Q(I,J) = ZERO - 10 CONTINUE - 20 CONTINUE - 30 CONTINUE -C -C INITIALIZE REMAINING COLUMNS TO THOSE OF THE IDENTITY MATRIX. -C - NP1 = N + 1 - IF (M .LT. NP1) GO TO 60 - DO 50 J = NP1, M - DO 40 I = 1, M - Q(I,J) = ZERO - 40 CONTINUE - Q(J,J) = ONE - 50 CONTINUE - 60 CONTINUE -C -C ACCUMULATE Q FROM ITS FACTORED FORM. -C - DO 120 L = 1, MINMN - K = MINMN - L + 1 - DO 70 I = K, M - WA(I) = Q(I,K) - Q(I,K) = ZERO - 70 CONTINUE - Q(K,K) = ONE - IF (WA(K) .EQ. ZERO) GO TO 110 - DO 100 J = K, M - SUM = ZERO - DO 80 I = K, M - SUM = SUM + Q(I,J)*WA(I) - 80 CONTINUE - TEMP = SUM/WA(K) - DO 90 I = K, M - Q(I,J) = Q(I,J) - TEMP*WA(I) - 90 CONTINUE - 100 CONTINUE - 110 CONTINUE - 120 CONTINUE - RETURN -C -C LAST CARD OF SUBROUTINE QFORM. -C - END - SUBROUTINE QRFAC(M,N,A,LDA,PIVOT,IPVT,LIPVT,RDIAG,ACNORM,WA) - INTEGER M,N,LDA,LIPVT - INTEGER IPVT(LIPVT) - LOGICAL PIVOT - REAL A(LDA,N),RDIAG(N),ACNORM(N),WA(N) -C ********** -C -C SUBROUTINE QRFAC -C -C THIS SUBROUTINE USES HOUSEHOLDER TRANSFORMATIONS WITH COLUMN -C PIVOTING (OPTIONAL) TO COMPUTE A QR FACTORIZATION OF THE -C M BY N MATRIX A. THAT IS, QRFAC DETERMINES AN ORTHOGONAL -C MATRIX Q, A PERMUTATION MATRIX P, AND AN UPPER TRAPEZOIDAL -C MATRIX R WITH DIAGONAL ELEMENTS OF NONINCREASING MAGNITUDE, -C SUCH THAT A*P = Q*R. THE HOUSEHOLDER TRANSFORMATION FOR -C COLUMN K, K = 1,2,...,MIN(M,N), IS OF THE FORM -C -C T -C I - (1/U(K))*U*U -C -C WHERE U HAS ZEROS IN THE FIRST K-1 POSITIONS. THE FORM OF -C THIS TRANSFORMATION AND THE METHOD OF PIVOTING FIRST -C APPEARED IN THE CORRESPONDING LINPACK SUBROUTINE. -C -C THE SUBROUTINE STATEMENT IS -C -C SUBROUTINE QRFAC(M,N,A,LDA,PIVOT,IPVT,LIPVT,RDIAG,ACNORM,WA) -C -C WHERE -C -C M IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER -C OF ROWS OF A. -C -C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER -C OF COLUMNS OF A. -C -C A IS AN M BY N ARRAY. ON INPUT A CONTAINS THE MATRIX FOR -C WHICH THE QR FACTORIZATION IS TO BE COMPUTED. ON OUTPUT -C THE STRICT UPPER TRAPEZOIDAL PART OF A CONTAINS THE STRICT -C UPPER TRAPEZOIDAL PART OF R, AND THE LOWER TRAPEZOIDAL -C PART OF A CONTAINS A FACTORED FORM OF Q (THE NON-TRIVIAL -C ELEMENTS OF THE U VECTORS DESCRIBED ABOVE). -C -C LDA IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN M -C WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY A. -C -C PIVOT IS A LOGICAL INPUT VARIABLE. IF PIVOT IS SET TRUE, -C THEN COLUMN PIVOTING IS ENFORCED. IF PIVOT IS SET FALSE, -C THEN NO COLUMN PIVOTING IS DONE. -C -C IPVT IS AN INTEGER OUTPUT ARRAY OF LENGTH LIPVT. IPVT -C DEFINES THE PERMUTATION MATRIX P SUCH THAT A*P = Q*R. -C COLUMN J OF P IS COLUMN IPVT(J) OF THE IDENTITY MATRIX. -C IF PIVOT IS FALSE, IPVT IS NOT REFERENCED. -C -C LIPVT IS A POSITIVE INTEGER INPUT VARIABLE. IF PIVOT IS FALSE, -C THEN LIPVT MAY BE AS SMALL AS 1. IF PIVOT IS TRUE, THEN -C LIPVT MUST BE AT LEAST N. -C -C RDIAG IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE -C DIAGONAL ELEMENTS OF R. -C -C ACNORM IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE -C NORMS OF THE CORRESPONDING COLUMNS OF THE INPUT MATRIX A. -C IF THIS INFORMATION IS NOT NEEDED, THEN ACNORM CAN COINCIDE -C WITH RDIAG. -C -C WA IS A WORK ARRAY OF LENGTH N. IF PIVOT IS FALSE, THEN WA -C CAN COINCIDE WITH RDIAG. -C -C SUBPROGRAMS CALLED -C -C MINPACK-SUPPLIED ... SPMPAR,ENORM -C -C FORTRAN-SUPPLIED ... AMAX1,SQRT,MIN0 -C -C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. -C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE -C -C ********** - INTEGER I,J,JP1,K,KMAX,MINMN - REAL AJNORM,EPSMCH,ONE,P05,SUM,TEMP,ZERO - REAL SPMPAR,ENORM - DATA ONE,P05,ZERO /1.0E0,5.0E-2,0.0E0/ -C -C EPSMCH IS THE MACHINE PRECISION. -C - EPSMCH = SPMPAR(1) -C -C COMPUTE THE INITIAL COLUMN NORMS AND INITIALIZE SEVERAL ARRAYS. -C - DO 10 J = 1, N - ACNORM(J) = ENORM(M,A(1,J)) - RDIAG(J) = ACNORM(J) - WA(J) = RDIAG(J) - IF (PIVOT) IPVT(J) = J - 10 CONTINUE -C -C REDUCE A TO R WITH HOUSEHOLDER TRANSFORMATIONS. -C - MINMN = MIN0(M,N) - DO 110 J = 1, MINMN - IF (.NOT.PIVOT) GO TO 40 -C -C BRING THE COLUMN OF LARGEST NORM INTO THE PIVOT POSITION. -C - KMAX = J - DO 20 K = J, N - IF (RDIAG(K) .GT. RDIAG(KMAX)) KMAX = K - 20 CONTINUE - IF (KMAX .EQ. J) GO TO 40 - DO 30 I = 1, M - TEMP = A(I,J) - A(I,J) = A(I,KMAX) - A(I,KMAX) = TEMP - 30 CONTINUE - RDIAG(KMAX) = RDIAG(J) - WA(KMAX) = WA(J) - K = IPVT(J) - IPVT(J) = IPVT(KMAX) - IPVT(KMAX) = K - 40 CONTINUE -C -C COMPUTE THE HOUSEHOLDER TRANSFORMATION TO REDUCE THE -C J-TH COLUMN OF A TO A MULTIPLE OF THE J-TH UNIT VECTOR. -C - AJNORM = ENORM(M-J+1,A(J,J)) - IF (AJNORM .EQ. ZERO) GO TO 100 - IF (A(J,J) .LT. ZERO) AJNORM = -AJNORM - DO 50 I = J, M - A(I,J) = A(I,J)/AJNORM - 50 CONTINUE - A(J,J) = A(J,J) + ONE -C -C APPLY THE TRANSFORMATION TO THE REMAINING COLUMNS -C AND UPDATE THE NORMS. -C - JP1 = J + 1 - IF (N .LT. JP1) GO TO 100 - DO 90 K = JP1, N - SUM = ZERO - DO 60 I = J, M - SUM = SUM + A(I,J)*A(I,K) - 60 CONTINUE - TEMP = SUM/A(J,J) - DO 70 I = J, M - A(I,K) = A(I,K) - TEMP*A(I,J) - 70 CONTINUE - IF (.NOT.PIVOT .OR. RDIAG(K) .EQ. ZERO) GO TO 80 - TEMP = A(J,K)/RDIAG(K) - RDIAG(K) = RDIAG(K)*SQRT(AMAX1(ZERO,ONE-TEMP**2)) - IF (P05*(RDIAG(K)/WA(K))**2 .GT. EPSMCH) GO TO 80 - RDIAG(K) = ENORM(M-J,A(JP1,K)) - WA(K) = RDIAG(K) - 80 CONTINUE - 90 CONTINUE - 100 CONTINUE - RDIAG(J) = -AJNORM - 110 CONTINUE - RETURN -C -C LAST CARD OF SUBROUTINE QRFAC. -C - END - SUBROUTINE QRSOLV(N,R,LDR,IPVT,DIAG,QTB,X,SDIAG,WA) - INTEGER N,LDR - INTEGER IPVT(N) - REAL R(LDR,N),DIAG(N),QTB(N),X(N),SDIAG(N),WA(N) -C ********** -C -C SUBROUTINE QRSOLV -C -C GIVEN AN M BY N MATRIX A, AN N BY N DIAGONAL MATRIX D, -C AND AN M-VECTOR B, THE PROBLEM IS TO DETERMINE AN X WHICH -C SOLVES THE SYSTEM -C -C A*X = B , D*X = 0 , -C -C IN THE LEAST SQUARES SENSE. -C -C THIS SUBROUTINE COMPLETES THE SOLUTION OF THE PROBLEM -C IF IT IS PROVIDED WITH THE NECESSARY INFORMATION FROM THE -C QR FACTORIZATION, WITH COLUMN PIVOTING, OF A. THAT IS, IF -C A*P = Q*R, WHERE P IS A PERMUTATION MATRIX, Q HAS ORTHOGONAL -C COLUMNS, AND R IS AN UPPER TRIANGULAR MATRIX WITH DIAGONAL -C ELEMENTS OF NONINCREASING MAGNITUDE, THEN QRSOLV EXPECTS -C THE FULL UPPER TRIANGLE OF R, THE PERMUTATION MATRIX P, -C AND THE FIRST N COMPONENTS OF (Q TRANSPOSE)*B. THE SYSTEM -C A*X = B, D*X = 0, IS THEN EQUIVALENT TO -C -C T T -C R*Z = Q *B , P *D*P*Z = 0 , -C -C WHERE X = P*Z. IF THIS SYSTEM DOES NOT HAVE FULL RANK, -C THEN A LEAST SQUARES SOLUTION IS OBTAINED. ON OUTPUT QRSOLV -C ALSO PROVIDES AN UPPER TRIANGULAR MATRIX S SUCH THAT -C -C T T T -C P *(A *A + D*D)*P = S *S . -C -C S IS COMPUTED WITHIN QRSOLV AND MAY BE OF SEPARATE INTEREST. -C -C THE SUBROUTINE STATEMENT IS -C -C SUBROUTINE QRSOLV(N,R,LDR,IPVT,DIAG,QTB,X,SDIAG,WA) -C -C WHERE -C -C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE ORDER OF R. -C -C R IS AN N BY N ARRAY. ON INPUT THE FULL UPPER TRIANGLE -C MUST CONTAIN THE FULL UPPER TRIANGLE OF THE MATRIX R. -C ON OUTPUT THE FULL UPPER TRIANGLE IS UNALTERED, AND THE -C STRICT LOWER TRIANGLE CONTAINS THE STRICT UPPER TRIANGLE -C (TRANSPOSED) OF THE UPPER TRIANGULAR MATRIX S. -C -C LDR IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN N -C WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY R. -C -C IPVT IS AN INTEGER INPUT ARRAY OF LENGTH N WHICH DEFINES THE -C PERMUTATION MATRIX P SUCH THAT A*P = Q*R. COLUMN J OF P -C IS COLUMN IPVT(J) OF THE IDENTITY MATRIX. -C -C DIAG IS AN INPUT ARRAY OF LENGTH N WHICH MUST CONTAIN THE -C DIAGONAL ELEMENTS OF THE MATRIX D. -C -C QTB IS AN INPUT ARRAY OF LENGTH N WHICH MUST CONTAIN THE FIRST -C N ELEMENTS OF THE VECTOR (Q TRANSPOSE)*B. -C -C X IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE LEAST -C SQUARES SOLUTION OF THE SYSTEM A*X = B, D*X = 0. -C -C SDIAG IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE -C DIAGONAL ELEMENTS OF THE UPPER TRIANGULAR MATRIX S. -C -C WA IS A WORK ARRAY OF LENGTH N. -C -C SUBPROGRAMS CALLED -C -C FORTRAN-SUPPLIED ... ABS,SQRT -C -C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. -C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE -C -C ********** - INTEGER I,J,JP1,K,KP1,L,NSING - REAL COS,COTAN,P5,P25,QTBPJ,SIN,SUM,TAN,TEMP,ZERO - DATA P5,P25,ZERO /5.0E-1,2.5E-1,0.0E0/ -C -C COPY R AND (Q TRANSPOSE)*B TO PRESERVE INPUT AND INITIALIZE S. -C IN PARTICULAR, SAVE THE DIAGONAL ELEMENTS OF R IN X. -C - DO 20 J = 1, N - DO 10 I = J, N - R(I,J) = R(J,I) - 10 CONTINUE - X(J) = R(J,J) - WA(J) = QTB(J) - 20 CONTINUE -C -C ELIMINATE THE DIAGONAL MATRIX D USING A GIVENS ROTATION. -C - DO 100 J = 1, N -C -C PREPARE THE ROW OF D TO BE ELIMINATED, LOCATING THE -C DIAGONAL ELEMENT USING P FROM THE QR FACTORIZATION. -C - L = IPVT(J) - IF (DIAG(L) .EQ. ZERO) GO TO 90 - DO 30 K = J, N - SDIAG(K) = ZERO - 30 CONTINUE - SDIAG(J) = DIAG(L) -C -C THE TRANSFORMATIONS TO ELIMINATE THE ROW OF D -C MODIFY ONLY A SINGLE ELEMENT OF (Q TRANSPOSE)*B -C BEYOND THE FIRST N, WHICH IS INITIALLY ZERO. -C - QTBPJ = ZERO - DO 80 K = J, N -C -C DETERMINE A GIVENS ROTATION WHICH ELIMINATES THE -C APPROPRIATE ELEMENT IN THE CURRENT ROW OF D. -C - IF (SDIAG(K) .EQ. ZERO) GO TO 70 - IF (ABS(R(K,K)) .GE. ABS(SDIAG(K))) GO TO 40 - COTAN = R(K,K)/SDIAG(K) - SIN = P5/SQRT(P25+P25*COTAN**2) - COS = SIN*COTAN - GO TO 50 - 40 CONTINUE - TAN = SDIAG(K)/R(K,K) - COS = P5/SQRT(P25+P25*TAN**2) - SIN = COS*TAN - 50 CONTINUE -C -C COMPUTE THE MODIFIED DIAGONAL ELEMENT OF R AND -C THE MODIFIED ELEMENT OF ((Q TRANSPOSE)*B,0). -C - R(K,K) = COS*R(K,K) + SIN*SDIAG(K) - TEMP = COS*WA(K) + SIN*QTBPJ - QTBPJ = -SIN*WA(K) + COS*QTBPJ - WA(K) = TEMP -C -C ACCUMULATE THE TRANFORMATION IN THE ROW OF S. -C - KP1 = K + 1 - IF (N .LT. KP1) GO TO 70 - DO 60 I = KP1, N - TEMP = COS*R(I,K) + SIN*SDIAG(I) - SDIAG(I) = -SIN*R(I,K) + COS*SDIAG(I) - R(I,K) = TEMP - 60 CONTINUE - 70 CONTINUE - 80 CONTINUE - 90 CONTINUE -C -C STORE THE DIAGONAL ELEMENT OF S AND RESTORE -C THE CORRESPONDING DIAGONAL ELEMENT OF R. -C - SDIAG(J) = R(J,J) - R(J,J) = X(J) - 100 CONTINUE -C -C SOLVE THE TRIANGULAR SYSTEM FOR Z. IF THE SYSTEM IS -C SINGULAR, THEN OBTAIN A LEAST SQUARES SOLUTION. -C - NSING = N - DO 110 J = 1, N - IF (SDIAG(J) .EQ. ZERO .AND. NSING .EQ. N) NSING = J - 1 - IF (NSING .LT. N) WA(J) = ZERO - 110 CONTINUE - IF (NSING .LT. 1) GO TO 150 - DO 140 K = 1, NSING - J = NSING - K + 1 - SUM = ZERO - JP1 = J + 1 - IF (NSING .LT. JP1) GO TO 130 - DO 120 I = JP1, NSING - SUM = SUM + R(I,J)*WA(I) - 120 CONTINUE - 130 CONTINUE - WA(J) = (WA(J) - SUM)/SDIAG(J) - 140 CONTINUE - 150 CONTINUE -C -C PERMUTE THE COMPONENTS OF Z BACK TO COMPONENTS OF X. -C - DO 160 J = 1, N - L = IPVT(J) - X(L) = WA(J) - 160 CONTINUE - RETURN -C -C LAST CARD OF SUBROUTINE QRSOLV. -C - END - SUBROUTINE RWUPDT(N,R,LDR,W,B,ALPHA,COS,SIN) - INTEGER N,LDR - REAL ALPHA - REAL R(LDR,N),W(N),B(N),COS(N),SIN(N) -C ********** -C -C SUBROUTINE RWUPDT -C -C GIVEN AN N BY N UPPER TRIANGULAR MATRIX R, THIS SUBROUTINE -C COMPUTES THE QR DECOMPOSITION OF THE MATRIX FORMED WHEN A ROW -C IS ADDED TO R. IF THE ROW IS SPECIFIED BY THE VECTOR W, THEN -C RWUPDT DETERMINES AN ORTHOGONAL MATRIX Q SUCH THAT WHEN THE -C N+1 BY N MATRIX COMPOSED OF R AUGMENTED BY W IS PREMULTIPLIED -C BY (Q TRANSPOSE), THE RESULTING MATRIX IS UPPER TRAPEZOIDAL. -C THE MATRIX (Q TRANSPOSE) IS THE PRODUCT OF N TRANSFORMATIONS -C -C G(N)*G(N-1)* ... *G(1) -C -C WHERE G(I) IS A GIVENS ROTATION IN THE (I,N+1) PLANE WHICH -C ELIMINATES ELEMENTS IN THE (N+1)-ST PLANE. RWUPDT ALSO -C COMPUTES THE PRODUCT (Q TRANSPOSE)*C WHERE C IS THE -C (N+1)-VECTOR (B,ALPHA). Q ITSELF IS NOT ACCUMULATED, RATHER -C THE INFORMATION TO RECOVER THE G ROTATIONS IS SUPPLIED. -C -C THE SUBROUTINE STATEMENT IS -C -C SUBROUTINE RWUPDT(N,R,LDR,W,B,ALPHA,COS,SIN) -C -C WHERE -C -C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE ORDER OF R. -C -C R IS AN N BY N ARRAY. ON INPUT THE UPPER TRIANGULAR PART OF -C R MUST CONTAIN THE MATRIX TO BE UPDATED. ON OUTPUT R -C CONTAINS THE UPDATED TRIANGULAR MATRIX. -C -C LDR IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN N -C WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY R. -C -C W IS AN INPUT ARRAY OF LENGTH N WHICH MUST CONTAIN THE ROW -C VECTOR TO BE ADDED TO R. -C -C B IS AN ARRAY OF LENGTH N. ON INPUT B MUST CONTAIN THE -C FIRST N ELEMENTS OF THE VECTOR C. ON OUTPUT B CONTAINS -C THE FIRST N ELEMENTS OF THE VECTOR (Q TRANSPOSE)*C. -C -C ALPHA IS A VARIABLE. ON INPUT ALPHA MUST CONTAIN THE -C (N+1)-ST ELEMENT OF THE VECTOR C. ON OUTPUT ALPHA CONTAINS -C THE (N+1)-ST ELEMENT OF THE VECTOR (Q TRANSPOSE)*C. -C -C COS IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE -C COSINES OF THE TRANSFORMING GIVENS ROTATIONS. -C -C SIN IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE -C SINES OF THE TRANSFORMING GIVENS ROTATIONS. -C -C SUBPROGRAMS CALLED -C -C FORTRAN-SUPPLIED ... ABS,SQRT -C -C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. -C BURTON S. GARBOW, DUDLEY V. GOETSCHEL, KENNETH E. HILLSTROM, -C JORGE J. MORE -C -C ********** - INTEGER I,J,JM1 - REAL COTAN,ONE,P5,P25,ROWJ,TAN,TEMP,ZERO - DATA ONE,P5,P25,ZERO /1.0E0,5.0E-1,2.5E-1,0.0E0/ -C - DO 60 J = 1, N - ROWJ = W(J) - JM1 = J - 1 -C -C APPLY THE PREVIOUS TRANSFORMATIONS TO -C R(I,J), I=1,2,...,J-1, AND TO W(J). -C - IF (JM1 .LT. 1) GO TO 20 - DO 10 I = 1, JM1 - TEMP = COS(I)*R(I,J) + SIN(I)*ROWJ - ROWJ = -SIN(I)*R(I,J) + COS(I)*ROWJ - R(I,J) = TEMP - 10 CONTINUE - 20 CONTINUE -C -C DETERMINE A GIVENS ROTATION WHICH ELIMINATES W(J). -C - COS(J) = ONE - SIN(J) = ZERO - IF (ROWJ .EQ. ZERO) GO TO 50 - IF (ABS(R(J,J)) .GE. ABS(ROWJ)) GO TO 30 - COTAN = R(J,J)/ROWJ - SIN(J) = P5/SQRT(P25+P25*COTAN**2) - COS(J) = SIN(J)*COTAN - GO TO 40 - 30 CONTINUE - TAN = ROWJ/R(J,J) - COS(J) = P5/SQRT(P25+P25*TAN**2) - SIN(J) = COS(J)*TAN - 40 CONTINUE -C -C APPLY THE CURRENT TRANSFORMATION TO R(J,J), B(J), AND ALPHA. -C - R(J,J) = COS(J)*R(J,J) + SIN(J)*ROWJ - TEMP = COS(J)*B(J) + SIN(J)*ALPHA - ALPHA = -SIN(J)*B(J) + COS(J)*ALPHA - B(J) = TEMP - 50 CONTINUE - 60 CONTINUE - RETURN -C -C LAST CARD OF SUBROUTINE RWUPDT. -C - END - SUBROUTINE R1MPYQ(M,N,A,LDA,V,W) - INTEGER M,N,LDA - REAL A(LDA,N),V(N),W(N) -C ********** -C -C SUBROUTINE R1MPYQ -C -C GIVEN AN M BY N MATRIX A, THIS SUBROUTINE COMPUTES A*Q WHERE -C Q IS THE PRODUCT OF 2*(N - 1) TRANSFORMATIONS -C -C GV(N-1)*...*GV(1)*GW(1)*...*GW(N-1) -C -C AND GV(I), GW(I) ARE GIVENS ROTATIONS IN THE (I,N) PLANE WHICH -C ELIMINATE ELEMENTS IN THE I-TH AND N-TH PLANES, RESPECTIVELY. -C Q ITSELF IS NOT GIVEN, RATHER THE INFORMATION TO RECOVER THE -C GV, GW ROTATIONS IS SUPPLIED. -C -C THE SUBROUTINE STATEMENT IS -C -C SUBROUTINE R1MPYQ(M,N,A,LDA,V,W) -C -C WHERE -C -C M IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER -C OF ROWS OF A. -C -C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER -C OF COLUMNS OF A. -C -C A IS AN M BY N ARRAY. ON INPUT A MUST CONTAIN THE MATRIX -C TO BE POSTMULTIPLIED BY THE ORTHOGONAL MATRIX Q -C DESCRIBED ABOVE. ON OUTPUT A*Q HAS REPLACED A. -C -C LDA IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN M -C WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY A. -C -C V IS AN INPUT ARRAY OF LENGTH N. V(I) MUST CONTAIN THE -C INFORMATION NECESSARY TO RECOVER THE GIVENS ROTATION GV(I) -C DESCRIBED ABOVE. -C -C W IS AN INPUT ARRAY OF LENGTH N. W(I) MUST CONTAIN THE -C INFORMATION NECESSARY TO RECOVER THE GIVENS ROTATION GW(I) -C DESCRIBED ABOVE. -C -C SUBROUTINES CALLED -C -C FORTRAN-SUPPLIED ... ABS,SQRT -C -C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. -C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE -C -C ********** - INTEGER I,J,NMJ,NM1 - REAL COS,ONE,SIN,TEMP - DATA ONE /1.0E0/ -C -C APPLY THE FIRST SET OF GIVENS ROTATIONS TO A. -C - NM1 = N - 1 - IF (NM1 .LT. 1) GO TO 50 - DO 20 NMJ = 1, NM1 - J = N - NMJ - IF (ABS(V(J)) .GT. ONE) COS = ONE/V(J) - IF (ABS(V(J)) .GT. ONE) SIN = SQRT(ONE-COS**2) - IF (ABS(V(J)) .LE. ONE) SIN = V(J) - IF (ABS(V(J)) .LE. ONE) COS = SQRT(ONE-SIN**2) - DO 10 I = 1, M - TEMP = COS*A(I,J) - SIN*A(I,N) - A(I,N) = SIN*A(I,J) + COS*A(I,N) - A(I,J) = TEMP - 10 CONTINUE - 20 CONTINUE -C -C APPLY THE SECOND SET OF GIVENS ROTATIONS TO A. -C - DO 40 J = 1, NM1 - IF (ABS(W(J)) .GT. ONE) COS = ONE/W(J) - IF (ABS(W(J)) .GT. ONE) SIN = SQRT(ONE-COS**2) - IF (ABS(W(J)) .LE. ONE) SIN = W(J) - IF (ABS(W(J)) .LE. ONE) COS = SQRT(ONE-SIN**2) - DO 30 I = 1, M - TEMP = COS*A(I,J) + SIN*A(I,N) - A(I,N) = -SIN*A(I,J) + COS*A(I,N) - A(I,J) = TEMP - 30 CONTINUE - 40 CONTINUE - 50 CONTINUE - RETURN -C -C LAST CARD OF SUBROUTINE R1MPYQ. -C - END - SUBROUTINE R1UPDT(M,N,S,LS,U,V,W,SING) - INTEGER M,N,LS - LOGICAL SING - REAL S(LS),U(M),V(N),W(M) -C ********** -C -C SUBROUTINE R1UPDT -C -C GIVEN AN M BY N LOWER TRAPEZOIDAL MATRIX S, AN M-VECTOR U, -C AND AN N-VECTOR V, THE PROBLEM IS TO DETERMINE AN -C ORTHOGONAL MATRIX Q SUCH THAT -C -C T -C (S + U*V )*Q -C -C IS AGAIN LOWER TRAPEZOIDAL. -C -C THIS SUBROUTINE DETERMINES Q AS THE PRODUCT OF 2*(N - 1) -C TRANSFORMATIONS -C -C GV(N-1)*...*GV(1)*GW(1)*...*GW(N-1) -C -C WHERE GV(I), GW(I) ARE GIVENS ROTATIONS IN THE (I,N) PLANE -C WHICH ELIMINATE ELEMENTS IN THE I-TH AND N-TH PLANES, -C RESPECTIVELY. Q ITSELF IS NOT ACCUMULATED, RATHER THE -C INFORMATION TO RECOVER THE GV, GW ROTATIONS IS RETURNED. -C -C THE SUBROUTINE STATEMENT IS -C -C SUBROUTINE R1UPDT(M,N,S,LS,U,V,W,SING) -C -C WHERE -C -C M IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER -C OF ROWS OF S. -C -C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER -C OF COLUMNS OF S. N MUST NOT EXCEED M. -C -C S IS AN ARRAY OF LENGTH LS. ON INPUT S MUST CONTAIN THE LOWER -C TRAPEZOIDAL MATRIX S STORED BY COLUMNS. ON OUTPUT S CONTAINS -C THE LOWER TRAPEZOIDAL MATRIX PRODUCED AS DESCRIBED ABOVE. -C -C LS IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN -C (N*(2*M-N+1))/2. -C -C U IS AN INPUT ARRAY OF LENGTH M WHICH MUST CONTAIN THE -C VECTOR U. -C -C V IS AN ARRAY OF LENGTH N. ON INPUT V MUST CONTAIN THE VECTOR -C V. ON OUTPUT V(I) CONTAINS THE INFORMATION NECESSARY TO -C RECOVER THE GIVENS ROTATION GV(I) DESCRIBED ABOVE. -C -C W IS AN OUTPUT ARRAY OF LENGTH M. W(I) CONTAINS INFORMATION -C NECESSARY TO RECOVER THE GIVENS ROTATION GW(I) DESCRIBED -C ABOVE. -C -C SING IS A LOGICAL OUTPUT VARIABLE. SING IS SET TRUE IF ANY -C OF THE DIAGONAL ELEMENTS OF THE OUTPUT S ARE ZERO. OTHERWISE -C SING IS SET FALSE. -C -C SUBPROGRAMS CALLED -C -C MINPACK-SUPPLIED ... SPMPAR -C -C FORTRAN-SUPPLIED ... ABS,SQRT -C -C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. -C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE, -C JOHN L. NAZARETH -C -C ********** - INTEGER I,J,JJ,L,NMJ,NM1 - REAL COS,COTAN,GIANT,ONE,P5,P25,SIN,TAN,TAU,TEMP,ZERO - REAL SPMPAR - DATA ONE,P5,P25,ZERO /1.0E0,5.0E-1,2.5E-1,0.0E0/ -C -C GIANT IS THE LARGEST MAGNITUDE. -C - GIANT = SPMPAR(3) -C -C INITIALIZE THE DIAGONAL ELEMENT POINTER. -C - JJ = (N*(2*M - N + 1))/2 - (M - N) -C -C MOVE THE NONTRIVIAL PART OF THE LAST COLUMN OF S INTO W. -C - L = JJ - DO 10 I = N, M - W(I) = S(L) - L = L + 1 - 10 CONTINUE -C -C ROTATE THE VECTOR V INTO A MULTIPLE OF THE N-TH UNIT VECTOR -C IN SUCH A WAY THAT A SPIKE IS INTRODUCED INTO W. -C - NM1 = N - 1 - IF (NM1 .LT. 1) GO TO 70 - DO 60 NMJ = 1, NM1 - J = N - NMJ - JJ = JJ - (M - J + 1) - W(J) = ZERO - IF (V(J) .EQ. ZERO) GO TO 50 -C -C DETERMINE A GIVENS ROTATION WHICH ELIMINATES THE -C J-TH ELEMENT OF V. -C - IF (ABS(V(N)) .GE. ABS(V(J))) GO TO 20 - COTAN = V(N)/V(J) - SIN = P5/SQRT(P25+P25*COTAN**2) - COS = SIN*COTAN - TAU = ONE - IF (ABS(COS)*GIANT .GT. ONE) TAU = ONE/COS - GO TO 30 - 20 CONTINUE - TAN = V(J)/V(N) - COS = P5/SQRT(P25+P25*TAN**2) - SIN = COS*TAN - TAU = SIN - 30 CONTINUE -C -C APPLY THE TRANSFORMATION TO V AND STORE THE INFORMATION -C NECESSARY TO RECOVER THE GIVENS ROTATION. -C - V(N) = SIN*V(J) + COS*V(N) - V(J) = TAU -C -C APPLY THE TRANSFORMATION TO S AND EXTEND THE SPIKE IN W. -C - L = JJ - DO 40 I = J, M - TEMP = COS*S(L) - SIN*W(I) - W(I) = SIN*S(L) + COS*W(I) - S(L) = TEMP - L = L + 1 - 40 CONTINUE - 50 CONTINUE - 60 CONTINUE - 70 CONTINUE -C -C ADD THE SPIKE FROM THE RANK 1 UPDATE TO W. -C - DO 80 I = 1, M - W(I) = W(I) + V(N)*U(I) - 80 CONTINUE -C -C ELIMINATE THE SPIKE. -C - SING = .FALSE. - IF (NM1 .LT. 1) GO TO 140 - DO 130 J = 1, NM1 - IF (W(J) .EQ. ZERO) GO TO 120 -C -C DETERMINE A GIVENS ROTATION WHICH ELIMINATES THE -C J-TH ELEMENT OF THE SPIKE. -C - IF (ABS(S(JJ)) .GE. ABS(W(J))) GO TO 90 - COTAN = S(JJ)/W(J) - SIN = P5/SQRT(P25+P25*COTAN**2) - COS = SIN*COTAN - TAU = ONE - IF (ABS(COS)*GIANT .GT. ONE) TAU = ONE/COS - GO TO 100 - 90 CONTINUE - TAN = W(J)/S(JJ) - COS = P5/SQRT(P25+P25*TAN**2) - SIN = COS*TAN - TAU = SIN - 100 CONTINUE -C -C APPLY THE TRANSFORMATION TO S AND REDUCE THE SPIKE IN W. -C - L = JJ - DO 110 I = J, M - TEMP = COS*S(L) + SIN*W(I) - W(I) = -SIN*S(L) + COS*W(I) - S(L) = TEMP - L = L + 1 - 110 CONTINUE -C -C STORE THE INFORMATION NECESSARY TO RECOVER THE -C GIVENS ROTATION. -C - W(J) = TAU - 120 CONTINUE -C -C TEST FOR ZERO DIAGONAL ELEMENTS IN THE OUTPUT S. -C - IF (S(JJ) .EQ. ZERO) SING = .TRUE. - JJ = JJ + (M - J + 1) - 130 CONTINUE - 140 CONTINUE -C -C MOVE W BACK INTO THE LAST COLUMN OF THE OUTPUT S. -C - L = JJ - DO 150 I = N, M - S(L) = W(I) - L = L + 1 - 150 CONTINUE - IF (S(JJ) .EQ. ZERO) SING = .TRUE. - RETURN -C -C LAST CARD OF SUBROUTINE R1UPDT. -C - END diff --git a/ex/file03 b/ex/file03 deleted file mode 100644 index bd737ec..0000000 --- a/ex/file03 +++ /dev/null @@ -1,3526 +0,0 @@ -1 -0 Page -0 Documentation for MINPACK subroutine HYBRD1 -0 Single precision version -0 Argonne National Laboratory -0 Burton S. Garbow, Kenneth E. Hillstrom, Jorge J. More -0 March 1980 -0 - 1. Purpose. -0 The purpose of HYBRD1 is to find a zero of a system of N non- - linear functions in N variables by a modification of the Powell - hybrid method. This is done by using the more general nonlinea - equation solver HYBRD. The user must provide a subroutine whic - calculates the functions. The Jacobian is then calculated by a - forward-difference approximation. -0 - 2. Subroutine and type statements. -0 SUBROUTINE HYBRD1(FCN,N,X,FVEC,TOL,INFO,WA,LWA) - INTEGER N,INFO,LWA - REAL TOL - REAL X(N),FVEC(N),WA(LWA) - EXTERNAL FCN -0 - 3. Parameters. -0 Parameters designated as input parameters must be specified on - entry to HYBRD1 and are not changed on exit, while parameters - designated as output parameters need not be specified on entry - and are set to appropriate values on exit from HYBRD1. -0 FCN is the name of the user-supplied subroutine which calculate - the functions. FCN must be declared in an EXTERNAL statement - in the user calling program, and should be written as follows -0 SUBROUTINE FCN(N,X,FVEC,IFLAG) - INTEGER N,IFLAG - REAL X(N),FVEC(N) - ---------- - CALCULATE THE FUNCTIONS AT X AND - RETURN THIS VECTOR IN FVEC. - ---------- - RETURN - END -0 The value of IFLAG should not be changed by FCN unless the - user wants to terminate execution of HYBRD1. In this case se - IFLAG to a negative integer. -1 -0 Page -0 N is a positive integer input variable set to the number of - functions and variables. -0 X is an array of length N. On input X must contain an initial - estimate of the solution vector. On output X contains the - final estimate of the solution vector. -0 FVEC is an output array of length N which contains the function - evaluated at the output X. -0 TOL is a nonnegative input variable. Termination occurs when - the algorithm estimates that the relative error between X and - the solution is at most TOL. Section 4 contains more details - about TOL. -0 INFO is an integer output variable. If the user has terminated - execution, INFO is set to the (negative) value of IFLAG. See - description of FCN. Otherwise, INFO is set as follows. -0 INFO = 0 Improper input parameters. -0 INFO = 1 Algorithm estimates that the relative error between - X and the solution is at most TOL. -0 INFO = 2 Number of calls to FCN has reached or exceeded - 200*(N+1). -0 INFO = 3 TOL is too small. No further improvement in the - approximate solution X is possible. -0 INFO = 4 Iteration is not making good progress. -0 Sections 4 and 5 contain more details about INFO. -0 WA is a work array of length LWA. -0 LWA is a positive integer input variable not less than - (N*(3*N+13))/2. -0 - 4. Successful completion. -0 The accuracy of HYBRD1 is controlled by the convergence parame- - ter TOL. This parameter is used in a test which makes a compar - ison between the approximation X and a solution XSOL. HYBRD1 - terminates when the test is satisfied. If TOL is less than the - machine precision (as defined by the MINPACK function - SPMPAR(1)), then HYBRD1 only attempts to satisfy the test - defined by the machine precision. Further progress is not usu- - ally possible. Unless high precision solutions are required, - the recommended value for TOL is the square root of the machine - precision. -0 The test assumes that the functions are reasonably well behaved -1 -0 Page -0 If this condition is not satisfied, then HYBRD1 may incorrectly - indicate convergence. The validity of the answer can be - checked, for example, by rerunning HYBRD1 with a tighter toler- - ance. -0 Convergence test. If ENORM(Z) denotes the Euclidean norm of a - vector Z, then this test attempts to guarantee that -0 ENORM(X-XSOL) .LE. TOL*ENORM(XSOL). -0 If this condition is satisfied with TOL = 10**(-K), then the - larger components of X have K significant decimal digits and - INFO is set to 1. There is a danger that the smaller compo- - nents of X may have large relative errors, but the fast rate - of convergence of HYBRD1 usually avoids this possibility. -0 - 5. Unsuccessful completion. -0 Unsuccessful termination of HYBRD1 can be due to improper input - parameters, arithmetic interrupts, an excessive number of func- - tion evaluations, errors in the functions, or lack of good prog - ress. -0 Improper input parameters. INFO is set to 0 if N .LE. 0, or - TOL .LT. 0.E0, or LWA .LT. (N*(3*N+13))/2. -0 Arithmetic interrupts. If these interrupts occur in the FCN - subroutine during an early stage of the computation, they may - be caused by an unacceptable choice of X by HYBRD1. In this - case, it may be possible to remedy the situation by not evalu - ating the functions here, but instead setting the components - of FVEC to numbers that exceed those in the initial FVEC, - thereby indirectly reducing the step length. The step length - can be more directly controlled by using instead HYBRD, which - includes in its calling sequence the step-length- governing - parameter FACTOR. -0 Excessive number of function evaluations. If the number of - calls to FCN reaches 200*(N+1), then this indicates that the - routine is converging very slowly as measured by the progress - of FVEC, and INFO is set to 2. This situation should be unu- - sual because, as indicated below, lack of good progress is - usually diagnosed earlier by HYBRD1, causing termination with - INFO = 4. -0 Errors in the functions. The choice of step length in the for- - ward-difference approximation to the Jacobian assumes that th - relative errors in the functions are of the order of the - machine precision. If this is not the case, HYBRD1 may fail - (usually with INFO = 4). The user should then use HYBRD - instead, or one of the programs which require the analytic - Jacobian (HYBRJ1 and HYBRJ). -1 -0 Page -0 Lack of good progress. HYBRD1 searches for a zero of the syste - by minimizing the sum of the squares of the functions. In so - doing, it can become trapped in a region where the minimum - does not correspond to a zero of the system and, in this situ - ation, the iteration eventually fails to make good progress. - In particular, this will happen if the system does not have a - zero. If the system has a zero, rerunning HYBRD1 from a dif- - ferent starting point may be helpful. -0 - 6. Characteristics of the algorithm. -0 HYBRD1 is a modification of the Powell hybrid method. Two of - its main characteristics involve the choice of the correction a - a convex combination of the Newton and scaled gradient direc- - tions, and the updating of the Jacobian by the rank-1 method of - Broyden. The choice of the correction guarantees (under reason - able conditions) global convergence for starting points far fro - the solution and a fast rate of convergence. The Jacobian is - approximated by forward differences at the starting point, but - forward differences are not used again until the rank-1 method - fails to produce satisfactory progress. -0 Timing. The time required by HYBRD1 to solve a given problem - depends on N, the behavior of the functions, the accuracy - requested, and the starting point. The number of arithmetic - operations needed by HYBRD1 is about 11.5*(N**2) to process - each call to FCN. Unless FCN can be evaluated quickly, the - timing of HYBRD1 will be strongly influenced by the time spen - in FCN. -0 Storage. HYBRD1 requires (3*N**2 + 17*N)/2 single precision - storage locations, in addition to the storage required by the - program. There are no internally declared storage arrays. -0 - 7. Subprograms required. -0 USER-supplied ...... FCN -0 MINPACK-supplied ... DOGLEG,SPMPAR,ENORM,FDJAC1,HYBRD, - QFORM,QRFAC,R1MPYQ,R1UPDT -0 FORTRAN-supplied ... ABS,AMAX1,AMIN1,SQRT,MIN0,MOD -0 - 8. References. -0 M. J. D. Powell, A Hybrid Method for Nonlinear Equations. - Numerical Methods for Nonlinear Algebraic Equations, - P. Rabinowitz, editor. Gordon and Breach, 1970. -0 - 9. Example. -1 -0 Page -0 The problem is to determine the values of x(1), x(2), ..., x(9) - which solve the system of tridiagonal equations -0 (3-2*x(1))*x(1) -2*x(2) = -1 - -x(i-1) + (3-2*x(i))*x(i) -2*x(i+1) = -1, i=2-8 - -x(8) + (3-2*x(9))*x(9) = -1 -0 C ********** - C - C DRIVER FOR HYBRD1 EXAMPLE. - C SINGLE PRECISION VERSION - C - C ********** - INTEGER J,N,INFO,LWA,NWRITE - REAL TOL,FNORM - REAL X(9),FVEC(9),WA(180) - REAL ENORM,SPMPAR - EXTERNAL FCN - C - C LOGICAL OUTPUT UNIT IS ASSUMED TO BE NUMBER 6. - C - DATA NWRITE /6/ - C - N = 9 - C - C THE FOLLOWING STARTING VALUES PROVIDE A ROUGH SOLUTION. - C - DO 10 J = 1, 9 - X(J) = -1.E0 - 10 CONTINUE - C - LWA = 180 - C - C SET TOL TO THE SQUARE ROOT OF THE MACHINE PRECISION. - C UNLESS HIGH PRECISION SOLUTIONS ARE REQUIRED, - C THIS IS THE RECOMMENDED SETTING. - C - TOL = SQRT(SPMPAR(1)) - C - CALL HYBRD1(FCN,N,X,FVEC,TOL,INFO,WA,LWA) - FNORM = ENORM(N,FVEC) - WRITE (NWRITE,1000) FNORM,INFO,(X(J),J=1,N) - STOP - 1000 FORMAT (5X,31H FINAL L2 NORM OF THE RESIDUALS,E15.7 // - * 5X,15H EXIT PARAMETER,16X,I10 // - * 5X,27H FINAL APPROXIMATE SOLUTION // (5X,3E15.7)) - C - C LAST CARD OF DRIVER FOR HYBRD1 EXAMPLE. - C - END - SUBROUTINE FCN(N,X,FVEC,IFLAG) - INTEGER N,IFLAG - REAL X(N),FVEC(N) - C -1 -0 Page -0 C SUBROUTINE FCN FOR HYBRD1 EXAMPLE. - C - INTEGER K - REAL ONE,TEMP,TEMP1,TEMP2,THREE,TWO,ZERO - DATA ZERO,ONE,TWO,THREE /0.E0,1.E0,2.E0,3.E0/ - C - DO 10 K = 1, N - TEMP = (THREE - TWO*X(K))*X(K) - TEMP1 = ZERO - IF (K .NE. 1) TEMP1 = X(K-1) - TEMP2 = ZERO - IF (K .NE. N) TEMP2 = X(K+1) - FVEC(K) = TEMP - TEMP1 - TWO*TEMP2 + ONE - 10 CONTINUE - RETURN - C - C LAST CARD OF SUBROUTINE FCN. - C - END -0 Results obtained with different compilers or machines - may be slightly different. -0 FINAL L2 NORM OF THE RESIDUALS 0.1192636E-07 -0 EXIT PARAMETER 1 -0 FINAL APPROXIMATE SOLUTION -0 -0.5706545E+00 -0.6816283E+00 -0.7017325E+00 - -0.7042129E+00 -0.7013690E+00 -0.6918656E+00 - -0.6657920E+00 -0.5960342E+00 -0.4164121E+00 -1 -0 -1 -0 Page -0 Documentation for MINPACK subroutine HYBRD -0 Single precision version -0 Argonne National Laboratory -0 Burton S. Garbow, Kenneth E. Hillstrom, Jorge J. More -0 March 1980 -0 - 1. Purpose. -0 The purpose of HYBRD is to find a zero of a system of N non- - linear functions in N variables by a modification of the Powell - hybrid method. The user must provide a subroutine which calcu- - lates the functions. The Jacobian is then calculated by a for- - ward-difference approximation. -0 - 2. Subroutine and type statements. -0 SUBROUTINE HYBRD(FCN,N,X,FVEC,XTOL,MAXFEV,ML,MU,EPSFCN,DIAG, - * MODE,FACTOR,NPRINT,INFO,NFEV,FJAC,LDFJAC, - * R,LR,QTF,WA1,WA2,WA3,WA4) - INTEGER N,MAXFEV,ML,MU,MODE,NPRINT,INFO,NFEV,LDFJAC,LR - REAL XTOL,EPSFCN,FACTOR - REAL X(N),FVEC(N),DIAG(N),FJAC(LDFJAC,N),R(LR),QTF(N), - * WA1(N),WA2(N),WA3(N),WA4(N) - EXTERNAL FCN -0 - 3. Parameters. -0 Parameters designated as input parameters must be specified on - entry to HYBRD and are not changed on exit, while parameters - designated as output parameters need not be specified on entry - and are set to appropriate values on exit from HYBRD. -0 FCN is the name of the user-supplied subroutine which calculate - the functions. FCN must be declared in an EXTERNAL statement - in the user calling program, and should be written as follows -0 SUBROUTINE FCN(N,X,FVEC,IFLAG) - INTEGER N,IFLAG - REAL X(N),FVEC(N) - ---------- - CALCULATE THE FUNCTIONS AT X AND - RETURN THIS VECTOR IN FVEC. - ---------- - RETURN - END -0 The value of IFLAG should not be changed by FCN unless the -1 -0 Page -0 user wants to terminate execution of HYBRD. In this case set - IFLAG to a negative integer. -0 N is a positive integer input variable set to the number of - functions and variables. -0 X is an array of length N. On input X must contain an initial - estimate of the solution vector. On output X contains the - final estimate of the solution vector. -0 FVEC is an output array of length N which contains the function - evaluated at the output X. -0 XTOL is a nonnegative input variable. Termination occurs when - the relative error between two consecutive iterates is at mos - XTOL. Therefore, XTOL measures the relative error desired in - the approximate solution. Section 4 contains more details - about XTOL. -0 MAXFEV is a positive integer input variable. Termination occur - when the number of calls to FCN is at least MAXFEV by the end - of an iteration. -0 ML is a nonnegative integer input variable which specifies the - number of subdiagonals within the band of the Jacobian matrix - If the Jacobian is not banded, set ML to at least N - 1. -0 MU is a nonnegative integer input variable which specifies the - number of superdiagonals within the band of the Jacobian - matrix. If the Jacobian is not banded, set MU to at least - N - 1. -0 EPSFCN is an input variable used in determining a suitable step - for the forward-difference approximation. This approximation - assumes that the relative errors in the functions are of the - order of EPSFCN. If EPSFCN is less than the machine preci- - sion, it is assumed that the relative errors in the functions - are of the order of the machine precision. -0 DIAG is an array of length N. If MODE = 1 (see below), DIAG is - internally set. If MODE = 2, DIAG must contain positive - entries that serve as multiplicative scale factors for the - variables. -0 MODE is an integer input variable. If MODE = 1, the variables - will be scaled internally. If MODE = 2, the scaling is speci - fied by the input DIAG. Other values of MODE are equivalent - to MODE = 1. -0 FACTOR is a positive input variable used in determining the ini - tial step bound. This bound is set to the product of FACTOR - and the Euclidean norm of DIAG*X if nonzero, or else to FACTO - itself. In most cases FACTOR should lie in the interval - (.1,100.). 100. is a generally recommended value. -1 -0 Page -0 NPRINT is an integer input variable that enables controlled - printing of iterates if it is positive. In this case, FCN is - called with IFLAG = 0 at the beginning of the first iteration - and every NPRINT iterations thereafter and immediately prior - to return, with X and FVEC available for printing. If NPRINT - is not positive, no special calls of FCN with IFLAG = 0 are - made. -0 INFO is an integer output variable. If the user has terminated - execution, INFO is set to the (negative) value of IFLAG. See - description of FCN. Otherwise, INFO is set as follows. -0 INFO = 0 Improper input parameters. -0 INFO = 1 Relative error between two consecutive iterates is - at most XTOL. -0 INFO = 2 Number of calls to FCN has reached or exceeded - MAXFEV. -0 INFO = 3 XTOL is too small. No further improvement in the - approximate solution X is possible. -0 INFO = 4 Iteration is not making good progress, as measured - by the improvement from the last five Jacobian eval - uations. -0 INFO = 5 Iteration is not making good progress, as measured - by the improvement from the last ten iterations. -0 Sections 4 and 5 contain more details about INFO. -0 NFEV is an integer output variable set to the number of calls t - FCN. -0 FJAC is an output N by N array which contains the orthogonal - matrix Q produced by the QR factorization of the final approx - imate Jacobian. -0 LDFJAC is a positive integer input variable not less than N - which specifies the leading dimension of the array FJAC. -0 R is an output array of length LR which contains the upper - triangular matrix produced by the QR factorization of the - final approximate Jacobian, stored rowwise. -0 LR is a positive integer input variable not less than - (N*(N+1))/2. -0 QTF is an output array of length N which contains the vector - (Q transpose)*FVEC. -0 WA1, WA2, WA3, and WA4 are work arrays of length N. -1 -0 Page -0 - 4. Successful completion. -0 The accuracy of HYBRD is controlled by the convergence paramete - XTOL. This parameter is used in a test which makes a compariso - between the approximation X and a solution XSOL. HYBRD termi- - nates when the test is satisfied. If the convergence parameter - is less than the machine precision (as defined by the MINPACK - function SPMPAR(1)), then HYBRD only attempts to satisfy the - test defined by the machine precision. Further progress is not - usually possible. -0 The test assumes that the functions are reasonably well behaved - If this condition is not satisfied, then HYBRD may incorrectly - indicate convergence. The validity of the answer can be - checked, for example, by rerunning HYBRD with a tighter toler- - ance. -0 Convergence test. If ENORM(Z) denotes the Euclidean norm of a - vector Z and D is the diagonal matrix whose entries are - defined by the array DIAG, then this test attempts to guaran- - tee that -0 ENORM(D*(X-XSOL)) .LE. XTOL*ENORM(D*XSOL). -0 If this condition is satisfied with XTOL = 10**(-K), then the - larger components of D*X have K significant decimal digits an - INFO is set to 1. There is a danger that the smaller compo- - nents of D*X may have large relative errors, but the fast rat - of convergence of HYBRD usually avoids this possibility. - Unless high precision solutions are required, the recommended - value for XTOL is the square root of the machine precision. -0 - 5. Unsuccessful completion. -0 Unsuccessful termination of HYBRD can be due to improper input - parameters, arithmetic interrupts, an excessive number of func- - tion evaluations, or lack of good progress. -0 Improper input parameters. INFO is set to 0 if N .LE. 0, or - XTOL .LT. 0.E0, or MAXFEV .LE. 0, or ML .LT. 0, or MU .LT. 0, - or FACTOR .LE. 0.E0, or LDFJAC .LT. N, or LR .LT. (N*(N+1))/2 -0 Arithmetic interrupts. If these interrupts occur in the FCN - subroutine during an early stage of the computation, they may - be caused by an unacceptable choice of X by HYBRD. In this - case, it may be possible to remedy the situation by rerunning - HYBRD with a smaller value of FACTOR. -0 Excessive number of function evaluations. A reasonable value - for MAXFEV is 200*(N+1). If the number of calls to FCN - reaches MAXFEV, then this indicates that the routine is con- - verging very slowly as measured by the progress of FVEC, and -1 -0 Page -0 INFO is set to 2. This situation should be unusual because, - as indicated below, lack of good progress is usually diagnose - earlier by HYBRD, causing termination with INFO = 4 or - INFO = 5. -0 Lack of good progress. HYBRD searches for a zero of the system - by minimizing the sum of the squares of the functions. In so - doing, it can become trapped in a region where the minimum - does not correspond to a zero of the system and, in this situ - ation, the iteration eventually fails to make good progress. - In particular, this will happen if the system does not have a - zero. If the system has a zero, rerunning HYBRD from a dif- - ferent starting point may be helpful. -0 - 6. Characteristics of the algorithm. -0 HYBRD is a modification of the Powell hybrid method. Two of it - main characteristics involve the choice of the correction as a - convex combination of the Newton and scaled gradient directions - and the updating of the Jacobian by the rank-1 method of Broy- - den. The choice of the correction guarantees (under reasonable - conditions) global convergence for starting points far from the - solution and a fast rate of convergence. The Jacobian is - approximated by forward differences at the starting point, but - forward differences are not used again until the rank-1 method - fails to produce satisfactory progress. -0 Timing. The time required by HYBRD to solve a given problem - depends on N, the behavior of the functions, the accuracy - requested, and the starting point. The number of arithmetic - operations needed by HYBRD is about 11.5*(N**2) to process - each call to FCN. Unless FCN can be evaluated quickly, the - timing of HYBRD will be strongly influenced by the time spent - in FCN. -0 Storage. HYBRD requires (3*N**2 + 17*N)/2 single precision - storage locations, in addition to the storage required by the - program. There are no internally declared storage arrays. -0 - 7. Subprograms required. -0 USER-supplied ...... FCN -0 MINPACK-supplied ... DOGLEG,SPMPAR,ENORM,FDJAC1, - QFORM,QRFAC,R1MPYQ,R1UPDT -0 FORTRAN-supplied ... ABS,AMAX1,AMIN1,SQRT,MIN0,MOD -0 - 8. References. -0 M. J. D. Powell, A Hybrid Method for Nonlinear Equations. -1 -0 Page -0 Numerical Methods for Nonlinear Algebraic Equations, - P. Rabinowitz, editor. Gordon and Breach, 1970. -0 - 9. Example. -0 The problem is to determine the values of x(1), x(2), ..., x(9) - which solve the system of tridiagonal equations -0 (3-2*x(1))*x(1) -2*x(2) = -1 - -x(i-1) + (3-2*x(i))*x(i) -2*x(i+1) = -1, i=2-8 - -x(8) + (3-2*x(9))*x(9) = -1 -0 C ********** - C - C DRIVER FOR HYBRD EXAMPLE. - C SINGLE PRECISION VERSION - C - C ********** - INTEGER J,N,MAXFEV,ML,MU,MODE,NPRINT,INFO,NFEV,LDFJAC,LR,NWRITE - REAL XTOL,EPSFCN,FACTOR,FNORM - REAL X(9),FVEC(9),DIAG(9),FJAC(9,9),R(45),QTF(9), - * WA1(9),WA2(9),WA3(9),WA4(9) - REAL ENORM,SPMPAR - EXTERNAL FCN - C - C LOGICAL OUTPUT UNIT IS ASSUMED TO BE NUMBER 6. - C - DATA NWRITE /6/ - C - N = 9 - C - C THE FOLLOWING STARTING VALUES PROVIDE A ROUGH SOLUTION. - C - DO 10 J = 1, 9 - X(J) = -1.E0 - 10 CONTINUE - C - LDFJAC = 9 - LR = 45 - C - C SET XTOL TO THE SQUARE ROOT OF THE MACHINE PRECISION. - C UNLESS HIGH PRECISION SOLUTIONS ARE REQUIRED, - C THIS IS THE RECOMMENDED SETTING. - C - XTOL = SQRT(SPMPAR(1)) - C - MAXFEV = 2000 - ML = 1 - MU = 1 - EPSFCN = 0.E0 - MODE = 2 - DO 20 J = 1, 9 - DIAG(J) = 1.E0 -1 -0 Page -0 20 CONTINUE - FACTOR = 1.E2 - NPRINT = 0 - C - CALL HYBRD(FCN,N,X,FVEC,XTOL,MAXFEV,ML,MU,EPSFCN,DIAG, - * MODE,FACTOR,NPRINT,INFO,NFEV,FJAC,LDFJAC, - * R,LR,QTF,WA1,WA2,WA3,WA4) - FNORM = ENORM(N,FVEC) - WRITE (NWRITE,1000) FNORM,NFEV,INFO,(X(J),J=1,N) - STOP - 1000 FORMAT (5X,31H FINAL L2 NORM OF THE RESIDUALS,E15.7 // - * 5X,31H NUMBER OF FUNCTION EVALUATIONS,I10 // - * 5X,15H EXIT PARAMETER,16X,I10 // - * 5X,27H FINAL APPROXIMATE SOLUTION // (5X,3E15.7)) - C - C LAST CARD OF DRIVER FOR HYBRD EXAMPLE. - C - END - SUBROUTINE FCN(N,X,FVEC,IFLAG) - INTEGER N,IFLAG - REAL X(N),FVEC(N) - C - C SUBROUTINE FCN FOR HYBRD EXAMPLE. - C - INTEGER K - REAL ONE,TEMP,TEMP1,TEMP2,THREE,TWO,ZERO - DATA ZERO,ONE,TWO,THREE /0.E0,1.E0,2.E0,3.E0/ - C - IF (IFLAG .NE. 0) GO TO 5 - C - C INSERT PRINT STATEMENTS HERE WHEN NPRINT IS POSITIVE. - C - RETURN - 5 CONTINUE - DO 10 K = 1, N - TEMP = (THREE - TWO*X(K))*X(K) - TEMP1 = ZERO - IF (K .NE. 1) TEMP1 = X(K-1) - TEMP2 = ZERO - IF (K .NE. N) TEMP2 = X(K+1) - FVEC(K) = TEMP - TEMP1 - TWO*TEMP2 + ONE - 10 CONTINUE - RETURN - C - C LAST CARD OF SUBROUTINE FCN. - C - END -0 Results obtained with different compilers or machines - may be slightly different. -0 FINAL L2 NORM OF THE RESIDUALS 0.1192636E-07 -0 NUMBER OF FUNCTION EVALUATIONS 14 -1 -0 Page -0 EXIT PARAMETER 1 -0 FINAL APPROXIMATE SOLUTION -0 -0.5706545E+00 -0.6816283E+00 -0.7017325E+00 - -0.7042129E+00 -0.7013690E+00 -0.6918656E+00 - -0.6657920E+00 -0.5960342E+00 -0.4164121E+00 -1 -0 -1 -0 Page -0 Documentation for MINPACK subroutine HYBRJ1 -0 Single precision version -0 Argonne National Laboratory -0 Burton S. Garbow, Kenneth E. Hillstrom, Jorge J. More -0 March 1980 -0 - 1. Purpose. -0 The purpose of HYBRJ1 is to find a zero of a system of N non- - linear functions in N variables by a modification of the Powell - hybrid method. This is done by using the more general nonlinea - equation solver HYBRJ. The user must provide a subroutine whic - calculates the functions and the Jacobian. -0 - 2. Subroutine and type statements. -0 SUBROUTINE HYBRJ1(FCN,N,X,FVEC,FJAC,LDFJAC,TOL,INFO,WA,LWA) - INTEGER N,LDFJAC,INFO,LWA - REAL TOL - REAL X(N),FVEC(N),FJAC(LDFJAC,N),WA(LWA) - EXTERNAL FCN -0 - 3. Parameters. -0 Parameters designated as input parameters must be specified on - entry to HYBRJ1 and are not changed on exit, while parameters - designated as output parameters need not be specified on entry - and are set to appropriate values on exit from HYBRJ1. -0 FCN is the name of the user-supplied subroutine which calculate - the functions and the Jacobian. FCN must be declared in an - EXTERNAL statement in the user calling program, and should be - written as follows. -0 SUBROUTINE FCN(N,X,FVEC,FJAC,LDFJAC,IFLAG) - INTEGER N,LDFJAC,IFLAG - REAL X(N),FVEC(N),FJAC(LDFJAC,N) - ---------- - IF IFLAG = 1 CALCULATE THE FUNCTIONS AT X AND - RETURN THIS VECTOR IN FVEC. DO NOT ALTER FJAC. - IF IFLAG = 2 CALCULATE THE JACOBIAN AT X AND - RETURN THIS MATRIX IN FJAC. DO NOT ALTER FVEC. - ---------- - RETURN - END -0 The value of IFLAG should not be changed by FCN unless the -1 -0 Page -0 user wants to terminate execution of HYBRJ1. In this case se - IFLAG to a negative integer. -0 N is a positive integer input variable set to the number of - functions and variables. -0 X is an array of length N. On input X must contain an initial - estimate of the solution vector. On output X contains the - final estimate of the solution vector. -0 FVEC is an output array of length N which contains the function - evaluated at the output X. -0 FJAC is an output N by N array which contains the orthogonal - matrix Q produced by the QR factorization of the final approx - imate Jacobian. Section 6 contains more details about the - approximation to the Jacobian. -0 LDFJAC is a positive integer input variable not less than N - which specifies the leading dimension of the array FJAC. -0 TOL is a nonnegative input variable. Termination occurs when - the algorithm estimates that the relative error between X and - the solution is at most TOL. Section 4 contains more details - about TOL. -0 INFO is an integer output variable. If the user has terminated - execution, INFO is set to the (negative) value of IFLAG. See - description of FCN. Otherwise, INFO is set as follows. -0 INFO = 0 Improper input parameters. -0 INFO = 1 Algorithm estimates that the relative error between - X and the solution is at most TOL. -0 INFO = 2 Number of calls to FCN with IFLAG = 1 has reached - 100*(N+1). -0 INFO = 3 TOL is too small. No further improvement in the - approximate solution X is possible. -0 INFO = 4 Iteration is not making good progress. -0 Sections 4 and 5 contain more details about INFO. -0 WA is a work array of length LWA. -0 LWA is a positive integer input variable not less than - (N*(N+13))/2. -0 - 4. Successful completion. -0 The accuracy of HYBRJ1 is controlled by the convergence -1 -0 Page -0 parameter TOL. This parameter is used in a test which makes a - comparison between the approximation X and a solution XSOL. - HYBRJ1 terminates when the test is satisfied. If TOL is less - than the machine precision (as defined by the MINPACK function - SPMPAR(1)), then HYBRJ1 only attempts to satisfy the test - defined by the machine precision. Further progress is not usu- - ally possible. Unless high precision solutions are required, - the recommended value for TOL is the square root of the machine - precision. -0 The test assumes that the functions and the Jacobian are coded - consistently, and that the functions are reasonably well - behaved. If these conditions are not satisfied, then HYBRJ1 ma - incorrectly indicate convergence. The coding of the Jacobian - can be checked by the MINPACK subroutine CHKDER. If the Jaco- - bian is coded correctly, then the validity of the answer can be - checked, for example, by rerunning HYBRJ1 with a tighter toler- - ance. -0 Convergence test. If ENORM(Z) denotes the Euclidean norm of a - vector Z, then this test attempts to guarantee that -0 ENORM(X-XSOL) .LE. TOL*ENORM(XSOL). -0 If this condition is satisfied with TOL = 10**(-K), then the - larger components of X have K significant decimal digits and - INFO is set to 1. There is a danger that the smaller compo- - nents of X may have large relative errors, but the fast rate - of convergence of HYBRJ1 usually avoids this possibility. -0 - 5. Unsuccessful completion. -0 Unsuccessful termination of HYBRJ1 can be due to improper input - parameters, arithmetic interrupts, an excessive number of func- - tion evaluations, or lack of good progress. -0 Improper input parameters. INFO is set to 0 if N .LE. 0, or - LDFJAC .LT. N, or TOL .LT. 0.E0, or LWA .LT. (N*(N+13))/2. -0 Arithmetic interrupts. If these interrupts occur in the FCN - subroutine during an early stage of the computation, they may - be caused by an unacceptable choice of X by HYBRJ1. In this - case, it may be possible to remedy the situation by not evalu - ating the functions here, but instead setting the components - of FVEC to numbers that exceed those in the initial FVEC, - thereby indirectly reducing the step length. The step length - can be more directly controlled by using instead HYBRJ, which - includes in its calling sequence the step-length- governing - parameter FACTOR. -0 Excessive number of function evaluations. If the number of - calls to FCN with IFLAG = 1 reaches 100*(N+1), then this indi - cates that the routine is converging very slowly as measured -1 -0 Page -0 by the progress of FVEC, and INFO is set to 2. This situatio - should be unusual because, as indicated below, lack of good - progress is usually diagnosed earlier by HYBRJ1, causing ter- - mination with INFO = 4. -0 Lack of good progress. HYBRJ1 searches for a zero of the syste - by minimizing the sum of the squares of the functions. In so - doing, it can become trapped in a region where the minimum - does not correspond to a zero of the system and, in this situ - ation, the iteration eventually fails to make good progress. - In particular, this will happen if the system does not have a - zero. If the system has a zero, rerunning HYBRJ1 from a dif- - ferent starting point may be helpful. -0 - 6. Characteristics of the algorithm. -0 HYBRJ1 is a modification of the Powell hybrid method. Two of - its main characteristics involve the choice of the correction a - a convex combination of the Newton and scaled gradient direc- - tions, and the updating of the Jacobian by the rank-1 method of - Broyden. The choice of the correction guarantees (under reason - able conditions) global convergence for starting points far fro - the solution and a fast rate of convergence. The Jacobian is - calculated at the starting point, but it is not recalculated - until the rank-1 method fails to produce satisfactory progress. -0 Timing. The time required by HYBRJ1 to solve a given problem - depends on N, the behavior of the functions, the accuracy - requested, and the starting point. The number of arithmetic - operations needed by HYBRJ1 is about 11.5*(N**2) to process - each evaluation of the functions (call to FCN with IFLAG = 1) - and 1.3*(N**3) to process each evaluation of the Jacobian - (call to FCN with IFLAG = 2). Unless FCN can be evaluated - quickly, the timing of HYBRJ1 will be strongly influenced by - the time spent in FCN. -0 Storage. HYBRJ1 requires (3*N**2 + 17*N)/2 single precision - storage locations, in addition to the storage required by the - program. There are no internally declared storage arrays. -0 - 7. Subprograms required. -0 USER-supplied ...... FCN -0 MINPACK-supplied ... DOGLEG,SPMPAR,ENORM,HYBRJ, - QFORM,QRFAC,R1MPYQ,R1UPDT -0 FORTRAN-supplied ... ABS,AMAX1,AMIN1,SQRT,MIN0,MOD -0 - 8. References. -1 -0 Page -0 M. J. D. Powell, A Hybrid Method for Nonlinear Equations. - Numerical Methods for Nonlinear Algebraic Equations, - P. Rabinowitz, editor. Gordon and Breach, 1970. -0 - 9. Example. -0 The problem is to determine the values of x(1), x(2), ..., x(9) - which solve the system of tridiagonal equations -0 (3-2*x(1))*x(1) -2*x(2) = -1 - -x(i-1) + (3-2*x(i))*x(i) -2*x(i+1) = -1, i=2-8 - -x(8) + (3-2*x(9))*x(9) = -1 -0 C ********** - C - C DRIVER FOR HYBRJ1 EXAMPLE. - C SINGLE PRECISION VERSION - C - C ********** - INTEGER J,N,LDFJAC,INFO,LWA,NWRITE - REAL TOL,FNORM - REAL X(9),FVEC(9),FJAC(9,9),WA(99) - REAL ENORM,SPMPAR - EXTERNAL FCN - C - C LOGICAL OUTPUT UNIT IS ASSUMED TO BE NUMBER 6. - C - DATA NWRITE /6/ - C - N = 9 - C - C THE FOLLOWING STARTING VALUES PROVIDE A ROUGH SOLUTION. - C - DO 10 J = 1, 9 - X(J) = -1.E0 - 10 CONTINUE - C - LDFJAC = 9 - LWA = 99 - C - C SET TOL TO THE SQUARE ROOT OF THE MACHINE PRECISION. - C UNLESS HIGH PRECISION SOLUTIONS ARE REQUIRED, - C THIS IS THE RECOMMENDED SETTING. - C - TOL = SQRT(SPMPAR(1)) - C - CALL HYBRJ1(FCN,N,X,FVEC,FJAC,LDFJAC,TOL,INFO,WA,LWA) - FNORM = ENORM(N,FVEC) - WRITE (NWRITE,1000) FNORM,INFO,(X(J),J=1,N) - STOP - 1000 FORMAT (5X,31H FINAL L2 NORM OF THE RESIDUALS,E15.7 // - * 5X,15H EXIT PARAMETER,16X,I10 // - * 5X,27H FINAL APPROXIMATE SOLUTION // (5X,3E15.7)) -1 -0 Page -0 C - C LAST CARD OF DRIVER FOR HYBRJ1 EXAMPLE. - C - END - SUBROUTINE FCN(N,X,FVEC,FJAC,LDFJAC,IFLAG) - INTEGER N,LDFJAC,IFLAG - REAL X(N),FVEC(N),FJAC(LDFJAC,N) - C - C SUBROUTINE FCN FOR HYBRJ1 EXAMPLE. - C - INTEGER J,K - REAL ONE,TEMP,TEMP1,TEMP2,THREE,TWO,ZERO - DATA ZERO,ONE,TWO,THREE,FOUR /0.E0,1.E0,2.E0,3.E0,4.E0/ - C - IF (IFLAG .EQ. 2) GO TO 20 - DO 10 K = 1, N - TEMP = (THREE - TWO*X(K))*X(K) - TEMP1 = ZERO - IF (K .NE. 1) TEMP1 = X(K-1) - TEMP2 = ZERO - IF (K .NE. N) TEMP2 = X(K+1) - FVEC(K) = TEMP - TEMP1 - TWO*TEMP2 + ONE - 10 CONTINUE - GO TO 50 - 20 CONTINUE - DO 40 K = 1, N - DO 30 J = 1, N - FJAC(K,J) = ZERO - 30 CONTINUE - FJAC(K,K) = THREE - FOUR*X(K) - IF (K .NE. 1) FJAC(K,K-1) = -ONE - IF (K .NE. N) FJAC(K,K+1) = -TWO - 40 CONTINUE - 50 CONTINUE - RETURN - C - C LAST CARD OF SUBROUTINE FCN. - C - END -0 Results obtained with different compilers or machines - may be slightly different. -0 FINAL L2 NORM OF THE RESIDUALS 0.1192636E-07 -0 EXIT PARAMETER 1 -0 FINAL APPROXIMATE SOLUTION -0 -0.5706545E+00 -0.6816283E+00 -0.7017325E+00 - -0.7042129E+00 -0.7013690E+00 -0.6918656E+00 - -0.6657920E+00 -0.5960342E+00 -0.4164121E+00 -1 -0 -1 -0 Page -0 Documentation for MINPACK subroutine HYBRJ -0 Single precision version -0 Argonne National Laboratory -0 Burton S. Garbow, Kenneth E. Hillstrom, Jorge J. More -0 March 1980 -0 - 1. Purpose. -0 The purpose of HYBRJ is to find a zero of a system of N non- - linear functions in N variables by a modification of the Powell - hybrid method. The user must provide a subroutine which calcu- - lates the functions and the Jacobian. -0 - 2. Subroutine and type statements. -0 SUBROUTINE HYBRJ(FCN,N,X,FVEC,FJAC,LDFJAC,XTOL,MAXFEV,DIAG, - * MODE,FACTOR,NPRINT,INFO,NFEV,NJEV,R,LR,QTF, - * WA1,WA2,WA3,WA4) - INTEGER N,LDFJAC,MAXFEV,MODE,NPRINT,INFO,NFEV,NJEV,LR - REAL XTOL,FACTOR - REAL X(N),FVEC(N),FJAC(LDFJAC,N),DIAG(N),R(LR),QTF(N), - * WA1(N),WA2(N),WA3(N),WA4(N) -0 - 3. Parameters. -0 Parameters designated as input parameters must be specified on - entry to HYBRJ and are not changed on exit, while parameters - designated as output parameters need not be specified on entry - and are set to appropriate values on exit from HYBRJ. -0 FCN is the name of the user-supplied subroutine which calculate - the functions and the Jacobian. FCN must be declared in an - EXTERNAL statement in the user calling program, and should be - written as follows. -0 SUBROUTINE FCN(N,X,FVEC,FJAC,LDFJAC,IFLAG) - INTEGER N,LDFJAC,IFLAG - REAL X(N),FVEC(N),FJAC(LDFJAC,N) - ---------- - IF IFLAG = 1 CALCULATE THE FUNCTIONS AT X AND - RETURN THIS VECTOR IN FVEC. DO NOT ALTER FJAC. - IF IFLAG = 2 CALCULATE THE JACOBIAN AT X AND - RETURN THIS MATRIX IN FJAC. DO NOT ALTER FVEC. - ---------- - RETURN - END -1 -0 Page -0 The value of IFLAG should not be changed by FCN unless the - user wants to terminate execution of HYBRJ. In this case set - IFLAG to a negative integer. -0 N is a positive integer input variable set to the number of - functions and variables. -0 X is an array of length N. On input X must contain an initial - estimate of the solution vector. On output X contains the - final estimate of the solution vector. -0 FVEC is an output array of length N which contains the function - evaluated at the output X. -0 FJAC is an output N by N array which contains the orthogonal - matrix Q produced by the QR factorization of the final approx - imate Jacobian. Section 6 contains more details about the - approximation to the Jacobian. -0 LDFJAC is a positive integer input variable not less than N - which specifies the leading dimension of the array FJAC. -0 XTOL is a nonnegative input variable. Termination occurs when - the relative error between two consecutive iterates is at mos - XTOL. Therefore, XTOL measures the relative error desired in - the approximate solution. Section 4 contains more details - about XTOL. -0 MAXFEV is a positive integer input variable. Termination occur - when the number of calls to FCN with IFLAG = 1 has reached - MAXFEV. -0 DIAG is an array of length N. If MODE = 1 (see below), DIAG is - internally set. If MODE = 2, DIAG must contain positive - entries that serve as multiplicative scale factors for the - variables. -0 MODE is an integer input variable. If MODE = 1, the variables - will be scaled internally. If MODE = 2, the scaling is speci - fied by the input DIAG. Other values of MODE are equivalent - to MODE = 1. -0 FACTOR is a positive input variable used in determining the ini - tial step bound. This bound is set to the product of FACTOR - and the Euclidean norm of DIAG*X if nonzero, or else to FACTO - itself. In most cases FACTOR should lie in the interval - (.1,100.). 100. is a generally recommended value. -0 NPRINT is an integer input variable that enables controlled - printing of iterates if it is positive. In this case, FCN is - called with IFLAG = 0 at the beginning of the first iteration - and every NPRINT iterations thereafter and immediately prior - to return, with X and FVEC available for printing. FVEC and - FJAC should not be altered. If NPRINT is not positive, no -1 -0 Page -0 special calls of FCN with IFLAG = 0 are made. -0 INFO is an integer output variable. If the user has terminated - execution, INFO is set to the (negative) value of IFLAG. See - description of FCN. Otherwise, INFO is set as follows. -0 INFO = 0 Improper input parameters. -0 INFO = 1 Relative error between two consecutive iterates is - at most XTOL. -0 INFO = 2 Number of calls to FCN with IFLAG = 1 has reached - MAXFEV. -0 INFO = 3 XTOL is too small. No further improvement in the - approximate solution X is possible. -0 INFO = 4 Iteration is not making good progress, as measured - by the improvement from the last five Jacobian eval - uations. -0 INFO = 5 Iteration is not making good progress, as measured - by the improvement from the last ten iterations. -0 Sections 4 and 5 contain more details about INFO. -0 NFEV is an integer output variable set to the number of calls t - FCN with IFLAG = 1. -0 NJEV is an integer output variable set to the number of calls t - FCN with IFLAG = 2. -0 R is an output array of length LR which contains the upper - triangular matrix produced by the QR factorization of the - final approximate Jacobian, stored rowwise. -0 LR is a positive integer input variable not less than - (N*(N+1))/2. -0 QTF is an output array of length N which contains the vector - (Q transpose)*FVEC. -0 WA1, WA2, WA3, and WA4 are work arrays of length N. -0 - 4. Successful completion. -0 The accuracy of HYBRJ is controlled by the convergence paramete - XTOL. This parameter is used in a test which makes a compariso - between the approximation X and a solution XSOL. HYBRJ termi- - nates when the test is satisfied. If the convergence parameter - is less than the machine precision (as defined by the MINPACK - function SPMPAR(1)), then HYBRJ only attempts to satisfy the - test defined by the machine precision. Further progress is not -1 -0 Page -0 usually possible. -0 The test assumes that the functions and the Jacobian are coded - consistently, and that the functions are reasonably well - behaved. If these conditions are not satisfied, then HYBRJ may - incorrectly indicate convergence. The coding of the Jacobian - can be checked by the MINPACK subroutine CHKDER. If the Jaco- - bian is coded correctly, then the validity of the answer can be - checked, for example, by rerunning HYBRJ with a tighter toler- - ance. -0 Convergence test. If ENORM(Z) denotes the Euclidean norm of a - vector Z and D is the diagonal matrix whose entries are - defined by the array DIAG, then this test attempts to guaran- - tee that -0 ENORM(D*(X-XSOL)) .LE. XTOL*ENORM(D*XSOL). -0 If this condition is satisfied with XTOL = 10**(-K), then the - larger components of D*X have K significant decimal digits an - INFO is set to 1. There is a danger that the smaller compo- - nents of D*X may have large relative errors, but the fast rat - of convergence of HYBRJ usually avoids this possibility. - Unless high precision solutions are required, the recommended - value for XTOL is the square root of the machine precision. -0 - 5. Unsuccessful completion. -0 Unsuccessful termination of HYBRJ can be due to improper input - parameters, arithmetic interrupts, an excessive number of func- - tion evaluations, or lack of good progress. -0 Improper input parameters. INFO is set to 0 if N .LE. 0, or - LDFJAC .LT. N, or XTOL .LT. 0.E0, or MAXFEV .LE. 0, or - FACTOR .LE. 0.E0, or LR .LT. (N*(N+1))/2. -0 Arithmetic interrupts. If these interrupts occur in the FCN - subroutine during an early stage of the computation, they may - be caused by an unacceptable choice of X by HYBRJ. In this - case, it may be possible to remedy the situation by rerunning - HYBRJ with a smaller value of FACTOR. -0 Excessive number of function evaluations. A reasonable value - for MAXFEV is 100*(N+1). If the number of calls to FCN with - IFLAG = 1 reaches MAXFEV, then this indicates that the routin - is converging very slowly as measured by the progress of FVEC - and INFO is set to 2. This situation should be unusual - because, as indicated below, lack of good progress is usually - diagnosed earlier by HYBRJ, causing termination with INFO = 4 - or INFO = 5. -0 Lack of good progress. HYBRJ searches for a zero of the system - by minimizing the sum of the squares of the functions. In so -1 -0 Page -0 doing, it can become trapped in a region where the minimum - does not correspond to a zero of the system and, in this situ - ation, the iteration eventually fails to make good progress. - In particular, this will happen if the system does not have a - zero. If the system has a zero, rerunning HYBRJ from a dif- - ferent starting point may be helpful. -0 - 6. Characteristics of the algorithm. -0 HYBRJ is a modification of the Powell hybrid method. Two of it - main characteristics involve the choice of the correction as a - convex combination of the Newton and scaled gradient directions - and the updating of the Jacobian by the rank-1 method of Broy- - den. The choice of the correction guarantees (under reasonable - conditions) global convergence for starting points far from the - solution and a fast rate of convergence. The Jacobian is calcu - lated at the starting point, but it is not recalculated until - the rank-1 method fails to produce satisfactory progress. -0 Timing. The time required by HYBRJ to solve a given problem - depends on N, the behavior of the functions, the accuracy - requested, and the starting point. The number of arithmetic - operations needed by HYBRJ is about 11.5*(N**2) to process - each evaluation of the functions (call to FCN with IFLAG = 1) - and 1.3*(N**3) to process each evaluation of the Jacobian - (call to FCN with IFLAG = 2). Unless FCN can be evaluated - quickly, the timing of HYBRJ will be strongly influenced by - the time spent in FCN. -0 Storage. HYBRJ requires (3*N**2 + 17*N)/2 single precision - storage locations, in addition to the storage required by the - program. There are no internally declared storage arrays. -0 - 7. Subprograms required. -0 USER-supplied ...... FCN -0 MINPACK-supplied ... DOGLEG,SPMPAR,ENORM, - QFORM,QRFAC,R1MPYQ,R1UPDT -0 FORTRAN-supplied ... ABS,AMAX1,AMIN1,SQRT,MIN0,MOD -0 - 8. References. -0 M. J. D. Powell, A Hybrid Method for Nonlinear Equations. - Numerical Methods for Nonlinear Algebraic Equations, - P. Rabinowitz, editor. Gordon and Breach, 1970. -0 - 9. Example. -1 -0 Page -0 The problem is to determine the values of x(1), x(2), ..., x(9) - which solve the system of tridiagonal equations -0 (3-2*x(1))*x(1) -2*x(2) = -1 - -x(i-1) + (3-2*x(i))*x(i) -2*x(i+1) = -1, i=2-8 - -x(8) + (3-2*x(9))*x(9) = -1 -0 C ********** - C - C DRIVER FOR HYBRJ EXAMPLE. - C SINGLE PRECISION VERSION - C - C ********** - INTEGER J,N,LDFJAC,MAXFEV,MODE,NPRINT,INFO,NFEV,NJEV,LR,NWRITE - REAL XTOL,FACTOR,FNORM - REAL X(9),FVEC(9),FJAC(9,9),DIAG(9),R(45),QTF(9), - * WA1(9),WA2(9),WA3(9),WA4(9) - REAL ENORM,SPMPAR - EXTERNAL FCN - C - C LOGICAL OUTPUT UNIT IS ASSUMED TO BE NUMBER 6. - C - DATA NWRITE /6/ - C - N = 9 - C - C THE FOLLOWING STARTING VALUES PROVIDE A ROUGH SOLUTION. - C - DO 10 J = 1, 9 - X(J) = -1.E0 - 10 CONTINUE - C - LDFJAC = 9 - LR = 45 - C - C SET XTOL TO THE SQUARE ROOT OF THE MACHINE PRECISION. - C UNLESS HIGH PRECISION SOLUTIONS ARE REQUIRED, - C THIS IS THE RECOMMENDED SETTING. - C - XTOL = SQRT(SPMPAR(1)) - C - MAXFEV = 1000 - MODE = 2 - DO 20 J = 1, 9 - DIAG(J) = 1.E0 - 20 CONTINUE - FACTOR = 1.E2 - NPRINT = 0 - C - CALL HYBRJ(FCN,N,X,FVEC,FJAC,LDFJAC,XTOL,MAXFEV,DIAG, - * MODE,FACTOR,NPRINT,INFO,NFEV,NJEV,R,LR,QTF, - * WA1,WA2,WA3,WA4) - FNORM = ENORM(N,FVEC) - WRITE (NWRITE,1000) FNORM,NFEV,NJEV,INFO,(X(J),J=1,N) -1 -0 Page -0 STOP - 1000 FORMAT (5X,31H FINAL L2 NORM OF THE RESIDUALS,E15.7 // - * 5X,31H NUMBER OF FUNCTION EVALUATIONS,I10 // - * 5X,31H NUMBER OF JACOBIAN EVALUATIONS,I10 // - * 5X,15H EXIT PARAMETER,16X,I10 // - * 5X,27H FINAL APPROXIMATE SOLUTION // (5X,3E15.7)) - C - C LAST CARD OF DRIVER FOR HYBRJ EXAMPLE. - C - END - SUBROUTINE FCN(N,X,FVEC,FJAC,LDFJAC,IFLAG) - INTEGER N,LDFJAC,IFLAG - REAL X(N),FVEC(N),FJAC(LDFJAC,N) - C - C SUBROUTINE FCN FOR HYBRJ EXAMPLE. - C - INTEGER J,K - REAL ONE,TEMP,TEMP1,TEMP2,THREE,TWO,ZERO - DATA ZERO,ONE,TWO,THREE,FOUR /0.E0,1.E0,2.E0,3.E0,4.E0/ - C - IF (IFLAG .NE. 0) GO TO 5 - C - C INSERT PRINT STATEMENTS HERE WHEN NPRINT IS POSITIVE. - C - RETURN - 5 CONTINUE - IF (IFLAG .EQ. 2) GO TO 20 - DO 10 K = 1, N - TEMP = (THREE - TWO*X(K))*X(K) - TEMP1 = ZERO - IF (K .NE. 1) TEMP1 = X(K-1) - TEMP2 = ZERO - IF (K .NE. N) TEMP2 = X(K+1) - FVEC(K) = TEMP - TEMP1 - TWO*TEMP2 + ONE - 10 CONTINUE - GO TO 50 - 20 CONTINUE - DO 40 K = 1, N - DO 30 J = 1, N - FJAC(K,J) = ZERO - 30 CONTINUE - FJAC(K,K) = THREE - FOUR*X(K) - IF (K .NE. 1) FJAC(K,K-1) = -ONE - IF (K .NE. N) FJAC(K,K+1) = -TWO - 40 CONTINUE - 50 CONTINUE - RETURN - C - C LAST CARD OF SUBROUTINE FCN. - C - END -0 Results obtained with different compilers or machines - may be slightly different. -1 -0 Page -0 FINAL L2 NORM OF THE RESIDUALS 0.1192636E-07 -0 NUMBER OF FUNCTION EVALUATIONS 11 -0 NUMBER OF JACOBIAN EVALUATIONS 1 -0 EXIT PARAMETER 1 -0 FINAL APPROXIMATE SOLUTION -0 -0.5706545E+00 -0.6816283E+00 -0.7017325E+00 - -0.7042129E+00 -0.7013690E+00 -0.6918656E+00 - -0.6657920E+00 -0.5960342E+00 -0.4164121E+00 -1 -0 -1 -0 Page -0 Documentation for MINPACK subroutine LMDER1 -0 Single precision version -0 Argonne National Laboratory -0 Burton S. Garbow, Kenneth E. Hillstrom, Jorge J. More -0 March 1980 -0 - 1. Purpose. -0 The purpose of LMDER1 is to minimize the sum of the squares of - nonlinear functions in N variables by a modification of the - Levenberg-Marquardt algorithm. This is done by using the more - general least-squares solver LMDER. The user must provide a - subroutine which calculates the functions and the Jacobian. -0 - 2. Subroutine and type statements. -0 SUBROUTINE LMDER1(FCN,M,N,X,FVEC,FJAC,LDFJAC,TOL, - * INFO,IPVT,WA,LWA) - INTEGER M,N,LDFJAC,INFO,LWA - INTEGER IPVT(N) - REAL TOL - REAL X(N),FVEC(M),FJAC(LDFJAC,N),WA(LWA) - EXTERNAL FCN -0 - 3. Parameters. -0 Parameters designated as input parameters must be specified on - entry to LMDER1 and are not changed on exit, while parameters - designated as output parameters need not be specified on entry - and are set to appropriate values on exit from LMDER1. -0 FCN is the name of the user-supplied subroutine which calculate - the functions and the Jacobian. FCN must be declared in an - EXTERNAL statement in the user calling program, and should be - written as follows. -0 SUBROUTINE FCN(M,N,X,FVEC,FJAC,LDFJAC,IFLAG) - INTEGER M,N,LDFJAC,IFLAG - REAL X(N),FVEC(M),FJAC(LDFJAC,N) - ---------- - IF IFLAG = 1 CALCULATE THE FUNCTIONS AT X AND - RETURN THIS VECTOR IN FVEC. DO NOT ALTER FJAC. - IF IFLAG = 2 CALCULATE THE JACOBIAN AT X AND - RETURN THIS MATRIX IN FJAC. DO NOT ALTER FVEC. - ---------- - RETURN - END -1 -0 Page -0 The value of IFLAG should not be changed by FCN unless the - user wants to terminate execution of LMDER1. In this case se - IFLAG to a negative integer. -0 M is a positive integer input variable set to the number of - functions. -0 N is a positive integer input variable set to the number of - variables. N must not exceed M. -0 X is an array of length N. On input X must contain an initial - estimate of the solution vector. On output X contains the - final estimate of the solution vector. -0 FVEC is an output array of length M which contains the function - evaluated at the output X. -0 FJAC is an output M by N array. The upper N by N submatrix of - FJAC contains an upper triangular matrix R with diagonal ele- - ments of nonincreasing magnitude such that -0 T T T - P *(JAC *JAC)*P = R *R, -0 where P is a permutation matrix and JAC is the final calcu- - lated Jacobian. Column j of P is column IPVT(j) (see below) - of the identity matrix. The lower trapezoidal part of FJAC - contains information generated during the computation of R. -0 LDFJAC is a positive integer input variable not less than M - which specifies the leading dimension of the array FJAC. -0 TOL is a nonnegative input variable. Termination occurs when - the algorithm estimates either that the relative error in the - sum of squares is at most TOL or that the relative error - between X and the solution is at most TOL. Section 4 contain - more details about TOL. -0 INFO is an integer output variable. If the user has terminated - execution, INFO is set to the (negative) value of IFLAG. See - description of FCN. Otherwise, INFO is set as follows. -0 INFO = 0 Improper input parameters. -0 INFO = 1 Algorithm estimates that the relative error in the - sum of squares is at most TOL. -0 INFO = 2 Algorithm estimates that the relative error between - X and the solution is at most TOL. -0 INFO = 3 Conditions for INFO = 1 and INFO = 2 both hold. -0 INFO = 4 FVEC is orthogonal to the columns of the Jacobian t - machine precision. -1 -0 Page -0 INFO = 5 Number of calls to FCN with IFLAG = 1 has reached - 100*(N+1). -0 INFO = 6 TOL is too small. No further reduction in the sum - of squares is possible. -0 INFO = 7 TOL is too small. No further improvement in the - approximate solution X is possible. -0 Sections 4 and 5 contain more details about INFO. -0 IPVT is an integer output array of length N. IPVT defines a - permutation matrix P such that JAC*P = Q*R, where JAC is the - final calculated Jacobian, Q is orthogonal (not stored), and - is upper triangular with diagonal elements of nonincreasing - magnitude. Column j of P is column IPVT(j) of the identity - matrix. -0 WA is a work array of length LWA. -0 LWA is a positive integer input variable not less than 5*N+M. -0 - 4. Successful completion. -0 The accuracy of LMDER1 is controlled by the convergence parame- - ter TOL. This parameter is used in tests which make three type - of comparisons between the approximation X and a solution XSOL. - LMDER1 terminates when any of the tests is satisfied. If TOL i - less than the machine precision (as defined by the MINPACK func - tion SPMPAR(1)), then LMDER1 only attempts to satisfy the test - defined by the machine precision. Further progress is not usu- - ally possible. Unless high precision solutions are required, - the recommended value for TOL is the square root of the machine - precision. -0 The tests assume that the functions and the Jacobian are coded - consistently, and that the functions are reasonably well - behaved. If these conditions are not satisfied, then LMDER1 ma - incorrectly indicate convergence. The coding of the Jacobian - can be checked by the MINPACK subroutine CHKDER. If the Jaco- - bian is coded correctly, then the validity of the answer can be - checked, for example, by rerunning LMDER1 with a tighter toler- - ance. -0 First convergence test. If ENORM(Z) denotes the Euclidean norm - of a vector Z, then this test attempts to guarantee that -0 ENORM(FVEC) .LE. (1+TOL)*ENORM(FVECS), -0 where FVECS denotes the functions evaluated at XSOL. If this - condition is satisfied with TOL = 10**(-K), then the final - residual norm ENORM(FVEC) has K significant decimal digits an - INFO is set to 1 (or to 3 if the second test is also -1 -0 Page -0 satisfied). -0 Second convergence test. If D is a diagonal matrix (implicitly - generated by LMDER1) whose entries contain scale factors for - the variables, then this test attempts to guarantee that -0 ENORM(D*(X-XSOL)) .LE. TOL*ENORM(D*XSOL). -0 If this condition is satisfied with TOL = 10**(-K), then the - larger components of D*X have K significant decimal digits an - INFO is set to 2 (or to 3 if the first test is also satis- - fied). There is a danger that the smaller components of D*X - may have large relative errors, but the choice of D is such - that the accuracy of the components of X is usually related t - their sensitivity. -0 Third convergence test. This test is satisfied when FVEC is - orthogonal to the columns of the Jacobian to machine preci- - sion. There is no clear relationship between this test and - the accuracy of LMDER1, and furthermore, the test is equally - well satisfied at other critical points, namely maximizers an - saddle points. Therefore, termination caused by this test - (INFO = 4) should be examined carefully. -0 - 5. Unsuccessful completion. -0 Unsuccessful termination of LMDER1 can be due to improper input - parameters, arithmetic interrupts, or an excessive number of - function evaluations. -0 Improper input parameters. INFO is set to 0 if N .LE. 0, or - M .LT. N, or LDFJAC .LT. M, or TOL .LT. 0.E0, or - LWA .LT. 5*N+M. -0 Arithmetic interrupts. If these interrupts occur in the FCN - subroutine during an early stage of the computation, they may - be caused by an unacceptable choice of X by LMDER1. In this - case, it may be possible to remedy the situation by not evalu - ating the functions here, but instead setting the components - of FVEC to numbers that exceed those in the initial FVEC, - thereby indirectly reducing the step length. The step length - can be more directly controlled by using instead LMDER, which - includes in its calling sequence the step-length- governing - parameter FACTOR. -0 Excessive number of function evaluations. If the number of - calls to FCN with IFLAG = 1 reaches 100*(N+1), then this indi - cates that the routine is converging very slowly as measured - by the progress of FVEC, and INFO is set to 5. In this case, - it may be helpful to restart LMDER1, thereby forcing it to - disregard old (and possibly harmful) information. -0 -1 -0 Page -0 6. Characteristics of the algorithm. -0 LMDER1 is a modification of the Levenberg-Marquardt algorithm. - Two of its main characteristics involve the proper use of - implicitly scaled variables and an optimal choice for the cor- - rection. The use of implicitly scaled variables achieves scale - invariance of LMDER1 and limits the size of the correction in - any direction where the functions are changing rapidly. The - optimal choice of the correction guarantees (under reasonable - conditions) global convergence from starting points far from th - solution and a fast rate of convergence for problems with small - residuals. -0 Timing. The time required by LMDER1 to solve a given problem - depends on M and N, the behavior of the functions, the accu- - racy requested, and the starting point. The number of arith- - metic operations needed by LMDER1 is about N**3 to process - each evaluation of the functions (call to FCN with IFLAG = 1) - and M*(N**2) to process each evaluation of the Jacobian (call - to FCN with IFLAG = 2). Unless FCN can be evaluated quickly, - the timing of LMDER1 will be strongly influenced by the time - spent in FCN. -0 Storage. LMDER1 requires M*N + 2*M + 6*N single precision sto- - rage locations and N integer storage locations, in addition t - the storage required by the program. There are no internally - declared storage arrays. -0 - 7. Subprograms required. -0 USER-supplied ...... FCN -0 MINPACK-supplied ... SPMPAR,ENORM,LMDER,LMPAR,QRFAC,QRSOLV -0 FORTRAN-supplied ... ABS,AMAX1,AMIN1,SQRT,MOD -0 - 8. References. -0 Jorge J. More, The Levenberg-Marquardt Algorithm, Implementatio - and Theory. Numerical Analysis, G. A. Watson, editor. - Lecture Notes in Mathematics 630, Springer-Verlag, 1977. -0 - 9. Example. -0 The problem is to determine the values of x(1), x(2), and x(3) - which provide the best fit (in the least squares sense) of -0 x(1) + u(i)/(v(i)*x(2) + w(i)*x(3)), i = 1, 15 -0 to the data -1 -0 Page -0 y = (0.14,0.18,0.22,0.25,0.29,0.32,0.35,0.39, - 0.37,0.58,0.73,0.96,1.34,2.10,4.39), -0 where u(i) = i, v(i) = 16 - i, and w(i) = min(u(i),v(i)). The - i-th component of FVEC is thus defined by -0 y(i) - (x(1) + u(i)/(v(i)*x(2) + w(i)*x(3))). -0 C ********** - C - C DRIVER FOR LMDER1 EXAMPLE. - C SINGLE PRECISION VERSION - C - C ********** - INTEGER J,M,N,LDFJAC,INFO,LWA,NWRITE - INTEGER IPVT(3) - REAL TOL,FNORM - REAL X(3),FVEC(15),FJAC(15,3),WA(30) - REAL ENORM,SPMPAR - EXTERNAL FCN - C - C LOGICAL OUTPUT UNIT IS ASSUMED TO BE NUMBER 6. - C - DATA NWRITE /6/ - C - M = 15 - N = 3 - C - C THE FOLLOWING STARTING VALUES PROVIDE A ROUGH FIT. - C - X(1) = 1.E0 - X(2) = 1.E0 - X(3) = 1.E0 - C - LDFJAC = 15 - LWA = 30 - C - C SET TOL TO THE SQUARE ROOT OF THE MACHINE PRECISION. - C UNLESS HIGH PRECISION SOLUTIONS ARE REQUIRED, - C THIS IS THE RECOMMENDED SETTING. - C - TOL = SQRT(SPMPAR(1)) - C - CALL LMDER1(FCN,M,N,X,FVEC,FJAC,LDFJAC,TOL, - * INFO,IPVT,WA,LWA) - FNORM = ENORM(M,FVEC) - WRITE (NWRITE,1000) FNORM,INFO,(X(J),J=1,N) - STOP - 1000 FORMAT (5X,31H FINAL L2 NORM OF THE RESIDUALS,E15.7 // - * 5X,15H EXIT PARAMETER,16X,I10 // - * 5X,27H FINAL APPROXIMATE SOLUTION // 5X,3E15.7) - C - C LAST CARD OF DRIVER FOR LMDER1 EXAMPLE. - C -1 -0 Page -0 END - SUBROUTINE FCN(M,N,X,FVEC,FJAC,LDFJAC,IFLAG) - INTEGER M,N,LDFJAC,IFLAG - REAL X(N),FVEC(M),FJAC(LDFJAC,N) - C - C SUBROUTINE FCN FOR LMDER1 EXAMPLE. - C - INTEGER I - REAL TMP1,TMP2,TMP3,TMP4 - REAL Y(15) - DATA Y(1),Y(2),Y(3),Y(4),Y(5),Y(6),Y(7),Y(8), - * Y(9),Y(10),Y(11),Y(12),Y(13),Y(14),Y(15) - * /1.4E-1,1.8E-1,2.2E-1,2.5E-1,2.9E-1,3.2E-1,3.5E-1,3.9E-1, - * 3.7E-1,5.8E-1,7.3E-1,9.6E-1,1.34E0,2.1E0,4.39E0/ - C - IF (IFLAG .EQ. 2) GO TO 20 - DO 10 I = 1, 15 - TMP1 = I - TMP2 = 16 - I - TMP3 = TMP1 - IF (I .GT. 8) TMP3 = TMP2 - FVEC(I) = Y(I) - (X(1) + TMP1/(X(2)*TMP2 + X(3)*TMP3)) - 10 CONTINUE - GO TO 40 - 20 CONTINUE - DO 30 I = 1, 15 - TMP1 = I - TMP2 = 16 - I - TMP3 = TMP1 - IF (I .GT. 8) TMP3 = TMP2 - TMP4 = (X(2)*TMP2 + X(3)*TMP3)**2 - FJAC(I,1) = -1.E0 - FJAC(I,2) = TMP1*TMP2/TMP4 - FJAC(I,3) = TMP1*TMP3/TMP4 - 30 CONTINUE - 40 CONTINUE - RETURN - C - C LAST CARD OF SUBROUTINE FCN. - C - END -0 Results obtained with different compilers or machines - may be slightly different. -0 FINAL L2 NORM OF THE RESIDUALS 0.9063596E-01 -0 EXIT PARAMETER 1 -0 FINAL APPROXIMATE SOLUTION -0 0.8241058E-01 0.1133037E+01 0.2343695E+01 -1 -0 -1 -0 Page -0 Documentation for MINPACK subroutine LMDER -0 Single precision version -0 Argonne National Laboratory -0 Burton S. Garbow, Kenneth E. Hillstrom, Jorge J. More -0 March 1980 -0 - 1. Purpose. -0 The purpose of LMDER is to minimize the sum of the squares of M - nonlinear functions in N variables by a modification of the - Levenberg-Marquardt algorithm. The user must provide a subrou- - tine which calculates the functions and the Jacobian. -0 - 2. Subroutine and type statements. -0 SUBROUTINE LMDER(FCN,M,N,X,FVEC,FJAC,LDFJAC,FTOL,XTOL,GTOL, - * MAXFEV,DIAG,MODE,FACTOR,NPRINT,INFO,NFEV,NJEV, - * IPVT,QTF,WA1,WA2,WA3,WA4) - INTEGER M,N,LDFJAC,MAXFEV,MODE,NPRINT,INFO,NFEV,NJEV - INTEGER IPVT(N) - REAL FTOL,XTOL,GTOL,FACTOR - REAL X(N),FVEC(M),FJAC(LDFJAC,N),DIAG(N),QTF(N), - * WA1(N),WA2(N),WA3(N),WA4(M) -0 - 3. Parameters. -0 Parameters designated as input parameters must be specified on - entry to LMDER and are not changed on exit, while parameters - designated as output parameters need not be specified on entry - and are set to appropriate values on exit from LMDER. -0 FCN is the name of the user-supplied subroutine which calculate - the functions and the Jacobian. FCN must be declared in an - EXTERNAL statement in the user calling program, and should be - written as follows. -0 SUBROUTINE FCN(M,N,X,FVEC,FJAC,LDFJAC,IFLAG) - INTEGER M,N,LDFJAC,IFLAG - REAL X(N),FVEC(M),FJAC(LDFJAC,N) - ---------- - IF IFLAG = 1 CALCULATE THE FUNCTIONS AT X AND - RETURN THIS VECTOR IN FVEC. DO NOT ALTER FJAC. - IF IFLAG = 2 CALCULATE THE JACOBIAN AT X AND - RETURN THIS MATRIX IN FJAC. DO NOT ALTER FVEC. - ---------- - RETURN - END -1 -0 Page -0 The value of IFLAG should not be changed by FCN unless the - user wants to terminate execution of LMDER. In this case set - IFLAG to a negative integer. -0 M is a positive integer input variable set to the number of - functions. -0 N is a positive integer input variable set to the number of - variables. N must not exceed M. -0 X is an array of length N. On input X must contain an initial - estimate of the solution vector. On output X contains the - final estimate of the solution vector. -0 FVEC is an output array of length M which contains the function - evaluated at the output X. -0 FJAC is an output M by N array. The upper N by N submatrix of - FJAC contains an upper triangular matrix R with diagonal ele- - ments of nonincreasing magnitude such that -0 T T T - P *(JAC *JAC)*P = R *R, -0 where P is a permutation matrix and JAC is the final calcu- - lated Jacobian. Column j of P is column IPVT(j) (see below) - of the identity matrix. The lower trapezoidal part of FJAC - contains information generated during the computation of R. -0 LDFJAC is a positive integer input variable not less than M - which specifies the leading dimension of the array FJAC. -0 FTOL is a nonnegative input variable. Termination occurs when - both the actual and predicted relative reductions in the sum - of squares are at most FTOL. Therefore, FTOL measures the - relative error desired in the sum of squares. Section 4 con- - tains more details about FTOL. -0 XTOL is a nonnegative input variable. Termination occurs when - the relative error between two consecutive iterates is at mos - XTOL. Therefore, XTOL measures the relative error desired in - the approximate solution. Section 4 contains more details - about XTOL. -0 GTOL is a nonnegative input variable. Termination occurs when - the cosine of the angle between FVEC and any column of the - Jacobian is at most GTOL in absolute value. Therefore, GTOL - measures the orthogonality desired between the function vecto - and the columns of the Jacobian. Section 4 contains more - details about GTOL. -0 MAXFEV is a positive integer input variable. Termination occur - when the number of calls to FCN with IFLAG = 1 has reached - MAXFEV. -1 -0 Page -0 DIAG is an array of length N. If MODE = 1 (see below), DIAG is - internally set. If MODE = 2, DIAG must contain positive - entries that serve as multiplicative scale factors for the - variables. -0 MODE is an integer input variable. If MODE = 1, the variables - will be scaled internally. If MODE = 2, the scaling is speci - fied by the input DIAG. Other values of MODE are equivalent - to MODE = 1. -0 FACTOR is a positive input variable used in determining the ini - tial step bound. This bound is set to the product of FACTOR - and the Euclidean norm of DIAG*X if nonzero, or else to FACTO - itself. In most cases FACTOR should lie in the interval - (.1,100.). 100. is a generally recommended value. -0 NPRINT is an integer input variable that enables controlled - printing of iterates if it is positive. In this case, FCN is - called with IFLAG = 0 at the beginning of the first iteration - and every NPRINT iterations thereafter and immediately prior - to return, with X, FVEC, and FJAC available for printing. - FVEC and FJAC should not be altered. If NPRINT is not posi- - tive, no special calls of FCN with IFLAG = 0 are made. -0 INFO is an integer output variable. If the user has terminated - execution, INFO is set to the (negative) value of IFLAG. See - description of FCN. Otherwise, INFO is set as follows. -0 INFO = 0 Improper input parameters. -0 INFO = 1 Both actual and predicted relative reductions in th - sum of squares are at most FTOL. -0 INFO = 2 Relative error between two consecutive iterates is - at most XTOL. -0 INFO = 3 Conditions for INFO = 1 and INFO = 2 both hold. -0 INFO = 4 The cosine of the angle between FVEC and any column - of the Jacobian is at most GTOL in absolute value. -0 INFO = 5 Number of calls to FCN with IFLAG = 1 has reached - MAXFEV. -0 INFO = 6 FTOL is too small. No further reduction in the sum - of squares is possible. -0 INFO = 7 XTOL is too small. No further improvement in the - approximate solution X is possible. -0 INFO = 8 GTOL is too small. FVEC is orthogonal to the - columns of the Jacobian to machine precision. -0 Sections 4 and 5 contain more details about INFO. -1 -0 Page -0 NFEV is an integer output variable set to the number of calls t - FCN with IFLAG = 1. -0 NJEV is an integer output variable set to the number of calls t - FCN with IFLAG = 2. -0 IPVT is an integer output array of length N. IPVT defines a - permutation matrix P such that JAC*P = Q*R, where JAC is the - final calculated Jacobian, Q is orthogonal (not stored), and - is upper triangular with diagonal elements of nonincreasing - magnitude. Column j of P is column IPVT(j) of the identity - matrix. -0 QTF is an output array of length N which contains the first N - elements of the vector (Q transpose)*FVEC. -0 WA1, WA2, and WA3 are work arrays of length N. -0 WA4 is a work array of length M. -0 - 4. Successful completion. -0 The accuracy of LMDER is controlled by the convergence parame- - ters FTOL, XTOL, and GTOL. These parameters are used in tests - which make three types of comparisons between the approximation - X and a solution XSOL. LMDER terminates when any of the tests - is satisfied. If any of the convergence parameters is less tha - the machine precision (as defined by the MINPACK function - SPMPAR(1)), then LMDER only attempts to satisfy the test define - by the machine precision. Further progress is not usually pos- - sible. -0 The tests assume that the functions and the Jacobian are coded - consistently, and that the functions are reasonably well - behaved. If these conditions are not satisfied, then LMDER may - incorrectly indicate convergence. The coding of the Jacobian - can be checked by the MINPACK subroutine CHKDER. If the Jaco- - bian is coded correctly, then the validity of the answer can be - checked, for example, by rerunning LMDER with tighter toler- - ances. -0 First convergence test. If ENORM(Z) denotes the Euclidean norm - of a vector Z, then this test attempts to guarantee that -0 ENORM(FVEC) .LE. (1+FTOL)*ENORM(FVECS), -0 where FVECS denotes the functions evaluated at XSOL. If this - condition is satisfied with FTOL = 10**(-K), then the final - residual norm ENORM(FVEC) has K significant decimal digits an - INFO is set to 1 (or to 3 if the second test is also satis- - fied). Unless high precision solutions are required, the - recommended value for FTOL is the square root of the machine - precision. -1 -0 Page -0 Second convergence test. If D is the diagonal matrix whose - entries are defined by the array DIAG, then this test attempt - to guarantee that -0 ENORM(D*(X-XSOL)) .LE. XTOL*ENORM(D*XSOL). -0 If this condition is satisfied with XTOL = 10**(-K), then the - larger components of D*X have K significant decimal digits an - INFO is set to 2 (or to 3 if the first test is also satis- - fied). There is a danger that the smaller components of D*X - may have large relative errors, but if MODE = 1, then the - accuracy of the components of X is usually related to their - sensitivity. Unless high precision solutions are required, - the recommended value for XTOL is the square root of the - machine precision. -0 Third convergence test. This test is satisfied when the cosine - of the angle between FVEC and any column of the Jacobian at X - is at most GTOL in absolute value. There is no clear rela- - tionship between this test and the accuracy of LMDER, and - furthermore, the test is equally well satisfied at other crit - ical points, namely maximizers and saddle points. Therefore, - termination caused by this test (INFO = 4) should be examined - carefully. The recommended value for GTOL is zero. -0 - 5. Unsuccessful completion. -0 Unsuccessful termination of LMDER can be due to improper input - parameters, arithmetic interrupts, or an excessive number of - function evaluations. -0 Improper input parameters. INFO is set to 0 if N .LE. 0, or - M .LT. N, or LDFJAC .LT. M, or FTOL .LT. 0.E0, or - XTOL .LT. 0.E0, or GTOL .LT. 0.E0, or MAXFEV .LE. 0, or - FACTOR .LE. 0.E0. -0 Arithmetic interrupts. If these interrupts occur in the FCN - subroutine during an early stage of the computation, they may - be caused by an unacceptable choice of X by LMDER. In this - case, it may be possible to remedy the situation by rerunning - LMDER with a smaller value of FACTOR. -0 Excessive number of function evaluations. A reasonable value - for MAXFEV is 100*(N+1). If the number of calls to FCN with - IFLAG = 1 reaches MAXFEV, then this indicates that the routin - is converging very slowly as measured by the progress of FVEC - and INFO is set to 5. In this case, it may be helpful to - restart LMDER with MODE set to 1. -0 - 6. Characteristics of the algorithm. -0 LMDER is a modification of the Levenberg-Marquardt algorithm. -1 -0 Page -0 Two of its main characteristics involve the proper use of - implicitly scaled variables (if MODE = 1) and an optimal choice - for the correction. The use of implicitly scaled variables - achieves scale invariance of LMDER and limits the size of the - correction in any direction where the functions are changing - rapidly. The optimal choice of the correction guarantees (unde - reasonable conditions) global convergence from starting points - far from the solution and a fast rate of convergence for prob- - lems with small residuals. -0 Timing. The time required by LMDER to solve a given problem - depends on M and N, the behavior of the functions, the accu- - racy requested, and the starting point. The number of arith- - metic operations needed by LMDER is about N**3 to process eac - evaluation of the functions (call to FCN with IFLAG = 1) and - M*(N**2) to process each evaluation of the Jacobian (call to - FCN with IFLAG = 2). Unless FCN can be evaluated quickly, th - timing of LMDER will be strongly influenced by the time spent - in FCN. -0 Storage. LMDER requires M*N + 2*M + 6*N single precision sto- - rage locations and N integer storage locations, in addition t - the storage required by the program. There are no internally - declared storage arrays. -0 - 7. Subprograms required. -0 USER-supplied ...... FCN -0 MINPACK-supplied ... SPMPAR,ENORM,LMPAR,QRFAC,QRSOLV -0 FORTRAN-supplied ... ABS,AMAX1,AMIN1,SQRT,MOD -0 - 8. References. -0 Jorge J. More, The Levenberg-Marquardt Algorithm, Implementatio - and Theory. Numerical Analysis, G. A. Watson, editor. - Lecture Notes in Mathematics 630, Springer-Verlag, 1977. -0 - 9. Example. -0 The problem is to determine the values of x(1), x(2), and x(3) - which provide the best fit (in the least squares sense) of -0 x(1) + u(i)/(v(i)*x(2) + w(i)*x(3)), i = 1, 15 -0 to the data -0 y = (0.14,0.18,0.22,0.25,0.29,0.32,0.35,0.39, - 0.37,0.58,0.73,0.96,1.34,2.10,4.39), -1 -0 Page -0 where u(i) = i, v(i) = 16 - i, and w(i) = min(u(i),v(i)). The - i-th component of FVEC is thus defined by -0 y(i) - (x(1) + u(i)/(v(i)*x(2) + w(i)*x(3))). -0 C ********** - C - C DRIVER FOR LMDER EXAMPLE. - C SINGLE PRECISION VERSION - C - C ********** - INTEGER J,M,N,LDFJAC,MAXFEV,MODE,NPRINT,INFO,NFEV,NJEV,NWRITE - INTEGER IPVT(3) - REAL FTOL,XTOL,GTOL,FACTOR,FNORM - REAL X(3),FVEC(15),FJAC(15,3),DIAG(3),QTF(3), - * WA1(3),WA2(3),WA3(3),WA4(15) - REAL ENORM,SPMPAR - EXTERNAL FCN - C - C LOGICAL OUTPUT UNIT IS ASSUMED TO BE NUMBER 6. - C - DATA NWRITE /6/ - C - M = 15 - N = 3 - C - C THE FOLLOWING STARTING VALUES PROVIDE A ROUGH FIT. - C - X(1) = 1.E0 - X(2) = 1.E0 - X(3) = 1.E0 - C - LDFJAC = 15 - C - C SET FTOL AND XTOL TO THE SQUARE ROOT OF THE MACHINE PRECISION - C AND GTOL TO ZERO. UNLESS HIGH PRECISION SOLUTIONS ARE - C REQUIRED, THESE ARE THE RECOMMENDED SETTINGS. - C - FTOL = SQRT(SPMPAR(1)) - XTOL = SQRT(SPMPAR(1)) - GTOL = 0.E0 - C - MAXFEV = 400 - MODE = 1 - FACTOR = 1.E2 - NPRINT = 0 - C - CALL LMDER(FCN,M,N,X,FVEC,FJAC,LDFJAC,FTOL,XTOL,GTOL, - * MAXFEV,DIAG,MODE,FACTOR,NPRINT,INFO,NFEV,NJEV, - * IPVT,QTF,WA1,WA2,WA3,WA4) - FNORM = ENORM(M,FVEC) - WRITE (NWRITE,1000) FNORM,NFEV,NJEV,INFO,(X(J),J=1,N) - STOP - 1000 FORMAT (5X,31H FINAL L2 NORM OF THE RESIDUALS,E15.7 // -1 -0 Page -0 * 5X,31H NUMBER OF FUNCTION EVALUATIONS,I10 // - * 5X,31H NUMBER OF JACOBIAN EVALUATIONS,I10 // - * 5X,15H EXIT PARAMETER,16X,I10 // - * 5X,27H FINAL APPROXIMATE SOLUTION // 5X,3E15.7) - C - C LAST CARD OF DRIVER FOR LMDER EXAMPLE. - C - END - SUBROUTINE FCN(M,N,X,FVEC,FJAC,LDFJAC,IFLAG) - INTEGER M,N,LDFJAC,IFLAG - REAL X(N),FVEC(M),FJAC(LDFJAC,N) - C - C SUBROUTINE FCN FOR LMDER EXAMPLE. - C - INTEGER I - REAL TMP1,TMP2,TMP3,TMP4 - REAL Y(15) - DATA Y(1),Y(2),Y(3),Y(4),Y(5),Y(6),Y(7),Y(8), - * Y(9),Y(10),Y(11),Y(12),Y(13),Y(14),Y(15) - * /1.4E-1,1.8E-1,2.2E-1,2.5E-1,2.9E-1,3.2E-1,3.5E-1,3.9E-1, - * 3.7E-1,5.8E-1,7.3E-1,9.6E-1,1.34E0,2.1E0,4.39E0/ - C - IF (IFLAG .NE. 0) GO TO 5 - C - C INSERT PRINT STATEMENTS HERE WHEN NPRINT IS POSITIVE. - C - RETURN - 5 CONTINUE - IF (IFLAG .EQ. 2) GO TO 20 - DO 10 I = 1, 15 - TMP1 = I - TMP2 = 16 - I - TMP3 = TMP1 - IF (I .GT. 8) TMP3 = TMP2 - FVEC(I) = Y(I) - (X(1) + TMP1/(X(2)*TMP2 + X(3)*TMP3)) - 10 CONTINUE - GO TO 40 - 20 CONTINUE - DO 30 I = 1, 15 - TMP1 = I - TMP2 = 16 - I - TMP3 = TMP1 - IF (I .GT. 8) TMP3 = TMP2 - TMP4 = (X(2)*TMP2 + X(3)*TMP3)**2 - FJAC(I,1) = -1.E0 - FJAC(I,2) = TMP1*TMP2/TMP4 - FJAC(I,3) = TMP1*TMP3/TMP4 - 30 CONTINUE - 40 CONTINUE - RETURN - C - C LAST CARD OF SUBROUTINE FCN. - C - END -1 -0 Page -0 Results obtained with different compilers or machines - may be slightly different. -0 FINAL L2 NORM OF THE RESIDUALS 0.9063596E-01 -0 NUMBER OF FUNCTION EVALUATIONS 6 -0 NUMBER OF JACOBIAN EVALUATIONS 5 -0 EXIT PARAMETER 1 -0 FINAL APPROXIMATE SOLUTION -0 0.8241058E-01 0.1133037E+01 0.2343695E+01 -1 -0 -1 -0 Page -0 Documentation for MINPACK subroutine LMSTR1 -0 Single precision version -0 Argonne National Laboratory -0 Burton S. Garbow, Kenneth E. Hillstrom, Jorge J. More -0 March 1980 -0 - 1. Purpose. -0 The purpose of LMSTR1 is to minimize the sum of the squares of - nonlinear functions in N variables by a modification of the - Levenberg-Marquardt algorithm which uses minimal storage. This - is done by using the more general least-squares solver LMSTR. - The user must provide a subroutine which calculates the func- - tions and the rows of the Jacobian. -0 - 2. Subroutine and type statements. -0 SUBROUTINE LMSTR1(FCN,M,N,X,FVEC,FJAC,LDFJAC,TOL, - * INFO,IPVT,WA,LWA) - INTEGER M,N,LDFJAC,INFO,LWA - INTEGER IPVT(N) - REAL TOL - REAL X(N),FVEC(M),FJAC(LDFJAC,N),WA(LWA) - EXTERNAL FCN -0 - 3. Parameters. -0 Parameters designated as input parameters must be specified on - entry to LMSTR1 and are not changed on exit, while parameters - designated as output parameters need not be specified on entry - and are set to appropriate values on exit from LMSTR1. -0 FCN is the name of the user-supplied subroutine which calculate - the functions and the rows of the Jacobian. FCN must be - declared in an EXTERNAL statement in the user calling program - and should be written as follows. -0 SUBROUTINE FCN(M,N,X,FVEC,FJROW,IFLAG) - INTEGER M,N,IFLAG - REAL X(N),FVEC(M),FJROW(N) - ---------- - IF IFLAG = 1 CALCULATE THE FUNCTIONS AT X AND - RETURN THIS VECTOR IN FVEC. - IF IFLAG = I CALCULATE THE (I-1)-ST ROW OF THE - JACOBIAN AT X AND RETURN THIS VECTOR IN FJROW. - ---------- - RETURN -1 -0 Page -0 END -0 The value of IFLAG should not be changed by FCN unless the - user wants to terminate execution of LMSTR1. In this case se - IFLAG to a negative integer. -0 M is a positive integer input variable set to the number of - functions. -0 N is a positive integer input variable set to the number of - variables. N must not exceed M. -0 X is an array of length N. On input X must contain an initial - estimate of the solution vector. On output X contains the - final estimate of the solution vector. -0 FVEC is an output array of length M which contains the function - evaluated at the output X. -0 FJAC is an output N by N array. The upper triangle of FJAC con - tains an upper triangular matrix R such that -0 T T T - P *(JAC *JAC)*P = R *R, -0 where P is a permutation matrix and JAC is the final calcu- - lated Jacobian. Column j of P is column IPVT(j) (see below) - of the identity matrix. The lower triangular part of FJAC - contains information generated during the computation of R. -0 LDFJAC is a positive integer input variable not less than N - which specifies the leading dimension of the array FJAC. -0 TOL is a nonnegative input variable. Termination occurs when - the algorithm estimates either that the relative error in the - sum of squares is at most TOL or that the relative error - between X and the solution is at most TOL. Section 4 contain - more details about TOL. -0 INFO is an integer output variable. If the user has terminated - execution, INFO is set to the (negative) value of IFLAG. See - description of FCN. Otherwise, INFO is set as follows. -0 INFO = 0 Improper input parameters. -0 INFO = 1 Algorithm estimates that the relative error in the - sum of squares is at most TOL. -0 INFO = 2 Algorithm estimates that the relative error between - X and the solution is at most TOL. -0 INFO = 3 Conditions for INFO = 1 and INFO = 2 both hold. -0 INFO = 4 FVEC is orthogonal to the columns of the Jacobian t -1 -0 Page -0 machine precision. -0 INFO = 5 Number of calls to FCN with IFLAG = 1 has reached - 100*(N+1). -0 INFO = 6 TOL is too small. No further reduction in the sum - of squares is possible. -0 INFO = 7 TOL is too small. No further improvement in the - approximate solution X is possible. -0 Sections 4 and 5 contain more details about INFO. -0 IPVT is an integer output array of length N. IPVT defines a - permutation matrix P such that JAC*P = Q*R, where JAC is the - final calculated Jacobian, Q is orthogonal (not stored), and - is upper triangular. Column j of P is column IPVT(j) of the - identity matrix. -0 WA is a work array of length LWA. -0 LWA is a positive integer input variable not less than 5*N+M. -0 - 4. Successful completion. -0 The accuracy of LMSTR1 is controlled by the convergence parame- - ter TOL. This parameter is used in tests which make three type - of comparisons between the approximation X and a solution XSOL. - LMSTR1 terminates when any of the tests is satisfied. If TOL i - less than the machine precision (as defined by the MINPACK func - tion SPMPAR(1)), then LMSTR1 only attempts to satisfy the test - defined by the machine precision. Further progress is not usu- - ally possible. Unless high precision solutions are required, - the recommended value for TOL is the square root of the machine - precision. -0 The tests assume that the functions and the Jacobian are coded - consistently, and that the functions are reasonably well - behaved. If these conditions are not satisfied, then LMSTR1 ma - incorrectly indicate convergence. The coding of the Jacobian - can be checked by the MINPACK subroutine CHKDER. If the Jaco- - bian is coded correctly, then the validity of the answer can be - checked, for example, by rerunning LMSTR1 with a tighter toler- - ance. -0 First convergence test. If ENORM(Z) denotes the Euclidean norm - of a vector Z, then this test attempts to guarantee that -0 ENORM(FVEC) .LE. (1+TOL)*ENORM(FVECS), -0 where FVECS denotes the functions evaluated at XSOL. If this - condition is satisfied with TOL = 10**(-K), then the final - residual norm ENORM(FVEC) has K significant decimal digits an -1 -0 Page -0 INFO is set to 1 (or to 3 if the second test is also satis- - fied). -0 Second convergence test. If D is a diagonal matrix (implicitly - generated by LMSTR1) whose entries contain scale factors for - the variables, then this test attempts to guarantee that -0 ENORM(D*(X-XSOL)) .LE. TOL*ENORM(D*XSOL). -0 If this condition is satisfied with TOL = 10**(-K), then the - larger components of D*X have K significant decimal digits an - INFO is set to 2 (or to 3 if the first test is also satis- - fied). There is a danger that the smaller components of D*X - may have large relative errors, but the choice of D is such - that the accuracy of the components of X is usually related t - their sensitivity. -0 Third convergence test. This test is satisfied when FVEC is - orthogonal to the columns of the Jacobian to machine preci- - sion. There is no clear relationship between this test and - the accuracy of LMSTR1, and furthermore, the test is equally - well satisfied at other critical points, namely maximizers an - saddle points. Therefore, termination caused by this test - (INFO = 4) should be examined carefully. -0 - 5. Unsuccessful completion. -0 Unsuccessful termination of LMSTR1 can be due to improper input - parameters, arithmetic interrupts, or an excessive number of - function evaluations. -0 Improper input parameters. INFO is set to 0 if N .LE. 0, or - M .LT. N, or LDFJAC .LT. N, or TOL .LT. 0.E0, or - LWA .LT. 5*N+M. -0 Arithmetic interrupts. If these interrupts occur in the FCN - subroutine during an early stage of the computation, they may - be caused by an unacceptable choice of X by LMSTR1. In this - case, it may be possible to remedy the situation by not evalu - ating the functions here, but instead setting the components - of FVEC to numbers that exceed those in the initial FVEC, - thereby indirectly reducing the step length. The step length - can be more directly controlled by using instead LMSTR, which - includes in its calling sequence the step-length- governing - parameter FACTOR. -0 Excessive number of function evaluations. If the number of - calls to FCN with IFLAG = 1 reaches 100*(N+1), then this indi - cates that the routine is converging very slowly as measured - by the progress of FVEC, and INFO is set to 5. In this case, - it may be helpful to restart LMSTR1, thereby forcing it to - disregard old (and possibly harmful) information. -1 -0 Page -0 - 6. Characteristics of the algorithm. -0 LMSTR1 is a modification of the Levenberg-Marquardt algorithm. - Two of its main characteristics involve the proper use of - implicitly scaled variables and an optimal choice for the cor- - rection. The use of implicitly scaled variables achieves scale - invariance of LMSTR1 and limits the size of the correction in - any direction where the functions are changing rapidly. The - optimal choice of the correction guarantees (under reasonable - conditions) global convergence from starting points far from th - solution and a fast rate of convergence for problems with small - residuals. -0 Timing. The time required by LMSTR1 to solve a given problem - depends on M and N, the behavior of the functions, the accu- - racy requested, and the starting point. The number of arith- - metic operations needed by LMSTR1 is about N**3 to process - each evaluation of the functions (call to FCN with IFLAG = 1) - and 1.5*(N**2) to process each row of the Jacobian (call to - FCN with IFLAG .GE. 2). Unless FCN can be evaluated quickly, - the timing of LMSTR1 will be strongly influenced by the time - spent in FCN. -0 Storage. LMSTR1 requires N**2 + 2*M + 6*N single precision sto - rage locations and N integer storage locations, in addition t - the storage required by the program. There are no internally - declared storage arrays. -0 - 7. Subprograms required. -0 USER-supplied ...... FCN -0 MINPACK-supplied ... SPMPAR,ENORM,LMSTR,LMPAR,QRFAC,QRSOLV, - RWUPDT -0 FORTRAN-supplied ... ABS,AMAX1,AMIN1,SQRT,MOD -0 - 8. References. -0 Jorge J. More, The Levenberg-Marquardt Algorithm, Implementatio - and Theory. Numerical Analysis, G. A. Watson, editor. - Lecture Notes in Mathematics 630, Springer-Verlag, 1977. -0 - 9. Example. -0 The problem is to determine the values of x(1), x(2), and x(3) - which provide the best fit (in the least squares sense) of -0 x(1) + u(i)/(v(i)*x(2) + w(i)*x(3)), i = 1, 15 -1 -0 Page -0 to the data -0 y = (0.14,0.18,0.22,0.25,0.29,0.32,0.35,0.39, - 0.37,0.58,0.73,0.96,1.34,2.10,4.39), -0 where u(i) = i, v(i) = 16 - i, and w(i) = min(u(i),v(i)). The - i-th component of FVEC is thus defined by -0 y(i) - (x(1) + u(i)/(v(i)*x(2) + w(i)*x(3))). -0 C ********** - C - C DRIVER FOR LMSTR1 EXAMPLE. - C SINGLE PRECISION VERSION - C - C ********** - INTEGER J,M,N,LDFJAC,INFO,LWA,NWRITE - INTEGER IPVT(3) - REAL TOL,FNORM - REAL X(3),FVEC(15),FJAC(3,3),WA(30) - REAL ENORM,SPMPAR - EXTERNAL FCN - C - C LOGICAL OUTPUT UNIT IS ASSUMED TO BE NUMBER 6. - C - DATA NWRITE /6/ - C - M = 15 - N = 3 - C - C THE FOLLOWING STARTING VALUES PROVIDE A ROUGH FIT. - C - X(1) = 1.E0 - X(2) = 1.E0 - X(3) = 1.E0 - C - LDFJAC = 3 - LWA = 30 - C - C SET TOL TO THE SQUARE ROOT OF THE MACHINE PRECISION. - C UNLESS HIGH PRECISION SOLUTIONS ARE REQUIRED, - C THIS IS THE RECOMMENDED SETTING. - C - TOL = SQRT(SPMPAR(1)) - C - CALL LMSTR1(FCN,M,N,X,FVEC,FJAC,LDFJAC,TOL, - * INFO,IPVT,WA,LWA) - FNORM = ENORM(M,FVEC) - WRITE (NWRITE,1000) FNORM,INFO,(X(J),J=1,N) - STOP - 1000 FORMAT (5X,31H FINAL L2 NORM OF THE RESIDUALS,E15.7 // - * 5X,15H EXIT PARAMETER,16X,I10 // - * 5X,27H FINAL APPROXIMATE SOLUTION // 5X,3E15.7) - C -1 -0 Page -0 C LAST CARD OF DRIVER FOR LMSTR1 EXAMPLE. - C - END - SUBROUTINE FCN(M,N,X,FVEC,FJROW,IFLAG) - INTEGER M,N,IFLAG - REAL X(N),FVEC(M),FJROW(N) - C - C SUBROUTINE FCN FOR LMSTR1 EXAMPLE. - C - INTEGER I - REAL TMP1,TMP2,TMP3,TMP4 - REAL Y(15) - DATA Y(1),Y(2),Y(3),Y(4),Y(5),Y(6),Y(7),Y(8), - * Y(9),Y(10),Y(11),Y(12),Y(13),Y(14),Y(15) - * /1.4E-1,1.8E-1,2.2E-1,2.5E-1,2.9E-1,3.2E-1,3.5E-1,3.9E-1, - * 3.7E-1,5.8E-1,7.3E-1,9.6E-1,1.34E0,2.1E0,4.39E0/ - C - IF (IFLAG .GE. 2) GO TO 20 - DO 10 I = 1, 15 - TMP1 = I - TMP2 = 16 - I - TMP3 = TMP1 - IF (I .GT. 8) TMP3 = TMP2 - FVEC(I) = Y(I) - (X(1) + TMP1/(X(2)*TMP2 + X(3)*TMP3)) - 10 CONTINUE - GO TO 40 - 20 CONTINUE - I = IFLAG - 1 - TMP1 = I - TMP2 = 16 - I - TMP3 = TMP1 - IF (I .GT. 8) TMP3 = TMP2 - TMP4 = (X(2)*TMP2 + X(3)*TMP3)**2 - FJROW(1) = -1.E0 - FJROW(2) = TMP1*TMP2/TMP4 - FJROW(3) = TMP1*TMP3/TMP4 - 30 CONTINUE - 40 CONTINUE - RETURN - C - C LAST CARD OF SUBROUTINE FCN. - C - END -0 Results obtained with different compilers or machines - may be slightly different. -0 FINAL L2 NORM OF THE RESIDUALS 0.9063596E-01 -0 EXIT PARAMETER 1 -0 FINAL APPROXIMATE SOLUTION -0 0.8241058E-01 0.1133037E+01 0.2343695E+01 -1 -0 -1 -0 Page -0 Documentation for MINPACK subroutine LMSTR -0 Single precision version -0 Argonne National Laboratory -0 Burton S. Garbow, Kenneth E. Hillstrom, Jorge J. More -0 March 1980 -0 - 1. Purpose. -0 The purpose of LMSTR is to minimize the sum of the squares of M - nonlinear functions in N variables by a modification of the - Levenberg-Marquardt algorithm which uses minimal storage. The - user must provide a subroutine which calculates the functions - and the rows of the Jacobian. -0 - 2. Subroutine and type statements. -0 SUBROUTINE LMSTR(FCN,M,N,X,FVEC,FJAC,LDFJAC,FTOL,XTOL,GTOL, - * MAXFEV,DIAG,MODE,FACTOR,NPRINT,INFO,NFEV,NJEV, - * IPVT,QTF,WA1,WA2,WA3,WA4) - INTEGER M,N,LDFJAC,MAXFEV,MODE,NPRINT,INFO,NFEV,NJEV - INTEGER IPVT(N) - REAL FTOL,XTOL,GTOL,FACTOR - REAL X(N),FVEC(M),FJAC(LDFJAC,N),DIAG(N),QTF(N), - * WA1(N),WA2(N),WA3(N),WA4(M) -0 - 3. Parameters. -0 Parameters designated as input parameters must be specified on - entry to LMSTR and are not changed on exit, while parameters - designated as output parameters need not be specified on entry - and are set to appropriate values on exit from LMSTR. -0 FCN is the name of the user-supplied subroutine which calculate - the functions and the rows of the Jacobian. FCN must be - declared in an EXTERNAL statement in the user calling program - and should be written as follows. -0 SUBROUTINE FCN(M,N,X,FVEC,FJROW,IFLAG) - INTEGER M,N,IFLAG - REAL X(N),FVEC(M),FJROW(N) - ---------- - IF IFLAG = 1 CALCULATE THE FUNCTIONS AT X AND - RETURN THIS VECTOR IN FVEC. - IF IFLAG = I CALCULATE THE (I-1)-ST ROW OF THE - JACOBIAN AT X AND RETURN THIS VECTOR IN FJROW. - ---------- - RETURN -1 -0 Page -0 END -0 The value of IFLAG should not be changed by FCN unless the - user wants to terminate execution of LMSTR. In this case set - IFLAG to a negative integer. -0 M is a positive integer input variable set to the number of - functions. -0 N is a positive integer input variable set to the number of - variables. N must not exceed M. -0 X is an array of length N. On input X must contain an initial - estimate of the solution vector. On output X contains the - final estimate of the solution vector. -0 FVEC is an output array of length M which contains the function - evaluated at the output X. -0 FJAC is an output N by N array. The upper triangle of FJAC con - tains an upper triangular matrix R such that -0 T T T - P *(JAC *JAC)*P = R *R, -0 where P is a permutation matrix and JAC is the final calcu- - lated Jacobian. Column j of P is column IPVT(j) (see below) - of the identity matrix. The lower triangular part of FJAC - contains information generated during the computation of R. -0 LDFJAC is a positive integer input variable not less than N - which specifies the leading dimension of the array FJAC. -0 FTOL is a nonnegative input variable. Termination occurs when - both the actual and predicted relative reductions in the sum - of squares are at most FTOL. Therefore, FTOL measures the - relative error desired in the sum of squares. Section 4 con- - tains more details about FTOL. -0 XTOL is a nonnegative input variable. Termination occurs when - the relative error between two consecutive iterates is at mos - XTOL. Therefore, XTOL measures the relative error desired in - the approximate solution. Section 4 contains more details - about XTOL. -0 GTOL is a nonnegative input variable. Termination occurs when - the cosine of the angle between FVEC and any column of the - Jacobian is at most GTOL in absolute value. Therefore, GTOL - measures the orthogonality desired between the function vecto - and the columns of the Jacobian. Section 4 contains more - details about GTOL. -0 MAXFEV is a positive integer input variable. Termination occur - when the number of calls to FCN with IFLAG = 1 has reached -1 -0 Page -0 MAXFEV. -0 DIAG is an array of length N. If MODE = 1 (see below), DIAG is - internally set. If MODE = 2, DIAG must contain positive - entries that serve as multiplicative scale factors for the - variables. -0 MODE is an integer input variable. If MODE = 1, the variables - will be scaled internally. If MODE = 2, the scaling is speci - fied by the input DIAG. Other values of MODE are equivalent - to MODE = 1. -0 FACTOR is a positive input variable used in determining the ini - tial step bound. This bound is set to the product of FACTOR - and the Euclidean norm of DIAG*X if nonzero, or else to FACTO - itself. In most cases FACTOR should lie in the interval - (.1,100.). 100. is a generally recommended value. -0 NPRINT is an integer input variable that enables controlled - printing of iterates if it is positive. In this case, FCN is - called with IFLAG = 0 at the beginning of the first iteration - and every NPRINT iterations thereafter and immediately prior - to return, with X and FVEC available for printing. If NPRINT - is not positive, no special calls of FCN with IFLAG = 0 are - made. -0 INFO is an integer output variable. If the user has terminated - execution, INFO is set to the (negative) value of IFLAG. See - description of FCN. Otherwise, INFO is set as follows. -0 INFO = 0 Improper input parameters. -0 INFO = 1 Both actual and predicted relative reductions in th - sum of squares are at most FTOL. -0 INFO = 2 Relative error between two consecutive iterates is - at most XTOL. -0 INFO = 3 Conditions for INFO = 1 and INFO = 2 both hold. -0 INFO = 4 The cosine of the angle between FVEC and any column - of the Jacobian is at most GTOL in absolute value. -0 INFO = 5 Number of calls to FCN with IFLAG = 1 has reached - MAXFEV. -0 INFO = 6 FTOL is too small. No further reduction in the sum - of squares is possible. -0 INFO = 7 XTOL is too small. No further improvement in the - approximate solution X is possible. -0 INFO = 8 GTOL is too small. FVEC is orthogonal to the - columns of the Jacobian to machine precision. -1 -0 Page -0 Sections 4 and 5 contain more details about INFO. -0 NFEV is an integer output variable set to the number of calls t - FCN with IFLAG = 1. -0 NJEV is an integer output variable set to the number of calls t - FCN with IFLAG = 2. -0 IPVT is an integer output array of length N. IPVT defines a - permutation matrix P such that JAC*P = Q*R, where JAC is the - final calculated Jacobian, Q is orthogonal (not stored), and - is upper triangular. Column j of P is column IPVT(j) of the - identity matrix. -0 QTF is an output array of length N which contains the first N - elements of the vector (Q transpose)*FVEC. -0 WA1, WA2, and WA3 are work arrays of length N. -0 WA4 is a work array of length M. -0 - 4. Successful completion. -0 The accuracy of LMSTR is controlled by the convergence parame- - ters FTOL, XTOL, and GTOL. These parameters are used in tests - which make three types of comparisons between the approximation - X and a solution XSOL. LMSTR terminates when any of the tests - is satisfied. If any of the convergence parameters is less tha - the machine precision (as defined by the MINPACK function - SPMPAR(1)), then LMSTR only attempts to satisfy the test define - by the machine precision. Further progress is not usually pos- - sible. -0 The tests assume that the functions and the Jacobian are coded - consistently, and that the functions are reasonably well - behaved. If these conditions are not satisfied, then LMSTR may - incorrectly indicate convergence. The coding of the Jacobian - can be checked by the MINPACK subroutine CHKDER. If the Jaco- - bian is coded correctly, then the validity of the answer can be - checked, for example, by rerunning LMSTR with tighter toler- - ances. -0 First convergence test. If ENORM(Z) denotes the Euclidean norm - of a vector Z, then this test attempts to guarantee that -0 ENORM(FVEC) .LE. (1+FTOL)*ENORM(FVECS), -0 where FVECS denotes the functions evaluated at XSOL. If this - condition is satisfied with FTOL = 10**(-K), then the final - residual norm ENORM(FVEC) has K significant decimal digits an - INFO is set to 1 (or to 3 if the second test is also satis- - fied). Unless high precision solutions are required, the - recommended value for FTOL is the square root of the machine -1 -0 Page -0 precision. -0 Second convergence test. If D is the diagonal matrix whose - entries are defined by the array DIAG, then this test attempt - to guarantee that -0 ENORM(D*(X-XSOL)) .LE. XTOL*ENORM(D*XSOL). -0 If this condition is satisfied with XTOL = 10**(-K), then the - larger components of D*X have K significant decimal digits an - INFO is set to 2 (or to 3 if the first test is also satis- - fied). There is a danger that the smaller components of D*X - may have large relative errors, but if MODE = 1, then the - accuracy of the components of X is usually related to their - sensitivity. Unless high precision solutions are required, - the recommended value for XTOL is the square root of the - machine precision. -0 Third convergence test. This test is satisfied when the cosine - of the angle between FVEC and any column of the Jacobian at X - is at most GTOL in absolute value. There is no clear rela- - tionship between this test and the accuracy of LMSTR, and - furthermore, the test is equally well satisfied at other crit - ical points, namely maximizers and saddle points. Therefore, - termination caused by this test (INFO = 4) should be examined - carefully. The recommended value for GTOL is zero. -0 - 5. Unsuccessful completion. -0 Unsuccessful termination of LMSTR can be due to improper input - parameters, arithmetic interrupts, or an excessive number of - function evaluations. -0 Improper input parameters. INFO is set to 0 if N .LE. 0, or - M .LT. N, or LDFJAC .LT. N, or FTOL .LT. 0.E0, or - XTOL .LT. 0.E0, or GTOL .LT. 0.E0, or MAXFEV .LE. 0, or - FACTOR .LE. 0.E0. -0 Arithmetic interrupts. If these interrupts occur in the FCN - subroutine during an early stage of the computation, they may - be caused by an unacceptable choice of X by LMSTR. In this - case, it may be possible to remedy the situation by rerunning - LMSTR with a smaller value of FACTOR. -0 Excessive number of function evaluations. A reasonable value - for MAXFEV is 100*(N+1). If the number of calls to FCN with - IFLAG = 1 reaches MAXFEV, then this indicates that the routin - is converging very slowly as measured by the progress of FVEC - and INFO is set to 5. In this case, it may be helpful to - restart LMSTR with MODE set to 1. -0 - 6. Characteristics of the algorithm. -1 -0 Page -0 LMSTR is a modification of the Levenberg-Marquardt algorithm. - Two of its main characteristics involve the proper use of - implicitly scaled variables (if MODE = 1) and an optimal choice - for the correction. The use of implicitly scaled variables - achieves scale invariance of LMSTR and limits the size of the - correction in any direction where the functions are changing - rapidly. The optimal choice of the correction guarantees (unde - reasonable conditions) global convergence from starting points - far from the solution and a fast rate of convergence for prob- - lems with small residuals. -0 Timing. The time required by LMSTR to solve a given problem - depends on M and N, the behavior of the functions, the accu- - racy requested, and the starting point. The number of arith- - metic operations needed by LMSTR is about N**3 to process eac - evaluation of the functions (call to FCN with IFLAG = 1) and - 1.5*(N**2) to process each row of the Jacobian (call to FCN - with IFLAG .GE. 2). Unless FCN can be evaluated quickly, the - timing of LMSTR will be strongly influenced by the time spent - in FCN. -0 Storage. LMSTR requires N**2 + 2*M + 6*N single precision sto- - rage locations and N integer storage locations, in addition t - the storage required by the program. There are no internally - declared storage arrays. -0 - 7. Subprograms required. -0 USER-supplied ...... FCN -0 MINPACK-supplied ... SPMPAR,ENORM,LMPAR,QRFAC,QRSOLV,RWUPDT -0 FORTRAN-supplied ... ABS,AMAX1,AMIN1,SQRT,MOD -0 - 8. References. -0 Jorge J. More, The Levenberg-Marquardt Algorithm, Implementatio - and Theory. Numerical Analysis, G. A. Watson, editor. - Lecture Notes in Mathematics 630, Springer-Verlag, 1977. -0 - 9. Example. -0 The problem is to determine the values of x(1), x(2), and x(3) - which provide the best fit (in the least squares sense) of -0 x(1) + u(i)/(v(i)*x(2) + w(i)*x(3)), i = 1, 15 -0 to the data -0 y = (0.14,0.18,0.22,0.25,0.29,0.32,0.35,0.39, - 0.37,0.58,0.73,0.96,1.34,2.10,4.39), -1 -0 Page -0 where u(i) = i, v(i) = 16 - i, and w(i) = min(u(i),v(i)). The - i-th component of FVEC is thus defined by -0 y(i) - (x(1) + u(i)/(v(i)*x(2) + w(i)*x(3))). -0 C ********** - C - C DRIVER FOR LMSTR EXAMPLE. - C SINGLE PRECISION VERSION - C - C ********** - INTEGER J,M,N,LDFJAC,MAXFEV,MODE,NPRINT,INFO,NFEV,NJEV,NWRITE - INTEGER IPVT(3) - REAL FTOL,XTOL,GTOL,FACTOR,FNORM - REAL X(3),FVEC(15),FJAC(3,3),DIAG(3),QTF(3), - * WA1(3),WA2(3),WA3(3),WA4(15) - REAL ENORM,SPMPAR - EXTERNAL FCN - C - C LOGICAL OUTPUT UNIT IS ASSUMED TO BE NUMBER 6. - C - DATA NWRITE /6/ - C - M = 15 - N = 3 - C - C THE FOLLOWING STARTING VALUES PROVIDE A ROUGH FIT. - C - X(1) = 1.E0 - X(2) = 1.E0 - X(3) = 1.E0 - C - LDFJAC = 3 - C - C SET FTOL AND XTOL TO THE SQUARE ROOT OF THE MACHINE PRECISION - C AND GTOL TO ZERO. UNLESS HIGH PRECISION SOLUTIONS ARE - C REQUIRED, THESE ARE THE RECOMMENDED SETTINGS. - C - FTOL = SQRT(SPMPAR(1)) - XTOL = SQRT(SPMPAR(1)) - GTOL = 0.E0 - C - MAXFEV = 400 - MODE = 1 - FACTOR = 1.E2 - NPRINT = 0 - C - CALL LMSTR(FCN,M,N,X,FVEC,FJAC,LDFJAC,FTOL,XTOL,GTOL, - * MAXFEV,DIAG,MODE,FACTOR,NPRINT,INFO,NFEV,NJEV, - * IPVT,QTF,WA1,WA2,WA3,WA4) - FNORM = ENORM(M,FVEC) - WRITE (NWRITE,1000) FNORM,NFEV,NJEV,INFO,(X(J),J=1,N) - STOP - 1000 FORMAT (5X,31H FINAL L2 NORM OF THE RESIDUALS,E15.7 // -1 -0 Page -0 * 5X,31H NUMBER OF FUNCTION EVALUATIONS,I10 // - * 5X,31H NUMBER OF JACOBIAN EVALUATIONS,I10 // - * 5X,15H EXIT PARAMETER,16X,I10 // - * 5X,27H FINAL APPROXIMATE SOLUTION // 5X,3E15.7) - C - C LAST CARD OF DRIVER FOR LMSTR EXAMPLE. - C - END - SUBROUTINE FCN(M,N,X,FVEC,FJROW,IFLAG) - INTEGER M,N,IFLAG - REAL X(N),FVEC(M),FJROW(N) - C - C SUBROUTINE FCN FOR LMSTR EXAMPLE. - C - INTEGER I - REAL TMP1,TMP2,TMP3,TMP4 - REAL Y(15) - DATA Y(1),Y(2),Y(3),Y(4),Y(5),Y(6),Y(7),Y(8), - * Y(9),Y(10),Y(11),Y(12),Y(13),Y(14),Y(15) - * /1.4E-1,1.8E-1,2.2E-1,2.5E-1,2.9E-1,3.2E-1,3.5E-1,3.9E-1, - * 3.7E-1,5.8E-1,7.3E-1,9.6E-1,1.34E0,2.1E0,4.39E0/ - C - IF (IFLAG .NE. 0) GO TO 5 - C - C INSERT PRINT STATEMENTS HERE WHEN NPRINT IS POSITIVE. - C - RETURN - 5 CONTINUE - IF (IFLAG .GE. 2) GO TO 20 - DO 10 I = 1, 15 - TMP1 = I - TMP2 = 16 - I - TMP3 = TMP1 - IF (I .GT. 8) TMP3 = TMP2 - FVEC(I) = Y(I) - (X(1) + TMP1/(X(2)*TMP2 + X(3)*TMP3)) - 10 CONTINUE - GO TO 40 - 20 CONTINUE - I = IFLAG - 1 - TMP1 = I - TMP2 = 16 - I - TMP3 = TMP1 - IF (I .GT. 8) TMP3 = TMP2 - TMP4 = (X(2)*TMP2 + X(3)*TMP3)**2 - FJROW(1) = -1.E0 - FJROW(2) = TMP1*TMP2/TMP4 - FJROW(3) = TMP1*TMP3/TMP4 - 30 CONTINUE - 40 CONTINUE - RETURN - C - C LAST CARD OF SUBROUTINE FCN. - C - END -1 -0 Page -0 Results obtained with different compilers or machines - may be slightly different. -0 FINAL L2 NORM OF THE RESIDUALS 0.9063596E-01 -0 NUMBER OF FUNCTION EVALUATIONS 6 -0 NUMBER OF JACOBIAN EVALUATIONS 5 -0 EXIT PARAMETER 1 -0 FINAL APPROXIMATE SOLUTION -0 0.8241058E-01 0.1133037E+01 0.2343695E+01 -1 -0 -1 -0 Page -0 Documentation for MINPACK subroutine LMDIF1 -0 Single precision version -0 Argonne National Laboratory -0 Burton S. Garbow, Kenneth E. Hillstrom, Jorge J. More -0 March 1980 -0 - 1. Purpose. -0 The purpose of LMDIF1 is to minimize the sum of the squares of - nonlinear functions in N variables by a modification of the - Levenberg-Marquardt algorithm. This is done by using the more - general least-squares solver LMDIF. The user must provide a - subroutine which calculates the functions. The Jacobian is the - calculated by a forward-difference approximation. -0 - 2. Subroutine and type statements. -0 SUBROUTINE LMDIF1(FCN,M,N,X,FVEC,TOL,INFO,IWA,WA,LWA) - INTEGER M,N,INFO,LWA - INTEGER IWA(N) - REAL TOL - REAL X(N),FVEC(M),WA(LWA) - EXTERNAL FCN -0 - 3. Parameters. -0 Parameters designated as input parameters must be specified on - entry to LMDIF1 and are not changed on exit, while parameters - designated as output parameters need not be specified on entry - and are set to appropriate values on exit from LMDIF1. -0 FCN is the name of the user-supplied subroutine which calculate - the functions. FCN must be declared in an EXTERNAL statement - in the user calling program, and should be written as follows -0 SUBROUTINE FCN(M,N,X,FVEC,IFLAG) - INTEGER M,N,IFLAG - REAL X(N),FVEC(M) - ---------- - CALCULATE THE FUNCTIONS AT X AND - RETURN THIS VECTOR IN FVEC. - ---------- - RETURN - END -0 The value of IFLAG should not be changed by FCN unless the - user wants to terminate execution of LMDIF1. In this case se -1 -0 Page -0 IFLAG to a negative integer. -0 M is a positive integer input variable set to the number of - functions. -0 N is a positive integer input variable set to the number of - variables. N must not exceed M. -0 X is an array of length N. On input X must contain an initial - estimate of the solution vector. On output X contains the - final estimate of the solution vector. -0 FVEC is an output array of length M which contains the function - evaluated at the output X. -0 TOL is a nonnegative input variable. Termination occurs when - the algorithm estimates either that the relative error in the - sum of squares is at most TOL or that the relative error - between X and the solution is at most TOL. Section 4 contain - more details about TOL. -0 INFO is an integer output variable. If the user has terminated - execution, INFO is set to the (negative) value of IFLAG. See - description of FCN. Otherwise, INFO is set as follows. -0 INFO = 0 Improper input parameters. -0 INFO = 1 Algorithm estimates that the relative error in the - sum of squares is at most TOL. -0 INFO = 2 Algorithm estimates that the relative error between - X and the solution is at most TOL. -0 INFO = 3 Conditions for INFO = 1 and INFO = 2 both hold. -0 INFO = 4 FVEC is orthogonal to the columns of the Jacobian t - machine precision. -0 INFO = 5 Number of calls to FCN has reached or exceeded - 200*(N+1). -0 INFO = 6 TOL is too small. No further reduction in the sum - of squares is possible. -0 INFO = 7 TOL is too small. No further improvement in the - approximate solution X is possible. -0 Sections 4 and 5 contain more details about INFO. -0 IWA is an integer work array of length N. -0 WA is a work array of length LWA. -0 LWA is a positive integer input variable not less than -1 -0 Page -0 M*N+5*N+M. -0 - 4. Successful completion. -0 The accuracy of LMDIF1 is controlled by the convergence parame- - ter TOL. This parameter is used in tests which make three type - of comparisons between the approximation X and a solution XSOL. - LMDIF1 terminates when any of the tests is satisfied. If TOL i - less than the machine precision (as defined by the MINPACK func - tion SPMPAR(1)), then LMDIF1 only attempts to satisfy the test - defined by the machine precision. Further progress is not usu- - ally possible. Unless high precision solutions are required, - the recommended value for TOL is the square root of the machine - precision. -0 The tests assume that the functions are reasonably well behaved - If this condition is not satisfied, then LMDIF1 may incorrectly - indicate convergence. The validity of the answer can be - checked, for example, by rerunning LMDIF1 with a tighter toler- - ance. -0 First convergence test. If ENORM(Z) denotes the Euclidean norm - of a vector Z, then this test attempts to guarantee that -0 ENORM(FVEC) .LE. (1+TOL)*ENORM(FVECS), -0 where FVECS denotes the functions evaluated at XSOL. If this - condition is satisfied with TOL = 10**(-K), then the final - residual norm ENORM(FVEC) has K significant decimal digits an - INFO is set to 1 (or to 3 if the second test is also satis- - fied). -0 Second convergence test. If D is a diagonal matrix (implicitly - generated by LMDIF1) whose entries contain scale factors for - the variables, then this test attempts to guarantee that -0 ENORM(D*(X-XSOL)) .LE. TOL*ENORM(D*XSOL). -0 If this condition is satisfied with TOL = 10**(-K), then the - larger components of D*X have K significant decimal digits an - INFO is set to 2 (or to 3 if the first test is also satis- - fied). There is a danger that the smaller components of D*X - may have large relative errors, but the choice of D is such - that the accuracy of the components of X is usually related t - their sensitivity. -0 Third convergence test. This test is satisfied when FVEC is - orthogonal to the columns of the Jacobian to machine preci- - sion. There is no clear relationship between this test and - the accuracy of LMDIF1, and furthermore, the test is equally - well satisfied at other critical points, namely maximizers an - saddle points. Also, errors in the functions (see below) may - result in the test being satisfied at a point not close to th -1 -0 Page -0 minimum. Therefore, termination caused by this test - (INFO = 4) should be examined carefully. -0 - 5. Unsuccessful completion. -0 Unsuccessful termination of LMDIF1 can be due to improper input - parameters, arithmetic interrupts, an excessive number of func- - tion evaluations, or errors in the functions. -0 Improper input parameters. INFO is set to 0 if N .LE. 0, or - M .LT. N, or TOL .LT. 0.E0, or LWA .LT. M*N+5*N+M. -0 Arithmetic interrupts. If these interrupts occur in the FCN - subroutine during an early stage of the computation, they may - be caused by an unacceptable choice of X by LMDIF1. In this - case, it may be possible to remedy the situation by not evalu - ating the functions here, but instead setting the components - of FVEC to numbers that exceed those in the initial FVEC, - thereby indirectly reducing the step length. The step length - can be more directly controlled by using instead LMDIF, which - includes in its calling sequence the step-length-governing - parameter FACTOR. -0 Excessive number of function evaluations. If the number of - calls to FCN reaches 200*(N+1), then this indicates that the - routine is converging very slowly as measured by the progress - of FVEC, and INFO is set to 5. In this case, it may be help- - ful to restart LMDIF1, thereby forcing it to disregard old - (and possibly harmful) information. -0 Errors in the functions. The choice of step length in the for- - ward-difference approximation to the Jacobian assumes that th - relative errors in the functions are of the order of the - machine precision. If this is not the case, LMDIF1 may fail - (usually with INFO = 4). The user should then use LMDIF - instead, or one of the programs which require the analytic - Jacobian (LMDER1 and LMDER). -0 - 6. Characteristics of the algorithm. -0 LMDIF1 is a modification of the Levenberg-Marquardt algorithm. - Two of its main characteristics involve the proper use of - implicitly scaled variables and an optimal choice for the cor- - rection. The use of implicitly scaled variables achieves scale - invariance of LMDIF1 and limits the size of the correction in - any direction where the functions are changing rapidly. The - optimal choice of the correction guarantees (under reasonable - conditions) global convergence from starting points far from th - solution and a fast rate of convergence for problems with small - residuals. -0 Timing. The time required by LMDIF1 to solve a given problem -1 -0 Page -0 depends on M and N, the behavior of the functions, the accu- - racy requested, and the starting point. The number of arith- - metic operations needed by LMDIF1 is about N**3 to process - each evaluation of the functions (one call to FCN) and - M*(N**2) to process each approximation to the Jacobian (N - calls to FCN). Unless FCN can be evaluated quickly, the tim- - ing of LMDIF1 will be strongly influenced by the time spent i - FCN. -0 Storage. LMDIF1 requires M*N + 2*M + 6*N single precision sto- - rage locations and N integer storage locations, in addition t - the storage required by the program. There are no internally - declared storage arrays. -0 - 7. Subprograms required. -0 USER-supplied ...... FCN -0 MINPACK-supplied ... SPMPAR,ENORM,FDJAC2,LMDIF,LMPAR, - QRFAC,QRSOLV -0 FORTRAN-supplied ... ABS,AMAX1,AMIN1,SQRT,MOD -0 - 8. References. -0 Jorge J. More, The Levenberg-Marquardt Algorithm, Implementatio - and Theory. Numerical Analysis, G. A. Watson, editor. - Lecture Notes in Mathematics 630, Springer-Verlag, 1977. -0 - 9. Example. -0 The problem is to determine the values of x(1), x(2), and x(3) - which provide the best fit (in the least squares sense) of -0 x(1) + u(i)/(v(i)*x(2) + w(i)*x(3)), i = 1, 15 -0 to the data -0 y = (0.14,0.18,0.22,0.25,0.29,0.32,0.35,0.39, - 0.37,0.58,0.73,0.96,1.34,2.10,4.39), -0 where u(i) = i, v(i) = 16 - i, and w(i) = min(u(i),v(i)). The - i-th component of FVEC is thus defined by -0 y(i) - (x(1) + u(i)/(v(i)*x(2) + w(i)*x(3))). -0 C ********** - C - C DRIVER FOR LMDIF1 EXAMPLE. - C SINGLE PRECISION VERSION - C -1 -0 Page -0 C ********** - INTEGER J,M,N,INFO,LWA,NWRITE - INTEGER IWA(3) - REAL TOL,FNORM - REAL X(3),FVEC(15),WA(75) - REAL ENORM,SPMPAR - EXTERNAL FCN - C - C LOGICAL OUTPUT UNIT IS ASSUMED TO BE NUMBER 6. - C - DATA NWRITE /6/ - C - M = 15 - N = 3 - C - C THE FOLLOWING STARTING VALUES PROVIDE A ROUGH FIT. - C - X(1) = 1.E0 - X(2) = 1.E0 - X(3) = 1.E0 - C - LWA = 75 - C - C SET TOL TO THE SQUARE ROOT OF THE MACHINE PRECISION. - C UNLESS HIGH PRECISION SOLUTIONS ARE REQUIRED, - C THIS IS THE RECOMMENDED SETTING. - C - TOL = SQRT(SPMPAR(1)) - C - CALL LMDIF1(FCN,M,N,X,FVEC,TOL,INFO,IWA,WA,LWA) - FNORM = ENORM(M,FVEC) - WRITE (NWRITE,1000) FNORM,INFO,(X(J),J=1,N) - STOP - 1000 FORMAT (5X,31H FINAL L2 NORM OF THE RESIDUALS,E15.7 // - * 5X,15H EXIT PARAMETER,16X,I10 // - * 5X,27H FINAL APPROXIMATE SOLUTION // 5X,3E15.7) - C - C LAST CARD OF DRIVER FOR LMDIF1 EXAMPLE. - C - END - SUBROUTINE FCN(M,N,X,FVEC,IFLAG) - INTEGER M,N,IFLAG - REAL X(N),FVEC(M) - C - C SUBROUTINE FCN FOR LMDIF1 EXAMPLE. - C - INTEGER I - REAL TMP1,TMP2,TMP3 - REAL Y(15) - DATA Y(1),Y(2),Y(3),Y(4),Y(5),Y(6),Y(7),Y(8), - * Y(9),Y(10),Y(11),Y(12),Y(13),Y(14),Y(15) - * /1.4E-1,1.8E-1,2.2E-1,2.5E-1,2.9E-1,3.2E-1,3.5E-1,3.9E-1, - * 3.7E-1,5.8E-1,7.3E-1,9.6E-1,1.34E0,2.1E0,4.39E0/ - C -1 -0 Page -0 DO 10 I = 1, 15 - TMP1 = I - TMP2 = 16 - I - TMP3 = TMP1 - IF (I .GT. 8) TMP3 = TMP2 - FVEC(I) = Y(I) - (X(1) + TMP1/(X(2)*TMP2 + X(3)*TMP3)) - 10 CONTINUE - RETURN - C - C LAST CARD OF SUBROUTINE FCN. - C - END -0 Results obtained with different compilers or machines - may be slightly different. -0 FINAL L2 NORM OF THE RESIDUALS 0.9063596E-01 -0 EXIT PARAMETER 1 -0 FINAL APPROXIMATE SOLUTION -0 0.8241057E-01 0.1133037E+01 0.2343695E+01 -1 -0 -1 -0 Page -0 Documentation for MINPACK subroutine LMDIF -0 Single precision version -0 Argonne National Laboratory -0 Burton S. Garbow, Kenneth E. Hillstrom, Jorge J. More -0 March 1980 -0 - 1. Purpose. -0 The purpose of LMDIF is to minimize the sum of the squares of M - nonlinear functions in N variables by a modification of the - Levenberg-Marquardt algorithm. The user must provide a subrou- - tine which calculates the functions. The Jacobian is then cal- - culated by a forward-difference approximation. -0 - 2. Subroutine and type statements. -0 SUBROUTINE LMDIF(FCN,M,N,X,FVEC,FTOL,XTOL,GTOL,MAXFEV,EPSFCN, - * DIAG,MODE,FACTOR,NPRINT,INFO,NFEV,FJAC,LDFJAC, - * IPVT,QTF,WA1,WA2,WA3,WA4) - INTEGER M,N,MAXFEV,MODE,NPRINT,INFO,NFEV,LDFJAC - INTEGER IPVT(N) - REAL FTOL,XTOL,GTOL,EPSFCN,FACTOR - REAL X(N),FVEC(M),DIAG(N),FJAC(LDFJAC,N),QTF(N), - * WA1(N),WA2(N),WA3(N),WA4(M) - EXTERNAL FCN -0 - 3. Parameters. -0 Parameters designated as input parameters must be specified on - entry to LMDIF and are not changed on exit, while parameters - designated as output parameters need not be specified on entry - and are set to appropriate values on exit from LMDIF. -0 FCN is the name of the user-supplied subroutine which calculate - the functions. FCN must be declared in an EXTERNAL statement - in the user calling program, and should be written as follows -0 SUBROUTINE FCN(M,N,X,FVEC,IFLAG) - INTEGER M,N,IFLAG - REAL X(N),FVEC(M) - ---------- - CALCULATE THE FUNCTIONS AT X AND - RETURN THIS VECTOR IN FVEC. - ---------- - RETURN - END -1 -0 Page -0 The value of IFLAG should not be changed by FCN unless the - user wants to terminate execution of LMDIF. In this case set - IFLAG to a negative integer. -0 M is a positive integer input variable set to the number of - functions. -0 N is a positive integer input variable set to the number of - variables. N must not exceed M. -0 X is an array of length N. On input X must contain an initial - estimate of the solution vector. On output X contains the - final estimate of the solution vector. -0 FVEC is an output array of length M which contains the function - evaluated at the output X. -0 FTOL is a nonnegative input variable. Termination occurs when - both the actual and predicted relative reductions in the sum - of squares are at most FTOL. Therefore, FTOL measures the - relative error desired in the sum of squares. Section 4 con- - tains more details about FTOL. -0 XTOL is a nonnegative input variable. Termination occurs when - the relative error between two consecutive iterates is at mos - XTOL. Therefore, XTOL measures the relative error desired in - the approximate solution. Section 4 contains more details - about XTOL. -0 GTOL is a nonnegative input variable. Termination occurs when - the cosine of the angle between FVEC and any column of the - Jacobian is at most GTOL in absolute value. Therefore, GTOL - measures the orthogonality desired between the function vecto - and the columns of the Jacobian. Section 4 contains more - details about GTOL. -0 MAXFEV is a positive integer input variable. Termination occur - when the number of calls to FCN is at least MAXFEV by the end - of an iteration. -0 EPSFCN is an input variable used in determining a suitable step - for the forward-difference approximation. This approximation - assumes that the relative errors in the functions are of the - order of EPSFCN. If EPSFCN is less than the machine preci- - sion, it is assumed that the relative errors in the functions - are of the order of the machine precision. -0 DIAG is an array of length N. If MODE = 1 (see below), DIAG is - internally set. If MODE = 2, DIAG must contain positive - entries that serve as multiplicative scale factors for the - variables. -0 MODE is an integer input variable. If MODE = 1, the variables - will be scaled internally. If MODE = 2, the scaling is -1 -0 Page -0 specified by the input DIAG. Other values of MODE are equiva - lent to MODE = 1. -0 FACTOR is a positive input variable used in determining the ini - tial step bound. This bound is set to the product of FACTOR - and the Euclidean norm of DIAG*X if nonzero, or else to FACTO - itself. In most cases FACTOR should lie in the interval - (.1,100.). 100. is a generally recommended value. -0 NPRINT is an integer input variable that enables controlled - printing of iterates if it is positive. In this case, FCN is - called with IFLAG = 0 at the beginning of the first iteration - and every NPRINT iterations thereafter and immediately prior - to return, with X and FVEC available for printing. If NPRINT - is not positive, no special calls of FCN with IFLAG = 0 are - made. -0 INFO is an integer output variable. If the user has terminated - execution, INFO is set to the (negative) value of IFLAG. See - description of FCN. Otherwise, INFO is set as follows. -0 INFO = 0 Improper input parameters. -0 INFO = 1 Both actual and predicted relative reductions in th - sum of squares are at most FTOL. -0 INFO = 2 Relative error between two consecutive iterates is - at most XTOL. -0 INFO = 3 Conditions for INFO = 1 and INFO = 2 both hold. -0 INFO = 4 The cosine of the angle between FVEC and any column - of the Jacobian is at most GTOL in absolute value. -0 INFO = 5 Number of calls to FCN has reached or exceeded - MAXFEV. -0 INFO = 6 FTOL is too small. No further reduction in the sum - of squares is possible. -0 INFO = 7 XTOL is too small. No further improvement in the - approximate solution X is possible. -0 INFO = 8 GTOL is too small. FVEC is orthogonal to the - columns of the Jacobian to machine precision. -0 Sections 4 and 5 contain more details about INFO. -0 NFEV is an integer output variable set to the number of calls t - FCN. -0 FJAC is an output M by N array. The upper N by N submatrix of - FJAC contains an upper triangular matrix R with diagonal ele- - ments of nonincreasing magnitude such that -1 -0 Page -0 T T T - P *(JAC *JAC)*P = R *R, -0 where P is a permutation matrix and JAC is the final calcu- - lated Jacobian. Column j of P is column IPVT(j) (see below) - of the identity matrix. The lower trapezoidal part of FJAC - contains information generated during the computation of R. -0 LDFJAC is a positive integer input variable not less than M - which specifies the leading dimension of the array FJAC. -0 IPVT is an integer output array of length N. IPVT defines a - permutation matrix P such that JAC*P = Q*R, where JAC is the - final calculated Jacobian, Q is orthogonal (not stored), and - is upper triangular with diagonal elements of nonincreasing - magnitude. Column j of P is column IPVT(j) of the identity - matrix. -0 QTF is an output array of length N which contains the first N - elements of the vector (Q transpose)*FVEC. -0 WA1, WA2, and WA3 are work arrays of length N. -0 WA4 is a work array of length M. -0 - 4. Successful completion. -0 The accuracy of LMDIF is controlled by the convergence parame- - ters FTOL, XTOL, and GTOL. These parameters are used in tests - which make three types of comparisons between the approximation - X and a solution XSOL. LMDIF terminates when any of the tests - is satisfied. If any of the convergence parameters is less tha - the machine precision (as defined by the MINPACK function - SPMPAR(1)), then LMDIF only attempts to satisfy the test define - by the machine precision. Further progress is not usually pos- - sible. -0 The tests assume that the functions are reasonably well behaved - If this condition is not satisfied, then LMDIF may incorrectly - indicate convergence. The validity of the answer can be - checked, for example, by rerunning LMDIF with tighter toler- - ances. -0 First convergence test. If ENORM(Z) denotes the Euclidean norm - of a vector Z, then this test attempts to guarantee that -0 ENORM(FVEC) .LE. (1+FTOL)*ENORM(FVECS), -0 where FVECS denotes the functions evaluated at XSOL. If this - condition is satisfied with FTOL = 10**(-K), then the final - residual norm ENORM(FVEC) has K significant decimal digits an - INFO is set to 1 (or to 3 if the second test is also satis- - fied). Unless high precision solutions are required, the -1 -0 Page -0 recommended value for FTOL is the square root of the machine - precision. -0 Second convergence test. If D is the diagonal matrix whose - entries are defined by the array DIAG, then this test attempt - to guarantee that -0 ENORM(D*(X-XSOL)) .LE. XTOL*ENORM(D*XSOL). -0 If this condition is satisfied with XTOL = 10**(-K), then the - larger components of D*X have K significant decimal digits an - INFO is set to 2 (or to 3 if the first test is also satis- - fied). There is a danger that the smaller components of D*X - may have large relative errors, but if MODE = 1, then the - accuracy of the components of X is usually related to their - sensitivity. Unless high precision solutions are required, - the recommended value for XTOL is the square root of the - machine precision. -0 Third convergence test. This test is satisfied when the cosine - of the angle between FVEC and any column of the Jacobian at X - is at most GTOL in absolute value. There is no clear rela- - tionship between this test and the accuracy of LMDIF, and - furthermore, the test is equally well satisfied at other crit - ical points, namely maximizers and saddle points. Therefore, - termination caused by this test (INFO = 4) should be examined - carefully. The recommended value for GTOL is zero. -0 - 5. Unsuccessful completion. -0 Unsuccessful termination of LMDIF can be due to improper input - parameters, arithmetic interrupts, or an excessive number of - function evaluations. -0 Improper input parameters. INFO is set to 0 if N .LE. 0, or - M .LT. N, or LDFJAC .LT. M, or FTOL .LT. 0.E0, or - XTOL .LT. 0.E0, or GTOL .LT. 0.E0, or MAXFEV .LE. 0, or - FACTOR .LE. 0.E0. -0 Arithmetic interrupts. If these interrupts occur in the FCN - subroutine during an early stage of the computation, they may - be caused by an unacceptable choice of X by LMDIF. In this - case, it may be possible to remedy the situation by rerunning - LMDIF with a smaller value of FACTOR. -0 Excessive number of function evaluations. A reasonable value - for MAXFEV is 200*(N+1). If the number of calls to FCN - reaches MAXFEV, then this indicates that the routine is con- - verging very slowly as measured by the progress of FVEC, and - INFO is set to 5. In this case, it may be helpful to restart - LMDIF with MODE set to 1. -0 -1 -0 Page -0 6. Characteristics of the algorithm. -0 LMDIF is a modification of the Levenberg-Marquardt algorithm. - Two of its main characteristics involve the proper use of - implicitly scaled variables (if MODE = 1) and an optimal choice - for the correction. The use of implicitly scaled variables - achieves scale invariance of LMDIF and limits the size of the - correction in any direction where the functions are changing - rapidly. The optimal choice of the correction guarantees (unde - reasonable conditions) global convergence from starting points - far from the solution and a fast rate of convergence for prob- - lems with small residuals. -0 Timing. The time required by LMDIF to solve a given problem - depends on M and N, the behavior of the functions, the accu- - racy requested, and the starting point. The number of arith- - metic operations needed by LMDIF is about N**3 to process eac - evaluation of the functions (one call to FCN) and M*(N**2) to - process each approximation to the Jacobian (N calls to FCN). - Unless FCN can be evaluated quickly, the timing of LMDIF will - be strongly influenced by the time spent in FCN. -0 Storage. LMDIF requires M*N + 2*M + 6*N single precision sto- - rage locations and N integer storage locations, in addition t - the storage required by the program. There are no internally - declared storage arrays. -0 - 7. Subprograms required. -0 USER-supplied ...... FCN -0 MINPACK-supplied ... SPMPAR,ENORM,FDJAC2,LMPAR,QRFAC,QRSOLV -0 FORTRAN-supplied ... ABS,AMAX1,AMIN1,SQRT,MOD -0 - 8. References. -0 Jorge J. More, The Levenberg-Marquardt Algorithm, Implementatio - and Theory. Numerical Analysis, G. A. Watson, editor. - Lecture Notes in Mathematics 630, Springer-Verlag, 1977. -0 - 9. Example. -0 The problem is to determine the values of x(1), x(2), and x(3) - which provide the best fit (in the least squares sense) of -0 x(1) + u(i)/(v(i)*x(2) + w(i)*x(3)), i = 1, 15 -0 to the data -1 -0 Page -0 y = (0.14,0.18,0.22,0.25,0.29,0.32,0.35,0.39, - 0.37,0.58,0.73,0.96,1.34,2.10,4.39), -0 where u(i) = i, v(i) = 16 - i, and w(i) = min(u(i),v(i)). The - i-th component of FVEC is thus defined by -0 y(i) - (x(1) + u(i)/(v(i)*x(2) + w(i)*x(3))). -0 C ********** - C - C DRIVER FOR LMDIF EXAMPLE. - C SINGLE PRECISION VERSION - C - C ********** - INTEGER J,M,N,MAXFEV,MODE,NPRINT,INFO,NFEV,LDFJAC,NWRITE - INTEGER IPVT(3) - REAL FTOL,XTOL,GTOL,EPSFCN,FACTOR,FNORM - REAL X(3),FVEC(15),DIAG(3),FJAC(15,3),QTF(3), - * WA1(3),WA2(3),WA3(3),WA4(15) - REAL ENORM,SPMPAR - EXTERNAL FCN - C - C LOGICAL OUTPUT UNIT IS ASSUMED TO BE NUMBER 6. - C - DATA NWRITE /6/ - C - M = 15 - N = 3 - C - C THE FOLLOWING STARTING VALUES PROVIDE A ROUGH FIT. - C - X(1) = 1.E0 - X(2) = 1.E0 - X(3) = 1.E0 - C - LDFJAC = 15 - C - C SET FTOL AND XTOL TO THE SQUARE ROOT OF THE MACHINE PRECISION - C AND GTOL TO ZERO. UNLESS HIGH PRECISION SOLUTIONS ARE - C REQUIRED, THESE ARE THE RECOMMENDED SETTINGS. - C - FTOL = SQRT(SPMPAR(1)) - XTOL = SQRT(SPMPAR(1)) - GTOL = 0.E0 - C - MAXFEV = 800 - EPSFCN = 0.E0 - MODE = 1 - FACTOR = 1.E2 - NPRINT = 0 - C - CALL LMDIF(FCN,M,N,X,FVEC,FTOL,XTOL,GTOL,MAXFEV,EPSFCN, - * DIAG,MODE,FACTOR,NPRINT,INFO,NFEV,FJAC,LDFJAC, - * IPVT,QTF,WA1,WA2,WA3,WA4) -1 -0 Page -0 FNORM = ENORM(M,FVEC) - WRITE (NWRITE,1000) FNORM,NFEV,INFO,(X(J),J=1,N) - STOP - 1000 FORMAT (5X,31H FINAL L2 NORM OF THE RESIDUALS,E15.7 // - * 5X,31H NUMBER OF FUNCTION EVALUATIONS,I10 // - * 5X,15H EXIT PARAMETER,16X,I10 // - * 5X,27H FINAL APPROXIMATE SOLUTION // 5X,3E15.7) - C - C LAST CARD OF DRIVER FOR LMDIF EXAMPLE. - C - END - SUBROUTINE FCN(M,N,X,FVEC,IFLAG) - INTEGER M,N,IFLAG - REAL X(N),FVEC(M) - C - C SUBROUTINE FCN FOR LMDIF EXAMPLE. - C - INTEGER I - REAL TMP1,TMP2,TMP3 - REAL Y(15) - DATA Y(1),Y(2),Y(3),Y(4),Y(5),Y(6),Y(7),Y(8), - * Y(9),Y(10),Y(11),Y(12),Y(13),Y(14),Y(15) - * /1.4E-1,1.8E-1,2.2E-1,2.5E-1,2.9E-1,3.2E-1,3.5E-1,3.9E-1, - * 3.7E-1,5.8E-1,7.3E-1,9.6E-1,1.34E0,2.1E0,4.39E0/ - C - IF (IFLAG .NE. 0) GO TO 5 - C - C INSERT PRINT STATEMENTS HERE WHEN NPRINT IS POSITIVE. - C - RETURN - 5 CONTINUE - DO 10 I = 1, 15 - TMP1 = I - TMP2 = 16 - I - TMP3 = TMP1 - IF (I .GT. 8) TMP3 = TMP2 - FVEC(I) = Y(I) - (X(1) + TMP1/(X(2)*TMP2 + X(3)*TMP3)) - 10 CONTINUE - RETURN - C - C LAST CARD OF SUBROUTINE FCN. - C - END -0 Results obtained with different compilers or machines - may be slightly different. -0 FINAL L2 NORM OF THE RESIDUALS 0.9063596E-01 -0 NUMBER OF FUNCTION EVALUATIONS 21 -0 EXIT PARAMETER 1 -0 FINAL APPROXIMATE SOLUTION -1 -0 Page -0 0.8241057E-01 0.1133037E+01 0.2343695E+01 -1 -0 -1 -0 Page -0 Documentation for MINPACK subroutine CHKDER -0 Single precision version -0 Argonne National Laboratory -0 Burton S. Garbow, Kenneth E. Hillstrom, Jorge J. More -0 March 1980 -0 - 1. Purpose. -0 The purpose of CHKDER is to check the gradients of M nonlinear - functions in N variables, evaluated at a point X, for consis- - tency with the functions themselves. The user must call CHKDER - twice, first with MODE = 1 and then with MODE = 2. -0 - 2. Subroutine and type statements. -0 SUBROUTINE CHKDER(M,N,X,FVEC,FJAC,LDFJAC,XP,FVECP,MODE,ERR) - INTEGER M,N,LDFJAC,MODE - REAL X(N),FVEC(M),FJAC(LDFJAC,N),XP(N),FVECP(M),ERR(M) -0 - 3. Parameters. -0 Parameters designated as input parameters must be specified on - entry to CHKDER and are not changed on exit, while parameters - designated as output parameters need not be specified on entry - and are set to appropriate values on exit from CHKDER. -0 M is a positive integer input variable set to the number of - functions. -0 N is a positive integer input variable set to the number of - variables. -0 X is an input array of length N. -0 FVEC is an array of length M. On input when MODE = 2, FVEC mus - contain the functions evaluated at X. -0 FJAC is an M by N array. On input when MODE = 2, the rows of - FJAC must contain the gradients of the respective functions - evaluated at X. -0 LDFJAC is a positive integer input variable not less than M - which specifies the leading dimension of the array FJAC. -0 XP is an array of length N. On output when MODE = 1, XP is set - to a neighboring point of X. -1 -0 Page -0 FVECP is an array of length M. On input when MODE = 2, FVECP - must contain the functions evaluated at XP. -0 MODE is an integer input variable set to 1 on the first call an - 2 on the second. Other values of MODE are equivalent to - MODE = 1. -0 ERR is an array of length M. On output when MODE = 2, ERR con- - tains measures of correctness of the respective gradients. I - there is no severe loss of significance, then if ERR(I) is 1. - the I-th gradient is correct, while if ERR(I) is 0.0 the I-th - gradient is incorrect. For values of ERR between 0.0 and 1.0 - the categorization is less certain. In general, a value of - ERR(I) greater than 0.5 indicates that the I-th gradient is - probably correct, while a value of ERR(I) less than 0.5 indi- - cates that the I-th gradient is probably incorrect. -0 - 4. Successful completion. -0 CHKDER usually guarantees that if ERR(I) is 1.0, then the I-th - gradient at X is consistent with the I-th function. This sug- - gests that the input X be such that consistency of the gradient - at X implies consistency of the gradient at all points of inter - est. If all the components of X are distinct and the fractiona - part of each one has two nonzero digits, then X is likely to be - a satisfactory choice. -0 If ERR(I) is not 1.0 but is greater than 0.5, then the I-th gra - dient is probably consistent with the I-th function (the more s - the larger ERR(I) is), but the conditions for ERR(I) to be 1.0 - have not been completely satisfied. In this case, it is recom- - mended that CHKDER be rerun with other input values of X. If - ERR(I) is always greater than 0.5, then the I-th gradient is - consistent with the I-th function. -0 - 5. Unsuccessful completion. -0 CHKDER does not perform reliably if cancellation or rounding - errors cause a severe loss of significance in the evaluation of - a function. Therefore, none of the components of X should be - unusually small (in particular, zero) or any other value which - may cause loss of significance. The relative differences - between corresponding elements of FVECP and FVEC should be at - least two orders of magnitude greater than the machine precisio - (as defined by the MINPACK function SPMPAR(1)). If there is a - severe loss of significance in the evaluation of the I-th func- - tion, then ERR(I) may be 0.0 and yet the I-th gradient could be - correct. -0 If ERR(I) is not 0.0 but is less than 0.5, then the I-th gra- - dient is probably not consistent with the I-th function (the - more so the smaller ERR(I) is), but the conditions for ERR(I) t -1 -0 Page -0 be 0.0 have not been completely satisfied. In this case, it is - recommended that CHKDER be rerun with other input values of X. - If ERR(I) is always less than 0.5 and if there is no severe los - of significance, then the I-th gradient is not consistent with - the I-th function. -0 - 6. Characteristics of the algorithm. -0 CHKDER checks the I-th gradient for consistency with the I-th - function by computing a forward-difference approximation along - suitably chosen direction and comparing this approximation with - the user-supplied gradient along the same direction. The prin- - cipal characteristic of CHKDER is its invariance to changes in - scale of the variables or functions. -0 Timing. The time required by CHKDER depends only on M and N. - The number of arithmetic operations needed by CHKDER is about - N when MODE = 1 and M*N when MODE = 2. -0 Storage. CHKDER requires M*N + 3*M + 2*N single precision stor - age locations, in addition to the storage required by the pro - gram. There are no internally declared storage arrays. -0 - 7. Subprograms required. -0 MINPACK-supplied ... SPMPAR -0 FORTRAN-supplied ... ABS,ALOG10,SQRT -0 - 8. References. -0 None. -0 - 9. Example. -0 This example checks the Jacobian matrix for the problem that - determines the values of x(1), x(2), and x(3) which provide the - best fit (in the least squares sense) of -0 x(1) + u(i)/(v(i)*x(2) + w(i)*x(3)), i = 1, 15 -0 to the data -0 y = (0.14,0.18,0.22,0.25,0.29,0.32,0.35,0.39, - 0.37,0.58,0.73,0.96,1.34,2.10,4.39), -0 where u(i) = i, v(i) = 16 - i, and w(i) = min(u(i),v(i)). The - i-th component of FVEC is thus defined by -0 y(i) - (x(1) + u(i)/(v(i)*x(2) + w(i)*x(3))). -1 -0 Page -0 C ********** - C - C DRIVER FOR CHKDER EXAMPLE. - C SINGLE PRECISION VERSION - C - C ********** - INTEGER I,M,N,LDFJAC,MODE,NWRITE - REAL X(3),FVEC(15),FJAC(15,3),XP(3),FVECP(15),ERR(15) - C - C LOGICAL OUTPUT UNIT IS ASSUMED TO BE NUMBER 6. - C - DATA NWRITE /6/ - C - M = 15 - N = 3 - C - C THE FOLLOWING VALUES SHOULD BE SUITABLE FOR - C CHECKING THE JACOBIAN MATRIX. - C - X(1) = 9.2E-1 - X(2) = 1.3E-1 - X(3) = 5.4E-1 - C - LDFJAC = 15 - C - MODE = 1 - CALL CHKDER(M,N,X,FVEC,FJAC,LDFJAC,XP,FVECP,MODE,ERR) - MODE = 2 - CALL FCN(M,N,X,FVEC,FJAC,LDFJAC,1) - CALL FCN(M,N,X,FVEC,FJAC,LDFJAC,2) - CALL FCN(M,N,XP,FVECP,FJAC,LDFJAC,1) - CALL CHKDER(M,N,X,FVEC,FJAC,LDFJAC,XP,FVECP,MODE,ERR) - C - DO 10 I = 1, M - FVECP(I) = FVECP(I) - FVEC(I) - 10 CONTINUE - WRITE (NWRITE,1000) (FVEC(I),I=1,M) - WRITE (NWRITE,2000) (FVECP(I),I=1,M) - WRITE (NWRITE,3000) (ERR(I),I=1,M) - STOP - 1000 FORMAT (/5X,5H FVEC // (5X,3E15.7)) - 2000 FORMAT (/5X,13H FVECP - FVEC // (5X,3E15.7)) - 3000 FORMAT (/5X,4H ERR // (5X,3E15.7)) - C - C LAST CARD OF DRIVER FOR CHKDER EXAMPLE. - C - END - SUBROUTINE FCN(M,N,X,FVEC,FJAC,LDFJAC,IFLAG) - INTEGER M,N,LDFJAC,IFLAG - REAL X(N),FVEC(M),FJAC(LDFJAC,N) - C - C SUBROUTINE FCN FOR CHKDER EXAMPLE. - C - INTEGER I -1 -0 Page -0 REAL TMP1,TMP2,TMP3,TMP4 - REAL Y(15) - DATA Y(1),Y(2),Y(3),Y(4),Y(5),Y(6),Y(7),Y(8), - * Y(9),Y(10),Y(11),Y(12),Y(13),Y(14),Y(15) - * /1.4E-1,1.8E-1,2.2E-1,2.5E-1,2.9E-1,3.2E-1,3.5E-1,3.9E-1, - * 3.7E-1,5.8E-1,7.3E-1,9.6E-1,1.34E0,2.1E0,4.39E0/ - C - IF (IFLAG .EQ. 2) GO TO 20 - DO 10 I = 1, 15 - TMP1 = I - TMP2 = 16 - I - TMP3 = TMP1 - IF (I .GT. 8) TMP3 = TMP2 - FVEC(I) = Y(I) - (X(1) + TMP1/(X(2)*TMP2 + X(3)*TMP3)) - 10 CONTINUE - GO TO 40 - 20 CONTINUE - DO 30 I = 1, 15 - TMP1 = I - TMP2 = 16 - I - C - C ERROR INTRODUCED INTO NEXT STATEMENT FOR ILLUSTRATION. - C CORRECTED STATEMENT SHOULD READ TMP3 = TMP1 . - C - TMP3 = TMP2 - IF (I .GT. 8) TMP3 = TMP2 - TMP4 = (X(2)*TMP2 + X(3)*TMP3)**2 - FJAC(I,1) = -1.E0 - FJAC(I,2) = TMP1*TMP2/TMP4 - FJAC(I,3) = TMP1*TMP3/TMP4 - 30 CONTINUE - 40 CONTINUE - RETURN - C - C LAST CARD OF SUBROUTINE FCN. - C - END -0 Results obtained with different compilers or machines - may be different. In particular, the differences - FVECP - FVEC are machine dependent. -0 FVEC -0 -0.1181606E+01 -0.1429655E+01 -0.1606344E+01 - -0.1745269E+01 -0.1840654E+01 -0.1921586E+01 - -0.1984141E+01 -0.2022537E+01 -0.2468977E+01 - -0.2827562E+01 -0.3473582E+01 -0.4437612E+01 - -0.6047662E+01 -0.9267761E+01 -0.1891806E+02 -0 FVECP - FVEC -0 -0.7724666E-08 -0.3432405E-08 -0.2034843E-09 - 0.2313685E-08 0.4331078E-08 0.5984096E-08 -1 -0 Page -0 0.7363281E-08 0.8531470E-08 0.1488591E-07 - 0.2335850E-07 0.3522012E-07 0.5301255E-07 - 0.8266660E-07 0.1419747E-06 0.3198990E-06 -0 ERR -0 0.1141397E+00 0.9943516E-01 0.9674474E-01 - 0.9980447E-01 0.1073116E+00 0.1220445E+00 - 0.1526814E+00 0.1000000E+01 0.1000000E+01 - 0.1000000E+01 0.1000000E+01 0.1000000E+01 - 0.1000000E+01 0.1000000E+01 0.1000000E+01 diff --git a/ex/file04 b/ex/file04 deleted file mode 100644 index 7205031..0000000 --- a/ex/file04 +++ /dev/null @@ -1,192 +0,0 @@ - DOUBLE PRECISION FUNCTION DPMPAR(I) - INTEGER I -C ********** -C -C FUNCTION DPMPAR -C -C THIS FUNCTION PROVIDES DOUBLE PRECISION MACHINE PARAMETERS -C WHEN THE APPROPRIATE SET OF DATA STATEMENTS IS ACTIVATED (BY -C REMOVING THE C FROM COLUMN 1) AND ALL OTHER DATA STATEMENTS ARE -C RENDERED INACTIVE. MOST OF THE PARAMETER VALUES WERE OBTAINED -C FROM THE CORRESPONDING BELL LABORATORIES PORT LIBRARY FUNCTION. -C -C THE FUNCTION STATEMENT IS -C -C DOUBLE PRECISION FUNCTION DPMPAR(I) -C -C WHERE -C -C I IS AN INTEGER INPUT VARIABLE SET TO 1, 2, OR 3 WHICH -C SELECTS THE DESIRED MACHINE PARAMETER. IF THE MACHINE HAS -C T BASE B DIGITS AND ITS SMALLEST AND LARGEST EXPONENTS ARE -C EMIN AND EMAX, RESPECTIVELY, THEN THESE PARAMETERS ARE -C -C DPMPAR(1) = B**(1 - T), THE MACHINE PRECISION, -C -C DPMPAR(2) = B**(EMIN - 1), THE SMALLEST MAGNITUDE, -C -C DPMPAR(3) = B**EMAX*(1 - B**(-T)), THE LARGEST MAGNITUDE. -C -C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. -C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE -C -C ********** - INTEGER MCHEPS(4) - INTEGER MINMAG(4) - INTEGER MAXMAG(4) - DOUBLE PRECISION DMACH(3) - EQUIVALENCE (DMACH(1),MCHEPS(1)) - EQUIVALENCE (DMACH(2),MINMAG(1)) - EQUIVALENCE (DMACH(3),MAXMAG(1)) -C -C MACHINE CONSTANTS FOR THE IBM 360/370 SERIES, -C THE AMDAHL 470/V6, THE ICL 2900, THE ITEL AS/6, -C THE XEROX SIGMA 5/7/9 AND THE SEL SYSTEMS 85/86. -C - DATA MCHEPS(1),MCHEPS(2) / Z34100000, Z00000000 / - DATA MINMAG(1),MINMAG(2) / Z00100000, Z00000000 / - DATA MAXMAG(1),MAXMAG(2) / Z7FFFFFFF, ZFFFFFFFF / -C -C MACHINE CONSTANTS FOR THE HONEYWELL 600/6000 SERIES. -C -C DATA MCHEPS(1),MCHEPS(2) / O606400000000, O000000000000 / -C DATA MINMAG(1),MINMAG(2) / O402400000000, O000000000000 / -C DATA MAXMAG(1),MAXMAG(2) / O376777777777, O777777777777 / -C -C MACHINE CONSTANTS FOR THE CDC 6000/7000 SERIES. -C -C DATA MCHEPS(1) / 15614000000000000000B / -C DATA MCHEPS(2) / 15010000000000000000B / -C -C DATA MINMAG(1) / 00604000000000000000B / -C DATA MINMAG(2) / 00000000000000000000B / -C -C DATA MAXMAG(1) / 37767777777777777777B / -C DATA MAXMAG(2) / 37167777777777777777B / -C -C MACHINE CONSTANTS FOR THE PDP-10 (KA PROCESSOR). -C -C DATA MCHEPS(1),MCHEPS(2) / "114400000000, "000000000000 / -C DATA MINMAG(1),MINMAG(2) / "033400000000, "000000000000 / -C DATA MAXMAG(1),MAXMAG(2) / "377777777777, "344777777777 / -C -C MACHINE CONSTANTS FOR THE PDP-10 (KI PROCESSOR). -C -C DATA MCHEPS(1),MCHEPS(2) / "104400000000, "000000000000 / -C DATA MINMAG(1),MINMAG(2) / "000400000000, "000000000000 / -C DATA MAXMAG(1),MAXMAG(2) / "377777777777, "377777777777 / -C -C MACHINE CONSTANTS FOR THE PDP-11 FORTRAN SUPPORTING -C 32-BIT INTEGERS (EXPRESSED IN INTEGER AND OCTAL). -C -C DATA MCHEPS(1),MCHEPS(2) / 620756992, 0 / -C DATA MINMAG(1),MINMAG(2) / 8388608, 0 / -C DATA MAXMAG(1),MAXMAG(2) / 2147483647, -1 / -C -C DATA MCHEPS(1),MCHEPS(2) / O04500000000, O00000000000 / -C DATA MINMAG(1),MINMAG(2) / O00040000000, O00000000000 / -C DATA MAXMAG(1),MAXMAG(2) / O17777777777, O37777777777 / -C -C MACHINE CONSTANTS FOR THE PDP-11 FORTRAN SUPPORTING -C 16-BIT INTEGERS (EXPRESSED IN INTEGER AND OCTAL). -C -C DATA MCHEPS(1),MCHEPS(2) / 9472, 0 / -C DATA MCHEPS(3),MCHEPS(4) / 0, 0 / -C -C DATA MINMAG(1),MINMAG(2) / 128, 0 / -C DATA MINMAG(3),MINMAG(4) / 0, 0 / -C -C DATA MAXMAG(1),MAXMAG(2) / 32767, -1 / -C DATA MAXMAG(3),MAXMAG(4) / -1, -1 / -C -C DATA MCHEPS(1),MCHEPS(2) / O022400, O000000 / -C DATA MCHEPS(3),MCHEPS(4) / O000000, O000000 / -C -C DATA MINMAG(1),MINMAG(2) / O000200, O000000 / -C DATA MINMAG(3),MINMAG(4) / O000000, O000000 / -C -C DATA MAXMAG(1),MAXMAG(2) / O077777, O177777 / -C DATA MAXMAG(3),MAXMAG(4) / O177777, O177777 / -C -C MACHINE CONSTANTS FOR THE BURROUGHS 6700/7700 SYSTEMS. -C -C DATA MCHEPS(1) / O1451000000000000 / -C DATA MCHEPS(2) / O0000000000000000 / -C -C DATA MINMAG(1) / O1771000000000000 / -C DATA MINMAG(2) / O7770000000000000 / -C -C DATA MAXMAG(1) / O0777777777777777 / -C DATA MAXMAG(2) / O7777777777777777 / -C -C MACHINE CONSTANTS FOR THE BURROUGHS 5700 SYSTEM. -C -C DATA MCHEPS(1) / O1451000000000000 / -C DATA MCHEPS(2) / O0000000000000000 / -C -C DATA MINMAG(1) / O1771000000000000 / -C DATA MINMAG(2) / O0000000000000000 / -C -C DATA MAXMAG(1) / O0777777777777777 / -C DATA MAXMAG(2) / O0007777777777777 / -C -C MACHINE CONSTANTS FOR THE BURROUGHS 1700 SYSTEM. -C -C DATA MCHEPS(1) / ZCC6800000 / -C DATA MCHEPS(2) / Z000000000 / -C -C DATA MINMAG(1) / ZC00800000 / -C DATA MINMAG(2) / Z000000000 / -C -C DATA MAXMAG(1) / ZDFFFFFFFF / -C DATA MAXMAG(2) / ZFFFFFFFFF / -C -C MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES. -C -C DATA MCHEPS(1),MCHEPS(2) / O170640000000, O000000000000 / -C DATA MINMAG(1),MINMAG(2) / O000040000000, O000000000000 / -C DATA MAXMAG(1),MAXMAG(2) / O377777777777, O777777777777 / -C -C MACHINE CONSTANTS FOR THE DATA GENERAL ECLIPSE S/200. -C -C NOTE - IT MAY BE APPROPRIATE TO INCLUDE THE FOLLOWING CARD - -C STATIC DMACH(3) -C -C DATA MINMAG/20K,3*0/,MAXMAG/77777K,3*177777K/ -C DATA MCHEPS/32020K,3*0/ -C -C MACHINE CONSTANTS FOR THE HARRIS 220. -C -C DATA MCHEPS(1),MCHEPS(2) / '20000000, '00000334 / -C DATA MINMAG(1),MINMAG(2) / '20000000, '00000201 / -C DATA MAXMAG(1),MAXMAG(2) / '37777777, '37777577 / -C -C MACHINE CONSTANTS FOR THE CRAY-1. -C -C DATA MCHEPS(1) / 0376424000000000000000B / -C DATA MCHEPS(2) / 0000000000000000000000B / -C -C DATA MINMAG(1) / 0200034000000000000000B / -C DATA MINMAG(2) / 0000000000000000000000B / -C -C DATA MAXMAG(1) / 0577777777777777777777B / -C DATA MAXMAG(2) / 0000007777777777777776B / -C -C MACHINE CONSTANTS FOR THE PRIME 400. -C -C DATA MCHEPS(1),MCHEPS(2) / :10000000000, :00000000123 / -C DATA MINMAG(1),MINMAG(2) / :10000000000, :00000100000 / -C DATA MAXMAG(1),MAXMAG(2) / :17777777777, :37777677776 / -C -C MACHINE CONSTANTS FOR THE VAX-11. -C -C DATA MCHEPS(1),MCHEPS(2) / 9472, 0 / -C DATA MINMAG(1),MINMAG(2) / 128, 0 / -C DATA MAXMAG(1),MAXMAG(2) / -32769, -1 / -C - DPMPAR = DMACH(I) - RETURN -C -C LAST CARD OF FUNCTION DPMPAR. -C - END diff --git a/ex/file05 b/ex/file05 deleted file mode 100644 index f777577..0000000 --- a/ex/file05 +++ /dev/null @@ -1,4778 +0,0 @@ - SUBROUTINE CHKDER(M,N,X,FVEC,FJAC,LDFJAC,XP,FVECP,MODE,ERR) - INTEGER M,N,LDFJAC,MODE - DOUBLE PRECISION X(N),FVEC(M),FJAC(LDFJAC,N),XP(N),FVECP(M), - * ERR(M) -C ********** -C -C SUBROUTINE CHKDER -C -C THIS SUBROUTINE CHECKS THE GRADIENTS OF M NONLINEAR FUNCTIONS -C IN N VARIABLES, EVALUATED AT A POINT X, FOR CONSISTENCY WITH -C THE FUNCTIONS THEMSELVES. THE USER MUST CALL CHKDER TWICE, -C FIRST WITH MODE = 1 AND THEN WITH MODE = 2. -C -C MODE = 1. ON INPUT, X MUST CONTAIN THE POINT OF EVALUATION. -C ON OUTPUT, XP IS SET TO A NEIGHBORING POINT. -C -C MODE = 2. ON INPUT, FVEC MUST CONTAIN THE FUNCTIONS AND THE -C ROWS OF FJAC MUST CONTAIN THE GRADIENTS -C OF THE RESPECTIVE FUNCTIONS EACH EVALUATED -C AT X, AND FVECP MUST CONTAIN THE FUNCTIONS -C EVALUATED AT XP. -C ON OUTPUT, ERR CONTAINS MEASURES OF CORRECTNESS OF -C THE RESPECTIVE GRADIENTS. -C -C THE SUBROUTINE DOES NOT PERFORM RELIABLY IF CANCELLATION OR -C ROUNDING ERRORS CAUSE A SEVERE LOSS OF SIGNIFICANCE IN THE -C EVALUATION OF A FUNCTION. THEREFORE, NONE OF THE COMPONENTS -C OF X SHOULD BE UNUSUALLY SMALL (IN PARTICULAR, ZERO) OR ANY -C OTHER VALUE WHICH MAY CAUSE LOSS OF SIGNIFICANCE. -C -C THE SUBROUTINE STATEMENT IS -C -C SUBROUTINE CHKDER(M,N,X,FVEC,FJAC,LDFJAC,XP,FVECP,MODE,ERR) -C -C WHERE -C -C M IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER -C OF FUNCTIONS. -C -C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER -C OF VARIABLES. -C -C X IS AN INPUT ARRAY OF LENGTH N. -C -C FVEC IS AN ARRAY OF LENGTH M. ON INPUT WHEN MODE = 2, -C FVEC MUST CONTAIN THE FUNCTIONS EVALUATED AT X. -C -C FJAC IS AN M BY N ARRAY. ON INPUT WHEN MODE = 2, -C THE ROWS OF FJAC MUST CONTAIN THE GRADIENTS OF -C THE RESPECTIVE FUNCTIONS EVALUATED AT X. -C -C LDFJAC IS A POSITIVE INTEGER INPUT PARAMETER NOT LESS THAN M -C WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY FJAC. -C -C XP IS AN ARRAY OF LENGTH N. ON OUTPUT WHEN MODE = 1, -C XP IS SET TO A NEIGHBORING POINT OF X. -C -C FVECP IS AN ARRAY OF LENGTH M. ON INPUT WHEN MODE = 2, -C FVECP MUST CONTAIN THE FUNCTIONS EVALUATED AT XP. -C -C MODE IS AN INTEGER INPUT VARIABLE SET TO 1 ON THE FIRST CALL -C AND 2 ON THE SECOND. OTHER VALUES OF MODE ARE EQUIVALENT -C TO MODE = 1. -C -C ERR IS AN ARRAY OF LENGTH M. ON OUTPUT WHEN MODE = 2, -C ERR CONTAINS MEASURES OF CORRECTNESS OF THE RESPECTIVE -C GRADIENTS. IF THERE IS NO SEVERE LOSS OF SIGNIFICANCE, -C THEN IF ERR(I) IS 1.0 THE I-TH GRADIENT IS CORRECT, -C WHILE IF ERR(I) IS 0.0 THE I-TH GRADIENT IS INCORRECT. -C FOR VALUES OF ERR BETWEEN 0.0 AND 1.0, THE CATEGORIZATION -C IS LESS CERTAIN. IN GENERAL, A VALUE OF ERR(I) GREATER -C THAN 0.5 INDICATES THAT THE I-TH GRADIENT IS PROBABLY -C CORRECT, WHILE A VALUE OF ERR(I) LESS THAN 0.5 INDICATES -C THAT THE I-TH GRADIENT IS PROBABLY INCORRECT. -C -C SUBPROGRAMS CALLED -C -C MINPACK SUPPLIED ... DPMPAR -C -C FORTRAN SUPPLIED ... DABS,DLOG10,DSQRT -C -C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. -C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE -C -C ********** - INTEGER I,J - DOUBLE PRECISION EPS,EPSF,EPSLOG,EPSMCH,FACTOR,ONE,TEMP,ZERO - DOUBLE PRECISION DPMPAR - DATA FACTOR,ONE,ZERO /1.0D2,1.0D0,0.0D0/ -C -C EPSMCH IS THE MACHINE PRECISION. -C - EPSMCH = DPMPAR(1) -C - EPS = DSQRT(EPSMCH) -C - IF (MODE .EQ. 2) GO TO 20 -C -C MODE = 1. -C - DO 10 J = 1, N - TEMP = EPS*DABS(X(J)) - IF (TEMP .EQ. ZERO) TEMP = EPS - XP(J) = X(J) + TEMP - 10 CONTINUE - GO TO 70 - 20 CONTINUE -C -C MODE = 2. -C - EPSF = FACTOR*EPSMCH - EPSLOG = DLOG10(EPS) - DO 30 I = 1, M - ERR(I) = ZERO - 30 CONTINUE - DO 50 J = 1, N - TEMP = DABS(X(J)) - IF (TEMP .EQ. ZERO) TEMP = ONE - DO 40 I = 1, M - ERR(I) = ERR(I) + TEMP*FJAC(I,J) - 40 CONTINUE - 50 CONTINUE - DO 60 I = 1, M - TEMP = ONE - IF (FVEC(I) .NE. ZERO .AND. FVECP(I) .NE. ZERO - * .AND. DABS(FVECP(I)-FVEC(I)) .GE. EPSF*DABS(FVEC(I))) - * TEMP = EPS*DABS((FVECP(I)-FVEC(I))/EPS-ERR(I)) - * /(DABS(FVEC(I)) + DABS(FVECP(I))) - ERR(I) = ONE - IF (TEMP .GT. EPSMCH .AND. TEMP .LT. EPS) - * ERR(I) = (DLOG10(TEMP) - EPSLOG)/EPSLOG - IF (TEMP .GE. EPS) ERR(I) = ZERO - 60 CONTINUE - 70 CONTINUE -C - RETURN -C -C LAST CARD OF SUBROUTINE CHKDER. -C - END - SUBROUTINE DOGLEG(N,R,LR,DIAG,QTB,DELTA,X,WA1,WA2) - INTEGER N,LR - DOUBLE PRECISION DELTA - DOUBLE PRECISION R(LR),DIAG(N),QTB(N),X(N),WA1(N),WA2(N) -C ********** -C -C SUBROUTINE DOGLEG -C -C GIVEN AN M BY N MATRIX A, AN N BY N NONSINGULAR DIAGONAL -C MATRIX D, AN M-VECTOR B, AND A POSITIVE NUMBER DELTA, THE -C PROBLEM IS TO DETERMINE THE CONVEX COMBINATION X OF THE -C GAUSS-NEWTON AND SCALED GRADIENT DIRECTIONS THAT MINIMIZES -C (A*X - B) IN THE LEAST SQUARES SENSE, SUBJECT TO THE -C RESTRICTION THAT THE EUCLIDEAN NORM OF D*X BE AT MOST DELTA. -C -C THIS SUBROUTINE COMPLETES THE SOLUTION OF THE PROBLEM -C IF IT IS PROVIDED WITH THE NECESSARY INFORMATION FROM THE -C QR FACTORIZATION OF A. THAT IS, IF A = Q*R, WHERE Q HAS -C ORTHOGONAL COLUMNS AND R IS AN UPPER TRIANGULAR MATRIX, -C THEN DOGLEG EXPECTS THE FULL UPPER TRIANGLE OF R AND -C THE FIRST N COMPONENTS OF (Q TRANSPOSE)*B. -C -C THE SUBROUTINE STATEMENT IS -C -C SUBROUTINE DOGLEG(N,R,LR,DIAG,QTB,DELTA,X,WA1,WA2) -C -C WHERE -C -C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE ORDER OF R. -C -C R IS AN INPUT ARRAY OF LENGTH LR WHICH MUST CONTAIN THE UPPER -C TRIANGULAR MATRIX R STORED BY ROWS. -C -C LR IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN -C (N*(N+1))/2. -C -C DIAG IS AN INPUT ARRAY OF LENGTH N WHICH MUST CONTAIN THE -C DIAGONAL ELEMENTS OF THE MATRIX D. -C -C QTB IS AN INPUT ARRAY OF LENGTH N WHICH MUST CONTAIN THE FIRST -C N ELEMENTS OF THE VECTOR (Q TRANSPOSE)*B. -C -C DELTA IS A POSITIVE INPUT VARIABLE WHICH SPECIFIES AN UPPER -C BOUND ON THE EUCLIDEAN NORM OF D*X. -C -C X IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE DESIRED -C CONVEX COMBINATION OF THE GAUSS-NEWTON DIRECTION AND THE -C SCALED GRADIENT DIRECTION. -C -C WA1 AND WA2 ARE WORK ARRAYS OF LENGTH N. -C -C SUBPROGRAMS CALLED -C -C MINPACK-SUPPLIED ... DPMPAR,ENORM -C -C FORTRAN-SUPPLIED ... DABS,DMAX1,DMIN1,DSQRT -C -C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. -C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE -C -C ********** - INTEGER I,J,JJ,JP1,K,L - DOUBLE PRECISION ALPHA,BNORM,EPSMCH,GNORM,ONE,QNORM,SGNORM,SUM, - * TEMP,ZERO - DOUBLE PRECISION DPMPAR,ENORM - DATA ONE,ZERO /1.0D0,0.0D0/ -C -C EPSMCH IS THE MACHINE PRECISION. -C - EPSMCH = DPMPAR(1) -C -C FIRST, CALCULATE THE GAUSS-NEWTON DIRECTION. -C - JJ = (N*(N + 1))/2 + 1 - DO 50 K = 1, N - J = N - K + 1 - JP1 = J + 1 - JJ = JJ - K - L = JJ + 1 - SUM = ZERO - IF (N .LT. JP1) GO TO 20 - DO 10 I = JP1, N - SUM = SUM + R(L)*X(I) - L = L + 1 - 10 CONTINUE - 20 CONTINUE - TEMP = R(JJ) - IF (TEMP .NE. ZERO) GO TO 40 - L = J - DO 30 I = 1, J - TEMP = DMAX1(TEMP,DABS(R(L))) - L = L + N - I - 30 CONTINUE - TEMP = EPSMCH*TEMP - IF (TEMP .EQ. ZERO) TEMP = EPSMCH - 40 CONTINUE - X(J) = (QTB(J) - SUM)/TEMP - 50 CONTINUE -C -C TEST WHETHER THE GAUSS-NEWTON DIRECTION IS ACCEPTABLE. -C - DO 60 J = 1, N - WA1(J) = ZERO - WA2(J) = DIAG(J)*X(J) - 60 CONTINUE - QNORM = ENORM(N,WA2) - IF (QNORM .LE. DELTA) GO TO 140 -C -C THE GAUSS-NEWTON DIRECTION IS NOT ACCEPTABLE. -C NEXT, CALCULATE THE SCALED GRADIENT DIRECTION. -C - L = 1 - DO 80 J = 1, N - TEMP = QTB(J) - DO 70 I = J, N - WA1(I) = WA1(I) + R(L)*TEMP - L = L + 1 - 70 CONTINUE - WA1(J) = WA1(J)/DIAG(J) - 80 CONTINUE -C -C CALCULATE THE NORM OF THE SCALED GRADIENT AND TEST FOR -C THE SPECIAL CASE IN WHICH THE SCALED GRADIENT IS ZERO. -C - GNORM = ENORM(N,WA1) - SGNORM = ZERO - ALPHA = DELTA/QNORM - IF (GNORM .EQ. ZERO) GO TO 120 -C -C CALCULATE THE POINT ALONG THE SCALED GRADIENT -C AT WHICH THE QUADRATIC IS MINIMIZED. -C - DO 90 J = 1, N - WA1(J) = (WA1(J)/GNORM)/DIAG(J) - 90 CONTINUE - L = 1 - DO 110 J = 1, N - SUM = ZERO - DO 100 I = J, N - SUM = SUM + R(L)*WA1(I) - L = L + 1 - 100 CONTINUE - WA2(J) = SUM - 110 CONTINUE - TEMP = ENORM(N,WA2) - SGNORM = (GNORM/TEMP)/TEMP -C -C TEST WHETHER THE SCALED GRADIENT DIRECTION IS ACCEPTABLE. -C - ALPHA = ZERO - IF (SGNORM .GE. DELTA) GO TO 120 -C -C THE SCALED GRADIENT DIRECTION IS NOT ACCEPTABLE. -C FINALLY, CALCULATE THE POINT ALONG THE DOGLEG -C AT WHICH THE QUADRATIC IS MINIMIZED. -C - BNORM = ENORM(N,QTB) - TEMP = (BNORM/GNORM)*(BNORM/QNORM)*(SGNORM/DELTA) - TEMP = TEMP - (DELTA/QNORM)*(SGNORM/DELTA)**2 - * + DSQRT((TEMP-(DELTA/QNORM))**2 - * +(ONE-(DELTA/QNORM)**2)*(ONE-(SGNORM/DELTA)**2)) - ALPHA = ((DELTA/QNORM)*(ONE - (SGNORM/DELTA)**2))/TEMP - 120 CONTINUE -C -C FORM APPROPRIATE CONVEX COMBINATION OF THE GAUSS-NEWTON -C DIRECTION AND THE SCALED GRADIENT DIRECTION. -C - TEMP = (ONE - ALPHA)*DMIN1(SGNORM,DELTA) - DO 130 J = 1, N - X(J) = TEMP*WA1(J) + ALPHA*X(J) - 130 CONTINUE - 140 CONTINUE - RETURN -C -C LAST CARD OF SUBROUTINE DOGLEG. -C - END - DOUBLE PRECISION FUNCTION ENORM(N,X) - INTEGER N - DOUBLE PRECISION X(N) -C ********** -C -C FUNCTION ENORM -C -C GIVEN AN N-VECTOR X, THIS FUNCTION CALCULATES THE -C EUCLIDEAN NORM OF X. -C -C THE EUCLIDEAN NORM IS COMPUTED BY ACCUMULATING THE SUM OF -C SQUARES IN THREE DIFFERENT SUMS. THE SUMS OF SQUARES FOR THE -C SMALL AND LARGE COMPONENTS ARE SCALED SO THAT NO OVERFLOWS -C OCCUR. NON-DESTRUCTIVE UNDERFLOWS ARE PERMITTED. UNDERFLOWS -C AND OVERFLOWS DO NOT OCCUR IN THE COMPUTATION OF THE UNSCALED -C SUM OF SQUARES FOR THE INTERMEDIATE COMPONENTS. -C THE DEFINITIONS OF SMALL, INTERMEDIATE AND LARGE COMPONENTS -C DEPEND ON TWO CONSTANTS, RDWARF AND RGIANT. THE MAIN -C RESTRICTIONS ON THESE CONSTANTS ARE THAT RDWARF**2 NOT -C UNDERFLOW AND RGIANT**2 NOT OVERFLOW. THE CONSTANTS -C GIVEN HERE ARE SUITABLE FOR EVERY KNOWN COMPUTER. -C -C THE FUNCTION STATEMENT IS -C -C DOUBLE PRECISION FUNCTION ENORM(N,X) -C -C WHERE -C -C N IS A POSITIVE INTEGER INPUT VARIABLE. -C -C X IS AN INPUT ARRAY OF LENGTH N. -C -C SUBPROGRAMS CALLED -C -C FORTRAN-SUPPLIED ... DABS,DSQRT -C -C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. -C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE -C -C ********** - INTEGER I - DOUBLE PRECISION AGIANT,FLOATN,ONE,RDWARF,RGIANT,S1,S2,S3,XABS, - * X1MAX,X3MAX,ZERO - DATA ONE,ZERO,RDWARF,RGIANT /1.0D0,0.0D0,3.834D-20,1.304D19/ - S1 = ZERO - S2 = ZERO - S3 = ZERO - X1MAX = ZERO - X3MAX = ZERO - FLOATN = N - AGIANT = RGIANT/FLOATN - DO 90 I = 1, N - XABS = DABS(X(I)) - IF (XABS .GT. RDWARF .AND. XABS .LT. AGIANT) GO TO 70 - IF (XABS .LE. RDWARF) GO TO 30 -C -C SUM FOR LARGE COMPONENTS. -C - IF (XABS .LE. X1MAX) GO TO 10 - S1 = ONE + S1*(X1MAX/XABS)**2 - X1MAX = XABS - GO TO 20 - 10 CONTINUE - S1 = S1 + (XABS/X1MAX)**2 - 20 CONTINUE - GO TO 60 - 30 CONTINUE -C -C SUM FOR SMALL COMPONENTS. -C - IF (XABS .LE. X3MAX) GO TO 40 - S3 = ONE + S3*(X3MAX/XABS)**2 - X3MAX = XABS - GO TO 50 - 40 CONTINUE - IF (XABS .NE. ZERO) S3 = S3 + (XABS/X3MAX)**2 - 50 CONTINUE - 60 CONTINUE - GO TO 80 - 70 CONTINUE -C -C SUM FOR INTERMEDIATE COMPONENTS. -C - S2 = S2 + XABS**2 - 80 CONTINUE - 90 CONTINUE -C -C CALCULATION OF NORM. -C - IF (S1 .EQ. ZERO) GO TO 100 - ENORM = X1MAX*DSQRT(S1+(S2/X1MAX)/X1MAX) - GO TO 130 - 100 CONTINUE - IF (S2 .EQ. ZERO) GO TO 110 - IF (S2 .GE. X3MAX) - * ENORM = DSQRT(S2*(ONE+(X3MAX/S2)*(X3MAX*S3))) - IF (S2 .LT. X3MAX) - * ENORM = DSQRT(X3MAX*((S2/X3MAX)+(X3MAX*S3))) - GO TO 120 - 110 CONTINUE - ENORM = X3MAX*DSQRT(S3) - 120 CONTINUE - 130 CONTINUE - RETURN -C -C LAST CARD OF FUNCTION ENORM. -C - END - SUBROUTINE FDJAC1(FCN,N,X,FVEC,FJAC,LDFJAC,IFLAG,ML,MU,EPSFCN, - * WA1,WA2) - INTEGER N,LDFJAC,IFLAG,ML,MU - DOUBLE PRECISION EPSFCN - DOUBLE PRECISION X(N),FVEC(N),FJAC(LDFJAC,N),WA1(N),WA2(N) -C ********** -C -C SUBROUTINE FDJAC1 -C -C THIS SUBROUTINE COMPUTES A FORWARD-DIFFERENCE APPROXIMATION -C TO THE N BY N JACOBIAN MATRIX ASSOCIATED WITH A SPECIFIED -C PROBLEM OF N FUNCTIONS IN N VARIABLES. IF THE JACOBIAN HAS -C A BANDED FORM, THEN FUNCTION EVALUATIONS ARE SAVED BY ONLY -C APPROXIMATING THE NONZERO TERMS. -C -C THE SUBROUTINE STATEMENT IS -C -C SUBROUTINE FDJAC1(FCN,N,X,FVEC,FJAC,LDFJAC,IFLAG,ML,MU,EPSFCN, -C WA1,WA2) -C -C WHERE -C -C FCN IS THE NAME OF THE USER-SUPPLIED SUBROUTINE WHICH -C CALCULATES THE FUNCTIONS. FCN MUST BE DECLARED -C IN AN EXTERNAL STATEMENT IN THE USER CALLING -C PROGRAM, AND SHOULD BE WRITTEN AS FOLLOWS. -C -C SUBROUTINE FCN(N,X,FVEC,IFLAG) -C INTEGER N,IFLAG -C DOUBLE PRECISION X(N),FVEC(N) -C ---------- -C CALCULATE THE FUNCTIONS AT X AND -C RETURN THIS VECTOR IN FVEC. -C ---------- -C RETURN -C END -C -C THE VALUE OF IFLAG SHOULD NOT BE CHANGED BY FCN UNLESS -C THE USER WANTS TO TERMINATE EXECUTION OF FDJAC1. -C IN THIS CASE SET IFLAG TO A NEGATIVE INTEGER. -C -C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER -C OF FUNCTIONS AND VARIABLES. -C -C X IS AN INPUT ARRAY OF LENGTH N. -C -C FVEC IS AN INPUT ARRAY OF LENGTH N WHICH MUST CONTAIN THE -C FUNCTIONS EVALUATED AT X. -C -C FJAC IS AN OUTPUT N BY N ARRAY WHICH CONTAINS THE -C APPROXIMATION TO THE JACOBIAN MATRIX EVALUATED AT X. -C -C LDFJAC IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN N -C WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY FJAC. -C -C IFLAG IS AN INTEGER VARIABLE WHICH CAN BE USED TO TERMINATE -C THE EXECUTION OF FDJAC1. SEE DESCRIPTION OF FCN. -C -C ML IS A NONNEGATIVE INTEGER INPUT VARIABLE WHICH SPECIFIES -C THE NUMBER OF SUBDIAGONALS WITHIN THE BAND OF THE -C JACOBIAN MATRIX. IF THE JACOBIAN IS NOT BANDED, SET -C ML TO AT LEAST N - 1. -C -C EPSFCN IS AN INPUT VARIABLE USED IN DETERMINING A SUITABLE -C STEP LENGTH FOR THE FORWARD-DIFFERENCE APPROXIMATION. THIS -C APPROXIMATION ASSUMES THAT THE RELATIVE ERRORS IN THE -C FUNCTIONS ARE OF THE ORDER OF EPSFCN. IF EPSFCN IS LESS -C THAN THE MACHINE PRECISION, IT IS ASSUMED THAT THE RELATIVE -C ERRORS IN THE FUNCTIONS ARE OF THE ORDER OF THE MACHINE -C PRECISION. -C -C MU IS A NONNEGATIVE INTEGER INPUT VARIABLE WHICH SPECIFIES -C THE NUMBER OF SUPERDIAGONALS WITHIN THE BAND OF THE -C JACOBIAN MATRIX. IF THE JACOBIAN IS NOT BANDED, SET -C MU TO AT LEAST N - 1. -C -C WA1 AND WA2 ARE WORK ARRAYS OF LENGTH N. IF ML + MU + 1 IS AT -C LEAST N, THEN THE JACOBIAN IS CONSIDERED DENSE, AND WA2 IS -C NOT REFERENCED. -C -C SUBPROGRAMS CALLED -C -C MINPACK-SUPPLIED ... DPMPAR -C -C FORTRAN-SUPPLIED ... DABS,DMAX1,DSQRT -C -C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. -C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE -C -C ********** - INTEGER I,J,K,MSUM - DOUBLE PRECISION EPS,EPSMCH,H,TEMP,ZERO - DOUBLE PRECISION DPMPAR - DATA ZERO /0.0D0/ -C -C EPSMCH IS THE MACHINE PRECISION. -C - EPSMCH = DPMPAR(1) -C - EPS = DSQRT(DMAX1(EPSFCN,EPSMCH)) - MSUM = ML + MU + 1 - IF (MSUM .LT. N) GO TO 40 -C -C COMPUTATION OF DENSE APPROXIMATE JACOBIAN. -C - DO 20 J = 1, N - TEMP = X(J) - H = EPS*DABS(TEMP) - IF (H .EQ. ZERO) H = EPS - X(J) = TEMP + H - CALL FCN(N,X,WA1,IFLAG) - IF (IFLAG .LT. 0) GO TO 30 - X(J) = TEMP - DO 10 I = 1, N - FJAC(I,J) = (WA1(I) - FVEC(I))/H - 10 CONTINUE - 20 CONTINUE - 30 CONTINUE - GO TO 110 - 40 CONTINUE -C -C COMPUTATION OF BANDED APPROXIMATE JACOBIAN. -C - DO 90 K = 1, MSUM - DO 60 J = K, N, MSUM - WA2(J) = X(J) - H = EPS*DABS(WA2(J)) - IF (H .EQ. ZERO) H = EPS - X(J) = WA2(J) + H - 60 CONTINUE - CALL FCN(N,X,WA1,IFLAG) - IF (IFLAG .LT. 0) GO TO 100 - DO 80 J = K, N, MSUM - X(J) = WA2(J) - H = EPS*DABS(WA2(J)) - IF (H .EQ. ZERO) H = EPS - DO 70 I = 1, N - FJAC(I,J) = ZERO - IF (I .GE. J - MU .AND. I .LE. J + ML) - * FJAC(I,J) = (WA1(I) - FVEC(I))/H - 70 CONTINUE - 80 CONTINUE - 90 CONTINUE - 100 CONTINUE - 110 CONTINUE - RETURN -C -C LAST CARD OF SUBROUTINE FDJAC1. -C - END - SUBROUTINE FDJAC2(FCN,M,N,X,FVEC,FJAC,LDFJAC,IFLAG,EPSFCN,WA) - INTEGER M,N,LDFJAC,IFLAG - DOUBLE PRECISION EPSFCN - DOUBLE PRECISION X(N),FVEC(M),FJAC(LDFJAC,N),WA(M) -C ********** -C -C SUBROUTINE FDJAC2 -C -C THIS SUBROUTINE COMPUTES A FORWARD-DIFFERENCE APPROXIMATION -C TO THE M BY N JACOBIAN MATRIX ASSOCIATED WITH A SPECIFIED -C PROBLEM OF M FUNCTIONS IN N VARIABLES. -C -C THE SUBROUTINE STATEMENT IS -C -C SUBROUTINE FDJAC2(FCN,M,N,X,FVEC,FJAC,LDFJAC,IFLAG,EPSFCN,WA) -C -C WHERE -C -C FCN IS THE NAME OF THE USER-SUPPLIED SUBROUTINE WHICH -C CALCULATES THE FUNCTIONS. FCN MUST BE DECLARED -C IN AN EXTERNAL STATEMENT IN THE USER CALLING -C PROGRAM, AND SHOULD BE WRITTEN AS FOLLOWS. -C -C SUBROUTINE FCN(M,N,X,FVEC,IFLAG) -C INTEGER M,N,IFLAG -C DOUBLE PRECISION X(N),FVEC(M) -C ---------- -C CALCULATE THE FUNCTIONS AT X AND -C RETURN THIS VECTOR IN FVEC. -C ---------- -C RETURN -C END -C -C THE VALUE OF IFLAG SHOULD NOT BE CHANGED BY FCN UNLESS -C THE USER WANTS TO TERMINATE EXECUTION OF FDJAC2. -C IN THIS CASE SET IFLAG TO A NEGATIVE INTEGER. -C -C M IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER -C OF FUNCTIONS. -C -C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER -C OF VARIABLES. N MUST NOT EXCEED M. -C -C X IS AN INPUT ARRAY OF LENGTH N. -C -C FVEC IS AN INPUT ARRAY OF LENGTH M WHICH MUST CONTAIN THE -C FUNCTIONS EVALUATED AT X. -C -C FJAC IS AN OUTPUT M BY N ARRAY WHICH CONTAINS THE -C APPROXIMATION TO THE JACOBIAN MATRIX EVALUATED AT X. -C -C LDFJAC IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN M -C WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY FJAC. -C -C IFLAG IS AN INTEGER VARIABLE WHICH CAN BE USED TO TERMINATE -C THE EXECUTION OF FDJAC2. SEE DESCRIPTION OF FCN. -C -C EPSFCN IS AN INPUT VARIABLE USED IN DETERMINING A SUITABLE -C STEP LENGTH FOR THE FORWARD-DIFFERENCE APPROXIMATION. THIS -C APPROXIMATION ASSUMES THAT THE RELATIVE ERRORS IN THE -C FUNCTIONS ARE OF THE ORDER OF EPSFCN. IF EPSFCN IS LESS -C THAN THE MACHINE PRECISION, IT IS ASSUMED THAT THE RELATIVE -C ERRORS IN THE FUNCTIONS ARE OF THE ORDER OF THE MACHINE -C PRECISION. -C -C WA IS A WORK ARRAY OF LENGTH M. -C -C SUBPROGRAMS CALLED -C -C USER-SUPPLIED ...... FCN -C -C MINPACK-SUPPLIED ... DPMPAR -C -C FORTRAN-SUPPLIED ... DABS,DMAX1,DSQRT -C -C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. -C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE -C -C ********** - INTEGER I,J - DOUBLE PRECISION EPS,EPSMCH,H,TEMP,ZERO - DOUBLE PRECISION DPMPAR - DATA ZERO /0.0D0/ -C -C EPSMCH IS THE MACHINE PRECISION. -C - EPSMCH = DPMPAR(1) -C - EPS = DSQRT(DMAX1(EPSFCN,EPSMCH)) - DO 20 J = 1, N - TEMP = X(J) - H = EPS*DABS(TEMP) - IF (H .EQ. ZERO) H = EPS - X(J) = TEMP + H - CALL FCN(M,N,X,WA,IFLAG) - IF (IFLAG .LT. 0) GO TO 30 - X(J) = TEMP - DO 10 I = 1, M - FJAC(I,J) = (WA(I) - FVEC(I))/H - 10 CONTINUE - 20 CONTINUE - 30 CONTINUE - RETURN -C -C LAST CARD OF SUBROUTINE FDJAC2. -C - END - SUBROUTINE HYBRD(FCN,N,X,FVEC,XTOL,MAXFEV,ML,MU,EPSFCN,DIAG, - * MODE,FACTOR,NPRINT,INFO,NFEV,FJAC,LDFJAC,R,LR, - * QTF,WA1,WA2,WA3,WA4) - INTEGER N,MAXFEV,ML,MU,MODE,NPRINT,INFO,NFEV,LDFJAC,LR - DOUBLE PRECISION XTOL,EPSFCN,FACTOR - DOUBLE PRECISION X(N),FVEC(N),DIAG(N),FJAC(LDFJAC,N),R(LR), - * QTF(N),WA1(N),WA2(N),WA3(N),WA4(N) - EXTERNAL FCN -C ********** -C -C SUBROUTINE HYBRD -C -C THE PURPOSE OF HYBRD IS TO FIND A ZERO OF A SYSTEM OF -C N NONLINEAR FUNCTIONS IN N VARIABLES BY A MODIFICATION -C OF THE POWELL HYBRID METHOD. THE USER MUST PROVIDE A -C SUBROUTINE WHICH CALCULATES THE FUNCTIONS. THE JACOBIAN IS -C THEN CALCULATED BY A FORWARD-DIFFERENCE APPROXIMATION. -C -C THE SUBROUTINE STATEMENT IS -C -C SUBROUTINE HYBRD(FCN,N,X,FVEC,XTOL,MAXFEV,ML,MU,EPSFCN, -C DIAG,MODE,FACTOR,NPRINT,INFO,NFEV,FJAC, -C LDFJAC,R,LR,QTF,WA1,WA2,WA3,WA4) -C -C WHERE -C -C FCN IS THE NAME OF THE USER-SUPPLIED SUBROUTINE WHICH -C CALCULATES THE FUNCTIONS. FCN MUST BE DECLARED -C IN AN EXTERNAL STATEMENT IN THE USER CALLING -C PROGRAM, AND SHOULD BE WRITTEN AS FOLLOWS. -C -C SUBROUTINE FCN(N,X,FVEC,IFLAG) -C INTEGER N,IFLAG -C DOUBLE PRECISION X(N),FVEC(N) -C ---------- -C CALCULATE THE FUNCTIONS AT X AND -C RETURN THIS VECTOR IN FVEC. -C --------- -C RETURN -C END -C -C THE VALUE OF IFLAG SHOULD NOT BE CHANGED BY FCN UNLESS -C THE USER WANTS TO TERMINATE EXECUTION OF HYBRD. -C IN THIS CASE SET IFLAG TO A NEGATIVE INTEGER. -C -C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER -C OF FUNCTIONS AND VARIABLES. -C -C X IS AN ARRAY OF LENGTH N. ON INPUT X MUST CONTAIN -C AN INITIAL ESTIMATE OF THE SOLUTION VECTOR. ON OUTPUT X -C CONTAINS THE FINAL ESTIMATE OF THE SOLUTION VECTOR. -C -C FVEC IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS -C THE FUNCTIONS EVALUATED AT THE OUTPUT X. -C -C XTOL IS A NONNEGATIVE INPUT VARIABLE. TERMINATION -C OCCURS WHEN THE RELATIVE ERROR BETWEEN TWO CONSECUTIVE -C ITERATES IS AT MOST XTOL. -C -C MAXFEV IS A POSITIVE INTEGER INPUT VARIABLE. TERMINATION -C OCCURS WHEN THE NUMBER OF CALLS TO FCN IS AT LEAST MAXFEV -C BY THE END OF AN ITERATION. -C -C ML IS A NONNEGATIVE INTEGER INPUT VARIABLE WHICH SPECIFIES -C THE NUMBER OF SUBDIAGONALS WITHIN THE BAND OF THE -C JACOBIAN MATRIX. IF THE JACOBIAN IS NOT BANDED, SET -C ML TO AT LEAST N - 1. -C -C MU IS A NONNEGATIVE INTEGER INPUT VARIABLE WHICH SPECIFIES -C THE NUMBER OF SUPERDIAGONALS WITHIN THE BAND OF THE -C JACOBIAN MATRIX. IF THE JACOBIAN IS NOT BANDED, SET -C MU TO AT LEAST N - 1. -C -C EPSFCN IS AN INPUT VARIABLE USED IN DETERMINING A SUITABLE -C STEP LENGTH FOR THE FORWARD-DIFFERENCE APPROXIMATION. THIS -C APPROXIMATION ASSUMES THAT THE RELATIVE ERRORS IN THE -C FUNCTIONS ARE OF THE ORDER OF EPSFCN. IF EPSFCN IS LESS -C THAN THE MACHINE PRECISION, IT IS ASSUMED THAT THE RELATIVE -C ERRORS IN THE FUNCTIONS ARE OF THE ORDER OF THE MACHINE -C PRECISION. -C -C DIAG IS AN ARRAY OF LENGTH N. IF MODE = 1 (SEE -C BELOW), DIAG IS INTERNALLY SET. IF MODE = 2, DIAG -C MUST CONTAIN POSITIVE ENTRIES THAT SERVE AS -C MULTIPLICATIVE SCALE FACTORS FOR THE VARIABLES. -C -C MODE IS AN INTEGER INPUT VARIABLE. IF MODE = 1, THE -C VARIABLES WILL BE SCALED INTERNALLY. IF MODE = 2, -C THE SCALING IS SPECIFIED BY THE INPUT DIAG. OTHER -C VALUES OF MODE ARE EQUIVALENT TO MODE = 1. -C -C FACTOR IS A POSITIVE INPUT VARIABLE USED IN DETERMINING THE -C INITIAL STEP BOUND. THIS BOUND IS SET TO THE PRODUCT OF -C FACTOR AND THE EUCLIDEAN NORM OF DIAG*X IF NONZERO, OR ELSE -C TO FACTOR ITSELF. IN MOST CASES FACTOR SHOULD LIE IN THE -C INTERVAL (.1,100.). 100. IS A GENERALLY RECOMMENDED VALUE. -C -C NPRINT IS AN INTEGER INPUT VARIABLE THAT ENABLES CONTROLLED -C PRINTING OF ITERATES IF IT IS POSITIVE. IN THIS CASE, -C FCN IS CALLED WITH IFLAG = 0 AT THE BEGINNING OF THE FIRST -C ITERATION AND EVERY NPRINT ITERATIONS THEREAFTER AND -C IMMEDIATELY PRIOR TO RETURN, WITH X AND FVEC AVAILABLE -C FOR PRINTING. IF NPRINT IS NOT POSITIVE, NO SPECIAL CALLS -C OF FCN WITH IFLAG = 0 ARE MADE. -C -C INFO IS AN INTEGER OUTPUT VARIABLE. IF THE USER HAS -C TERMINATED EXECUTION, INFO IS SET TO THE (NEGATIVE) -C VALUE OF IFLAG. SEE DESCRIPTION OF FCN. OTHERWISE, -C INFO IS SET AS FOLLOWS. -C -C INFO = 0 IMPROPER INPUT PARAMETERS. -C -C INFO = 1 RELATIVE ERROR BETWEEN TWO CONSECUTIVE ITERATES -C IS AT MOST XTOL. -C -C INFO = 2 NUMBER OF CALLS TO FCN HAS REACHED OR EXCEEDED -C MAXFEV. -C -C INFO = 3 XTOL IS TOO SMALL. NO FURTHER IMPROVEMENT IN -C THE APPROXIMATE SOLUTION X IS POSSIBLE. -C -C INFO = 4 ITERATION IS NOT MAKING GOOD PROGRESS, AS -C MEASURED BY THE IMPROVEMENT FROM THE LAST -C FIVE JACOBIAN EVALUATIONS. -C -C INFO = 5 ITERATION IS NOT MAKING GOOD PROGRESS, AS -C MEASURED BY THE IMPROVEMENT FROM THE LAST -C TEN ITERATIONS. -C -C NFEV IS AN INTEGER OUTPUT VARIABLE SET TO THE NUMBER OF -C CALLS TO FCN. -C -C FJAC IS AN OUTPUT N BY N ARRAY WHICH CONTAINS THE -C ORTHOGONAL MATRIX Q PRODUCED BY THE QR FACTORIZATION -C OF THE FINAL APPROXIMATE JACOBIAN. -C -C LDFJAC IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN N -C WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY FJAC. -C -C R IS AN OUTPUT ARRAY OF LENGTH LR WHICH CONTAINS THE -C UPPER TRIANGULAR MATRIX PRODUCED BY THE QR FACTORIZATION -C OF THE FINAL APPROXIMATE JACOBIAN, STORED ROWWISE. -C -C LR IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN -C (N*(N+1))/2. -C -C QTF IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS -C THE VECTOR (Q TRANSPOSE)*FVEC. -C -C WA1, WA2, WA3, AND WA4 ARE WORK ARRAYS OF LENGTH N. -C -C SUBPROGRAMS CALLED -C -C USER-SUPPLIED ...... FCN -C -C MINPACK-SUPPLIED ... DOGLEG,DPMPAR,ENORM,FDJAC1, -C QFORM,QRFAC,R1MPYQ,R1UPDT -C -C FORTRAN-SUPPLIED ... DABS,DMAX1,DMIN1,MIN0,MOD -C -C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. -C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE -C -C ********** - INTEGER I,IFLAG,ITER,J,JM1,L,MSUM,NCFAIL,NCSUC,NSLOW1,NSLOW2 - INTEGER IWA(1) - LOGICAL JEVAL,SING - DOUBLE PRECISION ACTRED,DELTA,EPSMCH,FNORM,FNORM1,ONE,PNORM, - * PRERED,P1,P5,P001,P0001,RATIO,SUM,TEMP,XNORM, - * ZERO - DOUBLE PRECISION DPMPAR,ENORM - DATA ONE,P1,P5,P001,P0001,ZERO - * /1.0D0,1.0D-1,5.0D-1,1.0D-3,1.0D-4,0.0D0/ -C -C EPSMCH IS THE MACHINE PRECISION. -C - EPSMCH = DPMPAR(1) -C - INFO = 0 - IFLAG = 0 - NFEV = 0 -C -C CHECK THE INPUT PARAMETERS FOR ERRORS. -C - IF (N .LE. 0 .OR. XTOL .LT. ZERO .OR. MAXFEV .LE. 0 - * .OR. ML .LT. 0 .OR. MU .LT. 0 .OR. FACTOR .LE. ZERO - * .OR. LDFJAC .LT. N .OR. LR .LT. (N*(N + 1))/2) GO TO 300 - IF (MODE .NE. 2) GO TO 20 - DO 10 J = 1, N - IF (DIAG(J) .LE. ZERO) GO TO 300 - 10 CONTINUE - 20 CONTINUE -C -C EVALUATE THE FUNCTION AT THE STARTING POINT -C AND CALCULATE ITS NORM. -C - IFLAG = 1 - CALL FCN(N,X,FVEC,IFLAG) - NFEV = 1 - IF (IFLAG .LT. 0) GO TO 300 - FNORM = ENORM(N,FVEC) -C -C DETERMINE THE NUMBER OF CALLS TO FCN NEEDED TO COMPUTE -C THE JACOBIAN MATRIX. -C - MSUM = MIN0(ML+MU+1,N) -C -C INITIALIZE ITERATION COUNTER AND MONITORS. -C - ITER = 1 - NCSUC = 0 - NCFAIL = 0 - NSLOW1 = 0 - NSLOW2 = 0 -C -C BEGINNING OF THE OUTER LOOP. -C - 30 CONTINUE - JEVAL = .TRUE. -C -C CALCULATE THE JACOBIAN MATRIX. -C - IFLAG = 2 - CALL FDJAC1(FCN,N,X,FVEC,FJAC,LDFJAC,IFLAG,ML,MU,EPSFCN,WA1, - * WA2) - NFEV = NFEV + MSUM - IF (IFLAG .LT. 0) GO TO 300 -C -C COMPUTE THE QR FACTORIZATION OF THE JACOBIAN. -C - CALL QRFAC(N,N,FJAC,LDFJAC,.FALSE.,IWA,1,WA1,WA2,WA3) -C -C ON THE FIRST ITERATION AND IF MODE IS 1, SCALE ACCORDING -C TO THE NORMS OF THE COLUMNS OF THE INITIAL JACOBIAN. -C - IF (ITER .NE. 1) GO TO 70 - IF (MODE .EQ. 2) GO TO 50 - DO 40 J = 1, N - DIAG(J) = WA2(J) - IF (WA2(J) .EQ. ZERO) DIAG(J) = ONE - 40 CONTINUE - 50 CONTINUE -C -C ON THE FIRST ITERATION, CALCULATE THE NORM OF THE SCALED X -C AND INITIALIZE THE STEP BOUND DELTA. -C - DO 60 J = 1, N - WA3(J) = DIAG(J)*X(J) - 60 CONTINUE - XNORM = ENORM(N,WA3) - DELTA = FACTOR*XNORM - IF (DELTA .EQ. ZERO) DELTA = FACTOR - 70 CONTINUE -C -C FORM (Q TRANSPOSE)*FVEC AND STORE IN QTF. -C - DO 80 I = 1, N - QTF(I) = FVEC(I) - 80 CONTINUE - DO 120 J = 1, N - IF (FJAC(J,J) .EQ. ZERO) GO TO 110 - SUM = ZERO - DO 90 I = J, N - SUM = SUM + FJAC(I,J)*QTF(I) - 90 CONTINUE - TEMP = -SUM/FJAC(J,J) - DO 100 I = J, N - QTF(I) = QTF(I) + FJAC(I,J)*TEMP - 100 CONTINUE - 110 CONTINUE - 120 CONTINUE -C -C COPY THE TRIANGULAR FACTOR OF THE QR FACTORIZATION INTO R. -C - SING = .FALSE. - DO 150 J = 1, N - L = J - JM1 = J - 1 - IF (JM1 .LT. 1) GO TO 140 - DO 130 I = 1, JM1 - R(L) = FJAC(I,J) - L = L + N - I - 130 CONTINUE - 140 CONTINUE - R(L) = WA1(J) - IF (WA1(J) .EQ. ZERO) SING = .TRUE. - 150 CONTINUE -C -C ACCUMULATE THE ORTHOGONAL FACTOR IN FJAC. -C - CALL QFORM(N,N,FJAC,LDFJAC,WA1) -C -C RESCALE IF NECESSARY. -C - IF (MODE .EQ. 2) GO TO 170 - DO 160 J = 1, N - DIAG(J) = DMAX1(DIAG(J),WA2(J)) - 160 CONTINUE - 170 CONTINUE -C -C BEGINNING OF THE INNER LOOP. -C - 180 CONTINUE -C -C IF REQUESTED, CALL FCN TO ENABLE PRINTING OF ITERATES. -C - IF (NPRINT .LE. 0) GO TO 190 - IFLAG = 0 - IF (MOD(ITER-1,NPRINT) .EQ. 0) CALL FCN(N,X,FVEC,IFLAG) - IF (IFLAG .LT. 0) GO TO 300 - 190 CONTINUE -C -C DETERMINE THE DIRECTION P. -C - CALL DOGLEG(N,R,LR,DIAG,QTF,DELTA,WA1,WA2,WA3) -C -C STORE THE DIRECTION P AND X + P. CALCULATE THE NORM OF P. -C - DO 200 J = 1, N - WA1(J) = -WA1(J) - WA2(J) = X(J) + WA1(J) - WA3(J) = DIAG(J)*WA1(J) - 200 CONTINUE - PNORM = ENORM(N,WA3) -C -C ON THE FIRST ITERATION, ADJUST THE INITIAL STEP BOUND. -C - IF (ITER .EQ. 1) DELTA = DMIN1(DELTA,PNORM) -C -C EVALUATE THE FUNCTION AT X + P AND CALCULATE ITS NORM. -C - IFLAG = 1 - CALL FCN(N,WA2,WA4,IFLAG) - NFEV = NFEV + 1 - IF (IFLAG .LT. 0) GO TO 300 - FNORM1 = ENORM(N,WA4) -C -C COMPUTE THE SCALED ACTUAL REDUCTION. -C - ACTRED = -ONE - IF (FNORM1 .LT. FNORM) ACTRED = ONE - (FNORM1/FNORM)**2 -C -C COMPUTE THE SCALED PREDICTED REDUCTION. -C - L = 1 - DO 220 I = 1, N - SUM = ZERO - DO 210 J = I, N - SUM = SUM + R(L)*WA1(J) - L = L + 1 - 210 CONTINUE - WA3(I) = QTF(I) + SUM - 220 CONTINUE - TEMP = ENORM(N,WA3) - PRERED = ZERO - IF (TEMP .LT. FNORM) PRERED = ONE - (TEMP/FNORM)**2 -C -C COMPUTE THE RATIO OF THE ACTUAL TO THE PREDICTED -C REDUCTION. -C - RATIO = ZERO - IF (PRERED .GT. ZERO) RATIO = ACTRED/PRERED -C -C UPDATE THE STEP BOUND. -C - IF (RATIO .GE. P1) GO TO 230 - NCSUC = 0 - NCFAIL = NCFAIL + 1 - DELTA = P5*DELTA - GO TO 240 - 230 CONTINUE - NCFAIL = 0 - NCSUC = NCSUC + 1 - IF (RATIO .GE. P5 .OR. NCSUC .GT. 1) - * DELTA = DMAX1(DELTA,PNORM/P5) - IF (DABS(RATIO-ONE) .LE. P1) DELTA = PNORM/P5 - 240 CONTINUE -C -C TEST FOR SUCCESSFUL ITERATION. -C - IF (RATIO .LT. P0001) GO TO 260 -C -C SUCCESSFUL ITERATION. UPDATE X, FVEC, AND THEIR NORMS. -C - DO 250 J = 1, N - X(J) = WA2(J) - WA2(J) = DIAG(J)*X(J) - FVEC(J) = WA4(J) - 250 CONTINUE - XNORM = ENORM(N,WA2) - FNORM = FNORM1 - ITER = ITER + 1 - 260 CONTINUE -C -C DETERMINE THE PROGRESS OF THE ITERATION. -C - NSLOW1 = NSLOW1 + 1 - IF (ACTRED .GE. P001) NSLOW1 = 0 - IF (JEVAL) NSLOW2 = NSLOW2 + 1 - IF (ACTRED .GE. P1) NSLOW2 = 0 -C -C TEST FOR CONVERGENCE. -C - IF (DELTA .LE. XTOL*XNORM .OR. FNORM .EQ. ZERO) INFO = 1 - IF (INFO .NE. 0) GO TO 300 -C -C TESTS FOR TERMINATION AND STRINGENT TOLERANCES. -C - IF (NFEV .GE. MAXFEV) INFO = 2 - IF (P1*DMAX1(P1*DELTA,PNORM) .LE. EPSMCH*XNORM) INFO = 3 - IF (NSLOW2 .EQ. 5) INFO = 4 - IF (NSLOW1 .EQ. 10) INFO = 5 - IF (INFO .NE. 0) GO TO 300 -C -C CRITERION FOR RECALCULATING JACOBIAN APPROXIMATION -C BY FORWARD DIFFERENCES. -C - IF (NCFAIL .EQ. 2) GO TO 290 -C -C CALCULATE THE RANK ONE MODIFICATION TO THE JACOBIAN -C AND UPDATE QTF IF NECESSARY. -C - DO 280 J = 1, N - SUM = ZERO - DO 270 I = 1, N - SUM = SUM + FJAC(I,J)*WA4(I) - 270 CONTINUE - WA2(J) = (SUM - WA3(J))/PNORM - WA1(J) = DIAG(J)*((DIAG(J)*WA1(J))/PNORM) - IF (RATIO .GE. P0001) QTF(J) = SUM - 280 CONTINUE -C -C COMPUTE THE QR FACTORIZATION OF THE UPDATED JACOBIAN. -C - CALL R1UPDT(N,N,R,LR,WA1,WA2,WA3,SING) - CALL R1MPYQ(N,N,FJAC,LDFJAC,WA2,WA3) - CALL R1MPYQ(1,N,QTF,1,WA2,WA3) -C -C END OF THE INNER LOOP. -C - JEVAL = .FALSE. - GO TO 180 - 290 CONTINUE -C -C END OF THE OUTER LOOP. -C - GO TO 30 - 300 CONTINUE -C -C TERMINATION, EITHER NORMAL OR USER IMPOSED. -C - IF (IFLAG .LT. 0) INFO = IFLAG - IFLAG = 0 - IF (NPRINT .GT. 0) CALL FCN(N,X,FVEC,IFLAG) - RETURN -C -C LAST CARD OF SUBROUTINE HYBRD. -C - END - SUBROUTINE HYBRD1(FCN,N,X,FVEC,TOL,INFO,WA,LWA) - INTEGER N,INFO,LWA - DOUBLE PRECISION TOL - DOUBLE PRECISION X(N),FVEC(N),WA(LWA) - EXTERNAL FCN -C ********** -C -C SUBROUTINE HYBRD1 -C -C THE PURPOSE OF HYBRD1 IS TO FIND A ZERO OF A SYSTEM OF -C N NONLINEAR FUNCTIONS IN N VARIABLES BY A MODIFICATION -C OF THE POWELL HYBRID METHOD. THIS IS DONE BY USING THE -C MORE GENERAL NONLINEAR EQUATION SOLVER HYBRD. THE USER -C MUST PROVIDE A SUBROUTINE WHICH CALCULATES THE FUNCTIONS. -C THE JACOBIAN IS THEN CALCULATED BY A FORWARD-DIFFERENCE -C APPROXIMATION. -C -C THE SUBROUTINE STATEMENT IS -C -C SUBROUTINE HYBRD1(FCN,N,X,FVEC,TOL,INFO,WA,LWA) -C -C WHERE -C -C FCN IS THE NAME OF THE USER-SUPPLIED SUBROUTINE WHICH -C CALCULATES THE FUNCTIONS. FCN MUST BE DECLARED -C IN AN EXTERNAL STATEMENT IN THE USER CALLING -C PROGRAM, AND SHOULD BE WRITTEN AS FOLLOWS. -C -C SUBROUTINE FCN(N,X,FVEC,IFLAG) -C INTEGER N,IFLAG -C DOUBLE PRECISION X(N),FVEC(N) -C ---------- -C CALCULATE THE FUNCTIONS AT X AND -C RETURN THIS VECTOR IN FVEC. -C --------- -C RETURN -C END -C -C THE VALUE OF IFLAG SHOULD NOT BE CHANGED BY FCN UNLESS -C THE USER WANTS TO TERMINATE EXECUTION OF HYBRD1. -C IN THIS CASE SET IFLAG TO A NEGATIVE INTEGER. -C -C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER -C OF FUNCTIONS AND VARIABLES. -C -C X IS AN ARRAY OF LENGTH N. ON INPUT X MUST CONTAIN -C AN INITIAL ESTIMATE OF THE SOLUTION VECTOR. ON OUTPUT X -C CONTAINS THE FINAL ESTIMATE OF THE SOLUTION VECTOR. -C -C FVEC IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS -C THE FUNCTIONS EVALUATED AT THE OUTPUT X. -C -C TOL IS A NONNEGATIVE INPUT VARIABLE. TERMINATION OCCURS -C WHEN THE ALGORITHM ESTIMATES THAT THE RELATIVE ERROR -C BETWEEN X AND THE SOLUTION IS AT MOST TOL. -C -C INFO IS AN INTEGER OUTPUT VARIABLE. IF THE USER HAS -C TERMINATED EXECUTION, INFO IS SET TO THE (NEGATIVE) -C VALUE OF IFLAG. SEE DESCRIPTION OF FCN. OTHERWISE, -C INFO IS SET AS FOLLOWS. -C -C INFO = 0 IMPROPER INPUT PARAMETERS. -C -C INFO = 1 ALGORITHM ESTIMATES THAT THE RELATIVE ERROR -C BETWEEN X AND THE SOLUTION IS AT MOST TOL. -C -C INFO = 2 NUMBER OF CALLS TO FCN HAS REACHED OR EXCEEDED -C 200*(N+1). -C -C INFO = 3 TOL IS TOO SMALL. NO FURTHER IMPROVEMENT IN -C THE APPROXIMATE SOLUTION X IS POSSIBLE. -C -C INFO = 4 ITERATION IS NOT MAKING GOOD PROGRESS. -C -C WA IS A WORK ARRAY OF LENGTH LWA. -C -C LWA IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN -C (N*(3*N+13))/2. -C -C SUBPROGRAMS CALLED -C -C USER-SUPPLIED ...... FCN -C -C MINPACK-SUPPLIED ... HYBRD -C -C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. -C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE -C -C ********** - INTEGER INDEX,J,LR,MAXFEV,ML,MODE,MU,NFEV,NPRINT - DOUBLE PRECISION EPSFCN,FACTOR,ONE,XTOL,ZERO - DATA FACTOR,ONE,ZERO /1.0D2,1.0D0,0.0D0/ - INFO = 0 -C -C CHECK THE INPUT PARAMETERS FOR ERRORS. -C - IF (N .LE. 0 .OR. TOL .LT. ZERO .OR. LWA .LT. (N*(3*N + 13))/2) - * GO TO 20 -C -C CALL HYBRD. -C - MAXFEV = 200*(N + 1) - XTOL = TOL - ML = N - 1 - MU = N - 1 - EPSFCN = ZERO - MODE = 2 - DO 10 J = 1, N - WA(J) = ONE - 10 CONTINUE - NPRINT = 0 - LR = (N*(N + 1))/2 - INDEX = 6*N + LR - CALL HYBRD(FCN,N,X,FVEC,XTOL,MAXFEV,ML,MU,EPSFCN,WA(1),MODE, - * FACTOR,NPRINT,INFO,NFEV,WA(INDEX+1),N,WA(6*N+1),LR, - * WA(N+1),WA(2*N+1),WA(3*N+1),WA(4*N+1),WA(5*N+1)) - IF (INFO .EQ. 5) INFO = 4 - 20 CONTINUE - RETURN -C -C LAST CARD OF SUBROUTINE HYBRD1. -C - END - SUBROUTINE HYBRJ(FCN,N,X,FVEC,FJAC,LDFJAC,XTOL,MAXFEV,DIAG,MODE, - * FACTOR,NPRINT,INFO,NFEV,NJEV,R,LR,QTF,WA1,WA2, - * WA3,WA4) - INTEGER N,LDFJAC,MAXFEV,MODE,NPRINT,INFO,NFEV,NJEV,LR - DOUBLE PRECISION XTOL,FACTOR - DOUBLE PRECISION X(N),FVEC(N),FJAC(LDFJAC,N),DIAG(N),R(LR), - * QTF(N),WA1(N),WA2(N),WA3(N),WA4(N) -C ********** -C -C SUBROUTINE HYBRJ -C -C THE PURPOSE OF HYBRJ IS TO FIND A ZERO OF A SYSTEM OF -C N NONLINEAR FUNCTIONS IN N VARIABLES BY A MODIFICATION -C OF THE POWELL HYBRID METHOD. THE USER MUST PROVIDE A -C SUBROUTINE WHICH CALCULATES THE FUNCTIONS AND THE JACOBIAN. -C -C THE SUBROUTINE STATEMENT IS -C -C SUBROUTINE HYBRJ(FCN,N,X,FVEC,FJAC,LDFJAC,XTOL,MAXFEV,DIAG, -C MODE,FACTOR,NPRINT,INFO,NFEV,NJEV,R,LR,QTF, -C WA1,WA2,WA3,WA4) -C -C WHERE -C -C FCN IS THE NAME OF THE USER-SUPPLIED SUBROUTINE WHICH -C CALCULATES THE FUNCTIONS AND THE JACOBIAN. FCN MUST -C BE DECLARED IN AN EXTERNAL STATEMENT IN THE USER -C CALLING PROGRAM, AND SHOULD BE WRITTEN AS FOLLOWS. -C -C SUBROUTINE FCN(N,X,FVEC,FJAC,LDFJAC,IFLAG) -C INTEGER N,LDFJAC,IFLAG -C DOUBLE PRECISION X(N),FVEC(N),FJAC(LDFJAC,N) -C ---------- -C IF IFLAG = 1 CALCULATE THE FUNCTIONS AT X AND -C RETURN THIS VECTOR IN FVEC. DO NOT ALTER FJAC. -C IF IFLAG = 2 CALCULATE THE JACOBIAN AT X AND -C RETURN THIS MATRIX IN FJAC. DO NOT ALTER FVEC. -C --------- -C RETURN -C END -C -C THE VALUE OF IFLAG SHOULD NOT BE CHANGED BY FCN UNLESS -C THE USER WANTS TO TERMINATE EXECUTION OF HYBRJ. -C IN THIS CASE SET IFLAG TO A NEGATIVE INTEGER. -C -C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER -C OF FUNCTIONS AND VARIABLES. -C -C X IS AN ARRAY OF LENGTH N. ON INPUT X MUST CONTAIN -C AN INITIAL ESTIMATE OF THE SOLUTION VECTOR. ON OUTPUT X -C CONTAINS THE FINAL ESTIMATE OF THE SOLUTION VECTOR. -C -C FVEC IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS -C THE FUNCTIONS EVALUATED AT THE OUTPUT X. -C -C FJAC IS AN OUTPUT N BY N ARRAY WHICH CONTAINS THE -C ORTHOGONAL MATRIX Q PRODUCED BY THE QR FACTORIZATION -C OF THE FINAL APPROXIMATE JACOBIAN. -C -C LDFJAC IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN N -C WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY FJAC. -C -C XTOL IS A NONNEGATIVE INPUT VARIABLE. TERMINATION -C OCCURS WHEN THE RELATIVE ERROR BETWEEN TWO CONSECUTIVE -C ITERATES IS AT MOST XTOL. -C -C MAXFEV IS A POSITIVE INTEGER INPUT VARIABLE. TERMINATION -C OCCURS WHEN THE NUMBER OF CALLS TO FCN WITH IFLAG = 1 -C HAS REACHED MAXFEV. -C -C DIAG IS AN ARRAY OF LENGTH N. IF MODE = 1 (SEE -C BELOW), DIAG IS INTERNALLY SET. IF MODE = 2, DIAG -C MUST CONTAIN POSITIVE ENTRIES THAT SERVE AS -C MULTIPLICATIVE SCALE FACTORS FOR THE VARIABLES. -C -C MODE IS AN INTEGER INPUT VARIABLE. IF MODE = 1, THE -C VARIABLES WILL BE SCALED INTERNALLY. IF MODE = 2, -C THE SCALING IS SPECIFIED BY THE INPUT DIAG. OTHER -C VALUES OF MODE ARE EQUIVALENT TO MODE = 1. -C -C FACTOR IS A POSITIVE INPUT VARIABLE USED IN DETERMINING THE -C INITIAL STEP BOUND. THIS BOUND IS SET TO THE PRODUCT OF -C FACTOR AND THE EUCLIDEAN NORM OF DIAG*X IF NONZERO, OR ELSE -C TO FACTOR ITSELF. IN MOST CASES FACTOR SHOULD LIE IN THE -C INTERVAL (.1,100.). 100. IS A GENERALLY RECOMMENDED VALUE. -C -C NPRINT IS AN INTEGER INPUT VARIABLE THAT ENABLES CONTROLLED -C PRINTING OF ITERATES IF IT IS POSITIVE. IN THIS CASE, -C FCN IS CALLED WITH IFLAG = 0 AT THE BEGINNING OF THE FIRST -C ITERATION AND EVERY NPRINT ITERATIONS THEREAFTER AND -C IMMEDIATELY PRIOR TO RETURN, WITH X AND FVEC AVAILABLE -C FOR PRINTING. FVEC AND FJAC SHOULD NOT BE ALTERED. -C IF NPRINT IS NOT POSITIVE, NO SPECIAL CALLS OF FCN -C WITH IFLAG = 0 ARE MADE. -C -C INFO IS AN INTEGER OUTPUT VARIABLE. IF THE USER HAS -C TERMINATED EXECUTION, INFO IS SET TO THE (NEGATIVE) -C VALUE OF IFLAG. SEE DESCRIPTION OF FCN. OTHERWISE, -C INFO IS SET AS FOLLOWS. -C -C INFO = 0 IMPROPER INPUT PARAMETERS. -C -C INFO = 1 RELATIVE ERROR BETWEEN TWO CONSECUTIVE ITERATES -C IS AT MOST XTOL. -C -C INFO = 2 NUMBER OF CALLS TO FCN WITH IFLAG = 1 HAS -C REACHED MAXFEV. -C -C INFO = 3 XTOL IS TOO SMALL. NO FURTHER IMPROVEMENT IN -C THE APPROXIMATE SOLUTION X IS POSSIBLE. -C -C INFO = 4 ITERATION IS NOT MAKING GOOD PROGRESS, AS -C MEASURED BY THE IMPROVEMENT FROM THE LAST -C FIVE JACOBIAN EVALUATIONS. -C -C INFO = 5 ITERATION IS NOT MAKING GOOD PROGRESS, AS -C MEASURED BY THE IMPROVEMENT FROM THE LAST -C TEN ITERATIONS. -C -C NFEV IS AN INTEGER OUTPUT VARIABLE SET TO THE NUMBER OF -C CALLS TO FCN WITH IFLAG = 1. -C -C NJEV IS AN INTEGER OUTPUT VARIABLE SET TO THE NUMBER OF -C CALLS TO FCN WITH IFLAG = 2. -C -C R IS AN OUTPUT ARRAY OF LENGTH LR WHICH CONTAINS THE -C UPPER TRIANGULAR MATRIX PRODUCED BY THE QR FACTORIZATION -C OF THE FINAL APPROXIMATE JACOBIAN, STORED ROWWISE. -C -C LR IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN -C (N*(N+1))/2. -C -C QTF IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS -C THE VECTOR (Q TRANSPOSE)*FVEC. -C -C WA1, WA2, WA3, AND WA4 ARE WORK ARRAYS OF LENGTH N. -C -C SUBPROGRAMS CALLED -C -C USER-SUPPLIED ...... FCN -C -C MINPACK-SUPPLIED ... DOGLEG,DPMPAR,ENORM, -C QFORM,QRFAC,R1MPYQ,R1UPDT -C -C FORTRAN-SUPPLIED ... DABS,DMAX1,DMIN1,MOD -C -C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. -C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE -C -C ********** - INTEGER I,IFLAG,ITER,J,JM1,L,NCFAIL,NCSUC,NSLOW1,NSLOW2 - INTEGER IWA(1) - LOGICAL JEVAL,SING - DOUBLE PRECISION ACTRED,DELTA,EPSMCH,FNORM,FNORM1,ONE,PNORM, - * PRERED,P1,P5,P001,P0001,RATIO,SUM,TEMP,XNORM, - * ZERO - DOUBLE PRECISION DPMPAR,ENORM - DATA ONE,P1,P5,P001,P0001,ZERO - * /1.0D0,1.0D-1,5.0D-1,1.0D-3,1.0D-4,0.0D0/ -C -C EPSMCH IS THE MACHINE PRECISION. -C - EPSMCH = DPMPAR(1) -C - INFO = 0 - IFLAG = 0 - NFEV = 0 - NJEV = 0 -C -C CHECK THE INPUT PARAMETERS FOR ERRORS. -C - IF (N .LE. 0 .OR. LDFJAC .LT. N .OR. XTOL .LT. ZERO - * .OR. MAXFEV .LE. 0 .OR. FACTOR .LE. ZERO - * .OR. LR .LT. (N*(N + 1))/2) GO TO 300 - IF (MODE .NE. 2) GO TO 20 - DO 10 J = 1, N - IF (DIAG(J) .LE. ZERO) GO TO 300 - 10 CONTINUE - 20 CONTINUE -C -C EVALUATE THE FUNCTION AT THE STARTING POINT -C AND CALCULATE ITS NORM. -C - IFLAG = 1 - CALL FCN(N,X,FVEC,FJAC,LDFJAC,IFLAG) - NFEV = 1 - IF (IFLAG .LT. 0) GO TO 300 - FNORM = ENORM(N,FVEC) -C -C INITIALIZE ITERATION COUNTER AND MONITORS. -C - ITER = 1 - NCSUC = 0 - NCFAIL = 0 - NSLOW1 = 0 - NSLOW2 = 0 -C -C BEGINNING OF THE OUTER LOOP. -C - 30 CONTINUE - JEVAL = .TRUE. -C -C CALCULATE THE JACOBIAN MATRIX. -C - IFLAG = 2 - CALL FCN(N,X,FVEC,FJAC,LDFJAC,IFLAG) - NJEV = NJEV + 1 - IF (IFLAG .LT. 0) GO TO 300 -C -C COMPUTE THE QR FACTORIZATION OF THE JACOBIAN. -C - CALL QRFAC(N,N,FJAC,LDFJAC,.FALSE.,IWA,1,WA1,WA2,WA3) -C -C ON THE FIRST ITERATION AND IF MODE IS 1, SCALE ACCORDING -C TO THE NORMS OF THE COLUMNS OF THE INITIAL JACOBIAN. -C - IF (ITER .NE. 1) GO TO 70 - IF (MODE .EQ. 2) GO TO 50 - DO 40 J = 1, N - DIAG(J) = WA2(J) - IF (WA2(J) .EQ. ZERO) DIAG(J) = ONE - 40 CONTINUE - 50 CONTINUE -C -C ON THE FIRST ITERATION, CALCULATE THE NORM OF THE SCALED X -C AND INITIALIZE THE STEP BOUND DELTA. -C - DO 60 J = 1, N - WA3(J) = DIAG(J)*X(J) - 60 CONTINUE - XNORM = ENORM(N,WA3) - DELTA = FACTOR*XNORM - IF (DELTA .EQ. ZERO) DELTA = FACTOR - 70 CONTINUE -C -C FORM (Q TRANSPOSE)*FVEC AND STORE IN QTF. -C - DO 80 I = 1, N - QTF(I) = FVEC(I) - 80 CONTINUE - DO 120 J = 1, N - IF (FJAC(J,J) .EQ. ZERO) GO TO 110 - SUM = ZERO - DO 90 I = J, N - SUM = SUM + FJAC(I,J)*QTF(I) - 90 CONTINUE - TEMP = -SUM/FJAC(J,J) - DO 100 I = J, N - QTF(I) = QTF(I) + FJAC(I,J)*TEMP - 100 CONTINUE - 110 CONTINUE - 120 CONTINUE -C -C COPY THE TRIANGULAR FACTOR OF THE QR FACTORIZATION INTO R. -C - SING = .FALSE. - DO 150 J = 1, N - L = J - JM1 = J - 1 - IF (JM1 .LT. 1) GO TO 140 - DO 130 I = 1, JM1 - R(L) = FJAC(I,J) - L = L + N - I - 130 CONTINUE - 140 CONTINUE - R(L) = WA1(J) - IF (WA1(J) .EQ. ZERO) SING = .TRUE. - 150 CONTINUE -C -C ACCUMULATE THE ORTHOGONAL FACTOR IN FJAC. -C - CALL QFORM(N,N,FJAC,LDFJAC,WA1) -C -C RESCALE IF NECESSARY. -C - IF (MODE .EQ. 2) GO TO 170 - DO 160 J = 1, N - DIAG(J) = DMAX1(DIAG(J),WA2(J)) - 160 CONTINUE - 170 CONTINUE -C -C BEGINNING OF THE INNER LOOP. -C - 180 CONTINUE -C -C IF REQUESTED, CALL FCN TO ENABLE PRINTING OF ITERATES. -C - IF (NPRINT .LE. 0) GO TO 190 - IFLAG = 0 - IF (MOD(ITER-1,NPRINT) .EQ. 0) - * CALL FCN(N,X,FVEC,FJAC,LDFJAC,IFLAG) - IF (IFLAG .LT. 0) GO TO 300 - 190 CONTINUE -C -C DETERMINE THE DIRECTION P. -C - CALL DOGLEG(N,R,LR,DIAG,QTF,DELTA,WA1,WA2,WA3) -C -C STORE THE DIRECTION P AND X + P. CALCULATE THE NORM OF P. -C - DO 200 J = 1, N - WA1(J) = -WA1(J) - WA2(J) = X(J) + WA1(J) - WA3(J) = DIAG(J)*WA1(J) - 200 CONTINUE - PNORM = ENORM(N,WA3) -C -C ON THE FIRST ITERATION, ADJUST THE INITIAL STEP BOUND. -C - IF (ITER .EQ. 1) DELTA = DMIN1(DELTA,PNORM) -C -C EVALUATE THE FUNCTION AT X + P AND CALCULATE ITS NORM. -C - IFLAG = 1 - CALL FCN(N,WA2,WA4,FJAC,LDFJAC,IFLAG) - NFEV = NFEV + 1 - IF (IFLAG .LT. 0) GO TO 300 - FNORM1 = ENORM(N,WA4) -C -C COMPUTE THE SCALED ACTUAL REDUCTION. -C - ACTRED = -ONE - IF (FNORM1 .LT. FNORM) ACTRED = ONE - (FNORM1/FNORM)**2 -C -C COMPUTE THE SCALED PREDICTED REDUCTION. -C - L = 1 - DO 220 I = 1, N - SUM = ZERO - DO 210 J = I, N - SUM = SUM + R(L)*WA1(J) - L = L + 1 - 210 CONTINUE - WA3(I) = QTF(I) + SUM - 220 CONTINUE - TEMP = ENORM(N,WA3) - PRERED = ZERO - IF (TEMP .LT. FNORM) PRERED = ONE - (TEMP/FNORM)**2 -C -C COMPUTE THE RATIO OF THE ACTUAL TO THE PREDICTED -C REDUCTION. -C - RATIO = ZERO - IF (PRERED .GT. ZERO) RATIO = ACTRED/PRERED -C -C UPDATE THE STEP BOUND. -C - IF (RATIO .GE. P1) GO TO 230 - NCSUC = 0 - NCFAIL = NCFAIL + 1 - DELTA = P5*DELTA - GO TO 240 - 230 CONTINUE - NCFAIL = 0 - NCSUC = NCSUC + 1 - IF (RATIO .GE. P5 .OR. NCSUC .GT. 1) - * DELTA = DMAX1(DELTA,PNORM/P5) - IF (DABS(RATIO-ONE) .LE. P1) DELTA = PNORM/P5 - 240 CONTINUE -C -C TEST FOR SUCCESSFUL ITERATION. -C - IF (RATIO .LT. P0001) GO TO 260 -C -C SUCCESSFUL ITERATION. UPDATE X, FVEC, AND THEIR NORMS. -C - DO 250 J = 1, N - X(J) = WA2(J) - WA2(J) = DIAG(J)*X(J) - FVEC(J) = WA4(J) - 250 CONTINUE - XNORM = ENORM(N,WA2) - FNORM = FNORM1 - ITER = ITER + 1 - 260 CONTINUE -C -C DETERMINE THE PROGRESS OF THE ITERATION. -C - NSLOW1 = NSLOW1 + 1 - IF (ACTRED .GE. P001) NSLOW1 = 0 - IF (JEVAL) NSLOW2 = NSLOW2 + 1 - IF (ACTRED .GE. P1) NSLOW2 = 0 -C -C TEST FOR CONVERGENCE. -C - IF (DELTA .LE. XTOL*XNORM .OR. FNORM .EQ. ZERO) INFO = 1 - IF (INFO .NE. 0) GO TO 300 -C -C TESTS FOR TERMINATION AND STRINGENT TOLERANCES. -C - IF (NFEV .GE. MAXFEV) INFO = 2 - IF (P1*DMAX1(P1*DELTA,PNORM) .LE. EPSMCH*XNORM) INFO = 3 - IF (NSLOW2 .EQ. 5) INFO = 4 - IF (NSLOW1 .EQ. 10) INFO = 5 - IF (INFO .NE. 0) GO TO 300 -C -C CRITERION FOR RECALCULATING JACOBIAN. -C - IF (NCFAIL .EQ. 2) GO TO 290 -C -C CALCULATE THE RANK ONE MODIFICATION TO THE JACOBIAN -C AND UPDATE QTF IF NECESSARY. -C - DO 280 J = 1, N - SUM = ZERO - DO 270 I = 1, N - SUM = SUM + FJAC(I,J)*WA4(I) - 270 CONTINUE - WA2(J) = (SUM - WA3(J))/PNORM - WA1(J) = DIAG(J)*((DIAG(J)*WA1(J))/PNORM) - IF (RATIO .GE. P0001) QTF(J) = SUM - 280 CONTINUE -C -C COMPUTE THE QR FACTORIZATION OF THE UPDATED JACOBIAN. -C - CALL R1UPDT(N,N,R,LR,WA1,WA2,WA3,SING) - CALL R1MPYQ(N,N,FJAC,LDFJAC,WA2,WA3) - CALL R1MPYQ(1,N,QTF,1,WA2,WA3) -C -C END OF THE INNER LOOP. -C - JEVAL = .FALSE. - GO TO 180 - 290 CONTINUE -C -C END OF THE OUTER LOOP. -C - GO TO 30 - 300 CONTINUE -C -C TERMINATION, EITHER NORMAL OR USER IMPOSED. -C - IF (IFLAG .LT. 0) INFO = IFLAG - IFLAG = 0 - IF (NPRINT .GT. 0) CALL FCN(N,X,FVEC,FJAC,LDFJAC,IFLAG) - RETURN -C -C LAST CARD OF SUBROUTINE HYBRJ. -C - END - SUBROUTINE HYBRJ1(FCN,N,X,FVEC,FJAC,LDFJAC,TOL,INFO,WA,LWA) - INTEGER N,LDFJAC,INFO,LWA - DOUBLE PRECISION TOL - DOUBLE PRECISION X(N),FVEC(N),FJAC(LDFJAC,N),WA(LWA) - EXTERNAL FCN -C ********** -C -C SUBROUTINE HYBRJ1 -C -C THE PURPOSE OF HYBRJ1 IS TO FIND A ZERO OF A SYSTEM OF -C N NONLINEAR FUNCTIONS IN N VARIABLES BY A MODIFICATION -C OF THE POWELL HYBRID METHOD. THIS IS DONE BY USING THE -C MORE GENERAL NONLINEAR EQUATION SOLVER HYBRJ. THE USER -C MUST PROVIDE A SUBROUTINE WHICH CALCULATES THE FUNCTIONS -C AND THE JACOBIAN. -C -C THE SUBROUTINE STATEMENT IS -C -C SUBROUTINE HYBRJ1(FCN,N,X,FVEC,FJAC,LDFJAC,TOL,INFO,WA,LWA) -C -C WHERE -C -C FCN IS THE NAME OF THE USER-SUPPLIED SUBROUTINE WHICH -C CALCULATES THE FUNCTIONS AND THE JACOBIAN. FCN MUST -C BE DECLARED IN AN EXTERNAL STATEMENT IN THE USER -C CALLING PROGRAM, AND SHOULD BE WRITTEN AS FOLLOWS. -C -C SUBROUTINE FCN(N,X,FVEC,FJAC,LDFJAC,IFLAG) -C INTEGER N,LDFJAC,IFLAG -C DOUBLE PRECISION X(N),FVEC(N),FJAC(LDFJAC,N) -C ---------- -C IF IFLAG = 1 CALCULATE THE FUNCTIONS AT X AND -C RETURN THIS VECTOR IN FVEC. DO NOT ALTER FJAC. -C IF IFLAG = 2 CALCULATE THE JACOBIAN AT X AND -C RETURN THIS MATRIX IN FJAC. DO NOT ALTER FVEC. -C --------- -C RETURN -C END -C -C THE VALUE OF IFLAG SHOULD NOT BE CHANGED BY FCN UNLESS -C THE USER WANTS TO TERMINATE EXECUTION OF HYBRJ1. -C IN THIS CASE SET IFLAG TO A NEGATIVE INTEGER. -C -C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER -C OF FUNCTIONS AND VARIABLES. -C -C X IS AN ARRAY OF LENGTH N. ON INPUT X MUST CONTAIN -C AN INITIAL ESTIMATE OF THE SOLUTION VECTOR. ON OUTPUT X -C CONTAINS THE FINAL ESTIMATE OF THE SOLUTION VECTOR. -C -C FVEC IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS -C THE FUNCTIONS EVALUATED AT THE OUTPUT X. -C -C FJAC IS AN OUTPUT N BY N ARRAY WHICH CONTAINS THE -C ORTHOGONAL MATRIX Q PRODUCED BY THE QR FACTORIZATION -C OF THE FINAL APPROXIMATE JACOBIAN. -C -C LDFJAC IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN N -C WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY FJAC. -C -C TOL IS A NONNEGATIVE INPUT VARIABLE. TERMINATION OCCURS -C WHEN THE ALGORITHM ESTIMATES THAT THE RELATIVE ERROR -C BETWEEN X AND THE SOLUTION IS AT MOST TOL. -C -C INFO IS AN INTEGER OUTPUT VARIABLE. IF THE USER HAS -C TERMINATED EXECUTION, INFO IS SET TO THE (NEGATIVE) -C VALUE OF IFLAG. SEE DESCRIPTION OF FCN. OTHERWISE, -C INFO IS SET AS FOLLOWS. -C -C INFO = 0 IMPROPER INPUT PARAMETERS. -C -C INFO = 1 ALGORITHM ESTIMATES THAT THE RELATIVE ERROR -C BETWEEN X AND THE SOLUTION IS AT MOST TOL. -C -C INFO = 2 NUMBER OF CALLS TO FCN WITH IFLAG = 1 HAS -C REACHED 100*(N+1). -C -C INFO = 3 TOL IS TOO SMALL. NO FURTHER IMPROVEMENT IN -C THE APPROXIMATE SOLUTION X IS POSSIBLE. -C -C INFO = 4 ITERATION IS NOT MAKING GOOD PROGRESS. -C -C WA IS A WORK ARRAY OF LENGTH LWA. -C -C LWA IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN -C (N*(N+13))/2. -C -C SUBPROGRAMS CALLED -C -C USER-SUPPLIED ...... FCN -C -C MINPACK-SUPPLIED ... HYBRJ -C -C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. -C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE -C -C ********** - INTEGER J,LR,MAXFEV,MODE,NFEV,NJEV,NPRINT - DOUBLE PRECISION FACTOR,ONE,XTOL,ZERO - DATA FACTOR,ONE,ZERO /1.0D2,1.0D0,0.0D0/ - INFO = 0 -C -C CHECK THE INPUT PARAMETERS FOR ERRORS. -C - IF (N .LE. 0 .OR. LDFJAC .LT. N .OR. TOL .LT. ZERO - * .OR. LWA .LT. (N*(N + 13))/2) GO TO 20 -C -C CALL HYBRJ. -C - MAXFEV = 100*(N + 1) - XTOL = TOL - MODE = 2 - DO 10 J = 1, N - WA(J) = ONE - 10 CONTINUE - NPRINT = 0 - LR = (N*(N + 1))/2 - CALL HYBRJ(FCN,N,X,FVEC,FJAC,LDFJAC,XTOL,MAXFEV,WA(1),MODE, - * FACTOR,NPRINT,INFO,NFEV,NJEV,WA(6*N+1),LR,WA(N+1), - * WA(2*N+1),WA(3*N+1),WA(4*N+1),WA(5*N+1)) - IF (INFO .EQ. 5) INFO = 4 - 20 CONTINUE - RETURN -C -C LAST CARD OF SUBROUTINE HYBRJ1. -C - END - SUBROUTINE LMDER(FCN,M,N,X,FVEC,FJAC,LDFJAC,FTOL,XTOL,GTOL, - * MAXFEV,DIAG,MODE,FACTOR,NPRINT,INFO,NFEV,NJEV, - * IPVT,QTF,WA1,WA2,WA3,WA4) - INTEGER M,N,LDFJAC,MAXFEV,MODE,NPRINT,INFO,NFEV,NJEV - INTEGER IPVT(N) - DOUBLE PRECISION FTOL,XTOL,GTOL,FACTOR - DOUBLE PRECISION X(N),FVEC(M),FJAC(LDFJAC,N),DIAG(N),QTF(N), - * WA1(N),WA2(N),WA3(N),WA4(M) -C ********** -C -C SUBROUTINE LMDER -C -C THE PURPOSE OF LMDER IS TO MINIMIZE THE SUM OF THE SQUARES OF -C M NONLINEAR FUNCTIONS IN N VARIABLES BY A MODIFICATION OF -C THE LEVENBERG-MARQUARDT ALGORITHM. THE USER MUST PROVIDE A -C SUBROUTINE WHICH CALCULATES THE FUNCTIONS AND THE JACOBIAN. -C -C THE SUBROUTINE STATEMENT IS -C -C SUBROUTINE LMDER(FCN,M,N,X,FVEC,FJAC,LDFJAC,FTOL,XTOL,GTOL, -C MAXFEV,DIAG,MODE,FACTOR,NPRINT,INFO,NFEV, -C NJEV,IPVT,QTF,WA1,WA2,WA3,WA4) -C -C WHERE -C -C FCN IS THE NAME OF THE USER-SUPPLIED SUBROUTINE WHICH -C CALCULATES THE FUNCTIONS AND THE JACOBIAN. FCN MUST -C BE DECLARED IN AN EXTERNAL STATEMENT IN THE USER -C CALLING PROGRAM, AND SHOULD BE WRITTEN AS FOLLOWS. -C -C SUBROUTINE FCN(M,N,X,FVEC,FJAC,LDFJAC,IFLAG) -C INTEGER M,N,LDFJAC,IFLAG -C DOUBLE PRECISION X(N),FVEC(M),FJAC(LDFJAC,N) -C ---------- -C IF IFLAG = 1 CALCULATE THE FUNCTIONS AT X AND -C RETURN THIS VECTOR IN FVEC. DO NOT ALTER FJAC. -C IF IFLAG = 2 CALCULATE THE JACOBIAN AT X AND -C RETURN THIS MATRIX IN FJAC. DO NOT ALTER FVEC. -C ---------- -C RETURN -C END -C -C THE VALUE OF IFLAG SHOULD NOT BE CHANGED BY FCN UNLESS -C THE USER WANTS TO TERMINATE EXECUTION OF LMDER. -C IN THIS CASE SET IFLAG TO A NEGATIVE INTEGER. -C -C M IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER -C OF FUNCTIONS. -C -C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER -C OF VARIABLES. N MUST NOT EXCEED M. -C -C X IS AN ARRAY OF LENGTH N. ON INPUT X MUST CONTAIN -C AN INITIAL ESTIMATE OF THE SOLUTION VECTOR. ON OUTPUT X -C CONTAINS THE FINAL ESTIMATE OF THE SOLUTION VECTOR. -C -C FVEC IS AN OUTPUT ARRAY OF LENGTH M WHICH CONTAINS -C THE FUNCTIONS EVALUATED AT THE OUTPUT X. -C -C FJAC IS AN OUTPUT M BY N ARRAY. THE UPPER N BY N SUBMATRIX -C OF FJAC CONTAINS AN UPPER TRIANGULAR MATRIX R WITH -C DIAGONAL ELEMENTS OF NONINCREASING MAGNITUDE SUCH THAT -C -C T T T -C P *(JAC *JAC)*P = R *R, -C -C WHERE P IS A PERMUTATION MATRIX AND JAC IS THE FINAL -C CALCULATED JACOBIAN. COLUMN J OF P IS COLUMN IPVT(J) -C (SEE BELOW) OF THE IDENTITY MATRIX. THE LOWER TRAPEZOIDAL -C PART OF FJAC CONTAINS INFORMATION GENERATED DURING -C THE COMPUTATION OF R. -C -C LDFJAC IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN M -C WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY FJAC. -C -C FTOL IS A NONNEGATIVE INPUT VARIABLE. TERMINATION -C OCCURS WHEN BOTH THE ACTUAL AND PREDICTED RELATIVE -C REDUCTIONS IN THE SUM OF SQUARES ARE AT MOST FTOL. -C THEREFORE, FTOL MEASURES THE RELATIVE ERROR DESIRED -C IN THE SUM OF SQUARES. -C -C XTOL IS A NONNEGATIVE INPUT VARIABLE. TERMINATION -C OCCURS WHEN THE RELATIVE ERROR BETWEEN TWO CONSECUTIVE -C ITERATES IS AT MOST XTOL. THEREFORE, XTOL MEASURES THE -C RELATIVE ERROR DESIRED IN THE APPROXIMATE SOLUTION. -C -C GTOL IS A NONNEGATIVE INPUT VARIABLE. TERMINATION -C OCCURS WHEN THE COSINE OF THE ANGLE BETWEEN FVEC AND -C ANY COLUMN OF THE JACOBIAN IS AT MOST GTOL IN ABSOLUTE -C VALUE. THEREFORE, GTOL MEASURES THE ORTHOGONALITY -C DESIRED BETWEEN THE FUNCTION VECTOR AND THE COLUMNS -C OF THE JACOBIAN. -C -C MAXFEV IS A POSITIVE INTEGER INPUT VARIABLE. TERMINATION -C OCCURS WHEN THE NUMBER OF CALLS TO FCN WITH IFLAG = 1 -C HAS REACHED MAXFEV. -C -C DIAG IS AN ARRAY OF LENGTH N. IF MODE = 1 (SEE -C BELOW), DIAG IS INTERNALLY SET. IF MODE = 2, DIAG -C MUST CONTAIN POSITIVE ENTRIES THAT SERVE AS -C MULTIPLICATIVE SCALE FACTORS FOR THE VARIABLES. -C -C MODE IS AN INTEGER INPUT VARIABLE. IF MODE = 1, THE -C VARIABLES WILL BE SCALED INTERNALLY. IF MODE = 2, -C THE SCALING IS SPECIFIED BY THE INPUT DIAG. OTHER -C VALUES OF MODE ARE EQUIVALENT TO MODE = 1. -C -C FACTOR IS A POSITIVE INPUT VARIABLE USED IN DETERMINING THE -C INITIAL STEP BOUND. THIS BOUND IS SET TO THE PRODUCT OF -C FACTOR AND THE EUCLIDEAN NORM OF DIAG*X IF NONZERO, OR ELSE -C TO FACTOR ITSELF. IN MOST CASES FACTOR SHOULD LIE IN THE -C INTERVAL (.1,100.).100. IS A GENERALLY RECOMMENDED VALUE. -C -C NPRINT IS AN INTEGER INPUT VARIABLE THAT ENABLES CONTROLLED -C PRINTING OF ITERATES IF IT IS POSITIVE. IN THIS CASE, -C FCN IS CALLED WITH IFLAG = 0 AT THE BEGINNING OF THE FIRST -C ITERATION AND EVERY NPRINT ITERATIONS THEREAFTER AND -C IMMEDIATELY PRIOR TO RETURN, WITH X, FVEC, AND FJAC -C AVAILABLE FOR PRINTING. FVEC AND FJAC SHOULD NOT BE -C ALTERED. IF NPRINT IS NOT POSITIVE, NO SPECIAL CALLS -C OF FCN WITH IFLAG = 0 ARE MADE. -C -C INFO IS AN INTEGER OUTPUT VARIABLE. IF THE USER HAS -C TERMINATED EXECUTION, INFO IS SET TO THE (NEGATIVE) -C VALUE OF IFLAG. SEE DESCRIPTION OF FCN. OTHERWISE, -C INFO IS SET AS FOLLOWS. -C -C INFO = 0 IMPROPER INPUT PARAMETERS. -C -C INFO = 1 BOTH ACTUAL AND PREDICTED RELATIVE REDUCTIONS -C IN THE SUM OF SQUARES ARE AT MOST FTOL. -C -C INFO = 2 RELATIVE ERROR BETWEEN TWO CONSECUTIVE ITERATES -C IS AT MOST XTOL. -C -C INFO = 3 CONDITIONS FOR INFO = 1 AND INFO = 2 BOTH HOLD. -C -C INFO = 4 THE COSINE OF THE ANGLE BETWEEN FVEC AND ANY -C COLUMN OF THE JACOBIAN IS AT MOST GTOL IN -C ABSOLUTE VALUE. -C -C INFO = 5 NUMBER OF CALLS TO FCN WITH IFLAG = 1 HAS -C REACHED MAXFEV. -C -C INFO = 6 FTOL IS TOO SMALL. NO FURTHER REDUCTION IN -C THE SUM OF SQUARES IS POSSIBLE. -C -C INFO = 7 XTOL IS TOO SMALL. NO FURTHER IMPROVEMENT IN -C THE APPROXIMATE SOLUTION X IS POSSIBLE. -C -C INFO = 8 GTOL IS TOO SMALL. FVEC IS ORTHOGONAL TO THE -C COLUMNS OF THE JACOBIAN TO MACHINE PRECISION. -C -C NFEV IS AN INTEGER OUTPUT VARIABLE SET TO THE NUMBER OF -C CALLS TO FCN WITH IFLAG = 1. -C -C NJEV IS AN INTEGER OUTPUT VARIABLE SET TO THE NUMBER OF -C CALLS TO FCN WITH IFLAG = 2. -C -C IPVT IS AN INTEGER OUTPUT ARRAY OF LENGTH N. IPVT -C DEFINES A PERMUTATION MATRIX P SUCH THAT JAC*P = Q*R, -C WHERE JAC IS THE FINAL CALCULATED JACOBIAN, Q IS -C ORTHOGONAL (NOT STORED), AND R IS UPPER TRIANGULAR -C WITH DIAGONAL ELEMENTS OF NONINCREASING MAGNITUDE. -C COLUMN J OF P IS COLUMN IPVT(J) OF THE IDENTITY MATRIX. -C -C QTF IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS -C THE FIRST N ELEMENTS OF THE VECTOR (Q TRANSPOSE)*FVEC. -C -C WA1, WA2, AND WA3 ARE WORK ARRAYS OF LENGTH N. -C -C WA4 IS A WORK ARRAY OF LENGTH M. -C -C SUBPROGRAMS CALLED -C -C USER-SUPPLIED ...... FCN -C -C MINPACK-SUPPLIED ... DPMPAR,ENORM,LMPAR,QRFAC -C -C FORTRAN-SUPPLIED ... DABS,DMAX1,DMIN1,DSQRT,MOD -C -C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. -C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE -C -C ********** - INTEGER I,IFLAG,ITER,J,L - DOUBLE PRECISION ACTRED,DELTA,DIRDER,EPSMCH,FNORM,FNORM1,GNORM, - * ONE,PAR,PNORM,PRERED,P1,P5,P25,P75,P0001,RATIO, - * SUM,TEMP,TEMP1,TEMP2,XNORM,ZERO - DOUBLE PRECISION DPMPAR,ENORM - DATA ONE,P1,P5,P25,P75,P0001,ZERO - * /1.0D0,1.0D-1,5.0D-1,2.5D-1,7.5D-1,1.0D-4,0.0D0/ -C -C EPSMCH IS THE MACHINE PRECISION. -C - EPSMCH = DPMPAR(1) -C - INFO = 0 - IFLAG = 0 - NFEV = 0 - NJEV = 0 -C -C CHECK THE INPUT PARAMETERS FOR ERRORS. -C - IF (N .LE. 0 .OR. M .LT. N .OR. LDFJAC .LT. M - * .OR. FTOL .LT. ZERO .OR. XTOL .LT. ZERO .OR. GTOL .LT. ZERO - * .OR. MAXFEV .LE. 0 .OR. FACTOR .LE. ZERO) GO TO 300 - IF (MODE .NE. 2) GO TO 20 - DO 10 J = 1, N - IF (DIAG(J) .LE. ZERO) GO TO 300 - 10 CONTINUE - 20 CONTINUE -C -C EVALUATE THE FUNCTION AT THE STARTING POINT -C AND CALCULATE ITS NORM. -C - IFLAG = 1 - CALL FCN(M,N,X,FVEC,FJAC,LDFJAC,IFLAG) - NFEV = 1 - IF (IFLAG .LT. 0) GO TO 300 - FNORM = ENORM(M,FVEC) -C -C INITIALIZE LEVENBERG-MARQUARDT PARAMETER AND ITERATION COUNTER. -C - PAR = ZERO - ITER = 1 -C -C BEGINNING OF THE OUTER LOOP. -C - 30 CONTINUE -C -C CALCULATE THE JACOBIAN MATRIX. -C - IFLAG = 2 - CALL FCN(M,N,X,FVEC,FJAC,LDFJAC,IFLAG) - NJEV = NJEV + 1 - IF (IFLAG .LT. 0) GO TO 300 -C -C IF REQUESTED, CALL FCN TO ENABLE PRINTING OF ITERATES. -C - IF (NPRINT .LE. 0) GO TO 40 - IFLAG = 0 - IF (MOD(ITER-1,NPRINT) .EQ. 0) - * CALL FCN(M,N,X,FVEC,FJAC,LDFJAC,IFLAG) - IF (IFLAG .LT. 0) GO TO 300 - 40 CONTINUE -C -C COMPUTE THE QR FACTORIZATION OF THE JACOBIAN. -C - CALL QRFAC(M,N,FJAC,LDFJAC,.TRUE.,IPVT,N,WA1,WA2,WA3) -C -C ON THE FIRST ITERATION AND IF MODE IS 1, SCALE ACCORDING -C TO THE NORMS OF THE COLUMNS OF THE INITIAL JACOBIAN. -C - IF (ITER .NE. 1) GO TO 80 - IF (MODE .EQ. 2) GO TO 60 - DO 50 J = 1, N - DIAG(J) = WA2(J) - IF (WA2(J) .EQ. ZERO) DIAG(J) = ONE - 50 CONTINUE - 60 CONTINUE -C -C ON THE FIRST ITERATION, CALCULATE THE NORM OF THE SCALED X -C AND INITIALIZE THE STEP BOUND DELTA. -C - DO 70 J = 1, N - WA3(J) = DIAG(J)*X(J) - 70 CONTINUE - XNORM = ENORM(N,WA3) - DELTA = FACTOR*XNORM - IF (DELTA .EQ. ZERO) DELTA = FACTOR - 80 CONTINUE -C -C FORM (Q TRANSPOSE)*FVEC AND STORE THE FIRST N COMPONENTS IN -C QTF. -C - DO 90 I = 1, M - WA4(I) = FVEC(I) - 90 CONTINUE - DO 130 J = 1, N - IF (FJAC(J,J) .EQ. ZERO) GO TO 120 - SUM = ZERO - DO 100 I = J, M - SUM = SUM + FJAC(I,J)*WA4(I) - 100 CONTINUE - TEMP = -SUM/FJAC(J,J) - DO 110 I = J, M - WA4(I) = WA4(I) + FJAC(I,J)*TEMP - 110 CONTINUE - 120 CONTINUE - FJAC(J,J) = WA1(J) - QTF(J) = WA4(J) - 130 CONTINUE -C -C COMPUTE THE NORM OF THE SCALED GRADIENT. -C - GNORM = ZERO - IF (FNORM .EQ. ZERO) GO TO 170 - DO 160 J = 1, N - L = IPVT(J) - IF (WA2(L) .EQ. ZERO) GO TO 150 - SUM = ZERO - DO 140 I = 1, J - SUM = SUM + FJAC(I,J)*(QTF(I)/FNORM) - 140 CONTINUE - GNORM = DMAX1(GNORM,DABS(SUM/WA2(L))) - 150 CONTINUE - 160 CONTINUE - 170 CONTINUE -C -C TEST FOR CONVERGENCE OF THE GRADIENT NORM. -C - IF (GNORM .LE. GTOL) INFO = 4 - IF (INFO .NE. 0) GO TO 300 -C -C RESCALE IF NECESSARY. -C - IF (MODE .EQ. 2) GO TO 190 - DO 180 J = 1, N - DIAG(J) = DMAX1(DIAG(J),WA2(J)) - 180 CONTINUE - 190 CONTINUE -C -C BEGINNING OF THE INNER LOOP. -C - 200 CONTINUE -C -C DETERMINE THE LEVENBERG-MARQUARDT PARAMETER. -C - CALL LMPAR(N,FJAC,LDFJAC,IPVT,DIAG,QTF,DELTA,PAR,WA1,WA2, - * WA3,WA4) -C -C STORE THE DIRECTION P AND X + P. CALCULATE THE NORM OF P. -C - DO 210 J = 1, N - WA1(J) = -WA1(J) - WA2(J) = X(J) + WA1(J) - WA3(J) = DIAG(J)*WA1(J) - 210 CONTINUE - PNORM = ENORM(N,WA3) -C -C ON THE FIRST ITERATION, ADJUST THE INITIAL STEP BOUND. -C - IF (ITER .EQ. 1) DELTA = DMIN1(DELTA,PNORM) -C -C EVALUATE THE FUNCTION AT X + P AND CALCULATE ITS NORM. -C - IFLAG = 1 - CALL FCN(M,N,WA2,WA4,FJAC,LDFJAC,IFLAG) - NFEV = NFEV + 1 - IF (IFLAG .LT. 0) GO TO 300 - FNORM1 = ENORM(M,WA4) -C -C COMPUTE THE SCALED ACTUAL REDUCTION. -C - ACTRED = -ONE - IF (P1*FNORM1 .LT. FNORM) ACTRED = ONE - (FNORM1/FNORM)**2 -C -C COMPUTE THE SCALED PREDICTED REDUCTION AND -C THE SCALED DIRECTIONAL DERIVATIVE. -C - DO 230 J = 1, N - WA3(J) = ZERO - L = IPVT(J) - TEMP = WA1(L) - DO 220 I = 1, J - WA3(I) = WA3(I) + FJAC(I,J)*TEMP - 220 CONTINUE - 230 CONTINUE - TEMP1 = ENORM(N,WA3)/FNORM - TEMP2 = (DSQRT(PAR)*PNORM)/FNORM - PRERED = TEMP1**2 + TEMP2**2/P5 - DIRDER = -(TEMP1**2 + TEMP2**2) -C -C COMPUTE THE RATIO OF THE ACTUAL TO THE PREDICTED -C REDUCTION. -C - RATIO = ZERO - IF (PRERED .NE. ZERO) RATIO = ACTRED/PRERED -C -C UPDATE THE STEP BOUND. -C - IF (RATIO .GT. P25) GO TO 240 - IF (ACTRED .GE. ZERO) TEMP = P5 - IF (ACTRED .LT. ZERO) - * TEMP = P5*DIRDER/(DIRDER + P5*ACTRED) - IF (P1*FNORM1 .GE. FNORM .OR. TEMP .LT. P1) TEMP = P1 - DELTA = TEMP*DMIN1(DELTA,PNORM/P1) - PAR = PAR/TEMP - GO TO 260 - 240 CONTINUE - IF (PAR .NE. ZERO .AND. RATIO .LT. P75) GO TO 250 - DELTA = PNORM/P5 - PAR = P5*PAR - 250 CONTINUE - 260 CONTINUE -C -C TEST FOR SUCCESSFUL ITERATION. -C - IF (RATIO .LT. P0001) GO TO 290 -C -C SUCCESSFUL ITERATION. UPDATE X, FVEC, AND THEIR NORMS. -C - DO 270 J = 1, N - X(J) = WA2(J) - WA2(J) = DIAG(J)*X(J) - 270 CONTINUE - DO 280 I = 1, M - FVEC(I) = WA4(I) - 280 CONTINUE - XNORM = ENORM(N,WA2) - FNORM = FNORM1 - ITER = ITER + 1 - 290 CONTINUE -C -C TESTS FOR CONVERGENCE. -C - IF (DABS(ACTRED) .LE. FTOL .AND. PRERED .LE. FTOL - * .AND. P5*RATIO .LE. ONE) INFO = 1 - IF (DELTA .LE. XTOL*XNORM) INFO = 2 - IF (DABS(ACTRED) .LE. FTOL .AND. PRERED .LE. FTOL - * .AND. P5*RATIO .LE. ONE .AND. INFO .EQ. 2) INFO = 3 - IF (INFO .NE. 0) GO TO 300 -C -C TESTS FOR TERMINATION AND STRINGENT TOLERANCES. -C - IF (NFEV .GE. MAXFEV) INFO = 5 - IF (DABS(ACTRED) .LE. EPSMCH .AND. PRERED .LE. EPSMCH - * .AND. P5*RATIO .LE. ONE) INFO = 6 - IF (DELTA .LE. EPSMCH*XNORM) INFO = 7 - IF (GNORM .LE. EPSMCH) INFO = 8 - IF (INFO .NE. 0) GO TO 300 -C -C END OF THE INNER LOOP. REPEAT IF ITERATION UNSUCCESSFUL. -C - IF (RATIO .LT. P0001) GO TO 200 -C -C END OF THE OUTER LOOP. -C - GO TO 30 - 300 CONTINUE -C -C TERMINATION, EITHER NORMAL OR USER IMPOSED. -C - IF (IFLAG .LT. 0) INFO = IFLAG - IFLAG = 0 - IF (NPRINT .GT. 0) CALL FCN(M,N,X,FVEC,FJAC,LDFJAC,IFLAG) - RETURN -C -C LAST CARD OF SUBROUTINE LMDER. -C - END - SUBROUTINE LMDER1(FCN,M,N,X,FVEC,FJAC,LDFJAC,TOL,INFO,IPVT,WA, - * LWA) - INTEGER M,N,LDFJAC,INFO,LWA - INTEGER IPVT(N) - DOUBLE PRECISION TOL - DOUBLE PRECISION X(N),FVEC(M),FJAC(LDFJAC,N),WA(LWA) - EXTERNAL FCN -C ********** -C -C SUBROUTINE LMDER1 -C -C THE PURPOSE OF LMDER1 IS TO MINIMIZE THE SUM OF THE SQUARES OF -C M NONLINEAR FUNCTIONS IN N VARIABLES BY A MODIFICATION OF THE -C LEVENBERG-MARQUARDT ALGORITHM. THIS IS DONE BY USING THE MORE -C GENERAL LEAST-SQUARES SOLVER LMDER. THE USER MUST PROVIDE A -C SUBROUTINE WHICH CALCULATES THE FUNCTIONS AND THE JACOBIAN. -C -C THE SUBROUTINE STATEMENT IS -C -C SUBROUTINE LMDER1(FCN,M,N,X,FVEC,FJAC,LDFJAC,TOL,INFO, -C IPVT,WA,LWA) -C -C WHERE -C -C FCN IS THE NAME OF THE USER-SUPPLIED SUBROUTINE WHICH -C CALCULATES THE FUNCTIONS AND THE JACOBIAN. FCN MUST -C BE DECLARED IN AN EXTERNAL STATEMENT IN THE USER -C CALLING PROGRAM, AND SHOULD BE WRITTEN AS FOLLOWS. -C -C SUBROUTINE FCN(M,N,X,FVEC,FJAC,LDFJAC,IFLAG) -C INTEGER M,N,LDFJAC,IFLAG -C DOUBLE PRECISION X(N),FVEC(M),FJAC(LDFJAC,N) -C ---------- -C IF IFLAG = 1 CALCULATE THE FUNCTIONS AT X AND -C RETURN THIS VECTOR IN FVEC. DO NOT ALTER FJAC. -C IF IFLAG = 2 CALCULATE THE JACOBIAN AT X AND -C RETURN THIS MATRIX IN FJAC. DO NOT ALTER FVEC. -C ---------- -C RETURN -C END -C -C THE VALUE OF IFLAG SHOULD NOT BE CHANGED BY FCN UNLESS -C THE USER WANTS TO TERMINATE EXECUTION OF LMDER1. -C IN THIS CASE SET IFLAG TO A NEGATIVE INTEGER. -C -C M IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER -C OF FUNCTIONS. -C -C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER -C OF VARIABLES. N MUST NOT EXCEED M. -C -C X IS AN ARRAY OF LENGTH N. ON INPUT X MUST CONTAIN -C AN INITIAL ESTIMATE OF THE SOLUTION VECTOR. ON OUTPUT X -C CONTAINS THE FINAL ESTIMATE OF THE SOLUTION VECTOR. -C -C FVEC IS AN OUTPUT ARRAY OF LENGTH M WHICH CONTAINS -C THE FUNCTIONS EVALUATED AT THE OUTPUT X. -C -C FJAC IS AN OUTPUT M BY N ARRAY. THE UPPER N BY N SUBMATRIX -C OF FJAC CONTAINS AN UPPER TRIANGULAR MATRIX R WITH -C DIAGONAL ELEMENTS OF NONINCREASING MAGNITUDE SUCH THAT -C -C T T T -C P *(JAC *JAC)*P = R *R, -C -C WHERE P IS A PERMUTATION MATRIX AND JAC IS THE FINAL -C CALCULATED JACOBIAN. COLUMN J OF P IS COLUMN IPVT(J) -C (SEE BELOW) OF THE IDENTITY MATRIX. THE LOWER TRAPEZOIDAL -C PART OF FJAC CONTAINS INFORMATION GENERATED DURING -C THE COMPUTATION OF R. -C -C LDFJAC IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN M -C WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY FJAC. -C -C TOL IS A NONNEGATIVE INPUT VARIABLE. TERMINATION OCCURS -C WHEN THE ALGORITHM ESTIMATES EITHER THAT THE RELATIVE -C ERROR IN THE SUM OF SQUARES IS AT MOST TOL OR THAT -C THE RELATIVE ERROR BETWEEN X AND THE SOLUTION IS AT -C MOST TOL. -C -C INFO IS AN INTEGER OUTPUT VARIABLE. IF THE USER HAS -C TERMINATED EXECUTION, INFO IS SET TO THE (NEGATIVE) -C VALUE OF IFLAG. SEE DESCRIPTION OF FCN. OTHERWISE, -C INFO IS SET AS FOLLOWS. -C -C INFO = 0 IMPROPER INPUT PARAMETERS. -C -C INFO = 1 ALGORITHM ESTIMATES THAT THE RELATIVE ERROR -C IN THE SUM OF SQUARES IS AT MOST TOL. -C -C INFO = 2 ALGORITHM ESTIMATES THAT THE RELATIVE ERROR -C BETWEEN X AND THE SOLUTION IS AT MOST TOL. -C -C INFO = 3 CONDITIONS FOR INFO = 1 AND INFO = 2 BOTH HOLD. -C -C INFO = 4 FVEC IS ORTHOGONAL TO THE COLUMNS OF THE -C JACOBIAN TO MACHINE PRECISION. -C -C INFO = 5 NUMBER OF CALLS TO FCN WITH IFLAG = 1 HAS -C REACHED 100*(N+1). -C -C INFO = 6 TOL IS TOO SMALL. NO FURTHER REDUCTION IN -C THE SUM OF SQUARES IS POSSIBLE. -C -C INFO = 7 TOL IS TOO SMALL. NO FURTHER IMPROVEMENT IN -C THE APPROXIMATE SOLUTION X IS POSSIBLE. -C -C IPVT IS AN INTEGER OUTPUT ARRAY OF LENGTH N. IPVT -C DEFINES A PERMUTATION MATRIX P SUCH THAT JAC*P = Q*R, -C WHERE JAC IS THE FINAL CALCULATED JACOBIAN, Q IS -C ORTHOGONAL (NOT STORED), AND R IS UPPER TRIANGULAR -C WITH DIAGONAL ELEMENTS OF NONINCREASING MAGNITUDE. -C COLUMN J OF P IS COLUMN IPVT(J) OF THE IDENTITY MATRIX. -C -C WA IS A WORK ARRAY OF LENGTH LWA. -C -C LWA IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN 5*N+M. -C -C SUBPROGRAMS CALLED -C -C USER-SUPPLIED ...... FCN -C -C MINPACK-SUPPLIED ... LMDER -C -C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. -C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE -C -C ********** - INTEGER MAXFEV,MODE,NFEV,NJEV,NPRINT - DOUBLE PRECISION FACTOR,FTOL,GTOL,XTOL,ZERO - DATA FACTOR,ZERO /1.0D2,0.0D0/ - INFO = 0 -C -C CHECK THE INPUT PARAMETERS FOR ERRORS. -C - IF (N .LE. 0 .OR. M .LT. N .OR. LDFJAC .LT. M .OR. TOL .LT. ZERO - * .OR. LWA .LT. 5*N + M) GO TO 10 -C -C CALL LMDER. -C - MAXFEV = 100*(N + 1) - FTOL = TOL - XTOL = TOL - GTOL = ZERO - MODE = 1 - NPRINT = 0 - CALL LMDER(FCN,M,N,X,FVEC,FJAC,LDFJAC,FTOL,XTOL,GTOL,MAXFEV, - * WA(1),MODE,FACTOR,NPRINT,INFO,NFEV,NJEV,IPVT,WA(N+1), - * WA(2*N+1),WA(3*N+1),WA(4*N+1),WA(5*N+1)) - IF (INFO .EQ. 8) INFO = 4 - 10 CONTINUE - RETURN -C -C LAST CARD OF SUBROUTINE LMDER1. -C - END - SUBROUTINE LMDIF(FCN,M,N,X,FVEC,FTOL,XTOL,GTOL,MAXFEV,EPSFCN, - * DIAG,MODE,FACTOR,NPRINT,INFO,NFEV,FJAC,LDFJAC, - * IPVT,QTF,WA1,WA2,WA3,WA4) - INTEGER M,N,MAXFEV,MODE,NPRINT,INFO,NFEV,LDFJAC - INTEGER IPVT(N) - DOUBLE PRECISION FTOL,XTOL,GTOL,EPSFCN,FACTOR - DOUBLE PRECISION X(N),FVEC(M),DIAG(N),FJAC(LDFJAC,N),QTF(N), - * WA1(N),WA2(N),WA3(N),WA4(M) - EXTERNAL FCN -C ********** -C -C SUBROUTINE LMDIF -C -C THE PURPOSE OF LMDIF IS TO MINIMIZE THE SUM OF THE SQUARES OF -C M NONLINEAR FUNCTIONS IN N VARIABLES BY A MODIFICATION OF -C THE LEVENBERG-MARQUARDT ALGORITHM. THE USER MUST PROVIDE A -C SUBROUTINE WHICH CALCULATES THE FUNCTIONS. THE JACOBIAN IS -C THEN CALCULATED BY A FORWARD-DIFFERENCE APPROXIMATION. -C -C THE SUBROUTINE STATEMENT IS -C -C SUBROUTINE LMDIF(FCN,M,N,X,FVEC,FTOL,XTOL,GTOL,MAXFEV,EPSFCN, -C DIAG,MODE,FACTOR,NPRINT,INFO,NFEV,FJAC, -C LDFJAC,IPVT,QTF,WA1,WA2,WA3,WA4) -C -C WHERE -C -C FCN IS THE NAME OF THE USER-SUPPLIED SUBROUTINE WHICH -C CALCULATES THE FUNCTIONS. FCN MUST BE DECLARED -C IN AN EXTERNAL STATEMENT IN THE USER CALLING -C PROGRAM, AND SHOULD BE WRITTEN AS FOLLOWS. -C -C SUBROUTINE FCN(M,N,X,FVEC,IFLAG) -C INTEGER M,N,IFLAG -C DOUBLE PRECISION X(N),FVEC(M) -C ---------- -C CALCULATE THE FUNCTIONS AT X AND -C RETURN THIS VECTOR IN FVEC. -C ---------- -C RETURN -C END -C -C THE VALUE OF IFLAG SHOULD NOT BE CHANGED BY FCN UNLESS -C THE USER WANTS TO TERMINATE EXECUTION OF LMDIF. -C IN THIS CASE SET IFLAG TO A NEGATIVE INTEGER. -C -C M IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER -C OF FUNCTIONS. -C -C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER -C OF VARIABLES. N MUST NOT EXCEED M. -C -C X IS AN ARRAY OF LENGTH N. ON INPUT X MUST CONTAIN -C AN INITIAL ESTIMATE OF THE SOLUTION VECTOR. ON OUTPUT X -C CONTAINS THE FINAL ESTIMATE OF THE SOLUTION VECTOR. -C -C FVEC IS AN OUTPUT ARRAY OF LENGTH M WHICH CONTAINS -C THE FUNCTIONS EVALUATED AT THE OUTPUT X. -C -C FTOL IS A NONNEGATIVE INPUT VARIABLE. TERMINATION -C OCCURS WHEN BOTH THE ACTUAL AND PREDICTED RELATIVE -C REDUCTIONS IN THE SUM OF SQUARES ARE AT MOST FTOL. -C THEREFORE, FTOL MEASURES THE RELATIVE ERROR DESIRED -C IN THE SUM OF SQUARES. -C -C XTOL IS A NONNEGATIVE INPUT VARIABLE. TERMINATION -C OCCURS WHEN THE RELATIVE ERROR BETWEEN TWO CONSECUTIVE -C ITERATES IS AT MOST XTOL. THEREFORE, XTOL MEASURES THE -C RELATIVE ERROR DESIRED IN THE APPROXIMATE SOLUTION. -C -C GTOL IS A NONNEGATIVE INPUT VARIABLE. TERMINATION -C OCCURS WHEN THE COSINE OF THE ANGLE BETWEEN FVEC AND -C ANY COLUMN OF THE JACOBIAN IS AT MOST GTOL IN ABSOLUTE -C VALUE. THEREFORE, GTOL MEASURES THE ORTHOGONALITY -C DESIRED BETWEEN THE FUNCTION VECTOR AND THE COLUMNS -C OF THE JACOBIAN. -C -C MAXFEV IS A POSITIVE INTEGER INPUT VARIABLE. TERMINATION -C OCCURS WHEN THE NUMBER OF CALLS TO FCN IS AT LEAST -C MAXFEV BY THE END OF AN ITERATION. -C -C EPSFCN IS AN INPUT VARIABLE USED IN DETERMINING A SUITABLE -C STEP LENGTH FOR THE FORWARD-DIFFERENCE APPROXIMATION. THIS -C APPROXIMATION ASSUMES THAT THE RELATIVE ERRORS IN THE -C FUNCTIONS ARE OF THE ORDER OF EPSFCN. IF EPSFCN IS LESS -C THAN THE MACHINE PRECISION, IT IS ASSUMED THAT THE RELATIVE -C ERRORS IN THE FUNCTIONS ARE OF THE ORDER OF THE MACHINE -C PRECISION. -C -C DIAG IS AN ARRAY OF LENGTH N. IF MODE = 1 (SEE -C BELOW), DIAG IS INTERNALLY SET. IF MODE = 2, DIAG -C MUST CONTAIN POSITIVE ENTRIES THAT SERVE AS -C MULTIPLICATIVE SCALE FACTORS FOR THE VARIABLES. -C -C MODE IS AN INTEGER INPUT VARIABLE. IF MODE = 1, THE -C VARIABLES WILL BE SCALED INTERNALLY. IF MODE = 2, -C THE SCALING IS SPECIFIED BY THE INPUT DIAG. OTHER -C VALUES OF MODE ARE EQUIVALENT TO MODE = 1. -C -C FACTOR IS A POSITIVE INPUT VARIABLE USED IN DETERMINING THE -C INITIAL STEP BOUND. THIS BOUND IS SET TO THE PRODUCT OF -C FACTOR AND THE EUCLIDEAN NORM OF DIAG*X IF NONZERO, OR ELSE -C TO FACTOR ITSELF. IN MOST CASES FACTOR SHOULD LIE IN THE -C INTERVAL (.1,100.). 100. IS A GENERALLY RECOMMENDED VALUE. -C -C NPRINT IS AN INTEGER INPUT VARIABLE THAT ENABLES CONTROLLED -C PRINTING OF ITERATES IF IT IS POSITIVE. IN THIS CASE, -C FCN IS CALLED WITH IFLAG = 0 AT THE BEGINNING OF THE FIRST -C ITERATION AND EVERY NPRINT ITERATIONS THEREAFTER AND -C IMMEDIATELY PRIOR TO RETURN, WITH X AND FVEC AVAILABLE -C FOR PRINTING. IF NPRINT IS NOT POSITIVE, NO SPECIAL CALLS -C OF FCN WITH IFLAG = 0 ARE MADE. -C -C INFO IS AN INTEGER OUTPUT VARIABLE. IF THE USER HAS -C TERMINATED EXECUTION, INFO IS SET TO THE (NEGATIVE) -C VALUE OF IFLAG. SEE DESCRIPTION OF FCN. OTHERWISE, -C INFO IS SET AS FOLLOWS. -C -C INFO = 0 IMPROPER INPUT PARAMETERS. -C -C INFO = 1 BOTH ACTUAL AND PREDICTED RELATIVE REDUCTIONS -C IN THE SUM OF SQUARES ARE AT MOST FTOL. -C -C INFO = 2 RELATIVE ERROR BETWEEN TWO CONSECUTIVE ITERATES -C IS AT MOST XTOL. -C -C INFO = 3 CONDITIONS FOR INFO = 1 AND INFO = 2 BOTH HOLD. -C -C INFO = 4 THE COSINE OF THE ANGLE BETWEEN FVEC AND ANY -C COLUMN OF THE JACOBIAN IS AT MOST GTOL IN -C ABSOLUTE VALUE. -C -C INFO = 5 NUMBER OF CALLS TO FCN HAS REACHED OR -C EXCEEDED MAXFEV. -C -C INFO = 6 FTOL IS TOO SMALL. NO FURTHER REDUCTION IN -C THE SUM OF SQUARES IS POSSIBLE. -C -C INFO = 7 XTOL IS TOO SMALL. NO FURTHER IMPROVEMENT IN -C THE APPROXIMATE SOLUTION X IS POSSIBLE. -C -C INFO = 8 GTOL IS TOO SMALL. FVEC IS ORTHOGONAL TO THE -C COLUMNS OF THE JACOBIAN TO MACHINE PRECISION. -C -C NFEV IS AN INTEGER OUTPUT VARIABLE SET TO THE NUMBER OF -C CALLS TO FCN. -C -C FJAC IS AN OUTPUT M BY N ARRAY. THE UPPER N BY N SUBMATRIX -C OF FJAC CONTAINS AN UPPER TRIANGULAR MATRIX R WITH -C DIAGONAL ELEMENTS OF NONINCREASING MAGNITUDE SUCH THAT -C -C T T T -C P *(JAC *JAC)*P = R *R, -C -C WHERE P IS A PERMUTATION MATRIX AND JAC IS THE FINAL -C CALCULATED JACOBIAN. COLUMN J OF P IS COLUMN IPVT(J) -C (SEE BELOW) OF THE IDENTITY MATRIX. THE LOWER TRAPEZOIDAL -C PART OF FJAC CONTAINS INFORMATION GENERATED DURING -C THE COMPUTATION OF R. -C -C LDFJAC IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN M -C WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY FJAC. -C -C IPVT IS AN INTEGER OUTPUT ARRAY OF LENGTH N. IPVT -C DEFINES A PERMUTATION MATRIX P SUCH THAT JAC*P = Q*R, -C WHERE JAC IS THE FINAL CALCULATED JACOBIAN, Q IS -C ORTHOGONAL (NOT STORED), AND R IS UPPER TRIANGULAR -C WITH DIAGONAL ELEMENTS OF NONINCREASING MAGNITUDE. -C COLUMN J OF P IS COLUMN IPVT(J) OF THE IDENTITY MATRIX. -C -C QTF IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS -C THE FIRST N ELEMENTS OF THE VECTOR (Q TRANSPOSE)*FVEC. -C -C WA1, WA2, AND WA3 ARE WORK ARRAYS OF LENGTH N. -C -C WA4 IS A WORK ARRAY OF LENGTH M. -C -C SUBPROGRAMS CALLED -C -C USER-SUPPLIED ...... FCN -C -C MINPACK-SUPPLIED ... DPMPAR,ENORM,FDJAC2,LMPAR,QRFAC -C -C FORTRAN-SUPPLIED ... DABS,DMAX1,DMIN1,DSQRT,MOD -C -C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. -C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE -C -C ********** - INTEGER I,IFLAG,ITER,J,L - DOUBLE PRECISION ACTRED,DELTA,DIRDER,EPSMCH,FNORM,FNORM1,GNORM, - * ONE,PAR,PNORM,PRERED,P1,P5,P25,P75,P0001,RATIO, - * SUM,TEMP,TEMP1,TEMP2,XNORM,ZERO - DOUBLE PRECISION DPMPAR,ENORM - DATA ONE,P1,P5,P25,P75,P0001,ZERO - * /1.0D0,1.0D-1,5.0D-1,2.5D-1,7.5D-1,1.0D-4,0.0D0/ -C -C EPSMCH IS THE MACHINE PRECISION. -C - EPSMCH = DPMPAR(1) -C - INFO = 0 - IFLAG = 0 - NFEV = 0 -C -C CHECK THE INPUT PARAMETERS FOR ERRORS. -C - IF (N .LE. 0 .OR. M .LT. N .OR. LDFJAC .LT. M - * .OR. FTOL .LT. ZERO .OR. XTOL .LT. ZERO .OR. GTOL .LT. ZERO - * .OR. MAXFEV .LE. 0 .OR. FACTOR .LE. ZERO) GO TO 300 - IF (MODE .NE. 2) GO TO 20 - DO 10 J = 1, N - IF (DIAG(J) .LE. ZERO) GO TO 300 - 10 CONTINUE - 20 CONTINUE -C -C EVALUATE THE FUNCTION AT THE STARTING POINT -C AND CALCULATE ITS NORM. -C - IFLAG = 1 - CALL FCN(M,N,X,FVEC,IFLAG) - NFEV = 1 - IF (IFLAG .LT. 0) GO TO 300 - FNORM = ENORM(M,FVEC) -C -C INITIALIZE LEVENBERG-MARQUARDT PARAMETER AND ITERATION COUNTER. -C - PAR = ZERO - ITER = 1 -C -C BEGINNING OF THE OUTER LOOP. -C - 30 CONTINUE -C -C CALCULATE THE JACOBIAN MATRIX. -C - IFLAG = 2 - CALL FDJAC2(FCN,M,N,X,FVEC,FJAC,LDFJAC,IFLAG,EPSFCN,WA4) - NFEV = NFEV + N - IF (IFLAG .LT. 0) GO TO 300 -C -C IF REQUESTED, CALL FCN TO ENABLE PRINTING OF ITERATES. -C - IF (NPRINT .LE. 0) GO TO 40 - IFLAG = 0 - IF (MOD(ITER-1,NPRINT) .EQ. 0) CALL FCN(M,N,X,FVEC,IFLAG) - IF (IFLAG .LT. 0) GO TO 300 - 40 CONTINUE -C -C COMPUTE THE QR FACTORIZATION OF THE JACOBIAN. -C - CALL QRFAC(M,N,FJAC,LDFJAC,.TRUE.,IPVT,N,WA1,WA2,WA3) -C -C ON THE FIRST ITERATION AND IF MODE IS 1, SCALE ACCORDING -C TO THE NORMS OF THE COLUMNS OF THE INITIAL JACOBIAN. -C - IF (ITER .NE. 1) GO TO 80 - IF (MODE .EQ. 2) GO TO 60 - DO 50 J = 1, N - DIAG(J) = WA2(J) - IF (WA2(J) .EQ. ZERO) DIAG(J) = ONE - 50 CONTINUE - 60 CONTINUE -C -C ON THE FIRST ITERATION, CALCULATE THE NORM OF THE SCALED X -C AND INITIALIZE THE STEP BOUND DELTA. -C - DO 70 J = 1, N - WA3(J) = DIAG(J)*X(J) - 70 CONTINUE - XNORM = ENORM(N,WA3) - DELTA = FACTOR*XNORM - IF (DELTA .EQ. ZERO) DELTA = FACTOR - 80 CONTINUE -C -C FORM (Q TRANSPOSE)*FVEC AND STORE THE FIRST N COMPONENTS IN -C QTF. -C - DO 90 I = 1, M - WA4(I) = FVEC(I) - 90 CONTINUE - DO 130 J = 1, N - IF (FJAC(J,J) .EQ. ZERO) GO TO 120 - SUM = ZERO - DO 100 I = J, M - SUM = SUM + FJAC(I,J)*WA4(I) - 100 CONTINUE - TEMP = -SUM/FJAC(J,J) - DO 110 I = J, M - WA4(I) = WA4(I) + FJAC(I,J)*TEMP - 110 CONTINUE - 120 CONTINUE - FJAC(J,J) = WA1(J) - QTF(J) = WA4(J) - 130 CONTINUE -C -C COMPUTE THE NORM OF THE SCALED GRADIENT. -C - GNORM = ZERO - IF (FNORM .EQ. ZERO) GO TO 170 - DO 160 J = 1, N - L = IPVT(J) - IF (WA2(L) .EQ. ZERO) GO TO 150 - SUM = ZERO - DO 140 I = 1, J - SUM = SUM + FJAC(I,J)*(QTF(I)/FNORM) - 140 CONTINUE - GNORM = DMAX1(GNORM,DABS(SUM/WA2(L))) - 150 CONTINUE - 160 CONTINUE - 170 CONTINUE -C -C TEST FOR CONVERGENCE OF THE GRADIENT NORM. -C - IF (GNORM .LE. GTOL) INFO = 4 - IF (INFO .NE. 0) GO TO 300 -C -C RESCALE IF NECESSARY. -C - IF (MODE .EQ. 2) GO TO 190 - DO 180 J = 1, N - DIAG(J) = DMAX1(DIAG(J),WA2(J)) - 180 CONTINUE - 190 CONTINUE -C -C BEGINNING OF THE INNER LOOP. -C - 200 CONTINUE -C -C DETERMINE THE LEVENBERG-MARQUARDT PARAMETER. -C - CALL LMPAR(N,FJAC,LDFJAC,IPVT,DIAG,QTF,DELTA,PAR,WA1,WA2, - * WA3,WA4) -C -C STORE THE DIRECTION P AND X + P. CALCULATE THE NORM OF P. -C - DO 210 J = 1, N - WA1(J) = -WA1(J) - WA2(J) = X(J) + WA1(J) - WA3(J) = DIAG(J)*WA1(J) - 210 CONTINUE - PNORM = ENORM(N,WA3) -C -C ON THE FIRST ITERATION, ADJUST THE INITIAL STEP BOUND. -C - IF (ITER .EQ. 1) DELTA = DMIN1(DELTA,PNORM) -C -C EVALUATE THE FUNCTION AT X + P AND CALCULATE ITS NORM. -C - IFLAG = 1 - CALL FCN(M,N,WA2,WA4,IFLAG) - NFEV = NFEV + 1 - IF (IFLAG .LT. 0) GO TO 300 - FNORM1 = ENORM(M,WA4) -C -C COMPUTE THE SCALED ACTUAL REDUCTION. -C - ACTRED = -ONE - IF (P1*FNORM1 .LT. FNORM) ACTRED = ONE - (FNORM1/FNORM)**2 -C -C COMPUTE THE SCALED PREDICTED REDUCTION AND -C THE SCALED DIRECTIONAL DERIVATIVE. -C - DO 230 J = 1, N - WA3(J) = ZERO - L = IPVT(J) - TEMP = WA1(L) - DO 220 I = 1, J - WA3(I) = WA3(I) + FJAC(I,J)*TEMP - 220 CONTINUE - 230 CONTINUE - TEMP1 = ENORM(N,WA3)/FNORM - TEMP2 = (DSQRT(PAR)*PNORM)/FNORM - PRERED = TEMP1**2 + TEMP2**2/P5 - DIRDER = -(TEMP1**2 + TEMP2**2) -C -C COMPUTE THE RATIO OF THE ACTUAL TO THE PREDICTED -C REDUCTION. -C - RATIO = ZERO - IF (PRERED .NE. ZERO) RATIO = ACTRED/PRERED -C -C UPDATE THE STEP BOUND. -C - IF (RATIO .GT. P25) GO TO 240 - IF (ACTRED .GE. ZERO) TEMP = P5 - IF (ACTRED .LT. ZERO) - * TEMP = P5*DIRDER/(DIRDER + P5*ACTRED) - IF (P1*FNORM1 .GE. FNORM .OR. TEMP .LT. P1) TEMP = P1 - DELTA = TEMP*DMIN1(DELTA,PNORM/P1) - PAR = PAR/TEMP - GO TO 260 - 240 CONTINUE - IF (PAR .NE. ZERO .AND. RATIO .LT. P75) GO TO 250 - DELTA = PNORM/P5 - PAR = P5*PAR - 250 CONTINUE - 260 CONTINUE -C -C TEST FOR SUCCESSFUL ITERATION. -C - IF (RATIO .LT. P0001) GO TO 290 -C -C SUCCESSFUL ITERATION. UPDATE X, FVEC, AND THEIR NORMS. -C - DO 270 J = 1, N - X(J) = WA2(J) - WA2(J) = DIAG(J)*X(J) - 270 CONTINUE - DO 280 I = 1, M - FVEC(I) = WA4(I) - 280 CONTINUE - XNORM = ENORM(N,WA2) - FNORM = FNORM1 - ITER = ITER + 1 - 290 CONTINUE -C -C TESTS FOR CONVERGENCE. -C - IF (DABS(ACTRED) .LE. FTOL .AND. PRERED .LE. FTOL - * .AND. P5*RATIO .LE. ONE) INFO = 1 - IF (DELTA .LE. XTOL*XNORM) INFO = 2 - IF (DABS(ACTRED) .LE. FTOL .AND. PRERED .LE. FTOL - * .AND. P5*RATIO .LE. ONE .AND. INFO .EQ. 2) INFO = 3 - IF (INFO .NE. 0) GO TO 300 -C -C TESTS FOR TERMINATION AND STRINGENT TOLERANCES. -C - IF (NFEV .GE. MAXFEV) INFO = 5 - IF (DABS(ACTRED) .LE. EPSMCH .AND. PRERED .LE. EPSMCH - * .AND. P5*RATIO .LE. ONE) INFO = 6 - IF (DELTA .LE. EPSMCH*XNORM) INFO = 7 - IF (GNORM .LE. EPSMCH) INFO = 8 - IF (INFO .NE. 0) GO TO 300 -C -C END OF THE INNER LOOP. REPEAT IF ITERATION UNSUCCESSFUL. -C - IF (RATIO .LT. P0001) GO TO 200 -C -C END OF THE OUTER LOOP. -C - GO TO 30 - 300 CONTINUE -C -C TERMINATION, EITHER NORMAL OR USER IMPOSED. -C - IF (IFLAG .LT. 0) INFO = IFLAG - IFLAG = 0 - IF (NPRINT .GT. 0) CALL FCN(M,N,X,FVEC,IFLAG) - RETURN -C -C LAST CARD OF SUBROUTINE LMDIF. -C - END - SUBROUTINE LMDIF1(FCN,M,N,X,FVEC,TOL,INFO,IWA,WA,LWA) - INTEGER M,N,INFO,LWA - INTEGER IWA(N) - DOUBLE PRECISION TOL - DOUBLE PRECISION X(N),FVEC(M),WA(LWA) - EXTERNAL FCN -C ********** -C -C SUBROUTINE LMDIF1 -C -C THE PURPOSE OF LMDIF1 IS TO MINIMIZE THE SUM OF THE SQUARES OF -C M NONLINEAR FUNCTIONS IN N VARIABLES BY A MODIFICATION OF THE -C LEVENBERG-MARQUARDT ALGORITHM. THIS IS DONE BY USING THE MORE -C GENERAL LEAST-SQUARES SOLVER LMDIF. THE USER MUST PROVIDE A -C SUBROUTINE WHICH CALCULATES THE FUNCTIONS. THE JACOBIAN IS -C THEN CALCULATED BY A FORWARD-DIFFERENCE APPROXIMATION. -C -C THE SUBROUTINE STATEMENT IS -C -C SUBROUTINE LMDIF1(FCN,M,N,X,FVEC,TOL,INFO,IWA,WA,LWA) -C -C WHERE -C -C FCN IS THE NAME OF THE USER-SUPPLIED SUBROUTINE WHICH -C CALCULATES THE FUNCTIONS. FCN MUST BE DECLARED -C IN AN EXTERNAL STATEMENT IN THE USER CALLING -C PROGRAM, AND SHOULD BE WRITTEN AS FOLLOWS. -C -C SUBROUTINE FCN(M,N,X,FVEC,IFLAG) -C INTEGER M,N,IFLAG -C DOUBLE PRECISION X(N),FVEC(M) -C ---------- -C CALCULATE THE FUNCTIONS AT X AND -C RETURN THIS VECTOR IN FVEC. -C ---------- -C RETURN -C END -C -C THE VALUE OF IFLAG SHOULD NOT BE CHANGED BY FCN UNLESS -C THE USER WANTS TO TERMINATE EXECUTION OF LMDIF1. -C IN THIS CASE SET IFLAG TO A NEGATIVE INTEGER. -C -C M IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER -C OF FUNCTIONS. -C -C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER -C OF VARIABLES. N MUST NOT EXCEED M. -C -C X IS AN ARRAY OF LENGTH N. ON INPUT X MUST CONTAIN -C AN INITIAL ESTIMATE OF THE SOLUTION VECTOR. ON OUTPUT X -C CONTAINS THE FINAL ESTIMATE OF THE SOLUTION VECTOR. -C -C FVEC IS AN OUTPUT ARRAY OF LENGTH M WHICH CONTAINS -C THE FUNCTIONS EVALUATED AT THE OUTPUT X. -C -C TOL IS A NONNEGATIVE INPUT VARIABLE. TERMINATION OCCURS -C WHEN THE ALGORITHM ESTIMATES EITHER THAT THE RELATIVE -C ERROR IN THE SUM OF SQUARES IS AT MOST TOL OR THAT -C THE RELATIVE ERROR BETWEEN X AND THE SOLUTION IS AT -C MOST TOL. -C -C INFO IS AN INTEGER OUTPUT VARIABLE. IF THE USER HAS -C TERMINATED EXECUTION, INFO IS SET TO THE (NEGATIVE) -C VALUE OF IFLAG. SEE DESCRIPTION OF FCN. OTHERWISE, -C INFO IS SET AS FOLLOWS. -C -C INFO = 0 IMPROPER INPUT PARAMETERS. -C -C INFO = 1 ALGORITHM ESTIMATES THAT THE RELATIVE ERROR -C IN THE SUM OF SQUARES IS AT MOST TOL. -C -C INFO = 2 ALGORITHM ESTIMATES THAT THE RELATIVE ERROR -C BETWEEN X AND THE SOLUTION IS AT MOST TOL. -C -C INFO = 3 CONDITIONS FOR INFO = 1 AND INFO = 2 BOTH HOLD. -C -C INFO = 4 FVEC IS ORTHOGONAL TO THE COLUMNS OF THE -C JACOBIAN TO MACHINE PRECISION. -C -C INFO = 5 NUMBER OF CALLS TO FCN HAS REACHED OR -C EXCEEDED 200*(N+1). -C -C INFO = 6 TOL IS TOO SMALL. NO FURTHER REDUCTION IN -C THE SUM OF SQUARES IS POSSIBLE. -C -C INFO = 7 TOL IS TOO SMALL. NO FURTHER IMPROVEMENT IN -C THE APPROXIMATE SOLUTION X IS POSSIBLE. -C -C IWA IS AN INTEGER WORK ARRAY OF LENGTH N. -C -C WA IS A WORK ARRAY OF LENGTH LWA. -C -C LWA IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN -C M*N+5*N+M. -C -C SUBPROGRAMS CALLED -C -C USER-SUPPLIED ...... FCN -C -C MINPACK-SUPPLIED ... LMDIF -C -C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. -C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE -C -C ********** - INTEGER MAXFEV,MODE,MP5N,NFEV,NPRINT - DOUBLE PRECISION EPSFCN,FACTOR,FTOL,GTOL,XTOL,ZERO - DATA FACTOR,ZERO /1.0D2,0.0D0/ - INFO = 0 -C -C CHECK THE INPUT PARAMETERS FOR ERRORS. -C - IF (N .LE. 0 .OR. M .LT. N .OR. TOL .LT. ZERO - * .OR. LWA .LT. M*N + 5*N + M) GO TO 10 -C -C CALL LMDIF. -C - MAXFEV = 200*(N + 1) - FTOL = TOL - XTOL = TOL - GTOL = ZERO - EPSFCN = ZERO - MODE = 1 - NPRINT = 0 - MP5N = M + 5*N - CALL LMDIF(FCN,M,N,X,FVEC,FTOL,XTOL,GTOL,MAXFEV,EPSFCN,WA(1), - * MODE,FACTOR,NPRINT,INFO,NFEV,WA(MP5N+1),M,IWA, - * WA(N+1),WA(2*N+1),WA(3*N+1),WA(4*N+1),WA(5*N+1)) - IF (INFO .EQ. 8) INFO = 4 - 10 CONTINUE - RETURN -C -C LAST CARD OF SUBROUTINE LMDIF1. -C - END - SUBROUTINE LMPAR(N,R,LDR,IPVT,DIAG,QTB,DELTA,PAR,X,SDIAG,WA1, - * WA2) - INTEGER N,LDR - INTEGER IPVT(N) - DOUBLE PRECISION DELTA,PAR - DOUBLE PRECISION R(LDR,N),DIAG(N),QTB(N),X(N),SDIAG(N),WA1(N), - * WA2(N) -C ********** -C -C SUBROUTINE LMPAR -C -C GIVEN AN M BY N MATRIX A, AN N BY N NONSINGULAR DIAGONAL -C MATRIX D, AN M-VECTOR B, AND A POSITIVE NUMBER DELTA, -C THE PROBLEM IS TO DETERMINE A VALUE FOR THE PARAMETER -C PAR SUCH THAT IF X SOLVES THE SYSTEM -C -C A*X = B , SQRT(PAR)*D*X = 0 , -C -C IN THE LEAST SQUARES SENSE, AND DXNORM IS THE EUCLIDEAN -C NORM OF D*X, THEN EITHER PAR IS ZERO AND -C -C (DXNORM-DELTA) .LE. 0.1*DELTA , -C -C OR PAR IS POSITIVE AND -C -C ABS(DXNORM-DELTA) .LE. 0.1*DELTA . -C -C THIS SUBROUTINE COMPLETES THE SOLUTION OF THE PROBLEM -C IF IT IS PROVIDED WITH THE NECESSARY INFORMATION FROM THE -C QR FACTORIZATION, WITH COLUMN PIVOTING, OF A. THAT IS, IF -C A*P = Q*R, WHERE P IS A PERMUTATION MATRIX, Q HAS ORTHOGONAL -C COLUMNS, AND R IS AN UPPER TRIANGULAR MATRIX WITH DIAGONAL -C ELEMENTS OF NONINCREASING MAGNITUDE, THEN LMPAR EXPECTS -C THE FULL UPPER TRIANGLE OF R, THE PERMUTATION MATRIX P, -C AND THE FIRST N COMPONENTS OF (Q TRANSPOSE)*B. ON OUTPUT -C LMPAR ALSO PROVIDES AN UPPER TRIANGULAR MATRIX S SUCH THAT -C -C T T T -C P *(A *A + PAR*D*D)*P = S *S . -C -C S IS EMPLOYED WITHIN LMPAR AND MAY BE OF SEPARATE INTEREST. -C -C ONLY A FEW ITERATIONS ARE GENERALLY NEEDED FOR CONVERGENCE -C OF THE ALGORITHM. IF, HOWEVER, THE LIMIT OF 10 ITERATIONS -C IS REACHED, THEN THE OUTPUT PAR WILL CONTAIN THE BEST -C VALUE OBTAINED SO FAR. -C -C THE SUBROUTINE STATEMENT IS -C -C SUBROUTINE LMPAR(N,R,LDR,IPVT,DIAG,QTB,DELTA,PAR,X,SDIAG, -C WA1,WA2) -C -C WHERE -C -C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE ORDER OF R. -C -C R IS AN N BY N ARRAY. ON INPUT THE FULL UPPER TRIANGLE -C MUST CONTAIN THE FULL UPPER TRIANGLE OF THE MATRIX R. -C ON OUTPUT THE FULL UPPER TRIANGLE IS UNALTERED, AND THE -C STRICT LOWER TRIANGLE CONTAINS THE STRICT UPPER TRIANGLE -C (TRANSPOSED) OF THE UPPER TRIANGULAR MATRIX S. -C -C LDR IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN N -C WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY R. -C -C IPVT IS AN INTEGER INPUT ARRAY OF LENGTH N WHICH DEFINES THE -C PERMUTATION MATRIX P SUCH THAT A*P = Q*R. COLUMN J OF P -C IS COLUMN IPVT(J) OF THE IDENTITY MATRIX. -C -C DIAG IS AN INPUT ARRAY OF LENGTH N WHICH MUST CONTAIN THE -C DIAGONAL ELEMENTS OF THE MATRIX D. -C -C QTB IS AN INPUT ARRAY OF LENGTH N WHICH MUST CONTAIN THE FIRST -C N ELEMENTS OF THE VECTOR (Q TRANSPOSE)*B. -C -C DELTA IS A POSITIVE INPUT VARIABLE WHICH SPECIFIES AN UPPER -C BOUND ON THE EUCLIDEAN NORM OF D*X. -C -C PAR IS A NONNEGATIVE VARIABLE. ON INPUT PAR CONTAINS AN -C INITIAL ESTIMATE OF THE LEVENBERG-MARQUARDT PARAMETER. -C ON OUTPUT PAR CONTAINS THE FINAL ESTIMATE. -C -C X IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE LEAST -C SQUARES SOLUTION OF THE SYSTEM A*X = B, SQRT(PAR)*D*X = 0, -C FOR THE OUTPUT PAR. -C -C SDIAG IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE -C DIAGONAL ELEMENTS OF THE UPPER TRIANGULAR MATRIX S. -C -C WA1 AND WA2 ARE WORK ARRAYS OF LENGTH N. -C -C SUBPROGRAMS CALLED -C -C MINPACK-SUPPLIED ... DPMPAR,ENORM,QRSOLV -C -C FORTRAN-SUPPLIED ... DABS,DMAX1,DMIN1,DSQRT -C -C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. -C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE -C -C ********** - INTEGER I,ITER,J,JM1,JP1,K,L,NSING - DOUBLE PRECISION DXNORM,DWARF,FP,GNORM,PARC,PARL,PARU,P1,P001, - * SUM,TEMP,ZERO - DOUBLE PRECISION DPMPAR,ENORM - DATA P1,P001,ZERO /1.0D-1,1.0D-3,0.0D0/ -C -C DWARF IS THE SMALLEST POSITIVE MAGNITUDE. -C - DWARF = DPMPAR(2) -C -C COMPUTE AND STORE IN X THE GAUSS-NEWTON DIRECTION. IF THE -C JACOBIAN IS RANK-DEFICIENT, OBTAIN A LEAST SQUARES SOLUTION. -C - NSING = N - DO 10 J = 1, N - WA1(J) = QTB(J) - IF (R(J,J) .EQ. ZERO .AND. NSING .EQ. N) NSING = J - 1 - IF (NSING .LT. N) WA1(J) = ZERO - 10 CONTINUE - IF (NSING .LT. 1) GO TO 50 - DO 40 K = 1, NSING - J = NSING - K + 1 - WA1(J) = WA1(J)/R(J,J) - TEMP = WA1(J) - JM1 = J - 1 - IF (JM1 .LT. 1) GO TO 30 - DO 20 I = 1, JM1 - WA1(I) = WA1(I) - R(I,J)*TEMP - 20 CONTINUE - 30 CONTINUE - 40 CONTINUE - 50 CONTINUE - DO 60 J = 1, N - L = IPVT(J) - X(L) = WA1(J) - 60 CONTINUE -C -C INITIALIZE THE ITERATION COUNTER. -C EVALUATE THE FUNCTION AT THE ORIGIN, AND TEST -C FOR ACCEPTANCE OF THE GAUSS-NEWTON DIRECTION. -C - ITER = 0 - DO 70 J = 1, N - WA2(J) = DIAG(J)*X(J) - 70 CONTINUE - DXNORM = ENORM(N,WA2) - FP = DXNORM - DELTA - IF (FP .LE. P1*DELTA) GO TO 220 -C -C IF THE JACOBIAN IS NOT RANK DEFICIENT, THE NEWTON -C STEP PROVIDES A LOWER BOUND, PARL, FOR THE ZERO OF -C THE FUNCTION. OTHERWISE SET THIS BOUND TO ZERO. -C - PARL = ZERO - IF (NSING .LT. N) GO TO 120 - DO 80 J = 1, N - L = IPVT(J) - WA1(J) = DIAG(L)*(WA2(L)/DXNORM) - 80 CONTINUE - DO 110 J = 1, N - SUM = ZERO - JM1 = J - 1 - IF (JM1 .LT. 1) GO TO 100 - DO 90 I = 1, JM1 - SUM = SUM + R(I,J)*WA1(I) - 90 CONTINUE - 100 CONTINUE - WA1(J) = (WA1(J) - SUM)/R(J,J) - 110 CONTINUE - TEMP = ENORM(N,WA1) - PARL = ((FP/DELTA)/TEMP)/TEMP - 120 CONTINUE -C -C CALCULATE AN UPPER BOUND, PARU, FOR THE ZERO OF THE FUNCTION. -C - DO 140 J = 1, N - SUM = ZERO - DO 130 I = 1, J - SUM = SUM + R(I,J)*QTB(I) - 130 CONTINUE - L = IPVT(J) - WA1(J) = SUM/DIAG(L) - 140 CONTINUE - GNORM = ENORM(N,WA1) - PARU = GNORM/DELTA - IF (PARU .EQ. ZERO) PARU = DWARF/DMIN1(DELTA,P1) -C -C IF THE INPUT PAR LIES OUTSIDE OF THE INTERVAL (PARL,PARU), -C SET PAR TO THE CLOSER ENDPOINT. -C - PAR = DMAX1(PAR,PARL) - PAR = DMIN1(PAR,PARU) - IF (PAR .EQ. ZERO) PAR = GNORM/DXNORM -C -C BEGINNING OF AN ITERATION. -C - 150 CONTINUE - ITER = ITER + 1 -C -C EVALUATE THE FUNCTION AT THE CURRENT VALUE OF PAR. -C - IF (PAR .EQ. ZERO) PAR = DMAX1(DWARF,P001*PARU) - TEMP = DSQRT(PAR) - DO 160 J = 1, N - WA1(J) = TEMP*DIAG(J) - 160 CONTINUE - CALL QRSOLV(N,R,LDR,IPVT,WA1,QTB,X,SDIAG,WA2) - DO 170 J = 1, N - WA2(J) = DIAG(J)*X(J) - 170 CONTINUE - DXNORM = ENORM(N,WA2) - TEMP = FP - FP = DXNORM - DELTA -C -C IF THE FUNCTION IS SMALL ENOUGH, ACCEPT THE CURRENT VALUE -C OF PAR. ALSO TEST FOR THE EXCEPTIONAL CASES WHERE PARL -C IS ZERO OR THE NUMBER OF ITERATIONS HAS REACHED 10. -C - IF (DABS(FP) .LE. P1*DELTA - * .OR. PARL .EQ. ZERO .AND. FP .LE. TEMP - * .AND. TEMP .LT. ZERO .OR. ITER .EQ. 10) GO TO 220 -C -C COMPUTE THE NEWTON CORRECTION. -C - DO 180 J = 1, N - L = IPVT(J) - WA1(J) = DIAG(L)*(WA2(L)/DXNORM) - 180 CONTINUE - DO 210 J = 1, N - WA1(J) = WA1(J)/SDIAG(J) - TEMP = WA1(J) - JP1 = J + 1 - IF (N .LT. JP1) GO TO 200 - DO 190 I = JP1, N - WA1(I) = WA1(I) - R(I,J)*TEMP - 190 CONTINUE - 200 CONTINUE - 210 CONTINUE - TEMP = ENORM(N,WA1) - PARC = ((FP/DELTA)/TEMP)/TEMP -C -C DEPENDING ON THE SIGN OF THE FUNCTION, UPDATE PARL OR PARU. -C - IF (FP .GT. ZERO) PARL = DMAX1(PARL,PAR) - IF (FP .LT. ZERO) PARU = DMIN1(PARU,PAR) -C -C COMPUTE AN IMPROVED ESTIMATE FOR PAR. -C - PAR = DMAX1(PARL,PAR+PARC) -C -C END OF AN ITERATION. -C - GO TO 150 - 220 CONTINUE -C -C TERMINATION. -C - IF (ITER .EQ. 0) PAR = ZERO - RETURN -C -C LAST CARD OF SUBROUTINE LMPAR. -C - END - SUBROUTINE LMSTR(FCN,M,N,X,FVEC,FJAC,LDFJAC,FTOL,XTOL,GTOL, - * MAXFEV,DIAG,MODE,FACTOR,NPRINT,INFO,NFEV,NJEV, - * IPVT,QTF,WA1,WA2,WA3,WA4) - INTEGER M,N,LDFJAC,MAXFEV,MODE,NPRINT,INFO,NFEV,NJEV - INTEGER IPVT(N) - LOGICAL SING - DOUBLE PRECISION FTOL,XTOL,GTOL,FACTOR - DOUBLE PRECISION X(N),FVEC(M),FJAC(LDFJAC,N),DIAG(N),QTF(N), - * WA1(N),WA2(N),WA3(N),WA4(M) -C ********** -C -C SUBROUTINE LMSTR -C -C THE PURPOSE OF LMSTR IS TO MINIMIZE THE SUM OF THE SQUARES OF -C M NONLINEAR FUNCTIONS IN N VARIABLES BY A MODIFICATION OF -C THE LEVENBERG-MARQUARDT ALGORITHM WHICH USES MINIMAL STORAGE. -C THE USER MUST PROVIDE A SUBROUTINE WHICH CALCULATES THE -C FUNCTIONS AND THE ROWS OF THE JACOBIAN. -C -C THE SUBROUTINE STATEMENT IS -C -C SUBROUTINE LMSTR(FCN,M,N,X,FVEC,FJAC,LDFJAC,FTOL,XTOL,GTOL, -C MAXFEV,DIAG,MODE,FACTOR,NPRINT,INFO,NFEV, -C NJEV,IPVT,QTF,WA1,WA2,WA3,WA4) -C -C WHERE -C -C FCN IS THE NAME OF THE USER-SUPPLIED SUBROUTINE WHICH -C CALCULATES THE FUNCTIONS AND THE ROWS OF THE JACOBIAN. -C FCN MUST BE DECLARED IN AN EXTERNAL STATEMENT IN THE -C USER CALLING PROGRAM, AND SHOULD BE WRITTEN AS FOLLOWS. -C -C SUBROUTINE FCN(M,N,X,FVEC,FJROW,IFLAG) -C INTEGER M,N,IFLAG -C DOUBLE PRECISION X(N),FVEC(M),FJROW(N) -C ---------- -C IF IFLAG = 1 CALCULATE THE FUNCTIONS AT X AND -C RETURN THIS VECTOR IN FVEC. -C IF IFLAG = I CALCULATE THE (I-1)-ST ROW OF THE -C JACOBIAN AT X AND RETURN THIS VECTOR IN FJROW. -C ---------- -C RETURN -C END -C -C THE VALUE OF IFLAG SHOULD NOT BE CHANGED BY FCN UNLESS -C THE USER WANTS TO TERMINATE EXECUTION OF LMSTR. -C IN THIS CASE SET IFLAG TO A NEGATIVE INTEGER. -C -C M IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER -C OF FUNCTIONS. -C -C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER -C OF VARIABLES. N MUST NOT EXCEED M. -C -C X IS AN ARRAY OF LENGTH N. ON INPUT X MUST CONTAIN -C AN INITIAL ESTIMATE OF THE SOLUTION VECTOR. ON OUTPUT X -C CONTAINS THE FINAL ESTIMATE OF THE SOLUTION VECTOR. -C -C FVEC IS AN OUTPUT ARRAY OF LENGTH M WHICH CONTAINS -C THE FUNCTIONS EVALUATED AT THE OUTPUT X. -C -C FJAC IS AN OUTPUT N BY N ARRAY. THE UPPER TRIANGLE OF FJAC -C CONTAINS AN UPPER TRIANGULAR MATRIX R SUCH THAT -C -C T T T -C P *(JAC *JAC)*P = R *R, -C -C WHERE P IS A PERMUTATION MATRIX AND JAC IS THE FINAL -C CALCULATED JACOBIAN. COLUMN J OF P IS COLUMN IPVT(J) -C (SEE BELOW) OF THE IDENTITY MATRIX. THE LOWER TRIANGULAR -C PART OF FJAC CONTAINS INFORMATION GENERATED DURING -C THE COMPUTATION OF R. -C -C LDFJAC IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN N -C WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY FJAC. -C -C FTOL IS A NONNEGATIVE INPUT VARIABLE. TERMINATION -C OCCURS WHEN BOTH THE ACTUAL AND PREDICTED RELATIVE -C REDUCTIONS IN THE SUM OF SQUARES ARE AT MOST FTOL. -C THEREFORE, FTOL MEASURES THE RELATIVE ERROR DESIRED -C IN THE SUM OF SQUARES. -C -C XTOL IS A NONNEGATIVE INPUT VARIABLE. TERMINATION -C OCCURS WHEN THE RELATIVE ERROR BETWEEN TWO CONSECUTIVE -C ITERATES IS AT MOST XTOL. THEREFORE, XTOL MEASURES THE -C RELATIVE ERROR DESIRED IN THE APPROXIMATE SOLUTION. -C -C GTOL IS A NONNEGATIVE INPUT VARIABLE. TERMINATION -C OCCURS WHEN THE COSINE OF THE ANGLE BETWEEN FVEC AND -C ANY COLUMN OF THE JACOBIAN IS AT MOST GTOL IN ABSOLUTE -C VALUE. THEREFORE, GTOL MEASURES THE ORTHOGONALITY -C DESIRED BETWEEN THE FUNCTION VECTOR AND THE COLUMNS -C OF THE JACOBIAN. -C -C MAXFEV IS A POSITIVE INTEGER INPUT VARIABLE. TERMINATION -C OCCURS WHEN THE NUMBER OF CALLS TO FCN WITH IFLAG = 1 -C HAS REACHED MAXFEV. -C -C DIAG IS AN ARRAY OF LENGTH N. IF MODE = 1 (SEE -C BELOW), DIAG IS INTERNALLY SET. IF MODE = 2, DIAG -C MUST CONTAIN POSITIVE ENTRIES THAT SERVE AS -C MULTIPLICATIVE SCALE FACTORS FOR THE VARIABLES. -C -C MODE IS AN INTEGER INPUT VARIABLE. IF MODE = 1, THE -C VARIABLES WILL BE SCALED INTERNALLY. IF MODE = 2, -C THE SCALING IS SPECIFIED BY THE INPUT DIAG. OTHER -C VALUES OF MODE ARE EQUIVALENT TO MODE = 1. -C -C FACTOR IS A POSITIVE INPUT VARIABLE USED IN DETERMINING THE -C INITIAL STEP BOUND. THIS BOUND IS SET TO THE PRODUCT OF -C FACTOR AND THE EUCLIDEAN NORM OF DIAG*X IF NONZERO, OR ELSE -C TO FACTOR ITSELF. IN MOST CASES FACTOR SHOULD LIE IN THE -C INTERVAL (.1,100.). 100. IS A GENERALLY RECOMMENDED VALUE. -C -C NPRINT IS AN INTEGER INPUT VARIABLE THAT ENABLES CONTROLLED -C PRINTING OF ITERATES IF IT IS POSITIVE. IN THIS CASE, -C FCN IS CALLED WITH IFLAG = 0 AT THE BEGINNING OF THE FIRST -C ITERATION AND EVERY NPRINT ITERATIONS THEREAFTER AND -C IMMEDIATELY PRIOR TO RETURN, WITH X AND FVEC AVAILABLE -C FOR PRINTING. IF NPRINT IS NOT POSITIVE, NO SPECIAL CALLS -C OF FCN WITH IFLAG = 0 ARE MADE. -C -C INFO IS AN INTEGER OUTPUT VARIABLE. IF THE USER HAS -C TERMINATED EXECUTION, INFO IS SET TO THE (NEGATIVE) -C VALUE OF IFLAG. SEE DESCRIPTION OF FCN. OTHERWISE, -C INFO IS SET AS FOLLOWS. -C -C INFO = 0 IMPROPER INPUT PARAMETERS. -C -C INFO = 1 BOTH ACTUAL AND PREDICTED RELATIVE REDUCTIONS -C IN THE SUM OF SQUARES ARE AT MOST FTOL. -C -C INFO = 2 RELATIVE ERROR BETWEEN TWO CONSECUTIVE ITERATES -C IS AT MOST XTOL. -C -C INFO = 3 CONDITIONS FOR INFO = 1 AND INFO = 2 BOTH HOLD. -C -C INFO = 4 THE COSINE OF THE ANGLE BETWEEN FVEC AND ANY -C COLUMN OF THE JACOBIAN IS AT MOST GTOL IN -C ABSOLUTE VALUE. -C -C INFO = 5 NUMBER OF CALLS TO FCN WITH IFLAG = 1 HAS -C REACHED MAXFEV. -C -C INFO = 6 FTOL IS TOO SMALL. NO FURTHER REDUCTION IN -C THE SUM OF SQUARES IS POSSIBLE. -C -C INFO = 7 XTOL IS TOO SMALL. NO FURTHER IMPROVEMENT IN -C THE APPROXIMATE SOLUTION X IS POSSIBLE. -C -C INFO = 8 GTOL IS TOO SMALL. FVEC IS ORTHOGONAL TO THE -C COLUMNS OF THE JACOBIAN TO MACHINE PRECISION. -C -C NFEV IS AN INTEGER OUTPUT VARIABLE SET TO THE NUMBER OF -C CALLS TO FCN WITH IFLAG = 1. -C -C NJEV IS AN INTEGER OUTPUT VARIABLE SET TO THE NUMBER OF -C CALLS TO FCN WITH IFLAG = 2. -C -C IPVT IS AN INTEGER OUTPUT ARRAY OF LENGTH N. IPVT -C DEFINES A PERMUTATION MATRIX P SUCH THAT JAC*P = Q*R, -C WHERE JAC IS THE FINAL CALCULATED JACOBIAN, Q IS -C ORTHOGONAL (NOT STORED), AND R IS UPPER TRIANGULAR. -C COLUMN J OF P IS COLUMN IPVT(J) OF THE IDENTITY MATRIX. -C -C QTF IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS -C THE FIRST N ELEMENTS OF THE VECTOR (Q TRANSPOSE)*FVEC. -C -C WA1, WA2, AND WA3 ARE WORK ARRAYS OF LENGTH N. -C -C WA4 IS A WORK ARRAY OF LENGTH M. -C -C SUBPROGRAMS CALLED -C -C USER-SUPPLIED ...... FCN -C -C MINPACK-SUPPLIED ... DPMPAR,ENORM,LMPAR,QRFAC,RWUPDT -C -C FORTRAN-SUPPLIED ... DABS,DMAX1,DMIN1,DSQRT,MOD -C -C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. -C BURTON S. GARBOW, DUDLEY V. GOETSCHEL, KENNETH E. HILLSTROM, -C JORGE J. MORE -C -C ********** - INTEGER I,IFLAG,ITER,J,L - DOUBLE PRECISION ACTRED,DELTA,DIRDER,EPSMCH,FNORM,FNORM1,GNORM, - * ONE,PAR,PNORM,PRERED,P1,P5,P25,P75,P0001,RATIO, - * SUM,TEMP,TEMP1,TEMP2,XNORM,ZERO - DOUBLE PRECISION DPMPAR,ENORM - DATA ONE,P1,P5,P25,P75,P0001,ZERO - * /1.0D0,1.0D-1,5.0D-1,2.5D-1,7.5D-1,1.0D-4,0.0D0/ -C -C EPSMCH IS THE MACHINE PRECISION. -C - EPSMCH = DPMPAR(1) -C - INFO = 0 - IFLAG = 0 - NFEV = 0 - NJEV = 0 -C -C CHECK THE INPUT PARAMETERS FOR ERRORS. -C - IF (N .LE. 0 .OR. M .LT. N .OR. LDFJAC .LT. N - * .OR. FTOL .LT. ZERO .OR. XTOL .LT. ZERO .OR. GTOL .LT. ZERO - * .OR. MAXFEV .LE. 0 .OR. FACTOR .LE. ZERO) GO TO 340 - IF (MODE .NE. 2) GO TO 20 - DO 10 J = 1, N - IF (DIAG(J) .LE. ZERO) GO TO 340 - 10 CONTINUE - 20 CONTINUE -C -C EVALUATE THE FUNCTION AT THE STARTING POINT -C AND CALCULATE ITS NORM. -C - IFLAG = 1 - CALL FCN(M,N,X,FVEC,WA3,IFLAG) - NFEV = 1 - IF (IFLAG .LT. 0) GO TO 340 - FNORM = ENORM(M,FVEC) -C -C INITIALIZE LEVENBERG-MARQUARDT PARAMETER AND ITERATION COUNTER. -C - PAR = ZERO - ITER = 1 -C -C BEGINNING OF THE OUTER LOOP. -C - 30 CONTINUE -C -C IF REQUESTED, CALL FCN TO ENABLE PRINTING OF ITERATES. -C - IF (NPRINT .LE. 0) GO TO 40 - IFLAG = 0 - IF (MOD(ITER-1,NPRINT) .EQ. 0) CALL FCN(M,N,X,FVEC,WA3,IFLAG) - IF (IFLAG .LT. 0) GO TO 340 - 40 CONTINUE -C -C COMPUTE THE QR FACTORIZATION OF THE JACOBIAN MATRIX -C CALCULATED ONE ROW AT A TIME, WHILE SIMULTANEOUSLY -C FORMING (Q TRANSPOSE)*FVEC AND STORING THE FIRST -C N COMPONENTS IN QTF. -C - DO 60 J = 1, N - QTF(J) = ZERO - DO 50 I = 1, N - FJAC(I,J) = ZERO - 50 CONTINUE - 60 CONTINUE - IFLAG = 2 - DO 70 I = 1, M - CALL FCN(M,N,X,FVEC,WA3,IFLAG) - IF (IFLAG .LT. 0) GO TO 340 - TEMP = FVEC(I) - CALL RWUPDT(N,FJAC,LDFJAC,WA3,QTF,TEMP,WA1,WA2) - IFLAG = IFLAG + 1 - 70 CONTINUE - NJEV = NJEV + 1 -C -C IF THE JACOBIAN IS RANK DEFICIENT, CALL QRFAC TO -C REORDER ITS COLUMNS AND UPDATE THE COMPONENTS OF QTF. -C - SING = .FALSE. - DO 80 J = 1, N - IF (FJAC(J,J) .EQ. ZERO) SING = .TRUE. - IPVT(J) = J - WA2(J) = ENORM(J,FJAC(1,J)) - 80 CONTINUE - IF (.NOT.SING) GO TO 130 - CALL QRFAC(N,N,FJAC,LDFJAC,.TRUE.,IPVT,N,WA1,WA2,WA3) - DO 120 J = 1, N - IF (FJAC(J,J) .EQ. ZERO) GO TO 110 - SUM = ZERO - DO 90 I = J, N - SUM = SUM + FJAC(I,J)*QTF(I) - 90 CONTINUE - TEMP = -SUM/FJAC(J,J) - DO 100 I = J, N - QTF(I) = QTF(I) + FJAC(I,J)*TEMP - 100 CONTINUE - 110 CONTINUE - FJAC(J,J) = WA1(J) - 120 CONTINUE - 130 CONTINUE -C -C ON THE FIRST ITERATION AND IF MODE IS 1, SCALE ACCORDING -C TO THE NORMS OF THE COLUMNS OF THE INITIAL JACOBIAN. -C - IF (ITER .NE. 1) GO TO 170 - IF (MODE .EQ. 2) GO TO 150 - DO 140 J = 1, N - DIAG(J) = WA2(J) - IF (WA2(J) .EQ. ZERO) DIAG(J) = ONE - 140 CONTINUE - 150 CONTINUE -C -C ON THE FIRST ITERATION, CALCULATE THE NORM OF THE SCALED X -C AND INITIALIZE THE STEP BOUND DELTA. -C - DO 160 J = 1, N - WA3(J) = DIAG(J)*X(J) - 160 CONTINUE - XNORM = ENORM(N,WA3) - DELTA = FACTOR*XNORM - IF (DELTA .EQ. ZERO) DELTA = FACTOR - 170 CONTINUE -C -C COMPUTE THE NORM OF THE SCALED GRADIENT. -C - GNORM = ZERO - IF (FNORM .EQ. ZERO) GO TO 210 - DO 200 J = 1, N - L = IPVT(J) - IF (WA2(L) .EQ. ZERO) GO TO 190 - SUM = ZERO - DO 180 I = 1, J - SUM = SUM + FJAC(I,J)*(QTF(I)/FNORM) - 180 CONTINUE - GNORM = DMAX1(GNORM,DABS(SUM/WA2(L))) - 190 CONTINUE - 200 CONTINUE - 210 CONTINUE -C -C TEST FOR CONVERGENCE OF THE GRADIENT NORM. -C - IF (GNORM .LE. GTOL) INFO = 4 - IF (INFO .NE. 0) GO TO 340 -C -C RESCALE IF NECESSARY. -C - IF (MODE .EQ. 2) GO TO 230 - DO 220 J = 1, N - DIAG(J) = DMAX1(DIAG(J),WA2(J)) - 220 CONTINUE - 230 CONTINUE -C -C BEGINNING OF THE INNER LOOP. -C - 240 CONTINUE -C -C DETERMINE THE LEVENBERG-MARQUARDT PARAMETER. -C - CALL LMPAR(N,FJAC,LDFJAC,IPVT,DIAG,QTF,DELTA,PAR,WA1,WA2, - * WA3,WA4) -C -C STORE THE DIRECTION P AND X + P. CALCULATE THE NORM OF P. -C - DO 250 J = 1, N - WA1(J) = -WA1(J) - WA2(J) = X(J) + WA1(J) - WA3(J) = DIAG(J)*WA1(J) - 250 CONTINUE - PNORM = ENORM(N,WA3) -C -C ON THE FIRST ITERATION, ADJUST THE INITIAL STEP BOUND. -C - IF (ITER .EQ. 1) DELTA = DMIN1(DELTA,PNORM) -C -C EVALUATE THE FUNCTION AT X + P AND CALCULATE ITS NORM. -C - IFLAG = 1 - CALL FCN(M,N,WA2,WA4,WA3,IFLAG) - NFEV = NFEV + 1 - IF (IFLAG .LT. 0) GO TO 340 - FNORM1 = ENORM(M,WA4) -C -C COMPUTE THE SCALED ACTUAL REDUCTION. -C - ACTRED = -ONE - IF (P1*FNORM1 .LT. FNORM) ACTRED = ONE - (FNORM1/FNORM)**2 -C -C COMPUTE THE SCALED PREDICTED REDUCTION AND -C THE SCALED DIRECTIONAL DERIVATIVE. -C - DO 270 J = 1, N - WA3(J) = ZERO - L = IPVT(J) - TEMP = WA1(L) - DO 260 I = 1, J - WA3(I) = WA3(I) + FJAC(I,J)*TEMP - 260 CONTINUE - 270 CONTINUE - TEMP1 = ENORM(N,WA3)/FNORM - TEMP2 = (DSQRT(PAR)*PNORM)/FNORM - PRERED = TEMP1**2 + TEMP2**2/P5 - DIRDER = -(TEMP1**2 + TEMP2**2) -C -C COMPUTE THE RATIO OF THE ACTUAL TO THE PREDICTED -C REDUCTION. -C - RATIO = ZERO - IF (PRERED .NE. ZERO) RATIO = ACTRED/PRERED -C -C UPDATE THE STEP BOUND. -C - IF (RATIO .GT. P25) GO TO 280 - IF (ACTRED .GE. ZERO) TEMP = P5 - IF (ACTRED .LT. ZERO) - * TEMP = P5*DIRDER/(DIRDER + P5*ACTRED) - IF (P1*FNORM1 .GE. FNORM .OR. TEMP .LT. P1) TEMP = P1 - DELTA = TEMP*DMIN1(DELTA,PNORM/P1) - PAR = PAR/TEMP - GO TO 300 - 280 CONTINUE - IF (PAR .NE. ZERO .AND. RATIO .LT. P75) GO TO 290 - DELTA = PNORM/P5 - PAR = P5*PAR - 290 CONTINUE - 300 CONTINUE -C -C TEST FOR SUCCESSFUL ITERATION. -C - IF (RATIO .LT. P0001) GO TO 330 -C -C SUCCESSFUL ITERATION. UPDATE X, FVEC, AND THEIR NORMS. -C - DO 310 J = 1, N - X(J) = WA2(J) - WA2(J) = DIAG(J)*X(J) - 310 CONTINUE - DO 320 I = 1, M - FVEC(I) = WA4(I) - 320 CONTINUE - XNORM = ENORM(N,WA2) - FNORM = FNORM1 - ITER = ITER + 1 - 330 CONTINUE -C -C TESTS FOR CONVERGENCE. -C - IF (DABS(ACTRED) .LE. FTOL .AND. PRERED .LE. FTOL - * .AND. P5*RATIO .LE. ONE) INFO = 1 - IF (DELTA .LE. XTOL*XNORM) INFO = 2 - IF (DABS(ACTRED) .LE. FTOL .AND. PRERED .LE. FTOL - * .AND. P5*RATIO .LE. ONE .AND. INFO .EQ. 2) INFO = 3 - IF (INFO .NE. 0) GO TO 340 -C -C TESTS FOR TERMINATION AND STRINGENT TOLERANCES. -C - IF (NFEV .GE. MAXFEV) INFO = 5 - IF (DABS(ACTRED) .LE. EPSMCH .AND. PRERED .LE. EPSMCH - * .AND. P5*RATIO .LE. ONE) INFO = 6 - IF (DELTA .LE. EPSMCH*XNORM) INFO = 7 - IF (GNORM .LE. EPSMCH) INFO = 8 - IF (INFO .NE. 0) GO TO 340 -C -C END OF THE INNER LOOP. REPEAT IF ITERATION UNSUCCESSFUL. -C - IF (RATIO .LT. P0001) GO TO 240 -C -C END OF THE OUTER LOOP. -C - GO TO 30 - 340 CONTINUE -C -C TERMINATION, EITHER NORMAL OR USER IMPOSED. -C - IF (IFLAG .LT. 0) INFO = IFLAG - IFLAG = 0 - IF (NPRINT .GT. 0) CALL FCN(M,N,X,FVEC,WA3,IFLAG) - RETURN -C -C LAST CARD OF SUBROUTINE LMSTR. -C - END - SUBROUTINE LMSTR1(FCN,M,N,X,FVEC,FJAC,LDFJAC,TOL,INFO,IPVT,WA, - * LWA) - INTEGER M,N,LDFJAC,INFO,LWA - INTEGER IPVT(N) - DOUBLE PRECISION TOL - DOUBLE PRECISION X(N),FVEC(M),FJAC(LDFJAC,N),WA(LWA) - EXTERNAL FCN -C ********** -C -C SUBROUTINE LMSTR1 -C -C THE PURPOSE OF LMSTR1 IS TO MINIMIZE THE SUM OF THE SQUARES OF -C M NONLINEAR FUNCTIONS IN N VARIABLES BY A MODIFICATION OF -C THE LEVENBERG-MARQUARDT ALGORITHM WHICH USES MINIMAL STORAGE. -C THIS IS DONE BY USING THE MORE GENERAL LEAST-SQUARES SOLVER -C LMSTR. THE USER MUST PROVIDE A SUBROUTINE WHICH CALCULATES -C THE FUNCTIONS AND THE ROWS OF THE JACOBIAN. -C -C THE SUBROUTINE STATEMENT IS -C -C SUBROUTINE LMSTR1(FCN,M,N,X,FVEC,FJAC,LDFJAC,TOL,INFO, -C IPVT,WA,LWA) -C -C WHERE -C -C FCN IS THE NAME OF THE USER-SUPPLIED SUBROUTINE WHICH -C CALCULATES THE FUNCTIONS AND THE ROWS OF THE JACOBIAN. -C FCN MUST BE DECLARED IN AN EXTERNAL STATEMENT IN THE -C USER CALLING PROGRAM, AND SHOULD BE WRITTEN AS FOLLOWS. -C -C SUBROUTINE FCN(M,N,X,FVEC,FJROW,IFLAG) -C INTEGER M,N,IFLAG -C DOUBLE PRECISION X(N),FVEC(M),FJROW(N) -C ---------- -C IF IFLAG = 1 CALCULATE THE FUNCTIONS AT X AND -C RETURN THIS VECTOR IN FVEC. -C IF IFLAG = I CALCULATE THE (I-1)-ST ROW OF THE -C JACOBIAN AT X AND RETURN THIS VECTOR IN FJROW. -C ---------- -C RETURN -C END -C -C THE VALUE OF IFLAG SHOULD NOT BE CHANGED BY FCN UNLESS -C THE USER WANTS TO TERMINATE EXECUTION OF LMSTR1. -C IN THIS CASE SET IFLAG TO A NEGATIVE INTEGER. -C -C M IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER -C OF FUNCTIONS. -C -C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER -C OF VARIABLES. N MUST NOT EXCEED M. -C -C X IS AN ARRAY OF LENGTH N. ON INPUT X MUST CONTAIN -C AN INITIAL ESTIMATE OF THE SOLUTION VECTOR. ON OUTPUT X -C CONTAINS THE FINAL ESTIMATE OF THE SOLUTION VECTOR. -C -C FVEC IS AN OUTPUT ARRAY OF LENGTH M WHICH CONTAINS -C THE FUNCTIONS EVALUATED AT THE OUTPUT X. -C -C FJAC IS AN OUTPUT N BY N ARRAY. THE UPPER TRIANGLE OF FJAC -C CONTAINS AN UPPER TRIANGULAR MATRIX R SUCH THAT -C -C T T T -C P *(JAC *JAC)*P = R *R, -C -C WHERE P IS A PERMUTATION MATRIX AND JAC IS THE FINAL -C CALCULATED JACOBIAN. COLUMN J OF P IS COLUMN IPVT(J) -C (SEE BELOW) OF THE IDENTITY MATRIX. THE LOWER TRIANGULAR -C PART OF FJAC CONTAINS INFORMATION GENERATED DURING -C THE COMPUTATION OF R. -C -C LDFJAC IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN N -C WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY FJAC. -C -C TOL IS A NONNEGATIVE INPUT VARIABLE. TERMINATION OCCURS -C WHEN THE ALGORITHM ESTIMATES EITHER THAT THE RELATIVE -C ERROR IN THE SUM OF SQUARES IS AT MOST TOL OR THAT -C THE RELATIVE ERROR BETWEEN X AND THE SOLUTION IS AT -C MOST TOL. -C -C INFO IS AN INTEGER OUTPUT VARIABLE. IF THE USER HAS -C TERMINATED EXECUTION, INFO IS SET TO THE (NEGATIVE) -C VALUE OF IFLAG. SEE DESCRIPTION OF FCN. OTHERWISE, -C INFO IS SET AS FOLLOWS. -C -C INFO = 0 IMPROPER INPUT PARAMETERS. -C -C INFO = 1 ALGORITHM ESTIMATES THAT THE RELATIVE ERROR -C IN THE SUM OF SQUARES IS AT MOST TOL. -C -C INFO = 2 ALGORITHM ESTIMATES THAT THE RELATIVE ERROR -C BETWEEN X AND THE SOLUTION IS AT MOST TOL. -C -C INFO = 3 CONDITIONS FOR INFO = 1 AND INFO = 2 BOTH HOLD. -C -C INFO = 4 FVEC IS ORTHOGONAL TO THE COLUMNS OF THE -C JACOBIAN TO MACHINE PRECISION. -C -C INFO = 5 NUMBER OF CALLS TO FCN WITH IFLAG = 1 HAS -C REACHED 100*(N+1). -C -C INFO = 6 TOL IS TOO SMALL. NO FURTHER REDUCTION IN -C THE SUM OF SQUARES IS POSSIBLE. -C -C INFO = 7 TOL IS TOO SMALL. NO FURTHER IMPROVEMENT IN -C THE APPROXIMATE SOLUTION X IS POSSIBLE. -C -C IPVT IS AN INTEGER OUTPUT ARRAY OF LENGTH N. IPVT -C DEFINES A PERMUTATION MATRIX P SUCH THAT JAC*P = Q*R, -C WHERE JAC IS THE FINAL CALCULATED JACOBIAN, Q IS -C ORTHOGONAL (NOT STORED), AND R IS UPPER TRIANGULAR. -C COLUMN J OF P IS COLUMN IPVT(J) OF THE IDENTITY MATRIX. -C -C WA IS A WORK ARRAY OF LENGTH LWA. -C -C LWA IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN 5*N+M. -C -C SUBPROGRAMS CALLED -C -C USER-SUPPLIED ...... FCN -C -C MINPACK-SUPPLIED ... LMSTR -C -C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. -C BURTON S. GARBOW, DUDLEY V. GOETSCHEL, KENNETH E. HILLSTROM, -C JORGE J. MORE -C -C ********** - INTEGER MAXFEV,MODE,NFEV,NJEV,NPRINT - DOUBLE PRECISION FACTOR,FTOL,GTOL,XTOL,ZERO - DATA FACTOR,ZERO /1.0D2,0.0D0/ - INFO = 0 -C -C CHECK THE INPUT PARAMETERS FOR ERRORS. -C - IF (N .LE. 0 .OR. M .LT. N .OR. LDFJAC .LT. N .OR. TOL .LT. ZERO - * .OR. LWA .LT. 5*N + M) GO TO 10 -C -C CALL LMSTR. -C - MAXFEV = 100*(N + 1) - FTOL = TOL - XTOL = TOL - GTOL = ZERO - MODE = 1 - NPRINT = 0 - CALL LMSTR(FCN,M,N,X,FVEC,FJAC,LDFJAC,FTOL,XTOL,GTOL,MAXFEV, - * WA(1),MODE,FACTOR,NPRINT,INFO,NFEV,NJEV,IPVT,WA(N+1), - * WA(2*N+1),WA(3*N+1),WA(4*N+1),WA(5*N+1)) - IF (INFO .EQ. 8) INFO = 4 - 10 CONTINUE - RETURN -C -C LAST CARD OF SUBROUTINE LMSTR1. -C - END - SUBROUTINE QFORM(M,N,Q,LDQ,WA) - INTEGER M,N,LDQ - DOUBLE PRECISION Q(LDQ,M),WA(M) -C ********** -C -C SUBROUTINE QFORM -C -C THIS SUBROUTINE PROCEEDS FROM THE COMPUTED QR FACTORIZATION OF -C AN M BY N MATRIX A TO ACCUMULATE THE M BY M ORTHOGONAL MATRIX -C Q FROM ITS FACTORED FORM. -C -C THE SUBROUTINE STATEMENT IS -C -C SUBROUTINE QFORM(M,N,Q,LDQ,WA) -C -C WHERE -C -C M IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER -C OF ROWS OF A AND THE ORDER OF Q. -C -C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER -C OF COLUMNS OF A. -C -C Q IS AN M BY M ARRAY. ON INPUT THE FULL LOWER TRAPEZOID IN -C THE FIRST MIN(M,N) COLUMNS OF Q CONTAINS THE FACTORED FORM. -C ON OUTPUT Q HAS BEEN ACCUMULATED INTO A SQUARE MATRIX. -C -C LDQ IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN M -C WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY Q. -C -C WA IS A WORK ARRAY OF LENGTH M. -C -C SUBPROGRAMS CALLED -C -C FORTRAN-SUPPLIED ... MIN0 -C -C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. -C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE -C -C ********** - INTEGER I,J,JM1,K,L,MINMN,NP1 - DOUBLE PRECISION ONE,SUM,TEMP,ZERO - DATA ONE,ZERO /1.0D0,0.0D0/ -C -C ZERO OUT UPPER TRIANGLE OF Q IN THE FIRST MIN(M,N) COLUMNS. -C - MINMN = MIN0(M,N) - IF (MINMN .LT. 2) GO TO 30 - DO 20 J = 2, MINMN - JM1 = J - 1 - DO 10 I = 1, JM1 - Q(I,J) = ZERO - 10 CONTINUE - 20 CONTINUE - 30 CONTINUE -C -C INITIALIZE REMAINING COLUMNS TO THOSE OF THE IDENTITY MATRIX. -C - NP1 = N + 1 - IF (M .LT. NP1) GO TO 60 - DO 50 J = NP1, M - DO 40 I = 1, M - Q(I,J) = ZERO - 40 CONTINUE - Q(J,J) = ONE - 50 CONTINUE - 60 CONTINUE -C -C ACCUMULATE Q FROM ITS FACTORED FORM. -C - DO 120 L = 1, MINMN - K = MINMN - L + 1 - DO 70 I = K, M - WA(I) = Q(I,K) - Q(I,K) = ZERO - 70 CONTINUE - Q(K,K) = ONE - IF (WA(K) .EQ. ZERO) GO TO 110 - DO 100 J = K, M - SUM = ZERO - DO 80 I = K, M - SUM = SUM + Q(I,J)*WA(I) - 80 CONTINUE - TEMP = SUM/WA(K) - DO 90 I = K, M - Q(I,J) = Q(I,J) - TEMP*WA(I) - 90 CONTINUE - 100 CONTINUE - 110 CONTINUE - 120 CONTINUE - RETURN -C -C LAST CARD OF SUBROUTINE QFORM. -C - END - SUBROUTINE QRFAC(M,N,A,LDA,PIVOT,IPVT,LIPVT,RDIAG,ACNORM,WA) - INTEGER M,N,LDA,LIPVT - INTEGER IPVT(LIPVT) - LOGICAL PIVOT - DOUBLE PRECISION A(LDA,N),RDIAG(N),ACNORM(N),WA(N) -C ********** -C -C SUBROUTINE QRFAC -C -C THIS SUBROUTINE USES HOUSEHOLDER TRANSFORMATIONS WITH COLUMN -C PIVOTING (OPTIONAL) TO COMPUTE A QR FACTORIZATION OF THE -C M BY N MATRIX A. THAT IS, QRFAC DETERMINES AN ORTHOGONAL -C MATRIX Q, A PERMUTATION MATRIX P, AND AN UPPER TRAPEZOIDAL -C MATRIX R WITH DIAGONAL ELEMENTS OF NONINCREASING MAGNITUDE, -C SUCH THAT A*P = Q*R. THE HOUSEHOLDER TRANSFORMATION FOR -C COLUMN K, K = 1,2,...,MIN(M,N), IS OF THE FORM -C -C T -C I - (1/U(K))*U*U -C -C WHERE U HAS ZEROS IN THE FIRST K-1 POSITIONS. THE FORM OF -C THIS TRANSFORMATION AND THE METHOD OF PIVOTING FIRST -C APPEARED IN THE CORRESPONDING LINPACK SUBROUTINE. -C -C THE SUBROUTINE STATEMENT IS -C -C SUBROUTINE QRFAC(M,N,A,LDA,PIVOT,IPVT,LIPVT,RDIAG,ACNORM,WA) -C -C WHERE -C -C M IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER -C OF ROWS OF A. -C -C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER -C OF COLUMNS OF A. -C -C A IS AN M BY N ARRAY. ON INPUT A CONTAINS THE MATRIX FOR -C WHICH THE QR FACTORIZATION IS TO BE COMPUTED. ON OUTPUT -C THE STRICT UPPER TRAPEZOIDAL PART OF A CONTAINS THE STRICT -C UPPER TRAPEZOIDAL PART OF R, AND THE LOWER TRAPEZOIDAL -C PART OF A CONTAINS A FACTORED FORM OF Q (THE NON-TRIVIAL -C ELEMENTS OF THE U VECTORS DESCRIBED ABOVE). -C -C LDA IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN M -C WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY A. -C -C PIVOT IS A LOGICAL INPUT VARIABLE. IF PIVOT IS SET TRUE, -C THEN COLUMN PIVOTING IS ENFORCED. IF PIVOT IS SET FALSE, -C THEN NO COLUMN PIVOTING IS DONE. -C -C IPVT IS AN INTEGER OUTPUT ARRAY OF LENGTH LIPVT. IPVT -C DEFINES THE PERMUTATION MATRIX P SUCH THAT A*P = Q*R. -C COLUMN J OF P IS COLUMN IPVT(J) OF THE IDENTITY MATRIX. -C IF PIVOT IS FALSE, IPVT IS NOT REFERENCED. -C -C LIPVT IS A POSITIVE INTEGER INPUT VARIABLE. IF PIVOT IS FALSE, -C THEN LIPVT MAY BE AS SMALL AS 1. IF PIVOT IS TRUE, THEN -C LIPVT MUST BE AT LEAST N. -C -C RDIAG IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE -C DIAGONAL ELEMENTS OF R. -C -C ACNORM IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE -C NORMS OF THE CORRESPONDING COLUMNS OF THE INPUT MATRIX A. -C IF THIS INFORMATION IS NOT NEEDED, THEN ACNORM CAN COINCIDE -C WITH RDIAG. -C -C WA IS A WORK ARRAY OF LENGTH N. IF PIVOT IS FALSE, THEN WA -C CAN COINCIDE WITH RDIAG. -C -C SUBPROGRAMS CALLED -C -C MINPACK-SUPPLIED ... DPMPAR,ENORM -C -C FORTRAN-SUPPLIED ... DMAX1,DSQRT,MIN0 -C -C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. -C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE -C -C ********** - INTEGER I,J,JP1,K,KMAX,MINMN - DOUBLE PRECISION AJNORM,EPSMCH,ONE,P05,SUM,TEMP,ZERO - DOUBLE PRECISION DPMPAR,ENORM - DATA ONE,P05,ZERO /1.0D0,5.0D-2,0.0D0/ -C -C EPSMCH IS THE MACHINE PRECISION. -C - EPSMCH = DPMPAR(1) -C -C COMPUTE THE INITIAL COLUMN NORMS AND INITIALIZE SEVERAL ARRAYS. -C - DO 10 J = 1, N - ACNORM(J) = ENORM(M,A(1,J)) - RDIAG(J) = ACNORM(J) - WA(J) = RDIAG(J) - IF (PIVOT) IPVT(J) = J - 10 CONTINUE -C -C REDUCE A TO R WITH HOUSEHOLDER TRANSFORMATIONS. -C - MINMN = MIN0(M,N) - DO 110 J = 1, MINMN - IF (.NOT.PIVOT) GO TO 40 -C -C BRING THE COLUMN OF LARGEST NORM INTO THE PIVOT POSITION. -C - KMAX = J - DO 20 K = J, N - IF (RDIAG(K) .GT. RDIAG(KMAX)) KMAX = K - 20 CONTINUE - IF (KMAX .EQ. J) GO TO 40 - DO 30 I = 1, M - TEMP = A(I,J) - A(I,J) = A(I,KMAX) - A(I,KMAX) = TEMP - 30 CONTINUE - RDIAG(KMAX) = RDIAG(J) - WA(KMAX) = WA(J) - K = IPVT(J) - IPVT(J) = IPVT(KMAX) - IPVT(KMAX) = K - 40 CONTINUE -C -C COMPUTE THE HOUSEHOLDER TRANSFORMATION TO REDUCE THE -C J-TH COLUMN OF A TO A MULTIPLE OF THE J-TH UNIT VECTOR. -C - AJNORM = ENORM(M-J+1,A(J,J)) - IF (AJNORM .EQ. ZERO) GO TO 100 - IF (A(J,J) .LT. ZERO) AJNORM = -AJNORM - DO 50 I = J, M - A(I,J) = A(I,J)/AJNORM - 50 CONTINUE - A(J,J) = A(J,J) + ONE -C -C APPLY THE TRANSFORMATION TO THE REMAINING COLUMNS -C AND UPDATE THE NORMS. -C - JP1 = J + 1 - IF (N .LT. JP1) GO TO 100 - DO 90 K = JP1, N - SUM = ZERO - DO 60 I = J, M - SUM = SUM + A(I,J)*A(I,K) - 60 CONTINUE - TEMP = SUM/A(J,J) - DO 70 I = J, M - A(I,K) = A(I,K) - TEMP*A(I,J) - 70 CONTINUE - IF (.NOT.PIVOT .OR. RDIAG(K) .EQ. ZERO) GO TO 80 - TEMP = A(J,K)/RDIAG(K) - RDIAG(K) = RDIAG(K)*DSQRT(DMAX1(ZERO,ONE-TEMP**2)) - IF (P05*(RDIAG(K)/WA(K))**2 .GT. EPSMCH) GO TO 80 - RDIAG(K) = ENORM(M-J,A(JP1,K)) - WA(K) = RDIAG(K) - 80 CONTINUE - 90 CONTINUE - 100 CONTINUE - RDIAG(J) = -AJNORM - 110 CONTINUE - RETURN -C -C LAST CARD OF SUBROUTINE QRFAC. -C - END - SUBROUTINE QRSOLV(N,R,LDR,IPVT,DIAG,QTB,X,SDIAG,WA) - INTEGER N,LDR - INTEGER IPVT(N) - DOUBLE PRECISION R(LDR,N),DIAG(N),QTB(N),X(N),SDIAG(N),WA(N) -C ********** -C -C SUBROUTINE QRSOLV -C -C GIVEN AN M BY N MATRIX A, AN N BY N DIAGONAL MATRIX D, -C AND AN M-VECTOR B, THE PROBLEM IS TO DETERMINE AN X WHICH -C SOLVES THE SYSTEM -C -C A*X = B , D*X = 0 , -C -C IN THE LEAST SQUARES SENSE. -C -C THIS SUBROUTINE COMPLETES THE SOLUTION OF THE PROBLEM -C IF IT IS PROVIDED WITH THE NECESSARY INFORMATION FROM THE -C QR FACTORIZATION, WITH COLUMN PIVOTING, OF A. THAT IS, IF -C A*P = Q*R, WHERE P IS A PERMUTATION MATRIX, Q HAS ORTHOGONAL -C COLUMNS, AND R IS AN UPPER TRIANGULAR MATRIX WITH DIAGONAL -C ELEMENTS OF NONINCREASING MAGNITUDE, THEN QRSOLV EXPECTS -C THE FULL UPPER TRIANGLE OF R, THE PERMUTATION MATRIX P, -C AND THE FIRST N COMPONENTS OF (Q TRANSPOSE)*B. THE SYSTEM -C A*X = B, D*X = 0, IS THEN EQUIVALENT TO -C -C T T -C R*Z = Q *B , P *D*P*Z = 0 , -C -C WHERE X = P*Z. IF THIS SYSTEM DOES NOT HAVE FULL RANK, -C THEN A LEAST SQUARES SOLUTION IS OBTAINED. ON OUTPUT QRSOLV -C ALSO PROVIDES AN UPPER TRIANGULAR MATRIX S SUCH THAT -C -C T T T -C P *(A *A + D*D)*P = S *S . -C -C S IS COMPUTED WITHIN QRSOLV AND MAY BE OF SEPARATE INTEREST. -C -C THE SUBROUTINE STATEMENT IS -C -C SUBROUTINE QRSOLV(N,R,LDR,IPVT,DIAG,QTB,X,SDIAG,WA) -C -C WHERE -C -C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE ORDER OF R. -C -C R IS AN N BY N ARRAY. ON INPUT THE FULL UPPER TRIANGLE -C MUST CONTAIN THE FULL UPPER TRIANGLE OF THE MATRIX R. -C ON OUTPUT THE FULL UPPER TRIANGLE IS UNALTERED, AND THE -C STRICT LOWER TRIANGLE CONTAINS THE STRICT UPPER TRIANGLE -C (TRANSPOSED) OF THE UPPER TRIANGULAR MATRIX S. -C -C LDR IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN N -C WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY R. -C -C IPVT IS AN INTEGER INPUT ARRAY OF LENGTH N WHICH DEFINES THE -C PERMUTATION MATRIX P SUCH THAT A*P = Q*R. COLUMN J OF P -C IS COLUMN IPVT(J) OF THE IDENTITY MATRIX. -C -C DIAG IS AN INPUT ARRAY OF LENGTH N WHICH MUST CONTAIN THE -C DIAGONAL ELEMENTS OF THE MATRIX D. -C -C QTB IS AN INPUT ARRAY OF LENGTH N WHICH MUST CONTAIN THE FIRST -C N ELEMENTS OF THE VECTOR (Q TRANSPOSE)*B. -C -C X IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE LEAST -C SQUARES SOLUTION OF THE SYSTEM A*X = B, D*X = 0. -C -C SDIAG IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE -C DIAGONAL ELEMENTS OF THE UPPER TRIANGULAR MATRIX S. -C -C WA IS A WORK ARRAY OF LENGTH N. -C -C SUBPROGRAMS CALLED -C -C FORTRAN-SUPPLIED ... DABS,DSQRT -C -C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. -C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE -C -C ********** - INTEGER I,J,JP1,K,KP1,L,NSING - DOUBLE PRECISION COS,COTAN,P5,P25,QTBPJ,SIN,SUM,TAN,TEMP,ZERO - DATA P5,P25,ZERO /5.0D-1,2.5D-1,0.0D0/ -C -C COPY R AND (Q TRANSPOSE)*B TO PRESERVE INPUT AND INITIALIZE S. -C IN PARTICULAR, SAVE THE DIAGONAL ELEMENTS OF R IN X. -C - DO 20 J = 1, N - DO 10 I = J, N - R(I,J) = R(J,I) - 10 CONTINUE - X(J) = R(J,J) - WA(J) = QTB(J) - 20 CONTINUE -C -C ELIMINATE THE DIAGONAL MATRIX D USING A GIVENS ROTATION. -C - DO 100 J = 1, N -C -C PREPARE THE ROW OF D TO BE ELIMINATED, LOCATING THE -C DIAGONAL ELEMENT USING P FROM THE QR FACTORIZATION. -C - L = IPVT(J) - IF (DIAG(L) .EQ. ZERO) GO TO 90 - DO 30 K = J, N - SDIAG(K) = ZERO - 30 CONTINUE - SDIAG(J) = DIAG(L) -C -C THE TRANSFORMATIONS TO ELIMINATE THE ROW OF D -C MODIFY ONLY A SINGLE ELEMENT OF (Q TRANSPOSE)*B -C BEYOND THE FIRST N, WHICH IS INITIALLY ZERO. -C - QTBPJ = ZERO - DO 80 K = J, N -C -C DETERMINE A GIVENS ROTATION WHICH ELIMINATES THE -C APPROPRIATE ELEMENT IN THE CURRENT ROW OF D. -C - IF (SDIAG(K) .EQ. ZERO) GO TO 70 - IF (DABS(R(K,K)) .GE. DABS(SDIAG(K))) GO TO 40 - COTAN = R(K,K)/SDIAG(K) - SIN = P5/DSQRT(P25+P25*COTAN**2) - COS = SIN*COTAN - GO TO 50 - 40 CONTINUE - TAN = SDIAG(K)/R(K,K) - COS = P5/DSQRT(P25+P25*TAN**2) - SIN = COS*TAN - 50 CONTINUE -C -C COMPUTE THE MODIFIED DIAGONAL ELEMENT OF R AND -C THE MODIFIED ELEMENT OF ((Q TRANSPOSE)*B,0). -C - R(K,K) = COS*R(K,K) + SIN*SDIAG(K) - TEMP = COS*WA(K) + SIN*QTBPJ - QTBPJ = -SIN*WA(K) + COS*QTBPJ - WA(K) = TEMP -C -C ACCUMULATE THE TRANFORMATION IN THE ROW OF S. -C - KP1 = K + 1 - IF (N .LT. KP1) GO TO 70 - DO 60 I = KP1, N - TEMP = COS*R(I,K) + SIN*SDIAG(I) - SDIAG(I) = -SIN*R(I,K) + COS*SDIAG(I) - R(I,K) = TEMP - 60 CONTINUE - 70 CONTINUE - 80 CONTINUE - 90 CONTINUE -C -C STORE THE DIAGONAL ELEMENT OF S AND RESTORE -C THE CORRESPONDING DIAGONAL ELEMENT OF R. -C - SDIAG(J) = R(J,J) - R(J,J) = X(J) - 100 CONTINUE -C -C SOLVE THE TRIANGULAR SYSTEM FOR Z. IF THE SYSTEM IS -C SINGULAR, THEN OBTAIN A LEAST SQUARES SOLUTION. -C - NSING = N - DO 110 J = 1, N - IF (SDIAG(J) .EQ. ZERO .AND. NSING .EQ. N) NSING = J - 1 - IF (NSING .LT. N) WA(J) = ZERO - 110 CONTINUE - IF (NSING .LT. 1) GO TO 150 - DO 140 K = 1, NSING - J = NSING - K + 1 - SUM = ZERO - JP1 = J + 1 - IF (NSING .LT. JP1) GO TO 130 - DO 120 I = JP1, NSING - SUM = SUM + R(I,J)*WA(I) - 120 CONTINUE - 130 CONTINUE - WA(J) = (WA(J) - SUM)/SDIAG(J) - 140 CONTINUE - 150 CONTINUE -C -C PERMUTE THE COMPONENTS OF Z BACK TO COMPONENTS OF X. -C - DO 160 J = 1, N - L = IPVT(J) - X(L) = WA(J) - 160 CONTINUE - RETURN -C -C LAST CARD OF SUBROUTINE QRSOLV. -C - END - SUBROUTINE RWUPDT(N,R,LDR,W,B,ALPHA,COS,SIN) - INTEGER N,LDR - DOUBLE PRECISION ALPHA - DOUBLE PRECISION R(LDR,N),W(N),B(N),COS(N),SIN(N) -C ********** -C -C SUBROUTINE RWUPDT -C -C GIVEN AN N BY N UPPER TRIANGULAR MATRIX R, THIS SUBROUTINE -C COMPUTES THE QR DECOMPOSITION OF THE MATRIX FORMED WHEN A ROW -C IS ADDED TO R. IF THE ROW IS SPECIFIED BY THE VECTOR W, THEN -C RWUPDT DETERMINES AN ORTHOGONAL MATRIX Q SUCH THAT WHEN THE -C N+1 BY N MATRIX COMPOSED OF R AUGMENTED BY W IS PREMULTIPLIED -C BY (Q TRANSPOSE), THE RESULTING MATRIX IS UPPER TRAPEZOIDAL. -C THE MATRIX (Q TRANSPOSE) IS THE PRODUCT OF N TRANSFORMATIONS -C -C G(N)*G(N-1)* ... *G(1) -C -C WHERE G(I) IS A GIVENS ROTATION IN THE (I,N+1) PLANE WHICH -C ELIMINATES ELEMENTS IN THE (N+1)-ST PLANE. RWUPDT ALSO -C COMPUTES THE PRODUCT (Q TRANSPOSE)*C WHERE C IS THE -C (N+1)-VECTOR (B,ALPHA). Q ITSELF IS NOT ACCUMULATED, RATHER -C THE INFORMATION TO RECOVER THE G ROTATIONS IS SUPPLIED. -C -C THE SUBROUTINE STATEMENT IS -C -C SUBROUTINE RWUPDT(N,R,LDR,W,B,ALPHA,COS,SIN) -C -C WHERE -C -C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE ORDER OF R. -C -C R IS AN N BY N ARRAY. ON INPUT THE UPPER TRIANGULAR PART OF -C R MUST CONTAIN THE MATRIX TO BE UPDATED. ON OUTPUT R -C CONTAINS THE UPDATED TRIANGULAR MATRIX. -C -C LDR IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN N -C WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY R. -C -C W IS AN INPUT ARRAY OF LENGTH N WHICH MUST CONTAIN THE ROW -C VECTOR TO BE ADDED TO R. -C -C B IS AN ARRAY OF LENGTH N. ON INPUT B MUST CONTAIN THE -C FIRST N ELEMENTS OF THE VECTOR C. ON OUTPUT B CONTAINS -C THE FIRST N ELEMENTS OF THE VECTOR (Q TRANSPOSE)*C. -C -C ALPHA IS A VARIABLE. ON INPUT ALPHA MUST CONTAIN THE -C (N+1)-ST ELEMENT OF THE VECTOR C. ON OUTPUT ALPHA CONTAINS -C THE (N+1)-ST ELEMENT OF THE VECTOR (Q TRANSPOSE)*C. -C -C COS IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE -C COSINES OF THE TRANSFORMING GIVENS ROTATIONS. -C -C SIN IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE -C SINES OF THE TRANSFORMING GIVENS ROTATIONS. -C -C SUBPROGRAMS CALLED -C -C FORTRAN-SUPPLIED ... DABS,DSQRT -C -C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. -C BURTON S. GARBOW, DUDLEY V. GOETSCHEL, KENNETH E. HILLSTROM, -C JORGE J. MORE -C -C ********** - INTEGER I,J,JM1 - DOUBLE PRECISION COTAN,ONE,P5,P25,ROWJ,TAN,TEMP,ZERO - DATA ONE,P5,P25,ZERO /1.0D0,5.0D-1,2.5D-1,0.0D0/ -C - DO 60 J = 1, N - ROWJ = W(J) - JM1 = J - 1 -C -C APPLY THE PREVIOUS TRANSFORMATIONS TO -C R(I,J), I=1,2,...,J-1, AND TO W(J). -C - IF (JM1 .LT. 1) GO TO 20 - DO 10 I = 1, JM1 - TEMP = COS(I)*R(I,J) + SIN(I)*ROWJ - ROWJ = -SIN(I)*R(I,J) + COS(I)*ROWJ - R(I,J) = TEMP - 10 CONTINUE - 20 CONTINUE -C -C DETERMINE A GIVENS ROTATION WHICH ELIMINATES W(J). -C - COS(J) = ONE - SIN(J) = ZERO - IF (ROWJ .EQ. ZERO) GO TO 50 - IF (DABS(R(J,J)) .GE. DABS(ROWJ)) GO TO 30 - COTAN = R(J,J)/ROWJ - SIN(J) = P5/DSQRT(P25+P25*COTAN**2) - COS(J) = SIN(J)*COTAN - GO TO 40 - 30 CONTINUE - TAN = ROWJ/R(J,J) - COS(J) = P5/DSQRT(P25+P25*TAN**2) - SIN(J) = COS(J)*TAN - 40 CONTINUE -C -C APPLY THE CURRENT TRANSFORMATION TO R(J,J), B(J), AND ALPHA. -C - R(J,J) = COS(J)*R(J,J) + SIN(J)*ROWJ - TEMP = COS(J)*B(J) + SIN(J)*ALPHA - ALPHA = -SIN(J)*B(J) + COS(J)*ALPHA - B(J) = TEMP - 50 CONTINUE - 60 CONTINUE - RETURN -C -C LAST CARD OF SUBROUTINE RWUPDT. -C - END - SUBROUTINE R1MPYQ(M,N,A,LDA,V,W) - INTEGER M,N,LDA - DOUBLE PRECISION A(LDA,N),V(N),W(N) -C ********** -C -C SUBROUTINE R1MPYQ -C -C GIVEN AN M BY N MATRIX A, THIS SUBROUTINE COMPUTES A*Q WHERE -C Q IS THE PRODUCT OF 2*(N - 1) TRANSFORMATIONS -C -C GV(N-1)*...*GV(1)*GW(1)*...*GW(N-1) -C -C AND GV(I), GW(I) ARE GIVENS ROTATIONS IN THE (I,N) PLANE WHICH -C ELIMINATE ELEMENTS IN THE I-TH AND N-TH PLANES, RESPECTIVELY. -C Q ITSELF IS NOT GIVEN, RATHER THE INFORMATION TO RECOVER THE -C GV, GW ROTATIONS IS SUPPLIED. -C -C THE SUBROUTINE STATEMENT IS -C -C SUBROUTINE R1MPYQ(M,N,A,LDA,V,W) -C -C WHERE -C -C M IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER -C OF ROWS OF A. -C -C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER -C OF COLUMNS OF A. -C -C A IS AN M BY N ARRAY. ON INPUT A MUST CONTAIN THE MATRIX -C TO BE POSTMULTIPLIED BY THE ORTHOGONAL MATRIX Q -C DESCRIBED ABOVE. ON OUTPUT A*Q HAS REPLACED A. -C -C LDA IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN M -C WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY A. -C -C V IS AN INPUT ARRAY OF LENGTH N. V(I) MUST CONTAIN THE -C INFORMATION NECESSARY TO RECOVER THE GIVENS ROTATION GV(I) -C DESCRIBED ABOVE. -C -C W IS AN INPUT ARRAY OF LENGTH N. W(I) MUST CONTAIN THE -C INFORMATION NECESSARY TO RECOVER THE GIVENS ROTATION GW(I) -C DESCRIBED ABOVE. -C -C SUBROUTINES CALLED -C -C FORTRAN-SUPPLIED ... DABS,DSQRT -C -C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. -C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE -C -C ********** - INTEGER I,J,NMJ,NM1 - DOUBLE PRECISION COS,ONE,SIN,TEMP - DATA ONE /1.0D0/ -C -C APPLY THE FIRST SET OF GIVENS ROTATIONS TO A. -C - NM1 = N - 1 - IF (NM1 .LT. 1) GO TO 50 - DO 20 NMJ = 1, NM1 - J = N - NMJ - IF (DABS(V(J)) .GT. ONE) COS = ONE/V(J) - IF (DABS(V(J)) .GT. ONE) SIN = DSQRT(ONE-COS**2) - IF (DABS(V(J)) .LE. ONE) SIN = V(J) - IF (DABS(V(J)) .LE. ONE) COS = DSQRT(ONE-SIN**2) - DO 10 I = 1, M - TEMP = COS*A(I,J) - SIN*A(I,N) - A(I,N) = SIN*A(I,J) + COS*A(I,N) - A(I,J) = TEMP - 10 CONTINUE - 20 CONTINUE -C -C APPLY THE SECOND SET OF GIVENS ROTATIONS TO A. -C - DO 40 J = 1, NM1 - IF (DABS(W(J)) .GT. ONE) COS = ONE/W(J) - IF (DABS(W(J)) .GT. ONE) SIN = DSQRT(ONE-COS**2) - IF (DABS(W(J)) .LE. ONE) SIN = W(J) - IF (DABS(W(J)) .LE. ONE) COS = DSQRT(ONE-SIN**2) - DO 30 I = 1, M - TEMP = COS*A(I,J) + SIN*A(I,N) - A(I,N) = -SIN*A(I,J) + COS*A(I,N) - A(I,J) = TEMP - 30 CONTINUE - 40 CONTINUE - 50 CONTINUE - RETURN -C -C LAST CARD OF SUBROUTINE R1MPYQ. -C - END - SUBROUTINE R1UPDT(M,N,S,LS,U,V,W,SING) - INTEGER M,N,LS - LOGICAL SING - DOUBLE PRECISION S(LS),U(M),V(N),W(M) -C ********** -C -C SUBROUTINE R1UPDT -C -C GIVEN AN M BY N LOWER TRAPEZOIDAL MATRIX S, AN M-VECTOR U, -C AND AN N-VECTOR V, THE PROBLEM IS TO DETERMINE AN -C ORTHOGONAL MATRIX Q SUCH THAT -C -C T -C (S + U*V )*Q -C -C IS AGAIN LOWER TRAPEZOIDAL. -C -C THIS SUBROUTINE DETERMINES Q AS THE PRODUCT OF 2*(N - 1) -C TRANSFORMATIONS -C -C GV(N-1)*...*GV(1)*GW(1)*...*GW(N-1) -C -C WHERE GV(I), GW(I) ARE GIVENS ROTATIONS IN THE (I,N) PLANE -C WHICH ELIMINATE ELEMENTS IN THE I-TH AND N-TH PLANES, -C RESPECTIVELY. Q ITSELF IS NOT ACCUMULATED, RATHER THE -C INFORMATION TO RECOVER THE GV, GW ROTATIONS IS RETURNED. -C -C THE SUBROUTINE STATEMENT IS -C -C SUBROUTINE R1UPDT(M,N,S,LS,U,V,W,SING) -C -C WHERE -C -C M IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER -C OF ROWS OF S. -C -C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER -C OF COLUMNS OF S. N MUST NOT EXCEED M. -C -C S IS AN ARRAY OF LENGTH LS. ON INPUT S MUST CONTAIN THE LOWER -C TRAPEZOIDAL MATRIX S STORED BY COLUMNS. ON OUTPUT S CONTAINS -C THE LOWER TRAPEZOIDAL MATRIX PRODUCED AS DESCRIBED ABOVE. -C -C LS IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN -C (N*(2*M-N+1))/2. -C -C U IS AN INPUT ARRAY OF LENGTH M WHICH MUST CONTAIN THE -C VECTOR U. -C -C V IS AN ARRAY OF LENGTH N. ON INPUT V MUST CONTAIN THE VECTOR -C V. ON OUTPUT V(I) CONTAINS THE INFORMATION NECESSARY TO -C RECOVER THE GIVENS ROTATION GV(I) DESCRIBED ABOVE. -C -C W IS AN OUTPUT ARRAY OF LENGTH M. W(I) CONTAINS INFORMATION -C NECESSARY TO RECOVER THE GIVENS ROTATION GW(I) DESCRIBED -C ABOVE. -C -C SING IS A LOGICAL OUTPUT VARIABLE. SING IS SET TRUE IF ANY -C OF THE DIAGONAL ELEMENTS OF THE OUTPUT S ARE ZERO. OTHERWISE -C SING IS SET FALSE. -C -C SUBPROGRAMS CALLED -C -C MINPACK-SUPPLIED ... DPMPAR -C -C FORTRAN-SUPPLIED ... DABS,DSQRT -C -C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. -C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE, -C JOHN L. NAZARETH -C -C ********** - INTEGER I,J,JJ,L,NMJ,NM1 - DOUBLE PRECISION COS,COTAN,GIANT,ONE,P5,P25,SIN,TAN,TAU,TEMP, - * ZERO - DOUBLE PRECISION DPMPAR - DATA ONE,P5,P25,ZERO /1.0D0,5.0D-1,2.5D-1,0.0D0/ -C -C GIANT IS THE LARGEST MAGNITUDE. -C - GIANT = DPMPAR(3) -C -C INITIALIZE THE DIAGONAL ELEMENT POINTER. -C - JJ = (N*(2*M - N + 1))/2 - (M - N) -C -C MOVE THE NONTRIVIAL PART OF THE LAST COLUMN OF S INTO W. -C - L = JJ - DO 10 I = N, M - W(I) = S(L) - L = L + 1 - 10 CONTINUE -C -C ROTATE THE VECTOR V INTO A MULTIPLE OF THE N-TH UNIT VECTOR -C IN SUCH A WAY THAT A SPIKE IS INTRODUCED INTO W. -C - NM1 = N - 1 - IF (NM1 .LT. 1) GO TO 70 - DO 60 NMJ = 1, NM1 - J = N - NMJ - JJ = JJ - (M - J + 1) - W(J) = ZERO - IF (V(J) .EQ. ZERO) GO TO 50 -C -C DETERMINE A GIVENS ROTATION WHICH ELIMINATES THE -C J-TH ELEMENT OF V. -C - IF (DABS(V(N)) .GE. DABS(V(J))) GO TO 20 - COTAN = V(N)/V(J) - SIN = P5/DSQRT(P25+P25*COTAN**2) - COS = SIN*COTAN - TAU = ONE - IF (DABS(COS)*GIANT .GT. ONE) TAU = ONE/COS - GO TO 30 - 20 CONTINUE - TAN = V(J)/V(N) - COS = P5/DSQRT(P25+P25*TAN**2) - SIN = COS*TAN - TAU = SIN - 30 CONTINUE -C -C APPLY THE TRANSFORMATION TO V AND STORE THE INFORMATION -C NECESSARY TO RECOVER THE GIVENS ROTATION. -C - V(N) = SIN*V(J) + COS*V(N) - V(J) = TAU -C -C APPLY THE TRANSFORMATION TO S AND EXTEND THE SPIKE IN W. -C - L = JJ - DO 40 I = J, M - TEMP = COS*S(L) - SIN*W(I) - W(I) = SIN*S(L) + COS*W(I) - S(L) = TEMP - L = L + 1 - 40 CONTINUE - 50 CONTINUE - 60 CONTINUE - 70 CONTINUE -C -C ADD THE SPIKE FROM THE RANK 1 UPDATE TO W. -C - DO 80 I = 1, M - W(I) = W(I) + V(N)*U(I) - 80 CONTINUE -C -C ELIMINATE THE SPIKE. -C - SING = .FALSE. - IF (NM1 .LT. 1) GO TO 140 - DO 130 J = 1, NM1 - IF (W(J) .EQ. ZERO) GO TO 120 -C -C DETERMINE A GIVENS ROTATION WHICH ELIMINATES THE -C J-TH ELEMENT OF THE SPIKE. -C - IF (DABS(S(JJ)) .GE. DABS(W(J))) GO TO 90 - COTAN = S(JJ)/W(J) - SIN = P5/DSQRT(P25+P25*COTAN**2) - COS = SIN*COTAN - TAU = ONE - IF (DABS(COS)*GIANT .GT. ONE) TAU = ONE/COS - GO TO 100 - 90 CONTINUE - TAN = W(J)/S(JJ) - COS = P5/DSQRT(P25+P25*TAN**2) - SIN = COS*TAN - TAU = SIN - 100 CONTINUE -C -C APPLY THE TRANSFORMATION TO S AND REDUCE THE SPIKE IN W. -C - L = JJ - DO 110 I = J, M - TEMP = COS*S(L) + SIN*W(I) - W(I) = -SIN*S(L) + COS*W(I) - S(L) = TEMP - L = L + 1 - 110 CONTINUE -C -C STORE THE INFORMATION NECESSARY TO RECOVER THE -C GIVENS ROTATION. -C - W(J) = TAU - 120 CONTINUE -C -C TEST FOR ZERO DIAGONAL ELEMENTS IN THE OUTPUT S. -C - IF (S(JJ) .EQ. ZERO) SING = .TRUE. - JJ = JJ + (M - J + 1) - 130 CONTINUE - 140 CONTINUE -C -C MOVE W BACK INTO THE LAST COLUMN OF THE OUTPUT S. -C - L = JJ - DO 150 I = N, M - S(L) = W(I) - L = L + 1 - 150 CONTINUE - IF (S(JJ) .EQ. ZERO) SING = .TRUE. - RETURN -C -C LAST CARD OF SUBROUTINE R1UPDT. -C - END diff --git a/ex/file06 b/ex/file06 deleted file mode 100644 index b9da052..0000000 --- a/ex/file06 +++ /dev/null @@ -1,3528 +0,0 @@ -1 -0 Page -0 Documentation for MINPACK subroutine HYBRD1 -0 Double precision version -0 Argonne National Laboratory -0 Burton S. Garbow, Kenneth E. Hillstrom, Jorge J. More -0 March 1980 -0 - 1. Purpose. -0 The purpose of HYBRD1 is to find a zero of a system of N non- - linear functions in N variables by a modification of the Powell - hybrid method. This is done by using the more general nonlinea - equation solver HYBRD. The user must provide a subroutine whic - calculates the functions. The Jacobian is then calculated by a - forward-difference approximation. -0 - 2. Subroutine and type statements. -0 SUBROUTINE HYBRD1(FCN,N,X,FVEC,TOL,INFO,WA,LWA) - INTEGER N,INFO,LWA - DOUBLE PRECISION TOL - DOUBLE PRECISION X(N),FVEC(N),WA(LWA) - EXTERNAL FCN -0 - 3. Parameters. -0 Parameters designated as input parameters must be specified on - entry to HYBRD1 and are not changed on exit, while parameters - designated as output parameters need not be specified on entry - and are set to appropriate values on exit from HYBRD1. -0 FCN is the name of the user-supplied subroutine which calculate - the functions. FCN must be declared in an EXTERNAL statement - in the user calling program, and should be written as follows -0 SUBROUTINE FCN(N,X,FVEC,IFLAG) - INTEGER N,IFLAG - DOUBLE PRECISION X(N),FVEC(N) - ---------- - CALCULATE THE FUNCTIONS AT X AND - RETURN THIS VECTOR IN FVEC. - ---------- - RETURN - END -0 The value of IFLAG should not be changed by FCN unless the - user wants to terminate execution of HYBRD1. In this case se - IFLAG to a negative integer. -1 -0 Page -0 N is a positive integer input variable set to the number of - functions and variables. -0 X is an array of length N. On input X must contain an initial - estimate of the solution vector. On output X contains the - final estimate of the solution vector. -0 FVEC is an output array of length N which contains the function - evaluated at the output X. -0 TOL is a nonnegative input variable. Termination occurs when - the algorithm estimates that the relative error between X and - the solution is at most TOL. Section 4 contains more details - about TOL. -0 INFO is an integer output variable. If the user has terminated - execution, INFO is set to the (negative) value of IFLAG. See - description of FCN. Otherwise, INFO is set as follows. -0 INFO = 0 Improper input parameters. -0 INFO = 1 Algorithm estimates that the relative error between - X and the solution is at most TOL. -0 INFO = 2 Number of calls to FCN has reached or exceeded - 200*(N+1). -0 INFO = 3 TOL is too small. No further improvement in the - approximate solution X is possible. -0 INFO = 4 Iteration is not making good progress. -0 Sections 4 and 5 contain more details about INFO. -0 WA is a work array of length LWA. -0 LWA is a positive integer input variable not less than - (N*(3*N+13))/2. -0 - 4. Successful completion. -0 The accuracy of HYBRD1 is controlled by the convergence parame- - ter TOL. This parameter is used in a test which makes a compar - ison between the approximation X and a solution XSOL. HYBRD1 - terminates when the test is satisfied. If TOL is less than the - machine precision (as defined by the MINPACK function - DPMPAR(1)), then HYBRD1 only attempts to satisfy the test - defined by the machine precision. Further progress is not usu- - ally possible. Unless high precision solutions are required, - the recommended value for TOL is the square root of the machine - precision. -0 The test assumes that the functions are reasonably well behaved -1 -0 Page -0 If this condition is not satisfied, then HYBRD1 may incorrectly - indicate convergence. The validity of the answer can be - checked, for example, by rerunning HYBRD1 with a tighter toler- - ance. -0 Convergence test. If ENORM(Z) denotes the Euclidean norm of a - vector Z, then this test attempts to guarantee that -0 ENORM(X-XSOL) .LE. TOL*ENORM(XSOL). -0 If this condition is satisfied with TOL = 10**(-K), then the - larger components of X have K significant decimal digits and - INFO is set to 1. There is a danger that the smaller compo- - nents of X may have large relative errors, but the fast rate - of convergence of HYBRD1 usually avoids this possibility. -0 - 5. Unsuccessful completion. -0 Unsuccessful termination of HYBRD1 can be due to improper input - parameters, arithmetic interrupts, an excessive number of func- - tion evaluations, errors in the functions, or lack of good prog - ress. -0 Improper input parameters. INFO is set to 0 if N .LE. 0, or - TOL .LT. 0.D0, or LWA .LT. (N*(3*N+13))/2. -0 Arithmetic interrupts. If these interrupts occur in the FCN - subroutine during an early stage of the computation, they may - be caused by an unacceptable choice of X by HYBRD1. In this - case, it may be possible to remedy the situation by not evalu - ating the functions here, but instead setting the components - of FVEC to numbers that exceed those in the initial FVEC, - thereby indirectly reducing the step length. The step length - can be more directly controlled by using instead HYBRD, which - includes in its calling sequence the step-length- governing - parameter FACTOR. -0 Excessive number of function evaluations. If the number of - calls to FCN reaches 200*(N+1), then this indicates that the - routine is converging very slowly as measured by the progress - of FVEC, and INFO is set to 2. This situation should be unu- - sual because, as indicated below, lack of good progress is - usually diagnosed earlier by HYBRD1, causing termination with - INFO = 4. -0 Errors in the functions. The choice of step length in the for- - ward-difference approximation to the Jacobian assumes that th - relative errors in the functions are of the order of the - machine precision. If this is not the case, HYBRD1 may fail - (usually with INFO = 4). The user should then use HYBRD - instead, or one of the programs which require the analytic - Jacobian (HYBRJ1 and HYBRJ). -1 -0 Page -0 Lack of good progress. HYBRD1 searches for a zero of the syste - by minimizing the sum of the squares of the functions. In so - doing, it can become trapped in a region where the minimum - does not correspond to a zero of the system and, in this situ - ation, the iteration eventually fails to make good progress. - In particular, this will happen if the system does not have a - zero. If the system has a zero, rerunning HYBRD1 from a dif- - ferent starting point may be helpful. -0 - 6. Characteristics of the algorithm. -0 HYBRD1 is a modification of the Powell hybrid method. Two of - its main characteristics involve the choice of the correction a - a convex combination of the Newton and scaled gradient direc- - tions, and the updating of the Jacobian by the rank-1 method of - Broyden. The choice of the correction guarantees (under reason - able conditions) global convergence for starting points far fro - the solution and a fast rate of convergence. The Jacobian is - approximated by forward differences at the starting point, but - forward differences are not used again until the rank-1 method - fails to produce satisfactory progress. -0 Timing. The time required by HYBRD1 to solve a given problem - depends on N, the behavior of the functions, the accuracy - requested, and the starting point. The number of arithmetic - operations needed by HYBRD1 is about 11.5*(N**2) to process - each call to FCN. Unless FCN can be evaluated quickly, the - timing of HYBRD1 will be strongly influenced by the time spen - in FCN. -0 Storage. HYBRD1 requires (3*N**2 + 17*N)/2 double precision - storage locations, in addition to the storage required by the - program. There are no internally declared storage arrays. -0 - 7. Subprograms required. -0 USER-supplied ...... FCN -0 MINPACK-supplied ... DOGLEG,DPMPAR,ENORM,FDJAC1,HYBRD, - QFORM,QRFAC,R1MPYQ,R1UPDT -0 FORTRAN-supplied ... DABS,DMAX1,DMIN1,DSQRT,MIN0,MOD -0 - 8. References. -0 M. J. D. Powell, A Hybrid Method for Nonlinear Equations. - Numerical Methods for Nonlinear Algebraic Equations, - P. Rabinowitz, editor. Gordon and Breach, 1970. -0 - 9. Example. -1 -0 Page -0 The problem is to determine the values of x(1), x(2), ..., x(9) - which solve the system of tridiagonal equations -0 (3-2*x(1))*x(1) -2*x(2) = -1 - -x(i-1) + (3-2*x(i))*x(i) -2*x(i+1) = -1, i=2-8 - -x(8) + (3-2*x(9))*x(9) = -1 -0 C ********** - C - C DRIVER FOR HYBRD1 EXAMPLE. - C DOUBLE PRECISION VERSION - C - C ********** - INTEGER J,N,INFO,LWA,NWRITE - DOUBLE PRECISION TOL,FNORM - DOUBLE PRECISION X(9),FVEC(9),WA(180) - DOUBLE PRECISION ENORM,DPMPAR - EXTERNAL FCN - C - C LOGICAL OUTPUT UNIT IS ASSUMED TO BE NUMBER 6. - C - DATA NWRITE /6/ - C - N = 9 - C - C THE FOLLOWING STARTING VALUES PROVIDE A ROUGH SOLUTION. - C - DO 10 J = 1, 9 - X(J) = -1.D0 - 10 CONTINUE - C - LWA = 180 - C - C SET TOL TO THE SQUARE ROOT OF THE MACHINE PRECISION. - C UNLESS HIGH PRECISION SOLUTIONS ARE REQUIRED, - C THIS IS THE RECOMMENDED SETTING. - C - TOL = DSQRT(DPMPAR(1)) - C - CALL HYBRD1(FCN,N,X,FVEC,TOL,INFO,WA,LWA) - FNORM = ENORM(N,FVEC) - WRITE (NWRITE,1000) FNORM,INFO,(X(J),J=1,N) - STOP - 1000 FORMAT (5X,31H FINAL L2 NORM OF THE RESIDUALS,D15.7 // - * 5X,15H EXIT PARAMETER,16X,I10 // - * 5X,27H FINAL APPROXIMATE SOLUTION // (5X,3D15.7)) - C - C LAST CARD OF DRIVER FOR HYBRD1 EXAMPLE. - C - END - SUBROUTINE FCN(N,X,FVEC,IFLAG) - INTEGER N,IFLAG - DOUBLE PRECISION X(N),FVEC(N) - C -1 -0 Page -0 C SUBROUTINE FCN FOR HYBRD1 EXAMPLE. - C - INTEGER K - DOUBLE PRECISION ONE,TEMP,TEMP1,TEMP2,THREE,TWO,ZERO - DATA ZERO,ONE,TWO,THREE /0.D0,1.D0,2.D0,3.D0/ - C - DO 10 K = 1, N - TEMP = (THREE - TWO*X(K))*X(K) - TEMP1 = ZERO - IF (K .NE. 1) TEMP1 = X(K-1) - TEMP2 = ZERO - IF (K .NE. N) TEMP2 = X(K+1) - FVEC(K) = TEMP - TEMP1 - TWO*TEMP2 + ONE - 10 CONTINUE - RETURN - C - C LAST CARD OF SUBROUTINE FCN. - C - END -0 Results obtained with different compilers or machines - may be slightly different. -0 FINAL L2 NORM OF THE RESIDUALS 0.1192636D-07 -0 EXIT PARAMETER 1 -0 FINAL APPROXIMATE SOLUTION -0 -0.5706545D+00 -0.6816283D+00 -0.7017325D+00 - -0.7042129D+00 -0.7013690D+00 -0.6918656D+00 - -0.6657920D+00 -0.5960342D+00 -0.4164121D+00 -1 -0 -1 -0 Page -0 Documentation for MINPACK subroutine HYBRD -0 Double precision version -0 Argonne National Laboratory -0 Burton S. Garbow, Kenneth E. Hillstrom, Jorge J. More -0 March 1980 -0 - 1. Purpose. -0 The purpose of HYBRD is to find a zero of a system of N non- - linear functions in N variables by a modification of the Powell - hybrid method. The user must provide a subroutine which calcu- - lates the functions. The Jacobian is then calculated by a for- - ward-difference approximation. -0 - 2. Subroutine and type statements. -0 SUBROUTINE HYBRD(FCN,N,X,FVEC,XTOL,MAXFEV,ML,MU,EPSFCN,DIAG, - * MODE,FACTOR,NPRINT,INFO,NFEV,FJAC,LDFJAC, - * R,LR,QTF,WA1,WA2,WA3,WA4) - INTEGER N,MAXFEV,ML,MU,MODE,NPRINT,INFO,NFEV,LDFJAC,LR - DOUBLE PRECISION XTOL,EPSFCN,FACTOR - DOUBLE PRECISION X(N),FVEC(N),DIAG(N),FJAC(LDFJAC,N),R(LR),QTF( - * WA1(N),WA2(N),WA3(N),WA4(N) - EXTERNAL FCN -0 - 3. Parameters. -0 Parameters designated as input parameters must be specified on - entry to HYBRD and are not changed on exit, while parameters - designated as output parameters need not be specified on entry - and are set to appropriate values on exit from HYBRD. -0 FCN is the name of the user-supplied subroutine which calculate - the functions. FCN must be declared in an EXTERNAL statement - in the user calling program, and should be written as follows -0 SUBROUTINE FCN(N,X,FVEC,IFLAG) - INTEGER N,IFLAG - DOUBLE PRECISION X(N),FVEC(N) - ---------- - CALCULATE THE FUNCTIONS AT X AND - RETURN THIS VECTOR IN FVEC. - ---------- - RETURN - END -0 The value of IFLAG should not be changed by FCN unless the -1 -0 Page -0 user wants to terminate execution of HYBRD. In this case set - IFLAG to a negative integer. -0 N is a positive integer input variable set to the number of - functions and variables. -0 X is an array of length N. On input X must contain an initial - estimate of the solution vector. On output X contains the - final estimate of the solution vector. -0 FVEC is an output array of length N which contains the function - evaluated at the output X. -0 XTOL is a nonnegative input variable. Termination occurs when - the relative error between two consecutive iterates is at mos - XTOL. Therefore, XTOL measures the relative error desired in - the approximate solution. Section 4 contains more details - about XTOL. -0 MAXFEV is a positive integer input variable. Termination occur - when the number of calls to FCN is at least MAXFEV by the end - of an iteration. -0 ML is a nonnegative integer input variable which specifies the - number of subdiagonals within the band of the Jacobian matrix - If the Jacobian is not banded, set ML to at least N - 1. -0 MU is a nonnegative integer input variable which specifies the - number of superdiagonals within the band of the Jacobian - matrix. If the Jacobian is not banded, set MU to at least - N - 1. -0 EPSFCN is an input variable used in determining a suitable step - for the forward-difference approximation. This approximation - assumes that the relative errors in the functions are of the - order of EPSFCN. If EPSFCN is less than the machine preci- - sion, it is assumed that the relative errors in the functions - are of the order of the machine precision. -0 DIAG is an array of length N. If MODE = 1 (see below), DIAG is - internally set. If MODE = 2, DIAG must contain positive - entries that serve as multiplicative scale factors for the - variables. -0 MODE is an integer input variable. If MODE = 1, the variables - will be scaled internally. If MODE = 2, the scaling is speci - fied by the input DIAG. Other values of MODE are equivalent - to MODE = 1. -0 FACTOR is a positive input variable used in determining the ini - tial step bound. This bound is set to the product of FACTOR - and the Euclidean norm of DIAG*X if nonzero, or else to FACTO - itself. In most cases FACTOR should lie in the interval - (.1,100.). 100. is a generally recommended value. -1 -0 Page -0 NPRINT is an integer input variable that enables controlled - printing of iterates if it is positive. In this case, FCN is - called with IFLAG = 0 at the beginning of the first iteration - and every NPRINT iterations thereafter and immediately prior - to return, with X and FVEC available for printing. If NPRINT - is not positive, no special calls of FCN with IFLAG = 0 are - made. -0 INFO is an integer output variable. If the user has terminated - execution, INFO is set to the (negative) value of IFLAG. See - description of FCN. Otherwise, INFO is set as follows. -0 INFO = 0 Improper input parameters. -0 INFO = 1 Relative error between two consecutive iterates is - at most XTOL. -0 INFO = 2 Number of calls to FCN has reached or exceeded - MAXFEV. -0 INFO = 3 XTOL is too small. No further improvement in the - approximate solution X is possible. -0 INFO = 4 Iteration is not making good progress, as measured - by the improvement from the last five Jacobian eval - uations. -0 INFO = 5 Iteration is not making good progress, as measured - by the improvement from the last ten iterations. -0 Sections 4 and 5 contain more details about INFO. -0 NFEV is an integer output variable set to the number of calls t - FCN. -0 FJAC is an output N by N array which contains the orthogonal - matrix Q produced by the QR factorization of the final approx - imate Jacobian. -0 LDFJAC is a positive integer input variable not less than N - which specifies the leading dimension of the array FJAC. -0 R is an output array of length LR which contains the upper - triangular matrix produced by the QR factorization of the - final approximate Jacobian, stored rowwise. -0 LR is a positive integer input variable not less than - (N*(N+1))/2. -0 QTF is an output array of length N which contains the vector - (Q transpose)*FVEC. -0 WA1, WA2, WA3, and WA4 are work arrays of length N. -1 -0 Page -0 - 4. Successful completion. -0 The accuracy of HYBRD is controlled by the convergence paramete - XTOL. This parameter is used in a test which makes a compariso - between the approximation X and a solution XSOL. HYBRD termi- - nates when the test is satisfied. If the convergence parameter - is less than the machine precision (as defined by the MINPACK - function DPMPAR(1)), then HYBRD only attempts to satisfy the - test defined by the machine precision. Further progress is not - usually possible. -0 The test assumes that the functions are reasonably well behaved - If this condition is not satisfied, then HYBRD may incorrectly - indicate convergence. The validity of the answer can be - checked, for example, by rerunning HYBRD with a tighter toler- - ance. -0 Convergence test. If ENORM(Z) denotes the Euclidean norm of a - vector Z and D is the diagonal matrix whose entries are - defined by the array DIAG, then this test attempts to guaran- - tee that -0 ENORM(D*(X-XSOL)) .LE. XTOL*ENORM(D*XSOL). -0 If this condition is satisfied with XTOL = 10**(-K), then the - larger components of D*X have K significant decimal digits an - INFO is set to 1. There is a danger that the smaller compo- - nents of D*X may have large relative errors, but the fast rat - of convergence of HYBRD usually avoids this possibility. - Unless high precision solutions are required, the recommended - value for XTOL is the square root of the machine precision. -0 - 5. Unsuccessful completion. -0 Unsuccessful termination of HYBRD can be due to improper input - parameters, arithmetic interrupts, an excessive number of func- - tion evaluations, or lack of good progress. -0 Improper input parameters. INFO is set to 0 if N .LE. 0, or - XTOL .LT. 0.D0, or MAXFEV .LE. 0, or ML .LT. 0, or MU .LT. 0, - or FACTOR .LE. 0.D0, or LDFJAC .LT. N, or LR .LT. (N*(N+1))/2 -0 Arithmetic interrupts. If these interrupts occur in the FCN - subroutine during an early stage of the computation, they may - be caused by an unacceptable choice of X by HYBRD. In this - case, it may be possible to remedy the situation by rerunning - HYBRD with a smaller value of FACTOR. -0 Excessive number of function evaluations. A reasonable value - for MAXFEV is 200*(N+1). If the number of calls to FCN - reaches MAXFEV, then this indicates that the routine is con- - verging very slowly as measured by the progress of FVEC, and -1 -0 Page -0 INFO is set to 2. This situation should be unusual because, - as indicated below, lack of good progress is usually diagnose - earlier by HYBRD, causing termination with INFO = 4 or - INFO = 5. -0 Lack of good progress. HYBRD searches for a zero of the system - by minimizing the sum of the squares of the functions. In so - doing, it can become trapped in a region where the minimum - does not correspond to a zero of the system and, in this situ - ation, the iteration eventually fails to make good progress. - In particular, this will happen if the system does not have a - zero. If the system has a zero, rerunning HYBRD from a dif- - ferent starting point may be helpful. -0 - 6. Characteristics of the algorithm. -0 HYBRD is a modification of the Powell hybrid method. Two of it - main characteristics involve the choice of the correction as a - convex combination of the Newton and scaled gradient directions - and the updating of the Jacobian by the rank-1 method of Broy- - den. The choice of the correction guarantees (under reasonable - conditions) global convergence for starting points far from the - solution and a fast rate of convergence. The Jacobian is - approximated by forward differences at the starting point, but - forward differences are not used again until the rank-1 method - fails to produce satisfactory progress. -0 Timing. The time required by HYBRD to solve a given problem - depends on N, the behavior of the functions, the accuracy - requested, and the starting point. The number of arithmetic - operations needed by HYBRD is about 11.5*(N**2) to process - each call to FCN. Unless FCN can be evaluated quickly, the - timing of HYBRD will be strongly influenced by the time spent - in FCN. -0 Storage. HYBRD requires (3*N**2 + 17*N)/2 double precision - storage locations, in addition to the storage required by the - program. There are no internally declared storage arrays. -0 - 7. Subprograms required. -0 USER-supplied ...... FCN -0 MINPACK-supplied ... DOGLEG,DPMPAR,ENORM,FDJAC1, - QFORM,QRFAC,R1MPYQ,R1UPDT -0 FORTRAN-supplied ... DABS,DMAX1,DMIN1,DSQRT,MIN0,MOD -0 - 8. References. -0 M. J. D. Powell, A Hybrid Method for Nonlinear Equations. -1 -0 Page -0 Numerical Methods for Nonlinear Algebraic Equations, - P. Rabinowitz, editor. Gordon and Breach, 1970. -0 - 9. Example. -0 The problem is to determine the values of x(1), x(2), ..., x(9) - which solve the system of tridiagonal equations -0 (3-2*x(1))*x(1) -2*x(2) = -1 - -x(i-1) + (3-2*x(i))*x(i) -2*x(i+1) = -1, i=2-8 - -x(8) + (3-2*x(9))*x(9) = -1 -0 C ********** - C - C DRIVER FOR HYBRD EXAMPLE. - C DOUBLE PRECISION VERSION - C - C ********** - INTEGER J,N,MAXFEV,ML,MU,MODE,NPRINT,INFO,NFEV,LDFJAC,LR,NWRITE - DOUBLE PRECISION XTOL,EPSFCN,FACTOR,FNORM - DOUBLE PRECISION X(9),FVEC(9),DIAG(9),FJAC(9,9),R(45),QTF(9), - * WA1(9),WA2(9),WA3(9),WA4(9) - DOUBLE PRECISION ENORM,DPMPAR - EXTERNAL FCN - C - C LOGICAL OUTPUT UNIT IS ASSUMED TO BE NUMBER 6. - C - DATA NWRITE /6/ - C - N = 9 - C - C THE FOLLOWING STARTING VALUES PROVIDE A ROUGH SOLUTION. - C - DO 10 J = 1, 9 - X(J) = -1.D0 - 10 CONTINUE - C - LDFJAC = 9 - LR = 45 - C - C SET XTOL TO THE SQUARE ROOT OF THE MACHINE PRECISION. - C UNLESS HIGH PRECISION SOLUTIONS ARE REQUIRED, - C THIS IS THE RECOMMENDED SETTING. - C - XTOL = DSQRT(DPMPAR(1)) - C - MAXFEV = 2000 - ML = 1 - MU = 1 - EPSFCN = 0.D0 - MODE = 2 - DO 20 J = 1, 9 - DIAG(J) = 1.D0 -1 -0 Page -0 20 CONTINUE - FACTOR = 1.D2 - NPRINT = 0 - C - CALL HYBRD(FCN,N,X,FVEC,XTOL,MAXFEV,ML,MU,EPSFCN,DIAG, - * MODE,FACTOR,NPRINT,INFO,NFEV,FJAC,LDFJAC, - * R,LR,QTF,WA1,WA2,WA3,WA4) - FNORM = ENORM(N,FVEC) - WRITE (NWRITE,1000) FNORM,NFEV,INFO,(X(J),J=1,N) - STOP - 1000 FORMAT (5X,31H FINAL L2 NORM OF THE RESIDUALS,D15.7 // - * 5X,31H NUMBER OF FUNCTION EVALUATIONS,I10 // - * 5X,15H EXIT PARAMETER,16X,I10 // - * 5X,27H FINAL APPROXIMATE SOLUTION // (5X,3D15.7)) - C - C LAST CARD OF DRIVER FOR HYBRD EXAMPLE. - C - END - SUBROUTINE FCN(N,X,FVEC,IFLAG) - INTEGER N,IFLAG - DOUBLE PRECISION X(N),FVEC(N) - C - C SUBROUTINE FCN FOR HYBRD EXAMPLE. - C - INTEGER K - DOUBLE PRECISION ONE,TEMP,TEMP1,TEMP2,THREE,TWO,ZERO - DATA ZERO,ONE,TWO,THREE /0.D0,1.D0,2.D0,3.D0/ - C - IF (IFLAG .NE. 0) GO TO 5 - C - C INSERT PRINT STATEMENTS HERE WHEN NPRINT IS POSITIVE. - C - RETURN - 5 CONTINUE - DO 10 K = 1, N - TEMP = (THREE - TWO*X(K))*X(K) - TEMP1 = ZERO - IF (K .NE. 1) TEMP1 = X(K-1) - TEMP2 = ZERO - IF (K .NE. N) TEMP2 = X(K+1) - FVEC(K) = TEMP - TEMP1 - TWO*TEMP2 + ONE - 10 CONTINUE - RETURN - C - C LAST CARD OF SUBROUTINE FCN. - C - END -0 Results obtained with different compilers or machines - may be slightly different. -0 FINAL L2 NORM OF THE RESIDUALS 0.1192636D-07 -0 NUMBER OF FUNCTION EVALUATIONS 14 -1 -0 Page -0 EXIT PARAMETER 1 -0 FINAL APPROXIMATE SOLUTION -0 -0.5706545D+00 -0.6816283D+00 -0.7017325D+00 - -0.7042129D+00 -0.7013690D+00 -0.6918656D+00 - -0.6657920D+00 -0.5960342D+00 -0.4164121D+00 -1 -0 -1 -0 Page -0 Documentation for MINPACK subroutine HYBRJ1 -0 Double precision version -0 Argonne National Laboratory -0 Burton S. Garbow, Kenneth E. Hillstrom, Jorge J. More -0 March 1980 -0 - 1. Purpose. -0 The purpose of HYBRJ1 is to find a zero of a system of N non- - linear functions in N variables by a modification of the Powell - hybrid method. This is done by using the more general nonlinea - equation solver HYBRJ. The user must provide a subroutine whic - calculates the functions and the Jacobian. -0 - 2. Subroutine and type statements. -0 SUBROUTINE HYBRJ1(FCN,N,X,FVEC,FJAC,LDFJAC,TOL,INFO,WA,LWA) - INTEGER N,LDFJAC,INFO,LWA - DOUBLE PRECISION TOL - DOUBLE PRECISION X(N),FVEC(N),FJAC(LDFJAC,N),WA(LWA) - EXTERNAL FCN -0 - 3. Parameters. -0 Parameters designated as input parameters must be specified on - entry to HYBRJ1 and are not changed on exit, while parameters - designated as output parameters need not be specified on entry - and are set to appropriate values on exit from HYBRJ1. -0 FCN is the name of the user-supplied subroutine which calculate - the functions and the Jacobian. FCN must be declared in an - EXTERNAL statement in the user calling program, and should be - written as follows. -0 SUBROUTINE FCN(N,X,FVEC,FJAC,LDFJAC,IFLAG) - INTEGER N,LDFJAC,IFLAG - DOUBLE PRECISION X(N),FVEC(N),FJAC(LDFJAC,N) - ---------- - IF IFLAG = 1 CALCULATE THE FUNCTIONS AT X AND - RETURN THIS VECTOR IN FVEC. DO NOT ALTER FJAC. - IF IFLAG = 2 CALCULATE THE JACOBIAN AT X AND - RETURN THIS MATRIX IN FJAC. DO NOT ALTER FVEC. - ---------- - RETURN - END -0 The value of IFLAG should not be changed by FCN unless the -1 -0 Page -0 user wants to terminate execution of HYBRJ1. In this case se - IFLAG to a negative integer. -0 N is a positive integer input variable set to the number of - functions and variables. -0 X is an array of length N. On input X must contain an initial - estimate of the solution vector. On output X contains the - final estimate of the solution vector. -0 FVEC is an output array of length N which contains the function - evaluated at the output X. -0 FJAC is an output N by N array which contains the orthogonal - matrix Q produced by the QR factorization of the final approx - imate Jacobian. Section 6 contains more details about the - approximation to the Jacobian. -0 LDFJAC is a positive integer input variable not less than N - which specifies the leading dimension of the array FJAC. -0 TOL is a nonnegative input variable. Termination occurs when - the algorithm estimates that the relative error between X and - the solution is at most TOL. Section 4 contains more details - about TOL. -0 INFO is an integer output variable. If the user has terminated - execution, INFO is set to the (negative) value of IFLAG. See - description of FCN. Otherwise, INFO is set as follows. -0 INFO = 0 Improper input parameters. -0 INFO = 1 Algorithm estimates that the relative error between - X and the solution is at most TOL. -0 INFO = 2 Number of calls to FCN with IFLAG = 1 has reached - 100*(N+1). -0 INFO = 3 TOL is too small. No further improvement in the - approximate solution X is possible. -0 INFO = 4 Iteration is not making good progress. -0 Sections 4 and 5 contain more details about INFO. -0 WA is a work array of length LWA. -0 LWA is a positive integer input variable not less than - (N*(N+13))/2. -0 - 4. Successful completion. -0 The accuracy of HYBRJ1 is controlled by the convergence -1 -0 Page -0 parameter TOL. This parameter is used in a test which makes a - comparison between the approximation X and a solution XSOL. - HYBRJ1 terminates when the test is satisfied. If TOL is less - than the machine precision (as defined by the MINPACK function - DPMPAR(1)), then HYBRJ1 only attempts to satisfy the test - defined by the machine precision. Further progress is not usu- - ally possible. Unless high precision solutions are required, - the recommended value for TOL is the square root of the machine - precision. -0 The test assumes that the functions and the Jacobian are coded - consistently, and that the functions are reasonably well - behaved. If these conditions are not satisfied, then HYBRJ1 ma - incorrectly indicate convergence. The coding of the Jacobian - can be checked by the MINPACK subroutine CHKDER. If the Jaco- - bian is coded correctly, then the validity of the answer can be - checked, for example, by rerunning HYBRJ1 with a tighter toler- - ance. -0 Convergence test. If ENORM(Z) denotes the Euclidean norm of a - vector Z, then this test attempts to guarantee that -0 ENORM(X-XSOL) .LE. TOL*ENORM(XSOL). -0 If this condition is satisfied with TOL = 10**(-K), then the - larger components of X have K significant decimal digits and - INFO is set to 1. There is a danger that the smaller compo- - nents of X may have large relative errors, but the fast rate - of convergence of HYBRJ1 usually avoids this possibility. -0 - 5. Unsuccessful completion. -0 Unsuccessful termination of HYBRJ1 can be due to improper input - parameters, arithmetic interrupts, an excessive number of func- - tion evaluations, or lack of good progress. -0 Improper input parameters. INFO is set to 0 if N .LE. 0, or - LDFJAC .LT. N, or TOL .LT. 0.D0, or LWA .LT. (N*(N+13))/2. -0 Arithmetic interrupts. If these interrupts occur in the FCN - subroutine during an early stage of the computation, they may - be caused by an unacceptable choice of X by HYBRJ1. In this - case, it may be possible to remedy the situation by not evalu - ating the functions here, but instead setting the components - of FVEC to numbers that exceed those in the initial FVEC, - thereby indirectly reducing the step length. The step length - can be more directly controlled by using instead HYBRJ, which - includes in its calling sequence the step-length- governing - parameter FACTOR. -0 Excessive number of function evaluations. If the number of - calls to FCN with IFLAG = 1 reaches 100*(N+1), then this indi - cates that the routine is converging very slowly as measured -1 -0 Page -0 by the progress of FVEC, and INFO is set to 2. This situatio - should be unusual because, as indicated below, lack of good - progress is usually diagnosed earlier by HYBRJ1, causing ter- - mination with INFO = 4. -0 Lack of good progress. HYBRJ1 searches for a zero of the syste - by minimizing the sum of the squares of the functions. In so - doing, it can become trapped in a region where the minimum - does not correspond to a zero of the system and, in this situ - ation, the iteration eventually fails to make good progress. - In particular, this will happen if the system does not have a - zero. If the system has a zero, rerunning HYBRJ1 from a dif- - ferent starting point may be helpful. -0 - 6. Characteristics of the algorithm. -0 HYBRJ1 is a modification of the Powell hybrid method. Two of - its main characteristics involve the choice of the correction a - a convex combination of the Newton and scaled gradient direc- - tions, and the updating of the Jacobian by the rank-1 method of - Broyden. The choice of the correction guarantees (under reason - able conditions) global convergence for starting points far fro - the solution and a fast rate of convergence. The Jacobian is - calculated at the starting point, but it is not recalculated - until the rank-1 method fails to produce satisfactory progress. -0 Timing. The time required by HYBRJ1 to solve a given problem - depends on N, the behavior of the functions, the accuracy - requested, and the starting point. The number of arithmetic - operations needed by HYBRJ1 is about 11.5*(N**2) to process - each evaluation of the functions (call to FCN with IFLAG = 1) - and 1.3*(N**3) to process each evaluation of the Jacobian - (call to FCN with IFLAG = 2). Unless FCN can be evaluated - quickly, the timing of HYBRJ1 will be strongly influenced by - the time spent in FCN. -0 Storage. HYBRJ1 requires (3*N**2 + 17*N)/2 double precision - storage locations, in addition to the storage required by the - program. There are no internally declared storage arrays. -0 - 7. Subprograms required. -0 USER-supplied ...... FCN -0 MINPACK-supplied ... DOGLEG,DPMPAR,ENORM,HYBRJ, - QFORM,QRFAC,R1MPYQ,R1UPDT -0 FORTRAN-supplied ... DABS,DMAX1,DMIN1,DSQRT,MIN0,MOD -0 - 8. References. -1 -0 Page -0 M. J. D. Powell, A Hybrid Method for Nonlinear Equations. - Numerical Methods for Nonlinear Algebraic Equations, - P. Rabinowitz, editor. Gordon and Breach, 1970. -0 - 9. Example. -0 The problem is to determine the values of x(1), x(2), ..., x(9) - which solve the system of tridiagonal equations -0 (3-2*x(1))*x(1) -2*x(2) = -1 - -x(i-1) + (3-2*x(i))*x(i) -2*x(i+1) = -1, i=2-8 - -x(8) + (3-2*x(9))*x(9) = -1 -0 C ********** - C - C DRIVER FOR HYBRJ1 EXAMPLE. - C DOUBLE PRECISION VERSION - C - C ********** - INTEGER J,N,LDFJAC,INFO,LWA,NWRITE - DOUBLE PRECISION TOL,FNORM - DOUBLE PRECISION X(9),FVEC(9),FJAC(9,9),WA(99) - DOUBLE PRECISION ENORM,DPMPAR - EXTERNAL FCN - C - C LOGICAL OUTPUT UNIT IS ASSUMED TO BE NUMBER 6. - C - DATA NWRITE /6/ - C - N = 9 - C - C THE FOLLOWING STARTING VALUES PROVIDE A ROUGH SOLUTION. - C - DO 10 J = 1, 9 - X(J) = -1.D0 - 10 CONTINUE - C - LDFJAC = 9 - LWA = 99 - C - C SET TOL TO THE SQUARE ROOT OF THE MACHINE PRECISION. - C UNLESS HIGH PRECISION SOLUTIONS ARE REQUIRED, - C THIS IS THE RECOMMENDED SETTING. - C - TOL = DSQRT(DPMPAR(1)) - C - CALL HYBRJ1(FCN,N,X,FVEC,FJAC,LDFJAC,TOL,INFO,WA,LWA) - FNORM = ENORM(N,FVEC) - WRITE (NWRITE,1000) FNORM,INFO,(X(J),J=1,N) - STOP - 1000 FORMAT (5X,31H FINAL L2 NORM OF THE RESIDUALS,D15.7 // - * 5X,15H EXIT PARAMETER,16X,I10 // - * 5X,27H FINAL APPROXIMATE SOLUTION // (5X,3D15.7)) -1 -0 Page -0 C - C LAST CARD OF DRIVER FOR HYBRJ1 EXAMPLE. - C - END - SUBROUTINE FCN(N,X,FVEC,FJAC,LDFJAC,IFLAG) - INTEGER N,LDFJAC,IFLAG - DOUBLE PRECISION X(N),FVEC(N),FJAC(LDFJAC,N) - C - C SUBROUTINE FCN FOR HYBRJ1 EXAMPLE. - C - INTEGER J,K - DOUBLE PRECISION ONE,TEMP,TEMP1,TEMP2,THREE,TWO,ZERO - DATA ZERO,ONE,TWO,THREE,FOUR /0.D0,1.D0,2.D0,3.D0,4.D0/ - C - IF (IFLAG .EQ. 2) GO TO 20 - DO 10 K = 1, N - TEMP = (THREE - TWO*X(K))*X(K) - TEMP1 = ZERO - IF (K .NE. 1) TEMP1 = X(K-1) - TEMP2 = ZERO - IF (K .NE. N) TEMP2 = X(K+1) - FVEC(K) = TEMP - TEMP1 - TWO*TEMP2 + ONE - 10 CONTINUE - GO TO 50 - 20 CONTINUE - DO 40 K = 1, N - DO 30 J = 1, N - FJAC(K,J) = ZERO - 30 CONTINUE - FJAC(K,K) = THREE - FOUR*X(K) - IF (K .NE. 1) FJAC(K,K-1) = -ONE - IF (K .NE. N) FJAC(K,K+1) = -TWO - 40 CONTINUE - 50 CONTINUE - RETURN - C - C LAST CARD OF SUBROUTINE FCN. - C - END -0 Results obtained with different compilers or machines - may be slightly different. -0 FINAL L2 NORM OF THE RESIDUALS 0.1192636D-07 -0 EXIT PARAMETER 1 -0 FINAL APPROXIMATE SOLUTION -0 -0.5706545D+00 -0.6816283D+00 -0.7017325D+00 - -0.7042129D+00 -0.7013690D+00 -0.6918656D+00 - -0.6657920D+00 -0.5960342D+00 -0.4164121D+00 -1 -0 -1 -0 Page -0 Documentation for MINPACK subroutine HYBRJ -0 Double precision version -0 Argonne National Laboratory -0 Burton S. Garbow, Kenneth E. Hillstrom, Jorge J. More -0 March 1980 -0 - 1. Purpose. -0 The purpose of HYBRJ is to find a zero of a system of N non- - linear functions in N variables by a modification of the Powell - hybrid method. The user must provide a subroutine which calcu- - lates the functions and the Jacobian. -0 - 2. Subroutine and type statements. -0 SUBROUTINE HYBRJ(FCN,N,X,FVEC,FJAC,LDFJAC,XTOL,MAXFEV,DIAG, - * MODE,FACTOR,NPRINT,INFO,NFEV,NJEV,R,LR,QTF, - * WA1,WA2,WA3,WA4) - INTEGER N,LDFJAC,MAXFEV,MODE,NPRINT,INFO,NFEV,NJEV,LR - DOUBLE PRECISION XTOL,FACTOR - DOUBLE PRECISION X(N),FVEC(N),FJAC(LDFJAC,N),DIAG(N),R(LR),QTF( - * WA1(N),WA2(N),WA3(N),WA4(N) -0 - 3. Parameters. -0 Parameters designated as input parameters must be specified on - entry to HYBRJ and are not changed on exit, while parameters - designated as output parameters need not be specified on entry - and are set to appropriate values on exit from HYBRJ. -0 FCN is the name of the user-supplied subroutine which calculate - the functions and the Jacobian. FCN must be declared in an - EXTERNAL statement in the user calling program, and should be - written as follows. -0 SUBROUTINE FCN(N,X,FVEC,FJAC,LDFJAC,IFLAG) - INTEGER N,LDFJAC,IFLAG - DOUBLE PRECISION X(N),FVEC(N),FJAC(LDFJAC,N) - ---------- - IF IFLAG = 1 CALCULATE THE FUNCTIONS AT X AND - RETURN THIS VECTOR IN FVEC. DO NOT ALTER FJAC. - IF IFLAG = 2 CALCULATE THE JACOBIAN AT X AND - RETURN THIS MATRIX IN FJAC. DO NOT ALTER FVEC. - ---------- - RETURN - END -1 -0 Page -0 The value of IFLAG should not be changed by FCN unless the - user wants to terminate execution of HYBRJ. In this case set - IFLAG to a negative integer. -0 N is a positive integer input variable set to the number of - functions and variables. -0 X is an array of length N. On input X must contain an initial - estimate of the solution vector. On output X contains the - final estimate of the solution vector. -0 FVEC is an output array of length N which contains the function - evaluated at the output X. -0 FJAC is an output N by N array which contains the orthogonal - matrix Q produced by the QR factorization of the final approx - imate Jacobian. Section 6 contains more details about the - approximation to the Jacobian. -0 LDFJAC is a positive integer input variable not less than N - which specifies the leading dimension of the array FJAC. -0 XTOL is a nonnegative input variable. Termination occurs when - the relative error between two consecutive iterates is at mos - XTOL. Therefore, XTOL measures the relative error desired in - the approximate solution. Section 4 contains more details - about XTOL. -0 MAXFEV is a positive integer input variable. Termination occur - when the number of calls to FCN with IFLAG = 1 has reached - MAXFEV. -0 DIAG is an array of length N. If MODE = 1 (see below), DIAG is - internally set. If MODE = 2, DIAG must contain positive - entries that serve as multiplicative scale factors for the - variables. -0 MODE is an integer input variable. If MODE = 1, the variables - will be scaled internally. If MODE = 2, the scaling is speci - fied by the input DIAG. Other values of MODE are equivalent - to MODE = 1. -0 FACTOR is a positive input variable used in determining the ini - tial step bound. This bound is set to the product of FACTOR - and the Euclidean norm of DIAG*X if nonzero, or else to FACTO - itself. In most cases FACTOR should lie in the interval - (.1,100.). 100. is a generally recommended value. -0 NPRINT is an integer input variable that enables controlled - printing of iterates if it is positive. In this case, FCN is - called with IFLAG = 0 at the beginning of the first iteration - and every NPRINT iterations thereafter and immediately prior - to return, with X and FVEC available for printing. FVEC and - FJAC should not be altered. If NPRINT is not positive, no -1 -0 Page -0 special calls of FCN with IFLAG = 0 are made. -0 INFO is an integer output variable. If the user has terminated - execution, INFO is set to the (negative) value of IFLAG. See - description of FCN. Otherwise, INFO is set as follows. -0 INFO = 0 Improper input parameters. -0 INFO = 1 Relative error between two consecutive iterates is - at most XTOL. -0 INFO = 2 Number of calls to FCN with IFLAG = 1 has reached - MAXFEV. -0 INFO = 3 XTOL is too small. No further improvement in the - approximate solution X is possible. -0 INFO = 4 Iteration is not making good progress, as measured - by the improvement from the last five Jacobian eval - uations. -0 INFO = 5 Iteration is not making good progress, as measured - by the improvement from the last ten iterations. -0 Sections 4 and 5 contain more details about INFO. -0 NFEV is an integer output variable set to the number of calls t - FCN with IFLAG = 1. -0 NJEV is an integer output variable set to the number of calls t - FCN with IFLAG = 2. -0 R is an output array of length LR which contains the upper - triangular matrix produced by the QR factorization of the - final approximate Jacobian, stored rowwise. -0 LR is a positive integer input variable not less than - (N*(N+1))/2. -0 QTF is an output array of length N which contains the vector - (Q transpose)*FVEC. -0 WA1, WA2, WA3, and WA4 are work arrays of length N. -0 - 4. Successful completion. -0 The accuracy of HYBRJ is controlled by the convergence paramete - XTOL. This parameter is used in a test which makes a compariso - between the approximation X and a solution XSOL. HYBRJ termi- - nates when the test is satisfied. If the convergence parameter - is less than the machine precision (as defined by the MINPACK - function DPMPAR(1)), then HYBRJ only attempts to satisfy the - test defined by the machine precision. Further progress is not -1 -0 Page -0 usually possible. -0 The test assumes that the functions and the Jacobian are coded - consistently, and that the functions are reasonably well - behaved. If these conditions are not satisfied, then HYBRJ may - incorrectly indicate convergence. The coding of the Jacobian - can be checked by the MINPACK subroutine CHKDER. If the Jaco- - bian is coded correctly, then the validity of the answer can be - checked, for example, by rerunning HYBRJ with a tighter toler- - ance. -0 Convergence test. If ENORM(Z) denotes the Euclidean norm of a - vector Z and D is the diagonal matrix whose entries are - defined by the array DIAG, then this test attempts to guaran- - tee that -0 ENORM(D*(X-XSOL)) .LE. XTOL*ENORM(D*XSOL). -0 If this condition is satisfied with XTOL = 10**(-K), then the - larger components of D*X have K significant decimal digits an - INFO is set to 1. There is a danger that the smaller compo- - nents of D*X may have large relative errors, but the fast rat - of convergence of HYBRJ usually avoids this possibility. - Unless high precision solutions are required, the recommended - value for XTOL is the square root of the machine precision. -0 - 5. Unsuccessful completion. -0 Unsuccessful termination of HYBRJ can be due to improper input - parameters, arithmetic interrupts, an excessive number of func- - tion evaluations, or lack of good progress. -0 Improper input parameters. INFO is set to 0 if N .LE. 0, or - LDFJAC .LT. N, or XTOL .LT. 0.D0, or MAXFEV .LE. 0, or - FACTOR .LE. 0.D0, or LR .LT. (N*(N+1))/2. -0 Arithmetic interrupts. If these interrupts occur in the FCN - subroutine during an early stage of the computation, they may - be caused by an unacceptable choice of X by HYBRJ. In this - case, it may be possible to remedy the situation by rerunning - HYBRJ with a smaller value of FACTOR. -0 Excessive number of function evaluations. A reasonable value - for MAXFEV is 100*(N+1). If the number of calls to FCN with - IFLAG = 1 reaches MAXFEV, then this indicates that the routin - is converging very slowly as measured by the progress of FVEC - and INFO is set to 2. This situation should be unusual - because, as indicated below, lack of good progress is usually - diagnosed earlier by HYBRJ, causing termination with INFO = 4 - or INFO = 5. -0 Lack of good progress. HYBRJ searches for a zero of the system - by minimizing the sum of the squares of the functions. In so -1 -0 Page -0 doing, it can become trapped in a region where the minimum - does not correspond to a zero of the system and, in this situ - ation, the iteration eventually fails to make good progress. - In particular, this will happen if the system does not have a - zero. If the system has a zero, rerunning HYBRJ from a dif- - ferent starting point may be helpful. -0 - 6. Characteristics of the algorithm. -0 HYBRJ is a modification of the Powell hybrid method. Two of it - main characteristics involve the choice of the correction as a - convex combination of the Newton and scaled gradient directions - and the updating of the Jacobian by the rank-1 method of Broy- - den. The choice of the correction guarantees (under reasonable - conditions) global convergence for starting points far from the - solution and a fast rate of convergence. The Jacobian is calcu - lated at the starting point, but it is not recalculated until - the rank-1 method fails to produce satisfactory progress. -0 Timing. The time required by HYBRJ to solve a given problem - depends on N, the behavior of the functions, the accuracy - requested, and the starting point. The number of arithmetic - operations needed by HYBRJ is about 11.5*(N**2) to process - each evaluation of the functions (call to FCN with IFLAG = 1) - and 1.3*(N**3) to process each evaluation of the Jacobian - (call to FCN with IFLAG = 2). Unless FCN can be evaluated - quickly, the timing of HYBRJ will be strongly influenced by - the time spent in FCN. -0 Storage. HYBRJ requires (3*N**2 + 17*N)/2 double precision - storage locations, in addition to the storage required by the - program. There are no internally declared storage arrays. -0 - 7. Subprograms required. -0 USER-supplied ...... FCN -0 MINPACK-supplied ... DOGLEG,DPMPAR,ENORM, - QFORM,QRFAC,R1MPYQ,R1UPDT -0 FORTRAN-supplied ... DABS,DMAX1,DMIN1,DSQRT,MIN0,MOD -0 - 8. References. -0 M. J. D. Powell, A Hybrid Method for Nonlinear Equations. - Numerical Methods for Nonlinear Algebraic Equations, - P. Rabinowitz, editor. Gordon and Breach, 1970. -0 - 9. Example. -1 -0 Page -0 The problem is to determine the values of x(1), x(2), ..., x(9) - which solve the system of tridiagonal equations -0 (3-2*x(1))*x(1) -2*x(2) = -1 - -x(i-1) + (3-2*x(i))*x(i) -2*x(i+1) = -1, i=2-8 - -x(8) + (3-2*x(9))*x(9) = -1 -0 C ********** - C - C DRIVER FOR HYBRJ EXAMPLE. - C DOUBLE PRECISION VERSION - C - C ********** - INTEGER J,N,LDFJAC,MAXFEV,MODE,NPRINT,INFO,NFEV,NJEV,LR,NWRITE - DOUBLE PRECISION XTOL,FACTOR,FNORM - DOUBLE PRECISION X(9),FVEC(9),FJAC(9,9),DIAG(9),R(45),QTF(9), - * WA1(9),WA2(9),WA3(9),WA4(9) - DOUBLE PRECISION ENORM,DPMPAR - EXTERNAL FCN - C - C LOGICAL OUTPUT UNIT IS ASSUMED TO BE NUMBER 6. - C - DATA NWRITE /6/ - C - N = 9 - C - C THE FOLLOWING STARTING VALUES PROVIDE A ROUGH SOLUTION. - C - DO 10 J = 1, 9 - X(J) = -1.D0 - 10 CONTINUE - C - LDFJAC = 9 - LR = 45 - C - C SET XTOL TO THE SQUARE ROOT OF THE MACHINE PRECISION. - C UNLESS HIGH PRECISION SOLUTIONS ARE REQUIRED, - C THIS IS THE RECOMMENDED SETTING. - C - XTOL = DSQRT(DPMPAR(1)) - C - MAXFEV = 1000 - MODE = 2 - DO 20 J = 1, 9 - DIAG(J) = 1.D0 - 20 CONTINUE - FACTOR = 1.D2 - NPRINT = 0 - C - CALL HYBRJ(FCN,N,X,FVEC,FJAC,LDFJAC,XTOL,MAXFEV,DIAG, - * MODE,FACTOR,NPRINT,INFO,NFEV,NJEV,R,LR,QTF, - * WA1,WA2,WA3,WA4) - FNORM = ENORM(N,FVEC) - WRITE (NWRITE,1000) FNORM,NFEV,NJEV,INFO,(X(J),J=1,N) -1 -0 Page -0 STOP - 1000 FORMAT (5X,31H FINAL L2 NORM OF THE RESIDUALS,D15.7 // - * 5X,31H NUMBER OF FUNCTION EVALUATIONS,I10 // - * 5X,31H NUMBER OF JACOBIAN EVALUATIONS,I10 // - * 5X,15H EXIT PARAMETER,16X,I10 // - * 5X,27H FINAL APPROXIMATE SOLUTION // (5X,3D15.7)) - C - C LAST CARD OF DRIVER FOR HYBRJ EXAMPLE. - C - END - SUBROUTINE FCN(N,X,FVEC,FJAC,LDFJAC,IFLAG) - INTEGER N,LDFJAC,IFLAG - DOUBLE PRECISION X(N),FVEC(N),FJAC(LDFJAC,N) - C - C SUBROUTINE FCN FOR HYBRJ EXAMPLE. - C - INTEGER J,K - DOUBLE PRECISION ONE,TEMP,TEMP1,TEMP2,THREE,TWO,ZERO - DATA ZERO,ONE,TWO,THREE,FOUR /0.D0,1.D0,2.D0,3.D0,4.D0/ - C - IF (IFLAG .NE. 0) GO TO 5 - C - C INSERT PRINT STATEMENTS HERE WHEN NPRINT IS POSITIVE. - C - RETURN - 5 CONTINUE - IF (IFLAG .EQ. 2) GO TO 20 - DO 10 K = 1, N - TEMP = (THREE - TWO*X(K))*X(K) - TEMP1 = ZERO - IF (K .NE. 1) TEMP1 = X(K-1) - TEMP2 = ZERO - IF (K .NE. N) TEMP2 = X(K+1) - FVEC(K) = TEMP - TEMP1 - TWO*TEMP2 + ONE - 10 CONTINUE - GO TO 50 - 20 CONTINUE - DO 40 K = 1, N - DO 30 J = 1, N - FJAC(K,J) = ZERO - 30 CONTINUE - FJAC(K,K) = THREE - FOUR*X(K) - IF (K .NE. 1) FJAC(K,K-1) = -ONE - IF (K .NE. N) FJAC(K,K+1) = -TWO - 40 CONTINUE - 50 CONTINUE - RETURN - C - C LAST CARD OF SUBROUTINE FCN. - C - END -0 Results obtained with different compilers or machines - may be slightly different. -1 -0 Page -0 FINAL L2 NORM OF THE RESIDUALS 0.1192636D-07 -0 NUMBER OF FUNCTION EVALUATIONS 11 -0 NUMBER OF JACOBIAN EVALUATIONS 1 -0 EXIT PARAMETER 1 -0 FINAL APPROXIMATE SOLUTION -0 -0.5706545D+00 -0.6816283D+00 -0.7017325D+00 - -0.7042129D+00 -0.7013690D+00 -0.6918656D+00 - -0.6657920D+00 -0.5960342D+00 -0.4164121D+00 -1 -0 -1 -0 Page -0 Documentation for MINPACK subroutine LMDER1 -0 Double precision version -0 Argonne National Laboratory -0 Burton S. Garbow, Kenneth E. Hillstrom, Jorge J. More -0 March 1980 -0 - 1. Purpose. -0 The purpose of LMDER1 is to minimize the sum of the squares of - nonlinear functions in N variables by a modification of the - Levenberg-Marquardt algorithm. This is done by using the more - general least-squares solver LMDER. The user must provide a - subroutine which calculates the functions and the Jacobian. -0 - 2. Subroutine and type statements. -0 SUBROUTINE LMDER1(FCN,M,N,X,FVEC,FJAC,LDFJAC,TOL, - * INFO,IPVT,WA,LWA) - INTEGER M,N,LDFJAC,INFO,LWA - INTEGER IPVT(N) - DOUBLE PRECISION TOL - DOUBLE PRECISION X(N),FVEC(M),FJAC(LDFJAC,N),WA(LWA) - EXTERNAL FCN -0 - 3. Parameters. -0 Parameters designated as input parameters must be specified on - entry to LMDER1 and are not changed on exit, while parameters - designated as output parameters need not be specified on entry - and are set to appropriate values on exit from LMDER1. -0 FCN is the name of the user-supplied subroutine which calculate - the functions and the Jacobian. FCN must be declared in an - EXTERNAL statement in the user calling program, and should be - written as follows. -0 SUBROUTINE FCN(M,N,X,FVEC,FJAC,LDFJAC,IFLAG) - INTEGER M,N,LDFJAC,IFLAG - DOUBLE PRECISION X(N),FVEC(M),FJAC(LDFJAC,N) - ---------- - IF IFLAG = 1 CALCULATE THE FUNCTIONS AT X AND - RETURN THIS VECTOR IN FVEC. DO NOT ALTER FJAC. - IF IFLAG = 2 CALCULATE THE JACOBIAN AT X AND - RETURN THIS MATRIX IN FJAC. DO NOT ALTER FVEC. - ---------- - RETURN - END -1 -0 Page -0 The value of IFLAG should not be changed by FCN unless the - user wants to terminate execution of LMDER1. In this case se - IFLAG to a negative integer. -0 M is a positive integer input variable set to the number of - functions. -0 N is a positive integer input variable set to the number of - variables. N must not exceed M. -0 X is an array of length N. On input X must contain an initial - estimate of the solution vector. On output X contains the - final estimate of the solution vector. -0 FVEC is an output array of length M which contains the function - evaluated at the output X. -0 FJAC is an output M by N array. The upper N by N submatrix of - FJAC contains an upper triangular matrix R with diagonal ele- - ments of nonincreasing magnitude such that -0 T T T - P *(JAC *JAC)*P = R *R, -0 where P is a permutation matrix and JAC is the final calcu- - lated Jacobian. Column j of P is column IPVT(j) (see below) - of the identity matrix. The lower trapezoidal part of FJAC - contains information generated during the computation of R. -0 LDFJAC is a positive integer input variable not less than M - which specifies the leading dimension of the array FJAC. -0 TOL is a nonnegative input variable. Termination occurs when - the algorithm estimates either that the relative error in the - sum of squares is at most TOL or that the relative error - between X and the solution is at most TOL. Section 4 contain - more details about TOL. -0 INFO is an integer output variable. If the user has terminated - execution, INFO is set to the (negative) value of IFLAG. See - description of FCN. Otherwise, INFO is set as follows. -0 INFO = 0 Improper input parameters. -0 INFO = 1 Algorithm estimates that the relative error in the - sum of squares is at most TOL. -0 INFO = 2 Algorithm estimates that the relative error between - X and the solution is at most TOL. -0 INFO = 3 Conditions for INFO = 1 and INFO = 2 both hold. -0 INFO = 4 FVEC is orthogonal to the columns of the Jacobian t - machine precision. -1 -0 Page -0 INFO = 5 Number of calls to FCN with IFLAG = 1 has reached - 100*(N+1). -0 INFO = 6 TOL is too small. No further reduction in the sum - of squares is possible. -0 INFO = 7 TOL is too small. No further improvement in the - approximate solution X is possible. -0 Sections 4 and 5 contain more details about INFO. -0 IPVT is an integer output array of length N. IPVT defines a - permutation matrix P such that JAC*P = Q*R, where JAC is the - final calculated Jacobian, Q is orthogonal (not stored), and - is upper triangular with diagonal elements of nonincreasing - magnitude. Column j of P is column IPVT(j) of the identity - matrix. -0 WA is a work array of length LWA. -0 LWA is a positive integer input variable not less than 5*N+M. -0 - 4. Successful completion. -0 The accuracy of LMDER1 is controlled by the convergence parame- - ter TOL. This parameter is used in tests which make three type - of comparisons between the approximation X and a solution XSOL. - LMDER1 terminates when any of the tests is satisfied. If TOL i - less than the machine precision (as defined by the MINPACK func - tion DPMPAR(1)), then LMDER1 only attempts to satisfy the test - defined by the machine precision. Further progress is not usu- - ally possible. Unless high precision solutions are required, - the recommended value for TOL is the square root of the machine - precision. -0 The tests assume that the functions and the Jacobian are coded - consistently, and that the functions are reasonably well - behaved. If these conditions are not satisfied, then LMDER1 ma - incorrectly indicate convergence. The coding of the Jacobian - can be checked by the MINPACK subroutine CHKDER. If the Jaco- - bian is coded correctly, then the validity of the answer can be - checked, for example, by rerunning LMDER1 with a tighter toler- - ance. -0 First convergence test. If ENORM(Z) denotes the Euclidean norm - of a vector Z, then this test attempts to guarantee that -0 ENORM(FVEC) .LE. (1+TOL)*ENORM(FVECS), -0 where FVECS denotes the functions evaluated at XSOL. If this - condition is satisfied with TOL = 10**(-K), then the final - residual norm ENORM(FVEC) has K significant decimal digits an - INFO is set to 1 (or to 3 if the second test is also -1 -0 Page -0 satisfied). -0 Second convergence test. If D is a diagonal matrix (implicitly - generated by LMDER1) whose entries contain scale factors for - the variables, then this test attempts to guarantee that -0 ENORM(D*(X-XSOL)) .LE. TOL*ENORM(D*XSOL). -0 If this condition is satisfied with TOL = 10**(-K), then the - larger components of D*X have K significant decimal digits an - INFO is set to 2 (or to 3 if the first test is also satis- - fied). There is a danger that the smaller components of D*X - may have large relative errors, but the choice of D is such - that the accuracy of the components of X is usually related t - their sensitivity. -0 Third convergence test. This test is satisfied when FVEC is - orthogonal to the columns of the Jacobian to machine preci- - sion. There is no clear relationship between this test and - the accuracy of LMDER1, and furthermore, the test is equally - well satisfied at other critical points, namely maximizers an - saddle points. Therefore, termination caused by this test - (INFO = 4) should be examined carefully. -0 - 5. Unsuccessful completion. -0 Unsuccessful termination of LMDER1 can be due to improper input - parameters, arithmetic interrupts, or an excessive number of - function evaluations. -0 Improper input parameters. INFO is set to 0 if N .LE. 0, or - M .LT. N, or LDFJAC .LT. M, or TOL .LT. 0.D0, or - LWA .LT. 5*N+M. -0 Arithmetic interrupts. If these interrupts occur in the FCN - subroutine during an early stage of the computation, they may - be caused by an unacceptable choice of X by LMDER1. In this - case, it may be possible to remedy the situation by not evalu - ating the functions here, but instead setting the components - of FVEC to numbers that exceed those in the initial FVEC, - thereby indirectly reducing the step length. The step length - can be more directly controlled by using instead LMDER, which - includes in its calling sequence the step-length- governing - parameter FACTOR. -0 Excessive number of function evaluations. If the number of - calls to FCN with IFLAG = 1 reaches 100*(N+1), then this indi - cates that the routine is converging very slowly as measured - by the progress of FVEC, and INFO is set to 5. In this case, - it may be helpful to restart LMDER1, thereby forcing it to - disregard old (and possibly harmful) information. -0 -1 -0 Page -0 6. Characteristics of the algorithm. -0 LMDER1 is a modification of the Levenberg-Marquardt algorithm. - Two of its main characteristics involve the proper use of - implicitly scaled variables and an optimal choice for the cor- - rection. The use of implicitly scaled variables achieves scale - invariance of LMDER1 and limits the size of the correction in - any direction where the functions are changing rapidly. The - optimal choice of the correction guarantees (under reasonable - conditions) global convergence from starting points far from th - solution and a fast rate of convergence for problems with small - residuals. -0 Timing. The time required by LMDER1 to solve a given problem - depends on M and N, the behavior of the functions, the accu- - racy requested, and the starting point. The number of arith- - metic operations needed by LMDER1 is about N**3 to process - each evaluation of the functions (call to FCN with IFLAG = 1) - and M*(N**2) to process each evaluation of the Jacobian (call - to FCN with IFLAG = 2). Unless FCN can be evaluated quickly, - the timing of LMDER1 will be strongly influenced by the time - spent in FCN. -0 Storage. LMDER1 requires M*N + 2*M + 6*N double precision sto- - rage locations and N integer storage locations, in addition t - the storage required by the program. There are no internally - declared storage arrays. -0 - 7. Subprograms required. -0 USER-supplied ...... FCN -0 MINPACK-supplied ... DPMPAR,ENORM,LMDER,LMPAR,QRFAC,QRSOLV -0 FORTRAN-supplied ... DABS,DMAX1,DMIN1,DSQRT,MOD -0 - 8. References. -0 Jorge J. More, The Levenberg-Marquardt Algorithm, Implementatio - and Theory. Numerical Analysis, G. A. Watson, editor. - Lecture Notes in Mathematics 630, Springer-Verlag, 1977. -0 - 9. Example. -0 The problem is to determine the values of x(1), x(2), and x(3) - which provide the best fit (in the least squares sense) of -0 x(1) + u(i)/(v(i)*x(2) + w(i)*x(3)), i = 1, 15 -0 to the data -1 -0 Page -0 y = (0.14,0.18,0.22,0.25,0.29,0.32,0.35,0.39, - 0.37,0.58,0.73,0.96,1.34,2.10,4.39), -0 where u(i) = i, v(i) = 16 - i, and w(i) = min(u(i),v(i)). The - i-th component of FVEC is thus defined by -0 y(i) - (x(1) + u(i)/(v(i)*x(2) + w(i)*x(3))). -0 C ********** - C - C DRIVER FOR LMDER1 EXAMPLE. - C DOUBLE PRECISION VERSION - C - C ********** - INTEGER J,M,N,LDFJAC,INFO,LWA,NWRITE - INTEGER IPVT(3) - DOUBLE PRECISION TOL,FNORM - DOUBLE PRECISION X(3),FVEC(15),FJAC(15,3),WA(30) - DOUBLE PRECISION ENORM,DPMPAR - EXTERNAL FCN - C - C LOGICAL OUTPUT UNIT IS ASSUMED TO BE NUMBER 6. - C - DATA NWRITE /6/ - C - M = 15 - N = 3 - C - C THE FOLLOWING STARTING VALUES PROVIDE A ROUGH FIT. - C - X(1) = 1.D0 - X(2) = 1.D0 - X(3) = 1.D0 - C - LDFJAC = 15 - LWA = 30 - C - C SET TOL TO THE SQUARE ROOT OF THE MACHINE PRECISION. - C UNLESS HIGH PRECISION SOLUTIONS ARE REQUIRED, - C THIS IS THE RECOMMENDED SETTING. - C - TOL = DSQRT(DPMPAR(1)) - C - CALL LMDER1(FCN,M,N,X,FVEC,FJAC,LDFJAC,TOL, - * INFO,IPVT,WA,LWA) - FNORM = ENORM(M,FVEC) - WRITE (NWRITE,1000) FNORM,INFO,(X(J),J=1,N) - STOP - 1000 FORMAT (5X,31H FINAL L2 NORM OF THE RESIDUALS,D15.7 // - * 5X,15H EXIT PARAMETER,16X,I10 // - * 5X,27H FINAL APPROXIMATE SOLUTION // 5X,3D15.7) - C - C LAST CARD OF DRIVER FOR LMDER1 EXAMPLE. - C -1 -0 Page -0 END - SUBROUTINE FCN(M,N,X,FVEC,FJAC,LDFJAC,IFLAG) - INTEGER M,N,LDFJAC,IFLAG - DOUBLE PRECISION X(N),FVEC(M),FJAC(LDFJAC,N) - C - C SUBROUTINE FCN FOR LMDER1 EXAMPLE. - C - INTEGER I - DOUBLE PRECISION TMP1,TMP2,TMP3,TMP4 - DOUBLE PRECISION Y(15) - DATA Y(1),Y(2),Y(3),Y(4),Y(5),Y(6),Y(7),Y(8), - * Y(9),Y(10),Y(11),Y(12),Y(13),Y(14),Y(15) - * /1.4D-1,1.8D-1,2.2D-1,2.5D-1,2.9D-1,3.2D-1,3.5D-1,3.9D-1, - * 3.7D-1,5.8D-1,7.3D-1,9.6D-1,1.34D0,2.1D0,4.39D0/ - C - IF (IFLAG .EQ. 2) GO TO 20 - DO 10 I = 1, 15 - TMP1 = I - TMP2 = 16 - I - TMP3 = TMP1 - IF (I .GT. 8) TMP3 = TMP2 - FVEC(I) = Y(I) - (X(1) + TMP1/(X(2)*TMP2 + X(3)*TMP3)) - 10 CONTINUE - GO TO 40 - 20 CONTINUE - DO 30 I = 1, 15 - TMP1 = I - TMP2 = 16 - I - TMP3 = TMP1 - IF (I .GT. 8) TMP3 = TMP2 - TMP4 = (X(2)*TMP2 + X(3)*TMP3)**2 - FJAC(I,1) = -1.D0 - FJAC(I,2) = TMP1*TMP2/TMP4 - FJAC(I,3) = TMP1*TMP3/TMP4 - 30 CONTINUE - 40 CONTINUE - RETURN - C - C LAST CARD OF SUBROUTINE FCN. - C - END -0 Results obtained with different compilers or machines - may be slightly different. -0 FINAL L2 NORM OF THE RESIDUALS 0.9063596D-01 -0 EXIT PARAMETER 1 -0 FINAL APPROXIMATE SOLUTION -0 0.8241058D-01 0.1133037D+01 0.2343695D+01 -1 -0 -1 -0 Page -0 Documentation for MINPACK subroutine LMDER -0 Double precision version -0 Argonne National Laboratory -0 Burton S. Garbow, Kenneth E. Hillstrom, Jorge J. More -0 March 1980 -0 - 1. Purpose. -0 The purpose of LMDER is to minimize the sum of the squares of M - nonlinear functions in N variables by a modification of the - Levenberg-Marquardt algorithm. The user must provide a subrou- - tine which calculates the functions and the Jacobian. -0 - 2. Subroutine and type statements. -0 SUBROUTINE LMDER(FCN,M,N,X,FVEC,FJAC,LDFJAC,FTOL,XTOL,GTOL, - * MAXFEV,DIAG,MODE,FACTOR,NPRINT,INFO,NFEV,NJEV, - * IPVT,QTF,WA1,WA2,WA3,WA4) - INTEGER M,N,LDFJAC,MAXFEV,MODE,NPRINT,INFO,NFEV,NJEV - INTEGER IPVT(N) - DOUBLE PRECISION FTOL,XTOL,GTOL,FACTOR - DOUBLE PRECISION X(N),FVEC(M),FJAC(LDFJAC,N),DIAG(N),QTF(N), - * WA1(N),WA2(N),WA3(N),WA4(M) -0 - 3. Parameters. -0 Parameters designated as input parameters must be specified on - entry to LMDER and are not changed on exit, while parameters - designated as output parameters need not be specified on entry - and are set to appropriate values on exit from LMDER. -0 FCN is the name of the user-supplied subroutine which calculate - the functions and the Jacobian. FCN must be declared in an - EXTERNAL statement in the user calling program, and should be - written as follows. -0 SUBROUTINE FCN(M,N,X,FVEC,FJAC,LDFJAC,IFLAG) - INTEGER M,N,LDFJAC,IFLAG - DOUBLE PRECISION X(N),FVEC(M),FJAC(LDFJAC,N) - ---------- - IF IFLAG = 1 CALCULATE THE FUNCTIONS AT X AND - RETURN THIS VECTOR IN FVEC. DO NOT ALTER FJAC. - IF IFLAG = 2 CALCULATE THE JACOBIAN AT X AND - RETURN THIS MATRIX IN FJAC. DO NOT ALTER FVEC. - ---------- - RETURN - END -1 -0 Page -0 The value of IFLAG should not be changed by FCN unless the - user wants to terminate execution of LMDER. In this case set - IFLAG to a negative integer. -0 M is a positive integer input variable set to the number of - functions. -0 N is a positive integer input variable set to the number of - variables. N must not exceed M. -0 X is an array of length N. On input X must contain an initial - estimate of the solution vector. On output X contains the - final estimate of the solution vector. -0 FVEC is an output array of length M which contains the function - evaluated at the output X. -0 FJAC is an output M by N array. The upper N by N submatrix of - FJAC contains an upper triangular matrix R with diagonal ele- - ments of nonincreasing magnitude such that -0 T T T - P *(JAC *JAC)*P = R *R, -0 where P is a permutation matrix and JAC is the final calcu- - lated Jacobian. Column j of P is column IPVT(j) (see below) - of the identity matrix. The lower trapezoidal part of FJAC - contains information generated during the computation of R. -0 LDFJAC is a positive integer input variable not less than M - which specifies the leading dimension of the array FJAC. -0 FTOL is a nonnegative input variable. Termination occurs when - both the actual and predicted relative reductions in the sum - of squares are at most FTOL. Therefore, FTOL measures the - relative error desired in the sum of squares. Section 4 con- - tains more details about FTOL. -0 XTOL is a nonnegative input variable. Termination occurs when - the relative error between two consecutive iterates is at mos - XTOL. Therefore, XTOL measures the relative error desired in - the approximate solution. Section 4 contains more details - about XTOL. -0 GTOL is a nonnegative input variable. Termination occurs when - the cosine of the angle between FVEC and any column of the - Jacobian is at most GTOL in absolute value. Therefore, GTOL - measures the orthogonality desired between the function vecto - and the columns of the Jacobian. Section 4 contains more - details about GTOL. -0 MAXFEV is a positive integer input variable. Termination occur - when the number of calls to FCN with IFLAG = 1 has reached - MAXFEV. -1 -0 Page -0 DIAG is an array of length N. If MODE = 1 (see below), DIAG is - internally set. If MODE = 2, DIAG must contain positive - entries that serve as multiplicative scale factors for the - variables. -0 MODE is an integer input variable. If MODE = 1, the variables - will be scaled internally. If MODE = 2, the scaling is speci - fied by the input DIAG. Other values of MODE are equivalent - to MODE = 1. -0 FACTOR is a positive input variable used in determining the ini - tial step bound. This bound is set to the product of FACTOR - and the Euclidean norm of DIAG*X if nonzero, or else to FACTO - itself. In most cases FACTOR should lie in the interval - (.1,100.). 100. is a generally recommended value. -0 NPRINT is an integer input variable that enables controlled - printing of iterates if it is positive. In this case, FCN is - called with IFLAG = 0 at the beginning of the first iteration - and every NPRINT iterations thereafter and immediately prior - to return, with X, FVEC, and FJAC available for printing. - FVEC and FJAC should not be altered. If NPRINT is not posi- - tive, no special calls of FCN with IFLAG = 0 are made. -0 INFO is an integer output variable. If the user has terminated - execution, INFO is set to the (negative) value of IFLAG. See - description of FCN. Otherwise, INFO is set as follows. -0 INFO = 0 Improper input parameters. -0 INFO = 1 Both actual and predicted relative reductions in th - sum of squares are at most FTOL. -0 INFO = 2 Relative error between two consecutive iterates is - at most XTOL. -0 INFO = 3 Conditions for INFO = 1 and INFO = 2 both hold. -0 INFO = 4 The cosine of the angle between FVEC and any column - of the Jacobian is at most GTOL in absolute value. -0 INFO = 5 Number of calls to FCN with IFLAG = 1 has reached - MAXFEV. -0 INFO = 6 FTOL is too small. No further reduction in the sum - of squares is possible. -0 INFO = 7 XTOL is too small. No further improvement in the - approximate solution X is possible. -0 INFO = 8 GTOL is too small. FVEC is orthogonal to the - columns of the Jacobian to machine precision. -0 Sections 4 and 5 contain more details about INFO. -1 -0 Page -0 NFEV is an integer output variable set to the number of calls t - FCN with IFLAG = 1. -0 NJEV is an integer output variable set to the number of calls t - FCN with IFLAG = 2. -0 IPVT is an integer output array of length N. IPVT defines a - permutation matrix P such that JAC*P = Q*R, where JAC is the - final calculated Jacobian, Q is orthogonal (not stored), and - is upper triangular with diagonal elements of nonincreasing - magnitude. Column j of P is column IPVT(j) of the identity - matrix. -0 QTF is an output array of length N which contains the first N - elements of the vector (Q transpose)*FVEC. -0 WA1, WA2, and WA3 are work arrays of length N. -0 WA4 is a work array of length M. -0 - 4. Successful completion. -0 The accuracy of LMDER is controlled by the convergence parame- - ters FTOL, XTOL, and GTOL. These parameters are used in tests - which make three types of comparisons between the approximation - X and a solution XSOL. LMDER terminates when any of the tests - is satisfied. If any of the convergence parameters is less tha - the machine precision (as defined by the MINPACK function - DPMPAR(1)), then LMDER only attempts to satisfy the test define - by the machine precision. Further progress is not usually pos- - sible. -0 The tests assume that the functions and the Jacobian are coded - consistently, and that the functions are reasonably well - behaved. If these conditions are not satisfied, then LMDER may - incorrectly indicate convergence. The coding of the Jacobian - can be checked by the MINPACK subroutine CHKDER. If the Jaco- - bian is coded correctly, then the validity of the answer can be - checked, for example, by rerunning LMDER with tighter toler- - ances. -0 First convergence test. If ENORM(Z) denotes the Euclidean norm - of a vector Z, then this test attempts to guarantee that -0 ENORM(FVEC) .LE. (1+FTOL)*ENORM(FVECS), -0 where FVECS denotes the functions evaluated at XSOL. If this - condition is satisfied with FTOL = 10**(-K), then the final - residual norm ENORM(FVEC) has K significant decimal digits an - INFO is set to 1 (or to 3 if the second test is also satis- - fied). Unless high precision solutions are required, the - recommended value for FTOL is the square root of the machine - precision. -1 -0 Page -0 Second convergence test. If D is the diagonal matrix whose - entries are defined by the array DIAG, then this test attempt - to guarantee that -0 ENORM(D*(X-XSOL)) .LE. XTOL*ENORM(D*XSOL). -0 If this condition is satisfied with XTOL = 10**(-K), then the - larger components of D*X have K significant decimal digits an - INFO is set to 2 (or to 3 if the first test is also satis- - fied). There is a danger that the smaller components of D*X - may have large relative errors, but if MODE = 1, then the - accuracy of the components of X is usually related to their - sensitivity. Unless high precision solutions are required, - the recommended value for XTOL is the square root of the - machine precision. -0 Third convergence test. This test is satisfied when the cosine - of the angle between FVEC and any column of the Jacobian at X - is at most GTOL in absolute value. There is no clear rela- - tionship between this test and the accuracy of LMDER, and - furthermore, the test is equally well satisfied at other crit - ical points, namely maximizers and saddle points. Therefore, - termination caused by this test (INFO = 4) should be examined - carefully. The recommended value for GTOL is zero. -0 - 5. Unsuccessful completion. -0 Unsuccessful termination of LMDER can be due to improper input - parameters, arithmetic interrupts, or an excessive number of - function evaluations. -0 Improper input parameters. INFO is set to 0 if N .LE. 0, or - M .LT. N, or LDFJAC .LT. M, or FTOL .LT. 0.D0, or - XTOL .LT. 0.D0, or GTOL .LT. 0.D0, or MAXFEV .LE. 0, or - FACTOR .LE. 0.D0. -0 Arithmetic interrupts. If these interrupts occur in the FCN - subroutine during an early stage of the computation, they may - be caused by an unacceptable choice of X by LMDER. In this - case, it may be possible to remedy the situation by rerunning - LMDER with a smaller value of FACTOR. -0 Excessive number of function evaluations. A reasonable value - for MAXFEV is 100*(N+1). If the number of calls to FCN with - IFLAG = 1 reaches MAXFEV, then this indicates that the routin - is converging very slowly as measured by the progress of FVEC - and INFO is set to 5. In this case, it may be helpful to - restart LMDER with MODE set to 1. -0 - 6. Characteristics of the algorithm. -0 LMDER is a modification of the Levenberg-Marquardt algorithm. -1 -0 Page -0 Two of its main characteristics involve the proper use of - implicitly scaled variables (if MODE = 1) and an optimal choice - for the correction. The use of implicitly scaled variables - achieves scale invariance of LMDER and limits the size of the - correction in any direction where the functions are changing - rapidly. The optimal choice of the correction guarantees (unde - reasonable conditions) global convergence from starting points - far from the solution and a fast rate of convergence for prob- - lems with small residuals. -0 Timing. The time required by LMDER to solve a given problem - depends on M and N, the behavior of the functions, the accu- - racy requested, and the starting point. The number of arith- - metic operations needed by LMDER is about N**3 to process eac - evaluation of the functions (call to FCN with IFLAG = 1) and - M*(N**2) to process each evaluation of the Jacobian (call to - FCN with IFLAG = 2). Unless FCN can be evaluated quickly, th - timing of LMDER will be strongly influenced by the time spent - in FCN. -0 Storage. LMDER requires M*N + 2*M + 6*N double precision sto- - rage locations and N integer storage locations, in addition t - the storage required by the program. There are no internally - declared storage arrays. -0 - 7. Subprograms required. -0 USER-supplied ...... FCN -0 MINPACK-supplied ... DPMPAR,ENORM,LMPAR,QRFAC,QRSOLV -0 FORTRAN-supplied ... DABS,DMAX1,DMIN1,DSQRT,MOD -0 - 8. References. -0 Jorge J. More, The Levenberg-Marquardt Algorithm, Implementatio - and Theory. Numerical Analysis, G. A. Watson, editor. - Lecture Notes in Mathematics 630, Springer-Verlag, 1977. -0 - 9. Example. -0 The problem is to determine the values of x(1), x(2), and x(3) - which provide the best fit (in the least squares sense) of -0 x(1) + u(i)/(v(i)*x(2) + w(i)*x(3)), i = 1, 15 -0 to the data -0 y = (0.14,0.18,0.22,0.25,0.29,0.32,0.35,0.39, - 0.37,0.58,0.73,0.96,1.34,2.10,4.39), -1 -0 Page -0 where u(i) = i, v(i) = 16 - i, and w(i) = min(u(i),v(i)). The - i-th component of FVEC is thus defined by -0 y(i) - (x(1) + u(i)/(v(i)*x(2) + w(i)*x(3))). -0 C ********** - C - C DRIVER FOR LMDER EXAMPLE. - C DOUBLE PRECISION VERSION - C - C ********** - INTEGER J,M,N,LDFJAC,MAXFEV,MODE,NPRINT,INFO,NFEV,NJEV,NWRITE - INTEGER IPVT(3) - DOUBLE PRECISION FTOL,XTOL,GTOL,FACTOR,FNORM - DOUBLE PRECISION X(3),FVEC(15),FJAC(15,3),DIAG(3),QTF(3), - * WA1(3),WA2(3),WA3(3),WA4(15) - DOUBLE PRECISION ENORM,DPMPAR - EXTERNAL FCN - C - C LOGICAL OUTPUT UNIT IS ASSUMED TO BE NUMBER 6. - C - DATA NWRITE /6/ - C - M = 15 - N = 3 - C - C THE FOLLOWING STARTING VALUES PROVIDE A ROUGH FIT. - C - X(1) = 1.D0 - X(2) = 1.D0 - X(3) = 1.D0 - C - LDFJAC = 15 - C - C SET FTOL AND XTOL TO THE SQUARE ROOT OF THE MACHINE PRECISION - C AND GTOL TO ZERO. UNLESS HIGH PRECISION SOLUTIONS ARE - C REQUIRED, THESE ARE THE RECOMMENDED SETTINGS. - C - FTOL = DSQRT(DPMPAR(1)) - XTOL = DSQRT(DPMPAR(1)) - GTOL = 0.D0 - C - MAXFEV = 400 - MODE = 1 - FACTOR = 1.D2 - NPRINT = 0 - C - CALL LMDER(FCN,M,N,X,FVEC,FJAC,LDFJAC,FTOL,XTOL,GTOL, - * MAXFEV,DIAG,MODE,FACTOR,NPRINT,INFO,NFEV,NJEV, - * IPVT,QTF,WA1,WA2,WA3,WA4) - FNORM = ENORM(M,FVEC) - WRITE (NWRITE,1000) FNORM,NFEV,NJEV,INFO,(X(J),J=1,N) - STOP - 1000 FORMAT (5X,31H FINAL L2 NORM OF THE RESIDUALS,D15.7 // -1 -0 Page -0 * 5X,31H NUMBER OF FUNCTION EVALUATIONS,I10 // - * 5X,31H NUMBER OF JACOBIAN EVALUATIONS,I10 // - * 5X,15H EXIT PARAMETER,16X,I10 // - * 5X,27H FINAL APPROXIMATE SOLUTION // 5X,3D15.7) - C - C LAST CARD OF DRIVER FOR LMDER EXAMPLE. - C - END - SUBROUTINE FCN(M,N,X,FVEC,FJAC,LDFJAC,IFLAG) - INTEGER M,N,LDFJAC,IFLAG - DOUBLE PRECISION X(N),FVEC(M),FJAC(LDFJAC,N) - C - C SUBROUTINE FCN FOR LMDER EXAMPLE. - C - INTEGER I - DOUBLE PRECISION TMP1,TMP2,TMP3,TMP4 - DOUBLE PRECISION Y(15) - DATA Y(1),Y(2),Y(3),Y(4),Y(5),Y(6),Y(7),Y(8), - * Y(9),Y(10),Y(11),Y(12),Y(13),Y(14),Y(15) - * /1.4D-1,1.8D-1,2.2D-1,2.5D-1,2.9D-1,3.2D-1,3.5D-1,3.9D-1, - * 3.7D-1,5.8D-1,7.3D-1,9.6D-1,1.34D0,2.1D0,4.39D0/ - C - IF (IFLAG .NE. 0) GO TO 5 - C - C INSERT PRINT STATEMENTS HERE WHEN NPRINT IS POSITIVE. - C - RETURN - 5 CONTINUE - IF (IFLAG .EQ. 2) GO TO 20 - DO 10 I = 1, 15 - TMP1 = I - TMP2 = 16 - I - TMP3 = TMP1 - IF (I .GT. 8) TMP3 = TMP2 - FVEC(I) = Y(I) - (X(1) + TMP1/(X(2)*TMP2 + X(3)*TMP3)) - 10 CONTINUE - GO TO 40 - 20 CONTINUE - DO 30 I = 1, 15 - TMP1 = I - TMP2 = 16 - I - TMP3 = TMP1 - IF (I .GT. 8) TMP3 = TMP2 - TMP4 = (X(2)*TMP2 + X(3)*TMP3)**2 - FJAC(I,1) = -1.D0 - FJAC(I,2) = TMP1*TMP2/TMP4 - FJAC(I,3) = TMP1*TMP3/TMP4 - 30 CONTINUE - 40 CONTINUE - RETURN - C - C LAST CARD OF SUBROUTINE FCN. - C - END -1 -0 Page -0 Results obtained with different compilers or machines - may be slightly different. -0 FINAL L2 NORM OF THE RESIDUALS 0.9063596D-01 -0 NUMBER OF FUNCTION EVALUATIONS 6 -0 NUMBER OF JACOBIAN EVALUATIONS 5 -0 EXIT PARAMETER 1 -0 FINAL APPROXIMATE SOLUTION -0 0.8241058D-01 0.1133037D+01 0.2343695D+01 -1 -0 -1 -0 Page -0 Documentation for MINPACK subroutine LMSTR1 -0 Double precision version -0 Argonne National Laboratory -0 Burton S. Garbow, Kenneth E. Hillstrom, Jorge J. More -0 March 1980 -0 - 1. Purpose. -0 The purpose of LMSTR1 is to minimize the sum of the squares of - nonlinear functions in N variables by a modification of the - Levenberg-Marquardt algorithm which uses minimal storage. This - is done by using the more general least-squares solver LMSTR. - The user must provide a subroutine which calculates the func- - tions and the rows of the Jacobian. -0 - 2. Subroutine and type statements. -0 SUBROUTINE LMSTR1(FCN,M,N,X,FVEC,FJAC,LDFJAC,TOL, - * INFO,IPVT,WA,LWA) - INTEGER M,N,LDFJAC,INFO,LWA - INTEGER IPVT(N) - DOUBLE PRECISION TOL - DOUBLE PRECISION X(N),FVEC(M),FJAC(LDFJAC,N),WA(LWA) - EXTERNAL FCN -0 - 3. Parameters. -0 Parameters designated as input parameters must be specified on - entry to LMSTR1 and are not changed on exit, while parameters - designated as output parameters need not be specified on entry - and are set to appropriate values on exit from LMSTR1. -0 FCN is the name of the user-supplied subroutine which calculate - the functions and the rows of the Jacobian. FCN must be - declared in an EXTERNAL statement in the user calling program - and should be written as follows. -0 SUBROUTINE FCN(M,N,X,FVEC,FJROW,IFLAG) - INTEGER M,N,IFLAG - DOUBLE PRECISION X(N),FVEC(M),FJROW(N) - ---------- - IF IFLAG = 1 CALCULATE THE FUNCTIONS AT X AND - RETURN THIS VECTOR IN FVEC. - IF IFLAG = I CALCULATE THE (I-1)-ST ROW OF THE - JACOBIAN AT X AND RETURN THIS VECTOR IN FJROW. - ---------- - RETURN -1 -0 Page -0 END -0 The value of IFLAG should not be changed by FCN unless the - user wants to terminate execution of LMSTR1. In this case se - IFLAG to a negative integer. -0 M is a positive integer input variable set to the number of - functions. -0 N is a positive integer input variable set to the number of - variables. N must not exceed M. -0 X is an array of length N. On input X must contain an initial - estimate of the solution vector. On output X contains the - final estimate of the solution vector. -0 FVEC is an output array of length M which contains the function - evaluated at the output X. -0 FJAC is an output N by N array. The upper triangle of FJAC con - tains an upper triangular matrix R such that -0 T T T - P *(JAC *JAC)*P = R *R, -0 where P is a permutation matrix and JAC is the final calcu- - lated Jacobian. Column j of P is column IPVT(j) (see below) - of the identity matrix. The lower triangular part of FJAC - contains information generated during the computation of R. -0 LDFJAC is a positive integer input variable not less than N - which specifies the leading dimension of the array FJAC. -0 TOL is a nonnegative input variable. Termination occurs when - the algorithm estimates either that the relative error in the - sum of squares is at most TOL or that the relative error - between X and the solution is at most TOL. Section 4 contain - more details about TOL. -0 INFO is an integer output variable. If the user has terminated - execution, INFO is set to the (negative) value of IFLAG. See - description of FCN. Otherwise, INFO is set as follows. -0 INFO = 0 Improper input parameters. -0 INFO = 1 Algorithm estimates that the relative error in the - sum of squares is at most TOL. -0 INFO = 2 Algorithm estimates that the relative error between - X and the solution is at most TOL. -0 INFO = 3 Conditions for INFO = 1 and INFO = 2 both hold. -0 INFO = 4 FVEC is orthogonal to the columns of the Jacobian t -1 -0 Page -0 machine precision. -0 INFO = 5 Number of calls to FCN with IFLAG = 1 has reached - 100*(N+1). -0 INFO = 6 TOL is too small. No further reduction in the sum - of squares is possible. -0 INFO = 7 TOL is too small. No further improvement in the - approximate solution X is possible. -0 Sections 4 and 5 contain more details about INFO. -0 IPVT is an integer output array of length N. IPVT defines a - permutation matrix P such that JAC*P = Q*R, where JAC is the - final calculated Jacobian, Q is orthogonal (not stored), and - is upper triangular. Column j of P is column IPVT(j) of the - identity matrix. -0 WA is a work array of length LWA. -0 LWA is a positive integer input variable not less than 5*N+M. -0 - 4. Successful completion. -0 The accuracy of LMSTR1 is controlled by the convergence parame- - ter TOL. This parameter is used in tests which make three type - of comparisons between the approximation X and a solution XSOL. - LMSTR1 terminates when any of the tests is satisfied. If TOL i - less than the machine precision (as defined by the MINPACK func - tion DPMPAR(1)), then LMSTR1 only attempts to satisfy the test - defined by the machine precision. Further progress is not usu- - ally possible. Unless high precision solutions are required, - the recommended value for TOL is the square root of the machine - precision. -0 The tests assume that the functions and the Jacobian are coded - consistently, and that the functions are reasonably well - behaved. If these conditions are not satisfied, then LMSTR1 ma - incorrectly indicate convergence. The coding of the Jacobian - can be checked by the MINPACK subroutine CHKDER. If the Jaco- - bian is coded correctly, then the validity of the answer can be - checked, for example, by rerunning LMSTR1 with a tighter toler- - ance. -0 First convergence test. If ENORM(Z) denotes the Euclidean norm - of a vector Z, then this test attempts to guarantee that -0 ENORM(FVEC) .LE. (1+TOL)*ENORM(FVECS), -0 where FVECS denotes the functions evaluated at XSOL. If this - condition is satisfied with TOL = 10**(-K), then the final - residual norm ENORM(FVEC) has K significant decimal digits an -1 -0 Page -0 INFO is set to 1 (or to 3 if the second test is also satis- - fied). -0 Second convergence test. If D is a diagonal matrix (implicitly - generated by LMSTR1) whose entries contain scale factors for - the variables, then this test attempts to guarantee that -0 ENORM(D*(X-XSOL)) .LE. TOL*ENORM(D*XSOL). -0 If this condition is satisfied with TOL = 10**(-K), then the - larger components of D*X have K significant decimal digits an - INFO is set to 2 (or to 3 if the first test is also satis- - fied). There is a danger that the smaller components of D*X - may have large relative errors, but the choice of D is such - that the accuracy of the components of X is usually related t - their sensitivity. -0 Third convergence test. This test is satisfied when FVEC is - orthogonal to the columns of the Jacobian to machine preci- - sion. There is no clear relationship between this test and - the accuracy of LMSTR1, and furthermore, the test is equally - well satisfied at other critical points, namely maximizers an - saddle points. Therefore, termination caused by this test - (INFO = 4) should be examined carefully. -0 - 5. Unsuccessful completion. -0 Unsuccessful termination of LMSTR1 can be due to improper input - parameters, arithmetic interrupts, or an excessive number of - function evaluations. -0 Improper input parameters. INFO is set to 0 if N .LE. 0, or - M .LT. N, or LDFJAC .LT. N, or TOL .LT. 0.D0, or - LWA .LT. 5*N+M. -0 Arithmetic interrupts. If these interrupts occur in the FCN - subroutine during an early stage of the computation, they may - be caused by an unacceptable choice of X by LMSTR1. In this - case, it may be possible to remedy the situation by not evalu - ating the functions here, but instead setting the components - of FVEC to numbers that exceed those in the initial FVEC, - thereby indirectly reducing the step length. The step length - can be more directly controlled by using instead LMSTR, which - includes in its calling sequence the step-length- governing - parameter FACTOR. -0 Excessive number of function evaluations. If the number of - calls to FCN with IFLAG = 1 reaches 100*(N+1), then this indi - cates that the routine is converging very slowly as measured - by the progress of FVEC, and INFO is set to 5. In this case, - it may be helpful to restart LMSTR1, thereby forcing it to - disregard old (and possibly harmful) information. -1 -0 Page -0 - 6. Characteristics of the algorithm. -0 LMSTR1 is a modification of the Levenberg-Marquardt algorithm. - Two of its main characteristics involve the proper use of - implicitly scaled variables and an optimal choice for the cor- - rection. The use of implicitly scaled variables achieves scale - invariance of LMSTR1 and limits the size of the correction in - any direction where the functions are changing rapidly. The - optimal choice of the correction guarantees (under reasonable - conditions) global convergence from starting points far from th - solution and a fast rate of convergence for problems with small - residuals. -0 Timing. The time required by LMSTR1 to solve a given problem - depends on M and N, the behavior of the functions, the accu- - racy requested, and the starting point. The number of arith- - metic operations needed by LMSTR1 is about N**3 to process - each evaluation of the functions (call to FCN with IFLAG = 1) - and 1.5*(N**2) to process each row of the Jacobian (call to - FCN with IFLAG .GE. 2). Unless FCN can be evaluated quickly, - the timing of LMSTR1 will be strongly influenced by the time - spent in FCN. -0 Storage. LMSTR1 requires N**2 + 2*M + 6*N double precision sto - rage locations and N integer storage locations, in addition t - the storage required by the program. There are no internally - declared storage arrays. -0 - 7. Subprograms required. -0 USER-supplied ...... FCN -0 MINPACK-supplied ... DPMPAR,ENORM,LMSTR,LMPAR,QRFAC,QRSOLV, - RWUPDT -0 FORTRAN-supplied ... DABS,DMAX1,DMIN1,DSQRT,MOD -0 - 8. References. -0 Jorge J. More, The Levenberg-Marquardt Algorithm, Implementatio - and Theory. Numerical Analysis, G. A. Watson, editor. - Lecture Notes in Mathematics 630, Springer-Verlag, 1977. -0 - 9. Example. -0 The problem is to determine the values of x(1), x(2), and x(3) - which provide the best fit (in the least squares sense) of -0 x(1) + u(i)/(v(i)*x(2) + w(i)*x(3)), i = 1, 15 -1 -0 Page -0 to the data -0 y = (0.14,0.18,0.22,0.25,0.29,0.32,0.35,0.39, - 0.37,0.58,0.73,0.96,1.34,2.10,4.39), -0 where u(i) = i, v(i) = 16 - i, and w(i) = min(u(i),v(i)). The - i-th component of FVEC is thus defined by -0 y(i) - (x(1) + u(i)/(v(i)*x(2) + w(i)*x(3))). -0 C ********** - C - C DRIVER FOR LMSTR1 EXAMPLE. - C DOUBLE PRECISION VERSION - C - C ********** - INTEGER J,M,N,LDFJAC,INFO,LWA,NWRITE - INTEGER IPVT(3) - DOUBLE PRECISION TOL,FNORM - DOUBLE PRECISION X(3),FVEC(15),FJAC(3,3),WA(30) - DOUBLE PRECISION ENORM,DPMPAR - EXTERNAL FCN - C - C LOGICAL OUTPUT UNIT IS ASSUMED TO BE NUMBER 6. - C - DATA NWRITE /6/ - C - M = 15 - N = 3 - C - C THE FOLLOWING STARTING VALUES PROVIDE A ROUGH FIT. - C - X(1) = 1.D0 - X(2) = 1.D0 - X(3) = 1.D0 - C - LDFJAC = 3 - LWA = 30 - C - C SET TOL TO THE SQUARE ROOT OF THE MACHINE PRECISION. - C UNLESS HIGH PRECISION SOLUTIONS ARE REQUIRED, - C THIS IS THE RECOMMENDED SETTING. - C - TOL = DSQRT(DPMPAR(1)) - C - CALL LMSTR1(FCN,M,N,X,FVEC,FJAC,LDFJAC,TOL, - * INFO,IPVT,WA,LWA) - FNORM = ENORM(M,FVEC) - WRITE (NWRITE,1000) FNORM,INFO,(X(J),J=1,N) - STOP - 1000 FORMAT (5X,31H FINAL L2 NORM OF THE RESIDUALS,D15.7 // - * 5X,15H EXIT PARAMETER,16X,I10 // - * 5X,27H FINAL APPROXIMATE SOLUTION // 5X,3D15.7) - C -1 -0 Page -0 C LAST CARD OF DRIVER FOR LMSTR1 EXAMPLE. - C - END - SUBROUTINE FCN(M,N,X,FVEC,FJROW,IFLAG) - INTEGER M,N,IFLAG - DOUBLE PRECISION X(N),FVEC(M),FJROW(N) - C - C SUBROUTINE FCN FOR LMSTR1 EXAMPLE. - C - INTEGER I - DOUBLE PRECISION TMP1,TMP2,TMP3,TMP4 - DOUBLE PRECISION Y(15) - DATA Y(1),Y(2),Y(3),Y(4),Y(5),Y(6),Y(7),Y(8), - * Y(9),Y(10),Y(11),Y(12),Y(13),Y(14),Y(15) - * /1.4D-1,1.8D-1,2.2D-1,2.5D-1,2.9D-1,3.2D-1,3.5D-1,3.9D-1, - * 3.7D-1,5.8D-1,7.3D-1,9.6D-1,1.34D0,2.1D0,4.39D0/ - C - IF (IFLAG .GE. 2) GO TO 20 - DO 10 I = 1, 15 - TMP1 = I - TMP2 = 16 - I - TMP3 = TMP1 - IF (I .GT. 8) TMP3 = TMP2 - FVEC(I) = Y(I) - (X(1) + TMP1/(X(2)*TMP2 + X(3)*TMP3)) - 10 CONTINUE - GO TO 40 - 20 CONTINUE - I = IFLAG - 1 - TMP1 = I - TMP2 = 16 - I - TMP3 = TMP1 - IF (I .GT. 8) TMP3 = TMP2 - TMP4 = (X(2)*TMP2 + X(3)*TMP3)**2 - FJROW(1) = -1.D0 - FJROW(2) = TMP1*TMP2/TMP4 - FJROW(3) = TMP1*TMP3/TMP4 - 30 CONTINUE - 40 CONTINUE - RETURN - C - C LAST CARD OF SUBROUTINE FCN. - C - END -0 Results obtained with different compilers or machines - may be slightly different. -0 FINAL L2 NORM OF THE RESIDUALS 0.9063596D-01 -0 EXIT PARAMETER 1 -0 FINAL APPROXIMATE SOLUTION -0 0.8241058D-01 0.1133037D+01 0.2343695D+01 -1 -0 -1 -0 Page -0 Documentation for MINPACK subroutine LMSTR -0 Double precision version -0 Argonne National Laboratory -0 Burton S. Garbow, Kenneth E. Hillstrom, Jorge J. More -0 March 1980 -0 - 1. Purpose. -0 The purpose of LMSTR is to minimize the sum of the squares of M - nonlinear functions in N variables by a modification of the - Levenberg-Marquardt algorithm which uses minimal storage. The - user must provide a subroutine which calculates the functions - and the rows of the Jacobian. -0 - 2. Subroutine and type statements. -0 SUBROUTINE LMSTR(FCN,M,N,X,FVEC,FJAC,LDFJAC,FTOL,XTOL,GTOL, - * MAXFEV,DIAG,MODE,FACTOR,NPRINT,INFO,NFEV,NJEV, - * IPVT,QTF,WA1,WA2,WA3,WA4) - INTEGER M,N,LDFJAC,MAXFEV,MODE,NPRINT,INFO,NFEV,NJEV - INTEGER IPVT(N) - DOUBLE PRECISION FTOL,XTOL,GTOL,FACTOR - DOUBLE PRECISION X(N),FVEC(M),FJAC(LDFJAC,N),DIAG(N),QTF(N), - * WA1(N),WA2(N),WA3(N),WA4(M) -0 - 3. Parameters. -0 Parameters designated as input parameters must be specified on - entry to LMSTR and are not changed on exit, while parameters - designated as output parameters need not be specified on entry - and are set to appropriate values on exit from LMSTR. -0 FCN is the name of the user-supplied subroutine which calculate - the functions and the rows of the Jacobian. FCN must be - declared in an EXTERNAL statement in the user calling program - and should be written as follows. -0 SUBROUTINE FCN(M,N,X,FVEC,FJROW,IFLAG) - INTEGER M,N,IFLAG - DOUBLE PRECISION X(N),FVEC(M),FJROW(N) - ---------- - IF IFLAG = 1 CALCULATE THE FUNCTIONS AT X AND - RETURN THIS VECTOR IN FVEC. - IF IFLAG = I CALCULATE THE (I-1)-ST ROW OF THE - JACOBIAN AT X AND RETURN THIS VECTOR IN FJROW. - ---------- - RETURN -1 -0 Page -0 END -0 The value of IFLAG should not be changed by FCN unless the - user wants to terminate execution of LMSTR. In this case set - IFLAG to a negative integer. -0 M is a positive integer input variable set to the number of - functions. -0 N is a positive integer input variable set to the number of - variables. N must not exceed M. -0 X is an array of length N. On input X must contain an initial - estimate of the solution vector. On output X contains the - final estimate of the solution vector. -0 FVEC is an output array of length M which contains the function - evaluated at the output X. -0 FJAC is an output N by N array. The upper triangle of FJAC con - tains an upper triangular matrix R such that -0 T T T - P *(JAC *JAC)*P = R *R, -0 where P is a permutation matrix and JAC is the final calcu- - lated Jacobian. Column j of P is column IPVT(j) (see below) - of the identity matrix. The lower triangular part of FJAC - contains information generated during the computation of R. -0 LDFJAC is a positive integer input variable not less than N - which specifies the leading dimension of the array FJAC. -0 FTOL is a nonnegative input variable. Termination occurs when - both the actual and predicted relative reductions in the sum - of squares are at most FTOL. Therefore, FTOL measures the - relative error desired in the sum of squares. Section 4 con- - tains more details about FTOL. -0 XTOL is a nonnegative input variable. Termination occurs when - the relative error between two consecutive iterates is at mos - XTOL. Therefore, XTOL measures the relative error desired in - the approximate solution. Section 4 contains more details - about XTOL. -0 GTOL is a nonnegative input variable. Termination occurs when - the cosine of the angle between FVEC and any column of the - Jacobian is at most GTOL in absolute value. Therefore, GTOL - measures the orthogonality desired between the function vecto - and the columns of the Jacobian. Section 4 contains more - details about GTOL. -0 MAXFEV is a positive integer input variable. Termination occur - when the number of calls to FCN with IFLAG = 1 has reached -1 -0 Page -0 MAXFEV. -0 DIAG is an array of length N. If MODE = 1 (see below), DIAG is - internally set. If MODE = 2, DIAG must contain positive - entries that serve as multiplicative scale factors for the - variables. -0 MODE is an integer input variable. If MODE = 1, the variables - will be scaled internally. If MODE = 2, the scaling is speci - fied by the input DIAG. Other values of MODE are equivalent - to MODE = 1. -0 FACTOR is a positive input variable used in determining the ini - tial step bound. This bound is set to the product of FACTOR - and the Euclidean norm of DIAG*X if nonzero, or else to FACTO - itself. In most cases FACTOR should lie in the interval - (.1,100.). 100. is a generally recommended value. -0 NPRINT is an integer input variable that enables controlled - printing of iterates if it is positive. In this case, FCN is - called with IFLAG = 0 at the beginning of the first iteration - and every NPRINT iterations thereafter and immediately prior - to return, with X and FVEC available for printing. If NPRINT - is not positive, no special calls of FCN with IFLAG = 0 are - made. -0 INFO is an integer output variable. If the user has terminated - execution, INFO is set to the (negative) value of IFLAG. See - description of FCN. Otherwise, INFO is set as follows. -0 INFO = 0 Improper input parameters. -0 INFO = 1 Both actual and predicted relative reductions in th - sum of squares are at most FTOL. -0 INFO = 2 Relative error between two consecutive iterates is - at most XTOL. -0 INFO = 3 Conditions for INFO = 1 and INFO = 2 both hold. -0 INFO = 4 The cosine of the angle between FVEC and any column - of the Jacobian is at most GTOL in absolute value. -0 INFO = 5 Number of calls to FCN with IFLAG = 1 has reached - MAXFEV. -0 INFO = 6 FTOL is too small. No further reduction in the sum - of squares is possible. -0 INFO = 7 XTOL is too small. No further improvement in the - approximate solution X is possible. -0 INFO = 8 GTOL is too small. FVEC is orthogonal to the - columns of the Jacobian to machine precision. -1 -0 Page -0 Sections 4 and 5 contain more details about INFO. -0 NFEV is an integer output variable set to the number of calls t - FCN with IFLAG = 1. -0 NJEV is an integer output variable set to the number of calls t - FCN with IFLAG = 2. -0 IPVT is an integer output array of length N. IPVT defines a - permutation matrix P such that JAC*P = Q*R, where JAC is the - final calculated Jacobian, Q is orthogonal (not stored), and - is upper triangular. Column j of P is column IPVT(j) of the - identity matrix. -0 QTF is an output array of length N which contains the first N - elements of the vector (Q transpose)*FVEC. -0 WA1, WA2, and WA3 are work arrays of length N. -0 WA4 is a work array of length M. -0 - 4. Successful completion. -0 The accuracy of LMSTR is controlled by the convergence parame- - ters FTOL, XTOL, and GTOL. These parameters are used in tests - which make three types of comparisons between the approximation - X and a solution XSOL. LMSTR terminates when any of the tests - is satisfied. If any of the convergence parameters is less tha - the machine precision (as defined by the MINPACK function - DPMPAR(1)), then LMSTR only attempts to satisfy the test define - by the machine precision. Further progress is not usually pos- - sible. -0 The tests assume that the functions and the Jacobian are coded - consistently, and that the functions are reasonably well - behaved. If these conditions are not satisfied, then LMSTR may - incorrectly indicate convergence. The coding of the Jacobian - can be checked by the MINPACK subroutine CHKDER. If the Jaco- - bian is coded correctly, then the validity of the answer can be - checked, for example, by rerunning LMSTR with tighter toler- - ances. -0 First convergence test. If ENORM(Z) denotes the Euclidean norm - of a vector Z, then this test attempts to guarantee that -0 ENORM(FVEC) .LE. (1+FTOL)*ENORM(FVECS), -0 where FVECS denotes the functions evaluated at XSOL. If this - condition is satisfied with FTOL = 10**(-K), then the final - residual norm ENORM(FVEC) has K significant decimal digits an - INFO is set to 1 (or to 3 if the second test is also satis- - fied). Unless high precision solutions are required, the - recommended value for FTOL is the square root of the machine -1 -0 Page -0 precision. -0 Second convergence test. If D is the diagonal matrix whose - entries are defined by the array DIAG, then this test attempt - to guarantee that -0 ENORM(D*(X-XSOL)) .LE. XTOL*ENORM(D*XSOL). -0 If this condition is satisfied with XTOL = 10**(-K), then the - larger components of D*X have K significant decimal digits an - INFO is set to 2 (or to 3 if the first test is also satis- - fied). There is a danger that the smaller components of D*X - may have large relative errors, but if MODE = 1, then the - accuracy of the components of X is usually related to their - sensitivity. Unless high precision solutions are required, - the recommended value for XTOL is the square root of the - machine precision. -0 Third convergence test. This test is satisfied when the cosine - of the angle between FVEC and any column of the Jacobian at X - is at most GTOL in absolute value. There is no clear rela- - tionship between this test and the accuracy of LMSTR, and - furthermore, the test is equally well satisfied at other crit - ical points, namely maximizers and saddle points. Therefore, - termination caused by this test (INFO = 4) should be examined - carefully. The recommended value for GTOL is zero. -0 - 5. Unsuccessful completion. -0 Unsuccessful termination of LMSTR can be due to improper input - parameters, arithmetic interrupts, or an excessive number of - function evaluations. -0 Improper input parameters. INFO is set to 0 if N .LE. 0, or - M .LT. N, or LDFJAC .LT. N, or FTOL .LT. 0.D0, or - XTOL .LT. 0.D0, or GTOL .LT. 0.D0, or MAXFEV .LE. 0, or - FACTOR .LE. 0.D0. -0 Arithmetic interrupts. If these interrupts occur in the FCN - subroutine during an early stage of the computation, they may - be caused by an unacceptable choice of X by LMSTR. In this - case, it may be possible to remedy the situation by rerunning - LMSTR with a smaller value of FACTOR. -0 Excessive number of function evaluations. A reasonable value - for MAXFEV is 100*(N+1). If the number of calls to FCN with - IFLAG = 1 reaches MAXFEV, then this indicates that the routin - is converging very slowly as measured by the progress of FVEC - and INFO is set to 5. In this case, it may be helpful to - restart LMSTR with MODE set to 1. -0 - 6. Characteristics of the algorithm. -1 -0 Page -0 LMSTR is a modification of the Levenberg-Marquardt algorithm. - Two of its main characteristics involve the proper use of - implicitly scaled variables (if MODE = 1) and an optimal choice - for the correction. The use of implicitly scaled variables - achieves scale invariance of LMSTR and limits the size of the - correction in any direction where the functions are changing - rapidly. The optimal choice of the correction guarantees (unde - reasonable conditions) global convergence from starting points - far from the solution and a fast rate of convergence for prob- - lems with small residuals. -0 Timing. The time required by LMSTR to solve a given problem - depends on M and N, the behavior of the functions, the accu- - racy requested, and the starting point. The number of arith- - metic operations needed by LMSTR is about N**3 to process eac - evaluation of the functions (call to FCN with IFLAG = 1) and - 1.5*(N**2) to process each row of the Jacobian (call to FCN - with IFLAG .GE. 2). Unless FCN can be evaluated quickly, the - timing of LMSTR will be strongly influenced by the time spent - in FCN. -0 Storage. LMSTR requires N**2 + 2*M + 6*N double precision sto- - rage locations and N integer storage locations, in addition t - the storage required by the program. There are no internally - declared storage arrays. -0 - 7. Subprograms required. -0 USER-supplied ...... FCN -0 MINPACK-supplied ... DPMPAR,ENORM,LMPAR,QRFAC,QRSOLV,RWUPDT -0 FORTRAN-supplied ... DABS,DMAX1,DMIN1,DSQRT,MOD -0 - 8. References. -0 Jorge J. More, The Levenberg-Marquardt Algorithm, Implementatio - and Theory. Numerical Analysis, G. A. Watson, editor. - Lecture Notes in Mathematics 630, Springer-Verlag, 1977. -0 - 9. Example. -0 The problem is to determine the values of x(1), x(2), and x(3) - which provide the best fit (in the least squares sense) of -0 x(1) + u(i)/(v(i)*x(2) + w(i)*x(3)), i = 1, 15 -0 to the data -0 y = (0.14,0.18,0.22,0.25,0.29,0.32,0.35,0.39, - 0.37,0.58,0.73,0.96,1.34,2.10,4.39), -1 -0 Page -0 where u(i) = i, v(i) = 16 - i, and w(i) = min(u(i),v(i)). The - i-th component of FVEC is thus defined by -0 y(i) - (x(1) + u(i)/(v(i)*x(2) + w(i)*x(3))). -0 C ********** - C - C DRIVER FOR LMSTR EXAMPLE. - C DOUBLE PRECISION VERSION - C - C ********** - INTEGER J,M,N,LDFJAC,MAXFEV,MODE,NPRINT,INFO,NFEV,NJEV,NWRITE - INTEGER IPVT(3) - DOUBLE PRECISION FTOL,XTOL,GTOL,FACTOR,FNORM - DOUBLE PRECISION X(3),FVEC(15),FJAC(3,3),DIAG(3),QTF(3), - * WA1(3),WA2(3),WA3(3),WA4(15) - DOUBLE PRECISION ENORM,DPMPAR - EXTERNAL FCN - C - C LOGICAL OUTPUT UNIT IS ASSUMED TO BE NUMBER 6. - C - DATA NWRITE /6/ - C - M = 15 - N = 3 - C - C THE FOLLOWING STARTING VALUES PROVIDE A ROUGH FIT. - C - X(1) = 1.D0 - X(2) = 1.D0 - X(3) = 1.D0 - C - LDFJAC = 3 - C - C SET FTOL AND XTOL TO THE SQUARE ROOT OF THE MACHINE PRECISION - C AND GTOL TO ZERO. UNLESS HIGH PRECISION SOLUTIONS ARE - C REQUIRED, THESE ARE THE RECOMMENDED SETTINGS. - C - FTOL = DSQRT(DPMPAR(1)) - XTOL = DSQRT(DPMPAR(1)) - GTOL = 0.D0 - C - MAXFEV = 400 - MODE = 1 - FACTOR = 1.D2 - NPRINT = 0 - C - CALL LMSTR(FCN,M,N,X,FVEC,FJAC,LDFJAC,FTOL,XTOL,GTOL, - * MAXFEV,DIAG,MODE,FACTOR,NPRINT,INFO,NFEV,NJEV, - * IPVT,QTF,WA1,WA2,WA3,WA4) - FNORM = ENORM(M,FVEC) - WRITE (NWRITE,1000) FNORM,NFEV,NJEV,INFO,(X(J),J=1,N) - STOP - 1000 FORMAT (5X,31H FINAL L2 NORM OF THE RESIDUALS,D15.7 // -1 -0 Page -0 * 5X,31H NUMBER OF FUNCTION EVALUATIONS,I10 // - * 5X,31H NUMBER OF JACOBIAN EVALUATIONS,I10 // - * 5X,15H EXIT PARAMETER,16X,I10 // - * 5X,27H FINAL APPROXIMATE SOLUTION // 5X,3D15.7) - C - C LAST CARD OF DRIVER FOR LMSTR EXAMPLE. - C - END - SUBROUTINE FCN(M,N,X,FVEC,FJROW,IFLAG) - INTEGER M,N,IFLAG - DOUBLE PRECISION X(N),FVEC(M),FJROW(N) - C - C SUBROUTINE FCN FOR LMSTR EXAMPLE. - C - INTEGER I - DOUBLE PRECISION TMP1,TMP2,TMP3,TMP4 - DOUBLE PRECISION Y(15) - DATA Y(1),Y(2),Y(3),Y(4),Y(5),Y(6),Y(7),Y(8), - * Y(9),Y(10),Y(11),Y(12),Y(13),Y(14),Y(15) - * /1.4D-1,1.8D-1,2.2D-1,2.5D-1,2.9D-1,3.2D-1,3.5D-1,3.9D-1, - * 3.7D-1,5.8D-1,7.3D-1,9.6D-1,1.34D0,2.1D0,4.39D0/ - C - IF (IFLAG .NE. 0) GO TO 5 - C - C INSERT PRINT STATEMENTS HERE WHEN NPRINT IS POSITIVE. - C - RETURN - 5 CONTINUE - IF (IFLAG .GE. 2) GO TO 20 - DO 10 I = 1, 15 - TMP1 = I - TMP2 = 16 - I - TMP3 = TMP1 - IF (I .GT. 8) TMP3 = TMP2 - FVEC(I) = Y(I) - (X(1) + TMP1/(X(2)*TMP2 + X(3)*TMP3)) - 10 CONTINUE - GO TO 40 - 20 CONTINUE - I = IFLAG - 1 - TMP1 = I - TMP2 = 16 - I - TMP3 = TMP1 - IF (I .GT. 8) TMP3 = TMP2 - TMP4 = (X(2)*TMP2 + X(3)*TMP3)**2 - FJROW(1) = -1.D0 - FJROW(2) = TMP1*TMP2/TMP4 - FJROW(3) = TMP1*TMP3/TMP4 - 30 CONTINUE - 40 CONTINUE - RETURN - C - C LAST CARD OF SUBROUTINE FCN. - C - END -1 -0 Page -0 Results obtained with different compilers or machines - may be slightly different. -0 FINAL L2 NORM OF THE RESIDUALS 0.9063596D-01 -0 NUMBER OF FUNCTION EVALUATIONS 6 -0 NUMBER OF JACOBIAN EVALUATIONS 5 -0 EXIT PARAMETER 1 -0 FINAL APPROXIMATE SOLUTION -0 0.8241058D-01 0.1133037D+01 0.2343695D+01 -1 -0 -1 -0 Page -0 Documentation for MINPACK subroutine LMDIF1 -0 Double precision version -0 Argonne National Laboratory -0 Burton S. Garbow, Kenneth E. Hillstrom, Jorge J. More -0 March 1980 -0 - 1. Purpose. -0 The purpose of LMDIF1 is to minimize the sum of the squares of - nonlinear functions in N variables by a modification of the - Levenberg-Marquardt algorithm. This is done by using the more - general least-squares solver LMDIF. The user must provide a - subroutine which calculates the functions. The Jacobian is the - calculated by a forward-difference approximation. -0 - 2. Subroutine and type statements. -0 SUBROUTINE LMDIF1(FCN,M,N,X,FVEC,TOL,INFO,IWA,WA,LWA) - INTEGER M,N,INFO,LWA - INTEGER IWA(N) - DOUBLE PRECISION TOL - DOUBLE PRECISION X(N),FVEC(M),WA(LWA) - EXTERNAL FCN -0 - 3. Parameters. -0 Parameters designated as input parameters must be specified on - entry to LMDIF1 and are not changed on exit, while parameters - designated as output parameters need not be specified on entry - and are set to appropriate values on exit from LMDIF1. -0 FCN is the name of the user-supplied subroutine which calculate - the functions. FCN must be declared in an EXTERNAL statement - in the user calling program, and should be written as follows -0 SUBROUTINE FCN(M,N,X,FVEC,IFLAG) - INTEGER M,N,IFLAG - DOUBLE PRECISION X(N),FVEC(M) - ---------- - CALCULATE THE FUNCTIONS AT X AND - RETURN THIS VECTOR IN FVEC. - ---------- - RETURN - END -0 The value of IFLAG should not be changed by FCN unless the - user wants to terminate execution of LMDIF1. In this case se -1 -0 Page -0 IFLAG to a negative integer. -0 M is a positive integer input variable set to the number of - functions. -0 N is a positive integer input variable set to the number of - variables. N must not exceed M. -0 X is an array of length N. On input X must contain an initial - estimate of the solution vector. On output X contains the - final estimate of the solution vector. -0 FVEC is an output array of length M which contains the function - evaluated at the output X. -0 TOL is a nonnegative input variable. Termination occurs when - the algorithm estimates either that the relative error in the - sum of squares is at most TOL or that the relative error - between X and the solution is at most TOL. Section 4 contain - more details about TOL. -0 INFO is an integer output variable. If the user has terminated - execution, INFO is set to the (negative) value of IFLAG. See - description of FCN. Otherwise, INFO is set as follows. -0 INFO = 0 Improper input parameters. -0 INFO = 1 Algorithm estimates that the relative error in the - sum of squares is at most TOL. -0 INFO = 2 Algorithm estimates that the relative error between - X and the solution is at most TOL. -0 INFO = 3 Conditions for INFO = 1 and INFO = 2 both hold. -0 INFO = 4 FVEC is orthogonal to the columns of the Jacobian t - machine precision. -0 INFO = 5 Number of calls to FCN has reached or exceeded - 200*(N+1). -0 INFO = 6 TOL is too small. No further reduction in the sum - of squares is possible. -0 INFO = 7 TOL is too small. No further improvement in the - approximate solution X is possible. -0 Sections 4 and 5 contain more details about INFO. -0 IWA is an integer work array of length N. -0 WA is a work array of length LWA. -0 LWA is a positive integer input variable not less than -1 -0 Page -0 M*N+5*N+M. -0 - 4. Successful completion. -0 The accuracy of LMDIF1 is controlled by the convergence parame- - ter TOL. This parameter is used in tests which make three type - of comparisons between the approximation X and a solution XSOL. - LMDIF1 terminates when any of the tests is satisfied. If TOL i - less than the machine precision (as defined by the MINPACK func - tion DPMPAR(1)), then LMDIF1 only attempts to satisfy the test - defined by the machine precision. Further progress is not usu- - ally possible. Unless high precision solutions are required, - the recommended value for TOL is the square root of the machine - precision. -0 The tests assume that the functions are reasonably well behaved - If this condition is not satisfied, then LMDIF1 may incorrectly - indicate convergence. The validity of the answer can be - checked, for example, by rerunning LMDIF1 with a tighter toler- - ance. -0 First convergence test. If ENORM(Z) denotes the Euclidean norm - of a vector Z, then this test attempts to guarantee that -0 ENORM(FVEC) .LE. (1+TOL)*ENORM(FVECS), -0 where FVECS denotes the functions evaluated at XSOL. If this - condition is satisfied with TOL = 10**(-K), then the final - residual norm ENORM(FVEC) has K significant decimal digits an - INFO is set to 1 (or to 3 if the second test is also satis- - fied). -0 Second convergence test. If D is a diagonal matrix (implicitly - generated by LMDIF1) whose entries contain scale factors for - the variables, then this test attempts to guarantee that -0 ENORM(D*(X-XSOL)) .LE. TOL*ENORM(D*XSOL). -0 If this condition is satisfied with TOL = 10**(-K), then the - larger components of D*X have K significant decimal digits an - INFO is set to 2 (or to 3 if the first test is also satis- - fied). There is a danger that the smaller components of D*X - may have large relative errors, but the choice of D is such - that the accuracy of the components of X is usually related t - their sensitivity. -0 Third convergence test. This test is satisfied when FVEC is - orthogonal to the columns of the Jacobian to machine preci- - sion. There is no clear relationship between this test and - the accuracy of LMDIF1, and furthermore, the test is equally - well satisfied at other critical points, namely maximizers an - saddle points. Also, errors in the functions (see below) may - result in the test being satisfied at a point not close to th -1 -0 Page -0 minimum. Therefore, termination caused by this test - (INFO = 4) should be examined carefully. -0 - 5. Unsuccessful completion. -0 Unsuccessful termination of LMDIF1 can be due to improper input - parameters, arithmetic interrupts, an excessive number of func- - tion evaluations, or errors in the functions. -0 Improper input parameters. INFO is set to 0 if N .LE. 0, or - M .LT. N, or TOL .LT. 0.D0, or LWA .LT. M*N+5*N+M. -0 Arithmetic interrupts. If these interrupts occur in the FCN - subroutine during an early stage of the computation, they may - be caused by an unacceptable choice of X by LMDIF1. In this - case, it may be possible to remedy the situation by not evalu - ating the functions here, but instead setting the components - of FVEC to numbers that exceed those in the initial FVEC, - thereby indirectly reducing the step length. The step length - can be more directly controlled by using instead LMDIF, which - includes in its calling sequence the step-length-governing - parameter FACTOR. -0 Excessive number of function evaluations. If the number of - calls to FCN reaches 200*(N+1), then this indicates that the - routine is converging very slowly as measured by the progress - of FVEC, and INFO is set to 5. In this case, it may be help- - ful to restart LMDIF1, thereby forcing it to disregard old - (and possibly harmful) information. -0 Errors in the functions. The choice of step length in the for- - ward-difference approximation to the Jacobian assumes that th - relative errors in the functions are of the order of the - machine precision. If this is not the case, LMDIF1 may fail - (usually with INFO = 4). The user should then use LMDIF - instead, or one of the programs which require the analytic - Jacobian (LMDER1 and LMDER). -0 - 6. Characteristics of the algorithm. -0 LMDIF1 is a modification of the Levenberg-Marquardt algorithm. - Two of its main characteristics involve the proper use of - implicitly scaled variables and an optimal choice for the cor- - rection. The use of implicitly scaled variables achieves scale - invariance of LMDIF1 and limits the size of the correction in - any direction where the functions are changing rapidly. The - optimal choice of the correction guarantees (under reasonable - conditions) global convergence from starting points far from th - solution and a fast rate of convergence for problems with small - residuals. -0 Timing. The time required by LMDIF1 to solve a given problem -1 -0 Page -0 depends on M and N, the behavior of the functions, the accu- - racy requested, and the starting point. The number of arith- - metic operations needed by LMDIF1 is about N**3 to process - each evaluation of the functions (one call to FCN) and - M*(N**2) to process each approximation to the Jacobian (N - calls to FCN). Unless FCN can be evaluated quickly, the tim- - ing of LMDIF1 will be strongly influenced by the time spent i - FCN. -0 Storage. LMDIF1 requires M*N + 2*M + 6*N double precision sto- - rage locations and N integer storage locations, in addition t - the storage required by the program. There are no internally - declared storage arrays. -0 - 7. Subprograms required. -0 USER-supplied ...... FCN -0 MINPACK-supplied ... DPMPAR,ENORM,FDJAC2,LMDIF,LMPAR, - QRFAC,QRSOLV -0 FORTRAN-supplied ... DABS,DMAX1,DMIN1,DSQRT,MOD -0 - 8. References. -0 Jorge J. More, The Levenberg-Marquardt Algorithm, Implementatio - and Theory. Numerical Analysis, G. A. Watson, editor. - Lecture Notes in Mathematics 630, Springer-Verlag, 1977. -0 - 9. Example. -0 The problem is to determine the values of x(1), x(2), and x(3) - which provide the best fit (in the least squares sense) of -0 x(1) + u(i)/(v(i)*x(2) + w(i)*x(3)), i = 1, 15 -0 to the data -0 y = (0.14,0.18,0.22,0.25,0.29,0.32,0.35,0.39, - 0.37,0.58,0.73,0.96,1.34,2.10,4.39), -0 where u(i) = i, v(i) = 16 - i, and w(i) = min(u(i),v(i)). The - i-th component of FVEC is thus defined by -0 y(i) - (x(1) + u(i)/(v(i)*x(2) + w(i)*x(3))). -0 C ********** - C - C DRIVER FOR LMDIF1 EXAMPLE. - C DOUBLE PRECISION VERSION - C -1 -0 Page -0 C ********** - INTEGER J,M,N,INFO,LWA,NWRITE - INTEGER IWA(3) - DOUBLE PRECISION TOL,FNORM - DOUBLE PRECISION X(3),FVEC(15),WA(75) - DOUBLE PRECISION ENORM,DPMPAR - EXTERNAL FCN - C - C LOGICAL OUTPUT UNIT IS ASSUMED TO BE NUMBER 6. - C - DATA NWRITE /6/ - C - M = 15 - N = 3 - C - C THE FOLLOWING STARTING VALUES PROVIDE A ROUGH FIT. - C - X(1) = 1.D0 - X(2) = 1.D0 - X(3) = 1.D0 - C - LWA = 75 - C - C SET TOL TO THE SQUARE ROOT OF THE MACHINE PRECISION. - C UNLESS HIGH PRECISION SOLUTIONS ARE REQUIRED, - C THIS IS THE RECOMMENDED SETTING. - C - TOL = DSQRT(DPMPAR(1)) - C - CALL LMDIF1(FCN,M,N,X,FVEC,TOL,INFO,IWA,WA,LWA) - FNORM = ENORM(M,FVEC) - WRITE (NWRITE,1000) FNORM,INFO,(X(J),J=1,N) - STOP - 1000 FORMAT (5X,31H FINAL L2 NORM OF THE RESIDUALS,D15.7 // - * 5X,15H EXIT PARAMETER,16X,I10 // - * 5X,27H FINAL APPROXIMATE SOLUTION // 5X,3D15.7) - C - C LAST CARD OF DRIVER FOR LMDIF1 EXAMPLE. - C - END - SUBROUTINE FCN(M,N,X,FVEC,IFLAG) - INTEGER M,N,IFLAG - DOUBLE PRECISION X(N),FVEC(M) - C - C SUBROUTINE FCN FOR LMDIF1 EXAMPLE. - C - INTEGER I - DOUBLE PRECISION TMP1,TMP2,TMP3 - DOUBLE PRECISION Y(15) - DATA Y(1),Y(2),Y(3),Y(4),Y(5),Y(6),Y(7),Y(8), - * Y(9),Y(10),Y(11),Y(12),Y(13),Y(14),Y(15) - * /1.4D-1,1.8D-1,2.2D-1,2.5D-1,2.9D-1,3.2D-1,3.5D-1,3.9D-1, - * 3.7D-1,5.8D-1,7.3D-1,9.6D-1,1.34D0,2.1D0,4.39D0/ - C -1 -0 Page -0 DO 10 I = 1, 15 - TMP1 = I - TMP2 = 16 - I - TMP3 = TMP1 - IF (I .GT. 8) TMP3 = TMP2 - FVEC(I) = Y(I) - (X(1) + TMP1/(X(2)*TMP2 + X(3)*TMP3)) - 10 CONTINUE - RETURN - C - C LAST CARD OF SUBROUTINE FCN. - C - END -0 Results obtained with different compilers or machines - may be slightly different. -0 FINAL L2 NORM OF THE RESIDUALS 0.9063596D-01 -0 EXIT PARAMETER 1 -0 FINAL APPROXIMATE SOLUTION -0 0.8241057D-01 0.1133037D+01 0.2343695D+01 -1 -0 -1 -0 Page -0 Documentation for MINPACK subroutine LMDIF -0 Double precision version -0 Argonne National Laboratory -0 Burton S. Garbow, Kenneth E. Hillstrom, Jorge J. More -0 March 1980 -0 - 1. Purpose. -0 The purpose of LMDIF is to minimize the sum of the squares of M - nonlinear functions in N variables by a modification of the - Levenberg-Marquardt algorithm. The user must provide a subrou- - tine which calculates the functions. The Jacobian is then cal- - culated by a forward-difference approximation. -0 - 2. Subroutine and type statements. -0 SUBROUTINE LMDIF(FCN,M,N,X,FVEC,FTOL,XTOL,GTOL,MAXFEV,EPSFCN, - * DIAG,MODE,FACTOR,NPRINT,INFO,NFEV,FJAC,LDFJAC, - * IPVT,QTF,WA1,WA2,WA3,WA4) - INTEGER M,N,MAXFEV,MODE,NPRINT,INFO,NFEV,LDFJAC - INTEGER IPVT(N) - DOUBLE PRECISION FTOL,XTOL,GTOL,EPSFCN,FACTOR - DOUBLE PRECISION X(N),FVEC(M),DIAG(N),FJAC(LDFJAC,N),QTF(N), - * WA1(N),WA2(N),WA3(N),WA4(M) - EXTERNAL FCN -0 - 3. Parameters. -0 Parameters designated as input parameters must be specified on - entry to LMDIF and are not changed on exit, while parameters - designated as output parameters need not be specified on entry - and are set to appropriate values on exit from LMDIF. -0 FCN is the name of the user-supplied subroutine which calculate - the functions. FCN must be declared in an EXTERNAL statement - in the user calling program, and should be written as follows -0 SUBROUTINE FCN(M,N,X,FVEC,IFLAG) - INTEGER M,N,IFLAG - DOUBLE PRECISION X(N),FVEC(M) - ---------- - CALCULATE THE FUNCTIONS AT X AND - RETURN THIS VECTOR IN FVEC. - ---------- - RETURN - END -1 -0 Page -0 The value of IFLAG should not be changed by FCN unless the - user wants to terminate execution of LMDIF. In this case set - IFLAG to a negative integer. -0 M is a positive integer input variable set to the number of - functions. -0 N is a positive integer input variable set to the number of - variables. N must not exceed M. -0 X is an array of length N. On input X must contain an initial - estimate of the solution vector. On output X contains the - final estimate of the solution vector. -0 FVEC is an output array of length M which contains the function - evaluated at the output X. -0 FTOL is a nonnegative input variable. Termination occurs when - both the actual and predicted relative reductions in the sum - of squares are at most FTOL. Therefore, FTOL measures the - relative error desired in the sum of squares. Section 4 con- - tains more details about FTOL. -0 XTOL is a nonnegative input variable. Termination occurs when - the relative error between two consecutive iterates is at mos - XTOL. Therefore, XTOL measures the relative error desired in - the approximate solution. Section 4 contains more details - about XTOL. -0 GTOL is a nonnegative input variable. Termination occurs when - the cosine of the angle between FVEC and any column of the - Jacobian is at most GTOL in absolute value. Therefore, GTOL - measures the orthogonality desired between the function vecto - and the columns of the Jacobian. Section 4 contains more - details about GTOL. -0 MAXFEV is a positive integer input variable. Termination occur - when the number of calls to FCN is at least MAXFEV by the end - of an iteration. -0 EPSFCN is an input variable used in determining a suitable step - for the forward-difference approximation. This approximation - assumes that the relative errors in the functions are of the - order of EPSFCN. If EPSFCN is less than the machine preci- - sion, it is assumed that the relative errors in the functions - are of the order of the machine precision. -0 DIAG is an array of length N. If MODE = 1 (see below), DIAG is - internally set. If MODE = 2, DIAG must contain positive - entries that serve as multiplicative scale factors for the - variables. -0 MODE is an integer input variable. If MODE = 1, the variables - will be scaled internally. If MODE = 2, the scaling is -1 -0 Page -0 specified by the input DIAG. Other values of MODE are equiva - lent to MODE = 1. -0 FACTOR is a positive input variable used in determining the ini - tial step bound. This bound is set to the product of FACTOR - and the Euclidean norm of DIAG*X if nonzero, or else to FACTO - itself. In most cases FACTOR should lie in the interval - (.1,100.). 100. is a generally recommended value. -0 NPRINT is an integer input variable that enables controlled - printing of iterates if it is positive. In this case, FCN is - called with IFLAG = 0 at the beginning of the first iteration - and every NPRINT iterations thereafter and immediately prior - to return, with X and FVEC available for printing. If NPRINT - is not positive, no special calls of FCN with IFLAG = 0 are - made. -0 INFO is an integer output variable. If the user has terminated - execution, INFO is set to the (negative) value of IFLAG. See - description of FCN. Otherwise, INFO is set as follows. -0 INFO = 0 Improper input parameters. -0 INFO = 1 Both actual and predicted relative reductions in th - sum of squares are at most FTOL. -0 INFO = 2 Relative error between two consecutive iterates is - at most XTOL. -0 INFO = 3 Conditions for INFO = 1 and INFO = 2 both hold. -0 INFO = 4 The cosine of the angle between FVEC and any column - of the Jacobian is at most GTOL in absolute value. -0 INFO = 5 Number of calls to FCN has reached or exceeded - MAXFEV. -0 INFO = 6 FTOL is too small. No further reduction in the sum - of squares is possible. -0 INFO = 7 XTOL is too small. No further improvement in the - approximate solution X is possible. -0 INFO = 8 GTOL is too small. FVEC is orthogonal to the - columns of the Jacobian to machine precision. -0 Sections 4 and 5 contain more details about INFO. -0 NFEV is an integer output variable set to the number of calls t - FCN. -0 FJAC is an output M by N array. The upper N by N submatrix of - FJAC contains an upper triangular matrix R with diagonal ele- - ments of nonincreasing magnitude such that -1 -0 Page -0 T T T - P *(JAC *JAC)*P = R *R, -0 where P is a permutation matrix and JAC is the final calcu- - lated Jacobian. Column j of P is column IPVT(j) (see below) - of the identity matrix. The lower trapezoidal part of FJAC - contains information generated during the computation of R. -0 LDFJAC is a positive integer input variable not less than M - which specifies the leading dimension of the array FJAC. -0 IPVT is an integer output array of length N. IPVT defines a - permutation matrix P such that JAC*P = Q*R, where JAC is the - final calculated Jacobian, Q is orthogonal (not stored), and - is upper triangular with diagonal elements of nonincreasing - magnitude. Column j of P is column IPVT(j) of the identity - matrix. -0 QTF is an output array of length N which contains the first N - elements of the vector (Q transpose)*FVEC. -0 WA1, WA2, and WA3 are work arrays of length N. -0 WA4 is a work array of length M. -0 - 4. Successful completion. -0 The accuracy of LMDIF is controlled by the convergence parame- - ters FTOL, XTOL, and GTOL. These parameters are used in tests - which make three types of comparisons between the approximation - X and a solution XSOL. LMDIF terminates when any of the tests - is satisfied. If any of the convergence parameters is less tha - the machine precision (as defined by the MINPACK function - DPMPAR(1)), then LMDIF only attempts to satisfy the test define - by the machine precision. Further progress is not usually pos- - sible. -0 The tests assume that the functions are reasonably well behaved - If this condition is not satisfied, then LMDIF may incorrectly - indicate convergence. The validity of the answer can be - checked, for example, by rerunning LMDIF with tighter toler- - ances. -0 First convergence test. If ENORM(Z) denotes the Euclidean norm - of a vector Z, then this test attempts to guarantee that -0 ENORM(FVEC) .LE. (1+FTOL)*ENORM(FVECS), -0 where FVECS denotes the functions evaluated at XSOL. If this - condition is satisfied with FTOL = 10**(-K), then the final - residual norm ENORM(FVEC) has K significant decimal digits an - INFO is set to 1 (or to 3 if the second test is also satis- - fied). Unless high precision solutions are required, the -1 -0 Page -0 recommended value for FTOL is the square root of the machine - precision. -0 Second convergence test. If D is the diagonal matrix whose - entries are defined by the array DIAG, then this test attempt - to guarantee that -0 ENORM(D*(X-XSOL)) .LE. XTOL*ENORM(D*XSOL). -0 If this condition is satisfied with XTOL = 10**(-K), then the - larger components of D*X have K significant decimal digits an - INFO is set to 2 (or to 3 if the first test is also satis- - fied). There is a danger that the smaller components of D*X - may have large relative errors, but if MODE = 1, then the - accuracy of the components of X is usually related to their - sensitivity. Unless high precision solutions are required, - the recommended value for XTOL is the square root of the - machine precision. -0 Third convergence test. This test is satisfied when the cosine - of the angle between FVEC and any column of the Jacobian at X - is at most GTOL in absolute value. There is no clear rela- - tionship between this test and the accuracy of LMDIF, and - furthermore, the test is equally well satisfied at other crit - ical points, namely maximizers and saddle points. Therefore, - termination caused by this test (INFO = 4) should be examined - carefully. The recommended value for GTOL is zero. -0 - 5. Unsuccessful completion. -0 Unsuccessful termination of LMDIF can be due to improper input - parameters, arithmetic interrupts, or an excessive number of - function evaluations. -0 Improper input parameters. INFO is set to 0 if N .LE. 0, or - M .LT. N, or LDFJAC .LT. M, or FTOL .LT. 0.D0, or - XTOL .LT. 0.D0, or GTOL .LT. 0.D0, or MAXFEV .LE. 0, or - FACTOR .LE. 0.D0. -0 Arithmetic interrupts. If these interrupts occur in the FCN - subroutine during an early stage of the computation, they may - be caused by an unacceptable choice of X by LMDIF. In this - case, it may be possible to remedy the situation by rerunning - LMDIF with a smaller value of FACTOR. -0 Excessive number of function evaluations. A reasonable value - for MAXFEV is 200*(N+1). If the number of calls to FCN - reaches MAXFEV, then this indicates that the routine is con- - verging very slowly as measured by the progress of FVEC, and - INFO is set to 5. In this case, it may be helpful to restart - LMDIF with MODE set to 1. -0 -1 -0 Page -0 6. Characteristics of the algorithm. -0 LMDIF is a modification of the Levenberg-Marquardt algorithm. - Two of its main characteristics involve the proper use of - implicitly scaled variables (if MODE = 1) and an optimal choice - for the correction. The use of implicitly scaled variables - achieves scale invariance of LMDIF and limits the size of the - correction in any direction where the functions are changing - rapidly. The optimal choice of the correction guarantees (unde - reasonable conditions) global convergence from starting points - far from the solution and a fast rate of convergence for prob- - lems with small residuals. -0 Timing. The time required by LMDIF to solve a given problem - depends on M and N, the behavior of the functions, the accu- - racy requested, and the starting point. The number of arith- - metic operations needed by LMDIF is about N**3 to process eac - evaluation of the functions (one call to FCN) and M*(N**2) to - process each approximation to the Jacobian (N calls to FCN). - Unless FCN can be evaluated quickly, the timing of LMDIF will - be strongly influenced by the time spent in FCN. -0 Storage. LMDIF requires M*N + 2*M + 6*N double precision sto- - rage locations and N integer storage locations, in addition t - the storage required by the program. There are no internally - declared storage arrays. -0 - 7. Subprograms required. -0 USER-supplied ...... FCN -0 MINPACK-supplied ... DPMPAR,ENORM,FDJAC2,LMPAR,QRFAC,QRSOLV -0 FORTRAN-supplied ... DABS,DMAX1,DMIN1,DSQRT,MOD -0 - 8. References. -0 Jorge J. More, The Levenberg-Marquardt Algorithm, Implementatio - and Theory. Numerical Analysis, G. A. Watson, editor. - Lecture Notes in Mathematics 630, Springer-Verlag, 1977. -0 - 9. Example. -0 The problem is to determine the values of x(1), x(2), and x(3) - which provide the best fit (in the least squares sense) of -0 x(1) + u(i)/(v(i)*x(2) + w(i)*x(3)), i = 1, 15 -0 to the data -1 -0 Page -0 y = (0.14,0.18,0.22,0.25,0.29,0.32,0.35,0.39, - 0.37,0.58,0.73,0.96,1.34,2.10,4.39), -0 where u(i) = i, v(i) = 16 - i, and w(i) = min(u(i),v(i)). The - i-th component of FVEC is thus defined by -0 y(i) - (x(1) + u(i)/(v(i)*x(2) + w(i)*x(3))). -0 C ********** - C - C DRIVER FOR LMDIF EXAMPLE. - C DOUBLE PRECISION VERSION - C - C ********** - INTEGER J,M,N,MAXFEV,MODE,NPRINT,INFO,NFEV,LDFJAC,NWRITE - INTEGER IPVT(3) - DOUBLE PRECISION FTOL,XTOL,GTOL,EPSFCN,FACTOR,FNORM - DOUBLE PRECISION X(3),FVEC(15),DIAG(3),FJAC(15,3),QTF(3), - * WA1(3),WA2(3),WA3(3),WA4(15) - DOUBLE PRECISION ENORM,DPMPAR - EXTERNAL FCN - C - C LOGICAL OUTPUT UNIT IS ASSUMED TO BE NUMBER 6. - C - DATA NWRITE /6/ - C - M = 15 - N = 3 - C - C THE FOLLOWING STARTING VALUES PROVIDE A ROUGH FIT. - C - X(1) = 1.D0 - X(2) = 1.D0 - X(3) = 1.D0 - C - LDFJAC = 15 - C - C SET FTOL AND XTOL TO THE SQUARE ROOT OF THE MACHINE PRECISION - C AND GTOL TO ZERO. UNLESS HIGH PRECISION SOLUTIONS ARE - C REQUIRED, THESE ARE THE RECOMMENDED SETTINGS. - C - FTOL = DSQRT(DPMPAR(1)) - XTOL = DSQRT(DPMPAR(1)) - GTOL = 0.D0 - C - MAXFEV = 800 - EPSFCN = 0.D0 - MODE = 1 - FACTOR = 1.D2 - NPRINT = 0 - C - CALL LMDIF(FCN,M,N,X,FVEC,FTOL,XTOL,GTOL,MAXFEV,EPSFCN, - * DIAG,MODE,FACTOR,NPRINT,INFO,NFEV,FJAC,LDFJAC, - * IPVT,QTF,WA1,WA2,WA3,WA4) -1 -0 Page -0 FNORM = ENORM(M,FVEC) - WRITE (NWRITE,1000) FNORM,NFEV,INFO,(X(J),J=1,N) - STOP - 1000 FORMAT (5X,31H FINAL L2 NORM OF THE RESIDUALS,D15.7 // - * 5X,31H NUMBER OF FUNCTION EVALUATIONS,I10 // - * 5X,15H EXIT PARAMETER,16X,I10 // - * 5X,27H FINAL APPROXIMATE SOLUTION // 5X,3D15.7) - C - C LAST CARD OF DRIVER FOR LMDIF EXAMPLE. - C - END - SUBROUTINE FCN(M,N,X,FVEC,IFLAG) - INTEGER M,N,IFLAG - DOUBLE PRECISION X(N),FVEC(M) - C - C SUBROUTINE FCN FOR LMDIF EXAMPLE. - C - INTEGER I - DOUBLE PRECISION TMP1,TMP2,TMP3 - DOUBLE PRECISION Y(15) - DATA Y(1),Y(2),Y(3),Y(4),Y(5),Y(6),Y(7),Y(8), - * Y(9),Y(10),Y(11),Y(12),Y(13),Y(14),Y(15) - * /1.4D-1,1.8D-1,2.2D-1,2.5D-1,2.9D-1,3.2D-1,3.5D-1,3.9D-1, - * 3.7D-1,5.8D-1,7.3D-1,9.6D-1,1.34D0,2.1D0,4.39D0/ - C - IF (IFLAG .NE. 0) GO TO 5 - C - C INSERT PRINT STATEMENTS HERE WHEN NPRINT IS POSITIVE. - C - RETURN - 5 CONTINUE - DO 10 I = 1, 15 - TMP1 = I - TMP2 = 16 - I - TMP3 = TMP1 - IF (I .GT. 8) TMP3 = TMP2 - FVEC(I) = Y(I) - (X(1) + TMP1/(X(2)*TMP2 + X(3)*TMP3)) - 10 CONTINUE - RETURN - C - C LAST CARD OF SUBROUTINE FCN. - C - END -0 Results obtained with different compilers or machines - may be slightly different. -0 FINAL L2 NORM OF THE RESIDUALS 0.9063596D-01 -0 NUMBER OF FUNCTION EVALUATIONS 21 -0 EXIT PARAMETER 1 -0 FINAL APPROXIMATE SOLUTION -1 -0 Page -0 0.8241057D-01 0.1133037D+01 0.2343695D+01 -1 -0 -1 -0 Page -0 Documentation for MINPACK subroutine CHKDER -0 Double precision version -0 Argonne National Laboratory -0 Burton S. Garbow, Kenneth E. Hillstrom, Jorge J. More -0 March 1980 -0 - 1. Purpose. -0 The purpose of CHKDER is to check the gradients of M nonlinear - functions in N variables, evaluated at a point X, for consis- - tency with the functions themselves. The user must call CHKDER - twice, first with MODE = 1 and then with MODE = 2. -0 - 2. Subroutine and type statements. -0 SUBROUTINE CHKDER(M,N,X,FVEC,FJAC,LDFJAC,XP,FVECP,MODE,ERR) - INTEGER M,N,LDFJAC,MODE - DOUBLE PRECISION X(N),FVEC(M),FJAC(LDFJAC,N),XP(N),FVECP(M), - * ERR(M) -0 - 3. Parameters. -0 Parameters designated as input parameters must be specified on - entry to CHKDER and are not changed on exit, while parameters - designated as output parameters need not be specified on entry - and are set to appropriate values on exit from CHKDER. -0 M is a positive integer input variable set to the number of - functions. -0 N is a positive integer input variable set to the number of - variables. -0 X is an input array of length N. -0 FVEC is an array of length M. On input when MODE = 2, FVEC mus - contain the functions evaluated at X. -0 FJAC is an M by N array. On input when MODE = 2, the rows of - FJAC must contain the gradients of the respective functions - evaluated at X. -0 LDFJAC is a positive integer input variable not less than M - which specifies the leading dimension of the array FJAC. -0 XP is an array of length N. On output when MODE = 1, XP is set - to a neighboring point of X. -1 -0 Page -0 FVECP is an array of length M. On input when MODE = 2, FVECP - must contain the functions evaluated at XP. -0 MODE is an integer input variable set to 1 on the first call an - 2 on the second. Other values of MODE are equivalent to - MODE = 1. -0 ERR is an array of length M. On output when MODE = 2, ERR con- - tains measures of correctness of the respective gradients. I - there is no severe loss of significance, then if ERR(I) is 1. - the I-th gradient is correct, while if ERR(I) is 0.0 the I-th - gradient is incorrect. For values of ERR between 0.0 and 1.0 - the categorization is less certain. In general, a value of - ERR(I) greater than 0.5 indicates that the I-th gradient is - probably correct, while a value of ERR(I) less than 0.5 indi- - cates that the I-th gradient is probably incorrect. -0 - 4. Successful completion. -0 CHKDER usually guarantees that if ERR(I) is 1.0, then the I-th - gradient at X is consistent with the I-th function. This sug- - gests that the input X be such that consistency of the gradient - at X implies consistency of the gradient at all points of inter - est. If all the components of X are distinct and the fractiona - part of each one has two nonzero digits, then X is likely to be - a satisfactory choice. -0 If ERR(I) is not 1.0 but is greater than 0.5, then the I-th gra - dient is probably consistent with the I-th function (the more s - the larger ERR(I) is), but the conditions for ERR(I) to be 1.0 - have not been completely satisfied. In this case, it is recom- - mended that CHKDER be rerun with other input values of X. If - ERR(I) is always greater than 0.5, then the I-th gradient is - consistent with the I-th function. -0 - 5. Unsuccessful completion. -0 CHKDER does not perform reliably if cancellation or rounding - errors cause a severe loss of significance in the evaluation of - a function. Therefore, none of the components of X should be - unusually small (in particular, zero) or any other value which - may cause loss of significance. The relative differences - between corresponding elements of FVECP and FVEC should be at - least two orders of magnitude greater than the machine precisio - (as defined by the MINPACK function DPMPAR(1)). If there is a - severe loss of significance in the evaluation of the I-th func- - tion, then ERR(I) may be 0.0 and yet the I-th gradient could be - correct. -0 If ERR(I) is not 0.0 but is less than 0.5, then the I-th gra- - dient is probably not consistent with the I-th function (the - more so the smaller ERR(I) is), but the conditions for ERR(I) t -1 -0 Page -0 be 0.0 have not been completely satisfied. In this case, it is - recommended that CHKDER be rerun with other input values of X. - If ERR(I) is always less than 0.5 and if there is no severe los - of significance, then the I-th gradient is not consistent with - the I-th function. -0 - 6. Characteristics of the algorithm. -0 CHKDER checks the I-th gradient for consistency with the I-th - function by computing a forward-difference approximation along - suitably chosen direction and comparing this approximation with - the user-supplied gradient along the same direction. The prin- - cipal characteristic of CHKDER is its invariance to changes in - scale of the variables or functions. -0 Timing. The time required by CHKDER depends only on M and N. - The number of arithmetic operations needed by CHKDER is about - N when MODE = 1 and M*N when MODE = 2. -0 Storage. CHKDER requires M*N + 3*M + 2*N double precision stor - age locations, in addition to the storage required by the pro - gram. There are no internally declared storage arrays. -0 - 7. Subprograms required. -0 MINPACK-supplied ... DPMPAR -0 FORTRAN-supplied ... DABS,DLOG10,DSQRT -0 - 8. References. -0 None. -0 - 9. Example. -0 This example checks the Jacobian matrix for the problem that - determines the values of x(1), x(2), and x(3) which provide the - best fit (in the least squares sense) of -0 x(1) + u(i)/(v(i)*x(2) + w(i)*x(3)), i = 1, 15 -0 to the data -0 y = (0.14,0.18,0.22,0.25,0.29,0.32,0.35,0.39, - 0.37,0.58,0.73,0.96,1.34,2.10,4.39), -0 where u(i) = i, v(i) = 16 - i, and w(i) = min(u(i),v(i)). The - i-th component of FVEC is thus defined by -0 y(i) - (x(1) + u(i)/(v(i)*x(2) + w(i)*x(3))). -1 -0 Page -0 C ********** - C - C DRIVER FOR CHKDER EXAMPLE. - C DOUBLE PRECISION VERSION - C - C ********** - INTEGER I,M,N,LDFJAC,MODE,NWRITE - DOUBLE PRECISION X(3),FVEC(15),FJAC(15,3),XP(3),FVECP(15), - * ERR(15) - C - C LOGICAL OUTPUT UNIT IS ASSUMED TO BE NUMBER 6. - C - DATA NWRITE /6/ - C - M = 15 - N = 3 - C - C THE FOLLOWING VALUES SHOULD BE SUITABLE FOR - C CHECKING THE JACOBIAN MATRIX. - C - X(1) = 9.2D-1 - X(2) = 1.3D-1 - X(3) = 5.4D-1 - C - LDFJAC = 15 - C - MODE = 1 - CALL CHKDER(M,N,X,FVEC,FJAC,LDFJAC,XP,FVECP,MODE,ERR) - MODE = 2 - CALL FCN(M,N,X,FVEC,FJAC,LDFJAC,1) - CALL FCN(M,N,X,FVEC,FJAC,LDFJAC,2) - CALL FCN(M,N,XP,FVECP,FJAC,LDFJAC,1) - CALL CHKDER(M,N,X,FVEC,FJAC,LDFJAC,XP,FVECP,MODE,ERR) - C - DO 10 I = 1, M - FVECP(I) = FVECP(I) - FVEC(I) - 10 CONTINUE - WRITE (NWRITE,1000) (FVEC(I),I=1,M) - WRITE (NWRITE,2000) (FVECP(I),I=1,M) - WRITE (NWRITE,3000) (ERR(I),I=1,M) - STOP - 1000 FORMAT (/5X,5H FVEC // (5X,3D15.7)) - 2000 FORMAT (/5X,13H FVECP - FVEC // (5X,3D15.7)) - 3000 FORMAT (/5X,4H ERR // (5X,3D15.7)) - C - C LAST CARD OF DRIVER FOR CHKDER EXAMPLE. - C - END - SUBROUTINE FCN(M,N,X,FVEC,FJAC,LDFJAC,IFLAG) - INTEGER M,N,LDFJAC,IFLAG - DOUBLE PRECISION X(N),FVEC(M),FJAC(LDFJAC,N) - C - C SUBROUTINE FCN FOR CHKDER EXAMPLE. - C -1 -0 Page -0 INTEGER I - DOUBLE PRECISION TMP1,TMP2,TMP3,TMP4 - DOUBLE PRECISION Y(15) - DATA Y(1),Y(2),Y(3),Y(4),Y(5),Y(6),Y(7),Y(8), - * Y(9),Y(10),Y(11),Y(12),Y(13),Y(14),Y(15) - * /1.4D-1,1.8D-1,2.2D-1,2.5D-1,2.9D-1,3.2D-1,3.5D-1,3.9D-1, - * 3.7D-1,5.8D-1,7.3D-1,9.6D-1,1.34D0,2.1D0,4.39D0/ - C - IF (IFLAG .EQ. 2) GO TO 20 - DO 10 I = 1, 15 - TMP1 = I - TMP2 = 16 - I - TMP3 = TMP1 - IF (I .GT. 8) TMP3 = TMP2 - FVEC(I) = Y(I) - (X(1) + TMP1/(X(2)*TMP2 + X(3)*TMP3)) - 10 CONTINUE - GO TO 40 - 20 CONTINUE - DO 30 I = 1, 15 - TMP1 = I - TMP2 = 16 - I - C - C ERROR INTRODUCED INTO NEXT STATEMENT FOR ILLUSTRATION. - C CORRECTED STATEMENT SHOULD READ TMP3 = TMP1 . - C - TMP3 = TMP2 - IF (I .GT. 8) TMP3 = TMP2 - TMP4 = (X(2)*TMP2 + X(3)*TMP3)**2 - FJAC(I,1) = -1.D0 - FJAC(I,2) = TMP1*TMP2/TMP4 - FJAC(I,3) = TMP1*TMP3/TMP4 - 30 CONTINUE - 40 CONTINUE - RETURN - C - C LAST CARD OF SUBROUTINE FCN. - C - END -0 Results obtained with different compilers or machines - may be different. In particular, the differences - FVECP - FVEC are machine dependent. -0 FVEC -0 -0.1181606D+01 -0.1429655D+01 -0.1606344D+01 - -0.1745269D+01 -0.1840654D+01 -0.1921586D+01 - -0.1984141D+01 -0.2022537D+01 -0.2468977D+01 - -0.2827562D+01 -0.3473582D+01 -0.4437612D+01 - -0.6047662D+01 -0.9267761D+01 -0.1891806D+02 -0 FVECP - FVEC -0 -0.7724666D-08 -0.3432405D-08 -0.2034843D-09 -1 -0 Page -0 0.2313685D-08 0.4331078D-08 0.5984096D-08 - 0.7363281D-08 0.8531470D-08 0.1488591D-07 - 0.2335850D-07 0.3522012D-07 0.5301255D-07 - 0.8266660D-07 0.1419747D-06 0.3198990D-06 -0 ERR -0 0.1141397D+00 0.9943516D-01 0.9674474D-01 - 0.9980447D-01 0.1073116D+00 0.1220445D+00 - 0.1526814D+00 0.1000000D+01 0.1000000D+01 - 0.1000000D+01 0.1000000D+01 0.1000000D+01 - 0.1000000D+01 0.1000000D+01 0.1000000D+01 diff --git a/ex/file07 b/ex/file07 deleted file mode 100644 index c9403b1..0000000 --- a/ex/file07 +++ /dev/null @@ -1,283 +0,0 @@ -C ********** -C -C THIS PROGRAM CHECKS THE CONSTANTS OF MACHINE PRECISION AND -C SMALLEST AND LARGEST MACHINE REPRESENTABLE NUMBERS SPECIFIED IN -C FUNCTION SPMPAR, AGAINST THE CORRESPONDING HARDWARE-DETERMINED -C MACHINE CONSTANTS OBTAINED BY SMCHAR, A SUBROUTINE DUE TO -C W. J. CODY. -C -C DATA STATEMENTS IN SPMPAR CORRESPONDING TO THE MACHINE USED MUST -C BE ACTIVATED BY REMOVING C IN COLUMN 1. -C -C THE PRINTED OUTPUT CONSISTS OF THE MACHINE CONSTANTS OBTAINED BY -C SMCHAR AND COMPARISONS OF THE SPMPAR CONSTANTS WITH THEIR -C SMCHAR COUNTERPARTS. DESCRIPTIONS OF THE MACHINE CONSTANTS ARE -C GIVEN IN THE PROLOGUE COMMENTS OF SMCHAR. -C -C SUBPROGRAMS CALLED -C -C MINPACK-SUPPLIED ... SMCHAR,SPMPAR -C -C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. -C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE -C -C ********** - INTEGER IBETA,IEXP,IRND,IT,MACHEP,MAXEXP,MINEXP,NEGEP,NGRD, - * NWRITE - REAL DWARF,EPS,EPSMCH,EPSNEG,GIANT,XMAX,XMIN - REAL RERR(3) - REAL SPMPAR -C -C LOGICAL OUTPUT UNIT IS ASSUMED TO BE NUMBER 6. -C - DATA NWRITE /6/ -C -C DETERMINE THE MACHINE CONSTANTS DYNAMICALLY FROM SMCHAR. -C - CALL SMCHAR(IBETA,IT,IRND,NGRD,MACHEP,NEGEP,IEXP,MINEXP,MAXEXP, - * EPS,EPSNEG,XMIN,XMAX) -C -C COMPARE THE SPMPAR CONSTANTS WITH THEIR SMCHAR COUNTERPARTS AND -C STORE THE RELATIVE DIFFERENCES IN RERR. -C - EPSMCH = SPMPAR(1) - DWARF = SPMPAR(2) - GIANT = SPMPAR(3) - RERR(1) = (EPSMCH - EPS)/EPSMCH - RERR(2) = (DWARF - XMIN)/DWARF - RERR(3) = (XMAX - GIANT)/GIANT -C -C WRITE THE SMCHAR CONSTANTS. -C - WRITE (NWRITE,10) - * IBETA,IT,IRND,NGRD,MACHEP,NEGEP,IEXP,MINEXP,MAXEXP,EPS, - * EPSNEG,XMIN,XMAX -C -C WRITE THE SPMPAR CONSTANTS AND THE RELATIVE DIFFERENCES. -C - WRITE (NWRITE,20) EPSMCH,RERR(1),DWARF,RERR(2),GIANT,RERR(3) - STOP - 10 FORMAT (17H1SMCHAR CONSTANTS /// 8H IBETA =, I6 // 8H IT =, - * I6 // 8H IRND =, I6 // 8H NGRD =, I6 // 9H MACHEP =, - * I6 // 8H NEGEP =, I6 // 7H IEXP =, I6 // 9H MINEXP =, - * I6 // 9H MAXEXP =, I6 // 6H EPS =, E15.7 // 9H EPSNEG =, - * E15.7 // 7H XMIN =, E15.7 // 7H XMAX =, E15.7) - 20 FORMAT ( /// 42H SPMPAR CONSTANTS AND RELATIVE DIFFERENCES /// - * 9H EPSMCH =, E15.7 / 10H RERR(1) =, E15.7 // - * 8H DWARF =, E15.7 / 10H RERR(2) =, E15.7 // 8H GIANT =, - * E15.7 / 10H RERR(3) =, E15.7) -C -C LAST CARD OF DRIVER. -C - END - SUBROUTINE SMCHAR(IBETA,IT,IRND,NGRD,MACHEP,NEGEP,IEXP,MINEXP, - 1 MAXEXP,EPS,EPSNEG,XMIN,XMAX) -C - INTEGER I,IBETA,IEXP,IRND,IT,IZ,J,K,MACHEP,MAXEXP,MINEXP, - 1 MX,NEGEP,NGRD - REAL A,B,BETA,BETAIN,BETAM1,EPS,EPSNEG,ONE,XMAX,XMIN,Y,Z,ZERO -C -C THIS SUBROUTINE IS INTENDED TO DETERMINE THE CHARACTERISTICS -C OF THE FLOATING-POINT ARITHMETIC SYSTEM THAT ARE SPECIFIED -C BELOW. THE FIRST THREE ARE DETERMINED ACCORDING TO AN -C ALGORITHM DUE TO M. MALCOLM, CACM 15 (1972), PP. 949-951, -C INCORPORATING SOME, BUT NOT ALL, OF THE IMPROVEMENTS -C SUGGESTED BY M. GENTLEMAN AND S. MAROVICH, CACM 17 (1974), -C PP. 276-277. -C -C -C IBETA - THE RADIX OF THE FLOATING-POINT REPRESENTATION -C IT - THE NUMBER OF BASE IBETA DIGITS IN THE FLOATING-POINT -C SIGNIFICAND -C IRND - 0 IF FLOATING-POINT ADDITION CHOPS, -C 1 IF FLOATING-POINT ADDITION ROUNDS -C NGRD - THE NUMBER OF GUARD DIGITS FOR MULTIPLICATION. IT IS -C 0 IF IRND=1, OR IF IRND=0 AND ONLY IT BASE IBET -C DIGITS PARTICIPATE IN THE POST NORMALIZATION SHIFT -C OF THE FLOATING-POINT SIGNIFICAND IN MULTIPLICATION -C 1 IF IRND=0 AND MORE THAN IT BASE IBETA DIGITS -C PARTICIPATE IN THE POST NORMALIZATION SHIFT OF THE -C FLOATING-POINT SIGNIFICAND IN MULTIPLICATION -C MACHEP - THE LARGEST NEGATIVE INTEGER SUCH THAT -C 1.0+FLOAT(IBETA)**MACHEP .NE. 1.0, EXCEPT THAT -C MACHEP IS BOUNDED BELOW BY -(IT+3) -C NEGEPS - THE LARGEST NEGATIVE INTEGER SUCH THAT -C 1.0-FLOAT(IBETA)**NEGEPS .NE. 1.0, EXCEPT THAT -C NEGEPS IS BOUNDED BELOW BY -(IT+3) -C IEXP - THE NUMBER OF BITS (DECIMAL PLACES IF IBETA = 10) -C RESERVED FOR THE REPRESENTATION OF THE EXPONENT -C (INCLUDING THE BIAS OR SIGN) OF A FLOATING-POINT -C NUMBER -C MINEXP - THE LARGEST IN MAGNITUDE NEGATIVE INTEGER SUCH THAT -C FLOAT(IBETA)**MINEXP IS A POSITIVE FLOATING-POINT -C NUMBER -C MAXEXP - THE LARGEST POSITIVE INTEGER EXPONENT FOR A FINITE -C FLOATING-POINT NUMBER -C EPS - THE SMALLEST POSITIVE FLOATING-POINT NUMBER SUCH -C THAT 1.0+EPS .NE. 1.0. IN PARTICULAR, IF EITHER -C IBETA = 2 OR IRND = 0, EPS = FLOAT(IBETA)**MACHEP. -C OTHERWISE, EPS = (FLOAT(IBETA)**MACHEP)/2 -C EPSNEG - A SMALL POSITIVE FLOATING-POINT NUMBER SUCH THAT -C 1.0-EPSNEG .NE. 1.0. IN PARTICULAR, IF IBETA = 2 -C OR IRND = 0, EPSNEG = FLOAT(IBETA)**NEGEPS. -C OTHERWISE, EPSNEG = (IBETA**NEGEPS)/2. BECAUSE -C NEGEPS IS BOUNDED BELOW BY -(IT+3), EPSNEG MAY NOT -C BE THE SMALLEST NUMBER WHICH CAN ALTER 1.0 BY -C SUBTRACTION. -C XMIN - THE SMALLEST NON-VANISHING FLOATING-POINT POWER OF TH -C RADIX. IN PARTICULAR, XMIN = FLOAT(IBETA)**MINEXP -C XMAX - THE LARGEST FINITE FLOATING-POINT NUMBER. IN -C PARTICULAR XMAX = (1.0-EPSNEG)*FLOAT(IBETA)**MAXEXP -C NOTE - ON SOME MACHINES XMAX WILL BE ONLY THE -C SECOND, OR PERHAPS THIRD, LARGEST NUMBER, BEING -C TOO SMALL BY 1 OR 2 UNITS IN THE LAST DIGIT OF -C THE SIGNIFICAND. -C -C LATEST REVISION - OCTOBER 22, 1979 -C -C AUTHOR - W. J. CODY -C ARGONNE NATIONAL LABORATORY -C -C----------------------------------------------------------------- - ONE = FLOAT(1) - ZERO = 0.0E0 -C----------------------------------------------------------------- -C DETERMINE IBETA,BETA ALA MALCOLM -C----------------------------------------------------------------- - A = ONE - 10 A = A + A - IF (((A+ONE)-A)-ONE .EQ. ZERO) GO TO 10 - B = ONE - 20 B = B + B - IF ((A+B)-A .EQ. ZERO) GO TO 20 - IBETA = INT((A+B)-A) - BETA = FLOAT(IBETA) -C----------------------------------------------------------------- -C DETERMINE IT, IRND -C----------------------------------------------------------------- - IT = 0 - B = ONE - 100 IT = IT + 1 - B = B * BETA - IF (((B+ONE)-B)-ONE .EQ. ZERO) GO TO 100 - IRND = 0 - BETAM1 = BETA - ONE - IF ((A+BETAM1)-A .NE. ZERO) IRND = 1 -C----------------------------------------------------------------- -C DETERMINE NEGEP, EPSNEG -C----------------------------------------------------------------- - NEGEP = IT + 3 - BETAIN = ONE / BETA - A = ONE -C - DO 200 I = 1, NEGEP - A = A * BETAIN - 200 CONTINUE -C - B = A - 210 IF ((ONE-A)-ONE .NE. ZERO) GO TO 220 - A = A * BETA - NEGEP = NEGEP - 1 - GO TO 210 - 220 NEGEP = -NEGEP - EPSNEG = A - IF ((IBETA .EQ. 2) .OR. (IRND .EQ. 0)) GO TO 300 - A = (A*(ONE+A)) / (ONE+ONE) - IF ((ONE-A)-ONE .NE. ZERO) EPSNEG = A -C----------------------------------------------------------------- -C DETERMINE MACHEP, EPS -C----------------------------------------------------------------- - 300 MACHEP = -IT - 3 - A = B - 310 IF((ONE+A)-ONE .NE. ZERO) GO TO 320 - A = A * BETA - MACHEP = MACHEP + 1 - GO TO 310 - 320 EPS = A - IF ((IBETA .EQ. 2) .OR. (IRND .EQ. 0)) GO TO 350 - A = (A*(ONE+A)) / (ONE+ONE) - IF ((ONE+A)-ONE .NE. ZERO) EPS = A -C----------------------------------------------------------------- -C DETERMINE NGRD -C----------------------------------------------------------------- - 350 NGRD = 0 - IF ((IRND .EQ. 0) .AND. ((ONE+EPS)*ONE-ONE) .NE. ZERO) NGRD = 1 -C----------------------------------------------------------------- -C DETERMINE IEXP, MINEXP, XMIN -C -C LOOP TO DETERMINE LARGEST I AND K = 2**I SUCH THAT -C (1/BETA) ** (2**(I)) -C DOES NOT UNDERFLOW -C EXIT FROM LOOP IS SIGNALED BY AN UNDERFLOW. -C----------------------------------------------------------------- - I = 0 - K = 1 - Z = BETAIN - 400 Y = Z - Z = Y * Y -C----------------------------------------------------------------- -C CHECK FOR UNDERFLOW HERE -C----------------------------------------------------------------- - A = Z * ONE - IF ((A+A .EQ. ZERO) .OR. (ABS(Z) .GE. Y)) GO TO 410 - I = I + 1 - K = K + K - GO TO 400 - 410 IF (IBETA .EQ. 10) GO TO 420 - IEXP = I + 1 - MX = K + K - GO TO 450 -C----------------------------------------------------------------- -C FOR DECIMAL MACHINES ONLY -C----------------------------------------------------------------- - 420 IEXP = 2 - IZ = IBETA - 430 IF (K .LT. IZ) GO TO 440 - IZ = IZ * IBETA - IEXP = IEXP + 1 - GO TO 430 - 440 MX = IZ + IZ - 1 -C----------------------------------------------------------------- -C LOOP TO DETERMINE MINEXP, XMIN -C EXIT FROM LOOP IS SIGNALED BY AN UNDERFLOW. -C----------------------------------------------------------------- - 450 XMIN = Y - Y = Y * BETAIN -C----------------------------------------------------------------- -C CHECK FOR UNDERFLOW HERE -C----------------------------------------------------------------- - A = Y * ONE - IF (((A+A) .EQ. ZERO) .OR. (ABS(Y) .GE. XMIN)) GO TO 460 - K = K + 1 - GO TO 450 - 460 MINEXP = -K -C----------------------------------------------------------------- -C DETERMINE MAXEXP, XMAX -C----------------------------------------------------------------- - IF ((MX .GT. K+K-3) .OR. (IBETA .EQ. 10)) GO TO 500 - MX = MX + MX - IEXP = IEXP + 1 - 500 MAXEXP = MX + MINEXP -C----------------------------------------------------------------- -C ADJUST FOR MACHINES WITH IMPLICIT LEADING -C BIT IN BINARY SIGNIFICAND AND MACHINES WITH -C RADIX POINT AT EXTREME RIGHT OF SIGNIFICAND -C----------------------------------------------------------------- - I = MAXEXP + MINEXP - IF ((IBETA .EQ. 2) .AND. (I .EQ. 0)) MAXEXP = MAXEXP - 1 - IF (I .GT. 20) MAXEXP = MAXEXP - 1 - IF (A .NE. Y) MAXEXP = MAXEXP - 2 - XMAX = ONE - EPSNEG - IF (XMAX*ONE .NE. XMAX) XMAX = ONE - BETA * EPSNEG - XMAX = XMAX / (BETA * BETA * BETA * XMIN) - I = MAXEXP + MINEXP + 3 - IF (I .LE. 0) GO TO 520 -C - DO 510 J = 1, I - IF (IBETA .EQ. 2) XMAX = XMAX + XMAX - IF (IBETA .NE. 2) XMAX = XMAX * BETA - 510 CONTINUE -C - 520 RETURN -C ---------- LAST CARD OF SMCHAR ---------- - END diff --git a/ex/file08 b/ex/file08 deleted file mode 100644 index 47fdb71..0000000 --- a/ex/file08 +++ /dev/null @@ -1,551 +0,0 @@ -C ********** -C -C THIS PROGRAM TESTS CODES FOR THE SOLUTION OF N NONLINEAR -C EQUATIONS IN N VARIABLES. IT CONSISTS OF A DRIVER AND AN -C INTERFACE SUBROUTINE FCN. THE DRIVER READS IN DATA, CALLS THE -C NONLINEAR EQUATION SOLVER, AND FINALLY PRINTS OUT INFORMATION -C ON THE PERFORMANCE OF THE SOLVER. THIS IS ONLY A SAMPLE DRIVER, -C MANY OTHER DRIVERS ARE POSSIBLE. THE INTERFACE SUBROUTINE FCN -C IS NECESSARY TO TAKE INTO ACCOUNT THE FORMS OF CALLING -C SEQUENCES USED BY THE FUNCTION SUBROUTINES IN THE VARIOUS -C NONLINEAR EQUATION SOLVERS. -C -C SUBPROGRAMS CALLED -C -C USER-SUPPLIED ...... FCN -C -C MINPACK-SUPPLIED ... SPMPAR,ENORM,HYBRD1,INITPT,VECFCN -C -C FORTRAN-SUPPLIED ... SQRT -C -C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. -C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE -C -C ********** - INTEGER I,IC,INFO,K,LWA,N,NFEV,NPROB,NREAD,NTRIES,NWRITE - INTEGER NA(60),NF(60),NP(60),NX(60) - REAL FACTOR,FNORM1,FNORM2,ONE,TEN,TOL - REAL FNM(60),FVEC(40),WA(2660),X(40) - REAL SPMPAR,ENORM - EXTERNAL FCN - COMMON /REFNUM/ NPROB,NFEV -C -C LOGICAL INPUT UNIT IS ASSUMED TO BE NUMBER 5. -C LOGICAL OUTPUT UNIT IS ASSUMED TO BE NUMBER 6. -C - DATA NREAD,NWRITE /5,6/ -C - DATA ONE,TEN /1.0E0,1.0E1/ - TOL = SQRT(SPMPAR(1)) - LWA = 2660 - IC = 0 - 10 CONTINUE - READ (NREAD,50) NPROB,N,NTRIES - IF (NPROB .LE. 0) GO TO 30 - FACTOR = ONE - DO 20 K = 1, NTRIES - IC = IC + 1 - CALL INITPT(N,X,NPROB,FACTOR) - CALL VECFCN(N,X,FVEC,NPROB) - FNORM1 = ENORM(N,FVEC) - WRITE (NWRITE,60) NPROB,N - NFEV = 0 - CALL HYBRD1(FCN,N,X,FVEC,TOL,INFO,WA,LWA) - FNORM2 = ENORM(N,FVEC) - NP(IC) = NPROB - NA(IC) = N - NF(IC) = NFEV - NX(IC) = INFO - FNM(IC) = FNORM2 - WRITE (NWRITE,70) FNORM1,FNORM2,NFEV,INFO,(X(I), I = 1, N) - FACTOR = TEN*FACTOR - 20 CONTINUE - GO TO 10 - 30 CONTINUE - WRITE (NWRITE,80) IC - WRITE (NWRITE,90) - DO 40 I = 1, IC - WRITE (NWRITE,100) NP(I),NA(I),NF(I),NX(I),FNM(I) - 40 CONTINUE - STOP - 50 FORMAT (3I5) - 60 FORMAT ( //// 5X, 8H PROBLEM, I5, 5X, 10H DIMENSION, I5, 5X //) - 70 FORMAT (5X, 33H INITIAL L2 NORM OF THE RESIDUALS, E15.7 // 5X, - * 33H FINAL L2 NORM OF THE RESIDUALS , E15.7 // 5X, - * 33H NUMBER OF FUNCTION EVALUATIONS , I10 // 5X, - * 15H EXIT PARAMETER, 18X, I10 // 5X, - * 27H FINAL APPROXIMATE SOLUTION // (5X, 5E15.7)) - 80 FORMAT (12H1SUMMARY OF , I3, 16H CALLS TO HYBRD1 /) - 90 FORMAT (39H NPROB N NFEV INFO FINAL L2 NORM /) - 100 FORMAT (I4, I6, I7, I6, 1X, E15.7) -C -C LAST CARD OF DRIVER. -C - END - SUBROUTINE FCN(N,X,FVEC,IFLAG) - INTEGER N,IFLAG - REAL X(N),FVEC(N) -C ********** -C -C THE CALLING SEQUENCE OF FCN SHOULD BE IDENTICAL TO THE -C CALLING SEQUENCE OF THE FUNCTION SUBROUTINE IN THE NONLINEAR -C EQUATION SOLVER. FCN SHOULD ONLY CALL THE TESTING FUNCTION -C SUBROUTINE VECFCN WITH THE APPROPRIATE VALUE OF PROBLEM -C NUMBER (NPROB). -C -C SUBPROGRAMS CALLED -C -C MINPACK-SUPPLIED ... VECFCN -C -C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. -C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE -C -C ********** - INTEGER NPROB,NFEV - COMMON /REFNUM/ NPROB,NFEV - CALL VECFCN(N,X,FVEC,NPROB) - NFEV = NFEV + 1 - RETURN -C -C LAST CARD OF INTERFACE SUBROUTINE FCN. -C - END - SUBROUTINE VECFCN(N,X,FVEC,NPROB) - INTEGER N,NPROB - REAL X(N),FVEC(N) -C ********** -C -C SUBROUTINE VECFCN -C -C THIS SUBROUTINE DEFINES FOURTEEN TEST FUNCTIONS. THE FIRST -C FIVE TEST FUNCTIONS ARE OF DIMENSIONS 2,4,2,4,3, RESPECTIVELY, -C WHILE THE REMAINING TEST FUNCTIONS ARE OF VARIABLE DIMENSION -C N FOR ANY N GREATER THAN OR EQUAL TO 1 (PROBLEM 6 IS AN -C EXCEPTION TO THIS, SINCE IT DOES NOT ALLOW N = 1). -C -C THE SUBROUTINE STATEMENT IS -C -C SUBROUTINE VECFCN(N,X,FVEC,NPROB) -C -C WHERE -C -C N IS A POSITIVE INTEGER INPUT VARIABLE. -C -C X IS AN INPUT ARRAY OF LENGTH N. -C -C FVEC IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE NPROB -C FUNCTION VECTOR EVALUATED AT X. -C -C NPROB IS A POSITIVE INTEGER INPUT VARIABLE WHICH DEFINES THE -C NUMBER OF THE PROBLEM. NPROB MUST NOT EXCEED 14. -C -C SUBPROGRAMS CALLED -C -C FORTRAN-SUPPLIED ... ATAN,COS,EXP,SIGN,SIN,SQRT, -C MAX0,MIN0 -C -C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. -C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE -C -C ********** - INTEGER I,IEV,IVAR,J,K,K1,K2,KP1,ML,MU - REAL C1,C2,C3,C4,C5,C6,C7,C8,C9,EIGHT,FIVE,H,ONE,PROD,SUM,SUM1, - * SUM2,TEMP,TEMP1,TEMP2,TEN,THREE,TI,TJ,TK,TPI,TWO,ZERO - REAL FLOAT - DATA ZERO,ONE,TWO,THREE,FIVE,EIGHT,TEN - * /0.0E0,1.0E0,2.0E0,3.0E0,5.0E0,8.0E0,1.0E1/ - DATA C1,C2,C3,C4,C5,C6,C7,C8,C9 - * /1.0E4,1.0001E0,2.0E2,2.02E1,1.98E1,1.8E2,2.5E-1,5.0E-1, - * 2.9E1/ - FLOAT(IVAR) = IVAR -C -C PROBLEM SELECTOR. -C - GO TO (10,20,30,40,50,60,120,170,200,220,270,300,330,350), NPROB -C -C ROSENBROCK FUNCTION. -C - 10 CONTINUE - FVEC(1) = ONE - X(1) - FVEC(2) = TEN*(X(2) - X(1)**2) - GO TO 380 -C -C POWELL SINGULAR FUNCTION. -C - 20 CONTINUE - FVEC(1) = X(1) + TEN*X(2) - FVEC(2) = SQRT(FIVE)*(X(3) - X(4)) - FVEC(3) = (X(2) - TWO*X(3))**2 - FVEC(4) = SQRT(TEN)*(X(1) - X(4))**2 - GO TO 380 -C -C POWELL BADLY SCALED FUNCTION. -C - 30 CONTINUE - FVEC(1) = C1*X(1)*X(2) - ONE - FVEC(2) = EXP(-X(1)) + EXP(-X(2)) - C2 - GO TO 380 -C -C WOOD FUNCTION. -C - 40 CONTINUE - TEMP1 = X(2) - X(1)**2 - TEMP2 = X(4) - X(3)**2 - FVEC(1) = -C3*X(1)*TEMP1 - (ONE - X(1)) - FVEC(2) = C3*TEMP1 + C4*(X(2) - ONE) + C5*(X(4) - ONE) - FVEC(3) = -C6*X(3)*TEMP2 - (ONE - X(3)) - FVEC(4) = C6*TEMP2 + C4*(X(4) - ONE) + C5*(X(2) - ONE) - GO TO 380 -C -C HELICAL VALLEY FUNCTION. -C - 50 CONTINUE - TPI = EIGHT*ATAN(ONE) - TEMP1 = SIGN(C7,X(2)) - IF (X(1) .GT. ZERO) TEMP1 = ATAN(X(2)/X(1))/TPI - IF (X(1) .LT. ZERO) TEMP1 = ATAN(X(2)/X(1))/TPI + C8 - TEMP2 = SQRT(X(1)**2+X(2)**2) - FVEC(1) = TEN*(X(3) - TEN*TEMP1) - FVEC(2) = TEN*(TEMP2 - ONE) - FVEC(3) = X(3) - GO TO 380 -C -C WATSON FUNCTION. -C - 60 CONTINUE - DO 70 K = 1, N - FVEC(K) = ZERO - 70 CONTINUE - DO 110 I = 1, 29 - TI = FLOAT(I)/C9 - SUM1 = ZERO - TEMP = ONE - DO 80 J = 2, N - SUM1 = SUM1 + FLOAT(J-1)*TEMP*X(J) - TEMP = TI*TEMP - 80 CONTINUE - SUM2 = ZERO - TEMP = ONE - DO 90 J = 1, N - SUM2 = SUM2 + TEMP*X(J) - TEMP = TI*TEMP - 90 CONTINUE - TEMP1 = SUM1 - SUM2**2 - ONE - TEMP2 = TWO*TI*SUM2 - TEMP = ONE/TI - DO 100 K = 1, N - FVEC(K) = FVEC(K) + TEMP*(FLOAT(K-1) - TEMP2)*TEMP1 - TEMP = TI*TEMP - 100 CONTINUE - 110 CONTINUE - TEMP = X(2) - X(1)**2 - ONE - FVEC(1) = FVEC(1) + X(1)*(ONE - TWO*TEMP) - FVEC(2) = FVEC(2) + TEMP - GO TO 380 -C -C CHEBYQUAD FUNCTION. -C - 120 CONTINUE - DO 130 K = 1, N - FVEC(K) = ZERO - 130 CONTINUE - DO 150 J = 1, N - TEMP1 = ONE - TEMP2 = TWO*X(J) - ONE - TEMP = TWO*TEMP2 - DO 140 I = 1, N - FVEC(I) = FVEC(I) + TEMP2 - TI = TEMP*TEMP2 - TEMP1 - TEMP1 = TEMP2 - TEMP2 = TI - 140 CONTINUE - 150 CONTINUE - TK = ONE/FLOAT(N) - IEV = -1 - DO 160 K = 1, N - FVEC(K) = TK*FVEC(K) - IF (IEV .GT. 0) FVEC(K) = FVEC(K) + ONE/(FLOAT(K)**2 - ONE) - IEV = -IEV - 160 CONTINUE - GO TO 380 -C -C BROWN ALMOST-LINEAR FUNCTION. -C - 170 CONTINUE - SUM = -FLOAT(N+1) - PROD = ONE - DO 180 J = 1, N - SUM = SUM + X(J) - PROD = X(J)*PROD - 180 CONTINUE - DO 190 K = 1, N - FVEC(K) = X(K) + SUM - 190 CONTINUE - FVEC(N) = PROD - ONE - GO TO 380 -C -C DISCRETE BOUNDARY VALUE FUNCTION. -C - 200 CONTINUE - H = ONE/FLOAT(N+1) - DO 210 K = 1, N - TEMP = (X(K) + FLOAT(K)*H + ONE)**3 - TEMP1 = ZERO - IF (K .NE. 1) TEMP1 = X(K-1) - TEMP2 = ZERO - IF (K .NE. N) TEMP2 = X(K+1) - FVEC(K) = TWO*X(K) - TEMP1 - TEMP2 + TEMP*H**2/TWO - 210 CONTINUE - GO TO 380 -C -C DISCRETE INTEGRAL EQUATION FUNCTION. -C - 220 CONTINUE - H = ONE/FLOAT(N+1) - DO 260 K = 1, N - TK = FLOAT(K)*H - SUM1 = ZERO - DO 230 J = 1, K - TJ = FLOAT(J)*H - TEMP = (X(J) + TJ + ONE)**3 - SUM1 = SUM1 + TJ*TEMP - 230 CONTINUE - SUM2 = ZERO - KP1 = K + 1 - IF (N .LT. KP1) GO TO 250 - DO 240 J = KP1, N - TJ = FLOAT(J)*H - TEMP = (X(J) + TJ + ONE)**3 - SUM2 = SUM2 + (ONE - TJ)*TEMP - 240 CONTINUE - 250 CONTINUE - FVEC(K) = X(K) + H*((ONE - TK)*SUM1 + TK*SUM2)/TWO - 260 CONTINUE - GO TO 380 -C -C TRIGONOMETRIC FUNCTION. -C - 270 CONTINUE - SUM = ZERO - DO 280 J = 1, N - FVEC(J) = COS(X(J)) - SUM = SUM + FVEC(J) - 280 CONTINUE - DO 290 K = 1, N - FVEC(K) = FLOAT(N+K) - SIN(X(K)) - SUM - FLOAT(K)*FVEC(K) - 290 CONTINUE - GO TO 380 -C -C VARIABLY DIMENSIONED FUNCTION. -C - 300 CONTINUE - SUM = ZERO - DO 310 J = 1, N - SUM = SUM + FLOAT(J)*(X(J) - ONE) - 310 CONTINUE - TEMP = SUM*(ONE + TWO*SUM**2) - DO 320 K = 1, N - FVEC(K) = X(K) - ONE + FLOAT(K)*TEMP - 320 CONTINUE - GO TO 380 -C -C BROYDEN TRIDIAGONAL FUNCTION. -C - 330 CONTINUE - DO 340 K = 1, N - TEMP = (THREE - TWO*X(K))*X(K) - TEMP1 = ZERO - IF (K .NE. 1) TEMP1 = X(K-1) - TEMP2 = ZERO - IF (K .NE. N) TEMP2 = X(K+1) - FVEC(K) = TEMP - TEMP1 - TWO*TEMP2 + ONE - 340 CONTINUE - GO TO 380 -C -C BROYDEN BANDED FUNCTION. -C - 350 CONTINUE - ML = 5 - MU = 1 - DO 370 K = 1, N - K1 = MAX0(1,K-ML) - K2 = MIN0(K+MU,N) - TEMP = ZERO - DO 360 J = K1, K2 - IF (J .NE. K) TEMP = TEMP + X(J)*(ONE + X(J)) - 360 CONTINUE - FVEC(K) = X(K)*(TWO + FIVE*X(K)**2) + ONE - TEMP - 370 CONTINUE - 380 CONTINUE - RETURN -C -C LAST CARD OF SUBROUTINE VECFCN. -C - END - SUBROUTINE INITPT(N,X,NPROB,FACTOR) - INTEGER N,NPROB - REAL FACTOR - REAL X(N) -C ********** -C -C SUBROUTINE INITPT -C -C THIS SUBROUTINE SPECIFIES THE STANDARD STARTING POINTS FOR -C THE FUNCTIONS DEFINED BY SUBROUTINE VECFCN. THE SUBROUTINE -C RETURNS IN X A MULTIPLE (FACTOR) OF THE STANDARD STARTING -C POINT. FOR THE SIXTH FUNCTION THE STANDARD STARTING POINT IS -C ZERO, SO IN THIS CASE, IF FACTOR IS NOT UNITY, THEN THE -C SUBROUTINE RETURNS THE VECTOR X(J) = FACTOR, J=1,...,N. -C -C THE SUBROUTINE STATEMENT IS -C -C SUBROUTINE INITPT(N,X,NPROB,FACTOR) -C -C WHERE -C -C N IS A POSITIVE INTEGER INPUT VARIABLE. -C -C X IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE STANDARD -C STARTING POINT FOR PROBLEM NPROB MULTIPLIED BY FACTOR. -C -C NPROB IS A POSITIVE INTEGER INPUT VARIABLE WHICH DEFINES THE -C NUMBER OF THE PROBLEM. NPROB MUST NOT EXCEED 14. -C -C FACTOR IS AN INPUT VARIABLE WHICH SPECIFIES THE MULTIPLE OF -C THE STANDARD STARTING POINT. IF FACTOR IS UNITY, NO -C MULTIPLICATION IS PERFORMED. -C -C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. -C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE -C -C ********** - INTEGER IVAR,J - REAL C1,H,HALF,ONE,THREE,TJ,ZERO - REAL FLOAT - DATA ZERO,HALF,ONE,THREE,C1 /0.0E0,5.0E-1,1.0E0,3.0E0,1.2E0/ - FLOAT(IVAR) = IVAR -C -C SELECTION OF INITIAL POINT. -C - GO TO (10,20,30,40,50,60,80,100,120,120,140,160,180,180), NPROB -C -C ROSENBROCK FUNCTION. -C - 10 CONTINUE - X(1) = -C1 - X(2) = ONE - GO TO 200 -C -C POWELL SINGULAR FUNCTION. -C - 20 CONTINUE - X(1) = THREE - X(2) = -ONE - X(3) = ZERO - X(4) = ONE - GO TO 200 -C -C POWELL BADLY SCALED FUNCTION. -C - 30 CONTINUE - X(1) = ZERO - X(2) = ONE - GO TO 200 -C -C WOOD FUNCTION. -C - 40 CONTINUE - X(1) = -THREE - X(2) = -ONE - X(3) = -THREE - X(4) = -ONE - GO TO 200 -C -C HELICAL VALLEY FUNCTION. -C - 50 CONTINUE - X(1) = -ONE - X(2) = ZERO - X(3) = ZERO - GO TO 200 -C -C WATSON FUNCTION. -C - 60 CONTINUE - DO 70 J = 1, N - X(J) = ZERO - 70 CONTINUE - GO TO 200 -C -C CHEBYQUAD FUNCTION. -C - 80 CONTINUE - H = ONE/FLOAT(N+1) - DO 90 J = 1, N - X(J) = FLOAT(J)*H - 90 CONTINUE - GO TO 200 -C -C BROWN ALMOST-LINEAR FUNCTION. -C - 100 CONTINUE - DO 110 J = 1, N - X(J) = HALF - 110 CONTINUE - GO TO 200 -C -C DISCRETE BOUNDARY VALUE AND INTEGRAL EQUATION FUNCTIONS. -C - 120 CONTINUE - H = ONE/FLOAT(N+1) - DO 130 J = 1, N - TJ = FLOAT(J)*H - X(J) = TJ*(TJ - ONE) - 130 CONTINUE - GO TO 200 -C -C TRIGONOMETRIC FUNCTION. -C - 140 CONTINUE - H = ONE/FLOAT(N) - DO 150 J = 1, N - X(J) = H - 150 CONTINUE - GO TO 200 -C -C VARIABLY DIMENSIONED FUNCTION. -C - 160 CONTINUE - H = ONE/FLOAT(N) - DO 170 J = 1, N - X(J) = ONE - FLOAT(J)*H - 170 CONTINUE - GO TO 200 -C -C BROYDEN TRIDIAGONAL AND BANDED FUNCTIONS. -C - 180 CONTINUE - DO 190 J = 1, N - X(J) = -ONE - 190 CONTINUE - 200 CONTINUE -C -C COMPUTE MULTIPLE OF INITIAL POINT. -C - IF (FACTOR .EQ. ONE) GO TO 250 - IF (NPROB .EQ. 6) GO TO 220 - DO 210 J = 1, N - X(J) = FACTOR*X(J) - 210 CONTINUE - GO TO 240 - 220 CONTINUE - DO 230 J = 1, N - X(J) = FACTOR - 230 CONTINUE - 240 CONTINUE - 250 CONTINUE - RETURN -C -C LAST CARD OF SUBROUTINE INITPT. -C - END diff --git a/ex/file09 b/ex/file09 deleted file mode 100644 index 672ec01..0000000 --- a/ex/file09 +++ /dev/null @@ -1,879 +0,0 @@ -C ********** -C -C THIS PROGRAM TESTS CODES FOR THE SOLUTION OF N NONLINEAR -C EQUATIONS IN N VARIABLES. IT CONSISTS OF A DRIVER AND AN -C INTERFACE SUBROUTINE FCN. THE DRIVER READS IN DATA, CALLS THE -C NONLINEAR EQUATION SOLVER, AND FINALLY PRINTS OUT INFORMATION -C ON THE PERFORMANCE OF THE SOLVER. THIS IS ONLY A SAMPLE DRIVER, -C MANY OTHER DRIVERS ARE POSSIBLE. THE INTERFACE SUBROUTINE FCN -C IS NECESSARY TO TAKE INTO ACCOUNT THE FORMS OF CALLING -C SEQUENCES USED BY THE FUNCTION AND JACOBIAN SUBROUTINES IN -C THE VARIOUS NONLINEAR EQUATION SOLVERS. -C -C SUBPROGRAMS CALLED -C -C USER-SUPPLIED ...... FCN -C -C MINPACK-SUPPLIED ... SPMPAR,ENORM,HYBRJ1,INITPT,VECFCN -C -C FORTRAN-SUPPLIED ... SQRT -C -C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. -C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE -C -C ********** - INTEGER I,IC,INFO,K,LDFJAC,LWA,N,NFEV,NJEV,NPROB,NREAD,NTRIES, - * NWRITE - INTEGER NA(60),NF(60),NJ(60),NP(60),NX(60) - REAL FACTOR,FNORM1,FNORM2,ONE,TEN,TOL - REAL FNM(60),FJAC(40,40),FVEC(40),WA(1060),X(40) - REAL SPMPAR,ENORM - EXTERNAL FCN - COMMON /REFNUM/ NPROB,NFEV,NJEV -C -C LOGICAL INPUT UNIT IS ASSUMED TO BE NUMBER 5. -C LOGICAL OUTPUT UNIT IS ASSUMED TO BE NUMBER 6. -C - DATA NREAD,NWRITE /5,6/ -C - DATA ONE,TEN /1.0E0,1.0E1/ - TOL = SQRT(SPMPAR(1)) - LDFJAC = 40 - LWA = 1060 - IC = 0 - 10 CONTINUE - READ (NREAD,50) NPROB,N,NTRIES - IF (NPROB .LE. 0) GO TO 30 - FACTOR = ONE - DO 20 K = 1, NTRIES - IC = IC + 1 - CALL INITPT(N,X,NPROB,FACTOR) - CALL VECFCN(N,X,FVEC,NPROB) - FNORM1 = ENORM(N,FVEC) - WRITE (NWRITE,60) NPROB,N - NFEV = 0 - NJEV = 0 - CALL HYBRJ1(FCN,N,X,FVEC,FJAC,LDFJAC,TOL,INFO,WA,LWA) - FNORM2 = ENORM(N,FVEC) - NP(IC) = NPROB - NA(IC) = N - NF(IC) = NFEV - NJ(IC) = NJEV - NX(IC) = INFO - FNM(IC) = FNORM2 - WRITE (NWRITE,70) - * FNORM1,FNORM2,NFEV,NJEV,INFO,(X(I), I = 1, N) - FACTOR = TEN*FACTOR - 20 CONTINUE - GO TO 10 - 30 CONTINUE - WRITE (NWRITE,80) IC - WRITE (NWRITE,90) - DO 40 I = 1, IC - WRITE (NWRITE,100) NP(I),NA(I),NF(I),NJ(I),NX(I),FNM(I) - 40 CONTINUE - STOP - 50 FORMAT (3I5) - 60 FORMAT ( //// 5X, 8H PROBLEM, I5, 5X, 10H DIMENSION, I5, 5X //) - 70 FORMAT (5X, 33H INITIAL L2 NORM OF THE RESIDUALS, E15.7 // 5X, - * 33H FINAL L2 NORM OF THE RESIDUALS , E15.7 // 5X, - * 33H NUMBER OF FUNCTION EVALUATIONS , I10 // 5X, - * 33H NUMBER OF JACOBIAN EVALUATIONS , I10 // 5X, - * 15H EXIT PARAMETER, 18X, I10 // 5X, - * 27H FINAL APPROXIMATE SOLUTION // (5X, 5E15.7)) - 80 FORMAT (12H1SUMMARY OF , I3, 16H CALLS TO HYBRJ1 /) - 90 FORMAT (46H NPROB N NFEV NJEV INFO FINAL L2 NORM /) - 100 FORMAT (I4, I6, 2I7, I6, 1X, E15.7) -C -C LAST CARD OF DRIVER. -C - END - SUBROUTINE FCN(N,X,FVEC,FJAC,LDFJAC,IFLAG) - INTEGER N,LDFJAC,IFLAG - REAL X(N),FVEC(N),FJAC(LDFJAC,N) -C ********** -C -C THE CALLING SEQUENCE OF FCN SHOULD BE IDENTICAL TO THE -C CALLING SEQUENCE OF THE FUNCTION SUBROUTINE IN THE NONLINEAR -C EQUATION SOLVER. FCN SHOULD ONLY CALL THE TESTING FUNCTION -C AND JACOBIAN SUBROUTINES VECFCN AND VECJAC WITH THE -C APPROPRIATE VALUE OF PROBLEM NUMBER (NPROB). -C -C SUBPROGRAMS CALLED -C -C MINPACK-SUPPLIED ... VECFCN,VECJAC -C -C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. -C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE -C -C ********** - INTEGER NPROB,NFEV,NJEV - COMMON /REFNUM/ NPROB,NFEV,NJEV - IF (IFLAG .EQ. 1) CALL VECFCN(N,X,FVEC,NPROB) - IF (IFLAG .EQ. 2) CALL VECJAC(N,X,FJAC,LDFJAC,NPROB) - IF (IFLAG .EQ. 1) NFEV = NFEV + 1 - IF (IFLAG .EQ. 2) NJEV = NJEV + 1 - RETURN -C -C LAST CARD OF INTERFACE SUBROUTINE FCN. -C - END - SUBROUTINE VECJAC(N,X,FJAC,LDFJAC,NPROB) - INTEGER N,LDFJAC,NPROB - REAL X(N),FJAC(LDFJAC,N) -C ********** -C -C SUBROUTINE VECJAC -C -C THIS SUBROUTINE DEFINES THE JACOBIAN MATRICES OF FOURTEEN -C TEST FUNCTIONS. THE PROBLEM DIMENSIONS ARE AS DESCRIBED -C IN THE PROLOGUE COMMENTS OF VECFCN. -C -C THE SUBROUTINE STATEMENT IS -C -C SUBROUTINE VECJAC(N,X,FJAC,LDFJAC,NPROB) -C -C WHERE -C -C N IS A POSITIVE INTEGER VARIABLE. -C -C X IS AN ARRAY OF LENGTH N. -C -C FJAC IS AN N BY N ARRAY. ON OUTPUT FJAC CONTAINS THE -C JACOBIAN MATRIX OF THE NPROB FUNCTION EVALUATED AT X. -C -C LDFJAC IS A POSITIVE INTEGER VARIABLE NOT LESS THAN N -C WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY FJAC. -C -C NPROB IS A POSITIVE INTEGER VARIABLE WHICH DEFINES THE -C NUMBER OF THE PROBLEM. NPROB MUST NOT EXCEED 14. -C -C SUBPROGRAMS CALLED -C -C FORTRAN-SUPPLIED ... ATAN,COS,EXP,AMIN1,SIN,SQRT, -C MAX0,MIN0 -C -C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. -C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE -C -C ********** - INTEGER I,IVAR,J,K,K1,K2,ML,MU - REAL C1,C3,C4,C5,C6,C9,EIGHT,FIFTN,FIVE,FOUR,H,HUNDRD,ONE,PROD, - * SIX,SUM,SUM1,SUM2,TEMP,TEMP1,TEMP2,TEMP3,TEMP4,TEN,THREE, - * TI,TJ,TK,TPI,TWENTY,TWO,ZERO - REAL FLOAT - DATA ZERO,ONE,TWO,THREE,FOUR,FIVE,SIX,EIGHT,TEN,FIFTN,TWENTY, - * HUNDRD - * /0.0E0,1.0E0,2.0E0,3.0E0,4.0E0,5.0E0,6.0E0,8.0E0,1.0E1, - * 1.5E1,2.0E1,1.0E2/ - DATA C1,C3,C4,C5,C6,C9 /1.0E4,2.0E2,2.02E1,1.98E1,1.8E2,2.9E1/ - FLOAT(IVAR) = IVAR -C -C JACOBIAN ROUTINE SELECTOR. -C - GO TO (10,20,50,60,90,100,200,230,290,320,350,380,420,450), - * NPROB -C -C ROSENBROCK FUNCTION. -C - 10 CONTINUE - FJAC(1,1) = -ONE - FJAC(1,2) = ZERO - FJAC(2,1) = -TWENTY*X(1) - FJAC(2,2) = TEN - GO TO 490 -C -C POWELL SINGULAR FUNCTION. -C - 20 CONTINUE - DO 40 K = 1, 4 - DO 30 J = 1, 4 - FJAC(K,J) = ZERO - 30 CONTINUE - 40 CONTINUE - FJAC(1,1) = ONE - FJAC(1,2) = TEN - FJAC(2,3) = SQRT(FIVE) - FJAC(2,4) = -FJAC(2,3) - FJAC(3,2) = TWO*(X(2) - TWO*X(3)) - FJAC(3,3) = -TWO*FJAC(3,2) - FJAC(4,1) = TWO*SQRT(TEN)*(X(1) - X(4)) - FJAC(4,4) = -FJAC(4,1) - GO TO 490 -C -C POWELL BADLY SCALED FUNCTION. -C - 50 CONTINUE - FJAC(1,1) = C1*X(2) - FJAC(1,2) = C1*X(1) - FJAC(2,1) = -EXP(-X(1)) - FJAC(2,2) = -EXP(-X(2)) - GO TO 490 -C -C WOOD FUNCTION. -C - 60 CONTINUE - DO 80 K = 1, 4 - DO 70 J = 1, 4 - FJAC(K,J) = ZERO - 70 CONTINUE - 80 CONTINUE - TEMP1 = X(2) - THREE*X(1)**2 - TEMP2 = X(4) - THREE*X(3)**2 - FJAC(1,1) = -C3*TEMP1 + ONE - FJAC(1,2) = -C3*X(1) - FJAC(2,1) = -TWO*C3*X(1) - FJAC(2,2) = C3 + C4 - FJAC(2,4) = C5 - FJAC(3,3) = -C6*TEMP2 + ONE - FJAC(3,4) = -C6*X(3) - FJAC(4,2) = C5 - FJAC(4,3) = -TWO*C6*X(3) - FJAC(4,4) = C6 + C4 - GO TO 490 -C -C HELICAL VALLEY FUNCTION. -C - 90 CONTINUE - TPI = EIGHT*ATAN(ONE) - TEMP = X(1)**2 + X(2)**2 - TEMP1 = TPI*TEMP - TEMP2 = SQRT(TEMP) - FJAC(1,1) = HUNDRD*X(2)/TEMP1 - FJAC(1,2) = -HUNDRD*X(1)/TEMP1 - FJAC(1,3) = TEN - FJAC(2,1) = TEN*X(1)/TEMP2 - FJAC(2,2) = TEN*X(2)/TEMP2 - FJAC(2,3) = ZERO - FJAC(3,1) = ZERO - FJAC(3,2) = ZERO - FJAC(3,3) = ONE - GO TO 490 -C -C WATSON FUNCTION. -C - 100 CONTINUE - DO 120 K = 1, N - DO 110 J = K, N - FJAC(K,J) = ZERO - 110 CONTINUE - 120 CONTINUE - DO 170 I = 1, 29 - TI = FLOAT(I)/C9 - SUM1 = ZERO - TEMP = ONE - DO 130 J = 2, N - SUM1 = SUM1 + FLOAT(J-1)*TEMP*X(J) - TEMP = TI*TEMP - 130 CONTINUE - SUM2 = ZERO - TEMP = ONE - DO 140 J = 1, N - SUM2 = SUM2 + TEMP*X(J) - TEMP = TI*TEMP - 140 CONTINUE - TEMP1 = TWO*(SUM1 - SUM2**2 - ONE) - TEMP2 = TWO*SUM2 - TEMP = TI**2 - TK = ONE - DO 160 K = 1, N - TJ = TK - DO 150 J = K, N - FJAC(K,J) = FJAC(K,J) - * + TJ - * *((FLOAT(K-1)/TI - TEMP2) - * *(FLOAT(J-1)/TI - TEMP2) - TEMP1) - TJ = TI*TJ - 150 CONTINUE - TK = TEMP*TK - 160 CONTINUE - 170 CONTINUE - FJAC(1,1) = FJAC(1,1) + SIX*X(1)**2 - TWO*X(2) + THREE - FJAC(1,2) = FJAC(1,2) - TWO*X(1) - FJAC(2,2) = FJAC(2,2) + ONE - DO 190 K = 1, N - DO 180 J = K, N - FJAC(J,K) = FJAC(K,J) - 180 CONTINUE - 190 CONTINUE - GO TO 490 -C -C CHEBYQUAD FUNCTION. -C - 200 CONTINUE - TK = ONE/FLOAT(N) - DO 220 J = 1, N - TEMP1 = ONE - TEMP2 = TWO*X(J) - ONE - TEMP = TWO*TEMP2 - TEMP3 = ZERO - TEMP4 = TWO - DO 210 K = 1, N - FJAC(K,J) = TK*TEMP4 - TI = FOUR*TEMP2 + TEMP*TEMP4 - TEMP3 - TEMP3 = TEMP4 - TEMP4 = TI - TI = TEMP*TEMP2 - TEMP1 - TEMP1 = TEMP2 - TEMP2 = TI - 210 CONTINUE - 220 CONTINUE - GO TO 490 -C -C BROWN ALMOST-LINEAR FUNCTION. -C - 230 CONTINUE - PROD = ONE - DO 250 J = 1, N - PROD = X(J)*PROD - DO 240 K = 1, N - FJAC(K,J) = ONE - 240 CONTINUE - FJAC(J,J) = TWO - 250 CONTINUE - DO 280 J = 1, N - TEMP = X(J) - IF (TEMP .NE. ZERO) GO TO 270 - TEMP = ONE - PROD = ONE - DO 260 K = 1, N - IF (K .NE. J) PROD = X(K)*PROD - 260 CONTINUE - 270 CONTINUE - FJAC(N,J) = PROD/TEMP - 280 CONTINUE - GO TO 490 -C -C DISCRETE BOUNDARY VALUE FUNCTION. -C - 290 CONTINUE - H = ONE/FLOAT(N+1) - DO 310 K = 1, N - TEMP = THREE*(X(K) + FLOAT(K)*H + ONE)**2 - DO 300 J = 1, N - FJAC(K,J) = ZERO - 300 CONTINUE - FJAC(K,K) = TWO + TEMP*H**2/TWO - IF (K .NE. 1) FJAC(K,K-1) = -ONE - IF (K .NE. N) FJAC(K,K+1) = -ONE - 310 CONTINUE - GO TO 490 -C -C DISCRETE INTEGRAL EQUATION FUNCTION. -C - 320 CONTINUE - H = ONE/FLOAT(N+1) - DO 340 K = 1, N - TK = FLOAT(K)*H - DO 330 J = 1, N - TJ = FLOAT(J)*H - TEMP = THREE*(X(J) + TJ + ONE)**2 - FJAC(K,J) = H*AMIN1(TJ*(ONE-TK),TK*(ONE-TJ))*TEMP/TWO - 330 CONTINUE - FJAC(K,K) = FJAC(K,K) + ONE - 340 CONTINUE - GO TO 490 -C -C TRIGONOMETRIC FUNCTION. -C - 350 CONTINUE - DO 370 J = 1, N - TEMP = SIN(X(J)) - DO 360 K = 1, N - FJAC(K,J) = TEMP - 360 CONTINUE - FJAC(J,J) = FLOAT(J+1)*TEMP - COS(X(J)) - 370 CONTINUE - GO TO 490 -C -C VARIABLY DIMENSIONED FUNCTION. -C - 380 CONTINUE - SUM = ZERO - DO 390 J = 1, N - SUM = SUM + FLOAT(J)*(X(J) - ONE) - 390 CONTINUE - TEMP = ONE + SIX*SUM**2 - DO 410 K = 1, N - DO 400 J = K, N - FJAC(K,J) = FLOAT(K*J)*TEMP - FJAC(J,K) = FJAC(K,J) - 400 CONTINUE - FJAC(K,K) = FJAC(K,K) + ONE - 410 CONTINUE - GO TO 490 -C -C BROYDEN TRIDIAGONAL FUNCTION. -C - 420 CONTINUE - DO 440 K = 1, N - DO 430 J = 1, N - FJAC(K,J) = ZERO - 430 CONTINUE - FJAC(K,K) = THREE - FOUR*X(K) - IF (K .NE. 1) FJAC(K,K-1) = -ONE - IF (K .NE. N) FJAC(K,K+1) = -TWO - 440 CONTINUE - GO TO 490 -C -C BROYDEN BANDED FUNCTION. -C - 450 CONTINUE - ML = 5 - MU = 1 - DO 480 K = 1, N - DO 460 J = 1, N - FJAC(K,J) = ZERO - 460 CONTINUE - K1 = MAX0(1,K-ML) - K2 = MIN0(K+MU,N) - DO 470 J = K1, K2 - IF (J .NE. K) FJAC(K,J) = -(ONE + TWO*X(J)) - 470 CONTINUE - FJAC(K,K) = TWO + FIFTN*X(K)**2 - 480 CONTINUE - 490 CONTINUE - RETURN -C -C LAST CARD OF SUBROUTINE VECJAC. -C - END - SUBROUTINE INITPT(N,X,NPROB,FACTOR) - INTEGER N,NPROB - REAL FACTOR - REAL X(N) -C ********** -C -C SUBROUTINE INITPT -C -C THIS SUBROUTINE SPECIFIES THE STANDARD STARTING POINTS FOR -C THE FUNCTIONS DEFINED BY SUBROUTINE VECFCN. THE SUBROUTINE -C RETURNS IN X A MULTIPLE (FACTOR) OF THE STANDARD STARTING -C POINT. FOR THE SIXTH FUNCTION THE STANDARD STARTING POINT IS -C ZERO, SO IN THIS CASE, IF FACTOR IS NOT UNITY, THEN THE -C SUBROUTINE RETURNS THE VECTOR X(J) = FACTOR, J=1,...,N. -C -C THE SUBROUTINE STATEMENT IS -C -C SUBROUTINE INITPT(N,X,NPROB,FACTOR) -C -C WHERE -C -C N IS A POSITIVE INTEGER INPUT VARIABLE. -C -C X IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE STANDARD -C STARTING POINT FOR PROBLEM NPROB MULTIPLIED BY FACTOR. -C -C NPROB IS A POSITIVE INTEGER INPUT VARIABLE WHICH DEFINES THE -C NUMBER OF THE PROBLEM. NPROB MUST NOT EXCEED 14. -C -C FACTOR IS AN INPUT VARIABLE WHICH SPECIFIES THE MULTIPLE OF -C THE STANDARD STARTING POINT. IF FACTOR IS UNITY, NO -C MULTIPLICATION IS PERFORMED. -C -C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. -C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE -C -C ********** - INTEGER IVAR,J - REAL C1,H,HALF,ONE,THREE,TJ,ZERO - REAL FLOAT - DATA ZERO,HALF,ONE,THREE,C1 /0.0E0,5.0E-1,1.0E0,3.0E0,1.2E0/ - FLOAT(IVAR) = IVAR -C -C SELECTION OF INITIAL POINT. -C - GO TO (10,20,30,40,50,60,80,100,120,120,140,160,180,180), NPROB -C -C ROSENBROCK FUNCTION. -C - 10 CONTINUE - X(1) = -C1 - X(2) = ONE - GO TO 200 -C -C POWELL SINGULAR FUNCTION. -C - 20 CONTINUE - X(1) = THREE - X(2) = -ONE - X(3) = ZERO - X(4) = ONE - GO TO 200 -C -C POWELL BADLY SCALED FUNCTION. -C - 30 CONTINUE - X(1) = ZERO - X(2) = ONE - GO TO 200 -C -C WOOD FUNCTION. -C - 40 CONTINUE - X(1) = -THREE - X(2) = -ONE - X(3) = -THREE - X(4) = -ONE - GO TO 200 -C -C HELICAL VALLEY FUNCTION. -C - 50 CONTINUE - X(1) = -ONE - X(2) = ZERO - X(3) = ZERO - GO TO 200 -C -C WATSON FUNCTION. -C - 60 CONTINUE - DO 70 J = 1, N - X(J) = ZERO - 70 CONTINUE - GO TO 200 -C -C CHEBYQUAD FUNCTION. -C - 80 CONTINUE - H = ONE/FLOAT(N+1) - DO 90 J = 1, N - X(J) = FLOAT(J)*H - 90 CONTINUE - GO TO 200 -C -C BROWN ALMOST-LINEAR FUNCTION. -C - 100 CONTINUE - DO 110 J = 1, N - X(J) = HALF - 110 CONTINUE - GO TO 200 -C -C DISCRETE BOUNDARY VALUE AND INTEGRAL EQUATION FUNCTIONS. -C - 120 CONTINUE - H = ONE/FLOAT(N+1) - DO 130 J = 1, N - TJ = FLOAT(J)*H - X(J) = TJ*(TJ - ONE) - 130 CONTINUE - GO TO 200 -C -C TRIGONOMETRIC FUNCTION. -C - 140 CONTINUE - H = ONE/FLOAT(N) - DO 150 J = 1, N - X(J) = H - 150 CONTINUE - GO TO 200 -C -C VARIABLY DIMENSIONED FUNCTION. -C - 160 CONTINUE - H = ONE/FLOAT(N) - DO 170 J = 1, N - X(J) = ONE - FLOAT(J)*H - 170 CONTINUE - GO TO 200 -C -C BROYDEN TRIDIAGONAL AND BANDED FUNCTIONS. -C - 180 CONTINUE - DO 190 J = 1, N - X(J) = -ONE - 190 CONTINUE - 200 CONTINUE -C -C COMPUTE MULTIPLE OF INITIAL POINT. -C - IF (FACTOR .EQ. ONE) GO TO 250 - IF (NPROB .EQ. 6) GO TO 220 - DO 210 J = 1, N - X(J) = FACTOR*X(J) - 210 CONTINUE - GO TO 240 - 220 CONTINUE - DO 230 J = 1, N - X(J) = FACTOR - 230 CONTINUE - 240 CONTINUE - 250 CONTINUE - RETURN -C -C LAST CARD OF SUBROUTINE INITPT. -C - END - SUBROUTINE VECFCN(N,X,FVEC,NPROB) - INTEGER N,NPROB - REAL X(N),FVEC(N) -C ********** -C -C SUBROUTINE VECFCN -C -C THIS SUBROUTINE DEFINES FOURTEEN TEST FUNCTIONS. THE FIRST -C FIVE TEST FUNCTIONS ARE OF DIMENSIONS 2,4,2,4,3, RESPECTIVELY, -C WHILE THE REMAINING TEST FUNCTIONS ARE OF VARIABLE DIMENSION -C N FOR ANY N GREATER THAN OR EQUAL TO 1 (PROBLEM 6 IS AN -C EXCEPTION TO THIS, SINCE IT DOES NOT ALLOW N = 1). -C -C THE SUBROUTINE STATEMENT IS -C -C SUBROUTINE VECFCN(N,X,FVEC,NPROB) -C -C WHERE -C -C N IS A POSITIVE INTEGER INPUT VARIABLE. -C -C X IS AN INPUT ARRAY OF LENGTH N. -C -C FVEC IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE NPROB -C FUNCTION VECTOR EVALUATED AT X. -C -C NPROB IS A POSITIVE INTEGER INPUT VARIABLE WHICH DEFINES THE -C NUMBER OF THE PROBLEM. NPROB MUST NOT EXCEED 14. -C -C SUBPROGRAMS CALLED -C -C FORTRAN-SUPPLIED ... ATAN,COS,EXP,SIGN,SIN,SQRT, -C MAX0,MIN0 -C -C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. -C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE -C -C ********** - INTEGER I,IEV,IVAR,J,K,K1,K2,KP1,ML,MU - REAL C1,C2,C3,C4,C5,C6,C7,C8,C9,EIGHT,FIVE,H,ONE,PROD,SUM,SUM1, - * SUM2,TEMP,TEMP1,TEMP2,TEN,THREE,TI,TJ,TK,TPI,TWO,ZERO - REAL FLOAT - DATA ZERO,ONE,TWO,THREE,FIVE,EIGHT,TEN - * /0.0E0,1.0E0,2.0E0,3.0E0,5.0E0,8.0E0,1.0E1/ - DATA C1,C2,C3,C4,C5,C6,C7,C8,C9 - * /1.0E4,1.0001E0,2.0E2,2.02E1,1.98E1,1.8E2,2.5E-1,5.0E-1, - * 2.9E1/ - FLOAT(IVAR) = IVAR -C -C PROBLEM SELECTOR. -C - GO TO (10,20,30,40,50,60,120,170,200,220,270,300,330,350), NPROB -C -C ROSENBROCK FUNCTION. -C - 10 CONTINUE - FVEC(1) = ONE - X(1) - FVEC(2) = TEN*(X(2) - X(1)**2) - GO TO 380 -C -C POWELL SINGULAR FUNCTION. -C - 20 CONTINUE - FVEC(1) = X(1) + TEN*X(2) - FVEC(2) = SQRT(FIVE)*(X(3) - X(4)) - FVEC(3) = (X(2) - TWO*X(3))**2 - FVEC(4) = SQRT(TEN)*(X(1) - X(4))**2 - GO TO 380 -C -C POWELL BADLY SCALED FUNCTION. -C - 30 CONTINUE - FVEC(1) = C1*X(1)*X(2) - ONE - FVEC(2) = EXP(-X(1)) + EXP(-X(2)) - C2 - GO TO 380 -C -C WOOD FUNCTION. -C - 40 CONTINUE - TEMP1 = X(2) - X(1)**2 - TEMP2 = X(4) - X(3)**2 - FVEC(1) = -C3*X(1)*TEMP1 - (ONE - X(1)) - FVEC(2) = C3*TEMP1 + C4*(X(2) - ONE) + C5*(X(4) - ONE) - FVEC(3) = -C6*X(3)*TEMP2 - (ONE - X(3)) - FVEC(4) = C6*TEMP2 + C4*(X(4) - ONE) + C5*(X(2) - ONE) - GO TO 380 -C -C HELICAL VALLEY FUNCTION. -C - 50 CONTINUE - TPI = EIGHT*ATAN(ONE) - TEMP1 = SIGN(C7,X(2)) - IF (X(1) .GT. ZERO) TEMP1 = ATAN(X(2)/X(1))/TPI - IF (X(1) .LT. ZERO) TEMP1 = ATAN(X(2)/X(1))/TPI + C8 - TEMP2 = SQRT(X(1)**2+X(2)**2) - FVEC(1) = TEN*(X(3) - TEN*TEMP1) - FVEC(2) = TEN*(TEMP2 - ONE) - FVEC(3) = X(3) - GO TO 380 -C -C WATSON FUNCTION. -C - 60 CONTINUE - DO 70 K = 1, N - FVEC(K) = ZERO - 70 CONTINUE - DO 110 I = 1, 29 - TI = FLOAT(I)/C9 - SUM1 = ZERO - TEMP = ONE - DO 80 J = 2, N - SUM1 = SUM1 + FLOAT(J-1)*TEMP*X(J) - TEMP = TI*TEMP - 80 CONTINUE - SUM2 = ZERO - TEMP = ONE - DO 90 J = 1, N - SUM2 = SUM2 + TEMP*X(J) - TEMP = TI*TEMP - 90 CONTINUE - TEMP1 = SUM1 - SUM2**2 - ONE - TEMP2 = TWO*TI*SUM2 - TEMP = ONE/TI - DO 100 K = 1, N - FVEC(K) = FVEC(K) + TEMP*(FLOAT(K-1) - TEMP2)*TEMP1 - TEMP = TI*TEMP - 100 CONTINUE - 110 CONTINUE - TEMP = X(2) - X(1)**2 - ONE - FVEC(1) = FVEC(1) + X(1)*(ONE - TWO*TEMP) - FVEC(2) = FVEC(2) + TEMP - GO TO 380 -C -C CHEBYQUAD FUNCTION. -C - 120 CONTINUE - DO 130 K = 1, N - FVEC(K) = ZERO - 130 CONTINUE - DO 150 J = 1, N - TEMP1 = ONE - TEMP2 = TWO*X(J) - ONE - TEMP = TWO*TEMP2 - DO 140 I = 1, N - FVEC(I) = FVEC(I) + TEMP2 - TI = TEMP*TEMP2 - TEMP1 - TEMP1 = TEMP2 - TEMP2 = TI - 140 CONTINUE - 150 CONTINUE - TK = ONE/FLOAT(N) - IEV = -1 - DO 160 K = 1, N - FVEC(K) = TK*FVEC(K) - IF (IEV .GT. 0) FVEC(K) = FVEC(K) + ONE/(FLOAT(K)**2 - ONE) - IEV = -IEV - 160 CONTINUE - GO TO 380 -C -C BROWN ALMOST-LINEAR FUNCTION. -C - 170 CONTINUE - SUM = -FLOAT(N+1) - PROD = ONE - DO 180 J = 1, N - SUM = SUM + X(J) - PROD = X(J)*PROD - 180 CONTINUE - DO 190 K = 1, N - FVEC(K) = X(K) + SUM - 190 CONTINUE - FVEC(N) = PROD - ONE - GO TO 380 -C -C DISCRETE BOUNDARY VALUE FUNCTION. -C - 200 CONTINUE - H = ONE/FLOAT(N+1) - DO 210 K = 1, N - TEMP = (X(K) + FLOAT(K)*H + ONE)**3 - TEMP1 = ZERO - IF (K .NE. 1) TEMP1 = X(K-1) - TEMP2 = ZERO - IF (K .NE. N) TEMP2 = X(K+1) - FVEC(K) = TWO*X(K) - TEMP1 - TEMP2 + TEMP*H**2/TWO - 210 CONTINUE - GO TO 380 -C -C DISCRETE INTEGRAL EQUATION FUNCTION. -C - 220 CONTINUE - H = ONE/FLOAT(N+1) - DO 260 K = 1, N - TK = FLOAT(K)*H - SUM1 = ZERO - DO 230 J = 1, K - TJ = FLOAT(J)*H - TEMP = (X(J) + TJ + ONE)**3 - SUM1 = SUM1 + TJ*TEMP - 230 CONTINUE - SUM2 = ZERO - KP1 = K + 1 - IF (N .LT. KP1) GO TO 250 - DO 240 J = KP1, N - TJ = FLOAT(J)*H - TEMP = (X(J) + TJ + ONE)**3 - SUM2 = SUM2 + (ONE - TJ)*TEMP - 240 CONTINUE - 250 CONTINUE - FVEC(K) = X(K) + H*((ONE - TK)*SUM1 + TK*SUM2)/TWO - 260 CONTINUE - GO TO 380 -C -C TRIGONOMETRIC FUNCTION. -C - 270 CONTINUE - SUM = ZERO - DO 280 J = 1, N - FVEC(J) = COS(X(J)) - SUM = SUM + FVEC(J) - 280 CONTINUE - DO 290 K = 1, N - FVEC(K) = FLOAT(N+K) - SIN(X(K)) - SUM - FLOAT(K)*FVEC(K) - 290 CONTINUE - GO TO 380 -C -C VARIABLY DIMENSIONED FUNCTION. -C - 300 CONTINUE - SUM = ZERO - DO 310 J = 1, N - SUM = SUM + FLOAT(J)*(X(J) - ONE) - 310 CONTINUE - TEMP = SUM*(ONE + TWO*SUM**2) - DO 320 K = 1, N - FVEC(K) = X(K) - ONE + FLOAT(K)*TEMP - 320 CONTINUE - GO TO 380 -C -C BROYDEN TRIDIAGONAL FUNCTION. -C - 330 CONTINUE - DO 340 K = 1, N - TEMP = (THREE - TWO*X(K))*X(K) - TEMP1 = ZERO - IF (K .NE. 1) TEMP1 = X(K-1) - TEMP2 = ZERO - IF (K .NE. N) TEMP2 = X(K+1) - FVEC(K) = TEMP - TEMP1 - TWO*TEMP2 + ONE - 340 CONTINUE - GO TO 380 -C -C BROYDEN BANDED FUNCTION. -C - 350 CONTINUE - ML = 5 - MU = 1 - DO 370 K = 1, N - K1 = MAX0(1,K-ML) - K2 = MIN0(K+MU,N) - TEMP = ZERO - DO 360 J = K1, K2 - IF (J .NE. K) TEMP = TEMP + X(J)*(ONE + X(J)) - 360 CONTINUE - FVEC(K) = X(K)*(TWO + FIVE*X(K)**2) + ONE - TEMP - 370 CONTINUE - 380 CONTINUE - RETURN -C -C LAST CARD OF SUBROUTINE VECFCN. -C - END diff --git a/ex/file10 b/ex/file10 deleted file mode 100644 index fea853e..0000000 --- a/ex/file10 +++ /dev/null @@ -1,1022 +0,0 @@ -C ********** -C -C THIS PROGRAM TESTS CODES FOR THE LEAST-SQUARES SOLUTION OF -C M NONLINEAR EQUATIONS IN N VARIABLES. IT CONSISTS OF A DRIVER -C AND AN INTERFACE SUBROUTINE FCN. THE DRIVER READS IN DATA, -C CALLS THE NONLINEAR LEAST-SQUARES SOLVER, AND FINALLY PRINTS -C OUT INFORMATION ON THE PERFORMANCE OF THE SOLVER. THIS IS -C ONLY A SAMPLE DRIVER, MANY OTHER DRIVERS ARE POSSIBLE. THE -C INTERFACE SUBROUTINE FCN IS NECESSARY TO TAKE INTO ACCOUNT THE -C FORMS OF CALLING SEQUENCES USED BY THE FUNCTION AND JACOBIAN -C SUBROUTINES IN THE VARIOUS NONLINEAR LEAST-SQUARES SOLVERS. -C -C SUBPROGRAMS CALLED -C -C USER-SUPPLIED ...... FCN -C -C MINPACK-SUPPLIED ... SPMPAR,ENORM,INITPT,LMDER1,SSQFCN -C -C FORTRAN-SUPPLIED ... SQRT -C -C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. -C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE -C -C ********** - INTEGER I,IC,INFO,K,LDFJAC,LWA,M,N,NFEV,NJEV,NPROB,NREAD,NTRIES, - * NWRITE - INTEGER IWA(40),MA(60),NA(60),NF(60),NJ(60),NP(60),NX(60) - REAL FACTOR,FNORM1,FNORM2,ONE,TEN,TOL - REAL FJAC(65,40),FNM(60),FVEC(65),WA(265),X(40) - REAL SPMPAR,ENORM - EXTERNAL FCN - COMMON /REFNUM/ NPROB,NFEV,NJEV -C -C LOGICAL INPUT UNIT IS ASSUMED TO BE NUMBER 5. -C LOGICAL OUTPUT UNIT IS ASSUMED TO BE NUMBER 6. -C - DATA NREAD,NWRITE /5,6/ -C - DATA ONE,TEN /1.0E0,1.0E1/ - TOL = SQRT(SPMPAR(1)) - LDFJAC = 65 - LWA = 265 - IC = 0 - 10 CONTINUE - READ (NREAD,50) NPROB,N,M,NTRIES - IF (NPROB .LE. 0) GO TO 30 - FACTOR = ONE - DO 20 K = 1, NTRIES - IC = IC + 1 - CALL INITPT(N,X,NPROB,FACTOR) - CALL SSQFCN(M,N,X,FVEC,NPROB) - FNORM1 = ENORM(M,FVEC) - WRITE (NWRITE,60) NPROB,N,M - NFEV = 0 - NJEV = 0 - CALL LMDER1(FCN,M,N,X,FVEC,FJAC,LDFJAC,TOL,INFO,IWA,WA, - * LWA) - CALL SSQFCN(M,N,X,FVEC,NPROB) - FNORM2 = ENORM(M,FVEC) - NP(IC) = NPROB - NA(IC) = N - MA(IC) = M - NF(IC) = NFEV - NJ(IC) = NJEV - NX(IC) = INFO - FNM(IC) = FNORM2 - WRITE (NWRITE,70) - * FNORM1,FNORM2,NFEV,NJEV,INFO,(X(I), I = 1, N) - FACTOR = TEN*FACTOR - 20 CONTINUE - GO TO 10 - 30 CONTINUE - WRITE (NWRITE,80) IC - WRITE (NWRITE,90) - DO 40 I = 1, IC - WRITE (NWRITE,100) NP(I),NA(I),MA(I),NF(I),NJ(I),NX(I),FNM(I) - 40 CONTINUE - STOP - 50 FORMAT (4I5) - 60 FORMAT ( //// 5X, 8H PROBLEM, I5, 5X, 11H DIMENSIONS, 2I5, 5X // - * ) - 70 FORMAT (5X, 33H INITIAL L2 NORM OF THE RESIDUALS, E15.7 // 5X, - * 33H FINAL L2 NORM OF THE RESIDUALS , E15.7 // 5X, - * 33H NUMBER OF FUNCTION EVALUATIONS , I10 // 5X, - * 33H NUMBER OF JACOBIAN EVALUATIONS , I10 // 5X, - * 15H EXIT PARAMETER, 18X, I10 // 5X, - * 27H FINAL APPROXIMATE SOLUTION // (5X, 5E15.7)) - 80 FORMAT (12H1SUMMARY OF , I3, 16H CALLS TO LMDER1 /) - 90 FORMAT (49H NPROB N M NFEV NJEV INFO FINAL L2 NORM /) - 100 FORMAT (3I5, 3I6, 2X, E15.7) -C -C LAST CARD OF DRIVER. -C - END - SUBROUTINE FCN(M,N,X,FVEC,FJAC,LDFJAC,IFLAG) - INTEGER M,N,LDFJAC,IFLAG - REAL X(N),FVEC(M),FJAC(LDFJAC,N) -C ********** -C -C THE CALLING SEQUENCE OF FCN SHOULD BE IDENTICAL TO THE -C CALLING SEQUENCE OF THE FUNCTION SUBROUTINE IN THE NONLINEAR -C LEAST-SQUARES SOLVER. FCN SHOULD ONLY CALL THE TESTING -C FUNCTION AND JACOBIAN SUBROUTINES SSQFCN AND SSQJAC WITH -C THE APPROPRIATE VALUE OF PROBLEM NUMBER (NPROB). -C -C SUBPROGRAMS CALLED -C -C MINPACK-SUPPLIED ... SSQFCN,SSQJAC -C -C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. -C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE -C -C ********** - INTEGER NPROB,NFEV,NJEV - COMMON /REFNUM/ NPROB,NFEV,NJEV - IF (IFLAG .EQ. 1) CALL SSQFCN(M,N,X,FVEC,NPROB) - IF (IFLAG .EQ. 2) CALL SSQJAC(M,N,X,FJAC,LDFJAC,NPROB) - IF (IFLAG .EQ. 1) NFEV = NFEV + 1 - IF (IFLAG .EQ. 2) NJEV = NJEV + 1 - RETURN -C -C LAST CARD OF INTERFACE SUBROUTINE FCN. -C - END - SUBROUTINE SSQJAC(M,N,X,FJAC,LDFJAC,NPROB) - INTEGER M,N,LDFJAC,NPROB - REAL X(N),FJAC(LDFJAC,N) -C ********** -C -C SUBROUTINE SSQJAC -C -C THIS SUBROUTINE DEFINES THE JACOBIAN MATRICES OF EIGHTEEN -C NONLINEAR LEAST SQUARES PROBLEMS. THE PROBLEM DIMENSIONS ARE -C AS DESCRIBED IN THE PROLOGUE COMMENTS OF SSQFCN. -C -C THE SUBROUTINE STATEMENT IS -C -C SUBROUTINE SSQJAC(M,N,X,FJAC,LDFJAC,NPROB) -C -C WHERE -C -C M AND N ARE POSITIVE INTEGER INPUT VARIABLES. N MUST NOT -C EXCEED M. -C -C X IS AN INPUT ARRAY OF LENGTH N. -C -C FJAC IS AN M BY N OUTPUT ARRAY WHICH CONTAINS THE JACOBIAN -C MATRIX OF THE NPROB FUNCTION EVALUATED AT X. -C -C LDFJAC IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN M -C WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY FJAC. -C -C NPROB IS A POSITIVE INTEGER VARIABLE WHICH DEFINES THE -C NUMBER OF THE PROBLEM. NPROB MUST NOT EXCEED 18. -C -C SUBPROGRAMS CALLED -C -C FORTRAN-SUPPLIED ... ATAN,COS,EXP,SIN,SQRT -C -C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. -C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE -C -C ********** - INTEGER I,IVAR,J,K,MM1,NM1 - REAL C14,C20,C29,C45,C100,DIV,DX,EIGHT,FIVE,FOUR,ONE,PROD,S2, - * TEMP,TEN,THREE,TI,TMP1,TMP2,TMP3,TMP4,TPI,TWO,ZERO - REAL V(11) - REAL FLOAT - DATA ZERO,ONE,TWO,THREE,FOUR,FIVE,EIGHT,TEN,C14,C20,C29,C45,C100 - * /0.0E0,1.0E0,2.0E0,3.0E0,4.0E0,5.0E0,8.0E0,1.0E1,1.4E1, - * 2.0E1,2.9E1,4.5E1,1.0E2/ - DATA V(1),V(2),V(3),V(4),V(5),V(6),V(7),V(8),V(9),V(10),V(11) - * /4.0E0,2.0E0,1.0E0,5.0E-1,2.5E-1,1.67E-1,1.25E-1,1.0E-1, - * 8.33E-2,7.14E-2,6.25E-2/ - FLOAT(IVAR) = IVAR -C -C JACOBIAN ROUTINE SELECTOR. -C - GO TO (10,40,70,130,140,150,180,190,210,230,250,310,330,350,370, - * 400,460,480), NPROB -C -C LINEAR FUNCTION - FULL RANK. -C - 10 CONTINUE - TEMP = TWO/FLOAT(M) - DO 30 J = 1, N - DO 20 I = 1, M - FJAC(I,J) = -TEMP - 20 CONTINUE - FJAC(J,J) = FJAC(J,J) + ONE - 30 CONTINUE - GO TO 500 -C -C LINEAR FUNCTION - RANK 1. -C - 40 CONTINUE - DO 60 J = 1, N - DO 50 I = 1, M - FJAC(I,J) = FLOAT(I)*FLOAT(J) - 50 CONTINUE - 60 CONTINUE - GO TO 500 -C -C LINEAR FUNCTION - RANK 1 WITH ZERO COLUMNS AND ROWS. -C - 70 CONTINUE - DO 90 J = 1, N - DO 80 I = 1, M - FJAC(I,J) = ZERO - 80 CONTINUE - 90 CONTINUE - NM1 = N - 1 - MM1 = M - 1 - IF (NM1 .LT. 2) GO TO 120 - DO 110 J = 2, NM1 - DO 100 I = 2, MM1 - FJAC(I,J) = FLOAT(I-1)*FLOAT(J) - 100 CONTINUE - 110 CONTINUE - 120 CONTINUE - GO TO 500 -C -C ROSENBROCK FUNCTION. -C - 130 CONTINUE - FJAC(1,1) = -C20*X(1) - FJAC(1,2) = TEN - FJAC(2,1) = -ONE - FJAC(2,2) = ZERO - GO TO 500 -C -C HELICAL VALLEY FUNCTION. -C - 140 CONTINUE - TPI = EIGHT*ATAN(ONE) - TEMP = X(1)**2 + X(2)**2 - TMP1 = TPI*TEMP - TMP2 = SQRT(TEMP) - FJAC(1,1) = C100*X(2)/TMP1 - FJAC(1,2) = -C100*X(1)/TMP1 - FJAC(1,3) = TEN - FJAC(2,1) = TEN*X(1)/TMP2 - FJAC(2,2) = TEN*X(2)/TMP2 - FJAC(2,3) = ZERO - FJAC(3,1) = ZERO - FJAC(3,2) = ZERO - FJAC(3,3) = ONE - GO TO 500 -C -C POWELL SINGULAR FUNCTION. -C - 150 CONTINUE - DO 170 J = 1, 4 - DO 160 I = 1, 4 - FJAC(I,J) = ZERO - 160 CONTINUE - 170 CONTINUE - FJAC(1,1) = ONE - FJAC(1,2) = TEN - FJAC(2,3) = SQRT(FIVE) - FJAC(2,4) = -FJAC(2,3) - FJAC(3,2) = TWO*(X(2) - TWO*X(3)) - FJAC(3,3) = -TWO*FJAC(3,2) - FJAC(4,1) = TWO*SQRT(TEN)*(X(1) - X(4)) - FJAC(4,4) = -FJAC(4,1) - GO TO 500 -C -C FREUDENSTEIN AND ROTH FUNCTION. -C - 180 CONTINUE - FJAC(1,1) = ONE - FJAC(1,2) = X(2)*(TEN - THREE*X(2)) - TWO - FJAC(2,1) = ONE - FJAC(2,2) = X(2)*(TWO + THREE*X(2)) - C14 - GO TO 500 -C -C BARD FUNCTION. -C - 190 CONTINUE - DO 200 I = 1, 15 - TMP1 = FLOAT(I) - TMP2 = FLOAT(16-I) - TMP3 = TMP1 - IF (I .GT. 8) TMP3 = TMP2 - TMP4 = (X(2)*TMP2 + X(3)*TMP3)**2 - FJAC(I,1) = -ONE - FJAC(I,2) = TMP1*TMP2/TMP4 - FJAC(I,3) = TMP1*TMP3/TMP4 - 200 CONTINUE - GO TO 500 -C -C KOWALIK AND OSBORNE FUNCTION. -C - 210 CONTINUE - DO 220 I = 1, 11 - TMP1 = V(I)*(V(I) + X(2)) - TMP2 = V(I)*(V(I) + X(3)) + X(4) - FJAC(I,1) = -TMP1/TMP2 - FJAC(I,2) = -V(I)*X(1)/TMP2 - FJAC(I,3) = FJAC(I,1)*FJAC(I,2) - FJAC(I,4) = FJAC(I,3)/V(I) - 220 CONTINUE - GO TO 500 -C -C MEYER FUNCTION. -C - 230 CONTINUE - DO 240 I = 1, 16 - TEMP = FIVE*FLOAT(I) + C45 + X(3) - TMP1 = X(2)/TEMP - TMP2 = EXP(TMP1) - FJAC(I,1) = TMP2 - FJAC(I,2) = X(1)*TMP2/TEMP - FJAC(I,3) = -TMP1*FJAC(I,2) - 240 CONTINUE - GO TO 500 -C -C WATSON FUNCTION. -C - 250 CONTINUE - DO 280 I = 1, 29 - DIV = FLOAT(I)/C29 - S2 = ZERO - DX = ONE - DO 260 J = 1, N - S2 = S2 + DX*X(J) - DX = DIV*DX - 260 CONTINUE - TEMP = TWO*DIV*S2 - DX = ONE/DIV - DO 270 J = 1, N - FJAC(I,J) = DX*(FLOAT(J-1) - TEMP) - DX = DIV*DX - 270 CONTINUE - 280 CONTINUE - DO 300 J = 1, N - DO 290 I = 30, 31 - FJAC(I,J) = ZERO - 290 CONTINUE - 300 CONTINUE - FJAC(30,1) = ONE - FJAC(31,1) = -TWO*X(1) - FJAC(31,2) = ONE - GO TO 500 -C -C BOX 3-DIMENSIONAL FUNCTION. -C - 310 CONTINUE - DO 320 I = 1, M - TEMP = FLOAT(I) - TMP1 = TEMP/TEN - FJAC(I,1) = -TMP1*EXP(-TMP1*X(1)) - FJAC(I,2) = TMP1*EXP(-TMP1*X(2)) - FJAC(I,3) = EXP(-TEMP) - EXP(-TMP1) - 320 CONTINUE - GO TO 500 -C -C JENNRICH AND SAMPSON FUNCTION. -C - 330 CONTINUE - DO 340 I = 1, M - TEMP = FLOAT(I) - FJAC(I,1) = -TEMP*EXP(TEMP*X(1)) - FJAC(I,2) = -TEMP*EXP(TEMP*X(2)) - 340 CONTINUE - GO TO 500 -C -C BROWN AND DENNIS FUNCTION. -C - 350 CONTINUE - DO 360 I = 1, M - TEMP = FLOAT(I)/FIVE - TI = SIN(TEMP) - TMP1 = X(1) + TEMP*X(2) - EXP(TEMP) - TMP2 = X(3) + TI*X(4) - COS(TEMP) - FJAC(I,1) = TWO*TMP1 - FJAC(I,2) = TEMP*FJAC(I,1) - FJAC(I,3) = TWO*TMP2 - FJAC(I,4) = TI*FJAC(I,3) - 360 CONTINUE - GO TO 500 -C -C CHEBYQUAD FUNCTION. -C - 370 CONTINUE - DX = ONE/FLOAT(N) - DO 390 J = 1, N - TMP1 = ONE - TMP2 = TWO*X(J) - ONE - TEMP = TWO*TMP2 - TMP3 = ZERO - TMP4 = TWO - DO 380 I = 1, M - FJAC(I,J) = DX*TMP4 - TI = FOUR*TMP2 + TEMP*TMP4 - TMP3 - TMP3 = TMP4 - TMP4 = TI - TI = TEMP*TMP2 - TMP1 - TMP1 = TMP2 - TMP2 = TI - 380 CONTINUE - 390 CONTINUE - GO TO 500 -C -C BROWN ALMOST-LINEAR FUNCTION. -C - 400 CONTINUE - PROD = ONE - DO 420 J = 1, N - PROD = X(J)*PROD - DO 410 I = 1, N - FJAC(I,J) = ONE - 410 CONTINUE - FJAC(J,J) = TWO - 420 CONTINUE - DO 450 J = 1, N - TEMP = X(J) - IF (TEMP .NE. ZERO) GO TO 440 - TEMP = ONE - PROD = ONE - DO 430 K = 1, N - IF (K .NE. J) PROD = X(K)*PROD - 430 CONTINUE - 440 CONTINUE - FJAC(N,J) = PROD/TEMP - 450 CONTINUE - GO TO 500 -C -C OSBORNE 1 FUNCTION. -C - 460 CONTINUE - DO 470 I = 1, 33 - TEMP = TEN*FLOAT(I-1) - TMP1 = EXP(-X(4)*TEMP) - TMP2 = EXP(-X(5)*TEMP) - FJAC(I,1) = -ONE - FJAC(I,2) = -TMP1 - FJAC(I,3) = -TMP2 - FJAC(I,4) = TEMP*X(2)*TMP1 - FJAC(I,5) = TEMP*X(3)*TMP2 - 470 CONTINUE - GO TO 500 -C -C OSBORNE 2 FUNCTION. -C - 480 CONTINUE - DO 490 I = 1, 65 - TEMP = FLOAT(I-1)/TEN - TMP1 = EXP(-X(5)*TEMP) - TMP2 = EXP(-X(6)*(TEMP-X(9))**2) - TMP3 = EXP(-X(7)*(TEMP-X(10))**2) - TMP4 = EXP(-X(8)*(TEMP-X(11))**2) - FJAC(I,1) = -TMP1 - FJAC(I,2) = -TMP2 - FJAC(I,3) = -TMP3 - FJAC(I,4) = -TMP4 - FJAC(I,5) = TEMP*X(1)*TMP1 - FJAC(I,6) = X(2)*(TEMP - X(9))**2*TMP2 - FJAC(I,7) = X(3)*(TEMP - X(10))**2*TMP3 - FJAC(I,8) = X(4)*(TEMP - X(11))**2*TMP4 - FJAC(I,9) = -TWO*X(2)*X(6)*(TEMP - X(9))*TMP2 - FJAC(I,10) = -TWO*X(3)*X(7)*(TEMP - X(10))*TMP3 - FJAC(I,11) = -TWO*X(4)*X(8)*(TEMP - X(11))*TMP4 - 490 CONTINUE - 500 CONTINUE - RETURN -C -C LAST CARD OF SUBROUTINE SSQJAC. -C - END - SUBROUTINE INITPT(N,X,NPROB,FACTOR) - INTEGER N,NPROB - REAL FACTOR - REAL X(N) -C ********** -C -C SUBROUTINE INITPT -C -C THIS SUBROUTINE SPECIFIES THE STANDARD STARTING POINTS FOR THE -C FUNCTIONS DEFINED BY SUBROUTINE SSQFCN. THE SUBROUTINE RETURNS -C IN X A MULTIPLE (FACTOR) OF THE STANDARD STARTING POINT. FOR -C THE 11TH FUNCTION THE STANDARD STARTING POINT IS ZERO, SO IN -C THIS CASE, IF FACTOR IS NOT UNITY, THEN THE SUBROUTINE RETURNS -C THE VECTOR X(J) = FACTOR, J=1,...,N. -C -C THE SUBROUTINE STATEMENT IS -C -C SUBROUTINE INITPT(N,X,NPROB,FACTOR) -C -C WHERE -C -C N IS A POSITIVE INTEGER INPUT VARIABLE. -C -C X IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE STANDARD -C STARTING POINT FOR PROBLEM NPROB MULTIPLIED BY FACTOR. -C -C NPROB IS A POSITIVE INTEGER INPUT VARIABLE WHICH DEFINES THE -C NUMBER OF THE PROBLEM. NPROB MUST NOT EXCEED 18. -C -C FACTOR IS AN INPUT VARIABLE WHICH SPECIFIES THE MULTIPLE OF -C THE STANDARD STARTING POINT. IF FACTOR IS UNITY, NO -C MULTIPLICATION IS PERFORMED. -C -C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. -C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE -C -C ********** - INTEGER IVAR,J - REAL C1,C2,C3,C4,C5,C6,C7,C8,C9,C10,C11,C12,C13,C14,C15,C16,C17, - * FIVE,H,HALF,ONE,SEVEN,TEN,THREE,TWENTY,TWNTF,TWO,ZERO - REAL FLOAT - DATA ZERO,HALF,ONE,TWO,THREE,FIVE,SEVEN,TEN,TWENTY,TWNTF - * /0.0E0,5.0E-1,1.0E0,2.0E0,3.0E0,5.0E0,7.0E0,1.0E1,2.0E1, - * 2.5E1/ - DATA C1,C2,C3,C4,C5,C6,C7,C8,C9,C10,C11,C12,C13,C14,C15,C16,C17 - * /1.2E0,2.5E-1,3.9E-1,4.15E-1,2.0E-2,4.0E3,2.5E2,3.0E-1, - * 4.0E-1,1.5E0,1.0E-2,1.3E0,6.5E-1,7.0E-1,6.0E-1,4.5E0, - * 5.5E0/ - FLOAT(IVAR) = IVAR -C -C SELECTION OF INITIAL POINT. -C - GO TO (10,10,10,30,40,50,60,70,80,90,100,120,130,140,150,170, - * 190,200), NPROB -C -C LINEAR FUNCTION - FULL RANK OR RANK 1. -C - 10 CONTINUE - DO 20 J = 1, N - X(J) = ONE - 20 CONTINUE - GO TO 210 -C -C ROSENBROCK FUNCTION. -C - 30 CONTINUE - X(1) = -C1 - X(2) = ONE - GO TO 210 -C -C HELICAL VALLEY FUNCTION. -C - 40 CONTINUE - X(1) = -ONE - X(2) = ZERO - X(3) = ZERO - GO TO 210 -C -C POWELL SINGULAR FUNCTION. -C - 50 CONTINUE - X(1) = THREE - X(2) = -ONE - X(3) = ZERO - X(4) = ONE - GO TO 210 -C -C FREUDENSTEIN AND ROTH FUNCTION. -C - 60 CONTINUE - X(1) = HALF - X(2) = -TWO - GO TO 210 -C -C BARD FUNCTION. -C - 70 CONTINUE - X(1) = ONE - X(2) = ONE - X(3) = ONE - GO TO 210 -C -C KOWALIK AND OSBORNE FUNCTION. -C - 80 CONTINUE - X(1) = C2 - X(2) = C3 - X(3) = C4 - X(4) = C3 - GO TO 210 -C -C MEYER FUNCTION. -C - 90 CONTINUE - X(1) = C5 - X(2) = C6 - X(3) = C7 - GO TO 210 -C -C WATSON FUNCTION. -C - 100 CONTINUE - DO 110 J = 1, N - X(J) = ZERO - 110 CONTINUE - GO TO 210 -C -C BOX 3-DIMENSIONAL FUNCTION. -C - 120 CONTINUE - X(1) = ZERO - X(2) = TEN - X(3) = TWENTY - GO TO 210 -C -C JENNRICH AND SAMPSON FUNCTION. -C - 130 CONTINUE - X(1) = C8 - X(2) = C9 - GO TO 210 -C -C BROWN AND DENNIS FUNCTION. -C - 140 CONTINUE - X(1) = TWNTF - X(2) = FIVE - X(3) = -FIVE - X(4) = -ONE - GO TO 210 -C -C CHEBYQUAD FUNCTION. -C - 150 CONTINUE - H = ONE/FLOAT(N+1) - DO 160 J = 1, N - X(J) = FLOAT(J)*H - 160 CONTINUE - GO TO 210 -C -C BROWN ALMOST-LINEAR FUNCTION. -C - 170 CONTINUE - DO 180 J = 1, N - X(J) = HALF - 180 CONTINUE - GO TO 210 -C -C OSBORNE 1 FUNCTION. -C - 190 CONTINUE - X(1) = HALF - X(2) = C10 - X(3) = -ONE - X(4) = C11 - X(5) = C5 - GO TO 210 -C -C OSBORNE 2 FUNCTION. -C - 200 CONTINUE - X(1) = C12 - X(2) = C13 - X(3) = C13 - X(4) = C14 - X(5) = C15 - X(6) = THREE - X(7) = FIVE - X(8) = SEVEN - X(9) = TWO - X(10) = C16 - X(11) = C17 - 210 CONTINUE -C -C COMPUTE MULTIPLE OF INITIAL POINT. -C - IF (FACTOR .EQ. ONE) GO TO 260 - IF (NPROB .EQ. 11) GO TO 230 - DO 220 J = 1, N - X(J) = FACTOR*X(J) - 220 CONTINUE - GO TO 250 - 230 CONTINUE - DO 240 J = 1, N - X(J) = FACTOR - 240 CONTINUE - 250 CONTINUE - 260 CONTINUE - RETURN -C -C LAST CARD OF SUBROUTINE INITPT. -C - END - SUBROUTINE SSQFCN(M,N,X,FVEC,NPROB) - INTEGER M,N,NPROB - REAL X(N),FVEC(M) -C ********** -C -C SUBROUTINE SSQFCN -C -C THIS SUBROUTINE DEFINES THE FUNCTIONS OF EIGHTEEN NONLINEAR -C LEAST SQUARES PROBLEMS. THE ALLOWABLE VALUES OF (M,N) FOR -C FUNCTIONS 1,2 AND 3 ARE VARIABLE BUT WITH M .GE. N. -C FOR FUNCTIONS 4,5,6,7,8,9 AND 10 THE VALUES OF (M,N) ARE -C (2,2),(3,3),(4,4),(2,2),(15,3),(11,4) AND (16,3), RESPECTIVELY. -C FUNCTION 11 (WATSON) HAS M = 31 WITH N USUALLY 6 OR 9. -C HOWEVER, ANY N, N = 2,...,31, IS PERMITTED. -C FUNCTIONS 12,13 AND 14 HAVE N = 3,2 AND 4, RESPECTIVELY, BUT -C ALLOW ANY M .GE. N, WITH THE USUAL CHOICES BEING 10,10 AND 20. -C FUNCTION 15 (CHEBYQUAD) ALLOWS M AND N VARIABLE WITH M .GE. N. -C FUNCTION 16 (BROWN) ALLOWS N VARIABLE WITH M = N. -C FOR FUNCTIONS 17 AND 18, THE VALUES OF (M,N) ARE -C (33,5) AND (65,11), RESPECTIVELY. -C -C THE SUBROUTINE STATEMENT IS -C -C SUBROUTINE SSQFCN(M,N,X,FVEC,NPROB) -C -C WHERE -C -C M AND N ARE POSITIVE INTEGER INPUT VARIABLES. N MUST NOT -C EXCEED M. -C -C X IS AN INPUT ARRAY OF LENGTH N. -C -C FVEC IS AN OUTPUT ARRAY OF LENGTH M WHICH CONTAINS THE NPROB -C FUNCTION EVALUATED AT X. -C -C NPROB IS A POSITIVE INTEGER INPUT VARIABLE WHICH DEFINES THE -C NUMBER OF THE PROBLEM. NPROB MUST NOT EXCEED 18. -C -C SUBPROGRAMS CALLED -C -C FORTRAN-SUPPLIED ... ATAN,COS,EXP,SIN,SQRT,SIGN -C -C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. -C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE -C -C ********** - INTEGER I,IEV,IVAR,J,NM1 - REAL C13,C14,C29,C45,DIV,DX,EIGHT,FIVE,ONE,PROD,SUM,S1,S2,TEMP, - * TEN,TI,TMP1,TMP2,TMP3,TMP4,TPI,TWO,ZERO,ZP25,ZP5 - REAL V(11),Y1(15),Y2(11),Y3(16),Y4(33),Y5(65) - REAL FLOAT - DATA ZERO,ZP25,ZP5,ONE,TWO,FIVE,EIGHT,TEN,C13,C14,C29,C45 - * /0.0E0,2.5E-1,5.0E-1,1.0E0,2.0E0,5.0E0,8.0E0,1.0E1,1.3E1, - * 1.4E1,2.9E1,4.5E1/ - DATA V(1),V(2),V(3),V(4),V(5),V(6),V(7),V(8),V(9),V(10),V(11) - * /4.0E0,2.0E0,1.0E0,5.0E-1,2.5E-1,1.67E-1,1.25E-1,1.0E-1, - * 8.33E-2,7.14E-2,6.25E-2/ - DATA Y1(1),Y1(2),Y1(3),Y1(4),Y1(5),Y1(6),Y1(7),Y1(8),Y1(9), - * Y1(10),Y1(11),Y1(12),Y1(13),Y1(14),Y1(15) - * /1.4E-1,1.8E-1,2.2E-1,2.5E-1,2.9E-1,3.2E-1,3.5E-1,3.9E-1, - * 3.7E-1,5.8E-1,7.3E-1,9.6E-1,1.34E0,2.1E0,4.39E0/ - DATA Y2(1),Y2(2),Y2(3),Y2(4),Y2(5),Y2(6),Y2(7),Y2(8),Y2(9), - * Y2(10),Y2(11) - * /1.957E-1,1.947E-1,1.735E-1,1.6E-1,8.44E-2,6.27E-2,4.56E-2, - * 3.42E-2,3.23E-2,2.35E-2,2.46E-2/ - DATA Y3(1),Y3(2),Y3(3),Y3(4),Y3(5),Y3(6),Y3(7),Y3(8),Y3(9), - * Y3(10),Y3(11),Y3(12),Y3(13),Y3(14),Y3(15),Y3(16) - * /3.478E4,2.861E4,2.365E4,1.963E4,1.637E4,1.372E4,1.154E4, - * 9.744E3,8.261E3,7.03E3,6.005E3,5.147E3,4.427E3,3.82E3, - * 3.307E3,2.872E3/ - DATA Y4(1),Y4(2),Y4(3),Y4(4),Y4(5),Y4(6),Y4(7),Y4(8),Y4(9), - * Y4(10),Y4(11),Y4(12),Y4(13),Y4(14),Y4(15),Y4(16),Y4(17), - * Y4(18),Y4(19),Y4(20),Y4(21),Y4(22),Y4(23),Y4(24),Y4(25), - * Y4(26),Y4(27),Y4(28),Y4(29),Y4(30),Y4(31),Y4(32),Y4(33) - * /8.44E-1,9.08E-1,9.32E-1,9.36E-1,9.25E-1,9.08E-1,8.81E-1, - * 8.5E-1,8.18E-1,7.84E-1,7.51E-1,7.18E-1,6.85E-1,6.58E-1, - * 6.28E-1,6.03E-1,5.8E-1,5.58E-1,5.38E-1,5.22E-1,5.06E-1, - * 4.9E-1,4.78E-1,4.67E-1,4.57E-1,4.48E-1,4.38E-1,4.31E-1, - * 4.24E-1,4.2E-1,4.14E-1,4.11E-1,4.06E-1/ - DATA Y5(1),Y5(2),Y5(3),Y5(4),Y5(5),Y5(6),Y5(7),Y5(8),Y5(9), - * Y5(10),Y5(11),Y5(12),Y5(13),Y5(14),Y5(15),Y5(16),Y5(17), - * Y5(18),Y5(19),Y5(20),Y5(21),Y5(22),Y5(23),Y5(24),Y5(25), - * Y5(26),Y5(27),Y5(28),Y5(29),Y5(30),Y5(31),Y5(32),Y5(33), - * Y5(34),Y5(35),Y5(36),Y5(37),Y5(38),Y5(39),Y5(40),Y5(41), - * Y5(42),Y5(43),Y5(44),Y5(45),Y5(46),Y5(47),Y5(48),Y5(49), - * Y5(50),Y5(51),Y5(52),Y5(53),Y5(54),Y5(55),Y5(56),Y5(57), - * Y5(58),Y5(59),Y5(60),Y5(61),Y5(62),Y5(63),Y5(64),Y5(65) - * /1.366E0,1.191E0,1.112E0,1.013E0,9.91E-1,8.85E-1,8.31E-1, - * 8.47E-1,7.86E-1,7.25E-1,7.46E-1,6.79E-1,6.08E-1,6.55E-1, - * 6.16E-1,6.06E-1,6.02E-1,6.26E-1,6.51E-1,7.24E-1,6.49E-1, - * 6.49E-1,6.94E-1,6.44E-1,6.24E-1,6.61E-1,6.12E-1,5.58E-1, - * 5.33E-1,4.95E-1,5.0E-1,4.23E-1,3.95E-1,3.75E-1,3.72E-1, - * 3.91E-1,3.96E-1,4.05E-1,4.28E-1,4.29E-1,5.23E-1,5.62E-1, - * 6.07E-1,6.53E-1,6.72E-1,7.08E-1,6.33E-1,6.68E-1,6.45E-1, - * 6.32E-1,5.91E-1,5.59E-1,5.97E-1,6.25E-1,7.39E-1,7.1E-1, - * 7.29E-1,7.2E-1,6.36E-1,5.81E-1,4.28E-1,2.92E-1,1.62E-1, - * 9.8E-2,5.4E-2/ - FLOAT(IVAR) = IVAR -C -C FUNCTION ROUTINE SELECTOR. -C - GO TO (10,40,70,110,120,130,140,150,170,190,210,250,270,290,310, - * 360,390,410), NPROB -C -C LINEAR FUNCTION - FULL RANK. -C - 10 CONTINUE - SUM = ZERO - DO 20 J = 1, N - SUM = SUM + X(J) - 20 CONTINUE - TEMP = TWO*SUM/FLOAT(M) + ONE - DO 30 I = 1, M - FVEC(I) = -TEMP - IF (I .LE. N) FVEC(I) = FVEC(I) + X(I) - 30 CONTINUE - GO TO 430 -C -C LINEAR FUNCTION - RANK 1. -C - 40 CONTINUE - SUM = ZERO - DO 50 J = 1, N - SUM = SUM + FLOAT(J)*X(J) - 50 CONTINUE - DO 60 I = 1, M - FVEC(I) = FLOAT(I)*SUM - ONE - 60 CONTINUE - GO TO 430 -C -C LINEAR FUNCTION - RANK 1 WITH ZERO COLUMNS AND ROWS. -C - 70 CONTINUE - SUM = ZERO - NM1 = N - 1 - IF (NM1 .LT. 2) GO TO 90 - DO 80 J = 2, NM1 - SUM = SUM + FLOAT(J)*X(J) - 80 CONTINUE - 90 CONTINUE - DO 100 I = 1, M - FVEC(I) = FLOAT(I-1)*SUM - ONE - 100 CONTINUE - FVEC(M) = -ONE - GO TO 430 -C -C ROSENBROCK FUNCTION. -C - 110 CONTINUE - FVEC(1) = TEN*(X(2) - X(1)**2) - FVEC(2) = ONE - X(1) - GO TO 430 -C -C HELICAL VALLEY FUNCTION. -C - 120 CONTINUE - TPI = EIGHT*ATAN(ONE) - TMP1 = SIGN(ZP25,X(2)) - IF (X(1) .GT. ZERO) TMP1 = ATAN(X(2)/X(1))/TPI - IF (X(1) .LT. ZERO) TMP1 = ATAN(X(2)/X(1))/TPI + ZP5 - TMP2 = SQRT(X(1)**2+X(2)**2) - FVEC(1) = TEN*(X(3) - TEN*TMP1) - FVEC(2) = TEN*(TMP2 - ONE) - FVEC(3) = X(3) - GO TO 430 -C -C POWELL SINGULAR FUNCTION. -C - 130 CONTINUE - FVEC(1) = X(1) + TEN*X(2) - FVEC(2) = SQRT(FIVE)*(X(3) - X(4)) - FVEC(3) = (X(2) - TWO*X(3))**2 - FVEC(4) = SQRT(TEN)*(X(1) - X(4))**2 - GO TO 430 -C -C FREUDENSTEIN AND ROTH FUNCTION. -C - 140 CONTINUE - FVEC(1) = -C13 + X(1) + ((FIVE - X(2))*X(2) - TWO)*X(2) - FVEC(2) = -C29 + X(1) + ((ONE + X(2))*X(2) - C14)*X(2) - GO TO 430 -C -C BARD FUNCTION. -C - 150 CONTINUE - DO 160 I = 1, 15 - TMP1 = FLOAT(I) - TMP2 = FLOAT(16-I) - TMP3 = TMP1 - IF (I .GT. 8) TMP3 = TMP2 - FVEC(I) = Y1(I) - (X(1) + TMP1/(X(2)*TMP2 + X(3)*TMP3)) - 160 CONTINUE - GO TO 430 -C -C KOWALIK AND OSBORNE FUNCTION. -C - 170 CONTINUE - DO 180 I = 1, 11 - TMP1 = V(I)*(V(I) + X(2)) - TMP2 = V(I)*(V(I) + X(3)) + X(4) - FVEC(I) = Y2(I) - X(1)*TMP1/TMP2 - 180 CONTINUE - GO TO 430 -C -C MEYER FUNCTION. -C - 190 CONTINUE - DO 200 I = 1, 16 - TEMP = FIVE*FLOAT(I) + C45 + X(3) - TMP1 = X(2)/TEMP - TMP2 = EXP(TMP1) - FVEC(I) = X(1)*TMP2 - Y3(I) - 200 CONTINUE - GO TO 430 -C -C WATSON FUNCTION. -C - 210 CONTINUE - DO 240 I = 1, 29 - DIV = FLOAT(I)/C29 - S1 = ZERO - DX = ONE - DO 220 J = 2, N - S1 = S1 + FLOAT(J-1)*DX*X(J) - DX = DIV*DX - 220 CONTINUE - S2 = ZERO - DX = ONE - DO 230 J = 1, N - S2 = S2 + DX*X(J) - DX = DIV*DX - 230 CONTINUE - FVEC(I) = S1 - S2**2 - ONE - 240 CONTINUE - FVEC(30) = X(1) - FVEC(31) = X(2) - X(1)**2 - ONE - GO TO 430 -C -C BOX 3-DIMENSIONAL FUNCTION. -C - 250 CONTINUE - DO 260 I = 1, M - TEMP = FLOAT(I) - TMP1 = TEMP/TEN - FVEC(I) = EXP(-TMP1*X(1)) - EXP(-TMP1*X(2)) - * + (EXP(-TEMP) - EXP(-TMP1))*X(3) - 260 CONTINUE - GO TO 430 -C -C JENNRICH AND SAMPSON FUNCTION. -C - 270 CONTINUE - DO 280 I = 1, M - TEMP = FLOAT(I) - FVEC(I) = TWO + TWO*TEMP - EXP(TEMP*X(1)) - EXP(TEMP*X(2)) - 280 CONTINUE - GO TO 430 -C -C BROWN AND DENNIS FUNCTION. -C - 290 CONTINUE - DO 300 I = 1, M - TEMP = FLOAT(I)/FIVE - TMP1 = X(1) + TEMP*X(2) - EXP(TEMP) - TMP2 = X(3) + SIN(TEMP)*X(4) - COS(TEMP) - FVEC(I) = TMP1**2 + TMP2**2 - 300 CONTINUE - GO TO 430 -C -C CHEBYQUAD FUNCTION. -C - 310 CONTINUE - DO 320 I = 1, M - FVEC(I) = ZERO - 320 CONTINUE - DO 340 J = 1, N - TMP1 = ONE - TMP2 = TWO*X(J) - ONE - TEMP = TWO*TMP2 - DO 330 I = 1, M - FVEC(I) = FVEC(I) + TMP2 - TI = TEMP*TMP2 - TMP1 - TMP1 = TMP2 - TMP2 = TI - 330 CONTINUE - 340 CONTINUE - DX = ONE/FLOAT(N) - IEV = -1 - DO 350 I = 1, M - FVEC(I) = DX*FVEC(I) - IF (IEV .GT. 0) FVEC(I) = FVEC(I) + ONE/(FLOAT(I)**2 - ONE) - IEV = -IEV - 350 CONTINUE - GO TO 430 -C -C BROWN ALMOST-LINEAR FUNCTION. -C - 360 CONTINUE - SUM = -FLOAT(N+1) - PROD = ONE - DO 370 J = 1, N - SUM = SUM + X(J) - PROD = X(J)*PROD - 370 CONTINUE - DO 380 I = 1, N - FVEC(I) = X(I) + SUM - 380 CONTINUE - FVEC(N) = PROD - ONE - GO TO 430 -C -C OSBORNE 1 FUNCTION. -C - 390 CONTINUE - DO 400 I = 1, 33 - TEMP = TEN*FLOAT(I-1) - TMP1 = EXP(-X(4)*TEMP) - TMP2 = EXP(-X(5)*TEMP) - FVEC(I) = Y4(I) - (X(1) + X(2)*TMP1 + X(3)*TMP2) - 400 CONTINUE - GO TO 430 -C -C OSBORNE 2 FUNCTION. -C - 410 CONTINUE - DO 420 I = 1, 65 - TEMP = FLOAT(I-1)/TEN - TMP1 = EXP(-X(5)*TEMP) - TMP2 = EXP(-X(6)*(TEMP-X(9))**2) - TMP3 = EXP(-X(7)*(TEMP-X(10))**2) - TMP4 = EXP(-X(8)*(TEMP-X(11))**2) - FVEC(I) = Y5(I) - * - (X(1)*TMP1 + X(2)*TMP2 + X(3)*TMP3 + X(4)*TMP4) - 420 CONTINUE - 430 CONTINUE - RETURN -C -C LAST CARD OF SUBROUTINE SSQFCN. -C - END diff --git a/ex/file11 b/ex/file11 deleted file mode 100644 index adbbbdd..0000000 --- a/ex/file11 +++ /dev/null @@ -1,1033 +0,0 @@ -C ********** -C -C THIS PROGRAM TESTS CODES FOR THE LEAST-SQUARES SOLUTION OF -C M NONLINEAR EQUATIONS IN N VARIABLES. IT CONSISTS OF A DRIVER -C AND AN INTERFACE SUBROUTINE FCN. THE DRIVER READS IN DATA, -C CALLS THE NONLINEAR LEAST-SQUARES SOLVER, AND FINALLY PRINTS -C OUT INFORMATION ON THE PERFORMANCE OF THE SOLVER. THIS IS -C ONLY A SAMPLE DRIVER, MANY OTHER DRIVERS ARE POSSIBLE. THE -C INTERFACE SUBROUTINE FCN IS NECESSARY TO TAKE INTO ACCOUNT THE -C FORMS OF CALLING SEQUENCES USED BY THE FUNCTION AND JACOBIAN -C SUBROUTINES IN THE VARIOUS NONLINEAR LEAST-SQUARES SOLVERS. -C -C SUBPROGRAMS CALLED -C -C USER-SUPPLIED ...... FCN -C -C MINPACK-SUPPLIED ... SPMPAR,ENORM,INITPT,LMSTR1,SSQFCN -C -C FORTRAN-SUPPLIED ... SQRT -C -C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. -C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE -C -C ********** - INTEGER I,IC,INFO,K,LDFJAC,LWA,M,N,NFEV,NJEV,NPROB,NREAD,NTRIES, - * NWRITE - INTEGER IWA(40),MA(60),NA(60),NF(60),NJ(60),NP(60),NX(60) - REAL FACTOR,FNORM1,FNORM2,ONE,TEN,TOL - REAL FJAC(40,40),FNM(60),FVEC(65),WA(265),X(40) - REAL SPMPAR,ENORM - EXTERNAL FCN - COMMON /REFNUM/ NPROB,NFEV,NJEV -C -C LOGICAL INPUT UNIT IS ASSUMED TO BE NUMBER 5. -C LOGICAL OUTPUT UNIT IS ASSUMED TO BE NUMBER 6. -C - DATA NREAD,NWRITE /5,6/ -C - DATA ONE,TEN /1.0E0,1.0E1/ - TOL = SQRT(SPMPAR(1)) - LDFJAC = 40 - LWA = 265 - IC = 0 - 10 CONTINUE - READ (NREAD,50) NPROB,N,M,NTRIES - IF (NPROB .LE. 0) GO TO 30 - FACTOR = ONE - DO 20 K = 1, NTRIES - IC = IC + 1 - CALL INITPT(N,X,NPROB,FACTOR) - CALL SSQFCN(M,N,X,FVEC,NPROB) - FNORM1 = ENORM(M,FVEC) - WRITE (NWRITE,60) NPROB,N,M - NFEV = 0 - NJEV = 0 - CALL LMSTR1(FCN,M,N,X,FVEC,FJAC,LDFJAC,TOL,INFO,IWA,WA, - * LWA) - CALL SSQFCN(M,N,X,FVEC,NPROB) - FNORM2 = ENORM(M,FVEC) - NP(IC) = NPROB - NA(IC) = N - MA(IC) = M - NF(IC) = NFEV - NJ(IC) = NJEV - NX(IC) = INFO - FNM(IC) = FNORM2 - WRITE (NWRITE,70) - * FNORM1,FNORM2,NFEV,NJEV,INFO,(X(I), I = 1, N) - FACTOR = TEN*FACTOR - 20 CONTINUE - GO TO 10 - 30 CONTINUE - WRITE (NWRITE,80) IC - WRITE (NWRITE,90) - DO 40 I = 1, IC - WRITE (NWRITE,100) NP(I),NA(I),MA(I),NF(I),NJ(I),NX(I),FNM(I) - 40 CONTINUE - STOP - 50 FORMAT (4I5) - 60 FORMAT ( //// 5X, 8H PROBLEM, I5, 5X, 11H DIMENSIONS, 2I5, 5X // - * ) - 70 FORMAT (5X, 33H INITIAL L2 NORM OF THE RESIDUALS, E15.7 // 5X, - * 33H FINAL L2 NORM OF THE RESIDUALS , E15.7 // 5X, - * 33H NUMBER OF FUNCTION EVALUATIONS , I10 // 5X, - * 33H NUMBER OF JACOBIAN EVALUATIONS , I10 // 5X, - * 15H EXIT PARAMETER, 18X, I10 // 5X, - * 27H FINAL APPROXIMATE SOLUTION // (5X, 5E15.7)) - 80 FORMAT (12H1SUMMARY OF , I3, 16H CALLS TO LMSTR1 /) - 90 FORMAT (49H NPROB N M NFEV NJEV INFO FINAL L2 NORM /) - 100 FORMAT (3I5, 3I6, 2X, E15.7) -C -C LAST CARD OF DRIVER. -C - END - SUBROUTINE FCN(M,N,X,FVEC,FJROW,IFLAG) - INTEGER M,N,IFLAG - REAL X(N),FVEC(M),FJROW(N) -C ********** -C -C THE CALLING SEQUENCE OF FCN SHOULD BE IDENTICAL TO THE -C CALLING SEQUENCE OF THE FUNCTION SUBROUTINE IN THE NONLINEAR -C LEAST SQUARES SOLVER. IF IFLAG = 1, FCN SHOULD ONLY CALL THE -C TESTING FUNCTION SUBROUTINE SSQFCN. IF IFLAG = I, I .GE. 2, -C FCN SHOULD ONLY CALL SUBROUTINE SSQJAC TO CALCULATE THE -C (I-1)-ST ROW OF THE JACOBIAN. (THE SSQJAC SUBROUTINE PROVIDED -C HERE FOR TESTING PURPOSES CALCULATES THE ENTIRE JACOBIAN -C MATRIX AND IS THEREFORE CALLED ONLY WHEN IFLAG = 2.) EACH -C CALL TO SSQFCN OR SSQJAC SHOULD SPECIFY THE APPROPRIATE -C VALUE OF PROBLEM NUMBER (NPROB). -C -C SUBPROGRAMS CALLED -C -C MINPACK-SUPPLIED ... SSQFCN,SSQJAC -C -C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. -C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE -C -C ********** - INTEGER NPROB,NFEV,NJEV,J - REAL TEMP(65,40) - COMMON /REFNUM/ NPROB,NFEV,NJEV - IF (IFLAG .EQ. 1) CALL SSQFCN(M,N,X,FVEC,NPROB) - IF (IFLAG .EQ. 2) CALL SSQJAC(M,N,X,TEMP,65,NPROB) - IF (IFLAG .EQ. 1) NFEV = NFEV + 1 - IF (IFLAG .EQ. 2) NJEV = NJEV + 1 - IF (IFLAG .EQ. 1) GO TO 120 - DO 110 J = 1, N - FJROW(J) = TEMP(IFLAG-1,J) - 110 CONTINUE - 120 CONTINUE - RETURN -C -C LAST CARD OF INTERFACE SUBROUTINE FCN. -C - END - SUBROUTINE SSQJAC(M,N,X,FJAC,LDFJAC,NPROB) - INTEGER M,N,LDFJAC,NPROB - REAL X(N),FJAC(LDFJAC,N) -C ********** -C -C SUBROUTINE SSQJAC -C -C THIS SUBROUTINE DEFINES THE JACOBIAN MATRICES OF EIGHTEEN -C NONLINEAR LEAST SQUARES PROBLEMS. THE PROBLEM DIMENSIONS ARE -C AS DESCRIBED IN THE PROLOGUE COMMENTS OF SSQFCN. -C -C THE SUBROUTINE STATEMENT IS -C -C SUBROUTINE SSQJAC(M,N,X,FJAC,LDFJAC,NPROB) -C -C WHERE -C -C M AND N ARE POSITIVE INTEGER INPUT VARIABLES. N MUST NOT -C EXCEED M. -C -C X IS AN INPUT ARRAY OF LENGTH N. -C -C FJAC IS AN M BY N OUTPUT ARRAY WHICH CONTAINS THE JACOBIAN -C MATRIX OF THE NPROB FUNCTION EVALUATED AT X. -C -C LDFJAC IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN M -C WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY FJAC. -C -C NPROB IS A POSITIVE INTEGER VARIABLE WHICH DEFINES THE -C NUMBER OF THE PROBLEM. NPROB MUST NOT EXCEED 18. -C -C SUBPROGRAMS CALLED -C -C FORTRAN-SUPPLIED ... ATAN,COS,EXP,SIN,SQRT -C -C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. -C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE -C -C ********** - INTEGER I,IVAR,J,K,MM1,NM1 - REAL C14,C20,C29,C45,C100,DIV,DX,EIGHT,FIVE,FOUR,ONE,PROD,S2, - * TEMP,TEN,THREE,TI,TMP1,TMP2,TMP3,TMP4,TPI,TWO,ZERO - REAL V(11) - REAL FLOAT - DATA ZERO,ONE,TWO,THREE,FOUR,FIVE,EIGHT,TEN,C14,C20,C29,C45,C100 - * /0.0E0,1.0E0,2.0E0,3.0E0,4.0E0,5.0E0,8.0E0,1.0E1,1.4E1, - * 2.0E1,2.9E1,4.5E1,1.0E2/ - DATA V(1),V(2),V(3),V(4),V(5),V(6),V(7),V(8),V(9),V(10),V(11) - * /4.0E0,2.0E0,1.0E0,5.0E-1,2.5E-1,1.67E-1,1.25E-1,1.0E-1, - * 8.33E-2,7.14E-2,6.25E-2/ - FLOAT(IVAR) = IVAR -C -C JACOBIAN ROUTINE SELECTOR. -C - GO TO (10,40,70,130,140,150,180,190,210,230,250,310,330,350,370, - * 400,460,480), NPROB -C -C LINEAR FUNCTION - FULL RANK. -C - 10 CONTINUE - TEMP = TWO/FLOAT(M) - DO 30 J = 1, N - DO 20 I = 1, M - FJAC(I,J) = -TEMP - 20 CONTINUE - FJAC(J,J) = FJAC(J,J) + ONE - 30 CONTINUE - GO TO 500 -C -C LINEAR FUNCTION - RANK 1. -C - 40 CONTINUE - DO 60 J = 1, N - DO 50 I = 1, M - FJAC(I,J) = FLOAT(I)*FLOAT(J) - 50 CONTINUE - 60 CONTINUE - GO TO 500 -C -C LINEAR FUNCTION - RANK 1 WITH ZERO COLUMNS AND ROWS. -C - 70 CONTINUE - DO 90 J = 1, N - DO 80 I = 1, M - FJAC(I,J) = ZERO - 80 CONTINUE - 90 CONTINUE - NM1 = N - 1 - MM1 = M - 1 - IF (NM1 .LT. 2) GO TO 120 - DO 110 J = 2, NM1 - DO 100 I = 2, MM1 - FJAC(I,J) = FLOAT(I-1)*FLOAT(J) - 100 CONTINUE - 110 CONTINUE - 120 CONTINUE - GO TO 500 -C -C ROSENBROCK FUNCTION. -C - 130 CONTINUE - FJAC(1,1) = -C20*X(1) - FJAC(1,2) = TEN - FJAC(2,1) = -ONE - FJAC(2,2) = ZERO - GO TO 500 -C -C HELICAL VALLEY FUNCTION. -C - 140 CONTINUE - TPI = EIGHT*ATAN(ONE) - TEMP = X(1)**2 + X(2)**2 - TMP1 = TPI*TEMP - TMP2 = SQRT(TEMP) - FJAC(1,1) = C100*X(2)/TMP1 - FJAC(1,2) = -C100*X(1)/TMP1 - FJAC(1,3) = TEN - FJAC(2,1) = TEN*X(1)/TMP2 - FJAC(2,2) = TEN*X(2)/TMP2 - FJAC(2,3) = ZERO - FJAC(3,1) = ZERO - FJAC(3,2) = ZERO - FJAC(3,3) = ONE - GO TO 500 -C -C POWELL SINGULAR FUNCTION. -C - 150 CONTINUE - DO 170 J = 1, 4 - DO 160 I = 1, 4 - FJAC(I,J) = ZERO - 160 CONTINUE - 170 CONTINUE - FJAC(1,1) = ONE - FJAC(1,2) = TEN - FJAC(2,3) = SQRT(FIVE) - FJAC(2,4) = -FJAC(2,3) - FJAC(3,2) = TWO*(X(2) - TWO*X(3)) - FJAC(3,3) = -TWO*FJAC(3,2) - FJAC(4,1) = TWO*SQRT(TEN)*(X(1) - X(4)) - FJAC(4,4) = -FJAC(4,1) - GO TO 500 -C -C FREUDENSTEIN AND ROTH FUNCTION. -C - 180 CONTINUE - FJAC(1,1) = ONE - FJAC(1,2) = X(2)*(TEN - THREE*X(2)) - TWO - FJAC(2,1) = ONE - FJAC(2,2) = X(2)*(TWO + THREE*X(2)) - C14 - GO TO 500 -C -C BARD FUNCTION. -C - 190 CONTINUE - DO 200 I = 1, 15 - TMP1 = FLOAT(I) - TMP2 = FLOAT(16-I) - TMP3 = TMP1 - IF (I .GT. 8) TMP3 = TMP2 - TMP4 = (X(2)*TMP2 + X(3)*TMP3)**2 - FJAC(I,1) = -ONE - FJAC(I,2) = TMP1*TMP2/TMP4 - FJAC(I,3) = TMP1*TMP3/TMP4 - 200 CONTINUE - GO TO 500 -C -C KOWALIK AND OSBORNE FUNCTION. -C - 210 CONTINUE - DO 220 I = 1, 11 - TMP1 = V(I)*(V(I) + X(2)) - TMP2 = V(I)*(V(I) + X(3)) + X(4) - FJAC(I,1) = -TMP1/TMP2 - FJAC(I,2) = -V(I)*X(1)/TMP2 - FJAC(I,3) = FJAC(I,1)*FJAC(I,2) - FJAC(I,4) = FJAC(I,3)/V(I) - 220 CONTINUE - GO TO 500 -C -C MEYER FUNCTION. -C - 230 CONTINUE - DO 240 I = 1, 16 - TEMP = FIVE*FLOAT(I) + C45 + X(3) - TMP1 = X(2)/TEMP - TMP2 = EXP(TMP1) - FJAC(I,1) = TMP2 - FJAC(I,2) = X(1)*TMP2/TEMP - FJAC(I,3) = -TMP1*FJAC(I,2) - 240 CONTINUE - GO TO 500 -C -C WATSON FUNCTION. -C - 250 CONTINUE - DO 280 I = 1, 29 - DIV = FLOAT(I)/C29 - S2 = ZERO - DX = ONE - DO 260 J = 1, N - S2 = S2 + DX*X(J) - DX = DIV*DX - 260 CONTINUE - TEMP = TWO*DIV*S2 - DX = ONE/DIV - DO 270 J = 1, N - FJAC(I,J) = DX*(FLOAT(J-1) - TEMP) - DX = DIV*DX - 270 CONTINUE - 280 CONTINUE - DO 300 J = 1, N - DO 290 I = 30, 31 - FJAC(I,J) = ZERO - 290 CONTINUE - 300 CONTINUE - FJAC(30,1) = ONE - FJAC(31,1) = -TWO*X(1) - FJAC(31,2) = ONE - GO TO 500 -C -C BOX 3-DIMENSIONAL FUNCTION. -C - 310 CONTINUE - DO 320 I = 1, M - TEMP = FLOAT(I) - TMP1 = TEMP/TEN - FJAC(I,1) = -TMP1*EXP(-TMP1*X(1)) - FJAC(I,2) = TMP1*EXP(-TMP1*X(2)) - FJAC(I,3) = EXP(-TEMP) - EXP(-TMP1) - 320 CONTINUE - GO TO 500 -C -C JENNRICH AND SAMPSON FUNCTION. -C - 330 CONTINUE - DO 340 I = 1, M - TEMP = FLOAT(I) - FJAC(I,1) = -TEMP*EXP(TEMP*X(1)) - FJAC(I,2) = -TEMP*EXP(TEMP*X(2)) - 340 CONTINUE - GO TO 500 -C -C BROWN AND DENNIS FUNCTION. -C - 350 CONTINUE - DO 360 I = 1, M - TEMP = FLOAT(I)/FIVE - TI = SIN(TEMP) - TMP1 = X(1) + TEMP*X(2) - EXP(TEMP) - TMP2 = X(3) + TI*X(4) - COS(TEMP) - FJAC(I,1) = TWO*TMP1 - FJAC(I,2) = TEMP*FJAC(I,1) - FJAC(I,3) = TWO*TMP2 - FJAC(I,4) = TI*FJAC(I,3) - 360 CONTINUE - GO TO 500 -C -C CHEBYQUAD FUNCTION. -C - 370 CONTINUE - DX = ONE/FLOAT(N) - DO 390 J = 1, N - TMP1 = ONE - TMP2 = TWO*X(J) - ONE - TEMP = TWO*TMP2 - TMP3 = ZERO - TMP4 = TWO - DO 380 I = 1, M - FJAC(I,J) = DX*TMP4 - TI = FOUR*TMP2 + TEMP*TMP4 - TMP3 - TMP3 = TMP4 - TMP4 = TI - TI = TEMP*TMP2 - TMP1 - TMP1 = TMP2 - TMP2 = TI - 380 CONTINUE - 390 CONTINUE - GO TO 500 -C -C BROWN ALMOST-LINEAR FUNCTION. -C - 400 CONTINUE - PROD = ONE - DO 420 J = 1, N - PROD = X(J)*PROD - DO 410 I = 1, N - FJAC(I,J) = ONE - 410 CONTINUE - FJAC(J,J) = TWO - 420 CONTINUE - DO 450 J = 1, N - TEMP = X(J) - IF (TEMP .NE. ZERO) GO TO 440 - TEMP = ONE - PROD = ONE - DO 430 K = 1, N - IF (K .NE. J) PROD = X(K)*PROD - 430 CONTINUE - 440 CONTINUE - FJAC(N,J) = PROD/TEMP - 450 CONTINUE - GO TO 500 -C -C OSBORNE 1 FUNCTION. -C - 460 CONTINUE - DO 470 I = 1, 33 - TEMP = TEN*FLOAT(I-1) - TMP1 = EXP(-X(4)*TEMP) - TMP2 = EXP(-X(5)*TEMP) - FJAC(I,1) = -ONE - FJAC(I,2) = -TMP1 - FJAC(I,3) = -TMP2 - FJAC(I,4) = TEMP*X(2)*TMP1 - FJAC(I,5) = TEMP*X(3)*TMP2 - 470 CONTINUE - GO TO 500 -C -C OSBORNE 2 FUNCTION. -C - 480 CONTINUE - DO 490 I = 1, 65 - TEMP = FLOAT(I-1)/TEN - TMP1 = EXP(-X(5)*TEMP) - TMP2 = EXP(-X(6)*(TEMP-X(9))**2) - TMP3 = EXP(-X(7)*(TEMP-X(10))**2) - TMP4 = EXP(-X(8)*(TEMP-X(11))**2) - FJAC(I,1) = -TMP1 - FJAC(I,2) = -TMP2 - FJAC(I,3) = -TMP3 - FJAC(I,4) = -TMP4 - FJAC(I,5) = TEMP*X(1)*TMP1 - FJAC(I,6) = X(2)*(TEMP - X(9))**2*TMP2 - FJAC(I,7) = X(3)*(TEMP - X(10))**2*TMP3 - FJAC(I,8) = X(4)*(TEMP - X(11))**2*TMP4 - FJAC(I,9) = -TWO*X(2)*X(6)*(TEMP - X(9))*TMP2 - FJAC(I,10) = -TWO*X(3)*X(7)*(TEMP - X(10))*TMP3 - FJAC(I,11) = -TWO*X(4)*X(8)*(TEMP - X(11))*TMP4 - 490 CONTINUE - 500 CONTINUE - RETURN -C -C LAST CARD OF SUBROUTINE SSQJAC. -C - END - SUBROUTINE INITPT(N,X,NPROB,FACTOR) - INTEGER N,NPROB - REAL FACTOR - REAL X(N) -C ********** -C -C SUBROUTINE INITPT -C -C THIS SUBROUTINE SPECIFIES THE STANDARD STARTING POINTS FOR THE -C FUNCTIONS DEFINED BY SUBROUTINE SSQFCN. THE SUBROUTINE RETURNS -C IN X A MULTIPLE (FACTOR) OF THE STANDARD STARTING POINT. FOR -C THE 11TH FUNCTION THE STANDARD STARTING POINT IS ZERO, SO IN -C THIS CASE, IF FACTOR IS NOT UNITY, THEN THE SUBROUTINE RETURNS -C THE VECTOR X(J) = FACTOR, J=1,...,N. -C -C THE SUBROUTINE STATEMENT IS -C -C SUBROUTINE INITPT(N,X,NPROB,FACTOR) -C -C WHERE -C -C N IS A POSITIVE INTEGER INPUT VARIABLE. -C -C X IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE STANDARD -C STARTING POINT FOR PROBLEM NPROB MULTIPLIED BY FACTOR. -C -C NPROB IS A POSITIVE INTEGER INPUT VARIABLE WHICH DEFINES THE -C NUMBER OF THE PROBLEM. NPROB MUST NOT EXCEED 18. -C -C FACTOR IS AN INPUT VARIABLE WHICH SPECIFIES THE MULTIPLE OF -C THE STANDARD STARTING POINT. IF FACTOR IS UNITY, NO -C MULTIPLICATION IS PERFORMED. -C -C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. -C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE -C -C ********** - INTEGER IVAR,J - REAL C1,C2,C3,C4,C5,C6,C7,C8,C9,C10,C11,C12,C13,C14,C15,C16,C17, - * FIVE,H,HALF,ONE,SEVEN,TEN,THREE,TWENTY,TWNTF,TWO,ZERO - REAL FLOAT - DATA ZERO,HALF,ONE,TWO,THREE,FIVE,SEVEN,TEN,TWENTY,TWNTF - * /0.0E0,5.0E-1,1.0E0,2.0E0,3.0E0,5.0E0,7.0E0,1.0E1,2.0E1, - * 2.5E1/ - DATA C1,C2,C3,C4,C5,C6,C7,C8,C9,C10,C11,C12,C13,C14,C15,C16,C17 - * /1.2E0,2.5E-1,3.9E-1,4.15E-1,2.0E-2,4.0E3,2.5E2,3.0E-1, - * 4.0E-1,1.5E0,1.0E-2,1.3E0,6.5E-1,7.0E-1,6.0E-1,4.5E0, - * 5.5E0/ - FLOAT(IVAR) = IVAR -C -C SELECTION OF INITIAL POINT. -C - GO TO (10,10,10,30,40,50,60,70,80,90,100,120,130,140,150,170, - * 190,200), NPROB -C -C LINEAR FUNCTION - FULL RANK OR RANK 1. -C - 10 CONTINUE - DO 20 J = 1, N - X(J) = ONE - 20 CONTINUE - GO TO 210 -C -C ROSENBROCK FUNCTION. -C - 30 CONTINUE - X(1) = -C1 - X(2) = ONE - GO TO 210 -C -C HELICAL VALLEY FUNCTION. -C - 40 CONTINUE - X(1) = -ONE - X(2) = ZERO - X(3) = ZERO - GO TO 210 -C -C POWELL SINGULAR FUNCTION. -C - 50 CONTINUE - X(1) = THREE - X(2) = -ONE - X(3) = ZERO - X(4) = ONE - GO TO 210 -C -C FREUDENSTEIN AND ROTH FUNCTION. -C - 60 CONTINUE - X(1) = HALF - X(2) = -TWO - GO TO 210 -C -C BARD FUNCTION. -C - 70 CONTINUE - X(1) = ONE - X(2) = ONE - X(3) = ONE - GO TO 210 -C -C KOWALIK AND OSBORNE FUNCTION. -C - 80 CONTINUE - X(1) = C2 - X(2) = C3 - X(3) = C4 - X(4) = C3 - GO TO 210 -C -C MEYER FUNCTION. -C - 90 CONTINUE - X(1) = C5 - X(2) = C6 - X(3) = C7 - GO TO 210 -C -C WATSON FUNCTION. -C - 100 CONTINUE - DO 110 J = 1, N - X(J) = ZERO - 110 CONTINUE - GO TO 210 -C -C BOX 3-DIMENSIONAL FUNCTION. -C - 120 CONTINUE - X(1) = ZERO - X(2) = TEN - X(3) = TWENTY - GO TO 210 -C -C JENNRICH AND SAMPSON FUNCTION. -C - 130 CONTINUE - X(1) = C8 - X(2) = C9 - GO TO 210 -C -C BROWN AND DENNIS FUNCTION. -C - 140 CONTINUE - X(1) = TWNTF - X(2) = FIVE - X(3) = -FIVE - X(4) = -ONE - GO TO 210 -C -C CHEBYQUAD FUNCTION. -C - 150 CONTINUE - H = ONE/FLOAT(N+1) - DO 160 J = 1, N - X(J) = FLOAT(J)*H - 160 CONTINUE - GO TO 210 -C -C BROWN ALMOST-LINEAR FUNCTION. -C - 170 CONTINUE - DO 180 J = 1, N - X(J) = HALF - 180 CONTINUE - GO TO 210 -C -C OSBORNE 1 FUNCTION. -C - 190 CONTINUE - X(1) = HALF - X(2) = C10 - X(3) = -ONE - X(4) = C11 - X(5) = C5 - GO TO 210 -C -C OSBORNE 2 FUNCTION. -C - 200 CONTINUE - X(1) = C12 - X(2) = C13 - X(3) = C13 - X(4) = C14 - X(5) = C15 - X(6) = THREE - X(7) = FIVE - X(8) = SEVEN - X(9) = TWO - X(10) = C16 - X(11) = C17 - 210 CONTINUE -C -C COMPUTE MULTIPLE OF INITIAL POINT. -C - IF (FACTOR .EQ. ONE) GO TO 260 - IF (NPROB .EQ. 11) GO TO 230 - DO 220 J = 1, N - X(J) = FACTOR*X(J) - 220 CONTINUE - GO TO 250 - 230 CONTINUE - DO 240 J = 1, N - X(J) = FACTOR - 240 CONTINUE - 250 CONTINUE - 260 CONTINUE - RETURN -C -C LAST CARD OF SUBROUTINE INITPT. -C - END - SUBROUTINE SSQFCN(M,N,X,FVEC,NPROB) - INTEGER M,N,NPROB - REAL X(N),FVEC(M) -C ********** -C -C SUBROUTINE SSQFCN -C -C THIS SUBROUTINE DEFINES THE FUNCTIONS OF EIGHTEEN NONLINEAR -C LEAST SQUARES PROBLEMS. THE ALLOWABLE VALUES OF (M,N) FOR -C FUNCTIONS 1,2 AND 3 ARE VARIABLE BUT WITH M .GE. N. -C FOR FUNCTIONS 4,5,6,7,8,9 AND 10 THE VALUES OF (M,N) ARE -C (2,2),(3,3),(4,4),(2,2),(15,3),(11,4) AND (16,3), RESPECTIVELY. -C FUNCTION 11 (WATSON) HAS M = 31 WITH N USUALLY 6 OR 9. -C HOWEVER, ANY N, N = 2,...,31, IS PERMITTED. -C FUNCTIONS 12,13 AND 14 HAVE N = 3,2 AND 4, RESPECTIVELY, BUT -C ALLOW ANY M .GE. N, WITH THE USUAL CHOICES BEING 10,10 AND 20. -C FUNCTION 15 (CHEBYQUAD) ALLOWS M AND N VARIABLE WITH M .GE. N. -C FUNCTION 16 (BROWN) ALLOWS N VARIABLE WITH M = N. -C FOR FUNCTIONS 17 AND 18, THE VALUES OF (M,N) ARE -C (33,5) AND (65,11), RESPECTIVELY. -C -C THE SUBROUTINE STATEMENT IS -C -C SUBROUTINE SSQFCN(M,N,X,FVEC,NPROB) -C -C WHERE -C -C M AND N ARE POSITIVE INTEGER INPUT VARIABLES. N MUST NOT -C EXCEED M. -C -C X IS AN INPUT ARRAY OF LENGTH N. -C -C FVEC IS AN OUTPUT ARRAY OF LENGTH M WHICH CONTAINS THE NPROB -C FUNCTION EVALUATED AT X. -C -C NPROB IS A POSITIVE INTEGER INPUT VARIABLE WHICH DEFINES THE -C NUMBER OF THE PROBLEM. NPROB MUST NOT EXCEED 18. -C -C SUBPROGRAMS CALLED -C -C FORTRAN-SUPPLIED ... ATAN,COS,EXP,SIN,SQRT,SIGN -C -C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. -C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE -C -C ********** - INTEGER I,IEV,IVAR,J,NM1 - REAL C13,C14,C29,C45,DIV,DX,EIGHT,FIVE,ONE,PROD,SUM,S1,S2,TEMP, - * TEN,TI,TMP1,TMP2,TMP3,TMP4,TPI,TWO,ZERO,ZP25,ZP5 - REAL V(11),Y1(15),Y2(11),Y3(16),Y4(33),Y5(65) - REAL FLOAT - DATA ZERO,ZP25,ZP5,ONE,TWO,FIVE,EIGHT,TEN,C13,C14,C29,C45 - * /0.0E0,2.5E-1,5.0E-1,1.0E0,2.0E0,5.0E0,8.0E0,1.0E1,1.3E1, - * 1.4E1,2.9E1,4.5E1/ - DATA V(1),V(2),V(3),V(4),V(5),V(6),V(7),V(8),V(9),V(10),V(11) - * /4.0E0,2.0E0,1.0E0,5.0E-1,2.5E-1,1.67E-1,1.25E-1,1.0E-1, - * 8.33E-2,7.14E-2,6.25E-2/ - DATA Y1(1),Y1(2),Y1(3),Y1(4),Y1(5),Y1(6),Y1(7),Y1(8),Y1(9), - * Y1(10),Y1(11),Y1(12),Y1(13),Y1(14),Y1(15) - * /1.4E-1,1.8E-1,2.2E-1,2.5E-1,2.9E-1,3.2E-1,3.5E-1,3.9E-1, - * 3.7E-1,5.8E-1,7.3E-1,9.6E-1,1.34E0,2.1E0,4.39E0/ - DATA Y2(1),Y2(2),Y2(3),Y2(4),Y2(5),Y2(6),Y2(7),Y2(8),Y2(9), - * Y2(10),Y2(11) - * /1.957E-1,1.947E-1,1.735E-1,1.6E-1,8.44E-2,6.27E-2,4.56E-2, - * 3.42E-2,3.23E-2,2.35E-2,2.46E-2/ - DATA Y3(1),Y3(2),Y3(3),Y3(4),Y3(5),Y3(6),Y3(7),Y3(8),Y3(9), - * Y3(10),Y3(11),Y3(12),Y3(13),Y3(14),Y3(15),Y3(16) - * /3.478E4,2.861E4,2.365E4,1.963E4,1.637E4,1.372E4,1.154E4, - * 9.744E3,8.261E3,7.03E3,6.005E3,5.147E3,4.427E3,3.82E3, - * 3.307E3,2.872E3/ - DATA Y4(1),Y4(2),Y4(3),Y4(4),Y4(5),Y4(6),Y4(7),Y4(8),Y4(9), - * Y4(10),Y4(11),Y4(12),Y4(13),Y4(14),Y4(15),Y4(16),Y4(17), - * Y4(18),Y4(19),Y4(20),Y4(21),Y4(22),Y4(23),Y4(24),Y4(25), - * Y4(26),Y4(27),Y4(28),Y4(29),Y4(30),Y4(31),Y4(32),Y4(33) - * /8.44E-1,9.08E-1,9.32E-1,9.36E-1,9.25E-1,9.08E-1,8.81E-1, - * 8.5E-1,8.18E-1,7.84E-1,7.51E-1,7.18E-1,6.85E-1,6.58E-1, - * 6.28E-1,6.03E-1,5.8E-1,5.58E-1,5.38E-1,5.22E-1,5.06E-1, - * 4.9E-1,4.78E-1,4.67E-1,4.57E-1,4.48E-1,4.38E-1,4.31E-1, - * 4.24E-1,4.2E-1,4.14E-1,4.11E-1,4.06E-1/ - DATA Y5(1),Y5(2),Y5(3),Y5(4),Y5(5),Y5(6),Y5(7),Y5(8),Y5(9), - * Y5(10),Y5(11),Y5(12),Y5(13),Y5(14),Y5(15),Y5(16),Y5(17), - * Y5(18),Y5(19),Y5(20),Y5(21),Y5(22),Y5(23),Y5(24),Y5(25), - * Y5(26),Y5(27),Y5(28),Y5(29),Y5(30),Y5(31),Y5(32),Y5(33), - * Y5(34),Y5(35),Y5(36),Y5(37),Y5(38),Y5(39),Y5(40),Y5(41), - * Y5(42),Y5(43),Y5(44),Y5(45),Y5(46),Y5(47),Y5(48),Y5(49), - * Y5(50),Y5(51),Y5(52),Y5(53),Y5(54),Y5(55),Y5(56),Y5(57), - * Y5(58),Y5(59),Y5(60),Y5(61),Y5(62),Y5(63),Y5(64),Y5(65) - * /1.366E0,1.191E0,1.112E0,1.013E0,9.91E-1,8.85E-1,8.31E-1, - * 8.47E-1,7.86E-1,7.25E-1,7.46E-1,6.79E-1,6.08E-1,6.55E-1, - * 6.16E-1,6.06E-1,6.02E-1,6.26E-1,6.51E-1,7.24E-1,6.49E-1, - * 6.49E-1,6.94E-1,6.44E-1,6.24E-1,6.61E-1,6.12E-1,5.58E-1, - * 5.33E-1,4.95E-1,5.0E-1,4.23E-1,3.95E-1,3.75E-1,3.72E-1, - * 3.91E-1,3.96E-1,4.05E-1,4.28E-1,4.29E-1,5.23E-1,5.62E-1, - * 6.07E-1,6.53E-1,6.72E-1,7.08E-1,6.33E-1,6.68E-1,6.45E-1, - * 6.32E-1,5.91E-1,5.59E-1,5.97E-1,6.25E-1,7.39E-1,7.1E-1, - * 7.29E-1,7.2E-1,6.36E-1,5.81E-1,4.28E-1,2.92E-1,1.62E-1, - * 9.8E-2,5.4E-2/ - FLOAT(IVAR) = IVAR -C -C FUNCTION ROUTINE SELECTOR. -C - GO TO (10,40,70,110,120,130,140,150,170,190,210,250,270,290,310, - * 360,390,410), NPROB -C -C LINEAR FUNCTION - FULL RANK. -C - 10 CONTINUE - SUM = ZERO - DO 20 J = 1, N - SUM = SUM + X(J) - 20 CONTINUE - TEMP = TWO*SUM/FLOAT(M) + ONE - DO 30 I = 1, M - FVEC(I) = -TEMP - IF (I .LE. N) FVEC(I) = FVEC(I) + X(I) - 30 CONTINUE - GO TO 430 -C -C LINEAR FUNCTION - RANK 1. -C - 40 CONTINUE - SUM = ZERO - DO 50 J = 1, N - SUM = SUM + FLOAT(J)*X(J) - 50 CONTINUE - DO 60 I = 1, M - FVEC(I) = FLOAT(I)*SUM - ONE - 60 CONTINUE - GO TO 430 -C -C LINEAR FUNCTION - RANK 1 WITH ZERO COLUMNS AND ROWS. -C - 70 CONTINUE - SUM = ZERO - NM1 = N - 1 - IF (NM1 .LT. 2) GO TO 90 - DO 80 J = 2, NM1 - SUM = SUM + FLOAT(J)*X(J) - 80 CONTINUE - 90 CONTINUE - DO 100 I = 1, M - FVEC(I) = FLOAT(I-1)*SUM - ONE - 100 CONTINUE - FVEC(M) = -ONE - GO TO 430 -C -C ROSENBROCK FUNCTION. -C - 110 CONTINUE - FVEC(1) = TEN*(X(2) - X(1)**2) - FVEC(2) = ONE - X(1) - GO TO 430 -C -C HELICAL VALLEY FUNCTION. -C - 120 CONTINUE - TPI = EIGHT*ATAN(ONE) - TMP1 = SIGN(ZP25,X(2)) - IF (X(1) .GT. ZERO) TMP1 = ATAN(X(2)/X(1))/TPI - IF (X(1) .LT. ZERO) TMP1 = ATAN(X(2)/X(1))/TPI + ZP5 - TMP2 = SQRT(X(1)**2+X(2)**2) - FVEC(1) = TEN*(X(3) - TEN*TMP1) - FVEC(2) = TEN*(TMP2 - ONE) - FVEC(3) = X(3) - GO TO 430 -C -C POWELL SINGULAR FUNCTION. -C - 130 CONTINUE - FVEC(1) = X(1) + TEN*X(2) - FVEC(2) = SQRT(FIVE)*(X(3) - X(4)) - FVEC(3) = (X(2) - TWO*X(3))**2 - FVEC(4) = SQRT(TEN)*(X(1) - X(4))**2 - GO TO 430 -C -C FREUDENSTEIN AND ROTH FUNCTION. -C - 140 CONTINUE - FVEC(1) = -C13 + X(1) + ((FIVE - X(2))*X(2) - TWO)*X(2) - FVEC(2) = -C29 + X(1) + ((ONE + X(2))*X(2) - C14)*X(2) - GO TO 430 -C -C BARD FUNCTION. -C - 150 CONTINUE - DO 160 I = 1, 15 - TMP1 = FLOAT(I) - TMP2 = FLOAT(16-I) - TMP3 = TMP1 - IF (I .GT. 8) TMP3 = TMP2 - FVEC(I) = Y1(I) - (X(1) + TMP1/(X(2)*TMP2 + X(3)*TMP3)) - 160 CONTINUE - GO TO 430 -C -C KOWALIK AND OSBORNE FUNCTION. -C - 170 CONTINUE - DO 180 I = 1, 11 - TMP1 = V(I)*(V(I) + X(2)) - TMP2 = V(I)*(V(I) + X(3)) + X(4) - FVEC(I) = Y2(I) - X(1)*TMP1/TMP2 - 180 CONTINUE - GO TO 430 -C -C MEYER FUNCTION. -C - 190 CONTINUE - DO 200 I = 1, 16 - TEMP = FIVE*FLOAT(I) + C45 + X(3) - TMP1 = X(2)/TEMP - TMP2 = EXP(TMP1) - FVEC(I) = X(1)*TMP2 - Y3(I) - 200 CONTINUE - GO TO 430 -C -C WATSON FUNCTION. -C - 210 CONTINUE - DO 240 I = 1, 29 - DIV = FLOAT(I)/C29 - S1 = ZERO - DX = ONE - DO 220 J = 2, N - S1 = S1 + FLOAT(J-1)*DX*X(J) - DX = DIV*DX - 220 CONTINUE - S2 = ZERO - DX = ONE - DO 230 J = 1, N - S2 = S2 + DX*X(J) - DX = DIV*DX - 230 CONTINUE - FVEC(I) = S1 - S2**2 - ONE - 240 CONTINUE - FVEC(30) = X(1) - FVEC(31) = X(2) - X(1)**2 - ONE - GO TO 430 -C -C BOX 3-DIMENSIONAL FUNCTION. -C - 250 CONTINUE - DO 260 I = 1, M - TEMP = FLOAT(I) - TMP1 = TEMP/TEN - FVEC(I) = EXP(-TMP1*X(1)) - EXP(-TMP1*X(2)) - * + (EXP(-TEMP) - EXP(-TMP1))*X(3) - 260 CONTINUE - GO TO 430 -C -C JENNRICH AND SAMPSON FUNCTION. -C - 270 CONTINUE - DO 280 I = 1, M - TEMP = FLOAT(I) - FVEC(I) = TWO + TWO*TEMP - EXP(TEMP*X(1)) - EXP(TEMP*X(2)) - 280 CONTINUE - GO TO 430 -C -C BROWN AND DENNIS FUNCTION. -C - 290 CONTINUE - DO 300 I = 1, M - TEMP = FLOAT(I)/FIVE - TMP1 = X(1) + TEMP*X(2) - EXP(TEMP) - TMP2 = X(3) + SIN(TEMP)*X(4) - COS(TEMP) - FVEC(I) = TMP1**2 + TMP2**2 - 300 CONTINUE - GO TO 430 -C -C CHEBYQUAD FUNCTION. -C - 310 CONTINUE - DO 320 I = 1, M - FVEC(I) = ZERO - 320 CONTINUE - DO 340 J = 1, N - TMP1 = ONE - TMP2 = TWO*X(J) - ONE - TEMP = TWO*TMP2 - DO 330 I = 1, M - FVEC(I) = FVEC(I) + TMP2 - TI = TEMP*TMP2 - TMP1 - TMP1 = TMP2 - TMP2 = TI - 330 CONTINUE - 340 CONTINUE - DX = ONE/FLOAT(N) - IEV = -1 - DO 350 I = 1, M - FVEC(I) = DX*FVEC(I) - IF (IEV .GT. 0) FVEC(I) = FVEC(I) + ONE/(FLOAT(I)**2 - ONE) - IEV = -IEV - 350 CONTINUE - GO TO 430 -C -C BROWN ALMOST-LINEAR FUNCTION. -C - 360 CONTINUE - SUM = -FLOAT(N+1) - PROD = ONE - DO 370 J = 1, N - SUM = SUM + X(J) - PROD = X(J)*PROD - 370 CONTINUE - DO 380 I = 1, N - FVEC(I) = X(I) + SUM - 380 CONTINUE - FVEC(N) = PROD - ONE - GO TO 430 -C -C OSBORNE 1 FUNCTION. -C - 390 CONTINUE - DO 400 I = 1, 33 - TEMP = TEN*FLOAT(I-1) - TMP1 = EXP(-X(4)*TEMP) - TMP2 = EXP(-X(5)*TEMP) - FVEC(I) = Y4(I) - (X(1) + X(2)*TMP1 + X(3)*TMP2) - 400 CONTINUE - GO TO 430 -C -C OSBORNE 2 FUNCTION. -C - 410 CONTINUE - DO 420 I = 1, 65 - TEMP = FLOAT(I-1)/TEN - TMP1 = EXP(-X(5)*TEMP) - TMP2 = EXP(-X(6)*(TEMP-X(9))**2) - TMP3 = EXP(-X(7)*(TEMP-X(10))**2) - TMP4 = EXP(-X(8)*(TEMP-X(11))**2) - FVEC(I) = Y5(I) - * - (X(1)*TMP1 + X(2)*TMP2 + X(3)*TMP3 + X(4)*TMP4) - 420 CONTINUE - 430 CONTINUE - RETURN -C -C LAST CARD OF SUBROUTINE SSQFCN. -C - END diff --git a/ex/file12 b/ex/file12 deleted file mode 100644 index d051988..0000000 --- a/ex/file12 +++ /dev/null @@ -1,673 +0,0 @@ -C ********** -C -C THIS PROGRAM TESTS CODES FOR THE LEAST-SQUARES SOLUTION OF -C M NONLINEAR EQUATIONS IN N VARIABLES. IT CONSISTS OF A DRIVER -C AND AN INTERFACE SUBROUTINE FCN. THE DRIVER READS IN DATA, -C CALLS THE NONLINEAR LEAST-SQUARES SOLVER, AND FINALLY PRINTS -C OUT INFORMATION ON THE PERFORMANCE OF THE SOLVER. THIS IS -C ONLY A SAMPLE DRIVER, MANY OTHER DRIVERS ARE POSSIBLE. THE -C INTERFACE SUBROUTINE FCN IS NECESSARY TO TAKE INTO ACCOUNT THE -C FORMS OF CALLING SEQUENCES USED BY THE FUNCTION AND JACOBIAN -C SUBROUTINES IN THE VARIOUS NONLINEAR LEAST-SQUARES SOLVERS. -C -C SUBPROGRAMS CALLED -C -C USER-SUPPLIED ...... FCN -C -C MINPACK-SUPPLIED ... SPMPAR,ENORM,INITPT,LMDIF1,SSQFCN -C -C FORTRAN-SUPPLIED ... SQRT -C -C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. -C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE -C -C ********** - INTEGER I,IC,INFO,K,LWA,M,N,NFEV,NJEV,NPROB,NREAD,NTRIES,NWRITE - INTEGER IWA(40),MA(60),NA(60),NF(60),NJ(60),NP(60),NX(60) - REAL FACTOR,FNORM1,FNORM2,ONE,TEN,TOL - REAL FNM(60),FVEC(65),WA(2865),X(40) - REAL SPMPAR,ENORM - EXTERNAL FCN - COMMON /REFNUM/ NPROB,NFEV,NJEV -C -C LOGICAL INPUT UNIT IS ASSUMED TO BE NUMBER 5. -C LOGICAL OUTPUT UNIT IS ASSUMED TO BE NUMBER 6. -C - DATA NREAD,NWRITE /5,6/ -C - DATA ONE,TEN /1.0E0,1.0E1/ - TOL = SQRT(SPMPAR(1)) - LWA = 2865 - IC = 0 - 10 CONTINUE - READ (NREAD,50) NPROB,N,M,NTRIES - IF (NPROB .LE. 0) GO TO 30 - FACTOR = ONE - DO 20 K = 1, NTRIES - IC = IC + 1 - CALL INITPT(N,X,NPROB,FACTOR) - CALL SSQFCN(M,N,X,FVEC,NPROB) - FNORM1 = ENORM(M,FVEC) - WRITE (NWRITE,60) NPROB,N,M - NFEV = 0 - NJEV = 0 - CALL LMDIF1(FCN,M,N,X,FVEC,TOL,INFO,IWA,WA,LWA) - CALL SSQFCN(M,N,X,FVEC,NPROB) - FNORM2 = ENORM(M,FVEC) - NP(IC) = NPROB - NA(IC) = N - MA(IC) = M - NF(IC) = NFEV - NJEV = NJEV/N - NJ(IC) = NJEV - NX(IC) = INFO - FNM(IC) = FNORM2 - WRITE (NWRITE,70) - * FNORM1,FNORM2,NFEV,NJEV,INFO,(X(I), I = 1, N) - FACTOR = TEN*FACTOR - 20 CONTINUE - GO TO 10 - 30 CONTINUE - WRITE (NWRITE,80) IC - WRITE (NWRITE,90) - DO 40 I = 1, IC - WRITE (NWRITE,100) NP(I),NA(I),MA(I),NF(I),NJ(I),NX(I),FNM(I) - 40 CONTINUE - STOP - 50 FORMAT (4I5) - 60 FORMAT ( //// 5X, 8H PROBLEM, I5, 5X, 11H DIMENSIONS, 2I5, 5X // - * ) - 70 FORMAT (5X, 33H INITIAL L2 NORM OF THE RESIDUALS, E15.7 // 5X, - * 33H FINAL L2 NORM OF THE RESIDUALS , E15.7 // 5X, - * 33H NUMBER OF FUNCTION EVALUATIONS , I10 // 5X, - * 33H NUMBER OF JACOBIAN EVALUATIONS , I10 // 5X, - * 15H EXIT PARAMETER, 18X, I10 // 5X, - * 27H FINAL APPROXIMATE SOLUTION // (5X, 5E15.7)) - 80 FORMAT (12H1SUMMARY OF , I3, 16H CALLS TO LMDIF1 /) - 90 FORMAT (49H NPROB N M NFEV NJEV INFO FINAL L2 NORM /) - 100 FORMAT (3I5, 3I6, 2X, E15.7) -C -C LAST CARD OF DRIVER. -C - END - SUBROUTINE FCN(M,N,X,FVEC,IFLAG) - INTEGER M,N,IFLAG - REAL X(N),FVEC(M) -C ********** -C -C THE CALLING SEQUENCE OF FCN SHOULD BE IDENTICAL TO THE -C CALLING SEQUENCE OF THE FUNCTION SUBROUTINE IN THE NONLINEAR -C LEAST-SQUARES SOLVER. FCN SHOULD ONLY CALL THE TESTING -C FUNCTION SUBROUTINE SSQFCN WITH THE APPROPRIATE VALUE OF -C PROBLEM NUMBER (NPROB). -C -C SUBPROGRAMS CALLED -C -C MINPACK-SUPPLIED ... SSQFCN -C -C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. -C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE -C -C ********** - INTEGER NPROB,NFEV,NJEV - COMMON /REFNUM/ NPROB,NFEV,NJEV - CALL SSQFCN(M,N,X,FVEC,NPROB) - IF (IFLAG .EQ. 1) NFEV = NFEV + 1 - IF (IFLAG .EQ. 2) NJEV = NJEV + 1 - RETURN -C -C LAST CARD OF INTERFACE SUBROUTINE FCN. -C - END - SUBROUTINE SSQFCN(M,N,X,FVEC,NPROB) - INTEGER M,N,NPROB - REAL X(N),FVEC(M) -C ********** -C -C SUBROUTINE SSQFCN -C -C THIS SUBROUTINE DEFINES THE FUNCTIONS OF EIGHTEEN NONLINEAR -C LEAST SQUARES PROBLEMS. THE ALLOWABLE VALUES OF (M,N) FOR -C FUNCTIONS 1,2 AND 3 ARE VARIABLE BUT WITH M .GE. N. -C FOR FUNCTIONS 4,5,6,7,8,9 AND 10 THE VALUES OF (M,N) ARE -C (2,2),(3,3),(4,4),(2,2),(15,3),(11,4) AND (16,3), RESPECTIVELY. -C FUNCTION 11 (WATSON) HAS M = 31 WITH N USUALLY 6 OR 9. -C HOWEVER, ANY N, N = 2,...,31, IS PERMITTED. -C FUNCTIONS 12,13 AND 14 HAVE N = 3,2 AND 4, RESPECTIVELY, BUT -C ALLOW ANY M .GE. N, WITH THE USUAL CHOICES BEING 10,10 AND 20. -C FUNCTION 15 (CHEBYQUAD) ALLOWS M AND N VARIABLE WITH M .GE. N. -C FUNCTION 16 (BROWN) ALLOWS N VARIABLE WITH M = N. -C FOR FUNCTIONS 17 AND 18, THE VALUES OF (M,N) ARE -C (33,5) AND (65,11), RESPECTIVELY. -C -C THE SUBROUTINE STATEMENT IS -C -C SUBROUTINE SSQFCN(M,N,X,FVEC,NPROB) -C -C WHERE -C -C M AND N ARE POSITIVE INTEGER INPUT VARIABLES. N MUST NOT -C EXCEED M. -C -C X IS AN INPUT ARRAY OF LENGTH N. -C -C FVEC IS AN OUTPUT ARRAY OF LENGTH M WHICH CONTAINS THE NPROB -C FUNCTION EVALUATED AT X. -C -C NPROB IS A POSITIVE INTEGER INPUT VARIABLE WHICH DEFINES THE -C NUMBER OF THE PROBLEM. NPROB MUST NOT EXCEED 18. -C -C SUBPROGRAMS CALLED -C -C FORTRAN-SUPPLIED ... ATAN,COS,EXP,SIN,SQRT,SIGN -C -C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. -C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE -C -C ********** - INTEGER I,IEV,IVAR,J,NM1 - REAL C13,C14,C29,C45,DIV,DX,EIGHT,FIVE,ONE,PROD,SUM,S1,S2,TEMP, - * TEN,TI,TMP1,TMP2,TMP3,TMP4,TPI,TWO,ZERO,ZP25,ZP5 - REAL V(11),Y1(15),Y2(11),Y3(16),Y4(33),Y5(65) - REAL FLOAT - DATA ZERO,ZP25,ZP5,ONE,TWO,FIVE,EIGHT,TEN,C13,C14,C29,C45 - * /0.0E0,2.5E-1,5.0E-1,1.0E0,2.0E0,5.0E0,8.0E0,1.0E1,1.3E1, - * 1.4E1,2.9E1,4.5E1/ - DATA V(1),V(2),V(3),V(4),V(5),V(6),V(7),V(8),V(9),V(10),V(11) - * /4.0E0,2.0E0,1.0E0,5.0E-1,2.5E-1,1.67E-1,1.25E-1,1.0E-1, - * 8.33E-2,7.14E-2,6.25E-2/ - DATA Y1(1),Y1(2),Y1(3),Y1(4),Y1(5),Y1(6),Y1(7),Y1(8),Y1(9), - * Y1(10),Y1(11),Y1(12),Y1(13),Y1(14),Y1(15) - * /1.4E-1,1.8E-1,2.2E-1,2.5E-1,2.9E-1,3.2E-1,3.5E-1,3.9E-1, - * 3.7E-1,5.8E-1,7.3E-1,9.6E-1,1.34E0,2.1E0,4.39E0/ - DATA Y2(1),Y2(2),Y2(3),Y2(4),Y2(5),Y2(6),Y2(7),Y2(8),Y2(9), - * Y2(10),Y2(11) - * /1.957E-1,1.947E-1,1.735E-1,1.6E-1,8.44E-2,6.27E-2,4.56E-2, - * 3.42E-2,3.23E-2,2.35E-2,2.46E-2/ - DATA Y3(1),Y3(2),Y3(3),Y3(4),Y3(5),Y3(6),Y3(7),Y3(8),Y3(9), - * Y3(10),Y3(11),Y3(12),Y3(13),Y3(14),Y3(15),Y3(16) - * /3.478E4,2.861E4,2.365E4,1.963E4,1.637E4,1.372E4,1.154E4, - * 9.744E3,8.261E3,7.03E3,6.005E3,5.147E3,4.427E3,3.82E3, - * 3.307E3,2.872E3/ - DATA Y4(1),Y4(2),Y4(3),Y4(4),Y4(5),Y4(6),Y4(7),Y4(8),Y4(9), - * Y4(10),Y4(11),Y4(12),Y4(13),Y4(14),Y4(15),Y4(16),Y4(17), - * Y4(18),Y4(19),Y4(20),Y4(21),Y4(22),Y4(23),Y4(24),Y4(25), - * Y4(26),Y4(27),Y4(28),Y4(29),Y4(30),Y4(31),Y4(32),Y4(33) - * /8.44E-1,9.08E-1,9.32E-1,9.36E-1,9.25E-1,9.08E-1,8.81E-1, - * 8.5E-1,8.18E-1,7.84E-1,7.51E-1,7.18E-1,6.85E-1,6.58E-1, - * 6.28E-1,6.03E-1,5.8E-1,5.58E-1,5.38E-1,5.22E-1,5.06E-1, - * 4.9E-1,4.78E-1,4.67E-1,4.57E-1,4.48E-1,4.38E-1,4.31E-1, - * 4.24E-1,4.2E-1,4.14E-1,4.11E-1,4.06E-1/ - DATA Y5(1),Y5(2),Y5(3),Y5(4),Y5(5),Y5(6),Y5(7),Y5(8),Y5(9), - * Y5(10),Y5(11),Y5(12),Y5(13),Y5(14),Y5(15),Y5(16),Y5(17), - * Y5(18),Y5(19),Y5(20),Y5(21),Y5(22),Y5(23),Y5(24),Y5(25), - * Y5(26),Y5(27),Y5(28),Y5(29),Y5(30),Y5(31),Y5(32),Y5(33), - * Y5(34),Y5(35),Y5(36),Y5(37),Y5(38),Y5(39),Y5(40),Y5(41), - * Y5(42),Y5(43),Y5(44),Y5(45),Y5(46),Y5(47),Y5(48),Y5(49), - * Y5(50),Y5(51),Y5(52),Y5(53),Y5(54),Y5(55),Y5(56),Y5(57), - * Y5(58),Y5(59),Y5(60),Y5(61),Y5(62),Y5(63),Y5(64),Y5(65) - * /1.366E0,1.191E0,1.112E0,1.013E0,9.91E-1,8.85E-1,8.31E-1, - * 8.47E-1,7.86E-1,7.25E-1,7.46E-1,6.79E-1,6.08E-1,6.55E-1, - * 6.16E-1,6.06E-1,6.02E-1,6.26E-1,6.51E-1,7.24E-1,6.49E-1, - * 6.49E-1,6.94E-1,6.44E-1,6.24E-1,6.61E-1,6.12E-1,5.58E-1, - * 5.33E-1,4.95E-1,5.0E-1,4.23E-1,3.95E-1,3.75E-1,3.72E-1, - * 3.91E-1,3.96E-1,4.05E-1,4.28E-1,4.29E-1,5.23E-1,5.62E-1, - * 6.07E-1,6.53E-1,6.72E-1,7.08E-1,6.33E-1,6.68E-1,6.45E-1, - * 6.32E-1,5.91E-1,5.59E-1,5.97E-1,6.25E-1,7.39E-1,7.1E-1, - * 7.29E-1,7.2E-1,6.36E-1,5.81E-1,4.28E-1,2.92E-1,1.62E-1, - * 9.8E-2,5.4E-2/ - FLOAT(IVAR) = IVAR -C -C FUNCTION ROUTINE SELECTOR. -C - GO TO (10,40,70,110,120,130,140,150,170,190,210,250,270,290,310, - * 360,390,410), NPROB -C -C LINEAR FUNCTION - FULL RANK. -C - 10 CONTINUE - SUM = ZERO - DO 20 J = 1, N - SUM = SUM + X(J) - 20 CONTINUE - TEMP = TWO*SUM/FLOAT(M) + ONE - DO 30 I = 1, M - FVEC(I) = -TEMP - IF (I .LE. N) FVEC(I) = FVEC(I) + X(I) - 30 CONTINUE - GO TO 430 -C -C LINEAR FUNCTION - RANK 1. -C - 40 CONTINUE - SUM = ZERO - DO 50 J = 1, N - SUM = SUM + FLOAT(J)*X(J) - 50 CONTINUE - DO 60 I = 1, M - FVEC(I) = FLOAT(I)*SUM - ONE - 60 CONTINUE - GO TO 430 -C -C LINEAR FUNCTION - RANK 1 WITH ZERO COLUMNS AND ROWS. -C - 70 CONTINUE - SUM = ZERO - NM1 = N - 1 - IF (NM1 .LT. 2) GO TO 90 - DO 80 J = 2, NM1 - SUM = SUM + FLOAT(J)*X(J) - 80 CONTINUE - 90 CONTINUE - DO 100 I = 1, M - FVEC(I) = FLOAT(I-1)*SUM - ONE - 100 CONTINUE - FVEC(M) = -ONE - GO TO 430 -C -C ROSENBROCK FUNCTION. -C - 110 CONTINUE - FVEC(1) = TEN*(X(2) - X(1)**2) - FVEC(2) = ONE - X(1) - GO TO 430 -C -C HELICAL VALLEY FUNCTION. -C - 120 CONTINUE - TPI = EIGHT*ATAN(ONE) - TMP1 = SIGN(ZP25,X(2)) - IF (X(1) .GT. ZERO) TMP1 = ATAN(X(2)/X(1))/TPI - IF (X(1) .LT. ZERO) TMP1 = ATAN(X(2)/X(1))/TPI + ZP5 - TMP2 = SQRT(X(1)**2+X(2)**2) - FVEC(1) = TEN*(X(3) - TEN*TMP1) - FVEC(2) = TEN*(TMP2 - ONE) - FVEC(3) = X(3) - GO TO 430 -C -C POWELL SINGULAR FUNCTION. -C - 130 CONTINUE - FVEC(1) = X(1) + TEN*X(2) - FVEC(2) = SQRT(FIVE)*(X(3) - X(4)) - FVEC(3) = (X(2) - TWO*X(3))**2 - FVEC(4) = SQRT(TEN)*(X(1) - X(4))**2 - GO TO 430 -C -C FREUDENSTEIN AND ROTH FUNCTION. -C - 140 CONTINUE - FVEC(1) = -C13 + X(1) + ((FIVE - X(2))*X(2) - TWO)*X(2) - FVEC(2) = -C29 + X(1) + ((ONE + X(2))*X(2) - C14)*X(2) - GO TO 430 -C -C BARD FUNCTION. -C - 150 CONTINUE - DO 160 I = 1, 15 - TMP1 = FLOAT(I) - TMP2 = FLOAT(16-I) - TMP3 = TMP1 - IF (I .GT. 8) TMP3 = TMP2 - FVEC(I) = Y1(I) - (X(1) + TMP1/(X(2)*TMP2 + X(3)*TMP3)) - 160 CONTINUE - GO TO 430 -C -C KOWALIK AND OSBORNE FUNCTION. -C - 170 CONTINUE - DO 180 I = 1, 11 - TMP1 = V(I)*(V(I) + X(2)) - TMP2 = V(I)*(V(I) + X(3)) + X(4) - FVEC(I) = Y2(I) - X(1)*TMP1/TMP2 - 180 CONTINUE - GO TO 430 -C -C MEYER FUNCTION. -C - 190 CONTINUE - DO 200 I = 1, 16 - TEMP = FIVE*FLOAT(I) + C45 + X(3) - TMP1 = X(2)/TEMP - TMP2 = EXP(TMP1) - FVEC(I) = X(1)*TMP2 - Y3(I) - 200 CONTINUE - GO TO 430 -C -C WATSON FUNCTION. -C - 210 CONTINUE - DO 240 I = 1, 29 - DIV = FLOAT(I)/C29 - S1 = ZERO - DX = ONE - DO 220 J = 2, N - S1 = S1 + FLOAT(J-1)*DX*X(J) - DX = DIV*DX - 220 CONTINUE - S2 = ZERO - DX = ONE - DO 230 J = 1, N - S2 = S2 + DX*X(J) - DX = DIV*DX - 230 CONTINUE - FVEC(I) = S1 - S2**2 - ONE - 240 CONTINUE - FVEC(30) = X(1) - FVEC(31) = X(2) - X(1)**2 - ONE - GO TO 430 -C -C BOX 3-DIMENSIONAL FUNCTION. -C - 250 CONTINUE - DO 260 I = 1, M - TEMP = FLOAT(I) - TMP1 = TEMP/TEN - FVEC(I) = EXP(-TMP1*X(1)) - EXP(-TMP1*X(2)) - * + (EXP(-TEMP) - EXP(-TMP1))*X(3) - 260 CONTINUE - GO TO 430 -C -C JENNRICH AND SAMPSON FUNCTION. -C - 270 CONTINUE - DO 280 I = 1, M - TEMP = FLOAT(I) - FVEC(I) = TWO + TWO*TEMP - EXP(TEMP*X(1)) - EXP(TEMP*X(2)) - 280 CONTINUE - GO TO 430 -C -C BROWN AND DENNIS FUNCTION. -C - 290 CONTINUE - DO 300 I = 1, M - TEMP = FLOAT(I)/FIVE - TMP1 = X(1) + TEMP*X(2) - EXP(TEMP) - TMP2 = X(3) + SIN(TEMP)*X(4) - COS(TEMP) - FVEC(I) = TMP1**2 + TMP2**2 - 300 CONTINUE - GO TO 430 -C -C CHEBYQUAD FUNCTION. -C - 310 CONTINUE - DO 320 I = 1, M - FVEC(I) = ZERO - 320 CONTINUE - DO 340 J = 1, N - TMP1 = ONE - TMP2 = TWO*X(J) - ONE - TEMP = TWO*TMP2 - DO 330 I = 1, M - FVEC(I) = FVEC(I) + TMP2 - TI = TEMP*TMP2 - TMP1 - TMP1 = TMP2 - TMP2 = TI - 330 CONTINUE - 340 CONTINUE - DX = ONE/FLOAT(N) - IEV = -1 - DO 350 I = 1, M - FVEC(I) = DX*FVEC(I) - IF (IEV .GT. 0) FVEC(I) = FVEC(I) + ONE/(FLOAT(I)**2 - ONE) - IEV = -IEV - 350 CONTINUE - GO TO 430 -C -C BROWN ALMOST-LINEAR FUNCTION. -C - 360 CONTINUE - SUM = -FLOAT(N+1) - PROD = ONE - DO 370 J = 1, N - SUM = SUM + X(J) - PROD = X(J)*PROD - 370 CONTINUE - DO 380 I = 1, N - FVEC(I) = X(I) + SUM - 380 CONTINUE - FVEC(N) = PROD - ONE - GO TO 430 -C -C OSBORNE 1 FUNCTION. -C - 390 CONTINUE - DO 400 I = 1, 33 - TEMP = TEN*FLOAT(I-1) - TMP1 = EXP(-X(4)*TEMP) - TMP2 = EXP(-X(5)*TEMP) - FVEC(I) = Y4(I) - (X(1) + X(2)*TMP1 + X(3)*TMP2) - 400 CONTINUE - GO TO 430 -C -C OSBORNE 2 FUNCTION. -C - 410 CONTINUE - DO 420 I = 1, 65 - TEMP = FLOAT(I-1)/TEN - TMP1 = EXP(-X(5)*TEMP) - TMP2 = EXP(-X(6)*(TEMP-X(9))**2) - TMP3 = EXP(-X(7)*(TEMP-X(10))**2) - TMP4 = EXP(-X(8)*(TEMP-X(11))**2) - FVEC(I) = Y5(I) - * - (X(1)*TMP1 + X(2)*TMP2 + X(3)*TMP3 + X(4)*TMP4) - 420 CONTINUE - 430 CONTINUE - RETURN -C -C LAST CARD OF SUBROUTINE SSQFCN. -C - END - SUBROUTINE INITPT(N,X,NPROB,FACTOR) - INTEGER N,NPROB - REAL FACTOR - REAL X(N) -C ********** -C -C SUBROUTINE INITPT -C -C THIS SUBROUTINE SPECIFIES THE STANDARD STARTING POINTS FOR THE -C FUNCTIONS DEFINED BY SUBROUTINE SSQFCN. THE SUBROUTINE RETURNS -C IN X A MULTIPLE (FACTOR) OF THE STANDARD STARTING POINT. FOR -C THE 11TH FUNCTION THE STANDARD STARTING POINT IS ZERO, SO IN -C THIS CASE, IF FACTOR IS NOT UNITY, THEN THE SUBROUTINE RETURNS -C THE VECTOR X(J) = FACTOR, J=1,...,N. -C -C THE SUBROUTINE STATEMENT IS -C -C SUBROUTINE INITPT(N,X,NPROB,FACTOR) -C -C WHERE -C -C N IS A POSITIVE INTEGER INPUT VARIABLE. -C -C X IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE STANDARD -C STARTING POINT FOR PROBLEM NPROB MULTIPLIED BY FACTOR. -C -C NPROB IS A POSITIVE INTEGER INPUT VARIABLE WHICH DEFINES THE -C NUMBER OF THE PROBLEM. NPROB MUST NOT EXCEED 18. -C -C FACTOR IS AN INPUT VARIABLE WHICH SPECIFIES THE MULTIPLE OF -C THE STANDARD STARTING POINT. IF FACTOR IS UNITY, NO -C MULTIPLICATION IS PERFORMED. -C -C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. -C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE -C -C ********** - INTEGER IVAR,J - REAL C1,C2,C3,C4,C5,C6,C7,C8,C9,C10,C11,C12,C13,C14,C15,C16,C17, - * FIVE,H,HALF,ONE,SEVEN,TEN,THREE,TWENTY,TWNTF,TWO,ZERO - REAL FLOAT - DATA ZERO,HALF,ONE,TWO,THREE,FIVE,SEVEN,TEN,TWENTY,TWNTF - * /0.0E0,5.0E-1,1.0E0,2.0E0,3.0E0,5.0E0,7.0E0,1.0E1,2.0E1, - * 2.5E1/ - DATA C1,C2,C3,C4,C5,C6,C7,C8,C9,C10,C11,C12,C13,C14,C15,C16,C17 - * /1.2E0,2.5E-1,3.9E-1,4.15E-1,2.0E-2,4.0E3,2.5E2,3.0E-1, - * 4.0E-1,1.5E0,1.0E-2,1.3E0,6.5E-1,7.0E-1,6.0E-1,4.5E0, - * 5.5E0/ - FLOAT(IVAR) = IVAR -C -C SELECTION OF INITIAL POINT. -C - GO TO (10,10,10,30,40,50,60,70,80,90,100,120,130,140,150,170, - * 190,200), NPROB -C -C LINEAR FUNCTION - FULL RANK OR RANK 1. -C - 10 CONTINUE - DO 20 J = 1, N - X(J) = ONE - 20 CONTINUE - GO TO 210 -C -C ROSENBROCK FUNCTION. -C - 30 CONTINUE - X(1) = -C1 - X(2) = ONE - GO TO 210 -C -C HELICAL VALLEY FUNCTION. -C - 40 CONTINUE - X(1) = -ONE - X(2) = ZERO - X(3) = ZERO - GO TO 210 -C -C POWELL SINGULAR FUNCTION. -C - 50 CONTINUE - X(1) = THREE - X(2) = -ONE - X(3) = ZERO - X(4) = ONE - GO TO 210 -C -C FREUDENSTEIN AND ROTH FUNCTION. -C - 60 CONTINUE - X(1) = HALF - X(2) = -TWO - GO TO 210 -C -C BARD FUNCTION. -C - 70 CONTINUE - X(1) = ONE - X(2) = ONE - X(3) = ONE - GO TO 210 -C -C KOWALIK AND OSBORNE FUNCTION. -C - 80 CONTINUE - X(1) = C2 - X(2) = C3 - X(3) = C4 - X(4) = C3 - GO TO 210 -C -C MEYER FUNCTION. -C - 90 CONTINUE - X(1) = C5 - X(2) = C6 - X(3) = C7 - GO TO 210 -C -C WATSON FUNCTION. -C - 100 CONTINUE - DO 110 J = 1, N - X(J) = ZERO - 110 CONTINUE - GO TO 210 -C -C BOX 3-DIMENSIONAL FUNCTION. -C - 120 CONTINUE - X(1) = ZERO - X(2) = TEN - X(3) = TWENTY - GO TO 210 -C -C JENNRICH AND SAMPSON FUNCTION. -C - 130 CONTINUE - X(1) = C8 - X(2) = C9 - GO TO 210 -C -C BROWN AND DENNIS FUNCTION. -C - 140 CONTINUE - X(1) = TWNTF - X(2) = FIVE - X(3) = -FIVE - X(4) = -ONE - GO TO 210 -C -C CHEBYQUAD FUNCTION. -C - 150 CONTINUE - H = ONE/FLOAT(N+1) - DO 160 J = 1, N - X(J) = FLOAT(J)*H - 160 CONTINUE - GO TO 210 -C -C BROWN ALMOST-LINEAR FUNCTION. -C - 170 CONTINUE - DO 180 J = 1, N - X(J) = HALF - 180 CONTINUE - GO TO 210 -C -C OSBORNE 1 FUNCTION. -C - 190 CONTINUE - X(1) = HALF - X(2) = C10 - X(3) = -ONE - X(4) = C11 - X(5) = C5 - GO TO 210 -C -C OSBORNE 2 FUNCTION. -C - 200 CONTINUE - X(1) = C12 - X(2) = C13 - X(3) = C13 - X(4) = C14 - X(5) = C15 - X(6) = THREE - X(7) = FIVE - X(8) = SEVEN - X(9) = TWO - X(10) = C16 - X(11) = C17 - 210 CONTINUE -C -C COMPUTE MULTIPLE OF INITIAL POINT. -C - IF (FACTOR .EQ. ONE) GO TO 260 - IF (NPROB .EQ. 11) GO TO 230 - DO 220 J = 1, N - X(J) = FACTOR*X(J) - 220 CONTINUE - GO TO 250 - 230 CONTINUE - DO 240 J = 1, N - X(J) = FACTOR - 240 CONTINUE - 250 CONTINUE - 260 CONTINUE - RETURN -C -C LAST CARD OF SUBROUTINE INITPT. -C - END diff --git a/ex/file13 b/ex/file13 deleted file mode 100644 index d299bb3..0000000 --- a/ex/file13 +++ /dev/null @@ -1,858 +0,0 @@ -C ********** -C -C THIS PROGRAM TESTS THE ABILITY OF CHKDER TO DETECT -C INCONSISTENCIES BETWEEN FUNCTIONS AND THEIR FIRST DERIVATIVES. -C FOURTEEN TEST FUNCTION VECTORS AND JACOBIANS ARE USED. ELEVEN OF -C THE TESTS ARE FALSE(F), I.E. THERE ARE INCONSISTENCIES BETWEEN -C THE FUNCTION VECTORS AND THE CORRESPONDING JACOBIANS. THREE OF -C THE TESTS ARE TRUE(T), I.E. THERE ARE NO INCONSISTENCIES. THE -C DRIVER READS IN DATA, CALLS CHKDER AND PRINTS OUT INFORMATION -C REQUIRED BY AND RECEIVED FROM CHKDER. -C -C SUBPROGRAMS CALLED -C -C MINPACK SUPPLIED ... CHKDER,ERRJAC,INITPT,VECFCN -C -C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. -C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE -C -C ********** - INTEGER I,LDFJAC,LNP,MODE,N,NPROB,NREAD,NWRITE - INTEGER NA(14),NP(14) - LOGICAL A(14) - REAL CP,ONE - REAL DIFF(10),ERR(10),ERRMAX(14),ERRMIN(14),FJAC(10,10), - * FVEC1(10),FVEC2(10),X1(10),X2(10) -C -C LOGICAL INPUT UNIT IS ASSUMED TO BE NUMBER 5. -C LOGICAL OUTPUT UNIT IS ASSUMED TO BE NUMBER 6. -C - DATA NREAD,NWRITE /5,6/ -C - DATA A(1),A(2),A(3),A(4),A(5),A(6),A(7),A(8),A(9),A(10),A(11), - * A(12),A(13),A(14) - * /.FALSE.,.FALSE.,.FALSE.,.TRUE.,.FALSE.,.FALSE.,.FALSE., - * .TRUE.,.FALSE.,.FALSE.,.FALSE.,.FALSE.,.TRUE.,.FALSE./ - DATA CP,ONE /1.23E-1,1.0E0/ - LDFJAC = 10 - 10 CONTINUE - READ (NREAD,60) NPROB,N - IF (NPROB .LE. 0) GO TO 40 - CALL INITPT(N,X1,NPROB,ONE) - DO 20 I = 1, N - X1(I) = X1(I) + CP - CP = -CP - 20 CONTINUE - WRITE (NWRITE,70) NPROB,N,A(NPROB) - MODE = 1 - CALL CHKDER(N,N,X1,FVEC1,FJAC,LDFJAC,X2,FVEC2,MODE,ERR) - MODE = 2 - CALL VECFCN(N,X1,FVEC1,NPROB) - CALL ERRJAC(N,X1,FJAC,LDFJAC,NPROB) - CALL VECFCN(N,X2,FVEC2,NPROB) - CALL CHKDER(N,N,X1,FVEC1,FJAC,LDFJAC,X2,FVEC2,MODE,ERR) - ERRMIN(NPROB) = ERR(1) - ERRMAX(NPROB) = ERR(1) - DO 30 I = 1, N - DIFF(I) = FVEC2(I) - FVEC1(I) - IF (ERRMIN(NPROB) .GT. ERR(I)) ERRMIN(NPROB) = ERR(I) - IF (ERRMAX(NPROB) .LT. ERR(I)) ERRMAX(NPROB) = ERR(I) - 30 CONTINUE - NP(NPROB) = NPROB - LNP = NPROB - NA(NPROB) = N - WRITE (NWRITE,80) (FVEC1(I), I = 1, N) - WRITE (NWRITE,90) (DIFF(I), I = 1, N) - WRITE (NWRITE,100) (ERR(I), I = 1, N) - GO TO 10 - 40 CONTINUE - WRITE (NWRITE,110) LNP - WRITE (NWRITE,120) - DO 50 I = 1, LNP - WRITE (NWRITE,130) NP(I),NA(I),A(I),ERRMIN(I),ERRMAX(I) - 50 CONTINUE - STOP - 60 FORMAT (2I5) - 70 FORMAT ( /// 5X, 8H PROBLEM, I5, 5X, 15H WITH DIMENSION, I5, 2X, - * 5H IS , L1) - 80 FORMAT ( // 5X, 25H FIRST FUNCTION VECTOR // (5X, 5E15.7)) - 90 FORMAT ( // 5X, 27H FUNCTION DIFFERENCE VECTOR // (5X, 5E15.7)) - 100 FORMAT ( // 5X, 13H ERROR VECTOR // (5X, 5E15.7)) - 110 FORMAT (12H1SUMMARY OF , I3, 16H TESTS OF CHKDER /) - 120 FORMAT (46H NPROB N STATUS ERRMIN ERRMAX /) - 130 FORMAT (I4, I6, 6X, L1, 3X, 2E15.7) -C -C LAST CARD OF DERIVATIVE CHECK TEST DRIVER. -C - END - SUBROUTINE ERRJAC(N,X,FJAC,LDFJAC,NPROB) - INTEGER N,LDFJAC,NPROB - REAL X(N),FJAC(LDFJAC,N) -C ********** -C -C SUBROUTINE ERRJAC -C -C THIS SUBROUTINE IS DERIVED FROM VECJAC WHICH DEFINES THE -C JACOBIAN MATRICES OF FOURTEEN TEST FUNCTIONS. THE PROBLEM -C DIMENSIONS ARE AS DESCRIBED IN THE PROLOGUE COMMENTS OF VECFCN. -C VARIOUS ERRORS ARE DELIBERATELY INTRODUCED TO PROVIDE A TEST -C FOR CHKDER. -C -C THE SUBROUTINE STATEMENT IS -C -C SUBROUTINE ERRJAC(N,X,FJAC,LDFJAC,NPROB) -C -C WHERE -C -C N IS A POSITIVE INTEGER VARIABLE. -C -C X IS AN ARRAY OF LENGTH N. -C -C FJAC IS AN N BY N ARRAY. ON OUTPUT FJAC CONTAINS THE -C JACOBIAN MATRIX, WITH VARIOUS ERRORS DELIBERATELY -C INTRODUCED, OF THE NPROB FUNCTION EVALUATED AT X. -C -C LDFJAC IS A POSITIVE INTEGER VARIABLE NOT LESS THAN N -C WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY FJAC. -C -C NPROB IS A POSITIVE INTEGER VARIABLE WHICH DEFINES THE -C NUMBER OF THE PROBLEM. NPROB MUST NOT EXCEED 14. -C -C SUBPROGRAMS CALLED -C -C FORTRAN-SUPPLIED ... ATAN,COS,EXP,AMIN1,SIN,SQRT, -C MAX0,MIN0 -C -C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. -C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE -C -C ********** - INTEGER I,IVAR,J,K,K1,K2,ML,MU - REAL C1,C3,C4,C5,C6,C9,EIGHT,FIFTN,FIVE,FOUR,H,HUNDRD,ONE,PROD, - * SIX,SUM,SUM1,SUM2,TEMP,TEMP1,TEMP2,TEMP3,TEMP4,TEN,THREE, - * TI,TJ,TK,TPI,TWENTY,TWO,ZERO - REAL FLOAT - DATA ZERO,ONE,TWO,THREE,FOUR,FIVE,SIX,EIGHT,TEN,FIFTN,TWENTY, - * HUNDRD - * /0.0E0,1.0E0,2.0E0,3.0E0,4.0E0,5.0E0,6.0E0,8.0E0,1.0E1, - * 1.5E1,2.0E1,1.0E2/ - DATA C1,C3,C4,C5,C6,C9 /1.0E4,2.0E2,2.02E1,1.98E1,1.8E2,2.9E1/ - FLOAT(IVAR) = IVAR -C -C JACOBIAN ROUTINE SELECTOR. -C - GO TO (10,20,50,60,90,100,200,230,290,320,350,380,420,450), - * NPROB -C -C ROSENBROCK FUNCTION WITH SIGN REVERSAL AFFECTING ELEMENT (1,1). -C - 10 CONTINUE - FJAC(1,1) = ONE - FJAC(1,2) = ZERO - FJAC(2,1) = -TWENTY*X(1) - FJAC(2,2) = TEN - GO TO 490 -C -C POWELL SINGULAR FUNCTION WITH SIGN REVERSAL AFFECTING ELEMENT -C (3,3). -C - 20 CONTINUE - DO 40 K = 1, 4 - DO 30 J = 1, 4 - FJAC(K,J) = ZERO - 30 CONTINUE - 40 CONTINUE - FJAC(1,1) = ONE - FJAC(1,2) = TEN - FJAC(2,3) = SQRT(FIVE) - FJAC(2,4) = -FJAC(2,3) - FJAC(3,2) = TWO*(X(2) - TWO*X(3)) - FJAC(3,3) = TWO*FJAC(3,2) - FJAC(4,1) = TWO*SQRT(TEN)*(X(1) - X(4)) - FJAC(4,4) = -FJAC(4,1) - GO TO 490 -C -C POWELL BADLY SCALED FUNCTION WITH THE SIGN OF THE JACOBIAN -C REVERSED. -C - 50 CONTINUE - FJAC(1,1) = -C1*X(2) - FJAC(1,2) = -C1*X(1) - FJAC(2,1) = EXP(-X(1)) - FJAC(2,2) = EXP(-X(2)) - GO TO 490 -C -C WOOD FUNCTION WITHOUT ERROR. -C - 60 CONTINUE - DO 80 K = 1, 4 - DO 70 J = 1, 4 - FJAC(K,J) = ZERO - 70 CONTINUE - 80 CONTINUE - TEMP1 = X(2) - THREE*X(1)**2 - TEMP2 = X(4) - THREE*X(3)**2 - FJAC(1,1) = -C3*TEMP1 + ONE - FJAC(1,2) = -C3*X(1) - FJAC(2,1) = -TWO*C3*X(1) - FJAC(2,2) = C3 + C4 - FJAC(2,4) = C5 - FJAC(3,3) = -C6*TEMP2 + ONE - FJAC(3,4) = -C6*X(3) - FJAC(4,2) = C5 - FJAC(4,3) = -TWO*C6*X(3) - FJAC(4,4) = C6 + C4 - GO TO 490 -C -C HELICAL VALLEY FUNCTION WITH MULTIPLICATIVE ERROR AFFECTING -C ELEMENTS (2,1) AND (2,2). -C - 90 CONTINUE - TPI = EIGHT*ATAN(ONE) - TEMP = X(1)**2 + X(2)**2 - TEMP1 = TPI*TEMP - TEMP2 = SQRT(TEMP) - FJAC(1,1) = HUNDRD*X(2)/TEMP1 - FJAC(1,2) = -HUNDRD*X(1)/TEMP1 - FJAC(1,3) = TEN - FJAC(2,1) = FIVE*X(1)/TEMP2 - FJAC(2,2) = FIVE*X(2)/TEMP2 - FJAC(2,3) = ZERO - FJAC(3,1) = ZERO - FJAC(3,2) = ZERO - FJAC(3,3) = ONE - GO TO 490 -C -C WATSON FUNCTION WITH SIGN REVERSALS AFFECTING THE COMPUTATION OF -C TEMP1. -C - 100 CONTINUE - DO 120 K = 1, N - DO 110 J = K, N - FJAC(K,J) = ZERO - 110 CONTINUE - 120 CONTINUE - DO 170 I = 1, 29 - TI = FLOAT(I)/C9 - SUM1 = ZERO - TEMP = ONE - DO 130 J = 2, N - SUM1 = SUM1 + FLOAT(J-1)*TEMP*X(J) - TEMP = TI*TEMP - 130 CONTINUE - SUM2 = ZERO - TEMP = ONE - DO 140 J = 1, N - SUM2 = SUM2 + TEMP*X(J) - TEMP = TI*TEMP - 140 CONTINUE - TEMP1 = TWO*(SUM1 + SUM2**2 + ONE) - TEMP2 = TWO*SUM2 - TEMP = TI**2 - TK = ONE - DO 160 K = 1, N - TJ = TK - DO 150 J = K, N - FJAC(K,J) = FJAC(K,J) - * + TJ - * *((FLOAT(K-1)/TI - TEMP2) - * *(FLOAT(J-1)/TI - TEMP2) - TEMP1) - TJ = TI*TJ - 150 CONTINUE - TK = TEMP*TK - 160 CONTINUE - 170 CONTINUE - FJAC(1,1) = FJAC(1,1) + SIX*X(1)**2 - TWO*X(2) + THREE - FJAC(1,2) = FJAC(1,2) - TWO*X(1) - FJAC(2,2) = FJAC(2,2) + ONE - DO 190 K = 1, N - DO 180 J = K, N - FJAC(J,K) = FJAC(K,J) - 180 CONTINUE - 190 CONTINUE - GO TO 490 -C -C CHEBYQUAD FUNCTION WITH JACOBIAN TWICE CORRECT SIZE. -C - 200 CONTINUE - TK = ONE/FLOAT(N) - DO 220 J = 1, N - TEMP1 = ONE - TEMP2 = TWO*X(J) - ONE - TEMP = TWO*TEMP2 - TEMP3 = ZERO - TEMP4 = TWO - DO 210 K = 1, N - FJAC(K,J) = TWO*TK*TEMP4 - TI = FOUR*TEMP2 + TEMP*TEMP4 - TEMP3 - TEMP3 = TEMP4 - TEMP4 = TI - TI = TEMP*TEMP2 - TEMP1 - TEMP1 = TEMP2 - TEMP2 = TI - 210 CONTINUE - 220 CONTINUE - GO TO 490 -C -C BROWN ALMOST-LINEAR FUNCTION WITHOUT ERROR. -C - 230 CONTINUE - PROD = ONE - DO 250 J = 1, N - PROD = X(J)*PROD - DO 240 K = 1, N - FJAC(K,J) = ONE - 240 CONTINUE - FJAC(J,J) = TWO - 250 CONTINUE - DO 280 J = 1, N - TEMP = X(J) - IF (TEMP .NE. ZERO) GO TO 270 - TEMP = ONE - PROD = ONE - DO 260 K = 1, N - IF (K .NE. J) PROD = X(K)*PROD - 260 CONTINUE - 270 CONTINUE - FJAC(N,J) = PROD/TEMP - 280 CONTINUE - GO TO 490 -C -C DISCRETE BOUNDARY VALUE FUNCTION WITH MULTIPLICATIVE ERROR -C AFFECTING THE JACOBIAN DIAGONAL. -C - 290 CONTINUE - H = ONE/FLOAT(N+1) - DO 310 K = 1, N - TEMP = THREE*(X(K) + FLOAT(K)*H + ONE)**2 - DO 300 J = 1, N - FJAC(K,J) = ZERO - 300 CONTINUE - FJAC(K,K) = FOUR + TEMP*H**2 - IF (K .NE. 1) FJAC(K,K-1) = -ONE - IF (K .NE. N) FJAC(K,K+1) = -ONE - 310 CONTINUE - GO TO 490 -C -C DISCRETE INTEGRAL EQUATION FUNCTION WITH SIGN ERROR AFFECTING -C THE JACOBIAN DIAGONAL. -C - 320 CONTINUE - H = ONE/FLOAT(N+1) - DO 340 K = 1, N - TK = FLOAT(K)*H - DO 330 J = 1, N - TJ = FLOAT(J)*H - TEMP = THREE*(X(J) + TJ + ONE)**2 - FJAC(K,J) = H*AMIN1(TJ*(ONE-TK),TK*(ONE-TJ))*TEMP/TWO - 330 CONTINUE - FJAC(K,K) = FJAC(K,K) - ONE - 340 CONTINUE - GO TO 490 -C -C TRIGONOMETRIC FUNCTION WITH SIGN ERRORS AFFECTING THE -C OFFDIAGONAL ELEMENTS OF THE JACOBIAN. -C - 350 CONTINUE - DO 370 J = 1, N - TEMP = SIN(X(J)) - DO 360 K = 1, N - FJAC(K,J) = -TEMP - 360 CONTINUE - FJAC(J,J) = FLOAT(J+1)*TEMP - COS(X(J)) - 370 CONTINUE - GO TO 490 -C -C VARIABLY DIMENSIONED FUNCTION WITH OPERATION ERROR AFFECTING -C THE UPPER TRIANGULAR ELEMENTS OF THE JACOBIAN. -C - 380 CONTINUE - SUM = ZERO - DO 390 J = 1, N - SUM = SUM + FLOAT(J)*(X(J) - ONE) - 390 CONTINUE - TEMP = ONE + SIX*SUM**2 - DO 410 K = 1, N - DO 400 J = K, N - FJAC(K,J) = FLOAT(K*J)/TEMP - FJAC(J,K) = FJAC(K,J) - 400 CONTINUE - FJAC(K,K) = FJAC(K,K) + ONE - 410 CONTINUE - GO TO 490 -C -C BROYDEN TRIDIAGONAL FUNCTION WITHOUT ERROR. -C - 420 CONTINUE - DO 440 K = 1, N - DO 430 J = 1, N - FJAC(K,J) = ZERO - 430 CONTINUE - FJAC(K,K) = THREE - FOUR*X(K) - IF (K .NE. 1) FJAC(K,K-1) = -ONE - IF (K .NE. N) FJAC(K,K+1) = -TWO - 440 CONTINUE - GO TO 490 -C -C BROYDEN BANDED FUNCTION WITH SIGN ERROR AFFECTING THE JACOBIAN -C DIAGONAL. -C - 450 CONTINUE - ML = 5 - MU = 1 - DO 480 K = 1, N - DO 460 J = 1, N - FJAC(K,J) = ZERO - 460 CONTINUE - K1 = MAX0(1,K-ML) - K2 = MIN0(K+MU,N) - DO 470 J = K1, K2 - IF (J .NE. K) FJAC(K,J) = -(ONE + TWO*X(J)) - 470 CONTINUE - FJAC(K,K) = TWO - FIFTN*X(K)**2 - 480 CONTINUE - 490 CONTINUE - RETURN -C -C LAST CARD OF SUBROUTINE ERRJAC. -C - END - SUBROUTINE INITPT(N,X,NPROB,FACTOR) - INTEGER N,NPROB - REAL FACTOR - REAL X(N) -C ********** -C -C SUBROUTINE INITPT -C -C THIS SUBROUTINE SPECIFIES THE STANDARD STARTING POINTS FOR -C THE FUNCTIONS DEFINED BY SUBROUTINE VECFCN. THE SUBROUTINE -C RETURNS IN X A MULTIPLE (FACTOR) OF THE STANDARD STARTING -C POINT. FOR THE SIXTH FUNCTION THE STANDARD STARTING POINT IS -C ZERO, SO IN THIS CASE, IF FACTOR IS NOT UNITY, THEN THE -C SUBROUTINE RETURNS THE VECTOR X(J) = FACTOR, J=1,...,N. -C -C THE SUBROUTINE STATEMENT IS -C -C SUBROUTINE INITPT(N,X,NPROB,FACTOR) -C -C WHERE -C -C N IS A POSITIVE INTEGER INPUT VARIABLE. -C -C X IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE STANDARD -C STARTING POINT FOR PROBLEM NPROB MULTIPLIED BY FACTOR. -C -C NPROB IS A POSITIVE INTEGER INPUT VARIABLE WHICH DEFINES THE -C NUMBER OF THE PROBLEM. NPROB MUST NOT EXCEED 14. -C -C FACTOR IS AN INPUT VARIABLE WHICH SPECIFIES THE MULTIPLE OF -C THE STANDARD STARTING POINT. IF FACTOR IS UNITY, NO -C MULTIPLICATION IS PERFORMED. -C -C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. -C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE -C -C ********** - INTEGER IVAR,J - REAL C1,H,HALF,ONE,THREE,TJ,ZERO - REAL FLOAT - DATA ZERO,HALF,ONE,THREE,C1 /0.0E0,5.0E-1,1.0E0,3.0E0,1.2E0/ - FLOAT(IVAR) = IVAR -C -C SELECTION OF INITIAL POINT. -C - GO TO (10,20,30,40,50,60,80,100,120,120,140,160,180,180), NPROB -C -C ROSENBROCK FUNCTION. -C - 10 CONTINUE - X(1) = -C1 - X(2) = ONE - GO TO 200 -C -C POWELL SINGULAR FUNCTION. -C - 20 CONTINUE - X(1) = THREE - X(2) = -ONE - X(3) = ZERO - X(4) = ONE - GO TO 200 -C -C POWELL BADLY SCALED FUNCTION. -C - 30 CONTINUE - X(1) = ZERO - X(2) = ONE - GO TO 200 -C -C WOOD FUNCTION. -C - 40 CONTINUE - X(1) = -THREE - X(2) = -ONE - X(3) = -THREE - X(4) = -ONE - GO TO 200 -C -C HELICAL VALLEY FUNCTION. -C - 50 CONTINUE - X(1) = -ONE - X(2) = ZERO - X(3) = ZERO - GO TO 200 -C -C WATSON FUNCTION. -C - 60 CONTINUE - DO 70 J = 1, N - X(J) = ZERO - 70 CONTINUE - GO TO 200 -C -C CHEBYQUAD FUNCTION. -C - 80 CONTINUE - H = ONE/FLOAT(N+1) - DO 90 J = 1, N - X(J) = FLOAT(J)*H - 90 CONTINUE - GO TO 200 -C -C BROWN ALMOST-LINEAR FUNCTION. -C - 100 CONTINUE - DO 110 J = 1, N - X(J) = HALF - 110 CONTINUE - GO TO 200 -C -C DISCRETE BOUNDARY VALUE AND INTEGRAL EQUATION FUNCTIONS. -C - 120 CONTINUE - H = ONE/FLOAT(N+1) - DO 130 J = 1, N - TJ = FLOAT(J)*H - X(J) = TJ*(TJ - ONE) - 130 CONTINUE - GO TO 200 -C -C TRIGONOMETRIC FUNCTION. -C - 140 CONTINUE - H = ONE/FLOAT(N) - DO 150 J = 1, N - X(J) = H - 150 CONTINUE - GO TO 200 -C -C VARIABLY DIMENSIONED FUNCTION. -C - 160 CONTINUE - H = ONE/FLOAT(N) - DO 170 J = 1, N - X(J) = ONE - FLOAT(J)*H - 170 CONTINUE - GO TO 200 -C -C BROYDEN TRIDIAGONAL AND BANDED FUNCTIONS. -C - 180 CONTINUE - DO 190 J = 1, N - X(J) = -ONE - 190 CONTINUE - 200 CONTINUE -C -C COMPUTE MULTIPLE OF INITIAL POINT. -C - IF (FACTOR .EQ. ONE) GO TO 250 - IF (NPROB .EQ. 6) GO TO 220 - DO 210 J = 1, N - X(J) = FACTOR*X(J) - 210 CONTINUE - GO TO 240 - 220 CONTINUE - DO 230 J = 1, N - X(J) = FACTOR - 230 CONTINUE - 240 CONTINUE - 250 CONTINUE - RETURN -C -C LAST CARD OF SUBROUTINE INITPT. -C - END - SUBROUTINE VECFCN(N,X,FVEC,NPROB) - INTEGER N,NPROB - REAL X(N),FVEC(N) -C ********** -C -C SUBROUTINE VECFCN -C -C THIS SUBROUTINE DEFINES FOURTEEN TEST FUNCTIONS. THE FIRST -C FIVE TEST FUNCTIONS ARE OF DIMENSIONS 2,4,2,4,3, RESPECTIVELY, -C WHILE THE REMAINING TEST FUNCTIONS ARE OF VARIABLE DIMENSION -C N FOR ANY N GREATER THAN OR EQUAL TO 1 (PROBLEM 6 IS AN -C EXCEPTION TO THIS, SINCE IT DOES NOT ALLOW N = 1). -C -C THE SUBROUTINE STATEMENT IS -C -C SUBROUTINE VECFCN(N,X,FVEC,NPROB) -C -C WHERE -C -C N IS A POSITIVE INTEGER INPUT VARIABLE. -C -C X IS AN INPUT ARRAY OF LENGTH N. -C -C FVEC IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE NPROB -C FUNCTION VECTOR EVALUATED AT X. -C -C NPROB IS A POSITIVE INTEGER INPUT VARIABLE WHICH DEFINES THE -C NUMBER OF THE PROBLEM. NPROB MUST NOT EXCEED 14. -C -C SUBPROGRAMS CALLED -C -C FORTRAN-SUPPLIED ... ATAN,COS,EXP,SIGN,SIN,SQRT, -C MAX0,MIN0 -C -C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. -C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE -C -C ********** - INTEGER I,IEV,IVAR,J,K,K1,K2,KP1,ML,MU - REAL C1,C2,C3,C4,C5,C6,C7,C8,C9,EIGHT,FIVE,H,ONE,PROD,SUM,SUM1, - * SUM2,TEMP,TEMP1,TEMP2,TEN,THREE,TI,TJ,TK,TPI,TWO,ZERO - REAL FLOAT - DATA ZERO,ONE,TWO,THREE,FIVE,EIGHT,TEN - * /0.0E0,1.0E0,2.0E0,3.0E0,5.0E0,8.0E0,1.0E1/ - DATA C1,C2,C3,C4,C5,C6,C7,C8,C9 - * /1.0E4,1.0001E0,2.0E2,2.02E1,1.98E1,1.8E2,2.5E-1,5.0E-1, - * 2.9E1/ - FLOAT(IVAR) = IVAR -C -C PROBLEM SELECTOR. -C - GO TO (10,20,30,40,50,60,120,170,200,220,270,300,330,350), NPROB -C -C ROSENBROCK FUNCTION. -C - 10 CONTINUE - FVEC(1) = ONE - X(1) - FVEC(2) = TEN*(X(2) - X(1)**2) - GO TO 380 -C -C POWELL SINGULAR FUNCTION. -C - 20 CONTINUE - FVEC(1) = X(1) + TEN*X(2) - FVEC(2) = SQRT(FIVE)*(X(3) - X(4)) - FVEC(3) = (X(2) - TWO*X(3))**2 - FVEC(4) = SQRT(TEN)*(X(1) - X(4))**2 - GO TO 380 -C -C POWELL BADLY SCALED FUNCTION. -C - 30 CONTINUE - FVEC(1) = C1*X(1)*X(2) - ONE - FVEC(2) = EXP(-X(1)) + EXP(-X(2)) - C2 - GO TO 380 -C -C WOOD FUNCTION. -C - 40 CONTINUE - TEMP1 = X(2) - X(1)**2 - TEMP2 = X(4) - X(3)**2 - FVEC(1) = -C3*X(1)*TEMP1 - (ONE - X(1)) - FVEC(2) = C3*TEMP1 + C4*(X(2) - ONE) + C5*(X(4) - ONE) - FVEC(3) = -C6*X(3)*TEMP2 - (ONE - X(3)) - FVEC(4) = C6*TEMP2 + C4*(X(4) - ONE) + C5*(X(2) - ONE) - GO TO 380 -C -C HELICAL VALLEY FUNCTION. -C - 50 CONTINUE - TPI = EIGHT*ATAN(ONE) - TEMP1 = SIGN(C7,X(2)) - IF (X(1) .GT. ZERO) TEMP1 = ATAN(X(2)/X(1))/TPI - IF (X(1) .LT. ZERO) TEMP1 = ATAN(X(2)/X(1))/TPI + C8 - TEMP2 = SQRT(X(1)**2+X(2)**2) - FVEC(1) = TEN*(X(3) - TEN*TEMP1) - FVEC(2) = TEN*(TEMP2 - ONE) - FVEC(3) = X(3) - GO TO 380 -C -C WATSON FUNCTION. -C - 60 CONTINUE - DO 70 K = 1, N - FVEC(K) = ZERO - 70 CONTINUE - DO 110 I = 1, 29 - TI = FLOAT(I)/C9 - SUM1 = ZERO - TEMP = ONE - DO 80 J = 2, N - SUM1 = SUM1 + FLOAT(J-1)*TEMP*X(J) - TEMP = TI*TEMP - 80 CONTINUE - SUM2 = ZERO - TEMP = ONE - DO 90 J = 1, N - SUM2 = SUM2 + TEMP*X(J) - TEMP = TI*TEMP - 90 CONTINUE - TEMP1 = SUM1 - SUM2**2 - ONE - TEMP2 = TWO*TI*SUM2 - TEMP = ONE/TI - DO 100 K = 1, N - FVEC(K) = FVEC(K) + TEMP*(FLOAT(K-1) - TEMP2)*TEMP1 - TEMP = TI*TEMP - 100 CONTINUE - 110 CONTINUE - TEMP = X(2) - X(1)**2 - ONE - FVEC(1) = FVEC(1) + X(1)*(ONE - TWO*TEMP) - FVEC(2) = FVEC(2) + TEMP - GO TO 380 -C -C CHEBYQUAD FUNCTION. -C - 120 CONTINUE - DO 130 K = 1, N - FVEC(K) = ZERO - 130 CONTINUE - DO 150 J = 1, N - TEMP1 = ONE - TEMP2 = TWO*X(J) - ONE - TEMP = TWO*TEMP2 - DO 140 I = 1, N - FVEC(I) = FVEC(I) + TEMP2 - TI = TEMP*TEMP2 - TEMP1 - TEMP1 = TEMP2 - TEMP2 = TI - 140 CONTINUE - 150 CONTINUE - TK = ONE/FLOAT(N) - IEV = -1 - DO 160 K = 1, N - FVEC(K) = TK*FVEC(K) - IF (IEV .GT. 0) FVEC(K) = FVEC(K) + ONE/(FLOAT(K)**2 - ONE) - IEV = -IEV - 160 CONTINUE - GO TO 380 -C -C BROWN ALMOST-LINEAR FUNCTION. -C - 170 CONTINUE - SUM = -FLOAT(N+1) - PROD = ONE - DO 180 J = 1, N - SUM = SUM + X(J) - PROD = X(J)*PROD - 180 CONTINUE - DO 190 K = 1, N - FVEC(K) = X(K) + SUM - 190 CONTINUE - FVEC(N) = PROD - ONE - GO TO 380 -C -C DISCRETE BOUNDARY VALUE FUNCTION. -C - 200 CONTINUE - H = ONE/FLOAT(N+1) - DO 210 K = 1, N - TEMP = (X(K) + FLOAT(K)*H + ONE)**3 - TEMP1 = ZERO - IF (K .NE. 1) TEMP1 = X(K-1) - TEMP2 = ZERO - IF (K .NE. N) TEMP2 = X(K+1) - FVEC(K) = TWO*X(K) - TEMP1 - TEMP2 + TEMP*H**2/TWO - 210 CONTINUE - GO TO 380 -C -C DISCRETE INTEGRAL EQUATION FUNCTION. -C - 220 CONTINUE - H = ONE/FLOAT(N+1) - DO 260 K = 1, N - TK = FLOAT(K)*H - SUM1 = ZERO - DO 230 J = 1, K - TJ = FLOAT(J)*H - TEMP = (X(J) + TJ + ONE)**3 - SUM1 = SUM1 + TJ*TEMP - 230 CONTINUE - SUM2 = ZERO - KP1 = K + 1 - IF (N .LT. KP1) GO TO 250 - DO 240 J = KP1, N - TJ = FLOAT(J)*H - TEMP = (X(J) + TJ + ONE)**3 - SUM2 = SUM2 + (ONE - TJ)*TEMP - 240 CONTINUE - 250 CONTINUE - FVEC(K) = X(K) + H*((ONE - TK)*SUM1 + TK*SUM2)/TWO - 260 CONTINUE - GO TO 380 -C -C TRIGONOMETRIC FUNCTION. -C - 270 CONTINUE - SUM = ZERO - DO 280 J = 1, N - FVEC(J) = COS(X(J)) - SUM = SUM + FVEC(J) - 280 CONTINUE - DO 290 K = 1, N - FVEC(K) = FLOAT(N+K) - SIN(X(K)) - SUM - FLOAT(K)*FVEC(K) - 290 CONTINUE - GO TO 380 -C -C VARIABLY DIMENSIONED FUNCTION. -C - 300 CONTINUE - SUM = ZERO - DO 310 J = 1, N - SUM = SUM + FLOAT(J)*(X(J) - ONE) - 310 CONTINUE - TEMP = SUM*(ONE + TWO*SUM**2) - DO 320 K = 1, N - FVEC(K) = X(K) - ONE + FLOAT(K)*TEMP - 320 CONTINUE - GO TO 380 -C -C BROYDEN TRIDIAGONAL FUNCTION. -C - 330 CONTINUE - DO 340 K = 1, N - TEMP = (THREE - TWO*X(K))*X(K) - TEMP1 = ZERO - IF (K .NE. 1) TEMP1 = X(K-1) - TEMP2 = ZERO - IF (K .NE. N) TEMP2 = X(K+1) - FVEC(K) = TEMP - TEMP1 - TWO*TEMP2 + ONE - 340 CONTINUE - GO TO 380 -C -C BROYDEN BANDED FUNCTION. -C - 350 CONTINUE - ML = 5 - MU = 1 - DO 370 K = 1, N - K1 = MAX0(1,K-ML) - K2 = MIN0(K+MU,N) - TEMP = ZERO - DO 360 J = K1, K2 - IF (J .NE. K) TEMP = TEMP + X(J)*(ONE + X(J)) - 360 CONTINUE - FVEC(K) = X(K)*(TWO + FIVE*X(K)**2) + ONE - TEMP - 370 CONTINUE - 380 CONTINUE - RETURN -C -C LAST CARD OF SUBROUTINE VECFCN. -C - END diff --git a/ex/file14 b/ex/file14 deleted file mode 100644 index 9ad38d8..0000000 --- a/ex/file14 +++ /dev/null @@ -1,284 +0,0 @@ -C ********** -C -C THIS PROGRAM CHECKS THE CONSTANTS OF MACHINE PRECISION AND -C SMALLEST AND LARGEST MACHINE REPRESENTABLE NUMBERS SPECIFIED IN -C FUNCTION DPMPAR, AGAINST THE CORRESPONDING HARDWARE-DETERMINED -C MACHINE CONSTANTS OBTAINED BY DMCHAR, A SUBROUTINE DUE TO -C W. J. CODY. -C -C DATA STATEMENTS IN DPMPAR CORRESPONDING TO THE MACHINE USED MUST -C BE ACTIVATED BY REMOVING C IN COLUMN 1. -C -C THE PRINTED OUTPUT CONSISTS OF THE MACHINE CONSTANTS OBTAINED BY -C DMCHAR AND COMPARISONS OF THE DPMPAR CONSTANTS WITH THEIR -C DMCHAR COUNTERPARTS. DESCRIPTIONS OF THE MACHINE CONSTANTS ARE -C GIVEN IN THE PROLOGUE COMMENTS OF DMCHAR. -C -C SUBPROGRAMS CALLED -C -C MINPACK-SUPPLIED ... DMCHAR,DPMPAR -C -C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. -C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE -C -C ********** - INTEGER IBETA,IEXP,IRND,IT,MACHEP,MAXEXP,MINEXP,NEGEP,NGRD, - * NWRITE - DOUBLE PRECISION DWARF,EPS,EPSMCH,EPSNEG,GIANT,XMAX,XMIN - DOUBLE PRECISION RERR(3) - DOUBLE PRECISION DPMPAR -C -C LOGICAL OUTPUT UNIT IS ASSUMED TO BE NUMBER 6. -C - DATA NWRITE /6/ -C -C DETERMINE THE MACHINE CONSTANTS DYNAMICALLY FROM DMCHAR. -C - CALL DMCHAR(IBETA,IT,IRND,NGRD,MACHEP,NEGEP,IEXP,MINEXP,MAXEXP, - * EPS,EPSNEG,XMIN,XMAX) -C -C COMPARE THE DPMPAR CONSTANTS WITH THEIR DMCHAR COUNTERPARTS AND -C STORE THE RELATIVE DIFFERENCES IN RERR. -C - EPSMCH = DPMPAR(1) - DWARF = DPMPAR(2) - GIANT = DPMPAR(3) - RERR(1) = (EPSMCH - EPS)/EPSMCH - RERR(2) = (DWARF - XMIN)/DWARF - RERR(3) = (XMAX - GIANT)/GIANT -C -C WRITE THE DMCHAR CONSTANTS. -C - WRITE (NWRITE,10) - * IBETA,IT,IRND,NGRD,MACHEP,NEGEP,IEXP,MINEXP,MAXEXP,EPS, - * EPSNEG,XMIN,XMAX -C -C WRITE THE DPMPAR CONSTANTS AND THE RELATIVE DIFFERENCES. -C - WRITE (NWRITE,20) EPSMCH,RERR(1),DWARF,RERR(2),GIANT,RERR(3) - STOP - 10 FORMAT (17H1DMCHAR CONSTANTS /// 8H IBETA =, I6 // 8H IT =, - * I6 // 8H IRND =, I6 // 8H NGRD =, I6 // 9H MACHEP =, - * I6 // 8H NEGEP =, I6 // 7H IEXP =, I6 // 9H MINEXP =, - * I6 // 9H MAXEXP =, I6 // 6H EPS =, D15.7 // 9H EPSNEG =, - * D15.7 // 7H XMIN =, D15.7 // 7H XMAX =, D15.7) - 20 FORMAT ( /// 42H DPMPAR CONSTANTS AND RELATIVE DIFFERENCES /// - * 9H EPSMCH =, D15.7 / 10H RERR(1) =, D15.7 // - * 8H DWARF =, D15.7 / 10H RERR(2) =, D15.7 // 8H GIANT =, - * D15.7 / 10H RERR(3) =, D15.7) -C -C LAST CARD OF DRIVER. -C - END - SUBROUTINE DMCHAR(IBETA,IT,IRND,NGRD,MACHEP,NEGEP,IEXP,MINEXP, - 1 MAXEXP,EPS,EPSNEG,XMIN,XMAX) -C - INTEGER I,IBETA,IEXP,IRND,IT,IZ,J,K,MACHEP,MAXEXP,MINEXP, - 1 MX,NEGEP,NGRD - DOUBLE PRECISION A,B,BETA,BETAIN,BETAM1,EPS,EPSNEG,ONE,XMAX, - 1 XMIN,Y,Z,ZERO -C -C THIS SUBROUTINE IS INTENDED TO DETERMINE THE CHARACTERISTICS -C OF THE FLOATING-POINT ARITHMETIC SYSTEM THAT ARE SPECIFIED -C BELOW. THE FIRST THREE ARE DETERMINED ACCORDING TO AN -C ALGORITHM DUE TO M. MALCOLM, CACM 15 (1972), PP. 949-951, -C INCORPORATING SOME, BUT NOT ALL, OF THE IMPROVEMENTS -C SUGGESTED BY M. GENTLEMAN AND S. MAROVICH, CACM 17 (1974), -C PP. 276-277. -C -C -C IBETA - THE RADIX OF THE FLOATING-POINT REPRESENTATION -C IT - THE NUMBER OF BASE IBETA DIGITS IN THE FLOATING-POINT -C SIGNIFICAND -C IRND - 0 IF FLOATING-POINT ADDITION CHOPS, -C 1 IF FLOATING-POINT ADDITION ROUNDS -C NGRD - THE NUMBER OF GUARD DIGITS FOR MULTIPLICATION. IT IS -C 0 IF IRND=1, OR IF IRND=0 AND ONLY IT BASE IBET -C DIGITS PARTICIPATE IN THE POST NORMALIZATION SHIFT -C OF THE FLOATING-POINT SIGNIFICAND IN MULTIPLICATION -C 1 IF IRND=0 AND MORE THAN IT BASE IBETA DIGITS -C PARTICIPATE IN THE POST NORMALIZATION SHIFT OF THE -C FLOATING-POINT SIGNIFICAND IN MULTIPLICATION -C MACHEP - THE LARGEST NEGATIVE INTEGER SUCH THAT -C 1.0+FLOAT(IBETA)**MACHEP .NE. 1.0, EXCEPT THAT -C MACHEP IS BOUNDED BELOW BY -(IT+3) -C NEGEPS - THE LARGEST NEGATIVE INTEGER SUCH THAT -C 1.0-FLOAT(IBETA)**NEGEPS .NE. 1.0, EXCEPT THAT -C NEGEPS IS BOUNDED BELOW BY -(IT+3) -C IEXP - THE NUMBER OF BITS (DECIMAL PLACES IF IBETA = 10) -C RESERVED FOR THE REPRESENTATION OF THE EXPONENT -C (INCLUDING THE BIAS OR SIGN) OF A FLOATING-POINT -C NUMBER -C MINEXP - THE LARGEST IN MAGNITUDE NEGATIVE INTEGER SUCH THAT -C FLOAT(IBETA)**MINEXP IS A POSITIVE FLOATING-POINT -C NUMBER -C MAXEXP - THE LARGEST POSITIVE INTEGER EXPONENT FOR A FINITE -C FLOATING-POINT NUMBER -C EPS - THE SMALLEST POSITIVE FLOATING-POINT NUMBER SUCH -C THAT 1.0+EPS .NE. 1.0. IN PARTICULAR, IF EITHER -C IBETA = 2 OR IRND = 0, EPS = FLOAT(IBETA)**MACHEP. -C OTHERWISE, EPS = (FLOAT(IBETA)**MACHEP)/2 -C EPSNEG - A SMALL POSITIVE FLOATING-POINT NUMBER SUCH THAT -C 1.0-EPSNEG .NE. 1.0. IN PARTICULAR, IF IBETA = 2 -C OR IRND = 0, EPSNEG = FLOAT(IBETA)**NEGEPS. -C OTHERWISE, EPSNEG = (IBETA**NEGEPS)/2. BECAUSE -C NEGEPS IS BOUNDED BELOW BY -(IT+3), EPSNEG MAY NOT -C BE THE SMALLEST NUMBER WHICH CAN ALTER 1.0 BY -C SUBTRACTION. -C XMIN - THE SMALLEST NON-VANISHING FLOATING-POINT POWER OF TH -C RADIX. IN PARTICULAR, XMIN = FLOAT(IBETA)**MINEXP -C XMAX - THE LARGEST FINITE FLOATING-POINT NUMBER. IN -C PARTICULAR XMAX = (1.0-EPSNEG)*FLOAT(IBETA)**MAXEXP -C NOTE - ON SOME MACHINES XMAX WILL BE ONLY THE -C SECOND, OR PERHAPS THIRD, LARGEST NUMBER, BEING -C TOO SMALL BY 1 OR 2 UNITS IN THE LAST DIGIT OF -C THE SIGNIFICAND. -C -C LATEST REVISION - OCTOBER 22, 1979 -C -C AUTHOR - W. J. CODY -C ARGONNE NATIONAL LABORATORY -C -C----------------------------------------------------------------- - ONE = DBLE(FLOAT(1)) - ZERO = 0.0D0 -C----------------------------------------------------------------- -C DETERMINE IBETA,BETA ALA MALCOLM -C----------------------------------------------------------------- - A = ONE - 10 A = A + A - IF (((A+ONE)-A)-ONE .EQ. ZERO) GO TO 10 - B = ONE - 20 B = B + B - IF ((A+B)-A .EQ. ZERO) GO TO 20 - IBETA = INT(SNGL((A + B) - A)) - BETA = DBLE(FLOAT(IBETA)) -C----------------------------------------------------------------- -C DETERMINE IT, IRND -C----------------------------------------------------------------- - IT = 0 - B = ONE - 100 IT = IT + 1 - B = B * BETA - IF (((B+ONE)-B)-ONE .EQ. ZERO) GO TO 100 - IRND = 0 - BETAM1 = BETA - ONE - IF ((A+BETAM1)-A .NE. ZERO) IRND = 1 -C----------------------------------------------------------------- -C DETERMINE NEGEP, EPSNEG -C----------------------------------------------------------------- - NEGEP = IT + 3 - BETAIN = ONE / BETA - A = ONE -C - DO 200 I = 1, NEGEP - A = A * BETAIN - 200 CONTINUE -C - B = A - 210 IF ((ONE-A)-ONE .NE. ZERO) GO TO 220 - A = A * BETA - NEGEP = NEGEP - 1 - GO TO 210 - 220 NEGEP = -NEGEP - EPSNEG = A - IF ((IBETA .EQ. 2) .OR. (IRND .EQ. 0)) GO TO 300 - A = (A*(ONE+A)) / (ONE+ONE) - IF ((ONE-A)-ONE .NE. ZERO) EPSNEG = A -C----------------------------------------------------------------- -C DETERMINE MACHEP, EPS -C----------------------------------------------------------------- - 300 MACHEP = -IT - 3 - A = B - 310 IF((ONE+A)-ONE .NE. ZERO) GO TO 320 - A = A * BETA - MACHEP = MACHEP + 1 - GO TO 310 - 320 EPS = A - IF ((IBETA .EQ. 2) .OR. (IRND .EQ. 0)) GO TO 350 - A = (A*(ONE+A)) / (ONE+ONE) - IF ((ONE+A)-ONE .NE. ZERO) EPS = A -C----------------------------------------------------------------- -C DETERMINE NGRD -C----------------------------------------------------------------- - 350 NGRD = 0 - IF ((IRND .EQ. 0) .AND. ((ONE+EPS)*ONE-ONE) .NE. ZERO) NGRD = 1 -C----------------------------------------------------------------- -C DETERMINE IEXP, MINEXP, XMIN -C -C LOOP TO DETERMINE LARGEST I AND K = 2**I SUCH THAT -C (1/BETA) ** (2**(I)) -C DOES NOT UNDERFLOW -C EXIT FROM LOOP IS SIGNALED BY AN UNDERFLOW. -C----------------------------------------------------------------- - I = 0 - K = 1 - Z = BETAIN - 400 Y = Z - Z = Y * Y -C----------------------------------------------------------------- -C CHECK FOR UNDERFLOW HERE -C----------------------------------------------------------------- - A = Z * ONE - IF ((A+A .EQ. ZERO) .OR. (DABS(Z) .GE. Y)) GO TO 410 - I = I + 1 - K = K + K - GO TO 400 - 410 IF (IBETA .EQ. 10) GO TO 420 - IEXP = I + 1 - MX = K + K - GO TO 450 -C----------------------------------------------------------------- -C FOR DECIMAL MACHINES ONLY -C----------------------------------------------------------------- - 420 IEXP = 2 - IZ = IBETA - 430 IF (K .LT. IZ) GO TO 440 - IZ = IZ * IBETA - IEXP = IEXP + 1 - GO TO 430 - 440 MX = IZ + IZ - 1 -C----------------------------------------------------------------- -C LOOP TO DETERMINE MINEXP, XMIN -C EXIT FROM LOOP IS SIGNALED BY AN UNDERFLOW. -C----------------------------------------------------------------- - 450 XMIN = Y - Y = Y * BETAIN -C----------------------------------------------------------------- -C CHECK FOR UNDERFLOW HERE -C----------------------------------------------------------------- - A = Y * ONE - IF (((A+A) .EQ. ZERO) .OR. (DABS(Y) .GE. XMIN)) GO TO 460 - K = K + 1 - GO TO 450 - 460 MINEXP = -K -C----------------------------------------------------------------- -C DETERMINE MAXEXP, XMAX -C----------------------------------------------------------------- - IF ((MX .GT. K+K-3) .OR. (IBETA .EQ. 10)) GO TO 500 - MX = MX + MX - IEXP = IEXP + 1 - 500 MAXEXP = MX + MINEXP -C----------------------------------------------------------------- -C ADJUST FOR MACHINES WITH IMPLICIT LEADING -C BIT IN BINARY SIGNIFICAND AND MACHINES WITH -C RADIX POINT AT EXTREME RIGHT OF SIGNIFICAND -C----------------------------------------------------------------- - I = MAXEXP + MINEXP - IF ((IBETA .EQ. 2) .AND. (I .EQ. 0)) MAXEXP = MAXEXP - 1 - IF (I .GT. 20) MAXEXP = MAXEXP - 1 - IF (A .NE. Y) MAXEXP = MAXEXP - 2 - XMAX = ONE - EPSNEG - IF (XMAX*ONE .NE. XMAX) XMAX = ONE - BETA * EPSNEG - XMAX = XMAX / (BETA * BETA * BETA * XMIN) - I = MAXEXP + MINEXP + 3 - IF (I .LE. 0) GO TO 520 -C - DO 510 J = 1, I - IF (IBETA .EQ. 2) XMAX = XMAX + XMAX - IF (IBETA .NE. 2) XMAX = XMAX * BETA - 510 CONTINUE -C - 520 RETURN -C ---------- LAST CARD OF DMCHAR ---------- - END diff --git a/ex/file15 b/ex/file15 deleted file mode 100644 index 13312c7..0000000 --- a/ex/file15 +++ /dev/null @@ -1,552 +0,0 @@ -C ********** -C -C THIS PROGRAM TESTS CODES FOR THE SOLUTION OF N NONLINEAR -C EQUATIONS IN N VARIABLES. IT CONSISTS OF A DRIVER AND AN -C INTERFACE SUBROUTINE FCN. THE DRIVER READS IN DATA, CALLS THE -C NONLINEAR EQUATION SOLVER, AND FINALLY PRINTS OUT INFORMATION -C ON THE PERFORMANCE OF THE SOLVER. THIS IS ONLY A SAMPLE DRIVER, -C MANY OTHER DRIVERS ARE POSSIBLE. THE INTERFACE SUBROUTINE FCN -C IS NECESSARY TO TAKE INTO ACCOUNT THE FORMS OF CALLING -C SEQUENCES USED BY THE FUNCTION SUBROUTINES IN THE VARIOUS -C NONLINEAR EQUATION SOLVERS. -C -C SUBPROGRAMS CALLED -C -C USER-SUPPLIED ...... FCN -C -C MINPACK-SUPPLIED ... DPMPAR,ENORM,HYBRD1,INITPT,VECFCN -C -C FORTRAN-SUPPLIED ... DSQRT -C -C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. -C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE -C -C ********** - INTEGER I,IC,INFO,K,LWA,N,NFEV,NPROB,NREAD,NTRIES,NWRITE - INTEGER NA(60),NF(60),NP(60),NX(60) - DOUBLE PRECISION FACTOR,FNORM1,FNORM2,ONE,TEN,TOL - DOUBLE PRECISION FNM(60),FVEC(40),WA(2660),X(40) - DOUBLE PRECISION DPMPAR,ENORM - EXTERNAL FCN - COMMON /REFNUM/ NPROB,NFEV -C -C LOGICAL INPUT UNIT IS ASSUMED TO BE NUMBER 5. -C LOGICAL OUTPUT UNIT IS ASSUMED TO BE NUMBER 6. -C - DATA NREAD,NWRITE /5,6/ -C - DATA ONE,TEN /1.0D0,1.0D1/ - TOL = DSQRT(DPMPAR(1)) - LWA = 2660 - IC = 0 - 10 CONTINUE - READ (NREAD,50) NPROB,N,NTRIES - IF (NPROB .LE. 0) GO TO 30 - FACTOR = ONE - DO 20 K = 1, NTRIES - IC = IC + 1 - CALL INITPT(N,X,NPROB,FACTOR) - CALL VECFCN(N,X,FVEC,NPROB) - FNORM1 = ENORM(N,FVEC) - WRITE (NWRITE,60) NPROB,N - NFEV = 0 - CALL HYBRD1(FCN,N,X,FVEC,TOL,INFO,WA,LWA) - FNORM2 = ENORM(N,FVEC) - NP(IC) = NPROB - NA(IC) = N - NF(IC) = NFEV - NX(IC) = INFO - FNM(IC) = FNORM2 - WRITE (NWRITE,70) FNORM1,FNORM2,NFEV,INFO,(X(I), I = 1, N) - FACTOR = TEN*FACTOR - 20 CONTINUE - GO TO 10 - 30 CONTINUE - WRITE (NWRITE,80) IC - WRITE (NWRITE,90) - DO 40 I = 1, IC - WRITE (NWRITE,100) NP(I),NA(I),NF(I),NX(I),FNM(I) - 40 CONTINUE - STOP - 50 FORMAT (3I5) - 60 FORMAT ( //// 5X, 8H PROBLEM, I5, 5X, 10H DIMENSION, I5, 5X //) - 70 FORMAT (5X, 33H INITIAL L2 NORM OF THE RESIDUALS, D15.7 // 5X, - * 33H FINAL L2 NORM OF THE RESIDUALS , D15.7 // 5X, - * 33H NUMBER OF FUNCTION EVALUATIONS , I10 // 5X, - * 15H EXIT PARAMETER, 18X, I10 // 5X, - * 27H FINAL APPROXIMATE SOLUTION // (5X, 5D15.7)) - 80 FORMAT (12H1SUMMARY OF , I3, 16H CALLS TO HYBRD1 /) - 90 FORMAT (39H NPROB N NFEV INFO FINAL L2 NORM /) - 100 FORMAT (I4, I6, I7, I6, 1X, D15.7) -C -C LAST CARD OF DRIVER. -C - END - SUBROUTINE FCN(N,X,FVEC,IFLAG) - INTEGER N,IFLAG - DOUBLE PRECISION X(N),FVEC(N) -C ********** -C -C THE CALLING SEQUENCE OF FCN SHOULD BE IDENTICAL TO THE -C CALLING SEQUENCE OF THE FUNCTION SUBROUTINE IN THE NONLINEAR -C EQUATION SOLVER. FCN SHOULD ONLY CALL THE TESTING FUNCTION -C SUBROUTINE VECFCN WITH THE APPROPRIATE VALUE OF PROBLEM -C NUMBER (NPROB). -C -C SUBPROGRAMS CALLED -C -C MINPACK-SUPPLIED ... VECFCN -C -C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. -C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE -C -C ********** - INTEGER NPROB,NFEV - COMMON /REFNUM/ NPROB,NFEV - CALL VECFCN(N,X,FVEC,NPROB) - NFEV = NFEV + 1 - RETURN -C -C LAST CARD OF INTERFACE SUBROUTINE FCN. -C - END - SUBROUTINE VECFCN(N,X,FVEC,NPROB) - INTEGER N,NPROB - DOUBLE PRECISION X(N),FVEC(N) -C ********** -C -C SUBROUTINE VECFCN -C -C THIS SUBROUTINE DEFINES FOURTEEN TEST FUNCTIONS. THE FIRST -C FIVE TEST FUNCTIONS ARE OF DIMENSIONS 2,4,2,4,3, RESPECTIVELY, -C WHILE THE REMAINING TEST FUNCTIONS ARE OF VARIABLE DIMENSION -C N FOR ANY N GREATER THAN OR EQUAL TO 1 (PROBLEM 6 IS AN -C EXCEPTION TO THIS, SINCE IT DOES NOT ALLOW N = 1). -C -C THE SUBROUTINE STATEMENT IS -C -C SUBROUTINE VECFCN(N,X,FVEC,NPROB) -C -C WHERE -C -C N IS A POSITIVE INTEGER INPUT VARIABLE. -C -C X IS AN INPUT ARRAY OF LENGTH N. -C -C FVEC IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE NPROB -C FUNCTION VECTOR EVALUATED AT X. -C -C NPROB IS A POSITIVE INTEGER INPUT VARIABLE WHICH DEFINES THE -C NUMBER OF THE PROBLEM. NPROB MUST NOT EXCEED 14. -C -C SUBPROGRAMS CALLED -C -C FORTRAN-SUPPLIED ... DATAN,DCOS,DEXP,DSIGN,DSIN,DSQRT, -C MAX0,MIN0 -C -C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. -C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE -C -C ********** - INTEGER I,IEV,IVAR,J,K,K1,K2,KP1,ML,MU - DOUBLE PRECISION C1,C2,C3,C4,C5,C6,C7,C8,C9,EIGHT,FIVE,H,ONE, - * PROD,SUM,SUM1,SUM2,TEMP,TEMP1,TEMP2,TEN,THREE, - * TI,TJ,TK,TPI,TWO,ZERO - DOUBLE PRECISION DFLOAT - DATA ZERO,ONE,TWO,THREE,FIVE,EIGHT,TEN - * /0.0D0,1.0D0,2.0D0,3.0D0,5.0D0,8.0D0,1.0D1/ - DATA C1,C2,C3,C4,C5,C6,C7,C8,C9 - * /1.0D4,1.0001D0,2.0D2,2.02D1,1.98D1,1.8D2,2.5D-1,5.0D-1, - * 2.9D1/ - DFLOAT(IVAR) = IVAR -C -C PROBLEM SELECTOR. -C - GO TO (10,20,30,40,50,60,120,170,200,220,270,300,330,350), NPROB -C -C ROSENBROCK FUNCTION. -C - 10 CONTINUE - FVEC(1) = ONE - X(1) - FVEC(2) = TEN*(X(2) - X(1)**2) - GO TO 380 -C -C POWELL SINGULAR FUNCTION. -C - 20 CONTINUE - FVEC(1) = X(1) + TEN*X(2) - FVEC(2) = DSQRT(FIVE)*(X(3) - X(4)) - FVEC(3) = (X(2) - TWO*X(3))**2 - FVEC(4) = DSQRT(TEN)*(X(1) - X(4))**2 - GO TO 380 -C -C POWELL BADLY SCALED FUNCTION. -C - 30 CONTINUE - FVEC(1) = C1*X(1)*X(2) - ONE - FVEC(2) = DEXP(-X(1)) + DEXP(-X(2)) - C2 - GO TO 380 -C -C WOOD FUNCTION. -C - 40 CONTINUE - TEMP1 = X(2) - X(1)**2 - TEMP2 = X(4) - X(3)**2 - FVEC(1) = -C3*X(1)*TEMP1 - (ONE - X(1)) - FVEC(2) = C3*TEMP1 + C4*(X(2) - ONE) + C5*(X(4) - ONE) - FVEC(3) = -C6*X(3)*TEMP2 - (ONE - X(3)) - FVEC(4) = C6*TEMP2 + C4*(X(4) - ONE) + C5*(X(2) - ONE) - GO TO 380 -C -C HELICAL VALLEY FUNCTION. -C - 50 CONTINUE - TPI = EIGHT*DATAN(ONE) - TEMP1 = DSIGN(C7,X(2)) - IF (X(1) .GT. ZERO) TEMP1 = DATAN(X(2)/X(1))/TPI - IF (X(1) .LT. ZERO) TEMP1 = DATAN(X(2)/X(1))/TPI + C8 - TEMP2 = DSQRT(X(1)**2+X(2)**2) - FVEC(1) = TEN*(X(3) - TEN*TEMP1) - FVEC(2) = TEN*(TEMP2 - ONE) - FVEC(3) = X(3) - GO TO 380 -C -C WATSON FUNCTION. -C - 60 CONTINUE - DO 70 K = 1, N - FVEC(K) = ZERO - 70 CONTINUE - DO 110 I = 1, 29 - TI = DFLOAT(I)/C9 - SUM1 = ZERO - TEMP = ONE - DO 80 J = 2, N - SUM1 = SUM1 + DFLOAT(J-1)*TEMP*X(J) - TEMP = TI*TEMP - 80 CONTINUE - SUM2 = ZERO - TEMP = ONE - DO 90 J = 1, N - SUM2 = SUM2 + TEMP*X(J) - TEMP = TI*TEMP - 90 CONTINUE - TEMP1 = SUM1 - SUM2**2 - ONE - TEMP2 = TWO*TI*SUM2 - TEMP = ONE/TI - DO 100 K = 1, N - FVEC(K) = FVEC(K) + TEMP*(DFLOAT(K-1) - TEMP2)*TEMP1 - TEMP = TI*TEMP - 100 CONTINUE - 110 CONTINUE - TEMP = X(2) - X(1)**2 - ONE - FVEC(1) = FVEC(1) + X(1)*(ONE - TWO*TEMP) - FVEC(2) = FVEC(2) + TEMP - GO TO 380 -C -C CHEBYQUAD FUNCTION. -C - 120 CONTINUE - DO 130 K = 1, N - FVEC(K) = ZERO - 130 CONTINUE - DO 150 J = 1, N - TEMP1 = ONE - TEMP2 = TWO*X(J) - ONE - TEMP = TWO*TEMP2 - DO 140 I = 1, N - FVEC(I) = FVEC(I) + TEMP2 - TI = TEMP*TEMP2 - TEMP1 - TEMP1 = TEMP2 - TEMP2 = TI - 140 CONTINUE - 150 CONTINUE - TK = ONE/DFLOAT(N) - IEV = -1 - DO 160 K = 1, N - FVEC(K) = TK*FVEC(K) - IF (IEV .GT. 0) FVEC(K) = FVEC(K) + ONE/(DFLOAT(K)**2 - ONE) - IEV = -IEV - 160 CONTINUE - GO TO 380 -C -C BROWN ALMOST-LINEAR FUNCTION. -C - 170 CONTINUE - SUM = -DFLOAT(N+1) - PROD = ONE - DO 180 J = 1, N - SUM = SUM + X(J) - PROD = X(J)*PROD - 180 CONTINUE - DO 190 K = 1, N - FVEC(K) = X(K) + SUM - 190 CONTINUE - FVEC(N) = PROD - ONE - GO TO 380 -C -C DISCRETE BOUNDARY VALUE FUNCTION. -C - 200 CONTINUE - H = ONE/DFLOAT(N+1) - DO 210 K = 1, N - TEMP = (X(K) + DFLOAT(K)*H + ONE)**3 - TEMP1 = ZERO - IF (K .NE. 1) TEMP1 = X(K-1) - TEMP2 = ZERO - IF (K .NE. N) TEMP2 = X(K+1) - FVEC(K) = TWO*X(K) - TEMP1 - TEMP2 + TEMP*H**2/TWO - 210 CONTINUE - GO TO 380 -C -C DISCRETE INTEGRAL EQUATION FUNCTION. -C - 220 CONTINUE - H = ONE/DFLOAT(N+1) - DO 260 K = 1, N - TK = DFLOAT(K)*H - SUM1 = ZERO - DO 230 J = 1, K - TJ = DFLOAT(J)*H - TEMP = (X(J) + TJ + ONE)**3 - SUM1 = SUM1 + TJ*TEMP - 230 CONTINUE - SUM2 = ZERO - KP1 = K + 1 - IF (N .LT. KP1) GO TO 250 - DO 240 J = KP1, N - TJ = DFLOAT(J)*H - TEMP = (X(J) + TJ + ONE)**3 - SUM2 = SUM2 + (ONE - TJ)*TEMP - 240 CONTINUE - 250 CONTINUE - FVEC(K) = X(K) + H*((ONE - TK)*SUM1 + TK*SUM2)/TWO - 260 CONTINUE - GO TO 380 -C -C TRIGONOMETRIC FUNCTION. -C - 270 CONTINUE - SUM = ZERO - DO 280 J = 1, N - FVEC(J) = DCOS(X(J)) - SUM = SUM + FVEC(J) - 280 CONTINUE - DO 290 K = 1, N - FVEC(K) = DFLOAT(N+K) - DSIN(X(K)) - SUM - DFLOAT(K)*FVEC(K) - 290 CONTINUE - GO TO 380 -C -C VARIABLY DIMENSIONED FUNCTION. -C - 300 CONTINUE - SUM = ZERO - DO 310 J = 1, N - SUM = SUM + DFLOAT(J)*(X(J) - ONE) - 310 CONTINUE - TEMP = SUM*(ONE + TWO*SUM**2) - DO 320 K = 1, N - FVEC(K) = X(K) - ONE + DFLOAT(K)*TEMP - 320 CONTINUE - GO TO 380 -C -C BROYDEN TRIDIAGONAL FUNCTION. -C - 330 CONTINUE - DO 340 K = 1, N - TEMP = (THREE - TWO*X(K))*X(K) - TEMP1 = ZERO - IF (K .NE. 1) TEMP1 = X(K-1) - TEMP2 = ZERO - IF (K .NE. N) TEMP2 = X(K+1) - FVEC(K) = TEMP - TEMP1 - TWO*TEMP2 + ONE - 340 CONTINUE - GO TO 380 -C -C BROYDEN BANDED FUNCTION. -C - 350 CONTINUE - ML = 5 - MU = 1 - DO 370 K = 1, N - K1 = MAX0(1,K-ML) - K2 = MIN0(K+MU,N) - TEMP = ZERO - DO 360 J = K1, K2 - IF (J .NE. K) TEMP = TEMP + X(J)*(ONE + X(J)) - 360 CONTINUE - FVEC(K) = X(K)*(TWO + FIVE*X(K)**2) + ONE - TEMP - 370 CONTINUE - 380 CONTINUE - RETURN -C -C LAST CARD OF SUBROUTINE VECFCN. -C - END - SUBROUTINE INITPT(N,X,NPROB,FACTOR) - INTEGER N,NPROB - DOUBLE PRECISION FACTOR - DOUBLE PRECISION X(N) -C ********** -C -C SUBROUTINE INITPT -C -C THIS SUBROUTINE SPECIFIES THE STANDARD STARTING POINTS FOR -C THE FUNCTIONS DEFINED BY SUBROUTINE VECFCN. THE SUBROUTINE -C RETURNS IN X A MULTIPLE (FACTOR) OF THE STANDARD STARTING -C POINT. FOR THE SIXTH FUNCTION THE STANDARD STARTING POINT IS -C ZERO, SO IN THIS CASE, IF FACTOR IS NOT UNITY, THEN THE -C SUBROUTINE RETURNS THE VECTOR X(J) = FACTOR, J=1,...,N. -C -C THE SUBROUTINE STATEMENT IS -C -C SUBROUTINE INITPT(N,X,NPROB,FACTOR) -C -C WHERE -C -C N IS A POSITIVE INTEGER INPUT VARIABLE. -C -C X IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE STANDARD -C STARTING POINT FOR PROBLEM NPROB MULTIPLIED BY FACTOR. -C -C NPROB IS A POSITIVE INTEGER INPUT VARIABLE WHICH DEFINES THE -C NUMBER OF THE PROBLEM. NPROB MUST NOT EXCEED 14. -C -C FACTOR IS AN INPUT VARIABLE WHICH SPECIFIES THE MULTIPLE OF -C THE STANDARD STARTING POINT. IF FACTOR IS UNITY, NO -C MULTIPLICATION IS PERFORMED. -C -C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. -C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE -C -C ********** - INTEGER IVAR,J - DOUBLE PRECISION C1,H,HALF,ONE,THREE,TJ,ZERO - DOUBLE PRECISION DFLOAT - DATA ZERO,HALF,ONE,THREE,C1 /0.0D0,5.0D-1,1.0D0,3.0D0,1.2D0/ - DFLOAT(IVAR) = IVAR -C -C SELECTION OF INITIAL POINT. -C - GO TO (10,20,30,40,50,60,80,100,120,120,140,160,180,180), NPROB -C -C ROSENBROCK FUNCTION. -C - 10 CONTINUE - X(1) = -C1 - X(2) = ONE - GO TO 200 -C -C POWELL SINGULAR FUNCTION. -C - 20 CONTINUE - X(1) = THREE - X(2) = -ONE - X(3) = ZERO - X(4) = ONE - GO TO 200 -C -C POWELL BADLY SCALED FUNCTION. -C - 30 CONTINUE - X(1) = ZERO - X(2) = ONE - GO TO 200 -C -C WOOD FUNCTION. -C - 40 CONTINUE - X(1) = -THREE - X(2) = -ONE - X(3) = -THREE - X(4) = -ONE - GO TO 200 -C -C HELICAL VALLEY FUNCTION. -C - 50 CONTINUE - X(1) = -ONE - X(2) = ZERO - X(3) = ZERO - GO TO 200 -C -C WATSON FUNCTION. -C - 60 CONTINUE - DO 70 J = 1, N - X(J) = ZERO - 70 CONTINUE - GO TO 200 -C -C CHEBYQUAD FUNCTION. -C - 80 CONTINUE - H = ONE/DFLOAT(N+1) - DO 90 J = 1, N - X(J) = DFLOAT(J)*H - 90 CONTINUE - GO TO 200 -C -C BROWN ALMOST-LINEAR FUNCTION. -C - 100 CONTINUE - DO 110 J = 1, N - X(J) = HALF - 110 CONTINUE - GO TO 200 -C -C DISCRETE BOUNDARY VALUE AND INTEGRAL EQUATION FUNCTIONS. -C - 120 CONTINUE - H = ONE/DFLOAT(N+1) - DO 130 J = 1, N - TJ = DFLOAT(J)*H - X(J) = TJ*(TJ - ONE) - 130 CONTINUE - GO TO 200 -C -C TRIGONOMETRIC FUNCTION. -C - 140 CONTINUE - H = ONE/DFLOAT(N) - DO 150 J = 1, N - X(J) = H - 150 CONTINUE - GO TO 200 -C -C VARIABLY DIMENSIONED FUNCTION. -C - 160 CONTINUE - H = ONE/DFLOAT(N) - DO 170 J = 1, N - X(J) = ONE - DFLOAT(J)*H - 170 CONTINUE - GO TO 200 -C -C BROYDEN TRIDIAGONAL AND BANDED FUNCTIONS. -C - 180 CONTINUE - DO 190 J = 1, N - X(J) = -ONE - 190 CONTINUE - 200 CONTINUE -C -C COMPUTE MULTIPLE OF INITIAL POINT. -C - IF (FACTOR .EQ. ONE) GO TO 250 - IF (NPROB .EQ. 6) GO TO 220 - DO 210 J = 1, N - X(J) = FACTOR*X(J) - 210 CONTINUE - GO TO 240 - 220 CONTINUE - DO 230 J = 1, N - X(J) = FACTOR - 230 CONTINUE - 240 CONTINUE - 250 CONTINUE - RETURN -C -C LAST CARD OF SUBROUTINE INITPT. -C - END diff --git a/ex/file16 b/ex/file16 deleted file mode 100644 index 165efe3..0000000 --- a/ex/file16 +++ /dev/null @@ -1,881 +0,0 @@ -C ********** -C -C THIS PROGRAM TESTS CODES FOR THE SOLUTION OF N NONLINEAR -C EQUATIONS IN N VARIABLES. IT CONSISTS OF A DRIVER AND AN -C INTERFACE SUBROUTINE FCN. THE DRIVER READS IN DATA, CALLS THE -C NONLINEAR EQUATION SOLVER, AND FINALLY PRINTS OUT INFORMATION -C ON THE PERFORMANCE OF THE SOLVER. THIS IS ONLY A SAMPLE DRIVER, -C MANY OTHER DRIVERS ARE POSSIBLE. THE INTERFACE SUBROUTINE FCN -C IS NECESSARY TO TAKE INTO ACCOUNT THE FORMS OF CALLING -C SEQUENCES USED BY THE FUNCTION AND JACOBIAN SUBROUTINES IN -C THE VARIOUS NONLINEAR EQUATION SOLVERS. -C -C SUBPROGRAMS CALLED -C -C USER-SUPPLIED ...... FCN -C -C MINPACK-SUPPLIED ... DPMPAR,ENORM,HYBRJ1,INITPT,VECFCN -C -C FORTRAN-SUPPLIED ... DSQRT -C -C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. -C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE -C -C ********** - INTEGER I,IC,INFO,K,LDFJAC,LWA,N,NFEV,NJEV,NPROB,NREAD,NTRIES, - 1 NWRITE - INTEGER NA(60),NF(60),NJ(60),NP(60),NX(60) - DOUBLE PRECISION FACTOR,FNORM1,FNORM2,ONE,TEN,TOL - DOUBLE PRECISION FNM(60),FJAC(40,40),FVEC(40),WA(1060),X(40) - DOUBLE PRECISION DPMPAR,ENORM - EXTERNAL FCN - COMMON /REFNUM/ NPROB,NFEV,NJEV -C -C LOGICAL INPUT UNIT IS ASSUMED TO BE NUMBER 5. -C LOGICAL OUTPUT UNIT IS ASSUMED TO BE NUMBER 6. -C - DATA NREAD,NWRITE /5,6/ -C - DATA ONE,TEN /1.0D0,1.0D1/ - TOL = DSQRT(DPMPAR(1)) - LDFJAC = 40 - LWA = 1060 - IC = 0 - 10 CONTINUE - READ (NREAD,50) NPROB,N,NTRIES - IF (NPROB .LE. 0) GO TO 30 - FACTOR = ONE - DO 20 K = 1, NTRIES - IC = IC + 1 - CALL INITPT(N,X,NPROB,FACTOR) - CALL VECFCN(N,X,FVEC,NPROB) - FNORM1 = ENORM(N,FVEC) - WRITE (NWRITE,60) NPROB,N - NFEV = 0 - NJEV = 0 - CALL HYBRJ1(FCN,N,X,FVEC,FJAC,LDFJAC,TOL,INFO,WA,LWA) - FNORM2 = ENORM(N,FVEC) - NP(IC) = NPROB - NA(IC) = N - NF(IC) = NFEV - NJ(IC) = NJEV - NX(IC) = INFO - FNM(IC) = FNORM2 - WRITE (NWRITE,70) - 1 FNORM1,FNORM2,NFEV,NJEV,INFO,(X(I), I = 1, N) - FACTOR = TEN*FACTOR - 20 CONTINUE - GO TO 10 - 30 CONTINUE - WRITE (NWRITE,80) IC - WRITE (NWRITE,90) - DO 40 I = 1, IC - WRITE (NWRITE,100) NP(I),NA(I),NF(I),NJ(I),NX(I),FNM(I) - 40 CONTINUE - STOP - 50 FORMAT (3I5) - 60 FORMAT ( //// 5X, 8H PROBLEM, I5, 5X, 10H DIMENSION, I5, 5X //) - 70 FORMAT (5X, 33H INITIAL L2 NORM OF THE RESIDUALS, D15.7 // 5X, - 1 33H FINAL L2 NORM OF THE RESIDUALS , D15.7 // 5X, - 2 33H NUMBER OF FUNCTION EVALUATIONS , I10 // 5X, - 3 33H NUMBER OF JACOBIAN EVALUATIONS , I10 // 5X, - 4 15H EXIT PARAMETER, 18X, I10 // 5X, - 5 27H FINAL APPROXIMATE SOLUTION // (5X, 5D15.7)) - 80 FORMAT (12H1SUMMARY OF , I3, 16H CALLS TO HYBRJ1 /) - 90 FORMAT (46H NPROB N NFEV NJEV INFO FINAL L2 NORM /) - 100 FORMAT (I4, I6, 2I7, I6, 1X, D15.7) -C -C LAST CARD OF DRIVER. -C - END - SUBROUTINE FCN(N,X,FVEC,FJAC,LDFJAC,IFLAG) - INTEGER N,LDFJAC,IFLAG - DOUBLE PRECISION X(N),FVEC(N),FJAC(LDFJAC,N) -C ********** -C -C THE CALLING SEQUENCE OF FCN SHOULD BE IDENTICAL TO THE -C CALLING SEQUENCE OF THE FUNCTION SUBROUTINE IN THE NONLINEAR -C EQUATION SOLVER. FCN SHOULD ONLY CALL THE TESTING FUNCTION -C AND JACOBIAN SUBROUTINES VECFCN AND VECJAC WITH THE -C APPROPRIATE VALUE OF PROBLEM NUMBER (NPROB). -C -C SUBPROGRAMS CALLED -C -C MINPACK-SUPPLIED ... VECFCN,VECJAC -C -C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. -C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE -C -C ********** - INTEGER NPROB,NFEV,NJEV - COMMON /REFNUM/ NPROB,NFEV,NJEV - IF (IFLAG .EQ. 1) CALL VECFCN(N,X,FVEC,NPROB) - IF (IFLAG .EQ. 2) CALL VECJAC(N,X,FJAC,LDFJAC,NPROB) - IF (IFLAG .EQ. 1) NFEV = NFEV + 1 - IF (IFLAG .EQ. 2) NJEV = NJEV + 1 - RETURN -C -C LAST CARD OF INTERFACE SUBROUTINE FCN. -C - END - SUBROUTINE VECJAC(N,X,FJAC,LDFJAC,NPROB) - INTEGER N,LDFJAC,NPROB - DOUBLE PRECISION X(N),FJAC(LDFJAC,N) -C ********** -C -C SUBROUTINE VECJAC -C -C THIS SUBROUTINE DEFINES THE JACOBIAN MATRICES OF FOURTEEN -C TEST FUNCTIONS. THE PROBLEM DIMENSIONS ARE AS DESCRIBED -C IN THE PROLOGUE COMMENTS OF VECFCN. -C -C THE SUBROUTINE STATEMENT IS -C -C SUBROUTINE VECJAC(N,X,FJAC,LDFJAC,NPROB) -C -C WHERE -C -C N IS A POSITIVE INTEGER VARIABLE. -C -C X IS AN ARRAY OF LENGTH N. -C -C FJAC IS AN N BY N ARRAY. ON OUTPUT FJAC CONTAINS THE -C JACOBIAN MATRIX OF THE NPROB FUNCTION EVALUATED AT X. -C -C LDFJAC IS A POSITIVE INTEGER VARIABLE NOT LESS THAN N -C WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY FJAC. -C -C NPROB IS A POSITIVE INTEGER VARIABLE WHICH DEFINES THE -C NUMBER OF THE PROBLEM. NPROB MUST NOT EXCEED 14. -C -C SUBPROGRAMS CALLED -C -C FORTRAN-SUPPLIED ... DATAN,DCOS,DEXP,DMIN1,DSIN,DSQRT, -C MAX0,MIN0 -C -C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. -C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE -C -C ********** - INTEGER I,IVAR,J,K,K1,K2,ML,MU - DOUBLE PRECISION C1,C3,C4,C5,C6,C9,EIGHT,FIFTN,FIVE,FOUR,H, - * HUNDRD,ONE,PROD,SIX,SUM,SUM1,SUM2,TEMP,TEMP1, - * TEMP2,TEMP3,TEMP4,TEN,THREE,TI,TJ,TK,TPI, - * TWENTY,TWO,ZERO - DOUBLE PRECISION DFLOAT - DATA ZERO,ONE,TWO,THREE,FOUR,FIVE,SIX,EIGHT,TEN,FIFTN,TWENTY, - * HUNDRD - * /0.0D0,1.0D0,2.0D0,3.0D0,4.0D0,5.0D0,6.0D0,8.0D0,1.0D1, - * 1.5D1,2.0D1,1.0D2/ - DATA C1,C3,C4,C5,C6,C9 /1.0D4,2.0D2,2.02D1,1.98D1,1.8D2,2.9D1/ - DFLOAT(IVAR) = IVAR -C -C JACOBIAN ROUTINE SELECTOR. -C - GO TO (10,20,50,60,90,100,200,230,290,320,350,380,420,450), - * NPROB -C -C ROSENBROCK FUNCTION. -C - 10 CONTINUE - FJAC(1,1) = -ONE - FJAC(1,2) = ZERO - FJAC(2,1) = -TWENTY*X(1) - FJAC(2,2) = TEN - GO TO 490 -C -C POWELL SINGULAR FUNCTION. -C - 20 CONTINUE - DO 40 K = 1, 4 - DO 30 J = 1, 4 - FJAC(K,J) = ZERO - 30 CONTINUE - 40 CONTINUE - FJAC(1,1) = ONE - FJAC(1,2) = TEN - FJAC(2,3) = DSQRT(FIVE) - FJAC(2,4) = -FJAC(2,3) - FJAC(3,2) = TWO*(X(2) - TWO*X(3)) - FJAC(3,3) = -TWO*FJAC(3,2) - FJAC(4,1) = TWO*DSQRT(TEN)*(X(1) - X(4)) - FJAC(4,4) = -FJAC(4,1) - GO TO 490 -C -C POWELL BADLY SCALED FUNCTION. -C - 50 CONTINUE - FJAC(1,1) = C1*X(2) - FJAC(1,2) = C1*X(1) - FJAC(2,1) = -DEXP(-X(1)) - FJAC(2,2) = -DEXP(-X(2)) - GO TO 490 -C -C WOOD FUNCTION. -C - 60 CONTINUE - DO 80 K = 1, 4 - DO 70 J = 1, 4 - FJAC(K,J) = ZERO - 70 CONTINUE - 80 CONTINUE - TEMP1 = X(2) - THREE*X(1)**2 - TEMP2 = X(4) - THREE*X(3)**2 - FJAC(1,1) = -C3*TEMP1 + ONE - FJAC(1,2) = -C3*X(1) - FJAC(2,1) = -TWO*C3*X(1) - FJAC(2,2) = C3 + C4 - FJAC(2,4) = C5 - FJAC(3,3) = -C6*TEMP2 + ONE - FJAC(3,4) = -C6*X(3) - FJAC(4,2) = C5 - FJAC(4,3) = -TWO*C6*X(3) - FJAC(4,4) = C6 + C4 - GO TO 490 -C -C HELICAL VALLEY FUNCTION. -C - 90 CONTINUE - TPI = EIGHT*DATAN(ONE) - TEMP = X(1)**2 + X(2)**2 - TEMP1 = TPI*TEMP - TEMP2 = DSQRT(TEMP) - FJAC(1,1) = HUNDRD*X(2)/TEMP1 - FJAC(1,2) = -HUNDRD*X(1)/TEMP1 - FJAC(1,3) = TEN - FJAC(2,1) = TEN*X(1)/TEMP2 - FJAC(2,2) = TEN*X(2)/TEMP2 - FJAC(2,3) = ZERO - FJAC(3,1) = ZERO - FJAC(3,2) = ZERO - FJAC(3,3) = ONE - GO TO 490 -C -C WATSON FUNCTION. -C - 100 CONTINUE - DO 120 K = 1, N - DO 110 J = K, N - FJAC(K,J) = ZERO - 110 CONTINUE - 120 CONTINUE - DO 170 I = 1, 29 - TI = DFLOAT(I)/C9 - SUM1 = ZERO - TEMP = ONE - DO 130 J = 2, N - SUM1 = SUM1 + DFLOAT(J-1)*TEMP*X(J) - TEMP = TI*TEMP - 130 CONTINUE - SUM2 = ZERO - TEMP = ONE - DO 140 J = 1, N - SUM2 = SUM2 + TEMP*X(J) - TEMP = TI*TEMP - 140 CONTINUE - TEMP1 = TWO*(SUM1 - SUM2**2 - ONE) - TEMP2 = TWO*SUM2 - TEMP = TI**2 - TK = ONE - DO 160 K = 1, N - TJ = TK - DO 150 J = K, N - FJAC(K,J) = FJAC(K,J) - * + TJ - * *((DFLOAT(K-1)/TI - TEMP2) - * *(DFLOAT(J-1)/TI - TEMP2) - TEMP1) - TJ = TI*TJ - 150 CONTINUE - TK = TEMP*TK - 160 CONTINUE - 170 CONTINUE - FJAC(1,1) = FJAC(1,1) + SIX*X(1)**2 - TWO*X(2) + THREE - FJAC(1,2) = FJAC(1,2) - TWO*X(1) - FJAC(2,2) = FJAC(2,2) + ONE - DO 190 K = 1, N - DO 180 J = K, N - FJAC(J,K) = FJAC(K,J) - 180 CONTINUE - 190 CONTINUE - GO TO 490 -C -C CHEBYQUAD FUNCTION. -C - 200 CONTINUE - TK = ONE/DFLOAT(N) - DO 220 J = 1, N - TEMP1 = ONE - TEMP2 = TWO*X(J) - ONE - TEMP = TWO*TEMP2 - TEMP3 = ZERO - TEMP4 = TWO - DO 210 K = 1, N - FJAC(K,J) = TK*TEMP4 - TI = FOUR*TEMP2 + TEMP*TEMP4 - TEMP3 - TEMP3 = TEMP4 - TEMP4 = TI - TI = TEMP*TEMP2 - TEMP1 - TEMP1 = TEMP2 - TEMP2 = TI - 210 CONTINUE - 220 CONTINUE - GO TO 490 -C -C BROWN ALMOST-LINEAR FUNCTION. -C - 230 CONTINUE - PROD = ONE - DO 250 J = 1, N - PROD = X(J)*PROD - DO 240 K = 1, N - FJAC(K,J) = ONE - 240 CONTINUE - FJAC(J,J) = TWO - 250 CONTINUE - DO 280 J = 1, N - TEMP = X(J) - IF (TEMP .NE. ZERO) GO TO 270 - TEMP = ONE - PROD = ONE - DO 260 K = 1, N - IF (K .NE. J) PROD = X(K)*PROD - 260 CONTINUE - 270 CONTINUE - FJAC(N,J) = PROD/TEMP - 280 CONTINUE - GO TO 490 -C -C DISCRETE BOUNDARY VALUE FUNCTION. -C - 290 CONTINUE - H = ONE/DFLOAT(N+1) - DO 310 K = 1, N - TEMP = THREE*(X(K) + DFLOAT(K)*H + ONE)**2 - DO 300 J = 1, N - FJAC(K,J) = ZERO - 300 CONTINUE - FJAC(K,K) = TWO + TEMP*H**2/TWO - IF (K .NE. 1) FJAC(K,K-1) = -ONE - IF (K .NE. N) FJAC(K,K+1) = -ONE - 310 CONTINUE - GO TO 490 -C -C DISCRETE INTEGRAL EQUATION FUNCTION. -C - 320 CONTINUE - H = ONE/DFLOAT(N+1) - DO 340 K = 1, N - TK = DFLOAT(K)*H - DO 330 J = 1, N - TJ = DFLOAT(J)*H - TEMP = THREE*(X(J) + TJ + ONE)**2 - FJAC(K,J) = H*DMIN1(TJ*(ONE-TK),TK*(ONE-TJ))*TEMP/TWO - 330 CONTINUE - FJAC(K,K) = FJAC(K,K) + ONE - 340 CONTINUE - GO TO 490 -C -C TRIGONOMETRIC FUNCTION. -C - 350 CONTINUE - DO 370 J = 1, N - TEMP = DSIN(X(J)) - DO 360 K = 1, N - FJAC(K,J) = TEMP - 360 CONTINUE - FJAC(J,J) = DFLOAT(J+1)*TEMP - DCOS(X(J)) - 370 CONTINUE - GO TO 490 -C -C VARIABLY DIMENSIONED FUNCTION. -C - 380 CONTINUE - SUM = ZERO - DO 390 J = 1, N - SUM = SUM + DFLOAT(J)*(X(J) - ONE) - 390 CONTINUE - TEMP = ONE + SIX*SUM**2 - DO 410 K = 1, N - DO 400 J = K, N - FJAC(K,J) = DFLOAT(K*J)*TEMP - FJAC(J,K) = FJAC(K,J) - 400 CONTINUE - FJAC(K,K) = FJAC(K,K) + ONE - 410 CONTINUE - GO TO 490 -C -C BROYDEN TRIDIAGONAL FUNCTION. -C - 420 CONTINUE - DO 440 K = 1, N - DO 430 J = 1, N - FJAC(K,J) = ZERO - 430 CONTINUE - FJAC(K,K) = THREE - FOUR*X(K) - IF (K .NE. 1) FJAC(K,K-1) = -ONE - IF (K .NE. N) FJAC(K,K+1) = -TWO - 440 CONTINUE - GO TO 490 -C -C BROYDEN BANDED FUNCTION. -C - 450 CONTINUE - ML = 5 - MU = 1 - DO 480 K = 1, N - DO 460 J = 1, N - FJAC(K,J) = ZERO - 460 CONTINUE - K1 = MAX0(1,K-ML) - K2 = MIN0(K+MU,N) - DO 470 J = K1, K2 - IF (J .NE. K) FJAC(K,J) = -(ONE + TWO*X(J)) - 470 CONTINUE - FJAC(K,K) = TWO + FIFTN*X(K)**2 - 480 CONTINUE - 490 CONTINUE - RETURN -C -C LAST CARD OF SUBROUTINE VECJAC. -C - END - SUBROUTINE INITPT(N,X,NPROB,FACTOR) - INTEGER N,NPROB - DOUBLE PRECISION FACTOR - DOUBLE PRECISION X(N) -C ********** -C -C SUBROUTINE INITPT -C -C THIS SUBROUTINE SPECIFIES THE STANDARD STARTING POINTS FOR -C THE FUNCTIONS DEFINED BY SUBROUTINE VECFCN. THE SUBROUTINE -C RETURNS IN X A MULTIPLE (FACTOR) OF THE STANDARD STARTING -C POINT. FOR THE SIXTH FUNCTION THE STANDARD STARTING POINT IS -C ZERO, SO IN THIS CASE, IF FACTOR IS NOT UNITY, THEN THE -C SUBROUTINE RETURNS THE VECTOR X(J) = FACTOR, J=1,...,N. -C -C THE SUBROUTINE STATEMENT IS -C -C SUBROUTINE INITPT(N,X,NPROB,FACTOR) -C -C WHERE -C -C N IS A POSITIVE INTEGER INPUT VARIABLE. -C -C X IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE STANDARD -C STARTING POINT FOR PROBLEM NPROB MULTIPLIED BY FACTOR. -C -C NPROB IS A POSITIVE INTEGER INPUT VARIABLE WHICH DEFINES THE -C NUMBER OF THE PROBLEM. NPROB MUST NOT EXCEED 14. -C -C FACTOR IS AN INPUT VARIABLE WHICH SPECIFIES THE MULTIPLE OF -C THE STANDARD STARTING POINT. IF FACTOR IS UNITY, NO -C MULTIPLICATION IS PERFORMED. -C -C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. -C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE -C -C ********** - INTEGER IVAR,J - DOUBLE PRECISION C1,H,HALF,ONE,THREE,TJ,ZERO - DOUBLE PRECISION DFLOAT - DATA ZERO,HALF,ONE,THREE,C1 /0.0D0,5.0D-1,1.0D0,3.0D0,1.2D0/ - DFLOAT(IVAR) = IVAR -C -C SELECTION OF INITIAL POINT. -C - GO TO (10,20,30,40,50,60,80,100,120,120,140,160,180,180), NPROB -C -C ROSENBROCK FUNCTION. -C - 10 CONTINUE - X(1) = -C1 - X(2) = ONE - GO TO 200 -C -C POWELL SINGULAR FUNCTION. -C - 20 CONTINUE - X(1) = THREE - X(2) = -ONE - X(3) = ZERO - X(4) = ONE - GO TO 200 -C -C POWELL BADLY SCALED FUNCTION. -C - 30 CONTINUE - X(1) = ZERO - X(2) = ONE - GO TO 200 -C -C WOOD FUNCTION. -C - 40 CONTINUE - X(1) = -THREE - X(2) = -ONE - X(3) = -THREE - X(4) = -ONE - GO TO 200 -C -C HELICAL VALLEY FUNCTION. -C - 50 CONTINUE - X(1) = -ONE - X(2) = ZERO - X(3) = ZERO - GO TO 200 -C -C WATSON FUNCTION. -C - 60 CONTINUE - DO 70 J = 1, N - X(J) = ZERO - 70 CONTINUE - GO TO 200 -C -C CHEBYQUAD FUNCTION. -C - 80 CONTINUE - H = ONE/DFLOAT(N+1) - DO 90 J = 1, N - X(J) = DFLOAT(J)*H - 90 CONTINUE - GO TO 200 -C -C BROWN ALMOST-LINEAR FUNCTION. -C - 100 CONTINUE - DO 110 J = 1, N - X(J) = HALF - 110 CONTINUE - GO TO 200 -C -C DISCRETE BOUNDARY VALUE AND INTEGRAL EQUATION FUNCTIONS. -C - 120 CONTINUE - H = ONE/DFLOAT(N+1) - DO 130 J = 1, N - TJ = DFLOAT(J)*H - X(J) = TJ*(TJ - ONE) - 130 CONTINUE - GO TO 200 -C -C TRIGONOMETRIC FUNCTION. -C - 140 CONTINUE - H = ONE/DFLOAT(N) - DO 150 J = 1, N - X(J) = H - 150 CONTINUE - GO TO 200 -C -C VARIABLY DIMENSIONED FUNCTION. -C - 160 CONTINUE - H = ONE/DFLOAT(N) - DO 170 J = 1, N - X(J) = ONE - DFLOAT(J)*H - 170 CONTINUE - GO TO 200 -C -C BROYDEN TRIDIAGONAL AND BANDED FUNCTIONS. -C - 180 CONTINUE - DO 190 J = 1, N - X(J) = -ONE - 190 CONTINUE - 200 CONTINUE -C -C COMPUTE MULTIPLE OF INITIAL POINT. -C - IF (FACTOR .EQ. ONE) GO TO 250 - IF (NPROB .EQ. 6) GO TO 220 - DO 210 J = 1, N - X(J) = FACTOR*X(J) - 210 CONTINUE - GO TO 240 - 220 CONTINUE - DO 230 J = 1, N - X(J) = FACTOR - 230 CONTINUE - 240 CONTINUE - 250 CONTINUE - RETURN -C -C LAST CARD OF SUBROUTINE INITPT. -C - END - SUBROUTINE VECFCN(N,X,FVEC,NPROB) - INTEGER N,NPROB - DOUBLE PRECISION X(N),FVEC(N) -C ********** -C -C SUBROUTINE VECFCN -C -C THIS SUBROUTINE DEFINES FOURTEEN TEST FUNCTIONS. THE FIRST -C FIVE TEST FUNCTIONS ARE OF DIMENSIONS 2,4,2,4,3, RESPECTIVELY, -C WHILE THE REMAINING TEST FUNCTIONS ARE OF VARIABLE DIMENSION -C N FOR ANY N GREATER THAN OR EQUAL TO 1 (PROBLEM 6 IS AN -C EXCEPTION TO THIS, SINCE IT DOES NOT ALLOW N = 1). -C -C THE SUBROUTINE STATEMENT IS -C -C SUBROUTINE VECFCN(N,X,FVEC,NPROB) -C -C WHERE -C -C N IS A POSITIVE INTEGER INPUT VARIABLE. -C -C X IS AN INPUT ARRAY OF LENGTH N. -C -C FVEC IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE NPROB -C FUNCTION VECTOR EVALUATED AT X. -C -C NPROB IS A POSITIVE INTEGER INPUT VARIABLE WHICH DEFINES THE -C NUMBER OF THE PROBLEM. NPROB MUST NOT EXCEED 14. -C -C SUBPROGRAMS CALLED -C -C FORTRAN-SUPPLIED ... DATAN,DCOS,DEXP,DSIGN,DSIN,DSQRT, -C MAX0,MIN0 -C -C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. -C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE -C -C ********** - INTEGER I,IEV,IVAR,J,K,K1,K2,KP1,ML,MU - DOUBLE PRECISION C1,C2,C3,C4,C5,C6,C7,C8,C9,EIGHT,FIVE,H,ONE, - * PROD,SUM,SUM1,SUM2,TEMP,TEMP1,TEMP2,TEN,THREE, - * TI,TJ,TK,TPI,TWO,ZERO - DOUBLE PRECISION DFLOAT - DATA ZERO,ONE,TWO,THREE,FIVE,EIGHT,TEN - * /0.0D0,1.0D0,2.0D0,3.0D0,5.0D0,8.0D0,1.0D1/ - DATA C1,C2,C3,C4,C5,C6,C7,C8,C9 - * /1.0D4,1.0001D0,2.0D2,2.02D1,1.98D1,1.8D2,2.5D-1,5.0D-1, - * 2.9D1/ - DFLOAT(IVAR) = IVAR -C -C PROBLEM SELECTOR. -C - GO TO (10,20,30,40,50,60,120,170,200,220,270,300,330,350), NPROB -C -C ROSENBROCK FUNCTION. -C - 10 CONTINUE - FVEC(1) = ONE - X(1) - FVEC(2) = TEN*(X(2) - X(1)**2) - GO TO 380 -C -C POWELL SINGULAR FUNCTION. -C - 20 CONTINUE - FVEC(1) = X(1) + TEN*X(2) - FVEC(2) = DSQRT(FIVE)*(X(3) - X(4)) - FVEC(3) = (X(2) - TWO*X(3))**2 - FVEC(4) = DSQRT(TEN)*(X(1) - X(4))**2 - GO TO 380 -C -C POWELL BADLY SCALED FUNCTION. -C - 30 CONTINUE - FVEC(1) = C1*X(1)*X(2) - ONE - FVEC(2) = DEXP(-X(1)) + DEXP(-X(2)) - C2 - GO TO 380 -C -C WOOD FUNCTION. -C - 40 CONTINUE - TEMP1 = X(2) - X(1)**2 - TEMP2 = X(4) - X(3)**2 - FVEC(1) = -C3*X(1)*TEMP1 - (ONE - X(1)) - FVEC(2) = C3*TEMP1 + C4*(X(2) - ONE) + C5*(X(4) - ONE) - FVEC(3) = -C6*X(3)*TEMP2 - (ONE - X(3)) - FVEC(4) = C6*TEMP2 + C4*(X(4) - ONE) + C5*(X(2) - ONE) - GO TO 380 -C -C HELICAL VALLEY FUNCTION. -C - 50 CONTINUE - TPI = EIGHT*DATAN(ONE) - TEMP1 = DSIGN(C7,X(2)) - IF (X(1) .GT. ZERO) TEMP1 = DATAN(X(2)/X(1))/TPI - IF (X(1) .LT. ZERO) TEMP1 = DATAN(X(2)/X(1))/TPI + C8 - TEMP2 = DSQRT(X(1)**2+X(2)**2) - FVEC(1) = TEN*(X(3) - TEN*TEMP1) - FVEC(2) = TEN*(TEMP2 - ONE) - FVEC(3) = X(3) - GO TO 380 -C -C WATSON FUNCTION. -C - 60 CONTINUE - DO 70 K = 1, N - FVEC(K) = ZERO - 70 CONTINUE - DO 110 I = 1, 29 - TI = DFLOAT(I)/C9 - SUM1 = ZERO - TEMP = ONE - DO 80 J = 2, N - SUM1 = SUM1 + DFLOAT(J-1)*TEMP*X(J) - TEMP = TI*TEMP - 80 CONTINUE - SUM2 = ZERO - TEMP = ONE - DO 90 J = 1, N - SUM2 = SUM2 + TEMP*X(J) - TEMP = TI*TEMP - 90 CONTINUE - TEMP1 = SUM1 - SUM2**2 - ONE - TEMP2 = TWO*TI*SUM2 - TEMP = ONE/TI - DO 100 K = 1, N - FVEC(K) = FVEC(K) + TEMP*(DFLOAT(K-1) - TEMP2)*TEMP1 - TEMP = TI*TEMP - 100 CONTINUE - 110 CONTINUE - TEMP = X(2) - X(1)**2 - ONE - FVEC(1) = FVEC(1) + X(1)*(ONE - TWO*TEMP) - FVEC(2) = FVEC(2) + TEMP - GO TO 380 -C -C CHEBYQUAD FUNCTION. -C - 120 CONTINUE - DO 130 K = 1, N - FVEC(K) = ZERO - 130 CONTINUE - DO 150 J = 1, N - TEMP1 = ONE - TEMP2 = TWO*X(J) - ONE - TEMP = TWO*TEMP2 - DO 140 I = 1, N - FVEC(I) = FVEC(I) + TEMP2 - TI = TEMP*TEMP2 - TEMP1 - TEMP1 = TEMP2 - TEMP2 = TI - 140 CONTINUE - 150 CONTINUE - TK = ONE/DFLOAT(N) - IEV = -1 - DO 160 K = 1, N - FVEC(K) = TK*FVEC(K) - IF (IEV .GT. 0) FVEC(K) = FVEC(K) + ONE/(DFLOAT(K)**2 - ONE) - IEV = -IEV - 160 CONTINUE - GO TO 380 -C -C BROWN ALMOST-LINEAR FUNCTION. -C - 170 CONTINUE - SUM = -DFLOAT(N+1) - PROD = ONE - DO 180 J = 1, N - SUM = SUM + X(J) - PROD = X(J)*PROD - 180 CONTINUE - DO 190 K = 1, N - FVEC(K) = X(K) + SUM - 190 CONTINUE - FVEC(N) = PROD - ONE - GO TO 380 -C -C DISCRETE BOUNDARY VALUE FUNCTION. -C - 200 CONTINUE - H = ONE/DFLOAT(N+1) - DO 210 K = 1, N - TEMP = (X(K) + DFLOAT(K)*H + ONE)**3 - TEMP1 = ZERO - IF (K .NE. 1) TEMP1 = X(K-1) - TEMP2 = ZERO - IF (K .NE. N) TEMP2 = X(K+1) - FVEC(K) = TWO*X(K) - TEMP1 - TEMP2 + TEMP*H**2/TWO - 210 CONTINUE - GO TO 380 -C -C DISCRETE INTEGRAL EQUATION FUNCTION. -C - 220 CONTINUE - H = ONE/DFLOAT(N+1) - DO 260 K = 1, N - TK = DFLOAT(K)*H - SUM1 = ZERO - DO 230 J = 1, K - TJ = DFLOAT(J)*H - TEMP = (X(J) + TJ + ONE)**3 - SUM1 = SUM1 + TJ*TEMP - 230 CONTINUE - SUM2 = ZERO - KP1 = K + 1 - IF (N .LT. KP1) GO TO 250 - DO 240 J = KP1, N - TJ = DFLOAT(J)*H - TEMP = (X(J) + TJ + ONE)**3 - SUM2 = SUM2 + (ONE - TJ)*TEMP - 240 CONTINUE - 250 CONTINUE - FVEC(K) = X(K) + H*((ONE - TK)*SUM1 + TK*SUM2)/TWO - 260 CONTINUE - GO TO 380 -C -C TRIGONOMETRIC FUNCTION. -C - 270 CONTINUE - SUM = ZERO - DO 280 J = 1, N - FVEC(J) = DCOS(X(J)) - SUM = SUM + FVEC(J) - 280 CONTINUE - DO 290 K = 1, N - FVEC(K) = DFLOAT(N+K) - DSIN(X(K)) - SUM - DFLOAT(K)*FVEC(K) - 290 CONTINUE - GO TO 380 -C -C VARIABLY DIMENSIONED FUNCTION. -C - 300 CONTINUE - SUM = ZERO - DO 310 J = 1, N - SUM = SUM + DFLOAT(J)*(X(J) - ONE) - 310 CONTINUE - TEMP = SUM*(ONE + TWO*SUM**2) - DO 320 K = 1, N - FVEC(K) = X(K) - ONE + DFLOAT(K)*TEMP - 320 CONTINUE - GO TO 380 -C -C BROYDEN TRIDIAGONAL FUNCTION. -C - 330 CONTINUE - DO 340 K = 1, N - TEMP = (THREE - TWO*X(K))*X(K) - TEMP1 = ZERO - IF (K .NE. 1) TEMP1 = X(K-1) - TEMP2 = ZERO - IF (K .NE. N) TEMP2 = X(K+1) - FVEC(K) = TEMP - TEMP1 - TWO*TEMP2 + ONE - 340 CONTINUE - GO TO 380 -C -C BROYDEN BANDED FUNCTION. -C - 350 CONTINUE - ML = 5 - MU = 1 - DO 370 K = 1, N - K1 = MAX0(1,K-ML) - K2 = MIN0(K+MU,N) - TEMP = ZERO - DO 360 J = K1, K2 - IF (J .NE. K) TEMP = TEMP + X(J)*(ONE + X(J)) - 360 CONTINUE - FVEC(K) = X(K)*(TWO + FIVE*X(K)**2) + ONE - TEMP - 370 CONTINUE - 380 CONTINUE - RETURN -C -C LAST CARD OF SUBROUTINE VECFCN. -C - END diff --git a/ex/file17 b/ex/file17 deleted file mode 100644 index e901bac..0000000 --- a/ex/file17 +++ /dev/null @@ -1,1025 +0,0 @@ -C ********** -C -C THIS PROGRAM TESTS CODES FOR THE LEAST-SQUARES SOLUTION OF -C M NONLINEAR EQUATIONS IN N VARIABLES. IT CONSISTS OF A DRIVER -C AND AN INTERFACE SUBROUTINE FCN. THE DRIVER READS IN DATA, -C CALLS THE NONLINEAR LEAST-SQUARES SOLVER, AND FINALLY PRINTS -C OUT INFORMATION ON THE PERFORMANCE OF THE SOLVER. THIS IS -C ONLY A SAMPLE DRIVER, MANY OTHER DRIVERS ARE POSSIBLE. THE -C INTERFACE SUBROUTINE FCN IS NECESSARY TO TAKE INTO ACCOUNT THE -C FORMS OF CALLING SEQUENCES USED BY THE FUNCTION AND JACOBIAN -C SUBROUTINES IN THE VARIOUS NONLINEAR LEAST-SQUARES SOLVERS. -C -C SUBPROGRAMS CALLED -C -C USER-SUPPLIED ...... FCN -C -C MINPACK-SUPPLIED ... DPMPAR,ENORM,INITPT,LMDER1,SSQFCN -C -C FORTRAN-SUPPLIED ... DSQRT -C -C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. -C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE -C -C ********** - INTEGER I,IC,INFO,K,LDFJAC,LWA,M,N,NFEV,NJEV,NPROB,NREAD,NTRIES, - * NWRITE - INTEGER IWA(40),MA(60),NA(60),NF(60),NJ(60),NP(60),NX(60) - DOUBLE PRECISION FACTOR,FNORM1,FNORM2,ONE,TEN,TOL - DOUBLE PRECISION FJAC(65,40),FNM(60),FVEC(65),WA(265),X(40) - DOUBLE PRECISION DPMPAR,ENORM - EXTERNAL FCN - COMMON /REFNUM/ NPROB,NFEV,NJEV -C -C LOGICAL INPUT UNIT IS ASSUMED TO BE NUMBER 5. -C LOGICAL OUTPUT UNIT IS ASSUMED TO BE NUMBER 6. -C - DATA NREAD,NWRITE /5,6/ -C - DATA ONE,TEN /1.0D0,1.0D1/ - TOL = DSQRT(DPMPAR(1)) - LDFJAC = 65 - LWA = 265 - IC = 0 - 10 CONTINUE - READ (NREAD,50) NPROB,N,M,NTRIES - IF (NPROB .LE. 0) GO TO 30 - FACTOR = ONE - DO 20 K = 1, NTRIES - IC = IC + 1 - CALL INITPT(N,X,NPROB,FACTOR) - CALL SSQFCN(M,N,X,FVEC,NPROB) - FNORM1 = ENORM(M,FVEC) - WRITE (NWRITE,60) NPROB,N,M - NFEV = 0 - NJEV = 0 - CALL LMDER1(FCN,M,N,X,FVEC,FJAC,LDFJAC,TOL,INFO,IWA,WA, - * LWA) - CALL SSQFCN(M,N,X,FVEC,NPROB) - FNORM2 = ENORM(M,FVEC) - NP(IC) = NPROB - NA(IC) = N - MA(IC) = M - NF(IC) = NFEV - NJ(IC) = NJEV - NX(IC) = INFO - FNM(IC) = FNORM2 - WRITE (NWRITE,70) - * FNORM1,FNORM2,NFEV,NJEV,INFO,(X(I), I = 1, N) - FACTOR = TEN*FACTOR - 20 CONTINUE - GO TO 10 - 30 CONTINUE - WRITE (NWRITE,80) IC - WRITE (NWRITE,90) - DO 40 I = 1, IC - WRITE (NWRITE,100) NP(I),NA(I),MA(I),NF(I),NJ(I),NX(I),FNM(I) - 40 CONTINUE - STOP - 50 FORMAT (4I5) - 60 FORMAT ( //// 5X, 8H PROBLEM, I5, 5X, 11H DIMENSIONS, 2I5, 5X // - * ) - 70 FORMAT (5X, 33H INITIAL L2 NORM OF THE RESIDUALS, D15.7 // 5X, - * 33H FINAL L2 NORM OF THE RESIDUALS , D15.7 // 5X, - * 33H NUMBER OF FUNCTION EVALUATIONS , I10 // 5X, - * 33H NUMBER OF JACOBIAN EVALUATIONS , I10 // 5X, - * 15H EXIT PARAMETER, 18X, I10 // 5X, - * 27H FINAL APPROXIMATE SOLUTION // (5X, 5D15.7)) - 80 FORMAT (12H1SUMMARY OF , I3, 16H CALLS TO LMDER1 /) - 90 FORMAT (49H NPROB N M NFEV NJEV INFO FINAL L2 NORM /) - 100 FORMAT (3I5, 3I6, 1X, D15.7) -C -C LAST CARD OF DRIVER. -C - END - SUBROUTINE FCN(M,N,X,FVEC,FJAC,LDFJAC,IFLAG) - INTEGER M,N,LDFJAC,IFLAG - DOUBLE PRECISION X(N),FVEC(M),FJAC(LDFJAC,N) -C ********** -C -C THE CALLING SEQUENCE OF FCN SHOULD BE IDENTICAL TO THE -C CALLING SEQUENCE OF THE FUNCTION SUBROUTINE IN THE NONLINEAR -C LEAST-SQUARES SOLVER. FCN SHOULD ONLY CALL THE TESTING -C FUNCTION AND JACOBIAN SUBROUTINES SSQFCN AND SSQJAC WITH -C THE APPROPRIATE VALUE OF PROBLEM NUMBER (NPROB). -C -C SUBPROGRAMS CALLED -C -C MINPACK-SUPPLIED ... SSQFCN,SSQJAC -C -C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. -C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE -C -C ********** - INTEGER NPROB,NFEV,NJEV - COMMON /REFNUM/ NPROB,NFEV,NJEV - IF (IFLAG .EQ. 1) CALL SSQFCN(M,N,X,FVEC,NPROB) - IF (IFLAG .EQ. 2) CALL SSQJAC(M,N,X,FJAC,LDFJAC,NPROB) - IF (IFLAG .EQ. 1) NFEV = NFEV + 1 - IF (IFLAG .EQ. 2) NJEV = NJEV + 1 - RETURN -C -C LAST CARD OF INTERFACE SUBROUTINE FCN. -C - END - SUBROUTINE SSQJAC(M,N,X,FJAC,LDFJAC,NPROB) - INTEGER M,N,LDFJAC,NPROB - DOUBLE PRECISION X(N),FJAC(LDFJAC,N) -C ********** -C -C SUBROUTINE SSQJAC -C -C THIS SUBROUTINE DEFINES THE JACOBIAN MATRICES OF EIGHTEEN -C NONLINEAR LEAST SQUARES PROBLEMS. THE PROBLEM DIMENSIONS ARE -C AS DESCRIBED IN THE PROLOGUE COMMENTS OF SSQFCN. -C -C THE SUBROUTINE STATEMENT IS -C -C SUBROUTINE SSQJAC(M,N,X,FJAC,LDFJAC,NPROB) -C -C WHERE -C -C M AND N ARE POSITIVE INTEGER INPUT VARIABLES. N MUST NOT -C EXCEED M. -C -C X IS AN INPUT ARRAY OF LENGTH N. -C -C FJAC IS AN M BY N OUTPUT ARRAY WHICH CONTAINS THE JACOBIAN -C MATRIX OF THE NPROB FUNCTION EVALUATED AT X. -C -C LDFJAC IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN M -C WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY FJAC. -C -C NPROB IS A POSITIVE INTEGER VARIABLE WHICH DEFINES THE -C NUMBER OF THE PROBLEM. NPROB MUST NOT EXCEED 18. -C -C SUBPROGRAMS CALLED -C -C FORTRAN-SUPPLIED ... DATAN,DCOS,DEXP,DSIN,DSQRT -C -C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. -C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE -C -C ********** - INTEGER I,IVAR,J,K,MM1,NM1 - DOUBLE PRECISION C14,C20,C29,C45,C100,DIV,DX,EIGHT,FIVE,FOUR, - * ONE,PROD,S2,TEMP,TEN,THREE,TI,TMP1,TMP2,TMP3, - * TMP4,TPI,TWO,ZERO - DOUBLE PRECISION V(11) - DOUBLE PRECISION DFLOAT - DATA ZERO,ONE,TWO,THREE,FOUR,FIVE,EIGHT,TEN,C14,C20,C29,C45,C100 - * /0.0D0,1.0D0,2.0D0,3.0D0,4.0D0,5.0D0,8.0D0,1.0D1,1.4D1, - * 2.0D1,2.9D1,4.5D1,1.0D2/ - DATA V(1),V(2),V(3),V(4),V(5),V(6),V(7),V(8),V(9),V(10),V(11) - * /4.0D0,2.0D0,1.0D0,5.0D-1,2.5D-1,1.67D-1,1.25D-1,1.0D-1, - * 8.33D-2,7.14D-2,6.25D-2/ - DFLOAT(IVAR) = IVAR -C -C JACOBIAN ROUTINE SELECTOR. -C - GO TO (10,40,70,130,140,150,180,190,210,230,250,310,330,350,370, - * 400,460,480), NPROB -C -C LINEAR FUNCTION - FULL RANK. -C - 10 CONTINUE - TEMP = TWO/DFLOAT(M) - DO 30 J = 1, N - DO 20 I = 1, M - FJAC(I,J) = -TEMP - 20 CONTINUE - FJAC(J,J) = FJAC(J,J) + ONE - 30 CONTINUE - GO TO 500 -C -C LINEAR FUNCTION - RANK 1. -C - 40 CONTINUE - DO 60 J = 1, N - DO 50 I = 1, M - FJAC(I,J) = DFLOAT(I)*DFLOAT(J) - 50 CONTINUE - 60 CONTINUE - GO TO 500 -C -C LINEAR FUNCTION - RANK 1 WITH ZERO COLUMNS AND ROWS. -C - 70 CONTINUE - DO 90 J = 1, N - DO 80 I = 1, M - FJAC(I,J) = ZERO - 80 CONTINUE - 90 CONTINUE - NM1 = N - 1 - MM1 = M - 1 - IF (NM1 .LT. 2) GO TO 120 - DO 110 J = 2, NM1 - DO 100 I = 2, MM1 - FJAC(I,J) = DFLOAT(I-1)*DFLOAT(J) - 100 CONTINUE - 110 CONTINUE - 120 CONTINUE - GO TO 500 -C -C ROSENBROCK FUNCTION. -C - 130 CONTINUE - FJAC(1,1) = -C20*X(1) - FJAC(1,2) = TEN - FJAC(2,1) = -ONE - FJAC(2,2) = ZERO - GO TO 500 -C -C HELICAL VALLEY FUNCTION. -C - 140 CONTINUE - TPI = EIGHT*DATAN(ONE) - TEMP = X(1)**2 + X(2)**2 - TMP1 = TPI*TEMP - TMP2 = DSQRT(TEMP) - FJAC(1,1) = C100*X(2)/TMP1 - FJAC(1,2) = -C100*X(1)/TMP1 - FJAC(1,3) = TEN - FJAC(2,1) = TEN*X(1)/TMP2 - FJAC(2,2) = TEN*X(2)/TMP2 - FJAC(2,3) = ZERO - FJAC(3,1) = ZERO - FJAC(3,2) = ZERO - FJAC(3,3) = ONE - GO TO 500 -C -C POWELL SINGULAR FUNCTION. -C - 150 CONTINUE - DO 170 J = 1, 4 - DO 160 I = 1, 4 - FJAC(I,J) = ZERO - 160 CONTINUE - 170 CONTINUE - FJAC(1,1) = ONE - FJAC(1,2) = TEN - FJAC(2,3) = DSQRT(FIVE) - FJAC(2,4) = -FJAC(2,3) - FJAC(3,2) = TWO*(X(2) - TWO*X(3)) - FJAC(3,3) = -TWO*FJAC(3,2) - FJAC(4,1) = TWO*DSQRT(TEN)*(X(1) - X(4)) - FJAC(4,4) = -FJAC(4,1) - GO TO 500 -C -C FREUDENSTEIN AND ROTH FUNCTION. -C - 180 CONTINUE - FJAC(1,1) = ONE - FJAC(1,2) = X(2)*(TEN - THREE*X(2)) - TWO - FJAC(2,1) = ONE - FJAC(2,2) = X(2)*(TWO + THREE*X(2)) - C14 - GO TO 500 -C -C BARD FUNCTION. -C - 190 CONTINUE - DO 200 I = 1, 15 - TMP1 = DFLOAT(I) - TMP2 = DFLOAT(16-I) - TMP3 = TMP1 - IF (I .GT. 8) TMP3 = TMP2 - TMP4 = (X(2)*TMP2 + X(3)*TMP3)**2 - FJAC(I,1) = -ONE - FJAC(I,2) = TMP1*TMP2/TMP4 - FJAC(I,3) = TMP1*TMP3/TMP4 - 200 CONTINUE - GO TO 500 -C -C KOWALIK AND OSBORNE FUNCTION. -C - 210 CONTINUE - DO 220 I = 1, 11 - TMP1 = V(I)*(V(I) + X(2)) - TMP2 = V(I)*(V(I) + X(3)) + X(4) - FJAC(I,1) = -TMP1/TMP2 - FJAC(I,2) = -V(I)*X(1)/TMP2 - FJAC(I,3) = FJAC(I,1)*FJAC(I,2) - FJAC(I,4) = FJAC(I,3)/V(I) - 220 CONTINUE - GO TO 500 -C -C MEYER FUNCTION. -C - 230 CONTINUE - DO 240 I = 1, 16 - TEMP = FIVE*DFLOAT(I) + C45 + X(3) - TMP1 = X(2)/TEMP - TMP2 = DEXP(TMP1) - FJAC(I,1) = TMP2 - FJAC(I,2) = X(1)*TMP2/TEMP - FJAC(I,3) = -TMP1*FJAC(I,2) - 240 CONTINUE - GO TO 500 -C -C WATSON FUNCTION. -C - 250 CONTINUE - DO 280 I = 1, 29 - DIV = DFLOAT(I)/C29 - S2 = ZERO - DX = ONE - DO 260 J = 1, N - S2 = S2 + DX*X(J) - DX = DIV*DX - 260 CONTINUE - TEMP = TWO*DIV*S2 - DX = ONE/DIV - DO 270 J = 1, N - FJAC(I,J) = DX*(DFLOAT(J-1) - TEMP) - DX = DIV*DX - 270 CONTINUE - 280 CONTINUE - DO 300 J = 1, N - DO 290 I = 30, 31 - FJAC(I,J) = ZERO - 290 CONTINUE - 300 CONTINUE - FJAC(30,1) = ONE - FJAC(31,1) = -TWO*X(1) - FJAC(31,2) = ONE - GO TO 500 -C -C BOX 3-DIMENSIONAL FUNCTION. -C - 310 CONTINUE - DO 320 I = 1, M - TEMP = DFLOAT(I) - TMP1 = TEMP/TEN - FJAC(I,1) = -TMP1*DEXP(-TMP1*X(1)) - FJAC(I,2) = TMP1*DEXP(-TMP1*X(2)) - FJAC(I,3) = DEXP(-TEMP) - DEXP(-TMP1) - 320 CONTINUE - GO TO 500 -C -C JENNRICH AND SAMPSON FUNCTION. -C - 330 CONTINUE - DO 340 I = 1, M - TEMP = DFLOAT(I) - FJAC(I,1) = -TEMP*DEXP(TEMP*X(1)) - FJAC(I,2) = -TEMP*DEXP(TEMP*X(2)) - 340 CONTINUE - GO TO 500 -C -C BROWN AND DENNIS FUNCTION. -C - 350 CONTINUE - DO 360 I = 1, M - TEMP = DFLOAT(I)/FIVE - TI = DSIN(TEMP) - TMP1 = X(1) + TEMP*X(2) - DEXP(TEMP) - TMP2 = X(3) + TI*X(4) - DCOS(TEMP) - FJAC(I,1) = TWO*TMP1 - FJAC(I,2) = TEMP*FJAC(I,1) - FJAC(I,3) = TWO*TMP2 - FJAC(I,4) = TI*FJAC(I,3) - 360 CONTINUE - GO TO 500 -C -C CHEBYQUAD FUNCTION. -C - 370 CONTINUE - DX = ONE/DFLOAT(N) - DO 390 J = 1, N - TMP1 = ONE - TMP2 = TWO*X(J) - ONE - TEMP = TWO*TMP2 - TMP3 = ZERO - TMP4 = TWO - DO 380 I = 1, M - FJAC(I,J) = DX*TMP4 - TI = FOUR*TMP2 + TEMP*TMP4 - TMP3 - TMP3 = TMP4 - TMP4 = TI - TI = TEMP*TMP2 - TMP1 - TMP1 = TMP2 - TMP2 = TI - 380 CONTINUE - 390 CONTINUE - GO TO 500 -C -C BROWN ALMOST-LINEAR FUNCTION. -C - 400 CONTINUE - PROD = ONE - DO 420 J = 1, N - PROD = X(J)*PROD - DO 410 I = 1, N - FJAC(I,J) = ONE - 410 CONTINUE - FJAC(J,J) = TWO - 420 CONTINUE - DO 450 J = 1, N - TEMP = X(J) - IF (TEMP .NE. ZERO) GO TO 440 - TEMP = ONE - PROD = ONE - DO 430 K = 1, N - IF (K .NE. J) PROD = X(K)*PROD - 430 CONTINUE - 440 CONTINUE - FJAC(N,J) = PROD/TEMP - 450 CONTINUE - GO TO 500 -C -C OSBORNE 1 FUNCTION. -C - 460 CONTINUE - DO 470 I = 1, 33 - TEMP = TEN*DFLOAT(I-1) - TMP1 = DEXP(-X(4)*TEMP) - TMP2 = DEXP(-X(5)*TEMP) - FJAC(I,1) = -ONE - FJAC(I,2) = -TMP1 - FJAC(I,3) = -TMP2 - FJAC(I,4) = TEMP*X(2)*TMP1 - FJAC(I,5) = TEMP*X(3)*TMP2 - 470 CONTINUE - GO TO 500 -C -C OSBORNE 2 FUNCTION. -C - 480 CONTINUE - DO 490 I = 1, 65 - TEMP = DFLOAT(I-1)/TEN - TMP1 = DEXP(-X(5)*TEMP) - TMP2 = DEXP(-X(6)*(TEMP-X(9))**2) - TMP3 = DEXP(-X(7)*(TEMP-X(10))**2) - TMP4 = DEXP(-X(8)*(TEMP-X(11))**2) - FJAC(I,1) = -TMP1 - FJAC(I,2) = -TMP2 - FJAC(I,3) = -TMP3 - FJAC(I,4) = -TMP4 - FJAC(I,5) = TEMP*X(1)*TMP1 - FJAC(I,6) = X(2)*(TEMP - X(9))**2*TMP2 - FJAC(I,7) = X(3)*(TEMP - X(10))**2*TMP3 - FJAC(I,8) = X(4)*(TEMP - X(11))**2*TMP4 - FJAC(I,9) = -TWO*X(2)*X(6)*(TEMP - X(9))*TMP2 - FJAC(I,10) = -TWO*X(3)*X(7)*(TEMP - X(10))*TMP3 - FJAC(I,11) = -TWO*X(4)*X(8)*(TEMP - X(11))*TMP4 - 490 CONTINUE - 500 CONTINUE - RETURN -C -C LAST CARD OF SUBROUTINE SSQJAC. -C - END - SUBROUTINE INITPT(N,X,NPROB,FACTOR) - INTEGER N,NPROB - DOUBLE PRECISION FACTOR - DOUBLE PRECISION X(N) -C ********** -C -C SUBROUTINE INITPT -C -C THIS SUBROUTINE SPECIFIES THE STANDARD STARTING POINTS FOR THE -C FUNCTIONS DEFINED BY SUBROUTINE SSQFCN. THE SUBROUTINE RETURNS -C IN X A MULTIPLE (FACTOR) OF THE STANDARD STARTING POINT. FOR -C THE 11TH FUNCTION THE STANDARD STARTING POINT IS ZERO, SO IN -C THIS CASE, IF FACTOR IS NOT UNITY, THEN THE SUBROUTINE RETURNS -C THE VECTOR X(J) = FACTOR, J=1,...,N. -C -C THE SUBROUTINE STATEMENT IS -C -C SUBROUTINE INITPT(N,X,NPROB,FACTOR) -C -C WHERE -C -C N IS A POSITIVE INTEGER INPUT VARIABLE. -C -C X IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE STANDARD -C STARTING POINT FOR PROBLEM NPROB MULTIPLIED BY FACTOR. -C -C NPROB IS A POSITIVE INTEGER INPUT VARIABLE WHICH DEFINES THE -C NUMBER OF THE PROBLEM. NPROB MUST NOT EXCEED 18. -C -C FACTOR IS AN INPUT VARIABLE WHICH SPECIFIES THE MULTIPLE OF -C THE STANDARD STARTING POINT. IF FACTOR IS UNITY, NO -C MULTIPLICATION IS PERFORMED. -C -C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. -C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE -C -C ********** - INTEGER IVAR,J - DOUBLE PRECISION C1,C2,C3,C4,C5,C6,C7,C8,C9,C10,C11,C12,C13,C14, - * C15,C16,C17,FIVE,H,HALF,ONE,SEVEN,TEN,THREE, - * TWENTY,TWNTF,TWO,ZERO - DOUBLE PRECISION DFLOAT - DATA ZERO,HALF,ONE,TWO,THREE,FIVE,SEVEN,TEN,TWENTY,TWNTF - * /0.0D0,5.0D-1,1.0D0,2.0D0,3.0D0,5.0D0,7.0D0,1.0D1,2.0D1, - * 2.5D1/ - DATA C1,C2,C3,C4,C5,C6,C7,C8,C9,C10,C11,C12,C13,C14,C15,C16,C17 - * /1.2D0,2.5D-1,3.9D-1,4.15D-1,2.0D-2,4.0D3,2.5D2,3.0D-1, - * 4.0D-1,1.5D0,1.0D-2,1.3D0,6.5D-1,7.0D-1,6.0D-1,4.5D0, - * 5.5D0/ - DFLOAT(IVAR) = IVAR -C -C SELECTION OF INITIAL POINT. -C - GO TO (10,10,10,30,40,50,60,70,80,90,100,120,130,140,150,170, - * 190,200), NPROB -C -C LINEAR FUNCTION - FULL RANK OR RANK 1. -C - 10 CONTINUE - DO 20 J = 1, N - X(J) = ONE - 20 CONTINUE - GO TO 210 -C -C ROSENBROCK FUNCTION. -C - 30 CONTINUE - X(1) = -C1 - X(2) = ONE - GO TO 210 -C -C HELICAL VALLEY FUNCTION. -C - 40 CONTINUE - X(1) = -ONE - X(2) = ZERO - X(3) = ZERO - GO TO 210 -C -C POWELL SINGULAR FUNCTION. -C - 50 CONTINUE - X(1) = THREE - X(2) = -ONE - X(3) = ZERO - X(4) = ONE - GO TO 210 -C -C FREUDENSTEIN AND ROTH FUNCTION. -C - 60 CONTINUE - X(1) = HALF - X(2) = -TWO - GO TO 210 -C -C BARD FUNCTION. -C - 70 CONTINUE - X(1) = ONE - X(2) = ONE - X(3) = ONE - GO TO 210 -C -C KOWALIK AND OSBORNE FUNCTION. -C - 80 CONTINUE - X(1) = C2 - X(2) = C3 - X(3) = C4 - X(4) = C3 - GO TO 210 -C -C MEYER FUNCTION. -C - 90 CONTINUE - X(1) = C5 - X(2) = C6 - X(3) = C7 - GO TO 210 -C -C WATSON FUNCTION. -C - 100 CONTINUE - DO 110 J = 1, N - X(J) = ZERO - 110 CONTINUE - GO TO 210 -C -C BOX 3-DIMENSIONAL FUNCTION. -C - 120 CONTINUE - X(1) = ZERO - X(2) = TEN - X(3) = TWENTY - GO TO 210 -C -C JENNRICH AND SAMPSON FUNCTION. -C - 130 CONTINUE - X(1) = C8 - X(2) = C9 - GO TO 210 -C -C BROWN AND DENNIS FUNCTION. -C - 140 CONTINUE - X(1) = TWNTF - X(2) = FIVE - X(3) = -FIVE - X(4) = -ONE - GO TO 210 -C -C CHEBYQUAD FUNCTION. -C - 150 CONTINUE - H = ONE/DFLOAT(N+1) - DO 160 J = 1, N - X(J) = DFLOAT(J)*H - 160 CONTINUE - GO TO 210 -C -C BROWN ALMOST-LINEAR FUNCTION. -C - 170 CONTINUE - DO 180 J = 1, N - X(J) = HALF - 180 CONTINUE - GO TO 210 -C -C OSBORNE 1 FUNCTION. -C - 190 CONTINUE - X(1) = HALF - X(2) = C10 - X(3) = -ONE - X(4) = C11 - X(5) = C5 - GO TO 210 -C -C OSBORNE 2 FUNCTION. -C - 200 CONTINUE - X(1) = C12 - X(2) = C13 - X(3) = C13 - X(4) = C14 - X(5) = C15 - X(6) = THREE - X(7) = FIVE - X(8) = SEVEN - X(9) = TWO - X(10) = C16 - X(11) = C17 - 210 CONTINUE -C -C COMPUTE MULTIPLE OF INITIAL POINT. -C - IF (FACTOR .EQ. ONE) GO TO 260 - IF (NPROB .EQ. 11) GO TO 230 - DO 220 J = 1, N - X(J) = FACTOR*X(J) - 220 CONTINUE - GO TO 250 - 230 CONTINUE - DO 240 J = 1, N - X(J) = FACTOR - 240 CONTINUE - 250 CONTINUE - 260 CONTINUE - RETURN -C -C LAST CARD OF SUBROUTINE INITPT. -C - END - SUBROUTINE SSQFCN(M,N,X,FVEC,NPROB) - INTEGER M,N,NPROB - DOUBLE PRECISION X(N),FVEC(M) -C ********** -C -C SUBROUTINE SSQFCN -C -C THIS SUBROUTINE DEFINES THE FUNCTIONS OF EIGHTEEN NONLINEAR -C LEAST SQUARES PROBLEMS. THE ALLOWABLE VALUES OF (M,N) FOR -C FUNCTIONS 1,2 AND 3 ARE VARIABLE BUT WITH M .GE. N. -C FOR FUNCTIONS 4,5,6,7,8,9 AND 10 THE VALUES OF (M,N) ARE -C (2,2),(3,3),(4,4),(2,2),(15,3),(11,4) AND (16,3), RESPECTIVELY. -C FUNCTION 11 (WATSON) HAS M = 31 WITH N USUALLY 6 OR 9. -C HOWEVER, ANY N, N = 2,...,31, IS PERMITTED. -C FUNCTIONS 12,13 AND 14 HAVE N = 3,2 AND 4, RESPECTIVELY, BUT -C ALLOW ANY M .GE. N, WITH THE USUAL CHOICES BEING 10,10 AND 20. -C FUNCTION 15 (CHEBYQUAD) ALLOWS M AND N VARIABLE WITH M .GE. N. -C FUNCTION 16 (BROWN) ALLOWS N VARIABLE WITH M = N. -C FOR FUNCTIONS 17 AND 18, THE VALUES OF (M,N) ARE -C (33,5) AND (65,11), RESPECTIVELY. -C -C THE SUBROUTINE STATEMENT IS -C -C SUBROUTINE SSQFCN(M,N,X,FVEC,NPROB) -C -C WHERE -C -C M AND N ARE POSITIVE INTEGER INPUT VARIABLES. N MUST NOT -C EXCEED M. -C -C X IS AN INPUT ARRAY OF LENGTH N. -C -C FVEC IS AN OUTPUT ARRAY OF LENGTH M WHICH CONTAINS THE NPROB -C FUNCTION EVALUATED AT X. -C -C NPROB IS A POSITIVE INTEGER INPUT VARIABLE WHICH DEFINES THE -C NUMBER OF THE PROBLEM. NPROB MUST NOT EXCEED 18. -C -C SUBPROGRAMS CALLED -C -C FORTRAN-SUPPLIED ... DATAN,DCOS,DEXP,DSIN,DSQRT,DSIGN -C -C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. -C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE -C -C ********** - INTEGER I,IEV,IVAR,J,NM1 - DOUBLE PRECISION C13,C14,C29,C45,DIV,DX,EIGHT,FIVE,ONE,PROD,SUM, - * S1,S2,TEMP,TEN,TI,TMP1,TMP2,TMP3,TMP4,TPI,TWO, - * ZERO,ZP25,ZP5 - DOUBLE PRECISION V(11),Y1(15),Y2(11),Y3(16),Y4(33),Y5(65) - DOUBLE PRECISION DFLOAT - DATA ZERO,ZP25,ZP5,ONE,TWO,FIVE,EIGHT,TEN,C13,C14,C29,C45 - * /0.0D0,2.5D-1,5.0D-1,1.0D0,2.0D0,5.0D0,8.0D0,1.0D1,1.3D1, - * 1.4D1,2.9D1,4.5D1/ - DATA V(1),V(2),V(3),V(4),V(5),V(6),V(7),V(8),V(9),V(10),V(11) - * /4.0D0,2.0D0,1.0D0,5.0D-1,2.5D-1,1.67D-1,1.25D-1,1.0D-1, - * 8.33D-2,7.14D-2,6.25D-2/ - DATA Y1(1),Y1(2),Y1(3),Y1(4),Y1(5),Y1(6),Y1(7),Y1(8),Y1(9), - * Y1(10),Y1(11),Y1(12),Y1(13),Y1(14),Y1(15) - * /1.4D-1,1.8D-1,2.2D-1,2.5D-1,2.9D-1,3.2D-1,3.5D-1,3.9D-1, - * 3.7D-1,5.8D-1,7.3D-1,9.6D-1,1.34D0,2.1D0,4.39D0/ - DATA Y2(1),Y2(2),Y2(3),Y2(4),Y2(5),Y2(6),Y2(7),Y2(8),Y2(9), - * Y2(10),Y2(11) - * /1.957D-1,1.947D-1,1.735D-1,1.6D-1,8.44D-2,6.27D-2,4.56D-2, - * 3.42D-2,3.23D-2,2.35D-2,2.46D-2/ - DATA Y3(1),Y3(2),Y3(3),Y3(4),Y3(5),Y3(6),Y3(7),Y3(8),Y3(9), - * Y3(10),Y3(11),Y3(12),Y3(13),Y3(14),Y3(15),Y3(16) - * /3.478D4,2.861D4,2.365D4,1.963D4,1.637D4,1.372D4,1.154D4, - * 9.744D3,8.261D3,7.03D3,6.005D3,5.147D3,4.427D3,3.82D3, - * 3.307D3,2.872D3/ - DATA Y4(1),Y4(2),Y4(3),Y4(4),Y4(5),Y4(6),Y4(7),Y4(8),Y4(9), - * Y4(10),Y4(11),Y4(12),Y4(13),Y4(14),Y4(15),Y4(16),Y4(17), - * Y4(18),Y4(19),Y4(20),Y4(21),Y4(22),Y4(23),Y4(24),Y4(25), - * Y4(26),Y4(27),Y4(28),Y4(29),Y4(30),Y4(31),Y4(32),Y4(33) - * /8.44D-1,9.08D-1,9.32D-1,9.36D-1,9.25D-1,9.08D-1,8.81D-1, - * 8.5D-1,8.18D-1,7.84D-1,7.51D-1,7.18D-1,6.85D-1,6.58D-1, - * 6.28D-1,6.03D-1,5.8D-1,5.58D-1,5.38D-1,5.22D-1,5.06D-1, - * 4.9D-1,4.78D-1,4.67D-1,4.57D-1,4.48D-1,4.38D-1,4.31D-1, - * 4.24D-1,4.2D-1,4.14D-1,4.11D-1,4.06D-1/ - DATA Y5(1),Y5(2),Y5(3),Y5(4),Y5(5),Y5(6),Y5(7),Y5(8),Y5(9), - * Y5(10),Y5(11),Y5(12),Y5(13),Y5(14),Y5(15),Y5(16),Y5(17), - * Y5(18),Y5(19),Y5(20),Y5(21),Y5(22),Y5(23),Y5(24),Y5(25), - * Y5(26),Y5(27),Y5(28),Y5(29),Y5(30),Y5(31),Y5(32),Y5(33), - * Y5(34),Y5(35),Y5(36),Y5(37),Y5(38),Y5(39),Y5(40),Y5(41), - * Y5(42),Y5(43),Y5(44),Y5(45),Y5(46),Y5(47),Y5(48),Y5(49), - * Y5(50),Y5(51),Y5(52),Y5(53),Y5(54),Y5(55),Y5(56),Y5(57), - * Y5(58),Y5(59),Y5(60),Y5(61),Y5(62),Y5(63),Y5(64),Y5(65) - * /1.366D0,1.191D0,1.112D0,1.013D0,9.91D-1,8.85D-1,8.31D-1, - * 8.47D-1,7.86D-1,7.25D-1,7.46D-1,6.79D-1,6.08D-1,6.55D-1, - * 6.16D-1,6.06D-1,6.02D-1,6.26D-1,6.51D-1,7.24D-1,6.49D-1, - * 6.49D-1,6.94D-1,6.44D-1,6.24D-1,6.61D-1,6.12D-1,5.58D-1, - * 5.33D-1,4.95D-1,5.0D-1,4.23D-1,3.95D-1,3.75D-1,3.72D-1, - * 3.91D-1,3.96D-1,4.05D-1,4.28D-1,4.29D-1,5.23D-1,5.62D-1, - * 6.07D-1,6.53D-1,6.72D-1,7.08D-1,6.33D-1,6.68D-1,6.45D-1, - * 6.32D-1,5.91D-1,5.59D-1,5.97D-1,6.25D-1,7.39D-1,7.1D-1, - * 7.29D-1,7.2D-1,6.36D-1,5.81D-1,4.28D-1,2.92D-1,1.62D-1, - * 9.8D-2,5.4D-2/ - DFLOAT(IVAR) = IVAR -C -C FUNCTION ROUTINE SELECTOR. -C - GO TO (10,40,70,110,120,130,140,150,170,190,210,250,270,290,310, - * 360,390,410), NPROB -C -C LINEAR FUNCTION - FULL RANK. -C - 10 CONTINUE - SUM = ZERO - DO 20 J = 1, N - SUM = SUM + X(J) - 20 CONTINUE - TEMP = TWO*SUM/DFLOAT(M) + ONE - DO 30 I = 1, M - FVEC(I) = -TEMP - IF (I .LE. N) FVEC(I) = FVEC(I) + X(I) - 30 CONTINUE - GO TO 430 -C -C LINEAR FUNCTION - RANK 1. -C - 40 CONTINUE - SUM = ZERO - DO 50 J = 1, N - SUM = SUM + DFLOAT(J)*X(J) - 50 CONTINUE - DO 60 I = 1, M - FVEC(I) = DFLOAT(I)*SUM - ONE - 60 CONTINUE - GO TO 430 -C -C LINEAR FUNCTION - RANK 1 WITH ZERO COLUMNS AND ROWS. -C - 70 CONTINUE - SUM = ZERO - NM1 = N - 1 - IF (NM1 .LT. 2) GO TO 90 - DO 80 J = 2, NM1 - SUM = SUM + DFLOAT(J)*X(J) - 80 CONTINUE - 90 CONTINUE - DO 100 I = 1, M - FVEC(I) = DFLOAT(I-1)*SUM - ONE - 100 CONTINUE - FVEC(M) = -ONE - GO TO 430 -C -C ROSENBROCK FUNCTION. -C - 110 CONTINUE - FVEC(1) = TEN*(X(2) - X(1)**2) - FVEC(2) = ONE - X(1) - GO TO 430 -C -C HELICAL VALLEY FUNCTION. -C - 120 CONTINUE - TPI = EIGHT*DATAN(ONE) - TMP1 = DSIGN(ZP25,X(2)) - IF (X(1) .GT. ZERO) TMP1 = DATAN(X(2)/X(1))/TPI - IF (X(1) .LT. ZERO) TMP1 = DATAN(X(2)/X(1))/TPI + ZP5 - TMP2 = DSQRT(X(1)**2+X(2)**2) - FVEC(1) = TEN*(X(3) - TEN*TMP1) - FVEC(2) = TEN*(TMP2 - ONE) - FVEC(3) = X(3) - GO TO 430 -C -C POWELL SINGULAR FUNCTION. -C - 130 CONTINUE - FVEC(1) = X(1) + TEN*X(2) - FVEC(2) = DSQRT(FIVE)*(X(3) - X(4)) - FVEC(3) = (X(2) - TWO*X(3))**2 - FVEC(4) = DSQRT(TEN)*(X(1) - X(4))**2 - GO TO 430 -C -C FREUDENSTEIN AND ROTH FUNCTION. -C - 140 CONTINUE - FVEC(1) = -C13 + X(1) + ((FIVE - X(2))*X(2) - TWO)*X(2) - FVEC(2) = -C29 + X(1) + ((ONE + X(2))*X(2) - C14)*X(2) - GO TO 430 -C -C BARD FUNCTION. -C - 150 CONTINUE - DO 160 I = 1, 15 - TMP1 = DFLOAT(I) - TMP2 = DFLOAT(16-I) - TMP3 = TMP1 - IF (I .GT. 8) TMP3 = TMP2 - FVEC(I) = Y1(I) - (X(1) + TMP1/(X(2)*TMP2 + X(3)*TMP3)) - 160 CONTINUE - GO TO 430 -C -C KOWALIK AND OSBORNE FUNCTION. -C - 170 CONTINUE - DO 180 I = 1, 11 - TMP1 = V(I)*(V(I) + X(2)) - TMP2 = V(I)*(V(I) + X(3)) + X(4) - FVEC(I) = Y2(I) - X(1)*TMP1/TMP2 - 180 CONTINUE - GO TO 430 -C -C MEYER FUNCTION. -C - 190 CONTINUE - DO 200 I = 1, 16 - TEMP = FIVE*DFLOAT(I) + C45 + X(3) - TMP1 = X(2)/TEMP - TMP2 = DEXP(TMP1) - FVEC(I) = X(1)*TMP2 - Y3(I) - 200 CONTINUE - GO TO 430 -C -C WATSON FUNCTION. -C - 210 CONTINUE - DO 240 I = 1, 29 - DIV = DFLOAT(I)/C29 - S1 = ZERO - DX = ONE - DO 220 J = 2, N - S1 = S1 + DFLOAT(J-1)*DX*X(J) - DX = DIV*DX - 220 CONTINUE - S2 = ZERO - DX = ONE - DO 230 J = 1, N - S2 = S2 + DX*X(J) - DX = DIV*DX - 230 CONTINUE - FVEC(I) = S1 - S2**2 - ONE - 240 CONTINUE - FVEC(30) = X(1) - FVEC(31) = X(2) - X(1)**2 - ONE - GO TO 430 -C -C BOX 3-DIMENSIONAL FUNCTION. -C - 250 CONTINUE - DO 260 I = 1, M - TEMP = DFLOAT(I) - TMP1 = TEMP/TEN - FVEC(I) = DEXP(-TMP1*X(1)) - DEXP(-TMP1*X(2)) - * + (DEXP(-TEMP) - DEXP(-TMP1))*X(3) - 260 CONTINUE - GO TO 430 -C -C JENNRICH AND SAMPSON FUNCTION. -C - 270 CONTINUE - DO 280 I = 1, M - TEMP = DFLOAT(I) - FVEC(I) = TWO + TWO*TEMP - DEXP(TEMP*X(1)) - DEXP(TEMP*X(2)) - 280 CONTINUE - GO TO 430 -C -C BROWN AND DENNIS FUNCTION. -C - 290 CONTINUE - DO 300 I = 1, M - TEMP = DFLOAT(I)/FIVE - TMP1 = X(1) + TEMP*X(2) - DEXP(TEMP) - TMP2 = X(3) + DSIN(TEMP)*X(4) - DCOS(TEMP) - FVEC(I) = TMP1**2 + TMP2**2 - 300 CONTINUE - GO TO 430 -C -C CHEBYQUAD FUNCTION. -C - 310 CONTINUE - DO 320 I = 1, M - FVEC(I) = ZERO - 320 CONTINUE - DO 340 J = 1, N - TMP1 = ONE - TMP2 = TWO*X(J) - ONE - TEMP = TWO*TMP2 - DO 330 I = 1, M - FVEC(I) = FVEC(I) + TMP2 - TI = TEMP*TMP2 - TMP1 - TMP1 = TMP2 - TMP2 = TI - 330 CONTINUE - 340 CONTINUE - DX = ONE/DFLOAT(N) - IEV = -1 - DO 350 I = 1, M - FVEC(I) = DX*FVEC(I) - IF (IEV .GT. 0) FVEC(I) = FVEC(I) + ONE/(DFLOAT(I)**2 - ONE) - IEV = -IEV - 350 CONTINUE - GO TO 430 -C -C BROWN ALMOST-LINEAR FUNCTION. -C - 360 CONTINUE - SUM = -DFLOAT(N+1) - PROD = ONE - DO 370 J = 1, N - SUM = SUM + X(J) - PROD = X(J)*PROD - 370 CONTINUE - DO 380 I = 1, N - FVEC(I) = X(I) + SUM - 380 CONTINUE - FVEC(N) = PROD - ONE - GO TO 430 -C -C OSBORNE 1 FUNCTION. -C - 390 CONTINUE - DO 400 I = 1, 33 - TEMP = TEN*DFLOAT(I-1) - TMP1 = DEXP(-X(4)*TEMP) - TMP2 = DEXP(-X(5)*TEMP) - FVEC(I) = Y4(I) - (X(1) + X(2)*TMP1 + X(3)*TMP2) - 400 CONTINUE - GO TO 430 -C -C OSBORNE 2 FUNCTION. -C - 410 CONTINUE - DO 420 I = 1, 65 - TEMP = DFLOAT(I-1)/TEN - TMP1 = DEXP(-X(5)*TEMP) - TMP2 = DEXP(-X(6)*(TEMP-X(9))**2) - TMP3 = DEXP(-X(7)*(TEMP-X(10))**2) - TMP4 = DEXP(-X(8)*(TEMP-X(11))**2) - FVEC(I) = Y5(I) - * - (X(1)*TMP1 + X(2)*TMP2 + X(3)*TMP3 + X(4)*TMP4) - 420 CONTINUE - 430 CONTINUE - RETURN -C -C LAST CARD OF SUBROUTINE SSQFCN. -C - END diff --git a/ex/file18 b/ex/file18 deleted file mode 100644 index 7497b7f..0000000 --- a/ex/file18 +++ /dev/null @@ -1,1036 +0,0 @@ -C ********** -C -C THIS PROGRAM TESTS CODES FOR THE LEAST-SQUARES SOLUTION OF -C M NONLINEAR EQUATIONS IN N VARIABLES. IT CONSISTS OF A DRIVER -C AND AN INTERFACE SUBROUTINE FCN. THE DRIVER READS IN DATA, -C CALLS THE NONLINEAR LEAST-SQUARES SOLVER, AND FINALLY PRINTS -C OUT INFORMATION ON THE PERFORMANCE OF THE SOLVER. THIS IS -C ONLY A SAMPLE DRIVER, MANY OTHER DRIVERS ARE POSSIBLE. THE -C INTERFACE SUBROUTINE FCN IS NECESSARY TO TAKE INTO ACCOUNT THE -C FORMS OF CALLING SEQUENCES USED BY THE FUNCTION AND JACOBIAN -C SUBROUTINES IN THE VARIOUS NONLINEAR LEAST-SQUARES SOLVERS. -C -C SUBPROGRAMS CALLED -C -C USER-SUPPLIED ...... FCN -C -C MINPACK-SUPPLIED ... DPMPAR,ENORM,INITPT,LMSTR1,SSQFCN -C -C FORTRAN-SUPPLIED ... DSQRT -C -C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. -C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE -C -C ********** - INTEGER I,IC,INFO,K,LDFJAC,LWA,M,N,NFEV,NJEV,NPROB,NREAD,NTRIES, - * NWRITE - INTEGER IWA(40),MA(60),NA(60),NF(60),NJ(60),NP(60),NX(60) - DOUBLE PRECISION FACTOR,FNORM1,FNORM2,ONE,TEN,TOL - DOUBLE PRECISION FJAC(40,40),FNM(60),FVEC(65),WA(265),X(40) - DOUBLE PRECISION DPMPAR,ENORM - EXTERNAL FCN - COMMON /REFNUM/ NPROB,NFEV,NJEV -C -C LOGICAL INPUT UNIT IS ASSUMED TO BE NUMBER 5. -C LOGICAL OUTPUT UNIT IS ASSUMED TO BE NUMBER 6. -C - DATA NREAD,NWRITE /5,6/ -C - DATA ONE,TEN /1.0D0,1.0D1/ - TOL = DSQRT(DPMPAR(1)) - LDFJAC = 40 - LWA = 265 - IC = 0 - 10 CONTINUE - READ (NREAD,50) NPROB,N,M,NTRIES - IF (NPROB .LE. 0) GO TO 30 - FACTOR = ONE - DO 20 K = 1, NTRIES - IC = IC + 1 - CALL INITPT(N,X,NPROB,FACTOR) - CALL SSQFCN(M,N,X,FVEC,NPROB) - FNORM1 = ENORM(M,FVEC) - WRITE (NWRITE,60) NPROB,N,M - NFEV = 0 - NJEV = 0 - CALL LMSTR1(FCN,M,N,X,FVEC,FJAC,LDFJAC,TOL,INFO,IWA,WA, - * LWA) - CALL SSQFCN(M,N,X,FVEC,NPROB) - FNORM2 = ENORM(M,FVEC) - NP(IC) = NPROB - NA(IC) = N - MA(IC) = M - NF(IC) = NFEV - NJ(IC) = NJEV - NX(IC) = INFO - FNM(IC) = FNORM2 - WRITE (NWRITE,70) - * FNORM1,FNORM2,NFEV,NJEV,INFO,(X(I), I = 1, N) - FACTOR = TEN*FACTOR - 20 CONTINUE - GO TO 10 - 30 CONTINUE - WRITE (NWRITE,80) IC - WRITE (NWRITE,90) - DO 40 I = 1, IC - WRITE (NWRITE,100) NP(I),NA(I),MA(I),NF(I),NJ(I),NX(I),FNM(I) - 40 CONTINUE - STOP - 50 FORMAT (4I5) - 60 FORMAT ( //// 5X, 8H PROBLEM, I5, 5X, 11H DIMENSIONS, 2I5, 5X // - * ) - 70 FORMAT (5X, 33H INITIAL L2 NORM OF THE RESIDUALS, D15.7 // 5X, - * 33H FINAL L2 NORM OF THE RESIDUALS , D15.7 // 5X, - * 33H NUMBER OF FUNCTION EVALUATIONS , I10 // 5X, - * 33H NUMBER OF JACOBIAN EVALUATIONS , I10 // 5X, - * 15H EXIT PARAMETER, 18X, I10 // 5X, - * 27H FINAL APPROXIMATE SOLUTION // (5X, 5D15.7)) - 80 FORMAT (12H1SUMMARY OF , I3, 16H CALLS TO LMSTR1 /) - 90 FORMAT (49H NPROB N M NFEV NJEV INFO FINAL L2 NORM /) - 100 FORMAT (3I5, 3I6, 1X, D15.7) -C -C LAST CARD OF DRIVER. -C - END - SUBROUTINE FCN(M,N,X,FVEC,FJROW,IFLAG) - INTEGER M,N,IFLAG - DOUBLE PRECISION X(N),FVEC(M),FJROW(N) -C ********** -C -C THE CALLING SEQUENCE OF FCN SHOULD BE IDENTICAL TO THE -C CALLING SEQUENCE OF THE FUNCTION SUBROUTINE IN THE NONLINEAR -C LEAST SQUARES SOLVER. IF IFLAG = 1, FCN SHOULD ONLY CALL THE -C TESTING FUNCTION SUBROUTINE SSQFCN. IF IFLAG = I, I .GE. 2, -C FCN SHOULD ONLY CALL SUBROUTINE SSQJAC TO CALCULATE THE -C (I-1)-ST ROW OF THE JACOBIAN. (THE SSQJAC SUBROUTINE PROVIDED -C HERE FOR TESTING PURPOSES CALCULATES THE ENTIRE JACOBIAN -C MATRIX AND IS THEREFORE CALLED ONLY WHEN IFLAG = 2.) EACH -C CALL TO SSQFCN OR SSQJAC SHOULD SPECIFY THE APPROPRIATE -C VALUE OF PROBLEM NUMBER (NPROB). -C -C SUBPROGRAMS CALLED -C -C MINPACK-SUPPLIED ... SSQFCN,SSQJAC -C -C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. -C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE -C -C ********** - INTEGER NPROB,NFEV,NJEV,J - DOUBLE PRECISION TEMP(65,40) - COMMON /REFNUM/ NPROB,NFEV,NJEV - IF (IFLAG .EQ. 1) CALL SSQFCN(M,N,X,FVEC,NPROB) - IF (IFLAG .EQ. 2) CALL SSQJAC(M,N,X,TEMP,65,NPROB) - IF (IFLAG .EQ. 1) NFEV = NFEV + 1 - IF (IFLAG .EQ. 2) NJEV = NJEV + 1 - IF (IFLAG .EQ. 1) GO TO 120 - DO 110 J = 1, N - FJROW(J) = TEMP(IFLAG-1,J) - 110 CONTINUE - 120 CONTINUE - RETURN -C -C LAST CARD OF INTERFACE SUBROUTINE FCN. -C - END - SUBROUTINE SSQJAC(M,N,X,FJAC,LDFJAC,NPROB) - INTEGER M,N,LDFJAC,NPROB - DOUBLE PRECISION X(N),FJAC(LDFJAC,N) -C ********** -C -C SUBROUTINE SSQJAC -C -C THIS SUBROUTINE DEFINES THE JACOBIAN MATRICES OF EIGHTEEN -C NONLINEAR LEAST SQUARES PROBLEMS. THE PROBLEM DIMENSIONS ARE -C AS DESCRIBED IN THE PROLOGUE COMMENTS OF SSQFCN. -C -C THE SUBROUTINE STATEMENT IS -C -C SUBROUTINE SSQJAC(M,N,X,FJAC,LDFJAC,NPROB) -C -C WHERE -C -C M AND N ARE POSITIVE INTEGER INPUT VARIABLES. N MUST NOT -C EXCEED M. -C -C X IS AN INPUT ARRAY OF LENGTH N. -C -C FJAC IS AN M BY N OUTPUT ARRAY WHICH CONTAINS THE JACOBIAN -C MATRIX OF THE NPROB FUNCTION EVALUATED AT X. -C -C LDFJAC IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN M -C WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY FJAC. -C -C NPROB IS A POSITIVE INTEGER VARIABLE WHICH DEFINES THE -C NUMBER OF THE PROBLEM. NPROB MUST NOT EXCEED 18. -C -C SUBPROGRAMS CALLED -C -C FORTRAN-SUPPLIED ... DATAN,DCOS,DEXP,DSIN,DSQRT -C -C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. -C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE -C -C ********** - INTEGER I,IVAR,J,K,MM1,NM1 - DOUBLE PRECISION C14,C20,C29,C45,C100,DIV,DX,EIGHT,FIVE,FOUR, - * ONE,PROD,S2,TEMP,TEN,THREE,TI,TMP1,TMP2,TMP3, - * TMP4,TPI,TWO,ZERO - DOUBLE PRECISION V(11) - DOUBLE PRECISION DFLOAT - DATA ZERO,ONE,TWO,THREE,FOUR,FIVE,EIGHT,TEN,C14,C20,C29,C45,C100 - * /0.0D0,1.0D0,2.0D0,3.0D0,4.0D0,5.0D0,8.0D0,1.0D1,1.4D1, - * 2.0D1,2.9D1,4.5D1,1.0D2/ - DATA V(1),V(2),V(3),V(4),V(5),V(6),V(7),V(8),V(9),V(10),V(11) - * /4.0D0,2.0D0,1.0D0,5.0D-1,2.5D-1,1.67D-1,1.25D-1,1.0D-1, - * 8.33D-2,7.14D-2,6.25D-2/ - DFLOAT(IVAR) = IVAR -C -C JACOBIAN ROUTINE SELECTOR. -C - GO TO (10,40,70,130,140,150,180,190,210,230,250,310,330,350,370, - * 400,460,480), NPROB -C -C LINEAR FUNCTION - FULL RANK. -C - 10 CONTINUE - TEMP = TWO/DFLOAT(M) - DO 30 J = 1, N - DO 20 I = 1, M - FJAC(I,J) = -TEMP - 20 CONTINUE - FJAC(J,J) = FJAC(J,J) + ONE - 30 CONTINUE - GO TO 500 -C -C LINEAR FUNCTION - RANK 1. -C - 40 CONTINUE - DO 60 J = 1, N - DO 50 I = 1, M - FJAC(I,J) = DFLOAT(I)*DFLOAT(J) - 50 CONTINUE - 60 CONTINUE - GO TO 500 -C -C LINEAR FUNCTION - RANK 1 WITH ZERO COLUMNS AND ROWS. -C - 70 CONTINUE - DO 90 J = 1, N - DO 80 I = 1, M - FJAC(I,J) = ZERO - 80 CONTINUE - 90 CONTINUE - NM1 = N - 1 - MM1 = M - 1 - IF (NM1 .LT. 2) GO TO 120 - DO 110 J = 2, NM1 - DO 100 I = 2, MM1 - FJAC(I,J) = DFLOAT(I-1)*DFLOAT(J) - 100 CONTINUE - 110 CONTINUE - 120 CONTINUE - GO TO 500 -C -C ROSENBROCK FUNCTION. -C - 130 CONTINUE - FJAC(1,1) = -C20*X(1) - FJAC(1,2) = TEN - FJAC(2,1) = -ONE - FJAC(2,2) = ZERO - GO TO 500 -C -C HELICAL VALLEY FUNCTION. -C - 140 CONTINUE - TPI = EIGHT*DATAN(ONE) - TEMP = X(1)**2 + X(2)**2 - TMP1 = TPI*TEMP - TMP2 = DSQRT(TEMP) - FJAC(1,1) = C100*X(2)/TMP1 - FJAC(1,2) = -C100*X(1)/TMP1 - FJAC(1,3) = TEN - FJAC(2,1) = TEN*X(1)/TMP2 - FJAC(2,2) = TEN*X(2)/TMP2 - FJAC(2,3) = ZERO - FJAC(3,1) = ZERO - FJAC(3,2) = ZERO - FJAC(3,3) = ONE - GO TO 500 -C -C POWELL SINGULAR FUNCTION. -C - 150 CONTINUE - DO 170 J = 1, 4 - DO 160 I = 1, 4 - FJAC(I,J) = ZERO - 160 CONTINUE - 170 CONTINUE - FJAC(1,1) = ONE - FJAC(1,2) = TEN - FJAC(2,3) = DSQRT(FIVE) - FJAC(2,4) = -FJAC(2,3) - FJAC(3,2) = TWO*(X(2) - TWO*X(3)) - FJAC(3,3) = -TWO*FJAC(3,2) - FJAC(4,1) = TWO*DSQRT(TEN)*(X(1) - X(4)) - FJAC(4,4) = -FJAC(4,1) - GO TO 500 -C -C FREUDENSTEIN AND ROTH FUNCTION. -C - 180 CONTINUE - FJAC(1,1) = ONE - FJAC(1,2) = X(2)*(TEN - THREE*X(2)) - TWO - FJAC(2,1) = ONE - FJAC(2,2) = X(2)*(TWO + THREE*X(2)) - C14 - GO TO 500 -C -C BARD FUNCTION. -C - 190 CONTINUE - DO 200 I = 1, 15 - TMP1 = DFLOAT(I) - TMP2 = DFLOAT(16-I) - TMP3 = TMP1 - IF (I .GT. 8) TMP3 = TMP2 - TMP4 = (X(2)*TMP2 + X(3)*TMP3)**2 - FJAC(I,1) = -ONE - FJAC(I,2) = TMP1*TMP2/TMP4 - FJAC(I,3) = TMP1*TMP3/TMP4 - 200 CONTINUE - GO TO 500 -C -C KOWALIK AND OSBORNE FUNCTION. -C - 210 CONTINUE - DO 220 I = 1, 11 - TMP1 = V(I)*(V(I) + X(2)) - TMP2 = V(I)*(V(I) + X(3)) + X(4) - FJAC(I,1) = -TMP1/TMP2 - FJAC(I,2) = -V(I)*X(1)/TMP2 - FJAC(I,3) = FJAC(I,1)*FJAC(I,2) - FJAC(I,4) = FJAC(I,3)/V(I) - 220 CONTINUE - GO TO 500 -C -C MEYER FUNCTION. -C - 230 CONTINUE - DO 240 I = 1, 16 - TEMP = FIVE*DFLOAT(I) + C45 + X(3) - TMP1 = X(2)/TEMP - TMP2 = DEXP(TMP1) - FJAC(I,1) = TMP2 - FJAC(I,2) = X(1)*TMP2/TEMP - FJAC(I,3) = -TMP1*FJAC(I,2) - 240 CONTINUE - GO TO 500 -C -C WATSON FUNCTION. -C - 250 CONTINUE - DO 280 I = 1, 29 - DIV = DFLOAT(I)/C29 - S2 = ZERO - DX = ONE - DO 260 J = 1, N - S2 = S2 + DX*X(J) - DX = DIV*DX - 260 CONTINUE - TEMP = TWO*DIV*S2 - DX = ONE/DIV - DO 270 J = 1, N - FJAC(I,J) = DX*(DFLOAT(J-1) - TEMP) - DX = DIV*DX - 270 CONTINUE - 280 CONTINUE - DO 300 J = 1, N - DO 290 I = 30, 31 - FJAC(I,J) = ZERO - 290 CONTINUE - 300 CONTINUE - FJAC(30,1) = ONE - FJAC(31,1) = -TWO*X(1) - FJAC(31,2) = ONE - GO TO 500 -C -C BOX 3-DIMENSIONAL FUNCTION. -C - 310 CONTINUE - DO 320 I = 1, M - TEMP = DFLOAT(I) - TMP1 = TEMP/TEN - FJAC(I,1) = -TMP1*DEXP(-TMP1*X(1)) - FJAC(I,2) = TMP1*DEXP(-TMP1*X(2)) - FJAC(I,3) = DEXP(-TEMP) - DEXP(-TMP1) - 320 CONTINUE - GO TO 500 -C -C JENNRICH AND SAMPSON FUNCTION. -C - 330 CONTINUE - DO 340 I = 1, M - TEMP = DFLOAT(I) - FJAC(I,1) = -TEMP*DEXP(TEMP*X(1)) - FJAC(I,2) = -TEMP*DEXP(TEMP*X(2)) - 340 CONTINUE - GO TO 500 -C -C BROWN AND DENNIS FUNCTION. -C - 350 CONTINUE - DO 360 I = 1, M - TEMP = DFLOAT(I)/FIVE - TI = DSIN(TEMP) - TMP1 = X(1) + TEMP*X(2) - DEXP(TEMP) - TMP2 = X(3) + TI*X(4) - DCOS(TEMP) - FJAC(I,1) = TWO*TMP1 - FJAC(I,2) = TEMP*FJAC(I,1) - FJAC(I,3) = TWO*TMP2 - FJAC(I,4) = TI*FJAC(I,3) - 360 CONTINUE - GO TO 500 -C -C CHEBYQUAD FUNCTION. -C - 370 CONTINUE - DX = ONE/DFLOAT(N) - DO 390 J = 1, N - TMP1 = ONE - TMP2 = TWO*X(J) - ONE - TEMP = TWO*TMP2 - TMP3 = ZERO - TMP4 = TWO - DO 380 I = 1, M - FJAC(I,J) = DX*TMP4 - TI = FOUR*TMP2 + TEMP*TMP4 - TMP3 - TMP3 = TMP4 - TMP4 = TI - TI = TEMP*TMP2 - TMP1 - TMP1 = TMP2 - TMP2 = TI - 380 CONTINUE - 390 CONTINUE - GO TO 500 -C -C BROWN ALMOST-LINEAR FUNCTION. -C - 400 CONTINUE - PROD = ONE - DO 420 J = 1, N - PROD = X(J)*PROD - DO 410 I = 1, N - FJAC(I,J) = ONE - 410 CONTINUE - FJAC(J,J) = TWO - 420 CONTINUE - DO 450 J = 1, N - TEMP = X(J) - IF (TEMP .NE. ZERO) GO TO 440 - TEMP = ONE - PROD = ONE - DO 430 K = 1, N - IF (K .NE. J) PROD = X(K)*PROD - 430 CONTINUE - 440 CONTINUE - FJAC(N,J) = PROD/TEMP - 450 CONTINUE - GO TO 500 -C -C OSBORNE 1 FUNCTION. -C - 460 CONTINUE - DO 470 I = 1, 33 - TEMP = TEN*DFLOAT(I-1) - TMP1 = DEXP(-X(4)*TEMP) - TMP2 = DEXP(-X(5)*TEMP) - FJAC(I,1) = -ONE - FJAC(I,2) = -TMP1 - FJAC(I,3) = -TMP2 - FJAC(I,4) = TEMP*X(2)*TMP1 - FJAC(I,5) = TEMP*X(3)*TMP2 - 470 CONTINUE - GO TO 500 -C -C OSBORNE 2 FUNCTION. -C - 480 CONTINUE - DO 490 I = 1, 65 - TEMP = DFLOAT(I-1)/TEN - TMP1 = DEXP(-X(5)*TEMP) - TMP2 = DEXP(-X(6)*(TEMP-X(9))**2) - TMP3 = DEXP(-X(7)*(TEMP-X(10))**2) - TMP4 = DEXP(-X(8)*(TEMP-X(11))**2) - FJAC(I,1) = -TMP1 - FJAC(I,2) = -TMP2 - FJAC(I,3) = -TMP3 - FJAC(I,4) = -TMP4 - FJAC(I,5) = TEMP*X(1)*TMP1 - FJAC(I,6) = X(2)*(TEMP - X(9))**2*TMP2 - FJAC(I,7) = X(3)*(TEMP - X(10))**2*TMP3 - FJAC(I,8) = X(4)*(TEMP - X(11))**2*TMP4 - FJAC(I,9) = -TWO*X(2)*X(6)*(TEMP - X(9))*TMP2 - FJAC(I,10) = -TWO*X(3)*X(7)*(TEMP - X(10))*TMP3 - FJAC(I,11) = -TWO*X(4)*X(8)*(TEMP - X(11))*TMP4 - 490 CONTINUE - 500 CONTINUE - RETURN -C -C LAST CARD OF SUBROUTINE SSQJAC. -C - END - SUBROUTINE INITPT(N,X,NPROB,FACTOR) - INTEGER N,NPROB - DOUBLE PRECISION FACTOR - DOUBLE PRECISION X(N) -C ********** -C -C SUBROUTINE INITPT -C -C THIS SUBROUTINE SPECIFIES THE STANDARD STARTING POINTS FOR THE -C FUNCTIONS DEFINED BY SUBROUTINE SSQFCN. THE SUBROUTINE RETURNS -C IN X A MULTIPLE (FACTOR) OF THE STANDARD STARTING POINT. FOR -C THE 11TH FUNCTION THE STANDARD STARTING POINT IS ZERO, SO IN -C THIS CASE, IF FACTOR IS NOT UNITY, THEN THE SUBROUTINE RETURNS -C THE VECTOR X(J) = FACTOR, J=1,...,N. -C -C THE SUBROUTINE STATEMENT IS -C -C SUBROUTINE INITPT(N,X,NPROB,FACTOR) -C -C WHERE -C -C N IS A POSITIVE INTEGER INPUT VARIABLE. -C -C X IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE STANDARD -C STARTING POINT FOR PROBLEM NPROB MULTIPLIED BY FACTOR. -C -C NPROB IS A POSITIVE INTEGER INPUT VARIABLE WHICH DEFINES THE -C NUMBER OF THE PROBLEM. NPROB MUST NOT EXCEED 18. -C -C FACTOR IS AN INPUT VARIABLE WHICH SPECIFIES THE MULTIPLE OF -C THE STANDARD STARTING POINT. IF FACTOR IS UNITY, NO -C MULTIPLICATION IS PERFORMED. -C -C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. -C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE -C -C ********** - INTEGER IVAR,J - DOUBLE PRECISION C1,C2,C3,C4,C5,C6,C7,C8,C9,C10,C11,C12,C13,C14, - * C15,C16,C17,FIVE,H,HALF,ONE,SEVEN,TEN,THREE, - * TWENTY,TWNTF,TWO,ZERO - DOUBLE PRECISION DFLOAT - DATA ZERO,HALF,ONE,TWO,THREE,FIVE,SEVEN,TEN,TWENTY,TWNTF - * /0.0D0,5.0D-1,1.0D0,2.0D0,3.0D0,5.0D0,7.0D0,1.0D1,2.0D1, - * 2.5D1/ - DATA C1,C2,C3,C4,C5,C6,C7,C8,C9,C10,C11,C12,C13,C14,C15,C16,C17 - * /1.2D0,2.5D-1,3.9D-1,4.15D-1,2.0D-2,4.0D3,2.5D2,3.0D-1, - * 4.0D-1,1.5D0,1.0D-2,1.3D0,6.5D-1,7.0D-1,6.0D-1,4.5D0, - * 5.5D0/ - DFLOAT(IVAR) = IVAR -C -C SELECTION OF INITIAL POINT. -C - GO TO (10,10,10,30,40,50,60,70,80,90,100,120,130,140,150,170, - * 190,200), NPROB -C -C LINEAR FUNCTION - FULL RANK OR RANK 1. -C - 10 CONTINUE - DO 20 J = 1, N - X(J) = ONE - 20 CONTINUE - GO TO 210 -C -C ROSENBROCK FUNCTION. -C - 30 CONTINUE - X(1) = -C1 - X(2) = ONE - GO TO 210 -C -C HELICAL VALLEY FUNCTION. -C - 40 CONTINUE - X(1) = -ONE - X(2) = ZERO - X(3) = ZERO - GO TO 210 -C -C POWELL SINGULAR FUNCTION. -C - 50 CONTINUE - X(1) = THREE - X(2) = -ONE - X(3) = ZERO - X(4) = ONE - GO TO 210 -C -C FREUDENSTEIN AND ROTH FUNCTION. -C - 60 CONTINUE - X(1) = HALF - X(2) = -TWO - GO TO 210 -C -C BARD FUNCTION. -C - 70 CONTINUE - X(1) = ONE - X(2) = ONE - X(3) = ONE - GO TO 210 -C -C KOWALIK AND OSBORNE FUNCTION. -C - 80 CONTINUE - X(1) = C2 - X(2) = C3 - X(3) = C4 - X(4) = C3 - GO TO 210 -C -C MEYER FUNCTION. -C - 90 CONTINUE - X(1) = C5 - X(2) = C6 - X(3) = C7 - GO TO 210 -C -C WATSON FUNCTION. -C - 100 CONTINUE - DO 110 J = 1, N - X(J) = ZERO - 110 CONTINUE - GO TO 210 -C -C BOX 3-DIMENSIONAL FUNCTION. -C - 120 CONTINUE - X(1) = ZERO - X(2) = TEN - X(3) = TWENTY - GO TO 210 -C -C JENNRICH AND SAMPSON FUNCTION. -C - 130 CONTINUE - X(1) = C8 - X(2) = C9 - GO TO 210 -C -C BROWN AND DENNIS FUNCTION. -C - 140 CONTINUE - X(1) = TWNTF - X(2) = FIVE - X(3) = -FIVE - X(4) = -ONE - GO TO 210 -C -C CHEBYQUAD FUNCTION. -C - 150 CONTINUE - H = ONE/DFLOAT(N+1) - DO 160 J = 1, N - X(J) = DFLOAT(J)*H - 160 CONTINUE - GO TO 210 -C -C BROWN ALMOST-LINEAR FUNCTION. -C - 170 CONTINUE - DO 180 J = 1, N - X(J) = HALF - 180 CONTINUE - GO TO 210 -C -C OSBORNE 1 FUNCTION. -C - 190 CONTINUE - X(1) = HALF - X(2) = C10 - X(3) = -ONE - X(4) = C11 - X(5) = C5 - GO TO 210 -C -C OSBORNE 2 FUNCTION. -C - 200 CONTINUE - X(1) = C12 - X(2) = C13 - X(3) = C13 - X(4) = C14 - X(5) = C15 - X(6) = THREE - X(7) = FIVE - X(8) = SEVEN - X(9) = TWO - X(10) = C16 - X(11) = C17 - 210 CONTINUE -C -C COMPUTE MULTIPLE OF INITIAL POINT. -C - IF (FACTOR .EQ. ONE) GO TO 260 - IF (NPROB .EQ. 11) GO TO 230 - DO 220 J = 1, N - X(J) = FACTOR*X(J) - 220 CONTINUE - GO TO 250 - 230 CONTINUE - DO 240 J = 1, N - X(J) = FACTOR - 240 CONTINUE - 250 CONTINUE - 260 CONTINUE - RETURN -C -C LAST CARD OF SUBROUTINE INITPT. -C - END - SUBROUTINE SSQFCN(M,N,X,FVEC,NPROB) - INTEGER M,N,NPROB - DOUBLE PRECISION X(N),FVEC(M) -C ********** -C -C SUBROUTINE SSQFCN -C -C THIS SUBROUTINE DEFINES THE FUNCTIONS OF EIGHTEEN NONLINEAR -C LEAST SQUARES PROBLEMS. THE ALLOWABLE VALUES OF (M,N) FOR -C FUNCTIONS 1,2 AND 3 ARE VARIABLE BUT WITH M .GE. N. -C FOR FUNCTIONS 4,5,6,7,8,9 AND 10 THE VALUES OF (M,N) ARE -C (2,2),(3,3),(4,4),(2,2),(15,3),(11,4) AND (16,3), RESPECTIVELY. -C FUNCTION 11 (WATSON) HAS M = 31 WITH N USUALLY 6 OR 9. -C HOWEVER, ANY N, N = 2,...,31, IS PERMITTED. -C FUNCTIONS 12,13 AND 14 HAVE N = 3,2 AND 4, RESPECTIVELY, BUT -C ALLOW ANY M .GE. N, WITH THE USUAL CHOICES BEING 10,10 AND 20. -C FUNCTION 15 (CHEBYQUAD) ALLOWS M AND N VARIABLE WITH M .GE. N. -C FUNCTION 16 (BROWN) ALLOWS N VARIABLE WITH M = N. -C FOR FUNCTIONS 17 AND 18, THE VALUES OF (M,N) ARE -C (33,5) AND (65,11), RESPECTIVELY. -C -C THE SUBROUTINE STATEMENT IS -C -C SUBROUTINE SSQFCN(M,N,X,FVEC,NPROB) -C -C WHERE -C -C M AND N ARE POSITIVE INTEGER INPUT VARIABLES. N MUST NOT -C EXCEED M. -C -C X IS AN INPUT ARRAY OF LENGTH N. -C -C FVEC IS AN OUTPUT ARRAY OF LENGTH M WHICH CONTAINS THE NPROB -C FUNCTION EVALUATED AT X. -C -C NPROB IS A POSITIVE INTEGER INPUT VARIABLE WHICH DEFINES THE -C NUMBER OF THE PROBLEM. NPROB MUST NOT EXCEED 18. -C -C SUBPROGRAMS CALLED -C -C FORTRAN-SUPPLIED ... DATAN,DCOS,DEXP,DSIN,DSQRT,DSIGN -C -C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. -C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE -C -C ********** - INTEGER I,IEV,IVAR,J,NM1 - DOUBLE PRECISION C13,C14,C29,C45,DIV,DX,EIGHT,FIVE,ONE,PROD,SUM, - * S1,S2,TEMP,TEN,TI,TMP1,TMP2,TMP3,TMP4,TPI,TWO, - * ZERO,ZP25,ZP5 - DOUBLE PRECISION V(11),Y1(15),Y2(11),Y3(16),Y4(33),Y5(65) - DOUBLE PRECISION DFLOAT - DATA ZERO,ZP25,ZP5,ONE,TWO,FIVE,EIGHT,TEN,C13,C14,C29,C45 - * /0.0D0,2.5D-1,5.0D-1,1.0D0,2.0D0,5.0D0,8.0D0,1.0D1,1.3D1, - * 1.4D1,2.9D1,4.5D1/ - DATA V(1),V(2),V(3),V(4),V(5),V(6),V(7),V(8),V(9),V(10),V(11) - * /4.0D0,2.0D0,1.0D0,5.0D-1,2.5D-1,1.67D-1,1.25D-1,1.0D-1, - * 8.33D-2,7.14D-2,6.25D-2/ - DATA Y1(1),Y1(2),Y1(3),Y1(4),Y1(5),Y1(6),Y1(7),Y1(8),Y1(9), - * Y1(10),Y1(11),Y1(12),Y1(13),Y1(14),Y1(15) - * /1.4D-1,1.8D-1,2.2D-1,2.5D-1,2.9D-1,3.2D-1,3.5D-1,3.9D-1, - * 3.7D-1,5.8D-1,7.3D-1,9.6D-1,1.34D0,2.1D0,4.39D0/ - DATA Y2(1),Y2(2),Y2(3),Y2(4),Y2(5),Y2(6),Y2(7),Y2(8),Y2(9), - * Y2(10),Y2(11) - * /1.957D-1,1.947D-1,1.735D-1,1.6D-1,8.44D-2,6.27D-2,4.56D-2, - * 3.42D-2,3.23D-2,2.35D-2,2.46D-2/ - DATA Y3(1),Y3(2),Y3(3),Y3(4),Y3(5),Y3(6),Y3(7),Y3(8),Y3(9), - * Y3(10),Y3(11),Y3(12),Y3(13),Y3(14),Y3(15),Y3(16) - * /3.478D4,2.861D4,2.365D4,1.963D4,1.637D4,1.372D4,1.154D4, - * 9.744D3,8.261D3,7.03D3,6.005D3,5.147D3,4.427D3,3.82D3, - * 3.307D3,2.872D3/ - DATA Y4(1),Y4(2),Y4(3),Y4(4),Y4(5),Y4(6),Y4(7),Y4(8),Y4(9), - * Y4(10),Y4(11),Y4(12),Y4(13),Y4(14),Y4(15),Y4(16),Y4(17), - * Y4(18),Y4(19),Y4(20),Y4(21),Y4(22),Y4(23),Y4(24),Y4(25), - * Y4(26),Y4(27),Y4(28),Y4(29),Y4(30),Y4(31),Y4(32),Y4(33) - * /8.44D-1,9.08D-1,9.32D-1,9.36D-1,9.25D-1,9.08D-1,8.81D-1, - * 8.5D-1,8.18D-1,7.84D-1,7.51D-1,7.18D-1,6.85D-1,6.58D-1, - * 6.28D-1,6.03D-1,5.8D-1,5.58D-1,5.38D-1,5.22D-1,5.06D-1, - * 4.9D-1,4.78D-1,4.67D-1,4.57D-1,4.48D-1,4.38D-1,4.31D-1, - * 4.24D-1,4.2D-1,4.14D-1,4.11D-1,4.06D-1/ - DATA Y5(1),Y5(2),Y5(3),Y5(4),Y5(5),Y5(6),Y5(7),Y5(8),Y5(9), - * Y5(10),Y5(11),Y5(12),Y5(13),Y5(14),Y5(15),Y5(16),Y5(17), - * Y5(18),Y5(19),Y5(20),Y5(21),Y5(22),Y5(23),Y5(24),Y5(25), - * Y5(26),Y5(27),Y5(28),Y5(29),Y5(30),Y5(31),Y5(32),Y5(33), - * Y5(34),Y5(35),Y5(36),Y5(37),Y5(38),Y5(39),Y5(40),Y5(41), - * Y5(42),Y5(43),Y5(44),Y5(45),Y5(46),Y5(47),Y5(48),Y5(49), - * Y5(50),Y5(51),Y5(52),Y5(53),Y5(54),Y5(55),Y5(56),Y5(57), - * Y5(58),Y5(59),Y5(60),Y5(61),Y5(62),Y5(63),Y5(64),Y5(65) - * /1.366D0,1.191D0,1.112D0,1.013D0,9.91D-1,8.85D-1,8.31D-1, - * 8.47D-1,7.86D-1,7.25D-1,7.46D-1,6.79D-1,6.08D-1,6.55D-1, - * 6.16D-1,6.06D-1,6.02D-1,6.26D-1,6.51D-1,7.24D-1,6.49D-1, - * 6.49D-1,6.94D-1,6.44D-1,6.24D-1,6.61D-1,6.12D-1,5.58D-1, - * 5.33D-1,4.95D-1,5.0D-1,4.23D-1,3.95D-1,3.75D-1,3.72D-1, - * 3.91D-1,3.96D-1,4.05D-1,4.28D-1,4.29D-1,5.23D-1,5.62D-1, - * 6.07D-1,6.53D-1,6.72D-1,7.08D-1,6.33D-1,6.68D-1,6.45D-1, - * 6.32D-1,5.91D-1,5.59D-1,5.97D-1,6.25D-1,7.39D-1,7.1D-1, - * 7.29D-1,7.2D-1,6.36D-1,5.81D-1,4.28D-1,2.92D-1,1.62D-1, - * 9.8D-2,5.4D-2/ - DFLOAT(IVAR) = IVAR -C -C FUNCTION ROUTINE SELECTOR. -C - GO TO (10,40,70,110,120,130,140,150,170,190,210,250,270,290,310, - * 360,390,410), NPROB -C -C LINEAR FUNCTION - FULL RANK. -C - 10 CONTINUE - SUM = ZERO - DO 20 J = 1, N - SUM = SUM + X(J) - 20 CONTINUE - TEMP = TWO*SUM/DFLOAT(M) + ONE - DO 30 I = 1, M - FVEC(I) = -TEMP - IF (I .LE. N) FVEC(I) = FVEC(I) + X(I) - 30 CONTINUE - GO TO 430 -C -C LINEAR FUNCTION - RANK 1. -C - 40 CONTINUE - SUM = ZERO - DO 50 J = 1, N - SUM = SUM + DFLOAT(J)*X(J) - 50 CONTINUE - DO 60 I = 1, M - FVEC(I) = DFLOAT(I)*SUM - ONE - 60 CONTINUE - GO TO 430 -C -C LINEAR FUNCTION - RANK 1 WITH ZERO COLUMNS AND ROWS. -C - 70 CONTINUE - SUM = ZERO - NM1 = N - 1 - IF (NM1 .LT. 2) GO TO 90 - DO 80 J = 2, NM1 - SUM = SUM + DFLOAT(J)*X(J) - 80 CONTINUE - 90 CONTINUE - DO 100 I = 1, M - FVEC(I) = DFLOAT(I-1)*SUM - ONE - 100 CONTINUE - FVEC(M) = -ONE - GO TO 430 -C -C ROSENBROCK FUNCTION. -C - 110 CONTINUE - FVEC(1) = TEN*(X(2) - X(1)**2) - FVEC(2) = ONE - X(1) - GO TO 430 -C -C HELICAL VALLEY FUNCTION. -C - 120 CONTINUE - TPI = EIGHT*DATAN(ONE) - TMP1 = DSIGN(ZP25,X(2)) - IF (X(1) .GT. ZERO) TMP1 = DATAN(X(2)/X(1))/TPI - IF (X(1) .LT. ZERO) TMP1 = DATAN(X(2)/X(1))/TPI + ZP5 - TMP2 = DSQRT(X(1)**2+X(2)**2) - FVEC(1) = TEN*(X(3) - TEN*TMP1) - FVEC(2) = TEN*(TMP2 - ONE) - FVEC(3) = X(3) - GO TO 430 -C -C POWELL SINGULAR FUNCTION. -C - 130 CONTINUE - FVEC(1) = X(1) + TEN*X(2) - FVEC(2) = DSQRT(FIVE)*(X(3) - X(4)) - FVEC(3) = (X(2) - TWO*X(3))**2 - FVEC(4) = DSQRT(TEN)*(X(1) - X(4))**2 - GO TO 430 -C -C FREUDENSTEIN AND ROTH FUNCTION. -C - 140 CONTINUE - FVEC(1) = -C13 + X(1) + ((FIVE - X(2))*X(2) - TWO)*X(2) - FVEC(2) = -C29 + X(1) + ((ONE + X(2))*X(2) - C14)*X(2) - GO TO 430 -C -C BARD FUNCTION. -C - 150 CONTINUE - DO 160 I = 1, 15 - TMP1 = DFLOAT(I) - TMP2 = DFLOAT(16-I) - TMP3 = TMP1 - IF (I .GT. 8) TMP3 = TMP2 - FVEC(I) = Y1(I) - (X(1) + TMP1/(X(2)*TMP2 + X(3)*TMP3)) - 160 CONTINUE - GO TO 430 -C -C KOWALIK AND OSBORNE FUNCTION. -C - 170 CONTINUE - DO 180 I = 1, 11 - TMP1 = V(I)*(V(I) + X(2)) - TMP2 = V(I)*(V(I) + X(3)) + X(4) - FVEC(I) = Y2(I) - X(1)*TMP1/TMP2 - 180 CONTINUE - GO TO 430 -C -C MEYER FUNCTION. -C - 190 CONTINUE - DO 200 I = 1, 16 - TEMP = FIVE*DFLOAT(I) + C45 + X(3) - TMP1 = X(2)/TEMP - TMP2 = DEXP(TMP1) - FVEC(I) = X(1)*TMP2 - Y3(I) - 200 CONTINUE - GO TO 430 -C -C WATSON FUNCTION. -C - 210 CONTINUE - DO 240 I = 1, 29 - DIV = DFLOAT(I)/C29 - S1 = ZERO - DX = ONE - DO 220 J = 2, N - S1 = S1 + DFLOAT(J-1)*DX*X(J) - DX = DIV*DX - 220 CONTINUE - S2 = ZERO - DX = ONE - DO 230 J = 1, N - S2 = S2 + DX*X(J) - DX = DIV*DX - 230 CONTINUE - FVEC(I) = S1 - S2**2 - ONE - 240 CONTINUE - FVEC(30) = X(1) - FVEC(31) = X(2) - X(1)**2 - ONE - GO TO 430 -C -C BOX 3-DIMENSIONAL FUNCTION. -C - 250 CONTINUE - DO 260 I = 1, M - TEMP = DFLOAT(I) - TMP1 = TEMP/TEN - FVEC(I) = DEXP(-TMP1*X(1)) - DEXP(-TMP1*X(2)) - * + (DEXP(-TEMP) - DEXP(-TMP1))*X(3) - 260 CONTINUE - GO TO 430 -C -C JENNRICH AND SAMPSON FUNCTION. -C - 270 CONTINUE - DO 280 I = 1, M - TEMP = DFLOAT(I) - FVEC(I) = TWO + TWO*TEMP - DEXP(TEMP*X(1)) - DEXP(TEMP*X(2)) - 280 CONTINUE - GO TO 430 -C -C BROWN AND DENNIS FUNCTION. -C - 290 CONTINUE - DO 300 I = 1, M - TEMP = DFLOAT(I)/FIVE - TMP1 = X(1) + TEMP*X(2) - DEXP(TEMP) - TMP2 = X(3) + DSIN(TEMP)*X(4) - DCOS(TEMP) - FVEC(I) = TMP1**2 + TMP2**2 - 300 CONTINUE - GO TO 430 -C -C CHEBYQUAD FUNCTION. -C - 310 CONTINUE - DO 320 I = 1, M - FVEC(I) = ZERO - 320 CONTINUE - DO 340 J = 1, N - TMP1 = ONE - TMP2 = TWO*X(J) - ONE - TEMP = TWO*TMP2 - DO 330 I = 1, M - FVEC(I) = FVEC(I) + TMP2 - TI = TEMP*TMP2 - TMP1 - TMP1 = TMP2 - TMP2 = TI - 330 CONTINUE - 340 CONTINUE - DX = ONE/DFLOAT(N) - IEV = -1 - DO 350 I = 1, M - FVEC(I) = DX*FVEC(I) - IF (IEV .GT. 0) FVEC(I) = FVEC(I) + ONE/(DFLOAT(I)**2 - ONE) - IEV = -IEV - 350 CONTINUE - GO TO 430 -C -C BROWN ALMOST-LINEAR FUNCTION. -C - 360 CONTINUE - SUM = -DFLOAT(N+1) - PROD = ONE - DO 370 J = 1, N - SUM = SUM + X(J) - PROD = X(J)*PROD - 370 CONTINUE - DO 380 I = 1, N - FVEC(I) = X(I) + SUM - 380 CONTINUE - FVEC(N) = PROD - ONE - GO TO 430 -C -C OSBORNE 1 FUNCTION. -C - 390 CONTINUE - DO 400 I = 1, 33 - TEMP = TEN*DFLOAT(I-1) - TMP1 = DEXP(-X(4)*TEMP) - TMP2 = DEXP(-X(5)*TEMP) - FVEC(I) = Y4(I) - (X(1) + X(2)*TMP1 + X(3)*TMP2) - 400 CONTINUE - GO TO 430 -C -C OSBORNE 2 FUNCTION. -C - 410 CONTINUE - DO 420 I = 1, 65 - TEMP = DFLOAT(I-1)/TEN - TMP1 = DEXP(-X(5)*TEMP) - TMP2 = DEXP(-X(6)*(TEMP-X(9))**2) - TMP3 = DEXP(-X(7)*(TEMP-X(10))**2) - TMP4 = DEXP(-X(8)*(TEMP-X(11))**2) - FVEC(I) = Y5(I) - * - (X(1)*TMP1 + X(2)*TMP2 + X(3)*TMP3 + X(4)*TMP4) - 420 CONTINUE - 430 CONTINUE - RETURN -C -C LAST CARD OF SUBROUTINE SSQFCN. -C - END diff --git a/ex/file19 b/ex/file19 deleted file mode 100644 index 9e1ba54..0000000 --- a/ex/file19 +++ /dev/null @@ -1,675 +0,0 @@ -C ********** -C -C THIS PROGRAM TESTS CODES FOR THE LEAST-SQUARES SOLUTION OF -C M NONLINEAR EQUATIONS IN N VARIABLES. IT CONSISTS OF A DRIVER -C AND AN INTERFACE SUBROUTINE FCN. THE DRIVER READS IN DATA, -C CALLS THE NONLINEAR LEAST-SQUARES SOLVER, AND FINALLY PRINTS -C OUT INFORMATION ON THE PERFORMANCE OF THE SOLVER. THIS IS -C ONLY A SAMPLE DRIVER, MANY OTHER DRIVERS ARE POSSIBLE. THE -C INTERFACE SUBROUTINE FCN IS NECESSARY TO TAKE INTO ACCOUNT THE -C FORMS OF CALLING SEQUENCES USED BY THE FUNCTION AND JACOBIAN -C SUBROUTINES IN THE VARIOUS NONLINEAR LEAST-SQUARES SOLVERS. -C -C SUBPROGRAMS CALLED -C -C USER-SUPPLIED ...... FCN -C -C MINPACK-SUPPLIED ... DPMPAR,ENORM,INITPT,LMDIF1,SSQFCN -C -C FORTRAN-SUPPLIED ... DSQRT -C -C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. -C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE -C -C ********** - INTEGER I,IC,INFO,K,LWA,M,N,NFEV,NJEV,NPROB,NREAD,NTRIES,NWRITE - INTEGER IWA(40),MA(60),NA(60),NF(60),NJ(60),NP(60),NX(60) - DOUBLE PRECISION FACTOR,FNORM1,FNORM2,ONE,TEN,TOL - DOUBLE PRECISION FNM(60),FVEC(65),WA(2865),X(40) - DOUBLE PRECISION DPMPAR,ENORM - EXTERNAL FCN - COMMON /REFNUM/ NPROB,NFEV,NJEV -C -C LOGICAL INPUT UNIT IS ASSUMED TO BE NUMBER 5. -C LOGICAL OUTPUT UNIT IS ASSUMED TO BE NUMBER 6. -C - DATA NREAD,NWRITE /5,6/ -C - DATA ONE,TEN /1.0D0,1.0D1/ - TOL = DSQRT(DPMPAR(1)) - LWA = 2865 - IC = 0 - 10 CONTINUE - READ (NREAD,50) NPROB,N,M,NTRIES - IF (NPROB .LE. 0) GO TO 30 - FACTOR = ONE - DO 20 K = 1, NTRIES - IC = IC + 1 - CALL INITPT(N,X,NPROB,FACTOR) - CALL SSQFCN(M,N,X,FVEC,NPROB) - FNORM1 = ENORM(M,FVEC) - WRITE (NWRITE,60) NPROB,N,M - NFEV = 0 - NJEV = 0 - CALL LMDIF1(FCN,M,N,X,FVEC,TOL,INFO,IWA,WA,LWA) - CALL SSQFCN(M,N,X,FVEC,NPROB) - FNORM2 = ENORM(M,FVEC) - NP(IC) = NPROB - NA(IC) = N - MA(IC) = M - NF(IC) = NFEV - NJEV = NJEV/N - NJ(IC) = NJEV - NX(IC) = INFO - FNM(IC) = FNORM2 - WRITE (NWRITE,70) - * FNORM1,FNORM2,NFEV,NJEV,INFO,(X(I), I = 1, N) - FACTOR = TEN*FACTOR - 20 CONTINUE - GO TO 10 - 30 CONTINUE - WRITE (NWRITE,80) IC - WRITE (NWRITE,90) - DO 40 I = 1, IC - WRITE (NWRITE,100) NP(I),NA(I),MA(I),NF(I),NJ(I),NX(I),FNM(I) - 40 CONTINUE - STOP - 50 FORMAT (4I5) - 60 FORMAT ( //// 5X, 8H PROBLEM, I5, 5X, 11H DIMENSIONS, 2I5, 5X // - * ) - 70 FORMAT (5X, 33H INITIAL L2 NORM OF THE RESIDUALS, D15.7 // 5X, - * 33H FINAL L2 NORM OF THE RESIDUALS , D15.7 // 5X, - * 33H NUMBER OF FUNCTION EVALUATIONS , I10 // 5X, - * 33H NUMBER OF JACOBIAN EVALUATIONS , I10 // 5X, - * 15H EXIT PARAMETER, 18X, I10 // 5X, - * 27H FINAL APPROXIMATE SOLUTION // (5X, 5D15.7)) - 80 FORMAT (12H1SUMMARY OF , I3, 16H CALLS TO LMDIF1 /) - 90 FORMAT (49H NPROB N M NFEV NJEV INFO FINAL L2 NORM /) - 100 FORMAT (3I5, 3I6, 1X, D15.7) -C -C LAST CARD OF DRIVER. -C - END - SUBROUTINE FCN(M,N,X,FVEC,IFLAG) - INTEGER M,N,IFLAG - DOUBLE PRECISION X(N),FVEC(M) -C ********** -C -C THE CALLING SEQUENCE OF FCN SHOULD BE IDENTICAL TO THE -C CALLING SEQUENCE OF THE FUNCTION SUBROUTINE IN THE NONLINEAR -C LEAST-SQUARES SOLVER. FCN SHOULD ONLY CALL THE TESTING -C FUNCTION SUBROUTINE SSQFCN WITH THE APPROPRIATE VALUE OF -C PROBLEM NUMBER (NPROB). -C -C SUBPROGRAMS CALLED -C -C MINPACK-SUPPLIED ... SSQFCN -C -C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. -C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE -C -C ********** - INTEGER NPROB,NFEV,NJEV - COMMON /REFNUM/ NPROB,NFEV,NJEV - CALL SSQFCN(M,N,X,FVEC,NPROB) - IF (IFLAG .EQ. 1) NFEV = NFEV + 1 - IF (IFLAG .EQ. 2) NJEV = NJEV + 1 - RETURN -C -C LAST CARD OF INTERFACE SUBROUTINE FCN. -C - END - SUBROUTINE SSQFCN(M,N,X,FVEC,NPROB) - INTEGER M,N,NPROB - DOUBLE PRECISION X(N),FVEC(M) -C ********** -C -C SUBROUTINE SSQFCN -C -C THIS SUBROUTINE DEFINES THE FUNCTIONS OF EIGHTEEN NONLINEAR -C LEAST SQUARES PROBLEMS. THE ALLOWABLE VALUES OF (M,N) FOR -C FUNCTIONS 1,2 AND 3 ARE VARIABLE BUT WITH M .GE. N. -C FOR FUNCTIONS 4,5,6,7,8,9 AND 10 THE VALUES OF (M,N) ARE -C (2,2),(3,3),(4,4),(2,2),(15,3),(11,4) AND (16,3), RESPECTIVELY. -C FUNCTION 11 (WATSON) HAS M = 31 WITH N USUALLY 6 OR 9. -C HOWEVER, ANY N, N = 2,...,31, IS PERMITTED. -C FUNCTIONS 12,13 AND 14 HAVE N = 3,2 AND 4, RESPECTIVELY, BUT -C ALLOW ANY M .GE. N, WITH THE USUAL CHOICES BEING 10,10 AND 20. -C FUNCTION 15 (CHEBYQUAD) ALLOWS M AND N VARIABLE WITH M .GE. N. -C FUNCTION 16 (BROWN) ALLOWS N VARIABLE WITH M = N. -C FOR FUNCTIONS 17 AND 18, THE VALUES OF (M,N) ARE -C (33,5) AND (65,11), RESPECTIVELY. -C -C THE SUBROUTINE STATEMENT IS -C -C SUBROUTINE SSQFCN(M,N,X,FVEC,NPROB) -C -C WHERE -C -C M AND N ARE POSITIVE INTEGER INPUT VARIABLES. N MUST NOT -C EXCEED M. -C -C X IS AN INPUT ARRAY OF LENGTH N. -C -C FVEC IS AN OUTPUT ARRAY OF LENGTH M WHICH CONTAINS THE NPROB -C FUNCTION EVALUATED AT X. -C -C NPROB IS A POSITIVE INTEGER INPUT VARIABLE WHICH DEFINES THE -C NUMBER OF THE PROBLEM. NPROB MUST NOT EXCEED 18. -C -C SUBPROGRAMS CALLED -C -C FORTRAN-SUPPLIED ... DATAN,DCOS,DEXP,DSIN,DSQRT,DSIGN -C -C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. -C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE -C -C ********** - INTEGER I,IEV,IVAR,J,NM1 - DOUBLE PRECISION C13,C14,C29,C45,DIV,DX,EIGHT,FIVE,ONE,PROD,SUM, - * S1,S2,TEMP,TEN,TI,TMP1,TMP2,TMP3,TMP4,TPI,TWO, - * ZERO,ZP25,ZP5 - DOUBLE PRECISION V(11),Y1(15),Y2(11),Y3(16),Y4(33),Y5(65) - DOUBLE PRECISION DFLOAT - DATA ZERO,ZP25,ZP5,ONE,TWO,FIVE,EIGHT,TEN,C13,C14,C29,C45 - * /0.0D0,2.5D-1,5.0D-1,1.0D0,2.0D0,5.0D0,8.0D0,1.0D1,1.3D1, - * 1.4D1,2.9D1,4.5D1/ - DATA V(1),V(2),V(3),V(4),V(5),V(6),V(7),V(8),V(9),V(10),V(11) - * /4.0D0,2.0D0,1.0D0,5.0D-1,2.5D-1,1.67D-1,1.25D-1,1.0D-1, - * 8.33D-2,7.14D-2,6.25D-2/ - DATA Y1(1),Y1(2),Y1(3),Y1(4),Y1(5),Y1(6),Y1(7),Y1(8),Y1(9), - * Y1(10),Y1(11),Y1(12),Y1(13),Y1(14),Y1(15) - * /1.4D-1,1.8D-1,2.2D-1,2.5D-1,2.9D-1,3.2D-1,3.5D-1,3.9D-1, - * 3.7D-1,5.8D-1,7.3D-1,9.6D-1,1.34D0,2.1D0,4.39D0/ - DATA Y2(1),Y2(2),Y2(3),Y2(4),Y2(5),Y2(6),Y2(7),Y2(8),Y2(9), - * Y2(10),Y2(11) - * /1.957D-1,1.947D-1,1.735D-1,1.6D-1,8.44D-2,6.27D-2,4.56D-2, - * 3.42D-2,3.23D-2,2.35D-2,2.46D-2/ - DATA Y3(1),Y3(2),Y3(3),Y3(4),Y3(5),Y3(6),Y3(7),Y3(8),Y3(9), - * Y3(10),Y3(11),Y3(12),Y3(13),Y3(14),Y3(15),Y3(16) - * /3.478D4,2.861D4,2.365D4,1.963D4,1.637D4,1.372D4,1.154D4, - * 9.744D3,8.261D3,7.03D3,6.005D3,5.147D3,4.427D3,3.82D3, - * 3.307D3,2.872D3/ - DATA Y4(1),Y4(2),Y4(3),Y4(4),Y4(5),Y4(6),Y4(7),Y4(8),Y4(9), - * Y4(10),Y4(11),Y4(12),Y4(13),Y4(14),Y4(15),Y4(16),Y4(17), - * Y4(18),Y4(19),Y4(20),Y4(21),Y4(22),Y4(23),Y4(24),Y4(25), - * Y4(26),Y4(27),Y4(28),Y4(29),Y4(30),Y4(31),Y4(32),Y4(33) - * /8.44D-1,9.08D-1,9.32D-1,9.36D-1,9.25D-1,9.08D-1,8.81D-1, - * 8.5D-1,8.18D-1,7.84D-1,7.51D-1,7.18D-1,6.85D-1,6.58D-1, - * 6.28D-1,6.03D-1,5.8D-1,5.58D-1,5.38D-1,5.22D-1,5.06D-1, - * 4.9D-1,4.78D-1,4.67D-1,4.57D-1,4.48D-1,4.38D-1,4.31D-1, - * 4.24D-1,4.2D-1,4.14D-1,4.11D-1,4.06D-1/ - DATA Y5(1),Y5(2),Y5(3),Y5(4),Y5(5),Y5(6),Y5(7),Y5(8),Y5(9), - * Y5(10),Y5(11),Y5(12),Y5(13),Y5(14),Y5(15),Y5(16),Y5(17), - * Y5(18),Y5(19),Y5(20),Y5(21),Y5(22),Y5(23),Y5(24),Y5(25), - * Y5(26),Y5(27),Y5(28),Y5(29),Y5(30),Y5(31),Y5(32),Y5(33), - * Y5(34),Y5(35),Y5(36),Y5(37),Y5(38),Y5(39),Y5(40),Y5(41), - * Y5(42),Y5(43),Y5(44),Y5(45),Y5(46),Y5(47),Y5(48),Y5(49), - * Y5(50),Y5(51),Y5(52),Y5(53),Y5(54),Y5(55),Y5(56),Y5(57), - * Y5(58),Y5(59),Y5(60),Y5(61),Y5(62),Y5(63),Y5(64),Y5(65) - * /1.366D0,1.191D0,1.112D0,1.013D0,9.91D-1,8.85D-1,8.31D-1, - * 8.47D-1,7.86D-1,7.25D-1,7.46D-1,6.79D-1,6.08D-1,6.55D-1, - * 6.16D-1,6.06D-1,6.02D-1,6.26D-1,6.51D-1,7.24D-1,6.49D-1, - * 6.49D-1,6.94D-1,6.44D-1,6.24D-1,6.61D-1,6.12D-1,5.58D-1, - * 5.33D-1,4.95D-1,5.0D-1,4.23D-1,3.95D-1,3.75D-1,3.72D-1, - * 3.91D-1,3.96D-1,4.05D-1,4.28D-1,4.29D-1,5.23D-1,5.62D-1, - * 6.07D-1,6.53D-1,6.72D-1,7.08D-1,6.33D-1,6.68D-1,6.45D-1, - * 6.32D-1,5.91D-1,5.59D-1,5.97D-1,6.25D-1,7.39D-1,7.1D-1, - * 7.29D-1,7.2D-1,6.36D-1,5.81D-1,4.28D-1,2.92D-1,1.62D-1, - * 9.8D-2,5.4D-2/ - DFLOAT(IVAR) = IVAR -C -C FUNCTION ROUTINE SELECTOR. -C - GO TO (10,40,70,110,120,130,140,150,170,190,210,250,270,290,310, - * 360,390,410), NPROB -C -C LINEAR FUNCTION - FULL RANK. -C - 10 CONTINUE - SUM = ZERO - DO 20 J = 1, N - SUM = SUM + X(J) - 20 CONTINUE - TEMP = TWO*SUM/DFLOAT(M) + ONE - DO 30 I = 1, M - FVEC(I) = -TEMP - IF (I .LE. N) FVEC(I) = FVEC(I) + X(I) - 30 CONTINUE - GO TO 430 -C -C LINEAR FUNCTION - RANK 1. -C - 40 CONTINUE - SUM = ZERO - DO 50 J = 1, N - SUM = SUM + DFLOAT(J)*X(J) - 50 CONTINUE - DO 60 I = 1, M - FVEC(I) = DFLOAT(I)*SUM - ONE - 60 CONTINUE - GO TO 430 -C -C LINEAR FUNCTION - RANK 1 WITH ZERO COLUMNS AND ROWS. -C - 70 CONTINUE - SUM = ZERO - NM1 = N - 1 - IF (NM1 .LT. 2) GO TO 90 - DO 80 J = 2, NM1 - SUM = SUM + DFLOAT(J)*X(J) - 80 CONTINUE - 90 CONTINUE - DO 100 I = 1, M - FVEC(I) = DFLOAT(I-1)*SUM - ONE - 100 CONTINUE - FVEC(M) = -ONE - GO TO 430 -C -C ROSENBROCK FUNCTION. -C - 110 CONTINUE - FVEC(1) = TEN*(X(2) - X(1)**2) - FVEC(2) = ONE - X(1) - GO TO 430 -C -C HELICAL VALLEY FUNCTION. -C - 120 CONTINUE - TPI = EIGHT*DATAN(ONE) - TMP1 = DSIGN(ZP25,X(2)) - IF (X(1) .GT. ZERO) TMP1 = DATAN(X(2)/X(1))/TPI - IF (X(1) .LT. ZERO) TMP1 = DATAN(X(2)/X(1))/TPI + ZP5 - TMP2 = DSQRT(X(1)**2+X(2)**2) - FVEC(1) = TEN*(X(3) - TEN*TMP1) - FVEC(2) = TEN*(TMP2 - ONE) - FVEC(3) = X(3) - GO TO 430 -C -C POWELL SINGULAR FUNCTION. -C - 130 CONTINUE - FVEC(1) = X(1) + TEN*X(2) - FVEC(2) = DSQRT(FIVE)*(X(3) - X(4)) - FVEC(3) = (X(2) - TWO*X(3))**2 - FVEC(4) = DSQRT(TEN)*(X(1) - X(4))**2 - GO TO 430 -C -C FREUDENSTEIN AND ROTH FUNCTION. -C - 140 CONTINUE - FVEC(1) = -C13 + X(1) + ((FIVE - X(2))*X(2) - TWO)*X(2) - FVEC(2) = -C29 + X(1) + ((ONE + X(2))*X(2) - C14)*X(2) - GO TO 430 -C -C BARD FUNCTION. -C - 150 CONTINUE - DO 160 I = 1, 15 - TMP1 = DFLOAT(I) - TMP2 = DFLOAT(16-I) - TMP3 = TMP1 - IF (I .GT. 8) TMP3 = TMP2 - FVEC(I) = Y1(I) - (X(1) + TMP1/(X(2)*TMP2 + X(3)*TMP3)) - 160 CONTINUE - GO TO 430 -C -C KOWALIK AND OSBORNE FUNCTION. -C - 170 CONTINUE - DO 180 I = 1, 11 - TMP1 = V(I)*(V(I) + X(2)) - TMP2 = V(I)*(V(I) + X(3)) + X(4) - FVEC(I) = Y2(I) - X(1)*TMP1/TMP2 - 180 CONTINUE - GO TO 430 -C -C MEYER FUNCTION. -C - 190 CONTINUE - DO 200 I = 1, 16 - TEMP = FIVE*DFLOAT(I) + C45 + X(3) - TMP1 = X(2)/TEMP - TMP2 = DEXP(TMP1) - FVEC(I) = X(1)*TMP2 - Y3(I) - 200 CONTINUE - GO TO 430 -C -C WATSON FUNCTION. -C - 210 CONTINUE - DO 240 I = 1, 29 - DIV = DFLOAT(I)/C29 - S1 = ZERO - DX = ONE - DO 220 J = 2, N - S1 = S1 + DFLOAT(J-1)*DX*X(J) - DX = DIV*DX - 220 CONTINUE - S2 = ZERO - DX = ONE - DO 230 J = 1, N - S2 = S2 + DX*X(J) - DX = DIV*DX - 230 CONTINUE - FVEC(I) = S1 - S2**2 - ONE - 240 CONTINUE - FVEC(30) = X(1) - FVEC(31) = X(2) - X(1)**2 - ONE - GO TO 430 -C -C BOX 3-DIMENSIONAL FUNCTION. -C - 250 CONTINUE - DO 260 I = 1, M - TEMP = DFLOAT(I) - TMP1 = TEMP/TEN - FVEC(I) = DEXP(-TMP1*X(1)) - DEXP(-TMP1*X(2)) - * + (DEXP(-TEMP) - DEXP(-TMP1))*X(3) - 260 CONTINUE - GO TO 430 -C -C JENNRICH AND SAMPSON FUNCTION. -C - 270 CONTINUE - DO 280 I = 1, M - TEMP = DFLOAT(I) - FVEC(I) = TWO + TWO*TEMP - DEXP(TEMP*X(1)) - DEXP(TEMP*X(2)) - 280 CONTINUE - GO TO 430 -C -C BROWN AND DENNIS FUNCTION. -C - 290 CONTINUE - DO 300 I = 1, M - TEMP = DFLOAT(I)/FIVE - TMP1 = X(1) + TEMP*X(2) - DEXP(TEMP) - TMP2 = X(3) + DSIN(TEMP)*X(4) - DCOS(TEMP) - FVEC(I) = TMP1**2 + TMP2**2 - 300 CONTINUE - GO TO 430 -C -C CHEBYQUAD FUNCTION. -C - 310 CONTINUE - DO 320 I = 1, M - FVEC(I) = ZERO - 320 CONTINUE - DO 340 J = 1, N - TMP1 = ONE - TMP2 = TWO*X(J) - ONE - TEMP = TWO*TMP2 - DO 330 I = 1, M - FVEC(I) = FVEC(I) + TMP2 - TI = TEMP*TMP2 - TMP1 - TMP1 = TMP2 - TMP2 = TI - 330 CONTINUE - 340 CONTINUE - DX = ONE/DFLOAT(N) - IEV = -1 - DO 350 I = 1, M - FVEC(I) = DX*FVEC(I) - IF (IEV .GT. 0) FVEC(I) = FVEC(I) + ONE/(DFLOAT(I)**2 - ONE) - IEV = -IEV - 350 CONTINUE - GO TO 430 -C -C BROWN ALMOST-LINEAR FUNCTION. -C - 360 CONTINUE - SUM = -DFLOAT(N+1) - PROD = ONE - DO 370 J = 1, N - SUM = SUM + X(J) - PROD = X(J)*PROD - 370 CONTINUE - DO 380 I = 1, N - FVEC(I) = X(I) + SUM - 380 CONTINUE - FVEC(N) = PROD - ONE - GO TO 430 -C -C OSBORNE 1 FUNCTION. -C - 390 CONTINUE - DO 400 I = 1, 33 - TEMP = TEN*DFLOAT(I-1) - TMP1 = DEXP(-X(4)*TEMP) - TMP2 = DEXP(-X(5)*TEMP) - FVEC(I) = Y4(I) - (X(1) + X(2)*TMP1 + X(3)*TMP2) - 400 CONTINUE - GO TO 430 -C -C OSBORNE 2 FUNCTION. -C - 410 CONTINUE - DO 420 I = 1, 65 - TEMP = DFLOAT(I-1)/TEN - TMP1 = DEXP(-X(5)*TEMP) - TMP2 = DEXP(-X(6)*(TEMP-X(9))**2) - TMP3 = DEXP(-X(7)*(TEMP-X(10))**2) - TMP4 = DEXP(-X(8)*(TEMP-X(11))**2) - FVEC(I) = Y5(I) - * - (X(1)*TMP1 + X(2)*TMP2 + X(3)*TMP3 + X(4)*TMP4) - 420 CONTINUE - 430 CONTINUE - RETURN -C -C LAST CARD OF SUBROUTINE SSQFCN. -C - END - SUBROUTINE INITPT(N,X,NPROB,FACTOR) - INTEGER N,NPROB - DOUBLE PRECISION FACTOR - DOUBLE PRECISION X(N) -C ********** -C -C SUBROUTINE INITPT -C -C THIS SUBROUTINE SPECIFIES THE STANDARD STARTING POINTS FOR THE -C FUNCTIONS DEFINED BY SUBROUTINE SSQFCN. THE SUBROUTINE RETURNS -C IN X A MULTIPLE (FACTOR) OF THE STANDARD STARTING POINT. FOR -C THE 11TH FUNCTION THE STANDARD STARTING POINT IS ZERO, SO IN -C THIS CASE, IF FACTOR IS NOT UNITY, THEN THE SUBROUTINE RETURNS -C THE VECTOR X(J) = FACTOR, J=1,...,N. -C -C THE SUBROUTINE STATEMENT IS -C -C SUBROUTINE INITPT(N,X,NPROB,FACTOR) -C -C WHERE -C -C N IS A POSITIVE INTEGER INPUT VARIABLE. -C -C X IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE STANDARD -C STARTING POINT FOR PROBLEM NPROB MULTIPLIED BY FACTOR. -C -C NPROB IS A POSITIVE INTEGER INPUT VARIABLE WHICH DEFINES THE -C NUMBER OF THE PROBLEM. NPROB MUST NOT EXCEED 18. -C -C FACTOR IS AN INPUT VARIABLE WHICH SPECIFIES THE MULTIPLE OF -C THE STANDARD STARTING POINT. IF FACTOR IS UNITY, NO -C MULTIPLICATION IS PERFORMED. -C -C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. -C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE -C -C ********** - INTEGER IVAR,J - DOUBLE PRECISION C1,C2,C3,C4,C5,C6,C7,C8,C9,C10,C11,C12,C13,C14, - * C15,C16,C17,FIVE,H,HALF,ONE,SEVEN,TEN,THREE, - * TWENTY,TWNTF,TWO,ZERO - DOUBLE PRECISION DFLOAT - DATA ZERO,HALF,ONE,TWO,THREE,FIVE,SEVEN,TEN,TWENTY,TWNTF - * /0.0D0,5.0D-1,1.0D0,2.0D0,3.0D0,5.0D0,7.0D0,1.0D1,2.0D1, - * 2.5D1/ - DATA C1,C2,C3,C4,C5,C6,C7,C8,C9,C10,C11,C12,C13,C14,C15,C16,C17 - * /1.2D0,2.5D-1,3.9D-1,4.15D-1,2.0D-2,4.0D3,2.5D2,3.0D-1, - * 4.0D-1,1.5D0,1.0D-2,1.3D0,6.5D-1,7.0D-1,6.0D-1,4.5D0, - * 5.5D0/ - DFLOAT(IVAR) = IVAR -C -C SELECTION OF INITIAL POINT. -C - GO TO (10,10,10,30,40,50,60,70,80,90,100,120,130,140,150,170, - * 190,200), NPROB -C -C LINEAR FUNCTION - FULL RANK OR RANK 1. -C - 10 CONTINUE - DO 20 J = 1, N - X(J) = ONE - 20 CONTINUE - GO TO 210 -C -C ROSENBROCK FUNCTION. -C - 30 CONTINUE - X(1) = -C1 - X(2) = ONE - GO TO 210 -C -C HELICAL VALLEY FUNCTION. -C - 40 CONTINUE - X(1) = -ONE - X(2) = ZERO - X(3) = ZERO - GO TO 210 -C -C POWELL SINGULAR FUNCTION. -C - 50 CONTINUE - X(1) = THREE - X(2) = -ONE - X(3) = ZERO - X(4) = ONE - GO TO 210 -C -C FREUDENSTEIN AND ROTH FUNCTION. -C - 60 CONTINUE - X(1) = HALF - X(2) = -TWO - GO TO 210 -C -C BARD FUNCTION. -C - 70 CONTINUE - X(1) = ONE - X(2) = ONE - X(3) = ONE - GO TO 210 -C -C KOWALIK AND OSBORNE FUNCTION. -C - 80 CONTINUE - X(1) = C2 - X(2) = C3 - X(3) = C4 - X(4) = C3 - GO TO 210 -C -C MEYER FUNCTION. -C - 90 CONTINUE - X(1) = C5 - X(2) = C6 - X(3) = C7 - GO TO 210 -C -C WATSON FUNCTION. -C - 100 CONTINUE - DO 110 J = 1, N - X(J) = ZERO - 110 CONTINUE - GO TO 210 -C -C BOX 3-DIMENSIONAL FUNCTION. -C - 120 CONTINUE - X(1) = ZERO - X(2) = TEN - X(3) = TWENTY - GO TO 210 -C -C JENNRICH AND SAMPSON FUNCTION. -C - 130 CONTINUE - X(1) = C8 - X(2) = C9 - GO TO 210 -C -C BROWN AND DENNIS FUNCTION. -C - 140 CONTINUE - X(1) = TWNTF - X(2) = FIVE - X(3) = -FIVE - X(4) = -ONE - GO TO 210 -C -C CHEBYQUAD FUNCTION. -C - 150 CONTINUE - H = ONE/DFLOAT(N+1) - DO 160 J = 1, N - X(J) = DFLOAT(J)*H - 160 CONTINUE - GO TO 210 -C -C BROWN ALMOST-LINEAR FUNCTION. -C - 170 CONTINUE - DO 180 J = 1, N - X(J) = HALF - 180 CONTINUE - GO TO 210 -C -C OSBORNE 1 FUNCTION. -C - 190 CONTINUE - X(1) = HALF - X(2) = C10 - X(3) = -ONE - X(4) = C11 - X(5) = C5 - GO TO 210 -C -C OSBORNE 2 FUNCTION. -C - 200 CONTINUE - X(1) = C12 - X(2) = C13 - X(3) = C13 - X(4) = C14 - X(5) = C15 - X(6) = THREE - X(7) = FIVE - X(8) = SEVEN - X(9) = TWO - X(10) = C16 - X(11) = C17 - 210 CONTINUE -C -C COMPUTE MULTIPLE OF INITIAL POINT. -C - IF (FACTOR .EQ. ONE) GO TO 260 - IF (NPROB .EQ. 11) GO TO 230 - DO 220 J = 1, N - X(J) = FACTOR*X(J) - 220 CONTINUE - GO TO 250 - 230 CONTINUE - DO 240 J = 1, N - X(J) = FACTOR - 240 CONTINUE - 250 CONTINUE - 260 CONTINUE - RETURN -C -C LAST CARD OF SUBROUTINE INITPT. -C - END diff --git a/ex/file20 b/ex/file20 deleted file mode 100644 index e7c61a3..0000000 --- a/ex/file20 +++ /dev/null @@ -1,860 +0,0 @@ -C ********** -C -C THIS PROGRAM TESTS THE ABILITY OF CHKDER TO DETECT -C INCONSISTENCIES BETWEEN FUNCTIONS AND THEIR FIRST DERIVATIVES. -C FOURTEEN TEST FUNCTION VECTORS AND JACOBIANS ARE USED. ELEVEN OF -C THE TESTS ARE FALSE(F), I.E. THERE ARE INCONSISTENCIES BETWEEN -C THE FUNCTION VECTORS AND THE CORRESPONDING JACOBIANS. THREE OF -C THE TESTS ARE TRUE(T), I.E. THERE ARE NO INCONSISTENCIES. THE -C DRIVER READS IN DATA, CALLS CHKDER AND PRINTS OUT INFORMATION -C REQUIRED BY AND RECEIVED FROM CHKDER. -C -C SUBPROGRAMS CALLED -C -C MINPACK SUPPLIED ... CHKDER,ERRJAC,INITPT,VECFCN -C -C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. -C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE -C -C ********** - INTEGER I,LDFJAC,LNP,MODE,N,NPROB,NREAD,NWRITE - INTEGER NA(14),NP(14) - LOGICAL A(14) - DOUBLE PRECISION CP,ONE - DOUBLE PRECISION DIFF(10),ERR(10),ERRMAX(14),ERRMIN(14), - * FJAC(10,10),FVEC1(10),FVEC2(10),X1(10),X2(10) -C -C LOGICAL INPUT UNIT IS ASSUMED TO BE NUMBER 5. -C LOGICAL OUTPUT UNIT IS ASSUMED TO BE NUMBER 6. -C - DATA NREAD,NWRITE /5,6/ -C - DATA A(1),A(2),A(3),A(4),A(5),A(6),A(7),A(8),A(9),A(10),A(11), - * A(12),A(13),A(14) - * /.FALSE.,.FALSE.,.FALSE.,.TRUE.,.FALSE.,.FALSE.,.FALSE., - * .TRUE.,.FALSE.,.FALSE.,.FALSE.,.FALSE.,.TRUE.,.FALSE./ - DATA CP,ONE /1.23D-1,1.0D0/ - LDFJAC = 10 - 10 CONTINUE - READ (NREAD,60) NPROB,N - IF (NPROB .LE. 0) GO TO 40 - CALL INITPT(N,X1,NPROB,ONE) - DO 20 I = 1, N - X1(I) = X1(I) + CP - CP = -CP - 20 CONTINUE - WRITE (NWRITE,70) NPROB,N,A(NPROB) - MODE = 1 - CALL CHKDER(N,N,X1,FVEC1,FJAC,LDFJAC,X2,FVEC2,MODE,ERR) - MODE = 2 - CALL VECFCN(N,X1,FVEC1,NPROB) - CALL ERRJAC(N,X1,FJAC,LDFJAC,NPROB) - CALL VECFCN(N,X2,FVEC2,NPROB) - CALL CHKDER(N,N,X1,FVEC1,FJAC,LDFJAC,X2,FVEC2,MODE,ERR) - ERRMIN(NPROB) = ERR(1) - ERRMAX(NPROB) = ERR(1) - DO 30 I = 1, N - DIFF(I) = FVEC2(I) - FVEC1(I) - IF (ERRMIN(NPROB) .GT. ERR(I)) ERRMIN(NPROB) = ERR(I) - IF (ERRMAX(NPROB) .LT. ERR(I)) ERRMAX(NPROB) = ERR(I) - 30 CONTINUE - NP(NPROB) = NPROB - LNP = NPROB - NA(NPROB) = N - WRITE (NWRITE,80) (FVEC1(I), I = 1, N) - WRITE (NWRITE,90) (DIFF(I), I = 1, N) - WRITE (NWRITE,100) (ERR(I), I = 1, N) - GO TO 10 - 40 CONTINUE - WRITE (NWRITE,110) LNP - WRITE (NWRITE,120) - DO 50 I = 1, LNP - WRITE (NWRITE,130) NP(I),NA(I),A(I),ERRMIN(I),ERRMAX(I) - 50 CONTINUE - STOP - 60 FORMAT (2I5) - 70 FORMAT ( /// 5X, 8H PROBLEM, I5, 5X, 15H WITH DIMENSION, I5, 2X, - * 5H IS , L1) - 80 FORMAT ( // 5X, 25H FIRST FUNCTION VECTOR // (5X, 5D15.7)) - 90 FORMAT ( // 5X, 27H FUNCTION DIFFERENCE VECTOR // (5X, 5D15.7)) - 100 FORMAT ( // 5X, 13H ERROR VECTOR // (5X, 5D15.7)) - 110 FORMAT (12H1SUMMARY OF , I3, 16H TESTS OF CHKDER /) - 120 FORMAT (46H NPROB N STATUS ERRMIN ERRMAX /) - 130 FORMAT (I4, I6, 6X, L1, 3X, 2D15.7) -C -C LAST CARD OF DERIVATIVE CHECK TEST DRIVER. -C - END - SUBROUTINE ERRJAC(N,X,FJAC,LDFJAC,NPROB) - INTEGER N,LDFJAC,NPROB - DOUBLE PRECISION X(N),FJAC(LDFJAC,N) -C ********** -C -C SUBROUTINE ERRJAC -C -C THIS SUBROUTINE IS DERIVED FROM VECJAC WHICH DEFINES THE -C JACOBIAN MATRICES OF FOURTEEN TEST FUNCTIONS. THE PROBLEM -C DIMENSIONS ARE AS DESCRIBED IN THE PROLOGUE COMMENTS OF VECFCN. -C VARIOUS ERRORS ARE DELIBERATELY INTRODUCED TO PROVIDE A TEST -C FOR CHKDER. -C -C THE SUBROUTINE STATEMENT IS -C -C SUBROUTINE ERRJAC(N,X,FJAC,LDFJAC,NPROB) -C -C WHERE -C -C N IS A POSITIVE INTEGER VARIABLE. -C -C X IS AN ARRAY OF LENGTH N. -C -C FJAC IS AN N BY N ARRAY. ON OUTPUT FJAC CONTAINS THE -C JACOBIAN MATRIX, WITH VARIOUS ERRORS DELIBERATELY -C INTRODUCED, OF THE NPROB FUNCTION EVALUATED AT X. -C -C LDFJAC IS A POSITIVE INTEGER VARIABLE NOT LESS THAN N -C WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY FJAC. -C -C NPROB IS A POSITIVE INTEGER VARIABLE WHICH DEFINES THE -C NUMBER OF THE PROBLEM. NPROB MUST NOT EXCEED 14. -C -C SUBPROGRAMS CALLED -C -C FORTRAN-SUPPLIED ... DATAN,DCOS,DEXP,DMIN1,DSIN,DSQRT, -C MAX0,MIN0 -C -C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. -C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE -C -C ********** - INTEGER I,IVAR,J,K,K1,K2,ML,MU - DOUBLE PRECISION C1,C3,C4,C5,C6,C9,EIGHT,FIFTN,FIVE,FOUR,H, - * HUNDRD,ONE,PROD,SIX,SUM,SUM1,SUM2,TEMP,TEMP1, - * TEMP2,TEMP3,TEMP4,TEN,THREE,TI,TJ,TK,TPI, - * TWENTY,TWO,ZERO - DOUBLE PRECISION DFLOAT - DATA ZERO,ONE,TWO,THREE,FOUR,FIVE,SIX,EIGHT,TEN,FIFTN,TWENTY, - * HUNDRD - * /0.0D0,1.0D0,2.0D0,3.0D0,4.0D0,5.0D0,6.0D0,8.0D0,1.0D1, - * 1.5D1,2.0D1,1.0D2/ - DATA C1,C3,C4,C5,C6,C9 /1.0D4,2.0D2,2.02D1,1.98D1,1.8D2,2.9D1/ - DFLOAT(IVAR) = IVAR -C -C JACOBIAN ROUTINE SELECTOR. -C - GO TO (10,20,50,60,90,100,200,230,290,320,350,380,420,450), - * NPROB -C -C ROSENBROCK FUNCTION WITH SIGN REVERSAL AFFECTING ELEMENT (1,1). -C - 10 CONTINUE - FJAC(1,1) = ONE - FJAC(1,2) = ZERO - FJAC(2,1) = -TWENTY*X(1) - FJAC(2,2) = TEN - GO TO 490 -C -C POWELL SINGULAR FUNCTION WITH SIGN REVERSAL AFFECTING ELEMENT -C (3,3). -C - 20 CONTINUE - DO 40 K = 1, 4 - DO 30 J = 1, 4 - FJAC(K,J) = ZERO - 30 CONTINUE - 40 CONTINUE - FJAC(1,1) = ONE - FJAC(1,2) = TEN - FJAC(2,3) = DSQRT(FIVE) - FJAC(2,4) = -FJAC(2,3) - FJAC(3,2) = TWO*(X(2) - TWO*X(3)) - FJAC(3,3) = TWO*FJAC(3,2) - FJAC(4,1) = TWO*DSQRT(TEN)*(X(1) - X(4)) - FJAC(4,4) = -FJAC(4,1) - GO TO 490 -C -C POWELL BADLY SCALED FUNCTION WITH THE SIGN OF THE JACOBIAN -C REVERSED. -C - 50 CONTINUE - FJAC(1,1) = -C1*X(2) - FJAC(1,2) = -C1*X(1) - FJAC(2,1) = DEXP(-X(1)) - FJAC(2,2) = DEXP(-X(2)) - GO TO 490 -C -C WOOD FUNCTION WITHOUT ERROR. -C - 60 CONTINUE - DO 80 K = 1, 4 - DO 70 J = 1, 4 - FJAC(K,J) = ZERO - 70 CONTINUE - 80 CONTINUE - TEMP1 = X(2) - THREE*X(1)**2 - TEMP2 = X(4) - THREE*X(3)**2 - FJAC(1,1) = -C3*TEMP1 + ONE - FJAC(1,2) = -C3*X(1) - FJAC(2,1) = -TWO*C3*X(1) - FJAC(2,2) = C3 + C4 - FJAC(2,4) = C5 - FJAC(3,3) = -C6*TEMP2 + ONE - FJAC(3,4) = -C6*X(3) - FJAC(4,2) = C5 - FJAC(4,3) = -TWO*C6*X(3) - FJAC(4,4) = C6 + C4 - GO TO 490 -C -C HELICAL VALLEY FUNCTION WITH MULTIPLICATIVE ERROR AFFECTING -C ELEMENTS (2,1) AND (2,2). -C - 90 CONTINUE - TPI = EIGHT*DATAN(ONE) - TEMP = X(1)**2 + X(2)**2 - TEMP1 = TPI*TEMP - TEMP2 = DSQRT(TEMP) - FJAC(1,1) = HUNDRD*X(2)/TEMP1 - FJAC(1,2) = -HUNDRD*X(1)/TEMP1 - FJAC(1,3) = TEN - FJAC(2,1) = FIVE*X(1)/TEMP2 - FJAC(2,2) = FIVE*X(2)/TEMP2 - FJAC(2,3) = ZERO - FJAC(3,1) = ZERO - FJAC(3,2) = ZERO - FJAC(3,3) = ONE - GO TO 490 -C -C WATSON FUNCTION WITH SIGN REVERSALS AFFECTING THE COMPUTATION OF -C TEMP1. -C - 100 CONTINUE - DO 120 K = 1, N - DO 110 J = K, N - FJAC(K,J) = ZERO - 110 CONTINUE - 120 CONTINUE - DO 170 I = 1, 29 - TI = DFLOAT(I)/C9 - SUM1 = ZERO - TEMP = ONE - DO 130 J = 2, N - SUM1 = SUM1 + DFLOAT(J-1)*TEMP*X(J) - TEMP = TI*TEMP - 130 CONTINUE - SUM2 = ZERO - TEMP = ONE - DO 140 J = 1, N - SUM2 = SUM2 + TEMP*X(J) - TEMP = TI*TEMP - 140 CONTINUE - TEMP1 = TWO*(SUM1 + SUM2**2 + ONE) - TEMP2 = TWO*SUM2 - TEMP = TI**2 - TK = ONE - DO 160 K = 1, N - TJ = TK - DO 150 J = K, N - FJAC(K,J) = FJAC(K,J) - * + TJ - * *((DFLOAT(K-1)/TI - TEMP2) - * *(DFLOAT(J-1)/TI - TEMP2) - TEMP1) - TJ = TI*TJ - 150 CONTINUE - TK = TEMP*TK - 160 CONTINUE - 170 CONTINUE - FJAC(1,1) = FJAC(1,1) + SIX*X(1)**2 - TWO*X(2) + THREE - FJAC(1,2) = FJAC(1,2) - TWO*X(1) - FJAC(2,2) = FJAC(2,2) + ONE - DO 190 K = 1, N - DO 180 J = K, N - FJAC(J,K) = FJAC(K,J) - 180 CONTINUE - 190 CONTINUE - GO TO 490 -C -C CHEBYQUAD FUNCTION WITH JACOBIAN TWICE CORRECT SIZE. -C - 200 CONTINUE - TK = ONE/DFLOAT(N) - DO 220 J = 1, N - TEMP1 = ONE - TEMP2 = TWO*X(J) - ONE - TEMP = TWO*TEMP2 - TEMP3 = ZERO - TEMP4 = TWO - DO 210 K = 1, N - FJAC(K,J) = TWO*TK*TEMP4 - TI = FOUR*TEMP2 + TEMP*TEMP4 - TEMP3 - TEMP3 = TEMP4 - TEMP4 = TI - TI = TEMP*TEMP2 - TEMP1 - TEMP1 = TEMP2 - TEMP2 = TI - 210 CONTINUE - 220 CONTINUE - GO TO 490 -C -C BROWN ALMOST-LINEAR FUNCTION WITHOUT ERROR. -C - 230 CONTINUE - PROD = ONE - DO 250 J = 1, N - PROD = X(J)*PROD - DO 240 K = 1, N - FJAC(K,J) = ONE - 240 CONTINUE - FJAC(J,J) = TWO - 250 CONTINUE - DO 280 J = 1, N - TEMP = X(J) - IF (TEMP .NE. ZERO) GO TO 270 - TEMP = ONE - PROD = ONE - DO 260 K = 1, N - IF (K .NE. J) PROD = X(K)*PROD - 260 CONTINUE - 270 CONTINUE - FJAC(N,J) = PROD/TEMP - 280 CONTINUE - GO TO 490 -C -C DISCRETE BOUNDARY VALUE FUNCTION WITH MULTIPLICATIVE ERROR -C AFFECTING THE JACOBIAN DIAGONAL. -C - 290 CONTINUE - H = ONE/DFLOAT(N+1) - DO 310 K = 1, N - TEMP = THREE*(X(K) + DFLOAT(K)*H + ONE)**2 - DO 300 J = 1, N - FJAC(K,J) = ZERO - 300 CONTINUE - FJAC(K,K) = FOUR + TEMP*H**2 - IF (K .NE. 1) FJAC(K,K-1) = -ONE - IF (K .NE. N) FJAC(K,K+1) = -ONE - 310 CONTINUE - GO TO 490 -C -C DISCRETE INTEGRAL EQUATION FUNCTION WITH SIGN ERROR AFFECTING -C THE JACOBIAN DIAGONAL. -C - 320 CONTINUE - H = ONE/DFLOAT(N+1) - DO 340 K = 1, N - TK = DFLOAT(K)*H - DO 330 J = 1, N - TJ = DFLOAT(J)*H - TEMP = THREE*(X(J) + TJ + ONE)**2 - FJAC(K,J) = H*DMIN1(TJ*(ONE-TK),TK*(ONE-TJ))*TEMP/TWO - 330 CONTINUE - FJAC(K,K) = FJAC(K,K) - ONE - 340 CONTINUE - GO TO 490 -C -C TRIGONOMETRIC FUNCTION WITH SIGN ERRORS AFFECTING THE -C OFFDIAGONAL ELEMENTS OF THE JACOBIAN. -C - 350 CONTINUE - DO 370 J = 1, N - TEMP = DSIN(X(J)) - DO 360 K = 1, N - FJAC(K,J) = -TEMP - 360 CONTINUE - FJAC(J,J) = DFLOAT(J+1)*TEMP - DCOS(X(J)) - 370 CONTINUE - GO TO 490 -C -C VARIABLY DIMENSIONED FUNCTION WITH OPERATION ERROR AFFECTING -C THE UPPER TRIANGULAR ELEMENTS OF THE JACOBIAN. -C - 380 CONTINUE - SUM = ZERO - DO 390 J = 1, N - SUM = SUM + DFLOAT(J)*(X(J) - ONE) - 390 CONTINUE - TEMP = ONE + SIX*SUM**2 - DO 410 K = 1, N - DO 400 J = K, N - FJAC(K,J) = DFLOAT(K*J)/TEMP - FJAC(J,K) = FJAC(K,J) - 400 CONTINUE - FJAC(K,K) = FJAC(K,K) + ONE - 410 CONTINUE - GO TO 490 -C -C BROYDEN TRIDIAGONAL FUNCTION WITHOUT ERROR. -C - 420 CONTINUE - DO 440 K = 1, N - DO 430 J = 1, N - FJAC(K,J) = ZERO - 430 CONTINUE - FJAC(K,K) = THREE - FOUR*X(K) - IF (K .NE. 1) FJAC(K,K-1) = -ONE - IF (K .NE. N) FJAC(K,K+1) = -TWO - 440 CONTINUE - GO TO 490 -C -C BROYDEN BANDED FUNCTION WITH SIGN ERROR AFFECTING THE JACOBIAN -C DIAGONAL. -C - 450 CONTINUE - ML = 5 - MU = 1 - DO 480 K = 1, N - DO 460 J = 1, N - FJAC(K,J) = ZERO - 460 CONTINUE - K1 = MAX0(1,K-ML) - K2 = MIN0(K+MU,N) - DO 470 J = K1, K2 - IF (J .NE. K) FJAC(K,J) = -(ONE + TWO*X(J)) - 470 CONTINUE - FJAC(K,K) = TWO - FIFTN*X(K)**2 - 480 CONTINUE - 490 CONTINUE - RETURN -C -C LAST CARD OF SUBROUTINE ERRJAC. -C - END - SUBROUTINE INITPT(N,X,NPROB,FACTOR) - INTEGER N,NPROB - DOUBLE PRECISION FACTOR - DOUBLE PRECISION X(N) -C ********** -C -C SUBROUTINE INITPT -C -C THIS SUBROUTINE SPECIFIES THE STANDARD STARTING POINTS FOR -C THE FUNCTIONS DEFINED BY SUBROUTINE VECFCN. THE SUBROUTINE -C RETURNS IN X A MULTIPLE (FACTOR) OF THE STANDARD STARTING -C POINT. FOR THE SIXTH FUNCTION THE STANDARD STARTING POINT IS -C ZERO, SO IN THIS CASE, IF FACTOR IS NOT UNITY, THEN THE -C SUBROUTINE RETURNS THE VECTOR X(J) = FACTOR, J=1,...,N. -C -C THE SUBROUTINE STATEMENT IS -C -C SUBROUTINE INITPT(N,X,NPROB,FACTOR) -C -C WHERE -C -C N IS A POSITIVE INTEGER INPUT VARIABLE. -C -C X IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE STANDARD -C STARTING POINT FOR PROBLEM NPROB MULTIPLIED BY FACTOR. -C -C NPROB IS A POSITIVE INTEGER INPUT VARIABLE WHICH DEFINES THE -C NUMBER OF THE PROBLEM. NPROB MUST NOT EXCEED 14. -C -C FACTOR IS AN INPUT VARIABLE WHICH SPECIFIES THE MULTIPLE OF -C THE STANDARD STARTING POINT. IF FACTOR IS UNITY, NO -C MULTIPLICATION IS PERFORMED. -C -C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. -C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE -C -C ********** - INTEGER IVAR,J - DOUBLE PRECISION C1,H,HALF,ONE,THREE,TJ,ZERO - DOUBLE PRECISION DFLOAT - DATA ZERO,HALF,ONE,THREE,C1 /0.0D0,5.0D-1,1.0D0,3.0D0,1.2D0/ - DFLOAT(IVAR) = IVAR -C -C SELECTION OF INITIAL POINT. -C - GO TO (10,20,30,40,50,60,80,100,120,120,140,160,180,180), NPROB -C -C ROSENBROCK FUNCTION. -C - 10 CONTINUE - X(1) = -C1 - X(2) = ONE - GO TO 200 -C -C POWELL SINGULAR FUNCTION. -C - 20 CONTINUE - X(1) = THREE - X(2) = -ONE - X(3) = ZERO - X(4) = ONE - GO TO 200 -C -C POWELL BADLY SCALED FUNCTION. -C - 30 CONTINUE - X(1) = ZERO - X(2) = ONE - GO TO 200 -C -C WOOD FUNCTION. -C - 40 CONTINUE - X(1) = -THREE - X(2) = -ONE - X(3) = -THREE - X(4) = -ONE - GO TO 200 -C -C HELICAL VALLEY FUNCTION. -C - 50 CONTINUE - X(1) = -ONE - X(2) = ZERO - X(3) = ZERO - GO TO 200 -C -C WATSON FUNCTION. -C - 60 CONTINUE - DO 70 J = 1, N - X(J) = ZERO - 70 CONTINUE - GO TO 200 -C -C CHEBYQUAD FUNCTION. -C - 80 CONTINUE - H = ONE/DFLOAT(N+1) - DO 90 J = 1, N - X(J) = DFLOAT(J)*H - 90 CONTINUE - GO TO 200 -C -C BROWN ALMOST-LINEAR FUNCTION. -C - 100 CONTINUE - DO 110 J = 1, N - X(J) = HALF - 110 CONTINUE - GO TO 200 -C -C DISCRETE BOUNDARY VALUE AND INTEGRAL EQUATION FUNCTIONS. -C - 120 CONTINUE - H = ONE/DFLOAT(N+1) - DO 130 J = 1, N - TJ = DFLOAT(J)*H - X(J) = TJ*(TJ - ONE) - 130 CONTINUE - GO TO 200 -C -C TRIGONOMETRIC FUNCTION. -C - 140 CONTINUE - H = ONE/DFLOAT(N) - DO 150 J = 1, N - X(J) = H - 150 CONTINUE - GO TO 200 -C -C VARIABLY DIMENSIONED FUNCTION. -C - 160 CONTINUE - H = ONE/DFLOAT(N) - DO 170 J = 1, N - X(J) = ONE - DFLOAT(J)*H - 170 CONTINUE - GO TO 200 -C -C BROYDEN TRIDIAGONAL AND BANDED FUNCTIONS. -C - 180 CONTINUE - DO 190 J = 1, N - X(J) = -ONE - 190 CONTINUE - 200 CONTINUE -C -C COMPUTE MULTIPLE OF INITIAL POINT. -C - IF (FACTOR .EQ. ONE) GO TO 250 - IF (NPROB .EQ. 6) GO TO 220 - DO 210 J = 1, N - X(J) = FACTOR*X(J) - 210 CONTINUE - GO TO 240 - 220 CONTINUE - DO 230 J = 1, N - X(J) = FACTOR - 230 CONTINUE - 240 CONTINUE - 250 CONTINUE - RETURN -C -C LAST CARD OF SUBROUTINE INITPT. -C - END - SUBROUTINE VECFCN(N,X,FVEC,NPROB) - INTEGER N,NPROB - DOUBLE PRECISION X(N),FVEC(N) -C ********** -C -C SUBROUTINE VECFCN -C -C THIS SUBROUTINE DEFINES FOURTEEN TEST FUNCTIONS. THE FIRST -C FIVE TEST FUNCTIONS ARE OF DIMENSIONS 2,4,2,4,3, RESPECTIVELY, -C WHILE THE REMAINING TEST FUNCTIONS ARE OF VARIABLE DIMENSION -C N FOR ANY N GREATER THAN OR EQUAL TO 1 (PROBLEM 6 IS AN -C EXCEPTION TO THIS, SINCE IT DOES NOT ALLOW N = 1). -C -C THE SUBROUTINE STATEMENT IS -C -C SUBROUTINE VECFCN(N,X,FVEC,NPROB) -C -C WHERE -C -C N IS A POSITIVE INTEGER INPUT VARIABLE. -C -C X IS AN INPUT ARRAY OF LENGTH N. -C -C FVEC IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE NPROB -C FUNCTION VECTOR EVALUATED AT X. -C -C NPROB IS A POSITIVE INTEGER INPUT VARIABLE WHICH DEFINES THE -C NUMBER OF THE PROBLEM. NPROB MUST NOT EXCEED 14. -C -C SUBPROGRAMS CALLED -C -C FORTRAN-SUPPLIED ... DATAN,DCOS,DEXP,DSIGN,DSIN,DSQRT, -C MAX0,MIN0 -C -C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. -C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE -C -C ********** - INTEGER I,IEV,IVAR,J,K,K1,K2,KP1,ML,MU - DOUBLE PRECISION C1,C2,C3,C4,C5,C6,C7,C8,C9,EIGHT,FIVE,H,ONE, - * PROD,SUM,SUM1,SUM2,TEMP,TEMP1,TEMP2,TEN,THREE, - * TI,TJ,TK,TPI,TWO,ZERO - DOUBLE PRECISION DFLOAT - DATA ZERO,ONE,TWO,THREE,FIVE,EIGHT,TEN - * /0.0D0,1.0D0,2.0D0,3.0D0,5.0D0,8.0D0,1.0D1/ - DATA C1,C2,C3,C4,C5,C6,C7,C8,C9 - * /1.0D4,1.0001D0,2.0D2,2.02D1,1.98D1,1.8D2,2.5D-1,5.0D-1, - * 2.9D1/ - DFLOAT(IVAR) = IVAR -C -C PROBLEM SELECTOR. -C - GO TO (10,20,30,40,50,60,120,170,200,220,270,300,330,350), NPROB -C -C ROSENBROCK FUNCTION. -C - 10 CONTINUE - FVEC(1) = ONE - X(1) - FVEC(2) = TEN*(X(2) - X(1)**2) - GO TO 380 -C -C POWELL SINGULAR FUNCTION. -C - 20 CONTINUE - FVEC(1) = X(1) + TEN*X(2) - FVEC(2) = DSQRT(FIVE)*(X(3) - X(4)) - FVEC(3) = (X(2) - TWO*X(3))**2 - FVEC(4) = DSQRT(TEN)*(X(1) - X(4))**2 - GO TO 380 -C -C POWELL BADLY SCALED FUNCTION. -C - 30 CONTINUE - FVEC(1) = C1*X(1)*X(2) - ONE - FVEC(2) = DEXP(-X(1)) + DEXP(-X(2)) - C2 - GO TO 380 -C -C WOOD FUNCTION. -C - 40 CONTINUE - TEMP1 = X(2) - X(1)**2 - TEMP2 = X(4) - X(3)**2 - FVEC(1) = -C3*X(1)*TEMP1 - (ONE - X(1)) - FVEC(2) = C3*TEMP1 + C4*(X(2) - ONE) + C5*(X(4) - ONE) - FVEC(3) = -C6*X(3)*TEMP2 - (ONE - X(3)) - FVEC(4) = C6*TEMP2 + C4*(X(4) - ONE) + C5*(X(2) - ONE) - GO TO 380 -C -C HELICAL VALLEY FUNCTION. -C - 50 CONTINUE - TPI = EIGHT*DATAN(ONE) - TEMP1 = DSIGN(C7,X(2)) - IF (X(1) .GT. ZERO) TEMP1 = DATAN(X(2)/X(1))/TPI - IF (X(1) .LT. ZERO) TEMP1 = DATAN(X(2)/X(1))/TPI + C8 - TEMP2 = DSQRT(X(1)**2+X(2)**2) - FVEC(1) = TEN*(X(3) - TEN*TEMP1) - FVEC(2) = TEN*(TEMP2 - ONE) - FVEC(3) = X(3) - GO TO 380 -C -C WATSON FUNCTION. -C - 60 CONTINUE - DO 70 K = 1, N - FVEC(K) = ZERO - 70 CONTINUE - DO 110 I = 1, 29 - TI = DFLOAT(I)/C9 - SUM1 = ZERO - TEMP = ONE - DO 80 J = 2, N - SUM1 = SUM1 + DFLOAT(J-1)*TEMP*X(J) - TEMP = TI*TEMP - 80 CONTINUE - SUM2 = ZERO - TEMP = ONE - DO 90 J = 1, N - SUM2 = SUM2 + TEMP*X(J) - TEMP = TI*TEMP - 90 CONTINUE - TEMP1 = SUM1 - SUM2**2 - ONE - TEMP2 = TWO*TI*SUM2 - TEMP = ONE/TI - DO 100 K = 1, N - FVEC(K) = FVEC(K) + TEMP*(DFLOAT(K-1) - TEMP2)*TEMP1 - TEMP = TI*TEMP - 100 CONTINUE - 110 CONTINUE - TEMP = X(2) - X(1)**2 - ONE - FVEC(1) = FVEC(1) + X(1)*(ONE - TWO*TEMP) - FVEC(2) = FVEC(2) + TEMP - GO TO 380 -C -C CHEBYQUAD FUNCTION. -C - 120 CONTINUE - DO 130 K = 1, N - FVEC(K) = ZERO - 130 CONTINUE - DO 150 J = 1, N - TEMP1 = ONE - TEMP2 = TWO*X(J) - ONE - TEMP = TWO*TEMP2 - DO 140 I = 1, N - FVEC(I) = FVEC(I) + TEMP2 - TI = TEMP*TEMP2 - TEMP1 - TEMP1 = TEMP2 - TEMP2 = TI - 140 CONTINUE - 150 CONTINUE - TK = ONE/DFLOAT(N) - IEV = -1 - DO 160 K = 1, N - FVEC(K) = TK*FVEC(K) - IF (IEV .GT. 0) FVEC(K) = FVEC(K) + ONE/(DFLOAT(K)**2 - ONE) - IEV = -IEV - 160 CONTINUE - GO TO 380 -C -C BROWN ALMOST-LINEAR FUNCTION. -C - 170 CONTINUE - SUM = -DFLOAT(N+1) - PROD = ONE - DO 180 J = 1, N - SUM = SUM + X(J) - PROD = X(J)*PROD - 180 CONTINUE - DO 190 K = 1, N - FVEC(K) = X(K) + SUM - 190 CONTINUE - FVEC(N) = PROD - ONE - GO TO 380 -C -C DISCRETE BOUNDARY VALUE FUNCTION. -C - 200 CONTINUE - H = ONE/DFLOAT(N+1) - DO 210 K = 1, N - TEMP = (X(K) + DFLOAT(K)*H + ONE)**3 - TEMP1 = ZERO - IF (K .NE. 1) TEMP1 = X(K-1) - TEMP2 = ZERO - IF (K .NE. N) TEMP2 = X(K+1) - FVEC(K) = TWO*X(K) - TEMP1 - TEMP2 + TEMP*H**2/TWO - 210 CONTINUE - GO TO 380 -C -C DISCRETE INTEGRAL EQUATION FUNCTION. -C - 220 CONTINUE - H = ONE/DFLOAT(N+1) - DO 260 K = 1, N - TK = DFLOAT(K)*H - SUM1 = ZERO - DO 230 J = 1, K - TJ = DFLOAT(J)*H - TEMP = (X(J) + TJ + ONE)**3 - SUM1 = SUM1 + TJ*TEMP - 230 CONTINUE - SUM2 = ZERO - KP1 = K + 1 - IF (N .LT. KP1) GO TO 250 - DO 240 J = KP1, N - TJ = DFLOAT(J)*H - TEMP = (X(J) + TJ + ONE)**3 - SUM2 = SUM2 + (ONE - TJ)*TEMP - 240 CONTINUE - 250 CONTINUE - FVEC(K) = X(K) + H*((ONE - TK)*SUM1 + TK*SUM2)/TWO - 260 CONTINUE - GO TO 380 -C -C TRIGONOMETRIC FUNCTION. -C - 270 CONTINUE - SUM = ZERO - DO 280 J = 1, N - FVEC(J) = DCOS(X(J)) - SUM = SUM + FVEC(J) - 280 CONTINUE - DO 290 K = 1, N - FVEC(K) = DFLOAT(N+K) - DSIN(X(K)) - SUM - DFLOAT(K)*FVEC(K) - 290 CONTINUE - GO TO 380 -C -C VARIABLY DIMENSIONED FUNCTION. -C - 300 CONTINUE - SUM = ZERO - DO 310 J = 1, N - SUM = SUM + DFLOAT(J)*(X(J) - ONE) - 310 CONTINUE - TEMP = SUM*(ONE + TWO*SUM**2) - DO 320 K = 1, N - FVEC(K) = X(K) - ONE + DFLOAT(K)*TEMP - 320 CONTINUE - GO TO 380 -C -C BROYDEN TRIDIAGONAL FUNCTION. -C - 330 CONTINUE - DO 340 K = 1, N - TEMP = (THREE - TWO*X(K))*X(K) - TEMP1 = ZERO - IF (K .NE. 1) TEMP1 = X(K-1) - TEMP2 = ZERO - IF (K .NE. N) TEMP2 = X(K+1) - FVEC(K) = TEMP - TEMP1 - TWO*TEMP2 + ONE - 340 CONTINUE - GO TO 380 -C -C BROYDEN BANDED FUNCTION. -C - 350 CONTINUE - ML = 5 - MU = 1 - DO 370 K = 1, N - K1 = MAX0(1,K-ML) - K2 = MIN0(K+MU,N) - TEMP = ZERO - DO 360 J = K1, K2 - IF (J .NE. K) TEMP = TEMP + X(J)*(ONE + X(J)) - 360 CONTINUE - FVEC(K) = X(K)*(TWO + FIVE*X(K)**2) + ONE - TEMP - 370 CONTINUE - 380 CONTINUE - RETURN -C -C LAST CARD OF SUBROUTINE VECFCN. -C - END diff --git a/ex/file21 b/ex/file21 deleted file mode 100644 index 9d867c8..0000000 --- a/ex/file21 +++ /dev/null @@ -1,23 +0,0 @@ - 1 2 3 - 2 4 3 - 3 2 2 - 4 4 3 - 5 3 3 - 6 6 2 - 6 9 2 - 7 5 3 - 7 6 3 - 7 7 3 - 7 8 1 - 7 9 1 - 8 10 3 - 8 30 1 - 8 40 1 - 9 10 3 - 10 1 3 - 10 10 3 - 11 10 3 - 12 10 3 - 13 10 3 - 14 10 3 - 0 0 0 diff --git a/ex/file22 b/ex/file22 deleted file mode 100644 index b3cf138..0000000 --- a/ex/file22 +++ /dev/null @@ -1,29 +0,0 @@ - 1 5 10 1 - 1 5 50 1 - 2 5 10 1 - 2 5 50 1 - 3 5 10 1 - 3 5 50 1 - 4 2 2 3 - 5 3 3 3 - 6 4 4 3 - 7 2 2 3 - 8 3 15 3 - 9 4 11 3 - 10 3 16 2 - 11 6 31 3 - 11 9 31 3 - 11 12 31 3 - 12 3 10 1 - 13 2 10 1 - 14 4 20 3 - 15 1 8 3 - 15 8 8 1 - 15 9 9 1 - 15 10 10 1 - 16 10 10 3 - 16 30 30 1 - 16 40 40 1 - 17 5 33 1 - 18 11 65 1 - 0 0 0 0 diff --git a/ex/file23 b/ex/file23 deleted file mode 100644 index 0dff12e..0000000 --- a/ex/file23 +++ /dev/null @@ -1,15 +0,0 @@ - 1 2 - 2 4 - 3 2 - 4 4 - 5 3 - 6 9 - 7 7 - 8 10 - 9 10 - 10 10 - 11 10 - 12 10 - 13 10 - 14 10 - 0 0 diff --git a/ex/hybdrv.f b/ex/hybdrv.f deleted file mode 100644 index 29b8b45..0000000 --- a/ex/hybdrv.f +++ /dev/null @@ -1,112 +0,0 @@ -c ********** -c -c this program tests codes for the solution of n nonlinear -c equations in n variables. it consists of a driver and an -c interface subroutine fcn. the driver reads in data, calls the -c nonlinear equation solver, and finally prints out information -c on the performance of the solver. this is only a sample driver, -c many other drivers are possible. the interface subroutine fcn -c is necessary to take into account the forms of calling -c sequences used by the function subroutines in the various -c nonlinear equation solvers. -c -c subprograms called -c -c user-supplied ...... fcn -c -c minpack-supplied ... dpmpar,enorm,hybrd1,initpt,vecfcn -c -c fortran-supplied ... dsqrt -c -c argonne national laboratory. minpack project. march 1980. -c burton s. garbow, kenneth e. hillstrom, jorge j. more -c -c ********** - integer i,ic,info,k,lwa,n,nfev,nprob,nread,ntries,nwrite - integer na(60),nf(60),np(60),nx(60) - double precision factor,fnorm1,fnorm2,one,ten,tol - double precision fnm(60),fvec(40),wa(2660),x(40) - double precision dpmpar,enorm - external fcn - common /refnum/ nprob,nfev -c -c logical input unit is assumed to be number 5. -c logical output unit is assumed to be number 6. -c - data nread,nwrite /5,6/ -c - data one,ten /1.0d0,1.0d1/ - tol = dsqrt(dpmpar(1)) - lwa = 2660 - ic = 0 - 10 continue - read (nread,50) nprob,n,ntries - if (nprob .le. 0) go to 30 - factor = one - do 20 k = 1, ntries - ic = ic + 1 - call initpt(n,x,nprob,factor) - call vecfcn(n,x,fvec,nprob) - fnorm1 = enorm(n,fvec) - write (nwrite,60) nprob,n - nfev = 0 - call hybrd1(fcn,n,x,fvec,tol,info,wa,lwa) - fnorm2 = enorm(n,fvec) - np(ic) = nprob - na(ic) = n - nf(ic) = nfev - nx(ic) = info - fnm(ic) = fnorm2 - write (nwrite,70) fnorm1,fnorm2,nfev,info,(x(i), i = 1, n) - factor = ten*factor - 20 continue - go to 10 - 30 continue - write (nwrite,80) ic - write (nwrite,90) - do 40 i = 1, ic - write (nwrite,100) np(i),na(i),nf(i),nx(i),fnm(i) - 40 continue - stop - 50 format (3i5) - 60 format ( //// 5x, 8h problem, i5, 5x, 10h dimension, i5, 5x //) - 70 format (5x, 33h initial l2 norm of the residuals, d15.7 // 5x, - * 33h final l2 norm of the residuals , d15.7 // 5x, - * 33h number of function evaluations , i10 // 5x, - * 15h exit parameter, 18x, i10 // 5x, - * 27h final approximate solution // (5x, 5d15.7)) - 80 format (12h1summary of , i3, 16h calls to hybrd1 /) - 90 format (39h nprob n nfev info final l2 norm /) - 100 format (i4, i6, i7, i6, 1x, d15.7) -c -c last card of driver. -c - end - subroutine fcn(n,x,fvec,iflag) - integer n,iflag - double precision x(n),fvec(n) -c ********** -c -c the calling sequence of fcn should be identical to the -c calling sequence of the function subroutine in the nonlinear -c equation solver. fcn should only call the testing function -c subroutine vecfcn with the appropriate value of problem -c number (nprob). -c -c subprograms called -c -c minpack-supplied ... vecfcn -c -c argonne national laboratory. minpack project. march 1980. -c burton s. garbow, kenneth e. hillstrom, jorge j. more -c -c ********** - integer nprob,nfev - common /refnum/ nprob,nfev - call vecfcn(n,x,fvec,nprob) - nfev = nfev + 1 - return -c -c last card of interface subroutine fcn. -c - end diff --git a/ex/hyjdrv.f b/ex/hyjdrv.f deleted file mode 100644 index dca87ad..0000000 --- a/ex/hyjdrv.f +++ /dev/null @@ -1,120 +0,0 @@ -c ********** -c -c this program tests codes for the solution of n nonlinear -c equations in n variables. it consists of a driver and an -c interface subroutine fcn. the driver reads in data, calls the -c nonlinear equation solver, and finally prints out information -c on the performance of the solver. this is only a sample driver, -c many other drivers are possible. the interface subroutine fcn -c is necessary to take into account the forms of calling -c sequences used by the function and jacobian subroutines in -c the various nonlinear equation solvers. -c -c subprograms called -c -c user-supplied ...... fcn -c -c minpack-supplied ... dpmpar,enorm,hybrj1,initpt,vecfcn -c -c fortran-supplied ... dsqrt -c -c argonne national laboratory. minpack project. march 1980. -c burton s. garbow, kenneth e. hillstrom, jorge j. more -c -c ********** - integer i,ic,info,k,ldfjac,lwa,n,nfev,njev,nprob,nread,ntries, - 1 nwrite - integer na(60),nf(60),nj(60),np(60),nx(60) - double precision factor,fnorm1,fnorm2,one,ten,tol - double precision fnm(60),fjac(40,40),fvec(40),wa(1060),x(40) - double precision dpmpar,enorm - external fcn - common /refnum/ nprob,nfev,njev -c -c logical input unit is assumed to be number 5. -c logical output unit is assumed to be number 6. -c - data nread,nwrite /5,6/ -c - data one,ten /1.0d0,1.0d1/ - tol = dsqrt(dpmpar(1)) - ldfjac = 40 - lwa = 1060 - ic = 0 - 10 continue - read (nread,50) nprob,n,ntries - if (nprob .le. 0) go to 30 - factor = one - do 20 k = 1, ntries - ic = ic + 1 - call initpt(n,x,nprob,factor) - call vecfcn(n,x,fvec,nprob) - fnorm1 = enorm(n,fvec) - write (nwrite,60) nprob,n - nfev = 0 - njev = 0 - call hybrj1(fcn,n,x,fvec,fjac,ldfjac,tol,info,wa,lwa) - fnorm2 = enorm(n,fvec) - np(ic) = nprob - na(ic) = n - nf(ic) = nfev - nj(ic) = njev - nx(ic) = info - fnm(ic) = fnorm2 - write (nwrite,70) - 1 fnorm1,fnorm2,nfev,njev,info,(x(i), i = 1, n) - factor = ten*factor - 20 continue - go to 10 - 30 continue - write (nwrite,80) ic - write (nwrite,90) - do 40 i = 1, ic - write (nwrite,100) np(i),na(i),nf(i),nj(i),nx(i),fnm(i) - 40 continue - stop - 50 format (3i5) - 60 format ( //// 5x, 8h problem, i5, 5x, 10h dimension, i5, 5x //) - 70 format (5x, 33h initial l2 norm of the residuals, d15.7 // 5x, - 1 33h final l2 norm of the residuals , d15.7 // 5x, - 2 33h number of function evaluations , i10 // 5x, - 3 33h number of jacobian evaluations , i10 // 5x, - 4 15h exit parameter, 18x, i10 // 5x, - 5 27h final approximate solution // (5x, 5d15.7)) - 80 format (12h1summary of , i3, 16h calls to hybrj1 /) - 90 format (46h nprob n nfev njev info final l2 norm /) - 100 format (i4, i6, 2i7, i6, 1x, d15.7) -c -c last card of driver. -c - end - subroutine fcn(n,x,fvec,fjac,ldfjac,iflag) - integer n,ldfjac,iflag - double precision x(n),fvec(n),fjac(ldfjac,n) -c ********** -c -c the calling sequence of fcn should be identical to the -c calling sequence of the function subroutine in the nonlinear -c equation solver. fcn should only call the testing function -c and jacobian subroutines vecfcn and vecjac with the -c appropriate value of problem number (nprob). -c -c subprograms called -c -c minpack-supplied ... vecfcn,vecjac -c -c argonne national laboratory. minpack project. march 1980. -c burton s. garbow, kenneth e. hillstrom, jorge j. more -c -c ********** - integer nprob,nfev,njev - common /refnum/ nprob,nfev,njev - if (iflag .eq. 1) call vecfcn(n,x,fvec,nprob) - if (iflag .eq. 2) call vecjac(n,x,fjac,ldfjac,nprob) - if (iflag .eq. 1) nfev = nfev + 1 - if (iflag .eq. 2) njev = njev + 1 - return -c -c last card of interface subroutine fcn. -c - end diff --git a/ex/lmddrv.f b/ex/lmddrv.f deleted file mode 100644 index 31a34c9..0000000 --- a/ex/lmddrv.f +++ /dev/null @@ -1,124 +0,0 @@ -c ********** -c -c this program tests codes for the least-squares solution of -c m nonlinear equations in n variables. it consists of a driver -c and an interface subroutine fcn. the driver reads in data, -c calls the nonlinear least-squares solver, and finally prints -c out information on the performance of the solver. this is -c only a sample driver, many other drivers are possible. the -c interface subroutine fcn is necessary to take into account the -c forms of calling sequences used by the function and jacobian -c subroutines in the various nonlinear least-squares solvers. -c -c subprograms called -c -c user-supplied ...... fcn -c -c minpack-supplied ... dpmpar,enorm,initpt,lmder1,ssqfcn -c -c fortran-supplied ... dsqrt -c -c argonne national laboratory. minpack project. march 1980. -c burton s. garbow, kenneth e. hillstrom, jorge j. more -c -c ********** - integer i,ic,info,k,ldfjac,lwa,m,n,nfev,njev,nprob,nread,ntries, - * nwrite - integer iwa(40),ma(60),na(60),nf(60),nj(60),np(60),nx(60) - double precision factor,fnorm1,fnorm2,one,ten,tol - double precision fjac(65,40),fnm(60),fvec(65),wa(265),x(40) - double precision dpmpar,enorm - external fcn - common /refnum/ nprob,nfev,njev -c -c logical input unit is assumed to be number 5. -c logical output unit is assumed to be number 6. -c - data nread,nwrite /5,6/ -c - data one,ten /1.0d0,1.0d1/ - tol = dsqrt(dpmpar(1)) - ldfjac = 65 - lwa = 265 - ic = 0 - 10 continue - read (nread,50) nprob,n,m,ntries - if (nprob .le. 0) go to 30 - factor = one - do 20 k = 1, ntries - ic = ic + 1 - call initpt(n,x,nprob,factor) - call ssqfcn(m,n,x,fvec,nprob) - fnorm1 = enorm(m,fvec) - write (nwrite,60) nprob,n,m - nfev = 0 - njev = 0 - call lmder1(fcn,m,n,x,fvec,fjac,ldfjac,tol,info,iwa,wa, - * lwa) - call ssqfcn(m,n,x,fvec,nprob) - fnorm2 = enorm(m,fvec) - np(ic) = nprob - na(ic) = n - ma(ic) = m - nf(ic) = nfev - nj(ic) = njev - nx(ic) = info - fnm(ic) = fnorm2 - write (nwrite,70) - * fnorm1,fnorm2,nfev,njev,info,(x(i), i = 1, n) - factor = ten*factor - 20 continue - go to 10 - 30 continue - write (nwrite,80) ic - write (nwrite,90) - do 40 i = 1, ic - write (nwrite,100) np(i),na(i),ma(i),nf(i),nj(i),nx(i),fnm(i) - 40 continue - stop - 50 format (4i5) - 60 format ( //// 5x, 8h problem, i5, 5x, 11h dimensions, 2i5, 5x // - * ) - 70 format (5x, 33h initial l2 norm of the residuals, d15.7 // 5x, - * 33h final l2 norm of the residuals , d15.7 // 5x, - * 33h number of function evaluations , i10 // 5x, - * 33h number of jacobian evaluations , i10 // 5x, - * 15h exit parameter, 18x, i10 // 5x, - * 27h final approximate solution // (5x, 5d15.7)) - 80 format (12h1summary of , i3, 16h calls to lmder1 /) - 90 format (49h nprob n m nfev njev info final l2 norm /) - 100 format (3i5, 3i6, 1x, d15.7) -c -c last card of driver. -c - end - subroutine fcn(m,n,x,fvec,fjac,ldfjac,iflag) - integer m,n,ldfjac,iflag - double precision x(n),fvec(m),fjac(ldfjac,n) -c ********** -c -c the calling sequence of fcn should be identical to the -c calling sequence of the function subroutine in the nonlinear -c least-squares solver. fcn should only call the testing -c function and jacobian subroutines ssqfcn and ssqjac with -c the appropriate value of problem number (nprob). -c -c subprograms called -c -c minpack-supplied ... ssqfcn,ssqjac -c -c argonne national laboratory. minpack project. march 1980. -c burton s. garbow, kenneth e. hillstrom, jorge j. more -c -c ********** - integer nprob,nfev,njev - common /refnum/ nprob,nfev,njev - if (iflag .eq. 1) call ssqfcn(m,n,x,fvec,nprob) - if (iflag .eq. 2) call ssqjac(m,n,x,fjac,ldfjac,nprob) - if (iflag .eq. 1) nfev = nfev + 1 - if (iflag .eq. 2) njev = njev + 1 - return -c -c last card of interface subroutine fcn. -c - end diff --git a/ex/lmfdrv.f b/ex/lmfdrv.f deleted file mode 100644 index ad8756f..0000000 --- a/ex/lmfdrv.f +++ /dev/null @@ -1,121 +0,0 @@ -c ********** -c -c this program tests codes for the least-squares solution of -c m nonlinear equations in n variables. it consists of a driver -c and an interface subroutine fcn. the driver reads in data, -c calls the nonlinear least-squares solver, and finally prints -c out information on the performance of the solver. this is -c only a sample driver, many other drivers are possible. the -c interface subroutine fcn is necessary to take into account the -c forms of calling sequences used by the function and jacobian -c subroutines in the various nonlinear least-squares solvers. -c -c subprograms called -c -c user-supplied ...... fcn -c -c minpack-supplied ... dpmpar,enorm,initpt,lmdif1,ssqfcn -c -c fortran-supplied ... dsqrt -c -c argonne national laboratory. minpack project. march 1980. -c burton s. garbow, kenneth e. hillstrom, jorge j. more -c -c ********** - integer i,ic,info,k,lwa,m,n,nfev,njev,nprob,nread,ntries,nwrite - integer iwa(40),ma(60),na(60),nf(60),nj(60),np(60),nx(60) - double precision factor,fnorm1,fnorm2,one,ten,tol - double precision fnm(60),fvec(65),wa(2865),x(40) - double precision dpmpar,enorm - external fcn - common /refnum/ nprob,nfev,njev -c -c logical input unit is assumed to be number 5. -c logical output unit is assumed to be number 6. -c - data nread,nwrite /5,6/ -c - data one,ten /1.0d0,1.0d1/ - tol = dsqrt(dpmpar(1)) - lwa = 2865 - ic = 0 - 10 continue - read (nread,50) nprob,n,m,ntries - if (nprob .le. 0) go to 30 - factor = one - do 20 k = 1, ntries - ic = ic + 1 - call initpt(n,x,nprob,factor) - call ssqfcn(m,n,x,fvec,nprob) - fnorm1 = enorm(m,fvec) - write (nwrite,60) nprob,n,m - nfev = 0 - njev = 0 - call lmdif1(fcn,m,n,x,fvec,tol,info,iwa,wa,lwa) - call ssqfcn(m,n,x,fvec,nprob) - fnorm2 = enorm(m,fvec) - np(ic) = nprob - na(ic) = n - ma(ic) = m - nf(ic) = nfev - njev = njev/n - nj(ic) = njev - nx(ic) = info - fnm(ic) = fnorm2 - write (nwrite,70) - * fnorm1,fnorm2,nfev,njev,info,(x(i), i = 1, n) - factor = ten*factor - 20 continue - go to 10 - 30 continue - write (nwrite,80) ic - write (nwrite,90) - do 40 i = 1, ic - write (nwrite,100) np(i),na(i),ma(i),nf(i),nj(i),nx(i),fnm(i) - 40 continue - stop - 50 format (4i5) - 60 format ( //// 5x, 8h problem, i5, 5x, 11h dimensions, 2i5, 5x // - * ) - 70 format (5x, 33h initial l2 norm of the residuals, d15.7 // 5x, - * 33h final l2 norm of the residuals , d15.7 // 5x, - * 33h number of function evaluations , i10 // 5x, - * 33h number of jacobian evaluations , i10 // 5x, - * 15h exit parameter, 18x, i10 // 5x, - * 27h final approximate solution // (5x, 5d15.7)) - 80 format (12h1summary of , i3, 16h calls to lmdif1 /) - 90 format (49h nprob n m nfev njev info final l2 norm /) - 100 format (3i5, 3i6, 1x, d15.7) -c -c last card of driver. -c - end - subroutine fcn(m,n,x,fvec,iflag) - integer m,n,iflag - double precision x(n),fvec(m) -c ********** -c -c the calling sequence of fcn should be identical to the -c calling sequence of the function subroutine in the nonlinear -c least-squares solver. fcn should only call the testing -c function subroutine ssqfcn with the appropriate value of -c problem number (nprob). -c -c subprograms called -c -c minpack-supplied ... ssqfcn -c -c argonne national laboratory. minpack project. march 1980. -c burton s. garbow, kenneth e. hillstrom, jorge j. more -c -c ********** - integer nprob,nfev,njev - common /refnum/ nprob,nfev,njev - call ssqfcn(m,n,x,fvec,nprob) - if (iflag .eq. 1) nfev = nfev + 1 - if (iflag .eq. 2) njev = njev + 1 - return -c -c last card of interface subroutine fcn. -c - end diff --git a/ex/lmsdrv.f b/ex/lmsdrv.f deleted file mode 100644 index 8681beb..0000000 --- a/ex/lmsdrv.f +++ /dev/null @@ -1,135 +0,0 @@ -c ********** -c -c this program tests codes for the least-squares solution of -c m nonlinear equations in n variables. it consists of a driver -c and an interface subroutine fcn. the driver reads in data, -c calls the nonlinear least-squares solver, and finally prints -c out information on the performance of the solver. this is -c only a sample driver, many other drivers are possible. the -c interface subroutine fcn is necessary to take into account the -c forms of calling sequences used by the function and jacobian -c subroutines in the various nonlinear least-squares solvers. -c -c subprograms called -c -c user-supplied ...... fcn -c -c minpack-supplied ... dpmpar,enorm,initpt,lmstr1,ssqfcn -c -c fortran-supplied ... dsqrt -c -c argonne national laboratory. minpack project. march 1980. -c burton s. garbow, kenneth e. hillstrom, jorge j. more -c -c ********** - integer i,ic,info,k,ldfjac,lwa,m,n,nfev,njev,nprob,nread,ntries, - * nwrite - integer iwa(40),ma(60),na(60),nf(60),nj(60),np(60),nx(60) - double precision factor,fnorm1,fnorm2,one,ten,tol - double precision fjac(40,40),fnm(60),fvec(65),wa(265),x(40) - double precision dpmpar,enorm - external fcn - common /refnum/ nprob,nfev,njev -c -c logical input unit is assumed to be number 5. -c logical output unit is assumed to be number 6. -c - data nread,nwrite /5,6/ -c - data one,ten /1.0d0,1.0d1/ - tol = dsqrt(dpmpar(1)) - ldfjac = 40 - lwa = 265 - ic = 0 - 10 continue - read (nread,50) nprob,n,m,ntries - if (nprob .le. 0) go to 30 - factor = one - do 20 k = 1, ntries - ic = ic + 1 - call initpt(n,x,nprob,factor) - call ssqfcn(m,n,x,fvec,nprob) - fnorm1 = enorm(m,fvec) - write (nwrite,60) nprob,n,m - nfev = 0 - njev = 0 - call lmstr1(fcn,m,n,x,fvec,fjac,ldfjac,tol,info,iwa,wa, - * lwa) - call ssqfcn(m,n,x,fvec,nprob) - fnorm2 = enorm(m,fvec) - np(ic) = nprob - na(ic) = n - ma(ic) = m - nf(ic) = nfev - nj(ic) = njev - nx(ic) = info - fnm(ic) = fnorm2 - write (nwrite,70) - * fnorm1,fnorm2,nfev,njev,info,(x(i), i = 1, n) - factor = ten*factor - 20 continue - go to 10 - 30 continue - write (nwrite,80) ic - write (nwrite,90) - do 40 i = 1, ic - write (nwrite,100) np(i),na(i),ma(i),nf(i),nj(i),nx(i),fnm(i) - 40 continue - stop - 50 format (4i5) - 60 format ( //// 5x, 8h problem, i5, 5x, 11h dimensions, 2i5, 5x // - * ) - 70 format (5x, 33h initial l2 norm of the residuals, d15.7 // 5x, - * 33h final l2 norm of the residuals , d15.7 // 5x, - * 33h number of function evaluations , i10 // 5x, - * 33h number of jacobian evaluations , i10 // 5x, - * 15h exit parameter, 18x, i10 // 5x, - * 27h final approximate solution // (5x, 5d15.7)) - 80 format (12h1summary of , i3, 16h calls to lmstr1 /) - 90 format (49h nprob n m nfev njev info final l2 norm /) - 100 format (3i5, 3i6, 1x, d15.7) -c -c last card of driver. -c - end - subroutine fcn(m,n,x,fvec,fjrow,iflag) - integer m,n,iflag - double precision x(n),fvec(m),fjrow(n) -c ********** -c -c the calling sequence of fcn should be identical to the -c calling sequence of the function subroutine in the nonlinear -c least squares solver. if iflag = 1, fcn should only call the -c testing function subroutine ssqfcn. if iflag = i, i .ge. 2, -c fcn should only call subroutine ssqjac to calculate the -c (i-1)-st row of the jacobian. (the ssqjac subroutine provided -c here for testing purposes calculates the entire jacobian -c matrix and is therefore called only when iflag = 2.) each -c call to ssqfcn or ssqjac should specify the appropriate -c value of problem number (nprob). -c -c subprograms called -c -c minpack-supplied ... ssqfcn,ssqjac -c -c argonne national laboratory. minpack project. march 1980. -c burton s. garbow, kenneth e. hillstrom, jorge j. more -c -c ********** - integer nprob,nfev,njev,j - double precision temp(65,40) - common /refnum/ nprob,nfev,njev - if (iflag .eq. 1) call ssqfcn(m,n,x,fvec,nprob) - if (iflag .eq. 2) call ssqjac(m,n,x,temp,65,nprob) - if (iflag .eq. 1) nfev = nfev + 1 - if (iflag .eq. 2) njev = njev + 1 - if (iflag .eq. 1) go to 120 - do 110 j = 1, n - fjrow(j) = temp(iflag-1,j) - 110 continue - 120 continue - return -c -c last card of interface subroutine fcn. -c - end diff --git a/ex/ucodrv.f b/ex/ucodrv.f deleted file mode 100644 index 3df3c44..0000000 --- a/ex/ucodrv.f +++ /dev/null @@ -1,122 +0,0 @@ -c ********** -c -c this program tests codes for the unconstrained optimization of -c a nonlinear function of n variables. it consists of a driver -c and an interface subroutine fcn. the driver reads in data, -c calls the unconstrained optimizer, and finally prints out -c information on the performance of the optimizer. this is -c only a sample driver, many other drivers are possible. the -c interface subroutine fcn is necessary to take into account the -c forms of calling sequences used by the function subroutines -c in the various unconstrained optimizers. -c -c subprograms called -c -c user-supplied ...... fcn -c -c minpack-supplied ... dpmpar,drvcr1,enorm,grdfcn,initpt,objfcn -c -c fortran-supplied ... dsqrt -c -c argonne national laboratory. minpack project. march 1980. -c burton s. garbow, kenneth e. hillstrom, jorge j. more -c -c ********** - integer i,ic,info,k,lwa,n,nfev,nprob,nread,ntries,nwrite - integer na(120),nf(120),np(120),nx(120) - double precision factor,f1,f2,gnorm1,gnorm2,one,ten,tol - double precision fval(120),gvec(100),gnm(120),wa(6130),x(100) - double precision dpmpar,enorm - external fcn - common /refnum/ nprob,nfev -c -c logical input unit is assumed to be number 5. -c logical output unit is assumed to be number 6. -c - data nread,nwrite /5,6/ -c - data one,ten /1.0d0,1.0d1/ - tol = dsqrt(dpmpar(1)) - lwa = 6130 - ic = 0 - 10 continue - read (nread,50) nprob,n,ntries - if (nprob .le. 0) go to 30 - factor = one - do 20 k = 1, ntries - ic = ic + 1 - call initpt(n,x,nprob,factor) - call objfcn(n,x,f1,nprob) - call grdfcn(n,x,gvec,nprob) - gnorm1 = enorm(n,gvec) - write (nwrite,60) nprob,n - nfev = 0 - call drvcr1(fcn,n,x,f2,gvec,tol,info,wa,lwa) - call objfcn(n,x,f2,nprob) - call grdfcn(n,x,gvec,nprob) - gnorm2 = enorm(n,gvec) - np(ic) = nprob - na(ic) = n - nf(ic) = nfev - nx(ic) = info - fval(ic) = f2 - gnm(ic) = gnorm2 - write (nwrite,70) - * f1,f2,gnorm1,gnorm2,nfev,info,(x(i), i = 1, n) - factor = ten*factor - 20 continue - go to 10 - 30 continue - write (nwrite,80) ic - write (nwrite,90) - do 40 i = 1, ic - write (nwrite,100) np(i),na(i),nf(i),nx(i),fval(i),gnm(i) - 40 continue - stop - 50 format (3i5) - 60 format ( //// 5x, 8h problem, i5, 5x, 10h dimension, i5, 5x //) - 70 format (5x, 23h initial function value, d15.7 // 5x, - * 23h final function value , d15.7 // 5x, - * 23h initial gradient norm , d15.7 // 5x, - * 23h final gradient norm , d15.7 // 5x, - * 33h number of function evaluations , i10 // 5x, - * 15h exit parameter, 18x, i10 // 5x, - * 27h final approximate solution // (5x, 5d15.7)) - 80 format (12h1summary of , i3, 16h calls to drvcr1 /) - 90 format (25h nprob n nfev info , - * 42h final function value final gradient norm /) - 100 format (i4, i6, i7, i6, 5x, d15.7, 6x, d15.7) -c -c last card of driver. -c - end - subroutine fcn(n,x,f,gvec,iflag) - integer n,iflag - double precision f - double precision x(n),gvec(n) -c ********** -c -c the calling sequence of fcn should be identical to the -c calling sequence of the function subroutine in the -c unconstrained optimizer. fcn should only call the testing -c function and gradient subroutines objfcn and grdfcn with -c the appropriate value of problem number (nprob). -c -c subprograms called -c -c minpack-supplied ... grdfcn,objfcn -c -c argonne national laboratory. minpack project. march 1980. -c burton s. garbow, kenneth e. hillstrom, jorge j. more -c -c ********** - integer nprob,nfev - common /refnum/ nprob,nfev - call objfcn(n,x,f,nprob) - call grdfcn(n,x,gvec,nprob) - nfev = nfev + 1 - return -c -c last card of interface subroutine fcn. -c - end diff --git a/examples/CMakeLists.txt b/examples/CMakeLists.txt deleted file mode 100644 index ede7a42..0000000 --- a/examples/CMakeLists.txt +++ /dev/null @@ -1,16 +0,0 @@ -include_directories(${PROJECT_BINARY_DIR}/src) - -add_executable(example_hybrd example_hybrd.f90) -target_link_libraries(example_hybrd minpack) - -add_executable(example_hybrd1 example_hybrd1.f90) -target_link_libraries(example_hybrd1 minpack) - -add_executable(example_lmder1 example_lmder1.f90) -target_link_libraries(example_lmder1 minpack) - -add_executable(example_lmdif1 example_lmdif1.f90) -target_link_libraries(example_lmdif1 minpack) - -add_executable(example_primes example_primes.f90) -target_link_libraries(example_primes minpack) diff --git a/examples/example_hybrd.f90 b/examples/example_hybrd.f90 index 80f97cf..bca92d5 100644 --- a/examples/example_hybrd.f90 +++ b/examples/example_hybrd.f90 @@ -5,7 +5,7 @@ !> -x(8) + (3-2*x(9))*x(9) = -1 program example_hybrd - use minpack, only: hybrd, enorm, dpmpar + use minpack_module, only: hybrd, enorm, dpmpar implicit none integer j, n, maxfev, ml, mu, mode, nprint, info, nfev, ldfjac, lr, nwrite double precision xtol, epsfcn, factor, fnorm diff --git a/examples/example_hybrd1.f90 b/examples/example_hybrd1.f90 index 29c2fc8..59f639a 100644 --- a/examples/example_hybrd1.f90 +++ b/examples/example_hybrd1.f90 @@ -6,7 +6,7 @@ !> -x(8) + (3-2*x(9))*x(9) = -1 program example_hybrd1 - use minpack, only: hybrd1, dpmpar, enorm + use minpack_module, only: hybrd1, dpmpar, enorm implicit none integer j, n, info, lwa, nwrite double precision tol, fnorm diff --git a/examples/example_lmder1.f90 b/examples/example_lmder1.f90 index 984207e..27ea4fe 100644 --- a/examples/example_lmder1.f90 +++ b/examples/example_lmder1.f90 @@ -43,7 +43,7 @@ subroutine fcn(m, n, x, fvec, fjac, ldfjac, iflag) program example_lmder1 -use minpack, only: enorm, lmder1, chkder +use minpack_module, only: enorm, lmder1, chkder use testmod_der1, only: dp, fcn implicit none diff --git a/examples/example_lmdif1.f90 b/examples/example_lmdif1.f90 index 7da6b75..1b73ae1 100644 --- a/examples/example_lmdif1.f90 +++ b/examples/example_lmdif1.f90 @@ -32,7 +32,7 @@ subroutine fcn(m, n, x, fvec, iflag) program example_lmdif1 -use minpack, only: enorm, lmdif1 +use minpack_module, only: enorm, lmdif1 use testmod_dif1, only: dp, fcn implicit none diff --git a/examples/example_primes.f90 b/examples/example_primes.f90 index d125537..8406b16 100644 --- a/examples/example_primes.f90 +++ b/examples/example_primes.f90 @@ -12,7 +12,7 @@ module find_fit_module ! This module contains a general function find_fit() for a nonlinear least ! squares fitting. The function can fit any nonlinear expression to any data. -use minpack, only: lmdif1 +use minpack_module, only: lmdif1 use types, only: dp implicit none private diff --git a/fpm.toml b/fpm.toml deleted file mode 100644 index 0c3d917..0000000 --- a/fpm.toml +++ /dev/null @@ -1,43 +0,0 @@ -name = "minpack" -description = "Minpack includes software for solving nonlinear equations and nonlinear least squares problems." -homepage = "http://www.netlib.org/minpack/" -version = "1.0.0" -license = "http://www.netlib.org/minpack/disclaimer" -author = "Jorge Moré, Burt Garbow, and Ken Hillstrom" -maintainer = "@fortran-lang" -copyright = "Minpack Copyright Notice (1999) University of Chicago. All rights reserved" -categories = ["numerical"] -keywords = ["least squares", "linear equations", "nonlinear equations"] - -[build] -auto-executables = false -auto-tests = false -auto-examples = false - -[install] -library = false - -[[ example ]] -name = "example_hybrd" -source-dir = "examples" -main = "example_hybrd.f90" - -[[ example ]] -name = "example_hybrd1" -source-dir = "examples" -main = "example_hybrd1.f90" - -[[ example ]] -name = "example_lmder1" -source-dir = "examples" -main = "example_lmder1.f90" - -[[ example ]] -name = "example_lmdif1" -source-dir = "examples" -main = "example_lmdif1.f90" - -[[ example ]] -name = "example_primes" -source-dir = "examples" -main = "example_primes.f90" diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt deleted file mode 100644 index 51d1676..0000000 --- a/src/CMakeLists.txt +++ /dev/null @@ -1,18 +0,0 @@ -set(SRC - covar.f errjac.f hybipt.f lhesfcn.f lmdipt.f ocpipt.f r1updt.f - vecjac.f chkder.f - dmchar.f fdjac1.f hybrd1.f lmder1.f lmpar.f qform.f rwupdt.f - dogleg.f fdjac2.f hybrd.f lmder.f lmstr1.f qrfac.f ssqfcn.f - dpmpar.f grdfcn.f hybrj1.f lmdif1.f lmstr.f qrsolv.f ssqjac.f - enorm.f hesfcn.f hybrj.f lmdif.f objfcn.f r1mpyq.f vecfcn.f - - minpack.f90 -) - -add_definitions(-std=legacy -Wno-implicit-interface) -add_library(minpack ${SRC}) -install(TARGETS minpack - RUNTIME DESTINATION bin - ARCHIVE DESTINATION lib - LIBRARY DESTINATION lib - ) diff --git a/src/chkder.f b/src/chkder.f deleted file mode 100644 index 29578fc..0000000 --- a/src/chkder.f +++ /dev/null @@ -1,140 +0,0 @@ - subroutine chkder(m,n,x,fvec,fjac,ldfjac,xp,fvecp,mode,err) - integer m,n,ldfjac,mode - double precision x(n),fvec(m),fjac(ldfjac,n),xp(n),fvecp(m), - * err(m) -c ********** -c -c subroutine chkder -c -c this subroutine checks the gradients of m nonlinear functions -c in n variables, evaluated at a point x, for consistency with -c the functions themselves. the user must call chkder twice, -c first with mode = 1 and then with mode = 2. -c -c mode = 1. on input, x must contain the point of evaluation. -c on output, xp is set to a neighboring point. -c -c mode = 2. on input, fvec must contain the functions and the -c rows of fjac must contain the gradients -c of the respective functions each evaluated -c at x, and fvecp must contain the functions -c evaluated at xp. -c on output, err contains measures of correctness of -c the respective gradients. -c -c the subroutine does not perform reliably if cancellation or -c rounding errors cause a severe loss of significance in the -c evaluation of a function. therefore, none of the components -c of x should be unusually small (in particular, zero) or any -c other value which may cause loss of significance. -c -c the subroutine statement is -c -c subroutine chkder(m,n,x,fvec,fjac,ldfjac,xp,fvecp,mode,err) -c -c where -c -c m is a positive integer input variable set to the number -c of functions. -c -c n is a positive integer input variable set to the number -c of variables. -c -c x is an input array of length n. -c -c fvec is an array of length m. on input when mode = 2, -c fvec must contain the functions evaluated at x. -c -c fjac is an m by n array. on input when mode = 2, -c the rows of fjac must contain the gradients of -c the respective functions evaluated at x. -c -c ldfjac is a positive integer input parameter not less than m -c which specifies the leading dimension of the array fjac. -c -c xp is an array of length n. on output when mode = 1, -c xp is set to a neighboring point of x. -c -c fvecp is an array of length m. on input when mode = 2, -c fvecp must contain the functions evaluated at xp. -c -c mode is an integer input variable set to 1 on the first call -c and 2 on the second. other values of mode are equivalent -c to mode = 1. -c -c err is an array of length m. on output when mode = 2, -c err contains measures of correctness of the respective -c gradients. if there is no severe loss of significance, -c then if err(i) is 1.0 the i-th gradient is correct, -c while if err(i) is 0.0 the i-th gradient is incorrect. -c for values of err between 0.0 and 1.0, the categorization -c is less certain. in general, a value of err(i) greater -c than 0.5 indicates that the i-th gradient is probably -c correct, while a value of err(i) less than 0.5 indicates -c that the i-th gradient is probably incorrect. -c -c subprograms called -c -c minpack supplied ... dpmpar -c -c fortran supplied ... dabs,dlog10,dsqrt -c -c argonne national laboratory. minpack project. march 1980. -c burton s. garbow, kenneth e. hillstrom, jorge j. more -c -c ********** - integer i,j - double precision eps,epsf,epslog,epsmch,factor,one,temp,zero - double precision dpmpar - data factor,one,zero /1.0d2,1.0d0,0.0d0/ -c -c epsmch is the machine precision. -c - epsmch = dpmpar(1) -c - eps = dsqrt(epsmch) -c - if (mode .eq. 2) go to 20 -c -c mode = 1. -c - do 10 j = 1, n - temp = eps*dabs(x(j)) - if (temp .eq. zero) temp = eps - xp(j) = x(j) + temp - 10 continue - go to 70 - 20 continue -c -c mode = 2. -c - epsf = factor*epsmch - epslog = dlog10(eps) - do 30 i = 1, m - err(i) = zero - 30 continue - do 50 j = 1, n - temp = dabs(x(j)) - if (temp .eq. zero) temp = one - do 40 i = 1, m - err(i) = err(i) + temp*fjac(i,j) - 40 continue - 50 continue - do 60 i = 1, m - temp = one - if (fvec(i) .ne. zero .and. fvecp(i) .ne. zero - * .and. dabs(fvecp(i)-fvec(i)) .ge. epsf*dabs(fvec(i))) - * temp = eps*dabs((fvecp(i)-fvec(i))/eps-err(i)) - * /(dabs(fvec(i)) + dabs(fvecp(i))) - err(i) = one - if (temp .gt. epsmch .and. temp .lt. eps) - * err(i) = (dlog10(temp) - epslog)/epslog - if (temp .ge. eps) err(i) = zero - 60 continue - 70 continue -c - return -c -c last card of subroutine chkder. -c - end diff --git a/src/covar.f b/src/covar.f deleted file mode 100644 index c466758..0000000 --- a/src/covar.f +++ /dev/null @@ -1,145 +0,0 @@ - subroutine covar(n,r,ldr,ipvt,tol,wa) - integer n,ldr - integer ipvt(n) - double precision tol - double precision r(ldr,n),wa(n) -c ********** -c -c subroutine covar -c -c given an m by n matrix a, the problem is to determine -c the covariance matrix corresponding to a, defined as -c -c t -c inverse(a *a) . -c -c this subroutine completes the solution of the problem -c if it is provided with the necessary information from the -c qr factorization, with column pivoting, of a. that is, if -c a*p = q*r, where p is a permutation matrix, q has orthogonal -c columns, and r is an upper triangular matrix with diagonal -c elements of nonincreasing magnitude, then covar expects -c the full upper triangle of r and the permutation matrix p. -c the covariance matrix is then computed as -c -c t t -c p*inverse(r *r)*p . -c -c if a is nearly rank deficient, it may be desirable to compute -c the covariance matrix corresponding to the linearly independent -c columns of a. to define the numerical rank of a, covar uses -c the tolerance tol. if l is the largest integer such that -c -c abs(r(l,l)) .gt. tol*abs(r(1,1)) , -c -c then covar computes the covariance matrix corresponding to -c the first l columns of r. for k greater than l, column -c and row ipvt(k) of the covariance matrix are set to zero. -c -c the subroutine statement is -c -c subroutine covar(n,r,ldr,ipvt,tol,wa) -c -c where -c -c n is a positive integer input variable set to the order of r. -c -c r is an n by n array. on input the full upper triangle must -c contain the full upper triangle of the matrix r. on output -c r contains the square symmetric covariance matrix. -c -c ldr is a positive integer input variable not less than n -c which specifies the leading dimension of the array r. -c -c ipvt is an integer input array of length n which defines the -c permutation matrix p such that a*p = q*r. column j of p -c is column ipvt(j) of the identity matrix. -c -c tol is a nonnegative input variable used to define the -c numerical rank of a in the manner described above. -c -c wa is a work array of length n. -c -c subprograms called -c -c fortran-supplied ... dabs -c -c argonne national laboratory. minpack project. august 1980. -c burton s. garbow, kenneth e. hillstrom, jorge j. more -c -c ********** - integer i,ii,j,jj,k,km1,l - logical sing - double precision one,temp,tolr,zero - data one,zero /1.0d0,0.0d0/ -c -c form the inverse of r in the full upper triangle of r. -c - tolr = tol*dabs(r(1,1)) - l = 0 - do 40 k = 1, n - if (dabs(r(k,k)) .le. tolr) go to 50 - r(k,k) = one/r(k,k) - km1 = k - 1 - if (km1 .lt. 1) go to 30 - do 20 j = 1, km1 - temp = r(k,k)*r(j,k) - r(j,k) = zero - do 10 i = 1, j - r(i,k) = r(i,k) - temp*r(i,j) - 10 continue - 20 continue - 30 continue - l = k - 40 continue - 50 continue -c -c form the full upper triangle of the inverse of (r transpose)*r -c in the full upper triangle of r. -c - if (l .lt. 1) go to 110 - do 100 k = 1, l - km1 = k - 1 - if (km1 .lt. 1) go to 80 - do 70 j = 1, km1 - temp = r(j,k) - do 60 i = 1, j - r(i,j) = r(i,j) + temp*r(i,k) - 60 continue - 70 continue - 80 continue - temp = r(k,k) - do 90 i = 1, k - r(i,k) = temp*r(i,k) - 90 continue - 100 continue - 110 continue -c -c form the full lower triangle of the covariance matrix -c in the strict lower triangle of r and in wa. -c - do 130 j = 1, n - jj = ipvt(j) - sing = j .gt. l - do 120 i = 1, j - if (sing) r(i,j) = zero - ii = ipvt(i) - if (ii .gt. jj) r(ii,jj) = r(i,j) - if (ii .lt. jj) r(jj,ii) = r(i,j) - 120 continue - wa(jj) = r(j,j) - 130 continue -c -c symmetrize the covariance matrix in r. -c - do 150 j = 1, n - do 140 i = 1, j - r(i,j) = r(j,i) - 140 continue - r(j,j) = wa(j) - 150 continue - return -c -c last card of subroutine covar. -c - end diff --git a/src/dmchar.f b/src/dmchar.f deleted file mode 100644 index e54d8be..0000000 --- a/src/dmchar.f +++ /dev/null @@ -1,212 +0,0 @@ - subroutine dmchar(ibeta,it,irnd,ngrd,machep,negep,iexp,minexp, - 1 maxexp,eps,epsneg,xmin,xmax) -c - integer i,ibeta,iexp,irnd,it,iz,j,k,machep,maxexp,minexp, - 1 mx,negep,ngrd - double precision a,b,beta,betain,betam1,eps,epsneg,one,xmax, - 1 xmin,y,z,zero -c -c this subroutine is intended to determine the characteristics -c of the floating-point arithmetic system that are specified -c below. the first three are determined according to an -c algorithm due to m. malcolm, cacm 15 (1972), pp. 949-951, -c incorporating some, but not all, of the improvements -c suggested by m. gentleman and s. marovich, cacm 17 (1974), -c pp. 276-277. -c -c -c ibeta - the radix of the floating-point representation -c it - the number of base ibeta digits in the floating-point -c significand -c irnd - 0 if floating-point addition chops, -c 1 if floating-point addition rounds -c ngrd - the number of guard digits for multiplication. it is -c 0 if irnd=1, or if irnd=0 and only it base ibeta -c digits participate in the post normalization shift -c of the floating-point significand in multiplication -c 1 if irnd=0 and more than it base ibeta digits -c participate in the post normalization shift of the -c floating-point significand in multiplication -c machep - the largest negative integer such that -c 1.0+float(ibeta)**machep .ne. 1.0, except that -c machep is bounded below by -(it+3) -c negeps - the largest negative integer such that -c 1.0-float(ibeta)**negeps .ne. 1.0, except that -c negeps is bounded below by -(it+3) -c iexp - the number of bits (decimal places if ibeta = 10) -c reserved for the representation of the exponent -c (including the bias or sign) of a floating-point -c number -c minexp - the largest in magnitude negative integer such that -c float(ibeta)**minexp is a positive floating-point -c number -c maxexp - the largest positive integer exponent for a finite -c floating-point number -c eps - the smallest positive floating-point number such -c that 1.0+eps .ne. 1.0. in particular, if either -c ibeta = 2 or irnd = 0, eps = float(ibeta)**machep. -c otherwise, eps = (float(ibeta)**machep)/2 -c epsneg - a small positive floating-point number such that -c 1.0-epsneg .ne. 1.0. in particular, if ibeta = 2 -c or irnd = 0, epsneg = float(ibeta)**negeps. -c otherwise, epsneg = (ibeta**negeps)/2. because -c negeps is bounded below by -(it+3), epsneg may not -c be the smallest number which can alter 1.0 by -c subtraction. -c xmin - the smallest non-vanishing floating-point power of the -c radix. in particular, xmin = float(ibeta)**minexp -c xmax - the largest finite floating-point number. in -c particular xmax = (1.0-epsneg)*float(ibeta)**maxexp -c note - on some machines xmax will be only the -c second, or perhaps third, largest number, being -c too small by 1 or 2 units in the last digit of -c the significand. -c -c latest revision - october 22, 1979 -c -c author - w. j. cody -c argonne national laboratory -c -c----------------------------------------------------------------- - one = dble(float(1)) - zero = 0.0d0 -c----------------------------------------------------------------- -c determine ibeta,beta ala malcolm -c----------------------------------------------------------------- - a = one - 10 a = a + a - if (((a+one)-a)-one .eq. zero) go to 10 - b = one - 20 b = b + b - if ((a+b)-a .eq. zero) go to 20 - ibeta = int(sngl((a + b) - a)) - beta = dble(float(ibeta)) -c----------------------------------------------------------------- -c determine it, irnd -c----------------------------------------------------------------- - it = 0 - b = one - 100 it = it + 1 - b = b * beta - if (((b+one)-b)-one .eq. zero) go to 100 - irnd = 0 - betam1 = beta - one - if ((a+betam1)-a .ne. zero) irnd = 1 -c----------------------------------------------------------------- -c determine negep, epsneg -c----------------------------------------------------------------- - negep = it + 3 - betain = one / beta - a = one -c - do 200 i = 1, negep - a = a * betain - 200 continue -c - b = a - 210 if ((one-a)-one .ne. zero) go to 220 - a = a * beta - negep = negep - 1 - go to 210 - 220 negep = -negep - epsneg = a - if ((ibeta .eq. 2) .or. (irnd .eq. 0)) go to 300 - a = (a*(one+a)) / (one+one) - if ((one-a)-one .ne. zero) epsneg = a -c----------------------------------------------------------------- -c determine machep, eps -c----------------------------------------------------------------- - 300 machep = -it - 3 - a = b - 310 if((one+a)-one .ne. zero) go to 320 - a = a * beta - machep = machep + 1 - go to 310 - 320 eps = a - if ((ibeta .eq. 2) .or. (irnd .eq. 0)) go to 350 - a = (a*(one+a)) / (one+one) - if ((one+a)-one .ne. zero) eps = a -c----------------------------------------------------------------- -c determine ngrd -c----------------------------------------------------------------- - 350 ngrd = 0 - if ((irnd .eq. 0) .and. ((one+eps)*one-one) .ne. zero) ngrd = 1 -c----------------------------------------------------------------- -c determine iexp, minexp, xmin -c -c loop to determine largest i and k = 2**i such that -c (1/beta) ** (2**(i)) -c does not underflow -c exit from loop is signaled by an underflow. -c----------------------------------------------------------------- - i = 0 - k = 1 - z = betain - 400 y = z - z = y * y -c----------------------------------------------------------------- -c check for underflow here -c----------------------------------------------------------------- - a = z * one - if ((a+a .eq. zero) .or. (dabs(z) .ge. y)) go to 410 - i = i + 1 - k = k + k - go to 400 - 410 if (ibeta .eq. 10) go to 420 - iexp = i + 1 - mx = k + k - go to 450 -c----------------------------------------------------------------- -c for decimal machines only -c----------------------------------------------------------------- - 420 iexp = 2 - iz = ibeta - 430 if (k .lt. iz) go to 440 - iz = iz * ibeta - iexp = iexp + 1 - go to 430 - 440 mx = iz + iz - 1 -c----------------------------------------------------------------- -c loop to determine minexp, xmin -c exit from loop is signaled by an underflow. -c----------------------------------------------------------------- - 450 xmin = y - y = y * betain -c----------------------------------------------------------------- -c check for underflow here -c----------------------------------------------------------------- - a = y * one - if (((a+a) .eq. zero) .or. (dabs(y) .ge. xmin)) go to 460 - k = k + 1 - go to 450 - 460 minexp = -k -c----------------------------------------------------------------- -c determine maxexp, xmax -c----------------------------------------------------------------- - if ((mx .gt. k+k-3) .or. (ibeta .eq. 10)) go to 500 - mx = mx + mx - iexp = iexp + 1 - 500 maxexp = mx + minexp -c----------------------------------------------------------------- -c adjust for machines with implicit leading -c bit in binary significand and machines with -c radix point at extreme right of significand -c----------------------------------------------------------------- - i = maxexp + minexp - if ((ibeta .eq. 2) .and. (i .eq. 0)) maxexp = maxexp - 1 - if (i .gt. 20) maxexp = maxexp - 1 - if (a .ne. y) maxexp = maxexp - 2 - xmax = one - epsneg - if (xmax*one .ne. xmax) xmax = one - beta * epsneg - xmax = xmax / (beta * beta * beta * xmin) - i = maxexp + minexp + 3 - if (i .le. 0) go to 520 -c - do 510 j = 1, i - if (ibeta .eq. 2) xmax = xmax + xmax - if (ibeta .ne. 2) xmax = xmax * beta - 510 continue -c - 520 return -c ---------- last card of dmchar ---------- - end diff --git a/src/dogleg.f b/src/dogleg.f deleted file mode 100644 index b812f19..0000000 --- a/src/dogleg.f +++ /dev/null @@ -1,177 +0,0 @@ - subroutine dogleg(n,r,lr,diag,qtb,delta,x,wa1,wa2) - integer n,lr - double precision delta - double precision r(lr),diag(n),qtb(n),x(n),wa1(n),wa2(n) -c ********** -c -c subroutine dogleg -c -c given an m by n matrix a, an n by n nonsingular diagonal -c matrix d, an m-vector b, and a positive number delta, the -c problem is to determine the convex combination x of the -c gauss-newton and scaled gradient directions that minimizes -c (a*x - b) in the least squares sense, subject to the -c restriction that the euclidean norm of d*x be at most delta. -c -c this subroutine completes the solution of the problem -c if it is provided with the necessary information from the -c qr factorization of a. that is, if a = q*r, where q has -c orthogonal columns and r is an upper triangular matrix, -c then dogleg expects the full upper triangle of r and -c the first n components of (q transpose)*b. -c -c the subroutine statement is -c -c subroutine dogleg(n,r,lr,diag,qtb,delta,x,wa1,wa2) -c -c where -c -c n is a positive integer input variable set to the order of r. -c -c r is an input array of length lr which must contain the upper -c triangular matrix r stored by rows. -c -c lr is a positive integer input variable not less than -c (n*(n+1))/2. -c -c diag is an input array of length n which must contain the -c diagonal elements of the matrix d. -c -c qtb is an input array of length n which must contain the first -c n elements of the vector (q transpose)*b. -c -c delta is a positive input variable which specifies an upper -c bound on the euclidean norm of d*x. -c -c x is an output array of length n which contains the desired -c convex combination of the gauss-newton direction and the -c scaled gradient direction. -c -c wa1 and wa2 are work arrays of length n. -c -c subprograms called -c -c minpack-supplied ... dpmpar,enorm -c -c fortran-supplied ... dabs,dmax1,dmin1,dsqrt -c -c argonne national laboratory. minpack project. march 1980. -c burton s. garbow, kenneth e. hillstrom, jorge j. more -c -c ********** - integer i,j,jj,jp1,k,l - double precision alpha,bnorm,epsmch,gnorm,one,qnorm,sgnorm,sum, - * temp,zero - double precision dpmpar,enorm - data one,zero /1.0d0,0.0d0/ -c -c epsmch is the machine precision. -c - epsmch = dpmpar(1) -c -c first, calculate the gauss-newton direction. -c - jj = (n*(n + 1))/2 + 1 - do 50 k = 1, n - j = n - k + 1 - jp1 = j + 1 - jj = jj - k - l = jj + 1 - sum = zero - if (n .lt. jp1) go to 20 - do 10 i = jp1, n - sum = sum + r(l)*x(i) - l = l + 1 - 10 continue - 20 continue - temp = r(jj) - if (temp .ne. zero) go to 40 - l = j - do 30 i = 1, j - temp = dmax1(temp,dabs(r(l))) - l = l + n - i - 30 continue - temp = epsmch*temp - if (temp .eq. zero) temp = epsmch - 40 continue - x(j) = (qtb(j) - sum)/temp - 50 continue -c -c test whether the gauss-newton direction is acceptable. -c - do 60 j = 1, n - wa1(j) = zero - wa2(j) = diag(j)*x(j) - 60 continue - qnorm = enorm(n,wa2) - if (qnorm .le. delta) go to 140 -c -c the gauss-newton direction is not acceptable. -c next, calculate the scaled gradient direction. -c - l = 1 - do 80 j = 1, n - temp = qtb(j) - do 70 i = j, n - wa1(i) = wa1(i) + r(l)*temp - l = l + 1 - 70 continue - wa1(j) = wa1(j)/diag(j) - 80 continue -c -c calculate the norm of the scaled gradient and test for -c the special case in which the scaled gradient is zero. -c - gnorm = enorm(n,wa1) - sgnorm = zero - alpha = delta/qnorm - if (gnorm .eq. zero) go to 120 -c -c calculate the point along the scaled gradient -c at which the quadratic is minimized. -c - do 90 j = 1, n - wa1(j) = (wa1(j)/gnorm)/diag(j) - 90 continue - l = 1 - do 110 j = 1, n - sum = zero - do 100 i = j, n - sum = sum + r(l)*wa1(i) - l = l + 1 - 100 continue - wa2(j) = sum - 110 continue - temp = enorm(n,wa2) - sgnorm = (gnorm/temp)/temp -c -c test whether the scaled gradient direction is acceptable. -c - alpha = zero - if (sgnorm .ge. delta) go to 120 -c -c the scaled gradient direction is not acceptable. -c finally, calculate the point along the dogleg -c at which the quadratic is minimized. -c - bnorm = enorm(n,qtb) - temp = (bnorm/gnorm)*(bnorm/qnorm)*(sgnorm/delta) - temp = temp - (delta/qnorm)*(sgnorm/delta)**2 - * + dsqrt((temp-(delta/qnorm))**2 - * +(one-(delta/qnorm)**2)*(one-(sgnorm/delta)**2)) - alpha = ((delta/qnorm)*(one - (sgnorm/delta)**2))/temp - 120 continue -c -c form appropriate convex combination of the gauss-newton -c direction and the scaled gradient direction. -c - temp = (one - alpha)*dmin1(sgnorm,delta) - do 130 j = 1, n - x(j) = temp*wa1(j) + alpha*x(j) - 130 continue - 140 continue - return -c -c last card of subroutine dogleg. -c - end diff --git a/src/dpmpar.f b/src/dpmpar.f deleted file mode 100644 index 5432a16..0000000 --- a/src/dpmpar.f +++ /dev/null @@ -1,45 +0,0 @@ - double precision function dpmpar(i) - integer i -c ********** -c -c Function dpmpar -c -c This function provides double precision machine parameters -c when the appropriate set of data statements is activated (by -c removing the c from column 1) and all other data statements are -c rendered inactive. Most of the parameter values were obtained -c from the corresponding Bell Laboratories Port Library function. -c -c The function statement is -c -c double precision function dpmpar(i) -c -c where -c -c i is an integer input variable set to 1, 2, or 3 which -c selects the desired machine parameter. If the machine has -c t base b digits and its smallest and largest exponents are -c emin and emax, respectively, then these parameters are -c -c dpmpar(1) = b**(1 - t), the machine precision, -c -c dpmpar(2) = b**(emin - 1), the smallest magnitude, -c -c dpmpar(3) = b**emax*(1 - b**(-t)), the largest magnitude. -c -c Argonne National Laboratory. MINPACK Project. November 1996. -c Burton S. Garbow, Kenneth E. Hillstrom, Jorge J. More' -c -c ********** - - double precision dmach(3) - dmach(1) = epsilon(1d0) - dmach(2) = tiny(1d0) - dmach(3) = huge(1d0) -c - dpmpar = dmach(i) - return -c -c Last card of function dpmpar. -c - end diff --git a/src/enorm.f b/src/enorm.f deleted file mode 100644 index 2cb5b60..0000000 --- a/src/enorm.f +++ /dev/null @@ -1,108 +0,0 @@ - double precision function enorm(n,x) - integer n - double precision x(n) -c ********** -c -c function enorm -c -c given an n-vector x, this function calculates the -c euclidean norm of x. -c -c the euclidean norm is computed by accumulating the sum of -c squares in three different sums. the sums of squares for the -c small and large components are scaled so that no overflows -c occur. non-destructive underflows are permitted. underflows -c and overflows do not occur in the computation of the unscaled -c sum of squares for the intermediate components. -c the definitions of small, intermediate and large components -c depend on two constants, rdwarf and rgiant. the main -c restrictions on these constants are that rdwarf**2 not -c underflow and rgiant**2 not overflow. the constants -c given here are suitable for every known computer. -c -c the function statement is -c -c double precision function enorm(n,x) -c -c where -c -c n is a positive integer input variable. -c -c x is an input array of length n. -c -c subprograms called -c -c fortran-supplied ... dabs,dsqrt -c -c argonne national laboratory. minpack project. march 1980. -c burton s. garbow, kenneth e. hillstrom, jorge j. more -c -c ********** - integer i - double precision agiant,floatn,one,rdwarf,rgiant,s1,s2,s3,xabs, - * x1max,x3max,zero - data one,zero,rdwarf,rgiant /1.0d0,0.0d0,3.834d-20,1.304d19/ - s1 = zero - s2 = zero - s3 = zero - x1max = zero - x3max = zero - floatn = n - agiant = rgiant/floatn - do 90 i = 1, n - xabs = dabs(x(i)) - if (xabs .gt. rdwarf .and. xabs .lt. agiant) go to 70 - if (xabs .le. rdwarf) go to 30 -c -c sum for large components. -c - if (xabs .le. x1max) go to 10 - s1 = one + s1*(x1max/xabs)**2 - x1max = xabs - go to 20 - 10 continue - s1 = s1 + (xabs/x1max)**2 - 20 continue - go to 60 - 30 continue -c -c sum for small components. -c - if (xabs .le. x3max) go to 40 - s3 = one + s3*(x3max/xabs)**2 - x3max = xabs - go to 50 - 40 continue - if (xabs .ne. zero) s3 = s3 + (xabs/x3max)**2 - 50 continue - 60 continue - go to 80 - 70 continue -c -c sum for intermediate components. -c - s2 = s2 + xabs**2 - 80 continue - 90 continue -c -c calculation of norm. -c - if (s1 .eq. zero) go to 100 - enorm = x1max*dsqrt(s1+(s2/x1max)/x1max) - go to 130 - 100 continue - if (s2 .eq. zero) go to 110 - if (s2 .ge. x3max) - * enorm = dsqrt(s2*(one+(x3max/s2)*(x3max*s3))) - if (s2 .lt. x3max) - * enorm = dsqrt(x3max*((s2/x3max)+(x3max*s3))) - go to 120 - 110 continue - enorm = x3max*dsqrt(s3) - 120 continue - 130 continue - return -c -c last card of function enorm. -c - end diff --git a/src/errjac.f b/src/errjac.f deleted file mode 100644 index 3913f23..0000000 --- a/src/errjac.f +++ /dev/null @@ -1,333 +0,0 @@ - subroutine errjac(n,x,fjac,ldfjac,nprob) - integer n,ldfjac,nprob - double precision x(n),fjac(ldfjac,n) -c ********** -c -c subroutine errjac -c -c this subroutine is derived from vecjac which defines the -c jacobian matrices of fourteen test functions. the problem -c dimensions are as described in the prologue comments of vecfcn. -c various errors are deliberately introduced to provide a test -c for chkder. -c -c the subroutine statement is -c -c subroutine errjac(n,x,fjac,ldfjac,nprob) -c -c where -c -c n is a positive integer variable. -c -c x is an array of length n. -c -c fjac is an n by n array. on output fjac contains the -c jacobian matrix, with various errors deliberately -c introduced, of the nprob function evaluated at x. -c -c ldfjac is a positive integer variable not less than n -c which specifies the leading dimension of the array fjac. -c -c nprob is a positive integer variable which defines the -c number of the problem. nprob must not exceed 14. -c -c subprograms called -c -c fortran-supplied ... datan,dcos,dexp,dmin1,dsin,dsqrt, -c max0,min0 -c -c argonne national laboratory. minpack project. march 1980. -c burton s. garbow, kenneth e. hillstrom, jorge j. more -c -c ********** - integer i,ivar,j,k,k1,k2,ml,mu - double precision c1,c3,c4,c5,c6,c9,eight,fiftn,five,four,h, - * hundrd,one,prod,six,sum,sum1,sum2,temp,temp1, - * temp2,temp3,temp4,ten,three,ti,tj,tk,tpi, - * twenty,two,zero - double precision dfloat - data zero,one,two,three,four,five,six,eight,ten,fiftn,twenty, - * hundrd - * /0.0d0,1.0d0,2.0d0,3.0d0,4.0d0,5.0d0,6.0d0,8.0d0,1.0d1, - * 1.5d1,2.0d1,1.0d2/ - data c1,c3,c4,c5,c6,c9 /1.0d4,2.0d2,2.02d1,1.98d1,1.8d2,2.9d1/ - dfloat(ivar) = ivar -c -c jacobian routine selector. -c - go to (10,20,50,60,90,100,200,230,290,320,350,380,420,450), - * nprob -c -c rosenbrock function with sign reversal affecting element (1,1). -c - 10 continue - fjac(1,1) = one - fjac(1,2) = zero - fjac(2,1) = -twenty*x(1) - fjac(2,2) = ten - go to 490 -c -c powell singular function with sign reversal affecting element -c (3,3). -c - 20 continue - do 40 k = 1, 4 - do 30 j = 1, 4 - fjac(k,j) = zero - 30 continue - 40 continue - fjac(1,1) = one - fjac(1,2) = ten - fjac(2,3) = dsqrt(five) - fjac(2,4) = -fjac(2,3) - fjac(3,2) = two*(x(2) - two*x(3)) - fjac(3,3) = two*fjac(3,2) - fjac(4,1) = two*dsqrt(ten)*(x(1) - x(4)) - fjac(4,4) = -fjac(4,1) - go to 490 -c -c powell badly scaled function with the sign of the jacobian -c reversed. -c - 50 continue - fjac(1,1) = -c1*x(2) - fjac(1,2) = -c1*x(1) - fjac(2,1) = dexp(-x(1)) - fjac(2,2) = dexp(-x(2)) - go to 490 -c -c wood function without error. -c - 60 continue - do 80 k = 1, 4 - do 70 j = 1, 4 - fjac(k,j) = zero - 70 continue - 80 continue - temp1 = x(2) - three*x(1)**2 - temp2 = x(4) - three*x(3)**2 - fjac(1,1) = -c3*temp1 + one - fjac(1,2) = -c3*x(1) - fjac(2,1) = -two*c3*x(1) - fjac(2,2) = c3 + c4 - fjac(2,4) = c5 - fjac(3,3) = -c6*temp2 + one - fjac(3,4) = -c6*x(3) - fjac(4,2) = c5 - fjac(4,3) = -two*c6*x(3) - fjac(4,4) = c6 + c4 - go to 490 -c -c helical valley function with multiplicative error affecting -c elements (2,1) and (2,2). -c - 90 continue - tpi = eight*datan(one) - temp = x(1)**2 + x(2)**2 - temp1 = tpi*temp - temp2 = dsqrt(temp) - fjac(1,1) = hundrd*x(2)/temp1 - fjac(1,2) = -hundrd*x(1)/temp1 - fjac(1,3) = ten - fjac(2,1) = five*x(1)/temp2 - fjac(2,2) = five*x(2)/temp2 - fjac(2,3) = zero - fjac(3,1) = zero - fjac(3,2) = zero - fjac(3,3) = one - go to 490 -c -c watson function with sign reversals affecting the computation of -c temp1. -c - 100 continue - do 120 k = 1, n - do 110 j = k, n - fjac(k,j) = zero - 110 continue - 120 continue - do 170 i = 1, 29 - ti = dfloat(i)/c9 - sum1 = zero - temp = one - do 130 j = 2, n - sum1 = sum1 + dfloat(j-1)*temp*x(j) - temp = ti*temp - 130 continue - sum2 = zero - temp = one - do 140 j = 1, n - sum2 = sum2 + temp*x(j) - temp = ti*temp - 140 continue - temp1 = two*(sum1 + sum2**2 + one) - temp2 = two*sum2 - temp = ti**2 - tk = one - do 160 k = 1, n - tj = tk - do 150 j = k, n - fjac(k,j) = fjac(k,j) - * + tj - * *((dfloat(k-1)/ti - temp2) - * *(dfloat(j-1)/ti - temp2) - temp1) - tj = ti*tj - 150 continue - tk = temp*tk - 160 continue - 170 continue - fjac(1,1) = fjac(1,1) + six*x(1)**2 - two*x(2) + three - fjac(1,2) = fjac(1,2) - two*x(1) - fjac(2,2) = fjac(2,2) + one - do 190 k = 1, n - do 180 j = k, n - fjac(j,k) = fjac(k,j) - 180 continue - 190 continue - go to 490 -c -c chebyquad function with jacobian twice correct size. -c - 200 continue - tk = one/dfloat(n) - do 220 j = 1, n - temp1 = one - temp2 = two*x(j) - one - temp = two*temp2 - temp3 = zero - temp4 = two - do 210 k = 1, n - fjac(k,j) = two*tk*temp4 - ti = four*temp2 + temp*temp4 - temp3 - temp3 = temp4 - temp4 = ti - ti = temp*temp2 - temp1 - temp1 = temp2 - temp2 = ti - 210 continue - 220 continue - go to 490 -c -c brown almost-linear function without error. -c - 230 continue - prod = one - do 250 j = 1, n - prod = x(j)*prod - do 240 k = 1, n - fjac(k,j) = one - 240 continue - fjac(j,j) = two - 250 continue - do 280 j = 1, n - temp = x(j) - if (temp .ne. zero) go to 270 - temp = one - prod = one - do 260 k = 1, n - if (k .ne. j) prod = x(k)*prod - 260 continue - 270 continue - fjac(n,j) = prod/temp - 280 continue - go to 490 -c -c discrete boundary value function with multiplicative error -c affecting the jacobian diagonal. -c - 290 continue - h = one/dfloat(n+1) - do 310 k = 1, n - temp = three*(x(k) + dfloat(k)*h + one)**2 - do 300 j = 1, n - fjac(k,j) = zero - 300 continue - fjac(k,k) = four + temp*h**2 - if (k .ne. 1) fjac(k,k-1) = -one - if (k .ne. n) fjac(k,k+1) = -one - 310 continue - go to 490 -c -c discrete integral equation function with sign error affecting -c the jacobian diagonal. -c - 320 continue - h = one/dfloat(n+1) - do 340 k = 1, n - tk = dfloat(k)*h - do 330 j = 1, n - tj = dfloat(j)*h - temp = three*(x(j) + tj + one)**2 - fjac(k,j) = h*dmin1(tj*(one-tk),tk*(one-tj))*temp/two - 330 continue - fjac(k,k) = fjac(k,k) - one - 340 continue - go to 490 -c -c trigonometric function with sign errors affecting the -c offdiagonal elements of the jacobian. -c - 350 continue - do 370 j = 1, n - temp = dsin(x(j)) - do 360 k = 1, n - fjac(k,j) = -temp - 360 continue - fjac(j,j) = dfloat(j+1)*temp - dcos(x(j)) - 370 continue - go to 490 -c -c variably dimensioned function with operation error affecting -c the upper triangular elements of the jacobian. -c - 380 continue - sum = zero - do 390 j = 1, n - sum = sum + dfloat(j)*(x(j) - one) - 390 continue - temp = one + six*sum**2 - do 410 k = 1, n - do 400 j = k, n - fjac(k,j) = dfloat(k*j)/temp - fjac(j,k) = fjac(k,j) - 400 continue - fjac(k,k) = fjac(k,k) + one - 410 continue - go to 490 -c -c broyden tridiagonal function without error. -c - 420 continue - do 440 k = 1, n - do 430 j = 1, n - fjac(k,j) = zero - 430 continue - fjac(k,k) = three - four*x(k) - if (k .ne. 1) fjac(k,k-1) = -one - if (k .ne. n) fjac(k,k+1) = -two - 440 continue - go to 490 -c -c broyden banded function with sign error affecting the jacobian -c diagonal. -c - 450 continue - ml = 5 - mu = 1 - do 480 k = 1, n - do 460 j = 1, n - fjac(k,j) = zero - 460 continue - k1 = max0(1,k-ml) - k2 = min0(k+mu,n) - do 470 j = k1, k2 - if (j .ne. k) fjac(k,j) = -(one + two*x(j)) - 470 continue - fjac(k,k) = two - fiftn*x(k)**2 - 480 continue - 490 continue - return -c -c last card of subroutine errjac. -c - end diff --git a/src/fdjac1.f b/src/fdjac1.f deleted file mode 100644 index 031ed46..0000000 --- a/src/fdjac1.f +++ /dev/null @@ -1,151 +0,0 @@ - subroutine fdjac1(fcn,n,x,fvec,fjac,ldfjac,iflag,ml,mu,epsfcn, - * wa1,wa2) - integer n,ldfjac,iflag,ml,mu - double precision epsfcn - double precision x(n),fvec(n),fjac(ldfjac,n),wa1(n),wa2(n) -c ********** -c -c subroutine fdjac1 -c -c this subroutine computes a forward-difference approximation -c to the n by n jacobian matrix associated with a specified -c problem of n functions in n variables. if the jacobian has -c a banded form, then function evaluations are saved by only -c approximating the nonzero terms. -c -c the subroutine statement is -c -c subroutine fdjac1(fcn,n,x,fvec,fjac,ldfjac,iflag,ml,mu,epsfcn, -c wa1,wa2) -c -c where -c -c fcn is the name of the user-supplied subroutine which -c calculates the functions. fcn must be declared -c in an external statement in the user calling -c program, and should be written as follows. -c -c subroutine fcn(n,x,fvec,iflag) -c integer n,iflag -c double precision x(n),fvec(n) -c ---------- -c calculate the functions at x and -c return this vector in fvec. -c ---------- -c return -c end -c -c the value of iflag should not be changed by fcn unless -c the user wants to terminate execution of fdjac1. -c in this case set iflag to a negative integer. -c -c n is a positive integer input variable set to the number -c of functions and variables. -c -c x is an input array of length n. -c -c fvec is an input array of length n which must contain the -c functions evaluated at x. -c -c fjac is an output n by n array which contains the -c approximation to the jacobian matrix evaluated at x. -c -c ldfjac is a positive integer input variable not less than n -c which specifies the leading dimension of the array fjac. -c -c iflag is an integer variable which can be used to terminate -c the execution of fdjac1. see description of fcn. -c -c ml is a nonnegative integer input variable which specifies -c the number of subdiagonals within the band of the -c jacobian matrix. if the jacobian is not banded, set -c ml to at least n - 1. -c -c epsfcn is an input variable used in determining a suitable -c step length for the forward-difference approximation. this -c approximation assumes that the relative errors in the -c functions are of the order of epsfcn. if epsfcn is less -c than the machine precision, it is assumed that the relative -c errors in the functions are of the order of the machine -c precision. -c -c mu is a nonnegative integer input variable which specifies -c the number of superdiagonals within the band of the -c jacobian matrix. if the jacobian is not banded, set -c mu to at least n - 1. -c -c wa1 and wa2 are work arrays of length n. if ml + mu + 1 is at -c least n, then the jacobian is considered dense, and wa2 is -c not referenced. -c -c subprograms called -c -c minpack-supplied ... dpmpar -c -c fortran-supplied ... dabs,dmax1,dsqrt -c -c argonne national laboratory. minpack project. march 1980. -c burton s. garbow, kenneth e. hillstrom, jorge j. more -c -c ********** - integer i,j,k,msum - double precision eps,epsmch,h,temp,zero - double precision dpmpar - data zero /0.0d0/ -c -c epsmch is the machine precision. -c - epsmch = dpmpar(1) -c - eps = dsqrt(dmax1(epsfcn,epsmch)) - msum = ml + mu + 1 - if (msum .lt. n) go to 40 -c -c computation of dense approximate jacobian. -c - do 20 j = 1, n - temp = x(j) - h = eps*dabs(temp) - if (h .eq. zero) h = eps - x(j) = temp + h - call fcn(n,x,wa1,iflag) - if (iflag .lt. 0) go to 30 - x(j) = temp - do 10 i = 1, n - fjac(i,j) = (wa1(i) - fvec(i))/h - 10 continue - 20 continue - 30 continue - go to 110 - 40 continue -c -c computation of banded approximate jacobian. -c - do 90 k = 1, msum - do 60 j = k, n, msum - wa2(j) = x(j) - h = eps*dabs(wa2(j)) - if (h .eq. zero) h = eps - x(j) = wa2(j) + h - 60 continue - call fcn(n,x,wa1,iflag) - if (iflag .lt. 0) go to 100 - do 80 j = k, n, msum - x(j) = wa2(j) - h = eps*dabs(wa2(j)) - if (h .eq. zero) h = eps - do 70 i = 1, n - fjac(i,j) = zero - if (i .ge. j - mu .and. i .le. j + ml) - * fjac(i,j) = (wa1(i) - fvec(i))/h - 70 continue - 80 continue - 90 continue - 100 continue - 110 continue - return -c -c last card of subroutine fdjac1. -c - end - diff --git a/src/fdjac2.f b/src/fdjac2.f deleted file mode 100644 index 218ab94..0000000 --- a/src/fdjac2.f +++ /dev/null @@ -1,107 +0,0 @@ - subroutine fdjac2(fcn,m,n,x,fvec,fjac,ldfjac,iflag,epsfcn,wa) - integer m,n,ldfjac,iflag - double precision epsfcn - double precision x(n),fvec(m),fjac(ldfjac,n),wa(m) -c ********** -c -c subroutine fdjac2 -c -c this subroutine computes a forward-difference approximation -c to the m by n jacobian matrix associated with a specified -c problem of m functions in n variables. -c -c the subroutine statement is -c -c subroutine fdjac2(fcn,m,n,x,fvec,fjac,ldfjac,iflag,epsfcn,wa) -c -c where -c -c fcn is the name of the user-supplied subroutine which -c calculates the functions. fcn must be declared -c in an external statement in the user calling -c program, and should be written as follows. -c -c subroutine fcn(m,n,x,fvec,iflag) -c integer m,n,iflag -c double precision x(n),fvec(m) -c ---------- -c calculate the functions at x and -c return this vector in fvec. -c ---------- -c return -c end -c -c the value of iflag should not be changed by fcn unless -c the user wants to terminate execution of fdjac2. -c in this case set iflag to a negative integer. -c -c m is a positive integer input variable set to the number -c of functions. -c -c n is a positive integer input variable set to the number -c of variables. n must not exceed m. -c -c x is an input array of length n. -c -c fvec is an input array of length m which must contain the -c functions evaluated at x. -c -c fjac is an output m by n array which contains the -c approximation to the jacobian matrix evaluated at x. -c -c ldfjac is a positive integer input variable not less than m -c which specifies the leading dimension of the array fjac. -c -c iflag is an integer variable which can be used to terminate -c the execution of fdjac2. see description of fcn. -c -c epsfcn is an input variable used in determining a suitable -c step length for the forward-difference approximation. this -c approximation assumes that the relative errors in the -c functions are of the order of epsfcn. if epsfcn is less -c than the machine precision, it is assumed that the relative -c errors in the functions are of the order of the machine -c precision. -c -c wa is a work array of length m. -c -c subprograms called -c -c user-supplied ...... fcn -c -c minpack-supplied ... dpmpar -c -c fortran-supplied ... dabs,dmax1,dsqrt -c -c argonne national laboratory. minpack project. march 1980. -c burton s. garbow, kenneth e. hillstrom, jorge j. more -c -c ********** - integer i,j - double precision eps,epsmch,h,temp,zero - double precision dpmpar - data zero /0.0d0/ -c -c epsmch is the machine precision. -c - epsmch = dpmpar(1) -c - eps = dsqrt(dmax1(epsfcn,epsmch)) - do 20 j = 1, n - temp = x(j) - h = eps*dabs(temp) - if (h .eq. zero) h = eps - x(j) = temp + h - call fcn(m,n,x,wa,iflag) - if (iflag .lt. 0) go to 30 - x(j) = temp - do 10 i = 1, m - fjac(i,j) = (wa(i) - fvec(i))/h - 10 continue - 20 continue - 30 continue - return -c -c last card of subroutine fdjac2. -c - end diff --git a/src/grdfcn.f b/src/grdfcn.f deleted file mode 100644 index 1dcb003..0000000 --- a/src/grdfcn.f +++ /dev/null @@ -1,438 +0,0 @@ - subroutine grdfcn(n,x,g,nprob) - integer n,nprob - double precision x(n),g(n) -c ********** -c -c subroutine grdfcn -c -c this subroutine defines the gradient vectors of eighteen -c nonlinear unconstrained minimization problems. the problem -c dimensions are as described in the prologue comments of objfcn. -c -c the subroutine statement is -c -c subroutine grdfcn(n,x,g,nprob) -c -c where -c -c n is a positive integer input variable. -c -c x is an input array of length n. -c -c g is an output array of length n which contains the components -c of the gradient vector of the nprob objective function -c evaluated at x. -c -c nprob is a positive integer input variable which defines the -c number of the problem. nprob must not exceed 18. -c -c subprograms called -c -c fortran-supplied ... dabs,datan,dcos,dexp,dlog,dsign,dsin, -c dsqrt -c -c argonne national laboratory. minpack project. march 1980. -c burton s. garbow, kenneth e. hillstrom, jorge j. more -c -c ********** - integer i,iev,ivar,j - double precision ap,arg,c2pdm6,cp0001,cp1,cp2,cp25,cp5,c1p5, - * c2p25,c2p625,c3p5,c19p8,c20p2,c25,c29,c100, - * c180,c200,c10000,c1pd6,d1,d2,eight,fifty,five, - * four,one,r,s1,s2,s3,t,t1,t2,t3,ten,th,three, - * tpi,twenty,two,zero - double precision fvec(50),y(15) - double precision dfloat - data zero,one,two,three,four,five,eight,ten,twenty,fifty - * /0.0d0,1.0d0,2.0d0,3.0d0,4.0d0,5.0d0,8.0d0,1.0d1,2.0d1, - * 5.0d1/ - data c2pdm6,cp0001,cp1,cp2,cp25,cp5,c1p5,c2p25,c2p625,c3p5, - * c19p8,c20p2,c25,c29,c100,c180,c200,c10000,c1pd6 - * /2.0d-6,1.0d-4,1.0d-1,2.0d-1,2.5d-1,5.0d-1,1.5d0,2.25d0, - * 2.625d0,3.5d0,1.98d1,2.02d1,2.5d1,2.9d1,1.0d2,1.8d2,2.0d2, - * 1.0d4,1.0d6/ - data ap /1.0d-5/ - data y(1),y(2),y(3),y(4),y(5),y(6),y(7),y(8),y(9),y(10),y(11), - * y(12),y(13),y(14),y(15) - * /9.0d-4,4.4d-3,1.75d-2,5.4d-2,1.295d-1,2.42d-1,3.521d-1, - * 3.989d-1,3.521d-1,2.42d-1,1.295d-1,5.4d-2,1.75d-2,4.4d-3, - * 9.0d-4/ - dfloat(ivar) = ivar -c -c gradient routine selector. -c - go to (10,20,50,70,80,100,130,190,220,260,270,290,310,350,370, - * 390,400,410), nprob -c -c helical valley function. -c - 10 continue - tpi = eight*datan(one) - th = dsign(cp25,x(2)) - if (x(1) .gt. zero) th = datan(x(2)/x(1))/tpi - if (x(1) .lt. zero) th = datan(x(2)/x(1))/tpi + cp5 - arg = x(1)**2 + x(2)**2 - r = dsqrt(arg) - t = x(3) - ten*th - s1 = ten*t/(tpi*arg) - g(1) = c200*(x(1) - x(1)/r + x(2)*s1) - g(2) = c200*(x(2) - x(2)/r - x(1)*s1) - g(3) = two*(c100*t + x(3)) - go to 490 -c -c biggs exp6 function. -c - 20 continue - do 30 j = 1, 6 - g(j) = zero - 30 continue - do 40 i = 1, 13 - d1 = dfloat(i)/ten - d2 = dexp(-d1) - five*dexp(-ten*d1) + three*dexp(-four*d1) - s1 = dexp(-d1*x(1)) - s2 = dexp(-d1*x(2)) - s3 = dexp(-d1*x(5)) - t = x(3)*s1 - x(4)*s2 + x(6)*s3 - d2 - th = d1*t - g(1) = g(1) - s1*th - g(2) = g(2) + s2*th - g(3) = g(3) + s1*t - g(4) = g(4) - s2*t - g(5) = g(5) - s3*th - g(6) = g(6) + s3*t - 40 continue - g(1) = two*x(3)*g(1) - g(2) = two*x(4)*g(2) - g(3) = two*g(3) - g(4) = two*g(4) - g(5) = two*x(6)*g(5) - g(6) = two*g(6) - go to 490 -c -c gaussian function. -c - 50 continue - g(1) = zero - g(2) = zero - g(3) = zero - do 60 i = 1, 15 - d1 = cp5*dfloat(i-1) - d2 = c3p5 - d1 - x(3) - arg = -cp5*x(2)*d2**2 - r = dexp(arg) - t = x(1)*r - y(i) - s1 = r*t - s2 = d2*s1 - g(1) = g(1) + s1 - g(2) = g(2) - d2*s2 - g(3) = g(3) + s2 - 60 continue - g(1) = two*g(1) - g(2) = x(1)*g(2) - g(3) = two*x(1)*x(2)*g(3) - go to 490 -c -c powell badly scaled function. -c - 70 continue - t1 = c10000*x(1)*x(2) - one - s1 = dexp(-x(1)) - s2 = dexp(-x(2)) - t2 = s1 + s2 - one - cp0001 - g(1) = two*(c10000*x(2)*t1 - s1*t2) - g(2) = two*(c10000*x(1)*t1 - s2*t2) - go to 490 -c -c box 3-dimensional function. -c - 80 continue - g(1) = zero - g(2) = zero - g(3) = zero - do 90 i = 1, 10 - d1 = dfloat(i) - d2 = d1/ten - s1 = dexp(-d2*x(1)) - s2 = dexp(-d2*x(2)) - s3 = dexp(-d2) - dexp(-d1) - t = s1 - s2 - s3*x(3) - th = d2*t - g(1) = g(1) - s1*th - g(2) = g(2) + s2*th - g(3) = g(3) - s3*t - 90 continue - g(1) = two*g(1) - g(2) = two*g(2) - g(3) = two*g(3) - go to 490 -c -c variably dimensioned function. -c - 100 continue - t1 = zero - do 110 j = 1, n - t1 = t1 + dfloat(j)*(x(j) - one) - 110 continue - t = t1*(one + two*t1**2) - do 120 j = 1, n - g(j) = two*(x(j) - one + dfloat(j)*t) - 120 continue - go to 490 -c -c watson function. -c - 130 continue - do 140 j = 1, n - g(j) = zero - 140 continue - do 180 i = 1, 29 - d1 = dfloat(i)/c29 - s1 = zero - d2 = one - do 150 j = 2, n - s1 = s1 + dfloat(j-1)*d2*x(j) - d2 = d1*d2 - 150 continue - s2 = zero - d2 = one - do 160 j = 1, n - s2 = s2 + d2*x(j) - d2 = d1*d2 - 160 continue - t = s1 - s2**2 - one - s3 = two*d1*s2 - d2 = two/d1 - do 170 j = 1, n - g(j) = g(j) + d2*(dfloat(j-1) - s3)*t - d2 = d1*d2 - 170 continue - 180 continue - t1 = x(2) - x(1)**2 - one - g(1) = g(1) + x(1)*(two - four*t1) - g(2) = g(2) + two*t1 - go to 490 -c -c penalty function i. -c - 190 continue - t1 = -cp25 - do 200 j = 1, n - t1 = t1 + x(j)**2 - 200 continue - d1 = two*ap - th = four*t1 - do 210 j = 1, n - g(j) = d1*(x(j) - one) + x(j)*th - 210 continue - go to 490 -c -c penalty function ii. -c - 220 continue - t1 = -one - do 230 j = 1, n - t1 = t1 + dfloat(n-j+1)*x(j)**2 - 230 continue - d1 = dexp(cp1) - d2 = one - th = four*t1 - do 250 j = 1, n - g(j) = dfloat(n-j+1)*x(j)*th - s1 = dexp(x(j)/ten) - if (j .eq. 1) go to 240 - s3 = s1 + s2 - d2*(d1 + one) - g(j) = g(j) + ap*s1*(s3 + s1 - one/d1)/five - g(j-1) = g(j-1) + ap*s2*s3/five - 240 continue - s2 = s1 - d2 = d1*d2 - 250 continue - g(1) = g(1) + two*(x(1) - cp2) - go to 490 -c -c brown badly scaled function. -c - 260 continue - t1 = x(1) - c1pd6 - t2 = x(2) - c2pdm6 - t3 = x(1)*x(2) - two - g(1) = two*(t1 + x(2)*t3) - g(2) = two*(t2 + x(1)*t3) - go to 490 -c -c brown and dennis function. -c - 270 continue - g(1) = zero - g(2) = zero - g(3) = zero - g(4) = zero - do 280 i = 1, 20 - d1 = dfloat(i)/five - d2 = dsin(d1) - t1 = x(1) + d1*x(2) - dexp(d1) - t2 = x(3) + d2*x(4) - dcos(d1) - t = t1**2 + t2**2 - s1 = t1*t - s2 = t2*t - g(1) = g(1) + s1 - g(2) = g(2) + d1*s1 - g(3) = g(3) + s2 - g(4) = g(4) + d2*s2 - 280 continue - g(1) = four*g(1) - g(2) = four*g(2) - g(3) = four*g(3) - g(4) = four*g(4) - go to 490 -c -c gulf research and development function. -c - 290 continue - g(1) = zero - g(2) = zero - g(3) = zero - d1 = two/three - do 300 i = 1, 99 - arg = dfloat(i)/c100 - r = (-fifty*dlog(arg))**d1 + c25 - x(2) - t1 = dabs(r)**x(3)/x(1) - t2 = dexp(-t1) - t = t2 - arg - s1 = t1*t2*t - g(1) = g(1) + s1 - g(2) = g(2) + s1/r - g(3) = g(3) - s1*dlog(dabs(r)) - 300 continue - g(1) = two*g(1)/x(1) - g(2) = two*x(3)*g(2) - g(3) = two*g(3) - go to 490 -c -c trigonometric function. -c - 310 continue - s1 = zero - do 320 j = 1, n - g(j) = dcos(x(j)) - s1 = s1 + g(j) - 320 continue - s2 = zero - do 330 j = 1, n - th = dsin(x(j)) - t = dfloat(n+j) - th - s1 - dfloat(j)*g(j) - s2 = s2 + t - g(j) = (dfloat(j)*th - g(j))*t - 330 continue - do 340 j = 1, n - g(j) = two*(g(j) + dsin(x(j))*s2) - 340 continue - go to 490 -c -c extended rosenbrock function. -c - 350 continue - do 360 j = 1, n, 2 - t1 = one - x(j) - g(j+1) = c200*(x(j+1) - x(j)**2) - g(j) = -two*(x(j)*g(j+1) + t1) - 360 continue - go to 490 -c -c extended powell function. -c - 370 continue - do 380 j = 1, n, 4 - t = x(j) + ten*x(j+1) - t1 = x(j+2) - x(j+3) - s1 = five*t1 - t2 = x(j+1) - two*x(j+2) - s2 = four*t2**3 - t3 = x(j) - x(j+3) - s3 = twenty*t3**3 - g(j) = two*(t + s3) - g(j+1) = twenty*t + s2 - g(j+2) = two*(s1 - s2) - g(j+3) = -two*(s1 + s3) - 380 continue - go to 490 -c -c beale function. -c - 390 continue - s1 = one - x(2) - t1 = c1p5 - x(1)*s1 - s2 = one - x(2)**2 - t2 = c2p25 - x(1)*s2 - s3 = one - x(2)**3 - t3 = c2p625 - x(1)*s3 - g(1) = -two*(s1*t1 + s2*t2 + s3*t3) - g(2) = two*x(1)*(t1 + x(2)*(two*t2 + three*x(2)*t3)) - go to 490 -c -c wood function. -c - 400 continue - s1 = x(2) - x(1)**2 - s2 = one - x(1) - s3 = x(2) - one - t1 = x(4) - x(3)**2 - t2 = one - x(3) - t3 = x(4) - one - g(1) = -two*(c200*x(1)*s1 + s2) - g(2) = c200*s1 + c20p2*s3 + c19p8*t3 - g(3) = -two*(c180*x(3)*t1 + t2) - g(4) = c180*t1 + c20p2*t3 + c19p8*s3 - go to 490 -c -c chebyquad function. -c - 410 continue - do 420 i = 1, n - fvec(i) = zero - 420 continue - do 440 j = 1, n - t1 = one - t2 = two*x(j) - one - t = two*t2 - do 430 i = 1, n - fvec(i) = fvec(i) + t2 - th = t*t2 - t1 - t1 = t2 - t2 = th - 430 continue - 440 continue - d1 = one/dfloat(n) - iev = -1 - do 450 i = 1, n - fvec(i) = d1*fvec(i) - if (iev .gt. 0) fvec(i) = fvec(i) + one/(dfloat(i)**2 - one) - iev = -iev - 450 continue - do 470 j = 1, n - g(j) = zero - t1 = one - t2 = two*x(j) - one - t = two*t2 - s1 = zero - s2 = two - do 460 i = 1, n - g(j) = g(j) + fvec(i)*s2 - th = four*t2 + t*s2 - s1 - s1 = s2 - s2 = th - th = t*t2 - t1 - t1 = t2 - t2 = th - 460 continue - 470 continue - d2 = two*d1 - do 480 j = 1, n - g(j) = d2*g(j) - 480 continue - 490 continue - return -c -c last card of subroutine grdfcn. -c - end diff --git a/src/hesfcn.f b/src/hesfcn.f deleted file mode 100644 index 15a8d03..0000000 --- a/src/hesfcn.f +++ /dev/null @@ -1,651 +0,0 @@ - subroutine hesfcn(n,x,h,ldh,nprob) - integer n,ldh,nprob - double precision x(n),h(ldh,n) -c ********** -c -c subroutine hesfcn -c -c this subroutine defines the hessian matrices of eighteen -c nonlinear unconstrained minimization problems. the problem -c dimensions are as described in the prologue comments of objfcn. -c the upper triangle of the (symmetric) hessian matrix is -c computed columnwise. storage locations below the diagonal -c are not disturbed until the final step, which reflects the -c upper triangle to fill the square matrix. -c -c the subroutine statement is -c -c subroutine hesfcn(n,x,h,ldh,nprob) -c -c where -c -c n is a positive integer input variable. -c -c x is an input array of length n. -c -c h is an n by n array. on output h contains the hessian -c matrix of the nprob objective function evaluated at x. -c -c ldh is a positive integer input variable not less than n -c which specifies the leading dimension of the array h. -c -c nprob is a positive integer input variable which defines the -c number of the problem. nprob must not exceed 18. -c -c subprograms called -c -c fortran-supplied ... dabs,datan,dcos,dexp,dlog,dsign,dsin, -c dsqrt -c -c argonne national laboratory. minpack project. march 1980. -c burton s. garbow, kenneth e. hillstrom, jorge j. more -c -c ********** - integer i,iev,ivar,j,k,n2 - double precision ap,arg,cp0001,cp1,cp25,cp5,c1p5,c2p25, - * c2p625,c3p5,c19p8,c25,c29,c100,c200,c10000,d1, - * d2,eight,fifty,five,four,one,r,s1,s2,s3,t,t1, - * t2,t3,ten,th,three,tpi,twenty,two,zero - double precision d3,r1,r2,r3,u1,u2,v,v1,v2 - double precision fvec(50),fvec1(50),y(15) - double precision dfloat - double precision six,xnine,twelve,c120,c200p2,c202,c220p2,c360, - * c400,c1200 - data six,xnine,twelve,c120,c200p2,c202,c220p2,c360,c400,c1200 - * /6.0d0,9.0d0,1.2d1,1.2d2,2.002d2,2.02d2,2.202d2,3.6d2, - * 4.0d2,1.2d3/ - data zero,one,two,three,four,five,eight,ten,twenty,fifty - * /0.0d0,1.0d0,2.0d0,3.0d0,4.0d0,5.0d0,8.0d0,1.0d1,2.0d1, - * 5.0d1/ - data cp0001,cp1,cp25,cp5,c1p5,c2p25,c2p625,c3p5,c19p8,c25,c29, - * c100,c200,c10000 - * /1.0d-4,1.0d-1,2.5d-1,5.0d-1,1.5d0,2.25d0,2.625d0,3.5d0, - * 1.98d1,2.5d1,2.9d1,1.0d2,2.0d2,1.0d4/ - data ap /1.0d-5/ - data y(1),y(2),y(3),y(4),y(5),y(6),y(7),y(8),y(9),y(10),y(11), - * y(12),y(13),y(14),y(15) - * /9.0d-4,4.4d-3,1.75d-2,5.4d-2,1.295d-1,2.42d-1,3.521d-1, - * 3.989d-1,3.521d-1,2.42d-1,1.295d-1,5.4d-2,1.75d-2,4.4d-3, - * 9.0d-4/ - dfloat(ivar) = ivar -c -c hessian routine selector. -c - go to (10,20,60,100,110,170,210,290,330,380,390,450,490,580,620, - * 660,670,680), nprob -c -c helical valley function. -c - 10 continue - tpi = eight*datan(one) - th = dsign(cp25,x(2)) - if (x(1) .gt. zero) th = datan(x(2)/x(1))/tpi - if (x(1) .lt. zero) th = datan(x(2)/x(1))/tpi + cp5 - arg = x(1)**2 + x(2)**2 - r = dsqrt(arg) - t = x(3) - ten*th - s1 = ten*t/(tpi*arg) - t1 = ten/tpi - t2 = t1/arg - t3 = (x(1)/r - t1*t2*x(1) - two*x(2)*s1)/arg - h(1,1) = c200 - * *(one - x(2)/arg*(x(2)/r - t1*t2*x(2) + two*x(1)*s1)) - h(1,2) = c200*(s1 + x(2)*t3) - h(2,2) = c200*(one - x(1)*t3) - h(1,3) = c200*t2*x(2) - h(2,3) = -c200*t2*x(1) - h(3,3) = c202 - go to 800 -c -c biggs exp6 function. -c - 20 continue - do 40 j = 1, 6 - do 30 i = 1, j - h(i,j) = zero - 30 continue - 40 continue - do 50 i = 1, 13 - d1 = dfloat(i)/ten - d2 = dexp(-d1) - five*dexp(-ten*d1) + three*dexp(-four*d1) - s1 = dexp(-d1*x(1)) - s2 = dexp(-d1*x(2)) - s3 = dexp(-d1*x(5)) - t = x(3)*s1 - x(4)*s2 + x(6)*s3 - d2 - th = d1*t - r1 = d1*s1 - r2 = d1*s2 - r3 = d1*s3 - h(1,1) = h(1,1) + r1*(th + x(3)*r1) - h(1,2) = h(1,2) - r1*r2 - h(2,2) = h(2,2) - r2*(th - x(4)*r2) - h(1,3) = h(1,3) - s1*(th + x(3)*r1) - h(3,3) = h(3,3) + s1**2 - h(1,4) = h(1,4) + r1*s2 - h(2,4) = h(2,4) + s2*(th - x(4)*r2) - h(3,4) = h(3,4) - s1*s2 - h(4,4) = h(4,4) + s2**2 - h(1,5) = h(1,5) + r1*r3 - h(2,5) = h(2,5) - r2*r3 - h(5,5) = h(5,5) + r3*(th + x(6)*r3) - h(1,6) = h(1,6) - r1*s3 - h(2,6) = h(2,6) + r2*s3 - h(3,6) = h(3,6) + s1*s3 - h(4,6) = h(4,6) - s2*s3 - h(5,6) = h(5,6) - s3*(th + x(6)*r3) - h(6,6) = h(6,6) + s3**2 - 50 continue - h(1,1) = two*x(3)*h(1,1) - h(1,2) = two*x(3)*x(4)*h(1,2) - h(2,2) = two*x(4)*h(2,2) - h(1,3) = two*h(1,3) - h(2,3) = two*x(4)*h(1,4) - h(3,3) = two*h(3,3) - h(1,4) = two*x(3)*h(1,4) - h(2,4) = two*h(2,4) - h(3,4) = two*h(3,4) - h(4,4) = two*h(4,4) - h(1,5) = two*x(3)*x(6)*h(1,5) - h(2,5) = two*x(4)*x(6)*h(2,5) - h(3,5) = two*x(6)*h(1,6) - h(4,5) = two*x(6)*h(2,6) - h(5,5) = two*x(6)*h(5,5) - h(1,6) = two*x(3)*h(1,6) - h(2,6) = two*x(4)*h(2,6) - h(3,6) = two*h(3,6) - h(4,6) = two*h(4,6) - h(5,6) = two*h(5,6) - h(6,6) = two*h(6,6) - go to 800 -c -c gaussian function. -c - 60 continue - do 80 j = 1, 3 - do 70 i = 1, j - h(i,j) = zero - 70 continue - 80 continue - do 90 i = 1, 15 - d1 = cp5*dfloat(i-1) - d2 = c3p5 - d1 - x(3) - arg = -cp5*x(2)*d2**2 - r = dexp(arg) - t = x(1)*r - y(i) - s1 = r*t - s2 = d2*s1 - t1 = s2 + d2*x(1)*r**2 - t2 = d2*t1 - h(1,1) = h(1,1) + r**2 - h(1,2) = h(1,2) - t2 - h(2,2) = h(2,2) + d2**2*t2 - h(1,3) = h(1,3) + t1 - h(2,3) = h(2,3) + two*s2 - d2*x(2)*t2 - h(3,3) = h(3,3) + x(2)*t2 - s1 - 90 continue - h(1,1) = two*h(1,1) - h(1,2) = h(1,2) - h(2,2) = cp5*x(1)*h(2,2) - h(1,3) = two*x(2)*h(1,3) - h(2,3) = x(1)*h(2,3) - h(3,3) = two*x(1)*x(2)*h(3,3) - go to 800 -c -c powell badly scaled function. -c - 100 continue - t1 = c10000*x(1)*x(2) - one - s1 = dexp(-x(1)) - s2 = dexp(-x(2)) - t2 = s1 + s2 - one - cp0001 - h(1,1) = two*((c10000*x(2))**2 + s1*(s1 + t2)) - h(1,2) = two*(c10000*(one + two*t1) + s1*s2) - h(2,2) = two*((c10000*x(1))**2 + s2*(s2 + t2)) - go to 800 -c -c box 3-dimensional function. -c - 110 continue - do 130 j = 1, 3 - do 120 i = 1, j - h(i,j) = zero - 120 continue - 130 continue - do 140 i = 1, 10 - d1 = dfloat(i) - d2 = d1/ten - s1 = dexp(-d2*x(1)) - s2 = dexp(-d2*x(2)) - s3 = dexp(-d2) - dexp(-d1) - t = s1 - s2 - s3*x(3) - th = d2*t - r1 = d2*s1 - r2 = d2*s2 - h(1,1) = h(1,1) + r1*(th + r1) - h(1,2) = h(1,2) - r1*r2 - h(2,2) = h(2,2) - r2*(th - r2) - h(1,3) = h(1,3) + r1*s3 - h(2,3) = h(2,3) - r2*s3 - h(3,3) = h(3,3) + s3**2 - 140 continue - do 160 j = 1, 3 - do 150 i = 1, j - h(i,j) = two*h(i,j) - 150 continue - 160 continue - go to 800 -c -c variably dimensioned function. -c - 170 continue - t1 = zero - do 180 j = 1, n - t1 = t1 + dfloat(j)*(x(j) - one) - 180 continue -c t = t1*(one + two*t1**2) - t2 = two + twelve*t1**2 - do 200 j = 1, n - do 190 i = 1, j - h(i,j) = dfloat(i*j)*t2 - 190 continue - h(j,j) = h(j,j) + two - 200 continue - go to 800 -c -c watson function. -c - 210 continue - do 230 j = 1, n - do 220 k = 1, j - h(k,j) = zero - 220 continue - 230 continue - do 280 i = 1, 29 - d1 = dfloat(i)/c29 - s1 = zero - d2 = one - do 240 j = 2, n - s1 = s1 + dfloat(j-1)*d2*x(j) - d2 = d1*d2 - 240 continue - s2 = zero - d2 = one - do 250 j = 1, n - s2 = s2 + d2*x(j) - d2 = d1*d2 - 250 continue - t = s1 - s2**2 - one - s3 = two*d1*s2 - d2 = two/d1 - th = two*d1**2*t - do 270 j = 1, n - v = dfloat(j-1) - s3 - d3 = one/d1 - do 260 k = 1, j - h(k,j) = h(k,j) + d2*d3*(v*(dfloat(k-1) - s3) - th) - d3 = d1*d3 - 260 continue - d2 = d1*d2 - 270 continue - 280 continue - t1 = x(2) - x(1)**2 - one - h(1,1) = h(1,1) + eight*x(1)**2 + two - four*t1 - h(1,2) = h(1,2) - four*x(1) - h(2,2) = h(2,2) + two - go to 800 -c -c penalty function i. -c - 290 continue - t1 = -cp25 - do 300 j = 1, n - t1 = t1 + x(j)**2 - 300 continue - d1 = two*ap - th = four*t1 - do 320 j = 1, n - t2 = eight*x(j) - do 310 i = 1, j - h(i,j) = x(i)*t2 - 310 continue - h(j,j) = h(j,j) + d1 + th - 320 continue - go to 800 -c -c penalty function ii. -c - 330 continue - t1 = -one - do 340 j = 1, n - t1 = t1 + dfloat(n-j+1)*x(j)**2 - 340 continue - d1 = dexp(cp1) - d2 = one - th = four*t1 - do 370 j = 1, n - t2 = eight*dfloat(n-j+1)*x(j) - do 350 i = 1, j - h(i,j) = dfloat(n-i+1)*x(i)*t2 - 350 continue - h(j,j) = h(j,j) + dfloat(n-j+1)*th - s1 = dexp(x(j)/ten) - if (j .eq. 1) go to 360 - s3 = s1 + s2 - d2*(d1 + one) - h(j,j) = h(j,j) + ap*s1*(s3 + three*s1 - one/d1)/fifty - h(j-1,j) = h(j-1,j) + ap*s1*s2/fifty - h(j-1,j-1) = h(j-1,j-1) + ap*s2*(s2 + s3)/fifty - 360 continue - s2 = s1 - d2 = d1*d2 - 370 continue - h(1,1) = h(1,1) + two - go to 800 -c -c brown badly scaled function. -c - 380 continue -c t1 = x(1) - c1pd6 -c t2 = x(2) - c2pdm6 - t3 = x(1)*x(2) - two - h(1,1) = two*(one + x(2)**2) - h(1,2) = four*(one + t3) - h(2,2) = two*(one + x(1)**2) - go to 800 -c -c brown and dennis function. -c - 390 continue - do 410 j = 1, 4 - do 400 i = 1, j - h(i,j) = zero - 400 continue - 410 continue - do 420 i = 1, 20 - d1 = dfloat(i)/five - d2 = dsin(d1) - t1 = x(1) + d1*x(2) - dexp(d1) - t2 = x(3) + d2*x(4) - dcos(d1) - t = t1**2 + t2**2 -c s1 = t1*t -c s2 = t2*t - s3 = two*t1*t2 - r1 = t + two*t1**2 - r2 = t + two*t2**2 - h(1,1) = h(1,1) + r1 - h(1,2) = h(1,2) + d1*r1 - h(2,2) = h(2,2) + d1**2*r1 - h(1,3) = h(1,3) + s3 - h(2,3) = h(2,3) + d1*s3 - h(3,3) = h(3,3) + r2 - h(1,4) = h(1,4) + d2*s3 - h(2,4) = h(2,4) + d1*d2*s3 - h(3,4) = h(3,4) + d2*r2 - h(4,4) = h(4,4) + d2**2*r2 - 420 continue - do 440 j = 1, 4 - do 430 i = 1, j - h(i,j) = four*h(i,j) - 430 continue - 440 continue - go to 800 -c -c gulf research and development function. -c - 450 continue - do 470 j = 1, 3 - do 460 i = 1, j - h(i,j) = zero - 460 continue - 470 continue - d1 = two/three - do 480 i = 1, 99 - arg = dfloat(i)/c100 - r = (-fifty*dlog(arg))**d1 + c25 - x(2) - t1 = dabs(r)**x(3)/x(1) - t2 = dexp(-t1) - t = t2 - arg - s1 = t1*t2*t - s2 = t1*(s1 + t2*(t1*t2 - t)) - r1 = dlog(dabs(r)) - r2 = r1*s2 - h(1,1) = h(1,1) + s2 - s1 - h(1,2) = h(1,2) + s2/r - h(2,2) = h(2,2) + (s1 + x(3)*s2)/r**2 - h(1,3) = h(1,3) - r2 - h(2,3) = h(2,3) + (s1 - x(3)*r2)/r - h(3,3) = h(3,3) + r1*r2 - 480 continue - h(1,1) = two*h(1,1)/x(1)**2 - h(1,2) = two*x(3)*h(1,2)/x(1) - h(2,2) = two*x(3)*h(2,2) - h(1,3) = two*h(1,3)/x(1) - h(2,3) = two*h(2,3) - h(3,3) = two*h(3,3) - go to 800 -c -c trigonometric function. -c - 490 continue - u2 = dcos(x(n)) - s1 = u2 - if (n .eq. 1) go to 510 - u1 = dcos(x(n-1)) - s1 = s1 + u1 - if (n .eq. 2) go to 510 - n2 = n - 2 - do 500 j = 1, n2 - h(j,n-1) = dcos(x(j)) - s1 = s1 + h(j,n-1) - 500 continue - 510 continue - v2 = dsin(x(n)) - s2 = dfloat(2*n) - v2 - s1 - dfloat(n)*u2 - r2 = dfloat(2*n)*v2 - u2 - if (n .eq. 1) go to 570 - v1 = dsin(x(n-1)) - s2 = s2 + dfloat(2*n-1) - v1 - s1 - dfloat(n-1)*u1 - r1 = dfloat(2*n-1)*v1 - u1 - if (n .eq. 2) go to 560 - do 520 j = 1, n2 - h(j,n) = dsin(x(j)) - t = dfloat(n+j) - h(j,n) - s1 - dfloat(j)*h(j,n-1) - s2 = s2 + t - 520 continue - do 540 j = 1, n2 - v = dfloat(j)*h(j,n-1) + h(j,n) - t = dfloat(n+j) - s1 - v - t1 = dfloat(n+j)*h(j,n) - h(j,n-1) - do 530 i = 1, j - th = dfloat(i)*h(i,n) - h(i,n-1) - h(i,j) = two*(h(i,n)*t1 + h(j,n)*th) - 530 continue - h(j,j) = h(j,j) + two*(h(j,n-1)*s2 + v*t + th**2) - 540 continue - do 550 i = 1, n2 - th = dfloat(i)*h(i,n) - h(i,n-1) - h(i,n-1) = two*(h(i,n)*r1 + v1*th) - h(i,n) = two*(h(i,n)*r2 + v2*th) - 550 continue - 560 continue - v = dfloat(n-1)*u1 + v1 - t = dfloat(2*n-1) - s1 - v - th = dfloat(n-1)*v1 - u1 - h(n-1,n-1) = two*(v1*(r1 + th) + u1*s2 + v*t + th**2) - h(n-1,n) = two*(v1*r2 + v2*th) - 570 continue - v = dfloat(n)*u2 + v2 - t = dfloat(2*n) - s1 - v - th = dfloat(n)*v2 - u2 - h(n,n) = two*(v2*(r2 + th) + u2*s2 + v*t + th**2) - go to 800 -c -c extended rosenbrock function. -c - 580 continue - do 600 j = 1, n - do 590 i = 1, j - h(i,j) = zero - 590 continue - 600 continue - do 610 j = 1, n, 2 -c t1 = one - x(j) - h(j,j) = c1200*x(j)**2 - c400*x(j+1) + two - h(j,j+1) = -c400*x(j) - h(j+1,j+1) = c200 - 610 continue - go to 800 -c -c extended powell function. -c - 620 continue - do 640 j = 1, n - do 630 i = 1, j - h(i,j) = zero - 630 continue - 640 continue - do 650 j = 1, n, 4 -c t = x(j) + ten*x(j+1) -c t1 = x(j+2) - x(j+3) -c s1 = five*t1 - t2 = x(j+1) - two*x(j+2) -c s2 = four*t2**3 - t3 = x(j) - x(j+3) -c s3 = twenty*t3**3 - r2 = twelve*t2**2 - r3 = c120*t3**2 - h(j,j) = two + r3 - h(j,j+1) = twenty - h(j+1,j+1) = c200 + r2 - h(j+1,j+2) = -two*r2 - h(j+2,j+2) = ten + four*r2 - h(j,j+3) = -r3 - h(j+2,j+3) = -ten - h(j+3,j+3) = ten + r3 - 650 continue - go to 800 -c -c beale function. -c - 660 continue - s1 = one - x(2) - t1 = c1p5 - x(1)*s1 - s2 = one - x(2)**2 - t2 = c2p25 - x(1)*s2 - s3 = one - x(2)**3 - t3 = c2p625 - x(1)*s3 - h(1,1) = two*(s1**2 + s2**2 + s3**2) - h(1,2) = two - * *(t1 + x(2)*(two*t2 + three*x(2)*t3) - * - x(1)*(s1 + x(2)*(two*s2 + three*x(2)*s3))) - h(2,2) = two*x(1) - * *(x(1) + two*t2 - * + x(2)*(six*t3 + x(1)*x(2)*(four + xnine*x(2)**2))) - go to 800 -c -c wood function. -c - 670 continue - s1 = x(2) - x(1)**2 -c s2 = one - x(1) -c s3 = x(2) - one - t1 = x(4) - x(3)**2 -c t2 = one - x(3) -c t3 = x(4) - one - h(1,1) = c400*(two*x(1)**2 - s1) + two - h(1,2) = -c400*x(1) - h(2,2) = c220p2 - h(1,3) = zero - h(2,3) = zero - h(3,3) = c360*(two*x(3)**2 - t1) + two - h(1,4) = zero - h(2,4) = c19p8 - h(3,4) = -c360*x(3) - h(4,4) = c200p2 - go to 800 -c -c chebyquad function. -c - 680 continue - do 690 i = 1, n - fvec(i) = zero - 690 continue - do 710 j = 1, n - t1 = one - t2 = two*x(j) - one - t = two*t2 - do 700 i = 1, n - fvec(i) = fvec(i) + t2 - th = t*t2 - t1 - t1 = t2 - t2 = th - 700 continue - 710 continue - d1 = one/dfloat(n) - iev = -1 - do 720 i = 1, n - fvec(i) = d1*fvec(i) - if (iev .gt. 0) fvec(i) = fvec(i) + one/(dfloat(i)**2 - one) - iev = -iev - 720 continue - do 770 j = 1, n - do 730 k = 1, j - h(k,j) = zero - 730 continue - t1 = one - t2 = two*x(j) - one - t = two*t2 - s1 = zero - s2 = two - r1 = zero - r2 = zero - do 740 i = 1, n - h(j,j) = h(j,j) + fvec(i)*r2 - th = eight*s2 + t*r2 - r1 - r1 = r2 - r2 = th - fvec1(i) = d1*s2 - th = four*t2 + t*s2 - s1 - s1 = s2 - s2 = th - th = t*t2 - t1 - t1 = t2 - t2 = th - 740 continue - do 760 k = 1, j - v1 = one - v2 = two*x(k) - one - v = two*v2 - u1 = zero - u2 = two - do 750 i = 1, n - h(k,j) = h(k,j) + fvec1(i)*u2 - th = four*v2 + v*u2 - u1 - u1 = u2 - u2 = th - th = v*v2 - v1 - v1 = v2 - v2 = th - 750 continue - 760 continue - 770 continue - d2 = two*d1 - do 790 j = 1, n - do 780 k = 1, j - h(k,j) = d2*h(k,j) - 780 continue - 790 continue -c -c reflect the upper triangle to fill the square matrix. -c - 800 continue - do 820 j = 1, n - do 810 i = j, n - h(i,j) = h(j,i) - 810 continue - 820 continue - return -c -c last card of subroutine hesfcn. -c - end - diff --git a/src/hybipt.f b/src/hybipt.f deleted file mode 100644 index 5bf4d2e..0000000 --- a/src/hybipt.f +++ /dev/null @@ -1,167 +0,0 @@ - subroutine initpt(n,x,nprob,factor) - integer n,nprob - double precision factor - double precision x(n) -c ********** -c -c subroutine initpt -c -c this subroutine specifies the standard starting points for -c the functions defined by subroutine vecfcn. the subroutine -c returns in x a multiple (factor) of the standard starting -c point. for the sixth function the standard starting point is -c zero, so in this case, if factor is not unity, then the -c subroutine returns the vector x(j) = factor, j=1,...,n. -c -c the subroutine statement is -c -c subroutine initpt(n,x,nprob,factor) -c -c where -c -c n is a positive integer input variable. -c -c x is an output array of length n which contains the standard -c starting point for problem nprob multiplied by factor. -c -c nprob is a positive integer input variable which defines the -c number of the problem. nprob must not exceed 14. -c -c factor is an input variable which specifies the multiple of -c the standard starting point. if factor is unity, no -c multiplication is performed. -c -c argonne national laboratory. minpack project. march 1980. -c burton s. garbow, kenneth e. hillstrom, jorge j. more -c -c ********** - integer ivar,j - double precision c1,h,half,one,three,tj,zero - double precision dfloat - data zero,half,one,three,c1 /0.0d0,5.0d-1,1.0d0,3.0d0,1.2d0/ - dfloat(ivar) = ivar -c -c selection of initial point. -c - go to (10,20,30,40,50,60,80,100,120,120,140,160,180,180), nprob -c -c rosenbrock function. -c - 10 continue - x(1) = -c1 - x(2) = one - go to 200 -c -c powell singular function. -c - 20 continue - x(1) = three - x(2) = -one - x(3) = zero - x(4) = one - go to 200 -c -c powell badly scaled function. -c - 30 continue - x(1) = zero - x(2) = one - go to 200 -c -c wood function. -c - 40 continue - x(1) = -three - x(2) = -one - x(3) = -three - x(4) = -one - go to 200 -c -c helical valley function. -c - 50 continue - x(1) = -one - x(2) = zero - x(3) = zero - go to 200 -c -c watson function. -c - 60 continue - do 70 j = 1, n - x(j) = zero - 70 continue - go to 200 -c -c chebyquad function. -c - 80 continue - h = one/dfloat(n+1) - do 90 j = 1, n - x(j) = dfloat(j)*h - 90 continue - go to 200 -c -c brown almost-linear function. -c - 100 continue - do 110 j = 1, n - x(j) = half - 110 continue - go to 200 -c -c discrete boundary value and integral equation functions. -c - 120 continue - h = one/dfloat(n+1) - do 130 j = 1, n - tj = dfloat(j)*h - x(j) = tj*(tj - one) - 130 continue - go to 200 -c -c trigonometric function. -c - 140 continue - h = one/dfloat(n) - do 150 j = 1, n - x(j) = h - 150 continue - go to 200 -c -c variably dimensioned function. -c - 160 continue - h = one/dfloat(n) - do 170 j = 1, n - x(j) = one - dfloat(j)*h - 170 continue - go to 200 -c -c broyden tridiagonal and banded functions. -c - 180 continue - do 190 j = 1, n - x(j) = -one - 190 continue - 200 continue -c -c compute multiple of initial point. -c - if (factor .eq. one) go to 250 - if (nprob .eq. 6) go to 220 - do 210 j = 1, n - x(j) = factor*x(j) - 210 continue - go to 240 - 220 continue - do 230 j = 1, n - x(j) = factor - 230 continue - 240 continue - 250 continue - return -c -c last card of subroutine initpt. -c - end diff --git a/src/hybrd.f b/src/hybrd.f deleted file mode 100644 index fc0b4c2..0000000 --- a/src/hybrd.f +++ /dev/null @@ -1,459 +0,0 @@ - subroutine hybrd(fcn,n,x,fvec,xtol,maxfev,ml,mu,epsfcn,diag, - * mode,factor,nprint,info,nfev,fjac,ldfjac,r,lr, - * qtf,wa1,wa2,wa3,wa4) - integer n,maxfev,ml,mu,mode,nprint,info,nfev,ldfjac,lr - double precision xtol,epsfcn,factor - double precision x(n),fvec(n),diag(n),fjac(ldfjac,n),r(lr), - * qtf(n),wa1(n),wa2(n),wa3(n),wa4(n) - external fcn -c ********** -c -c subroutine hybrd -c -c the purpose of hybrd is to find a zero of a system of -c n nonlinear functions in n variables by a modification -c of the powell hybrid method. the user must provide a -c subroutine which calculates the functions. the jacobian is -c then calculated by a forward-difference approximation. -c -c the subroutine statement is -c -c subroutine hybrd(fcn,n,x,fvec,xtol,maxfev,ml,mu,epsfcn, -c diag,mode,factor,nprint,info,nfev,fjac, -c ldfjac,r,lr,qtf,wa1,wa2,wa3,wa4) -c -c where -c -c fcn is the name of the user-supplied subroutine which -c calculates the functions. fcn must be declared -c in an external statement in the user calling -c program, and should be written as follows. -c -c subroutine fcn(n,x,fvec,iflag) -c integer n,iflag -c double precision x(n),fvec(n) -c ---------- -c calculate the functions at x and -c return this vector in fvec. -c --------- -c return -c end -c -c the value of iflag should not be changed by fcn unless -c the user wants to terminate execution of hybrd. -c in this case set iflag to a negative integer. -c -c n is a positive integer input variable set to the number -c of functions and variables. -c -c x is an array of length n. on input x must contain -c an initial estimate of the solution vector. on output x -c contains the final estimate of the solution vector. -c -c fvec is an output array of length n which contains -c the functions evaluated at the output x. -c -c xtol is a nonnegative input variable. termination -c occurs when the relative error between two consecutive -c iterates is at most xtol. -c -c maxfev is a positive integer input variable. termination -c occurs when the number of calls to fcn is at least maxfev -c by the end of an iteration. -c -c ml is a nonnegative integer input variable which specifies -c the number of subdiagonals within the band of the -c jacobian matrix. if the jacobian is not banded, set -c ml to at least n - 1. -c -c mu is a nonnegative integer input variable which specifies -c the number of superdiagonals within the band of the -c jacobian matrix. if the jacobian is not banded, set -c mu to at least n - 1. -c -c epsfcn is an input variable used in determining a suitable -c step length for the forward-difference approximation. this -c approximation assumes that the relative errors in the -c functions are of the order of epsfcn. if epsfcn is less -c than the machine precision, it is assumed that the relative -c errors in the functions are of the order of the machine -c precision. -c -c diag is an array of length n. if mode = 1 (see -c below), diag is internally set. if mode = 2, diag -c must contain positive entries that serve as -c multiplicative scale factors for the variables. -c -c mode is an integer input variable. if mode = 1, the -c variables will be scaled internally. if mode = 2, -c the scaling is specified by the input diag. other -c values of mode are equivalent to mode = 1. -c -c factor is a positive input variable used in determining the -c initial step bound. this bound is set to the product of -c factor and the euclidean norm of diag*x if nonzero, or else -c to factor itself. in most cases factor should lie in the -c interval (.1,100.). 100. is a generally recommended value. -c -c nprint is an integer input variable that enables controlled -c printing of iterates if it is positive. in this case, -c fcn is called with iflag = 0 at the beginning of the first -c iteration and every nprint iterations thereafter and -c immediately prior to return, with x and fvec available -c for printing. if nprint is not positive, no special calls -c of fcn with iflag = 0 are made. -c -c info is an integer output variable. if the user has -c terminated execution, info is set to the (negative) -c value of iflag. see description of fcn. otherwise, -c info is set as follows. -c -c info = 0 improper input parameters. -c -c info = 1 relative error between two consecutive iterates -c is at most xtol. -c -c info = 2 number of calls to fcn has reached or exceeded -c maxfev. -c -c info = 3 xtol is too small. no further improvement in -c the approximate solution x is possible. -c -c info = 4 iteration is not making good progress, as -c measured by the improvement from the last -c five jacobian evaluations. -c -c info = 5 iteration is not making good progress, as -c measured by the improvement from the last -c ten iterations. -c -c nfev is an integer output variable set to the number of -c calls to fcn. -c -c fjac is an output n by n array which contains the -c orthogonal matrix q produced by the qr factorization -c of the final approximate jacobian. -c -c ldfjac is a positive integer input variable not less than n -c which specifies the leading dimension of the array fjac. -c -c r is an output array of length lr which contains the -c upper triangular matrix produced by the qr factorization -c of the final approximate jacobian, stored rowwise. -c -c lr is a positive integer input variable not less than -c (n*(n+1))/2. -c -c qtf is an output array of length n which contains -c the vector (q transpose)*fvec. -c -c wa1, wa2, wa3, and wa4 are work arrays of length n. -c -c subprograms called -c -c user-supplied ...... fcn -c -c minpack-supplied ... dogleg,dpmpar,enorm,fdjac1, -c qform,qrfac,r1mpyq,r1updt -c -c fortran-supplied ... dabs,dmax1,dmin1,min0,mod -c -c argonne national laboratory. minpack project. march 1980. -c burton s. garbow, kenneth e. hillstrom, jorge j. more -c -c ********** - integer i,iflag,iter,j,jm1,l,msum,ncfail,ncsuc,nslow1,nslow2 - integer iwa(1) - logical jeval,sing - double precision actred,delta,epsmch,fnorm,fnorm1,one,pnorm, - * prered,p1,p5,p001,p0001,ratio,sum,temp,xnorm, - * zero - double precision dpmpar,enorm - data one,p1,p5,p001,p0001,zero - * /1.0d0,1.0d-1,5.0d-1,1.0d-3,1.0d-4,0.0d0/ -c -c epsmch is the machine precision. -c - epsmch = dpmpar(1) -c - info = 0 - iflag = 0 - nfev = 0 -c -c check the input parameters for errors. -c - if (n .le. 0 .or. xtol .lt. zero .or. maxfev .le. 0 - * .or. ml .lt. 0 .or. mu .lt. 0 .or. factor .le. zero - * .or. ldfjac .lt. n .or. lr .lt. (n*(n + 1))/2) go to 300 - if (mode .ne. 2) go to 20 - do 10 j = 1, n - if (diag(j) .le. zero) go to 300 - 10 continue - 20 continue -c -c evaluate the function at the starting point -c and calculate its norm. -c - iflag = 1 - call fcn(n,x,fvec,iflag) - nfev = 1 - if (iflag .lt. 0) go to 300 - fnorm = enorm(n,fvec) -c -c determine the number of calls to fcn needed to compute -c the jacobian matrix. -c - msum = min0(ml+mu+1,n) -c -c initialize iteration counter and monitors. -c - iter = 1 - ncsuc = 0 - ncfail = 0 - nslow1 = 0 - nslow2 = 0 -c -c beginning of the outer loop. -c - 30 continue - jeval = .true. -c -c calculate the jacobian matrix. -c - iflag = 2 - call fdjac1(fcn,n,x,fvec,fjac,ldfjac,iflag,ml,mu,epsfcn,wa1, - * wa2) - nfev = nfev + msum - if (iflag .lt. 0) go to 300 -c -c compute the qr factorization of the jacobian. -c - call qrfac(n,n,fjac,ldfjac,.false.,iwa,1,wa1,wa2,wa3) -c -c on the first iteration and if mode is 1, scale according -c to the norms of the columns of the initial jacobian. -c - if (iter .ne. 1) go to 70 - if (mode .eq. 2) go to 50 - do 40 j = 1, n - diag(j) = wa2(j) - if (wa2(j) .eq. zero) diag(j) = one - 40 continue - 50 continue -c -c on the first iteration, calculate the norm of the scaled x -c and initialize the step bound delta. -c - do 60 j = 1, n - wa3(j) = diag(j)*x(j) - 60 continue - xnorm = enorm(n,wa3) - delta = factor*xnorm - if (delta .eq. zero) delta = factor - 70 continue -c -c form (q transpose)*fvec and store in qtf. -c - do 80 i = 1, n - qtf(i) = fvec(i) - 80 continue - do 120 j = 1, n - if (fjac(j,j) .eq. zero) go to 110 - sum = zero - do 90 i = j, n - sum = sum + fjac(i,j)*qtf(i) - 90 continue - temp = -sum/fjac(j,j) - do 100 i = j, n - qtf(i) = qtf(i) + fjac(i,j)*temp - 100 continue - 110 continue - 120 continue -c -c copy the triangular factor of the qr factorization into r. -c - sing = .false. - do 150 j = 1, n - l = j - jm1 = j - 1 - if (jm1 .lt. 1) go to 140 - do 130 i = 1, jm1 - r(l) = fjac(i,j) - l = l + n - i - 130 continue - 140 continue - r(l) = wa1(j) - if (wa1(j) .eq. zero) sing = .true. - 150 continue -c -c accumulate the orthogonal factor in fjac. -c - call qform(n,n,fjac,ldfjac,wa1) -c -c rescale if necessary. -c - if (mode .eq. 2) go to 170 - do 160 j = 1, n - diag(j) = dmax1(diag(j),wa2(j)) - 160 continue - 170 continue -c -c beginning of the inner loop. -c - 180 continue -c -c if requested, call fcn to enable printing of iterates. -c - if (nprint .le. 0) go to 190 - iflag = 0 - if (mod(iter-1,nprint) .eq. 0) call fcn(n,x,fvec,iflag) - if (iflag .lt. 0) go to 300 - 190 continue -c -c determine the direction p. -c - call dogleg(n,r,lr,diag,qtf,delta,wa1,wa2,wa3) -c -c store the direction p and x + p. calculate the norm of p. -c - do 200 j = 1, n - wa1(j) = -wa1(j) - wa2(j) = x(j) + wa1(j) - wa3(j) = diag(j)*wa1(j) - 200 continue - pnorm = enorm(n,wa3) -c -c on the first iteration, adjust the initial step bound. -c - if (iter .eq. 1) delta = dmin1(delta,pnorm) -c -c evaluate the function at x + p and calculate its norm. -c - iflag = 1 - call fcn(n,wa2,wa4,iflag) - nfev = nfev + 1 - if (iflag .lt. 0) go to 300 - fnorm1 = enorm(n,wa4) -c -c compute the scaled actual reduction. -c - actred = -one - if (fnorm1 .lt. fnorm) actred = one - (fnorm1/fnorm)**2 -c -c compute the scaled predicted reduction. -c - l = 1 - do 220 i = 1, n - sum = zero - do 210 j = i, n - sum = sum + r(l)*wa1(j) - l = l + 1 - 210 continue - wa3(i) = qtf(i) + sum - 220 continue - temp = enorm(n,wa3) - prered = zero - if (temp .lt. fnorm) prered = one - (temp/fnorm)**2 -c -c compute the ratio of the actual to the predicted -c reduction. -c - ratio = zero - if (prered .gt. zero) ratio = actred/prered -c -c update the step bound. -c - if (ratio .ge. p1) go to 230 - ncsuc = 0 - ncfail = ncfail + 1 - delta = p5*delta - go to 240 - 230 continue - ncfail = 0 - ncsuc = ncsuc + 1 - if (ratio .ge. p5 .or. ncsuc .gt. 1) - * delta = dmax1(delta,pnorm/p5) - if (dabs(ratio-one) .le. p1) delta = pnorm/p5 - 240 continue -c -c test for successful iteration. -c - if (ratio .lt. p0001) go to 260 -c -c successful iteration. update x, fvec, and their norms. -c - do 250 j = 1, n - x(j) = wa2(j) - wa2(j) = diag(j)*x(j) - fvec(j) = wa4(j) - 250 continue - xnorm = enorm(n,wa2) - fnorm = fnorm1 - iter = iter + 1 - 260 continue -c -c determine the progress of the iteration. -c - nslow1 = nslow1 + 1 - if (actred .ge. p001) nslow1 = 0 - if (jeval) nslow2 = nslow2 + 1 - if (actred .ge. p1) nslow2 = 0 -c -c test for convergence. -c - if (delta .le. xtol*xnorm .or. fnorm .eq. zero) info = 1 - if (info .ne. 0) go to 300 -c -c tests for termination and stringent tolerances. -c - if (nfev .ge. maxfev) info = 2 - if (p1*dmax1(p1*delta,pnorm) .le. epsmch*xnorm) info = 3 - if (nslow2 .eq. 5) info = 4 - if (nslow1 .eq. 10) info = 5 - if (info .ne. 0) go to 300 -c -c criterion for recalculating jacobian approximation -c by forward differences. -c - if (ncfail .eq. 2) go to 290 -c -c calculate the rank one modification to the jacobian -c and update qtf if necessary. -c - do 280 j = 1, n - sum = zero - do 270 i = 1, n - sum = sum + fjac(i,j)*wa4(i) - 270 continue - wa2(j) = (sum - wa3(j))/pnorm - wa1(j) = diag(j)*((diag(j)*wa1(j))/pnorm) - if (ratio .ge. p0001) qtf(j) = sum - 280 continue -c -c compute the qr factorization of the updated jacobian. -c - call r1updt(n,n,r,lr,wa1,wa2,wa3,sing) - call r1mpyq(n,n,fjac,ldfjac,wa2,wa3) - call r1mpyq(1,n,qtf,1,wa2,wa3) -c -c end of the inner loop. -c - jeval = .false. - go to 180 - 290 continue -c -c end of the outer loop. -c - go to 30 - 300 continue -c -c termination, either normal or user imposed. -c - if (iflag .lt. 0) info = iflag - iflag = 0 - if (nprint .gt. 0) call fcn(n,x,fvec,iflag) - return -c -c last card of subroutine hybrd. -c - end diff --git a/src/hybrd1.f b/src/hybrd1.f deleted file mode 100644 index c0a8592..0000000 --- a/src/hybrd1.f +++ /dev/null @@ -1,123 +0,0 @@ - subroutine hybrd1(fcn,n,x,fvec,tol,info,wa,lwa) - integer n,info,lwa - double precision tol - double precision x(n),fvec(n),wa(lwa) - external fcn -c ********** -c -c subroutine hybrd1 -c -c the purpose of hybrd1 is to find a zero of a system of -c n nonlinear functions in n variables by a modification -c of the powell hybrid method. this is done by using the -c more general nonlinear equation solver hybrd. the user -c must provide a subroutine which calculates the functions. -c the jacobian is then calculated by a forward-difference -c approximation. -c -c the subroutine statement is -c -c subroutine hybrd1(fcn,n,x,fvec,tol,info,wa,lwa) -c -c where -c -c fcn is the name of the user-supplied subroutine which -c calculates the functions. fcn must be declared -c in an external statement in the user calling -c program, and should be written as follows. -c -c subroutine fcn(n,x,fvec,iflag) -c integer n,iflag -c double precision x(n),fvec(n) -c ---------- -c calculate the functions at x and -c return this vector in fvec. -c --------- -c return -c end -c -c the value of iflag should not be changed by fcn unless -c the user wants to terminate execution of hybrd1. -c in this case set iflag to a negative integer. -c -c n is a positive integer input variable set to the number -c of functions and variables. -c -c x is an array of length n. on input x must contain -c an initial estimate of the solution vector. on output x -c contains the final estimate of the solution vector. -c -c fvec is an output array of length n which contains -c the functions evaluated at the output x. -c -c tol is a nonnegative input variable. termination occurs -c when the algorithm estimates that the relative error -c between x and the solution is at most tol. -c -c info is an integer output variable. if the user has -c terminated execution, info is set to the (negative) -c value of iflag. see description of fcn. otherwise, -c info is set as follows. -c -c info = 0 improper input parameters. -c -c info = 1 algorithm estimates that the relative error -c between x and the solution is at most tol. -c -c info = 2 number of calls to fcn has reached or exceeded -c 200*(n+1). -c -c info = 3 tol is too small. no further improvement in -c the approximate solution x is possible. -c -c info = 4 iteration is not making good progress. -c -c wa is a work array of length lwa. -c -c lwa is a positive integer input variable not less than -c (n*(3*n+13))/2. -c -c subprograms called -c -c user-supplied ...... fcn -c -c minpack-supplied ... hybrd -c -c argonne national laboratory. minpack project. march 1980. -c burton s. garbow, kenneth e. hillstrom, jorge j. more -c -c ********** - integer index,j,lr,maxfev,ml,mode,mu,nfev,nprint - double precision epsfcn,factor,one,xtol,zero - data factor,one,zero /1.0d2,1.0d0,0.0d0/ - info = 0 -c -c check the input parameters for errors. -c - if (n .le. 0 .or. tol .lt. zero .or. lwa .lt. (n*(3*n + 13))/2) - * go to 20 -c -c call hybrd. -c - maxfev = 200*(n + 1) - xtol = tol - ml = n - 1 - mu = n - 1 - epsfcn = zero - mode = 2 - do 10 j = 1, n - wa(j) = one - 10 continue - nprint = 0 - lr = (n*(n + 1))/2 - index = 6*n + lr - call hybrd(fcn,n,x,fvec,xtol,maxfev,ml,mu,epsfcn,wa(1),mode, - * factor,nprint,info,nfev,wa(index+1),n,wa(6*n+1),lr, - * wa(n+1),wa(2*n+1),wa(3*n+1),wa(4*n+1),wa(5*n+1)) - if (info .eq. 5) info = 4 - 20 continue - return -c -c last card of subroutine hybrd1. -c - end diff --git a/src/hybrj.f b/src/hybrj.f deleted file mode 100644 index 3070dad..0000000 --- a/src/hybrj.f +++ /dev/null @@ -1,440 +0,0 @@ - subroutine hybrj(fcn,n,x,fvec,fjac,ldfjac,xtol,maxfev,diag,mode, - * factor,nprint,info,nfev,njev,r,lr,qtf,wa1,wa2, - * wa3,wa4) - integer n,ldfjac,maxfev,mode,nprint,info,nfev,njev,lr - double precision xtol,factor - double precision x(n),fvec(n),fjac(ldfjac,n),diag(n),r(lr), - * qtf(n),wa1(n),wa2(n),wa3(n),wa4(n) -c ********** -c -c subroutine hybrj -c -c the purpose of hybrj is to find a zero of a system of -c n nonlinear functions in n variables by a modification -c of the powell hybrid method. the user must provide a -c subroutine which calculates the functions and the jacobian. -c -c the subroutine statement is -c -c subroutine hybrj(fcn,n,x,fvec,fjac,ldfjac,xtol,maxfev,diag, -c mode,factor,nprint,info,nfev,njev,r,lr,qtf, -c wa1,wa2,wa3,wa4) -c -c where -c -c fcn is the name of the user-supplied subroutine which -c calculates the functions and the jacobian. fcn must -c be declared in an external statement in the user -c calling program, and should be written as follows. -c -c subroutine fcn(n,x,fvec,fjac,ldfjac,iflag) -c integer n,ldfjac,iflag -c double precision x(n),fvec(n),fjac(ldfjac,n) -c ---------- -c if iflag = 1 calculate the functions at x and -c return this vector in fvec. do not alter fjac. -c if iflag = 2 calculate the jacobian at x and -c return this matrix in fjac. do not alter fvec. -c --------- -c return -c end -c -c the value of iflag should not be changed by fcn unless -c the user wants to terminate execution of hybrj. -c in this case set iflag to a negative integer. -c -c n is a positive integer input variable set to the number -c of functions and variables. -c -c x is an array of length n. on input x must contain -c an initial estimate of the solution vector. on output x -c contains the final estimate of the solution vector. -c -c fvec is an output array of length n which contains -c the functions evaluated at the output x. -c -c fjac is an output n by n array which contains the -c orthogonal matrix q produced by the qr factorization -c of the final approximate jacobian. -c -c ldfjac is a positive integer input variable not less than n -c which specifies the leading dimension of the array fjac. -c -c xtol is a nonnegative input variable. termination -c occurs when the relative error between two consecutive -c iterates is at most xtol. -c -c maxfev is a positive integer input variable. termination -c occurs when the number of calls to fcn with iflag = 1 -c has reached maxfev. -c -c diag is an array of length n. if mode = 1 (see -c below), diag is internally set. if mode = 2, diag -c must contain positive entries that serve as -c multiplicative scale factors for the variables. -c -c mode is an integer input variable. if mode = 1, the -c variables will be scaled internally. if mode = 2, -c the scaling is specified by the input diag. other -c values of mode are equivalent to mode = 1. -c -c factor is a positive input variable used in determining the -c initial step bound. this bound is set to the product of -c factor and the euclidean norm of diag*x if nonzero, or else -c to factor itself. in most cases factor should lie in the -c interval (.1,100.). 100. is a generally recommended value. -c -c nprint is an integer input variable that enables controlled -c printing of iterates if it is positive. in this case, -c fcn is called with iflag = 0 at the beginning of the first -c iteration and every nprint iterations thereafter and -c immediately prior to return, with x and fvec available -c for printing. fvec and fjac should not be altered. -c if nprint is not positive, no special calls of fcn -c with iflag = 0 are made. -c -c info is an integer output variable. if the user has -c terminated execution, info is set to the (negative) -c value of iflag. see description of fcn. otherwise, -c info is set as follows. -c -c info = 0 improper input parameters. -c -c info = 1 relative error between two consecutive iterates -c is at most xtol. -c -c info = 2 number of calls to fcn with iflag = 1 has -c reached maxfev. -c -c info = 3 xtol is too small. no further improvement in -c the approximate solution x is possible. -c -c info = 4 iteration is not making good progress, as -c measured by the improvement from the last -c five jacobian evaluations. -c -c info = 5 iteration is not making good progress, as -c measured by the improvement from the last -c ten iterations. -c -c nfev is an integer output variable set to the number of -c calls to fcn with iflag = 1. -c -c njev is an integer output variable set to the number of -c calls to fcn with iflag = 2. -c -c r is an output array of length lr which contains the -c upper triangular matrix produced by the qr factorization -c of the final approximate jacobian, stored rowwise. -c -c lr is a positive integer input variable not less than -c (n*(n+1))/2. -c -c qtf is an output array of length n which contains -c the vector (q transpose)*fvec. -c -c wa1, wa2, wa3, and wa4 are work arrays of length n. -c -c subprograms called -c -c user-supplied ...... fcn -c -c minpack-supplied ... dogleg,dpmpar,enorm, -c qform,qrfac,r1mpyq,r1updt -c -c fortran-supplied ... dabs,dmax1,dmin1,mod -c -c argonne national laboratory. minpack project. march 1980. -c burton s. garbow, kenneth e. hillstrom, jorge j. more -c -c ********** - integer i,iflag,iter,j,jm1,l,ncfail,ncsuc,nslow1,nslow2 - integer iwa(1) - logical jeval,sing - double precision actred,delta,epsmch,fnorm,fnorm1,one,pnorm, - * prered,p1,p5,p001,p0001,ratio,sum,temp,xnorm, - * zero - double precision dpmpar,enorm - data one,p1,p5,p001,p0001,zero - * /1.0d0,1.0d-1,5.0d-1,1.0d-3,1.0d-4,0.0d0/ -c -c epsmch is the machine precision. -c - epsmch = dpmpar(1) -c - info = 0 - iflag = 0 - nfev = 0 - njev = 0 -c -c check the input parameters for errors. -c - if (n .le. 0 .or. ldfjac .lt. n .or. xtol .lt. zero - * .or. maxfev .le. 0 .or. factor .le. zero - * .or. lr .lt. (n*(n + 1))/2) go to 300 - if (mode .ne. 2) go to 20 - do 10 j = 1, n - if (diag(j) .le. zero) go to 300 - 10 continue - 20 continue -c -c evaluate the function at the starting point -c and calculate its norm. -c - iflag = 1 - call fcn(n,x,fvec,fjac,ldfjac,iflag) - nfev = 1 - if (iflag .lt. 0) go to 300 - fnorm = enorm(n,fvec) -c -c initialize iteration counter and monitors. -c - iter = 1 - ncsuc = 0 - ncfail = 0 - nslow1 = 0 - nslow2 = 0 -c -c beginning of the outer loop. -c - 30 continue - jeval = .true. -c -c calculate the jacobian matrix. -c - iflag = 2 - call fcn(n,x,fvec,fjac,ldfjac,iflag) - njev = njev + 1 - if (iflag .lt. 0) go to 300 -c -c compute the qr factorization of the jacobian. -c - call qrfac(n,n,fjac,ldfjac,.false.,iwa,1,wa1,wa2,wa3) -c -c on the first iteration and if mode is 1, scale according -c to the norms of the columns of the initial jacobian. -c - if (iter .ne. 1) go to 70 - if (mode .eq. 2) go to 50 - do 40 j = 1, n - diag(j) = wa2(j) - if (wa2(j) .eq. zero) diag(j) = one - 40 continue - 50 continue -c -c on the first iteration, calculate the norm of the scaled x -c and initialize the step bound delta. -c - do 60 j = 1, n - wa3(j) = diag(j)*x(j) - 60 continue - xnorm = enorm(n,wa3) - delta = factor*xnorm - if (delta .eq. zero) delta = factor - 70 continue -c -c form (q transpose)*fvec and store in qtf. -c - do 80 i = 1, n - qtf(i) = fvec(i) - 80 continue - do 120 j = 1, n - if (fjac(j,j) .eq. zero) go to 110 - sum = zero - do 90 i = j, n - sum = sum + fjac(i,j)*qtf(i) - 90 continue - temp = -sum/fjac(j,j) - do 100 i = j, n - qtf(i) = qtf(i) + fjac(i,j)*temp - 100 continue - 110 continue - 120 continue -c -c copy the triangular factor of the qr factorization into r. -c - sing = .false. - do 150 j = 1, n - l = j - jm1 = j - 1 - if (jm1 .lt. 1) go to 140 - do 130 i = 1, jm1 - r(l) = fjac(i,j) - l = l + n - i - 130 continue - 140 continue - r(l) = wa1(j) - if (wa1(j) .eq. zero) sing = .true. - 150 continue -c -c accumulate the orthogonal factor in fjac. -c - call qform(n,n,fjac,ldfjac,wa1) -c -c rescale if necessary. -c - if (mode .eq. 2) go to 170 - do 160 j = 1, n - diag(j) = dmax1(diag(j),wa2(j)) - 160 continue - 170 continue -c -c beginning of the inner loop. -c - 180 continue -c -c if requested, call fcn to enable printing of iterates. -c - if (nprint .le. 0) go to 190 - iflag = 0 - if (mod(iter-1,nprint) .eq. 0) - * call fcn(n,x,fvec,fjac,ldfjac,iflag) - if (iflag .lt. 0) go to 300 - 190 continue -c -c determine the direction p. -c - call dogleg(n,r,lr,diag,qtf,delta,wa1,wa2,wa3) -c -c store the direction p and x + p. calculate the norm of p. -c - do 200 j = 1, n - wa1(j) = -wa1(j) - wa2(j) = x(j) + wa1(j) - wa3(j) = diag(j)*wa1(j) - 200 continue - pnorm = enorm(n,wa3) -c -c on the first iteration, adjust the initial step bound. -c - if (iter .eq. 1) delta = dmin1(delta,pnorm) -c -c evaluate the function at x + p and calculate its norm. -c - iflag = 1 - call fcn(n,wa2,wa4,fjac,ldfjac,iflag) - nfev = nfev + 1 - if (iflag .lt. 0) go to 300 - fnorm1 = enorm(n,wa4) -c -c compute the scaled actual reduction. -c - actred = -one - if (fnorm1 .lt. fnorm) actred = one - (fnorm1/fnorm)**2 -c -c compute the scaled predicted reduction. -c - l = 1 - do 220 i = 1, n - sum = zero - do 210 j = i, n - sum = sum + r(l)*wa1(j) - l = l + 1 - 210 continue - wa3(i) = qtf(i) + sum - 220 continue - temp = enorm(n,wa3) - prered = zero - if (temp .lt. fnorm) prered = one - (temp/fnorm)**2 -c -c compute the ratio of the actual to the predicted -c reduction. -c - ratio = zero - if (prered .gt. zero) ratio = actred/prered -c -c update the step bound. -c - if (ratio .ge. p1) go to 230 - ncsuc = 0 - ncfail = ncfail + 1 - delta = p5*delta - go to 240 - 230 continue - ncfail = 0 - ncsuc = ncsuc + 1 - if (ratio .ge. p5 .or. ncsuc .gt. 1) - * delta = dmax1(delta,pnorm/p5) - if (dabs(ratio-one) .le. p1) delta = pnorm/p5 - 240 continue -c -c test for successful iteration. -c - if (ratio .lt. p0001) go to 260 -c -c successful iteration. update x, fvec, and their norms. -c - do 250 j = 1, n - x(j) = wa2(j) - wa2(j) = diag(j)*x(j) - fvec(j) = wa4(j) - 250 continue - xnorm = enorm(n,wa2) - fnorm = fnorm1 - iter = iter + 1 - 260 continue -c -c determine the progress of the iteration. -c - nslow1 = nslow1 + 1 - if (actred .ge. p001) nslow1 = 0 - if (jeval) nslow2 = nslow2 + 1 - if (actred .ge. p1) nslow2 = 0 -c -c test for convergence. -c - if (delta .le. xtol*xnorm .or. fnorm .eq. zero) info = 1 - if (info .ne. 0) go to 300 -c -c tests for termination and stringent tolerances. -c - if (nfev .ge. maxfev) info = 2 - if (p1*dmax1(p1*delta,pnorm) .le. epsmch*xnorm) info = 3 - if (nslow2 .eq. 5) info = 4 - if (nslow1 .eq. 10) info = 5 - if (info .ne. 0) go to 300 -c -c criterion for recalculating jacobian. -c - if (ncfail .eq. 2) go to 290 -c -c calculate the rank one modification to the jacobian -c and update qtf if necessary. -c - do 280 j = 1, n - sum = zero - do 270 i = 1, n - sum = sum + fjac(i,j)*wa4(i) - 270 continue - wa2(j) = (sum - wa3(j))/pnorm - wa1(j) = diag(j)*((diag(j)*wa1(j))/pnorm) - if (ratio .ge. p0001) qtf(j) = sum - 280 continue -c -c compute the qr factorization of the updated jacobian. -c - call r1updt(n,n,r,lr,wa1,wa2,wa3,sing) - call r1mpyq(n,n,fjac,ldfjac,wa2,wa3) - call r1mpyq(1,n,qtf,1,wa2,wa3) -c -c end of the inner loop. -c - jeval = .false. - go to 180 - 290 continue -c -c end of the outer loop. -c - go to 30 - 300 continue -c -c termination, either normal or user imposed. -c - if (iflag .lt. 0) info = iflag - iflag = 0 - if (nprint .gt. 0) call fcn(n,x,fvec,fjac,ldfjac,iflag) - return -c -c last card of subroutine hybrj. -c - end diff --git a/src/hybrj1.f b/src/hybrj1.f deleted file mode 100644 index 9f51c49..0000000 --- a/src/hybrj1.f +++ /dev/null @@ -1,127 +0,0 @@ - subroutine hybrj1(fcn,n,x,fvec,fjac,ldfjac,tol,info,wa,lwa) - integer n,ldfjac,info,lwa - double precision tol - double precision x(n),fvec(n),fjac(ldfjac,n),wa(lwa) - external fcn -c ********** -c -c subroutine hybrj1 -c -c the purpose of hybrj1 is to find a zero of a system of -c n nonlinear functions in n variables by a modification -c of the powell hybrid method. this is done by using the -c more general nonlinear equation solver hybrj. the user -c must provide a subroutine which calculates the functions -c and the jacobian. -c -c the subroutine statement is -c -c subroutine hybrj1(fcn,n,x,fvec,fjac,ldfjac,tol,info,wa,lwa) -c -c where -c -c fcn is the name of the user-supplied subroutine which -c calculates the functions and the jacobian. fcn must -c be declared in an external statement in the user -c calling program, and should be written as follows. -c -c subroutine fcn(n,x,fvec,fjac,ldfjac,iflag) -c integer n,ldfjac,iflag -c double precision x(n),fvec(n),fjac(ldfjac,n) -c ---------- -c if iflag = 1 calculate the functions at x and -c return this vector in fvec. do not alter fjac. -c if iflag = 2 calculate the jacobian at x and -c return this matrix in fjac. do not alter fvec. -c --------- -c return -c end -c -c the value of iflag should not be changed by fcn unless -c the user wants to terminate execution of hybrj1. -c in this case set iflag to a negative integer. -c -c n is a positive integer input variable set to the number -c of functions and variables. -c -c x is an array of length n. on input x must contain -c an initial estimate of the solution vector. on output x -c contains the final estimate of the solution vector. -c -c fvec is an output array of length n which contains -c the functions evaluated at the output x. -c -c fjac is an output n by n array which contains the -c orthogonal matrix q produced by the qr factorization -c of the final approximate jacobian. -c -c ldfjac is a positive integer input variable not less than n -c which specifies the leading dimension of the array fjac. -c -c tol is a nonnegative input variable. termination occurs -c when the algorithm estimates that the relative error -c between x and the solution is at most tol. -c -c info is an integer output variable. if the user has -c terminated execution, info is set to the (negative) -c value of iflag. see description of fcn. otherwise, -c info is set as follows. -c -c info = 0 improper input parameters. -c -c info = 1 algorithm estimates that the relative error -c between x and the solution is at most tol. -c -c info = 2 number of calls to fcn with iflag = 1 has -c reached 100*(n+1). -c -c info = 3 tol is too small. no further improvement in -c the approximate solution x is possible. -c -c info = 4 iteration is not making good progress. -c -c wa is a work array of length lwa. -c -c lwa is a positive integer input variable not less than -c (n*(n+13))/2. -c -c subprograms called -c -c user-supplied ...... fcn -c -c minpack-supplied ... hybrj -c -c argonne national laboratory. minpack project. march 1980. -c burton s. garbow, kenneth e. hillstrom, jorge j. more -c -c ********** - integer j,lr,maxfev,mode,nfev,njev,nprint - double precision factor,one,xtol,zero - data factor,one,zero /1.0d2,1.0d0,0.0d0/ - info = 0 -c -c check the input parameters for errors. -c - if (n .le. 0 .or. ldfjac .lt. n .or. tol .lt. zero - * .or. lwa .lt. (n*(n + 13))/2) go to 20 -c -c call hybrj. -c - maxfev = 100*(n + 1) - xtol = tol - mode = 2 - do 10 j = 1, n - wa(j) = one - 10 continue - nprint = 0 - lr = (n*(n + 1))/2 - call hybrj(fcn,n,x,fvec,fjac,ldfjac,xtol,maxfev,wa(1),mode, - * factor,nprint,info,nfev,njev,wa(6*n+1),lr,wa(n+1), - * wa(2*n+1),wa(3*n+1),wa(4*n+1),wa(5*n+1)) - if (info .eq. 5) info = 4 - 20 continue - return -c -c last card of subroutine hybrj1. -c - end diff --git a/src/lhesfcn.f b/src/lhesfcn.f deleted file mode 100644 index 146e272..0000000 --- a/src/lhesfcn.f +++ /dev/null @@ -1,663 +0,0 @@ - subroutine hesfcn(n,x,h,ldh,nprob) - integer n,ldh,nprob - double precision x(n),h(ldh) -c ********** -c -c subroutine hesfcn -c -c this subroutine defines the hessian matrices of eighteen -c nonlinear unconstrained minimization problems. the problem -c dimensions are as described in the prologue comments of objfcn. -c the upper triangle of the (symmetric) hessian matrix is -c computed columnwise and stored as a one-dimensional array. -c -c the subroutine statement is -c -c subroutine hesfcn(n,x,h,ldh,nprob) -c -c where -c -c n is a positive integer input variable. -c -c x is an input array of length n. -c -c h is an array of length ldh. on output h contains the hessian -c matrix of the nprob objective function evaluated at x. -c -c ldh is a positive integer input variable not less than -c (n*(n+1))/2 which specifies the dimension of the array h. -c -c nprob is a positive integer input variable which defines the -c number of the problem. nprob must not exceed 18. -c -c subprograms called -c -c fortran-supplied ... dabs,datan,dcos,dexp,dlog,dsign,dsin, -c dsqrt -c -c argonne national laboratory. minpack project. march 1980. -c burton s. garbow, kenneth e. hillstrom, jorge j. more -c -c ********** - integer i,iev,ivar,j,k,n2 - integer ij,ijm1,ijp1,ijp2,ijp3,ki,kip1,kj,kjp1,ntr - double precision ap,arg,cp0001,cp1,cp25,cp5,c1p5,c2p25, - * c2p625,c3p5,c19p8,c25,c29,c100,c200,c10000,d1, - * d2,eight,fifty,five,four,one,r,s1,s2,s3,t,t1, - * t2,t3,ten,th,three,tpi,twenty,two,zero - double precision d3,r1,r2,r3,u1,u2,v,v1,v2 - double precision fvec(50),fvec1(50),y(15) - double precision dfloat - double precision six,xnine,twelve,c120,c200p2,c202,c220p2,c360, - * c400,c1200 - data six,xnine,twelve,c120,c200p2,c202,c220p2,c360,c400,c1200 - * /6.0d0,9.0d0,1.2d1,1.2d2,2.002d2,2.02d2,2.202d2,3.6d2, - * 4.0d2,1.2d3/ - data zero,one,two,three,four,five,eight,ten,twenty,fifty - * /0.0d0,1.0d0,2.0d0,3.0d0,4.0d0,5.0d0,8.0d0,1.0d1,2.0d1, - * 5.0d1/ - data cp0001,cp1,cp25,cp5,c1p5,c2p25,c2p625,c3p5,c19p8,c25,c29, - * c100,c200,c10000 - * /1.0d-4,1.0d-1,2.5d-1,5.0d-1,1.5d0,2.25d0,2.625d0,3.5d0, - * 1.98d1,2.5d1,2.9d1,1.0d2,2.0d2,1.0d4/ - data ap /1.0d-5/ - data y(1),y(2),y(3),y(4),y(5),y(6),y(7),y(8),y(9),y(10),y(11), - * y(12),y(13),y(14),y(15) - * /9.0d-4,4.4d-3,1.75d-2,5.4d-2,1.295d-1,2.42d-1,3.521d-1, - * 3.989d-1,3.521d-1,2.42d-1,1.295d-1,5.4d-2,1.75d-2,4.4d-3, - * 9.0d-4/ - dfloat(ivar) = ivar -c -c hessian routine selector. -c - go to (10,20,60,100,110,170,210,290,330,380,390,450,490,580,620, - * 660,670,680), nprob -c -c helical valley function. -c - 10 continue - tpi = eight*datan(one) - th = dsign(cp25,x(2)) - if (x(1) .gt. zero) th = datan(x(2)/x(1))/tpi - if (x(1) .lt. zero) th = datan(x(2)/x(1))/tpi + cp5 - arg = x(1)**2 + x(2)**2 - r = dsqrt(arg) - t = x(3) - ten*th - s1 = ten*t/(tpi*arg) - t1 = ten/tpi - t2 = t1/arg - t3 = (x(1)/r - t1*t2*x(1) - two*x(2)*s1)/arg - h(1) = c200 - * *(one - x(2)/arg*(x(2)/r - t1*t2*x(2) + two*x(1)*s1)) - h(2) = c200*(s1 + x(2)*t3) - h(3) = c200*(one - x(1)*t3) - h(4) = c200*t2*x(2) - h(5) = -c200*t2*x(1) - h(6) = c202 - go to 800 -c -c biggs exp6 function. -c - 20 continue - do 40 ij = 1, 21 - h(ij) = zero - 40 continue - do 50 i = 1, 13 - d1 = dfloat(i)/ten - d2 = dexp(-d1) - five*dexp(-ten*d1) + three*dexp(-four*d1) - s1 = dexp(-d1*x(1)) - s2 = dexp(-d1*x(2)) - s3 = dexp(-d1*x(5)) - t = x(3)*s1 - x(4)*s2 + x(6)*s3 - d2 - th = d1*t - r1 = d1*s1 - r2 = d1*s2 - r3 = d1*s3 - h(1) = h(1) + r1*(th + x(3)*r1) - h(2) = h(2) - r1*r2 - h(3) = h(3) - r2*(th - x(4)*r2) - h(4) = h(4) - s1*(th + x(3)*r1) - h(6) = h(6) + s1**2 - h(7) = h(7) + r1*s2 - h(8) = h(8) + s2*(th - x(4)*r2) - h(9) = h(9) - s1*s2 - h(10) = h(10) + s2**2 - h(11) = h(11) + r1*r3 - h(12) = h(12) - r2*r3 - h(15) = h(15) + r3*(th + x(6)*r3) - h(16) = h(16) - r1*s3 - h(17) = h(17) + r2*s3 - h(18) = h(18) + s1*s3 - h(19) = h(19) - s2*s3 - h(20) = h(20) - s3*(th + x(6)*r3) - h(21) = h(21) + s3**2 - 50 continue - h(1) = two*x(3)*h(1) - h(2) = two*x(3)*x(4)*h(2) - h(3) = two*x(4)*h(3) - h(4) = two*h(4) - h(5) = two*x(4)*h(7) - h(6) = two*h(6) - h(7) = two*x(3)*h(7) - h(8) = two*h(8) - h(9) = two*h(9) - h(10) = two*h(10) - h(11) = two*x(3)*x(6)*h(11) - h(12) = two*x(4)*x(6)*h(12) - h(13) = two*x(6)*h(16) - h(14) = two*x(6)*h(17) - h(15) = two*x(6)*h(15) - h(16) = two*x(3)*h(16) - h(17) = two*x(4)*h(17) - h(18) = two*h(18) - h(19) = two*h(19) - h(20) = two*h(20) - h(21) = two*h(21) - go to 800 -c -c gaussian function. -c - 60 continue - do 80 ij = 1, 6 - h(ij) = zero - 80 continue - do 90 i = 1, 15 - d1 = cp5*dfloat(i-1) - d2 = c3p5 - d1 - x(3) - arg = -cp5*x(2)*d2**2 - r = dexp(arg) - t = x(1)*r - y(i) - s1 = r*t - s2 = d2*s1 - t1 = s2 + d2*x(1)*r**2 - t2 = d2*t1 - h(1) = h(1) + r**2 - h(2) = h(2) - t2 - h(3) = h(3) + d2**2*t2 - h(4) = h(4) + t1 - h(5) = h(5) + two*s2 - d2*x(2)*t2 - h(6) = h(6) + x(2)*t2 - s1 - 90 continue - h(1) = two*h(1) - h(2) = h(2) - h(3) = cp5*x(1)*h(3) - h(4) = two*x(2)*h(4) - h(5) = x(1)*h(5) - h(6) = two*x(1)*x(2)*h(6) - go to 800 -c -c powell badly scaled function. -c - 100 continue - t1 = c10000*x(1)*x(2) - one - s1 = dexp(-x(1)) - s2 = dexp(-x(2)) - t2 = s1 + s2 - one - cp0001 - h(1) = two*((c10000*x(2))**2 + s1*(s1 + t2)) - h(2) = two*(c10000*(one + two*t1) + s1*s2) - h(3) = two*((c10000*x(1))**2 + s2*(s2 + t2)) - go to 800 -c -c box 3-dimensional function. -c - 110 continue - do 130 ij = 1, 6 - h(ij) = zero - 130 continue - do 140 i = 1, 10 - d1 = dfloat(i) - d2 = d1/ten - s1 = dexp(-d2*x(1)) - s2 = dexp(-d2*x(2)) - s3 = dexp(-d2) - dexp(-d1) - t = s1 - s2 - s3*x(3) - th = d2*t - r1 = d2*s1 - r2 = d2*s2 - h(1) = h(1) + r1*(th + r1) - h(2) = h(2) - r1*r2 - h(3) = h(3) - r2*(th - r2) - h(4) = h(4) + r1*s3 - h(5) = h(5) - r2*s3 - h(6) = h(6) + s3**2 - 140 continue - do 160 ij = 1, 6 - h(ij) = two*h(ij) - 160 continue - go to 800 -c -c variably dimensioned function. -c - 170 continue - t1 = zero - do 180 j = 1, n - t1 = t1 + dfloat(j)*(x(j) - one) - 180 continue -c t = t1*(one + two*t1**2) - t2 = two + twelve*t1**2 - ij = 0 - do 200 j = 1, n - do 190 i = 1, j - ij = ij + 1 - h(ij) = dfloat(i*j)*t2 - 190 continue - h(ij) = h(ij) + two - 200 continue - go to 800 -c -c watson function. -c - 210 continue - ntr = (n*(n + 1))/2 - do 230 kj = 1, ntr - h(kj) = zero - 230 continue - do 280 i = 1, 29 - d1 = dfloat(i)/c29 - s1 = zero - d2 = one - do 240 j = 2, n - s1 = s1 + dfloat(j-1)*d2*x(j) - d2 = d1*d2 - 240 continue - s2 = zero - d2 = one - do 250 j = 1, n - s2 = s2 + d2*x(j) - d2 = d1*d2 - 250 continue - t = s1 - s2**2 - one - s3 = two*d1*s2 - d2 = two/d1 - th = two*d1**2*t - kj = 0 - do 270 j = 1, n - v = dfloat(j-1) - s3 - d3 = one/d1 - do 260 k = 1, j - kj = kj + 1 - h(kj) = h(kj) + d2*d3*(v*(dfloat(k-1) - s3) - th) - d3 = d1*d3 - 260 continue - d2 = d1*d2 - 270 continue - 280 continue - t1 = x(2) - x(1)**2 - one - h(1) = h(1) + eight*x(1)**2 + two - four*t1 - h(2) = h(2) - four*x(1) - h(3) = h(3) + two - go to 800 -c -c penalty function i. -c - 290 continue - t1 = -cp25 - do 300 j = 1, n - t1 = t1 + x(j)**2 - 300 continue - d1 = two*ap - th = four*t1 - ij = 0 - do 320 j = 1, n - t2 = eight*x(j) - do 310 i = 1, j - ij = ij + 1 - h(ij) = x(i)*t2 - 310 continue - h(ij) = h(ij) + d1 + th - 320 continue - go to 800 -c -c penalty function ii. -c - 330 continue - t1 = -one - do 340 j = 1, n - t1 = t1 + dfloat(n-j+1)*x(j)**2 - 340 continue - d1 = dexp(cp1) - d2 = one - th = four*t1 - ij = 0 - do 370 j = 1, n - t2 = eight*dfloat(n-j+1)*x(j) - do 350 i = 1, j - ij = ij + 1 - h(ij) = dfloat(n-i+1)*x(i)*t2 - 350 continue - h(ij) = h(ij) + dfloat(n-j+1)*th - s1 = dexp(x(j)/ten) - if (j .eq. 1) go to 360 - s3 = s1 + s2 - d2*(d1 + one) - h(ij) = h(ij) + ap*s1*(s3 + three*s1 - one/d1)/fifty - h(ij-1) = h(ij-1) + ap*s1*s2/fifty - h(ijm1) = h(ijm1) + ap*s2*(s2 + s3)/fifty - 360 continue - s2 = s1 - d2 = d1*d2 - ijm1 = ij - 370 continue - h(1) = h(1) + two - go to 800 -c -c brown badly scaled function. -c - 380 continue -c t1 = x(1) - c1pd6 -c t2 = x(2) - c2pdm6 - t3 = x(1)*x(2) - two - h(1) = two*(one + x(2)**2) - h(2) = four*(one + t3) - h(3) = two*(one + x(1)**2) - go to 800 -c -c brown and dennis function. -c - 390 continue - do 410 ij = 1, 10 - h(ij) = zero - 410 continue - do 420 i = 1, 20 - d1 = dfloat(i)/five - d2 = dsin(d1) - t1 = x(1) + d1*x(2) - dexp(d1) - t2 = x(3) + d2*x(4) - dcos(d1) - t = t1**2 + t2**2 -c s1 = t1*t -c s2 = t2*t - s3 = two*t1*t2 - r1 = t + two*t1**2 - r2 = t + two*t2**2 - h(1) = h(1) + r1 - h(2) = h(2) + d1*r1 - h(3) = h(3) + d1**2*r1 - h(4) = h(4) + s3 - h(5) = h(5) + d1*s3 - h(6) = h(6) + r2 - h(7) = h(7) + d2*s3 - h(8) = h(8) + d1*d2*s3 - h(9) = h(9) + d2*r2 - h(10) = h(10) + d2**2*r2 - 420 continue - do 440 ij = 1, 10 - h(ij) = four*h(ij) - 440 continue - go to 800 -c -c gulf research and development function. -c - 450 continue - do 470 ij = 1, 6 - h(ij) = zero - 470 continue - d1 = two/three - do 480 i = 1, 99 - arg = dfloat(i)/c100 - r = (-fifty*dlog(arg))**d1 + c25 - x(2) - t1 = dabs(r)**x(3)/x(1) - t2 = dexp(-t1) - t = t2 - arg - s1 = t1*t2*t - s2 = t1*(s1 + t2*(t1*t2 - t)) - r1 = dlog(dabs(r)) - r2 = r1*s2 - h(1) = h(1) + s2 - s1 - h(2) = h(2) + s2/r - h(3) = h(3) + (s1 + x(3)*s2)/r**2 - h(4) = h(4) - r2 - h(5) = h(5) + (s1 - x(3)*r2)/r - h(6) = h(6) + r1*r2 - 480 continue - h(1) = two*h(1)/x(1)**2 - h(2) = two*x(3)*h(2)/x(1) - h(3) = two*x(3)*h(3) - h(4) = two*h(4)/x(1) - h(5) = two*h(5) - h(6) = two*h(6) - go to 800 -c -c trigonometric function. -c - 490 continue - u2 = dcos(x(n)) - s1 = u2 - if (n .eq. 1) go to 510 - u1 = dcos(x(n-1)) - s1 = s1 + u1 - if (n .eq. 2) go to 510 - n2 = n - 2 - ntr = (n2*(n - 1))/2 - kj = ntr - do 500 j = 1, n2 - kj = kj + 1 - h(kj) = dcos(x(j)) - s1 = s1 + h(kj) - 500 continue - 510 continue - v2 = dsin(x(n)) - s2 = dfloat(2*n) - v2 - s1 - dfloat(n)*u2 - r2 = dfloat(2*n)*v2 - u2 - ij = 0 - if (n .eq. 1) go to 570 - v1 = dsin(x(n-1)) - s2 = s2 + dfloat(2*n-1) - v1 - s1 - dfloat(n-1)*u1 - r1 = dfloat(2*n-1)*v1 - u1 - if (n .eq. 2) go to 560 - kj = ntr - do 520 j = 1, n2 - kjp1 = kj + n - kj = kj + 1 - h(kjp1) = dsin(x(j)) - t = dfloat(n+j) - h(kjp1) - s1 - dfloat(j)*h(kj) - s2 = s2 + t - 520 continue - kj = ntr - do 540 j = 1, n2 - kjp1 = kj + n - kj = kj + 1 - v = dfloat(j)*h(kj) + h(kjp1) - t = dfloat(n+j) - s1 - v - t1 = dfloat(n+j)*h(kjp1) - h(kj) - ki = ntr - do 530 i = 1, j - ij = ij + 1 - kip1 = ki + n - ki = ki + 1 - th = dfloat(i)*h(kip1) - h(ki) - h(ij) = two*(h(kip1)*t1 + h(kjp1)*th) - 530 continue - h(ij) = h(ij) + two*(h(kj)*s2 + v*t + th**2) - 540 continue - do 550 i = 1, n2 - ijp1 = ij + n - ij = ij + 1 - th = dfloat(i)*h(ijp1) - h(ij) - h(ij) = two*(h(ijp1)*r1 + v1*th) - h(ijp1) = two*(h(ijp1)*r2 + v2*th) - 550 continue - 560 continue - v = dfloat(n-1)*u1 + v1 - t = dfloat(2*n-1) - s1 - v - th = dfloat(n-1)*v1 - u1 - ijp1 = ij + n - ij = ij + 1 - h(ij) = two*(v1*(r1 + th) + u1*s2 + v*t + th**2) - h(ijp1) = two*(v1*r2 + v2*th) - 570 continue - v = dfloat(n)*u2 + v2 - t = dfloat(2*n) - s1 - v - th = dfloat(n)*v2 - u2 - ijp1 = ij + n - h(ijp1) = two*(v2*(r2 + th) + u2*s2 + v*t + th**2) - go to 800 -c -c extended rosenbrock function. -c - 580 continue - ntr = (n*(n + 1))/2 - do 600 ij = 1, ntr - h(ij) = zero - 600 continue - ijp1 = 0 - do 610 j = 1, n, 2 -c t1 = one - x(j) - ij = ijp1 + j - ijp1 = ij + j + 1 - h(ij) = c1200*x(j)**2 - c400*x(j+1) + two - h(ijp1-1) = -c400*x(j) - h(ijp1) = c200 - 610 continue - go to 800 -c -c extended powell function. -c - 620 continue - ntr = (n*(n + 1))/2 - do 640 ij = 1, ntr - h(ij) = zero - 640 continue - ijp3 = 0 - do 650 j = 1, n, 4 -c t = x(j) + ten*x(j+1) -c t1 = x(j+2) - x(j+3) -c s1 = five*t1 - t2 = x(j+1) - two*x(j+2) -c s2 = four*t2**3 - t3 = x(j) - x(j+3) -c s3 = twenty*t3**3 - r2 = twelve*t2**2 - r3 = c120*t3**2 - ij = ijp3 + j - ijp1 = ij + j + 1 - ijp2 = ijp1 + j + 2 - ijp3 = ijp2 + j + 3 - h(ij) = two + r3 - h(ijp1-1) = twenty - h(ijp1) = c200 + r2 - h(ijp2-1) = -two*r2 - h(ijp2) = ten + four*r2 - h(ijp3-3) = -r3 - h(ijp3-1) = -ten - h(ijp3) = ten + r3 - 650 continue - go to 800 -c -c beale function. -c - 660 continue - s1 = one - x(2) - t1 = c1p5 - x(1)*s1 - s2 = one - x(2)**2 - t2 = c2p25 - x(1)*s2 - s3 = one - x(2)**3 - t3 = c2p625 - x(1)*s3 - h(1) = two*(s1**2 + s2**2 + s3**2) - h(2) = two - * *(t1 + x(2)*(two*t2 + three*x(2)*t3) - * - x(1)*(s1 + x(2)*(two*s2 + three*x(2)*s3))) - h(3) = two*x(1) - * *(x(1) + two*t2 - * + x(2)*(six*t3 + x(1)*x(2)*(four + xnine*x(2)**2))) - go to 800 -c -c wood function. -c - 670 continue - s1 = x(2) - x(1)**2 -c s2 = one - x(1) -c s3 = x(2) - one - t1 = x(4) - x(3)**2 -c t2 = one - x(3) -c t3 = x(4) - one - h(1) = c400*(two*x(1)**2 - s1) + two - h(2) = -c400*x(1) - h(3) = c220p2 - h(4) = zero - h(5) = zero - h(6) = c360*(two*x(3)**2 - t1) + two - h(7) = zero - h(8) = c19p8 - h(9) = -c360*x(3) - h(10) = c200p2 - go to 800 -c -c chebyquad function. -c - 680 continue - do 690 i = 1, n - fvec(i) = zero - 690 continue - do 710 j = 1, n - t1 = one - t2 = two*x(j) - one - t = two*t2 - do 700 i = 1, n - fvec(i) = fvec(i) + t2 - th = t*t2 - t1 - t1 = t2 - t2 = th - 700 continue - 710 continue - d1 = one/dfloat(n) - iev = -1 - do 720 i = 1, n - fvec(i) = d1*fvec(i) - if (iev .gt. 0) fvec(i) = fvec(i) + one/(dfloat(i)**2 - one) - iev = -iev - 720 continue - kj = 0 - do 770 j = 1, n - do 730 k = 1, j - kj = kj + 1 - h(kj) = zero - 730 continue - t1 = one - t2 = two*x(j) - one - t = two*t2 - s1 = zero - s2 = two - r1 = zero - r2 = zero - do 740 i = 1, n - h(kj) = h(kj) + fvec(i)*r2 - th = eight*s2 + t*r2 - r1 - r1 = r2 - r2 = th - fvec1(i) = d1*s2 - th = four*t2 + t*s2 - s1 - s1 = s2 - s2 = th - th = t*t2 - t1 - t1 = t2 - t2 = th - 740 continue - kj = kj - j - do 760 k = 1, j - kj = kj + 1 - v1 = one - v2 = two*x(k) - one - v = two*v2 - u1 = zero - u2 = two - do 750 i = 1, n - h(kj) = h(kj) + fvec1(i)*u2 - th = four*v2 + v*u2 - u1 - u1 = u2 - u2 = th - th = v*v2 - v1 - v1 = v2 - v2 = th - 750 continue - 760 continue - 770 continue - d2 = two*d1 - ntr = (n*(n + 1))/2 - do 790 kj = 1, ntr - h(kj) = d2*h(kj) - 790 continue - 800 continue - return -c -c last card of subroutine hesfcn. -c - end diff --git a/src/lmder.f b/src/lmder.f deleted file mode 100644 index 8797d8b..0000000 --- a/src/lmder.f +++ /dev/null @@ -1,452 +0,0 @@ - subroutine lmder(fcn,m,n,x,fvec,fjac,ldfjac,ftol,xtol,gtol, - * maxfev,diag,mode,factor,nprint,info,nfev,njev, - * ipvt,qtf,wa1,wa2,wa3,wa4) - integer m,n,ldfjac,maxfev,mode,nprint,info,nfev,njev - integer ipvt(n) - double precision ftol,xtol,gtol,factor - double precision x(n),fvec(m),fjac(ldfjac,n),diag(n),qtf(n), - * wa1(n),wa2(n),wa3(n),wa4(m) -c ********** -c -c subroutine lmder -c -c the purpose of lmder is to minimize the sum of the squares of -c m nonlinear functions in n variables by a modification of -c the levenberg-marquardt algorithm. the user must provide a -c subroutine which calculates the functions and the jacobian. -c -c the subroutine statement is -c -c subroutine lmder(fcn,m,n,x,fvec,fjac,ldfjac,ftol,xtol,gtol, -c maxfev,diag,mode,factor,nprint,info,nfev, -c njev,ipvt,qtf,wa1,wa2,wa3,wa4) -c -c where -c -c fcn is the name of the user-supplied subroutine which -c calculates the functions and the jacobian. fcn must -c be declared in an external statement in the user -c calling program, and should be written as follows. -c -c subroutine fcn(m,n,x,fvec,fjac,ldfjac,iflag) -c integer m,n,ldfjac,iflag -c double precision x(n),fvec(m),fjac(ldfjac,n) -c ---------- -c if iflag = 1 calculate the functions at x and -c return this vector in fvec. do not alter fjac. -c if iflag = 2 calculate the jacobian at x and -c return this matrix in fjac. do not alter fvec. -c ---------- -c return -c end -c -c the value of iflag should not be changed by fcn unless -c the user wants to terminate execution of lmder. -c in this case set iflag to a negative integer. -c -c m is a positive integer input variable set to the number -c of functions. -c -c n is a positive integer input variable set to the number -c of variables. n must not exceed m. -c -c x is an array of length n. on input x must contain -c an initial estimate of the solution vector. on output x -c contains the final estimate of the solution vector. -c -c fvec is an output array of length m which contains -c the functions evaluated at the output x. -c -c fjac is an output m by n array. the upper n by n submatrix -c of fjac contains an upper triangular matrix r with -c diagonal elements of nonincreasing magnitude such that -c -c t t t -c p *(jac *jac)*p = r *r, -c -c where p is a permutation matrix and jac is the final -c calculated jacobian. column j of p is column ipvt(j) -c (see below) of the identity matrix. the lower trapezoidal -c part of fjac contains information generated during -c the computation of r. -c -c ldfjac is a positive integer input variable not less than m -c which specifies the leading dimension of the array fjac. -c -c ftol is a nonnegative input variable. termination -c occurs when both the actual and predicted relative -c reductions in the sum of squares are at most ftol. -c therefore, ftol measures the relative error desired -c in the sum of squares. -c -c xtol is a nonnegative input variable. termination -c occurs when the relative error between two consecutive -c iterates is at most xtol. therefore, xtol measures the -c relative error desired in the approximate solution. -c -c gtol is a nonnegative input variable. termination -c occurs when the cosine of the angle between fvec and -c any column of the jacobian is at most gtol in absolute -c value. therefore, gtol measures the orthogonality -c desired between the function vector and the columns -c of the jacobian. -c -c maxfev is a positive integer input variable. termination -c occurs when the number of calls to fcn with iflag = 1 -c has reached maxfev. -c -c diag is an array of length n. if mode = 1 (see -c below), diag is internally set. if mode = 2, diag -c must contain positive entries that serve as -c multiplicative scale factors for the variables. -c -c mode is an integer input variable. if mode = 1, the -c variables will be scaled internally. if mode = 2, -c the scaling is specified by the input diag. other -c values of mode are equivalent to mode = 1. -c -c factor is a positive input variable used in determining the -c initial step bound. this bound is set to the product of -c factor and the euclidean norm of diag*x if nonzero, or else -c to factor itself. in most cases factor should lie in the -c interval (.1,100.).100. is a generally recommended value. -c -c nprint is an integer input variable that enables controlled -c printing of iterates if it is positive. in this case, -c fcn is called with iflag = 0 at the beginning of the first -c iteration and every nprint iterations thereafter and -c immediately prior to return, with x, fvec, and fjac -c available for printing. fvec and fjac should not be -c altered. if nprint is not positive, no special calls -c of fcn with iflag = 0 are made. -c -c info is an integer output variable. if the user has -c terminated execution, info is set to the (negative) -c value of iflag. see description of fcn. otherwise, -c info is set as follows. -c -c info = 0 improper input parameters. -c -c info = 1 both actual and predicted relative reductions -c in the sum of squares are at most ftol. -c -c info = 2 relative error between two consecutive iterates -c is at most xtol. -c -c info = 3 conditions for info = 1 and info = 2 both hold. -c -c info = 4 the cosine of the angle between fvec and any -c column of the jacobian is at most gtol in -c absolute value. -c -c info = 5 number of calls to fcn with iflag = 1 has -c reached maxfev. -c -c info = 6 ftol is too small. no further reduction in -c the sum of squares is possible. -c -c info = 7 xtol is too small. no further improvement in -c the approximate solution x is possible. -c -c info = 8 gtol is too small. fvec is orthogonal to the -c columns of the jacobian to machine precision. -c -c nfev is an integer output variable set to the number of -c calls to fcn with iflag = 1. -c -c njev is an integer output variable set to the number of -c calls to fcn with iflag = 2. -c -c ipvt is an integer output array of length n. ipvt -c defines a permutation matrix p such that jac*p = q*r, -c where jac is the final calculated jacobian, q is -c orthogonal (not stored), and r is upper triangular -c with diagonal elements of nonincreasing magnitude. -c column j of p is column ipvt(j) of the identity matrix. -c -c qtf is an output array of length n which contains -c the first n elements of the vector (q transpose)*fvec. -c -c wa1, wa2, and wa3 are work arrays of length n. -c -c wa4 is a work array of length m. -c -c subprograms called -c -c user-supplied ...... fcn -c -c minpack-supplied ... dpmpar,enorm,lmpar,qrfac -c -c fortran-supplied ... dabs,dmax1,dmin1,dsqrt,mod -c -c argonne national laboratory. minpack project. march 1980. -c burton s. garbow, kenneth e. hillstrom, jorge j. more -c -c ********** - integer i,iflag,iter,j,l - double precision actred,delta,dirder,epsmch,fnorm,fnorm1,gnorm, - * one,par,pnorm,prered,p1,p5,p25,p75,p0001,ratio, - * sum,temp,temp1,temp2,xnorm,zero - double precision dpmpar,enorm - data one,p1,p5,p25,p75,p0001,zero - * /1.0d0,1.0d-1,5.0d-1,2.5d-1,7.5d-1,1.0d-4,0.0d0/ -c -c epsmch is the machine precision. -c - epsmch = dpmpar(1) -c - info = 0 - iflag = 0 - nfev = 0 - njev = 0 -c -c check the input parameters for errors. -c - if (n .le. 0 .or. m .lt. n .or. ldfjac .lt. m - * .or. ftol .lt. zero .or. xtol .lt. zero .or. gtol .lt. zero - * .or. maxfev .le. 0 .or. factor .le. zero) go to 300 - if (mode .ne. 2) go to 20 - do 10 j = 1, n - if (diag(j) .le. zero) go to 300 - 10 continue - 20 continue -c -c evaluate the function at the starting point -c and calculate its norm. -c - iflag = 1 - call fcn(m,n,x,fvec,fjac,ldfjac,iflag) - nfev = 1 - if (iflag .lt. 0) go to 300 - fnorm = enorm(m,fvec) -c -c initialize levenberg-marquardt parameter and iteration counter. -c - par = zero - iter = 1 -c -c beginning of the outer loop. -c - 30 continue -c -c calculate the jacobian matrix. -c - iflag = 2 - call fcn(m,n,x,fvec,fjac,ldfjac,iflag) - njev = njev + 1 - if (iflag .lt. 0) go to 300 -c -c if requested, call fcn to enable printing of iterates. -c - if (nprint .le. 0) go to 40 - iflag = 0 - if (mod(iter-1,nprint) .eq. 0) - * call fcn(m,n,x,fvec,fjac,ldfjac,iflag) - if (iflag .lt. 0) go to 300 - 40 continue -c -c compute the qr factorization of the jacobian. -c - call qrfac(m,n,fjac,ldfjac,.true.,ipvt,n,wa1,wa2,wa3) -c -c on the first iteration and if mode is 1, scale according -c to the norms of the columns of the initial jacobian. -c - if (iter .ne. 1) go to 80 - if (mode .eq. 2) go to 60 - do 50 j = 1, n - diag(j) = wa2(j) - if (wa2(j) .eq. zero) diag(j) = one - 50 continue - 60 continue -c -c on the first iteration, calculate the norm of the scaled x -c and initialize the step bound delta. -c - do 70 j = 1, n - wa3(j) = diag(j)*x(j) - 70 continue - xnorm = enorm(n,wa3) - delta = factor*xnorm - if (delta .eq. zero) delta = factor - 80 continue -c -c form (q transpose)*fvec and store the first n components in -c qtf. -c - do 90 i = 1, m - wa4(i) = fvec(i) - 90 continue - do 130 j = 1, n - if (fjac(j,j) .eq. zero) go to 120 - sum = zero - do 100 i = j, m - sum = sum + fjac(i,j)*wa4(i) - 100 continue - temp = -sum/fjac(j,j) - do 110 i = j, m - wa4(i) = wa4(i) + fjac(i,j)*temp - 110 continue - 120 continue - fjac(j,j) = wa1(j) - qtf(j) = wa4(j) - 130 continue -c -c compute the norm of the scaled gradient. -c - gnorm = zero - if (fnorm .eq. zero) go to 170 - do 160 j = 1, n - l = ipvt(j) - if (wa2(l) .eq. zero) go to 150 - sum = zero - do 140 i = 1, j - sum = sum + fjac(i,j)*(qtf(i)/fnorm) - 140 continue - gnorm = dmax1(gnorm,dabs(sum/wa2(l))) - 150 continue - 160 continue - 170 continue -c -c test for convergence of the gradient norm. -c - if (gnorm .le. gtol) info = 4 - if (info .ne. 0) go to 300 -c -c rescale if necessary. -c - if (mode .eq. 2) go to 190 - do 180 j = 1, n - diag(j) = dmax1(diag(j),wa2(j)) - 180 continue - 190 continue -c -c beginning of the inner loop. -c - 200 continue -c -c determine the levenberg-marquardt parameter. -c - call lmpar(n,fjac,ldfjac,ipvt,diag,qtf,delta,par,wa1,wa2, - * wa3,wa4) -c -c store the direction p and x + p. calculate the norm of p. -c - do 210 j = 1, n - wa1(j) = -wa1(j) - wa2(j) = x(j) + wa1(j) - wa3(j) = diag(j)*wa1(j) - 210 continue - pnorm = enorm(n,wa3) -c -c on the first iteration, adjust the initial step bound. -c - if (iter .eq. 1) delta = dmin1(delta,pnorm) -c -c evaluate the function at x + p and calculate its norm. -c - iflag = 1 - call fcn(m,n,wa2,wa4,fjac,ldfjac,iflag) - nfev = nfev + 1 - if (iflag .lt. 0) go to 300 - fnorm1 = enorm(m,wa4) -c -c compute the scaled actual reduction. -c - actred = -one - if (p1*fnorm1 .lt. fnorm) actred = one - (fnorm1/fnorm)**2 -c -c compute the scaled predicted reduction and -c the scaled directional derivative. -c - do 230 j = 1, n - wa3(j) = zero - l = ipvt(j) - temp = wa1(l) - do 220 i = 1, j - wa3(i) = wa3(i) + fjac(i,j)*temp - 220 continue - 230 continue - temp1 = enorm(n,wa3)/fnorm - temp2 = (dsqrt(par)*pnorm)/fnorm - prered = temp1**2 + temp2**2/p5 - dirder = -(temp1**2 + temp2**2) -c -c compute the ratio of the actual to the predicted -c reduction. -c - ratio = zero - if (prered .ne. zero) ratio = actred/prered -c -c update the step bound. -c - if (ratio .gt. p25) go to 240 - if (actred .ge. zero) temp = p5 - if (actred .lt. zero) - * temp = p5*dirder/(dirder + p5*actred) - if (p1*fnorm1 .ge. fnorm .or. temp .lt. p1) temp = p1 - delta = temp*dmin1(delta,pnorm/p1) - par = par/temp - go to 260 - 240 continue - if (par .ne. zero .and. ratio .lt. p75) go to 250 - delta = pnorm/p5 - par = p5*par - 250 continue - 260 continue -c -c test for successful iteration. -c - if (ratio .lt. p0001) go to 290 -c -c successful iteration. update x, fvec, and their norms. -c - do 270 j = 1, n - x(j) = wa2(j) - wa2(j) = diag(j)*x(j) - 270 continue - do 280 i = 1, m - fvec(i) = wa4(i) - 280 continue - xnorm = enorm(n,wa2) - fnorm = fnorm1 - iter = iter + 1 - 290 continue -c -c tests for convergence. -c - if (dabs(actred) .le. ftol .and. prered .le. ftol - * .and. p5*ratio .le. one) info = 1 - if (delta .le. xtol*xnorm) info = 2 - if (dabs(actred) .le. ftol .and. prered .le. ftol - * .and. p5*ratio .le. one .and. info .eq. 2) info = 3 - if (info .ne. 0) go to 300 -c -c tests for termination and stringent tolerances. -c - if (nfev .ge. maxfev) info = 5 - if (dabs(actred) .le. epsmch .and. prered .le. epsmch - * .and. p5*ratio .le. one) info = 6 - if (delta .le. epsmch*xnorm) info = 7 - if (gnorm .le. epsmch) info = 8 - if (info .ne. 0) go to 300 -c -c end of the inner loop. repeat if iteration unsuccessful. -c - if (ratio .lt. p0001) go to 200 -c -c end of the outer loop. -c - go to 30 - 300 continue -c -c termination, either normal or user imposed. -c - if (iflag .lt. 0) info = iflag - iflag = 0 - if (nprint .gt. 0) call fcn(m,n,x,fvec,fjac,ldfjac,iflag) - return -c -c last card of subroutine lmder. -c - end diff --git a/src/lmder1.f b/src/lmder1.f deleted file mode 100644 index d691940..0000000 --- a/src/lmder1.f +++ /dev/null @@ -1,156 +0,0 @@ - subroutine lmder1(fcn,m,n,x,fvec,fjac,ldfjac,tol,info,ipvt,wa, - * lwa) - integer m,n,ldfjac,info,lwa - integer ipvt(n) - double precision tol - double precision x(n),fvec(m),fjac(ldfjac,n),wa(lwa) - external fcn -c ********** -c -c subroutine lmder1 -c -c the purpose of lmder1 is to minimize the sum of the squares of -c m nonlinear functions in n variables by a modification of the -c levenberg-marquardt algorithm. this is done by using the more -c general least-squares solver lmder. the user must provide a -c subroutine which calculates the functions and the jacobian. -c -c the subroutine statement is -c -c subroutine lmder1(fcn,m,n,x,fvec,fjac,ldfjac,tol,info, -c ipvt,wa,lwa) -c -c where -c -c fcn is the name of the user-supplied subroutine which -c calculates the functions and the jacobian. fcn must -c be declared in an external statement in the user -c calling program, and should be written as follows. -c -c subroutine fcn(m,n,x,fvec,fjac,ldfjac,iflag) -c integer m,n,ldfjac,iflag -c double precision x(n),fvec(m),fjac(ldfjac,n) -c ---------- -c if iflag = 1 calculate the functions at x and -c return this vector in fvec. do not alter fjac. -c if iflag = 2 calculate the jacobian at x and -c return this matrix in fjac. do not alter fvec. -c ---------- -c return -c end -c -c the value of iflag should not be changed by fcn unless -c the user wants to terminate execution of lmder1. -c in this case set iflag to a negative integer. -c -c m is a positive integer input variable set to the number -c of functions. -c -c n is a positive integer input variable set to the number -c of variables. n must not exceed m. -c -c x is an array of length n. on input x must contain -c an initial estimate of the solution vector. on output x -c contains the final estimate of the solution vector. -c -c fvec is an output array of length m which contains -c the functions evaluated at the output x. -c -c fjac is an output m by n array. the upper n by n submatrix -c of fjac contains an upper triangular matrix r with -c diagonal elements of nonincreasing magnitude such that -c -c t t t -c p *(jac *jac)*p = r *r, -c -c where p is a permutation matrix and jac is the final -c calculated jacobian. column j of p is column ipvt(j) -c (see below) of the identity matrix. the lower trapezoidal -c part of fjac contains information generated during -c the computation of r. -c -c ldfjac is a positive integer input variable not less than m -c which specifies the leading dimension of the array fjac. -c -c tol is a nonnegative input variable. termination occurs -c when the algorithm estimates either that the relative -c error in the sum of squares is at most tol or that -c the relative error between x and the solution is at -c most tol. -c -c info is an integer output variable. if the user has -c terminated execution, info is set to the (negative) -c value of iflag. see description of fcn. otherwise, -c info is set as follows. -c -c info = 0 improper input parameters. -c -c info = 1 algorithm estimates that the relative error -c in the sum of squares is at most tol. -c -c info = 2 algorithm estimates that the relative error -c between x and the solution is at most tol. -c -c info = 3 conditions for info = 1 and info = 2 both hold. -c -c info = 4 fvec is orthogonal to the columns of the -c jacobian to machine precision. -c -c info = 5 number of calls to fcn with iflag = 1 has -c reached 100*(n+1). -c -c info = 6 tol is too small. no further reduction in -c the sum of squares is possible. -c -c info = 7 tol is too small. no further improvement in -c the approximate solution x is possible. -c -c ipvt is an integer output array of length n. ipvt -c defines a permutation matrix p such that jac*p = q*r, -c where jac is the final calculated jacobian, q is -c orthogonal (not stored), and r is upper triangular -c with diagonal elements of nonincreasing magnitude. -c column j of p is column ipvt(j) of the identity matrix. -c -c wa is a work array of length lwa. -c -c lwa is a positive integer input variable not less than 5*n+m. -c -c subprograms called -c -c user-supplied ...... fcn -c -c minpack-supplied ... lmder -c -c argonne national laboratory. minpack project. march 1980. -c burton s. garbow, kenneth e. hillstrom, jorge j. more -c -c ********** - integer maxfev,mode,nfev,njev,nprint - double precision factor,ftol,gtol,xtol,zero - data factor,zero /1.0d2,0.0d0/ - info = 0 -c -c check the input parameters for errors. -c - if (n .le. 0 .or. m .lt. n .or. ldfjac .lt. m .or. tol .lt. zero - * .or. lwa .lt. 5*n + m) go to 10 -c -c call lmder. -c - maxfev = 100*(n + 1) - ftol = tol - xtol = tol - gtol = zero - mode = 1 - nprint = 0 - call lmder(fcn,m,n,x,fvec,fjac,ldfjac,ftol,xtol,gtol,maxfev, - * wa(1),mode,factor,nprint,info,nfev,njev,ipvt,wa(n+1), - * wa(2*n+1),wa(3*n+1),wa(4*n+1),wa(5*n+1)) - if (info .eq. 8) info = 4 - 10 continue - return -c -c last card of subroutine lmder1. -c - end diff --git a/src/lmdif.f b/src/lmdif.f deleted file mode 100644 index dd3d4ee..0000000 --- a/src/lmdif.f +++ /dev/null @@ -1,454 +0,0 @@ - subroutine lmdif(fcn,m,n,x,fvec,ftol,xtol,gtol,maxfev,epsfcn, - * diag,mode,factor,nprint,info,nfev,fjac,ldfjac, - * ipvt,qtf,wa1,wa2,wa3,wa4) - integer m,n,maxfev,mode,nprint,info,nfev,ldfjac - integer ipvt(n) - double precision ftol,xtol,gtol,epsfcn,factor - double precision x(n),fvec(m),diag(n),fjac(ldfjac,n),qtf(n), - * wa1(n),wa2(n),wa3(n),wa4(m) - external fcn -c ********** -c -c subroutine lmdif -c -c the purpose of lmdif is to minimize the sum of the squares of -c m nonlinear functions in n variables by a modification of -c the levenberg-marquardt algorithm. the user must provide a -c subroutine which calculates the functions. the jacobian is -c then calculated by a forward-difference approximation. -c -c the subroutine statement is -c -c subroutine lmdif(fcn,m,n,x,fvec,ftol,xtol,gtol,maxfev,epsfcn, -c diag,mode,factor,nprint,info,nfev,fjac, -c ldfjac,ipvt,qtf,wa1,wa2,wa3,wa4) -c -c where -c -c fcn is the name of the user-supplied subroutine which -c calculates the functions. fcn must be declared -c in an external statement in the user calling -c program, and should be written as follows. -c -c subroutine fcn(m,n,x,fvec,iflag) -c integer m,n,iflag -c double precision x(n),fvec(m) -c ---------- -c calculate the functions at x and -c return this vector in fvec. -c ---------- -c return -c end -c -c the value of iflag should not be changed by fcn unless -c the user wants to terminate execution of lmdif. -c in this case set iflag to a negative integer. -c -c m is a positive integer input variable set to the number -c of functions. -c -c n is a positive integer input variable set to the number -c of variables. n must not exceed m. -c -c x is an array of length n. on input x must contain -c an initial estimate of the solution vector. on output x -c contains the final estimate of the solution vector. -c -c fvec is an output array of length m which contains -c the functions evaluated at the output x. -c -c ftol is a nonnegative input variable. termination -c occurs when both the actual and predicted relative -c reductions in the sum of squares are at most ftol. -c therefore, ftol measures the relative error desired -c in the sum of squares. -c -c xtol is a nonnegative input variable. termination -c occurs when the relative error between two consecutive -c iterates is at most xtol. therefore, xtol measures the -c relative error desired in the approximate solution. -c -c gtol is a nonnegative input variable. termination -c occurs when the cosine of the angle between fvec and -c any column of the jacobian is at most gtol in absolute -c value. therefore, gtol measures the orthogonality -c desired between the function vector and the columns -c of the jacobian. -c -c maxfev is a positive integer input variable. termination -c occurs when the number of calls to fcn is at least -c maxfev by the end of an iteration. -c -c epsfcn is an input variable used in determining a suitable -c step length for the forward-difference approximation. this -c approximation assumes that the relative errors in the -c functions are of the order of epsfcn. if epsfcn is less -c than the machine precision, it is assumed that the relative -c errors in the functions are of the order of the machine -c precision. -c -c diag is an array of length n. if mode = 1 (see -c below), diag is internally set. if mode = 2, diag -c must contain positive entries that serve as -c multiplicative scale factors for the variables. -c -c mode is an integer input variable. if mode = 1, the -c variables will be scaled internally. if mode = 2, -c the scaling is specified by the input diag. other -c values of mode are equivalent to mode = 1. -c -c factor is a positive input variable used in determining the -c initial step bound. this bound is set to the product of -c factor and the euclidean norm of diag*x if nonzero, or else -c to factor itself. in most cases factor should lie in the -c interval (.1,100.). 100. is a generally recommended value. -c -c nprint is an integer input variable that enables controlled -c printing of iterates if it is positive. in this case, -c fcn is called with iflag = 0 at the beginning of the first -c iteration and every nprint iterations thereafter and -c immediately prior to return, with x and fvec available -c for printing. if nprint is not positive, no special calls -c of fcn with iflag = 0 are made. -c -c info is an integer output variable. if the user has -c terminated execution, info is set to the (negative) -c value of iflag. see description of fcn. otherwise, -c info is set as follows. -c -c info = 0 improper input parameters. -c -c info = 1 both actual and predicted relative reductions -c in the sum of squares are at most ftol. -c -c info = 2 relative error between two consecutive iterates -c is at most xtol. -c -c info = 3 conditions for info = 1 and info = 2 both hold. -c -c info = 4 the cosine of the angle between fvec and any -c column of the jacobian is at most gtol in -c absolute value. -c -c info = 5 number of calls to fcn has reached or -c exceeded maxfev. -c -c info = 6 ftol is too small. no further reduction in -c the sum of squares is possible. -c -c info = 7 xtol is too small. no further improvement in -c the approximate solution x is possible. -c -c info = 8 gtol is too small. fvec is orthogonal to the -c columns of the jacobian to machine precision. -c -c nfev is an integer output variable set to the number of -c calls to fcn. -c -c fjac is an output m by n array. the upper n by n submatrix -c of fjac contains an upper triangular matrix r with -c diagonal elements of nonincreasing magnitude such that -c -c t t t -c p *(jac *jac)*p = r *r, -c -c where p is a permutation matrix and jac is the final -c calculated jacobian. column j of p is column ipvt(j) -c (see below) of the identity matrix. the lower trapezoidal -c part of fjac contains information generated during -c the computation of r. -c -c ldfjac is a positive integer input variable not less than m -c which specifies the leading dimension of the array fjac. -c -c ipvt is an integer output array of length n. ipvt -c defines a permutation matrix p such that jac*p = q*r, -c where jac is the final calculated jacobian, q is -c orthogonal (not stored), and r is upper triangular -c with diagonal elements of nonincreasing magnitude. -c column j of p is column ipvt(j) of the identity matrix. -c -c qtf is an output array of length n which contains -c the first n elements of the vector (q transpose)*fvec. -c -c wa1, wa2, and wa3 are work arrays of length n. -c -c wa4 is a work array of length m. -c -c subprograms called -c -c user-supplied ...... fcn -c -c minpack-supplied ... dpmpar,enorm,fdjac2,lmpar,qrfac -c -c fortran-supplied ... dabs,dmax1,dmin1,dsqrt,mod -c -c argonne national laboratory. minpack project. march 1980. -c burton s. garbow, kenneth e. hillstrom, jorge j. more -c -c ********** - integer i,iflag,iter,j,l - double precision actred,delta,dirder,epsmch,fnorm,fnorm1,gnorm, - * one,par,pnorm,prered,p1,p5,p25,p75,p0001,ratio, - * sum,temp,temp1,temp2,xnorm,zero - double precision dpmpar,enorm - data one,p1,p5,p25,p75,p0001,zero - * /1.0d0,1.0d-1,5.0d-1,2.5d-1,7.5d-1,1.0d-4,0.0d0/ -c -c epsmch is the machine precision. -c - epsmch = dpmpar(1) -c - info = 0 - iflag = 0 - nfev = 0 -c -c check the input parameters for errors. -c - if (n .le. 0 .or. m .lt. n .or. ldfjac .lt. m - * .or. ftol .lt. zero .or. xtol .lt. zero .or. gtol .lt. zero - * .or. maxfev .le. 0 .or. factor .le. zero) go to 300 - if (mode .ne. 2) go to 20 - do 10 j = 1, n - if (diag(j) .le. zero) go to 300 - 10 continue - 20 continue -c -c evaluate the function at the starting point -c and calculate its norm. -c - iflag = 1 - call fcn(m,n,x,fvec,iflag) - nfev = 1 - if (iflag .lt. 0) go to 300 - fnorm = enorm(m,fvec) -c -c initialize levenberg-marquardt parameter and iteration counter. -c - par = zero - iter = 1 -c -c beginning of the outer loop. -c - 30 continue -c -c calculate the jacobian matrix. -c - iflag = 2 - call fdjac2(fcn,m,n,x,fvec,fjac,ldfjac,iflag,epsfcn,wa4) - nfev = nfev + n - if (iflag .lt. 0) go to 300 -c -c if requested, call fcn to enable printing of iterates. -c - if (nprint .le. 0) go to 40 - iflag = 0 - if (mod(iter-1,nprint) .eq. 0) call fcn(m,n,x,fvec,iflag) - if (iflag .lt. 0) go to 300 - 40 continue -c -c compute the qr factorization of the jacobian. -c - call qrfac(m,n,fjac,ldfjac,.true.,ipvt,n,wa1,wa2,wa3) -c -c on the first iteration and if mode is 1, scale according -c to the norms of the columns of the initial jacobian. -c - if (iter .ne. 1) go to 80 - if (mode .eq. 2) go to 60 - do 50 j = 1, n - diag(j) = wa2(j) - if (wa2(j) .eq. zero) diag(j) = one - 50 continue - 60 continue -c -c on the first iteration, calculate the norm of the scaled x -c and initialize the step bound delta. -c - do 70 j = 1, n - wa3(j) = diag(j)*x(j) - 70 continue - xnorm = enorm(n,wa3) - delta = factor*xnorm - if (delta .eq. zero) delta = factor - 80 continue -c -c form (q transpose)*fvec and store the first n components in -c qtf. -c - do 90 i = 1, m - wa4(i) = fvec(i) - 90 continue - do 130 j = 1, n - if (fjac(j,j) .eq. zero) go to 120 - sum = zero - do 100 i = j, m - sum = sum + fjac(i,j)*wa4(i) - 100 continue - temp = -sum/fjac(j,j) - do 110 i = j, m - wa4(i) = wa4(i) + fjac(i,j)*temp - 110 continue - 120 continue - fjac(j,j) = wa1(j) - qtf(j) = wa4(j) - 130 continue -c -c compute the norm of the scaled gradient. -c - gnorm = zero - if (fnorm .eq. zero) go to 170 - do 160 j = 1, n - l = ipvt(j) - if (wa2(l) .eq. zero) go to 150 - sum = zero - do 140 i = 1, j - sum = sum + fjac(i,j)*(qtf(i)/fnorm) - 140 continue - gnorm = dmax1(gnorm,dabs(sum/wa2(l))) - 150 continue - 160 continue - 170 continue -c -c test for convergence of the gradient norm. -c - if (gnorm .le. gtol) info = 4 - if (info .ne. 0) go to 300 -c -c rescale if necessary. -c - if (mode .eq. 2) go to 190 - do 180 j = 1, n - diag(j) = dmax1(diag(j),wa2(j)) - 180 continue - 190 continue -c -c beginning of the inner loop. -c - 200 continue -c -c determine the levenberg-marquardt parameter. -c - call lmpar(n,fjac,ldfjac,ipvt,diag,qtf,delta,par,wa1,wa2, - * wa3,wa4) -c -c store the direction p and x + p. calculate the norm of p. -c - do 210 j = 1, n - wa1(j) = -wa1(j) - wa2(j) = x(j) + wa1(j) - wa3(j) = diag(j)*wa1(j) - 210 continue - pnorm = enorm(n,wa3) -c -c on the first iteration, adjust the initial step bound. -c - if (iter .eq. 1) delta = dmin1(delta,pnorm) -c -c evaluate the function at x + p and calculate its norm. -c - iflag = 1 - call fcn(m,n,wa2,wa4,iflag) - nfev = nfev + 1 - if (iflag .lt. 0) go to 300 - fnorm1 = enorm(m,wa4) -c -c compute the scaled actual reduction. -c - actred = -one - if (p1*fnorm1 .lt. fnorm) actred = one - (fnorm1/fnorm)**2 -c -c compute the scaled predicted reduction and -c the scaled directional derivative. -c - do 230 j = 1, n - wa3(j) = zero - l = ipvt(j) - temp = wa1(l) - do 220 i = 1, j - wa3(i) = wa3(i) + fjac(i,j)*temp - 220 continue - 230 continue - temp1 = enorm(n,wa3)/fnorm - temp2 = (dsqrt(par)*pnorm)/fnorm - prered = temp1**2 + temp2**2/p5 - dirder = -(temp1**2 + temp2**2) -c -c compute the ratio of the actual to the predicted -c reduction. -c - ratio = zero - if (prered .ne. zero) ratio = actred/prered -c -c update the step bound. -c - if (ratio .gt. p25) go to 240 - if (actred .ge. zero) temp = p5 - if (actred .lt. zero) - * temp = p5*dirder/(dirder + p5*actred) - if (p1*fnorm1 .ge. fnorm .or. temp .lt. p1) temp = p1 - delta = temp*dmin1(delta,pnorm/p1) - par = par/temp - go to 260 - 240 continue - if (par .ne. zero .and. ratio .lt. p75) go to 250 - delta = pnorm/p5 - par = p5*par - 250 continue - 260 continue -c -c test for successful iteration. -c - if (ratio .lt. p0001) go to 290 -c -c successful iteration. update x, fvec, and their norms. -c - do 270 j = 1, n - x(j) = wa2(j) - wa2(j) = diag(j)*x(j) - 270 continue - do 280 i = 1, m - fvec(i) = wa4(i) - 280 continue - xnorm = enorm(n,wa2) - fnorm = fnorm1 - iter = iter + 1 - 290 continue -c -c tests for convergence. -c - if (dabs(actred) .le. ftol .and. prered .le. ftol - * .and. p5*ratio .le. one) info = 1 - if (delta .le. xtol*xnorm) info = 2 - if (dabs(actred) .le. ftol .and. prered .le. ftol - * .and. p5*ratio .le. one .and. info .eq. 2) info = 3 - if (info .ne. 0) go to 300 -c -c tests for termination and stringent tolerances. -c - if (nfev .ge. maxfev) info = 5 - if (dabs(actred) .le. epsmch .and. prered .le. epsmch - * .and. p5*ratio .le. one) info = 6 - if (delta .le. epsmch*xnorm) info = 7 - if (gnorm .le. epsmch) info = 8 - if (info .ne. 0) go to 300 -c -c end of the inner loop. repeat if iteration unsuccessful. -c - if (ratio .lt. p0001) go to 200 -c -c end of the outer loop. -c - go to 30 - 300 continue -c -c termination, either normal or user imposed. -c - if (iflag .lt. 0) info = iflag - iflag = 0 - if (nprint .gt. 0) call fcn(m,n,x,fvec,iflag) - return -c -c last card of subroutine lmdif. -c - end diff --git a/src/lmdif1.f b/src/lmdif1.f deleted file mode 100644 index 70f8aae..0000000 --- a/src/lmdif1.f +++ /dev/null @@ -1,135 +0,0 @@ - subroutine lmdif1(fcn,m,n,x,fvec,tol,info,iwa,wa,lwa) - integer m,n,info,lwa - integer iwa(n) - double precision tol - double precision x(n),fvec(m),wa(lwa) - external fcn -c ********** -c -c subroutine lmdif1 -c -c the purpose of lmdif1 is to minimize the sum of the squares of -c m nonlinear functions in n variables by a modification of the -c levenberg-marquardt algorithm. this is done by using the more -c general least-squares solver lmdif. the user must provide a -c subroutine which calculates the functions. the jacobian is -c then calculated by a forward-difference approximation. -c -c the subroutine statement is -c -c subroutine lmdif1(fcn,m,n,x,fvec,tol,info,iwa,wa,lwa) -c -c where -c -c fcn is the name of the user-supplied subroutine which -c calculates the functions. fcn must be declared -c in an external statement in the user calling -c program, and should be written as follows. -c -c subroutine fcn(m,n,x,fvec,iflag) -c integer m,n,iflag -c double precision x(n),fvec(m) -c ---------- -c calculate the functions at x and -c return this vector in fvec. -c ---------- -c return -c end -c -c the value of iflag should not be changed by fcn unless -c the user wants to terminate execution of lmdif1. -c in this case set iflag to a negative integer. -c -c m is a positive integer input variable set to the number -c of functions. -c -c n is a positive integer input variable set to the number -c of variables. n must not exceed m. -c -c x is an array of length n. on input x must contain -c an initial estimate of the solution vector. on output x -c contains the final estimate of the solution vector. -c -c fvec is an output array of length m which contains -c the functions evaluated at the output x. -c -c tol is a nonnegative input variable. termination occurs -c when the algorithm estimates either that the relative -c error in the sum of squares is at most tol or that -c the relative error between x and the solution is at -c most tol. -c -c info is an integer output variable. if the user has -c terminated execution, info is set to the (negative) -c value of iflag. see description of fcn. otherwise, -c info is set as follows. -c -c info = 0 improper input parameters. -c -c info = 1 algorithm estimates that the relative error -c in the sum of squares is at most tol. -c -c info = 2 algorithm estimates that the relative error -c between x and the solution is at most tol. -c -c info = 3 conditions for info = 1 and info = 2 both hold. -c -c info = 4 fvec is orthogonal to the columns of the -c jacobian to machine precision. -c -c info = 5 number of calls to fcn has reached or -c exceeded 200*(n+1). -c -c info = 6 tol is too small. no further reduction in -c the sum of squares is possible. -c -c info = 7 tol is too small. no further improvement in -c the approximate solution x is possible. -c -c iwa is an integer work array of length n. -c -c wa is a work array of length lwa. -c -c lwa is a positive integer input variable not less than -c m*n+5*n+m. -c -c subprograms called -c -c user-supplied ...... fcn -c -c minpack-supplied ... lmdif -c -c argonne national laboratory. minpack project. march 1980. -c burton s. garbow, kenneth e. hillstrom, jorge j. more -c -c ********** - integer maxfev,mode,mp5n,nfev,nprint - double precision epsfcn,factor,ftol,gtol,xtol,zero - data factor,zero /1.0d2,0.0d0/ - info = 0 -c -c check the input parameters for errors. -c - if (n .le. 0 .or. m .lt. n .or. tol .lt. zero - * .or. lwa .lt. m*n + 5*n + m) go to 10 -c -c call lmdif. -c - maxfev = 200*(n + 1) - ftol = tol - xtol = tol - gtol = zero - epsfcn = zero - mode = 1 - nprint = 0 - mp5n = m + 5*n - call lmdif(fcn,m,n,x,fvec,ftol,xtol,gtol,maxfev,epsfcn,wa(1), - * mode,factor,nprint,info,nfev,wa(mp5n+1),m,iwa, - * wa(n+1),wa(2*n+1),wa(3*n+1),wa(4*n+1),wa(5*n+1)) - if (info .eq. 8) info = 4 - 10 continue - return -c -c last card of subroutine lmdif1. -c - end diff --git a/src/lmdipt.f b/src/lmdipt.f deleted file mode 100644 index bdc93a3..0000000 --- a/src/lmdipt.f +++ /dev/null @@ -1,214 +0,0 @@ - subroutine initpt(n,x,nprob,factor) - integer n,nprob - double precision factor - double precision x(n) -c ********** -c -c subroutine initpt -c -c this subroutine specifies the standard starting points for the -c functions defined by subroutine ssqfcn. the subroutine returns -c in x a multiple (factor) of the standard starting point. for -c the 11th function the standard starting point is zero, so in -c this case, if factor is not unity, then the subroutine returns -c the vector x(j) = factor, j=1,...,n. -c -c the subroutine statement is -c -c subroutine initpt(n,x,nprob,factor) -c -c where -c -c n is a positive integer input variable. -c -c x is an output array of length n which contains the standard -c starting point for problem nprob multiplied by factor. -c -c nprob is a positive integer input variable which defines the -c number of the problem. nprob must not exceed 18. -c -c factor is an input variable which specifies the multiple of -c the standard starting point. if factor is unity, no -c multiplication is performed. -c -c argonne national laboratory. minpack project. march 1980. -c burton s. garbow, kenneth e. hillstrom, jorge j. more -c -c ********** - integer ivar,j - double precision c1,c2,c3,c4,c5,c6,c7,c8,c9,c10,c11,c12,c13,c14, - * c15,c16,c17,five,h,half,one,seven,ten,three, - * twenty,twntf,two,zero - double precision dfloat - data zero,half,one,two,three,five,seven,ten,twenty,twntf - * /0.0d0,5.0d-1,1.0d0,2.0d0,3.0d0,5.0d0,7.0d0,1.0d1,2.0d1, - * 2.5d1/ - data c1,c2,c3,c4,c5,c6,c7,c8,c9,c10,c11,c12,c13,c14,c15,c16,c17 - * /1.2d0,2.5d-1,3.9d-1,4.15d-1,2.0d-2,4.0d3,2.5d2,3.0d-1, - * 4.0d-1,1.5d0,1.0d-2,1.3d0,6.5d-1,7.0d-1,6.0d-1,4.5d0, - * 5.5d0/ - dfloat(ivar) = ivar -c -c selection of initial point. -c - go to (10,10,10,30,40,50,60,70,80,90,100,120,130,140,150,170, - * 190,200), nprob -c -c linear function - full rank or rank 1. -c - 10 continue - do 20 j = 1, n - x(j) = one - 20 continue - go to 210 -c -c rosenbrock function. -c - 30 continue - x(1) = -c1 - x(2) = one - go to 210 -c -c helical valley function. -c - 40 continue - x(1) = -one - x(2) = zero - x(3) = zero - go to 210 -c -c powell singular function. -c - 50 continue - x(1) = three - x(2) = -one - x(3) = zero - x(4) = one - go to 210 -c -c freudenstein and roth function. -c - 60 continue - x(1) = half - x(2) = -two - go to 210 -c -c bard function. -c - 70 continue - x(1) = one - x(2) = one - x(3) = one - go to 210 -c -c kowalik and osborne function. -c - 80 continue - x(1) = c2 - x(2) = c3 - x(3) = c4 - x(4) = c3 - go to 210 -c -c meyer function. -c - 90 continue - x(1) = c5 - x(2) = c6 - x(3) = c7 - go to 210 -c -c watson function. -c - 100 continue - do 110 j = 1, n - x(j) = zero - 110 continue - go to 210 -c -c box 3-dimensional function. -c - 120 continue - x(1) = zero - x(2) = ten - x(3) = twenty - go to 210 -c -c jennrich and sampson function. -c - 130 continue - x(1) = c8 - x(2) = c9 - go to 210 -c -c brown and dennis function. -c - 140 continue - x(1) = twntf - x(2) = five - x(3) = -five - x(4) = -one - go to 210 -c -c chebyquad function. -c - 150 continue - h = one/dfloat(n+1) - do 160 j = 1, n - x(j) = dfloat(j)*h - 160 continue - go to 210 -c -c brown almost-linear function. -c - 170 continue - do 180 j = 1, n - x(j) = half - 180 continue - go to 210 -c -c osborne 1 function. -c - 190 continue - x(1) = half - x(2) = c10 - x(3) = -one - x(4) = c11 - x(5) = c5 - go to 210 -c -c osborne 2 function. -c - 200 continue - x(1) = c12 - x(2) = c13 - x(3) = c13 - x(4) = c14 - x(5) = c15 - x(6) = three - x(7) = five - x(8) = seven - x(9) = two - x(10) = c16 - x(11) = c17 - 210 continue -c -c compute multiple of initial point. -c - if (factor .eq. one) go to 260 - if (nprob .eq. 11) go to 230 - do 220 j = 1, n - x(j) = factor*x(j) - 220 continue - go to 250 - 230 continue - do 240 j = 1, n - x(j) = factor - 240 continue - 250 continue - 260 continue - return -c -c last card of subroutine initpt. -c - end diff --git a/src/lmpar.f b/src/lmpar.f deleted file mode 100644 index 26c422a..0000000 --- a/src/lmpar.f +++ /dev/null @@ -1,264 +0,0 @@ - subroutine lmpar(n,r,ldr,ipvt,diag,qtb,delta,par,x,sdiag,wa1, - * wa2) - integer n,ldr - integer ipvt(n) - double precision delta,par - double precision r(ldr,n),diag(n),qtb(n),x(n),sdiag(n),wa1(n), - * wa2(n) -c ********** -c -c subroutine lmpar -c -c given an m by n matrix a, an n by n nonsingular diagonal -c matrix d, an m-vector b, and a positive number delta, -c the problem is to determine a value for the parameter -c par such that if x solves the system -c -c a*x = b , sqrt(par)*d*x = 0 , -c -c in the least squares sense, and dxnorm is the euclidean -c norm of d*x, then either par is zero and -c -c (dxnorm-delta) .le. 0.1*delta , -c -c or par is positive and -c -c abs(dxnorm-delta) .le. 0.1*delta . -c -c this subroutine completes the solution of the problem -c if it is provided with the necessary information from the -c qr factorization, with column pivoting, of a. that is, if -c a*p = q*r, where p is a permutation matrix, q has orthogonal -c columns, and r is an upper triangular matrix with diagonal -c elements of nonincreasing magnitude, then lmpar expects -c the full upper triangle of r, the permutation matrix p, -c and the first n components of (q transpose)*b. on output -c lmpar also provides an upper triangular matrix s such that -c -c t t t -c p *(a *a + par*d*d)*p = s *s . -c -c s is employed within lmpar and may be of separate interest. -c -c only a few iterations are generally needed for convergence -c of the algorithm. if, however, the limit of 10 iterations -c is reached, then the output par will contain the best -c value obtained so far. -c -c the subroutine statement is -c -c subroutine lmpar(n,r,ldr,ipvt,diag,qtb,delta,par,x,sdiag, -c wa1,wa2) -c -c where -c -c n is a positive integer input variable set to the order of r. -c -c r is an n by n array. on input the full upper triangle -c must contain the full upper triangle of the matrix r. -c on output the full upper triangle is unaltered, and the -c strict lower triangle contains the strict upper triangle -c (transposed) of the upper triangular matrix s. -c -c ldr is a positive integer input variable not less than n -c which specifies the leading dimension of the array r. -c -c ipvt is an integer input array of length n which defines the -c permutation matrix p such that a*p = q*r. column j of p -c is column ipvt(j) of the identity matrix. -c -c diag is an input array of length n which must contain the -c diagonal elements of the matrix d. -c -c qtb is an input array of length n which must contain the first -c n elements of the vector (q transpose)*b. -c -c delta is a positive input variable which specifies an upper -c bound on the euclidean norm of d*x. -c -c par is a nonnegative variable. on input par contains an -c initial estimate of the levenberg-marquardt parameter. -c on output par contains the final estimate. -c -c x is an output array of length n which contains the least -c squares solution of the system a*x = b, sqrt(par)*d*x = 0, -c for the output par. -c -c sdiag is an output array of length n which contains the -c diagonal elements of the upper triangular matrix s. -c -c wa1 and wa2 are work arrays of length n. -c -c subprograms called -c -c minpack-supplied ... dpmpar,enorm,qrsolv -c -c fortran-supplied ... dabs,dmax1,dmin1,dsqrt -c -c argonne national laboratory. minpack project. march 1980. -c burton s. garbow, kenneth e. hillstrom, jorge j. more -c -c ********** - integer i,iter,j,jm1,jp1,k,l,nsing - double precision dxnorm,dwarf,fp,gnorm,parc,parl,paru,p1,p001, - * sum,temp,zero - double precision dpmpar,enorm - data p1,p001,zero /1.0d-1,1.0d-3,0.0d0/ -c -c dwarf is the smallest positive magnitude. -c - dwarf = dpmpar(2) -c -c compute and store in x the gauss-newton direction. if the -c jacobian is rank-deficient, obtain a least squares solution. -c - nsing = n - do 10 j = 1, n - wa1(j) = qtb(j) - if (r(j,j) .eq. zero .and. nsing .eq. n) nsing = j - 1 - if (nsing .lt. n) wa1(j) = zero - 10 continue - if (nsing .lt. 1) go to 50 - do 40 k = 1, nsing - j = nsing - k + 1 - wa1(j) = wa1(j)/r(j,j) - temp = wa1(j) - jm1 = j - 1 - if (jm1 .lt. 1) go to 30 - do 20 i = 1, jm1 - wa1(i) = wa1(i) - r(i,j)*temp - 20 continue - 30 continue - 40 continue - 50 continue - do 60 j = 1, n - l = ipvt(j) - x(l) = wa1(j) - 60 continue -c -c initialize the iteration counter. -c evaluate the function at the origin, and test -c for acceptance of the gauss-newton direction. -c - iter = 0 - do 70 j = 1, n - wa2(j) = diag(j)*x(j) - 70 continue - dxnorm = enorm(n,wa2) - fp = dxnorm - delta - if (fp .le. p1*delta) go to 220 -c -c if the jacobian is not rank deficient, the newton -c step provides a lower bound, parl, for the zero of -c the function. otherwise set this bound to zero. -c - parl = zero - if (nsing .lt. n) go to 120 - do 80 j = 1, n - l = ipvt(j) - wa1(j) = diag(l)*(wa2(l)/dxnorm) - 80 continue - do 110 j = 1, n - sum = zero - jm1 = j - 1 - if (jm1 .lt. 1) go to 100 - do 90 i = 1, jm1 - sum = sum + r(i,j)*wa1(i) - 90 continue - 100 continue - wa1(j) = (wa1(j) - sum)/r(j,j) - 110 continue - temp = enorm(n,wa1) - parl = ((fp/delta)/temp)/temp - 120 continue -c -c calculate an upper bound, paru, for the zero of the function. -c - do 140 j = 1, n - sum = zero - do 130 i = 1, j - sum = sum + r(i,j)*qtb(i) - 130 continue - l = ipvt(j) - wa1(j) = sum/diag(l) - 140 continue - gnorm = enorm(n,wa1) - paru = gnorm/delta - if (paru .eq. zero) paru = dwarf/dmin1(delta,p1) -c -c if the input par lies outside of the interval (parl,paru), -c set par to the closer endpoint. -c - par = dmax1(par,parl) - par = dmin1(par,paru) - if (par .eq. zero) par = gnorm/dxnorm -c -c beginning of an iteration. -c - 150 continue - iter = iter + 1 -c -c evaluate the function at the current value of par. -c - if (par .eq. zero) par = dmax1(dwarf,p001*paru) - temp = dsqrt(par) - do 160 j = 1, n - wa1(j) = temp*diag(j) - 160 continue - call qrsolv(n,r,ldr,ipvt,wa1,qtb,x,sdiag,wa2) - do 170 j = 1, n - wa2(j) = diag(j)*x(j) - 170 continue - dxnorm = enorm(n,wa2) - temp = fp - fp = dxnorm - delta -c -c if the function is small enough, accept the current value -c of par. also test for the exceptional cases where parl -c is zero or the number of iterations has reached 10. -c - if (dabs(fp) .le. p1*delta - * .or. parl .eq. zero .and. fp .le. temp - * .and. temp .lt. zero .or. iter .eq. 10) go to 220 -c -c compute the newton correction. -c - do 180 j = 1, n - l = ipvt(j) - wa1(j) = diag(l)*(wa2(l)/dxnorm) - 180 continue - do 210 j = 1, n - wa1(j) = wa1(j)/sdiag(j) - temp = wa1(j) - jp1 = j + 1 - if (n .lt. jp1) go to 200 - do 190 i = jp1, n - wa1(i) = wa1(i) - r(i,j)*temp - 190 continue - 200 continue - 210 continue - temp = enorm(n,wa1) - parc = ((fp/delta)/temp)/temp -c -c depending on the sign of the function, update parl or paru. -c - if (fp .gt. zero) parl = dmax1(parl,par) - if (fp .lt. zero) paru = dmin1(paru,par) -c -c compute an improved estimate for par. -c - par = dmax1(parl,par+parc) -c -c end of an iteration. -c - go to 150 - 220 continue -c -c termination. -c - if (iter .eq. 0) par = zero - return -c -c last card of subroutine lmpar. -c - end diff --git a/src/lmstr.f b/src/lmstr.f deleted file mode 100644 index d9a7893..0000000 --- a/src/lmstr.f +++ /dev/null @@ -1,466 +0,0 @@ - subroutine lmstr(fcn,m,n,x,fvec,fjac,ldfjac,ftol,xtol,gtol, - * maxfev,diag,mode,factor,nprint,info,nfev,njev, - * ipvt,qtf,wa1,wa2,wa3,wa4) - integer m,n,ldfjac,maxfev,mode,nprint,info,nfev,njev - integer ipvt(n) - logical sing - double precision ftol,xtol,gtol,factor - double precision x(n),fvec(m),fjac(ldfjac,n),diag(n),qtf(n), - * wa1(n),wa2(n),wa3(n),wa4(m) -c ********** -c -c subroutine lmstr -c -c the purpose of lmstr is to minimize the sum of the squares of -c m nonlinear functions in n variables by a modification of -c the levenberg-marquardt algorithm which uses minimal storage. -c the user must provide a subroutine which calculates the -c functions and the rows of the jacobian. -c -c the subroutine statement is -c -c subroutine lmstr(fcn,m,n,x,fvec,fjac,ldfjac,ftol,xtol,gtol, -c maxfev,diag,mode,factor,nprint,info,nfev, -c njev,ipvt,qtf,wa1,wa2,wa3,wa4) -c -c where -c -c fcn is the name of the user-supplied subroutine which -c calculates the functions and the rows of the jacobian. -c fcn must be declared in an external statement in the -c user calling program, and should be written as follows. -c -c subroutine fcn(m,n,x,fvec,fjrow,iflag) -c integer m,n,iflag -c double precision x(n),fvec(m),fjrow(n) -c ---------- -c if iflag = 1 calculate the functions at x and -c return this vector in fvec. -c if iflag = i calculate the (i-1)-st row of the -c jacobian at x and return this vector in fjrow. -c ---------- -c return -c end -c -c the value of iflag should not be changed by fcn unless -c the user wants to terminate execution of lmstr. -c in this case set iflag to a negative integer. -c -c m is a positive integer input variable set to the number -c of functions. -c -c n is a positive integer input variable set to the number -c of variables. n must not exceed m. -c -c x is an array of length n. on input x must contain -c an initial estimate of the solution vector. on output x -c contains the final estimate of the solution vector. -c -c fvec is an output array of length m which contains -c the functions evaluated at the output x. -c -c fjac is an output n by n array. the upper triangle of fjac -c contains an upper triangular matrix r such that -c -c t t t -c p *(jac *jac)*p = r *r, -c -c where p is a permutation matrix and jac is the final -c calculated jacobian. column j of p is column ipvt(j) -c (see below) of the identity matrix. the lower triangular -c part of fjac contains information generated during -c the computation of r. -c -c ldfjac is a positive integer input variable not less than n -c which specifies the leading dimension of the array fjac. -c -c ftol is a nonnegative input variable. termination -c occurs when both the actual and predicted relative -c reductions in the sum of squares are at most ftol. -c therefore, ftol measures the relative error desired -c in the sum of squares. -c -c xtol is a nonnegative input variable. termination -c occurs when the relative error between two consecutive -c iterates is at most xtol. therefore, xtol measures the -c relative error desired in the approximate solution. -c -c gtol is a nonnegative input variable. termination -c occurs when the cosine of the angle between fvec and -c any column of the jacobian is at most gtol in absolute -c value. therefore, gtol measures the orthogonality -c desired between the function vector and the columns -c of the jacobian. -c -c maxfev is a positive integer input variable. termination -c occurs when the number of calls to fcn with iflag = 1 -c has reached maxfev. -c -c diag is an array of length n. if mode = 1 (see -c below), diag is internally set. if mode = 2, diag -c must contain positive entries that serve as -c multiplicative scale factors for the variables. -c -c mode is an integer input variable. if mode = 1, the -c variables will be scaled internally. if mode = 2, -c the scaling is specified by the input diag. other -c values of mode are equivalent to mode = 1. -c -c factor is a positive input variable used in determining the -c initial step bound. this bound is set to the product of -c factor and the euclidean norm of diag*x if nonzero, or else -c to factor itself. in most cases factor should lie in the -c interval (.1,100.). 100. is a generally recommended value. -c -c nprint is an integer input variable that enables controlled -c printing of iterates if it is positive. in this case, -c fcn is called with iflag = 0 at the beginning of the first -c iteration and every nprint iterations thereafter and -c immediately prior to return, with x and fvec available -c for printing. if nprint is not positive, no special calls -c of fcn with iflag = 0 are made. -c -c info is an integer output variable. if the user has -c terminated execution, info is set to the (negative) -c value of iflag. see description of fcn. otherwise, -c info is set as follows. -c -c info = 0 improper input parameters. -c -c info = 1 both actual and predicted relative reductions -c in the sum of squares are at most ftol. -c -c info = 2 relative error between two consecutive iterates -c is at most xtol. -c -c info = 3 conditions for info = 1 and info = 2 both hold. -c -c info = 4 the cosine of the angle between fvec and any -c column of the jacobian is at most gtol in -c absolute value. -c -c info = 5 number of calls to fcn with iflag = 1 has -c reached maxfev. -c -c info = 6 ftol is too small. no further reduction in -c the sum of squares is possible. -c -c info = 7 xtol is too small. no further improvement in -c the approximate solution x is possible. -c -c info = 8 gtol is too small. fvec is orthogonal to the -c columns of the jacobian to machine precision. -c -c nfev is an integer output variable set to the number of -c calls to fcn with iflag = 1. -c -c njev is an integer output variable set to the number of -c calls to fcn with iflag = 2. -c -c ipvt is an integer output array of length n. ipvt -c defines a permutation matrix p such that jac*p = q*r, -c where jac is the final calculated jacobian, q is -c orthogonal (not stored), and r is upper triangular. -c column j of p is column ipvt(j) of the identity matrix. -c -c qtf is an output array of length n which contains -c the first n elements of the vector (q transpose)*fvec. -c -c wa1, wa2, and wa3 are work arrays of length n. -c -c wa4 is a work array of length m. -c -c subprograms called -c -c user-supplied ...... fcn -c -c minpack-supplied ... dpmpar,enorm,lmpar,qrfac,rwupdt -c -c fortran-supplied ... dabs,dmax1,dmin1,dsqrt,mod -c -c argonne national laboratory. minpack project. march 1980. -c burton s. garbow, dudley v. goetschel, kenneth e. hillstrom, -c jorge j. more -c -c ********** - integer i,iflag,iter,j,l - double precision actred,delta,dirder,epsmch,fnorm,fnorm1,gnorm, - * one,par,pnorm,prered,p1,p5,p25,p75,p0001,ratio, - * sum,temp,temp1,temp2,xnorm,zero - double precision dpmpar,enorm - data one,p1,p5,p25,p75,p0001,zero - * /1.0d0,1.0d-1,5.0d-1,2.5d-1,7.5d-1,1.0d-4,0.0d0/ -c -c epsmch is the machine precision. -c - epsmch = dpmpar(1) -c - info = 0 - iflag = 0 - nfev = 0 - njev = 0 -c -c check the input parameters for errors. -c - if (n .le. 0 .or. m .lt. n .or. ldfjac .lt. n - * .or. ftol .lt. zero .or. xtol .lt. zero .or. gtol .lt. zero - * .or. maxfev .le. 0 .or. factor .le. zero) go to 340 - if (mode .ne. 2) go to 20 - do 10 j = 1, n - if (diag(j) .le. zero) go to 340 - 10 continue - 20 continue -c -c evaluate the function at the starting point -c and calculate its norm. -c - iflag = 1 - call fcn(m,n,x,fvec,wa3,iflag) - nfev = 1 - if (iflag .lt. 0) go to 340 - fnorm = enorm(m,fvec) -c -c initialize levenberg-marquardt parameter and iteration counter. -c - par = zero - iter = 1 -c -c beginning of the outer loop. -c - 30 continue -c -c if requested, call fcn to enable printing of iterates. -c - if (nprint .le. 0) go to 40 - iflag = 0 - if (mod(iter-1,nprint) .eq. 0) call fcn(m,n,x,fvec,wa3,iflag) - if (iflag .lt. 0) go to 340 - 40 continue -c -c compute the qr factorization of the jacobian matrix -c calculated one row at a time, while simultaneously -c forming (q transpose)*fvec and storing the first -c n components in qtf. -c - do 60 j = 1, n - qtf(j) = zero - do 50 i = 1, n - fjac(i,j) = zero - 50 continue - 60 continue - iflag = 2 - do 70 i = 1, m - call fcn(m,n,x,fvec,wa3,iflag) - if (iflag .lt. 0) go to 340 - temp = fvec(i) - call rwupdt(n,fjac,ldfjac,wa3,qtf,temp,wa1,wa2) - iflag = iflag + 1 - 70 continue - njev = njev + 1 -c -c if the jacobian is rank deficient, call qrfac to -c reorder its columns and update the components of qtf. -c - sing = .false. - do 80 j = 1, n - if (fjac(j,j) .eq. zero) sing = .true. - ipvt(j) = j - wa2(j) = enorm(j,fjac(1,j)) - 80 continue - if (.not.sing) go to 130 - call qrfac(n,n,fjac,ldfjac,.true.,ipvt,n,wa1,wa2,wa3) - do 120 j = 1, n - if (fjac(j,j) .eq. zero) go to 110 - sum = zero - do 90 i = j, n - sum = sum + fjac(i,j)*qtf(i) - 90 continue - temp = -sum/fjac(j,j) - do 100 i = j, n - qtf(i) = qtf(i) + fjac(i,j)*temp - 100 continue - 110 continue - fjac(j,j) = wa1(j) - 120 continue - 130 continue -c -c on the first iteration and if mode is 1, scale according -c to the norms of the columns of the initial jacobian. -c - if (iter .ne. 1) go to 170 - if (mode .eq. 2) go to 150 - do 140 j = 1, n - diag(j) = wa2(j) - if (wa2(j) .eq. zero) diag(j) = one - 140 continue - 150 continue -c -c on the first iteration, calculate the norm of the scaled x -c and initialize the step bound delta. -c - do 160 j = 1, n - wa3(j) = diag(j)*x(j) - 160 continue - xnorm = enorm(n,wa3) - delta = factor*xnorm - if (delta .eq. zero) delta = factor - 170 continue -c -c compute the norm of the scaled gradient. -c - gnorm = zero - if (fnorm .eq. zero) go to 210 - do 200 j = 1, n - l = ipvt(j) - if (wa2(l) .eq. zero) go to 190 - sum = zero - do 180 i = 1, j - sum = sum + fjac(i,j)*(qtf(i)/fnorm) - 180 continue - gnorm = dmax1(gnorm,dabs(sum/wa2(l))) - 190 continue - 200 continue - 210 continue -c -c test for convergence of the gradient norm. -c - if (gnorm .le. gtol) info = 4 - if (info .ne. 0) go to 340 -c -c rescale if necessary. -c - if (mode .eq. 2) go to 230 - do 220 j = 1, n - diag(j) = dmax1(diag(j),wa2(j)) - 220 continue - 230 continue -c -c beginning of the inner loop. -c - 240 continue -c -c determine the levenberg-marquardt parameter. -c - call lmpar(n,fjac,ldfjac,ipvt,diag,qtf,delta,par,wa1,wa2, - * wa3,wa4) -c -c store the direction p and x + p. calculate the norm of p. -c - do 250 j = 1, n - wa1(j) = -wa1(j) - wa2(j) = x(j) + wa1(j) - wa3(j) = diag(j)*wa1(j) - 250 continue - pnorm = enorm(n,wa3) -c -c on the first iteration, adjust the initial step bound. -c - if (iter .eq. 1) delta = dmin1(delta,pnorm) -c -c evaluate the function at x + p and calculate its norm. -c - iflag = 1 - call fcn(m,n,wa2,wa4,wa3,iflag) - nfev = nfev + 1 - if (iflag .lt. 0) go to 340 - fnorm1 = enorm(m,wa4) -c -c compute the scaled actual reduction. -c - actred = -one - if (p1*fnorm1 .lt. fnorm) actred = one - (fnorm1/fnorm)**2 -c -c compute the scaled predicted reduction and -c the scaled directional derivative. -c - do 270 j = 1, n - wa3(j) = zero - l = ipvt(j) - temp = wa1(l) - do 260 i = 1, j - wa3(i) = wa3(i) + fjac(i,j)*temp - 260 continue - 270 continue - temp1 = enorm(n,wa3)/fnorm - temp2 = (dsqrt(par)*pnorm)/fnorm - prered = temp1**2 + temp2**2/p5 - dirder = -(temp1**2 + temp2**2) -c -c compute the ratio of the actual to the predicted -c reduction. -c - ratio = zero - if (prered .ne. zero) ratio = actred/prered -c -c update the step bound. -c - if (ratio .gt. p25) go to 280 - if (actred .ge. zero) temp = p5 - if (actred .lt. zero) - * temp = p5*dirder/(dirder + p5*actred) - if (p1*fnorm1 .ge. fnorm .or. temp .lt. p1) temp = p1 - delta = temp*dmin1(delta,pnorm/p1) - par = par/temp - go to 300 - 280 continue - if (par .ne. zero .and. ratio .lt. p75) go to 290 - delta = pnorm/p5 - par = p5*par - 290 continue - 300 continue -c -c test for successful iteration. -c - if (ratio .lt. p0001) go to 330 -c -c successful iteration. update x, fvec, and their norms. -c - do 310 j = 1, n - x(j) = wa2(j) - wa2(j) = diag(j)*x(j) - 310 continue - do 320 i = 1, m - fvec(i) = wa4(i) - 320 continue - xnorm = enorm(n,wa2) - fnorm = fnorm1 - iter = iter + 1 - 330 continue -c -c tests for convergence. -c - if (dabs(actred) .le. ftol .and. prered .le. ftol - * .and. p5*ratio .le. one) info = 1 - if (delta .le. xtol*xnorm) info = 2 - if (dabs(actred) .le. ftol .and. prered .le. ftol - * .and. p5*ratio .le. one .and. info .eq. 2) info = 3 - if (info .ne. 0) go to 340 -c -c tests for termination and stringent tolerances. -c - if (nfev .ge. maxfev) info = 5 - if (dabs(actred) .le. epsmch .and. prered .le. epsmch - * .and. p5*ratio .le. one) info = 6 - if (delta .le. epsmch*xnorm) info = 7 - if (gnorm .le. epsmch) info = 8 - if (info .ne. 0) go to 340 -c -c end of the inner loop. repeat if iteration unsuccessful. -c - if (ratio .lt. p0001) go to 240 -c -c end of the outer loop. -c - go to 30 - 340 continue -c -c termination, either normal or user imposed. -c - if (iflag .lt. 0) info = iflag - iflag = 0 - if (nprint .gt. 0) call fcn(m,n,x,fvec,wa3,iflag) - return -c -c last card of subroutine lmstr. -c - end diff --git a/src/lmstr1.f b/src/lmstr1.f deleted file mode 100644 index 2fa8ee1..0000000 --- a/src/lmstr1.f +++ /dev/null @@ -1,156 +0,0 @@ - subroutine lmstr1(fcn,m,n,x,fvec,fjac,ldfjac,tol,info,ipvt,wa, - * lwa) - integer m,n,ldfjac,info,lwa - integer ipvt(n) - double precision tol - double precision x(n),fvec(m),fjac(ldfjac,n),wa(lwa) - external fcn -c ********** -c -c subroutine lmstr1 -c -c the purpose of lmstr1 is to minimize the sum of the squares of -c m nonlinear functions in n variables by a modification of -c the levenberg-marquardt algorithm which uses minimal storage. -c this is done by using the more general least-squares solver -c lmstr. the user must provide a subroutine which calculates -c the functions and the rows of the jacobian. -c -c the subroutine statement is -c -c subroutine lmstr1(fcn,m,n,x,fvec,fjac,ldfjac,tol,info, -c ipvt,wa,lwa) -c -c where -c -c fcn is the name of the user-supplied subroutine which -c calculates the functions and the rows of the jacobian. -c fcn must be declared in an external statement in the -c user calling program, and should be written as follows. -c -c subroutine fcn(m,n,x,fvec,fjrow,iflag) -c integer m,n,iflag -c double precision x(n),fvec(m),fjrow(n) -c ---------- -c if iflag = 1 calculate the functions at x and -c return this vector in fvec. -c if iflag = i calculate the (i-1)-st row of the -c jacobian at x and return this vector in fjrow. -c ---------- -c return -c end -c -c the value of iflag should not be changed by fcn unless -c the user wants to terminate execution of lmstr1. -c in this case set iflag to a negative integer. -c -c m is a positive integer input variable set to the number -c of functions. -c -c n is a positive integer input variable set to the number -c of variables. n must not exceed m. -c -c x is an array of length n. on input x must contain -c an initial estimate of the solution vector. on output x -c contains the final estimate of the solution vector. -c -c fvec is an output array of length m which contains -c the functions evaluated at the output x. -c -c fjac is an output n by n array. the upper triangle of fjac -c contains an upper triangular matrix r such that -c -c t t t -c p *(jac *jac)*p = r *r, -c -c where p is a permutation matrix and jac is the final -c calculated jacobian. column j of p is column ipvt(j) -c (see below) of the identity matrix. the lower triangular -c part of fjac contains information generated during -c the computation of r. -c -c ldfjac is a positive integer input variable not less than n -c which specifies the leading dimension of the array fjac. -c -c tol is a nonnegative input variable. termination occurs -c when the algorithm estimates either that the relative -c error in the sum of squares is at most tol or that -c the relative error between x and the solution is at -c most tol. -c -c info is an integer output variable. if the user has -c terminated execution, info is set to the (negative) -c value of iflag. see description of fcn. otherwise, -c info is set as follows. -c -c info = 0 improper input parameters. -c -c info = 1 algorithm estimates that the relative error -c in the sum of squares is at most tol. -c -c info = 2 algorithm estimates that the relative error -c between x and the solution is at most tol. -c -c info = 3 conditions for info = 1 and info = 2 both hold. -c -c info = 4 fvec is orthogonal to the columns of the -c jacobian to machine precision. -c -c info = 5 number of calls to fcn with iflag = 1 has -c reached 100*(n+1). -c -c info = 6 tol is too small. no further reduction in -c the sum of squares is possible. -c -c info = 7 tol is too small. no further improvement in -c the approximate solution x is possible. -c -c ipvt is an integer output array of length n. ipvt -c defines a permutation matrix p such that jac*p = q*r, -c where jac is the final calculated jacobian, q is -c orthogonal (not stored), and r is upper triangular. -c column j of p is column ipvt(j) of the identity matrix. -c -c wa is a work array of length lwa. -c -c lwa is a positive integer input variable not less than 5*n+m. -c -c subprograms called -c -c user-supplied ...... fcn -c -c minpack-supplied ... lmstr -c -c argonne national laboratory. minpack project. march 1980. -c burton s. garbow, dudley v. goetschel, kenneth e. hillstrom, -c jorge j. more -c -c ********** - integer maxfev,mode,nfev,njev,nprint - double precision factor,ftol,gtol,xtol,zero - data factor,zero /1.0d2,0.0d0/ - info = 0 -c -c check the input parameters for errors. -c - if (n .le. 0 .or. m .lt. n .or. ldfjac .lt. n .or. tol .lt. zero - * .or. lwa .lt. 5*n + m) go to 10 -c -c call lmstr. -c - maxfev = 100*(n + 1) - ftol = tol - xtol = tol - gtol = zero - mode = 1 - nprint = 0 - call lmstr(fcn,m,n,x,fvec,fjac,ldfjac,ftol,xtol,gtol,maxfev, - * wa(1),mode,factor,nprint,info,nfev,njev,ipvt,wa(n+1), - * wa(2*n+1),wa(3*n+1),wa(4*n+1),wa(5*n+1)) - if (info .eq. 8) info = 4 - 10 continue - return -c -c last card of subroutine lmstr1. -c - end diff --git a/src/minpack.f90 b/src/minpack.f90 deleted file mode 100644 index 294b144..0000000 --- a/src/minpack.f90 +++ /dev/null @@ -1,89 +0,0 @@ -module minpack -implicit none - -interface - - double precision function dpmpar(i) - integer i - end function - - double precision function enorm(n,x) - integer n - double precision x(n) - end function - - !> The purpose of `hybrd` is to find a zero of a system of N non- - !> linear functions in N variables by a modification of the Powell - !> hybrid method. The user must provide a subroutine which calcu- - !> lates the functions. The Jacobian is then calculated by a for- - !> ward-difference approximation. - subroutine hybrd(fcn,n,x,fvec,xtol,maxfev,ml,mu,epsfcn,diag, & - mode,factor,nprint,info,nfev,fjac,ldfjac, & - r,lr,qtf,wa1,wa2,wa3,wa4) - integer n,maxfev,ml,mu,mode,nprint,info,nfev,ldfjac,lr - double precision xtol,epsfcn,factor - double precision x(n),fvec(n),diag(n),fjac(ldfjac,n),r(lr),qtf(n), & - wa1(n),wa2(n),wa3(n),wa4(n) - interface - subroutine fcn(n,x,fvec,iflag) - integer n,iflag - double precision x(n),fvec(n) - end subroutine fcn - end interface - end subroutine hybrd - - !> The purpose of `hybrd1` is to find a zero of a system of - !> n nonlinear functions in n variables by a modification - !> of the powell hybrid method. - subroutine hybrd1(fcn,n,x,fvec,tol,info,wa,lwa) - integer n,info,lwa - double precision tol - double precision x(n),fvec(n),wa(lwa) - interface - subroutine fcn(n,x,fvec,iflag) - integer n,iflag - double precision x(n),fvec(n) - end subroutine fcn - end interface - end subroutine hybrd1 - - subroutine lmder1(fcn,m,n,x,fvec,fjac,ldfjac,tol,info,ipvt,wa,lwa) - integer m,n,ldfjac,info,lwa - integer ipvt(n) - double precision tol - double precision x(n),fvec(m),fjac(ldfjac,n),wa(lwa) - interface - subroutine fcn(m,n,x,fvec,fjac,ldfjac,iflag) - implicit none - integer, intent(in) :: m,n,ldfjac,iflag - double precision, intent(in) :: x(n) - double precision, intent(out) :: fvec(m),fjac(ldfjac,n) - end subroutine - end interface - end subroutine - - subroutine lmdif1(fcn,m,n,x,fvec,tol,info,iwa,wa,lwa) - integer m,n,info,lwa - integer iwa(n) - double precision tol - double precision x(n),fvec(m),wa(lwa) - interface - subroutine fcn(m,n,x,fvec,iflag) - implicit none - integer, intent(in) :: m,n,iflag - double precision, intent(in) :: x(n) - double precision, intent(out) :: fvec(m) - end subroutine - end interface - end subroutine - - subroutine chkder(m,n,x,fvec,fjac,ldfjac,xp,fvecp,mode,err) - integer m,n,ldfjac,mode - double precision x(n),fvec(m),fjac(ldfjac,n),xp(n),fvecp(m),err(m) - end subroutine - -end interface - -contains - -end module diff --git a/src/objfcn.f b/src/objfcn.f deleted file mode 100644 index 979325d..0000000 --- a/src/objfcn.f +++ /dev/null @@ -1,342 +0,0 @@ - subroutine objfcn(n,x,f,nprob) - integer n,nprob - double precision f - double precision x(n) -c ********** -c -c subroutine objfcn -c -c this subroutine defines the objective functions of eighteen -c nonlinear unconstrained minimization problems. the values -c of n for functions 1,2,3,4,5,10,11,12,16 and 17 are -c 3,6,3,2,3,2,4,3,2 and 4, respectively. -c for function 7, n may be 2 or greater but is usually 6 or 9. -c for functions 6,8,9,13,14,15 and 18 n may be variable, -c however it must be even for function 14, a multiple of 4 for -c function 15, and not greater than 50 for function 18. -c -c the subroutine statement is -c -c subroutine objfcn(n,x,f,nprob) -c -c where -c -c n is a positive integer input variable. -c -c x is an input array of length n. -c -c f is an output variable which contains the value of -c the nprob objective function evaluated at x. -c -c nprob is a positive integer input variable which defines the -c number of the problem. nprob must not exceed 18. -c -c subprograms called -c -c fortran-supplied ... dabs,datan,dcos,dexp,dlog,dsign,dsin, -c dsqrt -c -c argonne national laboratory. minpack project. march 1980. -c burton s. garbow, kenneth e. hillstrom, jorge j. more -c -c ********** - integer i,iev,ivar,j - double precision ap,arg,c2pdm6,cp0001,cp1,cp2,cp25,cp5,c1p5, - * c2p25,c2p625,c3p5,c25,c29,c90,c100,c10000, - * c1pd6,d1,d2,eight,fifty,five,four,one,r,s1,s2, - * s3,t,t1,t2,t3,ten,th,three,tpi,two,zero - double precision fvec(50),y(15) - double precision dfloat - data zero,one,two,three,four,five,eight,ten,fifty - * /0.0d0,1.0d0,2.0d0,3.0d0,4.0d0,5.0d0,8.0d0,1.0d1,5.0d1/ - data c2pdm6,cp0001,cp1,cp2,cp25,cp5,c1p5,c2p25,c2p625,c3p5,c25, - * c29,c90,c100,c10000,c1pd6 - * /2.0d-6,1.0d-4,1.0d-1,2.0d-1,2.5d-1,5.0d-1,1.5d0,2.25d0, - * 2.625d0,3.5d0,2.5d1,2.9d1,9.0d1,1.0d2,1.0d4,1.0d6/ - data ap /1.0d-5/ - data y(1),y(2),y(3),y(4),y(5),y(6),y(7),y(8),y(9),y(10),y(11), - * y(12),y(13),y(14),y(15) - * /9.0d-4,4.4d-3,1.75d-2,5.4d-2,1.295d-1,2.42d-1,3.521d-1, - * 3.989d-1,3.521d-1,2.42d-1,1.295d-1,5.4d-2,1.75d-2,4.4d-3, - * 9.0d-4/ - dfloat(ivar) = ivar -c -c function routine selector. -c - go to (10,20,40,60,70,90,110,150,170,200,210,230,250,280,300, - * 320,330,340), nprob -c -c helical valley function. -c - 10 continue - tpi = eight*datan(one) - th = dsign(cp25,x(2)) - if (x(1) .gt. zero) th = datan(x(2)/x(1))/tpi - if (x(1) .lt. zero) th = datan(x(2)/x(1))/tpi + cp5 - arg = x(1)**2 + x(2)**2 - r = dsqrt(arg) - t = x(3) - ten*th - f = c100*(t**2 + (r - one)**2) + x(3)**2 - go to 390 -c -c biggs exp6 function. -c - 20 continue - f = zero - do 30 i = 1, 13 - d1 = dfloat(i)/ten - d2 = dexp(-d1) - five*dexp(-ten*d1) + three*dexp(-four*d1) - s1 = dexp(-d1*x(1)) - s2 = dexp(-d1*x(2)) - s3 = dexp(-d1*x(5)) - t = x(3)*s1 - x(4)*s2 + x(6)*s3 - d2 - f = f + t**2 - 30 continue - go to 390 -c -c gaussian function. -c - 40 continue - f = zero - do 50 i = 1, 15 - d1 = cp5*dfloat(i-1) - d2 = c3p5 - d1 - x(3) - arg = -cp5*x(2)*d2**2 - r = dexp(arg) - t = x(1)*r - y(i) - f = f + t**2 - 50 continue - go to 390 -c -c powell badly scaled function. -c - 60 continue - t1 = c10000*x(1)*x(2) - one - s1 = dexp(-x(1)) - s2 = dexp(-x(2)) - t2 = s1 + s2 - one - cp0001 - f = t1**2 + t2**2 - go to 390 -c -c box 3-dimensional function. -c - 70 continue - f = zero - do 80 i = 1, 10 - d1 = dfloat(i) - d2 = d1/ten - s1 = dexp(-d2*x(1)) - s2 = dexp(-d2*x(2)) - s3 = dexp(-d2) - dexp(-d1) - t = s1 - s2 - s3*x(3) - f = f + t**2 - 80 continue - go to 390 -c -c variably dimensioned function. -c - 90 continue - t1 = zero - t2 = zero - do 100 j = 1, n - t1 = t1 + dfloat(j)*(x(j) - one) - t2 = t2 + (x(j) - one)**2 - 100 continue - f = t2 + t1**2*(one + t1**2) - go to 390 -c -c watson function. -c - 110 continue - f = zero - do 140 i = 1, 29 - d1 = dfloat(i)/c29 - s1 = zero - d2 = one - do 120 j = 2, n - s1 = s1 + dfloat(j-1)*d2*x(j) - d2 = d1*d2 - 120 continue - s2 = zero - d2 = one - do 130 j = 1, n - s2 = s2 + d2*x(j) - d2 = d1*d2 - 130 continue - t = s1 - s2**2 - one - f = f + t**2 - 140 continue - t1 = x(2) - x(1)**2 - one - f = f + x(1)**2 + t1**2 - go to 390 -c -c penalty function i. -c - 150 continue - t1 = -cp25 - t2 = zero - do 160 j = 1, n - t1 = t1 + x(j)**2 - t2 = t2 + (x(j) - one)**2 - 160 continue - f = ap*t2 + t1**2 - go to 390 -c -c penalty function ii. -c - 170 continue - t1 = -one - t2 = zero - t3 = zero - d1 = dexp(cp1) - d2 = one - do 190 j = 1, n - t1 = t1 + dfloat(n-j+1)*x(j)**2 - s1 = dexp(x(j)/ten) - if (j .eq. 1) go to 180 - s3 = s1 + s2 - d2*(d1 + one) - t2 = t2 + s3**2 - t3 = t3 + (s1 - one/d1)**2 - 180 continue - s2 = s1 - d2 = d1*d2 - 190 continue - f = ap*(t2 + t3) + t1**2 + (x(1) - cp2)**2 - go to 390 -c -c brown badly scaled function. -c - 200 continue - t1 = x(1) - c1pd6 - t2 = x(2) - c2pdm6 - t3 = x(1)*x(2) - two - f = t1**2 + t2**2 + t3**2 - go to 390 -c -c brown and dennis function. -c - 210 continue - f = zero - do 220 i = 1, 20 - d1 = dfloat(i)/five - d2 = dsin(d1) - t1 = x(1) + d1*x(2) - dexp(d1) - t2 = x(3) + d2*x(4) - dcos(d1) - t = t1**2 + t2**2 - f = f + t**2 - 220 continue - go to 390 -c -c gulf research and development function. -c - 230 continue - f = zero - d1 = two/three - do 240 i = 1, 99 - arg = dfloat(i)/c100 - r = (-fifty*dlog(arg))**d1 + c25 - x(2) - t1 = dabs(r)**x(3)/x(1) - t2 = dexp(-t1) - t = t2 - arg - f = f + t**2 - 240 continue - go to 390 -c -c trigonometric function. -c - 250 continue - s1 = zero - do 260 j = 1, n - s1 = s1 + dcos(x(j)) - 260 continue - f = zero - do 270 j = 1, n - t = dfloat(n+j) - dsin(x(j)) - s1 - dfloat(j)*dcos(x(j)) - f = f + t**2 - 270 continue - go to 390 -c -c extended rosenbrock function. -c - 280 continue - f = zero - do 290 j = 1, n, 2 - t1 = one - x(j) - t2 = ten*(x(j+1) - x(j)**2) - f = f + t1**2 + t2**2 - 290 continue - go to 390 -c -c extended powell function. -c - 300 continue - f = zero - do 310 j = 1, n, 4 - t = x(j) + ten*x(j+1) - t1 = x(j+2) - x(j+3) - s1 = five*t1 - t2 = x(j+1) - two*x(j+2) - s2 = t2**3 - t3 = x(j) - x(j+3) - s3 = ten*t3**3 - f = f + t**2 + s1*t1 + s2*t2 + s3*t3 - 310 continue - go to 390 -c -c beale function. -c - 320 continue - s1 = one - x(2) - t1 = c1p5 - x(1)*s1 - s2 = one - x(2)**2 - t2 = c2p25 - x(1)*s2 - s3 = one - x(2)**3 - t3 = c2p625 - x(1)*s3 - f = t1**2 + t2**2 + t3**2 - go to 390 -c -c wood function. -c - 330 continue - s1 = x(2) - x(1)**2 - s2 = one - x(1) - s3 = x(2) - one - t1 = x(4) - x(3)**2 - t2 = one - x(3) - t3 = x(4) - one - f = c100*s1**2 + s2**2 + c90*t1**2 + t2**2 + ten*(s3 + t3)**2 - * + (s3 - t3)**2/ten - go to 390 -c -c chebyquad function. -c - 340 continue - do 350 i = 1, n - fvec(i) = zero - 350 continue - do 370 j = 1, n - t1 = one - t2 = two*x(j) - one - t = two*t2 - do 360 i = 1, n - fvec(i) = fvec(i) + t2 - th = t*t2 - t1 - t1 = t2 - t2 = th - 360 continue - 370 continue - f = zero - d1 = one/dfloat(n) - iev = -1 - do 380 i = 1, n - t = d1*fvec(i) - if (iev .gt. 0) t = t + one/(dfloat(i)**2 - one) - f = f + t**2 - iev = -iev - 380 continue - 390 continue - return -c -c last card of subroutine objfcn. -c - end diff --git a/src/ocpipt.f b/src/ocpipt.f deleted file mode 100644 index 762ae9e..0000000 --- a/src/ocpipt.f +++ /dev/null @@ -1,223 +0,0 @@ - subroutine initpt(n,x,nprob,factor) - integer n,nprob - double precision factor - double precision x(n) -c ********** -c -c subroutine initpt -c -c this subroutine specifies the standard starting points for the -c functions defined by subroutine objfcn. the subroutine returns -c in x a multiple (factor) of the standard starting point. for -c the seventh function the standard starting point is zero, so in -c this case, if factor is not unity, then the subroutine returns -c the vector x(j) = factor, j=1,...,n. -c -c the subroutine statement is -c -c subroutine initpt(n,x,nprob,factor) -c -c where -c -c n is a positive integer input variable. -c -c x is an output array of length n which contains the standard -c starting point for problem nprob multiplied by factor. -c -c nprob is a positive integer input variable which defines the -c number of the problem. nprob must not exceed 18. -c -c factor is an input variable which specifies the multiple of -c the standard starting point. if factor is unity, no -c multiplication is performed. -c -c argonne national laboratory. minpack project. march 1980. -c burton s. garbow, kenneth e. hillstrom, jorge j. more -c -c ********** - integer ivar,j - double precision c1,c2,c3,c4,five,h,half,one,ten,three,twenty, - * twntf,two,zero - double precision dfloat - data zero,half,one,two,three,five,ten,twenty,twntf - * /0.0d0,0.5d0,1.0d0,2.0d0,3.0d0,5.0d0,1.0d1,2.0d1,2.5d1/ - data c1,c2,c3,c4 /4.0d-1,2.5d0,1.5d-1,1.2d0/ - dfloat(ivar) = ivar -c -c selection of initial point. -c - go to (10,20,30,40,50,60,80,100,120,140,150,160,170,190,210,230, - * 240,250), nprob -c -c helical valley function. -c - 10 continue - x(1) = -one - x(2) = zero - x(3) = zero - go to 270 -c -c biggs exp6 function. -c - 20 continue - x(1) = one - x(2) = two - x(3) = one - x(4) = one - x(5) = one - x(6) = one - go to 270 -c -c gaussian function. -c - 30 continue - x(1) = c1 - x(2) = one - x(3) = zero - go to 270 -c -c powell badly scaled function. -c - 40 continue - x(1) = zero - x(2) = one - go to 270 -c -c box 3-dimensional function. -c - 50 continue - x(1) = zero - x(2) = ten - x(3) = twenty - go to 270 -c -c variably dimensioned function. -c - 60 continue - h = one/dfloat(n) - do 70 j = 1, n - x(j) = one - dfloat(j)*h - 70 continue - go to 270 -c -c watson function. -c - 80 continue - do 90 j = 1, n - x(j) = zero - 90 continue - go to 270 -c -c penalty function i. -c - 100 continue - do 110 j = 1, n - x(j) = dfloat(j) - 110 continue - go to 270 -c -c penalty function ii. -c - 120 continue - do 130 j = 1, n - x(j) = half - 130 continue - go to 270 -c -c brown badly scaled function. -c - 140 continue - x(1) = one - x(2) = one - go to 270 -c -c brown and dennis function. -c - 150 continue - x(1) = twntf - x(2) = five - x(3) = -five - x(4) = -one - go to 270 -c -c gulf research and development function. -c - 160 continue - x(1) = five - x(2) = c2 - x(3) = c3 - go to 270 -c -c trigonometric function. -c - 170 continue - h = one/dfloat(n) - do 180 j = 1, n - x(j) = h - 180 continue - go to 270 -c -c extended rosenbrock function. -c - 190 continue - do 200 j = 1, n, 2 - x(j) = -c4 - x(j+1) = one - 200 continue - go to 270 -c -c extended powell singular function. -c - 210 continue - do 220 j = 1, n, 4 - x(j) = three - x(j+1) = -one - x(j+2) = zero - x(j+3) = one - 220 continue - go to 270 -c -c beale function. -c - 230 continue - x(1) = one - x(2) = one - go to 270 -c -c wood function. -c - 240 continue - x(1) = -three - x(2) = -one - x(3) = -three - x(4) = -one - go to 270 -c -c chebyquad function. -c - 250 continue - h = one/dfloat(n+1) - do 260 j = 1, n - x(j) = dfloat(j)*h - 260 continue - 270 continue -c -c compute multiple of initial point. -c - if (factor .eq. one) go to 320 - if (nprob .eq. 7) go to 290 - do 280 j = 1, n - x(j) = factor*x(j) - 280 continue - go to 310 - 290 continue - do 300 j = 1, n - x(j) = factor - 300 continue - 310 continue - 320 continue - return -c -c last card of subroutine initpt. -c - end diff --git a/src/qform.f b/src/qform.f deleted file mode 100644 index 087b247..0000000 --- a/src/qform.f +++ /dev/null @@ -1,95 +0,0 @@ - subroutine qform(m,n,q,ldq,wa) - integer m,n,ldq - double precision q(ldq,m),wa(m) -c ********** -c -c subroutine qform -c -c this subroutine proceeds from the computed qr factorization of -c an m by n matrix a to accumulate the m by m orthogonal matrix -c q from its factored form. -c -c the subroutine statement is -c -c subroutine qform(m,n,q,ldq,wa) -c -c where -c -c m is a positive integer input variable set to the number -c of rows of a and the order of q. -c -c n is a positive integer input variable set to the number -c of columns of a. -c -c q is an m by m array. on input the full lower trapezoid in -c the first min(m,n) columns of q contains the factored form. -c on output q has been accumulated into a square matrix. -c -c ldq is a positive integer input variable not less than m -c which specifies the leading dimension of the array q. -c -c wa is a work array of length m. -c -c subprograms called -c -c fortran-supplied ... min0 -c -c argonne national laboratory. minpack project. march 1980. -c burton s. garbow, kenneth e. hillstrom, jorge j. more -c -c ********** - integer i,j,jm1,k,l,minmn,np1 - double precision one,sum,temp,zero - data one,zero /1.0d0,0.0d0/ -c -c zero out upper triangle of q in the first min(m,n) columns. -c - minmn = min0(m,n) - if (minmn .lt. 2) go to 30 - do 20 j = 2, minmn - jm1 = j - 1 - do 10 i = 1, jm1 - q(i,j) = zero - 10 continue - 20 continue - 30 continue -c -c initialize remaining columns to those of the identity matrix. -c - np1 = n + 1 - if (m .lt. np1) go to 60 - do 50 j = np1, m - do 40 i = 1, m - q(i,j) = zero - 40 continue - q(j,j) = one - 50 continue - 60 continue -c -c accumulate q from its factored form. -c - do 120 l = 1, minmn - k = minmn - l + 1 - do 70 i = k, m - wa(i) = q(i,k) - q(i,k) = zero - 70 continue - q(k,k) = one - if (wa(k) .eq. zero) go to 110 - do 100 j = k, m - sum = zero - do 80 i = k, m - sum = sum + q(i,j)*wa(i) - 80 continue - temp = sum/wa(k) - do 90 i = k, m - q(i,j) = q(i,j) - temp*wa(i) - 90 continue - 100 continue - 110 continue - 120 continue - return -c -c last card of subroutine qform. -c - end diff --git a/src/qrfac.f b/src/qrfac.f deleted file mode 100644 index cb68608..0000000 --- a/src/qrfac.f +++ /dev/null @@ -1,164 +0,0 @@ - subroutine qrfac(m,n,a,lda,pivot,ipvt,lipvt,rdiag,acnorm,wa) - integer m,n,lda,lipvt - integer ipvt(lipvt) - logical pivot - double precision a(lda,n),rdiag(n),acnorm(n),wa(n) -c ********** -c -c subroutine qrfac -c -c this subroutine uses householder transformations with column -c pivoting (optional) to compute a qr factorization of the -c m by n matrix a. that is, qrfac determines an orthogonal -c matrix q, a permutation matrix p, and an upper trapezoidal -c matrix r with diagonal elements of nonincreasing magnitude, -c such that a*p = q*r. the householder transformation for -c column k, k = 1,2,...,min(m,n), is of the form -c -c t -c i - (1/u(k))*u*u -c -c where u has zeros in the first k-1 positions. the form of -c this transformation and the method of pivoting first -c appeared in the corresponding linpack subroutine. -c -c the subroutine statement is -c -c subroutine qrfac(m,n,a,lda,pivot,ipvt,lipvt,rdiag,acnorm,wa) -c -c where -c -c m is a positive integer input variable set to the number -c of rows of a. -c -c n is a positive integer input variable set to the number -c of columns of a. -c -c a is an m by n array. on input a contains the matrix for -c which the qr factorization is to be computed. on output -c the strict upper trapezoidal part of a contains the strict -c upper trapezoidal part of r, and the lower trapezoidal -c part of a contains a factored form of q (the non-trivial -c elements of the u vectors described above). -c -c lda is a positive integer input variable not less than m -c which specifies the leading dimension of the array a. -c -c pivot is a logical input variable. if pivot is set true, -c then column pivoting is enforced. if pivot is set false, -c then no column pivoting is done. -c -c ipvt is an integer output array of length lipvt. ipvt -c defines the permutation matrix p such that a*p = q*r. -c column j of p is column ipvt(j) of the identity matrix. -c if pivot is false, ipvt is not referenced. -c -c lipvt is a positive integer input variable. if pivot is false, -c then lipvt may be as small as 1. if pivot is true, then -c lipvt must be at least n. -c -c rdiag is an output array of length n which contains the -c diagonal elements of r. -c -c acnorm is an output array of length n which contains the -c norms of the corresponding columns of the input matrix a. -c if this information is not needed, then acnorm can coincide -c with rdiag. -c -c wa is a work array of length n. if pivot is false, then wa -c can coincide with rdiag. -c -c subprograms called -c -c minpack-supplied ... dpmpar,enorm -c -c fortran-supplied ... dmax1,dsqrt,min0 -c -c argonne national laboratory. minpack project. march 1980. -c burton s. garbow, kenneth e. hillstrom, jorge j. more -c -c ********** - integer i,j,jp1,k,kmax,minmn - double precision ajnorm,epsmch,one,p05,sum,temp,zero - double precision dpmpar,enorm - data one,p05,zero /1.0d0,5.0d-2,0.0d0/ -c -c epsmch is the machine precision. -c - epsmch = dpmpar(1) -c -c compute the initial column norms and initialize several arrays. -c - do 10 j = 1, n - acnorm(j) = enorm(m,a(1,j)) - rdiag(j) = acnorm(j) - wa(j) = rdiag(j) - if (pivot) ipvt(j) = j - 10 continue -c -c reduce a to r with householder transformations. -c - minmn = min0(m,n) - do 110 j = 1, minmn - if (.not.pivot) go to 40 -c -c bring the column of largest norm into the pivot position. -c - kmax = j - do 20 k = j, n - if (rdiag(k) .gt. rdiag(kmax)) kmax = k - 20 continue - if (kmax .eq. j) go to 40 - do 30 i = 1, m - temp = a(i,j) - a(i,j) = a(i,kmax) - a(i,kmax) = temp - 30 continue - rdiag(kmax) = rdiag(j) - wa(kmax) = wa(j) - k = ipvt(j) - ipvt(j) = ipvt(kmax) - ipvt(kmax) = k - 40 continue -c -c compute the householder transformation to reduce the -c j-th column of a to a multiple of the j-th unit vector. -c - ajnorm = enorm(m-j+1,a(j,j)) - if (ajnorm .eq. zero) go to 100 - if (a(j,j) .lt. zero) ajnorm = -ajnorm - do 50 i = j, m - a(i,j) = a(i,j)/ajnorm - 50 continue - a(j,j) = a(j,j) + one -c -c apply the transformation to the remaining columns -c and update the norms. -c - jp1 = j + 1 - if (n .lt. jp1) go to 100 - do 90 k = jp1, n - sum = zero - do 60 i = j, m - sum = sum + a(i,j)*a(i,k) - 60 continue - temp = sum/a(j,j) - do 70 i = j, m - a(i,k) = a(i,k) - temp*a(i,j) - 70 continue - if (.not.pivot .or. rdiag(k) .eq. zero) go to 80 - temp = a(j,k)/rdiag(k) - rdiag(k) = rdiag(k)*dsqrt(dmax1(zero,one-temp**2)) - if (p05*(rdiag(k)/wa(k))**2 .gt. epsmch) go to 80 - rdiag(k) = enorm(m-j,a(jp1,k)) - wa(k) = rdiag(k) - 80 continue - 90 continue - 100 continue - rdiag(j) = -ajnorm - 110 continue - return -c -c last card of subroutine qrfac. -c - end diff --git a/src/qrsolv.f b/src/qrsolv.f deleted file mode 100644 index f48954b..0000000 --- a/src/qrsolv.f +++ /dev/null @@ -1,193 +0,0 @@ - subroutine qrsolv(n,r,ldr,ipvt,diag,qtb,x,sdiag,wa) - integer n,ldr - integer ipvt(n) - double precision r(ldr,n),diag(n),qtb(n),x(n),sdiag(n),wa(n) -c ********** -c -c subroutine qrsolv -c -c given an m by n matrix a, an n by n diagonal matrix d, -c and an m-vector b, the problem is to determine an x which -c solves the system -c -c a*x = b , d*x = 0 , -c -c in the least squares sense. -c -c this subroutine completes the solution of the problem -c if it is provided with the necessary information from the -c qr factorization, with column pivoting, of a. that is, if -c a*p = q*r, where p is a permutation matrix, q has orthogonal -c columns, and r is an upper triangular matrix with diagonal -c elements of nonincreasing magnitude, then qrsolv expects -c the full upper triangle of r, the permutation matrix p, -c and the first n components of (q transpose)*b. the system -c a*x = b, d*x = 0, is then equivalent to -c -c t t -c r*z = q *b , p *d*p*z = 0 , -c -c where x = p*z. if this system does not have full rank, -c then a least squares solution is obtained. on output qrsolv -c also provides an upper triangular matrix s such that -c -c t t t -c p *(a *a + d*d)*p = s *s . -c -c s is computed within qrsolv and may be of separate interest. -c -c the subroutine statement is -c -c subroutine qrsolv(n,r,ldr,ipvt,diag,qtb,x,sdiag,wa) -c -c where -c -c n is a positive integer input variable set to the order of r. -c -c r is an n by n array. on input the full upper triangle -c must contain the full upper triangle of the matrix r. -c on output the full upper triangle is unaltered, and the -c strict lower triangle contains the strict upper triangle -c (transposed) of the upper triangular matrix s. -c -c ldr is a positive integer input variable not less than n -c which specifies the leading dimension of the array r. -c -c ipvt is an integer input array of length n which defines the -c permutation matrix p such that a*p = q*r. column j of p -c is column ipvt(j) of the identity matrix. -c -c diag is an input array of length n which must contain the -c diagonal elements of the matrix d. -c -c qtb is an input array of length n which must contain the first -c n elements of the vector (q transpose)*b. -c -c x is an output array of length n which contains the least -c squares solution of the system a*x = b, d*x = 0. -c -c sdiag is an output array of length n which contains the -c diagonal elements of the upper triangular matrix s. -c -c wa is a work array of length n. -c -c subprograms called -c -c fortran-supplied ... dabs,dsqrt -c -c argonne national laboratory. minpack project. march 1980. -c burton s. garbow, kenneth e. hillstrom, jorge j. more -c -c ********** - integer i,j,jp1,k,kp1,l,nsing - double precision cos,cotan,p5,p25,qtbpj,sin,sum,tan,temp,zero - data p5,p25,zero /5.0d-1,2.5d-1,0.0d0/ -c -c copy r and (q transpose)*b to preserve input and initialize s. -c in particular, save the diagonal elements of r in x. -c - do 20 j = 1, n - do 10 i = j, n - r(i,j) = r(j,i) - 10 continue - x(j) = r(j,j) - wa(j) = qtb(j) - 20 continue -c -c eliminate the diagonal matrix d using a givens rotation. -c - do 100 j = 1, n -c -c prepare the row of d to be eliminated, locating the -c diagonal element using p from the qr factorization. -c - l = ipvt(j) - if (diag(l) .eq. zero) go to 90 - do 30 k = j, n - sdiag(k) = zero - 30 continue - sdiag(j) = diag(l) -c -c the transformations to eliminate the row of d -c modify only a single element of (q transpose)*b -c beyond the first n, which is initially zero. -c - qtbpj = zero - do 80 k = j, n -c -c determine a givens rotation which eliminates the -c appropriate element in the current row of d. -c - if (sdiag(k) .eq. zero) go to 70 - if (dabs(r(k,k)) .ge. dabs(sdiag(k))) go to 40 - cotan = r(k,k)/sdiag(k) - sin = p5/dsqrt(p25+p25*cotan**2) - cos = sin*cotan - go to 50 - 40 continue - tan = sdiag(k)/r(k,k) - cos = p5/dsqrt(p25+p25*tan**2) - sin = cos*tan - 50 continue -c -c compute the modified diagonal element of r and -c the modified element of ((q transpose)*b,0). -c - r(k,k) = cos*r(k,k) + sin*sdiag(k) - temp = cos*wa(k) + sin*qtbpj - qtbpj = -sin*wa(k) + cos*qtbpj - wa(k) = temp -c -c accumulate the tranformation in the row of s. -c - kp1 = k + 1 - if (n .lt. kp1) go to 70 - do 60 i = kp1, n - temp = cos*r(i,k) + sin*sdiag(i) - sdiag(i) = -sin*r(i,k) + cos*sdiag(i) - r(i,k) = temp - 60 continue - 70 continue - 80 continue - 90 continue -c -c store the diagonal element of s and restore -c the corresponding diagonal element of r. -c - sdiag(j) = r(j,j) - r(j,j) = x(j) - 100 continue -c -c solve the triangular system for z. if the system is -c singular, then obtain a least squares solution. -c - nsing = n - do 110 j = 1, n - if (sdiag(j) .eq. zero .and. nsing .eq. n) nsing = j - 1 - if (nsing .lt. n) wa(j) = zero - 110 continue - if (nsing .lt. 1) go to 150 - do 140 k = 1, nsing - j = nsing - k + 1 - sum = zero - jp1 = j + 1 - if (nsing .lt. jp1) go to 130 - do 120 i = jp1, nsing - sum = sum + r(i,j)*wa(i) - 120 continue - 130 continue - wa(j) = (wa(j) - sum)/sdiag(j) - 140 continue - 150 continue -c -c permute the components of z back to components of x. -c - do 160 j = 1, n - l = ipvt(j) - x(l) = wa(j) - 160 continue - return -c -c last card of subroutine qrsolv. -c - end diff --git a/src/r1mpyq.f b/src/r1mpyq.f deleted file mode 100644 index ec99b96..0000000 --- a/src/r1mpyq.f +++ /dev/null @@ -1,92 +0,0 @@ - subroutine r1mpyq(m,n,a,lda,v,w) - integer m,n,lda - double precision a(lda,n),v(n),w(n) -c ********** -c -c subroutine r1mpyq -c -c given an m by n matrix a, this subroutine computes a*q where -c q is the product of 2*(n - 1) transformations -c -c gv(n-1)*...*gv(1)*gw(1)*...*gw(n-1) -c -c and gv(i), gw(i) are givens rotations in the (i,n) plane which -c eliminate elements in the i-th and n-th planes, respectively. -c q itself is not given, rather the information to recover the -c gv, gw rotations is supplied. -c -c the subroutine statement is -c -c subroutine r1mpyq(m,n,a,lda,v,w) -c -c where -c -c m is a positive integer input variable set to the number -c of rows of a. -c -c n is a positive integer input variable set to the number -c of columns of a. -c -c a is an m by n array. on input a must contain the matrix -c to be postmultiplied by the orthogonal matrix q -c described above. on output a*q has replaced a. -c -c lda is a positive integer input variable not less than m -c which specifies the leading dimension of the array a. -c -c v is an input array of length n. v(i) must contain the -c information necessary to recover the givens rotation gv(i) -c described above. -c -c w is an input array of length n. w(i) must contain the -c information necessary to recover the givens rotation gw(i) -c described above. -c -c subroutines called -c -c fortran-supplied ... dabs,dsqrt -c -c argonne national laboratory. minpack project. march 1980. -c burton s. garbow, kenneth e. hillstrom, jorge j. more -c -c ********** - integer i,j,nmj,nm1 - double precision cos,one,sin,temp - data one /1.0d0/ -c -c apply the first set of givens rotations to a. -c - nm1 = n - 1 - if (nm1 .lt. 1) go to 50 - do 20 nmj = 1, nm1 - j = n - nmj - if (dabs(v(j)) .gt. one) cos = one/v(j) - if (dabs(v(j)) .gt. one) sin = dsqrt(one-cos**2) - if (dabs(v(j)) .le. one) sin = v(j) - if (dabs(v(j)) .le. one) cos = dsqrt(one-sin**2) - do 10 i = 1, m - temp = cos*a(i,j) - sin*a(i,n) - a(i,n) = sin*a(i,j) + cos*a(i,n) - a(i,j) = temp - 10 continue - 20 continue -c -c apply the second set of givens rotations to a. -c - do 40 j = 1, nm1 - if (dabs(w(j)) .gt. one) cos = one/w(j) - if (dabs(w(j)) .gt. one) sin = dsqrt(one-cos**2) - if (dabs(w(j)) .le. one) sin = w(j) - if (dabs(w(j)) .le. one) cos = dsqrt(one-sin**2) - do 30 i = 1, m - temp = cos*a(i,j) + sin*a(i,n) - a(i,n) = -sin*a(i,j) + cos*a(i,n) - a(i,j) = temp - 30 continue - 40 continue - 50 continue - return -c -c last card of subroutine r1mpyq. -c - end diff --git a/src/r1updt.f b/src/r1updt.f deleted file mode 100644 index e034973..0000000 --- a/src/r1updt.f +++ /dev/null @@ -1,207 +0,0 @@ - subroutine r1updt(m,n,s,ls,u,v,w,sing) - integer m,n,ls - logical sing - double precision s(ls),u(m),v(n),w(m) -c ********** -c -c subroutine r1updt -c -c given an m by n lower trapezoidal matrix s, an m-vector u, -c and an n-vector v, the problem is to determine an -c orthogonal matrix q such that -c -c t -c (s + u*v )*q -c -c is again lower trapezoidal. -c -c this subroutine determines q as the product of 2*(n - 1) -c transformations -c -c gv(n-1)*...*gv(1)*gw(1)*...*gw(n-1) -c -c where gv(i), gw(i) are givens rotations in the (i,n) plane -c which eliminate elements in the i-th and n-th planes, -c respectively. q itself is not accumulated, rather the -c information to recover the gv, gw rotations is returned. -c -c the subroutine statement is -c -c subroutine r1updt(m,n,s,ls,u,v,w,sing) -c -c where -c -c m is a positive integer input variable set to the number -c of rows of s. -c -c n is a positive integer input variable set to the number -c of columns of s. n must not exceed m. -c -c s is an array of length ls. on input s must contain the lower -c trapezoidal matrix s stored by columns. on output s contains -c the lower trapezoidal matrix produced as described above. -c -c ls is a positive integer input variable not less than -c (n*(2*m-n+1))/2. -c -c u is an input array of length m which must contain the -c vector u. -c -c v is an array of length n. on input v must contain the vector -c v. on output v(i) contains the information necessary to -c recover the givens rotation gv(i) described above. -c -c w is an output array of length m. w(i) contains information -c necessary to recover the givens rotation gw(i) described -c above. -c -c sing is a logical output variable. sing is set true if any -c of the diagonal elements of the output s are zero. otherwise -c sing is set false. -c -c subprograms called -c -c minpack-supplied ... dpmpar -c -c fortran-supplied ... dabs,dsqrt -c -c argonne national laboratory. minpack project. march 1980. -c burton s. garbow, kenneth e. hillstrom, jorge j. more, -c john l. nazareth -c -c ********** - integer i,j,jj,l,nmj,nm1 - double precision cos,cotan,giant,one,p5,p25,sin,tan,tau,temp, - * zero - double precision dpmpar - data one,p5,p25,zero /1.0d0,5.0d-1,2.5d-1,0.0d0/ -c -c giant is the largest magnitude. -c - giant = dpmpar(3) -c -c initialize the diagonal element pointer. -c - jj = (n*(2*m - n + 1))/2 - (m - n) -c -c move the nontrivial part of the last column of s into w. -c - l = jj - do 10 i = n, m - w(i) = s(l) - l = l + 1 - 10 continue -c -c rotate the vector v into a multiple of the n-th unit vector -c in such a way that a spike is introduced into w. -c - nm1 = n - 1 - if (nm1 .lt. 1) go to 70 - do 60 nmj = 1, nm1 - j = n - nmj - jj = jj - (m - j + 1) - w(j) = zero - if (v(j) .eq. zero) go to 50 -c -c determine a givens rotation which eliminates the -c j-th element of v. -c - if (dabs(v(n)) .ge. dabs(v(j))) go to 20 - cotan = v(n)/v(j) - sin = p5/dsqrt(p25+p25*cotan**2) - cos = sin*cotan - tau = one - if (dabs(cos)*giant .gt. one) tau = one/cos - go to 30 - 20 continue - tan = v(j)/v(n) - cos = p5/dsqrt(p25+p25*tan**2) - sin = cos*tan - tau = sin - 30 continue -c -c apply the transformation to v and store the information -c necessary to recover the givens rotation. -c - v(n) = sin*v(j) + cos*v(n) - v(j) = tau -c -c apply the transformation to s and extend the spike in w. -c - l = jj - do 40 i = j, m - temp = cos*s(l) - sin*w(i) - w(i) = sin*s(l) + cos*w(i) - s(l) = temp - l = l + 1 - 40 continue - 50 continue - 60 continue - 70 continue -c -c add the spike from the rank 1 update to w. -c - do 80 i = 1, m - w(i) = w(i) + v(n)*u(i) - 80 continue -c -c eliminate the spike. -c - sing = .false. - if (nm1 .lt. 1) go to 140 - do 130 j = 1, nm1 - if (w(j) .eq. zero) go to 120 -c -c determine a givens rotation which eliminates the -c j-th element of the spike. -c - if (dabs(s(jj)) .ge. dabs(w(j))) go to 90 - cotan = s(jj)/w(j) - sin = p5/dsqrt(p25+p25*cotan**2) - cos = sin*cotan - tau = one - if (dabs(cos)*giant .gt. one) tau = one/cos - go to 100 - 90 continue - tan = w(j)/s(jj) - cos = p5/dsqrt(p25+p25*tan**2) - sin = cos*tan - tau = sin - 100 continue -c -c apply the transformation to s and reduce the spike in w. -c - l = jj - do 110 i = j, m - temp = cos*s(l) + sin*w(i) - w(i) = -sin*s(l) + cos*w(i) - s(l) = temp - l = l + 1 - 110 continue -c -c store the information necessary to recover the -c givens rotation. -c - w(j) = tau - 120 continue -c -c test for zero diagonal elements in the output s. -c - if (s(jj) .eq. zero) sing = .true. - jj = jj + (m - j + 1) - 130 continue - 140 continue -c -c move w back into the last column of the output s. -c - l = jj - do 150 i = n, m - s(l) = w(i) - l = l + 1 - 150 continue - if (s(jj) .eq. zero) sing = .true. - return -c -c last card of subroutine r1updt. -c - end diff --git a/src/rwupdt.f b/src/rwupdt.f deleted file mode 100644 index 05282b5..0000000 --- a/src/rwupdt.f +++ /dev/null @@ -1,113 +0,0 @@ - subroutine rwupdt(n,r,ldr,w,b,alpha,cos,sin) - integer n,ldr - double precision alpha - double precision r(ldr,n),w(n),b(n),cos(n),sin(n) -c ********** -c -c subroutine rwupdt -c -c given an n by n upper triangular matrix r, this subroutine -c computes the qr decomposition of the matrix formed when a row -c is added to r. if the row is specified by the vector w, then -c rwupdt determines an orthogonal matrix q such that when the -c n+1 by n matrix composed of r augmented by w is premultiplied -c by (q transpose), the resulting matrix is upper trapezoidal. -c the matrix (q transpose) is the product of n transformations -c -c g(n)*g(n-1)* ... *g(1) -c -c where g(i) is a givens rotation in the (i,n+1) plane which -c eliminates elements in the (n+1)-st plane. rwupdt also -c computes the product (q transpose)*c where c is the -c (n+1)-vector (b,alpha). q itself is not accumulated, rather -c the information to recover the g rotations is supplied. -c -c the subroutine statement is -c -c subroutine rwupdt(n,r,ldr,w,b,alpha,cos,sin) -c -c where -c -c n is a positive integer input variable set to the order of r. -c -c r is an n by n array. on input the upper triangular part of -c r must contain the matrix to be updated. on output r -c contains the updated triangular matrix. -c -c ldr is a positive integer input variable not less than n -c which specifies the leading dimension of the array r. -c -c w is an input array of length n which must contain the row -c vector to be added to r. -c -c b is an array of length n. on input b must contain the -c first n elements of the vector c. on output b contains -c the first n elements of the vector (q transpose)*c. -c -c alpha is a variable. on input alpha must contain the -c (n+1)-st element of the vector c. on output alpha contains -c the (n+1)-st element of the vector (q transpose)*c. -c -c cos is an output array of length n which contains the -c cosines of the transforming givens rotations. -c -c sin is an output array of length n which contains the -c sines of the transforming givens rotations. -c -c subprograms called -c -c fortran-supplied ... dabs,dsqrt -c -c argonne national laboratory. minpack project. march 1980. -c burton s. garbow, dudley v. goetschel, kenneth e. hillstrom, -c jorge j. more -c -c ********** - integer i,j,jm1 - double precision cotan,one,p5,p25,rowj,tan,temp,zero - data one,p5,p25,zero /1.0d0,5.0d-1,2.5d-1,0.0d0/ -c - do 60 j = 1, n - rowj = w(j) - jm1 = j - 1 -c -c apply the previous transformations to -c r(i,j), i=1,2,...,j-1, and to w(j). -c - if (jm1 .lt. 1) go to 20 - do 10 i = 1, jm1 - temp = cos(i)*r(i,j) + sin(i)*rowj - rowj = -sin(i)*r(i,j) + cos(i)*rowj - r(i,j) = temp - 10 continue - 20 continue -c -c determine a givens rotation which eliminates w(j). -c - cos(j) = one - sin(j) = zero - if (rowj .eq. zero) go to 50 - if (dabs(r(j,j)) .ge. dabs(rowj)) go to 30 - cotan = r(j,j)/rowj - sin(j) = p5/dsqrt(p25+p25*cotan**2) - cos(j) = sin(j)*cotan - go to 40 - 30 continue - tan = rowj/r(j,j) - cos(j) = p5/dsqrt(p25+p25*tan**2) - sin(j) = cos(j)*tan - 40 continue -c -c apply the current transformation to r(j,j), b(j), and alpha. -c - r(j,j) = cos(j)*r(j,j) + sin(j)*rowj - temp = cos(j)*b(j) + sin(j)*alpha - alpha = -sin(j)*b(j) + cos(j)*alpha - b(j) = temp - 50 continue - 60 continue - return -c -c last card of subroutine rwupdt. -c - end diff --git a/src/ssqfcn.f b/src/ssqfcn.f deleted file mode 100644 index 828c8d1..0000000 --- a/src/ssqfcn.f +++ /dev/null @@ -1,340 +0,0 @@ - subroutine ssqfcn(m,n,x,fvec,nprob) - integer m,n,nprob - double precision x(n),fvec(m) -c ********** -c -c subroutine ssqfcn -c -c this subroutine defines the functions of eighteen nonlinear -c least squares problems. the allowable values of (m,n) for -c functions 1,2 and 3 are variable but with m .ge. n. -c for functions 4,5,6,7,8,9 and 10 the values of (m,n) are -c (2,2),(3,3),(4,4),(2,2),(15,3),(11,4) and (16,3), respectively. -c function 11 (watson) has m = 31 with n usually 6 or 9. -c however, any n, n = 2,...,31, is permitted. -c functions 12,13 and 14 have n = 3,2 and 4, respectively, but -c allow any m .ge. n, with the usual choices being 10,10 and 20. -c function 15 (chebyquad) allows m and n variable with m .ge. n. -c function 16 (brown) allows n variable with m = n. -c for functions 17 and 18, the values of (m,n) are -c (33,5) and (65,11), respectively. -c -c the subroutine statement is -c -c subroutine ssqfcn(m,n,x,fvec,nprob) -c -c where -c -c m and n are positive integer input variables. n must not -c exceed m. -c -c x is an input array of length n. -c -c fvec is an output array of length m which contains the nprob -c function evaluated at x. -c -c nprob is a positive integer input variable which defines the -c number of the problem. nprob must not exceed 18. -c -c subprograms called -c -c fortran-supplied ... datan,dcos,dexp,dsin,dsqrt,dsign -c -c argonne national laboratory. minpack project. march 1980. -c burton s. garbow, kenneth e. hillstrom, jorge j. more -c -c ********** - integer i,iev,ivar,j,nm1 - double precision c13,c14,c29,c45,div,dx,eight,five,one,prod,sum, - * s1,s2,temp,ten,ti,tmp1,tmp2,tmp3,tmp4,tpi,two, - * zero,zp25,zp5 - double precision v(11),y1(15),y2(11),y3(16),y4(33),y5(65) - double precision dfloat - data zero,zp25,zp5,one,two,five,eight,ten,c13,c14,c29,c45 - * /0.0d0,2.5d-1,5.0d-1,1.0d0,2.0d0,5.0d0,8.0d0,1.0d1,1.3d1, - * 1.4d1,2.9d1,4.5d1/ - data v(1),v(2),v(3),v(4),v(5),v(6),v(7),v(8),v(9),v(10),v(11) - * /4.0d0,2.0d0,1.0d0,5.0d-1,2.5d-1,1.67d-1,1.25d-1,1.0d-1, - * 8.33d-2,7.14d-2,6.25d-2/ - data y1(1),y1(2),y1(3),y1(4),y1(5),y1(6),y1(7),y1(8),y1(9), - * y1(10),y1(11),y1(12),y1(13),y1(14),y1(15) - * /1.4d-1,1.8d-1,2.2d-1,2.5d-1,2.9d-1,3.2d-1,3.5d-1,3.9d-1, - * 3.7d-1,5.8d-1,7.3d-1,9.6d-1,1.34d0,2.1d0,4.39d0/ - data y2(1),y2(2),y2(3),y2(4),y2(5),y2(6),y2(7),y2(8),y2(9), - * y2(10),y2(11) - * /1.957d-1,1.947d-1,1.735d-1,1.6d-1,8.44d-2,6.27d-2,4.56d-2, - * 3.42d-2,3.23d-2,2.35d-2,2.46d-2/ - data y3(1),y3(2),y3(3),y3(4),y3(5),y3(6),y3(7),y3(8),y3(9), - * y3(10),y3(11),y3(12),y3(13),y3(14),y3(15),y3(16) - * /3.478d4,2.861d4,2.365d4,1.963d4,1.637d4,1.372d4,1.154d4, - * 9.744d3,8.261d3,7.03d3,6.005d3,5.147d3,4.427d3,3.82d3, - * 3.307d3,2.872d3/ - data y4(1),y4(2),y4(3),y4(4),y4(5),y4(6),y4(7),y4(8),y4(9), - * y4(10),y4(11),y4(12),y4(13),y4(14),y4(15),y4(16),y4(17), - * y4(18),y4(19),y4(20),y4(21),y4(22),y4(23),y4(24),y4(25), - * y4(26),y4(27),y4(28),y4(29),y4(30),y4(31),y4(32),y4(33) - * /8.44d-1,9.08d-1,9.32d-1,9.36d-1,9.25d-1,9.08d-1,8.81d-1, - * 8.5d-1,8.18d-1,7.84d-1,7.51d-1,7.18d-1,6.85d-1,6.58d-1, - * 6.28d-1,6.03d-1,5.8d-1,5.58d-1,5.38d-1,5.22d-1,5.06d-1, - * 4.9d-1,4.78d-1,4.67d-1,4.57d-1,4.48d-1,4.38d-1,4.31d-1, - * 4.24d-1,4.2d-1,4.14d-1,4.11d-1,4.06d-1/ - data y5(1),y5(2),y5(3),y5(4),y5(5),y5(6),y5(7),y5(8),y5(9), - * y5(10),y5(11),y5(12),y5(13),y5(14),y5(15),y5(16),y5(17), - * y5(18),y5(19),y5(20),y5(21),y5(22),y5(23),y5(24),y5(25), - * y5(26),y5(27),y5(28),y5(29),y5(30),y5(31),y5(32),y5(33), - * y5(34),y5(35),y5(36),y5(37),y5(38),y5(39),y5(40),y5(41), - * y5(42),y5(43),y5(44),y5(45),y5(46),y5(47),y5(48),y5(49), - * y5(50),y5(51),y5(52),y5(53),y5(54),y5(55),y5(56),y5(57), - * y5(58),y5(59),y5(60),y5(61),y5(62),y5(63),y5(64),y5(65) - * /1.366d0,1.191d0,1.112d0,1.013d0,9.91d-1,8.85d-1,8.31d-1, - * 8.47d-1,7.86d-1,7.25d-1,7.46d-1,6.79d-1,6.08d-1,6.55d-1, - * 6.16d-1,6.06d-1,6.02d-1,6.26d-1,6.51d-1,7.24d-1,6.49d-1, - * 6.49d-1,6.94d-1,6.44d-1,6.24d-1,6.61d-1,6.12d-1,5.58d-1, - * 5.33d-1,4.95d-1,5.0d-1,4.23d-1,3.95d-1,3.75d-1,3.72d-1, - * 3.91d-1,3.96d-1,4.05d-1,4.28d-1,4.29d-1,5.23d-1,5.62d-1, - * 6.07d-1,6.53d-1,6.72d-1,7.08d-1,6.33d-1,6.68d-1,6.45d-1, - * 6.32d-1,5.91d-1,5.59d-1,5.97d-1,6.25d-1,7.39d-1,7.1d-1, - * 7.29d-1,7.2d-1,6.36d-1,5.81d-1,4.28d-1,2.92d-1,1.62d-1, - * 9.8d-2,5.4d-2/ - dfloat(ivar) = ivar -c -c function routine selector. -c - go to (10,40,70,110,120,130,140,150,170,190,210,250,270,290,310, - * 360,390,410), nprob -c -c linear function - full rank. -c - 10 continue - sum = zero - do 20 j = 1, n - sum = sum + x(j) - 20 continue - temp = two*sum/dfloat(m) + one - do 30 i = 1, m - fvec(i) = -temp - if (i .le. n) fvec(i) = fvec(i) + x(i) - 30 continue - go to 430 -c -c linear function - rank 1. -c - 40 continue - sum = zero - do 50 j = 1, n - sum = sum + dfloat(j)*x(j) - 50 continue - do 60 i = 1, m - fvec(i) = dfloat(i)*sum - one - 60 continue - go to 430 -c -c linear function - rank 1 with zero columns and rows. -c - 70 continue - sum = zero - nm1 = n - 1 - if (nm1 .lt. 2) go to 90 - do 80 j = 2, nm1 - sum = sum + dfloat(j)*x(j) - 80 continue - 90 continue - do 100 i = 1, m - fvec(i) = dfloat(i-1)*sum - one - 100 continue - fvec(m) = -one - go to 430 -c -c rosenbrock function. -c - 110 continue - fvec(1) = ten*(x(2) - x(1)**2) - fvec(2) = one - x(1) - go to 430 -c -c helical valley function. -c - 120 continue - tpi = eight*datan(one) - tmp1 = dsign(zp25,x(2)) - if (x(1) .gt. zero) tmp1 = datan(x(2)/x(1))/tpi - if (x(1) .lt. zero) tmp1 = datan(x(2)/x(1))/tpi + zp5 - tmp2 = dsqrt(x(1)**2+x(2)**2) - fvec(1) = ten*(x(3) - ten*tmp1) - fvec(2) = ten*(tmp2 - one) - fvec(3) = x(3) - go to 430 -c -c powell singular function. -c - 130 continue - fvec(1) = x(1) + ten*x(2) - fvec(2) = dsqrt(five)*(x(3) - x(4)) - fvec(3) = (x(2) - two*x(3))**2 - fvec(4) = dsqrt(ten)*(x(1) - x(4))**2 - go to 430 -c -c freudenstein and roth function. -c - 140 continue - fvec(1) = -c13 + x(1) + ((five - x(2))*x(2) - two)*x(2) - fvec(2) = -c29 + x(1) + ((one + x(2))*x(2) - c14)*x(2) - go to 430 -c -c bard function. -c - 150 continue - do 160 i = 1, 15 - tmp1 = dfloat(i) - tmp2 = dfloat(16-i) - tmp3 = tmp1 - if (i .gt. 8) tmp3 = tmp2 - fvec(i) = y1(i) - (x(1) + tmp1/(x(2)*tmp2 + x(3)*tmp3)) - 160 continue - go to 430 -c -c kowalik and osborne function. -c - 170 continue - do 180 i = 1, 11 - tmp1 = v(i)*(v(i) + x(2)) - tmp2 = v(i)*(v(i) + x(3)) + x(4) - fvec(i) = y2(i) - x(1)*tmp1/tmp2 - 180 continue - go to 430 -c -c meyer function. -c - 190 continue - do 200 i = 1, 16 - temp = five*dfloat(i) + c45 + x(3) - tmp1 = x(2)/temp - tmp2 = dexp(tmp1) - fvec(i) = x(1)*tmp2 - y3(i) - 200 continue - go to 430 -c -c watson function. -c - 210 continue - do 240 i = 1, 29 - div = dfloat(i)/c29 - s1 = zero - dx = one - do 220 j = 2, n - s1 = s1 + dfloat(j-1)*dx*x(j) - dx = div*dx - 220 continue - s2 = zero - dx = one - do 230 j = 1, n - s2 = s2 + dx*x(j) - dx = div*dx - 230 continue - fvec(i) = s1 - s2**2 - one - 240 continue - fvec(30) = x(1) - fvec(31) = x(2) - x(1)**2 - one - go to 430 -c -c box 3-dimensional function. -c - 250 continue - do 260 i = 1, m - temp = dfloat(i) - tmp1 = temp/ten - fvec(i) = dexp(-tmp1*x(1)) - dexp(-tmp1*x(2)) - * + (dexp(-temp) - dexp(-tmp1))*x(3) - 260 continue - go to 430 -c -c jennrich and sampson function. -c - 270 continue - do 280 i = 1, m - temp = dfloat(i) - fvec(i) = two + two*temp - dexp(temp*x(1)) - dexp(temp*x(2)) - 280 continue - go to 430 -c -c brown and dennis function. -c - 290 continue - do 300 i = 1, m - temp = dfloat(i)/five - tmp1 = x(1) + temp*x(2) - dexp(temp) - tmp2 = x(3) + dsin(temp)*x(4) - dcos(temp) - fvec(i) = tmp1**2 + tmp2**2 - 300 continue - go to 430 -c -c chebyquad function. -c - 310 continue - do 320 i = 1, m - fvec(i) = zero - 320 continue - do 340 j = 1, n - tmp1 = one - tmp2 = two*x(j) - one - temp = two*tmp2 - do 330 i = 1, m - fvec(i) = fvec(i) + tmp2 - ti = temp*tmp2 - tmp1 - tmp1 = tmp2 - tmp2 = ti - 330 continue - 340 continue - dx = one/dfloat(n) - iev = -1 - do 350 i = 1, m - fvec(i) = dx*fvec(i) - if (iev .gt. 0) fvec(i) = fvec(i) + one/(dfloat(i)**2 - one) - iev = -iev - 350 continue - go to 430 -c -c brown almost-linear function. -c - 360 continue - sum = -dfloat(n+1) - prod = one - do 370 j = 1, n - sum = sum + x(j) - prod = x(j)*prod - 370 continue - do 380 i = 1, n - fvec(i) = x(i) + sum - 380 continue - fvec(n) = prod - one - go to 430 -c -c osborne 1 function. -c - 390 continue - do 400 i = 1, 33 - temp = ten*dfloat(i-1) - tmp1 = dexp(-x(4)*temp) - tmp2 = dexp(-x(5)*temp) - fvec(i) = y4(i) - (x(1) + x(2)*tmp1 + x(3)*tmp2) - 400 continue - go to 430 -c -c osborne 2 function. -c - 410 continue - do 420 i = 1, 65 - temp = dfloat(i-1)/ten - tmp1 = dexp(-x(5)*temp) - tmp2 = dexp(-x(6)*(temp-x(9))**2) - tmp3 = dexp(-x(7)*(temp-x(10))**2) - tmp4 = dexp(-x(8)*(temp-x(11))**2) - fvec(i) = y5(i) - * - (x(1)*tmp1 + x(2)*tmp2 + x(3)*tmp3 + x(4)*tmp4) - 420 continue - 430 continue - return -c -c last card of subroutine ssqfcn. -c - end diff --git a/src/ssqjac.f b/src/ssqjac.f deleted file mode 100644 index c57b8bd..0000000 --- a/src/ssqjac.f +++ /dev/null @@ -1,347 +0,0 @@ - subroutine ssqjac(m,n,x,fjac,ldfjac,nprob) - integer m,n,ldfjac,nprob - double precision x(n),fjac(ldfjac,n) -c ********** -c -c subroutine ssqjac -c -c this subroutine defines the jacobian matrices of eighteen -c nonlinear least squares problems. the problem dimensions are -c as described in the prologue comments of ssqfcn. -c -c the subroutine statement is -c -c subroutine ssqjac(m,n,x,fjac,ldfjac,nprob) -c -c where -c -c m and n are positive integer input variables. n must not -c exceed m. -c -c x is an input array of length n. -c -c fjac is an m by n output array which contains the jacobian -c matrix of the nprob function evaluated at x. -c -c ldfjac is a positive integer input variable not less than m -c which specifies the leading dimension of the array fjac. -c -c nprob is a positive integer variable which defines the -c number of the problem. nprob must not exceed 18. -c -c subprograms called -c -c fortran-supplied ... datan,dcos,dexp,dsin,dsqrt -c -c argonne national laboratory. minpack project. march 1980. -c burton s. garbow, kenneth e. hillstrom, jorge j. more -c -c ********** - integer i,ivar,j,k,mm1,nm1 - double precision c14,c20,c29,c45,c100,div,dx,eight,five,four, - * one,prod,s2,temp,ten,three,ti,tmp1,tmp2,tmp3, - * tmp4,tpi,two,zero - double precision v(11) - double precision dfloat - data zero,one,two,three,four,five,eight,ten,c14,c20,c29,c45,c100 - * /0.0d0,1.0d0,2.0d0,3.0d0,4.0d0,5.0d0,8.0d0,1.0d1,1.4d1, - * 2.0d1,2.9d1,4.5d1,1.0d2/ - data v(1),v(2),v(3),v(4),v(5),v(6),v(7),v(8),v(9),v(10),v(11) - * /4.0d0,2.0d0,1.0d0,5.0d-1,2.5d-1,1.67d-1,1.25d-1,1.0d-1, - * 8.33d-2,7.14d-2,6.25d-2/ - dfloat(ivar) = ivar -c -c jacobian routine selector. -c - go to (10,40,70,130,140,150,180,190,210,230,250,310,330,350,370, - * 400,460,480), nprob -c -c linear function - full rank. -c - 10 continue - temp = two/dfloat(m) - do 30 j = 1, n - do 20 i = 1, m - fjac(i,j) = -temp - 20 continue - fjac(j,j) = fjac(j,j) + one - 30 continue - go to 500 -c -c linear function - rank 1. -c - 40 continue - do 60 j = 1, n - do 50 i = 1, m - fjac(i,j) = dfloat(i)*dfloat(j) - 50 continue - 60 continue - go to 500 -c -c linear function - rank 1 with zero columns and rows. -c - 70 continue - do 90 j = 1, n - do 80 i = 1, m - fjac(i,j) = zero - 80 continue - 90 continue - nm1 = n - 1 - mm1 = m - 1 - if (nm1 .lt. 2) go to 120 - do 110 j = 2, nm1 - do 100 i = 2, mm1 - fjac(i,j) = dfloat(i-1)*dfloat(j) - 100 continue - 110 continue - 120 continue - go to 500 -c -c rosenbrock function. -c - 130 continue - fjac(1,1) = -c20*x(1) - fjac(1,2) = ten - fjac(2,1) = -one - fjac(2,2) = zero - go to 500 -c -c helical valley function. -c - 140 continue - tpi = eight*datan(one) - temp = x(1)**2 + x(2)**2 - tmp1 = tpi*temp - tmp2 = dsqrt(temp) - fjac(1,1) = c100*x(2)/tmp1 - fjac(1,2) = -c100*x(1)/tmp1 - fjac(1,3) = ten - fjac(2,1) = ten*x(1)/tmp2 - fjac(2,2) = ten*x(2)/tmp2 - fjac(2,3) = zero - fjac(3,1) = zero - fjac(3,2) = zero - fjac(3,3) = one - go to 500 -c -c powell singular function. -c - 150 continue - do 170 j = 1, 4 - do 160 i = 1, 4 - fjac(i,j) = zero - 160 continue - 170 continue - fjac(1,1) = one - fjac(1,2) = ten - fjac(2,3) = dsqrt(five) - fjac(2,4) = -fjac(2,3) - fjac(3,2) = two*(x(2) - two*x(3)) - fjac(3,3) = -two*fjac(3,2) - fjac(4,1) = two*dsqrt(ten)*(x(1) - x(4)) - fjac(4,4) = -fjac(4,1) - go to 500 -c -c freudenstein and roth function. -c - 180 continue - fjac(1,1) = one - fjac(1,2) = x(2)*(ten - three*x(2)) - two - fjac(2,1) = one - fjac(2,2) = x(2)*(two + three*x(2)) - c14 - go to 500 -c -c bard function. -c - 190 continue - do 200 i = 1, 15 - tmp1 = dfloat(i) - tmp2 = dfloat(16-i) - tmp3 = tmp1 - if (i .gt. 8) tmp3 = tmp2 - tmp4 = (x(2)*tmp2 + x(3)*tmp3)**2 - fjac(i,1) = -one - fjac(i,2) = tmp1*tmp2/tmp4 - fjac(i,3) = tmp1*tmp3/tmp4 - 200 continue - go to 500 -c -c kowalik and osborne function. -c - 210 continue - do 220 i = 1, 11 - tmp1 = v(i)*(v(i) + x(2)) - tmp2 = v(i)*(v(i) + x(3)) + x(4) - fjac(i,1) = -tmp1/tmp2 - fjac(i,2) = -v(i)*x(1)/tmp2 - fjac(i,3) = fjac(i,1)*fjac(i,2) - fjac(i,4) = fjac(i,3)/v(i) - 220 continue - go to 500 -c -c meyer function. -c - 230 continue - do 240 i = 1, 16 - temp = five*dfloat(i) + c45 + x(3) - tmp1 = x(2)/temp - tmp2 = dexp(tmp1) - fjac(i,1) = tmp2 - fjac(i,2) = x(1)*tmp2/temp - fjac(i,3) = -tmp1*fjac(i,2) - 240 continue - go to 500 -c -c watson function. -c - 250 continue - do 280 i = 1, 29 - div = dfloat(i)/c29 - s2 = zero - dx = one - do 260 j = 1, n - s2 = s2 + dx*x(j) - dx = div*dx - 260 continue - temp = two*div*s2 - dx = one/div - do 270 j = 1, n - fjac(i,j) = dx*(dfloat(j-1) - temp) - dx = div*dx - 270 continue - 280 continue - do 300 j = 1, n - do 290 i = 30, 31 - fjac(i,j) = zero - 290 continue - 300 continue - fjac(30,1) = one - fjac(31,1) = -two*x(1) - fjac(31,2) = one - go to 500 -c -c box 3-dimensional function. -c - 310 continue - do 320 i = 1, m - temp = dfloat(i) - tmp1 = temp/ten - fjac(i,1) = -tmp1*dexp(-tmp1*x(1)) - fjac(i,2) = tmp1*dexp(-tmp1*x(2)) - fjac(i,3) = dexp(-temp) - dexp(-tmp1) - 320 continue - go to 500 -c -c jennrich and sampson function. -c - 330 continue - do 340 i = 1, m - temp = dfloat(i) - fjac(i,1) = -temp*dexp(temp*x(1)) - fjac(i,2) = -temp*dexp(temp*x(2)) - 340 continue - go to 500 -c -c brown and dennis function. -c - 350 continue - do 360 i = 1, m - temp = dfloat(i)/five - ti = dsin(temp) - tmp1 = x(1) + temp*x(2) - dexp(temp) - tmp2 = x(3) + ti*x(4) - dcos(temp) - fjac(i,1) = two*tmp1 - fjac(i,2) = temp*fjac(i,1) - fjac(i,3) = two*tmp2 - fjac(i,4) = ti*fjac(i,3) - 360 continue - go to 500 -c -c chebyquad function. -c - 370 continue - dx = one/dfloat(n) - do 390 j = 1, n - tmp1 = one - tmp2 = two*x(j) - one - temp = two*tmp2 - tmp3 = zero - tmp4 = two - do 380 i = 1, m - fjac(i,j) = dx*tmp4 - ti = four*tmp2 + temp*tmp4 - tmp3 - tmp3 = tmp4 - tmp4 = ti - ti = temp*tmp2 - tmp1 - tmp1 = tmp2 - tmp2 = ti - 380 continue - 390 continue - go to 500 -c -c brown almost-linear function. -c - 400 continue - prod = one - do 420 j = 1, n - prod = x(j)*prod - do 410 i = 1, n - fjac(i,j) = one - 410 continue - fjac(j,j) = two - 420 continue - do 450 j = 1, n - temp = x(j) - if (temp .ne. zero) go to 440 - temp = one - prod = one - do 430 k = 1, n - if (k .ne. j) prod = x(k)*prod - 430 continue - 440 continue - fjac(n,j) = prod/temp - 450 continue - go to 500 -c -c osborne 1 function. -c - 460 continue - do 470 i = 1, 33 - temp = ten*dfloat(i-1) - tmp1 = dexp(-x(4)*temp) - tmp2 = dexp(-x(5)*temp) - fjac(i,1) = -one - fjac(i,2) = -tmp1 - fjac(i,3) = -tmp2 - fjac(i,4) = temp*x(2)*tmp1 - fjac(i,5) = temp*x(3)*tmp2 - 470 continue - go to 500 -c -c osborne 2 function. -c - 480 continue - do 490 i = 1, 65 - temp = dfloat(i-1)/ten - tmp1 = dexp(-x(5)*temp) - tmp2 = dexp(-x(6)*(temp-x(9))**2) - tmp3 = dexp(-x(7)*(temp-x(10))**2) - tmp4 = dexp(-x(8)*(temp-x(11))**2) - fjac(i,1) = -tmp1 - fjac(i,2) = -tmp2 - fjac(i,3) = -tmp3 - fjac(i,4) = -tmp4 - fjac(i,5) = temp*x(1)*tmp1 - fjac(i,6) = x(2)*(temp - x(9))**2*tmp2 - fjac(i,7) = x(3)*(temp - x(10))**2*tmp3 - fjac(i,8) = x(4)*(temp - x(11))**2*tmp4 - fjac(i,9) = -two*x(2)*x(6)*(temp - x(9))*tmp2 - fjac(i,10) = -two*x(3)*x(7)*(temp - x(10))*tmp3 - fjac(i,11) = -two*x(4)*x(8)*(temp - x(11))*tmp4 - 490 continue - 500 continue - return -c -c last card of subroutine ssqjac. -c - end diff --git a/src/vecfcn.f b/src/vecfcn.f deleted file mode 100644 index aa7e16a..0000000 --- a/src/vecfcn.f +++ /dev/null @@ -1,273 +0,0 @@ - subroutine vecfcn(n,x,fvec,nprob) - integer n,nprob - double precision x(n),fvec(n) -c ********** -c -c subroutine vecfcn -c -c this subroutine defines fourteen test functions. the first -c five test functions are of dimensions 2,4,2,4,3, respectively, -c while the remaining test functions are of variable dimension -c n for any n greater than or equal to 1 (problem 6 is an -c exception to this, since it does not allow n = 1). -c -c the subroutine statement is -c -c subroutine vecfcn(n,x,fvec,nprob) -c -c where -c -c n is a positive integer input variable. -c -c x is an input array of length n. -c -c fvec is an output array of length n which contains the nprob -c function vector evaluated at x. -c -c nprob is a positive integer input variable which defines the -c number of the problem. nprob must not exceed 14. -c -c subprograms called -c -c fortran-supplied ... datan,dcos,dexp,dsign,dsin,dsqrt, -c max0,min0 -c -c argonne national laboratory. minpack project. march 1980. -c burton s. garbow, kenneth e. hillstrom, jorge j. more -c -c ********** - integer i,iev,ivar,j,k,k1,k2,kp1,ml,mu - double precision c1,c2,c3,c4,c5,c6,c7,c8,c9,eight,five,h,one, - * prod,sum,sum1,sum2,temp,temp1,temp2,ten,three, - * ti,tj,tk,tpi,two,zero - double precision dfloat - data zero,one,two,three,five,eight,ten - * /0.0d0,1.0d0,2.0d0,3.0d0,5.0d0,8.0d0,1.0d1/ - data c1,c2,c3,c4,c5,c6,c7,c8,c9 - * /1.0d4,1.0001d0,2.0d2,2.02d1,1.98d1,1.8d2,2.5d-1,5.0d-1, - * 2.9d1/ - dfloat(ivar) = ivar -c -c problem selector. -c - go to (10,20,30,40,50,60,120,170,200,220,270,300,330,350), nprob -c -c rosenbrock function. -c - 10 continue - fvec(1) = one - x(1) - fvec(2) = ten*(x(2) - x(1)**2) - go to 380 -c -c powell singular function. -c - 20 continue - fvec(1) = x(1) + ten*x(2) - fvec(2) = dsqrt(five)*(x(3) - x(4)) - fvec(3) = (x(2) - two*x(3))**2 - fvec(4) = dsqrt(ten)*(x(1) - x(4))**2 - go to 380 -c -c powell badly scaled function. -c - 30 continue - fvec(1) = c1*x(1)*x(2) - one - fvec(2) = dexp(-x(1)) + dexp(-x(2)) - c2 - go to 380 -c -c wood function. -c - 40 continue - temp1 = x(2) - x(1)**2 - temp2 = x(4) - x(3)**2 - fvec(1) = -c3*x(1)*temp1 - (one - x(1)) - fvec(2) = c3*temp1 + c4*(x(2) - one) + c5*(x(4) - one) - fvec(3) = -c6*x(3)*temp2 - (one - x(3)) - fvec(4) = c6*temp2 + c4*(x(4) - one) + c5*(x(2) - one) - go to 380 -c -c helical valley function. -c - 50 continue - tpi = eight*datan(one) - temp1 = dsign(c7,x(2)) - if (x(1) .gt. zero) temp1 = datan(x(2)/x(1))/tpi - if (x(1) .lt. zero) temp1 = datan(x(2)/x(1))/tpi + c8 - temp2 = dsqrt(x(1)**2+x(2)**2) - fvec(1) = ten*(x(3) - ten*temp1) - fvec(2) = ten*(temp2 - one) - fvec(3) = x(3) - go to 380 -c -c watson function. -c - 60 continue - do 70 k = 1, n - fvec(k) = zero - 70 continue - do 110 i = 1, 29 - ti = dfloat(i)/c9 - sum1 = zero - temp = one - do 80 j = 2, n - sum1 = sum1 + dfloat(j-1)*temp*x(j) - temp = ti*temp - 80 continue - sum2 = zero - temp = one - do 90 j = 1, n - sum2 = sum2 + temp*x(j) - temp = ti*temp - 90 continue - temp1 = sum1 - sum2**2 - one - temp2 = two*ti*sum2 - temp = one/ti - do 100 k = 1, n - fvec(k) = fvec(k) + temp*(dfloat(k-1) - temp2)*temp1 - temp = ti*temp - 100 continue - 110 continue - temp = x(2) - x(1)**2 - one - fvec(1) = fvec(1) + x(1)*(one - two*temp) - fvec(2) = fvec(2) + temp - go to 380 -c -c chebyquad function. -c - 120 continue - do 130 k = 1, n - fvec(k) = zero - 130 continue - do 150 j = 1, n - temp1 = one - temp2 = two*x(j) - one - temp = two*temp2 - do 140 i = 1, n - fvec(i) = fvec(i) + temp2 - ti = temp*temp2 - temp1 - temp1 = temp2 - temp2 = ti - 140 continue - 150 continue - tk = one/dfloat(n) - iev = -1 - do 160 k = 1, n - fvec(k) = tk*fvec(k) - if (iev .gt. 0) fvec(k) = fvec(k) + one/(dfloat(k)**2 - one) - iev = -iev - 160 continue - go to 380 -c -c brown almost-linear function. -c - 170 continue - sum = -dfloat(n+1) - prod = one - do 180 j = 1, n - sum = sum + x(j) - prod = x(j)*prod - 180 continue - do 190 k = 1, n - fvec(k) = x(k) + sum - 190 continue - fvec(n) = prod - one - go to 380 -c -c discrete boundary value function. -c - 200 continue - h = one/dfloat(n+1) - do 210 k = 1, n - temp = (x(k) + dfloat(k)*h + one)**3 - temp1 = zero - if (k .ne. 1) temp1 = x(k-1) - temp2 = zero - if (k .ne. n) temp2 = x(k+1) - fvec(k) = two*x(k) - temp1 - temp2 + temp*h**2/two - 210 continue - go to 380 -c -c discrete integral equation function. -c - 220 continue - h = one/dfloat(n+1) - do 260 k = 1, n - tk = dfloat(k)*h - sum1 = zero - do 230 j = 1, k - tj = dfloat(j)*h - temp = (x(j) + tj + one)**3 - sum1 = sum1 + tj*temp - 230 continue - sum2 = zero - kp1 = k + 1 - if (n .lt. kp1) go to 250 - do 240 j = kp1, n - tj = dfloat(j)*h - temp = (x(j) + tj + one)**3 - sum2 = sum2 + (one - tj)*temp - 240 continue - 250 continue - fvec(k) = x(k) + h*((one - tk)*sum1 + tk*sum2)/two - 260 continue - go to 380 -c -c trigonometric function. -c - 270 continue - sum = zero - do 280 j = 1, n - fvec(j) = dcos(x(j)) - sum = sum + fvec(j) - 280 continue - do 290 k = 1, n - fvec(k) = dfloat(n+k) - dsin(x(k)) - sum - dfloat(k)*fvec(k) - 290 continue - go to 380 -c -c variably dimensioned function. -c - 300 continue - sum = zero - do 310 j = 1, n - sum = sum + dfloat(j)*(x(j) - one) - 310 continue - temp = sum*(one + two*sum**2) - do 320 k = 1, n - fvec(k) = x(k) - one + dfloat(k)*temp - 320 continue - go to 380 -c -c broyden tridiagonal function. -c - 330 continue - do 340 k = 1, n - temp = (three - two*x(k))*x(k) - temp1 = zero - if (k .ne. 1) temp1 = x(k-1) - temp2 = zero - if (k .ne. n) temp2 = x(k+1) - fvec(k) = temp - temp1 - two*temp2 + one - 340 continue - go to 380 -c -c broyden banded function. -c - 350 continue - ml = 5 - mu = 1 - do 370 k = 1, n - k1 = max0(1,k-ml) - k2 = min0(k+mu,n) - temp = zero - do 360 j = k1, k2 - if (j .ne. k) temp = temp + x(j)*(one + x(j)) - 360 continue - fvec(k) = x(k)*(two + five*x(k)**2) + one - temp - 370 continue - 380 continue - return -c -c last card of subroutine vecfcn. -c - end diff --git a/src/vecjac.f b/src/vecjac.f deleted file mode 100644 index 7debfed..0000000 --- a/src/vecjac.f +++ /dev/null @@ -1,321 +0,0 @@ - subroutine vecjac(n,x,fjac,ldfjac,nprob) - integer n,ldfjac,nprob - double precision x(n),fjac(ldfjac,n) -c ********** -c -c subroutine vecjac -c -c this subroutine defines the jacobian matrices of fourteen -c test functions. the problem dimensions are as described -c in the prologue comments of vecfcn. -c -c the subroutine statement is -c -c subroutine vecjac(n,x,fjac,ldfjac,nprob) -c -c where -c -c n is a positive integer variable. -c -c x is an array of length n. -c -c fjac is an n by n array. on output fjac contains the -c jacobian matrix of the nprob function evaluated at x. -c -c ldfjac is a positive integer variable not less than n -c which specifies the leading dimension of the array fjac. -c -c nprob is a positive integer variable which defines the -c number of the problem. nprob must not exceed 14. -c -c subprograms called -c -c fortran-supplied ... datan,dcos,dexp,dmin1,dsin,dsqrt, -c max0,min0 -c -c argonne national laboratory. minpack project. march 1980. -c burton s. garbow, kenneth e. hillstrom, jorge j. more -c -c ********** - integer i,ivar,j,k,k1,k2,ml,mu - double precision c1,c3,c4,c5,c6,c9,eight,fiftn,five,four,h, - * hundrd,one,prod,six,sum,sum1,sum2,temp,temp1, - * temp2,temp3,temp4,ten,three,ti,tj,tk,tpi, - * twenty,two,zero - double precision dfloat - data zero,one,two,three,four,five,six,eight,ten,fiftn,twenty, - * hundrd - * /0.0d0,1.0d0,2.0d0,3.0d0,4.0d0,5.0d0,6.0d0,8.0d0,1.0d1, - * 1.5d1,2.0d1,1.0d2/ - data c1,c3,c4,c5,c6,c9 /1.0d4,2.0d2,2.02d1,1.98d1,1.8d2,2.9d1/ - dfloat(ivar) = ivar -c -c jacobian routine selector. -c - go to (10,20,50,60,90,100,200,230,290,320,350,380,420,450), - * nprob -c -c rosenbrock function. -c - 10 continue - fjac(1,1) = -one - fjac(1,2) = zero - fjac(2,1) = -twenty*x(1) - fjac(2,2) = ten - go to 490 -c -c powell singular function. -c - 20 continue - do 40 k = 1, 4 - do 30 j = 1, 4 - fjac(k,j) = zero - 30 continue - 40 continue - fjac(1,1) = one - fjac(1,2) = ten - fjac(2,3) = dsqrt(five) - fjac(2,4) = -fjac(2,3) - fjac(3,2) = two*(x(2) - two*x(3)) - fjac(3,3) = -two*fjac(3,2) - fjac(4,1) = two*dsqrt(ten)*(x(1) - x(4)) - fjac(4,4) = -fjac(4,1) - go to 490 -c -c powell badly scaled function. -c - 50 continue - fjac(1,1) = c1*x(2) - fjac(1,2) = c1*x(1) - fjac(2,1) = -dexp(-x(1)) - fjac(2,2) = -dexp(-x(2)) - go to 490 -c -c wood function. -c - 60 continue - do 80 k = 1, 4 - do 70 j = 1, 4 - fjac(k,j) = zero - 70 continue - 80 continue - temp1 = x(2) - three*x(1)**2 - temp2 = x(4) - three*x(3)**2 - fjac(1,1) = -c3*temp1 + one - fjac(1,2) = -c3*x(1) - fjac(2,1) = -two*c3*x(1) - fjac(2,2) = c3 + c4 - fjac(2,4) = c5 - fjac(3,3) = -c6*temp2 + one - fjac(3,4) = -c6*x(3) - fjac(4,2) = c5 - fjac(4,3) = -two*c6*x(3) - fjac(4,4) = c6 + c4 - go to 490 -c -c helical valley function. -c - 90 continue - tpi = eight*datan(one) - temp = x(1)**2 + x(2)**2 - temp1 = tpi*temp - temp2 = dsqrt(temp) - fjac(1,1) = hundrd*x(2)/temp1 - fjac(1,2) = -hundrd*x(1)/temp1 - fjac(1,3) = ten - fjac(2,1) = ten*x(1)/temp2 - fjac(2,2) = ten*x(2)/temp2 - fjac(2,3) = zero - fjac(3,1) = zero - fjac(3,2) = zero - fjac(3,3) = one - go to 490 -c -c watson function. -c - 100 continue - do 120 k = 1, n - do 110 j = k, n - fjac(k,j) = zero - 110 continue - 120 continue - do 170 i = 1, 29 - ti = dfloat(i)/c9 - sum1 = zero - temp = one - do 130 j = 2, n - sum1 = sum1 + dfloat(j-1)*temp*x(j) - temp = ti*temp - 130 continue - sum2 = zero - temp = one - do 140 j = 1, n - sum2 = sum2 + temp*x(j) - temp = ti*temp - 140 continue - temp1 = two*(sum1 - sum2**2 - one) - temp2 = two*sum2 - temp = ti**2 - tk = one - do 160 k = 1, n - tj = tk - do 150 j = k, n - fjac(k,j) = fjac(k,j) - * + tj - * *((dfloat(k-1)/ti - temp2) - * *(dfloat(j-1)/ti - temp2) - temp1) - tj = ti*tj - 150 continue - tk = temp*tk - 160 continue - 170 continue - fjac(1,1) = fjac(1,1) + six*x(1)**2 - two*x(2) + three - fjac(1,2) = fjac(1,2) - two*x(1) - fjac(2,2) = fjac(2,2) + one - do 190 k = 1, n - do 180 j = k, n - fjac(j,k) = fjac(k,j) - 180 continue - 190 continue - go to 490 -c -c chebyquad function. -c - 200 continue - tk = one/dfloat(n) - do 220 j = 1, n - temp1 = one - temp2 = two*x(j) - one - temp = two*temp2 - temp3 = zero - temp4 = two - do 210 k = 1, n - fjac(k,j) = tk*temp4 - ti = four*temp2 + temp*temp4 - temp3 - temp3 = temp4 - temp4 = ti - ti = temp*temp2 - temp1 - temp1 = temp2 - temp2 = ti - 210 continue - 220 continue - go to 490 -c -c brown almost-linear function. -c - 230 continue - prod = one - do 250 j = 1, n - prod = x(j)*prod - do 240 k = 1, n - fjac(k,j) = one - 240 continue - fjac(j,j) = two - 250 continue - do 280 j = 1, n - temp = x(j) - if (temp .ne. zero) go to 270 - temp = one - prod = one - do 260 k = 1, n - if (k .ne. j) prod = x(k)*prod - 260 continue - 270 continue - fjac(n,j) = prod/temp - 280 continue - go to 490 -c -c discrete boundary value function. -c - 290 continue - h = one/dfloat(n+1) - do 310 k = 1, n - temp = three*(x(k) + dfloat(k)*h + one)**2 - do 300 j = 1, n - fjac(k,j) = zero - 300 continue - fjac(k,k) = two + temp*h**2/two - if (k .ne. 1) fjac(k,k-1) = -one - if (k .ne. n) fjac(k,k+1) = -one - 310 continue - go to 490 -c -c discrete integral equation function. -c - 320 continue - h = one/dfloat(n+1) - do 340 k = 1, n - tk = dfloat(k)*h - do 330 j = 1, n - tj = dfloat(j)*h - temp = three*(x(j) + tj + one)**2 - fjac(k,j) = h*dmin1(tj*(one-tk),tk*(one-tj))*temp/two - 330 continue - fjac(k,k) = fjac(k,k) + one - 340 continue - go to 490 -c -c trigonometric function. -c - 350 continue - do 370 j = 1, n - temp = dsin(x(j)) - do 360 k = 1, n - fjac(k,j) = temp - 360 continue - fjac(j,j) = dfloat(j+1)*temp - dcos(x(j)) - 370 continue - go to 490 -c -c variably dimensioned function. -c - 380 continue - sum = zero - do 390 j = 1, n - sum = sum + dfloat(j)*(x(j) - one) - 390 continue - temp = one + six*sum**2 - do 410 k = 1, n - do 400 j = k, n - fjac(k,j) = dfloat(k*j)*temp - fjac(j,k) = fjac(k,j) - 400 continue - fjac(k,k) = fjac(k,k) + one - 410 continue - go to 490 -c -c broyden tridiagonal function. -c - 420 continue - do 440 k = 1, n - do 430 j = 1, n - fjac(k,j) = zero - 430 continue - fjac(k,k) = three - four*x(k) - if (k .ne. 1) fjac(k,k-1) = -one - if (k .ne. n) fjac(k,k+1) = -two - 440 continue - go to 490 -c -c broyden banded function. -c - 450 continue - ml = 5 - mu = 1 - do 480 k = 1, n - do 460 j = 1, n - fjac(k,j) = zero - 460 continue - k1 = max0(1,k-ml) - k2 = min0(k+mu,n) - do 470 j = k1, k2 - if (j .ne. k) fjac(k,j) = -(one + two*x(j)) - 470 continue - fjac(k,k) = two + fiftn*x(k)**2 - 480 continue - 490 continue - return -c -c last card of subroutine vecjac. -c - end