!-------------------------------------- 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/P PHY_EXE
subroutine phy_exe (e, d, f, v, 5,39
$ esiz,dsiz,fsiz,vsiz,
$ dt,trnch,kount,task,ni,nk)
*
#include "impnone.cdk"
*
integer esiz,dsiz,fsiz,vsiz,trnch,kount,task,ni,nk
real e(esiz), d(dsiz), f(fsiz), v(vsiz)
real dt
*
*
*Author
* B. Bilodeau Nov 1993 (Routine formerly called "param")
*
*Revisions
* 001 N. Brunet (May 1995) - new surface processes
* 002 M. Gagnon (July 1995) - add reduction parameters to newrad1
* 003 N. Ek (Apr 1995) - Added accumulated surface energy fluxes
* 004 B. Bilodeau (Nov 1995) - Correct bug for MPRECIP
* 005 B. Bilodeau (Jan 1996) - Dynamic allocation of TE
* 006 M. Desgagne and J.-M. Belanger(Nov 1995) -
* Unified physics interface and CLASS
* 007 L. Lefaivre (Nov 95) - Latest version of Mc Farlane (GWDFX95)
* 008 G. Pellerin (Nov 95) - Revised condensation and deep convection
* 009 G. Pellerin (Fev 96) - New options for shallow convection
* 010 B. Dugas (Sep 96) - Correction for stratospheric clouds and
* RADFIX switch added to control usage of radiation fixes
* 011 B. Bilodeau (Sept 1996) - Correct bug in computation of
* tendencies for MPRECIP
* 012 G. Pellerin (Jan 1997) - Execution of whole physics at kount=0.
* Correct extraction of surface fluxes. Change calling sequence
* of vkuocon5.
* 013 M. Desgagne (Apr 1996) - Activate EPLUS (advectke option)
* 014 F. Kong (Dec 1996) - Add new explicit microphysics
* (Ref. Kong & Yau (1996) Atmosphere-Ocean)
* 015 V. Lee (Feb 1996) - Directional roughness length added
* 016 M. Roch (Nov 1997) - Introduce horizontal modulation of sponge
* 017 S. Belair (Spring 1998) - ISBA
* 018 B. Bilodeau (Oct 1998) - Merge phyexe and param4.
* Introduce "entry" bus.
* 019 J. Mailhot (Mar 1999) - Changes for new SURFACE interface
* B. Bilodeau
* 020 S. Belair (January 2000) - Accumulators for ISBA
* 021 B. Bilodeau (Nov 2000) - New comdeck phybus.cdk
* 022 B. Bilodeau (January 2001) - Dynamic memory allocation
* revisited
* 023 B. Dugas (July 2000) - Replace CLIMPHS by CLIMPHS2.
* Add MOYHR cloud average ccnm as well
* as the ttmin, ttmax temperatures.
* 024 J. Mailhot (May 2000) - Changes to add MOISTKE option (ifluvert=3)
* 025 J. Mailhot (Jun 2000) - Correct bug in interface for MIXED-PHASE
* 026 A. Erfani and B. Bilodeau (Oct 2001) - Added the precipitation
* partitioning code developed by A. Methot
* 027 D. Talbot (Oct 2001) - Call to gwd4 (blocking)
* 028 B. Dugas (Nov 2001) - Add the suaf and svaf accumulators
* 029 B. Bilodeau (Mar 2002) - QDIFV tendency = 0 if wet=.false.
* 030 S. Laroche (Apr 2002) - Call simplified physics options as
* suggested by B. Bilodeau and M. Desgagne
* 031 B. Bilodeau (Jun 2002) - Copy level NK of HUMOINS and TMOINS
* into HUCOND and TCOND for Kong-Yau
* 032 A.-M. Leduc, S. Belair and B. Bilodeau (Feb 2002) -
* Add KFC implicit condensate to IWC and LWC
* 033 S.Belair, A-M. Leduc (Nov 2002) - add averaged tendencies for kfc
* add zsqcem
* 034 A-M. Leduc (Nov 2002) - add switch for shallow convection ishlcvt(2)
* 035 B. Bilodeau (Feb 2003) - call to calcdiag and extdiag
* 036 J. Mailhot (Feb 2003) - Changes to the MOISTKE and ADVECTKE options
* 037 S. Belair (Apr 2003) - Changes to the lwc, iwc, and cloud
* fractions (better treatment of shallow
* and convective components
* 038 A. PLante (Sep 2003) - Update doc for key ipcptype (P_cond_pcptype_s)
*
* 039 B. Bilodeau and L. Spacek (Dec 2003) - Move ttmin and ttmax to calcdiag
* 040 B. Bilodeau and L. Spacek (Dec 2003) - Move ttmin and ttmax to calcdiag
* 041 B. Bilodeau (Feb 2004) - Move call to fisimp3 from surface to phyexe1
* 042 B. Bilodeau (Jun 2004) - replace fisimp3 by lin_kdif_simp1
* and move premilinary calculations
* from surface to phyexe1
* 043 J. Mailhot and B. Bilodeau (Jun 2004) - Correct tve bug
* 044 B. Bilodeau (Dec 2003) - Call to optimized gwd5 code
* 045 L. Spacek (Aug 2004) - cloud clean-up ccs,fn,ckt,cck,ccn
* change to fxp,fbl,fsc,fdc,ftot resp.
* elimination of ISTCOND=2,6,7,8 ICONVEC=4
* 3 new subroutines 1) prep_cw_rad just before newrad4 in order to
* regroup water and cloud calculation extracted
* from newrad4 and cldoptx4 and inichamp2
* 2) diagno_cw_rad after prep_cw_rad calculates
* entry diagnostics for radiation
* 3) prep_cw regroups water and cloud calculation
* at the end of phyexe1
* 046 B. Bilodeau (May 2005) - Call to climphs3
* 047 D. Talbot (July 2005) - Add call to CCC radiation from Li & Barker
* 048 M. Charron (May 2006) - add stratospheric HU tendency
* from methane oxydation
* 049 L. Spacek (June 2006) - Introduction of total tendencies
* "uphytd,vphytd,tphytd,huphytd" and
* renaming qccond,qrcond,qgcond,qicond
* to "qcphytd,qrphytd,qgphytd,qiphytd".
* Only those tendencies are passed to
* the dynamics.
* 050 L. Spacek (Nov 2006) - Rename to PHY_EXE for new dynamic/physic
* interface introduced with GEM v_3.3.0
* 051 J. Milbrandt (Dec 2006)- Added interface for Milbrandt-Yau microphysics scheme
* 052 B. Bilodeau (May 2007) - Clip specific humidity to zero
* - Remove option DMOM
* 053 L. Spacek (Dec 2007) - add "vertical staggering" option
* 054 Yanjun Jiao (March 2008) - Interface for Bechtold-Kain-Fritsch scheme
* 055 K. Winger (Sep 2008) - Apply climate increments every time step
* 056 B. Dugas (Sep 2008) - Use ININCR to control call to climphs4
* 057 A-M Leduc/P. Vaillancourt(Jan 2010)- Add tendencies UADV and VADV
* - Move calculation of total tendencies before call calcdiag.
*
*Object
* This is the main interface subroutine for the
* CMC/RPN unified physics
*
*Arguments
*
* - Input -
* E entry input field
* D dynamics input field
*
* - Input/Output -
* F historic variables for the physics
*
* - Output -
* V physics tendencies and other output fields from the physics
*
* - Input -
* ESIZ dimension of e
* DSIZ dimension of d
* FSIZ dimension of f
* VSIZ dimension of v
* DT timestep (sec.)
* TRNCH slice number
* KOUNT timestep number
* ICPU cpu number executing slice "trnch"
* N horizontal running length
* NK vertical dimension
*
*Notes
* PHYEXE is called by all the models that use the CMC/RPN
* common physics library. It returns tendencies to the
* dynamics.
*
*IMPLICITES
*
#include "phy_macros_f.h"
#include "phybus.cdk"
#include "nbvarsurf.cdk"
#include "dimsurf.cdk"
#include "workspc.cdk"
#include "options.cdk"
#include "consphy.cdk"
*
*MODULES
*
**
*
integer ikk
integer icpu
integer i,j,k,nsups
integer ierget
real cdt1, cdt2, rcdt1
real heurser
*
*
real*8 ppjour,locals,demipa
integer nik,nni,nnik
integer maxadj
parameter (maxadj=20)
integer itadj(maxadj)
*
************************************************************************
* AUTOMATIC ARRAYS
************************************************************************
*
*
AUTOMATIC ( EPLUS0 , REAL , (NI,NK ) )
AUTOMATIC ( UPLUS0 , REAL , (NI,NK ) )
AUTOMATIC ( VPLUS0 , REAL , (NI,NK ) )
AUTOMATIC ( TPLUS0 , REAL , (NI,NK ) )
AUTOMATIC ( HUPLUS0 , REAL , (NI,NK ) )
AUTOMATIC ( QCPLUS0 , REAL , (NI,NK ) )
AUTOMATIC ( GZMOINS , REAL , (NI,NK ) )
AUTOMATIC ( QCDIFV , REAL , (NI,NK ) )
AUTOMATIC ( QE , REAL , (NI,NK ) )
AUTOMATIC ( SELOC , REAL , (NI,NK ) )
AUTOMATIC ( TRAV1D , REAL , (NI ) )
AUTOMATIC ( TRAV2D , REAL , (NI,NK,4) )
AUTOMATIC ( TVIRT , REAL , (NI,NK ) )
AUTOMATIC ( FICEBL , REAL , (NI,NK ) )
AUTOMATIC ( WORK , REAL , (ESPWORK) )
AUTOMATIC ( QCBLIC , REAL , (NI,NK ) )
AUTOMATIC ( CLDFRAC , REAL , (NI,NK ) )
AUTOMATIC ( LIQWCIN , REAL , (NI,NK ) )
AUTOMATIC ( ICEWCIN , REAL , (NI,NK ) )
AUTOMATIC ( LIQWP , REAL , (NI,NK-1 ) )
AUTOMATIC ( ICEWP , REAL , (NI,NK-1 ) )
*
************************************************************************
*
*
external lin_phyexe1,serxst,vkuocon6,mprecip4
external difuvd9,serget
external gwd5,cldwin
external newrad4, oldrad3, cccmarad
external mzoniv, mzonxst
external difver6,mfotvt,adilwc,climphs4
external ficemxp,shallconv3
*
*
*----------------------------------------------------------------
*
* options de la physique
* ----------------------
*
* iconvec : convection
*
* 0 = 'nil'
* 1 = 'sec'
* 2 = 'manabe'
* 3 = 'oldkuo'
* 5 = 'fcp'
* 6 = 'kfc'
* 7 = 'kuostd'
* 8 = 'kuosym'
* 9 = 'kuosun'
* 10 = 'ras'
* 11 = 'fcpkuo'
* 12 = 'fcpkuo2'
* 13 = 'bechtold'
*
* ifluvert : couche limite
*
* -1 = 'surface'
* 0 = 'nil'
* 1 = 'physimp'
* 2 = 'clef'
* 3 = 'moistke'
*
* igwdrag : gravity wave drag
*
* 0 = 'nil'
* 1 = 'gwd86'
* 2 = 'gwd95'
*
* iradia : radiation
*
* 0 = 'nil'
* 1 = 'oldrad'
* 2 = 'newrad'
* 3 = 'cccmarad'
*
* ischmsol : svat (transferts energetiques entre le sol,
* la vegetation et l'atmosphere)
*
* 1 = 'fcrest'
* 2 = 'class'
* 3 = 'isba'
*
* ishlcvt : convection restreinte (2 valeurs)
*
* 1) 0 = 'nil'
* 1 = 'geleyn'
* 2 = 'conres'
* 3 = 'shalow'
* 4 = 'shalodqc'
* 5 = 'bmshal'
*
* 2) 0 = 'nil'
* 1 = 'ktrsnt'
* 2 = 'ktrsnt_mg'
* 3 = 'bechtold'
*
* istcond : grid-scale condensation
*
* 0 = 'nil'
* 1 = 'conds'
* 3 = 'newsund'
* 4 = 'consun'
* 5 = 'exc' !Tremblay (mixed-phase)
* 9 = 'excrig' !Kong-Yau
* 10 = 'my_sm' !Milbrandt-Yau, single-moment (optimized)
* 11 = 'my_exp1' !Milbrandt-Yau, double-moment (optimized)
* 12 = 'my_dm' !Milbrandt-Yau, double-moment (optimized)
* 13 = 'my_exp2' !Milbrandt-Yau, experimental (future version)
* 14 = 'my_full' !Milbrandt-Yau, triple-moment
*
* ilongmel : longueur de melange
*
* 0 = 'blac62'
* 1 = 'boujo'
*
* ikfcpcp : conservation de l'eau dans kfcp
*
* 0 = 'ori' ! code original
* 1 = 'conspcpn'
*
* ipcptype : Diagnostique de type de precipitations
*
* 0 = 'nil'
* 1 = 'bourge' ! Methode de Bourgouin etendue
*
*-------------------------------------------------------------
*
*
real sc
real eplus
pointer (paeplus, eplus(ni,nk))
*
integer ik
* fonction-formule pour faciliter le calcul des indices
ik(i,k) = (k-1)*ni + i -1
*
*
************************************************************************
* mise a zero des valeurs negatives d'humidite specifique *
* ------------------------------------------------------- *
************************************************************************
*
do k = 1,nk
do i = 1,ni
d(huplus +ik(i,k)) = max(0.,d(huplus +ik(i,k)))
d(humoins+ik(i,k)) = max(0.,d(humoins+ik(i,k)))
end do
end do
*
************************************************************************
* appel a la physique simplifiee si desire *
* ---------------------------------------- *
************************************************************************
if(lin_kph.eq.1) then
*
call lin_phyexe1 (e, d, f, v,
$ esiz,dsiz,fsiz,vsiz,
$ dt,trnch,kount,task,ni,nk)
*
return
endif
*
*
************************************************************************
* preparatifs *
* ----------- *
************************************************************************
*
if (.not.advectke) then
paeplus = loc(f(en))
else
paeplus = loc(d(enplus))
endif
*
icpu = task
*
*
************************************************************************
* garder une copie des champs du temps plus *
* ----------------------------------------- *
************************************************************************
*
do k = 1,nk
do i = 1,ni
uplus0(i,k) = d( uplus+ik(i,k))
vplus0(i,k) = d( vplus+ik(i,k))
tplus0(i,k) = d( tplus+ik(i,k))
huplus0(i,k) = d( huplus+ik(i,k))
qcplus0(i,k) = d( qcplus+ik(i,k))
end do
end do
if (advectke) then
do k = 1,nk
do i = 1,ni
eplus0(i,k) = d(enplus+ik(i,k))
end do
end do
endif
*
*
*
************************************************************************
* constantes derivees du pas de temps
* ----------------------------------- *
************************************************************************
*
cdt1 = factdt * dt
cdt2 = factdt * dt * facdifv
rcdt1 = 1./cdt1
*
if (climat) then
*
* sommes-nous pres du milieu du jour ?
*
ppjour = 86400 / dble( delt )
locals = kount / ppjour
locals = locals - int( locals )
demipa = 1./(2. * ppjour)
*
if (0.5-demipa .lt. locals
+ .and. locals .le. 0.5+demipa)
+ call climphs3(e,esiz,f,fsiz,kount,ni)
*
end if
*
*
*
************************************************************************
* initialisations *
* --------------- *
************************************************************************
*
* calcul des niveaux intermediaires
call sigmalev(seloc,d(sigm),d(sigt),v,vsiz,ni,nk)
*
call inichamp2 (e, esiz, f, fsiz,
$ v, vsiz, d, dsiz,
$ qcdifv,
$ kount, trnch,
$ cdt1, ni, nk)
*
* z0 directionnel
if (z0dir) then
* calcul de z0 avec z1,z2,z3,z4 et umoins,vmoins
call calcz0(f(mg),f(z0),f(z1),f(z2),f(z3),f(z4),
$ d(umoins+ik(1,nk-1)),
$ d(vmoins+ik(1,nk-1)), ni)
endif
*
************************************************************************
* extraction des tendances de la dynamique *
* ---------------------------------------- *
************************************************************************
*
call serget ( 'HEURE' , heurser , 1 , ierget )
*
call sersetm( 'KA', trnch, nk )
call mzoniv ( trnch, nk )
*
do k=1,nk
do i = 1,ni
v( tadv+ik(i,k)) = (d(tplus +ik(i,k)) -
$ d(tmoins+ik(i,k))) * rcdt1
*
v( qadv+ik(i,k)) = (d(huplus+ik(i,k)) -
$ d(humoins+ik(i,k))) * rcdt1
*
v( uadv+ik(i,k)) = (d(uplus+ik(i,k)) -
$ d(umoins+ik(i,k))) * rcdt1
*
v( vadv+ik(i,k)) = (d(vplus+ik(i,k)) -
$ d(vmoins+ik(i,k))) * rcdt1
*
if(istcond.ge.3) then
trav2d(i,k,4) = (d(qcplus+ik(i,k)) -
$ d(qcmoins+ik(i,k))) * rcdt1
endif
end do
end do
*
call serxst (v(tadv) ,'XT',trnch,ni,0., 1., -1 )
call mzonxst(v(tadv) ,'XT',trnch,ni,heurser,pmoins,-2, icpu)
call serxst (v(qadv) ,'XQ',trnch,ni,0., 1., -1 )
call mzonxst(v(qadv) ,'XQ',trnch,ni,heurser,pmoins,-2, icpu)
*
if(istcond.ge.3) then
call serxst (trav2d(1,1,4),'XL',trnch,ni,0., 1., -1 )
call mzonxst(trav2d(1,1,4),'XL',trnch,ni,heurser,pmoins,-2, icpu)
endif
*
call sersetm( 'KA', trnch, nk-1 )
call mzoniv ( trnch, -(nk-1) )
*
*
************************************************************************
* calculs radiatifs *
* ----------------- *
************************************************************************
*
*
if (iradia.ge.1) then
*
if (iradia.eq.2.or.iradia.eq.3) then
*
call prep_cw_rad2 (f, fsiz, d, dsiz, v, vsiz,
+ d(tmoins), d(humoins),d(pmoins), d(sigw),
+ cldfrac, liqwcin, icewcin, liqwp, icewp,
+ trav2d,seloc,
+ kount, trnch, task, ni, ni, nk-1)
*
call diagno_cw_rad (f, fsiz, d,dsiz, v, vsiz,
+ liqwcin, icewcin, liqwp, icewp,
+ cldfrac, heurser,
+ kount, trnch, task, ni, nk)
*
endif
*
if (iradia.eq.3) then
*
C scheme de radiation du CCC Li - Vaillancourt
*
call cccmarad (f, fsiz, v, vsiz,
+ d(tmoins), d(humoins),
+ d(pmoins), d(sigw), delt, kount, icpu,
+ trnch, ni, ni, nk-1, nk,
+ liqwcin, icewcin, liqwp, icewp, cldfrac)
*
else if (iradia.eq.2) then
*
* "nouveau" scheme de radiation
*
call newrad4 (d, dsiz, f, fsiz, v, vsiz, work, espwork,
+ liqwcin, icewcin, liqwp, icewp, cldfrac,
+ delt, kount,
+ trnch, ni, ni, nk-1, icpu, icpu,
+ nk,radnivl(1)-1, radnivl(1), radnivl(2))
*
else if (iradia.eq.1) then
*
* ancien scheme de radiation
*
call oldrad3 (f, fsiz, v, vsiz, work, espwork,
+ d(tmoins), d(humoins),
+ d(pmoins), d(sigw), delt, satuco,
+ radfix, kount, date, kntrad, trnch,
+ ni, ni, nk-1, dbgmem, icpu)
*
endif
*
*
* tendances de la radiation
do i = 1,ni*(nk-1)
v(trad+i-1) = f(ti+i-1) + f(t2+i-1)
end do
*
* tendances nulles au niveau diagnostique
do i = 1,ni
v(trad+ik(i,nk)) = 0.0
end do
*
else if (iradia.eq.0) then
*
* pas de radiation, tendances nulles
*
do i = 1,ni*nk
v(trad+i-1) = 0.0
end do
*
endif
*
*
************************************************************************
* calculs preliminaires a la diffusion verticale *
* ---------------------------------------------- *
************************************************************************
*
* calcul de la temperature virtuelle (tve),
* de l'humidite specifique (qe) et des hauteurs
* geopotentielles (ze) aux niveaux decales
*
CALL TOTHERMO(D(TMOINS), V(TVE), V(AT2T),V(AT2M),NI,NK,NK-1,.true.)
CALL TOTHERMO(D(HUMOINS),qe, V(AT2T),V(AT2M),NI,NK,NK-1,.true.)
do i=1,ni
v(tve+ik(i,nk-1)) = d( tmoins+ik(i,nk))
qe( i,nk-1) = d(humoins+ik(i,nk))
enddo
*
call mfotvt(v(tve),v(tve),qe,ni,nk-1,ni)
*
do i=1,ni
v(ze+ik(i,nk-1)) = 0.
end do
*
call integ2 ( v(ze), v(tve), -rgasd/grav, seloc,
$ trav2d(1,1,1),trav2d(1,1,2),trav2d(1,1,3),
$ ni, ni, ni, nk-1, .true. )
*
* calcul de la temperature virtuelle au temps moins
CALL TOTHERMO(TVIRT, D(TMOINS), V(AT2T),V(AT2M),NI,NK,NK,.false.)
CALL TOTHERMO(TRAV2D,D(HUMOINS),V(AT2T),V(AT2M),NI,NK,NK,.false.)
call mfotvt(tvirt,tvirt,trav2d,ni,nk-1,ni)
*
* heights au temps moins [m]
do i=1,ni
v(gzmom+ik(i,nk)) = 0.0
end do
call integ2 ( v(gzmom), tvirt, -rgasd/grav, d(sigm),
$ trav2d(1,1,1), trav2d(1,1,2), trav2d(1,1,3),
$ ni, ni, ni, nk, .true. )
*
* calcul du facteur de coriolis (fcor), de la hauteur du
* dernier niveau actif (za) et de la temperature potentielle
* a ce niveau (thetaa)
do i=1,ni
*
v(za+i-1) = -rgasd/grav* v(tve+ik(i,nk-1)) *
+ alog(d(sigm+ik(i,nk-1)))
v(ztsl+i-1) = -rgasd/grav* v(tve+ik(i,nk-1)) *
+ alog(d(sigw+ik(i,nk-1)))
v(zusl+i-1) = v(za+i-1)
sc = d(sigw+ik(i,nk-1))**(-cappa)
v(thetaa+i-1) = sc*d(tmoins+ik(i,nk-1))
v(fcor +i-1)= 1.45441e-4*sin(f(dlat+i-1))
*
end do
if(zua.gt.0..and.zta.gt.0.) then
do i=1,ni
v(ztsl+i-1) = zta
v(zusl+i-1) = zua
* In offline mode, when the surface is driven by outputs
* of the diagnostic level from a model run, sigma(nk-1)
* must not be used to calculate thetaa because that level
* is specified arbitrarily. Instead, we use the dry adiabatic
* lapse rate.
if (offline) v(thetaa+i-1) = d(tmoins+ik(i,nk-1)) + (grav/cpd)*v(ztsl+i-1)
enddo
endif
*
* calcul de la densite de l'air (pour AURAMS)
do k=1,nk
do i=1,ni
v(rhod+ik(i,k)) = d(sigw+ik(i,k))*d(pmoins+ik(i,1))/
$ (rgasd*d(tmoins+ik(i,k))*(1.0+delta*d(humoins+ik(i,k))))
end do
end do
*
*
************************************************************************
* physique simplifiee *
* ------------------- *
************************************************************************
*
if (ifluvert.eq.1) then
*
call lin_kdif_simp1( d, dsiz, f, fsiz, v, vsiz, ni, nk )
*
*
************************************************************************
* processus de surface *
* -------------------- *
************************************************************************
*
else if (ifluvert.ge.2 .or. ifluvert.eq.-1) then
*
call surface ( d, dsiz, f, fsiz, v, vsiz,
$ work, espwork, seloc, trnch,
$ kount, dt, ni, ni, nk, icpu )
*
*
************************************************************************
*
* energie cinetique turbulente, operateurs de diffusion *
* ----------------------------------------------------- *
* *
* et hauteur de la couche limite stable ou instable *
* ------------------------------------------------- *
* *
************************************************************************
*
*
if (ifluvert.ge.2) then
call turbul ( d, dsiz, f, fsiz, v, vsiz,
$ work, espwork,
$ eplus, qe, seloc,
$ kount, trnch, ni, ni, nk-1, icpu )
*
*
* calcul des tendances de TKE
* ---------------------------
*
if (advectke) then
do k = 1,nk-1
do i = 1,ni
v(enphytd+ik(i,k)) = (eplus(i,k)-eplus0(i,k))*rcdt1
end do
end do
do i = 1,ni
v(enphytd+ik(i,nk)) = 0.0
end do
*
endif
*
endif
*
endif
*
*
************************************************************************
* Oxydation du methane dans la stratosphere *
* ----------------------------------------- *
************************************************************************
*
if (lmetox) then
call metox ( v, vsiz, d(huplus), d(pplus), d(sigw), ni, ni, nk-1 )
*
*
*
* On s'assure que la tendance au niveau diagnostique est zero
* -----------------------------------------------------------
do i = 1,ni
v(qmetox+ik(i,nk)) = 0.0
end do
*
*
*
* On modifie huplus pour tenir compte de l'effet de l'oxydation du methane
* ------------------------------------------------------------------------
do k = 1,nk-1
do i = 1,ni
d(huplus+ik(i,k)) = d(huplus+ik(i,k)) + cdt1*v(qmetox+ik(i,k))
end do
end do
*
endif
*
*
************************************************************************
* gravity wave drag *
* ----------------- *
************************************************************************
*
if(igwdrag.eq.1 .or. igwdrag.eq.2 ) then
*
* calcul de la temperature virtuelle au temps moins
call mfotvt(tvirt,d(tplus),d(huplus),ni,nk,ni)
*
CALL GWD5 (D, F, V, DSIZ, FSIZ, VSIZ, TVIRT,
+ CDT1, KOUNT, TRNCH, NI, NI, NK-1,
+ ICPU )
*
* note : les tendances dues au gravity wave drag sont
* appliquees dans les sous-programmes gwdflx2 et
* gwdfx95
*
* tendances dues au gravity wave drag mises a zero
* au niveau diagnostique
do i=1,ni
v(ugwd+ik(i,nk)) = 0.
v(vgwd+ik(i,nk)) = 0.
end do
*
endif
*
* application des tendances de la radiation
* -----------------------------------------
*
if (iradia.ge.1) then
do k = 1,nk-1
do i = 1,ni
d(tplus+ik(i,k)) = d(tplus+ik(i,k)) + cdt1*v(trad+ik(i,k))
end do
end do
endif
*
*
************************************************************************
* diffusion verticale *
* ------------------- *
************************************************************************
*
if (ifluvert.eq.0.or.(ifluvert.eq.1.and..not.drag)) then
*
do i=1,ni
v( qdifv+ik(i,nk)) = 0.0
v( tdifv+ik(i,nk)) = 0.0
v( udifv+ik(i,nk)) = 0.0
v( vdifv+ik(i,nk)) = 0.0
end do
*
else
*
* calcul des tendances de la diffusion au niveau diagnostique
* (dont les series temporelles sont extraites dans difver6)
*
*VDIR NODEP
do i=1,ni
*
* tendances d'humidite specifique nulles si le modele est sec
if (wet) then
v( qdifv+ik(i,nk)) = (f(qdiag+i-1)-d(huplus+ik(i,nk)))*rcdt1
endif
*
v( tdifv+ik(i,nk)) = (f(tdiag+i-1)-d( tplus+ik(i,nk)))*rcdt1
v( udifv+ik(i,nk)) = (f(udiag+i-1)-d( uplus+ik(i,nk)))*rcdt1
v( vdifv+ik(i,nk)) = (f(vdiag+i-1)-d( vplus+ik(i,nk)))*rcdt1
end do
*
endif
*
do i=1,ni
qcdifv(i,nk) = 0.0
if (diffuw) then
v(wdifv+ik(i,nk)) = 0.0
endif
end do
*
call difver6 (d, dsiz, f, fsiz, v, vsiz,
$ work, espwork, qcdifv, seloc,
$ cdt1, kount, trnch, ni, nk-1,
$ icpu )
*
*
* application des tendances de la diffusion
* -----------------------------------------
*
if (ifluvert. ge. 1) then
do k = 1,nk-1
*VDIR NODEP
do i = 1,ni
d(huplus+ik(i,k)) = d(huplus+ik(i,k)) +
$ cdt1 * v(qdifv+ik(i,k))
d( tplus+ik(i,k)) = d( tplus+ik(i,k)) +
$ cdt1 * v(tdifv+ik(i,k))
d( uplus+ik(i,k)) = d( uplus+ik(i,k)) +
$ cdt1 * v(udifv+ik(i,k))
d( vplus+ik(i,k)) = d( vplus+ik(i,k)) +
$ cdt1 * v(vdifv+ik(i,k))
d(qcplus+ik(i,k)) = d(qcplus+ik(i,k)) +
$ cdt1 * qcdifv(i,k)
end do
end do
if (diffuw) then
do k = 1,nk-1
do i = 1,ni
d(omegap+ik(i,k))= d(omegap+ik(i,k)) +
$ cdt1 * v(wdifv+ik(i,k))
end do
end do
endif
endif
*
if (ifluvert. eq. 3) then
* BL ice fraction for later use (in cloud water section)
call ficemxp (ficebl, trav2d(1,1,1), trav2d(1,1,2),
$ d(tplus), ni, ni, nk-1)
endif
*
************************************************************************
* processus de convection/condensation *
* ------------------------------------ *
************************************************************************
*
*
*
* calcul de la temperature virtuelle au temps moins
call mfotvt(tvirt,d(tmoins),d(humoins),ni,nk,ni)
*
* calcul du geopotentiel au temps moins
do i=1,ni
gzmoins(i,nk) = 0.0
end do
call integ2 ( gzmoins, tvirt, -rgasd, d(sigw),
$ trav2d(1,1,1), trav2d(1,1,2), trav2d(1,1,3),
$ ni, ni, ni, nk, .true. )
*
*
*-----------------------------------------------------
* shallow convection calculation: ouput v(tshal) et v(hushal)
*
*
if (ishlcvt(2) == 1 .or. ishlcvt(2) == 2) then
CALL shallconv3( d, dsiz, f, fsiz, v, vsiz, kount, trnch,
1 cdt1, ni, nk )
****************************************************************************
do k = 1,nk-1
*VDIR NODEP
do i = 1,ni
d(huplus+ik(i,k)) = d(huplus+ik(i,k)) +
$ cdt1 * v(hushal+ik(i,k))
d( tplus+ik(i,k)) = d( tplus+ik(i,k)) +
$ cdt1 * v( tshal+ik(i,k))
end do
end do
endif
*
*----------------------------------------------------------
if ( iconvec.eq.1 .or. iconvec.ge.3 .or. istcond.ge.1 ) then
*
* transvidage
*VDIR NODEP
do i=1,ni*nk
v(hucond+i-1) = d(humoins+i-1)
v( tcond+i-1) = d( tmoins+i-1)
end do
*
*
call vkuocon6 (d, dsiz, f, fsiz, v, vsiz,
$ work, espwork, gzmoins, seloc,
$ dt, ni, ni, nk-1,
$ kount, trnch, icpu)
*
****************************************************************************
if (ishlcvt(2) == 3) then
*VDIR NODEP
do k = 1,nk-1
do i = 1,ni
d(huplus+ik(i,k)) = d(huplus+ik(i,k)) +
$ cdt1 * v(hushal+ik(i,k))
d( tplus+ik(i,k)) = d( tplus+ik(i,k)) +
$ cdt1 * v( tshal+ik(i,k))
end do
end do
endif
****************************************************************************
*
if ( istcond.eq.3) then
*
* transvider l'avant-dernier niveau dans le niveau diagnostique
*vdir nodep
do i=1,ni
*
v( rnflx+ik(i,nk)) = v( rnflx+ik(i,nk-1))
v(snoflx+ik(i,nk)) = v(snoflx+ik(i,nk-1))
*
end do
*
endif
*
*
else if ( iconvec .eq. 2 ) then
*
* convection selon schema de manabe
* ---------------------------------
*
*VDIR NODEP
do i=1,ni*(nk-1)
v(hucond+i-1) = d(huplus+i-1)
v( tcond+i-1) = d( tplus+i-1)
end do
*
call mprecip4 (v(tcond), v(hucond), f(tls),
+ d(omegap), d(pplus), v(kcl),
+ satuco, d(sigw),
+ cdt1, itadj, maxadj, nsups,
+ ni, nk, nk-1, ni)
*
* calcul des tendances de la convection
*VDIR NODEP
do i=1,ni*(nk-1)
v(hucond+i-1) = (v(hucond+i-1) -
+ d(huplus+i-1)) * rcdt1
v( tcond+i-1) = (v( tcond+i-1) -
+ d( tplus+i-1)) * rcdt1
end do
*
endif
*
*
* tendances de la convection/condensation nulles au niveau diagnostique
* --------------------------------------------------------
*
do i=1,ni
*
v( tcond+ik(i,nk)) = 0.0
v(hucond+ik(i,nk)) = 0.0
v(qcphytd+ik(i,nk)) = 0.0
f(fice +ik(i,nk)) = 0.0
v(tshal +ik(i,nk)) = 0.0
v(hushal+ik(i,nk)) = 0.0
*
end do
*
*
*
* application des tendances de la convection/condensation
* ------------------------------------------
*
if (iconvec.gt.0 .or. istcond.gt.0) then
*
*VDIR NODEP
do i=0,ni*(nk-1)-1
d(huplus+i) = d(huplus+i) + cdt1 * v(hucond+i)
d( tplus+i) = d( tplus+i) + cdt1 * v( tcond+i)
d(qcplus+i) = d(qcplus+i) + cdt1 * v(qcphytd+i)
end do
*
*
*
* add shallow convection tendencies to convection/condensation tendencies
* ------------------------------------------
*
do i=0,ni*(nk-1) -1
v(hucond+i) = v(hucond+i) + v(hushal+i)
v(tcond+i) = v(tcond+i) + v(tshal +i)
end do
*
endif
call prep_cw (f, fsiz, d, dsiz, v, vsiz,
+ qcplus0, ficebl,
+ kount, trnch, task, ni, nk)
*
*
*
************************************************************************
* Definir les tendances totales passees a la dynamique
* ----------------------------------------------------
************************************************************************
*
do k=1,nk-1
do i=1,ni
v(uphytd+ik(i,k)) = (d( uplus+ik(i,k)) -uplus0(i,k))*rcdt1
v(vphytd+ik(i,k)) = (d( vplus+ik(i,k)) -vplus0(i,k))*rcdt1
v(tphytd+ik(i,k)) = (d( tplus+ik(i,k)) -tplus0(i,k))*rcdt1
v(huphytd+ik(i,k))= (d( huplus+ik(i,k))-huplus0(i,k))*rcdt1
v(qcphytd+ik(i,k))= (d( qcplus+ik(i,k))-qcplus0(i,k))*rcdt1
enddo
enddo
*
do i=1,ni
*
* tendances d'humidite specifique nulles si le modele est sec
v(uphytd+ik(i,nk)) = v( udifv+ik(i,nk))
v(vphytd+ik(i,nk)) = v( vdifv+ik(i,nk))
v(tphytd+ik(i,nk)) = v( tdifv+ik(i,nk))
if (wet) then
v(huphytd+ik(i,nk)) = v( qdifv+ik(i,nk))
endif
end do
*
************************************************************************
* Calcul de moyennes et d'accumulateurs *
* ------------------------------------- *
************************************************************************
*
call calcdiag (d,f,v,dsiz,fsiz,vsiz,dt,trnch,kount,ni,nk)
*
*
************************************************************************
* extraction de diagnostics *
* ------------------------- *
************************************************************************
*
call extdiag (d,f,v,dsiz,fsiz,vsiz,trnch,icpu,ni,nk)
*
*
************************************************************************
return
end