      subroutine m1qn3a_1dv (ksat, n1d_x, n1d_y, n1d_z, n_max,       
     +                       knumb, kstglo,
     +                       p1d_x_fg           , 
     +                       p1d_x_xt           , 
     +                       p1d_b_evec         , 
     +                       p1d_b_eval         , 
     +                       p1d_x_sigb         , 
     +                       p1d_y              ,      
     +                       p1d_r_inv          ,      
     +                       xj_o               , 
     +                       xj_b               , 
     +                   prosca, ctonb_1dv, ctcab_1dv , 
     /                   n,x,f,g,dxmin,df1,
     /                   epsg,impres,io,mode,niter,nsim,inmemo,m,jmin,
     /                   jmax,d,gg,diag,aux,alpha,ybar,sbar, ifail)
c----
c
c     Code d'optimisation proprement dit.
c
c----
c
c     Modifications
c
c                                Modified for 1Dvar rain assimilation
c     A. Geer      4-Apr-2006    Change failure codes (ifail)
c
c     C. O'Dell   15-Jan-2007    Pass through ksat for multiple sensors extension
c
c----
c
c         arguments
c23456789012345678901234567890123456789012345678901234567890123456789012

      implicit none
 
      integer ksat, n1d_x,n1d_y,n1d_z
      integer n_max,knumb,kstglo
      real    p1d_b_evec (n1d_x,n1d_x)
      real    p1d_x_fg   (n1d_x) 
      real    p1d_b_eval (n1d_x)
      real    p1d_x_sigb (n1d_x)
      real    p1d_x_xt   (n1d_z)  
      real    p1d_y      (n1d_y) 
      real    p1d_r_inv  (n1d_y,n1d_y) 
      real    xj_o (0:n_max), xj_b (0:n_max)
 
 
      logical inmemo
      integer n,impres,io,mode,niter,nsim,m,jmin,jmax,ifail        
      real    x(n),f,g(n),dxmin,df1,epsg,d(n),gg(n),
     /     diag(n),aux(n),
     /     alpha(m),ybar(n,n),sbar(n,n)
      external prosca,ctonb_1dv,ctcab_1dv
c
c         variables locales
c
      logical sscale,cold,warm
      integer i,itmax,moderl,isim,jcour,indic,iprint
      real    r1,t,tmin,tmax,gnorm,eps1,ff,preco,precos,
     /     ys,den,dk,dk1
      double precision ps,ps2,hp0
c
c         parametres
c
      real rm1,rm2
      parameter (rm1=0.0001,rm2=0.9)
      real pi
      parameter (pi=3.1415927)
      real rmin
c
c---- initialisation
c
      rmin=1.e-20
c
      sscale=.true.
      if (mod(mode,2).eq.0) sscale=.false.
c
      warm=.false.
      if (mode/2.eq.1) warm=.true.
      cold=.not.warm
c
      itmax=niter
      niter=0
      isim=1
      eps1=1.
c
      call prosca (n,g,g,ps)
      gnorm=sngl(ps)
      gnorm=sqrt(gnorm)
      if (impres.ge.1) write (io,900) f,gnorm
  900 format (5x,"f         = ",e15.8
     /       /5x,"norm of g = ",e15.8)
      if (gnorm.lt.rmin) then
          mode=2
          if (impres.ge.1) write (io,901)
          goto 1000
      endif
  901 format (/" >>> m1qn3a: initial gradient is too small")
c
c     --- initialisation pour dd
c
      if (cold) then
          jmin=1
          jmax=0
      endif
      jcour=1
      if (inmemo) jcour=jmax
c
c     --- mise a l'echelle de la premiere direction de descente
c
      if (cold) then
c
c         --- use Fletcher's scaling and initialize diag to 1.
c
          precos=2.*df1/gnorm**2
          do 10 i=1,n
              d(i)=-g(i)*precos
              diag(i)=1.
   10     continue
          if (impres.ge.5) write(io,902) precos
  902     format (/" m1qn3a: descent direction -g: precon = ",e10.3)
	  
      else
c
c         --- use the matrix stored in [diag and] the (y,s) pairs
c
          if (sscale) then
              call prosca (n,ybar(1,jcour),ybar(1,jcour),ps)
              precos=1./sngl(ps)
          endif
          do 11 i=1,n
              d(i)=-g(i)
  11      continue
          if (inmemo) then
              call dd_1dv (prosca,ctonb_1dv,ctcab_1dv,n,sscale,m,d,
     /                     aux,jmin,jmax,precos,diag,alpha,ybar,sbar)
          else
              call dds_1dv (prosca,ctonb_1dv,ctcab_1dv,n,sscale,m,d,
     /                     aux,jmin,jmax,precos,diag,alpha,ybar,sbar)
          endif
      endif
c
      if (impres.eq.3) then
          write(io,903)
          write(io,904)
      endif
      if (impres.eq.4) write(io,903)
  903 format (/1x,79("-"))
  904 format (1x)
c
c     --- initialisation pour mlis0
c
      tmax=1.e+20
      call prosca (n,d,g,hp0)
      if (hp0.ge.0.d+0) then
          mode=7
          if (impres.ge.1) write (io,905) niter,hp0
          goto 1000
      endif
  905 format (/" >>> m1qn3 (iteration ",i2,"): "
     /        /5x," the search direction d is not a ",
     /         "descent direction: (g,d) = ",d12.5)
c
c     --- compute the angle (-g,d)
c
      if (warm.and.impres.ge.5) then
          call prosca (n,g,g,ps)
          ps=dsqrt(ps)
          call prosca (n,d,d,ps2)
          ps2=dsqrt(ps2)
          ps=hp0/ps/ps2
          ps=dmin1(-ps,1.d+0)
          ps=dacos(ps)
          r1=sngl(ps)
          r1=r1*180./pi
          write (io,906) r1
      endif
  906 format (/" m1qn3: descent direction d: ",
     /        "angle(-g,d) = ",f5.1," degrees")
c
c---- Debut de l'iteration. on cherche x(k+1) de la forme x(k) + t*d,
c     avec t > 0. On connait d.
c
c         Debut de la boucle: etiquette 100,
c         Sortie de la boucle: goto 1000.
c
100   niter=niter+1
      if (impres.lt.0) then
          if (mod(niter,-impres).eq.0) then
              indic=1
              call onedvar_simul (ksat, n1d_x, n1d_y, n1d_z, n_max, 
     +                            knumb, kstglo,
     +                            x                  , 
     +                            p1d_x_fg           , 
     +                            p1d_x_xt           , 
     +                            p1d_b_evec         , 
     +                            p1d_b_eval         , 
     +                            p1d_x_sigb         , 
     +                            p1d_y              ,      
     +                            p1d_r_inv          , 
     +                            niter              , 
     +                            xj_o               , 
     +                            xj_b               , 
     +                            g                  ,
     +                            ifail)
              if (ifail /= 0) return
     
              f=xj_b(niter)+xj_o(niter)
              goto 100
          endif
      endif
      if (impres.ge.5) write(io,903)
      if (impres.ge.4) write(io,904)
      if (impres.ge.3) write (io,910) niter,isim,f,hp0
  910 format (" m1qn3: iter ",i3,", simul ",i3,
     /        ", f=",e15.8,", h'(0)=",d12.5)
      do 101 i=1,n
          gg(i)=g(i)
101   continue
      ff=f
c
c     --- recherche lineaire et nouveau point x(k+1)
c
      if (impres.ge.5) write (io,911)
  911 format (/" m1qn3: line search")
c
c         --- calcul de tmin
c
      tmin=0.
      do 200 i=1,n
          tmin=amax1(tmin,abs(d(i)))
200   continue
      tmin=dxmin/tmin
      t=1.
      r1=sngl(hp0)
c
      call mlis0_1dv (ksat, n1d_x, n1d_y, n1d_z, n_max,
     +                knumb, kstglo,
     +                p1d_x_fg           , 
     +                p1d_x_xt           , 
     +                p1d_b_evec         , 
     +                p1d_b_eval         , 
     +                p1d_x_sigb         , 
     +                p1d_y              ,      
     +                p1d_r_inv          ,      
     +                xj_o               , 
     +                xj_b               , 
     +                prosca             , 
     +                n,x,f,r1,t,tmin,tmax,d,g,rm2,rm1,
     +                impres,io,moderl,isim,nsim,aux,niter, 
     +                ifail)
      if (ifail /= 0) return
c
c         --- mlis0 renvoie les nouvelles valeurs de x, f et g
c
      if (moderl.ne.0) then
          if (moderl.lt.0) then
c
c             --- calcul impossible
c                 t, g: ou les calculs sont impossibles
c                 x, f: ceux du t_gauche (donc f <= ff)
c
              mode=moderl
          elseif (moderl.eq.1) then
c
c             --- descente bloquee sur tmax
c                 [sortie rare (!!) d'apres le code de mlis0]
c
              mode=3
              if (impres.ge.1) write(io,912) niter
  912         format (/" >>> m1qn3 (iteration ",i3,
     /                "): line search blocked on tmax: ",
     /                "decrease the scaling")
          elseif (moderl.eq.4) then
c
c             --- nsim atteint
c                 x, f: ceux du t_gauche (donc f <= ff)
c
              mode=5
          elseif (moderl.eq.5) then
c
c             --- arret demande par l'utilisateur (indic = 0)
c                 x, f: ceux en sortie du simulateur
c
              mode=0
          elseif (moderl.eq.6) then
c
c             --- arret sur dxmin ou appel incoherent
c                 x, f: ceux du t_gauche (donc f <= ff)
c
              mode=6
          endif
          goto 1000
      endif
c
c NOTE: stopping tests are now done after having updated the matrix, so
c that update information can be stored in case of a later warm restart
c
c     --- mise a jour de la matrice
c
      if (m.gt.0) then
c
c         --- mise a jour des pointeurs
c
          jmax=jmax+1
          if (jmax.gt.m) jmax=jmax-m
          if ((cold.and.niter.gt.m).or.(warm.and.jmin.eq.jmax)) then
              jmin=jmin+1
              if (jmin.gt.m) jmin=jmin-m
          endif
          if (inmemo) jcour=jmax
c
c         --- y, s et (y,s)
c
          do 400 i=1,n
              sbar(i,jcour)=t*d(i)
              ybar(i,jcour)=g(i)-gg(i)
400       continue
          if (impres.ge.5) then
              call prosca (n,sbar(1,jcour),sbar(1,jcour),ps)
              dk1=sqrt(sngl(ps))
              if (niter.gt.1) write (io,930) dk1/dk
  930         format (/" m1qn3: convergence rate, s(k)/s(k-1) = ",
     /                e12.5)
              dk=dk1
          endif
          call prosca (n,ybar(1,jcour),sbar(1,jcour),ps)
          ys=sngl(ps)
          if (ys.le.0.) then
              mode=7
              if (impres.ge.1) write (io,931) niter,ys
  931         format (/" >>> m1qn3 (iteration ",i2,
     /                "): the scalar product (y,s) = ",e12.5
     /                /27x,"is not positive")
              goto 1000
          endif
c
c         --- ybar et sbar
c
          r1=sqrt(1./ys)
          do 410 i=1,n
              sbar(i,jcour)=r1*sbar(i,jcour)
              ybar(i,jcour)=r1*ybar(i,jcour)
  410     continue
          if (.not.inmemo) call ystbl_1dv (.true.,ybar,sbar,n,jmax)
c
c         --- compute the scalar or diagonal preconditioner
c
          if (impres.ge.5) write(io,932)
  932     format (/" m1qn3: matrix update:")
c
c             --- Here is the Oren-Spedicato factor, for scalar scaling
c
          if (sscale) then
              call prosca (n,ybar(1,jcour),ybar(1,jcour),ps)
              precos=1./sngl(ps)
c
              if (impres.ge.5) write (io,933) precos
  933         format (5x,"Oren-Spedicato factor = ",e10.3)
c
c             --- Scale the diagonal to Rayleigh's ellipsoid.
c                 Initially (niter.eq.1) and for a cold start, this is
c                 equivalent to an Oren-Spedicato scaling of the
c                 identity matrix.
c
          else
              call ctonb_1dv (n,ybar(1,jcour),aux)
              ps=0.d0
              do 420 i=1,n
                  ps=ps+dble(diag(i))*dble(aux(i))*dble(aux(i))
  420         continue
              r1=sngl(1.d0/ps)
              if (impres.ge.5) then
                  write (io,934) r1
  934             format(5x,"fitting the ellipsoid: factor = ",e10.3)
              endif
              do 421 i=1,n
                  diag(i)=diag(i)*r1
  421         continue
c
c             --- update the diagonal
c                 (gg is used as an auxiliary vector)
c
              call ctonb_1dv (n,sbar(1,jcour),gg)
              ps=0.d0
              do 430 i=1,n
                  ps=ps+dble(gg(i))*dble(gg(i))/dble(diag(i))
  430         continue
              den=sngl(ps)
              IPRINT=0
              do 431 i=1,n
                  diag(i)=1./
     &                    (1./diag(i)+aux(i)**2-(gg(i)/diag(i))**2/den)
                  if (diag(i).le.0.) then
CEA                      if (impres.ge.5) write (io,935) i,diag(i),rmin
                      diag(i)=rmin
                      IPRINT=I
                  endif
  431         continue
              IF(IPRINT.NE.0) THEN
                if (impres.ge.5) write (io,935) IPRINT,diag(IPRINT),rmin
              ENDIF
  935         format (/" >>> m1qn3-WARNING: diagonal element ",i8,
     &                 " is negative (",e10.3,"), reset to ",e10.3)
c
              if (impres.ge.5) then
                  ps=0.
                  do 440 i=1,n
                      ps=ps+dble(diag(i))
  440             continue
                  ps=ps/n
                  preco=sngl(ps)
c
                  ps2=0.
                  do 441 i=1,n
                      ps2=ps2+(dble(diag(i))-ps)**2
  441             continue
                  ps2=dsqrt(ps2/n)
                  write (io,936) preco,sngl(ps2)
  936             format (5x,"updated diagonal: average value = ",e10.3,
     &                   ", sqrt(variance) = ",e10.3)
              endif
          endif
      endif
c
c     --- tests d'arret
c
      call prosca(n,g,g,ps)
      eps1=sngl(ps)
      eps1=sqrt(eps1)/gnorm
c
      if (impres.ge.5) write (io,940) eps1
  940 format (/" m1qn3: stopping criterion on g: ",e12.5)
      if (eps1.lt.epsg) then
          mode=1
          goto 1000
      endif
      if (niter.eq.itmax) then
          mode=4
          if (impres.ge.1) write (io,941) niter
  941     format (/" >>> m1qn3 (iteration ",i3,
     /            "): maximal number of iterations")
          goto 1000
      endif
      if (isim.gt.nsim) then
          mode=5
          if (impres.ge.1) write (io,942) niter,isim
  942     format (/" >>> m1qn3 (iteration ",i3,"): ",i6,
     /            " simulations (maximal number reached)")
          goto 1000
      endif
c
c     --- calcul de la nouvelle direction de descente d = - H.g
c
      if (m.eq.0) then
          preco=2.*(ff-f)/(eps1*gnorm)**2
          do 500 i=1,n
              d(i)=-g(i)*preco
  500     continue
      else
          do 510 i=1,n
              d(i)=-g(i)
  510     continue
          if (inmemo) then
              call dd_1dv (prosca,ctonb_1dv,ctcab_1dv,n,sscale,m,d,
     /                 aux,jmin,jmax,precos,diag,alpha,ybar,sbar)
          else
              call dds_1dv (prosca,ctonb_1dv,ctcab_1dv,n,sscale,m,d,
     /                 aux,jmin,jmax,precos,diag,alpha,ybar,sbar)
          endif
      endif
c
c         --- test: la direction d est-elle de descente ?
c             hp0 sera utilise par mlis0
c
      call prosca (n,d,g,hp0)
      if (hp0.ge.0.d+0) then
          mode=7
          if (impres.ge.1) write (io,905) niter,hp0
          goto 1000
      endif
      if (impres.ge.5) then
          call prosca (n,g,g,ps)
          ps=dsqrt(ps)
          call prosca (n,d,d,ps2)
          ps2=dsqrt(ps2)
          ps=hp0/ps/ps2
          ps=dmin1(-ps,1.d+0)
          ps=dacos(ps)
          r1=sngl(ps)
          r1=r1*180./pi
          write (io,906) r1
      endif
c
c---- on poursuit les iterations
c
      goto 100
c
c---- retour
c
 1000 continue
      nsim=isim
      epsg=eps1
      return
      end
c
c-----------------------------------------------------------------------
c

