dyn_em/module_diffusion_em.F

   1
   2 ! WRF:MODEL_LAYER:PHYSICS
   3
   4     MODULE module_diffusion_em
   5
   6     USE module_bc, only: set_physical_bc3d, set_physical_bc2d ! XZ
   7     USE module_state_description, only: p_m23, p_m13, p_m22, p_m33, p_r23, p_r13, p_r12, p_m12, p_m11, &
   8                                         P_QNS, P_QNR, P_QNG, P_QT, P_QNH, P_QVOLG ! XZ
   9     USE module_big_step_utilities_em, only: grid_config_rec_type, param_first_scalar, p_qv, p_qi, p_qc
  10     USE module_model_constants
  11
  12     CONTAINS
  13
  14 !=======================================================================
  15 !=======================================================================
  16
  17     SUBROUTINE cal_deform_and_div( config_flags, u, v, w, div,       &
  18                                    defor11, defor22, defor33,        &
  19                                    defor12, defor13, defor23,        &
  20                                    nba_rij, n_nba_rij,               &
  21                                    u_base, v_base, msfux, msfuy,     &
  22                                    msfvx, msfvy, msftx, msfty,       &
  23                                    rdx, rdy, dn, dnw, rdz, rdzw,     &
  24                                    fnm, fnp, cf1, cf2, cf3, zx, zy,  &
  25                                    ids, ide, jds, jde, kds, kde,     &
  26                                    ims, ime, jms, jme, kms, kme,     &
  27                                    its, ite, jts, jte, kts, kte      )
  28
  29 ! History:     Sep 2003  Changes by Jason Knievel and George Bryan, NCAR
  30 !              Oct 2001  Converted to mass core by Bill Skamarock, NCAR
  31 !              ...        ...
  32
  33 ! Purpose:     This routine calculates deformation and 3-d divergence.
  34
  35 ! References:  Klemp and Wilhelmson (JAS 1978)
  36 !              Chen and Dudhia (NCAR WRF physics report 2000)
  37
  38 !-----------------------------------------------------------------------
  39 ! Comments 10-MAR-05
  40 ! Equations 13a-f, Chen and Dudhia 2000, Appendix A:
  41 ! Eqn 13a: D11=defor11= 2m^2 * (partial du^/dX + partial dpsi/dx * partial du^/dpsi)
  42 ! Eqn 13b: D22=defor22= 2m^2 * (partial dv^/dY + partial dpsi/dy * partial dv^/dpsi)
  43 ! Eqn 13c: D33=defor33= 2 * partial dw/dz [SIMPLER FORM]
  44 ! Eqn 13d: D12=defor12= m^2 * (partial dv^/dX + partial du^/dY +
  45 !                              partial dpsi/dx * partial dv^/dpsi +
  46 !                              partial dpsi/dy * partial du^/dpsi)
  47 ! Eqn 13e: D13=defor13= m^2 * (partial dw^/dX + partial dpsi/dx * partial dw^/dpsi)
  48 !                           + partial du/dz [SIMPLER FORM]
  49 ! Eqn 13f: D23=defor23= m^2 * (partial dw^/dY + partial dpsi/dy * partial dw^/dpsi)
  50 !                           + partial dv/dz [SIMPLER FORM]
  51 !-----------------------------------------------------------------------
  52 ! Begin declarations.
  53
  54     IMPLICIT NONE
  55
  56     TYPE( grid_config_rec_type ), INTENT( IN )  &
  57     :: config_flags
  58
  59     INTEGER, INTENT( IN )  &
  60     :: ids, ide, jds, jde, kds, kde, &
  61        ims, ime, jms, jme, kms, kme, &
  62        its, ite, jts, jte, kts, kte
  63
  64     REAL, INTENT( IN )  &
  65     :: rdx, rdy, cf1, cf2, cf3
  66
  67     REAL, DIMENSION( kms:kme ), INTENT( IN )  &
  68     :: fnm, fnp, dn, dnw, u_base, v_base
  69
  70     REAL, DIMENSION( ims:ime , jms:jme ),  INTENT( IN )  &
  71     :: msfux, msfuy, msfvx, msfvy, msftx, msfty
  72
  73     REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT( IN )  &
  74     ::  u, v, w, zx, zy, rdz, rdzw
  75
  76     REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT( INOUT )  &
  77     :: defor11, defor22, defor33, defor12, defor13, defor23, div
  78
  79    INTEGER, INTENT(  IN ) :: n_nba_rij
  80
  81    REAL , DIMENSION(ims:ime, kms:kme, jms:jme, n_nba_rij), INTENT(INOUT) &
  82    :: nba_rij
  83
  84
  85 ! Local variables.
  86
  87     INTEGER  &
  88     :: i, j, k, ktf, ktes1, ktes2, i_start, i_end, j_start, j_end
  89
  90     REAL  &
  91     :: tmp, tmpzx, tmpzy, tmpzeta_z, cft1, cft2
  92
  93     REAL, DIMENSION( its:ite, jts:jte )  &
  94     :: mm, zzavg, zeta_zd12
  95
  96     REAL, DIMENSION( its-2:ite+2, kts:kte, jts-2:jte+2 )  &
  97     :: tmp1, hat, hatavg
  98
  99 ! End declarations.
 100 !-----------------------------------------------------------------------
 101
 102 ! Comments 10-MAR-2005
 103 ! Treat all differentials as 'div-style' [or 'curl-style'],
 104 ! i.e., du/dX becomes (in map coordinate space) mx*my * d(u/my)/dx,
 105 ! NB - all equations referred to here are from Chen and Dudhia 2002, from the
 106 ! WRF physics documents web pages:
 107 ! http://www.mmm.ucar.edu/wrf/users/docs/wrf-doc-physics.pdf
 108
 109 !=======================================================================
 110 ! In the following section, calculate 3-d divergence and the first three
 111 ! (defor11, defor22, defor33) of six deformation terms.
 112
 113     ktes1   = kte-1
 114     ktes2   = kte-2
 115
 116     cft2    = - 0.5 * dnw(ktes1) / dn(ktes1)
 117     cft1    = 1.0 - cft2
 118
 119     ktf     = MIN( kte, kde-1 )
 120
 121     i_start = its
 122     i_end   = MIN( ite, ide-1 )
 123     j_start = jts
 124     j_end   = MIN( jte, jde-1 )
 125
 126 ! Square the map scale factor.
 127
 128     DO j = j_start, j_end
 129     DO i = i_start, i_end
 130       mm(i,j) = msftx(i,j) * msfty(i,j)
 131     END DO
 132     END DO
 133
 134 !-----------------------------------------------------------------------
 135 ! Calculate du/dx.
 136
 137 ! Apply a coordinate transformation to zonal velocity, u.
 138
 139     DO j = j_start, j_end
 140     DO k = kts, ktf
 141     DO i = i_start, i_end+1
 142       hat(i,k,j) = u(i,k,j) / msfuy(i,j)
 143     END DO
 144     END DO
 145     END DO
 146
 147 ! Average in x and z.
 148
 149     DO j=j_start,j_end
 150     DO k=kts+1,ktf
 151     DO i=i_start,i_end
 152       hatavg(i,k,j) = 0.5 *  &
 153                     ( fnm(k) * ( hat(i,k  ,j) + hat(i+1,  k,j) ) +  &
 154                       fnp(k) * ( hat(i,k-1,j) + hat(i+1,k-1,j) ) )
 155     END DO
 156     END DO
 157     END DO
 158
 159 ! Extrapolate to top and bottom of domain (to w levels).
 160
 161     DO j = j_start, j_end
 162     DO i = i_start, i_end
 163       hatavg(i,1,j)   =  0.5 * (  &
 164                          cf1 * hat(i  ,1,j) +  &
 165                          cf2 * hat(i  ,2,j) +  &
 166                          cf3 * hat(i  ,3,j) +  &
 167                          cf1 * hat(i+1,1,j) +  &
 168                          cf2 * hat(i+1,2,j) +  &
 169                          cf3 * hat(i+1,3,j) )
 170       hatavg(i,kte,j) =  0.5 * (  &
 171                         cft1 * ( hat(i,ktes1,j) + hat(i+1,ktes1,j) )  +  &
 172                         cft2 * ( hat(i,ktes2,j) + hat(i+1,ktes2,j) ) )
 173     END DO
 174     END DO
 175
 176     ! Comments 10-MAR-05
 177     ! Eqn 13a: D11=defor11= 2m^2 * (partial du^/dX + partial dpsi/dx * partial du^/dpsi)
 178     ! Below, D11 is set = 2*tmp1
 179     ! => tmp1 = m^2 * (partial du^/dX + partial dpsi/dx * partial du^/dpsi)
 180     ! tmpzx = averaged value of dpsi/dx (=zx)
 181
 182     DO j = j_start, j_end
 183     DO k = kts, ktf
 184     DO i = i_start, i_end
 185       tmpzx       = 0.25 * (  &
 186                     zx(i,k  ,j) + zx(i+1,k  ,j) +  &
 187                     zx(i,k+1,j) + zx(i+1,k+1,j) )
 188       tmp1(i,k,j) = ( hatavg(i,k+1,j) - hatavg(i,k,j) ) *tmpzx * rdzw(i,k,j)
 189       ! tmp1 to here = partial dpsi/dx * partial du^/dpsi:
 190     END DO
 191     END DO
 192     END DO
 193
 194     DO j = j_start, j_end
 195     DO k = kts, ktf
 196     DO i = i_start, i_end
 197       tmp1(i,k,j) = mm(i,j) * ( rdx * ( hat(i+1,k,j) - hat(i,k,j) ) -  &
 198                     tmp1(i,k,j))
 199     END DO
 200     END DO
 201     END DO
 202
 203 ! End calculation of du/dx.
 204 !-----------------------------------------------------------------------
 205
 206 !-----------------------------------------------------------------------
 207 ! Calculate defor11 (2*du/dx).
 208 ! Comments 10-MAR-05
 209 ! Eqn 13a: D11=defor11= 2 m^2 * (partial du^/dX + partial dpsi/dx * partial du^/dpsi)
 210 !                     = 2*tmp1
 211
 212     DO j = j_start, j_end
 213     DO k = kts, ktf
 214     DO i = i_start, i_end
 215       defor11(i,k,j) = 2.0 * tmp1(i,k,j)
 216     END DO
 217     END DO
 218     END DO
 219
 220 ! End calculation of defor11.
 221 !-----------------------------------------------------------------------
 222
 223 !-----------------------------------------------------------------------
 224 ! Calculate zonal divergence (du/dx) and add it to the divergence array.
 225
 226     DO j = j_start, j_end
 227     DO k = kts, ktf
 228     DO i = i_start, i_end
 229       div(i,k,j) = tmp1(i,k,j)
 230     END DO
 231     END DO
 232     END DO
 233
 234 ! End calculation of zonal divergence.
 235 !-----------------------------------------------------------------------
 236
 237 !-----------------------------------------------------------------------
 238 ! Calculate dv/dy.
 239
 240 ! Apply a coordinate transformation to meridional velocity, v.
 241
 242     DO j = j_start, j_end+1
 243     DO k = kts, ktf
 244     DO i = i_start, i_end
 245       ! Because msfvx at the poles will be undefined (1./0.), we will have
 246       ! trouble.  But we are OK since v at the poles is 0., and that takes
 247       ! precedence in this case.
 248       IF ((config_flags%polar) .AND. ((j == jds) .OR. (j == jde))) THEN
 249          hat(i,k,j) = 0.
 250       ELSE ! normal code
 251       hat(i,k,j) = v(i,k,j) / msfvx(i,j)
 252       ENDIF
 253     END DO
 254     END DO
 255     END DO
 256
 257 ! Account for the slope in y of eta surfaces.
 258
 259     DO j=j_start,j_end
 260     DO k=kts+1,ktf
 261     DO i=i_start,i_end
 262       hatavg(i,k,j) = 0.5 * (  &
 263                       fnm(k) * ( hat(i,k  ,j) + hat(i,k  ,j+1) ) +  &
 264                       fnp(k) * ( hat(i,k-1,j) + hat(i,k-1,j+1) ) )
 265     END DO
 266     END DO
 267     END DO
 268
 269 ! Extrapolate to top and bottom of domain (to w levels).
 270
 271     DO j = j_start, j_end
 272     DO i = i_start, i_end
 273       hatavg(i,1,j)   =  0.5 * (  &
 274                          cf1 * hat(i,1,j  ) +  &
 275                          cf2 * hat(i,2,j  ) +  &
 276                          cf3 * hat(i,3,j  ) +  &
 277                          cf1 * hat(i,1,j+1) +  &
 278                          cf2 * hat(i,2,j+1) +  &
 279                          cf3 * hat(i,3,j+1) )
 280       hatavg(i,kte,j) =  0.5 * (  &
 281                         cft1 * ( hat(i,ktes1,j) + hat(i,ktes1,j+1) ) +  &
 282                         cft2 * ( hat(i,ktes2,j) + hat(i,ktes2,j+1) ) )
 283     END DO
 284     END DO
 285
 286     ! Comments 10-MAR-05
 287     ! Eqn 13b: D22=defor22= 2m^2 * (partial dv^/dY + partial dpsi/dy * partial dv^/dpsi)
 288     ! Below, D22 is set = 2*tmp1
 289     ! => tmp1 = m^2 * (partial dv^/dY + partial dpsi/dy * partial dv^/dpsi)
 290     ! tmpzy = averaged value of dpsi/dy (=zy)
 291
 292     DO j = j_start, j_end
 293     DO k = kts, ktf
 294     DO i = i_start, i_end
 295       tmpzy       =  0.25 * (  &
 296                      zy(i,k  ,j) + zy(i,k  ,j+1) +  &
 297                      zy(i,k+1,j) + zy(i,k+1,j+1)  )
 298       tmp1(i,k,j) = ( hatavg(i,k+1,j) - hatavg(i,k,j) ) * tmpzy * rdzw(i,k,j)
 299       ! tmp1 to here = partial dpsi/dy * partial dv^/dpsi:
 300     END DO
 301     END DO
 302     END DO
 303
 304     DO j = j_start, j_end
 305     DO k = kts, ktf
 306     DO i = i_start, i_end
 307       tmp1(i,k,j) = mm(i,j) * (  &
 308                     rdy * ( hat(i,k,j+1) - hat(i,k,j) ) - tmp1(i,k,j) )
 309     END DO
 310     END DO
 311     END DO
 312
 313 ! End calculation of dv/dy.
 314 !-----------------------------------------------------------------------
 315
 316 !-----------------------------------------------------------------------
 317 ! Calculate defor22 (2*dv/dy).
 318 ! Comments 10-MAR-05
 319 ! Eqn 13b: D22=defor22= 2 m^2 * (partial dv^/dY + partial dpsi/dy * partial dv^/dpsi)
 320 !                     = 2*tmp1
 321
 322     DO j = j_start, j_end
 323     DO k = kts, ktf
 324     DO i = i_start, i_end
 325       defor22(i,k,j) = 2.0 * tmp1(i,k,j)
 326     END DO
 327     END DO
 328     END DO
 329
 330 ! End calculation of defor22.
 331 !-----------------------------------------------------------------------
 332
 333 !-----------------------------------------------------------------------
 334 ! Calculate meridional divergence (dv/dy) and add it to the divergence
 335 ! array.
 336
 337     DO j = j_start, j_end
 338     DO k = kts, ktf
 339     DO i = i_start, i_end
 340       div(i,k,j) = div(i,k,j) + tmp1(i,k,j)
 341     END DO
 342     END DO
 343     END DO
 344
 345 ! End calculation of meridional divergence.
 346 !-----------------------------------------------------------------------
 347
 348 !-----------------------------------------------------------------------
 349 ! Comments 10-MAR-05
 350 ! Eqn 13c: D33=defor33= 2 * partial dw/dz
 351 ! Below, D33 is set = 2*tmp1
 352 ! => tmp1 = partial dw/dz
 353
 354 ! Calculate dw/dz.
 355
 356     DO j = j_start, j_end
 357     DO k = kts, ktf
 358     DO i = i_start, i_end
 359       tmp1(i,k,j) = ( w(i,k+1,j) - w(i,k,j) ) * rdzw(i,k,j)
 360     END DO
 361     END DO
 362     END DO
 363
 364 ! End calculation of dw/dz.
 365 !-----------------------------------------------------------------------
 366
 367 !-----------------------------------------------------------------------
 368 ! Calculate defor33 (2*dw/dz).
 369
 370     DO j = j_start, j_end
 371     DO k = kts, ktf
 372     DO i = i_start, i_end
 373       defor33(i,k,j) = 2.0 * tmp1(i,k,j)
 374     END DO
 375     END DO
 376     END DO
 377
 378 ! End calculation of defor33.
 379 !-----------------------------------------------------------------------
 380
 381 !-----------------------------------------------------------------------
 382 ! Calculate vertical divergence (dw/dz) and add it to the divergence
 383 ! array.
 384
 385     DO j = j_start, j_end
 386     DO k = kts, ktf
 387     DO i = i_start, i_end
 388       div(i,k,j) = div(i,k,j) + tmp1(i,k,j)
 389     END DO
 390     END DO
 391     END DO
 392
 393 ! End calculation of vertical divergence.
 394 !-----------------------------------------------------------------------
 395
 396 ! Three-dimensional divergence is now finished and values are in array
 397 ! "div."  Also, the first three (defor11, defor22, defor33) of six
 398 ! deformation terms are now calculated at pressure points.
 399 !=======================================================================
 400
 401 ! Comments 10-MAR-2005
 402 ! Treat all differentials as 'div-style' [or 'curl-style'],
 403 ! i.e., du/dY becomes (in map coordinate space) mx*my * d(u/mx)/dy,
 404 !       dv/dX becomes (in map coordinate space) mx*my * d(v/my)/dx,
 405 ! (see e.g. Haltiner and Williams p. 441)
 406
 407 !=======================================================================
 408 ! Calculate the final three deformations (defor12, defor13, defor23) at
 409 ! vorticity points.
 410
 411     i_start = its
 412     i_end   = ite
 413     j_start = jts
 414     j_end   = jte
 415
 416     IF ( config_flags%open_xs .OR. config_flags%specified .OR. &
 417          config_flags%nested) i_start = MAX( ids+1, its )
 418     IF ( config_flags%open_xe .OR. config_flags%specified .OR. &
 419          config_flags%nested) i_end   = MIN( ide-1, ite )
 420     IF ( config_flags%open_ys .OR. config_flags%specified .OR. &
 421          config_flags%nested) j_start = MAX( jds+1, jts )
 422     IF ( config_flags%open_ye .OR. config_flags%specified .OR. &
 423          config_flags%nested) j_end   = MIN( jde-1, jte )
 424       IF ( config_flags%periodic_x ) i_start = its
 425       IF ( config_flags%periodic_x ) i_end = ite
 426
 427
 428 !-----------------------------------------------------------------------
 429 ! Calculate du/dy.
 430
 431 ! First, calculate an average mapscale factor.
 432
 433 ! Comments 10-MAR-05
 434 ! du/dy => need u map scale factor in x (which is defined at u points)
 435 ! averaged over j and j-1
 436 ! dv/dx => need v map scale factor in y (which is defined at v points)
 437 ! averaged over i and i-1
 438
 439     DO j = j_start, j_end
 440     DO i = i_start, i_end
 441       mm(i,j) = 0.25 * ( msfux(i,j-1) + msfux(i,j) ) * ( msfvy(i-1,j) + msfvy(i,j) )
 442     END DO
 443     END DO
 444
 445 ! Apply a coordinate transformation to zonal velocity, u.
 446
 447     DO j =j_start-1, j_end
 448     DO k =kts, ktf
 449     DO i =i_start, i_end
 450       ! Fixes to set_physical_bc2/3d for polar boundary conditions
 451       ! remove issues with loop over j
 452       hat(i,k,j) = u(i,k,j) / msfux(i,j)
 453     END DO
 454     END DO
 455     END DO
 456
 457 ! Average in y and z.
 458
 459     DO j=j_start,j_end
 460     DO k=kts+1,ktf
 461     DO i=i_start,i_end
 462       hatavg(i,k,j) = 0.5 * (  &
 463                       fnm(k) * ( hat(i,k  ,j-1) + hat(i,k  ,j) ) +  &
 464                       fnp(k) * ( hat(i,k-1,j-1) + hat(i,k-1,j) ) )
 465     END DO
 466     END DO
 467     END DO
 468
 469 ! Extrapolate to top and bottom of domain (to w levels).
 470
 471     DO j = j_start, j_end
 472     DO i = i_start, i_end
 473       hatavg(i,1,j)   =  0.5 * (  &
 474                          cf1 * hat(i,1,j-1) +  &
 475                          cf2 * hat(i,2,j-1) +  &
 476                          cf3 * hat(i,3,j-1) +  &
 477                          cf1 * hat(i,1,j  ) +  &
 478                          cf2 * hat(i,2,j  ) +  &
 479                          cf3 * hat(i,3,j  ) )
 480       hatavg(i,kte,j) =  0.5 * (  &
 481                         cft1 * ( hat(i,ktes1,j-1) + hat(i,ktes1,j) ) +  &
 482                         cft2 * ( hat(i,ktes2,j-1) + hat(i,ktes2,j) ) )
 483     END DO
 484     END DO
 485
 486     ! tmpzy = averaged value of dpsi/dy (=zy) on vorticity grid
 487     ! tmp1  = partial dpsi/dy * partial du^/dpsi
 488     DO j = j_start, j_end
 489     DO k = kts, ktf
 490     DO i = i_start, i_end
 491       tmpzy       = 0.25 * (  &
 492                     zy(i-1,k  ,j) + zy(i,k  ,j) +  &
 493                     zy(i-1,k+1,j) + zy(i,k+1,j) )
 494       tmp1(i,k,j) = ( hatavg(i,k+1,j) - hatavg(i,k,j) ) *  &
 495                     0.25 * tmpzy * ( rdzw(i,k,j) + rdzw(i-1,k,j) + &
 496                                      rdzw(i-1,k,j-1) + rdzw(i,k,j-1) )
 497     END DO
 498     END DO
 499     END DO
 500
 501 ! End calculation of du/dy.
 502 !----------------------------------------------------------------------
 503
 504 !-----------------------------------------------------------------------
 505 ! Add the first term to defor12 (du/dy+dv/dx) at vorticity points.
 506
 507 ! Comments 10-MAR-05
 508 ! Eqn 13d: D12=defor12= m^2 * (partial dv^/dX + partial du^/dY +
 509 !                              partial dpsi/dx * partial dv^/dpsi +
 510 !                              partial dpsi/dy * partial du^/dpsi)
 511 ! Here deal with m^2 * (partial du^/dY + partial dpsi/dy * partial du^/dpsi)
 512 ! Still need to add v^ terms:
 513 !   m^2 * (partial dv^/dX + partial dpsi/dx * partial dv^/dpsi)
 514
 515     DO j = j_start, j_end
 516     DO k = kts, ktf
 517     DO i = i_start, i_end
 518       defor12(i,k,j) = mm(i,j) * (  &
 519                        rdy * ( hat(i,k,j) - hat(i,k,j-1) ) - tmp1(i,k,j) )
 520     END DO
 521     END DO
 522     END DO
 523
 524 ! End addition of the first term to defor12.
 525 !-----------------------------------------------------------------------
 526
 527 !-----------------------------------------------------------------------
 528 ! Calculate dv/dx.
 529
 530 ! Apply a coordinate transformation to meridional velocity, v.
 531
 532     DO j = j_start, j_end
 533     DO k = kts, ktf
 534     DO i = i_start-1, i_end
 535        hat(i,k,j) = v(i,k,j) / msfvy(i,j)
 536     END DO
 537     END DO
 538     END DO
 539
 540 ! Account for the slope in x of eta surfaces.
 541
 542     DO j = j_start, j_end
 543     DO k = kts+1, ktf
 544     DO i = i_start, i_end
 545       hatavg(i,k,j) = 0.5 * (  &
 546                       fnm(k) * ( hat(i-1,k  ,j) + hat(i,k  ,j) ) +  &
 547                       fnp(k) * ( hat(i-1,k-1,j) + hat(i,k-1,j) ) )
 548     END DO
 549     END DO
 550     END DO
 551
 552 ! Extrapolate to top and bottom of domain (to w levels).
 553
 554     DO j = j_start, j_end
 555     DO i = i_start, i_end
 556        hatavg(i,1,j)   =  0.5 * (  &
 557                           cf1 * hat(i-1,1,j) +  &
 558                           cf2 * hat(i-1,2,j) +  &
 559                           cf3 * hat(i-1,3,j) +  &
 560                           cf1 * hat(i  ,1,j) +  &
 561                           cf2 * hat(i  ,2,j) +  &
 562                           cf3 * hat(i  ,3,j) )
 563        hatavg(i,kte,j) =  0.5 * (  &
 564                          cft1 * ( hat(i,ktes1,j) + hat(i-1,ktes1,j) ) +  &
 565                          cft2 * ( hat(i,ktes2,j) + hat(i-1,ktes2,j) ) )
 566     END DO
 567     END DO
 568
 569     ! Fixes to set_physical_bc2/3d have made any check for polar B.C.'s
 570     ! unnecessary in this place.  zx, rdzw, and hatavg are all defined
 571     ! in places they need to be and the values at the poles are replications
 572     ! of the values one grid point in, so the averaging over j and j-1 works
 573     ! to act as just using the value at j or j-1 (with out extra code).
 574     !
 575     ! tmpzx = averaged value of dpsi/dx (=zx) on vorticity grid
 576     ! tmp1  = partial dpsi/dx * partial dv^/dpsi
 577     DO j = j_start, j_end
 578     DO k = kts, ktf
 579     DO i = i_start, i_end
 580       tmpzx       = 0.25 * (  &
 581                     zx(i,k  ,j-1) + zx(i,k  ,j) +  &
 582                     zx(i,k+1,j-1) + zx(i,k+1,j) )
 583       tmp1(i,k,j) = ( hatavg(i,k+1,j) - hatavg(i,k,j) ) *  &
 584                     0.25 * tmpzx * ( rdzw(i,k,j) + rdzw(i,k,j-1) + &
 585                                      rdzw(i-1,k,j-1) + rdzw(i-1,k,j) )
 586     END DO
 587     END DO
 588     END DO
 589
 590 ! End calculation of dv/dx.
 591 !-----------------------------------------------------------------------
 592
 593 !-----------------------------------------------------------------------
 594 ! Add the second term to defor12 (du/dy+dv/dx) at vorticity points.
 595
 596 ! Comments 10-MAR-05
 597 ! Eqn 13d: D12=defor12= m^2 * (partial dv^/dX + partial du^/dY +
 598 !                              partial dpsi/dx * partial dv^/dpsi +
 599 !                              partial dpsi/dy * partial du^/dpsi)
 600 ! Here adding v^ terms:
 601 !    m^2 * (partial dv^/dX + partial dpsi/dx * partial dv^/dpsi)
 602
 603   IF ( config_flags%sfs_opt .GT. 0 ) THEN ! NBA--
 604
 605 !JDM____________________________________________________________________
 606 !
 607 !     s12 =  du/dy + dv/dx
 608 !         = (du/dy - dz/dy*du/dz) + (dv/dx - dz/dx*dv/dz)
 609 !            ______defor12______             ___tmp1___
 610 !
 611 !     r12 =  du/dy - dv/dx
 612 !         = (du/dy - dz/dy*du/dz) - (dv/dx - dz/dx*dv/dz)
 613 !            ______defor12______             ___tmp1___
 614 !_______________________________________________________________________
 615
 616
 617     DO j = j_start, j_end
 618     DO k = kts, ktf
 619     DO i = i_start, i_end
 620
 621       nba_rij(i,k,j,P_r12) = defor12(i,k,j) -  &
 622                              mm(i,j) * (   &
 623                              rdx * ( hat(i,k,j) - hat(i-1,k,j) ) - tmp1(i,k,j) )
 624
 625       defor12(i,k,j) = defor12(i,k,j) +  &
 626                        mm(i,j) * (  &
 627                        rdx * ( hat(i,k,j) - hat(i-1,k,j) ) - tmp1(i,k,j) )
 628     END DO
 629     END DO
 630     END DO
 631
 632 ! End addition of the second term to defor12.
 633 !-----------------------------------------------------------------------
 634
 635 !-----------------------------------------------------------------------
 636 ! Update the boundary for defor12 (might need to change later).
 637
 638     IF ( .NOT. config_flags%periodic_x .AND. i_start .EQ. ids+1 ) THEN
 639       DO j = jts, jte
 640       DO k = kts, kte
 641         defor12(ids,k,j) = defor12(ids+1,k,j)
 642         nba_rij(ids,k,j,P_r12) = nba_rij(ids+1,k,j,P_r12)
 643       END DO
 644       END DO
 645     END IF
 646
 647     IF ( .NOT. config_flags%periodic_y .AND. j_start .EQ. jds+1) THEN
 648       DO k = kts, kte
 649       DO i = its, ite
 650         defor12(i,k,jds) = defor12(i,k,jds+1)
 651         nba_rij(i,k,jds,P_r12) = nba_rij(i,k,jds+1,P_r12)
 652       END DO
 653       END DO
 654     END IF
 655
 656     IF ( .NOT. config_flags%periodic_x .AND. i_end .EQ. ide-1) THEN
 657       DO j = jts, jte
 658       DO k = kts, kte
 659         defor12(ide,k,j) = defor12(ide-1,k,j)
 660         nba_rij(ide,k,j,P_r12) = nba_rij(ide-1,k,j,P_r12)
 661       END DO
 662       END DO
 663     END IF
 664
 665     IF ( .NOT. config_flags%periodic_y .AND. j_end .EQ. jde-1) THEN
 666       DO k = kts, kte
 667       DO i = its, ite
 668         defor12(i,k,jde) = defor12(i,k,jde-1)
 669         nba_rij(i,k,jde,P_r12) = nba_rij(i,k,jde-1,P_r12)
 670       END DO
 671       END DO
 672     END IF
 673
 674   ELSE ! NOT NBA--------------------------------------------------------
 675
 676     DO j = j_start, j_end
 677     DO k = kts, ktf
 678     DO i = i_start, i_end
 679       defor12(i,k,j) = defor12(i,k,j) +  &
 680                        mm(i,j) * (  &
 681                        rdx * ( hat(i,k,j) - hat(i-1,k,j) ) - tmp1(i,k,j) )
 682     END DO
 683     END DO
 684     END DO
 685
 686 ! End addition of the second term to defor12.
 687 !-----------------------------------------------------------------------
 688
 689 !-----------------------------------------------------------------------
 690 ! Update the boundary for defor12 (might need to change later).
 691
 692     IF ( .NOT. config_flags%periodic_x .AND. i_start .EQ. ids+1 ) THEN
 693       DO j = jts, jte
 694       DO k = kts, kte
 695         defor12(ids,k,j) = defor12(ids+1,k,j)
 696       END DO
 697       END DO
 698     END IF
 699
 700     IF ( .NOT. config_flags%periodic_y .AND. j_start .EQ. jds+1) THEN
 701       DO k = kts, kte
 702       DO i = its, ite
 703         defor12(i,k,jds) = defor12(i,k,jds+1)
 704       END DO
 705       END DO
 706     END IF
 707
 708     IF ( .NOT. config_flags%periodic_x .AND. i_end .EQ. ide-1) THEN
 709       DO j = jts, jte
 710       DO k = kts, kte
 711         defor12(ide,k,j) = defor12(ide-1,k,j)
 712       END DO
 713       END DO
 714     END IF
 715
 716     IF ( .NOT. config_flags%periodic_y .AND. j_end .EQ. jde-1) THEN
 717       DO k = kts, kte
 718       DO i = its, ite
 719         defor12(i,k,jde) = defor12(i,k,jde-1)
 720       END DO
 721       END DO
 722     END IF
 723
 724   ENDIF ! NBA-----------------------------------------------------------
 725
 726 ! End update of boundary for defor12.
 727 !-----------------------------------------------------------------------
 728
 729 ! Comments 10-MAR-05
 730 ! Further deformation terms not needed for 2-dimensional Smagorinsky diffusion,
 731 ! so those terms have not been dealt with yet.
 732 ! A "y" has simply been added to all map scale factors to allow the model to
 733 ! compile without errors.
 734
 735 !-----------------------------------------------------------------------
 736 ! Calculate dw/dx.
 737
 738     i_start = its
 739     i_end   = MIN( ite, ide-1 )
 740     j_start = jts
 741     j_end   = MIN( jte, jde-1 )
 742
 743     IF ( config_flags%open_xs .OR. config_flags%specified .OR. &
 744          config_flags%nested) i_start = MAX( ids+1, its )
 745     IF ( config_flags%open_ys .OR. config_flags%specified .OR. &
 746          config_flags%nested) j_start = MAX( jds+1, jts )
 747
 748     IF ( config_flags%periodic_x ) i_start = its
 749     IF ( config_flags%periodic_x ) i_end = MIN( ite, ide )
 750     IF ( config_flags%periodic_y ) j_end = MIN( jte, jde )
 751
 752 ! Square the mapscale factor.
 753
 754     DO j = jts, jte
 755     DO i = its, ite
 756       mm(i,j) = msfux(i,j) * msfuy(i,j)
 757     END DO
 758     END DO
 759
 760 ! Apply a coordinate transformation to vertical velocity, w.  This is for both
 761 ! defor13 and defor23.
 762
 763     DO j = j_start, j_end
 764     DO k = kts, kte
 765     DO i = i_start, i_end
 766       hat(i,k,j) = w(i,k,j) / msfty(i,j)
 767     END DO
 768     END DO
 769     END DO
 770
 771     i = i_start-1
 772     DO j = j_start, MIN( jte, jde-1 )
 773     DO k = kts, kte
 774       hat(i,k,j) = w(i,k,j) / msfty(i,j)
 775     END DO
 776     END DO
 777
 778     j = j_start-1
 779     DO k = kts, kte
 780     DO i = i_start, MIN( ite, ide-1 )
 781       hat(i,k,j) = w(i,k,j) / msfty(i,j)
 782     END DO
 783     END DO
 784
 785 ! QUESTION: What is this for?
 786
 787     DO j = j_start, j_end
 788     DO k = kts, ktf
 789     DO i = i_start, i_end
 790       hatavg(i,k,j) = 0.25 * (  &
 791                       hat(i  ,k  ,j) +  &
 792                       hat(i  ,k+1,j) +  &
 793                       hat(i-1,k  ,j) +  &
 794                       hat(i-1,k+1,j) )
 795     END DO
 796     END DO
 797     END DO
 798
 799 ! Calculate dw/dx.
 800
 801     DO j = j_start, j_end
 802     DO k = kts+1, ktf
 803     DO i = i_start, i_end
 804       tmp1(i,k,j) = ( hatavg(i,k,j) - hatavg(i,k-1,j) ) * zx(i,k,j) *  &
 805                     0.5 * ( rdz(i,k,j) + rdz(i-1,k,j) )
 806     END DO
 807     END DO
 808     END DO
 809
 810 ! End calculation of dw/dx.
 811 !-----------------------------------------------------------------------
 812
 813 !-----------------------------------------------------------------------
 814 ! Add the first term (dw/dx) to defor13 (dw/dx+du/dz) at vorticity
 815 ! points.
 816
 817     DO j = j_start, j_end
 818     DO k = kts+1, ktf
 819     DO i = i_start, i_end
 820       defor13(i,k,j) = mm(i,j) * (  &
 821                        rdx * ( hat(i,k,j) - hat(i-1,k,j) ) - tmp1(i,k,j) )
 822     END DO
 823     END DO
 824     END DO
 825
 826     DO j = j_start, j_end
 827     DO i = i_start, i_end
 828       defor13(i,kts,j  ) = 0.0
 829       defor13(i,ktf+1,j) = 0.0
 830     END DO
 831     END DO
 832
 833 ! End addition of the first term to defor13.
 834 !-----------------------------------------------------------------------
 835
 836 !-----------------------------------------------------------------------
 837 ! Calculate du/dz.
 838
 839     IF ( config_flags%mix_full_fields ) THEN
 840
 841       DO j = j_start, j_end
 842       DO k = kts+1, ktf
 843       DO i = i_start, i_end
 844         tmp1(i,k,j) = ( u(i,k,j) - u(i,k-1,j) ) *  &
 845                       0.5 * ( rdz(i,k,j) + rdz(i-1,k,j) )
 846       END DO
 847       END DO
 848       END DO
 849
 850     ELSE
 851
 852       DO j = j_start, j_end
 853       DO k = kts+1, ktf
 854       DO i = i_start, i_end
 855         tmp1(i,k,j) = ( u(i,k,j) - u_base(k) - u(i,k-1,j) + u_base(k-1) ) *  &
 856                       0.5 * ( rdz(i,k,j) + rdz(i-1,k,j) )
 857       END DO
 858       END DO
 859       END DO
 860
 861     END IF
 862
 863 !-----------------------------------------------------------------------
 864 ! Add the second term (du/dz) to defor13 (dw/dx+du/dz) at vorticity
 865 ! points.
 866
 867
 868   IF ( config_flags%sfs_opt .GT. 0 ) THEN ! NBA--
 869
 870 !JDM____________________________________________________________________
 871 !
 872 !     s13 = du/dz +  dw/dx
 873 !         = du/dz + (dw/dx - dz/dx*dw/dz)
 874 !         = tmp1  +  ______defor13______
 875 !
 876 !     r13 = du/dz -  dw/dx
 877 !         = du/dz - (dw/dx - dz/dx*dw/dz)
 878 !         = tmp1  -  ______defor13______
 879 !_______________________________________________________________________
 880
 881     DO j = j_start, j_end
 882     DO k = kts+1, ktf
 883     DO i = i_start, i_end
 884       nba_rij(i,k,j,P_r13) =  tmp1(i,k,j) - defor13(i,k,j)
 885       defor13(i,k,j) = defor13(i,k,j) + tmp1(i,k,j)
 886     END DO
 887     END DO
 888     END DO
 889
 890     DO j = j_start, j_end !change for different surface B. C.
 891     DO i = i_start, i_end
 892       nba_rij(i,kts  ,j,P_r13) = 0.0
 893       nba_rij(i,ktf+1,j,P_r13) = 0.0
 894     END DO
 895     END DO
 896
 897   ELSE ! NOT NBA--------------------------------------------------------
 898
 899     DO j = j_start, j_end
 900     DO k = kts+1, ktf
 901     DO i = i_start, i_end
 902       defor13(i,k,j) = defor13(i,k,j) + tmp1(i,k,j)
 903     END DO
 904     END DO
 905     END DO
 906
 907   ENDIF ! NBA-----------------------------------------------------------
 908
 909 ! End addition of the second term to defor13.
 910 !-----------------------------------------------------------------------
 911
 912 !-----------------------------------------------------------------------
 913 ! Calculate dw/dy.
 914
 915     i_start = its
 916     i_end   = MIN( ite, ide-1 )
 917     j_start = jts
 918     j_end   = MIN( jte, jde-1 )
 919
 920     IF ( config_flags%open_xs .OR. config_flags%specified .OR. &
 921          config_flags%nested) i_start = MAX( ids+1, its )
 922     IF ( config_flags%open_ys .OR. config_flags%specified .OR. &
 923          config_flags%nested) j_start = MAX( jds+1, jts )
 924     IF ( config_flags%periodic_y ) j_end = MIN( jte, jde )
 925       IF ( config_flags%periodic_x ) i_start = its
 926       IF ( config_flags%periodic_x ) i_end = MIN( ite, ide-1 )
 927
 928 ! Square mapscale factor.
 929
 930     DO j = jts, jte
 931     DO i = its, ite
 932       mm(i,j) = msfvx(i,j) * msfvy(i,j)
 933     END DO
 934     END DO
 935
 936 ! Apply a coordinate transformation to vertical velocity, w.  Added by CW 7/19/07
 937
 938     DO j = j_start, j_end
 939     DO k = kts, kte
 940     DO i = i_start, i_end
 941       hat(i,k,j) = w(i,k,j) / msftx(i,j)
 942     END DO
 943     END DO
 944     END DO
 945
 946     i = i_start-1
 947     DO j = j_start, MIN( jte, jde-1 )
 948     DO k = kts, kte
 949       hat(i,k,j) = w(i,k,j) / msftx(i,j)
 950     END DO
 951     END DO
 952
 953     j = j_start-1
 954     DO k = kts, kte
 955     DO i = i_start, MIN( ite, ide-1 )
 956       hat(i,k,j) = w(i,k,j) / msftx(i,j)
 957     END DO
 958     END DO
 959
 960 ! QUESTION: What is this for?
 961
 962     DO j = j_start, j_end
 963     DO k = kts, ktf
 964     DO i = i_start, i_end
 965       hatavg(i,k,j) = 0.25 * (  &
 966                       hat(i,k  ,j  ) +  &
 967                       hat(i,k+1,j  ) +  &
 968                       hat(i,k  ,j-1) +  &
 969                       hat(i,k+1,j-1) )
 970     END DO
 971     END DO
 972     END DO
 973
 974 ! Calculate dw/dy and store in tmp1.
 975
 976     DO j = j_start, j_end
 977     DO k = kts+1, ktf
 978     DO i = i_start, i_end
 979       tmp1(i,k,j) = ( hatavg(i,k,j) - hatavg(i,k-1,j) ) * zy(i,k,j) *  &
 980                     0.5 * ( rdz(i,k,j) + rdz(i,k,j-1) )
 981     END DO
 982     END DO
 983     END DO
 984
 985 ! End calculation of dw/dy.
 986 !-----------------------------------------------------------------------
 987
 988 !-----------------------------------------------------------------------
 989 ! Add the first term (dw/dy) to defor23 (dw/dy+dv/dz) at vorticity
 990 ! points.
 991
 992     DO j = j_start, j_end
 993     DO k = kts+1, ktf
 994     DO i = i_start, i_end
 995       defor23(i,k,j) = mm(i,j) * (  &
 996                        rdy * ( hat(i,k,j) - hat(i,k,j-1) ) - tmp1(i,k,j) )
 997     END DO
 998     END DO
 999     END DO
1000
1001     DO j = j_start, j_end
1002     DO i = i_start, i_end
1003       defor23(i,kts,j  ) = 0.0
1004       defor23(i,ktf+1,j) = 0.0
1005     END DO
1006     END DO
1007
1008 ! End addition of the first term to defor23.
1009 !-----------------------------------------------------------------------
1010
1011 !-----------------------------------------------------------------------
1012 ! Calculate dv/dz.
1013
1014     IF ( config_flags%mix_full_fields ) THEN
1015
1016       DO j = j_start, j_end
1017       DO k = kts+1, ktf
1018       DO i = i_start, i_end
1019         tmp1(i,k,j) = ( v(i,k,j) - v(i,k-1,j) ) *  &
1020                       0.5 * ( rdz(i,k,j) + rdz(i,k,j-1) )
1021       END DO
1022       END DO
1023       END DO
1024
1025     ELSE
1026
1027       DO j = j_start, j_end
1028       DO k = kts+1, ktf
1029       DO i = i_start, i_end
1030         tmp1(i,k,j) = ( v(i,k,j) - v_base(k) - v(i,k-1,j) + v_base(k-1) ) *  &
1031                       0.5 * ( rdz(i,k,j) + rdz(i,k,j-1) )
1032       END DO
1033       END DO
1034       END DO
1035
1036     END IF
1037
1038 ! End calculation of dv/dz.
1039 !-----------------------------------------------------------------------
1040
1041 !-----------------------------------------------------------------------
1042 ! Add the second term (dv/dz) to defor23 (dw/dy+dv/dz) at vorticity
1043 ! points.
1044
1045   IF ( config_flags%sfs_opt .GT. 0 ) THEN ! NBA--
1046
1047 !JDM___________________________________________________________________
1048 !
1049 !     s23 = dv/dz +  dw/dy
1050 !         = dv/dz + (dw/dy - dz/dy*dw/dz)
1051 !           tmp1  +  ______defor23______
1052 !
1053 !     r23 = dv/dz -  dw/dy
1054 !         = dv/dz - (dw/dy - dz/dy*dw/dz)
1055 !         = tmp1  -  ______defor23______
1056
1057 ! Add tmp1 to defor23.
1058
1059     DO j = j_start, j_end
1060     DO k = kts+1, ktf
1061     DO i = i_start, i_end
1062       nba_rij(i,k,j,P_r23) = tmp1(i,k,j) - defor23(i,k,j)
1063       defor23(i,k,j) = defor23(i,k,j) + tmp1(i,k,j)
1064     END DO
1065     END DO
1066     END DO
1067
1068     DO j = j_start, j_end
1069       DO i = i_start, i_end
1070         nba_rij(i,kts  ,j,P_r23) = 0.0
1071         nba_rij(i,ktf+1,j,P_r23) = 0.0
1072       END DO
1073     END DO
1074
1075 ! End addition of the second term to defor23.
1076 !-----------------------------------------------------------------------
1077
1078 !-----------------------------------------------------------------------
1079 ! Update the boundary for defor13 and defor23 (might need to change
1080 ! later).
1081
1082     IF ( .NOT. config_flags%periodic_x .AND. i_start .EQ. ids+1) THEN
1083       DO j = jts, jte
1084       DO k = kts, kte
1085         defor13(ids,k,j) = defor13(ids+1,k,j)
1086         defor23(ids,k,j) = defor23(ids+1,k,j)
1087         nba_rij(ids,k,j,P_r13) = nba_rij(ids+1,k,j,P_r13)
1088         nba_rij(ids,k,j,P_r23) = nba_rij(ids+1,k,j,P_r23)
1089       END DO
1090       END DO
1091     END IF
1092
1093     IF ( .NOT. config_flags%periodic_y .AND. j_start .EQ. jds+1) THEN
1094       DO k = kts, kte
1095       DO i = its, ite
1096         defor13(i,k,jds) = defor13(i,k,jds+1)
1097         defor23(i,k,jds) = defor23(i,k,jds+1)
1098         nba_rij(i,k,jds,P_r13) = nba_rij(i,k,jds+1,P_r13)
1099         nba_rij(i,k,jds,P_r23) = nba_rij(i,k,jds+1,P_r23)
1100       END DO
1101       END DO
1102     END IF
1103
1104     IF ( .NOT. config_flags%periodic_x .AND. i_end .EQ. ide-1) THEN
1105       DO j = jts, jte
1106       DO k = kts, kte
1107         defor13(ide,k,j) = defor13(ide-1,k,j)
1108         defor23(ide,k,j) = defor23(ide-1,k,j)
1109         nba_rij(ide,k,j,P_r13) = nba_rij(ide-1,k,j,P_r13)
1110         nba_rij(ide,k,j,P_r23) = nba_rij(ide-1,k,j,P_r23)
1111       END DO
1112       END DO
1113     END IF
1114
1115     IF ( .NOT. config_flags%periodic_y .AND. j_end .EQ. jde-1) THEN
1116       DO k = kts, kte
1117       DO i = its, ite
1118         defor13(i,k,jde) = defor13(i,k,jde-1)
1119         defor23(i,k,jde) = defor23(i,k,jde-1)
1120         nba_rij(i,k,jde,P_r13) = nba_rij(i,k,jde-1,P_r13)
1121         nba_rij(i,k,jde,P_r23) = nba_rij(i,k,jde-1,P_r23)
1122       END DO
1123       END DO
1124     END IF
1125
1126   ELSE ! NOT NBA--------------------------------------------------------
1127
1128 ! Add tmp1 to defor23.
1129
1130     DO j = j_start, j_end
1131     DO k = kts+1, ktf
1132     DO i = i_start, i_end
1133       defor23(i,k,j) = defor23(i,k,j) + tmp1(i,k,j)
1134     END DO
1135     END DO
1136     END DO
1137
1138 ! End addition of the second term to defor23.
1139 !-----------------------------------------------------------------------
1140
1141 !-----------------------------------------------------------------------
1142 ! Update the boundary for defor13 and defor23 (might need to change
1143 ! later).
1144
1145     IF ( .NOT. config_flags%periodic_x .AND. i_start .EQ. ids+1) THEN
1146       DO j = jts, jte
1147       DO k = kts, kte
1148         defor13(ids,k,j) = defor13(ids+1,k,j)
1149         defor23(ids,k,j) = defor23(ids+1,k,j)
1150       END DO
1151       END DO
1152     END IF
1153
1154     IF ( .NOT. config_flags%periodic_y .AND. j_start .EQ. jds+1) THEN
1155       DO k = kts, kte
1156       DO i = its, ite
1157         defor13(i,k,jds) = defor13(i,k,jds+1)
1158         defor23(i,k,jds) = defor23(i,k,jds+1)
1159       END DO
1160       END DO
1161     END IF
1162
1163     IF ( .NOT. config_flags%periodic_x .AND. i_end .EQ. ide-1) THEN
1164       DO j = jts, jte
1165       DO k = kts, kte
1166         defor13(ide,k,j) = defor13(ide-1,k,j)
1167         defor23(ide,k,j) = defor23(ide-1,k,j)
1168       END DO
1169       END DO
1170     END IF
1171
1172     IF ( .NOT. config_flags%periodic_y .AND. j_end .EQ. jde-1) THEN
1173       DO k = kts, kte
1174       DO i = its, ite
1175         defor13(i,k,jde) = defor13(i,k,jde-1)
1176         defor23(i,k,jde) = defor23(i,k,jde-1)
1177       END DO
1178       END DO
1179     END IF
1180
1181   ENDIF ! NBA-----------------------------------------------------------
1182
1183 ! End update of boundary for defor13 and defor23.
1184 !-----------------------------------------------------------------------
1185
1186 ! The second three (defor12, defor13, defor23) of six deformation terms
1187 ! are now calculated at vorticity points.
1188 !=======================================================================
1189
1190     END SUBROUTINE cal_deform_and_div
1191
1192 !=======================================================================
1193 !=======================================================================
1194
1195     SUBROUTINE calculate_km_kh( config_flags, dt,                        &
1196                                 dampcoef, zdamp, damp_opt,               &
1197                                 xkmh, xkmv, xkhh, xkhv,                  &
1198                                 BN2, khdif, kvdif, div,                  &
1199                                 defor11, defor22, defor33,               &
1200                                 defor12, defor13, defor23,               &
1201                                 tke, p8w, t8w, theta, t, p, moist,       &
1202                                 dn, dnw, dx, dy, rdz, rdzw, isotropic,   &
1203                                 n_moist, cf1, cf2, cf3, warm_rain,       &
1204                                 mix_upper_bound,                         &
1205                                 msftx, msfty,                            &
1206                                 zx, zy,                                  &
1207                                 hpbl,dlk,xkmv_meso,                      & !XZ
1208                                 ids, ide, jds, jde, kds, kde,            &
1209                                 ims, ime, jms, jme, kms, kme,            &
1210                                 its, ite, jts, jte, kts, kte             )
1211
1212 ! History:     Sep 2003  Changes by George Bryan and Jason Knievel, NCAR
1213 !              Oct 2001  Converted to mass core by Bill Skamarock, NCAR
1214 !              ...       ...
1215
1216 ! Purpose:     This routine calculates exchange coefficients for the TKE
1217 !              scheme.
1218
1219 ! References:  Klemp and Wilhelmson (JAS 1978)
1220 !              Deardorff (B-L Meteor 1980)
1221 !              Chen and Dudhia (NCAR WRF physics report 2000)
1222
1223 !-----------------------------------------------------------------------
1224 ! Begin declarations.
1225
1226     IMPLICIT NONE
1227
1228     TYPE( grid_config_rec_type ), INTENT( IN )  &
1229     :: config_flags
1230
1231     INTEGER, INTENT( IN )  &
1232     :: n_moist, damp_opt, isotropic,  &
1233        ids, ide, jds, jde, kds, kde,  &
1234        ims, ime, jms, jme, kms, kme,  &
1235        its, ite, jts, jte, kts, kte
1236
1237     LOGICAL, INTENT( IN )  &
1238     :: warm_rain
1239
1240     REAL, INTENT( IN )  &
1241     :: dx, dy, zdamp, dt, dampcoef, cf1, cf2, cf3, khdif, kvdif
1242
1243     REAL, DIMENSION( kms:kme ), INTENT( IN )  &
1244     :: dnw, dn
1245
1246     REAL, DIMENSION( ims:ime, kms:kme, jms:jme, n_moist ), INTENT( INOUT )  &
1247     :: moist
1248
1249     REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT( INOUT )  &
1250     :: xkmv, xkmh, xkhv, xkhh, BN2
1251
1252     REAL, DIMENSION( ims:ime , kms:kme, jms:jme ),  INTENT( IN )  &
1253     :: defor11, defor22, defor33, defor12, defor13, defor23,      &
1254        div, rdz, rdzw, p8w, t8w, theta, t, p, zx, zy
1255
1256     REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT( INOUT )  &
1257     :: tke
1258
1259     REAL, INTENT( IN )  &
1260     :: mix_upper_bound
1261
1262     REAL, DIMENSION( ims:ime, jms:jme ), INTENT( IN )  &
1263     :: msftx, msfty
1264 !XZ
1265     REAL, DIMENSION( ims:ime, jms:jme ), INTENT( INOUT )          &
1266     :: hpbl
1267
1268     REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT( IN )    &
1269     :: dlk
1270
1271     REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT( INOUT ) &
1272     :: xkmv_meso
1273 !
1274
1275 ! Local variables.
1276
1277     INTEGER  &
1278     :: i_start, i_end, j_start, j_end, ktf, i, j, k
1279
1280 ! End declarations.
1281 !-----------------------------------------------------------------------
1282
1283     ktf     = MIN( kte, kde-1 )
1284     i_start = its
1285     i_end   = MIN( ite, ide-1 )
1286     j_start = jts
1287     j_end   = MIN( jte, jde-1 )
1288
1289     CALL calculate_N2( config_flags, BN2, moist,           &
1290                        theta, t, p, p8w, t8w,              &
1291                        dnw, dn, rdz, rdzw,                 &
1292                        n_moist, cf1, cf2, cf3, warm_rain,  &
1293                        ids, ide, jds, jde, kds, kde,       &
1294                        ims, ime, jms, jme, kms, kme,       &
1295                        its, ite, jts, jte, kts, kte        )
1296
1297 ! Select a scheme for calculating diffusion coefficients.
1298
1299     km_coef: SELECT CASE( config_flags%km_opt )
1300
1301       CASE (1)
1302             CALL isotropic_km( config_flags, xkmh, xkmv,                &
1303                                xkhh, xkhv, khdif, kvdif,                &
1304                                ids, ide, jds, jde, kds, kde,            &
1305                                ims, ime, jms, jme, kms, kme,            &
1306                                its, ite, jts, jte, kts, kte             )
1307       CASE (2, 5) !XZ
1308             CALL tke_km(       config_flags, xkmh, xkmv,                &
1309                                xkhh, xkhv, BN2, tke, p8w, t8w, theta,   &
1310                                rdz, rdzw, dx, dy, dt, isotropic,        &
1311                                mix_upper_bound, msftx, msfty,           &
1312                                hpbl,dlk,xkmv_meso,                      & ! XZ
1313                                defor11,defor22,defor12,zx,zy,           & ! XZ
1314                                ids, ide, jds, jde, kds, kde,            &
1315                                ims, ime, jms, jme, kms, kme,            &
1316                                its, ite, jts, jte, kts, kte             )
1317       CASE (3)
1318             CALL smag_km(      config_flags, xkmh, xkmv,                &
1319                                xkhh, xkhv, BN2, div,                    &
1320                                defor11, defor22, defor33,               &
1321                                defor12, defor13, defor23,               &
1322                                rdzw, dx, dy, dt, isotropic,             &
1323                                mix_upper_bound, msftx, msfty,           &
1324                                ids, ide, jds, jde, kds, kde,            &
1325                                ims, ime, jms, jme, kms, kme,            &
1326                                its, ite, jts, jte, kts, kte             )
1327       CASE (4)
1328             CALL smag2d_km(    config_flags, xkmh, xkmv,                &
1329                                xkhh, xkhv, defor11, defor22, defor12,   &
1330                                rdzw, dx, dy, msftx, msfty,              &
1331                                zx, zy,                                  &
1332                                ids, ide, jds, jde, kds, kde,            &
1333                                ims, ime, jms, jme, kms, kme,            &
1334                                its, ite, jts, jte, kts, kte             )
1335       CASE DEFAULT
1336             CALL wrf_error_fatal( 'Please choose diffusion coefficient scheme' )
1337
1338     END SELECT km_coef
1339
1340     IF ( damp_opt .eq. 1 ) THEN
1341       CALL cal_dampkm( config_flags, xkmh, xkhh, xkmv, xkhv,    &
1342                        dx, dy, dt, dampcoef, rdz, rdzw, zdamp,  &
1343                        msftx, msfty,                            &
1344                        ids, ide, jds, jde, kds, kde,            &
1345                        ims, ime, jms, jme, kms, kme,            &
1346                        its, ite, jts, jte, kts, kte             )
1347     END IF
1348
1349     END SUBROUTINE calculate_km_kh
1350
1351 !=======================================================================
1352
1353 SUBROUTINE cal_dampkm( config_flags,xkmh,xkhh,xkmv,xkhv,                       &
1354                        dx,dy,dt,dampcoef,                                      &
1355                        rdz, rdzw ,zdamp,                                       &
1356                        msftx, msfty,                                           &
1357                        ids,ide, jds,jde, kds,kde,                              &
1358                        ims,ime, jms,jme, kms,kme,                              &
1359                        its,ite, jts,jte, kts,kte                              )
1360
1361 !-----------------------------------------------------------------------
1362 ! Begin declarations.
1363
1364    IMPLICIT NONE
1365
1366    TYPE(grid_config_rec_type) , INTENT(IN   ) :: config_flags
1367
1368    INTEGER ,          INTENT(IN   )           :: ids, ide, jds, jde, kds, kde, &
1369                                                  ims, ime, jms, jme, kms, kme, &
1370                                                  its, ite, jts, jte, kts, kte
1371
1372    REAL    ,          INTENT(IN   )           :: zdamp,dx,dy,dt,dampcoef
1373
1374
1375    REAL , DIMENSION( ims:ime, kms:kme, jms:jme), INTENT(INOUT)    ::     xkmh , &
1376                                                                          xkhh , &
1377                                                                          xkmv , &
1378                                                                          xkhv
1379
1380    REAL , DIMENSION( ims:ime, kms:kme, jms:jme), INTENT(IN   )    ::     rdz,   &
1381                                                                          rdzw
1382
1383    REAL , DIMENSION( ims:ime, jms:jme), INTENT(IN   )             ::     msftx, &
1384                                                                          msfty
1385 ! LOCAL VARS
1386
1387    INTEGER :: i_start, i_end, j_start, j_end, ktf, ktfm1, i, j, k
1388    REAL    :: kmmax,kmmvmax,degrad90,dz,tmp
1389    REAL    :: ds
1390    REAL ,     DIMENSION( its:ite )                                ::   deltaz
1391    REAL , DIMENSION( its:ite, kts:kte, jts:jte)                   ::   dampk,dampkv
1392
1393 ! End declarations.
1394 !-----------------------------------------------------------------------
1395
1396    ktf = min(kte,kde-1)
1397    ktfm1 = ktf-1
1398
1399    i_start = its
1400    i_end   = MIN(ite,ide-1)
1401    j_start = jts
1402    j_end   = MIN(jte,jde-1)
1403
1404 ! keep upper damping diffusion away from relaxation zones at boundaries if used
1405    IF(config_flags%specified .OR. config_flags%nested)THEN
1406      i_start = MAX(i_start,ids+config_flags%spec_bdy_width-1)
1407      i_end   = MIN(i_end,ide-config_flags%spec_bdy_width)
1408      j_start = MAX(j_start,jds+config_flags%spec_bdy_width-1)
1409      j_end   = MIN(j_end,jde-config_flags%spec_bdy_width)
1410    ENDIF
1411
1412    kmmax=dx*dx/dt
1413    degrad90=DEGRAD*90.
1414    DO j = j_start, j_end
1415
1416       k=ktf
1417       DO i = i_start, i_end
1418          ! Unmodified dx used above may produce very large diffusivities
1419          ! when msftx is very large.  And the above formula ignores the fact
1420          ! that dy may now be different from dx as well.  Let's fix that by
1421          ! defining a "ds" as the minimum of the "real-space" (physical
1422          ! distance) values of dx and dy, and then using that smallest value
1423          ! to calculate a point-by-point kmmax
1424          ds = MIN(dx/msftx(i,j),dy/msfty(i,j))
1425          kmmax=ds*ds/dt
1426
1427 !         deltaz(i)=0.5*dnw(k)/zeta_z(i,j)
1428 !         dz=dnw(k)/zeta_z(i,j)
1429          dz = 1./rdzw(i,k,j)
1430          deltaz(i) = 0.5*dz
1431
1432          kmmvmax=dz*dz/dt
1433          tmp=min(deltaz(i)/zdamp,1.)
1434          dampk(i,k,j)=cos(degrad90*tmp)*cos(degrad90*tmp)*kmmax*dampcoef
1435          dampkv(i,k,j)=cos(degrad90*tmp)*cos(degrad90*tmp)*kmmvmax*dampcoef
1436 ! set upper limit on vertical K (based on horizontal K)
1437          dampkv(i,k,j)=min(dampkv(i,k,j),dampk(i,k,j))
1438
1439       ENDDO
1440
1441       DO k = ktfm1,kts,-1
1442       DO i = i_start, i_end
1443          ! Unmodified dx used above may produce very large diffusivities
1444          ! when msftx is very large.  And the above formula ignores the fact
1445          ! that dy may now be different from dx as well.  Let's fix that by
1446          ! defining a "ds" as the minimum of the "real-space" (physical
1447          ! distance) values of dx and dy, and then using that smallest value
1448          ! to calculate a point-by-point kmmax
1449          ds = MIN(dx/msftx(i,j),dy/msfty(i,j))
1450          kmmax=ds*ds/dt
1451
1452 !         deltaz(i)=deltaz(i)+dn(k)/zeta_z(i,j)
1453 !         dz=dnw(k)/zeta_z(i,j)
1454          dz = 1./rdz(i,k,j)
1455          deltaz(i) = deltaz(i) + dz
1456          dz = 1./rdzw(i,k,j)
1457
1458          kmmvmax=dz*dz/dt
1459          tmp=min(deltaz(i)/zdamp,1.)
1460          dampk(i,k,j)=cos(degrad90*tmp)*cos(degrad90*tmp)*kmmax*dampcoef
1461          dampkv(i,k,j)=cos(degrad90*tmp)*cos(degrad90*tmp)*kmmvmax*dampcoef
1462 ! set upper limit on vertical K (based on horizontal K)
1463          dampkv(i,k,j)=min(dampkv(i,k,j),dampk(i,k,j))
1464       ENDDO
1465       ENDDO
1466
1467    ENDDO
1468
1469    DO j = j_start, j_end
1470    DO k = kts,ktf
1471    DO i = i_start, i_end
1472       xkmh(i,k,j)=max(xkmh(i,k,j),dampk(i,k,j))
1473       xkhh(i,k,j)=max(xkhh(i,k,j),dampk(i,k,j))
1474       xkmv(i,k,j)=max(xkmv(i,k,j),dampkv(i,k,j))
1475       xkhv(i,k,j)=max(xkhv(i,k,j),dampkv(i,k,j))
1476    ENDDO
1477    ENDDO
1478    ENDDO
1479
1480 END SUBROUTINE cal_dampkm
1481
1482 !=======================================================================
1483 !=======================================================================
1484
1485     SUBROUTINE calculate_N2( config_flags, BN2, moist,           &
1486                              theta, t, p, p8w, t8w,              &
1487                              dnw, dn, rdz, rdzw,                 &
1488                              n_moist, cf1, cf2, cf3, warm_rain,  &
1489                              ids, ide, jds, jde, kds, kde,       &
1490                              ims, ime, jms, jme, kms, kme,       &
1491                              its, ite, jts, jte, kts, kte        )
1492
1493 !-----------------------------------------------------------------------
1494 ! Begin declarations.
1495
1496     IMPLICIT NONE
1497
1498     TYPE( grid_config_rec_type ), INTENT( IN )  &
1499     :: config_flags
1500
1501     INTEGER, INTENT( IN )  &
1502     :: n_moist,  &
1503        ids, ide, jds, jde, kds, kde, &
1504        ims, ime, jms, jme, kms, kme, &
1505        its, ite, jts, jte, kts, kte
1506
1507     LOGICAL, INTENT( IN )  &
1508     :: warm_rain
1509
1510     REAL, INTENT( IN )  &
1511     :: cf1, cf2, cf3
1512
1513     REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT( INOUT )  &
1514     :: BN2
1515
1516     REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT( IN )  &
1517     :: rdz, rdzw, theta, t, p, p8w, t8w
1518
1519     REAL, DIMENSION( kms:kme ), INTENT( IN )  &
1520     :: dnw, dn
1521
1522     REAL, DIMENSION( ims:ime, kms:kme, jms:jme, n_moist), INTENT( INOUT )  &
1523     :: moist
1524
1525 ! Local variables.
1526
1527     INTEGER  &
1528     :: i, j, k, ktf, ispe, ktes1, ktes2,  &
1529        i_start, i_end, j_start, j_end
1530
1531     REAL  &
1532     :: coefa, thetaep1, thetaem1, qc_cr, es, tc, qlpqi, qsw, qsi,  &
1533        tmpdz, xlvqv, thetaesfc, thetasfc, qvtop, qvsfc, thetatop, thetaetop
1534
1535     REAL, DIMENSION( its:ite, jts:jte )  &
1536     :: tmp1sfc, tmp1top
1537
1538     REAL, DIMENSION( its:ite, kts:kte, jts:jte )  &
1539     :: tmp1, qvs, qctmp
1540
1541 ! End declarations.
1542 !-----------------------------------------------------------------------
1543
1544     qc_cr   = 0.00001  ! in Kg/Kg
1545
1546     ktf     = MIN( kte, kde-1 )
1547     ktes1   = kte-1
1548     ktes2   = kte-2
1549
1550     i_start = its
1551     i_end   = MIN( ite, ide-1 )
1552     j_start = jts
1553     j_end   = MIN( jte, jde-1 )
1554
1555     IF ( config_flags%open_xs .OR. config_flags%specified .OR. &
1556          config_flags%nested) i_start = MAX( ids+1, its )
1557     IF ( config_flags%open_xe .OR. config_flags%specified .OR. &
1558          config_flags%nested) i_end   = MIN( ide-2, ite )
1559     IF ( config_flags%open_ys .OR. config_flags%specified .OR. &
1560          config_flags%nested) j_start = MAX( jds+1, jts )
1561     IF ( config_flags%open_ye .OR. config_flags%specified .OR. &
1562          config_flags%nested) j_end   = MIN( jde-2 ,jte )
1563       IF ( config_flags%periodic_x ) i_start = its
1564       IF ( config_flags%periodic_x ) i_end = MIN( ite, ide-1 )
1565
1566     IF ( P_QC .GT. PARAM_FIRST_SCALAR) THEN
1567       DO j = j_start, j_end
1568       DO k = kts, ktf
1569       DO i = i_start, i_end
1570         qctmp(i,k,j) = moist(i,k,j,P_QC)
1571       END DO
1572       END DO
1573       END DO
1574     ELSE
1575       DO j = j_start, j_end
1576       DO k = kts, ktf
1577       DO i = i_start, i_end
1578          qctmp(i,k,j) = 0.0
1579       END DO
1580       END DO
1581       END DO
1582     END IF
1583
1584     DO j = jts, jte
1585     DO k = kts, kte
1586     DO i = its, ite
1587       tmp1(i,k,j) = 0.0
1588     END DO
1589     END DO
1590     END DO
1591
1592     DO j = jts,jte
1593     DO i = its,ite
1594       tmp1sfc(i,j) = 0.0
1595       tmp1top(i,j) = 0.0
1596     END DO
1597     END DO
1598
1599     DO ispe = PARAM_FIRST_SCALAR, n_moist
1600       IF ( ispe .EQ. P_QV .OR. ispe .EQ. P_QC .OR. ispe .EQ. P_QI) THEN
1601         DO j = j_start, j_end
1602         DO k = kts, ktf
1603         DO i = i_start, i_end
1604           tmp1(i,k,j) = tmp1(i,k,j) + moist(i,k,j,ispe)
1605         END DO
1606         END DO
1607         END DO
1608
1609         DO j = j_start, j_end
1610         DO i = i_start, i_end
1611           tmp1sfc(i,j) = tmp1sfc(i,j) +  &
1612                          cf1 * moist(i,1,j,ispe) +  &
1613                          cf2 * moist(i,2,j,ispe) +  &
1614                          cf3 * moist(i,3,j,ispe)
1615           tmp1top(i,j) = tmp1top(i,j) +  &
1616                          moist(i,ktes1,j,ispe) + &
1617                          ( moist(i,ktes1,j,ispe) - moist(i,ktes2,j,ispe) ) *  &
1618                          0.5 * dnw(ktes1) / dn(ktes1)
1619         END DO
1620         END DO
1621       END IF
1622     END DO
1623
1624 ! Calculate saturation mixing ratio.
1625
1626     DO j = j_start, j_end
1627     DO k = kts, ktf
1628     DO i = i_start, i_end
1629       tc         = t(i,k,j) - SVPT0
1630       es         = 1000.0 * SVP1 * EXP( SVP2 * tc / ( t(i,k,j) - SVP3 ) )
1631       qvs(i,k,j) = EP_2 * es / ( p(i,k,j) - es )
1632     END DO
1633     END DO
1634     END DO
1635
1636     DO j = j_start, j_end
1637     DO k = kts+1, ktf-1
1638     DO i = i_start, i_end
1639       tmpdz = 1.0 / rdz(i,k,j) + 1.0 / rdz(i,k+1,j)
1640       IF ( moist(i,k,j,P_QV) .GE. qvs(i,k,j) .OR. qctmp(i,k,j) .GE. qc_cr) THEN
1641         xlvqv      = XLV * moist(i,k,j,P_QV)
1642         coefa      = ( 1.0 + xlvqv / R_d / t(i,k,j) ) / &
1643                      ( 1.0 + XLV * xlvqv / Cp / R_v / t(i,k,j) / t(i,k,j) ) /  &
1644                      theta(i,k,j)
1645         thetaep1   = theta(i,k+1,j) *  &
1646                      ( 1.0 + XLV * qvs(i,k+1,j) / Cp / t(i,k+1,j) )
1647         thetaem1   = theta(i,k-1,j) *  &
1648                      ( 1.0 + XLV * qvs(i,k-1,j) / Cp / t(i,k-1,j) )
1649         BN2(i,k,j) = g * ( coefa * ( thetaep1 - thetaem1 ) / tmpdz -  &
1650                      ( tmp1(i,k+1,j) - tmp1(i,k-1,j) ) / tmpdz )
1651       ELSE
1652         BN2(i,k,j) = g * ( (theta(i,k+1,j) - theta(i,k-1,j) ) /  &
1653                      theta(i,k,j) / tmpdz +  &
1654                      1.61 * ( moist(i,k+1,j,P_QV) - moist(i,k-1,j,P_QV) ) / &
1655                      tmpdz -   &
1656                      ( tmp1(i,k+1,j) - tmp1(i,k-1,j) ) / tmpdz )
1657       ENDIF
1658     END DO
1659     END DO
1660     END DO
1661
1662     k = kts
1663     DO j = j_start, j_end
1664     DO i = i_start, i_end
1665       tmpdz     = 1.0 / rdz(i,k+1,j) + 0.5 / rdzw(i,k,j)
1666       thetasfc  = T8w(i,kts,j) / ( p8w(i,k,j) / p1000mb )**( R_d / Cp )
1667       IF ( moist(i,k,j,P_QV) .GE. qvs(i,k,j) .OR. qctmp(i,k,j) .GE. qc_cr) THEN
1668         qvsfc     = cf1 * qvs(i,1,j) +  &
1669                     cf2 * qvs(i,2,j) +  &
1670                     cf3 * qvs(i,3,j)
1671         xlvqv      = XLV * moist(i,k,j,P_QV)
1672         coefa      = ( 1.0 + xlvqv / R_d / t(i,k,j) ) /  &
1673                      ( 1.0 + XLV * xlvqv / Cp / R_v / t(i,k,j) / t(i,k,j) ) /  &
1674                      theta(i,k,j)
1675         thetaep1   = theta(i,k+1,j) *  &
1676                      ( 1.0 + XLV * qvs(i,k+1,j) / Cp / t(i,k+1,j) )
1677         thetaesfc  = thetasfc *  &
1678                      ( 1.0 + XLV * qvsfc / Cp / t8w(i,kts,j) )
1679         BN2(i,k,j) = g * ( coefa * ( thetaep1 - thetaesfc ) / tmpdz -  &
1680                      ( tmp1(i,k+1,j) - tmp1sfc(i,j) ) / tmpdz )
1681       ELSE
1682         qvsfc     = cf1 * moist(i,1,j,P_QV) +  &
1683                     cf2 * moist(i,2,j,P_QV) +  &
1684                     cf3 * moist(i,3,j,P_QV)
1685 !        BN2(i,k,j) = g * ( ( theta(i,k+1,j) - thetasfc ) /  &
1686 !                     theta(i,k,j) / tmpdz +  &
1687 !                     1.61 * ( moist(i,k+1,j,P_QV) - qvsfc ) /  &
1688 !                     tmpdz -  &
1689 !                     ( tmp1(i,k+1,j) - tmp1sfc(i,j) ) / tmpdz  )
1690 !...... MARTA: change in computation of BN2 at the surface, WCS 040331
1691
1692         tmpdz= 1./rdzw(i,k,j) ! controlare come calcola rdzw
1693         BN2(i,k,j) = g * ( ( theta(i,k+1,j) - theta(i,k,j)) /  &
1694                      theta(i,k,j) / tmpdz +  &
1695                      1.61 * ( moist(i,k+1,j,P_QV) - qvsfc ) /  &
1696                      tmpdz -  &
1697                      ( tmp1(i,k+1,j) - tmp1sfc(i,j) ) / tmpdz  )
1698 ! end of MARTA/WCS change
1699
1700       ENDIF
1701     END DO
1702     END DO
1703
1704
1705 !...... MARTA: change in computation of BN2 at the top, WCS 040331
1706     DO j = j_start, j_end
1707     DO i = i_start, i_end
1708        BN2(i,ktf,j)=BN2(i,ktf-1,j)
1709     END DO
1710     END DO
1711 ! end of MARTA/WCS change
1712
1713     END SUBROUTINE calculate_N2
1714
1715 !=======================================================================
1716 !=======================================================================
1717
1718 SUBROUTINE isotropic_km( config_flags,                                         &
1719                          xkmh,xkmv,xkhh,xkhv,khdif,kvdif,                      &
1720                          ids,ide, jds,jde, kds,kde,                            &
1721                          ims,ime, jms,jme, kms,kme,                            &
1722                          its,ite, jts,jte, kts,kte                            )
1723
1724 !-----------------------------------------------------------------------
1725 ! Begin declarations.
1726
1727    IMPLICIT NONE
1728
1729    TYPE(grid_config_rec_type) , INTENT(IN   ) :: config_flags
1730
1731    INTEGER ,          INTENT(IN   )           :: ids, ide, jds, jde, kds, kde, &
1732                                                  ims, ime, jms, jme, kms, kme, &
1733                                                  its, ite, jts, jte, kts, kte
1734
1735    REAL    ,          INTENT(IN   )           :: khdif,kvdif
1736
1737    REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(INOUT) ::     xkmh, &
1738                                                                          xkmv, &
1739                                                                          xkhh, &
1740                                                                          xkhv
1741 ! LOCAL VARS
1742
1743    INTEGER :: i_start, i_end, j_start, j_end, ktf, i, j, k
1744    REAL    :: khdif3,kvdif3
1745
1746 ! End declarations.
1747 !-----------------------------------------------------------------------
1748
1749    ktf = kte
1750
1751    i_start = its
1752    i_end   = MIN(ite,ide-1)
1753    j_start = jts
1754    j_end   = MIN(jte,jde-1)
1755
1756 !   khdif3=khdif*3.
1757 !   kvdif3=kvdif*3.
1758    khdif3=khdif/prandtl
1759    kvdif3=kvdif/prandtl
1760
1761    DO j = j_start, j_end
1762    DO k = kts, ktf
1763    DO i = i_start, i_end
1764       xkmh(i,k,j)=khdif
1765       xkmv(i,k,j)=kvdif
1766       xkhh(i,k,j)=khdif3
1767       xkhv(i,k,j)=kvdif3
1768    ENDDO
1769    ENDDO
1770    ENDDO
1771
1772 END SUBROUTINE isotropic_km
1773
1774 !=======================================================================
1775 !=======================================================================
1776
1777 SUBROUTINE smag_km( config_flags,xkmh,xkmv,xkhh,xkhv,BN2,                      &
1778                     div,defor11,defor22,defor33,defor12,                       &
1779                     defor13,defor23,                                           &
1780                     rdzw,dx,dy,dt,isotropic,                                   &
1781                     mix_upper_bound, msftx, msfty,                             &
1782                     ids,ide, jds,jde, kds,kde,                                 &
1783                     ims,ime, jms,jme, kms,kme,                                 &
1784                     its,ite, jts,jte, kts,kte                                  )
1785
1786 !-----------------------------------------------------------------------
1787 ! Begin declarations.
1788
1789    IMPLICIT NONE
1790
1791    TYPE(grid_config_rec_type) , INTENT(IN   ) :: config_flags
1792
1793    INTEGER ,          INTENT(IN   )           :: ids, ide, jds, jde, kds, kde, &
1794                                                  ims, ime, jms, jme, kms, kme, &
1795                                                  its, ite, jts, jte, kts, kte
1796
1797    INTEGER ,          INTENT(IN   )           :: isotropic
1798    REAL    ,          INTENT(IN   )           :: dx, dy, dt, mix_upper_bound
1799
1800
1801    REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(IN   ) ::      BN2, &
1802                                                                          rdzw
1803
1804    REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(INOUT) ::     xkmh, &
1805                                                                          xkmv, &
1806                                                                          xkhh, &
1807                                                                          xkhv
1808
1809    REAL , DIMENSION( ims:ime , kms:kme, jms:jme ),  INTENT(IN   )      ::      &
1810                                                                       defor11, &
1811                                                                       defor22, &
1812                                                                       defor33, &
1813                                                                       defor12, &
1814                                                                       defor13, &
1815                                                                       defor23, &
1816                                                                           div
1817    REAL , DIMENSION( ims:ime, jms:jme), INTENT(IN   ) ::                msftx, &
1818                                                                         msfty
1819 ! LOCAL VARS
1820
1821    INTEGER :: i_start, i_end, j_start, j_end, ktf, i, j, k
1822    REAL    :: deltas, tmp, pr, mlen_h, mlen_v, c_s
1823
1824    REAL, DIMENSION( its:ite , kts:kte , jts:jte )                 ::     def2
1825
1826 ! End declarations.
1827 !-----------------------------------------------------------------------
1828
1829    ktf = min(kte,kde-1)
1830
1831    i_start = its
1832    i_end   = MIN(ite,ide-1)
1833    j_start = jts
1834    j_end   = MIN(jte,jde-1)
1835
1836    IF ( config_flags%open_xs .or. config_flags%specified .or. &
1837         config_flags%nested) i_start = MAX(ids+1,its)
1838    IF ( config_flags%open_xe .or. config_flags%specified .or. &
1839         config_flags%nested) i_end   = MIN(ide-2,ite)
1840    IF ( config_flags%open_ys .or. config_flags%specified .or. &
1841         config_flags%nested) j_start = MAX(jds+1,jts)
1842    IF ( config_flags%open_ye .or. config_flags%specified .or. &
1843         config_flags%nested) j_end   = MIN(jde-2,jte)
1844       IF ( config_flags%periodic_x ) i_start = its
1845       IF ( config_flags%periodic_x ) i_end = MIN( ite, ide-1 )
1846
1847    pr = prandtl
1848    c_s = config_flags%c_s
1849
1850    do j=j_start,j_end
1851    do k=kts,ktf
1852    do i=i_start,i_end
1853       def2(i,k,j)=0.5*(defor11(i,k,j)*defor11(i,k,j) + &
1854                        defor22(i,k,j)*defor22(i,k,j) + &
1855                        defor33(i,k,j)*defor33(i,k,j))
1856    enddo
1857    enddo
1858    enddo
1859
1860    do j=j_start,j_end
1861    do k=kts,ktf
1862    do i=i_start,i_end
1863       tmp=0.25*(defor12(i  ,k,j)+defor12(i  ,k,j+1)+ &
1864                 defor12(i+1,k,j)+defor12(i+1,k,j+1))
1865       def2(i,k,j)=def2(i,k,j)+tmp*tmp
1866    enddo
1867    enddo
1868    enddo
1869
1870    do j=j_start,j_end
1871    do k=kts,ktf
1872    do i=i_start,i_end
1873       tmp=0.25*(defor13(i  ,k+1,j)+defor13(i  ,k,j)+ &
1874                 defor13(i+1,k+1,j)+defor13(i+1,k,j))
1875       def2(i,k,j)=def2(i,k,j)+tmp*tmp
1876    enddo
1877    enddo
1878    enddo
1879
1880    do j=j_start,j_end
1881    do k=kts,ktf
1882    do i=i_start,i_end
1883       tmp=0.25*(defor23(i,k+1,j  )+defor23(i,k,j  )+ &
1884                 defor23(i,k+1,j+1)+defor23(i,k,j+1))
1885       def2(i,k,j)=def2(i,k,j)+tmp*tmp
1886    enddo
1887    enddo
1888    enddo
1889 !
1890    IF (isotropic .EQ. 0) THEN
1891       DO j = j_start, j_end
1892       DO k = kts, ktf
1893       DO i = i_start, i_end
1894          mlen_h=sqrt(dx/msftx(i,j) * dy/msfty(i,j))
1895          mlen_v= 1./rdzw(i,k,j)
1896          tmp=max(0.,def2(i,k,j)-BN2(i,k,j)/pr)
1897          tmp=tmp**0.5
1898          xkmh(i,k,j)=max(c_s*c_s*mlen_h*mlen_h*tmp, 1.0E-6*mlen_h*mlen_h )
1899          xkmh(i,k,j)=min(xkmh(i,k,j), mix_upper_bound * mlen_h * mlen_h / dt )
1900          xkmv(i,k,j)=max(c_s*c_s*mlen_v*mlen_v*tmp, 1.0E-6*mlen_v*mlen_v )
1901          xkmv(i,k,j)=min(xkmv(i,k,j), mix_upper_bound * mlen_v * mlen_v / dt )
1902          xkhh(i,k,j)=xkmh(i,k,j)/pr
1903          xkhh(i,k,j)=min(xkhh(i,k,j), mix_upper_bound * mlen_h * mlen_h / dt )
1904          xkhv(i,k,j)=xkmv(i,k,j)/pr
1905          xkhv(i,k,j)=min(xkhv(i,k,j), mix_upper_bound * mlen_v * mlen_v / dt )
1906       ENDDO
1907       ENDDO
1908       ENDDO
1909    ELSE
1910       DO j = j_start, j_end
1911       DO k = kts, ktf
1912       DO i = i_start, i_end
1913          deltas=(dx/msftx(i,j) * dy/msfty(i,j)/rdzw(i,k,j))**0.33333333
1914          tmp=max(0.,def2(i,k,j)-BN2(i,k,j)/pr)
1915          tmp=tmp**0.5
1916          xkmh(i,k,j)=max(c_s*c_s*deltas*deltas*tmp, 1.0E-6*deltas*deltas )
1917          xkmh(i,k,j)=min(xkmh(i,k,j), mix_upper_bound * dx/msftx(i,j) * dy/msfty(i,j) / dt )
1918          xkmv(i,k,j)=xkmh(i,k,j)
1919          xkmv(i,k,j)=min(xkmv(i,k,j), mix_upper_bound / rdzw(i,k,j) / rdzw(i,k,j) / dt )
1920          xkhh(i,k,j)=xkmh(i,k,j)/pr
1921          xkhh(i,k,j)=min(xkhh(i,k,j), mix_upper_bound * dx/msftx(i,j) * dy/msfty(i,j) / dt )
1922          xkhv(i,k,j)=xkmv(i,k,j)/pr
1923          xkhv(i,k,j)=min(xkhv(i,k,j), mix_upper_bound / rdzw(i,k,j) / rdzw(i,k,j) / dt )
1924       ENDDO
1925       ENDDO
1926       ENDDO
1927    ENDIF
1928
1929 END SUBROUTINE smag_km
1930
1931 !=======================================================================
1932 !=======================================================================
1933
1934 SUBROUTINE smag2d_km( config_flags,xkmh,xkmv,xkhh,xkhv,                        &
1935                     defor11,defor22,defor12,                                   &
1936                     rdzw,dx,dy,msftx, msfty,zx,zy,                             &
1937                     ids,ide, jds,jde, kds,kde,                                 &
1938                     ims,ime, jms,jme, kms,kme,                                 &
1939                     its,ite, jts,jte, kts,kte                                  )
1940
1941 !-----------------------------------------------------------------------
1942 ! Begin declarations.
1943
1944    IMPLICIT NONE
1945
1946    TYPE(grid_config_rec_type) , INTENT(IN   ) :: config_flags
1947
1948    INTEGER ,          INTENT(IN   )           :: ids, ide, jds, jde, kds, kde, &
1949                                                  ims, ime, jms, jme, kms, kme, &
1950                                                  its, ite, jts, jte, kts, kte
1951
1952    REAL    ,          INTENT(IN   )           :: dx, dy
1953
1954
1955    REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(IN   ) ::     rdzw,zx,zy
1956
1957    REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(INOUT) ::     xkmh, &
1958                                                                          xkmv, &
1959                                                                          xkhh, &
1960                                                                          xkhv
1961
1962    REAL , DIMENSION( ims:ime , kms:kme, jms:jme ),  INTENT(IN   )      ::      &
1963                                                                       defor11, &
1964                                                                       defor22, &
1965                                                                       defor12
1966
1967    REAL , DIMENSION( ims:ime, jms:jme), INTENT(IN   ) ::                msftx, &
1968                                                                         msfty
1969 ! LOCAL VARS
1970
1971    INTEGER :: i_start, i_end, j_start, j_end, ktf, i, j, k
1972    REAL    :: deltas, tmp, pr, mlen_h, c_s
1973    REAL    :: dxm, dym, tmpzx, tmpzy, alpha, def_limit
1974
1975    REAL, DIMENSION( its:ite , kts:kte , jts:jte )                 ::     def2
1976
1977 ! End declarations.
1978 !-----------------------------------------------------------------------
1979
1980    ktf = min(kte,kde-1)
1981
1982    i_start = its
1983    i_end   = MIN(ite,ide-1)
1984    j_start = jts
1985    j_end   = MIN(jte,jde-1)
1986
1987    IF ( config_flags%open_xs .or. config_flags%specified .or. &
1988         config_flags%nested) i_start = MAX(ids+1,its)
1989    IF ( config_flags%open_xe .or. config_flags%specified .or. &
1990         config_flags%nested) i_end   = MIN(ide-2,ite)
1991    IF ( config_flags%open_ys .or. config_flags%specified .or. &
1992         config_flags%nested) j_start = MAX(jds+1,jts)
1993    IF ( config_flags%open_ye .or. config_flags%specified .or. &
1994         config_flags%nested) j_end   = MIN(jde-2,jte)
1995       IF ( config_flags%periodic_x ) i_start = its
1996       IF ( config_flags%periodic_x ) i_end = MIN( ite, ide-1 )
1997
1998    pr=prandtl
1999    c_s = config_flags%c_s
2000
2001    do j=j_start,j_end
2002    do k=kts,ktf
2003    do i=i_start,i_end
2004       def2(i,k,j)=0.25*((defor11(i,k,j)-defor22(i,k,j))*(defor11(i,k,j)-defor22(i,k,j)))
2005       tmp=0.25*(defor12(i  ,k,j)+defor12(i  ,k,j+1)+ &
2006                 defor12(i+1,k,j)+defor12(i+1,k,j+1))
2007       def2(i,k,j)=def2(i,k,j)+tmp*tmp
2008    enddo
2009    enddo
2010    enddo
2011 !
2012       DO j = j_start, j_end
2013       DO k = kts, ktf
2014       DO i = i_start, i_end
2015          mlen_h=sqrt(dx/msftx(i,j) * dy/msfty(i,j))
2016          tmp=sqrt(def2(i,k,j))
2017 !        xkmh(i,k,j)=max(c_s*c_s*mlen_h*mlen_h*tmp, 1.0E-6*mlen_h*mlen_h )
2018          xkmh(i,k,j)=c_s*c_s*mlen_h*mlen_h*tmp
2019          xkmh(i,k,j)=min(xkmh(i,k,j), 10.*mlen_h )
2020          xkmv(i,k,j)=xkmh(i,k,j)               ! v4.2 and later, this is used for hor. diff. of w
2021          xkhh(i,k,j)=xkmh(i,k,j)/pr
2022          xkhv(i,k,j)=0.
2023          IF(config_flags%diff_opt .EQ. 2)THEN
2024 ! jd: reduce diffusion coefficient by slope factor (modified by JB August 2014)
2025             dxm=dx/msftx(i,j)
2026             dym=dy/msfty(i,j)
2027             tmpzx = (0.25*( abs(zx(i,k,j))+ abs(zx(i+1,k,j  )) + abs(zx(i,k+1,j))+ abs(zx(i+1,k+1,j  )))*rdzw(i,k,j)*dxm)
2028             tmpzy = (0.25*( abs(zy(i,k,j))+ abs(zy(i  ,k,j+1)) + abs(zy(i,k+1,j))+ abs(zy(i  ,k+1,j+1)))*rdzw(i,k,j)*dym)
2029             alpha = max(sqrt(tmpzx*tmpzx+tmpzy*tmpzy),1.0)
2030 ! If deformation is large, further reduce the diffusion coefficient
2031             def_limit = max(10./mlen_h,1.e-3)
2032            if ( tmp .gt. def_limit ) then
2033              xkmh(i,k,j)=xkmh(i,k,j)/(alpha*alpha)
2034            else
2035              xkmh(i,k,j)=xkmh(i,k,j)/(alpha)
2036            endif
2037            xkhh(i,k,j)=xkmh(i,k,j)/pr
2038            xkmv(i,k,j)=xkmh(i,k,j)               ! v4.2 and later, this is used for hor. diff. of w
2039          ENDIF
2040       ENDDO
2041       ENDDO
2042       ENDDO
2043
2044 END SUBROUTINE smag2d_km
2045
2046 !=======================================================================
2047 !=======================================================================
2048
2049     SUBROUTINE tke_km( config_flags, xkmh, xkmv, xkhh, xkhv,         &
2050                        bn2, tke, p8w, t8w, theta,                    &
2051                        rdz, rdzw, dx,dy, dt, isotropic,              &
2052                        mix_upper_bound, msftx, msfty,                &
2053                        hpbl,dlk,xkmv_meso,                           &  ! XZ
2054                        defor11,defor22,defor12,zx,zy,                &  ! XZ
2055                        ids, ide, jds, jde, kds, kde,                 &
2056                        ims, ime, jms, jme, kms, kme,                 &
2057                        its, ite, jts, jte, kts, kte                  )
2058
2059 ! History:     Sep 2003   Changes by Jason Knievel and George Bryan, NCAR
2060 !              Oct 2001   Converted to mass core by Bill Skamarock, NCAR
2061 !              ...        ...
2062
2063 ! Purpose:     This routine calculates the exchange coefficients for the
2064 !              TKE turbulence parameterization.
2065
2066 ! References:  Klemp and Wilhelmson (JAS 1978)
2067 !              Chen and Dudhia (NCAR WRF physics report 2000)
2068
2069 !-----------------------------------------------------------------------
2070 ! Begin declarations.
2071
2072     IMPLICIT NONE
2073
2074     TYPE( grid_config_rec_type ), INTENT( IN )  &
2075     :: config_flags
2076
2077     INTEGER, INTENT( IN )  &
2078     :: ids, ide, jds, jde, kds, kde,  &
2079        ims, ime, jms, jme, kms, kme,  &
2080        its, ite, jts, jte, kts, kte
2081
2082     INTEGER, INTENT( IN )  :: isotropic
2083     REAL, INTENT( IN )  &
2084     :: dx, dy, dt
2085
2086     REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT( IN )  &
2087     :: tke, p8w, t8w, theta, rdz, rdzw, bn2
2088
2089     REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT( INOUT )  &
2090     :: xkmh, xkmv, xkhh, xkhv
2091
2092     REAL, INTENT( IN )  &
2093     :: mix_upper_bound
2094
2095    REAL , DIMENSION( ims:ime, jms:jme), INTENT(IN   ) ::     msftx, &
2096                                                              msfty
2097 !XZ
2098    REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT( IN )     &
2099    :: zx,zy
2100
2101    REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT( IN )     &
2102    :: defor11, defor22, defor12
2103
2104    REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT( INOUT )  &
2105    :: xkmv_meso
2106
2107    REAL, DIMENSION( ims:ime, jms:jme), INTENT( INOUT )            &
2108    :: hpbl
2109
2110    REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT( IN )     &
2111    :: dlk
2112 !
2113 ! Local variables.
2114
2115     REAL, DIMENSION( its:ite, kts:kte, jts:jte )  &
2116     :: l_scale
2117
2118     REAL, DIMENSION( its:ite, kts:kte, jts:jte )  &
2119     :: dthrdn
2120
2121     REAL  &
2122     :: deltas, tmp, mlen_s, mlen_h, mlen_v, tmpdz,  &
2123        thetasfc, thetatop, minkx, pr_inv, pr_inv_h, pr_inv_v, c_k
2124
2125     INTEGER  &
2126     :: i_start, i_end, j_start, j_end, ktf, i, j, k
2127
2128     REAL, PARAMETER :: tke_seed_value = 1.e-06
2129     REAL            :: tke_seed
2130     REAL, PARAMETER :: epsilon = 1.e-10
2131 !XZ
2132     REAL            :: pth1, delxy, pu1, xkmv_les, pr_inv_v_meso, pr_inv_v_les, pr
2133     REAL            :: dxm, dym, tmpzx, tmpzy, alpha, def_limit, c_s, xkmh_t, xkhh_t
2134     REAL, DIMENSION( its:ite , kts:kte , jts:jte )   ::  def2
2135     REAL, DIMENSION( its:ite , kts:kte , jts:jte )   ::  xkmh_s, xkhh_s
2136     REAL, PARAMETER :: xkmvo = 0.0, xkhvo = 0.0 !background diffusivity
2137 !
2138 ! End declarations.
2139 !-----------------------------------------------------------------------
2140
2141     ktf     = MIN( kte, kde-1 )
2142     i_start = its
2143     i_end   = MIN( ite, ide-1 )
2144     j_start = jts
2145     j_end   = MIN( jte, jde-1 )
2146
2147     IF ( config_flags%open_xs .OR. config_flags%specified .OR. &
2148          config_flags%nested) i_start = MAX( ids+1, its )
2149     IF ( config_flags%open_xe .OR. config_flags%specified .OR. &
2150          config_flags%nested) i_end   = MIN( ide-2, ite )
2151     IF ( config_flags%open_ys .OR. config_flags%specified .OR. &
2152          config_flags%nested) j_start = MAX( jds+1, jts )
2153     IF ( config_flags%open_ye .OR. config_flags%specified .OR. &
2154          config_flags%nested) j_end   = MIN( jde-2, jte)
2155       IF ( config_flags%periodic_x ) i_start = its
2156       IF ( config_flags%periodic_x ) i_end = MIN( ite, ide-1 )
2157
2158 ! in the absence of surface drag or a surface heat flux, there
2159 ! is no way to generate tke without pre-existing tke.  Use
2160 ! tke_seed if the drag and flux are off.
2161
2162     c_k = config_flags%c_k
2163     tke_seed = 0.
2164     IF (config_flags%isfflx .eq. 0) THEN
2165       IF ((config_flags%diff_opt .eq. 2) .and. (config_flags%bl_pbl_physics .eq. 0)) THEN
2166         IF( (config_flags%tke_drag_coefficient .lt. epsilon) .and.  &
2167             (config_flags%tke_heat_flux .lt. epsilon)  )  THEN
2168           tke_seed = tke_seed_value
2169         ENDIF
2170       ELSE
2171         !tke_drag_coefficient and tke_heat_flux are irrelevant here
2172         tke_seed = tke_seed_value
2173       ENDIF
2174     ENDIF
2175
2176     DO j = j_start, j_end
2177     DO k = kts+1, ktf-1
2178     DO i = i_start, i_end
2179       tmpdz         = 1.0 / rdz(i,k+1,j) + 1.0 / rdz(i,k,j)
2180       dthrdn(i,k,j) = ( theta(i,k+1,j) - theta(i,k-1,j) ) / tmpdz
2181     END DO
2182     END DO
2183     END DO
2184
2185     k = kts
2186     DO j = j_start, j_end
2187     DO i = i_start, i_end
2188       tmpdz         = 1.0 / rdzw(i,k+1,j) + 1.0 / rdzw(i,k,j)
2189       thetasfc      = T8w(i,kts,j) / ( p8w(i,k,j) / p1000mb )**( R_d / Cp )
2190       dthrdn(i,k,j) = ( theta(i,k+1,j) - thetasfc ) / tmpdz
2191     END DO
2192     END DO
2193
2194     k = ktf
2195     DO j = j_start, j_end
2196     DO i = i_start, i_end
2197       tmpdz         = 1.0 / rdz(i,k,j) + 0.5 / rdzw(i,k,j)
2198       thetatop      = T8w(i,kde,j) / ( p8w(i,kde,j) / p1000mb )**( R_d / Cp )
2199       dthrdn(i,k,j) = ( thetatop - theta(i,k-1,j) ) / tmpdz
2200     END DO
2201     END DO
2202
2203     IF ( config_flags%km_opt .EQ. 2 .and. isotropic .EQ. 0 ) THEN  !XZ
2204       DO j = j_start, j_end
2205       DO k = kts, ktf
2206       DO i = i_start, i_end
2207         mlen_h = SQRT( dx/msftx(i,j) * dy/msfty(i,j) )
2208         tmp    = SQRT( MAX( tke(i,k,j), tke_seed ) )
2209         deltas = 1.0 / rdzw(i,k,j)
2210         mlen_v = deltas
2211         IF ( dthrdn(i,k,j) .GT. 0.) THEN
2212           mlen_s = 0.76 * tmp / ( ABS( g / theta(i,k,j) * dthrdn(i,k,j) ) )**0.5
2213           mlen_v = MIN( mlen_v, mlen_s )
2214         END IF
2215         xkmh(i,k,j)  = MAX( c_k * tmp * mlen_h, 1.0E-6 * mlen_h * mlen_h )
2216         xkmh(i,k,j)  = MIN( xkmh(i,k,j), mix_upper_bound * mlen_h *mlen_h / dt )
2217         xkmv(i,k,j)  = MAX( c_k * tmp * mlen_v, 1.0E-6 * deltas * deltas )
2218         xkmv(i,k,j)  = MIN( xkmv(i,k,j), mix_upper_bound * deltas *deltas / dt )
2219         pr_inv_h     = 1./prandtl
2220         pr_inv_v     = 1.0 + 2.0 * mlen_v / deltas
2221         xkhh(i,k,j)  = xkmh(i,k,j) * pr_inv_h
2222         xkhv(i,k,j)  = xkmv(i,k,j) * pr_inv_v
2223       END DO
2224       END DO
2225       END DO
2226     ENDIF  !XZ
2227
2228     IF ( config_flags%km_opt .eq.2.and.isotropic .NE. 0 ) THEN  ! XZ
2229       CALL calc_l_scale( config_flags, tke, BN2, l_scale,      &
2230                          i_start, i_end, ktf, j_start, j_end,  &
2231                          dx, dy, rdzw, msftx, msfty,           &
2232                          ids, ide, jds, jde, kds, kde,         &
2233                          ims, ime, jms, jme, kms, kme,         &
2234                          its, ite, jts, jte, kts, kte          )
2235       DO j = j_start, j_end
2236       DO k = kts, ktf
2237       DO i = i_start, i_end
2238         tmp          = SQRT( MAX( tke(i,k,j), tke_seed ) )
2239         deltas       = ( dx/msftx(i,j) * dy/msfty(i,j) / rdzw(i,k,j) )**0.33333333
2240         xkmh(i,k,j)  = c_k * tmp * l_scale(i,k,j)
2241         xkmh(i,k,j)  = MIN( mix_upper_bound * dx/msftx(i,j) * dy/msfty(i,j) / dt,  xkmh(i,k,j) )
2242         xkmv(i,k,j)  = c_k * tmp * l_scale(i,k,j)
2243         xkmv(i,k,j)  = MIN( mix_upper_bound / rdzw(i,k,j) / rdzw(i,k,j) / dt ,  xkmv(i,k,j) )
2244         pr_inv       = 1.0 + 2.0 * l_scale(i,k,j) / deltas
2245         xkhh(i,k,j)  = MIN( mix_upper_bound * dx/msftx(i,j) * dy/msfty(i,j) / dt, xkmh(i,k,j) * pr_inv )
2246         xkhv(i,k,j)  = MIN( mix_upper_bound / rdzw(i,k,j) / rdzw(i,k,j) / dt, xkmv(i,k,j) * pr_inv )
2247       END DO
2248       END DO
2249       END DO
2250     END IF
2251
2252 !!!XZ
2253     IF(config_flags%km_opt .eq.5 ) THEN  ! 3DTKE diffusivity
2254
2255 !  smag_2d horizontal diffusivity
2256        pr=prandtl
2257        c_s = config_flags%c_s
2258
2259        DO j=j_start,j_end
2260        DO k=kts,ktf
2261        DO i=i_start,i_end
2262              def2(i,k,j) = 0.25*((defor11(i,k,j)-defor22(i,k,j))*(defor11(i,k,j)-defor22(i,k,j)))
2263                      tmp = 0.25*(defor12(i  ,k,j)+defor12(i  ,k,j+1)+ &
2264                                  defor12(i+1,k,j)+defor12(i+1,k,j+1))
2265               def2(i,k,j)= def2(i,k,j)+tmp*tmp
2266        ENDDO
2267        ENDDO
2268        ENDDO
2269
2270        DO j = j_start, j_end
2271        DO k = kts, ktf
2272        DO i = i_start, i_end
2273           mlen_h = sqrt(dx/msftx(i,j) * dy/msfty(i,j))
2274           tmp    = sqrt(def2(i,k,j))
2275           xkmh_s(i,k,j) = c_s*c_s*mlen_h*mlen_h*tmp
2276           xkmh_s(i,k,j) = min(xkmh_s(i,k,j), 10.*mlen_h )
2277           xkhh_s(i,k,j) = xkmh_s(i,k,j)/pr
2278           IF(config_flags%diff_opt .EQ. 2)THEN
2279             dxm=dx/msftx(i,j)
2280             dym=dy/msfty(i,j)
2281             tmpzx = (0.25*( abs(zx(i,k,j))+ abs(zx(i+1,k,j  )) + abs(zx(i,k+1,j))+ abs(zx(i+1,k+1,j  )))*rdzw(i,k,j)*dxm)
2282             tmpzy = (0.25*( abs(zy(i,k,j))+ abs(zy(i  ,k,j+1)) + abs(zy(i,k+1,j))+ abs(zy(i  ,k+1,j+1)))*rdzw(i,k,j)*dym)
2283             alpha = max(sqrt(tmpzx*tmpzx+tmpzy*tmpzy),1.0)
2284             def_limit = max(10./mlen_h,1.e-3)
2285             IF ( tmp .GT. def_limit ) THEN
2286               xkmh_s(i,k,j)=xkmh_s(i,k,j)/(alpha*alpha)
2287             ELSE
2288               xkmh_s(i,k,j)=xkmh_s(i,k,j)/(alpha)
2289             ENDIF
2290               xkhh_s(i,k,j)=xkmh_s(i,k,j)/pr
2291           ENDIF
2292        ENDDO
2293        ENDDO
2294        ENDDO
2295
2296 !! difusivity based on TKE
2297        DO j = j_start, j_end
2298        DO k = kts, ktf
2299        DO i = i_start, i_end
2300               mlen_h = SQRT( dx/msftx(i,j) * dy/msfty(i,j) )  ! horizontal mixing length
2301               tmp    = SQRT( MAX( tke(i,k,j), tke_seed ) )
2302               deltas = 1.0 / rdzw(i,k,j)
2303               mlen_v = deltas
2304           IF ( dthrdn(i,k,j) .GT. 0.) THEN
2305               mlen_s = 0.76 * tmp / ( ABS( g / theta(i,k,j) * dthrdn(i,k,j)))**0.5
2306               mlen_v = MIN( mlen_v, mlen_s )
2307           END IF
2308 ! length scales multiplied by partial function for grid-size dependency
2309               delxy = SQRT(dx/msftx(i,j)*dy/msfty(i,j))
2310               pth1= pthl(delxy,hpbl(i,j))
2311               pu1 = pu  (delxy,hpbl(i,j))
2312
2313               xkmh_t           =  c_k * tmp * mlen_h
2314               xkmv_meso(i,k,j) =  0.4 * tmp * dlk(i,k,j)      ! diffusivity using mesoscale length scale
2315               xkmv_meso(i,k,j) =  xkmv_meso(i,k,j) + xkmvo
2316               xkmv_les         =  c_k * tmp * mlen_v          ! diffusivity using LES length scale
2317               xkmv(i,k,j)      =  ( 1.0 - pu1 ) * xkmv_les  +  pu1 * xkmv_meso(i,k,j)
2318               xkmv(i,k,j)      =  MIN(xkmv(i,k,j), 1000.)
2319
2320               pr_inv_h         =  1./prandtl
2321               pr_inv_v_les     =  1.0 + 2.0 * mlen_v / deltas
2322               pr_inv_v_meso    =  1.0
2323               xkhh_t           =  xkmh_t * pr_inv_h
2324               xkhv(i,k,j)      =  xkmv(i,k,j) * (1.0-pth1) * pr_inv_v_les    &
2325                                +  pth1 * (pr_inv_v_meso * xkmv(i,k,j) + xkhvo)
2326               xkhv(i,k,j)      =  MIN(xkhv(i,k,j), 1000.)
2327 !  blending of horizontal K(deformation) and K(TKE)
2328               xkmh(i,k,j) = pth1 * xkmh_s(i,k,j) + ( 1.0 - pth1 ) * xkmh_t
2329               xkhh(i,k,j) = pth1 * xkhh_s(i,k,j) + ( 1.0 - pth1 ) * xkhh_t
2330        ENDDO
2331        ENDDO
2332        ENDDO
2333
2334     ENDIF
2335 !!!
2336     END SUBROUTINE tke_km
2337
2338 !=======================================================================
2339 !=======================================================================
2340
2341     SUBROUTINE calc_l_scale( config_flags, tke, BN2, l_scale,      &
2342                              i_start, i_end, ktf, j_start, j_end,  &
2343                              dx, dy, rdzw, msftx, msfty,           &
2344                              ids, ide, jds, jde, kds, kde,         &
2345                              ims, ime, jms, jme, kms, kme,         &
2346                              its, ite, jts, jte, kts, kte          )
2347
2348 ! History:     Sep 2003   Written by Bryan and Knievel, NCAR
2349
2350 ! Purpose:     This routine calculates the length scale, based on stability,
2351 !              for TKE parameterization of subgrid-scale turbulence.
2352
2353 !-----------------------------------------------------------------------
2354 ! Begin declarations.
2355
2356     IMPLICIT NONE
2357
2358     TYPE( grid_config_rec_type ), INTENT( IN )  &
2359     :: config_flags
2360
2361     INTEGER, INTENT( IN )  &
2362     :: i_start, i_end, ktf, j_start, j_end,  &
2363        ids, ide, jds, jde, kds, kde,         &
2364        ims, ime, jms, jme, kms, kme,         &
2365        its, ite, jts, jte, kts, kte
2366
2367     REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT( IN )  &
2368     :: BN2, tke, rdzw
2369
2370     REAL, INTENT( IN )  &
2371     :: dx, dy
2372
2373     REAL, DIMENSION( its:ite, kts:kte, jts:jte ), INTENT( OUT )  &
2374     :: l_scale
2375
2376     REAL , DIMENSION( ims:ime, jms:jme), INTENT(IN   ) ::     msftx, &
2377                                                               msfty
2378 ! Local variables.
2379
2380     INTEGER  &
2381     :: i, j, k
2382
2383     REAL  &
2384     :: deltas, tmp
2385
2386 ! End declarations.
2387 !-----------------------------------------------------------------------
2388
2389     DO j = j_start, j_end
2390     DO k = kts, ktf
2391     DO i = i_start, i_end
2392       deltas         = ( dx/msftx(i,j) * dy/msfty(i,j) / rdzw(i,k,j) )**0.33333333
2393       l_scale(i,k,j) = deltas
2394
2395       IF ( BN2(i,k,j) .gt. 1.0e-6 ) THEN
2396         tmp            = SQRT( MAX( tke(i,k,j), 1.0e-6 ) )
2397         l_scale(i,k,j) = 0.76 * tmp / SQRT( BN2(i,k,j) )
2398         l_scale(i,k,j) = MIN( l_scale(i,k,j), deltas)
2399         l_scale(i,k,j) = MAX( l_scale(i,k,j), 0.001 * deltas )
2400       END IF
2401
2402     END DO
2403     END DO
2404     END DO
2405
2406     END SUBROUTINE calc_l_scale
2407
2408 !=======================================================================
2409 !=======================================================================
2410 !XZ
2411     SUBROUTINE meso_length_scale(config_flags,dx,dy,rdzw,rdz,tke,      &
2412                                  p8w,t8w,theta,dlk,hpbl,elmin,         &
2413                                  rmol,rho,hfx,qfx,moist,n_moist,       &
2414                                  ids, ide, jds, jde, kds, kde,         &
2415                                  ims, ime, jms, jme, kms, kme,         &
2416                                  its, ite, jts, jte, kts, kte )
2417 !
2418 ! The mesoscale length scale based on Nakanishi and Niino (2009)
2419 ! and modified by X. Zhang
2420
2421    IMPLICIT NONE
2422
2423    TYPE( grid_config_rec_type ), INTENT( IN )        &
2424    ::  config_flags
2425
2426    INTEGER,                      INTENT( IN )        &
2427    ::  ids, ide, jds, jde, kds, kde,                 &
2428        ims, ime, jms, jme, kms, kme,                 &
2429        its, ite, jts, jte, kts, kte
2430
2431    INTEGER,                      INTENT( IN )        &
2432    ::  n_moist
2433
2434    REAL,                         INTENT( IN )        &
2435    ::  dx,dy
2436
2437    REAL, DIMENSION( ims:ime, kms:kme, jms:jme, n_moist ), INTENT( INOUT )  &
2438    ::  moist
2439
2440    REAL, DIMENSION( ims:ime, kms:kme, jms:jme ),          INTENT( IN )     &
2441    ::  tke, rdzw, rdz, p8w, t8w
2442
2443    REAL, DIMENSION( ims:ime, kms:kme, jms:jme ),          INTENT( IN )     &
2444    ::  theta,rho
2445
2446    REAL, DIMENSION( ims:ime, kms:kme, jms:jme ),          INTENT( INOUT )  &
2447    ::  dlk,elmin
2448
2449    REAL, DIMENSION( ims:ime, jms:jme ),                   INTENT( INOUT )  &
2450    ::  rmol,hfx,qfx,hpbl
2451
2452 !Local variables.
2453    REAL, DIMENSION( its:ite, kts:kte, jts:jte )  :: zfull,za
2454    REAL, DIMENSION( its:ite, kts:kte, jts:jte )  :: elb,qtke,els,elf
2455    REAL, DIMENSION( its:ite,          jts:jte )  :: sflux,elt,vsc
2456    REAL, DIMENSION( its:ite, kts:kte, jts:jte )  :: dthrdn
2457    INTEGER        :: izz,i,k,j
2458    INTEGER        :: i_start, i_end, ktf, j_start, j_end
2459    REAL,PARAMETER :: alp1 = 0.8, alp2 = 1.0, alp3 = 1.0, alp4 = 100.0 !
2460    REAL           :: cpm,qcv,N2,tmpdz,thetasfc,thetatop,heat_flux,gtr,qdz,coe
2461    REAL           :: zi2,h1,h2,wt
2462
2463    REAL, PARAMETER :: minzi = 300.  !min mixed-layer height
2464    REAL, PARAMETER :: maxdz = 750.  !max (half) transition layer depth
2465                                     !=0.3*2500 m PBLH, so the transition
2466                                     !layer stops growing for PBLHs > 2.5 km.
2467    REAL, PARAMETER :: mindz = 300.  !min (half) transition layer depth
2468
2469
2470     ktf     = MIN( kte, kde-1 )
2471     i_start = its
2472     i_end   = MIN( ite, ide-1 )
2473     j_start = jts
2474     j_end   = MIN( jte, jde-1 )
2475
2476     IF ( config_flags%open_xs .OR. config_flags%specified .OR. &
2477          config_flags%nested) i_start = MAX( ids+1, its )
2478     IF ( config_flags%open_xe .OR. config_flags%specified .OR. &
2479          config_flags%nested) i_end   = MIN( ide-2, ite )
2480     IF ( config_flags%open_ys .OR. config_flags%specified .OR. &
2481          config_flags%nested) j_start = MAX( jds+1, jts )
2482     IF ( config_flags%open_ye .OR. config_flags%specified .OR. &
2483          config_flags%nested) j_end   = MIN( jde-2, jte)
2484     IF ( config_flags%periodic_x ) i_start = its
2485     IF ( config_flags%periodic_x ) i_end = MIN( ite, ide-1 )
2486
2487
2488     DO  j = j_start, j_end
2489     DO  i = i_start, i_end
2490         zfull(i,1,j) = 0.
2491     ENDDO
2492     ENDDO
2493
2494     DO  j = j_start, j_end
2495     DO  k = kts, ktf
2496     DO  i = i_start, i_end
2497         zfull(i,k+1,j) = 1.0/rdzw(i,k,j) + zfull(i,k,j)
2498     ENDDO
2499     ENDDO
2500     ENDDO
2501
2502     DO  j = j_start, j_end
2503     DO  k = kts, ktf
2504     DO  i = i_start, i_end
2505         za(i,k,j) = (zfull(i,k,j) + zfull(i,k+1,j))/2.0
2506     ENDDO
2507     ENDDO
2508     ENDDO
2509
2510     DO j = j_start, j_end
2511     DO k = kts, ktf
2512     DO i = i_start, i_end
2513        dlk(i,k,j) = 0.0
2514     ENDDO
2515     ENDDO
2516     ENDDO
2517
2518     DO j = j_start, j_end
2519     DO k = kts+1, ktf-1
2520     DO i = i_start, i_end
2521       tmpdz         = 1.0 / rdz(i,k+1,j) + 1.0 / rdz(i,k,j)
2522       dthrdn(i,k,j) = ( theta(i,k+1,j) - theta(i,k-1,j) ) / tmpdz
2523     END DO
2524     END DO
2525     END DO
2526
2527     k = kts
2528     DO j = j_start, j_end
2529     DO i = i_start, i_end
2530       tmpdz         = 1.0 / rdzw(i,k+1,j) + 1.0 / rdzw(i,k,j)
2531       thetasfc      = T8w(i,kts,j) / ( p8w(i,k,j) / p1000mb )**( R_d / Cp )
2532       dthrdn(i,k,j) = ( theta(i,k+1,j) - thetasfc ) / tmpdz
2533     END DO
2534     END DO
2535
2536     k = ktf
2537     DO j = j_start, j_end
2538     DO i = i_start, i_end
2539       tmpdz         = 1.0 / rdz(i,k,j) + 0.5 / rdzw(i,k,j)
2540       thetatop      = T8w(i,kde,j) / ( p8w(i,kde,j) / p1000mb )**( R_d / Cp )
2541       dthrdn(i,k,j) = ( thetatop - theta(i,k-1,j) ) / tmpdz
2542     END DO
2543     END DO
2544
2545     DO j = j_start, j_end
2546     DO k = kts,ktf
2547     DO i = i_start, i_end
2548       qtke(i,k,j) = sqrt(2.0*tke(i,k,j))
2549     ENDDO
2550     ENDDO
2551     ENDDO
2552
2553     DO j = j_start, j_end
2554     DO i = i_start, i_end
2555       elt(i,j) = 1.0e-5
2556       vsc(i,j) = 1.0e-5
2557     ENDDO
2558     ENDDO
2559
2560     DO j = j_start, j_end
2561     DO k = kts, ktf
2562     DO i = i_start, i_end
2563       qdz      = qtke(i,k,j)*(1.0/rdzw(i,k,j))
2564       elt(i,j) = elt(i,j) + qdz*za(i,k,j)
2565       vsc(i,j) = vsc(i,j) + qdz
2566     ENDDO
2567     ENDDO
2568     ENDDO
2569
2570     DO j = j_start, j_end
2571     DO i = i_start, i_end
2572       elt(i,j) = alp1*elt(i,j)/vsc(i,j)
2573     ENDDO
2574     ENDDO
2575
2576     hflux: SELECT CASE( config_flags%isfflx )
2577     CASE (0,2) ! with fixed surface heat flux given in the namelist
2578      heat_flux = config_flags%tke_heat_flux  ! constant heat flux value
2579      DO j = j_start, j_end
2580      DO i = i_start, i_end
2581         cpm = cp * (1. + 0.8 * moist(i,kts,j,P_QV))
2582         hfx(i,j)= heat_flux*cpm*rho(i,1,j)
2583      ENDDO
2584      ENDDO
2585
2586     CASE (1) ! use surface heat flux computed from surface routine
2587      DO j = j_start, j_end
2588      DO i = i_start, i_end
2589         cpm = cp * (1. + 0.8 * moist(i,kts,j,P_QV))
2590         heat_flux = hfx(i,j)/cpm/rho(i,1,j)
2591      ENDDO
2592      ENDDO
2593
2594     CASE DEFAULT
2595      CALL wrf_error_fatal( 'isfflx value invalid for diff_opt=2' )
2596     END SELECT hflux
2597
2598     DO j = j_start,j_end
2599     DO i = i_start,i_end
2600        cpm        = cp  * (1. + 0.8*moist(i,1,j,P_QV))
2601        sflux(i,j) = (hfx(i,j)/cpm)/rho(i,1,j)
2602     ENDDO
2603     ENDDO
2604
2605 !-------Length scale limited by bouyancy effect-----
2606     gtr  = g/300.
2607     DO j = j_start, j_end
2608     DO k = kts, ktf
2609     DO i = i_start, i_end
2610        IF( dthrdn(i,k,j).GT.0.0 ) THEN
2611         N2 = gtr*dthrdn(i,k,j)
2612         qcv = (gtr*MAX(sflux(i,j),0.0)*elt(i,j))**(1.0/3.0)
2613         elb(i,k,j) = qtke(i,k,j)/sqrt(N2)*(alp2 + alp3*sqrt(qcv/(elt(i,j)*sqrt(N2))))
2614         elf(i,k,j) = alp2*qtke(i,k,j)/sqrt(N2)
2615        ELSE
2616         elb(i,k,j) = 1.0e10
2617         elf(i,k,j) = elb(i,k,j)
2618        ENDIF
2619     ENDDO
2620     ENDDO
2621     ENDDO
2622
2623 !------Length scale in the surface layer-------
2624     DO j = j_start, j_end
2625     DO k = kts, ktf
2626     DO i = i_start,i_end
2627        IF (rmol(i,j) .GT. 0.0) THEN
2628          els(i,k,j) = karman*za(i,k,j)/(1.0+2.7*min(za(i,k,j)*rmol(i,j),1.0))
2629        ELSE
2630          coe = (1.0 - alp4*za(i,k,j)*rmol(i,j))**0.2
2631          els(i,k,j) = 1.0*karman*za(i,k,j)*coe
2632        ENDIF
2633     ENDDO
2634     ENDDO
2635     ENDDO
2636
2637 !----Harmonic averaging of mixing length scales-----
2638     DO j = j_start, j_end
2639     DO k = kts, ktf
2640     DO i = i_start, i_end
2641          dlk(i,k,j) = MIN(elb(i,k,j)/(elb(i,k,j)/elt(i,j)+elb(i,k,j)/els(i,k,j)+1.0),elf(i,k,j))
2642     ENDDO
2643     ENDDO
2644     ENDDO
2645
2646 !add blending to use BouLac mixing length in free atmos;
2647 !defined relative to the PBLH (zi) + transition layer (h1)
2648     DO j = j_start, j_end
2649     DO k = kts, ktf
2650     DO i = i_start, i_end
2651          zi2=MAX(hpbl(i,j),minzi)
2652          h1=MAX(0.3*zi2,mindz)
2653          h1=MIN(h1,maxdz)         ! 1/2 transition layer depth
2654          h2=h1/2.0                ! 1/4 transition layer depth
2655
2656          wt=.5*TANH((za(i,k,j) - (zi2+h1))/h2) + .5
2657          dlk(i,k,j) = dlk(i,k,j)*(1.-wt) + 0.4*elmin(i,k,j)*wt
2658     ENDDO
2659     ENDDO
2660     ENDDO
2661
2662     END SUBROUTINE meso_length_scale
2663 !=======================================================================
2664 !=======================================================================
2665     SUBROUTINE free_atmos_length(config_flags,dx,dy,rdzw,rdz,tke,theta,elmin,    &
2666                                  hfx,qfx,moist,n_moist,                          &
2667                                  ids, ide, jds, jde, kds, kde,                   &
2668                                  ims, ime, jms, jme, kms, kme,                   &
2669                                  its, ite, jts, jte, kts, kte )
2670 !
2671 ! NOTE: This subroutine is based on the BouLac PBL to calculate mixing length
2672 !       in the free atmosphere and modified for integration into the 3DTKE scheme.
2673 !       Modified by X.Zhang
2674 !
2675 !  dlu = the distance a parcel can be lifted upwards give a finite
2676 !        amount of TKE.
2677 !  dld = the distance a parcel can be displaced downwards given a
2678 !        finite amount of TKE.
2679
2680 ! compute the length scales up and down
2681
2682     IMPLICIT NONE
2683
2684     TYPE( grid_config_rec_type ), INTENT( IN )  &
2685     ::  config_flags
2686
2687     INTEGER,                      INTENT( IN )  &
2688     ::  ids, ide, jds, jde, kds, kde,           &
2689         ims, ime, jms, jme, kms, kme,           &
2690         its, ite, jts, jte, kts, kte
2691
2692     INTEGER,                      INTENT( IN )  &
2693     ::  n_moist
2694
2695     REAL,                         INTENT( IN )  &
2696     ::  dx,dy
2697
2698     REAL, DIMENSION( ims:ime, kms:kme, jms:jme, n_moist ), INTENT( INOUT ) &
2699     ::  moist
2700
2701     REAL, DIMENSION( ims:ime, kms:kme, jms:jme ),          INTENT( IN )    &
2702     ::  tke, rdzw, rdz
2703
2704     REAL, DIMENSION( ims:ime, kms:kme, jms:jme ),          INTENT( IN )    &
2705     ::  theta
2706
2707     REAL, DIMENSION( ims:ime, kms:kme, jms:jme ),          INTENT( INOUT ) &
2708     ::  elmin
2709
2710     REAL, DIMENSION( ims:ime, jms:jme ),                   INTENT( INOUT ) &
2711     ::  hfx,qfx
2712
2713 !Local variables
2714     REAL, DIMENSION( its:ite, kts:kte, jts:jte )  :: zfull,za
2715
2716     REAL, DIMENSION( its:ite, kts:kte, jts:jte )  :: dlg,dlu,dld
2717
2718     INTEGER   :: izz, found, i, k, j
2719
2720     REAL      :: dzt,zup,beta,zup_inf,bbb,tl,zdo,zdo_sup,zzz
2721
2722     INTEGER   :: i_start, i_end, ktf, j_start, j_end
2723
2724     ktf     = MIN( kte, kde-1 )
2725     i_start = its
2726     i_end   = MIN( ite, ide-1 )
2727     j_start = jts
2728     j_end   = MIN( jte, jde-1 )
2729
2730     IF ( config_flags%open_xs .OR. config_flags%specified .OR. &
2731          config_flags%nested) i_start = MAX( ids+1, its )
2732     IF ( config_flags%open_xe .OR. config_flags%specified .OR. &
2733          config_flags%nested) i_end   = MIN( ide-2, ite )
2734     IF ( config_flags%open_ys .OR. config_flags%specified .OR. &
2735          config_flags%nested) j_start = MAX( jds+1, jts )
2736     IF ( config_flags%open_ye .OR. config_flags%specified .OR. &
2737          config_flags%nested) j_end   = MIN( jde-2, jte)
2738     IF ( config_flags%periodic_x ) i_start = its
2739     IF ( config_flags%periodic_x ) i_end = MIN( ite, ide-1 )
2740
2741     DO j = j_start, j_end
2742     DO i = i_start, i_end
2743          zfull(i,1,j)= 0.
2744     ENDDO
2745     ENDDO
2746
2747     DO j = j_start, j_end
2748     DO k = kts, ktf
2749     DO i = i_start, i_end
2750          zfull(i,k+1,j) = 1.0/rdzw(i,k,j) + zfull(i,k,j)
2751     ENDDO
2752     ENDDO
2753     ENDDO
2754
2755     DO j = j_start, j_end
2756     DO k = kts, ktf
2757     DO i = i_start, i_end
2758          za(i,k,j) = (zfull(i,k,j) + zfull(i,k+1,j))/2.0
2759     ENDDO
2760     ENDDO
2761     ENDDO
2762
2763     DO j = j_start, j_end
2764     DO k = kts, ktf
2765     DO i = i_start, i_end
2766        elmin(i,k,j) = 0.0
2767     ENDDO
2768     ENDDO
2769     ENDDO
2770
2771     DO j = j_start, j_end
2772     DO k = kts, ktf
2773     DO i = i_start, i_end
2774           zup=0.
2775           dlu(i,k,j) = zfull(i,ktf+1,j) - zfull(i,k,j) - 1.0/rdzw(i,k,j)/2.
2776           zzz=0.
2777           zup_inf=0.
2778           beta=g/300. !th(i,1,j)      !Buoyancy coefficient
2779
2780           IF (k.LT.ktf) THEN
2781             found = 0
2782             izz = k
2783             DO WHILE (found.EQ.0)
2784               IF (izz .LT. ktf) THEN
2785                  dzt = (1.0/rdzw(i,izz+1,j) + 1.0/rdzw(i,izz,j))/2.
2786                  zup = zup - beta * theta(i,k,j) * dzt
2787                  zup = zup + beta * (theta(i,izz+1,j) + theta(i,izz,j)) * dzt/2.
2788                  zzz = zzz + dzt
2789                  IF (tke(i,k,j).LT.zup.and.tke(i,k,j).GE.zup_inf) THEN
2790                     bbb=(theta(i,izz+1,j)-theta(i,izz,j))/dzt
2791                     IF(bbb.NE.0) THEN
2792                        tl = (-beta * (theta(i,izz,j) - theta(i,k,j))               &
2793                           + sqrt(max(0.,(beta*(theta(i,izz,j)-theta(i,k,j)))**2.   &
2794                           + 2.*bbb*beta*(tke(i,k,j) - zup_inf))))/bbb/beta
2795                     ELSE
2796                        IF (theta(i,izz,j) .NE. theta(i,k,j)) THEN
2797                           tl = (tke(i,k,j) - zup_inf)/(beta*(theta(i,izz,j) - theta(i,k,j)))
2798                        ELSE
2799                           tl = 0.
2800                        ENDIF
2801                     ENDIF
2802                    dlu(i,k,j) = zzz - dzt + tl
2803                    found      = 1
2804                  ENDIF
2805                  zup_inf = zup
2806                  izz = izz + 1
2807               ELSE
2808                 found = 1
2809               ENDIF
2810             ENDDO
2811           ENDIF
2812
2813           zdo     = 0.
2814           zdo_sup = 0.
2815           dld(i,k,j) = zfull(i,k,j) + 1.0/rdzw(i,k,j)/2.
2816           zzz = 0.
2817           IF (k .GT. kts) THEN
2818               found = 0
2819               izz   = k
2820               DO WHILE (found.EQ.0)
2821                   IF (izz .GT. kts) THEN
2822                      dzt = (1.0/rdzw(i,izz-1,j) + 1.0/rdzw(i,izz,j))/2.
2823                      zdo = zdo + beta*theta(i,k,j)*dzt
2824                      zdo = zdo - beta*(theta(i,izz-1,j) + theta(i,izz,j))*dzt/2.
2825                      zzz = zzz + dzt
2826                      IF(tke(i,k,j) .LT. zdo .and. tke(i,k,j).GE.zdo_sup) THEN
2827                         bbb = (theta(i,izz,j) - theta(i,izz-1,j))/dzt
2828                            IF(bbb.NE.0.) THEN
2829                               tl = (beta*(theta(i,izz,j) - theta(i,k,j))    &
2830                                  + sqrt(max(0.,(beta*(theta(i,izz,j) - theta(i,k,j)))**2. &
2831                                  + 2.*bbb*beta*(tke(i,k,j) - zdo_sup))))/bbb/beta
2832                            ELSE
2833                               IF(theta(i,izz,j).NE.theta(i,k,j)) THEN
2834                                  tl = (tke(i,k,j) - zdo_sup)/(beta*(theta(i,izz,j) - theta(i,k,j)))
2835                               ELSE
2836                                  tl = 0.
2837                               ENDIF
2838                            ENDIF
2839
2840                         dld(i,k,j) = zzz - dzt + tl
2841                         found      = 1
2842                      ENDIF
2843                      zdo_sup = zdo
2844                      izz     = izz - 1
2845                   ELSE
2846                      found = 1
2847                   ENDIF
2848               ENDDO
2849           ENDIF
2850
2851           dlg(i,k,j) = (zfull(i,k,j)+zfull(i,k+1,j))/2.0
2852           dld(i,k,j) = min(dld(i,k,j),dlg(i,k,j))
2853
2854           elmin(i,k,j) = min(dlu(i,k,j),dld(i,k,j))
2855           elmin(i,k,j) = elmin(i,k,j)/(1. + (elmin(i,k,j)/2000.))
2856     ENDDO
2857     ENDDO
2858     ENDDO
2859
2860     END SUBROUTINE free_atmos_length
2861 !=======================================================================
2862 !=======================================================================
2863
2864 SUBROUTINE horizontal_diffusion_2 ( rt_tendf, ru_tendf, rv_tendf, rw_tendf,    &
2865                                     tke_tendf,                                 &
2866                                     moist_tendf, n_moist,                      &
2867                                     chem_tendf, n_chem,                        &
2868                                     scalar_tendf, n_scalar,                    &
2869                                     tracer_tendf, n_tracer,                    &
2870                                     thp, theta, tke, config_flags,             &
2871                                     defor11, defor22, defor12,                 &
2872                                     defor13, defor23,                          &
2873                                     nba_mij, n_nba_mij,                        &
2874                                     div,                                       &
2875                                     moist, chem, scalar,tracer,                &
2876                                     msfux, msfuy, msfvx, msfvy,                &
2877                                     msftx, msfty, xkmh, xkmv, xkhh, km_opt,    &
2878                                     rdx, rdy, rdz, rdzw, fnm, fnp,             &
2879                                     cf1, cf2, cf3, zx, zy, dn, dnw, rho,       &
2880                                     ids, ide, jds, jde, kds, kde,              &
2881                                     ims, ime, jms, jme, kms, kme,              &
2882                                     its, ite, jts, jte, kts, kte               )
2883
2884 !-----------------------------------------------------------------------
2885 ! Begin declarations.
2886
2887    IMPLICIT NONE
2888
2889    TYPE(grid_config_rec_type), INTENT(IN   ) :: config_flags
2890
2891    INTEGER ,        INTENT(IN   ) ::        ids, ide, jds, jde, kds, kde, &
2892                                             ims, ime, jms, jme, kms, kme, &
2893                                             its, ite, jts, jte, kts, kte
2894
2895    INTEGER ,        INTENT(IN   ) ::        n_moist,n_chem,n_scalar,n_tracer,km_opt
2896
2897    REAL ,           INTENT(IN   ) ::        cf1, cf2, cf3
2898
2899    REAL , DIMENSION( kms:kme ) ,                 INTENT(IN   ) ::    fnm
2900    REAL , DIMENSION( kms:kme ) ,                 INTENT(IN   ) ::    fnp
2901    REAL , DIMENSION( kms:kme ) ,                 INTENT(IN   ) ::    dnw
2902    REAL , DIMENSION( kms:kme ) ,                 INTENT(IN   ) ::    dn
2903
2904    REAL , DIMENSION( ims:ime, jms:jme) ,         INTENT(IN   ) ::   msfux, &
2905                                                                     msfuy, &
2906                                                                     msfvx, &
2907                                                                     msfvy, &
2908                                                                     msftx, &
2909                                                                     msfty
2910
2911    REAL , DIMENSION( ims:ime, kms:kme, jms:jme), INTENT(INOUT) ::rt_tendf,&
2912                                                                  ru_tendf,&
2913                                                                  rv_tendf,&
2914                                                                  rw_tendf,&
2915                                                                 tke_tendf
2916
2917    REAL , DIMENSION( ims:ime, kms:kme, jms:jme, n_moist),                 &
2918           INTENT(INOUT) ::                                    moist_tendf
2919
2920    REAL , DIMENSION( ims:ime, kms:kme, jms:jme, n_chem),                  &
2921           INTENT(INOUT) ::                                     chem_tendf
2922
2923    REAL , DIMENSION( ims:ime, kms:kme, jms:jme, n_scalar),                &
2924           INTENT(INOUT) ::                                   scalar_tendf
2925
2926    REAL , DIMENSION( ims:ime, kms:kme, jms:jme, n_tracer),                &
2927           INTENT(INOUT) ::                                   tracer_tendf
2928
2929    REAL , DIMENSION( ims:ime, kms:kme, jms:jme, n_moist),                 &
2930           INTENT(IN   ) ::                                          moist
2931
2932    REAL , DIMENSION( ims:ime, kms:kme, jms:jme, n_chem),                  &
2933           INTENT(IN   ) ::                                          chem
2934
2935    REAL , DIMENSION( ims:ime, kms:kme, jms:jme, n_scalar) ,               &
2936           INTENT(IN   ) ::                                         scalar
2937
2938    REAL , DIMENSION( ims:ime, kms:kme, jms:jme, n_tracer) ,               &
2939           INTENT(IN   ) ::                                         tracer
2940
2941    REAL , DIMENSION( ims:ime, kms:kme, jms:jme), INTENT(IN   ) ::defor11, &
2942                                                                  defor22, &
2943                                                                  defor12, &
2944                                                                  defor13, &
2945                                                                  defor23, &
2946                                                                      div, &
2947                                                                     xkmh, &
2948                                                                     xkmv, &
2949                                                                     xkhh, &
2950                                                                       zx, &
2951                                                                       zy, &
2952                                                                    theta, &
2953                                                                      thp, &
2954                                                                      tke, &
2955                                                                      rdz, &
2956                                                                     rdzw, &
2957                                                                      rho
2958
2959
2960    REAL ,                                        INTENT(IN   ) ::    rdx, &
2961                                                                      rdy
2962    INTEGER, INTENT(  IN ) :: n_nba_mij
2963
2964    REAL , DIMENSION(ims:ime, kms:kme, jms:jme, n_nba_mij), INTENT(INOUT) &
2965    :: nba_mij
2966
2967 ! LOCAL VARS
2968
2969    INTEGER :: im, ic, is
2970
2971 !  REAL , DIMENSION(its-1:ite+1, kts:kte, jts-1:jte+1)       ::     xkhh
2972
2973 ! End declarations.
2974 !-----------------------------------------------------------------------
2975
2976 !-----------------------------------------------------------------------
2977 ! Call diffusion subroutines.
2978
2979     CALL horizontal_diffusion_u_2( ru_tendf, config_flags,                 &
2980                                    defor11, defor12, div,                  &
2981                                    nba_mij, n_nba_mij,                     &
2982                                    tke(ims,kms,jms),                       &
2983                                    msfux, msfuy, xkmh, rdx, rdy, fnm, fnp, &
2984                                    dnw, zx, zy, rdzw, rho,                 &
2985                                    ids, ide, jds, jde, kds, kde,           &
2986                                    ims, ime, jms, jme, kms, kme,           &
2987                                    its, ite, jts, jte, kts, kte           )
2988
2989     CALL horizontal_diffusion_v_2( rv_tendf, config_flags,                 &
2990                                    defor12, defor22, div,                  &
2991                                    nba_mij, n_nba_mij,                     &
2992                                    tke(ims,kms,jms),                       &
2993                                    msfvx, msfvy, xkmh, rdx, rdy, fnm, fnp, &
2994                                    dnw, zx, zy, rdzw, rho,                 &
2995                                    ids, ide, jds, jde, kds, kde,           &
2996                                    ims, ime, jms, jme, kms, kme,           &
2997                                    its, ite, jts, jte, kts, kte           )
2998
2999     CALL horizontal_diffusion_w_2( rw_tendf, config_flags,                 &
3000                                    defor13, defor23, div,                  &
3001                                    nba_mij, n_nba_mij,                     &
3002                                    tke(ims,kms,jms),                       &
3003                                    msftx, msfty, xkmv, rdx, rdy, fnm, fnp, &
3004                                    dn, zx, zy, rdz, rho,                   &
3005                                    ids, ide, jds, jde, kds, kde,           &
3006                                    ims, ime, jms, jme, kms, kme,           &
3007                                    its, ite, jts, jte, kts, kte           )
3008
3009     CALL horizontal_diffusion_s  ( rt_tendf, config_flags,                 &
3010                                    thp,                                    &
3011                                    msftx, msfty, msfux, msfuy,             &
3012                                    msfvx, msfvy, xkhh, rdx, rdy,           &
3013                                    fnm, fnp, cf1, cf2, cf3,                &
3014                                    zx, zy, rdz, rdzw, dnw, dn, rho,        &
3015                                    .false.,                                &
3016                                    ids, ide, jds, jde, kds, kde,           &
3017                                    ims, ime, jms, jme, kms, kme,           &
3018                                    its, ite, jts, jte, kts, kte           )
3019
3020     IF ( ((km_opt .eq. 2) .and. (.not.config_flags%tke_mix2_off))          & !XZ
3021         .or. (km_opt .eq. 5) )                                             & !XZ
3022     CALL horizontal_diffusion_s  ( tke_tendf(ims,kms,jms),                 &
3023                                    config_flags,                           &
3024                                    tke(ims,kms,jms),                       &
3025                                    msftx, msfty, msfux, msfuy,             &
3026                                    msfvx, msfvy, xkhh, rdx, rdy,           &
3027                                    fnm, fnp, cf1, cf2, cf3,                &
3028                                    zx, zy, rdz, rdzw, dnw, dn, rho,        &
3029                                    .true.,                                 &
3030                                    ids, ide, jds, jde, kds, kde,           &
3031                                    ims, ime, jms, jme, kms, kme,           &
3032                                    its, ite, jts, jte, kts, kte           )
3033
3034     IF ((n_moist .ge. PARAM_FIRST_SCALAR) .and. (.not.config_flags%moist_mix2_off)) THEN
3035
3036       moist_loop: do im = PARAM_FIRST_SCALAR, n_moist
3037
3038           CALL horizontal_diffusion_s( moist_tendf(ims,kms,jms,im),       &
3039                                        config_flags,                      &
3040                                        moist(ims,kms,jms,im),             &
3041                                        msftx, msfty, msfux, msfuy,        &
3042                                        msfvx, msfvy, xkhh, rdx, rdy,      &
3043                                        fnm, fnp, cf1, cf2, cf3,           &
3044                                        zx, zy, rdz, rdzw, dnw, dn, rho,   &
3045                                        .false.,                           &
3046                                        ids, ide, jds, jde, kds, kde,      &
3047                                        ims, ime, jms, jme, kms, kme,      &
3048                                        its, ite, jts, jte, kts, kte      )
3049
3050       ENDDO moist_loop
3051
3052     ENDIF
3053
3054     IF ((n_chem .ge. PARAM_FIRST_SCALAR) .and. (.not.config_flags%chem_mix2_off)) THEN
3055
3056       chem_loop: do ic = PARAM_FIRST_SCALAR, n_chem
3057
3058         CALL horizontal_diffusion_s( chem_tendf(ims,kms,jms,ic),     &
3059                                      config_flags,                   &
3060                                      chem(ims,kms,jms,ic),           &
3061                                      msftx, msfty, msfux, msfuy,     &
3062                                      msfvx, msfvy, xkhh, rdx, rdy,   &
3063                                      fnm, fnp, cf1, cf2, cf3,        &
3064                                      zx, zy, rdz, rdzw, dnw, dn, rho,&
3065                                      .false.,                        &
3066                                      ids, ide, jds, jde, kds, kde,   &
3067                                      ims, ime, jms, jme, kms, kme,   &
3068                                      its, ite, jts, jte, kts, kte    )
3069
3070       ENDDO chem_loop
3071
3072     ENDIF
3073
3074     IF ((n_tracer .ge. PARAM_FIRST_SCALAR) .and. (.not.config_flags%tracer_mix2_off)) THEN
3075
3076       tracer_loop: do ic = PARAM_FIRST_SCALAR, n_tracer
3077
3078         CALL horizontal_diffusion_s( tracer_tendf(ims,kms,jms,ic),     &
3079                                      config_flags,                     &
3080                                      tracer(ims,kms,jms,ic),           &
3081                                      msftx, msfty, msfux, msfuy,       &
3082                                      msfvx, msfvy, xkhh, rdx, rdy,     &
3083                                      fnm, fnp, cf1, cf2, cf3,          &
3084                                      zx, zy, rdz, rdzw, dnw, dn, rho,  &
3085                                      .false.,                          &
3086                                      ids, ide, jds, jde, kds, kde,     &
3087                                      ims, ime, jms, jme, kms, kme,     &
3088                                      its, ite, jts, jte, kts, kte     )
3089
3090       ENDDO tracer_loop
3091
3092     ENDIF
3093     IF ((n_scalar .ge. PARAM_FIRST_SCALAR) .and. (.not.config_flags%scalar_mix2_off)) THEN
3094
3095       scalar_loop: do is = PARAM_FIRST_SCALAR, n_scalar
3096
3097         CALL horizontal_diffusion_s( scalar_tendf(ims,kms,jms,is),     &
3098                                      config_flags,                     &
3099                                      scalar(ims,kms,jms,is),           &
3100                                      msftx, msfty, msfux, msfuy,       &
3101                                      msfvx, msfvy, xkhh, rdx, rdy,     &
3102                                      fnm, fnp, cf1, cf2, cf3,          &
3103                                      zx, zy, rdz, rdzw, dnw, dn, rho,  &
3104                                      .false.,                          &
3105                                      ids, ide, jds, jde, kds, kde,     &
3106                                      ims, ime, jms, jme, kms, kme,     &
3107                                      its, ite, jts, jte, kts, kte     )
3108
3109       ENDDO scalar_loop
3110
3111     ENDIF
3112
3113     END SUBROUTINE horizontal_diffusion_2
3114
3115 !=======================================================================
3116 !=======================================================================
3117
3118 SUBROUTINE horizontal_diffusion_u_2( tendency, config_flags,              &
3119                                      defor11, defor12, div,               &
3120                                      nba_mij, n_nba_mij,                  &
3121                                      tke,                                 &
3122                                      msfux, msfuy,                        &
3123                                      xkmh, rdx, rdy, fnm, fnp,            &
3124                                      dnw, zx, zy, rdzw, rho,              &
3125                                      ids, ide, jds, jde, kds, kde,        &
3126                                      ims, ime, jms, jme, kms, kme,        &
3127                                      its, ite, jts, jte, kts, kte        )
3128
3129 !-----------------------------------------------------------------------
3130 ! Begin declarations.
3131
3132    IMPLICIT NONE
3133
3134    TYPE(grid_config_rec_type), INTENT(IN   ) :: config_flags
3135
3136    INTEGER ,        INTENT(IN   ) ::        ids, ide, jds, jde, kds, kde, &
3137                                             ims, ime, jms, jme, kms, kme, &
3138                                             its, ite, jts, jte, kts, kte
3139
3140    REAL , DIMENSION( kms:kme ) ,                 INTENT(IN   ) ::    fnm
3141    REAL , DIMENSION( kms:kme ) ,                 INTENT(IN   ) ::    fnp
3142    REAL , DIMENSION( kms:kme ) ,                 INTENT(IN   ) ::    dnw
3143
3144    REAL , DIMENSION( ims:ime, jms:jme) ,         INTENT(IN   ) ::  msfux, &
3145                                                                    msfuy
3146
3147    REAL , DIMENSION( ims:ime, kms:kme, jms:jme), INTENT(INOUT) ::tendency
3148
3149    REAL , DIMENSION( ims:ime, kms:kme, jms:jme), INTENT(IN   ) ::   rdzw, &
3150                                                                      rho
3151
3152    REAL , DIMENSION( ims:ime, kms:kme, jms:jme), INTENT(IN   ) ::defor11, &
3153                                                                  defor12, &
3154                                                                      div, &
3155                                                                      tke, &
3156                                                                     xkmh, &
3157                                                                       zx, &
3158                                                                       zy
3159
3160    INTEGER, INTENT(  IN ) :: n_nba_mij
3161
3162    REAL , DIMENSION(ims:ime, kms:kme, jms:jme, n_nba_mij),  INTENT(INOUT) &
3163    :: nba_mij
3164
3165    REAL ,                                        INTENT(IN   ) ::    rdx, &
3166                                                                      rdy
3167 ! Local data
3168
3169    INTEGER :: i, j, k, ktf
3170
3171    INTEGER :: i_start, i_end, j_start, j_end
3172    INTEGER :: is_ext,ie_ext,js_ext,je_ext
3173
3174    REAL , DIMENSION( its-1:ite+1, kts:kte, jts-1:jte+1)    :: titau1avg, &
3175                                                               titau2avg, &
3176                                                                  titau1, &
3177                                                                  titau2, &
3178                                                                  xkxavg, &
3179                                                                   rravg, &
3180                                                                 zy_at_u, &
3181                                                                 zx_at_u
3182
3183 ! new
3184 !                                                                 zxavg, &
3185 !                                                                 zyavg
3186    REAL :: mrdx, mrdy, rcoup
3187
3188    REAL :: tmpzy, tmpzeta_z
3189
3190    REAL :: tmpdz
3191
3192    REAL :: term1, term2, term3
3193
3194 ! End declarations.
3195 !-----------------------------------------------------------------------
3196
3197    ktf=MIN(kte,kde-1)
3198
3199 !-----------------------------------------------------------------------
3200 ! u :   p (.), u(|), w(-)
3201 !
3202 !       p  u  p  u                                  u     u
3203 !
3204 ! p  |  .  |  .  |  .  |   k+1                |  .  |  .  |  .  |   k+1
3205 !
3206 ! w     - 13  -     -      k+1                     13               k+1
3207 !
3208 ! p  |  11 O 11  |  .  |   k                  |  12 O 12  |  .  |   k
3209 !
3210 ! w     - 13  -     -      k                       13               k
3211 !
3212 ! p  |  .  |  .  |  .  |   k-1                |  .  |  .  |  .  |   k-1
3213 !
3214 !      i-1 i  i i+1                          j-1 j  j j+1 j+1
3215 !
3216
3217    i_start = its
3218    i_end   = ite
3219    j_start = jts
3220    j_end   = MIN(jte,jde-1)
3221
3222    IF ( config_flags%open_xs .or. config_flags%specified .or. &
3223         config_flags%nested) i_start = MAX(ids+1,its)
3224    IF ( config_flags%open_xe .or. config_flags%specified .or. &
3225         config_flags%nested) i_end   = MIN(ide-1,ite)
3226    IF ( config_flags%open_ys .or. config_flags%specified .or. &
3227         config_flags%nested) j_start = MAX(jds+1,jts)
3228    IF ( config_flags%open_ye .or. config_flags%specified .or. &
3229         config_flags%nested) j_end   = MIN(jde-2,jte)
3230       IF ( config_flags%periodic_x ) i_start = its
3231       IF ( config_flags%periodic_x ) i_end = ite
3232
3233 ! titau1 = titau11
3234    is_ext=1
3235    ie_ext=0
3236    js_ext=0
3237    je_ext=0
3238    CALL cal_titau_11_22_33( config_flags, titau1,            &
3239                             tke, xkmh, defor11,              &
3240                             nba_mij(ims,kms,jms,P_m11), rho, &
3241                             is_ext, ie_ext, js_ext, je_ext,  &
3242                             ids, ide, jds, jde, kds, kde,    &
3243                             ims, ime, jms, jme, kms, kme,    &
3244                             its, ite, jts, jte, kts, kte     )
3245
3246 ! titau2 = titau12
3247    is_ext=0
3248    ie_ext=0
3249    js_ext=0
3250    je_ext=1
3251    CALL cal_titau_12_21( config_flags, titau2,            &
3252                          xkmh, defor12,                   &
3253                          nba_mij(ims,kms,jms,P_m12), rho, &
3254                          is_ext, ie_ext, js_ext, je_ext,  &
3255                          ids, ide, jds, jde, kds, kde,    &
3256                          ims, ime, jms, jme, kms, kme,    &
3257                          its, ite, jts, jte, kts, kte     )
3258
3259 ! titau1avg = titau11avg
3260 ! titau2avg = titau12avg
3261
3262    DO j = j_start, j_end
3263    DO k = kts+1,ktf
3264    DO i = i_start, i_end
3265       titau1avg(i,k,j)=0.5*(fnm(k)*(titau1(i-1,k  ,j)+titau1(i,k  ,j))+ &
3266                             fnp(k)*(titau1(i-1,k-1,j)+titau1(i,k-1,j)))
3267       titau2avg(i,k,j)=0.5*(fnm(k)*(titau2(i,k  ,j+1)+titau2(i,k  ,j))+ &
3268                             fnp(k)*(titau2(i,k-1,j+1)+titau2(i,k-1,j)))
3269 !     tmpzy = 0.25*( zy(i-1,k,j  )+zy(i,k,j  )+ &
3270 !                    zy(i-1,k,j+1)+zy(i,k,j+1)  )
3271 !      tmpzeta_z = 0.5*(zeta_z(i,j)+zeta_z(i-1,j))
3272 !      titau1avg(i,k,j)=titau1avg(i,k,j)*zx(i,k,j)*tmpzeta_z
3273 !      titau2avg(i,k,j)=titau2avg(i,k,j)*tmpzy    *tmpzeta_z
3274
3275       zx_at_u(i, k, j) = 0.5 * (zx(i, k, j) + zx(i, k + 1 , j))
3276       zy_at_u(i, k, j) = 0.125 * (zy(i - 1, k, j) + zy(i, k, j) + &
3277           zy(i - 1, k, j + 1) + zy(i, k, j + 1) + zy(i - 1, k + 1, j) + &
3278           zy(i, k + 1, j) + zy(i - 1, k + 1, j + 1) + zy(i, k + 1, j + 1))
3279
3280 !     titau1avg(i,k,j)=titau1avg(i,k,j)*zx(i,k,j)
3281 !     titau2avg(i,k,j)=titau2avg(i,k,j)*tmpzy
3282
3283    ENDDO
3284    ENDDO
3285    ENDDO
3286 !
3287    DO j = j_start, j_end
3288    DO i = i_start, i_end
3289       titau1avg(i,kts,j)=0.
3290       titau1avg(i,ktf+1,j)=0.
3291       titau2avg(i,kts,j)=0.
3292       titau2avg(i,ktf+1,j)=0.
3293       zx_at_u(i, kts, j) = 0.5 * (zx(i, kts, j) + zx(i, kts + 1 , j))
3294       zy_at_u(i, kts, j) = 0.125 * (zy(i - 1, kts, j) + zy(i, kts, j) + &
3295           zy(i - 1, kts, j + 1) + zy(i, kts, j + 1) + zy(i - 1, kts + 1, j) + &
3296           zy(i, kts + 1, j) + zy(i - 1, kts + 1, j + 1) + zy(i, kts + 1, j + 1))
3297    ENDDO
3298    ENDDO
3299 !
3300    DO j = j_start, j_end
3301    DO k = kts,ktf
3302    DO i = i_start, i_end
3303
3304       mrdx=msfux(i,j)*rdx
3305       mrdy=msfuy(i,j)*rdy
3306
3307       tmpdz = (1./rdzw(i,k,j)+1./rdzw(i-1,k,j))/2.
3308       tendency(i,k,j)=tendency(i,k,j) +  g*tmpdz/dnw(k) *             &
3309            (mrdx*(titau1(i,k,j  ) - titau1(i-1,k,j)) +                &
3310             mrdy*(titau2(i,k,j+1) - titau2(i  ,k,j)) -                &
3311             msfux(i,j)*zx_at_u(i,k,j)*(titau1avg(i,k+1,j)-titau1avg(i,k,j)) / tmpdz - &
3312             msfuy(i,j)*zy_at_u(i,k,j)*(titau2avg(i,k+1,j)-titau2avg(i,k,j)) / tmpdz   &
3313                                                                   )
3314    ENDDO
3315    ENDDO
3316    ENDDO
3317
3318 END SUBROUTINE horizontal_diffusion_u_2
3319
3320 !=======================================================================
3321 !=======================================================================
3322
3323 SUBROUTINE horizontal_diffusion_v_2( tendency, config_flags,              &
3324                                      defor12, defor22, div,               &
3325                                      nba_mij, n_nba_mij,                  &
3326                                      tke,                                 &
3327                                      msfvx, msfvy,                        &
3328                                      xkmh, rdx, rdy, fnm, fnp,            &
3329                                      dnw, zx, zy, rdzw, rho,              &
3330                                      ids, ide, jds, jde, kds, kde,        &
3331                                      ims, ime, jms, jme, kms, kme,        &
3332                                      its, ite, jts, jte, kts, kte        )
3333
3334 !-----------------------------------------------------------------------
3335 ! Begin declarations.
3336
3337    IMPLICIT NONE
3338
3339    TYPE(grid_config_rec_type), INTENT(IN   ) :: config_flags
3340
3341    INTEGER ,        INTENT(IN   ) ::        ids, ide, jds, jde, kds, kde, &
3342                                             ims, ime, jms, jme, kms, kme, &
3343                                             its, ite, jts, jte, kts, kte
3344
3345    REAL , DIMENSION( kms:kme ) ,                 INTENT(IN   ) ::    fnm
3346    REAL , DIMENSION( kms:kme ) ,                 INTENT(IN   ) ::    fnp
3347    REAL , DIMENSION( kms:kme ) ,                 INTENT(IN   ) ::    dnw
3348
3349    REAL , DIMENSION( ims:ime, jms:jme) ,         INTENT(IN   ) ::  msfvx, &
3350                                                                    msfvy
3351
3352    REAL , DIMENSION( ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: tendency
3353
3354    REAL , DIMENSION( ims:ime, kms:kme, jms:jme), INTENT(IN   ) ::defor12, &
3355                                                                  defor22, &
3356                                                                      div, &
3357                                                                      tke, &
3358                                                                     xkmh, &
3359                                                                       zx, &
3360                                                                       zy, &
3361                                                                     rdzw, &
3362                                                                      rho
3363
3364    INTEGER,  INTENT(  IN ) :: n_nba_mij
3365
3366    REAL , DIMENSION(ims:ime, kms:kme, jms:jme, n_nba_mij),  INTENT(INOUT) &
3367    :: nba_mij
3368
3369    REAL ,                                        INTENT(IN   ) ::    rdx, &
3370                                                                      rdy
3371
3372 ! Local data
3373
3374    INTEGER :: i, j, k, ktf
3375
3376    INTEGER :: i_start, i_end, j_start, j_end
3377    INTEGER :: is_ext,ie_ext,js_ext,je_ext
3378
3379    REAL , DIMENSION( its-1:ite+1, kts:kte, jts-1:jte+1)    :: titau1avg, &
3380                                                               titau2avg, &
3381                                                                  titau1, &
3382                                                                  titau2, &
3383                                                                  xkxavg, &
3384                                                                   rravg, &
3385                                                                 zy_at_v, &
3386                                                                 zx_at_v
3387 ! new
3388 !                                                                 zxavg, &
3389 !                                                                 zyavg
3390
3391    REAL :: mrdx, mrdy, rcoup
3392    REAL :: tmpdz
3393    REAL :: tmpzx, tmpzeta_z
3394
3395 ! End declarations.
3396 !-----------------------------------------------------------------------
3397
3398    ktf=MIN(kte,kde-1)
3399
3400 !-----------------------------------------------------------------------
3401 ! v :   p (.), v(+), w(-)
3402 !
3403 !       p  v  p  v                                  v     v
3404 !
3405 ! p  +  .  +  .  +  .  +   k+1                +  .  +  .  +  .  +   k+1
3406 !
3407 ! w     - 23  -     -      k+1                     23               k+1
3408 !
3409 ! p  +  22 O 22  +  .  +   k                  +  21 O 21  +  .  +   k
3410 !
3411 ! w     - 23  -     -      k                       23               k
3412 !
3413 ! p  +  .  +  .  +  .  +   k-1                +  .  +  .  +  .  +   k-1
3414 !
3415 !      j-1 j  j j+1                          i-1 i  i i+1 i+1
3416 !
3417
3418    i_start = its
3419    i_end   = MIN(ite,ide-1)
3420    j_start = jts
3421    j_end   = jte
3422
3423    IF ( config_flags%open_xs .or. config_flags%specified .or. &
3424         config_flags%nested) i_start = MAX(ids+1,its)
3425    IF ( config_flags%open_xe .or. config_flags%specified .or. &
3426         config_flags%nested) i_end   = MIN(ide-2,ite)
3427    IF ( config_flags%open_ys .or. config_flags%specified .or. &
3428         config_flags%nested) j_start = MAX(jds+1,jts)
3429    IF ( config_flags%open_ye .or. config_flags%specified .or. &
3430         config_flags%nested) j_end   = MIN(jde-1,jte)
3431       IF ( config_flags%periodic_x ) i_start = its
3432       IF ( config_flags%periodic_x ) i_end = MIN(ite,ide-1)
3433
3434 ! titau1 = titau21
3435    is_ext=0
3436    ie_ext=1
3437    js_ext=0
3438    je_ext=0
3439    CALL cal_titau_12_21( config_flags, titau1,           &
3440                          xkmh, defor12,                  &
3441                          nba_mij(ims,kms,jms,P_m12),rho, &
3442                          is_ext,ie_ext,js_ext,je_ext,    &
3443                          ids, ide, jds, jde, kds, kde,   &
3444                          ims, ime, jms, jme, kms, kme,   &
3445                          its, ite, jts, jte, kts, kte    )
3446
3447 ! titau2 = titau22
3448    is_ext=0
3449    ie_ext=0
3450    js_ext=1
3451    je_ext=0
3452    CALL cal_titau_11_22_33( config_flags, titau2,           &
3453                             tke, xkmh, defor22,             &
3454                             nba_mij(ims,kms,jms,P_m22),rho, &
3455                             is_ext, ie_ext, js_ext, je_ext, &
3456                             ids, ide, jds, jde, kds, kde,   &
3457                             ims, ime, jms, jme, kms, kme,   &
3458                             its, ite, jts, jte, kts, kte    )
3459
3460    DO j = j_start, j_end
3461    DO k = kts+1,ktf
3462    DO i = i_start, i_end
3463       titau1avg(i,k,j)=0.5*(fnm(k)*(titau1(i+1,k  ,j)+titau1(i,k  ,j))+ &
3464                             fnp(k)*(titau1(i+1,k-1,j)+titau1(i,k-1,j)))
3465       titau2avg(i,k,j)=0.5*(fnm(k)*(titau2(i,k  ,j-1)+titau2(i,k  ,j))+ &
3466                             fnp(k)*(titau2(i,k-1,j-1)+titau2(i,k-1,j)))
3467
3468 !      tmpzx = 0.25*( zx(i,k,j  )+zx(i+1,k,j  )+ &
3469 !                     zx(i,k,j-1)+zx(i+1,k,j-1)  )
3470       zx_at_v(i, k, j) = 0.125 * (zx(i, k, j) + zx(i + 1, k, j) +     &
3471           zx(i, k, j - 1) + zx(i + 1, k, j - 1) + zx(i, k + 1, j) +   &
3472           zx(i + 1, k + 1, j) + zx(i, k + 1, j - 1) + zx(i + 1, k + 1, j - 1))
3473       zy_at_v(i, k, j) = 0.5 * (zy(i, k, j) + zy(i, k + 1 , j))
3474
3475 !     titau1avg(i,k,j)=titau1avg(i,k,j)*tmpzx
3476 !     titau2avg(i,k,j)=titau2avg(i,k,j)*zy(i,k,j)
3477
3478
3479    ENDDO
3480    ENDDO
3481    ENDDO
3482
3483    DO j = j_start, j_end
3484    DO i = i_start, i_end
3485       titau1avg(i,kts,j)=0.
3486       titau1avg(i,ktf+1,j)=0.
3487       titau2avg(i,kts,j)=0.
3488       titau2avg(i,ktf+1,j)=0.
3489       zx_at_v(i, kts, j) = 0.125 * (zx(i, kts, j) + zx(i + 1, kts, j) +     &
3490           zx(i, kts, j - 1) + zx(i + 1, kts, j - 1) + zx(i, kts + 1, j) + &
3491           zx(i + 1, kts + 1, j) + zx(i, kts + 1, j - 1) + zx(i + 1, kts + 1, j - 1))
3492       zy_at_v(i, kts, j) = 0.5 * (zy(i, kts, j) + zy(i, kts + 1 , j))
3493    ENDDO
3494    ENDDO
3495 !
3496    DO j = j_start, j_end
3497    DO k = kts,ktf
3498    DO i = i_start, i_end
3499
3500       mrdx=msfvx(i,j)*rdx
3501       mrdy=msfvy(i,j)*rdy
3502       tmpdz = (1./rdzw(i,k,j)+1./rdzw(i,k,j-1))/2.
3503       tendency(i,k,j)=tendency(i,k,j) +    g*tmpdz/dnw(k) *           &
3504            (mrdy*(titau2(i,k,j  ) - titau2(i,k,j-1)) +                &
3505             mrdx*(titau1(i+1,k,j) - titau1(i  ,k,j)) -                &
3506             msfvx(i,j)*zx_at_v(i,k,j)*(titau1avg(i,k+1,j)-titau1avg(i,k,j)) / tmpdz - &
3507             msfvy(i,j)*zy_at_v(i,k,j)*(titau2avg(i,k+1,j)-titau2avg(i,k,j)) / tmpdz   &
3508                                                                   )
3509
3510    ENDDO
3511    ENDDO
3512    ENDDO
3513
3514 END SUBROUTINE horizontal_diffusion_v_2
3515
3516 !=======================================================================
3517 !=======================================================================
3518
3519 SUBROUTINE horizontal_diffusion_w_2( tendency, config_flags,              &
3520                                      defor13, defor23, div,               &
3521                                      nba_mij, n_nba_mij,                  &
3522                                      tke,                                 &
3523                                      msftx, msfty,                        &
3524                                      xkmv, rdx, rdy, fnm, fnp,            &
3525                                      dn, zx, zy, rdz, rho,                &
3526                                      ids, ide, jds, jde, kds, kde,        &
3527                                      ims, ime, jms, jme, kms, kme,        &
3528                                      its, ite, jts, jte, kts, kte        )
3529
3530 !-----------------------------------------------------------------------
3531 ! Begin declarations.
3532
3533    IMPLICIT NONE
3534
3535    TYPE(grid_config_rec_type), INTENT(IN   ) :: config_flags
3536
3537    INTEGER ,        INTENT(IN   ) ::        ids, ide, jds, jde, kds, kde, &
3538                                             ims, ime, jms, jme, kms, kme, &
3539                                             its, ite, jts, jte, kts, kte
3540
3541    REAL , DIMENSION( kms:kme ) ,                 INTENT(IN   ) ::    fnm
3542    REAL , DIMENSION( kms:kme ) ,                 INTENT(IN   ) ::    fnp
3543    REAL , DIMENSION( kms:kme ) ,                 INTENT(IN   ) ::    dn
3544
3545    REAL , DIMENSION( ims:ime, jms:jme) ,         INTENT(IN   ) ::  msftx, &
3546                                                                    msfty
3547
3548    REAL , DIMENSION( ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: tendency
3549
3550    REAL , DIMENSION( ims:ime, kms:kme, jms:jme), INTENT(IN   ) ::defor13, &
3551                                                                  defor23, &
3552                                                                      div, &
3553                                                                      tke, &
3554                                                                     xkmv, &
3555                                                                       zx, &
3556                                                                       zy, &
3557                                                                      rdz, &
3558                                                                      rho
3559
3560    INTEGER,  INTENT(  IN ) :: n_nba_mij
3561
3562    REAL , DIMENSION(ims:ime, kms:kme, jms:jme, n_nba_mij),  INTENT(INOUT) &
3563    :: nba_mij
3564
3565    REAL ,                                        INTENT(IN   ) ::    rdx, &
3566                                                                      rdy
3567
3568 ! Local data
3569
3570    INTEGER :: i, j, k, ktf
3571
3572    INTEGER :: i_start, i_end, j_start, j_end
3573    INTEGER :: is_ext,ie_ext,js_ext,je_ext
3574
3575    REAL , DIMENSION( its-1:ite+1, kts:kte, jts-1:jte+1)    :: titau1avg, &
3576                                                               titau2avg, &
3577                                                                  titau1, &
3578                                                                  titau2, &
3579                                                                  xkxavg, &
3580                                                                   rravg, &
3581                                                                 zx_at_w, &
3582                                                                 zy_at_w
3583 ! new
3584 !                                                                 zxavg, &
3585 !                                                                 zyavg
3586
3587    REAL :: mrdx, mrdy, rcoup
3588
3589    REAL :: tmpzx, tmpzy, tmpzeta_z
3590 !
3591 ! End declarations.
3592 !-----------------------------------------------------------------------
3593
3594    ktf=MIN(kte,kde-1)
3595
3596 !-----------------------------------------------------------------------
3597 ! w :   p (.), u(|), v(+), w(-)
3598 !
3599 !       p  u  p  u                               p  v  p  v
3600 !
3601 ! w     -     -     -      k+1             w     -     -     -      k+1
3602 !
3603 ! p     .  | 33  |  .      k               p     .  + 33  +  .      k
3604 !
3605 ! w     -  31 O 31  -      k               w     -  32 O 32  -      k
3606 !
3607 ! p     .  | 33  |  .      k-1             p     .  | 33  |  .      k-1
3608 !
3609 ! w     -     -     -      k-1             w     -     -     -      k-1
3610 !
3611 !      i-1 i  i i+1                             j-1 j  j j+1
3612 !
3613    i_start = its
3614    i_end   = MIN(ite,ide-1)
3615    j_start = jts
3616    j_end   = MIN(jte,jde-1)
3617
3618    IF ( config_flags%open_xs .or. config_flags%specified .or. &
3619         config_flags%nested) i_start = MAX(ids+1,its)
3620    IF ( config_flags%open_xe .or. config_flags%specified .or. &
3621         config_flags%nested) i_end   = MIN(ide-2,ite)
3622    IF ( config_flags%open_ys .or. config_flags%specified .or. &
3623         config_flags%nested) j_start = MAX(jds+1,jts)
3624    IF ( config_flags%open_ye .or. config_flags%specified .or. &
3625         config_flags%nested) j_end   = MIN(jde-2,jte)
3626       IF ( config_flags%periodic_x ) i_start = its
3627       IF ( config_flags%periodic_x ) i_end = MIN(ite,ide-1)
3628
3629 ! titau1 = titau31
3630    is_ext=0
3631    ie_ext=1
3632    js_ext=0
3633    je_ext=0
3634    CALL cal_titau_13_31( config_flags, titau1, defor13,   &
3635                          nba_mij(ims,kms,jms,P_m13),      &
3636                          xkmv, fnm, fnp, rho,             &
3637                          is_ext, ie_ext, js_ext, je_ext,  &
3638                          ids, ide, jds, jde, kds, kde,    &
3639                          ims, ime, jms, jme, kms, kme,    &
3640                          its, ite, jts, jte, kts, kte     )
3641
3642 ! titau2 = titau32
3643    is_ext=0
3644    ie_ext=0
3645    js_ext=0
3646    je_ext=1
3647    CALL cal_titau_23_32( config_flags, titau2, defor23,   &
3648                          nba_mij(ims,kms,jms,P_m23),      &
3649                          xkmv, fnm, fnp, rho,             &
3650                          is_ext, ie_ext, js_ext, je_ext,  &
3651                          ids, ide, jds, jde, kds, kde,    &
3652                          ims, ime, jms, jme, kms, kme,    &
3653                          its, ite, jts, jte, kts, kte     )
3654
3655 ! titau1avg = titau31avg * zx * zeta_z = titau13avg * zx * zeta_z
3656 ! titau2avg = titau32avg * zy * zeta_z = titau23avg * zy * zeta_z
3657
3658    DO j = j_start, j_end
3659    DO k = kts,ktf
3660    DO i = i_start, i_end
3661       titau1avg(i,k,j)=0.25*(titau1(i+1,k+1,j)+titau1(i,k+1,j)+ &
3662                              titau1(i+1,k  ,j)+titau1(i,k  ,j))
3663       titau2avg(i,k,j)=0.25*(titau2(i,k+1,j+1)+titau2(i,k+1,j)+ &
3664                              titau2(i,k  ,j+1)+titau2(i,k  ,j))
3665       zx_at_w(i, k, j) = 0.5 * (zx(i, k, j) + zx(i + 1, k, j))
3666       zy_at_w(i, k, j) = 0.5 * (zy(i, k, j) + zy(i, k, j + 1))
3667 ! new
3668 !      tmpzx  =0.25*( zx(i,k  ,j)+zx(i+1,k  ,j)+ &
3669 !                     zx(i,k+1,j)+zx(i+1,k+1,j)  )
3670 !      tmpzy  =0.25*( zy(i,k  ,j)+zy(i,k  ,j+1)+ &
3671 !                     zy(i,k+1,j)+zy(i,k+1,j+1)  )
3672
3673 !      titau1avg(i,k,j)=titau1avg(i,k,j)*tmpzx
3674 !      titau2avg(i,k,j)=titau2avg(i,k,j)*tmpzy
3675 !      titau1avg(i,k,j)=titau1avg(i,k,j)*tmpzx*zeta_z(i,j)
3676 !      titau2avg(i,k,j)=titau2avg(i,k,j)*tmpzy*zeta_z(i,j)
3677    ENDDO
3678    ENDDO
3679    ENDDO
3680
3681    DO j = j_start, j_end
3682    DO i = i_start, i_end
3683       titau1avg(i,ktf+1,j)=0.
3684       titau2avg(i,ktf+1,j)=0.
3685    ENDDO
3686    ENDDO
3687
3688    DO j = j_start, j_end
3689    DO k = kts+1,ktf
3690    DO i = i_start, i_end
3691
3692       mrdx=msftx(i,j)*rdx
3693       mrdy=msfty(i,j)*rdy
3694
3695      tendency(i,k,j)=tendency(i,k,j) +   g/(dn(k)*rdz(i,k,j)) *         &
3696            (mrdx*(titau1(i+1,k,j)-titau1(i,k,j))+                       &
3697             mrdy*(titau2(i,k,j+1)-titau2(i,k,j))-                       &
3698             msfty(i,j)*rdz(i,k,j)*(zx_at_w(i,k,j)*(titau1avg(i,k,j)-titau1avg(i,k-1,j))+ &
3699                                    zy_at_w(i,k,j)*(titau2avg(i,k,j)-titau2avg(i,k-1,j))  &
3700                                   )                                     &
3701            )
3702    ENDDO
3703    ENDDO
3704    ENDDO
3705
3706 END SUBROUTINE horizontal_diffusion_w_2
3707
3708 !=======================================================================
3709 !=======================================================================
3710
3711 SUBROUTINE horizontal_diffusion_s (tendency, config_flags,                &
3712                                    var,                                   &
3713                                    msftx, msfty, msfux, msfuy,            &
3714                                    msfvx, msfvy, xkhh, rdx, rdy,          &
3715                                    fnm, fnp, cf1, cf2, cf3,               &
3716                                    zx, zy, rdz, rdzw, dnw, dn, rho,       &
3717                                    doing_tke,                             &
3718                                    ids, ide, jds, jde, kds, kde,          &
3719                                    ims, ime, jms, jme, kms, kme,          &
3720                                    its, ite, jts, jte, kts, kte           )
3721
3722 !-----------------------------------------------------------------------
3723 ! Begin declarations.
3724
3725    IMPLICIT NONE
3726
3727    TYPE(grid_config_rec_type), INTENT(IN   ) :: config_flags
3728
3729    INTEGER ,        INTENT(IN   ) ::        ids, ide, jds, jde, kds, kde, &
3730                                             ims, ime, jms, jme, kms, kme, &
3731                                             its, ite, jts, jte, kts, kte
3732
3733    LOGICAL,         INTENT(IN   ) ::        doing_tke
3734
3735    REAL , INTENT(IN   )           ::        cf1, cf2, cf3
3736
3737    REAL , DIMENSION( kms:kme ) ,                 INTENT(IN   ) ::    fnm
3738    REAL , DIMENSION( kms:kme ) ,                 INTENT(IN   ) ::    fnp
3739    REAL , DIMENSION( kms:kme ) ,                 INTENT(IN   ) ::     dn
3740    REAL , DIMENSION( kms:kme ) ,                 INTENT(IN   ) ::    dnw
3741
3742    REAL , DIMENSION( ims:ime, jms:jme) ,         INTENT(IN   ) ::   msfux
3743    REAL , DIMENSION( ims:ime, jms:jme) ,         INTENT(IN   ) ::   msfuy
3744    REAL , DIMENSION( ims:ime, jms:jme) ,         INTENT(IN   ) ::   msfvx
3745    REAL , DIMENSION( ims:ime, jms:jme) ,         INTENT(IN   ) ::   msfvy
3746    REAL , DIMENSION( ims:ime, jms:jme) ,         INTENT(IN   ) ::   msftx
3747    REAL , DIMENSION( ims:ime, jms:jme) ,         INTENT(IN   ) ::   msfty
3748
3749    REAL , DIMENSION( ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: tendency
3750
3751    REAL , DIMENSION( ims:ime, kms:kme, jms:jme), INTENT(IN   ) ::         &
3752                                                                     xkhh, &
3753                                                                      rdz, &
3754                                                                     rdzw, &
3755                                                                      rho
3756
3757    REAL , DIMENSION( ims:ime, kms:kme, jms:jme), INTENT(IN   ) ::    var, &
3758                                                                       zx, &
3759                                                                       zy
3760
3761    REAL ,                                        INTENT(IN   ) ::    rdx, &
3762                                                                      rdy
3763
3764 ! Local data
3765
3766    INTEGER :: i, j, k, ktf
3767
3768    INTEGER :: i_start, i_end, j_start, j_end
3769
3770    REAL , DIMENSION( its-1:ite+1, kts:kte, jts-1:jte+1)    ::     H1avg, &
3771                                                                   H2avg, &
3772                                                                      H1, &
3773                                                                      H2, &
3774                                                                  xkxavg, &
3775                                                                 zx_at_m, &
3776                                                                 zy_at_m
3777
3778    REAL , DIMENSION( its:ite, kts:kte, jts:jte)            ::  tmptendf
3779
3780    REAL    :: mrdx, mrdy, rcoup
3781    REAL    :: tmpzx, tmpzy, tmpzeta_z, rdzu, rdzv
3782    INTEGER :: ktes1,ktes2
3783 !
3784 ! End declarations.
3785 !-----------------------------------------------------------------------
3786
3787    ktf=MIN(kte,kde-1)
3788
3789 !-----------------------------------------------------------------------
3790 ! scalars:   t (.), u(|), v(+), w(-)
3791 !
3792 !       t  u  t  u                               t  v  t  v
3793 !
3794 ! w     -     3     -      k+1             w     -     3     -      k+1
3795 !
3796 ! t     .  1  O  1  .      k               t     .  2  O  2  .      k
3797 !
3798 ! w     -     3     -      k               w     -     3     -      k
3799 !
3800 ! t     .  |  .  |  .      k-1             t     .  +  .  +  .      k-1
3801 !
3802 ! w     -     -     -      k-1             w     -     -     -      k-1
3803 !
3804 ! t    i-1 i  i i+1                             j-1 j  j j+1
3805 !
3806
3807    ktes1=kte-1
3808    ktes2=kte-2
3809
3810    i_start = its
3811    i_end   = MIN(ite,ide-1)
3812    j_start = jts
3813    j_end   = MIN(jte,jde-1)
3814
3815    IF ( config_flags%open_xs .or. config_flags%specified .or. &
3816         config_flags%nested) i_start = MAX(ids+1,its)
3817    IF ( config_flags%open_xe .or. config_flags%specified .or. &
3818         config_flags%nested) i_end   = MIN(ide-2,ite)
3819    IF ( config_flags%open_ys .or. config_flags%specified .or. &
3820         config_flags%nested) j_start = MAX(jds+1,jts)
3821    IF ( config_flags%open_ye .or. config_flags%specified .or. &
3822         config_flags%nested) j_end   = MIN(jde-2,jte)
3823       IF ( config_flags%periodic_x ) i_start = its
3824       IF ( config_flags%periodic_x ) i_end = MIN(ite,ide-1)
3825
3826 ! diffusion of the TKE needs mutiple 2
3827
3828    IF ( doing_tke ) THEN
3829       DO j = j_start, j_end
3830       DO k = kts,ktf
3831       DO i = i_start, i_end
3832          tmptendf(i,k,j)=tendency(i,k,j)
3833       ENDDO
3834       ENDDO
3835       ENDDO
3836    ENDIF
3837
3838 ! H1 = partial var over partial x
3839
3840    DO j = j_start, j_end
3841    DO k = kts, ktf
3842    DO i = i_start, i_end + 1
3843       xkxavg(i,k,j)=0.5*(xkhh(i-1,k,j)+xkhh(i,k,j))*0.5*(rho(i-1,k,j)+rho(i,k,j))
3844    ENDDO
3845    ENDDO
3846    ENDDO
3847
3848    DO j = j_start, j_end
3849    DO k = kts+1, ktf
3850    DO i = i_start, i_end + 1
3851       H1avg(i,k,j)=0.5*(fnm(k)*(var(i-1,k  ,j)+var(i,k  ,j))+  &
3852                         fnp(k)*(var(i-1,k-1,j)+var(i,k-1,j)))
3853    ENDDO
3854    ENDDO
3855    ENDDO
3856
3857    DO j = j_start, j_end
3858    DO i = i_start, i_end + 1
3859       H1avg(i,kts  ,j)=0.5*(cf1*var(i  ,1,j)+cf2*var(i  ,2,j)+ &
3860                             cf3*var(i  ,3,j)+cf1*var(i-1,1,j)+  &
3861                             cf2*var(i-1,2,j)+cf3*var(i-1,3,j))
3862       H1avg(i,ktf+1,j)=0.5*(var(i,ktes1,j)+(var(i,ktes1,j)- &
3863                             var(i,ktes2,j))*0.5*dnw(ktes1)/dn(ktes1)+ &
3864                             var(i-1,ktes1,j)+(var(i-1,ktes1,j)- &
3865                             var(i-1,ktes2,j))*0.5*dnw(ktes1)/dn(ktes1))
3866    ENDDO
3867    ENDDO
3868
3869    DO j = j_start, j_end
3870    DO k = kts, ktf
3871    DO i = i_start, i_end + 1
3872 ! new
3873       tmpzx = 0.5*( zx(i,k,j)+ zx(i,k+1,j))
3874       rdzu = 2./(1./rdzw(i,k,j) + 1./rdzw(i-1,k,j))
3875       H1(i,k,j)=-msfux(i,j)*xkxavg(i,k,j)*(                      &
3876                  rdx*(var(i,k,j)-var(i-1,k,j)) - tmpzx*         &
3877                      (H1avg(i,k+1,j)-H1avg(i,k,j))*rdzu )
3878
3879 !      tmpzeta_z = 0.5*(zeta_z(i,j)+zeta_z(i-1,j))
3880 !      H1(i,k,j)=-msfuy(i,j)*xkxavg(i,k,j)*(                         &
3881 !                 rdx*(var(i,k,j)-var(i-1,k,j)) - tmpzx*tmpzeta_z*  &
3882 !                     (H1avg(i,k+1,j)-H1avg(i,k,j))/dnw(k))
3883    ENDDO
3884    ENDDO
3885    ENDDO
3886
3887 ! H2 = partial var over partial y
3888
3889    DO j = j_start, j_end + 1
3890    DO k = kts, ktf
3891    DO i = i_start, i_end
3892       xkxavg(i,k,j)=0.5*(xkhh(i,k,j-1)+xkhh(i,k,j))*0.5*(rho(i,k,j-1)+rho(i,k,j))
3893    ENDDO
3894    ENDDO
3895    ENDDO
3896
3897    DO j = j_start, j_end + 1
3898    DO k = kts+1,   ktf
3899    DO i = i_start, i_end
3900       H2avg(i,k,j)=0.5*(fnm(k)*(var(i,k  ,j-1)+var(i,k  ,j))+  &
3901                         fnp(k)*(var(i,k-1,j-1)+var(i,k-1,j)))
3902    ENDDO
3903    ENDDO
3904    ENDDO
3905
3906    DO j = j_start, j_end + 1
3907    DO i = i_start, i_end
3908       H2avg(i,kts  ,j)=0.5*(cf1*var(i,1,j  )+cf2*var(i  ,2,j)+ &
3909                             cf3*var(i,3,j  )+cf1*var(i,1,j-1)+  &
3910                             cf2*var(i,2,j-1)+cf3*var(i,3,j-1))
3911       H2avg(i,ktf+1,j)=0.5*(var(i,ktes1,j)+(var(i,ktes1,j)- &
3912                             var(i,ktes2,j))*0.5*dnw(ktes1)/dn(ktes1)+ &
3913                             var(i,ktes1,j-1)+(var(i,ktes1,j-1)- &
3914                             var(i,ktes2,j-1))*0.5*dnw(ktes1)/dn(ktes1))
3915    ENDDO
3916    ENDDO
3917
3918    DO j = j_start, j_end + 1
3919    DO k = kts, ktf
3920    DO i = i_start, i_end
3921 ! new
3922       tmpzy = 0.5*( zy(i,k,j)+ zy(i,k+1,j))
3923       rdzv = 2./(1./rdzw(i,k,j) + 1./rdzw(i,k,j-1))
3924       H2(i,k,j)=-msfvy(i,j)*xkxavg(i,k,j)*(                       &
3925                  rdy*(var(i,k,j)-var(i,k,j-1)) - tmpzy*          &
3926                      (H2avg(i ,k+1,j)-H2avg(i,k,j))*rdzv)
3927
3928 !      tmpzeta_z = 0.5*(zeta_z(i,j)+zeta_z(i,j-1))
3929 !      H2(i,k,j)=-msfvy(i,j)*xkxavg(i,k,j)*(                         &
3930 !                 rdy*(var(i,k,j)-var(i,k,j-1)) - tmpzy*tmpzeta_z*  &
3931 !                     (H2avg(i ,k+1,j)-H2avg(i,k,j))/dnw(k))
3932    ENDDO
3933    ENDDO
3934    ENDDO
3935
3936    DO j = j_start, j_end
3937    DO k = kts+1, ktf
3938    DO i = i_start, i_end
3939       H1avg(i,k,j)=0.5*(fnm(k)*(H1(i+1,k  ,j)+H1(i,k  ,j))+  &
3940                         fnp(k)*(H1(i+1,k-1,j)+H1(i,k-1,j)))
3941       H2avg(i,k,j)=0.5*(fnm(k)*(H2(i,k  ,j+1)+H2(i,k  ,j))+  &
3942                         fnp(k)*(H2(i,k-1,j+1)+H2(i,k-1,j)))
3943 ! new
3944 !     zxavg(i,k,j)=fnm(k)*zx(i,k,j)+fnp(k)*zx(i,k-1,j)
3945 !     zyavg(i,k,j)=fnm(k)*zy(i,k,j)+fnp(k)*zy(i,k-1,j)
3946
3947 ! H1avg(i,k,j)=zx*H1avg*zeta_z
3948 ! H2avg(i,k,j)=zy*H2avg*zeta_z
3949
3950       zx_at_m(i, k, j) = 0.25*(zx(i,k,j)+ zx(i+1,k,j) + zx(i,k+1,j)+ zx(i+1,k+1,j))
3951       zy_at_m(i, k, j) = 0.25*(zy(i,k,j)+ zy(i,k,j+1) + zy(i,k+1,j)+ zy(i,k+1,j+1))
3952
3953 !      H1avg(i,k,j)=H1avg(i,k,j)*tmpzx*zeta_z(i,j)
3954 !      H2avg(i,k,j)=H2avg(i,k,j)*tmpzy*zeta_z(i,j)
3955    ENDDO
3956    ENDDO
3957    ENDDO
3958
3959    DO j = j_start, j_end
3960    DO i = i_start, i_end
3961       H1avg(i,kts  ,j)=0.
3962       H1avg(i,ktf+1,j)=0.
3963       H2avg(i,kts  ,j)=0.
3964       H2avg(i,ktf+1,j)=0.
3965       zx_at_m(i, kts, j) = 0.25*(zx(i,kts,j)+ zx(i+1,kts,j) + zx(i,kts+1,j)+ zx(i+1,kts+1,j))
3966       zy_at_m(i, kts, j) = 0.25*(zy(i,kts,j)+ zy(i,kts,j+1) + zy(i,kts+1,j)+ zy(i,kts+1,j+1))
3967
3968    ENDDO
3969    ENDDO
3970
3971    DO j = j_start, j_end
3972    DO k = kts,ktf
3973    DO i = i_start, i_end
3974
3975       mrdx=msftx(i,j)*rdx
3976       mrdy=msfty(i,j)*rdy
3977
3978       tendency(i,k,j)=tendency(i,k,j) +   g/(dnw(k)*rdzw(i,k,j)) * &
3979            (mrdx*(H1(i+1,k,j)-H1(i  ,k,j)) +                       &
3980             mrdy*(H2(i,k,j+1)-H2(i,k,j  )) -                       &
3981             msftx(i,j)*zx_at_m(i, k, j)*(H1avg(i,k+1,j)-H1avg(i,k,j))*rdzw(i,k,j) - &
3982             msfty(i,j)*zy_at_m(i, k, j)*(H2avg(i,k+1,j)-H2avg(i,k,j))*rdzw(i,k,j)   &
3983            )
3984    ENDDO
3985    ENDDO
3986    ENDDO
3987
3988    IF ( doing_tke ) THEN
3989       DO j = j_start, j_end
3990       DO k = kts,ktf
3991       DO i = i_start, i_end
3992           tendency(i,k,j)=tmptendf(i,k,j)+2.* &
3993                           (tendency(i,k,j)-tmptendf(i,k,j))
3994       ENDDO
3995       ENDDO
3996       ENDDO
3997    ENDIF
3998
3999 END SUBROUTINE horizontal_diffusion_s
4000
4001 !=======================================================================
4002 !=======================================================================
4003
4004 SUBROUTINE vertical_diffusion_2   ( ru_tendf, rv_tendf, rw_tendf, rt_tendf,   &
4005                                     tke_tendf, moist_tendf, n_moist,          &
4006                                     chem_tendf, n_chem,                       &
4007                                     scalar_tendf, n_scalar,                   &
4008                                     tracer_tendf, n_tracer,                   &
4009                                     u_2, v_2,                                 &
4010                                     thp,u_base,v_base,t_base,qv_base,tke,     &
4011                                     theta,                                    &
4012                                     config_flags,defor13,defor23,defor33,     &
4013                                     nba_mij, n_nba_mij,                       &
4014                                     div,                                      &
4015                                     moist,chem,scalar,tracer,                 &
4016                                     xkmv,xkhv,xkmh,km_opt,                    & ! xkmh added
4017                                     fnm, fnp, dn, dnw, rdz, rdzw,             &
4018                                     hfx, qfx, ust, rho,                       &
4019                                     ids, ide, jds, jde, kds, kde,             &
4020                                     ims, ime, jms, jme, kms, kme,             &
4021                                     its, ite, jts, jte, kts, kte              )
4022
4023 !-----------------------------------------------------------------------
4024 ! Begin declarations.
4025
4026    IMPLICIT NONE
4027
4028    TYPE(grid_config_rec_type), INTENT(IN   ) :: config_flags
4029
4030    INTEGER ,        INTENT(IN   ) ::        ids, ide, jds, jde, kds, kde, &
4031                                             ims, ime, jms, jme, kms, kme, &
4032                                             its, ite, jts, jte, kts, kte
4033
4034    INTEGER ,        INTENT(IN   ) ::        n_moist,n_chem,n_scalar,n_tracer,km_opt
4035
4036    REAL , DIMENSION( kms:kme ) ,                 INTENT(IN   ) :: fnm
4037    REAL , DIMENSION( kms:kme ) ,                 INTENT(IN   ) :: fnp
4038    REAL , DIMENSION( kms:kme ) ,                 INTENT(IN   ) :: dnw
4039    REAL , DIMENSION( kms:kme ) ,                 INTENT(IN   ) ::  dn
4040
4041    REAL , DIMENSION( kms:kme ) ,                 INTENT(IN   ) :: qv_base
4042    REAL , DIMENSION( kms:kme ) ,                 INTENT(IN   ) ::  u_base
4043    REAL , DIMENSION( kms:kme ) ,                 INTENT(IN   ) ::  v_base
4044    REAL , DIMENSION( kms:kme ) ,                 INTENT(IN   ) ::  t_base
4045
4046    REAL , DIMENSION( ims:ime, kms:kme, jms:jme), INTENT(INOUT) ::ru_tendf,&
4047                                                                  rv_tendf,&
4048                                                                  rw_tendf,&
4049                                                                 tke_tendf,&
4050                                                                 rt_tendf
4051
4052    REAL , DIMENSION( ims:ime, kms:kme, jms:jme, n_moist),                 &
4053           INTENT(INOUT) ::                                    moist_tendf
4054
4055    REAL , DIMENSION( ims:ime, kms:kme, jms:jme, n_chem),                  &
4056           INTENT(INOUT) ::                                     chem_tendf
4057
4058    REAL , DIMENSION( ims:ime, kms:kme, jms:jme, n_scalar) ,               &
4059           INTENT(INOUT) ::                                   scalar_tendf
4060    REAL , DIMENSION( ims:ime, kms:kme, jms:jme, n_tracer) ,               &
4061           INTENT(INOUT) ::                                   tracer_tendf
4062
4063    REAL , DIMENSION( ims:ime, kms:kme, jms:jme, n_moist),                 &
4064           INTENT(INOUT) ::                                          moist
4065
4066    REAL , DIMENSION( ims:ime, kms:kme, jms:jme, n_chem),                  &
4067           INTENT(INOUT) ::                                           chem
4068
4069    REAL , DIMENSION( ims:ime, kms:kme, jms:jme, n_scalar) ,               &
4070           INTENT(IN   ) ::                                         scalar
4071    REAL , DIMENSION( ims:ime, kms:kme, jms:jme, n_tracer) ,               &
4072           INTENT(IN   ) ::                                         tracer
4073
4074    REAL , DIMENSION( ims:ime, kms:kme, jms:jme), INTENT(IN   ) ::defor13, &
4075                                                                  defor23, &
4076                                                                  defor33, &
4077                                                                      div, &
4078                                                                     xkmv, &
4079                                                                     xkhv, &
4080                                                                     xkmh, &
4081                                                                      tke, &
4082                                                                    theta, &
4083                                                                      rdz, &
4084                                                                      u_2, &
4085                                                                      v_2, &
4086                                                                     rdzw
4087
4088    INTEGER, INTENT(  IN ) :: n_nba_mij
4089
4090    REAL , DIMENSION(ims:ime, kms:kme, jms:jme, n_nba_mij), INTENT(INOUT) &
4091    :: nba_mij
4092
4093    REAL , DIMENSION( ims:ime, kms:kme, jms:jme), INTENT(IN   )   :: rho
4094    REAL , DIMENSION( ims:ime, jms:jme), INTENT(INOUT)            :: hfx,  &
4095                                                                     qfx
4096    REAL , DIMENSION( ims:ime, jms:jme), INTENT(IN   )            :: ust
4097    REAL , DIMENSION( ims:ime, kms:kme, jms:jme), INTENT(INOUT) ::    thp
4098
4099 ! LOCAL VAR
4100
4101    REAL , DIMENSION( ims:ime, kms:kme, jms:jme)  ::    var_mix
4102
4103    INTEGER :: im, i,j,k
4104    INTEGER :: i_start, i_end, j_start, j_end
4105
4106 !  REAL , DIMENSION( its:ite, kts:kte, jts:jte) :: xkhv
4107
4108 !***************************************************************************
4109 !***************************************************************************
4110 !MODIFICA VARIABILI PER I FLUSSI
4111 !
4112     REAL :: V0_u,V0_v,tao_xz,tao_yz,ustar,cd0
4113     REAL :: xsfc,psi1,vk2,zrough,lnz
4114     REAL :: heat_flux, moist_flux, heat_flux0
4115     REAL :: cpm
4116 !
4117 !FINE MODIFICA VARIABILI PER I FLUSSI
4118 !***************************************************************************
4119 !
4120
4121 ! End declarations.
4122 !-----------------------------------------------------------------------
4123
4124    i_start = its
4125    i_end   = MIN(ite,ide-1)
4126    j_start = jts
4127    j_end   = MIN(jte,jde-1)
4128 !
4129 !-----------------------------------------------------------------------
4130
4131       CALL vertical_diffusion_u_2( ru_tendf, config_flags,        &
4132                                    defor13, xkmv,                 &
4133                                    nba_mij, n_nba_mij,            &
4134                                    dnw, rdzw, fnm, fnp, rho,      &
4135                                    ids, ide, jds, jde, kds, kde,  &
4136                                    ims, ime, jms, jme, kms, kme,  &
4137                                    its, ite, jts, jte, kts, kte  )
4138
4139
4140       CALL vertical_diffusion_v_2( rv_tendf, config_flags,        &
4141                                    defor23, xkmv,                 &
4142                                    nba_mij, n_nba_mij,            &
4143                                    dnw, rdzw, fnm, fnp, rho,      &
4144                                    ids, ide, jds, jde, kds, kde,  &
4145                                    ims, ime, jms, jme, kms, kme,  &
4146                                    its, ite, jts, jte, kts, kte  )
4147
4148       CALL vertical_diffusion_w_2( rw_tendf, config_flags,        &
4149                                    defor33, tke(ims,kms,jms),     &
4150                                    nba_mij, n_nba_mij,            &
4151                                    div, xkmh,                     &
4152                                    dn, rdz, fnm, fnp, rho,        &
4153                                    ids, ide, jds, jde, kds, kde,  &
4154                                    ims, ime, jms, jme, kms, kme,  &
4155                                    its, ite, jts, jte, kts, kte  )
4156
4157 !*****************************************
4158 !*****************************************
4159 !  MODIFICA al flusso di momento alla parete
4160 !
4161   vflux: SELECT CASE( config_flags%isfflx )
4162   CASE (0) ! Assume cd a constant, specified in namelist
4163     cd0 = config_flags%tke_drag_coefficient  ! constant drag coefficient
4164                                              ! set in namelist.input
4165 !
4166 !calcolo del modulo della velocita
4167     DO j = j_start, j_end
4168     DO i = i_start, ite
4169        V0_u=0.
4170        tao_xz=0.
4171        V0_u=    sqrt((u_2(i,kts,j)**2) +         &
4172                         (((v_2(i  ,kts,j  )+          &
4173                            v_2(i  ,kts,j+1)+          &
4174                            v_2(i-1,kts,j  )+          &
4175                            v_2(i-1,kts,j+1))/4)**2))+epsilon
4176
4177        tao_xz=cd0*V0_u*u_2(i,kts,j)
4178        ru_tendf(i,kts,j)=ru_tendf(i,kts,j) +   g*tao_xz*0.5*(rho(i,kts,j)+rho(i-1,kts,j))/dnw(kts)
4179        IF ( (config_flags%m_opt .EQ. 1) .OR. (config_flags%sfs_opt .GT. 0) ) THEN
4180           nba_mij(i,kts,j,P_m13) = -tao_xz
4181        ENDIF
4182     ENDDO
4183     ENDDO
4184 !
4185     DO j = j_start, jte
4186     DO i = i_start, i_end
4187        V0_v=0.
4188        tao_yz=0.
4189        V0_v=    sqrt((v_2(i,kts,j)**2) +         &
4190                         (((u_2(i  ,kts,j  )+          &
4191                            u_2(i  ,kts,j-1)+          &
4192                            u_2(i+1,kts,j  )+          &
4193                            u_2(i+1,kts,j-1))/4)**2))+epsilon
4194
4195        tao_yz=cd0*V0_v*v_2(i,kts,j)
4196        rv_tendf(i,kts,j)=rv_tendf(i,kts,j) +   g*tao_yz*0.5*(rho(i,kts,j)+rho(i,kts,j-1))/dnw(kts)
4197        IF ( (config_flags%m_opt .EQ. 1) .OR. (config_flags%sfs_opt .GT. 0) ) THEN
4198           nba_mij(i,kts,j,P_m23) = -tao_yz
4199        ENDIF
4200     ENDDO
4201     ENDDO
4202
4203   CASE (1,2) ! ustar computed from surface routine
4204     DO j = j_start, j_end
4205     DO i = i_start, ite
4206        V0_u=0.
4207        tao_xz=0.
4208        V0_u=    sqrt((u_2(i,kts,j)**2) +         &
4209                         (((v_2(i  ,kts,j  )+          &
4210                            v_2(i  ,kts,j+1)+          &
4211                            v_2(i-1,kts,j  )+          &
4212                            v_2(i-1,kts,j+1))/4)**2))+epsilon
4213        ustar=0.5*(ust(i,j)+ust(i-1,j))
4214
4215        tao_xz=ustar*ustar*u_2(i,kts,j)/V0_u
4216        ru_tendf(i,kts,j)=ru_tendf(i,kts,j) +   g*tao_xz*0.5*(rho(i,kts,j)+rho(i-1,kts,j))/dnw(kts)
4217        IF ( (config_flags%m_opt .EQ. 1) .OR. (config_flags%sfs_opt .GT. 0) ) THEN
4218           nba_mij(i,kts,j,P_m13) = -tao_xz
4219        ENDIF
4220     ENDDO
4221     ENDDO
4222
4223     DO j = j_start, jte
4224     DO i = i_start, i_end
4225        V0_v=0.
4226        tao_yz=0.
4227        V0_v=    sqrt((v_2(i,kts,j)**2) +         &
4228                         (((u_2(i  ,kts,j  )+          &
4229                            u_2(i  ,kts,j-1)+          &
4230                            u_2(i+1,kts,j  )+          &
4231                            u_2(i+1,kts,j-1))/4)**2))+epsilon
4232        ustar=0.5*(ust(i,j)+ust(i,j-1))
4233
4234        tao_yz=ustar*ustar*v_2(i,kts,j)/V0_v
4235        rv_tendf(i,kts,j)=rv_tendf(i,kts,j) +   g*tao_yz*0.5*(rho(i,kts,j)+rho(i,kts,j-1))/dnw(kts)
4236        IF ( (config_flags%m_opt .EQ. 1) .OR. (config_flags%sfs_opt .GT. 0) ) THEN
4237           nba_mij(i,kts,j,P_m23) = -tao_yz
4238        ENDIF
4239     ENDDO
4240     ENDDO
4241
4242   CASE DEFAULT
4243     CALL wrf_error_fatal( 'isfflx value invalid for diff_opt=2' )
4244   END SELECT vflux
4245
4246 !
4247 !  FINE MODIFICA al flusso di momento alla parete
4248 !*****************************************
4249 !*****************************************
4250
4251    IF ( config_flags%mix_full_fields ) THEN
4252
4253      DO j=jts,min(jte,jde-1)
4254      DO k=kts,kte-1
4255      DO i=its,min(ite,ide-1)
4256        var_mix(i,k,j) = thp(i,k,j)
4257      ENDDO
4258      ENDDO
4259      ENDDO
4260
4261    ELSE
4262
4263      DO j=jts,min(jte,jde-1)
4264      DO k=kts,kte-1
4265      DO i=its,min(ite,ide-1)
4266        var_mix(i,k,j) = thp(i,k,j) - t_base(k)
4267      ENDDO
4268      ENDDO
4269      ENDDO
4270
4271    END IF
4272
4273    CALL vertical_diffusion_s( rt_tendf, config_flags, var_mix, xkhv, &
4274                               dn, dnw, rdz, rdzw, fnm, fnp, rho,     &
4275                               .false.,                               &
4276                               ids, ide, jds, jde, kds, kde,          &
4277                               ims, ime, jms, jme, kms, kme,          &
4278                               its, ite, jts, jte, kts, kte          )
4279
4280
4281 !*****************************************
4282 !*****************************************
4283 !MODIFICA al flusso di calore
4284 !
4285 !
4286   hflux: SELECT CASE( config_flags%isfflx )
4287   CASE (0,2) ! with fixed surface heat flux given in the namelist
4288     heat_flux = config_flags%tke_heat_flux  ! constant heat flux value
4289                                             ! set in namelist.input
4290     DO j = j_start, j_end
4291     DO i = i_start, i_end
4292        cpm = cp * (1. + 0.8 * moist(i,kts,j,P_QV))
4293        hfx(i,j)=heat_flux*cpm*rho(i,kts,j)         ! provided for output only
4294        if(config_flags%use_theta_m == 1)THEN
4295          rt_tendf(i,kts,j)=rt_tendf(i,kts,j)  &
4296              -g*heat_flux*(1.+rvovrd*moist(i,kts,j,P_QV))*rho(i,kts,j)/dnw(kts) &
4297              -g*1.61*theta(i,kts,j)*qfx(i,j)/dnw(kts)
4298        ELSE
4299          rt_tendf(i,kts,j)=rt_tendf(i,kts,j)  &
4300              -g*heat_flux*rho(i,kts,j)/dnw(kts)
4301        ENDIF
4302     ENDDO
4303     ENDDO
4304
4305   CASE (1) ! use surface heat flux computed from surface routine
4306     DO j = j_start, j_end
4307     DO i = i_start, i_end
4308
4309        cpm = cp * (1. + 0.8 * moist(i,kts,j,P_QV))
4310        heat_flux = hfx(i,j)/cpm
4311        if(config_flags%use_theta_m == 1)THEN
4312          rt_tendf(i,kts,j)=rt_tendf(i,kts,j)  &
4313              -g*heat_flux*(1.+rvovrd*moist(i,kts,j,P_QV))/dnw(kts) &
4314              -g*1.61*theta(i,kts,j)*qfx(i,j)/dnw(kts)
4315        ELSE
4316          rt_tendf(i,kts,j)=rt_tendf(i,kts,j)  &
4317              -g*heat_flux/dnw(kts)
4318        ENDIF
4319
4320     ENDDO
4321     ENDDO
4322
4323   CASE DEFAULT
4324     CALL wrf_error_fatal( 'isfflx value invalid for diff_opt=2' )
4325   END SELECT hflux
4326
4327 !
4328 ! FINE MODIFICA al flusso di calore
4329 !*****************************************
4330 !*****************************************
4331
4332    If (km_opt .eq. 2) then
4333    CALL vertical_diffusion_s( tke_tendf(ims,kms,jms),               &
4334                               config_flags, tke(ims,kms,jms),       &
4335                               xkhv,                                 &
4336                               dn, dnw, rdz, rdzw, fnm, fnp, rho,    &
4337                               .true.,                               &
4338                               ids, ide, jds, jde, kds, kde,         &
4339                               ims, ime, jms, jme, kms, kme,         &
4340                               its, ite, jts, jte, kts, kte         )
4341    endif
4342
4343    IF (n_moist .ge. PARAM_FIRST_SCALAR) THEN
4344
4345      moist_loop: do im = PARAM_FIRST_SCALAR, n_moist
4346
4347        IF ( (.not. config_flags%mix_full_fields) .and. (im == P_QV) ) THEN
4348
4349          DO j=jts,min(jte,jde-1)
4350          DO k=kts,kte-1
4351          DO i=its,min(ite,ide-1)
4352           var_mix(i,k,j) = moist(i,k,j,im) - qv_base(k)
4353          ENDDO
4354          ENDDO
4355          ENDDO
4356
4357        ELSE
4358
4359          DO j=jts,min(jte,jde-1)
4360          DO k=kts,kte-1
4361          DO i=its,min(ite,ide-1)
4362           var_mix(i,k,j) = moist(i,k,j,im)
4363          ENDDO
4364          ENDDO
4365          ENDDO
4366
4367        END IF
4368
4369
4370           CALL vertical_diffusion_s( moist_tendf(ims,kms,jms,im),         &
4371                                      config_flags, var_mix,               &
4372                                      xkhv,                                &
4373                                      dn, dnw, rdz, rdzw, fnm, fnp, rho,   &
4374                                      .false.,                             &
4375                                      ids, ide, jds, jde, kds, kde,        &
4376                                      ims, ime, jms, jme, kms, kme,        &
4377                                      its, ite, jts, jte, kts, kte        )
4378
4379 !*****************************************
4380 !*****************************************
4381 !MODIFICATIONS for water vapor flux
4382 !
4383 !
4384   qflux: SELECT CASE( config_flags%isfflx )
4385   CASE (0)
4386 ! do nothing
4387   CASE (1,2) ! with surface moisture flux
4388     IF ( im == P_QV ) THEN
4389        DO j = j_start, j_end
4390        DO i = i_start, i_end
4391           moist_flux = qfx(i,j)
4392           moist_tendf(i,kts,j,im)=moist_tendf(i,kts,j,im)  &
4393                -g*moist_flux/dnw(kts)
4394        ENDDO
4395        ENDDO
4396     ENDIF
4397
4398   CASE DEFAULT
4399     CALL wrf_error_fatal( 'isfflx value invalid for diff_opt=2' )
4400   END SELECT qflux
4401 !
4402 ! END MODIFICATIONS for water vapor flux
4403 !*****************************************
4404 !*****************************************
4405      ENDDO moist_loop
4406
4407    ENDIF
4408
4409    IF (n_chem .ge. PARAM_FIRST_SCALAR) THEN
4410
4411      chem_loop: do im = PARAM_FIRST_SCALAR, n_chem
4412
4413           CALL vertical_diffusion_s( chem_tendf(ims,kms,jms,im),         &
4414                                      config_flags, chem(ims,kms,jms,im), &
4415                                      xkhv,                               &
4416                                      dn, dnw, rdz, rdzw, fnm, fnp, rho,  &
4417                                      .false.,                            &
4418                                      ids, ide, jds, jde, kds, kde,       &
4419                                      ims, ime, jms, jme, kms, kme,       &
4420                                      its, ite, jts, jte, kts, kte         )
4421      ENDDO chem_loop
4422
4423    ENDIF
4424
4425    IF (n_tracer .ge. PARAM_FIRST_SCALAR) THEN
4426
4427      tracer_loop: do im = PARAM_FIRST_SCALAR, n_tracer
4428
4429           CALL vertical_diffusion_s( tracer_tendf(ims,kms,jms,im),         &
4430                                      config_flags, tracer(ims,kms,jms,im), &
4431                                      xkhv,                                 &
4432                                      dn, dnw, rdz, rdzw, fnm, fnp, rho,    &
4433                                      .false.,                              &
4434                                      ids, ide, jds, jde, kds, kde,         &
4435                                      ims, ime, jms, jme, kms, kme,         &
4436                                      its, ite, jts, jte, kts, kte         )
4437      ENDDO tracer_loop
4438
4439    ENDIF
4440
4441
4442    IF (n_scalar .ge. PARAM_FIRST_SCALAR) THEN
4443
4444      scalar_loop: do im = PARAM_FIRST_SCALAR, n_scalar
4445
4446           CALL vertical_diffusion_s( scalar_tendf(ims,kms,jms,im),         &
4447                                      config_flags, scalar(ims,kms,jms,im), &
4448                                      xkhv,                                 &
4449                                      dn, dnw, rdz, rdzw, fnm, fnp, rho,    &
4450                                      .false.,                              &
4451                                      ids, ide, jds, jde, kds, kde,         &
4452                                      ims, ime, jms, jme, kms, kme,         &
4453                                      its, ite, jts, jte, kts, kte         )
4454      ENDDO scalar_loop
4455
4456    ENDIF
4457
4458 END SUBROUTINE vertical_diffusion_2
4459
4460 !=======================================================================
4461 !=======================================================================
4462
4463 SUBROUTINE vertical_diffusion_u_2( tendency, config_flags,                &
4464                                    defor13, xkmv,                         &
4465                                    nba_mij, n_nba_mij,                    &
4466                                    dnw, rdzw, fnm, fnp, rho,              &
4467                                    ids, ide, jds, jde, kds, kde,          &
4468                                    ims, ime, jms, jme, kms, kme,          &
4469                                    its, ite, jts, jte, kts, kte          )
4470
4471 !-----------------------------------------------------------------------
4472 ! Begin declarations.
4473
4474    IMPLICIT NONE
4475
4476    TYPE(grid_config_rec_type), INTENT(IN   ) :: config_flags
4477
4478    INTEGER ,         INTENT(IN   ) ::       ids, ide, jds, jde, kds, kde, &
4479                                             ims, ime, jms, jme, kms, kme, &
4480                                             its, ite, jts, jte, kts, kte
4481
4482    REAL , DIMENSION( kms:kme ) ,                 INTENT(IN   ) ::    fnm
4483    REAL , DIMENSION( kms:kme ) ,                 INTENT(IN   ) ::    fnp
4484    REAL , DIMENSION( kms:kme ) ,            INTENT(IN   )      :: dnw
4485 !   REAL , DIMENSION( ims:ime , jms:jme ) ,  INTENT(IN   )      :: zeta_z
4486
4487    REAL , DIMENSION( ims:ime, kms:kme, jms:jme), INTENT(INOUT) ::tendency
4488
4489    REAL , DIMENSION( ims:ime , kms:kme, jms:jme ) ,                       &
4490                                             INTENT(IN   )      ::defor13, &
4491                                                                     xkmv, &
4492                                                                     rdzw, &
4493                                                                      rho
4494
4495    INTEGER, INTENT(  IN ) :: n_nba_mij
4496
4497    REAL , DIMENSION(ims:ime, kms:kme, jms:jme, n_nba_mij), INTENT(INOUT) &
4498    :: nba_mij
4499
4500 ! LOCAL VARS
4501
4502    INTEGER :: i, j, k, ktf
4503
4504    INTEGER :: i_start, i_end, j_start, j_end
4505    INTEGER :: is_ext,ie_ext,js_ext,je_ext
4506
4507    REAL , DIMENSION( its-1:ite+1, kts:kte, jts-1:jte+1)        :: titau3
4508
4509    REAL , DIMENSION( its:ite, jts:jte)                         ::  zzavg
4510
4511    REAL :: rdzu
4512
4513 ! End declarations.
4514 !-----------------------------------------------------------------------
4515
4516    ktf=MIN(kte,kde-1)
4517
4518    i_start = its
4519    i_end   = ite
4520    j_start = jts
4521    j_end   = MIN(jte,jde-1)
4522
4523    IF ( config_flags%open_xs .or. config_flags%specified .or. &
4524         config_flags%nested) i_start = MAX(ids+1,its)
4525    IF ( config_flags%open_xe .or. config_flags%specified .or. &
4526         config_flags%nested) i_end   = MIN(ide-1,ite)
4527    IF ( config_flags%open_ys .or. config_flags%specified .or. &
4528         config_flags%nested) j_start = MAX(jds+1,jts)
4529    IF ( config_flags%open_ye .or. config_flags%specified .or. &
4530         config_flags%nested) j_end   = MIN(jde-2,jte)
4531       IF ( config_flags%periodic_x ) i_start = its
4532       IF ( config_flags%periodic_x ) i_end = ite
4533
4534 ! titau3 = titau13
4535    is_ext=0
4536    ie_ext=0
4537    js_ext=0
4538    je_ext=0
4539    CALL cal_titau_13_31( config_flags, titau3, defor13,   &
4540                          nba_mij(ims,kms,jms,P_m13),      &
4541                          xkmv, fnm, fnp, rho,             &
4542                          is_ext, ie_ext, js_ext, je_ext,  &
4543                          ids, ide, jds, jde, kds, kde,    &
4544                          ims, ime, jms, jme, kms, kme,    &
4545                          its, ite, jts, jte, kts, kte     )
4546 !
4547       DO j = j_start, j_end
4548       DO k=kts+1,ktf
4549       DO i = i_start, i_end
4550
4551          rdzu = -g/(dnw(k))
4552          tendency(i,k,j)=tendency(i,k,j)-rdzu*(titau3(i,k+1,j)-titau3(i,k,j))
4553
4554       ENDDO
4555       ENDDO
4556       ENDDO
4557
4558 ! ******** MODIF...
4559 !  we will pick up the surface drag (titau3(i,kts,j)) later
4560 !
4561        DO j = j_start, j_end
4562        k=kts
4563        DO i = i_start, i_end
4564
4565           rdzu = -g/dnw(k)
4566           tendency(i,k,j)=tendency(i,k,j)-rdzu*(titau3(i,k+1,j))
4567        ENDDO
4568        ENDDO
4569 ! ******** MODIF...
4570
4571 END SUBROUTINE vertical_diffusion_u_2
4572
4573 !=======================================================================
4574 !=======================================================================
4575
4576 SUBROUTINE vertical_diffusion_v_2( tendency, config_flags,                &
4577                                    defor23, xkmv,                         &
4578                                    nba_mij, n_nba_mij,                    &
4579                                    dnw, rdzw, fnm, fnp, rho,              &
4580                                    ids, ide, jds, jde, kds, kde,          &
4581                                    ims, ime, jms, jme, kms, kme,          &
4582                                    its, ite, jts, jte, kts, kte          )
4583 !-----------------------------------------------------------------------
4584 ! Begin declarations.
4585
4586    IMPLICIT NONE
4587
4588    TYPE(grid_config_rec_type), INTENT(IN   ) :: config_flags
4589
4590    INTEGER ,         INTENT(IN   ) ::       ids, ide, jds, jde, kds, kde, &
4591                                             ims, ime, jms, jme, kms, kme, &
4592                                             its, ite, jts, jte, kts, kte
4593    REAL , DIMENSION( kms:kme ) ,                 INTENT(IN   ) ::    fnm
4594    REAL , DIMENSION( kms:kme ) ,                 INTENT(IN   ) ::    fnp
4595    REAL , DIMENSION( kms:kme ) ,            INTENT(IN   )      :: dnw
4596 !   REAL , DIMENSION( ims:ime , jms:jme ) ,  INTENT(IN   )      :: zeta_z
4597
4598    REAL , DIMENSION( ims:ime, kms:kme, jms:jme), INTENT(INOUT) ::tendency
4599
4600    REAL , DIMENSION( ims:ime , kms:kme, jms:jme ) ,                       &
4601                                             INTENT(IN   )      ::defor23, &
4602                                                                     xkmv, &
4603                                                                     rdzw, &
4604                                                                      rho
4605
4606    INTEGER, INTENT(  IN ) :: n_nba_mij
4607
4608    REAL , DIMENSION(ims:ime, kms:kme, jms:jme, n_nba_mij),  INTENT(INOUT) &
4609    :: nba_mij
4610
4611 ! LOCAL VARS
4612
4613    INTEGER :: i, j, k, ktf
4614
4615    INTEGER :: i_start, i_end, j_start, j_end
4616    INTEGER :: is_ext,ie_ext,js_ext,je_ext
4617
4618    REAL , DIMENSION( its-1:ite+1, kts:kte, jts-1:jte+1)        :: titau3
4619
4620    REAL , DIMENSION( its:ite, jts:jte)                         ::  zzavg
4621
4622    REAL  :: rdzv
4623
4624 ! End declarations.
4625 !-----------------------------------------------------------------------
4626
4627    ktf=MIN(kte,kde-1)
4628
4629    i_start = its
4630    i_end   = MIN(ite,ide-1)
4631    j_start = jts
4632    j_end   = jte
4633
4634    IF ( config_flags%open_xs .or. config_flags%specified .or. &
4635         config_flags%nested) i_start = MAX(ids+1,its)
4636    IF ( config_flags%open_xe .or. config_flags%specified .or. &
4637         config_flags%nested) i_end   = MIN(ide-2,ite)
4638    IF ( config_flags%open_ys .or. config_flags%specified .or. &
4639         config_flags%nested) j_start = MAX(jds+1,jts)
4640    IF ( config_flags%open_ye .or. config_flags%specified .or. &
4641         config_flags%nested) j_end   = MIN(jde-1,jte)
4642       IF ( config_flags%periodic_x ) i_start = its
4643       IF ( config_flags%periodic_x ) i_end = MIN(ite,ide-1)
4644
4645 ! titau3 = titau23
4646    is_ext=0
4647    ie_ext=0
4648    js_ext=0
4649    je_ext=0
4650    CALL cal_titau_23_32( config_flags, titau3, defor23,   &
4651                          nba_mij(ims,kms,jms,P_m23),      &
4652                          xkmv, fnm, fnp, rho,             &
4653                          is_ext, ie_ext, js_ext, je_ext,  &
4654                          ids, ide, jds, jde, kds, kde,    &
4655                          ims, ime, jms, jme, kms, kme,    &
4656                          its, ite, jts, jte, kts, kte     )
4657
4658    DO j = j_start, j_end
4659    DO k = kts+1,ktf
4660    DO i = i_start, i_end
4661
4662       rdzv = - g / dnw(k)
4663       tendency(i,k,j)=tendency(i,k,j)-rdzv*(titau3(i,k+1,j)-titau3(i,k,j))
4664
4665    ENDDO
4666    ENDDO
4667    ENDDO
4668
4669 ! ******** MODIF...
4670 !  we will pick up the surface drag (titau3(i,kts,j)) later
4671 !
4672        DO j = j_start, j_end
4673        k=kts
4674        DO i = i_start, i_end
4675
4676         rdzv = - g / dnw(k)
4677         tendency(i,k,j)=tendency(i,k,j)-rdzv*(titau3(i,k+1,j))
4678
4679        ENDDO
4680        ENDDO
4681 ! ******** MODIF...
4682
4683 END SUBROUTINE vertical_diffusion_v_2
4684
4685 !=======================================================================
4686 !=======================================================================
4687
4688 SUBROUTINE vertical_diffusion_w_2(tendency, config_flags,                 &
4689                                 defor33, tke,                             &
4690                                 nba_mij, n_nba_mij,                       &
4691                                 div, xkmh,                                &
4692                                 dn, rdz, fnm, fnp, rho,                   &
4693                                 ids, ide, jds, jde, kds, kde,             &
4694                                 ims, ime, jms, jme, kms, kme,             &
4695                                 its, ite, jts, jte, kts, kte              )
4696
4697 !-----------------------------------------------------------------------
4698 ! Begin declarations.
4699
4700    IMPLICIT NONE
4701
4702    TYPE(grid_config_rec_type), INTENT(IN   ) :: config_flags
4703
4704    INTEGER ,         INTENT(IN   ) ::       ids, ide, jds, jde, kds, kde, &
4705                                             ims, ime, jms, jme, kms, kme, &
4706                                             its, ite, jts, jte, kts, kte
4707
4708    REAL , DIMENSION( kms:kme ) ,            INTENT(IN   )      ::  dn, fnm, fnp
4709
4710    REAL , DIMENSION( ims:ime, kms:kme, jms:jme), INTENT(INOUT) ::tendency
4711
4712    REAL , DIMENSION( ims:ime , kms:kme, jms:jme ) ,                       &
4713                                             INTENT(IN   )      ::defor33, &
4714                                                                      tke, &
4715                                                                      div, &
4716                                                                     xkmh, &
4717                                                                      rdz, &
4718                                                                      rho
4719
4720    INTEGER, INTENT(  IN ) :: n_nba_mij
4721
4722    REAL , DIMENSION(ims:ime, kms:kme, jms:jme, n_nba_mij),  INTENT(INOUT) &
4723    :: nba_mij
4724
4725 ! LOCAL VARS
4726
4727    INTEGER :: i, j, k, ktf
4728
4729    INTEGER :: i_start, i_end, j_start, j_end
4730    INTEGER :: is_ext,ie_ext,js_ext,je_ext
4731
4732    REAL , DIMENSION( its-1:ite+1, kts:kte, jts-1:jte+1)        :: titau3
4733
4734 ! End declarations.
4735 !-----------------------------------------------------------------------
4736
4737    ktf=MIN(kte,kde-1)
4738
4739    i_start = its
4740    i_end   = MIN(ite,ide-1)
4741    j_start = jts
4742    j_end   = MIN(jte,jde-1)
4743
4744    IF ( config_flags%open_xs .or. config_flags%specified .or. &
4745         config_flags%nested) i_start = MAX(ids+1,its)
4746    IF ( config_flags%open_xe .or. config_flags%specified .or. &
4747         config_flags%nested) i_end   = MIN(ide-2,ite)
4748    IF ( config_flags%open_ys .or. config_flags%specified .or. &
4749         config_flags%nested) j_start = MAX(jds+1,jts)
4750    IF ( config_flags%open_ye .or. config_flags%specified .or. &
4751         config_flags%nested) j_end   = MIN(jde-2,jte)
4752       IF ( config_flags%periodic_x ) i_start = its
4753       IF ( config_flags%periodic_x ) i_end = MIN(ite,ide-1)
4754
4755 ! titau3 = titau33
4756    is_ext=0
4757    ie_ext=0
4758    js_ext=0
4759    je_ext=0
4760    CALL cal_titau_11_22_33( config_flags, titau3,            &
4761                             tke, xkmh, defor33,              &
4762                             nba_mij(ims,kms,jms,P_m33), rho, &
4763                             is_ext, ie_ext, js_ext, je_ext,  &
4764                             ids, ide, jds, jde, kds, kde,    &
4765                             ims, ime, jms, jme, kms, kme,    &
4766                             its, ite, jts, jte, kts, kte     )
4767
4768 !   DO j = j_start, j_end
4769 !   DO k = kts+1, ktf
4770 !   DO i = i_start, i_end
4771 !      titau3(i,k,j)=titau3(i,k,j)*zeta_z(i,j)
4772 !   ENDDO
4773 !   ENDDO
4774 !   ENDDO
4775
4776    DO j = j_start, j_end
4777    DO k = kts+1, ktf
4778    DO i = i_start, i_end
4779        tendency(i,k,j)=tendency(i,k,j)+   g*(titau3(i,k,j)-titau3(i,k-1,j))/dn(k)
4780    ENDDO
4781    ENDDO
4782    ENDDO
4783
4784 END SUBROUTINE vertical_diffusion_w_2
4785
4786 !=======================================================================
4787 !=======================================================================
4788
4789 SUBROUTINE vertical_diffusion_s( tendency, config_flags, var, xkhv,       &
4790                                  dn, dnw, rdz, rdzw, fnm, fnp, rho,       &
4791                                  doing_tke,                               &
4792                                  ids, ide, jds, jde, kds, kde,            &
4793                                  ims, ime, jms, jme, kms, kme,            &
4794                                  its, ite, jts, jte, kts, kte            )
4795
4796 !-----------------------------------------------------------------------
4797 ! Begin declarations.
4798
4799    IMPLICIT NONE
4800
4801    TYPE(grid_config_rec_type), INTENT(IN   ) :: config_flags
4802
4803    INTEGER ,         INTENT(IN   ) ::       ids, ide, jds, jde, kds, kde, &
4804                                             ims, ime, jms, jme, kms, kme, &
4805                                             its, ite, jts, jte, kts, kte
4806
4807    LOGICAL,         INTENT(IN   ) ::        doing_tke
4808
4809    REAL , DIMENSION( kms:kme ) ,                 INTENT(IN   ) ::    fnm
4810    REAL , DIMENSION( kms:kme ) ,                 INTENT(IN   ) ::    fnp
4811    REAL , DIMENSION( kms:kme ) ,            INTENT(IN   )      ::  dn
4812    REAL , DIMENSION( kms:kme ) ,            INTENT(IN   )      :: dnw
4813
4814    REAL , DIMENSION( ims:ime, kms:kme, jms:jme), INTENT(INOUT) ::tendency
4815
4816    REAL , DIMENSION( ims:ime , kms:kme, jms:jme ) , INTENT(IN) ::   xkhv
4817
4818    REAL , DIMENSION( ims:ime , kms:kme, jms:jme ) ,                       &
4819                                             INTENT(IN   )      ::    var, &
4820                                                                      rdz, &
4821                                                                     rdzw, &
4822                                                                      rho
4823 ! LOCAL VARS
4824
4825    INTEGER :: i, j, k, ktf
4826
4827    INTEGER :: i_start, i_end, j_start, j_end
4828
4829    REAL , DIMENSION( its:ite, kts:kte, jts:jte)            ::        H3, &
4830                                                                  xkxavg, &
4831                                                                   rravg
4832
4833    REAL , DIMENSION( its:ite, kts:kte, jts:jte)            ::  tmptendf
4834
4835 ! End declarations.
4836 !-----------------------------------------------------------------------
4837
4838    ktf=MIN(kte,kde-1)
4839
4840    i_start = its
4841    i_end   = MIN(ite,ide-1)
4842    j_start = jts
4843    j_end   = MIN(jte,jde-1)
4844
4845    IF ( config_flags%open_xs .or. config_flags%specified .or. &
4846         config_flags%nested) i_start = MAX(ids+1,its)
4847    IF ( config_flags%open_xe .or. config_flags%specified .or. &
4848         config_flags%nested) i_end   = MIN(ide-2,ite)
4849    IF ( config_flags%open_ys .or. config_flags%specified .or. &
4850         config_flags%nested) j_start = MAX(jds+1,jts)
4851    IF ( config_flags%open_ye .or. config_flags%specified .or. &
4852         config_flags%nested) j_end   = MIN(jde-2,jte)
4853       IF ( config_flags%periodic_x ) i_start = its
4854       IF ( config_flags%periodic_x ) i_end = MIN(ite,ide-1)
4855
4856    IF (doing_tke) THEN
4857       DO j = j_start, j_end
4858       DO k = kts,ktf
4859       DO i = i_start, i_end
4860          tmptendf(i,k,j)=tendency(i,k,j)
4861       ENDDO
4862       ENDDO
4863       ENDDO
4864    ENDIF
4865
4866 ! H3
4867
4868    xkxavg = 0.
4869
4870    DO j = j_start, j_end
4871    DO k = kts+1,ktf
4872    DO i = i_start, i_end
4873       xkxavg(i,k,j)=fnm(k)*xkhv(i,k,j)+fnp(k)*xkhv(i,k-1,j)
4874       xkxavg(i,k,j)=xkxavg(i,k,j)*(fnm(k)*rho(i,k,j)+fnp(k)*rho(i,k-1,j))
4875       H3(i,k,j)=-xkxavg(i,k,j)*(var(i,k,j)-var(i,k-1,j))*rdz(i,k,j)
4876    ENDDO
4877    ENDDO
4878    ENDDO
4879
4880    DO j = j_start, j_end
4881    DO i = i_start, i_end
4882       H3(i,kts,j)=0.
4883       H3(i,ktf+1,j)=0.
4884    ENDDO
4885    ENDDO
4886
4887    DO j = j_start, j_end
4888    DO k = kts,ktf
4889    DO i = i_start, i_end
4890       tendency(i,k,j)=tendency(i,k,j)  &
4891                        +   g * (H3(i,k+1,j)-H3(i,k,j))/dnw(k)
4892    ENDDO
4893    ENDDO
4894    ENDDO
4895
4896    IF (doing_tke) THEN
4897       DO j = j_start, j_end
4898       DO k = kts,ktf
4899       DO i = i_start, i_end
4900           tendency(i,k,j)=tmptendf(i,k,j)+2.* &
4901                           (tendency(i,k,j)-tmptendf(i,k,j))
4902       ENDDO
4903       ENDDO
4904       ENDDO
4905    ENDIF
4906
4907 END SUBROUTINE vertical_diffusion_s
4908
4909 !=======================================================================
4910 !=======================================================================
4911  SUBROUTINE nonlocal_flux (config_flags,nlflux,gamu,gamv,hpbl,kpbl,     &
4912                                   dx,dy,dt,ust,hfx,qfx,br,ep1,ep2,      &
4913                                   karman,u_phy,v_phy,th_phy,rho,moist,n_moist, &
4914                                   msftx,msfty,rdzw,                            &
4915                                   u10,v10,wspd,                                &
4916                                   ids, ide, jds, jde, kds, kde,     &
4917                                   ims, ime, jms, jme, kms, kme,     &
4918                                   its, ite, jts, jte, kts, kte      )
4919 !-----------------------------------------------------------------------
4920 !This subroutine prescibes the nonlocal heat flux profile based on LES analysis
4921 !And compute the nonlocal momentum gamma term
4922 !References:
4923 ! Shin and Hong 2015, MWR
4924 ! Xu Zhang et al. 2018, MWR
4925 !-----------------------------------------------------------------------
4926 ! Begin declarations.
4927
4928    IMPLICIT NONE
4929
4930    TYPE(grid_config_rec_type), INTENT(IN   ) :: config_flags
4931
4932    INTEGER ,         INTENT(IN   ) ::       ids, ide, jds, jde, kds, kde, &
4933                                             ims, ime, jms, jme, kms, kme, &
4934                                             its, ite, jts, jte, kts, kte
4935
4936    INTEGER ,         INTENT(IN   ) :: n_moist
4937
4938    REAL,    INTENT(IN )     ::      ep1,ep2,karman
4939
4940    REAL,    INTENT(IN )     ::      dx,dy,dt
4941
4942    REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(IN) ::   &
4943    th_phy,u_phy,v_phy
4944
4945    REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(IN) :: rdzw
4946
4947    REAL, DIMENSION( ims:ime, kms:kme, jms:jme, n_moist ), INTENT( INOUT ) :: &
4948    moist
4949
4950    REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(IN) :: rho
4951
4952    REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT)   :: hfx,qfx,br,ust,hpbl
4953
4954    REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN   )   :: u10,v10,wspd
4955
4956    REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN   )   :: msftx,msfty
4957
4958    REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(OUT) :: nlflux
4959
4960    REAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT   )  :: gamu,gamv
4961
4962    INTEGER, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT   )  :: kpbl
4963
4964 ! Local variables.
4965   REAL, DIMENSION( its:ite, kts:kte,   jts:jte ) :: zq
4966   REAL, DIMENSION( its:ite, kts:kte-1, jts:jte ) :: za,thv
4967   REAL, DIMENSION( its:ite, kts:kte,   jts:jte ) :: zfacmf,entfacmf
4968   REAL, DIMENSION( its:ite, jts:jte )            :: govrth,sflux,wstar3,wstar,rigs
4969   LOGICAL, DIMENSION( its:ite,jts:jte )          :: pblflg, sfcflg, stable
4970   REAL, DIMENSION( its:ite, jts:jte )            :: deltaoh,we,enlfrac2
4971   REAL, DIMENSION( its:ite, jts:jte )            :: hfxpbl,bfxpbl
4972   REAL, DIMENSION( its:ite, jts:jte )            :: dthv,wm2
4973   REAL, DIMENSION( its:ite, jts:jte )            :: wscale,thermal
4974   REAL               :: tvcon,delb,cpm,wm3,bfx0,ust3
4975   REAL               :: dtheta,du,dv,thsfc,brint
4976   INTEGER            :: i,j,k,i_start,i_end,j_start,j_end,ktf
4977   REAL               :: mlfrac,ezfrac,sfcfracn,sflux0,snlflux0
4978   REAL               :: amf1,amf2,amf3,bmf2,bmf3,pth1,delxy,pu1
4979   REAL               :: heat_flux
4980   REAL,PARAMETER     :: phifac = 8.,sfcfrac = 0.1,d1 = 0.02, d2 = 0.05, zfmin = 1.e-8
4981   REAL,PARAMETER     :: h1 = 0.33333335, h2 = 0.6666667, tmin = 1.e-2
4982 ! tunable parameters
4983   REAL,PARAMETER     ::  mltop = 1.0, sfcfracn1 = 0.075
4984   REAL,PARAMETER     ::  nlfrac = 0.68 ! the ratio of nonlocal heat flux to total heat flux
4985   REAL,PARAMETER     ::  enlfrac = -0.15
4986   REAL,PARAMETER     ::  a11 = 1.0, a12 = -1.15
4987   REAL,PARAMETER     ::  ezfac = 1.5
4988   REAL,PARAMETER     ::  cpent = -0.4, rigsmax = 100., rimin = -100.
4989   REAL,PARAMETER     ::  entfmin = 1.0, entfmax = 5.0, sm = 10.9
4990
4991    ktf=MIN(kte,kde-1)
4992
4993    i_start = its
4994    i_end   = MIN(ite,ide-1)
4995    j_start = jts
4996    j_end   = MIN(jte,jde-1)
4997
4998    IF ( config_flags%open_xs .or. config_flags%specified .or. &
4999         config_flags%nested) i_start = MAX(ids+1,its)
5000    IF ( config_flags%open_xe .or. config_flags%specified .or. &
5001         config_flags%nested) i_end   = MIN(ide-2,ite)
5002    IF ( config_flags%open_ys .or. config_flags%specified .or. &
5003         config_flags%nested) j_start = MAX(jds+1,jts)
5004    IF ( config_flags%open_ye .or. config_flags%specified .or. &
5005         config_flags%nested) j_end   = MIN(jde-2,jte)
5006    IF ( config_flags%periodic_x ) i_start = its
5007    IF ( config_flags%periodic_x ) i_end = MIN(ite,ide-1)
5008
5009    DO j = j_start, j_end
5010    DO i = i_start, i_end
5011        zq(i,1,j) = 0.0
5012    ENDDO
5013    ENDDO
5014
5015    DO j = j_start, j_end
5016    DO k = kts, ktf
5017    DO i = i_start, i_end
5018          zq(i,k+1,j) = 1.0/rdzw(i,k,j) + zq(i,k,j)
5019    ENDDO
5020    ENDDO
5021    ENDDO
5022
5023    DO j = j_start,j_end
5024    DO k = kts,ktf
5025    DO i = i_start,i_end
5026      za(i,k,j) = 0.5*(zq(i,k,j) + zq(i,k+1,j))
5027    ENDDO
5028    ENDDO
5029    ENDDO
5030
5031    DO j = j_start, j_end
5032    DO i = i_start, i_end
5033      deltaoh(i,j)  = 0.0
5034      rigs (i,j)    = 0.0
5035      enlfrac2(i,j) = 0.0
5036    ENDDO
5037    ENDDO
5038
5039    DO j = j_start, j_end
5040    DO k = kts, ktf
5041    DO i = i_start, i_end
5042       zfacmf(i,k,j) = 0.0
5043    ENDDO
5044    ENDDO
5045    ENDDO
5046
5047    DO j = j_start, j_end
5048    DO k = kts, ktf
5049    DO i = i_start, i_end
5050       nlflux(i,k,j) = 0.0
5051    ENDDO
5052    ENDDO
5053    ENDDO
5054
5055    DO j = j_start, j_end
5056    DO k = kts, ktf
5057    DO i = i_start, i_end
5058       tvcon = 1. + ep1*moist(i,k,j,P_QV)
5059       thv(i,k,j) = th_phy(i,k,j)*tvcon
5060    ENDDO
5061    ENDDO
5062    ENDDO
5063
5064    DO j = j_start,j_end
5065    DO i = i_start,i_end
5066      govrth(i,j) = g/th_phy(i,1,j)
5067    ENDDO
5068    ENDDO
5069
5070   hflux: SELECT CASE( config_flags%isfflx )
5071   CASE (0,2) ! with fixed surface heat flux given in the namelist
5072     heat_flux = config_flags%tke_heat_flux  ! constant heat flux value
5073     DO j = j_start, j_end
5074     DO i = i_start, i_end
5075        cpm = cp * (1. + 0.8 * moist(i,kts,j,P_QV))
5076        hfx(i,j)= heat_flux*cpm*rho(i,1,j)
5077     ENDDO
5078     ENDDO
5079
5080   CASE (1) ! use surface heat flux computed from surface routine
5081     DO j = j_start, j_end
5082     DO i = i_start, i_end
5083        cpm = cp * (1. + 0.8 * moist(i,kts,j,P_QV))
5084        heat_flux = hfx(i,j)/cpm/rho(i,1,j)
5085     ENDDO
5086     ENDDO
5087
5088   CASE DEFAULT
5089     CALL wrf_error_fatal( 'isfflx value invalid for diff_opt=2' )
5090   END SELECT hflux
5091
5092   DO j = j_start, j_end
5093   DO i = i_start, i_end
5094      kpbl(i,j)   = 1
5095      hpbl(i,j)   = zq(i,1,j)
5096      pblflg(i,j) = .true.
5097      sfcflg(i,j) = .true.
5098
5099      cpm = cp * (1. + 0.8*moist(i,1,j,P_QV))
5100      sflux(i,j) = (hfx(i,j)/cpm)/rho(i,1,j)
5101
5102      IF(br(i,j).GT.0.0) sfcflg(i,j) = .false.
5103   ENDDO
5104   ENDDO
5105
5106 ! get pbl height begin based on theta method
5107   DO j = j_start, j_end
5108   DO i = i_start, i_end
5109         thsfc = thv(i,kts,j) + 0.5
5110      DO k=kts+1,ktf
5111         IF(thv(i,k,j).GT.thsfc) THEN
5112          hpbl(i,j)=za(i,k-1,j)+(thsfc-thv(i,k-1,j))/(max(0.01,thv(i,k,j)-thv(i,k-1,j)))*(za(i,k,j)-za(i,k-1,j))
5113          kpbl(i,j) = k
5114          GO TO 119
5115         ENDIF
5116      ENDDO
5117   119 CONTINUE
5118   ENDDO
5119   ENDDO
5120
5121   DO j = j_start, j_end
5122   DO i = i_start, i_end
5123      IF(hpbl(i,j).LT.zq(i,2,j)) kpbl(i,j) = 1
5124      IF(kpbl(i,j).LE.1) pblflg(i,j) = .false.
5125   ENDDO
5126   ENDDO
5127
5128   DO j = j_start, j_end
5129   DO i = i_start, i_end
5130      IF(sfcflg(i,j))THEN
5131        bfx0  = max(sflux(i,j),0.)
5132        wstar3(i,j) = (govrth(i,j)*bfx0*hpbl(i,j))
5133        wstar(i,j)  = (wstar3(i,j))**h1
5134      ELSE
5135        wstar(i,j)  = 0.
5136        wstar3(i,j) = 0.
5137      ENDIF
5138        ust3 = ust(i,j)**3
5139        wscale(i,j) = (ust3 + phifac*karman*wstar3(i,j)*0.5)**h1
5140        wscale(i,j) = MIN(wscale(i,j), ust(i,j)*16.0)
5141        wscale(i,j) = MAX(wscale(i,j), ust(i,j)/5.0 )
5142   ENDDO
5143   ENDDO
5144
5145   DO j = j_start, j_end
5146   DO i = i_start, i_end
5147       delxy = sqrt(dx/msftx(i,j)*dy/msfty(i,j))
5148       pu1=pu(delxy,hpbl(i,j))
5149       IF((sfcflg(i,j).and.sflux(i,j).GT.0.0) .and. (hpbl(i,j) .GT. 0)) THEN
5150 !nonlocal momentum flux based on Brown and Grant (1997)
5151        brint = -sm*ust(i,j)*ust(i,j)*wstar3(i,j)/(hpbl(i,j)*wscale(i,j)**4)
5152        gamu(i,j) = pu1 * brint*u_phy(i,1,j)/wspd(i,j)
5153        gamv(i,j) = pu1 * brint*v_phy(i,1,j)/wspd(i,j)
5154       ELSE
5155        pblflg(i,j) = .false.
5156       ENDIF
5157   ENDDO
5158   ENDDO
5159
5160   DO j = j_start,j_end
5161   DO i = i_start,i_end
5162      IF(pblflg(i,j))THEN
5163        k = kpbl(i,j) - 1
5164        wm3           = wstar3(i,j) + 5. * ust(i,j)**3
5165        wm2(i,j)      = wm3**h2
5166        bfxpbl(i,j)   = -0.15*thv(i,1,j)/g*wm3/hpbl(i,j)
5167        dthv(i,j)     = max(thv(i,k+1,j) - thv(i,k,j),tmin)
5168        dtheta        = max(th_phy(i,k+1,j) - th_phy(i,k,j),tmin)
5169
5170        du            = u_phy(i,k+1,j)-u_phy(i,k,j)
5171        dv            = v_phy(i,k+1,j)-v_phy(i,k,j)
5172
5173        we(i,j)       = max(bfxpbl(i,j)/dthv(i,j),-sqrt(wm2(i,j)))
5174        hfxpbl(i,j)   = we(i,j)*dtheta
5175        delb          = govrth(i,j)*dthv(i,j)
5176
5177        deltaoh(i,j)  = d1*hpbl(i,j) + d2*wm2(i,j)/delb
5178        deltaoh(i,j)  = max(ezfac*deltaoh(i,j),hpbl(i,j)-za(i,k,j)-1.)
5179        deltaoh(i,j)  = min(deltaoh(i,j), hpbl(i,j))
5180
5181        if ((du .ne. 0) .or. (dv .ne. 0)) then
5182            rigs(i,j) = govrth(i,j)*dthv(i,j)*deltaoh(i,j)/(du**2.+dv**2.)
5183            rigs(i,j) = max(min(rigs(i,j), rigsmax),rimin)
5184        else
5185            rigs(i,j) = rigsmax
5186        endif
5187        enlfrac2(i,j) = max(min(wm3/wstar3(i,j)/(1.+cpent/rigs(i,j)),entfmax),entfmin)
5188        enlfrac2(i,j) = enlfrac2(i,j)*enlfrac
5189      ENDIF
5190   ENDDO
5191   ENDDO
5192
5193   DO j = j_start, j_end
5194   DO k = kts, ktf
5195   DO i = i_start, i_end
5196        IF(pblflg(i,j))THEN
5197           entfacmf(i,k,j) = sqrt(((zq(i,k+1,j) - hpbl(i,j))/deltaoh(i,j))**2.)
5198        ENDIF
5199   ENDDO
5200   ENDDO
5201   ENDDO
5202
5203   DO j = j_start, j_end
5204   DO i = i_start, i_end
5205      IF (pblflg(i,j)) THEN
5206          deltaoh(i,j) = deltaoh(i,j)/hpbl(i,j)
5207          delxy = sqrt(dx/msftx(i,j)*dy/msfty(i,j))
5208          mlfrac        = mltop-deltaoh(i,j)
5209          ezfrac        = mltop+deltaoh(i,j)
5210          zfacmf(i,1,j) = min(max((zq(i,2,j)/hpbl(i,j)),zfmin),1.)
5211          sfcfracn      = max(sfcfracn1,zfacmf(i,1,j))
5212     !
5213          sflux0      = (a11+a12*sfcfracn)*sflux(i,j)
5214          snlflux0    = nlfrac*sflux0
5215          amf1        = snlflux0/sfcfracn
5216          amf2        = -snlflux0/(mlfrac-sfcfracn)
5217          bmf2        = -mlfrac*amf2
5218          amf3        = snlflux0*enlfrac2(i,j)/deltaoh(i,j)
5219          bmf3        = -amf3*mlfrac
5220          hfxpbl(i,j) = amf3+bmf3
5221          pth1        = pthnl(delxy,hpbl(i,j))
5222          hfxpbl(i,j) = hfxpbl(i,j)*pth1
5223
5224         DO k = kts, ktf
5225            zfacmf(i,k,j) = max((zq(i,k+1,j)/hpbl(i,j)),zfmin)
5226            IF(k.LT.kpbl(i,j)) THEN
5227              IF(zfacmf(i,k,j).LE.sfcfracn) THEN
5228                nlflux(i,k,j) =  amf1*zfacmf(i,k,j)
5229              ELSE IF (zfacmf(i,k,j).LE.mlfrac) THEN
5230                nlflux(i,k,j) =  amf2*zfacmf(i,k,j)+bmf2
5231              ENDIF
5232              nlflux(i,k,j) = nlflux(i,k,j) + hfxpbl(i,j)*exp(-entfacmf(i,k,j))
5233              nlflux(i,k,j) = nlflux(i,k,j)*pth1
5234            ENDIF
5235         ENDDO
5236     ENDIF
5237   ENDDO
5238   ENDDO
5239 END SUBROUTINE nonlocal_flux
5240
5241 !==============================================================================
5242 !==============================================================================
5243
5244 ! partial function for nonlocal heat flux
5245    FUNCTION pthnl(d,h)
5246    IMPLICIT NONE
5247    REAL           :: pthnl
5248    REAL,PARAMETER :: pmin = 0.0,pmax = 1.0
5249    REAL,PARAMETER :: a1 = 1.000, a2 = 0.936, a3 = -1.110,         &
5250                      a4 = 1.000, a5 = 0.312, a6 = 0.329, a7 = 0.243
5251    REAL,PARAMETER :: b1 = 2.0, b2 = 0.875
5252    real           :: d,h,doh,num,den
5253
5254    if (h .ne. 0) then
5255       doh   = d/h
5256       num   = a1*(doh)**b1 + a2*(doh)**b2+a3
5257       den   = a4*(doh)**b1 + a5*(doh)**b2+a6
5258       pthnl = a7*num/den + (1. - a7)
5259    else
5260       pthnl = 1.
5261    endif
5262
5263    pthnl = max(pthnl,pmin)
5264    pthnl = min(pthnl,pmax)
5265
5266    IF(d.LE.100.) THEN  ! assume dx<=100m as LES
5267       pthnl = 0.0
5268    ENDIF
5269
5270    RETURN
5271    END FUNCTION
5272
5273 ! partial function for local heat flux
5274    FUNCTION pthl(d,h)
5275    IMPLICIT NONE
5276    REAL           :: pthl
5277    REAL,PARAMETER :: pmin = 0.0,pmax = 1.0
5278    REAL,PARAMETER :: a1 = 1.000, a2 = 0.870, a3 = -0.913,    &
5279                      a4 = 1.000, a5 = 0.153, a6 = 0.278, a7 = 0.280
5280    REAL,PARAMETER :: b1 = 2.0, b2 = 0.5
5281    REAL           :: d,h,doh,num,den
5282
5283    if (h .ne. 0) then
5284       doh  = d/h
5285       num  = a1*(doh)**b1 + a2*(doh)**b2+a3
5286       den  = a4*(doh)**b1 + a5*(doh)**b2+a6
5287       pthl = a7*num/den+(1. - a7)
5288    else
5289       pthl = 1.
5290    endif
5291    pthl = max(pthl,pmin)
5292    pthl = min(pthl,pmax)
5293
5294    IF(d.LE.100.) THEN  ! assume dx<=100m as LES
5295       pthl = 0.0
5296    ENDIF
5297
5298    RETURN
5299    END FUNCTION
5300
5301 ! partial function for momentum flux
5302    FUNCTION pu(d,h)
5303    IMPLICIT NONE
5304    REAL           :: pu
5305    REAL,PARAMETER :: pmin = 0.0,pmax = 1.0
5306    REAL,PARAMETER :: a1 = 1.0, a2 = 0.070, a3 = 1.0, a4 = 0.142, a5 = 0.071
5307    REAL,PARAMETER :: b1 = 2.0, b2 = 0.6666667
5308    REAL           :: d,h,doh,num,den
5309
5310    if (h .ne. 0) then
5311       doh = d/h
5312       num = a1*(doh)**b1 + a2*(doh)**b2
5313       den = a3*(doh)**b1 + a4*(doh)**b2+a5
5314       pu  = num/den
5315    else
5316       pu = 1.
5317    endif
5318    pu  = max(pu,pmin)
5319    pu  = min(pu,pmax)
5320
5321    IF(d.LE.100.) THEN  ! assume dx<=100 as LES
5322       pu = 0.0
5323    ENDIF
5324
5325    RETURN
5326    END FUNCTION
5327
5328 !=======================================================================
5329 !=======================================================================
5330
5331     SUBROUTINE cal_titau_11_22_33( config_flags, titau,              &
5332                                    tke, xkx, defor,                  &
5333                                    mtau, rho,                        &
5334                                    is_ext, ie_ext, js_ext, je_ext,   &
5335                                    ids, ide, jds, jde, kds, kde,     &
5336                                    ims, ime, jms, jme, kms, kme,     &
5337                                    its, ite, jts, jte, kts, kte      )
5338
5339 ! History:     Sep 2003  Changes by George Bryan and Jason Knievel, NCAR
5340 !              Oct 2001  Converted to mass core by Bill Skamarock, NCAR
5341 !              Aug 2000  Original code by Shu-Hua Chen, UC-Davis
5342
5343 ! Purpose:     This routine calculates stress terms (taus) for use in
5344 !              the calculation of production of TKE by sheared wind
5345
5346 ! References:  Klemp and Wilhelmson (JAS 1978)
5347 !              Deardorff (B-L Meteor 1980)
5348 !              Chen and Dudhia (NCAR WRF physics report 2000)
5349
5350 ! Key:
5351
5352 !-----------------------------------------------------------------------
5353 ! Begin declarations.
5354
5355     IMPLICIT NONE
5356
5357     TYPE( grid_config_rec_type ), INTENT( IN )  &
5358     :: config_flags
5359
5360     INTEGER, INTENT( IN )  &
5361     :: ids, ide, jds, jde, kds, kde,  &
5362        ims, ime, jms, jme, kms, kme,  &
5363        its, ite, jts, jte, kts, kte
5364
5365     INTEGER, INTENT( IN )  &
5366     :: is_ext, ie_ext, js_ext, je_ext
5367
5368     REAL, DIMENSION( its-1:ite+1, kts:kte, jts-1:jte+1 ), INTENT( INOUT )  &
5369     :: titau
5370
5371     REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT( IN )  &
5372     :: defor, xkx, tke, rho
5373
5374     REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT( INOUT )  &
5375     :: mtau
5376
5377 ! Local variables.
5378
5379     INTEGER  &
5380     :: i, j, k, ktf, i_start, i_end, j_start, j_end
5381
5382 ! End declarations.
5383 !-----------------------------------------------------------------------
5384
5385     ktf = MIN( kte, kde-1 )
5386
5387     i_start = its
5388     i_end   = ite
5389     j_start = jts
5390     j_end   = jte
5391
5392     IF ( config_flags%open_xs .OR. config_flags%specified .OR. &
5393          config_flags%nested) i_start = MAX( ids+1, its )
5394     IF ( config_flags%open_xe .OR. config_flags%specified .OR. &
5395          config_flags%nested) i_end   = MIN( ide-1, ite )
5396     IF ( config_flags%open_ys .OR. config_flags%specified .OR. &
5397          config_flags%nested) j_start = MAX( jds+1, jts )
5398     IF ( config_flags%open_ye .OR. config_flags%specified .OR. &
5399          config_flags%nested) j_end   = MIN( jde-1, jte )
5400       IF ( config_flags%periodic_x ) i_start = its
5401       IF ( config_flags%periodic_x ) i_end = ite
5402
5403     i_start = i_start - is_ext
5404     i_end   = i_end   + ie_ext
5405     j_start = j_start - js_ext
5406     j_end   = j_end   + je_ext
5407
5408     IF ( config_flags%sfs_opt .GT. 0 ) THEN ! USE NBA MODEL SFS STRESSES
5409
5410       DO j = j_start, j_end
5411       DO k = kts, ktf
5412       DO i = i_start, i_end
5413
5414         titau(i,k,j) = rho(i,k,j) * mtau(i,k,j)
5415
5416       END DO
5417       END DO
5418       END DO
5419
5420     ELSE !NOT NBA
5421
5422       IF ( config_flags%m_opt .EQ. 1 ) THEN ! ASSIGN STRESS TO MTAU FOR OUTPUT
5423
5424         DO j = j_start, j_end
5425         DO k = kts, ktf
5426         DO i = i_start, i_end
5427
5428           titau(i,k,j) = - rho(i,k,j) * xkx(i,k,j) * defor(i,k,j)
5429           mtau(i,k,j) = - xkx(i,k,j) * defor(i,k,j)
5430
5431         END DO
5432         END DO
5433         END DO
5434
5435       ELSE !NO STRESS OUTPUT
5436
5437         DO j = j_start, j_end
5438         DO k = kts, ktf
5439         DO i = i_start, i_end
5440
5441           titau(i,k,j) = - rho(i,k,j) * xkx(i,k,j) * defor(i,k,j)
5442
5443         END DO
5444         END DO
5445         END DO
5446
5447       ENDIF
5448
5449     ENDIF
5450
5451     END SUBROUTINE cal_titau_11_22_33
5452
5453 !=======================================================================
5454 !=======================================================================
5455
5456     SUBROUTINE cal_titau_12_21( config_flags, titau,             &
5457                                 xkx, defor,                      &
5458                                 mtau, rho,                       &
5459                                 is_ext, ie_ext, js_ext, je_ext,  &
5460                                 ids, ide, jds, jde, kds, kde,    &
5461                                 ims, ime, jms, jme, kms, kme,    &
5462                                 its, ite, jts, jte, kts, kte     )
5463
5464 ! History:     Sep 2003   Modifications by George Bryan and Jason Knievel, NCAR
5465 !              Oct 2001   Converted to mass core by Bill Skamarock, NCAR
5466 !              Aug 2000   Original code by Shu-Hua Chen, UC-Davis
5467
5468 ! Pusrpose     This routine calculates the stress terms (taus) for use in
5469 !              the calculation of production of TKE by sheared wind
5470
5471 ! References:  Klemp and Wilhelmson (JAS 1978)
5472 !              Deardorff (B-L Meteor 1980)
5473 !              Chen and Dudhia (NCAR WRF physics report 2000)
5474
5475 ! Key:
5476
5477 !-----------------------------------------------------------------------
5478 ! Begin declarations.
5479
5480     IMPLICIT NONE
5481
5482     TYPE( grid_config_rec_type), INTENT( IN )  &
5483     :: config_flags
5484
5485     INTEGER, INTENT( IN )  &
5486     :: ids, ide, jds, jde, kds, kde,  &
5487        ims, ime, jms, jme, kms, kme,  &
5488        its, ite, jts, jte, kts, kte
5489
5490     INTEGER, INTENT( IN )  &
5491     :: is_ext, ie_ext, js_ext, je_ext
5492
5493     REAL, DIMENSION( its-1:ite+1, kts:kte, jts-1:jte+1 ), INTENT( INOUT )  &
5494     :: titau
5495
5496     REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT( IN )  &
5497     :: defor, xkx, rho
5498
5499     REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT( INOUT )  &
5500     :: mtau
5501
5502 ! Local variables.
5503
5504     INTEGER  &
5505     :: i, j, k, ktf, i_start, i_end, j_start, j_end
5506
5507     REAL, DIMENSION( its-1:ite+1, kts:kte, jts-1:jte+1 )  &
5508     :: xkxavg, rhoavg
5509
5510 ! End declarations.
5511 !-----------------------------------------------------------------------
5512
5513     ktf = MIN( kte, kde-1 )
5514
5515 ! Needs one more point in the x and y directions.
5516
5517     i_start = its
5518     i_end   = ite
5519     j_start = jts
5520     j_end   = jte
5521
5522     IF ( config_flags%open_xs .OR. config_flags%specified .OR. &
5523          config_flags%nested ) i_start = MAX( ids+1, its )
5524     IF ( config_flags%open_xe .OR. config_flags%specified .OR. &
5525          config_flags%nested ) i_end   = MIN( ide-1, ite )
5526     IF ( config_flags%open_ys .OR. config_flags%specified .OR. &
5527          config_flags%nested ) j_start = MAX( jds+1, jts )
5528     IF ( config_flags%open_ye .OR. config_flags%specified .OR. &
5529          config_flags%nested ) j_end   = MIN( jde-1, jte )
5530       IF ( config_flags%periodic_x ) i_start = its
5531       IF ( config_flags%periodic_x ) i_end = ite
5532
5533     i_start = i_start - is_ext
5534     i_end   = i_end   + ie_ext
5535     j_start = j_start - js_ext
5536     j_end   = j_end   + je_ext
5537
5538     DO j = j_start, j_end
5539     DO k = kts, ktf
5540     DO i = i_start, i_end
5541       rhoavg(i,k,j) = 0.25 * ( rho(i-1,k,j  ) + rho(i,k,j  ) +  &
5542                                rho(i-1,k,j-1) + rho(i,k,j-1) )
5543       xkxavg(i,k,j) = rhoavg(i,k,j) *                           &
5544                       0.25 * ( xkx(i-1,k,j  ) + xkx(i,k,j  ) +  &
5545                                xkx(i-1,k,j-1) + xkx(i,k,j-1) )
5546     END DO
5547     END DO
5548     END DO
5549
5550 ! titau12 or titau21
5551
5552     IF ( config_flags%sfs_opt .GT. 0 ) THEN ! USE NBA MODEL SFS STRESSES
5553
5554       DO j = j_start, j_end
5555       DO k = kts, ktf
5556       DO i = i_start, i_end
5557
5558         titau(i,k,j) = rhoavg(i,k,j) * mtau(i,k,j)
5559
5560       END DO
5561       END DO
5562       END DO
5563
5564     ELSE ! NOT NBA
5565
5566       IF ( config_flags%m_opt .EQ. 1 ) THEN ! ASSIGN STRESS TO MTAU FOR OUTPUT
5567
5568         DO j = j_start, j_end
5569         DO k = kts, ktf
5570         DO i = i_start, i_end
5571           titau(i,k,j) = - xkxavg(i,k,j) * defor(i,k,j)
5572           mtau(i,k,j) = - xkxavg(i,k,j) * defor(i,k,j)  / rhoavg(i,k,j)
5573
5574         END DO
5575         END DO
5576         END DO
5577
5578       ELSE ! NO STRESS OUTPUT
5579
5580         DO j = j_start, j_end
5581         DO k = kts, ktf
5582         DO i = i_start, i_end
5583
5584           titau(i,k,j) = - xkxavg(i,k,j) * defor(i,k,j)
5585
5586         END DO
5587         END DO
5588         END DO
5589
5590       ENDIF
5591
5592     ENDIF
5593
5594     END SUBROUTINE cal_titau_12_21
5595
5596 !=======================================================================
5597
5598     SUBROUTINE cal_titau_13_31( config_flags, titau,             &
5599                                 defor,                           &
5600                                 mtau,                            &
5601                                 xkx, fnm, fnp, rho,              &
5602                                 is_ext, ie_ext, js_ext, je_ext,  &
5603                                 ids, ide, jds, jde, kds, kde,    &
5604                                 ims, ime, jms, jme, kms, kme,    &
5605                                 its, ite, jts, jte, kts, kte     )
5606
5607 ! History:     Sep 2003   Modifications by George Bryan and Jason Knievel, NCAR
5608 !              Oct 2001   Converted to mass core by Bill Skamarock, NCAR
5609 !              Aug 2000   Original code by Shu-Hua Chen, UC-Davis
5610
5611 ! Purpose:     This routine calculates the stress terms (taus) for use in
5612 !              the calculation of production of TKE by sheared wind
5613
5614 ! References:  Klemp and Wilhelmson (JAS 1978)
5615 !              Deardorff (B-L Meteor 1980)
5616 !              Chen and Dudhia (NCAR WRF physics report 2000)
5617
5618 ! Key:
5619
5620 !-----------------------------------------------------------------------
5621 ! Begin declarations.
5622
5623     IMPLICIT NONE
5624
5625     TYPE( grid_config_rec_type), INTENT( IN )  &
5626     :: config_flags
5627
5628     INTEGER, INTENT( IN )  &
5629     :: ids, ide, jds, jde, kds, kde,  &
5630        ims, ime, jms, jme, kms, kme,  &
5631        its, ite, jts, jte, kts, kte
5632
5633     INTEGER, INTENT( IN )  &
5634     :: is_ext, ie_ext, js_ext, je_ext
5635
5636     REAL, DIMENSION( kms:kme ), INTENT( IN )  &
5637     :: fnm, fnp
5638
5639     REAL, DIMENSION( its-1:ite+1, kts:kte, jts-1:jte+1 ), INTENT( INOUT )  &
5640     :: titau
5641
5642     REAL, DIMENSION( ims:ime, kms:kme, jms:jme), INTENT( IN )  &
5643     :: defor, xkx, rho
5644
5645     REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT( INOUT )  &
5646     :: mtau
5647
5648 ! Local variables.
5649
5650     INTEGER  &
5651     :: i, j, k, ktf, i_start, i_end, j_start, j_end
5652
5653     REAL, DIMENSION( its-1:ite+1, kts:kte, jts-1:jte+1 )  &
5654     :: xkxavg, rhoavg
5655
5656 ! End declarations.
5657 !-----------------------------------------------------------------------
5658
5659     ktf = MIN( kte, kde-1 )
5660
5661 ! Find ide-1 and jde-1 for averaging to p point.
5662
5663     i_start = its
5664     i_end   = ite
5665     j_start = jts
5666     j_end   = MIN( jte, jde-1 )
5667
5668     IF ( config_flags%open_xs .OR. config_flags%specified .OR. &
5669          config_flags%nested) i_start = MAX( ids+1, its )
5670     IF ( config_flags%open_xe .OR. config_flags%specified .OR. &
5671          config_flags%nested) i_end   = MIN( ide-1, ite )
5672     IF ( config_flags%open_ys .OR. config_flags%specified .OR. &
5673          config_flags%nested) j_start = MAX( jds+1, jts )
5674     IF ( config_flags%open_ye .OR. config_flags%specified .OR. &
5675          config_flags%nested) j_end   = MIN( jde-2, jte )
5676       IF ( config_flags%periodic_x ) i_start = its
5677       IF ( config_flags%periodic_x ) i_end = ite
5678
5679     i_start = i_start - is_ext
5680     i_end   = i_end   + ie_ext
5681     j_start = j_start - js_ext
5682     j_end   = j_end   + je_ext
5683
5684     DO j = j_start, j_end
5685     DO k = kts+1, ktf
5686     DO i = i_start, i_end
5687       rhoavg(i,k,j) = 0.5 * ( fnm(k) * ( rho(i-1,k  ,j) + rho(i,k  ,j) ) + &
5688                               fnp(k) * ( rho(i-1,k-1,j) + rho(i,k-1,j) ) )
5689       xkxavg(i,k,j) = rhoavg(i,k,j)  *                                     &
5690                       0.5 * ( fnm(k) * ( xkx(i,k  ,j) + xkx(i-1,k  ,j) ) + &
5691                               fnp(k) * ( xkx(i,k-1,j) + xkx(i-1,k-1,j) ) )
5692     END DO
5693     END DO
5694     END DO
5695
5696     IF ( config_flags%sfs_opt .GT. 0 ) THEN ! USE NBA MODEL SFS STRESSES
5697
5698       DO j = j_start, j_end
5699       DO k = kts+1, ktf
5700       DO i = i_start, i_end
5701          titau(i,k,j) = rhoavg(i,k,j) * mtau(i,k,j)
5702       ENDDO
5703       ENDDO
5704       ENDDO
5705
5706     ELSE ! NOT NBA
5707
5708       IF ( config_flags%m_opt .EQ. 1 ) THEN ! ASSIGN STRESS TO MTAU FOR OUTPUT
5709
5710         DO j = j_start, j_end
5711         DO k = kts+1, ktf
5712         DO i = i_start, i_end
5713
5714           titau(i,k,j) = - xkxavg(i,k,j) * defor(i,k,j)
5715           mtau(i,k,j) = - xkxavg(i,k,j) * defor(i,k,j)  / rhoavg(i,k,j)
5716
5717         ENDDO
5718         ENDDO
5719         ENDDO
5720
5721       ELSE ! NO STRESS OUTPUT
5722
5723         DO j = j_start, j_end
5724         DO k = kts+1, ktf
5725         DO i = i_start, i_end
5726
5727           titau(i,k,j) = - xkxavg(i,k,j) * defor(i,k,j)
5728
5729         ENDDO
5730         ENDDO
5731         ENDDO
5732
5733       ENDIF
5734
5735     ENDIF
5736
5737     DO j = j_start, j_end
5738     DO i = i_start, i_end
5739       titau(i,kts  ,j) = 0.0
5740       titau(i,ktf+1,j) = 0.0
5741     ENDDO
5742     ENDDO
5743
5744     END SUBROUTINE cal_titau_13_31
5745
5746 !=======================================================================
5747 !=======================================================================
5748
5749     SUBROUTINE cal_titau_23_32( config_flags, titau, defor,      &
5750                                 mtau,                            &
5751                                 xkx, fnm, fnp, rho,              &
5752                                 is_ext, ie_ext, js_ext, je_ext,  &
5753                                 ids, ide, jds, jde, kds, kde,    &
5754                                 ims, ime, jms, jme, kms, kme,    &
5755                                 its, ite, jts, jte, kts, kte     )
5756
5757 ! History:     Sep 2003  Changes by George Bryan and Jason Knievel, NCAR
5758 !              Oct 2001  Converted to mass core by Bill Skamarock, NCAR
5759 !              Aug 2000  Original code by Shu-Hua Chen, UC-Davis
5760
5761 ! Purpose:     This routine calculates stress terms (taus) for use in
5762 !              the calculation of production of TKE by sheared wind
5763
5764 ! References:  Klemp and Wilhelmson (JAS 1978)
5765 !              Deardorff (B-L Meteor 1980)
5766 !              Chen and Dudhia (NCAR WRF physics report 2000)
5767
5768 ! Key:
5769
5770 !-----------------------------------------------------------------------
5771 ! Begin declarations.
5772
5773     IMPLICIT NONE
5774
5775     TYPE( grid_config_rec_type ), INTENT( IN )  &
5776     :: config_flags
5777
5778     INTEGER, INTENT( IN )  &
5779     :: ids, ide, jds, jde, kds, kde,  &
5780        ims, ime, jms, jme, kms, kme,  &
5781        its, ite, jts, jte, kts, kte
5782
5783     INTEGER, INTENT( IN )  &
5784     :: is_ext,ie_ext,js_ext,je_ext
5785
5786     REAL, DIMENSION( kms:kme ), INTENT( IN )  &
5787     :: fnm, fnp
5788
5789     REAL, DIMENSION( its-1:ite+1, kts:kte, jts-1:jte+1 ), INTENT( INOUT )  &
5790     :: titau
5791
5792     REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT( IN )  &
5793     :: defor, xkx, rho
5794
5795     REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT( INOUT )  &
5796     :: mtau
5797
5798 ! Local variables.
5799
5800     INTEGER  &
5801     :: i, j, k, ktf, i_start, i_end, j_start, j_end
5802
5803     REAL, DIMENSION( its-1:ite+1, kts:kte, jts-1:jte+1 )  &
5804     :: xkxavg, rhoavg
5805
5806 ! End declarations.
5807 !-----------------------------------------------------------------------
5808
5809      ktf = MIN( kte, kde-1 )
5810
5811 ! Find ide-1 and jde-1 for averaging to p point.
5812
5813     i_start = its
5814     i_end   = MIN( ite, ide-1 )
5815     j_start = jts
5816     j_end   = jte
5817
5818     IF ( config_flags%open_xs .OR. config_flags%specified .OR. &
5819          config_flags%nested) i_start = MAX( ids+1, its )
5820     IF ( config_flags%open_xe .OR. config_flags%specified .OR. &
5821          config_flags%nested) i_end   = MIN( ide-2, ite )
5822     IF ( config_flags%open_ys .OR. config_flags%specified .OR. &
5823          config_flags%nested) j_start = MAX( jds+1, jts )
5824     IF ( config_flags%open_ye .OR. config_flags%specified .OR. &
5825          config_flags%nested) j_end   = MIN( jde-1, jte )
5826       IF ( config_flags%periodic_x ) i_start = its
5827       IF ( config_flags%periodic_x ) i_end = MIN( ite, ide-1 )
5828
5829     i_start = i_start - is_ext
5830     i_end   = i_end   + ie_ext
5831     j_start = j_start - js_ext
5832     j_end   = j_end   + je_ext
5833
5834     DO j = j_start, j_end
5835     DO k = kts+1, ktf
5836     DO i = i_start, i_end
5837       rhoavg(i,k,j) = 0.5 * ( fnm(k) * ( rho(i,k  ,j) + rho(i,k  ,j-1) ) + &
5838                               fnp(k) * ( rho(i,k-1,j) + rho(i,k-1,j-1) ) )
5839       xkxavg(i,k,j) = rhoavg(i,k,j)  *                                     &
5840                       0.5 * ( fnm(k) * ( xkx(i,k  ,j) + xkx(i,k  ,j-1) ) + &
5841                               fnp(k) * ( xkx(i,k-1,j) + xkx(i,k-1,j-1) ) )
5842     END DO
5843     END DO
5844     END DO
5845
5846     IF ( config_flags%sfs_opt .GT. 0 ) THEN ! USE NBA MODEL SFS STRESSES
5847
5848       DO j = j_start, j_end
5849       DO k = kts+1, ktf
5850       DO i = i_start, i_end
5851
5852         titau(i,k,j) =  rhoavg(i,k,j) * mtau(i,k,j)
5853
5854       END DO
5855       END DO
5856       END DO
5857
5858     ELSE ! NOT NBA
5859
5860       IF ( config_flags%m_opt .EQ. 1 ) THEN ! ASSIGN STRESS TO MTAU FOR OUTPUT
5861
5862         DO j = j_start, j_end
5863         DO k = kts+1, ktf
5864         DO i = i_start, i_end
5865
5866           titau(i,k,j) = - xkxavg(i,k,j) * defor(i,k,j)
5867           mtau(i,k,j) = - xkxavg(i,k,j) * defor(i,k,j)  / rhoavg(i,k,j)
5868
5869         END DO
5870         END DO
5871         END DO
5872
5873       ELSE ! NO STRESS OUTPUT
5874
5875         DO j = j_start, j_end
5876         DO k = kts+1, ktf
5877         DO i = i_start, i_end
5878
5879           titau(i,k,j) = -  xkxavg(i,k,j) * defor(i,k,j)
5880
5881         END DO
5882         END DO
5883         END DO
5884
5885       ENDIF
5886
5887     ENDIF
5888
5889     DO j = j_start, j_end
5890     DO i = i_start, i_end
5891       titau(i,kts  ,j) = 0.0
5892       titau(i,ktf+1,j) = 0.0
5893     END DO
5894     END DO
5895
5896     END SUBROUTINE cal_titau_23_32
5897
5898 !=======================================================================
5899 !=======================================================================
5900
5901 SUBROUTINE phy_bc ( config_flags,div,defor11,defor22,defor33,              &
5902                     defor12,defor13,defor23,xkmh,xkmv,xkhh,xkhv,tke,rho,   &
5903                     RUBLTEN, RVBLTEN,                                      &
5904                     RUCUTEN, RVCUTEN,                                      &
5905                     RUSHTEN, RVSHTEN,                                      &
5906                     gamu, gamv, xkmv_meso,                                 & ! XZ
5907                     ids, ide, jds, jde, kds, kde,                          &
5908                     ims, ime, jms, jme, kms, kme,                          &
5909                     ips, ipe, jps, jpe, kps, kpe,                          &
5910                     its, ite, jts, jte, kts, kte                           )
5911
5912 !------------------------------------------------------------------------------
5913 ! Begin declarations.
5914
5915    IMPLICIT NONE
5916
5917    TYPE(grid_config_rec_type), INTENT(IN   ) :: config_flags
5918
5919    INTEGER ,        INTENT(IN   ) ::        ids, ide, jds, jde, kds, kde, &
5920                                             ims, ime, jms, jme, kms, kme, &
5921                                             ips, ipe, jps, jpe, kps, kpe, &
5922                                             its, ite, jts, jte, kts, kte
5923
5924    REAL , DIMENSION( ims:ime, kms:kme, jms:jme), INTENT(INOUT) ::RUBLTEN, &
5925                                                                  RVBLTEN, &
5926                                                                  RUCUTEN, &
5927                                                                  RVCUTEN, &
5928                                                                  RUSHTEN, &
5929                                                                  RVSHTEN, &
5930                                                                  defor11, &
5931                                                                  defor22, &
5932                                                                  defor33, &
5933                                                                  defor12, &
5934                                                                  defor13, &
5935                                                                  defor23, &
5936                                                                     xkmh, &
5937                                                                     xkmv, &
5938                                                                     xkhh, &
5939                                                                     xkhv, &
5940                                                                xkmv_meso, & ! XZ
5941                                                                      tke, &
5942                                                                      div, &
5943                                                                      rho
5944 !XZ
5945   REAL , DIMENSION( ims:ime, jms:jme), INTENT(INOUT) :: gamu, gamv
5946 ! End declarations.
5947 !-----------------------------------------------------------------------
5948
5949    IF(config_flags%bl_pbl_physics .GT. 0) THEN
5950
5951         CALL set_physical_bc3d( RUBLTEN , 't', config_flags,              &
5952                                 ids, ide, jds, jde, kds, kde,             &
5953                                 ims, ime, jms, jme, kms, kme,             &
5954                                 ips, ipe, jps, jpe, kps, kpe,             &
5955                                 its, ite, jts, jte, kts, kte              )
5956
5957         CALL set_physical_bc3d( RVBLTEN , 't', config_flags,              &
5958                                 ids, ide, jds, jde, kds, kde,             &
5959                                 ims, ime, jms, jme, kms, kme,             &
5960                                 ips, ipe, jps, jpe, kps, kpe,             &
5961                                 its, ite, jts, jte, kts, kte              )
5962
5963    ENDIF
5964
5965    IF(config_flags%cu_physics .GT. 0) THEN
5966
5967         CALL set_physical_bc3d( RUCUTEN , 't', config_flags,              &
5968                                 ids, ide, jds, jde, kds, kde,             &
5969                                 ims, ime, jms, jme, kms, kme,             &
5970                                 ips, ipe, jps, jpe, kps, kpe,             &
5971                                 its, ite, jts, jte, kts, kte              )
5972
5973         CALL set_physical_bc3d( RVCUTEN , 't', config_flags,              &
5974                                 ids, ide, jds, jde, kds, kde,             &
5975                                 ims, ime, jms, jme, kms, kme,             &
5976                                 ips, ipe, jps, jpe, kps, kpe,             &
5977                                 its, ite, jts, jte, kts, kte              )
5978
5979    ENDIF
5980
5981    IF(config_flags%shcu_physics .GT. 0) THEN
5982
5983         CALL set_physical_bc3d( RUSHTEN , 't', config_flags,              &
5984                                 ids, ide, jds, jde, kds, kde,             &
5985                                 ims, ime, jms, jme, kms, kme,             &
5986                                 ips, ipe, jps, jpe, kps, kpe,             &
5987                                 its, ite, jts, jte, kts, kte              )
5988
5989         CALL set_physical_bc3d( RVSHTEN , 't', config_flags,              &
5990                                 ids, ide, jds, jde, kds, kde,             &
5991                                 ims, ime, jms, jme, kms, kme,             &
5992                                 ips, ipe, jps, jpe, kps, kpe,             &
5993                                 its, ite, jts, jte, kts, kte              )
5994
5995    ENDIF
5996
5997    ! move out of the conditional, below; horiz coeffs needed for
5998    ! all diff_opt cases.  JM
5999
6000    CALL set_physical_bc3d( xkmh    , 't', config_flags,                   &
6001                                 ids, ide, jds, jde, kds, kde,             &
6002                                 ims, ime, jms, jme, kms, kme,             &
6003                                 ips, ipe, jps, jpe, kps, kpe,             &
6004                                 its, ite, jts, jte, kts, kte              )
6005
6006    CALL set_physical_bc3d( xkhh    , 't', config_flags,                   &
6007                                 ids, ide, jds, jde, kds, kde,             &
6008                                 ims, ime, jms, jme, kms, kme,             &
6009                                 ips, ipe, jps, jpe, kps, kpe,             &
6010                                 its, ite, jts, jte, kts, kte              )
6011
6012    IF(config_flags%diff_opt .eq. 2) THEN
6013
6014    CALL set_physical_bc3d( xkmv    , 't', config_flags,                   &
6015                                 ids, ide, jds, jde, kds, kde,             &
6016                                 ims, ime, jms, jme, kms, kme,             &
6017                                 ips, ipe, jps, jpe, kps, kpe,             &
6018                                 its, ite, jts, jte, kts, kte              )
6019
6020    CALL set_physical_bc3d( xkhv    , 't', config_flags,                   &
6021                                 ids, ide, jds, jde, kds, kde,             &
6022                                 ims, ime, jms, jme, kms, kme,             &
6023                                 ips, ipe, jps, jpe, kps, kpe,             &
6024                                 its, ite, jts, jte, kts, kte              )
6025
6026    CALL set_physical_bc3d( div     , 't', config_flags,                   &
6027                                 ids, ide, jds, jde, kds, kde,             &
6028                                 ims, ime, jms, jme, kms, kme,             &
6029                                 ips, ipe, jps, jpe, kps, kpe,             &
6030                                 its, ite, jts, jte, kts, kte              )
6031
6032    CALL set_physical_bc3d( defor11 , 't', config_flags,                   &
6033                                 ids, ide, jds, jde, kds, kde,             &
6034                                 ims, ime, jms, jme, kms, kme,             &
6035                                 ips, ipe, jps, jpe, kps, kpe,             &
6036                                 its, ite, jts, jte, kts, kte              )
6037
6038    CALL set_physical_bc3d( defor22 , 't', config_flags,                   &
6039                                 ids, ide, jds, jde, kds, kde,             &
6040                                 ims, ime, jms, jme, kms, kme,             &
6041                                 ips, ipe, jps, jpe, kps, kpe,             &
6042                                 its, ite, jts, jte, kts, kte              )
6043
6044    CALL set_physical_bc3d( defor33 , 't', config_flags,                   &
6045                                 ids, ide, jds, jde, kds, kde,             &
6046                                 ims, ime, jms, jme, kms, kme,             &
6047                                 ips, ipe, jps, jpe, kps, kpe,             &
6048                                 its, ite, jts, jte, kts, kte              )
6049
6050    CALL set_physical_bc3d( defor12 , 'd', config_flags,                   &
6051                                 ids, ide, jds, jde, kds, kde,             &
6052                                 ims, ime, jms, jme, kms, kme,             &
6053                                 ips, ipe, jps, jpe, kps, kpe,             &
6054                                 its, ite, jts, jte, kts, kte              )
6055
6056    CALL set_physical_bc3d( defor13 , 'e', config_flags,                   &
6057                                 ids, ide, jds, jde, kds, kde,             &
6058                                 ims, ime, jms, jme, kms, kme,             &
6059                                 ips, ipe, jps, jpe, kps, kpe,             &
6060                                 its, ite, jts, jte, kts, kte              )
6061
6062    CALL set_physical_bc3d( defor23 , 'f', config_flags,                   &
6063                                 ids, ide, jds, jde, kds, kde,             &
6064                                 ims, ime, jms, jme, kms, kme,             &
6065                                 ips, ipe, jps, jpe, kps, kpe,             &
6066                                 its, ite, jts, jte, kts, kte              )
6067
6068    CALL set_physical_bc3d( rho , 't', config_flags,                       &
6069                                 ids, ide, jds, jde, kds, kde,             &
6070                                 ims, ime, jms, jme, kms, kme,             &
6071                                 ips, ipe, jps, jpe, kps, kpe,             &
6072                                 its, ite, jts, jte, kts, kte              )
6073    ENDIF
6074
6075 !XZ
6076    IF(config_flags%diff_opt .eq. 2 .and. config_flags%km_opt .eq. 5) THEN
6077    CALL set_physical_bc2d( gamu, 't', config_flags,                    &
6078                                    ids, ide, jds, jde,                 &
6079                                    ims, ime, jms, jme,                 &
6080                                    ips, ipe, jps, jpe,                 &
6081                                    its, ite, jts, jte                  )
6082    CALL set_physical_bc2d( gamv, 't', config_flags,                    &
6083                                    ids, ide, jds, jde,                 &
6084                                    ims, ime, jms, jme,                 &
6085                                    ips, ipe, jps, jpe,                 &
6086                                    its, ite, jts, jte                  )
6087    CALL set_physical_bc3d( xkmv_meso,'t', config_flags,                &
6088                                 ids, ide, jds, jde, kds, kde,          &
6089                                 ims, ime, jms, jme, kms, kme,          &
6090                                 ips, ipe, jps, jpe, kps, kpe,          &
6091                                 its, ite, jts, jte, kts, kte           )
6092    ENDIF
6093 !
6094 END SUBROUTINE phy_bc
6095
6096 !=======================================================================
6097 !=======================================================================
6098
6099     SUBROUTINE tke_rhs( tendency, BN2, config_flags,            &
6100                         defor11, defor22, defor33,              &
6101                         defor12, defor13, defor23,              &
6102                         u, v, w, div, tke, mu, c1, c2,          &
6103                         theta, p, p8w, t8w, z, fnm, fnp,        &
6104                         cf1, cf2, cf3, msftx, msfty,            &
6105                         xkmh, xkmv, xkhv,                       &
6106                         rdx, rdy, dx, dy, dt, zx, zy,           &
6107                         rdz, rdzw, dn, dnw, isotropic,          &
6108                         hfx, qfx, qv, ust, rho,                 &
6109                         l_diss, nlflux, hpbl, dlk,              & !XZ
6110                         ids, ide, jds, jde, kds, kde,           &
6111                         ims, ime, jms, jme, kms, kme,           &
6112                         its, ite, jts, jte, kts, kte            )
6113
6114 !-----------------------------------------------------------------------
6115 ! Begin declarations.
6116
6117     IMPLICIT NONE
6118
6119     TYPE( grid_config_rec_type ), INTENT( IN )  &
6120     :: config_flags
6121
6122     INTEGER, INTENT( IN )  &
6123     :: ids, ide, jds, jde, kds, kde,  &
6124        ims, ime, jms, jme, kms, kme,  &
6125        its, ite, jts, jte, kts, kte
6126
6127     INTEGER, INTENT( IN )  :: isotropic
6128     REAL, INTENT( IN )  &
6129     :: cf1, cf2, cf3, dt, rdx, rdy, dx, dy
6130
6131     REAL, DIMENSION( kms:kme ), INTENT( IN )  &
6132     :: fnm, fnp, dnw, dn
6133
6134     REAL, DIMENSION( ims:ime, jms:jme ), INTENT( IN )  &
6135     :: msftx, msfty
6136
6137     REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT( INOUT )  &
6138     :: tendency
6139
6140     REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT( IN )  &
6141     :: defor11, defor22, defor33, defor12, defor13, defor23,  &
6142        div, BN2, tke, xkmh, xkmv, xkhv, zx, zy, u, v, w, theta,  &
6143        p, p8w, t8w, z, rdz, rdzw
6144
6145     REAL, DIMENSION( ims:ime, jms:jme ), INTENT( IN )  &
6146     :: mu
6147     REAL, DIMENSION( kms:kme)          , INTENT( IN )  &
6148     :: c1, c2
6149
6150     REAL, DIMENSION ( ims:ime, jms:jme ), INTENT( IN )   &
6151     :: hfx, ust, qfx
6152     REAL, DIMENSION ( ims:ime, kms:kme, jms:jme ), INTENT ( IN ) &
6153     :: qv, rho
6154 ! XZ
6155     REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT( OUT )  &
6156     :: l_diss
6157
6158     REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT ( IN ) &
6159     :: nlflux, dlk
6160
6161     REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) &
6162     :: hpbl
6163 !
6164 ! Local variables.
6165
6166     INTEGER  &
6167     :: i, j, k, ktf, i_start, i_end, j_start, j_end
6168
6169 ! End declarations.
6170 !-----------------------------------------------------------------------
6171
6172     CALL tke_shear(    tendency, config_flags,                &
6173                        defor11, defor22, defor33,             &
6174                        defor12, defor13, defor23,             &
6175                        u, v, w, tke, ust, mu,                 &
6176                        c1, c2, fnm, fnp,                      &
6177                        cf1, cf2, cf3, msftx, msfty,           &
6178                        xkmh, xkmv,                            &
6179                        rdx, rdy, zx, zy, rdz, rdzw, dnw, dn,  &
6180                        ids, ide, jds, jde, kds, kde,          &
6181                        ims, ime, jms, jme, kms, kme,          &
6182                        its, ite, jts, jte, kts, kte           )
6183
6184     CALL tke_buoyancy( tendency, config_flags, mu,            &
6185                        c1, c2,                                &
6186                        tke, xkhv, BN2, theta, dt,             &
6187                        hfx, qfx, qv,  rho,                    &
6188                        nlflux,                                & ! XZ
6189                        ids, ide, jds, jde, kds, kde,          &
6190                        ims, ime, jms, jme, kms, kme,          &
6191                        its, ite, jts, jte, kts, kte           )
6192
6193     CALL tke_dissip(   tendency, config_flags, mu, c1, c2,    &
6194                        tke, bn2, theta, p8w, t8w, z,          &
6195                        dx, dy,rdz, rdzw, isotropic,           &
6196                        msftx, msfty,                          &
6197                        hpbl, dlk, l_diss,                     & ! XZ
6198                        ids, ide, jds, jde, kds, kde,          &
6199                        ims, ime, jms, jme, kms, kme,          &
6200                        its, ite, jts, jte, kts, kte           )
6201
6202 ! Set a lower limit on TKE.
6203
6204     ktf     = MIN( kte, kde-1 )
6205     i_start = its
6206     i_end   = MIN( ite, ide-1 )
6207     j_start = jts
6208     j_end   = MIN( jte, jde-1 )
6209
6210     IF ( config_flags%open_xs .or. config_flags%specified .or. &
6211          config_flags%nested) i_start = MAX(ids+1,its)
6212     IF ( config_flags%open_xe .or. config_flags%specified .or. &
6213          config_flags%nested) i_end   = MIN(ide-2,ite)
6214     IF ( config_flags%open_ys .or. config_flags%specified .or. &
6215          config_flags%nested) j_start = MAX(jds+1,jts)
6216     IF ( config_flags%open_ye .or. config_flags%specified .or. &
6217          config_flags%nested) j_end   = MIN(jde-2,jte)
6218       IF ( config_flags%periodic_x ) i_start = its
6219       IF ( config_flags%periodic_x ) i_end = MIN( ite, ide-1 )
6220
6221     DO j = j_start, j_end
6222     DO k = kts, ktf
6223     DO i = i_start, i_end
6224       tendency(i,k,j) = max( tendency(i,k,j), -(c1(k)*mu(i,j)+c2(k)) * max( 0.0 , tke(i,k,j) ) / dt )
6225     END DO
6226     END DO
6227     END DO
6228
6229     END SUBROUTINE tke_rhs
6230
6231 !=======================================================================
6232 !=======================================================================
6233
6234     SUBROUTINE tke_buoyancy( tendency, config_flags, mu,    &
6235                              c1, c2,                        &
6236                              tke, xkhv, BN2, theta, dt,     &
6237                              hfx, qfx, qv,  rho,            &
6238                              nlflux,                        & ! XZ
6239                              ids, ide, jds, jde, kds, kde,  &
6240                              ims, ime, jms, jme, kms, kme,  &
6241                              its, ite, jts, jte, kts, kte   )
6242
6243 !-----------------------------------------------------------------------
6244 ! Begin declarations.
6245
6246     IMPLICIT NONE
6247
6248     TYPE( grid_config_rec_type ), INTENT( IN )  &
6249     :: config_flags
6250
6251     INTEGER, INTENT( IN )  &
6252     :: ids, ide, jds, jde, kds, kde,  &
6253        ims, ime, jms, jme, kms, kme,  &
6254        its, ite, jts, jte, kts, kte
6255
6256     REAL, INTENT( IN )  &
6257     :: dt
6258
6259     REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT( INOUT )  &
6260     :: tendency
6261
6262     REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT( IN )  &
6263     :: xkhv, tke, BN2, theta
6264
6265     REAL, DIMENSION( ims:ime, jms:jme ), INTENT( IN )  &
6266     :: mu
6267     REAL, DIMENSION( kms:kme)          , INTENT( IN )  &
6268     :: c1, c2
6269
6270     REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT ( IN ) &
6271     :: qv, rho
6272
6273     REAL, DIMENSION(ims:ime, jms:jme ), INTENT ( IN ) :: hfx, qfx
6274 !XZ
6275     REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT ( IN ) &
6276     :: nlflux
6277 !
6278 ! Local variables.
6279
6280     INTEGER  &
6281     :: i, j, k, ktf
6282
6283     INTEGER  &
6284     :: i_start, i_end, j_start, j_end
6285
6286     REAL :: heat_flux, heat_flux0
6287
6288     REAL :: cpm
6289
6290 ! End declarations.
6291 !-----------------------------------------------------------------------
6292
6293 !-----------------------------------------------------------------------
6294 ! Add to the TKE tendency the term that accounts for production of TKE
6295 ! due to buoyant motions.
6296
6297     ktf     = MIN( kte, kde-1 )
6298     i_start = its
6299     i_end   = MIN( ite, ide-1 )
6300     j_start = jts
6301     j_end   = MIN( jte, jde-1 )
6302
6303     IF ( config_flags%open_xs .OR. config_flags%specified .OR. &
6304          config_flags%nested ) i_start = MAX( ids+1, its )
6305     IF ( config_flags%open_xe .OR. config_flags%specified .OR. &
6306          config_flags%nested ) i_end   = MIN( ide-2, ite )
6307     IF ( config_flags%open_ys .OR. config_flags%specified .OR. &
6308          config_flags%nested ) j_start = MAX( jds+1, jts )
6309     IF ( config_flags%open_ye .OR. config_flags%specified .OR. &
6310          config_flags%nested ) j_end   = MIN( jde-2, jte )
6311       IF ( config_flags%periodic_x ) i_start = its
6312       IF ( config_flags%periodic_x ) i_end = MIN( ite, ide-1 )
6313
6314 !XZ
6315     IF(config_flags%km_opt.eq.5) THEN
6316        DO j = j_start, j_end
6317        DO k = kts+1, ktf
6318        DO i = i_start, i_end
6319               tendency(i,k,j) = tendency(i,k,j) - (c1(k)*mu(i,j)+c2(k)) * (xkhv(i,k,j) * BN2(i,k,j)   &
6320                               - 0.5*(nlflux(i,k+1,j)+nlflux(i,k,j))*g/theta(i,k,j))
6321        END DO
6322        END DO
6323        END DO
6324     ELSE
6325        DO j = j_start, j_end
6326        DO k = kts+1, ktf
6327        DO i = i_start, i_end
6328               tendency(i,k,j) = tendency(i,k,j) - (c1(k)*mu(i,j)+c2(k)) * xkhv(i,k,j) * BN2(i,k,j)
6329        END DO
6330        END DO
6331        END DO
6332     ENDIF
6333
6334 ! MARTA: change in the computation of the tke's tendency  at the surface.
6335 !  the buoyancy flux is the average of the surface heat flux (0.06) and the
6336 !   flux at the first w level
6337 !
6338 ! WCS 040331
6339
6340   hflux: SELECT CASE( config_flags%isfflx )
6341   CASE (0,2) ! with fixed surface heat flux given in the namelist
6342    heat_flux0 = config_flags%tke_heat_flux  ! constant heat flux value
6343                                             ! set in namelist.input
6344 ! LES mods
6345    K=KTS
6346
6347    DO j = j_start, j_end
6348    DO i = i_start, i_end
6349       heat_flux = heat_flux0
6350       tendency(i,k,j)= tendency(i,k,j) - &
6351                     (c1(k)*mu(i,j)+c2(k))*((xkhv(i,k,j)*BN2(i,k,j))- (g/theta(i,k,j))*heat_flux)/2.
6352
6353    ENDDO
6354    ENDDO
6355
6356   CASE (1) ! use surface heat flux computed from surface routine
6357    K=KTS
6358
6359    DO j = j_start, j_end
6360    DO i = i_start, i_end
6361       cpm = cp * (1. + 0.8*qv(i,k,j))
6362       heat_flux = (hfx(i,j)/cpm)/rho(i,k,j)
6363
6364       tendency(i,k,j)= tendency(i,k,j) - &
6365                  (c1(k)*mu(i,j)+c2(k))*((xkhv(i,k,j)*BN2(i,k,j))- (g/theta(i,k,j))*heat_flux)/2.
6366    ENDDO
6367    ENDDO
6368
6369   CASE DEFAULT
6370     CALL wrf_error_fatal( 'isfflx value invalid for diff_opt=2' )
6371   END SELECT hflux
6372
6373 ! end of MARTA/WCS change
6374
6375 ! The tendency array now includes production of TKE from buoyant
6376 ! motions.
6377 !-----------------------------------------------------------------------
6378
6379     END SUBROUTINE tke_buoyancy
6380
6381 !=======================================================================
6382 !=======================================================================
6383
6384     SUBROUTINE tke_dissip( tendency, config_flags,            &
6385                            mu, c1, c2,                        &
6386                            tke, bn2, theta, p8w, t8w, z,      &
6387                            dx, dy, rdz, rdzw, isotropic,      &
6388                            msftx, msfty,                      &
6389                            hpbl, dlk, l_diss,                 & !XZ
6390                            ids, ide, jds, jde, kds, kde,      &
6391                            ims, ime, jms, jme, kms, kme,      &
6392                            its, ite, jts, jte, kts, kte       )
6393
6394 ! History:     Sep 2003  Changes by George Bryan and Jason Knievel, NCAR
6395 !              Oct 2001  Converted to mass core by Bill Skamarock, NCAR
6396 !              Aug 2000  Original code by Shu-Hua Chen, UC-Davis
6397
6398 ! Purpose:     This routine calculates dissipation of turbulent kinetic
6399 !              energy.
6400
6401 ! References:  Klemp and Wilhelmson (JAS 1978)
6402 !              Deardorff (B-L Meteor 1980)
6403 !              Chen and Dudhia (NCAR WRF physics report 2000)
6404
6405 !-----------------------------------------------------------------------
6406 ! Begin declarations.
6407
6408     IMPLICIT NONE
6409
6410     TYPE( grid_config_rec_type ), INTENT( IN )  &
6411     :: config_flags
6412
6413     INTEGER, INTENT( IN )  &
6414     ::  ids, ide, jds, jde, kds, kde,  &
6415         ims, ime, jms, jme, kms, kme,  &
6416         its, ite, jts, jte, kts, kte
6417
6418     INTEGER, INTENT( IN )  :: isotropic
6419     REAL, INTENT( IN )  &
6420     :: dx, dy
6421
6422     REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT( INOUT )  &
6423     :: tendency
6424
6425     REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT( IN )  &
6426     :: tke, bn2, theta, p8w, t8w, z, rdz, rdzw
6427
6428     REAL, DIMENSION( ims:ime, jms:jme ), INTENT( IN )  &
6429     :: mu
6430     REAL, DIMENSION( kms:kme)          , INTENT( IN )  &
6431     :: c1, c2
6432
6433     REAL, DIMENSION( ims:ime, jms:jme ), INTENT( IN )  &
6434     :: msftx, msfty
6435 ! XZ
6436     REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) &
6437     :: hpbl
6438
6439     REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(IN)  &
6440     :: dlk
6441
6442     REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(OUT) &
6443     :: l_diss
6444 !
6445 ! Local variables.
6446
6447     REAL, DIMENSION( its:ite, kts:kte, jts:jte )  &
6448     :: dthrdn
6449
6450     REAL, DIMENSION( its:ite, kts:kte, jts:jte )  &
6451     :: l_scale
6452
6453     REAL, DIMENSION( its:ite )  &
6454     :: sumtke,  sumtkez
6455
6456     INTEGER  &
6457     :: i, j, k, ktf, i_start, i_end, j_start, j_end
6458
6459     REAL  &
6460     :: disp_len, deltas, coefc, tmpdz, len_s, thetasfc,  &
6461        thetatop, len_0, tketmp, tmp, ce1, ce2, c_k
6462 !XZ
6463     REAL                                                 &
6464     :: delxy,coefc_m,pu1
6465 !
6466 ! End declarations.
6467 !-----------------------------------------------------------------------
6468     c_k = config_flags%c_k
6469
6470     ce1 = ( c_k / 0.10 ) * 0.19
6471     ce2 = max( 0.0 , 0.93 - ce1 )
6472
6473     ktf     = MIN( kte, kde-1 )
6474     i_start = its
6475     i_end   = MIN(ite,ide-1)
6476     j_start = jts
6477     j_end   = MIN(jte,jde-1)
6478
6479     IF ( config_flags%open_xs .OR. config_flags%specified .OR. &
6480          config_flags%nested) i_start = MAX( ids+1, its )
6481     IF ( config_flags%open_xe .OR. config_flags%specified .OR. &
6482          config_flags%nested) i_end   = MIN( ide-2, ite )
6483     IF ( config_flags%open_ys .OR. config_flags%specified .OR. &
6484          config_flags%nested) j_start = MAX( jds+1, jts )
6485     IF ( config_flags%open_ye .OR. config_flags%specified .OR. &
6486          config_flags%nested) j_end   = MIN( jde-2, jte )
6487       IF ( config_flags%periodic_x ) i_start = its
6488       IF ( config_flags%periodic_x ) i_end = MIN( ite, ide-1 )
6489
6490       CALL calc_l_scale( config_flags, tke, BN2, l_scale,      &
6491                          i_start, i_end, ktf, j_start, j_end,  &
6492                          dx, dy, rdzw, msftx, msfty,           &
6493                          ids, ide, jds, jde, kds, kde,         &
6494                          ims, ime, jms, jme, kms, kme,         &
6495                          its, ite, jts, jte, kts, kte          )
6496       DO j = j_start, j_end
6497       DO k = kts, ktf
6498       DO i = i_start, i_end
6499         deltas  = ( dx/msftx(i,j) * dy/msfty(i,j) / rdzw(i,k,j) )**0.33333333
6500         tketmp  = MAX( tke(i,k,j), 1.0e-6 )
6501
6502 ! Apply Deardorff's (1980) "wall effect" at the bottom of the domain.
6503 ! For LES with fine grid, no need for this wall effect!
6504
6505         IF ( k .eq. kts .or. k .eq. ktf ) then
6506           coefc = 3.9
6507         ELSE
6508           coefc = ce1 + ce2 * l_scale(i,k,j) / deltas
6509         END IF
6510
6511 ! XZ
6512         IF(config_flags%km_opt.eq.5) THEN
6513           delxy = SQRT(dx/msftx(i,j)*dy/msfty(i,j))
6514           pu1 = pu(delxy,hpbl(i,j))
6515           coefc_m = 0.3 !
6516           l_diss(i,k,j) = (1.0-pu1)*l_scale(i,k,j)/coefc + pu1*dlk(i,k,j)/coefc_m
6517         ELSE
6518           tendency(i,k,j) = tendency(i,k,j) - &
6519                            (c1(k)*mu(i,j)+c2(k)) * coefc * tketmp**1.5 / l_scale(i,k,j)
6520         ENDIF !
6521       END DO
6522       END DO
6523       END DO
6524     END SUBROUTINE tke_dissip
6525
6526 !=======================================================================
6527 !=======================================================================
6528
6529     SUBROUTINE tke_shear( tendency, config_flags,                &
6530                           defor11, defor22, defor33,             &
6531                           defor12, defor13, defor23,             &
6532                           u, v, w, tke, ust, mu, c1, c2,         &
6533                           fnm, fnp,                              &
6534                           cf1, cf2, cf3, msftx, msfty,           &
6535                           xkmh, xkmv,                            &
6536                           rdx, rdy, zx, zy, rdz, rdzw, dn, dnw,  &
6537                           ids, ide, jds, jde, kds, kde,          &
6538                           ims, ime, jms, jme, kms, kme,          &
6539                           its, ite, jts, jte, kts, kte           )
6540
6541 ! History:     Sep 2003   Rewritten by George Bryan and Jason Knievel,
6542 !                         NCAR
6543 !              Oct 2001   Converted to mass core by Bill Skamarock, NCAR
6544 !              Aug 2000   Original code by Shu-Hua Chen, UC-Davis
6545
6546 ! Purpose:     This routine calculates the production of turbulent
6547 !              kinetic energy by stresses due to sheared wind.
6548
6549 ! References:  Klemp and Wilhelmson (JAS 1978)
6550 !              Deardorff (B-L Meteor 1980)
6551 !              Chen and Dudhia (NCAR WRF physics report 2000)
6552
6553 ! Key:
6554
6555 ! avg          temporary working array
6556 ! cf1
6557 ! cf2
6558 ! cf3
6559 ! defor11      deformation term ( du/dx + du/dx )
6560 ! defor12      deformation term ( dv/dx + du/dy ); same as defor21
6561 ! defor13      deformation term ( dw/dx + du/dz ); same as defor31
6562 ! defor22      deformation term ( dv/dy + dv/dy )
6563 ! defor23      deformation term ( dw/dy + dv/dz ); same as defor32
6564 ! defor33      deformation term ( dw/dz + dw/dz )
6565 ! div          3-d divergence
6566 ! dn
6567 ! dnw
6568 ! fnm
6569 ! fnp
6570 ! msftx
6571 ! msfty
6572 ! rdx
6573 ! rdy
6574 ! tendency
6575 ! titau        tau (stress tensor) with a tilde, indicating division by
6576 !              a map-scale factor and the fraction of the total modeled
6577 !              atmosphere beneath a given altitude (titau = tau/m/zeta)
6578 ! tke          turbulent kinetic energy
6579
6580 !-----------------------------------------------------------------------
6581 ! Begin declarations.
6582
6583     IMPLICIT NONE
6584
6585     TYPE( grid_config_rec_type ), INTENT( IN )  &
6586     :: config_flags
6587
6588     INTEGER, INTENT( IN )  &
6589     :: ids, ide, jds, jde, kds, kde,  &
6590        ims, ime, jms, jme, kms, kme,  &
6591        its, ite, jts, jte, kts, kte
6592
6593     REAL, INTENT( IN )  &
6594     :: cf1, cf2, cf3, rdx, rdy
6595
6596     REAL, DIMENSION( kms:kme ), INTENT( IN )  &
6597     :: fnm, fnp, dn, dnw
6598
6599     REAL, DIMENSION( ims:ime, jms:jme ), INTENT( IN )  &
6600     :: msftx, msfty
6601
6602     REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT( INOUT )  &
6603     :: tendency
6604
6605     REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT( IN )  &
6606     :: defor11, defor22, defor33, defor12, defor13, defor23,    &
6607        tke, xkmh, xkmv, zx, zy, u, v, w, rdz, rdzw
6608
6609     REAL, DIMENSION( ims:ime, jms:jme ), INTENT( IN )  &
6610     :: mu
6611     REAL, DIMENSION( kms:kme)          , INTENT( IN )  &
6612     :: c1, c2
6613
6614     REAL, DIMENSION( ims:ime, jms:jme ), INTENT( IN )  &
6615     :: ust
6616
6617 ! Local variables.
6618
6619     INTEGER  &
6620     :: i, j, k, ktf, ktes1, ktes2,      &
6621        i_start, i_end, j_start, j_end,  &
6622        is_ext, ie_ext, js_ext, je_ext
6623
6624     REAL  &
6625     :: mtau
6626
6627     REAL, DIMENSION( its-1:ite+1, kts:kte, jts-1:jte+1 )  &
6628     :: avg, titau, tmp2
6629
6630     REAL, DIMENSION( its:ite, kts:kte, jts:jte )  &
6631     :: titau12, tmp1, zxavg, zyavg
6632
6633     REAL :: absU, cd0, Cd
6634
6635 ! End declarations.
6636 !-----------------------------------------------------------------------
6637
6638     ktf    = MIN( kte, kde-1 )
6639     ktes1  = kte-1
6640     ktes2  = kte-2
6641
6642     i_start = its
6643     i_end   = MIN( ite, ide-1 )
6644     j_start = jts
6645     j_end   = MIN( jte, jde-1 )
6646
6647     IF ( config_flags%open_xs .OR. config_flags%specified .OR. &
6648          config_flags%nested ) i_start = MAX( ids+1, its )
6649     IF ( config_flags%open_xe .OR. config_flags%specified .OR. &
6650          config_flags%nested ) i_end   = MIN( ide-2, ite )
6651     IF ( config_flags%open_ys .OR. config_flags%specified .OR. &
6652          config_flags%nested ) j_start = MAX( jds+1, jts )
6653     IF ( config_flags%open_ye .OR. config_flags%specified .OR. &
6654          config_flags%nested ) j_end   = MIN( jde-2, jte )
6655       IF ( config_flags%periodic_x ) i_start = its
6656       IF ( config_flags%periodic_x ) i_end = MIN( ite, ide-1 )
6657
6658     DO j = j_start, j_end
6659     DO k = kts, ktf
6660     DO i = i_start, i_end
6661       zxavg(i,k,j) = 0.25 * ( zx(i,k  ,j) + zx(i+1,k  ,j) + &
6662                               zx(i,k+1,j) + zx(i+1,k+1,j)  )
6663       zyavg(i,k,j) = 0.25 * ( zy(i,k  ,j) + zy(i,k  ,j+1) + &
6664                               zy(i,k+1,j) + zy(i,k+1,j+1)  )
6665     END DO
6666     END DO
6667     END DO
6668
6669 ! Begin calculating production of turbulence due to shear.  The approach
6670 ! is to add together contributions from six terms, each of which is the
6671 ! square of a deformation that is then multiplied by an exchange
6672 ! coefficiant.  The same exchange coefficient is assumed for horizontal
6673 ! and vertical coefficients for some of the terms (the vertical value is
6674 ! the one used).
6675
6676 ! For defor11.
6677
6678    DO j = j_start, j_end
6679    DO k = kts, ktf
6680    DO i = i_start, i_end
6681       tendency(i,k,j) = tendency(i,k,j) + 0.5 *  &
6682                      (c1(k)*mu(i,j)+c2(k)) * xkmh(i,k,j) * ( ( defor11(i,k,j) )**2 )
6683    END DO
6684    END DO
6685    END DO
6686
6687 ! For defor22.
6688
6689    DO j = j_start, j_end
6690    DO k = kts, ktf
6691    DO i = i_start, i_end
6692       tendency(i,k,j) = tendency(i,k,j) + 0.5 *  &
6693                      (c1(k)*mu(i,j)+c2(k)) * xkmh(i,k,j) * ( ( defor22(i,k,j) )**2 )
6694    END DO
6695    END DO
6696    END DO
6697
6698 ! For defor33.
6699
6700    DO j = j_start, j_end
6701    DO k = kts, ktf
6702    DO i = i_start, i_end
6703       tendency(i,k,j) = tendency(i,k,j) + 0.5 *  &
6704                      (c1(k)*mu(i,j)+c2(k)) * xkmv(i,k,j) * ( ( defor33(i,k,j) )**2 )
6705    END DO
6706    END DO
6707    END DO
6708
6709 ! For defor12.
6710
6711    DO j = j_start, j_end
6712    DO k = kts, ktf
6713    DO i = i_start, i_end
6714       avg(i,k,j) = 0.25 *  &
6715                   ( ( defor12(i  ,k,j)**2 ) + ( defor12(i  ,k,j+1)**2 ) +  &
6716                     ( defor12(i+1,k,j)**2 ) + ( defor12(i+1,k,j+1)**2 ) )
6717    END DO
6718    END DO
6719    END DO
6720
6721    DO j = j_start, j_end
6722    DO k = kts, ktf
6723    DO i = i_start, i_end
6724       tendency(i,k,j) = tendency(i,k,j) + (c1(k)*mu(i,j)+c2(k)) * xkmh(i,k,j) * avg(i,k,j)
6725    END DO
6726    END DO
6727    END DO
6728
6729 ! For defor13.
6730
6731     DO j = j_start, j_end
6732     DO k = kts+1, ktf
6733     DO i = i_start, i_end+1
6734       tmp2(i,k,j) = defor13(i,k,j)
6735     END DO
6736     END DO
6737     END DO
6738
6739     DO j = j_start, j_end
6740     DO i = i_start, i_end+1
6741       tmp2(i,kts  ,j) = 0.0
6742       tmp2(i,ktf+1,j) = 0.0
6743     END DO
6744     END DO
6745
6746     DO j = j_start, j_end
6747     DO k = kts, ktf
6748     DO i = i_start, i_end
6749       avg(i,k,j) = 0.25 *  &
6750                    ( ( tmp2(i  ,k+1,j)**2 ) + ( tmp2(i  ,k,j)**2 ) +  &
6751                      ( tmp2(i+1,k+1,j)**2 ) + ( tmp2(i+1,k,j)**2 ) )
6752     END DO
6753     END DO
6754     END DO
6755
6756     DO j = j_start, j_end
6757     DO k = kts, ktf
6758     DO i = i_start, i_end
6759        tendency(i,k,j) = tendency(i,k,j) + (c1(k)*mu(i,j)+c2(k)) * xkmv(i,k,j) * avg(i,k,j)
6760     END DO
6761     END DO
6762     END DO
6763
6764 !MARTA: add the drag at the surface; WCS 040331
6765     K=KTS
6766
6767   uflux: SELECT CASE( config_flags%isfflx )
6768   CASE (0) ! Assume cd a constant, specified in namelist
6769
6770     cd0 = config_flags%tke_drag_coefficient  ! drag coefficient set
6771                                              ! in namelist.input
6772     DO j = j_start, j_end
6773     DO i = i_start, i_end
6774
6775      absU=0.5*sqrt((u(i,k,j)+u(i+1,k,j))**2+(v(i,k,j)+v(i,k,j+1))**2)
6776      Cd = cd0
6777      tendency(i,k,j) = tendency(i,k,j) +                     &
6778           (c1(k)*mu(i,j)+c2(k))*( (u(i,k,j)+u(i+1,k,j))*0.5* &
6779                    Cd*absU*(defor13(i,kts+1,j)+defor13(i+1,kts+1,j))*0.5 )
6780
6781     END DO
6782     END DO
6783
6784   CASE (1,2) ! ustar computed from surface routine
6785
6786     DO j = j_start, j_end
6787     DO i = i_start, i_end
6788
6789      absU=0.5*sqrt((u(i,k,j)+u(i+1,k,j))**2+(v(i,k,j)+v(i,k,j+1))**2)+epsilon
6790      Cd = (ust(i,j)**2)/(absU**2)
6791      tendency(i,k,j) = tendency(i,k,j) +                     &
6792           (c1(k)*mu(i,j)+c2(k))*( (u(i,k,j)+u(i+1,k,j))*0.5* &
6793                     Cd*absU*(defor13(i,kts+1,j)+defor13(i+1,kts+1,j))*0.5 )
6794
6795     END DO
6796     END DO
6797
6798   CASE DEFAULT
6799     CALL wrf_error_fatal( 'isfflx value invalid for diff_opt=2' )
6800   END SELECT uflux
6801 ! end of MARTA/WCS change
6802
6803 ! For defor23.
6804
6805     DO j = j_start, j_end+1
6806     DO k = kts+1, ktf
6807     DO i = i_start, i_end
6808       tmp2(i,k,j) = defor23(i,k,j)
6809     END DO
6810     END DO
6811     END DO
6812
6813     DO j = j_start, j_end+1
6814     DO i = i_start, i_end
6815       tmp2(i,kts,  j) = 0.0
6816       tmp2(i,ktf+1,j) = 0.0
6817     END DO
6818     END DO
6819
6820     DO j = j_start, j_end
6821     DO k = kts, ktf
6822     DO i = i_start, i_end
6823       avg(i,k,j) = 0.25 *  &
6824                    ( ( tmp2(i,k+1,j  )**2 ) + ( tmp2(i,k,j  )**2) +  &
6825                      ( tmp2(i,k+1,j+1)**2 ) + ( tmp2(i,k,j+1)**2) )
6826     END DO
6827     END DO
6828     END DO
6829
6830     DO j = j_start, j_end
6831     DO k = kts, ktf
6832     DO i = i_start, i_end
6833       tendency(i,k,j) = tendency(i,k,j) + (c1(k)*mu(i,j)+c2(k)) * xkmv(i,k,j) * avg(i,k,j)
6834     END DO
6835     END DO
6836     END DO
6837
6838 !MARTA: add the drag at the surface; WCS 040331
6839     K=KTS
6840
6841   vflux: SELECT CASE( config_flags%isfflx )
6842   CASE (0) ! Assume cd a constant, specified in namelist
6843
6844     cd0 = config_flags%tke_drag_coefficient   ! constant drag coefficient
6845                                               ! set in namelist.input
6846     DO j = j_start, j_end
6847     DO i = i_start, i_end
6848
6849       absU=0.5*sqrt((u(i,k,j)+u(i+1,k,j))**2+(v(i,k,j)+v(i,k,j+1))**2)
6850       Cd = cd0
6851       tendency(i,k,j) = tendency(i,k,j) +                     &
6852            (c1(k)*mu(i,j)+c2(k))*( (v(i,k,j)+v(i,k,j+1))*0.5* &
6853                      Cd*absU*(defor23(i,kts+1,j)+defor23(i,kts+1,j+1))*0.5 )
6854
6855     END DO
6856     END DO
6857
6858   CASE (1,2) ! ustar computed from surface routine
6859
6860     DO j = j_start, j_end
6861     DO i = i_start, i_end
6862
6863       absU=0.5*sqrt((u(i,k,j)+u(i+1,k,j))**2+(v(i,k,j)+v(i,k,j+1))**2)+epsilon
6864       Cd = (ust(i,j)**2)/(absU**2)
6865       tendency(i,k,j) = tendency(i,k,j) +       &
6866            (c1(k)*mu(i,j)+c2(k))*( (v(i,k,j)+v(i,k,j+1))*0.5* &
6867                      Cd*absU*(defor23(i,kts+1,j)+defor23(i,kts+1,j+1))*0.5 )
6868
6869     END DO
6870     END DO
6871
6872   CASE DEFAULT
6873     CALL wrf_error_fatal( 'isfflx value invalid for diff_opt=2' )
6874   END SELECT vflux
6875 ! end of MARTA/WCS change
6876
6877     END SUBROUTINE tke_shear
6878
6879 !=======================================================================
6880 !=======================================================================
6881
6882     SUBROUTINE compute_diff_metrics( config_flags, ph, phb, z, rdz, rdzw,  &
6883                                      zx, zy, rdx, rdy,                     &
6884                                      ids, ide, jds, jde, kds, kde,         &
6885                                      ims, ime, jms, jme, kms, kme,         &
6886                                      its, ite, jts, jte, kts, kte         )
6887
6888 !-----------------------------------------------------------------------
6889 ! Begin declarations.
6890
6891     IMPLICIT NONE
6892
6893     TYPE( grid_config_rec_type ), INTENT( IN )  &
6894     :: config_flags
6895
6896     INTEGER, INTENT( IN )  &
6897     :: ids, ide, jds, jde, kds, kde,  &
6898        ims, ime, jms, jme, kms, kme,  &
6899        its, ite, jts, jte, kts, kte
6900
6901     REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT( IN )  &
6902     :: ph, phb
6903
6904     REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT( OUT )  &
6905     :: rdz, rdzw, zx, zy, z
6906
6907
6908     REAL, INTENT( IN )  &
6909     :: rdx, rdy
6910
6911 ! Local variables.
6912
6913     REAL, DIMENSION( its-1:ite, kts:kte, jts-1:jte )  &
6914     :: z_at_w
6915
6916     INTEGER  &
6917     :: i, j, k, i_start, i_end, j_start, j_end, ktf
6918
6919 ! End declarations.
6920 !-----------------------------------------------------------------------
6921
6922     ktf = MIN( kte, kde-1 )
6923
6924 ! Bug fix, WCS, 22 april 2002.
6925
6926 ! We need rdzw in halo for average to u and v points.
6927
6928     j_start = jts-1
6929     j_end   = jte
6930
6931 ! Begin with dz computations.
6932
6933     DO j = j_start, j_end
6934
6935       IF ( ( j_start >= jts ) .AND. ( j_end <= MIN( jte, jde-1 ) ) ) THEN
6936         i_start = its-1
6937         i_end   = ite
6938       ELSE
6939         i_start = its
6940         i_end   = MIN( ite, ide-1 )
6941       END IF
6942
6943 ! Compute z at w points for rdz and rdzw computations.  We'll switch z
6944 ! to z at p points before returning
6945
6946       DO k = 1, kte
6947
6948 ! Bug fix, WCS, 22 april 2002
6949
6950       DO i = i_start, i_end
6951         z_at_w(i,k,j) = ( ph(i,k,j) + phb(i,k,j) ) / g
6952       END DO
6953       END DO
6954
6955       DO k = 1, ktf
6956       DO i = i_start, i_end
6957         rdzw(i,k,j) = 1.0 / ( z_at_w(i,k+1,j) - z_at_w(i,k,j) )
6958       END DO
6959       END DO
6960
6961       DO k = 2, ktf
6962       DO i = i_start, i_end
6963         rdz(i,k,j) = 2.0 / ( z_at_w(i,k+1,j) - z_at_w(i,k-1,j) )
6964       END DO
6965       END DO
6966
6967 ! Bug fix, WCS, 22 april 2002; added the following code
6968
6969       DO i = i_start, i_end
6970         rdz(i,1,j) = 2./(z_at_w(i,2,j)-z_at_w(i,1,j))
6971       END DO
6972
6973     END DO
6974
6975 ! End bug fix.
6976
6977 ! Now compute zx and zy; we'll assume that the halo for ph and phb is
6978 ! properly filled.
6979
6980     i_start = its
6981     i_end   = MIN( ite, ide-1 )
6982     j_start = jts
6983     j_end   = MIN( jte, jde-1 )
6984
6985     DO j = j_start, j_end
6986     DO k = 1, kte
6987     DO i = MAX( ids+1, its ), i_end
6988       zx(i,k,j) = rdx * ( phb(i,k,j) - phb(i-1,k,j) ) / g
6989     END DO
6990     END DO
6991     END DO
6992
6993     DO j = j_start, j_end
6994     DO k = 1, kte
6995     DO i = MAX( ids+1, its ), i_end
6996       zx(i,k,j) = zx(i,k,j) + rdx * ( ph(i,k,j) - ph(i-1,k,j) ) / g
6997     END DO
6998     END DO
6999     END DO
7000
7001     DO j = MAX( jds+1, jts ), j_end
7002     DO k = 1, kte
7003     DO i = i_start, i_end
7004       zy(i,k,j) = rdy * ( phb(i,k,j) - phb(i,k,j-1) ) / g
7005     END DO
7006     END DO
7007     END DO
7008
7009     DO j = MAX( jds+1, jts ), j_end
7010     DO k = 1, kte
7011     DO i = i_start, i_end
7012       zy(i,k,j) = zy(i,k,j) + rdy * ( ph(i,k,j) - ph(i,k,j-1) ) / g
7013     END DO
7014     END DO
7015     END DO
7016
7017 ! Some b.c. on zx and zy.
7018
7019     IF ( .NOT. config_flags%periodic_x ) THEN
7020
7021       IF ( ite == ide ) THEN
7022         DO j = j_start, j_end
7023         DO k = 1, ktf
7024           zx(ide,k,j) = 0.0
7025         END DO
7026         END DO
7027       END IF
7028
7029       IF ( its == ids ) THEN
7030         DO j = j_start, j_end
7031         DO k = 1, ktf
7032           zx(ids,k,j) = 0.0
7033         END DO
7034         END DO
7035       END IF
7036
7037     ELSE
7038
7039       IF ( ite == ide ) THEN
7040         DO j=j_start,j_end
7041         DO k=1,ktf
7042          zx(ide,k,j) = rdx * ( phb(ide,k,j) - phb(ide-1,k,j) ) / g
7043         END DO
7044         END DO
7045
7046         DO j = j_start, j_end
7047         DO k = 1, ktf
7048           zx(ide,k,j) = zx(ide,k,j) + rdx * ( ph(ide,k,j) - ph(ide-1,k,j) ) / g
7049         END DO
7050         END DO
7051       END IF
7052
7053       IF ( its == ids ) THEN
7054         DO j = j_start, j_end
7055         DO k = 1, ktf
7056           zx(ids,k,j) = rdx * ( phb(ids,k,j) - phb(ids-1,k,j) ) / g
7057         END DO
7058         END DO
7059
7060         DO j =j_start,j_end
7061         DO k =1,ktf
7062           zx(ids,k,j) = zx(ids,k,j) + rdx * ( ph(ids,k,j) - ph(ids-1,k,j) ) / g
7063         END DO
7064         END DO
7065       END IF
7066
7067     END IF
7068
7069     IF ( .NOT. config_flags%periodic_y ) THEN
7070
7071       IF ( jte == jde ) THEN
7072         DO k =1, ktf
7073         DO i =i_start, i_end
7074           zy(i,k,jde) = 0.0
7075         END DO
7076         END DO
7077       END IF
7078
7079       IF ( jts == jds ) THEN
7080         DO k =1, ktf
7081         DO i =i_start, i_end
7082           zy(i,k,jds) = 0.0
7083         END DO
7084         END DO
7085       END IF
7086
7087     ELSE
7088
7089       IF ( jte == jde ) THEN
7090         DO k=1, ktf
7091         DO i =i_start, i_end
7092           zy(i,k,jde) = rdy * ( phb(i,k,jde) - phb(i,k,jde-1) ) / g
7093         END DO
7094         END DO
7095
7096         DO k = 1, ktf
7097         DO i =i_start, i_end
7098           zy(i,k,jde) = zy(i,k,jde) + rdy * ( ph(i,k,jde) - ph(i,k,jde-1) ) / g
7099         END DO
7100         END DO
7101       END IF
7102
7103       IF ( jts == jds ) THEN
7104         DO k = 1, ktf
7105         DO i =i_start, i_end
7106           zy(i,k,jds) = rdy * ( phb(i,k,jds) - phb(i,k,jds-1) ) / g
7107         END DO
7108         END DO
7109
7110         DO k = 1, ktf
7111         DO i =i_start, i_end
7112           zy(i,k,jds) = zy(i,k,jds) + rdy * ( ph(i,k,jds) - ph(i,k,jds-1) ) / g
7113         END DO
7114         END DO
7115       END IF
7116
7117     END IF
7118
7119 ! Calculate z at p points.
7120
7121     DO j = j_start, j_end
7122       DO k = 1, ktf
7123       DO i = i_start, i_end
7124         z(i,k,j) = 0.5 *  &
7125                    ( ph(i,k,j) + phb(i,k,j) + ph(i,k+1,j) + phb(i,k+1,j) ) / g
7126       END DO
7127       END DO
7128     END DO
7129
7130     END SUBROUTINE compute_diff_metrics
7131
7132     SUBROUTINE cal_helicity ( config_flags, u, v, w, uh, up_heli_max,&
7133                                    ph, phb,                          &
7134                                    msfux, msfuy,                     &
7135                                    msfvx, msfvy,                     &
7136                                    ht,                               &
7137                                    rdx, rdy, dn, dnw, rdz, rdzw,     &
7138                                    fnm, fnp, cf1, cf2, cf3, zx, zy,  &
7139                                    ids, ide, jds, jde, kds, kde,     &
7140                                    ims, ime, jms, jme, kms, kme,     &
7141                                    its, ite, jts, jte, kts, kte      )
7142
7143 ! History:     Apr 2007  Coded by Scott Dembek, USRA, basically using
7144 !                        code segments stolen from the deformation
7145 !                        and divergence subroutine.
7146 !              ...        ...
7147
7148 ! Purpose:     This routine calculates updraft helicity.
7149 !              w ( dv/dx - du/dy )
7150
7151 ! References:
7152
7153 !-----------------------------------------------------------------------
7154 ! Begin declarations.
7155
7156     IMPLICIT NONE
7157
7158     TYPE( grid_config_rec_type ), INTENT( IN )  &
7159     :: config_flags
7160
7161     INTEGER, INTENT( IN )  &
7162     :: ids, ide, jds, jde, kds, kde, &
7163        ims, ime, jms, jme, kms, kme, &
7164        its, ite, jts, jte, kts, kte
7165
7166     REAL, INTENT( IN )  &
7167     :: rdx, rdy, cf1, cf2, cf3
7168
7169     REAL, DIMENSION( kms:kme ), INTENT( IN )  &
7170     :: fnm, fnp, dn, dnw
7171
7172     REAL, DIMENSION( ims:ime , jms:jme ),  INTENT( IN )  &
7173     :: msfux, msfuy, msfvx, msfvy, ht
7174
7175     REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT( IN )  &
7176     ::  u, v, w, ph, phb, zx, zy, rdz, rdzw
7177
7178     REAL, DIMENSION( ims:ime, jms:jme ), INTENT( INOUT )  &
7179     :: uh, up_heli_max
7180
7181 ! Local variables.
7182
7183     INTEGER  &
7184     :: i, j, k, ktf, ktes1, ktes2, i_start, i_end, j_start, j_end
7185
7186     REAL  &
7187     :: tmp, tmpzx, tmpzy, tmpzeta_z, cft1, cft2
7188
7189     REAL  &
7190     :: zl, zu, uh_smth
7191
7192     REAL, DIMENSION( its-3:ite+2, jts-3:jte+2 )  :: mm
7193
7194     REAL, DIMENSION( its-3:ite+2, kts:kte, jts-3:jte+2 )  &
7195     :: tmp1, hat, hatavg
7196
7197     REAL, DIMENSION( its-3:ite+2, kts:kte, jts-3:jte+2 )  &
7198     :: wavg, rvort
7199
7200     LOGICAL, DIMENSION( its-3:ite+2, jts-3:jte+2 )  &
7201     :: use_column
7202
7203 ! End declarations.
7204 !-----------------------------------------------------------------------
7205
7206 !=======================================================================
7207 ! In the following section, calculate the vertical component of the
7208 ! relative vorticity as the first two terms of the updraft helicity
7209 ! w ( dv/dx - du/dy ).
7210
7211     ktes1   = kte-1
7212     ktes2   = kte-2
7213
7214     cft2    = - 0.5 * dnw(ktes1) / dn(ktes1)
7215     cft1    = 1.0 - cft2
7216
7217     ktf     = MIN( kte, kde-1 )
7218
7219 !=======================================================================
7220
7221     i_start = its
7222     i_end   = ite
7223     j_start = jts
7224     j_end   = jte
7225
7226     IF ( config_flags%open_xs .OR. config_flags%specified .OR. &
7227          config_flags%nested) i_start = MAX( ids+1, its-2 )
7228     IF ( config_flags%open_xe .OR. config_flags%specified .OR. &
7229          config_flags%nested) i_end   = MIN( ide-1, ite+2 )
7230     IF ( config_flags%open_ys .OR. config_flags%specified .OR. &
7231          config_flags%nested) j_start = MAX( jds+1, jts-2 )
7232     IF ( config_flags%open_ye .OR. config_flags%specified .OR. &
7233          config_flags%nested) j_end   = MIN( jde-1, jte+2 )
7234     IF ( config_flags%periodic_x ) i_start = its
7235     IF ( config_flags%periodic_x ) i_end = ite
7236
7237
7238 !-----------------------------------------------------------------------
7239 ! Calculate dv/dx.
7240
7241 ! First, calculate an average mapscale factor.
7242
7243 ! Comments 10-MAR-05
7244 ! du/dy => need u map scale factor in x (which is defined at u points)
7245 ! averaged over j and j-1
7246 ! dv/dx => need v map scale factor in y (which is defined at v points)
7247 ! averaged over i and i-1
7248
7249     DO j = j_start, j_end
7250     DO i = i_start, i_end
7251       mm(i,j) = 0.25 * ( msfux(i,j-1) + msfux(i,j) ) * ( msfvy(i-1,j) + msfvy(i,j) )
7252     END DO
7253     END DO
7254
7255 ! Apply a coordinate transformation to meridional velocity, v.
7256
7257     DO j = j_start, j_end
7258     DO k = kts, ktf
7259     DO i = i_start-1, i_end
7260        hat(i,k,j) = v(i,k,j) / msfvy(i,j)
7261     END DO
7262     END DO
7263     END DO
7264
7265 ! Account for the slope in x of eta surfaces.
7266
7267     DO j = j_start, j_end
7268     DO k = kts+1, ktf
7269     DO i = i_start, i_end
7270       hatavg(i,k,j) = 0.5 * (  &
7271                       fnm(k) * ( hat(i-1,k  ,j) + hat(i,k  ,j) ) +  &
7272                       fnp(k) * ( hat(i-1,k-1,j) + hat(i,k-1,j) ) )
7273     END DO
7274     END DO
7275     END DO
7276
7277 ! Extrapolate to top and bottom of domain (to w levels).
7278
7279     DO j = j_start, j_end
7280     DO i = i_start, i_end
7281        hatavg(i,1,j)   =  0.5 * (  &
7282                           cf1 * hat(i-1,1,j) +  &
7283                           cf2 * hat(i-1,2,j) +  &
7284                           cf3 * hat(i-1,3,j) +  &
7285                           cf1 * hat(i  ,1,j) +  &
7286                           cf2 * hat(i  ,2,j) +  &
7287                           cf3 * hat(i  ,3,j) )
7288        hatavg(i,kte,j) =  0.5 * (  &
7289                           cft1 * ( hat(i,ktes1,j) + hat(i-1,ktes1,j) ) +  &
7290                           cft2 * ( hat(i,ktes2,j) + hat(i-1,ktes2,j) ) )
7291     END DO
7292     END DO
7293
7294     ! Fixes to set_physical_bc2/3d have made any check for polar B.C.'s
7295     ! unnecessary in this place.  zx, rdzw, and hatavg are all defined
7296     ! in places they need to be and the values at the poles are replications
7297     ! of the values one grid point in, so the averaging over j and j-1 works
7298     ! to act as just using the value at j or j-1 (with out extra code).
7299     !
7300     ! tmpzx = averaged value of dpsi/dx (=zx) on vorticity grid
7301     ! tmp1  = partial dpsi/dx * partial dv^/dpsi
7302     DO j = j_start, j_end
7303     DO k = kts, ktf
7304     DO i = i_start, i_end
7305       tmpzx       = 0.25 * (  &
7306                     zx(i,k  ,j-1) + zx(i,k  ,j) +  &
7307                     zx(i,k+1,j-1) + zx(i,k+1,j) )
7308       tmp1(i,k,j) = ( hatavg(i,k+1,j) - hatavg(i,k,j) ) *  &
7309                     0.25 * tmpzx * ( rdzw(i,k,j) + rdzw(i,k,j-1) + &
7310                                      rdzw(i-1,k,j-1) + rdzw(i-1,k,j) )
7311     END DO
7312     END DO
7313     END DO
7314
7315 ! End calculation of dv/dx.
7316 !-----------------------------------------------------------------------
7317
7318 !-----------------------------------------------------------------------
7319 ! Calculate the first parenthetical term of
7320 ! updraft helicity = w ( dv/dx - du/dy ) at vorticity points.
7321
7322     DO j = j_start, j_end
7323     DO k = kts, ktf
7324     DO i = i_start, i_end
7325       rvort(i,k,j) = mm(i,j) * (  &
7326                      rdx * ( hat(i,k,j) - hat(i-1,k,j) ) - tmp1(i,k,j) )
7327     END DO
7328     END DO
7329     END DO
7330
7331 ! End calculation of the first parenthetical term of updraft helicity.
7332 !-----------------------------------------------------------------------
7333
7334 !-----------------------------------------------------------------------
7335 ! Calculate du/dy.
7336
7337 ! Apply a coordinate transformation to zonal velocity, u.
7338
7339     DO j =j_start-1, j_end
7340     DO k =kts, ktf
7341     DO i =i_start, i_end
7342       ! Fixes to set_physical_bc2/3d for polar boundary conditions
7343       ! remove issues with loop over j
7344       hat(i,k,j) = u(i,k,j) / msfux(i,j)
7345     END DO
7346     END DO
7347     END DO
7348
7349 ! Average in y and z.
7350
7351     DO j=j_start,j_end
7352     DO k=kts+1,ktf
7353     DO i=i_start,i_end
7354       hatavg(i,k,j) = 0.5 * (  &
7355                       fnm(k) * ( hat(i,k  ,j-1) + hat(i,k  ,j) ) +  &
7356                       fnp(k) * ( hat(i,k-1,j-1) + hat(i,k-1,j) ) )
7357     END DO
7358     END DO
7359     END DO
7360
7361 ! Extrapolate to top and bottom of domain (to w levels).
7362
7363     DO j = j_start, j_end
7364     DO i = i_start, i_end
7365       hatavg(i,1,j)   =  0.5 * (  &
7366                          cf1 * hat(i,1,j-1) +  &
7367                          cf2 * hat(i,2,j-1) +  &
7368                          cf3 * hat(i,3,j-1) +  &
7369                          cf1 * hat(i,1,j  ) +  &
7370                          cf2 * hat(i,2,j  ) +  &
7371                          cf3 * hat(i,3,j  ) )
7372       hatavg(i,kte,j) =  0.5 * (  &
7373                          cft1 * ( hat(i,ktes1,j-1) + hat(i,ktes1,j) ) +  &
7374                          cft2 * ( hat(i,ktes2,j-1) + hat(i,ktes2,j) ) )
7375     END DO
7376     END DO
7377
7378     ! tmpzy = averaged value of dpsi/dy (=zy) on vorticity grid
7379     ! tmp1  = partial dpsi/dy * partial du^/dpsi
7380     DO j = j_start, j_end
7381     DO k = kts, ktf
7382     DO i = i_start, i_end
7383       tmpzy       = 0.25 * (  &
7384                     zy(i-1,k  ,j) + zy(i,k  ,j) +  &
7385                     zy(i-1,k+1,j) + zy(i,k+1,j) )
7386       tmp1(i,k,j) = ( hatavg(i,k+1,j) - hatavg(i,k,j) ) *  &
7387                     0.25 * tmpzy * ( rdzw(i,k,j) + rdzw(i-1,k,j) + &
7388                                      rdzw(i-1,k,j-1) + rdzw(i,k,j-1) )
7389     END DO
7390     END DO
7391     END DO
7392
7393 ! End calculation of du/dy.
7394 !----------------------------------------------------------------------
7395
7396 !-----------------------------------------------------------------------
7397 ! Add (subtract, actually) the second parenthetical term to
7398 ! updraft helicity = w ( dv/dx - du/dy ) at vorticity points.
7399
7400     DO j = j_start, j_end
7401     DO k = kts, ktf
7402     DO i = i_start, i_end
7403       rvort(i,k,j) = rvort(i,k,j) -  &
7404                      mm(i,j) * (  &
7405                      rdy * ( hat(i,k,j) - hat(i,k,j-1) ) - tmp1(i,k,j) )
7406     END DO
7407     END DO
7408     END DO
7409
7410 ! End addition of the second parenthetical term to updraft helicity.
7411 !-----------------------------------------------------------------------
7412
7413 !-----------------------------------------------------------------------
7414 ! Update the boundary for the vorticity.
7415
7416      IF ( .NOT. config_flags%periodic_x .AND. i_start .EQ. ids+1 ) THEN
7417        DO j = jts, jte
7418        DO k = kts, kte
7419          rvort(ids,k,j) = rvort(ids+1,k,j)
7420        END DO
7421        END DO
7422      END IF
7423
7424      IF ( .NOT. config_flags%periodic_y .AND. j_start .EQ. jds+1) THEN
7425        DO k = kts, kte
7426        DO i = its, ite
7427          rvort(i,k,jds) = rvort(i,k,jds+1)
7428        END DO
7429        END DO
7430      END IF
7431
7432      IF ( .NOT. config_flags%periodic_x .AND. i_end .EQ. ide-1) THEN
7433        DO j = jts, jte
7434        DO k = kts, kte
7435          rvort(ide,k,j) = rvort(ide-1,k,j)
7436        END DO
7437        END DO
7438      END IF
7439
7440      IF ( .NOT. config_flags%periodic_y .AND. j_end .EQ. jde-1) THEN
7441        DO k = kts, kte
7442        DO i = its, ite
7443          rvort(i,k,jde) = rvort(i,k,jde-1)
7444        END DO
7445        END DO
7446      END IF
7447
7448 ! End update of boundary for the vorticity.
7449 !-----------------------------------------------------------------------
7450
7451 !-----------------------------------------------------------------------
7452 ! Calculate an 8-point average of w used to complete the
7453 ! calculation of updraft helicity = w ( dv/dx - du/dy ).
7454
7455     DO j = j_start, j_end
7456     DO k = kts, ktf
7457     DO i = i_start, i_end
7458       wavg(i,k,j) = 0.125 * (  &
7459                     w(i,k  ,j  ) + w(i-1,k  ,j  ) +  &
7460                     w(i,k  ,j-1) + w(i-1,k  ,j-1) +  &
7461                     w(i,k+1,j  ) + w(i-1,k+1,j  ) +  &
7462                     w(i,k+1,j-1) + w(i-1,k+1,j-1) )
7463     END DO
7464     END DO
7465     END DO
7466
7467 ! End addition of the average w calculation for updraft helicity.
7468 !-----------------------------------------------------------------------
7469
7470 !-----------------------------------------------------------------------
7471 ! Complete the updraft helicity calculation, only including columns with
7472 ! positive vertical velocity between the 2000 m and 5000 m levels.
7473
7474     DO j = j_start, j_end
7475     DO i = i_start, i_end
7476       use_column(i,j) = .true.
7477       uh(i,j) = 0.
7478     END DO
7479     END DO
7480
7481     !  We want zl and zu to be the height above ground, so we subtract
7482     !  the terrain elevation from the geopotential/g.
7483
7484     DO j = j_start, j_end
7485     DO k = kts, ktf
7486     DO i = i_start, i_end
7487       zl = ( 0.25 * (  &
7488            (( ph(i  ,k  ,j  ) + phb(i  ,k  ,j  ) ) / g - ht(i  ,j  ) ) +  &
7489            (( ph(i-1,k  ,j  ) + phb(i-1,k  ,j  ) ) / g - ht(i-1,j  ) ) +  &
7490            (( ph(i  ,k  ,j-1) + phb(i  ,k  ,j-1) ) / g - ht(i  ,j-1) ) +  &
7491            (( ph(i-1,k  ,j-1) + phb(i-1,k  ,j-1) ) / g - ht(i-1,j-1) ) ) )
7492
7493       zu = ( 0.25 * (  &
7494            (( ph(i  ,k+1,j  ) + phb(i  ,k+1,j  ) ) / g - ht(i  ,j  ) ) +  &
7495            (( ph(i-1,k+1,j  ) + phb(i-1,k+1,j  ) ) / g - ht(i-1,j  ) ) +  &
7496            (( ph(i  ,k+1,j-1) + phb(i  ,k+1,j-1) ) / g - ht(i  ,j-1) ) +  &
7497            (( ph(i-1,k+1,j-1) + phb(i-1,k+1,j-1) ) / g - ht(i-1,j-1) ) ) )
7498
7499       IF ( zl .GE. 2000. .AND. zu .LE. 5000. ) THEN
7500         IF ( wavg(i,k,j) .GT. 0. .AND. wavg(i,k+1,j) .GT. 0. ) THEN
7501           uh(i,j) = uh(i,j) + ( ( wavg(i,k,j) * rvort(i,k,j) + &
7502                     wavg(i,k+1,j) * rvort(i,k+1,j) ) * 0.5 ) &
7503                     * ( zu - zl )
7504         ELSE
7505           use_column(i,j) = .false.
7506           uh(i,j) = 0.
7507         ENDIF
7508       ENDIF
7509     END DO
7510     END DO
7511     END DO
7512
7513 ! Apply a smoother
7514
7515     DO j = MAX(jds+1,jts),MIN(jde-2,jte)
7516     DO i = MAX(ids+1,its),MIN(ide-2,ite)
7517       uh_smth = 0.25   *   uh(i  ,j  ) + &
7518                 0.125  * ( uh(i+1,j  ) + uh(i-1,j  ) + &
7519                            uh(i  ,j+1) + uh(i  ,j-1) ) + &
7520                 0.0625 * ( uh(i+1,j+1) + uh(i+1,j-1) + &
7521                            uh(i-1,j+1) + uh(i-1,j-1) )
7522
7523       IF ( use_column(i,j) ) THEN
7524         IF ( uh_smth .GT. up_heli_max(i,j) ) THEN
7525            up_heli_max(i,j) = uh_smth
7526         ENDIF
7527       ENDIF
7528
7529 !     IF ( up_heli_max(i,j) .GT. 1.0e+3 ) THEN
7530 !       print *,' i,j,up_heli_max = ', i,j,up_heli_max(i,j)
7531 !     ENDIF
7532     END DO
7533     END DO
7534
7535 ! End addition of the average w calculation for updraft helicity.
7536 !-----------------------------------------------------------------------
7537
7538 !-----------------------------------------------------------------------
7539 ! Update the boundary for updraft helicity (might need to change later).
7540
7541     IF ( .NOT. config_flags%periodic_x .AND. i_start .EQ. ids+1 ) THEN
7542       DO j = jts, jte
7543       DO k = kts, kte
7544 !        rvort(ids,k,j) = rvort(ids+1,k,j)
7545         up_heli_max(ids,j) = up_heli_max(ids+1,j)
7546       END DO
7547       END DO
7548     END IF
7549
7550     IF ( .NOT. config_flags%periodic_y .AND. j_start .EQ. jds+1) THEN
7551       DO k = kts, kte
7552       DO i = its, ite
7553 !        rvort(i,k,jds) = rvort(i,k,jds+1)
7554         up_heli_max(i,jds) = up_heli_max(i,jds+1)
7555       END DO
7556       END DO
7557     END IF
7558
7559     IF ( .NOT. config_flags%periodic_x .AND. i_end .EQ. ide-1) THEN
7560       DO j = jts, jte
7561       DO k = kts, kte
7562 !        rvort(ide,k,j) = rvort(ide-1,k,j)
7563         up_heli_max(ide,j) = up_heli_max(ide-1,j)
7564       END DO
7565       END DO
7566     END IF
7567
7568     IF ( .NOT. config_flags%periodic_y .AND. j_end .EQ. jde-1) THEN
7569       DO k = kts, kte
7570       DO i = its, ite
7571 !        rvort(i,k,jde) = rvort(i,k,jde-1)
7572         up_heli_max(i,jde) = up_heli_max(i,jde-1)
7573       END DO
7574       END DO
7575     END IF
7576
7577 ! End update of boundary for updraft helicity.
7578
7579     END SUBROUTINE cal_helicity
7580 !=======================================================================
7581 !=======================================================================
7582
7583     SUBROUTINE tridiag(n,a,b,c,d)
7584 !! to solve system of linear eqs on tridiagonal matrix n times n
7585 !! after Peaceman and Rachford, 1955
7586 !! a,b,c,d - are vectors of order n
7587 !! a,b,c - are coefficients on the LHS
7588 !! d - is initially RHS on the output becomes a solution vector
7589 !-------------------------------------------------------------------
7590
7591     INTEGER, INTENT(IN)               :: n
7592     REAL, DIMENSION(n), INTENT(IN)    :: a,b
7593     REAL, DIMENSION(n), INTENT(INOUT) :: c,d
7594
7595     INTEGER :: i
7596     REAL    :: p
7597     REAL, DIMENSION(n) :: q
7598
7599     c(n) = 0.
7600     q(1) = -c(1)/b(1)
7601     d(1) = d(1)/b(1)
7602
7603     DO i = 2, n
7604        p = 1./(b(i) + a(i)*q(i-1))
7605        q(i) = -c(i)*p
7606        d(i) = (d(i) - a(i)*d(i-1))*p
7607     ENDDO
7608
7609     DO i = n-1, 1, -1
7610        d(i) = d(i) + q(i)*d(i+1)
7611     ENDDO
7612
7613     END SUBROUTINE tridiag
7614 !=======================================================================
7615 !=======================================================================
7616     SUBROUTINE vertical_diffusion_implicit(ru_tendf, rv_tendf, rw_tendf, rt_tendf,&
7617                                         tke_tendf, moist_tendf, n_moist,          &
7618                                         chem_tendf, n_chem,                       &
7619                                         scalar_tendf, n_scalar,                   &
7620                                         tracer_tendf, n_tracer,                   &
7621                                         u_2, v_2, w_2, dt,                        &
7622                                         thp,u_base,v_base,t_base,qv_base,mu,tke,  &
7623                                         theta, config_flags,                      &
7624                                         moist,chem,scalar,tracer,                 &
7625                                         xkmv,xkhv,xkmh,km_opt,                    &
7626                                         fnm, fnp, dn, dnw, rdz, rdzw,             &
7627                                         hfx, qfx, ust, rho,                       &
7628                                         nlflux,gamu,gamv,xkmv_meso,l_diss,        &
7629                                         c1h, c2h, c1f, c2f,                       &
7630                                         ids, ide, jds, jde, kds, kde,             &
7631                                         ims, ime, jms, jme, kms, kme,             &
7632                                         its, ite, jts, jte, kts, kte              )
7633 !To solve the vertical diffusion equations for u,v,w,th,moist,
7634 !chem,scalar,tracer using implicit method.
7635 !The vertical TKE diffusion and dissipation are implicitly treated.
7636 !-----------------------------------------------------------------------
7637 ! Begin declarations.
7638
7639    IMPLICIT NONE
7640
7641    TYPE(grid_config_rec_type), INTENT(IN   ) :: config_flags
7642
7643    INTEGER ,        INTENT(IN   ) ::        ids, ide, jds, jde, kds, kde, &
7644                                             ims, ime, jms, jme, kms, kme, &
7645                                             its, ite, jts, jte, kts, kte
7646
7647    INTEGER ,        INTENT(IN   ) :: n_moist,n_chem,n_scalar,n_tracer,km_opt
7648    REAL,            INTENT(IN   ) :: dt
7649
7650    REAL , DIMENSION( kms:kme ) ,                 INTENT(IN   ) :: fnm
7651
7652    REAL , DIMENSION( kms:kme ) ,                 INTENT(IN   ) :: fnp
7653
7654    REAL , DIMENSION( kms:kme ) ,                 INTENT(IN   ) :: dnw
7655
7656    REAL , DIMENSION( kms:kme ) ,                 INTENT(IN   ) ::  dn
7657
7658    REAL , DIMENSION( ims:ime , jms:jme ) ,       INTENT(IN   ) ::  mu
7659
7660    REAL , DIMENSION( kms:kme ) ,                 INTENT(IN   ) :: qv_base
7661
7662    REAL , DIMENSION( kms:kme ) ,                 INTENT(IN   ) ::  u_base
7663
7664    REAL , DIMENSION( kms:kme ) ,                 INTENT(IN   ) ::  v_base
7665
7666    REAL , DIMENSION( kms:kme ) ,                 INTENT(IN   ) ::  t_base
7667
7668    REAL , DIMENSION( kms:kme)  ,                 INTENT(IN   ) ::         &
7669                                                        c1h, c2h, c1f ,c2f
7670
7671    REAL , DIMENSION( ims:ime, kms:kme, jms:jme), INTENT(INOUT) ::ru_tendf,&
7672                                                                  rv_tendf,&
7673                                                                  rw_tendf,&
7674                                                                 tke_tendf,&
7675                                                                  rt_tendf
7676
7677    REAL , DIMENSION( ims:ime, kms:kme, jms:jme, n_moist),                 &
7678           INTENT(INOUT) ::                                    moist_tendf
7679
7680    REAL , DIMENSION( ims:ime, kms:kme, jms:jme, n_chem),                  &
7681           INTENT(INOUT) ::                                     chem_tendf
7682
7683    REAL , DIMENSION( ims:ime, kms:kme, jms:jme, n_scalar) ,               &
7684           INTENT(INOUT) ::                                   scalar_tendf
7685
7686    REAL , DIMENSION( ims:ime, kms:kme, jms:jme, n_tracer) ,               &
7687           INTENT(INOUT) ::                                   tracer_tendf
7688
7689    REAL , DIMENSION( ims:ime, kms:kme, jms:jme, n_moist),                 &
7690           INTENT(INOUT) ::                                          moist
7691
7692    REAL , DIMENSION( ims:ime, kms:kme, jms:jme, n_chem),                  &
7693           INTENT(INOUT) ::                                           chem
7694
7695    REAL , DIMENSION( ims:ime, kms:kme, jms:jme, n_scalar) ,               &
7696           INTENT(IN   ) ::                                         scalar
7697
7698    REAL , DIMENSION( ims:ime, kms:kme, jms:jme, n_tracer) ,               &
7699           INTENT(IN   ) ::                                         tracer
7700
7701    REAL , DIMENSION( ims:ime, kms:kme, jms:jme),                          &
7702           INTENT(IN   ) ::                                          xkmv, &
7703                                                                     xkhv, &
7704                                                                     xkmh, &
7705                                                                      tke, &
7706                                                                    theta, &
7707                                                                      rdz, &
7708                                                                      u_2, &
7709                                                                      v_2, &
7710                                                                      w_2, &
7711                                                                     rdzw
7712
7713    REAL , DIMENSION( ims:ime, kms:kme, jms:jme), INTENT(IN   )   :: rho
7714
7715    REAL , DIMENSION( ims:ime, jms:jme),          INTENT(INOUT)   :: hfx,  &
7716                                                                     qfx
7717
7718    REAL , DIMENSION( ims:ime, jms:jme), INTENT(IN   )            :: ust
7719
7720    REAL , DIMENSION( ims:ime, kms:kme, jms:jme), INTENT(INOUT)   :: thp
7721
7722    REAL , DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT)  :: nlflux
7723
7724    REAL , DIMENSION( ims:ime, jms:jme), INTENT(INOUT)            :: gamu,&
7725                                                                     gamv
7726
7727    REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT)   :: xkmv_meso
7728
7729    REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT)   :: l_diss
7730 ! LOCAL VAR
7731    REAL , DIMENSION( ims:ime, kms:kme, jms:jme)           :: var_mix
7732
7733    REAL, DIMENSION( its-1:ite+1, kts:kte, jts-1:jte+1 ):: xkxavg_m, &
7734                                                           xkxavg_s
7735    REAL, DIMENSION( its:ite, kts:kte, jts:jte)         :: xkxavg,   &
7736                                                           xkxavg_w, &
7737                                                           rhoavg,   &
7738                                                           nlflux_rho
7739    REAL, DIMENSION( its-1:ite+1, jts-1:jte+1 )         :: gamvavg, gamuavg
7740    REAL, DIMENSION( its-1:ite+1, jts-1:jte+1 )         :: tao_xz, tao_yz
7741    REAL, DIMENSION( its-1:ite+1, kts:kte, jts-1:jte+1 ):: muavg_u,muavg_v
7742    REAL, DIMENSION( its-1:ite+1, kts:kte, jts-1:jte+1 ):: rdz_u, rdz_v
7743    REAL, DIMENSION(kts:kte) :: a, b, c, d
7744    REAL, DIMENSION(kts:kte-1) :: a1, b1, c1, d1
7745
7746    INTEGER :: im, i,j,k,ktf,nz
7747    INTEGER :: i_start, i_end, j_start, j_end
7748
7749    REAL :: V0_u,V0_v,ustar,beta
7750    REAL :: heat_flux, moist_flux, qfac
7751    REAL :: cpm,rdz_w,rhoavg_u,rhoavg_v,rdz_z
7752 ! End declarations.
7753 !-----------------------------------------------------------------------
7754 !!============================================
7755 !! u
7756 !!============================================
7757    ktf=MIN(kte,kde-1)
7758
7759    i_start = its
7760    i_end   = ite
7761    j_start = jts
7762    j_end   = MIN(jte,jde-1)
7763
7764    IF ( config_flags%open_xs .or. config_flags%specified .or. &
7765         config_flags%nested) i_start = MAX(ids+1,its)
7766    IF ( config_flags%open_xe .or. config_flags%specified .or. &
7767         config_flags%nested) i_end   = MIN(ide-1,ite)
7768    IF ( config_flags%open_ys .or. config_flags%specified .or. &
7769         config_flags%nested) j_start = MAX(jds+1,jts)
7770    IF ( config_flags%open_ye .or. config_flags%specified .or. &
7771         config_flags%nested) j_end   = MIN(jde-2,jte)
7772       IF ( config_flags%periodic_x ) i_start = its
7773       IF ( config_flags%periodic_x ) i_end = ite
7774
7775     DO j = j_start, j_end
7776     DO k = kts+1, ktf
7777     DO i = i_start, i_end
7778       rhoavg_u        =  0.5 * ( fnm(k) * ( rho(i,k  ,j) + rho(i-1,k,j) ) +                 &
7779                                  fnp(k) * ( rho(i,k-1,j) + rho(i-1,k-1,j) ) )
7780       xkxavg_m(i,k,j) =  0.5 * rhoavg_u *                                                   &
7781                                ( fnm(k) * ( xkmv_meso(i,k  ,j) + xkmv_meso(i-1,k,j) ) +     &
7782                                  fnp(k) * ( xkmv_meso(i,k-1,j) + xkmv_meso(i-1,k-1,j) ) )
7783       xkxavg_s(i,k,j) =  0.5 * rhoavg_u *                                                   &
7784                                ( fnm(k) * ( xkmv(i,k  ,j) + xkmv(i-1,k,j) ) +               &
7785                                  fnp(k) * ( xkmv(i,k-1,j) + xkmv(i-1,k-1,j) ) )
7786     END DO
7787     END DO
7788     END DO
7789
7790     DO j = j_start, j_end
7791     DO i = i_start, i_end
7792         xkxavg_m(i,kts,  j) = 0.0
7793         xkxavg_m(i,ktf+1,j) = 0.0
7794         xkxavg_s(i,kts,  j) = 0.0
7795         xkxavg_s(i,ktf+1,j) = 0.0
7796     END DO
7797     END DO
7798
7799     DO j = j_start, j_end
7800     DO i = i_start, i_end
7801       gamuavg(i,j) = 0.5 * ( gamu(i,j) + gamu(i-1,j) )
7802     END DO
7803     END DO
7804
7805     DO j = j_start, j_end
7806     DO k = kts, ktf
7807     DO i = i_start, i_end
7808        rdz_u(i,k,j)   = 2./( 1./rdz(i,k,j) +  1./rdz(i-1,k,j))
7809        muavg_u(i,k,j) = 0.5 * ( (c1h(k)*mu(i,j)+c2h(k)) + (c1h(k)*mu(i-1,j)+c2h(k)) )
7810     ENDDO
7811     ENDDO
7812     ENDDO
7813
7814     DO j = j_start, j_end
7815     DO i = i_start, ite
7816        V0_u = 0.
7817        V0_u =        sqrt((u_2(i,kts,j)**2)+          &
7818                         (((v_2(i  ,kts,j  )+          &
7819                            v_2(i  ,kts,j+1)+          &
7820                            v_2(i-1,kts,j  )+          &
7821                            v_2(i-1,kts,j+1))/4)**2))+epsilon
7822        ustar = 0.5*(ust(i,j)+ust(i-1,j))
7823        tao_xz(i,j) = ustar*ustar*(rho(i,kts,j)+rho(i-1,kts,j))/(2.*V0_u)
7824     ENDDO
7825     ENDDO
7826
7827     nz = ktf
7828
7829        DO  j = j_start, j_end
7830        DO  i = i_start, i_end
7831             k = kts
7832             rdz_w = -g/(dnw(k))/muavg_u(i,k,j)
7833             a(k) = 0.
7834             b(k) = 1.+rdz_w*(rdz_u(i,k+1,j)*xkxavg_s(i,k+1,j)+tao_xz(i,j))*dt
7835             c(k) =   -rdz_w*rdz_u(i,k+1,j)*xkxavg_s(i,k+1,j)*dt
7836             d(k) = u_2(i,kts,j)
7837
7838           DO  k = kts+1,ktf-1
7839             rdz_w =  -g/(dnw(k))/muavg_u(i,k,j)
7840             a(k) = -rdz_w*rdz_u(i,k,j)*xkxavg_s(i,k,j)*dt
7841             b(k) = 1 + rdz_w*(rdz_u(i,k+1,j)*xkxavg_s(i,k+1,j)+rdz_u(i,k,j)*xkxavg_s(i,k,j))*dt
7842             c(k) = -rdz_w*rdz_u(i,k+1,j)*xkxavg_s(i,k+1,j)*dt
7843             d(k) = -rdz_w*(xkxavg_m(i,k+1,j)-xkxavg_m(i,k,j))*dt*gamuavg(i,j) + u_2(i,k,j)
7844           ENDDO
7845
7846             a(ktf) = 0.
7847             b(ktf) = 1.
7848             c(ktf) = 0.
7849             d(ktf) = u_2(i,ktf,j)
7850
7851          CALL tridiag(nz,a,b,c,d)
7852
7853          DO k=kts,ktf
7854             ru_tendf(i,k,j) = ru_tendf(i,k,j) + muavg_u(i,k,j) * (d(k) - u_2(i,k,j))/dt
7855          ENDDO
7856
7857        ENDDO
7858        ENDDO
7859
7860 !!============================================
7861 !! v
7862 !!============================================
7863    ktf=MIN(kte,kde-1)
7864
7865    i_start = its
7866    i_end   = MIN(ite,ide-1)
7867    j_start = jts
7868    j_end   = jte
7869
7870    IF ( config_flags%open_xs .or. config_flags%specified .or. &
7871         config_flags%nested) i_start = MAX(ids+1,its)
7872    IF ( config_flags%open_xe .or. config_flags%specified .or. &
7873         config_flags%nested) i_end   = MIN(ide-2,ite)
7874    IF ( config_flags%open_ys .or. config_flags%specified .or. &
7875         config_flags%nested) j_start = MAX(jds+1,jts)
7876    IF ( config_flags%open_ye .or. config_flags%specified .or. &
7877         config_flags%nested) j_end   = MIN(jde-1,jte)
7878       IF ( config_flags%periodic_x ) i_start = its
7879       IF ( config_flags%periodic_x ) i_end = MIN(ite,ide-1)
7880
7881     DO j = j_start, j_end
7882     DO k = kts+1, ktf
7883     DO i = i_start, i_end
7884       rhoavg_v        = 0.5 * ( fnm(k) * ( rho(i,k  ,j) + rho(i,k,j-1) ) +       &
7885                                 fnp(k) * ( rho(i,k-1,j) + rho(i,k-1,j-1) ) )
7886       xkxavg_m(i,k,j) = 0.5 * rhoavg_v *                                         &
7887                        ( fnm(k) * ( xkmv_meso(i,k  ,j) + xkmv_meso(i,k,j-1) ) +  &
7888                          fnp(k) * ( xkmv_meso(i,k-1,j) + xkmv_meso(i,k-1,j-1) ) )
7889       xkxavg_s(i,k,j) = 0.5 * rhoavg_v *                                         &
7890                        ( fnm(k) * ( xkmv(i,k  ,j) + xkmv(i,k,j-1) ) +            &
7891                          fnp(k) * ( xkmv(i,k-1,j) + xkmv(i,k-1,j-1) ) )
7892     END DO
7893     END DO
7894     END DO
7895
7896     DO j = j_start, j_end
7897     DO i = i_start, i_end
7898         xkxavg_m(i,kts,  j) = 0.0
7899         xkxavg_m(i,ktf+1,j) = 0.0
7900         xkxavg_s(i,kts,  j) = 0.0
7901         xkxavg_s(i,ktf+1,j) = 0.0
7902     END DO
7903     END DO
7904
7905     DO j = j_start, j_end
7906     DO i = i_start, i_end
7907       gamvavg(i,j) = 0.5 * ( gamv(i,j) + gamv(i,j-1) )
7908     END DO
7909     END DO
7910
7911     DO j = j_start, j_end
7912     DO k = kts, ktf
7913     DO i = i_start, i_end
7914        muavg_v(i,k,j) = 0.5 * ( (c1h(k)*mu(i,j)+c2h(k)) + (c1h(k)*mu(i,j-1)+c2h(k)) )
7915     END DO
7916     END DO
7917     END DO
7918
7919     DO j = j_start, j_end
7920     DO k = kts, ktf
7921     DO i = i_start, i_end
7922         rdz_v(i,k,j) = 2./( 1./rdz(i,k,j) +  1./rdz(i,k,j-1))
7923     ENDDO
7924     ENDDO
7925     ENDDO
7926
7927     DO j = j_start, jte
7928     DO i = i_start, i_end
7929        V0_v = 0.
7930        V0_v =       sqrt((v_2(i,kts,j)**2) +          &
7931                         (((u_2(i  ,kts,j  )+          &
7932                            u_2(i  ,kts,j-1)+          &
7933                            u_2(i+1,kts,j  )+          &
7934                            u_2(i+1,kts,j-1))/4)**2))+epsilon
7935        ustar = 0.5*(ust(i,j)+ust(i,j-1))
7936        tao_yz(i,j) = ustar*ustar*(rho(i,kts,j)+rho(i,kts,j-1))/(2.*V0_v)
7937     ENDDO
7938     ENDDO
7939
7940        nz = ktf
7941
7942        DO  j = j_start, j_end
7943        DO  i = i_start, i_end
7944             k = kts
7945             rdz_w = -g/(dnw(k))/muavg_v(i,k,j)
7946             a(k) = 0.
7947             b(k) = 1. + rdz_w*(rdz_v(i,k+1,j)*xkxavg_s(i,k+1,j)+tao_yz(i,j))*dt
7948             c(k) =     -rdz_w* rdz_v(i,k+1,j)*xkxavg_s(i,k+1,j)*dt
7949             d(k) = v_2(i,kts,j)
7950
7951          DO  k = kts+1,ktf-1
7952             rdz_w = -g/(dnw(k))/muavg_v(i,k,j)
7953             a(k) = -rdz_w*rdz_v(i,k,j)*xkxavg_s(i,k,j)*dt
7954             b(k) = 1. + rdz_w*(rdz_v(i,k+1,j)*xkxavg_s(i,k+1,j)+rdz_v(i,k,j)*xkxavg_s(i,k,j))*dt
7955             c(k) = -rdz_w*rdz_v(i,k+1,j)*xkxavg_s(i,k+1,j)*dt
7956             d(k) = -rdz_w*(xkxavg_m(i,k+1,j)-xkxavg_m(i,k,j))*dt*gamvavg(i,j) + v_2(i,k,j)
7957           ENDDO
7958
7959             a(ktf) = 0.
7960             b(ktf) = 1.
7961             c(ktf) = 0.
7962             d(ktf) = v_2(i,ktf,j)
7963
7964          CALL tridiag(nz,a,b,c,d)
7965
7966          DO k=kts,ktf
7967             rv_tendf(i,k,j) = rv_tendf(i,k,j) + muavg_v(i,k,j) * (d(k) - v_2(i,k,j))/dt
7968          ENDDO
7969
7970        ENDDO
7971        ENDDO
7972
7973 !!============================================
7974 !! w
7975 !!============================================
7976    ktf=MIN(kte,kde-1)
7977
7978    i_start = its
7979    i_end   = MIN(ite,ide-1)
7980    j_start = jts
7981    j_end   = MIN(jte,jde-1)
7982
7983    IF ( config_flags%open_xs .or. config_flags%specified .or. &
7984         config_flags%nested) i_start = MAX(ids+1,its)
7985    IF ( config_flags%open_xe .or. config_flags%specified .or. &
7986         config_flags%nested) i_end   = MIN(ide-2,ite)
7987    IF ( config_flags%open_ys .or. config_flags%specified .or. &
7988         config_flags%nested) j_start = MAX(jds+1,jts)
7989    IF ( config_flags%open_ye .or. config_flags%specified .or. &
7990         config_flags%nested) j_end   = MIN(jde-2,jte)
7991       IF ( config_flags%periodic_x ) i_start = its
7992       IF ( config_flags%periodic_x ) i_end = MIN(ite,ide-1)
7993
7994     nz = ktf-1
7995
7996        DO j = j_start, j_end
7997        DO k = kts, ktf
7998        DO i = i_start, i_end
7999            xkxavg_w(i,k,j) = xkmh(i,k,j)*rho(i,k,j)
8000        ENDDO
8001        ENDDO
8002        ENDDO
8003
8004        DO  j = j_start, j_end
8005        DO  i = i_start, i_end
8006
8007           DO  k = kts+1,ktf
8008             rdz_z = -g/dn(k)/(c1f(k)*mu(i,j) + c2f(k))
8009             a1(k-1) =    - rdz_z* rdzw(i,k-1,j)*xkxavg_w(i,k-1,j)*dt
8010             b1(k-1) = 1. + rdz_z*(rdzw(i,k  ,j)*xkxavg_w(i,k,j)+rdzw(i,k-1,j)*xkxavg_w(i,k-1,j))*dt
8011             c1(k-1) =    - rdz_z* rdzw(i,k  ,j)*xkxavg_w(i,k,j)*dt
8012             d1(k-1) = w_2(i,k,j)
8013           ENDDO
8014
8015           CALL tridiag(nz,a1,b1,c1,d1)
8016
8017           DO k = kts+1,ktf
8018              rw_tendf(i,k,j) = rw_tendf(i,k,j) + (c1f(k)*mu(i,j) + c2f(k)) * (d1(k-1)-w_2(i,k,j))/dt
8019           ENDDO
8020
8021        ENDDO
8022        ENDDO
8023
8024 !!============================================
8025 !! th
8026 !!============================================
8027    ktf=MIN(kte,kde-1)
8028
8029    i_start = its
8030    i_end   = MIN(ite,ide-1)
8031    j_start = jts
8032    j_end   = MIN(jte,jde-1)
8033
8034    IF ( config_flags%open_xs .or. config_flags%specified .or. &
8035         config_flags%nested) i_start = MAX(ids+1,its)
8036    IF ( config_flags%open_xe .or. config_flags%specified .or. &
8037         config_flags%nested) i_end   = MIN(ide-2,ite)
8038    IF ( config_flags%open_ys .or. config_flags%specified .or. &
8039         config_flags%nested) j_start = MAX(jds+1,jts)
8040    IF ( config_flags%open_ye .or. config_flags%specified .or. &
8041         config_flags%nested) j_end   = MIN(jde-2,jte)
8042       IF ( config_flags%periodic_x ) i_start = its
8043       IF ( config_flags%periodic_x ) i_end = MIN(ite,ide-1)
8044
8045    IF ( config_flags%mix_full_fields ) THEN
8046      DO j = jts,min(jte,jde-1)
8047      DO k = kts,kte-1
8048      DO i = its,min(ite,ide-1)
8049        var_mix(i,k,j) = thp(i,k,j)
8050      ENDDO
8051      ENDDO
8052      ENDDO
8053    ELSE
8054      DO j = jts,min(jte,jde-1)
8055      DO k = kts,kte-1
8056      DO i = its,min(ite,ide-1)
8057        var_mix(i,k,j) = thp(i,k,j) - t_base(k)
8058      ENDDO
8059      ENDDO
8060      ENDDO
8061    END IF
8062
8063      DO j = j_start, j_end
8064      DO k = kts+1,ktf
8065      DO i = i_start, i_end
8066          xkxavg(i,k,j) = (fnm(k)*xkhv(i,k,j)+fnp(k)*xkhv(i,k-1,j)) * &
8067                          (fnm(k)*rho (i,k,j)+fnp(k)*rho (i,k-1,j))
8068      ENDDO
8069      ENDDO
8070      ENDDO
8071
8072      DO j = j_start, j_end
8073      DO k = kts+1,ktf
8074      DO i = i_start, i_end
8075         nlflux_rho(i,k,j) = nlflux(i,k,j) * &
8076                            (fnm(k)*rho (i,k,j)+fnp(k)*rho (i,k-1,j))
8077      ENDDO
8078      ENDDO
8079      ENDDO
8080
8081      DO j = j_start, j_end
8082      DO i = i_start, i_end
8083          xkxavg(i,kts  ,j) = 0.0
8084          xkxavg(i,ktf+1,j) = 0.0
8085      ENDDO
8086      ENDDO
8087
8088     nz = ktf
8089
8090   hflux: SELECT CASE( config_flags%isfflx )
8091   CASE (0,2) ! with fixed surface heat flux given in the namelist
8092     heat_flux = config_flags%tke_heat_flux  ! constant heat flux value
8093                                             ! set in namelist.input
8094     DO j = j_start, j_end
8095     DO i = i_start, i_end
8096        cpm = cp * (1. + 0.8 * moist(i,kts,j,P_QV))
8097        hfx(i,j)=heat_flux*cpm*rho(i,1,j)
8098     ENDDO
8099     ENDDO
8100
8101   CASE (1) ! use surface heat flux computed from surface routine
8102     ! do nothing
8103   CASE DEFAULT
8104     CALL wrf_error_fatal( 'isfflx value invalid for diff_opt=2' )
8105   END SELECT hflux
8106
8107     DO  j = j_start, j_end
8108     DO  i = i_start, i_end
8109             cpm = cp * (1. + 0.8 * moist(i,kts,j,P_QV))
8110             k = kts
8111             rdz_w = -g/dnw(k)/(c1h(k)*mu(i,j) + c2h(k))
8112             a(k) = 0.
8113             b(k) = 1. + rdz_w*(rdz(i,k+1,j)*xkxavg(i,k+1,j))*dt
8114             c(k) =    - rdz_w* rdz(i,k+1,j)*xkxavg(i,k+1,j) *dt
8115
8116           IF(config_flags%use_theta_m == 0)THEN
8117              d(k) = var_mix(i,kts,j)                    &
8118                   - dt*rdz_w*nlflux_rho(i,k+1,j)        &
8119                   + dt*rdz_w*hfx(i,j)/cpm
8120           ELSE
8121              qfac = 1.+rvovrd*moist(i,kts,j,P_QV)
8122              d(k) = var_mix(i,kts,j)                    &
8123                   - dt*rdz_w*nlflux_rho(i,k+1,j)*qfac   &
8124                   + dt*rdz_w*(qfac*hfx(i,j)/cpm+1.61*theta(i,kts,j)*qfx(i,j))
8125           ENDIF
8126
8127           IF(config_flags%use_theta_m == 1)THEN
8128               qfac = 1.+rvovrd*moist(i,kts,j,P_QV)
8129           ELSE
8130               qfac = 1.
8131           ENDIF
8132           DO  k = kts+1, ktf-1
8133             rdz_w = -g/dnw(k)/(c1h(k)*mu(i,j) + c2h(k))
8134             a(k)  = -rdz_w*rdz(i,k,j)*xkxavg(i,k,j)*dt
8135             b(k)  = 1.+rdz_w*(rdz(i,k+1,j)*xkxavg(i,k+1,j)+rdz(i,k,j)*xkxavg(i,k,j))*dt
8136             c(k)  = -rdz_w*rdz(i,k+1,j)*xkxavg(i,k+1,j)*dt
8137             d(k)  = -rdz_w*(nlflux_rho(i,k+1,j)-nlflux_rho(i,k,j))*qfac*dt + var_mix(i,k,j)
8138           ENDDO
8139
8140             a(ktf) = 0.
8141             b(ktf) = 1.
8142             c(ktf) = 0.
8143             d(ktf) = var_mix(i,ktf,j)
8144
8145           CALL tridiag(nz,a,b,c,d)
8146
8147           DO k = kts, ktf
8148              rt_tendf(i,k,j) = rt_tendf(i,k,j) + (c1h(k)*mu(i,j) + c2h(k)) * (d(k) - var_mix(i,k,j))/dt
8149           ENDDO
8150
8151        ENDDO
8152        ENDDO
8153
8154 !!============================================
8155 !! tke(including implicit treatments of vertical diffusion and disspation)
8156 !!============================================
8157     DO j = j_start, j_end
8158     DO k = kts+1, ktf
8159     DO i = i_start, i_end
8160         xkxavg(i,k,j) = ( fnm(k) * xkhv(i,k,j) + fnp(k) * xkhv(i,k-1,j) ) &
8161                        *( fnm(k) * rho (i,k,j) + fnp(k) * rho (i,k-1,j) )
8162     END DO
8163     END DO
8164     END DO
8165
8166     DO j = j_start, j_end
8167     DO i = i_start, i_end
8168         xkxavg(i,kts,  j) = 0.0
8169         xkxavg(i,ktf+1,j) = 0.0
8170     END DO
8171     END DO
8172
8173     nz = ktf
8174
8175     DO  j = j_start, j_end
8176     DO  i = i_start, i_end
8177         DO  k = kts, ktf-1
8178            rdz_w = - g/dnw(k)/(c1h(k)*mu(i,j)+c2h(k))
8179            IF (l_diss(i,k,j) .ne. 0) THEN
8180                beta  =   1.5*sqrt(tke(i,k,j))/l_diss(i,k,j)
8181            ELSE
8182                beta  =   0.
8183            ENDIF
8184            a(k)  = - 2.0*xkxavg(i,k,j)*dt*rdz_w*rdz(i,k,j)
8185            b(k)  =   1.0 + 2.0*dt*rdz_w*(rdz(i,k,j)*xkxavg(i,k,j)    &
8186                    + rdz(i,k+1,j)*xkxavg(i,k+1,j))                   &
8187                    + dt*beta
8188            c(k)  = - 2.0*xkxavg(i,k+1,j)*dt*rdz(i,k+1,j)*rdz_w
8189
8190            d(k)  =   tke(i,k,j)
8191            IF (l_diss(i,k,j) .ne. 0) THEN
8192                d(k) = d(k) + 0.5*dt*tke(i,k,j)**1.5/l_diss(i,k,j)
8193            ENDIF
8194         ENDDO
8195
8196            a(ktf) = 0. !-1
8197            b(ktf) = 1.
8198            c(ktf) = 0.
8199            d(ktf) = 0.
8200
8201        CALL tridiag(nz,a,b,c,d)
8202
8203         DO k = kts,ktf
8204            tke_tendf(i,k,j) = tke_tendf(i,k,j) + (c1h(k)*mu(i,j)+c2h(k)) * (d(k)-tke(i,k,j))/dt
8205         ENDDO
8206
8207     ENDDO
8208     ENDDO
8209
8210 !!============================================
8211 !! moisture
8212 !!============================================
8213     DO j = j_start, j_end
8214     DO k = kts+1,ktf
8215     DO i = i_start, i_end
8216        xkxavg(i,k,j) = ( fnm(k) * xkhv(i,k,j) + fnp(k) * xkhv(i,k-1,j) ) &
8217                       *( fnm(k) * rho (i,k,j) + fnp(k) * rho (i,k-1,j) )
8218     ENDDO
8219     ENDDO
8220     ENDDO
8221
8222     DO j = j_start, j_end
8223     DO i = i_start, i_end
8224         xkxavg(i,kts,  j) = 0.0
8225         xkxavg(i,ktf+1,j) = 0.0
8226     END DO
8227     END DO
8228
8229    IF (n_moist .ge. PARAM_FIRST_SCALAR) THEN
8230      moist_loop: do im = PARAM_FIRST_SCALAR, n_moist
8231        IF ( (.not. config_flags%mix_full_fields) .and. (im == P_QV) ) THEN
8232          DO j = jts,min(jte,jde-1)
8233          DO k = kts,kte-1
8234          DO i = its,min(ite,ide-1)
8235           var_mix(i,k,j) = moist(i,k,j,im) - qv_base(k)
8236          ENDDO
8237          ENDDO
8238          ENDDO
8239        ELSE
8240          DO j = jts,min(jte,jde-1)
8241          DO k = kts,kte-1
8242          DO i = its,min(ite,ide-1)
8243           var_mix(i,k,j) = moist(i,k,j,im)
8244          ENDDO
8245          ENDDO
8246          ENDDO
8247        END IF
8248
8249     nz = ktf
8250 !!
8251     IF ( im == P_QV ) THEN
8252          DO  j = j_start, j_end
8253          DO  i = i_start, i_end
8254              k = kts
8255              rdz_w = -g/dnw(k)/(c1h(k)*mu(i,j)+c2h(k))
8256              a(k) = 0.
8257              b(k) = 1.+rdz_w*(rdz(i,k+1,j)*xkxavg(i,k+1,j))*dt
8258              c(k) =   -rdz_w* rdz(i,k+1,j)*xkxavg(i,k+1,j) *dt
8259 !            d(k) = var_mix(i,k,j) + dt*rdz_w*qfx(i,j)/(1.+moist(i,k,j,P_QV))   !??
8260              d(k) = var_mix(i,k,j) + dt*rdz_w*qfx(i,j)
8261
8262            DO  k = kts+1,ktf-1
8263              rdz_w = -g/dnw(k)/(c1h(k)*mu(i,j)+c2h(k))
8264              a(k) = -rdz_w*rdz(i,k,j)*xkxavg(i,k,j)*dt
8265              b(k) = 1.+rdz_w*(rdz(i,k+1,j)*xkxavg(i,k+1,j)+rdz(i,k,j)*xkxavg(i,k,j))*dt
8266              c(k) = -rdz_w*rdz(i,k+1,j)*xkxavg(i,k+1,j)*dt
8267              d(k) = var_mix(i,k,j)
8268            ENDDO
8269
8270              a(ktf) = 0.
8271              b(ktf) = 1.
8272              c(ktf) = 0.
8273              d(ktf) = var_mix(i,ktf,j)
8274
8275              CALL tridiag(nz,a,b,c,d)
8276
8277            DO k = kts, ktf
8278              moist_tendf(i,k,j,im) = moist_tendf(i,k,j,im) + (c1h(k)*mu(i,j)+c2h(k)) * (d(k)-var_mix(i,k,j))/dt
8279            ENDDO
8280
8281          ENDDO
8282          ENDDO
8283     ENDIF
8284 !!
8285     IF ( im /= P_QV ) THEN
8286          DO  j = j_start, j_end
8287          DO  i = i_start, i_end
8288              k = kts
8289              rdz_w = -g/dnw(k)/(c1h(k)*mu(i,j)+c2h(k))
8290              a(k) = 0.
8291              b(k) = 1.+rdz_w*(rdz(i,k+1,j)*xkxavg(i,k+1,j))*dt
8292              c(k) =   -rdz_w* rdz(i,k+1,j)*xkxavg(i,k+1,j)*dt
8293              d(k) = var_mix(i,k,j)
8294
8295            DO  k = kts+1,ktf-1
8296              rdz_w = -g/dnw(k)/(c1h(k)*mu(i,j)+c2h(k))
8297              a(k) = -rdz_w*rdz(i,k,j)*xkxavg(i,k,j)*dt
8298              b(k) = 1.+rdz_w*(rdz(i,k+1,j)*xkxavg(i,k+1,j)+rdz(i,k,j)*xkxavg(i,k,j))*dt
8299              c(k) = -rdz_w*rdz(i,k+1,j)*xkxavg(i,k+1,j)*dt
8300              d(k) = var_mix(i,k,j)
8301            ENDDO
8302
8303              a(ktf) = 0.
8304              b(ktf) = 1.
8305              c(ktf) = 0.
8306              d(ktf) = var_mix(i,ktf,j)
8307
8308              CALL tridiag(nz,a,b,c,d)
8309
8310            DO k = kts, ktf
8311               moist_tendf(i,k,j,im) = moist_tendf(i,k,j,im) + (c1h(k)*mu(i,j)+c2h(k)) * (d(k)-var_mix(i,k,j))/dt
8312            ENDDO
8313          ENDDO
8314          ENDDO
8315     ENDIF
8316
8317      ENDDO moist_loop
8318    ENDIF
8319
8320 !!============================================
8321 !! scalar
8322 !!============================================
8323     DO j = j_start, j_end
8324     DO k = kts+1, ktf
8325     DO i = i_start, i_end
8326         xkxavg(i,k,j) = ( fnm(k) * xkhv(i,k,j) + fnp(k) * xkhv(i,k-1,j) ) &
8327                        *( fnm(k) * rho (i,k,j) + fnp(k) * rho (i,k-1,j) )
8328     ENDDO
8329     ENDDO
8330     ENDDO
8331
8332     DO j = j_start, j_end
8333     DO i = i_start, i_end
8334         xkxavg(i,kts  ,j) = 0.0
8335         xkxavg(i,ktf+1,j) = 0.0
8336     END DO
8337     END DO
8338
8339    IF (n_scalar .ge. PARAM_FIRST_SCALAR) THEN
8340      scalar_loop: do im = PARAM_FIRST_SCALAR, n_scalar
8341 ! need to avoid mixing scalars associated with precipitating species (e.g. Nr)
8342     IF(im.NE.P_QNS .AND. im.NE.P_QNR .AND. im.NE.P_QNG .AND. im.NE.P_QNH .AND. &
8343        im.NE.P_QT .AND. im.NE.P_QVOLG) THEN
8344          DO j = jts, min(jte,jde-1)
8345          DO k = kts, kte-1
8346          DO i = its, min(ite,ide-1)
8347           var_mix(i,k,j) = scalar(i,k,j,im)
8348          ENDDO
8349          ENDDO
8350          ENDDO
8351
8352          DO  j = j_start, j_end
8353          DO  i = i_start, i_end
8354              k = kts
8355              rdz_w = -g/dnw(k)/(c1h(k)*mu(i,j)+c2h(k))
8356              a(k) = 0.
8357              b(k) = 1.+rdz_w*(rdz(i,k+1,j)*xkxavg(i,k+1,j))*dt
8358              c(k) =   -rdz_w* rdz(i,k+1,j)*xkxavg(i,k+1,j)*dt
8359              d(k) = var_mix(i,k,j)
8360
8361            DO  k = kts+1, ktf-1
8362              rdz_w = -g/dnw(k)/(c1h(k)*mu(i,j)+c2h(k))
8363              a(k)  = -rdz_w*rdz(i,k,j)*xkxavg(i,k,j)*dt
8364              b(k)  = 1.+rdz_w*(rdz(i,k+1,j)*xkxavg(i,k+1,j)+rdz(i,k,j)*xkxavg(i,k,j))*dt
8365              c(k)  = -rdz_w*rdz(i,k+1,j)*xkxavg(i,k+1,j)*dt
8366              d(k)  = var_mix(i,k,j)
8367            ENDDO
8368
8369              a(ktf) = 0.
8370              b(ktf) = 1.
8371              c(ktf) = 0.
8372              d(ktf) = var_mix(i,ktf,j)
8373
8374              CALL tridiag(nz,a,b,c,d)
8375
8376            DO  k = kts, ktf
8377              scalar_tendf(i,k,j,im) = scalar_tendf(i,k,j,im) + (c1h(k)*mu(i,j)+c2h(k)) * (d(k)-var_mix(i,k,j))/dt
8378            ENDDO
8379         ENDDO
8380         ENDDO
8381      ENDIF
8382      ENDDO scalar_loop
8383    ENDIF
8384
8385 !!============================================
8386 !! tracer
8387 !!============================================
8388    IF (n_tracer .ge. PARAM_FIRST_SCALAR) THEN
8389      tracer_loop: do im = PARAM_FIRST_SCALAR, n_tracer
8390          DO j = jts, min(jte,jde-1)
8391          DO k = kts, kte-1
8392          DO i = its, min(ite,ide-1)
8393           var_mix(i,k,j) = tracer(i,k,j,im)
8394          ENDDO
8395          ENDDO
8396          ENDDO
8397
8398          DO  j = j_start, j_end
8399          DO  i = i_start, i_end
8400              k = kts
8401              rdz_w = -g/dnw(k)/(c1h(k)*mu(i,j)+c2h(k))
8402              a(k) = 0.
8403              b(k) = 1.+rdz_w*(rdz(i,k+1,j)*xkxavg(i,k+1,j))*dt
8404              c(k) =   -rdz_w* rdz(i,k+1,j)*xkxavg(i,k+1,j)*dt
8405              d(k) = var_mix(i,kts,j)
8406
8407            DO  k = kts+1,ktf-1
8408              rdz_w = -g/dnw(k)/(c1h(k)*mu(i,j)+c2h(k))
8409              a(k) = -rdz_w*rdz(i,k,j)*xkxavg(i,k,j)*dt
8410              b(k) = 1.+rdz_w*(rdz(i,k+1,j)*xkxavg(i,k+1,j)+rdz(i,k,j)*xkxavg(i,k,j))*dt
8411              c(k) = -rdz_w*rdz(i,k+1,j)*xkxavg(i,k+1,j)*dt
8412              d(k) = var_mix(i,k,j)
8413            ENDDO
8414
8415              a(ktf) = 0.
8416              b(ktf) = 1.
8417              c(ktf) = 0.
8418              d(ktf) = var_mix(i,ktf,j)
8419
8420              CALL tridiag(nz,a,b,c,d)
8421
8422            DO k = kts, ktf
8423              tracer_tendf(i,k,j,im) = tracer_tendf(i,k,j,im) + (c1h(k)*mu(i,j)+c2h(k)) * (d(k) - var_mix(i,k,j))/dt
8424            ENDDO
8425          ENDDO
8426          ENDDO
8427      ENDDO tracer_loop
8428    ENDIF
8429
8430 !!============================================
8431 !! chemistry
8432 !!============================================
8433    IF (n_chem .ge. PARAM_FIRST_SCALAR) THEN
8434      chem_loop: do im = PARAM_FIRST_SCALAR, n_chem
8435          DO j = jts,min(jte,jde-1)
8436          DO k = kts,kte-1
8437          DO i = its,min(ite,ide-1)
8438           var_mix(i,k,j) = chem(i,k,j,im)
8439          ENDDO
8440          ENDDO
8441          ENDDO
8442
8443         DO  j = j_start, j_end
8444         DO  i = i_start, i_end
8445             k = kts
8446             rdz_w = -g/dnw(k)/(c1h(k)*mu(i,j)+c2h(k))
8447             a(k) = 0.
8448             b(k) = 1.+rdz_w*(rdz(i,k+1,j)*xkxavg(i,k+1,j))*dt
8449             c(k) =   -rdz_w* rdz(i,k+1,j)*xkxavg(i,k+1,j)*dt
8450             d(k) = var_mix(i,kts,j)
8451
8452           DO  k = kts+1,ktf-1
8453             rdz_w = -g/dnw(k)/(c1h(k)*mu(i,j)+c2h(k))
8454             a(k) = -rdz_w*rdz(i,k,j)*xkxavg(i,k,j)*dt
8455             b(k) = 1.+rdz_w*(rdz(i,k+1,j)*xkxavg(i,k+1,j)+rdz(i,k,j)*xkxavg(i,k,j))*dt
8456             c(k) = -rdz_w*rdz(i,k+1,j)*xkxavg(i,k+1,j)*dt
8457             d(k) = var_mix(i,k,j)
8458           ENDDO
8459
8460             a(ktf) = 0.
8461             b(ktf) = 1.
8462             c(ktf) = 0.
8463             d(ktf) = var_mix(i,ktf,j)
8464
8465             CALL tridiag(nz,a,b,c,d)
8466
8467           DO k = kts, ktf
8468              chem_tendf(i,k,j,im) = chem_tendf(i,k,j,im) + (c1h(k)*mu(i,j)+c2h(k)) * (d(k) - var_mix(i,k,j))/dt
8469           ENDDO
8470         ENDDO
8471         ENDDO
8472      ENDDO chem_loop
8473    ENDIF
8474
8475     END SUBROUTINE vertical_diffusion_implicit
8476
8477 !=======================================================================
8478 !=======================================================================
8479     END MODULE module_diffusion_em
8480
8481 !=======================================================================
8482 !=======================================================================