lbfgs_jpl_version/lsopt.2/lsupdxx.F


      subroutine lsupdxx(
     &     nn, ifail, lphprint
     &     , jmin, jmax, nupdate
     &     , ff, fmin, fold, gnorm0, dotdg
     &     , gg, dd, xx, xdiff
     &     , tmin, tmax, tact, epsx
     &     )

c     ==================================================================
c     SUBROUTINE lsupdxx
c     ==================================================================
c
c     o conceived for variable online/offline version
c       computes - new descent direction dd based on latest 
c                  available gradient
c                - new tact based on new dd
c                - new control vector xx needed for offline run
c
c     o started: Patrick Heimbach, MIT/EAPS
c                29-Feb-2000: 
c
c     o Version 2.1.0, 02-Mar-2000: Patrick Heimbach, MIT/EAPS
c
c     ==================================================================
c     SUBROUTINE lsupdxx
c     ==================================================================
c

#include "blas1.h"
      implicit none
      include 'mpif.h'

c-----------------------------------------
c declare arguments
c-----------------------------------------
      integer nmax
      parameter( nmax = MAX_INDEPEND )
      integer nn, jmin, jmax, nupdate, ifail
      double precision    ff, fmin, fold, gnorm0, dotdg,dnorm
      double precision    gg(nn), dd(nn), xx(nn), xdiff(nn)
      double precision    tmin, tmax, tact, epsx,temp
      logical lphprint

      integer pidlen,myindx(2)
      integer status(MPI_STATUS_SIZE),ierr
      integer myid, nprocs,mystart,myend
      common /mpi_parm/ myid,nprocs,mystart,myend

c-----------------------------------------
C declare local variables
c-----------------------------------------
      integer i
      double precision    fdiff, preco

      real*8,allocatable:: vv(:)
      integer, allocatable:: displs(:)
      integer, allocatable:: counts(:) 
      double precision     DDOT,DNRM2
      external DDOT,DNRM2

c     ==================================================================

c-----------------------------------------
c use Fletchers scaling
c and initialize diagional to 1.
c-----------------------------------------
c
      if ( ( jmax .eq. 0 ) .or. (nupdate .eq. 0 ) ) then

         if (jmax .eq. 0) then
            fold = fmin
!            if (lphprint .and. myid .eq. 0) 
!     &           print *, 'pathei-lsopt: using fold = fmin = ', fmin
         end if
!         fdiff = fold - ff
         fdiff = .01D0*ff
         if (jmax .eq. 0) fdiff = ABS(fdiff)
         
         preco = 2. * fdiff / (gnorm0*gnorm0)
         do i = 1, nn
            dd(i)    = -gg(i)*preco
         end do

         if (lphprint .and. myid .eq. 0) 
     &        print *, 'pathei-lsopt: first estimate of dd via ',
     &        '.01*ff'

c-----------------------------------------
c use the matrix stored in [diag]
c and the (y,s) pairs
c-----------------------------------------

      else

            do i = 1, nn
               dd(i) = -gg(i)
            end do

            if (jmax .gt. 0) then
               call hessupd( nn, nupdate, dd, jmin, jmax, xdiff, 
     &              lphprint )
            else
               if (lphprint .and. myid .eq. 0) 
     &              print *, 'pathei-lsopt: no hessupd for first optim.'
            end if

      endif

c-----------------------------------------
c check whether new direction is a descent one
c-----------------------------------------

         temp  = DDOT( nn, dd, 1, gg, 1 )
         call MPI_ALLREDUCE(temp,dotdg,1,MPI_DOUBLE_PRECISION,MPI_SUM,MPI_COMM_WORLD,ierr)
         
         if (dotdg .ge. 0.0) then
            ifail = 4
            if(myid .eq. 0) print *,'bnc: ifail = 4, dotdg > 0.'
            goto 999
         end if

c----------------------------------
c declare arguments
c----------------------------------

      tmin = 0.
      do i = 1, nn
         tmin = max( tmin, abs(dd(i)) )
      end do
      temp = tmin
      call MPI_ALLREDUCE(temp,tmin,1,MPI_DOUBLE_PRECISION,MPI_MAX,MPI_COMM_WORLD,ierr)
      tmin = epsx/tmin

c----------------------------------
c make sure that t is between
c tmin and tmax
c----------------------------------

      tact  = 1.0
      tmax = 1.0e+10
      if (tact.le.tmin) then
         tact = tmin
         if (tact.gt.tmax) then
            tmin = tmax
         endif
      endif

      if (tact .gt. tmax) then
          tact = tmax
          ifail = 7
      endif

c----------------------------------
c compute new x
c----------------------------------
         temp = DNRM2(nn,dd,1)
         call MPI_ALLREDUCE(temp*temp,dnorm,1,MPI_DOUBLE_PRECISION,MPI_SUM,MPI_COMM_WORLD,ierr)
         dnorm = dsqrt(dnorm)

      if (myid .eq. 0) then
      print *,'bnc: initial stepsize tact = ',tact
      print *,'bnc: norm of dd            = ',dnorm
      endif

      do i = 1, nn
         xdiff(i) = xx(i) + tact*dd(i)
      end do

c----------------------------------
c save new x to file for offline version
c----------------------------------

 999  continue

      return

      end
1	heimbach	1.1
2			subroutine lsupdxx(
3			& nn, ifail, lphprint
4			& , jmin, jmax, nupdate
5			& , ff, fmin, fold, gnorm0, dotdg
6			& , gg, dd, xx, xdiff
7			& , tmin, tmax, tact, epsx
8			& )
9
10			c ==================================================================
11			c SUBROUTINE lsupdxx
12			c ==================================================================
13			c
14			c o conceived for variable online/offline version
15			c computes - new descent direction dd based on latest
16			c available gradient
17			c - new tact based on new dd
18			c - new control vector xx needed for offline run
19			c
20			c o started: Patrick Heimbach, MIT/EAPS
21			c 29-Feb-2000:
22			c
23			c o Version 2.1.0, 02-Mar-2000: Patrick Heimbach, MIT/EAPS
24			c
25			c ==================================================================
26			c SUBROUTINE lsupdxx
27			c ==================================================================
28			c
29
30			#include "blas1.h"
31			implicit none
32			include 'mpif.h'
33
34			c-----------------------------------------
35			c declare arguments
36			c-----------------------------------------
37			integer nmax
38			parameter( nmax = MAX_INDEPEND )
39			integer nn, jmin, jmax, nupdate, ifail
40			double precision ff, fmin, fold, gnorm0, dotdg,dnorm
41			double precision gg(nn), dd(nn), xx(nn), xdiff(nn)
42			double precision tmin, tmax, tact, epsx,temp
43			logical lphprint
44
45			integer pidlen,myindx(2)
46			integer status(MPI_STATUS_SIZE),ierr
47			integer myid, nprocs,mystart,myend
48			common /mpi_parm/ myid,nprocs,mystart,myend
49
50			c-----------------------------------------
51			C declare local variables
52			c-----------------------------------------
53			integer i
54			double precision fdiff, preco
55
56			real*8,allocatable:: vv(:)
57			integer, allocatable:: displs(:)
58			integer, allocatable:: counts(:)
59			double precision DDOT,DNRM2
60			external DDOT,DNRM2
61
62			c ==================================================================
63
64			c-----------------------------------------
65			c use Fletchers scaling
66			c and initialize diagional to 1.
67			c-----------------------------------------
68			c
69			if ( ( jmax .eq. 0 ) .or. (nupdate .eq. 0 ) ) then
70
71			if (jmax .eq. 0) then
72			fold = fmin
73			! if (lphprint .and. myid .eq. 0)
74			! & print *, 'pathei-lsopt: using fold = fmin = ', fmin
75			end if
76			! fdiff = fold - ff
77			fdiff = .01D0*ff
78			if (jmax .eq. 0) fdiff = ABS(fdiff)
79
80			preco = 2. * fdiff / (gnorm0*gnorm0)
81			do i = 1, nn
82			dd(i) = -gg(i)*preco
83			end do
84
85			if (lphprint .and. myid .eq. 0)
86			& print *, 'pathei-lsopt: first estimate of dd via ',
87			& '.01*ff'
88
89			c-----------------------------------------
90			c use the matrix stored in [diag]
91			c and the (y,s) pairs
92			c-----------------------------------------
93
94			else
95
96			do i = 1, nn
97			dd(i) = -gg(i)
98			end do
99
100			if (jmax .gt. 0) then
101			call hessupd( nn, nupdate, dd, jmin, jmax, xdiff,
102			& lphprint )
103			else
104			if (lphprint .and. myid .eq. 0)
105			& print *, 'pathei-lsopt: no hessupd for first optim.'
106			end if
107
108			endif
109
110			c-----------------------------------------
111			c check whether new direction is a descent one
112			c-----------------------------------------
113
114			temp = DDOT( nn, dd, 1, gg, 1 )
115			call MPI_ALLREDUCE(temp,dotdg,1,MPI_DOUBLE_PRECISION,MPI_SUM,MPI_COMM_WORLD,ierr)
116
117			if (dotdg .ge. 0.0) then
118			ifail = 4
119			if(myid .eq. 0) print *,'bnc: ifail = 4, dotdg > 0.'
120			goto 999
121			end if
122
123			c----------------------------------
124			c declare arguments
125			c----------------------------------
126
127			tmin = 0.
128			do i = 1, nn
129			tmin = max( tmin, abs(dd(i)) )
130			end do
131			temp = tmin
132			call MPI_ALLREDUCE(temp,tmin,1,MPI_DOUBLE_PRECISION,MPI_MAX,MPI_COMM_WORLD,ierr)
133			tmin = epsx/tmin
134
135			c----------------------------------
136			c make sure that t is between
137			c tmin and tmax
138			c----------------------------------
139
140			tact = 1.0
141			tmax = 1.0e+10
142			if (tact.le.tmin) then
143			tact = tmin
144			if (tact.gt.tmax) then
145			tmin = tmax
146			endif
147			endif
148
149			if (tact .gt. tmax) then
150			tact = tmax
151			ifail = 7
152			endif
153
154			c----------------------------------
155			c compute new x
156			c----------------------------------
157			temp = DNRM2(nn,dd,1)
158			call MPI_ALLREDUCE(temp*temp,dnorm,1,MPI_DOUBLE_PRECISION,MPI_SUM,MPI_COMM_WORLD,ierr)
159			dnorm = dsqrt(dnorm)
160
161			if (myid .eq. 0) then
162			print *,'bnc: initial stepsize tact = ',tact
163			print *,'bnc: norm of dd = ',dnorm
164			endif
165
166			do i = 1, nn
167			xdiff(i) = xx(i) + tact*dd(i)
168			end do
169
170			c----------------------------------
171			c save new x to file for offline version
172			c----------------------------------
173
174			999 continue
175
176			return
177
178			end