subroutine n1cga (simul,K_N,YD_X,YD_B,YD_Q,YD_R,YD_V,YD_RM,P_EPSNEG,P_EPS2,K_ITER,K_IMP,K_IO,&
 & K_MODE,&
 & K_BFGSP,&
 & K_M0,K_NYS0,K_JMIN0,K_JMAX0,YD_YBAR0,YD_SBAR0,P_SIZE0,&
 & K_BFGSB,&
 & K_M1,K_NYS1,K_JMIN1,K_JMAX1,K_JOL,YD_YBAR1,YD_SBAR1,P_SIZE1,P_OL,&
 & K_SELECT,&
 & P_RHO,YD_AUX,P_F0,&
 & YD_YS,YD_YRS)  

USE PARKIND1  ,ONLY : JPIM     ,JPRB
USE YOMHOOK   ,ONLY : LHOOK,   DR_HOOK
USE PARKIND2  ,ONLY : JPRH

use CONTROL_VECTORS

IMPLICIT NONE
external simul
INTEGER(KIND=JPIM),INTENT(IN)    :: K_M0 
INTEGER(KIND=JPIM),INTENT(INOUT) :: K_M1 
INTEGER(KIND=JPIM)               :: K_N ! UNDETERMINED INTENT
TYPE(CONTROL_VECTOR)               :: YD_X ! UNDETERMINED INTENT
TYPE(CONTROL_VECTOR),INTENT(INOUT) :: YD_B 
TYPE(CONTROL_VECTOR)               :: YD_Q ! UNDETERMINED INTENT
TYPE(CONTROL_VECTOR)               :: YD_R ! UNDETERMINED INTENT
TYPE(CONTROL_VECTOR)               :: YD_V ! UNDETERMINED INTENT
TYPE(CONTROL_VECTOR),INTENT(INOUT) :: YD_RM 
REAL(KIND=JPRB)   ,INTENT(IN)    :: P_EPSNEG 
REAL(KIND=JPRB)   ,INTENT(INOUT) :: P_EPS2 
INTEGER(KIND=JPIM)               :: K_ITER ! UNDETERMINED INTENT
INTEGER(KIND=JPIM),INTENT(IN)    :: K_IMP 
INTEGER(KIND=JPIM)               :: K_IO ! UNDETERMINED INTENT
INTEGER(KIND=JPIM),INTENT(OUT)   :: K_MODE 
INTEGER(KIND=JPIM),INTENT(IN)    :: K_BFGSP 
INTEGER(KIND=JPIM),INTENT(IN)    :: K_NYS0 
INTEGER(KIND=JPIM),INTENT(IN)    :: K_JMIN0 
INTEGER(KIND=JPIM),INTENT(IN)    :: K_JMAX0 
TYPE(CONTROL_VECTOR),INTENT(IN)    :: YD_YBAR0(K_M0) 
TYPE(CONTROL_VECTOR),INTENT(IN)    :: YD_SBAR0(K_M0) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: P_SIZE0 
INTEGER(KIND=JPIM),INTENT(IN)    :: K_BFGSB 
INTEGER(KIND=JPIM),INTENT(INOUT) :: K_NYS1 
INTEGER(KIND=JPIM),INTENT(INOUT) :: K_JMIN1 
INTEGER(KIND=JPIM),INTENT(INOUT) :: K_JMAX1 
INTEGER(KIND=JPIM),INTENT(INOUT) :: K_JOL(K_M1) 
TYPE(CONTROL_VECTOR),INTENT(INOUT) :: YD_YBAR1(K_M1) 
TYPE(CONTROL_VECTOR),INTENT(INOUT) :: YD_SBAR1(K_M1) 
REAL(KIND=JPRB)   ,INTENT(OUT)   :: P_SIZE1 
REAL(KIND=JPRB)   ,INTENT(INOUT) :: P_OL(K_M1) 
INTEGER(KIND=JPIM),INTENT(IN)    :: K_SELECT 
REAL(KIND=JPRB)   ,INTENT(OUT)   :: P_RHO(K_M0) 
TYPE(CONTROL_VECTOR)               :: YD_AUX ! Argument NOT used
REAL(KIND=JPRB)   ,INTENT(IN)    :: P_F0 
INTEGER(KIND=JPIM) ::indic
REAL(KIND=JPRB) ::Z_F
TYPE(CONTROL_VECTOR) ,INTENT(IN)    :: YD_YS
TYPE(CONTROL_VECTOR) ,INTENT(IN)    :: YD_YRS
!----

!     This routine solves the linear system (LS) Ax=b, for x,
!     by the possibly preconditioned Fletcher-Reeves CG algorithm.
!     The preconditioning can come from l-BFGS updates stored in ybar0,
!     sbar0 and rho.

!     The residual is denoted by r = Ax-b and the preconditioning
!     matrix by P (=+- inverse of A).

!     The first iterate is supposed to be in x.

!     Input:

!       n (integer): dimension of the LS to solve.
!       a (double precision vector): name of the vector storing the
!           matrix A, when necessary.
!       epsneg = epsilon for detecting negative curvature directions.
!       iter = max number of iterations
!       imp: printing levels
!         <= 0: nothing is printed,
!          = 1: error, terminal, and stopping messages,
!          = 2: also, one line per iteration.
!       bfgsb:
!         =0: don't build a BFGS preconditioning matrix
!         =1: build a full BFGS preconditioning matrix in pmat1, if
!             pmat1(1,1) <= 0., the matrix is re-initialized
!         =2: build a limited memory BFGS preconditioning matrix
!       bfgsp:
!         =0: no BFGS preconditioning
!         =1: full BFGS preconditioning with pmat0
!         =2: limited memory BFGS preconditioning

!     Output:

!       x (double precision vector of dim n): approximate solution of
!           the (LS).
!       b (double precision vector of dim n): RHS of the (LS).
!       q (double precision vector of dim n): auxiliary vector for
!           storing Av.
!       r (double precision vector of dim n): updated residual.
!       v (double precision vector of dim n): inner CG directions.
!       rm (double precision vector of dim n): auxiliary vector for
!           storing Pr.
!>>>>>>>>>>>> a mon avis inutile, pourrait etre stocke dans q.
!       iter = number of iterations
!       mode:
!         =0: normal terminaison (on eps2),
!         =3: A is probably indefinite (Rayleigh quotient less than
!             epsneg),
!         =4: maximum number of iterations reached,
!         =5: number of iterations exceeds 2n.
!         =6: the initial residual is zero.
!         =7: bad call to dysave.
!         =8: stop on a cost increase

!----

! --- parameter

REAL(KIND=JPRB) :: Z_PI
parameter (Z_PI=3.1415927e0_JPRB)

! --- local variables
!     restart=.true.:
!           restarts are allowed. A restart of the CG iterations
!           occurs at iterations n, 3n/2, 9n/4, ... or when
!           (Pr_,r)>=0.2|Pr_||r| (Powell's criterion).
!     r2i = |initial residual|^2
!     v2 = |v|^2
!     pprr = previous prr
!     prr = <Pr,r>
!     r2 = |r|^2
!     avv = <Av,v>
!     rr=(|r|/|r0|)**2: relative r
!     cost = (Ax,x)/2 - (b,x)
!     x2 = |x|^2

logical :: LL_RESTART
INTEGER(KIND=JPIM) :: I_MITER,iterr,I_NITER,I_BITER,I_YSMODE
character :: CL_SC
REAL(KIND=JPRB) :: Z_DANGLE,Z_AUX1,Z_COST,Z_MCOST,Z_COST0,Z_RR,Z_BETA
REAL(KIND=JPRH) :: Z_R2I,Z_R2,Z_RM2,Z_PRR,pprr,Z_V2,Z_AVV,Z_X2,Z_BTX,Z_RTX,Z_GPERP,Z_SP,Z_RAYL,Z_ALPHA,Z_T
REAL(KIND=JPRB) :: ZHOOK_HANDLE

#include "dbfgsl.h"
#include "dpseuclid.h"
#include "dysave.h"

! --- initialisation
!     miter = max iterations
!     niter = iteration nbr of the next forced restart
!     iterr = iteration nbr of the previous restart
!     biter = bad iteration nbr (will produce failure)

IF (LHOOK) CALL DR_HOOK('N1CGA',0,ZHOOK_HANDLE)
I_MITER=K_ITER
I_NITER=K_N
iterr=1
I_BITER=int(sqrt(real(K_N*K_N*K_N,JPRB)))
K_ITER=0
Z_RR=1.0_JPRB
Z_GPERP=0.0_JPRB
if (K_SELECT == 0) CL_SC='S'

!     --- In my experience, it is better no doing restart

LL_RESTART=.false.

!     --- force initialize the l-BFGS matrix if appropriate

K_NYS1=0

!     --- initial residual r = Ax-b
!         r2i = |initial residual|^2

!      call simul (indic,n,x,f,r,iter)
!      appel au simul. inutile car deja effectue a l'exterieur !

!     --- change of variable for x, r and b (RHS)

YD_X%data = YD_X%data * YD_YS%data
YD_R%data = 0.5_JPRB * YD_R%data * YD_YS%data
YD_B%data = 0.5_JPRB * YD_B%data * YD_YS%data
YD_RM = YD_R
call dpseuclid (K_N,YD_R,YD_R,Z_R2I)
Z_R2=Z_R2I
if (Z_R2I == 0.0_JPRB) then
  K_MODE=6
  if (K_IMP > 0) write (K_IO,900)
  goto 1000
endif
900 format(/4x,"n1cga-WARNING: zero initial residual")

!     --- rm = Pr
!         prr = <Pr,r>

!      rm = r     ! Inutile a mon avis

if (K_BFGSP == 2) then
  call dbfgsl (K_N,YD_RM,K_M0,K_NYS0,K_JMIN0,K_JMAX0,YD_YBAR0,YD_SBAR0,P_RHO,P_SIZE0)
endif
call dpseuclid (K_N,YD_RM,YD_RM,Z_RM2)
call dpseuclid (K_N,YD_R,YD_RM,Z_PRR)

!     --- initial search direction v
!         v2 = |v|^2

YD_V%data = -YD_RM%data
Z_V2=Z_RM2

! --- cost
!     cost = current cost
!     mcost = min cost encountered

Z_COST=0.e0_JPRB
Z_MCOST=0.e0_JPRB

! --- printings

if (K_IMP >= 2) then
  write (K_IO,901) sqrt(Z_R2I)
endif
901 format (/4x,"n1cga: initial residual |r0| =",1pd13.6)

! --- start the CG iterations at 100, end at 1000

100 CONTINUE
K_ITER=K_ITER+1

!     --- check iter (force convergence, however)

if (K_ITER > I_MITER) then
  K_MODE=4
  K_ITER=K_ITER-1
  if (K_IMP > 0) write (K_IO,910)
  goto 1000
endif
910 format(/4x,"n1cga: max inner iterations")

!     --- too many iterations ?

!     if (iter > biter) then
!         mode=5
!         if (imp > 0) write (io,911) biter
!         goto 1000
!     endif
! 911 format(/4x,"n1cga-ERROR: number of inner iterations exceeds",i6)

!     --- restart ?

if (LL_RESTART.and.(Z_GPERP > 0.2e0_JPRB.or.K_ITER > I_NITER)) then
  if (K_ITER > I_NITER) I_NITER=I_NITER*3/2
  iterr=K_ITER
  if (K_IMP >= 2) write (K_IO,912)
  912 format(4x,"n1cga: LL_RESTART")

!         --- recompute the residuals r and rm

!         --- inverse change of variable

  YD_X%data = YD_X%data * YD_YRS%data

  call simul (indic,K_N,YD_X,Z_F,YD_R,K_ITER)

!         --- change of variable for x and r

  YD_X%data = YD_X%data * YD_YS%data
  YD_R%data = 0.5_JPRB * YD_R%data * YD_YS%data
  YD_RM = YD_R
  call dpseuclid (K_N,YD_R,YD_R,Z_R2)

  if (K_BFGSP == 2) then
    call dbfgsl (K_N,YD_RM,K_M0,K_NYS0,K_JMIN0,K_JMAX0,YD_YBAR0,YD_SBAR0,P_RHO,P_SIZE0)
  endif
  call dpseuclid (K_N,YD_RM,YD_RM,Z_RM2)
  call dpseuclid (K_N,YD_R,YD_RM,Z_PRR)

!         --- and the search direction v

  YD_V%data = -YD_RM%data
  Z_V2=Z_RM2
endif

!     --- q = Av
!         avv = <v,q> = <Av,v>

!     --- inverse of change of variable for v

YD_V%data = YD_V%data * YD_YRS%data

call simul (indic,K_N,YD_V,Z_F,YD_Q,K_ITER)

!     --- change of variable for v and q

YD_V%data = YD_V%data * YD_YS%data
YD_Q%data = 0.5_JPRB * YD_YS%data * YD_Q%data
YD_Q%data = YD_Q%data + YD_B%data

call dpseuclid (K_N,YD_V,YD_Q,Z_AVV)

!     --- check positive definiteness

if (K_IMP > 0.and.Z_V2 /= 0.0_JPRB) Z_RAYL=Z_AVV/Z_V2
if (Z_AVV <= P_EPSNEG*Z_V2) then
  K_MODE=3
  if (K_IMP > 0.and.Z_V2 /= 0.0_JPRB) write (K_IO,913) Z_RAYL
  goto 1000
endif
913 format(/4x,"n1cga-ERROR: non positive definite matrix,",&
 & " <Av,YD_V>/|YD_V|^2 = ",1pe9.2)  

!     --- update the preconditioning matrix when appropriate
!         y=q=Av, s=v, ys=avv

if (K_BFGSB == 2) then

!         --- limited memory inverse BFGS update

  CL_SC='-'
  call dysave (K_N,YD_Q,YD_V,Z_AVV,K_M1,K_NYS1,K_JMIN1,K_JMAX1,YD_YBAR1,YD_SBAR1,K_SELECT,&
   & K_ITER,P_OL,K_JOL,P_EPSNEG,P_SIZE1,I_YSMODE,4,K_IO)  
  if (I_YSMODE == 0) CL_SC='S'
  if (I_YSMODE > 0) then
    K_MODE=7
    IF (LHOOK) CALL DR_HOOK('N1CGA',1,ZHOOK_HANDLE)
    return
  endif
endif
914 format(4x,"n1cga: initialization of the BFGS matrix with P_OL",&
 & " factor =",1pe13.6)  

!     --- new iterate x and residual r

Z_ALPHA=Z_PRR/Z_AVV
YD_X%data = YD_X%data + Z_ALPHA*YD_V%data
call dpseuclid (K_N,YD_X,YD_X,Z_X2)
YD_R%data = YD_R%data + Z_ALPHA*YD_Q%data

! --- stop if the cost increases

Z_MCOST=min(Z_COST,Z_MCOST)
call dpseuclid (K_N,YD_R,YD_X,Z_RTX)
call dpseuclid (K_N,YD_B,YD_X,Z_BTX)
Z_COST = 0.5e0_JPRB*(Z_RTX - Z_BTX)
Z_COST0 = P_F0 + 2*Z_COST
if (Z_COST > 0.999999e0_JPRB*Z_MCOST) then
  K_MODE=8
  if (K_IMP > 0) write (K_IO,915)
  goto 1000
endif
915 format(/4x,"n1cga-ERROR: Z_COST increase (rounding error)")

!     --- r2=|r|^2

call dpseuclid (K_N,YD_R,YD_R,Z_R2)

!     --- prepare to check conjugacy
!         gperp = (rmo,r)/|rmo|/|r| == 0 ?

call dpseuclid (K_N,YD_RM,YD_R,Z_GPERP)
Z_T=sqrt(Z_R2*Z_RM2)
if (Z_T /= 0.0_JPRB) then
  Z_GPERP=Z_GPERP/Z_T
else
  Z_GPERP=0.0_JPRB
endif

!     --- new rm
!         rm2 = |rm|^2
!         new pprr=prr
!         prr=<Pr,r>

YD_RM = YD_R

if (K_BFGSP == 2) then
  call dbfgsl (K_N,YD_RM,K_M0,K_NYS0,K_JMIN0,K_JMAX0,YD_YBAR0,YD_SBAR0,P_RHO,P_SIZE0)
endif
call dpseuclid (K_N,YD_RM,YD_RM,Z_RM2)
pprr=Z_PRR
call dpseuclid (K_N,YD_R,YD_RM,Z_PRR)

!     --- some printings

if (K_IMP >= 2) then
  call dpseuclid (K_N,YD_RM,YD_RM,Z_SP)
  Z_DANGLE=0.e0_JPRB
  if (sqrt(Z_SP*Z_R2) /= 0.0_JPRB) then
    Z_AUX1 = Z_PRR/sqrt(Z_SP*Z_R2)
    if (Z_AUX1 < -1.e0_JPRB) Z_AUX1 = -1.e0_JPRB
    if (Z_AUX1 > 1e0_JPRB) Z_AUX1 = 1.e0_JPRB
    Z_DANGLE=acos(Z_AUX1)/Z_PI*180.e0_JPRB
  endif
  if (K_ITER == 1) write (K_IO,905)
  write (K_IO,902) K_ITER,Z_COST0,sqrt(Z_R2/Z_R2I),Z_DANGLE,Z_RAYL,Z_GPERP,&
   & Z_ALPHA,sqrt(Z_X2),CL_SC  
  call flush (K_IO)
endif
905 format (/4x,"n1cga: K_ITER",6x,"Z_COST",7x,"|YD_R|/|r0|",2x,"<(YD_R,Pr)",&
 & "(Av,YD_V)/|YD_V|^2",4x,"conj",3x,"Z_ALPHA",4x,"|YD_X|",3x,"S")  
902 format (4x,"n1cga:",i5,1x,1pe13.6,1x,e12.6,1x,0pf5.2,1x,1pe12.6,&
 & 1x,e9.2,1x,e6.0,1x,e7.1,1x,A1)  

!     --- stop on the relative residual (eps2)

Z_RR=Z_R2/Z_R2I
if (Z_RR <= P_EPS2) then
  K_MODE=0
  if (K_IMP > 0) write (K_IO,916) sqrt(Z_RR),sqrt(P_EPS2)
  goto 1000
endif
916 format(/4x,"n1cga: stopping criterion satisfied, |YD_R|/|r0| = ",&
 & 1pe8.2," <= ",e8.2)  

!     --- FR beta, new v, v2=|v|^2

80 continue 
Z_BETA=Z_PRR/pprr
YD_V%data = -YD_RM%data + Z_BETA*YD_V%data
call dpseuclid (K_N,YD_V,YD_V,Z_V2)

!     --- loop

goto 100

! --- terminaison

1000 continue
P_EPS2=Z_RR
if (K_IMP == 1) write (K_IO,920) K_ITER,sqrt(Z_R2I),sqrt(Z_R2)
920 format(4x,"n1cga: I_NITER=",i5,", |YD_R|:",d13.6," -> ",d13.6)

!     ---- inverse change of var. for x

YD_X%data = YD_X%data * YD_YRS%data

IF (LHOOK) CALL DR_HOOK('N1CGA',1,ZHOOK_HANDLE)
end subroutine n1cga
