!-------------------------------------- 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 minvar 1,25
use mod4dv
, only : l4dvar
use oda_shared, only : dg_vbar
!
!Purpose:
!Setup of 3D/4D VAR minimization
!
*Author : P. Gauthier *ARMA/AES June 9, 1992
*Revision:
*
* . P. Koclas *CMC/CMDA February 94
* -comdeck comgdpar added for argument in call to postproc
* . -new definition for zxmin
* . C. Charette *ARMA/AES Jan 96
* . -Etikette for analysed increments
* -Open restart files and call to DEMARRE if LRSTART = .T.
* -Write restart files. Do test of the gradient
* according the status of the minimization
* -Added call supost. Added trial fields to RPN standard file
* . S. Pellerin *ARMA/AES Sept 97.
* -Control of GRTEST and its output to fst file
* . S. Pellerin *ARMA/AES .
* -Added call to PRINTREV
* . C. Charette *ARMA/AES Jul 98.
* -Changed etiket of gradient fields (NGRTEST=1)
* . S. Pellerin *ARMA/SMC May 2000
* -Control for minimization with preproc and postproc
* subroutine calls at cnt0 level
* . C. Charette *ARMA/SMC Nov 2000
* -Move call RSETCMA completely to the end
* . B. Brasnett *CMC/CMDA Dec 200
* -Control the use of VarQC
* . JM Belanger CMDA/SMC April 2001
* - 32 bits conversion
* - Replace call to M1QN3 by N1QN3
* . S. Pellerin SMC/ARMA Nov. 2001
* - Send of an end of simulation signal to TLM-ADJ unit
* . M. Buehner *ARMA/SMC April 2002
* - Added call to suprecon for Hessian eigenvector
C preconditioning
* . P. Gauthier *ARMA/MSC July 2003
* . - Numerous changes to insure that the printouts do reflect
C what the minimization
* . has seen. Improvements to the clarity of printouts.
* . PRNTHDR and PRNTBDY have been restricted to print results
C for assimilated data only
* . GRTEST is now called after the minimization when NGRTEST =
C 1 (in NAMELIST)
* . S. Pellerin *ARMA/SMC August 2004
* - Modification of the preconditioning file for multi-dataset
* outer-loop need
* . S. Pellerin *ARMA/MSC January 2005
* - Dynamical Multi-Inc. : Call to rw_vatra
* . M. Tanguay *ARMN/MSC Jan. 2005
* - Introduction of minimizer N1CG1
* . J. Halle *CMDA/SMC May. 2006
* - Added non-linear treatment of 'TO' data
* - Req'd addition of partov.cdk, comtov.cdk, and namtov.cdk.
* . S. Pellerin, ARMA, August 2008
* - Added calls to 'tmg_*' subroutines
* . S. Pellerin, ARMA, January 2009
* - Subroutine minimize renamed under minvar
* - Introduction of the new simulator (simvar)
* - Introduction of a new global vbar variable (instead of vazxbar)
* - Introduction of new grtest2
* . L. Fillion *ARMN/EC 14 Aug 2007 - Update to v_10_0_3.
* . M. Tanguay *ARMN/EC 06 Dec 2007.
* - LAM4D Limited-Area: Add grd_typ in rw_vatra parameters
* . L. Fillion *ARMN/EC 3 June 2008
* - Introduce lwrthess to allow not writing Hessian (i.e. requires less cpu when debugging...).
* . L. Fillion *ARMN/EC 11 Feb 2009
* - Upgrade to v_10_2_2.
* -------------------
*Arguments
* -NONE-
IMPLICIT NONE
*implicits
#include "comdim.cdk"
#include "comlun.cdk"
#include "comcst.cdk"
#include "comcva.cdk"
#include "comgdpar.cdk"
#include "comvarqc.cdk"
#include "comvfiles.cdk"
#include "comanl.cdk"
#include "cvcord.cdk"
#include "partov.cdk"
#include "comtov.cdk"
#include "comgrd_param.cdk"
#include "comin.cdk"
*
C
INTEGER IZS(1),IZTRL(10)
REAL ZZSUNUSED(1)
REAL*8 DLDS(1)
LOGICAL LLTEST,llvarqc, llstop, lldf1, lrdvatra, llvazx, llxbar
C
INTEGER IMPRES, IMODE, ITERMAX, iterdone, ISIMMAX, INDIC, IITNOVQC
INTEGER IERR,ITERTOT,isimdone,isimtot,jdata, ISIMNOVQC
integer ireslun,ibrpstamp,isim3d
INTEGER IPRECON,ILEN
REAL*8 ZJSP, ZXMIN, ZDF1, ZEPS0, ZEPS1
REAL*8 DLGNORM, DLXNORM, ZJOTOV
C
INTEGER FNOM,FCLOS,II, remove_c
EXTERNAL FNOM,FCLOS,MVPROD
EXTERNAL TESTSP, M1QN2, N1QN3
S , DSCALQN, DCANAB, DCANONB, PRSCAL , DEMARRE
S , TRANSFER, SUPOST, simvar
real*8 :: zeps0_000,zdf1_000
integer :: iterdone_000,isimdone_000
character(len=128) :: clfname
C
logical bid_L
C
C Additional parameters for minimization (N1CG1)
C ----------------------------------------------
real*8 xx,bb,a_not_use,r8_not_use,pj0
integer in_mode(3),out_mode,i_not_use,nilm,ilm0(10),ilm1(10)
integer i_pmat1,nl_stat, dl_bidon
C
C ------------------------------------------
C
allocate(dg_vbar(nvadim),STAT=nl_stat)
if (nl_stat .ne. 0) then
write(nulout,*) 'MINVAR: PROBLEM allocating state vectors'
call abort3d(NULOUT,'MINVAR: allocation problem')
endif
dg_vbar = 0.d0
C Initialization and allocation specific to (N1CG1)
C -------------------------------------------------
if( N1GC.EQ.4.and.lvarqc ) call abort3d(nulout
& ,' MINIMIZE N1CG1 with lvarqc not done ')
if( BFGSB.EQ.1 ) call abort3d(nulout
& ,' MINIMIZE n1cg1: option not validated ')
C
C Define i_pmat1 even if BFGSB.NE.1 (Otherwise abort in n1cg1)
C ------------------------------------------------------------
i_pmat1 = NVADIM**2
C
in_mode(2) = 0
in_mode(3) = IMODE3
C
nilm = NVAMAJ + 3
if( nilm.gt.10 .and. N1GC.EQ.4) call abort3d(nulout
& ,' MINIMIZE n1cg1: ilm0,ilm1 incorrect ')
C
C -------------------------------------------------
c Prepare for non-linear processing of 'TO' data:
c - fill PZDBLPRIM8 with Z" = H(xb_lr) + Z'
c = H(xb_lr) - H(xb_hr) + Z
c
if ( lnlvtov ) then
call tmg_start(60,'RTTOV')
call tovs_obs ('LR', ZJOTOV)
call tmg_stop(60)
endif
c
ITERTOT = 0
isimtot = 0
C
ZXMIN = RPRECIS
C * 2. Set-up the minimization
C . -----------------------
llvarqc = lvarqc
c If minimization start without qcvar : turn off varqc to compute
c innovations and test the gradients
ireslun=0
lldf1 = .true.
if(niterjob /= -1 .and. lrestart) then
if( N1GC.EQ.4 ) call abort3d(nulout,' MINIMIZE N1CG1 with restart not done ')
write(nulout,*) 'Minimize : Restart mode'
lrdvatra = .true.
clfname = crestart
imode = 2
llvazx = .true.
llxbar = .true.
elseif (lpcon .and. nprecon <= 0) then
write(nulout,*) 'Minimize : Preconditioning mode'
lrdvatra = .true.
clfname = cpconf
imode = 2
llvazx = .false.
llxbar = lxbar ! from namcva (default is .true.)
else
lrdvatra = .false.
imode = 0
zeps0 = repsg
endif
if(.not.(imode.eq.0.or.imode.eq.2)) call abort3d(nulout,' RW_VATRA not done ')
if (lrdvatra) then
ibrpstamp = nbrpstamp ! ibrpstamp is a I/O argument of rw_vatra
*
if(n1gc.eq.3) then
call rw_vatra (clfname,0,
% isim3d,ibrpstamp,zeps0_000,zdf1_000,iterdone_000
& ,isimdone_000,iztrl,vatra,nmtra,dg_vbar,nvadim,
& vazx,ntrunc,nksdim,nvamaj,llxbar,llvazx,n1gc,imode,grd_typ)
*
elseif(n1gc.eq.4) then
if(grd_typ.eq.'LU') then
call abort3d(nulout,'n1gc.eq.4, grd_typ=LU not yet implemented')
else
call rw_vatra (clfname,0,
% isim3d,ibrpstamp,zeps0_000,zdf1_000,iterdone_000
& ,isimdone_000,ilm0,vatra,nmtra,dg_vbar,nvadim,
& vazx,ntrunc,nksdim,nvamaj,llxbar,llvazx,n1gc,imode,grd_typ)
endif
endif
!
if(niterjob /= -1 .and. lrestart) then
ierr = remove_c(clfname)
nsim3d = isim3d
write(nulout,*) 'MINVAR : NSIM3D read from precon file: '
& ,nsim3d
zeps0 = zeps0_000
zdf1 = zdf1_000
lldf1 = .false. ! don't re-compute df1 base on Cost function
iterdone = iterdone_000
isimdone = isimdone_000 - 1
itermax = min(nitermax - iterdone + 1, niterjob)
isimmax = nsimmax - isimdone + 1
if (iterdone < nwoqcv) lvarqc = .false.
else
if (ibrpstamp == nbrpstamp .and. lxbar) then
zeps0 = zeps0_000
zdf1 = zdf1_000
lldf1 = .false. ! don't re-compute df1 base on Cost function
else
zeps0 = repsg
lldf1 = .true. ! Compute df1 base on Cost function
endif
endif
endif
if(niterjob == -1 .or. .not. lrestart) then
iterdone = 0
isimdone = 0
if (niterjob /= -1) then
itermax = min(nitermax,niterjob)
else
itermax = nitermax
endif
isimmax = nsimmax
c
if (nwoqcv > 0) lvarqc = .false.
c
if(ngrtest.ne.0) then
lmin = .true.
call grtest2(simvar,nulout,nvadim,vazx,ngrange)
endif
endif
C
zeps1 = zeps0
itertot = iterdone
isimtot = isimdone
C * 2. Set-up the minimization
C . -----------------------
c
c Calculate Hessian Eigenvectors
c
IF(NPRECON.ge.1) THEN
NCV=2*NPRECON
NCORDIM=NVADIM
ILEN = NCORDIM*NCV
CALL HPALLOC(PTRRNK1,MAX(ILEN,1),IERR,8)
ILEN = NCORDIM*NPRECON
CALL HPALLOC(PTRRNK2,MAX(ILEN,1),IERR,8)
ILEN = NPRECON
CALL HPALLOC(PTHESEVAL,MAX(ILEN,1),IERR,8)
CALL SUPRECON
ENDIF
C
C * . Test the gradient again at the initial point WITH PRECON
C . --------------------------------------------------------
C
C . 2.1.4 Test the complete functional
C
IF(NPRECON.gt.0 .and. ngrtest.ne.0) THEN
WRITE(NULOUT,*) '***STARTING GRTEST WITH PRECON***'
call grtest2(simvar,nulout,nvadim,vazx,ngrange)
ENDIF
C
C * . 2.2 Compute the value of J(X) and the gradient
C . at the initial point
C
INDIC =2
call simvar(indic,nvadim,vazx,zjsp,vazg)
if (lldf1) ZDF1 = rdf1fac * ABS(ZJSP)
C Put QCVAR logical to its original values
lvarqc=llvarqc
C
CALL PRSCAL(NVADIM,VAZG,VAZG,DLGNORM)
DLGNORM = DSQRT(DLGNORM)
CALL PRSCAL(NVADIM,VAZX,VAZX,DLXNORM)
DLXNORM = DSQRT(DLXNORM)
WRITE(NULOUT,*)' |X| = ', DLXNORM
WRITE(NULOUT,FMT=9220) ZJSP, DLGNORM
9220 FORMAT(/4X,'J(X) = ',G23.16,4X,'|Grad J(X)| = ',G23.16)
C
C * . 2.4. Constants required by MODULOPT
C . ------------------------------
C
IMPRES = NIMPRES
C
C * 3. Iterations of the minimization algorithm
C . ----------------------------------------
C
C
C * . 3.2 Starting point of the minimization written to
C . RPN standard output file
C
IF(N1GC.EQ.3) THEN
WRITE(NULOUT,FMT=9320)ZXMIN,ZDF1,ZEPS0,IMPRES,NITERMAX,NSIMMAX
ELSEIF(N1GC.EQ.4) THEN
WRITE(NULOUT,FMT=9321)ZXMIN,ZDF1,ZEPS0,EPSNEG,SELECT0,BFGSB,IMODE3,IMPRES,NITERMAX,NSIMMAX
ENDIF
c
9320 FORMAT(//,10X,' Minimization N1QN3 starts ...',/
S 10x,'DXMIN =',G23.16,2X,'DF1 =',G23.16,2X,'EPSG =',G23.16
S /,10X,'IMPRES =',I3,2X,'NITER = ',I3,2X,'NSIM = ',I3,//
S ,15X,'-STARTING POINT IS WRITTEN TO FILE ...')
9321 FORMAT(//,10X,' Minimization N1CG1 starts ...',/
S 10x,'DXMIN =',G23.16,2X,'DF1 =',G23.16,2X,'EPSG =',G23.16,2X,'EPSNEG =',G23.16,/,
$ 10x,'SELECT0 = ',I3,2X,'BFGSB = ',I3,2X,'IMODE3 = ',I3,
S /,10X,'IMPRES =',I3,2X,'NITER = ',I3,2X,'NSIM = ',I3,2X,'NHESS = ',I3,//
S ,15X,'-STARTING POINT IS WRITTEN TO FILE ...')
C
C * . 3.3 Beginning the minimization
C . --------------------------
c
lminend = .false.
llstop = .false.
if (lvarqc .and. nwoqcv > 0 .and. iterdone < nwoqcv) then
iitnovqc = min(nwoqcv - iterdone,itermax)
isimnovqc = isimmax
lvarqc = .false.
call tmg_start(21,'QN')
call n1qn3(simvar, dscalqn, dcanonb, dcanab, nvadim, vazx,
& zjsp,vazg, zxmin, zdf1, zeps1, impres, nulout, imode
& ,iitnovqc, isimnovqc ,iztrl, vatra, nmtra, izs, zzsunused
& ,dlds)
call tmg_stop (21)
isimnovqc = isimnovqc - 1
itermax = itermax - iitnovqc + 1
isimmax = isimmax - isimnovqc + 1
itertot = itertot + iitnovqc
isimtot = isimtot + isimnovqc
zeps1 = zeps0/zeps1
zeps0 = zeps1
lvarqc = .true.
if (imode == 4 .and. itertot < nitermax) then
imode = 2
INDIC = 2
call simvar(indic,nvadim,vazx,zjsp,vazg)
c CALL SIM3D(INDIC,NVADIM,VAZX,ZJSP,VAZG)
else
llstop = .true.
endif
endif
if (.not. llstop) then
C
if(N1GC.EQ.3) then
C
call tmg_start(21,'QN')
call n1qn3(simvar, dscalqn, dcanonb, dcanab, nvadim, vazx,
& zjsp,vazg, zxmin, zdf1, zeps1, impres, nulout, imode,
& itermax,isimmax, iztrl, vatra, nmtra, izs, zzsunused,
& dlds)
call tmg_stop (21)
itertot = itertot + itermax
isimtot = isimtot + isimmax
C
zeps1 = zeps0/zeps1
C
elseif(N1GC.EQ.4) then
C
C Set VAZB = - VAZG (Valid only if VAZX = ZERO)
C ---------------------------------------------
VAZB = - VAZG
C
C Keep constant term in pj0 (Valid only if VAZX = ZERO)
C -----------------------------------------------------
pj0 = ZJSP
C
C Print cost function at iter 0 (Valid only if VAZX = ZERO)
C ---------------------------------------------------------
WRITE(NULOUT,FMT=9700) 0,0.d0+pj0,pj0,0.d0
9700 FORMAT (4x,"n1cga:",i5,1x,e15.8,1x,e15.8,1x,e15.8)
C
if(imode.eq.0) in_mode(1) = 0
if(imode.eq.2) in_mode(1) = 1
C
call n1cg1 (mvprod,NVADIM,VAZX,VAZB,a_not_use,pj0,xx,bb,.false
& .,EPSNEG,zeps1,itermax,impres,NULOUT,in_mode,out_mode
& ,VWORK,NWORK,imode,r8_not_use,i_not_use,NVAMAJ,ilm0,nilm
& ,VATRA,NMTRA,BFGSB,r8_not_use,i_pmat1, NVAMAJ,ilm1,nilm
& ,VATR1,NMTRA,SELECT0,izs,zzsunused,dlds)
C
zeps1 = zeps0/zeps1
zeps0 = zeps1
C
imode = out_mode
C
isimmax = itermax
C
itertot = itertot + itermax
isimtot = isimtot + isimmax
C
C Call 4D-Var simulator without gradient to get ZJSP
C --------------------------------------------------
INDIC = 2
call simvar(indic,nvadim,vazx,zjsp,vazg)
c CALL SIM3D(INDIC,NVADIM,VAZX,ZJSP,VAZG)
C
endif
C
endif
c if lrestart remain false... postmin will execute
lrestart = .false.
ireslun=0
if (niterjob /= -1 .and. itertot < nitermax .and. imode == 4) then
clfname = crestart
c Careful: lrestart before minimisation was used to trigger a
C read of restart file... now it is set to .true. to avoid
C execution of postmin.
lrestart = .true.
else
do jdata = 1, nvadim
dg_vbar(jdata) = vazx(jdata) + dg_vbar(jdata)
enddo
clfname = 'pm1q'
endif
if(lwrthess) then
if(n1gc.eq.3) then
call rw_vatra (clfname,1,
% nsim3d,nbrpstamp,zeps1,zdf1,itertot,isimtot,
% iztrl,vatra,nmtra,
% dg_vbar,nvadim,
% vazx,ntrunc,nksdim,nvamaj,.true.,llvazx,n1gc,imode,grd_typ)
elseif(n1gc.eq.4) then
if(grd_typ.eq.'LU') then
call abort3d(nulout,'n1gc.eq.4, grd_typ=LU not yet implemented')
else
call rw_vatra (clfname,1,
% nsim3d,nbrpstamp,zeps1,zdf1,itertot,isimtot,
% ilm1,vatr1,nmtra,
% dg_vbar,nvadim,
% vazx,ntrunc,nksdim,nvamaj,.true.,llvazx,n1gc,imode,grd_typ)
endif
endif
endif
WRITE(NULOUT,FMT=9500) imode,iterdone,itertot-iterdone,itertot
& ,isimdone,isimtot-isimdone,isimtot
9500 FORMAT(//,20X,20('*'),2X
& ,/,20X,' Minimization ended with MODE:',I4
S ,/,20X,' Number of iterations done in previous job:',I4
S ,/,20X,' Number of iterations in this job:',I4
S ,/,20X,' Total number of iterations:',I4
S ,/,20X,'Number of simulations done in previous job:',I4
S ,/,20X,' Number of simulations in this job:',I4
S ,/,20X,' Total number of simulations:',I4)
c
niter = itertot
C
C * 4. Test the gradient at the final point if NGRTEST=1
C . ------------------------------------
C
400 CONTINUE
C
if ((NGRTEST.ne.0 .and. IMODE.ne.4 .and. .not. LRSTART)) then
WRITE(NULOUT,FMT=9400)
9400 FORMAT(//,12X,40('**'),/,12X,
S 'TESTING THE GRADIENT AT THE FINAL POINT',/,40('**'))
!
call grtest2(simvar,nulout,nvadim,vazx,ngrange)
!
END IF
if(l4dvar) then
ldiag4d = .false.
lminend = .true.
call endsim2(nvadim,vazx)
endif
C
RETURN
END