! E04GGF Example Program Text
! Mark 28.6 Release. NAG Copyright 2022.
Module e04ggfe_mod
! .. Use Statements ..
Use iso_c_binding, Only: c_ptr
Use nag_library, Only: nag_wp
! .. Implicit None Statement ..
Implicit None
! .. Accessibility Statements ..
Private
Public :: lsqfun, lsqgrd, lsqhes
Contains
Subroutine lsqfun(nvar,x,nres,rx,inform,iuser,ruser,cpuser)
! .. Scalar Arguments ..
Type (c_ptr), Intent (In) :: cpuser
Integer, Intent (Inout) :: inform
Integer, Intent (In) :: nres, nvar
! .. Array Arguments ..
Real (Kind=nag_wp), Intent (Inout) :: ruser(*)
Real (Kind=nag_wp), Intent (Out) :: rx(nres)
Real (Kind=nag_wp), Intent (In) :: x(nvar)
Integer, Intent (Inout) :: iuser(*)
! .. Intrinsic Procedures ..
Intrinsic :: exp
! .. Executable Statements ..
rx(:) = 0.0_nag_wp
rx(1:nres) = ruser(nres+1:2*nres) - x(1)*exp(-x(2)*ruser(1:nres)) - &
x(3)*exp(-x(4)*ruser(1:nres)) - x(5)*exp(-x(6)*ruser(1:nres))
inform = 0
End Subroutine lsqfun
Subroutine lsqgrd(nvar,x,nres,nnzrd,rdx,inform,iuser,ruser,cpuser)
! .. Scalar Arguments ..
Type (c_ptr), Intent (In) :: cpuser
Integer, Intent (Inout) :: inform
Integer, Intent (In) :: nnzrd, nres, nvar
! .. Array Arguments ..
Real (Kind=nag_wp), Intent (Inout) :: rdx(nnzrd), ruser(*)
Real (Kind=nag_wp), Intent (In) :: x(nvar)
Integer, Intent (Inout) :: iuser(*)
! .. Local Scalars ..
Integer :: i
! .. Intrinsic Procedures ..
Intrinsic :: exp
! .. Executable Statements ..
rdx(:) = 0.0_nag_wp
Do i = 1, nres
rdx((i-1)*nvar+1) = -exp(-x(2)*ruser(i))
rdx((i-1)*nvar+2) = ruser(i)*x(1)*exp(-x(2)*ruser(i))
rdx((i-1)*nvar+3) = -exp(-x(4)*ruser(i))
rdx((i-1)*nvar+4) = ruser(i)*x(3)*exp(-x(4)*ruser(i))
rdx((i-1)*nvar+5) = -exp(-x(6)*ruser(i))
rdx((i-1)*nvar+6) = ruser(i)*x(5)*exp(-x(6)*ruser(i))
End Do
inform = 0
End Subroutine lsqgrd
Subroutine lsqhes(nvar,x,nres,lambda,hx,inform,iuser,ruser,cpuser)
! .. Scalar Arguments ..
Type (c_ptr), Intent (In) :: cpuser
Integer, Intent (Inout) :: inform
Integer, Intent (In) :: nres, nvar
! .. Array Arguments ..
Real (Kind=nag_wp), Intent (Inout) :: hx(nvar,nvar), ruser(*)
Real (Kind=nag_wp), Intent (In) :: lambda(nres), x(nvar)
Integer, Intent (Inout) :: iuser(*)
! .. Intrinsic Procedures ..
Intrinsic :: exp, sum
! .. Executable Statements ..
hx(1:nvar,1:nvar) = 0.0_nag_wp
hx(2,1) = sum(lambda(1:nres)*ruser(1:nres)*exp(-x(2)*ruser(1:nres)))
hx(1,2) = hx(2,1)
hx(2,2) = sum(-lambda(1:nres)*(ruser(1:nres)**2)*x(1)*exp(-x(2)*ruser( &
1:nres)))
hx(4,3) = sum(lambda(1:nres)*ruser(1:nres)*exp(-x(4)*ruser(1:nres)))
hx(3,4) = hx(4,3)
hx(4,4) = sum(-lambda(1:nres)*(ruser(1:nres)**2)*x(3)*exp(-x(4)*ruser( &
1:nres)))
hx(6,5) = sum(lambda(1:nres)*ruser(1:nres)*exp(-x(6)*ruser(1:nres)))
hx(5,6) = hx(6,5)
hx(6,6) = sum(-lambda(1:nres)*(ruser(1:nres)**2)*x(5)*exp(-x(6)*ruser( &
1:nres)))
inform = 0
End Subroutine lsqhes
End Module e04ggfe_mod
Program e04ggfe
! .. Use Statements ..
Use e04ggfe_mod, Only: lsqfun, lsqgrd, lsqhes
Use iso_c_binding, Only: c_null_ptr, c_ptr
Use nag_library, Only: e04ffu, e04ggf, e04ggv, e04raf, e04rhf, e04rmf, &
e04rxf, e04rzf, e04zmf, nag_wp
! .. Implicit None Statement ..
Implicit None
! .. Parameters ..
Real (Kind=nag_wp), Parameter :: infbnd = 1.0E20_nag_wp
Integer, Parameter :: nout = 6
! .. Local Scalars ..
Type (c_ptr) :: cpuser, handle
Integer :: ifail, isparse, nnzrd, nres, nvar
! .. Local Arrays ..
Real (Kind=nag_wp), Allocatable :: blx(:), bux(:), ruser(:), rx(:), &
x(:), z(:)
Real (Kind=nag_wp) :: rinfo(100), stats(100)
Integer :: icolrd(0), irowrd(0), iuser(0)
! .. Executable Statements ..
Write (nout,*) 'E04GGF Example Program Results'
Write (nout,*)
Flush (nout)
cpuser = c_null_ptr
! Problem size
nvar = 6
! Residual quantity
nres = 24
Allocate (ruser(2*nres))
! Data from Lanczos 3 Problem
! t(:) =
ruser(1:nres) = (/0.00E+0_nag_wp,5.00E-2_nag_wp,1.00E-1_nag_wp, &
1.50E-1_nag_wp,2.00E-1_nag_wp,2.50E-1_nag_wp,3.00E-1_nag_wp, &
3.50E-1_nag_wp,4.00E-1_nag_wp,4.50E-1_nag_wp,5.00E-1_nag_wp, &
5.50E-1_nag_wp,6.00E-1_nag_wp,6.50E-1_nag_wp,7.00E-1_nag_wp, &
7.50E-1_nag_wp,8.00E-1_nag_wp,8.50E-1_nag_wp,9.00E-1_nag_wp, &
9.50E-1_nag_wp,1.00E+0_nag_wp,1.05E+0_nag_wp,1.10E+0_nag_wp, &
1.15E+0_nag_wp/)
! y(:) =
ruser(nres+1:2*nres) = (/2.5134_nag_wp,2.0443_nag_wp,1.6684_nag_wp, &
1.3664_nag_wp,1.1232_nag_wp,0.9269_nag_wp,0.7679_nag_wp,0.6389_nag_wp, &
0.5338_nag_wp,0.4479_nag_wp,0.3776_nag_wp,0.3197_nag_wp,0.2720_nag_wp, &
0.2325_nag_wp,0.1997_nag_wp,0.1723_nag_wp,0.1493_nag_wp,0.1301_nag_wp, &
0.1138_nag_wp,0.1000_nag_wp,0.0883_nag_wp,0.0783_nag_wp,0.0698_nag_wp, &
0.0624_nag_wp/)
iuser(:) = 0
! Initialize handle
ifail = 0
Call e04raf(handle,nvar,ifail)
! Define residuals structure, isparse=0 means the residual structure is
! dense => irowrd and icolrd are not accessed
isparse = 0
nnzrd = 0
Call e04rmf(handle,nres,isparse,nnzrd,irowrd,icolrd,ifail)
! Set options
Call e04zmf(handle,'BXNL Use Second Derivatives = Yes',ifail)
Call e04zmf(handle,'BXNL Model = Gauss-Newton',ifail)
Call e04zmf(handle,'BXNL Glob Method = Reg',ifail)
! Change printed output verbosity
Call e04zmf(handle,'Print Level = 1',ifail)
! Define starting point
Allocate (x(nvar),rx(nres),z(nvar))
x(1:nvar) = (/1.2_nag_wp,0.3_nag_wp,5.6_nag_wp,5.5_nag_wp,6.5_nag_wp, &
7.6_nag_wp/)
! Define bounds
Allocate (blx(nvar),bux(nvar))
blx(1) = 0.0_nag_wp
bux(1) = 1.0_nag_wp
blx(2) = -1.0_nag_wp
bux(2) = infbnd
blx(3) = -1.0_nag_wp
bux(3) = infbnd
blx(4) = -1.0_nag_wp
bux(4) = infbnd
blx(5) = -1.0_nag_wp
bux(5) = 1.0_nag_wp
blx(6) = -1.0_nag_wp
bux(6) = 10.0_nag_wp
Call e04rhf(handle,nvar,blx,bux,ifail)
! Call the solver
ifail = -1
Call e04ggf(handle,lsqfun,lsqgrd,lsqhes,e04ggv,e04ffu,nvar,x,nres,rx, &
rinfo,stats,iuser,ruser,cpuser,ifail)
! Recover latest iterate from handle if available
If (ifail==0) Then
ifail = -1
Call e04rxf(handle,'X',1,nvar,z,ifail)
If (ifail==0) Then
Write (6,*) ''
Write (6,*) 'Solver stored solution iterate in the handle'
Write (6,Fmt=99999) 'X:', z(1:nvar)
End If
End If
! Free the handle memory
ifail = 0
Call e04rzf(handle,ifail)
99999 Format (A,1X,6(Es8.2e1,1X))
End Program e04ggfe