! E04GB_P0W_F Example Program Text
! Mark 28.7 Release. NAG Copyright 2022.
Module e04gb_p0w_fe_mod
! E04GB_P0W_F Example Program Module:
! Parameters and User-defined Routines
! .. Use Statements ..
Use iso_c_binding, Only: c_ptr
Use nag_library, Only: ddot, dgemv, nag_wp
! .. Implicit None Statement ..
Implicit None
! .. Accessibility Statements ..
Private
Public :: lsqfun, lsqgrd, lsqmon
! .. Parameters ..
Integer, Parameter :: inc1 = 1
Integer, Parameter, Public :: m = 15, n = 3, nin = 5, nout = 6, &
nt = 3
Integer, Parameter, Public :: ldfjac = m
Integer, Parameter, Public :: ldv = n
! .. Local Arrays ..
Real (Kind=nag_wp), Public, Save :: t(m,nt), y(m)
Contains
Subroutine lsqgrd(ad_handle,m,n,fvec,fjac,ldfjac,g)
! Routine to evaluate gradient of the sum of squares
! .. Scalar Arguments ..
Type (c_ptr), Intent (Inout) :: ad_handle
Integer, Intent (In) :: ldfjac, m, n
! .. Array Arguments ..
Real (Kind=nag_wp), Intent (In) :: fjac(ldfjac,n), fvec(m)
Real (Kind=nag_wp), Intent (Out) :: g(n)
! .. Local Scalars ..
Real (Kind=nag_wp) :: alpha, beta
Character (1), Save :: trans = 'T'
! .. Executable Statements ..
alpha = 1.0_nag_wp
beta = 0.0_nag_wp
Call dgemv(trans,m,n,alpha,fjac,ldfjac,fvec,inc1,beta,g,inc1)
g(1:n) = 2.0_nag_wp*g(1:n)
Return
End Subroutine lsqgrd
Subroutine lsqfun(ad_handle,iflag,m,n,xc,fvec,fjac,ldfjac,iuser,ruser)
! Routine to evaluate the residuals
! Always use algorithmic differentiation here for simplicity
! .. Scalar Arguments ..
Type (c_ptr), Intent (Inout) :: ad_handle
Integer, Intent (Inout) :: iflag
Integer, Intent (In) :: ldfjac, m, n
! .. Array Arguments ..
Real (Kind=nag_wp), Intent (Inout) :: fjac(ldfjac,n), ruser(*)
Real (Kind=nag_wp), Intent (Out) :: fvec(m)
Real (Kind=nag_wp), Intent (In) :: xc(n)
Integer, Intent (Inout) :: iuser(*)
! .. Local Scalars ..
Real (Kind=nag_wp) :: denom, denom2
Integer :: i
! .. Executable Statements ..
Do i = 1, m
denom = xc(2)*t(i,2) + xc(3)*t(i,3)
fvec(i) = xc(1) + t(i,1)/denom - y(i)
If (iflag/=0) Then
fjac(i,1) = 1.0_nag_wp
denom2 = -1.0_nag_wp/(denom*denom)
fjac(i,2) = t(i,1)*t(i,2)*denom2
fjac(i,3) = t(i,1)*t(i,3)*denom2
End If
End Do
Return
End Subroutine lsqfun
Subroutine lsqmon(ad_handle,m,n,xc,fvec,fjac,ldfjac,s,igrade,niter,nf, &
iuser,ruser)
! Monitoring routine
! .. Parameters ..
Integer, Parameter :: ndec = 3
! .. Scalar Arguments ..
Type (c_ptr), Intent (Inout) :: ad_handle
Integer, Intent (In) :: igrade, ldfjac, m, n, nf, niter
! .. Array Arguments ..
Real (Kind=nag_wp), Intent (In) :: fjac(ldfjac,n), fvec(m), s(n), &
xc(n)
Real (Kind=nag_wp), Intent (Inout) :: ruser(*)
Integer, Intent (Inout) :: iuser(*)
! .. Local Scalars ..
Real (Kind=nag_wp) :: fsumsq, gtg
Integer :: j
! .. Local Arrays ..
Real (Kind=nag_wp) :: g(ndec)
! .. Executable Statements ..
fsumsq = ddot(m,fvec,inc1,fvec,inc1)
Call lsqgrd(ad_handle,m,n,fvec,fjac,ldfjac,g)
gtg = ddot(n,g,inc1,g,inc1)
Write (nout,*)
Write (nout,*) &
' Itn F evals SUMSQ GTG Grade'
Write (nout,99999) niter, nf, fsumsq, gtg, igrade
Write (nout,*)
Write (nout,*) &
' x g Singular values'
Write (nout,99998)(xc(j),g(j),s(j),j=1,n)
Return
99999 Format (1X,I4,6X,I5,6X,1P,E13.5,6X,1P,E9.1,6X,I3)
99998 Format (1X,1P,E13.5,10X,1P,E9.1,10X,1P,E9.1)
End Subroutine lsqmon
End Module e04gb_p0w_fe_mod
Program e04gb_p0w_fe
! E04GB_P0W_F Example Main Program
! .. Use Statements ..
Use e04gb_p0w_fe_mod, Only: ldfjac, ldv, lsqfun, lsqgrd, lsqmon, m, n, &
nin, nout, nt, t, y
Use iso_c_binding, Only: c_ptr
Use nagad_library, Only: e04gb_p0w_f
Use nag_library, Only: nag_wp, x02ajf
! .. Implicit None Statement ..
Implicit None
! .. Local Scalars ..
Type (c_ptr) :: ad_handle
Real (Kind=nag_wp) :: eta, fsumsq, stepmx, xtol
Integer :: i, ifail, iprint, maxcal, nf, niter, &
selct
! .. Local Arrays ..
Real (Kind=nag_wp) :: fjac(m,n), fvec(m), g(n), ruser(1), &
s(n), v(ldv,n), x(n)
Integer :: iuser(1)
! .. Intrinsic Procedures ..
Intrinsic :: real, sqrt
! .. Executable Statements ..
Write (nout,*) 'E04GB_P0W_F Example Program Results'
! Skip heading in data file
Read (nin,*)
! Observations of T_j (j = 1:nt) are held in T(1:m, j)
Do i = 1, m
Read (nin,*) y(i), t(i,1:nt)
End Do
! Set iprint to 1 to obtain output from lsqmon at each iteration
iprint = -1
maxcal = 50*n
eta = 0.9_nag_wp
xtol = 10.0_nag_wp*sqrt(x02ajf())
! We estimate that the minimum will be within 10 units of the
! starting point
stepmx = 10.0_nag_wp
! Set up the starting point
Do i = 1, n
x(i) = 0.5_nag_wp*real(i,kind=nag_wp)
End Do
! Solve the problem
selct = 2
ifail = -1
Call e04gb_p0w_f(ad_handle,m,n,selct,lsqfun,lsqmon,iprint,maxcal,eta, &
xtol,stepmx,x,fsumsq,fvec,fjac,ldfjac,s,v,ldv,niter,nf,iuser,ruser, &
ifail)
Select Case (ifail)
Case (0,2:)
Write (nout,*)
Write (nout,99999) 'Sum of squares = ', fsumsq
Write (nout,99999) 'Solution point = ', x(1:n)
Call lsqgrd(ad_handle,m,n,fvec,fjac,ldfjac,g)
Write (nout,99998) 'Estim gradien = ', g(1:n)
Write (nout,*) ' (machine dependent)'
Write (nout,*) 'Residuals:'
Write (nout,99997) fvec(1:m)
Case (:-1)
Write (nout,*)
Write (nout,99996) 'Routine e04gb_p0w_f failed with ifail = ', ifail
End Select
99999 Format (1X,A,3F12.4)
99998 Format (1X,A,1P,3E12.3)
99997 Format (3(1X,1P,E11.1))
99996 Format (1X,A,I5)
End Program e04gb_p0w_fe