!-------------------------------------- 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_varconv_ad - ADJ of conversion control variables GEM <--> 3D-Var
*
#include "model_macros_f.h"
*
subroutine v4d_varconv_ad( C_ut1, C_vt1, C_tt1, C_hut1, C_st1, 3,4
$ C_tt1m, C_hut1m, C_st1m, DIST_DIM, Nk, inverse_L )
*
implicit none
*
integer DIST_DIM,Nk
real C_ut1 (DIST_SHAPE,Nk), C_vt1 (DIST_SHAPE,Nk),
% C_tt1 (DIST_SHAPE,Nk), C_hut1 (DIST_SHAPE,Nk),
% C_st1 (DIST_SHAPE),
% C_tt1m(DIST_SHAPE,Nk), C_hut1m(DIST_SHAPE,Nk),
% C_st1m(DIST_SHAPE)
logical inverse_L
*
*author
* Stephane Laroche
*
*revision
* v3_00 - Laroche S. - initial MPI version
* v3_00 - Gauthier P. - ln q to q
* v3_00 - Tanguay M. - verify zeroing of hut1m
* v3_02 - Laroche S. - conversion to hybrid coordinate
* v3_02 - Buehner M. - temporarilly set humidity to zero for SV job
* v3_11 - Tanguay M. - Add option for profiles done on U-V grids for winds
* - Add option for staggering already done by 3D-Var
* v3_20 - Buehner & Zadra - add option for using HU as humidity variable
* v3_30 - Fillion/Tanguay - Extend the scaling to all the grid in LAM mode
* v3_31 - Tanguay M. - Add OPENMP directives
*
*object
*
*arguments
* Name I/O Description
*----------------------------------------------------------------
* C_ut1
* C_vt1
* C_tt1
* C_hut1
* C_st1
*----------------------------------------------------------------
*
*implicits
#include "glb_ld.cdk"
#include "geomg.cdk"
#include "cstv.cdk"
#include "dcst.cdk"
#include "v4dg.cdk"
*
*modules
*
integer i, j, k
real*8 pri2c_8
real wu(LDIST_SHAPE,l_nk),wv(LDIST_SHAPE,l_nk)
if(.not.inverse_L) then
C
C Conversion GEM --> 4D-Var
C =========================
C
*
* Humidity: Delta(log q) = Delta q / q(ref)
*
if (V4dg_chum_s.eq.'LQ') then
!$omp parallel do
do k=1,Nk
do j= 1, l_nj
do i= 1, l_ni
if(C_hut1m(i,j,k).eq.0.0) then
C_hut1(i,j,k) = 0.0
else
C_hut1(i,j,k) = C_hut1(i,j,k)/C_hut1m(i,j,k)
endif
end do
end do
end do
!$omp end parallel do
endif
C
C Winds
C -----
C
if (.not.V4dg_pruv_L) then
*
!$omp parallel do
do k=1,Nk
do j= 1, l_nj
pri2c_8 = (1.0/Geomg_cy_8(j))*Dcst_rayt_8
do i= 1, l_ni
C_ut1(i,j,k) = C_ut1(i,j,k)*pri2c_8
C_vt1(i,j,k) = C_vt1(i,j,k)*pri2c_8
end do
end do
end do
!$omp end parallel do
call itf_phy_uvgridscal_ad ( C_ut1, C_vt1, LDIST_DIM, Nk, .true. )
*
else
*
!$omp parallel do
do k=1,Nk
do j= 1, l_njv
pri2c_8 = (1.0/Geomg_cyv_8(j))*Dcst_rayt_8
do i= 1, l_ni
C_vt1(i,j,k) = C_vt1(i,j,k)*pri2c_8
end do
end do
end do
!$omp end parallel do
*
!$omp parallel do
do k=1,Nk
do j= 1, l_nj
pri2c_8 = (1.0/Geomg_cy_8(j))*Dcst_rayt_8
do i= 1, l_niu
C_ut1(i,j,k) = C_ut1(i,j,k)*pri2c_8
end do
end do
end do
!$omp end parallel do
*
endif
C
C Temperature
C -----------
C
!$omp parallel do
do k=1,Nk
do j= 1, l_nj
do i= 1, l_ni
C_hut1(i,j,k) = C_hut1(i,j,k)
$ - (C_tt1(i,j,k)*Dcst_delta_8/(1.0 + Dcst_delta_8*C_hut1m(i,j,k)))
$ *((C_tt1m(i,j,k) + Cstv_tstr_8)/(1.0 + Dcst_delta_8*C_hut1m(i,j,k)))
C_tt1(i,j,k) = (C_tt1(i,j,k)/(C_tt1m(i,j,k) + Cstv_tstr_8))
$ *((C_tt1m(i,j,k) + Cstv_tstr_8)/(1.0 + Dcst_delta_8*C_hut1m(i,j,k)))
end do
end do
end do
!$omp end parallel do
C
C Surface pressure
C ----------------
C
!$omp parallel do
do j= 1, l_nj
do i= 1, l_ni
C_st1(i,j) = Geomg_z_8(Nk) * exp(C_st1m(i,j)) * C_st1(i,j)
end do
end do
!$omp end parallel do
*
else
*
C
C Conversion 4D-Var --> GEM
C =========================
C
*
C
C Winds
C -----
*
* Zero adjoint variables
* ----------------------
!$omp parallel do
do k=1,Nk
do j=l_miny,l_maxy
do i=l_minx,l_maxx
wu(i,j,k) = 0.0
wv(i,j,k) = 0.0
enddo
enddo
enddo
!$omp end parallel do
*
if(V4dg_vstag_L) then
!$omp parallel do
do k=1,Nk
do j= 1, l_njv
pri2c_8 = (1.0/Geomg_cyv_8(j))*Dcst_rayt_8
do i= 1, l_ni
C_vt1(i,j,k) = C_vt1(i,j,k)/pri2c_8
end do
end do
end do
!$omp end parallel do
endif
*
if(V4dg_ustag_L) then
!$omp parallel do
do k=1,Nk
do j= 1, l_nj
pri2c_8 = (1.0/Geomg_cy_8(j))*Dcst_rayt_8
do i= 1, l_niu
C_ut1(i,j,k) = C_ut1(i,j,k)/pri2c_8
end do
end do
end do
!$omp end parallel do
endif
*
if(.not.V4dg_ustag_L.and..not.V4dg_vstag_L) then
call itf_phy_uvgridscal_ad ( C_ut1, C_vt1, LDIST_DIM, Nk, .false. )
*
elseif(V4dg_ustag_L.and..not.V4dg_vstag_L) then
call itf_phy_uvgridscal_ad ( wu, C_vt1, LDIST_DIM, Nk, .false. )
*
elseif(.not.V4dg_ustag_L.and.V4dg_vstag_L) then
call itf_phy_uvgridscal_ad ( C_ut1, wv, LDIST_DIM, Nk, .false. )
endif
*
if(.not.V4dg_vstag_L) then
!$omp parallel do
do k=1,Nk
do j= 1, l_nj
pri2c_8 = (1.0/Geomg_cy_8(j))*Dcst_rayt_8
do i= 1, l_ni
C_vt1(i,j,k) = C_vt1(i,j,k)/pri2c_8
end do
end do
end do
!$omp end parallel do
endif
*
if(.not.V4dg_ustag_L) then
!$omp parallel do
do k=1,Nk
do j= 1, l_nj
pri2c_8 = (1.0/Geomg_cy_8(j))*Dcst_rayt_8
do i= 1, l_ni
C_ut1(i,j,k) = C_ut1(i,j,k)/pri2c_8
end do
end do
end do
!$omp end parallel do
endif
*
!$omp parallel do
do k=1,Nk
do j=l_miny,l_maxy
do i=l_minx,l_maxx
wu(i,j,k) = 0.0
wv(i,j,k) = 0.0
enddo
enddo
enddo
!$omp end parallel do
C
C Temperature
C -----------
C
!$omp parallel do
do k=1,Nk
do j= 1, l_nj
do i= 1, l_ni
C_hut1(i,j,k) = C_hut1(i,j,k) + C_tt1(i,j,k)*Dcst_delta_8
$ *(C_tt1m(i,j,k) + Cstv_tstr_8)/(1.0 + Dcst_delta_8*C_hut1m(i,j,k))
C_tt1(i,j,k) = C_tt1(i,j,k)*(1.0 + Dcst_delta_8*C_hut1m(i,j,k))
end do
end do
end do
!$omp end parallel do
C
C Surface pressure
C ----------------
C
!$omp parallel do
do j= 1, l_nj
do i= 1, l_ni
C_st1(i,j) = C_st1(i,j)/(Geomg_z_8(Nk) * exp(C_st1m(i,j)))
end do
end do
!$omp end parallel do
C
C Humidity: Delta q = q(ref) * Delta( log q)
C
if (V4dg_chum_s.eq.'LQ') then
!$omp parallel do
do k=1,Nk
do j= 1, l_nj
do i= 1, l_ni
C_hut1(i,j,k) = C_hut1(i,j,k)*C_hut1m(i,j,k)
end do
end do
end do
!$omp end parallel do
endif
*
endif
*
* TEMPORARY: Set humidity field to zero for SV job
c if(V4dg_sgvc_L) C_hut1(:,:,:)=0.0
*
return
end