subroutine slpcon(me, Ioptn, Nparm, Numgr, Fun, Ifun, Pttbl, Iptb, Indm, &
Tolcon, Rchin, Irk, Itypm1, Itypm2, Icntyp, Rchdwn, &
Numlim, Itersl, Prjslp, Funtbl, Iyrct, x, Mact1, Iact1, &
Jcntyp, Iphse, Enchg, Iwork, Liwrk, Work, Lwrk, Parser, &
Isucc, Param, Error)
implicit none
class(conmax_solver), intent(inout) :: me
integer, intent(in) :: Nparm
integer, intent(in) :: Numgr
integer, intent(in) :: Ifun
integer, intent(in) :: Iptb
integer, intent(in) :: Indm
integer, intent(in) :: Liwrk
integer, intent(in) :: Lwrk
integer :: Ioptn
integer :: Irk
integer :: Itypm1
integer :: Itypm2
integer :: Numlim
integer :: Itersl
integer :: Mact1
integer :: Iphse
integer :: Isucc
real(wp) :: Tolcon
real(wp) :: Rchin
real(wp) :: Rchdwn
real(wp) :: Prjslp
real(wp) :: Enchg
real(wp) :: Fun(Ifun)
real(wp) :: Pttbl(Iptb, Indm)
integer :: Icntyp(Numgr)
integer :: Iyrct(Numgr + 2*Nparm)
integer :: Iact1(Numgr)
integer :: Jcntyp(Numgr)
integer :: Iwork(Liwrk)
real(wp) :: Funtbl(Numgr, Nparm + 1)
real(wp) :: x(Nparm + 1)
real(wp) :: Work(Lwrk)
real(wp) :: Parser(Nparm)
real(wp) :: Param(Nparm)
real(wp) :: Error(Numgr + 3)
real(wp) :: bndlgt, emin, emin1, enorm, prjlim, quots, &
ss, tol1, tol2, unit
integer :: i, ilc05, ilc07, ilc08, ilc11, ilc13, ilc18, &
ilc19, ilc25, ilc35, ilc45, ilc47, indic, &
ipmax, ismax, j, m, ng3, npar1, nsrch, numin
! SET MACHINE AND PRECISION DEPENDENT CONSTANTS.
tol1 = ten*ten*spcmn
tol2 = ten*spcmn
ilc05 = iloc(5, Nparm, Numgr)
ilc07 = iloc(7, Nparm, Numgr)
ilc08 = iloc(8, Nparm, Numgr)
ilc11 = iloc(11, Nparm, Numgr)
ilc13 = iloc(13, Nparm, Numgr)
ilc18 = iloc(18, Nparm, Numgr)
ilc19 = iloc(19, Nparm, Numgr)
ilc25 = iloc(25, Nparm, Numgr)
ilc35 = iloc(35, Nparm, Numgr)
ilc45 = iloc(45, Nparm, Numgr)
ilc47 = iloc(47, Nparm, Numgr)
numin = 0
Isucc = 0
enorm = Error(Numgr + 1)
npar1 = Nparm + 1
ng3 = Numgr + 3
! IF ITERSL=0, SET IYRCT(1)=-1 FOR USE IN SETU1 AND TO TELL SLNPRO NOT
! TO TRY TO USE INFORMATION FROM A PREVIOUS VERTEX.
if (Itersl <= 0) Iyrct(1) = -1
do
! CALL BNDSET TO SET (OR RESET) THE COEFFICIENT CHANGE BOUNDS.
call bndset(Nparm, x, Itersl, numin, Prjslp, Work(ilc07), Work(ilc45), &
Work(ilc05))
! CALL SETU1 TO SET UP FOR SLNPRO AND, IF NUMIN=0, TO DETERMINE
! WHICH CONSTRAINTS ARE ACTIVE AND STORE FUNCTION AND GRADIENT VALUES
! FOR THEM IN FUNTBL.
call me%setu1(Ioptn, Numgr, Nparm, numin, Rchin, Pttbl, Iptb, Indm, Fun, Ifun, &
Funtbl, Work(ilc07), Param, Icntyp, Rchdwn, Error, Mact1, &
Iact1, bndlgt, Iyrct, Iphse, Iwork, Liwrk, Work, Lwrk, &
Work(ilc08), Iwork(ilc13), Work(ilc35), m)
! SET UNIT (FOR USE IN RCHMOD) EQUAL TO THE VALUE OF BNDLGT AFTER
! SETU1 IS CALLED WITH NUMIN=0.
if (numin <= 0) unit = bndlgt
! CALL SLNPRO TO COMPUTE A SEARCH DIRECTION X.
call slnpro(Work(ilc35), m, npar1, Iyrct, Work(ilc47), Iwork(ilc18), &
Iwork(ilc19), Nparm, Numgr, x, indic)
! IF INDIC > 0 THEN SLNPRO FAILED TO PRODUCE AN X, AND IF WE HAVE
! REACHED THE SLPCON ITERATION LIMIT WE RETURN WITH THE WARNING
! ISUCC=1.
if (indic <= 0) then
! HERE SLNPRO SUCCEEDED AND WE SET PRJSLP=1.0 INITIALLY FOR SEARSL.
Prjslp = one
! WE NOW WISH TO DETERMINE PRJLIM = THE SMALLER OF 1.0/SPCMN AND
! THE LARGEST VALUE OF PRJSLP FOR WHICH THE LINEAR STANDARD CONSTRAINTS
! ARE SATISFIED FOR THE PARAMETER VECTOR PARAM+PRJSLP*X. THIS
! WILL GIVE AN UPPER BOUND FOR LINE SEARCHING. NOTE THAT IN
! THEORY WE SHOULD HAVE PRJLIM >= 1.0 SINCE THE LINEAR STANDARD
! CONSTRAINTS SHOULD BE SATISFIED FOR PRJSLP=0.0 AND PRJSLP=1.0, BUT
! ROUNDOFF ERROR COULD AFFECT THIS A LITTLE. IF THERE ARE NO
! LINEAR STANDARD CONSTRAINTS, WE SET PRJLIM=1.0/SPCMN.
prjlim = big
!*****INSERT TO MAKE SEARCHING LESS VIOLENT.
! PRJLIM=TWO
!*****END INSERT
if (Itypm1 > 0) then
do i = 1, Numgr
if (Icntyp(i) + 1 == 0) then
! WE WISH TO HAVE SUMMATION (FUNTBL(I,J+1)*(PARAM(J)+PRJSLP*X(J)))
! + C(I) <= 0.0 FOR I=1,...,NUMGR, ICNTYP(I) = -1,
! WHERE THE ITH CONSTRAINT APPLIED TO PARAM SAYS
! SUMMATION (FUNTBL(I,J+1)*PARAM(J)) + C(I) <= 0.0, SO C(I) IS THE
! CONSTANT TERM ON THE LEFT SIDE OF LINEAR CONSTRANT I.
! THUS FOR I=1,...,NUMGR, ICNTYP(I) = -1, WE WANT PRJLIM*SS <= SSS,
! WHERE SS = SUMMATION (FUNTBL(I,J+1)*X(J)) AND SSS = -C(I) -
! SUMMATION (FUNTBL(I,J+1)*PARAM(J)) = -FUNTBL(I,1).
ss = zero
do j = 1, Nparm
ss = ss + Funtbl(i, j + 1)*x(j)
end do
! IF SS < 10.0*SPCMN THIS CONSTRAINT WILL NOT PUT A SIGNIFICANT
! RESTRICTION ON PRJSLP.
if (ss >= tol2) then
! HERE SS >= 10.0*SPCMN AND WE COMPARE SSS/SS AGIANST PRJLIM.
quots = -Funtbl(i, 1)/ss
if (prjlim > quots) prjlim = quots
end if
end if
end do
end if
! DO NOT ALLOW A PRJSLP SMALLER THAN TOL1.
if (Prjslp < tol1) Prjslp = tol1
! CALL SEARSL TO DO A LINE SEARCH IN DIRECTION X.
call me%searsl(Ioptn, Numgr, Nparm, prjlim, tol1, x, Fun, Ifun, Pttbl, &
Iptb, Indm, Param, Error, Rchdwn, Mact1, Iact1, Iphse, &
unit, Tolcon, Rchin, Itypm1, Itypm2, Iwork, Liwrk, Work, &
Lwrk, Work(ilc11), Work(ilc25), Prjslp, emin, emin1, &
Parser, nsrch)
! COMPUTE THE ERROR NORM CHANGE ENCHG.
Enchg = emin - enorm
! IF WE HAVE AN IMPROVEMENT IN THE ERROR NORM ENORM OF MORE THAN TOL1
! WE UPDATE PARAM AND ERROR AND RETURN WITH ISUCC=0, INDICATING SUCCESS.
! OTHERWISE WE CHECK TO SEE IF WE HAVE REACHED THE SLPCON ITERATION
! LIMIT, AND IF SO WE RETURN WITH ISUCC=1, INDICATING FAILURE.
if (Enchg + tol1 < 0) then
! HERE WE HAD AN IMPROVEMENT IN THE ERROR NORM ENORM OF MORE THAN TOL1.
do j = 1, Nparm
Param(j) = Parser(j)
end do
call me%ercmp1(Ioptn, Nparm, Numgr, Fun, Ifun, Pttbl, Iptb, Indm, &
Param, 1, Iphse, Iwork, Liwrk, Work(ilc08), Icntyp, &
ipmax, ismax, Error)
return
end if
end if
! HERE WE DID NOT OBTAIN AN IMPROVED ERROR NORM SO WE RETURN WITH THE
! WARNING ISUCC=1 IF WE HAVE DONE NUMLIN ITERATIONS IN SLPCON.
if (numin < Numlim) then
! HERE WE DID NOT OBTAIN AN IMPROVED ERROR NORM BUT WE HAVE NOT YET DONE
! NUMLIM ITERATIONS IN SLPCON SO WE INCREMENT NUMIN, SET IYRCT(1)=-1 TO
! TELL SLNPRO NOT TO TRY TO USE INFORMATION FROM THE PREVIOUS FAILED
! VERTEX, AND GO BACK TO CALL BNDSET AND TRY ANOTHER ITERATION WITH
! A DIFFERENT TRUST REGION.
numin = numin + 1
Iyrct(1) = -1
cycle
end if
exit
end do
Isucc = 1
end subroutine slpcon