!-------------------------------------- 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 -------------------------------------- !subroutine lesahugd(phu,pttg,phug,pesg,ppsg,ppt,kni,knj,knk) 2 #if defined (DOC) * ***S/R lesahugd - Computes analysis increment of specific humidity q * from del(T) and del(T-Td). TL of T branch of mesahuv (G. Brunet) * where ice phase is ignored. Grid-point version. * *Author: L. Fillion - ARMA/CMC - 10 dec 98 * *Revision: * C. Charette - ARMA/SMC - Sep. 2004 * - Conversion to hybrid vertical coordinate *Arguments: * - Output - * zhu : Grid-point analysis increment of specific humidity q. * * - Input - * pttg : Grid-point basic-state temperature. (K) * phug : Grid-point basic-state specific-humidity. (Kg/Kg) * pesg : Grid-point basic-state (T-Td). (K) * ppsg : Grid-point basic-state Surface-pressure (Pa). * ppt : Grid-point top pressure level of the analysis domain. * kni : X-dimension of input grid-point fields. * knj : Y-dimension of input grid-point fields. * knk : Vertical-dimension of input grid-point fields. * * ------------------- #endif IMPLICIT NONE integer kni,knj,knk real*8 phu(kni,knk,knj),pttg(kni,knk,knj),phug(kni,knk,knj) real*8 pesg(kni,knk,knj) real*8 ppsg(kni,knj),ppt(kni,knj) INTEGER IERR,ILEN EXTERNAL HPDEALLC, HPALLOC *implicits #include "pardim.cdk"
#include "comdim.cdk"
#include "comphy.cdk"
#include "comgd0.cdk"
#include "comgem.cdk"
integer ji,jj,jlev,jij real*8 zdeltd,zdeles,znum1,znum2,zdenom,ztd,zestdg,zdlnesg real*8 zpres,zrqgfac real*8 zpresa,zpresb C * #include "dinternv.cdk"
#include "finternv.cdk"
** c c do jlev = 1, knk do ji = 1, kni do jj = 1, knj if(phug(ji,jlev,jj).eq.1.0) then zrqgfac = 0. else zrqgfac = 1. endif jij=(ji-1)*knj+jj zpresb = ((vhybinc(jlev) - rptopinc/rprefinc) & /(1.0-rptopinc/rprefinc))**rcoefinc zpresa = rprefinc * (vhybinc(jlev)-zpresb) zpres = zpresa + zpresb*ppsg(ji,jj) c c zpres = ppt(ji,jj) + vlev(jlev)*(ppsg(ji,jj)-ppt(ji,jj)) c ztd = pttg(ji,jlev,jj) - pesg(ji,jlev,jj) zdlnesg = fodle(ztd) zestdg = foew(ztd) C--------------del(Td) = delT - del(T-Td) zdeltd = tt0(ji,jlev,jj) - q0(ji,jlev,jj) C------------- del(es(Td) = es(Td)*fodle(Td)*del(Td) zdeles = zestdg*zdlnesg*zdeltd znum1 = eps1*zpres znum2 = eps1*zestdg*vhybinc(jlev) zdenom = (zpres-eps2*zestdg)**2 phu(ji,jlev,jj) = zrqgfac* & (znum1*zdeles-znum2*gps0(ji,1,jj))/zdenom enddo enddo enddo c return end