      subroutine m1qn3 (simul,prosca,ctonb,ctcab,n,x,f,g,dxmin,df1,
     /                  epsg,impres,io,mode,niter,nsim,iz,m,mmemo,
     /                  rzdiag, ybar,sbar)
c----
c
c     M1QN3, Version 2.0b, December 1993
c     Jean Charles Gilbert, Claude Lemarechal, INRIA.
c
c     M1qn3 has two running modes: the SID (Scalar Initial Scaling) mode
c     and the DIS (Diagonal Initial Scaling) mode. Both do not require
c     the same amount of storage, the same subroutines, ...
c     In the description below, items that differ in the DIS mode with
c     respect to the SIS mode are given in brakets.
c
c     Use the following subroutines:
c         M1QN3A
c         DD, DDS
c         MLIS0 + ECUBE (Dec 88)
c         MUPDTS, YSTBL.
c
c     The following routines are proposed to the user in case the
c     Euclidean scalar product is used:
c         EUCLID, CTONBE, CTCABE.
c
c     La sous-routine M1QN3 est une interface entre le programme
c     appelant et la sous-routine M1QN3A, le minimiseur proprement dit.
c
c     Le module PROSCA est sense realiser le produit scalaire de deux
c     vecteurs de Rn; le module CTONB est sense realiser le changement
c     de coordonnees correspondant au changement de bases: base
c     euclidienne -> base orthonormale (pour le produit scalaire
c     PROSCA); le module CTBAB fait la transformation inverse: base
c     orthonormale -> base euclidienne.
c
c     Iz is an integer working zone for M1QN3A, its dimension is 5.
c     It is formed of 5 scalars that are set by the optimizer:
c         - the dimension of the problem,
c         - a identifier of the scaling mode,
c         - the number of updates,
c         - two pointers.
c
c     Rz est la zone de travail pour M1QN3A, de dimension nrz.
c     Elle est subdivisee en
c         3 [ou 4] vecteurs de dimension n: d,gg,[diag,]aux
c         m scalaires: alpha
c         m vecteurs de dimension n: ybar
c         m vecteurs de dimension n: sbar
c
c     m est alors le plus grand entier tel que
c         m*(2*n+1)+3*n .le. nrz [m*(2*n+1)+4*n .le. nrz)]
c     soit m := (nrz-3*n) / (2*n+1) [m := (nrz-4*n) / (2*n+1)].
c     Il faut avoir m >= 1, donc nrz >= 5n+1 [nrz >= 6n+1].
c
c     A chaque iteration la metrique est formee a partir d'un multiple
c     de l'identite [d'une matrice diagonale] D qui est mise a jour m
c     fois par la formule de BFGS en utilisant les m couples {y,s} les
c     plus recents.
c
c    Modifications:
c    --------------
c
c       2001-07-27: M. Fisher - {y,s} pairs are now held with respect to
c                               the Euclidean inner product. This greatly
c                               reduces the number of calls to prosca.
c                               NB: if you manipulate {y,s} outside of
c                               m1qn3, consider uncommenting the (untested)
c                               code before and after the call to m1qn3a.
c                               
c
c----
      use control_vectors
      implicit none
c
c         arguments
c
      integer n,impres,io,mode,niter,nsim,iz(5),m,mmemo       
      real f,dxmin,df1,epsg       
      external simul,prosca,ctonb,ctcab
      type (control_vector) :: x,g
      type (control_vector),dimension(mmemo) :: ybar,sbar
      type (control_vector) :: rzdiag
c
c         variables locales
c
      type (control_vector) :: rzd,rzgg,rzaux
      real alpha(m)
      logical inmemo
      logical sscale
      integer id,igg,idiag,iaux,ialpha,iybar,isbar,j,jfin
      real r1,r2
      real ps
c
c---- impressions initiales et controle des arguments
c
      if (impres.ge.1)
     /    write (io,900) n,m,dxmin,df1,epsg,niter,nsim,impres
900   format (/" M1QN3 (Version 2.0b, December 1993): entry point"/
     /    5x,"dimension of the problem (n):",i9/
     /    5x,"number of updates (m):",i9/
     /    5x,"absolute precision on x (dxmin):",e9.2/
     /    5x,"expected decrease for f (df1):",e9.2/
     /    5x,"relative precision on g (epsg):",e9.2/
     /    5x,"maximal number of iterations (niter):",i6/
     /    5x,"maximal number of simulations (nsim):",i6/
     /    5x,"printing level (impres):",i4)
      if (n.le.0.or.niter.le.0.or.nsim.le.0.or.dxmin.le.0..or.epsg.le.0.
     /    .or.epsg.gt.1..or.mode.lt.0.or.mode.gt.3) then
          mode=2
          if (impres.ge.1) write (io,901)
901       format (/" >>> m1qn3: inconsistent call")
          return
      endif
c
c---- what method
c
      if (mod(mode,2).eq.0) then
          if (impres.ge.1) write (io,920)
  920     format (/" m1qn3: Diagonal Initial Scaling mode")
          sscale=.false.
      else
          if (impres.ge.1) write (io,921)
  921     format (/" m1qn3: Scalar Initial Scaling mode")
          sscale=.true.
      endif
c
c     --- Check the value of m (if (y,s) pairs in core, m will be >= 1)
c
      if (m.lt.1) then
          mode=2
          if (impres.ge.1) write (io,9020)
 9020     format (/" >>> m1qn3: m is set too small in mupdts")
          return
      endif
c
c     --- mmemo = number of (y,s) pairs in core memory
c
      call allocate_ctlvec(rzd,  x)
      call allocate_ctlvec(rzgg, x)
      call allocate_ctlvec(rzaux,x)
c
      if(m.eq.mmemo) then
        inmemo=.true.
      else
        inmemo=.false.
      endif
      if (impres.ge.1) then
          if (inmemo) then
              write (io,907)
          else
              write (io,908)
          endif
      endif
907   format (5x,"(y,s) pairs are stored in core memory")
908   format (5x,"(y,s) pairs are stored by the user")
c
c---- cold start or warm restart ?
c     check iz: iz(1)=n, iz(2)=(0 if DIS, 1 if SIS),
c               iz(3)=m, iz(4)=jmin, iz(5)=jmax
c
      if (mode/2.eq.0) then
          if (impres.ge.1) write (io,922)
      else
          iaux=0
          if (sscale) iaux=1
          if (iz(1).ne.n.or.iz(2).ne.iaux.or.iz(3).ne.m.or.iz(4).lt.1
     &        .or.iz(5).lt.1.or.iz(4).gt.iz(3).or.iz(5).gt.iz(3)) then
              mode=2
              if (impres.ge.1) write (io,923)
              return
          endif
          if (impres.ge.1) write (io,924)
      endif
  922 format (/" m1qn3: cold start"/)
  923 format (/" >>> m1qn3: inconsistent iz for a warm restart")
  924 format (/" m1qn3: warm restart"/)
      iz(1)=n
      iz(2)=0
      if (sscale) iz(2)=1
      iz(3)=m
c
c---- split the working zone rz
c
!      idiag=1
!      iybar=idiag+n
!      if (sscale) iybar=1
!      isbar=iybar+n*mmemo
!      id=isbar+n*mmemo
!      igg=id+n
!      iaux=igg+n
!      ialpha=iaux+n

!=========== uncomment the following if you require m1qn3 to 
!=========== input and output the (y,s) pairs w.r.t. the prosca inner
!=========== product. If you don't care how (y,s) are stored externally
!=========== then this transformation is unnecessary expense.
c
c---- transform the (y,s) pairs to Euclidean inner product
c
!     if (mode/2.ne.0) then
!       jfin=jmax
!       if (jfin.lt.jmin) jfin=jmax+iz(3)
!       do j=jfin,jmin,-1
!         jp=j
!         if (jp.gt.iz(3)) jp=jp-iz(3)
!         if (inmemo) then
!           rzaux=sbar(jp)
!           call ctonb (n,rzaux,sbar(jp))
!           rzaux=ybar(jp)
!           call ctonb (n,rzaux,ybar(jp))
!         else
!           call ystbl (.false.,ybar,sbar,n,jp)
!           rzaux=sbar(1)
!           call ctonb (n,rzaux,sbar(1))
!           rzaux=ybar(1)
!           call ctonb (n,rzaux,ybar(1))
!           call ystbl (.true.,ybar,sbar,n,jp)
!         endif
!       enddo
!     endif
c
c---- call the optimization code
c
      call m1qn3a (simul,prosca,ctonb,ctcab,n,x,f,g,dxmin,df1,epsg,
     /             impres,io,mode,niter,nsim,inmemo,iz(3),iz(4),iz(5),
     /             rzd,rzgg,rzdiag,rzaux,alpha,
     /             ybar,sbar)

!=========== uncomment the following if you require m1qn3 to 
!=========== input and output the (y,s) pairs w.r.t. the prosca inner
!=========== product. If you don't care how (y,s) are stored externally
!=========== then this transformation is unnecessary expense.
c
c---- transform the (y,s) pairs back to a prosca inner product
c
!     if (mode/2.ne.0) then
!       jfin=jmax
!       if (jfin.lt.jmin) jfin=jmax+iz(3)
!       do j=jfin,jmin,-1
!         jp=j
!         if (jp.gt.iz(3)) jp=jp-iz(3)
!         if (inmemo) then
!           rzaux=sbar(jp)
!           call ctcab (n,rzaux,sbar(jp))
!           rzaux=ybar(jp)
!           call ctcab (n,rzaux,ybar(jp))
!         else
!           call ystbl (.false.,ybar,sbar,n,jp)
!           rzaux=sbar(1)
!           call ctcab (n,rzaux,sbar(1))
!           rzaux=ybar(1)
!           call ctcab (n,rzaux,ybar(1))
!           call ystbl (.true.,ybar,sbar,n,jp)
!         endif
!       enddo
!     endif
c
c---- impressions finales
c
      if (impres.ge.1) write (io,905) mode,niter,nsim,epsg
905   format (/,1x,79("-")/
     /        /" m1qn3: output mode is ",i2
     /        /5x,"number of iterations: ",i4
     /        /5x,"number of simulations: ",i6
     /        /5x,"realized relative precision on g: ",e9.2)
      call prosca (n,x,x,ps)
      r1=sqrt(ps)
      call prosca (n,g,g,ps)
      r2=sqrt(ps)
      if (impres.ge.1) write (io,906) r1,f,r2
906   format (5x,"norm of x = ",e15.8
     /       /5x,"f         = ",e15.8
     /       /5x,"norm of g = ",e15.8)

      call deallocate_ctlvec(rzd)
      call deallocate_ctlvec(rzgg)
      call deallocate_ctlvec(rzaux)
      return
      end
c
c-----------------------------------------------------------------------
c

