!--------------------------------------- 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 nlis0 (n,simul,prosca,xn,fn,fpn,t,tmin,tmax,d,g, 1,2
1 amd,amf,imp,io,logic,nap,napmax,x,izs,rzs,dzs)
c ----
c
c nlis0 + minuscules + commentaires
c + version amelioree (XII 88): interpolation cubique systematique
c et anti-overflows
c + declaration variables (II/89, JCG).
c + barr is also progressively decreased (12/93, CL & JChG).
c barmul is set to 5.
c
c ----------------------------------------------------------------
c
c en sortie logic =
c
c 0 descente serieuse
c 1 descente bloquee
c 4 nap > napmax
c 5 retour a l'utilisateur
c 6 fonction et gradient pas d'accord
c < 0 contrainte implicite active
c
c ----
c
c --- arguments
c
external simul,prosca
integer n,imp,io,logic,nap,napmax,izs(*)
real rzs(*)
double precision xn(n),fn,fpn,t,tmin,tmax,d(n),g(n),amd,amf,x(n),
/ dzs(*)
c
c --- variables locales
c
logical lfound,lfound2
integer i,indic,indica,indicd
double precision tesf,tesd,tg,fg,fpg,td,ta,fa,fpa,d2,f,fp,ffn,fd,
/ fpd,z,test,barmin,barmul,barmax,barr,gauche,droite,taa,ps
c
!bhe call tmg_start(74,'NLIS0')
1000 format (/4x,9h nlis0 ,4x,4hfpn=,d10.3,4h d2=,d9.2,
1 7h tmin=,d9.2,6h tmax=,d9.2)
1001 format (/4x,6h mlis0,3x,"stop on tmin",8x,
1 "step",11x,"functions",5x,"derivatives")
1002 format (4x,6h nlis0,37x,d10.3,2d11.3)
1003 format (4x,6h nlis0,d14.3,2d11.3)
1004 format (4x,6h nlis0,37x,d10.3,7h indic=,i3)
1005 format (4x,6h nlis0,14x,2d18.8,d11.3)
1006 format (4x,6h nlis0,14x,d18.8,12h indic=,i3)
1007 format (/4x,6h mlis0,10x,"tmin forced to tmax")
1008 format (/4x,6h mlis0,10x,"inconsistent call")
if (n.gt.0 .and. fpn.lt.0.d0 .and. t.gt.0.d0
1 .and. tmax.gt.0.d0 .and. amf.gt.0.d0
1 .and. amd.gt.amf .and. amd.lt.1.d0) go to 5
logic=6
go to 999
5 tesf=amf*fpn
tesd=amd*fpn
barmin=0.01d0
barmul=5.d0
barmax=0.3d0
barr=barmin
td=0.d0
tg=0.d0
fg=fn
fpg=fpn
ta=0.d0
fa=fn
fpa=fpn
call prosca (n,d,d,ps,izs,rzs,dzs)
d2=ps
c
c elimination d'un t initial ridiculement petit
c
if (t.gt.tmin) go to 20
t=tmin
if (t.le.tmax) go to 20
if (imp.gt.0) write (io,1007)
tmin=tmax
20 if (fn+t*fpn.lt.fn+0.9d0*t*fpn) go to 30
t=2.d0*t
go to 20
30 indica=1
logic=0
if (t.gt.tmax) then
t=tmax
logic=1
endif
if (imp.ge.4) write (io,1000) fpn,d2,tmin,tmax
c
c --- nouveau x
c
do 50 i=1,n
x(i)=xn(i)+t*d(i)
50 continue
c
c --- boucle
c
100 nap=nap+1
if(nap.gt.napmax) then
logic=4
fn=fg
do 120 i=1,n
xn(i)=xn(i)+tg*d(i)
120 continue
go to 999
endif
indic=4
c
c --- appel simulateur
c
call tmg_stop(74)
call simul(indic,n,x,f,g,izs,rzs,dzs)
call tmg_start(74,'NLIS0')
if(indic.eq.0) then
c
c --- arret demande par l'utilisateur
c
logic=5
fn=f
do 170 i=1,n
xn(i)=x(i)
170 continue
go to 999
endif
if(indic.lt.0) then
c
c --- les calculs n'ont pas pu etre effectues par le simulateur
c
td=t
indicd=indic
logic=0
if (imp.ge.4) write (io,1004) t,indic
t=tg+0.1d0*(td-tg)
go to 905
endif
c
c --- les tests elementaires sont faits, on y va
c
call prosca (n,d,g,ps,izs,rzs,dzs)
fp=ps
c
c --- premier test de Wolfe
c
ffn=f-fn
if(ffn.gt.t*tesf) then
td=t
fd=f
fpd=fp
indicd=indic
logic=0
if(imp.ge.4) write (io,1002) t,ffn,fp
go to 500
endif
c
c --- test 1 ok, donc deuxieme test de Wolfe
c
if(imp.ge.4) write (io,1003) t,ffn,fp
if(fp.gt.tesd) then
logic=0
go to 320
endif
if (logic.eq.0) go to 350
c
c --- test 2 ok, donc pas serieux, on sort
c
320 fn=f
do 330 i=1,n
xn(i)=x(i)
330 continue
go to 999
c
c
c
350 tg=t
fg=f
fpg=fp
if(td.ne.0.d0) go to 500
c
c extrapolation
c
taa=t
gauche=(1.d0+barmin)*t
droite=10.d0*t
call dcube
(t,f,fp,ta,fa,fpa,gauche,droite)
ta=taa
if(t.lt.tmax) go to 900
logic=1
t=tmax
go to 900
c
c interpolation
c
500 if(indica.le.0) then
ta=t
t=0.9d0*tg+0.1d0*td
go to 900
endif
test=barr*(td-tg)
gauche=tg+test
droite=td-test
taa=t
call dcube (t,f,fp,ta,fa,fpa,gauche,droite)
ta=taa
if (t.gt.gauche .and. t.lt.droite) then
barr=dmax1(barmin,barr/barmul)
c barr=barmin
else
barr=dmin1(barmul*barr,barmax)
endif
c
c --- fin de boucle
c - t peut etre bloque sur tmax
c (venant de l'extrapolation avec logic=1)
c
900 fa=f
fpa=fp
905 indica=indic
c
c --- faut-il continuer ?
c
if (td.eq.0.d0) go to 950
if (td-tg.lt.tmin) go to 920
c
c --- limite de precision machine (arret de secours) ?
c
lfound=.false.
do i=1,n
z=xn(i)+t*d(i)
if (z.ne.xn(i).and.z.ne.x(i)) then
lfound=.true.
exit
endif
enddo
call tmg_start(79,'QN_COMM')
call rpn_comm_allreduce(lfound,lfound2,1,"mpi_logical","mpi_lor","GRID",ierr)
call tmg_stop(79)
if(lfound2) go to 950
c
c --- arret sur dxmin ou de secours
c
920 logic=6
c
c si indicd<0, derniers calculs non faits par simul
c
if (indicd.lt.0) logic=indicd
c
c si tg=0, xn = xn_depart,
c sinon on prend xn=x_gauche qui fait decroitre f
c
if (tg.eq.0.d0) go to 940
fn=fg
do 930 i=1,n
930 xn(i)=xn(i)+tg*d(i)
940 if (imp.le.0) go to 999
write (io,1001)
write (io,1005) tg,fg,fpg
if (logic.eq.6) write (io,1005) td,fd,fpd
if (logic.eq.7) write (io,1006) td,indicd
go to 999
c
c recopiage de x et boucle
c
950 do 960 i=1,n
960 x(i)=xn(i)+t*d(i)
go to 100
call tmg_stop(74)
999 return
end