NAG Library Manual, Mark 28.4
```!   E05UC_P0W_F Example Program Text
!   Mark 28.4 Release. NAG Copyright 2022.

Module e05uc_p0w_fe_mod

!     E05UC_P0W_F Example Program Module:
!            Parameters and User-defined Routines

!     .. Use Statements ..
Use nag_library, Only: nag_wp
!     .. Implicit None Statement ..
Implicit None
!     .. Accessibility Statements ..
Private
Public                           :: mystart, schwefel_confun,            &
schwefel_obj
Contains
ruser)

!       .. Use Statements ..
Use iso_c_binding, Only: c_ptr
!       .. Scalar Arguments ..
Type (c_ptr), Intent (Inout)   :: ad_handle
Real (Kind=nag_wp), Intent (Out) :: objf
Integer, Intent (Inout)        :: mode
Integer, Intent (In)           :: n, nstate
!       .. Array Arguments ..
Real (Kind=nag_wp), Intent (Inout) :: objgrd(n), ruser(*)
Real (Kind=nag_wp), Intent (In) :: x(n)
Integer, Intent (Inout)        :: iuser(*)
!       .. Intrinsic Procedures ..
Intrinsic                      :: abs, cos, sin, sqrt, sum
!       .. Executable Statements ..
If (nstate==1) Then
!         This is the first call.
!         Take any special action here if desired.
Continue
End If
If (mode==0 .Or. mode==2) Then
!         Evaluate the objective function.
objf = sum(x(1:n)*sin(sqrt(abs(x(1:n)))))
End If

If (mode==1 .Or. mode==2) Then
!         Calculate the gradient of the objective function.
objgrd(1:n) = sin(sqrt(abs(x(1:n)))) + 0.5_nag_wp*sqrt(abs(x(1:n)))* &
cos(sqrt(abs(x(1:n))))
End If

Return
End Subroutine schwefel_obj
nstate,iuser,ruser)

!       .. Use Statements ..
Use iso_c_binding, Only: c_ptr
!       .. Scalar Arguments ..
Type (c_ptr), Intent (Inout)   :: ad_handle
Integer, Intent (In)           :: ldcjsl, n, ncnln, nstate
Integer, Intent (Inout)        :: mode
!       .. Array Arguments ..
Real (Kind=nag_wp), Intent (Out) :: c(ncnln)
Real (Kind=nag_wp), Intent (Inout) :: cjsl(ldcjsl,n), ruser(*)
Real (Kind=nag_wp), Intent (In) :: x(n)
Integer, Intent (Inout)        :: iuser(*)
Integer, Intent (In)           :: needc(ncnln)
!       .. Local Scalars ..
Real (Kind=nag_wp)             :: t1, t2
Integer                        :: k
Logical                        :: evalc, evalcjsl
!       .. Intrinsic Procedures ..
Intrinsic                      :: cos, sin
!       .. Executable Statements ..
If (nstate==1) Then
!         This is the first call.
!         Take any special action here if desired.
Continue
End If

!       mode: what is required - constraints, derivatives, or both?
evalc = (mode==0 .Or. mode==2)
evalcjsl = (mode==1 .Or. mode==2)

loop_constraints: Do k = 1, ncnln

If (needc(k)<=0) Then
Cycle loop_constraints
End If

If (evalc) Then
!           Constraint values are required.
Select Case (k)
Case (1)
c(k) = x(1)**2 - x(2)**2 + 3.0_nag_wp*x(1)*x(2)
Case (2)
c(k) = cos((x(1)/200.0_nag_wp)**2+(x(2)/100.0_nag_wp))
Case Default
!             This constraint is not coded (there are only two).
!             Terminate.
mode = -1
Exit loop_constraints
End Select
End If

If (evalcjsl) Then
!           Constraint derivatives are required.
Select Case (k)
Case (1)
cjsl(k,1) = 2.0_nag_wp*x(1) + 3.0_nag_wp*x(2)
cjsl(k,2) = -2.0_nag_wp*x(2) + 3.0_nag_wp*x(1)
Case (2)
t1 = x(1)/200.0_nag_wp
t2 = x(2)/100.0_nag_wp
cjsl(k,1) = -sin(t1**2+t2)*2.0_nag_wp*t1/200.0_nag_wp
cjsl(k,2) = -sin(t1**2+t2)/100.0_nag_wp
End Select
End If

End Do loop_constraints

Return
End Subroutine schwefel_confun

!       Sets the initial points.
!       A typical user-defined start procedure.
!       Only nonzero elements of quas need to be specified here.

!       .. Use Statements ..
Use iso_c_binding, Only: c_ptr
Use nag_library, Only: g05kgf, g05saf
!       .. Scalar Arguments ..
Type (c_ptr), Intent (Inout)   :: ad_handle
Integer, Intent (Inout)        :: mode
Integer, Intent (In)           :: n, npts
Logical, Intent (In)           :: repeat
!       .. Array Arguments ..
Real (Kind=nag_wp), Intent (In) :: bl(n), bu(n)
Real (Kind=nag_wp), Intent (Inout) :: quas(n,npts), ruser(*)
Integer, Intent (Inout)        :: iuser(*)
!       .. Local Scalars ..
Integer                        :: genid, i, ifail, lstate, subid
!       .. Local Arrays ..
Integer, Allocatable           :: state(:)
!       .. Intrinsic Procedures ..
Intrinsic                      :: real
!       .. Executable Statements ..
If (repeat) Then
!         Generate a uniform spread of points between bl and bu.
Do i = 1, npts
quas(1:n,i) = bl(1:n) + (bu(1:n)-bl(1:n))*real(i-1,kind=nag_wp)/   &
real(npts-1,kind=nag_wp)
End Do
Else
!         Generate a non-repeatable spread of points between bl and bu.
genid = 2
subid = 53
lstate = -1
Allocate (state(lstate))
ifail = 0
Call g05kgf(genid,subid,state,lstate,ifail)
Deallocate (state)
Allocate (state(lstate))
ifail = 0
Call g05kgf(genid,subid,state,lstate,ifail)
Do i = 1, npts
ifail = 0
Call g05saf(n,state,quas(1,i),ifail)
quas(1:n,i) = bl(1:n) + (bu(1:n)-bl(1:n))*quas(1:n,i)
End Do
Deallocate (state)
End If
!       Set mode negative to terminate execution for any reason.
mode = 0
Return
End Subroutine mystart
End Module e05uc_p0w_fe_mod
Program e05uc_p0w_fe

!     E05UC_P0W_F Example Main Program

!     .. Use Statements ..
Use e05uc_p0w_fe_mod, Only: mystart, schwefel_confun, schwefel_obj
Use iso_c_binding, Only: c_ptr
Use nag_library, Only: dgemv, nag_wp
!     .. Implicit None Statement ..
Implicit None
!     .. Parameters ..
Integer, Parameter               :: n = 2, nclin = 1, ncnln = 2,         &
nin = 5, nout = 6
!     .. Local Scalars ..
Integer                          :: i, ifail, j, k, l, lda, ldc, ldcjac, &
ldclda, ldobjd, ldr, ldx, liopts,    &
listat, lopts, nb, npts, sda,        &
sdcjac, sdr
Logical                          :: repeat
!     .. Local Arrays ..
Real (Kind=nag_wp), Allocatable  :: a(:,:), bl(:), bu(:), c(:,:),        &
cjac(:,:,:), clamda(:,:), objf(:),   &
objgrd(:,:), opts(:), r(:,:,:),      &
work(:), x(:,:)
Real (Kind=nag_wp)               :: ruser(1)
Integer, Allocatable             :: info(:), iopts(:), istate(:,:),      &
iter(:)
Integer                          :: iuser(1)
!     .. Executable Statements ..
Write (nout,*) 'E05UC_P0W_F Example Program Results'
Flush (nout)

!     Skip heading in data file

lda = nclin

If (nclin>0) Then
sda = n
Else
sda = 1
End If

ldx = n
ldobjd = n
ldc = ncnln
ldcjac = ncnln

If (ncnln>0) Then
sdcjac = n
Else
sdcjac = 0
End If

ldr = n
sdr = n
ldclda = n + nclin + ncnln
listat = n + nclin + ncnln
liopts = 740
lopts = 485
Allocate (a(lda,sda),bl(n+nclin+ncnln),bu(n+nclin+ncnln),x(ldx,nb),      &
objf(nb),objgrd(ldobjd,nb),iter(nb),c(ldc,nb),cjac(ldcjac,sdcjac,nb),  &
r(ldr,sdr,nb),clamda(ldclda,nb),istate(listat,nb),iopts(liopts),       &
opts(lopts),info(nb),work(nclin))

bl(1:n+nclin+ncnln) = (/-500.0_nag_wp,-500.0_nag_wp,-10000.0_nag_wp,     &
-1.0_nag_wp,-0.9_nag_wp/)
bu(1:n+nclin+ncnln) = (/500.0_nag_wp,500.0_nag_wp,10.0_nag_wp,           &
500000.0_nag_wp,0.9_nag_wp/)

a(1,1) = 3.0_nag_wp
a(1,2) = -2.0_nag_wp

!     Initialize the solver.

ifail = 0
lopts,ifail)

!     Solve the problem.

ifail = -1
schwefel_obj,npts,x,ldx,mystart,repeat,nb,objf,objgrd,ldobjd,iter,c,   &
ldc,cjac,ldcjac,sdcjac,r,ldr,sdr,clamda,ldclda,istate,listat,iopts,    &
opts,iuser,ruser,info,ifail)

Select Case (ifail)
Case (0)
l = nb
Case (8)
l = info(nb)
Write (nout,99992) iter(nb)
Case Default
Go To 100
End Select

loop: Do i = 1, l
Write (nout,99999) i
Write (nout,99998) info(i)
Write (nout,99997) 'Varbl'
Do j = 1, n
Write (nout,99996) 'V', j, istate(j,i), x(j,i), clamda(j,i)
End Do
If (nclin>0) Then
Write (nout,99997) 'L Con'

!         Below is a call to the level 2 BLAS routine DGEMV.
!         This performs the matrix vector multiplication A*X
!         (linear constraint values) and puts the result in
!         the first NCLIN locations of WORK.

Call dgemv('N',nclin,n,1.0_nag_wp,a,lda,x(1,i),1,0.0_nag_wp,work,1)

Do k = n + 1, n + nclin
j = k - n
Write (nout,99996) 'L', j, istate(k,i), work(j), clamda(k,i)
End Do
End If
If (ncnln>0) Then
Write (nout,99997) 'N Con'
Do k = n + nclin + 1, n + nclin + ncnln
j = k - n - nclin
Write (nout,99996) 'N', j, istate(k,i), c(j,i), clamda(k,i)
End Do
End If
Write (nout,99995) objf(i)
Write (nout,99994)
Write (nout,99993)(clamda(k,i),k=1,n+nclin+ncnln)

If (l==1) Then
Exit loop
End If

Write (nout,*)

Write (nout,*)                                                         &
' ------------------------------------------------------ '

End Do loop

100   Continue

99999 Format (/,1X,'Solution number',I16)
99998 Format (/,1X,'Local minimization exited with code',I5)
99997 Format (/,1X,A,2X,'Istate',3X,'Value',9X,'Lagr Mult',/)
99996 Format (1X,A,2(1X,I3),4X,F12.4,2X,F12.4)
99995 Format (/,1X,'Final objective value = ',1X,F12.4)
99994 Format (/,1X,'QP multipliers')
99993 Format (1X,F12.4)
99992 Format (1X,I16,' starting points converged')
End Program e05uc_p0w_fe
```