phys/module_sf_sfcdiags_ruclsm.F

   1 !WRF:MODEL_LAYER:PHYSICS
   2 !
   3 MODULE module_sf_sfcdiags_ruclsm
   4
   5 CONTAINS
   6
   7    SUBROUTINE SFCDIAGS_RUCLSM(HFX,QFX,TSK,QSFC,CQS,CQS2,CHS,CHS2,T2,TH2,Q2,  &
   8                      T3D,QV3D,RHO3D,P3D,PSFC2D,SNOW,                         &
   9                      CP,R_d,ROVCP,                                           &
  10                      ids,ide, jds,jde, kds,kde,                              &
  11                      ims,ime, jms,jme, kms,kme,                              &
  12                      its,ite, jts,jte, kts,kte                     )
  13 !-------------------------------------------------------------------
  14       IMPLICIT NONE
  15 !-------------------------------------------------------------------
  16       INTEGER,  INTENT(IN )   ::        ids,ide, jds,jde, kds,kde, &
  17                                         ims,ime, jms,jme, kms,kme, &
  18                                         its,ite, jts,jte, kts,kte
  19       REAL,     DIMENSION( ims:ime, jms:jme )                    , &
  20                 INTENT(IN)                  ::                HFX, &
  21                                                               QFX, &
  22                                                              SNOW, &
  23                                                               TSK, &
  24                                                              QSFC
  25       REAL,     DIMENSION( ims:ime, jms:jme )                    , &
  26                 INTENT(INOUT)               ::                 Q2, &
  27                                                               TH2, &
  28                                                                T2
  29       REAL,     DIMENSION( ims:ime, jms:jme )                    , &
  30                 INTENT(IN)                  ::                     &
  31                                                            PSFC2D, &
  32                                                               CHS, &
  33                                                               CQS, &
  34                                                              CHS2, &
  35                                                              CQS2
  36       REAL,    DIMENSION( ims:ime, kms:kme, jms:jme )            , &
  37                INTENT(IN   )    ::                           QV3D, &
  38                                                               T3D, &
  39                                                               P3D, &
  40                                                             rho3D
  41
  42       REAL,     INTENT(IN   )               ::       CP,R_d,ROVCP
  43 ! LOCAL VARS
  44       INTEGER ::  I,J
  45       REAL    ::  RHO, x2m, qlev1, tempc, qsat, p2m, qsfcprox, qsfcmr, &
  46                   psfc, dT, dQ, fh, fac, dz1
  47
  48       LOGICAL :: FLUX
  49
  50       flux = .true.
  51       !flux = .false.
  52
  53       DO J=jts,jte
  54         DO I=its,ite
  55           RHO = RHO3D(i,1,j)
  56 !          PSFC = P3D(I,kms,J)
  57 ! Assume that 2-m pressure also equal to PSFC
  58           PSFC = PSFC2D(I,J)
  59 !          P2m = PSFC2D(I,J)*EXP(-0.068283/t3d(i,1,j))
  60
  61     if ( flux ) then
  62 !!! 2-m Temperature - T2
  63            if(CHS2(I,J).lt.1.E-5) then
  64 ! may be to small treshold?
  65 !         if(CHS2(I,J).lt.3.E-3 .AND. HFX(I,J).lt.0.) then
  66 ! when stable - let 2-m temperature be equal the first atm. level temp.
  67 !             TH2(I,J) = TSK(I,J)*(1.E5/PSFC(I,J))**ROVCP
  68              TH2(I,J) = t3d(i,1,j)*(1.E5/PSFC)**ROVCP
  69           else
  70              TH2(I,J) = TSK(I,J)*(1.E5/PSFC)**ROVCP - HFX(I,J)/(RHO*CP*CHS2(I,J))
  71 !             T2(I,J) = TSK(I,J) - HFX(I,J)/(RHO*CP*CHS2(I,J))
  72           endif
  73 !             TH2(I,J) = T2(I,J)*(1.E5/PSFC(I,J))**ROVCP
  74              T2(I,J) = TH2(I,J)*(1.E-5*PSFC)**ROVCP
  75 ! check that T2 values lie in the range between TSK and T at the 1st level
  76              x2m     = MAX(MIN(tsk(i,j),t3d(i,1,j)) , t2(i,j))
  77              t2(i,j) = MIN(MAX(tsk(i,j),t3d(i,1,j)) , x2m)
  78              TH2(I,J) = T2(I,J)*(1.E5/PSFC)**ROVCP
  79     else
  80              fac=(1.E5/PSFC)**ROVCP
  81              TH2(I,J) = tsk(i,j)*fac - CHS(I,J)/CHS2(I,J)*(tsk(i,j) - t3d(i,1,j))*fac
  82              T2(I,J) = TH2(I,J)*(1.E-5*PSFC)**ROVCP
  83     endif ! flux method
  84
  85
  86 !!! 2-m Water vapor mixing ratio - Q2
  87              qlev1 = qv3d(i,1,j)
  88 ! saturation check
  89              tempc=t3d(i,1,j)-273.15
  90            if (tempc .le. 0.0) then
  91 ! over ice
  92              qsat = rsif(p3d(i,1,j), t3d(i,1,j))
  93            else
  94              qsat = rslf(p3d(i,1,j), t3d(i,1,j))
  95            endif
  96 !remove oversaturation at level 1
  97              qlev1 = min(qsat, qlev1)
  98
  99 ! Compute QSFC proxy from QFX, qlev1 and CQS
 100 ! Use of QSFCprox is more accurate diagnostics for densely vegetated areas,
 101 ! like cropland in summer
 102              qsfcprox=qlev1+QFX(I,J)/(RHO*CQS(I,J))
 103              qsfcmr = qsfc(i,j)/(1.-qsfc(i,j))
 104
 105 !  if(i.eq.426.and.j.eq.250) then
 106 !! RAP cropland point
 107 !    print *,'qsfc,qsfcmr,qsfcprox,qlev1',qsfc(i,j),qsfcmr,qsfcprox,qlev1
 108 !    print *,'(qsfcprox-qsfcmr)/qsfcmr =', (qsfcprox-qsfcmr)/qsfcmr
 109 !  endif
 110
 111     if ( flux ) then
 112           if(CQS2(I,J).lt.1.E-5) then
 113 ! - under very stable conditions use first level for 2-m mixing ratio
 114              Q2(I,J)=qlev1
 115           else
 116 !             x2m = QSFCmr - QFX(I,J)/(RHO*CQS2(I,J))
 117              x2m = QSFCprox - QFX(I,J)/(RHO*CQS2(I,J))
 118              q2(i,j) = x2m
 119           endif
 120     else
 121 ! QFX is not used
 122             Q2(I,J) = qsfcmr - CQS(I,J)/CQS2(I,J)*(qsfcmr - qlev1)
 123     endif  ! flux
 124
 125 ! Check that Q2 values lie between QSFCmr and qlev1
 126              x2m     = MAX(MIN(qsfcmr,qlev1) , q2(i,j))
 127              q2(i,j) = MIN(MAX(qsfcmr,qlev1) , x2m)
 128
 129 ! saturation check
 130              tempc=t2(i,j)-273.15
 131            if (tempc .le. 0.0) then
 132 ! ice and supercooled water
 133              qsat = rsif(psfc, t2(i,j))
 134            else
 135 ! water
 136              qsat = rslf(psfc, t2(i,j))
 137            endif
 138
 139              q2(i,j) = min(qsat, q2(i,j))
 140 !  if(i.eq.426.and.j.eq.250) then
 141 !! cropland point
 142 !    print *,'FINAL - qsfc,qsfcmr,qsfcprox,q2(i,j),qlev1', &
 143 !                     qsfc(i,j),qsfcmr,qsfcprox,q2(i,j),qlev1
 144 !    print *,'(q2-qlev1)/qlev1 =', (q2(i,j)-qlev1)/qlev1
 145 !  endif
 146
 147         ENDDO
 148       ENDDO
 149
 150   END SUBROUTINE SFCDIAGS_RUCLSM
 151
 152 !tgs - saturation functions are from Thompson microphysics scheme
 153       REAL FUNCTION RSLF(P,T)
 154
 155       IMPLICIT NONE
 156       REAL, INTENT(IN):: P, T
 157       REAL:: ESL,X
 158       REAL, PARAMETER:: C0= .611583699E03
 159       REAL, PARAMETER:: C1= .444606896E02
 160       REAL, PARAMETER:: C2= .143177157E01
 161       REAL, PARAMETER:: C3= .264224321E-1
 162       REAL, PARAMETER:: C4= .299291081E-3
 163       REAL, PARAMETER:: C5= .203154182E-5
 164       REAL, PARAMETER:: C6= .702620698E-8
 165       REAL, PARAMETER:: C7= .379534310E-11
 166       REAL, PARAMETER:: C8=-.321582393E-13
 167
 168       X=MAX(-80.,T-273.16)
 169
 170 !      ESL=612.2*EXP(17.67*X/(T-29.65))
 171       ESL=C0+X*(C1+X*(C2+X*(C3+X*(C4+X*(C5+X*(C6+X*(C7+X*C8)))))))
 172       RSLF=.622*ESL/(P-ESL)
 173
 174       END FUNCTION RSLF
 175 !
 176 !    ALTERNATIVE
 177 !  ; Source: Murphy and Koop, Review of the vapour pressure of ice and
 178 !             supercooled water for atmospheric applications, Q. J. R.
 179 !             Meteorol. Soc (2005), 131, pp. 1539-1565.
 180 !    Psat = EXP(54.842763 - 6763.22 / T - 4.210 * ALOG(T) + 0.000367 * T
 181 !         + TANH(0.0415 * (T - 218.8)) * (53.878 - 1331.22
 182 !         / T - 9.44523 * ALOG(T) + 0.014025 * T))
 183 !
 184 !+---+-----------------------------------------------------------------+
 185 ! THIS FUNCTION CALCULATES THE ICE SATURATION VAPOR MIXING RATIO AS A
 186 ! FUNCTION OF TEMPERATURE AND PRESSURE
 187 !
 188       REAL FUNCTION RSIF(P,T)
 189
 190       IMPLICIT NONE
 191       REAL, INTENT(IN):: P, T
 192       REAL:: ESI,X
 193       REAL, PARAMETER:: C0= .609868993E03
 194       REAL, PARAMETER:: C1= .499320233E02
 195       REAL, PARAMETER:: C2= .184672631E01
 196       REAL, PARAMETER:: C3= .402737184E-1
 197       REAL, PARAMETER:: C4= .565392987E-3
 198       REAL, PARAMETER:: C5= .521693933E-5
 199       REAL, PARAMETER:: C6= .307839583E-7
 200       REAL, PARAMETER:: C7= .105785160E-9
 201       REAL, PARAMETER:: C8= .161444444E-12
 202
 203       X=MAX(-80.,T-273.16)
 204       ESI=C0+X*(C1+X*(C2+X*(C3+X*(C4+X*(C5+X*(C6+X*(C7+X*C8)))))))
 205       RSIF=.622*ESI/(P-ESI)
 206
 207       END FUNCTION RSIF
 208
 209 END MODULE module_sf_sfcdiags_ruclsm