subroutine dysave (K_N,YD_Y,YD_S,P_YS,K_M,K_NYS,K_JMIN,K_JMAX,YD_YBAR,YD_SBAR,K_SELECT,&
 & K_IITER,P_OL,K_JOL,P_EPS,P_SIZE,K_MODE,K_PLEV,K_IO)  

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

use CONTROL_VECTORS

IMPLICIT NONE
INTEGER(KIND=JPIM),INTENT(IN)    :: K_M 
INTEGER(KIND=JPIM)               :: K_N ! Argument NOT used
TYPE(CONTROL_VECTOR),INTENT(IN)    :: YD_Y 
TYPE(CONTROL_VECTOR),INTENT(IN)    :: YD_S 
REAL(KIND=JPRH)   ,INTENT(IN)    :: P_YS 
INTEGER(KIND=JPIM),INTENT(INOUT) :: K_NYS 
INTEGER(KIND=JPIM),INTENT(INOUT) :: K_JMIN 
INTEGER(KIND=JPIM),INTENT(INOUT) :: K_JMAX 
TYPE(CONTROL_VECTOR),INTENT(INOUT) :: YD_YBAR(K_M) 
TYPE(CONTROL_VECTOR),INTENT(INOUT) :: YD_SBAR(K_M) 
INTEGER(KIND=JPIM),INTENT(IN)    :: K_SELECT 
INTEGER(KIND=JPIM),INTENT(IN)    :: K_IITER 
REAL(KIND=JPRB)   ,INTENT(INOUT) :: P_OL(K_M) 
INTEGER(KIND=JPIM),INTENT(INOUT) :: K_JOL(K_M) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: P_EPS 
REAL(KIND=JPRB)   ,INTENT(OUT)   :: P_SIZE 
INTEGER(KIND=JPIM),INTENT(OUT)   :: K_MODE 
INTEGER(KIND=JPIM),INTENT(IN)    :: K_PLEV 
INTEGER(KIND=JPIM),INTENT(IN)    :: K_IO 
!----

!     Save a pair (y,s)/sqrt(ys) in YBAR and SBAR and update the
!     Oren-Luenberger factor OLFACT.

!     Input:

!       ys: Euclidean scalar product (y,s). Must be positive.
!       nys: number of (y,s) pairs having been received. Must be
!         initialized to 0 before calling dysave for the first time.
!       select monitors the selection of the pairs (y,s) to build the
!         l-BFGS preconditioning matrix, with the following meanings:
!         =0: no particular selection, FIFO policy
!         =1: mexican selection (the pairs are distributed uniformely
!             on the iteration counter iiter for a particular CG run,
!             at each new run the previous pairs are discarded and a
!             new l-bfgs matrix is build from scratch)
!         =2: selection by the Rayleigh quotient; the aim is to obtain
!             uniformely distributed OL factors in the logarithmic
!             scale
!       iiter: integer giving the index of the current inner iteration
!         when dysave is called.
!       jol(m): jol(i) is the index of the pair (y,s) with the i-th
!         smallest OL factor.
!       eps = epsilon for detecting negative curvature directions,
!         whose square root is used for selecting good pairs.
!       size: scalar preconditioner.

!     Output:

!       mode: output mode
!         =-1: the (y,s) pair is not selected
!         =0 : good call,
!         =1 : the number m of pairs that can be stored in (ybar,sbar)
!              is <= 0.
!         =2 : ys <= 0.
!         =3 : unknown value of select

!----

! --- local variables

INTEGER(KIND=JPIM) :: i,i2,j,jcour,I_ODIFF
REAL(KIND=JPRB) :: Z_RMIN,Z_R,Z_OLMED,Z_OLDQ,Z_NEWQ,Z_OL0,Z_OL1,Z_OL2,Z_OL3,Z_OLX,Z_OLVAR,Z_OLVAR1,Z_OLVAR2,Z_EXPO
REAL(KIND=JPRH) :: Z_OLF
REAL(KIND=JPRB) :: ZHOOK_HANDLE

#include "dpseuclid.h"

! --- check the input

IF (LHOOK) CALL DR_HOOK('DYSAVE',0,ZHOOK_HANDLE)
if (K_M <= 0) then
  K_MODE=1
  if (K_PLEV >= 1) write (K_IO,900) K_M
  IF (LHOOK) CALL DR_HOOK('DYSAVE',1,ZHOOK_HANDLE)
  return
endif
900 format (/" dysave-ERROR: non positive number of updates K_M = ",i5)

if (P_YS <= 0.0_JPRB) then
  K_MODE=2
  if (K_PLEV >= 1) write (K_IO,901) P_YS
  901 format (/" dysave-ERROR: non positive scalar product",&
   & " (YD_Y,YD_S) = ",1pd12.5)  
  IF (LHOOK) CALL DR_HOOK('DYSAVE',1,ZHOOK_HANDLE)
  return
endif

! --- initialization

K_MODE=0
Z_RMIN=1.e-20_JPRB

! --- Oren-Luenberger factor

!     call dpseuclid (n,y,y,olf)
!     olf=ys/olf

!     for a quadratic function, I prefer

call dpseuclid (K_N,YD_S,YD_S,Z_OLF)
Z_OLF=Z_OLF/P_YS
!>          print *,"olf=",olf
if (K_PLEV >= 5) write (K_IO,902) Z_OLF
902 format (/4x,"dysave: inverse Oren-Luenberger factor: ",&
 & "|YD_S|^2/(YD_Y,YD_S) = ",1pe10.3)  

! --- select the pair to discard if any and update the pointers

!     --- is this a good pair to save ?

if (K_SELECT >= 0.and. Z_OLF < sqrt(P_EPS)) then
  K_MODE=-1
  IF (LHOOK) CALL DR_HOOK('DYSAVE',1,ZHOOK_HANDLE)
  return
endif

!     --- accept any pair, discard the oldest one

if (K_SELECT == 0) then
  if (K_NYS == 0) then
    K_JMIN=1
    K_JMAX=0
  endif
  K_NYS=K_NYS+1
  K_JMAX=K_JMAX+1
  if (K_JMAX > K_M) K_JMAX=K_JMAX-K_M
  if (K_NYS > K_M) then
    K_JMIN=K_JMIN+1
    if (K_JMIN > K_M) K_JMIN=K_JMIN-K_M
  endif
  jcour=K_JMAX
  P_OL(jcour)=Z_OLF

!     --- mexican selection

elseif (K_SELECT == 1) then
  if (K_IITER == 1) K_NYS=0
  if (K_NYS == 0) then
    K_JMIN=1
    K_JMAX=0
    do i=1,K_M
      K_JOL(i)=0
    enddo
  endif
  K_NYS=K_NYS+1
  if (K_NYS <= K_M) then
    K_JMAX=K_JMAX+1
    K_JOL(K_JMAX)=K_IITER
    jcour=K_JMAX
  elseif (K_M == 2) then
    K_JOL(2)=K_IITER
    jcour=2
  elseif (K_M > 2) then

!         --- reject current pair if iiter is too close to jol(m-1)
!             jol gives the iteration number of the selected pairs
!             they are supposed to be in order of iteration
!             here jmin=1 and jmax=m (always)

    I_ODIFF=K_JOL(K_M)-K_JOL(K_M-1)
    if (K_IITER-K_JOL(K_M)  <  I_ODIFF) then
      K_MODE=-1
      IF (LHOOK) CALL DR_HOOK('DYSAVE',1,ZHOOK_HANDLE)
      return
    endif

!         --- select the pair jcour to discard

    do j=1,K_M-1
      jcour=j+1
      if (K_JOL(jcour)-K_JOL(j)  ==  I_ODIFF) goto 10
    enddo
    10 continue

!         --- shift the other (ybar,sbar) and jol
!>>>>>>>>>>>> playing with pointers instead of with the actual pairs
!             would yield a saving in time (TO DO if the selection is
!             efficient)

    do j=jcour+1,K_M
      K_JOL(j-1)=K_JOL(j)
      YD_YBAR(j-1) = YD_YBAR(j)
      YD_SBAR(j-1) = YD_SBAR(j)
    enddo
    K_JOL(K_M)=K_IITER
    jcour=K_M
  endif
  P_OL(jcour)=Z_OLF
!         print *,"jol=",(jol(i),i=1,m)

!     --- selection by the Rayleigh quotient

elseif (K_SELECT == 2) then

!>>>>>>>> the following should be changed in the futur so that a
!         matrix build in a previous CG run could be updated (TO DO)

  if (K_IITER == 1) K_NYS=0
  if (K_NYS == 0) then
    K_JMIN=1
    K_JMAX=0
    do i=1,K_M
      K_JOL(i)=0
    enddo
  endif

!         --- it remains to set nys, jmax, jcour, ol(), and jol()

  if (K_M == 1) then
    K_NYS=1
    K_JMAX=1
    jcour=1
    P_OL(1)=Z_OLF
    K_JOL(1)=1
  elseif (K_NYS < K_M) then

!             --- select the current pair, since there is enough space
!                 to save it

    K_JMAX=K_JMAX+1
    jcour=K_JMAX
    P_OL(jcour)=Z_OLF

!             --- it remains to set jol(); for this, sort the saved
!                 pairs according to their OL factor

    if (K_NYS == 0) then
      K_JOL(1)=1
    else

!                 --- find the smallest index i2 such that
!                     ol(jol(i2)) >= olf, this is the position of the
!                     current OLF

      i2=1
      101 continue
      if (P_OL(K_JOL(i2)) >= Z_OLF) goto 102
      i2=i2+1
      if (i2 <= K_NYS) goto 101
      102 continue

!                 --- shift jol(i), for i>=i2

      if (i2 <= K_NYS) then
        do i=K_NYS,i2,-1
          K_JOL(i+1)=K_JOL(i)
        enddo
      endif
      K_JOL(i2)=jcour
    endif
    K_NYS=K_NYS+1

  else

!             --- here, if the current (y,s) is selected, an older one
!                 must be discarded;

!                 here, nys>=m (updated at the end of the ELSE), jmax=m
!                 (no longer udated); it remains to set jcour (inside
!                 the long if-then-else below and ol(jcour)=olf (at the
!                 end of the ELSE);

!                 start by finding the smallest index i2 such that
!                 ol(jol(i2)) >= olf, this is the position of the
!                 current OLF

    i2=1
    103 continue
    if (P_OL(K_JOL(i2)) >= Z_OLF) goto 104
    i2=i2+1
    if (i2 <= K_M) goto 103
    104 continue
    if (i2 == 1) then

!                 --- olf is smaller than all the other OL factors
!                     ==> save the (y,s) pair

      jcour=K_JOL(1)
    elseif (i2 > K_M) then

!                 --- olf is greater than all the other OL factors
!                     ==> save the (y,s) pair

      jcour=K_JOL(K_M)
    elseif (K_M == 2) then

!                 --- reject the (y,s) pair, since when m=2, we want to
!                     save the pairs with the extreme OL factors

      K_MODE=-1
      IF (LHOOK) CALL DR_HOOK('DYSAVE',1,ZHOOK_HANDLE)
      return
    elseif (i2 == 2) then

!                 --- check whether to replace the pair jol(2), by
!                     looking at jol(1), jol(2), and jol(3)

      Z_OLMED=sqrt(P_OL(K_JOL(1))*P_OL(K_JOL(3)))
      Z_OLDQ=P_OL(K_JOL(2))/Z_OLMED
      if (Z_OLDQ < 1.e0_JPRB) Z_OLDQ=1.e0_JPRB/Z_OLDQ
      Z_NEWQ=Z_OLF/Z_OLMED
      if (Z_NEWQ < 1.e0_JPRB) Z_NEWQ=1.e0_JPRB/Z_NEWQ
      if (Z_NEWQ >= Z_OLDQ) then
        K_MODE=-1
        IF (LHOOK) CALL DR_HOOK('DYSAVE',1,ZHOOK_HANDLE)
        return
      endif
      jcour=K_JOL(2)
    elseif (i2 == K_M) then

!                 --- check whether to replace the pair jol(m-1), by
!                     looking at jol(m-2), jol(m-1), and jol(m)

      Z_OLMED=sqrt(P_OL(K_JOL(K_M-2))*P_OL(K_JOL(K_M)))
      Z_OLDQ=P_OL(K_JOL(K_M-1))/Z_OLMED
      if (Z_OLDQ < 1.e0_JPRB) Z_OLDQ=1.e0_JPRB/Z_OLDQ
      Z_NEWQ=Z_OLF/Z_OLMED
      if (Z_NEWQ < 1.e0_JPRB) Z_NEWQ=1.e0_JPRB/Z_NEWQ
      if (Z_NEWQ >= Z_OLDQ) then
        K_MODE=-1
        IF (LHOOK) CALL DR_HOOK('DYSAVE',1,ZHOOK_HANDLE)
        return
      endif
      jcour=K_JOL(K_M-1)
    else

!                 --- here m>=4;
!                     check whether to replace the pair jol(i2-1) or
!                     jol(i2), by looking at jol(i2-2), jol(i2-1),
!                     jol(i2), and jol(i2+1)

      Z_OL0=log(P_OL(K_JOL(i2-2)))
      Z_OL1=log(P_OL(K_JOL(i2-1)))
      Z_OL2=log(P_OL(K_JOL(i2)))
      Z_OL3=log(P_OL(K_JOL(i2+1)))
      Z_OLX=log(Z_OLF)
      Z_OLVAR =max(Z_OL1-Z_OL0,Z_OL2-Z_OL1,Z_OL3-Z_OL2)
      Z_OLVAR1=max(Z_OLX-Z_OL0,Z_OL2-Z_OLX,Z_OL3-Z_OL2)
      Z_OLVAR2=max(Z_OL1-Z_OL0,Z_OLX-Z_OL1,Z_OL3-Z_OLX)
      if (Z_OLVAR <= min(Z_OLVAR1,Z_OLVAR2)) then
        K_MODE=-1
        IF (LHOOK) CALL DR_HOOK('DYSAVE',1,ZHOOK_HANDLE)
        return
      elseif (Z_OLVAR1 < Z_OLVAR2) then
        jcour=K_JOL(i2-1)
      else
        jcour=K_JOL(i2)
      endif
    endif

!             --- save the pair

    K_NYS=K_NYS+1
    P_OL(jcour)=Z_OLF
  endif
!>          print *," "
!>          print *,(ol(i),i=1,min(nys,m))
!>          print *,"jol=",(jol(i),i=1,min(nys,m))
!>          write(6,999) (ol(jol(i)),i=1,min(nys,m))
!>  999     format (1pe12.6,2x,50(e12.6,2x))
else

!     --- unknown value of select

  K_MODE=3
  if (K_PLEV >= 1) write (K_IO,903) K_SELECT
  903 format (/" dysave-ERROR: unknown selection procedure,"" K_SELECT = ",i5)
  IF (LHOOK) CALL DR_HOOK('DYSAVE',1,ZHOOK_HANDLE)
  return
endif

! --- store ybar et sbar

Z_R=sqrt(1.e0_JPRB/P_YS)
YD_YBAR(jcour)%data = Z_R*YD_Y%data
YD_SBAR(jcour)%data = Z_R*YD_S%data

! --- save the OL factor

!     --- the simplest strategy is to take the OL factor at the
!         first CG iteration (the function is supposed to be
!         quadratic)

if (K_NYS == 1) P_SIZE=Z_OLF

!     --- another strategy is to take the geometric means of the
!         previous OL factors (taking the d'OL factor, the closest
!         in the logarithmic scale to this geometric means give
!         approximately the same results)

Z_OLMED=1.e0_JPRB
Z_EXPO=1.e0_JPRB/real(min(K_NYS,K_M),JPRB)
do j=1,min(K_NYS,K_M)
  Z_OLMED=Z_OLMED*(P_OL(j)**Z_EXPO)
enddo
P_SIZE = Z_OLMED
IF (LHOOK) CALL DR_HOOK('DYSAVE',1,ZHOOK_HANDLE)
!      print *,"ol=",(ol(j),j=1,min(nys,m))
!      print *,"olmed=",olmed

end subroutine dysave
