!-------------------------------------- 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 rw_vatra (cfname,status, 4,13
% nsim3d,kbrpstamp,zeps1,zdf1,itertot,isimtot,
% nztrl,vatra,nmtra,
% vazxbar,kvadim,
% vazx,ktrunc,kksdim,nvamaj,lxbar,lvazx,k1gc,imode,grd_typ_S)
*
#if defined (DOC)
*
***s/r RW_VATRA - Read-Write VAZXBAR and VATRA on file
*
*
*Author : M. Tanguay RPN January 2005
*Revision: S. Pellerin (January 2005)
* . Dynamical Multi-Inc.: Read and write based on date,
* working and stored resolutions
* M. Buehner (May 2008)
* . Added code for dealing with multiple bands of
* correlations (corns) - changed some argument names
* to avoid complict with comdecks
*Revision: M. Tanguay (December 2007)
* . Lam4d Limited-Area: Add grd_typ in rw_vatra parameters
*Revision: L. Fillion - ARMA/EC - 12 Jan 2009
* . Upgrade lam4d to v_10_1_2.
*
*Arguments
* i cfname : precon file
* i status : = 0 if READ, = 1 if WRITE
* i nsim3d : Number of simulations in N1QN3
* io kbrpstamp : Date
* i zeps1 : Parameter in N1QN3
* i zdf1 : Parameter in N1QN3
* i itertot : Parameter in N1QN3
* i isimtot : Parameter in N1QN3
* i nztrl : Localisation parameters for Hessian
* i vatra : Hessian
* i nmtra : Size of Hessian
* i vazxbar : Vazx of previous loop
* i kvadim : Dimension of vazxbar
* i vazx : Current state of the minimization
* i ktrunc : truncation of working resolution
* i kksdim : nvar3d*nlev + nvar2d of working field
* i nvamaj : nomber of updates in Hessian
* i lxbar : read in vaxzbar if dates are compatible
* i lvazx : Logical to read vazx
* i k1gc : Minimizer ID (2: m1qn2, 3: m1qn3, 4: m1gc)
* o imode : If status=0, set imode=0 (no prec) or 2 (prec)
#endif
IMPLICIT NONE
*
logical lxbar,lvazx
*
integer status,kbrpstamp,nsim3d,itertot,isimtot
integer, dimension(10), target :: nztrl
integer nmtra, kvadim, ktrunc, kksdim, nvamaj, k1gc, imode
*
real*8 zeps1,zdf1
*
real*8, dimension(kvadim), target :: vazxbar, vazx
real*8, dimension(nmtra), target :: vatra
*
*implicits
#include "comlun.cdk"
#include "pardim.cdk"
#include "comdim.cdk"
*
integer isize, ibrpstamp,ireslun, ierr, fnom, fclos
integer, save :: ivadim = 0, imtra = 0, itrlsize = 1, imemo = 1
integer, save :: itrunc = 0
integer :: jvadim, i1gc,ictrlvec
integer, dimension(10), target, save :: iztrl
integer ilatbin, jlatbin,itemp
real*8, allocatable, dimension(:), target, save :: zvatra
real*8, allocatable, dimension(:), target, save :: zvazxbar,zvazx
*
integer, pointer, dimension(:) :: iptrl
real*8, pointer, dimension(:) :: pvatra , pvazxbar, pvazx
*
character(len=128) :: cfname
character(len=3) :: cl_version
character*2 grd_typ_S
*
if(status.eq.0) then
write(nulout,*) 'Read VATRA in RW_VATRA'
elseif(status.eq.1) then
write(nulout,*) 'Write VATRA in RW_VATRA'
else
call abort3d(nulout," RW_VATRA: status not valid ")
endif
ireslun=0
*
* Read Hessian
* ------------
if(status.eq.0) then
*
ierr = fnom(ireslun,cfname,'FTN+SEQ+UNF+OLD+R/O',0)
! Checking version number
read (ireslun) cl_version,i1gc
if(trim(cl_version) /= 'V2') then
call abort3d(nulout," RW_VATRA: invalid Hessian version")
endif
if (i1gc == 3 .and. i1gc == k1gc) then
write(*,*) trim(cl_version),' M1QN3'
elseif (i1gc == 4 .and. i1gc == k1gc) then
write(*,*) trim(cl_version),' N1CG1'
else
write(*,*) 'Version, n1gc =',trim(cl_version),i1gc
call abort3d(nulout," RW_VATRA: Inconsistant input hessian")
endif
rewind (ireslun)
read(ireslun) cl_version,k1gc,nsim3d,ibrpstamp,zeps1,zdf1
& ,itertot,isimtot,ivadim, itrunc
*
if(itrunc .ne. ntrunc .and. grd_typ_S.eq.'LU' ) then
write(nulout,*) 'ITRUNC .NE. NTRUNC when reading HESSIAN when LAM'
call flush(nulout)
call abort3d(nulout," ITRUNC .NE. NTRUNC when reading HESSIAN for LAM")
endif
*
read(ireslun) imtra,iztrl
if(.not. allocated(zvatra).and.grd_typ_S.ne.'LU') then
allocate(zvatra(imtra))
zvatra = 0.d0
endif
* imemo = nvamaj
imemo = (imtra - 4*ivadim)/(2*ivadim + 1)
if(k1gc.eq.3) ictrlvec = 2*imemo+1
if(k1gc.eq.4) ictrlvec = 2*imemo
cBUE
write(nulout,*) 'PARAMETERS REGARDING VATRA:'
write(nulout,*) 'k1gc=',k1gc
write(nulout,*) 'imtra=',imtra
write(nulout,*) 'ivadim,kvadim=',ivadim,kvadim
write(nulout,*) 'imemo=',imemo
write(nulout,*) 'ictrlvec=',ictrlvec
write(nulout,*) 'nvamaj=',nvamaj
write(nulout,*) 'nlatbin=',nlatbin
if(nlatbin.gt.1) then
itemp=kvadim/ivadim
if(itemp.eq.nlatbin) then
write(nulout,*) 'HESSIAN IS FOR ONLY 1 REGION, DUPLICATE FOR EACH REGION'
elseif(itemp.eq.1) then
write(nulout,*) 'HESSIAN IS ALREADY FOR CORRECT NUMBER OF REGIONS'
endif
endif
cBUE
if(.not. allocated(zvatra)) allocate(zvatra(imtra))
zvatra = 0.d0
c
do jvadim = 1, ictrlvec
if(grd_typ_S.ne.'LU') then
read(ireslun) zvatra((jvadim-1)*ivadim+1:jvadim*ivadim)
else
read(ireslun) vatra((jvadim-1)*ivadim+1:jvadim*ivadim)
endif
enddo
*
* Write Residual Hessian (needed when LAM)
* ----------------------------------------
if (ictrlvec*ivadim.lt.imtra.and.grd_typ_S.eq.'LU')
& read(ireslun) vatra(ictrlvec*ivadim+1:imtra)
*
if(k1gc.eq.4) read(ireslun) zvatra(ictrlvec*ivadim+1:ictrlvec
& *ivadim+1)
c if(k1gc.eq.3) read(ireslun) iztrl,zvatra(1:(2*imemo+1)*ivadim )
c if(k1gc.eq.4) read(ireslun) iztrl,zvatra(1:(2*imemo)*ivadim+1)
c read(ireslun) iztrl, zvatra
imemo = nvamaj ! saved for writing
if(itrunc .ge. ktrunc) then
write(nulout,*) 'RW_VATRA : setting vatra'
if(grd_typ_S.ne.'LU') then
call setvatra(vatra,nmtra,kvadim,ktrunc,nztrl,zvatra,imtra
& ,ivadim,itrunc,iztrl,.false.,kksdim,nvamaj,k1gc,nlatbin)
else
nztrl = iztrl
endif
imode = 2
else
imode = 0
endif
*
if(ibrpstamp == kbrpstamp .and. lxbar) then
if(.not. allocated(zvazxbar)) allocate(zvazxbar(ivadim))
read(ireslun) zvazxbar
write(nulout,*) 'RW_VATRA : setting vazxbar'
if(itrunc .ge. ktrunc) then ! Given res. > working res.
if(grd_typ_S.ne.'LU') then
call setvazx(vazxbar,ktrunc,zvazxbar,itrunc,.false.,kksdim,nlatbin)
else
vazxbar = zvazxbar
endif
else
vazxbar = 0.d0
call setvazx(vazxbar,ktrunc,zvazxbar,itrunc,.true.,kksdim,nlatbin)
endif
if(lvazx) then
write(nulout,*) 'RW_VATRA : setting vazx'
if(.not. allocated(zvazx)) allocate(zvazx(ivadim))
read(ireslun) zvazx
if(itrunc .ge. ktrunc) then ! Given res. > working res.
if(grd_typ_S.ne.'LU') then
call setvazx(vazx,ktrunc,zvazx,itrunc,.false.,kksdim,nlatbin)
else
vazx = zvazx
endif
else
vazx = 0.d0
call setvazx(vazx,ktrunc,zvazx,itrunc,.true.,kksdim,nlatbin)
endif
endif
else
kbrpstamp = ibrpstamp
endif
ierr = fclos(ireslun)
*
* Write Hessian
* -------------
elseif(status.eq.1) then
ierr = fnom(ireslun,cfname, 'FTN+SEQ+UNF' , 0)
*
* if ivadim = 0 then no precon file has been read
if (ivadim .le. kvadim) then
if (ivadim == 0) imemo = nvamaj
ivadim = kvadim
itrunc = ktrunc
imtra = nmtra
iptrl => nztrl
pvatra => vatra
pvazxbar => vazxbar
pvazx => vazx
else
if(.not. allocated(zvatra)) allocate(zvatra(imtra))
iptrl => iztrl
pvatra => zvatra
call setvatra(pvatra,imtra,ivadim,itrunc,iptrl,vatra,nmtra
& ,kvadim,ktrunc,nztrl,.true.,kksdim,nvamaj,k1gc,nlatbin)
if(.not. allocated(zvazxbar)) allocate(zvazxbar(ivadim))
pvazxbar => zvazxbar
pvazxbar = 0.d0
call setvazx(pvazxbar,itrunc,vazxbar,ktrunc,.true.,kksdim,nlatbin)
if(.not. allocated(zvazx)) allocate(zvazx(ivadim))
pvazx => zvazx
pvazx = 0.d0
call setvazx(pvazx,itrunc,vazx,ktrunc,.true.,kksdim,nlatbin)
endif
cl_version = 'V2'
write(ireslun) cl_version,k1gc,nsim3d,kbrpstamp,zeps1,zdf1,itertot,isimtot
& ,ivadim, itrunc
write(ireslun) imtra,iptrl
c write(ireslun) iptrl, pvatra
if(k1gc.eq.3) ictrlvec = 2*imemo+1
if(k1gc.eq.4) ictrlvec = 2*imemo
do jvadim = 1, ictrlvec
write(ireslun) pvatra((jvadim-1)*ivadim+1:jvadim*ivadim)
enddo
*
* Write Residual Hessian (needed when LAM)
* ----------------------------------------
if (ictrlvec*ivadim.lt.imtra.and.grd_typ_S.eq.'LU') write(ireslun) pvatra(ictrlvec*ivadim+1:imtra)
*
if(k1gc.eq.4) write(ireslun) pvatra(ictrlvec*ivadim+1:ictrlvec
& *ivadim+1)
c if(k1gc.eq.3) write(ireslun) iptrl, pvatra(1:(2*imemo+1)*ivadim )
c if(k1gc.eq.4) write(ireslun) iptrl, pvatra(1:(2*imemo) *ivadim+1)
write(ireslun) pvazxbar
write(ireslun) pvazx
ierr = fclos(ireslun)
else
call abort3d(nulout," RW_VATRA: status not valid ")
endif
*
return
end