subroutine dysave (n,y,s,ys,m,nys,jmin,jmax,ybar,sbar,select, 2
& iiter,ol,jol,nu,size,mode,plev,io,izs,
& rzs,dzs)
c
integer n,m,select,nys,jmin,jmax,iiter,jol(m),mode,plev,io,izs(1)
real rzs(1)
double precision y(n),s(n),ys,ybar(n,m),sbar(n,m),ol(m),nu,
& size,dzs(1)
c
c----
c
c Save a pair (y,s)/sqrt(ys) in YBAR and SBAR and update the
c Oren-Luenberger factor OLFACT.
c
c Input:
c
c ys: Euclidean scalar product (y,s). Must be positive.
c nys: number of (y,s) pairs having been received. Must be
c initialized to 0 before calling dysave for the first time.
c select monitors the selection of the pairs (y,s) to build the
c l-BFGS preconditioning matrix, with the following meanings:
c =0: no particular selection, FIFO policy
c =1: mexican selection (the pairs are distributed uniformely
c on the iteration counter iiter for a particular CG run,
c at each new run the previous pairs are discarded and a
c new l-bfgs matrix is build from scratch)
c =2: selection by the Rayleigh quotient; the aim is to obtain
c uniformely distributed OL factors in the logarithmic
c scale
c iiter: integer giving the index of the current inner iteration
c when dysave is called.
c jol(m): jol(i) is the index of the pair (y,s) with the i-th
c smallest OL factor.
c nu = epsilon for detecting negative curvature directions,
c whose square root is used for selecting good pairs.
c size: scalar preconditioner.
c
c Output:
c
c mode: output mode
c =-1: the (y,s) pair is not selected
c =0 : good call,
c =1 : the number m of pairs that can be stored in (ybar,sbar)
c is <= 0.
c =2 : ys <= 0.
c =3 : unknown value of select
c
c----
c
c --- local variables
c
integer i,i2,j,jcour,odiff
double precision rmin,r,olf,olmed,oldq,newq,ol0,ol1,ol2,
& ol3,olx,olvar,olvar1,olvar2
c
c --- check the input
c
if (m.le.0) then
mode=1
if (plev.ge.1) write (io,900) m
return
endif
900 format (/" dysave-ERROR: non positive number of updates m = ",i5)
c
if (ys.le.0.d0) then
mode=2
if (plev.ge.1) write (io,901) ys
901 format (/" dysave-ERROR: non positive scalar product",
& " (y,s) = ",1pd12.5)
return
endif
c
c --- initialization
c
mode=0
rmin=1.d-20
c
c --- Oren-Luenberger factor
c
c call deuclid (n,y,y,olf,izs,rzs,dzs)
c olf=ys/olf
c
c for a quadratic function, I prefer
c
call deuclid (n,s,s,olf,izs,rzs,dzs)
olf=olf/ys
c> print *,"olf=",olf
if (plev.ge.5) write (io,902) olf
902 format (/4x,"dysave: inverse Oren-Luenberger factor: ",
& "|s|^2/(y,s) = ",1pd10.3)
c
c --- select the pair to discard if any and update the pointers
c
c --- is this a good pair to save ?
c
if (select.ge.0 .and. olf.lt.sqrt(nu)) then
mode=-1
return
endif
c
c --- accept any pair, discard the oldest one
c
if (select.eq.0) then
if (nys.eq.0) then
jmin=1
jmax=0
endif
nys=nys+1
jmax=jmax+1
if (jmax.gt.m) jmax=jmax-m
if (nys.gt.m) then
jmin=jmin+1
if (jmin.gt.m) jmin=jmin-m
endif
jcour=jmax
ol(jcour)=olf
c
c --- mexican selection
c
elseif (select.eq.1) then
if (iiter.eq.1) nys=0
if (nys.eq.0) then
jmin=1
jmax=0
do i=1,m
jol(i)=0
enddo
endif
nys=nys+1
if (nys.le.m) then
jmax=jmax+1
jol(jmax)=iiter
jcour=jmax
elseif (m.eq.2) then
jol(2)=iiter
jcour=2
elseif (m.gt.2) then
c
c --- reject current pair if iiter is too close to jol(m-1)
c jol gives the iteration number of the selected pairs
c they are supposed to be in order of iteration
c here jmin=1 and jmax=m (always)
c
odiff=jol(m)-jol(m-1)
if (iiter-jol(m) .lt. odiff) then
mode=-1
return
endif
c
c --- select the pair jcour to discard
c
do j=1,m-1
jcour=j+1
if (jol(jcour)-jol(j) .eq. odiff) goto 10
enddo
10 continue
c
c --- shift the other (ybar,sbar) and jol
c>>>>>>>>>>>> playing with pointers instead of with the actual pairs
c would yield a saving in time (TO DO if the selection is
c efficient)
c
do j=jcour+1,m
jol(j-1)=jol(j)
do i=1,n
ybar(i,j-1)=ybar(i,j)
sbar(i,j-1)=sbar(i,j)
enddo
enddo
jol(m)=iiter
jcour=m
endif
ol(jcour)=olf
c print *,"jol=",(jol(i),i=1,m)
c
c --- selection by the Rayleigh quotient
c
elseif (select.eq.2) then
c
c>>>>>>>> the following should be changed in the futur so that a
c matrix build in a previous CG run could be updated (TO DO)
c
if (iiter.eq.1) nys=0
if (nys.eq.0) then
jmin=1
jmax=0
do i=1,m
jol(i)=0
enddo
endif
c
c --- it remains to set nys, jmax, jcour, ol(), and jol()
c
if (m.eq.1) then
nys=1
jmax=1
jcour=1
ol(1)=olf
jol(1)=1
elseif (nys.lt.m) then
c
c --- select the current pair, since there is enough space
c to save it
c
jmax=jmax+1
jcour=jmax
ol(jcour)=olf
c
c --- it remains to set jol(); for this, sort the saved
c pairs according to their OL factor
c
if (nys.eq.0) then
jol(1)=1
else
c
c --- find the smallest index i2 such that
c ol(jol(i2)) >= olf, this is the position of the
c current OLF
c
i2=1
101 continue
if (ol(jol(i2)).ge.olf) goto 102
i2=i2+1
if (i2.le.nys) goto 101
102 continue
c
c --- shift jol(i), for i>=i2
c
if (i2.le.nys) then
do i=nys,i2,-1
jol(i+1)=jol(i)
enddo
endif
jol(i2)=jcour
endif
nys=nys+1
c
else
c
c --- here, if the current (y,s) is selected, an older one
c must be discarded;
c
c here, nys>=m (updated at the end of the ELSE), jmax=m
c (no longer udated); it remains to set jcour (inside
c the long if-then-else below and ol(jcour)=olf (at the
c end of the ELSE);
c
c start by finding the smallest index i2 such that
c ol(jol(i2)) >= olf, this is the position of the
c current OLF
c
i2=1
103 continue
if (ol(jol(i2)).ge.olf) goto 104
i2=i2+1
if (i2.le.m) goto 103
104 continue
if (i2.eq.1) then
c
c --- olf is smaller than all the other OL factors
c ==> save the (y,s) pair
c
jcour=jol(1)
elseif (i2.gt.m) then
c
c --- olf is greater than all the other OL factors
c ==> save the (y,s) pair
c
jcour=jol(m)
elseif (m.eq.2) then
c
c --- reject the (y,s) pair, since when m=2, we want to
c save the pairs with the extreme OL factors
c
mode=-1
return
elseif (i2.eq.2) then
c
c --- check whether to replace the pair jol(2), by
c looking at jol(1), jol(2), and jol(3)
c
olmed=sqrt(ol(jol(1))*ol(jol(3)))
oldq=ol(jol(2))/olmed
if (oldq.lt.1.d0) oldq=1.d0/oldq
newq=olf/olmed
if (newq.lt.1.d0) newq=1.d0/newq
if (newq.ge.oldq) then
mode=-1
return
endif
jcour=jol(2)
elseif (i2.eq.m) then
c
c --- check whether to replace the pair jol(m-1), by
c looking at jol(m-2), jol(m-1), and jol(m)
c
olmed=sqrt(ol(jol(m-2))*ol(jol(m)))
oldq=ol(jol(m-1))/olmed
if (oldq.lt.1.d0) oldq=1.d0/oldq
newq=olf/olmed
if (newq.lt.1.d0) newq=1.d0/newq
if (newq.ge.oldq) then
mode=-1
return
endif
jcour=jol(m-1)
else
c
c --- here m>=4;
c check whether to replace the pair jol(i2-1) or
c jol(i2), by looking at jol(i2-2), jol(i2-1),
c jol(i2), and jol(i2+1)
c
ol0=log(ol(jol(i2-2)))
ol1=log(ol(jol(i2-1)))
ol2=log(ol(jol(i2)))
ol3=log(ol(jol(i2+1)))
olx=log(olf)
olvar =max(ol1-ol0,ol2-ol1,ol3-ol2)
olvar1=max(olx-ol0,ol2-olx,ol3-ol2)
olvar2=max(ol1-ol0,olx-ol1,ol3-olx)
if (olvar.le.min(olvar1,olvar2)) then
mode=-1
return
elseif (olvar1.lt.olvar2) then
jcour=jol(i2-1)
else
jcour=jol(i2)
endif
endif
c
c --- save the pair
c
nys=nys+1
ol(jcour)=olf
endif
c> print *," "
c> print *,(ol(i),i=1,min(nys,m))
c> print *,"jol=",(jol(i),i=1,min(nys,m))
c> write(6,999) (ol(jol(i)),i=1,min(nys,m))
c> 999 format (1pe12.6,2x,50(e12.6,2x))
else
c
c --- unknown value of select
c
mode=3
if (plev.ge.1) write (io,903) select
903 format (/" dysave-ERROR: unknown selection procedure,"
& ," select = ",i5)
return
endif
c
c --- store ybar et sbar
c
r=sqrt(1.d0/ys)
do i=1,n
ybar(i,jcour)=r*y(i)
sbar(i,jcour)=r*s(i)
enddo
c
c --- save the OL factor
c
c --- the simplest strategy is to take the OL factor at the
c first CG iteration (the function is supposed to be
c quadratic)
c
if (nys.eq.1) size=olf
c
c --- another strategy is to take the geometric means of the
c previous OL factors (taking the d'OL factor, the closest
c in the logarithmic scale to this geometric means give
c approximately the same results)
c
olmed=1.d0
do j=1,min(nys,m)
olmed=olmed*ol(j)
enddo
olmed=olmed**(1.d0/dble(min(nys,m)))
size=olmed
c print *,"ol=",(ol(j),j=1,min(nys,m))
c print *,"olmed=",olmed
c
1000 return
end
c
c--------0---------0---------0---------0---------0---------0---------0--
c