!-------------------------------------- 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_phystep_ad - Apply the adjoint simplified physical processes: CMC/RPN package
*
#include "model_macros_f.h"
*
subroutine p_phystep_ad (F_stepno) 1,12
implicit none
*
integer F_stepno
*
*author
* Stephane Laroche Janvier 2001
*
*revision
* v3_00 - Laroche S. - initial MPI version
* v3_02 - Laroche S. - allows physic variables outputs
* v3_11 - Laroche S. - AIXport+Opti+OpenMP for TLM-ADJ
* v3_30 - Tanguay M. - adapt TL/AD to itf/new tendencies
* - Validation for LAM version
* v3_31 - Tanguay M. - Introduce Ptopo_smtphy
*
*object
* Computes the physical processes and apply the resulting
* tendencies to the dynamic variables of the model:
* CMC/RPN package
*
*arguments
* Name I/O Description
*----------------------------------------------------------------
* F_stepno O step number
*----------------------------------------------------------------
*
*implicits
#include "glb_ld.cdk"
#include "lun.cdk"
#include "mem.cdk"
#include "macro.cdk"
#include "ptopo.cdk"
#include "itf_phy_busind.cdk"
#include "dimout.cdk"
#include "v4dg.cdk"
#include "p4d_simp.cdk"
#include "itf_phy_buses.cdk"
*
*modules
integer open_db_file,rewind_db_file,close_db_file
external open_db_file,rewind_db_file,close_db_file
integer omp_get_max_threads
external omp_get_max_threads
**
integer dim,err,i,j,k,obussiz
real, dimension(:,:), allocatable :: obusval
real*8, parameter :: ZERO_8 = 0.0
real, dimension(:), allocatable :: up,vp,wp,tp,qp,trp,
$ um,vm,tm,trm,lnpsm,
$ sig,kmm,ktm,
$ upm,vpm,tpm,qpm,trpm,
$ umm,vmm,tmm, trmm
*
* ---------------------------------------------------------------
*
call iniobus(obussiz)
allocate(obusval(p_ni*p_nj,obussiz))
dim = (l_maxx-l_minx+1)*(l_maxy-l_miny+1)*l_nk
allocate (up(dim),vp(dim),wp(dim),tp(dim),qp(dim),
$ um(dim),vm(dim),tm(dim),lnpsm(dim),
$ sig(dim),kmm(dim),ktm(dim),
$ trp(dim*phyt_ntr),trm(dim*phyt_ntr),
$ upm(dim),vpm(dim),tpm(dim),qpm(dim),
$ umm(dim),vmm(dim),tmm(dim),
$ trpm(dim),trmm(dim))
*
* Read TRAJ for the simplified physics
* -------------------------------------
call v4d_rwtraj_sigma (sig,LDIST_DIM,l_nk)
call v4d_rwtraj_phystep(upm,vpm,tpm,qpm,trpm,
$ umm,vmm,tmm, trmm,
$ LDIST_DIM,l_nk)
if( P4d_pbl.eq.2) call v4d_rwtraj_kmkt(kmm,ktm,LDIST_DIM,l_nk)
*
*
* Set adjoint variables to zero
* -----------------------------
*
do i=1,dim
up(i) = ZERO_8
vp(i) = ZERO_8
wp(i) = ZERO_8
tp(i) = ZERO_8
qp(i) = ZERO_8
um(i) = ZERO_8
vm(i) = ZERO_8
tm(i) = ZERO_8
lnpsm(i) = ZERO_8
end do
do i=1,dim*phyt_ntr
trm(i) = ZERO_8
trp(i) = ZERO_8
end do
*
*
*C 6. Apply physics tendencies to the appropriate dynamic fields
*C and insure consistency with other dynamic variables
* ----------------------------------------------------------
*
call p_apply_ad ( um, vm, tm, trm, tp, qp,
$ tpm, trpm, qpm,
$ LDIST_DIM, l_nk)
*
*
*
*C 4. compute physics tendencies
* --------------------------
* initialize the number of slices previously done
*
Mem_pslic = 0
*
if (.not.Mem_phyncore_L) then
err = open_db_file (Lun_waphy)
err = rewind_db_file (Lun_waphy)
endif
*
call pe_rebind (Ptopo_smtphy,(Ptopo_myproc.eq.0).and.
$ (F_stepno.eq.0))
!$omp parallel
!$omp do
do j=1,omp_get_max_threads()
call p_physlb_ad ( j, F_stepno,obusval,
$ up, vp, wp, tp, qp, trp,
$ um, vm, tm, trm,
$ upm, vpm, tpm, qpm, trpm,
$ umm, vmm, tmm, trmm,
$ lnpsm, sig, kmm, ktm, LDIST_DIM, l_nk)
enddo
!$omp enddo
!$omp end parallel
call pe_rebind (Ptopo_smtdyn,(Ptopo_myproc.eq.0).and.
$ (F_stepno.eq.0))
*
*
*C 2. load all fields required by the physic in memory
* ------------------------------------------------
*
call out_phy(obusval,p_ni,p_nj,F_stepno)
deallocate(obusval)
call p_vmmphy_ad ( up, vp, wp, tp, qp, trp,
$ um, vm, tm, trm,
$ lnpsm, sig, LDIST_DIM,l_nk )
*
*
if (.not.Mem_phyncore_L) err = close_db_file (Lun_waphy)
*
deallocate (up,vp,wp,tp,qp,trp,um,vm,tm,trm,lnpsm,sig,kmm,ktm,
$ upm,vpm,tpm,qpm,trpm,umm,vmm,tmm,trmm)
*
*
* ---------------------------------------------------------------
*
return
end