1985 lines
58 KiB
Fortran
1985 lines
58 KiB
Fortran
|
module minpack
|
||
|
|
|
||
|
|
use const_and_precisions, only : wp_
|
||
|
|
implicit none
|
||
|
|
|
||
|
|
contains
|
||
|
|
|
||
|
|
subroutine hybrj1(fcn,n,x,fvec,fjac,ldfjac,tol,info,wa,lwa)
|
||
|
|
use const_and_precisions, only : zero, one
|
||
|
|
implicit none
|
||
|
|
! arguments
|
||
|
|
integer, intent(in) :: n, ldfjac, lwa
|
||
|
|
integer, intent(out) :: info
|
||
|
|
real(wp_), intent(in) :: tol
|
||
|
|
real(wp_), intent(out) :: wa(lwa)
|
||
|
|
real(wp_), intent(inout) :: fvec(n), fjac(ldfjac,n), x(n)
|
||
|
|
! **********
|
||
|
|
!
|
||
|
|
! subroutine hybrj1
|
||
|
|
!
|
||
|
|
! the purpose of hybrj1 is to find a zero of a system of
|
||
|
|
! n nonlinear functions in n variables by a modification
|
||
|
|
! of the powell hybrid method. this is done by using the
|
||
|
|
! more general nonlinear equation solver hybrj. the user
|
||
|
|
! must provide a subroutine which calculates the functions
|
||
|
|
! and the jacobian.
|
||
|
|
!
|
||
|
|
! the subroutine statement is
|
||
|
|
!
|
||
|
|
! subroutine hybrj1(fcn,n,x,fvec,fjac,ldfjac,tol,info,wa,lwa)
|
||
|
|
!
|
||
|
|
! where
|
||
|
|
!
|
||
|
|
! fcn is the name of the user-supplied subroutine which
|
||
|
|
! calculates the functions and the jacobian. fcn must
|
||
|
|
! be declared in an external statement in the user
|
||
|
|
! calling program, and should be written as follows.
|
||
|
|
!
|
||
|
|
! subroutine fcn(n,x,fvec,fjac,ldfjac,iflag)
|
||
|
|
! integer n,ldfjac,iflag
|
||
|
|
! real(8) 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
|
||
|
|
!
|
||
|
|
! the value of iflag should not be changed by fcn unless
|
||
|
|
! the user wants to terminate execution of hybrj1.
|
||
|
|
! in this case set iflag to a negative integer.
|
||
|
|
!
|
||
|
|
! n is a positive integer input variable set to the number
|
||
|
|
! of functions and variables.
|
||
|
|
!
|
||
|
|
! 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.
|
||
|
|
!
|
||
|
|
! fvec is an output array of length n which contains
|
||
|
|
! the functions evaluated at the output x.
|
||
|
|
!
|
||
|
|
! fjac is an output n by n array which contains the
|
||
|
|
! orthogonal matrix q produced by the qr factorization
|
||
|
|
! of the final approximate jacobian.
|
||
|
|
!
|
||
|
|
! ldfjac is a positive integer input variable not less than n
|
||
|
|
! which specifies the leading dimension of the array fjac.
|
||
|
|
!
|
||
|
|
! 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.
|
||
|
|
!
|
||
|
|
! 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.
|
||
|
|
!
|
||
|
|
! info = 0 improper input parameters.
|
||
|
|
!
|
||
|
|
! info = 1 algorithm estimates that the relative error
|
||
|
|
! between x and the solution is at most tol.
|
||
|
|
!
|
||
|
|
! info = 2 number of calls to fcn with iflag = 1 has
|
||
|
|
! reached 100*(n+1).
|
||
|
|
!
|
||
|
|
! info = 3 tol is too small. no further improvement in
|
||
|
|
! the approximate solution x is possible.
|
||
|
|
!
|
||
|
|
! info = 4 iteration is not making good progress.
|
||
|
|
!
|
||
|
|
! wa is a work array of length lwa.
|
||
|
|
!
|
||
|
|
! lwa is a positive integer input variable not less than
|
||
|
|
! (n*(n+13))/2.
|
||
|
|
!
|
||
|
|
! subprograms called
|
||
|
|
!
|
||
|
|
! user-supplied ...... fcn
|
||
|
|
!
|
||
|
|
! minpack-supplied ... hybrj
|
||
|
|
!
|
||
|
|
! argonne national laboratory. minpack project. march 1980.
|
||
|
|
! burton s. garbow, kenneth e. hillstrom, jorge j. more
|
||
|
|
!
|
||
|
|
! **********
|
||
|
|
! local variables
|
||
|
|
integer :: j, lr, maxfev, mode, nfev, njev, nprint
|
||
|
|
real(wp_) :: xtol
|
||
|
|
! parameters
|
||
|
|
real(wp_), parameter :: factor=1.0e2_wp_
|
||
|
|
|
||
|
|
interface
|
||
|
|
subroutine fcn(n,x,fvec,fjac,ldfjac,iflag)
|
||
|
|
use const_and_precisions, only : wp_
|
||
|
|
implicit none
|
||
|
|
integer, intent(in) :: n,ldfjac,iflag
|
||
|
|
real(wp_), intent(in) :: x(n)
|
||
|
|
real(wp_), intent(inout) :: fvec(n),fjac(ldfjac,n)
|
||
|
|
end subroutine fcn
|
||
|
|
end interface
|
||
|
|
|
||
|
|
info = 0
|
||
|
|
!
|
||
|
|
! check the input parameters for errors.
|
||
|
|
!
|
||
|
|
if (n <= 0 .or. ldfjac < n .or. tol < zero &
|
||
|
|
.or. lwa < (n*(n + 13))/2) return
|
||
|
|
!
|
||
|
|
! call hybrj.
|
||
|
|
!
|
||
|
|
maxfev = 100*(n + 1)
|
||
|
|
xtol = tol
|
||
|
|
mode = 2
|
||
|
|
do j = 1, n
|
||
|
|
wa(j) = one
|
||
|
|
end do
|
||
|
|
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 == 5) info = 4
|
||
|
|
end subroutine hybrj1
|
||
|
|
|
||
|
|
subroutine hybrj(fcn,n,x,fvec,fjac,ldfjac,xtol,maxfev,diag,mode, &
|
||
|
|
factor,nprint,info,nfev,njev,r,lr,qtf,wa1,wa2, &
|
||
|
|
wa3,wa4)
|
||
|
|
use const_and_precisions, only : zero, one, epsmch=>comp_eps
|
||
|
|
implicit none
|
||
|
|
! arguments
|
||
|
|
integer, intent(in) :: n, ldfjac, maxfev, mode, nprint, lr
|
||
|
|
integer, intent(out) :: info, nfev, njev
|
||
|
|
real(wp_), intent(in) :: xtol, factor
|
||
|
|
real(wp_), intent(out) :: fvec(n), fjac(ldfjac,n), r(lr), qtf(n), &
|
||
|
|
wa1(n), wa2(n), wa3(n), wa4(n)
|
||
|
|
real(wp_), intent(inout) :: x(n), diag(n)
|
||
|
|
! **********
|
||
|
|
!
|
||
|
|
! subroutine hybrj
|
||
|
|
!
|
||
|
|
! the purpose of hybrj is to find a zero of a system of
|
||
|
|
! n nonlinear functions in n variables by a modification
|
||
|
|
! of the powell hybrid method. the user must provide a
|
||
|
|
! subroutine which calculates the functions and the jacobian.
|
||
|
|
!
|
||
|
|
! the subroutine statement is
|
||
|
|
!
|
||
|
|
! subroutine hybrj(fcn,n,x,fvec,fjac,ldfjac,xtol,maxfev,diag,
|
||
|
|
! mode,factor,nprint,info,nfev,njev,r,lr,qtf,
|
||
|
|
! wa1,wa2,wa3,wa4)
|
||
|
|
!
|
||
|
|
! where
|
||
|
|
!
|
||
|
|
! fcn is the name of the user-supplied subroutine which
|
||
|
|
! calculates the functions and the jacobian. fcn must
|
||
|
|
! be declared in an external statement in the user
|
||
|
|
! calling program, and should be written as follows.
|
||
|
|
!
|
||
|
|
! subroutine fcn(n,x,fvec,fjac,ldfjac,iflag)
|
||
|
|
! integer n,ldfjac,iflag
|
||
|
|
! real(8) 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
|
||
|
|
!
|
||
|
|
! 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.
|
||
|
|
!
|
||
|
|
! n is a positive integer input variable set to the number
|
||
|
|
! of functions and variables.
|
||
|
|
!
|
||
|
|
! 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.
|
||
|
|
!
|
||
|
|
! fvec is an output array of length n which contains
|
||
|
|
! the functions evaluated at the output x.
|
||
|
|
!
|
||
|
|
! fjac is an output n by n array which contains the
|
||
|
|
! orthogonal matrix q produced by the qr factorization
|
||
|
|
! of the final approximate jacobian.
|
||
|
|
!
|
||
|
|
! ldfjac is a positive integer input variable not less than n
|
||
|
|
! which specifies the leading dimension of the array fjac.
|
||
|
|
!
|
||
|
|
! xtol is a nonnegative input variable. termination
|
||
|
|
! occurs when the relative error between two consecutive
|
||
|
|
! iterates is at most xtol.
|
||
|
|
!
|
||
|
|
! maxfev is a positive integer input variable. termination
|
||
|
|
! occurs when the number of calls to fcn with iflag = 1
|
||
|
|
! has reached maxfev.
|
||
|
|
!
|
||
|
|
! 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.
|
||
|
|
!
|
||
|
|
! mode is an integer input variable. if mode = 1, the
|
||
|
|
! variables will be scaled internally. if mode = 2,
|
||
|
|
! the scaling is specified by the input diag. other
|
||
|
|
! values of mode are equivalent to mode = 1.
|
||
|
|
!
|
||
|
|
! factor is a positive input variable used in determining the
|
||
|
|
! initial step bound. this bound is set to the product of
|
||
|
|
! factor and the euclidean norm of diag*x if nonzero, or else
|
||
|
|
! to factor itself. in most cases factor should lie in the
|
||
|
|
! interval (.1,100.). 100. is a generally recommended value.
|
||
|
|
!
|
||
|
|
! 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 special calls of fcn
|
||
|
|
! with iflag = 0 are made.
|
||
|
|
!
|
||
|
|
! 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.
|
||
|
|
!
|
||
|
|
! info = 0 improper input parameters.
|
||
|
|
!
|
||
|
|
! info = 1 relative error between two consecutive iterates
|
||
|
|
! is at most xtol.
|
||
|
|
!
|
||
|
|
! info = 2 number of calls to fcn with iflag = 1 has
|
||
|
|
! reached maxfev.
|
||
|
|
!
|
||
|
|
! info = 3 xtol is too small. no further improvement in
|
||
|
|
! the approximate solution x is possible.
|
||
|
|
!
|
||
|
|
! info = 4 iteration is not making good progress, as
|
||
|
|
! measured by the improvement from the last
|
||
|
|
! five jacobian evaluations.
|
||
|
|
!
|
||
|
|
! info = 5 iteration is not making good progress, as
|
||
|
|
! measured by the improvement from the last
|
||
|
|
! ten iterations.
|
||
|
|
!
|
||
|
|
! nfev is an integer output variable set to the number of
|
||
|
|
! calls to fcn with iflag = 1.
|
||
|
|
!
|
||
|
|
! njev is an integer output variable set to the number of
|
||
|
|
! calls to fcn with iflag = 2.
|
||
|
|
!
|
||
|
|
! 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.
|
||
|
|
!
|
||
|
|
! lr is a positive integer input variable not less than
|
||
|
|
! (n*(n+1))/2.
|
||
|
|
!
|
||
|
|
! qtf is an output array of length n which contains
|
||
|
|
! the vector (q transpose)*fvec.
|
||
|
|
!
|
||
|
|
! wa1, wa2, wa3, and wa4 are work arrays of length n.
|
||
|
|
!
|
||
|
|
! subprograms called
|
||
|
|
!
|
||
|
|
! user-supplied ...... fcn
|
||
|
|
!
|
||
|
|
! minpack-supplied ... dogleg,enorm,
|
||
|
|
! qform,qrfac,r1mpyq,r1updt
|
||
|
|
!
|
||
|
|
! fortran-supplied ... abs,dmax1,dmin1,mod
|
||
|
|
!
|
||
|
|
! argonne national laboratory. minpack project. march 1980.
|
||
|
|
! burton s. garbow, kenneth e. hillstrom, jorge j. more
|
||
|
|
!
|
||
|
|
! **********
|
||
|
|
! local variables
|
||
|
|
integer :: i, iflag, iter, j, jm1, l, ncfail, ncsuc, nslow1, nslow2
|
||
|
|
integer, dimension(1) :: iwa
|
||
|
|
logical :: jeval, sing
|
||
|
|
real(wp_) :: actred, delta, fnorm, fnorm1, pnorm, prered, &
|
||
|
|
ratio, summ, temp, xnorm
|
||
|
|
! parameters
|
||
|
|
real(wp_), parameter :: p1 = 1.0e-1_wp_, p5 = 5.0e-1_wp_, &
|
||
|
|
p001 = 1.0e-3_wp_, p0001 = 1.0e-4_wp_
|
||
|
|
|
||
|
|
interface
|
||
|
|
subroutine fcn(n,x,fvec,fjac,ldfjac,iflag)
|
||
|
|
use const_and_precisions, only : wp_
|
||
|
|
implicit none
|
||
|
|
integer, intent(in) :: n,ldfjac,iflag
|
||
|
|
real(wp_), intent(in) :: x(n)
|
||
|
|
real(wp_), intent(inout) :: fvec(n),fjac(ldfjac,n)
|
||
|
|
end subroutine fcn
|
||
|
|
end interface
|
||
|
|
!
|
||
|
|
info = 0
|
||
|
|
iflag = 0
|
||
|
|
nfev = 0
|
||
|
|
njev = 0
|
||
|
|
!
|
||
|
|
! check the input parameters for errors.
|
||
|
|
!
|
||
|
|
if (n <= 0 .or. ldfjac < n .or. xtol < zero &
|
||
|
|
.or. maxfev <= 0 .or. factor <= zero &
|
||
|
|
.or. lr < (n*(n + 1))/2) go to 300
|
||
|
|
if (mode == 2) then
|
||
|
|
do j = 1, n
|
||
|
|
if (diag(j) <= zero) go to 300
|
||
|
|
end do
|
||
|
|
end if
|
||
|
|
!
|
||
|
|
! evaluate the function at the starting point
|
||
|
|
! and calculate its norm.
|
||
|
|
!
|
||
|
|
iflag = 1
|
||
|
|
call fcn(n,x,fvec,fjac,ldfjac,iflag)
|
||
|
|
nfev = 1
|
||
|
|
if (iflag < 0) go to 300
|
||
|
|
fnorm = enorm(n,fvec)
|
||
|
|
!
|
||
|
|
! initialize iteration counter and monitors.
|
||
|
|
!
|
||
|
|
iter = 1
|
||
|
|
ncsuc = 0
|
||
|
|
ncfail = 0
|
||
|
|
nslow1 = 0
|
||
|
|
nslow2 = 0
|
||
|
|
!
|
||
|
|
! beginning of the outer loop.
|
||
|
|
!
|
||
|
|
do
|
||
|
|
jeval = .true.
|
||
|
|
!
|
||
|
|
! calculate the jacobian matrix.
|
||
|
|
!
|
||
|
|
iflag = 2
|
||
|
|
call fcn(n,x,fvec,fjac,ldfjac,iflag)
|
||
|
|
njev = njev + 1
|
||
|
|
if (iflag < 0) go to 300
|
||
|
|
!
|
||
|
|
! compute the qr factorization of the jacobian.
|
||
|
|
!
|
||
|
|
call qrfac(n,n,fjac,ldfjac,.false.,iwa,1,wa1,wa2,wa3)
|
||
|
|
!
|
||
|
|
! on the first iteration and if mode is 1, scale according
|
||
|
|
! to the norms of the columns of the initial jacobian.
|
||
|
|
!
|
||
|
|
if (iter == 1) then
|
||
|
|
if (mode /= 2) then
|
||
|
|
do j = 1, n
|
||
|
|
diag(j) = wa2(j)
|
||
|
|
if (wa2(j) == zero) diag(j) = one
|
||
|
|
end do
|
||
|
|
end if
|
||
|
|
!
|
||
|
|
! on the first iteration, calculate the norm of the scaled x
|
||
|
|
! and initialize the step bound delta.
|
||
|
|
!
|
||
|
|
do j = 1, n
|
||
|
|
wa3(j) = diag(j)*x(j)
|
||
|
|
end do
|
||
|
|
xnorm = enorm(n,wa3)
|
||
|
|
delta = factor*xnorm
|
||
|
|
if (delta == zero) delta = factor
|
||
|
|
end if
|
||
|
|
!
|
||
|
|
! form (q transpose)*fvec and store in qtf.
|
||
|
|
!
|
||
|
|
do i = 1, n
|
||
|
|
qtf(i) = fvec(i)
|
||
|
|
end do
|
||
|
|
do j = 1, n
|
||
|
|
if (fjac(j,j) /= zero) then
|
||
|
|
summ = zero
|
||
|
|
do i = j, n
|
||
|
|
summ = summ + fjac(i,j)*qtf(i)
|
||
|
|
end do
|
||
|
|
temp = -summ/fjac(j,j)
|
||
|
|
do i = j, n
|
||
|
|
qtf(i) = qtf(i) + fjac(i,j)*temp
|
||
|
|
end do
|
||
|
|
end if
|
||
|
|
end do
|
||
|
|
!
|
||
|
|
! copy the triangular factor of the qr factorization into r.
|
||
|
|
!
|
||
|
|
sing = .false.
|
||
|
|
do j = 1, n
|
||
|
|
l = j
|
||
|
|
jm1 = j - 1
|
||
|
|
do i = 1, jm1
|
||
|
|
r(l) = fjac(i,j)
|
||
|
|
l = l + n - i
|
||
|
|
end do
|
||
|
|
r(l) = wa1(j)
|
||
|
|
if (wa1(j) == zero) sing = .true.
|
||
|
|
end do
|
||
|
|
!
|
||
|
|
! accumulate the orthogonal factor in fjac.
|
||
|
|
!
|
||
|
|
call qform(n,n,fjac,ldfjac,wa1)
|
||
|
|
!
|
||
|
|
! rescale if necessary.
|
||
|
|
!
|
||
|
|
if (mode /= 2) then
|
||
|
|
do j = 1, n
|
||
|
|
diag(j) = dmax1(diag(j),wa2(j))
|
||
|
|
end do
|
||
|
|
end if
|
||
|
|
!
|
||
|
|
! beginning of the inner loop.
|
||
|
|
!
|
||
|
|
do
|
||
|
|
!
|
||
|
|
! if requested, call fcn to enable printing of iterates.
|
||
|
|
!
|
||
|
|
if (nprint > 0) then
|
||
|
|
iflag = 0
|
||
|
|
if (mod(iter-1,nprint) == 0) call fcn(n,x,fvec,fjac,ldfjac,iflag)
|
||
|
|
if (iflag < 0) go to 300
|
||
|
|
end if
|
||
|
|
!
|
||
|
|
! determine the direction p.
|
||
|
|
!
|
||
|
|
call dogleg(n,r,lr,diag,qtf,delta,wa1,wa2,wa3)
|
||
|
|
!
|
||
|
|
! store the direction p and x + p. calculate the norm of p.
|
||
|
|
!
|
||
|
|
do j = 1, n
|
||
|
|
wa1(j) = -wa1(j)
|
||
|
|
wa2(j) = x(j) + wa1(j)
|
||
|
|
wa3(j) = diag(j)*wa1(j)
|
||
|
|
end do
|
||
|
|
pnorm = enorm(n,wa3)
|
||
|
|
!
|
||
|
|
! on the first iteration, adjust the initial step bound.
|
||
|
|
!
|
||
|
|
if (iter == 1) delta = dmin1(delta,pnorm)
|
||
|
|
!
|
||
|
|
! evaluate the function at x + p and calculate its norm.
|
||
|
|
!
|
||
|
|
iflag = 1
|
||
|
|
call fcn(n,wa2,wa4,fjac,ldfjac,iflag)
|
||
|
|
nfev = nfev + 1
|
||
|
|
if (iflag < 0) go to 300
|
||
|
|
fnorm1 = enorm(n,wa4)
|
||
|
|
!
|
||
|
|
! compute the scaled actual reduction.
|
||
|
|
!
|
||
|
|
actred = -one
|
||
|
|
if (fnorm1 < fnorm) actred = one - (fnorm1/fnorm)**2
|
||
|
|
!
|
||
|
|
! compute the scaled predicted reduction.
|
||
|
|
!
|
||
|
|
l = 1
|
||
|
|
do i = 1, n
|
||
|
|
summ = zero
|
||
|
|
do j = i, n
|
||
|
|
summ = summ + r(l)*wa1(j)
|
||
|
|
l = l + 1
|
||
|
|
end do
|
||
|
|
wa3(i) = qtf(i) + summ
|
||
|
|
end do
|
||
|
|
temp = enorm(n,wa3)
|
||
|
|
prered = zero
|
||
|
|
if (temp < fnorm) prered = one - (temp/fnorm)**2
|
||
|
|
!
|
||
|
|
! compute the ratio of the actual to the predicted
|
||
|
|
! reduction.
|
||
|
|
!
|
||
|
|
ratio = zero
|
||
|
|
if (prered > zero) ratio = actred/prered
|
||
|
|
!
|
||
|
|
! update the step bound.
|
||
|
|
!
|
||
|
|
if (ratio < p1) then
|
||
|
|
ncsuc = 0
|
||
|
|
ncfail = ncfail + 1
|
||
|
|
delta = p5*delta
|
||
|
|
else
|
||
|
|
ncfail = 0
|
||
|
|
ncsuc = ncsuc + 1
|
||
|
|
if (ratio >= p5 .or. ncsuc > 1) delta = dmax1(delta,pnorm/p5)
|
||
|
|
if (abs(ratio-one) <= p1) delta = pnorm/p5
|
||
|
|
end if
|
||
|
|
!
|
||
|
|
! test for successful iteration.
|
||
|
|
!
|
||
|
|
if (ratio >= p0001) then
|
||
|
|
!
|
||
|
|
! successful iteration. update x, fvec, and their norms.
|
||
|
|
!
|
||
|
|
do j = 1, n
|
||
|
|
x(j) = wa2(j)
|
||
|
|
wa2(j) = diag(j)*x(j)
|
||
|
|
fvec(j) = wa4(j)
|
||
|
|
end do
|
||
|
|
xnorm = enorm(n,wa2)
|
||
|
|
fnorm = fnorm1
|
||
|
|
iter = iter + 1
|
||
|
|
end if
|
||
|
|
!
|
||
|
|
! determine the progress of the iteration.
|
||
|
|
!
|
||
|
|
nslow1 = nslow1 + 1
|
||
|
|
if (actred >= p001) nslow1 = 0
|
||
|
|
if (jeval) nslow2 = nslow2 + 1
|
||
|
|
if (actred >= p1) nslow2 = 0
|
||
|
|
!
|
||
|
|
! test for convergence.
|
||
|
|
!
|
||
|
|
if (delta <= xtol*xnorm .or. fnorm == zero) info = 1
|
||
|
|
if (info /= 0) go to 300
|
||
|
|
!
|
||
|
|
! tests for termination and stringent tolerances.
|
||
|
|
!
|
||
|
|
if (nfev >= maxfev) info = 2
|
||
|
|
if (p1*dmax1(p1*delta,pnorm) <= epsmch*xnorm) info = 3
|
||
|
|
if (nslow2 == 5) info = 4
|
||
|
|
if (nslow1 == 10) info = 5
|
||
|
|
if (info /= 0) go to 300
|
||
|
|
!
|
||
|
|
! criterion for recalculating jacobian.
|
||
|
|
!
|
||
|
|
if (ncfail == 2) exit
|
||
|
|
!
|
||
|
|
! calculate the rank one modification to the jacobian
|
||
|
|
! and update qtf if necessary.
|
||
|
|
!
|
||
|
|
do j = 1, n
|
||
|
|
summ = zero
|
||
|
|
do i = 1, n
|
||
|
|
summ = summ + fjac(i,j)*wa4(i)
|
||
|
|
end do
|
||
|
|
wa2(j) = (summ - wa3(j))/pnorm
|
||
|
|
wa1(j) = diag(j)*((diag(j)*wa1(j))/pnorm)
|
||
|
|
if (ratio >= p0001) qtf(j) = summ
|
||
|
|
end do
|
||
|
|
!
|
||
|
|
! compute the qr factorization of the updated jacobian.
|
||
|
|
!
|
||
|
|
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)
|
||
|
|
!
|
||
|
|
! end of the inner loop.
|
||
|
|
!
|
||
|
|
jeval = .false.
|
||
|
|
end do
|
||
|
|
!
|
||
|
|
! end of the outer loop.
|
||
|
|
!
|
||
|
|
end do
|
||
|
|
300 continue
|
||
|
|
!
|
||
|
|
! termination, either normal or user imposed.
|
||
|
|
!
|
||
|
|
if (iflag < 0) info = iflag
|
||
|
|
iflag = 0
|
||
|
|
if (nprint > 0) call fcn(n,x,fvec,fjac,ldfjac,iflag)
|
||
|
|
end subroutine hybrj
|
||
|
|
|
||
|
|
subroutine hybrj1mv(fcn,n,x,f0,fvec,fjac,ldfjac,tol,info,wa,lwa)
|
||
|
|
use const_and_precisions, only : zero, one
|
||
|
|
implicit none
|
||
|
|
! arguments
|
||
|
|
integer, intent(in) :: n, ldfjac, lwa
|
||
|
|
integer, intent(out) :: info
|
||
|
|
real(wp_), intent(in) :: tol,f0(n)
|
||
|
|
real(wp_), intent(out) :: wa(lwa)
|
||
|
|
real(wp_), intent(inout) :: fvec(n), fjac(ldfjac,n), x(n)
|
||
|
|
! **********
|
||
|
|
!
|
||
|
|
! subroutine hybrj1mv
|
||
|
|
!
|
||
|
|
! the purpose of hybrj1mv is to find a zero of a system of
|
||
|
|
! n nonlinear functions in n variables by a modification
|
||
|
|
! of the powell hybrid method. this is done by using the
|
||
|
|
! more general nonlinear equation solver hybrjmv. the user
|
||
|
|
! must provide a subroutine which calculates the functions
|
||
|
|
! and the jacobian.
|
||
|
|
!
|
||
|
|
! the subroutine statement is
|
||
|
|
!
|
||
|
|
! subroutine hybrj1mv(fcn,n,x,f0,fvec,fjac,ldfjac,tol,info,wa,lwa)
|
||
|
|
!
|
||
|
|
! where
|
||
|
|
!
|
||
|
|
! fcn is the name of the user-supplied subroutine which
|
||
|
|
! calculates the functions and the jacobian. fcn must
|
||
|
|
! be declared in an external statement in the user
|
||
|
|
! calling program, and should be written as follows.
|
||
|
|
!
|
||
|
|
! subroutine fcn(n,x,f0,fvec,fjac,ldfjac,iflag)
|
||
|
|
! integer n,ldfjac,iflag
|
||
|
|
! real(8) 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
|
||
|
|
!
|
||
|
|
! the value of iflag should not be changed by fcn unless
|
||
|
|
! the user wants to terminate execution of hybrj1mv.
|
||
|
|
! in this case set iflag to a negative integer.
|
||
|
|
!
|
||
|
|
! n is a positive integer input variable set to the number
|
||
|
|
! of functions and variables.
|
||
|
|
!
|
||
|
|
! 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.
|
||
|
|
!
|
||
|
|
! fvec is an output array of length n which contains
|
||
|
|
! the functions evaluated at the output x.
|
||
|
|
!
|
||
|
|
! fjac is an output n by n array which contains the
|
||
|
|
! orthogonal matrix q produced by the qr factorization
|
||
|
|
! of the final approximate jacobian.
|
||
|
|
!
|
||
|
|
! ldfjac is a positive integer input variable not less than n
|
||
|
|
! which specifies the leading dimension of the array fjac.
|
||
|
|
!
|
||
|
|
! 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.
|
||
|
|
!
|
||
|
|
! 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.
|
||
|
|
!
|
||
|
|
! info = 0 improper input parameters.
|
||
|
|
!
|
||
|
|
! info = 1 algorithm estimates that the relative error
|
||
|
|
! between x and the solution is at most tol.
|
||
|
|
!
|
||
|
|
! info = 2 number of calls to fcn with iflag = 1 has
|
||
|
|
! reached 100*(n+1).
|
||
|
|
!
|
||
|
|
! info = 3 tol is too small. no further improvement in
|
||
|
|
! the approximate solution x is possible.
|
||
|
|
!
|
||
|
|
! info = 4 iteration is not making good progress.
|
||
|
|
!
|
||
|
|
! wa is a work array of length lwa.
|
||
|
|
!
|
||
|
|
! lwa is a positive integer input variable not less than
|
||
|
|
! (n*(n+13))/2.
|
||
|
|
!
|
||
|
|
! subprograms called
|
||
|
|
!
|
||
|
|
! user-supplied ...... fcn
|
||
|
|
!
|
||
|
|
! minpack-supplied ... hybrjmv
|
||
|
|
!
|
||
|
|
! argonne national laboratory. minpack project. march 1980.
|
||
|
|
! burton s. garbow, kenneth e. hillstrom, jorge j. more
|
||
|
|
!
|
||
|
|
! **********
|
||
|
|
! local variables
|
||
|
|
integer :: j, lr, maxfev, mode, nfev, njev, nprint
|
||
|
|
real(wp_) :: xtol
|
||
|
|
! parameters
|
||
|
|
real(wp_), parameter :: factor=1.0e2_wp_
|
||
|
|
|
||
|
|
interface
|
||
|
|
subroutine fcn(n,x,f0,fvec,fjac,ldfjac,iflag)
|
||
|
|
use const_and_precisions, only : wp_
|
||
|
|
implicit none
|
||
|
|
integer, intent(in) :: n,ldfjac,iflag
|
||
|
|
real(wp_), intent(in) :: x(n),f0(n)
|
||
|
|
real(wp_), intent(inout) :: fvec(n),fjac(ldfjac,n)
|
||
|
|
end subroutine fcn
|
||
|
|
end interface
|
||
|
|
|
||
|
|
info = 0
|
||
|
|
!
|
||
|
|
! check the input parameters for errors.
|
||
|
|
!
|
||
|
|
if (n <= 0 .or. ldfjac < n .or. tol < zero &
|
||
|
|
.or. lwa < (n*(n + 13))/2) return
|
||
|
|
!
|
||
|
|
! call hybrjmv.
|
||
|
|
!
|
||
|
|
maxfev = 100*(n + 1)
|
||
|
|
xtol = tol
|
||
|
|
mode = 2
|
||
|
|
do j = 1, n
|
||
|
|
wa(j) = one
|
||
|
|
end do
|
||
|
|
nprint = 0
|
||
|
|
lr = (n*(n + 1))/2
|
||
|
|
call hybrjmv(fcn,n,x,f0,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 == 5) info = 4
|
||
|
|
end subroutine hybrj1mv
|
||
|
|
|
||
|
|
subroutine hybrjmv(fcn,n,x,f0,fvec,fjac,ldfjac,xtol,maxfev,diag,mode, &
|
||
|
|
factor,nprint,info,nfev,njev,r,lr,qtf,wa1,wa2, &
|
||
|
|
wa3,wa4)
|
||
|
|
use const_and_precisions, only : zero, one, epsmch=>comp_eps
|
||
|
|
implicit none
|
||
|
|
! arguments
|
||
|
|
integer, intent(in) :: n, ldfjac, maxfev, mode, nprint, lr
|
||
|
|
integer, intent(out) :: info, nfev, njev
|
||
|
|
real(wp_), intent(in) :: xtol, factor, f0(n)
|
||
|
|
real(wp_), intent(out) :: fvec(n), fjac(ldfjac,n), r(lr), qtf(n), &
|
||
|
|
wa1(n), wa2(n), wa3(n), wa4(n)
|
||
|
|
real(wp_), intent(inout) :: x(n), diag(n)
|
||
|
|
! **********
|
||
|
|
!
|
||
|
|
! subroutine hybrj
|
||
|
|
!
|
||
|
|
! the purpose of hybrj is to find a zero of a system of
|
||
|
|
! n nonlinear functions in n variables by a modification
|
||
|
|
! of the powell hybrid method. the user must provide a
|
||
|
|
! subroutine which calculates the functions and the jacobian.
|
||
|
|
!
|
||
|
|
! the subroutine statement is
|
||
|
|
!
|
||
|
|
! subroutine hybrj(fcn,n,x,f0,fvec,fjac,ldfjac,xtol,maxfev,diag,
|
||
|
|
! mode,factor,nprint,info,nfev,njev,r,lr,qtf,
|
||
|
|
! wa1,wa2,wa3,wa4)
|
||
|
|
!
|
||
|
|
! where
|
||
|
|
!
|
||
|
|
! fcn is the name of the user-supplied subroutine which
|
||
|
|
! calculates the functions and the jacobian. fcn must
|
||
|
|
! be declared in an external statement in the user
|
||
|
|
! calling program, and should be written as follows.
|
||
|
|
!
|
||
|
|
! subroutine fcn(n,x,f0,fvec,fjac,ldfjac,iflag)
|
||
|
|
! integer n,ldfjac,iflag
|
||
|
|
! real(8) x(n),f0(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
|
||
|
|
!
|
||
|
|
! 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.
|
||
|
|
!
|
||
|
|
! n is a positive integer input variable set to the number
|
||
|
|
! of functions and variables.
|
||
|
|
!
|
||
|
|
! 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.
|
||
|
|
!
|
||
|
|
! fvec is an output array of length n which contains
|
||
|
|
! the functions evaluated at the output x.
|
||
|
|
!
|
||
|
|
! fjac is an output n by n array which contains the
|
||
|
|
! orthogonal matrix q produced by the qr factorization
|
||
|
|
! of the final approximate jacobian.
|
||
|
|
!
|
||
|
|
! ldfjac is a positive integer input variable not less than n
|
||
|
|
! which specifies the leading dimension of the array fjac.
|
||
|
|
!
|
||
|
|
! xtol is a nonnegative input variable. termination
|
||
|
|
! occurs when the relative error between two consecutive
|
||
|
|
! iterates is at most xtol.
|
||
|
|
!
|
||
|
|
! maxfev is a positive integer input variable. termination
|
||
|
|
! occurs when the number of calls to fcn with iflag = 1
|
||
|
|
! has reached maxfev.
|
||
|
|
!
|
||
|
|
! 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.
|
||
|
|
!
|
||
|
|
! mode is an integer input variable. if mode = 1, the
|
||
|
|
! variables will be scaled internally. if mode = 2,
|
||
|
|
! the scaling is specified by the input diag. other
|
||
|
|
! values of mode are equivalent to mode = 1.
|
||
|
|
!
|
||
|
|
! factor is a positive input variable used in determining the
|
||
|
|
! initial step bound. this bound is set to the product of
|
||
|
|
! factor and the euclidean norm of diag*x if nonzero, or else
|
||
|
|
! to factor itself. in most cases factor should lie in the
|
||
|
|
! interval (.1,100.). 100. is a generally recommended value.
|
||
|
|
!
|
||
|
|
! 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 special calls of fcn
|
||
|
|
! with iflag = 0 are made.
|
||
|
|
!
|
||
|
|
! 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.
|
||
|
|
!
|
||
|
|
! info = 0 improper input parameters.
|
||
|
|
!
|
||
|
|
! info = 1 relative error between two consecutive iterates
|
||
|
|
! is at most xtol.
|
||
|
|
!
|
||
|
|
! info = 2 number of calls to fcn with iflag = 1 has
|
||
|
|
! reached maxfev.
|
||
|
|
!
|
||
|
|
! info = 3 xtol is too small. no further improvement in
|
||
|
|
! the approximate solution x is possible.
|
||
|
|
!
|
||
|
|
! info = 4 iteration is not making good progress, as
|
||
|
|
! measured by the improvement from the last
|
||
|
|
! five jacobian evaluations.
|
||
|
|
!
|
||
|
|
! info = 5 iteration is not making good progress, as
|
||
|
|
! measured by the improvement from the last
|
||
|
|
! ten iterations.
|
||
|
|
!
|
||
|
|
! nfev is an integer output variable set to the number of
|
||
|
|
! calls to fcn with iflag = 1.
|
||
|
|
!
|
||
|
|
! njev is an integer output variable set to the number of
|
||
|
|
! calls to fcn with iflag = 2.
|
||
|
|
!
|
||
|
|
! 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.
|
||
|
|
!
|
||
|
|
! lr is a positive integer input variable not less than
|
||
|
|
! (n*(n+1))/2.
|
||
|
|
!
|
||
|
|
! qtf is an output array of length n which contains
|
||
|
|
! the vector (q transpose)*fvec.
|
||
|
|
!
|
||
|
|
! wa1, wa2, wa3, and wa4 are work arrays of length n.
|
||
|
|
!
|
||
|
|
! subprograms called
|
||
|
|
!
|
||
|
|
! user-supplied ...... fcn
|
||
|
|
!
|
||
|
|
! minpack-supplied ... dogleg,enorm,
|
||
|
|
! qform,qrfac,r1mpyq,r1updt
|
||
|
|
!
|
||
|
|
! fortran-supplied ... abs,dmax1,dmin1,mod
|
||
|
|
!
|
||
|
|
! argonne national laboratory. minpack project. march 1980.
|
||
|
|
! burton s. garbow, kenneth e. hillstrom, jorge j. more
|
||
|
|
!
|
||
|
|
! **********
|
||
|
|
! local variables
|
||
|
|
integer :: i, iflag, iter, j, jm1, l, ncfail, ncsuc, nslow1, nslow2
|
||
|
|
integer, dimension(1) :: iwa
|
||
|
|
logical :: jeval, sing
|
||
|
|
real(wp_) :: actred, delta, fnorm, fnorm1, pnorm, prered, &
|
||
|
|
ratio, summ, temp, xnorm
|
||
|
|
! parameters
|
||
|
|
real(wp_), parameter :: p1 = 1.0e-1_wp_, p5 = 5.0e-1_wp_, &
|
||
|
|
p001 = 1.0e-3_wp_, p0001 = 1.0e-4_wp_
|
||
|
|
|
||
|
|
interface
|
||
|
|
subroutine fcn(n,x,f0,fvec,fjac,ldfjac,iflag)
|
||
|
|
use const_and_precisions, only : wp_
|
||
|
|
implicit none
|
||
|
|
integer, intent(in) :: n,ldfjac,iflag
|
||
|
|
real(wp_), intent(in) :: x(n),f0(n)
|
||
|
|
real(wp_), intent(inout) :: fvec(n),fjac(ldfjac,n)
|
||
|
|
end subroutine fcn
|
||
|
|
end interface
|
||
|
|
!
|
||
|
|
info = 0
|
||
|
|
iflag = 0
|
||
|
|
nfev = 0
|
||
|
|
njev = 0
|
||
|
|
!
|
||
|
|
! check the input parameters for errors.
|
||
|
|
!
|
||
|
|
if (n <= 0 .or. ldfjac < n .or. xtol < zero &
|
||
|
|
.or. maxfev <= 0 .or. factor <= zero &
|
||
|
|
.or. lr < (n*(n + 1))/2) go to 300
|
||
|
|
if (mode == 2) then
|
||
|
|
do j = 1, n
|
||
|
|
if (diag(j) <= zero) go to 300
|
||
|
|
end do
|
||
|
|
end if
|
||
|
|
!
|
||
|
|
! evaluate the function at the starting point
|
||
|
|
! and calculate its norm.
|
||
|
|
!
|
||
|
|
iflag = 1
|
||
|
|
call fcn(n,x,f0,fvec,fjac,ldfjac,iflag)
|
||
|
|
nfev = 1
|
||
|
|
if (iflag < 0) go to 300
|
||
|
|
fnorm = enorm(n,fvec)
|
||
|
|
!
|
||
|
|
! initialize iteration counter and monitors.
|
||
|
|
!
|
||
|
|
iter = 1
|
||
|
|
ncsuc = 0
|
||
|
|
ncfail = 0
|
||
|
|
nslow1 = 0
|
||
|
|
nslow2 = 0
|
||
|
|
!
|
||
|
|
! beginning of the outer loop.
|
||
|
|
!
|
||
|
|
do
|
||
|
|
jeval = .true.
|
||
|
|
!
|
||
|
|
! calculate the jacobian matrix.
|
||
|
|
!
|
||
|
|
iflag = 2
|
||
|
|
call fcn(n,x,f0,fvec,fjac,ldfjac,iflag)
|
||
|
|
njev = njev + 1
|
||
|
|
if (iflag < 0) go to 300
|
||
|
|
!
|
||
|
|
! compute the qr factorization of the jacobian.
|
||
|
|
!
|
||
|
|
call qrfac(n,n,fjac,ldfjac,.false.,iwa,1,wa1,wa2,wa3)
|
||
|
|
!
|
||
|
|
! on the first iteration and if mode is 1, scale according
|
||
|
|
! to the norms of the columns of the initial jacobian.
|
||
|
|
!
|
||
|
|
if (iter == 1) then
|
||
|
|
if (mode /= 2) then
|
||
|
|
do j = 1, n
|
||
|
|
diag(j) = wa2(j)
|
||
|
|
if (wa2(j) == zero) diag(j) = one
|
||
|
|
end do
|
||
|
|
end if
|
||
|
|
!
|
||
|
|
! on the first iteration, calculate the norm of the scaled x
|
||
|
|
! and initialize the step bound delta.
|
||
|
|
!
|
||
|
|
do j = 1, n
|
||
|
|
wa3(j) = diag(j)*x(j)
|
||
|
|
end do
|
||
|
|
xnorm = enorm(n,wa3)
|
||
|
|
delta = factor*xnorm
|
||
|
|
if (delta == zero) delta = factor
|
||
|
|
end if
|
||
|
|
!
|
||
|
|
! form (q transpose)*fvec and store in qtf.
|
||
|
|
!
|
||
|
|
do i = 1, n
|
||
|
|
qtf(i) = fvec(i)
|
||
|
|
end do
|
||
|
|
do j = 1, n
|
||
|
|
if (fjac(j,j) /= zero) then
|
||
|
|
summ = zero
|
||
|
|
do i = j, n
|
||
|
|
summ = summ + fjac(i,j)*qtf(i)
|
||
|
|
end do
|
||
|
|
temp = -summ/fjac(j,j)
|
||
|
|
do i = j, n
|
||
|
|
qtf(i) = qtf(i) + fjac(i,j)*temp
|
||
|
|
end do
|
||
|
|
end if
|
||
|
|
end do
|
||
|
|
!
|
||
|
|
! copy the triangular factor of the qr factorization into r.
|
||
|
|
!
|
||
|
|
sing = .false.
|
||
|
|
do j = 1, n
|
||
|
|
l = j
|
||
|
|
jm1 = j - 1
|
||
|
|
do i = 1, jm1
|
||
|
|
r(l) = fjac(i,j)
|
||
|
|
l = l + n - i
|
||
|
|
end do
|
||
|
|
r(l) = wa1(j)
|
||
|
|
if (wa1(j) == zero) sing = .true.
|
||
|
|
end do
|
||
|
|
!
|
||
|
|
! accumulate the orthogonal factor in fjac.
|
||
|
|
!
|
||
|
|
call qform(n,n,fjac,ldfjac,wa1)
|
||
|
|
!
|
||
|
|
! rescale if necessary.
|
||
|
|
!
|
||
|
|
if (mode /= 2) then
|
||
|
|
do j = 1, n
|
||
|
|
diag(j) = dmax1(diag(j),wa2(j))
|
||
|
|
end do
|
||
|
|
end if
|
||
|
|
!
|
||
|
|
! beginning of the inner loop.
|
||
|
|
!
|
||
|
|
do
|
||
|
|
!
|
||
|
|
! if requested, call fcn to enable printing of iterates.
|
||
|
|
!
|
||
|
|
if (nprint > 0) then
|
||
|
|
iflag = 0
|
||
|
|
if (mod(iter-1,nprint) == 0) call fcn(n,x,f0,fvec,fjac,ldfjac,iflag)
|
||
|
|
if (iflag < 0) go to 300
|
||
|
|
end if
|
||
|
|
!
|
||
|
|
! determine the direction p.
|
||
|
|
!
|
||
|
|
call dogleg(n,r,lr,diag,qtf,delta,wa1,wa2,wa3)
|
||
|
|
!
|
||
|
|
! store the direction p and x + p. calculate the norm of p.
|
||
|
|
!
|
||
|
|
do j = 1, n
|
||
|
|
wa1(j) = -wa1(j)
|
||
|
|
wa2(j) = x(j) + wa1(j)
|
||
|
|
wa3(j) = diag(j)*wa1(j)
|
||
|
|
end do
|
||
|
|
pnorm = enorm(n,wa3)
|
||
|
|
!
|
||
|
|
! on the first iteration, adjust the initial step bound.
|
||
|
|
!
|
||
|
|
if (iter == 1) delta = dmin1(delta,pnorm)
|
||
|
|
!
|
||
|
|
! evaluate the function at x + p and calculate its norm.
|
||
|
|
!
|
||
|
|
iflag = 1
|
||
|
|
call fcn(n,wa2,f0,wa4,fjac,ldfjac,iflag)
|
||
|
|
nfev = nfev + 1
|
||
|
|
if (iflag < 0) go to 300
|
||
|
|
fnorm1 = enorm(n,wa4)
|
||
|
|
!
|
||
|
|
! compute the scaled actual reduction.
|
||
|
|
!
|
||
|
|
actred = -one
|
||
|
|
if (fnorm1 < fnorm) actred = one - (fnorm1/fnorm)**2
|
||
|
|
!
|
||
|
|
! compute the scaled predicted reduction.
|
||
|
|
!
|
||
|
|
l = 1
|
||
|
|
do i = 1, n
|
||
|
|
summ = zero
|
||
|
|
do j = i, n
|
||
|
|
summ = summ + r(l)*wa1(j)
|
||
|
|
l = l + 1
|
||
|
|
end do
|
||
|
|
wa3(i) = qtf(i) + summ
|
||
|
|
end do
|
||
|
|
temp = enorm(n,wa3)
|
||
|
|
prered = zero
|
||
|
|
if (temp < fnorm) prered = one - (temp/fnorm)**2
|
||
|
|
!
|
||
|
|
! compute the ratio of the actual to the predicted
|
||
|
|
! reduction.
|
||
|
|
!
|
||
|
|
ratio = zero
|
||
|
|
if (prered > zero) ratio = actred/prered
|
||
|
|
!
|
||
|
|
! update the step bound.
|
||
|
|
!
|
||
|
|
if (ratio < p1) then
|
||
|
|
ncsuc = 0
|
||
|
|
ncfail = ncfail + 1
|
||
|
|
delta = p5*delta
|
||
|
|
else
|
||
|
|
ncfail = 0
|
||
|
|
ncsuc = ncsuc + 1
|
||
|
|
if (ratio >= p5 .or. ncsuc > 1) delta = dmax1(delta,pnorm/p5)
|
||
|
|
if (abs(ratio-one) <= p1) delta = pnorm/p5
|
||
|
|
end if
|
||
|
|
!
|
||
|
|
! test for successful iteration.
|
||
|
|
!
|
||
|
|
if (ratio >= p0001) then
|
||
|
|
!
|
||
|
|
! successful iteration. update x, fvec, and their norms.
|
||
|
|
!
|
||
|
|
do j = 1, n
|
||
|
|
x(j) = wa2(j)
|
||
|
|
wa2(j) = diag(j)*x(j)
|
||
|
|
fvec(j) = wa4(j)
|
||
|
|
end do
|
||
|
|
xnorm = enorm(n,wa2)
|
||
|
|
fnorm = fnorm1
|
||
|
|
iter = iter + 1
|
||
|
|
end if
|
||
|
|
!
|
||
|
|
! determine the progress of the iteration.
|
||
|
|
!
|
||
|
|
nslow1 = nslow1 + 1
|
||
|
|
if (actred >= p001) nslow1 = 0
|
||
|
|
if (jeval) nslow2 = nslow2 + 1
|
||
|
|
if (actred >= p1) nslow2 = 0
|
||
|
|
!
|
||
|
|
! test for convergence.
|
||
|
|
!
|
||
|
|
if (delta <= xtol*xnorm .or. fnorm == zero) info = 1
|
||
|
|
if (info /= 0) go to 300
|
||
|
|
!
|
||
|
|
! tests for termination and stringent tolerances.
|
||
|
|
!
|
||
|
|
if (nfev >= maxfev) info = 2
|
||
|
|
if (p1*dmax1(p1*delta,pnorm) <= epsmch*xnorm) info = 3
|
||
|
|
if (nslow2 == 5) info = 4
|
||
|
|
if (nslow1 == 10) info = 5
|
||
|
|
if (info /= 0) go to 300
|
||
|
|
!
|
||
|
|
! criterion for recalculating jacobian.
|
||
|
|
!
|
||
|
|
if (ncfail == 2) exit
|
||
|
|
!
|
||
|
|
! calculate the rank one modification to the jacobian
|
||
|
|
! and update qtf if necessary.
|
||
|
|
!
|
||
|
|
do j = 1, n
|
||
|
|
summ = zero
|
||
|
|
do i = 1, n
|
||
|
|
summ = summ + fjac(i,j)*wa4(i)
|
||
|
|
end do
|
||
|
|
wa2(j) = (summ - wa3(j))/pnorm
|
||
|
|
wa1(j) = diag(j)*((diag(j)*wa1(j))/pnorm)
|
||
|
|
if (ratio >= p0001) qtf(j) = summ
|
||
|
|
end do
|
||
|
|
!
|
||
|
|
! compute the qr factorization of the updated jacobian.
|
||
|
|
!
|
||
|
|
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)
|
||
|
|
!
|
||
|
|
! end of the inner loop.
|
||
|
|
!
|
||
|
|
jeval = .false.
|
||
|
|
end do
|
||
|
|
!
|
||
|
|
! end of the outer loop.
|
||
|
|
!
|
||
|
|
end do
|
||
|
|
300 continue
|
||
|
|
!
|
||
|
|
! termination, either normal or user imposed.
|
||
|
|
!
|
||
|
|
if (iflag < 0) info = iflag
|
||
|
|
iflag = 0
|
||
|
|
if (nprint > 0) call fcn(n,x,f0,fvec,fjac,ldfjac,iflag)
|
||
|
|
end subroutine hybrjmv
|
||
|
|
|
||
|
|
subroutine dogleg(n,r,lr,diag,qtb,delta,x,wa1,wa2)
|
||
|
|
use const_and_precisions, only : zero, one, epsmch=>comp_eps
|
||
|
|
implicit none
|
||
|
|
! arguments
|
||
|
|
integer, intent(in) :: n, lr
|
||
|
|
real(wp_), intent(in) :: delta, r(lr), diag(n), qtb(n)
|
||
|
|
real(wp_), intent(out) :: x(n), wa1(n), wa2(n)
|
||
|
|
! **********
|
||
|
|
!
|
||
|
|
! subroutine dogleg
|
||
|
|
!
|
||
|
|
! given an m by n matrix a, an n by n nonsingular diagonal
|
||
|
|
! matrix d, an m-vector b, and a positive number delta, the
|
||
|
|
! problem is to determine the convex combination x of the
|
||
|
|
! gauss-newton and scaled gradient directions that minimizes
|
||
|
|
! (a*x - b) in the least squares sense, subject to the
|
||
|
|
! restriction that the euclidean norm of d*x be at most delta.
|
||
|
|
!
|
||
|
|
! this subroutine completes the solution of the problem
|
||
|
|
! if it is provided with the necessary information from the
|
||
|
|
! qr factorization of a. that is, if a = q*r, where q has
|
||
|
|
! orthogonal columns and r is an upper triangular matrix,
|
||
|
|
! then dogleg expects the full upper triangle of r and
|
||
|
|
! the first n components of (q transpose)*b.
|
||
|
|
!
|
||
|
|
! the subroutine statement is
|
||
|
|
!
|
||
|
|
! subroutine dogleg(n,r,lr,diag,qtb,delta,x,wa1,wa2)
|
||
|
|
!
|
||
|
|
! where
|
||
|
|
!
|
||
|
|
! n is a positive integer input variable set to the order of r.
|
||
|
|
!
|
||
|
|
! r is an input array of length lr which must contain the upper
|
||
|
|
! triangular matrix r stored by rows.
|
||
|
|
!
|
||
|
|
! lr is a positive integer input variable not less than
|
||
|
|
! (n*(n+1))/2.
|
||
|
|
!
|
||
|
|
! diag is an input array of length n which must contain the
|
||
|
|
! diagonal elements of the matrix d.
|
||
|
|
!
|
||
|
|
! qtb is an input array of length n which must contain the first
|
||
|
|
! n elements of the vector (q transpose)*b.
|
||
|
|
!
|
||
|
|
! delta is a positive input variable which specifies an upper
|
||
|
|
! bound on the euclidean norm of d*x.
|
||
|
|
!
|
||
|
|
! x is an output array of length n which contains the desired
|
||
|
|
! convex combination of the gauss-newton direction and the
|
||
|
|
! scaled gradient direction.
|
||
|
|
!
|
||
|
|
! wa1 and wa2 are work arrays of length n.
|
||
|
|
!
|
||
|
|
! subprograms called
|
||
|
|
!
|
||
|
|
! minpack-supplied ... enorm
|
||
|
|
!
|
||
|
|
! fortran-supplied ... abs,dmax1,dmin1,sqrt
|
||
|
|
!
|
||
|
|
! argonne national laboratory. minpack project. march 1980.
|
||
|
|
! burton s. garbow, kenneth e. hillstrom, jorge j. more
|
||
|
|
!
|
||
|
|
! **********
|
||
|
|
! local variables
|
||
|
|
integer :: i, j, jj, jp1, k, l
|
||
|
|
real(wp_) :: alpha, bnorm, gnorm, qnorm, sgnorm, summ, temp
|
||
|
|
!
|
||
|
|
! first, calculate the gauss-newton direction.
|
||
|
|
!
|
||
|
|
jj = (n*(n + 1))/2 + 1
|
||
|
|
do k = 1, n
|
||
|
|
j = n - k + 1
|
||
|
|
jp1 = j + 1
|
||
|
|
jj = jj - k
|
||
|
|
l = jj + 1
|
||
|
|
summ = zero
|
||
|
|
do i = jp1, n
|
||
|
|
summ = summ + r(l)*x(i)
|
||
|
|
l = l + 1
|
||
|
|
end do
|
||
|
|
temp = r(jj)
|
||
|
|
if (temp == zero) then
|
||
|
|
l = j
|
||
|
|
do i = 1, j
|
||
|
|
temp = dmax1(temp,abs(r(l)))
|
||
|
|
l = l + n - i
|
||
|
|
end do
|
||
|
|
temp = epsmch*temp
|
||
|
|
if (temp == zero) temp = epsmch
|
||
|
|
end if
|
||
|
|
x(j) = (qtb(j) - summ)/temp
|
||
|
|
end do
|
||
|
|
!
|
||
|
|
! test whether the gauss-newton direction is acceptable.
|
||
|
|
!
|
||
|
|
do j = 1, n
|
||
|
|
wa1(j) = zero
|
||
|
|
wa2(j) = diag(j)*x(j)
|
||
|
|
end do
|
||
|
|
qnorm = enorm(n,wa2)
|
||
|
|
if (qnorm <= delta) return
|
||
|
|
!
|
||
|
|
! the gauss-newton direction is not acceptable.
|
||
|
|
! next, calculate the scaled gradient direction.
|
||
|
|
!
|
||
|
|
l = 1
|
||
|
|
do j = 1, n
|
||
|
|
temp = qtb(j)
|
||
|
|
do i = j, n
|
||
|
|
wa1(i) = wa1(i) + r(l)*temp
|
||
|
|
l = l + 1
|
||
|
|
end do
|
||
|
|
wa1(j) = wa1(j)/diag(j)
|
||
|
|
end do
|
||
|
|
!
|
||
|
|
! calculate the norm of the scaled gradient and test for
|
||
|
|
! the special case in which the scaled gradient is zero.
|
||
|
|
!
|
||
|
|
gnorm = enorm(n,wa1)
|
||
|
|
sgnorm = zero
|
||
|
|
alpha = delta/qnorm
|
||
|
|
if (gnorm /= zero) then
|
||
|
|
!
|
||
|
|
! calculate the point along the scaled gradient
|
||
|
|
! at which the quadratic is minimized.
|
||
|
|
!
|
||
|
|
do j = 1, n
|
||
|
|
wa1(j) = (wa1(j)/gnorm)/diag(j)
|
||
|
|
end do
|
||
|
|
l = 1
|
||
|
|
do j = 1, n
|
||
|
|
summ = zero
|
||
|
|
do i = j, n
|
||
|
|
summ = summ + r(l)*wa1(i)
|
||
|
|
l = l + 1
|
||
|
|
end do
|
||
|
|
wa2(j) = summ
|
||
|
|
end do
|
||
|
|
temp = enorm(n,wa2)
|
||
|
|
sgnorm = (gnorm/temp)/temp
|
||
|
|
!
|
||
|
|
! test whether the scaled gradient direction is acceptable.
|
||
|
|
!
|
||
|
|
alpha = zero
|
||
|
|
if (sgnorm < delta) then
|
||
|
|
!
|
||
|
|
! the scaled gradient direction is not acceptable.
|
||
|
|
! finally, calculate the point along the dogleg
|
||
|
|
! at which the quadratic is minimized.
|
||
|
|
!
|
||
|
|
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
|
||
|
|
end if
|
||
|
|
end if
|
||
|
|
!
|
||
|
|
! form appropriate convex combination of the gauss-newton
|
||
|
|
! direction and the scaled gradient direction.
|
||
|
|
!
|
||
|
|
temp = (one - alpha)*dmin1(sgnorm,delta)
|
||
|
|
do j = 1, n
|
||
|
|
x(j) = temp*wa1(j) + alpha*x(j)
|
||
|
|
end do
|
||
|
|
end subroutine dogleg
|
||
|
|
|
||
|
|
function enorm(n,x)
|
||
|
|
use const_and_precisions, only : zero, one
|
||
|
|
implicit none
|
||
|
|
real(wp_) :: enorm
|
||
|
|
integer, intent(in) :: n
|
||
|
|
real(wp_), dimension(n), intent(in) :: x
|
||
|
|
! **********
|
||
|
|
!
|
||
|
|
! function enorm
|
||
|
|
!
|
||
|
|
! given an n-vector x, this function calculates the
|
||
|
|
! euclidean norm of x.
|
||
|
|
!
|
||
|
|
! the euclidean norm is computed by accumulating the sum of
|
||
|
|
! squares in three different sums. the sums of squares for the
|
||
|
|
! small and large components are scaled so that no overflows
|
||
|
|
! occur. non-destructive underflows are permitted. underflows
|
||
|
|
! and overflows do not occur in the computation of the unscaled
|
||
|
|
! sum of squares for the intermediate components.
|
||
|
|
! the definitions of small, intermediate and large components
|
||
|
|
! depend on two constants, rdwarf and rgiant. the main
|
||
|
|
! restrictions on these constants are that rdwarf**2 not
|
||
|
|
! underflow and rgiant**2 not overflow. the constants
|
||
|
|
! given here are suitable for every known computer.
|
||
|
|
!
|
||
|
|
! the function statement is
|
||
|
|
!
|
||
|
|
! real(8) function enorm(n,x)
|
||
|
|
!
|
||
|
|
! where
|
||
|
|
!
|
||
|
|
! n is a positive integer input variable.
|
||
|
|
!
|
||
|
|
! x is an input array of length n.
|
||
|
|
!
|
||
|
|
! subprograms called
|
||
|
|
!
|
||
|
|
! fortran-supplied ... abs,sqrt
|
||
|
|
!
|
||
|
|
! argonne national laboratory. minpack project. march 1980.
|
||
|
|
! burton s. garbow, kenneth e. hillstrom, jorge j. more
|
||
|
|
!
|
||
|
|
! **********
|
||
|
|
integer :: i
|
||
|
|
real(wp_) :: agiant,floatn,s1,s2,s3,xabs,x1max,x3max
|
||
|
|
real(wp_), parameter :: rdwarf=3.834e-20_wp_,rgiant=1.304e19_wp_
|
||
|
|
s1 = zero
|
||
|
|
s2 = zero
|
||
|
|
s3 = zero
|
||
|
|
x1max = zero
|
||
|
|
x3max = zero
|
||
|
|
floatn = n
|
||
|
|
agiant = rgiant/floatn
|
||
|
|
do i = 1, n
|
||
|
|
xabs = abs(x(i))
|
||
|
|
if (xabs <= rdwarf .or. xabs >= agiant) then
|
||
|
|
if (xabs > rdwarf) then
|
||
|
|
!
|
||
|
|
! sum for large components.
|
||
|
|
!
|
||
|
|
if (xabs > x1max) then
|
||
|
|
s1 = one + s1*(x1max/xabs)**2
|
||
|
|
x1max = xabs
|
||
|
|
else
|
||
|
|
s1 = s1 + (xabs/x1max)**2
|
||
|
|
end if
|
||
|
|
else
|
||
|
|
!
|
||
|
|
! sum for small components.
|
||
|
|
!
|
||
|
|
if (xabs > x3max) then
|
||
|
|
s3 = one + s3*(x3max/xabs)**2
|
||
|
|
x3max = xabs
|
||
|
|
else
|
||
|
|
if (xabs /= zero) s3 = s3 + (xabs/x3max)**2
|
||
|
|
end if
|
||
|
|
end if
|
||
|
|
else
|
||
|
|
!
|
||
|
|
! sum for intermediate components.
|
||
|
|
!
|
||
|
|
s2 = s2 + xabs**2
|
||
|
|
end if
|
||
|
|
end do
|
||
|
|
!
|
||
|
|
! calculation of norm.
|
||
|
|
!
|
||
|
|
if (s1 /= zero) then
|
||
|
|
enorm = x1max*sqrt(s1+(s2/x1max)/x1max)
|
||
|
|
else
|
||
|
|
if (s2 /= zero) then
|
||
|
|
if (s2 >= x3max) enorm = sqrt(s2*(one+(x3max/s2)*(x3max*s3)))
|
||
|
|
if (s2 < x3max) enorm = sqrt(x3max*((s2/x3max)+(x3max*s3)))
|
||
|
|
else
|
||
|
|
enorm = x3max*sqrt(s3)
|
||
|
|
end if
|
||
|
|
end if
|
||
|
|
end function enorm
|
||
|
|
|
||
|
|
subroutine qform(m,n,q,ldq,wa)
|
||
|
|
use const_and_precisions, only : zero, one
|
||
|
|
implicit none
|
||
|
|
! arguments
|
||
|
|
integer, intent(in) :: m,n,ldq
|
||
|
|
real(wp_), intent(out) :: wa(m)
|
||
|
|
real(wp_), intent(inout) :: q(ldq,m)
|
||
|
|
! **********
|
||
|
|
!
|
||
|
|
! subroutine qform
|
||
|
|
!
|
||
|
|
! this subroutine proceeds from the computed qr factorization of
|
||
|
|
! an m by n matrix a to accumulate the m by m orthogonal matrix
|
||
|
|
! q from its factored form.
|
||
|
|
!
|
||
|
|
! the subroutine statement is
|
||
|
|
!
|
||
|
|
! subroutine qform(m,n,q,ldq,wa)
|
||
|
|
!
|
||
|
|
! where
|
||
|
|
!
|
||
|
|
! m is a positive integer input variable set to the number
|
||
|
|
! of rows of a and the order of q.
|
||
|
|
!
|
||
|
|
! n is a positive integer input variable set to the number
|
||
|
|
! of columns of a.
|
||
|
|
!
|
||
|
|
! q is an m by m array. on input the full lower trapezoid in
|
||
|
|
! the first min(m,n) columns of q contains the factored form.
|
||
|
|
! on output q has been accumulated into a square matrix.
|
||
|
|
!
|
||
|
|
! ldq is a positive integer input variable not less than m
|
||
|
|
! which specifies the leading dimension of the array q.
|
||
|
|
!
|
||
|
|
! wa is a work array of length m.
|
||
|
|
!
|
||
|
|
! subprograms called
|
||
|
|
!
|
||
|
|
! fortran-supplied ... min0
|
||
|
|
!
|
||
|
|
! argonne national laboratory. minpack project. march 1980.
|
||
|
|
! burton s. garbow, kenneth e. hillstrom, jorge j. more
|
||
|
|
!
|
||
|
|
! **********
|
||
|
|
! local variables
|
||
|
|
integer :: i, j, jm1, k, l, minmn, np1
|
||
|
|
real(wp_) :: summ, temp
|
||
|
|
!
|
||
|
|
! zero out upper triangle of q in the first min(m,n) columns.
|
||
|
|
!
|
||
|
|
minmn = min0(m,n)
|
||
|
|
do j = 2, minmn
|
||
|
|
jm1 = j - 1
|
||
|
|
do i = 1, jm1
|
||
|
|
q(i,j) = zero
|
||
|
|
end do
|
||
|
|
end do
|
||
|
|
!
|
||
|
|
! initialize remaining columns to those of the identity matrix.
|
||
|
|
!
|
||
|
|
np1 = n + 1
|
||
|
|
do j = np1, m
|
||
|
|
do i = 1, m
|
||
|
|
q(i,j) = zero
|
||
|
|
end do
|
||
|
|
q(j,j) = one
|
||
|
|
end do
|
||
|
|
!
|
||
|
|
! accumulate q from its factored form.
|
||
|
|
!
|
||
|
|
do l = 1, minmn
|
||
|
|
k = minmn - l + 1
|
||
|
|
do i = k, m
|
||
|
|
wa(i) = q(i,k)
|
||
|
|
q(i,k) = zero
|
||
|
|
end do
|
||
|
|
q(k,k) = one
|
||
|
|
if (wa(k) /= zero) then
|
||
|
|
do j = k, m
|
||
|
|
summ = zero
|
||
|
|
do i = k, m
|
||
|
|
summ = summ + q(i,j)*wa(i)
|
||
|
|
end do
|
||
|
|
temp = summ/wa(k)
|
||
|
|
do i = k, m
|
||
|
|
q(i,j) = q(i,j) - temp*wa(i)
|
||
|
|
end do
|
||
|
|
end do
|
||
|
|
end if
|
||
|
|
end do
|
||
|
|
end subroutine qform
|
||
|
|
|
||
|
|
subroutine qrfac(m,n,a,lda,pivot,ipvt,lipvt,rdiag,acnorm,wa)
|
||
|
|
use const_and_precisions, only : zero, one, epsmch=>comp_eps
|
||
|
|
implicit none
|
||
|
|
! arguments
|
||
|
|
integer, intent(in) :: m, n, lda, lipvt
|
||
|
|
integer, intent(out) :: ipvt(lipvt)
|
||
|
|
logical, intent(in) :: pivot
|
||
|
|
real(wp_), intent(out) :: rdiag(n), acnorm(n), wa(n)
|
||
|
|
real(wp_), intent(inout) :: a(lda,n)
|
||
|
|
! **********
|
||
|
|
!
|
||
|
|
! subroutine qrfac
|
||
|
|
!
|
||
|
|
! this subroutine uses householder transformations with column
|
||
|
|
! pivoting (optional) to compute a qr factorization of the
|
||
|
|
! m by n matrix a. that is, qrfac determines an orthogonal
|
||
|
|
! matrix q, a permutation matrix p, and an upper trapezoidal
|
||
|
|
! matrix r with diagonal elements of nonincreasing magnitude,
|
||
|
|
! such that a*p = q*r. the householder transformation for
|
||
|
|
! column k, k = 1,2,...,min(m,n), is of the form
|
||
|
|
!
|
||
|
|
! t
|
||
|
|
! i - (1/u(k))*u*u
|
||
|
|
!
|
||
|
|
! where u has zeros in the first k-1 positions. the form of
|
||
|
|
! this transformation and the method of pivoting first
|
||
|
|
! appeared in the corresponding linpack subroutine.
|
||
|
|
!
|
||
|
|
! the subroutine statement is
|
||
|
|
!
|
||
|
|
! subroutine qrfac(m,n,a,lda,pivot,ipvt,lipvt,rdiag,acnorm,wa)
|
||
|
|
!
|
||
|
|
! where
|
||
|
|
!
|
||
|
|
! m is a positive integer input variable set to the number
|
||
|
|
! of rows of a.
|
||
|
|
!
|
||
|
|
! n is a positive integer input variable set to the number
|
||
|
|
! of columns of a.
|
||
|
|
!
|
||
|
|
! a is an m by n array. on input a contains the matrix for
|
||
|
|
! which the qr factorization is to be computed. on output
|
||
|
|
! the strict upper trapezoidal part of a contains the strict
|
||
|
|
! upper trapezoidal part of r, and the lower trapezoidal
|
||
|
|
! part of a contains a factored form of q (the non-trivial
|
||
|
|
! elements of the u vectors described above).
|
||
|
|
!
|
||
|
|
! lda is a positive integer input variable not less than m
|
||
|
|
! which specifies the leading dimension of the array a.
|
||
|
|
!
|
||
|
|
! pivot is a logical input variable. if pivot is set true,
|
||
|
|
! then column pivoting is enforced. if pivot is set false,
|
||
|
|
! then no column pivoting is done.
|
||
|
|
!
|
||
|
|
! ipvt is an integer output array of length lipvt. ipvt
|
||
|
|
! defines the permutation matrix p such that a*p = q*r.
|
||
|
|
! column j of p is column ipvt(j) of the identity matrix.
|
||
|
|
! if pivot is false, ipvt is not referenced.
|
||
|
|
!
|
||
|
|
! lipvt is a positive integer input variable. if pivot is false,
|
||
|
|
! then lipvt may be as small as 1. if pivot is true, then
|
||
|
|
! lipvt must be at least n.
|
||
|
|
!
|
||
|
|
! rdiag is an output array of length n which contains the
|
||
|
|
! diagonal elements of r.
|
||
|
|
!
|
||
|
|
! acnorm is an output array of length n which contains the
|
||
|
|
! norms of the corresponding columns of the input matrix a.
|
||
|
|
! if this information is not needed, then acnorm can coincide
|
||
|
|
! with rdiag.
|
||
|
|
!
|
||
|
|
! wa is a work array of length n. if pivot is false, then wa
|
||
|
|
! can coincide with rdiag.
|
||
|
|
!
|
||
|
|
! subprograms called
|
||
|
|
!
|
||
|
|
! minpack-supplied ... enorm
|
||
|
|
!
|
||
|
|
! fortran-supplied ... dmax1,sqrt,min0
|
||
|
|
!
|
||
|
|
! argonne national laboratory. minpack project. march 1980.
|
||
|
|
! burton s. garbow, kenneth e. hillstrom, jorge j. more
|
||
|
|
!
|
||
|
|
! **********
|
||
|
|
! local variables
|
||
|
|
integer :: i, j, jp1, k, kmax, minmn
|
||
|
|
real(wp_) :: ajnorm, summ, temp
|
||
|
|
! parameters
|
||
|
|
real(wp_), parameter :: p05=5.0e-2_wp_
|
||
|
|
!
|
||
|
|
! compute the initial column norms and initialize several arrays.
|
||
|
|
!
|
||
|
|
do j = 1, n
|
||
|
|
acnorm(j) = enorm(m,a(1,j))
|
||
|
|
rdiag(j) = acnorm(j)
|
||
|
|
wa(j) = rdiag(j)
|
||
|
|
if (pivot) ipvt(j) = j
|
||
|
|
end do
|
||
|
|
!
|
||
|
|
! reduce a to r with householder transformations.
|
||
|
|
!
|
||
|
|
minmn = min0(m,n)
|
||
|
|
do j = 1, minmn
|
||
|
|
if (pivot) then
|
||
|
|
!
|
||
|
|
! bring the column of largest norm into the pivot position.
|
||
|
|
!
|
||
|
|
kmax = j
|
||
|
|
do k = j, n
|
||
|
|
if (rdiag(k) > rdiag(kmax)) kmax = k
|
||
|
|
end do
|
||
|
|
if (kmax /= j) then
|
||
|
|
do i = 1, m
|
||
|
|
temp = a(i,j)
|
||
|
|
a(i,j) = a(i,kmax)
|
||
|
|
a(i,kmax) = temp
|
||
|
|
end do
|
||
|
|
rdiag(kmax) = rdiag(j)
|
||
|
|
wa(kmax) = wa(j)
|
||
|
|
k = ipvt(j)
|
||
|
|
ipvt(j) = ipvt(kmax)
|
||
|
|
ipvt(kmax) = k
|
||
|
|
end if
|
||
|
|
end if
|
||
|
|
!
|
||
|
|
! compute the householder transformation to reduce the
|
||
|
|
! j-th column of a to a multiple of the j-th unit vector.
|
||
|
|
!
|
||
|
|
ajnorm = enorm(m-j+1,a(j,j))
|
||
|
|
if (ajnorm /= zero) then
|
||
|
|
if (a(j,j) < zero) ajnorm = -ajnorm
|
||
|
|
do i = j, m
|
||
|
|
a(i,j) = a(i,j)/ajnorm
|
||
|
|
end do
|
||
|
|
a(j,j) = a(j,j) + one
|
||
|
|
!
|
||
|
|
! apply the transformation to the remaining columns
|
||
|
|
! and update the norms.
|
||
|
|
!
|
||
|
|
jp1 = j + 1
|
||
|
|
do k = jp1, n
|
||
|
|
summ = zero
|
||
|
|
do i = j, m
|
||
|
|
summ = summ + a(i,j)*a(i,k)
|
||
|
|
end do
|
||
|
|
temp = summ/a(j,j)
|
||
|
|
do i = j, m
|
||
|
|
a(i,k) = a(i,k) - temp*a(i,j)
|
||
|
|
end do
|
||
|
|
if (pivot .and. rdiag(k) /= zero) then
|
||
|
|
temp = a(j,k)/rdiag(k)
|
||
|
|
rdiag(k) = rdiag(k)*sqrt(dmax1(zero,one-temp**2))
|
||
|
|
if (p05*(rdiag(k)/wa(k))**2 <= epsmch) then
|
||
|
|
rdiag(k) = enorm(m-j,a(jp1,k))
|
||
|
|
wa(k) = rdiag(k)
|
||
|
|
end if
|
||
|
|
end if
|
||
|
|
end do
|
||
|
|
end if
|
||
|
|
rdiag(j) = -ajnorm
|
||
|
|
end do
|
||
|
|
end subroutine qrfac
|
||
|
|
|
||
|
|
subroutine r1mpyq(m,n,a,lda,v,w)
|
||
|
|
use const_and_precisions, only : one
|
||
|
|
implicit none
|
||
|
|
! arguments
|
||
|
|
integer, intent(in) :: m, n, lda
|
||
|
|
real(wp_), intent(in) :: v(n),w(n)
|
||
|
|
real(wp_), intent(inout) :: a(lda,n)
|
||
|
|
! **********
|
||
|
|
!
|
||
|
|
! subroutine r1mpyq
|
||
|
|
!
|
||
|
|
! given an m by n matrix a, this subroutine computes a*q where
|
||
|
|
! q is the product of 2*(n - 1) transformations
|
||
|
|
!
|
||
|
|
! gv(n-1)*...*gv(1)*gw(1)*...*gw(n-1)
|
||
|
|
!
|
||
|
|
! and gv(i), gw(i) are givens rotations in the (i,n) plane which
|
||
|
|
! eliminate elements in the i-th and n-th planes, respectively.
|
||
|
|
! q itself is not given, rather the information to recover the
|
||
|
|
! gv, gw rotations is supplied.
|
||
|
|
!
|
||
|
|
! the subroutine statement is
|
||
|
|
!
|
||
|
|
! subroutine r1mpyq(m,n,a,lda,v,w)
|
||
|
|
!
|
||
|
|
! where
|
||
|
|
!
|
||
|
|
! m is a positive integer input variable set to the number
|
||
|
|
! of rows of a.
|
||
|
|
!
|
||
|
|
! n is a positive integer input variable set to the number
|
||
|
|
! of columns of a.
|
||
|
|
!
|
||
|
|
! a is an m by n array. on input a must contain the matrix
|
||
|
|
! to be postmultiplied by the orthogonal matrix q
|
||
|
|
! described above. on output a*q has replaced a.
|
||
|
|
!
|
||
|
|
! lda is a positive integer input variable not less than m
|
||
|
|
! which specifies the leading dimension of the array a.
|
||
|
|
!
|
||
|
|
! v is an input array of length n. v(i) must contain the
|
||
|
|
! information necessary to recover the givens rotation gv(i)
|
||
|
|
! described above.
|
||
|
|
!
|
||
|
|
! w is an input array of length n. w(i) must contain the
|
||
|
|
! information necessary to recover the givens rotation gw(i)
|
||
|
|
! described above.
|
||
|
|
!
|
||
|
|
! subroutines called
|
||
|
|
!
|
||
|
|
! fortran-supplied ... abs,sqrt
|
||
|
|
!
|
||
|
|
! argonne national laboratory. minpack project. march 1980.
|
||
|
|
! burton s. garbow, kenneth e. hillstrom, jorge j. more
|
||
|
|
!
|
||
|
|
! **********
|
||
|
|
! local variables
|
||
|
|
integer :: i, j, nmj, nm1
|
||
|
|
real(wp_) :: cs, sn, temp
|
||
|
|
!
|
||
|
|
! apply the first set of givens rotations to a.
|
||
|
|
!
|
||
|
|
nm1 = n - 1
|
||
|
|
if (nm1 < 1) return
|
||
|
|
do nmj = 1, nm1
|
||
|
|
j = n - nmj
|
||
|
|
if (abs(v(j)) > one) cs = one/v(j)
|
||
|
|
if (abs(v(j)) > one) sn = sqrt(one-cs**2)
|
||
|
|
if (abs(v(j)) <= one) sn = v(j)
|
||
|
|
if (abs(v(j)) <= one) cs = sqrt(one-sn**2)
|
||
|
|
do i = 1, m
|
||
|
|
temp = cs*a(i,j) - sn*a(i,n)
|
||
|
|
a(i,n) = sn*a(i,j) + cs*a(i,n)
|
||
|
|
a(i,j) = temp
|
||
|
|
end do
|
||
|
|
end do
|
||
|
|
!
|
||
|
|
! apply the second set of givens rotations to a.
|
||
|
|
!
|
||
|
|
do j = 1, nm1
|
||
|
|
if (abs(w(j)) > one) cs = one/w(j)
|
||
|
|
if (abs(w(j)) > one) sn = sqrt(one-cs**2)
|
||
|
|
if (abs(w(j)) <= one) sn = w(j)
|
||
|
|
if (abs(w(j)) <= one) cs = sqrt(one-sn**2)
|
||
|
|
do i = 1, m
|
||
|
|
temp = cs*a(i,j) + sn*a(i,n)
|
||
|
|
a(i,n) = -sn*a(i,j) + cs*a(i,n)
|
||
|
|
a(i,j) = temp
|
||
|
|
end do
|
||
|
|
end do
|
||
|
|
end subroutine r1mpyq
|
||
|
|
|
||
|
|
subroutine r1updt(m,n,s,ls,u,v,w,sing)
|
||
|
|
use const_and_precisions, only : zero, one, giant=>comp_huge
|
||
|
|
implicit none
|
||
|
|
! arguments
|
||
|
|
integer, intent(in) :: m, n, ls
|
||
|
|
logical, intent(out) :: sing
|
||
|
|
real(wp_), intent(in) :: u(m)
|
||
|
|
real(wp_), intent(out) :: w(m)
|
||
|
|
real(wp_), intent(inout) :: s(ls), v(n)
|
||
|
|
! **********
|
||
|
|
!
|
||
|
|
! subroutine r1updt
|
||
|
|
!
|
||
|
|
! given an m by n lower trapezoidal matrix s, an m-vector u,
|
||
|
|
! and an n-vector v, the problem is to determine an
|
||
|
|
! orthogonal matrix q such that
|
||
|
|
!
|
||
|
|
! t
|
||
|
|
! (s + u*v )*q
|
||
|
|
!
|
||
|
|
! is again lower trapezoidal.
|
||
|
|
!
|
||
|
|
! this subroutine determines q as the product of 2*(n - 1)
|
||
|
|
! transformations
|
||
|
|
!
|
||
|
|
! gv(n-1)*...*gv(1)*gw(1)*...*gw(n-1)
|
||
|
|
!
|
||
|
|
! where gv(i), gw(i) are givens rotations in the (i,n) plane
|
||
|
|
! which eliminate elements in the i-th and n-th planes,
|
||
|
|
! respectively. q itself is not accumulated, rather the
|
||
|
|
! information to recover the gv, gw rotations is returned.
|
||
|
|
!
|
||
|
|
! the subroutine statement is
|
||
|
|
!
|
||
|
|
! subroutine r1updt(m,n,s,ls,u,v,w,sing)
|
||
|
|
!
|
||
|
|
! where
|
||
|
|
!
|
||
|
|
! m is a positive integer input variable set to the number
|
||
|
|
! of rows of s.
|
||
|
|
!
|
||
|
|
! n is a positive integer input variable set to the number
|
||
|
|
! of columns of s. n must not exceed m.
|
||
|
|
!
|
||
|
|
! s is an array of length ls. on input s must contain the lower
|
||
|
|
! trapezoidal matrix s stored by columns. on output s contains
|
||
|
|
! the lower trapezoidal matrix produced as described above.
|
||
|
|
!
|
||
|
|
! ls is a positive integer input variable not less than
|
||
|
|
! (n*(2*m-n+1))/2.
|
||
|
|
!
|
||
|
|
! u is an input array of length m which must contain the
|
||
|
|
! vector u.
|
||
|
|
!
|
||
|
|
! v is an array of length n. on input v must contain the vector
|
||
|
|
! v. on output v(i) contains the information necessary to
|
||
|
|
! recover the givens rotation gv(i) described above.
|
||
|
|
!
|
||
|
|
! w is an output array of length m. w(i) contains information
|
||
|
|
! necessary to recover the givens rotation gw(i) described
|
||
|
|
! above.
|
||
|
|
!
|
||
|
|
! sing is a logical output variable. sing is set true if any
|
||
|
|
! of the diagonal elements of the output s are zero. otherwise
|
||
|
|
! sing is set false.
|
||
|
|
!
|
||
|
|
! subprograms called
|
||
|
|
!
|
||
|
|
! fortran-supplied ... abs,sqrt
|
||
|
|
!
|
||
|
|
! argonne national laboratory. minpack project. march 1980.
|
||
|
|
! burton s. garbow, kenneth e. hillstrom, jorge j. more,
|
||
|
|
! john l. nazareth
|
||
|
|
!
|
||
|
|
! **********
|
||
|
|
! local variables
|
||
|
|
integer :: i, j, jj, l, nmj, nm1
|
||
|
|
real(wp_) :: cs, cotan, sn, tn, tau, temp
|
||
|
|
! parameters
|
||
|
|
real(wp_), parameter :: p5=5.0e-1_wp_, p25=2.5e-1_wp_
|
||
|
|
!
|
||
|
|
! initialize the diagonal element pointer.
|
||
|
|
!
|
||
|
|
jj = (n*(2*m - n + 1))/2 - (m - n)
|
||
|
|
!
|
||
|
|
! move the nontrivial part of the last column of s into w.
|
||
|
|
!
|
||
|
|
l = jj
|
||
|
|
do i = n, m
|
||
|
|
w(i) = s(l)
|
||
|
|
l = l + 1
|
||
|
|
end do
|
||
|
|
!
|
||
|
|
! rotate the vector v into a multiple of the n-th unit vector
|
||
|
|
! in such a way that a spike is introduced into w.
|
||
|
|
!
|
||
|
|
nm1 = n - 1
|
||
|
|
do nmj = 1, nm1
|
||
|
|
j = n - nmj
|
||
|
|
jj = jj - (m - j + 1)
|
||
|
|
w(j) = zero
|
||
|
|
if (v(j) /= zero) then
|
||
|
|
!
|
||
|
|
! determine a givens rotation which eliminates the
|
||
|
|
! j-th element of v.
|
||
|
|
!
|
||
|
|
if (abs(v(n)) < abs(v(j))) then
|
||
|
|
cotan = v(n)/v(j)
|
||
|
|
sn = p5/sqrt(p25+p25*cotan**2)
|
||
|
|
cs = sn*cotan
|
||
|
|
tau = one
|
||
|
|
if (abs(cs)*giant > one) tau = one/cs
|
||
|
|
else
|
||
|
|
tn = v(j)/v(n)
|
||
|
|
cs = p5/sqrt(p25+p25*tn**2)
|
||
|
|
sn = cs*tn
|
||
|
|
tau = sn
|
||
|
|
end if
|
||
|
|
!
|
||
|
|
! apply the transformation to v and store the information
|
||
|
|
! necessary to recover the givens rotation.
|
||
|
|
!
|
||
|
|
v(n) = sn*v(j) + cs*v(n)
|
||
|
|
v(j) = tau
|
||
|
|
!
|
||
|
|
! apply the transformation to s and extend the spike in w.
|
||
|
|
!
|
||
|
|
l = jj
|
||
|
|
do i = j, m
|
||
|
|
temp = cs*s(l) - sn*w(i)
|
||
|
|
w(i) = sn*s(l) + cs*w(i)
|
||
|
|
s(l) = temp
|
||
|
|
l = l + 1
|
||
|
|
end do
|
||
|
|
end if
|
||
|
|
end do
|
||
|
|
!
|
||
|
|
! add the spike from the rank 1 update to w.
|
||
|
|
!
|
||
|
|
do i = 1, m
|
||
|
|
w(i) = w(i) + v(n)*u(i)
|
||
|
|
end do
|
||
|
|
!
|
||
|
|
! eliminate the spike.
|
||
|
|
!
|
||
|
|
sing = .false.
|
||
|
|
do j = 1, nm1
|
||
|
|
if (w(j) /= zero) then
|
||
|
|
!
|
||
|
|
! determine a givens rotation which eliminates the
|
||
|
|
! j-th element of the spike.
|
||
|
|
!
|
||
|
|
if (abs(s(jj)) < abs(w(j))) then
|
||
|
|
cotan = s(jj)/w(j)
|
||
|
|
sn = p5/sqrt(p25+p25*cotan**2)
|
||
|
|
cs = sn*cotan
|
||
|
|
tau = one
|
||
|
|
if (abs(cs)*giant > one) tau = one/cs
|
||
|
|
else
|
||
|
|
tn = w(j)/s(jj)
|
||
|
|
cs = p5/sqrt(p25+p25*tn**2)
|
||
|
|
sn = cs*tn
|
||
|
|
tau = sn
|
||
|
|
end if
|
||
|
|
!
|
||
|
|
! apply the transformation to s and reduce the spike in w.
|
||
|
|
!
|
||
|
|
l = jj
|
||
|
|
do i = j, m
|
||
|
|
temp = cs*s(l) + sn*w(i)
|
||
|
|
w(i) = -sn*s(l) + cs*w(i)
|
||
|
|
s(l) = temp
|
||
|
|
l = l + 1
|
||
|
|
end do
|
||
|
|
!
|
||
|
|
! store the information necessary to recover the
|
||
|
|
! givens rotation.
|
||
|
|
!
|
||
|
|
w(j) = tau
|
||
|
|
end if
|
||
|
|
!
|
||
|
|
! test for zero diagonal elements in the output s.
|
||
|
|
!
|
||
|
|
if (s(jj) == zero) sing = .true.
|
||
|
|
jj = jj + (m - j + 1)
|
||
|
|
end do
|
||
|
|
!
|
||
|
|
! move w back into the last column of the output s.
|
||
|
|
!
|
||
|
|
l = jj
|
||
|
|
do i = n, m
|
||
|
|
s(l) = w(i)
|
||
|
|
l = l + 1
|
||
|
|
end do
|
||
|
|
if (s(jj) == zero) sing = .true.
|
||
|
|
!
|
||
|
|
end subroutine r1updt
|
||
|
|
|
||
|
|
end module minpack
|