NAG Library Manual, Mark 30.2
Interfaces:  FL   CL   CPP   AD 

NAG FL Interface Introduction
Example description
!   E04GGF Example Program Text

!   Mark 30.2 Release. NAG Copyright 2024.

    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