!--------------------------------------- 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 n1qn3 (simul,prosca,dtonb,dtcab,n,x,f,g,dxmin,df1, 2,2
/ epsg,impres,io,mode,niter,nsim,iz,dz,ndz,
/ izs,rzs,dzs)
c----
c
c N1QN3, Version 2.0c, June 1995
c Jean Charles Gilbert, Claude Lemarechal, INRIA.
c
c Double precision version of M1QN3.
c
c N1qn3 has two running modes: the SID (Scalar Initial Scaling) mode
c and the DIS (Diagonal Initial Scaling) mode. Both do not require
c the same amount of storage, the same subroutines, ...
c In the description below, items that differ in the DIS mode with
c respect to the SIS mode are given in brakets.
c
c Use the following subroutines:
c N1QN3A
c DDD, DDDS
c NLIS0 + DCUBE (Dec 88)
c MUPDTS, DYSTBL.
c
c The following routines are proposed to the user in case the
c Euclidean scalar product is used:
c DUCLID, DTONBE, DTCABE.
c
c La sous-routine N1QN3 est une interface entre le programme
c appelant et la sous-routine N1QN3A, le minimiseur proprement dit.
c
c Le module PROSCA est sense realiser le produit scalaire de deux
c vecteurs de Rn; le module DTONB est sense realiser le changement
c de coordonnees correspondant au changement de bases: base
c euclidienne -> base orthonormale (pour le produit scalaire
c PROSCA); le module CTBAB fait la transformation inverse: base
c orthonormale -> base euclidienne.
c
c Iz is an integer working zone for N1QN3A, its dimension is 5.
c It is formed of 5 scalars that are set by the optimizer:
c - the dimension of the problem,
c - a identifier of the scaling mode,
c - the number of updates,
c - two pointers.
c
c Dz est la zone de travail pour N1QN3A, de dimension ndz.
c Elle est subdivisee en
c 3 [ou 4] vecteurs de dimension n: d,gg,[diag,]aux
c m vecteurs de dimension n: ybar
c m vecteurs de dimension n: sbar
c
c m est alors le plus grand entier tel que
c m*(2*n+1)+3*n .le. ndz [m*(2*n+1)+4*n .le. ndz)]
c soit m := (ndz-3*n) / (2*n+1) [m := (ndz-4*n) / (2*n+1)].
c Il faut avoir m >= 1, donc ndz >= 5n+1 [ndz >= 6n+1].
c
c A chaque iteration la metrique est formee a partir d'un multiple
c de l'identite [d'une matrice diagonale] D qui est mise a jour m
c fois par la formule de BFGS en utilisant les m couples {y,s} les
c plus recents.
c
c----
c
c arguments
c
integer n,impres,io,mode,niter,nsim,iz(5),ndz,izs(1)
real rzs(1)
double precision x(n),f,g(n),dxmin,df1,epsg,dz(ndz),dzs(1)
external simul,prosca,dtonb,dtcab
c
c variables locales
c
logical inmemo,sscale
integer ntravu,id,igg,idiag,iaux,iybar,isbar,m,mmemo
double precision d1,d2,ps
c
c---- impressions initiales et controle des arguments
c
write(io,*) '--------------------------------------------------'
write(io,*) 'N1QN3: calling modified MPI version of modulopt!!!'
write(io,*) '--------------------------------------------------'
if (impres.ge.1)
/ write (io,900) n,dxmin,df1,epsg,niter,nsim,impres
900 format (/" N1QN3 (Version 2.0c, June 1995): entry point"/
/ 5x,"dimension of the problem (n):",i9/
/ 5x,"absolute precision on x (dxmin):",d9.2/
/ 5x,"expected decrease for f (df1):",d9.2/
/ 5x,"relative precision on g (epsg):",d9.2/
/ 5x,"maximal number of iterations (niter):",i6/
/ 5x,"maximal number of simulations (nsim):",i6/
/ 5x,"printing level (impres):",i4)
if (n.le.0.or.niter.le.0.or.nsim.le.0.or.dxmin.le.0.d+0.or.
& epsg.le.0.d+0.or.epsg.gt.1.d+0.or.mode.lt.0.or.mode.gt.3) then
mode=2
if (impres.ge.1) write (io,901)
901 format (/" >>> n1qn3: inconsistent call")
return
endif
c
c---- what method
c
if (mod(mode,2).eq.0) then
if (impres.ge.1) write (io,920)
920 format (/" n1qn3: Diagonal Initial Scaling mode")
sscale=.false.
else
if (impres.ge.1) write (io,921)
921 format (/" n1qn3: Scalar Initial Scaling mode")
sscale=.true.
endif
c
if ((ndz.lt.5*n+1).or.((.not.sscale).and.(ndz.lt.6*n+1))) then
mode=2
if (impres.ge.1) write (io,902)
902 format (/" >>> n1qn3: not enough memory allocated")
return
endif
c
c---- Compute m
c
call mupdts
(sscale,inmemo,n,m,ndz)
c
c --- Check the value of m (if (y,s) pairs in core, m will be >= 1)
c
if (m.lt.1) then
mode=2
if (impres.ge.1) write (io,9020)
9020 format (/" >>> n1qn3: m is set too small in mupdts")
return
endif
c
c --- mmemo = number of (y,s) pairs in core memory
c
mmemo=1
if (inmemo) mmemo=m
c
ntravu=2*(2+mmemo)*n
if (sscale) ntravu=ntravu-n
if (impres.ge.1) write (io,903) ndz,ntravu,m
903 format (/5x,"allocated memory (ndz) :",i9/
/ 5x,"used memory : ",i9/
/ 5x,"number of updates : ",i9)
if (ndz.lt.ntravu) then
mode=2
if (impres.ge.1) write (io,902)
return
endif
c
if (impres.ge.1) then
if (inmemo) then
write (io,907)
else
write (io,908)
endif
endif
907 format (5x,"(y,s) pairs are stored in core memory")
908 format (5x,"(y,s) pairs are stored by the user")
c
c---- cold start or warm restart ?
c check iz: iz(1)=n, iz(2)=(0 if DIS, 1 if SIS),
c iz(3)=m, iz(4)=jmin, iz(5)=jmax
c
if (mode/2.eq.0) then
if (impres.ge.1) write (io,922)
else
iaux=0
if (sscale) iaux=1
! if (iz(1).ne.n.or.iz(2).ne.iaux.or.iz(3).ne.m.or.iz(4).lt.1
! & .or.iz(5).lt.1.or.iz(4).gt.iz(3).or.iz(5).gt.iz(3)) then
if (iz(2).ne.iaux.or.iz(3).ne.m.or.iz(4).lt.1
& .or.iz(5).lt.1.or.iz(4).gt.iz(3).or.iz(5).gt.iz(3)) then
mode=2
write(*,*) 'iz=',iz(:)
write(*,*) 'n,iaux,m=',n,iaux,m
if (impres.ge.1) write (io,923)
return
endif
if (impres.ge.1) write (io,924)
endif
922 format (/" n1qn3: cold start"/,1x)
923 format (/" >>> n1qn3: inconsistent iz for a warm restart")
924 format (/" n1qn3: warm restart"/,1x)
iz(1)=n
iz(2)=0
if (sscale) iz(2)=1
iz(3)=m
c
c---- split the working zone dz
c
idiag=1
iybar=idiag+n
if (sscale) iybar=1
isbar=iybar+n*mmemo
id=isbar+n*mmemo
igg=id+n
iaux=igg+n
c
c---- call the optimization code
c
call n1qn3a (simul,prosca,dtonb,dtcab,n,x,f,g,dxmin,df1,epsg,
/ impres,io,mode,niter,nsim,inmemo,iz(3),iz(4),iz(5),
/ dz(id),dz(igg),dz(idiag),dz(iaux),
/ dz(iybar),dz(isbar),izs,rzs,dzs)
c
c---- impressions finales
c
if (impres.ge.1) write (io,905) mode,niter,nsim,epsg
905 format (/,1x,79("-")/
/ /" n1qn3: output mode is ",i2
/ /5x,"number of iterations: ",i4
/ /5x,"number of simulations: ",i6
/ /5x,"realized relative precision on g: ",d9.2)
call prosca (n,x,x,ps,izs,rzs,dzs)
d1=dsqrt(ps)
call prosca (n,g,g,ps,izs,rzs,dzs)
d2=dsqrt(ps)
if (impres.ge.1) write (io,906) d1,f,d2
906 format (5x,"norm of x = ",d15.8
/ /5x,"f = ",d15.8
/ /5x,"norm of g = ",d15.8)
return
end