!-------------------------------------- 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 p_fillbus_ad - Adjoint of Fill the slice workspace variable for the physics
*
#include "model_macros_f.h"
*
subroutine p_fillbus_ad ( F_busdyn, 1,2
$ F_up, F_vp, F_wp, F_tp , F_qp, F_trp,
$ F_um, F_vm, F_tm, F_trm, F_lpsm, F_trpm, F_trmm,
$ F_qpm,
$ F_jdo, F_step, DIST_DIM, Nk )
*
implicit none
*
integer F_step,F_jdo, DIST_DIM, Nk
*
real F_busdyn(*)
real F_up (DIST_SHAPE,Nk), F_vp (DIST_SHAPE,Nk),
$ F_wp (DIST_SHAPE,Nk), F_tp (DIST_SHAPE,Nk),
$ F_qp (DIST_SHAPE,Nk), F_trp(DIST_SHAPE,Nk,*),
$ F_um (DIST_SHAPE,Nk), F_vm (DIST_SHAPE,Nk),
$ F_tm (DIST_SHAPE,Nk), F_trm(DIST_SHAPE,Nk,*),
$ F_lpsm (DIST_SHAPE), F_qpm(DIST_SHAPE,Nk),
$ F_trmm(DIST_SHAPE,Nk), F_trpm(DIST_SHAPE,Nk)
*
*author
* Stephane Laroche - January 2002
*
*revision
* v3_00 - Laroche S. - initial MPI version
* v3_02 - Tanguay M./Laroche S. - do not assume TRAJ HU positive
* - contribution of surface pressure
* v3_30 - Tanguay M. - adapt TL/AD to itf
* - Validation for LAM version
*
*object
* Fill the slice workspace variable for the physics.
* Change of units if required
*
*arguments
* Name I/O Description
*----------------------------------------------------------------
* F_busdyn I - dynamic bus
* F_up I - wind image in x direction at time t*
* F_vp I - wind image in y direction at time t*
* F_tp I - virtual temperature at time t*
* F_qp I - ln of pressure at time t*
* F_um I - wind image in x direction at time t-
* F_vm I - wind image in y direction at time t-
* F_tm I - virtual temperature at time t-
* F_lpsm I - ln of surface pressure at time t-
* F_wp I - vertical motion at time t*
* F_sig I - sigma levels
* F_jdo I - slice number being processed
*----------------------------------------------------------------
*
*implicits
#include "glb_ld.cdk"
#include "geomg.cdk"
#include "dcst.cdk"
#include "p_pbl.cdk"
#include "p_cond.cdk"
#include "p_geol.cdk"
#include "itf_phy_buses.cdk"
#include "itf_phy_busind.cdk"
#include "busind_tr.cdk"
*
*notes
*
integer i, k, n, ii, indx, offp, offg, pid, gid, mul
real con
real*8, parameter :: ZERO_8 = 0.0
real wk1(p_ni*l_nk),wk2(p_ni*l_nk)
*
* ---------------------------------------------------------------
*
* Compute temperature from virtual temperature
* --------------------------------------------
*
do k=1,Nk
do i= 1, p_ni
indx = (k-1)*p_ni+i-1
wk1(indx+1) = F_busdyn(tplus +indx)
wk2(indx+1) = F_busdyn(tmoins +indx)
F_busdyn(tplus +indx) = ZERO_8
F_busdyn(tmoins +indx) = ZERO_8
end do
end do
*
call mfottv_ad(wk1, F_busdyn(tplus) , F_busdyn(h2o_ind(1,hucond)),
$ F_busdyn(ttrajp), F_busdyn(hutrajp), p_ni, Nk, p_ni)
call mfottv_ad(wk2, F_busdyn(tmoins) , F_busdyn(h2o_ind(2,hucond)),
$ F_busdyn(ttrajm), F_busdyn(hutrajm), p_ni, Nk, p_ni)
*
*
*
* Surface fields: extract row F_jdo
* ---------------------------------
*
* WARNING: SURFACE PRESSURE (plus) ONLY IN THE SIMPLIFIED PHYSICS
*
do i= 1, p_ni
indx = i-1
ii = i + p_offi
F_qp(ii,F_jdo,Nk) = exp(F_qpm(ii,F_jdo,Nk))*F_busdyn(pplus + indx)
end do
*
*
*C 3D variables: extract row F_jdo
*
con = ( 1.0/cos(geomg_y_8(F_jdo))) * Dcst_rayt_8
do k= 1,Nk
do i= 1, p_ni
indx = (k-1)*p_ni+i-1
ii = i + p_offi
F_tm(ii,F_jdo,k) = F_tm(ii,F_jdo,k) + F_busdyn(tmoins+indx)
F_vm(ii,F_jdo,k) = F_vm(ii,F_jdo,k) + F_busdyn(vmoins+indx)*con
F_um(ii,F_jdo,k) = F_um(ii,F_jdo,k) + F_busdyn(umoins+indx)*con
F_tp(ii,F_jdo,k) = F_tp(ii,F_jdo,k) + F_busdyn(tplus +indx)
F_vp(ii,F_jdo,k) = F_vp(ii,F_jdo,k) + F_busdyn(vplus +indx)*con
F_up(ii,F_jdo,k) = F_up(ii,F_jdo,k) + F_busdyn(uplus +indx)*con
F_busdyn(uplus +indx) = ZERO_8
F_busdyn(vplus +indx) = ZERO_8
F_busdyn(tplus +indx) = ZERO_8
F_busdyn(umoins+indx) = ZERO_8
F_busdyn(vmoins+indx) = ZERO_8
F_busdyn(tmoins+indx) = ZERO_8
end do
end do
*
do n=1,phyt_ntr
if (phyt_ind(2,n).gt.0) then
do k= 1,Nk
do i= 1, p_ni
indx = (k-1)*p_ni+i-1
ii = i + p_offi
*
if(n.eq.hucond) then
if(F_trmm(ii,F_jdo,k).lt.0.) F_busdyn(phyt_ind(2,n)+indx) = 0.
endif
F_trm(ii,F_jdo,k,n) = F_trm(ii,F_jdo,k,n) + F_busdyn(phyt_ind(2,n)+indx)
F_busdyn(phyt_ind(2,n)+indx) = ZERO_8
end do
end do
endif
do k= 1,Nk
do i= 1, p_ni
indx = (k-1)*p_ni+i-1
ii = i + p_offi
if(n.eq.hucond) then
if(F_trpm(ii,F_jdo,k).lt.0.) F_busdyn(phyt_ind(1,n)+indx) = 0.
endif
F_trp(ii,F_jdo,k,n) = F_trp(ii,F_jdo,k,n) + F_busdyn(phyt_ind(1,n)+indx)
F_busdyn(phyt_ind(1,n)+indx) = ZERO_8
end do
end do
end do
*
return
end