subroutine fit_message(fit,mseve,rname,message)
  use fit_minuit
  use gmath_dependencies_interfaces
  !---------------------------------------------------------------------
  ! @ private
  !  Print messages as usual, but they are owned by fit%owner, i.e.
  ! the message filter rules are those of the owner, not those of gmath
  ! ---
  !  Private to this file (i.e. to be used by MINUIT fitting routines
  ! only).
  !---------------------------------------------------------------------
  type(fit_minuit_t), intent(in) :: fit      !
  integer(kind=4),    intent(in) :: mseve    ! Message severity
  character(len=*),   intent(in) :: rname    ! Calling routine name
  character(len=*),   intent(in) :: message  !
  !
  ! if (fit%verbose) ... ???
  ! What about a "fit%rname" for a unique calling command name in messages?
  !
  call gmessage_write(fit%owner,mseve,rname,message)
  !
end subroutine fit_message
!
subroutine derive(fit,gg,gg2,fcn)
  use gmath_dependencies_interfaces
  use gmath_interfaces, except_this=>derive
  use fit_minuit
  !----------------------------------------------------------------------
  ! @ private
  ! Internal routine
  !      Calculates the first derivatives of FCN (GG),
  !      either by finite differences or by transforming the user-
  !      supplied derivatives to internal coordinates,
  !      according to whether ISW(3) is zero or one.
  !      if ISW(3) = 0, an error estimate GG2  is available
  !
  !      External routine FCN added to allow use of various
  !      minimization functions.
  !----------------------------------------------------------------------
  type(fit_minuit_t), intent(inout) :: fit        !
  real(kind=8),       intent(inout) :: gg(ntot)   ! First derivatives of function FCN
  real(kind=8),       intent(out)   :: gg2(nvar)  ! Error estimate for variables
  external                          :: fcn        ! Function to minimise
  ! Global
  include 'gbl_memory.inc'
  ! Local
  integer(kind=4) :: iflag,i,lc
  real(kind=8) :: eps,xtf,fs1,fs2,dd
  real(kind=8) :: gy(ntot)
  logical :: passdata
  integer(kind=address_length) :: ipnt
  !
  passdata = fit%data.ne.0
  if (passdata)  ipnt = gag_pointer(fit%data,memory)
  !
  if (fit%isw(3).ne.1) then
     iflag = 4
     do i=1,fit%npar
        eps = 0.1d0 * dabs(fit%dirin(i))
        if (fit%isw(2) .ge. 1) eps = eps + 0.005d0*dsqrt(fit%v(i,i)*fit%up)
        !
        if (eps.lt.theprec*dabs(fit%x(i)))  eps = theprec*fit%x(i)
        xtf = fit%x(i)
        fit%x(i) = xtf + eps
        call intoex(fit,fit%x)
        if (passdata) then
          call fcn(fit%npar,gy,fs1,fit%u ,iflag,memory(ipnt))
        else
          call fcn(fit%npar,gy,fs1,fit%u ,iflag)
        endif
        fit%nfcn=fit%nfcn+1
        fit%x(i) = xtf - eps
        call intoex(fit,fit%x)
        if (passdata) then
          call fcn(fit%npar,gy,fs2,fit%u,iflag,memory(ipnt))
        else
          call fcn(fit%npar,gy,fs2,fit%u,iflag)
        endif
        fit%nfcn=fit%nfcn+1
        ! First derivative
        gg(i)= (fs1-fs2)/(2.0d0*eps)
        ! Error on first derivative
        gg2(i)= (fs1+fs2-2.0d0*fit%amin)/(2.0d0*eps)
        fit%x(i) = xtf
     enddo
     call intoex(fit,fit%x)
  else
     !
     ! Derivatives calculated by FCN
     do i= 1, fit%nu
        lc=fit%lcorsp(i)
        if (lc.ge.1) then
           if (fit%lcode(i) .le. 1) then
              gg(lc)=gg(i)
           else
              dd = (fit%blim(i)-fit%alim(i))*0.5d0 *dcos(fit%x(lc))
              gg(lc)=gg(i)*dd
           endif
        endif
     enddo
  endif
end subroutine derive
!
subroutine extoin(fit,pint)
  use gmath_interfaces, except_this=>extoin
  use fit_minuit
  !----------------------------------------------------------------------
  ! @ public
  !      Transforms the external parameter values X  to internal
  !      values in the dense array PINT.   Function PINTF is used.
  !----------------------------------------------------------------------
  type(fit_minuit_t), intent(inout) :: fit      !
  real(kind=8),       intent(out)   :: pint(2)  ! Dense array
  ! Local
  integer(kind=4) ::  i,j
  !
  fit%limset=0
  do i= 1, fit%nu
     j = fit%lcorsp(i)
     if (j.gt.0) then
        pint(j) = pintf(fit,fit%u(i),i)
     endif
  enddo
end subroutine extoin
!
subroutine fixpar(fit,i2,kode,ilax)
  use gbl_message
  use gmath_interfaces, except_this=>fixpar
  use fit_minuit
  !----------------------------------------------------------------------
  ! @ private
  ! MINUIT      Internal routine
  !      Removes parameter I2 from the internal (variable) parameter
  !      list, and arranges the rest of the list to fill the hole.
  !      If KODE=0, I2 is an external number, otherwise internal.
  !      ILAX is returned as the external number of the parameter.
  !----------------------------------------------------------------------
  type(fit_minuit_t), intent(inout) :: fit   !
  integer(kind=4),    intent(in)    :: kode  ! Indicates Internal (1) or External (0)
  integer(kind=4),    intent(in)    :: i2    ! Internal or external parameter number
  integer(kind=4),    intent(out)   :: ilax  ! External number
  ! Local
  character(len=*), parameter :: rname='FIXPAR'
  integer(kind=4) :: lc,it,ik,iq,kon,kon2,i,j
  real(kind=8) :: eps,yy(nvar)
  ! real(kind=8) :: v1(2)
  ! equivalence (v(1,1) , v1(1))  ! Removed (see below)
  integer(kind=4) :: ion,jon
  character(len=message_length) :: mess
  !
  if (kode.ge.0) then
     if (kode.eq.0) then
        !
        ! External parameter number specified
        i = i2
        if (i .gt. fit%nu)  goto 70
        if (i .lt. 1)  goto 70
     elseif  (kode.gt.0) then
        !
        ! Internal parameter number specified
        i = 0
        do iq= 1, fit%nu
           if (fit%lcorsp(iq).eq.i2) then
              i = iq
           endif
        enddo
        if (i.eq.0) goto 70
     endif
     !
     if (fit%lcorsp(i).le.0) goto 70
     !
     lc = fit%lcorsp(i)
     it = lc
     fit%lcorsp(i) = 0
     ilax = i
     fit%npar = fit%npar - 1
     fit%npfix = fit%npfix + 1
     fit%ipfix(fit%npfix) = i
     fit%xs(fit%npfix) = fit%x(lc)
     fit%xts(fit%npfix) = fit%xt(lc)
     eps = dabs(fit%dirin(lc)) * 10.d0
     if (fit%isw(2).ge.1)  eps = eps + dsqrt(dabs(fit%v(lc,lc))*fit%up)
     if (eps .lt. 0.01*theprec*dabs(fit%x(lc)))  eps = theprec*fit%x(lc)
     fit%wts(fit%npfix) = eps*0.1d0
     do ik= i, fit%nu
        if (fit%lcorsp(ik).gt.0)  then
           lc = fit%lcorsp(ik) - 1
           fit%lcorsp(ik) = lc
           fit%x(lc) = fit%x(lc+1)
           fit%xt(lc) = fit%xt(lc+1)
           fit%dirin(lc) = fit%dirin(lc+1)
        endif
     enddo
     !
     if (fit%isw(2) .le. 1) then
        fit%isw(2) = 0
        return
     endif
  endif
  !
  ! Remove one row and one column from variance matrix
  kon = 0
  if (fit%npar.le.0) return
  kon2 = 0
  do i= 1, fit%npar+1
     yy(i)=fit%v(i,it)
  enddo
  !
  do i= 1, fit%npar+1
     if (i.ne.it) then
        kon2 = kon2 + 1
        do j= 1, fit%npar+1
           if (j.ne.it)  then
              kon = kon + 1
              ! Replace this code with Equivalence between v1(1) and v(1,1)
              !          v1(kon)=v(j,i) - yy(j)*yy(i)/yy(it)
              ! by true index computation
              ion = (kon-1) / nvar  + 1
              jon = kon - nvar*jon
              fit%v(jon,ion) = fit%v(j,i) - yy(j)*yy(i)/yy(it)
           endif
        enddo
        kon = fit%maxint*kon2
     endif
  enddo
  !
  ! Check for well-behaved final matrix
  do i= 1, fit%npar
     if (fit%v(i,i) .le. 0.d0) then
        fit%isw(2) = 0
        if (fit%verbose)  &
          call fit_message(fit,seve%e,rname,'Covariance matrix ill-conditioned, Destroyed')
        return
     endif
     do j= 1, fit%npar
        if (i .ne. j)  then
           if (fit%v(i,j)**2 .ge. fit%v(i,i)*fit%v(j,j))  fit%v(i,j) = 0.d0
        endif
     enddo
  enddo
  return
  !
  ! Error return:   parameter already fixed
70 ilax = 0
  if (fit%verbose)  then
    write(mess,'(A,I0,A)')  'Parameter ',i,' was not variable'
    call fit_message(fit,seve%e,rname,mess)
  endif
end subroutine fixpar
!
subroutine hesse(fit,fcn)
  use gbl_message
  use gmath_dependencies_interfaces
  use gmath_interfaces, except_this=>hesse
  use fit_minuit
  !----------------------------------------------------------------------
  ! @ public
  !      Calculates the full second-derivative matrix of FCN
  !      by taking finite differences.   Includes some safeguards
  !      against non-positive-definite matrices, and it may set
  !       off-diagonal elements to zero in attempt to force
  !      positiveness.
  !----------------------------------------------------------------------
  type(fit_minuit_t), intent(inout) :: fit  !
  external                          :: fcn  ! Function to minimise
  ! Global
  include 'gbl_memory.inc'
  ! Local
  character(len=*), parameter :: rname='HESSE'
  character(len=message_length) :: mess
  logical :: goon
  integer(kind=4) :: ifaut1,ifaut2,iflag,npfn,npard,mdiag,id,i,j,icyc
  integer(kind=4) :: ifail,ifix
  real(kind=8) :: d,xtf,fs1,fs2,df,chan,xti,xtj,elem,r
  real(kind=8) :: yy(nvar),gy(ntot)
  real(kind=8) :: dfwant,dfzero,dfmin,dfmax
  logical :: passdata
  integer(kind=address_length) :: ipnt
  ! Data
  data dfwant, dfzero,       dfmin,   dfmax  &
     / 0.01d0, 0.00000001d0, 0.001d0, 0.1d0 /
  !
  passdata = fit%data.ne.0
  if (passdata)  ipnt = gag_pointer(fit%data,memory)
  ifaut2=0
  ifaut1=0
  iflag = 4
  npfn = fit%nfcn
  npard = fit%npar
  !                                        . . . . . . DIAGONAL ELEMENTS .
  mdiag = 0
  do id= 1, npard
     i = id + fit%npar - npard
     d = 0.02d0* dabs(fit%dirin(i))
     if (fit%isw(2) .ge. 1)  d = 0.02d0* dsqrt(dabs(fit%v(i,i))*fit%up)
     if (d.lt.theprec*dabs(fit%x(i)))  d = theprec*dabs(fit%x(i))
     do j= 1, fit%npar
        fit%v(i,j) = 0.d0
     enddo
     icyc = 0
     !
     ! Loop here
     goon = .true.
     do while (goon)
        fit%dirin(i) = d
        xtf = fit%x(i)
        fit%x(i) = xtf + d
        call intoex(fit,fit%x)
        if (passdata) then
          call fcn(fit%npar, gy, fs1, fit%u, iflag, memory(ipnt))
        else
          call fcn(fit%npar, gy, fs1, fit%u, iflag)
        endif
        fit%nfcn = fit%nfcn + 1
        fit%x(i) = xtf - d
        call intoex(fit,fit%x)
        if (passdata) then
          call fcn (fit%npar, gy, fs2, fit%u, iflag, memory(ipnt))
        else
          call fcn (fit%npar, gy, fs2, fit%u, iflag)
        endif
        fit%nfcn = fit%nfcn + 1
        fit%x(i) = xtf
        !
        ! Check if step sizes appropriate
        icyc = icyc + 1
        if (icyc.lt.4) then
           df = dmax1(dabs(fs1-fit%amin),dabs(fs2-fit%amin))/fit%up
           if (df.gt.dfmin) then
              if (df.lt.dfmax) then
                 goon = .false.
              else
                 chan = dsqrt(dfwant/df)
                 if (chan .lt. 0.001d0)  chan = 0.001d0
                 d = d*chan
              endif
           else
              if (df.gt.dfzero) then
                 chan = dsqrt(dfwant/df)
                 if (chan .lt. 0.001d0)  chan = 0.001d0
                 d = d*chan
              else
                 d = d*1000.d0
              endif
           endif
        else
           goon = .false.
        endif
     enddo
     !
     ! Get first and second derivative
     fit%g(i) = (fs1-fs2)/(2.0d0 * d)
     fit%g2(i) = (fs1 + fs2 - 2.0d0*fit%amin) / d**2
     yy(i) = fs1
     if (dabs(fit%g(i))+dabs(fit%g2(i)).gt.1.0d-30) then
        if (fit%g2(i) .le. 1.0d-30) then
           mdiag = 1
           ! write (fit%isyswr,510)  i
           ifaut2=ifaut2+1
        endif
        fit%v(i,i) = fit%g2(i)
     else
        !
        ! Fix a parameter if  G = G2 = 0.0 .
        if (fit%itaur .ge. 1) then
           mdiag = 1
           ! write (fit%isyswr,510)  i
           ifaut2=ifaut2+1
           fit%v(i,i) = fit%g2(i)
        else
           fit%isw(2) = 0
           call fixpar(fit,i,1,ifix)
           if (fit%verbose) then
              write (mess,460) ifix,fit%g(i),fit%g2(i)
              call fit_message(fit,seve%i,rname,mess)
           endif
           if (fit%npar .eq. 0)  mdiag = 1
        endif
     endif
  enddo
  !
  call intoex(fit,fit%x)
  if (mdiag .eq. 1)  go to 390
  fit%isw(2) = 1
  !
  ! Off-diagonal elements
  do i= 1, fit%npar-1
     do j= i+1, fit%npar
        if (fit%nfcnmx-fit%nfcn+npfn .lt. fit%npar) then
           if (fit%verbose) then
              write (mess,490) i,j-1
              call fit_message(fit,seve%i,rname,mess)
           endif
        else
           xti = fit%x(i)
           xtj = fit%x(j)
           fit%x(i) = xti + fit%dirin(i)
           fit%x(j) = xtj + fit%dirin(j)
           call intoex(fit,fit%x)
           if (passdata) then
             call fcn(fit%npar, gy, fs1, fit%u, iflag, memory(ipnt))
           else
             call fcn(fit%npar, gy, fs1, fit%u, iflag)
           endif
           fit%nfcn = fit%nfcn + 1
           fit%x(i) = xti
           fit%x(j) = xtj
           elem = (fs1+fit%amin-yy(i)-yy(j)) / (fit%dirin(i)*fit%dirin(j))
           if (elem**2 .ge. fit%g2(i)*fit%g2(j)) then
              elem = 0.d0
              ! write (mess,470)  i,j
              ! call fit_message(fit,seve%i,rname,mess)
              ifaut1=ifaut1+1
           endif
           fit%v(i,j) = elem
           fit%v(j,i) = elem
        endif
     enddo
  enddo
  !
  call intoex(fit,fit%x)
  call vermin(fit,fit%v,fit%maxint,fit%maxint,fit%npar,ifail)
  if (ifail .lt. 1)  go to 222
  if (fit%verbose)  &
     call fit_message(fit,seve%w,rname,'HESSE Matrix inversion fails')
  !
  ! Diagonal matrix only
216 continue
  if (fit%verbose)  &
     call fit_message(fit,seve%w,rname,'Only diagonal matrix produced')
  fit%isw(2) = 1
  do i= 1, fit%npar
     do j= 1, fit%npar
        fit%v(i,j) = 0.d0
     enddo
     fit%v(i,i) = 1.0d0/fit%g2(i)
  enddo
  mdiag = 1                    ! Was zero before...
  go to 223
  !
222 continue
  if (fit%verbose)  &
     call fit_message(fit,seve%i,rname,'Second derivative matrix inverted')
  fit%isw(2) = 2
  !
  ! Calculate  Estimated Distance to Mimimum
223 continue
  do i= 1, fit%npar
     do j= 1, fit%npar
        fit%v(i,j) = 2.0d0 * fit%v(i,j)
     enddo
  enddo
  fit%sigma = 0.d0
  do i= 1, fit%npar
     if (fit%v(i,i) .le. 0.d0) then
        ! write (fit%isyswr,510)  i
        ifaut2=ifaut2+1
        mdiag = 1
     endif
     r = 0.d0
     do j= 1, fit%npar
        if (i.ne.j) then
           if (fit%v(i,j)**2 .ge. dabs(fit%v(i,i)*fit%v(j,j))) then
              ! write (fit%isyswr, 470)  i,j
              ifaut1=ifaut1+1
              fit%v(i,j) = 0.d0
              fit%v(j,i) = 0.d0
           endif
        endif
        r = r + fit%v(i,j) * fit%g(j)
     enddo
     fit%sigma = fit%sigma + 0.5d0 *r *fit%g(i)
  enddo
  if (mdiag .eq. 1)  go to 390
  if (fit%sigma .gt. 0.d0)  go to 400
  if (fit%verbose)  &
     call fit_message(fit,seve%i,rname,'Matrix not positive-definite')
  go to 216
  !
390 continue
  fit%isw(2) = 0
  !
400 continue
  if (fit%verbose) then
     if (ifaut1.ne.0) then
        write(mess,600) ifaut1
        call fit_message(fit,seve%w,rname,mess)
     endif
     if (ifaut2.ne.0) then
      write(mess,610) ifaut2
      call fit_message(fit,seve%w,rname,mess)
     endif
  endif
  !
  return
  !
460 format (1x,'HESSE Parameter',i3,' has been fixed. ', &
          'First derivative ',e11.3,' Second derivative ',e11.3)
! 470 format (1x,'HESSE Covariance matrix not positive-definite. ', &
!           'Faulty element in position',2i3)
490 format (1x,'HESSE Call limit. Off-diagonal elements calculated', &
          ' only up to ',2i3)
! 510 format (1x,'HESSE Diagonal element',i5,' is zero or negative')
600 format (1x,'HESSE Covariance matrix not positive-definite.',i4,  &
           ' Faulty elements')
610 format (1x,'HESSE',i4,' Non-positive diagonal elements ')
end subroutine hesse
!
subroutine intoex(fit,pint)
  use gmath_interfaces, except_this=>intoex
  use fit_minuit
  !----------------------------------------------------------------------
  ! @ public
  !      Transforms from internal coordinates (PINT) to external
  !      parameters (U).   The minimizing routines which work in
  !      internal coordinates call this routine before calling FCN.
  !----------------------------------------------------------------------
  type(fit_minuit_t), intent(inout) :: fit      !
  real(kind=8),       intent(in)    :: pint(2)  ! Dense array
  ! Local
  integer(kind=4) :: i,j
  real(kind=8) :: al
  !
  do i= 1, fit%nu
     j = fit%lcorsp(i)
     if (j.gt.0) then
        if (fit%lcode(i) .eq. 1)  then
           fit%u(i) = pint(j)
        else
           al = fit%alim(i)
           fit%u(i) = al + 0.5d0*(dsin(pint(j))+1.0d0) * (fit%blim(i)-al)
        endif
     endif
  enddo
end subroutine intoex
!
subroutine migrad(fit,fcn,ier)
  use gbl_message
  use gmath_dependencies_interfaces
  use gmath_interfaces, except_this=>migrad
  use fit_minuit
  !----------------------------------------------------------------------
  ! @ public
  !      Performs a local function minimization using basically the
  !      method of DAVIDON-FLETCHER-POWELL as modified by FLETCHER
  !      Ref. -- FLETCHER, COMP.J. 13,317 (1970)   "Switching method"
  !----------------------------------------------------------------------
  type(fit_minuit_t), intent(inout) :: fit  !
  external                          :: fcn  ! Function to minimise
  integer(kind=4),    intent(out)   :: ier  ! Error condition flag for HESSE
  ! Global
  include 'gbl_memory.inc'
  ! Local
  character(len=*), parameter :: rname='MIGRAD'
  character(len=message_length) :: mess
  integer(kind=4) :: ifaut1,iswtr,npfn,iflag,npard,i,ntry,negg2
  integer(kind=4) :: id,kg,nf,ns,j,iter,npargd,matgd
  real(kind=8) :: parn,rho2,rostop,trace,fs,d,xtf,fs1,fs2,xbeg,f
  real(kind=8) :: ri,gdel,denom,slam,f2,aa,bb,cc,tlam,f3,gvg,delgam,vgi
  real(kind=8) :: gami
  real(kind=8) :: gs(ntot) , r(nvar),xxs(nvar)
  real(kind=8) :: flnu(nvar), vg(nvar), vii(nvar)
  real(kind=8) :: slamin,slamax,tlamin,tlamax
  logical :: passdata
  integer(kind=address_length) :: ipnt
  ! Data
  data slamin,slamax,tlamin,tlamax/0.2d0, 3.0d0, 0.05d0, 6.0d0/
  !
  ier=0
  ifaut1=0
  if (fit%npar .le. 0)  return
  !
  passdata = fit%data.ne.0
  if (passdata)  ipnt = gag_pointer(fit%data,memory)
  iswtr = fit%isw(5) - fit%itaur
  npfn = fit%nfcn
  parn = fit%npar
  rho2 = 10.d0*fit%apsi
  rostop = sqrt(theprec) * fit%apsi
  trace=1.d0
  iflag=4
  if (fit%isw(3) .eq. 1)  iflag = 2
  fs = fit%amin
  go to 2
  !
  !   1 write (fit%isyswr,520)
1 ifaut1=ifaut1+1
  !
  ! Step sizes dirin
2 npard = fit%npar
  do i= 1, fit%npar
     d = 0.02d0* dabs(fit%dirin(i))
     if (fit%isw(2) .ge. 1)  d = 0.02d0 * dsqrt(dabs(fit%v(i,i))*fit%up)
     if (d.lt.theprec*dabs(fit%x(i)))  d = theprec*fit%x(i)
     fit%dirin(i) = d
  enddo
  !
  ! Starting gradient
  ntry = 0
4 negg2 = 0
  !      DO 10  ID= 1, NPARD
  do id=1, npard
     i = id + fit%npar - npard
     d = fit%dirin(i)
     xtf = fit%x(i)
     fit%x(i) = xtf + d
     call intoex(fit,fit%x)
     if (passdata) then
       call fcn(fit%npar,fit%g,fs1,fit%u,4,memory(ipnt))
     else
       call fcn(fit%npar,fit%g,fs1,fit%u,4)
     endif
     fit%nfcn = fit%nfcn + 1
     fit%x(i) = xtf - d
     call intoex(fit,fit%x)
     if (passdata) then
       call fcn(fit%npar,fit%g,fs2,fit%u,4,memory(ipnt))
     else
       call fcn(fit%npar,fit%g,fs2,fit%u,4)
     endif
     fit%nfcn = fit%nfcn + 1
     fit%x(i) = xtf
     gs(i) = (fs1-fs2)/(2.0d0 * d)
     fit%g2(i) = (fs1 + fs2 - 2.0d0*fit%amin) / d**2
     if (fit%g2(i) .gt. 1.0d-30)  go to 10
     !
     ! Search if G2 .LE. 0.
     !     write (fit%isyswr,520)
     ifaut1=ifaut1+1
     negg2 = negg2 + 1
     ntry = ntry + 1
     if (ntry .gt. 4)  go to 230
     d = 50.d0*dabs(fit%dirin(i))
     xbeg = xtf
     if (gs(i) .lt. 0.d0)  fit%dirin(i) = -fit%dirin(i)
     kg = 0
     nf = 0
     ns = 0
5    fit%x(i) = xtf + d
     call intoex(fit,fit%x)
     if (passdata) then
       call fcn(fit%npar,fit%g,f,fit%u,4,memory(ipnt))
     else
       call fcn(fit%npar,fit%g,f,fit%u,4)
     endif
     fit%nfcn = fit%nfcn + 1
     if (f .le. fit%amin)  go to 6
     !
     ! Failure
     if (kg .eq. 1)  go to 8
     kg = -1
     nf = nf + 1
     d = -0.4d0*d
     if (nf .lt. 10)  go to 5
     d = 1000.d0*d
     go to 7
     !
     ! Success
6    xtf = fit%x(i)
     d = 3.0d0*d
     fit%amin = f
     kg = 1
     ns = ns + 1
     if (ns .lt. 10)  go to 5
     if (fit%amin .lt. fs)  go to 8
     d = 0.001d0*d
7    xtf = xbeg
     fit%g2(i) = 1.0d0
     negg2 = negg2 - 1
8    fit%x(i) = xtf
     fit%dirin(i) = 0.1d0*d
     fs = fit%amin
10   continue
  enddo
  if (negg2 .ge. 1)  go to 4
  ntry = 0
  matgd = 1
  !
  ! Diagonal matrix
  if (fit%isw(2) .gt. 1)  go to 15
  !
11 ntry = 1
  matgd = 0
  do i= 1, fit%npar
     do j= 1, fit%npar
        fit%v(i,j) = 0.d0
     enddo
     fit%v(i,i) = 2.0d0/fit%g2(i)
  enddo
  !
  ! Get sigma and set up loop
15 fit%sigma = 0.d0
  do i= 1, fit%npar
     if (fit%v(i,i) .le. 0.d0)  go to 11
     ri = 0.d0
     do j= 1, fit%npar
        xxs(i) = fit%x(i)
        ri= ri+ fit%v(i,j) * gs(j)
     enddo
     fit%sigma = fit%sigma + gs(i) *ri *0.5d0
  enddo
  if (fit%sigma .ge. 0.d0)  go to 20
  !     write (fit%isyswr,520)
  ifaut1=ifaut1+1
  if (ntry.eq.0)  go to 11
  fit%isw(2) = 0
  go to 230
  !
20 fit%isw(2) = 1
  iter = 0
  call intoex(fit,fit%x)
  !
  ! Start main loop
24 continue
  gdel = 0.d0
  do i=1,fit%npar
     ri = 0.d0
     do j=1,fit%npar
        ri = ri + fit%v(i,j) *gs(j)
     enddo
     fit%dirin(i) = -0.5d0*ri
     gdel = gdel + fit%dirin(i)*gs(i)
     !
     ! Linear search along -VG
     fit%x(i) =xxs(i) + fit%dirin(i)
  enddo
  call intoex(fit,fit%x)
  if (passdata) then
    call fcn (fit%npar, fit%g, f, fit%u, 4, memory(ipnt))
  else
    call fcn (fit%npar, fit%g, f, fit%u, 4)
  endif
  fit%nfcn=fit%nfcn+1
  !
  ! Quadrupole interpolation using slope GDEL
  denom = 2.0d0*(f-fit%amin-gdel)
  if (denom .le. 0.d0) then
     slam = slamax
  else
     slam = -gdel/denom
     if (slam .gt. slamax) then
        slam = slamax
     elseif  (slam.lt.slamin) then
        slam = slamin
     endif
  endif
  if (dabs(slam-1.0d0) .lt. 0.1d0)  go to 70
  !
  do i= 1, fit%npar
     fit%x(i) = xxs(i) + slam*fit%dirin(i)
  enddo
  call intoex(fit,fit%x)
  if (passdata) then
    call fcn(fit%npar,fit%g,f2,fit%u,4,memory(ipnt))
  else
    call fcn(fit%npar,fit%g,f2,fit%u,4)
  endif
  fit%nfcn = fit%nfcn + 1
  !
  ! Quadrupole interpolation using 3 points
  aa = fs/slam
  bb = f/(1.0d0-slam)
  cc = f2/ (slam*(slam-1.0d0))
  denom = 2.0d0*(aa+bb+cc)
  if (denom .le. 0.d0) then
     tlam = tlamax
  else
     tlam = (aa*(slam+1.0d0) + bb*slam + cc)/denom
     if (tlam .gt. tlamax) then
        tlam = tlamax
     elseif  (tlam.lt.tlamin) then
        tlam = tlamin
     endif
  endif
  !
  !!50    CONTINUE
  do i= 1, fit%npar
     fit%x(i) = xxs(i)+tlam*fit%dirin(i)
  enddo
  call intoex(fit,fit%x)
  if (passdata) then
    call fcn(fit%npar,fit%g,f3,fit%u,4,memory(ipnt))
  else
    call fcn(fit%npar,fit%g,f3,fit%u,4)
  endif
  fit%nfcn = fit%nfcn + 1
  if (f.ge.fit%amin .and. f2.ge.fit%amin .and. f3.ge.fit%amin) go to 200
  !
  if (f.lt.f2 .and. f.lt.f3) then
     slam = 1.0d0
  elseif  (f.lt.f3) then
     f = f2
  else
     f = f3
     slam = tlam
  endif
  !
  do i= 1, fit%npar
     fit%dirin(i) = fit%dirin(i)*slam
     fit%x(i) = xxs(i) + fit%dirin(i)
  enddo
  !
70 fit%amin = f
  fit%isw(2) = 2
  if (fit%sigma+fs-fit%amin .lt. rostop)  go to 170
  if (fit%sigma+rho2+fs-fit%amin .gt. fit%apsi)  go to 75
  if (trace .lt. fit%vtest)  go to 170
75 continue
  if (fit%nfcn-npfn .ge. fit%nfcnmx)  go to 190
  iter = iter + 1
  !
  ! Get gradient and sigma
  if (fit%isw(3).eq.1) then
     call intoex(fit,fit%x)
     if (passdata) then
       call fcn(fit%npar,fit%g,fit%amin,fit%u,iflag,memory(ipnt))
     else
       call fcn(fit%npar,fit%g,fit%amin,fit%u,iflag)
     endif
     fit%nfcn = fit%nfcn + 1
  endif
  !
  call derive(fit,fit%g,fit%g2,fcn)
  rho2 = fit%sigma
  fit%sigma = 0.d0
  gvg = 0.d0
  delgam = 0.d0
  do i= 1, fit%npar
     ri = 0.d0
     vgi = 0.d0
     do j= 1, fit%npar
        vgi = vgi + fit%v(i,j)*(fit%g(j)-gs(j))
        ri = ri + fit%v(i,j) *fit%g (j)
     enddo
     r(i) = ri * 0.5d0
     vg(i) = vgi*0.5d0
     gami = fit%g(i) - gs(i)
     gvg = gvg + gami*vg(i)
     delgam = delgam + fit%dirin(i)*gami
     fit%sigma = fit%sigma + fit%g(i)*r(i)
  enddo
  if (fit%sigma .lt. 0.d0)  go to 1
  if (gvg .le. 0.d0)  go to 105
  if (delgam .le. 0.d0)  go to 105
  go to 107
105 if (fit%sigma .lt. 0.1d0*rostop)  go to 170
  go to 1
107 continue
  !
  ! Update covariance matrix
  trace=0.d0
  do i= 1, fit%npar
     vii(i) = fit%v(i,i)
     do j=1,fit%npar
        d = fit%dirin(i)*fit%dirin(j)/delgam - vg(i)*vg(j)/gvg
        fit%v(i,j) = fit%v(i,j) + 2.0d0*d
     enddo
  enddo
  if (delgam .gt. gvg) then
     do i= 1, fit%npar
        flnu(i) = fit%dirin(i)/delgam - vg(i)/gvg
     enddo
     do i= 1, fit%npar
        do j= 1, fit%npar
           fit%v(i,j) = fit%v(i,j) + 2.0d0*gvg*flnu(i)*flnu(j)
        enddo
     enddo
  endif
  do i= 1, fit%npar
     trace = trace + ((fit%v(i,i)-vii(i))/(fit%v(i,i)+vii(i)))**2
  enddo
  trace = dsqrt(trace/parn)
  xxs(1:fit%npar) = fit%x(1:fit%npar)
  gs(1:fit%npar)  = fit%g(1:fit%npar)
  fs = f
  go to 24
  !
  ! End main loop
170 continue
  if (fit%verbose)  &
     call fit_message(fit,seve%i,rname,'Minimization has converged')
  fit%isw(2) = 3
  iswtr = iswtr - 3*fit%itaur
  if (fit%itaur .gt. 0)  go to 435
  if (matgd .gt. 0)  go to 435
  npargd = fit%npar*(fit%npar+5)/2
  if (fit%nfcn-npfn .ge. npargd)  go to 435
  !
  if (fit%verbose)  &
     call fit_message(fit,seve%i,rname,  &
     'Covariance matrix inaccurate. HESSE will recalculate')
  !
  ! CALL HESSE fait par FITGAU si IER = 1
  if (fit%isw(2).ge.2)  fit%isw(2) = 3
  ier = 1
  go to 435
190 fit%isw(1) = 1
  go to 230
  !
200 continue
  if (fit%verbose)  &
     call fit_message(fit,seve%w,rname,'Fails to find improvement')
  fit%x(1:fit%npar) = xxs(1:fit%npar)
  fit%isw(2) = 1
  if (fit%sigma .lt. rostop)  go to 170
  if (matgd .gt. 0)  go to 2
  !
230 continue
  if (fit%verbose)  &
     call fit_message(fit,seve%i,rname,'Terminated without convergence')
  call intoex(fit,fit%x)
  iswtr = fit%isw(5) - fit%itaur*3
  ier = 3
  !
435 continue
  if (fit%verbose) then
     if (ifaut1.ne.0) then
        write(mess,700) ifaut1
        call fit_message(fit,seve%w,rname,mess)
     endif
  endif
  return
  !
700 format (1x,'MIGRAD Covariance matrix is not positive-definite ('  &
           ,i3,') times.')
end subroutine migrad
!
function pintf(fit,pexti,i)
  use gbl_message
  use gmath_interfaces, except_this=>pintf
  use fit_minuit
  !----------------------------------------------------------------------
  ! @ public
  !      Calculates the internal parameter value PINTF corresponding
  !      to the external value PEXTI for parameter I.
  !----------------------------------------------------------------------
  real(kind=8) :: pintf  ! Function value on return
  type(fit_minuit_t), intent(inout) :: fit    !
  real(kind=8),       intent(inout) :: pexti  ! External value
  integer(kind=4),    intent(in)    :: i      ! Parameter number
  ! Local
  character(len=*), parameter :: rname='PINTF'
  integer(kind=4) :: igo
  real(kind=8) :: yy,alimi,blimi,a
  character(len=message_length) :: mess
  real(kind=8) :: big, small
  ! Data
  data big,small/ 1.570796326794897d0, -1.570796326794897d0/
  !
  igo = fit%lcode(i)
  !
  ! IGO = 1  means no limits
  if (igo.le.1) then
     pintf = pexti
  else
     !
     ! Others mean some limits
     alimi = fit%alim(i)
     blimi = fit%blim(i)
     if (pexti.lt.alimi) then
        a = small
     elseif  (pexti.eq.alimi) then
        pintf = small
        return
     elseif  (pexti.gt.blimi) then
        a = big
     elseif  (pexti.eq.blimi) then
        pintf = big
        return
     else
        yy=2.0d0*(pexti-alimi)/(blimi-alimi) - 1.0d0
        pintf = datan(yy/dsqrt(1.d0- yy**2) )
        return
     endif
     pintf = a
     pexti = alimi + 0.5d0* (blimi-alimi) *(dsin(a) +1.0d0)
     fit%limset=1
     if (fit%verbose) then
       write(mess,'(A,I0,A)') 'Variable ',i,' has been brought back inside limits'
       call fit_message(fit,seve%w,rname,mess)
     endif
  endif
  !
end function pintf
!
subroutine razzia(fit,ynew,pnew,ier)
  use gbl_message
  use gmath_interfaces, except_this=>razzia
  use fit_minuit
  !----------------------------------------------------------------------
  ! @ private
  ! MINUIT      Internal routine
  !      Called only by SIMPLEX (and IMPROV) to add a new point
  !      and remove an old one from the current simplex, and get the
  !      estimated distance to minimum.
  !----------------------------------------------------------------------
  type(fit_minuit_t), intent(inout) :: fit         !
  real(kind=8),       intent(in)    :: ynew        !
  real(kind=8),       intent(in)    :: pnew(nvar)  !
  integer(kind=4),    intent(out)   :: ier         !
  ! Local
  character(len=*), parameter :: rname='RAZZIA'
  integer(kind=4) :: i,j
  real(kind=8) :: us,pbig,plit
  character(len=message_length) :: mess
  !
  do i=1,fit%npar
     fit%p(i,fit%jh)=pnew(i)
  enddo
  fit%y(fit%jh)=ynew
  !
  if (ynew.lt.fit%amin) then
     do i=1,fit%npar
        fit%x(i)=pnew(i)
     enddo
     call intoex(fit,fit%x)
     fit%amin=ynew
     fit%jl=fit%jh
  endif
  !
  fit%jh=1
  do j=2,fit%npar+1
     if (fit%y(j) .gt. fit%y(fit%jh))  fit%jh = j
  enddo
  !
  fit%sigma = fit%y(fit%jh) - fit%y(fit%jl)
  if (fit%sigma .le. 0.d0)  then
     write (mess,'(A,I0,A)') 'Function value does not seem to depend on any of the ',  &
       fit%npar,' variable parameters'
     call fit_message(fit,seve%w,rname,mess)
     call fit_message(fit,seve%w,rname,'Check input parameters and try again')
     ier = 4
  else
     us = 1.0d0/fit%sigma
     do i = 1, fit%npar
        pbig = fit%p(i,1)
        plit = pbig
        do j= 2, fit%npar+1
           if (fit%p(i,j) .gt. pbig)  pbig = fit%p(i,j)
           if (fit%p(i,j) .lt. plit)  plit = fit%p(i,j)
        enddo
        fit%dirin(i) = pbig - plit
        if (fit%itaur .lt. 1 )  fit%v(i,i) = 0.5d0*(fit%v(i,i) +us*fit%dirin(i)**2)
     enddo
  endif
  !
end subroutine razzia
!
subroutine restor(fit,k)
  use gbl_message
  use gmath_interfaces, except_this=>restor
  use fit_minuit
  !----------------------------------------------------------------------
  ! @ private
  ! MINUIT      Internal routine
  !      Restores a fixed parameter to variable status
  !      by inserting it into the internal parameter list at the
  !      appropriate place.
  !
  !       K = 0 means restore all parameters
  !       K = 1 means restore the last parameter fixed
  !       K = -I means restore external parameter I (if possible)
  !       IQ = fix-location where internal parameters were stored
  !       IR = external number of parameter being restored
  !       IS = internal number of parameter being restored
  !----------------------------------------------------------------------
  type(fit_minuit_t), intent(inout) :: fit  !
  integer(kind=4),    intent(in)    :: k    ! Code for operation
  ! Local
  character(len=*), parameter :: rname='RESTORE'
  integer(kind=4) :: ka,ik,ipsav,i,ir,is,ij,lc,iq
  real(kind=8) :: xssav,xtssav,wtssav
  logical :: goon
  character(len=message_length) :: mess
  !
  if (fit%npfix.lt.1 .and. fit%verbose)  &
    call fit_message(fit,seve%i,rname,'There are no more fixed parameters')
  !
  ! Not the last one in list
  if (k.gt.1) then
     !
     ! Release parameter with specified external number
     ka = iabs(k)
     if (fit%lcorsp(ka) .ne. 0) return  ! not fixed
     ik = 0
     do i = 1, fit%npfix
        if (fit%ipfix(i) .eq. ka)  ik = i
     enddo
     if (ik.eq.0) then
        if (fit%verbose)  &
          call fit_message(fit,seve%i,rname,'Parameter specified has never been variable')
        return
     endif
     !
     ! Not the last one in list ?
     if (ik.ne.fit%npfix) then
        !
        ! Move specified parameter to end of list
        ipsav = fit%ipfix(ik)
        xssav = fit%xs(ik)
        xtssav = fit%xts(ik)
        wtssav = fit%wts(ik)
        do i= ik+1,fit%npfix
           fit%ipfix(i-1) = fit%ipfix(i)
           fit%xs(i-1) = fit%xs(i)
           fit%xts(i-1) = fit%xts(i)
           fit%wts(i-1) = fit%wts(i)
        enddo
        fit%ipfix(fit%npfix) = ipsav
        fit%xs(fit%npfix) = xssav
        fit%xts(fit%npfix) = xtssav
        fit%wts(fit%npfix) = wtssav
     endif
  endif
  !
  ! Restore last parameter in list  -- IPFIX(NPFIX)
  goon = fit%npfix.ge.1
  do while (goon)
     ir = fit%ipfix(fit%npfix)
     is = 0
     do ij= ir, fit%nu
        ik = fit%nu + ir - ij
        if (fit%lcorsp(ik).gt.0) then
           lc = fit%lcorsp(ik) + 1
           is = lc - 1
           fit%lcorsp(ik) = lc
           fit%x(lc) = fit%x(lc-1)
           fit%xt(lc) = fit%xt(lc-1)
           fit%dirin(lc) = fit%dirin(lc-1)
        endif
     enddo
     !
     fit%npar = fit%npar + 1
     if (is .eq. 0)   is = fit%npar
     fit%lcorsp(ir) = is
     iq = fit%npfix
     fit%x(is) = fit%xs(iq)
     fit%xt(is) = fit%xts(iq)
     fit%dirin(is) = fit%wts(iq)
     fit%npfix = fit%npfix - 1
     fit%isw(2) = 0
     if (fit%itaur.lt.1 .and. fit%verbose) then
       write(mess,'(A,I0,A)')  'Parameter ',ir,' restored to variable'
       call fit_message(fit,seve%i,rname,mess)
     endif
     !
     if (k.ne.0) goon = .false.
     if (fit%npfix.lt.1) goon = .false.
  enddo
  !
end subroutine restor
!
subroutine simplx(fit,fcn,ier)
  use gbl_message
  use gmath_dependencies_interfaces
  use gmath_interfaces, except_this=>simplx
  use fit_minuit
  !----------------------------------------------------------------------
  ! @ public
  !      Performs a minimization using the SIMPLEX method of NELDER
  !      and MEAD (REF. -- COMP. J. 7,308 (1965)).
  !----------------------------------------------------------------------
  type(fit_minuit_t), intent(inout) :: fit  !
  external                          :: fcn  ! Function to minimize
  integer(kind=4),    intent(out)   :: ier  ! Error condition flag
  ! Global
  include 'gbl_memory.inc'
  ! Local
  character(len=*), parameter :: rname='SIMPLX'
  integer(kind=4) :: npfn,nparp1,iflag,i,j,k,kg,ns,nf,ignal,ncycl,jhold
  real(kind=8) :: rho1,rho2,wg,ynpp1,absmin,aming,bestx,sig2,pb
  real(kind=8) :: ystar,ystst,y1,y2,rho,yrho,ypbar,f
  real(kind=8) :: alpha, beta, gamma, rhomin, rhomax
  logical :: passdata
  integer(kind=address_length) :: ipnt
  ! Data
  data  alpha, beta,  gamma, rhomin, rhomax  &
      / 1.0d0, 0.5d0, 2.0d0, 4.0d0,  8.0d0 /
  !
  ier=0
  if (fit%npar .le. 0)  return
  !
  passdata = fit%data.ne.0
  if (passdata)  ipnt = gag_pointer(fit%data,memory)
  npfn = fit%nfcn
  nparp1=fit%npar+1
  rho1 = 1.0d0 + alpha
  rho2 = rho1 + alpha*gamma
  wg = 1.0d0/dble(fit%npar)
  iflag=4
  do i= 1, fit%npar
     if (fit%isw(2).ge.1)  fit%dirin(i) = dsqrt(fit%v(i,i)*fit%up)
     if (dabs(fit%dirin(i)) .lt. 0.01*theprec*dabs(fit%x(i)))  &
          &   fit%dirin(i)=theprec*fit%x(i)
     if (fit%itaur.lt.1)  fit%v(i,i) =    fit%dirin(i)**2/fit%up
  enddo
  if (fit%itaur.lt.1)  fit%isw(2) = 1
  !
  ! Choose the initial Simplex using single-parameter searches
1 continue
  ynpp1 = fit%amin
  fit%jl = nparp1
  fit%y(nparp1) = fit%amin
  absmin = fit%amin
  do i= 1, fit%npar
     aming = fit%amin
     fit%pbar(i) = fit%x(i)
     bestx = fit%x(i)
     kg = 0
     ns = 0
     nf = 0
4    fit%x(i) = bestx + fit%dirin(i)
     call intoex(fit,fit%x)
     if (passdata) then
       call fcn(fit%npar,fit%g, f, fit%u, 4, memory(ipnt))
     else
       call fcn(fit%npar,fit%g, f, fit%u, 4)
     endif
     fit%nfcn = fit%nfcn + 1
     if (f .le. aming)  go to 6
     !
     ! Failure
     if (kg .eq. 1)  go to 8
     kg = -1
     nf = nf + 1
     fit%dirin(i) = fit%dirin(i) * (-0.4d0)
     if (nf .lt. 3)  go to 4
     ns = 6
     !
     ! Success
6    bestx = fit%x(i)
     fit%dirin(i) = fit%dirin(i) * 3.0d0
     aming = f
     kg = 1
     ns = ns + 1
     if (ns .lt. 6)  go to 4
     !
     ! Local minimum found in Ith direction
8    fit%y(i) = aming
     if (aming .lt. absmin)  fit%jl = i
     if (aming .lt. absmin)  absmin = aming
     fit%x(i) = bestx
     do k= 1, fit%npar
        fit%p(k,i) = fit%x(k)
     enddo
  enddo
  fit%jh = nparp1
  fit%amin=fit%y(fit%jl)
  call razzia(fit,ynpp1,fit%pbar,ier)
  !
  ! Error Patch in Case of bad behaved Function
  if (ier.ne.0) return
  do i= 1, fit%npar
     fit%x(i) = fit%p(i,fit%jl)
  enddo
  call intoex(fit,fit%x)
  fit%sigma = fit%sigma * 10.d0
  sig2 = fit%sigma
  ignal = 0
  ncycl=0
  !
  ! Start main loop
50 continue
  if (ignal .ge. 10)  go to 1
  if (sig2 .lt. fit%epsi .and. fit%sigma.lt.fit%epsi)     go to 76
  sig2 = fit%sigma
  if ((fit%nfcn-npfn) .gt. fit%nfcnmx)  go to 78
  !
  ! Calculate new point * by reflection
  do i= 1, fit%npar
     pb = 0.d0
     do j= 1, nparp1
        pb = pb + wg * fit%p(i,j)
     enddo
     fit%pbar(i) = pb - wg * fit%p(i,fit%jh)
     fit%pstar(i)=(1.d0+alpha)*fit%pbar(i)-alpha*fit%p(i,fit%jh)
  enddo
  call intoex(fit,fit%pstar)
  if (passdata) then
    call fcn(fit%npar,fit%g,ystar,fit%u,4,memory(ipnt))
  else
    call fcn(fit%npar,fit%g,ystar,fit%u,4)
  endif
  fit%nfcn=fit%nfcn+1
  if (ystar.ge.fit%amin) go to 70
  !
  ! Point * better than JL, calculate new point **
  do i=1,fit%npar
     fit%pstst(i)=gamma*fit%pstar(i)+(1.d0-gamma)*fit%pbar(i)
  enddo
  call intoex(fit,fit%pstst)
  if (passdata) then
    call fcn(fit%npar,fit%g,ystst,fit%u,4,memory(ipnt))
  else
    call fcn(fit%npar,fit%g,ystst,fit%u,4)
  endif
  fit%nfcn=fit%nfcn+1
  !
  ! Try a parabola through PH, PSTAR, PSTST.  min = PRHO
  y1 = (ystar-fit%y(fit%jh)) * rho2
  y2 = (ystst-fit%y(fit%jh)) * rho1
  rho = 0.5d0 * (rho2*y1 -rho1*y2) / (y1 -y2)
  if (rho .lt. rhomin)  go to 66
  if (rho .gt. rhomax)  rho = rhomax
  do i= 1, fit%npar
     fit%prho(i) = rho*fit%pstar(i) + (1.d0 -rho)*fit%p(i,fit%jh)
  enddo
  call intoex(fit,fit%prho)
  if (passdata) then
    call fcn(fit%npar, fit%g, yrho, fit%u, 4, memory(ipnt))
  else
    call fcn(fit%npar, fit%g, yrho, fit%u, 4)
  endif
  fit%nfcn = fit%nfcn + 1
  if (yrho .lt. fit%y(fit%jl) .and. yrho .lt. ystst)  go to 65
  if (ystst .lt. fit%y(fit%jl))  go to 67
  if (yrho .gt. fit%y(fit%jl))  go to 66
  !
  ! Accept minimum point of parabola, PRHO
65 call razzia(fit,yrho,fit%prho,ier)
  !
  ! Error Patch in Case of bad behaved Function
  if (ier.ne.0) return
  ignal = max(ignal-2, 0)
  go to 68
66 if (ystst .lt. fit%y(fit%jl))  go to 67
  ignal = max(ignal-1, 0)
  call razzia(fit,ystar,fit%pstar,ier)
  !
  ! Error Patch in Case of bad behaved Function
  if (ier.ne.0) return
  go to 68
67 ignal = max(ignal-2, 0)
675 call razzia(fit,ystst,fit%pstst,ier)
  !
  ! Error Patch in Case of bad behaved Function
  if (ier.ne.0) return
68 ncycl=ncycl+1
  go to 50
  !
  ! Point * is not as good as JL
70 if (ystar .ge. fit%y(fit%jh))  go to 73
  jhold = fit%jh
  call razzia(fit,ystar,fit%pstar,ier)
  !
  ! Error Patch in Case of bad behaved Function
  if (ier.ne.0) return
  if (jhold .ne. fit%jh)  go to 50
  !
  ! Calculate new point **
73 continue
  do i=1,fit%npar
     fit%pstst(i)=beta*fit%p(i,fit%jh)+(1.d0-beta)*fit%pbar(i)
  enddo
  call intoex(fit,fit%pstst)
  if (passdata) then
    call fcn(fit%npar,fit%g,ystst,fit%u,4,memory(ipnt))
  else
    call fcn(fit%npar,fit%g,ystst,fit%u,4)
  endif
  fit%nfcn=fit%nfcn+1
  if (ystst.gt.fit%y(fit%jh)) go to 1
  !
  ! Point ** is better than JH
  if (ystst .lt. fit%amin)  go to 675
  ignal = ignal + 1
  call razzia(fit,ystst,fit%pstst,ier)
  !
  ! Error Patch in Case of bad behaved Function
  if (ier.ne.0) return
  go to 50
  !
  ! End main loop
76 continue
  if (fit%verbose)  &
     call fit_message(fit,seve%i,rname,'Minimization has converged')
  go to 80
  !
78 continue
  if (fit%verbose)  &
     call fit_message(fit,seve%i,rname,'Terminates without convergence')
  fit%isw(1) = 1
  !
80 continue
  do i=1,fit%npar
     pb = 0.d0
     do j=1,nparp1
        pb = pb + wg * fit%p(i,j)
     enddo
     fit%pbar(i) = pb - wg * fit%p(i,fit%jh)
  enddo
  call intoex(fit,fit%pbar)
  if (passdata) then
    call fcn(fit%npar,fit%g,ypbar,fit%u,iflag,memory(ipnt))
  else
    call fcn(fit%npar,fit%g,ypbar,fit%u,iflag)
  endif
  fit%nfcn=fit%nfcn+1
  if (ypbar .lt. fit%amin)  call razzia(fit,ypbar,fit%pbar,ier)
  !
  ! Error Patch in Case of bad behaved Function
  if (ier.ne.0) return
  call intoex(fit,fit%x)
  if (fit%nfcnmx+npfn-fit%nfcn .lt. 3*fit%npar)  return
  if (fit%sigma .gt. 2.0d0*fit%epsi)  go to 1
  !
end subroutine simplx
!
subroutine vermin(fit,a,l,m,n,ifail)
  use gmath_interfaces, except_this=>vermin
  use fit_minuit
  !----------------------------------------------------------------------
  ! @ private
  ! MINUIT      Internal routine
  !      Inverts a symmetric matrix.   Matrix is first scaled to
  !      have all ones on the diagonal (equivalent to change of units)
  !      but no pivoting is done since matrix is positive-definite.
  !----------------------------------------------------------------------
  type(fit_minuit_t), intent(in)    :: fit     !
  integer(kind=4),    intent(in)    :: l       ! 1st dim of matrix A
  integer(kind=4),    intent(in)    :: m       ! 2nd dim of matrix A
  integer(kind=4),    intent(in)    :: n       !
  real(kind=8),       intent(inout) :: a(l,m)  ! Matrix to be inverted
  integer(kind=4),    intent(out)   :: ifail   ! Error code
  ! Local
  integer(kind=4) :: i,j,k
  real(kind=8) :: si,s(nvar),q(nvar),pp(nvar)
  !
  ifail=1
  if (n.lt.1 .or. n.gt.fit%maxint) return
  !
  ! Scale matrix by sqrt of diagonal elements
  do i=1,n
     si = a(i,i)
     if (si.le.0d0) return
     s(i) = 1.0d0/dsqrt(si)
  enddo
  ifail=0
  !
  do i= 1, n
     do j= 1, n
        a(i,j) = a(i,j) *s(i)*s(j)
     enddo
  enddo
  !
  ! Start main loop
  do i=1,n
     k = i
     !
     ! Preparation for elimination step1
     q(k) = 1.d0/a(k,k)
     pp(k)= 1.0d0
     a(k,k)=0.0d0
     do j=1,k-1
        pp(j)=a(j,k)
        q(j)=a(j,k)*q(k)
        a(j,k)=0.d0
     enddo
     do j=k+1,n
        pp(j)=a(k,j)
        q(j)=-a(k,j)*q(k)
        a(k,j)=0.0d0
     enddo
     !
     ! Elimination proper
     do j=1,n
        do k=j,n
           a(j,k)=a(j,k)+pp(j)*q(k)
        enddo
     enddo
  enddo
  !
  ! Elements of left diagonal and unscaling
  do j= 1, n
     do k= 1, j
        a(k,j) = a(k,j) *s(k)*s(j)
        a(j,k) = a(k,j)
     enddo
  enddo
end subroutine vermin
