! E04GB_T2W_F Example Program Text
! Mark 30.1 Release. NAG Copyright 2024.
Module e04gb_t2w_fe_mod
! E04GB_T2W_F Example Program Module:
! Parameters and User-defined Routines
! .. Use Statements ..
Use iso_c_binding, Only: c_ptr
Use nagad_library, Only: nagad_t2w_w_rtype, Operator (+), &
Assignment (=), Operator (-), Operator (/), &
Operator (*)
Use nag_library, Only: 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 ..
Type (nagad_t2w_w_rtype), Public, Save :: t(m,nt)
Contains
Subroutine lsqgrd(ad_handle,m,n,fvec,fjac,ldfjac,g_t2w)
! Routine to evaluate gradient of the sum of squares
! .. Use Statements ..
Use nagad_library, Only: dgemv_t2w
! .. Scalar Arguments ..
Type (c_ptr), Intent (Inout) :: ad_handle
Integer, Intent (In) :: ldfjac, m, n
! .. Array Arguments ..
Type (nagad_t2w_w_rtype), Intent (In) :: fjac(ldfjac,n), fvec(m)
Type (nagad_t2w_w_rtype), Intent (Out) :: g_t2w(n)
! .. Local Scalars ..
Type (nagad_t2w_w_rtype) :: alpha, beta
Character (1), Save :: trans = 'T'
! .. Executable Statements ..
alpha = 1.0_nag_wp
beta = 0.0_nag_wp
Call dgemv_t2w(trans,m,n,alpha,fjac,ldfjac,fvec,inc1,beta,g_t2w,inc1)
g_t2w(1:n) = 2.0_nag_wp*g_t2w(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 ..
Type (nagad_t2w_w_rtype), Intent (Inout) :: fjac(ldfjac,n), ruser(*)
Type (nagad_t2w_w_rtype), Intent (Out) :: fvec(m)
Type (nagad_t2w_w_rtype), Intent (In) :: xc(n)
Integer, Intent (Inout) :: iuser(*)
! .. Local Scalars ..
Type (nagad_t2w_w_rtype) :: 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 - ruser(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
! .. Use Statements ..
Use nagad_library, Only: ddot_t2w
! .. 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 ..
Type (nagad_t2w_w_rtype), Intent (In) :: fjac(ldfjac,n), fvec(m), &
s(n), xc(n)
Type (nagad_t2w_w_rtype), Intent (Inout) :: ruser(*)
Integer, Intent (Inout) :: iuser(*)
! .. Local Scalars ..
Type (nagad_t2w_w_rtype) :: fsumsq, gtg
Integer :: j
! .. Local Arrays ..
Type (nagad_t2w_w_rtype) :: g_t2w(ndec)
! .. Executable Statements ..
fsumsq = ddot_t2w(m,fvec,inc1,fvec,inc1)
Call lsqgrd(ad_handle,m,n,fvec,fjac,ldfjac,g_t2w)
gtg = ddot_t2w(n,g_t2w,inc1,g_t2w,inc1)
Write (nout,*)
Write (nout,*) &
' Itn F evals SUMSQ GTG Grade'
Write (nout,99999) niter, nf, fsumsq%value, gtg%value, igrade
Write (nout,*)
Write (nout,*) &
' x g Singular values'
Write (nout,99998)(xc(j)%value,g_t2w(j)%value,s(j)%value,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_t2w_fe_mod
Program e04gb_t2w_fe
! E04GB_T2W_F Example Main Program
! .. Use Statements ..
Use e04gb_t2w_fe_mod, Only: ldfjac, ldv, lsqfun, lsqgrd, lsqmon, m, n, &
nin, nout, nt, t
Use iso_c_binding, Only: c_ptr
Use nagad_library, Only: e04gb_t2w_f, nagad_t2w_w_rtype, x10aa_t2w_f, &
x10ab_t2w_f, Assignment (=)
Use nag_library, Only: nag_wp, x02ajf
! .. Implicit None Statement ..
Implicit None
! .. Local Scalars ..
Type (c_ptr) :: ad_handle
Type (nagad_t2w_w_rtype) :: eta, fsumsq, stepmx, xtol
Real (Kind=nag_wp) :: yr
Integer :: i, ifail, iprint, j, maxcal, nf, &
niter, selct
! .. Local Arrays ..
Type (nagad_t2w_w_rtype) :: fjac(m,n), fvec(m), g_t2w(n), &
ruser(m), s(n), v(ldv,n), x(n)
Real (Kind=nag_wp) :: dfdy(m), dxdy(n,m), tr(nt)
Integer :: iuser(1)
! .. Intrinsic Procedures ..
Intrinsic :: real, sqrt
! .. Executable Statements ..
Write (nout,*) 'E04GB_T2W_F Example Program Results'
! Skip heading in data file
Read (nin,*)
! Store y in ruser
! Observations of T_j (j = 1:nt) are held in T(1:m, j)
Do i = 1, m
Read (nin,*) yr, tr(1:nt)
ruser(i) = yr
t(i,1:nt) = tr(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
! Create AD configuration data object
ifail = 0
Call x10aa_t2w_f(ad_handle,ifail)
Do i = 1, m
ruser(i)%value%tangent = 1.0_nag_wp
ruser(i)%tangent%value = 1.0_nag_wp
! Set up the starting point
Do j = 1, n
x(j) = 0.5_nag_wp*real(j,kind=nag_wp)
End Do
! Solve the problem
selct = 2
ifail = -1
Call e04gb_t2w_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)
If (ifail<0) Then
Write (nout,*)
Write (nout,99995) 'Routine e04gb_t2w_f failed with ifail = ', ifail
Go To 100
End If
ruser(i)%value%tangent = 0.0_nag_wp
ruser(i)%tangent%value = 0.0_nag_wp
dxdy(1:n,i) = x(1:n)%tangent%tangent
dfdy(i) = fsumsq%tangent%tangent
End Do
Write (nout,*)
Write (nout,99999) 'Sum of squares = ', fsumsq%value%value
Write (nout,99999) 'Solution point = ', x(1:n)%value%value
Call lsqgrd(ad_handle,m,n,fvec,fjac,ldfjac,g_t2w)
Write (nout,99998) 'Estim gradien = ', g_t2w(1:n)%value%value
Write (nout,*) ' (machine dependent)'
Write (nout,*) 'Residuals:'
Write (nout,99997) fvec(1:m)%value%value
99999 Format (1X,A,3F12.4)
99998 Format (1X,A,1P,3E12.3)
99997 Format (3(1X,1P,E11.1))
Write (nout,*)
Write (nout,*) ' Derivatives calculated: First order tangents'
Write (nout,*) ' Computational mode : algorithmic'
Write (nout,*)
Write (nout,*) ' Derivatives:'
Write (nout,*)
Write (nout,*) ' sum of squares w.r.t y (d^2f/dy(j)^2):'
Write (nout,99996) dfdy(1:m)
99996 Format (3(1X,1P,E11.1))
Do i = 1, n
Write (nout,*)
Write (nout,99995) ' d^2x(', i, ')/dy(j)^2:'
Write (nout,99996) dxdy(i,1:m)
End Do
99995 Format (1X,A,I0,A)
100 Continue
! Remove computational data object
Call x10ab_t2w_f(ad_handle,ifail)
End Program e04gb_t2w_fe