!-------------------------------------- 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_rwconv - Read (Write) from (on) TRAJ Conversion WA file
* at each observation time (needed in v4d_varconv)
*
#include "model_macros_f.h"
*
subroutine v4d_rwconv () 10,10
*
implicit none
*
*author
* Stephane Laroche
*
*revision
* v3_00 - Laroche S. - initial MPI version (from v4d_rwtraj)
* v3_00 - N. Ek - update for humidity
* v3_00 - Tanguay M. - parameters v4d_rwfld/initialize addcv in v4d_4dvar
* v3_02 - Laroche S. - humidity clipping based on relative humidity
* v3_02 - Tanguay M. - locate HU in tracers
*
*object
* see id section
*
*arguments
* none
*
*implicits
#include "glb_ld.cdk"
#include "vt1.cdk"
#include "vt1m.cdk"
#include "tr3d.cdk"
#include "cstv.cdk"
#include "geomg.cdk"
#include "v4dg.cdk"
#include "lun.cdk"
*
*modules
integer vmmlod,vmmget,vmmuld
external vmmlod,vmmget,vmmuld
*
integer pnerr,pnlod,pnlkey1(3), key1_, key1(max(Tr3d_ntr,4)),
& key1m_, key1m(max(Tr3d_ntr,4)),i,j,k
*
real pr1,hut1,hut1m
pointer (pahu1,hut1(LDIST_SHAPE,*)),(pahu1m,hut1m(LDIST_SHAPE,*))
*
logical plpr_L,hu_threshold_L
*
logical done_once_L
save done_once_L
data done_once_L /.false./
*
* Work arrays
* -----------
real work(l_ni*l_nj*l_nk),hut1work(LDIST_SHAPE,l_nk)
real hrwork(l_ni,l_nk),huwork(l_ni,l_nk),txwork(l_ni,l_nk)
real lpwork(l_ni,l_nk),pxwork(l_nk)
real threshold
* ______________________________________________________
*
* Flag to trace storing and retrieving of trajectory
* --------------------------------------------------
plpr_L = .false.
plpr_L = plpr_L.and.Lun_out.gt.0
*
* Specify if we need to impose a threshold to hu
* ----------------------------------------------
hu_threshold_L = .true.
C threshold = 0.02
threshold = 0.05
*
if(.not.done_once_L.and.Lun_out.gt.0) write(Lun_out,*) 'VALUE OF THRESHOLD =',threshold
done_once_L = .true.
*
* ----------------
* Read TRAJ Fields
* ----------------
if(V4dg_rwcv.eq.0) then
*
pnlkey1(1) = VMM_KEY(tpt1m)
pnlkey1(2) = VMM_KEY(st1m)
pnlod = 2
* - - - - - - - - - - - - - - -
pnerr = vmmlod(pnlkey1,pnlod)
* - - - - - - - - - - - - - - -
pnerr = VMM_GET_VAR(tpt1m)
pnerr = VMM_GET_VAR(st1m)
*
* Load TRAJ humidity field
* ------------------------
key1m_ = VMM_KEY (trt1m)
do k=1,Tr3d_ntr
key1m(k) = key1m_ + k
end do
pnerr = vmmlod(key1m,Tr3d_ntr)
do k=1,Tr3d_ntr
if (Tr3d_name_S(k).eq.'HU') pnerr = vmmget(key1m(k),pahu1m,hut1m)
end do
*
* TANGENT LINEAR MODEL
* --------------------
if(V4dg_tl_L) then
*
call v4d_rwfld (tpt1m,work,l_ni,l_nj,LDIST_DIM,l_nk,
% V4dg_iuncv,V4dg_addcv,plpr_L,'TPT1M', V4dg_ad_L,0,-1)
*
call v4d_rwfld (hut1m,work,l_ni,l_nj,LDIST_DIM,l_nk,
% V4dg_iuncv,V4dg_addcv,plpr_L,'HUT1M', V4dg_ad_L,0,-1)
*
call v4d_rwfld (st1m,work,l_ni,l_nj,LDIST_DIM,1,
% V4dg_iuncv,V4dg_addcv,plpr_L,'ST1M', V4dg_ad_L,0,-1)
*
endif
*
* ADJOINT MODEL
* -------------
if(V4dg_ad_L) then
*
call v4d_rwfld (st1m,work,l_ni,l_nj,LDIST_DIM,1,
% V4dg_iuncv,V4dg_addcv,plpr_L,'ST1M', V4dg_ad_L,
% l_ni*l_nj*l_nk,-1)
*
call v4d_rwfld (hut1m,work,l_ni,l_nj,LDIST_DIM,l_nk,
% V4dg_iuncv,V4dg_addcv,plpr_L,'HUT1M', V4dg_ad_L,
% l_ni*l_nj*l_nk,-1)
*
call v4d_rwfld (tpt1m,work,l_ni,l_nj,LDIST_DIM,l_nk,
% V4dg_iuncv,V4dg_addcv,plpr_L,'TPT1M', V4dg_ad_L,
% l_ni*l_nj,-1)
endif
*
* -----------------
* Write TRAJ Fields
* -----------------
elseif(V4dg_rwcv.eq.1) then
*
pnlkey1(1) = VMM_KEY(tpt1)
pnlkey1(2) = VMM_KEY(st1)
pnlod = 2
* - - - - - - - - - - - - - - -
pnerr = vmmlod(pnlkey1,pnlod)
* - - - - - - - - - - - - - - -
pnerr = VMM_GET_VAR(tpt1)
pnerr = VMM_GET_VAR(st1)
*
* Load humidity field
* -------------------
key1_ = VMM_KEY (trt1)
do k=1,Tr3d_ntr
key1(k) = key1_ + k
end do
pnerr = vmmlod(key1,Tr3d_ntr)
do k=1,Tr3d_ntr
if (Tr3d_name_S(k).eq.'HU') pnerr = vmmget(key1(k),pahu1,hut1)
end do
*
do k=1,l_nk
do j=l_miny,l_maxy
do i=l_minx,l_maxx
* hut1work(i,j,k) = MAX(2.5e-6,hut1(i,j,k))
hut1work(i,j,k) = hut1(i,j,k)
enddo
enddo
enddo
* Check if the relative humidity is less then threshold
* in percent (threshold*100)
* ------------------------------------------------------
*
if(hu_threshold_L) then
do j=1,l_nj
do k=1,l_nk
do i=1,l_ni
hrwork(i,k) = threshold*(((float(k)/l_nk))**2)
txwork(i,k) = tpt1(i,j,k) + Cstv_tstr_8
lpwork(i,k) = Geomg_z_8(k) + Geomg_pib(k)*(exp(st1(i,j)-1.))
enddo
enddo
CALL MHRAHU(huwork,hrwork,txwork,pxwork,lpwork,
% 3,.false.,.true.,l_ni,l_nk,l_ni)
do k=1,l_nk
do i=1,l_ni
huwork(i,k) = MAX(2.5e-6,huwork(i,k))
if(hut1(i,j,k).lt.huwork(i,k)) hut1work(i,j,k) = huwork(i,k)
enddo
enddo
enddo
endif
*
* Write TRAJ Fields
* -----------------
*
call v4d_rwfld (tpt1,work,l_ni,l_nj,LDIST_DIM,l_nk,
% V4dg_iuncv,V4dg_addcv,plpr_L,'TPT1', V4dg_ad_L,0,1)
*
call v4d_rwfld (hut1work,work,l_ni,l_nj,LDIST_DIM,l_nk,
% V4dg_iuncv,V4dg_addcv,plpr_L,'HUT1', V4dg_ad_L,0,1)
*
call v4d_rwfld (st1,work,l_ni,l_nj,LDIST_DIM,1,
% V4dg_iuncv,V4dg_addcv,plpr_L,'ST1', V4dg_ad_L,0,1)
*
endif
*
pnerr = vmmuld(-1,0)
*
return
end