!--------------------------------------- LICENCE BEGIN -----------------------------------
!Environment Canada - Atmospheric Science and Technology License/Disclaimer,
! version 3; Last Modified: May 7, 2008.
!This is free but copyrighted software; you can use/redistribute/modify it under the terms
!of the Environment Canada - Atmospheric Science and Technology License/Disclaimer
!version 3 or (at your option) any later version that should be found at:
!http://collaboration.cmc.ec.gc.ca/science/rpn.comm/license.html
!
!This software is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY;
!without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
!See the above mentioned License/Disclaimer for more details.
!You should have received a copy of the License/Disclaimer along with this software;
!if not, you can write to: EC-RPN COMM Group, 2121 TransCanada, suite 500, Dorval (Quebec),
!CANADA, H9P 1J3; or send e-mail to service.rpn@ec.gc.ca
!-------------------------------------- LICENCE END --------------------------------------
subroutine ddd (prosca,dtonb,dtcab,n,sscale,nm,depl,aux,jmin,jmax, 2
& precos,diag,ybar,sbar,izs,rzs,dzs)
c----
c
c calcule le produit H.g ou
c . H est une matrice construite par la formule de bfgs inverse
c a nm memoires a partir de la matrice diagonale diag
c dans un espace hilbertien dont le produit scalaire
c est donne par prosca
c (cf. J. Nocedal, Math. of Comp. 35/151 (1980) 773-782)
c . g est un vecteur de dimension n (en general le gradient)
c
c la matrice diag apparait donc comme un preconditionneur diagonal
c
c depl = g (en entree), = H g (en sortie)
c
c la matrice H est memorisee par les vecteurs des tableaux
c ybar, sbar et les pointeurs jmin, jmax
c
c alpha(nm) est une zone de travail
c
c izs(1),rzs(1),dzs(1) sont des zones de travail pour prosca
c
c----
c
c arguments
c
logical sscale
integer n,nm,jmin,jmax,izs(1)
real rzs(1)
double precision depl(n),precos,diag(n),alpha(nm),ybar(n,1),
& sbar(n,1),aux(n),dzs(1)
external prosca,dtonb,dtcab
c
c variables locales
c
integer jfin,i,j,jp
double precision r,ps
c
call tmg_start(72,'DDD')
jfin=jmax
if (jfin.lt.jmin) jfin=jmax+nm
c
c phase de descente
c
do 100 j=jfin,jmin,-1
jp=j
if (jp.gt.nm) jp=jp-nm
call prosca (n,depl,sbar(1,jp),ps,izs,rzs,dzs)
r=ps
alpha(jp)=r
!$OMP PARALLEL DO DEFAULT(SHARED) PRIVATE(I)
do 20 i=1,n
depl(i)=depl(i)-r*ybar(i,jp)
20 continue
!$OMP END PARALLEL DO
100 continue
c
c preconditionnement
c
if (sscale) then
!$OMP PARALLEL DO DEFAULT(SHARED) PRIVATE(I)
do 150 i=1,n
depl(i)=depl(i)*precos
150 continue
!$OMP END PARALLEL DO
else
call dtonb (n,depl,aux,izs,rzs,dzs)
!$OMP PARALLEL DO DEFAULT(SHARED) PRIVATE(I)
do 151 i=1,n
aux(i)=aux(i)*diag(i)
151 continue
!$OMP END PARALLEL DO
call dtcab (n,aux,depl,izs,rzs,dzs)
endif
c
c remontee
c
do 200 j=jmin,jfin
jp=j
if (jp.gt.nm) jp=jp-nm
call prosca (n,depl,ybar(1,jp),ps,izs,rzs,dzs)
r=alpha(jp)-ps
!$OMP PARALLEL DO DEFAULT(SHARED) PRIVATE(I)
do 120 i=1,n
depl(i)=depl(i)+r*sbar(i,jp)
120 continue
!$OMP END PARALLEL DO
200 continue
call tmg_stop(72)
return
end