!-------------------------------------- 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 --------------------------------------
***s/r v4d_putdx - Prepare and Write increments or adjoint increments
* to be read by 3D-Var
*
#include "model_macros_f.h"
*
subroutine v4d_putdx(kstatus) 4,24
*
use v4d_prof, only: Pr_mode_S, Pr_nsim4d
use v4dz, only: V4dzgauss_ni,V4dzgauss_nj
*
implicit none
*
integer, intent(inout):: kstatus
*
*author
* P. Gauthier
*
*revision
* v3_00 - P. Gauthier - initial MPI version
* v3_00 - M. Tanguay - add v4d_gauss2gem_ad/Simon's exchange
* v3_01 - Tanguay/Buehner - introduce gem2gauss for singular vectors
* v3_02 - Tanguay M. - locate HU in tracers
* v3_30 - Fillion/Tanguay - Adapt diagnostics for LAM
*
*object
* -------------------------
* If V4dg_di_L or V4dg_tl_L
* -------------------------
* 1) All processors: Conversion from GEM units and Staggering to 3D-Var units
* 2) Proc0: Transfert from GEM scalar grid to Gaussian grid
* 3) Proc0: Write increments to be read by 3D-Var
*
* ------------
* If V4dg_ad_L
* ------------
* 1) All processors: Adjoint of [Conversion from 3D-Var units to GEM units and Staggering]
* 2) Proc0: Adjoint of [Transfert from Gaussian grid to GEM scalar grid]
* 3) Proc0: Write adjoint increments to be read by 3D-Var
*
*arguments
* Name I/O Description
*----------------------------------------------------------------
* kstatus I Status of the job
*----------------------------------------------------------------
*
*implicits
#include "glb_ld.cdk"
#include "v4dg.cdk"
#include "lun.cdk"
#include "vt1.cdk"
#include "vt1m.cdk"
#include "ptopo.cdk"
#include "geomg.cdk"
#include "tr3d.cdk"
#include "lctl.cdk"
#include "path.cdk"
#include <clib_interface.cdk>
#include <prof_f.h>
*
* Local variables
* ---------------
integer istat,ihdlout,icount,jlev,jlat,jlon,ierr,
% pnerr,pnlkey1(8),nigauss,njgauss,inn
*
real*8,allocatable:: dlbuff_8(:,:), dlbuff2d_8(:)
real, allocatable:: zbuff(:,:,:),zbuff2d(:,:)
real, allocatable:: gut1 (:,:,:),gvt1(:,:,:),gtpt1(:,:,:),
% ghut1(:,:,:),gst1(:,:)
*
character*256 pathdwga_S,pathdwgf_S
*
integer vmmlod,vmmget,vmmuld,prof_wrrec
external vmmlod,vmmget,vmmuld,prof_wrrec
*
integer key1(Tr3d_ntr), key1_, key1m(Tr3d_ntr), key1m_, n, err
real hut1, hut1m
pointer (pahu1, hut1(LDIST_SHAPE,*)), (pahu1m, hut1m(LDIST_SHAPE,*))
*
real*8, parameter :: ZERO_8 = 0.0
*
logical plpr_L
* ______________________________________________________
*
if ( V4dg_di_L ) call gem_stop('v4d_putdx',-1)
* ______________________________________________________
*
write(Lun_out,2000)
* Flag for diagnostics
* --------------------
plpr_L=.false.
*
* Recall dimensions of 3D-Var Gaussian grid
* -----------------------------------------
nigauss = V4dzgauss_ni
njgauss = V4dzgauss_nj
*
if (Ptopo_myproc.eq.0) then
if(.not.allocated(gut1 )) allocate(gut1 (nigauss,njgauss,G_nk))
if(.not.allocated(gvt1 )) allocate(gvt1 (nigauss,njgauss,G_nk))
if(.not.allocated(gtpt1)) allocate(gtpt1(nigauss,njgauss,G_nk))
if(.not.allocated(ghut1)) allocate(ghut1(nigauss,njgauss,G_nk))
if(.not.allocated(gst1 )) allocate(gst1 (nigauss,njgauss) )
*
* Zero adjoint variables
* ----------------------
gut1 (:,:,:) = ZERO_8
gvt1 (:,:,:) = ZERO_8
gtpt1(:,:,:) = ZERO_8
ghut1(:,:,:) = ZERO_8
gst1 (:,: ) = ZERO_8
endif
*
* Get fields in memory
* --------------------
pnlkey1(1) = VMM_KEY(ut1)
pnlkey1(2) = VMM_KEY(vt1)
pnlkey1(3) = VMM_KEY(tpt1)
pnlkey1(4) = VMM_KEY(st1)
*
if(V4dg_tl_L.or.V4dg_ad_L) then
pnlkey1(5) = VMM_KEY(tpt1m)
pnlkey1(6) = VMM_KEY(st1m)
*
pnerr = vmmlod(pnlkey1,6)
*
pnerr = VMM_GET_VAR(tpt1m)
pnerr = VMM_GET_VAR(st1m)
elseif(V4dg_di_L) then
pnerr = vmmlod(pnlkey1,4)
endif
*
pnerr = VMM_GET_VAR(ut1)
pnerr = VMM_GET_VAR(vt1)
pnerr = VMM_GET_VAR(tpt1)
pnerr = VMM_GET_VAR(st1)
*
if(V4dg_tl_L.or.V4dg_ad_L) then
*
* Load PERT and TRAJ humidity fields
* ----------------------------------
key1_ = VMM_KEY (trt1 )
key1m_= VMM_KEY (trt1m)
do n=1,Tr3d_ntr
key1 (n) = key1_ + n
key1m(n) = key1m_ + n
end do
err = vmmlod(key1, Tr3d_ntr)
err = vmmlod(key1m,Tr3d_ntr)
do n=1,Tr3d_ntr
if (Tr3d_name_S(n).eq.'HU') then
err = vmmget(key1 (n),pahu1, hut1 )
err = vmmget(key1m(n),pahu1m,hut1m)
endif
end do
*
elseif(V4dg_di_L) then
*
* Load humidity fields
* --------------------
key1_ = VMM_KEY (trt1 )
do n=1,Tr3d_ntr
key1 (n) = key1_ + n
end do
err = vmmlod(key1, Tr3d_ntr)
do n=1,Tr3d_ntr
if (Tr3d_name_S(n).eq.'HU') err = vmmget(key1 (n),pahu1, hut1 )
end do
*
endif
*
if(plpr_L) then
inn= 0
if (G_lam) then
inn=1
endif
write(Lun_out,*) 'BEFORE VARCONV OR VARCONV_AD'
call glbstat(ut1 ,'UU',LDIST_DIM,G_nk,1,G_ni-inn,1,G_nj, 1,G_nk)
call glbstat(vt1 ,'VV',LDIST_DIM,G_nk,1,G_ni,1,G_nj-1,1,G_nk)
call glbstat(tpt1,'TP',LDIST_DIM,G_nk,1,G_ni,1,G_nj, 1,G_nk)
call glbstat(st1 ,'4S',LDIST_DIM, 1,1,G_ni,1,G_nj, 1, 1)
call glbstat(hut1,'HU',LDIST_DIM,G_nk,1,G_ni,1,G_nj, 1,G_nk)
write(Lun_out,*) '-----------------------'
endif
*
if(V4dg_di_L.or.V4dg_tl_L) then
* --------------------------------------------------------
* Conversion from GEM units and Staggering to 3D-Var units
* --------------------------------------------------------
*
* Direct (nonlinear)
* ------------------
if(V4dg_di_L) then
call v4d_varconv(ut1,vt1,tpt1,hut1,st1,LDIST_DIM,l_nk,.FALSE.)
*
* TLM
* ---
elseif(V4dg_tl_L) then
call v4d_varconv_tl(ut1,vt1,tpt1,hut1,st1,
$ tpt1m,hut1m,st1m,LDIST_DIM,l_nk,.FALSE.)
end if
*
elseif(V4dg_ad_L) then
* ---------------------------------------------------------------------
* Adjoint of [Conversion from 3D-Var units to GEM units and Staggering]
* ---------------------------------------------------------------------
call v4d_varconv_ad(ut1,vt1,tpt1,hut1,st1,
% tpt1m,hut1m,st1m,LDIST_DIM,l_nk,.TRUE.)
endif
*
if(Ptopo_myproc.eq.0) then
*
if(V4dg_di_L.or.V4dg_tl_L) then
*
* 1A.Opening dwgf PROF file
* ----------------------
write(Lun_out,*) 'Opening file dwgf PROF file'
*
pathdwgf_S = trim(Path_xchg_S)//'/dwgf1.prof'
ihdlout = prof_open(pathdwgf_S,'WRITE',Pr_mode_S)
*
if(ihdlout.le.0) then
write(Lun_out,*) 'Problem opening dwgf PROF file'
kstatus = -99
goto 1001
end if
*
elseif(V4dg_ad_L) then
*
* 1B.Opening dwga PROF file
* ----------------------
write(Lun_out,*) 'Opening file dwga PROF file'
*
pathdwga_S = trim(Path_xchg_S)//'/dwga.prof'
ihdlout = prof_open(pathdwga_S,'WRITE',Pr_mode_S)
*
if(ihdlout.le.0) then
write(Lun_out,*) 'Problem opening dwga PROF file'
kstatus = -99
goto 1001
end if
*
end if
*
end if
*
1001 call rpn_comm_bcast(kstatus,1,"MPI_INTEGER",0,"GRID",ierr)
*
if(kstatus.ne.0) return
*
* 2. Collect and write all 3D and 2D dynamical fields
* ------------------------------------------------
*
* -----------------------------------------------------------------
* Allocate local 3D and 2D global buffer (one real and one real*8)
* -----------------------------------------------------------------
if(Ptopo_myproc.eq.0) then
*
allocate( zbuff(nigauss,njgauss,G_nk))
allocate(dlbuff_8(nigauss*njgauss,G_nk))
*
allocate( zbuff2d(nigauss,njgauss))
allocate(dlbuff2d_8(nigauss*njgauss))
*
* Zero adjoint variables
* ----------------------
zbuff(:,:,:) = ZERO_8
zbuff2d(:,:) = ZERO_8
*
end if
*
if(plpr_L) then
write(Lun_out,*) 'BEFORE GAUSS2GEM_AD OR GEM2GAUSS'
if(G_lam) then
call glbstat(ut1 ,'UU',LDIST_DIM,G_nk,1,G_ni-1,1,G_nj, 1,G_nk)
else
call glbstat(ut1 ,'UU',LDIST_DIM,G_nk,1,G_ni, 1,G_nj, 1,G_nk)
endif
call glbstat(vt1 ,'VV',LDIST_DIM,G_nk,1,G_ni,1,G_nj-1,1,G_nk)
call glbstat(tpt1,'TP',LDIST_DIM,G_nk,1,G_ni,1,G_nj, 1,G_nk)
call glbstat(st1 ,'4S',LDIST_DIM, 1,1,G_ni,1,G_nj, 1, 1)
call glbstat(hut1,'HU',LDIST_DIM,G_nk,1,G_ni,1,G_nj, 1,G_nk)
write(Lun_out,*) '-----------------------'
endif
*
if(V4dg_di_L.or.V4dg_tl_L) then
* -----------------------------------------------
* Transfert from GEM scalar grid to Gaussian grid
* -----------------------------------------------
call v4d_gem2gauss ( ut1, vt1, tpt1, hut1, st1, LDIST_DIM,
% gut1,gvt1,gtpt1,ghut1,gst1,nigauss,njgauss,G_nk)
*
elseif(V4dg_ad_L) then
* ------------------------------------------------------------
* Adjoint of [Transfert from Gaussian grid to GEM scalar grid]
* ------------------------------------------------------------
call v4d_gauss2gem_ad( ut1, vt1, tpt1, hut1, st1, LDIST_DIM,
% gut1,gvt1,gtpt1,ghut1,gst1,nigauss,njgauss,G_nk)
*
endif
*
if(Ptopo_myproc.eq.0) then
*
* -----------------------------
* Write all 3D dynamical fields
* -----------------------------
zbuff(:,:,:) = gut1 (:,:,:)
call v4d_putfld('UU',kstatus)
*
if(kstatus.ne.0) goto 1002
*
zbuff(:,:,:) = gvt1 (:,:,:)
call v4d_putfld('VV',kstatus)
*
if(kstatus.ne.0) goto 1002
*
zbuff(:,:,:) = gtpt1(:,:,:)
call v4d_putfld('TT',kstatus)
*
if(kstatus.ne.0) goto 1002
*
zbuff(:,:,:) = ghut1(:,:,:)
call v4d_putfld('HU',kstatus)
*
if(kstatus.ne.0) goto 1002
*
write(Lun_out,*) 'Write first record with 3D fields...'
*
istat = prof_wrrec(ihdlout)
*
if(istat.ne.0) then
write(Lun_out,*) 'Problem writing first record with 3D fields'
kstatus = -99
goto 1002
endif
*
* -----------------------------
* Write all 2D dynamical fields
* -----------------------------
zbuff2d(:,:) = gst1(:,:)
call v4d_putfld('PS',kstatus)
*
if(kstatus.ne.0) goto 1002
*
write(Lun_out,*) 'Write second record with 2D fields...'
*
istat = prof_wrrec(ihdlout)
*
if(istat.ne.0) then
write(Lun_out,*) 'Problem writing second record with 2D fields'
kstatus = -99
goto 1002
endif
*
endif
*
1002 call rpn_comm_bcast(kstatus,1,"MPI_INTEGER",0,"GRID",ierr)
*
if(kstatus.ne.0) return
*
* -------------
* Deallocations
* -------------
if(Ptopo_myproc.eq.0) then
*
deallocate(zbuff, dlbuff_8 )
deallocate(zbuff2D,dlbuff2d_8)
*
if(allocated (gut1 )) deallocate(gut1 )
if(allocated (gvt1 )) deallocate(gvt1 )
if(allocated (gtpt1 )) deallocate(gtpt1 )
if(allocated (ghut1 )) deallocate(ghut1 )
if(allocated (gst1 )) deallocate(gst1 )
*
endif
*
pnerr = vmmuld(-1,0)
*
if(Ptopo_myproc.eq.0) then
*
if(V4dg_di_L.or.V4dg_tl_L) then
*
* 3A.Closing dwgf PROF file
* ----------------------
write(Lun_out,*) 'Closing file dwgf PROF file'
*
istat = prof_close(ihdlout)
*
if(istat.ne.0) then
write(Lun_out,*) 'Problem closing file dwgf PROF file'
kstatus = -99
goto 1003
endif
*
elseif(V4dg_ad_L) then
*
* 3B.Closing dwga PROF file
* ----------------------
write(Lun_out,*) 'Closing file dwga PROF file'
*
istat = prof_close(ihdlout)
*
if(istat.ne.0) then
write(Lun_out,*) 'Problem closing file dwga PROF file'
kstatus = -99
goto 1003
endif
*
end if
*
end if
*
1003 call rpn_comm_bcast(kstatus,1,"MPI_INTEGER",0,"GRID",ierr)
*
if(kstatus.ne.0) return
*
write(Lun_out,2001) kstatus
*
2000 format(/,'V4D_PUTDX: Prepare Model state to be sent to 3D-Var ',
+ /,'====================================================')
2001 format(/,'V4D_PUTDX: Model state sent to 3D-Var --- Status = ',I8,
+ /,'===================================================')
*
return
*
* Local Host subroutine
* ---------------------
*
contains
subroutine v4d_putfld(cdvar,kstatus) 10,1
*
implicit none
*
character*2, intent(in) :: cdvar
integer, intent(inout) :: kstatus
*
*author
* P. Gauthier
*
*revision
* v3_00 - P. Gauthier - initial MPI version
* v3_01 - M. Tanguay - introduce gem2gauss for singular vectors
* v3_11 - P. Gauthier - Adjust latitude reversing when V4dg_vstag_L
* v3_30 - Fillion/Tanguay - Allow Limited-Area option
*
*object
*
*arguments
* Name I/O Description
*----------------------------------------------------------------
* cdvar I Type of profile
* kstatus I Status of the job
*----------------------------------------------------------------
*
*implicits
#include "v4dg.cdk"
*
integer njx
*
write(Lun_out,*)' ... collecting variable ',cdvar
*
* Adjoint of
* Change accuracy and reverse latitude if 3D field
* ------------------------------------------------
select case (cdvar)
case('UU','VV','TT','HU')
dlbuff_8(:,:) = 0.
*
if(.not.G_lam) then
njx = njgauss
if(cdvar.eq.'VV'.and.V4dg_vstag_L) njx = njgauss -1
do jlev = 1, G_nk
icount = 0
do jlat = 1,njx
do jlon = 1,nigauss
icount = icount+1
dlbuff_8(icount,jlev) = zbuff(jlon,njx -jlat+1,jlev)
end do
end do
end do
else
njx = njgauss
if(cdvar.eq.'VV'.and.V4dg_vstag_L) njx = njgauss -1
do jlev = 1, G_nk
icount = 0
do jlat = 1,njx
do jlon = 1,nigauss
icount = icount+1
dlbuff_8(icount,jlev) = zbuff(jlon,jlat,jlev)
end do
end do
end do
endif
*
* Adjoint of
* Change accuracy and reverse latitude if 2D field
* ------------------------------------------------
case('PS')
dlbuff2d_8(:) = 0.
if(.not.G_lam) then
icount = 0
do jlat = 1,njgauss
do jlon = 1,nigauss
icount = icount+1
dlbuff2d_8(icount) = zbuff2d(jlon,njgauss -jlat+1)
end do
end do
else
icount = 0
do jlat = 1,njgauss
do jlon = 1,nigauss
icount = icount+1
dlbuff2d_8(icount) = zbuff2d(jlon,jlat)
end do
end do
endif
end select
*
* Store 4D-Var simulation no.
* ---------------------------
istat = prof_pvar(ihdlout,Pr_nsim4d,PRM_EVNT)
*
* Write it in Prof Record
* -----------------------
select case (cdvar)
case('UU')
istat = prof_pvar(ihdlout,dlbuff_8,v3d_utru) + istat
case('VV')
istat = prof_pvar(ihdlout,dlbuff_8,v3d_vtru) + istat
case('TT')
istat = prof_pvar(ihdlout,dlbuff_8,v3d_temp) + istat
case('HU')
istat = prof_pvar(ihdlout,dlbuff_8,v3d_sphu) + istat
case('PS')
istat = prof_pvar(ihdlout,dlbuff2d_8,v2d_psur) + istat
end select
*
kstatus = 0
*
if(istat.ne.0) then
write(Lun_out,*)'Problem in writing ',cdvar
kstatus = -99
return
endif
*
write(Lun_out,*)' Transfer of ',cdvar,' completed ...Status = ',kstatus
*
end subroutine v4d_putfld
end subroutine v4d_putdx