module press_f1com
  integer :: ncom
  integer, parameter :: nmax=50
  real :: pcom(nmax)
  real :: xicom(nmax)
end module press_f1com
!
function press_func (para)
  use sic_dependencies_interfaces
  use sic_interfaces, except_this=>press_func
  use sic_adjust
  !---------------------------------------------------------------------
  ! @ private
  !---------------------------------------------------------------------
  real :: press_func                !
  real :: para(*)                   !
  ! Local
  logical :: error
  real(8) :: value,y
  integer :: i
  !
  ! From x to association module
  error = .false.
  do i=1,adj_n
     value = para(i)  ! Promote to R*8
     call from_internal(i,value,y)
     call sic_let_auto(adj_names(i),y,error)
  enddo
  !
  adj_ncall = adj_ncall + 1
  press_func = 0.0
  !
  call exec_subprogram (membyt(cur_exec),diff_expression,error)
  if (error) press_error = .true.
  value = 0.d0
  do i = 1,ndata
     y = dvec(i)*wvec(i)
     value = value + y*y
  enddo
  if (sic_ctrlc()) press_error = .true.
  press_func = sqrt(value)
end function press_func
!
!*************************************************************************
! The following modules are derived from the
! subroutines AMOEBA  LINMIN  MNBRAK  POWELL and the function BRENT
! as described from "Numerical Recipes" by Press et al.
!
! With a lot of modifications allowing better insertion into a generic program
! and more error control
!
!
subroutine press_amoeba(p,y,mp,np,ndim,ftol,my_func,iter)
  use sic_interfaces, except_this=>press_amoeba
  use sic_adjust
  use gbl_message
  !---------------------------------------------------------------------
  ! @ private
  !---------------------------------------------------------------------
  integer :: mp                     !
  integer :: np                     !
  real :: p(mp,np)                  !
  real :: y(mp)                     !
  integer :: ndim                   !
  real :: ftol                      !
  real, external :: my_func         !
  integer :: iter                   !
  ! Local
  integer, parameter :: nmax=26
  real, parameter :: alpha=1.0, beta=0.5, gamma=2.0
  real :: pr(nmax),prr(nmax),pbar(nmax)
  integer :: mpts,ilo,ihi,inhi,i,j
  real :: rtol,ypr,yprr
  !
  mpts=ndim+1
  iter=0
1 ilo=1
  if (y(1).gt.y(2)) then
     ihi=1
     inhi=2
  else
     ihi=2
     inhi=1
  endif
  do i=1,mpts
     if (y(i).lt.y(ilo)) ilo=i
     if (y(i).gt.y(ihi)) then
        inhi=ihi
        ihi=i
     elseif (y(i).gt.y(inhi)) then
        if (i.ne.ihi) inhi=i
     endif
  enddo
  !
  ! MB 3-Feb-1994: The original RTOL criterium did not stop the iteration
  ! when a good result was already obtained. The PAUSE command in the
  ! ITMAX condition has been replaced to avoid a global program shutdown.
  !
  rtol=2.*abs(y(ihi)-y(ilo))/(abs(y(ihi))+abs(y(ilo)))
  if ((rtol.lt.ftol) .or. (abs(y(ihi)-y(ilo)).lt.ftol)) return
  !
  if (iter.eq.press_itmax) then
     call sic_message(seve%i,'ADJUST','SIMPLEX exceeds maximum iteration.')
     return
  endif
  iter=iter+1
  do j=1,ndim
     pbar(j)=0.
  enddo
  do i=1,mpts
     if (i.ne.ihi) then
        do j=1,ndim
           pbar(j)=pbar(j)+p(i,j)
        enddo
     endif
  enddo
  do j=1,ndim
     pbar(j)=pbar(j)/ndim
     pr(j)=(1.+alpha)*pbar(j)-alpha*p(ihi,j)
  enddo
  ypr=my_func(pr)
  if (press_error) return
  !
  if (ypr.le.y(ilo)) then
     do j=1,ndim
        prr(j)=gamma*pr(j)+(1.-gamma)*pbar(j)
     enddo
     yprr=my_func(prr)
     if (press_error) return
     !
     if (yprr.lt.y(ilo)) then
        do j=1,ndim
           p(ihi,j)=prr(j)
        enddo
        y(ihi)=yprr
     else
        do j=1,ndim
           p(ihi,j)=pr(j)
        enddo
        y(ihi)=ypr
     endif
  elseif (ypr.ge.y(inhi)) then
     if (ypr.lt.y(ihi)) then
        do j=1,ndim
           p(ihi,j)=pr(j)
        enddo
        y(ihi)=ypr
     endif
     do j=1,ndim
        prr(j)=beta*p(ihi,j)+(1.-beta)*pbar(j)
     enddo
     yprr=my_func(prr)
     if (press_error) return
     !
     if (yprr.lt.y(ihi)) then
        do j=1,ndim
           p(ihi,j)=prr(j)
        enddo
        y(ihi)=yprr
     else
        do i=1,mpts
           if (i.ne.ilo) then
              do j=1,ndim
                 pr(j)=0.5*(p(i,j)+p(ilo,j))
                 p(i,j)=pr(j)
              enddo
              y(i)=my_func(pr)
              if (press_error) return
              !
           endif
        enddo
     endif
  else
     do j=1,ndim
        p(ihi,j)=pr(j)
     enddo
     y(ihi)=ypr
  endif
  goto 1
end subroutine press_amoeba
!
subroutine press_powell(p,xi,n,np,ftol,iter,fret,my_func,my_f1dim)
  use sic_interfaces, except_this=>press_powell
  use sic_adjust
  use gbl_message
  !---------------------------------------------------------------------
  ! @ private
  !---------------------------------------------------------------------
  integer :: np                     !
  real :: p(np)                     !
  real :: xi(np,np)                 !
  integer :: n                      !
  real :: ftol                      !
  integer :: iter                   !
  real :: fret                      !
  real, external :: my_func         !
  real, external :: my_f1dim        !
  ! Local
  integer, parameter :: nmax=26
  real :: pt(nmax),ptt(nmax),xit(nmax)
  integer :: j,ibig,i
  real :: del,fp,fptt,t
  !
  press_error = .false.
  fret = my_func(p)
  if (press_error) return
  !
  do j=1,n
     pt(j)=p(j)
  enddo
  iter=0
  !
1 iter=iter+1
  fp=fret
  ibig=0
  del=0.
  do i=1,n
     do j=1,n
        xit(j)=xi(j,i)
     enddo
     call press_linmin(p,xit,n,fret,ftol,my_f1dim)
     if (press_error) return
     if (abs(fp-fret).gt.del) then
        del=abs(fp-fret)
        ibig=i
     endif
  enddo
  !
  if (2.*abs(fp-fret).le.ftol*(abs(fp)+abs(fret))) return
  if (iter.eq.press_itmax) then
     call sic_message(seve%i,'ADJUST','POWELL exceeds maximum iteration.')
     return
  endif
  do j=1,n
     ptt(j)=2.*p(j)-pt(j)
     xit(j)=p(j)-pt(j)
     pt(j)=p(j)
  enddo
  !
  fptt=my_func(ptt)
  if (press_error) return
  !
  if (fptt.ge.fp) goto 1
  t=2.*(fp-2.*fret+fptt)*(fp-fret-del)**2-del*(fp-fptt)**2
  if (t.ge.0.) goto 1
  call press_linmin(p,xit,n,fret,ftol,my_f1dim)
  if (press_error) return
  do j=1,n
     xi(j,ibig)=xit(j)
  enddo
  goto 1
end subroutine press_powell
!
subroutine press_linmin(p,xi,n,fret,ftol,my_f1dim)
  use sic_interfaces, except_this=>press_linmin
  use press_f1com
  use sic_adjust ! Is it compatible ?
  !---------------------------------------------------------------------
  ! @ private
  !---------------------------------------------------------------------
  integer :: n                      !
  real :: p(n)                      !
  real :: xi(n)                     !
  real :: fret                      !
  real :: ftol                      !
  real, external :: my_f1dim        !
  ! Local
  integer :: j
  real :: ax,bx,xx,fa,fx,fb,xmin
  !
  ncom=n
  do j=1,n
     pcom(j)=p(j)
     xicom(j)=xi(j)
  enddo
  ax=0.
  xx=1.
  bx=2.
  call press_mnbrak(ax,xx,bx,fa,fx,fb,my_f1dim)
  if (press_error) return
  !
  fret = press_brent(ax,xx,bx,my_f1dim,ftol,xmin)
  if (press_error) return
  !
  do j=1,n
     xi(j)=xmin*xi(j)
     p(j)=p(j)+xi(j)
  enddo
end subroutine press_linmin
!
function press_brent(ax,bx,cx,my_f1dim,tol,xmin)
  use sic_interfaces, except_this=>press_brent
  use sic_adjust
  use gbl_message
  !---------------------------------------------------------------------
  ! @ private
  !---------------------------------------------------------------------
  real :: press_brent               !
  real :: ax                        !
  real :: bx                        !
  real :: cx                        !
  real, external :: my_f1dim        !
  real :: tol                       !
  real :: xmin                      !
  ! Local
  integer, parameter :: itmx=100
  real, parameter :: cgold=.3819660, zeps=1.0e-6
  real :: a,b,v,w,x,e,fx,fv,fw,xm,tol1,tol2,r,q,p,d,etemp,u,fu
  integer :: iter
  !
  a=min(ax,cx)
  b=max(ax,cx)
  v=bx
  w=v
  x=v
  e=0.
  fx=my_f1dim(x)
  fv=fx
  fw=fx
  do iter=1,itmx
     xm=0.5*(a+b)
     tol1=tol*abs(x)+zeps
     tol2=2.*tol1
     if (abs(x-xm).le.(tol2-.5*(b-a))) goto 3
     if (abs(e).gt.tol1) then
        r=(x-w)*(fx-fv)
        q=(x-v)*(fx-fw)
        p=(x-v)*q-(x-w)*r
        q=2.*(q-r)
        if (q.gt.0.) p=-p
        q=abs(q)
        etemp=e
        e=d
        if (abs(p).ge.abs(.5*q*etemp).or.p.le.q*(a-x).or.p.ge.q*(b-x)) goto 1
        d=p/q
        u=x+d
        if (u-a.lt.tol2 .or. b-u.lt.tol2) d=sign(tol1,xm-x)
        goto 2
     endif
1    continue
     if (x.ge.xm) then
        e=a-x
     else
        e=b-x
     endif
     d=cgold*e
2    continue
     if (abs(d).ge.tol1) then
        u=x+d
     else
        u=x+sign(tol1,d)
     endif
     fu=my_f1dim(u)
     if (fu.le.fx) then
        if (u.ge.x) then
           a=x
        else
           b=x
        endif
        v=w
        fv=fw
        w=x
        fw=fx
        x=u
        fx=fu
     else
        if (u.lt.x) then
           a=u
        else
           b=u
        endif
        if (fu.le.fw .or. w.eq.x) then
           v=w
           fv=fw
           w=u
           fw=fu
        elseif (fu.le.fv .or. v.eq.x .or. v.eq.w) then
           v=u
           fv=fu
        endif
     endif
  enddo
  call sic_message(seve%i,'ADJUST','BRENT exceeds maximum iteration.')
  press_error = .true.
  press_brent = 0.0                  ! For completeness
  return
  !
3 xmin=x
  press_brent=fx
  return
end function press_brent
!
subroutine press_mnbrak(ax,bx,cx,fa,fb,fc,my_func)
  use sic_interfaces, except_this=>press_mnbrak
  use sic_adjust
  !---------------------------------------------------------------------
  ! @ private
  !---------------------------------------------------------------------
  real :: ax                        !
  real :: bx                        !
  real :: cx                        !
  real :: fa                        !
  real :: fb                        !
  real :: fc                        !
  real, external :: my_func         !
  ! Local
  real, parameter :: gold=1.618034, glimit=100., tiny=1.e-20
  !
  real :: dum,r,q,u,ulim,fu
  fa=my_func(ax)
  if (press_error) return
  !
  fb=my_func(bx)
  if (press_error) return
  !
  if (fb.gt.fa) then
     dum=ax
     ax=bx
     bx=dum
     dum=fb
     fb=fa
     fa=dum
  endif
  cx=bx+gold*(bx-ax)
  fc=my_func(cx)
  if (press_error) return
  !
1 continue
  if (fb.ge.fc) then
     r=(bx-ax)*(fb-fc)
     q=(bx-cx)*(fb-fa)
     u=bx-((bx-cx)*q-(bx-ax)*r)/(2.*sign(max(abs(q-r),tiny),q-r))
     ulim=bx+glimit*(cx-bx)
     if ((bx-u)*(u-cx).gt.0.) then
        fu=my_func(u)
        if (press_error) return
        if (fu.lt.fc) then
           ax=bx
           fa=fb
           bx=u
           fb=fu
           goto 1
        elseif (fu.gt.fb) then
           cx=u
           fc=fu
           goto 1
        endif
        u=cx+gold*(cx-bx)
        fu=my_func(u)
        if (press_error) return
     elseif ((cx-u)*(u-ulim).gt.0.) then
        fu=my_func(u)
        if (press_error) return
        if (fu.lt.fc) then
           bx=cx
           cx=u
           u=cx+gold*(cx-bx)
           fb=fc
           fc=fu
           fu=my_func(u)
           if (press_error) return
        endif
     elseif ((u-ulim)*(ulim-cx).ge.0.) then
        u=ulim
        fu=my_func(u)
        if (press_error) return
     else
        u=cx+gold*(cx-bx)
        fu=my_func(u)
        if (press_error) return
     endif
     ax=bx
     bx=cx
     cx=u
     fa=fb
     fb=fc
     fc=fu
     goto 1
  endif
  return
end subroutine press_mnbrak
!
function press_f1dim(x)
  use press_f1com
  !---------------------------------------------------------------------
  ! @ private
  !---------------------------------------------------------------------
  real :: press_f1dim               !
  real :: x                         !
  ! Global
  real, external :: press_func
  ! Local
  integer :: j
  real :: xt(nmax)
  !
  do j=1,ncom
     xt(j)=pcom(j)+x*xicom(j)
  enddo
  press_f1dim = press_func(xt)
end function press_f1dim
