       subroutine 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,xn,fn,fpn,t,tmin,tmax,d,g,
     +                       amd,amf,imp,io,logic,nap,napmax,x,niter,
     +                       ifail)
c ----
c
c     mlis0 + minuscules + commentaires
c     + version amelioree (XII 88): interpolation cubique systematique
c       et anti-overflows
c     + declaration variables (II/89, JCG).
c     + barr is also progressively decreased (12/93, CL & JChG).
c       barmul is set to 5.
c
c     ----------------------------------------------------------------
c
c        en sortie logic =
c
c        0          descente serieuse
c        1          descente bloquee
c        4          nap > napmax
c        5          retour a l'utilisateur
c        6          fonction et gradient pas d'accord
c        < 0        contrainte implicite active
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 --- arguments
c
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)
      real    dj_n       (n_max)
      real    dj         (n1d_x)

      external prosca
      integer n,imp,io,logic,nap,napmax,niter,ifail      
      real xn(n),fn,fpn,t,tmin,tmax,d(n),g(n),amd,amf,x(n)   
       
c
c --- variables locales
c
      integer i,indic,indica,indicd
      real    tesf,tesd,tg,fg,fpg,td,ta,fa,fpa,d2,f,fp,
     / ffn,fd,fpd,
     / z,test,barmin,barmul,barmax,barr,gauche,droite,
     / taa
      double precision ps
c
 1000 format (/4x,9h mlis0   ,4x,4hfpn=,e10.3,4h d2=,e9.2,
     1 7h  tmin=,e9.2,6h tmax=,e9.2)
 1001 format (/4x,6h mlis0,3x,"stop on tmin",8x,
     1   "step",11x,"functions",5x,"derivatives")
 1002 format (4x,6h mlis0,37x,e10.3,2e11.3)
 1003 format (4x,6h mlis0,e14.3,2e11.3)
 1004 format (4x,6h mlis0,37x,e10.3,7h indic=,i3)
 1005 format (4x,6h mlis0,14x,2e18.8,e11.3)
 1006 format (4x,6h mlis0,14x,e18.8,12h      indic=,i3)
 1007 format (/4x,6h mlis0,10x,"tmin forced to tmax")
 1008 format (/4x,6h mlis0,10x,"inconsistent call")
      if (n.gt.0 .and. fpn.lt.0. .and. t.gt.0.
     1 .and. tmax.gt.0. .and. amf.gt.0.
     1 .and. amd.gt.amf .and. amd.lt.1.) go to 5
      logic=6
      go to 999
    5 tesf=amf*fpn
      tesd=amd*fpn
      barmin=0.01
      barmul=5.
      barmax=0.3
      barr=barmin
      td=0.
      tg=0.
      fg=fn
      fpg=fpn
      ta=0.
      fa=fn
      fpa=fpn
      call prosca (n,d,d,ps)
      d2=sngl(ps)
c
c               elimination d'un t initial ridiculement petit
c
      if (t.gt.tmin) go to 20
      t=tmin
      if (t.le.tmax) go to 20
      if (imp.gt.0) write (io,1007)
      tmin=tmax
   20 if (fn+t*fpn.lt.fn+0.9*t*fpn) go to 30
      t=2.*t
      go to 20
   30 indica=1
      logic=0
      if (t.gt.tmax) then
          t=tmax
          logic=1
      endif
      if (imp.ge.4) write (io,1000) fpn,d2,tmin,tmax
c
c     --- nouveau x
c                
      do 50 i=1,n
          x(i)=xn(i)+t*d(i)
   50 continue
c
c --- boucle
c
  100 nap=nap+1
      if(nap.gt.napmax) then
          logic=4
          fn=fg
          do 120 i=1,n
              xn(i)=xn(i)+tg*d(i)
  120     continue
          go to 999
      endif
      indic=4
c
c     --- appel simulateur
c
      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)
      if(indic.eq.0) then
c
c         --- arret demande par l'utilisateur
c
          logic=5
          fn=f
          do 170 i=1,n
              xn(i)=x(i)
  170     continue
          go to 999
      endif
      if(indic.lt.0) then
c
c         --- les calculs n'ont pas pu etre effectues par le simulateur
c
          td=t
          indicd=indic
          logic=0
          if (imp.ge.4) write (io,1004) t,indic
          t=tg+0.1*(td-tg)
          go to 905
      endif
c
c     --- les tests elementaires sont faits, on y va
c
      call prosca (n,d,g,ps)
      fp=sngl(ps)
c
c     --- premier test de Wolfe
c
      ffn=f-fn
      if(ffn.gt.t*tesf) then
          td=t
          fd=f
          fpd=fp
          indicd=indic
          logic=0
          if(imp.ge.4) write (io,1002) t,ffn,fp
          go to 500
      endif
c
c     --- test 1 ok, donc deuxieme test de Wolfe
c
      if(imp.ge.4) write (io,1003) t,ffn,fp
      if(fp.gt.tesd) then
          logic=0
          go to 320
      endif
      if (logic.eq.0) go to 350
c
c     --- test 2 ok, donc pas serieux, on sort
c
  320 fn=f
      do 330 i=1,n
          xn(i)=x(i)
  330 continue
      go to 999
c
c
c
  350 tg=t
      fg=f
      fpg=fp
      if(td.ne.0.) go to 500
c
c              extrapolation
c
      taa=t
      gauche=(1.+barmin)*t
      droite=10.*t
      call ecube_1dv (t,f,fp,ta,fa,fpa,gauche,droite)
      ta=taa
      if(t.lt.tmax) go to 900
      logic=1
      t=tmax
      go to 900
c
c              interpolation
c
  500 if(indica.le.0) then
          ta=t
          t=0.9*tg+0.1*td
          go to 900
      endif
      test=barr*(td-tg)
      gauche=tg+test
      droite=td-test
      taa=t
      call ecube_1dv (t,f,fp,ta,fa,fpa,gauche,droite)
      ta=taa
      if (t.gt.gauche .and. t.lt.droite) then
          barr=amax1(barmin,barr/barmul)
c         barr=barmin
        else
          barr=amin1(barmul*barr,barmax)
      endif
c
c --- fin de boucle
c     - t peut etre bloque sur tmax
c       (venant de l'extrapolation avec logic=1)
c
  900 fa=f
      fpa=fp
  905 indica=indic
c
c --- faut-il continuer ?
c
      if (td.eq.0.) go to 950
      if (td-tg.lt.tmin) go to 920
c
c     --- limite de precision machine (arret de secours) ?
c
      do 910 i=1,n
          z=xn(i)+t*d(i)
          if (z.ne.xn(i).and.z.ne.x(i)) go to 950
  910 continue
c
c --- arret sur dxmin ou de secours
c
  920 logic=6
c
c     si indicd<0, derniers calculs non faits par simul
c
      if (indicd.lt.0) logic=indicd
c
c     si tg=0, xn = xn_depart,
c     sinon on prend xn=x_gauche qui fait decroitre f
c
      if (tg.eq.0.) go to 940
      fn=fg
      do 930 i=1,n
  930 xn(i)=xn(i)+tg*d(i)
  940 if (imp.le.0) go to 999
      write (io,1001)
      write (io,1005) tg,fg,fpg
      if (logic.eq.6) write (io,1005) td,fd,fpd
      if (logic.eq.7) write (io,1006) td,indicd
      go to 999
c
c               recopiage de x et boucle
c
  950 do 960 i=1,n
  960 x(i)=xn(i)+t*d(i)
      go to 100
  999 return
      end
c
c-----------------------------------------------------------------------
c

  
